374 lines
14 KiB
Haskell
374 lines
14 KiB
Haskell
{-# LANGUAGE TupleSections #-}
|
|
|
|
module Dodge.Inventory (
|
|
selSecSelPos,
|
|
checkInvSlotsYou,
|
|
rmSelectedInvItem,
|
|
selNumPos,
|
|
selNumTextEndPos,
|
|
selSecSelCol,
|
|
selNumEndMidHeight,
|
|
rmInvItem,
|
|
updateCloseObjects,
|
|
updateRBList,
|
|
updateTerminal,
|
|
closeObjScrollDir,
|
|
changeSwapInvSel,
|
|
scrollAugInvSel,
|
|
crNumFreeSlots,
|
|
crInvSize,
|
|
selectedCloseObject,
|
|
invDimColor,
|
|
setInvPosFromSS,
|
|
) where
|
|
|
|
import Dodge.SelectionSections
|
|
import Control.Applicative
|
|
import Dodge.Data.SelectionList
|
|
import Color
|
|
import qualified Data.Map.Strict as M
|
|
import Data.Maybe
|
|
import Dodge.Base
|
|
import Dodge.Data.Config
|
|
import Dodge.Data.World
|
|
import Dodge.Euse
|
|
import Dodge.Inventory.CheckSlots
|
|
import Dodge.Inventory.CloseObject
|
|
import Dodge.Inventory.Color
|
|
import Dodge.ItEffect
|
|
import Dodge.Reloading
|
|
import Geometry
|
|
import qualified IntMapHelp as IM
|
|
import LensHelp
|
|
import ListHelp
|
|
import Padding
|
|
|
|
-- | after this the item at the inventory position will no longer exist
|
|
rmInvItem ::
|
|
-- | Creature id
|
|
Int ->
|
|
-- | Inventory position
|
|
Int ->
|
|
World ->
|
|
World
|
|
rmInvItem cid invid w = case w ^? getcid . crInv . ix invid . itUse . useAmount of
|
|
Just x | x > 1 -> w & pointcid . crInv . ix invid . itUse . useAmount -~ 1
|
|
_ ->
|
|
w
|
|
& pointcid . crInv %~ f
|
|
& pointcid %~ crCancelReloading
|
|
& pointcid . crLeftInvSel . lisMPos %~ g'
|
|
& removeAnySlotEquipment
|
|
& dounequipfunction
|
|
& doanyitemeffect
|
|
& pointcid . crInvEquipped %~ IM.delete invid
|
|
& pointcid . crInvEquipped %~ IM.mapKeys g
|
|
& updateselection
|
|
where
|
|
|
|
getcid = cWorld . lWorld . creatures . ix cid
|
|
pointcid = cWorld . lWorld . creatures . ix cid
|
|
|
|
updateselection
|
|
| cid == 0 && cr ^? crManipulation . manObject . inInventory . ispItem == Just invid
|
|
= scrollAugInvSel (-1) . scrollAugInvSel 1
|
|
| otherwise
|
|
= pointcid . crManipulation . manObject . inInventory . ispItem %~ g
|
|
|
|
cr = w ^?! cWorld . lWorld . creatures . ix cid
|
|
itm = _crInv cr IM.! invid
|
|
dounequipfunction = fromMaybe id $ do
|
|
rmf <- itm ^? itUse . equipEffect . eeOnRemove
|
|
return $ useE rmf itm cr
|
|
doanyitemeffect = fromMaybe id $ do
|
|
rmf <- itm ^? itEffect . ieOnDrop
|
|
return $ doInvEffect rmf itm cr
|
|
removeAnySlotEquipment = case w ^? cWorld . lWorld . creatures . ix cid . crInvEquipped . ix invid of
|
|
Just epos -> pointcid . crEquipment . at epos .~ Nothing
|
|
Nothing -> id
|
|
maxk = fmap fst $ IM.lookupMax $ cr ^. crInv
|
|
f inv =
|
|
let (xs, ys) = IM.split invid inv
|
|
in xs `IM.union` IM.mapKeysMonotonic (subtract 1) ys
|
|
-- the following might not work if a non-player creature drops their last item
|
|
g x
|
|
| x > invid || Just x == maxk = max 0 $ x - 1
|
|
| otherwise = x
|
|
g' Nothing = Nothing
|
|
g' (Just x)
|
|
| x == invid = Nothing
|
|
| x > invid || Just x == maxk = Just $ max 0 $ x - 1
|
|
| otherwise = Just x
|
|
|
|
rmSelectedInvItem :: Int -> World -> World
|
|
rmSelectedInvItem cid w = case w ^? cWorld . lWorld . creatures . ix cid . crManipulation . manObject . inInventory . ispItem of
|
|
Just i -> rmInvItem cid i w
|
|
Nothing -> w
|
|
|
|
selNumPos :: ManipulatedObject -> World -> Maybe Int
|
|
selNumPos mo w = w ^? hud . hudElement . diSections >>=
|
|
case mo of
|
|
InInventory SortInventory -> selSecSelPos (-1) 0
|
|
InInventory (SelItem i _) -> selSecSelPos 0 i
|
|
SelNothing -> selSecSelPos 1 0
|
|
InNearby SortNearby -> selSecSelPos 2 0
|
|
InNearby (SelCloseObject i) -> selSecSelPos 3 i
|
|
|
|
-- there are still more ListDisplayParams to integrate here
|
|
selNumTextEndPos :: Configuration -> ListDisplayParams -> SelectionSections a -> Int -> Int -> Maybe Point2
|
|
selNumTextEndPos cfig ldp sss i j = do
|
|
ipos <- selSecSelPos i j sss
|
|
return $ V2 (150 - hw) (hh - ((s * 10 + ygap) * (fromIntegral ipos + 1)))
|
|
where
|
|
s = _ldpScale ldp
|
|
ygap = _ldpVerticalGap ldp
|
|
hh = halfHeight cfig
|
|
hw = halfWidth cfig
|
|
|
|
selNumEndMidHeight :: Configuration -> ListDisplayParams -> SelectionSections a -> Int
|
|
-> Int -> Maybe Point2
|
|
selNumEndMidHeight cfig ldp sss i j = do
|
|
ipos <- selSecSelPos i j sss
|
|
size <- selSecSelSize i j sss
|
|
--let bump = negate $ (10 * s + ygap) * fromIntegral size
|
|
return $ V2 (150 - hw) (hh - ((10 * s + ygap) * (fromIntegral ipos + fromIntegral size * 0.5)))
|
|
where
|
|
s = _ldpScale ldp
|
|
ygap = _ldpVerticalGap ldp
|
|
hh = halfHeight cfig
|
|
hw = halfWidth cfig
|
|
|
|
selSecSelCol :: Int -> Int -> SelectionSections a -> Maybe Color
|
|
selSecSelCol i j sss = sss ^? sssSections . ix i . ssItems . ix j . siColor
|
|
|
|
updateTerminal :: World -> World
|
|
updateTerminal = checkTermDist
|
|
|
|
checkTermDist :: World -> World
|
|
checkTermDist w = case w ^? hud . hudElement . subInventory . termID of
|
|
Just tmid -> fromMaybe (w & hud . hudElement . subInventory .~ NoSubInventory) $ do
|
|
btid <- w ^? cWorld . lWorld . terminals . ix tmid . tmButtonID
|
|
btpos <- w ^? cWorld . lWorld . buttons . ix btid . btPos
|
|
if dist btpos (_crPos $ you w) < 40 then Just w else Nothing
|
|
Nothing -> w
|
|
|
|
-- this looks ugly...
|
|
updateCloseObjects :: World -> World
|
|
updateCloseObjects w =
|
|
w
|
|
& hud . closeObjects .~ newcloseobjects
|
|
& updatecursorposifnecessary
|
|
where
|
|
newcloseobjects = unionBy closeObjEq oldCloseFiltered currentClose
|
|
updatecursorposifnecessary
|
|
= case w ^? cWorld . lWorld . creatures . ix 0 . crManipulation . manObject. inNearby . ispCloseObject of
|
|
Just i
|
|
| i >= length newcloseobjects -> scrollAugInvSel 1
|
|
| isNothing (w ^? hud . hudElement . diSections . sssSections . ix 3 . ssItems . ix i)
|
|
-> scrollAugInvSel (-1)
|
|
_ -> id
|
|
filt = filter $ \obj -> dist ypos (closeObjPos obj) < 40 && hasButtonLOS ypos (closeObjPos obj) w
|
|
ypos = _crPos $ you w
|
|
activeButtons =
|
|
map Right
|
|
. filter ((/=) BtNoLabel . _btState)
|
|
. IM.elems
|
|
$ w ^. cWorld . lWorld . buttons
|
|
currentClose = filt $ map Left (IM.elems $ w ^. cWorld . lWorld . floorItems) ++ activeButtons
|
|
oldClose = filt $ mapMaybe updatebyid $ w ^. hud . closeObjects
|
|
oldCloseFiltered = intersectBy closeObjEq oldClose currentClose
|
|
updatebyid (Left flid) = fmap Left $ w ^? cWorld . lWorld . floorItems . ix (_flItID flid)
|
|
updatebyid (Right btid) = fmap Right $ w ^? cWorld . lWorld . buttons . ix (_btID btid)
|
|
|
|
updateRBList :: World -> World
|
|
updateRBList w
|
|
| w ^? rbOptions . opItemID == mcurrentitemid =
|
|
w & setEquipAllocation & setEquipActivation
|
|
| otherwise = fromMaybe (w & rbOptions .~ NoRightButtonOptions) $ do
|
|
i <- cr ^? crManipulation . manObject . inInventory . ispItem
|
|
esite <- cr ^? crInv . ix i . itUse . equipEffect . eeSite
|
|
itid <- mcurrentitemid
|
|
return $
|
|
w
|
|
& rbOptions
|
|
.~ EquipOptions
|
|
{ _opEquip = equipSiteToPositions esite
|
|
, _opSel = chooseEquipmentPosition cr (equipSiteToPositions esite)
|
|
, _opItemID = itid
|
|
, _opAllocateEquipment = DoNotMoveEquipment
|
|
, _opActivateEquipment = NoChangeActivateEquipment
|
|
}
|
|
& setEquipAllocation
|
|
& setEquipActivation
|
|
where
|
|
mcurrentitemid = do
|
|
i <- cr ^? crManipulation . manObject . inInventory . ispItem
|
|
cr ^? crInv . ix i . itID
|
|
--curinvid = crSel cr
|
|
cr = you w
|
|
|
|
chooseEquipmentPosition :: Creature -> [EquipPosition] -> Int
|
|
chooseEquipmentPosition cr eps = fromMaybe (chooseFreeSite cr eps) $ do
|
|
i <- cr ^? crManipulation . manObject . inInventory . ispItem
|
|
ep <- cr ^? crInvEquipped . ix i
|
|
elemIndex ep eps
|
|
|
|
chooseFreeSite :: Creature -> [EquipPosition] -> Int
|
|
chooseFreeSite cr = fromMaybe 0 . findIndex hasnoequipment
|
|
where
|
|
hasnoequipment ep = isNothing $ cr ^? crEquipment . ix ep
|
|
|
|
setEquipAllocation :: World -> World
|
|
setEquipAllocation w = fromMaybe w $ do
|
|
curpos <- you w ^? crManipulation . manObject . inInventory . ispItem
|
|
return $ case _rbOptions w of
|
|
EquipOptions{_opEquip = es, _opSel = i} ->
|
|
case you w ^? crInvEquipped . ix curpos of
|
|
Just epos
|
|
| es !! i == epos ->
|
|
w & rbOptions . opAllocateEquipment
|
|
.~ RemoveEquipment
|
|
{ _allocOldPos = epos
|
|
}
|
|
Just epos
|
|
| isJust (you w ^? crEquipment . ix (es !! i)) ->
|
|
w & rbOptions . opAllocateEquipment
|
|
.~ SwapEquipment
|
|
{ _allocOldPos = epos
|
|
, _allocNewPos = es !! i
|
|
, _allocSwapID = _crEquipment (you w) M.! (es !! i)
|
|
}
|
|
Just epos ->
|
|
w & rbOptions . opAllocateEquipment
|
|
.~ MoveEquipment
|
|
{ _allocOldPos = epos
|
|
, _allocNewPos = es !! i
|
|
}
|
|
Nothing
|
|
| isJust (you w ^? crEquipment . ix (es !! i)) ->
|
|
w & rbOptions . opAllocateEquipment
|
|
.~ ReplaceEquipment
|
|
{ _allocNewPos = es !! i
|
|
, _allocRemoveID = _crEquipment (you w) M.! (es !! i)
|
|
}
|
|
Nothing ->
|
|
w & rbOptions . opAllocateEquipment
|
|
.~ PutOnEquipment
|
|
{ _allocNewPos = es !! i
|
|
}
|
|
_ -> w
|
|
|
|
setEquipActivation :: World -> World
|
|
setEquipActivation w = case w ^? rbOptions . opAllocateEquipment of
|
|
Just DoNotMoveEquipment -> w
|
|
Just RemoveEquipment{} ->
|
|
case you w ^. crLeftInvSel . lisMPos of
|
|
Just i
|
|
| Just i == minvsel ->
|
|
w & rbOptions . opActivateEquipment
|
|
.~ DeactivateEquipment
|
|
{ _deactivateEquipment = i
|
|
}
|
|
_ -> w & rbOptions . opActivateEquipment .~ NoChangeActivateEquipment
|
|
Just rbos ->
|
|
case you w ^. crLeftInvSel . lisMPos of
|
|
Just i | Just i == minvsel -> w & rbOptions . opActivateEquipment .~ NoChangeActivateEquipment
|
|
Just i
|
|
| invselcanactivate ->
|
|
w & rbOptions . opActivateEquipment
|
|
.~ ActivateDeactivateEquipment
|
|
{ _activateEquipment = fromJust minvsel
|
|
, _deactivateEquipment = i
|
|
}
|
|
Just i
|
|
| Just i == rbos ^? allocRemoveID ->
|
|
w & rbOptions . opActivateEquipment .~ DeactivateEquipment i
|
|
Just _ -> w & rbOptions . opActivateEquipment .~ NoChangeActivateEquipment
|
|
Nothing
|
|
| invselcanactivate ->
|
|
w & rbOptions . opActivateEquipment
|
|
.~ ActivateEquipment
|
|
{ _activateEquipment = fromJust minvsel
|
|
}
|
|
Nothing -> w & rbOptions . opActivateEquipment .~ NoChangeActivateEquipment
|
|
Nothing -> w & rbOptions . opActivateEquipment .~ NoChangeActivateEquipment
|
|
where
|
|
--invsel = crSel (you w)
|
|
minvsel = cr ^? crManipulation . manObject . inInventory . ispItem
|
|
cr = you w
|
|
invselcanactivate = isJust $ do
|
|
i <- minvsel
|
|
return $ cr ^? crInv . ix i . itUse . leftUse
|
|
|
|
equipSiteToPositions :: EquipSite -> [EquipPosition]
|
|
equipSiteToPositions es = case es of
|
|
GoesOnHead -> [OnHead]
|
|
GoesOnChest -> [OnChest]
|
|
GoesOnBack -> [OnBack]
|
|
GoesOnWrist -> [OnLeftWrist, OnRightWrist]
|
|
GoesOnLegs -> [OnLegs]
|
|
|
|
closeObjScrollDir :: Float -> World -> World
|
|
closeObjScrollDir x
|
|
| x > 0 = over (hud . closeObjects) rotU
|
|
| x < 0 = over (hud . closeObjects) rotD
|
|
| otherwise = id
|
|
|
|
changeSwapInvSel :: Int -> World -> World
|
|
changeSwapInvSel k w = case you w ^? crManipulation . manObject of
|
|
Just (InInventory (SelItem i _)) -> w & cWorld . lWorld . creatures . ix 0 %~ updatecreature i
|
|
Just (InNearby (SelCloseObject i)) -> w
|
|
& cWorld . lWorld . creatures . ix 0 . crManipulation . manObject . inNearby . ispCloseObject
|
|
.~ ((i - k) `mod` numCO)
|
|
& hud . closeObjects %~ swapIndices i ((i - k) `mod` numCO)
|
|
_ -> w
|
|
where
|
|
updatecreature i =
|
|
(crInv %~ IM.safeSwapKeys (i `mod` n) (swapi i))
|
|
. (crLeftInvSel . lisMPos . _Just %~ updateLeftInvSel i)
|
|
. (crManipulation . manObject . inInventory . ispItem %~ (`mod` n) . subtract k)
|
|
. (crInvEquipped %~ IM.safeSwapKeys i (swapi i))
|
|
. swapSite i (swapi i)
|
|
. swapSite (swapi i) i
|
|
swapSite a b = case cr ^? crInvEquipped . ix a of
|
|
Just epos -> crEquipment . ix epos .~ b
|
|
Nothing -> id
|
|
cr = you w
|
|
swapi i = (i - k) `mod` n
|
|
updateLeftInvSel i li
|
|
| i == li = swapi i
|
|
| swapi i == li = i
|
|
| otherwise = li
|
|
n = length $ _crInv cr
|
|
numCO = length $ w ^. hud . closeObjects
|
|
|
|
scrollAugInvSel :: Int -> World -> World
|
|
scrollAugInvSel yi w
|
|
| yi == 0 = w
|
|
| otherwise =
|
|
w & hud . hudElement . diSections %~ scrollSelectionSections yi
|
|
& setInvPosFromSS
|
|
|
|
setInvPosFromSS :: World -> World
|
|
setInvPosFromSS w = w
|
|
& cWorld . lWorld . creatures . ix 0 . crManipulation . manObject .~ thesel
|
|
where
|
|
thesel = fromMaybe SelNothing $ do
|
|
sss <- w ^? hud . hudElement . diSections
|
|
(i,j) <- sss ^? sssSelPos . _Just
|
|
-- j <- sss ^? sssSections . ix i . ssCursor . _Just . scurSel
|
|
case i of
|
|
(-1) -> Just $ InInventory SortInventory
|
|
0 -> Just $ InInventory (SelItem j NoInvSelAction)
|
|
1 -> Just SelNothing
|
|
2 -> Just $ InNearby SortNearby
|
|
3 -> Just $ InNearby $ SelCloseObject j
|
|
_ -> error "selection out of bounds"
|
|
|
|
|
|
selectedCloseObject :: World -> Maybe (Either FloorItem Button)
|
|
selectedCloseObject w = do
|
|
i <- you w ^? crManipulation . manObject . inNearby . ispCloseObject
|
|
<|> fmap fst (IM.lookupMin =<< w ^? hud . hudElement . diSections . sssSections . ix 3 . ssItems)
|
|
w ^? hud . closeObjects . ix i
|