-- | 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