556 lines
21 KiB
Haskell
556 lines
21 KiB
Haskell
{-# LANGUAGE LambdaCase #-}
|
|
|
|
module Dodge.Update.Input.InGame (
|
|
updateUseInputInGame,
|
|
updateMouseInGame,
|
|
) where
|
|
|
|
import Control.Applicative
|
|
import Control.Monad
|
|
import Data.Foldable
|
|
import qualified Data.IntMap.Strict as IM
|
|
import qualified Data.IntSet as IS
|
|
import Data.List (sort)
|
|
import qualified Data.Map.Strict as M
|
|
import Data.Maybe
|
|
import Data.Monoid
|
|
import Dodge.Base.Collide
|
|
import Dodge.Camera
|
|
import Dodge.Creature.Action
|
|
import Dodge.Data.CardinalPoint
|
|
import Dodge.Data.Combine
|
|
import Dodge.Data.Terminal.Status
|
|
import Dodge.Data.Universe
|
|
import Dodge.DisplayInventory
|
|
import Dodge.Event.Test
|
|
import Dodge.Inventory
|
|
import Dodge.Inventory.Add
|
|
import Dodge.Inventory.CheckSlots
|
|
import Dodge.Item.Display
|
|
import Dodge.Item.InvSize
|
|
import Dodge.ListDisplayParams
|
|
import Dodge.Menu
|
|
import Dodge.Save
|
|
import Dodge.SelectedClose
|
|
import Dodge.SelectionSections
|
|
import Dodge.SoundLogic
|
|
import Dodge.Terminal
|
|
import Dodge.Update.Input.DebugTest
|
|
import Dodge.Update.Input.Text
|
|
import Geometry.Vector
|
|
import LensHelp
|
|
import NewInt
|
|
import SDL
|
|
|
|
updateUseInputInGame :: Universe -> Universe
|
|
updateUseInputInGame u = updateFunctionKeys $ case u ^. uvWorld . hud of
|
|
HUD{_subInventory = si, _diSelection = disel} -> case si of
|
|
DisplayTerminal tmid -> updateKeysInTerminal tmid u
|
|
CombineInventory{_ciSections = sss, _ciSelection = msel@(Just (Sel (-1) _ _))} ->
|
|
u
|
|
& tohud . subInventory %~ docombineregexinput sss msel
|
|
& uvWorld . worldEventFlags . at CombineInventoryChange ?~ ()
|
|
_
|
|
| disel ^? _Just . slSec == Just (-1) ->
|
|
u
|
|
& tohud %~ dodisplayregexinput diInvFilter diInvFilter (-1)
|
|
& uvWorld . worldEventFlags . at InventoryChange ?~ ()
|
|
& uvWorld %~ setInvPosFromSS
|
|
_
|
|
| disel ^? _Just . slSec == Just 2 ->
|
|
u
|
|
& tohud %~ dodisplayregexinput diCloseFilter diCloseFilter 2
|
|
& uvWorld . worldEventFlags . at InventoryChange ?~ ()
|
|
& uvWorld %~ setInvPosFromSS
|
|
_ -> M.foldlWithKey' updateKeyInGame u pkeys
|
|
where
|
|
tohud = uvWorld . hud
|
|
pkeys = u ^. uvWorld . input . pressedKeys
|
|
dodisplayregexinput filterprism filterlens x di = fromMaybe di $ do
|
|
sss <- di ^? diSections
|
|
msel <- di ^? diSelection
|
|
filts <- di ^? filterprism
|
|
let (sss', msel', filts') = doRegexInput (u ^. uvWorld . input) x sss msel filts
|
|
return $
|
|
di & diSections .~ sss'
|
|
& diSelection .~ msel'
|
|
& filterlens .~ filts'
|
|
docombineregexinput sss msel ci = fromMaybe ci $ do
|
|
filts <- ci ^? ciFilter
|
|
let (sss', msel', filts') = doRegexInput (u ^. uvWorld . input) (-1) sss msel filts
|
|
return $
|
|
ci & ciSections .~ sss'
|
|
& ciSelection .~ msel'
|
|
& ciFilter .~ filts'
|
|
|
|
updateMouseInGame :: Config -> World -> World
|
|
updateMouseInGame cfig w
|
|
| Just 0 <- lbpress = updateMouseClickInGame cfig w
|
|
| Just _ <- lbpress = updateMouseHeldInGame cfig w
|
|
| Just 0 <- lbrelease = updateMouseReleaseInGame w
|
|
| otherwise = w
|
|
where
|
|
lbpress = w ^? input . mouseButtons . ix ButtonLeft
|
|
lbrelease = w ^? input . mouseButtonsReleased . ix ButtonLeft
|
|
|
|
updateMouseHeldInGame :: Config -> World -> World
|
|
updateMouseHeldInGame cfig w = case w ^. input . mouseContext of
|
|
OverInvDragSelect{} | ButtonRight `M.member` (w ^. input . mouseButtons) ->
|
|
w & input . mouseContext .~ MouseGameRotate
|
|
OverInvDragSelect (Just sstart) _ ->
|
|
let sss = w ^. hud . diSections
|
|
msel = inverseSelNumPos cfig invDP (w ^. input . mousePos) sss
|
|
in case msel of
|
|
Nothing -> w & input . mouseContext . mcoSelEnd .~ Nothing
|
|
Just (i, j)
|
|
| i == fst sstart -> w & input . mouseContext . mcoSelEnd ?~ j
|
|
| i < fst sstart -> w & input . mouseContext . mcoSelEnd ?~ 0
|
|
| otherwise ->
|
|
w & input . mouseContext . mcoSelEnd
|
|
.~ fmap
|
|
fst
|
|
(IM.lookupMax =<< sss ^? ix (fst sstart) . ssItems)
|
|
-- not sure how the above performs when filtering...
|
|
OverInvDragSelect Nothing _ -> fromMaybe w $ do
|
|
sss <- w ^? hud . diSections
|
|
ysel <-
|
|
inverseSelSecYint
|
|
(posSelSecYint cfig invDP (w ^. input . mousePos . _y))
|
|
sss
|
|
^? nonInf
|
|
guard (isGroupSelectableSection $ fst ysel)
|
|
return $ w & input . mouseContext .~ OverInvDragSelect (Just ysel) Nothing
|
|
OverInvDrag k mmouseover -> doDrag cfig 30 k mmouseover w
|
|
_ -> w
|
|
|
|
doDrag :: Config -> Int -> Int -> Maybe (Int, Int) -> World -> World
|
|
doDrag cfig n k mmouseover w = fromMaybe w $ do
|
|
guard (n /= 0)
|
|
ss <- w ^? hud . diSections . ix k . ssItems
|
|
x <- mmouseover
|
|
is <- w ^? hud . diSelection . _Just . slSet
|
|
return $
|
|
if concurrentIS is
|
|
then shiftInvItems cfig n k x is ss w
|
|
else collectInvItems k is w
|
|
|
|
tryDropSelected :: Maybe (Int, Int) -> World -> Maybe World
|
|
tryDropSelected mpos w = do
|
|
guard $ maybe True (\(i, _) -> i == 3) mpos
|
|
cr <- w ^? cWorld . lWorld . creatures . ix 0
|
|
Sel 0 _ xs <- w ^? hud . diSelection . _Just
|
|
return . foldl' (flip $ dropItem cr) w . IS.toDescList $ xs
|
|
|
|
tryPickupSelected :: Int -> Maybe (Int, Int) -> World -> Maybe World
|
|
tryPickupSelected k mpos w = do
|
|
guard $ k == 3
|
|
guard $ maybe True (\(i, _) -> i == 0 || i == 1) mpos
|
|
cr <- w ^? cWorld . lWorld . creatures . ix 0
|
|
xs <- w ^? hud . diSelection . _Just . slSet
|
|
let nfreeslots = crNumFreeSlots (w ^. cWorld . lWorld . items) cr
|
|
itmstopickup = mapMaybe g $ IS.toList xs
|
|
slotsneeded = alaf Sum foldMap itInvHeight itmstopickup
|
|
ispickup = map (_unNInt . _itID) itmstopickup
|
|
guard $ nfreeslots >= slotsneeded
|
|
return $ case mpos of
|
|
Just (0, j) -> foldr (pickUpItemAt j 0) w ispickup & newdisel j xs
|
|
_ -> foldl' (flip $ pickUpItem 0) w ispickup & newdisel (length (cr ^. crInv)) xs
|
|
where
|
|
newdisel j xs =
|
|
hud . diSelection
|
|
?~ Sel 0 j (IS.fromDistinctAscList [j .. j + IS.size xs -1])
|
|
g i = do
|
|
NInt j <- w ^? hud . closeItems . ix i
|
|
w ^? cWorld . lWorld . items . ix j
|
|
|
|
updateMouseReleaseInGame :: World -> World
|
|
updateMouseReleaseInGame w = case w ^. input . mouseContext of
|
|
OverInvDrag k mpos ->
|
|
input . mouseContext .~ MouseInGame $
|
|
fromMaybe w $ tryDropSelected mpos w <|> tryPickupSelected k mpos w
|
|
OverInvDragSelect (Just ssel) mesel
|
|
| ScancodeLShift `M.member` (w ^. input . pressedKeys) ->
|
|
w & input . mouseContext .~ MouseInGame
|
|
& hud . diSelection . _Just . slSet
|
|
%~ getuniques
|
|
( maybe
|
|
mempty
|
|
(h ssel)
|
|
(guard (ssel ^? _1 == w ^? hud . diSelection . _Just . slSec) >> mesel ^? _Just)
|
|
)
|
|
OverInvDragSelect (Just ssel) (Just esel) ->
|
|
w & input . mouseContext .~ MouseInGame
|
|
& invSetSelection (f (fst ssel, esel) (h ssel esel))
|
|
OverInvDragSelect{} ->
|
|
w & input . mouseContext .~ MouseInGame
|
|
& hud . diSelection . _Just . slSet %~ const mempty
|
|
_ -> w
|
|
where
|
|
getuniques x y = IS.union x y IS.\\ IS.intersection x y
|
|
f (x, y) z = Sel x y z
|
|
h (k, i) j = fold $ do
|
|
sss <- w ^? hud . diSections . ix k . ssItems
|
|
let (_, xss) = IM.split (min i j -1) sss
|
|
(yss, _) = IM.split (max i j + 1) xss
|
|
return . IM.keysSet $ yss
|
|
|
|
isGroupSelectableSection :: Int -> Bool
|
|
isGroupSelectableSection = \case
|
|
0 -> True
|
|
3 -> True
|
|
_ -> False
|
|
|
|
updateMouseClickInGame :: Config -> World -> World
|
|
updateMouseClickInGame cfig w = case w ^. input . mouseContext of
|
|
MouseInGame -> fromMaybe (w & input . mouseContext .~ OverInvDragSelect Nothing Nothing) $ do
|
|
let sss = w ^. hud . diSections
|
|
ysel <-
|
|
inverseSelSecYint
|
|
(posSelSecYint cfig invDP (w ^. input . mousePos . _y))
|
|
sss
|
|
^? nonInf
|
|
guard (isGroupSelectableSection $ fst ysel)
|
|
return $ w & input . mouseContext .~ OverInvDragSelect (Just ysel) Nothing
|
|
OverInvSelect (-1, _)
|
|
| selsec == Just (-1) ->
|
|
w & hud . diSelection %~ endRegex (-1) w
|
|
& hud . diInvFilter .~ Nothing
|
|
OverInvSelect (2, _)
|
|
| selsec == Just 2 ->
|
|
w & hud . diSelection %~ endRegex 2 w
|
|
& hud . diCloseFilter .~ Nothing
|
|
OverInvSelect x
|
|
| ScancodeLShift `M.member` (w ^. input . pressedKeys)
|
|
&& isGroupSelectableSection (fst x) ->
|
|
w & input . mouseContext .~ OverInvDragSelect (Just x) (Just $ snd x)
|
|
OverInvSelect x -> startDrag x w
|
|
OverTerminal tmid TerminalTextInput{} -> terminalReturnEffect tmid w
|
|
OverTerminal tmid TerminalPressTo{} -> continueTerminal tmid w
|
|
OutsideTerminal -> w & hud . subInventory .~ NoSubInventory
|
|
OverCombSelect x ->
|
|
w & hud . subInventory . ciSelection ?~ f x
|
|
& worldEventFlags . at CombineInventoryChange ?~ ()
|
|
OverCombFilter ->
|
|
w & hud . subInventory . ciFilter .~ Nothing
|
|
& worldEventFlags . at CombineInventoryChange ?~ ()
|
|
& hud . subInventory . ciSelection %~ endCombineRegex w
|
|
OverCombCombine x ->
|
|
w
|
|
& tryCombine x
|
|
& worldEventFlags . at CombineInventoryChange ?~ ()
|
|
& worldEventFlags . at InventoryChange ?~ ()
|
|
& maybeExitCombine
|
|
OverCombEscape ->
|
|
w
|
|
& worldEventFlags . at InventoryChange ?~ ()
|
|
& hud . subInventory .~ NoSubInventory
|
|
OverCombFiltInv (0, j) -> fromMaybe w $ do
|
|
str <-
|
|
fmap (take 5) $
|
|
w ^? cWorld . lWorld . creatures . ix 0 . crInv . ix (NInt j)
|
|
>>= \k ->
|
|
w ^? cWorld . lWorld . items . ix k
|
|
>>= (listToMaybe . basicItemDisplay)
|
|
return . (worldEventFlags . at CombineInventoryChange ?~ ()) $
|
|
case w ^? hud . subInventory . ciFilter . _Just of
|
|
Just ('#' : xs)
|
|
| str == xs ->
|
|
w & hud . subInventory . ciFilter .~ Nothing
|
|
_ -> w & hud . subInventory . ciFilter ?~ ("#" ++ str)
|
|
_ -> w
|
|
where
|
|
f (x, y) = Sel x y mempty
|
|
selsec = w ^? hud . diSelection . _Just . slSec
|
|
|
|
endRegex :: Int -> World -> Maybe Selection -> Maybe Selection
|
|
endRegex i w = ssSetCursor (ssLookupDown i j) sss
|
|
where
|
|
sss = w ^. hud . diSections
|
|
j = maybe 0 fst $ IM.lookupMin =<< sss ^? ix i . ssItems
|
|
|
|
endCombineRegex :: World -> Maybe Selection -> Maybe Selection
|
|
endCombineRegex w = ssSetCursor (ssLookupDown 0 j) sss
|
|
where
|
|
sss = w ^. hud . subInventory . ciSections
|
|
j = fromMaybe 0 $ do
|
|
itms <- sss ^? ix 0 . ssItems
|
|
(k, _) <- IM.lookupMin itms
|
|
return (k -1)
|
|
|
|
startDrag :: (Int, Int) -> World -> World
|
|
startDrag (a, b) w = setcontext $ case w ^? hud . diSelection . _Just of
|
|
Just (Sel i _ xs) | i == a && b `IS.member` xs -> w
|
|
_ -> invSetSelection (Sel a b (IS.singleton b)) w
|
|
where
|
|
setcontext = input . mouseContext .~ OverInvDrag a (Just (a, b))
|
|
|
|
concurrentIS :: IS.IntSet -> Bool
|
|
concurrentIS = go . IS.minView
|
|
where
|
|
go x = fromMaybe True $ do
|
|
(i, is) <- x
|
|
(j, js) <- IS.minView is
|
|
return $ i + 1 == j && go (Just (j, js))
|
|
|
|
collectInvItems :: Int -> IS.IntSet -> World -> World
|
|
collectInvItems secid is w = fromMaybe w $ do
|
|
guard $ secid == 0
|
|
(j, js) <- IS.minView is
|
|
return $ h j js w
|
|
where
|
|
h j js w' = fromMaybe w' $ do
|
|
(k, ks) <- IS.minView js
|
|
return . h (j + 1) ks $ swapInvItems (\_ _ -> Just (j + 1)) k w'
|
|
|
|
shiftInvItems ::
|
|
Config ->
|
|
Int -> -- recurse limit
|
|
Int -> -- section where drag started
|
|
(Int, Int) -> -- selection item mouse is over
|
|
IS.IntSet ->
|
|
IM.IntMap (SelectionItem a) ->
|
|
World ->
|
|
World
|
|
shiftInvItems cfig n k x xs ss w = setSelWhileDragging . fromMaybe w $ do
|
|
let xk = fst x
|
|
let yint = posSelSecYint cfig invDP (w ^. input . mousePos . _y)
|
|
bn =
|
|
(\v -> inverseSelSecYint (yint + 1) v ^? nonInf)
|
|
=<< w ^? hud . diSections
|
|
ab =
|
|
(\v -> inverseSelSecYint (yint - 1) v ^? nonInf)
|
|
=<< w ^? hud . diSections
|
|
guard $ xk == k || xk + 1 == k || xk -1 == k
|
|
(maxi, _) <- IS.maxView xs
|
|
(mini, _) <- IS.minView xs
|
|
case True of
|
|
_ | x < (k, mini) -> do
|
|
guard $ not . null . fst $ IM.split mini ss
|
|
guard $ Just (k, mini -1) /= ab
|
|
return . doDrag cfig (n -1) k (Just x) $ shiftInvItemsUp k xs w
|
|
_ | x > (k, maxi) -> do
|
|
guard $ not . null . snd $ IM.split maxi ss
|
|
guard $ Just (k, maxi + 1) /= bn
|
|
return . doDrag cfig (n -1) k (Just x) $ shiftInvItemsDown k xs w
|
|
_ -> Nothing
|
|
|
|
setSelWhileDragging :: World -> World
|
|
setSelWhileDragging w = fromMaybe w $ do
|
|
Sel i _ xs <- w ^? hud . diSelection . _Just
|
|
(k, j) <- w ^? input . mouseContext . mcoMaybeSelect . _Just
|
|
guard $ i == k && j `IS.member` xs
|
|
return $ w & hud . diSelection . _Just . slInt .~ j
|
|
|
|
shiftInvItemsUp :: Int -> IS.IntSet -> World -> World
|
|
shiftInvItemsUp j is w = IS.foldl' f w is
|
|
where
|
|
f w' i' = swapItemWith g (j, i') w'
|
|
g i' m = fst <$> IM.lookupLT i' m
|
|
|
|
shiftInvItemsDown :: Int -> IS.IntSet -> World -> World
|
|
shiftInvItemsDown j is w = fromMaybe w $ do
|
|
let i = IS.findMax is
|
|
guard . isJust $ w ^? hud . diSections . ix j . ssItems . ix i
|
|
return $ IS.foldr f w is
|
|
where
|
|
f i' w' = swapItemWith g (j, i') w'
|
|
g i' m = fst <$> IM.lookupGT i' m
|
|
|
|
updateFunctionKeys :: Universe -> Universe
|
|
updateFunctionKeys u =
|
|
M.foldlWithKey' updateFunctionKey u (u ^. uvWorld . input . pressedKeys)
|
|
|
|
updateFunctionKey :: Universe -> Scancode -> Int -> Universe
|
|
updateFunctionKey uv sc 0 = case sc of
|
|
ScancodeF1 -> useNormalCamera uv
|
|
ScancodeF2 -> pauseAndFloatCam uv
|
|
ScancodeF5 -> doQuicksave uv
|
|
ScancodeF9 -> doQuickload uv
|
|
ScancodeF6 -> doDebugTestF6 uv
|
|
ScancodeF7 -> doDebugTestF7 uv
|
|
ScancodeF8 -> doDebugTestF8 uv
|
|
ScancodeF10 -> doDebugTestF10 uv
|
|
ScancodeF11 -> doDebugTestF11 uv
|
|
ScancodeF12 -> doDebugTestF12 uv
|
|
ScancodeEscape -> pauseGame uv
|
|
_ -> uv
|
|
updateFunctionKey uv ScancodeF3 _ = doDebugTest uv
|
|
updateFunctionKey uv ScancodeF4 _ = doDebugTest2 uv
|
|
updateFunctionKey uv _ _ = uv
|
|
|
|
updateKeysInTerminal :: Int -> Universe -> Universe
|
|
updateKeysInTerminal tmid u = fromMaybe u $ do
|
|
tm <- u ^? uvWorld . cWorld . lWorld . terminals . ix tmid
|
|
x <- u ^? uvWorld . cWorld . lWorld . buttons . ix (tm ^. tmButtonID) . btPos
|
|
y <- u ^? uvWorld . cWorld . lWorld . creatures . ix 0 . crPos
|
|
return $ case tm ^. tmStatus of
|
|
_
|
|
| dist x y > 40 || not (hasButtonLOS x y (u ^. uvWorld)) ->
|
|
u & uvWorld . hud . subInventory .~ NoSubInventory
|
|
TerminalDeactivated -> u & uvWorld . hud . subInventory .~ NoSubInventory
|
|
TerminalTextInput{} -> updateKeysTextInputTerminal tmid u
|
|
TerminalPressTo{} -> updateKeyContinueTerminal tmid u
|
|
_ -> u
|
|
|
|
updateKeyContinueTerminal :: Int -> Universe -> Universe
|
|
updateKeyContinueTerminal tmid u
|
|
| elem 0 $ u ^. uvWorld . input . pressedKeys = u & uvWorld %~ continueTerminal tmid
|
|
| otherwise = u
|
|
|
|
continueTerminal :: Int -> World -> World
|
|
continueTerminal tmid = cWorld . lWorld . terminals . ix tmid . tmStatus .~ TerminalLineRead
|
|
|
|
updateKeysTextInputTerminal :: Int -> Universe -> Universe
|
|
updateKeysTextInputTerminal tmid u =
|
|
u
|
|
& doTextInputOverUniverse
|
|
(uvWorld . cWorld . lWorld . terminals . ix tmid . tmStatus . tiText)
|
|
& checkEndStatus
|
|
& tryTabComplete
|
|
where
|
|
checkEndStatus
|
|
| u ^. uvWorld . input . pressedKeys . at ScancodeReturn == Just 0 =
|
|
uvWorld %~ terminalReturnEffect tmid
|
|
| otherwise = id
|
|
tryTabComplete
|
|
| u ^. uvWorld . input . pressedKeys . at ScancodeTab == Just 0 =
|
|
uvWorld . cWorld . lWorld . terminals . ix tmid %~ tabComplete (u ^. uvWorld)
|
|
| otherwise = id
|
|
|
|
updateKeyInGame :: Universe -> Scancode -> Int -> Universe
|
|
updateKeyInGame uv sc = \case
|
|
0 -> updateInitialPressInGame uv sc
|
|
x | x >= 30 -> updateLongPressInGame uv sc
|
|
_ -> uv
|
|
|
|
updateInitialPressInGame :: Universe -> Scancode -> Universe
|
|
updateInitialPressInGame uv = \case
|
|
ScancodeSpace -> over uvWorld spaceAction uv
|
|
ScancodeP -> pauseGame uv
|
|
ScancodeF -> over uvWorld youDropItem uv
|
|
-- ScancodeM -> toggleMap uv
|
|
ScancodeT -> over uvWorld testEvent uv
|
|
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 = \case
|
|
ScancodeF -> over uvWorld youDropItem uv
|
|
ScancodeSpace -> over uvWorld spaceAction uv
|
|
_ -> uv
|
|
|
|
doRegexInput ::
|
|
Input ->
|
|
Int ->
|
|
IMSS a ->
|
|
Maybe Selection ->
|
|
Maybe String ->
|
|
(IMSS a, Maybe Selection, Maybe String)
|
|
doRegexInput inp i sss msel filts
|
|
| backspacetonothing || escapekey = endregex i 0
|
|
| endkeys = endregex (i + 1) (j -1)
|
|
| otherwise =
|
|
( sss
|
|
, msel
|
|
, filts & doTextInputOver inp _Just
|
|
)
|
|
where
|
|
endregex a b =
|
|
( sss
|
|
, msel & ssSetCursor (ssLookupDown a b) sss
|
|
, Nothing
|
|
)
|
|
j = fromMaybe 0 $ do
|
|
itms <- sss ^? ix (i + 1) . ssItems
|
|
fst <$> IM.lookupMin itms
|
|
escapekey = ScancodeEscape `M.lookup` pkeys == Just 0
|
|
endkeys = any ((== Just 0) . (`M.lookup` pkeys)) [ScancodeReturn, ScancodeSlash]
|
|
backspacetonothing =
|
|
filts == Just ""
|
|
&& ScancodeBackspace `M.lookup` pkeys == Just 0
|
|
pkeys = inp ^. pressedKeys
|
|
|
|
updateBackspaceRegex :: World -> World
|
|
updateBackspaceRegex w = case di ^? subInventory of
|
|
Just NoSubInventory{}
|
|
| secfocus (-1) 0 ->
|
|
w & hud %~ trybackspace (-1) diInvFilter diInvFilter diSelection
|
|
& worldEventFlags . at InventoryChange ?~ ()
|
|
Just NoSubInventory{}
|
|
| secfocus 2 3 ->
|
|
w & hud %~ trybackspace 2 diCloseFilter diCloseFilter diSelection
|
|
& worldEventFlags . at InventoryChange ?~ ()
|
|
Just CombineInventory{} ->
|
|
w & hud . subInventory %~ trybackspace (-1) ciFilter ciFilter ciSelection
|
|
& worldEventFlags . at InventoryChange ?~ ()
|
|
_ -> w
|
|
where
|
|
secfocus a b = fromMaybe False $ do
|
|
i <- di ^? diSelection . _Just . slSec
|
|
return $ i == a || i == b
|
|
trybackspace x filtget filtset selset he = fromMaybe he $ do
|
|
str <- he ^? filtget . _Just
|
|
return $ case str of
|
|
(_ : _) ->
|
|
he & filtset . _Just %~ init
|
|
& selset ?~ Sel x 0 mempty
|
|
[] -> he & filtset .~ Nothing
|
|
di = w ^. hud
|
|
|
|
updateEnterRegex :: World -> World
|
|
updateEnterRegex w = case w ^? hud . subInventory of
|
|
Just NoSubInventory{}
|
|
| secfocus [-1, 0, 1] ->
|
|
w & hud . diSelection ?~ Sel (-1) 0 mempty
|
|
& hud . diInvFilter %~ enterregex
|
|
Just NoSubInventory{}
|
|
| secfocus [2, 3] ->
|
|
w & hud . diSelection ?~ Sel 2 0 mempty
|
|
& hud . diCloseFilter %~ enterregex
|
|
Just CombineInventory{} ->
|
|
w & hud . subInventory . ciFilter %~ enterregex
|
|
& hud . subInventory . ciSelection ?~ Sel (-1) 0 mempty
|
|
_ -> w
|
|
where
|
|
secfocus xs = fromMaybe False $ do
|
|
i <- w ^? hud . diSelection . _Just . slSec
|
|
return $ i `elem` xs
|
|
enterregex = (<|> Just "")
|
|
|
|
pauseGame :: Universe -> Universe
|
|
pauseGame u = u & uvScreenLayers .~ [pauseMenu u] & pauseSound
|
|
|
|
spaceAction :: World -> World
|
|
spaceAction w = case w ^. hud . subInventory of
|
|
NoSubInventory -> maybe id interactWithCloseObj (getCloseObj w) w
|
|
_ -> w & hud . subInventory .~ NoSubInventory
|
|
|
|
getCloseObj :: World -> Maybe (Either (NewInt ItmInt) Button)
|
|
getCloseObj w = getSelectedCloseObj w <|> topcitem <|> topcbut
|
|
where
|
|
topcitem = do
|
|
k <- (w ^? hud . diSections . ix 3 . ssItems)
|
|
>>= (fmap fst . IM.lookupMin)
|
|
Left <$> w ^? hud . closeItems . ix k
|
|
topcbut = do
|
|
k <- w ^? hud . closeButtons . ix 0
|
|
Right <$> w ^? cWorld . lWorld . buttons . ix k
|
|
|
|
tryCombine :: (Int, Int) -> World -> World
|
|
tryCombine (i, j) w = fromMaybe w $ do
|
|
CombinableItem is it <- w ^? hud . subInventory
|
|
. ciSections . ix i . ssItems . ix j . siPayload . _Just
|
|
p <- w ^? cWorld . lWorld . creatures . ix 0 . crPos
|
|
return $
|
|
(createItemYou it (foldr (destroyInvItem 0 . NInt) w (sort is)))
|
|
& soundStart InventorySound p wrench1S Nothing
|
|
& hud . diSelection . _Just . slSet .~ mempty
|
|
|
|
maybeExitCombine :: World -> World
|
|
maybeExitCombine w
|
|
| ButtonRight `M.member` (w ^. input . mouseButtons) = w
|
|
| otherwise = w & hud . subInventory .~ NoSubInventory
|