Work on inventory management

2021-11-30 20:11:03 +00:00
parent 3754627e0d
commit 42d7ca3ba8
8 changed files with 154 additions and 85 deletions
@@ -48,8 +48,20 @@ you w = _creatures w IM.! _yourID w
 aCrPos :: Int -> World -> Point2
 aCrPos i w = _crPos $ _creatures w IM.! i

-yourItem :: World -> Item
-yourItem w = _crInv (you w) IM.! _crInvSel (you w)
+yourItem :: World -> Maybe Item
+yourItem w = _crInv (you w) IM.!? _crInvSel (you w)
+
+yourInv :: World -> IM.IntMap Item
+yourInv w = _crInv (you w)
+
+yourInvSel :: World -> Int
+yourInvSel w = _crInvSel (you w)
+
+selectedObject :: World -> Maybe (Either FloorItem Button)
+selectedObject w = lookup (_crInvSel ycr) $ zip [n..] $ _closeObjects w
+  where
+    ycr = you w
+    n = length $ _crInv ycr

 crItem :: World -> Int -> Item
 crItem w cid = _crInv cr IM.! _crInvSel cr
@@ -232,7 +232,7 @@ dropItem cr invid = rmInvItem cid invid . copyInvItemToFloor cr invid . mayberem

 {- | Get your creature to drop the item under the cursor.  -}
 youDropItem :: World -> World
-youDropItem w = case yourItem w ^? itCurseStatus of
+youDropItem w = case yourItem w ^? _Just . itCurseStatus of
    Just Uncursed -> w
        & dropItem cr (_crInvSel cr) 
        & soundStart (CrSound (_crID cr)) (_crPos cr) whiteNoiseFadeOutS Nothing
@@ -250,7 +250,7 @@ pickUpItem cid flit w = case maybeInvSlot of
    Just i  -> w
        & soundStart (CrSound cid) (_flItPos flit) pickUpS Nothing
        & updateItLocation i
-        & floorItems                      %~ IM.delete (_flItID flit)
+        & floorItems %~ IM.delete (_flItID flit)
        & creatures . ix cid . crInv %~ IM.insertWith (const $ itAmount +~ 1) i it
  where 
    it = _flIt flit
@@ -25,6 +25,7 @@ import Dodge.Inventory
 --import Preload.Update
 import qualified IntMapHelp as IM

+import Data.Maybe
 import Control.Lens
 --import Data.Maybe
 --import Data.Char
@@ -105,15 +106,15 @@ wheelEvent y w = case (_carteDisplay w, _inventoryMode w) of
        | rbDown -> w & carteZoom %~ min 0.75 . max 0.05 . ((1+y*0.1) * )
        | otherwise -> w & selLocation %~ (`mod` numLocs) . (+ yi)
    (_, TopInventory)
-        | rbDown -> case yourItem w ^? itScroll of
+        | rbDown -> case yourItem w ^? _Just . itScroll of
            Nothing -> closeObjScrollDir y w
            Just f  -> w & creatures . ix 0 . crInv . ix (_crInvSel $ you w) %~ f y (you w)
        | lbDown -> w & cameraZoom +~ y
-        | invKeyDown -> swapInvDir yi $ stopSoundFrom (CrReloadSound 0) $ dirInvPos yi w
-        | otherwise -> stopSoundFrom (CrReloadSound 0) $ dirInvPos yi w
+        | invKeyDown -> swapInvDir yi $ stopSoundFrom (CrReloadSound 0) $ changeInvPos yi w
+        | otherwise -> stopSoundFrom (CrReloadSound 0) $ changeInvCloseObjectsPos yi w
    (_, TweakInventory)
        | invKeyDown && rbDown -> w & moveTweakSel yi
-        | invKeyDown -> stopSoundFrom (CrReloadSound 0) $ dirInvPos yi w
+        | invKeyDown -> stopSoundFrom (CrReloadSound 0) $ changeInvPos yi w
        | rbDown ->     w & changeTweakParam yi
        | otherwise ->  w & moveTweakSel yi
    (_, _) -> w
@@ -125,7 +126,7 @@ wheelEvent y w = case (_carteDisplay w, _inventoryMode w) of
    invKeyDown = ScancodeCapsLock `S.member` _keys w

 moveTweakSel :: Int -> World -> World
-moveTweakSel i w = case yourItem w ^? itTweaks . tweakParams of
+moveTweakSel i w = case yourItem w ^? _Just . itTweaks . tweakParams of
    Just l -> w & creatures . ix (_yourID w) . crInv . ix (_crInvSel (you w))
                    . itTweaks . tweakSel %~ (`mod` length l) . subtract i
    _ -> w
@@ -135,7 +136,7 @@ changeTweakParam i w = w
        ( (itTweaks . tweakParams . ix paramid . curTweak .~ x)
        . _doTweak params x)
  where
-    tweaks = _itTweaks $ yourItem w
+    tweaks = _itTweaks . fromJust $ yourItem w
    params = _tweakParams tweaks IM.! paramid
    x = (_curTweak params + i) `mod` _maxTweak params
    paramid = _tweakSel tweaks
@@ -5,14 +5,17 @@ module Dodge.Inventory
    , updateCloseObjects
    , closeObjScrollDir
    , swapInvDir
-    , dirInvPos
+    , changeInvPos
+    , changeInvCloseObjectsPos
+    , crNumFreeSlots
+    , crInvSize
    )
    where
 import Dodge.Data
 import Dodge.Base
 import Dodge.Base.Collide
 import Geometry
-import FoldableHelp
+--import FoldableHelp
 import Padding
 import qualified IntMapHelp as IM

@@ -25,28 +28,26 @@ import Control.Lens
 -- if so return Just the next slot to be used
 checkInvSlotsYou :: Item -> World -> Maybe Int
 checkInvSlotsYou it w
-    | _crInvCapacity ycr >= curinvsize + _itInvSize it 
+    | crNumFreeSlots ycr >= _itInvSize it 
                = Just $ maybe 0 ((+1) . fst) $ IM.lookupMax inv
    | otherwise = Nothing
  where 
    ycr = you w
    inv = _crInv ycr
-    curinvsize = sum $ fmap _itInvSize inv
+--    curinvsize = invSize inv

---- | Finds first available slot where a new item may be placed in the inventory
--checkInvSlots :: Item -> IM.IntMap Item -> Maybe Int
--checkInvSlots it = checkInvSlotsH it . IM.toList
+crNumFreeSlots :: Creature -> Int
+crNumFreeSlots cr = _crInvCapacity cr - invSize (_crInv cr)

-itNotFull :: Item -> Bool
-itNotFull it = case it ^? itMaxStack of
-    Just themax -> themax > _itAmount it
-    Nothing -> False
+crInvSize :: Creature -> Int
+crInvSize = invSize . _crInv

-rmInvItem 
-    :: Int      -- ^ Creature id
+invSize :: IM.IntMap Item -> Int
+invSize = sum . fmap _itInvSize
+
+rmInvItem :: Int      -- ^ Creature id
    -> Int      -- ^ Inventory position
-    -> World 
-    -> World
+    -> World -> World
 rmInvItem cid invid w = case w ^? creatures . ix cid . crInv . ix invid . itAmount of
    Just x | x > 1 -> w & creatures . ix cid . crInv . ix invid . itAmount %~ subtract 1
    _ -> w & creatures . ix cid . crInv %~ f
@@ -56,8 +57,8 @@ rmInvItem cid invid w = case w ^? creatures . ix cid . crInv . ix invid . itAmou
    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 = x - 1
-        | otherwise = x 
+    g x | x > invid || Just x == maxk = max 0 $ x - 1
+        | otherwise = x
 {- Delete a creature's selected item, the item will no longer exist.  -}
 rmSelectedInvItem 
    :: Int  -- ^ Creature id
@@ -91,7 +92,9 @@ closeObjScrollDir x
    | otherwise = id

 swapInvDir :: Int -> World -> World
-swapInvDir k w = w & creatures . ix (_yourID w) %~ updatecreature
+swapInvDir k w 
+    | n == 0    = w
+    | otherwise = w & creatures . ix (_yourID w) %~ updatecreature
  where
    updatecreature = ( crInv %~ IM.swapKeys (i `mod` n) swapi )
        . (crLeftInvSel . _Just %~ updateLeftInvSel)
@@ -102,8 +105,16 @@ swapInvDir k w = w & creatures . ix (_yourID w) %~ updatecreature
    i = _crInvSel $ you w
    n = length $ IM.keys $ _crInv $ _creatures w IM.! _yourID w

-dirInvPos :: Int -> World -> World
-dirInvPos i w =  w
-    & creatures . ix (_yourID w) . crInvSel %~ (`mod` n) . subtract i
+changeInvPos :: Int -> World -> World
+changeInvPos i w 
+    | n == 0    = w
+    | otherwise =  w & creatures . ix (_yourID w) . crInvSel %~ (`mod` n) . subtract i
  where 
    n = length $ IM.keys $ _crInv $ _creatures w IM.! _yourID w
+
+changeInvCloseObjectsPos :: Int -> World -> World
+changeInvCloseObjectsPos i w 
+    | n == 0    = w
+    | otherwise =  w & creatures . ix (_yourID w) . crInvSel %~ (`mod` n) . subtract i
+  where 
+    n = (length $ IM.keys $ _crInv $ _creatures w IM.! _yourID w) + length (_closeObjects w)
@@ -43,7 +43,7 @@ poisonSprayer = defaultAutoGun
        [ ammoCheckI
        , withSoundForI foamSprayLoopS 5
        , useAmmo 1
-        , spreadNumI
+--        , spreadNumI
        ] 
        & useAim . aimSpeed .~ 0.2
        & useAim . aimRange .~ 0
@@ -1,8 +1,7 @@
 {-# LANGUAGE TupleSections #-}
 module Dodge.Render.HUD
    ( hudDrawings
-    )
-    where
+    ) where
 import Dodge.Data
 import Dodge.WinScale
 import Dodge.Base
@@ -14,6 +13,7 @@ import Picture
 import Geometry
 import Padding

+import Data.Foldable
 import Data.Maybe
 import qualified Data.IntMap.Strict as IM
 import qualified Data.Set as S
@@ -25,23 +25,16 @@ hudDrawings :: Configuration -> World -> Picture
 hudDrawings cfig w = pictures
    [ winScale cfig . dShadCol white $ displayHP 0 cfig w
    , renderListAt (halfWidth cfig) 0 cfig $ map (,white) (_testString w w)
-    , selectionText
-    ]
-  where
-    selectionText = if _carteDisplay w
+    , if _carteDisplay w
        then drawLocations cfig w
-        else drawInventory cfig w
-
-
-drawInventory :: Configuration -> World -> Picture
-drawInventory cfig w = subInventoryDisplay cfig w `appendPic` displayInv 0 cfig w
+        else subInventoryDisplay cfig w `appendPic` displayInv 0 cfig w
+    ]

 subInventoryDisplay :: Configuration -> World -> Picture
 subInventoryDisplay cfig w = case _inventoryMode w of
    LockedInventory -> mempty -- topInvCursor col cursPos cfig w
    TopInventory -> pictures
-        [ closeObjectTexts cfig w
--        , topInvCursor col cursPos cfig w
+        [ --closeObjectTexts cfig w
        ]
    TweakInventory -> pictures
        [ mCurs it cfig w
@@ -52,20 +45,45 @@ subInventoryDisplay cfig w = case _inventoryMode w of
    CombineInventory -> invHead cfig "COMBINE"
    InspectInventory -> invHead cfig "INSPECT"
  where 
-    itCol = fromMaybe (greyN 0.5) . (^? itInvColor)
-    cr = you w
+    itCol = fromMaybe (greyN 0.5) . (^? _Just . itInvColor)
+    --cr = you w
    it = yourItem w
    col = itCol it
-    cursPos = crInvSelPos cr
+    cursPos = invSelPos w

-crInvSelSize :: Creature -> Int
-crInvSelSize cr = _itInvSize $ _crInv cr IM.! _crInvSel cr
+--crInvSelSize :: Creature -> Int
+--crInvSelSize cr = fromMaybe 1 $ fmap _itInvSize $ _crInv cr IM.!? _crInvSel cr

-crInvSelPos :: Creature -> Int
-crInvSelPos cr = sum . fmap _itInvSize . fst $ IM.split (_crInvSel cr) (_crInv cr)
+--crInvSelPos :: Creature -> Int
+--crInvSelPos cr = foldl' (+) 0 . fmap _itInvSize . fst $ IM.split (_crInvSel cr) (_crInv cr)

-cursorsZ :: Configuration -> Int -> Item -> Picture
-cursorsZ cfig ipos it = case it ^? itTweaks . tweakSel of
+invSelPos :: World -> Int
+invSelPos w = splitgap + (foldl' (+) 0 . fst $ IM.split invsel (augmentedInvSizes w))
+  where
+    invsel = yourInvSel w
+    splitgap
+        | yourInvSel w < length (yourInv w) = 0
+        | otherwise = 1
+
+augmentedInvSizes :: World -> IM.IntMap Int
+augmentedInvSizes w = IM.union (fmap _itInvSize $ yourInv w)
+    (IM.fromAscList $ zip [length (yourInv w) ..] $ map closeObjectSize $ _closeObjects w)
+--augmentedInvSizesWithGap :: World -> IM.IntMap Int
+--augmentedInvSizesWithGap w = IM.union (safeUpdateMax (Just . (+1)) $ fmap _itInvSize $ yourInv w)
+--    (IM.fromAscList $ zip [length (yourInv w) ..] $ (map closeObjectSize $ _closeObjects w))
+--
+--safeUpdateMax :: (a -> Maybe a) -> IM.IntMap a -> IM.IntMap a
+--safeUpdateMax f m 
+--    | IM.null m = m
+--    | otherwise = IM.updateMax f m
+
+closeObjectSize :: Either FloorItem Button -> Int
+closeObjectSize e = case e of
+    Left flit -> _itInvSize $ _flIt flit
+    Right bt  -> 1
+
+cursorsZ :: Configuration -> Int -> Maybe Item -> Picture
+cursorsZ cfig ipos it = case it ^? _Just . itTweaks . tweakSel of
    Nothing   -> f $ zConnect sp (V2 (155- hw) ( hh - 77.5))
    Just jpos -> f $ zConnect sp (V2 (155 - hw) ( hh - (20 * fromIntegral jpos + 77.5)))
  where
@@ -74,13 +92,13 @@ cursorsZ cfig ipos it = case it ^? itTweaks . tweakSel of
    hw = halfWidth  cfig
    sp = V2 (125 - hw) ( hh - (20 * fromIntegral ipos + 17.5))

-ammoTweakStrings :: Item -> [String]
-ammoTweakStrings it = case it ^? itTweaks . tweakParams of
+ammoTweakStrings :: Maybe Item -> [String]
+ammoTweakStrings it = case it ^? _Just . itTweaks . tweakParams of
    Just l -> map tweakString $ IM.elems l
    _ -> ["NOT TWEAKABLE"]

-mCurs :: Item -> Configuration -> World -> Picture
-mCurs it cfig w = case it ^? itTweaks . tweakSel of
+mCurs :: Maybe Item -> Configuration -> World -> Picture
+mCurs it cfig w = case it ^? _Just . itTweaks . tweakSel of
    Nothing -> []
    Just i 
        | ButtonRight `S.member` _mouseButtons w -> 
@@ -111,19 +129,41 @@ invHead cfig s = winScale cfig
 --{-# INLINE renderItemMapAt #-}
 --renderItemMapAt tx ty cfig = concatMapPic (uncurry $ listItemAt tx ty cfig) . IM.toList

-
 displayInv :: Int -> Configuration -> World -> Picture
-displayInv n cfig w = listTextPicturesAt 0 0 cfig (concatMap itemToTextPictures $ IM.elems $ _crInv cr)
+displayInv n cfig w = listTextPicturesAt 0 0 cfig invlist
    <> equipcursor
-    <> listCursorAt 0 0 cfig curpos white curx cury
+    <> selcursor
  where
-    curpos = crInvSelPos $ you w
+    selcursor 
+        | IM.null inv && null (_closeObjects w) = mempty
+        | otherwise   = listCursorAt 0 0 cfig curpos white curx cury
+    inv = _crInv cr
+    invlist = (concatMap itemToTextPictures $ IM.elems inv) 
+        ++ displayFreeSlots ++ concatMap (closeObjectToTextPictures nfreeslots) (_closeObjects w)
+    nfreeslots = crNumFreeSlots cr
+    displayFreeSlots = case nfreeslots of
+        0 -> [color invDimColor . text $ "  INVENTORY FULL"]
+        1 -> [color invDimColor . text $ "  +1 FREE SLOT"]
+        x -> [color invDimColor . text $ "  +" ++ show x ++ " FREE SLOTS"]
+    curpos = invSelPos w
    curx   = 10
-    cury   = crInvSelSize $ you w
+    --cury   = crInvSelSize $ you w
+    cury   = fromMaybe 1 $ augmentedInvSizes w IM.!? _crInvSel (you w)
    equipcursor = case _crLeftInvSel cr of
        Nothing -> mempty
        Just invid -> openCursorAt 20 yellow 0 0 invid cfig
    cr = _creatures w IM.! n
+invDimColor :: Color
+invDimColor = greyN 0.7
+closeObjectToTextPictures :: Int -> Either FloorItem Button -> [Picture]
+closeObjectToTextPictures nfreeslots e = case e of
+    Left flit -> let it = _flIt flit in map (applycolor it . textindent) $ _itInvDisplay it it
+    Right bt  -> [color yellow $ textindent $ _btText bt]
+  where
+    textindent = text . ("  "++)
+    applycolor it
+        | nfreeslots >= _itInvSize it = color $ _itInvColor it
+        | otherwise = color invDimColor

 drawLocations :: Configuration -> World -> Picture
 drawLocations cfig w = pictures $ 
@@ -160,6 +200,26 @@ mapWall cfig w wl =
    n2 = 20 *.* vNormal t
    (x,y) = _wlLine wl
    c = _wlColor wl
+
+bestCloseObjectIndex :: World -> Maybe Int
+bestCloseObjectIndex w = Nothing
+
+selectedCloseObject :: World -> Maybe (Int,Either FloorItem Button)
+selectedCloseObject w
+    | invsel > length inv = Just $ selectNthCloseObject w (invsel - length inv)
+    | otherwise = fmap (selectNthCloseObject w) $ bestCloseObjectIndex w
+  where
+    invsel = _crInvSel cr
+    cr = you w
+    inv = _crInv cr
+    invsize = crInvSize (you w)
+
+selectNthCloseObject :: World -> Int -> (Int,Either FloorItem Button)
+selectNthCloseObject w n = undefined
+
+selectedCloseObjectLink :: Configuration -> World -> Picture
+selectedCloseObjectLink cfig w = mempty
+
 {- | Pictures of popup text for items close to your position.-}
 closeObjectTexts :: Configuration -> World -> Picture
 closeObjectTexts cfig w = pictures $ 
@@ -197,8 +257,6 @@ itemToTextPictures it = itemText it

 itemText :: Item -> [Picture]
 {-# INLINE itemText #-}
--itemText NoItem = dShadCol (greyN 0.5) $ text "----"
--itemText it = dShadCol (_itInvColor it) $ text (_itInvDisplay it it)
 itemText it = case _itCurseStatus it of
    UndroppableIdentified -> map (color yellow . text) (_itInvDisplay it it)
 --        <> color (withAlpha 0.9 thecolor) (polygon (rectNSEW 110 (-65) 885 (-90)))
@@ -42,22 +42,9 @@ listTextPictureAt xoff yoff cfig yint = winScale cfig
    hh = halfHeight cfig

 renderListAt :: Float -> Float -> Configuration -> [(String,Color)] -> Picture
-renderListAt tx ty cfig =
-    concatMapPic (winScale cfig) . zipWith (listPairAt tx ty cfig) [0..]
+renderListAt tx ty cfig = listTextPicturesAt tx ty cfig . map (\(str,col) -> color col $ text str)
+--    concatMapPic (winScale cfig) . zipWith (listPairAt tx ty cfig) [0..]

-listPairAt
-    :: Float    -- ^ x offset
-    -> Float    -- ^ y offset
-    -> Configuration
-    -> Int      -- ^ y offset (discrete)
-    -> (String,Color)   -- ^ The text item
-    -> Picture
-{-# INLINE listPairAt #-}
-listPairAt xoff yoff cfig yint (s,col) 
-    = translate (xoff + 15 - halfWidth cfig) (yoff + halfHeight cfig - (20 * (fromIntegral yint+1)))
-    . scale 0.1 0.1
-    . dShadCol col
-    $ text s
 --TODO put the following functions in an appropriate place
 {- | Colour picture and add black drop shadow. -}
 dShadCol :: Color -> Picture -> Picture
@@ -38,7 +38,7 @@ moveCamera w = w
  where 
    aimRangeFactor 
        | _cameraZoom w == 0 = 0
-        | otherwise = fromMaybe 0 (yourItem w ^? itUse . useAim . aimRange) / _cameraZoom w
+        | otherwise = fromMaybe 0 (yourItem w ^? _Just . itUse . useAim . aimRange) / _cameraZoom w
    aimingMult 
        | SDL.ButtonRight `S.member` _mouseButtons w = 1
        | otherwise                                  = 0
@@ -46,9 +46,9 @@ moveCamera w = w
    idealPos = camCenter 
        +.+ rotateV (_cameraRot w) (aimRangeFactor * aimingMult *.* _mousePos w)
    camCenter  = ypos +.+ scopeOffset
-    scopeOffset = fromMaybe (V2 0 0) $ yourItem w ^? itAttachment . scopePos
+    scopeOffset = fromMaybe (V2 0 0) $ yourItem w ^? _Just . itAttachment . scopePos
    sightFrom 
-        | fromMaybe False $ yourItem w ^? itAttachment . scopeIsCamera
+        | fromMaybe False $ yourItem w ^? _Just . itAttachment . scopeIsCamera
                    = camCenter
        | otherwise = ypos

@@ -159,7 +159,7 @@ autoZoomCamera cfig w = w & cameraZoom %~ changeZoom
    wallZoom = farWallDist camPos cfig w
    idealZoom 
        | SDL.ButtonRight `S.member` _mouseButtons w 
-            = theScopeZoom * maybe zoomNoItem zoomFromItem (yourItem w ^? itUse . useAim . aimZoom) wallZoom
+            = theScopeZoom * maybe zoomNoItem zoomFromItem (yourItem w ^? _Just . itUse . useAim . aimZoom) wallZoom
        | otherwise = zoomNoItem wallZoom
 --            = maybe zoomNoItem zoomFromItem (yourItem w ^? itZoom) wallZoom
    changeZoom curZoom 
@@ -169,7 +169,7 @@ autoZoomCamera cfig w = w & cameraZoom %~ changeZoom
    -- these speeds are inverted, larger means slower
    zoomInSpeed  = 25
    zoomOutSpeed = 15
-    theScopeZoom = fromMaybe 1 $ yourItem w ^? itAttachment . scopeZoom
+    theScopeZoom = fromMaybe 1 $ yourItem w ^? _Just . itAttachment . scopeZoom

 farWallDist :: Point2 -> Configuration -> World -> Float
 farWallDist p cfig w = (winFac /) . min maxViewDistance $ ssfold (> maxViewDistance) findMax 1 vps