Allow for real time window resize

This commit is contained in:
2021-04-08 13:21:40 +02:00
parent 7969c3f9e8
commit feec924d5d
5 changed files with 25 additions and 8 deletions
+2 -3
View File
@@ -60,8 +60,8 @@ doSideEffects preData w = do
. translate (-0.5) (-0.8) . scale 0.0005 0.0005 . translate (-0.5) (-0.8) . scale 0.0005 0.0005
. text $ "ms/frame " ++ show (endTicks - lastFrameTicks) . text $ "ms/frame " ++ show (endTicks - lastFrameTicks)
) )
return $ preData & soundData . playingSounds .~ newPlayingSounds foldr (=<<) (return (preData & soundData . playingSounds .~ newPlayingSounds
& frameTimer .~ endTicks & frameTimer .~ endTicks)) (_doneSideEffects w)
doPreload' :: Dodge.LoadConfig.Configuration -> IO (PreloadData a) doPreload' :: Dodge.LoadConfig.Configuration -> IO (PreloadData a)
doPreload' config = do doPreload' config = do
@@ -79,7 +79,6 @@ doPreload' config = do
, _frameTimer = 0 , _frameTimer = 0
} }
checkForGlErrors :: IO () checkForGlErrors :: IO ()
checkForGlErrors = do checkForGlErrors = do
errs <- errors errs <- errors
+3
View File
@@ -10,6 +10,7 @@ module Dodge.Data
) )
where where
import Dodge.Data.Menu import Dodge.Data.Menu
import Preload.Data
import Picture.Data import Picture.Data
import Geometry.Data import Geometry.Data
@@ -85,6 +86,8 @@ data World = World
, _debugMode :: Bool , _debugMode :: Bool
, _config :: Configuration , _config :: Configuration
, _configNeedsUpdate :: Bool , _configNeedsUpdate :: Bool
, _sideEffects :: [PreloadData SoundOrigin -> IO (PreloadData SoundOrigin)]
, _doneSideEffects :: [PreloadData SoundOrigin -> IO (PreloadData SoundOrigin)]
} }
data Corpse = Corpse data Corpse = Corpse
+2
View File
@@ -237,6 +237,8 @@ defaultWorld = World
, _debugMode = True , _debugMode = True
, _config = defaultConfig , _config = defaultConfig
, _configNeedsUpdate = False , _configNeedsUpdate = False
, _sideEffects = []
, _doneSideEffects = []
} }
youLight = youLight =
TLS { _tlsPos = (0,0) TLS { _tlsPos = (0,0)
+7 -2
View File
@@ -21,6 +21,8 @@ import Dodge.CreatureAction
import Dodge.SoundLogic import Dodge.SoundLogic
import Dodge.Inventory import Dodge.Inventory
import Geometry import Geometry
import Preload.Update
import Control.Lens import Control.Lens
import Data.Maybe import Data.Maybe
import Data.Char import Data.Char
@@ -65,9 +67,12 @@ handleMouseWheelEvent mwev w = case _menuLayers w of
_ -> Just w _ -> Just w
handleResizeEvent :: WindowSizeChangedEventData -> World -> Maybe World handleResizeEvent :: WindowSizeChangedEventData -> World -> Maybe World
handleResizeEvent sev = Just . set windowX (fromIntegral x) handleResizeEvent sev = Just
. set windowX (fromIntegral x)
. set windowY (fromIntegral y) . set windowY (fromIntegral y)
where V2 x y = windowSizeChangedEventSize sev . over sideEffects ( resizeSpareFBO (fromIntegral x) (fromIntegral y) : )
where
V2 x y = windowSizeChangedEventSize sev
handlePressedMouseButton :: MouseButton -> World -> Maybe World handlePressedMouseButton :: MouseButton -> World -> Maybe World
handlePressedMouseButton but w handlePressedMouseButton but w
+10 -2
View File
@@ -22,12 +22,20 @@ import qualified Data.Set as S
import qualified Data.IntMap.Strict as IM import qualified Data.IntMap.Strict as IM
import qualified Data.Map as M import qualified Data.Map as M
import Control.Lens import Control.Lens
update = update' . pushSideEffects
pushSideEffects :: World -> World
pushSideEffects w = w
& sideEffects .~ []
& doneSideEffects .~ _sideEffects w
{- | The update step. {- | The update step.
If '_menuLayers' is not empty, or the saving screen, this is the identity. If '_menuLayers' is not empty, or the saving screen, this is the identity.
In such menus, the only way to change the world is using event handling. In such menus, the only way to change the world is using event handling.
-} -}
update :: World -> World update' :: World -> World
update w = case _menuLayers w of update' w = case _menuLayers w of
(ConfigSaveScreen : ls) -> w & menuLayers .~ ls (ConfigSaveScreen : ls) -> w & menuLayers .~ ls
(_ : _) -> w (_ : _) -> w
[] -> let w1 = updateParticles' . updateProjectiles [] -> let w1 = updateParticles' . updateProjectiles