From d0986d09221448fc8760e3f85c7cde434ed1d028 Mon Sep 17 00:00:00 2001 From: jgk Date: Thu, 25 Mar 2021 14:23:45 +0100 Subject: [PATCH] Refactor event code --- app/Main.hs | 4 +- src/Dodge/AIs.hs | 2 +- src/Dodge/Event.hs | 123 +++++++++++++++++++++++ src/Dodge/Event/Keyboard.hs | 67 +++++++++++++ src/Dodge/KeyEvents.hs | 192 ------------------------------------ 5 files changed, 193 insertions(+), 195 deletions(-) create mode 100644 src/Dodge/Event.hs create mode 100644 src/Dodge/Event/Keyboard.hs delete mode 100644 src/Dodge/KeyEvents.hs diff --git a/app/Main.hs b/app/Main.hs index 28591fa8c..6fc3f02bf 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -12,7 +12,7 @@ import Dodge.Rooms import Dodge.Layout import Dodge.LoadSound import Dodge.Update -import Dodge.KeyEvents +import Dodge.Event import Dodge.Rendering import Dodge.Menu import Dodge.Floor @@ -70,7 +70,7 @@ main = do return $ preData & soundData .~ newSoundData & frameTimer .~ endTicks ) - (flip $ menuEvents $ flip handleEvent) + (flip $ menuEvents $ handleEvent) (\w -> Just $ update w) Mix.closeAudio diff --git a/src/Dodge/AIs.hs b/src/Dodge/AIs.hs index f702994f7..9d4ebfb63 100644 --- a/src/Dodge/AIs.hs +++ b/src/Dodge/AIs.hs @@ -5,7 +5,7 @@ import Dodge.Base import Dodge.Path import Dodge.SoundLogic import Dodge.CreatureAction -import Dodge.KeyEvents +import Dodge.Event import Dodge.RandomHelp import Dodge.WorldEvent import Dodge.CreatureState diff --git a/src/Dodge/Event.hs b/src/Dodge/Event.hs new file mode 100644 index 000000000..c3c37cc2d --- /dev/null +++ b/src/Dodge/Event.hs @@ -0,0 +1,123 @@ +module Dodge.Event where +import Dodge.Event.Keyboard + +import Dodge.Data +import Dodge.Base +import Dodge.CreatureAction +import Dodge.SoundLogic +import Dodge.Inventory +import Geometry +import Control.Lens +import Data.Maybe +import Data.Char +import Data.List +import Data.Function (on) +import qualified Data.Set as S +import qualified Data.IntMap.Strict as IM +import SDL + +handleEvent :: Event -> World -> Maybe World +handleEvent e = case eventPayload e of + KeyboardEvent kev -> handleKeyboardEvent kev + MouseMotionEvent mmev -> handleMouseMotionEvent mmev + MouseButtonEvent mbev -> handleMouseButtonEvent mbev + MouseWheelEvent mwev -> handleMouseWheelEvent mwev + WindowSizeChangedEvent sev -> handleResizeEvent sev + _ -> Just + +handleMouseMotionEvent :: MouseMotionEventData -> World -> Maybe World +handleMouseMotionEvent mmev w + = Just $ w & mousePos .~ (fromIntegral x - 0.5*_windowX w + ,0.5*_windowY w - fromIntegral y + ) + where P (V2 x y) = mouseMotionEventPos mmev + +handleMouseButtonEvent :: MouseButtonEventData -> World -> Maybe World +handleMouseButtonEvent mbev w = case mouseButtonEventMotion mbev of + Released -> Just $ over mouseButtons (S.delete but) w + Pressed -> handlePressedMouseButton but + $ over mouseButtons (S.insert but) w + where but = mouseButtonEventButton mbev + +handleMouseWheelEvent :: MouseWheelEventData -> World -> Maybe World +handleMouseWheelEvent mwev = + case mouseWheelEventPos mwev of + V2 x y | y > 0 -> Just . wheelUpEvent + | y < 0 -> Just . wheelDownEvent + | otherwise -> Just + +handleResizeEvent :: WindowSizeChangedEventData -> World -> Maybe World +handleResizeEvent sev = Just . set windowX (fromIntegral x) + . set windowY (fromIntegral y) + where V2 x y = windowSizeChangedEventSize sev + +handlePressedMouseButton :: MouseButton -> World -> Maybe World +handlePressedMouseButton ButtonMiddle w = Just $ set lbClickMousePos (_mousePos w) w +handlePressedMouseButton _ w = Just w + +wheelUpEvent :: World -> World +wheelUpEvent w = case _mapDisplay w of + (True,z) -> w & mapDisplay . _2 .~ min 0.3 (z+(0.1*z)) + _ | rbPressed -> fromMaybe (closeObjScrollUp w) + $ (yourItem w ^? itScrollUp) + <*> pure (_crInvSel (you w)) + <*> pure w + | lbPressed -> w {_cameraZoom = _cameraZoom w + 0.1} + | otherwise -> upInvPos w + where + lbPressed = ButtonLeft `S.member` mbs + rbPressed = ButtonRight `S.member` mbs + mbs = _mouseButtons w +wheelDownEvent :: World -> World +wheelDownEvent w = case _mapDisplay w of + (True,z) -> w & mapDisplay . _2 .~ max 0.05 (z-(0.1*z)) + _ | rbPressed -> fromMaybe (closeObjScrollDown w) + $ (yourItem w ^? itScrollDown) + <*> pure (_crInvSel (you w)) + <*> pure w + | lbPressed -> w {_cameraZoom = max (_cameraZoom w - 0.1) 0.01} + | otherwise -> downInvPos w + where lbPressed = ButtonLeft `S.member` mbs + rbPressed = ButtonRight `S.member` mbs + mbs = _mouseButtons w + +upInvPos :: World -> World +upInvPos w = stopSoundFrom (CrReloadSound 0) $ set (creatures . ix (_yourID w) . crInvSel) x w + where is = IM.keys $ _crInv $ _creatures w IM.! _yourID w + isis = is ++ is + x = before (_crInvSel (you w)) isis +downInvPos :: World -> World +downInvPos w = stopSoundFrom (CrReloadSound 0) $ set (creatures . ix (_yourID w) . crInvSel) x w + where is = IM.keys $ _crInv $ _creatures w IM.! _yourID w + isis = is ++ is + x = after (_crInvSel (you w)) isis + +-- these are incomplete: should put in error case here! +before y (x:z:ys) | y == z = x + | otherwise = before y (z:ys) +after y (x:z:ys) | y == x = z + | otherwise = after y (z:ys) + +mouseActionsCr :: S.Set MouseButton -> Creature -> Creature +mouseActionsCr keys cr + | rbPressed + = set ( crState . stance . posture) Aiming cr + | otherwise + = set ( crState . stance . posture) AtEase cr + where lbPressed = ButtonLeft `S.member` keys + rbPressed = ButtonRight `S.member` keys + +mouseActionsWorld :: S.Set MouseButton -> World -> World +mouseActionsWorld keys w + | lbPressed && rbPressed + = useItem (_yourID w) w + | mbPressed + = set lbClickMousePos (_mousePos w) $ over cameraRot (\r-> r - rotation) w + | otherwise + = w + where lbPressed = ButtonLeft `S.member` keys + rbPressed = ButtonRight `S.member` keys + mbPressed = ButtonMiddle `S.member` keys + rotation = angleBetween (_mousePos w) (_lbClickMousePos w) + + diff --git a/src/Dodge/Event/Keyboard.hs b/src/Dodge/Event/Keyboard.hs new file mode 100644 index 000000000..7052a2258 --- /dev/null +++ b/src/Dodge/Event/Keyboard.hs @@ -0,0 +1,67 @@ +module Dodge.Event.Keyboard + ( handleKeyboardEvent + ) + where +import Dodge.Data +import Dodge.Base +import Dodge.CreatureAction +import SDL +import Data.Maybe +import qualified Data.Set as S +import Control.Lens + +handleKeyboardEvent :: KeyboardEventData -> World -> Maybe World +handleKeyboardEvent kev w = case keyboardEventKeyMotion kev of + Released -> Just $ w & keys %~ S.delete kcode + Pressed -> handlePressedKey + (keyboardEventRepeat kev) + kcode + (w & keys %~ S.insert kcode) + where + kcode = (keysymScancode . keyboardEventKeysym) kev + +handlePressedKey :: Bool -> Scancode -> World -> Maybe World +handlePressedKey True _ w = Just w +handlePressedKey _ keycode w = case keycode of + ScancodeEscape -> Nothing + ScancodeC -> Just $ pauseGame $ escapeMap w + ScancodeF -> Just $ dropItem w + ScancodeM -> Just $ toggleMap w + ScancodeP -> Just $ pauseGame $ escapeMap w + ScancodeR -> Just $ fromMaybe w $ reloadWeapon (_yourID w) w + ScancodeT -> Just $ testEvent w + ScancodeSpace -> Just $ spaceAction w + ScancodeQ -> Just $ w & cameraRot +~ 0.01 + ScancodeE -> Just $ w & cameraRot -~ 0.01 + _ -> Just w + +spaceAction :: World -> World +spaceAction w = case listToMaybe $ _closeActiveObjects w of + Just (Left flit) -> pickUpItem' flit w + Just (Right but) -> _btEvent but but w + Nothing -> w + +testEvent :: World -> World +testEvent w = w + +pauseGame :: World -> World +pauseGame w = w {_menuState = PauseMenu} + +toggleMap w = w & mapDisplay . _1 %~ not +escapeMap w = w & mapDisplay . _1 .~ False + +-- Basic key remapping for a dvorak key layout +keyremap :: Keycode -> Keycode +keyremap KeycodeComma = KeycodeW +keyremap KeycodeA = KeycodeA +keyremap KeycodeE = KeycodeD +keyremap KeycodeO = KeycodeS +keyremap KeycodeSlash = KeycodeQ +keyremap KeycodePeriod = KeycodeE +keyremap KeycodeP = KeycodeR +keyremap KeycodeU = KeycodeF +keyremap k = k + +keyremapDefault :: Keycode -> Keycode +keyremapDefault k = k + diff --git a/src/Dodge/KeyEvents.hs b/src/Dodge/KeyEvents.hs deleted file mode 100644 index c5f36c9bd..000000000 --- a/src/Dodge/KeyEvents.hs +++ /dev/null @@ -1,192 +0,0 @@ -module Dodge.KeyEvents where --- imports {{{ -import Dodge.Data -import Dodge.Base -import Dodge.CreatureAction -import Dodge.SoundLogic -import Dodge.Inventory - -import Geometry - -import Control.Lens - -import Data.Maybe -import Data.Char -import Data.List -import Data.Function (on) - -import qualified Data.Set as S -import qualified Data.IntMap.Strict as IM - -import SDL - --- }}} - -pauseGame :: World -> World -pauseGame w = w {_menuState = PauseMenu} - -handleEvent :: World -> Event -> Maybe World -handleEvent w e = case eventPayload e of - KeyboardEvent kev -> handleKeyEvent w kev - MouseMotionEvent mmev -> handleMouseMotionEvent w mmev - MouseButtonEvent mbev -> handleMouseButtonEvent w mbev - MouseWheelEvent mwev -> handleMouseWheelEvent w mwev - WindowSizeChangedEvent sev -> handleResizeEvent w sev - _ -> Just w - -handleKeyEvent :: World -> KeyboardEventData -> Maybe World -handleKeyEvent w kev = case keyboardEventKeyMotion kev of - Released -> Just $ over keys (S.delete $ getScancode kev) w - _ -> handlePressedKeyEvent (addKey (getScancode kev) w) (keyboardEventRepeat kev) (getScancode kev) - where - getScancode = keysymScancode . keyboardEventKeysym --- where getKeycode :: KeyboardEventData -> Keycode --- getKeycode = _remap w . keysymKeycode . keyboardEventKeysym - -addKey :: Scancode -> World -> World -addKey k = over keys $ S.insert k - --- Basic key remapping for a dvorak key layout -keyremap :: Keycode -> Keycode -keyremap KeycodeComma = KeycodeW -keyremap KeycodeA = KeycodeA -keyremap KeycodeE = KeycodeD -keyremap KeycodeO = KeycodeS -keyremap KeycodeSlash = KeycodeQ -keyremap KeycodePeriod = KeycodeE -keyremap KeycodeP = KeycodeR -keyremap KeycodeU = KeycodeF -keyremap k = k - -keyremapDefault :: Keycode -> Keycode -keyremapDefault k = k - -handlePressedKeyEvent :: World -> Bool -> Scancode -> Maybe World -handlePressedKeyEvent w True _ = Just w -handlePressedKeyEvent w _ keycode - = case keycode of - ScancodeEscape -> Nothing - ScancodeC -> Just $ pauseGame $ escapeMap w - ScancodeF -> Just $ dropItem w - ScancodeM -> Just $ toggleMap w - ScancodeP -> Just $ pauseGame $ escapeMap w - ScancodeR -> Just $ fromMaybe w $ reloadWeapon (_yourID w) w - ScancodeT -> Just $ testEvent w - ScancodeSpace -> Just $ spaceAction w - ScancodeQ -> Just $ w {_cameraRot = _cameraRot w + 0.01} - ScancodeE -> Just $ w {_cameraRot = _cameraRot w - 0.01} --- ScancodeF1 -> Just $ w {_remap = keyremap} --- ScancodeF2 -> Just $ w {_remap = keyremapDefault} - _ -> Just w - -handleMouseMotionEvent :: World -> MouseMotionEventData -> Maybe World -handleMouseMotionEvent w mmev - = Just $ set mousePos (fromIntegral x - 0.5*_windowX w - ,0.5*_windowY w - fromIntegral y - ) w - where P (V2 x y) = mouseMotionEventPos mmev - -handleMouseButtonEvent :: World -> MouseButtonEventData -> Maybe World -handleMouseButtonEvent w mbev = case mouseButtonEventMotion mbev of - Released -> Just $ over mouseButtons (S.delete but) w - Pressed -> handlePressedMouseButton but $ over mouseButtons (S.insert but) w - where but = mouseButtonEventButton mbev - -handlePressedMouseButton :: MouseButton -> World -> Maybe World -handlePressedMouseButton ButtonMiddle w = Just $ set lbClickMousePos (_mousePos w) w -handlePressedMouseButton _ w = Just w - -handleMouseWheelEvent :: World -> MouseWheelEventData -> Maybe World -handleMouseWheelEvent w mwev = - case mouseWheelEventPos mwev of - V2 x y | y > 0 -> Just $ wheelUpEvent w - | y < 0 -> Just $ wheelDownEvent w - | otherwise -> Just $ w - -handleResizeEvent :: World -> WindowSizeChangedEventData -> Maybe World -handleResizeEvent w sev = Just $ set windowX (fromIntegral x) - $ set windowY (fromIntegral y) w - where V2 x y = windowSizeChangedEventSize sev - -toggleMap w = w & mapDisplay . _1 %~ not -escapeMap w = w & mapDisplay . _1 .~ False - -wheelUpEvent :: World -> World -wheelUpEvent w - = case _mapDisplay w of - (True,z) -> w & mapDisplay . _2 .~ min 0.3 (z+(0.1*z)) - _ | rbPressed -> fromMaybe (closeObjScrollUp w) - $ (yourItem w ^? itScrollUp) <*> pure (_crInvSel (you w)) - <*> pure w - | lbPressed -> w {_cameraZoom = _cameraZoom w + 0.1} - | otherwise -> upInvPos w - where lbPressed = ButtonLeft `S.member` mbs - rbPressed = ButtonRight `S.member` mbs - mbs = _mouseButtons w -wheelDownEvent :: World -> World -wheelDownEvent w - = case _mapDisplay w of - (True,z) -> w & mapDisplay . _2 .~ max 0.05 (z-(0.1*z)) - _ | rbPressed -> fromMaybe (closeObjScrollDown w) - $ (yourItem w ^? itScrollDown) <*> pure (_crInvSel (you w)) - <*> pure w - | lbPressed -> w {_cameraZoom = max (_cameraZoom w - 0.1) 0.01} - | otherwise -> downInvPos w - where lbPressed = ButtonLeft `S.member` mbs - rbPressed = ButtonRight `S.member` mbs - mbs = _mouseButtons w - -upInvPos :: World -> World ---upInvPos w = soundOnce 3 $ stopSoundFrom (CrReloadSound 0) $ set (creatures . ix (_yourID w) . crInvSel) x w -upInvPos w = stopSoundFrom (CrReloadSound 0) $ set (creatures . ix (_yourID w) . crInvSel) x w - where is = IM.keys $ _crInv $ _creatures w IM.! _yourID w - isis = is ++ is - x = before (_crInvSel (you w)) isis -downInvPos :: World -> World ---downInvPos w = playSoundFromFor InventorySound 3 2 $ stopSoundFrom (CrReloadSound 0) $ set (creatures . ix (_yourID w) . crInvSel) x w -downInvPos w = stopSoundFrom (CrReloadSound 0) $ set (creatures . ix (_yourID w) . crInvSel) x w - where is = IM.keys $ _crInv $ _creatures w IM.! _yourID w - isis = is ++ is - x = after (_crInvSel (you w)) isis - - --- these are incomplete: should put in error case here! -before y (x:z:ys) | y == z = x - | otherwise = before y (z:ys) -after y (x:z:ys) | y == x = z - | otherwise = after y (z:ys) - -mouseActionsCr :: S.Set MouseButton -> Creature -> Creature -mouseActionsCr keys cr - | rbPressed - = set ( crState . stance . posture) Aiming cr - | otherwise - = set ( crState . stance . posture) AtEase cr - where lbPressed = ButtonLeft `S.member` keys - rbPressed = ButtonRight `S.member` keys - -mouseActionsWorld :: S.Set MouseButton -> World -> World -mouseActionsWorld keys w - | lbPressed && rbPressed - = useItem (_yourID w) w - | mbPressed - = set lbClickMousePos (_mousePos w) $ over cameraRot (\r-> r - rotation) w - | otherwise - = w - where lbPressed = ButtonLeft `S.member` keys - rbPressed = ButtonRight `S.member` keys - mbPressed = ButtonMiddle `S.member` keys - ---wUp = MouseButton WheelUp `S.member` keys - ---wDown = MouseButton WheelDown `S.member` keys - ---theItem = _crInv (you w) IM.! _crInvSel (you w) - rotation = angleBetween (_mousePos w) (_lbClickMousePos w) - -spaceAction :: World -> World -spaceAction w = case listToMaybe $ _closeActiveObjects w of - Just (Left flit) -> pickUpItem' flit w - Just (Right but) -> _btEvent but but w - Nothing -> w - -testEvent :: World -> World -testEvent w = w -