finish porting process

shell.nix

@@ -26,25 +26,25 @@ let
     }) {};
 
   algebraic-graphs = with haskellPackages; callPackage(
-    { mkDerivation, array, base, base-compat, base-orphans, containers
+    { mkDerivation, array, base, containers, deepseq, extra
-    , deepseq, extra, inspection-testing, mtl, QuickCheck, stdenv
+    , inspection-testing, mtl, QuickCheck, stdenv, transformers
     }:
     mkDerivation {
       pname = "algebraic-graphs";
-      version = "0.4";
+      version = "0.5";
-      sha256 = "c905d32a6178a11e3c8096dbbf3bd19e570e87362c51fdc8653b43a51e46d3b7";
+      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
+        array base containers deepseq extra inspection-testing mtl
-        inspection-testing QuickCheck
+        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

src/Init.hs

@@ -38,24 +38,25 @@ init = do
   _ <- glewInit
   nvg <- createGL3 (S.fromList [NanoVG.Debug, Antialias, StencilStrokes])
   UserData
-    <$> newMVar Load
+    <$> newMVar Load            -- state
-    <*> pure subs
+    <*> pure subs               -- subsystems
-    <*> newMVar M.empty
+    <*> newMVar M.empty         -- assetIcons
-    <*> newMVar M.empty
+    <*> newMVar M.empty         -- assetImages
-    <*> newMVar M.empty
+    <*> newMVar M.empty         -- assetFonts
-    <*> newMVar M.empty
+    <*> newMVar M.empty         -- assetAnimations
-    <*> newMVar NoController
+    <*> newMVar NoController    -- controls
-    <*> newMVar NoTranslation
+    <*> newMVar NoTranslation   -- translation
-    <*> pure nvg
+    <*> pure nvg                -- nano
-    <*> newMVar []
+    <*> newMVar []              -- uuid
-    <*> newEmptyMVar
+    <*> newEmptyMVar            -- worldState           <-
-    <*> newMVar None
+    <*> newMVar None            -- stateData
-    <*> newEmptyMVar
+    <*> newEmptyMVar            -- stateMVar            <-
-    <*> newMVar (0, "foobar!")
+    <*> newEmptyMVar            -- stateProgress        <-
-    <*> newMVar Nothing
+    <*> newMVar Nothing         -- threadContext
-    <*> newMVar Nothing
+    <*> newMVar Nothing         -- window
-    <*> newMVar []
+    <*> newMVar []              -- joyCache
-    <*> newEmptyMVar
+    <*> newEmptyMVar            -- joyUUID              <-
+    <*> newMVar True            -- doNextStep
 
 loadPlayerSprite
   :: FilePath         -- Path to spritemap

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

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 $ putMVar (stateProgress ud) progress
-  void $ liftIO $ tryReadMVar (stateMVar ud)
   _ <- 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

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
+        } :: AffectionConfig UserData
-        , preLoop        = pre >> smLoad Load
-        , eventLoop      = handle
-        , updateLoop     = update
-        , drawLoop       = draw
-        , loadState      = Init.init
-        , cleanUp        = clean
-        , initScreenMode = SDL.Windowed
-        }
   withAffection config
 
-pre :: Affection UserData ()
+pre :: UserData -> Affection ()
-pre = do
+pre ud = do
   ad <- A.get
-  ud <- getAffection
+  threadCtx <- SDL.glCreateContext ((\(_, y, _) -> y) $ head $ drawWindows ad)
-  threadCtx <- SDL.glCreateContext (snd $ head $ drawWindows ad)
+  SDL.glMakeCurrent ((\(_, y, _) -> y) $ head $ drawWindows ad) (snd $ head $ glContext ad)
-  SDL.glMakeCurrent (snd $ head $ drawWindows ad) (snd $ head $ glContext ad)
+  let Subsystems w _ k j _ = subsystems ud
-  let Subsystems w m k j t = subsystems ud
   _ <- partSubscribe w (fitViewport (1280/720))
-  _ <- partSubscribe w exitOnWindowClose
+  _ <- partSubscribe w (exitOnWindowClose ud)
   _ <- partSubscribe k toggleFullScreen
-  _ <- partSubscribe k quitGame
+  _ <- partSubscribe k (quitGame ud)
-  u <- partSubscribe j cacheJoypad
+  u <- partSubscribe j (cacheJoypad ud)
   (ws, _) <- yieldSystemT (0, defStorage) (return ())
-  putAffection ud
+  void $ liftIO $ swapMVar (threadContext ud) (Just threadCtx)
-    { threadContext = Just threadCtx
+  void $ liftIO $ swapMVar (window ud) (Just $ (\(_, y, _) -> y) $ head $ drawWindows ad)
-    , window     = Just (snd $ head $ drawWindows ad)
+  void $ liftIO $ putMVar (worldState ud) ws
-    , worldState = ws
+  void $ liftIO $ putMVar (joyUUID ud) u
-    , joyUUID    = u
-    }
 
-quitGame :: KeyboardMessage -> Affection UserData ()
+quitGame :: UserData -> KeyboardMessage -> Affection ()
-quitGame (MsgKeyboardEvent _ _ SDL.Pressed False sym)
+quitGame ud (MsgKeyboardEvent _ _ SDL.Pressed False sym)
-  | SDL.keysymKeycode sym == SDL.KeycodeEscape = quit
+  | SDL.keysymKeycode sym == SDL.KeycodeEscape =
+    void $ liftIO $ swapMVar (doNextStep ud) False
   | SDL.keysymKeycode sym == SDL.KeycodeF5 = do
     ad <- A.get
-    ud <- getAffection
+    curState <- liftIO $ readMVar (state ud)
-    when (state ud == Main WorldMap || state ud == Main MindMap) $ do
+    when (curState == Main WorldMap || curState == Main MindMap) $ do
       let Subsystems w m k j t = subsystems ud
-      mapM_ (partUnSubscribe w) (uuid ud)
+      curUUID <- liftIO $ readMVar (uuid ud)
-      mapM_ (partUnSubscribe m) (uuid ud)
+      mapM_ (partUnSubscribe w) curUUID
-      mapM_ (partUnSubscribe k) (uuid ud)
+      mapM_ (partUnSubscribe m) curUUID
-      mapM_ (partUnSubscribe j) (uuid ud)
+      mapM_ (partUnSubscribe k) curUUID
-      mapM_ (partUnSubscribe t) (uuid ud)
+      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
+      void $ liftIO $ swapMVar (worldState ud) ws
-        { worldState = ws
+      void $ liftIO $ swapMVar (state ud) Load
-        , state = Load
+      smLoad Load ud
-        }
-      smLoad Load
   | otherwise = return ()
-quitGame _ = 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 :: UserData -> Double -> Affection ()
-update dt = do
+update ud dt = do
-  ud <- getAffection
+  curState <- liftIO $ readMVar (state ud)
-  smUpdate (state ud) dt
+  smUpdate curState ud dt
 
-draw :: Affection UserData ()
+draw :: UserData -> Affection ()
-draw = do
+draw ud = do
-  ud <- getAffection
+  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 :: UserData -> [SDL.EventPayload] -> Affection ()
-handle evs = do
+handle ud evs = do
-  s <- state <$> getAffection
+  s <- liftIO $ readMVar (state ud)
-  smEvent s evs
+  smEvent s ud evs
 
-exitOnWindowClose :: WindowMessage -> Affection UserData ()
+exitOnWindowClose :: UserData -> WindowMessage -> Affection ()
-exitOnWindowClose (MsgWindowClose _ _) = do
+exitOnWindowClose ud (MsgWindowClose _ _) = do
   liftIO $ logIO A.Debug "Window Closed"
-  quit
+  void $ liftIO $ swapMVar (doNextStep ud) False
-exitOnWindowClose _ = return ()
+exitOnWindowClose _ _ = return ()
 
 clean :: UserData -> IO ()
-clean ud =
+clean ud = do
-  SDL.glDeleteContext $ fromJust $ threadContext ud
+  tContext <- readMVar (threadContext ud)
+  SDL.glDeleteContext $ fromJust tContext

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,10 +28,11 @@ import Collision
 
 import Util
 
-updateMind :: Double -> Affection UserData ()
+updateMind :: UserData -> Double -> Affection ()
-updateMind dt = do
+updateMind ud dt = do
- ud <- getAffection
+  wState <- liftIO $ readMVar (worldState ud)
- (nws, _) <- yieldSystemT (worldState ud) $ do
+  sData <- liftIO $ readMVar (stateData ud)
+  (nws, _) <- yieldSystemT wState $ do
     emap allEnts $ do
       with player
       with xyvel
@@ -44,7 +48,8 @@ updateMind dt = do
       with anim
       with mmpos
       stat <- query anim
-     let an = assetAnimations ud Map.! asId stat
+      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))
@@ -139,7 +144,7 @@ updateMind dt = do
                 let bs = fromMaybe [] $ collisionObstacle <$> M.unsafeGet
                       (fromIntegral $ floor pr + dr)
                       (fromIntegral $ floor pc + dc)
-                     (mmImgMat (stateData ud))
+                      (mmImgMat sData)
                 in  Prelude.map (\(Boundaries (minr, minc) (maxr, maxc))->
                       Boundaries
                         (minr + fromIntegral dr, minc + fromIntegral dc)
@@ -154,16 +159,15 @@ updateMind dt = do
             , anim = Set nstat
             }
       return ent
- putAffection ud
+  void $ liftIO $ swapMVar (worldState ud) nws
-   { worldState = nws
-   }
 
-drawMind :: Affection UserData ()
+drawMind :: UserData -> Affection ()
-drawMind = do
+drawMind ud = do
-  ud <- getAffection
+  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)
+        (nrows $ mmImgMat $ sData)
-        (ncols $ mmImgMat $ stateData ud)
+        (ncols $ mmImgMat $ sData)
         ((reverse . fst)
           (Prelude.foldl
             (\(done, proc) coord ->
@@ -195,8 +199,8 @@ drawMind = do
               )
             ([], posanims)
             ((,)
-              <$> [1 .. (nrows $ mmImgMat $ stateData ud)]
+              <$> [1 .. (nrows $ mmImgMat $ sData)]
-              <*> [1 .. (ncols $ mmImgMat $ stateData ud)]
+              <*> [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)))

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 :: UserData -> Affection ()
-loadMap = do
+loadMap ud = do
-  ud <- getAffection
   ad <- get
   let (Subsystems _ _ k j t) = subsystems ud
-  uu0 <- partSubscribe k emitKbdActionMessage
+  uu0 <- partSubscribe k (emitKbdActionMessage ud)
-  uu1 <- partSubscribe j emitJoyActionMessage
+  uu1 <- partSubscribe j (emitJoyActionMessage ud)
-  uu2 <- partSubscribe t movePlayer2
+  uu2 <- partSubscribe t (movePlayer2 ud)
-  uu3 <- partSubscribe t playerInteract2
+  uu3 <- partSubscribe t (playerInteract2 ud)
-  uu4 <- partSubscribe t changeMaps2
+  uu4 <- partSubscribe t (changeMaps2 ud)
-  future <- liftIO newEmptyMVar
+  void $ liftIO $ swapMVar (stateProgress ud) (0, "Ohai!")
-  progress <- liftIO $ newMVar (0, "Ohai!")
+  _ <- liftIO $ forkIO $ loadMapFork ud ad (stateMVar ud) (stateProgress ud)
-  _ <- liftIO $ forkIO $ loadMapFork ud ad future progress
+  void $ liftIO $ swapMVar (stateData ud) None
-  putAffection ud
+  void $ liftIO $ swapMVar (uuid ud) [ uu0, uu1, uu2, uu3, uu4 ]
-    { stateData = None
+  void $ liftIO $ swapMVar (state ud) (Main WorldMap)
-    , uuid = [ uu0, uu1, uu2, uu3, uu4 ]
-    , stateMVar = future
-    , stateProgress = progress
-    , state = Main WorldMap
-    }
 
-changeMaps :: KeyboardMessage -> Affection UserData ()
+changeMaps :: UserData -> KeyboardMessage -> Affection ()
-changeMaps (MsgKeyboardEvent _ _ SDL.Pressed False sym)
+changeMaps ud (MsgKeyboardEvent _ _ SDL.Pressed False sym)
   | SDL.keysymKeycode sym == SDL.KeycodeF1 = do
-  ud <- getAffection
+  curState <- liftIO $ readMVar (state ud)
-  case state ud of
+  case curState of
     Main MindMap ->
-      putAffection ud
+      void $ liftIO $ swapMVar (state ud) (Main WorldMap)
-        { state = Main WorldMap
-        }
     Main WorldMap ->
-      putAffection ud
+      void $ liftIO $ swapMVar (state ud) (Main MindMap)
-        { state = Main MindMap
-        }
     _ -> return ()
   | otherwise = return ()
-changeMaps _ = return ()
+changeMaps _ _ = return ()
 
-changeMaps2 :: ActionMessage -> Affection UserData ()
+changeMaps2 :: UserData -> ActionMessage -> Affection ()
-changeMaps2 (ActionMessage ActSwitchMap _) = do
+changeMaps2 ud (ActionMessage ActSwitchMap _) = do
-  ud <- getAffection
+  curState <- liftIO $ readMVar (state ud)
-  case state ud of
+  case curState of
     Main MindMap ->
-      putAffection ud
+      void $ liftIO $ swapMVar (state ud) (Main WorldMap)
-        { state = Main WorldMap
-        }
     Main WorldMap ->
-      putAffection ud
+      void $ liftIO $ swapMVar (state ud) (Main MindMap)
-        { state = Main MindMap
-        }
     _ -> return ()
-changeMaps2 _ = return ()
+changeMaps2 _ _ = return ()
 
 loadMapFork
   :: UserData
-  -> AffectionData UserData
+  -> AffectionData
-  -> MVar (SystemState Entity (AffectionState (AffectionData UserData) IO), StateData)
+  -> 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 :: UserData -> KeyboardMessage -> Affection ()
-movePlayerKbd (MsgKeyboardEvent _ _ press False sym)
+movePlayerKbd ud (MsgKeyboardEvent _ _ press False sym)
   | SDL.keysymKeycode sym == SDL.KeycodeW = do
-    ud <- getAffection
+    wState <- liftIO $ readMVar (worldState ud)
-    (nws, _) <- yieldSystemT (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
+    void $ liftIO $ swapMVar (worldState ud) nws
-      { worldState = nws
-      }
   | SDL.keysymKeycode sym == SDL.KeycodeS = do
-    ud <- getAffection
+    wState <- liftIO $ readMVar (worldState ud)
-    (nws, _) <- yieldSystemT (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
+    void $ liftIO $ swapMVar (worldState ud) nws
-      { worldState = nws
-      }
   | SDL.keysymKeycode sym == SDL.KeycodeA = do
-    ud <- getAffection
+    wState <- liftIO $ readMVar (worldState ud)
-    (nws, _) <- yieldSystemT (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
+    void $ liftIO $ swapMVar (worldState ud) nws
-      { worldState = nws
-      }
   | SDL.keysymKeycode sym == SDL.KeycodeD = do
-    ud <- getAffection
+    wState <- liftIO $ readMVar (worldState ud)
-    (nws, _) <- yieldSystemT (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
+    void $ liftIO $ swapMVar (worldState ud) nws
-      { worldState = nws
-      }
   | otherwise = return ()
-movePlayerKbd _ = return ()
+movePlayerKbd _ _ = return ()
 
-movePlayer2 :: ActionMessage -> Affection UserData ()
+movePlayer2 :: UserData -> ActionMessage -> Affection ()
-movePlayer2 (ActionMessage mov _) = do
+movePlayer2 ud (ActionMessage mov _) = do
-  ud <- getAffection
+  wState <- liftIO $ readMVar (worldState ud)
-  (nws, _) <- yieldSystemT (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
+  void $ liftIO $ swapMVar (worldState ud) nws
-    { worldState = nws
-    }
 
-playerInteract2 :: ActionMessage -> Affection UserData ()
+playerInteract2 :: UserData -> ActionMessage -> Affection ()
-playerInteract2 (ActionMessage ActActivate _) = do
+playerInteract2 ud (ActionMessage ActActivate _) = do
-  ud <- getAffection
+  wState <- liftIO $ readMVar (worldState ud)
-  (nws, _) <- yieldSystemT (worldState ud) $ do
+  (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
+  void $ liftIO $ swapMVar (worldState ud) nws
-    { worldState = nws
+playerInteract2 _ _ = return ()
-    }
-playerInteract2 _ = return ()
 
-drawMap :: Affection UserData ()
+drawMap :: UserData -> Affection ()
-drawMap = do
+drawMap ud = do
-  ud <- getAffection
+  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)
+            (nrows $ mapMat sData)
-            (ncols $ mapMat $ stateData ud)
+            (ncols $ mapMat sData)
             ((reverse . fst)
               (Prelude.foldl
                 (\(done, proc) coord ->
@@ -555,8 +530,8 @@ drawMap = do
                   )
                 ([], posanims)
                 ((,)
-                  <$> [1 .. (nrows $ mapMat $ stateData ud)]
+                  <$> [1 .. (nrows $ mapMat sData)]
-                  <*> [1 .. (ncols $ mapMat $ stateData ud)]
+                  <*> [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,14 +632,14 @@ drawTile
   -> Int
   -> Maybe ImgId
   -> IO ()
-drawTile ud ctx posanims pr pc row col img =
+drawTile ud ctx posanims pr pc row col img = do
-  do
   let (bef, beh) = L.partition delimiter sorted
+  aImages <- readMVar (assetImages ud)
   save ctx
   mapM_ (flip drawAnim fact) beh
-    maybe (return ()) (draw ud x (y - 42) 64 74
+  maybe (return ()) (Types.draw ud x (y - 42) 64 74
     (if fromMaybe False (isWall <$> img) then fact else 1))
-      ((assetImages ud Map.!) <$> case img of
+    ((aImages Map.!) <$> case img of
       Just ImgEmpty -> Nothing
       _ -> img
       )
@@ -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 :: UserData -> Double -> Affection ()
-updateMap dt = do
+updateMap ud dt = do
-  ud <- getAffection
+  osData <- liftIO $ readMVar (stateData ud)
-  if stateData ud == None
+  if osData == None
   then do
     mstart <- liftIO $ tryTakeMVar (stateMVar ud)
     case mstart of
       Just (nws, mendat) -> do
-        putAffection ud
+        void $ liftIO $ swapMVar (worldState ud) nws
-          { worldState = nws
+        void $ liftIO $ swapMVar (stateData ud) mendat
-          , stateData = mendat
+        void $ liftIO $ swapMVar (state ud) (Main WorldMap)
-          , state = Main WorldMap
+        updateMap ud 0.1
-          }
+        updateMap ud 0.1
-        updateMap 0.1
+        updateMap ud 0.1
-        updateMap 0.1
+        updateMap ud 19
-        updateMap 0.1
-        updateMap 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
+        let an = aAnim Map.! asId stat
-            mat = mapMat (stateData ud)
+            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)
+      (imgMat sData)
-      (mapMat $ stateData ud)
+      (mapMat sData)
       nws
       (V.filter
         (\p -> pointType p /= RoomExit)
-        (reachPoints $ stateData ud)
+        (reachPoints sData)
         )
       dt
-    putAffection ud
+    void $ liftIO $ swapMVar (worldState ud) nws2
-      { worldState = nws2
-      }

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 :: UserData -> Affection ()
-loadMenu = do
+loadMenu ud = do
-  ud <- getAffection
-  ad <- get
   let (Subsystems _ m k j t) = subsystems ud
-  uu1 <- partSubscribe j joystickConnect
+  uu1 <- partSubscribe j (joystickConnect ud)
-  uu2 <- partSubscribe j joystickDisconnect
+  uu2 <- partSubscribe j (joystickDisconnect ud)
-  uu3 <- partSubscribe j emitJoyActionMessage
+  uu3 <- partSubscribe j (emitJoyActionMessage ud)
-  uu4 <- partSubscribe k emitKbdActionMessage
+  uu4 <- partSubscribe k (emitKbdActionMessage ud)
-  uu5 <- partSubscribe t handleActionMessages
+  uu5 <- partSubscribe t (handleActionMessages ud)
-  uu6 <- partSubscribe m handleClicks
+  uu6 <- partSubscribe m (handleClicks ud)
   -- uu6 <- partSubscribe k emitKbdActionMessage
-  partUnSubscribe j (joyUUID ud)
+  juuid <- liftIO $ readMVar (joyUUID ud)
-  putAffection ud
+  partUnSubscribe j juuid
-    { uuid      = [ uu1, uu2, uu3, uu4, uu5, uu6 ]
+  cache <- liftIO $ readMVar (joyCache ud)
-    , state     = Menu Connect
+  void $ liftIO $ swapMVar (uuid ud) [ uu1, uu2, uu3, uu4, uu5, uu6 ]
-    , stateData = MenuData (V2 0 0) S 0 0
+  void $ liftIO $ swapMVar (state ud) (Menu Connect)
-    , joyCache  = []
+  void $ liftIO $ swapMVar (stateData ud) (MenuData (V2 0 0) S 0 0)
-    }
+  void $ liftIO $ swapMVar (joyCache ud) []
-  mapM_ (partEmit j) (joyCache ud)
+  mapM_ (partEmit j) cache
 
-joystickConnect :: JoystickMessage -> Affection UserData ()
+joystickConnect :: UserData -> JoystickMessage -> Affection ()
-joystickConnect msg = do
+joystickConnect ud msg = do
-  ud <- getAffection
+  ctrls <- liftIO $ readMVar (controls ud)
-  when (controls ud == NoController) $ do
+  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)
+      liftIO $ logIO A.Debug $ "Joystick connected: " <> fromString (show (ident :: Int))
-      putAffection ud
+      void $ liftIO $ swapMVar (controls ud) (Joystick joy)
-        { controls = Joystick joy
+      void $ liftIO $ swapMVar (translation ud) (JoyTranslation defaultJoyTranslation)
-        , translation = JoyTranslation defaultJoyTranslation
-        }
       ) mjoy
 
-joystickDisconnect :: JoystickMessage -> Affection UserData ()
+joystickDisconnect :: UserData -> JoystickMessage -> Affection ()
-joystickDisconnect msg = do
+joystickDisconnect ud msg = do
-  ud <- getAffection
+  ctrls <- liftIO $ readMVar (controls ud)
-  case controls ud of
+  case ctrls of
     Joystick joy -> do
       njoys <- joystickAutoDisconnect [joy] msg
       when (null njoys) $ do
         liftIO $ logIO A.Debug $ "Joystick disconnected"
-        putAffection ud
+        void $ liftIO $ swapMVar (controls ud) NoController
-          { controls = NoController
+        void $ liftIO $ swapMVar (translation ud) NoTranslation
-          , translation = NoTranslation
-          }
     _ -> return ()
 
-handleActionMessages :: ActionMessage -> Affection UserData ()
+handleActionMessages :: UserData -> ActionMessage -> Affection ()
-handleActionMessages (ActionMessage ActActivate _) = do
+handleActionMessages ud (ActionMessage ActActivate _) = do
-  ud <- getAffection
+  liftIO $ modifyMVar_ (stateData ud) (\dat -> return dat
-  putAffection ud
-    { stateData = (stateData ud)
     { activate = 0.5
     }
-    }
+    )
-handleActionMessages (ActionMessage ActSwitchMap _) = do
+handleActionMessages ud (ActionMessage ActSwitchMap _) = do
-  ud <- getAffection
+  liftIO $ modifyMVar_ (stateData ud) (\dat -> return dat
-  putAffection ud
-    { stateData = (stateData ud)
     { switchMap = 0.5
     }
-    }
+    )
-handleActionMessages (ActionMessage (ActUp f) _) = do
+handleActionMessages ud (ActionMessage (ActUp f) _) = do
-  ud <- getAffection
+  liftIO $ modifyMVar_ (stateData ud) (\dat ->
-  let V2 vx _ = velocity $ stateData ud
+    let V2 vx _ = velocity dat
-  putAffection ud
+    in return dat
-    { stateData = (stateData ud)
       { velocity = (V2 vx (-f))
       }
-    }
+    )
-handleActionMessages (ActionMessage (ActDown f) _) = do
+handleActionMessages ud (ActionMessage (ActDown f) _) = do
-  ud <- getAffection
+  liftIO $ modifyMVar_ (stateData ud) (\dat ->
-  let V2 vx _ = velocity $ stateData ud
+    let V2 vx _ = velocity dat
-  putAffection ud
+    in return dat
-    { stateData = (stateData ud)
       { velocity = (V2 vx f)
       }
-    }
+    )
-handleActionMessages (ActionMessage (ActLeft f) _) = do
+handleActionMessages ud (ActionMessage (ActLeft f) _) = do
-  ud <- getAffection
+  liftIO $ modifyMVar_ (stateData ud) (\dat ->
-  let V2 _ vy = velocity $ stateData ud
+    let V2 _ vy = velocity dat
-  putAffection ud
+    in return dat
-    { stateData = (stateData ud)
       { velocity = (V2 (-f) vy)
       }
-    }
+    )
-handleActionMessages (ActionMessage (ActRight f) _) = do
+handleActionMessages ud (ActionMessage (ActRight f) _) = do
-  ud <- getAffection
+  liftIO $ modifyMVar_ (stateData ud) (\dat ->
-  let V2 _ vy = velocity $ stateData ud
+    let V2 _ vy = velocity dat
-  putAffection ud
+    in return dat
-    { stateData = (stateData ud)
       { velocity = (V2 f vy)
       }
-    }
+    )
 
-handleClicks :: MouseMessage -> Affection UserData ()
+handleClicks :: UserData -> MouseMessage -> Affection ()
-handleClicks (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft 1 pos@(V2 px py)) = do
+handleClicks ud (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft 1 cpos) = do
-  ud <- getAffection
+  rels <- liftIO $ fmap ((/ 2) . (+ 1)) <$> (relativizeMouseCoords cpos)
-  rels@(V2 rx ry) <- liftIO $ fmap ((/ 2) . (+ 1)) <$> (relativizeMouseCoords pos)
+  ctrls <- liftIO $ readMVar (controls ud)
-  case controls ud of
+  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) $
+      when (kbdIcon rels) $ do
-        putAffection ud
+        void $ liftIO $ swapMVar (controls ud) Keyboard
-          { controls = Keyboard
+        void $ liftIO $ swapMVar (translation ud) (KbdTranslation defaultKbdTranslation)
-          , translation = KbdTranslation defaultKbdTranslation
-          }
     Keyboard -> do
-      when (kbdIcon rels) $
+      when (kbdIcon rels) $ do
-        putAffection ud
+        void $ liftIO $ swapMVar (controls ud) NoController
-          { controls = NoController
+        void $ liftIO $ swapMVar (translation ud) NoTranslation
-          , translation = NoTranslation
-          }
       when (buttonPlay rels) enterGame
   where
     adjustKbdUp = do
-        fullClean
+        fullClean ud
-        loadAdjust (ActUp 1) Keyboard loadMenu
+        loadAdjust ud (ActUp 1) Keyboard (loadMenu ud)
     adjustKbdDown = do
-        fullClean
+        fullClean ud
-        loadAdjust (ActDown 1) Keyboard loadMenu
+        loadAdjust ud (ActDown 1) Keyboard (loadMenu ud)
     adjustKbdLeft = do
-        fullClean
+        fullClean ud
-        loadAdjust (ActLeft 1) Keyboard loadMenu
+        loadAdjust ud (ActLeft 1) Keyboard (loadMenu ud)
     adjustKbdRight = do
-        fullClean
+        fullClean ud
-        loadAdjust (ActRight 1) Keyboard loadMenu
+        loadAdjust ud (ActRight 1) Keyboard (loadMenu ud)
     adjustKbdActivate = do
-      fullClean
+      fullClean ud
-      loadAdjust ActActivate Keyboard loadMenu
+      loadAdjust ud ActActivate Keyboard (loadMenu ud)
     adjustKbdSwitchMap = do
-      fullClean
+      fullClean ud
-      loadAdjust ActSwitchMap Keyboard loadMenu
+      loadAdjust ud ActSwitchMap Keyboard (loadMenu ud)
     enterGame = do
-      fullClean
+      fullClean ud
-      loadMap
+      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 :: UserData -> Double -> Affection ()
-updateMenu dt = do
+updateMenu ud dt = do
-  ud <- getAffection
+  sData <- liftIO $ readMVar (stateData ud)
-  case stateData ud of
+  case sData of
     MenuData _ _ _ _ ->
-      putAffection ud
+      void $ liftIO $ swapMVar (stateData ud) (
-        { stateData = MenuData
+        MenuData
-          (velocity $ stateData ud)
+          (velocity sData)
-          (rotation $ stateData ud)
+          (rotation sData)
-          (max 0 ((activate $ stateData ud) - dt))
+          (max 0 ((activate sData) - dt))
-          (max 0 ((switchMap $ stateData ud) - dt))
+          (max 0 ((switchMap sData) - dt))
-        }
+        )
     _ -> return ()
 
-drawMenu :: Affection UserData ()
+drawMenu :: UserData -> Affection ()
-drawMenu = do
+drawMenu ud = do
-  ud <- getAffection
+  sData <- liftIO $ readMVar (stateData ud)
-  case stateData ud of
+  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)

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
 

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
+  smEvent _ ud evs = do
-    Subsystems w m k j _ <- subsystems <$> getAffection
+    let Subsystems w m k j _ = subsystems ud
     _ <- consumeSDLEvents j =<<
       consumeSDLEvents k =<<
       consumeSDLEvents w =<<

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