Work on inventory management

src/Dodge/Base.hs

@@ -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 :: World -> Maybe Item
-yourItem w = _crInv (you w) IM.! _crInvSel (you w)
+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

src/Dodge/Creature/Action.hs

@@ -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

src/Dodge/Event.hs

@@ -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
+        | invKeyDown -> swapInvDir yi $ stopSoundFrom (CrReloadSound 0) $ changeInvPos yi w
-        | otherwise -> stopSoundFrom (CrReloadSound 0) $ dirInvPos 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

src/Dodge/Inventory.hs

@@ -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
+crNumFreeSlots :: Creature -> Int
---checkInvSlots :: Item -> IM.IntMap Item -> Maybe Int
+crNumFreeSlots cr = _crInvCapacity cr - invSize (_crInv cr)
---checkInvSlots it = checkInvSlotsH it . IM.toList
 
-itNotFull :: Item -> Bool
+crInvSize :: Creature -> Int
-itNotFull it = case it ^? itMaxStack of
+crInvSize = invSize . _crInv
-    Just themax -> themax > _itAmount it
-    Nothing -> False
 
-rmInvItem 
+invSize :: IM.IntMap Item -> Int
-    :: Int      -- ^ Creature id
+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,7 +57,7 @@ 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
+    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 
@@ -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
+changeInvPos :: Int -> World -> World
-dirInvPos i w =  w
+changeInvPos i w 
-    & creatures . ix (_yourID w) . crInvSel %~ (`mod` n) . subtract i
+    | 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)

src/Dodge/Item/Weapon/SprayGuns.hs

@@ -43,7 +43,7 @@ poisonSprayer = defaultAutoGun
         [ ammoCheckI
         , withSoundForI foamSprayLoopS 5
         , useAmmo 1
-        , spreadNumI
+--        , spreadNumI
         ] 
         & useAim . aimSpeed .~ 0.2
         & useAim . aimRange .~ 0

src/Dodge/Render/HUD.hs

@@ -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
+    , if _carteDisplay w
-    ]
-  where
-    selectionText = if _carteDisplay w
         then drawLocations cfig w
-        else drawInventory cfig w
+        else subInventoryDisplay cfig w `appendPic` displayInv 0 cfig w
-
+    ]
-
-drawInventory :: Configuration -> World -> Picture
-drawInventory cfig w = 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
+        [ --closeObjectTexts cfig w
---        , topInvCursor col cursPos 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)
+    itCol = fromMaybe (greyN 0.5) . (^? _Just . itInvColor)
-    cr = you w
+    --cr = you w
     it = yourItem w
     col = itCol it
-    cursPos = crInvSelPos cr
+    cursPos = invSelPos w
 
-crInvSelSize :: Creature -> Int
+--crInvSelSize :: Creature -> Int
-crInvSelSize cr = _itInvSize $ _crInv cr IM.! _crInvSel cr
+--crInvSelSize cr = fromMaybe 1 $ fmap _itInvSize $ _crInv cr IM.!? _crInvSel cr
 
-crInvSelPos :: Creature -> Int
+--crInvSelPos :: Creature -> Int
-crInvSelPos cr = sum . fmap _itInvSize . fst $ IM.split (_crInvSel cr) (_crInv cr)
+--crInvSelPos cr = foldl' (+) 0 . fmap _itInvSize . fst $ IM.split (_crInvSel cr) (_crInv cr)
 
-cursorsZ :: Configuration -> Int -> Item -> Picture
+invSelPos :: World -> Int
-cursorsZ cfig ipos it = case it ^? itTweaks . tweakSel of
+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 :: Maybe Item -> [String]
-ammoTweakStrings it = case it ^? itTweaks . tweakParams of
+ammoTweakStrings it = case it ^? _Just . itTweaks . tweakParams of
     Just l -> map tweakString $ IM.elems l
     _ -> ["NOT TWEAKABLE"]
 
-mCurs :: Item -> Configuration -> World -> Picture
+mCurs :: Maybe Item -> Configuration -> World -> Picture
-mCurs it cfig w = case it ^? itTweaks . tweakSel of
+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)))

src/Dodge/Render/List.hs

@@ -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 =
+renderListAt tx ty cfig = listTextPicturesAt tx ty cfig . map (\(str,col) -> color col $ text str)
-    concatMapPic (winScale cfig) . zipWith (listPairAt tx ty cfig) [0..]
+--    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

src/Dodge/Update/Camera.hs

@@ -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