150 lines
6.0 KiB
Haskell
150 lines
6.0 KiB
Haskell
{- | Deals with keyboard events. -}
|
|
module Dodge.Event.Keyboard
|
|
( handleKeyboardEvent
|
|
, handleTextInput
|
|
, guardDisconnectedID
|
|
) where
|
|
import Dodge.Terminal
|
|
import Dodge.InputFocus
|
|
import Dodge.Base
|
|
import Dodge.Combine
|
|
import Dodge.Creature.Action
|
|
import Dodge.Data
|
|
import Dodge.Event.Menu
|
|
import Dodge.Event.Test
|
|
import Dodge.Inventory
|
|
import Dodge.Menu
|
|
import Dodge.Reloading
|
|
import Dodge.Save
|
|
import LensHelp
|
|
--import Color
|
|
|
|
--import Data.List
|
|
import qualified Data.IntMap.Strict as IM
|
|
import Data.Maybe
|
|
import qualified Data.Set as S
|
|
import SDL
|
|
--import Data.Text (unpack)
|
|
import qualified Data.Text as T
|
|
|
|
-- annoyingly, the text input event doesn't register backspace, so deletion has to be
|
|
-- dealt with using key presses (handlePressedKey)
|
|
-- also, note that this currently "doubles" the inputs to both terminals if both
|
|
-- are open
|
|
handleTextInput :: T.Text -> Universe -> Universe
|
|
handleTextInput text u = u
|
|
& menuLayers . ix 0 . scInput %~ updateText
|
|
& updateTerminalText
|
|
where
|
|
updateTerminalText = case u ^? uvWorld . hud . hudElement . subInventory of
|
|
Just (DisplayTerminal tmid) | hasfocus tmid
|
|
-> uvWorld %~ \w -> guardDisconnectedID tmid w (w & terminals . ix tmid . tmInput . tiText %~ updateText)
|
|
_ -> id
|
|
hasfocus tmid = fromMaybe False $ u ^? uvWorld . terminals . ix tmid . tmInput . tiFocus
|
|
updateText s = case T.unpack text of
|
|
";" -> s
|
|
_ -> s `T.append` T.toUpper text
|
|
|
|
guardDisconnectedID :: Int -> World -> World -> World
|
|
guardDisconnectedID tmid w w' = case w ^? terminals . ix tmid . tmStatus of
|
|
Just TerminalReady -> w'
|
|
_ -> w
|
|
|
|
|
|
{- | Handles keyboard press and release.
|
|
On release, remove scancode from the 'Set' of pressed keys.
|
|
On press, adds the scancode, and perhaps applies a direct effect:
|
|
see 'handlePressedKeyInGame'.
|
|
-}
|
|
handleKeyboardEvent :: KeyboardEventData -> Universe -> IO (Maybe Universe)
|
|
handleKeyboardEvent kev u = case keyboardEventKeyMotion kev of
|
|
Released -> return . Just $ u & uvWorld . keys %~ S.delete scode
|
|
Pressed -> handlePressedKey (keyboardEventRepeat kev) scode
|
|
(u & uvWorld . keys %~ S.insert scode)
|
|
where
|
|
scode = (keysymScancode . keyboardEventKeysym) kev
|
|
|
|
handlePressedKey :: Bool -> Scancode -> Universe -> IO (Maybe Universe)
|
|
handlePressedKey True ScancodeBackspace u
|
|
| _backspaceTimer (_uvWorld u) <= 0 = handlePressedKey False ScancodeBackspace u
|
|
<&> _Just . uvWorld . backspaceTimer .~ 0
|
|
| otherwise = return $ Just $ u & uvWorld . backspaceTimer -~ 1
|
|
handlePressedKey True _ u = return $ Just u
|
|
handlePressedKey _ scode u = case scode of
|
|
ScancodeF5 -> return . Just $ doQuicksave u
|
|
ScancodeF9 -> return . Just $ loadSaveSlot QuicksaveSlot u
|
|
ScancodeSemicolon -> return . Just $ gotoTerminal u
|
|
_ | null (_menuLayers u) -> case u ^? uvWorld . hud . hudElement . subInventory of
|
|
Just (DisplayTerminal tmid) | inTermFocus (_uvWorld u)
|
|
-> return $ uvWorld (Just . handlePressedKeyTerminal tmid scode) u
|
|
_ -> return $ uvWorld (Just . handlePressedKeyInGame scode) u
|
|
_ -> handlePressedKeyInMenu (head $ _menuLayers u) scode u
|
|
|
|
handlePressedKeyInGame :: Scancode -> World -> World
|
|
handlePressedKeyInGame scode w = case scode of
|
|
ScancodeEscape -> pauseGame $ escapeMap w
|
|
ScancodeSpace -> spaceAction w
|
|
ScancodeP -> pauseGame $ escapeMap w
|
|
ScancodeF -> youDropItem w
|
|
ScancodeM -> toggleMap w
|
|
ScancodeR -> crToggleReloading (you w) w
|
|
ScancodeT -> testEvent w
|
|
ScancodeX -> w & hud . hudElement %~ toggleTweakInv
|
|
ScancodeC -> toggleCombineInv w
|
|
ScancodeI -> w & hud . hudElement %~ toggleInspectInv
|
|
_ -> w
|
|
|
|
|
|
handlePressedKeyTerminal :: Int -> Scancode -> World -> World
|
|
handlePressedKeyTerminal tmid scode w = case scode of
|
|
ScancodeEscape -> w & terminals . ix tmid . tmInput . tiFocus %~ const False
|
|
ScancodeReturn -> w & terminalReturnEffect (w ^?! terminals . ix tmid)
|
|
ScancodeBackspace -> w
|
|
& terminals . ix tmid . tmInput . tiText %~ doBackspace
|
|
& backspaceTimer .~ 5
|
|
_ -> w
|
|
where
|
|
doBackspace t = case T.unsnoc t of
|
|
Nothing -> t
|
|
Just (t',_) -> t'
|
|
|
|
toggleTweakInv :: HUDElement -> HUDElement
|
|
toggleTweakInv he = case he of
|
|
DisplayInventory TweakInventory -> DisplayInventory NoSubInventory
|
|
_ -> DisplayInventory TweakInventory
|
|
|
|
toggleInspectInv :: HUDElement -> HUDElement
|
|
toggleInspectInv he = case he of
|
|
DisplayInventory InspectInventory -> DisplayInventory NoSubInventory
|
|
_ -> DisplayInventory InspectInventory
|
|
|
|
gotoTerminal :: Universe -> Universe
|
|
gotoTerminal w = case _menuLayers w of
|
|
(InputScreen {} : _) -> w
|
|
_ -> w & menuLayers .:~ InputScreen T.empty "Enter command"
|
|
|
|
spaceAction :: World -> World
|
|
spaceAction w = case _hudElement $ _hud w of
|
|
DisplayCarte -> w & hud . carteCenter .~ theLoc
|
|
DisplayInventory NoSubInventory -> case selectedCloseObject w of
|
|
Just (_,Left flit) -> pickUpItem 0 flit w
|
|
Just (_,Right but) -> _btEvent but but w
|
|
_ -> w
|
|
DisplayInventory DisplayTerminal {} -> w & hud . hudElement .~ DisplayInventory NoSubInventory
|
|
_ -> w & hud . hudElement .~ DisplayInventory NoSubInventory
|
|
where
|
|
theLoc = fst (_seenLocations w IM.! _selLocation w) w
|
|
-- updateTopCloseObject i w' = w' & closeObjects %~ ( Right (_buttons w' IM.! i) : ) . tail
|
|
|
|
pauseGame :: World -> World
|
|
pauseGame w = w & sideEffects %~ (. (menuLayers .~ [pauseMenu]))
|
|
|
|
toggleMap :: World -> World
|
|
toggleMap w = case _hudElement $ _hud w of
|
|
DisplayCarte -> w & hud . hudElement .~ DisplayInventory NoSubInventory
|
|
_ -> w & hud . hudElement .~ DisplayCarte
|
|
escapeMap :: World -> World
|
|
escapeMap w = case _hudElement $ _hud w of
|
|
DisplayCarte -> w & hud . hudElement .~ DisplayInventory NoSubInventory
|
|
_ -> w
|