From 7c8958cea7451069f4c1568b34618f60440e278e Mon Sep 17 00:00:00 2001
From: justin <justin.g.kruger@gmail.com>
Date: Wed, 2 Nov 2022 09:36:16 +0000
Subject: [PATCH] Start to unify selection lists

---
 src/Dodge/Data/SelectionList.hs | 26 ++++++++++++++++++
 src/Dodge/Data/Universe.hs      |  1 +
 src/Dodge/Event/Input.hs        | 18 ++++++-------
 src/Dodge/Menu/Option.hs        |  1 +
 src/Dodge/Render/HUD.hs         | 47 ++++++++++++++++++++++++++++++++-
 src/Dodge/Render/List.hs        | 25 +++++++++++++++++-
 src/Dodge/Render/MenuScreen.hs  | 28 +++++++++++---------
 7 files changed, 122 insertions(+), 24 deletions(-)
 create mode 100644 src/Dodge/Data/SelectionList.hs

diff --git a/src/Dodge/Data/SelectionList.hs b/src/Dodge/Data/SelectionList.hs
new file mode 100644
index 000000000..7b2f9e780
--- /dev/null
+++ b/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
diff --git a/src/Dodge/Data/Universe.hs b/src/Dodge/Data/Universe.hs
index 93c919548..706b0235f 100644
--- a/src/Dodge/Data/Universe.hs
+++ b/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
diff --git a/src/Dodge/Event/Input.hs b/src/Dodge/Event/Input.hs
index 357298b51..1d8174100 100644
--- a/src/Dodge/Event/Input.hs
+++ b/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,23 +18,23 @@ 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
-            .~ V2
-                (fromIntegral x - 0.5 * _windowX cfig)
-                (0.5 * _windowY cfig - fromIntegral y)
+handleMouseMotionEvent mmev cfig =
+    mousePos
+        .~ V2
+            (fromIntegral x - 0.5 * _windowX cfig)
+            (0.5 * _windowY cfig - fromIntegral y)
   where
     P (V2 x y) = mouseMotionEventPos mmev
 
diff --git a/src/Dodge/Menu/Option.hs b/src/Dodge/Menu/Option.hs
index bb70558dd..c83b1d52b 100644
--- a/src/Dodge/Menu/Option.hs
+++ b/src/Dodge/Menu/Option.hs
@@ -10,4 +10,5 @@ slTitleOptionsEff title ops eff =
         , _scDefaultEff = eff
         , _scOptionFlag = NormalOptions
         , _scOptionsOffset = 0
+        , _scSelPos = Just 0
         }
diff --git a/src/Dodge/Render/HUD.hs b/src/Dodge/Render/HUD.hs
index 0d38be7bc..9ac52c754 100644
--- a/src/Dodge/Render/HUD.hs
+++ b/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
diff --git a/src/Dodge/Render/List.hs b/src/Dodge/Render/List.hs
index 10b0cf650..fa737b24e 100644
--- a/src/Dodge/Render/List.hs
+++ b/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)
 
diff --git a/src/Dodge/Render/MenuScreen.hs b/src/Dodge/Render/MenuScreen.hs
index 835a2330b..7fac059d0 100644
--- a/src/Dodge/Render/MenuScreen.hs
+++ b/src/Dodge/Render/MenuScreen.hs
@@ -3,21 +3,21 @@ 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"
---    (WaitScreen sf _) -> drawOptions w (sf w) [] 0 ""
-    (InputScreen inputstr help) -> drawOptions w ('>' : T.unpack inputstr) [] 0 help
---    (DisplayScreen sd) -> sd w
+    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 Nothing help
+    --    (DisplayScreen sd) -> sd w
     (ColumnsScreen titf pairs) -> drawTwoColumnsScreen (_uvConfig w) (titf w) pairs
 
 --displayStringList :: World -> [String] -> Picture
@@ -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
@@ -77,7 +79,7 @@ drawOptions u title ops off footer =
         x | x < length ops -> take (availableMenuLines cfig) (drop off visibleops)
         _ -> visibleops
     ops'' = case availableMenuLines cfig of
-        x | x < length ops -> map (menuOptionToString u maxOptionLength) ops' ++ [(white,"SPACE: MORE OPTIONS")]
+        x | x < length ops -> map (menuOptionToString u maxOptionLength) ops' ++ [(white, "SPACE: MORE OPTIONS")]
         _ -> map (menuOptionToString u maxOptionLength) ops'
     visibleops = filter notInvisible ops
     notInvisible InvisibleToggle{} = False
@@ -118,9 +120,9 @@ placeColorString ::
     Float ->
     -- | scale
     Float ->
-    (Color,String) ->
+    (Color, String) ->
     Picture
-placeColorString x y sc (col,str) = color col . translate x y . scale sc sc . text $ str
+placeColorString x y sc (col, str) = color col . translate x y . scale sc sc . text $ str
 
 drawFooterText :: Configuration -> Color -> String -> Picture
 drawFooterText cfig col = color col . placeString (- hw + 30) (- hh + 10) 0.1
@@ -128,11 +130,11 @@ drawFooterText cfig col = color col . placeString (- hw + 30) (- hh + 10) 0.1
     hh = halfHeight cfig
     hw = halfWidth cfig
 
-menuOptionToString :: Universe -> Int -> MenuOption -> (Color,String)
-menuOptionToString w padAmount mo = (thecol,theKeys ++ optionText)
+menuOptionToString :: Universe -> Int -> MenuOption -> (Color, String)
+menuOptionToString w padAmount mo = (thecol, theKeys ++ optionText)
   where
     thecol = case _moString mo w of
-        MODBlockedString {} -> greyN 0.5
+        MODBlockedString{} -> greyN 0.5
         _ -> white
     optionText = case _moString mo w of
         MODStringOption s t -> rightPad padAmount '.' s ++ t