127 lines
4.9 KiB
Haskell
127 lines
4.9 KiB
Haskell
{- |
|
|
Module : Dodge.Event
|
|
Description : Direct event handling
|
|
|
|
Deals with direct events.
|
|
This includes individual key or mouse presses, but /not/ continuous held down input.
|
|
We cannot handle multiple keys held down at once here,
|
|
(eg left mouse button + right mouse button)
|
|
because these are separate events.
|
|
Instead we store the events in a set, and deal with the combinations in
|
|
"Dodge.Update".
|
|
-}
|
|
module Dodge.Event
|
|
( handleEvent
|
|
) where
|
|
import Dodge.Event.Keyboard
|
|
import Dodge.Event.Menu
|
|
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 :: World -> Event -> Maybe World
|
|
handleEvent = flip handleEvent'
|
|
|
|
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 w = case _menuLayers w of
|
|
[] -> case mouseWheelEventPos mwev of
|
|
V2 x y | y > 0 -> Just (wheelUpEvent w)
|
|
| y < 0 -> Just (wheelDownEvent w)
|
|
| otherwise -> Just w
|
|
_ -> Just w
|
|
|
|
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 but w
|
|
| but == ButtonMiddle || _carteDisplay w
|
|
= Just $ w & clickMousePos .~ _mousePos w
|
|
| otherwise = Just w
|
|
|
|
wheelUpEvent :: World -> World
|
|
wheelUpEvent w = case _carteDisplay w of
|
|
True | rbDown -> w & carteZoom .~ min 0.75 (z+(0.1*z))
|
|
| otherwise -> w & selLocation %~ (`mod` numLocs) . (\i -> i - 1)
|
|
_ | rbDown -> fromMaybe (closeObjScrollUp w)
|
|
$ (yourItem w ^? itScrollUp)
|
|
<*> pure (_crInvSel (you w))
|
|
<*> pure w
|
|
| lbDown -> w & cameraZoom +~ 0.1
|
|
| otherwise -> upInvPos w
|
|
where
|
|
rbDown = ButtonRight `S.member` _mouseButtons w
|
|
lbDown = ButtonLeft `S.member` _mouseButtons w
|
|
z = _carteZoom w
|
|
numLocs = (fst . IM.findMax $ _seenLocations w) + 1
|
|
|
|
wheelDownEvent :: World -> World
|
|
wheelDownEvent w = case _carteDisplay w of
|
|
True | rbDown -> w & carteZoom .~ max 0.05 (z-(0.1*z))
|
|
| otherwise -> w & selLocation %~ (`mod` numLocs) . (\i -> i + 1)
|
|
False | rbDown -> fromMaybe (closeObjScrollDown w)
|
|
$ (yourItem w ^? itScrollDown)
|
|
<*> pure (_crInvSel (you w))
|
|
<*> pure w
|
|
| lbDown -> w {_cameraZoom = max (_cameraZoom w - 0.1) 0.01}
|
|
| otherwise -> downInvPos w
|
|
where
|
|
rbDown = ButtonRight `S.member` _mouseButtons w
|
|
lbDown = ButtonLeft `S.member` _mouseButtons w
|
|
z = _carteZoom w
|
|
numLocs = (fst . IM.findMax $ _seenLocations w) + 1
|
|
|
|
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)
|
|
|