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.Unboxed as U
import Data.Word (Word32, Word8)
import Foreign.C.String (withCString)
import Foreign.C.Types (CInt)
import Foreign.Ptr (nullPtr)
import Foreign.Storable (peek)
import System.Directory
import System.Exit (exitSuccess)
import System.FilePath
import qualified SDL
import qualified SDL.Font as TTF
import SDL.Input.Keyboard.Codes
import qualified SDL.Internal.Types
import qualified SDL.Raw.Basic as SDL (logSetAllPriority)
import qualified SDL.Raw.Enum
import qualified SDL.Raw.Types
import qualified SDL.Raw.Video
import qualified SDL.Vect as Vect
import Game.LambdaHack.Client.ClientOptions
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.Common.File
import Game.LambdaHack.Common.Misc
import Game.LambdaHack.Common.Point
import qualified Game.LambdaHack.Common.PointArray as PointArray
import Game.LambdaHack.Content.TileKind (floorSymbol)
import qualified Game.LambdaHack.Definition.Color as Color
type FontAtlas = EM.EnumMap Color.AttrCharW32 SDL.Texture
data FrontendSession = FrontendSession
{ FrontendSession -> Window
swindow :: SDL.Window
, FrontendSession -> Renderer
srenderer :: SDL.Renderer
, FrontendSession -> Font
sfont :: TTF.Font
, FrontendSession -> IORef FontAtlas
satlas :: IORef FontAtlas
, 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 = "sdl"
startup :: ScreenContent -> ClientOptions -> IO RawFrontend
startup :: ScreenContent -> ClientOptions -> IO RawFrontend
startup coscreen :: ScreenContent
coscreen soptions :: ClientOptions
soptions = (MVar RawFrontend -> IO ()) -> IO RawFrontend
startupBound ((MVar RawFrontend -> IO ()) -> IO RawFrontend)
-> (MVar RawFrontend -> IO ()) -> IO RawFrontend
forall a b. (a -> b) -> a -> b
$ ScreenContent -> ClientOptions -> MVar RawFrontend -> IO ()
startupFun ScreenContent
coscreen ClientOptions
soptions
startupFun :: ScreenContent -> ClientOptions -> MVar RawFrontend -> IO ()
startupFun :: ScreenContent -> ClientOptions -> MVar RawFrontend -> IO ()
startupFun coscreen :: ScreenContent
coscreen soptions :: ClientOptions
soptions@ClientOptions{..} rfMVar :: MVar RawFrontend
rfMVar = do
[InitFlag] -> IO ()
forall (f :: * -> *) (m :: * -> *).
(Foldable f, Functor m, MonadIO m) =>
f InitFlag -> m ()
SDL.initialize [InitFlag
SDL.InitEvents]
LogPriority -> IO ()
forall (m :: * -> *). MonadIO m => LogPriority -> m ()
SDL.logSetAllPriority (LogPriority -> IO ()) -> LogPriority -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> LogPriority
forall a. Enum a => Int -> a
toEnum (Int -> LogPriority) -> Int -> LogPriority
forall a b. (a -> b) -> a -> b
$ Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe 5 Maybe Int
slogPriority
let title :: Text
title = Maybe Text -> Text
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Text
stitle
fontFileName :: String
fontFileName = Text -> String
T.unpack (Maybe Text -> Text
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Text
sdlFontFile)
fontFileOrig :: String
fontFileOrig | String -> Bool
isRelative String
fontFileName = Maybe String -> String
forall a. HasCallStack => Maybe a -> a
fromJust Maybe String
sfontDir String -> String -> String
</> String
fontFileName
| Bool
otherwise = String
fontFileName
(fontFileExists :: Bool
fontFileExists, fontFile :: String
fontFile) <- do
Bool
fontFileOrigExists <- String -> IO Bool
doesFileExist String
fontFileOrig
if Bool
fontFileOrigExists
then (Bool, String) -> IO (Bool, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, String
fontFileOrig)
else do
let fontFileAlt :: String
fontFileAlt = String -> String
dropExtension String
fontFileOrig String -> String -> String
<.> "fnt"
Bool
fontFileAltExists <- String -> IO Bool
doesFileExist String
fontFileAlt
(Bool, String) -> IO (Bool, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
fontFileAltExists, String
fontFileAlt)
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
fontFileExists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Font file does not exist: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fontFileOrig
let fontSize :: Int
fontSize = Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Int
sscalableFontSize
IO ()
forall (m :: * -> *). MonadIO m => m ()
TTF.initialize
Font
sfont <- String -> Int -> IO Font
forall (m :: * -> *). MonadIO m => String -> Int -> m Font
TTF.load String
fontFile Int
fontSize
let isBitmapFile :: Bool
isBitmapFile = "fon" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` Text -> String
T.unpack (Maybe Text -> Text
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Text
sdlFontFile)
Bool -> Bool -> Bool
|| "fnt" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` Text -> String
T.unpack (Maybe Text -> Text
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Text
sdlFontFile)
Bool -> Bool -> Bool
|| "bdf" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` Text -> String
T.unpack (Maybe Text -> Text
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Text
sdlFontFile)
Bool -> Bool -> Bool
|| "FON" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` Text -> String
T.unpack (Maybe Text -> Text
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Text
sdlFontFile)
Bool -> Bool -> Bool
|| "FNT" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` Text -> String
T.unpack (Maybe Text -> Text
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Text
sdlFontFile)
Bool -> Bool -> Bool
|| "BDF" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` Text -> String
T.unpack (Maybe Text -> Text
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Text
sdlFontFile)
sdlSizeAdd :: Int
sdlSizeAdd = Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ if Bool
isBitmapFile
then Maybe Int
sdlBitmapSizeAdd
else Maybe Int
sdlScalableSizeAdd
Int
boxSize <- (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
sdlSizeAdd) (Int -> Int) -> IO Int -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Font -> IO Int
forall (m :: * -> *). MonadIO m => Font -> m Int
TTF.height Font
sfont
if Maybe Int
slogPriority Maybe Int -> Maybe Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> Maybe Int
forall a. a -> Maybe a
Just 0 then do
RawFrontend
rf <- ScreenContent -> (SingleFrame -> IO ()) -> IO () -> IO RawFrontend
createRawFrontend ScreenContent
coscreen (\_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
MVar RawFrontend -> RawFrontend -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar RawFrontend
rfMVar RawFrontend
rf
Font -> IO ()
forall (m :: * -> *). MonadIO m => Font -> m ()
TTF.free Font
sfont
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 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}
rendererConfig :: RendererConfig
rendererConfig = RendererConfig :: RendererType -> Bool -> RendererConfig
SDL.RendererConfig
{ rendererType :: RendererType
rendererType = if Bool
sbenchmark
then RendererType
SDL.AcceleratedRenderer
else RendererType
SDL.AcceleratedVSyncRenderer
, rendererTargetTexture :: Bool
rendererTargetTexture = Bool
True
}
Window
swindow <- Text -> WindowConfig -> IO Window
forall (m :: * -> *). MonadIO m => Text -> WindowConfig -> m Window
SDL.createWindow Text
title WindowConfig
windowConfig
Renderer
srenderer <- Window -> CInt -> RendererConfig -> IO Renderer
forall (m :: * -> *).
MonadIO m =>
Window -> CInt -> RendererConfig -> m Renderer
SDL.createRenderer Window
swindow (-1) RendererConfig
rendererConfig
let initTexture :: IO Texture
initTexture = do
Texture
texture <- Renderer -> PixelFormat -> TextureAccess -> V2 CInt -> IO Texture
forall (m :: * -> *).
(Functor m, MonadIO m) =>
Renderer -> PixelFormat -> TextureAccess -> V2 CInt -> m Texture
SDL.createTexture Renderer
srenderer PixelFormat
SDL.ARGB8888
TextureAccess
SDL.TextureAccessTarget V2 CInt
screenV2
Renderer -> StateVar (Maybe Texture)
SDL.rendererRenderTarget Renderer
srenderer StateVar (Maybe Texture) -> Maybe Texture -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
SDL.$= Texture -> Maybe Texture
forall a. a -> Maybe a
Just Texture
texture
Renderer -> StateVar BlendMode
SDL.rendererDrawBlendMode Renderer
srenderer StateVar BlendMode -> BlendMode -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
SDL.$= BlendMode
SDL.BlendNone
Renderer -> StateVar (V4 Word8)
SDL.rendererDrawColor Renderer
srenderer StateVar (V4 Word8) -> V4 Word8 -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
SDL.$= Color -> V4 Word8
colorToRGBA Color
Color.Black
Renderer -> IO ()
forall (m :: * -> *). (Functor m, MonadIO m) => Renderer -> m ()
SDL.clear Renderer
srenderer
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
Texture -> IO Texture
forall (m :: * -> *) a. Monad m => a -> m a
return Texture
texture
Texture
texture <- IO Texture
initTexture
IORef FontAtlas
satlas <- FontAtlas -> IO (IORef FontAtlas)
forall a. a -> IO (IORef a)
newIORef FontAtlas
forall k a. EnumMap k a
EM.empty
IORef Texture
stexture <- Texture -> IO (IORef Texture)
forall a. a -> IO (IORef a)
newIORef Texture
texture
IORef SingleFrame
spreviousFrame <- SingleFrame -> IO (IORef SingleFrame)
forall a. a -> IO (IORef a)
newIORef (SingleFrame -> IO (IORef SingleFrame))
-> SingleFrame -> IO (IORef SingleFrame)
forall a b. (a -> b) -> a -> b
$ ScreenContent -> SingleFrame
blankSingleFrame ScreenContent
coscreen
IORef Bool
sforcedShutdown <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
IORef Bool
scontinueSdlLoop <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
True
MVar SingleFrame
sframeQueue <- IO (MVar SingleFrame)
forall a. IO (MVar a)
newEmptyMVar
MVar ()
sframeDrawn <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
let sess :: FrontendSession
sess = $WFrontendSession :: Window
-> Renderer
-> Font
-> IORef FontAtlas
-> IORef Texture
-> IORef SingleFrame
-> IORef Bool
-> IORef Bool
-> MVar SingleFrame
-> MVar ()
-> FrontendSession
FrontendSession{..}
RawFrontend
rfWithoutPrintScreen <-
ScreenContent -> (SingleFrame -> IO ()) -> IO () -> IO RawFrontend
createRawFrontend ScreenContent
coscreen (FrontendSession -> SingleFrame -> IO ()
display FrontendSession
sess) (FrontendSession -> IO ()
shutdown FrontendSession
sess)
let rf :: RawFrontend
rf = RawFrontend
rfWithoutPrintScreen {fprintScreen :: IO ()
fprintScreen = FrontendSession -> IO ()
printScreen FrontendSession
sess}
MVar RawFrontend -> RawFrontend -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar RawFrontend
rfMVar RawFrontend
rf
let pointTranslate :: forall i. (Enum i) => Vect.Point Vect.V2 i -> Point
pointTranslate :: Point V2 i -> Point
pointTranslate (SDL.P (SDL.V2 x :: i
x y :: i
y)) =
Int -> Int -> Point
Point (i -> Int
forall a. Enum a => a -> Int
fromEnum i
x Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
boxSize) (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
satlas
IORef FontAtlas -> FontAtlas -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef FontAtlas
satlas FontAtlas
forall k a. EnumMap k a
EM.empty
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 b.
(Foldable t, Monad m) =>
(a -> m b) -> 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 ()
forall (m :: * -> *). MonadIO m => Texture -> m ()
SDL.destroyTexture Texture
oldTexture
IORef Texture -> Texture -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Texture
stexture Texture
newTexture
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 (ScreenContent -> SingleFrame
blankSingleFrame ScreenContent
coscreen)
ClientOptions -> FrontendSession -> SingleFrame -> IO ()
drawFrame ClientOptions
soptions FrontendSession
sess SingleFrame
prevFrame
loopSDL :: IO ()
loopSDL :: IO ()
loopSDL = do
Maybe Event
me <- IO (Maybe Event)
forall (m :: * -> *). MonadIO m => m (Maybe Event)
SDL.pollEvent
case Maybe Event
me of
Nothing -> do
Maybe SingleFrame
mfr <- MVar SingleFrame -> IO (Maybe SingleFrame)
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar SingleFrame
sframeQueue
case Maybe SingleFrame
mfr of
Just fr :: SingleFrame
fr -> do
SingleFrame
prevFrame <- IORef SingleFrame -> IO SingleFrame
forall a. IORef a -> IO a
readIORef IORef SingleFrame
spreviousFrame
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (SingleFrame
prevFrame SingleFrame -> SingleFrame -> Bool
forall a. Eq a => a -> a -> Bool
== SingleFrame
fr) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
ClientOptions -> FrontendSession -> SingleFrame -> IO ()
drawFrame ClientOptions
soptions FrontendSession
sess SingleFrame
fr
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
MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
sframeDrawn ()
Nothing -> Int -> IO ()
threadDelay (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ if Bool
sbenchmark then 150 else 15000
Just e :: Event
e -> Event -> IO ()
handleEvent Event
e
Bool
continueSdlLoop <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
scontinueSdlLoop
if Bool
continueSdlLoop
then IO ()
loopSDL
else do
Font -> IO ()
forall (m :: * -> *). MonadIO m => Font -> m ()
TTF.free Font
sfont
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 e :: Event
e = case Event -> EventPayload
SDL.eventPayload Event
e of
SDL.KeyboardEvent keyboardEvent :: KeyboardEventData
keyboardEvent
| KeyboardEventData -> InputMotion
SDL.keyboardEventKeyMotion KeyboardEventData
keyboardEvent InputMotion -> InputMotion -> Bool
forall a. Eq a => a -> a -> Bool
== InputMotion
SDL.Pressed -> do
let sym :: Keysym
sym = KeyboardEventData -> Keysym
SDL.keyboardEventKeysym KeyboardEventData
keyboardEvent
ksm :: KeyModifier
ksm = Keysym -> KeyModifier
SDL.keysymModifier Keysym
sym
shiftPressed :: Bool
shiftPressed = KeyModifier -> Bool
SDL.keyModifierLeftShift KeyModifier
ksm
Bool -> Bool -> Bool
|| KeyModifier -> Bool
SDL.keyModifierRightShift KeyModifier
ksm
key :: Key
key = Bool -> Keycode -> Key
keyTranslate Bool
shiftPressed (Keycode -> Key) -> Keycode -> Key
forall a b. (a -> b) -> a -> b
$ Keysym -> Keycode
SDL.keysymKeycode Keysym
sym
modifier :: Modifier
modifier = KeyModifier -> Modifier
modTranslate KeyModifier
ksm
modifierNoShift :: Modifier
modifierNoShift = case Modifier
modifier of
K.Shift -> Modifier
K.NoModifier
K.ControlShift -> Modifier
K.Control
_ -> 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 -> Point -> IO ()
saveKMP RawFrontend
rf Modifier
modifierNoShift Key
key (Point V2 CInt -> Point
forall i. Enum i => Point V2 i -> Point
pointTranslate Point V2 CInt
p)
SDL.MouseButtonEvent mouseButtonEvent :: MouseButtonEventData
mouseButtonEvent
| MouseButtonEventData -> InputMotion
SDL.mouseButtonEventMotion MouseButtonEventData
mouseButtonEvent InputMotion -> InputMotion -> Bool
forall a. Eq a => a -> a -> Bool
== InputMotion
SDL.Released -> do
Modifier
modifier <- KeyModifier -> Modifier
modTranslate (KeyModifier -> Modifier) -> IO KeyModifier -> IO Modifier
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO KeyModifier
forall (m :: * -> *). (Functor m, MonadIO m) => m KeyModifier
SDL.getModState
let key :: Key
key = case MouseButtonEventData -> MouseButton
SDL.mouseButtonEventButton MouseButtonEventData
mouseButtonEvent of
SDL.ButtonLeft -> Key
K.LeftButtonRelease
SDL.ButtonMiddle -> Key
K.MiddleButtonRelease
SDL.ButtonRight -> Key
K.RightButtonRelease
_ -> Key
K.LeftButtonRelease
p :: Point V2 Int32
p = MouseButtonEventData -> Point V2 Int32
SDL.mouseButtonEventPos MouseButtonEventData
mouseButtonEvent
RawFrontend -> Modifier -> Key -> Point -> IO ()
saveKMP RawFrontend
rf Modifier
modifier Key
key (Point V2 Int32 -> Point
forall i. Enum i => Point V2 i -> Point
pointTranslate Point V2 Int32
p)
SDL.MouseWheelEvent mouseWheelEvent :: MouseWheelEventData
mouseWheelEvent -> do
Modifier
modifier <- KeyModifier -> Modifier
modTranslate (KeyModifier -> Modifier) -> IO KeyModifier -> IO Modifier
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO KeyModifier
forall (m :: * -> *). (Functor m, MonadIO m) => m KeyModifier
SDL.getModState
let SDL.V2 _ y :: Int32
y = MouseWheelEventData -> V2 Int32
SDL.mouseWheelEventPos MouseWheelEventData
mouseWheelEvent
mkey :: Maybe Key
mkey = case (Int32 -> Int32 -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int32
y 0, MouseWheelEventData -> MouseScrollDirection
SDL.mouseWheelEventDirection
MouseWheelEventData
mouseWheelEvent) of
(EQ, _) -> Maybe Key
forall a. Maybe a
Nothing
(LT, SDL.ScrollNormal) -> Key -> Maybe Key
forall a. a -> Maybe a
Just Key
K.WheelSouth
(GT, SDL.ScrollNormal) -> Key -> Maybe Key
forall a. a -> Maybe a
Just Key
K.WheelNorth
(LT, SDL.ScrollFlipped) -> Key -> Maybe Key
forall a. a -> Maybe a
Just Key
K.WheelNorth
(GT, SDL.ScrollFlipped) -> Key -> Maybe Key
forall a. a -> Maybe a
Just Key
K.WheelSouth
Point V2 CInt
p <- IO (Point V2 CInt)
forall (m :: * -> *). MonadIO m => m (Point V2 CInt)
SDL.getAbsoluteMouseLocation
IO () -> (Key -> IO ()) -> Maybe Key -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
(\key :: Key
key -> RawFrontend -> Modifier -> Key -> Point -> IO ()
saveKMP RawFrontend
rf Modifier
modifier Key
key (Point V2 CInt -> Point
forall i. Enum i => Point V2 i -> Point
pointTranslate Point V2 CInt
p)) Maybe Key
mkey
SDL.WindowClosedEvent{} -> FrontendSession -> IO ()
forceShutdown FrontendSession
sess
SDL.QuitEvent -> FrontendSession -> IO ()
forceShutdown FrontendSession
sess
SDL.WindowRestoredEvent{} -> IO ()
redraw
SDL.WindowExposedEvent{} -> IO ()
redraw
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
IO ()
loopSDL
shutdown :: FrontendSession -> IO ()
shutdown :: FrontendSession -> IO ()
shutdown FrontendSession{..} = IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
scontinueSdlLoop Bool
False
forceShutdown :: FrontendSession -> IO ()
forceShutdown :: FrontendSession -> IO ()
forceShutdown sess :: FrontendSession
sess@FrontendSession{..} = do
IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
sforcedShutdown Bool
True
FrontendSession -> IO ()
shutdown FrontendSession
sess
display :: FrontendSession
-> SingleFrame
-> IO ()
display :: FrontendSession -> SingleFrame -> IO ()
display FrontendSession{..} curFrame :: SingleFrame
curFrame = do
Bool
continueSdlLoop <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
scontinueSdlLoop
if Bool
continueSdlLoop then do
MVar SingleFrame -> SingleFrame -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar SingleFrame
sframeQueue SingleFrame
curFrame
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 50000
drawFrame :: ClientOptions
-> FrontendSession
-> SingleFrame
-> IO ()
drawFrame :: ClientOptions -> FrontendSession -> SingleFrame -> IO ()
drawFrame ClientOptions{..} FrontendSession{..} curFrame :: SingleFrame
curFrame = do
let isBitmapFile :: Bool
isBitmapFile = "fon" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` Text -> String
T.unpack (Maybe Text -> Text
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Text
sdlFontFile)
Bool -> Bool -> Bool
|| "fnt" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` Text -> String
T.unpack (Maybe Text -> Text
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Text
sdlFontFile)
Bool -> Bool -> Bool
|| "bdf" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` Text -> String
T.unpack (Maybe Text -> Text
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Text
sdlFontFile)
Bool -> Bool -> Bool
|| "FON" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` Text -> String
T.unpack (Maybe Text -> Text
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Text
sdlFontFile)
Bool -> Bool -> Bool
|| "FNT" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` Text -> String
T.unpack (Maybe Text -> Text
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Text
sdlFontFile)
Bool -> Bool -> Bool
|| "BDF" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` Text -> String
T.unpack (Maybe Text -> Text
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Text
sdlFontFile)
sdlSizeAdd :: Int
sdlSizeAdd = Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ if Bool
isBitmapFile
then Maybe Int
sdlBitmapSizeAdd
else Maybe Int
sdlScalableSizeAdd
Int
boxSize <- (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
sdlSizeAdd) (Int -> Int) -> IO Int -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Font -> IO Int
forall (m :: * -> *). MonadIO m => Font -> m Int
TTF.height Font
sfont
let 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
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 x :: Int
x y :: Int
y = V2 CInt -> Point V2 CInt
forall (f :: * -> *) a. f a -> Point f a
Vect.P (V2 CInt -> Point V2 CInt) -> V2 CInt -> Point V2 CInt
forall a b. (a -> b) -> a -> b
$ CInt -> CInt -> V2 CInt
forall a. a -> a -> V2 a
Vect.V2 (Int -> CInt
forall a. Enum a => Int -> a
toEnum Int
x) (Int -> CInt
forall a. Enum a => Int -> a
toEnum Int
y)
drawHighlight :: Int -> Int -> Color -> IO ()
drawHighlight !Int
x !Int
y !Color
color = do
Renderer -> StateVar (V4 Word8)
SDL.rendererDrawColor Renderer
srenderer StateVar (V4 Word8) -> V4 Word8 -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
SDL.$= Color -> V4 Word8
colorToRGBA Color
color
let rect :: Rectangle CInt
rect = Point V2 CInt -> V2 CInt -> Rectangle CInt
forall a. Point V2 a -> V2 a -> Rectangle a
SDL.Rectangle (Int -> Int -> Point V2 CInt
vp (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
boxSize) (Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
boxSize)) V2 CInt
tt2
Renderer -> Maybe (Rectangle CInt) -> IO ()
forall (m :: * -> *).
MonadIO m =>
Renderer -> Maybe (Rectangle CInt) -> m ()
SDL.drawRect Renderer
srenderer (Maybe (Rectangle CInt) -> IO ())
-> Maybe (Rectangle CInt) -> IO ()
forall a b. (a -> b) -> a -> b
$ Rectangle CInt -> Maybe (Rectangle CInt)
forall a. a -> Maybe a
Just Rectangle CInt
rect
Renderer -> StateVar (V4 Word8)
SDL.rendererDrawColor Renderer
srenderer StateVar (V4 Word8) -> V4 Word8 -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
SDL.$= Color -> V4 Word8
colorToRGBA Color
Color.Black
chooseAndDrawHighlight :: Int -> Int -> Highlight -> IO ()
chooseAndDrawHighlight !Int
x !Int
y !Highlight
bg = case Highlight
bg of
Color.HighlightNone -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
_ -> Int -> Int -> Color -> IO ()
drawHighlight Int
x Int
y (Color -> IO ()) -> Color -> IO ()
forall a b. (a -> b) -> a -> b
$ Highlight -> Color
Color.highlightToColor Highlight
bg
setChar :: Int -> (Word32, Word32) -> IO Int
setChar :: Int -> (LogPriority, LogPriority) -> IO Int
setChar !Int
i (!LogPriority
w, !LogPriority
wPrev) | LogPriority
w LogPriority -> LogPriority -> Bool
forall a. Eq a => a -> a -> Bool
== LogPriority
wPrev = Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$! Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
setChar i :: Int
i (w :: LogPriority
w, _) = do
FontAtlas
atlas <- IORef FontAtlas -> IO FontAtlas
forall a. IORef a -> IO a
readIORef IORef FontAtlas
satlas
let Point{..} = Int -> Point
forall a. Enum a => Int -> a
toEnum Int
i
Color.AttrChar{acAttr :: AttrChar -> Attr
acAttr=Color.Attr{fg :: Attr -> Color
fg=Color
fgRaw,Highlight
bg :: Attr -> Highlight
bg :: Highlight
bg}, acChar :: AttrChar -> Char
acChar=Char
acCharRaw} =
AttrCharW32 -> AttrChar
Color.attrCharFromW32 (AttrCharW32 -> AttrChar) -> AttrCharW32 -> AttrChar
forall a b. (a -> b) -> a -> b
$ LogPriority -> AttrCharW32
Color.AttrCharW32 LogPriority
w
fg :: Color
fg | Int
py Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` 2 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 Bool -> Bool -> Bool
&& Color
fgRaw Color -> Color -> Bool
forall a. Eq a => a -> a -> Bool
== Color
Color.White = Color
Color.AltWhite
| Bool
otherwise = Color
fgRaw
ac :: AttrCharW32
ac = Color -> Char -> AttrCharW32
Color.attrChar2ToW32 Color
fg Char
acCharRaw
Texture
textTexture <- case AttrCharW32 -> FontAtlas -> Maybe Texture
forall k a. Enum k => k -> EnumMap k a -> Maybe a
EM.lookup AttrCharW32
ac FontAtlas
atlas of
Nothing -> do
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
isBitmapFile
then Int -> Char
Char.chr 7
else Int -> Char
Char.chr 8901
else Char
acCharRaw
Surface
textSurfaceRaw <- Font -> V4 Word8 -> V4 Word8 -> Char -> IO Surface
forall (m :: * -> *).
MonadIO m =>
Font -> V4 Word8 -> V4 Word8 -> Char -> m Surface
TTF.shadedGlyph Font
sfont (Color -> V4 Word8
colorToRGBA Color
fg)
(Color -> V4 Word8
colorToRGBA Color
Color.Black) Char
acChar
Vect.V2 sw :: CInt
sw sh :: CInt
sh <- Surface -> IO (V2 CInt)
forall (m :: * -> *). MonadIO m => Surface -> m (V2 CInt)
SDL.surfaceDimensions Surface
textSurfaceRaw
let width :: Int
width = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
boxSize (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ CInt -> Int
forall a. Enum a => a -> Int
fromEnum CInt
sw
height :: Int
height = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
boxSize (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ CInt -> Int
forall a. Enum a => a -> Int
fromEnum CInt
sh
xsrc :: Int
xsrc = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max 0 (CInt -> Int
forall a. Enum a => a -> Int
fromEnum CInt
sw Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
width) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 2
ysrc :: Int
ysrc = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max 0 (CInt -> Int
forall a. Enum a => a -> Int
fromEnum CInt
sh Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
height) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 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
boxSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
width) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`divUp` 2
ytgt :: Int
ytgt = (Int
boxSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
height) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 2
tgtR :: Point V2 CInt
tgtR = Int -> Int -> Point V2 CInt
vp Int
xtgt Int
ytgt
Surface
textSurface <- V2 CInt -> PixelFormat -> IO Surface
forall (m :: * -> *).
(Functor m, MonadIO m) =>
V2 CInt -> PixelFormat -> m Surface
SDL.createRGBSurface V2 CInt
tt2 PixelFormat
SDL.ARGB8888
Surface -> Maybe (Rectangle CInt) -> V4 Word8 -> IO ()
forall (m :: * -> *).
MonadIO m =>
Surface -> Maybe (Rectangle CInt) -> V4 Word8 -> m ()
SDL.surfaceFillRect Surface
textSurface Maybe (Rectangle CInt)
forall a. Maybe a
Nothing (Color -> V4 Word8
colorToRGBA Color
Color.Black)
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
IORef FontAtlas -> FontAtlas -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef FontAtlas
satlas (FontAtlas -> IO ()) -> FontAtlas -> IO ()
forall a b. (a -> b) -> a -> b
$ AttrCharW32 -> Texture -> FontAtlas -> FontAtlas
forall k a. Enum k => k -> a -> EnumMap k a -> EnumMap k a
EM.insert AttrCharW32
ac Texture
textTexture FontAtlas
atlas
Texture -> IO Texture
forall (m :: * -> *) a. Monad m => a -> m a
return Texture
textTexture
Just textTexture :: Texture
textTexture -> Texture -> IO Texture
forall (m :: * -> *) a. Monad m => a -> m a
return Texture
textTexture
let tgtR :: Rectangle CInt
tgtR = Point V2 CInt -> V2 CInt -> Rectangle CInt
forall a. Point V2 a -> V2 a -> Rectangle a
SDL.Rectangle (Int -> Int -> Point V2 CInt
vp (Int
px Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
boxSize) (Int
py Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
boxSize)) V2 CInt
tt2
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
px Int
py Highlight
bg
Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$! Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
Texture
texture <- IORef Texture -> IO Texture
forall a. IORef a -> IO a
readIORef IORef Texture
stexture
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
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.$= Texture -> Maybe Texture
forall a. a -> Maybe a
Just Texture
texture
Renderer -> StateVar (V4 Word8)
SDL.rendererDrawColor Renderer
srenderer StateVar (V4 Word8) -> V4 Word8 -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
SDL.$= Color -> V4 Word8
colorToRGBA Color
Color.Black
(Int -> (LogPriority, LogPriority) -> IO Int)
-> Int -> Vector (LogPriority, LogPriority) -> IO ()
forall (m :: * -> *) b a.
(Monad m, Unbox b) =>
(a -> b -> m a) -> a -> Vector b -> m ()
U.foldM'_ Int -> (LogPriority, LogPriority) -> IO Int
setChar 0 (Vector (LogPriority, LogPriority) -> IO ())
-> Vector (LogPriority, LogPriority) -> IO ()
forall a b. (a -> b) -> a -> b
$ Vector LogPriority
-> Vector LogPriority -> Vector (LogPriority, LogPriority)
forall a b.
(Unbox a, Unbox b) =>
Vector a -> Vector b -> Vector (a, b)
U.zip (Array AttrCharW32 -> Vector LogPriority
forall c. Array c -> Vector (UnboxRep c)
PointArray.avector (Array AttrCharW32 -> Vector LogPriority)
-> Array AttrCharW32 -> Vector LogPriority
forall a b. (a -> b) -> a -> b
$ SingleFrame -> Array AttrCharW32
singleFrame SingleFrame
curFrame)
(Array AttrCharW32 -> Vector LogPriority
forall c. Array c -> Vector (UnboxRep c)
PointArray.avector (Array AttrCharW32 -> Vector LogPriority)
-> Array AttrCharW32 -> Vector LogPriority
forall a b. (a -> b) -> a -> b
$ SingleFrame -> Array AttrCharW32
singleFrame SingleFrame
prevFrame)
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
printScreen :: FrontendSession -> IO ()
printScreen :: FrontendSession -> IO ()
printScreen FrontendSession{..} = do
String
dataDir <- IO String
appDataDir
String -> IO ()
tryCreateDir String
dataDir
String -> IO ()
tryCreateDir (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
dataDir String -> String -> String
</> "screenshots"
UTCTime
utcTime <- IO UTCTime
getCurrentTime
TimeZone
timezone <- UTCTime -> IO TimeZone
getTimeZone UTCTime
utcTime
let unspace :: String -> String
unspace = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map ((Char -> Char) -> String -> String)
-> (Char -> Char) -> String -> String
forall a b. (a -> b) -> a -> b
$ \c :: Char
c -> case Char
c of
' ' -> '_'
':' -> '.'
_ -> Char
c
dateText :: String
dateText = String -> String
unspace (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
forall a. Int -> [a] -> [a]
take 25 (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ LocalTime -> String
forall a. Show a => a -> String
show (LocalTime -> String) -> LocalTime -> String
forall a b. (a -> b) -> a -> b
$ TimeZone -> UTCTime -> LocalTime
utcToLocalTime TimeZone
timezone UTCTime
utcTime
fileName :: String
fileName = String
dataDir String -> String -> String
</> "screenshots" String -> String -> String
</> "prtscn" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
dateText String -> String -> String
<.> "bmp"
SDL.Internal.Types.Renderer renderer :: Renderer
renderer = Renderer
srenderer
Vect.V2 sw :: CInt
sw sh :: CInt
sh <- StateVar (V2 CInt) -> IO (V2 CInt)
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
SDL.get (StateVar (V2 CInt) -> IO (V2 CInt))
-> StateVar (V2 CInt) -> IO (V2 CInt)
forall a b. (a -> b) -> a -> b
$ Window -> StateVar (V2 CInt)
SDL.windowSize Window
swindow
Ptr Surface
ptrOut <- LogPriority
-> CInt
-> CInt
-> CInt
-> LogPriority
-> LogPriority
-> LogPriority
-> LogPriority
-> IO (Ptr Surface)
forall (m :: * -> *).
MonadIO m =>
LogPriority
-> CInt
-> CInt
-> CInt
-> LogPriority
-> LogPriority
-> LogPriority
-> LogPriority
-> m (Ptr Surface)
SDL.Raw.Video.createRGBSurface 0 CInt
sw CInt
sh 32 0 0 0 0
Surface
surfaceOut <- Ptr Surface -> IO Surface
forall a. Storable a => Ptr a -> IO a
peek Ptr Surface
ptrOut
IO CInt -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO CInt -> IO ()) -> IO CInt -> IO ()
forall a b. (a -> b) -> a -> b
$ Renderer -> Ptr Rect -> LogPriority -> Renderer -> CInt -> IO CInt
forall (m :: * -> *).
MonadIO m =>
Renderer -> Ptr Rect -> LogPriority -> Renderer -> CInt -> m CInt
SDL.Raw.Video.renderReadPixels
Renderer
renderer
Ptr Rect
forall a. Ptr a
nullPtr
LogPriority
forall a. (Eq a, Num a) => a
SDL.Raw.Enum.SDL_PIXELFORMAT_ARGB8888
(Surface -> Renderer
SDL.Raw.Types.surfacePixels Surface
surfaceOut)
(CInt
sw CInt -> CInt -> CInt
forall a. Num a => a -> a -> a
* 4)
String -> (CString -> IO ()) -> IO ()
forall a. String -> (CString -> IO a) -> IO a
withCString String
fileName ((CString -> IO ()) -> IO ()) -> (CString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \fileNameCString :: CString
fileNameCString ->
IO CInt -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO CInt -> IO ()) -> IO CInt -> IO ()
forall a b. (a -> b) -> a -> b
$! Ptr Surface -> CString -> IO CInt
forall (m :: * -> *). MonadIO m => Ptr Surface -> CString -> m CInt
SDL.Raw.Video.saveBMP Ptr Surface
ptrOut CString
fileNameCString
Ptr Surface -> IO ()
forall (m :: * -> *). MonadIO m => Ptr Surface -> m ()
SDL.Raw.Video.freeSurface Ptr Surface
ptrOut
modTranslate :: SDL.KeyModifier -> K.Modifier
modTranslate :: KeyModifier -> Modifier
modTranslate m :: KeyModifier
m =
Bool -> Bool -> Bool -> Bool -> Modifier
modifierTranslate
(KeyModifier -> Bool
SDL.keyModifierLeftCtrl KeyModifier
m Bool -> Bool -> Bool
|| KeyModifier -> Bool
SDL.keyModifierRightCtrl KeyModifier
m)
(KeyModifier -> Bool
SDL.keyModifierLeftShift KeyModifier
m Bool -> Bool -> Bool
|| KeyModifier -> Bool
SDL.keyModifierRightShift KeyModifier
m)
(KeyModifier -> Bool
SDL.keyModifierLeftAlt KeyModifier
m
Bool -> Bool -> Bool
|| KeyModifier -> Bool
SDL.keyModifierRightAlt KeyModifier
m
Bool -> Bool -> Bool
|| KeyModifier -> Bool
SDL.keyModifierAltGr KeyModifier
m)
Bool
False
keyTranslate :: Bool -> SDL.Keycode -> K.Key
keyTranslate :: Bool -> Keycode -> Key
keyTranslate shiftPressed :: Bool
shiftPressed n :: Keycode
n = case Keycode
n of
KeycodeEscape -> Key
K.Esc
KeycodeReturn -> Key
K.Return
KeycodeBackspace -> Key
K.BackSpace
KeycodeTab -> if Bool
shiftPressed then Key
K.BackTab else Key
K.Tab
KeycodeSpace -> Key
K.Space
KeycodeExclaim -> Char -> Key
K.Char '!'
KeycodeQuoteDbl -> Char -> Key
K.Char '"'
KeycodeHash -> Char -> Key
K.Char '#'
KeycodePercent -> Char -> Key
K.Char '%'
KeycodeDollar -> Char -> Key
K.Char '$'
KeycodeAmpersand -> Char -> Key
K.Char '&'
KeycodeQuote -> if Bool
shiftPressed then Char -> Key
K.Char '"' else Char -> Key
K.Char '\''
KeycodeLeftParen -> Char -> Key
K.Char '('
KeycodeRightParen -> Char -> Key
K.Char ')'
KeycodeAsterisk -> Char -> Key
K.Char '*'
KeycodePlus -> Char -> Key
K.Char '+'
KeycodeComma -> if Bool
shiftPressed then Char -> Key
K.Char '<' else Char -> Key
K.Char ','
KeycodeMinus -> if Bool
shiftPressed then Char -> Key
K.Char '_' else Char -> Key
K.Char '-'
KeycodePeriod -> if Bool
shiftPressed then Char -> Key
K.Char '>' else Char -> Key
K.Char '.'
KeycodeSlash -> if Bool
shiftPressed then Char -> Key
K.Char '?' else Char -> Key
K.Char '/'
Keycode1 -> if Bool
shiftPressed then Char -> Key
K.Char '!' else Char -> Key
K.Char '1'
Keycode2 -> if Bool
shiftPressed then Char -> Key
K.Char '@' else Char -> Key
K.Char '2'
Keycode3 -> if Bool
shiftPressed then Char -> Key
K.Char '#' else Char -> Key
K.Char '3'
Keycode4 -> if Bool
shiftPressed then Char -> Key
K.Char '$' else Char -> Key
K.Char '4'
Keycode5 -> if Bool
shiftPressed then Char -> Key
K.Char '%' else Char -> Key
K.Char '5'
Keycode6 -> if Bool
shiftPressed then Char -> Key
K.Char '^' else Char -> Key
K.Char '6'
Keycode7 -> if Bool
shiftPressed then Char -> Key
K.Char '&' else Char -> Key
K.Char '7'
Keycode8 -> if Bool
shiftPressed then Char -> Key
K.Char '*' else Char -> Key
K.Char '8'
Keycode9 -> if Bool
shiftPressed then Char -> Key
K.Char '(' else Char -> Key
K.Char '9'
Keycode0 -> if Bool
shiftPressed then Char -> Key
K.Char ')' else Char -> Key
K.Char '0'
KeycodeColon -> Char -> Key
K.Char ':'
KeycodeSemicolon -> if Bool
shiftPressed then Char -> Key
K.Char ':' else Char -> Key
K.Char ';'
KeycodeLess -> Char -> Key
K.Char '<'
KeycodeEquals -> if Bool
shiftPressed then Char -> Key
K.Char '+' else Char -> Key
K.Char '='
KeycodeGreater -> Char -> Key
K.Char '>'
KeycodeQuestion -> Char -> Key
K.Char '?'
KeycodeAt -> Char -> Key
K.Char '@'
KeycodeLeftBracket -> if Bool
shiftPressed then Char -> Key
K.Char '{' else Char -> Key
K.Char '['
KeycodeBackslash -> if Bool
shiftPressed then Char -> Key
K.Char '|' else Char -> Key
K.Char '\\'
KeycodeRightBracket -> if Bool
shiftPressed then Char -> Key
K.Char '}' else Char -> Key
K.Char ']'
KeycodeCaret -> Char -> Key
K.Char '^'
KeycodeUnderscore -> Char -> Key
K.Char '_'
KeycodeBackquote -> if Bool
shiftPressed then Char -> Key
K.Char '~' else Char -> Key
K.Char '`'
KeycodeUp -> Key
K.Up
KeycodeDown -> Key
K.Down
KeycodeLeft -> Key
K.Left
KeycodeRight -> Key
K.Right
KeycodeHome -> Key
K.Home
KeycodeEnd -> Key
K.End
KeycodePageUp -> Key
K.PgUp
KeycodePageDown -> Key
K.PgDn
KeycodeInsert -> Key
K.Insert
KeycodeDelete -> Key
K.Delete
KeycodePrintScreen -> Key
K.PrintScreen
KeycodeClear -> Key
K.Begin
KeycodeKPClear -> Key
K.Begin
KeycodeKPDivide -> if Bool
shiftPressed then Char -> Key
K.Char '?' else Char -> Key
K.Char '/'
KeycodeKPMultiply -> Char -> Key
K.KP '*'
KeycodeKPMinus -> Char -> Key
K.Char '-'
KeycodeKPPlus -> Char -> Key
K.Char '+'
KeycodeKPEnter -> Key
K.Return
KeycodeKPEquals -> Key
K.Return
KeycodeKP1 -> if Bool
shiftPressed then Char -> Key
K.KP '1' else Key
K.End
KeycodeKP2 -> if Bool
shiftPressed then Char -> Key
K.KP '2' else Key
K.Down
KeycodeKP3 -> if Bool
shiftPressed then Char -> Key
K.KP '3' else Key
K.PgDn
KeycodeKP4 -> if Bool
shiftPressed then Char -> Key
K.KP '4' else Key
K.Left
KeycodeKP5 -> if Bool
shiftPressed then Char -> Key
K.KP '5' else Key
K.Begin
KeycodeKP6 -> if Bool
shiftPressed then Char -> Key
K.KP '6' else Key
K.Right
KeycodeKP7 -> if Bool
shiftPressed then Char -> Key
K.KP '7' else Key
K.Home
KeycodeKP8 -> if Bool
shiftPressed then Char -> Key
K.KP '8' else Key
K.Up
KeycodeKP9 -> if Bool
shiftPressed then Char -> Key
K.KP '9' else Key
K.PgUp
KeycodeKP0 -> if Bool
shiftPressed then Char -> Key
K.KP '0' else Key
K.Insert
KeycodeKPPeriod -> Char -> Key
K.Char '.'
KeycodeKPComma -> Char -> Key
K.Char '.'
KeycodeF1 -> Int -> Key
K.Fun 1
KeycodeF2 -> Int -> Key
K.Fun 2
KeycodeF3 -> Int -> Key
K.Fun 3
KeycodeF4 -> Int -> Key
K.Fun 4
KeycodeF5 -> Int -> Key
K.Fun 5
KeycodeF6 -> Int -> Key
K.Fun 6
KeycodeF7 -> Int -> Key
K.Fun 7
KeycodeF8 -> Int -> Key
K.Fun 8
KeycodeF9 -> Int -> Key
K.Fun 9
KeycodeF10 -> Int -> Key
K.Fun 10
KeycodeF11 -> Int -> Key
K.Fun 11
KeycodeF12 -> Int -> Key
K.Fun 12
KeycodeLCtrl -> Key
K.DeadKey
KeycodeLShift -> Key
K.DeadKey
KeycodeLAlt -> Key
K.DeadKey
KeycodeLGUI -> Key
K.DeadKey
KeycodeRCtrl -> Key
K.DeadKey
KeycodeRShift -> Key
K.DeadKey
KeycodeRAlt -> Key
K.DeadKey
KeycodeRGUI -> Key
K.DeadKey
KeycodeMode -> Key
K.DeadKey
KeycodeNumLockClear -> Key
K.DeadKey
KeycodeUnknown -> String -> Key
K.Unknown "KeycodeUnknown"
_ -> let i :: Int
i = Int32 -> Int
forall a. Enum a => a -> Int
fromEnum (Int32 -> Int) -> Int32 -> Int
forall a b. (a -> b) -> a -> b
$ Keycode -> Int32
unwrapKeycode Keycode
n
in if | 97 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
i Bool -> Bool -> Bool
&& Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 122
Bool -> Bool -> Bool
&& Bool
shiftPressed -> Char -> Key
K.Char (Char -> Key) -> Char -> Key
forall a b. (a -> b) -> a -> b
$ Int -> Char
Char.chr (Int -> Char) -> Int -> Char
forall a b. (a -> b) -> a -> b
$ Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- 32
| 32 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
i Bool -> Bool -> Bool
&& Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 126 -> Char -> Key
K.Char (Char -> Key) -> Char -> Key
forall a b. (a -> b) -> a -> b
$ Int -> Char
Char.chr Int
i
| Bool
otherwise -> String -> Key
K.Unknown (String -> Key) -> String -> Key
forall a b. (a -> b) -> a -> b
$ Keycode -> String
forall a. Show a => a -> String
show Keycode
n
sDL_ALPHA_OPAQUE :: Word8
sDL_ALPHA_OPAQUE :: Word8
sDL_ALPHA_OPAQUE = 255
colorToRGBA :: Color.Color -> SDL.V4 Word8
colorToRGBA :: Color -> V4 Word8
colorToRGBA Color.Black = Word8 -> Word8 -> Word8 -> Word8 -> V4 Word8
forall a. a -> a -> a -> a -> V4 a
SDL.V4 0 0 0 Word8
sDL_ALPHA_OPAQUE
colorToRGBA Color.Red = Word8 -> Word8 -> Word8 -> Word8 -> V4 Word8
forall a. a -> a -> a -> a -> V4 a
SDL.V4 0xD5 0x05 0x05 Word8
sDL_ALPHA_OPAQUE
colorToRGBA Color.Green = Word8 -> Word8 -> Word8 -> Word8 -> V4 Word8
forall a. a -> a -> a -> a -> V4 a
SDL.V4 0x05 0x9D 0x05 Word8
sDL_ALPHA_OPAQUE
colorToRGBA Color.Brown = Word8 -> Word8 -> Word8 -> Word8 -> V4 Word8
forall a. a -> a -> a -> a -> V4 a
SDL.V4 0xCA 0x4A 0x05 Word8
sDL_ALPHA_OPAQUE
colorToRGBA Color.Blue = Word8 -> Word8 -> Word8 -> Word8 -> V4 Word8
forall a. a -> a -> a -> a -> V4 a
SDL.V4 0x05 0x56 0xF4 Word8
sDL_ALPHA_OPAQUE
colorToRGBA Color.Magenta = Word8 -> Word8 -> Word8 -> Word8 -> V4 Word8
forall a. a -> a -> a -> a -> V4 a
SDL.V4 0xAF 0x0E 0xAF Word8
sDL_ALPHA_OPAQUE
colorToRGBA Color.Cyan = Word8 -> Word8 -> Word8 -> Word8 -> V4 Word8
forall a. a -> a -> a -> a -> V4 a
SDL.V4 0x05 0x96 0x96 Word8
sDL_ALPHA_OPAQUE
colorToRGBA Color.White = Word8 -> Word8 -> Word8 -> Word8 -> V4 Word8
forall a. a -> a -> a -> a -> V4 a
SDL.V4 0xB8 0xBF 0xCB Word8
sDL_ALPHA_OPAQUE
colorToRGBA Color.AltWhite = Word8 -> Word8 -> Word8 -> Word8 -> V4 Word8
forall a. a -> a -> a -> a -> V4 a
SDL.V4 0xC4 0xBE 0xB1 Word8
sDL_ALPHA_OPAQUE
colorToRGBA Color.BrBlack = Word8 -> Word8 -> Word8 -> Word8 -> V4 Word8
forall a. a -> a -> a -> a -> V4 a
SDL.V4 0x6F 0x5F 0x5F Word8
sDL_ALPHA_OPAQUE
colorToRGBA Color.BrRed = Word8 -> Word8 -> Word8 -> Word8 -> V4 Word8
forall a. a -> a -> a -> a -> V4 a
SDL.V4 0xFF 0x55 0x55 Word8
sDL_ALPHA_OPAQUE
colorToRGBA Color.BrGreen = Word8 -> Word8 -> Word8 -> Word8 -> V4 Word8
forall a. a -> a -> a -> a -> V4 a
SDL.V4 0x65 0xF1 0x36 Word8
sDL_ALPHA_OPAQUE
colorToRGBA Color.BrYellow = Word8 -> Word8 -> Word8 -> Word8 -> V4 Word8
forall a. a -> a -> a -> a -> V4 a
SDL.V4 0xEB 0xD6 0x42 Word8
sDL_ALPHA_OPAQUE
colorToRGBA Color.BrBlue = Word8 -> Word8 -> Word8 -> Word8 -> V4 Word8
forall a. a -> a -> a -> a -> V4 a
SDL.V4 0x4D 0x98 0xF4 Word8
sDL_ALPHA_OPAQUE
colorToRGBA Color.BrMagenta = Word8 -> Word8 -> Word8 -> Word8 -> V4 Word8
forall a. a -> a -> a -> a -> V4 a
SDL.V4 0xFF 0x77 0xFF Word8
sDL_ALPHA_OPAQUE
colorToRGBA Color.BrCyan = Word8 -> Word8 -> Word8 -> Word8 -> V4 Word8
forall a. a -> a -> a -> a -> V4 a
SDL.V4 0x52 0xF4 0xE5 Word8
sDL_ALPHA_OPAQUE
colorToRGBA Color.BrWhite = Word8 -> Word8 -> Word8 -> Word8 -> V4 Word8
forall a. a -> a -> a -> a -> V4 a
SDL.V4 0xFF 0xFF 0xFF Word8
sDL_ALPHA_OPAQUE