Refactor event code

2021-03-25 14:23:45 +01:00
parent de31daf21e
commit d0986d0922
5 changed files with 193 additions and 195 deletions
@@ -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)
+
+