Work on menus

appDodge/Main.hs

@@ -80,13 +80,25 @@ firstWorldLoad theConfig = do
     --return $ startNewGame $ Universe
     cancontinue <- doesFileExist "saveSlot/0"
     mseed <- loadSeed
+    let u = Universe
+            { --{_uvWorld = initialWorld
+              _uvWorld = splashScreen
+            , _uvConfig = theConfig
+            , _preloadData = pdata
+            , _uvScreenLayers = []
+            , _uvIOEffects = return
+            , _uvTestString = testStringInit
+            , _uvSideEffects = mempty
+            , _uvCanContinue = cancontinue
+            , _uvMSeed = mseed
+            }
     return $
         Universe
             { --{_uvWorld = initialWorld
               _uvWorld = splashScreen
             , _uvConfig = theConfig
             , _preloadData = pdata
-            , _uvScreenLayers = [splashMenu]
+            , _uvScreenLayers = [splashMenu u]
             , _uvIOEffects = return
             , _uvTestString = testStringInit
             , _uvSideEffects = mempty

src/Dodge/Data/SelectionList.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE StrictData #-}
 module Dodge.Data.SelectionList where
 import Color
 import Picture.Data
@@ -13,14 +14,36 @@ data SelectionList = SelectionList
     , _slScale :: Float
     , _slVerticalGap :: Float
     , _slItems :: [SelectionItem]
+    , _slShownItems :: [(SelectionItem,SelectionItemIndex)]
     , _slSelPos :: Maybe Int
     , _slCursorType :: CursorType
     , _slWidth :: SelectionWidth
     , _slLength :: Int
+    , _slSizeRestriction :: SelectionSizeRestriction
+    , _slSpecialItem :: SpecialSelectionItem
     }
 
+data SelectionItemIndex = ListedSelectionItem Int
+    | ScrollUpSelectionItem
+    | ScrollDownSelectionItem
+    | SpecialSelectionItem
+
+data SpecialSelectionItem = NoSpecialSelectionItem
+    | BottomSelectionItem {_bottomSelectionItem :: SelectionItem}
+
+data SelectionSizeRestriction = NoSelectionSizeRestriction
+    | SelectionSizeRestriction
+        { _maxSelectionLines :: Int
+        , _overflowItemTop :: SelectionItem
+        , _overflowItemBottom :: SelectionItem
+        , _ssrType :: SSRType
+        }
+
+newtype SSRType = SSRFromScreenBottom {_ssrFromScreenBottom :: Float}
+
 data SelectionWidth = FixedSelectionWidth Int
-    | VariableSelectionWidth [Int]
+    | VariableSelectionWidth (Int -> Int)
+    | UseMaxSelectionItemWidth
 
 data CursorType = NoCursor
     | BorderCursor (Set CardinalPoint)
@@ -36,3 +59,6 @@ data SelectionItem = SelectionItem
     
 makeLenses ''SelectionList
 makeLenses ''SelectionItem
+makeLenses ''SpecialSelectionItem
+makeLenses ''SelectionSizeRestriction
+makeLenses ''SSRType

src/Dodge/Data/Universe.hs

@@ -12,6 +12,7 @@ module Dodge.Data.Universe (
     module Loop.Data,
 ) where
 
+import Dodge.Data.SelectionList
 import Control.Lens
 --import qualified Data.Map.Strict as M
 import Data.Preload
@@ -21,7 +22,7 @@ import Dodge.Data.Config
 import Dodge.Data.World
 import Loop.Data
 import Picture.Data
-import SDL (Scancode)
+--import SDL (Scancode)
 
 data Universe = Universe
     { _uvWorld :: World
@@ -48,15 +49,14 @@ data OptionScreenFlag = NormalOptions | GameOverOptions | SplashOptions
 
 data ScreenLayer
     = OptionScreen
-        { _scTitle :: Universe -> String
+        { _scTitle :: String
         , _scOptions :: [MenuOption]
-        , _scDefaultEff :: Universe -> Universe
+        , _scMaybeOption :: Maybe MenuOption
         , _scOptionFlag :: OptionScreenFlag
-        , _scOptionsOffset :: Int
+        , _scSelectionList :: SelectionList
-        , _scSelPos :: Maybe Int
         }
     | ColumnsScreen
-        { _scTitle :: Universe -> String
+        { _scTitle :: String
         , _scColumns :: [(String, String)]
         }
     | InputScreen
@@ -94,3 +94,4 @@ makeLenses ''Universe
 makeLenses ''ScreenLayer
 makeLenses ''SideEffect
 makeLenses ''MenuOptionDisplay
+makeLenses ''MenuOption

src/Dodge/Menu.hs

@@ -4,6 +4,7 @@ module Dodge.Menu (
     splashMenu,
 ) where
 
+import Dodge.Data.SelectionList
 import ShortShow
 import Control.Monad
 import Dodge.Concurrent
@@ -24,15 +25,15 @@ import System.Clipboard
 import Text.Read
 import Data.Maybe
 
-splashMenu :: ScreenLayer
+splashMenu :: Universe -> ScreenLayer
-splashMenu =
+splashMenu u =
-    slTitleOptionsEff "AMNESIS" splashMenuOptions id
+    slTitleOptionsEff "AMNESIS" splashMenuOptions Nothing id u
         & scOptionFlag .~ SplashOptions
 
 splashMenuOptions :: [MenuOption]
 splashMenuOptions =
         [ Toggle ( loadSaveSlot (SaveSlotNum 0)) displaycontinue
-        , Toggle id (\u -> MODString $ show $ u ^? uvScreenLayers . _head . scSelPos . _Just)
+        , Toggle id (\u -> MODString $ show $ u ^? uvScreenLayers . _head . scSelectionList . slSelPos . _Just)
         , Toggle id (\u -> MODString $ shortShow $ u ^. uvWorld . input . mousePos)
         , Toggle ( startNewGameInSlot 0) (opText "NEW WITH RANDOM SEED")
         , Toggle reloadLevelStart (displaywhenseed "NEW WITH LAST SEED")
@@ -49,8 +50,8 @@ splashMenuOptions =
     displaywhenseed str u | isNothing (_uvMSeed u) = MODBlockedString str
         | otherwise = MODString str
 
-pauseMenu :: ScreenLayer
+pauseMenu :: Universe -> ScreenLayer
-pauseMenu = slTitleOptionsEff "PAUSED" pauseMenuOptions unpause
+pauseMenu = slTitleOptionsEff "PAUSED" pauseMenuOptions (Just "CONTINUE") unpause
 
 pauseMenuOptions :: [MenuOption]
 pauseMenuOptions =
@@ -75,8 +76,8 @@ saveQuitConc u = do
     void $ writeSaveSlot (SaveSlotNum 0) u
     return $ const Nothing
 
-seedStartMenu :: String -> ScreenLayer
+seedStartMenu :: String -> Universe -> ScreenLayer
-seedStartMenu str = slTitleOptionsEff str seedStartOptions popScreen
+seedStartMenu str = slTitleOptionsEff str seedStartOptions (Just "BACK") popScreen
 
 seedStartOptions :: [MenuOption]
 seedStartOptions =
@@ -94,11 +95,11 @@ trySeedFromClipboard u = do
                 (u & uvScreenLayers %~ tail)
         Just i -> return $ startSeedGame 0 i u
 
-slTitleOptions :: String -> [MenuOption] -> ScreenLayer
+slTitleOptions :: String -> [MenuOption] -> Universe -> ScreenLayer
-slTitleOptions title ops = slTitleOptionsEff title ops (popScreen . writeConfig)
+slTitleOptions title ops = slTitleOptionsEff title ops (Just "BACK") (popScreen . writeConfig)
 
-optionMenu :: ScreenLayer
+optionMenu :: Universe -> ScreenLayer
-optionMenu = slTitleOptionsEff "OPTIONS" optionsOptions popScreen
+optionMenu = slTitleOptionsEff "OPTIONS" optionsOptions (Just "BACK") popScreen
 
 optionsOptions :: [MenuOption]
 optionsOptions =
@@ -106,10 +107,9 @@ optionsOptions =
         , makeSubmenuOption graphicsMenu $ MODString "GRAPHICS"
         , makeSubmenuOption gameplayMenu $ MODString "GAMEPLAY"
         , makeSubmenuOption debugMenu $ MODString "DEBUG OPTIONS"
-        , Toggle popScreen $ const $ MODString "BACK"
         ]
 
-debugMenu :: ScreenLayer
+debugMenu :: Universe -> ScreenLayer
 debugMenu =
     slTitleOptions
         "OPTIONS:GAMEPLAY"
@@ -117,7 +117,7 @@ debugMenu =
 
 debugMenuOptions :: [MenuOption]
 debugMenuOptions =
-        (map f [minBound ..] ++ [makeEnumOption debug_view_clip_bounds "SHOW ROOM CLIP" id])
+        map f [minBound ..] ++ [makeEnumOption debug_view_clip_bounds "SHOW ROOM CLIP" id]
   where
     f :: DebugBool -> MenuOption
     f bd =
@@ -141,7 +141,7 @@ debugMenuOptions =
 --    , makeBoolOption debug_cull_more_lights "CULL MORE LIGHTS"
 --    ]
 --    $ map Scancode [4 ..]
-gameplayMenu :: ScreenLayer
+gameplayMenu :: Universe -> ScreenLayer
 gameplayMenu =
     slTitleOptions
         "OPTIONS:GAMEPLAY"
@@ -152,7 +152,7 @@ gameplayMenuOptions =
         [ makeBoolOption gameplay_rotate_to_wall "ROTATE TO WALL"
         ]
 
-soundMenu :: ScreenLayer
+soundMenu :: Universe -> ScreenLayer
 soundMenu =
     slTitleOptions
         "OPTIONS:VOLUME"
@@ -179,7 +179,7 @@ soundMenuOptions =
 writeConfig :: Universe -> Universe
 writeConfig w = w & uvIOEffects %~ saveConfig (_uvConfig w)
 
-graphicsMenu :: ScreenLayer
+graphicsMenu :: Universe -> ScreenLayer
 graphicsMenu = slTitleOptions "OPTIONS:GRAPHICS" graphicsMenuOptions
 
 graphicsMenuOptions :: [MenuOption]
@@ -190,9 +190,9 @@ graphicsMenuOptions =
         , makeBoolOption graphics_cloud_shadows "CLOUD SHADOWS"
         ]
 
-gameOverMenu :: ScreenLayer
+gameOverMenu :: Universe -> ScreenLayer
-gameOverMenu =
+gameOverMenu u =
-    slTitleOptionsEff "GAME OVER" pauseMenuOptions id
+    slTitleOptionsEff "GAME OVER" pauseMenuOptions Nothing id u
         & scOptionFlag .~ GameOverOptions
 
 --    OptionScreen
@@ -209,8 +209,8 @@ gameOverMenu =
 unpause :: Universe -> Universe
 unpause w = resumeSound $ w & uvScreenLayers .~ []
 
-displayControls :: ScreenLayer
+displayControls :: Universe -> ScreenLayer
-displayControls = ColumnsScreen (const "CONTROLS") listControls
+displayControls = const $ ColumnsScreen "CONTROLS" listControls
 
 listControls :: [(String, String)]
 listControls =

src/Dodge/Menu/Option.hs

@@ -1,43 +1,68 @@
 module Dodge.Menu.Option
     where
-import Dodge.ScodeToChar
+--import Dodge.ScodeToChar
+import Data.Maybe
+import Dodge.WindowLayout
 import Padding
 import Picture.Base
 import Dodge.Data.CardinalPoint
 import Dodge.Data.SelectionList
 import Dodge.Data.Universe
 import qualified Data.Set as Set
+import LensHelp
 
-slTitleOptionsEff :: String -> [MenuOption] -> (Universe -> Universe) -> ScreenLayer
+slTitleOptionsEff :: String -> [MenuOption] -> Maybe String -> (Universe -> Universe) -> Universe -> ScreenLayer
-slTitleOptionsEff title ops eff =
+slTitleOptionsEff title ops defstr eff u =
     OptionScreen
-        { _scTitle = const title
+        { _scTitle = title
         , _scOptions = ops
-        , _scDefaultEff = eff
+        , _scMaybeOption = fmap (Toggle eff . const . MODString) defstr
         , _scOptionFlag = NormalOptions
-        , _scOptionsOffset = 0
+        , _scSelectionList = makeOptionsSelectionList (Just 0) u ops defstr
-        , _scSelPos = Just 0
         }
 
-makeOptionsSelectionList :: Maybe Int -> Universe -> [MenuOption] -> SelectionList
+makeOptionsSelectionList :: Maybe Int -> Universe -> [MenuOption] -> Maybe String -> SelectionList
-makeOptionsSelectionList mselpos u mos = SelectionList
+makeOptionsSelectionList mselpos u mos defstr = SelectionList
     { _slPosX = 50
     , _slPosY = 50
     , _slOffset = 0
     , _slScale = 2
     , _slVerticalGap = 30
     , _slItems = optionsToSelections u mos
+    , _slShownItems = []
     , _slSelPos = mselpos
     , _slCursorType = BorderCursor (Set.fromList [North,South,West])
     , _slWidth = FixedSelectionWidth 15
     , _slLength = length $ optionsToSelections u mos
+    , _slSizeRestriction = SelectionSizeRestriction (availableMenuLines cfig) overflowit overflowit
+        (SSRFromScreenBottom 5)
+    , _slSpecialItem = fromMaybe NoSpecialSelectionItem $ do
+        str <- defstr
+        return $ BottomSelectionItem SelectionItem 
+            { _siPictures = [color white $ text str]
+            , _siHeight = 1
+            , _siIsSelectable = True
+            , _siWidth = length str
+            , _siColor = white
+            , _siOffX = 0
+            }
+    }
+  where
+    cfig = u ^. uvConfig
+    overflowit = SelectionItem
+        { _siPictures = [text "MORE OPTIONS"]
+        , _siHeight = 1
+        , _siIsSelectable = True
+        , _siWidth = length "MORE OPTIONS"
+        , _siColor = white
+        , _siOffX = 0
         }
 
 optionsToSelections :: Universe -> [MenuOption] -> [SelectionItem]
 optionsToSelections u ops = map colStrToSelItem colstrs
   where
     maxOptionLength = 3 + maximum (0 : map (optionValueOffset u) ops)
-    colstrs = zipWith (menuOptionToString u maxOptionLength) ['A'..] ops
+    colstrs = map (menuOptionToString u maxOptionLength) ops
 
 colStrToSelItem :: (Color,String) -> SelectionItem
 colStrToSelItem (col,str) = SelectionItem
@@ -54,8 +79,8 @@ optionValueOffset u mo = case _moString mo u of
     MODStringOption s _ -> length s
     _ -> 0
 
-menuOptionToString :: Universe -> Int -> Char -> MenuOption -> (Color, String)
+menuOptionToString :: Universe -> Int -> MenuOption -> (Color, String)
-menuOptionToString w padAmount char mo = (thecol, (char:":") ++ optionText)
+menuOptionToString w padAmount mo = (thecol, optionText)
   where
     thecol = case _moString mo w of
         MODBlockedString{} -> greyN 0.5

src/Dodge/Menu/PushPop.hs

@@ -6,6 +6,6 @@ import LensHelp
 popScreen :: Universe -> Universe
 popScreen = uvScreenLayers %~ tail
 
-pushScreen :: ScreenLayer -> Universe -> Universe
+pushScreen :: (Universe -> ScreenLayer) -> Universe -> Universe
-pushScreen ml = uvScreenLayers .:~ ml
+pushScreen ml u = u & uvScreenLayers .:~ ml u
 

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
+drawHUD :: Universe -> Picture
-hudDrawings uv = case w ^. cWorld . lWorld . hud . hudElement of
+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
+drawSubInventory :: SubInventory -> Configuration -> World -> Picture
-subInventoryDisplay subinv cfig w = case subinv of
+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 LensHelp
-import Dodge.Render.List
+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' :: Configuration -> ScreenLayer -> Picture
-menuScreen' w screen = case screen of
+menuScreen' cfig screen = case screen of
-    OptionScreen{_scTitle = titf, _scOptions = mos, _scOptionsOffset = off, _scSelPos = selpos} ->
+    OptionScreen{_scTitle = titf, _scSelectionList = selpos} ->
-        drawOptions w (titf w) mos off selpos "Use keys to navigate the menu"
+        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 :: Configuration -> ScreenLayer -> Picture
-menuScreen w screen = case screen of
+menuScreen cfig screen = case screen of
-    OptionScreen{_scTitle = titf, _scOptions = mos, _scOptionsOffset = off, _scSelPos = selpos} ->
+    OptionScreen{_scTitle = titf, _scSelectionList = selpos} ->
-        drawOptions w (titf w) mos off selpos "Use keys to navigate the menu"
+        drawOptions cfig titf selpos "Use keys to navigate the menu"
-    --    (WaitScreen sf _) -> drawOptions w (sf w) [] 0 ""
+    (InputScreen inputstr help) -> drawInputMenu cfig ('>' : T.unpack inputstr) help
-    (InputScreen inputstr help) -> drawOptions w ('>' : T.unpack inputstr) [] 0 Nothing help
+    (ColumnsScreen titf pairs) -> drawTwoColumnsScreen cfig titf pairs
-    --    (DisplayScreen sd) -> sd w
-    (ColumnsScreen titf pairs) -> drawTwoColumnsScreen (_uvConfig w) (titf w) 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
+    f (s1, s2) = color white $ text $ rightPad ln '.' s1 ++ s2
-    hh = halfHeight cfig
-    hw = halfWidth cfig
     ln = maximum (map (length . fst) lps) + 3
 
-drawOptions ::
+--drawTwoColumns' :: Configuration -> [(String, String)] -> Picture
-    Universe ->
+--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 =
+drawInputMenu cfig title footer =
-    pictures $
+    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
+    drawConcurrentMessage u <> customMouseCursor cfig (u ^. uvWorld . input) <> case u ^. uvScreenLayers of
-        [] -> hudDrawings u
+        [] -> drawHUD u
-        (lay : _) -> (setDepth (-1) $ menuScreen' u lay) 
+        (lay : _) -> setDepth (-1) (menuScreen' cfig lay)
-            <> (setDepth (-1) . winScale cfig $ menuScreen u 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 :: Configuration -> Input -> Picture
-customMouseCursor cfig w =
+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]]

src/Dodge/SelectionList.hs

@@ -0,0 +1,16 @@
+module Dodge.SelectionList where
+
+import Dodge.Data.SelectionList
+import LensHelp
+
+setShownSelectionItems :: SelectionList -> SelectionList
+setShownSelectionItems sl = case sl ^? slSizeRestriction of
+    Just (SelectionSizeRestriction maxlines topit botit _)
+        | length allitems <= maxlines -> sl & slShownItems .~ allitems
+        | otherwise -> if offset > 0
+            then sl & slShownItems .~ ((topit,ScrollUpSelectionItem) : take (maxlines - 2) (drop offset allitems))
+            else sl & slShownItems .~ (take (maxlines - 2) allitems ++ [(botit,ScrollDownSelectionItem)])
+    _ -> sl & slShownItems .~ allitems
+  where
+    offset = sl ^. slOffset
+    allitems = zipWith (\x y -> (x,ListedSelectionItem y)) (sl ^. slItems) [0..]

src/Dodge/Update.hs

@@ -6,7 +6,8 @@ Description : Simulation update
 -}
 module Dodge.Update (updateUniverse) where
 
-import Dodge.Menu.Option
+--import Dodge.Menu.Option
+import Dodge.SelectionList
 import Dodge.Data.SelectionList
 import Dodge.InputFocus
 import Color
@@ -65,7 +66,7 @@ import SDL
 import Sound.Data
 import StrictHelp
 import qualified Data.Text as T
-import ListHelp
+--import ListHelp
 
 updateUniverse :: Universe -> Universe
 updateUniverse u =
@@ -91,20 +92,24 @@ gotoTerminal w = case _uvScreenLayers w of
     (InputScreen{} : _) -> w
     _ -> w & uvScreenLayers .:~ InputScreen T.empty "Enter command"
 
-mouseClickOptionsList :: [MenuOption] -> Maybe Int -> Universe -> Universe
+mouseClickOptionsList :: [MenuOption] -> SelectionList -> Maybe MenuOption -> Universe -> Universe
-mouseClickOptionsList mos mi u = case u ^. uvWorld . input . mouseButtons . at ButtonLeft of
+mouseClickOptionsList mos sl mop u = case u ^. uvWorld . input . mouseButtons . at ButtonLeft of
     Just False -> fromMaybe u $ do
-        i <- mi
+        i <- sl ^. slSelPos
-        mo <- mos !? i
+        si <- sl ^? slShownItems . ix i . _2
-        return $ _moEff mo u
+        return $ maybe u ($ u) $ case si of
+            ListedSelectionItem j -> mos ^? ix j . moEff
+            ScrollUpSelectionItem -> Just $ uvScreenLayers . _head . scSelectionList . slOffset %~ (min 0 . subtract 10)
+            ScrollDownSelectionItem -> Just $ uvScreenLayers . _head . scSelectionList . slOffset +~ 10
     _ -> u
 
 mouseOverSelectionList :: SelectionList -> Universe -> Universe
 mouseOverSelectionList sl u
     | x > xl && x < xr && ylower == yupper && mmoving
-        && ylower >= 0 && ylower < _slLength sl  = u & uvScreenLayers . _head . scSelPos ?~ yupper
+        && ylower >= 0 && ylower < ymax  = u & uvScreenLayers . _head . scSelectionList . slSelPos ?~ yupper
     | otherwise = u
   where
+    ymax = maybe 0 length $ u ^? uvScreenLayers . _head . scSelectionList . slShownItems 
     mmoving = u ^. uvWorld . input . mouseMoving
     ylower = ceiling $ (hh - (75 + y + _slPosY sl)) / 50
     yupper = floor $ (hh - (15 + y + _slPosY sl)) / 50
@@ -115,32 +120,44 @@ mouseOverSelectionList sl u
     hh = halfHeight cfig
     hw = halfWidth cfig
 
+setSelectionListRestriction :: Configuration -> SelectionList -> SelectionList
+setSelectionListRestriction cfig sl = sl & slSizeRestriction . maxSelectionLines %~ const nlines
+  where
+    nlines = floor ((dToBot - vgap) / itmHeight)
+    vgap = sl ^. slVerticalGap
+    itmHeight = 10 * sl ^. slScale + vgap
+    dToBot = cfig ^. windowY - (sl ^. slPosY + dFromScreenBot)
+    dFromScreenBot = fromMaybe 0 $ sl ^? slSizeRestriction . ssrType . ssrFromScreenBottom
+
 updateUseInput :: Universe -> Universe
 updateUseInput u = case u ^? uvScreenLayers . _head of
     Just (InputScreen thetext _) -> doInputScreenInput thetext u
-    Just OptionScreen{_scOptions = mos, _scDefaultEff = defeff, _scOptionFlag = flag, _scSelPos = mselpos} 
+    Just OptionScreen{_scOptions = mos, _scMaybeOption = mop, _scOptionFlag = flag, _scSelectionList = sellist} 
-        -> optionScreenUpdate mos defeff flag mselpos u
+        -> optionScreenUpdate mos mop flag sellist u
---        foldl' (\u' scode -> optionListToEffects defeff scode mos u') u (M.keys $ M.filter (== InitialPress) pkeys)
+--    Just ColumnsScreen{} -> u & uvScreenLayers %~ tail
-    Just ColumnsScreen{} -> u & uvScreenLayers %~ tail
     _ -> case u ^? uvWorld . cWorld . lWorld . hud . hudElement . subInventory of
-        Just (DisplayTerminal tmid) | inTermFocus (_uvWorld u) -> updateKeysInTerminal tmid u-- M.foldlWithKey' (updateKeyInTerminal tmid) u pkeys
+        Just (DisplayTerminal tmid) | inTermFocus (_uvWorld u) -> updateKeysInTerminal tmid u
         _ -> M.foldlWithKey' updateKeyInGame u pkeys
   where
     pkeys = u ^. uvWorld . input . pressedKeys
 
-optionScreenUpdate :: [MenuOption] -> (Universe -> Universe) -> OptionScreenFlag -> Maybe Int
+optionScreenUpdate :: [MenuOption] -> Maybe MenuOption -> OptionScreenFlag
+    -> SelectionList
     -> Universe -> Universe
-optionScreenUpdate mos defeff _ mselpos u = 
+optionScreenUpdate mos mop _ sl u = 
-    optionScreenDefEff defeff
+     optionScreenDefEff mop
-    . mouseClickOptionsList mos mselpos
+    . mouseClickOptionsList mos sl mop
-    . mouseOverSelectionList 
+    . mouseOverSelectionList sl
-        (makeOptionsSelectionList mselpos u mos)
+    . menuWheelEvents
-    $ menuWheelEvents
+    . over (uvScreenLayers . _head . scSelectionList) (setSelectionListRestriction cfig)
+    $ over (uvScreenLayers . _head . scSelectionList) setShownSelectionItems
     u
+  where
+    cfig = u ^. uvConfig
 
-optionScreenDefEff :: (Universe -> Universe) -> Universe -> Universe
+optionScreenDefEff :: Maybe MenuOption -> Universe -> Universe
 optionScreenDefEff f u = case u ^. uvWorld . input . pressedKeys . at ScancodeEscape of
-    Just InitialPress -> f u
+    Just InitialPress -> fromMaybe id (f ^? _Just . moEff) u
     _ -> u
 
 updateUniverseLast :: Universe -> Universe
@@ -276,9 +293,9 @@ functionalUpdate w =
         $ over uvWorld updatePastWorlds w
 
 menuWheelEvents :: Universe -> Universe
-menuWheelEvents u = u & uvScreenLayers . _head . scSelPos . _Just %~ (\y' -> (y' - y) `mod` ymax)
+menuWheelEvents u = u & uvScreenLayers . _head . scSelectionList . slSelPos . _Just %~ (\y' -> (y' - y) `mod` ymax)
   where
-    ymax = maybe 0 length (u ^? uvScreenLayers . _head . scOptions)
+    ymax = max 1 $ maybe 1 length (u ^? uvScreenLayers . _head . scSelectionList . slShownItems)
     y = u ^. uvWorld . input . scrollAmount
 
 updateWheelEvents :: World -> World
@@ -622,7 +639,7 @@ checkEndGame :: Universe -> Universe
 checkEndGame uv = case w ^? cWorld . timeFlow . deathDelay of
     Just x
         | x < 0 ->
-            uv & uvScreenLayers .~ [gameOverMenu]
+            uv & uvScreenLayers .~ [gameOverMenu uv]
     Just _ -> uv & uvWorld . cWorld . timeFlow . deathDelay -~ 1
     _ | _crHP (you w) < 1 -> uv & uvWorld . cWorld . timeFlow .~ DeathTime 50
     _ -> uv

src/Dodge/Update/Input.hs

@@ -84,7 +84,7 @@ updateKeyInGame  uv sc InitialPress = case sc of
 updateKeyInGame  uv _ _ = uv
 
 pauseGame :: Universe -> Universe
-pauseGame = uvScreenLayers .~ [pauseMenu]
+pauseGame u = u & uvScreenLayers .~ [pauseMenu u]
 
 spaceAction :: World -> World
 spaceAction w = case w ^?! cWorld . lWorld . hud . hudElement of