181 lines
6.9 KiB
Haskell
181 lines
6.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.Combine
|
|
--import Dodge.Event.Menu
|
|
import Dodge.Data
|
|
import Dodge.Base
|
|
--import Dodge.Base.Window
|
|
import Dodge.PreloadData
|
|
--import Dodge.Creature.Action
|
|
import Dodge.SoundLogic
|
|
import Dodge.Inventory
|
|
import Dodge.Inventory.Add
|
|
--import Geometry
|
|
--import Preload.Update
|
|
import qualified IntMapHelp as IM
|
|
import ListHelp
|
|
import Dodge.FloorItem
|
|
|
|
--import Data.Monoid
|
|
import Data.Maybe
|
|
import Control.Lens
|
|
--import Data.Maybe
|
|
--import Data.Char
|
|
--import Data.List
|
|
--import Data.Function (on)
|
|
import qualified Data.Set as S
|
|
import SDL
|
|
|
|
|
|
--handleEvent :: Event -> Universe -> Maybe Universe
|
|
--handleEvent e uv = case handleEvent' e (_uvWorld uv) of
|
|
-- Nothing -> Nothing
|
|
-- Just w -> Just $ uv & uvWorld .~ w
|
|
|
|
handleEvent :: Event -> Universe -> IO (Maybe Universe)
|
|
handleEvent e = case eventPayload e of
|
|
KeyboardEvent kev -> handleKeyboardEvent kev
|
|
MouseMotionEvent mmev -> return . handleMouseMotionEvent mmev
|
|
MouseButtonEvent mbev -> return . handleMouseButtonEvent mbev
|
|
MouseWheelEvent mwev -> return . handleMouseWheelEvent mwev
|
|
WindowSizeChangedEvent sev -> handleResizeEvent sev
|
|
WindowMovedEvent mev -> return . handleWindowMoveEvent mev
|
|
_ -> return . Just
|
|
|
|
handleMouseMotionEvent :: MouseMotionEventData -> Universe -> Maybe Universe
|
|
handleMouseMotionEvent mmev u = Just $ u & uvWorld . mousePos .~ V2
|
|
(fromIntegral x - 0.5*_windowX cfig)
|
|
(0.5*_windowY cfig - fromIntegral y)
|
|
where
|
|
cfig = _config u
|
|
P (V2 x y) = mouseMotionEventPos mmev
|
|
|
|
handleMouseButtonEvent :: MouseButtonEventData -> Universe -> Maybe Universe
|
|
handleMouseButtonEvent mbev u = case mouseButtonEventMotion mbev of
|
|
Released -> Just $ u & updateButtons S.delete
|
|
Pressed -> handlePressedMouseButton thebutton $ u & updateButtons S.insert
|
|
where
|
|
thebutton = mouseButtonEventButton mbev
|
|
updateButtons f = uvWorld . mouseButtons %~ f thebutton
|
|
|
|
{- | Sets window position in config. -}
|
|
handleWindowMoveEvent :: WindowMovedEventData -> Universe -> Maybe Universe
|
|
handleWindowMoveEvent mev u = Just $ u
|
|
& config . windowPosX .~ fromIntegral x
|
|
& config . windowPosY .~ fromIntegral y
|
|
where
|
|
P (V2 x y) = windowMovedEventPosition mev
|
|
|
|
{- | Resets the world window size, and resizes the fbo that gets the light map drawn into it. -}
|
|
-- using a sideeffect here for the io change seems to work better, more testing
|
|
-- later may be a good idea
|
|
handleResizeEvent :: WindowSizeChangedEventData -> Universe -> IO (Maybe Universe)
|
|
handleResizeEvent sev u = return . Just $ u
|
|
& config . windowX .~ fromIntegral x
|
|
& config . windowY .~ fromIntegral y
|
|
& uvWorld . sideEffects %~ sideEffectUpdatePreload divRes x y
|
|
where
|
|
x = fromIntegral x'
|
|
y = fromIntegral y'
|
|
V2 x' y' = windowSizeChangedEventSize sev
|
|
divRes = resFactorNum $ u ^. config . resolution_factor
|
|
|
|
handlePressedMouseButton :: MouseButton -> Universe -> Maybe Universe
|
|
handlePressedMouseButton but w
|
|
| but == ButtonMiddle || _carteDisplay (_uvWorld w)
|
|
= Just $ w & uvWorld . clickMousePos .~ _mousePos (_uvWorld w)
|
|
| but == ButtonLeft = case _inventoryMode (_uvWorld w) of
|
|
CombineInventory mi -> Just $ fromMaybe w $ do -- ugly
|
|
i <- mi
|
|
return $ over uvWorld (doCombine i) w
|
|
_ -> Just w
|
|
| otherwise = Just w
|
|
|
|
doCombine :: Int -> World -> World
|
|
doCombine i w = case combineItemListYou w !? i of
|
|
Nothing -> w
|
|
Just (is,it) -> enterCombineInv
|
|
. uncurry (putItemInInvID yid)
|
|
. copyItemToFloorID (_crPos $ you w) it
|
|
$ foldr (rmInvItem yid) w is & enterCombineInv
|
|
where
|
|
yid = _yourID w
|
|
|
|
handleMouseWheelEvent :: MouseWheelEventData -> Universe -> Maybe Universe
|
|
handleMouseWheelEvent mwev w = case _menuLayers w of
|
|
[] -> case mouseWheelEventPos mwev of
|
|
V2 _ y -> Just $ w & uvWorld %~ wheelEvent (fromIntegral y)
|
|
_ -> Just w
|
|
|
|
wheelEvent :: Float -> World -> World
|
|
wheelEvent y w = case (_carteDisplay w, _inventoryMode w) of
|
|
(True, _)
|
|
| rbDown -> w & carteZoom %~ min 0.75 . max 0.05 . ((1+y*0.1) * )
|
|
| otherwise -> w & selLocation %~ (`mod` numLocs) . (+ yi)
|
|
(_, TopInventory)
|
|
-- functions that modify the inventory should be centralised so that
|
|
-- this lock can be sensibly applied, perhaps
|
|
| _crInvLock (_creatures w IM.! _yourID w) -> w
|
|
| rbDown -> case yourItem w ^? _Just . itScroll of
|
|
Nothing -> closeObjScrollDir y w
|
|
Just f -> w & creatures . ix 0 . crInv . ix (_crInvSel $ you w) %~ f y (you w)
|
|
| lbDown -> w & cameraZoom +~ y
|
|
| invKeyDown -> stopSoundFrom (CrReloadSound 0) $ changeSwapInvSel yi w
|
|
| otherwise -> stopSoundFrom (CrReloadSound 0) $ changeAugInvSel yi w
|
|
(_, TweakInventory)
|
|
| invKeyDown && rbDown -> w & moveTweakSel yi
|
|
| invKeyDown -> stopSoundFrom (CrReloadSound 0) $ changeInvSel yi w
|
|
| rbDown -> w & changeTweakParam yi
|
|
| otherwise -> w & moveTweakSel yi
|
|
(_, CombineInventory _) -> w
|
|
& inventoryMode . combineInvSel . _Just %~ ((`mod` numcombs) . subtract yi)
|
|
(_, _) -> w
|
|
where
|
|
numcombs = length $ combineItemListYou w
|
|
yi = round $ signum y
|
|
numLocs = (fst . IM.findMax $ _seenLocations w) + 1
|
|
rbDown = ButtonRight `S.member` _mouseButtons w
|
|
lbDown = ButtonLeft `S.member` _mouseButtons w
|
|
invKeyDown = ScancodeCapsLock `S.member` _keys w
|
|
|
|
-- nice idea, but the chain of setters and getters seems prohibitive
|
|
--scrollOver :: Foldable t
|
|
-- => ASetter s s Int Int -- index setter
|
|
-- -> Getting (First (t a)) s (t a) -- pointer to object of size
|
|
-- -> Float -- direction
|
|
-- -> s -> s
|
|
--scrollOver theset theget y w = case w ^? theget of
|
|
-- Just t -> w & theset %~ ( (`mod` length t) . (subtract y'))
|
|
-- Nothing -> w
|
|
-- where
|
|
-- y' = round $ signum y
|
|
|
|
moveTweakSel :: Int -> World -> World
|
|
moveTweakSel i w = case yourItem w ^? _Just . itTweaks . tweakParams of
|
|
Just l -> w & creatures . ix (_yourID w) . crInv . ix (_crInvSel (you w))
|
|
. itTweaks . tweakSel %~ (`mod` length l) . subtract i
|
|
_ -> w
|
|
changeTweakParam :: Int -> World -> World
|
|
changeTweakParam i w = w
|
|
& creatures . ix (_yourID w) . crInv . ix (_crInvSel (you w)) %~
|
|
( (itTweaks . tweakParams . ix paramid . curTweak .~ x)
|
|
. _doTweak params x)
|
|
where
|
|
tweaks = _itTweaks . fromJust $ yourItem w
|
|
params = _tweakParams tweaks IM.! paramid
|
|
x = (_curTweak params + i) `mod` _maxTweak params
|
|
paramid = _tweakSel tweaks
|