Move menu layers outside of world

This commit is contained in:
2021-11-28 14:26:15 +00:00
parent 574f195b21
commit 462100703c
13 changed files with 132 additions and 124 deletions
+9 -6
View File
@@ -56,10 +56,13 @@ firstWorldLoad theConfig = do
theKeyConfig <- loadKeyConfig theKeyConfig <- loadKeyConfig
pdata <- doPreload >>= applyWorldConfig theConfig pdata <- doPreload >>= applyWorldConfig theConfig
w <- generateWorldFromSeed 0 w <- generateWorldFromSeed 0
return $ Universe ( w return $ Universe
& keyConfig .~ theKeyConfig {_uvWorld = w
& config .~ theConfig & keyConfig .~ theKeyConfig
) pdata & config .~ theConfig
,_preloadData = pdata
,_menuLayers = []
}
theUpdateStep :: Universe -> IO Universe theUpdateStep :: Universe -> IO Universe
theUpdateStep = doSideEffects <=< updateRenderSplit theUpdateStep = doSideEffects <=< updateRenderSplit
@@ -67,8 +70,8 @@ theUpdateStep = doSideEffects <=< updateRenderSplit
updateRenderSplit :: Universe -> IO Universe updateRenderSplit :: Universe -> IO Universe
updateRenderSplit u = do updateRenderSplit u = do
let preData = _preloadData u let preData = _preloadData u
update (_uvWorld u) `par` void (doDrawing (_renderData preData) (_uvWorld u)) updateUniverse u `par` void (doDrawing (_renderData preData) u)
return $ u {_uvWorld = update (_uvWorld u)} return $ updateUniverse u
playSoundUnlessRewinding :: Universe -> IO (M.Map SoundOrigin Sound) playSoundUnlessRewinding :: Universe -> IO (M.Map SoundOrigin Sound)
playSoundUnlessRewinding u playSoundUnlessRewinding u
+11 -11
View File
@@ -55,6 +55,7 @@ type CRUpdate = Creature -> World -> (Endo World, Maybe Creature)
data Universe = Universe data Universe = Universe
{ _uvWorld :: World { _uvWorld :: World
, _preloadData :: PreloadData , _preloadData :: PreloadData
, _menuLayers :: [ScreenLayer]
} }
data World = World data World = World
{ _keys :: !(S.Set Scancode) { _keys :: !(S.Set Scancode)
@@ -98,7 +99,6 @@ data World = World
, _pathGraph :: ~(Gr Point2 Float) , _pathGraph :: ~(Gr Point2 Float)
, _pathGraphP :: ~[(Point2,Point2)] , _pathGraphP :: ~[(Point2,Point2)]
, _pathPoints :: ~(IM.IntMap (IM.IntMap [(Int,Point2)])) , _pathPoints :: ~(IM.IntMap (IM.IntMap [(Int,Point2)]))
, _menuLayers :: [ScreenLayer]
, _worldFlags :: S.Set WorldFlag , _worldFlags :: S.Set WorldFlag
, _carteDisplay :: !Bool , _carteDisplay :: !Bool
, _carteCenter :: !Point2 , _carteCenter :: !Point2
@@ -129,37 +129,37 @@ data SaveSlot = QuicksaveSlot | LevelStartSlot
data OptionScreenFlag = NormalOptions | GameOverOptions data OptionScreenFlag = NormalOptions | GameOverOptions
data ScreenLayer data ScreenLayer
= OptionScreen = OptionScreen
{ _scTitle :: World -> String { _scTitle :: Universe -> String
, _scOptions :: [MenuOption] , _scOptions :: [MenuOption]
, _scDefaultEff :: World -> Maybe World , _scDefaultEff :: Universe -> Maybe Universe
, _scOptionFlag :: OptionScreenFlag , _scOptionFlag :: OptionScreenFlag
} }
| ColumnsScreen String [(String,String)] | ColumnsScreen String [(String,String)]
| InputScreen String | InputScreen String
| TerminalScreen Int [(Int,String)] | TerminalScreen Int [(Int,String)]
| WaitScreen | WaitScreen
{ _scWaitMessage :: World -> String { _scWaitMessage :: Universe -> String
, _scWaitTime :: Int , _scWaitTime :: Int
} }
| DisplayScreen | DisplayScreen
{ _scDisplay :: World -> Picture { _scDisplay :: Universe -> Picture
} }
data MenuOption data MenuOption
= Toggle = Toggle
{ _moKey :: Scancode { _moKey :: Scancode
, _moEff :: World -> Maybe World , _moEff :: Universe -> Maybe Universe
, _moString :: World -> String , _moString :: Universe -> String
} }
| Toggle2 | Toggle2
{ _moKey1 :: Scancode { _moKey1 :: Scancode
, _moEff1 :: World -> Maybe World , _moEff1 :: Universe -> Maybe Universe
, _moKey2 :: Scancode , _moKey2 :: Scancode
, _moEff2 :: World -> Maybe World , _moEff2 :: Universe -> Maybe Universe
, _moString :: World -> String , _moString :: Universe -> String
} }
| InvisibleToggle | InvisibleToggle
{ _moKey :: Scancode { _moKey :: Scancode
, _moEff :: World -> Maybe World , _moEff :: Universe -> Maybe Universe
} }
data InventoryMode data InventoryMode
= TopInventory = TopInventory
+1 -1
View File
@@ -55,7 +55,7 @@ defaultWorld = World
, _corpses = Zone IM.empty , _corpses = Zone IM.empty
, _decorations = IM.empty , _decorations = IM.empty
, _savedWorlds = M.empty , _savedWorlds = M.empty
, _menuLayers = [] -- , _menuLayers = []
, _worldFlags = S.empty , _worldFlags = S.empty
, _clickMousePos = V2 0 0 , _clickMousePos = V2 0 0
, _pathGraph = Data.Graph.Inductive.Graph.empty , _pathGraph = Data.Graph.Inductive.Graph.empty
+1 -1
View File
@@ -93,7 +93,7 @@ handlePressedMouseButton but w
| otherwise = Just w | otherwise = Just w
handleMouseWheelEvent :: MouseWheelEventData -> Universe -> Maybe Universe handleMouseWheelEvent :: MouseWheelEventData -> Universe -> Maybe Universe
handleMouseWheelEvent mwev w = case _menuLayers (_uvWorld w) of handleMouseWheelEvent mwev w = case _menuLayers w of
[] -> case mouseWheelEventPos mwev of [] -> case mouseWheelEventPos mwev of
V2 _ y -> Just $ w & uvWorld %~ wheelEvent (fromIntegral y) V2 _ y -> Just $ w & uvWorld %~ wheelEvent (fromIntegral y)
_ -> Just w _ -> Just w
+6 -6
View File
@@ -35,15 +35,15 @@ handlePressedKey :: Bool -> Scancode -> Universe -> Maybe Universe
handlePressedKey True _ w = Just w handlePressedKey True _ w = Just w
handlePressedKey _ ScancodeF5 w = Just $ over uvWorld doQuicksave w handlePressedKey _ ScancodeF5 w = Just $ over uvWorld doQuicksave w
handlePressedKey _ ScancodeF9 w = Just $ over uvWorld (loadSaveSlot QuicksaveSlot) w handlePressedKey _ ScancodeF9 w = Just $ over uvWorld (loadSaveSlot QuicksaveSlot) w
handlePressedKey _ ScancodeSemicolon w = Just $ over uvWorld gotoTerminal w handlePressedKey _ ScancodeSemicolon w = Just $ gotoTerminal w
handlePressedKey _ scode w handlePressedKey _ scode w
| null (_menuLayers (_uvWorld w)) = uvWorld (handlePressedKeyInGame scode) w | null (_menuLayers w) = uvWorld (handlePressedKeyInGame scode) w
| otherwise = handlePressedKeyInMenu (head $ _menuLayers (_uvWorld w)) scode w | otherwise = handlePressedKeyInMenu (head $ _menuLayers w) scode w
handlePressedKeyInGame :: Scancode -> World -> Maybe World handlePressedKeyInGame :: Scancode -> World -> Maybe World
handlePressedKeyInGame scode w handlePressedKeyInGame scode w
| scode == escapeKey (_keyConfig w) = Nothing | scode == escapeKey (_keyConfig w) = Nothing
| scode == pauseKey (_keyConfig w) = Just $ pauseGame $ escapeMap w -- | scode == pauseKey (_keyConfig w) = Just $ pauseGame $ escapeMap w
| scode == dropItemKey (_keyConfig w) = Just $ youDropItem w | scode == dropItemKey (_keyConfig w) = Just $ youDropItem w
| scode == toggleMapKey (_keyConfig w) = Just $ toggleMap w | scode == toggleMapKey (_keyConfig w) = Just $ toggleMap w
| scode == reloadKey (_keyConfig w) = Just $ fromMaybe w $ startReloadingWeapon (you w) w | scode == reloadKey (_keyConfig w) = Just $ fromMaybe w $ startReloadingWeapon (you w) w
@@ -61,7 +61,7 @@ toggleInv x y
| x == y = TopInventory | x == y = TopInventory
| otherwise = x | otherwise = x
gotoTerminal :: World -> World gotoTerminal :: Universe -> Universe
gotoTerminal w = case _menuLayers w of gotoTerminal w = case _menuLayers w of
(InputScreen _ : _ ) -> w (InputScreen _ : _ ) -> w
_ -> w & menuLayers %~ (InputScreen [] :) _ -> w & menuLayers %~ (InputScreen [] :)
@@ -77,7 +77,7 @@ spaceAction w = if _carteDisplay w
theLoc = fst (_seenLocations w IM.! _selLocation w) w theLoc = fst (_seenLocations w IM.! _selLocation w) w
updateTopCloseObject i w' = w' & closeObjects %~ ( Right (_buttons w' IM.! i) : ) . tail updateTopCloseObject i w' = w' & closeObjects %~ ( Right (_buttons w' IM.! i) : ) . tail
pauseGame :: World -> World pauseGame :: Universe -> Universe
pauseGame w = w {_menuLayers = [pauseMenu]} pauseGame w = w {_menuLayers = [pauseMenu]}
toggleMap :: World -> World toggleMap :: World -> World
+12 -11
View File
@@ -13,29 +13,30 @@ import SDL
handlePressedKeyInMenu :: ScreenLayer -> Scancode -> Universe -> Maybe Universe handlePressedKeyInMenu :: ScreenLayer -> Scancode -> Universe -> Maybe Universe
handlePressedKeyInMenu mState scode = case mState of handlePressedKeyInMenu mState scode = case mState of
OptionScreen { _scOptions = mos, _scDefaultEff = defeff} OptionScreen { _scOptions = mos, _scDefaultEff = defeff}
-> uvWorld $ optionListToEffects mos defeff scode -> optionListToEffects mos defeff scode
DisplayScreen {} -> uvWorld $ popScreen DisplayScreen {} -> popScreen
ColumnsScreen {} -> uvWorld $ popScreen ColumnsScreen {} -> popScreen
WaitScreen {} -> Just WaitScreen {} -> Just
TerminalScreen 0 _ -> uvWorld $ popScreen TerminalScreen 0 _ -> popScreen
TerminalScreen _ m -> Just . (uvWorld . menuLayers %~ ( (TerminalScreen 0 m : ) . tail) ) TerminalScreen _ m -> Just . (menuLayers %~ ( (TerminalScreen 0 m : ) . tail) )
InputScreen s -> case scode of InputScreen s -> case scode of
ScancodeEscape -> uvWorld $ popScreen ScancodeEscape -> popScreen
ScancodeReturn -> uvWorld $ popScreen . applyTerminalString s ScancodeReturn -> popScreen . (over uvWorld $ applyTerminalString s)
ScancodeBackspace ScancodeBackspace
-> uvWorld $ popScreen >=> pushScreen (InputScreen $ dropLast s) -> popScreen >=> pushScreen (InputScreen $ dropLast s)
_ -> uvWorld $ popScreen >=> pushScreen (InputScreen $ s ++ [scodeToChar scode]) _ -> popScreen >=> pushScreen (InputScreen $ s ++ [scodeToChar scode])
where where
dropLast (x:xs) = init (x:xs) dropLast (x:xs) = init (x:xs)
dropLast _ = [] dropLast _ = []
optionListToEffects :: [MenuOption] -> (World -> Maybe World) -> Scancode -> World -> Maybe World optionListToEffects :: [MenuOption] -> (Universe -> Maybe Universe) -> Scancode
-> Universe -> Maybe Universe
optionListToEffects mos defaulteff sc w = case lookup sc listEffects of optionListToEffects mos defaulteff sc w = case lookup sc listEffects of
Nothing -> defaulteff w Nothing -> defaulteff w
Just eff -> eff w Just eff -> eff w
where where
listEffects = concatMap menuOptionToEffects mos listEffects = concatMap menuOptionToEffects mos
menuOptionToEffects :: MenuOption -> [(Scancode,World -> Maybe World)] menuOptionToEffects :: MenuOption -> [(Scancode,Universe -> Maybe Universe)]
menuOptionToEffects Toggle {_moKey = k, _moEff = eff} = [(k,eff)] menuOptionToEffects Toggle {_moKey = k, _moEff = eff} = [(k,eff)]
menuOptionToEffects InvisibleToggle {_moKey = k, _moEff = eff} = [(k,eff)] menuOptionToEffects InvisibleToggle {_moKey = k, _moEff = eff} = [(k,eff)]
menuOptionToEffects Toggle2 menuOptionToEffects Toggle2
+1 -1
View File
@@ -34,7 +34,7 @@ initialWorld = defaultWorld
, _buttons = IM.empty , _buttons = IM.empty
, _toPlaySounds = M.empty , _toPlaySounds = M.empty
, _decorations = IM.empty , _decorations = IM.empty
, _menuLayers = [TerminalScreen 300 rezText'] -- , _menuLayers = [TerminalScreen 300 rezText']
} }
testStringInit :: World -> [String] testStringInit :: World -> [String]
+28 -28
View File
@@ -40,7 +40,7 @@ debugMenu :: ScreenLayer
debugMenu = OptionScreen debugMenu = OptionScreen
{ _scTitle = const "OPTIONS:GAMEPLAY" { _scTitle = const "OPTIONS:GAMEPLAY"
, _scOptions = debugMenuOptions , _scOptions = debugMenuOptions
, _scDefaultEff = popScreen . writeConfig , _scDefaultEff = popScreen . over uvWorld writeConfig
, _scOptionFlag = NormalOptions , _scOptionFlag = NormalOptions
} }
debugMenuOptions :: [MenuOption] debugMenuOptions :: [MenuOption]
@@ -53,12 +53,12 @@ debugMenuOptions =
] ]
where where
doption scode l t rec doption scode l t rec
= Toggle scode (Just . (config . l %~ not)) (\w -> t ++ ":" ++ show (rec $ _config w)) = Toggle scode (Just . (uvWorld . config . l %~ not)) (\w -> t ++ ":" ++ show (rec $ _config (_uvWorld w)))
gameplayMenu :: ScreenLayer gameplayMenu :: ScreenLayer
gameplayMenu = OptionScreen gameplayMenu = OptionScreen
{ _scTitle = const "OPTIONS:GAMEPLAY" { _scTitle = const "OPTIONS:GAMEPLAY"
, _scOptions = gameplayMenuOptions , _scOptions = gameplayMenuOptions
, _scDefaultEff = popScreen . writeConfig , _scDefaultEff = popScreen . over uvWorld writeConfig
, _scOptionFlag = NormalOptions , _scOptionFlag = NormalOptions
} }
gameplayMenuOptions :: [MenuOption] gameplayMenuOptions :: [MenuOption]
@@ -67,43 +67,43 @@ gameplayMenuOptions =
, option ScancodeS show_sound "SHOW VISUAL SOUNDS" _show_sound , option ScancodeS show_sound "SHOW VISUAL SOUNDS" _show_sound
] ]
where where
option scode l t rec = Toggle scode (Just . (config . l %~ not)) option scode l t rec = Toggle scode (Just . (uvWorld . config . l %~ not))
(\w -> t ++ ":" ++ show (rec $ _config w)) (\w -> t ++ ":" ++ show (rec $ _config (_uvWorld w)))
soundMenu :: ScreenLayer soundMenu :: ScreenLayer
soundMenu = OptionScreen soundMenu = OptionScreen
{ _scTitle = const "OPTIONS:VOLUME" { _scTitle = const "OPTIONS:VOLUME"
, _scOptions = soundMenuOptions , _scOptions = soundMenuOptions
, _scDefaultEff = popScreen . writeConfig , _scDefaultEff = popScreen . over uvWorld writeConfig
, _scOptionFlag = NormalOptions , _scOptionFlag = NormalOptions
} }
soundMenuOptions :: [MenuOption] soundMenuOptions :: [MenuOption]
soundMenuOptions = soundMenuOptions =
[ Toggle2 ScancodeY (master dec . sw) [ Toggle2 ScancodeY (master dec . sw)
ScancodeU (master inc . sw) (\w -> "MASTER VOLUME:" ++ mavol w) ScancodeU (master inc . sw) (\w -> "MASTER VOLUME:" ++ mavol (_uvWorld w))
, Toggle2 ScancodeH (soundEffs dec . sw) , Toggle2 ScancodeH (soundEffs dec . sw)
ScancodeJ (soundEffs inc . sw) (\w -> "EFFECTS VOLUME:" ++ snvol w) ScancodeJ (soundEffs inc . sw) (\w -> "EFFECTS VOLUME:" ++ snvol (_uvWorld w))
, Toggle2 ScancodeN (music dec . sw) , Toggle2 ScancodeN (music dec . sw)
ScancodeM (music inc . sw) (\w -> "MUSIC VOLUME:" ++ muvol w) ScancodeM (music inc . sw) (\w -> "MUSIC VOLUME:" ++ muvol (_uvWorld w))
] ]
where where
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)
--sw w = w & sideEffects %~ (setVol (_config w) : ) --sw w = w & sideEffects %~ (setVol (_config w) : )
sw w = w & sideEffects %~ setVolThen (_config w) sw w = w & uvWorld . sideEffects %~ setVolThen (_config (_uvWorld w))
master g = Just . (config . volume_master %~ g) master g = Just . (uvWorld . config . volume_master %~ g)
soundEffs g = Just . (config . volume_sound %~ g) soundEffs g = Just . (uvWorld . config . volume_sound %~ g)
music g = Just . (config . volume_music %~ g) music g = Just . (uvWorld . config . volume_music %~ g)
cfig w = _config w cfig w = _config w
mavol w = f $ _volume_master $ cfig w mavol w = f $ _volume_master $ cfig w
snvol w = f $ _volume_sound $ cfig w snvol w = f $ _volume_sound $ cfig w
muvol w = f $ _volume_music $ cfig w muvol w = f $ _volume_music $ cfig w
f x = show (round $ 10 * x :: Int) f x = show (round $ 10 * x :: Int)
pushScreen :: ScreenLayer -> World -> Maybe World pushScreen :: ScreenLayer -> Universe -> Maybe Universe
pushScreen ml w = Just $ w & menuLayers %~ (ml :) pushScreen ml w = Just $ w & menuLayers %~ (ml :)
popScreen :: World -> Maybe World popScreen :: Universe -> Maybe Universe
popScreen = Just . (menuLayers %~ tail) popScreen = Just . (menuLayers %~ tail)
writeConfig :: World -> World writeConfig :: World -> World
@@ -113,20 +113,20 @@ graphicsMenu :: ScreenLayer
graphicsMenu = OptionScreen graphicsMenu = OptionScreen
{ _scTitle = const "OPTIONS:GRAPHICS" { _scTitle = const "OPTIONS:GRAPHICS"
, _scOptions = graphicsMenuOptions , _scOptions = graphicsMenuOptions
, _scDefaultEff = popScreen . writeConfig , _scDefaultEff = popScreen . over uvWorld writeConfig
, _scOptionFlag = NormalOptions , _scOptionFlag = NormalOptions
} }
graphicsMenuOptions :: [MenuOption] graphicsMenuOptions :: [MenuOption]
graphicsMenuOptions = graphicsMenuOptions =
[ Toggle ScancodeW (Just . (config . wall_textured %~ not)) wtextstring [ Toggle ScancodeW (Just . (uvWorld . config . wall_textured %~ not)) wtextstring
, Toggle ScancodeS upf resostring , Toggle ScancodeS upf resostring
, Toggle ScancodeD (Just . (config . cloud_shadows %~ not)) cshadstring , Toggle ScancodeD (Just . (uvWorld . config . cloud_shadows %~ not)) cshadstring
] ]
where where
wtextstring w = "WALL TEXTURES:" ++ show (_wall_textured $ _config w) wtextstring w = "WALL TEXTURES:" ++ show (_wall_textured $ _config (_uvWorld w))
resostring w = "RESOLUTION: 1/" ++ show (_resolution_factor $ _config w) resostring w = "RESOLUTION: 1/" ++ show (_resolution_factor $ _config (_uvWorld w))
upf w = Just $ updateFramebufferSize $ w & config . resolution_factor %~ cycleResolution upf w = Just $ over uvWorld updateFramebufferSize $ w & uvWorld . config . resolution_factor %~ cycleResolution
cshadstring w = "CLOUD SHADOWS:" ++ show (_cloud_shadows $ _config w) cshadstring w = "CLOUD SHADOWS:" ++ show (_cloud_shadows $ _config (_uvWorld w))
cycleResolution :: (Eq a, Num a, Num p) => a -> p cycleResolution :: (Eq a, Num a, Num p) => a -> p
cycleResolution 1 = 2 cycleResolution 1 = 2
@@ -152,17 +152,17 @@ pauseMenu = OptionScreen
pauseMenuOptions :: [MenuOption] pauseMenuOptions :: [MenuOption]
pauseMenuOptions = pauseMenuOptions =
[ Toggle ScancodeN startNewGame (const "NEW LEVEL") [ Toggle ScancodeN startNewGame (const "NEW LEVEL")
, Toggle ScancodeR (Just . loadSaveSlot LevelStartSlot) (const "RESTART") , Toggle ScancodeR (uvWorld (Just . loadSaveSlot LevelStartSlot)) (const "RESTART")
, Toggle ScancodeO (pushScreen optionMenu ) (const "OPTIONS") , Toggle ScancodeO (pushScreen optionMenu ) (const "OPTIONS")
, Toggle ScancodeC (pushScreen displayControls) (const "CONTROLS") , Toggle ScancodeC (pushScreen displayControls) (const "CONTROLS")
, InvisibleToggle ScancodeEscape (const Nothing) , InvisibleToggle ScancodeEscape (const Nothing)
] ]
startNewGame :: World -> Maybe World startNewGame :: Universe -> Maybe Universe
startNewGame w = Just $ w startNewGame w = Just $ w
& menuLayers .~ [WaitScreen (const "GENERATING...") 1] & menuLayers .~ [WaitScreen (const "GENERATING...") 1]
& sideEffects .~ uvWorld (uvWorldSideEffects i w) & uvWorld . sideEffects .~ uvWorld (uvWorldSideEffects i (_uvWorld w))
where where
i = fst $ random (_randGen w) i = fst $ random (_randGen (_uvWorld w))
uvWorldSideEffects :: Int -> World -> b -> IO World uvWorldSideEffects :: Int -> World -> b -> IO World
uvWorldSideEffects i w = const (generateWorldFromSeed i <&> keyConfig .~ _keyConfig w <&> config .~ _config w uvWorldSideEffects i w = const (generateWorldFromSeed i <&> keyConfig .~ _keyConfig w <&> config .~ _config w
@@ -195,8 +195,8 @@ updateFramebufferSize w = w & sideEffects %~ sideEffectUpdatePreload divRes x y
-- , _scDefaultEff = unpause . storeLevel -- , _scDefaultEff = unpause . storeLevel
-- , _scOptionFlag = NormalOptions -- , _scOptionFlag = NormalOptions
-- } -- }
unpause :: World -> Maybe World unpause :: Universe -> Maybe Universe
unpause w = Just . resumeSound $ w {_menuLayers = []} unpause w = Just . resumeSound $ w & menuLayers .~ []
displayControls :: ScreenLayer displayControls :: ScreenLayer
displayControls = ColumnsScreen "CONTROLS" listControls displayControls = ColumnsScreen "CONTROLS" listControls
+4 -3
View File
@@ -30,8 +30,9 @@ import qualified SDL
import qualified Data.Vector.Unboxed.Mutable as UMV import qualified Data.Vector.Unboxed.Mutable as UMV
import Graphics.GL.Core43 import Graphics.GL.Core43
doDrawing :: RenderData -> World -> IO Word32 doDrawing :: RenderData -> Universe -> IO Word32
doDrawing pdata w = do doDrawing pdata u = do
let w = _uvWorld u
sTicks <- SDL.ticks sTicks <- SDL.ticks
let rot = _cameraRot w let rot = _cameraRot w
camzoom = _cameraZoom w camzoom = _cameraZoom w
@@ -245,7 +246,7 @@ doDrawing pdata w = do
blendFunc $= (SrcAlpha,OneMinusSrcAlpha) blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
renderLayer 4 shadV layerCounts renderLayer 4 shadV layerCounts
bufferUBO $ isoMatrix 0 1 (V2 0 0) (V2 2 2) bufferUBO $ isoMatrix 0 1 (V2 0 0) (V2 2 2)
renderFoldable shadV $ fixedCoordPictures w renderFoldable shadV $ fixedCoordPictures u
depthMask $= Enabled depthMask $= Enabled
eTicks <- SDL.ticks eTicks <- SDL.ticks
return (eTicks - sTicks) return (eTicks - sTicks)
+9 -13
View File
@@ -9,18 +9,15 @@ import Picture
import Dodge.Menu import Dodge.Menu
import Padding import Padding
menuScreen menuScreen :: Universe -> ScreenLayer -> Picture
:: World
-> ScreenLayer
-> Picture
menuScreen w screen = case screen of menuScreen w screen = case screen of
OptionScreen {_scTitle = titf, _scOptions = mos} OptionScreen {_scTitle = titf, _scOptions = mos}
-> drawOptions w (titf w) mos -> drawOptions w (titf w) mos
(WaitScreen sf _) -> drawOptions w (sf w) [] (WaitScreen sf _) -> drawOptions w (sf w) []
(InputScreen s) -> drawOptions w ('>':s) [] (InputScreen s) -> drawOptions w ('>':s) []
(TerminalScreen t xs ) -> displayStringList w $ map snd $ filter (( > t) . fst) xs (TerminalScreen t xs ) -> displayStringList (_uvWorld w) $ map snd $ filter (( > t) . fst) xs
(DisplayScreen sd ) -> sd w (DisplayScreen sd ) -> sd w
(ColumnsScreen title pairs) -> drawTwoColumnsScreen w title pairs (ColumnsScreen title pairs) -> drawTwoColumnsScreen (_uvWorld w) title pairs
displayStringList :: World -> [String] -> Picture displayStringList :: World -> [String] -> Picture
displayStringList w ss = pictures displayStringList w ss = pictures
@@ -52,14 +49,13 @@ drawTwoColumns w lps = pictures $ zipWith f [hh-100,hh-130..] lps
hw = halfWidth w hw = halfWidth w
ln = maximum (map (length . fst) lps) + 3 ln = maximum (map (length . fst) lps) + 3
drawOptions drawOptions :: Universe
:: World
-> String -- ^ Title -> String -- ^ Title
-> [MenuOption] -- ^ Options -> [MenuOption] -- ^ Options
-> Picture -> Picture
drawOptions w title ops = pictures $ drawOptions w title ops = pictures $
[darkenBackground w [darkenBackground (_uvWorld w)
,drawTitle w title] ,drawTitle (_uvWorld w) title]
++ ++
zipWith (\ s vpos -> placeString (-hw + 50) vpos 0.2 s) (map (menuOptionToString w) ops') [hh-100,hh-150 ..] zipWith (\ s vpos -> placeString (-hw + 50) vpos 0.2 s) (map (menuOptionToString w) ops') [hh-100,hh-150 ..]
where where
@@ -67,8 +63,8 @@ drawOptions w title ops = pictures $
notInvisible InvisibleToggle {} = False notInvisible InvisibleToggle {} = False
notInvisible _ = True notInvisible _ = True
placeString x y sc t = translate x y $ scale sc sc $ color white $ text t placeString x y sc t = translate x y $ scale sc sc $ color white $ text t
hh = halfHeight w hh = halfHeight (_uvWorld w)
hw = halfWidth w hw = halfWidth (_uvWorld w)
darkenBackground :: World -> Picture darkenBackground :: World -> Picture
darkenBackground = color (withAlpha 0.5 black) . polygon . screenBox darkenBackground = color (withAlpha 0.5 black) . polygon . screenBox
@@ -80,7 +76,7 @@ drawTitle w = placeString (-hw + 30) (hh - 50) 0.4
hh = halfHeight w hh = halfHeight w
hw = halfWidth w hw = halfWidth w
menuOptionToString :: World -> MenuOption -> String menuOptionToString :: Universe -> MenuOption -> String
menuOptionToString w mo = theKeys ++ _moString mo w menuOptionToString w mo = theKeys ++ _moString mo w
where where
theKeys :: String theKeys :: String
+4 -4
View File
@@ -10,15 +10,15 @@ import Dodge.Render.MenuScreen
import Geometry import Geometry
import Picture import Picture
fixedCoordPictures :: World -> Picture fixedCoordPictures :: Universe -> Picture
fixedCoordPictures w = case _menuLayers w of fixedCoordPictures w = case _menuLayers w of
[] -> pictures [] -> pictures
[ hudDrawings w [ hudDrawings (_uvWorld w)
, customMouseCursor w , customMouseCursor (_uvWorld w)
] ]
(lay:_) -> scaler . onLayer MenuDepth $ menuScreen w lay (lay:_) -> scaler . onLayer MenuDepth $ menuScreen w lay
where where
scaler = setDepth (-1) . scale (2 / getWindowX w) (2 / getWindowY w) scaler = setDepth (-1) . scale (2 / getWindowX (_uvWorld w)) (2 / getWindowY (_uvWorld w))
customMouseCursor :: World -> Picture customMouseCursor :: World -> Picture
customMouseCursor w = customMouseCursor w =
+1 -1
View File
@@ -40,7 +40,7 @@ pauseSound :: World -> World
pauseSound w = w pauseSound w = w
{-| Placeholder...-} {-| Placeholder...-}
resumeSound :: World -> World resumeSound :: Universe -> Universe
resumeSound w = w resumeSound w = w
soundWithStatus soundWithStatus
+45 -38
View File
@@ -2,7 +2,10 @@
Module : Dodge.Update Module : Dodge.Update
Description : Simulation update Description : Simulation update
-} -}
module Dodge.Update (update) where module Dodge.Update
(update
,updateUniverse
) where
import Dodge.Data import Dodge.Data
import Dodge.Hammer import Dodge.Hammer
import Dodge.Block import Dodge.Block
@@ -27,47 +30,51 @@ import Control.Lens
import Data.Monoid import Data.Monoid
import System.Random import System.Random
updateUniverse :: Universe -> Universe
updateUniverse w = case _menuLayers w of
(TerminalScreen t xs:mls) -> w & menuLayers .~ (TerminalScreen (max (t-1) 0) xs:mls)
(WaitScreen s i : _)
| i < 1 -> w & over uvWorld (dbArg _worldEvents)
| otherwise -> w & menuLayers %~ ( (WaitScreen s (i-1) :) . tail )
(OptionScreen {_scOptionFlag = GameOverOptions} : _) ->
-- updateParticles
-- . updateProjectiles
-- . updateLightSources
-- $ updateClouds
w
(_ : _) -> w
[] -> over uvWorld update w
update :: World -> World update :: World -> World
update = (frameClock +~ 1) . functionalUpdate update = (frameClock +~ 1) . functionalUpdate
{- | The update step. {- | The update step.
For most menus the only way to change the world is using event handling. -} For most menus the only way to change the world is using event handling. -}
functionalUpdate :: World -> World functionalUpdate :: World -> World
functionalUpdate w = case _menuLayers w of functionalUpdate w = checkEndGame
(TerminalScreen t xs:mls) -> w & menuLayers .~ (TerminalScreen (max (t-1) 0) xs:mls) . updateDistortions
(WaitScreen s i : _) . updateCreatureSoundPositions
| i < 1 -> w & dbArg _worldEvents . ppEvents
| otherwise -> w & menuLayers %~ ( (WaitScreen s (i-1) :) . tail ) . updateCamera
(OptionScreen {_scOptionFlag = GameOverOptions} : _) -> updateParticles . colCrsWalls
. updateProjectiles -- . ifConfigWallRotate
. updateLightSources . simpleCrSprings
$ updateClouds . zoneCreatures
w . updateDoors
(_ : _) -> w . resetWorldEvents
[] -> checkEndGame . dbArg _worldEvents
. updateDistortions . updateModifications
. updateCreatureSoundPositions . updateParticles
. ppEvents . updateProjectiles
. updateCamera . updateLightSources
. colCrsWalls . updateClouds
-- . ifConfigWallRotate . zoneClouds
. simpleCrSprings . updateMachines
. zoneCreatures . updateCreatures
. updateDoors . updateCreatureGroups
. resetWorldEvents . updateBlocks
. dbArg _worldEvents . updateSeenWalls
. updateModifications . (lSelHammerPosition %~ moveHammerUp)
. updateParticles $ updateCloseObjects w
. updateProjectiles
. updateLightSources
. updateClouds
. zoneClouds
. updateMachines
. updateCreatures
. updateCreatureGroups
. updateBlocks
. updateSeenWalls
. (lSelHammerPosition %~ moveHammerUp)
$ updateCloseObjects w
where where
--updatedLightSources = mapMaybe (\b -> _tlsUpdate b w b) $ _tempLightSources w --updatedLightSources = mapMaybe (\b -> _tlsUpdate b w b) $ _tempLightSources w
zoneCreatures = set (creaturesZone . znObjects) zoneCreatures = set (creaturesZone . znObjects)
@@ -171,7 +178,7 @@ markWallSeen w wl = w { _walls = IM.adjust mw (_wlID wl) $ _walls w }
checkEndGame :: World -> World checkEndGame :: World -> World
checkEndGame w checkEndGame w
| _crHP (you w) < 1 = haltSound $ w {_menuLayers = [gameOverMenu]} | _crHP (you w) < 1 = undefined -- haltSound $ w {_menuLayers = [gameOverMenu]}
| otherwise = w | otherwise = w
updateClouds :: World -> World updateClouds :: World -> World