Continue selection refactor
This commit is contained in:
@@ -3,7 +3,7 @@ module Dodge.Update.Input.InGame (
|
||||
updateMouseInGame,
|
||||
) where
|
||||
|
||||
import Data.Foldable
|
||||
import qualified Data.IntSet as IS
|
||||
import Dodge.ListDisplayParams
|
||||
import Control.Applicative
|
||||
import Control.Monad
|
||||
@@ -102,9 +102,9 @@ updateMouseHeldInGame cfig w = case w ^. input . mouseContext of
|
||||
OverInvDrag {} -> fromMaybe w $ do
|
||||
sss <- w ^? hud . hudElement . diSections
|
||||
let mpos = w ^. input . mousePos
|
||||
sel <- w ^? hud . hudElement . diSelection . _Just
|
||||
(0,i) <- w ^? hud . hudElement . diSelection . _Just
|
||||
x <- w ^? hud . hudElement . diSelectionExtra
|
||||
return $ w & shiftInvItems sel x cfig mpos ldp sss
|
||||
return $ w & dragInvItems (IS.insert i x) cfig mpos ldp sss
|
||||
_ -> w
|
||||
where
|
||||
ldp = invDisplayParams w
|
||||
@@ -113,8 +113,8 @@ dropSelected :: World -> World
|
||||
dropSelected w = fromMaybe w $ do
|
||||
cr <- w ^? cWorld . lWorld . creatures . ix 0
|
||||
(0,j) <- w ^? hud . hudElement . diSelection . _Just
|
||||
x <- w ^? hud . hudElement . diSelectionExtra
|
||||
return $ foldl' (flip $ dropItem cr) w (reverse [j .. j+x])
|
||||
xs <- w ^? hud . hudElement . diSelectionExtra
|
||||
return $ IS.foldr (dropItem cr) w (IS.insert j xs)
|
||||
|
||||
updateMouseReleaseInGame :: World -> World
|
||||
updateMouseReleaseInGame w = case w ^. input . mouseContext of
|
||||
@@ -126,7 +126,7 @@ updateMouseReleaseInGame w = case w ^. input . mouseContext of
|
||||
OverInvDragSelect ssel (Just esel) ->
|
||||
w & input . mouseContext .~ MouseInGame
|
||||
& hud . hudElement . diSelectionExtra
|
||||
.~ (max (snd ssel) (snd esel) - min (snd ssel) (snd esel))
|
||||
.~ IS.fromAscList [min (snd ssel) (snd esel) + 1 .. max (snd ssel) (snd esel)]
|
||||
& augInvDirectSelect (min ssel esel)
|
||||
_ -> w
|
||||
|
||||
@@ -177,44 +177,76 @@ updateMouseClickInGame cfig w = case w ^. input . mouseContext of
|
||||
startDrag :: (Int, Int) -> World -> World
|
||||
startDrag (a, b) w = case w ^? hud . hudElement . diInvFilter . _Just of
|
||||
Just {} -> w & input . mouseContext .~ OverInvFiltDrag
|
||||
_ -> fromMaybe (augInvDirectSelect (a, b) $ setmichosen 0 w) $ do
|
||||
_ -> fromMaybe (augInvDirectSelect (a, b) $ setmichosen mempty w) $ do
|
||||
(i, j) <- w ^? hud . hudElement . diSelection . _Just
|
||||
x <- w ^? hud . hudElement . diSelectionExtra
|
||||
guard $ i == a && b >= j && b <= j + x
|
||||
return $ setmichosen x w
|
||||
xs <- w ^? hud . hudElement . diSelectionExtra
|
||||
guard $ i == a && b `IS.member` (IS.insert j xs)
|
||||
return $ setmichosen xs w
|
||||
where
|
||||
setmichosen x =
|
||||
(input . mouseContext .~ OverInvDrag (Just b))
|
||||
. (hud . hudElement . diSelectionExtra .~ x)
|
||||
|
||||
shiftInvItems ::
|
||||
(Int, Int) ->
|
||||
Int ->
|
||||
dragInvItems ::
|
||||
IS.IntSet ->
|
||||
Configuration ->
|
||||
Point2 ->
|
||||
ListDisplayParams ->
|
||||
IM.IntMap (SelectionSection a) ->
|
||||
World ->
|
||||
World
|
||||
shiftInvItems topsel x cfig mpos ldp sss w = case inverseSelBoundaryUp cfig ldp sss mpos of
|
||||
Just p | p < topsel -> shiftInvItemsUp topsel x w
|
||||
dragInvItems is cfig mpos ldp sss w
|
||||
| nonconcurrent = collectInvItems is w
|
||||
| otherwise = shiftInvItems is cfig mpos ldp sss w
|
||||
where
|
||||
nonconcurrent = not $ concurrentIS is
|
||||
|
||||
concurrentIS :: IS.IntSet -> Bool
|
||||
concurrentIS = go . IS.minView
|
||||
where
|
||||
go Nothing = True
|
||||
go (Just (i,is)) = fromMaybe True $ do
|
||||
(j,js) <- IS.minView is
|
||||
return $ i + 1 == j && go (Just (j,js))
|
||||
|
||||
collectInvItems :: IS.IntSet -> World -> World
|
||||
collectInvItems is w = fromMaybe w $ do
|
||||
(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 ::
|
||||
IS.IntSet ->
|
||||
Configuration ->
|
||||
Point2 ->
|
||||
ListDisplayParams ->
|
||||
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
|
||||
_ -> case inverseSelBoundaryDown cfig ldp sss mpos of
|
||||
Just p | p > (topsel & _2 +~ x) -> shiftInvItemsDown topsel x w
|
||||
Just p | p > (0,IS.findMax xs) -> shiftInvItemsDown xs w
|
||||
_ -> w
|
||||
|
||||
shiftInvItemsUp :: (Int, Int) -> Int -> World -> World
|
||||
shiftInvItemsUp (_, i) x w = foldl' f w [i .. i + x]
|
||||
shiftInvItemsUp :: IS.IntSet -> World -> World
|
||||
shiftInvItemsUp is w = IS.foldl' f w is
|
||||
where
|
||||
f w' i' = swapInvItems g i' w'
|
||||
g i' m = fst <$> IM.lookupLT i' m
|
||||
|
||||
shiftInvItemsDown :: (Int, Int) -> Int -> World -> World
|
||||
shiftInvItemsDown (_, i) x w = fromMaybe w $ do
|
||||
shiftInvItemsDown :: IS.IntSet -> World -> World
|
||||
shiftInvItemsDown is w = fromMaybe w $ do
|
||||
let i = IS.findMax is
|
||||
guard . isJust $
|
||||
w ^? hud . hudElement . diSections . ix 0 . ssItems . ix (i + x + 1)
|
||||
return $ foldl' f w $ reverse [i .. i + x]
|
||||
w ^? hud . hudElement . diSections . ix 0 . ssItems . ix i
|
||||
return $ IS.foldr f w $ is
|
||||
where
|
||||
f w' i' = swapInvItems g i' w'
|
||||
f i' w' = swapInvItems g i' w'
|
||||
g i' m = fst <$> IM.lookupGT i' m
|
||||
|
||||
|
||||
@@ -430,9 +462,8 @@ toggleMap u = case u ^. uvWorld . hud . hudElement of
|
||||
{ _subInventory = NoSubInventory --MouseInvNothing
|
||||
, _diSections = defaultInvSections
|
||||
, _diSelection = Nothing
|
||||
, _diSelectionExtra = 0
|
||||
, -- , _diFilters = IM.fromList [(-1, mempty), (2, mempty)]
|
||||
_diInvFilter = mempty
|
||||
, _diSelectionExtra = mempty
|
||||
, _diInvFilter = mempty
|
||||
, _diCloseFilter = mempty
|
||||
}
|
||||
_ -> u & uvWorld . hud . hudElement .~ DisplayCarte
|
||||
|
||||
Reference in New Issue
Block a user