Work on menus

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 mos mi u = case u ^. uvWorld . input . mouseButtons . at ButtonLeft of
+mouseClickOptionsList :: [MenuOption] -> SelectionList -> Maybe MenuOption -> Universe -> Universe
+mouseClickOptionsList mos sl mop u = case u ^. uvWorld . input . mouseButtons . at ButtonLeft of
     Just False -> fromMaybe u $ do
-        i <- mi
-        mo <- mos !? i
-        return $ _moEff mo u
+        i <- sl ^. slSelPos
+        si <- sl ^? slShownItems . ix i . _2
+        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} 
-        -> optionScreenUpdate mos defeff flag mselpos u
---        foldl' (\u' scode -> optionListToEffects defeff scode mos u') u (M.keys $ M.filter (== InitialPress) pkeys)
-    Just ColumnsScreen{} -> u & uvScreenLayers %~ tail
+    Just OptionScreen{_scOptions = mos, _scMaybeOption = mop, _scOptionFlag = flag, _scSelectionList = sellist} 
+        -> optionScreenUpdate mos mop flag sellist u
+--    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 = 
-    optionScreenDefEff defeff
-    . mouseClickOptionsList mos mselpos
-    . mouseOverSelectionList 
-        (makeOptionsSelectionList mselpos u mos)
-    $ menuWheelEvents
+optionScreenUpdate mos mop _ sl u = 
+     optionScreenDefEff mop
+    . mouseClickOptionsList mos sl mop
+    . mouseOverSelectionList sl
+    . 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