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,65 +22,65 @@ 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 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")
-        , Toggle (pushScreen $ seedStartMenu "START FROM SEED") (opText "NEW WITH SPECIFIC SEED")
-        , Toggle (pushScreen optionMenu) (opText "OPTIONS")
-        , Toggle (pushScreen displayControls) (opText "VIEW CONTROLS")
-        , Toggle id (displaywhenseed "VIEW LAST SEED")
-        , Toggle hardQuit  (opText "QUIT")
-        ]
+    [ 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 reloadLevelStart (displaywhenseed "NEW WITH LAST SEED")
+    , Toggle (pushScreen $ seedStartMenu "START FROM SEED") (opText "NEW WITH SPECIFIC SEED")
+    , Toggle (pushScreen optionMenu) (opText "OPTIONS")
+    , Toggle (pushScreen displayControls) (opText "VIEW CONTROLS")
+    , Toggle id (displaywhenseed "VIEW LAST SEED")
+    , Toggle hardQuit (opText "QUIT")
+    ]
  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"))

 pauseMenuOptions :: [MenuOption]
 pauseMenuOptions =
-        [ Toggle (startNewGameInSlot 0) (opText "NEW GAME")
-        , Toggle reloadLevelStart (opText "RESTART")
-        , Toggle (pushScreen $ seedStartMenu "START FROM SEED") (opText "NEW FROM SEED")
-        , Toggle (pushScreen optionMenu) (opText "OPTIONS")
-        , Toggle (pushScreen displayControls) (opText "VIEW CONTROLS")
-        , Toggle id (opText "VIEW CURRENT SEED")
-        , Toggle saveQuit (opText "SAVE AND QUIT")
-        ]
+    [ Toggle (startNewGameInSlot 0) (opText "NEW GAME")
+    , Toggle reloadLevelStart (opText "RESTART")
+    , Toggle (pushScreen $ seedStartMenu "START FROM SEED") (opText "NEW FROM SEED")
+    , Toggle (pushScreen optionMenu) (opText "OPTIONS")
+    , Toggle (pushScreen displayControls) (opText "VIEW CONTROLS")
+    , Toggle id (opText "VIEW CURRENT SEED")
+    , Toggle saveQuit (opText "SAVE AND QUIT")
+    ]
  where
    opText = const . MODString

 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,37 +93,35 @@ trySeedFromClipboard u = do
    mcstr <- getClipboardString
    case mcstr >>= readMaybe of
        Nothing ->
-            return $ pushScreen
-                (seedStartMenu "CLIPBOARD UNUSABLE, NEED INTEGER")
-                (u & uvScreenLayers %~ tail)
+            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 =
-        [ makeSubmenuOption soundMenu $ MODString "VOLUME"
-        , makeSubmenuOption graphicsMenu $ MODString "GRAPHICS"
-        , makeSubmenuOption gameplayMenu $ MODString "GAMEPLAY"
-        , makeSubmenuOption debugMenu $ MODString "DEBUG OPTIONS"
-        ]
+    [ makeSubmenuOption soundMenu $ MODString "VOLUME"
+    , makeSubmenuOption graphicsMenu $ MODString "GRAPHICS"
+    , makeSubmenuOption gameplayMenu $ MODString "GAMEPLAY"
+    , makeSubmenuOption debugMenu $ MODString "DEBUG OPTIONS"
+    ]

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

 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 =
@@ -146,27 +146,21 @@ debugMenuOptions =
 --    ]
 --    $ map Scancode [4 ..]
 gameplayMenu :: Universe -> ScreenLayer
-gameplayMenu =
-    slTitleOptions
-        "OPTIONS:GAMEPLAY"
-        gameplayMenuOptions
+gameplayMenu = titleOptionsMenu "OPTIONS:GAMEPLAY" gameplayMenuOptions

 gameplayMenuOptions :: [MenuOption]
 gameplayMenuOptions =
-        [ makeBoolOption gameplay_rotate_to_wall "ROTATE TO WALL"
-        ]
+    [ makeBoolOption gameplay_rotate_to_wall "ROTATE TO WALL"
+    ]

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

 soundMenuOptions :: [MenuOption]
 soundMenuOptions =
    [ theoption volume_master "MASTER VOLUME" _volume_master
-    , theoption volume_sound  "EFFECTS VOLUME" _volume_sound
-    , theoption volume_music  "MUSIC VOLUME" _volume_music
+    , theoption volume_sound "EFFECTS VOLUME" _volume_sound
+    , theoption volume_music "MUSIC VOLUME" _volume_music
    ]
  where
    theoption stype str voltype =
@@ -174,8 +168,9 @@ 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
-        & uvIOEffects .~ \u -> sw uv >> return u
+    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)
    sw w = setVol (_uvConfig w)
@@ -184,29 +179,21 @@ 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 =
-        [ makeEnumOption graphics_resolution_factor "RESOLUTION" (uvIOEffects .~ updateFramebufferSize)
-        , makeBoolOption graphics_wall_textured "WALL TEXTURES"
-        , makeBoolOption graphics_object_shadows "OBJECT SHADOWS"
-        , makeBoolOption graphics_cloud_shadows "CLOUD SHADOWS"
-        ]
+    [ makeEnumOption graphics_resolution_factor "RESOLUTION" (uvIOEffects .~ updateFramebufferSize)
+    , makeBoolOption graphics_wall_textured "WALL TEXTURES"
+    , makeBoolOption graphics_object_shadows "OBJECT SHADOWS"
+    , makeBoolOption graphics_cloud_shadows "CLOUD SHADOWS"
+    ]

 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,76 +1,85 @@
-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
-            { _ldpPosX = 50
-            , _ldpPosY = 50
-            , _ldpScale = 2
-            , _ldpVerticalGap = 30
-            , _ldpWidth = FixedSelectionWidth 15
-            , _ldpCursorType = BorderCursor (Set.fromList [North,South,West])
-            } 
+optionListDisplayParams =
+    ListDisplayParams
+        { _ldpPosX = 50
+        , _ldpPosY = 50
+        , _ldpScale = 2
+        , _ldpVerticalGap = 30
+        , _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
        , _scOffset = 0
-        , _scPositionedMenuOption = pmo 
+        , _scPositionedMenuOption = pmo
        , _scOptionFlag = NormalOptions
        , _scSelectionList = makeOptionsSelectionList 10 (Just 0) u ops pmo
        , _scAvailableLines = getAvailableListLines optionListDisplayParams (u ^. uvConfig)
        , _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
-    { _slItems = optionsToSelections maxlines u mos pmo
-    , _slSelPos = mselpos
-    , _slLength = length $ optionsToSelections maxlines u mos pmo
-    }
+
+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
+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 
+    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
-        NoPositionedMenuOption -> map (menuOptionToSelectionItem u maxOptionLength) ops
-        TopMenuOption mo -> map (menuOptionToSelectionItem u maxOptionLength) (mo : ops)
-        BottomMenuOption mo -> map (menuOptionToSelectionItem u maxOptionLength) (ops ++ [mo])
    cycleOptionsOption = Toggle cycleOptions (const (MODString ("MORE OPTIONS " ++ show n ++ "/" ++ show m)))
    l = length allops
    m = div (l - 1) (max 1 (maxlines - 2)) + 1
@@ -86,19 +95,21 @@ 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
-    { _siPictures = [color col $ text str]
-    , _siHeight = 1
-    , _siIsSelectable = True
-    , _siWidth = length str
-    , _siColor = col
-    , _siOffX = 0
-    , _siPayload = id
-    }
+colStrToSelItem :: (Color, String) -> SelectionItem (Universe -> Universe)
+colStrToSelItem (col, str) =
+    SelectionItem
+        { _siPictures = [color col $ text str]
+        , _siHeight = 1
+        , _siIsSelectable = True
+        , _siWidth = length str
+        , _siColor = col
+        , _siOffX = 0
+        , _siPayload = id
+        }

 optionValueOffset :: Universe -> MenuOption -> Int
 optionValueOffset u mo = case _moString mo u of
@@ -106,15 +117,16 @@ optionValueOffset u mo = case _moString mo u of
    _ -> 0

 menuOptionToSelectionItem :: Universe -> Int -> MenuOption -> SelectionItem (Universe -> Universe)
-menuOptionToSelectionItem w padAmount mo = SelectionItem
-    { _siPictures = [color thecol $ text optionText]
-    , _siHeight = 1
-    , _siIsSelectable = isselectable
-    , _siWidth = length optionText
-    , _siColor = white
-    , _siOffX = 0
-    , _siPayload = f
-    }
+menuOptionToSelectionItem w padAmount mo =
+    SelectionItem
+        { _siPictures = [color thecol $ text optionText]
+        , _siHeight = 1
+        , _siIsSelectable = isselectable
+        , _siWidth = length optionText
+        , _siColor = white
+        , _siOffX = 0
+        , _siPayload = f
+        }
  where
    isselectable = case _moString mo w of
        MODBlockedString{} -> False
@@ -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