394 lines
14 KiB
Haskell
394 lines
14 KiB
Haskell
{-# LANGUAGE TupleSections #-}
|
|
|
|
module Dodge.Inventory (
|
|
checkInvSlotsYou,
|
|
rmSelectedInvItem,
|
|
invSelPos,
|
|
invSelSize,
|
|
selNumPos,
|
|
selNumTextPos,
|
|
selNumCol,
|
|
selNumSlots,
|
|
selNumMidHeight,
|
|
augmentedInvSizes,
|
|
rmInvItem,
|
|
updateCloseObjects,
|
|
updateRBList,
|
|
updateTerminal,
|
|
closeObjScrollDir,
|
|
closeObjectCol,
|
|
changeInvSel,
|
|
changeSwapInvSel,
|
|
changeAugInvSel,
|
|
crNumFreeSlots,
|
|
crInvSize,
|
|
selectedCloseObject,
|
|
) where
|
|
|
|
import Color
|
|
import qualified Data.Map.Strict as M
|
|
import Data.Maybe
|
|
import Dodge.Base
|
|
import Dodge.Data.Universe
|
|
import Dodge.Euse
|
|
import Dodge.Inventory.CheckSlots
|
|
import Dodge.Inventory.CloseObject
|
|
import Dodge.Inventory.ItemSpace
|
|
import Dodge.ItEffect
|
|
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 ^? cWorld . creatures . ix cid . crInv . ix invid . itUse . useAmount of
|
|
Just x | x > 1 -> w & cWorld . creatures . ix cid . crInv . ix invid . itUse . useAmount %~ subtract 1
|
|
_ ->
|
|
w
|
|
& cWorld . creatures . ix cid . crInv %~ f
|
|
& cWorld . creatures . ix cid . crInvSel %~ stopCrInvSelAction
|
|
& cWorld . creatures . ix cid . crInvSel . iselPos %~ g
|
|
& cWorld . creatures . ix cid . crLeftInvSel %~ g'
|
|
& removeAnySlotEquipment
|
|
& dounequipfunction
|
|
& doanyitemeffect
|
|
& cWorld . creatures . ix cid . crInvEquipped %~ IM.delete invid
|
|
& cWorld . creatures . ix cid . crInvEquipped %~ IM.mapKeys g
|
|
where
|
|
-- TODO check whether this can be mapKeysMonotonic
|
|
|
|
stopCrInvSelAction (InvSel i a)
|
|
| i == invid = InvSel i NoInvSelAction
|
|
| otherwise = InvSel i a
|
|
cr = _creatures (_cWorld w) IM.! 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 . creatures . ix cid . crInvEquipped . ix invid of
|
|
Just epos -> cWorld . creatures . ix cid . crEquipment . at epos .~ Nothing
|
|
Nothing -> id
|
|
maxk = fmap fst $ IM.lookupMax $ _crInv $ _creatures (_cWorld w) IM.! cid
|
|
f inv =
|
|
let (xs, ys) = IM.split invid inv
|
|
in xs `IM.union` IM.mapKeys (subtract 1) ys
|
|
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 = rmInvItem cid (crSel (_creatures (_cWorld w) IM.! cid)) w
|
|
|
|
augmentedInvSizes :: World -> IM.IntMap Int
|
|
augmentedInvSizes = bimapAugmentInv itSlotsTaken closeObjectSize
|
|
|
|
bimapAugmentInv :: (Item -> a) -> (Either FloorItem Button -> a) -> World -> IM.IntMap a
|
|
bimapAugmentInv f g w =
|
|
IM.union
|
|
(f <$> yourInv w)
|
|
(IM.fromAscList $ zip [length (yourInv w) ..] $ map g $ _closeObjects (_cWorld w))
|
|
|
|
invSelSize :: Int -> World -> Int
|
|
invSelSize i w = fromMaybe 1 $ augmentedInvSizes w IM.!? i
|
|
|
|
closeObjectSize :: Either FloorItem Button -> Int
|
|
closeObjectSize e = case e of
|
|
Left flit -> itSlotsTaken $ _flIt flit
|
|
Right _ -> 1
|
|
|
|
closeObjectCol :: Either FloorItem Button -> Color
|
|
closeObjectCol e = case e of
|
|
Left flit -> _itInvColor $ _flIt flit
|
|
Right _ -> yellow
|
|
|
|
selNumSlots :: Int -> World -> Int
|
|
selNumSlots i w = fromMaybe 1 $ augmentedInvSizes w IM.!? i
|
|
|
|
selNumPos :: Int -> World -> Int
|
|
selNumPos i w = splitgap + (foldl' (+) 0 . fst $ IM.split i (augmentedInvSizes w))
|
|
where
|
|
splitgap
|
|
| i < length (yourInv w) = 0
|
|
| otherwise = 1
|
|
|
|
selNumTextPos :: Configuration -> World -> Int -> Point2
|
|
selNumTextPos cfig w i = V2 (150 - hw) (hh - (20 * fromIntegral ipos + 20))
|
|
where
|
|
hh = halfHeight cfig
|
|
hw = halfWidth cfig
|
|
ipos = selNumPos i w
|
|
|
|
selNumMidHeight :: Configuration -> World -> Int -> Point2
|
|
selNumMidHeight cfig w i = V2 (150 - hw) (hh + bump - (20 * fromIntegral ipos + 7.5))
|
|
where
|
|
hh = halfHeight cfig
|
|
hw = halfWidth cfig
|
|
ipos = selNumPos i w
|
|
bump = negate $ 10 * fromIntegral (selNumSlots i w)
|
|
|
|
selNumCol :: Int -> World -> Color
|
|
selNumCol i w = fromMaybe white $ bimapAugmentInv _itInvColor closeObjectCol w IM.!? i
|
|
|
|
invSelPos :: World -> Int
|
|
invSelPos w = splitgap + (foldl' (+) 0 . fst $ IM.split invsel (augmentedInvSizes w))
|
|
where
|
|
invsel = yourInvSel w
|
|
splitgap
|
|
| invsel < length (yourInv w) = 0
|
|
| otherwise = 1
|
|
|
|
updateTerminal :: World -> World
|
|
updateTerminal = checkTermDist
|
|
|
|
checkTermDist :: World -> World
|
|
checkTermDist w = case w ^? cWorld . hud . hudElement . subInventory . termID of
|
|
Just tmid -> fromMaybe (w & cWorld . hud . hudElement .~ DisplayInventory NoSubInventory) $ do
|
|
btid <- w ^? cWorld . terminals . ix tmid . tmButtonID
|
|
btpos <- w ^? cWorld . 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
|
|
& cWorld . closeObjects .~ unionBy closeObjEq oldCloseFiltered currentClose
|
|
& cWorld . creatures . ix (_yourID (_cWorld w)) . crInvSel . iselPos %~ updateinvsel
|
|
where
|
|
updateinvsel curinvsel
|
|
| length (augmentedInvSizes w) <= curinvsel = max 0 $ length (augmentedInvSizes w) - 1
|
|
| otherwise = curinvsel
|
|
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
|
|
$ _buttons (_cWorld w)
|
|
currentClose = filt $ map Left (IM.elems $ _floorItems (_cWorld w)) ++ activeButtons
|
|
oldClose = filt $ mapMaybe updatebyid $ _closeObjects (_cWorld w)
|
|
oldCloseFiltered = intersectBy closeObjEq oldClose currentClose
|
|
updatebyid (Left flid) = fmap Left $ w ^? cWorld . floorItems . ix (_flItID flid)
|
|
updatebyid (Right btid) = fmap Right $ w ^? cWorld . buttons . ix (_btID btid)
|
|
|
|
updateRBList :: World -> World
|
|
updateRBList w
|
|
| w ^? rbOptions . opCurInvPos == Just curinvid =
|
|
w & setEquipAllocation & setEquipActivation
|
|
| otherwise = case cr ^? crInv . ix curinvid . itUse . equipEffect . eeSite of
|
|
Just esite ->
|
|
w
|
|
& rbOptions
|
|
.~ EquipOptions
|
|
(equipSiteToPositions esite)
|
|
(chooseEquipmentPosition cr (equipSiteToPositions esite))
|
|
curinvid
|
|
DoNotMoveEquipment
|
|
NoChangeActivateEquipment
|
|
& setEquipAllocation
|
|
& setEquipActivation
|
|
Nothing -> w & rbOptions .~ NoRightButtonOptions
|
|
where
|
|
-- | otherwise = w & rbOptions .~ NoRightButtonOptions
|
|
|
|
curinvid = crSel cr
|
|
cr = you w
|
|
|
|
chooseEquipmentPosition :: Creature -> [EquipPosition] -> Int
|
|
chooseEquipmentPosition cr eps = fromMaybe (chooseFreeSite cr eps) $ do
|
|
ep <- cr ^? crInvEquipped . ix (crSel cr)
|
|
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 = case _rbOptions w of
|
|
EquipOptions{_opEquip = es, _opSel = i} ->
|
|
case you w ^? crInvEquipped . ix (crSel (you w)) 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
|
|
|
|
-- where
|
|
-- curpos = invSelPos w
|
|
|
|
setEquipActivation :: World -> World
|
|
setEquipActivation w = case w ^? rbOptions . opAllocateEquipment of
|
|
Just DoNotMoveEquipment -> w
|
|
Just RemoveEquipment{} ->
|
|
case _crLeftInvSel (you w) of
|
|
Just i
|
|
| i == invsel ->
|
|
w & rbOptions . opActivateEquipment
|
|
.~ DeactivateEquipment
|
|
{ _deactivateEquipment = i
|
|
}
|
|
_ -> w & rbOptions . opActivateEquipment .~ NoChangeActivateEquipment
|
|
Just rbos ->
|
|
case _crLeftInvSel (you w) of
|
|
Just i | i == invsel -> w & rbOptions . opActivateEquipment .~ NoChangeActivateEquipment
|
|
Just i
|
|
| invselcanactivate ->
|
|
w & rbOptions . opActivateEquipment
|
|
.~ ActivateDeactivateEquipment
|
|
{ _activateEquipment = invsel
|
|
, _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 = invsel
|
|
}
|
|
Nothing -> w & rbOptions . opActivateEquipment .~ NoChangeActivateEquipment
|
|
Nothing -> w & rbOptions . opActivateEquipment .~ NoChangeActivateEquipment
|
|
where
|
|
invsel = crSel (you w)
|
|
invselcanactivate = isJust (you w ^? crInv . ix invsel . itUse . leftUse)
|
|
|
|
equipSiteToPositions :: EquipSite -> [EquipPosition]
|
|
equipSiteToPositions es = case es of
|
|
GoesOnHead -> [OnHead]
|
|
GoesOnChest -> [OnChest]
|
|
GoesOnBack -> [OnBack]
|
|
GoesOnWrist -> [OnLeftWrist, OnRightWrist]
|
|
GoesOnLegs -> [OnLegs]
|
|
GoesOnSpecial -> [OnSpecial]
|
|
|
|
closeObjScrollDir :: Float -> World -> World
|
|
closeObjScrollDir x
|
|
| x > 0 = over (cWorld . closeObjects) rotU
|
|
| x < 0 = over (cWorld . closeObjects) rotD
|
|
| otherwise = id
|
|
|
|
changeInvSel :: Int -> World -> World
|
|
changeInvSel i w
|
|
| n == 0 = w
|
|
| yourInvSel w < n =
|
|
w
|
|
& cWorld . creatures . ix (_yourID (_cWorld w)) . crInvSel . iselPos %~ (`mod` n) . subtract i
|
|
& cWorld . creatures . ix (_yourID (_cWorld w)) . crInvSel . iselAction .~ NoInvSelAction
|
|
| otherwise =
|
|
w
|
|
& cWorld . creatures . ix (_yourID (_cWorld w)) . crInvSel . iselPos %~ ((+ n) . (`mod` numCO) . subtract (i + n))
|
|
& cWorld . creatures . ix (_yourID (_cWorld w)) . crInvSel . iselAction .~ NoInvSelAction
|
|
where
|
|
-- arguably this should jump the invpos into the inventory proper
|
|
|
|
n = length $ _crInv $ _creatures (_cWorld w) IM.! _yourID (_cWorld w)
|
|
numCO = length $ _closeObjects (_cWorld w)
|
|
|
|
changeSwapInvSel :: Int -> World -> World
|
|
changeSwapInvSel k w
|
|
| n == 0 = w
|
|
| yourInvSel w < n =
|
|
w
|
|
& cWorld . creatures . ix (_yourID (_cWorld w)) %~ updatecreature
|
|
| otherwise =
|
|
w
|
|
& cWorld . creatures . ix (_yourID (_cWorld w)) . crInvSel . iselPos .~ ico'
|
|
& cWorld . closeObjects %~ swapIndices (i - n) (ico' - n)
|
|
where
|
|
updatecreature =
|
|
(crInv %~ IM.safeSwapKeys (i `mod` n) swapi)
|
|
. (crLeftInvSel . _Just %~ updateLeftInvSel)
|
|
. (crInvSel . iselPos %~ (`mod` n) . subtract k)
|
|
. (crInvEquipped %~ IM.safeSwapKeys i swapi)
|
|
. swapSite i swapi
|
|
. swapSite swapi i
|
|
swapSite a b = case cr ^? crInvEquipped . ix a of
|
|
Just epos -> crEquipment . ix epos .~ b
|
|
Nothing -> id
|
|
cr = you w
|
|
swapi = (i - k) `mod` n
|
|
updateLeftInvSel li
|
|
| i == li = swapi
|
|
| swapi == li = i
|
|
| otherwise = li
|
|
i = crSel cr
|
|
ico' = ((i - (k + n)) `mod` numCO) + n
|
|
n = length $ _crInv cr
|
|
numCO = length $ _closeObjects (_cWorld w)
|
|
|
|
changeAugInvSel :: Int -> World -> World
|
|
changeAugInvSel i w
|
|
| n == 0 = w
|
|
| otherwise =
|
|
w
|
|
& cWorld . creatures . ix (_yourID (_cWorld w)) . crInvSel . iselPos %~ (`mod` n) . subtract i
|
|
& cWorld . creatures . ix (_yourID (_cWorld w)) . crInvSel . iselAction .~ NoInvSelAction
|
|
where
|
|
n = length (yourInv w) + length (_closeObjects (_cWorld w))
|
|
|
|
bestCloseObjectIndex :: World -> Maybe Int
|
|
bestCloseObjectIndex w = findIndex f $ _closeObjects (_cWorld w)
|
|
where
|
|
f (Right _) = True
|
|
f (Left flit) = itSlotsTaken (_flIt flit) <= _crInvCapacity ycr - crInvSize ycr
|
|
ycr = you w
|
|
|
|
selectedCloseObject :: World -> Maybe (Int, Either FloorItem Button)
|
|
selectedCloseObject w
|
|
| invsel >= length inv = selectNthCloseObject w (invsel - length inv)
|
|
| otherwise = selectNthCloseObject w =<< bestCloseObjectIndex w
|
|
where
|
|
invsel = crSel cr
|
|
cr = you w
|
|
inv = _crInv cr
|
|
|
|
selectNthCloseObject :: World -> Int -> Maybe (Int, Either FloorItem Button)
|
|
selectNthCloseObject w n = (length (yourInv w) + n,) <$> (_closeObjects (_cWorld w) !? n)
|