-- | Text frontend based on SDL2.
module Game.LambdaHack.Client.UI.Frontend.Sdl
  ( startup, frontendName
#ifdef EXPOSE_INTERNAL
    -- * Internal operations
  , FontAtlas, FrontendSession(..), startupFun, shutdown, forceShutdown
  , display, drawFrame, printScreen, modTranslate, keyTranslate, colorToRGBA
#endif
  ) where

import Prelude ()

import Game.LambdaHack.Core.Prelude

import           Control.Concurrent
import qualified Data.Char as Char
import qualified Data.EnumMap.Strict as EM
import           Data.IORef
import qualified Data.Text as T
import           Data.Time.Clock.POSIX
import           Data.Time.LocalTime
import qualified Data.Vector.Unboxed as U
import           Data.Word (Word32, Word8)
import           Foreign.C.String (withCString)
import           Foreign.C.Types (CInt)
import           Foreign.Ptr (nullPtr)
import           Foreign.Storable (peek)
import           System.Directory
import           System.Exit (exitSuccess)
import           System.FilePath

import qualified SDL
import qualified SDL.Font as TTF
import           SDL.Input.Keyboard.Codes
import qualified SDL.Internal.Types
import qualified SDL.Raw.Basic as SDL (logSetAllPriority)
import qualified SDL.Raw.Enum
import qualified SDL.Raw.Types
import qualified SDL.Raw.Video
import qualified SDL.Vect as Vect

import           Game.LambdaHack.Client.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

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 :: String
frontendName = "sdl"

-- | Set up and start the main loop providing input and output.
--
-- Because of Windows and OS X, SDL2 needs to be on a bound thread,
-- so we can't avoid the communication overhead of bound threads.
startup :: ScreenContent -> ClientOptions -> IO RawFrontend
startup :: ScreenContent -> ClientOptions -> IO RawFrontend
startup coscreen :: ScreenContent
coscreen soptions :: 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 coscreen :: ScreenContent
coscreen soptions :: ClientOptions
soptions@ClientOptions{..} rfMVar :: 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
 LogPriority -> IO ()
forall (m :: * -> *). MonadIO m => LogPriority -> m ()
SDL.logSetAllPriority (LogPriority -> IO ()) -> LogPriority -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> LogPriority
forall a. Enum a => Int -> a
toEnum (Int -> LogPriority) -> Int -> LogPriority
forall a b. (a -> b) -> a -> b
$ Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe 5 Maybe Int
slogPriority
 IO ()
forall (m :: * -> *). MonadIO m => m ()
TTF.initialize
 let title :: Text
title = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Maybe String -> String
forall a. HasCallStack => Maybe a -> a
fromJust Maybe String
stitle
     chosenFontsetID :: Text
chosenFontsetID = Maybe Text -> Text
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Text
schosenFontset
     chosenFontset :: FontSet
chosenFontset = case Text -> [(Text, FontSet)] -> Maybe FontSet
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
chosenFontsetID [(Text, FontSet)]
sfontsets of
       Nothing -> String -> FontSet
forall a. HasCallStack => String -> a
error (String -> FontSet) -> String -> FontSet
forall a b. (a -> b) -> a -> b
$ "Fontset not defined in config file"
                          String -> Text -> String
forall v. Show v => String -> v -> String
`showFailure` Text
chosenFontsetID
       Just fs :: FontSet
fs -> 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.
     findFontFile :: Text -> IO (Maybe (Font, Int))
findFontFile t :: Text
t =
       if Text -> Bool
T.null Text
t
       then Maybe (Font, Int) -> IO (Maybe (Font, Int))
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
         Nothing -> String -> IO (Maybe (Font, Int))
forall a. HasCallStack => String -> a
error (String -> IO (Maybe (Font, Int)))
-> String -> IO (Maybe (Font, Int))
forall a b. (a -> b) -> a -> b
$ "Font not defined in config file" String -> Text -> String
forall v. Show v => String -> v -> String
`showFailure` Text
t
         Just (FontProportional fname :: Text
fname fsize :: Int
fsize fhint :: HintingMode
fhint) -> do
           Font
sdlFont <- Text -> Int -> IO Font
loadFontFile Text
fname Int
fsize
           Font -> HintingMode -> IO ()
forall (m :: * -> *). MonadIO m => Font -> HintingMode -> m ()
setHintMode Font
sdlFont HintingMode
fhint
           -- TODO: when SDL_ttf can do it, check that not a bitmap font
           Int
realSize <- Font -> IO Int
forall (m :: * -> *). MonadIO m => Font -> m Int
TTF.height Font
sdlFont
           let !_A :: ()
_A = Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert (Int
realSize Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0) ()  -- sanity
           Maybe (Font, Int) -> IO (Maybe (Font, Int))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Font, Int) -> IO (Maybe (Font, Int)))
-> Maybe (Font, Int) -> IO (Maybe (Font, Int))
forall a b. (a -> b) -> a -> b
$ (Font, Int) -> Maybe (Font, Int)
forall a. a -> Maybe a
Just (Font
sdlFont, Int
realSize)
         Just (FontMonospace fname :: Text
fname fsize :: Int
fsize fhint :: HintingMode
fhint) -> do
           Font
sdlFont <- Text -> Int -> IO Font
loadFontFile Text
fname Int
fsize
           Font -> HintingMode -> IO ()
forall (m :: * -> *). MonadIO m => Font -> HintingMode -> m ()
setHintMode Font
sdlFont HintingMode
fhint
           Bool
isFontMono <- Font -> IO Bool
forall (m :: * -> *). MonadIO m => Font -> m Bool
TTF.isMonospace Font
sdlFont
           Int
realSize <- Font -> IO Int
forall (m :: * -> *). MonadIO m => Font -> m Int
TTF.height Font
sdlFont
           let !_A :: ()
_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
> 0) ()  -- sanity
           Maybe (Font, Int) -> IO (Maybe (Font, Int))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Font, Int) -> IO (Maybe (Font, Int)))
-> Maybe (Font, Int) -> IO (Maybe (Font, Int))
forall a b. (a -> b) -> a -> b
$ (Font, Int) -> Maybe (Font, Int)
forall a. a -> Maybe a
Just (Font
sdlFont, Int
realSize)
         Just (FontMapScalable fname :: Text
fname fsize :: Int
fsize fhint :: HintingMode
fhint cellSizeAdd :: Int
cellSizeAdd) -> do
           Font
sdlFont <- Text -> Int -> IO Font
loadFontFile Text
fname Int
fsize
           Font -> HintingMode -> IO ()
forall (m :: * -> *). MonadIO m => Font -> HintingMode -> m ()
setHintMode Font
sdlFont HintingMode
fhint
           Bool
isFontMono <- Font -> IO Bool
forall (m :: * -> *). MonadIO m => Font -> m Bool
TTF.isMonospace Font
sdlFont
           Int
realSize <- Font -> IO Int
forall (m :: * -> *). MonadIO m => Font -> m Int
TTF.height Font
sdlFont
           let !_A :: ()
_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
> 0) ()  -- sanity
           Maybe (Font, Int) -> IO (Maybe (Font, Int))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Font, Int) -> IO (Maybe (Font, Int)))
-> Maybe (Font, Int) -> IO (Maybe (Font, Int))
forall a b. (a -> b) -> a -> b
$ (Font, Int) -> Maybe (Font, Int)
forall a. a -> Maybe a
Just (Font
sdlFont, Int
realSize Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
cellSizeAdd)
         Just (FontMapBitmap fname :: Text
fname cellSizeAdd :: Int
cellSizeAdd) -> do
           Font
sdlFont <- Text -> Int -> IO Font
loadFontFile Text
fname 0  -- size ignored for bitmap fonts
           Bool
isFontMono <- Font -> IO Bool
forall (m :: * -> *). MonadIO m => Font -> m Bool
TTF.isMonospace Font
sdlFont
           Int
realSize <- Font -> IO Int
forall (m :: * -> *). MonadIO m => Font -> m Int
TTF.height Font
sdlFont
           let !_A :: ()
_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
> 0) ()  -- sanity
           Maybe (Font, Int) -> IO (Maybe (Font, Int))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Font, Int) -> IO (Maybe (Font, Int)))
-> Maybe (Font, Int) -> IO (Maybe (Font, Int))
forall a b. (a -> b) -> a -> b
$ (Font, Int) -> Maybe (Font, Int)
forall a. a -> Maybe a
Just (Font
sdlFont, Int
realSize Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
cellSizeAdd)
     loadFontFile :: Text -> Int -> IO Font
loadFontFile fname :: Text
fname fsize :: Int
fsize = do
       let fontFileName :: String
fontFileName = Text -> String
T.unpack Text
fname
           fontSize :: Int
fontSize = Double -> Int
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 String -> Bool
isRelative String
fontFileName
       then do
         case String -> [(String, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
fontFileName ([(String, ByteString)] -> Maybe ByteString)
-> [(String, ByteString)] -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ ScreenContent -> [(String, ByteString)]
rFontFiles ScreenContent
coscreen of
           Nothing -> String -> IO Font
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO Font) -> String -> IO Font
forall a b. (a -> b) -> a -> b
$ "Font file not supplied with the game: "
                             String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fontFileName
                             String -> String -> String
forall a. [a] -> [a] -> [a]
++ " within "
                             String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show (((String, ByteString) -> String)
-> [(String, ByteString)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, ByteString) -> String
forall a b. (a, b) -> a
fst ([(String, ByteString)] -> [String])
-> [(String, ByteString)] -> [String]
forall a b. (a -> b) -> a -> b
$ ScreenContent -> [(String, ByteString)]
rFontFiles ScreenContent
coscreen)
           Just bs :: ByteString
bs -> ByteString -> Int -> IO Font
forall (m :: * -> *). MonadIO m => ByteString -> Int -> m Font
TTF.decode ByteString
bs Int
fontSize
       else do
         Bool
fontFileExists <- String -> IO Bool
doesFileExist String
fontFileName
         if Bool -> Bool
not Bool
fontFileExists
         then String -> IO Font
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO Font) -> String -> IO Font
forall a b. (a -> b) -> a -> b
$ "Font file does not exist: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fontFileName
         else String -> Int -> IO Font
forall (m :: * -> *). MonadIO m => String -> Int -> m Font
TTF.load String
fontFileName Int
fontSize
     setHintMode :: Font -> HintingMode -> m ()
setHintMode _ HintingHeavy = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()  -- default
     setHintMode sdlFont :: Font
sdlFont HintingLight = Font -> Hinting -> m ()
forall (m :: * -> *). MonadIO m => Font -> Hinting -> m ()
TTF.setHinting Font
sdlFont Hinting
TTF.Light
 (squareFont :: Font
squareFont, squareFontSize :: Int
squareFontSize, mapFontIsBitmap :: Bool
mapFontIsBitmap) <-
   if Maybe Double -> Double
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Double
sallFontsScale Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== 1.0 then do
     Maybe (Font, Int)
mfontMapBitmap <- 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
fontMapBitmap FontSet
chosenFontset
     case Maybe (Font, Int)
mfontMapBitmap of
       Just (sdlFont :: Font
sdlFont, size :: Int
size) -> (Font, Int, Bool) -> IO (Font, Int, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Font
sdlFont, Int
size, Bool
True)
       Nothing -> do
         Maybe (Font, Int)
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 Maybe (Font, Int)
mfontMapScalable of
           Just (sdlFont :: Font
sdlFont, size :: Int
size) -> (Font, Int, Bool) -> IO (Font, Int, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Font
sdlFont, Int
size, Bool
False)
           Nothing -> String -> IO (Font, Int, Bool)
forall a. HasCallStack => String -> a
error "Neither bitmap nor scalable map font defined"
   else do
     Maybe (Font, Int)
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 Maybe (Font, Int)
mfontMapScalable of
        Just (sdlFont :: Font
sdlFont, size :: Int
size) -> (Font, Int, Bool) -> IO (Font, Int, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Font
sdlFont, Int
size, Bool
False)
        Nothing -> String -> IO (Font, Int, Bool)
forall a. HasCallStack => String -> a
error "Scaling requested but scalable map font not defined"
 let halfSize :: Int
halfSize = Int
squareFontSize Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 2
     boxSize :: Int
boxSize = 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.
 Maybe Font
spropFont <- (Font, Int) -> Font
forall a b. (a, b) -> a
fst ((Font, Int) -> Font) -> IO (Maybe (Font, Int)) -> IO (Maybe Font)
forall (f :: * -> *) (g :: * -> *) a b.
(Functor f, Functor g) =>
(a -> b) -> f (g a) -> f (g b)
<$$> Text -> IO (Maybe (Font, Int))
findFontFile (FontSet -> Text
fontPropRegular FontSet
chosenFontset)
 Maybe Font
sboldFont <- (Font, Int) -> Font
forall a b. (a, b) -> a
fst ((Font, Int) -> Font) -> IO (Maybe (Font, Int)) -> IO (Maybe Font)
forall (f :: * -> *) (g :: * -> *) a b.
(Functor f, Functor g) =>
(a -> b) -> f (g a) -> f (g b)
<$$> Text -> IO (Maybe (Font, Int))
findFontFile (FontSet -> Text
fontPropBold FontSet
chosenFontset)
 Maybe Font
smonoFont <- (Font, Int) -> Font
forall a b. (a, b) -> a
fst ((Font, Int) -> Font) -> IO (Maybe (Font, Int)) -> IO (Maybe Font)
forall (f :: * -> *) (g :: * -> *) a b.
(Functor f, Functor g) =>
(a -> b) -> f (g a) -> f (g b)
<$$> Text -> IO (Maybe (Font, Int))
findFontFile (FontSet -> Text
fontMono FontSet
chosenFontset)
 let !_A :: ()
_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 -> (String, FontSet) -> Bool
forall a. Show a => Bool -> a -> Bool
`blame` "Either all auxiliary fonts should be defined or none"
          String -> FontSet -> (String, FontSet)
forall v. String -> v -> (String, 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 Maybe Int
slogPriority Maybe Int -> Maybe Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> Maybe Int
forall a. a -> Maybe a
Just 0 then do
  RawFrontend
rf <- ScreenContent -> (SingleFrame -> IO ()) -> IO () -> IO RawFrontend
createRawFrontend ScreenContent
coscreen (\_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
  MVar RawFrontend -> RawFrontend -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar RawFrontend
rfMVar RawFrontend
rf
  IO () -> (Font -> IO ()) -> Maybe Font -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) Font -> IO ()
forall (m :: * -> *). MonadIO m => Font -> m ()
TTF.free Maybe Font
spropFont
  IO () -> (Font -> IO ()) -> Maybe Font -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) Font -> IO ()
forall (m :: * -> *). MonadIO m => Font -> m ()
TTF.free Maybe Font
sboldFont
  IO () -> (Font -> IO ()) -> Maybe Font -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) Font -> IO ()
forall (m :: * -> *). MonadIO m => Font -> m ()
TTF.free Maybe Font
smonoFont
  Font -> IO ()
forall (m :: * -> *). MonadIO m => Font -> m ()
TTF.free Font
squareFont
  IO ()
forall (m :: * -> *). MonadIO m => m ()
TTF.quit
  IO ()
forall (m :: * -> *). MonadIO m => m ()
SDL.quit
 else do
  -- The code below fails without access to a graphics system.
  [InitFlag] -> IO ()
forall (f :: * -> *) (m :: * -> *).
(Foldable f, Functor m, MonadIO m) =>
f InitFlag -> m ()
SDL.initialize [InitFlag
SDL.InitVideo]
  let screenV2 :: V2 CInt
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
windowConfig = WindowConfig
SDL.defaultWindow
        { windowInitialSize :: V2 CInt
SDL.windowInitialSize = V2 CInt
screenV2
        , windowMode :: WindowMode
SDL.windowMode = case FullscreenMode -> Maybe FullscreenMode -> FullscreenMode
forall a. a -> Maybe a -> a
fromMaybe FullscreenMode
NotFullscreen Maybe FullscreenMode
sfullscreenMode of
            ModeChange -> WindowMode
SDL.Fullscreen
            BigBorderlessWindow -> WindowMode
SDL.FullscreenDesktop
            NotFullscreen -> WindowMode
SDL.Windowed }
      rendererConfig :: RendererConfig
rendererConfig = RendererConfig :: RendererType -> Bool -> RendererConfig
SDL.RendererConfig
        { rendererType :: RendererType
rendererType          = if Bool
sbenchmark
                                  then RendererType
SDL.AcceleratedRenderer
                                  else RendererType
SDL.AcceleratedVSyncRenderer
        , rendererTargetTexture :: Bool
rendererTargetTexture = Bool
True
        }
  Window
swindow <- Text -> WindowConfig -> IO Window
forall (m :: * -> *). MonadIO m => Text -> WindowConfig -> m Window
SDL.createWindow Text
title WindowConfig
windowConfig
  Renderer
srenderer <- Window -> CInt -> RendererConfig -> IO Renderer
forall (m :: * -> *).
MonadIO m =>
Window -> CInt -> RendererConfig -> m Renderer
SDL.createRenderer Window
swindow (-1) RendererConfig
rendererConfig
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (FullscreenMode -> Maybe FullscreenMode -> FullscreenMode
forall a. a -> Maybe a -> a
fromMaybe FullscreenMode
NotFullscreen Maybe FullscreenMode
sfullscreenMode FullscreenMode -> FullscreenMode -> Bool
forall a. Eq a => a -> a -> Bool
== FullscreenMode
NotFullscreen) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    -- 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.
    Renderer -> StateVar (Maybe (V2 CInt))
SDL.rendererLogicalSize Renderer
srenderer StateVar (Maybe (V2 CInt)) -> Maybe (V2 CInt) -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
SDL.$= V2 CInt -> Maybe (V2 CInt)
forall a. a -> Maybe a
Just V2 CInt
screenV2
  let clearScreen :: IO ()
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 ()
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
  IO ()
clearScreen
  let initTexture :: IO Texture
initTexture = do
        Texture
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
        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 ()
SDL.$= Texture -> Maybe Texture
forall a. a -> Maybe a
Just Texture
texture
        Renderer -> StateVar BlendMode
SDL.rendererDrawBlendMode Renderer
srenderer StateVar BlendMode -> BlendMode -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
SDL.$= BlendMode
SDL.BlendNone
        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 ()
SDL.$= Color -> V4 Word8
colorToRGBA Color
Color.Black
        Renderer -> IO ()
forall (m :: * -> *). (Functor m, MonadIO m) => Renderer -> m ()
SDL.clear Renderer
srenderer  -- clear the texture
        Texture -> IO Texture
forall (m :: * -> *) a. Monad m => a -> m a
return Texture
texture
  Texture
basicTexture <- IO Texture
initTexture
  IORef Texture
sbasicTexture <- Texture -> IO (IORef Texture)
forall a. a -> IO (IORef a)
newIORef Texture
basicTexture
  Texture
texture <- IO Texture
initTexture
  IORef Texture
stexture <- Texture -> IO (IORef Texture)
forall a. a -> IO (IORef a)
newIORef Texture
texture
  IORef FontAtlas
squareAtlas <- FontAtlas -> IO (IORef FontAtlas)
forall a. a -> IO (IORef a)
newIORef FontAtlas
forall k a. EnumMap k a
EM.empty
  IORef FontAtlas
smonoAtlas <- FontAtlas -> IO (IORef FontAtlas)
forall a. a -> IO (IORef a)
newIORef FontAtlas
forall k a. EnumMap k a
EM.empty
  IORef SingleFrame
spreviousFrame <- SingleFrame -> IO (IORef SingleFrame)
forall a. a -> IO (IORef a)
newIORef (SingleFrame -> IO (IORef SingleFrame))
-> SingleFrame -> IO (IORef SingleFrame)
forall a b. (a -> b) -> a -> b
$ ScreenContent -> SingleFrame
blankSingleFrame ScreenContent
coscreen
  IORef Bool
sforcedShutdown <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
  IORef Bool
scontinueSdlLoop <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
True
  MVar SingleFrame
sframeQueue <- IO (MVar SingleFrame)
forall a. IO (MVar a)
newEmptyMVar
  MVar ()
sframeDrawn <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
  let sess :: FrontendSession
sess = $WFrontendSession :: Window
-> Renderer
-> Font
-> Int
-> Bool
-> Maybe Font
-> Maybe Font
-> Maybe Font
-> IORef FontAtlas
-> IORef FontAtlas
-> IORef Texture
-> IORef Texture
-> IORef SingleFrame
-> IORef Bool
-> IORef Bool
-> MVar SingleFrame
-> MVar ()
-> FrontendSession
FrontendSession{..}
  RawFrontend
rfWithoutPrintScreen <-
    ScreenContent -> (SingleFrame -> IO ()) -> IO () -> IO RawFrontend
createRawFrontend ScreenContent
coscreen (FrontendSession -> SingleFrame -> IO ()
display FrontendSession
sess) (FrontendSession -> IO ()
shutdown FrontendSession
sess)
  let rf :: RawFrontend
rf = RawFrontend
rfWithoutPrintScreen {fprintScreen :: IO ()
fprintScreen = FrontendSession -> IO ()
printScreen FrontendSession
sess}
  MVar RawFrontend -> RawFrontend -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar RawFrontend
rfMVar RawFrontend
rf
  let pointTranslate :: forall i. (Enum i) => Vect.Point Vect.V2 i -> PointUI
      pointTranslate :: Point V2 i -> PointUI
pointTranslate (SDL.P (SDL.V2 x :: i
x y :: 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 :: IO ()
redraw = do
        -- Textures may be trashed and even invalid, especially on Windows.
        FontAtlas
atlas <- IORef FontAtlas -> IO FontAtlas
forall a. IORef a -> IO a
readIORef IORef FontAtlas
squareAtlas
        IORef FontAtlas -> FontAtlas -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef FontAtlas
squareAtlas FontAtlas
forall k a. EnumMap k a
EM.empty
        FontAtlas
monoAtlas <- IORef FontAtlas -> IO FontAtlas
forall a. IORef a -> IO a
readIORef IORef FontAtlas
smonoAtlas
        IORef FontAtlas -> FontAtlas -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef FontAtlas
smonoAtlas FontAtlas
forall k a. EnumMap k a
EM.empty
        Texture
oldBasicTexture <- IORef Texture -> IO Texture
forall a. IORef a -> IO a
readIORef IORef Texture
sbasicTexture
        Texture
newBasicTexture <- IO Texture
initTexture
        Texture
oldTexture <- IORef Texture -> IO Texture
forall a. IORef a -> IO a
readIORef IORef Texture
stexture
        Texture
newTexture <- IO Texture
initTexture
        (Texture -> IO ()) -> [Texture] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m ()) -> t a -> m ()
mapM_ Texture -> IO ()
forall (m :: * -> *). MonadIO m => Texture -> m ()
SDL.destroyTexture ([Texture] -> IO ()) -> [Texture] -> IO ()
forall a b. (a -> b) -> a -> b
$ FontAtlas -> [Texture]
forall k a. EnumMap k a -> [a]
EM.elems FontAtlas
atlas
        (Texture -> IO ()) -> [Texture] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m ()) -> t a -> m ()
mapM_ Texture -> IO ()
forall (m :: * -> *). MonadIO m => Texture -> m ()
SDL.destroyTexture ([Texture] -> IO ()) -> [Texture] -> IO ()
forall a b. (a -> b) -> a -> b
$ FontAtlas -> [Texture]
forall k a. EnumMap k a -> [a]
EM.elems FontAtlas
monoAtlas
        Texture -> IO ()
forall (m :: * -> *). MonadIO m => Texture -> m ()
SDL.destroyTexture Texture
oldBasicTexture
        Texture -> IO ()
forall (m :: * -> *). MonadIO m => Texture -> m ()
SDL.destroyTexture Texture
oldTexture
        IORef Texture -> Texture -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Texture
sbasicTexture Texture
newBasicTexture
        IORef Texture -> Texture -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Texture
stexture Texture
newTexture
        -- To clear the margins in fullscreen:
        IO ()
clearScreen
        -- To overwrite each char:
        SingleFrame
prevFrame <- IORef SingleFrame -> IO SingleFrame
forall a. IORef a -> IO a
readIORef IORef SingleFrame
spreviousFrame
        IORef SingleFrame -> SingleFrame -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef SingleFrame
spreviousFrame (SingleFrame -> IO ()) -> SingleFrame -> IO ()
forall a b. (a -> b) -> a -> b
$ ScreenContent -> SingleFrame
blankSingleFrame ScreenContent
coscreen
        ScreenContent
-> ClientOptions -> FrontendSession -> SingleFrame -> IO ()
drawFrame ScreenContent
coscreen ClientOptions
soptions FrontendSession
sess SingleFrame
prevFrame
      loopSDL :: IO ()
      loopSDL :: IO ()
loopSDL = do
        Maybe Event
me <- IO (Maybe Event)
forall (m :: * -> *). MonadIO m => m (Maybe Event)
SDL.pollEvent  -- events take precedence over frames
        case Maybe Event
me of
          Nothing -> do
            Maybe SingleFrame
mfr <- MVar SingleFrame -> IO (Maybe SingleFrame)
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar SingleFrame
sframeQueue
            case Maybe SingleFrame
mfr of
              Just fr :: 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
              Nothing -> Int -> IO ()
threadDelay (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ if Bool
sbenchmark then 150 else 15000
                           -- 60 polls per second, so keyboard snappy enough;
                           -- max 6000 FPS when benchmarking
          Just e :: Event
e -> Event -> IO ()
handleEvent Event
e
        Bool
continueSdlLoop <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
scontinueSdlLoop
        if Bool
continueSdlLoop
        then IO ()
loopSDL
        else do
          IO () -> (Font -> IO ()) -> Maybe Font -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) Font -> IO ()
forall (m :: * -> *). MonadIO m => Font -> m ()
TTF.free Maybe Font
spropFont
          IO () -> (Font -> IO ()) -> Maybe Font -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) Font -> IO ()
forall (m :: * -> *). MonadIO m => Font -> m ()
TTF.free Maybe Font
sboldFont
          IO () -> (Font -> IO ()) -> Maybe Font -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) Font -> IO ()
forall (m :: * -> *). MonadIO m => Font -> m ()
TTF.free Maybe Font
smonoFont
          Font -> IO ()
forall (m :: * -> *). MonadIO m => Font -> m ()
TTF.free Font
squareFont
          IO ()
forall (m :: * -> *). MonadIO m => m ()
TTF.quit
          Renderer -> IO ()
forall (m :: * -> *). MonadIO m => Renderer -> m ()
SDL.destroyRenderer Renderer
srenderer
          Window -> IO ()
forall (m :: * -> *). MonadIO m => Window -> m ()
SDL.destroyWindow Window
swindow
          IO ()
forall (m :: * -> *). MonadIO m => m ()
SDL.quit
          Bool
forcedShutdown <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
sforcedShutdown
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
forcedShutdown
            IO ()
forall a. IO a
exitSuccess  -- not in the main thread, so no exit yet, see "Main"
      handleEvent :: Event -> IO ()
handleEvent e :: Event
e = case Event -> EventPayload
SDL.eventPayload Event
e of
        SDL.KeyboardEvent 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.
                  K.Shift -> Modifier
K.NoModifier
                  K.ControlShift -> Modifier
K.Control
                  K.AltShift -> Modifier
K.Alt
                  _ -> Modifier
modifier
            Point V2 CInt
p <- IO (Point V2 CInt)
forall (m :: * -> *). MonadIO m => m (Point V2 CInt)
SDL.getAbsoluteMouseLocation
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Key
key Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
== Key
K.Esc) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ TQueue KMP -> IO ()
resetChanKey (RawFrontend -> TQueue KMP
fchanKey RawFrontend
rf)
            RawFrontend -> Modifier -> Key -> PointUI -> IO ()
saveKMP RawFrontend
rf Modifier
modifierNoShift Key
key (Point V2 CInt -> PointUI
forall i. Enum i => Point V2 i -> PointUI
pointTranslate Point V2 CInt
p)
        SDL.MouseButtonEvent mouseButtonEvent :: MouseButtonEventData
mouseButtonEvent
          | MouseButtonEventData -> InputMotion
SDL.mouseButtonEventMotion MouseButtonEventData
mouseButtonEvent InputMotion -> InputMotion -> Bool
forall a. Eq a => a -> a -> Bool
== InputMotion
SDL.Released -> do
            Modifier
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 :: Key
key = case MouseButtonEventData -> MouseButton
SDL.mouseButtonEventButton MouseButtonEventData
mouseButtonEvent of
                  SDL.ButtonLeft -> Key
K.LeftButtonRelease
                  SDL.ButtonMiddle -> Key
K.MiddleButtonRelease
                  SDL.ButtonRight -> Key
K.RightButtonRelease
                  _ -> Key
K.LeftButtonRelease  -- any other is spare left
                p :: Point V2 Int32
p = MouseButtonEventData -> Point V2 Int32
SDL.mouseButtonEventPos MouseButtonEventData
mouseButtonEvent
            RawFrontend -> Modifier -> Key -> PointUI -> IO ()
saveKMP RawFrontend
rf Modifier
modifier Key
key (Point V2 Int32 -> PointUI
forall i. Enum i => Point V2 i -> PointUI
pointTranslate Point V2 Int32
p)
        SDL.MouseWheelEvent mouseWheelEvent :: MouseWheelEventData
mouseWheelEvent -> do
          Modifier
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 :: Int32
y = MouseWheelEventData -> V2 Int32
SDL.mouseWheelEventPos MouseWheelEventData
mouseWheelEvent
              mkey :: Maybe Key
mkey = case (Int32 -> Int32 -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int32
y 0, MouseWheelEventData -> MouseScrollDirection
SDL.mouseWheelEventDirection
                                          MouseWheelEventData
mouseWheelEvent) of
                (EQ, _) -> Maybe Key
forall a. Maybe a
Nothing
                (LT, SDL.ScrollNormal) -> Key -> Maybe Key
forall a. a -> Maybe a
Just Key
K.WheelSouth
                (GT, SDL.ScrollNormal) -> Key -> Maybe Key
forall a. a -> Maybe a
Just Key
K.WheelNorth
                (LT, SDL.ScrollFlipped) -> Key -> Maybe Key
forall a. a -> Maybe a
Just Key
K.WheelNorth
                (GT, SDL.ScrollFlipped) -> Key -> Maybe Key
forall a. a -> Maybe a
Just Key
K.WheelSouth
          Point V2 CInt
p <- IO (Point V2 CInt)
forall (m :: * -> *). MonadIO m => m (Point V2 CInt)
SDL.getAbsoluteMouseLocation
          IO () -> (Key -> IO ()) -> Maybe Key -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
                (\key :: 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)) Maybe Key
mkey
        SDL.WindowClosedEvent{} -> FrontendSession -> IO ()
forceShutdown FrontendSession
sess
        SDL.QuitEvent -> FrontendSession -> IO ()
forceShutdown FrontendSession
sess
        SDL.WindowRestoredEvent{} -> IO ()
redraw
        SDL.WindowExposedEvent{} -> IO ()
redraw  -- needed on Windows
        -- Probably not needed, because no textures nor their content lost:
        -- SDL.WindowShownEvent{} -> redraw
        _ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  IO ()
loopSDL

shutdown :: FrontendSession -> IO ()
shutdown :: FrontendSession -> IO ()
shutdown FrontendSession{..} = 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{..} = 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{..} curFrame :: SingleFrame
curFrame = do
  Bool
continueSdlLoop <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
scontinueSdlLoop
  if Bool
continueSdlLoop then do
    MVar SingleFrame -> SingleFrame -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar SingleFrame
sframeQueue SingleFrame
curFrame
    -- Wait until the frame is drawn.
    MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
sframeDrawn
  else do
    Bool
forcedShutdown <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
sforcedShutdown
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
forcedShutdown (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      -- 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".
      Int -> IO ()
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 coscreen :: ScreenContent
coscreen ClientOptions{..} sess :: FrontendSession
sess@FrontendSession{..} curFrame :: SingleFrame
curFrame = do
  SingleFrame
prevFrame <- IORef SingleFrame -> IO SingleFrame
forall a. IORef a -> IO a
readIORef IORef SingleFrame
spreviousFrame
  let halfSize :: Int
halfSize = Int
squareFontSize Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 2
      boxSize :: Int
boxSize = 2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
halfSize
      vp :: Int -> Int -> Vect.Point Vect.V2 CInt
      vp :: Int -> Int -> Point V2 CInt
vp x :: Int
x y :: 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 -> Int -> Color -> IO ()
drawHighlight !Int
x !Int
y !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 ()
SDL.$= Color -> V4 Word8
colorToRGBA Color
color
        let tt2Square :: V2 CInt
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)
            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
x Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
boxSize) (Int
y 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 ()
SDL.$= Color -> V4 Word8
colorToRGBA Color
Color.Black
          -- reset back to black
      chooseAndDrawHighlight :: Int -> Int -> Highlight -> IO ()
chooseAndDrawHighlight !Int
x !Int
y !Highlight
bg = case Highlight
bg of
        Color.HighlightNone -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Color.HighlightNoneCursor -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        _ -> Int -> Int -> Color -> IO ()
drawHighlight Int
x Int
y (Color -> IO ()) -> Color -> IO ()
forall a b. (a -> b) -> a -> b
$ Highlight -> Color
Color.highlightToColor Highlight
bg
      -- This also frees the surface it gets.
      scaleSurfaceToTexture :: Int -> SDL.Surface -> IO SDL.Texture
      scaleSurfaceToTexture :: Int -> Surface -> IO Texture
scaleSurfaceToTexture xsize :: Int
xsize textSurfaceRaw :: Surface
textSurfaceRaw = do
        Vect.V2 sw :: CInt
sw sh :: CInt
sh <- Surface -> IO (V2 CInt)
forall (m :: * -> *). MonadIO m => Surface -> m (V2 CInt)
SDL.surfaceDimensions Surface
textSurfaceRaw
        let width :: Int
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
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
xsrc = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max 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` 2
            ysrc :: Int
ysrc = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max 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` 2
            srcR :: Rectangle CInt
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
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` 2
            ytgt :: Int
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` 2
            tgtR :: Point V2 CInt
tgtR = Int -> Int -> Point V2 CInt
vp Int
xtgt Int
ytgt
            tt2 :: V2 CInt
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)
        Surface
textSurface <- V2 CInt -> PixelFormat -> IO Surface
forall (m :: * -> *).
(Functor m, MonadIO m) =>
V2 CInt -> PixelFormat -> m Surface
SDL.createRGBSurface V2 CInt
tt2 PixelFormat
SDL.ARGB8888
        Surface -> Maybe (Rectangle CInt) -> V4 Word8 -> IO ()
forall (m :: * -> *).
MonadIO m =>
Surface -> Maybe (Rectangle CInt) -> V4 Word8 -> m ()
SDL.surfaceFillRect Surface
textSurface Maybe (Rectangle CInt)
forall a. Maybe a
Nothing (Color -> V4 Word8
colorToRGBA Color
Color.Black)
        -- We crop surface rather than texture to set the resulting
        -- texture as @TextureAccessStatic@ via @createTextureFromSurface@,
        -- which otherwise we wouldn't be able to do.
        IO (Maybe (Rectangle CInt)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (Rectangle CInt)) -> IO ())
-> IO (Maybe (Rectangle CInt)) -> IO ()
forall a b. (a -> b) -> a -> b
$ Surface
-> Maybe (Rectangle CInt)
-> Surface
-> Maybe (Point V2 CInt)
-> IO (Maybe (Rectangle CInt))
forall (m :: * -> *).
MonadIO m =>
Surface
-> Maybe (Rectangle CInt)
-> Surface
-> Maybe (Point V2 CInt)
-> m (Maybe (Rectangle CInt))
SDL.surfaceBlit Surface
textSurfaceRaw (Rectangle CInt -> Maybe (Rectangle CInt)
forall a. a -> Maybe a
Just Rectangle CInt
srcR)
                               Surface
textSurface (Point V2 CInt -> Maybe (Point V2 CInt)
forall a. a -> Maybe a
Just Point V2 CInt
tgtR)
        Surface -> IO ()
forall (m :: * -> *). MonadIO m => Surface -> m ()
SDL.freeSurface Surface
textSurfaceRaw
        Texture
textTexture <- Renderer -> Surface -> IO Texture
forall (m :: * -> *).
(Functor m, MonadIO m) =>
Renderer -> Surface -> m Texture
SDL.createTextureFromSurface Renderer
srenderer Surface
textSurface
        Surface -> IO ()
forall (m :: * -> *). MonadIO m => Surface -> m ()
SDL.freeSurface Surface
textSurface
        Texture -> IO Texture
forall (m :: * -> *) a. Monad m => a -> m a
return Texture
textTexture
      -- This also frees the surface it gets.
      scaleSurfaceToTextureProp :: Int -> Int -> SDL.Surface
                                -> IO (Int, SDL.Texture)
      scaleSurfaceToTextureProp :: Int -> Int -> Surface -> IO (Int, Texture)
scaleSurfaceToTextureProp x :: Int
x row :: Int
row textSurfaceRaw :: Surface
textSurfaceRaw = do
        Vect.V2 sw :: CInt
sw sh :: CInt
sh <- Surface -> IO (V2 CInt)
forall (m :: * -> *). MonadIO m => Surface -> m (V2 CInt)
SDL.surfaceDimensions Surface
textSurfaceRaw
        let widthRaw :: Int
widthRaw = CInt -> Int
forall a. Enum a => a -> Int
fromEnum CInt
sw
            width :: Int
width = if Int
widthRaw 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
boxSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
x
                    then (ScreenContent -> Int
rwidth ScreenContent
coscreen Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
boxSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
x
                    else Int
widthRaw
            height :: Int
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
xsrc = 0
            ysrc :: Int
ysrc = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max 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` 2
            srcR :: Rectangle CInt
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
xtgt = 0
            ytgt :: Int
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` 2
            tgtR :: Point V2 CInt
tgtR = Int -> Int -> Point V2 CInt
vp Int
xtgt Int
ytgt
            tt2Prop :: V2 CInt
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)
        Surface
textSurface <- V2 CInt -> PixelFormat -> IO Surface
forall (m :: * -> *).
(Functor m, MonadIO m) =>
V2 CInt -> PixelFormat -> m Surface
SDL.createRGBSurface V2 CInt
tt2Prop PixelFormat
SDL.ARGB8888
        Surface -> Maybe (Rectangle CInt) -> V4 Word8 -> IO ()
forall (m :: * -> *).
MonadIO m =>
Surface -> Maybe (Rectangle CInt) -> V4 Word8 -> m ()
SDL.surfaceFillRect Surface
textSurface Maybe (Rectangle CInt)
forall a. Maybe a
Nothing (Color -> V4 Word8
colorToRGBA Color
Color.Black)
        -- 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.
        IO (Maybe (Rectangle CInt)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (Rectangle CInt)) -> IO ())
-> IO (Maybe (Rectangle CInt)) -> IO ()
forall a b. (a -> b) -> a -> b
$ Surface
-> Maybe (Rectangle CInt)
-> Surface
-> Maybe (Point V2 CInt)
-> IO (Maybe (Rectangle CInt))
forall (m :: * -> *).
MonadIO m =>
Surface
-> Maybe (Rectangle CInt)
-> Surface
-> Maybe (Point V2 CInt)
-> m (Maybe (Rectangle CInt))
SDL.surfaceBlit Surface
textSurfaceRaw (Rectangle CInt -> Maybe (Rectangle CInt)
forall a. a -> Maybe a
Just Rectangle CInt
srcR)
                               Surface
textSurface (Point V2 CInt -> Maybe (Point V2 CInt)
forall a. a -> Maybe a
Just Point V2 CInt
tgtR)
        Surface -> IO ()
forall (m :: * -> *). MonadIO m => Surface -> m ()
SDL.freeSurface Surface
textSurfaceRaw
        Texture
textTexture <- Renderer -> Surface -> IO Texture
forall (m :: * -> *).
(Functor m, MonadIO m) =>
Renderer -> Surface -> m Texture
SDL.createTextureFromSurface Renderer
srenderer Surface
textSurface
        Surface -> IO ()
forall (m :: * -> *). MonadIO m => Surface -> m ()
SDL.freeSurface Surface
textSurface
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
width Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
widthRaw) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          let greyDollar :: AttrCharW32
greyDollar = AttrCharW32
Color.trimmedLineAttrW32
          IO Int -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int -> IO ()) -> IO Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> (LogPriority, LogPriority) -> IO Int
setChar (Point -> Int
forall a. Enum a => a -> Int
fromEnum $WPoint :: Int -> Int -> Point
Point{px :: Int
px = ScreenContent -> Int
rwidth ScreenContent
coscreen Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1, py :: Int
py = Int
row})
                         (AttrCharW32 -> LogPriority
Color.attrCharW32 AttrCharW32
greyDollar, 0)
        (Int, Texture) -> IO (Int, Texture)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
width, Texture
textTexture)
      -- <https://www.libsdl.org/projects/SDL_ttf/docs/SDL_ttf_42.html#SEC42>
      setChar :: PointI -> (Word32, Word32) -> IO Int
      setChar :: Int -> (LogPriority, LogPriority) -> IO Int
setChar !Int
i (!LogPriority
w, !LogPriority
wPrev) =
        if LogPriority
w LogPriority -> LogPriority -> Bool
forall a. Eq a => a -> a -> Bool
== LogPriority
wPrev
        then Int -> IO Int
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
+ 1
        else do
          let Point{..} = Int -> Point
forall a. Enum a => Int -> a
toEnum Int
i
          FontAtlas
atlas <- IORef FontAtlas -> IO FontAtlas
forall a. IORef a -> IO a
readIORef IORef FontAtlas
squareAtlas
          let Color.AttrChar{ acAttr :: AttrChar -> Attr
acAttr=Color.Attr{fg :: Attr -> Color
fg=Color
fgRaw, Highlight
bg :: Attr -> Highlight
bg :: Highlight
bg}
                            , acChar :: AttrChar -> Char
acChar=Char
acCharRaw } =
                AttrCharW32 -> AttrChar
Color.attrCharFromW32 (AttrCharW32 -> AttrChar) -> AttrCharW32 -> AttrChar
forall a b. (a -> b) -> a -> b
$ LogPriority -> AttrCharW32
Color.AttrCharW32 LogPriority
w
              fg :: Color
fg | Int
py Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` 2 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 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 :: AttrCharW32
ac = Color -> Char -> AttrCharW32
Color.attrChar2ToW32 Color
fg Char
acCharRaw
          Texture
textTexture <- case AttrCharW32 -> FontAtlas -> Maybe Texture
forall k a. Enum k => k -> EnumMap k a -> Maybe a
EM.lookup AttrCharW32
ac FontAtlas
atlas of
            Nothing -> do
              -- Make all visible floors bold (no bold fold 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 '\x0007'
                                else '\x22C5'
                           else Char
acCharRaw
              Surface
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)
                                                (Color -> V4 Word8
colorToRGBA Color
Color.Black) Char
acChar
              Texture
textTexture <- Int -> Surface -> IO Texture
scaleSurfaceToTexture Int
boxSize Surface
textSurfaceRaw
              IORef FontAtlas -> FontAtlas -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef FontAtlas
squareAtlas (FontAtlas -> IO ()) -> FontAtlas -> IO ()
forall a b. (a -> b) -> a -> b
$ AttrCharW32 -> Texture -> FontAtlas -> FontAtlas
forall k a. Enum k => k -> a -> EnumMap k a -> EnumMap k a
EM.insert AttrCharW32
ac Texture
textTexture FontAtlas
atlas
              Texture -> IO Texture
forall (m :: * -> *) a. Monad m => a -> m a
return Texture
textTexture
            Just textTexture :: Texture
textTexture -> Texture -> IO Texture
forall (m :: * -> *) a. Monad m => a -> m a
return Texture
textTexture
          let tt2Square :: V2 CInt
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)
              tgtR :: Rectangle CInt
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
px Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
boxSize) (Int
py Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
boxSize)) V2 CInt
tt2Square
          Renderer
-> Texture
-> Maybe (Rectangle CInt)
-> Maybe (Rectangle CInt)
-> IO ()
forall (m :: * -> *).
MonadIO m =>
Renderer
-> Texture
-> Maybe (Rectangle CInt)
-> Maybe (Rectangle CInt)
-> m ()
SDL.copy Renderer
srenderer Texture
textTexture Maybe (Rectangle CInt)
forall a. Maybe a
Nothing (Rectangle CInt -> Maybe (Rectangle CInt)
forall a. a -> Maybe a
Just Rectangle CInt
tgtR)
          -- Potentially overwrite a portion of the glyph.
          Int -> Int -> Highlight -> IO ()
chooseAndDrawHighlight Int
px Int
py Highlight
bg
          Int -> IO Int
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
+ 1
      drawMonoOverlay :: OverlaySpace -> IO ()
      drawMonoOverlay :: OverlaySpace -> IO ()
drawMonoOverlay =
        ((PointUI, [AttrCharW32]) -> IO ()) -> OverlaySpace -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m ()) -> t a -> m ()
mapM_ (\(PointUI x :: Int
x y :: Int
y, al :: [AttrCharW32]
al) ->
                 let lineCut :: [AttrCharW32]
lineCut = Int -> [AttrCharW32] -> [AttrCharW32]
forall a. Int -> [a] -> [a]
take (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) [AttrCharW32]
al
                 in Int -> Int -> [AttrCharW32] -> IO ()
drawMonoLine (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
halfSize) Int
y [AttrCharW32]
lineCut)
      drawMonoLine :: Int -> Int -> AttrString -> IO ()
      drawMonoLine :: Int -> Int -> [AttrCharW32] -> IO ()
drawMonoLine _ _ [] = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      drawMonoLine x :: Int
x row :: Int
row (w :: AttrCharW32
w : rest :: [AttrCharW32]
rest) = do
        Int -> Int -> AttrCharW32 -> IO ()
setMonoChar Int
x Int
row AttrCharW32
w
        Int -> Int -> [AttrCharW32] -> IO ()
drawMonoLine (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
halfSize) Int
row [AttrCharW32]
rest
      setMonoChar :: Int -> Int -> Color.AttrCharW32 -> IO ()
      setMonoChar :: Int -> Int -> AttrCharW32 -> IO ()
setMonoChar !Int
x !Int
row !AttrCharW32
w = do
        FontAtlas
atlas <- IORef FontAtlas -> IO FontAtlas
forall a. IORef a -> IO a
readIORef IORef FontAtlas
smonoAtlas
        let Color.AttrChar{acAttr :: AttrChar -> Attr
acAttr=Color.Attr{fg :: Attr -> Color
fg=Color
fgRaw, Highlight
bg :: Highlight
bg :: Attr -> Highlight
bg}, Char
acChar :: Char
acChar :: AttrChar -> Char
acChar} =
              AttrCharW32 -> AttrChar
Color.attrCharFromW32 AttrCharW32
w
            fg :: Color
fg | Int
row Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` 2 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 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 :: AttrCharW32
ac = Color -> Char -> AttrCharW32
Color.attrChar2ToW32 Color
fg Char
acChar
            !_A :: ()
_A = Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert (Highlight
bg Highlight -> [Highlight] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ Highlight
Color.HighlightNone
                                    , Highlight
Color.HighlightNoneCursor ]) ()
        Texture
textTexture <- case AttrCharW32 -> FontAtlas -> Maybe Texture
forall k a. Enum k => k -> EnumMap k a -> Maybe a
EM.lookup AttrCharW32
ac FontAtlas
atlas of
          Nothing -> do
            Surface
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)
                              (Color -> V4 Word8
colorToRGBA Color
Color.Black) Char
acChar
            Texture
textTexture <- Int -> Surface -> IO Texture
scaleSurfaceToTexture Int
halfSize Surface
textSurfaceRaw
            IORef FontAtlas -> FontAtlas -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef FontAtlas
smonoAtlas (FontAtlas -> IO ()) -> FontAtlas -> IO ()
forall a b. (a -> b) -> a -> b
$ AttrCharW32 -> Texture -> FontAtlas -> FontAtlas
forall k a. Enum k => k -> a -> EnumMap k a -> EnumMap k a
EM.insert AttrCharW32
ac Texture
textTexture FontAtlas
atlas
            Texture -> IO Texture
forall (m :: * -> *) a. Monad m => a -> m a
return Texture
textTexture
          Just textTexture :: Texture
textTexture -> Texture -> IO Texture
forall (m :: * -> *) a. Monad m => a -> m a
return Texture
textTexture
        let tt2Mono :: V2 CInt
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 :: Rectangle CInt
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)) V2 CInt
tt2Mono
        Renderer
-> Texture
-> Maybe (Rectangle CInt)
-> Maybe (Rectangle CInt)
-> IO ()
forall (m :: * -> *).
MonadIO m =>
Renderer
-> Texture
-> Maybe (Rectangle CInt)
-> Maybe (Rectangle CInt)
-> m ()
SDL.copy Renderer
srenderer Texture
textTexture Maybe (Rectangle CInt)
forall a. Maybe a
Nothing (Rectangle CInt -> Maybe (Rectangle CInt)
forall a. a -> Maybe a
Just Rectangle CInt
tgtR)
      drawPropOverlay :: OverlaySpace -> IO ()
      drawPropOverlay :: OverlaySpace -> IO ()
drawPropOverlay =
        ((PointUI, [AttrCharW32]) -> IO ()) -> OverlaySpace -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m ()) -> t a -> m ()
mapM_ (\(PointUI x :: Int
x y :: Int
y, al :: [AttrCharW32]
al) ->
                 Int -> Int -> [AttrCharW32] -> IO ()
drawPropLine (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
halfSize) Int
y [AttrCharW32]
al)
      drawPropLine :: Int -> Int -> AttrString -> IO ()
      drawPropLine :: Int -> Int -> [AttrCharW32] -> IO ()
drawPropLine _ _ [] = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      drawPropLine x :: Int
x _ _ | 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
- 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 (m :: * -> *) a. Monad m => a -> m a
return ()
      drawPropLine x :: Int
x row :: Int
row (w :: AttrCharW32
w : rest :: [AttrCharW32]
rest) = do
        let isSpace :: AttrCharW32 -> Bool
isSpace = (AttrCharW32 -> [AttrCharW32] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [AttrCharW32
Color.spaceAttrW32, AttrCharW32
Color.spaceCursorAttrW32])
            Color.AttrChar{acAttr :: AttrChar -> Attr
acAttr=Color.Attr{fg :: Attr -> Color
fg=Color
fgRaw, Highlight
bg :: Highlight
bg :: Attr -> 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) -> [AttrCharW32] -> [AttrCharW32]
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) [AttrCharW32]
rest of
                  w2 :: AttrCharW32
w2 : _ -> AttrCharW32
w2
                  [] -> AttrCharW32
w
                else AttrCharW32
w
            sameAttr :: AttrCharW32 -> Bool
sameAttr ac :: 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
            (sameRest :: [AttrCharW32]
sameRest, otherRest :: [AttrCharW32]
otherRest) = (AttrCharW32 -> Bool)
-> [AttrCharW32] -> ([AttrCharW32], [AttrCharW32])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span AttrCharW32 -> Bool
sameAttr [AttrCharW32]
rest
            !_A :: ()
_A = Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert (Highlight
bg Highlight -> [Highlight] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ Highlight
Color.HighlightNone
                                    , Highlight
Color.HighlightNoneCursor ]) ()
            fg :: Color
fg | Int
row Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` 2 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 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 = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ (AttrCharW32 -> Char) -> [AttrCharW32] -> String
forall a b. (a -> b) -> [a] -> [b]
map AttrCharW32 -> Char
Color.charFromW32 ([AttrCharW32] -> String) -> [AttrCharW32] -> String
forall a b. (a -> b) -> a -> b
$ AttrCharW32
w AttrCharW32 -> [AttrCharW32] -> [AttrCharW32]
forall a. a -> [a] -> [a]
: [AttrCharW32]
sameRest
        Int
width <- Int -> Int -> Color -> Text -> IO Int
drawPropChunk Int
x Int
row Color
fg Text
t
        Int -> Int -> [AttrCharW32] -> IO ()
drawPropLine (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
width) Int
row [AttrCharW32]
otherRest
      drawPropChunk :: Int -> Int -> Color.Color -> T.Text -> IO Int
      drawPropChunk :: Int -> Int -> Color -> Text -> IO Int
drawPropChunk x :: Int
x row :: Int
row fg :: Color
fg t :: 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
        Surface
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)
                                     (Color -> V4 Word8
colorToRGBA Color
Color.Black) Text
t
        (width :: Int
width, textTexture :: Texture
textTexture) <- Int -> Int -> Surface -> IO (Int, Texture)
scaleSurfaceToTextureProp Int
x Int
row Surface
textSurfaceRaw
        let tgtR :: Rectangle CInt
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.
        Renderer
-> Texture
-> Maybe (Rectangle CInt)
-> Maybe (Rectangle CInt)
-> IO ()
forall (m :: * -> *).
MonadIO m =>
Renderer
-> Texture
-> Maybe (Rectangle CInt)
-> Maybe (Rectangle CInt)
-> m ()
SDL.copy Renderer
srenderer Texture
textTexture Maybe (Rectangle CInt)
forall a. Maybe a
Nothing (Rectangle CInt -> Maybe (Rectangle CInt)
forall a. a -> Maybe a
Just Rectangle CInt
tgtR)
        Texture -> IO ()
forall (m :: * -> *). MonadIO m => Texture -> m ()
SDL.destroyTexture Texture
textTexture
        Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
width
  let arraysEqual :: Bool
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 :: Bool
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
singlePropOverlay SingleFrame
curFrame OverlaySpace -> OverlaySpace -> Bool
forall a. Eq a => a -> a -> Bool
== SingleFrame -> OverlaySpace
singlePropOverlay SingleFrame
prevFrame
  Texture
basicTexture <- IORef Texture -> IO Texture
forall a. IORef a -> IO a
readIORef IORef Texture
sbasicTexture  -- previous content still present
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
arraysEqual (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    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 ()
SDL.$= Texture -> Maybe Texture
forall a. a -> Maybe a
Just Texture
basicTexture
    (Int -> (LogPriority, LogPriority) -> IO Int)
-> Int -> Vector (LogPriority, LogPriority) -> IO ()
forall (m :: * -> *) b a.
(Monad m, Unbox b) =>
(a -> b -> m a) -> a -> Vector b -> m ()
U.foldM'_ Int -> (LogPriority, LogPriority) -> IO Int
setChar 0 (Vector (LogPriority, LogPriority) -> IO ())
-> Vector (LogPriority, LogPriority) -> IO ()
forall a b. (a -> b) -> a -> b
$ Vector LogPriority
-> Vector LogPriority -> Vector (LogPriority, LogPriority)
forall a b.
(Unbox a, Unbox b) =>
Vector a -> Vector b -> Vector (a, b)
U.zip (Array AttrCharW32 -> Vector LogPriority
forall c. Array c -> Vector (UnboxRep c)
PointArray.avector (Array AttrCharW32 -> Vector LogPriority)
-> Array AttrCharW32 -> Vector LogPriority
forall a b. (a -> b) -> a -> b
$ SingleFrame -> Array AttrCharW32
singleArray SingleFrame
curFrame)
                                (Array AttrCharW32 -> Vector LogPriority
forall c. Array c -> Vector (UnboxRep c)
PointArray.avector (Array AttrCharW32 -> Vector LogPriority)
-> Array AttrCharW32 -> Vector LogPriority
forall a b. (a -> b) -> a -> b
$ SingleFrame -> Array AttrCharW32
singleArray SingleFrame
prevFrame)
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
arraysEqual Bool -> Bool -> Bool
&& Bool
overlaysEqual) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Texture
texture <- IORef Texture -> IO Texture
forall a. IORef a -> IO a
readIORef IORef Texture
stexture
    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 ()
SDL.$= Texture -> Maybe Texture
forall a. a -> Maybe a
Just Texture
texture
    Renderer
-> Texture
-> Maybe (Rectangle CInt)
-> Maybe (Rectangle CInt)
-> IO ()
forall (m :: * -> *).
MonadIO m =>
Renderer
-> Texture
-> Maybe (Rectangle CInt)
-> Maybe (Rectangle CInt)
-> m ()
SDL.copy Renderer
srenderer Texture
basicTexture Maybe (Rectangle CInt)
forall a. Maybe a
Nothing Maybe (Rectangle CInt)
forall a. Maybe a
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.
    OverlaySpace -> IO ()
drawPropOverlay (OverlaySpace -> IO ()) -> OverlaySpace -> IO ()
forall a b. (a -> b) -> a -> b
$ SingleFrame -> OverlaySpace
singlePropOverlay SingleFrame
curFrame
    OverlaySpace -> IO ()
drawMonoOverlay (OverlaySpace -> IO ()) -> OverlaySpace -> IO ()
forall a b. (a -> b) -> a -> b
$ SingleFrame -> OverlaySpace
singleMonoOverlay SingleFrame
curFrame
    IORef SingleFrame -> SingleFrame -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef SingleFrame
spreviousFrame SingleFrame
curFrame
    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 ()
SDL.$= Maybe Texture
forall a. Maybe a
Nothing
    Renderer
-> Texture
-> Maybe (Rectangle CInt)
-> Maybe (Rectangle CInt)
-> IO ()
forall (m :: * -> *).
MonadIO m =>
Renderer
-> Texture
-> Maybe (Rectangle CInt)
-> Maybe (Rectangle CInt)
-> m ()
SDL.copy Renderer
srenderer Texture
texture Maybe (Rectangle CInt)
forall a. Maybe a
Nothing Maybe (Rectangle CInt)
forall a. Maybe a
Nothing  -- overwrite the backbuffer
    Renderer -> IO ()
forall (m :: * -> *). MonadIO m => Renderer -> m ()
SDL.present Renderer
srenderer
    -- We can't print screen in @display@ due to thread-unsafety.
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
sprintEachScreen (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FrontendSession -> IO ()
printScreen FrontendSession
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{..} = do
  String
dataDir <- IO String
appDataDir
  String -> IO ()
tryCreateDir String
dataDir
  String -> IO ()
tryCreateDir (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
dataDir String -> String -> String
</> "screenshots"
  UTCTime
utcTime <- IO UTCTime
getCurrentTime
  TimeZone
timezone <- UTCTime -> IO TimeZone
getTimeZone UTCTime
utcTime
  let unspace :: String -> String
unspace = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map ((Char -> Char) -> String -> String)
-> (Char -> Char) -> String -> String
forall a b. (a -> b) -> a -> b
$ \c :: Char
c -> case Char
c of  -- prevent the need for backquoting
        ' ' -> '_'
        ':' -> '.'
        _ -> Char
c
      dateText :: String
dateText = String -> String
unspace (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
forall a. Int -> [a] -> [a]
take 25 (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ LocalTime -> String
forall a. Show a => a -> String
show (LocalTime -> String) -> LocalTime -> String
forall a b. (a -> b) -> a -> b
$ TimeZone -> UTCTime -> LocalTime
utcToLocalTime TimeZone
timezone UTCTime
utcTime
      fileName :: String
fileName = String
dataDir String -> String -> String
</> "screenshots" String -> String -> String
</> "prtscn" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
dateText String -> String -> String
<.> "bmp"
      SDL.Internal.Types.Renderer renderer :: Renderer
renderer = Renderer
srenderer
  Vect.V2 sw :: CInt
sw sh :: CInt
sh <- StateVar (V2 CInt) -> IO (V2 CInt)
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
SDL.get (StateVar (V2 CInt) -> IO (V2 CInt))
-> StateVar (V2 CInt) -> IO (V2 CInt)
forall a b. (a -> b) -> a -> b
$ Window -> StateVar (V2 CInt)
SDL.windowSize Window
swindow
  Ptr Surface
ptrOut <- LogPriority
-> CInt
-> CInt
-> CInt
-> LogPriority
-> LogPriority
-> LogPriority
-> LogPriority
-> IO (Ptr Surface)
forall (m :: * -> *).
MonadIO m =>
LogPriority
-> CInt
-> CInt
-> CInt
-> LogPriority
-> LogPriority
-> LogPriority
-> LogPriority
-> m (Ptr Surface)
SDL.Raw.Video.createRGBSurface 0 CInt
sw CInt
sh 32 0 0 0 0
  Surface
surfaceOut <- Ptr Surface -> IO Surface
forall a. Storable a => Ptr a -> IO a
peek Ptr Surface
ptrOut
  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
$ Renderer -> Ptr Rect -> LogPriority -> Renderer -> CInt -> IO CInt
forall (m :: * -> *).
MonadIO m =>
Renderer -> Ptr Rect -> LogPriority -> Renderer -> CInt -> m CInt
SDL.Raw.Video.renderReadPixels
    Renderer
renderer
    Ptr Rect
forall a. Ptr a
nullPtr
    LogPriority
forall a. (Eq a, Num a) => a
SDL.Raw.Enum.SDL_PIXELFORMAT_ARGB8888
    (Surface -> Renderer
SDL.Raw.Types.surfacePixels Surface
surfaceOut)
    (CInt
sw CInt -> CInt -> CInt
forall a. Num a => a -> a -> a
* 4)
  String -> (CString -> IO ()) -> IO ()
forall a. String -> (CString -> IO a) -> IO a
withCString String
fileName ((CString -> IO ()) -> IO ()) -> (CString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \fileNameCString :: 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
  Ptr Surface -> IO ()
forall (m :: * -> *). MonadIO m => Ptr Surface -> m ()
SDL.Raw.Video.freeSurface Ptr Surface
ptrOut

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


sDL_ALPHA_OPAQUE :: Word8
sDL_ALPHA_OPAQUE :: Word8
sDL_ALPHA_OPAQUE = 255

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