296 lines
9.6 KiB
Haskell
296 lines
9.6 KiB
Haskell
-- {-# LANGUAGE TupleSections #-}
|
|
module Dodge.Inventory (
|
|
rmInvItem,
|
|
destroyInvItem,
|
|
updateCloseObjects,
|
|
changeSwapSel,
|
|
invSetSelection,
|
|
invSetSelectionPos,
|
|
scrollAugInvSel,
|
|
setInvPosFromSS,
|
|
module Dodge.Inventory.RBList,
|
|
swapInvItems,
|
|
scrollAugNextInSection,
|
|
swapItemWith,
|
|
destroyAllInvItems,
|
|
multiSelScroll,
|
|
changeSwapSelSet,
|
|
concurrentIS,
|
|
collectInvItems,
|
|
shiftInvItemsUp,
|
|
shiftInvItemsDown,
|
|
closeItemDist,
|
|
) where
|
|
|
|
import Control.Monad
|
|
import Data.Function
|
|
import qualified Data.IntSet as IS
|
|
import Data.Maybe
|
|
import Dodge.Base
|
|
import Dodge.Data.SelectionList
|
|
import Dodge.Data.World
|
|
import Dodge.Euse
|
|
import Dodge.Inventory.Location
|
|
import Dodge.Inventory.RBList
|
|
import Dodge.Inventory.Swap
|
|
import Dodge.SelectionSections
|
|
import Geometry
|
|
import qualified IntMapHelp as IM
|
|
import LensHelp
|
|
import Linear
|
|
import ListHelp
|
|
import NewInt
|
|
|
|
-- TODO check what happens to selection index when dropping non-selected items
|
|
|
|
-- should consider never fully destroying items, but assigning a flag saying how
|
|
-- they were moved from play
|
|
destroyInvItem :: Int -> NewInt InvInt -> World -> World
|
|
destroyInvItem cid invid w = rmInvItem cid invid w & removeitloc & removeithotkey
|
|
where
|
|
removeitloc = fromMaybe id $ do
|
|
itid <- w ^? cWorld . lWorld . creatures . ix cid . crInv . ix invid
|
|
return $ cWorld . lWorld . items . at itid .~ Nothing
|
|
removeithotkey = fromMaybe id $ do
|
|
itid <- w ^? cWorld . lWorld . creatures . ix cid . crInv . ix invid
|
|
hk <- w ^? cWorld . lWorld . imHotkeys . unNIntMap . ix itid
|
|
return $
|
|
(cWorld . lWorld . imHotkeys . unNIntMap . at itid .~ Nothing)
|
|
. (cWorld . lWorld . hotkeys . at hk .~ Nothing)
|
|
|
|
destroyAllInvItems :: Creature -> World -> World
|
|
destroyAllInvItems cr w =
|
|
foldl' (flip $ destroyInvItem (cr ^. crID)) w
|
|
. reverse
|
|
. fmap NInt
|
|
. IM.keys
|
|
. _unNIntMap
|
|
$ cr ^. crInv
|
|
|
|
-- note rmInvItem does not fully destroy the item, other updates to the item
|
|
-- location are required
|
|
-- note if this gets called ssInvPosFromSS might be necessary elsewhere
|
|
rmInvItem :: Int -> NewInt InvInt -> World -> World
|
|
rmInvItem cid invid w =
|
|
w
|
|
& dounequipfunction -- the ordering of these is
|
|
& pointcid . crInv %~ f -- important
|
|
& removeAnySlotEquipment
|
|
& cWorld . lWorld . items . ix itid . itLocation . ilEquipSite .~ Nothing
|
|
& updateselection
|
|
& worldEventFlags . at InventoryChange ?~ ()
|
|
where
|
|
pointcid = cWorld . lWorld . creatures . ix cid
|
|
updateselection
|
|
| cid == 0 && (w ^? hud .diSelection._Just) == Just (Sel 0 (invid^.unNInt)) =
|
|
scrollAugInvSel (-1) . scrollAugInvSel 1
|
|
| otherwise = id
|
|
cr = w ^?! cWorld . lWorld . creatures . ix cid
|
|
itid = cr ^?! crInv . ix invid
|
|
itm = w ^?! cWorld . lWorld . items . ix itid
|
|
dounequipfunction = effectOnRemove itm cr
|
|
removeAnySlotEquipment = fromMaybe id $ do
|
|
epos <- itm ^? itLocation . ilEquipSite . _Just
|
|
return $ pointcid . crEquipment . at epos .~ Nothing
|
|
f inv =
|
|
let (xs, ys) = IM.split (_unNInt invid) $ _unNIntMap inv
|
|
in NIntMap $ xs `IM.union` IM.mapKeysMonotonic (subtract 1) ys
|
|
|
|
updateCloseObjects :: World -> World
|
|
updateCloseObjects w =
|
|
w
|
|
& hud . closeItems %~ h citems
|
|
& hud . closeButtons %~ h cbts
|
|
where
|
|
h a b = intersect b a `union` a
|
|
lw = w ^. cWorld . lWorld
|
|
citems =
|
|
map NInt $
|
|
IM.keys $
|
|
IM.intersection (lw ^. items) $
|
|
IM.filter (isclose . _flItPos) (lw ^. floorItems)
|
|
cbts = lw ^.. buttons . each . filtered canpress . filtered (isclose . _btPos) . to _btID
|
|
canpress bt = case bt ^. btEvent of
|
|
ButtonPress{_btOn = t} -> not t
|
|
ButtonAccessTerminal tid -> fromMaybe False $ do
|
|
x <- lw ^? terminals . ix tid . tmStatus
|
|
return (x /= TerminalDeactivated)
|
|
_ -> True
|
|
isclose x = dist y x < closeItemDist && hasButtonLOS y x w
|
|
y = you w ^. crPos . _xy
|
|
|
|
closeItemDist :: Float
|
|
closeItemDist = 30
|
|
|
|
changeSwapSelSet :: Int -> World -> World
|
|
changeSwapSelSet yi w
|
|
| yi >= 0 = foldl' (&) w $ replicate yi (swapSelSet shiftSetUp)
|
|
| otherwise = foldl' (&) w $ replicate (negate yi) (swapSelSet shiftSetDown)
|
|
|
|
swapSelSet :: (Int -> IS.IntSet -> World -> World) -> World -> World
|
|
swapSelSet f w = fromMaybe w $ do
|
|
Sel j i <- w ^. hud . diSelection
|
|
is' <- w ^? hud . diSections . ix j . ssSet
|
|
let is = if IS.null is'
|
|
then IS.singleton i
|
|
else is'
|
|
return $
|
|
if concurrentIS is
|
|
then f j is w
|
|
else collectInvItems j is w
|
|
|
|
shiftSetUp :: Int -> IS.IntSet -> World -> World
|
|
shiftSetUp j is w = fromMaybe w $ do
|
|
(mini, _) <- IS.minView is
|
|
guard (mini > 0)
|
|
return $ shiftInvItemsUp j is w
|
|
|
|
shiftSetDown :: Int -> IS.IntSet -> World -> World
|
|
shiftSetDown j is w = fromMaybe w $ do
|
|
(maxi, _) <- IS.maxView is
|
|
(maxinv, _) <- IM.lookupMax =<< (w ^? hud . diSections . ix j . ssItems)
|
|
guard (maxi < maxinv)
|
|
return $ shiftInvItemsDown j is w
|
|
|
|
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' = swapItemWith g (j, i')
|
|
g i' m = fst <$> IM.lookupGT i' m
|
|
|
|
|
|
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
|
|
|
|
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 || secid == 3
|
|
(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'
|
|
return . h (j + 1) ks $ swapItemWith (\_ _ -> Just (j + 1)) (secid,k) w'
|
|
|
|
changeSwapSel :: Int -> World -> World
|
|
changeSwapSel yi w
|
|
| yi >= 0 = foldl' (&) w $ replicate yi (changeSwapWith $ f IM.cycleLT)
|
|
| otherwise = foldl' (&) w $ replicate (negate yi) (changeSwapWith $ f IM.cycleGT)
|
|
where
|
|
f g i m = fst <$> g i m
|
|
|
|
multiSelScroll :: Int -> World -> World
|
|
multiSelScroll yi w
|
|
| yi >= 0 = foldl' (&) w $ replicate yi (multiSelScroll' $ f IM.lookupLT)
|
|
| otherwise = foldl' (&) w $ replicate (negate yi) (multiSelScroll' $ f IM.lookupGT)
|
|
where
|
|
f g i m = fst <$> g i m
|
|
|
|
multiSelScroll' :: (Int -> IM.IntMap (SelectionItem ()) -> Maybe Int) -> World -> World
|
|
multiSelScroll' f w = fromMaybe w $ do
|
|
--Sel j i is <- w ^. hud . diSelection
|
|
Sel j i <- w ^. hud . diSelection
|
|
is <- w ^? hud . diSections . ix j . ssSet
|
|
ss <- w ^? hud . diSections . ix j . ssItems
|
|
k <- f i ss
|
|
let insertordelete
|
|
| not (i `IS.member` is) && k `IS.member` is = IS.delete k
|
|
| k `IS.member` is = IS.delete i
|
|
| otherwise = IS.insert i . IS.insert k
|
|
return $
|
|
w
|
|
-- & hud . diSelection . _Just . slSet %~ insertordelete
|
|
& hud . diSections . ix j . ssSet %~ insertordelete
|
|
& hud . diSelection . _Just . slInt .~ k
|
|
|
|
changeSwapOther ::
|
|
Int ->
|
|
(Int -> IM.IntMap (SelectionItem ()) -> Maybe Int) ->
|
|
Int ->
|
|
World ->
|
|
World
|
|
changeSwapOther n f i w = fromMaybe w $ do
|
|
ss <- w ^? hud . diSections . ix n . ssItems
|
|
k <- f i ss
|
|
let doswap j
|
|
| j == i = k
|
|
| j == k = i
|
|
| otherwise = j
|
|
return $
|
|
w
|
|
& hud . diSections . ix 3 . ssSet %~ swapInIntSet i k
|
|
& hud . closeItems %~ swapIndices i k
|
|
& hud . diSelection . _Just . slInt %~ doswap
|
|
& worldEventFlags . at InventoryChange ?~ ()
|
|
|
|
swapItemWith ::
|
|
(Int -> IM.IntMap (SelectionItem ()) -> Maybe Int) ->
|
|
(Int, Int) ->
|
|
World ->
|
|
World
|
|
swapItemWith f (j, i) = case j of
|
|
0 -> swapInvItems f i
|
|
3 -> changeSwapOther 3 f i
|
|
5 -> changeSwapOther 5 f i
|
|
_ -> id
|
|
|
|
changeSwapWith :: (Int -> IM.IntMap (SelectionItem ()) -> Maybe Int) -> World -> World
|
|
changeSwapWith f w
|
|
| Just (Sel j i) <- w ^. hud . diSelection = swapItemWith f (j, i) w
|
|
| otherwise = w
|
|
|
|
invSetSelection :: Selection -> World -> World
|
|
invSetSelection sel w =
|
|
w
|
|
& hud . diSelection ?~ sel
|
|
& worldEventFlags . at InventoryChange ?~ ()
|
|
-- & crUpdateItemLocations
|
|
& setInvPosFromSS -- is this necessary here?
|
|
& crUpdateItemLocations
|
|
|
|
invSetSelectionPos :: Int -> Int -> World -> World
|
|
invSetSelectionPos i j = invSetSelection (Sel i j)
|
|
|
|
scrollAugInvSel :: Int -> World -> World
|
|
scrollAugInvSel yi w
|
|
| yi == 0 = w
|
|
| otherwise =
|
|
w
|
|
& hud %~ doscroll
|
|
& worldEventFlags . at InventoryChange ?~ ()
|
|
& crUpdateItemLocations
|
|
& setInvPosFromSS
|
|
& crUpdateItemLocations
|
|
where
|
|
doscroll he = fromMaybe he $ do
|
|
sss <- he ^? diSections
|
|
return $ he & diSelection %~ scrollSelectionSections yi sss
|
|
|
|
scrollAugNextInSection :: World -> World
|
|
scrollAugNextInSection w =
|
|
w
|
|
& hud %~ doscroll
|
|
& worldEventFlags . at InventoryChange ?~ ()
|
|
& crUpdateItemLocations
|
|
& setInvPosFromSS
|
|
& crUpdateItemLocations
|
|
where
|
|
doscroll he = fromMaybe he $ do
|
|
sss <- he ^? diSections
|
|
return $ he & diSelection %~ nextInSectionSS sss
|