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