172 lines
5.9 KiB
Haskell
172 lines
5.9 KiB
Haskell
module Dodge.Menu
|
|
( scodeToChar
|
|
, pauseMenu
|
|
, gameOverMenu
|
|
) where
|
|
import LensHelp
|
|
import Dodge.Menu.OptionType
|
|
import Dodge.StartNewGame
|
|
import Dodge.Menu.PushPop
|
|
import Dodge.Data
|
|
import Dodge.PreloadData
|
|
import Dodge.Save
|
|
import Dodge.Config.Update
|
|
--import SDL.Internal.Numbered
|
|
--import Preload.Update
|
|
import Dodge.SoundLogic
|
|
--import Dodge.LevelGen
|
|
|
|
import Text.Read
|
|
import SDL
|
|
import System.Clipboard
|
|
--import Control.Lens
|
|
--import System.Random
|
|
|
|
slTitleOptionsEff :: String -> [MenuOption] -> (Universe -> IO (Maybe Universe)) -> ScreenLayer
|
|
slTitleOptionsEff title ops eff = OptionScreen
|
|
{ _scTitle = const title
|
|
, _scOptions = ops
|
|
, _scDefaultEff = eff
|
|
, _scOptionFlag = NormalOptions
|
|
}
|
|
pauseMenu :: ScreenLayer
|
|
pauseMenu = slTitleOptionsEff "PAUSED" pauseMenuOptions (return . unpause)
|
|
pauseMenuOptions :: [MenuOption]
|
|
pauseMenuOptions =
|
|
[ Toggle ScancodeN (return . Just . startNewGame) (const "NEW LEVEL")
|
|
, Toggle ScancodeR (return . Just . loadSaveSlot LevelStartSlot) (const "RESTART")
|
|
, Toggle ScancodeS (pushScreen $ seedStartMenu "START FROM SEED") (const "START FROM SEED")
|
|
, Toggle ScancodeO (pushScreen optionMenu ) (const "OPTIONS")
|
|
, Toggle ScancodeC (pushScreen displayControls) (const "CONTROLS")
|
|
, InvisibleToggle ScancodeEscape (return . const Nothing)
|
|
]
|
|
seedStartMenu :: String -> ScreenLayer
|
|
seedStartMenu str = slTitleOptionsEff str seedStartOptions popScreen
|
|
seedStartOptions :: [MenuOption]
|
|
seedStartOptions =
|
|
[ Toggle ScancodeP trySeedFromClipboard (const "PASTE NUMBER FROM CLIPBOARD")
|
|
-- , Toggle ScancodeI (return . Just . loadSaveSlot LevelStartSlot) (const "INSERT NUMBER")
|
|
]
|
|
|
|
trySeedFromClipboard :: Universe -> IO (Maybe Universe)
|
|
trySeedFromClipboard u = do
|
|
mcstr <- getClipboardString
|
|
case mcstr >>= readMaybe of
|
|
Nothing -> pushScreen (seedStartMenu "CLIPBOARD UNUSABLE, NEED INTEGER")
|
|
(u & menuLayers %~ tail)
|
|
Just i -> return . Just $ startSeedGame i u
|
|
|
|
slTitleOptions :: String -> [MenuOption] -> ScreenLayer
|
|
slTitleOptions title ops = slTitleOptionsEff title ops (popScreen . writeConfig)
|
|
|
|
optionMenu :: ScreenLayer
|
|
optionMenu = slTitleOptionsEff "OPTIONS" optionsOptions popScreen
|
|
|
|
optionsOptions :: [MenuOption]
|
|
optionsOptions =
|
|
[ makeSubmenuOption ScancodeV soundMenu "VOLUME"
|
|
, makeSubmenuOption ScancodeG graphicsMenu "GRAPHICS"
|
|
, makeSubmenuOption ScancodeP gameplayMenu "GAMEPLAY"
|
|
, makeSubmenuOption ScancodeD debugMenu "DEBUG OPTIONS"
|
|
]
|
|
debugMenu :: ScreenLayer
|
|
debugMenu = slTitleOptions
|
|
"OPTIONS:GAMEPLAY"
|
|
debugMenuOptions
|
|
debugMenuOptions :: [MenuOption]
|
|
debugMenuOptions =
|
|
[ doption ScancodeF debug_seconds_frame "SHOW SECONDS/FRAME" _debug_seconds_frame
|
|
, doption ScancodeC debug_noclip "NOCLIP" _debug_noclip
|
|
, doption ScancodeS debug_cr_status "SHOW CREATURE STATUS" _debug_cr_status
|
|
, doption ScancodeV debug_view_boundaries "SHOW VIEW BOUNDARIES" _debug_view_boundaries
|
|
, doption ScancodeP debug_pathing "SHOW PATHING" _debug_pathing
|
|
]
|
|
where
|
|
doption scode l t rec
|
|
= Toggle scode (return . Just . (config . l %~ not)) (\w -> t ++ ":" ++ show (rec $ _config w))
|
|
gameplayMenu :: ScreenLayer
|
|
gameplayMenu = slTitleOptions
|
|
"OPTIONS:GAMEPLAY"
|
|
gameplayMenuOptions
|
|
|
|
gameplayMenuOptions :: [MenuOption]
|
|
gameplayMenuOptions =
|
|
[ makeBoolOption ScancodeR rotate_to_wall "ROTATE TO WALL"
|
|
, makeBoolOption ScancodeS show_sound "SHOW VISUAL SOUNDS"
|
|
]
|
|
|
|
soundMenu :: ScreenLayer
|
|
soundMenu = slTitleOptions
|
|
"OPTIONS:VOLUME"
|
|
soundMenuOptions
|
|
|
|
soundMenuOptions :: [MenuOption]
|
|
soundMenuOptions =
|
|
[ theoption ScancodeY volume_master ScancodeU "MASTER VOLUME:" _volume_master
|
|
, theoption ScancodeH volume_sound ScancodeJ "EFFECTS VOLUME:" _volume_sound
|
|
, theoption ScancodeN volume_music ScancodeM "MUSIC VOLUME:" _volume_music
|
|
]
|
|
where
|
|
theoption scod1 stype scod2 str voltype = Toggle2
|
|
scod1
|
|
(change dec stype)
|
|
scod2
|
|
(change inc stype)
|
|
(\w -> str ++ show (round $ 10 * voltype (_config w)::Int))
|
|
change g vt = return . Just . (config . vt %~ g) . sw
|
|
dec x = max 0 (x - 0.1)
|
|
inc x = min 1 (x + 0.1)
|
|
sw w = w & uvWorld . sideEffects %~ setVolThen (_config w)
|
|
|
|
writeConfig :: Universe -> Universe
|
|
writeConfig w = w & uvWorld . sideEffects %~ saveConfig (_config w)
|
|
|
|
graphicsMenu :: ScreenLayer
|
|
graphicsMenu = slTitleOptions "OPTIONS:GRAPHICS" graphicsMenuOptions
|
|
|
|
graphicsMenuOptions :: [MenuOption]
|
|
graphicsMenuOptions =
|
|
[ makeEnumOption ScancodeS resolution_factor "RESOLUTION" updateFramebufferSize
|
|
, makeBoolOption ScancodeW wall_textured "WALL TEXTURES"
|
|
, makeBoolOption ScancodeD cloud_shadows "CLOUD SHADOWS"
|
|
]
|
|
|
|
gameOverMenu :: ScreenLayer
|
|
gameOverMenu = OptionScreen
|
|
{ _scTitle = const "GAME OVER"
|
|
, _scOptions = pauseMenuOptions
|
|
, _scDefaultEff = return . Just
|
|
, _scOptionFlag = GameOverOptions
|
|
}
|
|
|
|
-- | hacky
|
|
scodeToChar :: Scancode -> Char
|
|
scodeToChar = toEnum . (+ 61) . fromIntegral . unwrapScancode
|
|
|
|
--charToScode :: Char -> Scancode
|
|
--charToScode = Scancode . fromIntegral . (\x -> x - 61) . fromEnum
|
|
|
|
unpause :: Universe -> Maybe Universe
|
|
unpause w = Just . resumeSound $ w & menuLayers .~ []
|
|
|
|
displayControls :: ScreenLayer
|
|
displayControls = ColumnsScreen "CONTROLS" listControls
|
|
|
|
listControls :: [(String,String)]
|
|
listControls =
|
|
[("wasd", "MOVEMENT")
|
|
,("[rmb]", "AIM")
|
|
,("[rmb+lmb]", "SHOOT/USE/EQUIP SELECTED")
|
|
,("[lmb]", "USE EQUIPPED")
|
|
,("[wheelscroll]" , "SELECT ITEM" )
|
|
,("[space]" , "PICKUP ITEM" )
|
|
,("m" , "DISPLAY MAP" )
|
|
,("f" , "DROP ITEM" )
|
|
,("c" , "COMBINE ITEMS" )
|
|
,("x" , "TWEAK ITEMS" )
|
|
,("c[esc]" , "PAUSE" )
|
|
,("qe" , "ROTATE CAMERA")
|
|
,("F5" , "QUICKSAVE")
|
|
,("F9" , "QUICKLOAD")
|
|
]
|