Reorganise update-input-gamestate structure
This commit is contained in:
@@ -0,0 +1,250 @@
|
||||
module Dodge.Update.Input.InGame
|
||||
( updateUseInputInGame
|
||||
) where
|
||||
|
||||
import qualified Data.IntMap.Strict as IM
|
||||
import Data.List (sort)
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Maybe
|
||||
import Dodge.Base.You
|
||||
import Dodge.Button.Event
|
||||
import Dodge.Creature.Action
|
||||
import Dodge.Data.Combine
|
||||
import Dodge.Data.Universe
|
||||
import Dodge.Default.World
|
||||
import Dodge.DisplayInventory
|
||||
import Dodge.Event.Test
|
||||
import Dodge.InputFocus
|
||||
import Dodge.Inventory
|
||||
import Dodge.Inventory.Add
|
||||
import Dodge.Menu
|
||||
import Dodge.Reloading
|
||||
import Dodge.Save
|
||||
import Dodge.SelectionSections
|
||||
import Dodge.Terminal.LeftButton
|
||||
import Dodge.Update.Input.Text
|
||||
import Dodge.WorldPos
|
||||
import Geometry
|
||||
import LensHelp
|
||||
import SDL
|
||||
|
||||
updateUseInputInGame :: HUDElement -> Universe -> Universe
|
||||
updateUseInputInGame h u = case h of
|
||||
DisplayCarte -> over uvWorld updatePressedButtonsCarte u
|
||||
DisplayInventory{_subInventory = si} -> case si of
|
||||
DisplayTerminal tmid
|
||||
| lbinitialpress && inTermFocus w ->
|
||||
over uvWorld (doTerminalEffectLB (w ^?! cWorld . lWorld . terminals . ix tmid)) u
|
||||
| inTermFocus (_uvWorld u) -> updateKeysInTerminal tmid u
|
||||
| lbinitialpress ->
|
||||
u & uvWorld . cWorld . lWorld . terminals . ix tmid . tmInput . tiFocus %~ const True
|
||||
CombineInventory{_ciSections = sss}
|
||||
| inSubInvRegex (u ^. uvWorld) -> u & uvWorld . hud . hudElement . subInventory . ciSections %~ doRegexInput u (-1)
|
||||
& uvWorld . worldEventFlags . at CombineInventoryChange ?~ ()
|
||||
| lbinitialpress -> (uvWorld . worldEventFlags . at InventoryChange ?~ ()) . maybeExitCombine $ over uvWorld (tryCombine sss) u
|
||||
& uvWorld . worldEventFlags . at CombineInventoryChange ?~ ()
|
||||
-- _ -> case regexFocus w of
|
||||
-- Nothing -> M.foldlWithKey' updateKeyInGame u pkeys
|
||||
-- Just (filtpoint,selpoint,i) -> u & uvWorld . p %~ doRegexInput
|
||||
_
|
||||
| inInvRegex (u ^. uvWorld) ->
|
||||
u & uvWorld . hud . hudElement . diSections %~ doRegexInput u (-1)
|
||||
& uvWorld . worldEventFlags . at InventoryChange ?~ ()
|
||||
& uvWorld %~ setInvPosFromSS
|
||||
_
|
||||
| inCloseRegex (u ^. uvWorld) ->
|
||||
u & uvWorld . hud . hudElement . diSections %~ doRegexInput u 2
|
||||
& uvWorld . worldEventFlags . at InventoryChange ?~ ()
|
||||
& uvWorld %~ setInvPosFromSS
|
||||
_ -> M.foldlWithKey' updateKeyInGame u pkeys
|
||||
where
|
||||
w = u ^. uvWorld
|
||||
pkeys = u ^. uvWorld . input . pressedKeys
|
||||
lbinitialpress = u ^? uvWorld . input . mouseButtons . ix ButtonLeft == Just False
|
||||
|
||||
updatePressedButtonsCarte :: World -> World
|
||||
updatePressedButtonsCarte w = updatePressedButtonsCarte' (_mouseButtons (_input w)) w
|
||||
|
||||
updatePressedButtonsCarte' :: M.Map MouseButton Bool -> World -> World
|
||||
updatePressedButtonsCarte' pkeys w
|
||||
| isDown ButtonRight =
|
||||
w
|
||||
& input . clickMousePos .~ _mousePos (_input w)
|
||||
& hud . carteCenter %~ (-.- trans)
|
||||
| isDown ButtonLeft =
|
||||
w
|
||||
& input . clickMousePos .~ _mousePos (_input w)
|
||||
& hud . carteRot -~ rot
|
||||
& hud . carteZoom *~ czoom
|
||||
| otherwise = w
|
||||
where
|
||||
isDown but = but `M.member` pkeys
|
||||
rot = angleBetween (_mousePos (_input w)) (_clickMousePos (_input w))
|
||||
czoom = magV (_mousePos (_input w)) / magV (_clickMousePos (_input w))
|
||||
trans =
|
||||
rotateV (w ^. hud . carteRot) $
|
||||
1 / (w ^. hud . carteZoom) *.* (_mousePos (_input w) -.- _clickMousePos (_input w))
|
||||
|
||||
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 -> 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
|
||||
|
||||
doRegexInput :: Universe -> Int -> SelectionSections a -> SelectionSections a
|
||||
doRegexInput u i sss
|
||||
| backspacetonothing || escapekey = endregex i 0
|
||||
| endkeys || endmouse = endregex (i + 1) (j -1)
|
||||
| otherwise = sss & doTextInputOver' u (sssExtra . sssFilters . ix i . _Just)
|
||||
where
|
||||
endregex a b =
|
||||
sss
|
||||
& sssExtra . sssFilters . ix i .~ Nothing
|
||||
& sssSections . ix i . ssItems .~ mempty
|
||||
& ssSetCursor (ssLookupDown a b)
|
||||
j = fromMaybe 0 $ do
|
||||
itms <- sss ^? sssSections . ix (i + 1) . ssItems
|
||||
fst <$> IM.lookupMin itms
|
||||
escapekey = ScancodeEscape `M.lookup` pkeys == Just InitialPress
|
||||
endkeys =
|
||||
any
|
||||
((== Just InitialPress) . (`M.lookup` pkeys))
|
||||
[ScancodeReturn, ScancodeSlash]
|
||||
endmouse = fromMaybe False $ u ^? uvWorld . input . mouseButtons . ix ButtonLeft
|
||||
backspacetonothing =
|
||||
sss ^? sssExtra . sssFilters . ix i . _Just == Just ""
|
||||
&& ScancodeBackspace `M.lookup` pkeys == Just InitialPress
|
||||
pkeys = u ^. uvWorld . input . pressedKeys
|
||||
|
||||
updateBackspaceRegex :: World -> World
|
||||
updateBackspaceRegex w = case di ^? subInventory of
|
||||
Just NoSubInventory | secfocus (-1) 0 -> w & hud . hudElement . diSections %~ trybackspace (-1)
|
||||
& worldEventFlags . at InventoryChange ?~ ()
|
||||
Just NoSubInventory | secfocus 2 3 -> w & hud . hudElement . diSections %~ trybackspace 2
|
||||
& worldEventFlags . at InventoryChange ?~ ()
|
||||
Just CombineInventory{} -> w & hud . hudElement . subInventory . ciSections %~ trybackspace (-1)
|
||||
& worldEventFlags . at InventoryChange ?~ ()
|
||||
_ -> w
|
||||
where
|
||||
secfocus a b = fromMaybe False $ do
|
||||
i <- di ^? diSections . sssExtra . sssSelPos . _Just . _1
|
||||
return $ i == a || i == b
|
||||
trybackspace x sss = fromMaybe sss $ do
|
||||
-- i <- fss ^? fssSections . sssSelPos . _Just . _1
|
||||
-- guard (i == x || i == x+1)
|
||||
str <- sss ^? sssExtra . sssFilters . ix x . _Just
|
||||
return $ case str of
|
||||
(_ : _) ->
|
||||
sss & sssExtra . sssFilters . ix x . _Just %~ init
|
||||
& sssExtra . sssSelPos ?~ (x, 0)
|
||||
[] -> sss & sssExtra . sssFilters . ix x .~ Nothing
|
||||
di = w ^. hud . hudElement
|
||||
|
||||
updateEnterRegex :: World -> World
|
||||
updateEnterRegex w = case w ^? hud . hudElement . subInventory of
|
||||
Just NoSubInventory
|
||||
| secfocus (-1) 0 ->
|
||||
w & hud . hudElement . diSections . sssExtra . sssSelPos ?~ (-1, 0)
|
||||
& hud . hudElement . diSections %~ enterregex (-1)
|
||||
Just NoSubInventory
|
||||
| secfocus 2 3 ->
|
||||
w & hud . hudElement . diSections . sssExtra . sssSelPos ?~ (2, 0)
|
||||
& hud . hudElement . diSections %~ enterregex 2
|
||||
Just CombineInventory{} ->
|
||||
w & hud . hudElement . subInventory . ciSections %~ enterregex (-1)
|
||||
& hud . hudElement . subInventory . ciSections . sssExtra . sssSelPos ?~ (-1, 0)
|
||||
_ -> w
|
||||
where
|
||||
di = w ^. hud . hudElement
|
||||
secfocus a b = fromMaybe False $ do
|
||||
i <- di ^? diSections . sssExtra . sssSelPos . _Just . _1
|
||||
return $ i == a || i == b
|
||||
enterregex x sss =
|
||||
sss & sssExtra . sssFilters . ix x %~ f
|
||||
& sssExtra . sssSelPos ?~ (x, 0)
|
||||
f Nothing = Just ""
|
||||
f x = x
|
||||
|
||||
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
|
||||
& worldEventFlags . at InventoryChange ?~ ()
|
||||
Just (Right but) -> doButtonEvent (_btEvent but) but w
|
||||
& worldEventFlags . at InventoryChange ?~ ()
|
||||
_ -> w
|
||||
DisplayInventory{_subInventory = DisplayTerminal{}} ->
|
||||
w & hud . hudElement . subInventory .~ NoSubInventory
|
||||
& worldEventFlags . at InventoryChange ?~ ()
|
||||
_ -> w & hud . hudElement . subInventory .~ NoSubInventory
|
||||
where
|
||||
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 = defaultInvSections}
|
||||
_ -> u & uvWorld . hud . hudElement .~ DisplayCarte
|
||||
|
||||
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))
|
||||
|
||||
tryCombine :: SelectionSections CombinableItem -> World -> World
|
||||
tryCombine sss w = fromMaybe w $ do
|
||||
(i, j) <- sss ^? sssExtra . sssSelPos . _Just
|
||||
CombinableItem is it _ <- sss ^? sssSections . ix i . ssItems . ix j . siPayload
|
||||
return $ createAndSelectItem it $ foldr (rmInvItem 0) w (sort is)
|
||||
|
||||
maybeExitCombine :: Universe -> Universe
|
||||
maybeExitCombine u
|
||||
| ButtonRight `M.member` (u ^. uvWorld . input . mouseButtons) = u
|
||||
| otherwise = u & uvWorld . hud . hudElement . subInventory .~ NoSubInventory
|
||||
@@ -0,0 +1,115 @@
|
||||
module Dodge.Update.Input.ScreenLayer (
|
||||
updateUseInputOnScreen,
|
||||
) where
|
||||
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Maybe
|
||||
import Dodge.Base.Window
|
||||
import Dodge.Data.Universe
|
||||
import Dodge.Debug.Terminal
|
||||
import Dodge.Menu.Option
|
||||
import Dodge.SelectionList
|
||||
import Dodge.Update.Input.Text
|
||||
import Geometry
|
||||
import LensHelp
|
||||
import SDL
|
||||
|
||||
updateUseInputOnScreen :: ScreenLayer -> Universe -> Universe
|
||||
updateUseInputOnScreen sl = case sl of
|
||||
InputScreen thetext _ -> doInputScreenInput thetext
|
||||
screen@OptionScreen{_scPositionedMenuOption = mop, _scSelectionList = sellist, _scListDisplayParams = ldps} ->
|
||||
optionScreenUpdate screen mop ldps sellist
|
||||
|
||||
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)
|
||||
. (uvWorld . worldEventFlags . at InventoryChange ?~ ())
|
||||
| ScancodeEscape `M.member` pkeys = uvScreenLayers %~ tail
|
||||
| otherwise = id
|
||||
|
||||
optionScreenUpdate ::
|
||||
ScreenLayer ->
|
||||
PositionedMenuOption ->
|
||||
ListDisplayParams ->
|
||||
SelectionList (Universe -> Universe) ->
|
||||
Universe ->
|
||||
Universe
|
||||
optionScreenUpdate screen mop ldps sl u =
|
||||
refreshOptionsSelectionList
|
||||
. optionScreenDefaultEffect mop
|
||||
. mouseClickOptionsList screen
|
||||
. mouseOverSelectionList ldps sl
|
||||
. menuWheelEvents
|
||||
. over (uvScreenLayers . _head) (setSelectionListRestriction (u ^. uvConfig))
|
||||
$ u
|
||||
|
||||
optionScreenDefaultEffect :: PositionedMenuOption -> Universe -> Universe
|
||||
optionScreenDefaultEffect f u = case u ^. uvWorld . input . pressedKeys . at ScancodeEscape of
|
||||
Just InitialPress -> fromMaybe id (f ^? pmoMenuOption . moEff) u
|
||||
_ -> u
|
||||
|
||||
mouseClickOptionsList :: ScreenLayer -> Universe -> Universe
|
||||
mouseClickOptionsList screen u = fromMaybe u $ do
|
||||
sl <- screen ^? scSelectionList
|
||||
Just $ case u ^. uvWorld . input . mouseButtons . at ButtonLeft of
|
||||
Just False -> fromMaybe u $ do
|
||||
i <- sl ^. slSelPos
|
||||
f <- sl ^? slItems . ix i . siPayload
|
||||
return $ f u
|
||||
_ -> u
|
||||
|
||||
mouseOverSelectionList :: ListDisplayParams -> SelectionList (Universe -> Universe) -> Universe -> Universe
|
||||
mouseOverSelectionList ldps sl u
|
||||
| x > xl && x < xr
|
||||
&& ylower == yupper
|
||||
&& mmoving
|
||||
&& ylower >= 0
|
||||
&& ylower < ymax
|
||||
&& isselectable =
|
||||
u & uvScreenLayers . _head . scSelectionList . slSelPos ?~ yupper
|
||||
| otherwise = u
|
||||
where
|
||||
isselectable =
|
||||
fromMaybe False $
|
||||
u ^? uvScreenLayers . _head . scSelectionList . slItems . ix yupper . siIsSelectable
|
||||
ymax = maybe 0 length $ sl ^? slItems
|
||||
mmoving = u ^. uvWorld . input . mouseMoving
|
||||
ylower = ceiling $ (hh - (75 + y + _ldpPosY ldps)) / 50
|
||||
yupper = floor $ (hh - (15 + y + _ldpPosY ldps)) / 50
|
||||
xl = _ldpPosX ldps - hw
|
||||
--xr = xl + _ldpScale ldps * 15 * 9
|
||||
xr = xl + _ldpScale ldps * 26 * 9
|
||||
V2 x y = u ^. uvWorld . input . mousePos
|
||||
cfig = u ^. uvConfig
|
||||
hh = halfHeight cfig
|
||||
hw = halfWidth cfig
|
||||
|
||||
menuWheelEvents :: Universe -> Universe
|
||||
menuWheelEvents u = foldr ($) u (replicate (abs y) (menuWheelStep (signum y)))
|
||||
where
|
||||
y = u ^. uvWorld . input . scrollAmount
|
||||
|
||||
-- you probably want i to be 1 or -1
|
||||
menuWheelStep :: Int -> Universe -> Universe
|
||||
menuWheelStep i u = fromMaybe u $ do
|
||||
sl <- u ^? uvScreenLayers . _head . scSelectionList
|
||||
selpos <- sl ^? slSelPos . _Just
|
||||
ymax <- fmap length (sl ^? slItems)
|
||||
let newpos = (selpos - i) `mod` ymax
|
||||
itm <- sl ^? slItems . ix newpos
|
||||
let newu = u & uvScreenLayers . _head . scSelectionList . slSelPos . _Just %~ const newpos
|
||||
if _siIsSelectable itm
|
||||
then Just newu
|
||||
else Just $ menuWheelStep i newu
|
||||
|
||||
setSelectionListRestriction :: Configuration -> ScreenLayer -> ScreenLayer
|
||||
setSelectionListRestriction cfig screen = fromMaybe screen $ do
|
||||
ldps <- screen ^? scListDisplayParams
|
||||
return $ screen & scAvailableLines %~ const (getAvailableListLines ldps cfig)
|
||||
@@ -0,0 +1,32 @@
|
||||
module Dodge.Update.Input.Text (
|
||||
doTextInputOver,
|
||||
doTextInputOver',
|
||||
) where
|
||||
|
||||
import Data.Char
|
||||
import Dodge.Data.Universe
|
||||
import LensHelp
|
||||
import SDL
|
||||
|
||||
doTextInputOver :: ASetter' Universe String -> Universe -> Universe
|
||||
doTextInputOver p u = doTextInputOver' u p u
|
||||
|
||||
doTextInputOver' :: Universe -> ASetter' a String -> a -> a
|
||||
doTextInputOver' u p x =
|
||||
x & p %~ (++ map toUpper str)
|
||||
& checkBackspace
|
||||
where
|
||||
str = u ^. uvWorld . input . textInput
|
||||
checkBackspace
|
||||
| backspaceInputted u = p %~ doBackspace
|
||||
| otherwise = id
|
||||
|
||||
backspaceInputted :: Universe -> Bool
|
||||
backspaceInputted u = case u ^. uvWorld . input . pressedKeys . at ScancodeBackspace of
|
||||
Just InitialPress -> True
|
||||
Just LongPress -> True
|
||||
_ -> False
|
||||
|
||||
doBackspace :: String -> String
|
||||
doBackspace [] = []
|
||||
doBackspace s = init s
|
||||
Reference in New Issue
Block a user