Refactor event code
This commit is contained in:
+1
-1
@@ -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
|
||||
|
||||
@@ -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)
|
||||
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user