Browse Source

resize window

tags/v1.0.1.0
soupi 1 year ago
parent
commit
872687912a
6 changed files with 50 additions and 8 deletions
  1. BIN
      assets/imgs/keys.png
  2. +2
    -0
      src/Play/Engine/Input.hs
  3. +21
    -5
      src/Play/Engine/MySDL/MySDL.hs
  4. +17
    -3
      src/Play/Engine/Runner.hs
  5. +7
    -0
      src/Play/Engine/Settings.hs
  6. +3
    -0
      src/Play/Engine/Utils.hs

BIN
assets/imgs/keys.png View File

Before After
Width: 800  |  Height: 1000  |  Size: 107KB Width: 800  |  Height: 1000  |  Size: 125KB

+ 2
- 0
src/Play/Engine/Input.hs View File

@@ -40,6 +40,7 @@ data Key
| KeyD
| KeyM
| KeyP
| KeyScale
| KeyStart
| KeyQuit
deriving (Show, Read, Eq, Ord, Bounded, Enum, Generic, NFData)
@@ -69,6 +70,7 @@ defKeyMap = map swap
, (SDL.ScancodeV, KeyD)
, (SDL.ScancodeM, KeyM)
, (SDL.ScancodeP, KeyP)
, (SDL.ScancodeF12, KeyScale)
]

-- can't have more than one binding to the same key as this will create a state accumulation problem


+ 21
- 5
src/Play/Engine/MySDL/MySDL.hs View File

@@ -27,6 +27,10 @@ import qualified SDL.Font as SDLF
import qualified SDL.Mixer as Mix
import SDL.Vect (V2(..), V4(..))

import Play.Engine.Types (Size)
import Play.Engine.Utils (scalePoint)


--import Debug.Trace

-- | Config window
@@ -41,6 +45,7 @@ withWindow title winConf go = do
SDLF.initialize

window <- SDL.createWindow title winConf

SDL.showWindow window

mJoystick <- getJoystick
@@ -72,12 +77,13 @@ withRenderer window go = do
apploop
:: ResourcesT TVar
-> TQueue Response
-> SDL.Window
-> SDL.Renderer
-> a
-> ([Response] -> [SDL.EventPayload] -> (SDL.Scancode -> Bool) -> a -> IO (Either [String] ([Request], a)))
-> (a -> IO ())
-> IO a
apploop resources responsesQueue renderer world update render = do
apploop resources responsesQueue window renderer world update render = do
-- measure ticks at the start
start <- SDL.ticks

@@ -90,7 +96,7 @@ apploop resources responsesQueue renderer world update render = do
liftIO $ mapM (hPutStrLn stderr . ("*** Error: " ++)) errs >> pure world
Right (reqs, newWorld) -> do
render newWorld
void $ async $ mapConcurrently_ (runRequest resources responsesQueue renderer) reqs
void $ async $ mapConcurrently_ (runRequest resources responsesQueue window renderer) reqs
if checkEvent SDL.QuitEvent events
then pure world
else do
@@ -106,7 +112,7 @@ apploop resources responsesQueue renderer world update render = do
-- measure ticks at the end and regulate FPS
end <- SDL.ticks
regulateFPS 60 start end
apploop resources responsesQueue renderer newWorld update render
apploop resources responsesQueue window renderer newWorld update render

-- | Will wait until ticks pass
regulateFPS :: Word32 -> Word32 -> Word32 -> IO ()
@@ -182,6 +188,8 @@ data Request
| PlayMusic (String, FilePath)
| MuteMusic
| UnmuteMusic
| SetNormalWindowScale Size
| SetSmallWindowScale Size

data Response
= ResourcesLoaded Resources
@@ -208,8 +216,8 @@ initResources =
<*> newTVarIO M.empty
<*> newTVarIO M.empty

runRequest :: ResourcesT TVar -> TQueue Response -> SDL.Renderer -> Request -> IO ()
runRequest resources queue renderer req =
runRequest :: ResourcesT TVar -> TQueue Response -> SDL.Window -> SDL.Renderer -> Request -> IO ()
runRequest resources queue window renderer req =
flip catch (\(SomeException e) -> atomically $ writeTQueue queue $ Exception $ show e) $
case req of
Load files -> do
@@ -231,6 +239,14 @@ runRequest resources queue renderer req =
Mix.setMusicVolume 0
UnmuteMusic -> do
Mix.setMusicVolume 100
SetSmallWindowScale size -> do
SDL.windowSize window SDL.$= (scalePoint 0.7 size)
SDL.rendererScale renderer SDL.$= 0.7
SDL.setWindowPosition window SDL.Centered
SetNormalWindowScale size -> do
SDL.windowSize window SDL.$= fmap fromIntegral size
SDL.rendererScale renderer SDL.$= 1
SDL.setWindowPosition window SDL.Centered


loadResource renderer resources (n, r) =


+ 17
- 3
src/Play/Engine/Runner.hs View File

@@ -40,6 +40,7 @@ run settings stack = do
MySDL.apploop
resources
responsesQueue
window
ren
(settings, stack)
update
@@ -54,7 +55,7 @@ update
-> (SDL.Scancode -> Bool)
-> (Settings, Stack Scene)
-> IO (Either [String] ([MySDL.Request], (Settings, Stack Scene)))
update responses payload isKeyPressed (settings, stack) =
update responses payload isKeyPressed (settings, stack) = do
let
(keys, joykeys) = makeEvents (_keyStats settings) (_joyKeyStats settings) payload isKeyPressed (_keyMap settings)

@@ -62,8 +63,15 @@ update responses payload isKeyPressed (settings, stack) =
| keyClicked' KeyM keys = not
| otherwise = id

toggleWindowScale
| keyClicked' KeyScale keys = \case
NormalWindow -> SmallWindow
SmallWindow -> NormalWindow
| otherwise = id

settings' = settings
& over muteMusic toggleMuteFlag
& over windowScale toggleWindowScale
& set keyStats keys
& set joyKeyStats joykeys

@@ -72,8 +80,14 @@ update responses payload isKeyPressed (settings, stack) =
| not (settings' ^. muteMusic) = (:) MySDL.UnmuteMusic
| otherwise = id

in pure
. fmap (\(setts, (reqs, states)) -> (toggleMuteCmd reqs, (setts, states)))
toggleWindowScaleCmd
| keyClicked' KeyScale keys = case settings' ^. windowScale of
NormalWindow -> (:) $ MySDL.SetNormalWindowScale $ settings' ^. windowSize
SmallWindow -> (:) $ MySDL.SetSmallWindowScale $ settings' ^. windowSize
| otherwise = id

pure
. fmap (\(setts, (reqs, states)) -> (toggleWindowScaleCmd $ toggleMuteCmd reqs, (setts, states)))
. (joykeys `deepseq` keys `deepseq` runResult $! settings')
$ updateScenes (Input (M.unionWith max keys joykeys) responses) stack



+ 7
- 0
src/Play/Engine/Settings.hs View File

@@ -18,9 +18,15 @@ data Settings
, _keyStats :: !Keys
, _joyKeyStats :: !Keys
, _muteMusic :: !Bool
, _windowScale :: WindowScale
}
deriving (Show)

data WindowScale
= SmallWindow
| NormalWindow
deriving Show

makeLenses ''Settings

type Result a = SM.StateT Settings (Except [String]) a
@@ -34,4 +40,5 @@ def = Settings
, _keyStats = initKeyStats
, _joyKeyStats = initKeyStats
, _muteMusic = False
, _windowScale = NormalWindow
}

+ 3
- 0
src/Play/Engine/Utils.hs View File

@@ -66,6 +66,9 @@ supplyBoth = (=<<)
(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d
(.:) f g a b = f (g a b)

scalePoint :: Float -> Size -> V2 C.CInt
scalePoint ratio = fmap (floor . (*) ratio . fromIntegral)

absPoint :: IPoint -> IPoint
absPoint = fmap abs



Loading…
Cancel
Save