Simplify the main loop, events only perform functional update

2022-11-01 11:05:51 +00:00
parent 82c4b992b0
commit d982ac728a
14 changed files with 232 additions and 150 deletions
@@ -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
@@ -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
@@ -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
@@ -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"
@@ -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 ->
@@ -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
@@ -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

@@ -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
@@ -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 =
@@ -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

@@ -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
@@ -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))