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 cabal.sandbox.config
dist/ dist/
dist-newstyle/ dist-newstyle/
.direnv/
.envrc
*.prof *.prof
*.aux *.aux
*.hp *.hp

View file

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

View file

@ -2,3 +2,4 @@ packages:
./ ./
../affection ../affection
profiling: True 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 (forkIO)
import Control.Concurrent.MVar import Control.Concurrent.MVar
import Control.Monad import Control.Monad
import Control.Monad.Trans.Resource (ResIO)
import qualified Data.Map as M import qualified Data.Map as M
import qualified Data.Text as T import qualified Data.Text as T
@ -45,7 +46,7 @@ loadLoad ud = do
(nano ud) (nano ud)
(stateMVar ud) (stateMVar ud)
(stateProgress 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 (state ud) Load
void $ liftIO $ swapMVar (assetFonts ud) (M.fromList void $ liftIO $ swapMVar (assetFonts ud) (M.fromList
[ (FontBedstead, "bedstead") [ (FontBedstead, "bedstead")
@ -53,12 +54,12 @@ loadLoad ud = do
) )
loadFork loadFork
:: SystemState Entity (AffectionState (AffectionData) IO) :: SystemState Entity (AffectionState (AffectionData) ResIO)
-> SDL.Window -> SDL.Window
-> SDL.GLContext -> SDL.GLContext
-> Context -> Context
-> MVar -> MVar
( SystemState Entity (AffectionState (AffectionData) IO) ( SystemState Entity (AffectionState (AffectionData) ResIO)
, StateData , StateData
) )
-> MVar (Float, T.Text) -> MVar (Float, T.Text)

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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