265 lines
8.6 KiB
Haskell
265 lines
8.6 KiB
Haskell
module Dodge.Menu (
|
|
pauseMenu,
|
|
gameOverMenu,
|
|
splashMenu,
|
|
) where
|
|
|
|
import Control.Monad
|
|
import qualified Data.Aeson.Encode.Pretty as AEP
|
|
import Data.ByteString.Lazy.Char8 (unpack)
|
|
import Data.Maybe
|
|
import Dodge.Base.Coordinate
|
|
import Dodge.Concurrent
|
|
import Dodge.Config
|
|
import Dodge.Data.Universe
|
|
import Dodge.Menu.Option
|
|
import Dodge.Menu.OptionType
|
|
import Dodge.Menu.PushPop
|
|
import Dodge.Save
|
|
import Dodge.SoundLogic
|
|
import Dodge.StartNewGame
|
|
import Geometry
|
|
import LensHelp
|
|
import MaybeHelp
|
|
import Padding
|
|
import Preload.Update
|
|
import qualified SDL
|
|
import System.Hclip
|
|
import System.Directory
|
|
import Text.Read
|
|
|
|
splashMenu :: Universe -> ScreenLayer
|
|
splashMenu =
|
|
(scOptionFlag .~ SplashOptions)
|
|
. initializeOptionMenu NoExtraMenuOption "GAME TITLE" splashMenuOptions
|
|
|
|
splashMenuOptions :: [MenuOption]
|
|
splashMenuOptions =
|
|
[ Toggle (loadSaveSlot (SaveSlotNum 0)) displaycontinue
|
|
, Toggle (startNewGameInSlot 0) (otext "NEW WITH RANDOM SEED")
|
|
, Toggle reloadLevelStart (displaywhenseed "NEW WITH LAST SEED")
|
|
, Toggle (pushScreen $ seedStartMenu "START FROM SEED") (otext "NEW WITH SPECIFIC SEED")
|
|
, Toggle (pushScreen optionMenu) (otext "OPTIONS")
|
|
, Toggle (pushScreen displayControls) (otext "VIEW CONTROLS")
|
|
, Toggle (pushScreen displayConfig) (otext "VIEW CONFIG")
|
|
, Toggle id (displaywhenseed "VIEW LAST SEED")
|
|
, Toggle hardQuit (otext "QUIT")
|
|
]
|
|
where
|
|
otext = const . MODString
|
|
displaycontinue u
|
|
| _uvCanContinue u = MODString "CONTINUE"
|
|
| otherwise = MODBlockedString "CONTINUE"
|
|
displaywhenseed str u
|
|
| isNothing (_uvMSeed u) = MODBlockedString str
|
|
| otherwise = MODString str
|
|
|
|
pauseMenu :: Universe -> ScreenLayer
|
|
pauseMenu =
|
|
initializeOptionMenu
|
|
(TopMenuOption $ Toggle unpause (const (MODString "CONTINUE")))
|
|
"PAUSED"
|
|
pauseMenuOptions
|
|
|
|
pauseMenuOptions :: [MenuOption]
|
|
pauseMenuOptions =
|
|
[ Toggle (startNewGameInSlot 0) (otext "NEW GAME")
|
|
, Toggle reloadLevelStart (otext "RESTART")
|
|
, Toggle (pushScreen $ seedStartMenu "START FROM SEED") (otext "NEW FROM SEED")
|
|
, Toggle (pushScreen optionMenu) (otext "OPTIONS")
|
|
, Toggle (pushScreen displayControls) (otext "VIEW CONTROLS")
|
|
, Toggle id (otext "VIEW CURRENT SEED")
|
|
, Toggle saveQuit (otext "SAVE AND QUIT")
|
|
]
|
|
where
|
|
otext = 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 = titleOptionsNoWrite str seedStartOptions
|
|
|
|
seedStartOptions :: [MenuOption]
|
|
seedStartOptions =
|
|
[ Toggle (uvIOEffects .~ trySeedFromClipboard) (const $ MODString "PASTE NUMBER FROM CLIPBOARD")
|
|
-- , Toggle ScancodeI (return . Just . loadSaveSlot LevelStartSlot) (const "INSERT NUMBER")
|
|
]
|
|
|
|
trySeedFromClipboard :: Universe -> IO Universe
|
|
trySeedFromClipboard u = do
|
|
str <- getClipboard
|
|
return $ case readMaybe str of
|
|
Nothing ->
|
|
pushScreen
|
|
(seedStartMenu "CLIPBOARD UNUSABLE, NEED INTEGER")
|
|
(u & uvScreenLayers %~ tail)
|
|
Just i -> startSeedGame 0 i u
|
|
|
|
titleOptionsMenu :: String -> [MenuOption] -> Universe -> ScreenLayer
|
|
titleOptionsMenu = initializeOptionMenuBO "BACK" (popScreen . writeConfig)
|
|
|
|
titleOptionsNoWrite :: String -> [MenuOption] -> Universe -> ScreenLayer
|
|
titleOptionsNoWrite = initializeOptionMenuBO "BACK" popScreen
|
|
|
|
optionMenu :: Universe -> ScreenLayer
|
|
optionMenu = titleOptionsNoWrite "OPTIONS" optionsOptions
|
|
|
|
optionsOptions :: [MenuOption]
|
|
optionsOptions =
|
|
[ makeSubmenuOption soundMenu $ MODString "VOLUME"
|
|
, makeSubmenuOption graphicsMenu $ MODString "GRAPHICS"
|
|
, makeSubmenuOption gameplayMenu $ MODString "GAMEPLAY"
|
|
, makeSubmenuOption debugMenu $ MODString "DEBUG"
|
|
, makeSubmenuOption logMenu $ MODString "LOG"
|
|
]
|
|
|
|
debugMenu :: Universe -> ScreenLayer
|
|
debugMenu = titleOptionsMenu "OPTIONS:DEBUG" debugMenuOptions
|
|
|
|
logMenu :: Universe -> ScreenLayer
|
|
logMenu = titleOptionsMenu "OPTIONS:LOG" logOptions
|
|
|
|
debugMenuOptions :: [MenuOption]
|
|
debugMenuOptions =
|
|
map f [minBound ..] ++ [enumOption debug_view_clip_bounds "SHOW ROOM CLIP" id]
|
|
where
|
|
f :: DebugBool -> MenuOption
|
|
f bd =
|
|
Toggle
|
|
(uvConfig . debug_booleans . at bd %~ toggleJust)
|
|
(uncurry MODStringOption . g bd . (^? uvConfig . debug_booleans . ix bd))
|
|
g bd Nothing = (show bd, "False")
|
|
g bd _ = (show bd, "True")
|
|
|
|
logOptions :: [MenuOption]
|
|
logOptions =
|
|
[ Toggle
|
|
(uvIOEffects %~ \f u -> generateGraphs >> f u)
|
|
(const $ MODString "Create item combination graph")
|
|
]
|
|
|
|
generateGraphs :: IO ()
|
|
generateGraphs = do
|
|
createDirectoryIfMissing True "generated/graph"
|
|
print "Placeholder for graph generation activated"
|
|
|
|
gameplayMenu :: Universe -> ScreenLayer
|
|
gameplayMenu = titleOptionsMenu "OPTIONS:GAMEPLAY" gameplayMenuOptions
|
|
|
|
gameplayMenuOptions :: [MenuOption]
|
|
gameplayMenuOptions = [boolOption gameplay_rotate_to_wall "ROTATE TO WALL"]
|
|
|
|
soundMenu :: Universe -> ScreenLayer
|
|
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
|
|
]
|
|
where
|
|
theoption stype str voltype =
|
|
Toggle2
|
|
(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
|
|
dec x = max 0 (x - 0.1)
|
|
inc x = min 1 (x + 0.1)
|
|
sw w = setVol (_uvConfig w)
|
|
|
|
writeConfig :: Universe -> Universe
|
|
writeConfig w = w & uvIOEffects %~ saveConfig (_uvConfig w)
|
|
|
|
graphicsMenu :: Universe -> ScreenLayer
|
|
graphicsMenu = titleOptionsMenu "OPTIONS:GRAPHICS" graphicsMenuOptions
|
|
|
|
graphicsMenuOptions :: [MenuOption]
|
|
graphicsMenuOptions =
|
|
[ enumOption gr_world_res "World resolution" (uvIOEffects .~ updatePreload)
|
|
, enumOption gr_downsize_res "Downsize resolution" (uvIOEffects .~ updatePreload)
|
|
, boolOption gr_upscale_filter "UPSCALE FILTER"
|
|
, enumOption gr_shadow_rendering "SHADOW RENDERING" id
|
|
, enumOption gr_shadows_on_clouds "SHADOW DETAIL ON CLOUDS" id
|
|
, enumOption gr_shadow_size "SHADOW DETAIL" id
|
|
, enumOption gr_distortions "ENABLE DISTORTIONS" id
|
|
-- , enumOption gr_bloom "ENABLE BLOOM" id
|
|
, boolOption gr_cloud_shadows "CLOUD SHADOWS TOGGLE"
|
|
, enumOption gr_num_shadow_casters "NUM SHADOW CASTERS" id
|
|
]
|
|
|
|
gameOverMenu :: Universe -> ScreenLayer
|
|
gameOverMenu =
|
|
set scOptionFlag GameOverOptions
|
|
. initializeOptionMenu NoExtraMenuOption "GAME OVER" pauseMenuOptions
|
|
|
|
unpause :: Universe -> Universe
|
|
unpause u' =
|
|
resumeSound . set uvScreenLayers []
|
|
. set (uvWorld . input . mousePos) (u' ^. uvWorld . cWorld . lWorld . lAimPos)
|
|
$ over
|
|
uvIOEffects
|
|
(\f u -> SDL.warpMouse SDL.WarpCurrentFocus (SDL.P (SDL.V2 x' y')) >> f u)
|
|
u'
|
|
where
|
|
cfig = u' ^. uvConfig
|
|
x' = round $ x + 0.5 * windowXFloat cfig
|
|
y' = round $ 0.5 * windowYFloat cfig - y
|
|
V2 x y =
|
|
worldPosToScreen
|
|
(u' ^. uvWorld . wCam)
|
|
(u' ^. uvWorld . cWorld . lWorld . lAimPos)
|
|
|
|
-- note that this won't update after it is first loaded
|
|
displayConfig :: Universe -> ScreenLayer
|
|
displayConfig u =
|
|
titleOptionsNoWrite
|
|
"CONFIG"
|
|
( map (Toggle id . const . MODString) $
|
|
listConfig u
|
|
)
|
|
u
|
|
|
|
listConfig :: Universe -> [String]
|
|
listConfig =
|
|
lines
|
|
. unpack
|
|
. AEP.encodePretty' (AEP.Config (AEP.Spaces 2) compare AEP.Generic False)
|
|
. _uvConfig
|
|
|
|
displayControls :: Universe -> ScreenLayer
|
|
displayControls =
|
|
titleOptionsNoWrite "CONTROLS" $
|
|
map (Toggle id . const . uncurry MODStringOption) listControls
|
|
|
|
listControls :: [(String, String)]
|
|
listControls =
|
|
[ ("w|a|s|d", "MOVE")
|
|
, ("<rmb>", "AIM")
|
|
, ("<rmb>&<lmb>", "USE SELECTED")
|
|
, ("<lmb>&<rmb>", "ROTATE")
|
|
, ("<wheelscroll>", "SELECT ITEM")
|
|
, ("<space>", "PICKUP ITEM")
|
|
, ("f", "DROP ITEM")
|
|
, ("<caps>+<wheelscroll>", "SWAP ITEMS")
|
|
, ("<shift>&q|e|0-9", "SET HOTKEY")
|
|
, ("q|e|0-9", "USE HOTKEY")
|
|
, ("<caps>&q|e|0-9", "JUMP TO HOTKEY")
|
|
, ("c", "COMBINE ITEMS")
|
|
, ("p|<esc>", "PAUSE")
|
|
, ("<lmb>", "SELECT/MOVE ITEMS")
|
|
, ("<F1>", "NORMAL CAMERA")
|
|
, ("<F2>", "DEBUG CAMERA")
|
|
, ("<F5>", "QUICKSAVE")
|
|
, ("<F9>", "QUICKLOAD")
|
|
]
|