Work on menus

src/Dodge/Render/HUD.hs

@@ -1,6 +1,6 @@
 --{-# LANGUAGE TupleSections #-}
 module Dodge.Render.HUD (
-    hudDrawings,
+    drawHUD,
 ) where
 
 import Dodge.Data.CardinalPoint
@@ -29,12 +29,12 @@ import Picture
 import SDL (MouseButton (..))
 import qualified Data.Set as Set
 
-hudDrawings :: Universe -> Picture
-hudDrawings uv = case w ^. cWorld . lWorld . hud . hudElement of
+drawHUD :: Universe -> Picture
+drawHUD uv = case w ^. cWorld . lWorld . hud . hudElement of
     DisplayCarte -> drawCarte cfig w
     DisplayInventory subinv ->
         drawInGameHUD subinv uv
-            <> subInventoryDisplay subinv cfig w
+            <> drawSubInventory subinv cfig w
   where
     w = _uvWorld uv
     cfig = _uvConfig uv
@@ -58,9 +58,13 @@ defaultSelectionList = SelectionList
     , _slPosY = 0
     , _slOffset = 0
     , _slItems = []
+    , _slShownItems = []
     , _slSelPos = Nothing
     , _slCursorType = NoCursor
     , _slWidth = FixedSelectionWidth 15
+    , _slLength = 0
+    , _slSizeRestriction = NoSelectionSizeRestriction
+    , _slSpecialItem = NoSpecialSelectionItem
     }
 
 subInvSelectionList :: SelectionList
@@ -71,9 +75,13 @@ subInvSelectionList = SelectionList
     , _slPosY = 60
     , _slOffset = 0
     , _slItems = []
+    , _slShownItems = []
     , _slSelPos = Nothing
     , _slCursorType = NoCursor
     , _slWidth = FixedSelectionWidth 15
+    , _slLength = 0
+    , _slSizeRestriction = NoSelectionSizeRestriction
+    , _slSpecialItem = NoSpecialSelectionItem
     }
 
 inventorySelectionList :: World -> [SelectionItem]
@@ -107,8 +115,8 @@ inventoryDisplay subinv cfig w = drawSelectionList cfig $
         | ButtonRight `M.member` _mouseButtons (_input w) = [North,South,East,West]
         | otherwise = [North,South,West]
 
-subInventoryDisplay :: SubInventory -> Configuration -> World -> Picture
-subInventoryDisplay subinv cfig w = case subinv of
+drawSubInventory :: SubInventory -> Configuration -> World -> Picture
+drawSubInventory subinv cfig w = case subinv of
     LockedInventory -> mempty -- topInvCursor col cursPos cfig w
     NoSubInventory ->
         pictures

src/Dodge/Render/List.hs

@@ -1,5 +1,6 @@
 module Dodge.Render.List where
 
+--import LensHelp
 import Data.Foldable
 import Data.Maybe
 import Data.Set (Set)
@@ -12,6 +13,7 @@ import Dodge.Data.SelectionList
 import Geometry
 import ListHelp
 import Picture
+import LensHelp
 
 drawSelectionList :: Configuration -> SelectionList -> Picture
 drawSelectionList cfig sl =
@@ -22,13 +24,18 @@ drawSelectionList cfig sl =
         (_slPosY sl)
         cfig
         (_slOffset sl)
-        (concatMap _siPictures (_slItems sl))
+        (makeSelectionListPictures sl)
         <> drawSelectionCursor cfig sl
 
+makeSelectionListPictures :: SelectionList -> [Picture]
+makeSelectionListPictures sl = case sl ^. slSizeRestriction of
+    SelectionSizeRestriction {} -> concatMap (_siPictures . fst) $ _slShownItems sl
+    _ -> concatMap _siPictures $ _slItems sl
+
 drawSelectionCursor :: Configuration -> SelectionList -> Picture
 drawSelectionCursor cfig sl = fromMaybe mempty $ do
     i <- _slSelPos sl
-    selit <- (filter _siIsSelectable lis) !? i
+    selit <- filter _siIsSelectable lis !? i
     f <- case _slCursorType sl of
         BorderCursor cps -> Just $ listCursorChooseBorderScale (_slVerticalGap sl) (_slScale sl) cps
         NoCursor -> Nothing

src/Dodge/Render/MenuScreen.hs

@@ -4,33 +4,32 @@ module Dodge.Render.MenuScreen (
     menuScreen',
 ) where
 
-import Dodge.Menu.Option
-import Dodge.Render.List
+--import LensHelp
+import Dodge.Base.WinScale
 import Dodge.Data.SelectionList
+--import Dodge.Menu.Option
+import Dodge.Render.List
 import qualified Data.Text as T
 import Dodge.Base.Window
 import Dodge.Data.Universe
-import Dodge.WindowLayout
 import Padding
 import Picture
 
-menuScreen' :: Universe -> ScreenLayer -> Picture
-menuScreen' w screen = case screen of
-    OptionScreen{_scTitle = titf, _scOptions = mos, _scOptionsOffset = off, _scSelPos = selpos} ->
-        drawOptions w (titf w) mos off selpos "Use keys to navigate the menu"
+menuScreen' :: Configuration -> ScreenLayer -> Picture
+menuScreen' cfig screen = case screen of
+    OptionScreen{_scTitle = titf, _scSelectionList = selpos} ->
+        drawOptions cfig titf 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
+    (InputScreen inputstr help) -> drawInputMenu cfig ('>' : T.unpack inputstr) help
     --    (DisplayScreen sd) -> sd w
-    (ColumnsScreen titf pairs) -> drawTwoColumnsScreen (_uvConfig w) (titf w) pairs
+    (ColumnsScreen titf pairs) -> drawTwoColumnsScreen cfig titf pairs
 
-menuScreen :: Universe -> ScreenLayer -> Picture
-menuScreen w screen = case screen of
-    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
+menuScreen :: Configuration -> ScreenLayer -> Picture
+menuScreen cfig screen = case screen of
+    OptionScreen{_scTitle = titf, _scSelectionList = selpos} ->
+        drawOptions cfig titf selpos "Use keys to navigate the menu"
+    (InputScreen inputstr help) -> drawInputMenu cfig ('>' : T.unpack inputstr) help
+    (ColumnsScreen titf pairs) -> drawTwoColumnsScreen cfig titf pairs
 
 --displayStringList :: World -> [String] -> Picture
 --displayStringList w ss = pictures
@@ -51,81 +50,65 @@ drawTwoColumnsScreen cfig title lps =
         ]
 
 drawTwoColumns :: Configuration -> [(String, String)] -> Picture
-drawTwoColumns cfig lps = pictures $ zipWith f [hh -100, hh -130 ..] lps
+drawTwoColumns cfig lps = listPicturesAtScaleOff 30 2 50 50 cfig 0 $ map f lps
   where
-    f y (s1, s2) = placeString (50 - hw) y 0.15 $ rightPad ln '.' s1 ++ s2
-    hh = halfHeight cfig
-    hw = halfWidth cfig
+    f (s1, s2) = color white $ text $ rightPad ln '.' s1 ++ s2
     ln = maximum (map (length . fst) lps) + 3
 
-drawOptions ::
-    Universe ->
+--drawTwoColumns' :: Configuration -> [(String, String)] -> Picture
+--drawTwoColumns' cfig lps = pictures $ zipWith f [hh -100, hh -130 ..] lps
+--  where
+--    f y (s1, s2) = placeString (50 - hw) y 0.15 $ rightPad ln '.' s1 ++ s2
+--    hh = halfHeight cfig
+--    hw = halfWidth cfig
+--    ln = maximum (map (length . fst) lps) + 3
+
+drawInputMenu :: 
+    Configuration ->
     -- | Title
     String ->
-    -- | Options
-    [MenuOption] ->
-    -- | Options offset
-    Int ->
-    -- | Select position
-    Maybe Int ->
     -- | Help Text
     String ->
     Picture
-drawOptions u title ops off mselpos footer =
-    pictures $
+drawInputMenu cfig title footer =
+    pictures 
         [ --darkenBackground cfig
          drawTitle cfig title
         , drawFooterText cfig red footer
-        , drawSelectionList cfig (makeOptionsSelectionList mselpos u ops)
         ]
---            ++ zipWith
---                (\s vpos -> placeColorString (- hw + 50) vpos 0.2 s)
---                ops''
---                [hh -100, hh -150 ..]
-  where
-    --    ++ [color yellow $ concat [line [V2 (negate hw) (hh-y), V2 hw (hh-y)] |
-    --            y <- map (+75) [0,50..hh*2]]
-    --        ]
-
-    maxOptionLength = 3 + maximum (0 : map (optionValueOffset u) ops')
-    ops' = case availableMenuLines cfig of
-        x | x < length ops -> take (availableMenuLines cfig) (drop off ops)
-        _ -> ops
-    ops'' = case availableMenuLines cfig of
-        x | x < length ops -> zipWith (menuOptionToString u maxOptionLength) ['A'..] ops' ++ [(white, "SPACE: MORE OPTIONS")]
-        _ -> zipWith (menuOptionToString u maxOptionLength) ['A'..] ops'
-    hh = halfHeight cfig
-    hw = halfWidth cfig
-    cfig = _uvConfig u
-
-defaultSelectionItem :: SelectionItem
-defaultSelectionItem =  SelectionItem
-    { _siPictures = [color white $ text "HELLOW"]
-    , _siHeight = 1
-    , _siIsSelectable = True
-    , _siColor = white
-    , _siOffX = 0
-    }
-
-colStrToSelItem :: (Color,String) -> SelectionItem
-colStrToSelItem (col,str) = SelectionItem
-    { _siPictures = [color col $ text str]
-    , _siHeight = 1
-    , _siIsSelectable = True
-    , _siColor = col
-    , _siOffX = 0
-    }
 
+drawOptions ::
+    Configuration ->
+    -- | Title
+    String ->
+    -- | Select position
+    SelectionList ->
+    -- | Help Text
+    String ->
+    Picture
+drawOptions cfig title sl footer =
+    pictures 
+        [ --darkenBackground cfig
+         drawTitle cfig title
+        , drawFooterText cfig red footer
+        , drawSelectionList cfig sl
+        ]
 
 darkenBackground :: Configuration -> Picture
 darkenBackground = color (withAlpha 0.5 black) . polygon . reverse . screenBox
 
 drawTitle :: Configuration -> String -> Picture
-drawTitle cfig = placeString (- hw + 30) (hh - 50) 0.4
+drawTitle cfig = winScale cfig . translate (30 - hw) (hh-50) . scale 0.4 0.4 . text
   where
     hh = halfHeight cfig
     hw = halfWidth cfig
 
+--drawTitle' :: Configuration -> String -> Picture
+--drawTitle' cfig = placeString (- hw + 30) (hh - 50) 0.4
+--  where
+--    hh = halfHeight cfig
+--    hw = halfWidth cfig
+
 placeString ::
     -- | x distance from center
     Float ->
@@ -137,17 +120,6 @@ placeString ::
     Picture
 placeString x y sc = color white . translate x y . scale sc sc . text
 
-placeColorString ::
-    -- | x distance from center
-    Float ->
-    -- | y distance from center
-    Float ->
-    -- | scale
-    Float ->
-    (Color, String) ->
-    Picture
-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
   where

src/Dodge/Render/Picture.hs

@@ -14,10 +14,10 @@ import Picture
 
 fixedCoordPictures :: Universe -> Picture
 fixedCoordPictures u =
-    drawConcurrentMessage u <> customMouseCursor cfig (u ^. uvWorld) <> case u ^. uvScreenLayers of
-        [] -> hudDrawings u
-        (lay : _) -> (setDepth (-1) $ menuScreen' u lay) 
-            <> (setDepth (-1) . winScale cfig $ menuScreen u lay)
+    drawConcurrentMessage u <> customMouseCursor cfig (u ^. uvWorld . input) <> case u ^. uvScreenLayers of
+        [] -> drawHUD u
+        (lay : _) -> setDepth (-1) (menuScreen' cfig lay)
+--            <> (setDepth (-1) . winScale cfig $ menuScreen cfig lay)
   where
     cfig = _uvConfig u
 
@@ -33,9 +33,9 @@ drawConcurrentMessage u =
     f (RunningSideEffect ce) = ce ++ " IN PROGRESS"
     f x = _ceString x ++ " QUEUED"
 
-customMouseCursor :: Configuration -> World -> Picture
-customMouseCursor cfig w =
+customMouseCursor :: Configuration -> Input -> Picture
+customMouseCursor cfig inp =
     winScale cfig
-        . uncurryV translate (_mousePos (_input w))
+        . uncurryV translate (_mousePos inp)
         . color white
         $ pictures [line [V2 (-5) 0, V2 5 0], line [V2 0 (-5), V2 0 5]]