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
|
||||
|
||||
+49
-44
@@ -1,61 +1,66 @@
|
||||
module Dodge.Event.Menu
|
||||
( handlePressedKeyInMenu
|
||||
) where
|
||||
import Dodge.Data
|
||||
module Dodge.Event.Menu (
|
||||
handlePressedKeyInMenu,
|
||||
) where
|
||||
|
||||
import Control.Lens
|
||||
import Data.Maybe
|
||||
import qualified Data.Text as T
|
||||
import Dodge.Data.Universe
|
||||
import Dodge.Debug.Terminal
|
||||
--import Dodge.Menu
|
||||
import Dodge.Menu.PushPop
|
||||
import Dodge.WindowLayout
|
||||
|
||||
import Data.Maybe
|
||||
--import Control.Monad
|
||||
import Control.Lens
|
||||
import SDL
|
||||
--import qualified Debug.Trace
|
||||
import qualified Data.Text as T
|
||||
|
||||
handlePressedKeyInMenu :: ScreenLayer -> Scancode -> Universe -> IO (Maybe Universe)
|
||||
handlePressedKeyInMenu mState scode = case mState of
|
||||
OptionScreen { _scOptions = mos, _scDefaultEff = defeff}
|
||||
-> optionListToEffects defeff scode mos
|
||||
DisplayScreen {} -> popScreen
|
||||
ColumnsScreen {} -> popScreen
|
||||
WaitScreen {} -> return . Just
|
||||
InputScreen s help -> case scode of
|
||||
ScancodeEscape -> popScreen
|
||||
ScancodeReturn -> popScreen . applyTerminalString (words $ T.unpack s)
|
||||
ScancodeTab -> autoCompleteTerminal (T.unpack s) help
|
||||
ScancodeBackspace -> return . Just . (menuLayers . ix 0 . scInput %~ doBackspace)
|
||||
OptionScreen{_scOptions = mos, _scDefaultEff = defeff} ->
|
||||
optionListToEffects defeff scode mos
|
||||
DisplayScreen{} -> popScreen
|
||||
ColumnsScreen{} -> popScreen
|
||||
WaitScreen{} -> return . Just
|
||||
InputScreen s help -> case scode of
|
||||
ScancodeEscape -> popScreen
|
||||
ScancodeReturn -> popScreen . applyTerminalString (words $ T.unpack s)
|
||||
ScancodeTab -> autoCompleteTerminal (T.unpack s) help
|
||||
ScancodeBackspace -> return . Just . (menuLayers . ix 0 . scInput %~ doBackspace)
|
||||
-- text input handled by handleTextInput
|
||||
_ -> return . Just
|
||||
_ -> return . Just
|
||||
where
|
||||
doBackspace t = case T.unsnoc t of
|
||||
Nothing -> t
|
||||
Just (t',_) -> t'
|
||||
Just (t', _) -> t'
|
||||
|
||||
optionListToEffects
|
||||
:: (Universe -> IO (Maybe Universe))
|
||||
-> Scancode
|
||||
-> [MenuOption]
|
||||
-> Universe -> IO (Maybe Universe)
|
||||
optionListToEffects ::
|
||||
(Universe -> IO (Maybe Universe)) ->
|
||||
Scancode ->
|
||||
[MenuOption] ->
|
||||
Universe ->
|
||||
IO (Maybe Universe)
|
||||
optionListToEffects defaulteff sc mops u = case sc of
|
||||
ScancodeSpace -> return . Just
|
||||
. (menuLayers . ix 0 . scOptionsOffset %~ (f . (+ mlines)))
|
||||
$ u
|
||||
_ -> (fromMaybe defaulteff
|
||||
. lookup sc
|
||||
. concatMap menuOptionToEffects $ mops) u
|
||||
ScancodeSpace ->
|
||||
return . Just
|
||||
. (menuLayers . ix 0 . scOptionsOffset %~ (f . (+ mlines)))
|
||||
$ u
|
||||
_ ->
|
||||
( fromMaybe defaulteff
|
||||
. lookup sc
|
||||
. concatMap menuOptionToEffects
|
||||
$ mops
|
||||
)
|
||||
u
|
||||
where
|
||||
f x | x > length mops = 0
|
||||
f x
|
||||
| x > length mops = 0
|
||||
| otherwise = x
|
||||
mlines = availableMenuLines $ _uvConfig u
|
||||
|
||||
menuOptionToEffects :: MenuOption -> [(Scancode,Universe -> IO (Maybe Universe))]
|
||||
menuOptionToEffects Toggle {_moKey = k, _moEff = eff} = [(k,eff)]
|
||||
menuOptionToEffects InvisibleToggle {_moKey = k, _moEff = eff} = [(k,eff)]
|
||||
menuOptionToEffects Toggle2
|
||||
{ _moKey1 = k1
|
||||
, _moEff1 = eff1
|
||||
, _moKey2 = k2
|
||||
, _moEff2 = eff2
|
||||
} = [(k1,eff1) , (k2,eff2)]
|
||||
menuOptionToEffects :: MenuOption -> [(Scancode, Universe -> IO (Maybe Universe))]
|
||||
menuOptionToEffects Toggle{_moKey = k, _moEff = eff} = [(k, eff)]
|
||||
menuOptionToEffects InvisibleToggle{_moKey = k, _moEff = eff} = [(k, eff)]
|
||||
menuOptionToEffects
|
||||
Toggle2
|
||||
{ _moKey1 = k1
|
||||
, _moEff1 = eff1
|
||||
, _moKey2 = k2
|
||||
, _moEff2 = eff2
|
||||
} = [(k1, eff1), (k2, eff2)]
|
||||
|
||||
+14
-20
@@ -1,15 +1,9 @@
|
||||
module Dodge.Event.Test
|
||||
( testEvent
|
||||
)
|
||||
where
|
||||
import Dodge.Data
|
||||
--import Dodge.Base
|
||||
--import Dodge.Default
|
||||
--import Picture
|
||||
--import Geometry
|
||||
--
|
||||
--import qualified IntMapHelp as IM
|
||||
--import Control.Lens
|
||||
module Dodge.Event.Test (
|
||||
testEvent,
|
||||
) where
|
||||
|
||||
import Dodge.Data.World
|
||||
|
||||
testEvent :: World -> World
|
||||
testEvent w = w
|
||||
|
||||
@@ -21,17 +15,17 @@ testEvent w = w
|
||||
--
|
||||
-- testWalls = IM.fromList $ zip [k..] $ setKeys (startWalls ++ errorWalls ++ (errorWall : polyWalls) ++ endWalls)
|
||||
--
|
||||
-- polyPairs = makeLoopPairs
|
||||
-- polyPairs = makeLoopPairs
|
||||
-- $ reverse [(-340.0,59.999996),(-374.64102,79.99999),(-340.0,100.0)]
|
||||
---- [(4172.5835,2597.1892),(3855.1414,2597.1895),(3855.141,2324.7563),(4172.5835,2324.756)]
|
||||
-- polyWalls = map (wallWithCol red . flat2) polyPairs
|
||||
--
|
||||
-- errorWallPair =
|
||||
--
|
||||
-- errorWallPair =
|
||||
-- (9,[(-340.0,60.0),(-320.0,60.0)])
|
||||
---- (48,[(3855.1414,2587.1892),(3855.141,2324.7563)])
|
||||
-- errorWall = wallWithCol green $ snd errorWallPair
|
||||
--
|
||||
-- errorWallPairs =
|
||||
-- errorWallPairs =
|
||||
-- [(1,[(-400.0,59.999996),(-340.0,60.0)])
|
||||
-- ,(12,[(-340.0,60.0),(-340.0,59.999996)])
|
||||
-- ]
|
||||
@@ -39,8 +33,8 @@ testEvent w = w
|
||||
---- ,(49,[(3855.1414,2597.1895),(3855.1414,2587.1892)])
|
||||
---- ]
|
||||
-- errorWalls = map (wallWithCol blue . snd) errorWallPairs
|
||||
--
|
||||
-- startWallPairs =
|
||||
--
|
||||
-- startWallPairs =
|
||||
-- [(0,[(-320.0,60.0),(-320.0,100.0)])
|
||||
-- ,(1,[(-400.0,59.999996),(-320.0,60.0)])
|
||||
-- ,(2,[(-400.0,100.0),(-400.0,59.999996)])
|
||||
@@ -61,9 +55,9 @@ testEvent w = w
|
||||
---- ,(40,[(3895.1414,2647.1892),(3895.1414,2667.1892)])
|
||||
---- ]
|
||||
-- startWalls = map (wallWithCol yellow . snd) startWallPairs
|
||||
--
|
||||
--
|
||||
-- endWalls = map (wallWithCol (withAlpha 0.2 orange) . snd) endWallPairs
|
||||
-- endWallPairs =
|
||||
-- endWallPairs =
|
||||
-- [(0,[(-320.0,60.0),(-320.0,100.0)])
|
||||
-- ,(1,[(-400.0,59.999996),(-340.0,60.0)])
|
||||
-- ,(2,[(-400.0,100.0),(-400.0,59.999996)])
|
||||
|
||||
Reference in New Issue
Block a user