justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Continue selection refactor

Browse Source
This commit is contained in:
justin
2024-11-20 16:15:51 +00:00
parent 3ecf137801
commit 1f5d034c5f
9 changed files with 159 additions and 114 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data/HUD.hs
+2 -1
View File
@@ -5,6 +5,7 @@
module Dodge.Data.HUD where
import Data.IntSet (IntSet)
import Data.IntMap
import Control.Lens
import Dodge.Data.Button
@@ -20,7 +21,7 @@ data HUDElement
, _diSelection :: Maybe (Int, Int)
, _diInvFilter :: Maybe String
, _diCloseFilter :: Maybe String
, _diSelectionExtra :: Int
, _diSelectionExtra :: IntSet
}
| DisplayCarte
src/Dodge/Default/World.hs
+1 -1
View File
@@ -167,7 +167,7 @@ defaultDisplayInventory =
-- }
, _diSections = defaultInvSections
, _diSelection = Just (1,0)
, _diSelectionExtra = 0
, _diSelectionExtra = mempty
, _diInvFilter = mempty
, _diCloseFilter = mempty
}
src/Dodge/Inventory.hs
+11 -2
View File
@@ -17,6 +17,7 @@ module Dodge.Inventory (
isFilteringInv,
) where
import qualified Data.IntSet as IS
import Control.Monad
import Dodge.Item.Grammar
import Dodge.Data.DoubleTree
@@ -88,7 +89,7 @@ rmInvItem cid invid w =
-- & updateCreatureItemLocations cid
pointcid = cWorld . lWorld . creatures . ix cid
updateselectionextra | cid == 0 = hud . hudElement . diSelectionExtra .~ 0
updateselectionextra | cid == 0 = hud . hudElement . diSelectionExtra .~ mempty
| otherwise = id
updateselection
| cid == 0 && cr ^? crManipulation . manObject . imSelectedItem == Just invid =
@@ -194,7 +195,7 @@ swapInvItems f i w = fromMaybe w $ do
_ -> id
return $
w
-- & checkconnect k InventorySound disconnectItemS
& swapAnyExtraSelection i k
& checkConnection InventorySound disconnectItemS i k
& cWorld . lWorld . creatures . ix 0 %~ updatecreature k
& updateselection
@@ -230,6 +231,14 @@ swapInvItems f i w = fromMaybe w $ do
Just epos -> crHotkeys . ix epos .~ b
Nothing -> id
swapAnyExtraSelection :: Int -> Int -> World -> World
swapAnyExtraSelection i k w = fromMaybe w $ do
is <- w ^? hud . hudElement . diSelectionExtra
let f = if i `IS.member` is then IS.insert k else id
g = if k `IS.member` is then IS.insert i else id
return $ w & hud . hudElement . diSelectionExtra
%~ (f . g . IS.delete i . IS.delete k)
checkConnection :: SoundOrigin -> SoundID -> Int -> Int -> World -> World
checkConnection so s i j w = fromMaybe w $ do
inv <- w ^? cWorld . lWorld . creatures . ix 0 . crInv
src/Dodge/Inventory/Add.hs
+1 -1
View File
@@ -46,7 +46,7 @@ tryPutItemInInv cid flit w = case maybeInvSlot of
& cWorld . lWorld %~ crUpdateItemLocations cid
)
where
updateselectionextra | cid == 0 = hud . hudElement . diSelectionExtra .~ 0
updateselectionextra | cid == 0 = hud . hudElement . diSelectionExtra .~ mempty
| otherwise = id
it = _flIt flit
maybeInvSlot = checkInvSlotsYou it w
src/Dodge/Render/HUD.hs
+5 -4
View File
@@ -4,6 +4,7 @@ module Dodge.Render.HUD (
drawHUD,
) where
import qualified Data.IntSet as IS
import Control.Applicative
import Control.Lens
import Control.Monad
@@ -146,15 +147,15 @@ drawMouseOver cfig w = concat (invsel <|> combinvsel
drawDragSelected :: Configuration -> World -> Maybe Picture
drawDragSelected cfig w = do
y <- w ^? hud . hudElement . diSelectionExtra
guard $ y > 0
ys <- w ^? hud . hudElement . diSelectionExtra
guard $ not (IS.null ys)
(i,j) <- w ^? hud . hudElement . diSelection . _Just
guard $ i == 0
sss <- w ^? hud . hudElement . diSections
let idp = invDisplayParams w
let f x = selSecDrawCursorAt 15 idp BackdropCursor sss (0, x)
let f x = (selSecDrawCursorAt 15 idp BackdropCursor sss (0, x) <>)
return . translateScreenPos cfig (invDisplayParams w ^. ldpPos)
. color (withAlpha 0.2 white) . foldMap f $ [j .. j + y]
. color (withAlpha 0.2 white) . IS.foldr f mempty $ IS.insert j ys
drawDragSelect :: Configuration -> World -> Maybe Picture
drawDragSelect cfig w = do
src/Dodge/Update/Input/InGame.hs
+57 -26
View File
@@ -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
src/Dodge/Update/Scroll.hs
+2 -2
View File
@@ -33,8 +33,8 @@ updateWheelEvent yi w = case w ^. hud . hudElement of
EquipOptions{} -> w & rbOptions . opSel %~ scrollRBOption yi rbscrollmax
NoRightButtonOptions -> w
| bdown ButtonLeft -> w & wCam . camZoom +~ y
| invKeyDown -> changeSwapSel yi $ w & hud . hudElement . diSelectionExtra .~ 0
| otherwise -> scrollAugInvSel yi $ w & hud . hudElement . diSelectionExtra .~ 0
| invKeyDown -> changeSwapSel yi $ w & hud . hudElement . diSelectionExtra .~ mempty
| otherwise -> scrollAugInvSel yi $ w & hud . hudElement . diSelectionExtra .~ mempty
DisplayInventory{_subInventory = ExamineInventory}
| invKeyDown -> scrollAugInvSel yi w
| otherwise -> w