Cleanup

src/Dodge/Menu.hs

@@ -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 (loadSaveSlot (SaveSlotNum 0)) displaycontinue
-        , Toggle id (\u -> MODString $ show $ u ^? uvScreenLayers . _head . scSelectionList . slSelPos . _Just)
+    , Toggle id (\u -> MODString $ show $ u ^? uvScreenLayers . _head . scSelectionList . slSelPos . _Just)
-        , Toggle id (\u -> MODString $ shortShow $ u ^. uvWorld . input . mousePos)
+    , 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 reloadLevelStart (displaywhenseed "NEW WITH LAST SEED")
-        , Toggle (pushScreen $ seedStartMenu "START FROM SEED") (opText "NEW WITH SPECIFIC SEED")
+    , Toggle (pushScreen $ seedStartMenu "START FROM SEED") (opText "NEW WITH SPECIFIC SEED")
-        , Toggle (pushScreen optionMenu) (opText "OPTIONS")
+    , Toggle (pushScreen optionMenu) (opText "OPTIONS")
-        , Toggle (pushScreen displayControls) (opText "VIEW CONTROLS")
+    , Toggle (pushScreen displayControls) (opText "VIEW CONTROLS")
-        , Toggle id (displaywhenseed "VIEW LAST SEED")
+    , Toggle id (displaywhenseed "VIEW LAST SEED")
-        , Toggle hardQuit  (opText "QUIT")
+    , 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 (startNewGameInSlot 0) (opText "NEW GAME")
-        , Toggle reloadLevelStart (opText "RESTART")
+    , Toggle reloadLevelStart (opText "RESTART")
-        , Toggle (pushScreen $ seedStartMenu "START FROM SEED") (opText "NEW FROM SEED")
+    , Toggle (pushScreen $ seedStartMenu "START FROM SEED") (opText "NEW FROM SEED")
-        , Toggle (pushScreen optionMenu) (opText "OPTIONS")
+    , Toggle (pushScreen optionMenu) (opText "OPTIONS")
-        , Toggle (pushScreen displayControls) (opText "VIEW CONTROLS")
+    , Toggle (pushScreen displayControls) (opText "VIEW CONTROLS")
-        , Toggle id (opText "VIEW CURRENT SEED")
+    , Toggle id (opText "VIEW CURRENT SEED")
-        , Toggle saveQuit (opText "SAVE AND QUIT")
+    , 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
+            return $
-                (seedStartMenu "CLIPBOARD UNUSABLE, NEED INTEGER")
+                pushScreen
-                (u & uvScreenLayers %~ tail)
+                    (seedStartMenu "CLIPBOARD UNUSABLE, NEED INTEGER")
+                    (u & uvScreenLayers %~ tail)
         Just i -> return $ startSeedGame 0 i u
 
-slTitleOptions :: String -> [MenuOption] -> Universe -> ScreenLayer
+titleOptionsMenu :: String -> [MenuOption] -> Universe -> ScreenLayer
-slTitleOptions title ops = initializeOptionMenu title ops (Just "BACK") (popScreen . writeConfig)
+titleOptionsMenu title ops = initializeOptionMenuBO title ops "BACK" (popScreen . writeConfig)
 
-optionsNoWrite :: String -> [MenuOption] -> Universe -> ScreenLayer
+titleOptionsNoWrite :: String -> [MenuOption] -> Universe -> ScreenLayer
-optionsNoWrite title ops = initializeOptionMenu title ops (Just "BACK") popScreen
+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 soundMenu $ MODString "VOLUME"
-        , makeSubmenuOption graphicsMenu $ MODString "GRAPHICS"
+    , makeSubmenuOption graphicsMenu $ MODString "GRAPHICS"
-        , makeSubmenuOption gameplayMenu $ MODString "GAMEPLAY"
+    , makeSubmenuOption gameplayMenu $ MODString "GAMEPLAY"
-        , makeSubmenuOption debugMenu $ MODString "DEBUG OPTIONS"
+    , makeSubmenuOption debugMenu $ MODString "DEBUG OPTIONS"
-        ]
+    ]
 
 debugMenu :: Universe -> ScreenLayer
-debugMenu =
+debugMenu = titleOptionsMenu "OPTIONS:GAMEPLAY" debugMenuOptions
-    slTitleOptions
-        "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 =
+gameplayMenu = titleOptionsMenu "OPTIONS:GAMEPLAY" gameplayMenuOptions
-    slTitleOptions
-        "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 =
+soundMenu = titleOptionsMenu "OPTIONS:VOLUME" soundMenuOptions
-    slTitleOptions
-        "OPTIONS:VOLUME"
-        soundMenuOptions
 
 soundMenuOptions :: [MenuOption]
 soundMenuOptions =
     [ theoption volume_master "MASTER VOLUME" _volume_master
-    , theoption volume_sound  "EFFECTS VOLUME" _volume_sound
+    , theoption volume_sound "EFFECTS VOLUME" _volume_sound
-    , theoption volume_music  "MUSIC VOLUME" _volume_music
+    , 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
+    change g vt uv =
-        & uvIOEffects .~ \u -> sw uv >> return u
+        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)
+    [ makeEnumOption graphics_resolution_factor "RESOLUTION" (uvIOEffects .~ updateFramebufferSize)
-        , makeBoolOption graphics_wall_textured "WALL TEXTURES"
+    , makeBoolOption graphics_wall_textured "WALL TEXTURES"
-        , makeBoolOption graphics_object_shadows "OBJECT SHADOWS"
+    , makeBoolOption graphics_object_shadows "OBJECT SHADOWS"
-        , makeBoolOption graphics_cloud_shadows "CLOUD 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 =

src/Dodge/Menu/Option.hs

@@ -1,76 +1,85 @@
-module Dodge.Menu.Option
+module Dodge.Menu.Option where
-    where
+
 --import Dodge.ScodeToChar
 import Data.Maybe
 --import Dodge.WindowLayout
-import Dodge.SelectionList
+
-import Padding
+import qualified Data.Set as Set
-import Picture.Base
 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 =
-            { _ldpPosX = 50
+    ListDisplayParams
-            , _ldpPosY = 50
+        { _ldpPosX = 50
-            , _ldpScale = 2
+        , _ldpPosY = 50
-            , _ldpVerticalGap = 30
+        , _ldpScale = 2
-            , _ldpWidth = FixedSelectionWidth 15
+        , _ldpVerticalGap = 30
-            , _ldpCursorType = BorderCursor (Set.fromList [North,South,West])
+        , _ldpWidth = FixedSelectionWidth 50
-            } 
+        , _ldpCursorType = BorderCursor (Set.fromList [North, South, West])
+        }
 
-initializeOptionMenu' :: String -> [MenuOption] -> PositionedMenuOption -> Universe -> ScreenLayer
+initializeOptionMenu :: String -> [MenuOption] -> PositionedMenuOption -> Universe -> ScreenLayer
-initializeOptionMenu' title ops pmo u =
+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
+-- BO = Bottom Option
-initializeOptionMenu title ops defstr eff = initializeOptionMenu' title ops pmo
+initializeOptionMenuBO :: String -> [MenuOption] -> String -> (Universe -> Universe) -> Universe -> ScreenLayer
+initializeOptionMenuBO title ops str eff = initializeOptionMenu title ops pmo
   where
-    pmo = case defstr of
+    pmo = BottomMenuOption $ (Toggle eff . const . MODString) str
-            Nothing -> NoPositionedMenuOption
-            Just str -> 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} 
+            , _scAvailableLines = maxlines
-            -> sl & scSelectionList . slItems .~ optionsToSelections maxlines u mops pmo
+            } ->
+                sl & scSelectionList . slItems .~ optionsToSelections maxlines u mops pmo
         _ -> sl
-     
+
-makeOptionsSelectionList :: Int -> Maybe Int -> Universe -> [MenuOption] -> PositionedMenuOption
+makeOptionsSelectionList ::
-    -> SelectionList (Universe -> Universe)
+    Int ->
-makeOptionsSelectionList maxlines mselpos u mos pmo = SelectionList
+    Maybe Int ->
-    { _slItems = optionsToSelections maxlines u mos pmo
+    Universe ->
-    , _slSelPos = mselpos
+    [MenuOption] ->
-    , _slLength = length $ optionsToSelections maxlines u mos pmo
+    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 :: (Color, String) -> SelectionItem (Universe -> Universe)
-colStrToSelItem (col,str) = SelectionItem
+colStrToSelItem (col, str) =
-    { _siPictures = [color col $ text str]
+    SelectionItem
-    , _siHeight = 1
+        { _siPictures = [color col $ text str]
-    , _siIsSelectable = True
+        , _siHeight = 1
-    , _siWidth = length str
+        , _siIsSelectable = True
-    , _siColor = col
+        , _siWidth = length str
-    , _siOffX = 0
+        , _siColor = col
-    , _siPayload = id
+        , _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
+menuOptionToSelectionItem w padAmount mo =
-    { _siPictures = [color thecol $ text optionText]
+    SelectionItem
-    , _siHeight = 1
+        { _siPictures = [color thecol $ text optionText]
-    , _siIsSelectable = isselectable
+        , _siHeight = 1
-    , _siWidth = length optionText
+        , _siIsSelectable = isselectable
-    , _siColor = white
+        , _siWidth = length optionText
-    , _siOffX = 0
+        , _siColor = white
-    , _siPayload = f
+        , _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

src/Dodge/SelectionList.hs

@@ -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)

src/Dodge/Update.hs

@@ -124,8 +124,8 @@ mouseOverSelectionList ldps sl u
     hh = halfHeight cfig
     hw = halfWidth cfig
 
-setSelectionListRestriction' :: Configuration -> ScreenLayer -> ScreenLayer
+setSelectionListRestriction :: Configuration -> ScreenLayer -> ScreenLayer
-setSelectionListRestriction' cfig screen = fromMaybe screen $ do
+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
+optionScreenDefaultEffect :: PositionedMenuOption -> Universe -> Universe
-optionScreenDefEff f u = case u ^. uvWorld . input . pressedKeys . at ScancodeEscape of
+optionScreenDefaultEffect f u = case u ^. uvWorld . input . pressedKeys . at ScancodeEscape of
     Just InitialPress -> fromMaybe id (f ^? pmoMenuOption . moEff) u
     _ -> u