justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity
Files
38fdf5151710b6de569b4a58d0ebd6cf0a259f67
loop/src/Dodge/Update/Input.hs
T
justin 38fdf51517 Cleanup
2023-02-17 11:53:54 +00:00

258 lines
10 KiB
Haskell
Raw Blame History

module Dodge.Update.Input (
updateKeyInGame,
updateKeysInTerminal,
doInputScreenInput,
doSubInvRegexInput,
doRegexInput,
) where
import Data.Monoid (First)
import Dodge.Inventory
import Data.Maybe
import Dodge.DisplayInventory
import SelectionIntMap
import qualified Data.Map.Strict as M
import Data.Char
import Dodge.Base.You
import Dodge.Button.Event
import Dodge.Combine
import Dodge.Creature.Action
import Dodge.Data.Universe
import Dodge.Debug.Terminal
import Dodge.Event.Test
import Dodge.Menu
import Dodge.Reloading
import Dodge.Save
import Dodge.Terminal.LeftButton
import Dodge.WorldPos
import LensHelp
import SDL
--doTextInputOver' :: Universe -> ASetter' a String -> a -> a
--doTextInputOver' u p x = x & p %~ (++ map toUpper thetext)
-- & checkBackspace
-- where
-- thetext = u ^. uvWorld . input . textInput
-- checkBackspace
-- | backspaceInputted u = p %~ doBackspace
-- | otherwise = id
doTextInputOver :: ASetter' Universe String -> Universe -> Universe
doTextInputOver p u = u & p %~ (++ map toUpper thetext)
& checkBackspace
where
thetext = u ^. uvWorld . input . textInput
checkBackspace
| backspaceInputted u = p %~ doBackspace
| otherwise = id
doBackspace :: String -> String
doBackspace [] = []
doBackspace s = init s
backspaceInputted :: Universe -> Bool
backspaceInputted u = case u ^. uvWorld . input . pressedKeys . at ScancodeBackspace of
Just InitialPress -> True
Just LongPress -> True
_ -> False
doSubInvRegexInput :: Universe -> Universe
doSubInvRegexInput u
| backspacetonothing
= u & uvWorld . hud . hudElement . subInventory . subInvMap . smRegex .~ Nothing
& uvWorld . hud . hudElement . subInventory . subInvMap %~ initialSelPos
& uvWorld . hud . hudElement . subInventory . subInvMap %~ setShownIntMap
| endkeys || endmouse
= u & uvWorld . hud . hudElement . subInventory . subInvMap %~ initialSelPos
| otherwise = u & doTextInputOver (uvWorld . hud . hudElement . subInventory . subInvMap . smRegex . _Just)
& uvWorld . hud . hudElement . subInventory . subInvMap %~ setShownIntMap
where
endkeys = any
( (== Just InitialPress) . (`M.lookup` pkeys))
[ScancodeReturn,ScancodeEscape,ScancodeSlash]
endmouse = Just True == (u ^? uvWorld . input . mouseButtons . ix ButtonLeft)
backspacetonothing = u ^? uvWorld . hud . hudElement . subInventory . subInvMap . smRegex . _Just == Just ""
&& ScancodeBackspace `M.lookup` pkeys == Just InitialPress
pkeys = u ^. uvWorld . input . pressedKeys
doRegexInput :: Int
-> ((Maybe String -> Identity (Maybe String))
-> Manipulation -> Identity Manipulation)
-> ((Maybe String
-> Const (First String) (Maybe String))
-> Manipulation -> Const (First String) Manipulation)
-> Universe
-> Universe
doRegexInput i crregex crregex' u
| backspacetonothing
= u
& uvWorld . cWorld . lWorld . creatures . ix 0 . crManipulation . crregex .~ Nothing
& uvWorld . hud . hudElement . diSections %~
( ssSetCursor (ssLookupGT i 0)
. (overSection (ssItems . at i .~ Nothing))
)
& uvWorld %~ setInvPosFromSS
| endkeys || endmouse = u
| otherwise = u & doTextInputOver
(uvWorld . cWorld . lWorld . creatures . ix 0 . crManipulation . crregex . _Just)
where
endkeys = any
( (== Just InitialPress) . (`M.lookup` pkeys))
[ScancodeReturn,ScancodeEscape,ScancodeSlash]
endmouse = Just True == (u ^? uvWorld . input . mouseButtons . ix ButtonLeft)
backspacetonothing = u ^? uvWorld . cWorld . lWorld . creatures . ix 0 . crManipulation . crregex' . _Just == Just ""
&& ScancodeBackspace `M.lookup` pkeys == Just InitialPress
pkeys = u ^. uvWorld . input . pressedKeys
doInputScreenInput :: String -> Universe -> Universe
doInputScreenInput s u =
u & doTextInputOver (uvScreenLayers . _head . scInput)
& checkEndStatus
where
pkeys = u ^. uvWorld . input . pressedKeys
checkEndStatus
| ScancodeReturn `M.member` pkeys = (uvScreenLayers %~ tail)
. applyTerminalString (words s)
| ScancodeEscape `M.member` pkeys = uvScreenLayers %~ tail
| otherwise = id
updateKeysInTerminal :: Int -> Universe -> Universe
updateKeysInTerminal tmid u =
u & doTextInputOver tmpoint
& checkEndStatus
where
tmpoint = uvWorld . cWorld . lWorld . terminals . ix tmid . tmInput . tiText
pkeys = u ^. uvWorld . input . pressedKeys
checkEndStatus
| pkeys ^. at ScancodeReturn == Just InitialPress =
over uvWorld (\w -> terminalReturnEffect (w ^?! cWorld . lWorld . terminals . ix tmid) w)
| otherwise = id
updateKeyInGame :: Universe -> Scancode -> PressType -> Universe
updateKeyInGame uv sc pt = case pt of
InitialPress -> updateInitialPressInGame uv sc
LongPress -> updateLongPressInGame uv sc
_ -> uv
updateInitialPressInGame :: Universe -> Scancode -> Universe
updateInitialPressInGame uv sc = case sc of
ScancodeF5 -> doQuicksave uv
ScancodeF9 -> loadSaveSlot QuicksaveSlot uv
ScancodeEscape -> pauseGame uv
ScancodeSpace -> over uvWorld spaceAction uv
ScancodeP -> pauseGame uv
ScancodeF -> over uvWorld youDropItem uv
ScancodeM -> toggleMap uv
ScancodeR -> over (uvWorld . cWorld . lWorld . creatures . ix 0) crToggleReloading uv
ScancodeT -> over uvWorld testEvent uv
ScancodeX -> uv & uvWorld %~ toggleTweakInv
ScancodeC -> over uvWorld toggleCombineInv uv
-- the following should be put in a more sensible place
ScancodeSlash -> uv & uvWorld %~ updateEnterRegex
ScancodeBackspace -> uv & uvWorld %~ updateBackspaceRegex
_ -> uv
updateLongPressInGame :: Universe -> Scancode -> Universe
updateLongPressInGame uv sc = case sc of
ScancodeF -> over uvWorld youDropItem uv
ScancodeSpace -> over uvWorld spaceAction uv
_ -> uv
updateBackspaceRegex :: World -> World
updateBackspaceRegex w = case di ^? subInventory of
Just NoSubInventory | invfocus -> w & cWorld . lWorld . creatures . ix 0 . crManipulation %~ trybackspace
Just NoSubInventory | closefocus -> w & cWorld . lWorld . creatures . ix 0 . crManipulation %~ trybackspaceclose
Just CombineInventory {} -> w & hud . hudElement . subInventory . subInvMap %~
( ( smRegex %~ enternonzeroregex )
. ( smSelPos ?~ 0 )
. ( setShownIntMap )
)
_ -> w
where
invfocus = fromMaybe False $ do
i <- di ^? diSections . sssSelPos . _Just
return $ i == (-1) || i == 0
closefocus = fromMaybe False $ do
i <- di ^? diSections . sssSelPos . _Just
return $ i == 2 || i == 3
trybackspace cm = case cm ^? invRegex . _Just of
Just (_:_) -> cm & invRegex . _Just %~ init
& manObject .~ InInventory SortInventory
Just [] -> cm & invRegex .~ Nothing
Nothing -> cm
trybackspaceclose cm = case cm ^? closeRegex . _Just of
Just (_:_) -> cm & closeRegex . _Just %~ init
& manObject .~ InNearby SortNearby
Just [] -> cm & closeRegex .~ Nothing
Nothing -> cm
di = w ^. hud . hudElement
enternonzeroregex (Just (x:xs)) = Just (init (x:xs))
enternonzeroregex smr = smr
updateEnterRegex :: World -> World
updateEnterRegex w = case w ^? hud . hudElement . subInventory of
Just NoSubInventory | invfocus -> w & cWorld . lWorld . creatures . ix 0 . crManipulation %~
( ( invRegex %~ startregex )
. ( manObject .~ InInventory SortInventory)
)
Just NoSubInventory | closefocus -> w & cWorld . lWorld . creatures . ix 0 . crManipulation %~
( ( closeRegex %~ startregex )
. ( manObject .~ InNearby SortNearby)
)
Just CombineInventory {} -> w & hud . hudElement . subInventory . subInvMap %~
( setShownIntMap
. (smSelPos ?~ 0 )
. ( smRegex %~ enterregex)
)
_ -> w
where
di = w ^. hud . hudElement
invfocus = fromMaybe False $ do
i <- di ^? diSections . sssSelPos . _Just
return $ i == (-1) || i == 0
closefocus = fromMaybe False $ do
i <- di ^? diSections . sssSelPos . _Just
return $ i == 2 || i == 3
startregex Nothing = Just ""
startregex x = x
enterregex Nothing = Just ""
enterregex (Just str) = Just str
overSection :: (SelectionSection a -> SelectionSection a) -> SelectionSections a -> SelectionSections a
overSection f sss = fromMaybe sss $ do
i <- sss ^? sssSelPos . _Just
return $ sss & sssSections . ix i %~ f
pauseGame :: Universe -> Universe
pauseGame u = u & uvScreenLayers .~ [pauseMenu u]
spaceAction :: World -> World
spaceAction w = case w ^?! hud . hudElement of
DisplayCarte -> w & hud . carteCenter .~ theLoc
DisplayInventory {_subInventory = NoSubInventory} -> case selectedCloseObject w of
Just (_, Left flit) -> pickUpItem 0 flit w
Just (_, Right but) -> doButtonEvent (_btEvent but) but w
_ -> w
DisplayInventory {_subInventory = DisplayTerminal{}}
-> w & hud . hudElement . subInventory .~ NoSubInventory
_ -> w & hud . hudElement . subInventory .~ NoSubInventory
where
--theLoc = doWorldPos (fst (_seenLocations (_cWorld w) IM.! _selLocation (_cWorld w))) w
theLoc = doWorldPos (w ^?! cWorld . lWorld . seenLocations . ix (w ^. cWorld . lWorld . selLocation) . _1) w
toggleMap :: Universe -> Universe
toggleMap u = case u ^?! uvWorld . hud . hudElement of
DisplayCarte -> u & uvWorld . hud . hudElement .~ DisplayInventory {_subInventory = NoSubInventory, _diSections = defaultDisplaySections}
_ -> u & uvWorld . hud . hudElement .~ DisplayCarte
-- where
-- w = u ^. uvWorld
-- cfig = u ^. uvConfig
toggleTweakInv :: World -> World
toggleTweakInv w = case w ^? hud . hudElement . subInventory of
Just ExamineInventory{} -> w & thepointer .~ NoSubInventory
_ -> w & thepointer .~ ExamineInventory mi
where
thepointer = hud . hudElement . subInventory
mi = 0 <$ (yourItem w >>= (^? itTweaks . tweakParams . ix 0))
Reference in New Issue View Git Blame Copy Permalink