Work on selection lists and option menus

src/Dodge/Data/Universe.hs

@@ -48,12 +48,17 @@ data SideEffect
 data OptionScreenFlag = NormalOptions | GameOverOptions | SplashOptions
     deriving (Eq, Ord, Show, Read) --Generic, Flat)
 
+data PositionedMenuOption
+    = BottomMenuOption { _pmoMenuOption :: MenuOption }
+    | TopMenuOption { _pmoMenuOption :: MenuOption }
+    | NoPositionedMenuOption
+
 data ScreenLayer
     = OptionScreen
         { _scTitle :: String
         , _scOptions :: [MenuOption]
         , _scOffset :: Int
-        , _scMaybeOption :: Maybe MenuOption
+        , _scPositionedMenuOption :: PositionedMenuOption
         , _scOptionFlag :: OptionScreenFlag
         , _scSelectionList :: SelectionList
         , _scAvailableLines :: Int
@@ -100,3 +105,4 @@ makeLenses ''ScreenLayer
 makeLenses ''SideEffect
 makeLenses ''MenuOptionDisplay
 makeLenses ''MenuOption
+makeLenses ''PositionedMenuOption

src/Dodge/Menu/Option.hs

@@ -3,6 +3,7 @@ module Dodge.Menu.Option
 --import Dodge.ScodeToChar
 --import Data.Maybe
 --import Dodge.WindowLayout
+import Dodge.SelectionList
 import Padding
 import Picture.Base
 import Dodge.Data.CardinalPoint
@@ -11,18 +12,8 @@ import Dodge.Data.Universe
 import qualified Data.Set as Set
 import LensHelp
 
-initializeOptionMenu :: String -> [MenuOption] -> Maybe String -> (Universe -> Universe) -> Universe -> ScreenLayer
+optionListDisplayParams :: ListDisplayParams
-initializeOptionMenu title ops defstr eff u =
+optionListDisplayParams = ListDisplayParams
-    OptionScreen
-        { _scTitle = title
-        , _scOptions = ops
-        , _scOffset = 0
-        , _scMaybeOption = fmap (Toggle eff . const . MODString) defstr
-        , _scOptionFlag = NormalOptions
-        , _scSelectionList = makeOptionsSelectionList 10 (Just 0) u ops
-        , _scAvailableLines = 10
-        , _scShownItems = []
-        , _scListDisplayParams = ListDisplayParams
             { _ldpPosX = 50
             , _ldpPosY = 50
             , _ldpScale = 2
@@ -31,7 +22,6 @@ initializeOptionMenu title ops defstr eff u =
             , _ldpSizeRestriction = SelectionSizeRestriction overflowit
             , _ldpCursorType = BorderCursor (Set.fromList [North,South,West])
             } 
-        }
   where
     overflowit = SelectionItem
         { _siPictures = [text "MORE OPTIONS"]
@@ -42,6 +32,22 @@ initializeOptionMenu title ops defstr eff u =
         , _siOffX = 0
         }
 
+initializeOptionMenu :: String -> [MenuOption] -> Maybe String -> (Universe -> Universe) -> Universe -> ScreenLayer
+initializeOptionMenu title ops defstr eff u =
+    OptionScreen
+        { _scTitle = title
+        , _scOptions = ops
+        , _scOffset = 0
+        , _scPositionedMenuOption = case defstr of
+            Nothing -> NoPositionedMenuOption
+            Just str -> BottomMenuOption $ (Toggle eff . const . MODString) str
+        , _scOptionFlag = NormalOptions
+        , _scSelectionList = makeOptionsSelectionList 10 (Just 0) u ops
+        , _scAvailableLines = getAvailableListLines optionListDisplayParams (u ^. uvConfig)
+        , _scShownItems = []
+        , _scListDisplayParams = optionListDisplayParams
+        }
+
 refreshOptionsSelectionList :: Universe -> Universe
 refreshOptionsSelectionList u = u & uvScreenLayers . ix 0 %~ f
   where
@@ -61,9 +67,14 @@ makeOptionsSelectionList maxlines mselpos u mos = SelectionList
 optionsToSelections :: Int -> Universe -> [MenuOption] -> [SelectionItem]
 optionsToSelections maxlines u allops = map colStrToSelItem colstrs
   where
-    ops = take maxlines allops
+    ops | maxlines >= length allops = allops 
+        | otherwise = take (maxlines - 1) allops ++ [cycleOptionsOption]
     maxOptionLength = 3 + maximum (0 : map (optionValueOffset u) ops)
     colstrs = map (menuOptionToString u maxOptionLength) ops
+    cycleOptionsOption = Toggle cycleOptions (const (MODString "MORE OPTIONS"))
+
+cycleOptions :: Universe -> Universe
+cycleOptions = id
 
 colStrToSelItem :: (Color,String) -> SelectionItem
 colStrToSelItem (col,str) = SelectionItem

src/Dodge/Render/List.hs

@@ -1,6 +1,5 @@
 module Dodge.Render.List where
 
---import LensHelp
 import Data.Foldable
 import Data.Maybe
 import Data.Set (Set)
@@ -13,7 +12,7 @@ import Dodge.Data.SelectionList
 import Geometry
 import ListHelp
 import Picture
-import LensHelp
+--import LensHelp
 
 drawSelectionList :: ListDisplayParams -> Configuration -> SelectionList -> Picture
 drawSelectionList ldps cfig sl =

src/Dodge/SelectionList.hs

@@ -24,3 +24,13 @@ setShownSelectionItems' maxlines offset sl = case sl ^? scListDisplayParams . ld
   where
 --    dummyitem = (SelectionItem [] 1 False 0 white 0, DummySelectionItem)
     allitems = zipWith (\x y -> (x,ListedSelectionItem y)) (sl ^. scSelectionList . slItems) [0..]
+
+getAvailableListLines :: ListDisplayParams -> Configuration -> Int
+getAvailableListLines ldps cfig = nlines
+  where
+    nlines = floor ((dToBot - vgap) / itmHeight)
+    vgap = ldps ^. ldpVerticalGap
+    itmHeight = 10 * ldps ^. ldpScale + vgap
+    dToBot = cfig ^. windowY - (ldps ^. ldpPosY + dFromScreenBot)
+    dFromScreenBot = 5 -- fromMaybe 0 $ sl ^? slSizeRestriction . ssrType . ssrFromScreenBottom
+

src/Dodge/Update.hs

@@ -115,7 +115,7 @@ mouseOverSelectionList ldps sl u
         && ylower >= 0 && ylower < ymax  = u & uvScreenLayers . _head . scSelectionList . slSelPos ?~ yupper
     | otherwise = u
   where
-    ymax = maybe 0 length $ u ^? uvScreenLayers . _head . scSelectionList . slItems 
+    ymax = maybe 0 length $ sl ^? slItems 
     mmoving = u ^. uvWorld . input . mouseMoving
     ylower = ceiling $ (hh - (75 + y + _ldpPosY ldps)) / 50
     yupper = floor $ (hh - (15 + y + _ldpPosY ldps)) / 50
@@ -128,23 +128,13 @@ mouseOverSelectionList ldps sl u
 
 setSelectionListRestriction' :: Configuration -> ScreenLayer -> ScreenLayer
 setSelectionListRestriction' cfig screen = fromMaybe screen $ do
-    sl <- screen ^? scSelectionList
     ldps <- screen ^? scListDisplayParams
-    return $ screen & scAvailableLines %~ const (setSelectionListRestriction ldps cfig sl)
+    return $ screen & scAvailableLines %~ const (getAvailableListLines ldps cfig)
-
-setSelectionListRestriction :: ListDisplayParams -> Configuration -> SelectionList -> Int
-setSelectionListRestriction ldps cfig sl = nlines
-  where
-    nlines = floor ((dToBot - vgap) / itmHeight)
-    vgap = ldps ^. ldpVerticalGap
-    itmHeight = 10 * ldps ^. ldpScale + vgap
-    dToBot = cfig ^. windowY - (ldps ^. ldpPosY + dFromScreenBot)
-    dFromScreenBot = 5 -- fromMaybe 0 $ sl ^? slSizeRestriction . ssrType . ssrFromScreenBottom
 
 updateUseInput :: Universe -> Universe
 updateUseInput u = case u ^? uvScreenLayers . _head of
     Just (InputScreen thetext _) -> doInputScreenInput thetext u
-    Just screen@OptionScreen{_scOptions = mos, _scMaybeOption = mop, _scOptionFlag = flag, _scSelectionList = sellist, _scListDisplayParams = ldps}
+    Just screen@OptionScreen{_scOptions = mos, _scPositionedMenuOption = mop, _scOptionFlag = flag, _scSelectionList = sellist, _scListDisplayParams = ldps}
         -> optionScreenUpdate screen mos mop flag ldps sellist u
 --    Just ColumnsScreen{} -> u & uvScreenLayers %~ tail
     _ -> case u ^? uvWorld . cWorld . lWorld . hud . hudElement . subInventory of
@@ -153,7 +143,7 @@ updateUseInput u = case u ^? uvScreenLayers . _head of
   where
     pkeys = u ^. uvWorld . input . pressedKeys
 
-optionScreenUpdate :: ScreenLayer -> [MenuOption] -> Maybe MenuOption -> OptionScreenFlag
+optionScreenUpdate :: ScreenLayer -> [MenuOption] -> PositionedMenuOption -> OptionScreenFlag
     -> ListDisplayParams
     -> SelectionList
     -> Universe -> Universe
@@ -168,9 +158,9 @@ optionScreenUpdate screen mos mop _ ldps sl u =
   where
     cfig = u ^. uvConfig
 
-optionScreenDefEff :: Maybe MenuOption -> Universe -> Universe
+optionScreenDefEff :: PositionedMenuOption -> Universe -> Universe
 optionScreenDefEff f u = case u ^. uvWorld . input . pressedKeys . at ScancodeEscape of
-    Just InitialPress -> fromMaybe id (f ^? _Just . moEff) u
+    Just InitialPress -> fromMaybe id (f ^? pmoMenuOption . moEff) u
     _ -> u
 
 updateUniverseLast :: Universe -> Universe