From 7c18915e9bc24e972ae61ed93671d11a971db926 Mon Sep 17 00:00:00 2001 From: nek0 Date: Sat, 17 Oct 2020 01:53:25 +0200 Subject: [PATCH] build foundations for state machine --- pituicat.cabal | 7 +++++++ shell.nix | 10 ++++++---- src/Main.hs | 24 ++++++++++++++++++++---- src/State/Loading.hs | 7 +++++++ src/State/Loading/Draw.hs | 10 ++++++++++ src/State/Loading/Load.hs | 33 +++++++++++++++++++++++++++++++++ src/State/Loading/Update.hs | 10 ++++++++++ src/StateMachine.hs | 32 ++++++++++++++++++++++++++++++++ 8 files changed, 125 insertions(+), 8 deletions(-) create mode 100644 src/State/Loading.hs create mode 100644 src/State/Loading/Draw.hs create mode 100644 src/State/Loading/Load.hs create mode 100644 src/State/Loading/Update.hs create mode 100644 src/StateMachine.hs diff --git a/pituicat.cabal b/pituicat.cabal index d6acc4b..18f464d 100644 --- a/pituicat.cabal +++ b/pituicat.cabal @@ -24,13 +24,19 @@ executable pituicat , Types.Texture , Classes , Classes.Bindable + , State.Loading + , State.Loading.Load + , State.Loading.Update + , State.Loading.Draw , Map + , StateMachine , Texture -- other-extensions: build-depends: base ^>=4.13.0.0 , affection , stm , OpenGL + , OpenGLRaw , sdl2 , containers , linear @@ -39,5 +45,6 @@ executable pituicat , vector , JuicyPixels , JuicyPixels-extra + , bytestring hs-source-dirs: src default-language: Haskell2010 diff --git a/shell.nix b/shell.nix index 37af4e7..65219a3 100644 --- a/shell.nix +++ b/shell.nix @@ -24,16 +24,18 @@ let license = stdenv.lib.licenses.lgpl3; }) {}; - f = { mkDerivation, aeson, base, containers, JuicyPixels, JuicyPixels-extra - , linear, OpenGL, stdenv , sdl2, stm, text, vector}: + f = { mkDerivation, aeson, base, bytestring, containers, JuicyPixels + , JuicyPixels-extra, linear, OpenGL, OpenGLRaw, stdenv , sdl2, stm, text + , vector}: mkDerivation { pname = "pituicat"; version = "0.0.0.0"; src = ./.; isLibrary = false; isExecutable = true; - executableHaskellDepends = [ aeson affection base linear containers - JuicyPixels JuicyPixels-extra OpenGL sdl2 stm text vector]; + executableHaskellDepends = [ aeson affection base bytestring linear + containers JuicyPixels JuicyPixels-extra OpenGL OpenGLRaw sdl2 stm text + vector]; license = stdenv.lib.licenses.gpl3; }; diff --git a/src/Main.hs b/src/Main.hs index eb537ef..389e925 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -15,13 +15,14 @@ import Linear -- internal imports +import StateMachine import Types instance Affectionate GameData where - preLoop _ = return () - handleEvents _ _ = return () - update _ _ = return () - draw _ = return () + preLoop = smLoad Loading + handleEvents = handle + update = Main.update + draw = Main.draw loadState = Main.init cleanUp _ = return () hasNextStep = liftIO . atomically . readTVar . gameRunning @@ -46,6 +47,21 @@ main = do } :: AffectionConfig GameData withAffection config +handle :: GameData -> [SDL.EventPayload] -> Affection () +handle gd evs = do + state <- liftIO (atomically $ readTVar $ gameState gd) + smEvent state gd evs + +update :: GameData -> Double -> Affection () +update gd dt = do + state <- liftIO (atomically $ readTVar $ gameState gd) + smUpdate state gd dt + +draw :: GameData -> Affection () +draw gd = do + state <- liftIO (atomically $ readTVar $ gameState gd) + smDraw state gd + init :: IO GameData init = GameData <$> newTVarIO Loading diff --git a/src/State/Loading.hs b/src/State/Loading.hs new file mode 100644 index 0000000..c8a4231 --- /dev/null +++ b/src/State/Loading.hs @@ -0,0 +1,7 @@ +module State.Loading + ( module L + ) where + +import State.Loading.Load as L +import State.Loading.Update as L +import State.Loading.Draw as L diff --git a/src/State/Loading/Draw.hs b/src/State/Loading/Draw.hs new file mode 100644 index 0000000..2ae2249 --- /dev/null +++ b/src/State/Loading/Draw.hs @@ -0,0 +1,10 @@ +module State.Loading.Draw where + +import Affection + +-- internal imports + +import Types + +initLoadDraw :: GameData -> Affection () +initLoadDraw gd = return () diff --git a/src/State/Loading/Load.hs b/src/State/Loading/Load.hs new file mode 100644 index 0000000..46beb7d --- /dev/null +++ b/src/State/Loading/Load.hs @@ -0,0 +1,33 @@ +module State.Loading.Load where + +import Affection + +import SDL (($=), get) +import qualified SDL +import qualified SDL.Internal.Numbered as SDL +import qualified SDL.Raw.Video as SDL (glSetAttribute) +import qualified SDL.Raw.Enum as SDL + +import qualified Graphics.Rendering.OpenGL as GL +import qualified Graphics.GL as GLRaw + +import Foreign.Marshal.Array + +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B8 + +import Control.Concurrent.STM + +-- internal imports + +import Types +import Map + +initLoadLoad + :: GameData + -> Affection () +initLoadLoad gd = do + stateData <- liftIO (TestData <$> constructMap testLevelDesc 0) + liftIO $ atomically $ do + writeTVar (gameStateData gd) stateData + writeTVar (gameState gd) (MainGame Test) diff --git a/src/State/Loading/Update.hs b/src/State/Loading/Update.hs new file mode 100644 index 0000000..ac984ef --- /dev/null +++ b/src/State/Loading/Update.hs @@ -0,0 +1,10 @@ +module State.Loading.Update where + +import Affection + +-- internal imports + +import Types + +initLoadUpdate :: GameData -> Double -> Affection () +initLoadUpdate gd dt = return () diff --git a/src/StateMachine.hs b/src/StateMachine.hs new file mode 100644 index 0000000..0e5d061 --- /dev/null +++ b/src/StateMachine.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +module StateMachine where + +import Affection + +import Control.Monad (void) + +-- internal imports + +import Types + +import State.Loading + +instance StateMachine GameData State where + + smLoad Loading = initLoadLoad + smLoad x = error ("State load not yet implemented: " <> show x) + + smUpdate Loading = initLoadUpdate + smUpdate x = error ("State update not yet implemented: " <> show x) + + smDraw Loading = initLoadDraw + smDraw x = error ("State draw not yet implemented: " <> show x) + + smEvent _ gd evs = do + let Subsystems w m k _ = gameSubsystems gd + void . (consumeSDLEvents k) =<< + consumeSDLEvents m =<< + consumeSDLEvents w evs + + smClean x = error ("State clean not yet implemented: " <> show x)