Continue improving mouse|inventory interface
This commit is contained in:
@@ -3,9 +3,9 @@ module Dodge.Update.Input.InGame (
|
||||
updateMouseInGame,
|
||||
) where
|
||||
|
||||
import Data.Foldable
|
||||
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)
|
||||
@@ -95,17 +95,19 @@ updateMouseInGame cfig w = case w ^? input . mouseButtons . ix ButtonLeft of
|
||||
|
||||
updateMouseHeldInGame :: Configuration -> World -> World
|
||||
updateMouseHeldInGame cfig w = case w ^. input . mouseContext of
|
||||
OverInvDragSelect{} -> fromMaybe w $ do
|
||||
OverInvDragSelect sstart _ -> fromMaybe w $ do
|
||||
sss <- w ^? hud . hudElement . diSections
|
||||
let msel = inverseSelNumPos cfig ldp sss (w ^. input . mousePos)
|
||||
guard $ Just (fst sstart) == fmap fst msel || isNothing msel
|
||||
return $ w & input . mouseContext . mcoSelEnd .~ msel
|
||||
OverInvDrag Nothing -> w
|
||||
OverInvDrag{} -> fromMaybe w $ do
|
||||
OverInvDrag k mmouseover -> fromMaybe w $ do
|
||||
sss <- w ^? hud . hudElement . diSections
|
||||
_ <- mmouseover
|
||||
let mpos = w ^. input . mousePos
|
||||
(0, i) <- w ^? hud . hudElement . diSelection . _Just
|
||||
(j, i) <- w ^? hud . hudElement . diSelection . _Just
|
||||
guard $ j == k -- this should always be the case?
|
||||
x <- w ^? hud . hudElement . diSelectionExtra
|
||||
return $ w & dragInvItems (IS.insert i x) cfig mpos ldp sss
|
||||
return $ w & dragInvItems k (IS.insert i x) cfig mpos ldp sss
|
||||
_ -> w
|
||||
where
|
||||
ldp = invDisplayParams w
|
||||
@@ -119,23 +121,24 @@ dropSelected w = fromMaybe w $ do
|
||||
|
||||
updateMouseReleaseInGame :: World -> World
|
||||
updateMouseReleaseInGame w = case w ^. input . mouseContext of
|
||||
OverInvDrag mpos -> fromMaybe (dropSelected w & input . mouseContext .~ MouseInGame) $ do
|
||||
OverInvDrag i mpos -> fromMaybe (dropSelected w & input . mouseContext .~ MouseInGame) $ do
|
||||
j <- mpos
|
||||
return $ w & input . mouseContext .~ OverInvSelect (0, j)
|
||||
guard $ fst j == i
|
||||
return $ w & input . mouseContext .~ OverInvSelect j
|
||||
OverInvDragSelect _ Nothing ->
|
||||
w & input . mouseContext .~ MouseInGame
|
||||
& hud . hudElement . diSelectionExtra .~ mempty
|
||||
OverInvDragSelect ssel (Just esel) ->
|
||||
w & input . mouseContext .~ MouseInGame
|
||||
& hud . hudElement . diSelectionExtra
|
||||
.~ h (snd ssel) (snd esel)-- IM.keysSet [min (snd ssel) (snd esel) + 1 .. max (snd ssel) (snd esel)]
|
||||
.~ h (snd ssel) (snd esel) -- IM.keysSet [min (snd ssel) (snd esel) + 1 .. max (snd ssel) (snd esel)]
|
||||
& augInvDirectSelect (min ssel esel)
|
||||
_ -> w
|
||||
where
|
||||
h i j = fold $ do
|
||||
sss <- w ^? hud . hudElement . diSections . ix 0 . ssItems
|
||||
let (_,xss) = IM.split ((min i j)-1) sss
|
||||
(yss,_) = IM.split ((max i j)+1) xss
|
||||
let (_, xss) = IM.split (min i j -1) sss
|
||||
(yss, _) = IM.split (max i j + 1) xss
|
||||
return . IM.keysSet $ yss
|
||||
|
||||
updateMouseClickInGame :: Configuration -> World -> World
|
||||
@@ -189,14 +192,15 @@ startDrag :: (Int, Int) -> World -> World
|
||||
startDrag (a, b) w = fromMaybe (augInvDirectSelect (a, b) $ setmichosen mempty w) $ do
|
||||
(i, j) <- w ^? hud . hudElement . diSelection . _Just
|
||||
xs <- w ^? hud . hudElement . diSelectionExtra
|
||||
guard $ i == a && b `IS.member` (IS.insert j xs)
|
||||
guard $ i == a && b `IS.member` IS.insert j xs
|
||||
return $ setmichosen xs w
|
||||
where
|
||||
setmichosen x =
|
||||
(input . mouseContext .~ OverInvDrag (Just b))
|
||||
(input . mouseContext .~ OverInvDrag a (Just (a, b)))
|
||||
. (hud . hudElement . diSelectionExtra .~ x)
|
||||
|
||||
dragInvItems ::
|
||||
Int ->
|
||||
IS.IntSet ->
|
||||
Configuration ->
|
||||
Point2 ->
|
||||
@@ -204,9 +208,9 @@ dragInvItems ::
|
||||
IM.IntMap (SelectionSection a) ->
|
||||
World ->
|
||||
World
|
||||
dragInvItems is cfig mpos ldp sss w
|
||||
dragInvItems j is cfig mpos ldp sss w
|
||||
| nonconcurrent = collectInvItems is w
|
||||
| otherwise = shiftInvItems is cfig mpos ldp sss w
|
||||
| otherwise = shiftInvItems j is cfig mpos ldp sss w
|
||||
where
|
||||
nonconcurrent = not $ concurrentIS is
|
||||
|
||||
@@ -228,6 +232,7 @@ collectInvItems is w = fromMaybe w $ do
|
||||
return . h (j + 1) ks $ swapInvItems (\_ _ -> Just (j + 1)) k w'
|
||||
|
||||
shiftInvItems ::
|
||||
Int ->
|
||||
IS.IntSet ->
|
||||
Configuration ->
|
||||
Point2 ->
|
||||
@@ -235,26 +240,34 @@ shiftInvItems ::
|
||||
IM.IntMap (SelectionSection a) ->
|
||||
World ->
|
||||
World
|
||||
shiftInvItems xs cfig mpos ldp sss w = case inverseSelBoundaryUp cfig ldp sss mpos of
|
||||
Just p | p < (0, IS.findMin xs) -> shiftInvItemsUp xs w
|
||||
shiftInvItems j xs cfig mpos ldp sss w = case inverseSelBoundaryUp cfig ldp sss mpos of
|
||||
Just p | p < (j, IS.findMin xs) -> fromMaybe w $ do
|
||||
ss <- sss ^? ix j . ssItems
|
||||
minsss <- IM.lookupMin ss
|
||||
guard (IS.findMin xs > fst minsss)
|
||||
return $ shiftInvItemsUp j xs w
|
||||
_ -> case inverseSelBoundaryDown cfig ldp sss mpos of
|
||||
Just p | p > (0, IS.findMax xs) -> shiftInvItemsDown xs w
|
||||
Just p | p > (j, IS.findMax xs) -> fromMaybe w $ do
|
||||
ss <- sss ^? ix j . ssItems
|
||||
maxsss <- IM.lookupMax ss
|
||||
guard (IS.findMax xs < fst maxsss)
|
||||
return $ shiftInvItemsDown j xs w
|
||||
_ -> w
|
||||
|
||||
shiftInvItemsUp :: IS.IntSet -> World -> World
|
||||
shiftInvItemsUp is w = IS.foldl' f w is
|
||||
shiftInvItemsUp :: Int -> IS.IntSet -> World -> World
|
||||
shiftInvItemsUp j is w = IS.foldl' f w is
|
||||
where
|
||||
f w' i' = swapInvItems g i' w'
|
||||
f w' i' = swapItemWith g (j, i') w'
|
||||
g i' m = fst <$> IM.lookupLT i' m
|
||||
|
||||
shiftInvItemsDown :: IS.IntSet -> World -> World
|
||||
shiftInvItemsDown is w = fromMaybe w $ do
|
||||
shiftInvItemsDown :: Int -> IS.IntSet -> World -> World
|
||||
shiftInvItemsDown j is w = fromMaybe w $ do
|
||||
let i = IS.findMax is
|
||||
guard . isJust $
|
||||
w ^? hud . hudElement . diSections . ix 0 . ssItems . ix i
|
||||
return $ IS.foldr f w $ is
|
||||
w ^? hud . hudElement . diSections . ix j . ssItems . ix i
|
||||
return $ IS.foldr f w is
|
||||
where
|
||||
f i' w' = swapInvItems g i' w'
|
||||
f i' w' = swapItemWith g (j, i') w'
|
||||
g i' m = fst <$> IM.lookupGT i' m
|
||||
|
||||
updateFunctionKeys :: Universe -> Universe
|
||||
@@ -301,13 +314,14 @@ updatePressedButtonsCarte' pkeys w
|
||||
|
||||
updateKeysInTerminal :: Int -> Universe -> Universe
|
||||
updateKeysInTerminal tmid u =
|
||||
u & doTextInputOverUniverse (uvWorld . cWorld . lWorld . terminals . ix tmid . tmInput . tiText)
|
||||
u
|
||||
& doTextInputOverUniverse
|
||||
(uvWorld . cWorld . lWorld . terminals . ix tmid . tmInput . tiText)
|
||||
& checkEndStatus
|
||||
where
|
||||
pkeys = u ^. uvWorld . input . pressedKeys
|
||||
checkEndStatus
|
||||
| pkeys ^. at ScancodeReturn == Just InitialPress =
|
||||
over uvWorld (\w -> terminalReturnEffect tmid w)
|
||||
| u ^. uvWorld . input . pressedKeys . at ScancodeReturn == Just InitialPress =
|
||||
uvWorld %~ terminalReturnEffect tmid
|
||||
| otherwise = id
|
||||
|
||||
updateKeyInGame :: Universe -> Scancode -> PressType -> Universe
|
||||
|
||||
Reference in New Issue
Block a user