loop/src/Dodge/Event.hs

{- |
Module      : Dodge.Event
Description : Direct event handling

Deals with direct events.
This could include individual key or mouse presses.
However, we cannot handle multiple keys held down at once here,
(eg left mouse button + right mouse button)
because these are separate events.
Nor could we handle continuous mouse button input.
Instead we store button presses (in a Map) and deal with the combinations in
the simulation step; in particular see 'updatePressedButtons'.
-}
module Dodge.Event
    ( handleEvent
    ) where
import Dodge.InputFocus
import Dodge.Combine
import Dodge.Event.Keyboard
--import Dodge.Event.Menu
import Dodge.Base
--import Dodge.Item
--import Dodge.Combine.Module
import Dodge.Data
--import Dodge.Base.Window
import Dodge.PreloadData
--import Dodge.Creature.Action
import Dodge.Inventory
import Dodge.SoundLogic
--import Geometry
--import Preload.Update
--import Dodge.FloorItem
import qualified IntMapHelp           as IM

--import Data.Monoid
import Control.Lens
import Data.Maybe
--import Data.Maybe
--import Data.Char
--import Data.List
--import Data.Function (on)
import qualified Data.Map.Strict as M
import qualified Data.Set as S
import qualified Data.Text as T
import SDL

handleEvent :: Event -> Universe -> IO (Maybe Universe)
handleEvent e = case eventPayload e of
    TextInputEvent tev         -> return . Just . handleTextInput (textInputEventText tev)
    KeyboardEvent kev          -> handleKeyboardEvent kev
    MouseMotionEvent mmev      -> return . handleMouseMotionEvent mmev
    MouseButtonEvent mbev      -> return . Just . over uvWorld (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 -> World -> World
handleMouseButtonEvent mbev = case mouseButtonEventMotion mbev of
    Released -> mouseButtons . at thebutton .~ Nothing
    Pressed  -> mouseButtons . at thebutton ?~ False
  where
    thebutton = mouseButtonEventButton mbev

{- | Sets window position in config. -}
handleWindowMoveEvent :: WindowMovedEventData -> Universe -> Maybe Universe
handleWindowMoveEvent mev = Just
    . (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 . graphics_resolution_factor

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 _hudElement $ _hud w of
    DisplayCarte
        | rbDown -> w & hud . carteZoom %~ min 0.75 . max 0.05 . ((1+y*0.1) * )
        | otherwise -> w & selLocation %~ (`mod` numLocs) . (+ yi)
    DisplayInventory NoSubInventory
            -- 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 . itUse . heldScroll,_rbOptions w) of
            (_,EquipOptions{}) -> scrollRBOption y w
            (Nothing,_) -> closeObjScrollDir y w
            (Just f,_)  -> w & creatures . ix 0 . crInv . ix (crSel $ you w) %~ f y (you w)
        | lbDown -> w & cameraZoom +~ y
        | invKeyDown -> changeSwapInvSel yi w
        | otherwise  -> stopSoundFrom (CrReloadSound 0) $ changeAugInvSel yi w
    DisplayInventory TweakInventory
        | invKeyDown && rbDown -> w & moveTweakSel yi
        | invKeyDown -> stopSoundFrom (CrReloadSound 0) $ changeInvSel yi w
        | rbDown ->     w & changeTweakParam yi
        | otherwise ->  w & moveTweakSel yi
    DisplayInventory (CombineInventory _) -> w
        & hud . hudElement . subInventory . combineInvSel . _Just %~ ((`mod` numcombs) . subtract yi)
    DisplayInventory (DisplayTerminal tmid)
        | rbDown && inTermFocus w -> guardDisconnectedID tmid w $ w
            & terminals . ix tmid %~ updatetermsubsel
        | inTermFocus w -> w
            & terminals . ix tmid %~ updatetermsel
    _ -> w
  where
    updatetermsel tm = case tm ^? tmInput . tiSel of
        Nothing -> tm & tmInput . tiSel .~ (0,0)
        Just (i,_) -> let newi = (i - yi) `mod` length (scrollCommands tm)
            in tm & setInput newi 0 w
    updatetermsubsel tm = case tm ^? tmInput . tiSel of
        Nothing -> tm & tmInput . tiSel .~ (0,0)
        Just (i,j) -> let newj = (j - yi) `mod` length (getArguments' (scrollCommands tm !! i) tm w)
            in tm & setInput i newj w
    setInput i j w' tm = tm
        & tmInput . tiSel .~ (i,j)
        & tmInput . tiText .~ T.pack (_tcString tc ++ " " ++ arg)
      where
        tc = scrollCommands tm !! i
        arg = getArguments' tc tm w' !! j
    numcombs = length $ combineItemListYou w
    yi = round $ signum y
    numLocs = (fst . IM.findMax $ _seenLocations w) + 1
    rbDown = ButtonRight `M.member` _mouseButtons w
    lbDown = ButtonLeft `M.member` _mouseButtons w
    invKeyDown = ScancodeCapsLock `S.member` _keys w

getArguments' :: TerminalCommand -> Terminal -> World -> [String]
getArguments' tc tm = ("" :) . getArguments tc tm

getArguments :: TerminalCommand -> Terminal -> World -> [String]
getArguments tc tm w = case _tcEffect tc tm w of
    NoArguments {} -> []
    OneArgument _ m -> M.keys m

scrollCommands :: Terminal -> [TerminalCommand]
scrollCommands = (nullCommand :) . _tmScrollCommands
nullCommand :: TerminalCommand
nullCommand = TerminalCommand
    { _tcString = ""
    , _tcAlias  = []
    , _tcHelp   = ""
    , _tcEffect = \_ _ -> NoArguments []
    }

scrollRBOption :: Float -> World -> World
scrollRBOption y w
    | y < 0 = w & rbOptions . opSel %~ (min (length (_opEquip (_rbOptions w))-1) . (+1))
    | y > 0 = w & rbOptions . opSel %~ (max 0 . subtract 1)
    | otherwise = 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 (crSel (you w))
                    . itTweaks . tweakSel %~ (`mod` length l) . subtract i
    _ -> w
changeTweakParam :: Int -> World -> World
changeTweakParam i w = w
    & creatures . ix (_yourID w) . crInv . ix (crSel (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