justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Simplify the main loop, events only perform functional update

Browse Source
This commit is contained in:
justin
2022-11-01 11:05:51 +00:00
parent 82c4b992b0
commit d982ac728a
14 changed files with 232 additions and 150 deletions
Download Patch File Download Diff File Expand all files Collapse all files
appDodge/Main.hs
+1 -1
View File
@@ -41,7 +41,7 @@ main = do
sizey = floor $ _windowY con
posx = _windowPosX con
posy = _windowPosY con
setupConLoop
setupConLoop'
20
(T.pack "Simple Game Loop")
(winConfig sizex sizey (Just (posx, posy)))
src/Dodge/Concurrent.hs
+3
View File
@@ -25,6 +25,9 @@ conEffects u = case u ^? uvSideEffects . _head of
addSideEffect :: IO (Universe -> Maybe Universe) -> String -> Universe -> Universe
addSideEffect f s = uvSideEffects %~ (|> NewSideEffect f s)
hardQuit :: Universe -> Universe
hardQuit = addSideEffect (return $ const Nothing) "QUITTING"
--tryConcEffect :: Bool -> String -> IO (Universe -> Maybe Universe) -> Universe -> Universe
--tryConcEffect bl str eff u = case u ^. uvConcEffects of
-- NoConcEffect -> u & uvConcEffects .~ NewConcEffect (ConcurrentEffect setstr (clearConcEff eff)) str bl
src/Dodge/Event.hs
+18 -40
View File
@@ -15,46 +15,32 @@ module Dodge.Event (
handleEvent,
) where
import Dodge.Concurrent
import LensHelp
import Dodge.Data.Universe
import Dodge.Event.Keyboard
import Dodge.Event.Input
import Dodge.PreloadData
import SDL
handleEvent :: Event -> Universe -> IO (Maybe Universe)
handleEvent e = case eventPayload e of
TextInputEvent tev -> return . Just . handleTextInput (textInputEventText tev)
KeyboardEvent kev -> return . Just . handleKeyboardEvent kev
MouseMotionEvent mmev -> return . handleMouseMotionEvent mmev
MouseButtonEvent mbev -> return . Just . over uvWorld (handleMouseButtonEvent mbev)
MouseWheelEvent mwev -> return . handleMouseWheelEvent mwev
WindowSizeChangedEvent sev -> handleResizeEvent sev
WindowMovedEvent mev -> return . handleWindowMoveEvent mev
_ -> return . Just
handleMouseMotionEvent :: MouseMotionEventData -> Universe -> Maybe Universe
handleMouseMotionEvent mmev u =
Just $
u & uvWorld . input . mousePos
.~ V2
(fromIntegral x - 0.5 * _windowX cfig)
(0.5 * _windowY cfig - fromIntegral y)
handleEvent :: Event -> Universe -> Universe
handleEvent e u = case eventPayload e of
TextInputEvent tev -> inputpoint (handleTextInput (textInputEventText tev)) u
KeyboardEvent kev -> inputpoint (handleKeyboardEvent kev) u
MouseMotionEvent mmev -> inputpoint (handleMouseMotionEvent mmev cfig) u
MouseButtonEvent mbev -> inputpoint (handleMouseButtonEvent mbev) u
MouseWheelEvent mwev -> inputpoint (handleMouseWheelEvent mwev) u
WindowSizeChangedEvent sev -> handleResizeEvent sev u
WindowMovedEvent mev -> handleWindowMoveEvent mev u
QuitEvent -> hardQuit u
WindowClosedEvent _ -> hardQuit u
_ -> u
where
inputpoint = over (uvWorld . input)
cfig = _uvConfig u
P (V2 x y) = mouseMotionEventPos mmev
handleMouseButtonEvent :: MouseButtonEventData -> World -> World
handleMouseButtonEvent mbev = case mouseButtonEventMotion mbev of
Released -> input . mouseButtons . at thebutton .~ Nothing
Pressed -> input . mouseButtons . at thebutton ?~ False
where
thebutton = mouseButtonEventButton mbev
-- | Sets window position in config.
handleWindowMoveEvent :: WindowMovedEventData -> Universe -> Maybe Universe
handleWindowMoveEvent mev =
Just
. (uvConfig . windowPosX .~ fromIntegral x)
handleWindowMoveEvent :: WindowMovedEventData -> Universe -> Universe
handleWindowMoveEvent mev = (uvConfig . windowPosX .~ fromIntegral x)
. (uvConfig . windowPosY .~ fromIntegral y)
where
P (V2 x y) = windowMovedEventPosition mev
@@ -63,9 +49,8 @@ handleWindowMoveEvent mev =
-- using a sideeffect here for the io change seems to work better, more testing
-- later may be a good idea
handleResizeEvent :: WindowSizeChangedEventData -> Universe -> IO (Maybe Universe)
handleResizeEvent :: WindowSizeChangedEventData -> Universe -> Universe
handleResizeEvent sev u =
return . Just $
u
& uvConfig . windowX .~ fromIntegral x
& uvConfig . windowY .~ fromIntegral y
@@ -75,10 +60,3 @@ handleResizeEvent sev u =
y = fromIntegral y'
V2 x' y' = windowSizeChangedEventSize sev
divRes = resFactorNum $ u ^. uvConfig . graphics_resolution_factor
handleMouseWheelEvent :: MouseWheelEventData -> Universe -> Maybe Universe
handleMouseWheelEvent mwev w = case _uvScreenLayers w of
[] -> case mouseWheelEventPos mwev of
V2 _ y -> Just $ w -- & uvWorld %~ wheelEvent (fromIntegral y)
& uvWorld . input . scrollAmount +~ fromIntegral y
_ -> Just w
src/Dodge/Event/Input.hs
+51
View File
@@ -0,0 +1,51 @@
-- | Deals with events that only affect Input.
module Dodge.Event.Input (
handleKeyboardEvent,
handleTextInput,
handleMouseMotionEvent,
handleMouseButtonEvent,
handleMouseWheelEvent,
) where
import qualified Data.Text as T
import Dodge.Data.Input
import Dodge.Data.Config
import LensHelp
import SDL
-- annoyingly, the text input event doesn't register backspace, so deletion has to be
-- dealt with separately
handleTextInput :: T.Text -> Input -> Input
handleTextInput text = textInput %~ (`T.append` text)
{- | Handles keyboard press and release.
-}
handleKeyboardEvent :: KeyboardEventData -> Input -> Input
handleKeyboardEvent kev = case keyboardEventKeyMotion kev of
Released -> pressedKeys . at scode .~ Nothing
Pressed -> pressedKeys . at scode ?~ val
where
val | keyboardEventRepeat kev = LongPress
| otherwise = InitialPress
scode = (keysymScancode . keyboardEventKeysym) kev
handleMouseMotionEvent :: MouseMotionEventData -> Configuration -> Input -> Input
handleMouseMotionEvent mmev cfig inp =
inp & mousePos
.~ V2
(fromIntegral x - 0.5 * _windowX cfig)
(0.5 * _windowY cfig - fromIntegral y)
where
P (V2 x y) = mouseMotionEventPos mmev
handleMouseWheelEvent :: MouseWheelEventData -> Input -> Input
handleMouseWheelEvent mwev = scrollAmount +~ fromIntegral y
where
V2 _ y = mouseWheelEventPos mwev
handleMouseButtonEvent :: MouseButtonEventData -> Input -> Input
handleMouseButtonEvent mbev = case mouseButtonEventMotion mbev of
Released -> mouseButtons . at thebutton .~ Nothing
Pressed -> mouseButtons . at thebutton ?~ False
where
thebutton = mouseButtonEventButton mbev
src/Dodge/Event/Keyboard.hs
-86
View File
@@ -1,86 +0,0 @@
-- | Deals with keyboard events.
module Dodge.Event.Keyboard (
handleKeyboardEvent,
handleTextInput,
guardDisconnectedID,
) where
--import Data.Maybe
--import Data.Text (unpack)
import qualified Data.Text as T
import Dodge.Data.Universe
import Dodge.Event.Menu
import Dodge.InputFocus
import Dodge.Save
import Dodge.Terminal.LeftButton
import LensHelp
import SDL
--import qualified Data.Map.Strict as M
-- annoyingly, the text input event doesn't register backspace, so deletion has to be
-- dealt with using key presses (handlePressedKey)
-- also, note that this currently "doubles" the inputs to both terminals if both
-- are open
handleTextInput :: T.Text -> Universe -> Universe
handleTextInput text = uvWorld . input . textInput %~ T.append text
--handleTextInput text u = u
-- & uvScreenLayers . ix 0 . scInput %~ updateText
-- & updateTerminalText
-- where
-- updateTerminalText = case u ^? uvWorld . cWorld . lWorld . hud . hudElement . subInventory of
-- Just (DisplayTerminal tmid)
-- | hasfocus tmid ->
-- uvWorld %~ \w -> guardDisconnectedID tmid w (w & cWorld . lWorld . terminals . ix tmid . tmInput . tiText %~ updateText)
-- _ -> id
-- hasfocus tmid = fromMaybe False $ u ^? uvWorld . cWorld . lWorld . terminals . ix tmid . tmInput . tiFocus
-- updateText s = case T.unpack text of
-- ";" -> s
-- _ -> s `T.append` T.toUpper text
guardDisconnectedID :: Int -> World -> World -> World
guardDisconnectedID tmid w w' = case w ^? cWorld . lWorld . terminals . ix tmid . tmStatus of
Just TerminalReady -> w'
_ -> w
{- | Handles keyboard press and release.
On release, remove scancode from the 'Set' of pressed keys.
On press, adds the scancode, and perhaps applies a direct effect:
see 'handlePressedKeyInGame'.
-}
handleKeyboardEvent :: KeyboardEventData -> Universe -> Universe
handleKeyboardEvent kev u = case keyboardEventKeyMotion kev of
Released -> u & uvWorld . input . pressedKeys . at scode .~ Nothing
Pressed ->
handlePressedKey
(keyboardEventRepeat kev)
scode
--(u & uvWorld . input . pressedKeys %~ M.insertWith f scode val)
(u & uvWorld . input . pressedKeys . at scode ?~ val)
where
val | keyboardEventRepeat kev = LongPress
| otherwise = InitialPress
scode = (keysymScancode . keyboardEventKeysym) kev
handlePressedKey :: Bool -> Scancode -> Universe -> Universe
handlePressedKey True _ u = u
handlePressedKey _ scode u = case scode of
ScancodeF5 -> doQuicksave u
ScancodeF9 -> loadSaveSlot QuicksaveSlot u
ScancodeSemicolon -> gotoTerminal u
_ | null (_uvScreenLayers u) -> case u ^? uvWorld . cWorld . lWorld . hud . hudElement . subInventory of
Just (DisplayTerminal tmid)
| inTermFocus (_uvWorld u) ->
over uvWorld (handlePressedKeyTerminal tmid scode) u
_ -> u
_ -> handlePressedKeyInMenu (head $ _uvScreenLayers u) scode u
handlePressedKeyTerminal :: Int -> Scancode -> World -> World
handlePressedKeyTerminal tmid scode w = case scode of
ScancodeEscape -> w & cWorld . lWorld . terminals . ix tmid . tmInput . tiFocus %~ const False
ScancodeReturn -> w & terminalReturnEffect (w ^?! cWorld . lWorld . terminals . ix tmid)
_ -> w
gotoTerminal :: Universe -> Universe
gotoTerminal w = case _uvScreenLayers w of
(InputScreen{} : _) -> w
_ -> w & uvScreenLayers .:~ InputScreen T.empty "Enter command"
src/Dodge/Event/Menu.hs
-7
View File
@@ -1,5 +1,4 @@
module Dodge.Event.Menu (
handlePressedKeyInMenu,
optionListToEffects,
) where
@@ -9,12 +8,6 @@ import Dodge.Data.Universe
import Dodge.WindowLayout
import SDL
handlePressedKeyInMenu :: ScreenLayer -> Scancode -> Universe -> Universe
handlePressedKeyInMenu mState scode = case mState of
OptionScreen{_scOptions = mos, _scDefaultEff = defeff} ->
optionListToEffects defeff scode mos
_ -> id
optionListToEffects ::
(Universe -> Universe) ->
Scancode ->
src/Dodge/Menu.hs
-2
View File
@@ -70,8 +70,6 @@ pauseMenuOptions =
saveQuit :: Universe -> Universe
saveQuit u = u & addSideEffect (saveQuitConc u) "SAVING"
hardQuit :: Universe -> Universe
hardQuit = addSideEffect (return $ const Nothing) "QUITTING"
saveQuitConc :: Universe -> IO (Universe -> Maybe Universe)
saveQuitConc u = do
src/Dodge/PreloadData.hs
+3
View File
@@ -1,11 +1,14 @@
module Dodge.PreloadData where
--import qualified Graphics.Rendering.OpenGL as GL
import Control.Lens
import Dodge.Data.Universe
import Preload.Update
--import SDL
sideEffectUpdatePreload :: Int -> Int -> Int -> (Universe -> IO Universe) -> Universe -> IO Universe
sideEffectUpdatePreload divRes x y f u = do
-- GL.viewport $= (GL.Position 0 0, GL.Size (fromIntegral x) (fromIntegral y))
pdata <- pdataResizeUpdate (x `div` divRes) (y `div` divRes) x y (_preloadData u)
f $ u & preloadData .~ pdata
src/Dodge/Render/List.hs
+6
View File
@@ -16,6 +16,12 @@ listPicturesAt tx ty cfig = listPicturesAtOff tx ty cfig 0
listPicturesAtOff :: Float -> Float -> Configuration -> Int -> [Picture] -> Picture
listPicturesAtOff tx ty cfig i = mconcat . zipWith (listTextPictureAt tx ty cfig) [i ..]
stackPicturesAt :: Float -> Float -> Configuration -> [Picture] -> Picture
stackPicturesAt tx ty cfig = stackPicturesAtOff tx ty cfig 0
stackPicturesAtOff :: Float -> Float -> Configuration -> Int -> [Picture] -> Picture
stackPicturesAtOff tx ty cfig i = mconcat . zipWith (listTextPictureAt tx ty cfig) [i, i-1 ..]
-- displays a cursor that should match up to list text pictures
-- the width of a character appears to be 9(?!)
-- this is probably because it is 8 pixels plus one for the border
src/Dodge/Render/Picture.hs
+20 -9
View File
@@ -26,17 +26,28 @@ fixedCoordPictures u =
cfig = _uvConfig u
drawConcurrentMessage :: Universe -> Picture
drawConcurrentMessage u = case u ^? uvSideEffects . _head of
--Just (BlockingConcEffect str) -> fillWidthText cfig str
Just (RunningSideEffect str) ->
listPicturesAt
(halfWidth cfig)
(_windowY cfig - 50)
cfig
[centerText str]
_ -> mempty
drawConcurrentMessage u =
stackPicturesAt
(halfWidth cfig)
(_windowY cfig - 50)
cfig
(map (centerText . f) $ u ^.. uvSideEffects . each)
where
cfig = _uvConfig u
f (RunningSideEffect ce) = ce ++ " IN PROGRESS"
f x = _ceString x ++ " QUEUED"
-- = case u ^? uvSideEffects . _head of
-- --Just (BlockingConcEffect str) -> fillWidthText cfig str
-- Just (RunningSideEffect str) ->
-- stackPicturesAt
-- (halfWidth cfig)
-- (_windowY cfig - 50)
-- cfig
-- [centerText str]
-- _ -> mempty
-- where
-- cfig = _uvConfig u
customMouseCursor :: Configuration -> World -> Picture
customMouseCursor cfig w =
src/Dodge/Update.hs
+16 -4
View File
@@ -6,6 +6,7 @@ Description : Simulation update
-}
module Dodge.Update (updateUniverse) where
import Dodge.InputFocus
import Dodge.Event.Menu
import Color
import Control.Applicative
@@ -62,10 +63,12 @@ import LensHelp
import SDL
import Sound.Data
import StrictHelp
import qualified Data.Text as T
updateUniverse :: Universe -> Universe
updateUniverse u =
updateUniverseLast
. maybeOpenTerminal
. over (uvWorld . input . textInput) (const mempty)
. updateUniverseMid
. updateUseInput
@@ -75,16 +78,25 @@ updateUniverse u =
where
cfig = u ^. uvConfig
maybeOpenTerminal :: Universe -> Universe
maybeOpenTerminal u = case u ^. uvWorld . input . pressedKeys . at ScancodeSemicolon of
Just InitialPress -> gotoTerminal u
_ -> u
gotoTerminal :: Universe -> Universe
gotoTerminal w = case _uvScreenLayers w of
(InputScreen{} : _) -> w
_ -> w & uvScreenLayers .:~ InputScreen T.empty "Enter command"
updateUseInput :: Universe -> Universe
updateUseInput u = case u ^? uvScreenLayers . _head of
Just (InputScreen thetext _) -> doInputScreenInput thetext u
-- Just OptionScreen{} -> --{_scOptions = mos, _scDefaultEff = defeff} -> u
-- u
--
Just OptionScreen{_scOptions = mos, _scDefaultEff = defeff} ->
foldl' (\u' scode -> optionListToEffects defeff scode mos u') u (M.keys $ M.filter (== InitialPress) pkeys)
Just ColumnsScreen{} -> u & uvScreenLayers %~ tail
_ -> M.foldlWithKey' updateKeyInGame u pkeys
_ -> case u ^? uvWorld . cWorld . lWorld . hud . hudElement . subInventory of
Just (DisplayTerminal tmid) | inTermFocus (_uvWorld u) -> updateKeysInTerminal tmid u-- M.foldlWithKey' (updateKeyInTerminal tmid) u pkeys
_ -> M.foldlWithKey' updateKeyInGame u pkeys
where
pkeys = u ^. uvWorld . input . pressedKeys
src/Dodge/Update/Input.hs
+24
View File
@@ -1,8 +1,11 @@
module Dodge.Update.Input
( updateKeyInGame
, updateKeysInTerminal
, doInputScreenInput
) where
import Dodge.Terminal.LeftButton
import Dodge.Save
import Dodge.Debug.Terminal
import Dodge.WorldPos
import Dodge.Button.Event
@@ -41,9 +44,30 @@ doBackspace t = case T.unsnoc t of
Nothing -> t
Just (t', _) -> t'
updateKeysInTerminal :: Int -> Universe -> Universe
updateKeysInTerminal tmid u= u & tmpoint %~ (`T.append` T.toUpper thetext)
& checkBackspace
& checkEndStatus
where
tmpoint = uvWorld . cWorld . lWorld . terminals . ix tmid . tmInput . tiText
thetext = u ^. uvWorld . input . textInput
checkBackspace = case u ^. uvWorld . input . pressedKeys . at ScancodeBackspace of
Just InitialPress -> f
Just LongPress -> f
_ -> id
f = tmpoint %~ doBackspace
pkeys = u ^. uvWorld . input . pressedKeys
checkEndStatus
| pkeys ^. at ScancodeReturn == Just InitialPress
= over uvWorld (\w -> terminalReturnEffect (w ^?! cWorld . lWorld . terminals . ix tmid) w)
-- | pkeys ^. at ScancodeEscape == Just InitialPress
-- = uvWorld . cWorld . lWorld . terminals . ix tmid . tmInput . tiFocus %~ const False
| otherwise = id
updateKeyInGame :: Universe -> Scancode -> PressType -> Universe
updateKeyInGame uv sc InitialPress = case sc of
ScancodeF5 -> doQuicksave uv
ScancodeF9 -> loadSaveSlot QuicksaveSlot uv
ScancodeEscape -> pauseGame uv
ScancodeSpace -> over uvWorld spaceAction uv
ScancodeP -> pauseGame uv
src/Dodge/Update/Scroll.hs
+5 -1
View File
@@ -6,7 +6,6 @@ import qualified Data.Text as T
import Dodge.Base
import Dodge.Combine
import Dodge.Data.Universe
import Dodge.Event.Keyboard
import Dodge.HeldScroll
import Dodge.InputFocus
import Dodge.Inventory
@@ -75,6 +74,11 @@ updateWheelEvent yi w = case w ^. cWorld . lWorld . hud . hudElement of
lbDown = ButtonLeft `M.member` _mouseButtons (_input w)
invKeyDown = ScancodeCapsLock `M.member` _pressedKeys (_input w)
guardDisconnectedID :: Int -> World -> World -> World
guardDisconnectedID tmid w w' = case w ^? cWorld . lWorld . terminals . ix tmid . tmStatus of
Just TerminalReady -> w'
_ -> w
scrollRBOption :: Float -> World -> World
scrollRBOption y w
| y < 0 = w & rbOptions . opSel %~ (min (length (_opEquip (_rbOptions w)) -1) . (+ 1))
src/Loop.hs
+85
View File
@@ -11,6 +11,7 @@ This module sets up an SDL window which may be updated using a simple game loop.
module Loop (
setupLoop,
setupConLoop,
setupConLoop',
) where
import Loop.Data
@@ -21,6 +22,7 @@ import qualified Data.Text as T
import qualified Graphics.Rendering.OpenGL as GL
import SDL
import System.Mem
import Data.Foldable
-- | Create a game loop with an SDL window.
setupLoop ::
@@ -180,3 +182,86 @@ doConLoop themvar spf window coneffs worldSideEffects eventFn !startWorld = go s
threadDelay (theDelay * 1000)
go $! updatedWorld
Nothing -> return ()
-- | Create a game loop with an SDL window.
setupConLoop' ::
-- | Target seconds per frame
Int ->
-- | Window title
T.Text ->
WindowConfig ->
-- | Function for cleaning up parameters, applied when exiting loop.
(world -> IO ()) ->
-- | Initial simulation state.
IO world ->
---- | Concurrent effects. Evaluating 'Nothing' exits the loop
(world -> ConcurrentEffect world) ->
-- | update, called once per frame. Allows for side effects such as rendering.
(world -> IO world) ->
-- | SDL Event handling, once per frame. Note no side effects.
(world -> Event -> world) ->
IO ()
setupConLoop' spf title winconfig paramCleanup ioStartWorld coneffs sideEffects eventFn = do
initializeAll
themvar <- newEmptyMVar
bracket
(createWindow title winconfig)
destroyWindow
$ \window -> bracket
(glCreateContext window)
(\con -> GL.finish >> glDeleteContext con)
$ \_ ->
bracket
ioStartWorld
paramCleanup
(doConLoop' themvar spf window coneffs sideEffects eventFn)
-- | The internal loop.
doConLoop' ::
-- | The mvar for concurrency
MVar (world -> Maybe world) ->
-- | target msec per frame
Int ->
-- | The SDL window.
Window ->
---- | Concurrent effects, the first function in the pair is applied
---- immediately
(world -> ConcurrentEffect world) ->
-- | simulation update. Allows for side effects such as rendering.
(world -> IO world) ->
-- | SDL Event handling. Note no side effects.
(world -> Event -> world) ->
-- | Current simulation state.
world ->
IO ()
doConLoop' themvar spf window coneffs worldSideEffects eventFn !startWorld = go startWorld
where
go sw = do
startTicks <- ticks
es <- pollEvents
let mconeff = coneffs sw
case mconeff of
NoConcurrentEffect -> return ()
ConcurrentEffect _ acc -> do
_ <- forkIO $ do
up <- acc
putMVar themvar up
return ()
let startWorld'' = case mconeff of
NoConcurrentEffect -> sw
ConcurrentEffect immediatef _ -> immediatef
mconupdate <- tryTakeMVar themvar
let mstartWorld' = case mconupdate of
Just conupdate -> conupdate startWorld''
Nothing -> Just startWorld''
case mstartWorld' of
Nothing -> return ()
Just startWorld' -> do
worldAfterSimStep <- worldSideEffects startWorld'
glSwapWindow window
let updatedWorld = foldl' eventFn worldAfterSimStep es
performGC
endTicks <- ticks -- it might be better to use System.Clock (monotonic)
let theDelay = max 0 (spf + fromIntegral startTicks - fromIntegral endTicks)
threadDelay (theDelay * 1000)
go $! updatedWorld