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

Unify option menu display and effects

Browse Source
This commit is contained in:
justin
2021-09-03 12:38:56 +01:00
parent 083000c103
commit 6a2df15d0d
5 changed files with 117 additions and 39 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Event/Menu.hs
+12 -15
View File
@@ -12,8 +12,10 @@ import Dodge.Config.Update
import Dodge.Layout
import Preload.Update
import Dodge.Debug.Terminal
import Dodge.Menu
import Data.Maybe
import Data.Foldable
--import qualified Data.Set as S
import Control.Lens
import SDL
@@ -47,10 +49,11 @@ handlePressedKeyInMenu mState scode w = case mState of
ScancodeO -> pushMenu OptionMenu w
ScancodeC -> pushMenu ControlList w
_ -> Just w
OptionMenu -> case scode of
ScancodeV -> pushMenu SoundOptionMenu w
ScancodeG -> pushMenu GraphicsOptionMenu w
_ -> popMenu w
OptionMenu -> optionListToEffects optionsOptions popMenu scode w
-- OptionMenu -> case scode of
-- ScancodeV -> pushMenu SoundOptionMenu w
-- ScancodeG -> pushMenu GraphicsOptionMenu w
-- _ -> popMenu w
SoundOptionMenu -> case scode of
ScancodeY -> Just $ sw & config . volume_master %~ dec
ScancodeU -> Just $ sw & config . volume_master %~ inc
@@ -66,8 +69,7 @@ handlePressedKeyInMenu mState scode w = case mState of
ControlList -> Just $ w & menuLayers %~ tail
_ -> Just w
where
unpause w' = Just . resumeSound $
w' {_menuLayers = []}
unpause w' = Just . resumeSound $ w' {_menuLayers = []}
startLevel = unpause . storeLevel
dec x = max 0 (x - 0.1)
inc x = min 1 (x + 0.1)
@@ -84,16 +86,11 @@ handlePressedKeyInMenu mState scode w = case mState of
dropLast (x:xs) = init (x:xs)
dropLast _ = []
-- | hacky
scodeToChar :: Scancode -> Char
scodeToChar = toEnum . (+ 61) . fromIntegral . toNumber
optionListToEffects :: [MenuOption] -> (World -> Maybe World) -> Scancode -> World -> Maybe World
optionListToEffects mos eff sc w = case find (\mo -> _moKey mo == sc) mos of
Nothing -> eff w
Just mo -> _moEffect mo w
updateFramebufferSize :: World -> World
updateFramebufferSize w = w & sideEffects
%~ (pdataResizeUpdate (x `div` divRes) (y `div` divRes) x y : )
where
(x,y) = (round $ getWindowX w, round $ getWindowY w)
divRes = w ^. config . resolution_factor
cycleResolution :: (Eq a, Num a, Num p) => a -> p
src/Dodge/Menu.hs
+66
View File
@@ -0,0 +1,66 @@
module Dodge.Menu
where
import Dodge.Data
import Dodge.Data.Menu
import Dodge.Config.Data
import SDL
import SDL.Internal.Numbered
import Dodge.Layout
import Dodge.Floor
import Dodge.Initialisation
import Preload.Update
import Dodge.Base.Window
import Control.Lens
import Data.Maybe
data MenuOption
= Toggle
{ _moKey :: Scancode
, _moEffect :: World -> Maybe World
, _moString :: World -> String
}
| InvisibleToggle
{ _moKey :: Scancode
, _moEffect :: World -> Maybe World
}
optionsOptions :: [MenuOption]
optionsOptions =
[ Toggle ScancodeV (pushMenu SoundOptionMenu) (const "VOLUME")
, Toggle ScancodeG (pushMenu GraphicsOptionMenu) (const "GRAPHICS")
]
pushMenu ml w' = Just $ w' & menuLayers %~ (ml :)
pauseMenuOptions :: [MenuOption]
pauseMenuOptions =
[ Toggle ScancodeN startNewGame (const "NEW LEVEL")
, Toggle ScancodeR (\w -> return $ fromMaybe w $ _storedLevel w) (const "RESTART")
, Toggle ScancodeO (pushMenu OptionMenu ) (const "OPTIONS")
, Toggle ScancodeC (pushMenu ControlList) (const "CONTROLS")
, InvisibleToggle ScancodeEscape (const Nothing)
]
startNewGame w = Just $ w
& menuLayers .~ [WaitMessage "GENERATING..." 1]
& worldEvents .~ const aNewGame
where
aNewGame :: World
aNewGame = updateFramebufferSize $ generateLevelFromRoomList levx $ initialWorld
& randGen .~ _randGen w
& config .~ _config w
-- | hacky
scodeToChar :: Scancode -> Char
scodeToChar = toEnum . (+ 61) . fromIntegral . toNumber
charToScode :: Char -> Scancode
charToScode = Scancode . fromIntegral . (\x -> x - 61) . fromEnum
updateFramebufferSize :: World -> World
updateFramebufferSize w = w & sideEffects
%~ (pdataResizeUpdate (x `div` divRes) (y `div` divRes) x y : )
where
(x,y) = (round $ getWindowX w, round $ getWindowY w)
divRes = w ^. config . resolution_factor
src/Dodge/Render.hs
-11
View File
@@ -72,8 +72,6 @@ doDrawing pdata w = do
-- set the coordinate uniform ready for drawing elements using world coordinates
bufferUBO $ perspectiveMatrixb rot camzoom trans wins viewFroms
setViewportSize (round winx `div` resFact) (round winy `div` resFact)
-- viewport $= (Position 0 0
-- , divideSize (w ^. config . resolution_factor) $ Size (round $ fstV2 wins) (round $ sndV2 wins))
bindFramebuffer Framebuffer $= fst (_fboBase pdata)
clearColor $= Color4 0 0 0 0
clear [ColorBuffer,DepthBuffer]
@@ -120,8 +118,6 @@ doDrawing pdata w = do
--depthMask $= Enabled
--setup downscale viewport for blurring bloom
setViewportSize (round winx `div` (2*resFact)) (round winy `div` (2*resFact))
-- viewport $= (Position 0 0
-- , divideSize (2 * (w ^. config . resolution_factor)) $ Size (round $ fstV2 wins) (round $ sndV2 wins))
bindFramebuffer Framebuffer $= fst (_fboHalf1 pdata)
depthFunc $= Just Always
textureBinding Texture2D $= Just (snd $ _fboBloom pdata)
@@ -130,8 +126,6 @@ doDrawing pdata w = do
replicateM_ 5 $ pingPongBetween (_fboHalf1 pdata) (_fboHalf2 pdata) (_bloomBlurShader pdata)
blend $= Enabled
setViewportSize (round winx `div` resFact) (round winy `div` resFact)
-- viewport $= (Position 0 0
-- , divideSize (w ^. config . resolution_factor) $ Size (round $ fstV2 wins) (round $ sndV2 wins))
--draw clouds
bindFramebuffer Framebuffer $= fst (_fboCloud pdata)
depthFunc $= Just Lequal
@@ -150,14 +144,10 @@ doDrawing pdata w = do
renderLayer 2 shadV layerCounts
renderWindows pdata windowPoints
-- --downscale transparency depths
-- viewport $= (Position 0 0
-- , divideSize (2 * (w ^. config . shadow_resolution)) $ Size (round $ fstV2 wins) (round $ sndV2 wins))
-- bindFramebuffer Framebuffer $= fst (_fboHalf3 pdata)
-- bindTO (snd $ snd $ _fboCloud pdata)
-- depthFunc $= Just Always
-- drawShader (_fullscreenShader pdata) 4
-- viewport $= (Position 0 0
-- , divideSize (w ^. config . shadow_resolution) $ Size (round $ fstV2 wins) (round $ sndV2 wins))
----draw lightmap for cloud buffer
depthMask $= Disabled
blend $= Enabled
@@ -190,7 +180,6 @@ doDrawing pdata w = do
drawShader (_fullscreenShader pdata) 4
--set viewport for radial distortion
setViewportSize (round winx) (round winy)
--viewport $= (Position 0 0, Size (round $ fstV2 wins) (round $ sndV2 wins))
depthFunc $= Just Always
blendFunc $= (One,Zero)
-- perform any radial distortion
src/Dodge/Render/MenuScreen.hs
+38 -12
View File
@@ -6,37 +6,42 @@ module Dodge.Render.MenuScreen
)
where
import Dodge.Data.Menu
import Dodge.Data
--import Dodge.Config.Update
import Dodge.Config.Data
--import Dodge.Base (halfWidth,halfHeight)
import Picture
import Geometry
import Dodge.Menu
--import Geometry.Data
menuScreen
:: Configuration
:: World
-> Configuration
-> Float -- Half width of screen
-> Float -- Half height of screen
-> [MenuLayer]
-> Picture
menuScreen cfig hw hh mLays = case mLays of
menuScreen w cfig hw hh mLays = case mLays of
(LevelMenu x:_) -> optionsList hw hh ("LEVEL"++show x) []
(PauseMenu:_) -> optionsList hw hh "PAUSED"
["N - NEW LEVEL"
,"R - RESTART"
,"O - OPTIONS"
,"C - CONTROLS"
]
(PauseMenu : _) -> optionsFromList w hw hh "PAUSED" pauseMenuOptions
-- (PauseMenu:_) -> optionsList hw hh "PAUSED"
-- ["N - NEW LEVEL"
-- ,"R - RESTART"
-- ,"O - OPTIONS"
-- ,"C - CONTROLS"
-- ]
(GameOverMenu:_) -> optionsList hw hh "GAME OVER"
["N - NEW LEVEL"
,"R - RESTART"
,"O - OPTIONS"
,"C - CONTROLS"
]
(OptionMenu : _) -> optionsList hw hh "OPTIONS"
["V - VOLUME"
,"G - GRAPHICS"
]
(OptionMenu : _) -> optionsFromList w hw hh "OPTIONS" optionsOptions
-- (OptionMenu : _) -> optionsList hw hh "OPTIONS"
-- ["V - VOLUME"
-- ,"G - GRAPHICS"
-- ]
(SoundOptionMenu : _) -> optionsList hw hh "OPTIONS:VOLUME"
["Y - MASTER VOLUME + U : " ++ mavol
,"H - SOUND VOLUME + J : " ++ snvol
@@ -71,6 +76,27 @@ displayStringList hw hh ss = pictures
ys = [0,22..]
f y s = translate (10-hw) y . scale 0.15 0.15 $ text s
optionsFromList
:: World
-> Float -- ^ Half screen width
-> Float -- ^ Half screen height
-> String -- ^ Title
-> [MenuOption] -- ^ Options
-> Picture
optionsFromList w hw hh tit ops = pictures $
[darkenBackground
,theTitle]
++
zipWith (\ s vpos -> placeString (-hw + 50) vpos 0.2 s) (map (menuOptionToString w) ops') [hh-100,hh-150 ..]
where
ops' = filter notInvisible ops
notInvisible InvisibleToggle {} = False
notInvisible _ = True
placeString x y sc t = translate x y $ scale sc sc $ color white $ text t
darkenBackground = color (withAlpha 0.5 black) $ polygon $ screenBox hw hh
theTitle = placeString (-hw + 30) (hh - 50) 0.4 tit
menuOptionToString :: World -> MenuOption -> String
menuOptionToString w mo = (scodeToChar $ _moKey mo) : ':' : _moString mo w
optionsList
:: Float -- ^ Half screen width
src/Dodge/Render/Picture.hs
+1 -1
View File
@@ -50,7 +50,7 @@ fixedCoordPictures w = case _menuLayers w of
[ hudDrawings w
, customMouseCursor w
]
lays -> scaler . onLayer MenuDepth $ menuScreen (_config w) (halfWidth w) (halfHeight w) lays
lays -> scaler . onLayer MenuDepth $ menuScreen w (_config w) (halfWidth w) (halfHeight w) lays
where
scaler = setDepth (-1) . scale (2 / getWindowX w) (2 / getWindowY w)