244 lines
8.4 KiB
Haskell
244 lines
8.4 KiB
Haskell
module Dodge.Menu (
|
|
pauseMenu,
|
|
gameOverMenu,
|
|
splashMenu,
|
|
) where
|
|
|
|
import Dodge.Base.Coordinate
|
|
import Geometry
|
|
import Control.Monad
|
|
import qualified Data.Aeson.Encode.Pretty as AEP
|
|
import Data.ByteString.Lazy.Char8 (unpack)
|
|
import Data.Maybe
|
|
import Dodge.Concurrent
|
|
import Dodge.Config.Update
|
|
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 LensHelp
|
|
import MaybeHelp
|
|
import Padding
|
|
import Preload.Update
|
|
import System.Clipboard
|
|
import Text.Read
|
|
import qualified SDL as SDL
|
|
|
|
splashMenu :: Universe -> ScreenLayer
|
|
splashMenu u =
|
|
initializeOptionMenu "GAME TITLE" splashMenuOptions NoEscapeMenuOption u
|
|
& scOptionFlag .~ SplashOptions
|
|
|
|
splashMenuOptions :: [MenuOption]
|
|
splashMenuOptions =
|
|
[ Toggle (loadSaveSlot (SaveSlotNum 0)) displaycontinue
|
|
, 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 (pushScreen displayConfig) (opText "VIEW CONFIG")
|
|
, Toggle id (displaywhenseed "VIEW LAST SEED")
|
|
, Toggle hardQuit (opText "QUIT")
|
|
]
|
|
where
|
|
opText = 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 "PAUSED" pauseMenuOptions $
|
|
TopEscapeMenuOption $ 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")
|
|
]
|
|
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 = 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
|
|
mcstr <- getClipboardString
|
|
case mcstr >>= readMaybe of
|
|
Nothing ->
|
|
return $
|
|
pushScreen
|
|
(seedStartMenu "CLIPBOARD UNUSABLE, NEED INTEGER")
|
|
(u & uvScreenLayers %~ tail)
|
|
Just i -> return $ startSeedGame 0 i u
|
|
|
|
titleOptionsMenu :: String -> [MenuOption] -> Universe -> ScreenLayer
|
|
titleOptionsMenu title ops = initializeOptionMenuBO title ops "BACK" (popScreen . writeConfig)
|
|
|
|
titleOptionsNoWrite :: String -> [MenuOption] -> Universe -> ScreenLayer
|
|
titleOptionsNoWrite title ops = initializeOptionMenuBO title ops "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 OPTIONS"
|
|
]
|
|
|
|
debugMenu :: Universe -> ScreenLayer
|
|
debugMenu = titleOptionsMenu "OPTIONS:GAMEPLAY" debugMenuOptions
|
|
|
|
debugMenuOptions :: [MenuOption]
|
|
debugMenuOptions =
|
|
map f [minBound ..] ++ [makeEnumOption 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")
|
|
|
|
gameplayMenu :: Universe -> ScreenLayer
|
|
gameplayMenu = titleOptionsMenu "OPTIONS:GAMEPLAY" gameplayMenuOptions
|
|
|
|
gameplayMenuOptions :: [MenuOption]
|
|
gameplayMenuOptions = [makeBoolOption 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 =
|
|
[ makeEnumOption graphics_world_resolution "World resolution" (uvIOEffects .~ updatePreload)
|
|
, makeEnumOption
|
|
graphics_downsize_resolution
|
|
"Downsize resolution"
|
|
(uvIOEffects .~ updatePreload)
|
|
, makeEnumOption
|
|
graphics_distortion_resolution
|
|
"Distortion resolution"
|
|
(uvIOEffects .~ updatePreload)
|
|
, makeEnumOption graphics_shadow_rendering "SHADOW RENDERING" id
|
|
, makeEnumOption graphics_shadow_size "SHADOW DETAIL" id
|
|
, makeEnumOption graphics_distortions "ENABLE DISTORTIONS" id
|
|
, makeEnumOption graphics_bloom "ENABLE BLOOM" id
|
|
, makeBoolOption graphics_cloud_shadows "CLOUD SHADOWS"
|
|
, makeEnumOption graphics_num_shadow_casters "NUM SHADOW CASTERS" id
|
|
]
|
|
|
|
gameOverMenu :: Universe -> ScreenLayer
|
|
gameOverMenu u =
|
|
initializeOptionMenu "GAME OVER" pauseMenuOptions NoEscapeMenuOption u
|
|
& scOptionFlag .~ GameOverOptions
|
|
|
|
--charToScode :: Char -> Scancode
|
|
--charToScode = Scancode . fromIntegral . (\x -> x - 61) . fromEnum
|
|
|
|
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 = const $ ColumnsScreen "CONTROLS" listControls
|
|
displayControls =
|
|
titleOptionsNoWrite "CONTROLS" $
|
|
map (Toggle id . const . uncurry MODStringOption) listControls
|
|
|
|
listControls :: [(String, String)]
|
|
listControls =
|
|
[ ("w|a|s|d", "MOVEMENT")
|
|
, ("<rmb>", "AIM")
|
|
, ("<rmb>&<lmb>", "SHOOT/USE/EQUIP SELECTED")
|
|
-- , ("<lmb>", "USE EQUIPPED")
|
|
, ("<wheelscroll>", "SELECT ITEM")
|
|
, ("<space>", "PICKUP ITEM")
|
|
, ("f", "DROP ITEM")
|
|
, ("q|e|0-9", "USE EQUIPMENT")
|
|
, ("c", "COMBINE ITEMS")
|
|
, ("x", "EXAMINE ITEMS")
|
|
, ("m", "DISPLAY MAP")
|
|
, ("c|<esc>", "PAUSE AND DISPLAY MENU")
|
|
, ("<F1>", "USE NORMAL CAMERA")
|
|
, ("<F2>", "PAUSE AND FLOAT CAMERA")
|
|
, ("<F5>", "QUICKSAVE")
|
|
, ("<F9>", "QUICKLOAD")
|
|
]
|