Work on a selection list datatype

src/Dodge/Data/SelectionList.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE TemplateHaskell #-}
 module Dodge.Data.SelectionList where
+import Color
 import Picture.Data
 import Control.Lens
 
@@ -12,14 +13,23 @@ data SelectionList = SelectionList
     , _slItems :: [SelectionItem]
     , _slSelPos :: Maybe Int
     , _slCursorType :: CursorType
+    , _slWidth :: SelectionWidth
     }
 
+data SelectionWidth = FixedSelectionWidth Int
+    | VariableSelectionWidth [Int]
+
 data CursorType = NoCursor
+    | NSEWCursor
+    | NSWCursor
+    | NSCursor
 
 data SelectionItem = SelectionItem
     { _siPictures :: [Picture]
     , _siHeight :: Int
     , _siIsSelectable :: Bool
+    , _siColor  :: Color
+    , _siOffX   :: Int
     }
     
 makeLenses ''SelectionList

src/Dodge/Render/HUD.hs

@@ -31,18 +31,18 @@ hudDrawings :: Universe -> Picture
 hudDrawings uv = case w ^. cWorld . lWorld . hud . hudElement of
     DisplayCarte -> drawCarte cfig w
     DisplayInventory subinv ->
-        drawInGameHUD uv
+        drawInGameHUD subinv uv
             <> subInventoryDisplay subinv cfig w
   where
     w = _uvWorld uv
     cfig = _uvConfig uv
 
-drawInGameHUD :: Universe -> Picture
+drawInGameHUD :: SubInventory -> Universe -> Picture
-drawInGameHUD uv =
+drawInGameHUD subinv uv =
     pictures
         [ winScale cfig . dShadCol white $ displayHP 0 cfig w
         , listPicturesAt (halfWidth cfig) 0 cfig $ map text (_uvTestString uv uv)
-        , inventoryDisplay cfig w
+        , inventoryDisplay subinv cfig w
         ]
   where
     w = _uvWorld uv
@@ -58,11 +58,25 @@ defaultSelectionList = SelectionList
     , _slItems = []
     , _slSelPos = Nothing
     , _slCursorType = NoCursor
+    , _slWidth = FixedSelectionWidth 15
+    }
+
+subInvSelectionList :: SelectionList
+subInvSelectionList = SelectionList
+    { _slVerticalGap = 10
+    , _slScale = 1
+    , _slPosX = subInvX
+    , _slPosY = 60
+    , _slOffset = 0
+    , _slItems = []
+    , _slSelPos = Nothing
+    , _slCursorType = NoCursor
+    , _slWidth = FixedSelectionWidth 15
     }
 
 inventorySelectionList :: World -> [SelectionItem]
 inventorySelectionList w = map (invSelectionItem cr) (IM.toList inv)
-    ++ [SelectionItem displayFreeSlots 1 False]
+    ++ [SelectionItem displayFreeSlots 1 False white 0]
             ++ map (closeObjectToSelectionItem nfreeslots) (w ^. cWorld . lWorld . closeObjects)
   where
     cr = you w
@@ -73,58 +87,48 @@ inventorySelectionList w = map (invSelectionItem cr) (IM.toList inv)
         1 -> [color invDimColor . text $ "  +1 FREE SLOT"]
         x -> [color invDimColor . text $ "  +" ++ show x ++ " FREE SLOTS"]
 
-inventoryDisplay :: Configuration -> World -> Picture
+inventoryCursorPos :: SubInventory -> World -> Maybe Int
-inventoryDisplay cfig w = drawSelectionList cfig (defaultSelectionList & slItems .~ inventorySelectionList w)
+inventoryCursorPos subinv w = case subinv of
---inventoryDisplay cfig w = listPicturesAt 0 0 cfig invlist
+    CombineInventory {} -> Nothing
+    _ -> Just $ yourInvSel w
+
+inventoryDisplay :: SubInventory -> Configuration -> World -> Picture
+inventoryDisplay subinv cfig w = drawSelectionList cfig $
+    defaultSelectionList & slItems .~ inventorySelectionList w
+        & slWidth .~ FixedSelectionWidth topInvW
+        & slCursorType .~ selcursortype
+        & slSelPos .~ inventoryCursorPos subinv w
+        & slWidth .~ FixedSelectionWidth (determineInvSelCursorWidth w)
   where
-    cr = you w
+    selcursortype
-    inv = _crInv cr
+        | ButtonRight `M.member` _mouseButtons (_input w) = NSEWCursor
-    invlist =
+        | otherwise = NSWCursor
-        concatMap (itemText' cr) (IM.toList inv)
-            ++ displayFreeSlots
-            ++ concatMap (closeObjectToTextPictures nfreeslots) (w ^. cWorld . lWorld . closeObjects)
-    --        ++ map floorItemsColor (concatMap (closeObjectToTextPictures nfreeslots) (_closeObjects w))
-    --    floorItemsColor = case _hudElement (_hud w) of
-    --        DisplayInventory NoSubInventory -> id
-    --        _ -> 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"]
 
 subInventoryDisplay :: SubInventory -> Configuration -> World -> Picture
 subInventoryDisplay subinv cfig w = case subinv of
     LockedInventory -> mempty -- topInvCursor col cursPos cfig w
     NoSubInventory ->
         pictures
-            [ selcursor
+            [ closeobjectcursor
-            , closeobjectcursor
             , equipcursors
             , equipcursor -- the order is important, this should go on top of the other equipcursors
             , rboptions
             ]
     TweakInventory mtweaki ->
-        pictures
+        titledSub "TWEAK" (subInvSelectionList & slItems .~ ammoTweakSelectionItems it)
-            --[ mCurs it cfig w
             [ selcursor' listCursorNESW
-            , --        , cursorsZ cfig curpos it
+            , fromMaybe mempty $ do
-              fromMaybe mempty $ do
                 tweaki <- mtweaki
                 -- consider moving this functionality out into a tweaks module
                 tparam <- it ^? _Just . itTweaks . tweakParams . ix tweaki
                 return $
                     lnkMidInvSel cfig w curpos tweaki
                         <> listCursorNSW subInvX 60 cfig tweaki white (length $ showTweak tparam) 1
-            , invHead cfig "TWEAK"
-            , listPicturesAt subInvX 60 cfig $ map text (ammoTweakStrings it)
             ]
     DisplayTerminal tid -> displayTerminal tid cfig (w ^. cWorld . lWorld)
     CombineInventory mi ->
-        pictures
+        titledSub "COMBINE" (combineListSelection w)
-            [ invHead cfig "COMBINE"
+            [ fromMaybe mempty $ do
-            , listPicturesAt subInvX 60 cfig $ combineListStringPictures w
-            , fromMaybe mempty $ do
                 i <- mi
                 cpos <- combinePoss w !? i
                 col <- (combineItemListYou w !? i) <&> _itInvColor . snd
@@ -145,12 +149,13 @@ subInventoryDisplay subinv cfig w = case subinv of
                         ]
             ]
     InspectInventory ->
-        mconcat
+        titledSub "INSPECT" (subInvSelectionList & slItems .~ textSelItems (itmInfo it))
             [ selcursor' listCursorNESW
-            , invHead cfig "INSPECT"
-            , listPicturesAt subInvX 60 cfig $ map text (itmInfo it)
             ]
   where
+    titledSub subtitle subitems extrapics = pictures $ [invHead cfig subtitle
+        ,drawSelectionList cfig subitems] <>
+        extrapics
     closeobjectcursor = case selectedCloseObject w of
         Nothing -> mempty
         Just (i, co) ->
@@ -166,10 +171,6 @@ subInventoryDisplay subinv cfig w = case subinv of
     cr = you w
     it = yourItem w
     selcursor' ct = fromMaybe mempty $ ct 0 0 cfig curpos itcol (determineInvSelCursorWidth w) cury <$ it
-    selcursor = selcursor' selcursortype
-    selcursortype
-        | ButtonRight `M.member` _mouseButtons (_input w) = listCursorNESW
-        | otherwise = listCursorNSW
     curpos = invSelPos w
     cury = fromMaybe 1 $ augmentedInvSizes w IM.!? crSel (you w)
     equipcursor = case _crLeftInvSel cr of
@@ -308,14 +309,20 @@ determineInvSelCursorWidth w = case _rbOptions w of
             then 47
             else topInvW
 
---listSelHeight :: Configuration -> World -> Int -> Float
+combineListSelection :: World -> SelectionList
---listSelHeight
+combineListSelection w = subInvSelectionList & slItems .~ combineListSelectionItems w
 
-combineListStringPictures :: World -> [Picture]
+combineListSelectionItems :: World -> [SelectionItem]
-combineListStringPictures w = case concatMap (itemText . snd) . combineItemListYou $ w of
+combineListSelectionItems w = case combineListSelectionItems' w of
-    [] -> [text "NO POSSIBLE COMBINATIONS"]
+    [] -> [SelectionItem [text "NO POSSIBLE COMBINATIONS"] 1 False white 0]
     xs -> xs
 
+combineListSelectionItems' :: World -> [SelectionItem]
+combineListSelectionItems' w = map (picsToSelectable . itemText . snd) $ combineItemListYou w
+
+ammoTweakSelectionItems :: Maybe Item -> [SelectionItem]
+ammoTweakSelectionItems = textSelItems . ammoTweakStrings
+
 ammoTweakStrings :: Maybe Item -> [String]
 ammoTweakStrings it = case it ^? _Just . itTweaks . tweakParams of
     Just l -> map tweakString $ IM.elems l
@@ -340,19 +347,25 @@ closeObjectToSelectionItem n e = SelectionItem
     { _siPictures = pics
     , _siHeight = length pics
     , _siIsSelectable = True
+    , _siColor = col
+    , _siOffX = 2
     }
   where
-    pics = closeObjectToTextPictures n e
+    (pics,col) = closeObjectToTextPictures' n e
 
-closeObjectToTextPictures :: Int -> Either FloorItem Button -> [Picture]
+closeObjectToTextPictures' :: Int -> Either FloorItem Button -> ([Picture],Color)
-closeObjectToTextPictures nfreeslots e = case e of
+closeObjectToTextPictures' nfreeslots e = case e of
-    Left flit -> let it = _flIt flit in map (applycolor it . textindent) $ itemDisplay it
+    Left flit -> let it = _flIt flit 
-    Right bt -> [color yellow $ textindent $ _btText bt]
+        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
@@ -432,24 +445,32 @@ mapWall cfig thehud wl =
 mainListCursor :: Color -> Int -> Configuration -> Picture
 mainListCursor c = openCursorAt 120 c 5 0
 
-invSelectionItem :: Creature -> (Int,Item) -> SelectionItem
+picsToSelectable :: [Picture] -> SelectionItem
-invSelectionItem cr x = SelectionItem
+picsToSelectable pics = SelectionItem
     { _siPictures = pics
     , _siHeight = length pics
     , _siIsSelectable = True
+    , _siColor = white
+    , _siOffX = 0
+    }
+
+textSelItems :: [String] -> [SelectionItem]
+textSelItems = map (picsToSelectable . (:[]) . text)
+
+invSelectionItem :: Creature -> (Int,Item) -> SelectionItem
+invSelectionItem cr (i,it) = SelectionItem
+    { _siPictures = pics
+    , _siHeight = length pics
+    , _siIsSelectable = True
+    , _siColor = col
+    , _siOffX = 0
     }
   where
-    pics = itemText' cr x
+    col = _itInvColor it
-
+    pics = take (itSlotsTaken it) . (++ replicate 10 (color col $ text "*")) $ case _itCurseStatus it of
-itemText' :: Creature -> (Int, Item) -> [Picture]
+        UndroppableIdentified -> map (color yellow . text) (itemDisplay it)
-{-# INLINE itemText' #-}
+        _ | crSel cr == i -> map (color col . text) (selectedItemDisplay cr it)
-itemText' cr (i, it) = f $ case _itCurseStatus it of
+        _ -> map (color col . text) (itemDisplay it)
-    UndroppableIdentified -> map (color yellow . text) (itemDisplay it)
-    _ | crSel cr == i -> map (color thecolor . text) (selectedItemDisplay cr it)
-    _ -> map (color thecolor . text) (itemDisplay it)
-  where
-    thecolor = _itInvColor it
-    f = take (itSlotsTaken it) . (++ replicate 10 (color (_itInvColor it) $ text "*"))
 
 itemText :: Item -> [Picture]
 {-# INLINE itemText #-}

src/Dodge/Render/List.hs

@@ -1,5 +1,6 @@
 module Dodge.Render.List where
 
+import ListHelp
 import Dodge.Data.SelectionList
 import Data.Foldable
 import Data.Maybe
@@ -18,6 +19,25 @@ drawSelectionList cfig sl = listPicturesAtScaleOff
     cfig
     (_slOffset sl)
     (concatMap _siPictures (_slItems sl))
+    <> drawSelectionCursor cfig sl
+
+drawSelectionCursor :: Configuration -> SelectionList -> Picture
+drawSelectionCursor cfig sl = fromMaybe mempty $ do
+    i <- _slSelPos sl
+    selit <- (filter _siIsSelectable lis) !? i
+    f <- case _slCursorType sl of
+        NSEWCursor -> Just listCursorNESW
+        NSWCursor -> Just listCursorNSW
+        NSCursor -> Just listCursorNS
+        NoCursor -> Nothing
+    let j = sum . map _siHeight $ takeWhileArb (<= i) (\x itsel -> x + if _siIsSelectable itsel then 1 else 0) 0 lis
+        col = _siColor selit
+    return $ f (_slPosX sl + (9 * fromIntegral (_siOffX selit))) (_slPosY sl) cfig j col wdth (_siHeight selit)
+  where
+    lis = _slItems sl
+    wdth = case _slWidth sl of
+        FixedSelectionWidth x -> x
+        _ -> 1
 
 -- given a list of pictures that are each the size of a "text" call, displays them as
 -- a list on the screen

src/ListHelp.hs

@@ -14,9 +14,14 @@ module ListHelp
     , merge
     , mergeBy
     , mergeOn
+
+    , takeWhileArb
+    , takeWhileArb'
+    , foldrWhileArb
     ) where
 import Data.List
 import Data.Ord
+import FoldableHelp
 
 loopPairs :: [a] -> [(a,a)]
 loopPairs (a:as) = snd $ foldr f (Just a,[]) (a:as)
@@ -85,3 +90,21 @@ mergeOn :: Ord b => (a -> b) -> [a] -> [a] -> [a]
 mergeOn f xs = map snd . mergeBy (comparing fst) (g xs) . g
   where
     g = map (\x -> let y = f x in y `seq` (y,x))
+
+-- | A generalised version of takeWhile
+takeWhileArb :: (a -> Bool) -> (a -> b -> a) -> a -> [b] -> [b]
+takeWhileArb _ _ _ [] = []
+takeWhileArb t f y (x:xs) = case f y x of
+    y' | t y' -> x : takeWhileArb t f y' xs
+       | otherwise -> []
+
+-- this may fuse better
+-- should do tests
+takeWhileArb' :: (a -> Bool) -> (a -> b -> a) -> a -> [b] -> [b]
+takeWhileArb' t f a0 = snd . ssfold (t . fst) (\(a0',xs) x -> (f a0' x,x:xs)) (a0,[])
+
+foldrWhileArb :: (b -> c -> c) -> c -> (a -> Bool) -> (a -> b -> a) -> a -> [b] -> c
+foldrWhileArb _ z _ _ _ [] = z
+foldrWhileArb h z t f y (x:xs) = case f y x of
+    y' | t y' -> h x $ foldrWhileArb h z t f y' xs
+       | otherwise -> h x z