fix flake and update

Axe

.envrc

@@ -0,0 +1 @@
+use flake

.gitignore

@@ -8,6 +8,7 @@
 cabal.sandbox.config
 dist/
 dist-newstyle/
+.direnv/
 *.prof
 *.aux
 *.hp
@@ -18,3 +19,4 @@ dist-newstyle/
 *.eventlog
 *.*~
 .*autosave.kra
+result

cabal.config

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

cabal.project

@@ -1,4 +0,0 @@
-packages:
-  ./
-  ../ecstasy/
-profiling: True

flake.lock

@@ -0,0 +1,84 @@
+{
+  "nodes": {
+    "affection-src": {
+      "inputs": {
+        "flake-utils": [
+          "flake-utils"
+        ],
+        "nixpkgs": [
+          "nixpkgs"
+        ]
+      },
+      "locked": {
+        "lastModified": 1700847735,
+        "narHash": "sha256-hSHgLPZwWP7tPoUhH2GLQ4GvHvVGFiXIM0CLps+O5KE=",
+        "ref": "refs/heads/master",
+        "rev": "d0465fa3e1d122503439df7c2de9d16598fc0cf5",
+        "revCount": 306,
+        "type": "git",
+        "url": "https://gitea.nek0.eu/nek0/affection"
+      },
+      "original": {
+        "type": "git",
+        "url": "https://gitea.nek0.eu/nek0/affection"
+      }
+    },
+    "flake-utils": {
+      "inputs": {
+        "systems": "systems"
+      },
+      "locked": {
+        "lastModified": 1694529238,
+        "narHash": "sha256-zsNZZGTGnMOf9YpHKJqMSsa0dXbfmxeoJ7xHlrt+xmY=",
+        "owner": "numtide",
+        "repo": "flake-utils",
+        "rev": "ff7b65b44d01cf9ba6a71320833626af21126384",
+        "type": "github"
+      },
+      "original": {
+        "owner": "numtide",
+        "repo": "flake-utils",
+        "type": "github"
+      }
+    },
+    "nixpkgs": {
+      "locked": {
+        "lastModified": 1700844339,
+        "narHash": "sha256-VRlPYk0eRn1ao75hoA99LGehYhxZH5RlkP1YXpVROHM=",
+        "owner": "NixOS",
+        "repo": "nixpkgs",
+        "rev": "33576fdfce2d11204067d6cfa99a2f990ef2169a",
+        "type": "github"
+      },
+      "original": {
+        "owner": "NixOS",
+        "repo": "nixpkgs",
+        "type": "github"
+      }
+    },
+    "root": {
+      "inputs": {
+        "affection-src": "affection-src",
+        "flake-utils": "flake-utils",
+        "nixpkgs": "nixpkgs"
+      }
+    },
+    "systems": {
+      "locked": {
+        "lastModified": 1681028828,
+        "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=",
+        "owner": "nix-systems",
+        "repo": "default",
+        "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e",
+        "type": "github"
+      },
+      "original": {
+        "owner": "nix-systems",
+        "repo": "default",
+        "type": "github"
+      }
+    }
+  },
+  "root": "root",
+  "version": 7
+}

flake.nix

@@ -0,0 +1,46 @@
+{
+  description = "A game stub written in Haskell";
+
+  inputs = {
+    nixpkgs.url = "github:NixOS/nixpkgs";
+    flake-utils.url = "github:numtide/flake-utils";
+    affection-src = {
+      url = "git+https://gitea.nek0.eu/nek0/affection";
+      inputs = {
+        nixpkgs.follows = "nixpkgs";
+        flake-utils.follows = "flake-utils";
+      };
+    };
+  };
+
+  outputs = { self, nixpkgs, flake-utils, affection-src }:
+    flake-utils.lib.eachDefaultSystem (system:
+      let
+        pkgs = nixpkgs.legacyPackages.${system};
+
+        haskellPackages = pkgs.haskellPackages;
+
+        jailbreakUnbreak = pkg:
+          pkgs.haskell.lib.doJailbreak (pkg.overrideAttrs (_: { meta = { }; }));
+
+        packageName = "tracer-game";
+      in rec {
+        packages.${packageName} = # (ref:haskell-package-def)
+          haskellPackages.callCabal2nix packageName self rec {
+            affection = affection-src.defaultPackage.${system};
+          };
+
+        defaultPackage = self.packages.${system}.${packageName};
+
+        devShell = haskellPackages.shellFor {
+          packages = p: [ defaultPackage ];
+          withHoogle = true;
+          buildInputs = with haskellPackages; [
+            haskell-language-server
+            ghcid
+            cabal-install
+          ] ++ (builtins.attrValues self.packages.${system});
+        };
+      });
+}
+

shell.nix

@@ -1,264 +1,14 @@
-{ nixpkgs ? import <nixpkgs> {}, compiler ? "default", doBenchmark ? false }:
+{ pkgs ? import <nixpkgs> {}}:
 
 let
-
+  # create a modified haskell package set with my package inside it and broken dependencies
-  inherit (nixpkgs) pkgs;
+  # jailbroken.
-
+  hpkgs = pkgs.haskellPackages.override {
-  #provideOldHaskellAttributeNames = true;
+    overrides = hself: hsuper: {
-
+      tracer-game = hself.callCabal2nix "tracer-game" (gitignore ./.) {};
-  glib = with haskellPackages; callPackage(
+      affection = hself.callCabal2nix "affection" (gitignore ../affection) {};
-    { mkDerivation, base, bytestring, Cabal, containers, glib
+    };
-    , stdenv, text, utf8-string
+  };
-    }:
+  gitignore = dir: pkgs.nix-gitignore.gitignoreSource [] dir;
-    mkDerivation {
-      pname = "glib";
-      version = "0.13.6.0";
-      sha256 = "4e71062c6a458440294d820e21449aa4666deed2ea233ef5915da7c1d4aee8eb";
-      setupHaskellDepends = [ base Cabal gtk2hs-buildtools ];
-      libraryHaskellDepends = [
-        base bytestring containers text utf8-string
-      ];
-      libraryPkgconfigDepends = [ pkgs.glib ];
-      homepage = "http://projects.haskell.org/gtk2hs/";
-      description = "Binding to the GLIB library for Gtk2Hs";
-      license = stdenv.lib.licenses.lgpl21;
-    }) {};
-
-  gtk2hs-buildtools = with haskellPackages; callPackage(
-    { mkDerivation, alex, array, base, Cabal, containers, directory
-    , filepath, happy, hashtables, pretty, process, random, stdenv
-    }:
-    mkDerivation {
-      pname = "gtk2hs-buildtools";
-      version = "0.13.4.0";
-      src = ../gtk2hs/tools;
-      isLibrary = true;
-      isExecutable = true;
-      enableSeparateDataOutput = true;
-      libraryHaskellDepends = [
-        array base Cabal containers directory filepath hashtables pretty
-        process random
-      ];
-      libraryToolDepends = [ alex happy ];
-      executableHaskellDepends = [ base ];
-      homepage = "http://projects.haskell.org/gtk2hs/";
-      description = "Tools to build the Gtk2Hs suite of User Interface libraries";
-      license = stdenv.lib.licenses.gpl2;
-    }) {};
-
-  cereal = with haskellPackages; callPackage(
-    { mkDerivation, array, base, bytestring, containers, ghc-prim
-    , QuickCheck, stdenv, test-framework, test-framework-quickcheck2
-    }:
-    mkDerivation {
-      pname = "cereal";
-      version = "0.5.7.0";
-      sha256 = "7abdaf6d52260e714adcf1c3e16f2e25a56492d90a747d1a9594e15f05acf1c8";
-      libraryHaskellDepends = [
-        array base bytestring containers ghc-prim
-      ];
-      testHaskellDepends = [
-        base bytestring QuickCheck test-framework
-        test-framework-quickcheck2
-      ];
-      homepage = "https://github.com/GaloisInc/cereal";
-      description = "A binary serialization library";
-      license = stdenv.lib.licenses.bsd3;
-      doCheck = false;
-    }) {};
-
-  linear = with haskellPackages; callPackage(
-    { mkDerivation, adjunctions, base, base-orphans, binary
-    , bytestring, Cabal, cabal-doctest, containers, deepseq
-    , distributive, doctest, ghc-prim, hashable, HUnit, lens
-    , reflection, semigroupoids, semigroups, simple-reflect, stdenv
-    , tagged, template-haskell, test-framework, test-framework-hunit
-    , transformers, transformers-compat, unordered-containers, vector
-    , void
-    }:
-    mkDerivation {
-      pname = "linear";
-      version = "1.20.8";
-      sha256 = "5ebd1b99837f2e3c7386bcd2ca425d9c66b09a61409792b141428345fb9edb10";
-      setupHaskellDepends = [ base Cabal cabal-doctest ];
-      libraryHaskellDepends = [
-        adjunctions base base-orphans binary bytes cereal containers
-        deepseq distributive ghc-prim hashable lens reflection
-        semigroupoids semigroups tagged template-haskell transformers
-        transformers-compat unordered-containers vector void
-      ];
-      testHaskellDepends = [
-        base binary bytestring deepseq doctest HUnit lens reflection
-        simple-reflect test-framework test-framework-hunit vector
-      ];
-      homepage = "http://github.com/ekmett/linear/";
-      description = "Linear Algebra";
-      license = stdenv.lib.licenses.bsd3;
-    }) {};
-
-  bytes = with haskellPackages; callPackage(
-    { mkDerivation, base, binary, bytestring, Cabal, cabal-doctest
-    , containers, directory, doctest, filepath, hashable, mtl
-    , scientific, stdenv, text, time, transformers, transformers-compat
-    , unordered-containers, void
-    }:
-    mkDerivation {
-      pname = "bytes";
-      version = "0.15.5";
-      sha256 = "039935e6b367eb8657aa3eb109e719b257a06524b0d9ff5246e8029bb7a07118";
-      setupHaskellDepends = [ base Cabal cabal-doctest ];
-      libraryHaskellDepends = [
-        base binary bytestring cereal containers hashable mtl scientific
-        text time transformers transformers-compat unordered-containers
-        void
-      ];
-      testHaskellDepends = [ base directory doctest filepath ];
-      homepage = "https://github.com/ekmett/bytes";
-      description = "Sharing code for serialization between binary and cereal";
-      license = stdenv.lib.licenses.bsd3;
-    }) {};
-
-  aff = with haskellPackages; callPackage(
-    { mkDerivation, base, bytestring, clock, containers, fetchgit
-    , monad-loops, monad-parallel, mtl, OpenGL, stdenv, stm
-    , text, uuid, vector
-    }:
-    mkDerivation {
-      pname = "affection";
-      version = "0.0.0.9";
-      src = fetchgit {
-        url = "https://github.com/nek0/affection";
-        sha256 = "08pf1nqha62m608zmcyyshljzga8h1p9hyxvwrk4affsaj7vpkpx";
-        rev = "91c70c6ec62e407bd6d0233fbc2c64bafc3b6cdc";
-        fetchSubmodules = true;
-      };
-      configureFlags = [ "-fdebug" ];
-      isLibrary = true;
-      isExecutable = true;
-      libraryHaskellDepends = [
-        base bytestring clock containers glib linear monad-loops
-        monad-parallel mtl OpenGL sdl stm uuid text vector
-      ];
-      homepage = "https://github.com/nek0/affection#readme";
-      description = "A simple Game Engine using SDL";
-      license = stdenv.lib.licenses.lgpl3;
-    }) {};
-
-  psq = with haskellPackages; callPackage(
-    { mkDerivation, array, base, containers, criterion, deepseq
-    , fingertree-psqueue, ghc-prim, hashable, HUnit, mtl, PSQueue
-    , QuickCheck, random, stdenv, tagged, test-framework
-    , test-framework-hunit, test-framework-quickcheck2
-    , unordered-containers
-    }:
-    mkDerivation {
-      pname = "psqueues";
-      version = "0.2.7.0";
-      sha256 = "4cf3628884015b091471e4425f5414207fd547cf71d9546e9b7318d857624fea";
-      libraryHaskellDepends = [ base deepseq ghc-prim hashable ];
-      testHaskellDepends = [
-        array base deepseq ghc-prim hashable HUnit QuickCheck tagged
-        test-framework test-framework-hunit test-framework-quickcheck2
-      ];
-      benchmarkHaskellDepends = [
-        base containers criterion deepseq fingertree-psqueue ghc-prim
-        hashable mtl PSQueue random unordered-containers
-      ];
-      description = "Pure priority search queues";
-      license = stdenv.lib.licenses.bsd3;
-      doCheck = false;
-    }) {};
-
-  astar = with haskellPackages; callPackage(
-    { mkDerivation, base, hashable, stdenv
-    , unordered-containers
-    }:
-    mkDerivation {
-      pname = "astar";
-      version = "0.3.0.0";
-      sha256 = "2117c007d5daa88401a49c994b8e3361ddae331d458b1a403fac2a4f304b9b87";
-      libraryHaskellDepends = [
-        base hashable psq unordered-containers
-      ];
-      homepage = "https://github.com/weissi/astar";
-      description = "General A* search algorithm";
-      license = stdenv.lib.licenses.bsd3;
-    }) {};
-
-  sdl = with haskellPackages; callPackage(
-    { mkDerivation, base, bytestring, deepseq, exceptions
-    , StateVar, stdenv, text, transformers, vector, weigh, pkgconfig
-    }:
-    mkDerivation {
-      pname = "sdl2";
-      version = "2.4.1.0";
-      sha256 = "21a569c0c19f8ff2bbe1cf1d3eb32f65e8143806de353cedd240df5e9d088b5c";
-      isLibrary = true;
-      isExecutable = true;
-      enableSeparateDataOutput = true;
-      libraryHaskellDepends = [
-        base bytestring exceptions linear StateVar text transformers vector
-      ];
-      buildDepends = [ pkgconfig ];
-      librarySystemDepends = [ nixpkgs.SDL2 pkgconfig ];
-      libraryPkgconfigDepends = [ nixpkgs.SDL2 pkgconfig ];
-      testHaskellDepends = [ base deepseq linear vector weigh ];
-      doCheck = false;
-      description = "Both high- and low-level bindings to the SDL library (version 2.0.4+).";
-      license = stdenv.lib.licenses.bsd3;
-    }) {};
-
-  nano = with haskellPackages; callPackage(
-    { mkDerivation, base, bytestring, c2hs, containers, fetchgit
-    , glew, hspec, inline-c, libGL, libGLU, QuickCheck, stdenv, text
-    , vector
-    }:
-    mkDerivation {
-      pname = "nanovg";
-      version = "0.6.0.0";
-      src = ../nanovg-hs;
-      isLibrary = true;
-      isExecutable = true;
-      libraryHaskellDepends = [ base bytestring containers text vector ];
-      librarySystemDepends = [ glew libGL libGLU ];
-      libraryPkgconfigDepends = [ glew ];
-      libraryToolDepends = [ c2hs ];
-      testHaskellDepends = [ base containers hspec inline-c QuickCheck ];
-      homepage = "https://github.com/cocreature/nanovg-hs";
-      description = "Haskell bindings for nanovg";
-      doCheck = false;
-      license = stdenv.lib.licenses.isc;
-    }) {};
-
-  f = { mkDerivation, algebraic-graphs, base
-      , bytestring, containers, ecstasy, JuicyPixels, JuicyPixels-extra
-      , matrix, mtl, OpenGL, random, stdenv, stm
-      , text, unordered-containers, vector, pkgconfig
-      }:
-      mkDerivation {
-        pname = "tracer-game";
-        version = "0.0.0.0";
-        src = ./.;
-        isLibrary = false;
-        isExecutable = true;
-        executableHaskellDepends = [
-          aff algebraic-graphs astar base bytestring containers ecstasy
-          JuicyPixels JuicyPixels-extra linear matrix mtl nano OpenGL
-          random sdl stm text unordered-containers vector pkgconfig
-        ];
-        enableExecutableProfiling = true;
-        enableLibraryProfiling = true;
-        license = stdenv.lib.licenses.gpl3;
-      };
-
-  haskellPackages = if compiler == "default"
-                       then pkgs.haskellPackages
-                       else pkgs.haskell.packages.${compiler};
-
-  variant = if doBenchmark then pkgs.haskell.lib.doBenchmark else pkgs.lib.id;
-
-  drv = variant (haskellPackages.callPackage f {});
-
 in
-
+  hpkgs.tracer-game.env
-  if pkgs.lib.inNixShell then drv.env else drv

src/Floorplan.hs

@@ -6,7 +6,8 @@ import Data.Matrix (Matrix(..))
 import qualified Data.Matrix as M
 import qualified Data.Text as T
 import Data.Maybe
-import Data.List (intersect)
+import qualified Data.Vector as V
+import Data.String
 
 import Linear (V2(..))
 
@@ -25,7 +26,7 @@ buildHallFloorIO
   :: FloorConfig
   -> MVar (Float, T.Text)
   -> Float
-  -> IO (Matrix TileState, [Graph])
+  -> IO (Matrix TileState, V.Vector Graph)
 buildHallFloorIO fc progress increment = do
   rand <- newStdGen
   modifyMVar_ progress (return . (\(p, _) ->
@@ -77,8 +78,12 @@ buildHallFloorIO fc progress increment = do
     ( p + increment
     , "Assigned room clearances"
     )))
-  A.logIO A.Debug ("length accessGraph: " ++ show (length accessGraph))
+  A.logIO
-  A.logIO A.Debug ("length doorgraph: " ++ show (length doorgraph))
+    A.Debug
+    ("length accessGraph: " <> fromString (show $ length accessGraph))
+  A.logIO
+    A.Debug
+    ("length doorgraph: " <> fromString (show $ length doorgraph))
   return (facils, accessGraph)
 
 emptyFloor :: FloorConfig -> Matrix TileState
@@ -123,10 +128,8 @@ placeHalls rng fc input =
               (fst (matmin b) + 10, fst (matmax b) - 10) agen
             (col, g2)   = randomR
               (snd (matmin b) + 10, snd (matmax b) - 10) g1
-            -- (nw, g3)    = randomR (2, wmax) g2
             (nbs, nmat) = buildHall cross 3 b amat
         in
-          -- if hallRatio nmat < 0.33 && wmax - 1 >= 2
           if wmax - 1 >= 3 &&
             all (\(Boundaries (minr, minc) (maxr, maxc)) ->
               maxr - minr > 3 && maxc - minc > 3) nbs
@@ -134,10 +137,6 @@ placeHalls rng fc input =
           else (g2, nmat)
         ) (rand, mat) bs
 
-boundSize :: Boundaries Int -> Int
-boundSize (Boundaries mi ma) =
-  (fst ma - fst mi) * (snd ma - snd mi)
-
 buildHall
   :: (V2 Int)
   -> Int
@@ -179,101 +178,106 @@ hallRatio mat =
 
 buildInnerWalls :: StdGen -> Matrix TileState -> (StdGen, Matrix TileState)
 buildInnerWalls rng input =
-  let floodSearchReplace
+  let tups mat = (,) <$> [1 .. nrows mat] <*> [1 .. ncols mat]
-        :: StdGen
-        -> (Int, Int)
-        -> Matrix TileState
-        -> (StdGen, Matrix TileState)
-      floodSearchReplace gn coord@(row, col) mat
-        | mat M.! coord == Unde =
-          let maxRow = doRow row
-              doRow r
-                | M.safeGet (r + 1) col mat == Just Unde = doRow (r + 1)
-                | otherwise = r
-              maxCol = doCol col
-              doCol c
-                | M.safeGet row (c + 1) mat == Just Unde = doCol (c + 1)
-                | otherwise = c
-              (cr, g1) = randomR
-                ( if maxRow - 3 < row + 3
-                  then (row + 2, row + 2)
-                  else (row + 3, maxRow - 3)
-                ) gn
-              (cc, g2) = randomR
-                ( if maxCol - 3 < col + 3
-                  then (col + 2, col + 2)
-                  else (col + 3,maxCol - 3)
-                ) g1
-              (nngen, nnmat) =
-                if (cr - 2 > row && cr + 2 < maxRow)
-                  && (cc - 2 > col && cc + 2 < maxCol)
-                then
-                  doCross
-                    g2
-                    (cr, cc)
-                    (Boundaries coord (maxRow, maxCol))
-                    mat
-                else
-                  let btups = (,)
-                        <$> [fst coord .. maxRow]
-                        <*> [snd coord .. maxCol]
-                  in
-                    ( g2
-                    , foldl
-                        (\acc coords ->
-                          M.setElem (replaceTile (acc M.! coords) Offi) coords acc
-                          ) mat btups
-                    )
-              doCross
-                :: StdGen
-                -> (Int, Int)
-                -> Boundaries Int
-                -> Matrix TileState
-                -> (StdGen, Matrix TileState)
-              doCross gen cd@(xr, xc) b imat =
-                let nbs = map (uncurry Boundaries) bs
-                    bs =
-                      [ (matmin b, cd)
-                      , ((fst (matmin b), col), (row, snd (matmax b)))
-                      , ((row, snd (matmin b)), (fst (matmax b), col))
-                      , (cd, matmax b)
-                      ]
-                    (ngen, crosses) = foldl
-                      (\(agen, acc) (minb, maxb) ->
-                        let (fc, gg1) = randomR (fst minb, fst maxb) agen
-                            (fr, gg2) = randomR (snd minb, snd maxb) gg1
-                        in  (gg2, acc ++ [(fc, fr)])
-                        ) (gen, []) bs
-                    horz = M.mapRow (\icol cur ->
-                      if icol >= snd (matmin b) && icol <= snd (matmax b)
-                      then replaceTile cur Wall
-                      else cur
-                      ) xr imat
-                    vert = M.mapCol (\irow cur ->
-                      if irow >= fst (matmin b) && irow <= fst (matmax b)
-                      then replaceTile cur Wall
-                      else cur
-                      ) xc horz
-                    omat = foldl
-                      (\acc coords ->
-                        M.setElem (replaceTile (acc M.! coords) Offi) coords acc
-                        ) vert btups
-                    btups = (,)
-                      <$> [fst (matmin b) .. fst (matmax b)]
-                      <*> [snd (matmin b) .. snd (matmax b)]
-                in if boundSize b >= 16
-                   then foldl
-                     (\(agen, amat) (acr, nb) -> doCross agen acr nb amat)
-                     (ngen, omat)
-                     (zip crosses nbs)
-                   else
-                     (gen, omat)
-          in  (nngen, nnmat)
-        | otherwise = (gn, mat)
-      tups mat = (,) <$> [1 .. nrows mat] <*> [1 .. ncols mat]
   in  foldl (\(agen, amat) cds -> floodSearchReplace agen cds amat)
         (rng, input) (tups input)
 
+floodSearchReplace
+  :: StdGen
+  -> (Int, Int)
+  -> Matrix TileState
+  -> (StdGen, Matrix TileState)
+floodSearchReplace gn coord@(row, col) mat
+  | mat M.! coord == Unde =
+    let maxRow = doRow row
+        doRow r
+          | M.safeGet (r + 1) col mat == Just Unde = doRow (r + 1)
+          | otherwise = r
+        maxCol = doCol col
+        doCol c
+          | M.safeGet row (c + 1) mat == Just Unde = doCol (c + 1)
+          | otherwise = c
+        (cr, g1) = randomR
+          ( if maxRow - 3 < row + 3
+            then (row + 2, row + 2)
+            else (row + 3, maxRow - 3)
+          ) gn
+        (cc, g2) = randomR
+          ( if maxCol - 3 < col + 3
+            then (col + 2, col + 2)
+            else (col + 3,maxCol - 3)
+          ) g1
+        (nngen, nnmat) =
+          if (cr - 2 > row && cr + 2 < maxRow)
+            && (cc - 2 > col && cc + 2 < maxCol)
+          then
+            doCross
+              g2
+              (cr, cc)
+              coord
+              (Boundaries coord (maxRow, maxCol))
+              mat
+          else
+            let btups = (,)
+                  <$> [fst coord .. maxRow]
+                  <*> [snd coord .. maxCol]
+            in
+              ( g2
+              , foldl
+                  (\acc coords ->
+                    M.setElem (replaceTile (acc M.! coords) Offi) coords acc
+                    ) mat btups
+              )
+    in  (nngen, nnmat)
+  | otherwise = (gn, mat)
+
+doCross
+  :: RandomGen t
+  => t
+  -> (Int, Int)
+  -> (Int, Int)
+  -> Boundaries Int
+  -> Matrix TileState
+  -> (t, Matrix TileState)
+doCross gen cd@(xr, xc) coord@(row, col) b imat =
+  let nbs = map (uncurry Boundaries) bs
+      bs =
+        [ (matmin b, cd)
+        , ((fst (matmin b), col), (row, snd (matmax b)))
+        , ((row, snd (matmin b)), (fst (matmax b), col))
+        , (cd, matmax b)
+        ]
+      (ngen, crosses) = foldl
+        (\(agen, acc) (minb, maxb) ->
+          let (fc, gg1) = randomR (fst minb, fst maxb) agen
+              (fr, gg2) = randomR (snd minb, snd maxb) gg1
+          in  (gg2, acc ++ [(fc, fr)])
+          ) (gen, []) bs
+      horz = M.mapRow (\icol cur ->
+        if icol >= snd (matmin b) && icol <= snd (matmax b)
+        then replaceTile cur Wall
+        else cur
+        ) xr imat
+      vert = M.mapCol (\irow cur ->
+        if irow >= fst (matmin b) && irow <= fst (matmax b)
+        then replaceTile cur Wall
+        else cur
+        ) xc horz
+      omat = foldl
+        (\acc coords ->
+          M.setElem (replaceTile (acc M.! coords) Offi) coords acc
+          ) vert btups
+      btups = (,)
+        <$> [fst (matmin b) .. fst (matmax b)]
+        <*> [snd (matmin b) .. snd (matmax b)]
+  in if size b >= 16
+     then foldl
+       (\(agen, amat) (acr, nb) -> doCross agen acr coord nb amat)
+       (ngen, omat)
+       (zip crosses nbs)
+     else
+       (gen, omat)
+
 closeOffices :: Matrix TileState -> Matrix TileState
 closeOffices input =
   let tups mat = (,) <$> [2 .. nrows mat - 1] <*> [2 .. ncols mat - 1]
@@ -311,26 +315,28 @@ buildFacilities
   -> Matrix TileState
   -> (StdGen, Matrix TileState)
 buildFacilities gen fc input =
-  let flood ts mat coords@(cr, cc) =
+  let nearests = map (findNearestOffice input) (fcFacilities fc)
-        let cur = mat M.! coords
-            altered = M.setElem ts coords mat
-        in
-          if cur == ts || cur /= Offi
-          then mat
-          else foldl (flood ts)
-            altered
-            [ (cr + 1, cc)
-            , (cr - 1, cc)
-            , (cr, cc + 1)
-            , (cr, cc - 1)
-            ]
-      nearests = map (findNearestOffice input) (fcFacilities fc)
   in  foldl (\(agen, acc) x ->
         let (numfac, ngen) = randomR (0 :: Int, 1 :: Int) agen
             facil = if numfac == 1 then Kitc else Toil
-        in  (ngen, flood facil acc x)
+        in  (ngen, facilFlood facil acc x)
         ) (gen, input) nearests
 
+facilFlood :: TileState -> Matrix TileState -> (Int, Int) -> Matrix TileState
+facilFlood ts mat coords@(cr, cc) =
+  let cur = mat M.! coords
+      altered = M.setElem ts coords mat
+  in
+    if cur == ts || cur /= Offi
+    then mat
+    else foldl (facilFlood ts)
+      altered
+      [ (cr + 1, cc)
+      , (cr - 1, cc)
+      , (cr, cc + 1)
+      , (cr, cc - 1)
+      ]
+
 findNearestOffice
   :: Matrix TileState
   -> (V2 Int)
@@ -346,104 +352,119 @@ findNearestOffice mat (V2 rrr ccc) =
         else acc
         ) (fst $ head inlist) inlist
 
-buildDoorsGraph :: Matrix TileState -> IO [Graph]
+buildDoorsGraph :: Matrix TileState -> IO (V.Vector Graph)
 buildDoorsGraph mat =
-  let maxCol r c
+  weedOut (buildGraph mat mat (V.singleton (GHall V.empty)) (2, 2))
-        | M.safeGet r (c + 1) mat == Just Offi = maxCol r (c + 1)
-        | otherwise = c
-      buildGraph :: Matrix TileState -> [Graph] -> (Int, Int) -> [Graph]
-      buildGraph amat root coord@(br, bc)
-        | bc > ncols amat - 1 =
-          buildGraph amat root (br + 1, 1)
-        | br > nrows amat - 1 =
-          root
-        | M.safeGet br bc amat == Just Offi =
-          let flood acc (fr, fc) =
-                let ncoords = [] ++
-                      (if (fr + 1, fc) `notElem` acc &&
-                        M.safeGet (fr + 1) fc amat == Just Offi
-                      then [(fr + 1, fc)]
-                      else []) ++
-                      (if (fr - 1, fc) `notElem` acc &&
-                        M.safeGet (fr - 1) fc amat == Just Offi
-                      then [(fr - 1, fc)]
-                      else []) ++
-                      (if (fr, fc - 1) `notElem` acc &&
-                        M.safeGet fr (fc - 1) amat == Just Offi
-                      then [(fr, fc - 1)]
-                      else []) ++
-                      (if (fr, fc + 1) `notElem` acc &&
-                        M.safeGet fr (fc + 1) amat == Just Offi
-                      then [(fr, fc + 1)]
-                      else [])
-                in  foldl flood (acc ++ ncoords) ncoords
-              roomcoords = flood [coord] coord
-              b = Boundaries
-                (minimum (map fst roomcoords), minimum (map snd roomcoords))
-                (maximum (map fst roomcoords), maximum (map snd roomcoords))
-              neighs = map (\(a, bx) -> (a, fromJust bx)) (filter ((/=Nothing) . snd)
-                [ (North, M.safeGet (fst (matmin b) - 2) (snd (matmin b)) amat)
-                , (South, M.safeGet (fst (matmax b) + 2) (snd (matmin b)) amat)
-                , (West,  M.safeGet (fst (matmin b)) (snd (matmin b) - 2) amat)
-                , (East,  M.safeGet (fst (matmin b)) (snd (matmax b) + 2) amat)
-                ])
-          in
-            if Hall `elem` map snd neighs
-            then
-              let nroot =
-                    if GRoom neighs b 0 Offi `notElem` connects (head root)
-                    then
-                      GHall
-                        { connects = connects (head root) ++
-                          [GRoom neighs b 0 Offi]
-                        } : tail root
-                    else root
-              in  buildGraph amat nroot (br, 1 + snd (matmax b))
-            else
-              let nroot = root ++
-                    if GRoom neighs b 0 Offi `elem` root
-                    then []
-                    else [GRoom neighs b 0 Offi]
-              in  buildGraph amat nroot (br, 1 + snd (matmax b))
-        | otherwise =
-          buildGraph amat root (br, maxCol br (bc + 1))
-  in  weedOut $ buildGraph mat [GHall []] (2, 2)
   where
-    weedOut (hall@(GHall _):gs) = (hall :) <$> weedOut gs
+    weedOut vect = if V.null vect
-    weedOut (g@(GRoom neighs _ _ _):gs) = do
+      then
-      let filtered = filter ((== Offi) . snd) neighs
+        return V.empty
-      rand <- randomRIO (0, length filtered -1) :: IO Int
+      else
-      let nneigh = filtered !! rand : []
+        case V.head vect of
-      rest <- weedOut gs
+          hall@(GHall _) ->
-      return (g { neighbs = nneigh } : rest)
+            (hall `V.cons`) <$> weedOut (V.tail vect)
-    weedOut [] = return []
+          g@(GRoom neighs _ _ _) -> do
+            let filtered = V.filter ((== Offi) . snd) neighs
+            rand <- randomRIO (0, length filtered -1) :: IO Int
+            let nneigh = filtered V.! rand `V.cons` V.empty
+            rest <- weedOut (V.tail vect)
+            return (g { neighbs = nneigh } `V.cons` rest)
 
-assignClearance :: [Graph] -> M.Matrix TileState -> IO [Graph]
+buildGraph
+  :: Matrix TileState
+  -> Matrix TileState
+ -> V.Vector Graph
+  -> (Int, Int)
+  -> V.Vector Graph
+buildGraph amat mat root coord@(br, bc)
+  | bc > ncols amat - 1 =
+    buildGraph amat mat root (br + 1, 1)
+  | br > nrows amat - 1 =
+    root
+  | M.safeGet br bc amat == Just Offi =
+    let roomcoords = flood amat [coord] coord
+        b = Boundaries
+          (minimum (map fst roomcoords), minimum (map snd roomcoords))
+          (maximum (map fst roomcoords), maximum (map snd roomcoords))
+        neighs = V.map (\(a, bx) -> (a, fromJust bx)) (V.filter ((/=Nothing) . snd)
+          $ V.fromList
+            [ (North, M.safeGet (fst (matmin b) - 2) (snd (matmin b)) amat)
+            , (South, M.safeGet (fst (matmax b) + 2) (snd (matmin b)) amat)
+            , (West,  M.safeGet (fst (matmin b)) (snd (matmin b) - 2) amat)
+            , (East,  M.safeGet (fst (matmin b)) (snd (matmax b) + 2) amat)
+            ])
+    in
+      if Hall `V.elem` V.map snd neighs
+      then
+        let nroot =
+              if GRoom neighs b 0 Offi `V.notElem` connects (V.head root)
+              then
+                GHall
+                  { connects = connects (V.head root) `V.snoc`
+                    GRoom neighs b 0 Offi
+                  } `V.cons` V.tail root
+              else root
+        in  buildGraph amat mat nroot (br, 1 + snd (matmax b))
+      else
+        let nroot = if GRoom neighs b 0 Offi `V.elem` root
+              then root
+              else root `V.snoc` GRoom neighs b 0 Offi
+        in  buildGraph amat mat nroot (br, 1 + snd (matmax b))
+  | otherwise =
+    buildGraph amat mat root (br, maxCol br (bc + 1))
+  where
+    maxCol r c
+      | M.safeGet r (c + 1) mat == Just Offi = maxCol r (c + 1)
+      | otherwise = c
+
+
+flood :: Matrix TileState -> [(Int, Int)] -> (Int, Int) -> [(Int,Int)]
+flood amat acc (fr, fc) =
+  let ncoords = [] ++
+        (if (fr + 1, fc) `notElem` acc &&
+          M.safeGet (fr + 1) fc amat == Just Offi
+        then [(fr + 1, fc)]
+        else []) ++
+        (if (fr - 1, fc) `notElem` acc &&
+          M.safeGet (fr - 1) fc amat == Just Offi
+        then [(fr - 1, fc)]
+        else []) ++
+        (if (fr, fc - 1) `notElem` acc &&
+          M.safeGet fr (fc - 1) amat == Just Offi
+        then [(fr, fc - 1)]
+        else []) ++
+        (if (fr, fc + 1) `notElem` acc &&
+          M.safeGet fr (fc + 1) amat == Just Offi
+        then [(fr, fc + 1)]
+        else [])
+  in  foldl (flood amat) (acc ++ ncoords) ncoords
+
+assignClearance :: V.Vector Graph -> M.Matrix TileState -> IO (V.Vector Graph)
 assignClearance graph imat =
-  foldM doAssignClearance [] graph
+  V.foldM doAssignClearance V.empty graph
   where
     doAssignClearance acc (GHall conns) = do
-      ret <- GHall <$> foldM (\acc a -> do
+      ret <- GHall <$> V.foldM (\facc a -> do
-        res <- reassign True acc a
+        res <- reassign True facc a
-        return (acc ++ [res])
+        return (facc `V.snoc` res)
-        ) [] conns
+        ) V.empty conns
-      return (ret : acc)
+      return (ret `V.cons` acc)
     doAssignClearance acc room = do
       ret <- reassign False acc room
-      return (acc ++ [ret])
+      return (acc `V.snoc` ret)
-    reassign :: Bool -> [Graph] -> Graph -> IO Graph
+    reassign :: Bool -> V.Vector Graph -> Graph -> IO Graph
-    reassign p acc room@(GRoom ns b c t) =
+    reassign p acc room@(GRoom ns b _ _) =
       if p
       then do
         if actualRoomType b imat == Offi
         then do
-          let neigh = filter (all ((/= Hall) . snd) . neighbs) $
+          let neigh = V.filter (all ((/= Hall) . snd) . neighbs) $
-                catMaybes
+                V.fromList $ catMaybes $ V.toList $
-                  (map
+                  (V.map
-                    (\n -> findNeighbor n b imat onlyrooms)
+                    (\n -> findNeighbor n b onlyrooms)
                     nonhalls
                     )
-              onlyrooms = tail graph
+              onlyrooms = V.tail graph
               nonhalls = ns -- filter ((/= Hall) . snd) ns
           if not (null neigh) && any ((Offi /=) . flip actualRoomType imat . bounds) neigh
           then
@@ -456,19 +477,22 @@ assignClearance graph imat =
         if actualRoomType b imat == Offi
         then do
           let neigh =
-                catMaybes
+                V.fromList $ catMaybes $ V.toList $
-                  (map
+                  (V.map
-                    (\n -> findNeighbor n b imat onlyrooms)
+                    (\n -> findNeighbor n b onlyrooms)
                     nonhalls
                     )
-              onlyrooms = connects (head acc)
+              onlyrooms = connects (V.head acc)
               nonhalls = ns -- filter ((/= Hall) . snd) ns
           ret <- if null neigh
             then doRandomAssign room
-            else doBoundedAssign room (clearance $ head neigh)
+            else doBoundedAssign room (clearance $ V.head neigh)
           return ret
         else
           return room
+    reassign _ _ (GHall _) = do
+      logIO A.Error "cannot reassign Hallways!"
+      error "*dies*"
 
 actualRoomType :: Boundaries Int -> M.Matrix TileState -> TileState
 actualRoomType (Boundaries (minrow, mincol) (maxrow, maxcol)) imat =
@@ -490,8 +514,12 @@ doBoundedAssign g b = do
     { clearance = c
     }
 
-findNeighbor :: (GraphDirection, TileState) -> Boundaries Int -> M.Matrix TileState -> [Graph] -> Maybe Graph
+findNeighbor
-findNeighbor (dir, _) bnds imat ingraph
+  :: (GraphDirection, TileState)
+  -> Boundaries Int
+  -> V.Vector Graph
+  -> Maybe Graph
+findNeighbor (dir, _) bnds ingraph
   | dir == North =
     let row = fst (matmin bnds) - 2
         col = snd (matmin bnds) + ((snd (matmax bnds) - snd (matmin bnds)) `div` 2)
@@ -509,106 +537,111 @@ findNeighbor (dir, _) bnds imat ingraph
         col = snd (matmin bnds) - 2
     in  postprocess row col
   where 
-    neighTile row col = imat M.! (row, col)
     postprocess row col =
-      let filtered = filter
+      let filtered = V.filter
             (inBounds (V2 row col) . bounds)
             ingraph
       in
-        case filtered of
+        if V.null filtered
-          [a@(GRoom _ _ _ ts)] -> Just a
+        then Nothing
-                                  -- if ts == neighTile row col
+        else if V.length filtered == 1
-                                  -- then Just a
+          then
-                                  -- else error "findNeighbor: Query Result does not match"
+            case V.head filtered of
-          []                   -> Nothing
+              a@(GRoom _ _ _ _) -> Just a
-          _                    -> error "findNeighbor: Non-singleton filter result"
+              _                 -> error "findNeighbor: Not a GRoom result"
+          else
+            error "findNeighbor: Non-Singleton filter result"
+findNeighbor (_, _) _ _ =
+  A.log A.Error "*confused from indirection*" (error "*dies*")
 
-buildDoors :: Matrix TileState -> [Graph] -> IO (Matrix TileState)
+buildDoors :: Matrix TileState -> V.Vector Graph -> IO (Matrix TileState)
-buildDoors = foldM placeDoors
+buildDoors = V.foldM placeDoors
-  where
+
-    placeDoors :: Matrix TileState -> Graph -> IO (Matrix TileState)
+placeDoors :: Matrix TileState -> Graph -> IO (Matrix TileState)
-    placeDoors amat (GHall conns) =
+placeDoors amat (GHall conns) =
-      foldM placeDoors amat conns
+  foldM placeDoors amat conns
-    placeDoors amat (GRoom neighs bs _ _) =
+placeDoors amat (GRoom neighs bs _ _) =
-      if Hall `elem` map snd neighs
+  if Hall `V.elem` V.map snd neighs
-      then do
+  then do
-        let halls = filter ((== Hall) . snd) neighs
+    let halls = V.filter ((== Hall) . snd) neighs
-        idx <- randomRIO (0, length halls - 1)
+    idx <- randomRIO (0, length halls - 1)
-        let (dir, _) = halls !! idx
+    let (dir, _) = halls V.! idx
-        case dir of
+    case dir of
-          North ->
+      North ->
-            inRow
+        inRow
-              amat
+          amat
-              (fst (matmin bs) - 1)
+          (fst (matmin bs) - 1)
-              (snd (matmin bs), snd (matmax bs))
+          (snd (matmin bs), snd (matmax bs))
-          South ->
+      South ->
-            inRow
+        inRow
-              amat
+          amat
-              (fst (matmax bs) + 1)
+          (fst (matmax bs) + 1)
-              (snd (matmin bs), snd (matmax bs))
+          (snd (matmin bs), snd (matmax bs))
-          West ->
+      West ->
-            inCol
+        inCol
-              amat
+          amat
-              (fst (matmin bs), fst (matmax bs))
+          (fst (matmin bs), fst (matmax bs))
-              (snd (matmin bs) - 1)
+          (snd (matmin bs) - 1)
-          East ->
+      East ->
-            inCol
+        inCol
-              amat
+          amat
-              (fst (matmin bs), fst (matmax bs))
+          (fst (matmin bs), fst (matmax bs))
-              (snd (matmax bs) + 1)
+          (snd (matmax bs) + 1)
-      else do
+  else do
-        idx <- randomRIO (0, length neighs - 1)
+    idx <- randomRIO (0, length neighs - 1)
-        let (dir, _) = neighs !! idx
+    let (dir, _) = neighs V.! idx
-        case dir of
+    case dir of
-          North ->
+      North ->
-            inRow
+        inRow
-              amat
+          amat
-              (fst (matmin bs) - 1)
+          (fst (matmin bs) - 1)
-              (snd (matmin bs), snd (matmax bs))
+          (snd (matmin bs), snd (matmax bs))
-          South ->
+      South ->
-            inRow
+        inRow
-              amat
+          amat
-              (fst (matmax bs) + 1)
+          (fst (matmax bs) + 1)
-              (snd (matmin bs), snd (matmax bs))
+          (snd (matmin bs), snd (matmax bs))
-          West ->
+      West ->
-            inCol
+        inCol
-              amat
+          amat
-              (fst (matmin bs), fst (matmax bs))
+          (fst (matmin bs), fst (matmax bs))
-              (snd (matmin bs) - 1)
+          (snd (matmin bs) - 1)
-          East ->
+      East ->
-            inCol
+        inCol
-              amat
+          amat
-              (fst (matmin bs), fst (matmax bs))
+          (fst (matmin bs), fst (matmax bs))
-              (snd (matmax bs) + 1)
+          (snd (matmax bs) + 1)
-    inRow :: Matrix TileState -> Int -> (Int, Int) -> IO (Matrix TileState)
+
-    inRow mat row cols = do
+inRow :: Matrix TileState -> Int -> (Int, Int) -> IO (Matrix TileState)
-      col <- randomRIO cols
+inRow mat row cols = do
-      let tile = mat M.! (row, col)
+  col <- randomRIO cols
-      if tile == Wall
+  let tile = mat M.! (row, col)
-        && length (filter
+  if tile == Wall
-          (== Wall)
+    && length (filter
-          (M.toList (M.submatrix (row - 1) (row + 1) col col mat)))
+      (== Wall)
-          == 1
+      (M.toList (M.submatrix (row - 1) (row + 1) col col mat)))
-      then
+      == 1
-        if Door `elem` M.toList (uncurry (M.submatrix row row) cols mat)
+  then
-        then return mat
+    if Door `elem` M.toList (uncurry (M.submatrix row row) cols mat)
-        else
+    then return mat
-          return $ M.setElem Door (row, col) mat
+    else
-      else
+      return $ M.setElem Door (row, col) mat
-        inRow mat row cols
+  else
-    inCol :: Matrix TileState -> (Int, Int) -> Int -> IO (Matrix TileState)
+    inRow mat row cols
-    inCol mat rows col = do
+
-      row <- randomRIO rows
+inCol :: Matrix TileState -> (Int, Int) -> Int -> IO (Matrix TileState)
-      let tile = mat M.! (row, col)
+inCol mat rows col = do
-      if tile == Wall
+  row <- randomRIO rows
-        && length (filter
+  let tile = mat M.! (row, col)
-          (== Wall)
+  if tile == Wall
-          (M.toList (M.submatrix row row (col - 1) (col + 1) mat)))
+    && length (filter
-          == 1
+      (== Wall)
-      then
+      (M.toList (M.submatrix row row (col - 1) (col + 1) mat)))
-        if Door `elem` M.toList (uncurry M.submatrix rows col col mat)
+      == 1
-        then return mat
+  then
-        else
+    if Door `elem` M.toList (uncurry M.submatrix rows col col mat)
-          return $ M.setElem Door (row, col) mat
+    then return mat
-      else
+    else
-        inCol mat rows col
+      return $ M.setElem Door (row, col) mat
+  else
+    inCol mat rows col

src/Init.hs

@@ -11,7 +11,9 @@ import Codec.Picture as CP
 import Codec.Picture.Extra
 
 import Control.Concurrent.STM
+import Control.Concurrent.MVar
 
+import Data.String
 import qualified Data.Set as S
 import qualified Data.Map.Strict as M
 import Data.ByteString.Lazy (toStrict)
@@ -35,21 +37,26 @@ init = do
     <*> (SubTranslator <$> newTVarIO [])
   _ <- glewInit
   nvg <- createGL3 (S.fromList [NanoVG.Debug, Antialias, StencilStrokes])
-  return UserData
+  UserData
-    { state           = Load
+    <$> newMVar Load            -- state
-    , subsystems      = subs
+    <*> pure subs               -- subsystems
-    , assetImages     = M.empty
+    <*> newMVar M.empty         -- assetIcons
-    , assetAnimations = M.empty
+    <*> newMVar M.empty         -- assetImages
-    , assetFonts      = M.empty
+    <*> newMVar M.empty         -- assetFonts
-    , assetIcons      = M.empty
+    <*> newMVar M.empty         -- assetAnimations
-    , nano            = nvg
+    <*> newMVar NoController    -- controls
-    , uuid            = []
+    <*> newMVar NoTranslation   -- translation
-    , stateData       = None
+    <*> pure nvg                -- nano
-    , threadContext   = Nothing
+    <*> newMVar []              -- uuid
-    , controls        = NoController
+    <*> newEmptyMVar            -- worldState           <-
-    , translation     = NoTranslation
+    <*> newMVar None            -- stateData
-    , joyCache        = []
+    <*> newEmptyMVar            -- stateMVar            <-
-    }
+    <*> newEmptyMVar            -- stateProgress        <-
+    <*> newMVar Nothing         -- threadContext
+    <*> newMVar Nothing         -- window
+    <*> newMVar []              -- joyCache
+    <*> newEmptyMVar            -- joyUUID              <-
+    <*> newMVar True            -- doNextStep
 
 loadPlayerSprite
   :: FilePath         -- Path to spritemap
@@ -62,7 +69,7 @@ loadPlayerSprite fp w h nvg rids = do
   eimg <- readImage fp
   case eimg of
     Left err -> do
-      logIO Error err
+      logIO Error (fromString err)
       exitFailure
     Right dimg -> do
       let img = convertRGBA8 dimg
@@ -70,10 +77,16 @@ loadPlayerSprite fp w h nvg rids = do
         mapM (\(num, i) -> do
           let cr = crop (num * w) (row * h) w h img
           mresimg <-
-            createImageMem nvg ImagePremultiplied (toStrict $ encodePng cr)
+            createImageMem nvg (S.singleton ImagePremultiplied) (toStrict $ encodePng cr)
           case mresimg of
             Nothing     -> do
-              logIO Error ("Failed to load: " ++ fp ++ " " ++ show i)
+              logIO
+                Error
+                ("Failed to load: " <>
+                  fromString fp <>
+                  " " <>
+                  fromString (show i)
+                  )
               exitFailure
             Just resimg -> return (i, resimg)
           ) (zip [0..] ids)

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

@@ -7,57 +7,59 @@ import Graphics.Rendering.OpenGL.GL.FlushFinish (finish)
 
 import Control.Concurrent (forkIO)
 import Control.Concurrent.MVar
-import Control.Monad (when)
+import Control.Monad
+import Control.Monad.Trans.Resource (ResIO)
 
 import qualified Data.Map as M
 import qualified Data.Text as T
 import Data.Ecstasy
 import Data.Maybe
+import qualified Data.Set as S
+import Data.String
 
 import System.Exit (exitFailure)
 
 import NanoVG hiding (V2(..))
+import NanoVG.Internal.Image
 
 -- internal imports
 
 import Menu.Connect
 import Types
-import MainGame.WorldMap
 import Util
 
-loadLoad :: Affection UserData ()
+loadLoad :: UserData -> Affection ()
-loadLoad = do
+loadLoad ud = do
   ad <- A.get
-  ud <- getAffection
+  wState <- liftIO $ readMVar (worldState ud)
-  progress <- liftIO $ newMVar (0, "Starting up")
+  curWin <- liftIO $ readMVar (window ud)
-  future <- liftIO newEmptyMVar
+  tContext <- liftIO $ readMVar (threadContext ud)
+  let progress = (0, "Starting up")
+  void $ liftIO $ putMVar (stateProgress ud) progress
   _ <- liftIO $ createFont (nano ud) "bedstead"
     (FileName "assets/font/Bedstead-Semicondensed.ttf")
   _ <- liftIO $ forkIO $
     loadFork
-      (worldState ud)
+      wState
-      (fromJust $ window ud)
+      (fromJust curWin)
-      (fromJust $ threadContext ud)
+      (fromJust tContext)
       (nano ud)
-      future
+      (stateMVar ud)
-      progress
+      (stateProgress ud)
-  SDL.glMakeCurrent (fromJust $ window ud) (glContext ad)
+  SDL.glMakeCurrent (fromJust curWin) (acContext $ head $ glContext ad)
-  putAffection ud
+  void $ liftIO $ swapMVar (state ud) Load
-    { stateMVar = future
+  void $ liftIO $ swapMVar (assetFonts ud) (M.fromList
-    , stateProgress = progress
+    [ (FontBedstead, "bedstead")
-    , state = Load
+    ]
-    , assetFonts  = M.fromList
+    )
-      [ (FontBedstead, "bedstead")
-      ]
-    }
 
 loadFork
-  :: SystemState Entity (AffectionState (AffectionData UserData) IO)
+  :: SystemState Entity (AffectionState (AffectionData) ResIO)
   -> SDL.Window
   -> SDL.GLContext
   -> Context
   -> MVar
-    ( SystemState Entity (AffectionState (AffectionData UserData) IO)
+    ( SystemState Entity (AffectionState (AffectionData) ResIO)
     , StateData
     )
   -> MVar (Float, T.Text)
@@ -70,202 +72,202 @@ loadFork ws win glc nvg future progress = do
     ( p + increment
     , "Loading icon \"conntroller_blue\""
     )))
-  mcontrblue <- createImage nvg (FileName "assets/icons/controller_blue.png") 0
+  mcontrblue <- createImage nvg (FileName "assets/icons/controller_blue.png") (S.singleton ImagePremultiplied)
   modifyMVar_ progress (return . (\(p, _) ->
     ( p + increment
     , "Loading icon \"controller_blue\""
     )))
-  mcontrgreen <- createImage nvg (FileName "assets/icons/controller_green.png") 0
+  mcontrgreen <- createImage nvg (FileName "assets/icons/controller_green.png") (S.singleton ImagePremultiplied)
   modifyMVar_ progress (return . (\(p, _) ->
     ( p + increment
     , "Loading icon \"controller_green\""
     )))
-  mkbdblue <- createImage nvg (FileName "assets/icons/keyboard_blue.png") 0
+  mkbdblue <- createImage nvg (FileName "assets/icons/keyboard_blue.png") (S.singleton ImagePremultiplied)
   modifyMVar_ progress (return . (\(p, _) ->
     ( p + increment
     , "Loading icon \"keyboard_blue\""
     )))
-  mkbdgreen <- createImage nvg (FileName "assets/icons/keyboard_green.png") 0
+  mkbdgreen <- createImage nvg (FileName "assets/icons/keyboard_green.png") (S.singleton ImagePremultiplied)
   modifyMVar_ progress (return . (\(p, _) ->
     ( p + increment
     , "Loading icon \"keyboard_green\""
     )))
-  marrow <- createImage nvg (FileName "assets/icons/arrow.png") 0
+  marrow <- createImage nvg (FileName "assets/icons/arrow.png") (S.singleton ImagePremultiplied)
   modifyMVar_ progress (return . (\(p, _) ->
     ( p + increment
     , "Loading asset \"wall_asc\""
     )))
-  mwallasc <- createImage nvg (FileName "assets/walls/wall_asc.png") 0
+  mwallasc <- createImage nvg (FileName "assets/walls/wall_asc.png") (S.singleton ImagePremultiplied)
   modifyMVar_ progress (return . (\(p, _) ->
     ( p + increment
     , "Loading asset \"wall_desc\""
     )))
-  mwalldesc <- createImage nvg (FileName "assets/walls/wall_desc.png") 0
+  mwalldesc <- createImage nvg (FileName "assets/walls/wall_desc.png") (S.singleton ImagePremultiplied)
   modifyMVar_ progress (return . (\(p, _) ->
     ( p + increment
     , "Loading asset \"wall_corner_n\""
     )))
-  mwallcornern <- createImage nvg (FileName "assets/walls/wall_corner_n.png") 0
+  mwallcornern <- createImage nvg (FileName "assets/walls/wall_corner_n.png") (S.singleton ImagePremultiplied)
   modifyMVar_ progress (return . (\(p, _) ->
     ( p + increment
     , "Loading asset \"wall_corner_e\""
     )))
-  mwallcornere <- createImage nvg (FileName "assets/walls/wall_corner_e.png") 0
+  mwallcornere <- createImage nvg (FileName "assets/walls/wall_corner_e.png") (S.singleton ImagePremultiplied)
   modifyMVar_ progress (return . (\(p, _) ->
     ( p + increment
     , "Loading asset \"wall_corner_s\""
     )))
-  mwallcorners <- createImage nvg (FileName "assets/walls/wall_corner_s.png") 0
+  mwallcorners <- createImage nvg (FileName "assets/walls/wall_corner_s.png") (S.singleton ImagePremultiplied)
   modifyMVar_ progress (return . (\(p, _) ->
     ( p + increment
     , "Loading asset \"wall_corner_w\""
     )))
-  mwallcornerw <- createImage nvg (FileName "assets/walls/wall_corner_w.png") 0
+  mwallcornerw <- createImage nvg (FileName "assets/walls/wall_corner_w.png") (S.singleton ImagePremultiplied)
   modifyMVar_ progress (return . (\(p, _) ->
     ( p + increment
     , "Loading asset \"wall_t_ne\""
     )))
-  mwalltne <- createImage nvg (FileName "assets/walls/wall_t_ne.png") 0
+  mwalltne <- createImage nvg (FileName "assets/walls/wall_t_ne.png") (S.singleton ImagePremultiplied)
   modifyMVar_ progress (return . (\(p, _) ->
     ( p + increment
     , "Loading asset \"wall_t_se\""
     )))
-  mwalltse <- createImage nvg (FileName "assets/walls/wall_t_se.png") 0
+  mwalltse <- createImage nvg (FileName "assets/walls/wall_t_se.png") (S.singleton ImagePremultiplied)
   modifyMVar_ progress (return . (\(p, _) ->
     ( p + increment
     , "Loading asset \"wall_t_sw\""
     )))
-  mwalltsw <- createImage nvg (FileName "assets/walls/wall_t_sw.png") 0
+  mwalltsw <- createImage nvg (FileName "assets/walls/wall_t_sw.png") (S.singleton ImagePremultiplied)
   modifyMVar_ progress (return . (\(p, _) ->
     ( p + increment
     , "Loading asset \"wall_t_nw\""
     )))
-  mwalltnw <- createImage nvg (FileName "assets/walls/wall_t_nw.png") 0
+  mwalltnw <- createImage nvg (FileName "assets/walls/wall_t_nw.png") (S.singleton ImagePremultiplied)
   modifyMVar_ progress (return . (\(p, _) ->
     ( p + increment
     , "Loading asset \"wall_cross\""
     )))
-  mwallcross <- createImage nvg (FileName "assets/walls/wall_cross.png") 0
+  mwallcross <- createImage nvg (FileName "assets/walls/wall_cross.png") (S.singleton ImagePremultiplied)
   modifyMVar_ progress (return . (\(p, _) ->
     ( p + increment
     , "Loading asset \"box1\""
     )))
-  mmiscbox1 <- createImage nvg (FileName "assets/misc/box1.png") 0
+  mmiscbox1 <- createImage nvg (FileName "assets/misc/box1.png") (S.singleton ImagePremultiplied)
   modifyMVar_ progress (return . (\(p, _) ->
     ( p + increment
     , "Loading asset \"tableSW\""
     )))
-  mtableSW <- createImage nvg (FileName "assets/table/tableSW.png") 0
+  mtableSW <- createImage nvg (FileName "assets/table/tableSW.png") (S.singleton ImagePremultiplied)
   modifyMVar_ progress (return . (\(p, _) ->
     ( p + increment
     , "Loading asset \"tableSE\""
     )))
-  mtableSE <- createImage nvg (FileName "assets/table/tableSE.png") 0
+  mtableSE <- createImage nvg (FileName "assets/table/tableSE.png") (S.singleton ImagePremultiplied)
   modifyMVar_ progress (return . (\(p, _) ->
     ( p + increment
     , "Loading asset \"tableNE\""
     )))
-  mtableNE <- createImage nvg (FileName "assets/table/tableNE.png") 0
+  mtableNE <- createImage nvg (FileName "assets/table/tableNE.png") (S.singleton ImagePremultiplied)
   modifyMVar_ progress (return . (\(p, _) ->
     ( p + increment
     , "Loading asset \"tableNW\""
     )))
-  mtableNW <- createImage nvg (FileName "assets/table/tableNW.png") 0
+  mtableNW <- createImage nvg (FileName "assets/table/tableNW.png") (S.singleton ImagePremultiplied)
   modifyMVar_ progress (return . (\(p, _) ->
     ( p + increment
     , "Loading asset \"tableC1\""
     )))
-  mtablec1 <- createImage nvg (FileName "assets/table/tablec1.png") 0
+  mtablec1 <- createImage nvg (FileName "assets/table/tablec1.png") (S.singleton ImagePremultiplied)
   modifyMVar_ progress (return . (\(p, _) ->
     ( p + increment
     , "Loading asset \"tableC2\""
     )))
-  mtablec2 <- createImage nvg (FileName "assets/table/tablec2.png") 0
+  mtablec2 <- createImage nvg (FileName "assets/table/tablec2.png") (S.singleton ImagePremultiplied)
   modifyMVar_ progress (return . (\(p, _) ->
     ( p + increment
     , "Loading asset \"tableC3\""
     )))
-  mtablec3 <- createImage nvg (FileName "assets/table/tablec3.png") 0
+  mtablec3 <- createImage nvg (FileName "assets/table/tablec3.png") (S.singleton ImagePremultiplied)
   modifyMVar_ progress (return . (\(p, _) ->
     ( p + increment
     , "Loading asset \"tableC4\""
     )))
-  mtablec4 <- createImage nvg (FileName "assets/table/tablec4.png") 0
+  mtablec4 <- createImage nvg (FileName "assets/table/tablec4.png") (S.singleton ImagePremultiplied)
   modifyMVar_ progress (return . (\(p, _) ->
     ( p + increment
     , "Loading asset \"tableCorner\""
     )))
-  mtableC <- createImage nvg (FileName "assets/table/tableCorner.png") 0
+  mtableC <- createImage nvg (FileName "assets/table/tableCorner.png") (S.singleton ImagePremultiplied)
   modifyMVar_ progress (return . (\(p, _) ->
     ( p + increment
     , "Loading asset \"flipchart\""
     )))
-  mmiscFlipchart <- createImage nvg (FileName "assets/misc/flipchart.png") 0
+  mmiscFlipchart <- createImage nvg (FileName "assets/misc/flipchart.png") (S.singleton ImagePremultiplied)
   modifyMVar_ progress (return . (\(p, _) ->
     ( p + increment
     , "Loading asset \"plant1\""
     )))
-  mmiscPlant1 <- createImage nvg (FileName "assets/misc/plant1.png") 0
+  mmiscPlant1 <- createImage nvg (FileName "assets/misc/plant1.png") (S.singleton ImagePremultiplied)
   modifyMVar_ progress (return . (\(p, _) ->
     ( p + increment
     , "Loading asset \"plant2\""
     )))
-  mmiscPlant2 <- createImage nvg (FileName "assets/misc/plant2.png") 0
+  mmiscPlant2 <- createImage nvg (FileName "assets/misc/plant2.png") (S.singleton ImagePremultiplied)
   modifyMVar_ progress (return . (\(p, _) ->
     ( p + increment
     , "Loading asset \"watercooler\""
     )))
-  mmiscWatercooler <- createImage nvg (FileName "assets/misc/watercooler.png") 0
+  mmiscWatercooler <- createImage nvg (FileName "assets/misc/watercooler.png") (S.singleton ImagePremultiplied)
   modifyMVar_ progress (return . (\(p, _) ->
     ( p + increment
     , "Loading asset \"vending machine\""
     )))
-  mmiscVending <- createImage nvg (FileName "assets/misc/vending.png") 0
+  mmiscVending <- createImage nvg (FileName "assets/misc/vending.png") (S.singleton ImagePremultiplied)
   modifyMVar_ progress (return . (\(p, _) ->
     ( p + increment
     , "Loading asset \"Cabinet with Coffee machine SW\""
     )))
-  mcabCoffeeSW <- createImage nvg (FileName "assets/cabinet/cabCoffeeSW.png") 0
+  mcabCoffeeSW <- createImage nvg (FileName "assets/cabinet/cabCoffeeSW.png") (S.singleton ImagePremultiplied)
   modifyMVar_ progress (return . (\(p, _) ->
     ( p + increment
     , "Loading asset \"Cabinet with Coffee machine SE\""
     )))
-  mcabCoffeeSE <- createImage nvg (FileName "assets/cabinet/cabCoffeeSE.png") 0
+  mcabCoffeeSE <- createImage nvg (FileName "assets/cabinet/cabCoffeeSE.png") (S.singleton ImagePremultiplied)
   modifyMVar_ progress (return . (\(p, _) ->
     ( p + increment
     , "Loading asset \"Cabinet with sink SW\""
     )))
-  mcabSinkSW <- createImage nvg (FileName "assets/cabinet/cabSinkSW.png") 0
+  mcabSinkSW <- createImage nvg (FileName "assets/cabinet/cabSinkSW.png") (S.singleton ImagePremultiplied)
   modifyMVar_ progress (return . (\(p, _) ->
     ( p + increment
     , "Loading asset \"Cabinet with sink SE\""
     )))
-  mcabSinkSE <- createImage nvg (FileName "assets/cabinet/cabSinkSE.png") 0
+  mcabSinkSE <- createImage nvg (FileName "assets/cabinet/cabSinkSE.png") (S.singleton ImagePremultiplied)
   modifyMVar_ progress (return . (\(p, _) ->
     ( p + increment
     , "Loading asset \"Cabinet with stove SW\""
     )))
-  mcabStoveSW <- createImage nvg (FileName "assets/cabinet/cabStoveSW.png") 0
+  mcabStoveSW <- createImage nvg (FileName "assets/cabinet/cabStoveSW.png") (S.singleton ImagePremultiplied)
   modifyMVar_ progress (return . (\(p, _) ->
     ( p + increment
     , "Loading asset \"Cabinet with stove SE\""
     )))
-  mcabStoveSE <- createImage nvg (FileName "assets/cabinet/cabStoveSE.png") 0
+  mcabStoveSE <- createImage nvg (FileName "assets/cabinet/cabStoveSE.png") (S.singleton ImagePremultiplied)
   modifyMVar_ progress (return . (\(p, _) ->
     ( p + increment
     , "Loading asset \"cabinet SW\""
     )))
-  mcabinetSW <- createImage nvg (FileName "assets/cabinet/cabinetSW.png") 0
+  mcabinetSW <- createImage nvg (FileName "assets/cabinet/cabinetSW.png") (S.singleton ImagePremultiplied)
   modifyMVar_ progress (return . (\(p, _) ->
     ( p + increment
     , "Loading asset \"cabinet SE\""
     )))
-  mcabinetSE <- createImage nvg (FileName "assets/cabinet/cabinetSE.png") 0
+  mcabinetSE <- createImage nvg (FileName "assets/cabinet/cabinetSE.png") (S.singleton ImagePremultiplied)
   modifyMVar_ progress (return . (\(p, _) ->
     ( p + increment
     , "Loading asset \"cabinet corner\""
     )))
-  mcabinetCorner <- createImage nvg (FileName "assets/cabinet/cabinetCorner.png") 0
+  mcabinetCorner <- createImage nvg (FileName "assets/cabinet/cabinetCorner.png") (S.singleton ImagePremultiplied)
   let micons =
         [ mcontrblue, mcontrgreen, mkbdblue, mkbdgreen, marrow
         ]
@@ -335,6 +337,18 @@ loadFork ws win glc nvg future progress = do
     )))
   jdoemWalking <- loadAnimationSprites "assets/jdoem.png" nvg
     (zip (walkIds AnimJDoeM) walkConfigs)
+  modifyMVar_ progress (return . (\(p, _) ->
+    ( p + increment
+    , "Loading Animation \"policem: standing\""
+    )))
+  policemStanding <- loadAnimationSprites "assets/policem.png" nvg
+    (zip (standIds AnimPoliceM) standConfigs)
+  modifyMVar_ progress (return . (\(p, _) ->
+    ( p + increment
+    , "Loading Animation \"policem: walking\""
+    )))
+  policemWalking <- loadAnimationSprites "assets/policem.png" nvg
+    (zip (walkIds AnimPoliceM) walkConfigs)
   modifyMVar_ progress (return . (\(p, _) ->
     ( p + increment
     , "Loading Animation \"copier: stand\""
@@ -491,9 +505,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
@@ -503,6 +521,8 @@ loadFork ws win glc nvg future progress = do
           playerWalking ++
           jdoemStanding ++
           jdoemWalking ++
+          policemStanding ++
+          policemWalking ++
           copierStand ++
           copierCopy ++
           cornerComputerOff ++
@@ -525,30 +545,24 @@ loadFork ws win glc nvg future progress = do
       }
     )
 
-drawLoad :: Affection UserData ()
+drawLoad :: UserData -> Affection ()
-drawLoad = do
+drawLoad ud = do
-  ud <- getAffection
   progress <- liftIO $ readMVar (stateProgress ud)
   liftIO $ do
-    logIO A.Verbose ("LoadProgress: " ++ show progress)
+    logIO A.Verbose ("LoadProgress: " <> fromString (show progress))
     drawLoadScreen ud progress
 
-updateLoad :: Double -> Affection UserData ()
+updateLoad :: UserData -> Double -> Affection ()
-updateLoad _ = do
+updateLoad ud _ = do
-  ud <- getAffection
   mwsld <- liftIO $ tryTakeMVar (stateMVar ud)
   case mwsld of
     Just (_, ld) -> do
       liftIO $ logIO A.Debug "loaded assets, entering menu"
-      putAffection ud
+      void $ liftIO $ swapMVar (assetImages ud) (loadAssetImages ld)
-        { assetImages     = loadAssetImages ld
+      void $ liftIO $ swapMVar (assetAnimations ud) (loadAssetAnims ld)
-        , assetAnimations = loadAssetAnims ld
+      void $ liftIO $ swapMVar (assetIcons ud) (loadAssetIcons ld)
-        , assetIcons      = loadAssetIcons ld
+      void $ liftIO $ swapMVar (stateData ud) None
-        -- , state           = Main WorldMap
-        -- , state           = Menu Connect
-        , stateData       = None
-        }
       -- loadMap
-      loadMenu
+      loadMenu ud
     Nothing ->
       return ()

src/Main.hs

@@ -4,7 +4,6 @@ module Main where
 import Affection as A
 
 import Data.Ecstasy
-import Data.Ecstasy.Types
 
 import qualified SDL
 
@@ -16,7 +15,9 @@ import Foreign.C.Types (CInt(..))
 
 import Data.Maybe (fromJust)
 
-import Control.Monad (when)
+import Control.Monad
+import Control.Concurrent.MVar
+import Control.Monad.Trans.Resource (allocate)
 
 -- internal imports
 
@@ -28,101 +29,108 @@ 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
-        { initComponents = All
+        { initComponents  = All
-        , windowTitle    = "Tracer"
+        , windowTitle     = "Tracer"
-        , windowConfig   = SDL.defaultWindow
+        , windowConfigs   =
-          { SDL.windowInitialSize = V2 1280 720
+          [ ( 0
-          , SDL.windowResizable   = True
+            , SDL.defaultWindow
-          , SDL.windowOpenGL      = Just SDL.defaultOpenGL
+              { SDL.windowInitialSize     = V2 1920 1080
-            { SDL.glProfile = SDL.Core SDL.Normal 3 3
+              , SDL.windowResizable       = True
-            }
+              , SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL
-          }
+                { SDL.glProfile = SDL.Core SDL.Normal 3 3
-        , canvasSize     = Nothing
+                }
-        , preLoop        = pre >> smLoad Load
+              }
-        , eventLoop      = handle
+            , SDL.Windowed
-        , updateLoop     = update
+            )
-        , drawLoop       = draw
+          ]
-        , loadState      = Init.init
+        } :: AffectionConfig UserData
-        , cleanUp        = clean
-        , initScreenMode = SDL.Windowed
-        }
   withAffection config
 
-pre :: Affection UserData ()
+pre :: UserData -> Affection ()
-pre = do
+pre ud = do
   ad <- A.get
-  ud <- getAffection
+  let (AffectionWindow awwindow _ _) = head $ drawWindows ad
-  threadCtx <- SDL.glCreateContext (drawWindow ad)
+  threadCtx <- SDL.glCreateContext awwindow
-  SDL.glMakeCurrent (drawWindow ad) (glContext ad)
+  SDL.glMakeCurrent awwindow (acContext $ head $ glContext ad)
-  let Subsystems w m k j t = subsystems ud
+  let Subsystems w _ k j _ = subsystems ud
-  _ <- partSubscribe w (fitViewport (1280/720))
+  _ <- partSubscribe w (fitViewport (1920/1080))
-  _ <- 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 (SystemState 0 defStorage defHooks) (return ())
+  (ws, _) <- yieldSystemT (0, defStorage) (return ())
-  putAffection ud
+  void $ liftIO $ swapMVar (threadContext ud) (Just threadCtx)
-    { threadContext = Just threadCtx
+  void $ liftIO $ swapMVar (window ud) (Just awwindow)
-    , window     = Just (drawWindow 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
-      SDL.glMakeCurrent (drawWindow ad) (glContext ad)
+      mapM_ (partUnSubscribe t) curUUID
-      (ws, _) <- yieldSystemT (SystemState 0 defStorage defHooks) (return ())
+      SDL.glMakeCurrent
-      putAffection ud
+        (awWindow $ head $ drawWindows ad)
-        { worldState = ws
+        (acContext $ head $ glContext ad)
-        , state = Load
+      (ws, _) <- yieldSystemT (0, defStorage) (return ())
-        }
+      void $ liftIO $ swapMVar (worldState ud) ws
-      smLoad Load
+      void $ liftIO $ swapMVar (state ud) Load
-  | otherwise                                  = return ()
+      smLoad Load ud
-quitGame _ = return ()
+  | 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 :: 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

@@ -11,9 +11,13 @@ import qualified Data.Text as T
 import Data.List as L
 import Data.Ecstasy as E
 import Data.Maybe
+import Data.String
 
 import NanoVG hiding (V2(..))
 
+import Control.Concurrent.MVar
+import Control.Monad
+
 -- internal imports
 
 import Types
@@ -24,145 +28,146 @@ 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)
-   emap allEnts $ do
+  (nws, _) <- yieldSystemT wState $ do
-     with player
+    emap allEnts $ do
-     with xyvel
+      with player
-     with mmvel
+      with xyvel
-     V2 rx ry <- query xyvel
+      with mmvel
-     -- let dr = (ry / sin (atan (1/2)) / 2) + rx
+      V2 rx ry <- query xyvel
-     --     dc = rx - (ry / sin (atan (1/2)) / 2)
+      -- let dr = (ry / sin (atan (1/2)) / 2) + rx
-     let V2 dr dc = fmap (* 1.5) (V2 rx ry `rotVec` 45)
+      --     dc = rx - (ry / sin (atan (1/2)) / 2)
-     return $ unchanged
+      let V2 dr dc = fmap (* 1.5) (V2 rx ry `rotVec` 45)
-       { mmvel = Set $ 2 * V2 dr dc
+      return $ unchanged
-       }
+        { mmvel = Set $ 2 * V2 dr dc
-   emap allEnts $ do
+        }
-     with anim
+    emap allEnts $ do
-     with mmpos
+      with anim
-     stat <- query anim
+      with mmpos
-     let an = assetAnimations ud Map.! asId stat
+      stat <- query anim
-         ntime = asElapsedTime stat + dt
+      aAnims <- liftIO $ readMVar (assetAnimations ud)
-         nstate = if ntime > fromIntegral (asCurrentFrame stat) *
+      let an = aAnims Map.! asId stat
-           (animDuration an / fromIntegral (length $ animSprites an))
+          ntime = asElapsedTime stat + dt
-           then
+          nstate = if ntime > fromIntegral (asCurrentFrame stat) *
-             let nframe = asCurrentFrame stat + 1
+            (animDuration an / fromIntegral (length $ animSprites an))
-             in  case animPlay an of
+            then
-                   APLoop ->
+              let nframe = asCurrentFrame stat + 1
-                     let (nnframe, nntime) =
+              in  case animPlay an of
-                           if nframe >= length (animSprites an)
+                    APLoop ->
-                           then (0, 0)
+                      let (nnframe, nntime) =
-                           else (nframe, ntime)
+                            if nframe >= length (animSprites an)
-                     in  stat
+                            then (0, 0)
-                           { asCurrentFrame = nnframe
+                            else (nframe, ntime)
-                           , asElapsedTime  = nntime
+                      in  stat
-                           }
+                            { asCurrentFrame = nnframe
-                   APOnce ->
+                            , asElapsedTime  = nntime
-                     let nnframe = if nframe >= length (animSprites an)
+                            }
-                           then nframe - 1
+                    APOnce ->
-                           else nframe
+                      let nnframe = if nframe >= length (animSprites an)
-                     in  stat
+                            then nframe - 1
-                           { asCurrentFrame = nnframe
+                            else nframe
-                           , asElapsedTime  = ntime
+                      in  stat
-                           }
+                            { asCurrentFrame = nnframe
-           else
+                            , asElapsedTime  = ntime
-             stat
+                            }
-               { asElapsedTime = ntime
+            else
-               }
+              stat
-     return $ unchanged
+                { asElapsedTime = ntime
-       { anim = Set nstate
+                }
-       }
+      return $ unchanged
-   emap allEnts $ do
+        { anim = Set nstate
-     with player
+        }
-     with mmvel
+    emap allEnts $ do
-     with mmpos
+      with player
-     with rot
+      with mmvel
-     with anim
+      with mmpos
-     pos'@(V2 pr pc) <- query mmpos
+      with rot
-     vel' <- query mmvel
+      with anim
-     rot' <- query rot
+      pos'@(V2 pr pc) <- query mmpos
-     stat <- query anim
+      vel' <- query mmvel
-     let npos = pos' + fmap (* dt) vel'
+      rot' <- query rot
-         dpos@(V2 dpr dpc) = npos - pos'
+      stat <- query anim
-         aId = asId stat
+      let npos = pos' + fmap (* dt) vel'
-         nstat = case aiName aId of
+          dpos@(V2 dpr dpc) = npos - pos'
-           "walking"
+          aId = asId stat
-             | sqrt (colldpos `dot` colldpos) > 0 ->
+          nstat = case aiName aId of
-               stat
+            "walking"
-                 { asId = aId
+              | sqrt (colldpos `dot` colldpos) > 0 ->
-                   { aiDirection = fromMaybe rot' (direction vel')
+                stat
-                   }
+                  { asId = aId
-                 }
+                    { aiDirection = fromMaybe rot' (direction vel')
-             | otherwise ->
+                    }
-               stat
+                  }
-                 { asId = aId
+              | otherwise ->
-                   { aiDirection = fromMaybe rot' (direction vel')
+                stat
-                   , aiName = "standing"
+                  { asId = aId
-                   }
+                    { aiDirection = fromMaybe rot' (direction vel')
-                 , asCurrentFrame = 0
+                    , aiName = "standing"
-                 }
+                    }
-           "standing"
+                  , asCurrentFrame = 0
-             | sqrt (colldpos `dot` colldpos) > 0 ->
+                  }
-               stat
+            "standing"
-                 { asId = aId
+              | sqrt (colldpos `dot` colldpos) > 0 ->
-                   { aiDirection = fromMaybe rot' (direction vel')
+                stat
-                   , aiName = "walking"
+                  { asId = aId
-                   }
+                    { aiDirection = fromMaybe rot' (direction vel')
-                 , asCurrentFrame = 0
+                    , aiName = "walking"
-                 }
+                    }
-             | otherwise ->
+                  , asCurrentFrame = 0
-               stat
+                  }
-                 { asId = aId
+              | otherwise ->
-                   { aiDirection = fromMaybe rot' (direction vel')
+                stat
-                   }
+                  { asId = aId
-                 }
+                    { aiDirection = fromMaybe rot' (direction vel')
-           x -> error ("unknown animation name" ++ x)
+                    }
-         lll = (,)
+                  }
-           <$> (
+            x -> error ("unknown animation name" ++ x)
-             if dpr < 0
+          lll = (,)
-             then [(floor dpr :: Int) .. 0]
+            <$> (
-             else [0 .. (ceiling dpr :: Int)])
+              if dpr < 0
-           <*> (
+              then [(floor dpr :: Int) .. 0]
-             if dpc < 0
+              else [0 .. (ceiling dpr :: Int)])
-             then [(floor dpc :: Int) .. 0]
+            <*> (
-             else [0 .. (ceiling dpc :: Int)])
+              if dpc < 0
-         colldpos = dpos * Prelude.foldl
+              then [(floor dpc :: Int) .. 0]
-           (\acc a -> let ret = checkBoundsCollision2 pos' npos dt acc a
+              else [0 .. (ceiling dpc :: Int)])
-             in A.log A.Verbose (show ret) ret)
+          colldpos = dpos * Prelude.foldl
-           (V2 1 1)
+            (\acc a -> let ret = checkBoundsCollision2 pos' npos dt acc a
-           (
+              in A.log A.Verbose (fromString $ show ret) ret)
-             concatMap
+            (V2 1 1)
-             (\(dr, dc) ->
+            (
-               let bs = maybe [] collisionObstacle (fromMaybe Nothing $ M.safeGet
+              concatMap
-                     (fromIntegral $ floor pr + dr)
+              (\(dr, dc) ->
-                     (fromIntegral $ floor pc + dc)
+                let bs = fromMaybe [] $ collisionObstacle <$> M.unsafeGet
-                     (mmImgMat (stateData ud)))
+                      (fromIntegral $ floor pr + dr)
-               in  Prelude.map (\(Boundaries (minr, minc) (maxr, maxc))->
+                      (fromIntegral $ floor pc + dc)
-                     Boundaries
+                      (mmImgMat sData)
-                       (minr + fromIntegral dr, minc + fromIntegral dc)
+                in  Prelude.map (\(Boundaries (minr, minc) (maxr, maxc))->
-                       (maxr + fromIntegral dr, maxc + fromIntegral dc)
+                      Boundaries
-                     ) bs
+                        (minr + fromIntegral dr, minc + fromIntegral dc)
-               )
+                        (maxr + fromIntegral dr, maxc + fromIntegral dc)
-             lll -- (A.log A.Verbose (show lll ++ " " ++ show len) lll)
+                      ) bs
-             )
+                )
-         ent = unchanged
+              lll -- (A.log A.Verbose (show lll ++ " " ++ show len) lll)
-           { mmpos = Set $ pos' + colldpos
+              )
-           , rot = Set (fromMaybe rot' $ direction vel')
+          ent = unchanged
-           , anim = Set nstat
+            { mmpos = Set $ pos' + colldpos
-           }
+            , rot = Set (fromMaybe rot' $ direction vel')
-     return ent
+            , anim = Set nstat
- putAffection ud
+            }
-   { worldState = nws
+      return ent
-   }
+  void $ liftIO $ swapMVar (worldState ud) 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
@@ -176,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
@@ -184,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 ->
@@ -194,8 +199,8 @@ drawMind = do
               )
             ([], posanims)
             ((,)
-              <$> [1 .. (nrows $ mmImgMat $ stateData ud)]
+              <$> [1 .. (nrows $ mmImgMat $ sData)]
-              <*> [1 .. (ncols $ mmImgMat $ stateData ud)]
+              <*> [1 .. (ncols $ mmImgMat $ sData)]
               )
             )
           )
@@ -229,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,8 +11,8 @@ 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.Monad.Trans.Resource (ResIO, runResourceT)
 import Control.Concurrent.MVar
 import Control.Concurrent (forkIO)
 import Control.Parallel.Strategies hiding (dot)
@@ -23,7 +23,9 @@ import qualified Data.Text as T
 import Data.Matrix as M
 import Data.Ecstasy as E
 import Data.Maybe
-import Data.List as L (sortOn, partition, find)
+import Data.List as L
+import qualified Data.Vector as V
+import Data.String
 
 import System.Random (randomRIO)
 
@@ -42,63 +44,49 @@ import NPC
 import Animation
 import Collision
 
-loadMap :: Affection UserData ()
+loadMap :: UserData -> Affection ()
-loadMap = do
+loadMap ud = do
-  ud <- getAffection
   ad <- get
-  let (Subsystems _ m k j t) = subsystems ud
+  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 ResIO), StateData)
   -> MVar (Float, T.Text)
   -> IO ()
 loadMapFork ud ad future progress = do
@@ -107,7 +95,7 @@ loadMapFork ud ad future progress = do
       fc = FloorConfig
         (V2 10 10)
         [(V2 5 5), (V2 5 20)]
-        (50, 50)
+        (40, 40)
   modifyMVar_ progress (return . (\(p, _) ->
     ( p + increment
     , "Building floor"
@@ -136,13 +124,14 @@ loadMapFork ud ad future progress = do
     ( p + increment
     , "Placing furniture"
     )))
-  (!inter, !rawrps) <- placeInteriorIO mat imgmat exits gr
+  (!inter, !rawrps) <- placeInteriorIO mat imgmat exits (V.toList gr)
   let !rps = ReachPoint Elevator (fcElevator fc) SE 0 : rawrps
   modifyMVar_ progress (return . (\(p, _) ->
     ( p + increment
     , "Creating WorldState"
     )))
-  (nws, mmimgmat) <- evalStateT (runState (yieldSystemT (worldState ud) $ do
+  wState <- liftIO $ readMVar (worldState ud)
+  (nws, mmimgmat) <- runResourceT $ evalStateT (runState (yieldSystemT wState $ do
     liftIO $ modifyMVar_ progress (return . (\(p, _) ->
       ( p + increment
       , "Registering copiers into WorldState"
@@ -158,7 +147,12 @@ loadMapFork ud ad future progress = do
         , objType   = Just ObjCopier
         , objState  = Just "idle"
         }
-      ) (A.log A.Debug ("number of copiers: " ++ show (length copiers)) copiers)
+      )
+      (A.log
+        A.Debug
+        ("number of copiers: " <> fromString (show $ length copiers))
+        copiers
+        )
     liftIO $ modifyMVar_ progress (return . (\(p, _) ->
       ( p + increment
       , "Registering computers into WorldState"
@@ -179,7 +173,12 @@ loadMapFork ud ad future progress = do
         , objType   = Just ObjComputer
         , objState  = Just "off"
         }
-      ) (A.log A.Debug ("number of computers: " ++ show (length computers)) computers)
+      )
+      (A.log
+        A.Debug
+        ("number of computers: " <> fromString (show $ length computers))
+        computers
+        )
     liftIO $ modifyMVar_ progress (return . (\(p, _) ->
       ( p + increment
       , "Registering toilets into WorldState"
@@ -194,7 +193,12 @@ loadMapFork ud ad future progress = do
         , objAccess = Just [(V2 0 (-1), dir)]
         , objType   = Just ObjToilet
         }
-      ) (A.log A.Debug ("number of toilets: " ++ show (length toilets)) toilets)
+      )
+      (A.log
+        A.Debug
+        ("number of toilets: " <> fromString (show  $ length toilets))
+        toilets
+        )
     liftIO $ modifyMVar_ progress (return . (\(p, _) ->
       ( p + increment
       , "Preparing MindMap graph"
@@ -229,7 +233,9 @@ loadMapFork ud ad future progress = do
       , clearanceLvl  = Just 0
       , anim          = Just $ AnimState (AnimId AnimIntruder "standing" SE) 0 0
       }
-    liftIO $ A.logIO A.Debug $ "number of placed NPCs: " ++ show (length computers)
+    liftIO $ A.logIO
+      A.Debug
+      ("number of placed NPCs: " <> fromString (show $ length computers))
     liftIO $ modifyMVar_ progress (return . (\(p, _) ->
       ( p + increment
       , "Registering NPCs into WorldState"
@@ -243,22 +249,25 @@ loadMapFork ud ad future progress = do
         <*> (randomRIO (0, 1))
         <*> (randomRIO (0, 1))
         <*> (randomRIO (0, 1))
-      let room = head
+      police <- liftIO $ randomRIO (0 :: Int, 9 :: Int)
-            (Prelude.filter
+      let room = V.head
+            (V.filter
               ((inBounds $ pointCoord cpr) . bounds)
-              (Types.connects (head gr) ++ tail gr)
+              (V.fromList $
+                V.toList (Types.connects (V.head gr)) ++ (V.toList (V.tail gr)))
               )
       void $ createEntity $ newEntity
         { pos            = Just (fmap ((+ 0.5) . fromIntegral) (pointCoord cpr))
         , vel            = Just (V2 0 0)
         , velFact        = Just fact
         , rot            = Just SE
-        , npcMoveState   = Just (NPCWalking [pointCoord cpr])
+        , npcMoveState   = Just (NPCWalking [[pointCoord cpr]])
         , npcWorkplace   = Just cpr
         , npcActionState = Just ASWork
         , npcStats       = Just stats
         , clearanceLvl   = Just (clearance room)
-        , anim           = Just $ AnimState (AnimId AnimJDoeM "standing" SE) 0 0
+        , anim           = Just $ AnimState
+          (AnimId (if police == 0 then AnimPoliceM else AnimJDoeM) "standing" SE) 0 0
         }
       ) computers
     liftIO $ modifyMVar_ progress (return . (\(p, _) ->
@@ -266,17 +275,18 @@ loadMapFork ud ad future progress = do
       , "Registering doors into WorldState"
       )))
     mapM_ (\door -> do
-      let rooms = Prelude.foldl
+      let rooms = V.foldl
             (\acc coord ->
-              let rs = Prelude.filter ((inBounds coord) . bounds) graph
+              let rs = V.filter ((inBounds coord) . bounds) graph
               in
-                if not (Prelude.null rs)
+                if not (V.null rs)
-                then (coord, head rs) : acc
+                then (coord, V.head rs) `V.cons` acc
                 else acc
               )
-            []
+            V.empty
-            coords
+            (V.fromList coords)
-          graph = Types.connects (head gr) ++ tail gr
+          graph = V.fromList $
+            (V.toList $ Types.connects (V.head gr)) ++ (V.toList $ V.tail gr)
           coords = Prelude.map (door +) deltas
           deltas =
             [ V2 0 1
@@ -285,18 +295,19 @@ loadMapFork ud ad future progress = do
             , V2 0 (-1)
             ]
           wall = Prelude.filter
-            (\delta ->
+            (\ddelta ->
-              let V2 r c = door + delta
+              let V2 r c = door + ddelta
               in
                 fromMaybe False (isWall <$> imgmat M.! (r, c)))
             deltas
           orientation
             | head wall == V2 0 1 || head wall == V2 0 (-1) = NW
             | head wall == V2 1 0 || head wall == V2 (-1) 0 = NE
-            | otherwise                                     = error ("strange wall: " ++ show wall)
+            | otherwise = error ("strange wall: " ++ show wall)
       void $ createEntity $ newEntity
         { pos            = Just (fmap ((+ 0.5) . fromIntegral) door)
-        , clearanceLvl   = Just (maximum $ 0 : Prelude.map clearance (Prelude.map snd rooms))
+        , clearanceLvl   = Just (V.maximum $
+          0 `V.cons` V.map clearance (V.map snd rooms))
         , anim           = Just $ AnimState (AnimId AnimDoor0 "shut" orientation) 0 1
         , obstacle       = Just $ case orientation of
           NW -> Boundaries (4/9, 0) (5/9, 1)
@@ -330,19 +341,19 @@ 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 = rps
+      , reachPoints = V.fromList rps
       , mmImgMat = mmimgmat
       , 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
@@ -352,12 +363,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
@@ -367,12 +376,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
@@ -382,12 +389,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
@@ -397,16 +402,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
@@ -418,66 +421,12 @@ movePlayer2 (ActionMessage mov _) = do
           ActRight f -> V2 f vy
           _          -> V2 vx vy
         }
-  putAffection ud
+  void $ liftIO $ swapMVar (worldState ud) nws
-    { worldState = nws
-    }
-movePlayer2 _ = return ()
 
-playerInteract :: MouseMessage -> Affection UserData ()
+playerInteract2 :: UserData -> ActionMessage -> Affection ()
-playerInteract (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonRight _ m) = do
+playerInteract2 ud (ActionMessage ActActivate _) = do
-  ud <- getAffection
+  wState <- liftIO $ readMVar (worldState ud)
-  (V2 rx ry) <- liftIO $ (* V2 640 360) <$> relativizeMouseCoords m
+  (nws, _) <- yieldSystemT wState $ do
-  let dr = ((ry / 32) / sin (atan 0.5) / 2) + (rx / 64)
-      dc = (rx / 64) - ((ry / 32) / sin (atan 0.5) / 2)
-  (nws, _) <- yieldSystemT (worldState ud) $ do
-    emap allEnts $ do
-      with player
-      with rot
-      rot' <- query rot
-      let ndir = direction (V2 dr dc)
-      return $ unchanged
-        { rot = Set $ fromMaybe rot' ndir
-        }
-    pdata <- efor allEnts $ do
-      with player
-      with pos
-      with rot
-      pos' <- query pos
-      rot' <- query rot
-      ent <- queryEnt
-      return (pos', rot', ent)
-    let (ppos, pdir, pent) = head pdata
-    mrelEnts <- efor allEnts $ do
-      with pos
-      with objAccess
-      with objType
-      with objState
-      reldirs <- query objAccess
-      pos' <- query pos
-      otype <- query objType
-      ostate <- query objState
-      ent <- queryEnt
-      if any (\(rel, dir) -> ((fmap floor ppos :: V2 Int) == (fmap floor pos' :: V2 Int) ||
-        (fmap floor ppos :: V2 Int) == (fmap floor pos' :: V2 Int) + rel) &&
-        (fmap floor (ppos + V2 dr dc) :: V2 Int) == (fmap floor pos' ::V2 Int) &&
-        pdir == dir) reldirs
-      then return $ Just (otype, ostate, ent)
-      else return Nothing
-    let relEnts = catMaybes mrelEnts
-    liftIO $ A.logIO A.Debug ("relEnts: " ++ show relEnts)
-    -- liftIO $ A.logIO A.Debug ("dV2: " ++ show (V2 dr dc))
-    mapM_ (\(t, s, e) ->
-      setEntity e =<< objectTransition t s True e (Just pent)
-      ) relEnts
-  putAffection ud
-    { worldState = nws
-    }
-playerInteract _ = return ()
-
-playerInteract2 :: ActionMessage -> Affection UserData ()
-playerInteract2 (ActionMessage ActActivate _) = do
-  ud <- getAffection
-  (nws, _) <- yieldSystemT (worldState ud) $ do
     pdata <- efor allEnts $ do
       with player
       with pos
@@ -503,31 +452,30 @@ playerInteract2 (ActionMessage ActActivate _) = do
       then return $ Just (otype, ostate, ent)
       else return Nothing
     let relEnts = catMaybes mrelEnts
-    liftIO $ A.logIO A.Debug ("relEnts: " ++ show relEnts)
+    liftIO $ A.logIO A.Debug ("relEnts: " <> fromString (show relEnts))
     -- liftIO $ A.logIO A.Debug ("dV2: " ++ show (V2 dr dc))
     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
-            player <- queryMaybe player
+            player' <- queryMaybe player
             stat <- queryMaybe anim
             mbnds <- queryMaybe obstacle
             t <- queryMaybe objType
@@ -535,7 +483,7 @@ drawMap = do
             pa <- queryMaybe objPlayerActivated
             ttl <- queryMaybe objStateTime
             let maxt = fromMaybe 1 (actionTime <$> t <*> s)
-                first = if isJust player
+                first = if isJust player'
                   then Just
                     pos'
                   else Nothing
@@ -564,10 +512,10 @@ drawMap = do
             ([], [], [])
             dat
           V2 pr pc = playerPos
-          MainData _ _ _ _ gr = stateData ud
+          MainData _ _ _ _ gr = sData
-          seekGraph = Types.connects (head gr) ++ tail gr
+          seekGraph = V.foldl V.snoc (Types.connects (V.head gr)) (V.tail gr)
-          room = Prelude.filter (inBounds (fmap floor playerPos) . bounds) seekGraph
+          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
@@ -575,8 +523,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 ->
@@ -585,8 +533,8 @@ drawMap = do
                   )
                 ([], posanims)
                 ((,)
-                  <$> [1 .. (nrows $ mapMat $ stateData ud)]
+                  <$> [1 .. (nrows $ mapMat sData)]
-                  <*> [1 .. (ncols $ mapMat $ stateData ud)]
+                  <*> [1 .. (ncols $ mapMat sData)]
                   )
                 )
               )
@@ -615,15 +563,37 @@ drawMap = do
         closePath ctx
         fillColor ctx (rgb 255 255 255)
         fill ctx
-        -- void $ sequence $ parMap rpar
+        let coordList = concatMap
-        mapM_
+              (\(i, ls) -> Prelude.map
-          (\(i, ls) ->
+                (\(j, t) -> ((i, j), t))
-            -- void $ sequence $ parMap rpar
+                (reverse $ zip [1..] ls)
-            mapM_
+                )
-              (\(j, t) -> drawTile ud ctx (partposanims M.! (i, j)) pr pc i j t)
+              (zip [1..] (toLists mat))
-            (reverse $ zip [1..] ls)
+            filterList = Prelude.filter
+              (\((frow, fcol), _) ->
+                ((realToFrac (sx frow fcol) > -tileWidth &&
+                  realToFrac (sy frow fcol) > -tileHeight) &&
+                ((realToFrac (sx frow fcol) :: Double) < 1280 &&
+                (realToFrac ((sy frow fcol)- (74 - (realToFrac tileHeight :: CFloat))) :: Double) < 720))
+                )
+              coordList
+            !posanimList = Prelude.map
+              (\((row, col), tile) -> ((row, col), tile, partposanims M.! (row, col)))
+              filterList
+            sx row col = realToFrac $ 640 + ((fromIntegral col - pc) +
+              (fromIntegral row - pr)) * (tileWidth / 2) :: CFloat
+            sy row col = realToFrac $ 360 - (tileHeight / 2) + ((fromIntegral row - pr) -
+              (fromIntegral col - pc)) * (tileHeight / 2) :: CFloat
+        void $ sequence $ parMap rpar
+        -- mapM_
+          (\((row, col), tile, posanim) ->
+            drawTile ud ctx posanim pr pc row col tile
             )
-          (zip [1..] (toLists mat))
+          posanimList
+        -- void $ sequence $ parMap rpar (\(i, ls) -> void $ sequence $ parMap rpar
+        --     (\(j, t) -> drawTile ud ctx (partposanims M.! (i, j)) pr pc i j t)
+        --     (reverse $ zip [1..] ls))
+        --   (zip [1..] (toLists mat))
         mapM_ (\(V2 sr sc, pa, perc) -> when pa $ do
           let lx = realToFrac $ 640 + ((sc - pc) +
                 (sr - pr)) * (tileWidth / 2) :: CFloat
@@ -642,15 +612,20 @@ 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 (
           "FPS: "
           <> T.pack (Prelude.take 5 $ show (1/dt))
           <> " Clearance: "
-          <> if not (Prelude.null room) then T.pack (show $ clearance $ head room) else "0"
+          <> (if not (Prelude.null room)
+            then T.pack (show $ clearance $ V.head room)
+            else "0"
             )
+          -- <> "\nFor answers call 6350"
+          )
 
 drawTile
   :: UserData
@@ -662,25 +637,23 @@ drawTile
   -> Int
   -> Maybe ImgId
   -> IO ()
-drawTile ud ctx posanims pr pc row col img =
+drawTile ud ctx posanims pr pc row col img = do
-  when ((realToFrac x > -tileWidth && realToFrac y > -tileHeight) &&
+  let (bef, beh) = L.partition delimiter sorted
-    ((realToFrac x :: Double) < 1280 &&
+  aImages <- readMVar (assetImages ud)
-    (realToFrac (y - (74 - (realToFrac tileHeight :: CFloat))) :: Double) < 720)) $
+  save ctx
-      do
+  mapM_ (flip drawAnim fact) beh
-        let (bef, beh) = L.partition delimiter sorted
+  maybe (return ()) (Types.draw ud x (y - 42) 64 74
-        save ctx
+    (if fromMaybe False (isWall <$> img) then fact else 1))
-        mapM_ drawAnim beh
+    ((aImages Map.!) <$> case img of
-        maybe (return ()) (draw ud x (y - 42) 64 74 fact)
+      Just ImgEmpty -> Nothing
-          ((assetImages ud Map.!) <$> case img of
+      _ -> img
-            Just ImgEmpty -> Nothing
+      )
-            _ -> img
+  mapM_ (flip drawAnim fact) bef
-            )
+  restore ctx
-        mapM_ drawAnim bef
+  -- when (floor pr == row && floor pc == col) $ do
-        restore ctx
+  --   A.logIO A.Debug ("sorted: " ++ show sorted)
-        -- when (floor pr == row && floor pc == col) $ do
+  --   A.logIO A.Debug ("beh: " ++ show beh)
-        --   A.logIO A.Debug ("sorted: " ++ show sorted)
+  --   A.logIO A.Debug ("bef: " ++ show bef)
-        --   A.logIO A.Debug ("beh: " ++ show beh)
-        --   A.logIO A.Debug ("bef: " ++ show bef)
   where
     delimiter (V2 nr nc, as, mbnds) =
       animFloats (asId as) ||
@@ -704,7 +677,8 @@ drawTile ud ctx posanims pr pc row col img =
     tileWidth = 64 :: Double
     tileHeight = 32 :: Double
     sorted = sortOn (\(V2 sr sc, _, mbnds) ->
-      let comp srow scol = (floor $ (1 - scol) * 100) + (floor $ srow * 100)
+      let comp srow scol =
+            ((floor $ (1 - scol) * 100) :: Int) + ((floor $ srow * 100) :: Int)
       in
         case mbnds of
           Just (Boundaries (minr, minc) (maxr, maxc)) ->
@@ -725,38 +699,38 @@ drawTile ud ctx posanims pr pc row col img =
     dist = distance (V2 (fromIntegral row) (fromIntegral col))
       (V2 (realToFrac pr - 1) (realToFrac pc)) / 4
     fact =
-      if isWall (fromJust img) &&
+      if pr <= fromIntegral row + (if L.null maxrs then 0.5 else minimum maxrs) &&
-         (pr <= fromIntegral row + minimum maxrs &&
+         pc >= fromIntegral col + (if L.null mincs then 0.5 else maximum mincs)
-         pc >= fromIntegral col + maximum mincs)
       then min 1 dist
       else 1
     mb = maybe [] collisionObstacle img
-    drawAnim (V2 nr nc, as, _) = do
+    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 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
@@ -766,11 +740,12 @@ updateMap dt = do
       emap allEnts $ do
         pos'@(V2 pr pc) <- query pos
         vel' <- queryMaybe vel
-        rot' <- query rot
+        rot' <- fromMaybe N <$> queryMaybe rot
         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 sData
             ntime = asElapsedTime stat + dt
             npos = pos' + fmap (* (dt * fact')) (fromMaybe (V2 0 0) vel')
             dpos@(V2 dpr dpc) = npos - pos'
@@ -787,16 +762,16 @@ updateMap dt = do
             colldpos = dpos * Prelude.foldl
               (\acc a ->
                 let ret = checkBoundsCollision2 pos' npos dt acc a
-                in A.log A.Verbose (show ret) ret)
+                in A.log A.Verbose (fromString $ show ret) ret)
               (V2 1 1)
               (
-                concatMap
+                nub $ concatMap
                 (\(dr, dc) ->
                   let bs = (++)
-                        (maybe [] collisionObstacle (fromMaybe Nothing $ M.safeGet
+                        (fromMaybe [] $ collisionObstacle <$> M.unsafeGet
-                          (fromIntegral $ floor pr + dr)
+                          (min (nrows mat) $ max 1 $ fromIntegral $ floor pr + dr)
-                          (fromIntegral $ floor pc + dc)
+                          (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 &&
@@ -871,7 +846,7 @@ updateMap dt = do
                           { aiDirection = fromMaybe rot' (direction velo)
                           }
                         }
-                  x -> nstat
+                  _ -> nstat
             ent = unchanged
               { pos  = Set $ pos' + colldpos
               , rot  = Set $ fromMaybe rot' (direction (fromMaybe (V2 0 0) vel'))
@@ -885,16 +860,16 @@ updateMap dt = do
                 Nothing -> Keep
               }
         return ent
-      allRelEnts <- efor allEnts $ do
+      -- allRelEnts <- efor allEnts $ do
-        with pos
+      --   with pos
-        with rot
+      --   with rot
-        with clearanceLvl
+      --   with clearanceLvl
-        without objType
+      --   without objType
-        pos' <- query pos
+      --   pos' <- query pos
-        rot' <- query rot
+      --   rot' <- query rot
-        clvl <- query clearanceLvl
+      --   clvl <- query clearanceLvl
-        entn <- queryEnt
+      --   entn <- queryEnt
-        return (entn, pos', rot', clvl)
+      --   return (entn, pos', rot', clvl)
       tses <- efor allEnts $ do
         with objType
         with objState
@@ -903,16 +878,15 @@ updateMap dt = do
         e <- queryEnt
         return (t, s, e)
       mapM_ (\(t, s, e) ->
-        objectAction allRelEnts dt t s e
+        objectAction dt t s e
         ) tses
     (nws2, _) <- yieldSystemT nws $ updateNPCs
-      (imgMat $ stateData ud)
+      (imgMat sData)
+      (mapMat sData)
       nws
-      (Prelude.filter
+      (V.filter
         (\p -> pointType p /= RoomExit)
-        (reachPoints $ stateData ud)
+        (reachPoints sData)
         )
       dt
-    putAffection ud
+    void $ liftIO $ swapMVar (worldState ud) nws2
-      { worldState = nws2
-      }

src/Menu/Adjust.hs

@@ -10,91 +10,74 @@ import qualified Data.Map.Strict as M
 import qualified Data.Set as S
 import Data.List (find)
 import Data.Maybe (fromJust, isJust)
+import Data.String (fromString)
+
+import Control.Monad
+
+import Control.Concurrent.MVar
 
 -- internal imports
 
 import Types
 import Util
 
-loadAdjust :: Action -> Controller -> Affection UserData () -> Affection UserData ()
+loadAdjust :: UserData -> Action -> Controller -> Affection () -> Affection ()
-loadAdjust sub contr switchBack = do
+loadAdjust ud sub contr switchBack = do
-  ud <- getAffection
+  let Subsystems _ _ _ j _ = subsystems ud
-  let Subsystems w m k j t = subsystems ud
+  uu1 <- partSubscribe j (joyListener ud switchBack)
-  uu1 <- partSubscribe j (joyListener switchBack)
+  void $ liftIO $ swapMVar (state ud) (Menu (Adjust sub contr))
-  putAffection ud
+  void $ liftIO $ swapMVar (uuid ud) [uu1]
-    { state = Menu (Adjust sub contr)
-    , uuid = [ uu1 ]
-    }
 
-joyListener :: Affection UserData () -> JoystickMessage -> Affection UserData ()
+joyListener :: UserData -> Affection () -> JoystickMessage -> Affection ()
-joyListener switchBack (MsgJoystickAxis _ _ axis val) = do
+joyListener ud switchBack message = do
-  ud <- getAffection
+  curState <- liftIO $ readMVar (state ud)
-  liftIO $ logIO A.Debug ("switching " ++ show (state ud) ++ " to " ++ show axis)
+  trans <- liftIO $ readMVar (translation ud)
-  let trans = translation ud
+  case message of
-      align
+    MsgJoystickAxis _ _ axis val -> do
-        | val > 0 = AxisPositive
+      let align
-        | val < 0 = AxisNegative
+            | val > 0 = AxisPositive
-        | otherwise = A.log A.Error "Can not assign neitral axis align" (error "*dies*")
+            | val < 0 = AxisNegative
-  case trans of
+            | otherwise = A.log A.Error "Can not assign neitral axis align" (error "*dies*")
-    JoyTranslation tmap -> do
+      case trans of
-      case state ud of
+        JoyTranslation tmap -> do
-        Menu (Adjust (ActUp s) (Joystick _)) -> do
+          let (Menu (Adjust cact (Joystick _))) = curState
-          let k = fst <$> find (\(_, v) -> v == ActUp 1) (M.assocs tmap)
+              act = case cact of
-          putAffection ud
+                ActUp _ -> ActUp 1
-            { translation = JoyTranslation $
+                ActDown _ -> ActDown 1
-              M.insert (AxisAction (fromIntegral axis) align) (ActUp 1) $
+                ActLeft _ -> ActLeft 1
-                if isJust k then M.delete (fromJust k) (tmap) else tmap
+                ActRight _ -> ActRight 1
-            }
+                x -> A.log A.Error (fromString (show x) <> " is a non-movement action!") (error "*dies*")
-        Menu (Adjust (ActDown s) (Joystick _)) -> do
+              k = fst <$> find (\(_, v) -> v == act) (M.assocs tmap)
-          let k = fst <$> find (\(_, v) -> v == ActDown 1) (M.assocs tmap)
+          void $ liftIO $ swapMVar (translation ud) (JoyTranslation $
-          putAffection ud
+            M.insert (AxisAction (fromIntegral axis) align) act $
-            { translation = JoyTranslation $
+              if isJust k then M.delete (fromJust k) tmap else tmap
-              M.insert (AxisAction (fromIntegral axis) align) (ActDown 1) $
+            )
-                if isJust k then M.delete (fromJust k) (tmap) else tmap
+          fullClean ud
-            }
+          switchBack
-        Menu (Adjust (ActLeft s) (Joystick _)) -> do
-          let k = fst <$> find (\(_, v) -> v == ActLeft 1) (M.assocs tmap)
-          putAffection ud
-            { translation = JoyTranslation $
-              M.insert (AxisAction (fromIntegral axis) align) (ActLeft 1) $
-                if isJust k then M.delete (fromJust k) (tmap) else tmap
-            }
-        Menu (Adjust (ActRight s) (Joystick _)) -> do
-          let k = fst <$> find (\(_, v) -> v == ActRight 1) (M.assocs tmap)
-          putAffection ud
-            { translation = JoyTranslation $
-              M.insert (AxisAction (fromIntegral axis) align) (ActRight 1) $
-                if isJust k then M.delete (fromJust k) (tmap) else tmap
-            }
-      fullClean
-      switchBack
-    _ -> return ()
-joyListener switchBack (MsgJoystickButton _ _ but SDL.JoyButtonPressed) = do
-  ud <- getAffection
-  case translation ud of
-    JoyTranslation tmap -> do
-      case state ud of
-        Menu (Adjust (ActUp _) (Joystick _)) -> return ()
-        Menu (Adjust (ActDown _) (Joystick _)) -> return ()
-        Menu (Adjust (ActLeft _) (Joystick _)) -> return ()
-        Menu (Adjust (ActRight _) (Joystick _)) -> return ()
-        Menu (Adjust (act) (Joystick _)) -> do
-          let k = fst <$> find (\(_, v) -> v == act) (M.assocs tmap)
-          putAffection ud
-            { translation = JoyTranslation $
-              M.insert (ButtonAction but SDL.JoyButtonPressed) act $
-                if isJust k then M.delete (fromJust k) tmap else tmap
-            }
         _ -> return ()
-      fullClean
+    MsgJoystickButton _ _ but SDL.JoyButtonPressed -> do
-      switchBack
+      case trans of
-joyListener _ _ = return ()
+        JoyTranslation tmap -> do
+          case curState of
+            Menu (Adjust (ActUp _) (Joystick _)) -> return ()
+            Menu (Adjust (ActDown _) (Joystick _)) -> return ()
+            Menu (Adjust (ActLeft _) (Joystick _)) -> return ()
+            Menu (Adjust (ActRight _) (Joystick _)) -> return ()
+            Menu (Adjust (act) (Joystick _)) -> do
+              let k = fst <$> find (\(_, v) -> v == act) (M.assocs tmap)
+              void $ liftIO $ swapMVar (translation ud) (JoyTranslation $
+                M.insert (ButtonAction but SDL.JoyButtonPressed) act $
+                  if isJust k then M.delete (fromJust k) tmap else tmap
+                )
+            _ -> return ()
+          fullClean ud
+          switchBack
+        x -> A.log A.Error (fromString (show x) <> " is a non-joystick translation!") (error "*dies*")
+    _ -> return ()
 
-drawAdjust :: Affection UserData ()
+drawAdjust :: Context -> Affection ()
-drawAdjust = do
+drawAdjust ctx = do
-  ud <- getAffection
   liftIO $ do
-    let ctx = nano ud
     save ctx
     beginPath ctx
     roundedRect ctx 440 310 400 100 10

src/Menu/Connect.hs

@@ -10,7 +10,9 @@ 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
 
@@ -21,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: " ++ 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
+    { activate = 0.5
-    { stateData = (stateData ud)
-      { activate = 0.5
-      }
     }
-handleActionMessages (ActionMessage ActSwitchMap _) = do
+    )
-  ud <- getAffection
+handleActionMessages ud (ActionMessage ActSwitchMap _) = do
-  putAffection ud
+  liftIO $ modifyMVar_ (stateData ud) (\dat -> return dat
-    { stateData = (stateData ud)
+    { switchMap = 0.5
-      { switchMap = 0.5
-      }
     }
-handleActionMessages (ActionMessage (ActUp f) _) = do
+    )
-  ud <- getAffection
+handleActionMessages ud (ActionMessage (ActUp f) _) = do
-  let V2 vx _ = velocity $ stateData ud
+  liftIO $ modifyMVar_ (stateData ud) (\dat ->
-  putAffection ud
+    let V2 vx _ = velocity dat
-    { stateData = (stateData ud)
+    in return dat
       { 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
@@ -132,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) =
@@ -182,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
@@ -218,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
@@ -239,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)
@@ -253,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)
@@ -275,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)
@@ -297,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)
@@ -319,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)
@@ -335,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)
@@ -367,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/NPC.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE TypeSynonymInstances #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 module NPC where
 
 import Affection as A
@@ -8,9 +9,13 @@ import qualified Data.Matrix as M
 import Data.Ecstasy as E
 import Data.Maybe
 import Data.List (find)
+import Data.List.Split (splitWhen)
+import qualified Data.Vector as V
+import Data.String
 
 import Control.Monad.IO.Class (MonadIO(..))
 import Control.Monad.Trans (lift)
+import Control.Monad.Trans.Resource (ResIO)
 import Control.Concurrent.MVar
 import Control.Concurrent (forkIO)
 
@@ -29,7 +34,7 @@ import Object ()
 getPosBounds
   :: SystemT
     Entity
-    (AffectionState (AffectionData UserData) IO)
+    (AffectionState AffectionData ResIO)
     [(V2 Double, Boundaries Double)]
 getPosBounds = do
   efor allEnts $ do
@@ -42,11 +47,12 @@ getPosBounds = do
 
 updateNPCs
   :: M.Matrix (Maybe ImgId)
-  -> SystemState Entity (AffectionState (AffectionData UserData) IO)
+  -> M.Matrix TileState
-  -> [ReachPoint]
+  -> SystemState Entity (AffectionState AffectionData ResIO)
+  -> V.Vector ReachPoint
   -> Double
-  -> SystemT Entity (AffectionState (AffectionData UserData) IO) ()
+  -> SystemT Entity (AffectionState AffectionData ResIO) ()
-updateNPCs imgmat ws rrp dt = do
+updateNPCs imgmat tsmat ws rrp dt = do
   updateStats dt
   posbounds <- getPosBounds
   moent <- catMaybes <$> eover allEnts (do
@@ -62,8 +68,9 @@ updateNPCs imgmat ws rrp dt = do
     pos' <- query pos
     rot' <- query rot
     lvl  <- query clearanceLvl
+    stat <- query anim
     npcState' <- query npcMoveState
-    let rp = filter ((lvl >=) . pointClearance) rrp
+    let rp = V.filter ((lvl >=) . pointClearance) rrp
     case npcState' of
       NPCStanding ttl future -> do
         let nttl = ttl - dt
@@ -102,77 +109,48 @@ updateNPCs imgmat ws rrp dt = do
                 })
       NPCWalking path ->
         if not (null path)
-        then do
+        then
-          let itarget = fmap (+ 0.5) (fromIntegral <$> head path) :: V2 Double
+          case head path of
-          if distance pos' itarget < 1.5 * dt
+            [] -> if null (tail path)
-          then
+              then standStill imgmat tsmat pos' rot' ws posbounds rp
-            return (Nothing, unchanged
+              else do
-              { npcMoveState = Set $ NPCWalking (tail path)
+                (_, accessibles) <- lift $ yieldSystemT ws (getObject pos')
-              })
+                liftIO $ logIO
-          else
+                  A.Verbose
-            return (Nothing, unchanged
+                  ("accessibles: " <> fromString (show accessibles))
-              { vel = Set $ (* 2) <$> signorm (itarget - pos')
+                case accessibles of
-              })
+                  [] -> error ("unknown reason to stop at " ++ show pos')
+                  objects -> do
+                    rind <- liftIO $ randomRIO (0, length objects - 1)
+                    npcent <- queryEnt
+                    let (oent, _, _) = objects !! rind
+                        mdir = 
+                          pointDir <$> V.find (\a -> pointCoord a == fmap floor pos') rp
+                    return (Just (oent, npcent, Nothing), unchanged
+                      { rot      = Set $ fromMaybe rot' mdir
+                      , anim     = Set stat
+                        { asId = (asId stat)
+                          { aiDirection = fromMaybe rot' mdir
+                          }
+                        }
+                      , vel = Set $ V2 0 0
+                      , npcMoveState = Set $ NPCWalking (tail path)
+                      })
+            ppath -> do
+              let itarget = fmap (+ 0.5) (fromIntegral <$> head ppath) :: V2 Double
+              if distance pos' itarget < 1.5 * dt
+              then
+                return (Nothing, unchanged
+                  { npcMoveState = Set $ NPCWalking (tail ppath : tail path)
+                  })
+              else
+                return (Nothing, unchanged
+                  { vel = Set $ (* 2) <$> signorm (itarget - pos')
+                  })
         else do
-          future <- liftIO $ newEmptyMVar
+          standStill imgmat tsmat pos' rot' ws posbounds rp
-          stat <- query anim
+    )
-          as <- query npcActionState
+  mapM_ (\(oent, npcent, mfuture) -> do
-          targetRPs <- case as of
-            ASWork     ->
-              let fltrd = filter (\p -> pointType p == Copier) rp
-              in
-                ((fltrd ++) . replicate (5 * length fltrd)) <$>
-                  query npcWorkplace
-            ASToilet   -> do
-              let seekRP = filter (\p -> pointType p == Toilet) rp
-              if null seekRP
-              then return $ filter (\p -> pointType p == Elevator) rp
-              else return seekRP
-            ASDrink    -> do
-              let seekRP = filter (\p -> pointType p == Drink) rp
-              if null seekRP
-              then return $ filter (\p -> pointType p == Elevator) rp
-              else return seekRP
-            ASEat      -> do
-              let seekRP = filter (\p -> pointType p == Eat) rp
-              if null seekRP
-              then return $ filter (\p -> pointType p == Elevator) rp
-              else return seekRP
-            ASRandWalk ->
-              return $ filter (\p -> pointType p /= RoomExit) rp
-          _ <- liftIO $ forkIO $
-            getPath (fmap floor pos') future targetRPs imgmat posbounds
-          let mdir = 
-                pointDir <$> find (\a -> pointCoord a == fmap floor pos') rp
-          (_, accessibles) <- lift $ yieldSystemT ws (getObject pos')
-          liftIO $ logIO A.Verbose ("accessibles: " ++ show accessibles)
-          case accessibles of
-            [] -> do
-              ttl <- liftIO $ randomRIO (5, 30)
-              return (Nothing, unchanged
-                { npcMoveState = Set $ NPCStanding ttl future
-                , vel      = Set $ V2 0 0
-                , rot      = Set $ fromMaybe rot' mdir
-                , anim     = Set stat
-                  { asId = (asId stat)
-                    { aiDirection = fromMaybe rot' mdir
-                    }
-                  }
-                })
-            objects -> do
-              rind <- liftIO $ randomRIO (0, length objects - 1)
-              npcent <- queryEnt
-              let (oent, _, _) = objects !! rind
-              return (Just (oent, npcent, future), unchanged
-                { rot      = Set $ fromMaybe rot' mdir
-                , anim     = Set stat
-                  { asId = (asId stat)
-                    { aiDirection = fromMaybe rot' mdir
-                    }
-                  }
-                , vel = Set $ V2 0 0
-                }))
-  mapM_ (\(oent, npcent, future) -> do
     mts <- efor (anEnt oent) $ do
       with objType
       with objState
@@ -205,14 +183,88 @@ updateNPCs imgmat ws rrp dt = do
       let ttl = case head mntns of
             Just (nt, ns) -> actionTime nt ns
             Nothing       -> 1
-      return unchanged
+      maybe
-        { npcMoveState = Set $ NPCStanding ttl future
+        (return unchanged)
-        }
+        (\future -> return unchanged
+          { npcMoveState = Set $ NPCStanding ttl future
+          }
+          )
+        mfuture
     ) moent
 
+standStill
+  :: (MonadIO m, RealFrac a1)
+  => M.Matrix (Maybe ImgId)
+  -> M.Matrix TileState
+  -> V2 a1
+  -> Direction
+  -> SystemState Entity m
+  -> [(V2 Double, Boundaries Double)]
+  -> V.Vector ReachPoint
+  -> QueryT Entity m (Maybe (Ent, Ent, Maybe (MVar [[V2 Int]])), Entity 'SetterOf)
+standStill imgmat tsmat pos' rot' ws posbounds rp = do
+  future <- liftIO $ newEmptyMVar
+  stat <- query anim
+  as <- query npcActionState
+  targetRPs <- case as of
+    ASWork     ->
+      let fltrd = V.filter (\p -> pointType p == Copier) rp
+      in
+        (V.foldl V.snoc fltrd . V.replicate (5 * V.length fltrd)) <$>
+          query npcWorkplace
+    ASToilet   -> do
+      let seekRP = V.filter (\p -> pointType p == Toilet) rp
+      if V.null seekRP
+      then return $ V.filter (\p -> pointType p == Elevator) rp
+      else return seekRP
+    ASDrink    -> do
+      let seekRP = V.filter (\p -> pointType p == Drink) rp
+      if V.null seekRP
+      then return $ V.filter (\p -> pointType p == Elevator) rp
+      else return seekRP
+    ASEat      -> do
+      let seekRP = V.filter (\p -> pointType p == Eat) rp
+      if V.null seekRP
+      then return $ V.filter (\p -> pointType p == Elevator) rp
+      else return seekRP
+    ASRandWalk ->
+      return $ V.filter (\p -> pointType p /= RoomExit) rp
+  _ <- liftIO $ forkIO $
+    getPath (fmap floor pos') future targetRPs imgmat tsmat posbounds
+  let mdir = 
+        pointDir <$> find (\a -> pointCoord a == fmap floor pos') rp
+  (_, accessibles) <- lift $ yieldSystemT ws (getObject pos')
+  liftIO $ logIO A.Verbose ("accessibles: " <> fromString (show accessibles))
+  case accessibles of
+    [] -> do
+      ttl <- liftIO $ randomRIO (5, 30)
+      return (Nothing, unchanged
+        { npcMoveState = Set $ NPCStanding ttl future
+        , vel      = Set $ V2 0 0
+        , rot      = Set $ fromMaybe rot' mdir
+        , anim     = Set stat
+          { asId = (asId stat)
+            { aiDirection = fromMaybe rot' mdir
+            }
+          }
+        })
+    objects -> do
+      rind <- liftIO $ randomRIO (0, length objects - 1)
+      npcent <- queryEnt
+      let (oent, _, _) = objects !! rind
+      return (Just (oent, npcent, Just future), unchanged
+        { rot      = Set $ fromMaybe rot' mdir
+        , anim     = Set stat
+          { asId = (asId stat)
+            { aiDirection = fromMaybe rot' mdir
+            }
+          }
+        , vel = Set $ V2 0 0
+        })
+
 updateStats
   :: Double
-  -> SystemT Entity (AffectionState (AffectionData UserData) IO) ()
+  -> SystemT Entity (AffectionState AffectionData ResIO) ()
 updateStats dt =
   emap allEnts $ do
     with npcStats
@@ -263,7 +315,7 @@ getObject npos = do
     oacc <- query objAccess
     ent <- queryEnt
     return (ent, pos', oacc)
-  liftIO $ logIO A.Verbose ("candidates: " ++ show candidates)
+  liftIO $ logIO A.Verbose ("candidates: " <> fromString (show candidates))
   return $
     filter (\(_, p, deltaors) ->
       any (\(delta, _) -> fmap floor p + delta == fmap floor npos) deltaors
@@ -271,35 +323,77 @@ getObject npos = do
 
 getPath
   :: V2 Int
-  -> MVar [V2 Int]
+  -> MVar [[V2 Int]]
-  -> [ReachPoint]
+  -> V.Vector ReachPoint
   -> M.Matrix (Maybe ImgId)
+  -> M.Matrix TileState
   -> [(V2 Double, Boundaries Double)]
   -> IO ()
-getPath pos' mvar rp imgmat posbounds = do
+getPath pos' mvar rp imgmat tsmat posbounds = do
-  let seekRP = filter (\p -> pointType p /= RoomExit) rp
+  let seekRP = V.filter (\p -> pointType p /= RoomExit) rp
-  ntargeti <- randomRIO (0, length seekRP - 1)
+  ntargeti <- randomRIO (0, V.length seekRP - 1)
-  let ntarget = pointCoord (seekRP !! ntargeti)
+  let ntarget = pointCoord (seekRP V.! ntargeti)
       path = astarAppl imgmat posbounds ntarget pos'
-  logIO A.Verbose ("seeking path from " ++ show pos' ++ " to " ++ show ntarget)
+  logIO
+    A.Verbose
+    ("seeking path from " <>
+      fromString (show pos') <>
+      " to " <>
+      fromString (show ntarget)
+      )
   case path of
     Nothing -> do
-      logIO A.Error ("No path from " ++ show pos' ++ " to " ++ show ntarget)
+      logIO
+        A.Error
+        ("No path from " <>
+          fromString (show pos') <>
+          " to " <>
+          fromString ( show ntarget)
+          )
       putMVar mvar []
       -- getPath pos' mvar rp imgmat posbounds
-    Just p  -> putMVar mvar p
+    Just p  -> putMVar mvar (chewPath tsmat p)
 
 getPathTo
   :: V2 Int
-  -> MVar [V2 Int]
+  -> MVar [[V2 Int]]
   -> V2 Int
   -> M.Matrix (Maybe ImgId)
+  -> M.Matrix TileState
   -> [(V2 Double, Boundaries Double)]
   -> IO ()
-getPathTo pos' mvar target imgmat posbounds = do
+getPathTo pos' mvar target imgmat tsmat posbounds = do
   let path = astarAppl imgmat posbounds target pos'
-  logIO A.Verbose ("seeking path from " ++ show pos' ++ " to " ++ show target)
+  logIO
+    A.Verbose
+    ("seeking path from " <>
+      fromString (show pos') <>
+      " to " <>
+      fromString (show target)
+      )
   case path of
     Nothing -> do
-      logIO A.Error ("No path from " ++ show pos' ++ " to " ++ show target)
+      logIO
-    Just p  -> putMVar mvar p
+        A.Error
+        ("No path from " <>
+          fromString (show pos') <>
+          " to " <>
+          fromString (show target)
+          )
+    Just p  -> putMVar mvar (chewPath tsmat p)
+
+simplifyPath :: [V2 Int] -> V2 Int -> [V2 Int]
+simplifyPath [] a = [a]
+simplifyPath acc@[_] a = a : acc
+simplifyPath (b:c:bs) a
+  | ((signorm $ fmap fromIntegral a) - (signorm $ fmap fromIntegral b)) `dot`
+    ((signorm $ fmap fromIntegral b) - (signorm $ fmap fromIntegral c)) == (1 :: Double)
+    = a : c : bs
+  | otherwise
+    = a : b : c : bs
+
+chunkPath :: M.Matrix TileState -> [V2 Int] -> [[V2 Int]]
+chunkPath tsmat = splitWhen (\(V2 r c) -> tsmat M.! (r, c) == Door)
+
+chewPath :: M.Matrix TileState -> [V2 Int] -> [[V2 Int]]
+chewPath tsmat = map (reverse . foldl simplifyPath []) . chunkPath tsmat

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/Object.hs

@@ -3,14 +3,7 @@
 {-# LANGUAGE FlexibleInstances #-}
 module Object where
 
-import Affection as A
-
-import Control.Monad (when)
-
 import Data.Ecstasy
-import Data.Maybe
-
-import Linear
 
 -- internal imports
 
@@ -21,13 +14,13 @@ import Object.Copier
 import Object.Door
 
 instance ObjectAction ObjType ObjState where
-  objectAction relEnts dt t@ObjCopier s ent = copierObjectAction relEnts dt t s ent
+  objectAction dt t@ObjCopier s ent = copierObjectAction dt t s ent
 
-  objectAction relEnts dt t@ObjComputer s ent = computerObjectAction relEnts dt t s ent
+  objectAction dt t@ObjComputer s ent = computerObjectAction dt t s ent
 
-  objectAction relEnts dt t@ObjDoor s ent = doorObjectAction relEnts dt t s ent
+  objectAction dt t@ObjDoor s ent = doorObjectAction dt t s ent
 
-  objectAction _ _ _ _ _ = return ()
+  objectAction _ _ _ _ = return ()
 
   objectTransition t@ObjCopier s pa ent aent =
     copierObjectTransition t s pa ent aent

src/Object/ActionTime.hs

@@ -5,6 +5,8 @@ module Object.ActionTime where
 
 import Affection as A
 
+import Data.String
+
 -- internal imports
 
 import Types
@@ -14,7 +16,9 @@ instance ActionTime ObjType ObjState where
   actionTime ObjComputer "off" = 0
   actionTime ObjComputer "on" = 20
   actionTime ObjComputer "hack" = 20
-  actionTime ObjComputer "hack" = 20
   actionTime ObjDoor     "open" = 2
 
-  actionTime o s = A.log Error (show o ++ ": " ++ s ++ ": has not a time") 0
+  actionTime o s = A.log
+    Error
+    (fromString (show o) <> ": " <> fromString s <> ": has not a time")
+    0

src/Object/Computer.hs

@@ -6,11 +6,11 @@ module Object.Computer where
 
 import Affection as A
 
-import Control.Monad (when)
 import Control.Monad.IO.Class (MonadIO(..))
 
 import Data.Ecstasy
 import Data.Maybe
+import Data.String
 
 import Linear
 
@@ -18,17 +18,16 @@ import Linear
 
 import Types
 
-import Object.ActionTime
+import Object.ActionTime ()
 
 computerObjectAction
   :: (Monad m, MonadIO m)
-  => [(Ent, V2 Double, Direction, Word)]
+  => Double
-  -> Double
   -> ObjType
   -> ObjState
   -> Ent
   -> SystemT Entity m ()
-computerObjectAction _ dt t@ObjComputer s@"on" ent = do
+computerObjectAction dt t@ObjComputer s@"on" ent = do
   pent <- efor (anEnt ent) $ do
     with objUsedBy
     query objUsedBy
@@ -40,7 +39,7 @@ computerObjectAction _ dt t@ObjComputer s@"on" ent = do
     mtime <- queryMaybe objStateTime
     case mtime of
       Nothing -> do
-        liftIO $ logIO Verbose ("Computer " ++ show ent ++ ": on!")
+        liftIO $ logIO Verbose ("Computer " <> fromString (show ent) <> ": on!")
         let dur = actionTime t s
         return unchanged
           { objStateTime = Set dur
@@ -66,7 +65,7 @@ computerObjectAction _ dt t@ObjComputer s@"on" ent = do
     (\tpa -> setEntity ent =<< computerObjectTransition t s tpa ent Nothing)
     (head trans)
 
-computerObjectAction _ dt t@ObjComputer s@"hack" ent = do
+computerObjectAction dt t@ObjComputer s@"hack" ent = do
   aent <- efor (anEnt ent) $ do
     with objUsedBy
     query objUsedBy
@@ -78,7 +77,9 @@ computerObjectAction _ dt t@ObjComputer s@"hack" ent = do
     mtime <- queryMaybe objStateTime
     case mtime of
       Nothing -> do
-        liftIO $ logIO Verbose ("Computer " ++ show ent ++ ": hacking!")
+        liftIO $ logIO
+          Verbose
+          ("Computer " <> fromString (show ent) <> ": hacking!")
         return unchanged
           { objStateTime = Set (actionTime t s)
           }
@@ -101,7 +102,7 @@ computerObjectAction _ dt t@ObjComputer s@"hack" ent = do
     (\tpa -> setEntity ent =<< computerObjectTransition t s tpa ent Nothing)
     (head trans)
 
-computerObjectAction _ _ _ _ _ = return ()
+computerObjectAction _ _ _ _ = return ()
 
 computerObjectTransition
   :: (Monad m, MonadIO m)
@@ -112,7 +113,8 @@ computerObjectTransition
   -> Maybe Ent
   -> SystemT Entity m (Entity 'SetterOf)
 computerObjectTransition ObjComputer "off" pa ent (Just aent) = do
-  [dir] <- efor (anEnt aent) (query rot)
+  ldir <- efor (anEnt aent) (query rot)
+  let dir = head ldir
   e <- efor (anEnt ent) $ do
     solved <- queryMaybe objSolved
     if pa

src/Object/Copier.hs

@@ -10,27 +10,24 @@ import Control.Monad (when)
 import Control.Monad.IO.Class
 
 import Data.Ecstasy
-import Data.Maybe
 import Data.String (IsString(..))
 
-import Linear
-
 import Types
 
 copierObjectAction
   :: (Monad m, MonadIO m, ActionTime ObjType ObjState)
-  => [(Ent, V2 Double, Direction, Word)]
+  => Double
-  -> Double
   -> ObjType
   -> ObjState
   -> Ent
   -> SystemT Entity m ()
-copierObjectAction _ dt t@ObjCopier s@"copying" ent = do
+copierObjectAction dt t@ObjCopier s@"copying" ent = do
   emap (anEnt ent) $ do
     mtime <- queryMaybe objStateTime
     case mtime of
       Nothing -> do
-        liftIO $ logIO Verbose ("Copier " ++ show ent ++ ": copying!")
+        liftIO $ logIO Verbose
+          ("Copier " <> fromString (show ent) <> ": copying!")
         return unchanged
           { objStateTime = Set (actionTime t s)
           , objState = Set "copying"
@@ -46,7 +43,7 @@ copierObjectAction _ dt t@ObjCopier s@"copying" ent = do
       Just ttl -> return (ttl < 0)
   when (head trans) (setEntity ent =<< copierObjectTransition t s False ent Nothing)
 
-copierObjectAction _ _ _ _ _ = return ()
+copierObjectAction _ _ _ _ = return ()
 
 copierObjectTransition
   :: (Eq a, IsString a, MonadIO m)

src/Object/Door.hs

@@ -7,19 +7,25 @@ module Object.Door where
 import Affection as A
 
 import Control.Monad (when)
+import Control.Monad.IO.Class (MonadIO)
 
 import Data.Ecstasy
 import Data.Maybe
-
+import Data.String
-import Linear
 
 -- internal imports
 
 import Types
 
-import Object.ActionTime
+import Object.ActionTime ()
 
-doorObjectAction _ dt t@ObjDoor s@"open" ent = do
+doorObjectAction :: (Eq a, IsString a, MonadIO m)
+  => Double
+  -> ObjType
+  -> a
+  -> Ent
+  -> SystemT Entity m ()
+doorObjectAction dt t@ObjDoor s@"open" ent = do
   emap (anEnt ent) $ do
     mtime <- queryMaybe objStateTime
     case mtime of
@@ -36,49 +42,33 @@ doorObjectAction _ dt t@ObjDoor s@"open" ent = do
       Just ttl -> return (ttl < 0)
   when (head trans) (setEntity ent =<< doorObjectTransition t s False ent Nothing)
 
-doorObjectAction allRelEnts dt t@ObjDoor s@"shut" ent = do
+doorObjectAction _ _ _ _ = return ()
-  permEnts <- efor (anEnt ent) $ do
-    pos' <- query pos
-    rot' <- query rot
-    clvl <- query clearanceLvl
-    let posEnts = filter
-          (\(_, b, _, _) ->
-            (fmap floor b `elem` deltaCoords || fmap floor b == floorPos) &&
-            distance b pos' < 0.75)
-          allRelEnts
-        floorPos = fmap floor pos'
-        deltas = case rot' of
-          NW ->
-            [ V2 (-1) 0
-            , V2 1    0
-            ]
-          NE ->
-            [ V2 0 (-1)
-            , V2 0    1
-            ]
-        acceptedRots = case rot' of
-          NW -> [NW, SE]
-          NE -> [NE, SW]
-        deltaCoords = map (floorPos +) deltas
-        predicate (_, _, c, d) = c `elem` acceptedRots && d >= clvl
-        ret = filter predicate posEnts
-    return ret
-  mapM_
-    (\(e, _, _, _) -> setEntity ent =<< doorObjectTransition t s False ent (Just e))
-    (head permEnts)
 
-doorObjectAction _ _ _ _ _ = return ()
+doorObjectTransition :: (MonadIO m, Eq a, IsString a)
-
+  => ObjType
-doorObjectTransition t@ObjDoor s@"shut" _ ent (Just aent) = do
+  -> a
-  [clearance] <- efor (anEnt aent) (query clearanceLvl)
+  -> p
+  -> Ent
+  -> Maybe Ent
+  -> SystemT Entity m (Entity 'SetterOf)
+doorObjectTransition t@ObjDoor _ _ ent (Just aent) = do
+  curClearance <- head <$> efor (anEnt aent) (query clearanceLvl)
   e <- efor (anEnt ent) $ do
       dir <- query rot
       oclear <- query clearanceLvl
-      liftIO $ A.logIO A.Verbose (show aent ++ " is attempting to open door " ++ show ent)
+      mttl <- queryMaybe objStateTime
-      liftIO $ A.logIO A.Verbose ("door clearance: " ++ show oclear ++ ", entity clearance: " ++ show clearance)
+      liftIO $ A.logIO
-      if clearance >= oclear
+        A.Verbose
+        (fromString (show aent) <>
+          " is attempting to open door " <>
+          fromString (show ent)
+          )
+      -- liftIO $ A.logIO A.Debug ("door clearance: " ++ show oclear ++ ", entity clearance: " ++ show clearance)
+      if curClearance >= oclear
       then do
-        liftIO $ A.logIO A.Verbose ("door " ++ show oclear ++ " opens")
+        liftIO $ A.logIO
+          A.Verbose
+          ("door " <> fromString (show ent) <> " opens")
         let nstat = AnimState
               (AnimId AnimDoor0 "open" dir)
               0
@@ -86,8 +76,9 @@ doorObjectTransition t@ObjDoor s@"shut" _ ent (Just aent) = do
         return unchanged
           { objState     = Set "open"
           , objStateTime = Set (actionTime t ("open" :: String))
-          , objUsedBy    = Set aent
+          , anim         = if fromMaybe True (fmap (0 >) mttl)
-          , anim         = Set nstat
+              then Set nstat
+              else Keep
           , obstacle     = Unset
           }
       else
@@ -108,7 +99,6 @@ doorObjectTransition ObjDoor "open" _ ent Nothing = do
         { anim         = Set nstat
         , objState     = Set "shut"
         , objStateTime = Unset
-        , objUsedBy    = Unset
         , obstacle     = Set $ case orientation of
           NW -> Boundaries (4/9, 0) (5/9, 1)
           NE -> Boundaries (0, 4/9) (1, 5/9)

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 _)) = loadAdjust
+  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/Animation.hs

@@ -46,5 +46,10 @@ data AnimationName
   | AnimComputer
   | AnimToilet
   | AnimJDoeM
+  | AnimPoliceM
   | AnimDoor0
   deriving (Show, Eq, Ord, Enum)
+
+isWallLike :: AnimationName -> Bool
+isWallLike AnimDoor0 = True
+isWallLike _ = False

src/Types/Drawable.hs

@@ -4,6 +4,8 @@ module Types.Drawable where
 
 import qualified Data.Map.Strict as Map
 
+import Control.Concurrent.MVar
+
 import NanoVG
 
 import Foreign.C.Types (CFloat(..))
@@ -30,7 +32,7 @@ instance NanoDrawable UserData Image where
 
 instance NanoDrawable UserData AnimState where
   draw us x y w h alpha as = do
-    let anims = assetAnimations us
+    anims <- readMVar (assetAnimations us)
-        a = anims Map.! asId as
+    let a = anims Map.! asId as
         img = (animSprites a !! asCurrentFrame as) :: Image
     draw us x y w h alpha img

src/Types/Interior.hs

@@ -34,6 +34,7 @@ data Cluster
   | ClusterWatercooler
   | ClusterVending
   | ClusterCabinets
+  | ClusterBreakroomTable
   deriving (Enum, Bounded, Show)
 
 -- row -> NS; col -> WE
@@ -72,18 +73,6 @@ clusterMatWithRPs ClusterTableSE dim@(_, mw) g =
       ]
   , ps
   )
--- clusterMatWithRPs ClusterTableNE dim@(h, _) _ =
---   ( M.fromLists $ replicate h
---       [Just ImgTableNE, Just ImgEmpty]
---   , clusterPoints ClusterTableNE dim
---   )
--- clusterMatWithRPs ClusterTableNW dim@(_, w) _ =
---   ( M.fromLists $
---       [ replicate w (Just ImgEmpty)
---       , replicate w (Just ImgTableNW)
---       ]
---   , clusterPoints ClusterTableNW dim
---   )
 clusterMatWithRPs ClusterCornerTable dim _ =
   ( M.fromLists
       [ [Just ImgTableSE, Just ImgTableCorner]
@@ -232,12 +221,14 @@ clusterMatWithRPs ClusterCabinets (h, w) g =
           M.fromLists (map (\a -> [a]) sws)
           )
   in (outmat, (seps ++ swps))
+clusterMatWithRPs ClusterBreakroomTable dim g =
+  ( fst (clusterMatWithRPs ClusterConferenceTable (4, 4) g)
+  , clusterPoints ClusterBreakroomTable dim
+  )
 
 clusterRoom :: Cluster -> [TileState]
 clusterRoom ClusterBox1             = [Offi]
 clusterRoom ClusterTableSW          = [Offi]
--- clusterRoom ClusterTableNW          = [Offi]
--- clusterRoom ClusterTableNE          = [Offi]
 clusterRoom ClusterTableSE          = [Offi]
 clusterRoom ClusterCornerTable      = [Offi]
 clusterRoom ClusterTableGroup       = [Offi]
@@ -250,13 +241,10 @@ clusterRoom ClusterToilets          = [Toil]
 clusterRoom ClusterWatercooler      = [Kitc, Offi]
 clusterRoom ClusterVending          = [Kitc]
 clusterRoom ClusterCabinets         = [Kitc]
+clusterRoom ClusterBreakroomTable   = [Kitc]
 
 clusterPoints :: Cluster -> (Int, Int) -> [ReachPoint]
 clusterPoints ClusterBox1 _ = []
--- clusterPoints ClusterTableNE (h, _) =
---   [ ReachPoint Table (V2 r 2) SW 0 | r <- [1..h] ]
--- clusterPoints ClusterTableNW (_, w) =
---   [ ReachPoint Table (V2 1 c) SE 0 | c <- [1..w] ]
 clusterPoints ClusterCornerTable _ =
   [ ReachPoint Computer (V2 2 1) N 0
   ]
@@ -292,6 +280,12 @@ clusterPoints ClusterWatercooler _ =
 clusterPoints ClusterVending _ =
   [ ReachPoint Eat (V2 2 1) NW 0
   ]
+clusterPoints ClusterBreakroomTable _ =
+  map
+    (\p -> p
+      { pointType = Eat }
+      )
+    (clusterPoints ClusterConferenceTable (4, 4))
 clusterPoints _ _ = []
 
 instance Size (Cluster, (Int, Int), StdGen) where

src/Types/Map.hs

@@ -3,6 +3,8 @@ module Types.Map where
 
 import Linear (V2)
 
+import qualified Data.Vector as V
+
 data TileState
   = Wall
   -- | Wind
@@ -50,10 +52,10 @@ data GraphDirection = North | South | East | West
 
 data Graph
   = GHall
-    { connects :: [Graph]
+    { connects  :: V.Vector Graph
     }
   | GRoom
-    { neighbs   :: [(GraphDirection, TileState)]
+    { neighbs   :: V.Vector (GraphDirection, TileState)
     , bounds    :: Boundaries Int
     , clearance :: Word
     , roomType  :: TileState

src/Types/NPCState.hs

@@ -5,11 +5,11 @@ import Linear (V2)
 
 data NPCMoveState
   = NPCWalking
-    { npcWalkPath :: [V2 Int]
+    { npcWalkPath :: [[V2 Int]]
     }
   | NPCStanding
     { npcStandTime  :: Double
-    , npcFuturePath :: MVar [V2 Int]
+    , npcFuturePath :: MVar [[V2 Int]]
     }
 
 data NPCActionState

src/Types/ObjClass.hs

@@ -5,20 +5,18 @@ module Types.ObjClass where
 
 import Affection
 
+import Control.Monad.Trans.Resource (ResIO)
 import Data.Ecstasy
 
 import Types.Entity
-import Types.UserData
-import Types.Direction
 
 class ObjectAction otype ostate where
   objectAction
-    :: [(Ent, V2 Double, Direction, Word)]
+    :: Double
-    -> Double
     -> otype
     -> ostate
     -> Ent
-    -> SystemT Entity (AffectionState (AffectionData UserData) IO) ()
+    -> SystemT Entity (AffectionState AffectionData ResIO) ()
 
   objectTransition
     :: otype
@@ -26,7 +24,7 @@ class ObjectAction otype ostate where
     -> Bool
     -> Ent
     -> Maybe Ent
-    -> SystemT Entity (AffectionState (AffectionData UserData) IO) (Entity 'SetterOf)
+    -> SystemT Entity (AffectionState AffectionData ResIO) (Entity 'SetterOf)
 
 class ActionTime otype ostate where
   actionTime :: otype -> ostate -> Double

src/Types/StateData.hs

@@ -2,6 +2,7 @@ module Types.StateData where
 
 import Data.Matrix
 import Data.Map
+import Data.Vector as V
 
 import NanoVG hiding (V2)
 
@@ -23,9 +24,9 @@ data StateData
   | MainData
     { mapMat      :: Matrix TileState
     , imgMat      :: Matrix (Maybe ImgId)
-    , reachPoints :: [ReachPoint]
+    , reachPoints :: V.Vector ReachPoint
     , mmImgMat    :: Matrix (Maybe ImgId)
-    , roomGraph   :: [Graph]
+    , roomGraph   :: V.Vector Graph
     }
   | MenuData
     { velocity  :: V2 Double

src/Types/UserData.hs

@@ -16,6 +16,7 @@ import qualified Data.Text as T
 import Data.Ecstasy
 
 import Control.Concurrent.MVar
+import Control.Monad.Trans.Resource
 
 import Types.StateData
 import Types.ImgId
@@ -24,27 +25,28 @@ import Types.Animation
 import Types.Entity
 
 data UserData = UserData
-  { state           :: State
+  { state           :: MVar State
   , subsystems      :: Subsystems
-  , assetIcons      :: M.Map IconId Image
+  , assetIcons      :: MVar (M.Map IconId Image)
-  , assetImages     :: M.Map ImgId Image
+  , assetImages     :: MVar (M.Map ImgId Image)
-  , assetFonts      :: M.Map FontId T.Text
+  , assetFonts      :: MVar (M.Map FontId T.Text)
-  , assetAnimations :: M.Map AnimId Animation
+  , assetAnimations :: MVar (M.Map AnimId Animation)
-  , controls        :: Controller -- Maybe SDL.Joystick
+  , controls        :: MVar Controller
-  , translation     :: Translation
+  , translation     :: MVar Translation
   , nano            :: Context
-  , uuid            :: [UUID]
+  , uuid            :: MVar [UUID]
-  , worldState      :: SystemState Entity (AffectionState (AffectionData UserData) IO)
+  , worldState      :: MVar (SystemState Entity (AffectionState AffectionData ResIO))
-  , stateData       :: StateData
+  , stateData       :: MVar StateData
   , stateMVar       :: MVar
-    ( SystemState Entity (AffectionState (AffectionData UserData) IO)
+    ( SystemState Entity (AffectionState AffectionData ResIO)
     , StateData
     )
   , stateProgress   :: MVar (Float, T.Text)
-  , threadContext   :: Maybe SDL.GLContext
+  , threadContext   :: MVar (Maybe SDL.GLContext)
-  , window          :: Maybe SDL.Window
+  , window          :: MVar (Maybe SDL.Window)
-  , joyCache        :: [JoystickMessage]
+  , joyCache        :: MVar [JoystickMessage]
-  , joyUUID         :: UUID
+  , joyUUID         :: MVar UUID
+  , doNextStep      :: MVar Bool
   }
 
 data Controller
@@ -133,14 +135,14 @@ data ActionMessage = ActionMessage
 instance Message ActionMessage where
   msgTime (ActionMessage _ t) = t
 
-newtype SubWindow     = SubWindow (TVar [(UUID, WindowMessage -> Affection UserData())])
+newtype SubWindow     = SubWindow (TVar [(UUID, WindowMessage -> Affection())])
-newtype SubMouse      = SubMouse (TVar [(UUID, MouseMessage -> Affection UserData ())])
+newtype SubMouse      = SubMouse (TVar [(UUID, MouseMessage -> Affection ())])
-newtype SubKeyboard   = SubKeyboard (TVar [(UUID, KeyboardMessage -> Affection UserData ())])
+newtype SubKeyboard   = SubKeyboard (TVar [(UUID, KeyboardMessage -> Affection ())])
-newtype SubJoypad     = SubJoypad (TVar [(UUID, JoystickMessage -> Affection UserData ())])
+newtype SubJoypad     = SubJoypad (TVar [(UUID, JoystickMessage -> Affection ())])
-newtype SubTranslator = SubTranslator (TVar [(UUID, ActionMessage -> Affection UserData ())])
+newtype SubTranslator = SubTranslator (TVar [(UUID, ActionMessage -> Affection ())])
 
-instance Participant SubWindow UserData where
+instance Participant SubWindow where
-  type Mesg SubWindow UserData = WindowMessage
+  type Mesg SubWindow = WindowMessage
 
   partSubscribers (SubWindow t) = generalSubscribers t
 
@@ -148,11 +150,11 @@ instance Participant SubWindow UserData where
 
   partUnSubscribe (SubWindow t) = generalUnSubscribe t
 
-instance SDLSubsystem SubWindow UserData where
+instance SDLSubsystem SubWindow where
   consumeSDLEvents = consumeSDLWindowEvents
 
-instance Participant SubMouse UserData where
+instance Participant SubMouse where
-  type Mesg SubMouse UserData = MouseMessage
+  type Mesg SubMouse = MouseMessage
 
   partSubscribers (SubMouse t) = generalSubscribers t
 
@@ -160,11 +162,11 @@ instance Participant SubMouse UserData where
 
   partUnSubscribe (SubMouse t) = generalUnSubscribe t
 
-instance SDLSubsystem SubMouse UserData where
+instance SDLSubsystem SubMouse where
   consumeSDLEvents = consumeSDLMouseEvents
 
-instance Participant SubKeyboard UserData where
+instance Participant SubKeyboard where
-  type Mesg SubKeyboard UserData = KeyboardMessage
+  type Mesg SubKeyboard = KeyboardMessage
 
   partSubscribers (SubKeyboard t) = generalSubscribers t
 
@@ -172,11 +174,11 @@ instance Participant SubKeyboard UserData where
 
   partUnSubscribe (SubKeyboard t) = generalUnSubscribe t
 
-instance SDLSubsystem SubKeyboard UserData where
+instance SDLSubsystem SubKeyboard where
   consumeSDLEvents = consumeSDLKeyboardEvents
 
-instance Participant SubJoypad UserData where
+instance Participant SubJoypad where
-  type Mesg SubJoypad UserData = JoystickMessage
+  type Mesg SubJoypad = JoystickMessage
 
   partSubscribers (SubJoypad t) = generalSubscribers t
 
@@ -184,11 +186,11 @@ instance Participant SubJoypad UserData where
 
   partUnSubscribe (SubJoypad t) = generalUnSubscribe t
 
-instance SDLSubsystem SubJoypad UserData where
+instance SDLSubsystem SubJoypad where
   consumeSDLEvents = consumeSDLJoystickEvents
 
-instance Participant SubTranslator UserData where
+instance Participant SubTranslator where
-  type Mesg SubTranslator UserData = ActionMessage
+  type Mesg SubTranslator = ActionMessage
 
   partSubscribers (SubTranslator t) = generalSubscribers t
 
@@ -197,25 +199,25 @@ instance Participant SubTranslator UserData where
   partUnSubscribe (SubTranslator t) = generalUnSubscribe t
 
 generalSubscribers
-  :: TVar [(UUID, msg -> Affection UserData ())]
+  :: TVar [(UUID, msg -> Affection ())]
-  -> Affection UserData [(msg -> Affection UserData ())]
+  -> Affection [(msg -> Affection ())]
 generalSubscribers t = do
   subTups <- liftIO $ readTVarIO t
   return $ map snd subTups
 
 generalSubscribe
-  :: TVar [(UUID, msg -> Affection UserData ())]
+  :: TVar [(UUID, msg -> Affection ())]
-  -> (msg -> Affection UserData ())
+  -> (msg -> Affection ())
-  -> Affection UserData UUID
+  -> Affection UUID
 generalSubscribe t funct = do
   uu <- genUUID
   liftIO $ atomically $ modifyTVar' t ((uu, funct) :)
   return uu
 
 generalUnSubscribe
-  :: TVar [(UUID, msg -> Affection UserData ())]
+  :: TVar [(UUID, msg -> Affection ())]
   -> UUID
-  -> Affection UserData ()
+  -> Affection ()
 generalUnSubscribe t uu =
   liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uu))
   where

src/Util.hs

@@ -10,8 +10,11 @@ import Data.ByteString.Lazy (toStrict)
 import Data.Graph.AStar
 import Data.Maybe
 import qualified Data.Text as T
+import Data.String
 
-import Control.Monad (join, when)
+import Control.Monad
+
+import Control.Concurrent.MVar
 
 import qualified SDL
 import qualified Graphics.Rendering.OpenGL as GL hiding (get)
@@ -195,14 +198,14 @@ naviGraph imgmat animBounds (V2 r c) =
           (\acc (rr, cc) ->
             if null
               (maybe [] collisionObstacle
-                (join $ M.safeGet (r + rr) (c + cc) imgmat)
+                (M.unsafeGet (r + rr) (c + cc) imgmat)
               ++
               map snd (filter (\(V2 br bc, _) -> floor br == r + rr && floor bc == c + cc)
                 animBounds))
               && all null
               (map
               (\(oor, ooc) -> (maybe [] collisionObstacle
-                (join $ M.safeGet (r + oor) (c + ooc) imgmat)) ++
+                (M.unsafeGet (r + oor) (c + ooc) imgmat)) ++
                 map snd (filter
                   (\(V2 br bc, _) -> floor br == r + oor && floor bc == c + ooc)
                   animBounds))
@@ -220,7 +223,8 @@ drawLoadScreen ud (progress, msg) = do
   save ctx
   fillColor ctx (rgb 255 128 0)
   fontSize ctx 100
-  fontFace ctx (assetFonts ud Map.! FontBedstead)
+  fonts <- readMVar (assetFonts ud)
+  fontFace ctx (fonts Map.! FontBedstead)
   textAlign ctx (S.fromList [AlignCenter, AlignTop])
   textBox ctx 0 300 1280 "Loading"
   beginPath ctx
@@ -241,7 +245,7 @@ loadAnimationSprites fp nvg idconfs = do
   eimg <- readImage fp
   case eimg of
     Left err -> do
-      logIO Error err
+      logIO Error (fromString err)
       exitFailure
     Right dimg -> do
       let img = convertRGBA8 dimg
@@ -253,11 +257,17 @@ loadAnimationSprites fp nvg idconfs = do
           mresimgs <- mapM
             (\cr ->
               createImageMem nvg
-                ImagePremultiplied (toStrict $ encodePng cr))
+                (S.singleton ImagePremultiplied) (toStrict $ encodePng cr))
             crs
           imgs <- if any isNothing mresimgs
             then do
-              logIO Error ("failed to load: " ++ fp ++ " " ++ show i)
+              logIO
+                Error
+                ("failed to load: " <>
+                  fromString fp <>
+                  " " <>
+                  fromString (show i)
+                  )
               exitFailure
             else
               return $ catMaybes mresimgs
@@ -297,48 +307,47 @@ rotVec (V2 x y) deg = V2 nx ny
 dtor :: (Num a, Floating a) => a -> a
 dtor = (pi / 180 *)
 
-cacheJoypad :: JoystickMessage -> Affection UserData ()
+cacheJoypad :: UserData -> JoystickMessage -> Affection ()
-cacheJoypad msg = do
+cacheJoypad ud msg = do
-  ud <- getAffection
+  joy <- liftIO $ readMVar (joyCache ud)
-  putAffection ud
+  void $ liftIO $ swapMVar (joyCache ud) (msg : joy)
-    { joyCache = msg : joyCache ud
-    }
 
-emitJoyActionMessage :: JoystickMessage -> Affection UserData ()
+emitJoyActionMessage :: UserData -> JoystickMessage -> Affection ()
-emitJoyActionMessage (MsgJoystickAxis time _ axis val) = do
+emitJoyActionMessage ud message = do
-  ud <- getAffection
+  trans <- liftIO $ readMVar (translation ud)
-  case translation ud of
+  case message of
-    JoyTranslation tmap -> do
+    MsgJoystickAxis time _ axis val -> do
+      case trans of
+        JoyTranslation tmap -> do
+          let Subsystems _ _ _ _ t = subsystems ud
+              vnormal = fromIntegral val / 32768
+              sigvnormal = abs vnormal
+              align
+                | signum vnormal >= 0 = AxisPositive
+                | signum vnormal < 0 = AxisNegative
+          case tmap Map.!? (AxisAction axis align) of
+            Just (ActUp _)    -> partEmit t (ActionMessage (ActUp sigvnormal) time)
+            Just (ActDown _)  -> partEmit t (ActionMessage (ActDown sigvnormal) time)
+            Just (ActLeft _)  -> partEmit t (ActionMessage (ActLeft sigvnormal) time)
+            Just (ActRight _) -> partEmit t (ActionMessage (ActRight sigvnormal) time)
+            _              -> return ()
+        _ -> return ()
+    MsgJoystickButton time _ but SDL.JoyButtonPressed -> do
       let Subsystems _ _ _ _ t = subsystems ud
-          vnormal = fromIntegral val / 32768
+      case trans of
-          sigvnormal = abs vnormal
+        JoyTranslation tmap -> do
-          align
+          case tmap Map.!? (ButtonAction but SDL.JoyButtonPressed) of
-            | signum vnormal >= 0 = AxisPositive
+            Just act -> partEmit t (ActionMessage act time)
-            | signum vnormal < 0 = AxisNegative
+            _        -> return ()
-      case tmap Map.!? (AxisAction axis align) of
+        _ -> return ()
-        Just (ActUp _)    -> partEmit t (ActionMessage (ActUp sigvnormal) time)
-        Just (ActDown _)  -> partEmit t (ActionMessage (ActDown sigvnormal) time)
-        Just (ActLeft _)  -> partEmit t (ActionMessage (ActLeft sigvnormal) time)
-        Just (ActRight _) -> partEmit t (ActionMessage (ActRight sigvnormal) time)
-        _              -> return ()
     _ -> return ()
-emitJoyActionMessage (MsgJoystickButton time _ but SDL.JoyButtonPressed) = do
-  ud <- getAffection
-  let Subsystems _ _ _ _ t = subsystems ud
-  case (translation ud) of
-    JoyTranslation tmap -> do
-      case tmap Map.!? (ButtonAction but SDL.JoyButtonPressed) of
-        Just act -> partEmit t (ActionMessage act time)
-        _        -> return ()
-    _ -> return ()
-emitJoyActionMessage _ = return ()
 
-emitKbdActionMessage :: KeyboardMessage -> Affection UserData ()
+emitKbdActionMessage :: UserData -> KeyboardMessage -> Affection ()
-emitKbdActionMessage (MsgKeyboardEvent time _ press False sym) = do
+emitKbdActionMessage ud (MsgKeyboardEvent time _ press False sym) = do
-  ud <- getAffection
   let Subsystems _ _ _ _ t = subsystems ud
       val = if press == SDL.Pressed then 1 else 0
-  case (translation ud) of
+  trans <- liftIO $ readMVar (translation ud)
+  case trans of
     KbdTranslation tmap -> do
       case tmap Map.!? SDL.keysymKeycode sym of
         Just (ActUp _)    -> partEmit t (ActionMessage (ActUp val) time)
@@ -348,13 +357,12 @@ emitKbdActionMessage (MsgKeyboardEvent time _ press False sym) = do
         Just act -> when (press == SDL.Pressed) (partEmit t (ActionMessage act time))
         _        -> return ()
     _ -> return ()
-emitKbdActionMessage _ = return ()
+emitKbdActionMessage _ _ = return ()
 
-fullClean :: Affection UserData ()
+fullClean :: UserData -> Affection ()
-fullClean = do
+fullClean ud = do
-  ud <- getAffection
   let Subsystems w m k j t = subsystems ud
-      toClean              = uuid ud
+  toClean <- liftIO $ readMVar $ uuid ud
   mapM_ (\u -> do
     partUnSubscribe w u
     partUnSubscribe m u
@@ -362,6 +370,4 @@ fullClean = do
     partUnSubscribe j u
     partUnSubscribe t u
     ) toClean
-  putAffection ud
+  void $ liftIO $ swapMVar (uuid ud) []
-    { uuid = []
-    }

tracer-game.cabal

@@ -59,7 +59,7 @@ executable tracer-game
                      , DataKinds
   -- other-extensions:    
   build-depends:       base >=4.10 && <5
-                     , affection == 0.0.0.9
+                     , affection == 0.0.0.10
                      , sdl2 >= 2.4.0.0
                      , OpenGL
                      , nanovg >= 0.6.0.0
@@ -79,6 +79,8 @@ executable tracer-game
                      , algebraic-graphs
                      , mtl
                      , parallel
+                     , split
+                     , resourcet
   hs-source-dirs:      src
   ghc-options:         -Wall -threaded
   default-language:    Haskell2010