From cdd5db2b73db03a4e386a9188df30e26d3457fa3 Mon Sep 17 00:00:00 2001 From: nek0 Date: Tue, 5 May 2020 10:26:16 +0200 Subject: [PATCH] finish porting process --- shell.nix | 18 +-- src/Init.hs | 37 ++--- src/Interior.hs | 2 - src/Load.hs | 9 +- src/Main.hs | 127 ++++++++--------- src/MainGame/MindMap.hs | 289 ++++++++++++++++++++------------------- src/MainGame/WorldMap.hs | 247 +++++++++++++++------------------ src/Menu/Connect.hs | 251 ++++++++++++++++------------------ src/Navigation.hs | 2 +- src/StateMachine.hs | 12 +- src/Types/UserData.hs | 1 + 11 files changed, 482 insertions(+), 513 deletions(-) diff --git a/shell.nix b/shell.nix index 3de23cd..f593ef7 100644 --- a/shell.nix +++ b/shell.nix @@ -26,25 +26,25 @@ let }) {}; algebraic-graphs = with haskellPackages; callPackage( - { mkDerivation, array, base, base-compat, base-orphans, containers - , deepseq, extra, inspection-testing, mtl, QuickCheck, stdenv + { mkDerivation, array, base, containers, deepseq, extra + , inspection-testing, mtl, QuickCheck, stdenv, transformers }: mkDerivation { pname = "algebraic-graphs"; - version = "0.4"; - sha256 = "c905d32a6178a11e3c8096dbbf3bd19e570e87362c51fdc8653b43a51e46d3b7"; + version = "0.5"; + sha256 = "89b9fecf8245476ec823355125fcb95decf41fd9784e807d7bd0d09f0a79c50b"; libraryHaskellDepends = [ - array base base-compat containers deepseq mtl + array base containers deepseq mtl transformers ]; testHaskellDepends = [ - array base base-compat base-orphans containers extra - inspection-testing QuickCheck + array base containers deepseq extra inspection-testing mtl + QuickCheck transformers ]; homepage = "https://github.com/snowleopard/alga"; description = "A library for algebraic graph construction and transformation"; license = stdenv.lib.licenses.mit; - doCheck = false; - }) {}; + } + ) {}; nanovg = with haskellPackages; callPackage( { mkDerivation, base, bytestring, c2hs, containers, glew diff --git a/src/Init.hs b/src/Init.hs index c0983a1..150b966 100644 --- a/src/Init.hs +++ b/src/Init.hs @@ -38,24 +38,25 @@ init = do _ <- glewInit nvg <- createGL3 (S.fromList [NanoVG.Debug, Antialias, StencilStrokes]) UserData - <$> newMVar Load - <*> pure subs - <*> newMVar M.empty - <*> newMVar M.empty - <*> newMVar M.empty - <*> newMVar M.empty - <*> newMVar NoController - <*> newMVar NoTranslation - <*> pure nvg - <*> newMVar [] - <*> newEmptyMVar - <*> newMVar None - <*> newEmptyMVar - <*> newMVar (0, "foobar!") - <*> newMVar Nothing - <*> newMVar Nothing - <*> newMVar [] - <*> newEmptyMVar + <$> newMVar Load -- state + <*> pure subs -- subsystems + <*> newMVar M.empty -- assetIcons + <*> newMVar M.empty -- assetImages + <*> newMVar M.empty -- assetFonts + <*> newMVar M.empty -- assetAnimations + <*> newMVar NoController -- controls + <*> newMVar NoTranslation -- translation + <*> pure nvg -- nano + <*> newMVar [] -- uuid + <*> newEmptyMVar -- worldState <- + <*> newMVar None -- stateData + <*> newEmptyMVar -- stateMVar <- + <*> newEmptyMVar -- stateProgress <- + <*> newMVar Nothing -- threadContext + <*> newMVar Nothing -- window + <*> newMVar [] -- joyCache + <*> newEmptyMVar -- joyUUID <- + <*> newMVar True -- doNextStep loadPlayerSprite :: FilePath -- Path to spritemap diff --git a/src/Interior.hs b/src/Interior.hs index 52ba10c..03f7c71 100644 --- a/src/Interior.hs +++ b/src/Interior.hs @@ -1,7 +1,5 @@ module Interior where -import qualified Affection as A - import Data.Matrix as M import qualified Data.Map.Strict as Map import Data.List as L diff --git a/src/Load.hs b/src/Load.hs index 9125211..90ad625 100644 --- a/src/Load.hs +++ b/src/Load.hs @@ -32,8 +32,7 @@ loadLoad ud = do curWin <- liftIO $ readMVar (window ud) tContext <- liftIO $ readMVar (threadContext ud) let progress = (0, "Starting up") - void $ liftIO $ swapMVar (stateProgress ud) progress - void $ liftIO $ tryReadMVar (stateMVar ud) + void $ liftIO $ putMVar (stateProgress ud) progress _ <- liftIO $ createFont (nano ud) "bedstead" (FileName "assets/font/Bedstead-Semicondensed.ttf") _ <- liftIO $ forkIO $ @@ -491,9 +490,13 @@ loadFork ws win glc nvg future progress = do ] modifyMVar_ progress (return . (\(p, _) -> ( p + increment - , "Handing over" + , "GL_Finish" ))) finish + modifyMVar_ progress (return . (\(p, _) -> + ( p + increment + , "Handing over" + ))) putMVar future ( ws , LoadData diff --git a/src/Main.hs b/src/Main.hs index 637d16f..d2490bb 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -15,7 +15,8 @@ import Foreign.C.Types (CInt(..)) import Data.Maybe (fromJust) -import Control.Monad (when) +import Control.Monad +import Control.Concurrent.MVar -- internal imports @@ -27,6 +28,15 @@ import Util foreign import ccall unsafe "glewInit" glewInit :: IO CInt +instance Affectionate UserData where + preLoop = (\ud -> pre ud >> smLoad Load ud) + handleEvents = handle + update = Main.update + draw = Main.draw + loadState = Init.init + cleanUp = clean + hasNextStep = liftIO . readMVar . doNextStep + main :: IO () main = do let config = AffectionConfig @@ -41,93 +51,84 @@ main = do { SDL.glProfile = SDL.Core SDL.Normal 3 3 } } + , SDL.Windowed ) ] - , canvasSize = Nothing - , preLoop = pre >> smLoad Load - , eventLoop = handle - , updateLoop = update - , drawLoop = draw - , loadState = Init.init - , cleanUp = clean - , initScreenMode = SDL.Windowed - } + } :: AffectionConfig UserData withAffection config -pre :: Affection UserData () -pre = do +pre :: UserData -> Affection () +pre ud = do ad <- A.get - ud <- getAffection - threadCtx <- SDL.glCreateContext (snd $ head $ drawWindows ad) - SDL.glMakeCurrent (snd $ head $ drawWindows ad) (snd $ head $ glContext ad) - let Subsystems w m k j t = subsystems ud + threadCtx <- SDL.glCreateContext ((\(_, y, _) -> y) $ head $ drawWindows ad) + SDL.glMakeCurrent ((\(_, y, _) -> y) $ head $ drawWindows ad) (snd $ head $ glContext ad) + let Subsystems w _ k j _ = subsystems ud _ <- partSubscribe w (fitViewport (1280/720)) - _ <- partSubscribe w exitOnWindowClose + _ <- partSubscribe w (exitOnWindowClose ud) _ <- partSubscribe k toggleFullScreen - _ <- partSubscribe k quitGame - u <- partSubscribe j cacheJoypad + _ <- partSubscribe k (quitGame ud) + u <- partSubscribe j (cacheJoypad ud) (ws, _) <- yieldSystemT (0, defStorage) (return ()) - putAffection ud - { threadContext = Just threadCtx - , window = Just (snd $ head $ drawWindows ad) - , worldState = ws - , joyUUID = u - } + void $ liftIO $ swapMVar (threadContext ud) (Just threadCtx) + void $ liftIO $ swapMVar (window ud) (Just $ (\(_, y, _) -> y) $ head $ drawWindows ad) + void $ liftIO $ putMVar (worldState ud) ws + void $ liftIO $ putMVar (joyUUID ud) u -quitGame :: KeyboardMessage -> Affection UserData () -quitGame (MsgKeyboardEvent _ _ SDL.Pressed False sym) - | SDL.keysymKeycode sym == SDL.KeycodeEscape = quit +quitGame :: UserData -> KeyboardMessage -> Affection () +quitGame ud (MsgKeyboardEvent _ _ SDL.Pressed False sym) + | SDL.keysymKeycode sym == SDL.KeycodeEscape = + void $ liftIO $ swapMVar (doNextStep ud) False | SDL.keysymKeycode sym == SDL.KeycodeF5 = do ad <- A.get - ud <- getAffection - when (state ud == Main WorldMap || state ud == Main MindMap) $ do + curState <- liftIO $ readMVar (state ud) + when (curState == Main WorldMap || curState == Main MindMap) $ do let Subsystems w m k j t = subsystems ud - mapM_ (partUnSubscribe w) (uuid ud) - mapM_ (partUnSubscribe m) (uuid ud) - mapM_ (partUnSubscribe k) (uuid ud) - mapM_ (partUnSubscribe j) (uuid ud) - mapM_ (partUnSubscribe t) (uuid ud) + curUUID <- liftIO $ readMVar (uuid ud) + mapM_ (partUnSubscribe w) curUUID + mapM_ (partUnSubscribe m) curUUID + mapM_ (partUnSubscribe k) curUUID + mapM_ (partUnSubscribe j) curUUID + mapM_ (partUnSubscribe t) curUUID SDL.glMakeCurrent - (snd $ head $ drawWindows ad) + ((\(_, y, _) -> y) $ head $ drawWindows ad) (snd $ head $ glContext ad) (ws, _) <- yieldSystemT (0, defStorage) (return ()) - putAffection ud - { worldState = ws - , state = Load - } - smLoad Load - | otherwise = return () -quitGame _ = return () + void $ liftIO $ swapMVar (worldState ud) ws + void $ liftIO $ swapMVar (state ud) Load + smLoad Load ud + | otherwise = return () +quitGame _ _ = return () -toggleFullScreen :: KeyboardMessage -> Affection UserData () +toggleFullScreen :: KeyboardMessage -> Affection () toggleFullScreen (MsgKeyboardEvent _ _ SDL.Pressed False sym) - | SDL.keysymKeycode sym == SDL.KeycodeF11 = toggleScreen + | SDL.keysymKeycode sym == SDL.KeycodeF11 = toggleScreen 0 | otherwise = return () toggleFullScreen _ = return () -update :: Double -> Affection UserData () -update dt = do - ud <- getAffection - smUpdate (state ud) dt +update :: UserData -> Double -> Affection () +update ud dt = do + curState <- liftIO $ readMVar (state ud) + smUpdate curState ud dt -draw :: Affection UserData () -draw = do - ud <- getAffection +draw :: UserData -> Affection () +draw ud = do + curState <- liftIO $ readMVar (state ud) liftIO $ beginFrame (nano ud) 1280 720 1 - smDraw (state ud) + smDraw curState ud liftIO $ endFrame (nano ud) -handle :: [SDL.EventPayload] -> Affection UserData () -handle evs = do - s <- state <$> getAffection - smEvent s evs +handle :: UserData -> [SDL.EventPayload] -> Affection () +handle ud evs = do + s <- liftIO $ readMVar (state ud) + smEvent s ud evs -exitOnWindowClose :: WindowMessage -> Affection UserData () -exitOnWindowClose (MsgWindowClose _ _) = do +exitOnWindowClose :: UserData -> WindowMessage -> Affection () +exitOnWindowClose ud (MsgWindowClose _ _) = do liftIO $ logIO A.Debug "Window Closed" - quit -exitOnWindowClose _ = return () + void $ liftIO $ swapMVar (doNextStep ud) False +exitOnWindowClose _ _ = return () clean :: UserData -> IO () -clean ud = - SDL.glDeleteContext $ fromJust $ threadContext ud +clean ud = do + tContext <- readMVar (threadContext ud) + SDL.glDeleteContext $ fromJust tContext diff --git a/src/MainGame/MindMap.hs b/src/MainGame/MindMap.hs index 7c360eb..36ab60d 100644 --- a/src/MainGame/MindMap.hs +++ b/src/MainGame/MindMap.hs @@ -15,6 +15,9 @@ import Data.String import NanoVG hiding (V2(..)) +import Control.Concurrent.MVar +import Control.Monad + -- internal imports import Types @@ -25,145 +28,146 @@ import Collision import Util -updateMind :: Double -> Affection UserData () -updateMind dt = do - ud <- getAffection - (nws, _) <- yieldSystemT (worldState ud) $ do - emap allEnts $ do - with player - with xyvel - with mmvel - V2 rx ry <- query xyvel - -- let dr = (ry / sin (atan (1/2)) / 2) + rx - -- dc = rx - (ry / sin (atan (1/2)) / 2) - let V2 dr dc = fmap (* 1.5) (V2 rx ry `rotVec` 45) - return $ unchanged - { mmvel = Set $ 2 * V2 dr dc - } - emap allEnts $ do - with anim - with mmpos - stat <- query anim - let an = assetAnimations ud Map.! asId stat - ntime = asElapsedTime stat + dt - nstate = if ntime > fromIntegral (asCurrentFrame stat) * - (animDuration an / fromIntegral (length $ animSprites an)) - then - let nframe = asCurrentFrame stat + 1 - in case animPlay an of - APLoop -> - let (nnframe, nntime) = - if nframe >= length (animSprites an) - then (0, 0) - else (nframe, ntime) - in stat - { asCurrentFrame = nnframe - , asElapsedTime = nntime - } - APOnce -> - let nnframe = if nframe >= length (animSprites an) - then nframe - 1 - else nframe - in stat - { asCurrentFrame = nnframe - , asElapsedTime = ntime - } - else - stat - { asElapsedTime = ntime - } - return $ unchanged - { anim = Set nstate - } - emap allEnts $ do - with player - with mmvel - with mmpos - with rot - with anim - pos'@(V2 pr pc) <- query mmpos - vel' <- query mmvel - rot' <- query rot - stat <- query anim - let npos = pos' + fmap (* dt) vel' - dpos@(V2 dpr dpc) = npos - pos' - aId = asId stat - nstat = case aiName aId of - "walking" - | sqrt (colldpos `dot` colldpos) > 0 -> - stat - { asId = aId - { aiDirection = fromMaybe rot' (direction vel') - } - } - | otherwise -> - stat - { asId = aId - { aiDirection = fromMaybe rot' (direction vel') - , aiName = "standing" - } - , asCurrentFrame = 0 - } - "standing" - | sqrt (colldpos `dot` colldpos) > 0 -> - stat - { asId = aId - { aiDirection = fromMaybe rot' (direction vel') - , aiName = "walking" - } - , asCurrentFrame = 0 - } - | otherwise -> - stat - { asId = aId - { aiDirection = fromMaybe rot' (direction vel') - } - } - x -> error ("unknown animation name" ++ x) - lll = (,) - <$> ( - if dpr < 0 - then [(floor dpr :: Int) .. 0] - else [0 .. (ceiling dpr :: Int)]) - <*> ( - if dpc < 0 - then [(floor dpc :: Int) .. 0] - else [0 .. (ceiling dpc :: Int)]) - colldpos = dpos * Prelude.foldl - (\acc a -> let ret = checkBoundsCollision2 pos' npos dt acc a - in A.log A.Verbose (fromString $ show ret) ret) - (V2 1 1) - ( - concatMap - (\(dr, dc) -> - let bs = fromMaybe [] $ collisionObstacle <$> M.unsafeGet - (fromIntegral $ floor pr + dr) - (fromIntegral $ floor pc + dc) - (mmImgMat (stateData ud)) - in Prelude.map (\(Boundaries (minr, minc) (maxr, maxc))-> - Boundaries - (minr + fromIntegral dr, minc + fromIntegral dc) - (maxr + fromIntegral dr, maxc + fromIntegral dc) - ) bs - ) - lll -- (A.log A.Verbose (show lll ++ " " ++ show len) lll) - ) - ent = unchanged - { mmpos = Set $ pos' + colldpos - , rot = Set (fromMaybe rot' $ direction vel') - , anim = Set nstat - } - return ent - putAffection ud - { worldState = nws - } +updateMind :: UserData -> Double -> Affection () +updateMind ud dt = do + wState <- liftIO $ readMVar (worldState ud) + sData <- liftIO $ readMVar (stateData ud) + (nws, _) <- yieldSystemT wState $ do + emap allEnts $ do + with player + with xyvel + with mmvel + V2 rx ry <- query xyvel + -- let dr = (ry / sin (atan (1/2)) / 2) + rx + -- dc = rx - (ry / sin (atan (1/2)) / 2) + let V2 dr dc = fmap (* 1.5) (V2 rx ry `rotVec` 45) + return $ unchanged + { mmvel = Set $ 2 * V2 dr dc + } + emap allEnts $ do + with anim + with mmpos + stat <- query anim + aAnims <- liftIO $ readMVar (assetAnimations ud) + let an = aAnims Map.! asId stat + ntime = asElapsedTime stat + dt + nstate = if ntime > fromIntegral (asCurrentFrame stat) * + (animDuration an / fromIntegral (length $ animSprites an)) + then + let nframe = asCurrentFrame stat + 1 + in case animPlay an of + APLoop -> + let (nnframe, nntime) = + if nframe >= length (animSprites an) + then (0, 0) + else (nframe, ntime) + in stat + { asCurrentFrame = nnframe + , asElapsedTime = nntime + } + APOnce -> + let nnframe = if nframe >= length (animSprites an) + then nframe - 1 + else nframe + in stat + { asCurrentFrame = nnframe + , asElapsedTime = ntime + } + else + stat + { asElapsedTime = ntime + } + return $ unchanged + { anim = Set nstate + } + emap allEnts $ do + with player + with mmvel + with mmpos + with rot + with anim + pos'@(V2 pr pc) <- query mmpos + vel' <- query mmvel + rot' <- query rot + stat <- query anim + let npos = pos' + fmap (* dt) vel' + dpos@(V2 dpr dpc) = npos - pos' + aId = asId stat + nstat = case aiName aId of + "walking" + | sqrt (colldpos `dot` colldpos) > 0 -> + stat + { asId = aId + { aiDirection = fromMaybe rot' (direction vel') + } + } + | otherwise -> + stat + { asId = aId + { aiDirection = fromMaybe rot' (direction vel') + , aiName = "standing" + } + , asCurrentFrame = 0 + } + "standing" + | sqrt (colldpos `dot` colldpos) > 0 -> + stat + { asId = aId + { aiDirection = fromMaybe rot' (direction vel') + , aiName = "walking" + } + , asCurrentFrame = 0 + } + | otherwise -> + stat + { asId = aId + { aiDirection = fromMaybe rot' (direction vel') + } + } + x -> error ("unknown animation name" ++ x) + lll = (,) + <$> ( + if dpr < 0 + then [(floor dpr :: Int) .. 0] + else [0 .. (ceiling dpr :: Int)]) + <*> ( + if dpc < 0 + then [(floor dpc :: Int) .. 0] + else [0 .. (ceiling dpc :: Int)]) + colldpos = dpos * Prelude.foldl + (\acc a -> let ret = checkBoundsCollision2 pos' npos dt acc a + in A.log A.Verbose (fromString $ show ret) ret) + (V2 1 1) + ( + concatMap + (\(dr, dc) -> + let bs = fromMaybe [] $ collisionObstacle <$> M.unsafeGet + (fromIntegral $ floor pr + dr) + (fromIntegral $ floor pc + dc) + (mmImgMat sData) + in Prelude.map (\(Boundaries (minr, minc) (maxr, maxc))-> + Boundaries + (minr + fromIntegral dr, minc + fromIntegral dc) + (maxr + fromIntegral dr, maxc + fromIntegral dc) + ) bs + ) + lll -- (A.log A.Verbose (show lll ++ " " ++ show len) lll) + ) + ent = unchanged + { mmpos = Set $ pos' + colldpos + , rot = Set (fromMaybe rot' $ direction vel') + , anim = Set nstat + } + return ent + void $ liftIO $ swapMVar (worldState ud) nws -drawMind :: Affection UserData () -drawMind = do - ud <- getAffection +drawMind :: UserData -> Affection () +drawMind ud = do + sData <- liftIO $ readMVar (stateData ud) + wState <- liftIO $ readMVar (worldState ud) let ctx = nano ud dt <- getDelta - (_, (playerPos, posanims)) <- yieldSystemT (worldState ud) $ do + (_, (playerPos, posanims)) <- yieldSystemT wState $ do pc <- fmap head $ efor allEnts $ do with player with mmpos @@ -177,7 +181,7 @@ drawMind = do return (pos', stat, mbnds) return (pc, posanims) let V2 pr pc = playerPos - mat = mmImgMat (stateData ud) + mat = mmImgMat sData cols = fromIntegral (ncols mat) rows = fromIntegral (nrows mat) tileWidth = 64 :: Double @@ -185,8 +189,8 @@ drawMind = do x = realToFrac $ 640 + ((1 - pc) + (1 - pr)) * (tileWidth / 2) y = realToFrac $ 360 + ((1 - pr) - (1 - pc)) * (tileHeight / 2) partposanims = M.fromList - (nrows $ mmImgMat $ stateData ud) - (ncols $ mmImgMat $ stateData ud) + (nrows $ mmImgMat $ sData) + (ncols $ mmImgMat $ sData) ((reverse . fst) (Prelude.foldl (\(done, proc) coord -> @@ -195,8 +199,8 @@ drawMind = do ) ([], posanims) ((,) - <$> [1 .. (nrows $ mmImgMat $ stateData ud)] - <*> [1 .. (ncols $ mmImgMat $ stateData ud)] + <$> [1 .. (nrows $ mmImgMat $ sData)] + <*> [1 .. (ncols $ mmImgMat $ sData)] ) ) ) @@ -230,7 +234,8 @@ drawMind = do (reverse $ zip [1..] ls)) (zip [1..] (toLists mat)) fontSize ctx 20 - fontFace ctx (assetFonts ud Map.! FontBedstead) + aFonts <- readMVar (assetFonts ud) + fontFace ctx (aFonts Map.! FontBedstead) textAlign ctx (S.fromList [AlignCenter,AlignTop]) fillColor ctx (rgb 255 128 0) textBox ctx 0 0 200 ("FPS: " `T.append` T.pack (Prelude.take 5 $ show (1/dt))) diff --git a/src/MainGame/WorldMap.hs b/src/MainGame/WorldMap.hs index 0382ad2..b6563e5 100644 --- a/src/MainGame/WorldMap.hs +++ b/src/MainGame/WorldMap.hs @@ -11,7 +11,6 @@ import qualified SDL import NanoVG hiding (V2(..)) import Control.Monad (when, void) -import Control.Monad.IO.Class (liftIO) import Control.Monad.State.Strict (evalStateT) import Control.Concurrent.MVar import Control.Concurrent (forkIO) @@ -44,63 +43,49 @@ import NPC import Animation import Collision -loadMap :: Affection UserData () -loadMap = do - ud <- getAffection +loadMap :: UserData -> Affection () +loadMap ud = do ad <- get let (Subsystems _ _ k j t) = subsystems ud - uu0 <- partSubscribe k emitKbdActionMessage - uu1 <- partSubscribe j emitJoyActionMessage - uu2 <- partSubscribe t movePlayer2 - uu3 <- partSubscribe t playerInteract2 - uu4 <- partSubscribe t changeMaps2 - future <- liftIO newEmptyMVar - progress <- liftIO $ newMVar (0, "Ohai!") - _ <- liftIO $ forkIO $ loadMapFork ud ad future progress - putAffection ud - { stateData = None - , uuid = [ uu0, uu1, uu2, uu3, uu4 ] - , stateMVar = future - , stateProgress = progress - , state = Main WorldMap - } + uu0 <- partSubscribe k (emitKbdActionMessage ud) + uu1 <- partSubscribe j (emitJoyActionMessage ud) + uu2 <- partSubscribe t (movePlayer2 ud) + uu3 <- partSubscribe t (playerInteract2 ud) + uu4 <- partSubscribe t (changeMaps2 ud) + void $ liftIO $ swapMVar (stateProgress ud) (0, "Ohai!") + _ <- liftIO $ forkIO $ loadMapFork ud ad (stateMVar ud) (stateProgress ud) + void $ liftIO $ swapMVar (stateData ud) None + void $ liftIO $ swapMVar (uuid ud) [ uu0, uu1, uu2, uu3, uu4 ] + void $ liftIO $ swapMVar (state ud) (Main WorldMap) -changeMaps :: KeyboardMessage -> Affection UserData () -changeMaps (MsgKeyboardEvent _ _ SDL.Pressed False sym) +changeMaps :: UserData -> KeyboardMessage -> Affection () +changeMaps ud (MsgKeyboardEvent _ _ SDL.Pressed False sym) | SDL.keysymKeycode sym == SDL.KeycodeF1 = do - ud <- getAffection - case state ud of + curState <- liftIO $ readMVar (state ud) + case curState of Main MindMap -> - putAffection ud - { state = Main WorldMap - } + void $ liftIO $ swapMVar (state ud) (Main WorldMap) Main WorldMap -> - putAffection ud - { state = Main MindMap - } + void $ liftIO $ swapMVar (state ud) (Main MindMap) _ -> return () | otherwise = return () -changeMaps _ = return () +changeMaps _ _ = return () -changeMaps2 :: ActionMessage -> Affection UserData () -changeMaps2 (ActionMessage ActSwitchMap _) = do - ud <- getAffection - case state ud of +changeMaps2 :: UserData -> ActionMessage -> Affection () +changeMaps2 ud (ActionMessage ActSwitchMap _) = do + curState <- liftIO $ readMVar (state ud) + case curState of Main MindMap -> - putAffection ud - { state = Main WorldMap - } + void $ liftIO $ swapMVar (state ud) (Main WorldMap) Main WorldMap -> - putAffection ud - { state = Main MindMap - } + void $ liftIO $ swapMVar (state ud) (Main MindMap) _ -> return () -changeMaps2 _ = return () +changeMaps2 _ _ = return () loadMapFork :: UserData - -> AffectionData UserData - -> MVar (SystemState Entity (AffectionState (AffectionData UserData) IO), StateData) + -> AffectionData + -> MVar (SystemState Entity (AffectionState AffectionData IO), StateData) -> MVar (Float, T.Text) -> IO () loadMapFork ud ad future progress = do @@ -144,7 +129,8 @@ loadMapFork ud ad future progress = do ( p + increment , "Creating WorldState" ))) - (nws, mmimgmat) <- evalStateT (runState (yieldSystemT (worldState ud) $ do + wState <- liftIO $ readMVar (worldState ud) + (nws, mmimgmat) <- evalStateT (runState (yieldSystemT wState $ do liftIO $ modifyMVar_ progress (return . (\(p, _) -> ( p + increment , "Registering copiers into WorldState" @@ -352,7 +338,7 @@ loadMapFork ud ad future progress = do then Nothing else a) (M.toList inter) - putMVar future (nws, MainData + void $ putMVar future (nws, MainData { mapMat = mat , imgMat = retMat , reachPoints = V.fromList rps @@ -360,11 +346,11 @@ loadMapFork ud ad future progress = do , roomGraph = gr }) -movePlayerKbd :: KeyboardMessage -> Affection UserData () -movePlayerKbd (MsgKeyboardEvent _ _ press False sym) +movePlayerKbd :: UserData -> KeyboardMessage -> Affection () +movePlayerKbd ud (MsgKeyboardEvent _ _ press False sym) | SDL.keysymKeycode sym == SDL.KeycodeW = do - ud <- getAffection - (nws, _) <- yieldSystemT (worldState ud) $ + wState <- liftIO $ readMVar (worldState ud) + (nws, _) <- yieldSystemT wState $ emap allEnts $ do with player (V2 vx _) <- query xyvel @@ -374,12 +360,10 @@ movePlayerKbd (MsgKeyboardEvent _ _ press False sym) return $ unchanged { xyvel = Set $ V2 vx ry } - putAffection ud - { worldState = nws - } + void $ liftIO $ swapMVar (worldState ud) nws | SDL.keysymKeycode sym == SDL.KeycodeS = do - ud <- getAffection - (nws, _) <- yieldSystemT (worldState ud) $ + wState <- liftIO $ readMVar (worldState ud) + (nws, _) <- yieldSystemT wState $ emap allEnts $ do with player (V2 vx _) <- query xyvel @@ -389,12 +373,10 @@ movePlayerKbd (MsgKeyboardEvent _ _ press False sym) return $ unchanged { xyvel = Set $ V2 vx ry } - putAffection ud - { worldState = nws - } + void $ liftIO $ swapMVar (worldState ud) nws | SDL.keysymKeycode sym == SDL.KeycodeA = do - ud <- getAffection - (nws, _) <- yieldSystemT (worldState ud) $ + wState <- liftIO $ readMVar (worldState ud) + (nws, _) <- yieldSystemT wState $ emap allEnts $ do with player (V2 _ vy) <- query xyvel @@ -404,12 +386,10 @@ movePlayerKbd (MsgKeyboardEvent _ _ press False sym) return $ unchanged { xyvel = Set $ V2 rx vy } - putAffection ud - { worldState = nws - } + void $ liftIO $ swapMVar (worldState ud) nws | SDL.keysymKeycode sym == SDL.KeycodeD = do - ud <- getAffection - (nws, _) <- yieldSystemT (worldState ud) $ + wState <- liftIO $ readMVar (worldState ud) + (nws, _) <- yieldSystemT wState $ emap allEnts $ do with player (V2 _ vy) <- query xyvel @@ -419,16 +399,14 @@ movePlayerKbd (MsgKeyboardEvent _ _ press False sym) return $ unchanged { xyvel = Set $ V2 rx vy } - putAffection ud - { worldState = nws - } + void $ liftIO $ swapMVar (worldState ud) nws | otherwise = return () -movePlayerKbd _ = return () +movePlayerKbd _ _ = return () -movePlayer2 :: ActionMessage -> Affection UserData () -movePlayer2 (ActionMessage mov _) = do - ud <- getAffection - (nws, _) <- yieldSystemT (worldState ud) $ +movePlayer2 :: UserData -> ActionMessage -> Affection () +movePlayer2 ud (ActionMessage mov _) = do + wState <- liftIO $ readMVar (worldState ud) + (nws, _) <- yieldSystemT wState $ emap allEnts $ do with player V2 vx vy <- query xyvel @@ -440,14 +418,12 @@ movePlayer2 (ActionMessage mov _) = do ActRight f -> V2 f vy _ -> V2 vx vy } - putAffection ud - { worldState = nws - } + void $ liftIO $ swapMVar (worldState ud) nws -playerInteract2 :: ActionMessage -> Affection UserData () -playerInteract2 (ActionMessage ActActivate _) = do - ud <- getAffection - (nws, _) <- yieldSystemT (worldState ud) $ do +playerInteract2 :: UserData -> ActionMessage -> Affection () +playerInteract2 ud (ActionMessage ActActivate _) = do + wState <- liftIO $ readMVar (worldState ud) + (nws, _) <- yieldSystemT wState $ do pdata <- efor allEnts $ do with player with pos @@ -478,22 +454,21 @@ playerInteract2 (ActionMessage ActActivate _) = do mapM_ (\(t, s, e) -> setEntity e =<< objectTransition t s True e (Just pent) ) relEnts - putAffection ud - { worldState = nws - } -playerInteract2 _ = return () + void $ liftIO $ swapMVar (worldState ud) nws +playerInteract2 _ _ = return () -drawMap :: Affection UserData () -drawMap = do - ud <- getAffection +drawMap :: UserData -> Affection () +drawMap ud = do + sData <- liftIO $ readMVar (stateData ud) + wState <- liftIO $ readMVar (worldState ud) let ctx = nano ud - case stateData ud of + case sData of None -> liftIO $ do progress <- readMVar (stateProgress ud) drawLoadScreen ud progress _ -> do dt <- getDelta - (_, dat) <- yieldSystemT (worldState ud) $ do + (_, dat) <- yieldSystemT wState $ do efor allEnts $ do with pos pos' <- query pos @@ -534,10 +509,10 @@ drawMap = do ([], [], []) dat V2 pr pc = playerPos - MainData _ _ _ _ gr = stateData ud + MainData _ _ _ _ gr = sData seekGraph = V.foldl V.snoc (Types.connects (V.head gr)) (V.tail gr) room = V.filter (inBounds (fmap floor playerPos) . bounds) seekGraph - mat = imgMat (stateData ud) + mat = imgMat sData cols = fromIntegral (ncols mat) rows = fromIntegral (nrows mat) tileWidth = 64 :: Double @@ -545,8 +520,8 @@ drawMap = do x = realToFrac $ 640 + ((1 - pc) + (1 - pr)) * (tileWidth / 2) y = realToFrac $ 360 + ((1 - pr) - (1 - pc)) * (tileHeight / 2) partposanims = M.fromList - (nrows $ mapMat $ stateData ud) - (ncols $ mapMat $ stateData ud) + (nrows $ mapMat sData) + (ncols $ mapMat sData) ((reverse . fst) (Prelude.foldl (\(done, proc) coord -> @@ -555,8 +530,8 @@ drawMap = do ) ([], posanims) ((,) - <$> [1 .. (nrows $ mapMat $ stateData ud)] - <*> [1 .. (ncols $ mapMat $ stateData ud)] + <$> [1 .. (nrows $ mapMat sData)] + <*> [1 .. (ncols $ mapMat sData)] ) ) ) @@ -634,7 +609,8 @@ drawMap = do closePath ctx ) posActions fontSize ctx 20 - fontFace ctx (assetFonts ud Map.! FontBedstead) + aFonts <- readMVar (assetFonts ud) + fontFace ctx (aFonts Map.! FontBedstead) textAlign ctx (S.fromList [AlignCenter,AlignTop]) fillColor ctx (rgb 255 128 0) textBox ctx 0 0 200 ( @@ -656,23 +632,23 @@ drawTile -> Int -> Maybe ImgId -> IO () -drawTile ud ctx posanims pr pc row col img = - do - let (bef, beh) = L.partition delimiter sorted - save ctx - mapM_ (flip drawAnim fact) beh - maybe (return ()) (draw ud x (y - 42) 64 74 - (if fromMaybe False (isWall <$> img) then fact else 1)) - ((assetImages ud Map.!) <$> case img of - Just ImgEmpty -> Nothing - _ -> img - ) - mapM_ (flip drawAnim fact) bef - restore ctx - -- when (floor pr == row && floor pc == col) $ do - -- A.logIO A.Debug ("sorted: " ++ show sorted) - -- A.logIO A.Debug ("beh: " ++ show beh) - -- A.logIO A.Debug ("bef: " ++ show bef) +drawTile ud ctx posanims pr pc row col img = do + let (bef, beh) = L.partition delimiter sorted + aImages <- readMVar (assetImages ud) + save ctx + mapM_ (flip drawAnim fact) beh + maybe (return ()) (Types.draw ud x (y - 42) 64 74 + (if fromMaybe False (isWall <$> img) then fact else 1)) + ((aImages Map.!) <$> case img of + Just ImgEmpty -> Nothing + _ -> img + ) + mapM_ (flip drawAnim fact) bef + restore ctx + -- when (floor pr == row && floor pc == col) $ do + -- A.logIO A.Debug ("sorted: " ++ show sorted) + -- A.logIO A.Debug ("beh: " ++ show beh) + -- A.logIO A.Debug ("bef: " ++ show bef) where delimiter (V2 nr nc, as, mbnds) = animFloats (asId as) || @@ -726,29 +702,30 @@ drawTile ud ctx posanims pr pc row col img = drawAnim (V2 nr nc, as, _) factor = do let ax = realToFrac $ 640 + ((nc - pc) + (nr - pr)) * 32 - 32 ay = realToFrac $ 360 + ((nr - pr) - (nc - pc)) * 16 - 58 - draw ud ax ay 64 74 (if isWallLike (aiVariation $ asId as) then factor else 1) as + Types.draw ud ax ay 64 74 (if isWallLike (aiVariation $ asId as) then factor else 1) as -updateMap :: Double -> Affection UserData () -updateMap dt = do - ud <- getAffection - if stateData ud == None +updateMap :: UserData -> Double -> Affection () +updateMap ud dt = do + osData <- liftIO $ readMVar (stateData ud) + if osData == None then do mstart <- liftIO $ tryTakeMVar (stateMVar ud) case mstart of Just (nws, mendat) -> do - putAffection ud - { worldState = nws - , stateData = mendat - , state = Main WorldMap - } - updateMap 0.1 - updateMap 0.1 - updateMap 0.1 - updateMap 19 + void $ liftIO $ swapMVar (worldState ud) nws + void $ liftIO $ swapMVar (stateData ud) mendat + void $ liftIO $ swapMVar (state ud) (Main WorldMap) + updateMap ud 0.1 + updateMap ud 0.1 + updateMap ud 0.1 + updateMap ud 19 liftIO $ logIO A.Debug "Loaded game data" Nothing -> return () else do - (nws, _) <- yieldSystemT (worldState ud) $ do + wState <- liftIO $ readMVar (worldState ud) + sData <- liftIO $ readMVar (stateData ud) + aAnim <- liftIO $ readMVar (assetAnimations ud) + (nws, _) <- yieldSystemT wState $ do obstacleBounds <- efor allEnts $ do with obstacle with pos @@ -762,8 +739,8 @@ updateMap dt = do fact' <- fromMaybe 1 <$> queryMaybe velFact xyv2 <- queryMaybe xyvel stat <- query anim - let an = assetAnimations ud Map.! asId stat - mat = mapMat (stateData ud) + let an = aAnim Map.! asId stat + mat = mapMat sData ntime = asElapsedTime stat + dt npos = pos' + fmap (* (dt * fact')) (fromMaybe (V2 0 0) vel') dpos@(V2 dpr dpc) = npos - pos' @@ -789,7 +766,7 @@ updateMap dt = do (fromMaybe [] $ collisionObstacle <$> M.unsafeGet (min (nrows mat) $ max 1 $ fromIntegral $ floor pr + dr) (min (ncols mat) $ max 1 $ fromIntegral $ floor pc + dc) - (imgMat (stateData ud))) + (imgMat sData)) (Prelude.map snd $ Prelude.filter (\((V2 br bc), _) -> floor pr + dr == floor br && @@ -899,14 +876,12 @@ updateMap dt = do objectAction dt t s e ) tses (nws2, _) <- yieldSystemT nws $ updateNPCs - (imgMat $ stateData ud) - (mapMat $ stateData ud) + (imgMat sData) + (mapMat sData) nws (V.filter (\p -> pointType p /= RoomExit) - (reachPoints $ stateData ud) + (reachPoints sData) ) dt - putAffection ud - { worldState = nws2 - } + void $ liftIO $ swapMVar (worldState ud) nws2 diff --git a/src/Menu/Connect.hs b/src/Menu/Connect.hs index 4c3bd0c..f0e775d 100644 --- a/src/Menu/Connect.hs +++ b/src/Menu/Connect.hs @@ -10,9 +10,10 @@ import Linear hiding (rotate, translation) import qualified Data.Set as S import qualified Data.Map.Strict as M -import Data.Maybe (isNothing, isJust) import Data.String +import Control.Concurrent.MVar + import Control.Monad -- internal imports @@ -22,108 +23,94 @@ import Util import Menu.Adjust import MainGame.WorldMap -loadMenu :: Affection UserData () -loadMenu = do - ud <- getAffection - ad <- get +loadMenu :: UserData -> Affection () +loadMenu ud = do let (Subsystems _ m k j t) = subsystems ud - uu1 <- partSubscribe j joystickConnect - uu2 <- partSubscribe j joystickDisconnect - uu3 <- partSubscribe j emitJoyActionMessage - uu4 <- partSubscribe k emitKbdActionMessage - uu5 <- partSubscribe t handleActionMessages - uu6 <- partSubscribe m handleClicks + uu1 <- partSubscribe j (joystickConnect ud) + uu2 <- partSubscribe j (joystickDisconnect ud) + uu3 <- partSubscribe j (emitJoyActionMessage ud) + uu4 <- partSubscribe k (emitKbdActionMessage ud) + uu5 <- partSubscribe t (handleActionMessages ud) + uu6 <- partSubscribe m (handleClicks ud) -- uu6 <- partSubscribe k emitKbdActionMessage - partUnSubscribe j (joyUUID ud) - putAffection ud - { uuid = [ uu1, uu2, uu3, uu4, uu5, uu6 ] - , state = Menu Connect - , stateData = MenuData (V2 0 0) S 0 0 - , joyCache = [] - } - mapM_ (partEmit j) (joyCache ud) + juuid <- liftIO $ readMVar (joyUUID ud) + partUnSubscribe j juuid + cache <- liftIO $ readMVar (joyCache ud) + void $ liftIO $ swapMVar (uuid ud) [ uu1, uu2, uu3, uu4, uu5, uu6 ] + void $ liftIO $ swapMVar (state ud) (Menu Connect) + void $ liftIO $ swapMVar (stateData ud) (MenuData (V2 0 0) S 0 0) + void $ liftIO $ swapMVar (joyCache ud) [] + mapM_ (partEmit j) cache -joystickConnect :: JoystickMessage -> Affection UserData () -joystickConnect msg = do - ud <- getAffection - when (controls ud == NoController) $ do +joystickConnect :: UserData -> JoystickMessage -> Affection () +joystickConnect ud msg = do + ctrls <- liftIO $ readMVar (controls ud) + when (ctrls == NoController) $ do mjoy <- joystickAutoConnect msg maybe (return ()) (\joy -> do ident <- liftIO $ fromIntegral <$> SDL.getJoystickID joy - liftIO $ logIO A.Debug $ "Joystick connected: " <> fromString (show ident) - putAffection ud - { controls = Joystick joy - , translation = JoyTranslation defaultJoyTranslation - } + liftIO $ logIO A.Debug $ "Joystick connected: " <> fromString (show (ident :: Int)) + void $ liftIO $ swapMVar (controls ud) (Joystick joy) + void $ liftIO $ swapMVar (translation ud) (JoyTranslation defaultJoyTranslation) ) mjoy -joystickDisconnect :: JoystickMessage -> Affection UserData () -joystickDisconnect msg = do - ud <- getAffection - case controls ud of +joystickDisconnect :: UserData -> JoystickMessage -> Affection () +joystickDisconnect ud msg = do + ctrls <- liftIO $ readMVar (controls ud) + case ctrls of Joystick joy -> do njoys <- joystickAutoDisconnect [joy] msg when (null njoys) $ do liftIO $ logIO A.Debug $ "Joystick disconnected" - putAffection ud - { controls = NoController - , translation = NoTranslation - } + void $ liftIO $ swapMVar (controls ud) NoController + void $ liftIO $ swapMVar (translation ud) NoTranslation _ -> return () -handleActionMessages :: ActionMessage -> Affection UserData () -handleActionMessages (ActionMessage ActActivate _) = do - ud <- getAffection - putAffection ud - { stateData = (stateData ud) - { activate = 0.5 - } +handleActionMessages :: UserData -> ActionMessage -> Affection () +handleActionMessages ud (ActionMessage ActActivate _) = do + liftIO $ modifyMVar_ (stateData ud) (\dat -> return dat + { activate = 0.5 } -handleActionMessages (ActionMessage ActSwitchMap _) = do - ud <- getAffection - putAffection ud - { stateData = (stateData ud) - { switchMap = 0.5 - } + ) +handleActionMessages ud (ActionMessage ActSwitchMap _) = do + liftIO $ modifyMVar_ (stateData ud) (\dat -> return dat + { switchMap = 0.5 } -handleActionMessages (ActionMessage (ActUp f) _) = do - ud <- getAffection - let V2 vx _ = velocity $ stateData ud - putAffection ud - { stateData = (stateData ud) + ) +handleActionMessages ud (ActionMessage (ActUp f) _) = do + liftIO $ modifyMVar_ (stateData ud) (\dat -> + let V2 vx _ = velocity dat + in return dat { velocity = (V2 vx (-f)) } - } -handleActionMessages (ActionMessage (ActDown f) _) = do - ud <- getAffection - let V2 vx _ = velocity $ stateData ud - putAffection ud - { stateData = (stateData ud) + ) +handleActionMessages ud (ActionMessage (ActDown f) _) = do + liftIO $ modifyMVar_ (stateData ud) (\dat -> + let V2 vx _ = velocity dat + in return dat { velocity = (V2 vx f) } - } -handleActionMessages (ActionMessage (ActLeft f) _) = do - ud <- getAffection - let V2 _ vy = velocity $ stateData ud - putAffection ud - { stateData = (stateData ud) + ) +handleActionMessages ud (ActionMessage (ActLeft f) _) = do + liftIO $ modifyMVar_ (stateData ud) (\dat -> + let V2 _ vy = velocity dat + in return dat { velocity = (V2 (-f) vy) } - } -handleActionMessages (ActionMessage (ActRight f) _) = do - ud <- getAffection - let V2 _ vy = velocity $ stateData ud - putAffection ud - { stateData = (stateData ud) + ) +handleActionMessages ud (ActionMessage (ActRight f) _) = do + liftIO $ modifyMVar_ (stateData ud) (\dat -> + let V2 _ vy = velocity dat + in return dat { velocity = (V2 f vy) } - } + ) -handleClicks :: MouseMessage -> Affection UserData () -handleClicks (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft 1 pos@(V2 px py)) = do - ud <- getAffection - rels@(V2 rx ry) <- liftIO $ fmap ((/ 2) . (+ 1)) <$> (relativizeMouseCoords pos) - case controls ud of +handleClicks :: UserData -> MouseMessage -> Affection () +handleClicks ud (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft 1 cpos) = do + rels <- liftIO $ fmap ((/ 2) . (+ 1)) <$> (relativizeMouseCoords cpos) + ctrls <- liftIO $ readMVar (controls ud) + case ctrls of Joystick _ -> do when (arrowUp rels) adjustKbdUp when (arrowDown rels) adjustKbdDown @@ -133,40 +120,36 @@ handleClicks (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft 1 pos@(V2 px py)) when (buttonSwitchMap rels) adjustKbdSwitchMap when (buttonPlay rels) enterGame NoController -> do - when (kbdIcon rels) $ - putAffection ud - { controls = Keyboard - , translation = KbdTranslation defaultKbdTranslation - } + when (kbdIcon rels) $ do + void $ liftIO $ swapMVar (controls ud) Keyboard + void $ liftIO $ swapMVar (translation ud) (KbdTranslation defaultKbdTranslation) Keyboard -> do - when (kbdIcon rels) $ - putAffection ud - { controls = NoController - , translation = NoTranslation - } + when (kbdIcon rels) $ do + void $ liftIO $ swapMVar (controls ud) NoController + void $ liftIO $ swapMVar (translation ud) NoTranslation when (buttonPlay rels) enterGame where adjustKbdUp = do - fullClean - loadAdjust (ActUp 1) Keyboard loadMenu + fullClean ud + loadAdjust ud (ActUp 1) Keyboard (loadMenu ud) adjustKbdDown = do - fullClean - loadAdjust (ActDown 1) Keyboard loadMenu + fullClean ud + loadAdjust ud (ActDown 1) Keyboard (loadMenu ud) adjustKbdLeft = do - fullClean - loadAdjust (ActLeft 1) Keyboard loadMenu + fullClean ud + loadAdjust ud (ActLeft 1) Keyboard (loadMenu ud) adjustKbdRight = do - fullClean - loadAdjust (ActRight 1) Keyboard loadMenu + fullClean ud + loadAdjust ud (ActRight 1) Keyboard (loadMenu ud) adjustKbdActivate = do - fullClean - loadAdjust ActActivate Keyboard loadMenu + fullClean ud + loadAdjust ud ActActivate Keyboard (loadMenu ud) adjustKbdSwitchMap = do - fullClean - loadAdjust ActSwitchMap Keyboard loadMenu + fullClean ud + loadAdjust ud ActSwitchMap Keyboard (loadMenu ud) enterGame = do - fullClean - loadMap + fullClean ud + loadMap ud arrowUp (V2 rx ry) = rx > 310 / 1280 && rx < 410 / 1280 && ry > 190 / 720 && ry < 290 / 720 arrowDown (V2 rx ry) = @@ -183,33 +166,35 @@ handleClicks (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft 1 pos@(V2 px py)) rx > 650 / 1280 && rx < 800 / 1280 && ry > 560 / 720 && ry < 610 / 720 kbdIcon (V2 rx ry) = rx > 650 / 1280 && rx < 730 / 1280 && ry > 620 / 720 && ry < 700 / 720 -handleClicks _ = return () +handleClicks _ _ = return () -updateMenu :: Double -> Affection UserData () -updateMenu dt = do - ud <- getAffection - case stateData ud of +updateMenu :: UserData -> Double -> Affection () +updateMenu ud dt = do + sData <- liftIO $ readMVar (stateData ud) + case sData of MenuData _ _ _ _ -> - putAffection ud - { stateData = MenuData - (velocity $ stateData ud) - (rotation $ stateData ud) - (max 0 ((activate $ stateData ud) - dt)) - (max 0 ((switchMap $ stateData ud) - dt)) - } + void $ liftIO $ swapMVar (stateData ud) ( + MenuData + (velocity sData) + (rotation sData) + (max 0 ((activate sData) - dt)) + (max 0 ((switchMap sData) - dt)) + ) _ -> return () -drawMenu :: Affection UserData () -drawMenu = do - ud <- getAffection - case stateData ud of +drawMenu :: UserData -> Affection () +drawMenu ud = do + sData <- liftIO $ readMVar (stateData ud) + curState <- liftIO $ readMVar (state ud) + aIcons <- liftIO $ readMVar (assetIcons ud) + case sData of MenuData _ _ _ _ -> liftIO $ do let ctx = nano ud - controller = controls ud + controller <- readMVar (controls ud) save ctx beginPath ctx - cpaint <- imagePattern ctx 550 620 80 80 0 (assetIcons ud M.! + cpaint <- imagePattern ctx 550 620 80 80 0 (aIcons M.! case controller of Joystick _ -> IconContrGreen _ -> IconContrBlue @@ -219,17 +204,17 @@ drawMenu = do closePath ctx fill ctx beginPath ctx - cpaint <- imagePattern ctx 650 620 80 80 0 (assetIcons ud M.! + cpaint2 <- imagePattern ctx 650 620 80 80 0 (aIcons M.! case controller of Keyboard -> IconKbdGreen _ -> IconKbdBlue ) 1 rect ctx 650 620 80 80 - fillPaint ctx cpaint + fillPaint ctx cpaint2 closePath ctx fill ctx when (controller /= NoController) $ do - let V2 vx vy = velocity $ stateData ud + let V2 vx vy = velocity sData beginPath ctx roundedRect ctx 140 110 1000 500 25 strokeWidth ctx 5 @@ -240,7 +225,7 @@ drawMenu = do mapM_ (\deg -> do let V2 px py = fmap realToFrac $ V2 360 360 - V2 50 50 + fmap realToFrac rot - rot@(V2 rx ry) = fmap (fromIntegral . floor) $ + rot = fmap (fromIntegral . floor) $ V2 0 120 `rotVec` deg :: V2 Int save ctx translate ctx (px + 50) (py + 50) @@ -254,7 +239,7 @@ drawMenu = do roundedRect ctx 0 0 100 100 10 closePath ctx fill ctx - case state ud of + case curState of Menu (Adjust (ActUp _) _) -> do beginPath ctx fillColor ctx (rgb 0 255 0) @@ -276,7 +261,7 @@ drawMenu = do roundedRect ctx 0 0 100 100 10 closePath ctx fill ctx - case state ud of + case curState of Menu (Adjust (ActLeft _) _) -> do beginPath ctx fillColor ctx (rgb 0 255 0) @@ -298,7 +283,7 @@ drawMenu = do roundedRect ctx 0 0 100 100 10 closePath ctx fill ctx - case state ud of + case curState of Menu (Adjust (ActUp _) _) -> do beginPath ctx fillColor ctx (rgb 0 255 0) @@ -320,7 +305,7 @@ drawMenu = do roundedRect ctx 0 0 100 100 10 closePath ctx fill ctx - case state ud of + case curState of Menu (Adjust (ActLeft _) _) -> do beginPath ctx fillColor ctx (rgb 0 255 0) @@ -336,20 +321,20 @@ drawMenu = do _ -> return () beginPath ctx - apaint <- imagePattern ctx 0 0 100 100 0 (assetIcons ud M.! IconArrow) 1 + apaint <- imagePattern ctx 0 0 100 100 0 (aIcons M.! IconArrow) 1 rect ctx 0 0 100 100 fillPaint ctx apaint closePath ctx fill ctx restore ctx ) [0, 90, 180, 270] - when (activate (stateData ud) > 0) $ do + when (activate sData > 0) $ do beginPath ctx fillColor ctx (rgb 255 128 0) roundedRect ctx 650 160 150 50 10 fill ctx closePath ctx - case state ud of + case curState of Menu (Adjust ActActivate _) -> do beginPath ctx fillColor ctx (rgb 0 255 0) @@ -368,13 +353,13 @@ drawMenu = do fillColor ctx (rgb 255 255 255) textBox ctx 650 175 150 "Activate" closePath ctx - when (switchMap (stateData ud) > 0) $ do + when (switchMap sData > 0) $ do beginPath ctx fillColor ctx (rgb 255 128 0) roundedRect ctx 650 220 150 50 10 fill ctx closePath ctx - case state ud of + case curState of Menu (Adjust ActSwitchMap _) -> do beginPath ctx fillColor ctx (rgb 0 255 0) diff --git a/src/Navigation.hs b/src/Navigation.hs index f6aaec5..c43aeba 100644 --- a/src/Navigation.hs +++ b/src/Navigation.hs @@ -3,7 +3,7 @@ module Navigation where import Affection as A import Data.Matrix as M -import Data.Maybe (isJust, catMaybes) +import Data.Maybe (isJust) -- internal imports diff --git a/src/StateMachine.hs b/src/StateMachine.hs index af27a93..0964b3f 100644 --- a/src/StateMachine.hs +++ b/src/StateMachine.hs @@ -13,26 +13,26 @@ import MainGame.WorldMap import MainGame.MindMap import Util -instance StateMachine State UserData where +instance StateMachine UserData State where smLoad Load = loadLoad smLoad (Menu Connect) = loadMenu - smLoad (Menu (Adjust a c)) = loadAdjust a c loadMenu + smLoad (Menu (Adjust a c)) = (\ud -> loadAdjust ud a c (loadMenu ud)) smLoad (Main _) = loadMap smUpdate Load = updateLoad smUpdate (Menu Connect) = updateMenu - smUpdate (Menu (Adjust _ _)) = const (return ()) + smUpdate (Menu (Adjust _ _)) = const $ const (return ()) smUpdate (Main WorldMap) = updateMap smUpdate (Main MindMap) = updateMind smDraw Load = drawLoad smDraw (Menu Connect) = drawMenu - smDraw (Menu (Adjust _ _)) = drawMenu >> drawAdjust + smDraw (Menu (Adjust _ _)) = (\ud -> drawMenu ud >> drawAdjust (nano ud)) smDraw (Main WorldMap) = drawMap smDraw (Main MindMap) = drawMind - smEvent _ evs = do - Subsystems w m k j _ <- subsystems <$> getAffection + smEvent _ ud evs = do + let Subsystems w m k j _ = subsystems ud _ <- consumeSDLEvents j =<< consumeSDLEvents k =<< consumeSDLEvents w =<< diff --git a/src/Types/UserData.hs b/src/Types/UserData.hs index dcbb6d5..14b18f5 100644 --- a/src/Types/UserData.hs +++ b/src/Types/UserData.hs @@ -45,6 +45,7 @@ data UserData = UserData , window :: MVar (Maybe SDL.Window) , joyCache :: MVar [JoystickMessage] , joyUUID :: MVar UUID + , doNextStep :: MVar Bool } data Controller