module Game.LambdaHack.Client.UI.Frontend.Sdl
( startup, frontendName
#ifdef EXPOSE_INTERNAL
, FontAtlas, FrontendSession(..), startupFun, shutdown, forceShutdown
, display, drawFrame, printScreen, modTranslate, keyTranslate, colorToRGBA
#endif
) where
import Prelude ()
import Game.LambdaHack.Core.Prelude
import Control.Concurrent
import qualified Data.Char as Char
import qualified Data.EnumMap.Strict as EM
import Data.IORef
import qualified Data.Text as T
import Data.Time.Clock.POSIX
import Data.Time.LocalTime
import qualified Data.Vector.Storable as VS
import qualified Data.Vector.Unboxed as U
import Data.Word (Word32, Word8)
import Foreign.C.String (withCString)
import Foreign.C.Types (CInt)
import Foreign.Ptr (nullPtr)
import Foreign.Storable (peek)
import System.Directory
import System.Exit (die, exitSuccess)
import System.FilePath
import qualified SDL
import qualified SDL.Font as TTF
import SDL.Input.Keyboard.Codes
import qualified SDL.Internal.Types
import qualified SDL.Raw.Basic as SDL (logSetAllPriority)
import qualified SDL.Raw.Enum
import qualified SDL.Raw.Event
import qualified SDL.Raw.Types
import qualified SDL.Raw.Video
import qualified SDL.Vect as Vect
import Game.LambdaHack.Client.UI.Content.Screen
import Game.LambdaHack.Client.UI.Frame
import Game.LambdaHack.Client.UI.Frontend.Common
import qualified Game.LambdaHack.Client.UI.Key as K
import Game.LambdaHack.Client.UI.Overlay
import Game.LambdaHack.Client.UI.PointUI
import Game.LambdaHack.Common.ClientOptions
import Game.LambdaHack.Common.File
import Game.LambdaHack.Common.Misc
import Game.LambdaHack.Common.Point
import qualified Game.LambdaHack.Common.PointArray as PointArray
import Game.LambdaHack.Content.TileKind (floorSymbol)
import qualified Game.LambdaHack.Definition.Color as Color
import Control.Monad.IO.Class (MonadIO, liftIO)
import SDL.Internal.Exception (throwIfNull)
import qualified SDL.Raw.Event as Raw
import Unsafe.Coerce (unsafeCoerce)
type FontAtlas = EM.EnumMap Color.AttrCharW32 SDL.Texture
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 ()
}
frontendName :: String
frontendName :: String
frontendName = String
"sdl"
startup :: ScreenContent -> ClientOptions -> IO RawFrontend
startup :: ScreenContent -> ClientOptions -> IO RawFrontend
startup ScreenContent
coscreen ClientOptions
soptions = (MVar RawFrontend -> IO ()) -> IO RawFrontend
startupBound ((MVar RawFrontend -> IO ()) -> IO RawFrontend)
-> (MVar RawFrontend -> IO ()) -> IO RawFrontend
forall a b. (a -> b) -> a -> b
$ ScreenContent -> ClientOptions -> MVar RawFrontend -> IO ()
startupFun ScreenContent
coscreen ClientOptions
soptions
startupFun :: ScreenContent -> ClientOptions -> MVar RawFrontend -> IO ()
startupFun :: ScreenContent -> ClientOptions -> MVar RawFrontend -> IO ()
startupFun ScreenContent
coscreen soptions :: ClientOptions
soptions@ClientOptions{Bool
String
[(Text, FontSet)]
[(Text, FontDefinition)]
Maybe Bool
Maybe Double
Maybe Int
Maybe String
Maybe Text
Maybe FullscreenMode
sexposeActors :: ClientOptions -> Bool
sexposeItems :: ClientOptions -> Bool
sexposePlaces :: ClientOptions -> Bool
sprintEachScreen :: ClientOptions -> Bool
sstopAfterFrames :: ClientOptions -> Maybe Int
sstopAfterSeconds :: ClientOptions -> Maybe Int
sdbgMsgCli :: ClientOptions -> Bool
sfrontendLazy :: ClientOptions -> Bool
sfrontendNull :: ClientOptions -> Bool
sfrontendTeletype :: ClientOptions -> Bool
sfrontendANSI :: ClientOptions -> Bool
ssavePrefixCli :: ClientOptions -> String
stitle :: ClientOptions -> Maybe String
sbenchMessages :: ClientOptions -> Bool
sbenchmark :: ClientOptions -> Bool
snewGameCli :: ClientOptions -> Bool
snoAnim :: ClientOptions -> Maybe Bool
sdisableAutoYes :: ClientOptions -> Bool
smaxFps :: ClientOptions -> Maybe Double
slogPriority :: ClientOptions -> Maybe Int
sfullscreenMode :: ClientOptions -> Maybe FullscreenMode
sfontsets :: ClientOptions -> [(Text, FontSet)]
sfonts :: ClientOptions -> [(Text, FontDefinition)]
sallFontsScale :: ClientOptions -> Maybe Double
schosenFontset :: ClientOptions -> Maybe Text
sexposeActors :: Bool
sexposeItems :: Bool
sexposePlaces :: Bool
sprintEachScreen :: Bool
sstopAfterFrames :: Maybe Int
sstopAfterSeconds :: Maybe Int
sdbgMsgCli :: Bool
sfrontendLazy :: Bool
sfrontendNull :: Bool
sfrontendTeletype :: Bool
sfrontendANSI :: Bool
ssavePrefixCli :: String
stitle :: Maybe String
sbenchMessages :: Bool
sbenchmark :: Bool
snewGameCli :: Bool
snoAnim :: Maybe Bool
sdisableAutoYes :: Bool
smaxFps :: Maybe Double
slogPriority :: Maybe Int
sfullscreenMode :: Maybe FullscreenMode
sfontsets :: [(Text, FontSet)]
sfonts :: [(Text, FontDefinition)]
sallFontsScale :: Maybe Double
schosenFontset :: Maybe Text
..} MVar RawFrontend
rfMVar = do
[InitFlag] -> IO ()
forall (f :: * -> *) (m :: * -> *).
(Foldable f, Functor m, MonadIO m) =>
f InitFlag -> m ()
SDL.initialize [InitFlag
SDL.InitEvents]
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 Int
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
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
Maybe FontSet
Nothing -> String -> IO FontSet
forall a. String -> IO a
die (String -> IO FontSet) -> String -> IO FontSet
forall a b. (a -> b) -> a -> b
$ String
"Fontset not defined in config file"
String -> Text -> String
forall v. Show v => String -> v -> String
`showFailure` Text
chosenFontsetID
Just FontSet
fs -> FontSet -> IO FontSet
forall (m :: * -> *) a. Monad m => a -> m a
return FontSet
fs
let findFontFile :: Text -> IO (Maybe (Font, Int))
findFontFile 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
Maybe FontDefinition
Nothing -> String -> IO (Maybe (Font, Int))
forall a. String -> IO a
die (String -> IO (Maybe (Font, Int)))
-> String -> IO (Maybe (Font, Int))
forall a b. (a -> b) -> a -> b
$ String
"Font not defined in config file" String -> Text -> String
forall v. Show v => String -> v -> String
`showFailure` Text
t
Just (FontProportional Text
fname Int
fsize 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
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
> Int
0) ()
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 Text
fname Int
fsize 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
> Int
0) ()
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 Text
fname Int
fsize HintingMode
fhint 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
> Int
0) ()
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 Text
fname Int
cellSizeAdd) -> do
Font
sdlFont <- Text -> Int -> IO Font
loadFontFile Text
fname Int
0
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
> Int
0) ()
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 Text
fname 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
Maybe ByteString
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
$ String
"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]
++ String
" 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 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
$ String
"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 Font
_ HintingMode
HintingHeavy = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
setHintMode Font
sdlFont HintingMode
HintingLight = Font -> Hinting -> m ()
forall (m :: * -> *). MonadIO m => Font -> Hinting -> m ()
TTF.setHinting Font
sdlFont Hinting
TTF.Light
(Font
squareFont, Int
squareFontSize, 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
== Double
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 (Font
sdlFont, Int
size) -> (Font, Int, Bool) -> IO (Font, Int, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Font
sdlFont, Int
size, Bool
True)
Maybe (Font, Int)
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 (Font
sdlFont, Int
size) -> (Font, Int, Bool) -> IO (Font, Int, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Font
sdlFont, Int
size, Bool
False)
Maybe (Font, Int)
Nothing -> String -> IO (Font, Int, Bool)
forall a. String -> IO a
die String
"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 (Font
sdlFont, Int
size) -> (Font, Int, Bool) -> IO (Font, Int, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Font
sdlFont, Int
size, Bool
False)
Maybe (Font, Int)
Nothing -> String -> IO (Font, Int, Bool)
forall a. String -> IO a
die String
"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` Int
2
boxSize :: Int
boxSize = Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
halfSize
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` String
"Either all auxiliary fonts should be defined or none"
String -> FontSet -> (String, FontSet)
forall v. String -> v -> (String, v)
`swith` FontSet
chosenFontset) ()
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 Int
0 then do
RawFrontend
rf <- ScreenContent -> (SingleFrame -> IO ()) -> IO () -> IO RawFrontend
createRawFrontend ScreenContent
coscreen (\SingleFrame
_ -> () -> 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
[InitFlag] -> IO ()
forall (f :: * -> *) (m :: * -> *).
(Foldable f, Functor m, MonadIO m) =>
f InitFlag -> m ()
SDL.initialize [InitFlag
SDL.InitVideo]
let (Vector Word8
cursorAlpha, Vector Word8
cursorBW) = (Vector Word8, Vector Word8)
cursorXhair
Cursor
xhairCursor <-
Vector Word8
-> Vector Word8 -> V2 CInt -> Point V2 CInt -> IO Cursor
forall (m :: * -> *).
MonadIO m =>
Vector Word8
-> Vector Word8 -> V2 CInt -> Point V2 CInt -> m Cursor
createCursor Vector Word8
cursorBW Vector Word8
cursorAlpha (CInt -> CInt -> V2 CInt
forall a. a -> a -> V2 a
SDL.V2 CInt
32 CInt
27) (V2 CInt -> Point V2 CInt
forall (f :: * -> *) a. f a -> Point f a
SDL.P (CInt -> CInt -> V2 CInt
forall a. a -> a -> V2 a
SDL.V2 CInt
13 CInt
13))
StateVar Cursor
SDL.activeCursor StateVar Cursor -> Cursor -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
SDL.$= Cursor
xhairCursor
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
FullscreenMode
ModeChange -> WindowMode
SDL.Fullscreen
FullscreenMode
BigBorderlessWindow -> WindowMode
SDL.FullscreenDesktop
FullscreenMode
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 (-CInt
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
$
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
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
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
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.$= V4 Word8
blackRGBA
Renderer -> IO ()
forall (m :: * -> *). (Functor m, MonadIO m) => Renderer -> m ()
SDL.clear Renderer
srenderer
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 = FrontendSession :: 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{Bool
Int
Maybe Font
IORef Bool
IORef FontAtlas
IORef Texture
IORef SingleFrame
MVar ()
MVar SingleFrame
Window
Renderer
Font
sframeDrawn :: MVar ()
sframeQueue :: MVar SingleFrame
scontinueSdlLoop :: IORef Bool
sforcedShutdown :: IORef Bool
spreviousFrame :: IORef SingleFrame
smonoAtlas :: IORef FontAtlas
squareAtlas :: IORef FontAtlas
stexture :: IORef Texture
sbasicTexture :: IORef Texture
srenderer :: Renderer
swindow :: Window
smonoFont :: Maybe Font
sboldFont :: Maybe Font
spropFont :: Maybe Font
mapFontIsBitmap :: Bool
squareFontSize :: Int
squareFont :: Font
sframeDrawn :: MVar ()
sframeQueue :: MVar SingleFrame
scontinueSdlLoop :: IORef Bool
sforcedShutdown :: IORef Bool
spreviousFrame :: IORef SingleFrame
stexture :: IORef Texture
sbasicTexture :: IORef Texture
smonoAtlas :: IORef FontAtlas
squareAtlas :: IORef FontAtlas
smonoFont :: Maybe Font
sboldFont :: Maybe Font
spropFont :: Maybe Font
mapFontIsBitmap :: Bool
squareFontSize :: Int
squareFont :: Font
srenderer :: Renderer
swindow :: Window
..}
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 i
x i
y)) =
Int -> Int -> PointUI
PointUI (i -> Int
forall a. Enum a => a -> Int
fromEnum i
x Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
halfSize) (i -> Int
forall a. Enum a => a -> Int
fromEnum i
y Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
boxSize)
redraw :: IO ()
redraw = do
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
IO ()
clearScreen
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
IO ()
forall (m :: * -> *). MonadIO m => m ()
SDL.pumpEvents
LogPriority -> LogPriority -> IO ()
forall (m :: * -> *).
MonadIO m =>
LogPriority -> LogPriority -> m ()
SDL.Raw.Event.flushEvents LogPriority
forall a. Bounded a => a
minBound LogPriority
forall a. Bounded a => a
maxBound
loopSDL :: IO ()
loopSDL :: IO ()
loopSDL = do
Maybe Event
me <- IO (Maybe Event)
forall (m :: * -> *). MonadIO m => m (Maybe Event)
SDL.pollEvent
case Maybe Event
me of
Maybe Event
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 SingleFrame
fr -> do
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 ()
Maybe SingleFrame
Nothing -> Int -> IO ()
threadDelay (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ if Bool
sbenchmark then Int
150 else Int
15000
Just 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
handleEvent :: Event -> IO ()
handleEvent Event
e = case Event -> EventPayload
SDL.eventPayload Event
e of
SDL.KeyboardEvent KeyboardEventData
keyboardEvent
| KeyboardEventData -> InputMotion
SDL.keyboardEventKeyMotion KeyboardEventData
keyboardEvent InputMotion -> InputMotion -> Bool
forall a. Eq a => a -> a -> Bool
== InputMotion
SDL.Pressed -> do
let sym :: Keysym
sym = KeyboardEventData -> Keysym
SDL.keyboardEventKeysym KeyboardEventData
keyboardEvent
ksm :: KeyModifier
ksm = Keysym -> KeyModifier
SDL.keysymModifier Keysym
sym
shiftPressed :: Bool
shiftPressed = KeyModifier -> Bool
SDL.keyModifierLeftShift KeyModifier
ksm
Bool -> Bool -> Bool
|| KeyModifier -> Bool
SDL.keyModifierRightShift KeyModifier
ksm
key :: Key
key = Bool -> Keycode -> Key
keyTranslate Bool
shiftPressed (Keycode -> Key) -> Keycode -> Key
forall a b. (a -> b) -> a -> b
$ Keysym -> Keycode
SDL.keysymKeycode Keysym
sym
modifier :: Modifier
modifier = KeyModifier -> Modifier
modTranslate KeyModifier
ksm
modifierNoShift :: Modifier
modifierNoShift = case Modifier
modifier of
Modifier
K.Shift -> Modifier
K.NoModifier
Modifier
K.ControlShift -> Modifier
K.Control
Modifier
K.AltShift -> Modifier
K.Alt
Modifier
_ -> 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 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
MouseButton
SDL.ButtonLeft -> Key
K.LeftButtonRelease
MouseButton
SDL.ButtonMiddle -> Key
K.MiddleButtonRelease
MouseButton
SDL.ButtonRight -> Key
K.RightButtonRelease
MouseButton
_ -> Key
K.LeftButtonRelease
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 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 Int32
_ 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 Int32
0, MouseWheelEventData -> MouseScrollDirection
SDL.mouseWheelEventDirection
MouseWheelEventData
mouseWheelEvent) of
(Ordering
EQ, MouseScrollDirection
_) -> Maybe Key
forall a. Maybe a
Nothing
(Ordering
LT, MouseScrollDirection
SDL.ScrollNormal) -> Key -> Maybe Key
forall a. a -> Maybe a
Just Key
K.WheelSouth
(Ordering
GT, MouseScrollDirection
SDL.ScrollNormal) -> Key -> Maybe Key
forall a. a -> Maybe a
Just Key
K.WheelNorth
(Ordering
LT, MouseScrollDirection
SDL.ScrollFlipped) -> Key -> Maybe Key
forall a. a -> Maybe a
Just Key
K.WheelNorth
(Ordering
GT, MouseScrollDirection
SDL.ScrollFlipped) -> Key -> Maybe Key
forall a. a -> Maybe a
Just Key
K.WheelSouth
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 -> 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
EventPayload
SDL.QuitEvent -> FrontendSession -> IO ()
forceShutdown FrontendSession
sess
SDL.WindowRestoredEvent{} -> IO ()
redraw
SDL.WindowExposedEvent{} -> IO ()
redraw
SDL.WindowResizedEvent{} -> do
Maybe Window -> MessageKind -> Text -> Text -> IO ()
forall (m :: * -> *).
MonadIO m =>
Maybe Window -> MessageKind -> Text -> Text -> m ()
SDL.showSimpleMessageBox Maybe Window
forall a. Maybe a
Nothing MessageKind
SDL.Warning
Text
"Windows resize detected"
Text
"Please resize the game and/or make it fullscreen via 'allFontsScale' and 'fullscreenMode' settings in the 'config.ui.ini' file. Resizing fonts via generic scaling algorithms gives poor results."
IO ()
redraw
EventPayload
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
IO ()
loopSDL
createCursor :: MonadIO m
=> VS.Vector Word8
-> VS.Vector Word8
-> Vect.V2 CInt
-> Vect.Point Vect.V2 CInt
-> m SDL.Cursor
createCursor :: Vector Word8
-> Vector Word8 -> V2 CInt -> Point V2 CInt -> m Cursor
createCursor Vector Word8
dta Vector Word8
msk (Vect.V2 CInt
w CInt
h) (Vect.P (Vect.V2 CInt
hx CInt
hy)) =
IO Cursor -> m Cursor
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Cursor -> m Cursor)
-> (IO (Ptr ()) -> IO Cursor) -> IO (Ptr ()) -> m Cursor
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ptr () -> Cursor) -> IO (Ptr ()) -> IO Cursor
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Ptr () -> Cursor
forall a b. a -> b
unsafeCoerce (IO (Ptr ()) -> m Cursor) -> IO (Ptr ()) -> m Cursor
forall a b. (a -> b) -> a -> b
$
Text -> Text -> IO (Ptr ()) -> IO (Ptr ())
forall (m :: * -> *) a.
MonadIO m =>
Text -> Text -> m (Ptr a) -> m (Ptr a)
throwIfNull Text
"SDL.Input.Mouse.createCursor" Text
"SDL_createCursor" (IO (Ptr ()) -> IO (Ptr ())) -> IO (Ptr ()) -> IO (Ptr ())
forall a b. (a -> b) -> a -> b
$
Vector Word8 -> (Ptr Word8 -> IO (Ptr ())) -> IO (Ptr ())
forall a b. Storable a => Vector a -> (Ptr a -> IO b) -> IO b
VS.unsafeWith Vector Word8
dta ((Ptr Word8 -> IO (Ptr ())) -> IO (Ptr ()))
-> (Ptr Word8 -> IO (Ptr ())) -> IO (Ptr ())
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
unsafeDta ->
Vector Word8 -> (Ptr Word8 -> IO (Ptr ())) -> IO (Ptr ())
forall a b. Storable a => Vector a -> (Ptr a -> IO b) -> IO b
VS.unsafeWith Vector Word8
msk ((Ptr Word8 -> IO (Ptr ())) -> IO (Ptr ()))
-> (Ptr Word8 -> IO (Ptr ())) -> IO (Ptr ())
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
unsafeMsk ->
Ptr Word8
-> Ptr Word8 -> CInt -> CInt -> CInt -> CInt -> IO (Ptr ())
forall (m :: * -> *).
MonadIO m =>
Ptr Word8
-> Ptr Word8 -> CInt -> CInt -> CInt -> CInt -> m (Ptr ())
Raw.createCursor Ptr Word8
unsafeDta Ptr Word8
unsafeMsk CInt
w CInt
h CInt
hx CInt
hy
boolListToWord8List :: [Bool] -> [Word8]
boolListToWord8List :: [Bool] -> [Word8]
boolListToWord8List =
let i :: Bool -> p -> p
i Bool
True p
multiple = p
multiple
i Bool
False p
_ = p
0
in \case
Bool
b1 : Bool
b2 : Bool
b3 : Bool
b4 : Bool
b5 : Bool
b6 : Bool
b7 : Bool
b8 : [Bool]
rest ->
Bool -> Word8 -> Word8
forall p. Num p => Bool -> p -> p
i Bool
b1 Word8
128 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Bool -> Word8 -> Word8
forall p. Num p => Bool -> p -> p
i Bool
b2 Word8
64 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Bool -> Word8 -> Word8
forall p. Num p => Bool -> p -> p
i Bool
b3 Word8
32 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Bool -> Word8 -> Word8
forall p. Num p => Bool -> p -> p
i Bool
b4 Word8
16 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Bool -> Word8 -> Word8
forall p. Num p => Bool -> p -> p
i Bool
b5 Word8
8 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Bool -> Word8 -> Word8
forall p. Num p => Bool -> p -> p
i Bool
b6 Word8
4 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Bool -> Word8 -> Word8
forall p. Num p => Bool -> p -> p
i Bool
b7 Word8
2 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Bool -> Word8 -> Word8
forall p. Num p => Bool -> p -> p
i Bool
b8 Word8
1
Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: [Bool] -> [Word8]
boolListToWord8List [Bool]
rest
[Bool]
_ -> []
cursorXhair :: (VS.Vector Word8, VS.Vector Word8)
cursorXhair :: (Vector Word8, Vector Word8)
cursorXhair =
let charToBool :: Char -> (Bool, Bool)
charToBool Char
'.' = (Bool
True, Bool
True)
charToBool Char
'#' = (Bool
True, Bool
False)
charToBool Char
_ = (Bool
False, Bool
False)
toVS :: [Bool] -> Vector Word8
toVS = [Word8] -> Vector Word8
forall a. Storable a => [a] -> Vector a
VS.fromList ([Word8] -> Vector Word8)
-> ([Bool] -> [Word8]) -> [Bool] -> Vector Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Bool] -> [Word8]
boolListToWord8List
in [Bool] -> Vector Word8
toVS ([Bool] -> Vector Word8)
-> ([Bool] -> Vector Word8)
-> ([Bool], [Bool])
-> (Vector Word8, Vector Word8)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** [Bool] -> Vector Word8
toVS (([Bool], [Bool]) -> (Vector Word8, Vector Word8))
-> ([Bool], [Bool]) -> (Vector Word8, Vector Word8)
forall a b. (a -> b) -> a -> b
$ [(Bool, Bool)] -> ([Bool], [Bool])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Bool, Bool)] -> ([Bool], [Bool]))
-> [(Bool, Bool)] -> ([Bool], [Bool])
forall a b. (a -> b) -> a -> b
$ (Char -> (Bool, Bool)) -> String -> [(Bool, Bool)]
forall a b. (a -> b) -> [a] -> [b]
map Char -> (Bool, Bool)
charToBool (String -> [(Bool, Bool)]) -> String -> [(Bool, Bool)]
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ String
" ... "
, String
" .#. "
, String
" .. .#. .. "
, String
" ..## .#. ##.. "
, String
" .## .#. ##. "
, String
" .# .#. #. "
, String
" .# .#. #. "
, String
" .# ... #. "
, String
" .# #. "
, String
" .# #. "
, String
" "
, String
" . "
, String
"........ .#. ........ "
, String
".######. .###. .######. "
, String
"........ .#. ........ "
, String
" . "
, String
" "
, String
" .# #. "
, String
" .# #. "
, String
" .# ... #. "
, String
" .# .#. #. "
, String
" .# .#. #. "
, String
" .## .#. ##. "
, String
" ..## .#. ##.. "
, String
" .. .#. .. "
, String
" .#. "
, String
" ... " ]
shutdown :: FrontendSession -> IO ()
shutdown :: FrontendSession -> IO ()
shutdown FrontendSession{Bool
Int
Maybe Font
IORef Bool
IORef FontAtlas
IORef Texture
IORef SingleFrame
MVar ()
MVar SingleFrame
Window
Renderer
Font
sframeDrawn :: MVar ()
sframeQueue :: MVar SingleFrame
scontinueSdlLoop :: IORef Bool
sforcedShutdown :: IORef Bool
spreviousFrame :: IORef SingleFrame
stexture :: IORef Texture
sbasicTexture :: IORef Texture
smonoAtlas :: IORef FontAtlas
squareAtlas :: IORef FontAtlas
smonoFont :: Maybe Font
sboldFont :: Maybe Font
spropFont :: Maybe Font
mapFontIsBitmap :: Bool
squareFontSize :: Int
squareFont :: Font
srenderer :: Renderer
swindow :: Window
sframeDrawn :: FrontendSession -> MVar ()
sframeQueue :: FrontendSession -> MVar SingleFrame
scontinueSdlLoop :: FrontendSession -> IORef Bool
sforcedShutdown :: FrontendSession -> IORef Bool
spreviousFrame :: FrontendSession -> IORef SingleFrame
stexture :: FrontendSession -> IORef Texture
sbasicTexture :: FrontendSession -> IORef Texture
smonoAtlas :: FrontendSession -> IORef FontAtlas
squareAtlas :: FrontendSession -> IORef FontAtlas
smonoFont :: FrontendSession -> Maybe Font
sboldFont :: FrontendSession -> Maybe Font
spropFont :: FrontendSession -> Maybe Font
mapFontIsBitmap :: FrontendSession -> Bool
squareFontSize :: FrontendSession -> Int
squareFont :: FrontendSession -> Font
srenderer :: FrontendSession -> Renderer
swindow :: FrontendSession -> Window
..} = IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
scontinueSdlLoop Bool
False
forceShutdown :: FrontendSession -> IO ()
forceShutdown :: FrontendSession -> IO ()
forceShutdown sess :: FrontendSession
sess@FrontendSession{Bool
Int
Maybe Font
IORef Bool
IORef FontAtlas
IORef Texture
IORef SingleFrame
MVar ()
MVar SingleFrame
Window
Renderer
Font
sframeDrawn :: MVar ()
sframeQueue :: MVar SingleFrame
scontinueSdlLoop :: IORef Bool
sforcedShutdown :: IORef Bool
spreviousFrame :: IORef SingleFrame
stexture :: IORef Texture
sbasicTexture :: IORef Texture
smonoAtlas :: IORef FontAtlas
squareAtlas :: IORef FontAtlas
smonoFont :: Maybe Font
sboldFont :: Maybe Font
spropFont :: Maybe Font
mapFontIsBitmap :: Bool
squareFontSize :: Int
squareFont :: Font
srenderer :: Renderer
swindow :: Window
sframeDrawn :: FrontendSession -> MVar ()
sframeQueue :: FrontendSession -> MVar SingleFrame
scontinueSdlLoop :: FrontendSession -> IORef Bool
sforcedShutdown :: FrontendSession -> IORef Bool
spreviousFrame :: FrontendSession -> IORef SingleFrame
stexture :: FrontendSession -> IORef Texture
sbasicTexture :: FrontendSession -> IORef Texture
smonoAtlas :: FrontendSession -> IORef FontAtlas
squareAtlas :: FrontendSession -> IORef FontAtlas
smonoFont :: FrontendSession -> Maybe Font
sboldFont :: FrontendSession -> Maybe Font
spropFont :: FrontendSession -> Maybe Font
mapFontIsBitmap :: FrontendSession -> Bool
squareFontSize :: FrontendSession -> Int
squareFont :: FrontendSession -> Font
srenderer :: FrontendSession -> Renderer
swindow :: FrontendSession -> Window
..} = do
IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
sforcedShutdown Bool
True
FrontendSession -> IO ()
shutdown FrontendSession
sess
display :: FrontendSession
-> SingleFrame
-> IO ()
display :: FrontendSession -> SingleFrame -> IO ()
display FrontendSession{Bool
Int
Maybe Font
IORef Bool
IORef FontAtlas
IORef Texture
IORef SingleFrame
MVar ()
MVar SingleFrame
Window
Renderer
Font
sframeDrawn :: MVar ()
sframeQueue :: MVar SingleFrame
scontinueSdlLoop :: IORef Bool
sforcedShutdown :: IORef Bool
spreviousFrame :: IORef SingleFrame
stexture :: IORef Texture
sbasicTexture :: IORef Texture
smonoAtlas :: IORef FontAtlas
squareAtlas :: IORef FontAtlas
smonoFont :: Maybe Font
sboldFont :: Maybe Font
spropFont :: Maybe Font
mapFontIsBitmap :: Bool
squareFontSize :: Int
squareFont :: Font
srenderer :: Renderer
swindow :: Window
sframeDrawn :: FrontendSession -> MVar ()
sframeQueue :: FrontendSession -> MVar SingleFrame
scontinueSdlLoop :: FrontendSession -> IORef Bool
sforcedShutdown :: FrontendSession -> IORef Bool
spreviousFrame :: FrontendSession -> IORef SingleFrame
stexture :: FrontendSession -> IORef Texture
sbasicTexture :: FrontendSession -> IORef Texture
smonoAtlas :: FrontendSession -> IORef FontAtlas
squareAtlas :: FrontendSession -> IORef FontAtlas
smonoFont :: FrontendSession -> Maybe Font
sboldFont :: FrontendSession -> Maybe Font
spropFont :: FrontendSession -> Maybe Font
mapFontIsBitmap :: FrontendSession -> Bool
squareFontSize :: FrontendSession -> Int
squareFont :: FrontendSession -> Font
srenderer :: FrontendSession -> Renderer
swindow :: FrontendSession -> Window
..} 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
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
$
Int -> IO ()
threadDelay Int
50000
drawFrame :: ScreenContent
-> ClientOptions
-> FrontendSession
-> SingleFrame
-> IO ()
drawFrame :: ScreenContent
-> ClientOptions -> FrontendSession -> SingleFrame -> IO ()
drawFrame ScreenContent
coscreen ClientOptions{Bool
String
[(Text, FontSet)]
[(Text, FontDefinition)]
Maybe Bool
Maybe Double
Maybe Int
Maybe String
Maybe Text
Maybe FullscreenMode
sexposeActors :: Bool
sexposeItems :: Bool
sexposePlaces :: Bool
sprintEachScreen :: Bool
sstopAfterFrames :: Maybe Int
sstopAfterSeconds :: Maybe Int
sdbgMsgCli :: Bool
sfrontendLazy :: Bool
sfrontendNull :: Bool
sfrontendTeletype :: Bool
sfrontendANSI :: Bool
ssavePrefixCli :: String
stitle :: Maybe String
sbenchMessages :: Bool
sbenchmark :: Bool
snewGameCli :: Bool
snoAnim :: Maybe Bool
sdisableAutoYes :: Bool
smaxFps :: Maybe Double
slogPriority :: Maybe Int
sfullscreenMode :: Maybe FullscreenMode
sfontsets :: [(Text, FontSet)]
sfonts :: [(Text, FontDefinition)]
sallFontsScale :: Maybe Double
schosenFontset :: Maybe Text
sexposeActors :: ClientOptions -> Bool
sexposeItems :: ClientOptions -> Bool
sexposePlaces :: ClientOptions -> Bool
sprintEachScreen :: ClientOptions -> Bool
sstopAfterFrames :: ClientOptions -> Maybe Int
sstopAfterSeconds :: ClientOptions -> Maybe Int
sdbgMsgCli :: ClientOptions -> Bool
sfrontendLazy :: ClientOptions -> Bool
sfrontendNull :: ClientOptions -> Bool
sfrontendTeletype :: ClientOptions -> Bool
sfrontendANSI :: ClientOptions -> Bool
ssavePrefixCli :: ClientOptions -> String
stitle :: ClientOptions -> Maybe String
sbenchMessages :: ClientOptions -> Bool
sbenchmark :: ClientOptions -> Bool
snewGameCli :: ClientOptions -> Bool
snoAnim :: ClientOptions -> Maybe Bool
sdisableAutoYes :: ClientOptions -> Bool
smaxFps :: ClientOptions -> Maybe Double
slogPriority :: ClientOptions -> Maybe Int
sfullscreenMode :: ClientOptions -> Maybe FullscreenMode
sfontsets :: ClientOptions -> [(Text, FontSet)]
sfonts :: ClientOptions -> [(Text, FontDefinition)]
sallFontsScale :: ClientOptions -> Maybe Double
schosenFontset :: ClientOptions -> Maybe Text
..} sess :: FrontendSession
sess@FrontendSession{Bool
Int
Maybe Font
IORef Bool
IORef FontAtlas
IORef Texture
IORef SingleFrame
MVar ()
MVar SingleFrame
Window
Renderer
Font
sframeDrawn :: MVar ()
sframeQueue :: MVar SingleFrame
scontinueSdlLoop :: IORef Bool
sforcedShutdown :: IORef Bool
spreviousFrame :: IORef SingleFrame
stexture :: IORef Texture
sbasicTexture :: IORef Texture
smonoAtlas :: IORef FontAtlas
squareAtlas :: IORef FontAtlas
smonoFont :: Maybe Font
sboldFont :: Maybe Font
spropFont :: Maybe Font
mapFontIsBitmap :: Bool
squareFontSize :: Int
squareFont :: Font
srenderer :: Renderer
swindow :: Window
sframeDrawn :: FrontendSession -> MVar ()
sframeQueue :: FrontendSession -> MVar SingleFrame
scontinueSdlLoop :: FrontendSession -> IORef Bool
sforcedShutdown :: FrontendSession -> IORef Bool
spreviousFrame :: FrontendSession -> IORef SingleFrame
stexture :: FrontendSession -> IORef Texture
sbasicTexture :: FrontendSession -> IORef Texture
smonoAtlas :: FrontendSession -> IORef FontAtlas
squareAtlas :: FrontendSession -> IORef FontAtlas
smonoFont :: FrontendSession -> Maybe Font
sboldFont :: FrontendSession -> Maybe Font
spropFont :: FrontendSession -> Maybe Font
mapFontIsBitmap :: FrontendSession -> Bool
squareFontSize :: FrontendSession -> Int
squareFont :: FrontendSession -> Font
srenderer :: FrontendSession -> Renderer
swindow :: FrontendSession -> Window
..} 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` Int
2
boxSize :: Int
boxSize = Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
halfSize
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)
vp :: Int -> Int -> Vect.Point Vect.V2 CInt
vp :: Int -> Int -> Point V2 CInt
vp Int
x Int
y = V2 CInt -> Point V2 CInt
forall (f :: * -> *) a. f a -> Point f a
Vect.P (V2 CInt -> Point V2 CInt) -> V2 CInt -> Point V2 CInt
forall a b. (a -> b) -> a -> b
$ CInt -> CInt -> V2 CInt
forall a. a -> a -> V2 a
Vect.V2 (Int -> CInt
forall a. Enum a => Int -> a
toEnum Int
x) (Int -> CInt
forall a. Enum a => Int -> a
toEnum Int
y)
drawHighlight :: Int -> Int -> Color -> IO ()
drawHighlight !Int
col !Int
row !Color
color = do
Renderer -> StateVar (V4 Word8)
SDL.rendererDrawColor Renderer
srenderer StateVar (V4 Word8) -> V4 Word8 -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
SDL.$= Color -> V4 Word8
colorToRGBA Color
color
let rect :: Rectangle CInt
rect = Point V2 CInt -> V2 CInt -> Rectangle CInt
forall a. Point V2 a -> V2 a -> Rectangle a
SDL.Rectangle (Int -> Int -> Point V2 CInt
vp (Int
col Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
boxSize) (Int
row Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
boxSize)) V2 CInt
tt2Square
Renderer -> Maybe (Rectangle CInt) -> IO ()
forall (m :: * -> *).
MonadIO m =>
Renderer -> Maybe (Rectangle CInt) -> m ()
SDL.drawRect Renderer
srenderer (Maybe (Rectangle CInt) -> IO ())
-> Maybe (Rectangle CInt) -> IO ()
forall a b. (a -> b) -> a -> b
$ Rectangle CInt -> Maybe (Rectangle CInt)
forall a. a -> Maybe a
Just Rectangle CInt
rect
Renderer -> StateVar (V4 Word8)
SDL.rendererDrawColor Renderer
srenderer StateVar (V4 Word8) -> V4 Word8 -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
SDL.$= V4 Word8
blackRGBA
chooseAndDrawHighlight :: Int -> Int -> Highlight -> IO ()
chooseAndDrawHighlight !Int
col !Int
row !Highlight
bg = do
let workaroundOverwriteHighlight :: IO ()
workaroundOverwriteHighlight = do
let rect :: Rectangle CInt
rect = Point V2 CInt -> V2 CInt -> Rectangle CInt
forall a. Point V2 a -> V2 a -> Rectangle a
SDL.Rectangle (Int -> Int -> Point V2 CInt
vp (Int
col Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
boxSize) (Int
row Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
boxSize))
V2 CInt
tt2Square
Renderer -> Maybe (Rectangle CInt) -> IO ()
forall (m :: * -> *).
MonadIO m =>
Renderer -> Maybe (Rectangle CInt) -> m ()
SDL.drawRect Renderer
srenderer (Maybe (Rectangle CInt) -> IO ())
-> Maybe (Rectangle CInt) -> IO ()
forall a b. (a -> b) -> a -> b
$ Rectangle CInt -> Maybe (Rectangle CInt)
forall a. a -> Maybe a
Just Rectangle CInt
rect
case Highlight
bg of
Highlight
Color.HighlightNone -> IO ()
workaroundOverwriteHighlight
Highlight
Color.HighlightBackground -> IO ()
workaroundOverwriteHighlight
Highlight
Color.HighlightNoneCursor -> IO ()
workaroundOverwriteHighlight
Highlight
_ -> Int -> Int -> Color -> IO ()
drawHighlight Int
col Int
row (Color -> IO ()) -> Color -> IO ()
forall a b. (a -> b) -> a -> b
$ Highlight -> Color
Color.highlightToColor Highlight
bg
scaleSurfaceToTexture :: Int -> SDL.Surface -> IO SDL.Texture
scaleSurfaceToTexture :: Int -> Surface -> IO Texture
scaleSurfaceToTexture Int
xsize Surface
textSurfaceRaw = do
Vect.V2 CInt
sw 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 Int
0 (CInt -> Int
forall a. Enum a => a -> Int
fromEnum CInt
sw Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
width) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
ysrc :: Int
ysrc = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (CInt -> Int
forall a. Enum a => a -> Int
fromEnum CInt
sh Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
height) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`divUp` Int
2
srcR :: 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` Int
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` Int
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 V4 Word8
blackRGBA
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
scaleSurfaceToTextureProp :: Int -> Int -> SDL.Surface -> Bool
-> IO (Int, SDL.Texture)
scaleSurfaceToTextureProp :: Int -> Int -> Surface -> Bool -> IO (Int, Texture)
scaleSurfaceToTextureProp Int
x Int
row Surface
textSurfaceRaw Bool
allSpace = do
Vect.V2 CInt
sw 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
remainingWidth :: Int
remainingWidth = ScreenContent -> Int
rwidth ScreenContent
coscreen Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
boxSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
x
width :: Int
width | Int
widthRaw Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
remainingWidth = Int
widthRaw
| Bool
allSpace = Int
remainingWidth
| Bool
otherwise = Int
remainingWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
boxSize
height :: Int
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
0
ysrc :: Int
ysrc = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (CInt -> Int
forall a. Enum a => a -> Int
fromEnum CInt
sh Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
height) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`divUp` Int
2
srcR :: 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
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` Int
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 V4 Word8
blackRGBA
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 Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
allSpace) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Int -> Int -> AttrCharW32 -> IO ()
setSquareChar (ScreenContent -> Int
rwidth ScreenContent
coscreen Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int
row AttrCharW32
Color.trimmedLineAttrW32
(Int, Texture) -> IO (Int, Texture)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
width, Texture
textTexture)
setMapChar :: PointI -> (Word32, Word32) -> IO Int
setMapChar :: Int -> (LogPriority, LogPriority) -> IO Int
setMapChar !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
+ Int
1
else do
let Point{Int
py :: Point -> Int
px :: Point -> Int
py :: Int
px :: Int
..} = Int -> Point
forall a. Enum a => Int -> a
toEnum Int
i
Int -> Int -> AttrCharW32 -> IO ()
setSquareChar Int
px Int
py (LogPriority -> AttrCharW32
Color.AttrCharW32 LogPriority
w)
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
+ Int
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 Int
x Int
y, [AttrCharW32]
al) ->
let lineCut :: [AttrCharW32]
lineCut = Int -> [AttrCharW32] -> [AttrCharW32]
forall a. Int -> [a] -> [a]
take (Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* ScreenContent -> Int
rwidth ScreenContent
coscreen Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
x) [AttrCharW32]
al
in Int -> Int -> [AttrCharW32] -> IO ()
drawMonoLine Int
x Int
y [AttrCharW32]
lineCut)
drawMonoLine :: Int -> Int -> AttrString -> IO ()
drawMonoLine :: Int -> Int -> [AttrCharW32] -> IO ()
drawMonoLine Int
_ Int
_ [] = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
drawMonoLine Int
x Int
row (AttrCharW32
w : [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
1) 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 :: Attr -> Highlight
bg :: Highlight
bg}, Char
acChar :: AttrChar -> Char
acChar :: Char
acChar} =
AttrCharW32 -> AttrChar
Color.attrCharFromW32 AttrCharW32
w
fg :: Color
fg | Int -> Bool
forall a. Integral a => a -> Bool
even Int
row Bool -> Bool -> Bool
&& Color
fgRaw Color -> Color -> Bool
forall a. Eq a => a -> a -> Bool
== Color
Color.White = Color
Color.AltWhite
| Bool
otherwise = Color
fgRaw
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
Maybe Texture
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)
V4 Word8
blackRGBA 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 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 -> Int -> Int
forall a. Num a => a -> a -> a
* Int
halfSize) (Int
row Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
boxSize)) V2 CInt
tt2Mono
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)
drawSquareOverlay :: OverlaySpace -> IO ()
drawSquareOverlay :: OverlaySpace -> IO ()
drawSquareOverlay =
((PointUI, [AttrCharW32]) -> IO ()) -> OverlaySpace -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m ()) -> t a -> m ()
mapM_ (\(PointUI
pUI, [AttrCharW32]
al) ->
let PointSquare Int
col Int
row = PointUI -> PointSquare
uiToSquare PointUI
pUI
lineCut :: [AttrCharW32]
lineCut = Int -> [AttrCharW32] -> [AttrCharW32]
forall a. Int -> [a] -> [a]
take (ScreenContent -> Int
rwidth ScreenContent
coscreen Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
col) [AttrCharW32]
al
in Int -> Int -> [AttrCharW32] -> IO ()
drawSquareLine Int
col Int
row [AttrCharW32]
lineCut)
drawSquareLine :: Int -> Int -> AttrString -> IO ()
drawSquareLine :: Int -> Int -> [AttrCharW32] -> IO ()
drawSquareLine Int
_ Int
_ [] = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
drawSquareLine Int
col Int
row (AttrCharW32
w : [AttrCharW32]
rest) = do
Int -> Int -> AttrCharW32 -> IO ()
setSquareChar Int
col Int
row AttrCharW32
w
Int -> Int -> [AttrCharW32] -> IO ()
drawSquareLine (Int
col Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
row [AttrCharW32]
rest
setSquareChar :: Int -> Int -> Color.AttrCharW32 -> IO ()
setSquareChar :: Int -> Int -> AttrCharW32 -> IO ()
setSquareChar !Int
col !Int
row !AttrCharW32
w = do
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 :: Highlight
bg :: Attr -> Highlight
bg}
, acChar :: AttrChar -> Char
acChar=Char
acCharRaw } =
AttrCharW32 -> AttrChar
Color.attrCharFromW32 AttrCharW32
w
fg :: Color
fg | Int -> Bool
forall a. Integral a => a -> Bool
even Int
row Bool -> Bool -> Bool
&& Color
fgRaw Color -> Color -> Bool
forall a. Eq a => a -> a -> Bool
== Color
Color.White = Color
Color.AltWhite
| Bool
otherwise = Color
fgRaw
ac :: AttrCharW32
ac = if Highlight
bg Highlight -> Highlight -> Bool
forall a. Eq a => a -> a -> Bool
== Highlight
Color.HighlightBackground
then AttrCharW32
w
else Color -> Char -> AttrCharW32
Color.attrChar2ToW32 Color
fg Char
acCharRaw
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
Maybe Texture
Nothing -> do
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
then if Bool
mapFontIsBitmap
then Char
'\x0007'
else Char
'\x22C5'
else Char
acCharRaw
background :: V4 Word8
background = if Highlight
bg Highlight -> Highlight -> Bool
forall a. Eq a => a -> a -> Bool
== Highlight
Color.HighlightBackground
then V4 Word8
greyRGBA
else V4 Word8
blackRGBA
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)
V4 Word8
background 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 Texture
textTexture -> Texture -> IO Texture
forall (m :: * -> *) a. Monad m => a -> m a
return Texture
textTexture
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
col Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
boxSize) (Int
row Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
boxSize)) V2 CInt
tt2Square
Renderer
-> 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)
Int -> Int -> Highlight -> IO ()
chooseAndDrawHighlight Int
col Int
row Highlight
bg
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 Int
x Int
y, [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 Int
_ Int
_ [] = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
drawPropLine Int
x Int
_ [AttrCharW32]
_ | Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= (ScreenContent -> Int
rwidth ScreenContent
coscreen Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
boxSize =
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
drawPropLine Int
x Int
row (AttrCharW32
w : [AttrCharW32]
rest) = do
let isSpace :: AttrCharW32 -> Bool
isSpace = (AttrCharW32 -> AttrCharW32 -> Bool
forall a. Eq a => a -> a -> Bool
== AttrCharW32
Color.spaceAttrW32)
Color.AttrChar{acAttr :: AttrChar -> Attr
acAttr=Color.Attr{fg :: Attr -> Color
fg=Color
fgRaw, Highlight
bg :: 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
AttrCharW32
w2 : [AttrCharW32]
_ -> AttrCharW32
w2
[] -> AttrCharW32
w
else AttrCharW32
w
sameAttr :: AttrCharW32 -> Bool
sameAttr AttrCharW32
ac = AttrCharW32 -> Color
Color.fgFromW32 AttrCharW32
ac Color -> Color -> Bool
forall a. Eq a => a -> a -> Bool
== Color
fgRaw
Bool -> Bool -> Bool
|| AttrCharW32 -> Bool
isSpace AttrCharW32
ac
([AttrCharW32]
sameRest, [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 -> Bool
forall a. Integral a => a -> Bool
even Int
row Bool -> Bool -> Bool
&& Color
fgRaw Color -> Color -> Bool
forall a. Eq a => a -> a -> Bool
== Color
Color.White = Color
Color.AltWhite
| Bool
otherwise = Color
fgRaw
t :: Text
t = 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 Int
x Int
row Color
fg Text
t = do
let font :: Maybe Font
font = if Color
fg Color -> Color -> Bool
forall a. Ord a => a -> a -> Bool
>= Color
Color.White Bool -> Bool -> Bool
&& Color
fg Color -> Color -> Bool
forall a. Eq a => a -> a -> Bool
/= Color
Color.BrBlack
then Maybe Font
spropFont
else Maybe Font
sboldFont
allSpace :: Bool
allSpace = (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
Char.isSpace Text
t
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)
V4 Word8
blackRGBA Text
t
(Int
width, Texture
textTexture) <-
Int -> Int -> Surface -> Bool -> IO (Int, Texture)
scaleSurfaceToTextureProp Int
x Int
row Surface
textSurfaceRaw Bool
allSpace
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))
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
singleSquareOverlay SingleFrame
curFrame OverlaySpace -> OverlaySpace -> Bool
forall a. Eq a => a -> a -> Bool
== SingleFrame -> OverlaySpace
singleSquareOverlay SingleFrame
prevFrame
Bool -> Bool -> Bool
&& SingleFrame -> OverlaySpace
singlePropOverlay SingleFrame
curFrame OverlaySpace -> OverlaySpace -> Bool
forall a. Eq a => a -> a -> Bool
== SingleFrame -> OverlaySpace
singlePropOverlay SingleFrame
prevFrame
Texture
basicTexture <- IORef Texture -> IO Texture
forall a. IORef a -> IO a
readIORef IORef Texture
sbasicTexture
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
setMapChar Int
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 (UnboxRep AttrCharW32)
forall c. Array c -> Vector (UnboxRep c)
PointArray.avector (Array AttrCharW32 -> Vector (UnboxRep AttrCharW32))
-> Array AttrCharW32 -> Vector (UnboxRep AttrCharW32)
forall a b. (a -> b) -> a -> b
$ SingleFrame -> Array AttrCharW32
singleArray SingleFrame
curFrame)
(Array AttrCharW32 -> Vector (UnboxRep AttrCharW32)
forall c. Array c -> Vector (UnboxRep c)
PointArray.avector (Array AttrCharW32 -> Vector (UnboxRep AttrCharW32))
-> Array AttrCharW32 -> Vector (UnboxRep AttrCharW32)
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
OverlaySpace -> IO ()
drawPropOverlay (OverlaySpace -> IO ()) -> OverlaySpace -> IO ()
forall a b. (a -> b) -> a -> b
$ SingleFrame -> OverlaySpace
singlePropOverlay SingleFrame
curFrame
OverlaySpace -> IO ()
drawSquareOverlay (OverlaySpace -> IO ()) -> OverlaySpace -> IO ()
forall a b. (a -> b) -> a -> b
$ SingleFrame -> OverlaySpace
singleSquareOverlay 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
Renderer -> IO ()
forall (m :: * -> *). MonadIO m => Renderer -> m ()
SDL.present Renderer
srenderer
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
printScreen :: FrontendSession -> IO ()
printScreen :: FrontendSession -> IO ()
printScreen FrontendSession{Bool
Int
Maybe Font
IORef Bool
IORef FontAtlas
IORef Texture
IORef SingleFrame
MVar ()
MVar SingleFrame
Window
Renderer
Font
sframeDrawn :: MVar ()
sframeQueue :: MVar SingleFrame
scontinueSdlLoop :: IORef Bool
sforcedShutdown :: IORef Bool
spreviousFrame :: IORef SingleFrame
stexture :: IORef Texture
sbasicTexture :: IORef Texture
smonoAtlas :: IORef FontAtlas
squareAtlas :: IORef FontAtlas
smonoFont :: Maybe Font
sboldFont :: Maybe Font
spropFont :: Maybe Font
mapFontIsBitmap :: Bool
squareFontSize :: Int
squareFont :: Font
srenderer :: Renderer
swindow :: Window
sframeDrawn :: FrontendSession -> MVar ()
sframeQueue :: FrontendSession -> MVar SingleFrame
scontinueSdlLoop :: FrontendSession -> IORef Bool
sforcedShutdown :: FrontendSession -> IORef Bool
spreviousFrame :: FrontendSession -> IORef SingleFrame
stexture :: FrontendSession -> IORef Texture
sbasicTexture :: FrontendSession -> IORef Texture
smonoAtlas :: FrontendSession -> IORef FontAtlas
squareAtlas :: FrontendSession -> IORef FontAtlas
smonoFont :: FrontendSession -> Maybe Font
sboldFont :: FrontendSession -> Maybe Font
spropFont :: FrontendSession -> Maybe Font
mapFontIsBitmap :: FrontendSession -> Bool
squareFontSize :: FrontendSession -> Int
squareFont :: FrontendSession -> Font
srenderer :: FrontendSession -> Renderer
swindow :: FrontendSession -> Window
..} = 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
</> 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
$ \Char
c -> case Char
c of
Char
' ' -> Char
'_'
Char
':' -> Char
'.'
Char
_ -> 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 Int
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
</> String
"screenshots" String -> String -> String
</> String
"prtscn" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
dateText String -> String -> String
<.> String
"bmp"
SDL.Internal.Types.Renderer Ptr ()
renderer = Renderer
srenderer
Vect.V2 CInt
sw 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 LogPriority
0 CInt
sw CInt
sh CInt
32 LogPriority
0 LogPriority
0 LogPriority
0 LogPriority
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
$ Ptr () -> Ptr Rect -> LogPriority -> Ptr () -> CInt -> IO CInt
forall (m :: * -> *).
MonadIO m =>
Ptr () -> Ptr Rect -> LogPriority -> Ptr () -> CInt -> m CInt
SDL.Raw.Video.renderReadPixels
Ptr ()
renderer
Ptr Rect
forall a. Ptr a
nullPtr
LogPriority
forall a. (Eq a, Num a) => a
SDL.Raw.Enum.SDL_PIXELFORMAT_ARGB8888
(Surface -> Ptr ()
SDL.Raw.Types.surfacePixels Surface
surfaceOut)
(CInt
sw CInt -> CInt -> CInt
forall a. Num a => a -> a -> a
* CInt
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
$ \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
modTranslate :: SDL.KeyModifier -> K.Modifier
modTranslate :: KeyModifier -> Modifier
modTranslate KeyModifier
m =
Bool -> Bool -> Bool -> Bool -> Modifier
modifierTranslate
(KeyModifier -> Bool
SDL.keyModifierLeftCtrl KeyModifier
m Bool -> Bool -> Bool
|| KeyModifier -> Bool
SDL.keyModifierRightCtrl KeyModifier
m)
(KeyModifier -> Bool
SDL.keyModifierLeftShift KeyModifier
m Bool -> Bool -> Bool
|| KeyModifier -> Bool
SDL.keyModifierRightShift KeyModifier
m)
(KeyModifier -> Bool
SDL.keyModifierLeftAlt KeyModifier
m
Bool -> Bool -> Bool
|| KeyModifier -> Bool
SDL.keyModifierRightAlt KeyModifier
m
Bool -> Bool -> Bool
|| KeyModifier -> Bool
SDL.keyModifierAltGr KeyModifier
m
Bool -> Bool -> Bool
|| KeyModifier -> Bool
SDL.keyModifierLeftGUI KeyModifier
m
Bool -> Bool -> Bool
|| KeyModifier -> Bool
SDL.keyModifierRightGUI KeyModifier
m)
Bool
False
keyTranslate :: Bool -> SDL.Keycode -> K.Key
keyTranslate :: Bool -> Keycode -> Key
keyTranslate Bool
shiftPressed Keycode
n = case Keycode
n of
Keycode
KeycodeEscape -> Key
K.Esc
Keycode
KeycodeReturn -> Key
K.Return
Keycode
KeycodeBackspace -> Key
K.BackSpace
Keycode
KeycodeTab -> if Bool
shiftPressed then Key
K.BackTab else Key
K.Tab
Keycode
KeycodeSpace -> Key
K.Space
Keycode
KeycodeExclaim -> Char -> Key
K.Char Char
'!'
Keycode
KeycodeQuoteDbl -> Char -> Key
K.Char Char
'"'
Keycode
KeycodeHash -> Char -> Key
K.Char Char
'#'
Keycode
KeycodePercent -> Char -> Key
K.Char Char
'%'
Keycode
KeycodeDollar -> Char -> Key
K.Char Char
'$'
Keycode
KeycodeAmpersand -> Char -> Key
K.Char Char
'&'
Keycode
KeycodeQuote -> if Bool
shiftPressed then Char -> Key
K.Char Char
'"' else Char -> Key
K.Char Char
'\''
Keycode
KeycodeLeftParen -> Char -> Key
K.Char Char
'('
Keycode
KeycodeRightParen -> Char -> Key
K.Char Char
')'
Keycode
KeycodeAsterisk -> Char -> Key
K.Char Char
'*'
Keycode
KeycodePlus -> Char -> Key
K.Char Char
'+'
Keycode
KeycodeComma -> if Bool
shiftPressed then Char -> Key
K.Char Char
'<' else Char -> Key
K.Char Char
','
Keycode
KeycodeMinus -> if Bool
shiftPressed then Char -> Key
K.Char Char
'_' else Char -> Key
K.Char Char
'-'
Keycode
KeycodePeriod -> if Bool
shiftPressed then Char -> Key
K.Char Char
'>' else Char -> Key
K.Char Char
'.'
Keycode
KeycodeSlash -> if Bool
shiftPressed then Char -> Key
K.Char Char
'?' else Char -> Key
K.Char Char
'/'
Keycode
Keycode1 -> if Bool
shiftPressed then Char -> Key
K.Char Char
'!' else Char -> Key
K.Char Char
'1'
Keycode
Keycode2 -> if Bool
shiftPressed then Char -> Key
K.Char Char
'@' else Char -> Key
K.Char Char
'2'
Keycode
Keycode3 -> if Bool
shiftPressed then Char -> Key
K.Char Char
'#' else Char -> Key
K.Char Char
'3'
Keycode
Keycode4 -> if Bool
shiftPressed then Char -> Key
K.Char Char
'$' else Char -> Key
K.Char Char
'4'
Keycode
Keycode5 -> if Bool
shiftPressed then Char -> Key
K.Char Char
'%' else Char -> Key
K.Char Char
'5'
Keycode
Keycode6 -> if Bool
shiftPressed then Char -> Key
K.Char Char
'^' else Char -> Key
K.Char Char
'6'
Keycode
Keycode7 -> if Bool
shiftPressed then Char -> Key
K.Char Char
'&' else Char -> Key
K.Char Char
'7'
Keycode
Keycode8 -> if Bool
shiftPressed then Char -> Key
K.Char Char
'*' else Char -> Key
K.Char Char
'8'
Keycode
Keycode9 -> if Bool
shiftPressed then Char -> Key
K.Char Char
'(' else Char -> Key
K.Char Char
'9'
Keycode
Keycode0 -> if Bool
shiftPressed then Char -> Key
K.Char Char
')' else Char -> Key
K.Char Char
'0'
Keycode
KeycodeColon -> Char -> Key
K.Char Char
':'
Keycode
KeycodeSemicolon -> if Bool
shiftPressed then Char -> Key
K.Char Char
':' else Char -> Key
K.Char Char
';'
Keycode
KeycodeLess -> Char -> Key
K.Char Char
'<'
Keycode
KeycodeEquals -> if Bool
shiftPressed then Char -> Key
K.Char Char
'+' else Char -> Key
K.Char Char
'='
Keycode
KeycodeGreater -> Char -> Key
K.Char Char
'>'
Keycode
KeycodeQuestion -> Char -> Key
K.Char Char
'?'
Keycode
KeycodeAt -> Char -> Key
K.Char Char
'@'
Keycode
KeycodeLeftBracket -> if Bool
shiftPressed then Char -> Key
K.Char Char
'{' else Char -> Key
K.Char Char
'['
Keycode
KeycodeBackslash -> if Bool
shiftPressed then Char -> Key
K.Char Char
'|' else Char -> Key
K.Char Char
'\\'
Keycode
KeycodeRightBracket -> if Bool
shiftPressed then Char -> Key
K.Char Char
'}' else Char -> Key
K.Char Char
']'
Keycode
KeycodeCaret -> Char -> Key
K.Char Char
'^'
Keycode
KeycodeUnderscore -> Char -> Key
K.Char Char
'_'
Keycode
KeycodeBackquote -> if Bool
shiftPressed then Char -> Key
K.Char Char
'~' else Char -> Key
K.Char Char
'`'
Keycode Int32
167 -> if Bool
shiftPressed then Char -> Key
K.Char Char
'~' else Char -> Key
K.Char Char
'`'
Keycode
KeycodeUp -> Key
K.Up
Keycode
KeycodeDown -> Key
K.Down
Keycode
KeycodeLeft -> Key
K.Left
Keycode
KeycodeRight -> Key
K.Right
Keycode
KeycodeHome -> Key
K.Home
Keycode
KeycodeEnd -> Key
K.End
Keycode
KeycodePageUp -> Key
K.PgUp
Keycode
KeycodePageDown -> Key
K.PgDn
Keycode
KeycodeInsert -> Key
K.Insert
Keycode
KeycodeDelete -> Key
K.Delete
Keycode
KeycodePrintScreen -> Key
K.PrintScreen
Keycode
KeycodeClear -> Key
K.Begin
Keycode
KeycodeKPClear -> Key
K.Begin
Keycode
KeycodeKPDivide -> if Bool
shiftPressed then Char -> Key
K.Char Char
'?' else Char -> Key
K.Char Char
'/'
Keycode
KeycodeKPMultiply -> Char -> Key
K.Char Char
'*'
Keycode
KeycodeKPMinus -> Char -> Key
K.Char Char
'-'
Keycode
KeycodeKPPlus -> Char -> Key
K.Char Char
'+'
Keycode
KeycodeKPEnter -> Key
K.Return
Keycode
KeycodeKPEquals -> Key
K.Return
Keycode
KeycodeKP1 -> if Bool
shiftPressed then Char -> Key
K.KP Char
'1' else Key
K.End
Keycode
KeycodeKP2 -> if Bool
shiftPressed then Char -> Key
K.KP Char
'2' else Key
K.Down
Keycode
KeycodeKP3 -> if Bool
shiftPressed then Char -> Key
K.KP Char
'3' else Key
K.PgDn
Keycode
KeycodeKP4 -> if Bool
shiftPressed then Char -> Key
K.KP Char
'4' else Key
K.Left
Keycode
KeycodeKP5 -> if Bool
shiftPressed then Char -> Key
K.KP Char
'5' else Key
K.Begin
Keycode
KeycodeKP6 -> if Bool
shiftPressed then Char -> Key
K.KP Char
'6' else Key
K.Right
Keycode
KeycodeKP7 -> if Bool
shiftPressed then Char -> Key
K.KP Char
'7' else Key
K.Home
Keycode
KeycodeKP8 -> if Bool
shiftPressed then Char -> Key
K.KP Char
'8' else Key
K.Up
Keycode
KeycodeKP9 -> if Bool
shiftPressed then Char -> Key
K.KP Char
'9' else Key
K.PgUp
Keycode
KeycodeKP0 -> if Bool
shiftPressed then Char -> Key
K.KP Char
'0' else Key
K.Insert
Keycode
KeycodeKPPeriod -> Char -> Key
K.Char Char
'.'
Keycode
KeycodeKPComma -> Char -> Key
K.Char Char
'.'
Keycode
KeycodeF1 -> Int -> Key
K.Fun Int
1
Keycode
KeycodeF2 -> Int -> Key
K.Fun Int
2
Keycode
KeycodeF3 -> Int -> Key
K.Fun Int
3
Keycode
KeycodeF4 -> Int -> Key
K.Fun Int
4
Keycode
KeycodeF5 -> Int -> Key
K.Fun Int
5
Keycode
KeycodeF6 -> Int -> Key
K.Fun Int
6
Keycode
KeycodeF7 -> Int -> Key
K.Fun Int
7
Keycode
KeycodeF8 -> Int -> Key
K.Fun Int
8
Keycode
KeycodeF9 -> Int -> Key
K.Fun Int
9
Keycode
KeycodeF10 -> Int -> Key
K.Fun Int
10
Keycode
KeycodeF11 -> Int -> Key
K.Fun Int
11
Keycode
KeycodeF12 -> Int -> Key
K.Fun Int
12
Keycode
KeycodeLCtrl -> Key
K.DeadKey
Keycode
KeycodeLShift -> Key
K.DeadKey
Keycode
KeycodeLAlt -> Key
K.DeadKey
Keycode
KeycodeLGUI -> Key
K.DeadKey
Keycode
KeycodeRCtrl -> Key
K.DeadKey
Keycode
KeycodeRShift -> Key
K.DeadKey
Keycode
KeycodeRAlt -> Key
K.DeadKey
Keycode
KeycodeRGUI -> Key
K.DeadKey
Keycode
KeycodeMode -> Key
K.DeadKey
Keycode
KeycodeNumLockClear -> Key
K.DeadKey
Keycode
KeycodeUnknown -> String -> Key
K.Unknown String
"KeycodeUnknown"
Keycode
_ -> let i :: Int
i = Int32 -> Int
forall a. Enum a => a -> Int
fromEnum (Int32 -> Int) -> Int32 -> Int
forall a b. (a -> b) -> a -> b
$ Keycode -> Int32
unwrapKeycode Keycode
n
in if | Int
97 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
i Bool -> Bool -> Bool
&& Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
122
Bool -> Bool -> Bool
&& Bool
shiftPressed -> Char -> Key
K.Char (Char -> Key) -> Char -> Key
forall a b. (a -> b) -> a -> b
$ Int -> Char
Char.chr (Int -> Char) -> Int -> Char
forall a b. (a -> b) -> a -> b
$ Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
32
| Int
32 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
i Bool -> Bool -> Bool
&& Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
126 -> Char -> Key
K.Char (Char -> Key) -> Char -> Key
forall a b. (a -> b) -> a -> b
$ Int -> Char
Char.chr Int
i
| Bool
otherwise -> 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 = Word8
255
blackRGBA :: SDL.V4 Word8
blackRGBA :: V4 Word8
blackRGBA = Word8 -> Word8 -> Word8 -> Word8 -> V4 Word8
forall a. a -> a -> a -> a -> V4 a
SDL.V4 Word8
0 Word8
0 Word8
0 Word8
sDL_ALPHA_OPAQUE
greyRGBA :: SDL.V4 Word8
greyRGBA :: V4 Word8
greyRGBA = Word8 -> Word8 -> Word8 -> Word8 -> V4 Word8
forall a. a -> a -> a -> a -> V4 a
SDL.V4 Word8
0x25 Word8
0x1F Word8
0x1F Word8
sDL_ALPHA_OPAQUE
colorToRGBA :: Color.Color -> SDL.V4 Word8
colorToRGBA :: Color -> V4 Word8
colorToRGBA Color
Color.Black = V4 Word8
blackRGBA
colorToRGBA Color
Color.Red = Word8 -> Word8 -> Word8 -> Word8 -> V4 Word8
forall a. a -> a -> a -> a -> V4 a
SDL.V4 Word8
0xD5 Word8
0x05 Word8
0x05 Word8
sDL_ALPHA_OPAQUE
colorToRGBA Color
Color.Green = Word8 -> Word8 -> Word8 -> Word8 -> V4 Word8
forall a. a -> a -> a -> a -> V4 a
SDL.V4 Word8
0x05 Word8
0x9D Word8
0x05 Word8
sDL_ALPHA_OPAQUE
colorToRGBA Color
Color.Brown = Word8 -> Word8 -> Word8 -> Word8 -> V4 Word8
forall a. a -> a -> a -> a -> V4 a
SDL.V4 Word8
0xCA Word8
0x4A Word8
0x05 Word8
sDL_ALPHA_OPAQUE
colorToRGBA Color
Color.Blue = Word8 -> Word8 -> Word8 -> Word8 -> V4 Word8
forall a. a -> a -> a -> a -> V4 a
SDL.V4 Word8
0x05 Word8
0x56 Word8
0xF4 Word8
sDL_ALPHA_OPAQUE
colorToRGBA Color
Color.Magenta = Word8 -> Word8 -> Word8 -> Word8 -> V4 Word8
forall a. a -> a -> a -> a -> V4 a
SDL.V4 Word8
0xAF Word8
0x0E Word8
0xAF Word8
sDL_ALPHA_OPAQUE
colorToRGBA Color
Color.Cyan = Word8 -> Word8 -> Word8 -> Word8 -> V4 Word8
forall a. a -> a -> a -> a -> V4 a
SDL.V4 Word8
0x05 Word8
0x96 Word8
0x96 Word8
sDL_ALPHA_OPAQUE
colorToRGBA Color
Color.White = Word8 -> Word8 -> Word8 -> Word8 -> V4 Word8
forall a. a -> a -> a -> a -> V4 a
SDL.V4 Word8
0xB8 Word8
0xBF Word8
0xCB Word8
sDL_ALPHA_OPAQUE
colorToRGBA Color
Color.AltWhite = Word8 -> Word8 -> Word8 -> Word8 -> V4 Word8
forall a. a -> a -> a -> a -> V4 a
SDL.V4 Word8
0xC4 Word8
0xBE Word8
0xB1 Word8
sDL_ALPHA_OPAQUE
colorToRGBA Color
Color.BrBlack = Word8 -> Word8 -> Word8 -> Word8 -> V4 Word8
forall a. a -> a -> a -> a -> V4 a
SDL.V4 Word8
0x6F Word8
0x5F Word8
0x5F Word8
sDL_ALPHA_OPAQUE
colorToRGBA Color
Color.BrRed = Word8 -> Word8 -> Word8 -> Word8 -> V4 Word8
forall a. a -> a -> a -> a -> V4 a
SDL.V4 Word8
0xFF Word8
0x55 Word8
0x55 Word8
sDL_ALPHA_OPAQUE
colorToRGBA Color
Color.BrGreen = Word8 -> Word8 -> Word8 -> Word8 -> V4 Word8
forall a. a -> a -> a -> a -> V4 a
SDL.V4 Word8
0x65 Word8
0xF1 Word8
0x36 Word8
sDL_ALPHA_OPAQUE
colorToRGBA Color
Color.BrYellow = Word8 -> Word8 -> Word8 -> Word8 -> V4 Word8
forall a. a -> a -> a -> a -> V4 a
SDL.V4 Word8
0xEB Word8
0xD6 Word8
0x42 Word8
sDL_ALPHA_OPAQUE
colorToRGBA Color
Color.BrBlue = Word8 -> Word8 -> Word8 -> Word8 -> V4 Word8
forall a. a -> a -> a -> a -> V4 a
SDL.V4 Word8
0x4D Word8
0x98 Word8
0xF4 Word8
sDL_ALPHA_OPAQUE
colorToRGBA Color
Color.BrMagenta = Word8 -> Word8 -> Word8 -> Word8 -> V4 Word8
forall a. a -> a -> a -> a -> V4 a
SDL.V4 Word8
0xFF Word8
0x77 Word8
0xFF Word8
sDL_ALPHA_OPAQUE
colorToRGBA Color
Color.BrCyan = Word8 -> Word8 -> Word8 -> Word8 -> V4 Word8
forall a. a -> a -> a -> a -> V4 a
SDL.V4 Word8
0x52 Word8
0xF4 Word8
0xE5 Word8
sDL_ALPHA_OPAQUE
colorToRGBA Color
Color.BrWhite = Word8 -> Word8 -> Word8 -> Word8 -> V4 Word8
forall a. a -> a -> a -> a -> V4 a
SDL.V4 Word8
0xFF Word8
0xFF Word8
0xFF Word8
sDL_ALPHA_OPAQUE