Fix scroll selection of floor items and buttons

src/Dodge/Combine.hs

@@ -87,11 +87,11 @@ fullModuleName = fromMaybe "EMPTYMODULE" . moduleName
 
 toggleCombineInv :: World -> World
 toggleCombineInv w = case w ^. cWorld . lWorld . hud . hudElement of
-    DisplayInventory CombineInventory{} -> w & cWorld . lWorld . hud . hudElement .~ DisplayInventory NoSubInventory
+    DisplayInventory CombineInventory{} -> w & cWorld . lWorld . hud . hudElement . subInventory .~ NoSubInventory
     _ -> w & enterCombineInv
 
 enterCombineInv :: World -> World
-enterCombineInv w = w & cWorld . lWorld . hud . hudElement .~ DisplayInventory (CombineInventory mi)
+enterCombineInv w = w & cWorld . lWorld . hud . hudElement . subInventory .~ CombineInventory mi
   where
     mi = 0 <$ listToMaybe (combineItemListYou w)
 

src/Dodge/Data/HUD.hs

@@ -13,7 +13,8 @@ import Geometry.Data
 
 data HUDElement
     = DisplayInventory 
-        { _subInventory :: SubInventory}
+        { _subInventory :: SubInventory
+        }
     | DisplayCarte
     deriving (Eq, Ord, Show, Read) --Generic, Flat)
 

src/Dodge/Data/SelectionList.hs

@@ -1,5 +1,5 @@
-{-# LANGUAGE DeriveGeneric #-}
+--{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE DeriveAnyClass #-}
+--{-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE StrictData #-}
 module Dodge.Data.SelectionList where
@@ -8,8 +8,8 @@ import Picture.Data
 import Control.Lens
 import Data.Set (Set)
 import Dodge.Data.CardinalPoint
-import Data.Aeson
+--import Data.Aeson
-import Data.Aeson.TH
+--import Data.Aeson.TH
 
 data ListDisplayParams = ListDisplayParams
     { _ldpPosX :: Float
@@ -26,6 +26,7 @@ data SelectionList a = SelectionList
     , _slSelPos :: Maybe Int
     , _slLength :: Int
     }
+    --deriving (Eq, Ord, Show, Read) --Generic, Flat)
 
 data SelectionWidth = FixedSelectionWidth Int
     | VariableSelectionWidth (Int -> Int)
@@ -43,8 +44,10 @@ data SelectionItem a = SelectionItem
     , _siOffX   :: Int
     , _siPayload :: a
     }
+    --deriving (Eq, Ord, Show, Read) --Generic, Flat)
     
 makeLenses ''ListDisplayParams
 makeLenses ''SelectionList
 makeLenses ''SelectionItem
-deriveJSON defaultOptions ''SelectionItem
+--deriveJSON defaultOptions ''SelectionItem
+--deriveJSON defaultOptions ''SelectionList

src/Dodge/Default/World.hs

@@ -1,5 +1,6 @@
 module Dodge.Default.World where
 
+--import Dodge.Data.SelectionList
 import Data.Graph.Inductive.Graph hiding ((&))
 import qualified Data.Map as M
 import qualified Data.Set as S

src/Dodge/Inventory.hs

@@ -121,11 +121,7 @@ closeObjectCol e = case e of
     Right _ -> yellow
 
 selNumPos :: Int -> World -> Int
-selNumPos i w = splitgap + (foldl' (+) 0 . fst $ IM.split i (augmentedInvSizes w))
+selNumPos i w = sum . fst $ IM.split i (augmentedInvSizes w)
-  where
-    splitgap = 0
---        | i < length (yourInv w) = 0
---        | otherwise = 1
 
 selNumTextPos :: Configuration -> World -> Int -> Point2
 selNumTextPos cfig w i = V2 (150 - hw) (hh - (20 * fromIntegral ipos + 20))
@@ -162,7 +158,7 @@ updateTerminal = checkTermDist
 
 checkTermDist :: World -> World
 checkTermDist w = case w ^? cWorld . lWorld . hud . hudElement . subInventory . termID of
-    Just tmid -> fromMaybe (w & cWorld . lWorld . hud . hudElement .~ DisplayInventory NoSubInventory) $ do
+    Just tmid -> fromMaybe (w & cWorld . lWorld . hud . hudElement . subInventory .~ NoSubInventory) $ do
         btid <- w ^? cWorld . lWorld . terminals . ix tmid . tmButtonID
         btpos <- w ^? cWorld . lWorld . buttons . ix btid . btPos
         if dist btpos (_crPos $ you w) < 40 then Just w else Nothing
@@ -395,4 +391,4 @@ selectedCloseObject w
     inv = _crInv cr
 
 selectNthCloseObject :: World -> Int -> Maybe (Int, Either FloorItem Button)
-selectNthCloseObject w n = (length (yourInv w) + n,) <$> (_closeObjects (_lWorld (_cWorld w)) !? n)
+selectNthCloseObject w n = (length (yourInv w) + n + 1,) <$> (_closeObjects (_lWorld (_cWorld w)) !? n)

src/Dodge/Render/HUD.hs

@@ -3,6 +3,7 @@ module Dodge.Render.HUD (
     drawHUD,
 ) where
 
+import Dodge.Inventory.SelectionList
 import Dodge.Data.CardinalPoint
 import Dodge.Data.SelectionList
 import Control.Lens
@@ -33,17 +34,18 @@ drawHUD :: Universe -> Picture
 drawHUD uv = case w ^. cWorld . lWorld . hud . hudElement of
     DisplayCarte -> drawCarte cfig w
     DisplayInventory subinv ->
-        drawInGameHUD subinv uv
+        drawInGameHUD sl uv
             <> drawSubInventory subinv cfig w
   where
+    sl = makeInventorySelectionList w
     w = _uvWorld uv
     cfig = _uvConfig uv
 
-drawInGameHUD :: SubInventory -> Universe -> Picture
+drawInGameHUD :: SelectionList () -> Universe -> Picture
-drawInGameHUD subinv uv =
+drawInGameHUD sl uv =
     pictures
         [ winScale cfig . dShadCol white $ displayHP 0 cfig w
-        , inventoryDisplay subinv cfig w
+        , inventoryDisplay sl cfig w
         ]
   where
     w = _uvWorld uv
@@ -59,13 +61,6 @@ defaultListDisplayParams  = ListDisplayParams
     , _ldpWidth = FixedSelectionWidth 15
     } 
 
-defaultSelectionList :: SelectionList a
-defaultSelectionList = SelectionList
-    {_slItems = []
-    , _slSelPos = Nothing
-    , _slLength = 0
-    }
-
 subInvListDisplayParams :: ListDisplayParams
 subInvListDisplayParams = ListDisplayParams
     { _ldpVerticalGap = 10
@@ -83,25 +78,6 @@ subInvSelectionList = SelectionList
     , _slLength = 0
     }
 
-inventorySelectionList :: World -> [SelectionItem ()]
-inventorySelectionList w = map (invSelectionItem cr) (IM.toList inv)
-    ++ [SelectionItem displayFreeSlots 1 True (length thetext) invDimColor 2 ()]
-            ++ map (closeObjectToSelectionItem nfreeslots) (w ^. cWorld . lWorld . closeObjects)
-  where
-    cr = you w
-    inv = _crInv cr
-    nfreeslots = crNumFreeSlots cr
-    thetext = case nfreeslots of
-        0 -> "  INVENTORY FULL"
-        1 -> "  +1 FREE SLOT"
-        x -> "  +" ++ show x ++ " FREE SLOTS"
-    displayFreeSlots = [color invDimColor $ text thetext]
-
-inventoryCursorPos :: SubInventory -> World -> Maybe Int
-inventoryCursorPos subinv w = case subinv of
-    CombineInventory {} -> Nothing
-    _ -> Just $ yourInvSel w
-
 invDisplayParams :: World -> ListDisplayParams
 invDisplayParams w = defaultListDisplayParams
     & ldpWidth .~ FixedSelectionWidth topInvW
@@ -112,10 +88,8 @@ invDisplayParams w = defaultListDisplayParams
         | ButtonRight `M.member` _mouseButtons (_input w) = [North,South,East,West]
         | otherwise = [North,South,West]
 
-inventoryDisplay :: SubInventory -> Configuration -> World -> Picture
+inventoryDisplay :: SelectionList () -> Configuration -> World -> Picture
-inventoryDisplay subinv cfig w = drawSelectionList (invDisplayParams w) cfig $
+inventoryDisplay sl cfig w = drawSelectionList (invDisplayParams w) cfig sl
-    defaultSelectionList & slItems .~ inventorySelectionList w
-        & slSelPos .~ inventoryCursorPos subinv w
 
 drawSubInventory :: SubInventory -> Configuration -> World -> Picture
 drawSubInventory subinv cfig w = case subinv of
@@ -171,15 +145,16 @@ drawSubInventory subinv cfig w = case subinv of
         extrapics
     closeobjectcursor = case selectedCloseObject w of
         Nothing -> mempty
-        Just (i, co) ->
+        Just (i,co) -> drawCursorAt (invDisplayParams w & ldpCursorType .~ BorderCursor (Set.fromList [North,South])) cfig (Just i) (inventorySelectionList w)
-            listCursorNS
+--        Just (i, co) ->
-                clObjFloatIn
+--            listCursorNS
-                0
+--                clObjFloatIn
-                cfig
+--                0
-                (selNumPos i w)
+--                cfig
-                (closeObjectCol co)
+--                (selNumPos i w)
-                topInvW
+--                (closeObjectCol co)
-                (invSelSize i w)
+--                topInvW
+--                (invSelSize i w)
     itcol = fromMaybe (greyN 0.5) (it ^? _Just . itInvColor)
     cr = you w
     it = yourItem w
@@ -356,38 +331,8 @@ invHead cfig s =
         $ text s
 
 
-closeObjectToSelectionItem :: Int -> Either FloorItem Button -> SelectionItem ()
+--clObjFloatIn :: Float
-closeObjectToSelectionItem n e = SelectionItem
+--clObjFloatIn = fromIntegral clObjIntIn * 9
-    { _siPictures = pics
-    , _siHeight = length pics
-    , _siIsSelectable = True
-    , _siWidth = 15
-    , _siColor = col
-    , _siOffX = 2
-    , _siPayload = ()
-    }
-  where
-    (pics,col) = closeObjectToTextPictures' n e
-
-closeObjectToTextPictures' :: Int -> Either FloorItem Button -> ([Picture],Color)
-closeObjectToTextPictures' nfreeslots e = case e of
-    Left flit -> let it = _flIt flit 
-        in (map (applycolor it . textindent) $ itemDisplay it, thecol it)
-    Right bt -> ([color yellow $ textindent $ _btText bt], yellow)
-  where
-    textindent = text . (replicate clObjIntIn ' ' ++)
-    applycolor it
-        | nfreeslots >= itSlotsTaken it = color $ _itInvColor it
-        | otherwise = color invDimColor
-    thecol it
-        | nfreeslots >= itSlotsTaken it = _itInvColor it
-        | otherwise = invDimColor
-
-clObjIntIn :: Int
-clObjIntIn = 2
-
-clObjFloatIn :: Float
-clObjFloatIn = fromIntegral clObjIntIn * 9
 
 drawCarte :: Configuration -> World -> Picture
 drawCarte cfig w =
@@ -475,23 +420,6 @@ picsToSelectable wdth pics = SelectionItem
 textSelItems :: [String] -> [SelectionItem ()]
 textSelItems = map (picsToSelectable 15 . (:[]) . text)
 
-invSelectionItem :: Creature -> (Int,Item) -> SelectionItem ()
-invSelectionItem cr (i,it) = SelectionItem
-    { _siPictures = pics
-    , _siHeight = length pics
-    , _siIsSelectable = True
-    , _siWidth = 15
-    , _siColor = col
-    , _siOffX = 0
-    , _siPayload = ()
-    }
-  where
-    col = _itInvColor it
-    pics = take (itSlotsTaken it) . (++ replicate 10 (color col $ text "*")) $ case _itCurseStatus it of
-        UndroppableIdentified -> map (color yellow . text) (itemDisplay it)
-        _ | crSel cr == i -> map (color col . text) (selectedItemDisplay cr it)
-        _ -> map (color col . text) (itemDisplay it)
-
 itemText :: Item -> [Picture]
 {-# INLINE itemText #-}
 itemText it = f $ case _itCurseStatus it of

src/Dodge/Render/List.hs

@@ -12,7 +12,7 @@ import Dodge.Data.SelectionList
 import Geometry
 import ListHelp
 import Picture
---import LensHelp
+import LensHelp
 
 drawSelectionList :: ListDisplayParams -> Configuration -> SelectionList a -> Picture
 drawSelectionList ldps cfig sl =
@@ -32,9 +32,10 @@ makeSelectionListPictures sl = concatMap _siPictures $ _slItems sl
 --    SelectionSizeRestriction {} -> concatMap (_siPictures . fst) $ _slShownItems sl
 --    _ -> concatMap _siPictures $ _slItems sl
 
-drawSelectionCursor :: ListDisplayParams -> Configuration -> SelectionList a -> Picture
+
-drawSelectionCursor ldps cfig sl = fromMaybe mempty $ do
+drawCursorAt :: ListDisplayParams -> Configuration -> Maybe Int -> [SelectionItem a] -> Picture
-    i <- _slSelPos sl
+drawCursorAt ldps cfig mi lis = fromMaybe mempty $ do
+    i <- mi
     selit <- lis !? i
     f <- case _ldpCursorType ldps of
         BorderCursor cps -> Just $ listCursorChooseBorderScale (_ldpVerticalGap ldps) (_ldpScale ldps) cps
@@ -43,11 +44,13 @@ drawSelectionCursor ldps cfig sl = fromMaybe mempty $ do
         col = _siColor selit
     return $ f (_ldpPosX ldps + (9 * fromIntegral (_siOffX selit))) (_ldpPosY ldps) cfig j col wdth (_siHeight selit)
   where
-    lis = _slItems sl
     wdth = case _ldpWidth ldps of
         FixedSelectionWidth x -> x
         _ -> 1
 
+drawSelectionCursor :: ListDisplayParams -> Configuration -> SelectionList a -> Picture
+drawSelectionCursor ldps cfig sl = drawCursorAt ldps cfig (sl ^. slSelPos) (sl ^. slItems)
+
 -- given a list of pictures that are each the size of a "text" call, displays them as
 -- a list on the screen
 listPicturesAt :: Float -> Float -> Configuration -> [Picture] -> Picture

src/Dodge/SelectionList.hs

@@ -15,3 +15,10 @@ getAvailableListLines ldps cfig = nlines
     dToBot = cfig ^. windowY - (ldps ^. ldpPosY + dFromScreenBot)
     dFromScreenBot = 5 -- fromMaybe 0 $ sl ^? slSizeRestriction . ssrType . ssrFromScreenBottom
 
+defaultSelectionList :: SelectionList a
+defaultSelectionList = SelectionList
+    {_slItems = []
+    , _slSelPos = Nothing
+    , _slLength = 0
+    }
+

src/Dodge/TestString.hs

@@ -3,13 +3,15 @@ module Dodge.TestString where
 import Control.Lens
 import Dodge.Data.Universe
 --import Data.Maybe
-import ShortShow
+--import ShortShow
-import qualified Data.Map.Strict as M
+--import qualified Data.Map.Strict as M
+import qualified IntMapHelp as IM
 
 testStringInit :: Universe -> [String]
 testStringInit u =
-    [ show $ u ^? uvScreenLayers . _head . scOffset
+     [  show $ IM.keys $ u ^?! uvWorld . cWorld . lWorld . creatures . ix 0 . crInv ]
-    ]
+--    [ show $ u ^? uvScreenLayers . _head . scOffset
-    ++ [  shortShow $ u ^?! uvWorld . cWorld . lWorld . creatures . ix 0 . crPos
+--    ]
-    ] 
+--    ++ [  shortShow $ u ^?! uvWorld . cWorld . lWorld . creatures . ix 0 . crPos
-     ++ map show (M.toList (u ^. uvWorld . input . pressedKeys))
+--    ] 
+--     ++ map show (M.toList (u ^. uvWorld . input . pressedKeys))

src/Dodge/Update.hs

@@ -6,6 +6,7 @@ Description : Simulation update
 -}
 module Dodge.Update (updateUniverse) where
 
+--import Dodge.Inventory.SelectionList
 import Color
 import Control.Applicative
 import Data.List
@@ -293,8 +294,13 @@ functionalUpdate w =
         . over uvWorld updateRBList
         . over uvWorld updateCloseObjects
         . over uvWorld updateWheelEvents
+        -- . over uvWorld updateInventorySelectionList
         $ over uvWorld updatePastWorlds w
 
+--updateInventorySelectionList :: World -> World
+--updateInventorySelectionList w = w
+--    & cWorld . lWorld . hud . hudElement . augmentedInventory .~ makeInventorySelectionList w
+
 -- this can probably be unified with updateWheelEvents
 menuWheelEvents :: Universe -> Universe
 menuWheelEvents u = foldr ($) u (replicate (abs y) (menuWheelStep (signum y)))

src/Dodge/Update/Input.hs

@@ -4,6 +4,8 @@ module Dodge.Update.Input
     , doInputScreenInput
     ) where
 
+--import Dodge.Inventory.SelectionList
+--import Dodge.Render.HUD
 import Dodge.Terminal.LeftButton
 import Dodge.Save
 import Dodge.Debug.Terminal
@@ -93,8 +95,8 @@ spaceAction w = case w ^?! cWorld . lWorld . hud . hudElement of
         Just (_, Left flit) -> pickUpItem 0 flit w
         Just (_, Right but) -> doButtonEvent (_btEvent but) but w
         _ -> w
-    DisplayInventory DisplayTerminal{} -> w & cWorld . lWorld . hud . hudElement .~ DisplayInventory NoSubInventory
+    DisplayInventory DisplayTerminal{} -> w & cWorld . lWorld . hud . hudElement . subInventory .~ NoSubInventory
-    _ -> w & cWorld . lWorld . hud . hudElement .~ DisplayInventory NoSubInventory
+    _ -> w & cWorld . lWorld . hud . hudElement . subInventory .~ NoSubInventory
   where
     --theLoc = doWorldPos (fst (_seenLocations (_cWorld w) IM.! _selLocation (_cWorld w))) w
     theLoc = doWorldPos (w ^?! cWorld . lWorld . seenLocations . ix (w ^. cWorld . lWorld . selLocation) . _1) w
@@ -106,10 +108,10 @@ toggleMap w = case w ^?! cWorld . lWorld . hud . hudElement of
 
 toggleTweakInv :: World -> World
 toggleTweakInv w = case w ^. cWorld . lWorld . hud . hudElement of
-    DisplayInventory TweakInventory{} -> w & thepointer .~ DisplayInventory NoSubInventory
+    DisplayInventory TweakInventory{} -> w & thepointer .~ NoSubInventory
-    _ -> w & thepointer .~ DisplayInventory (TweakInventory mi)
+    _ -> w & thepointer .~ TweakInventory mi
   where
-    thepointer = cWorld . lWorld . hud . hudElement
+    thepointer = cWorld . lWorld . hud . hudElement . subInventory
     mi = 0 <$ (yourItem w >>= (^? itTweaks . tweakParams . ix 0))
 
 toggleInspectInv :: HUDElement -> HUDElement

src/Dodge/Update/UsingInput.hs

@@ -47,7 +47,7 @@ pressedMBEffects subinv pkeys w = case subinv of
   where
     maybeexitcombine
         | ButtonRight `M.member` _mouseButtons (_input w) = id
-        | otherwise = cWorld . lWorld . hud . hudElement .~ DisplayInventory NoSubInventory
+        | otherwise = cWorld . lWorld . hud . hudElement . subInventory .~ NoSubInventory
 
 pressedMBEffectsNoInventory :: M.Map MouseButton Bool -> World -> World
 pressedMBEffectsNoInventory pkeys w

src/Dodge/WorldEffect.hs

@@ -44,7 +44,7 @@ accessTerminal :: Maybe Int -> World -> World
 accessTerminal mtmid w = case mtmid of
     Nothing -> w
     Just tmid ->
-        w & cWorld . lWorld . hud . hudElement .~ DisplayInventory (DisplayTerminal tmid)
+        w & cWorld . lWorld . hud . hudElement . subInventory .~ DisplayTerminal tmid
             & cWorld . lWorld . terminals . ix tmid . tmInput . tiFocus .~ True
             & cWorld . lWorld . terminals . ix tmid %~ tryToBoot
       where