From ae29688a6bcd05daf9154fb5792861723afdb1ed Mon Sep 17 00:00:00 2001 From: 3gg <3gg@shellblade.net> Date: Thu, 2 Jan 2025 09:58:14 -0800 Subject: Introduce HasState to simplify state programming. --- Demos/Pong/Main.hs | 20 +++++-------------- Spear/App.hs | 51 +++++++++++++++++++++++++++++++++++------------ Spear/Game.hs | 12 ++++++++--- Spear/Render/Immediate.hs | 4 +++- 4 files changed, 55 insertions(+), 32 deletions(-) diff --git a/Demos/Pong/Main.hs b/Demos/Pong/Main.hs index 993c0ff..22b1021 100644 --- a/Demos/Pong/Main.hs +++ b/Demos/Pong/Main.hs @@ -7,7 +7,7 @@ import Pong import Spear.App import Spear.Game import Spear.Math.AABB -import Spear.Math.Matrix4 as Matrix4 hiding (position) +import Spear.Math.Matrix4 as Matrix4 import Spear.Math.Spatial import Spear.Math.Spatial2 import Spear.Math.Vector @@ -20,12 +20,10 @@ import Spear.Sound.State import Spear.Window import Control.Monad (when) -import Data.Maybe (mapMaybe) data Pong = Pong - { immRenderState :: ImmRenderState - , viewProjection :: Matrix4 + { viewProjection :: Matrix4 , backgroundMusic :: SoundSource , world :: [GameObject] } @@ -43,10 +41,6 @@ main = runApp app initGame :: Game AppContext Pong initGame = do - renderCoreState <- contextRenderCoreState <$> get - (immRenderState, renderCoreState') <- runSiblingGame renderCoreState newImmRenderer - -- TODO: This can work if we use FlexibleContexts and change the function signatures. - --immRenderState <- newImmRenderer music <- siblingGame $ do musicBuffer <- loadAudioFile "/home/jeanne/Casual Tiki Party Main.wav" music <- makeSoundSource @@ -54,13 +48,10 @@ initGame = do setSoundLoopMode music Loop playSounds [music] return music - return $ Pong immRenderState Matrix4.id music newWorld + return $ Pong Matrix4.id music newWorld endGame :: Game GameState () -endGame = do - renderCoreState <- appRenderCoreState <$> get - game <- getGameState - exec' runSiblingGame renderCoreState (deleteImmRenderer $ immRenderState game) +endGame = return () step :: Elapsed -> Dt -> [InputEvent] -> Game GameState Bool @@ -86,7 +77,7 @@ exitRequested = elem (KeyDown KEY_ESC) render :: Game GameState () render = do gameState <- getGameState - immRenderState' <- exec runSiblingGame (immRenderState gameState) $ do + siblingGame $ do immStart immSetViewProjectionMatrix (viewProjection gameState) -- Clear the background to a different colour than the playable area to make @@ -95,7 +86,6 @@ render = do clearBuffers [ColourBuffer] render' $ world gameState immEnd - putGameState $ gameState { immRenderState = immRenderState' } render' :: [GameObject] -> Game ImmRenderState () render' world = do diff --git a/Spear/App.hs b/Spear/App.hs index 75bf6fa..6e8f5f2 100644 --- a/Spear/App.hs +++ b/Spear/App.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} module Spear.App @@ -19,6 +20,7 @@ where import Spear.Game import Spear.Render.Core.State +import Spear.Render.Immediate import Spear.Sound.Sound import Spear.Sound.State import Spear.Sys.Timer as Timer @@ -78,46 +80,61 @@ data AppContext = AppContext { contextWindow :: Window , contextRenderCoreState :: RenderCoreState , contextSoundState :: SoundState + , contextImmRenderState :: ImmRenderState } instance HasState AppContext RenderCoreState where getInnerState = contextRenderCoreState - setInnerState context renderCoreState = context { contextRenderCoreState = renderCoreState } + setInnerState context state = context { contextRenderCoreState = state } instance HasState AppContext SoundState where getInnerState = contextSoundState - setInnerState context soundState = context { contextSoundState = soundState } + setInnerState context state = context { contextSoundState = state } + +instance HasState AppContext ImmRenderState where + getInnerState = contextImmRenderState + setInnerState context state = context { contextImmRenderState = state } -- | Application state. data AppState s = AppState { appWindow :: Window , appRenderCoreState :: RenderCoreState , appSoundState :: SoundState - , customState :: s + , appImmRenderState :: ImmRenderState + , appCustomState :: s } +-- Requires FlexibleInstances. +instance HasState (AppState s) s where + getInnerState = appCustomState + setInnerState appState state = appState { appCustomState = state } + instance HasState (AppState s) RenderCoreState where getInnerState = appRenderCoreState - setInnerState appState renderCoreState = appState { appRenderCoreState = renderCoreState } + setInnerState appState state = appState { appRenderCoreState = state } instance HasState (AppState s) SoundState where getInnerState = appSoundState - setInnerState appState soundState = appState { appSoundState = soundState } + setInnerState appState state = appState { appSoundState = state } + +instance HasState (AppState s) ImmRenderState where + getInnerState = appImmRenderState + setInnerState appState state = appState { appImmRenderState = state } -- | Get the custom state in the app state. getGameState :: Game (AppState s) s -getGameState = customState <$> get +getGameState = appCustomState <$> get -- | Put the custom state in the app state. putGameState :: s -> Game (AppState s) () putGameState custom = do appState <- get - put $ appState { customState = custom } + put $ appState { appCustomState = custom } -- | Modify the custom state in the app state. modifyGameState :: (s -> s) -> Game (AppState s) () -modifyGameState f = modify $ \appState -> appState { customState = f (customState appState )} +modifyGameState f = modify $ \appState -> appState { appCustomState = f (appCustomState appState )} -- | Run the application. runApp :: App s -> IO () @@ -129,21 +146,29 @@ runApp app = withWindow (w, h) (title ops) $ \window -> withSoundContext $ eval runGame () $ do -- Create initial context. + -- We could modify function signatures such as: + -- newImmRenderer :: HasState s RenderCoreState => Game s ImmRenderState + -- to simplify things a bit. But I'm not sure I want HasState to + -- proliferate like that right now. initialSoundState <- eval runSiblingGame () initSoundSystem - let context = AppContext window newRenderCoreState initialSoundState + (immRenderState, renderCoreState) <- runSiblingGame newRenderCoreState newImmRenderer + let context = AppContext window renderCoreState initialSoundState immRenderState -- Create initial app state. (gameState, context') <- runSiblingGame context (initApp app) let appState = AppState { appWindow = contextWindow context' , appRenderCoreState = contextRenderCoreState context' , appSoundState = contextSoundState context' - , customState = gameState + , appImmRenderState = contextImmRenderState context' + , appCustomState = gameState } -- Run app. - (result, endGameState) <- runSiblingGame appState (loop app window) + (result, endAppState) <- runSubGame appState $ do + loop app window + endApp app -- Shut down. - exec' runSiblingGame endGameState (endApp app) - exec' runSiblingGame (appSoundState appState) destroySoundSystem + exec' runSiblingGame (appRenderCoreState endAppState) $ deleteImmRenderer (appImmRenderState endAppState) + exec' runSiblingGame (appSoundState endAppState) destroySoundSystem -- | Enter the main application loop. loop :: App s -> Window -> Game (AppState s) () diff --git a/Spear/Game.hs b/Spear/Game.hs index 1af8e9b..0c8b963 100644 --- a/Spear/Game.hs +++ b/Spear/Game.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -79,6 +80,11 @@ class HasState s t where getInnerState :: s -> t setInnerState :: s -> t -> s +-- Identity instance. +instance HasState s s where + getInnerState = id + setInnerState s s' = s' + -- | Release the given 'Resource'. release' :: ResourceClass a => a -> Game s () @@ -129,7 +135,7 @@ exec' runner game state = void $ runner game state -- | Run a sibling game on nested state. siblingGame :: HasState s t => Game t a -> Game s a siblingGame tAction = do - tState <- getInnerState <$> get - (result, tState') <- runSiblingGame tState tAction - modify $ \outerState -> setInnerState outerState tState' + outerState <- getInnerState <$> get + (result, outerState') <- runSiblingGame outerState tAction + modify $ \outerState -> setInnerState outerState outerState' return result diff --git a/Spear/Render/Immediate.hs b/Spear/Render/Immediate.hs index b3a8998..786e844 100644 --- a/Spear/Render/Immediate.hs +++ b/Spear/Render/Immediate.hs @@ -74,7 +74,9 @@ deleteImmRenderer immState = do deleteGeometry (triangles immState) -- The functions below are all defined inside the Game ImmRenderState monad so --- that all of the drawing can conveniently happen inside the monad. +-- that all of the drawing can conveniently happen inside the monad. They could +-- technically be defined inside MonadIO, but then we would have to explicitly +-- pass in the ImmRenderState. immStart :: Game ImmRenderState () immStart = do -- cgit v1.2.3