    -- | 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
      { FrontendSession -> Window
    swindow          :: SDL.Window
      , FrontendSession -> Renderer
    srenderer        :: SDL.Renderer
      , FrontendSession -> Font
    squareFont       :: TTF.Font
      , FrontendSession -> Int
    squareFontSize   :: Int
      , FrontendSession -> Bool
    mapFontIsBitmap  :: Bool
      , FrontendSession -> Maybe Font
    spropFont        :: Maybe TTF.Font
      , FrontendSession -> Maybe Font
    sboldFont        :: Maybe TTF.Font
      , FrontendSession -> Maybe Font
    smonoFont        :: Maybe TTF.Font
      , FrontendSession -> IORef FontAtlas
    squareAtlas      :: IORef FontAtlas
      , FrontendSession -> IORef FontAtlas
    smonoAtlas       :: IORef FontAtlas
      , FrontendSession -> IORef Texture
    sbasicTexture    :: IORef SDL.Texture
      , FrontendSession -> IORef Texture
    stexture         :: IORef SDL.Texture
      , FrontendSession -> IORef SingleFrame
    spreviousFrame   :: IORef SingleFrame
      , FrontendSession -> IORef Bool
    sforcedShutdown  :: IORef Bool
      , FrontendSession -> IORef Bool
    scontinueSdlLoop :: IORef Bool
      , FrontendSession -> MVar SingleFrame
    sframeQueue      :: MVar SingleFrame
      , FrontendSession -> MVar ()
    sframeDrawn      :: MVar ()
      }

    -- | The name of the frontend.
    frontendName :: String
    frontendName :: FilePath
    frontendName = FilePath
    "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 :: ScreenContent -> ClientOptions -> IO RawFrontend
    startup ScreenContent
    coscreen ClientOptions
    soptions = (MVar RawFrontend -> IO ()) -> IO RawFrontend
    startupBound ((MVar RawFrontend -> IO ()) -> IO RawFrontend)
    -> (MVar RawFrontend -> IO ()) -> IO RawFrontend
    forall a b. (a -> b) -> a -> b
    $ ScreenContent -> ClientOptions -> MVar RawFrontend -> IO ()
    startupFun ScreenContent
    coscreen ClientOptions
    soptions

    startupFun :: ScreenContent -> ClientOptions -> MVar RawFrontend -> IO ()
    startupFun :: ScreenContent -> ClientOptions -> MVar RawFrontend -> IO ()
    startupFun ScreenContent
    coscreen soptions :: ClientOptions
    soptions@ClientOptions{Bool
    FilePath
    [(Text, FontSet)]
    [(Text, FontDefinition)]
    Maybe Bool
    Maybe Double
    Maybe Int
    Maybe FilePath
    Maybe Text
    Maybe FullscreenMode
    schosenFontset :: Maybe Text
    sallFontsScale :: Maybe Double
    sfonts :: [(Text, FontDefinition)]
    sfontsets :: [(Text, FontSet)]
    sfullscreenMode :: Maybe FullscreenMode
    slogPriority :: Maybe Int
    smaxFps :: Maybe Double
    sdisableAutoYes :: Bool
    snoAnim :: Maybe Bool
    snewGameCli :: Bool
    sbenchmark :: Bool
    sbenchMessages :: Bool
    stitle :: Maybe FilePath
    ssavePrefixCli :: FilePath
    sfrontendANSI :: Bool
    sfrontendTeletype :: Bool
    sfrontendNull :: Bool
    sfrontendLazy :: Bool
    sdbgMsgCli :: Bool
    sstopAfterSeconds :: Maybe Int
    sstopAfterFrames :: Maybe Int
    sprintEachScreen :: Bool
    sexposePlaces :: Bool
    sexposeItems :: Bool
    sexposeActors :: Bool
    sexposeActors :: ClientOptions -> Bool
    sexposeItems :: ClientOptions -> Bool
    sexposePlaces :: ClientOptions -> Bool
    sprintEachScreen :: ClientOptions -> Bool
    sstopAfterFrames :: ClientOptions -> Maybe Int
    sstopAfterSeconds :: ClientOptions -> Maybe Int
    sdbgMsgCli :: ClientOptions -> Bool
    sfrontendLazy :: ClientOptions -> Bool
    sfrontendNull :: ClientOptions -> Bool
    sfrontendTeletype :: ClientOptions -> Bool
    sfrontendANSI :: ClientOptions -> Bool
    ssavePrefixCli :: ClientOptions -> FilePath
    stitle :: ClientOptions -> Maybe FilePath
    sbenchMessages :: ClientOptions -> Bool
    sbenchmark :: ClientOptions -> Bool
    snewGameCli :: ClientOptions -> Bool
    snoAnim :: ClientOptions -> Maybe Bool
    sdisableAutoYes :: ClientOptions -> Bool
    smaxFps :: ClientOptions -> Maybe Double
    slogPriority :: ClientOptions -> Maybe Int
    sfullscreenMode :: ClientOptions -> Maybe FullscreenMode
    sfontsets :: ClientOptions -> [(Text, FontSet)]
    sfonts :: ClientOptions -> [(Text, FontDefinition)]
    sallFontsScale :: ClientOptions -> Maybe Double
    schosenFontset :: ClientOptions -> Maybe Text
    ..} MVar RawFrontend
    rfMVar = do
     [InitFlag] -> IO ()
    forall (f :: * -> *) (m :: * -> *).
    (Foldable f, Functor m, MonadIO m) =>
    f InitFlag -> m ()
    SDL.initialize [InitFlag
    SDL.InitEvents]
     -- lowest: pattern SDL_LOG_PRIORITY_VERBOSE = (1) :: LogPriority
     -- our default: pattern SDL_LOG_PRIORITY_ERROR = (5) :: LogPriority
     Word32 -> IO ()
    forall (m :: * -> *). MonadIO m => Word32 -> m ()
    SDL.logSetAllPriority (Word32 -> IO ()) -> Word32 -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Int -> Word32
    forall a. Enum a => Int -> a
    toEnum (Int -> Word32) -> Int -> Word32
    forall a b. (a -> b) -> a -> b
    $ Int -> Maybe Int -> Int
    forall a. a -> Maybe a -> a
    fromMaybe Int
    5 Maybe Int
    slogPriority
     IO ()
    forall (m :: * -> *). MonadIO m => m ()
    TTF.initialize
     let title :: Text
    title = FilePath -> Text
    T.pack (FilePath -> Text) -> FilePath -> Text
    forall a b. (a -> b) -> a -> b
    $ Maybe FilePath -> FilePath
    forall a. HasCallStack => Maybe a -> a
    fromJust Maybe FilePath
    stitle
         chosenFontsetID :: Text
    chosenFontsetID = Maybe Text -> Text
    forall a. HasCallStack => Maybe a -> a
    fromJust Maybe Text
    schosenFontset
     -- Unlike @error@, @die@ does not move savefiles aside.
     chosenFontset <- case Text -> [(Text, FontSet)] -> Maybe FontSet
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup Text
    chosenFontsetID [(Text, FontSet)]
    sfontsets of
       Maybe FontSet
    Nothing -> FilePath -> IO FontSet
    forall a. FilePath -> IO a
    die (FilePath -> IO FontSet) -> FilePath -> IO FontSet
    forall a b. (a -> b) -> a -> b
    $ FilePath
    "Fontset not defined in config file"
                        FilePath -> Text -> FilePath
    forall v. Show v => FilePath -> v -> FilePath
    `showFailure` Text
    chosenFontsetID
       Just FontSet
    fs -> FontSet -> IO FontSet
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return FontSet
    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 Text
    t =
           if Text -> Bool
    T.null Text
    t
           then Maybe (Font, Int) -> IO (Maybe (Font, Int))
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe (Font, Int)
    forall a. Maybe a
    Nothing
           else case Text -> [(Text, FontDefinition)] -> Maybe FontDefinition
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup Text
    t [(Text, FontDefinition)]
    sfonts of
             Maybe FontDefinition
    Nothing -> FilePath -> IO (Maybe (Font, Int))
    forall a. FilePath -> IO a
    die (FilePath -> IO (Maybe (Font, Int)))
    -> FilePath -> IO (Maybe (Font, Int))
    forall a b. (a -> b) -> a -> b
    $ FilePath
    "Font not defined in config file" FilePath -> Text -> FilePath
    forall v. Show v => FilePath -> v -> FilePath
    `showFailure` Text
    t
             Just (FontProportional Text
    fname Int
    fsize HintingMode
    fhint) -> do
               sdlFont <- Text -> Int -> IO Font
    loadFontFile Text
    fname Int
    fsize
               setHintMode sdlFont fhint
               -- TODO: when SDL_ttf can do it, check that not a bitmap font
               realSize <- TTF.height sdlFont
               let !_A = Bool -> () -> ()
    forall a. HasCallStack => Bool -> a -> a
    assert (Int
    realSize Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int
    0) ()  -- sanity
               return $ Just (sdlFont, realSize)
             Just (FontMonospace Text
    fname Int
    fsize HintingMode
    fhint) -> do
               sdlFont <- Text -> Int -> IO Font
    loadFontFile Text
    fname Int
    fsize
               setHintMode sdlFont fhint
               isFontMono <- TTF.isMonospace sdlFont
               realSize <- TTF.height sdlFont
               let !_A = Bool -> () -> ()
    forall a. HasCallStack => Bool -> a -> a
    assert (Bool
    isFontMono Bool -> Bool -> Bool
    && Int
    realSize Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int
    0) ()  -- sanity
               return $ Just (sdlFont, realSize)
             Just (FontMapScalable Text
    fname Int
    fsize HintingMode
    fhint Int
    cellSizeAdd) -> do
               sdlFont <- Text -> Int -> IO Font
    loadFontFile Text
    fname Int
    fsize
               setHintMode sdlFont fhint
               isFontMono <- TTF.isMonospace sdlFont
               realSize <- TTF.height sdlFont
               let !_A = Bool -> () -> ()
    forall a. HasCallStack => Bool -> a -> a
    assert (Bool
    isFontMono Bool -> Bool -> Bool
    && Int
    realSize Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int
    0) ()  -- sanity
               return $ Just (sdlFont, realSize + cellSizeAdd)
             Just (FontMapBitmap Text
    fname Int
    cellSizeAdd) -> do
               sdlFont <- Text -> Int -> IO Font
    loadFontFile Text
    fname Int
    0  -- size ignored for bitmap fonts
               isFontMono <- TTF.isMonospace sdlFont
               realSize <- TTF.height sdlFont
               let !_A = Bool -> () -> ()
    forall a. HasCallStack => Bool -> a -> a
    assert (Bool
    isFontMono Bool -> Bool -> Bool
    && Int
    realSize Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int
    0) ()  -- sanity
               return $ Just (sdlFont, realSize + cellSizeAdd)
         loadFontFile Text
    fname Int
    fsize = do
           let fontFileName :: FilePath
    fontFileName = Text -> FilePath
    T.unpack Text
    fname
               fontSize :: Int
    fontSize = Double -> Int
    forall b. Integral b => Double -> b
    forall a b. (RealFrac a, Integral b) => a -> b
    round (Double -> Int) -> Double -> Int
    forall a b. (a -> b) -> a -> b
    $ Maybe Double -> Double
    forall a. HasCallStack => Maybe a -> a
    fromJust Maybe Double
    sallFontsScale Double -> Double -> Double
    forall a. Num a => a -> a -> a
    * Int -> Double
    intToDouble Int
    fsize
           if FilePath -> Bool
    isRelative FilePath
    fontFileName
           then do
             case FilePath -> [(FilePath, ByteString)] -> Maybe ByteString
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup FilePath
    fontFileName ([(FilePath, ByteString)] -> Maybe ByteString)
    -> [(FilePath, ByteString)] -> Maybe ByteString
    forall a b. (a -> b) -> a -> b
    $ ScreenContent -> [(FilePath, ByteString)]
    rFontFiles ScreenContent
    coscreen of
               Maybe ByteString
    Nothing -> FilePath -> IO Font
    forall a. FilePath -> IO a
    forall (m :: * -> *) a. MonadFail m => FilePath -> m a
    fail (FilePath -> IO Font) -> FilePath -> IO Font
    forall a b. (a -> b) -> a -> b
    $ FilePath
    "Font file not supplied with the game: "
                                 FilePath -> FilePath -> FilePath
    forall a. [a] -> [a] -> [a]
    ++ FilePath
    fontFileName
                                 FilePath -> FilePath -> FilePath
    forall a. [a] -> [a] -> [a]
    ++ FilePath
    " within "
                                 FilePath -> FilePath -> FilePath
    forall a. [a] -> [a] -> [a]
    ++ [FilePath] -> FilePath
    forall a. Show a => a -> FilePath
    show (((FilePath, ByteString) -> FilePath)
    -> [(FilePath, ByteString)] -> [FilePath]
    forall a b. (a -> b) -> [a] -> [b]
    map (FilePath, ByteString) -> FilePath
    forall a b. (a, b) -> a
    fst ([(FilePath, ByteString)] -> [FilePath])
    -> [(FilePath, ByteString)] -> [FilePath]
    forall a b. (a -> b) -> a -> b
    $ ScreenContent -> [(FilePath, ByteString)]
    rFontFiles ScreenContent
    coscreen)
               Just ByteString
    bs -> ByteString -> Int -> IO Font
    forall (m :: * -> *). MonadIO m => ByteString -> Int -> m Font
    TTF.decode ByteString
    bs Int
    fontSize
           else do
             fontFileExists <- FilePath -> IO Bool
    doesFileExist FilePath
    fontFileName
             if not fontFileExists
             then fail $ "Font file does not exist: " ++ fontFileName
             else TTF.load fontFileName fontSize
         setHintMode Font
    _ HintingMode
    HintingHeavy = () -> m ()
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()  -- default
         setHintMode Font
    sdlFont HintingMode
    HintingLight = Font -> Hinting -> m ()
    forall (m :: * -> *). MonadIO m => Font -> Hinting -> m ()
    TTF.setHinting Font
    sdlFont Hinting
    TTF.Light
     (squareFont, squareFontSize, mapFontIsBitmap) <-
       if fromJust sallFontsScale == 1.0 then do
         mfontMapBitmap <- findFontFile $ fontMapBitmap chosenFontset
         case mfontMapBitmap of
           Just (Font
    sdlFont, Int
    size) -> (Font, Int, Bool) -> IO (Font, Int, Bool)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Font
    sdlFont, Int
    size, Bool
    True)
           Maybe (Font, Int)
    Nothing -> do
             mfontMapScalable <- Text -> IO (Maybe (Font, Int))
    findFontFile (Text -> IO (Maybe (Font, Int))) -> Text -> IO (Maybe (Font, Int))
    forall a b. (a -> b) -> a -> b
    $ FontSet -> Text
    fontMapScalable FontSet
    chosenFontset
             case mfontMapScalable of
               Just (Font
    sdlFont, Int
    size) -> (Font, Int, Bool) -> IO (Font, Int, Bool)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Font
    sdlFont, Int
    size, Bool
    False)
               Maybe (Font, Int)
    Nothing -> FilePath -> IO (Font, Int, Bool)
    forall a. FilePath -> IO a
    die FilePath
    "Neither bitmap nor scalable map font defined"
       else do
         mfontMapScalable <- findFontFile $ fontMapScalable chosenFontset
         case mfontMapScalable of
            Just (Font
    sdlFont, Int
    size) -> (Font, Int, Bool) -> IO (Font, Int, Bool)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Font
    sdlFont, Int
    size, Bool
    False)
            Maybe (Font, Int)
    Nothing -> FilePath -> IO (Font, Int, Bool)
    forall a. FilePath -> IO a
    die FilePath
    "Scaling requested but scalable map font not defined"
     let halfSize = Int
    squareFontSize Int -> Int -> Int
    forall a. Integral a => a -> a -> a
    `div` Int
    2
         boxSize = Int
    2 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    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 =
           Bool -> () -> ()
    forall a. HasCallStack => Bool -> a -> a
    assert
             (Maybe Font -> Bool
    forall a. Maybe a -> Bool
    isJust Maybe Font
    spropFont Bool -> Bool -> Bool
    && Maybe Font -> Bool
    forall a. Maybe a -> Bool
    isJust Maybe Font
    sboldFont Bool -> Bool -> Bool
    && Maybe Font -> Bool
    forall a. Maybe a -> Bool
    isJust Maybe Font
    smonoFont
              Bool -> Bool -> Bool
    || Maybe Font -> Bool
    forall a. Maybe a -> Bool
    isNothing Maybe Font
    spropFont Bool -> Bool -> Bool
    && Maybe Font -> Bool
    forall a. Maybe a -> Bool
    isNothing Maybe Font
    sboldFont Bool -> Bool -> Bool
    && Maybe Font -> Bool
    forall a. Maybe a -> Bool
    isNothing Maybe Font
    smonoFont
              Bool -> (FilePath, FontSet) -> Bool
    forall v. Show v => Bool -> v -> Bool
    `blame` FilePath
    "Either all auxiliary fonts should be defined or none"
              FilePath -> FontSet -> (FilePath, FontSet)
    forall v. FilePath -> v -> (FilePath, v)
    `swith` FontSet
    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 (\SingleFrame
    _ -> () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    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 = CInt -> CInt -> V2 CInt
    forall a. a -> a -> V2 a
    SDL.V2 (Int -> CInt
    forall a. Enum a => Int -> a
    toEnum (Int -> CInt) -> Int -> CInt
    forall a b. (a -> b) -> a -> b
    $ ScreenContent -> Int
    rwidth ScreenContent
    coscreen Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    boxSize)
                            (Int -> CInt
    forall a. Enum a => Int -> a
    toEnum (Int -> CInt) -> Int -> CInt
    forall a b. (a -> b) -> a -> b
    $ ScreenContent -> Int
    rheight ScreenContent
    coscreen Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    boxSize)
          windowConfig = WindowConfig
    SDL.defaultWindow
            { SDL.windowInitialSize = screenV2
            , SDL.windowMode = case fromMaybe NotFullscreen sfullscreenMode of
                FullscreenMode
    ModeChange -> WindowMode
    SDL.Fullscreen
                FullscreenMode
    BigBorderlessWindow -> WindowMode
    SDL.FullscreenDesktop
                FullscreenMode
    NotFullscreen -> WindowMode
    SDL.Windowed
            , SDL.windowResizable = False  -- the default, but just in case...
            , SDL.windowHighDPI = True  -- possibly prevents resize for Retina
            }
          rendererConfig = SDL.RendererConfig
            { rendererType :: RendererType
    rendererType          = if Bool
    sbenchmark
                                      then RendererType
    SDL.AcceleratedRenderer
                                      else RendererType
    SDL.AcceleratedVSyncRenderer
            , rendererTargetTexture :: Bool
    rendererTargetTexture = Bool
    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.
            Renderer -> StateVar (Maybe Texture)
    SDL.rendererRenderTarget Renderer
    srenderer StateVar (Maybe Texture) -> Maybe Texture -> IO ()
    forall t a (m :: * -> *).
    (HasSetter t a, MonadIO m) =>
    t -> a -> m ()
    forall (m :: * -> *).
    MonadIO m =>
    StateVar (Maybe Texture) -> Maybe Texture -> m ()
    SDL.$= Maybe Texture
    forall a. Maybe a
    Nothing
            Renderer -> IO ()
    forall (m :: * -> *). (Functor m, MonadIO m) => Renderer -> m ()
    SDL.clear Renderer
    srenderer  -- clear the backbuffer
            Renderer -> IO ()
    forall (m :: * -> *). MonadIO m => Renderer -> m ()
    SDL.present Renderer
    srenderer
            Renderer -> IO ()
    forall (m :: * -> *). (Functor m, MonadIO m) => Renderer -> m ()
    SDL.clear Renderer
    srenderer  -- clear the other half of the double buffer?
            Renderer -> IO ()
    forall (m :: * -> *). MonadIO m => Renderer -> m ()
    SDL.present Renderer
    srenderer
      clearScreen
      let initTexture = do
            texture <- Renderer -> PixelFormat -> TextureAccess -> V2 CInt -> IO Texture
    forall (m :: * -> *).
    (Functor m, MonadIO m) =>
    Renderer -> PixelFormat -> TextureAccess -> V2 CInt -> m Texture
    SDL.createTexture Renderer
    srenderer PixelFormat
    SDL.ARGB8888
                                         TextureAccess
    SDL.TextureAccessTarget V2 CInt
    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{Bool
    Int
    Maybe Font
    MVar ()
    MVar SingleFrame
    IORef Bool
    IORef FontAtlas
    IORef Texture
    IORef SingleFrame
    Renderer
    Window
    Font
    swindow :: Window
    srenderer :: Renderer
    squareFont :: Font
    squareFontSize :: Int
    mapFontIsBitmap :: Bool
    spropFont :: Maybe Font
    sboldFont :: Maybe Font
    smonoFont :: Maybe Font
    squareAtlas :: IORef FontAtlas
    smonoAtlas :: IORef FontAtlas
    sbasicTexture :: IORef Texture
    stexture :: IORef Texture
    spreviousFrame :: IORef SingleFrame
    sforcedShutdown :: IORef Bool
    scontinueSdlLoop :: IORef Bool
    sframeQueue :: MVar SingleFrame
    sframeDrawn :: MVar ()
    squareFont :: Font
    squareFontSize :: Int
    mapFontIsBitmap :: Bool
    spropFont :: Maybe Font
    sboldFont :: Maybe Font
    smonoFont :: Maybe Font
    swindow :: Window
    srenderer :: Renderer
    sbasicTexture :: IORef Texture
    stexture :: IORef Texture
    squareAtlas :: IORef FontAtlas
    smonoAtlas :: IORef FontAtlas
    spreviousFrame :: IORef SingleFrame
    sforcedShutdown :: IORef Bool
    scontinueSdlLoop :: IORef Bool
    sframeQueue :: MVar SingleFrame
    sframeDrawn :: MVar ()
    ..}
      rfWithoutPrintScreen <-
        createRawFrontend coscreen (display sess) (shutdown sess)
      let rf = RawFrontend
    rfWithoutPrintScreen {fprintScreen = printScreen sess}
      putMVar rfMVar rf
      let pointTranslate :: forall i. (Enum i) => Vect.Point Vect.V2 i -> PointUI
          pointTranslate (SDL.P (SDL.V2 i
    x i
    y)) =
            Int -> Int -> PointUI
    PointUI (i -> Int
    forall a. Enum a => a -> Int
    fromEnum i
    x Int -> Int -> Int
    forall a. Integral a => a -> a -> a
    `div` Int
    halfSize) (i -> Int
    forall a. Enum a => a -> Int
    fromEnum i
    y Int -> Int -> Int
    forall a. Integral a => a -> a -> a
    `div` Int
    boxSize)
          redraw = do
            -- Textures may be trashed and even invalid, especially on Windows.
            atlas <- IORef FontAtlas -> IO FontAtlas
    forall a. IORef a -> IO a
    readIORef IORef FontAtlas
    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 <- IO (Maybe Event)
    forall (m :: * -> *). MonadIO m => m (Maybe Event)
    SDL.pollEvent  -- events take precedence over frames
            case me of
              Maybe Event
    Nothing -> do
                mfr <- MVar SingleFrame -> IO (Maybe SingleFrame)
    forall a. MVar a -> IO (Maybe a)
    tryTakeMVar MVar SingleFrame
    sframeQueue
                case mfr of
                  Just SingleFrame
    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.
                    ScreenContent
    -> ClientOptions -> FrontendSession -> SingleFrame -> IO ()
    drawFrame ScreenContent
    coscreen ClientOptions
    soptions FrontendSession
    sess SingleFrame
    fr
                    MVar () -> () -> IO ()
    forall a. MVar a -> a -> IO ()
    putMVar MVar ()
    sframeDrawn ()  -- signal that drawing ended
                  Maybe SingleFrame
    Nothing -> Int -> IO ()
    threadDelay (Int -> IO ()) -> Int -> IO ()
    forall a b. (a -> b) -> a -> b
    $ if Bool
    sbenchmark then Int
    150 else Int
    15000
                               -- 60 polls per second, so keyboard snappy enough;
                               -- max 6000 FPS when benchmarking
              Just Event
    e -> Event -> IO ()
    handleEvent Event
    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 Event
    e = case Event -> EventPayload
    SDL.eventPayload Event
    e of
            SDL.KeyboardEvent KeyboardEventData
    keyboardEvent
              | KeyboardEventData -> InputMotion
    SDL.keyboardEventKeyMotion KeyboardEventData
    keyboardEvent InputMotion -> InputMotion -> Bool
    forall a. Eq a => a -> a -> Bool
    == InputMotion
    SDL.Pressed -> do
                let sym :: Keysym
    sym = KeyboardEventData -> Keysym
    SDL.keyboardEventKeysym KeyboardEventData
    keyboardEvent
                    ksm :: KeyModifier
    ksm = Keysym -> KeyModifier
    SDL.keysymModifier Keysym
    sym
                    shiftPressed :: Bool
    shiftPressed = KeyModifier -> Bool
    SDL.keyModifierLeftShift KeyModifier
    ksm
                                   Bool -> Bool -> Bool
    || KeyModifier -> Bool
    SDL.keyModifierRightShift KeyModifier
    ksm
                    key :: Key
    key = Bool -> Keycode -> Key
    keyTranslate Bool
    shiftPressed (Keycode -> Key) -> Keycode -> Key
    forall a b. (a -> b) -> a -> b
    $ Keysym -> Keycode
    SDL.keysymKeycode Keysym
    sym
                    modifier :: Modifier
    modifier = KeyModifier -> Modifier
    modTranslate KeyModifier
    ksm
                    modifierNoShift :: Modifier
    modifierNoShift = case Modifier
    modifier of  -- to prevent S-!, etc.
                      Modifier
    K.Shift -> Modifier
    K.NoModifier
                      Modifier
    K.ControlShift -> Modifier
    K.Control
                      Modifier
    K.AltShift -> Modifier
    K.Alt
                      Modifier
    _ -> Modifier
    modifier
                p <- IO (Point V2 CInt)
    forall (m :: * -> *). MonadIO m => m (Point V2 CInt)
    SDL.getAbsoluteMouseLocation
                when (key == K.Esc) $ resetChanKey (fchanKey rf)
                saveKMP rf modifierNoShift key (pointTranslate p)
            SDL.MouseButtonEvent MouseButtonEventData
    mouseButtonEvent
              | MouseButtonEventData -> InputMotion
    SDL.mouseButtonEventMotion MouseButtonEventData
    mouseButtonEvent InputMotion -> InputMotion -> Bool
    forall a. Eq a => a -> a -> Bool
    == InputMotion
    SDL.Released -> do
                modifier <- KeyModifier -> Modifier
    modTranslate (KeyModifier -> Modifier) -> IO KeyModifier -> IO Modifier
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> IO KeyModifier
    forall (m :: * -> *). (Functor m, MonadIO m) => m KeyModifier
    SDL.getModState
                let key = case MouseButtonEventData -> MouseButton
    SDL.mouseButtonEventButton MouseButtonEventData
    mouseButtonEvent of
                      MouseButton
    SDL.ButtonLeft -> Key
    K.LeftButtonRelease
                      MouseButton
    SDL.ButtonMiddle -> Key
    K.MiddleButtonRelease
                      MouseButton
    SDL.ButtonRight -> Key
    K.RightButtonRelease
                      MouseButton
    _ -> Key
    K.LeftButtonRelease  -- any other is spare left
                    p = MouseButtonEventData -> Point V2 Int32
    SDL.mouseButtonEventPos MouseButtonEventData
    mouseButtonEvent
                saveKMP rf modifier key (pointTranslate p)
            SDL.MouseWheelEvent MouseWheelEventData
    mouseWheelEvent -> do
              modifier <- KeyModifier -> Modifier
    modTranslate (KeyModifier -> Modifier) -> IO KeyModifier -> IO Modifier
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> IO KeyModifier
    forall (m :: * -> *). (Functor m, MonadIO m) => m KeyModifier
    SDL.getModState
              let SDL.V2 _ y = SDL.mouseWheelEventPos mouseWheelEvent
                  mkey = case (Int32 -> Int32 -> Ordering
    forall a. Ord a => a -> a -> Ordering
    compare Int32
    y Int32
    0, MouseWheelEventData -> MouseScrollDirection
    SDL.mouseWheelEventDirection
                                              MouseWheelEventData
    mouseWheelEvent) of
                    (Ordering
    EQ, MouseScrollDirection
    _) -> Maybe Key
    forall a. Maybe a
    Nothing
                    (Ordering
    LT, MouseScrollDirection
    SDL.ScrollNormal) -> Key -> Maybe Key
    forall a. a -> Maybe a
    Just Key
    K.WheelSouth
                    (Ordering
    GT, MouseScrollDirection
    SDL.ScrollNormal) -> Key -> Maybe Key
    forall a. a -> Maybe a
    Just Key
    K.WheelNorth
                    (Ordering
    LT, MouseScrollDirection
    SDL.ScrollFlipped) -> Key -> Maybe Key
    forall a. a -> Maybe a
    Just Key
    K.WheelNorth
                    (Ordering
    GT, MouseScrollDirection
    SDL.ScrollFlipped) -> Key -> Maybe Key
    forall a. a -> Maybe a
    Just Key
    K.WheelSouth
              p <- SDL.getAbsoluteMouseLocation
              maybe (return ())
                    (\Key
    key -> RawFrontend -> Modifier -> Key -> PointUI -> IO ()
    saveKMP RawFrontend
    rf Modifier
    modifier Key
    key (Point V2 CInt -> PointUI
    forall i. Enum i => Point V2 i -> PointUI
    pointTranslate Point V2 CInt
    p)) mkey
            SDL.WindowClosedEvent{} -> FrontendSession -> IO ()
    forceShutdown FrontendSession
    sess
            EventPayload
    SDL.QuitEvent -> FrontendSession -> IO ()
    forceShutdown FrontendSession
    sess
            SDL.WindowRestoredEvent{} -> IO ()
    redraw  -- e.g., unminimize
            SDL.WindowExposedEvent{} -> IO ()
    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."
              IO ()
    redraw
            -- Probably not needed, because no textures nor their content lost:
            -- SDL.WindowShownEvent{} -> redraw
            EventPayload
    _ -> () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    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 :: forall (m :: * -> *).
    MonadIO m =>
    Vector Word8
    -> Vector Word8 -> V2 CInt -> Point V2 CInt -> m Cursor
    createCursor Vector Word8
    dta Vector Word8
    msk (Vect.V2 CInt
    w CInt
    h) (Vect.P (Vect.V2 CInt
    hx CInt
    hy)) =
        IO Cursor -> m Cursor
    forall a. IO a -> m a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO Cursor -> m Cursor)
    -> (IO (Ptr ()) -> IO Cursor) -> IO (Ptr ()) -> m Cursor
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Ptr () -> Cursor) -> IO (Ptr ()) -> IO Cursor
    forall a b. (a -> b) -> IO a -> IO b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap Ptr () -> Cursor
    forall a b. a -> b
    unsafeCoerce (IO (Ptr ()) -> m Cursor) -> IO (Ptr ()) -> m Cursor
    forall a b. (a -> b) -> a -> b
    $
            Text -> Text -> IO (Ptr ()) -> IO (Ptr ())
    forall (m :: * -> *) a.
    MonadIO m =>
    Text -> Text -> m (Ptr a) -> m (Ptr a)
    throwIfNull Text
    "SDL.Input.Mouse.createCursor" Text
    "SDL_createCursor" (IO (Ptr ()) -> IO (Ptr ())) -> IO (Ptr ()) -> IO (Ptr ())
    forall a b. (a -> b) -> a -> b
    $
                Vector Word8 -> (Ptr Word8 -> IO (Ptr ())) -> IO (Ptr ())
    forall a b. Storable a => Vector a -> (Ptr a -> IO b) -> IO b
    VS.unsafeWith Vector Word8
    dta ((Ptr Word8 -> IO (Ptr ())) -> IO (Ptr ()))
    -> (Ptr Word8 -> IO (Ptr ())) -> IO (Ptr ())
    forall a b. (a -> b) -> a -> b
    $ \Ptr Word8
    unsafeDta ->
                Vector Word8 -> (Ptr Word8 -> IO (Ptr ())) -> IO (Ptr ())
    forall a b. Storable a => Vector a -> (Ptr a -> IO b) -> IO b
    VS.unsafeWith Vector Word8
    msk ((Ptr Word8 -> IO (Ptr ())) -> IO (Ptr ()))
    -> (Ptr Word8 -> IO (Ptr ())) -> IO (Ptr ())
    forall a b. (a -> b) -> a -> b
    $ \Ptr Word8
    unsafeMsk ->
                    Ptr Word8
    -> Ptr Word8 -> CInt -> CInt -> CInt -> CInt -> IO (Ptr ())
    forall (m :: * -> *).
    MonadIO m =>
    Ptr Word8
    -> Ptr Word8 -> CInt -> CInt -> CInt -> CInt -> m (Ptr ())
    Raw.createCursor Ptr Word8
    unsafeDta Ptr Word8
    unsafeMsk CInt
    w CInt
    h CInt
    hx CInt
    hy

    -- Ignores bits after the last 8 multiple.
    boolListToWord8List :: [Bool] -> [Word8]
    boolListToWord8List :: [Bool] -> [Word8]
    boolListToWord8List =
      let i :: Bool -> p -> p
    i Bool
    True p
    multiple = p
    multiple
          i Bool
    False p
    _ = p
    0
      in \case
        Bool
    b1 : Bool
    b2 : Bool
    b3 : Bool
    b4 : Bool
    b5 : Bool
    b6 : Bool
    b7 : Bool
    b8 : [Bool]
    rest ->
          Bool -> Word8 -> Word8
    forall {p}. Num p => Bool -> p -> p
    i Bool
    b1 Word8
    128 Word8 -> Word8 -> Word8
    forall a. Num a => a -> a -> a
    + Bool -> Word8 -> Word8
    forall {p}. Num p => Bool -> p -> p
    i Bool
    b2 Word8
    64 Word8 -> Word8 -> Word8
    forall a. Num a => a -> a -> a
    + Bool -> Word8 -> Word8
    forall {p}. Num p => Bool -> p -> p
    i Bool
    b3 Word8
    32 Word8 -> Word8 -> Word8
    forall a. Num a => a -> a -> a
    + Bool -> Word8 -> Word8
    forall {p}. Num p => Bool -> p -> p
    i Bool
    b4 Word8
    16 Word8 -> Word8 -> Word8
    forall a. Num a => a -> a -> a
    + Bool -> Word8 -> Word8
    forall {p}. Num p => Bool -> p -> p
    i Bool
    b5 Word8
    8 Word8 -> Word8 -> Word8
    forall a. Num a => a -> a -> a
    + Bool -> Word8 -> Word8
    forall {p}. Num p => Bool -> p -> p
    i Bool
    b6 Word8
    4 Word8 -> Word8 -> Word8
    forall a. Num a => a -> a -> a
    + Bool -> Word8 -> Word8
    forall {p}. Num p => Bool -> p -> p
    i Bool
    b7 Word8
    2 Word8 -> Word8 -> Word8
    forall a. Num a => a -> a -> a
    + Bool -> Word8 -> Word8
    forall {p}. Num p => Bool -> p -> p
    i Bool
    b8 Word8
    1
          Word8 -> [Word8] -> [Word8]
    forall a. a -> [a] -> [a]
    : [Bool] -> [Word8]
    boolListToWord8List [Bool]
    rest
        [Bool]
    _ -> []

    cursorXhair :: (VS.Vector Word8, VS.Vector Word8)  -- alpha, BW
    cursorXhair :: (Vector Word8, Vector Word8)
    cursorXhair =
      let charToBool :: Char -> (Bool, Bool)
    charToBool Char
    '.' = (Bool
    True, Bool
    True)  -- visible black
          charToBool Char
    '#' = (Bool
    True, Bool
    False)  -- visible white
          charToBool Char
    _ = (Bool
    False, Bool
    False)  -- transparent white
          toVS :: [Bool] -> Vector Word8
    toVS = [Word8] -> Vector Word8
    forall a. Storable a => [a] -> Vector a
    VS.fromList ([Word8] -> Vector Word8)
    -> ([Bool] -> [Word8]) -> [Bool] -> Vector Word8
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [Bool] -> [Word8]
    boolListToWord8List
      in [Bool] -> Vector Word8
    toVS ([Bool] -> Vector Word8)
    -> ([Bool] -> Vector Word8)
    -> ([Bool], [Bool])
    -> (Vector Word8, Vector Word8)
    forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
    forall (a :: * -> * -> *) b c b' c'.
    Arrow a =>
    a b c -> a b' c' -> a (b, b') (c, c')
    *** [Bool] -> Vector Word8
    toVS (([Bool], [Bool]) -> (Vector Word8, Vector Word8))
    -> ([Bool], [Bool]) -> (Vector Word8, Vector Word8)
    forall a b. (a -> b) -> a -> b
    $ [(Bool, Bool)] -> ([Bool], [Bool])
    forall a b. [(a, b)] -> ([a], [b])
    unzip ([(Bool, Bool)] -> ([Bool], [Bool]))
    -> [(Bool, Bool)] -> ([Bool], [Bool])
    forall a b. (a -> b) -> a -> b
    $ (Char -> (Bool, Bool)) -> FilePath -> [(Bool, Bool)]
    forall a b. (a -> b) -> [a] -> [b]
    map Char -> (Bool, Bool)
    charToBool (FilePath -> [(Bool, Bool)]) -> FilePath -> [(Bool, Bool)]
    forall a b. (a -> b) -> a -> b
    $ [FilePath] -> FilePath
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat

        [ FilePath
    "            ...                 "
        , FilePath
    "            .#.                 "
        , FilePath
    "        ..  .#.  ..             "
        , FilePath
    "      ..##  .#.  ##..           "
        , FilePath
    "     .##    .#.    ##.          "
        , FilePath
    "    .#      .#.      #.         "
        , FilePath
    "   .#       .#.       #.        "
        , FilePath
    "   .#       ...       #.        "
        , FilePath
    "  .#                   #.       "
        , FilePath
    "  .#                   #.       "
        , FilePath
    "                                "
        , FilePath
    "             .                  "
        , FilePath
    "........    .#.    ........     "
        , FilePath
    ".######.   .###.   .######.     "
        , FilePath
    "........    .#.    ........     "
        , FilePath
    "             .                  "
        , FilePath
    "                                "
        , FilePath
    "  .#                   #.       "
        , FilePath
    "  .#                   #.       "
        , FilePath
    "   .#       ...       #.        "
        , FilePath
    "   .#       .#.       #.        "
        , FilePath
    "    .#      .#.      #.         "
        , FilePath
    "     .##    .#.    ##.          "
        , FilePath
    "      ..##  .#.  ##..           "
        , FilePath
    "        ..  .#.  ..             "
        , FilePath
    "            .#.                 "
        , FilePath
    "            ...                 " ]

    shutdown :: FrontendSession -> IO ()
    shutdown :: FrontendSession -> IO ()
    shutdown FrontendSession{Bool
    Int
    Maybe Font
    MVar ()
    MVar SingleFrame
    IORef Bool
    IORef FontAtlas
    IORef Texture
    IORef SingleFrame
    Renderer
    Window
    Font
    swindow :: FrontendSession -> Window
    srenderer :: FrontendSession -> Renderer
    squareFont :: FrontendSession -> Font
    squareFontSize :: FrontendSession -> Int
    mapFontIsBitmap :: FrontendSession -> Bool
    spropFont :: FrontendSession -> Maybe Font
    sboldFont :: FrontendSession -> Maybe Font
    smonoFont :: FrontendSession -> Maybe Font
    squareAtlas :: FrontendSession -> IORef FontAtlas
    smonoAtlas :: FrontendSession -> IORef FontAtlas
    sbasicTexture :: FrontendSession -> IORef Texture
    stexture :: FrontendSession -> IORef Texture
    spreviousFrame :: FrontendSession -> IORef SingleFrame
    sforcedShutdown :: FrontendSession -> IORef Bool
    scontinueSdlLoop :: FrontendSession -> IORef Bool
    sframeQueue :: FrontendSession -> MVar SingleFrame
    sframeDrawn :: FrontendSession -> MVar ()
    swindow :: Window
    srenderer :: Renderer
    squareFont :: Font
    squareFontSize :: Int
    mapFontIsBitmap :: Bool
    spropFont :: Maybe Font
    sboldFont :: Maybe Font
    smonoFont :: Maybe Font
    squareAtlas :: IORef FontAtlas
    smonoAtlas :: IORef FontAtlas
    sbasicTexture :: IORef Texture
    stexture :: IORef Texture
    spreviousFrame :: IORef SingleFrame
    sforcedShutdown :: IORef Bool
    scontinueSdlLoop :: IORef Bool
    sframeQueue :: MVar SingleFrame
    sframeDrawn :: MVar ()
    ..} = IORef Bool -> Bool -> IO ()
    forall a. IORef a -> a -> IO ()
    writeIORef IORef Bool
    scontinueSdlLoop Bool
    False

    forceShutdown :: FrontendSession -> IO ()
    forceShutdown :: FrontendSession -> IO ()
    forceShutdown sess :: FrontendSession
    sess@FrontendSession{Bool
    Int
    Maybe Font
    MVar ()
    MVar SingleFrame
    IORef Bool
    IORef FontAtlas
    IORef Texture
    IORef SingleFrame
    Renderer
    Window
    Font
    swindow :: FrontendSession -> Window
    srenderer :: FrontendSession -> Renderer
    squareFont :: FrontendSession -> Font
    squareFontSize :: FrontendSession -> Int
    mapFontIsBitmap :: FrontendSession -> Bool
    spropFont :: FrontendSession -> Maybe Font
    sboldFont :: FrontendSession -> Maybe Font
    smonoFont :: FrontendSession -> Maybe Font
    squareAtlas :: FrontendSession -> IORef FontAtlas
    smonoAtlas :: FrontendSession -> IORef FontAtlas
    sbasicTexture :: FrontendSession -> IORef Texture
    stexture :: FrontendSession -> IORef Texture
    spreviousFrame :: FrontendSession -> IORef SingleFrame
    sforcedShutdown :: FrontendSession -> IORef Bool
    scontinueSdlLoop :: FrontendSession -> IORef Bool
    sframeQueue :: FrontendSession -> MVar SingleFrame
    sframeDrawn :: FrontendSession -> MVar ()
    swindow :: Window
    srenderer :: Renderer
    squareFont :: Font
    squareFontSize :: Int
    mapFontIsBitmap :: Bool
    spropFont :: Maybe Font
    sboldFont :: Maybe Font
    smonoFont :: Maybe Font
    squareAtlas :: IORef FontAtlas
    smonoAtlas :: IORef FontAtlas
    sbasicTexture :: IORef Texture
    stexture :: IORef Texture
    spreviousFrame :: IORef SingleFrame
    sforcedShutdown :: IORef Bool
    scontinueSdlLoop :: IORef Bool
    sframeQueue :: MVar SingleFrame
    sframeDrawn :: MVar ()
    ..} = do
      IORef Bool -> Bool -> IO ()
    forall a. IORef a -> a -> IO ()
    writeIORef IORef Bool
    sforcedShutdown Bool
    True
      FrontendSession -> IO ()
    shutdown FrontendSession
    sess

    -- | Add a frame to be drawn.
    display :: FrontendSession  -- ^ frontend session data
            -> SingleFrame      -- ^ the screen frame to draw
            -> IO ()
    display :: FrontendSession -> SingleFrame -> IO ()
    display FrontendSession{Bool
    Int
    Maybe Font
    MVar ()
    MVar SingleFrame
    IORef Bool
    IORef FontAtlas
    IORef Texture
    IORef SingleFrame
    Renderer
    Window
    Font
    swindow :: FrontendSession -> Window
    srenderer :: FrontendSession -> Renderer
    squareFont :: FrontendSession -> Font
    squareFontSize :: FrontendSession -> Int
    mapFontIsBitmap :: FrontendSession -> Bool
    spropFont :: FrontendSession -> Maybe Font
    sboldFont :: FrontendSession -> Maybe Font
    smonoFont :: FrontendSession -> Maybe Font
    squareAtlas :: FrontendSession -> IORef FontAtlas
    smonoAtlas :: FrontendSession -> IORef FontAtlas
    sbasicTexture :: FrontendSession -> IORef Texture
    stexture :: FrontendSession -> IORef Texture
    spreviousFrame :: FrontendSession -> IORef SingleFrame
    sforcedShutdown :: FrontendSession -> IORef Bool
    scontinueSdlLoop :: FrontendSession -> IORef Bool
    sframeQueue :: FrontendSession -> MVar SingleFrame
    sframeDrawn :: FrontendSession -> MVar ()
    swindow :: Window
    srenderer :: Renderer
    squareFont :: Font
    squareFontSize :: Int
    mapFontIsBitmap :: Bool
    spropFont :: Maybe Font
    sboldFont :: Maybe Font
    smonoFont :: Maybe Font
    squareAtlas :: IORef FontAtlas
    smonoAtlas :: IORef FontAtlas
    sbasicTexture :: IORef Texture
    stexture :: IORef Texture
    spreviousFrame :: IORef SingleFrame
    sforcedShutdown :: IORef Bool
    scontinueSdlLoop :: IORef Bool
    sframeQueue :: MVar SingleFrame
    sframeDrawn :: MVar ()
    ..} SingleFrame
    curFrame = do
      continueSdlLoop <- IORef Bool -> IO Bool
    forall a. IORef a -> IO a
    readIORef IORef Bool
    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 :: ScreenContent
    -> ClientOptions -> FrontendSession -> SingleFrame -> IO ()
    drawFrame ScreenContent
    coscreen ClientOptions{Bool
    FilePath
    [(Text, FontSet)]
    [(Text, FontDefinition)]
    Maybe Bool
    Maybe Double
    Maybe Int
    Maybe FilePath
    Maybe Text
    Maybe FullscreenMode
    sexposeActors :: ClientOptions -> Bool
    sexposeItems :: ClientOptions -> Bool
    sexposePlaces :: ClientOptions -> Bool
    sprintEachScreen :: ClientOptions -> Bool
    sstopAfterFrames :: ClientOptions -> Maybe Int
    sstopAfterSeconds :: ClientOptions -> Maybe Int
    sdbgMsgCli :: ClientOptions -> Bool
    sfrontendLazy :: ClientOptions -> Bool
    sfrontendNull :: ClientOptions -> Bool
    sfrontendTeletype :: ClientOptions -> Bool
    sfrontendANSI :: ClientOptions -> Bool
    ssavePrefixCli :: ClientOptions -> FilePath
    stitle :: ClientOptions -> Maybe FilePath
    sbenchMessages :: ClientOptions -> Bool
    sbenchmark :: ClientOptions -> Bool
    snewGameCli :: ClientOptions -> Bool
    snoAnim :: ClientOptions -> Maybe Bool
    sdisableAutoYes :: ClientOptions -> Bool
    smaxFps :: ClientOptions -> Maybe Double
    slogPriority :: ClientOptions -> Maybe Int
    sfullscreenMode :: ClientOptions -> Maybe FullscreenMode
    sfontsets :: ClientOptions -> [(Text, FontSet)]
    sfonts :: ClientOptions -> [(Text, FontDefinition)]
    sallFontsScale :: ClientOptions -> Maybe Double
    schosenFontset :: ClientOptions -> Maybe Text
    schosenFontset :: Maybe Text
    sallFontsScale :: Maybe Double
    sfonts :: [(Text, FontDefinition)]
    sfontsets :: [(Text, FontSet)]
    sfullscreenMode :: Maybe FullscreenMode
    slogPriority :: Maybe Int
    smaxFps :: Maybe Double
    sdisableAutoYes :: Bool
    snoAnim :: Maybe Bool
    snewGameCli :: Bool
    sbenchmark :: Bool
    sbenchMessages :: Bool
    stitle :: Maybe FilePath
    ssavePrefixCli :: FilePath
    sfrontendANSI :: Bool
    sfrontendTeletype :: Bool
    sfrontendNull :: Bool
    sfrontendLazy :: Bool
    sdbgMsgCli :: Bool
    sstopAfterSeconds :: Maybe Int
    sstopAfterFrames :: Maybe Int
    sprintEachScreen :: Bool
    sexposePlaces :: Bool
    sexposeItems :: Bool
    sexposeActors :: Bool
    ..} sess :: FrontendSession
    sess@FrontendSession{Bool
    Int
    Maybe Font
    MVar ()
    MVar SingleFrame
    IORef Bool
    IORef FontAtlas
    IORef Texture
    IORef SingleFrame
    Renderer
    Window
    Font
    swindow :: FrontendSession -> Window
    srenderer :: FrontendSession -> Renderer
    squareFont :: FrontendSession -> Font
    squareFontSize :: FrontendSession -> Int
    mapFontIsBitmap :: FrontendSession -> Bool
    spropFont :: FrontendSession -> Maybe Font
    sboldFont :: FrontendSession -> Maybe Font
    smonoFont :: FrontendSession -> Maybe Font
    squareAtlas :: FrontendSession -> IORef FontAtlas
    smonoAtlas :: FrontendSession -> IORef FontAtlas
    sbasicTexture :: FrontendSession -> IORef Texture
    stexture :: FrontendSession -> IORef Texture
    spreviousFrame :: FrontendSession -> IORef SingleFrame
    sforcedShutdown :: FrontendSession -> IORef Bool
    scontinueSdlLoop :: FrontendSession -> IORef Bool
    sframeQueue :: FrontendSession -> MVar SingleFrame
    sframeDrawn :: FrontendSession -> MVar ()
    swindow :: Window
    srenderer :: Renderer
    squareFont :: Font
    squareFontSize :: Int
    mapFontIsBitmap :: Bool
    spropFont :: Maybe Font
    sboldFont :: Maybe Font
    smonoFont :: Maybe Font
    squareAtlas :: IORef FontAtlas
    smonoAtlas :: IORef FontAtlas
    sbasicTexture :: IORef Texture
    stexture :: IORef Texture
    spreviousFrame :: IORef SingleFrame
    sforcedShutdown :: IORef Bool
    scontinueSdlLoop :: IORef Bool
    sframeQueue :: MVar SingleFrame
    sframeDrawn :: MVar ()
    ..} SingleFrame
    curFrame = do
      prevFrame <- IORef SingleFrame -> IO SingleFrame
    forall a. IORef a -> IO a
    readIORef IORef SingleFrame
    spreviousFrame
      let halfSize = Int
    squareFontSize Int -> Int -> Int
    forall a. Integral a => a -> a -> a
    `div` Int
    2
          boxSize = Int
    2 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    halfSize
          tt2Square = CInt -> CInt -> V2 CInt
    forall a. a -> a -> V2 a
    Vect.V2 (Int -> CInt
    forall a. Enum a => Int -> a
    toEnum Int
    boxSize) (Int -> CInt
    forall a. Enum a => Int -> a
    toEnum Int
    boxSize)
          vp :: Int -> Int -> Vect.Point Vect.V2 CInt
          vp Int
    x Int
    y = V2 CInt -> Point V2 CInt
    forall (f :: * -> *) a. f a -> Point f a
    Vect.P (V2 CInt -> Point V2 CInt) -> V2 CInt -> Point V2 CInt
    forall a b. (a -> b) -> a -> b
    $ CInt -> CInt -> V2 CInt
    forall a. a -> a -> V2 a
    Vect.V2 (Int -> CInt
    forall a. Enum a => Int -> a
    toEnum Int
    x) (Int -> CInt
    forall a. Enum a => Int -> a
    toEnum Int
    y)
          drawHighlight !Int
    col !Int
    row !Color
    color = do
            Renderer -> StateVar (V4 Word8)
    SDL.rendererDrawColor Renderer
    srenderer StateVar (V4 Word8) -> V4 Word8 -> IO ()
    forall t a (m :: * -> *).
    (HasSetter t a, MonadIO m) =>
    t -> a -> m ()
    forall (m :: * -> *).
    MonadIO m =>
    StateVar (V4 Word8) -> V4 Word8 -> m ()
    SDL.$= Color -> V4 Word8
    colorToRGBA Color
    color
            let rect :: Rectangle CInt
    rect = Point V2 CInt -> V2 CInt -> Rectangle CInt
    forall a. Point V2 a -> V2 a -> Rectangle a
    SDL.Rectangle (Int -> Int -> Point V2 CInt
    vp (Int
    col Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    boxSize) (Int
    row Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    boxSize)) V2 CInt
    tt2Square
            Renderer -> Maybe (Rectangle CInt) -> IO ()
    forall (m :: * -> *).
    MonadIO m =>
    Renderer -> Maybe (Rectangle CInt) -> m ()
    SDL.drawRect Renderer
    srenderer (Maybe (Rectangle CInt) -> IO ())
    -> Maybe (Rectangle CInt) -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Rectangle CInt -> Maybe (Rectangle CInt)
    forall a. a -> Maybe a
    Just Rectangle CInt
    rect
            Renderer -> StateVar (V4 Word8)
    SDL.rendererDrawColor Renderer
    srenderer StateVar (V4 Word8) -> V4 Word8 -> IO ()
    forall t a (m :: * -> *).
    (HasSetter t a, MonadIO m) =>
    t -> a -> m ()
    forall (m :: * -> *).
    MonadIO m =>
    StateVar (V4 Word8) -> V4 Word8 -> m ()
    SDL.$= V4 Word8
    blackRGBA
              -- reset back to black
          chooseAndDrawHighlight !Int
    col !Int
    row !Highlight
    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 :: IO ()
    workaroundOverwriteHighlight = do
                 let rect :: Rectangle CInt
    rect = Point V2 CInt -> V2 CInt -> Rectangle CInt
    forall a. Point V2 a -> V2 a -> Rectangle a
    SDL.Rectangle (Int -> Int -> Point V2 CInt
    vp (Int
    col Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    boxSize) (Int
    row Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    boxSize))
                                          V2 CInt
    tt2Square
                 Renderer -> Maybe (Rectangle CInt) -> IO ()
    forall (m :: * -> *).
    MonadIO m =>
    Renderer -> Maybe (Rectangle CInt) -> m ()
    SDL.drawRect Renderer
    srenderer (Maybe (Rectangle CInt) -> IO ())
    -> Maybe (Rectangle CInt) -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Rectangle CInt -> Maybe (Rectangle CInt)
    forall a. a -> Maybe a
    Just Rectangle CInt
    rect
           case Highlight
    bg of
            Highlight
    Color.HighlightNone -> IO ()
    workaroundOverwriteHighlight
            Highlight
    Color.HighlightBackground -> IO ()
    workaroundOverwriteHighlight
            Highlight
    Color.HighlightNoneCursor -> IO ()
    workaroundOverwriteHighlight
            Highlight
    _ -> Int -> Int -> Color -> IO ()
    drawHighlight Int
    col Int
    row (Color -> IO ()) -> Color -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Highlight -> Color
    Color.highlightToColor Highlight
    bg
    -- workarounds end
          -- This also frees the surface it gets.
          scaleSurfaceToTexture :: Int -> SDL.Surface -> IO SDL.Texture
          scaleSurfaceToTexture Int
    xsize Surface
    textSurfaceRaw = do
            Vect.V2 sw sh <- Surface -> IO (V2 CInt)
    forall (m :: * -> *). MonadIO m => Surface -> m (V2 CInt)
    SDL.surfaceDimensions Surface
    textSurfaceRaw
            let width = Int -> Int -> Int
    forall a. Ord a => a -> a -> a
    min Int
    xsize (Int -> Int) -> Int -> Int
    forall a b. (a -> b) -> a -> b
    $ CInt -> Int
    forall a. Enum a => a -> Int
    fromEnum CInt
    sw
                height = Int -> Int -> Int
    forall a. Ord a => a -> a -> a
    min Int
    boxSize (Int -> Int) -> Int -> Int
    forall a b. (a -> b) -> a -> b
    $ CInt -> Int
    forall a. Enum a => a -> Int
    fromEnum CInt
    sh
                xsrc = Int -> Int -> Int
    forall a. Ord a => a -> a -> a
    max Int
    0 (CInt -> Int
    forall a. Enum a => a -> Int
    fromEnum CInt
    sw Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    width) Int -> Int -> Int
    forall a. Integral a => a -> a -> a
    `div` Int
    2
                ysrc = Int -> Int -> Int
    forall a. Ord a => a -> a -> a
    max Int
    0 (CInt -> Int
    forall a. Enum a => a -> Int
    fromEnum CInt
    sh Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    height) Int -> Int -> Int
    forall a. Integral a => a -> a -> a
    `divUp` Int
    2
                srcR = Point V2 CInt -> V2 CInt -> Rectangle CInt
    forall a. Point V2 a -> V2 a -> Rectangle a
    SDL.Rectangle (Int -> Int -> Point V2 CInt
    vp Int
    xsrc Int
    ysrc)
                                     (CInt -> CInt -> V2 CInt
    forall a. a -> a -> V2 a
    Vect.V2 (Int -> CInt
    forall a. Enum a => Int -> a
    toEnum Int
    width) (Int -> CInt
    forall a. Enum a => Int -> a
    toEnum Int
    height))
                xtgt = (Int
    xsize Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    width) Int -> Int -> Int
    forall a. Integral a => a -> a -> a
    `divUp` Int
    2
                ytgt = (Int
    boxSize Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    height) Int -> Int -> Int
    forall a. Integral a => a -> a -> a
    `div` Int
    2
                tgtR = Int -> Int -> Point V2 CInt
    vp Int
    xtgt Int
    ytgt
                tt2 = CInt -> CInt -> V2 CInt
    forall a. a -> a -> V2 a
    Vect.V2 (Int -> CInt
    forall a. Enum a => Int -> a
    toEnum Int
    xsize) (Int -> CInt
    forall a. Enum a => Int -> a
    toEnum Int
    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 Int
    x Int
    row Surface
    textSurfaceRaw Bool
    allSpace = do
            Vect.V2 sw sh <- Surface -> IO (V2 CInt)
    forall (m :: * -> *). MonadIO m => Surface -> m (V2 CInt)
    SDL.surfaceDimensions Surface
    textSurfaceRaw
            let widthRaw = CInt -> Int
    forall a. Enum a => a -> Int
    fromEnum CInt
    sw
                remainingWidth = ScreenContent -> Int
    rwidth ScreenContent
    coscreen Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    boxSize Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    x
                width | Int
    widthRaw Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    <= Int
    remainingWidth = Int
    widthRaw
                      | Bool
    allSpace = Int
    remainingWidth
                      | Bool
    otherwise = Int
    remainingWidth Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    boxSize
                height = Int -> Int -> Int
    forall a. Ord a => a -> a -> a
    min Int
    boxSize (Int -> Int) -> Int -> Int
    forall a b. (a -> b) -> a -> b
    $ CInt -> Int
    forall a. Enum a => a -> Int
    fromEnum CInt
    sh
                xsrc = Int
    0
                ysrc = Int -> Int -> Int
    forall a. Ord a => a -> a -> a
    max Int
    0 (CInt -> Int
    forall a. Enum a => a -> Int
    fromEnum CInt
    sh Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    height) Int -> Int -> Int
    forall a. Integral a => a -> a -> a
    `divUp` Int
    2
                srcR = Point V2 CInt -> V2 CInt -> Rectangle CInt
    forall a. Point V2 a -> V2 a -> Rectangle a
    SDL.Rectangle (Int -> Int -> Point V2 CInt
    vp Int
    xsrc Int
    ysrc)
                                     (CInt -> CInt -> V2 CInt
    forall a. a -> a -> V2 a
    Vect.V2 (Int -> CInt
    forall a. Enum a => Int -> a
    toEnum Int
    width) (Int -> CInt
    forall a. Enum a => Int -> a
    toEnum Int
    height))
                xtgt = Int
    0
                ytgt = (Int
    boxSize Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    height) Int -> Int -> Int
    forall a. Integral a => a -> a -> a
    `div` Int
    2
                tgtR = Int -> Int -> Point V2 CInt
    vp Int
    xtgt Int
    ytgt
                tt2Prop = CInt -> CInt -> V2 CInt
    forall a. a -> a -> V2 a
    Vect.V2 (Int -> CInt
    forall a. Enum a => Int -> a
    toEnum Int
    width) (Int -> CInt
    forall a. Enum a => Int -> a
    toEnum Int
    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 !Int
    i (!Word32
    w, !Word32
    wPrev) =
            if Word32
    w Word32 -> Word32 -> Bool
    forall a. Eq a => a -> a -> Bool
    == Word32
    wPrev
            then Int -> IO Int
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Int -> IO Int) -> Int -> IO Int
    forall a b. (a -> b) -> a -> b
    $! Int
    i Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1
            else do
              let Point{Int
    px :: Int
    py :: Int
    py :: Point -> Int
    px :: Point -> Int
    ..} = Int -> Point
    forall a. Enum a => Int -> a
    toEnum Int
    i
              Int -> Int -> AttrCharW32 -> IO ()
    setSquareChar Int
    px Int
    py (Word32 -> AttrCharW32
    Color.AttrCharW32 Word32
    w)
              Int -> IO Int
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Int -> IO Int) -> Int -> IO Int
    forall a b. (a -> b) -> a -> b
    $! Int
    i Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1
          drawMonoOverlay :: OverlaySpace -> IO ()
          drawMonoOverlay =
            ((PointUI, AttrString) -> IO ()) -> OverlaySpace -> IO ()
    forall (t :: * -> *) (m :: * -> *) a.
    (Foldable t, Monad m) =>
    (a -> m ()) -> t a -> m ()
    mapM_ (\(PointUI Int
    x Int
    y, AttrString
    al) ->
                     let lineCut :: AttrString
    lineCut = Int -> AttrString -> AttrString
    forall a. Int -> [a] -> [a]
    take (Int
    2 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * ScreenContent -> Int
    rwidth ScreenContent
    coscreen Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    x) AttrString
    al
                     in Int -> Int -> AttrString -> IO ()
    drawMonoLine Int
    x Int
    y AttrString
    lineCut)
          drawMonoLine :: Int -> Int -> AttrString -> IO ()
          drawMonoLine Int
    _ Int
    _ [] = () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
          drawMonoLine Int
    x Int
    row (AttrCharW32
    w : AttrString
    rest) = do
            Int -> Int -> AttrCharW32 -> IO ()
    setMonoChar Int
    x Int
    row AttrCharW32
    w
            Int -> Int -> AttrString -> IO ()
    drawMonoLine (Int
    x Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1) Int
    row AttrString
    rest
          setMonoChar :: Int -> Int -> Color.AttrCharW32 -> IO ()
          setMonoChar !Int
    x !Int
    row !AttrCharW32
    w = do
            atlas <- IORef FontAtlas -> IO FontAtlas
    forall a. IORef a -> IO a
    readIORef IORef FontAtlas
    smonoAtlas
            let Color.AttrChar{acAttr=Color.Attr{fg=fgRaw, bg}, acChar} =
                  Color.attrCharFromW32 w
                fg | Int -> Bool
    forall a. Integral a => a -> Bool
    even Int
    row Bool -> Bool -> Bool
    && Color
    fgRaw Color -> Color -> Bool
    forall a. Eq a => a -> a -> Bool
    == Color
    Color.White = Color
    Color.AltWhite
                   | Bool
    otherwise = Color
    fgRaw
                ac = Color -> Char -> AttrCharW32
    Color.attrChar2ToW32 Color
    fg Char
    acChar
                !_A = Bool -> () -> ()
    forall a. HasCallStack => Bool -> a -> a
    assert (Highlight
    bg Highlight -> [Highlight] -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [ Highlight
    Color.HighlightNone
                                        , Highlight
    Color.HighlightNoneCursor ]) ()
            textTexture <- case EM.lookup ac atlas of
              Maybe Texture
    Nothing -> do
                textSurfaceRaw <-
                  Font -> V4 Word8 -> V4 Word8 -> Char -> IO Surface
    forall (m :: * -> *).
    MonadIO m =>
    Font -> V4 Word8 -> V4 Word8 -> Char -> m Surface
    TTF.shadedGlyph (Maybe Font -> Font
    forall a. HasCallStack => Maybe a -> a
    fromJust Maybe Font
    smonoFont) (Color -> V4 Word8
    colorToRGBA Color
    fg)
                                  V4 Word8
    blackRGBA Char
    acChar
                textTexture <- scaleSurfaceToTexture halfSize textSurfaceRaw
                writeIORef smonoAtlas $ EM.insert ac textTexture atlas
                return textTexture
              Just Texture
    textTexture -> Texture -> IO Texture
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Texture
    textTexture
            let tt2Mono = CInt -> CInt -> V2 CInt
    forall a. a -> a -> V2 a
    Vect.V2 (Int -> CInt
    forall a. Enum a => Int -> a
    toEnum Int
    halfSize) (Int -> CInt
    forall a. Enum a => Int -> a
    toEnum Int
    boxSize)
                tgtR = Point V2 CInt -> V2 CInt -> Rectangle CInt
    forall a. Point V2 a -> V2 a -> Rectangle a
    SDL.Rectangle (Int -> Int -> Point V2 CInt
    vp (Int
    x Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    halfSize) (Int
    row Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    boxSize)) V2 CInt
    tt2Mono
            SDL.copy srenderer textTexture Nothing (Just tgtR)
          drawSquareOverlay :: OverlaySpace -> IO ()
          drawSquareOverlay =
            ((PointUI, AttrString) -> IO ()) -> OverlaySpace -> IO ()
    forall (t :: * -> *) (m :: * -> *) a.
    (Foldable t, Monad m) =>
    (a -> m ()) -> t a -> m ()
    mapM_ (\(PointUI
    pUI, AttrString
    al) ->
                     let PointSquare Int
    col Int
    row = PointUI -> PointSquare
    uiToSquare PointUI
    pUI
                         lineCut :: AttrString
    lineCut = Int -> AttrString -> AttrString
    forall a. Int -> [a] -> [a]
    take (ScreenContent -> Int
    rwidth ScreenContent
    coscreen Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    col) AttrString
    al
                     in Int -> Int -> AttrString -> IO ()
    drawSquareLine Int
    col Int
    row AttrString
    lineCut)
          drawSquareLine :: Int -> Int -> AttrString -> IO ()
          drawSquareLine Int
    _ Int
    _ [] = () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
          drawSquareLine Int
    col Int
    row (AttrCharW32
    w : AttrString
    rest) = do
            Int -> Int -> AttrCharW32 -> IO ()
    setSquareChar Int
    col Int
    row AttrCharW32
    w
            Int -> Int -> AttrString -> IO ()
    drawSquareLine (Int
    col Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1) Int
    row AttrString
    rest
          setSquareChar :: Int -> Int -> Color.AttrCharW32 -> IO ()
          setSquareChar !Int
    col !Int
    row !AttrCharW32
    w = do
            atlas <- IORef FontAtlas -> IO FontAtlas
    forall a. IORef a -> IO a
    readIORef IORef FontAtlas
    squareAtlas
            let Color.AttrChar{ acAttr=Color.Attr{fg=fgRaw, bg}
                              , acChar=acCharRaw } =
                  Color.attrCharFromW32 w
                fg | Int -> Bool
    forall a. Integral a => a -> Bool
    even Int
    row Bool -> Bool -> Bool
    && Color
    fgRaw Color -> Color -> Bool
    forall a. Eq a => a -> a -> Bool
    == Color
    Color.White = Color
    Color.AltWhite
                   | Bool
    otherwise = Color
    fgRaw
                ac = if Highlight
    bg Highlight -> Highlight -> Bool
    forall a. Eq a => a -> a -> Bool
    == Highlight
    Color.HighlightBackground
                     then AttrCharW32
    w
                     else Color -> Char -> AttrCharW32
    Color.attrChar2ToW32 Color
    fg Char
    acCharRaw
            textTexture <- case EM.lookup ac atlas of
              Maybe Texture
    Nothing -> do
                -- Make all visible floors bold (no bold font variant for 16x16x,
                -- so only the dot can be bold).
                let acChar :: Char
    acChar = if Bool -> Bool
    not (Color -> Bool
    Color.isBright Color
    fg)
                                Bool -> Bool -> Bool
    && Char
    acCharRaw Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    floorSymbol  -- '\x00B7'
                             then if Bool
    mapFontIsBitmap
                                  then Char
    '\x0007'
                                  else Char
    '\x22C5'
                             else Char
    acCharRaw
                    background :: V4 Word8
    background = if Highlight
    bg Highlight -> Highlight -> Bool
    forall a. Eq a => a -> a -> Bool
    == Highlight
    Color.HighlightBackground
                                 then V4 Word8
    greyRGBA
                                 else V4 Word8
    blackRGBA
                textSurfaceRaw <- Font -> V4 Word8 -> V4 Word8 -> Char -> IO Surface
    forall (m :: * -> *).
    MonadIO m =>
    Font -> V4 Word8 -> V4 Word8 -> Char -> m Surface
    TTF.shadedGlyph Font
    squareFont (Color -> V4 Word8
    colorToRGBA Color
    fg)
                                                  V4 Word8
    background Char
    acChar
                textTexture <- scaleSurfaceToTexture boxSize textSurfaceRaw
                writeIORef squareAtlas $ EM.insert ac textTexture atlas
                return textTexture
              Just Texture
    textTexture -> Texture -> IO Texture
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Texture
    textTexture
            let tgtR = Point V2 CInt -> V2 CInt -> Rectangle CInt
    forall a. Point V2 a -> V2 a -> Rectangle a
    SDL.Rectangle (Int -> Int -> Point V2 CInt
    vp (Int
    col Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    boxSize) (Int
    row Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    boxSize)) V2 CInt
    tt2Square
            SDL.copy srenderer textTexture Nothing (Just tgtR)
            -- Potentially overwrite a portion of the glyph.
            chooseAndDrawHighlight col row bg
          drawPropOverlay :: OverlaySpace -> IO ()
          drawPropOverlay =
            ((PointUI, AttrString) -> IO ()) -> OverlaySpace -> IO ()
    forall (t :: * -> *) (m :: * -> *) a.
    (Foldable t, Monad m) =>
    (a -> m ()) -> t a -> m ()
    mapM_ (\(PointUI Int
    x Int
    y, AttrString
    al) ->
                     Int -> Int -> AttrString -> IO ()
    drawPropLine (Int
    x Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    halfSize) Int
    y AttrString
    al)
          drawPropLine :: Int -> Int -> AttrString -> IO ()
          drawPropLine Int
    _ Int
    _ [] = () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
          drawPropLine Int
    x Int
    _ AttrString
    _ | Int
    x Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    >= (ScreenContent -> Int
    rwidth ScreenContent
    coscreen Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    1) Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    boxSize =
            -- This chunk starts at $ sign or beyond so, for KISS, reject it.
            () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
          drawPropLine Int
    x Int
    row (AttrCharW32
    w : AttrString
    rest) = do
            let isSpace :: AttrCharW32 -> Bool
    isSpace = (AttrCharW32 -> AttrCharW32 -> Bool
    forall a. Eq a => a -> a -> Bool
    == AttrCharW32
    Color.spaceAttrW32)
                Color.AttrChar{acAttr :: AttrChar -> Attr
    acAttr=Color.Attr{fg :: Attr -> Color
    fg=Color
    fgRaw, Highlight
    bg :: Attr -> Highlight
    bg :: Highlight
    bg}} =
                  AttrCharW32 -> AttrChar
    Color.attrCharFromW32
                  (AttrCharW32 -> AttrChar) -> AttrCharW32 -> AttrChar
    forall a b. (a -> b) -> a -> b
    $ if AttrCharW32 -> Bool
    isSpace AttrCharW32
    w
                    then case (AttrCharW32 -> Bool) -> AttrString -> AttrString
    forall a. (a -> Bool) -> [a] -> [a]
    filter (Bool -> Bool
    not (Bool -> Bool) -> (AttrCharW32 -> Bool) -> AttrCharW32 -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . AttrCharW32 -> Bool
    isSpace) AttrString
    rest of
                      AttrCharW32
    w2 : AttrString
    _ -> AttrCharW32
    w2
                      [] -> AttrCharW32
    w
                    else AttrCharW32
    w
                sameAttr :: AttrCharW32 -> Bool
    sameAttr AttrCharW32
    ac = AttrCharW32 -> Color
    Color.fgFromW32 AttrCharW32
    ac Color -> Color -> Bool
    forall a. Eq a => a -> a -> Bool
    == Color
    fgRaw
                              Bool -> Bool -> Bool
    || AttrCharW32 -> Bool
    isSpace AttrCharW32
    ac  -- matches all colours
                (AttrString
    sameRest, AttrString
    otherRest) = (AttrCharW32 -> Bool) -> AttrString -> (AttrString, AttrString)
    forall a. (a -> Bool) -> [a] -> ([a], [a])
    span AttrCharW32 -> Bool
    sameAttr AttrString
    rest
                !_A :: ()
    _A = Bool -> () -> ()
    forall a. HasCallStack => Bool -> a -> a
    assert (Highlight
    bg Highlight -> [Highlight] -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [ Highlight
    Color.HighlightNone
                                        , Highlight
    Color.HighlightNoneCursor ]) ()
                fg :: Color
    fg | Int -> Bool
    forall a. Integral a => a -> Bool
    even Int
    row Bool -> Bool -> Bool
    && Color
    fgRaw Color -> Color -> Bool
    forall a. Eq a => a -> a -> Bool
    == Color
    Color.White = Color
    Color.AltWhite
                   | Bool
    otherwise = Color
    fgRaw
                t :: Text
    t = FilePath -> Text
    T.pack (FilePath -> Text)
    -> (AttrString -> FilePath) -> AttrString -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . AttrString -> FilePath
    attrStringToString  (AttrString -> Text) -> AttrString -> Text
    forall a b. (a -> b) -> a -> b
    $ AttrCharW32
    w AttrCharW32 -> AttrString -> AttrString
    forall a. a -> [a] -> [a]
    : AttrString
    sameRest
            width <- Int -> Int -> Color -> Text -> IO Int
    drawPropChunk Int
    x Int
    row Color
    fg Text
    t
            drawPropLine (x + width) row otherRest
          drawPropChunk :: Int -> Int -> Color.Color -> T.Text -> IO Int
          drawPropChunk Int
    x Int
    row Color
    fg Text
    t = do
            let font :: Maybe Font
    font = if Color
    fg Color -> Color -> Bool
    forall a. Ord a => a -> a -> Bool
    >= Color
    Color.White Bool -> Bool -> Bool
    && Color
    fg Color -> Color -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Color
    Color.BrBlack
                       then Maybe Font
    spropFont
                       else Maybe Font
    sboldFont
                allSpace :: Bool
    allSpace = (Char -> Bool) -> Text -> Bool
    T.all Char -> Bool
    Char.isSpace Text
    t
            textSurfaceRaw <- Font -> V4 Word8 -> V4 Word8 -> Text -> IO Surface
    forall (m :: * -> *).
    MonadIO m =>
    Font -> V4 Word8 -> V4 Word8 -> Text -> m Surface
    TTF.shaded (Maybe Font -> Font
    forall a. HasCallStack => Maybe a -> a
    fromJust Maybe Font
    font) (Color -> V4 Word8
    colorToRGBA Color
    fg)
                                         V4 Word8
    blackRGBA Text
    t
            (width, textTexture) <-
              scaleSurfaceToTextureProp x row textSurfaceRaw allSpace
            let tgtR = Point V2 CInt -> V2 CInt -> Rectangle CInt
    forall a. Point V2 a -> V2 a -> Rectangle a
    SDL.Rectangle (Int -> Int -> Point V2 CInt
    vp Int
    x (Int
    row Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    boxSize))
                                     (CInt -> CInt -> V2 CInt
    forall a. a -> a -> V2 a
    Vect.V2 (Int -> CInt
    forall a. Enum a => Int -> a
    toEnum Int
    width) (Int -> CInt
    forall a. Enum a => Int -> a
    toEnum Int
    boxSize))
            -- Potentially overwrite some of the screen.
            SDL.copy srenderer textTexture Nothing (Just tgtR)
            SDL.destroyTexture textTexture
            return width
      let arraysEqual = SingleFrame -> Array AttrCharW32
    singleArray SingleFrame
    curFrame Array AttrCharW32 -> Array AttrCharW32 -> Bool
    forall a. Eq a => a -> a -> Bool
    == SingleFrame -> Array AttrCharW32
    singleArray SingleFrame
    prevFrame
          overlaysEqual =
            SingleFrame -> OverlaySpace
    singleMonoOverlay SingleFrame
    curFrame OverlaySpace -> OverlaySpace -> Bool
    forall a. Eq a => a -> a -> Bool
    == SingleFrame -> OverlaySpace
    singleMonoOverlay SingleFrame
    prevFrame
            Bool -> Bool -> Bool
    && SingleFrame -> OverlaySpace
    singleSquareOverlay SingleFrame
    curFrame OverlaySpace -> OverlaySpace -> Bool
    forall a. Eq a => a -> a -> Bool
    == SingleFrame -> OverlaySpace
    singleSquareOverlay SingleFrame
    prevFrame
            Bool -> Bool -> Bool
    && SingleFrame -> OverlaySpace
    singlePropOverlay SingleFrame
    curFrame OverlaySpace -> OverlaySpace -> Bool
    forall a. Eq a => a -> a -> Bool
    == SingleFrame -> OverlaySpace
    singlePropOverlay SingleFrame
    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 -> IO ()
    printScreen FrontendSession{Bool
    Int
    Maybe Font
    MVar ()
    MVar SingleFrame
    IORef Bool
    IORef FontAtlas
    IORef Texture
    IORef SingleFrame
    Renderer
    Window
    Font
    swindow :: FrontendSession -> Window
    srenderer :: FrontendSession -> Renderer
    squareFont :: FrontendSession -> Font
    squareFontSize :: FrontendSession -> Int
    mapFontIsBitmap :: FrontendSession -> Bool
    spropFont :: FrontendSession -> Maybe Font
    sboldFont :: FrontendSession -> Maybe Font
    smonoFont :: FrontendSession -> Maybe Font
    squareAtlas :: FrontendSession -> IORef FontAtlas
    smonoAtlas :: FrontendSession -> IORef FontAtlas
    sbasicTexture :: FrontendSession -> IORef Texture
    stexture :: FrontendSession -> IORef Texture
    spreviousFrame :: FrontendSession -> IORef SingleFrame
    sforcedShutdown :: FrontendSession -> IORef Bool
    scontinueSdlLoop :: FrontendSession -> IORef Bool
    sframeQueue :: FrontendSession -> MVar SingleFrame
    sframeDrawn :: FrontendSession -> MVar ()
    swindow :: Window
    srenderer :: Renderer
    squareFont :: Font
    squareFontSize :: Int
    mapFontIsBitmap :: Bool
    spropFont :: Maybe Font
    sboldFont :: Maybe Font
    smonoFont :: Maybe Font
    squareAtlas :: IORef FontAtlas
    smonoAtlas :: IORef FontAtlas
    sbasicTexture :: IORef Texture
    stexture :: IORef Texture
    spreviousFrame :: IORef SingleFrame
    sforcedShutdown :: IORef Bool
    scontinueSdlLoop :: IORef Bool
    sframeQueue :: MVar SingleFrame
    sframeDrawn :: MVar ()
    ..} = do
      dataDir <- IO FilePath
    appDataDir
      tryCreateDir dataDir
      tryCreateDir $ dataDir </> "screenshots"
      utcTime <- getCurrentTime
      timezone <- getTimeZone utcTime
      let unspace = (Char -> Char) -> FilePath -> FilePath
    forall a b. (a -> b) -> [a] -> [b]
    map ((Char -> Char) -> FilePath -> FilePath)
    -> (Char -> Char) -> FilePath -> FilePath
    forall a b. (a -> b) -> a -> b
    $ \Char
    c -> case Char
    c of  -- prevent the need for backquoting
            Char
    ' ' -> Char
    '_'
            Char
    ':' -> Char
    '.'
            Char
    _ -> Char
    c
          dateText = FilePath -> FilePath
    unspace (FilePath -> FilePath) -> FilePath -> FilePath
    forall a b. (a -> b) -> a -> b
    $ Int -> FilePath -> FilePath
    forall a. Int -> [a] -> [a]
    take Int
    25 (FilePath -> FilePath) -> FilePath -> FilePath
    forall a b. (a -> b) -> a -> b
    $ LocalTime -> FilePath
    forall a. Show a => a -> FilePath
    show (LocalTime -> FilePath) -> LocalTime -> FilePath
    forall a b. (a -> b) -> a -> b
    $ TimeZone -> UTCTime -> LocalTime
    utcToLocalTime TimeZone
    timezone UTCTime
    utcTime
          fileName = FilePath
    dataDir FilePath -> FilePath -> FilePath
    </> FilePath
    "screenshots" FilePath -> FilePath -> FilePath
    </> FilePath
    "prtscn" FilePath -> FilePath -> FilePath
    forall a. Semigroup a => a -> a -> a
    <> FilePath
    dateText FilePath -> FilePath -> FilePath
    <.> FilePath
    "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 $ \CString
    fileNameCString ->
        IO CInt -> IO ()
    forall (f :: * -> *) a. Functor f => f a -> f ()
    void (IO CInt -> IO ()) -> IO CInt -> IO ()
    forall a b. (a -> b) -> a -> b
    $! Ptr Surface -> CString -> IO CInt
    forall (m :: * -> *). MonadIO m => Ptr Surface -> CString -> m CInt
    SDL.Raw.Video.saveBMP Ptr Surface
    ptrOut CString
    fileNameCString
      SDL.Raw.Video.freeSurface ptrOut

    -- | Translates modifiers to our own encoding.
    modTranslate :: SDL.KeyModifier -> K.Modifier
    modTranslate :: KeyModifier -> Modifier
    modTranslate KeyModifier
    m =
      Bool -> Bool -> Bool -> Bool -> Modifier
    modifierTranslate
        (KeyModifier -> Bool
    SDL.keyModifierLeftCtrl KeyModifier
    m Bool -> Bool -> Bool
    || KeyModifier -> Bool
    SDL.keyModifierRightCtrl KeyModifier
    m)
        (KeyModifier -> Bool
    SDL.keyModifierLeftShift KeyModifier
    m Bool -> Bool -> Bool
    || KeyModifier -> Bool
    SDL.keyModifierRightShift KeyModifier
    m)
        (KeyModifier -> Bool
    SDL.keyModifierLeftAlt KeyModifier
    m
         Bool -> Bool -> Bool
    || KeyModifier -> Bool
    SDL.keyModifierRightAlt KeyModifier
    m
         Bool -> Bool -> Bool
    || KeyModifier -> Bool
    SDL.keyModifierAltGr KeyModifier
    m
         Bool -> Bool -> Bool
    || KeyModifier -> Bool
    SDL.keyModifierLeftGUI KeyModifier
    m
         Bool -> Bool -> Bool
    || KeyModifier -> Bool
    SDL.keyModifierRightGUI KeyModifier
    m)
        Bool
    False

    keyTranslate :: Bool -> SDL.Keycode -> K.Key
    keyTranslate :: Bool -> Keycode -> Key
    keyTranslate Bool
    shiftPressed Keycode
    n = case Keycode
    n of
      Keycode
    KeycodeEscape     -> Key
    K.Esc
      Keycode
    KeycodeReturn     -> Key
    K.Return
      Keycode
    KeycodeBackspace  -> Key
    K.BackSpace
      Keycode
    KeycodeTab        -> if Bool
    shiftPressed then Key
    K.BackTab else Key
    K.Tab
      Keycode
    KeycodeSpace      -> Key
    K.Space
      Keycode
    KeycodeExclaim -> Char -> Key
    K.Char Char
    '!'
      Keycode
    KeycodeQuoteDbl -> Char -> Key
    K.Char Char
    '"'
      Keycode
    KeycodeHash -> Char -> Key
    K.Char Char
    '#'
      Keycode
    KeycodePercent -> Char -> Key
    K.Char Char
    '%'
      Keycode
    KeycodeDollar -> Char -> Key
    K.Char Char
    '$'
      Keycode
    KeycodeAmpersand -> Char -> Key
    K.Char Char
    '&'
      Keycode
    KeycodeQuote -> if Bool
    shiftPressed then Char -> Key
    K.Char Char
    '"' else Char -> Key
    K.Char Char
    '\''
      Keycode
    KeycodeLeftParen -> Char -> Key
    K.Char Char
    '('
      Keycode
    KeycodeRightParen -> Char -> Key
    K.Char Char
    ')'
      Keycode
    KeycodeAsterisk -> Char -> Key
    K.Char Char
    '*'
      Keycode
    KeycodePlus -> Char -> Key
    K.Char Char
    '+'
      Keycode
    KeycodeComma -> if Bool
    shiftPressed then Char -> Key
    K.Char Char
    '<' else Char -> Key
    K.Char Char
    ','
      Keycode
    KeycodeMinus -> if Bool
    shiftPressed then Char -> Key
    K.Char Char
    '_' else Char -> Key
    K.Char Char
    '-'
      Keycode
    KeycodePeriod -> if Bool
    shiftPressed then Char -> Key
    K.Char Char
    '>' else Char -> Key
    K.Char Char
    '.'
      Keycode
    KeycodeSlash -> if Bool
    shiftPressed then Char -> Key
    K.Char Char
    '?' else Char -> Key
    K.Char Char
    '/'
      Keycode
    Keycode1 -> if Bool
    shiftPressed then Char -> Key
    K.Char Char
    '!' else Char -> Key
    K.Char Char
    '1'
      Keycode
    Keycode2 -> if Bool
    shiftPressed then Char -> Key
    K.Char Char
    '@' else Char -> Key
    K.Char Char
    '2'
      Keycode
    Keycode3 -> if Bool
    shiftPressed then Char -> Key
    K.Char Char
    '#' else Char -> Key
    K.Char Char
    '3'
      Keycode
    Keycode4 -> if Bool
    shiftPressed then Char -> Key
    K.Char Char
    '$' else Char -> Key
    K.Char Char
    '4'
      Keycode
    Keycode5 -> if Bool
    shiftPressed then Char -> Key
    K.Char Char
    '%' else Char -> Key
    K.Char Char
    '5'
      Keycode
    Keycode6 -> if Bool
    shiftPressed then Char -> Key
    K.Char Char
    '^' else Char -> Key
    K.Char Char
    '6'
      Keycode
    Keycode7 -> if Bool
    shiftPressed then Char -> Key
    K.Char Char
    '&' else Char -> Key
    K.Char Char
    '7'
      Keycode
    Keycode8 -> if Bool
    shiftPressed then Char -> Key
    K.Char Char
    '*' else Char -> Key
    K.Char Char
    '8'
      Keycode
    Keycode9 -> if Bool
    shiftPressed then Char -> Key
    K.Char Char
    '(' else Char -> Key
    K.Char Char
    '9'
      Keycode
    Keycode0 -> if Bool
    shiftPressed then Char -> Key
    K.Char Char
    ')' else Char -> Key
    K.Char Char
    '0'
      Keycode
    KeycodeColon -> Char -> Key
    K.Char Char
    ':'
      Keycode
    KeycodeSemicolon -> if Bool
    shiftPressed then Char -> Key
    K.Char Char
    ':' else Char -> Key
    K.Char Char
    ';'
      Keycode
    KeycodeLess -> Char -> Key
    K.Char Char
    '<'
      Keycode
    KeycodeEquals -> if Bool
    shiftPressed then Char -> Key
    K.Char Char
    '+' else Char -> Key
    K.Char Char
    '='
      Keycode
    KeycodeGreater -> Char -> Key
    K.Char Char
    '>'
      Keycode
    KeycodeQuestion -> Char -> Key
    K.Char Char
    '?'
      Keycode
    KeycodeAt -> Char -> Key
    K.Char Char
    '@'
      Keycode
    KeycodeLeftBracket -> if Bool
    shiftPressed then Char -> Key
    K.Char Char
    '{' else Char -> Key
    K.Char Char
    '['
      Keycode
    KeycodeBackslash -> if Bool
    shiftPressed then Char -> Key
    K.Char Char
    '|' else Char -> Key
    K.Char Char
    '\\'
      Keycode
    KeycodeRightBracket -> if Bool
    shiftPressed then Char -> Key
    K.Char Char
    '}' else Char -> Key
    K.Char Char
    ']'
      Keycode
    KeycodeCaret -> Char -> Key
    K.Char Char
    '^'
      Keycode
    KeycodeUnderscore -> Char -> Key
    K.Char Char
    '_'
      Keycode
    KeycodeBackquote -> if Bool
    shiftPressed then Char -> Key
    K.Char Char
    '~' else Char -> Key
    K.Char Char
    '`'
      Keycode Int32
    167      -> if Bool
    shiftPressed then Char -> Key
    K.Char Char
    '~' else Char -> Key
    K.Char 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
      Keycode
    KeycodeUp         -> Key
    K.Up
      Keycode
    KeycodeDown       -> Key
    K.Down
      Keycode
    KeycodeLeft       -> Key
    K.Left
      Keycode
    KeycodeRight      -> Key
    K.Right
      Keycode
    KeycodeHome       -> Key
    K.Home
      Keycode
    KeycodeEnd        -> Key
    K.End
      Keycode
    KeycodePageUp     -> Key
    K.PgUp
      Keycode
    KeycodePageDown   -> Key
    K.PgDn
      Keycode
    KeycodeInsert     -> Key
    K.Insert
      Keycode
    KeycodeDelete     -> Key
    K.Delete
      Keycode
    KeycodePrintScreen -> Key
    K.PrintScreen
      Keycode
    KeycodeClear -> Key
    K.Begin
      Keycode
    KeycodeKPClear -> Key
    K.Begin
      Keycode
    KeycodeKPDivide   -> if Bool
    shiftPressed then Char -> Key
    K.Char Char
    '?' else Char -> Key
    K.Char Char
    '/'
                             -- KP and normal are merged here
      Keycode
    KeycodeKPMultiply -> Char -> Key
    K.Char Char
    '*'  -- KP and normal are merged here
      Keycode
    KeycodeKPMinus    -> Char -> Key
    K.Char Char
    '-'  -- KP and normal are merged here
      Keycode
    KeycodeKPPlus     -> Char -> Key
    K.Char Char
    '+'  -- KP and normal are merged here
      Keycode
    KeycodeKPEnter    -> Key
    K.Return
      Keycode
    KeycodeKPEquals   -> Key
    K.Return  -- in case of some funny layouts
      Keycode
    KeycodeKP1 -> if Bool
    shiftPressed then Char -> Key
    K.KP Char
    '1' else Key
    K.End
      Keycode
    KeycodeKP2 -> if Bool
    shiftPressed then Char -> Key
    K.KP Char
    '2' else Key
    K.Down
      Keycode
    KeycodeKP3 -> if Bool
    shiftPressed then Char -> Key
    K.KP Char
    '3' else Key
    K.PgDn
      Keycode
    KeycodeKP4 -> if Bool
    shiftPressed then Char -> Key
    K.KP Char
    '4' else Key
    K.Left
      Keycode
    KeycodeKP5 -> if Bool
    shiftPressed then Char -> Key
    K.KP Char
    '5' else Key
    K.Begin
      Keycode
    KeycodeKP6 -> if Bool
    shiftPressed then Char -> Key
    K.KP Char
    '6' else Key
    K.Right
      Keycode
    KeycodeKP7 -> if Bool
    shiftPressed then Char -> Key
    K.KP Char
    '7' else Key
    K.Home
      Keycode
    KeycodeKP8 -> if Bool
    shiftPressed then Char -> Key
    K.KP Char
    '8' else Key
    K.Up
      Keycode
    KeycodeKP9 -> if Bool
    shiftPressed then Char -> Key
    K.KP Char
    '9' else Key
    K.PgUp
      Keycode
    KeycodeKP0 -> if Bool
    shiftPressed then Char -> Key
    K.KP Char
    '0' else Key
    K.Insert
      Keycode
    KeycodeKPPeriod -> Char -> Key
    K.Char Char
    '.'  -- dot and comma are merged here
      Keycode
    KeycodeKPComma  -> Char -> Key
    K.Char Char
    '.'  -- to sidestep national standards
      Keycode
    KeycodeF1       -> Int -> Key
    K.Fun Int
    1
      Keycode
    KeycodeF2       -> Int -> Key
    K.Fun Int
    2
      Keycode
    KeycodeF3       -> Int -> Key
    K.Fun Int
    3
      Keycode
    KeycodeF4       -> Int -> Key
    K.Fun Int
    4
      Keycode
    KeycodeF5       -> Int -> Key
    K.Fun Int
    5
      Keycode
    KeycodeF6       -> Int -> Key
    K.Fun Int
    6
      Keycode
    KeycodeF7       -> Int -> Key
    K.Fun Int
    7
      Keycode
    KeycodeF8       -> Int -> Key
    K.Fun Int
    8
      Keycode
    KeycodeF9       -> Int -> Key
    K.Fun Int
    9
      Keycode
    KeycodeF10      -> Int -> Key
    K.Fun Int
    10
      Keycode
    KeycodeF11      -> Int -> Key
    K.Fun Int
    11
      Keycode
    KeycodeF12      -> Int -> Key
    K.Fun Int
    12
      Keycode
    KeycodeLCtrl    -> Key
    K.DeadKey
      Keycode
    KeycodeLShift   -> Key
    K.DeadKey
      Keycode
    KeycodeLAlt     -> Key
    K.DeadKey
      Keycode
    KeycodeLGUI     -> Key
    K.DeadKey
      Keycode
    KeycodeRCtrl    -> Key
    K.DeadKey
      Keycode
    KeycodeRShift   -> Key
    K.DeadKey
      Keycode
    KeycodeRAlt     -> Key
    K.DeadKey
      Keycode
    KeycodeRGUI     -> Key
    K.DeadKey
      Keycode
    KeycodeMode     -> Key
    K.DeadKey
      Keycode
    KeycodeNumLockClear -> Key
    K.DeadKey
      Keycode
    KeycodeUnknown  -> FilePath -> Key
    K.Unknown FilePath
    "KeycodeUnknown"
      Keycode
    _ -> let i :: Int
    i = Int32 -> Int
    forall a. Enum a => a -> Int
    fromEnum (Int32 -> Int) -> Int32 -> Int
    forall a b. (a -> b) -> a -> b
    $ Keycode -> Int32
    unwrapKeycode Keycode
    n
           in if | Int
    97 Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    <= Int
    i Bool -> Bool -> Bool
    && Int
    i Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    <= Int
    122
                   Bool -> Bool -> Bool
    && Bool
    shiftPressed -> Char -> Key
    K.Char (Char -> Key) -> Char -> Key
    forall a b. (a -> b) -> a -> b
    $ Int -> Char
    Char.chr (Int -> Char) -> Int -> Char
    forall a b. (a -> b) -> a -> b
    $ Int
    i Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    32
                 | Int
    32 Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    <= Int
    i Bool -> Bool -> Bool
    && Int
    i Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    <= Int
    126 -> Char -> Key
    K.Char (Char -> Key) -> Char -> Key
    forall a b. (a -> b) -> a -> b
    $ Int -> Char
    Char.chr Int
    i
                 | Bool
    otherwise -> FilePath -> Key
    K.Unknown (FilePath -> Key) -> FilePath -> Key
    forall a b. (a -> b) -> a -> b
    $ Keycode -> FilePath
    forall a. Show a => a -> FilePath
    show Keycode
    n

    sDL_ALPHA_OPAQUE :: Word8
    sDL_ALPHA_OPAQUE :: Word8
    sDL_ALPHA_OPAQUE = Word8
    255

    blackRGBA :: SDL.V4 Word8
    blackRGBA :: V4 Word8
    blackRGBA = Word8 -> Word8 -> Word8 -> Word8 -> V4 Word8
    forall a. a -> a -> a -> a -> V4 a
    SDL.V4 Word8
    0 Word8
    0 Word8
    0 Word8
    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 :: V4 Word8
    greyRGBA = Word8 -> Word8 -> Word8 -> Word8 -> V4 Word8
    forall a. a -> a -> a -> a -> V4 a
    SDL.V4 Word8
    0x25 Word8
    0x1F Word8
    0x1F Word8
    sDL_ALPHA_OPAQUE

    -- This code is sadly duplicated from "Game.LambdaHack.Definition.Color".
    colorToRGBA :: Color.Color -> SDL.V4 Word8
    colorToRGBA :: Color -> V4 Word8
    colorToRGBA Color
    Color.Black     = V4 Word8
    blackRGBA
    colorToRGBA Color
    Color.Red       = Word8 -> Word8 -> Word8 -> Word8 -> V4 Word8
    forall a. a -> a -> a -> a -> V4 a
    SDL.V4 Word8
    0xD5 Word8
    0x05 Word8
    0x05 Word8
    sDL_ALPHA_OPAQUE
    colorToRGBA Color
    Color.Green     = Word8 -> Word8 -> Word8 -> Word8 -> V4 Word8
    forall a. a -> a -> a -> a -> V4 a
    SDL.V4 Word8
    0x05 Word8
    0x9D Word8
    0x05 Word8
    sDL_ALPHA_OPAQUE
    colorToRGBA Color
    Color.Brown     = Word8 -> Word8 -> Word8 -> Word8 -> V4 Word8
    forall a. a -> a -> a -> a -> V4 a
    SDL.V4 Word8
    0xCA Word8
    0x4A Word8
    0x05 Word8
    sDL_ALPHA_OPAQUE
    colorToRGBA Color
    Color.Blue      = Word8 -> Word8 -> Word8 -> Word8 -> V4 Word8
    forall a. a -> a -> a -> a -> V4 a
    SDL.V4 Word8
    0x05 Word8
    0x56 Word8
    0xF4 Word8
    sDL_ALPHA_OPAQUE
    colorToRGBA Color
    Color.Magenta   = Word8 -> Word8 -> Word8 -> Word8 -> V4 Word8
    forall a. a -> a -> a -> a -> V4 a
    SDL.V4 Word8
    0xAF Word8
    0x0E Word8
    0xAF Word8
    sDL_ALPHA_OPAQUE
    colorToRGBA Color
    Color.Cyan      = Word8 -> Word8 -> Word8 -> Word8 -> V4 Word8
    forall a. a -> a -> a -> a -> V4 a
    SDL.V4 Word8
    0x05 Word8
    0x96 Word8
    0x96 Word8
    sDL_ALPHA_OPAQUE
    colorToRGBA Color
    Color.White     = Word8 -> Word8 -> Word8 -> Word8 -> V4 Word8
    forall a. a -> a -> a -> a -> V4 a
    SDL.V4 Word8
    0xB8 Word8
    0xBF Word8
    0xCB Word8
    sDL_ALPHA_OPAQUE
    colorToRGBA Color
    Color.AltWhite  = Word8 -> Word8 -> Word8 -> Word8 -> V4 Word8
    forall a. a -> a -> a -> a -> V4 a
    SDL.V4 Word8
    0xC4 Word8
    0xBE Word8
    0xB1 Word8
    sDL_ALPHA_OPAQUE
    colorToRGBA Color
    Color.BrBlack   = Word8 -> Word8 -> Word8 -> Word8 -> V4 Word8
    forall a. a -> a -> a -> a -> V4 a
    SDL.V4 Word8
    0x6F Word8
    0x5F Word8
    0x5F Word8
    sDL_ALPHA_OPAQUE
    colorToRGBA Color
    Color.BrRed     = Word8 -> Word8 -> Word8 -> Word8 -> V4 Word8
    forall a. a -> a -> a -> a -> V4 a
    SDL.V4 Word8
    0xFF Word8
    0x55 Word8
    0x55 Word8
    sDL_ALPHA_OPAQUE
    colorToRGBA Color
    Color.BrGreen   = Word8 -> Word8 -> Word8 -> Word8 -> V4 Word8
    forall a. a -> a -> a -> a -> V4 a
    SDL.V4 Word8
    0x65 Word8
    0xF1 Word8
    0x36 Word8
    sDL_ALPHA_OPAQUE
    colorToRGBA Color
    Color.BrYellow  = Word8 -> Word8 -> Word8 -> Word8 -> V4 Word8
    forall a. a -> a -> a -> a -> V4 a
    SDL.V4 Word8
    0xEB Word8
    0xD6 Word8
    0x42 Word8
    sDL_ALPHA_OPAQUE
    colorToRGBA Color
    Color.BrBlue    = Word8 -> Word8 -> Word8 -> Word8 -> V4 Word8
    forall a. a -> a -> a -> a -> V4 a
    SDL.V4 Word8
    0x4D Word8
    0x98 Word8
    0xF4 Word8
    sDL_ALPHA_OPAQUE
    colorToRGBA Color
    Color.BrMagenta = Word8 -> Word8 -> Word8 -> Word8 -> V4 Word8
    forall a. a -> a -> a -> a -> V4 a
    SDL.V4 Word8
    0xFF Word8
    0x77 Word8
    0xFF Word8
    sDL_ALPHA_OPAQUE
    colorToRGBA Color
    Color.BrCyan    = Word8 -> Word8 -> Word8 -> Word8 -> V4 Word8
    forall a. a -> a -> a -> a -> V4 a
    SDL.V4 Word8
    0x52 Word8
    0xF4 Word8
    0xE5 Word8
    sDL_ALPHA_OPAQUE
    colorToRGBA Color
    Color.BrWhite   = Word8 -> Word8 -> Word8 -> Word8 -> V4 Word8
    forall a. a -> a -> a -> a -> V4 a
    SDL.V4 Word8
    0xFF Word8
    0xFF Word8
    0xFF Word8
    sDL_ALPHA_OPAQUE