justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Cleanup

Browse Source
This commit is contained in:
justin
2022-12-26 23:14:30 +00:00
parent 1bafb427df
commit eecc38d68f
4 changed files with 142 additions and 145 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Menu.hs
+27 -40
View File
@@ -4,11 +4,13 @@ module Dodge.Menu (
splashMenu, splashMenu,
) where ) where
import Dodge.Data.SelectionList
import ShortShow
import Control.Monad import Control.Monad
--import SDL
import Data.Maybe
import Dodge.Concurrent import Dodge.Concurrent
import Dodge.Config.Update import Dodge.Config.Update
import Dodge.Data.SelectionList
import Dodge.Data.Universe import Dodge.Data.Universe
import Dodge.Menu.Option import Dodge.Menu.Option
import Dodge.Menu.OptionType import Dodge.Menu.OptionType
@@ -20,14 +22,13 @@ import Dodge.StartNewGame
import LensHelp import LensHelp
import MaybeHelp import MaybeHelp
import Padding import Padding
--import SDL import ShortShow
import System.Clipboard import System.Clipboard
import Text.Read import Text.Read
import Data.Maybe
splashMenu :: Universe -> ScreenLayer splashMenu :: Universe -> ScreenLayer
splashMenu u = splashMenu u =
initializeOptionMenu "AMNESIS" splashMenuOptions Nothing id u initializeOptionMenu "AMNESIS" splashMenuOptions NoPositionedMenuOption u
& scOptionFlag .~ SplashOptions & scOptionFlag .~ SplashOptions
splashMenuOptions :: [MenuOption] splashMenuOptions :: [MenuOption]
@@ -45,13 +46,15 @@ splashMenuOptions =
] ]
where where
opText = const . MODString opText = const . MODString
displaycontinue u | _uvCanContinue u = MODString "CONTINUE" displaycontinue u
| _uvCanContinue u = MODString "CONTINUE"
| otherwise = MODBlockedString "CONTINUE" | otherwise = MODBlockedString "CONTINUE"
displaywhenseed str u | isNothing (_uvMSeed u) = MODBlockedString str displaywhenseed str u
| isNothing (_uvMSeed u) = MODBlockedString str
| otherwise = MODString str | otherwise = MODString str
pauseMenu :: Universe -> ScreenLayer pauseMenu :: Universe -> ScreenLayer
pauseMenu = initializeOptionMenu' "PAUSED" pauseMenuOptions pmo pauseMenu = initializeOptionMenu "PAUSED" pauseMenuOptions pmo
where where
pmo = TopMenuOption $ Toggle unpause (const (MODString "CONTINUE")) pmo = TopMenuOption $ Toggle unpause (const (MODString "CONTINUE"))
@@ -71,14 +74,13 @@ pauseMenuOptions =
saveQuit :: Universe -> Universe saveQuit :: Universe -> Universe
saveQuit u = u & addSideEffect (saveQuitConc u) "SAVING" saveQuit u = u & addSideEffect (saveQuitConc u) "SAVING"
saveQuitConc :: Universe -> IO (Universe -> Maybe Universe) saveQuitConc :: Universe -> IO (Universe -> Maybe Universe)
saveQuitConc u = do saveQuitConc u = do
void $ writeSaveSlot (SaveSlotNum 0) u void $ writeSaveSlot (SaveSlotNum 0) u
return $ const Nothing return $ const Nothing
seedStartMenu :: String -> Universe -> ScreenLayer seedStartMenu :: String -> Universe -> ScreenLayer
seedStartMenu str = initializeOptionMenu str seedStartOptions (Just "BACK") popScreen seedStartMenu str = titleOptionsNoWrite str seedStartOptions
seedStartOptions :: [MenuOption] seedStartOptions :: [MenuOption]
seedStartOptions = seedStartOptions =
@@ -91,19 +93,20 @@ trySeedFromClipboard u = do
mcstr <- getClipboardString mcstr <- getClipboardString
case mcstr >>= readMaybe of case mcstr >>= readMaybe of
Nothing -> Nothing ->
return $ pushScreen return $
pushScreen
(seedStartMenu "CLIPBOARD UNUSABLE, NEED INTEGER") (seedStartMenu "CLIPBOARD UNUSABLE, NEED INTEGER")
(u & uvScreenLayers %~ tail) (u & uvScreenLayers %~ tail)
Just i -> return $ startSeedGame 0 i u 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 :: Universe -> ScreenLayer
optionMenu = initializeOptionMenu "OPTIONS" optionsOptions (Just "BACK") popScreen optionMenu = titleOptionsNoWrite "OPTIONS" optionsOptions
optionsOptions :: [MenuOption] optionsOptions :: [MenuOption]
optionsOptions = optionsOptions =
@@ -114,10 +117,7 @@ optionsOptions =
] ]
debugMenu :: Universe -> ScreenLayer debugMenu :: Universe -> ScreenLayer
debugMenu = debugMenu = titleOptionsMenu "OPTIONS:GAMEPLAY" debugMenuOptions
slTitleOptions
"OPTIONS:GAMEPLAY"
debugMenuOptions
debugMenuOptions :: [MenuOption] debugMenuOptions :: [MenuOption]
debugMenuOptions = debugMenuOptions =
@@ -146,10 +146,7 @@ debugMenuOptions =
-- ] -- ]
-- $ map Scancode [4 ..] -- $ map Scancode [4 ..]
gameplayMenu :: Universe -> ScreenLayer gameplayMenu :: Universe -> ScreenLayer
gameplayMenu = gameplayMenu = titleOptionsMenu "OPTIONS:GAMEPLAY" gameplayMenuOptions
slTitleOptions
"OPTIONS:GAMEPLAY"
gameplayMenuOptions
gameplayMenuOptions :: [MenuOption] gameplayMenuOptions :: [MenuOption]
gameplayMenuOptions = gameplayMenuOptions =
@@ -157,10 +154,7 @@ gameplayMenuOptions =
] ]
soundMenu :: Universe -> ScreenLayer soundMenu :: Universe -> ScreenLayer
soundMenu = soundMenu = titleOptionsMenu "OPTIONS:VOLUME" soundMenuOptions
slTitleOptions
"OPTIONS:VOLUME"
soundMenuOptions
soundMenuOptions :: [MenuOption] soundMenuOptions :: [MenuOption]
soundMenuOptions = soundMenuOptions =
@@ -174,7 +168,8 @@ soundMenuOptions =
(change dec stype) (change dec stype)
(change inc stype) (change inc stype)
(\w -> MODStringOption str (leftPad 2 '.' $ show (round $ 10 * voltype (_uvConfig w) :: Int))) (\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 & uvIOEffects .~ \u -> sw uv >> return u
dec x = max 0 (x - 0.1) dec x = max 0 (x - 0.1)
inc x = min 1 (x + 0.1) inc x = min 1 (x + 0.1)
@@ -184,7 +179,7 @@ writeConfig :: Universe -> Universe
writeConfig w = w & uvIOEffects %~ saveConfig (_uvConfig w) writeConfig w = w & uvIOEffects %~ saveConfig (_uvConfig w)
graphicsMenu :: Universe -> ScreenLayer graphicsMenu :: Universe -> ScreenLayer
graphicsMenu = slTitleOptions "OPTIONS:GRAPHICS" graphicsMenuOptions graphicsMenu = titleOptionsMenu "OPTIONS:GRAPHICS" graphicsMenuOptions
graphicsMenuOptions :: [MenuOption] graphicsMenuOptions :: [MenuOption]
graphicsMenuOptions = graphicsMenuOptions =
@@ -196,17 +191,9 @@ graphicsMenuOptions =
gameOverMenu :: Universe -> ScreenLayer gameOverMenu :: Universe -> ScreenLayer
gameOverMenu u = gameOverMenu u =
initializeOptionMenu "GAME OVER" pauseMenuOptions Nothing id u initializeOptionMenu "GAME OVER" pauseMenuOptions NoPositionedMenuOption u
& scOptionFlag .~ GameOverOptions & scOptionFlag .~ GameOverOptions
-- OptionScreen
-- { _scTitle = const "GAME OVER"
-- , _scOptions = pauseMenuOptions
-- , _scDefaultEff = return . Just
-- , _scOptionFlag = GameOverOptions
-- , _scOptionsOffset = 0
-- }
--charToScode :: Char -> Scancode --charToScode :: Char -> Scancode
--charToScode = Scancode . fromIntegral . (\x -> x - 61) . fromEnum --charToScode = Scancode . fromIntegral . (\x -> x - 61) . fromEnum
@@ -215,7 +202,7 @@ unpause w = resumeSound $ w & uvScreenLayers .~ []
displayControls :: Universe -> ScreenLayer displayControls :: Universe -> ScreenLayer
--displayControls = const $ ColumnsScreen "CONTROLS" listControls --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 :: [(String, String)]
listControls = listControls =
src/Dodge/Menu/Option.hs
+43 -32
View File
@@ -1,29 +1,31 @@
module Dodge.Menu.Option module Dodge.Menu.Option where
where
--import Dodge.ScodeToChar --import Dodge.ScodeToChar
import Data.Maybe import Data.Maybe
--import Dodge.WindowLayout --import Dodge.WindowLayout
import Dodge.SelectionList
import Padding import qualified Data.Set as Set
import Picture.Base
import Dodge.Data.CardinalPoint import Dodge.Data.CardinalPoint
import Dodge.Data.SelectionList import Dodge.Data.SelectionList
import Dodge.Data.Universe import Dodge.Data.Universe
import qualified Data.Set as Set import Dodge.SelectionList
import LensHelp import LensHelp
import Padding
import Picture.Base
optionListDisplayParams :: ListDisplayParams optionListDisplayParams :: ListDisplayParams
optionListDisplayParams = ListDisplayParams optionListDisplayParams =
ListDisplayParams
{ _ldpPosX = 50 { _ldpPosX = 50
, _ldpPosY = 50 , _ldpPosY = 50
, _ldpScale = 2 , _ldpScale = 2
, _ldpVerticalGap = 30 , _ldpVerticalGap = 30
, _ldpWidth = FixedSelectionWidth 15 , _ldpWidth = FixedSelectionWidth 50
, _ldpCursorType = BorderCursor (Set.fromList [North, South, West]) , _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 OptionScreen
{ _scTitle = title { _scTitle = title
, _scOptions = ops , _scOptions = ops
@@ -35,42 +37,49 @@ initializeOptionMenu' title ops pmo u =
, _scListDisplayParams = optionListDisplayParams , _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 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 :: Universe -> Universe
refreshOptionsSelectionList u = u & uvScreenLayers . ix 0 %~ f refreshOptionsSelectionList u = u & uvScreenLayers . ix 0 %~ f
where where
f sl = case sl of f sl = case sl of
OptionScreen {_scOptions = mops OptionScreen
{ _scOptions = mops
, _scPositionedMenuOption = pmo , _scPositionedMenuOption = pmo
, _scAvailableLines = maxlines} , _scAvailableLines = maxlines
-> sl & scSelectionList . slItems .~ optionsToSelections maxlines u mops pmo } ->
sl & scSelectionList . slItems .~ optionsToSelections maxlines u mops pmo
_ -> sl _ -> sl
makeOptionsSelectionList :: Int -> Maybe Int -> Universe -> [MenuOption] -> PositionedMenuOption makeOptionsSelectionList ::
-> SelectionList (Universe -> Universe) Int ->
makeOptionsSelectionList maxlines mselpos u mos pmo = SelectionList Maybe Int ->
Universe ->
[MenuOption] ->
PositionedMenuOption ->
SelectionList (Universe -> Universe)
makeOptionsSelectionList maxlines mselpos u mos pmo =
SelectionList
{ _slItems = optionsToSelections maxlines u mos pmo { _slItems = optionsToSelections maxlines u mos pmo
, _slSelPos = mselpos , _slSelPos = mselpos
, _slLength = length $ optionsToSelections maxlines u mos pmo , _slLength = length $ optionsToSelections maxlines u mos pmo
} }
optionsToSelections :: Int -> Universe -> [MenuOption] -> PositionedMenuOption -> [SelectionItem (Universe -> Universe)] optionsToSelections :: Int -> Universe -> [MenuOption] -> PositionedMenuOption -> [SelectionItem (Universe -> Universe)]
optionsToSelections maxlines u allops pmo = sits optionsToSelections maxlines u allops pmo = case pmo of
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
NoPositionedMenuOption -> map (menuOptionToSelectionItem u maxOptionLength) ops NoPositionedMenuOption -> map (menuOptionToSelectionItem u maxOptionLength) ops
TopMenuOption mo -> map (menuOptionToSelectionItem u maxOptionLength) (mo : ops) TopMenuOption mo -> map (menuOptionToSelectionItem u maxOptionLength) (mo : ops)
BottomMenuOption mo -> map (menuOptionToSelectionItem u maxOptionLength) (ops ++ [mo]) 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))) cycleOptionsOption = Toggle cycleOptions (const (MODString ("MORE OPTIONS " ++ show n ++ "/" ++ show m)))
l = length allops l = length allops
m = div (l - 1) (max 1 (maxlines - 2)) + 1 m = div (l - 1) (max 1 (maxlines - 2)) + 1
@@ -86,11 +95,13 @@ cycleOptions u = fromMaybe u $ do
numoptions <- fmap length $ screen ^? scOptions numoptions <- fmap length $ screen ^? scOptions
return $ u & uvScreenLayers . _head . scOffset %~ f numoptions (maxlines - 2) return $ u & uvScreenLayers . _head . scOffset %~ f numoptions (maxlines - 2)
where where
f n l curoff | l + curoff >= n = 0 f n l curoff
| l + curoff >= n = 0
| otherwise = l + curoff | otherwise = l + curoff
colStrToSelItem :: (Color, String) -> SelectionItem (Universe -> Universe) colStrToSelItem :: (Color, String) -> SelectionItem (Universe -> Universe)
colStrToSelItem (col,str) = SelectionItem colStrToSelItem (col, str) =
SelectionItem
{ _siPictures = [color col $ text str] { _siPictures = [color col $ text str]
, _siHeight = 1 , _siHeight = 1
, _siIsSelectable = True , _siIsSelectable = True
@@ -106,7 +117,8 @@ optionValueOffset u mo = case _moString mo u of
_ -> 0 _ -> 0
menuOptionToSelectionItem :: Universe -> Int -> MenuOption -> SelectionItem (Universe -> Universe) menuOptionToSelectionItem :: Universe -> Int -> MenuOption -> SelectionItem (Universe -> Universe)
menuOptionToSelectionItem w padAmount mo = SelectionItem menuOptionToSelectionItem w padAmount mo =
SelectionItem
{ _siPictures = [color thecol $ text optionText] { _siPictures = [color thecol $ text optionText]
, _siHeight = 1 , _siHeight = 1
, _siIsSelectable = isselectable , _siIsSelectable = isselectable
@@ -127,7 +139,6 @@ menuOptionToSelectionItem w padAmount mo = SelectionItem
MODStringOption s t -> rightPad padAmount '.' s ++ t MODStringOption s t -> rightPad padAmount '.' s ++ t
x -> _modString x x -> _modString x
menuOptionToString :: Universe -> Int -> MenuOption -> (Color, String) menuOptionToString :: Universe -> Int -> MenuOption -> (Color, String)
menuOptionToString w padAmount mo = (thecol, optionText) menuOptionToString w padAmount mo = (thecol, optionText)
where where
src/Dodge/SelectionList.hs
+1 -2
View File
@@ -7,9 +7,8 @@ import LensHelp
--import Data.Maybe --import Data.Maybe
getAvailableListLines :: ListDisplayParams -> Configuration -> Int getAvailableListLines :: ListDisplayParams -> Configuration -> Int
getAvailableListLines ldps cfig = nlines getAvailableListLines ldps cfig = floor ((dToBot - vgap) / itmHeight)
where where
nlines = floor ((dToBot - vgap) / itmHeight)
vgap = ldps ^. ldpVerticalGap vgap = ldps ^. ldpVerticalGap
itmHeight = 10 * ldps ^. ldpScale + vgap itmHeight = 10 * ldps ^. ldpScale + vgap
dToBot = cfig ^. windowY - (ldps ^. ldpPosY + dFromScreenBot) dToBot = cfig ^. windowY - (ldps ^. ldpPosY + dFromScreenBot)
src/Dodge/Update.hs
+6 -6
View File
@@ -124,8 +124,8 @@ mouseOverSelectionList ldps sl u
hh = halfHeight cfig hh = halfHeight cfig
hw = halfWidth 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 ldps <- screen ^? scListDisplayParams
return $ screen & scAvailableLines %~ const (getAvailableListLines ldps cfig) return $ screen & scAvailableLines %~ const (getAvailableListLines ldps cfig)
@@ -150,17 +150,17 @@ optionScreenUpdate ::
Universe Universe
optionScreenUpdate screen mop _ ldps sl u = optionScreenUpdate screen mop _ ldps sl u =
refreshOptionsSelectionList refreshOptionsSelectionList
. optionScreenDefEff mop . optionScreenDefaultEffect mop
. mouseClickOptionsList screen . mouseClickOptionsList screen
. mouseOverSelectionList ldps sl . mouseOverSelectionList ldps sl
. menuWheelEvents . menuWheelEvents
. over (uvScreenLayers . _head) (setSelectionListRestriction' cfig) . over (uvScreenLayers . _head) (setSelectionListRestriction cfig)
$ u $ u
where where
cfig = u ^. uvConfig 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 Just InitialPress -> fromMaybe id (f ^? pmoMenuOption . moEff) u
_ -> u _ -> u