<commit_before>-- | Text frontend based on SDL2.
module Game.LambdaHack.Client.UI.Frontend.Sdl
  ( startup, frontendName
#ifdef EXPOSE_INTERNAL
    -- * Internal operations
  , startupFun, shutdown, display
#endif
  ) where

import Prelude ()

import Game.LambdaHack.Common.Prelude hiding (Alt)

-- Cabal
import qualified Paths_LambdaHack as Self (getDataFileName)

import Control.Concurrent
import Control.Concurrent.Async
import qualified Data.Char as Char
import qualified Data.EnumMap.Strict as EM
import Data.IORef
import qualified Data.Text as T
import qualified Data.Vector.Unboxed as U
import Data.Word (Word32)
import Foreign.C.Types (CInt)
import System.Directory
import System.FilePath

import qualified SDL as SDL
import SDL.Input.Keyboard.Codes
import qualified SDL.Raw as Raw
import qualified SDL.TTF as TTF
import qualified SDL.TTF.FFI as TTF (TTFFont)
import qualified SDL.Vect as Vect

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.ClientOptions
import qualified Game.LambdaHack.Common.Color as Color
import Game.LambdaHack.Common.Misc
import Game.LambdaHack.Common.Point
import qualified Game.LambdaHack.Common.PointArray as PointArray

type FontAtlas = EM.EnumMap Color.AttrCharW32 SDL.Texture

-- | Session data maintained by the frontend.
data FrontendSession = FrontendSession
  { swindow           :: !SDL.Window
  , srenderer         :: !SDL.Renderer
  , sfont             :: !TTF.TTFFont
  , satlas            :: !(IORef FontAtlas)
  , screenTexture     :: !SDL.Texture
  , spreviousFrame    :: !(IORef SingleFrame)
  , squitSDL          :: !(IORef Bool)
  , sdisplayPermitted :: !(MVar ())
  }

-- | The name of the frontend.
frontendName :: String
frontendName = "sdl"

-- | Set up and start the main loop providing input and output.
--
-- It seems, even on Windows, SDL2 doesn't require a bound thread.
-- so we can avoid the communication overhead of bound threads.
-- However, events can only be pumped in the thread that initialized
-- the video subsystem, so we need to enter the event-gathering loop
-- after the initialization and stay there.
startup :: DebugModeCli -> IO RawFrontend
startup sdebugCli = do
  rfMVar <- newEmptyMVar
  a <- async $ startupFun sdebugCli rfMVar
  link a
  takeMVar rfMVar

startupFun :: DebugModeCli -> MVar RawFrontend -> IO ()
startupFun sdebugCli@DebugModeCli{..} rfMVar = do
  SDL.initialize [SDL.InitVideo, SDL.InitEvents]
  let title = fromJust stitle
      fontFileName =
        "GameDefinition/fonts" </> T.unpack (fromJust sdlFontFile)
  fontFile <- if isRelative fontFileName
              then Self.getDataFileName fontFileName
              else return fontFileName
  fontFileExists <- doesFileExist fontFile
  unless fontFileExists $ error $ "Font file does not exist: " ++ fontFile
  let fontSize = fromJust sfontSize
  code <- TTF.init
  when (code /= 0) $ error $ "init of sdl2-ttf failed with: " ++ show code
  sfont <- TTF.openFont fontFile fontSize
  let fonFile = "fon" `isSuffixOf` T.unpack (fromJust sdlFontFile)
      sdlSizeAdd = fromJust $ if fonFile then sdlFonSizeAdd else sdlTtfSizeAdd
  boxSize <- (+ sdlSizeAdd) <$> TTF.getFontHeight sfont
  let xsize = fst normalLevelBound + 1
      ysize = snd normalLevelBound + 4
      screenV2 = SDL.V2 (toEnum $ xsize * boxSize)
                        (toEnum $ ysize * boxSize)
      windowConfig = SDL.defaultWindow {SDL.windowInitialSize = screenV2}
      rendererConfig = SDL.defaultRenderer {SDL.rendererTargetTexture = True}
  swindow <- SDL.createWindow title windowConfig
  srenderer <- SDL.createRenderer swindow (-1) rendererConfig
  screenTexture <- SDL.createTexture srenderer SDL.ARGB8888
                                     SDL.TextureAccessTarget screenV2
  SDL.rendererDrawBlendMode srenderer SDL.$= SDL.BlendNone
  SDL.rendererRenderTarget srenderer SDL.$= Just screenTexture
  SDL.clear srenderer  -- clear the texture
  SDL.rendererRenderTarget srenderer SDL.$= Nothing
  SDL.copy srenderer screenTexture Nothing Nothing  -- clear the backbuffer
  satlas <- newIORef EM.empty
  spreviousFrame <- newIORef blankSingleFrame
  squitSDL <- newIORef False
  sdisplayPermitted <- newMVar ()
  let sess = FrontendSession{..}
  rf <- createRawFrontend (display sdebugCli sess) (shutdown sess)
  putMVar rfMVar rf
  let pointTranslate :: forall i. (Enum i) => Vect.Point Vect.V2 i -> Point
      pointTranslate (SDL.P (SDL.V2 x y)) =
        Point (fromEnum x `div` boxSize) (fromEnum y `div` boxSize)
      storeKeys :: IO ()
      storeKeys = do
        e <- SDL.waitEvent  -- blocks here, so no polling
        case SDL.eventPayload e of
          SDL.KeyboardEvent keyboardEvent
            | SDL.keyboardEventKeyMotion keyboardEvent == SDL.Pressed -> do
              let sym = SDL.keyboardEventKeysym keyboardEvent
                  ksm = SDL.keysymModifier sym
                  shiftPressed = SDL.keyModifierLeftShift ksm
                                 || SDL.keyModifierRightShift ksm
                  key = keyTranslate shiftPressed $ SDL.keysymKeycode sym
                  modifier = modTranslate ksm
              p <- SDL.getAbsoluteMouseLocation
              when (key == K.Esc) $ resetChanKey (fchanKey rf)
              saveKMP rf modifier key (pointTranslate p)
          SDL.MouseButtonEvent mouseButtonEvent
            | SDL.mouseButtonEventMotion mouseButtonEvent == SDL.Released -> do
              md <- modTranslate <$> SDL.getModState
              let key = case SDL.mouseButtonEventButton mouseButtonEvent of
                    SDL.ButtonLeft -> K.LeftButtonRelease
                    SDL.ButtonMiddle -> K.MiddleButtonRelease
                    SDL.ButtonRight -> K.RightButtonRelease
                    _ -> K.LeftButtonRelease  -- any other is spare left
                  modifier = if md == K.Shift then K.NoModifier else md
                  p = SDL.mouseButtonEventPos mouseButtonEvent
              saveKMP rf modifier key (pointTranslate p)
          SDL.MouseWheelEvent mouseWheelEvent -> do
            md <- modTranslate <$> SDL.getModState
            let SDL.V2 _ y = SDL.mouseWheelEventPos mouseWheelEvent
                mkey = case (compare y 0, SDL.mouseWheelEventDirection
                                            mouseWheelEvent) of
                  (EQ, _) -> Nothing
                  (LT, SDL.ScrollNormal) -> Just K.WheelSouth
                  (GT, SDL.ScrollNormal) -> Just K.WheelNorth
                  (LT, SDL.ScrollFlipped) -> Just K.WheelSouth
                  (GT, SDL.ScrollFlipped) -> Just K.WheelNorth
                modifier = if md == K.Shift then K.NoModifier else md
            p <- SDL.getAbsoluteMouseLocation
            maybe (return ())
                  (\key -> saveKMP rf modifier key (pointTranslate p)) mkey
          SDL.WindowClosedEvent{} -> shutdown sess
          SDL.QuitEvent -> shutdown sess
          _ -> return ()
        quitSDL <- readIORef squitSDL
        unless quitSDL storeKeys
  storeKeys
  TTF.closeFont sfont
  TTF.quit
  SDL.destroyRenderer srenderer
  SDL.destroyWindow swindow<commit_msg>Redraw after window restored from minimization<commit_after>-- | Text frontend based on SDL2.
module Game.LambdaHack.Client.UI.Frontend.Sdl
  ( startup, frontendName
#ifdef EXPOSE_INTERNAL
    -- * Internal operations
  , startupFun, shutdown, display
#endif
  ) where

import Prelude ()

import Game.LambdaHack.Common.Prelude hiding (Alt)

-- Cabal
import qualified Paths_LambdaHack as Self (getDataFileName)

import Control.Concurrent
import Control.Concurrent.Async
import qualified Data.Char as Char
import qualified Data.EnumMap.Strict as EM
import Data.IORef
import qualified Data.Text as T
import qualified Data.Vector.Unboxed as U
import Data.Word (Word32)
import Foreign.C.Types (CInt)
import System.Directory
import System.FilePath

import qualified SDL as SDL
import SDL.Input.Keyboard.Codes
import qualified SDL.Raw as Raw
import qualified SDL.TTF as TTF
import qualified SDL.TTF.FFI as TTF (TTFFont)
import qualified SDL.Vect as Vect

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.ClientOptions
import qualified Game.LambdaHack.Common.Color as Color
import Game.LambdaHack.Common.Misc
import Game.LambdaHack.Common.Point
import qualified Game.LambdaHack.Common.PointArray as PointArray

type FontAtlas = EM.EnumMap Color.AttrCharW32 SDL.Texture

-- | Session data maintained by the frontend.
data FrontendSession = FrontendSession
  { swindow           :: !SDL.Window
  , srenderer         :: !SDL.Renderer
  , sfont             :: !TTF.TTFFont
  , satlas            :: !(IORef FontAtlas)
  , screenTexture     :: !SDL.Texture
  , spreviousFrame    :: !(IORef SingleFrame)
  , squitSDL          :: !(IORef Bool)
  , sdisplayPermitted :: !(MVar ())
  }

-- | The name of the frontend.
frontendName :: String
frontendName = "sdl"

-- | Set up and start the main loop providing input and output.
--
-- It seems, even on Windows, SDL2 doesn't require a bound thread.
-- so we can avoid the communication overhead of bound threads.
-- However, events can only be pumped in the thread that initialized
-- the video subsystem, so we need to enter the event-gathering loop
-- after the initialization and stay there.
startup :: DebugModeCli -> IO RawFrontend
startup sdebugCli = do
  rfMVar <- newEmptyMVar
  a <- async $ startupFun sdebugCli rfMVar
  link a
  takeMVar rfMVar

startupFun :: DebugModeCli -> MVar RawFrontend -> IO ()
startupFun sdebugCli@DebugModeCli{..} rfMVar = do
  SDL.initialize [SDL.InitVideo, SDL.InitEvents]
  let title = fromJust stitle
      fontFileName =
        "GameDefinition/fonts" </> T.unpack (fromJust sdlFontFile)
  fontFile <- if isRelative fontFileName
              then Self.getDataFileName fontFileName
              else return fontFileName
  fontFileExists <- doesFileExist fontFile
  unless fontFileExists $ error $ "Font file does not exist: " ++ fontFile
  let fontSize = fromJust sfontSize
  code <- TTF.init
  when (code /= 0) $ error $ "init of sdl2-ttf failed with: " ++ show code
  sfont <- TTF.openFont fontFile fontSize
  let fonFile = "fon" `isSuffixOf` T.unpack (fromJust sdlFontFile)
      sdlSizeAdd = fromJust $ if fonFile then sdlFonSizeAdd else sdlTtfSizeAdd
  boxSize <- (+ sdlSizeAdd) <$> TTF.getFontHeight sfont
  let xsize = fst normalLevelBound + 1
      ysize = snd normalLevelBound + 4
      screenV2 = SDL.V2 (toEnum $ xsize * boxSize)
                        (toEnum $ ysize * boxSize)
      windowConfig = SDL.defaultWindow {SDL.windowInitialSize = screenV2}
      rendererConfig = SDL.defaultRenderer {SDL.rendererTargetTexture = True}
  swindow <- SDL.createWindow title windowConfig
  srenderer <- SDL.createRenderer swindow (-1) rendererConfig
  screenTexture <- SDL.createTexture srenderer SDL.ARGB8888
                                     SDL.TextureAccessTarget screenV2
  SDL.rendererDrawBlendMode srenderer SDL.$= SDL.BlendNone
  SDL.rendererRenderTarget srenderer SDL.$= Just screenTexture
  SDL.clear srenderer  -- clear the texture
  SDL.rendererRenderTarget srenderer SDL.$= Nothing
  SDL.copy srenderer screenTexture Nothing Nothing  -- clear the backbuffer
  satlas <- newIORef EM.empty
  spreviousFrame <- newIORef blankSingleFrame
  squitSDL <- newIORef False
  sdisplayPermitted <- newMVar ()
  let sess = FrontendSession{..}
  rf <- createRawFrontend (display sdebugCli sess) (shutdown sess)
  putMVar rfMVar rf
  let pointTranslate :: forall i. (Enum i) => Vect.Point Vect.V2 i -> Point
      pointTranslate (SDL.P (SDL.V2 x y)) =
        Point (fromEnum x `div` boxSize) (fromEnum y `div` boxSize)
      redraw = do
        prevFrame <- readIORef spreviousFrame
        display sdebugCli sess prevFrame
      storeKeys :: IO ()
      storeKeys = do
        e <- SDL.waitEvent  -- blocks here, so no polling
        case SDL.eventPayload e of
          SDL.KeyboardEvent keyboardEvent
            | SDL.keyboardEventKeyMotion keyboardEvent == SDL.Pressed -> do
              let sym = SDL.keyboardEventKeysym keyboardEvent
                  ksm = SDL.keysymModifier sym
                  shiftPressed = SDL.keyModifierLeftShift ksm
                                 || SDL.keyModifierRightShift ksm
                  key = keyTranslate shiftPressed $ SDL.keysymKeycode sym
                  modifier = modTranslate ksm
              p <- SDL.getAbsoluteMouseLocation
              when (key == K.Esc) $ resetChanKey (fchanKey rf)
              saveKMP rf modifier key (pointTranslate p)
          SDL.MouseButtonEvent mouseButtonEvent
            | SDL.mouseButtonEventMotion mouseButtonEvent == SDL.Released -> do
              md <- modTranslate <$> SDL.getModState
              let key = case SDL.mouseButtonEventButton mouseButtonEvent of
                    SDL.ButtonLeft -> K.LeftButtonRelease
                    SDL.ButtonMiddle -> K.MiddleButtonRelease
                    SDL.ButtonRight -> K.RightButtonRelease
                    _ -> K.LeftButtonRelease  -- any other is spare left
                  modifier = if md == K.Shift then K.NoModifier else md
                  p = SDL.mouseButtonEventPos mouseButtonEvent
              saveKMP rf modifier key (pointTranslate p)
          SDL.MouseWheelEvent mouseWheelEvent -> do
            md <- modTranslate <$> SDL.getModState
            let SDL.V2 _ y = SDL.mouseWheelEventPos mouseWheelEvent
                mkey = case (compare y 0, SDL.mouseWheelEventDirection
                                            mouseWheelEvent) of
                  (EQ, _) -> Nothing
                  (LT, SDL.ScrollNormal) -> Just K.WheelSouth
                  (GT, SDL.ScrollNormal) -> Just K.WheelNorth
                  (LT, SDL.ScrollFlipped) -> Just K.WheelSouth
                  (GT, SDL.ScrollFlipped) -> Just K.WheelNorth
                modifier = if md == K.Shift then K.NoModifier else md
            p <- SDL.getAbsoluteMouseLocation
            maybe (return ())
                  (\key -> saveKMP rf modifier key (pointTranslate p)) mkey
          SDL.WindowClosedEvent{} -> shutdown sess
          SDL.QuitEvent -> shutdown sess
          SDL.WindowRestoredEvent{} -> redraw
          _ -> return ()
        quitSDL <- readIORef squitSDL
        unless quitSDL storeKeys
  storeKeys
  TTF.closeFont sfont
  TTF.quit
  SDL.destroyRenderer srenderer
  SDL.destroyWindow swindow
{'fraction_non_alphanumeric': 0.07676434172513413, 'fraction_numerical': 0.003164121612326317, 'mean_word_length': 2.5591187270501834, 'pattern_counts': {'":': 0, '<': 54, '<?xml version=': 0, '>': 54, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 8, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '1873749', 'n_tokens_mistral': 4402, 'n_tokens_neox': 4111, 'n_words': 1245}