Cleanup

2022-12-26 23:14:30 +00:00
parent 1bafb427df
commit eecc38d68f
4 changed files with 142 additions and 145 deletions
@@ -4,11 +4,13 @@ module Dodge.Menu (
    splashMenu,
 ) where

-import Dodge.Data.SelectionList
-import ShortShow
 import Control.Monad
+--import SDL
+
+import Data.Maybe
 import Dodge.Concurrent
 import Dodge.Config.Update
+import Dodge.Data.SelectionList
 import Dodge.Data.Universe
 import Dodge.Menu.Option
 import Dodge.Menu.OptionType
@@ -20,22 +22,21 @@ import Dodge.StartNewGame
 import LensHelp
 import MaybeHelp
 import Padding
--import SDL
+import ShortShow
 import System.Clipboard
 import Text.Read
-import Data.Maybe

 splashMenu :: Universe -> ScreenLayer
 splashMenu u =
-    initializeOptionMenu "AMNESIS" splashMenuOptions Nothing id u
+    initializeOptionMenu "AMNESIS" splashMenuOptions NoPositionedMenuOption u
        & scOptionFlag .~ SplashOptions

 splashMenuOptions :: [MenuOption]
 splashMenuOptions =
-        [ Toggle ( loadSaveSlot (SaveSlotNum 0)) displaycontinue
+    [ Toggle (loadSaveSlot (SaveSlotNum 0)) displaycontinue
    , 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 (startNewGameInSlot 0) (opText "NEW WITH RANDOM SEED")
    , Toggle reloadLevelStart (displaywhenseed "NEW WITH LAST SEED")
    , Toggle (pushScreen $ seedStartMenu "START FROM SEED") (opText "NEW WITH SPECIFIC SEED")
    , Toggle (pushScreen optionMenu) (opText "OPTIONS")
@@ -45,13 +46,15 @@ splashMenuOptions =
    ]
  where
    opText = const . MODString
-    displaycontinue u | _uvCanContinue u = MODString "CONTINUE"
+    displaycontinue u
+        | _uvCanContinue u = MODString "CONTINUE"
        | otherwise = MODBlockedString "CONTINUE"
-    displaywhenseed str u | isNothing (_uvMSeed u) = MODBlockedString str
+    displaywhenseed str u
+        | isNothing (_uvMSeed u) = MODBlockedString str
        | otherwise = MODString str

 pauseMenu :: Universe -> ScreenLayer
-pauseMenu = initializeOptionMenu' "PAUSED" pauseMenuOptions pmo
+pauseMenu = initializeOptionMenu "PAUSED" pauseMenuOptions pmo
  where
    pmo = TopMenuOption $ Toggle unpause (const (MODString "CONTINUE"))

@@ -71,14 +74,13 @@ pauseMenuOptions =
 saveQuit :: Universe -> Universe
 saveQuit u = u & addSideEffect (saveQuitConc u) "SAVING"

-
 saveQuitConc :: Universe -> IO (Universe -> Maybe Universe)
 saveQuitConc u = do
    void $ writeSaveSlot (SaveSlotNum 0) u
    return $ const Nothing

 seedStartMenu :: String -> Universe -> ScreenLayer
-seedStartMenu str = initializeOptionMenu str seedStartOptions (Just "BACK") popScreen
+seedStartMenu str = titleOptionsNoWrite str seedStartOptions

 seedStartOptions :: [MenuOption]
 seedStartOptions =
@@ -91,19 +93,20 @@ trySeedFromClipboard u = do
    mcstr <- getClipboardString
    case mcstr >>= readMaybe of
        Nothing ->
-            return $ pushScreen
+            return $
+                pushScreen
                    (seedStartMenu "CLIPBOARD UNUSABLE, NEED INTEGER")
                    (u & uvScreenLayers %~ tail)
        Just i -> return $ startSeedGame 0 i u

-slTitleOptions :: String -> [MenuOption] -> Universe -> ScreenLayer
-slTitleOptions title ops = initializeOptionMenu title ops (Just "BACK") (popScreen . writeConfig)
+titleOptionsMenu :: String -> [MenuOption] -> Universe -> ScreenLayer
+titleOptionsMenu title ops = initializeOptionMenuBO title ops "BACK" (popScreen . writeConfig)

-optionsNoWrite :: String -> [MenuOption] -> Universe -> ScreenLayer
-optionsNoWrite title ops = initializeOptionMenu title ops (Just "BACK") popScreen
+titleOptionsNoWrite :: String -> [MenuOption] -> Universe -> ScreenLayer
+titleOptionsNoWrite title ops = initializeOptionMenuBO title ops "BACK" popScreen

 optionMenu :: Universe -> ScreenLayer
-optionMenu = initializeOptionMenu "OPTIONS" optionsOptions (Just "BACK") popScreen
+optionMenu = titleOptionsNoWrite "OPTIONS" optionsOptions

 optionsOptions :: [MenuOption]
 optionsOptions =
@@ -114,10 +117,7 @@ optionsOptions =
    ]

 debugMenu :: Universe -> ScreenLayer
-debugMenu =
-    slTitleOptions
-        "OPTIONS:GAMEPLAY"
-        debugMenuOptions
+debugMenu = titleOptionsMenu "OPTIONS:GAMEPLAY" debugMenuOptions

 debugMenuOptions :: [MenuOption]
 debugMenuOptions =
@@ -146,10 +146,7 @@ debugMenuOptions =
 --    ]
 --    $ map Scancode [4 ..]
 gameplayMenu :: Universe -> ScreenLayer
-gameplayMenu =
-    slTitleOptions
-        "OPTIONS:GAMEPLAY"
-        gameplayMenuOptions
+gameplayMenu = titleOptionsMenu "OPTIONS:GAMEPLAY" gameplayMenuOptions

 gameplayMenuOptions :: [MenuOption]
 gameplayMenuOptions =
@@ -157,10 +154,7 @@ gameplayMenuOptions =
    ]

 soundMenu :: Universe -> ScreenLayer
-soundMenu =
-    slTitleOptions
-        "OPTIONS:VOLUME"
-        soundMenuOptions
+soundMenu = titleOptionsMenu "OPTIONS:VOLUME" soundMenuOptions

 soundMenuOptions :: [MenuOption]
 soundMenuOptions =
@@ -174,7 +168,8 @@ soundMenuOptions =
            (change dec stype)
            (change inc stype)
            (\w -> MODStringOption str (leftPad 2 '.' $ show (round $ 10 * voltype (_uvConfig w) :: Int)))
-    change g vt uv = uv & uvConfig . vt %~ g
+    change g vt uv =
+        uv & uvConfig . vt %~ g
            & uvIOEffects .~ \u -> sw uv >> return u
    dec x = max 0 (x - 0.1)
    inc x = min 1 (x + 0.1)
@@ -184,7 +179,7 @@ writeConfig :: Universe -> Universe
 writeConfig w = w & uvIOEffects %~ saveConfig (_uvConfig w)

 graphicsMenu :: Universe -> ScreenLayer
-graphicsMenu = slTitleOptions "OPTIONS:GRAPHICS" graphicsMenuOptions
+graphicsMenu = titleOptionsMenu "OPTIONS:GRAPHICS" graphicsMenuOptions

 graphicsMenuOptions :: [MenuOption]
 graphicsMenuOptions =
@@ -196,17 +191,9 @@ graphicsMenuOptions =

 gameOverMenu :: Universe -> ScreenLayer
 gameOverMenu u =
-    initializeOptionMenu "GAME OVER" pauseMenuOptions Nothing id u
+    initializeOptionMenu "GAME OVER" pauseMenuOptions NoPositionedMenuOption u
        & scOptionFlag .~ GameOverOptions

--    OptionScreen
--        { _scTitle = const "GAME OVER"
--        , _scOptions = pauseMenuOptions
--        , _scDefaultEff = return . Just
--        , _scOptionFlag = GameOverOptions
--        , _scOptionsOffset = 0
--        }
-
 --charToScode :: Char -> Scancode
 --charToScode = Scancode . fromIntegral . (\x -> x - 61) . fromEnum

@@ -215,7 +202,7 @@ unpause w = resumeSound $ w & uvScreenLayers .~ []

 displayControls :: Universe -> ScreenLayer
 --displayControls = const $ ColumnsScreen "CONTROLS" listControls
-displayControls = optionsNoWrite "CONTROLS" $ map (Toggle id . const . uncurry MODStringOption) listControls
+displayControls = titleOptionsNoWrite "CONTROLS" $ map (Toggle id . const . uncurry MODStringOption) listControls

 listControls :: [(String, String)]
 listControls =
@@ -1,29 +1,31 @@
-module Dodge.Menu.Option
-    where
+module Dodge.Menu.Option where
+
 --import Dodge.ScodeToChar
 import Data.Maybe
 --import Dodge.WindowLayout
-import Dodge.SelectionList
-import Padding
-import Picture.Base
+
+import qualified Data.Set as Set
 import Dodge.Data.CardinalPoint
 import Dodge.Data.SelectionList
 import Dodge.Data.Universe
-import qualified Data.Set as Set
+import Dodge.SelectionList
 import LensHelp
+import Padding
+import Picture.Base

 optionListDisplayParams :: ListDisplayParams
-optionListDisplayParams = ListDisplayParams
+optionListDisplayParams =
+    ListDisplayParams
        { _ldpPosX = 50
        , _ldpPosY = 50
        , _ldpScale = 2
        , _ldpVerticalGap = 30
-            , _ldpWidth = FixedSelectionWidth 15
-            , _ldpCursorType = BorderCursor (Set.fromList [North,South,West])
+        , _ldpWidth = FixedSelectionWidth 50
+        , _ldpCursorType = BorderCursor (Set.fromList [North, South, West])
        }

-initializeOptionMenu' :: String -> [MenuOption] -> PositionedMenuOption -> Universe -> ScreenLayer
-initializeOptionMenu' title ops pmo u =
+initializeOptionMenu :: String -> [MenuOption] -> PositionedMenuOption -> Universe -> ScreenLayer
+initializeOptionMenu title ops pmo u =
    OptionScreen
        { _scTitle = title
        , _scOptions = ops
@@ -35,42 +37,49 @@ initializeOptionMenu' title ops pmo u =
        , _scListDisplayParams = optionListDisplayParams
        }

-initializeOptionMenu :: String -> [MenuOption] -> Maybe String -> (Universe -> Universe) -> Universe -> ScreenLayer
-initializeOptionMenu title ops defstr eff = initializeOptionMenu' title ops pmo
+-- BO = Bottom Option
+initializeOptionMenuBO :: String -> [MenuOption] -> String -> (Universe -> Universe) -> Universe -> ScreenLayer
+initializeOptionMenuBO title ops str eff = initializeOptionMenu title ops pmo
  where
-    pmo = case defstr of
-            Nothing -> NoPositionedMenuOption
-            Just str -> BottomMenuOption $ (Toggle eff . const . MODString) str
+    pmo = BottomMenuOption $ (Toggle eff . const . MODString) str

 refreshOptionsSelectionList :: Universe -> Universe
 refreshOptionsSelectionList u = u & uvScreenLayers . ix 0 %~ f
  where
    f sl = case sl of
-        OptionScreen {_scOptions = mops
+        OptionScreen
+            { _scOptions = mops
            , _scPositionedMenuOption = pmo
-            , _scAvailableLines = maxlines} 
-            -> sl & scSelectionList . slItems .~ optionsToSelections maxlines u mops pmo
+            , _scAvailableLines = maxlines
+            } ->
+                sl & scSelectionList . slItems .~ optionsToSelections maxlines u mops pmo
        _ -> sl

-makeOptionsSelectionList :: Int -> Maybe Int -> Universe -> [MenuOption] -> PositionedMenuOption
-    -> SelectionList (Universe -> Universe)
-makeOptionsSelectionList maxlines mselpos u mos pmo = SelectionList
+makeOptionsSelectionList ::
+    Int ->
+    Maybe Int ->
+    Universe ->
+    [MenuOption] ->
+    PositionedMenuOption ->
+    SelectionList (Universe -> Universe)
+makeOptionsSelectionList maxlines mselpos u mos pmo =
+    SelectionList
        { _slItems = optionsToSelections maxlines u mos pmo
        , _slSelPos = mselpos
        , _slLength = length $ optionsToSelections maxlines u mos pmo
        }

 optionsToSelections :: Int -> Universe -> [MenuOption] -> PositionedMenuOption -> [SelectionItem (Universe -> Universe)]
-optionsToSelections maxlines u allops pmo = sits
-  where
-    offset = fromMaybe 0 $ u ^? uvScreenLayers . _head . scOffset
-    ops | maxlines >= length allops = allops 
-        | otherwise = take (maxlines - 2) (drop offset allops ++ repeat dummyMenuOption) ++ [cycleOptionsOption]
-    maxOptionLength = 3 + maximum (0 : map (optionValueOffset u) ops)
-    sits = case pmo of
+optionsToSelections maxlines u allops pmo = case pmo of
    NoPositionedMenuOption -> map (menuOptionToSelectionItem u maxOptionLength) ops
    TopMenuOption mo -> map (menuOptionToSelectionItem u maxOptionLength) (mo : ops)
    BottomMenuOption mo -> map (menuOptionToSelectionItem u maxOptionLength) (ops ++ [mo])
+  where
+    offset = fromMaybe 0 $ u ^? uvScreenLayers . _head . scOffset
+    ops
+        | maxlines >= length allops = allops
+        | otherwise = take (maxlines - 2) (drop offset allops ++ repeat dummyMenuOption) ++ [cycleOptionsOption]
+    maxOptionLength = 3 + maximum (0 : map (optionValueOffset u) ops)
    cycleOptionsOption = Toggle cycleOptions (const (MODString ("MORE OPTIONS " ++ show n ++ "/" ++ show m)))
    l = length allops
    m = div (l - 1) (max 1 (maxlines - 2)) + 1
@@ -86,11 +95,13 @@ cycleOptions u = fromMaybe u $ do
    numoptions <- fmap length $ screen ^? scOptions
    return $ u & uvScreenLayers . _head . scOffset %~ f numoptions (maxlines - 2)
  where
-    f n l curoff | l + curoff >= n = 0
+    f n l curoff
+        | l + curoff >= n = 0
        | otherwise = l + curoff

-colStrToSelItem :: (Color,String) -> SelectionItem (Universe -> Universe)
-colStrToSelItem (col,str) = SelectionItem
+colStrToSelItem :: (Color, String) -> SelectionItem (Universe -> Universe)
+colStrToSelItem (col, str) =
+    SelectionItem
        { _siPictures = [color col $ text str]
        , _siHeight = 1
        , _siIsSelectable = True
@@ -106,7 +117,8 @@ optionValueOffset u mo = case _moString mo u of
    _ -> 0

 menuOptionToSelectionItem :: Universe -> Int -> MenuOption -> SelectionItem (Universe -> Universe)
-menuOptionToSelectionItem w padAmount mo = SelectionItem
+menuOptionToSelectionItem w padAmount mo =
+    SelectionItem
        { _siPictures = [color thecol $ text optionText]
        , _siHeight = 1
        , _siIsSelectable = isselectable
@@ -127,7 +139,6 @@ menuOptionToSelectionItem w padAmount mo = SelectionItem
        MODStringOption s t -> rightPad padAmount '.' s ++ t
        x -> _modString x

-
 menuOptionToString :: Universe -> Int -> MenuOption -> (Color, String)
 menuOptionToString w padAmount mo = (thecol, optionText)
  where
@@ -7,9 +7,8 @@ import LensHelp
 --import Data.Maybe

 getAvailableListLines :: ListDisplayParams -> Configuration -> Int
-getAvailableListLines ldps cfig = nlines
+getAvailableListLines ldps cfig = floor ((dToBot - vgap) / itmHeight)
  where
-    nlines = floor ((dToBot - vgap) / itmHeight)
    vgap = ldps ^. ldpVerticalGap
    itmHeight = 10 * ldps ^. ldpScale + vgap
    dToBot = cfig ^. windowY - (ldps ^. ldpPosY + dFromScreenBot)
@@ -124,8 +124,8 @@ mouseOverSelectionList ldps sl u
    hh = halfHeight cfig
    hw = halfWidth cfig

-setSelectionListRestriction' :: Configuration -> ScreenLayer -> ScreenLayer
-setSelectionListRestriction' cfig screen = fromMaybe screen $ do
+setSelectionListRestriction :: Configuration -> ScreenLayer -> ScreenLayer
+setSelectionListRestriction cfig screen = fromMaybe screen $ do
    ldps <- screen ^? scListDisplayParams
    return $ screen & scAvailableLines %~ const (getAvailableListLines ldps cfig)

@@ -150,17 +150,17 @@ optionScreenUpdate ::
    Universe
 optionScreenUpdate screen mop _ ldps sl u =
    refreshOptionsSelectionList
-        . optionScreenDefEff mop
+        . optionScreenDefaultEffect mop
        . mouseClickOptionsList screen
        . mouseOverSelectionList ldps sl
        . menuWheelEvents
-        . over (uvScreenLayers . _head) (setSelectionListRestriction' cfig)
+        . over (uvScreenLayers . _head) (setSelectionListRestriction cfig)
        $ u
  where
    cfig = u ^. uvConfig

-optionScreenDefEff :: PositionedMenuOption -> Universe -> Universe
-optionScreenDefEff f u = case u ^. uvWorld . input . pressedKeys . at ScancodeEscape of
+optionScreenDefaultEffect :: PositionedMenuOption -> Universe -> Universe
+optionScreenDefaultEffect f u = case u ^. uvWorld . input . pressedKeys . at ScancodeEscape of
    Just InitialPress -> fromMaybe id (f ^? pmoMenuOption . moEff) u
    _ -> u