Make combine and tweak menus servicable

src/Dodge/Combine.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE TupleSections #-}
+--{-# LANGUAGE TupleSections #-}
 module Dodge.Combine where
 import Dodge.Base.You
 import Dodge.Data
@@ -13,6 +13,7 @@ import qualified Data.IntMap.Strict as IM
 --import qualified Data.IntSet as IS
 import qualified Data.Map.Strict as M
 import Data.Maybe
+import Data.List (scanl')
 
 itemCombinations :: [ (M.Map CombineType Int, Item) ]
 itemCombinations = map (first toMultiset) $
@@ -53,8 +54,8 @@ combineItemList m = mapMaybe (pushoutmaybe . second combineToItem)
 itemsMultisets :: [(Int,Item)] -> [([Int],M.Map CombineType Int)]
 itemsMultisets = map mconcat . mapM itemMultisets
 
--- individual items can produce multiple multisets if they are a stack of more
+-- "individual" items can produce multiple multisets if they are in fact
--- than one item
+-- a stack of more than one item
 itemMultisets :: (Int,Item) -> [([Int],M.Map CombineType Int)]
 itemMultisets (i,it) = case it ^? itConsumption . itAmount' of
     Nothing -> [ ([i], M.singleton thetype 1 ) ]
@@ -66,7 +67,7 @@ itemMultisets (i,it) = case it ^? itConsumption . itAmount' of
 itemTypeAmounts :: Item -> [[CombineType]]
 itemTypeAmounts it = case it ^? itConsumption . itAmount' of
     Nothing -> [[thetype]]
-    Just i  -> map (flip replicate thetype) [1 .. i]
+    Just i  -> map (`replicate` thetype) [1 .. i]
   where
     thetype = _itCombineType it
 
@@ -84,7 +85,13 @@ toggleCombineInv w = case _inventoryMode w of
 enterCombineInv :: World -> World
 enterCombineInv w = w & inventoryMode .~ CombineInventory mi
   where
-    mi = const 0 <$> listToMaybe (combineListYou w)
+    mi = 0 <$ listToMaybe (combineListYou w)
 
 combine :: M.Map CombineType Int -> Maybe CombineType
 combine m = lookup m combinations
+
+combineSizes :: World -> [Int]
+combineSizes = map (ceiling . _itInvSize . snd) . combineItemListYou
+
+combinePoss :: World -> [Int]
+combinePoss = scanl' (+) 0 . combineSizes

src/Dodge/Creature.hs

@@ -164,8 +164,7 @@ startCr = defaultCreature
 {- | Items you start with.  -}
 startInvList :: [Item]
 startInvList =
-    [ miniGun
+    [ 
-    , hvAutoGun
     ]
 startInventory :: IM.IntMap Item
 startInventory = IM.fromList $ zip [0..] startInvList

src/Dodge/Creature/Impulse/UseItem.hs

@@ -38,20 +38,13 @@ itemEffect cr it w = case it ^? itUse of
 
 --this is ugly
 useLeftItem :: Int -> World -> World
-useLeftItem cid w = case _crInv cr IM.! crinvsel ^? itUse . lUse of
+useLeftItem cid w = case cr ^? crInv . ix crinvsel . itUse . lUse of
     Just f -> f cr crinvsel (w & creatures . ix cid . crLeftInvSel ?~ crinvsel)
     Nothing -> case _crLeftInvSel cr of
         Just invid -> case _itUse $ _crInv cr IM.! invid of
             LeftUse {_lUse = f}  -> f cr invid w
             _ -> w & creatures . ix cid . crLeftInvSel .~ Nothing
         Nothing -> w
---        Nothing -> case luse of
---            Nothing -> w
---            Just (invid, f) -> f cr invid w & creatures . ix cid . crLeftInvSel ?~ invid
   where
     crinvsel = _crInvSel cr 
     cr = _creatures w IM.! cid
---    luses = IM.mapMaybe (^? itUse . lUse) (_crInv cr)
---    luse = listToMaybe $ IM.toList luses
---the old code automatically selected the first unused item in the list: not
---sure if I want this behaviour, can probably set it as an option later

src/Dodge/Creature/Picture.hs

@@ -166,7 +166,6 @@ arms cr
         Just (Walking sa RightForward) -> waistSH $ translateSHf (-f sa) off    aHand
         _ -> emptySH 
   where
-    --crIt = _crInv cr IM.! _crInvSel cr
     aHand :: Shape
     aHand = translateSHz (-4) . upperPrismPolyHalf 4 $ polyCirc 3 4
     off = 8
@@ -182,20 +181,18 @@ scalp cr
   where
     fhead = colorSH (greyN 0.9) . upperPrismPolyHalf 5 $ polyCirc 4 5
 
+crInStance :: AimStance -> Creature -> Bool
+crInStance as cr = crIsAiming' cr 
+    && cr ^? crInv . ix (_crInvSel cr) . itUse . useAim . aimStance == Just as
+
 oneH :: Creature -> Bool
-oneH cr = crIsAiming' cr && crIt ^? itUse . useAim . aimStance == Just OneHand
+oneH = crInStance OneHand
-  where
-    crIt = _crInv cr IM.! _crInvSel cr
 
 twoFlat :: Creature -> Bool
-twoFlat cr = crIsAiming' cr && crIt ^? itUse . useAim . aimStance == Just TwoHandFlat
+twoFlat = crInStance TwoHandFlat
-  where
-    crIt = _crInv cr IM.! _crInvSel cr
 
 twists :: Creature -> Bool
-twists cr = crIsAiming' cr && crIt ^? itUse . useAim . aimStance == Just TwoHandTwist
+twists = crInStance TwoHandTwist
-  where
-    crIt = _crInv cr IM.! _crInvSel cr
 
 torso :: Creature -> Shape
 {-# INLINE torso #-}
@@ -244,9 +241,7 @@ light4 = light . light . light . light
 --  where
 --    setPos = translate 0 (_crRad cr)
 
-drawEquipment 
+drawEquipment :: Creature -> SPic
-    :: Creature 
-    -> SPic
 {-# INLINE drawEquipment #-}
 drawEquipment cr = mconcat $ map f $ IM.toList (_crInv cr)
   where 

src/Dodge/Inventory.hs

@@ -1,13 +1,18 @@
+{-# LANGUAGE TupleSections #-}
 module Dodge.Inventory
     ( checkInvSlotsYou
     , rmSelectedInvItem
     , invSelPos
     , invSelSize
     , selNumPos
+    , selNumCol
+    , selNumSlots
+    , selNumMidHeight
     , augmentedInvSizes
     , rmInvItem
     , updateCloseObjects
     , closeObjScrollDir
+    , closeObjectCol
 --    , swapInvDir
     , changeInvSel
     , changeSwapInvSel
@@ -22,12 +27,14 @@ import Dodge.Inventory.CloseObject
 import Dodge.Inventory.CheckSlots
 import Dodge.Inventory.ItemSpace
 import Dodge.Base
+import Dodge.Base.Window
 import Dodge.Base.Collide
 import Geometry
 --import FoldableHelp
 import Padding
 import qualified IntMapHelp as IM
 import ListHelp
+import Color
 
 import Data.Maybe
 --import Data.List
@@ -69,7 +76,13 @@ 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))
@@ -78,6 +91,17 @@ selNumPos i w = splitgap + (foldl' (+) 0 . fst $ IM.split i (augmentedInvSizes w
         | i < length (yourInv w) = 0
         | otherwise = 1
 
+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
@@ -156,12 +180,12 @@ bestCloseObjectIndex w = findIndex f $ _closeObjects w
 
 selectedCloseObject :: World -> Maybe (Int,Either FloorItem Button)
 selectedCloseObject w
-    | invsel >= length inv = Just $ selectNthCloseObject w (invsel - length inv)
+    | invsel >= length inv = selectNthCloseObject w (invsel - length inv)
-    | otherwise = selectNthCloseObject w <$> bestCloseObjectIndex w
+    | otherwise = selectNthCloseObject w =<< bestCloseObjectIndex w
   where
     invsel = _crInvSel cr
     cr = you w
     inv = _crInv cr
 
-selectNthCloseObject :: World -> Int -> (Int,Either FloorItem Button)
+selectNthCloseObject :: World -> Int -> Maybe (Int,Either FloorItem Button)
-selectNthCloseObject w n = (length (yourInv w) + n, _closeObjects w !! n)
+selectNthCloseObject w n = (length (yourInv w) + n,) <$> (_closeObjects w !? n)

src/Dodge/Inventory/Add.hs

@@ -11,7 +11,7 @@ putItemInInvID cid flid w = fromMaybe w
     $ tryPutItemInInv cid (_floorItems w IM.! flid) w
 
 putItemInInvSlot :: Int -> Item -> IM.IntMap Item -> IM.IntMap Item
-putItemInInvSlot invsel it = IM.insertWith (const $ itConsumption . itAmount' +~ 1) invsel it
+putItemInInvSlot = IM.insertWith (const $ itConsumption . itAmount' +~ 1)
 
 {- | Pick up a specific item. -}
 tryPutItemInInv :: Int -> FloorItem -> World -> Maybe World

src/Dodge/Item/Weapon/BulletGuns.hs

@@ -126,6 +126,7 @@ bangStick i = defaultGun
             }
         }
     , _itTweaks = defaultBulletSelTweak
+    , _itInvSize = fromIntegral i / 3
     }
 bangCane,bangRod :: Item
 bangCane = defaultGun
@@ -225,9 +226,9 @@ hvAutoGun = defaultAutoGun
         & useDelay .~ VariableRate {_rateMax = 25, _rateMaxMax = 24, _rateMinMax = 7, _rateTime = 0}
     , _itFloorPict = hvAutoGunPic
     , _itInvSize = 3
-    , _itInvDisplay = \it -> basicItemDisplay it ++ 
+    , _itInvDisplay = \it -> head (basicItemDisplay it) : 
-        ["* FRATE: *"
+        ["* FIRERATE:   *"
-        ,"* " ++ fromMaybe "    " (maybeRateStatus it) ++ " *"
+        ,"*     " ++ fromMaybe "    " (maybeRateStatus it) ++ "  *"
         ]
     }
 hvAutoGunPic :: Item -> SPic
@@ -340,10 +341,10 @@ miniGun = defaultAutoGun
     , _itEquipPict = pictureWeaponAim miniGunPictItem
     , _itTweaks = defaultBulletSelTweak
     , _itInvSize = 4
-    , _itInvDisplay = \it -> basicItemDisplay it ++ 
+    , _itInvDisplay = \it -> head (basicItemDisplay it) : 
-        ["*" ++ replicate 8 ' ' ++ "*"
+        ["*" ++ replicate 13 ' ' ++ "*"
-        ,"*  " ++ fromMaybe "    " (maybeWarmupStatus it) ++ "  *"
+        ,"*    " ++ fromMaybe "    " (maybeWarmupStatus it) ++ "     *"
-        ,"*" ++ replicate 8 ' ' ++ "*" ]
+        ,"*" ++ replicate 13 ' ' ++ "*" ]
 --        ["  " ++ replicate 8 ch
 --        ,"  " ++ replicate 2 ch ++ fromMaybe "    " (maybeWarmupStatus it) ++ replicate 2 ch
 --        ,"  " ++ replicate 8 ch]

src/Dodge/Item/Weapon/InventoryDisplay.hs

@@ -16,8 +16,8 @@ import Control.Lens
 {- | Displays the item name, ammo if loaded, and any selected '_itCharMode'.  -}
 basicItemDisplay :: Item -> [String]
 basicItemDisplay it = Prelude.take (itSlotsTaken it) $
-    [midPadL 15 ' ' thename (' ' : thenumber) ++ theparam]
+    (midPadL 15 ' ' thename (' ' : thenumber) ++ theparam)
-    ++ repeat "*"
+    : repeat "*"
   where 
     thename  = _itName it
     thenumber = case it ^? itConsumption of

src/Dodge/Item/Weapon/Launcher.hs

@@ -69,12 +69,8 @@ launcher = defaultGun
         , _tweakParams = basicAmPjMoves
         }
     , _itInvSize = 3
-    , _itInvDisplay = \it -> basicItemDisplay it ++ 
+    , _itInvDisplay = basicItemDisplay
-        ["!" ++ replicate 8 ch ++ "!"
-        ,"!" ++ replicate 8 ch ++ "!"]
     }
-  where
-    ch = ' '
 
 defaultShellAmmo :: AmmoType
 defaultShellAmmo = ProjectileAmmo

src/Dodge/Item/Weapon/TriggerType.hs

@@ -402,13 +402,13 @@ spreadLoaded :: ChainEffect
 spreadLoaded eff item cr w = foldr f w dirs
   where
     cd = 0.5 * spread * fromIntegral (numBulLoaded -1)
-    ds = (subtract cd . (spread *) . fromIntegral) <$> [0 .. numBulLoaded - 1]
+    ds = subtract cd . (spread *) . fromIntegral <$> [0 .. numBulLoaded - 1]
 --    dirs = ds
     dirs = zipWith (+) 
         ds
         (randomRs (-spread,spread) (_randGen w))
     f dir = eff item (cr & crDir +~ dir)
-    spread = (_spreadAngle . _brlSpread . _gunBarrels $ _itParams item)
+    spread = _spreadAngle . _brlSpread . _gunBarrels $ _itParams item
 --    numBarrels = _brlNum . _gunBarrels $ _itParams item
 --    spread = (_spreadAngle . _brlSpread . _gunBarrels $ _itParams item) * loadedSpreadParam
 --    loadedSpreadParam = 0.5 * (fromIntegral (numBulLoaded - numBarrels) + 1)

src/Dodge/Render/HUD.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE TupleSections #-}
+--{-# LANGUAGE TupleSections #-}
 module Dodge.Render.HUD
     ( hudDrawings
     ) where
@@ -27,77 +27,133 @@ import SDL (MouseButton (..))
 --import Data.Bifunctor
 
 hudDrawings :: Configuration -> World -> Picture
-hudDrawings cfig w = pictures
+hudDrawings cfig w = if _carteDisplay w
+    then drawCarte cfig w
+    else drawInGameHUD cfig w
+
+drawInGameHUD :: Configuration -> World -> Picture
+drawInGameHUD cfig w = pictures
     [ winScale cfig . dShadCol white $ displayHP 0 cfig w
-    , renderListAt (halfWidth cfig) 0 cfig $ map (,white) (_testString w w)
+    , listTextPicturesAt (halfWidth cfig) 0 cfig $ map text (_testString w w)
-    , if _carteDisplay w
+    , inventoryDisplay cfig w
-        then drawLocations cfig w
+    , subInventoryDisplay cfig w
-        else subInventoryDisplay cfig w `appendPic` displayInv 0 cfig w
     ]
 
+inventoryDisplay :: Configuration -> World -> Picture
+inventoryDisplay cfig w = listTextPicturesAt 0 0 cfig invlist
+    <> equipcursor
+  where
+    cr = you w
+    inv = _crInv cr
+    invlist = concatMap itemText (IM.elems inv)
+        ++ displayFreeSlots 
+        ++ map floorItemsColor (concatMap (closeObjectToTextPictures nfreeslots) (_closeObjects w))
+    floorItemsColor
+        | _inventoryMode w == TopInventory = id
+        | otherwise = color invDimColor
+    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"]
+    equipcursor = case _crLeftInvSel cr of
+        Nothing -> mempty
+        Just invid -> listCursorNES 0 0 cfig (selNumPos invid w) yellow topInvW 
+            (selNumSlots invid w)
+    
+
 subInventoryDisplay :: Configuration -> World -> Picture
 subInventoryDisplay cfig w = case _inventoryMode w of
     LockedInventory -> mempty -- topInvCursor col cursPos cfig w
     TopInventory -> pictures
-        [ --closeObjectTexts cfig w 
+        [ selcursor
-        selcursor
+        , closeobjectcursor
         ]
     TweakInventory -> pictures
-        [ mCurs it cfig w
+        --[ mCurs it cfig w
-        , cursorAt 120 col 5 0 cursPos cfig
+        [ selcursor' listCursorNESW
-        , cursorsZ cfig cursPos it
+--        , cursorsZ cfig curpos it
-        , displayMidList cfig (ammoTweakStrings it) "TWEAK"
+        , fromMaybe mempty $ do
+            tweaki <-  it ^? _Just . itTweaks . tweakSel
+                -- consider moving this functionality out into a tweaks module
+            showtweak <- it ^? _Just . itTweaks . tweakParams . ix tweaki . showTweak
+            tweakname <- it ^? _Just . itTweaks . tweakParams . ix tweaki . nameTweak
+            tweakstring <- showtweak <$> (it ^? _Just . itTweaks . tweakParams . ix tweaki . curTweak)
+            return $ lnkMidInvSel cfig w curpos tweaki
+                <> listCursorNSW subInvX 60 cfig tweaki white (length $ tweakstring ++ tweakname) 1
+        , invHead cfig "TWEAK"
+        , listTextPicturesAt subInvX 60 cfig $ map text (ammoTweakStrings it)
         ]
     CombineInventory mi -> pictures
         [ invHead cfig "COMBINE"
-        , listTextPicturesAt 150 60 cfig $ map text $ combineListStrings w
+        , listTextPicturesAt subInvX 60 cfig $ combineListStringPictures w
         , fromMaybe mempty $ do
             i <- mi
-            return $ listCursorAt 150 60 cfig i white 10 1
+            cpos  <- combinePoss  w !? i
+            csize <- combineSizes w !? i
+            col   <- (combineItemListYou w !? i) <&> _itInvColor . snd
+            return $ listCursorNSW subInvX 60 cfig cpos col 15 csize
         , fromMaybe mempty $ do
             i <- mi
             lnks <- combineListLnks w !? i
             return $ uncurry (lnkMidPosInvSels cfig w) lnks 
+                <> foldMap (cursorAtInvSel listCursorNESW cfig w) (snd lnks)
         ]
     InspectInventory -> invHead cfig "INSPECT"
   where 
-    itCol = fromMaybe (greyN 0.5) . (^? _Just . itInvColor)
+    closeobjectcursor = case selectedCloseObject w of
+        Nothing -> mempty
+        Just (i,co) -> listCursorNS clObjFloatIn 0 cfig (selNumPos i w) (closeObjectCol co) topInvW (invSelSize i w)
+    itcol = fromMaybe (greyN 0.5) (it ^? _Just . itInvColor)
     --cr = you w
     it = yourItem w
-    col = itCol it
+    selcursor' ct = fromMaybe mempty $ ct 0 0 cfig curpos itcol topInvW cury <$ it
-    cursPos = invSelPos w
+    selcursor = selcursor' selcursortype
-    selcursor 
+    selcursortype
-        | IM.null inv && null (_closeObjects w) = mempty
+        | ButtonRight `S.member` _mouseButtons w = listCursorNESW
-        | otherwise   = listCursorAt 0 0 cfig curpos white curx cury
+        | otherwise = listCursorNSW
-    inv = _crInv cr
     curpos = invSelPos w
-    curx   = 10
     cury   = fromMaybe 1 $ augmentedInvSizes w IM.!? _crInvSel (you w)
-    cr = _creatures w IM.! 0
+
+topInvW :: Int
+topInvW = 15
+
+subInvX :: Float
+subInvX = 9 * fromIntegral topInvW + 50
+
+lnkMidInvSel :: Configuration -> World -> Int -> Int -> Picture
+lnkMidInvSel cfig w lefti midi = winScale cfig
+    . color white 
+    . zConnect rp $ selNumMidHeight cfig w lefti
+  where
+--    lp ipos = V2 (150 - hw) ( hh - (20 * fromIntegral ipos + 17.5))
+    rp = V2 (190 - hw) ( hh - (20 * fromIntegral midi + 77.5))
+    hh = halfHeight cfig
+    hw = halfWidth  cfig
+    
 
 lnkMidPosInvSels :: Configuration -> World -> Int -> [Int] -> Picture
-lnkMidPosInvSels cfig w i is = winScale cfig . color white 
+lnkMidPosInvSels cfig w i = winScale cfig 
-    .  concatMap
+    . color white 
-    (zConnect rp) $ map (lp . flip selNumPos w) is
+    . concatMap (zConnect rp . selNumMidHeight cfig w)
   where
-    lp ipos = V2 (125 - hw) ( hh - (20 * fromIntegral ipos + 17.5))
+--    lp ipos = V2 (150 - hw) ( hh - (20 * fromIntegral ipos + 17.5))
-    rp = (V2 (155 - hw) ( hh - (20 * fromIntegral i + 77.5)))
+    rp = V2 (190 - hw) ( hh - (20 * fromIntegral i + 77.5))
     hh = halfHeight cfig
     hw = halfWidth  cfig
 
-cursorsZ :: Configuration -> Int -> Maybe Item -> Picture
+cursorAtInvSel ::  (Float -> Float -> Configuration -> Int -> Color -> Int -> Int -> Picture)
-cursorsZ cfig ipos it = case it ^? _Just . itTweaks . tweakSel of
+    -> Configuration -> World -> Int -> Picture
-    Nothing   -> f $ zConnect sp (V2 (155- hw) ( hh - 77.5))
+cursorAtInvSel ctype cfig w i 
-    Just jpos -> f $ zConnect sp (V2 (155 - hw) ( hh - (20 * fromIntegral jpos + 77.5)))
+    = ctype 0 0 cfig (selNumPos i w) (selNumCol i w) topInvW (selNumSlots i w)
-  where
-    f = winScale cfig . color white
-    hh = halfHeight cfig
-    hw = halfWidth  cfig
-    sp = V2 (125 - hw) ( hh - (20 * fromIntegral ipos + 17.5))
 
+--listSelHeight :: Configuration -> World -> Int -> Float
+--listSelHeight
 
-combineListStrings :: World -> [String]
+combineListStringPictures :: World -> [Picture]
-combineListStrings = map (show . snd) . combineListYou
+combineListStringPictures w = case concatMap (itemText . snd) . combineItemListYou $ w of
+    [] -> [text "NO POSSIBLE COMBINATIONS"]
+    xs -> xs
 
 combineListLnks :: World -> [(Int,[Int])]
 combineListLnks = zip [0..] . map fst . combineListYou
@@ -107,61 +163,16 @@ ammoTweakStrings it = case it ^? _Just . itTweaks . tweakParams of
     Just l -> map tweakString $ IM.elems l
     _ -> ["NOT TWEAKABLE"]
 
-mCurs :: Maybe Item -> Configuration -> World -> Picture
-mCurs it cfig w = case it ^? _Just . itTweaks . tweakSel of
-    Nothing -> []
-    Just i 
-        | ButtonRight `S.member` _mouseButtons w -> 
-            pictures 
-            [cursorAt x white y 60 i cfig
-            ,openCursorAt 20 white (x+y) 60 i cfig
-            ]
-        | otherwise -> openCursorAt 140 white 155 60 i cfig
-  where
-    x = 117.5
-    y = 155
-
 tweakString :: TweakParam -> String
 tweakString tp = rightPad 12 ' ' (_nameTweak tp) ++ " " ++ _showTweak tp (_curTweak tp)
 
-displayMidList :: Configuration -> [String] -> String -> Picture
-displayMidList cfig strs s = invHead cfig s
-    `appendPic` renderListAt 150 (-60) cfig (strs <&> (,white))
-
 invHead :: Configuration -> String -> Picture
 invHead cfig s = winScale cfig 
-    . translate (-130) (halfHeight cfig - 40) 
+    . translate (-halfWidth cfig + subInvX + 20) (halfHeight cfig - 40) 
     . dShadCol white
     . scale 0.4 0.4
     $ text s
 
---renderItemMapAt :: Float -> Float -> Configuration -> IM.IntMap Item -> Picture
---{-# 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 invlist
-    <> equipcursor
-    <> closeobjectcursor
-  where
-    closeobjectcursor = case selectedCloseObject w of
-        Nothing -> mempty
-        Just (i,_) -> listCursorAt 50 0 cfig (selNumPos i w) blue 15 (invSelSize i w)
-    inv = _crInv cr
-    invlist = concatMap itemText (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   = fromMaybe 1 $ augmentedInvSizes w IM.!? _crInvSel (you w)
-    equipcursor = case _crLeftInvSel cr of
-        Nothing -> mempty
-        Just invid -> openCursorAt 20 yellow 0 0 (selNumPos invid w) cfig
-    cr = _creatures w IM.! n
 invDimColor :: Color
 invDimColor = greyN 0.7
 closeObjectToTextPictures :: Int -> Either FloorItem Button -> [Picture]
@@ -169,13 +180,19 @@ 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 . ("  "++)
+    textindent = text . (replicate clObjIntIn ' '++)
     applycolor it
         | nfreeslots >= itSlotsTaken it = color $ _itInvColor it
         | otherwise = color invDimColor
 
-drawLocations :: Configuration -> World -> Picture
+clObjIntIn :: Int
-drawLocations cfig w = pictures $ 
+clObjIntIn = 2
+clObjFloatIn :: Float
+clObjFloatIn = fromIntegral clObjIntIn * 9
+
+
+drawCarte :: Configuration -> World -> Picture
+drawCarte cfig w = pictures $ 
     renderListAt 0 0 cfig locs
     : zipWith bConnect (displayListEndCoords cfig locTexts) locPoss
     ++ mapOverlay cfig w
@@ -247,12 +264,13 @@ mainListCursor c = openCursorAt 120 c 5 0
 
 itemText :: Item -> [Picture]
 {-# INLINE itemText #-}
-itemText it = case _itCurseStatus it of
+itemText it = f $ case _itCurseStatus it of
     UndroppableIdentified -> map (color yellow . text) (_itInvDisplay it it)
 --        <> color (withAlpha 0.9 thecolor) (polygon (rectNSEW 110 (-65) 885 (-90)))
     _ -> map (color thecolor . text) (_itInvDisplay it it)
   where
     thecolor = _itInvColor it
+    f = take (itSlotsTaken it) . (++ replicate 10 (color (_itInvColor it) $ text "*"))
     
 
 openCursorAt 
@@ -271,24 +289,6 @@ openCursorAt wth col xoff yoff yint w = winScale w
         ,(V2  0   (-7.5),col)
         ,(V2  wth (-7.5),withAlpha 0 col)
         ]
-cursorAt 
-    :: Float    -- ^ Width
-    -> Color
-    -> Float    -- ^ x offset
-    -> Float    -- ^ y offset
-    -> Int      -- ^ y offset (discrete)
-    -> Configuration 
-    -> Picture
-cursorAt wth col xoff yoff yint cfig = winScale cfig
-    . translate (xoff-halfWidth cfig) (halfHeight cfig - (20* fromIntegral yint + yoff) - 20)
-    . color col
-    $ line 
-        [V2  wth 12.5
-        ,V2  0   12.5
-        ,V2  0   (-7.5)   
-        ,V2  wth (-7.5) 
-        ,V2  wth 12.5 
-        ]
 
 displayHP :: Int -> Configuration -> World -> Picture
 displayHP cid cfig w = translate (halfWidth cfig-80) (halfHeight cfig-20) 

src/Dodge/Render/List.hs

@@ -4,34 +4,51 @@ import Dodge.Base.Window
 import Dodge.WinScale
 import Picture
 import Geometry
+--import Control.Monad
+import Data.Maybe
 
 -- given a list of pictures that are each the size of a "text" call, displays them as
 -- a list on the screen
 listTextPicturesAt :: Float -> Float -> Configuration -> [Picture] -> Picture
 listTextPicturesAt tx ty cfig = mconcat . zipWith (listTextPictureAt tx ty cfig) [0..]
 
+
 -- displays a cursor that should match up to list text pictures
 -- the width of a character appears to be 9(?!)
-listCursorAt :: Float -> Float -> Configuration -> Int -> Color -> Int -> Int -> Picture
+-- this is probably because it is 8 pixels plus one for the border
-listCursorAt xoff yoff cfig yint col cursxsize cursysize = winScale cfig
+listCursorChooseBorder :: [Bool] -> Float -> Float -> Configuration -> Int -> Color -> Int -> Int -> Picture
-    . translate (10.5+xoff-halfWidth cfig) (halfHeight cfig - (20* fromIntegral yint + yoff) - 20)
+listCursorChooseBorder borders xoff yoff cfig yint col cursxsize cursysize = winScale cfig
-    $  lineCol 
+    . translate (6+xoff-halfWidth cfig) 
-        [(V2  0   12.5  , col)
+        (halfHeight cfig + 12.5 - (20* fromIntegral yint + yoff + 20 + hgt))
-        ,(V2  wth 12.5  ,col)
+    . color col
-        ] <>
+    $ chooseCursorBorders wth hgt borders
-        lineCol
-        [(V2  0   (12.5 - hgt),col)
-        ,(V2  wth (12.5 - hgt),col)
-        ]
-        --[(V2  wth 12.5  ,withAlpha 0 col)
-        --,(V2  0   12.5  ,col)
-        --,(V2  0   (12.5 - hgt),col)
-        --,(V2  wth (12.5 - hgt),withAlpha 0 col)
-        --]
   where
     x = 9
-    wth =  x * fromIntegral cursxsize
+    wth =  x * fromIntegral cursxsize + 9
     hgt = 20 * fromIntegral cursysize
+-- note we cannot simply scale lines because they are drawn as solid rectangles
+chooseCursorBorders :: Float -> Float -> [Bool] -> Picture
+chooseCursorBorders wth hgt = concat . catMaybes . zipWith f
+    [ line [V2   0 hgt , V2 wth hgt ] 
+    , line [V2 wth hgt , V2 wth   0 ] 
+    , line [V2 wth   0 , V2   0   0 ]
+    , line [V2   0   0 , V2   0 hgt ] 
+    ]
+  where
+    f _ False = Nothing
+    f a True  = Just a
+
+listCursorNS :: Float -> Float -> Configuration -> Int -> Color -> Int -> Int -> Picture
+listCursorNS = listCursorChooseBorder [True,False,True]
+
+listCursorNES :: Float -> Float -> Configuration -> Int -> Color -> Int -> Int -> Picture
+listCursorNES = listCursorChooseBorder [True,True,True]
+
+listCursorNESW :: Float -> Float -> Configuration -> Int -> Color -> Int -> Int -> Picture
+listCursorNESW = listCursorChooseBorder [True,True,True,True]
+
+listCursorNSW :: Float -> Float -> Configuration -> Int -> Color -> Int -> Int -> Picture
+listCursorNSW = listCursorChooseBorder [True,False,True,True]
 
 listTextPictureAt :: Float -> Float -> Configuration -> Int -> Picture -> Picture
 listTextPictureAt xoff yoff cfig yint = winScale cfig

src/Dodge/Tweak.hs

@@ -0,0 +1 @@
+module Dodge.Tweak where

src/Multiset.hs

@@ -14,4 +14,4 @@ powlist :: [a] -> [[a]]
 powlist = filterM (const [True,False])
 
 toMultiset :: Ord a => [a] -> M.Map a Int
-toMultiset = foldr (uncurry $ M.insertWith (+)) M.empty . map (,1)
+toMultiset = foldr (uncurry (M.insertWith (+)) . (, 1)) M.empty