Start to unify selection lists

src/Dodge/Data/SelectionList.hs

@@ -0,0 +1,26 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Dodge.Data.SelectionList where
+import Picture.Data
+import Control.Lens
+
+data SelectionList = SelectionList
+    { _slPosX :: Float
+    , _slPosY :: Float
+    , _slOffset :: Int
+    , _slScale :: Float
+    , _slVerticalGap :: Float
+    , _slItems :: [SelectionItem]
+    , _slSelPos :: Maybe Int
+    , _slCursorType :: CursorType
+    }
+
+data CursorType = NoCursor
+
+data SelectionItem = SelectionItem
+    { _siPictures :: [Picture]
+    , _siHeight :: Int
+    , _siIsSelectable :: Bool
+    }
+    
+makeLenses ''SelectionList
+makeLenses ''SelectionItem

src/Dodge/Data/Universe.hs

@@ -53,6 +53,7 @@ data ScreenLayer
         , _scDefaultEff :: Universe -> Universe
         , _scOptionFlag :: OptionScreenFlag
         , _scOptionsOffset :: Int
+        , _scSelPos :: Maybe Int
         }
     | ColumnsScreen
         { _scTitle :: Universe -> String

src/Dodge/Event/Input.hs

@@ -8,8 +8,8 @@ module Dodge.Event.Input (
 ) where
 
 import qualified Data.Text as T
-import Dodge.Data.Input
 import Dodge.Data.Config
+import Dodge.Data.Input
 import LensHelp
 import SDL
 
@@ -18,20 +18,20 @@ import SDL
 handleTextInput :: T.Text -> Input -> Input
 handleTextInput text = textInput %~ (`T.append` text)
 
-{- | Handles keyboard press and release.
--}
+-- | Handles keyboard press and release.
 handleKeyboardEvent :: KeyboardEventData -> Input -> Input
 handleKeyboardEvent kev = case keyboardEventKeyMotion kev of
     Released -> pressedKeys . at scode .~ Nothing
     Pressed -> pressedKeys . at scode ?~ val
   where
-    val | keyboardEventRepeat kev = LongPress
+    val
+        | keyboardEventRepeat kev = LongPress
         | otherwise = InitialPress
     scode = (keysymScancode . keyboardEventKeysym) kev
 
 handleMouseMotionEvent :: MouseMotionEventData -> Configuration -> Input -> Input
-handleMouseMotionEvent mmev cfig inp =
-        inp & mousePos
+handleMouseMotionEvent mmev cfig =
+    mousePos
         .~ V2
             (fromIntegral x - 0.5 * _windowX cfig)
             (0.5 * _windowY cfig - fromIntegral y)

src/Dodge/Menu/Option.hs

@@ -10,4 +10,5 @@ slTitleOptionsEff title ops eff =
         , _scDefaultEff = eff
         , _scOptionFlag = NormalOptions
         , _scOptionsOffset = 0
+        , _scSelPos = Just 0
         }

src/Dodge/Render/HUD.hs

@@ -3,6 +3,7 @@ module Dodge.Render.HUD (
     hudDrawings,
 ) where
 
+import Dodge.Data.SelectionList
 import Control.Lens
 import qualified Data.Map.Strict as M
 import Data.Maybe
@@ -47,8 +48,34 @@ drawInGameHUD uv =
     w = _uvWorld uv
     cfig = _uvConfig uv
 
+defaultSelectionList :: SelectionList
+defaultSelectionList = SelectionList
+    { _slVerticalGap = 10
+    , _slScale = 1
+    , _slPosX = 0
+    , _slPosY = 0
+    , _slOffset = 0
+    , _slItems = []
+    , _slSelPos = Nothing
+    , _slCursorType = NoCursor
+    }
+
+inventorySelectionList :: World -> [SelectionItem]
+inventorySelectionList w = map (invSelectionItem cr) (IM.toList inv)
+    ++ [SelectionItem displayFreeSlots 1 False]
+            ++ map (closeObjectToSelectionItem nfreeslots) (w ^. cWorld . lWorld . closeObjects)
+  where
+    cr = you w
+    inv = _crInv cr
+    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"]
+
 inventoryDisplay :: Configuration -> World -> Picture
-inventoryDisplay cfig w = listPicturesAt 0 0 cfig invlist
+inventoryDisplay cfig w = drawSelectionList cfig (defaultSelectionList & slItems .~ inventorySelectionList w)
+--inventoryDisplay cfig w = listPicturesAt 0 0 cfig invlist
   where
     cr = you w
     inv = _crInv cr
@@ -308,6 +335,15 @@ invHead cfig s =
 invDimColor :: Color
 invDimColor = greyN 0.7
 
+closeObjectToSelectionItem :: Int -> Either FloorItem Button -> SelectionItem
+closeObjectToSelectionItem n e = SelectionItem
+    { _siPictures = pics
+    , _siHeight = length pics
+    , _siIsSelectable = True
+    }
+  where
+    pics = closeObjectToTextPictures n e
+
 closeObjectToTextPictures :: Int -> Either FloorItem Button -> [Picture]
 closeObjectToTextPictures nfreeslots e = case e of
     Left flit -> let it = _flIt flit in map (applycolor it . textindent) $ itemDisplay it
@@ -396,6 +432,15 @@ mapWall cfig thehud wl =
 mainListCursor :: Color -> Int -> Configuration -> Picture
 mainListCursor c = openCursorAt 120 c 5 0
 
+invSelectionItem :: Creature -> (Int,Item) -> SelectionItem
+invSelectionItem cr x = SelectionItem
+    { _siPictures = pics
+    , _siHeight = length pics
+    , _siIsSelectable = True
+    }
+  where
+    pics = itemText' cr x
+
 itemText' :: Creature -> (Int, Item) -> [Picture]
 {-# INLINE itemText' #-}
 itemText' cr (i, it) = f $ case _itCurseStatus it of

src/Dodge/Render/List.hs

@@ -1,5 +1,6 @@
 module Dodge.Render.List where
 
+import Dodge.Data.SelectionList
 import Data.Foldable
 import Data.Maybe
 import Dodge.Base.WinScale
@@ -8,14 +9,27 @@ import Dodge.Data.Config
 import Geometry
 import Picture
 
+drawSelectionList :: Configuration -> SelectionList -> Picture
+drawSelectionList cfig sl = listPicturesAtScaleOff 
+    (_slVerticalGap sl) 
+    (_slScale sl)
+    (_slPosX sl)
+    (_slPosY sl)
+    cfig
+    (_slOffset sl)
+    (concatMap _siPictures (_slItems sl))
+
 -- 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
-listPicturesAt tx ty cfig = listPicturesAtOff tx ty cfig 0
+listPicturesAt tx ty cfig = listPicturesAtScaleOff 10 1 tx ty cfig 0
 
 listPicturesAtOff :: Float -> Float -> Configuration -> Int -> [Picture] -> Picture
 listPicturesAtOff tx ty cfig i = mconcat . zipWith (listTextPictureAt tx ty cfig) [i ..]
 
+listPicturesAtScaleOff :: Float -> Float -> Float -> Float -> Configuration -> Int -> [Picture] -> Picture
+listPicturesAtScaleOff ygap s tx ty cfig i = mconcat . zipWith (listTextPictureAtScale ygap s tx ty cfig) [i ..]
+
 stackPicturesAt :: Float -> Float -> Configuration -> [Picture] -> Picture
 stackPicturesAt tx ty cfig = stackPicturesAtOff tx ty cfig 0
 
@@ -97,6 +111,15 @@ listTextPictureAt xoff yoff cfig yint =
     hw = halfWidth cfig
     hh = halfHeight cfig
 
+listTextPictureAtScale :: Float -> Float -> Float -> Float -> Configuration -> Int -> Picture -> Picture
+listTextPictureAtScale ygap s xoff yoff cfig yint =
+    winScale cfig
+        . translate (xoff + 15 - hw) (negate yoff + hh - ((s * 10 + ygap) * (fromIntegral yint + 1)))
+        . scale (s * 0.1) (s * 0.1)
+  where
+    hw = halfWidth cfig
+    hh = halfHeight cfig
+
 renderListAt :: Float -> Float -> Configuration -> [(String, Color)] -> Picture
 renderListAt tx ty cfig = listPicturesAt tx ty cfig . map (\(str, col) -> color col $ text str)
 

src/Dodge/Render/MenuScreen.hs

@@ -3,20 +3,20 @@ module Dodge.Render.MenuScreen (
     menuScreen,
 ) where
 
-import Dodge.ScodeToChar
 import qualified Data.Text as T
 import Dodge.Base.Window
 import Dodge.Data.Universe
+import Dodge.ScodeToChar
 import Dodge.WindowLayout
 import Padding
 import Picture
 
 menuScreen :: Universe -> ScreenLayer -> Picture
 menuScreen w screen = case screen of
-    OptionScreen{_scTitle = titf, _scOptions = mos, _scOptionsOffset = off} ->
-        drawOptions w (titf w) mos off "Use keys to navigate the menu"
+    OptionScreen{_scTitle = titf, _scOptions = mos, _scOptionsOffset = off, _scSelPos = selpos} ->
+        drawOptions w (titf w) mos off selpos "Use keys to navigate the menu"
     --    (WaitScreen sf _) -> drawOptions w (sf w) [] 0 ""
-    (InputScreen inputstr help) -> drawOptions w ('>' : T.unpack inputstr) [] 0 help
+    (InputScreen inputstr help) -> drawOptions w ('>' : T.unpack inputstr) [] 0 Nothing help
     --    (DisplayScreen sd) -> sd w
     (ColumnsScreen titf pairs) -> drawTwoColumnsScreen (_uvConfig w) (titf w) pairs
 
@@ -54,10 +54,12 @@ drawOptions ::
     [MenuOption] ->
     -- | Options offset
     Int ->
+    -- | Select position
+    Maybe Int ->
     -- | Help Text
     String ->
     Picture
-drawOptions u title ops off footer =
+drawOptions u title ops off mselpos footer =
     pictures $
         [ darkenBackground cfig
         , drawTitle cfig title