update to new affection

This commit is contained in:
nek0 2022-08-04 18:13:53 +02:00
parent eecfe82abd
commit cd2a0f3706
10 changed files with 30 additions and 19 deletions

2
.gitignore vendored
View file

@ -8,6 +8,8 @@
cabal.sandbox.config
dist/
dist-newstyle/
.direnv/
.envrc
*.prof
*.aux
*.hp

View file

@ -1,2 +1,2 @@
constraints: affection +verbose
constraints: affection +debug
profiling: True

View file

@ -2,3 +2,4 @@ packages:
./
../affection
profiling: True
constraints: affection +verbose

View file

@ -8,6 +8,7 @@ import Graphics.Rendering.OpenGL.GL.FlushFinish (finish)
import Control.Concurrent (forkIO)
import Control.Concurrent.MVar
import Control.Monad
import Control.Monad.Trans.Resource (ResIO)
import qualified Data.Map as M
import qualified Data.Text as T
@ -45,7 +46,7 @@ loadLoad ud = do
(nano ud)
(stateMVar ud)
(stateProgress ud)
SDL.glMakeCurrent (fromJust curWin) (snd $ head $ glContext ad)
SDL.glMakeCurrent (fromJust curWin) (acContext $ head $ glContext ad)
void $ liftIO $ swapMVar (state ud) Load
void $ liftIO $ swapMVar (assetFonts ud) (M.fromList
[ (FontBedstead, "bedstead")
@ -53,12 +54,12 @@ loadLoad ud = do
)
loadFork
:: SystemState Entity (AffectionState (AffectionData) IO)
:: SystemState Entity (AffectionState (AffectionData) ResIO)
-> SDL.Window
-> SDL.GLContext
-> Context
-> MVar
( SystemState Entity (AffectionState (AffectionData) IO)
( SystemState Entity (AffectionState (AffectionData) ResIO)
, StateData
)
-> MVar (Float, T.Text)

View file

@ -17,6 +17,7 @@ import Data.Maybe (fromJust)
import Control.Monad
import Control.Concurrent.MVar
import Control.Monad.Trans.Resource (allocate)
-- internal imports
@ -60,8 +61,9 @@ main = do
pre :: UserData -> Affection ()
pre ud = do
ad <- A.get
threadCtx <- SDL.glCreateContext ((\(_, y, _) -> y) $ head $ drawWindows ad)
SDL.glMakeCurrent ((\(_, y, _) -> y) $ head $ drawWindows ad) (snd $ head $ glContext ad)
let (AffectionWindow awwindow _ _) = head $ drawWindows ad
threadCtx <- SDL.glCreateContext awwindow
SDL.glMakeCurrent awwindow (acContext $ head $ glContext ad)
let Subsystems w _ k j _ = subsystems ud
_ <- partSubscribe w (fitViewport (1280/720))
_ <- partSubscribe w (exitOnWindowClose ud)
@ -70,7 +72,7 @@ pre ud = do
u <- partSubscribe j (cacheJoypad ud)
(ws, _) <- yieldSystemT (0, defStorage) (return ())
void $ liftIO $ swapMVar (threadContext ud) (Just threadCtx)
void $ liftIO $ swapMVar (window ud) (Just $ (\(_, y, _) -> y) $ head $ drawWindows ad)
void $ liftIO $ swapMVar (window ud) (Just awwindow)
void $ liftIO $ putMVar (worldState ud) ws
void $ liftIO $ putMVar (joyUUID ud) u
@ -90,8 +92,8 @@ quitGame ud (MsgKeyboardEvent _ _ SDL.Pressed False sym)
mapM_ (partUnSubscribe j) curUUID
mapM_ (partUnSubscribe t) curUUID
SDL.glMakeCurrent
((\(_, y, _) -> y) $ head $ drawWindows ad)
(snd $ head $ glContext ad)
(awWindow $ head $ drawWindows ad)
(acContext $ head $ glContext ad)
(ws, _) <- yieldSystemT (0, defStorage) (return ())
void $ liftIO $ swapMVar (worldState ud) ws
void $ liftIO $ swapMVar (state ud) Load

View file

@ -12,6 +12,7 @@ import NanoVG hiding (V2(..))
import Control.Monad (when, void)
import Control.Monad.State.Strict (evalStateT)
import Control.Monad.Trans.Resource (ResIO, runResourceT)
import Control.Concurrent.MVar
import Control.Concurrent (forkIO)
import Control.Parallel.Strategies hiding (dot)
@ -85,7 +86,7 @@ changeMaps2 _ _ = return ()
loadMapFork
:: UserData
-> AffectionData
-> MVar (SystemState Entity (AffectionState AffectionData IO), StateData)
-> MVar (SystemState Entity (AffectionState AffectionData ResIO), StateData)
-> MVar (Float, T.Text)
-> IO ()
loadMapFork ud ad future progress = do
@ -130,7 +131,7 @@ loadMapFork ud ad future progress = do
, "Creating WorldState"
)))
wState <- liftIO $ readMVar (worldState ud)
(nws, mmimgmat) <- evalStateT (runState (yieldSystemT wState $ do
(nws, mmimgmat) <- runResourceT $ evalStateT (runState (yieldSystemT wState $ do
liftIO $ modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Registering copiers into WorldState"

View file

@ -15,6 +15,7 @@ import Data.String
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Trans (lift)
import Control.Monad.Trans.Resource (ResIO)
import Control.Concurrent.MVar
import Control.Concurrent (forkIO)
@ -33,7 +34,7 @@ import Object ()
getPosBounds
:: SystemT
Entity
(AffectionState AffectionData IO)
(AffectionState AffectionData ResIO)
[(V2 Double, Boundaries Double)]
getPosBounds = do
efor allEnts $ do
@ -47,10 +48,10 @@ getPosBounds = do
updateNPCs
:: M.Matrix (Maybe ImgId)
-> M.Matrix TileState
-> SystemState Entity (AffectionState AffectionData IO)
-> SystemState Entity (AffectionState AffectionData ResIO)
-> V.Vector ReachPoint
-> Double
-> SystemT Entity (AffectionState AffectionData IO) ()
-> SystemT Entity (AffectionState AffectionData ResIO) ()
updateNPCs imgmat tsmat ws rrp dt = do
updateStats dt
posbounds <- getPosBounds
@ -263,7 +264,7 @@ standStill imgmat tsmat pos' rot' ws posbounds rp = do
updateStats
:: Double
-> SystemT Entity (AffectionState AffectionData IO) ()
-> SystemT Entity (AffectionState AffectionData ResIO) ()
updateStats dt =
emap allEnts $ do
with npcStats

View file

@ -5,6 +5,7 @@ module Types.ObjClass where
import Affection
import Control.Monad.Trans.Resource (ResIO)
import Data.Ecstasy
import Types.Entity
@ -15,7 +16,7 @@ class ObjectAction otype ostate where
-> otype
-> ostate
-> Ent
-> SystemT Entity (AffectionState AffectionData IO) ()
-> SystemT Entity (AffectionState AffectionData ResIO) ()
objectTransition
:: otype
@ -23,7 +24,7 @@ class ObjectAction otype ostate where
-> Bool
-> Ent
-> Maybe Ent
-> SystemT Entity (AffectionState AffectionData IO) (Entity 'SetterOf)
-> SystemT Entity (AffectionState AffectionData ResIO) (Entity 'SetterOf)
class ActionTime otype ostate where
actionTime :: otype -> ostate -> Double

View file

@ -16,6 +16,7 @@ import qualified Data.Text as T
import Data.Ecstasy
import Control.Concurrent.MVar
import Control.Monad.Trans.Resource
import Types.StateData
import Types.ImgId
@ -34,10 +35,10 @@ data UserData = UserData
, translation :: MVar Translation
, nano :: Context
, uuid :: MVar [UUID]
, worldState :: MVar (SystemState Entity (AffectionState AffectionData IO))
, worldState :: MVar (SystemState Entity (AffectionState AffectionData ResIO))
, stateData :: MVar StateData
, stateMVar :: MVar
( SystemState Entity (AffectionState AffectionData IO)
( SystemState Entity (AffectionState AffectionData ResIO)
, StateData
)
, stateProgress :: MVar (Float, T.Text)

View file

@ -80,6 +80,7 @@ executable tracer-game
, mtl
, parallel
, split
, resourcet
hs-source-dirs: src
ghc-options: -Wall -threaded
default-language: Haskell2010