Refactor, try to limit dependencies
This commit is contained in:
+86
-76
@@ -1,49 +1,53 @@
|
||||
{- | Deals with keyboard events. -}
|
||||
module Dodge.Event.Keyboard
|
||||
( handleKeyboardEvent
|
||||
, handleTextInput
|
||||
, guardDisconnectedID
|
||||
) where
|
||||
import Dodge.Terminal.LeftButton
|
||||
import Dodge.WorldPos
|
||||
import Dodge.Button.Event
|
||||
import Dodge.InputFocus
|
||||
-- | Deals with keyboard events.
|
||||
module Dodge.Event.Keyboard (
|
||||
handleKeyboardEvent,
|
||||
handleTextInput,
|
||||
guardDisconnectedID,
|
||||
) where
|
||||
|
||||
--import Color
|
||||
|
||||
--import Data.List
|
||||
|
||||
import Data.Maybe
|
||||
import qualified Data.Set as S
|
||||
--import Data.Text (unpack)
|
||||
import qualified Data.Text as T
|
||||
import Dodge.Base
|
||||
import Dodge.Button.Event
|
||||
import Dodge.Combine
|
||||
import Dodge.Creature.Action
|
||||
import Dodge.Data
|
||||
import Dodge.Data.Universe
|
||||
import Dodge.Event.Menu
|
||||
import Dodge.Event.Test
|
||||
import Dodge.InputFocus
|
||||
import Dodge.Inventory
|
||||
import Dodge.Menu
|
||||
import Dodge.Reloading
|
||||
import Dodge.Save
|
||||
import Dodge.Terminal.LeftButton
|
||||
import Dodge.WorldPos
|
||||
import qualified IntMapHelp as IM
|
||||
import LensHelp
|
||||
--import Color
|
||||
|
||||
--import Data.List
|
||||
import qualified IntMapHelp as IM
|
||||
import Data.Maybe
|
||||
import qualified Data.Set as S
|
||||
import SDL
|
||||
--import Data.Text (unpack)
|
||||
import qualified Data.Text as T
|
||||
import SDL
|
||||
|
||||
-- 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
|
||||
handleTextInput text u =
|
||||
u
|
||||
& menuLayers . ix 0 . scInput %~ updateText
|
||||
& updateTerminalText
|
||||
where
|
||||
updateTerminalText = case u ^? uvWorld . cWorld . hud . hudElement . subInventory of
|
||||
Just (DisplayTerminal tmid) | hasfocus tmid
|
||||
-> uvWorld %~ \w -> guardDisconnectedID tmid w (w & cWorld . terminals . ix tmid . tmInput . tiText %~ updateText)
|
||||
_ -> id
|
||||
Just (DisplayTerminal tmid)
|
||||
| hasfocus tmid ->
|
||||
uvWorld %~ \w -> guardDisconnectedID tmid w (w & cWorld . terminals . ix tmid . tmInput . tiText %~ updateText)
|
||||
_ -> id
|
||||
hasfocus tmid = fromMaybe False $ u ^? uvWorld . cWorld . terminals . ix tmid . tmInput . tiFocus
|
||||
updateText s = case T.unpack text of
|
||||
updateText s = case T.unpack text of
|
||||
";" -> s
|
||||
_ -> s `T.append` T.toUpper text
|
||||
|
||||
@@ -52,97 +56,102 @@ guardDisconnectedID tmid w w' = case w ^? cWorld . terminals . ix tmid . tmStatu
|
||||
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)
|
||||
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
|
||||
ScancodeF1 -> Just <$> (writeSaveSlot (SaveSlotNum 1) u >> return u)
|
||||
ScancodeF2 -> Just <$> readSaveSlot (SaveSlotNum 1) u
|
||||
ScancodeF5 -> return . Just $ doQuicksave u
|
||||
ScancodeF9 -> return . Just $ loadSaveSlot QuicksaveSlot u
|
||||
ScancodeSemicolon -> return . Just $ gotoTerminal u
|
||||
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
|
||||
ScancodeF1 -> Just <$> (writeSaveSlot (SaveSlotNum 1) u >> return u)
|
||||
ScancodeF2 -> Just <$> readSaveSlot (SaveSlotNum 1) u
|
||||
ScancodeF5 -> return . Just $ doQuicksave u
|
||||
ScancodeF9 -> return . Just $ loadSaveSlot QuicksaveSlot u
|
||||
ScancodeSemicolon -> return . Just $ gotoTerminal u
|
||||
_ | null (_menuLayers u) -> case u ^? uvWorld . cWorld . hud . hudElement . subInventory of
|
||||
Just (DisplayTerminal tmid) | inTermFocus (_uvWorld u)
|
||||
-> return $ uvWorld (Just . handlePressedKeyTerminal tmid scode) u
|
||||
_ -> return $ (Just . handlePressedKeyInGame scode) u
|
||||
Just (DisplayTerminal tmid)
|
||||
| inTermFocus (_uvWorld u) ->
|
||||
return $ uvWorld (Just . handlePressedKeyTerminal tmid scode) u
|
||||
_ -> return $ (Just . handlePressedKeyInGame scode) u
|
||||
_ -> handlePressedKeyInMenu (head $ _menuLayers u) scode u
|
||||
|
||||
handlePressedKeyInGame :: Scancode -> Universe -> Universe
|
||||
handlePressedKeyInGame scode uv = case scode of
|
||||
ScancodeEscape -> pauseGame $ over uvWorld escapeMap uv
|
||||
ScancodeSpace -> over uvWorld spaceAction uv
|
||||
ScancodeP -> pauseGame $ over uvWorld escapeMap uv
|
||||
ScancodeF -> over uvWorld youDropItem uv
|
||||
ScancodeM -> over uvWorld toggleMap uv
|
||||
ScancodeR -> over uvWorld (crToggleReloading (you w)) uv
|
||||
ScancodeT -> over uvWorld testEvent uv
|
||||
ScancodeX -> uv & uvWorld %~ toggleTweakInv
|
||||
ScancodeC -> over uvWorld toggleCombineInv uv
|
||||
ScancodeI -> uv & uvWorld . cWorld . hud . hudElement %~ toggleInspectInv
|
||||
_ -> uv
|
||||
ScancodeEscape -> pauseGame $ over uvWorld escapeMap uv
|
||||
ScancodeSpace -> over uvWorld spaceAction uv
|
||||
ScancodeP -> pauseGame $ over uvWorld escapeMap uv
|
||||
ScancodeF -> over uvWorld youDropItem uv
|
||||
ScancodeM -> over uvWorld toggleMap uv
|
||||
ScancodeR -> over uvWorld (crToggleReloading (you w)) uv
|
||||
ScancodeT -> over uvWorld testEvent uv
|
||||
ScancodeX -> uv & uvWorld %~ toggleTweakInv
|
||||
ScancodeC -> over uvWorld toggleCombineInv uv
|
||||
ScancodeI -> uv & uvWorld . cWorld . hud . hudElement %~ toggleInspectInv
|
||||
_ -> uv
|
||||
where
|
||||
w = _uvWorld uv
|
||||
|
||||
|
||||
handlePressedKeyTerminal :: Int -> Scancode -> World -> World
|
||||
handlePressedKeyTerminal tmid scode w = case scode of
|
||||
ScancodeEscape -> w & cWorld . terminals . ix tmid . tmInput . tiFocus %~ const False
|
||||
ScancodeReturn -> w & terminalReturnEffect (w ^?! cWorld . terminals . ix tmid)
|
||||
ScancodeBackspace -> w
|
||||
& cWorld . terminals . ix tmid . tmInput . tiText %~ doBackspace
|
||||
& backspaceTimer .~ 5
|
||||
_ -> w
|
||||
ScancodeEscape -> w & cWorld . terminals . ix tmid . tmInput . tiFocus %~ const False
|
||||
ScancodeReturn -> w & terminalReturnEffect (w ^?! cWorld . terminals . ix tmid)
|
||||
ScancodeBackspace ->
|
||||
w
|
||||
& cWorld . terminals . ix tmid . tmInput . tiText %~ doBackspace
|
||||
& backspaceTimer .~ 5
|
||||
_ -> w
|
||||
where
|
||||
doBackspace t = case T.unsnoc t of
|
||||
Nothing -> t
|
||||
Just (t',_) -> t'
|
||||
Just (t', _) -> t'
|
||||
|
||||
toggleTweakInv :: World -> World
|
||||
toggleTweakInv w = case w ^. cWorld . hud . hudElement of
|
||||
DisplayInventory TweakInventory{} -> w & thepointer .~ DisplayInventory NoSubInventory
|
||||
_ -> w & thepointer .~ DisplayInventory (TweakInventory mi)
|
||||
_ -> w & thepointer .~ DisplayInventory (TweakInventory mi)
|
||||
where
|
||||
thepointer = cWorld . hud . hudElement
|
||||
mi = 0 <$ (yourItem w >>= (^? itTweaks . tweakParams . ix 0))
|
||||
|
||||
toggleInspectInv :: HUDElement -> HUDElement
|
||||
toggleInspectInv he = case he of
|
||||
DisplayInventory InspectInventory -> DisplayInventory NoSubInventory
|
||||
_ -> DisplayInventory InspectInventory
|
||||
DisplayInventory InspectInventory -> DisplayInventory NoSubInventory
|
||||
_ -> DisplayInventory InspectInventory
|
||||
|
||||
gotoTerminal :: Universe -> Universe
|
||||
gotoTerminal w = case _menuLayers w of
|
||||
(InputScreen {} : _) -> w
|
||||
_ -> w & menuLayers .:~ InputScreen T.empty "Enter command"
|
||||
(InputScreen{} : _) -> w
|
||||
_ -> w & menuLayers .:~ InputScreen T.empty "Enter command"
|
||||
|
||||
spaceAction :: World -> World
|
||||
spaceAction w = case _hudElement $ _hud (_cWorld w) of
|
||||
DisplayCarte -> w & cWorld . hud . carteCenter .~ theLoc
|
||||
DisplayInventory NoSubInventory -> case selectedCloseObject w of
|
||||
Just (_,Left flit) -> pickUpItem 0 flit w
|
||||
Just (_,Right but) -> doButtonEvent (_btEvent but) but w
|
||||
_ -> w
|
||||
DisplayInventory DisplayTerminal {} -> w & cWorld . hud . hudElement .~ DisplayInventory NoSubInventory
|
||||
Just (_, Left flit) -> pickUpItem 0 flit w
|
||||
Just (_, Right but) -> doButtonEvent (_btEvent but) but w
|
||||
_ -> w
|
||||
DisplayInventory DisplayTerminal{} -> w & cWorld . hud . hudElement .~ DisplayInventory NoSubInventory
|
||||
_ -> w & cWorld . hud . hudElement .~ DisplayInventory NoSubInventory
|
||||
where
|
||||
theLoc = doWorldPos (fst (_seenLocations (_cWorld w) IM.! _selLocation (_cWorld w))) w
|
||||
|
||||
-- updateTopCloseObject i w' = w' & closeObjects %~ ( Right (_buttons w' IM.! i) : ) . tail
|
||||
|
||||
pauseGame :: Universe -> Universe
|
||||
@@ -151,8 +160,9 @@ pauseGame = menuLayers .~ [pauseMenu]
|
||||
toggleMap :: World -> World
|
||||
toggleMap w = case _hudElement $ _hud (_cWorld w) of
|
||||
DisplayCarte -> w & cWorld . hud . hudElement .~ DisplayInventory NoSubInventory
|
||||
_ -> w & cWorld . hud . hudElement .~ DisplayCarte
|
||||
_ -> w & cWorld . hud . hudElement .~ DisplayCarte
|
||||
|
||||
escapeMap :: World -> World
|
||||
escapeMap w = case _hudElement $ _hud (_cWorld w) of
|
||||
DisplayCarte -> w & cWorld . hud . hudElement .~ DisplayInventory NoSubInventory
|
||||
_ -> w
|
||||
_ -> w
|
||||
|
||||
Reference in New Issue
Block a user