344 lines
13 KiB
Haskell
344 lines
13 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 Dodge.Data
|
|
import Dodge.Inventory.CloseObject
|
|
import Dodge.Inventory.CheckSlots
|
|
import Dodge.Inventory.ItemSpace
|
|
import Dodge.Base
|
|
import Geometry
|
|
--import FoldableHelp
|
|
import Padding
|
|
import Color
|
|
import qualified IntMapHelp as IM
|
|
import ListHelp
|
|
import LensHelp
|
|
|
|
--import qualified Data.IntSet as IS
|
|
import qualified Data.Map.Strict as M
|
|
--import qualified Data.Set as S
|
|
import Data.Maybe
|
|
--import qualified Data.Text as T
|
|
--import SDL
|
|
--import Data.List
|
|
--import System.Random
|
|
|
|
-- | after this the item at the inventory position will no longer exist
|
|
rmInvItem :: Int -- ^ Creature id
|
|
-> Int -- ^ Inventory position
|
|
-> World
|
|
-> World
|
|
rmInvItem cid invid w = case w ^? creatures . ix cid . crInv . ix invid . itConsumption . icAmount of
|
|
Just x | x > 1 -> w & creatures . ix cid . crInv . ix invid . itConsumption . icAmount %~ subtract 1
|
|
_ -> w & creatures . ix cid . crInv %~ f
|
|
& creatures . ix cid . crInvSel %~ stopCrInvSelAction
|
|
& creatures . ix cid . crInvSel . iselPos %~ g
|
|
& creatures . ix cid . crLeftInvSel %~ g'
|
|
& removeAnySlotEquipment
|
|
& dounequipfunction
|
|
& doanyitemeffect
|
|
& creatures . ix cid . crInvEquipped %~ IM.delete invid
|
|
& creatures . ix cid . crInvEquipped %~ IM.mapKeys g
|
|
-- TODO check whether this can be mapKeysMonotonic
|
|
where
|
|
stopCrInvSelAction (InvSel i a)
|
|
| i == invid = InvSel i NoInvSelAction
|
|
| otherwise = InvSel i a
|
|
cr = _creatures w IM.! cid
|
|
itm = _crInv cr IM.! invid
|
|
dounequipfunction = fromMaybe id $ do
|
|
rmf <- itm ^? itUse . eqEq . eqOnRemove
|
|
return $ rmf itm cr
|
|
doanyitemeffect = fromMaybe id $ do
|
|
rmf <- itm ^? itEffect . ieDrop
|
|
return $ rmf itm cr
|
|
removeAnySlotEquipment = case w ^? creatures . ix cid . crInvEquipped . ix invid of
|
|
Just epos -> creatures . ix cid . crEquipment . at epos .~ Nothing
|
|
Nothing -> id
|
|
maxk = fmap fst $ IM.lookupMax $ _crInv $ _creatures 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 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 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 ^? hud . hudElement . subInventory . termID of
|
|
Just tmid -> fromMaybe (w & hud . hudElement .~ DisplayInventory NoSubInventory) $ do
|
|
btid <- w ^? terminals . ix tmid . tmButtonID
|
|
btpos <- w ^? 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
|
|
& closeObjects .~ unionBy closeObjEq oldCloseFiltered currentClose
|
|
& creatures . ix (_yourID 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 w
|
|
currentClose = filt $ map Left (IM.elems $ _floorItems w) ++ activeButtons
|
|
oldClose = filt $ mapMaybe updatebyid $ _closeObjects w
|
|
oldCloseFiltered = intersectBy closeObjEq oldClose currentClose
|
|
updatebyid (Left flid) = fmap Left $ w ^? floorItems . ix (_flItID flid)
|
|
updatebyid (Right btid) = fmap Right $ w ^? buttons . ix (_btID btid)
|
|
|
|
updateRBList :: World -> World
|
|
updateRBList w
|
|
| w ^? rbOptions . opCurInvPos == Just curinvid
|
|
= w & setEquipAllocation & setEquipActivation
|
|
| otherwise = case cr ^? crInv . ix curinvid . itUse . eqEq . eqSite of
|
|
Just esite -> w
|
|
& rbOptions .~ EquipOptions (equipSiteToPositions esite)
|
|
(chooseEquipmentPosition cr (equipSiteToPositions esite))
|
|
curinvid
|
|
DoNotMoveEquipment
|
|
NoChangeActivateEquipment
|
|
& setEquipAllocation & setEquipActivation
|
|
Nothing -> w & rbOptions .~ NoRightButtonOptions
|
|
-- | otherwise = w & rbOptions .~ NoRightButtonOptions
|
|
where
|
|
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 . lUse)
|
|
|
|
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 closeObjects rotU
|
|
| x < 0 = over closeObjects rotD
|
|
| otherwise = id
|
|
|
|
changeInvSel :: Int -> World -> World
|
|
changeInvSel i w
|
|
| n == 0 = w
|
|
| yourInvSel w < n = w & creatures . ix (_yourID w) . crInvSel . iselPos %~ (`mod` n) . subtract i
|
|
& creatures . ix (_yourID w) . crInvSel . iselAction .~ NoInvSelAction
|
|
| otherwise = w & creatures . ix (_yourID w) . crInvSel . iselPos %~ ((+n) . (`mod` numCO) . subtract (i+n))
|
|
& creatures . ix (_yourID w) . crInvSel . iselAction .~ NoInvSelAction
|
|
-- arguably this should jump the invpos into the inventory proper
|
|
where
|
|
n = length $ _crInv $ _creatures w IM.! _yourID w
|
|
numCO = length $ _closeObjects w
|
|
|
|
changeSwapInvSel :: Int -> World -> World
|
|
changeSwapInvSel k w
|
|
| n == 0 = w
|
|
| yourInvSel w < n = w
|
|
& creatures . ix (_yourID w) %~ updatecreature
|
|
| otherwise = w & creatures . ix (_yourID w) . crInvSel . iselPos .~ ico'
|
|
& 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 w
|
|
|
|
changeAugInvSel :: Int -> World -> World
|
|
changeAugInvSel i w
|
|
| n == 0 = w
|
|
| otherwise = w & creatures . ix (_yourID w) . crInvSel . iselPos %~ (`mod` n) . subtract i
|
|
& creatures . ix (_yourID w) . crInvSel . iselAction .~ NoInvSelAction
|
|
where
|
|
n = length (yourInv w) + length (_closeObjects w)
|
|
|
|
bestCloseObjectIndex :: World -> Maybe Int
|
|
bestCloseObjectIndex w = findIndex f $ _closeObjects 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 w !? n)
|