build foundations for state machine

This commit is contained in:
nek0 2020-10-17 01:53:25 +02:00
parent cf520852d0
commit 7c18915e9b
8 changed files with 125 additions and 8 deletions

View File

@ -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

View File

@ -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;
};

View File

@ -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

7
src/State/Loading.hs Normal file
View File

@ -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

10
src/State/Loading/Draw.hs Normal file
View File

@ -0,0 +1,10 @@
module State.Loading.Draw where
import Affection
-- internal imports
import Types
initLoadDraw :: GameData -> Affection ()
initLoadDraw gd = return ()

33
src/State/Loading/Load.hs Normal file
View File

@ -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)

View File

@ -0,0 +1,10 @@
module State.Loading.Update where
import Affection
-- internal imports
import Types
initLoadUpdate :: GameData -> Double -> Affection ()
initLoadUpdate gd dt = return ()

32
src/StateMachine.hs Normal file
View File

@ -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)