Work on combine cursors

src/Dodge/Creature/Action.hs

@@ -178,9 +178,7 @@ dropExcept cr invid w =
         invid `IM.delete` _crInv cr
 
 dropItem :: Creature -> Int -> World -> World
-dropItem cr invid = rmInvItem cid invid . copyInvItemToFloor cr invid -- . mayberemoveequip
+dropItem cr invid = rmInvItem (_crID cr) invid . copyInvItemToFloor cr invid -- . mayberemoveequip
-  where
-    cid = _crID cr
 
 -- the following should be done in rmInvItem
 --    mayberemoveequip = case _crLeftInvSel cr of

src/Dodge/Data/SelectionList.hs

@@ -45,11 +45,7 @@ data SectionCursor = SectionCursor
 data SelectionSection a = SelectionSection
     { _ssItems :: IntMap (SelectionItem a)
     , _ssCursor :: Maybe SectionCursor
---    , _ssSelPos :: Maybe Int
---    , _ssSelSize :: Maybe Int
---    , _ssSelColor :: Maybe Color
     , _ssMinSize :: Int
-    --, _ssPriority :: Int
     , _ssOffset :: Int
     , _ssShownItems :: [Picture]
     , _ssIndent :: Int

src/Dodge/Inventory.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE TupleSections #-}
 
 module Dodge.Inventory (
+    selSecSelPos,
     ssLookupDown,
     ssLookupGT,
     ssSetCursor,
@@ -9,9 +10,9 @@ module Dodge.Inventory (
     rmSelectedInvItem,
     invSelSize,
     selNumPos,
-    selNumTextPos,
+    selNumTextEndPos,
     selNumCol,
-    selNumMidHeight,
+    selNumEndMidHeight,
     augmentedInvSizes,
     rmInvItem,
     updateCloseObjects,
@@ -63,9 +64,6 @@ rmInvItem cid invid w = case w ^? getcid . crInv . ix invid . itUse . useAmount
         w
             & pointcid . crInv %~ f
             & pointcid %~ crCancelReloading
-            -- & pointcid . crInvSel . iselPos %~ g THIS NEEDS CHECKING
-            -- & pointcid . crManipulation . manObject . inInventory . ispItem %~ g
-            -- & pointcid . crManipulation . manObject %~ h
             & pointcid . crLeftInvSel . lisMPos %~ g'
             & removeAnySlotEquipment
             & dounequipfunction
@@ -74,7 +72,6 @@ rmInvItem cid invid w = case w ^? getcid . crInv . ix invid . itUse . useAmount
             & pointcid . crInvEquipped %~ IM.mapKeys g
             & updatemanipulation
   where
-    -- TODO check whether this can be mapKeysMonotonic
 
     getcid = cWorld . lWorld . creatures . ix cid
     pointcid = cWorld . lWorld . creatures . ix cid
@@ -96,10 +93,10 @@ rmInvItem cid invid w = case w ^? getcid . crInv . ix invid . itUse . useAmount
     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
+    maxk = fmap fst $ IM.lookupMax $ cr ^. crInv
     f inv =
         let (xs, ys) = IM.split invid inv
-         in xs `IM.union` IM.mapKeys (subtract 1) ys
+         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
@@ -128,8 +125,18 @@ trimapAugmentInv f x g w =
   where
     n = length $ yourInv w
 
-invSelSize :: Int -> World -> Int
+selSecSelSize :: Int -> Int -> SelectionSections a -> Maybe Int
-invSelSize i w = fromMaybe 1 $ augmentedInvSizes w IM.!? i
+selSecSelSize i j sss = fmap length $ sss ^? sssSections . ix i . ssItems . ix j . siPictures
+
+invSelSize :: ManipulatedObject -> World -> Int
+invSelSize mo w = case mo of
+    InInventory (SelItem i _) -> fromMaybe 1 $ fmap itSlotsTaken
+        $ w ^? cWorld . lWorld . creatures . ix 0 . crInv . ix i
+    InNearby (SelCloseObject i) -> fromMaybe 1 $ fmap closeObjectSize
+        $ w ^? hud . closeObjects . ix i
+    InInventory SortInventory -> 1
+    InNearby SortNearby -> 1
+    SelNothing -> 1
 
 closeObjectSize :: Either FloorItem Button -> Int
 closeObjectSize e = case e of
@@ -141,23 +148,49 @@ closeObjectCol e = case e of
     Left flit -> _itInvColor $ _flIt flit
     Right _ -> yellow
 
-selNumPos :: Int -> World -> Int
+selSecSelPos :: Int -> Int -> SelectionSections a -> Maybe Int
-selNumPos i w = sum . fst $ IM.split i (augmentedInvSizes w)
+selSecSelPos i j sss = do
-
+    ss <- sss ^? sssSections . ix i
-selNumTextPos :: Configuration -> World -> Int -> Point2
+    return . (secpos +) 
-selNumTextPos cfig w i = V2 (150 - hw) (hh - (20 * fromIntegral ipos + 20))
+        . subtract (ss ^. ssOffset) 
+        . sum 
+        . fmap (length . _siPictures) 
+        . fst $ IM.split j (ss ^. ssItems)
   where
+    secpos = sum . fmap (length . _ssItems) . fst $ IM.split i $ sss ^. sssSections
+
+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
-    ipos = selNumPos i w
 
-selNumMidHeight :: Configuration -> World -> Int -> Point2
+selNumEndMidHeight :: Configuration -> ListDisplayParams -> SelectionSections a -> Int 
-selNumMidHeight cfig w i = V2 (150 - hw) (hh + bump - (20 * fromIntegral ipos + 7.5))
+    -> 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
-    ipos = selNumPos i w
-    bump = negate $ 10 * fromIntegral (invSelSize i w)
 
 selNumCol :: Int -> World -> Color
 selNumCol i w = fromMaybe white $ trimapAugmentInv _itInvColor invDimColor closeObjectCol w IM.!? i

src/Dodge/Render/HUD.hs

@@ -4,6 +4,7 @@ module Dodge.Render.HUD (
     invDisplayParams,
 ) where
 
+import Dodge.Inventory
 import SelectionIntMap
 import Dodge.Data.Combine
 import Dodge.Default.SelectionList
@@ -19,9 +20,6 @@ import Dodge.Data.CardinalPoint
 import Dodge.Data.Config
 import Dodge.Data.SelectionList
 import Dodge.Data.World
-import Dodge.Inventory
---import Dodge.Inventory.ItemSpace
---import Dodge.Item.Display
 import Dodge.Item.Info
 import Dodge.Render.Connectors
 import Dodge.Render.List
@@ -167,15 +165,20 @@ drawNoSubInventory cfig w =
         , rboptions
         ]
   where
-    equipcursor = case cr ^. crLeftInvSel . lisMPos of
+    equipcursor = fromMaybe mempty $ do
-        Just invid -> f cyan invid (_crInvEquipped cr IM.! invid)
+        invid <- cr ^. crLeftInvSel . lisMPos
-        _ -> mempty
+        sss <- w ^? hud . hudElement . diSections
+        pos <- selSecSelPos 0 invid sss
+        return $ listTextPictureAt 144 0 cfig pos . color cyan . text . eqPosText $_crInvEquipped cr IM.! invid
+    f col invid epos = fromMaybe mempty $ do
+        sss <- w ^? hud . hudElement . diSections
+        pos <- selSecSelPos 0 invid sss
+        return $ listTextPictureAt 144 0 cfig pos . color col $ text $ eqPosText epos
     equipcursors = IM.foldMapWithKey (f yellow) (_crInvEquipped cr)
     cr = you w
     rboptions
         | ButtonRight `M.member` _mouseButtons (_input w) = drawRBOptions cfig w (_rbOptions w)
         | otherwise = mempty
-    f col invid epos = listTextPictureAt 144 0 cfig (selNumPos invid w) . color col $ text $ eqPosText epos
 
 examineInventoryExtra :: Maybe Int -> Maybe Item -> Configuration -> Picture
 examineInventoryExtra mtweaki mitm cfig = fromMaybe mempty $ do
@@ -199,9 +202,14 @@ combineInventoryExtra sm mi cfig w = fromMaybe mempty $ do
                 lnks <- sm ^? smShownItems . ix i . siPayload . ciInvIDs
                 return $
                     lnkMidPosInvSelsCol cfig w cpos col lnks
-                        <> foldMap (topCursorTypeWidth listCursorNESW (topInvW + 2) cfig w) lnks
+                        -- <> foldMap (topCursorTypeWidth listCursorNESW (topInvW + 2) cfig w) lnks
+                        <> foldMap invcursor lnks
                         <> combineCounts cfig w lnks
             ]
+  where
+    invcursor i = fromMaybe mempty $ do
+        sss <- w ^? hud . hudElement . diSections
+        return $ selSecDrawCursor 17 [North,South,East] cfig (invDisplayParams w) sss 0 i
 
 secondColumnParams :: ListDisplayParams
 secondColumnParams =
@@ -304,16 +312,21 @@ subInvX = 9 * fromIntegral topInvW + 50
 combineCounts :: Configuration -> World -> [Int] -> Picture
 combineCounts cfig w = winScale cfig . foldMap f . group
   where
-    f (i : is) = case yourInv w ^? ix i . itUse . useAmount of
+    f (i : is) = fromMaybe mempty $ do
-        Just _ -> color (selNumCol i w) $ uncurryV translate (selNumTextPos cfig w i) . scale 0.1 0.1 . text $ ('-' : show (length is + 1))
+        _ <- yourInv w ^? ix i . itUse . useAmount
-        _ -> mempty
+        sss <- w ^? hud . hudElement . diSections
+        p <- selNumTextEndPos cfig (invDisplayParams w) sss 0 i
+        return $ color (selNumCol i w) $ uncurryV translate p . scale 0.1 0.1 . text $ ('-' : show (length is + 1))
     f _ = mempty
 
 lnkMidPosInvSelsCol :: Configuration -> World -> Int -> Color -> [Int] -> Picture
-lnkMidPosInvSelsCol cfig w i col =
+lnkMidPosInvSelsCol cfig w i col = winScale cfig
-    winScale cfig
+        . foldMap f
-        . foldMap (\j -> zConnectCol rp (V2 18 0 + selNumMidHeight cfig w j) col white white (selNumCol j w))
   where
+    f j = fromMaybe mempty $ do
+        sss <- w ^? hud . hudElement . diSections
+        h <- selNumEndMidHeight cfig (invDisplayParams w) sss 0 j
+        return $ zConnectCol rp (V2 18 0 + h) col white white (selNumCol j w)
     rp = V2 (190 - hw) (hh - (20 * fromIntegral i + 77.5))
     hh = halfHeight cfig
     hw = halfWidth cfig
@@ -326,7 +339,7 @@ topCursorTypeWidth ::
     Int ->
     Picture
 topCursorTypeWidth ctype width cfig w i =
-    ctype 0 0 cfig (selNumPos i w) 0 (selNumCol i w) width (invSelSize i w)
+    ctype 0 0 cfig (fromMaybe 0 (selNumPos (InInventory (SelItem i NoInvSelAction)) w)) 0 (selNumCol i w) width (invSelSize (InInventory (SelItem i NoInvSelAction)) w)
 
 determineInvSelCursorWidth :: World -> Int
 determineInvSelCursorWidth w = case _rbOptions w of

src/Dodge/Render/List.hs

@@ -1,6 +1,7 @@
 module Dodge.Render.List where
 
 --import Picture.Text
+import Dodge.Inventory
 import SelectionIntMap
 import qualified Data.IntMap.Strict as IM
 --import Data.Foldable
@@ -109,6 +110,13 @@ stackPicturesAt tx ty cfig = stackPicturesAtOff tx ty cfig 0
 stackPicturesAtOff :: Float -> Float -> Configuration -> Int -> [Picture] -> Picture
 stackPicturesAtOff tx ty cfig i = mconcat . zipWith (listTextPictureAt tx ty cfig) [i, i -1 ..]
 
+selSecDrawCursor :: Int -> [CardinalPoint] -> Configuration -> ListDisplayParams -> SelectionSections a -> Int -> Int -> Picture
+selSecDrawCursor xsize borders cfig ldp sss i j = fromMaybe mempty $ do
+    yint <- selSecSelPos i j sss
+    xint <- sss ^? sssSections . ix i . ssIndent
+    si <- sss ^? sssSections . ix i . ssItems . ix j
+    return $ listCursorDisplayParams ldp borders cfig yint xint (_siColor si) xsize (length $ _siPictures si)
+
 listCursorDisplayParams :: 
     ListDisplayParams ->
     [CardinalPoint] ->
@@ -153,7 +161,7 @@ listCursorChooseBorderScale ygap s borders xoff yoff cfig yint xint col cursxsiz
   where
     x = 9
     wth = x * fromIntegral cursxsize + 9
-    hgt = 20 * fromIntegral cursysize
+    hgt = 20 * fromIntegral cursysize -- TODO this should be changed!
 
 -- displays a cursor that should match up to list text pictures
 -- the width of a character appears to be 9(?!)