174 lines
6.7 KiB
Haskell
174 lines
6.7 KiB
Haskell
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 $ getKeycode kev) w
|
|
_ -> handlePressedKeyEvent (addKey (getKeycode kev) w) (keyboardEventRepeat kev) (getKeycode kev)
|
|
where getKeycode :: KeyboardEventData -> Keycode
|
|
getKeycode = keysymKeycode . keyboardEventKeysym
|
|
|
|
addKey :: Keycode -> World -> World
|
|
addKey k = over keys $ S.insert k
|
|
|
|
handlePressedKeyEvent :: World -> Bool -> Keycode -> Maybe World
|
|
handlePressedKeyEvent w True _ = Just w
|
|
handlePressedKeyEvent w _ keycode
|
|
= case keycode of
|
|
KeycodeEscape -> Nothing
|
|
KeycodeC -> Just $ pauseGame $ escapeMap w
|
|
KeycodeF -> Just $ dropItem w
|
|
KeycodeM -> Just $ toggleMap w
|
|
KeycodeP -> Just $ pauseGame $ escapeMap w
|
|
KeycodeR -> Just $ fromMaybe w $ reloadWeapon (_yourID w) w
|
|
KeycodeT -> Just $ testEvent w
|
|
KeycodeSpace -> Just $ spaceAction w
|
|
KeycodeQ -> Just $ w {_cameraRot = _cameraRot w + 0.01}
|
|
KeycodeE -> Just $ w {_cameraRot = _cameraRot w - 0.01}
|
|
_ -> 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
|
|
|