fix flake and update

.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 +verbose
-profiling: True

cabal.project

@@ -1,4 +0,0 @@
-packages:
-  ./
-  ../affection
-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,102 +1,14 @@
-{ nixpkgs ? import <nixpkgs> {}, compiler ? "default", doBenchmark ? false }:
+{ pkgs ? import <nixpkgs> {}}:
 
 let
-
-  inherit (nixpkgs) pkgs;
-
-  affection = with haskellPackages; callPackage(
-    { mkDerivation, base, bytestring, clock, containers, glib, linear
-    , monad-loops, monad-parallel, mtl, OpenGL, sdl2, stdenv, stm, text
-    , uuid, vector
-    }:
-    mkDerivation {
-      pname = "affection";
-      version = "0.0.0.10";
-      src = ../affection;
-      isLibrary = true;
-      isExecutable = true;
-      libraryHaskellDepends = [
-        base bytestring clock containers glib linear monad-loops
-        monad-parallel mtl OpenGL sdl2 stm text uuid vector
-      ];
-      homepage = "https://github.com/nek0/affection#readme";
-      description = "A simple Game Engine using SDL";
-      license = stdenv.lib.licenses.lgpl3;
-      doHaddock = false;
-    }) {};
-
-  algebraic-graphs = with haskellPackages; callPackage(
-    { mkDerivation, array, base, containers, deepseq, extra
-    , inspection-testing, mtl, QuickCheck, stdenv, transformers
-    }:
-    mkDerivation {
-      pname = "algebraic-graphs";
-      version = "0.5";
-      sha256 = "89b9fecf8245476ec823355125fcb95decf41fd9784e807d7bd0d09f0a79c50b";
-      libraryHaskellDepends = [
-        array base containers deepseq mtl transformers
-      ];
-      testHaskellDepends = [
-        array base containers deepseq extra inspection-testing mtl
-        QuickCheck transformers
-      ];
-      homepage = "https://github.com/snowleopard/alga";
-      description = "A library for algebraic graph construction and transformation";
-      license = stdenv.lib.licenses.mit;
-    }
-  ) {};
-
-  nanovg = with haskellPackages; callPackage(
-    { mkDerivation, base, bytestring, c2hs, containers, glew
-    , hspec, inline-c, libGL, libGLU, QuickCheck, stdenv, text, vector
-    }:
-    mkDerivation {
-      pname = "nanovg";
-      version = "0.6.0.0";
-      sha256 = "e35a2772f2a2e71916013cab70eeb8eedd6f66b5490ddf7ce237c8c76895d496";
-      revision = "1";
-      editedCabalFile = "1lhfsq50r9bdby7mfscw8ih3wsz2m19lr2a2z9b6diaf5kz76vij";
-      configureFlags = [ "-fgl3" ];
-      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";
-      license = stdenv.lib.licenses.isc;
-      doCheck = false;
-    }) {};
-
-  f = { mkDerivation, astar, base
-      , bytestring, containers, ecstasy, JuicyPixels, JuicyPixels-extra
-      , linear, matrix, mtl, OpenGL, parallel, random, sdl2
-      , split, stdenv, stm, text, unordered-containers, vector
-      }:
-      mkDerivation {
-        pname = "tracer-game";
-        version = "0.0.0.0";
-        src = ./.;
-        isLibrary = false;
-        isExecutable = true;
-        executableHaskellDepends = [
-          affection algebraic-graphs astar base bytestring containers ecstasy
-          JuicyPixels JuicyPixels-extra linear matrix mtl nanovg OpenGL
-          parallel random sdl2 split stm text unordered-containers vector
-        ];
-        license = stdenv.lib.licenses.gpl3;
+  # create a modified haskell package set with my package inside it and broken dependencies
+  # jailbroken.
+  hpkgs = pkgs.haskellPackages.override {
+    overrides = hself: hsuper: {
+      tracer-game = hself.callCabal2nix "tracer-game" (gitignore ./.) {};
+      affection = hself.callCabal2nix "affection" (gitignore ../affection) {};
     };
-
-  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 {});
-
+  };
+  gitignore = dir: pkgs.nix-gitignore.gitignoreSource [] dir;
 in
-
-  if pkgs.lib.inNixShell then drv.env else drv
+  hpkgs.tracer-game.env

src/Init.hs

@@ -77,7 +77,7 @@ 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

src/Load.hs

@@ -8,16 +8,19 @@ import Graphics.Rendering.OpenGL.GL.FlushFinish (finish)
 import Control.Concurrent (forkIO)
 import Control.Concurrent.MVar
 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
 
@@ -43,7 +46,7 @@ loadLoad ud = do
       (nano ud)
       (stateMVar ud)
       (stateProgress ud)
-  SDL.glMakeCurrent (fromJust curWin) (snd $ head $ glContext ad)
+  SDL.glMakeCurrent (fromJust curWin) (acContext $ head $ glContext ad)
   void $ liftIO $ swapMVar (state ud) Load
   void $ liftIO $ swapMVar (assetFonts ud) (M.fromList
     [ (FontBedstead, "bedstead")
@@ -51,12 +54,12 @@ loadLoad ud = do
     )
 
 loadFork
-  :: SystemState Entity (AffectionState (AffectionData) IO)
+  :: SystemState Entity (AffectionState (AffectionData) ResIO)
   -> SDL.Window
   -> SDL.GLContext
   -> Context
   -> MVar
-    ( SystemState Entity (AffectionState (AffectionData) IO)
+    ( SystemState Entity (AffectionState (AffectionData) ResIO)
     , StateData
     )
   -> MVar (Float, T.Text)
@@ -69,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
         ]
@@ -334,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\""
@@ -506,6 +521,8 @@ loadFork ws win glc nvg future progress = do
           playerWalking ++
           jdoemStanding ++
           jdoemWalking ++
+          policemStanding ++
+          policemWalking ++
           copierStand ++
           copierCopy ++
           cornerComputerOff ++

src/Main.hs

@@ -17,6 +17,7 @@ import Data.Maybe (fromJust)
 
 import Control.Monad
 import Control.Concurrent.MVar
+import Control.Monad.Trans.Resource (allocate)
 
 -- internal imports
 
@@ -45,7 +46,7 @@ main = do
         , windowConfigs   =
           [ ( 0
             , SDL.defaultWindow
-              { SDL.windowInitialSize     = V2 1280 720
+              { SDL.windowInitialSize     = V2 1920 1080
               , SDL.windowResizable       = True
               , SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL
                 { SDL.glProfile = SDL.Core SDL.Normal 3 3
@@ -60,17 +61,18 @@ main = do
 pre :: UserData -> Affection ()
 pre ud = do
   ad <- A.get
-  threadCtx <- SDL.glCreateContext ((\(_, y, _) -> y) $ head $ drawWindows ad)
-  SDL.glMakeCurrent ((\(_, y, _) -> y) $ head $ drawWindows ad) (snd $ head $ glContext ad)
+  let (AffectionWindow awwindow _ _) = head $ drawWindows ad
+  threadCtx <- SDL.glCreateContext awwindow
+  SDL.glMakeCurrent awwindow (acContext $ head $ glContext ad)
   let Subsystems w _ k j _ = subsystems ud
-  _ <- partSubscribe w (fitViewport (1280/720))
+  _ <- partSubscribe w (fitViewport (1920/1080))
   _ <- partSubscribe w (exitOnWindowClose ud)
   _ <- partSubscribe k toggleFullScreen
   _ <- partSubscribe k (quitGame ud)
   u <- partSubscribe j (cacheJoypad ud)
   (ws, _) <- yieldSystemT (0, defStorage) (return ())
   void $ liftIO $ swapMVar (threadContext ud) (Just threadCtx)
-  void $ liftIO $ swapMVar (window ud) (Just $ (\(_, y, _) -> y) $ head $ drawWindows ad)
+  void $ liftIO $ swapMVar (window ud) (Just awwindow)
   void $ liftIO $ putMVar (worldState ud) ws
   void $ liftIO $ putMVar (joyUUID ud) u
 
@@ -90,8 +92,8 @@ quitGame ud (MsgKeyboardEvent _ _ SDL.Pressed False sym)
       mapM_ (partUnSubscribe j) curUUID
       mapM_ (partUnSubscribe t) curUUID
       SDL.glMakeCurrent
-        ((\(_, y, _) -> y) $ head $ drawWindows ad)
-        (snd $ head $ glContext ad)
+        (awWindow $ head $ drawWindows ad)
+        (acContext $ head $ glContext ad)
       (ws, _) <- yieldSystemT (0, defStorage) (return ())
       void $ liftIO $ swapMVar (worldState ud) ws
       void $ liftIO $ swapMVar (state ud) Load

src/MainGame/WorldMap.hs

@@ -12,6 +12,7 @@ import NanoVG hiding (V2(..))
 
 import Control.Monad (when, void)
 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)
@@ -85,7 +86,7 @@ changeMaps2 _ _ = return ()
 loadMapFork
   :: UserData
   -> AffectionData
-  -> MVar (SystemState Entity (AffectionState AffectionData IO), StateData)
+  -> MVar (SystemState Entity (AffectionState AffectionData ResIO), StateData)
   -> MVar (Float, T.Text)
   -> IO ()
 loadMapFork ud ad future progress = do
@@ -94,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"
@@ -130,7 +131,7 @@ loadMapFork ud ad future progress = do
     , "Creating WorldState"
     )))
   wState <- liftIO $ readMVar (worldState ud)
-  (nws, mmimgmat) <- evalStateT (runState (yieldSystemT wState $ do
+  (nws, mmimgmat) <- runResourceT $ evalStateT (runState (yieldSystemT wState $ do
     liftIO $ modifyMVar_ progress (return . (\(p, _) ->
       ( p + increment
       , "Registering copiers into WorldState"
@@ -248,6 +249,7 @@ loadMapFork ud ad future progress = do
         <*> (randomRIO (0, 1))
         <*> (randomRIO (0, 1))
         <*> (randomRIO (0, 1))
+      police <- liftIO $ randomRIO (0 :: Int, 9 :: Int)
       let room = V.head
             (V.filter
               ((inBounds $ pointCoord cpr) . bounds)
@@ -264,7 +266,8 @@ loadMapFork ud ad future progress = do
         , 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, _) ->
@@ -617,10 +620,12 @@ drawMap ud = do
           "FPS: "
           <> T.pack (Prelude.take 5 $ show (1/dt))
           <> " Clearance: "
-          <> if not (Prelude.null room)
+          <> (if not (Prelude.null room)
             then T.pack (show $ clearance $ V.head room)
             else "0"
             )
+          -- <> "\nFor answers call 6350"
+          )
 
 drawTile
   :: UserData

src/NPC.hs

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

src/Types/Animation.hs

@@ -46,6 +46,7 @@ data AnimationName
   | AnimComputer
   | AnimToilet
   | AnimJDoeM
+  | AnimPoliceM
   | AnimDoor0
   deriving (Show, Eq, Ord, Enum)
 

src/Types/ObjClass.hs

@@ -5,6 +5,7 @@ module Types.ObjClass where
 
 import Affection
 
+import Control.Monad.Trans.Resource (ResIO)
 import Data.Ecstasy
 
 import Types.Entity
@@ -15,7 +16,7 @@ class ObjectAction otype ostate where
     -> otype
     -> ostate
     -> Ent
-    -> SystemT Entity (AffectionState AffectionData IO) ()
+    -> SystemT Entity (AffectionState AffectionData ResIO) ()
 
   objectTransition
     :: otype
@@ -23,7 +24,7 @@ class ObjectAction otype ostate where
     -> Bool
     -> Ent
     -> Maybe Ent
-    -> SystemT Entity (AffectionState AffectionData IO) (Entity 'SetterOf)
+    -> SystemT Entity (AffectionState AffectionData ResIO) (Entity 'SetterOf)
 
 class ActionTime otype ostate where
   actionTime :: otype -> ostate -> 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
@@ -34,10 +35,10 @@ data UserData = UserData
   , translation     :: MVar Translation
   , nano            :: Context
   , uuid            :: MVar [UUID]
-  , worldState      :: MVar (SystemState Entity (AffectionState AffectionData IO))
+  , worldState      :: MVar (SystemState Entity (AffectionState AffectionData ResIO))
   , stateData       :: MVar StateData
   , stateMVar       :: MVar
-    ( SystemState Entity (AffectionState AffectionData IO)
+    ( SystemState Entity (AffectionState AffectionData ResIO)
     , StateData
     )
   , stateProgress   :: MVar (Float, T.Text)

src/Util.hs

@@ -257,7 +257,7 @@ 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

tracer-game.cabal

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