diff --git a/appDodge/Main.hs b/appDodge/Main.hs index 43ba94b30..738b88666 100644 --- a/appDodge/Main.hs +++ b/appDodge/Main.hs @@ -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))) diff --git a/src/Dodge/Concurrent.hs b/src/Dodge/Concurrent.hs index 9ba2ddd52..c5ccd2dbc 100644 --- a/src/Dodge/Concurrent.hs +++ b/src/Dodge/Concurrent.hs @@ -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 diff --git a/src/Dodge/Event.hs b/src/Dodge/Event.hs index 67de65828..a07cb3b31 100644 --- a/src/Dodge/Event.hs +++ b/src/Dodge/Event.hs @@ -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 diff --git a/src/Dodge/Event/Input.hs b/src/Dodge/Event/Input.hs new file mode 100644 index 000000000..357298b51 --- /dev/null +++ b/src/Dodge/Event/Input.hs @@ -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 diff --git a/src/Dodge/Event/Keyboard.hs b/src/Dodge/Event/Keyboard.hs deleted file mode 100644 index 468b9b26d..000000000 --- a/src/Dodge/Event/Keyboard.hs +++ /dev/null @@ -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" diff --git a/src/Dodge/Event/Menu.hs b/src/Dodge/Event/Menu.hs index 269244dc6..faa2e95b3 100644 --- a/src/Dodge/Event/Menu.hs +++ b/src/Dodge/Event/Menu.hs @@ -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 -> diff --git a/src/Dodge/Menu.hs b/src/Dodge/Menu.hs index 6a278f8e4..68c233bd1 100644 --- a/src/Dodge/Menu.hs +++ b/src/Dodge/Menu.hs @@ -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 diff --git a/src/Dodge/PreloadData.hs b/src/Dodge/PreloadData.hs index 25551bad0..1f7b64d20 100644 --- a/src/Dodge/PreloadData.hs +++ b/src/Dodge/PreloadData.hs @@ -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 diff --git a/src/Dodge/Render/List.hs b/src/Dodge/Render/List.hs index 5fe492ca0..10b0cf650 100644 --- a/src/Dodge/Render/List.hs +++ b/src/Dodge/Render/List.hs @@ -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 diff --git a/src/Dodge/Render/Picture.hs b/src/Dodge/Render/Picture.hs index ef3d77a02..8da991d30 100644 --- a/src/Dodge/Render/Picture.hs +++ b/src/Dodge/Render/Picture.hs @@ -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 = diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index da667db65..bc056e7f6 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -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 diff --git a/src/Dodge/Update/Input.hs b/src/Dodge/Update/Input.hs index 1999d55af..c4bf88832 100644 --- a/src/Dodge/Update/Input.hs +++ b/src/Dodge/Update/Input.hs @@ -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 diff --git a/src/Dodge/Update/Scroll.hs b/src/Dodge/Update/Scroll.hs index 703d1593a..52e0790e2 100644 --- a/src/Dodge/Update/Scroll.hs +++ b/src/Dodge/Update/Scroll.hs @@ -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)) diff --git a/src/Loop.hs b/src/Loop.hs index 35ee24e35..5e2561cbd 100644 --- a/src/Loop.hs +++ b/src/Loop.hs @@ -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