Compare commits

..

34 commits

Author SHA1 Message Date
01183a2465 fix flake and update 2023-11-24 18:55:42 +01:00
Amedeo Molnár
009cd6fac7 adjust flake to include haskell build inputs 2023-04-20 10:32:27 +02:00
13700f1b55 update flake 2023-04-20 07:04:45 +02:00
c044dc89da add .envrc 2023-04-20 06:59:47 +02:00
367ba034b6 ignore result symlink 2023-03-25 21:49:13 +01:00
3bc7faa7cd update flake 2023-03-25 13:52:56 +01:00
df2cfcf411 update flake 2022-12-27 19:40:55 +01:00
a7ce6f36a1 update flake 2022-12-01 22:09:04 +01:00
07edd99d0a remove ballast 2022-12-01 14:34:38 +01:00
dd8556ee2b some update 2022-09-14 20:10:20 +02:00
66f9d07905 flakify complete 2022-09-14 19:49:03 +02:00
518e27d1a8 flakify 2022-09-14 19:03:04 +02:00
cd2a0f3706 update to new affection 2022-08-04 18:13:53 +02:00
eecfe82abd follow NanoVG changes 2022-02-18 21:34:02 +01:00
f8ea2785bf modernize shell.nix 2022-02-18 21:33:40 +01:00
f678b216d6 add policeman 2020-05-12 16:24:36 +02:00
0cc3195455 add missing library 2020-05-12 16:22:21 +02:00
cdd5db2b73 finish porting process 2020-05-05 10:26:16 +02:00
a33fec68d4 bump module Load to affection 0.0.0.10 2020-05-05 09:13:39 +02:00
eea0ec07fd bumped module Floorplan to affection 0.0.0.10 2020-05-05 07:13:15 +02:00
ace1f0ce8c bumped module Menu.Adjust to affection 0.0.0.10 2020-05-05 07:05:59 +02:00
81e16c4428 bump module NPC to affection 0.0.0.10 2020-05-05 06:31:36 +02:00
8f2366502b bump module Util to affection 0.0.0.10 2020-05-05 06:29:35 +02:00
808ab1db06 fix more UserData stuff 2020-05-05 01:23:40 +02:00
adf5eefcdc bump UserData object and Util 2020-05-05 01:12:53 +02:00
83b3bbcd9b hunt warnings 2020-05-05 01:03:59 +02:00
c110f29c8f port module Types.ObjClass 2020-05-05 00:53:46 +02:00
55f688e9be port module Types.UserData 2020-05-05 00:52:24 +02:00
7a5e30c6ed bump affection version 2020-05-05 00:48:05 +02:00
d9a8045daa updated shell.nix 2019-11-12 00:49:54 +01:00
f61bc52ca6 Get tiles in an unsafe manner 2019-11-02 09:44:50 +01:00
7f1de2ae15 textify 2019-10-28 18:20:34 +01:00
42126a972d fix logging 2019-10-28 17:26:21 +01:00
7c59021aee various speed optimizations 2019-10-20 10:53:53 +02:00
34 changed files with 1152 additions and 1179 deletions

1
.envrc Normal file
View file

@ -0,0 +1 @@
use flake

2
.gitignore vendored
View file

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

BIN
assets/policem.kra Normal file

Binary file not shown.

BIN
assets/policem.png Normal file

Binary file not shown.

After

Width:  |  Height:  |  Size: 17 KiB

View file

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

View file

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

84
flake.lock Normal file
View file

@ -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
}

46
flake.nix Normal file
View file

@ -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});
};
});
}

272
shell.nix
View file

@ -1,264 +1,14 @@
{ nixpkgs ? import <nixpkgs> {}, compiler ? "default", doBenchmark ? false }: { pkgs ? import <nixpkgs> {}}:
let 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, split
, 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 split 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 in
hpkgs.tracer-game.env
if pkgs.lib.inNixShell then drv.env else drv

View file

@ -6,6 +6,8 @@ import Data.Matrix (Matrix(..))
import qualified Data.Matrix as M import qualified Data.Matrix as M
import qualified Data.Text as T import qualified Data.Text as T
import Data.Maybe import Data.Maybe
import qualified Data.Vector as V
import Data.String
import Linear (V2(..)) import Linear (V2(..))
@ -24,7 +26,7 @@ buildHallFloorIO
:: FloorConfig :: FloorConfig
-> MVar (Float, T.Text) -> MVar (Float, T.Text)
-> Float -> Float
-> IO (Matrix TileState, [Graph]) -> IO (Matrix TileState, V.Vector Graph)
buildHallFloorIO fc progress increment = do buildHallFloorIO fc progress increment = do
rand <- newStdGen rand <- newStdGen
modifyMVar_ progress (return . (\(p, _) -> modifyMVar_ progress (return . (\(p, _) ->
@ -76,8 +78,12 @@ buildHallFloorIO fc progress increment = do
( p + increment ( p + increment
, "Assigned room clearances" , "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) return (facils, accessGraph)
emptyFloor :: FloorConfig -> Matrix TileState emptyFloor :: FloorConfig -> Matrix TileState
@ -316,6 +322,7 @@ buildFacilities gen fc input =
in (ngen, facilFlood facil acc x) in (ngen, facilFlood facil acc x)
) (gen, input) nearests ) (gen, input) nearests
facilFlood :: TileState -> Matrix TileState -> (Int, Int) -> Matrix TileState
facilFlood ts mat coords@(cr, cc) = facilFlood ts mat coords@(cr, cc) =
let cur = mat M.! coords let cur = mat M.! coords
altered = M.setElem ts coords mat altered = M.setElem ts coords mat
@ -345,25 +352,30 @@ findNearestOffice mat (V2 rrr ccc) =
else acc else acc
) (fst $ head inlist) inlist ) (fst $ head inlist) inlist
buildDoorsGraph :: Matrix TileState -> IO [Graph] buildDoorsGraph :: Matrix TileState -> IO (V.Vector Graph)
buildDoorsGraph mat = buildDoorsGraph mat =
weedOut $ buildGraph mat mat [GHall []] (2, 2) weedOut (buildGraph mat mat (V.singleton (GHall V.empty)) (2, 2))
where 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)
buildGraph buildGraph
:: Matrix TileState :: Matrix TileState
-> Matrix TileState -> Matrix TileState
-> [Graph] -> V.Vector Graph
-> (Int, Int) -> (Int, Int)
-> [Graph] -> V.Vector Graph
buildGraph amat mat root coord@(br, bc) buildGraph amat mat root coord@(br, bc)
| bc > ncols amat - 1 = | bc > ncols amat - 1 =
buildGraph amat mat root (br + 1, 1) buildGraph amat mat root (br + 1, 1)
@ -374,29 +386,29 @@ buildGraph amat mat root coord@(br, bc)
b = Boundaries b = Boundaries
(minimum (map fst roomcoords), minimum (map snd roomcoords)) (minimum (map fst roomcoords), minimum (map snd roomcoords))
(maximum (map fst roomcoords), maximum (map snd roomcoords)) (maximum (map fst roomcoords), maximum (map snd roomcoords))
neighs = map (\(a, bx) -> (a, fromJust bx)) (filter ((/=Nothing) . snd) neighs = V.map (\(a, bx) -> (a, fromJust bx)) (V.filter ((/=Nothing) . snd)
[ (North, M.safeGet (fst (matmin b) - 2) (snd (matmin b)) amat) $ V.fromList
, (South, M.safeGet (fst (matmax b) + 2) (snd (matmin b)) amat) [ (North, M.safeGet (fst (matmin b) - 2) (snd (matmin b)) amat)
, (West, M.safeGet (fst (matmin b)) (snd (matmin b) - 2) amat) , (South, M.safeGet (fst (matmax b) + 2) (snd (matmin b)) amat)
, (East, M.safeGet (fst (matmin b)) (snd (matmax b) + 2) amat) , (West, M.safeGet (fst (matmin b)) (snd (matmin b) - 2) amat)
]) , (East, M.safeGet (fst (matmin b)) (snd (matmax b) + 2) amat)
])
in in
if Hall `elem` map snd neighs if Hall `V.elem` V.map snd neighs
then then
let nroot = let nroot =
if GRoom neighs b 0 Offi `notElem` connects (head root) if GRoom neighs b 0 Offi `V.notElem` connects (V.head root)
then then
GHall GHall
{ connects = connects (head root) ++ { connects = connects (V.head root) `V.snoc`
[GRoom neighs b 0 Offi] GRoom neighs b 0 Offi
} : tail root } `V.cons` V.tail root
else root else root
in buildGraph amat mat nroot (br, 1 + snd (matmax b)) in buildGraph amat mat nroot (br, 1 + snd (matmax b))
else else
let nroot = root ++ let nroot = if GRoom neighs b 0 Offi `V.elem` root
if GRoom neighs b 0 Offi `elem` root then root
then [] else root `V.snoc` GRoom neighs b 0 Offi
else [GRoom neighs b 0 Offi]
in buildGraph amat mat nroot (br, 1 + snd (matmax b)) in buildGraph amat mat nroot (br, 1 + snd (matmax b))
| otherwise = | otherwise =
buildGraph amat mat root (br, maxCol br (bc + 1)) buildGraph amat mat root (br, maxCol br (bc + 1))
@ -406,6 +418,7 @@ buildGraph amat mat root coord@(br, bc)
| otherwise = c | otherwise = c
flood :: Matrix TileState -> [(Int, Int)] -> (Int, Int) -> [(Int,Int)]
flood amat acc (fr, fc) = flood amat acc (fr, fc) =
let ncoords = [] ++ let ncoords = [] ++
(if (fr + 1, fc) `notElem` acc && (if (fr + 1, fc) `notElem` acc &&
@ -426,32 +439,32 @@ flood amat acc (fr, fc) =
else []) else [])
in foldl (flood amat) (acc ++ ncoords) ncoords in foldl (flood amat) (acc ++ ncoords) ncoords
assignClearance :: [Graph] -> M.Matrix TileState -> IO [Graph] assignClearance :: V.Vector Graph -> M.Matrix TileState -> IO (V.Vector Graph)
assignClearance graph imat = assignClearance graph imat =
foldM doAssignClearance [] graph V.foldM doAssignClearance V.empty graph
where where
doAssignClearance acc (GHall conns) = do doAssignClearance acc (GHall conns) = do
ret <- GHall <$> foldM (\facc a -> do ret <- GHall <$> V.foldM (\facc a -> do
res <- reassign True facc a res <- reassign True facc a
return (facc ++ [res]) return (facc `V.snoc` res)
) [] conns ) V.empty conns
return (ret : acc) return (ret `V.cons` acc)
doAssignClearance acc room = do doAssignClearance acc room = do
ret <- reassign False acc room 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 _ _) = reassign p acc room@(GRoom ns b _ _) =
if p if p
then do then do
if actualRoomType b imat == Offi if actualRoomType b imat == Offi
then do 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 onlyrooms) (\n -> findNeighbor n b onlyrooms)
nonhalls nonhalls
) )
onlyrooms = tail graph onlyrooms = V.tail graph
nonhalls = ns -- filter ((/= Hall) . snd) ns nonhalls = ns -- filter ((/= Hall) . snd) ns
if not (null neigh) && any ((Offi /=) . flip actualRoomType imat . bounds) neigh if not (null neigh) && any ((Offi /=) . flip actualRoomType imat . bounds) neigh
then then
@ -464,19 +477,22 @@ assignClearance graph imat =
if actualRoomType b imat == Offi if actualRoomType b imat == Offi
then do then do
let neigh = let neigh =
catMaybes V.fromList $ catMaybes $ V.toList $
(map (V.map
(\n -> findNeighbor n b onlyrooms) (\n -> findNeighbor n b onlyrooms)
nonhalls nonhalls
) )
onlyrooms = connects (head acc) onlyrooms = connects (V.head acc)
nonhalls = ns -- filter ((/= Hall) . snd) ns nonhalls = ns -- filter ((/= Hall) . snd) ns
ret <- if null neigh ret <- if null neigh
then doRandomAssign room then doRandomAssign room
else doBoundedAssign room (clearance $ head neigh) else doBoundedAssign room (clearance $ V.head neigh)
return ret return ret
else else
return room return room
reassign _ _ (GHall _) = do
logIO A.Error "cannot reassign Hallways!"
error "*dies*"
actualRoomType :: Boundaries Int -> M.Matrix TileState -> TileState actualRoomType :: Boundaries Int -> M.Matrix TileState -> TileState
actualRoomType (Boundaries (minrow, mincol) (maxrow, maxcol)) imat = actualRoomType (Boundaries (minrow, mincol) (maxrow, maxcol)) imat =
@ -501,7 +517,7 @@ doBoundedAssign g b = do
findNeighbor findNeighbor
:: (GraphDirection, TileState) :: (GraphDirection, TileState)
-> Boundaries Int -> Boundaries Int
-> [Graph] -> V.Vector Graph
-> Maybe Graph -> Maybe Graph
findNeighbor (dir, _) bnds ingraph findNeighbor (dir, _) bnds ingraph
| dir == North = | dir == North =
@ -522,27 +538,34 @@ findNeighbor (dir, _) bnds ingraph
in postprocess row col in postprocess row col
where where
postprocess row col = postprocess row col =
let filtered = filter let filtered = V.filter
(inBounds (V2 row col) . bounds) (inBounds (V2 row col) . bounds)
ingraph ingraph
in in
case filtered of if V.null filtered
[a@(GRoom _ _ _ _)] -> Just a then Nothing
[] -> Nothing else if V.length filtered == 1
_ -> error "findNeighbor: Non-singleton filter result" then
case V.head filtered of
a@(GRoom _ _ _ _) -> Just a
_ -> 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
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
@ -566,7 +589,7 @@ placeDoors amat (GRoom neighs 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

View file

@ -11,7 +11,9 @@ import Codec.Picture as CP
import Codec.Picture.Extra import Codec.Picture.Extra
import Control.Concurrent.STM import Control.Concurrent.STM
import Control.Concurrent.MVar
import Data.String
import qualified Data.Set as S import qualified Data.Set as S
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
import Data.ByteString.Lazy (toStrict) import Data.ByteString.Lazy (toStrict)
@ -35,21 +37,26 @@ init = do
<*> (SubTranslator <$> newTVarIO []) <*> (SubTranslator <$> newTVarIO [])
_ <- glewInit _ <- glewInit
nvg <- createGL3 (S.fromList [NanoVG.Debug, Antialias, StencilStrokes]) 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 loadPlayerSprite
:: FilePath -- Path to spritemap :: FilePath -- Path to spritemap
@ -62,7 +69,7 @@ loadPlayerSprite fp w h nvg rids = do
eimg <- readImage fp eimg <- readImage fp
case eimg of case eimg of
Left err -> do Left err -> do
logIO Error err logIO Error (fromString err)
exitFailure exitFailure
Right dimg -> do Right dimg -> do
let img = convertRGBA8 dimg let img = convertRGBA8 dimg
@ -70,10 +77,16 @@ loadPlayerSprite fp w h nvg rids = do
mapM (\(num, i) -> do mapM (\(num, i) -> do
let cr = crop (num * w) (row * h) w h img let cr = crop (num * w) (row * h) w h img
mresimg <- mresimg <-
createImageMem nvg ImagePremultiplied (toStrict $ encodePng cr) createImageMem nvg (S.singleton ImagePremultiplied) (toStrict $ encodePng cr)
case mresimg of case mresimg of
Nothing -> do Nothing -> do
logIO Error ("Failed to load: " ++ fp ++ " " ++ show i) logIO
Error
("Failed to load: " <>
fromString fp <>
" " <>
fromString (show i)
)
exitFailure exitFailure
Just resimg -> return (i, resimg) Just resimg -> return (i, resimg)
) (zip [0..] ids) ) (zip [0..] ids)

View file

@ -1,7 +1,5 @@
module Interior where module Interior where
import qualified Affection as A
import Data.Matrix as M import Data.Matrix as M
import qualified Data.Map.Strict as Map import qualified Data.Map.Strict as Map
import Data.List as L import Data.List as L

View file

@ -7,16 +7,20 @@ import Graphics.Rendering.OpenGL.GL.FlushFinish (finish)
import Control.Concurrent (forkIO) import Control.Concurrent (forkIO)
import Control.Concurrent.MVar 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.Map as M
import qualified Data.Text as T import qualified Data.Text as T
import Data.Ecstasy import Data.Ecstasy
import Data.Maybe import Data.Maybe
import qualified Data.Set as S
import Data.String
import System.Exit (exitFailure) import System.Exit (exitFailure)
import NanoVG hiding (V2(..)) import NanoVG hiding (V2(..))
import NanoVG.Internal.Image
-- internal imports -- internal imports
@ -24,39 +28,38 @@ import Menu.Connect
import Types import Types
import Util import Util
loadLoad :: Affection UserData () loadLoad :: UserData -> Affection ()
loadLoad = do loadLoad ud = do
ad <- A.get 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" _ <- liftIO $ createFont (nano ud) "bedstead"
(FileName "assets/font/Bedstead-Semicondensed.ttf") (FileName "assets/font/Bedstead-Semicondensed.ttf")
_ <- liftIO $ forkIO $ _ <- liftIO $ forkIO $
loadFork loadFork
(worldState ud) wState
(fromJust $ window ud) (fromJust curWin)
(fromJust $ threadContext ud) (fromJust tContext)
(nano ud) (nano ud)
future (stateMVar ud)
progress (stateProgress ud)
SDL.glMakeCurrent (fromJust $ window ud) (snd $ head $ 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 loadFork
:: SystemState Entity (AffectionState (AffectionData UserData) IO) :: SystemState Entity (AffectionState (AffectionData) ResIO)
-> SDL.Window -> SDL.Window
-> SDL.GLContext -> SDL.GLContext
-> Context -> Context
-> MVar -> MVar
( SystemState Entity (AffectionState (AffectionData UserData) IO) ( SystemState Entity (AffectionState (AffectionData) ResIO)
, StateData , StateData
) )
-> MVar (Float, T.Text) -> MVar (Float, T.Text)
@ -69,202 +72,202 @@ loadFork ws win glc nvg future progress = do
( p + increment ( p + increment
, "Loading icon \"conntroller_blue\"" , "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, _) -> modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Loading icon \"controller_blue\"" , "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, _) -> modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Loading icon \"controller_green\"" , "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, _) -> modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Loading icon \"keyboard_blue\"" , "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, _) -> modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Loading icon \"keyboard_green\"" , "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, _) -> modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Loading asset \"wall_asc\"" , "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, _) -> modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Loading asset \"wall_desc\"" , "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, _) -> modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Loading asset \"wall_corner_n\"" , "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, _) -> modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Loading asset \"wall_corner_e\"" , "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, _) -> modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Loading asset \"wall_corner_s\"" , "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, _) -> modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Loading asset \"wall_corner_w\"" , "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, _) -> modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Loading asset \"wall_t_ne\"" , "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, _) -> modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Loading asset \"wall_t_se\"" , "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, _) -> modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Loading asset \"wall_t_sw\"" , "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, _) -> modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Loading asset \"wall_t_nw\"" , "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, _) -> modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Loading asset \"wall_cross\"" , "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, _) -> modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Loading asset \"box1\"" , "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, _) -> modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Loading asset \"tableSW\"" , "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, _) -> modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Loading asset \"tableSE\"" , "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, _) -> modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Loading asset \"tableNE\"" , "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, _) -> modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Loading asset \"tableNW\"" , "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, _) -> modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Loading asset \"tableC1\"" , "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, _) -> modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Loading asset \"tableC2\"" , "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, _) -> modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Loading asset \"tableC3\"" , "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, _) -> modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Loading asset \"tableC4\"" , "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, _) -> modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Loading asset \"tableCorner\"" , "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, _) -> modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Loading asset \"flipchart\"" , "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, _) -> modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Loading asset \"plant1\"" , "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, _) -> modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Loading asset \"plant2\"" , "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, _) -> modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Loading asset \"watercooler\"" , "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, _) -> modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Loading asset \"vending machine\"" , "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, _) -> modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Loading asset \"Cabinet with Coffee machine SW\"" , "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, _) -> modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Loading asset \"Cabinet with Coffee machine SE\"" , "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, _) -> modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Loading asset \"Cabinet with sink SW\"" , "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, _) -> modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Loading asset \"Cabinet with sink SE\"" , "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, _) -> modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Loading asset \"Cabinet with stove SW\"" , "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, _) -> modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Loading asset \"Cabinet with stove SE\"" , "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, _) -> modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Loading asset \"cabinet SW\"" , "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, _) -> modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Loading asset \"cabinet SE\"" , "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, _) -> modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Loading asset \"cabinet corner\"" , "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 = let micons =
[ mcontrblue, mcontrgreen, mkbdblue, mkbdgreen, marrow [ mcontrblue, mcontrgreen, mkbdblue, mkbdgreen, marrow
] ]
@ -334,6 +337,18 @@ loadFork ws win glc nvg future progress = do
))) )))
jdoemWalking <- loadAnimationSprites "assets/jdoem.png" nvg jdoemWalking <- loadAnimationSprites "assets/jdoem.png" nvg
(zip (walkIds AnimJDoeM) walkConfigs) (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, _) -> modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Loading Animation \"copier: stand\"" , "Loading Animation \"copier: stand\""
@ -490,9 +505,13 @@ loadFork ws win glc nvg future progress = do
] ]
modifyMVar_ progress (return . (\(p, _) -> modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Handing over" , "GL_Finish"
))) )))
finish finish
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Handing over"
)))
putMVar future putMVar future
( ws ( ws
, LoadData , LoadData
@ -502,6 +521,8 @@ loadFork ws win glc nvg future progress = do
playerWalking ++ playerWalking ++
jdoemStanding ++ jdoemStanding ++
jdoemWalking ++ jdoemWalking ++
policemStanding ++
policemWalking ++
copierStand ++ copierStand ++
copierCopy ++ copierCopy ++
cornerComputerOff ++ cornerComputerOff ++
@ -524,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) progress <- liftIO $ readMVar (stateProgress ud)
liftIO $ do liftIO $ do
logIO A.Verbose ("LoadProgress: " ++ show progress) logIO A.Verbose ("LoadProgress: " <> fromString (show progress))
drawLoadScreen ud progress drawLoadScreen ud progress
updateLoad :: Double -> Affection UserData () updateLoad :: UserData -> Double -> Affection ()
updateLoad _ = do updateLoad ud _ = do
ud <- getAffection
mwsld <- liftIO $ tryTakeMVar (stateMVar ud) mwsld <- liftIO $ tryTakeMVar (stateMVar ud)
case mwsld of case mwsld of
Just (_, ld) -> do Just (_, ld) -> do
liftIO $ logIO A.Debug "loaded assets, entering menu" 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 -- loadMap
loadMenu loadMenu ud
Nothing -> Nothing ->
return () return ()

View file

@ -15,7 +15,9 @@ import Foreign.C.Types (CInt(..))
import Data.Maybe (fromJust) import Data.Maybe (fromJust)
import Control.Monad (when) import Control.Monad
import Control.Concurrent.MVar
import Control.Monad.Trans.Resource (allocate)
-- internal imports -- internal imports
@ -27,105 +29,108 @@ import Util
foreign import ccall unsafe "glewInit" foreign import ccall unsafe "glewInit"
glewInit :: IO CInt 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 :: IO ()
main = do main = do
let config = AffectionConfig let config = AffectionConfig
{ initComponents = All { initComponents = All
, windowTitle = "Tracer" , windowTitle = "Tracer"
, windowConfigs = [ , windowConfigs =
( 0 [ ( 0
, SDL.defaultWindow , SDL.defaultWindow
{ SDL.windowInitialSize = V2 1280 720 { SDL.windowInitialSize = V2 1920 1080
, SDL.windowResizable = True , SDL.windowResizable = True
, SDL.windowOpenGL = Just SDL.defaultOpenGL , SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL
{ SDL.glProfile = SDL.Core SDL.Normal 3 3 { SDL.glProfile = SDL.Core SDL.Normal 3 3
}
} }
} , SDL.Windowed
) )
] ]
, canvasSize = Nothing } :: AffectionConfig UserData
, preLoop = pre >> smLoad Load
, eventLoop = handle
, updateLoop = update
, drawLoop = draw
, loadState = Init.init
, cleanUp = clean
, initScreenMode = SDL.Windowed
}
withAffection config withAffection config
pre :: Affection UserData () pre :: UserData -> Affection ()
pre = do pre ud = do
ad <- A.get ad <- A.get
ud <- getAffection let (AffectionWindow awwindow _ _) = head $ drawWindows ad
threadCtx <- SDL.glCreateContext (snd $ head $ drawWindows ad) threadCtx <- SDL.glCreateContext awwindow
SDL.glMakeCurrent (snd $ head $ drawWindows ad) (snd $ head $ 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 toggleFullScreen
_ <- partSubscribe k quitGame _ <- partSubscribe k (quitGame ud)
u <- partSubscribe j cacheJoypad u <- partSubscribe j (cacheJoypad ud)
(ws, _) <- yieldSystemT (0, defStorage) (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 (snd $ head $ drawWindows ad) void $ liftIO $ putMVar (worldState ud) ws
, worldState = ws void $ liftIO $ putMVar (joyUUID ud) u
, joyUUID = u
}
quitGame :: KeyboardMessage -> Affection UserData () quitGame :: UserData -> KeyboardMessage -> Affection ()
quitGame (MsgKeyboardEvent _ _ SDL.Pressed False sym) quitGame ud (MsgKeyboardEvent _ _ SDL.Pressed False sym)
| SDL.keysymKeycode sym == SDL.KeycodeEscape = quit | SDL.keysymKeycode sym == SDL.KeycodeEscape =
void $ liftIO $ swapMVar (doNextStep ud) False
| SDL.keysymKeycode sym == SDL.KeycodeF5 = do | SDL.keysymKeycode sym == SDL.KeycodeF5 = do
ad <- A.get 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 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 (snd $ head $ drawWindows ad) (snd $ head $ glContext ad) mapM_ (partUnSubscribe t) curUUID
SDL.glMakeCurrent
(awWindow $ head $ drawWindows ad)
(acContext $ head $ glContext ad)
(ws, _) <- yieldSystemT (0, defStorage) (return ()) (ws, _) <- yieldSystemT (0, defStorage) (return ())
putAffection ud void $ liftIO $ swapMVar (worldState ud) ws
{ worldState = ws void $ liftIO $ swapMVar (state ud) Load
, state = Load smLoad Load ud
} | otherwise = return ()
smLoad Load quitGame _ _ = return ()
| otherwise = return ()
quitGame _ = return ()
toggleFullScreen :: KeyboardMessage -> Affection UserData () toggleFullScreen :: KeyboardMessage -> Affection ()
toggleFullScreen (MsgKeyboardEvent _ _ SDL.Pressed False sym) toggleFullScreen (MsgKeyboardEvent _ _ SDL.Pressed False sym)
| SDL.keysymKeycode sym == SDL.KeycodeF11 = toggleScreen | SDL.keysymKeycode sym == SDL.KeycodeF11 = toggleScreen 0
| otherwise = return () | otherwise = return ()
toggleFullScreen _ = 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 liftIO $ beginFrame (nano ud) 1280 720 1
smDraw (state ud) smDraw curState ud
liftIO $ endFrame (nano 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" liftIO $ logIO A.Debug "Window Closed"
quit void $ liftIO $ swapMVar (doNextStep ud) False
exitOnWindowClose _ = return () exitOnWindowClose _ _ = return ()
clean :: UserData -> IO () clean :: UserData -> IO ()
clean ud = clean ud = do
SDL.glDeleteContext $ fromJust $ threadContext ud tContext <- readMVar (threadContext ud)
SDL.glDeleteContext $ fromJust tContext

View file

@ -11,9 +11,13 @@ import qualified Data.Text as T
import Data.List as L import Data.List as L
import Data.Ecstasy as E import Data.Ecstasy as E
import Data.Maybe import Data.Maybe
import Data.String
import NanoVG hiding (V2(..)) import NanoVG hiding (V2(..))
import Control.Concurrent.MVar
import Control.Monad
-- internal imports -- internal imports
import Types import Types
@ -24,145 +28,146 @@ import Collision
import Util 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 let ctx = nano ud
dt <- getDelta dt <- getDelta
(_, (playerPos, posanims)) <- yieldSystemT (worldState ud) $ do (_, (playerPos, posanims)) <- yieldSystemT wState $ do
pc <- fmap head $ efor allEnts $ do pc <- fmap head $ efor allEnts $ do
with player with player
with mmpos with mmpos
@ -176,7 +181,7 @@ drawMind = do
return (pos', stat, mbnds) return (pos', stat, mbnds)
return (pc, posanims) return (pc, posanims)
let V2 pr pc = playerPos let V2 pr pc = playerPos
mat = mmImgMat (stateData ud) mat = mmImgMat sData
cols = fromIntegral (ncols mat) cols = fromIntegral (ncols mat)
rows = fromIntegral (nrows mat) rows = fromIntegral (nrows mat)
tileWidth = 64 :: Double tileWidth = 64 :: Double
@ -184,8 +189,8 @@ drawMind = do
x = realToFrac $ 640 + ((1 - pc) + (1 - pr)) * (tileWidth / 2) x = realToFrac $ 640 + ((1 - pc) + (1 - pr)) * (tileWidth / 2)
y = realToFrac $ 360 + ((1 - pr) - (1 - pc)) * (tileHeight / 2) y = realToFrac $ 360 + ((1 - pr) - (1 - pc)) * (tileHeight / 2)
partposanims = M.fromList partposanims = M.fromList
(nrows $ mmImgMat $ stateData ud) (nrows $ mmImgMat $ sData)
(ncols $ mmImgMat $ stateData ud) (ncols $ mmImgMat $ sData)
((reverse . fst) ((reverse . fst)
(Prelude.foldl (Prelude.foldl
(\(done, proc) coord -> (\(done, proc) coord ->
@ -194,8 +199,8 @@ drawMind = do
) )
([], posanims) ([], 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)) (reverse $ zip [1..] ls))
(zip [1..] (toLists mat)) (zip [1..] (toLists mat))
fontSize ctx 20 fontSize ctx 20
fontFace ctx (assetFonts ud Map.! FontBedstead) aFonts <- readMVar (assetFonts ud)
fontFace ctx (aFonts Map.! FontBedstead)
textAlign ctx (S.fromList [AlignCenter,AlignTop]) textAlign ctx (S.fromList [AlignCenter,AlignTop])
fillColor ctx (rgb 255 128 0) fillColor ctx (rgb 255 128 0)
textBox ctx 0 0 200 ("FPS: " `T.append` T.pack (Prelude.take 5 $ show (1/dt))) textBox ctx 0 0 200 ("FPS: " `T.append` T.pack (Prelude.take 5 $ show (1/dt)))

View file

@ -11,8 +11,8 @@ import qualified SDL
import NanoVG hiding (V2(..)) import NanoVG hiding (V2(..))
import Control.Monad (when, void) import Control.Monad (when, void)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.State.Strict (evalStateT) import Control.Monad.State.Strict (evalStateT)
import Control.Monad.Trans.Resource (ResIO, runResourceT)
import Control.Concurrent.MVar import Control.Concurrent.MVar
import Control.Concurrent (forkIO) import Control.Concurrent (forkIO)
import Control.Parallel.Strategies hiding (dot) import Control.Parallel.Strategies hiding (dot)
@ -24,6 +24,8 @@ import Data.Matrix as M
import Data.Ecstasy as E import Data.Ecstasy as E
import Data.Maybe import Data.Maybe
import Data.List as L import Data.List as L
import qualified Data.Vector as V
import Data.String
import System.Random (randomRIO) import System.Random (randomRIO)
@ -42,63 +44,49 @@ import NPC
import Animation import Animation
import Collision import Collision
loadMap :: Affection UserData () loadMap :: UserData -> Affection ()
loadMap = do loadMap ud = do
ud <- getAffection
ad <- get ad <- get
let (Subsystems _ _ 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 | SDL.keysymKeycode sym == SDL.KeycodeF1 = do
ud <- getAffection curState <- liftIO $ readMVar (state ud)
case state ud of case curState of
Main MindMap -> Main MindMap ->
putAffection ud void $ liftIO $ swapMVar (state ud) (Main WorldMap)
{ state = Main WorldMap
}
Main WorldMap -> Main WorldMap ->
putAffection ud void $ liftIO $ swapMVar (state ud) (Main MindMap)
{ state = Main MindMap
}
_ -> return () _ -> return ()
| otherwise = 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 -> Main MindMap ->
putAffection ud void $ liftIO $ swapMVar (state ud) (Main WorldMap)
{ state = Main WorldMap
}
Main WorldMap -> Main WorldMap ->
putAffection ud void $ liftIO $ swapMVar (state ud) (Main MindMap)
{ state = Main MindMap
}
_ -> return () _ -> return ()
changeMaps2 _ = return () changeMaps2 _ _ = return ()
loadMapFork loadMapFork
:: UserData :: UserData
-> AffectionData UserData -> AffectionData
-> MVar (SystemState Entity (AffectionState (AffectionData UserData) IO), StateData) -> MVar (SystemState Entity (AffectionState AffectionData ResIO), StateData)
-> MVar (Float, T.Text) -> MVar (Float, T.Text)
-> IO () -> IO ()
loadMapFork ud ad future progress = do loadMapFork ud ad future progress = do
@ -107,7 +95,7 @@ loadMapFork ud ad future progress = do
fc = FloorConfig fc = FloorConfig
(V2 10 10) (V2 10 10)
[(V2 5 5), (V2 5 20)] [(V2 5 5), (V2 5 20)]
(50, 50) (40, 40)
modifyMVar_ progress (return . (\(p, _) -> modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Building floor" , "Building floor"
@ -136,13 +124,14 @@ loadMapFork ud ad future progress = do
( p + increment ( p + increment
, "Placing furniture" , "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 let !rps = ReachPoint Elevator (fcElevator fc) SE 0 : rawrps
modifyMVar_ progress (return . (\(p, _) -> modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Creating WorldState" , "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, _) -> liftIO $ modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Registering copiers into WorldState" , "Registering copiers into WorldState"
@ -158,7 +147,12 @@ loadMapFork ud ad future progress = do
, objType = Just ObjCopier , objType = Just ObjCopier
, objState = Just "idle" , 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, _) -> liftIO $ modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Registering computers into WorldState" , "Registering computers into WorldState"
@ -179,7 +173,12 @@ loadMapFork ud ad future progress = do
, objType = Just ObjComputer , objType = Just ObjComputer
, objState = Just "off" , 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, _) -> liftIO $ modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Registering toilets into WorldState" , "Registering toilets into WorldState"
@ -194,7 +193,12 @@ loadMapFork ud ad future progress = do
, objAccess = Just [(V2 0 (-1), dir)] , objAccess = Just [(V2 0 (-1), dir)]
, objType = Just ObjToilet , 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, _) -> liftIO $ modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Preparing MindMap graph" , "Preparing MindMap graph"
@ -229,7 +233,9 @@ loadMapFork ud ad future progress = do
, clearanceLvl = Just 0 , clearanceLvl = Just 0
, anim = Just $ AnimState (AnimId AnimIntruder "standing" SE) 0 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, _) -> liftIO $ modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Registering NPCs into WorldState" , "Registering NPCs into WorldState"
@ -243,10 +249,12 @@ loadMapFork ud ad future progress = do
<*> (randomRIO (0, 1)) <*> (randomRIO (0, 1))
<*> (randomRIO (0, 1)) <*> (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) ((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 void $ createEntity $ newEntity
{ pos = Just (fmap ((+ 0.5) . fromIntegral) (pointCoord cpr)) { pos = Just (fmap ((+ 0.5) . fromIntegral) (pointCoord cpr))
@ -258,7 +266,8 @@ loadMapFork ud ad future progress = do
, npcActionState = Just ASWork , npcActionState = Just ASWork
, npcStats = Just stats , npcStats = Just stats
, clearanceLvl = Just (clearance room) , 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 ) computers
liftIO $ modifyMVar_ progress (return . (\(p, _) -> liftIO $ modifyMVar_ progress (return . (\(p, _) ->
@ -266,17 +275,18 @@ loadMapFork ud ad future progress = do
, "Registering doors into WorldState" , "Registering doors into WorldState"
))) )))
mapM_ (\door -> do mapM_ (\door -> do
let rooms = Prelude.foldl let rooms = V.foldl
(\acc coord -> (\acc coord ->
let rs = Prelude.filter ((inBounds coord) . bounds) graph let rs = V.filter ((inBounds coord) . bounds) graph
in 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 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 coords = Prelude.map (door +) deltas
deltas = deltas =
[ V2 0 1 [ V2 0 1
@ -293,10 +303,11 @@ loadMapFork ud ad future progress = do
orientation orientation
| head wall == V2 0 1 || head wall == V2 0 (-1) = NW | head wall == V2 0 1 || head wall == V2 0 (-1) = NW
| head wall == V2 1 0 || head wall == V2 (-1) 0 = NE | 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 void $ createEntity $ newEntity
{ pos = Just (fmap ((+ 0.5) . fromIntegral) door) { 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 , anim = Just $ AnimState (AnimId AnimDoor0 "shut" orientation) 0 1
, obstacle = Just $ case orientation of , obstacle = Just $ case orientation of
NW -> Boundaries (4/9, 0) (5/9, 1) NW -> Boundaries (4/9, 0) (5/9, 1)
@ -330,19 +341,19 @@ loadMapFork ud ad future progress = do
then Nothing then Nothing
else a) else a)
(M.toList inter) (M.toList inter)
putMVar future (nws, MainData void $ putMVar future (nws, MainData
{ mapMat = mat { mapMat = mat
, imgMat = retMat , imgMat = retMat
, reachPoints = rps , reachPoints = V.fromList rps
, mmImgMat = mmimgmat , mmImgMat = mmimgmat
, roomGraph = gr , 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 | SDL.keysymKeycode sym == SDL.KeycodeW = do
ud <- getAffection wState <- liftIO $ readMVar (worldState ud)
(nws, _) <- yieldSystemT (worldState ud) $ (nws, _) <- yieldSystemT wState $
emap allEnts $ do emap allEnts $ do
with player with player
(V2 vx _) <- query xyvel (V2 vx _) <- query xyvel
@ -352,12 +363,10 @@ movePlayerKbd (MsgKeyboardEvent _ _ press False sym)
return $ unchanged return $ unchanged
{ xyvel = Set $ V2 vx ry { xyvel = Set $ V2 vx ry
} }
putAffection ud void $ liftIO $ swapMVar (worldState ud) nws
{ worldState = nws
}
| SDL.keysymKeycode sym == SDL.KeycodeS = do | SDL.keysymKeycode sym == SDL.KeycodeS = do
ud <- getAffection wState <- liftIO $ readMVar (worldState ud)
(nws, _) <- yieldSystemT (worldState ud) $ (nws, _) <- yieldSystemT wState $
emap allEnts $ do emap allEnts $ do
with player with player
(V2 vx _) <- query xyvel (V2 vx _) <- query xyvel
@ -367,12 +376,10 @@ movePlayerKbd (MsgKeyboardEvent _ _ press False sym)
return $ unchanged return $ unchanged
{ xyvel = Set $ V2 vx ry { xyvel = Set $ V2 vx ry
} }
putAffection ud void $ liftIO $ swapMVar (worldState ud) nws
{ worldState = nws
}
| SDL.keysymKeycode sym == SDL.KeycodeA = do | SDL.keysymKeycode sym == SDL.KeycodeA = do
ud <- getAffection wState <- liftIO $ readMVar (worldState ud)
(nws, _) <- yieldSystemT (worldState ud) $ (nws, _) <- yieldSystemT wState $
emap allEnts $ do emap allEnts $ do
with player with player
(V2 _ vy) <- query xyvel (V2 _ vy) <- query xyvel
@ -382,12 +389,10 @@ movePlayerKbd (MsgKeyboardEvent _ _ press False sym)
return $ unchanged return $ unchanged
{ xyvel = Set $ V2 rx vy { xyvel = Set $ V2 rx vy
} }
putAffection ud void $ liftIO $ swapMVar (worldState ud) nws
{ worldState = nws
}
| SDL.keysymKeycode sym == SDL.KeycodeD = do | SDL.keysymKeycode sym == SDL.KeycodeD = do
ud <- getAffection wState <- liftIO $ readMVar (worldState ud)
(nws, _) <- yieldSystemT (worldState ud) $ (nws, _) <- yieldSystemT wState $
emap allEnts $ do emap allEnts $ do
with player with player
(V2 _ vy) <- query xyvel (V2 _ vy) <- query xyvel
@ -397,16 +402,14 @@ movePlayerKbd (MsgKeyboardEvent _ _ press False sym)
return $ unchanged return $ unchanged
{ xyvel = Set $ V2 rx vy { xyvel = Set $ V2 rx vy
} }
putAffection ud void $ liftIO $ swapMVar (worldState ud) nws
{ worldState = nws
}
| otherwise = return () | 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 emap allEnts $ do
with player with player
V2 vx vy <- query xyvel V2 vx vy <- query xyvel
@ -418,14 +421,12 @@ movePlayer2 (ActionMessage mov _) = do
ActRight f -> V2 f vy ActRight f -> V2 f vy
_ -> V2 vx vy _ -> V2 vx vy
} }
putAffection ud void $ liftIO $ swapMVar (worldState ud) nws
{ worldState = nws
}
playerInteract2 :: ActionMessage -> Affection UserData () playerInteract2 :: UserData -> ActionMessage -> Affection ()
playerInteract2 (ActionMessage ActActivate _) = do playerInteract2 ud (ActionMessage ActActivate _) = do
ud <- getAffection wState <- liftIO $ readMVar (worldState ud)
(nws, _) <- yieldSystemT (worldState ud) $ do (nws, _) <- yieldSystemT wState $ do
pdata <- efor allEnts $ do pdata <- efor allEnts $ do
with player with player
with pos with pos
@ -451,27 +452,26 @@ playerInteract2 (ActionMessage ActActivate _) = do
then return $ Just (otype, ostate, ent) then return $ Just (otype, ostate, ent)
else return Nothing else return Nothing
let relEnts = catMaybes mrelEnts 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)) -- liftIO $ A.logIO A.Debug ("dV2: " ++ show (V2 dr dc))
mapM_ (\(t, s, e) -> mapM_ (\(t, s, e) ->
setEntity e =<< objectTransition t s True e (Just pent) setEntity e =<< objectTransition t s True e (Just pent)
) relEnts ) 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 let ctx = nano ud
case stateData ud of case sData of
None -> liftIO $ do None -> liftIO $ do
progress <- readMVar (stateProgress ud) progress <- readMVar (stateProgress ud)
drawLoadScreen ud progress drawLoadScreen ud progress
_ -> do _ -> do
dt <- getDelta dt <- getDelta
(_, dat) <- yieldSystemT (worldState ud) $ do (_, dat) <- yieldSystemT wState $ do
efor allEnts $ do efor allEnts $ do
with pos with pos
pos' <- query pos pos' <- query pos
@ -512,10 +512,10 @@ drawMap = do
([], [], []) ([], [], [])
dat dat
V2 pr pc = playerPos 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) cols = fromIntegral (ncols mat)
rows = fromIntegral (nrows mat) rows = fromIntegral (nrows mat)
tileWidth = 64 :: Double tileWidth = 64 :: Double
@ -523,8 +523,8 @@ drawMap = do
x = realToFrac $ 640 + ((1 - pc) + (1 - pr)) * (tileWidth / 2) x = realToFrac $ 640 + ((1 - pc) + (1 - pr)) * (tileWidth / 2)
y = realToFrac $ 360 + ((1 - pr) - (1 - pc)) * (tileHeight / 2) y = realToFrac $ 360 + ((1 - pr) - (1 - pc)) * (tileHeight / 2)
partposanims = M.fromList partposanims = M.fromList
(nrows $ mapMat $ stateData ud) (nrows $ mapMat sData)
(ncols $ mapMat $ stateData ud) (ncols $ mapMat sData)
((reverse . fst) ((reverse . fst)
(Prelude.foldl (Prelude.foldl
(\(done, proc) coord -> (\(done, proc) coord ->
@ -533,8 +533,8 @@ drawMap = do
) )
([], posanims) ([], posanims)
((,) ((,)
<$> [1 .. (nrows $ mapMat $ stateData ud)] <$> [1 .. (nrows $ mapMat sData)]
<*> [1 .. (ncols $ mapMat $ stateData ud)] <*> [1 .. (ncols $ mapMat sData)]
) )
) )
) )
@ -612,15 +612,20 @@ drawMap = do
closePath ctx closePath ctx
) posActions ) posActions
fontSize ctx 20 fontSize ctx 20
fontFace ctx (assetFonts ud Map.! FontBedstead) aFonts <- readMVar (assetFonts ud)
fontFace ctx (aFonts Map.! FontBedstead)
textAlign ctx (S.fromList [AlignCenter,AlignTop]) textAlign ctx (S.fromList [AlignCenter,AlignTop])
fillColor ctx (rgb 255 128 0) fillColor ctx (rgb 255 128 0)
textBox ctx 0 0 200 ( textBox ctx 0 0 200 (
"FPS: " "FPS: "
<> T.pack (Prelude.take 5 $ show (1/dt)) <> T.pack (Prelude.take 5 $ show (1/dt))
<> " Clearance: " <> " 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 drawTile
:: UserData :: UserData
@ -632,23 +637,23 @@ drawTile
-> Int -> Int
-> Maybe ImgId -> Maybe ImgId
-> IO () -> IO ()
drawTile ud ctx posanims pr pc row col img = drawTile ud ctx posanims pr pc row col img = do
do let (bef, beh) = L.partition delimiter sorted
let (bef, beh) = L.partition delimiter sorted aImages <- readMVar (assetImages ud)
save ctx save ctx
mapM_ (flip drawAnim fact) beh mapM_ (flip drawAnim fact) beh
maybe (return ()) (draw ud x (y - 42) 64 74 maybe (return ()) (Types.draw ud x (y - 42) 64 74
(if fromMaybe False (isWall <$> img) then fact else 1)) (if fromMaybe False (isWall <$> img) then fact else 1))
((assetImages ud Map.!) <$> case img of ((aImages Map.!) <$> case img of
Just ImgEmpty -> Nothing Just ImgEmpty -> Nothing
_ -> img _ -> img
) )
mapM_ (flip drawAnim fact) bef mapM_ (flip drawAnim fact) bef
restore ctx restore ctx
-- when (floor pr == row && floor pc == col) $ do -- when (floor pr == row && floor pc == col) $ do
-- A.logIO A.Debug ("sorted: " ++ show sorted) -- A.logIO A.Debug ("sorted: " ++ show sorted)
-- A.logIO A.Debug ("beh: " ++ show beh) -- A.logIO A.Debug ("beh: " ++ show beh)
-- A.logIO A.Debug ("bef: " ++ show bef) -- A.logIO A.Debug ("bef: " ++ show bef)
where where
delimiter (V2 nr nc, as, mbnds) = delimiter (V2 nr nc, as, mbnds) =
animFloats (asId as) || animFloats (asId as) ||
@ -702,29 +707,30 @@ drawTile ud ctx posanims pr pc row col img =
drawAnim (V2 nr nc, as, _) factor = do drawAnim (V2 nr nc, as, _) factor = do
let ax = realToFrac $ 640 + ((nc - pc) + (nr - pr)) * 32 - 32 let ax = realToFrac $ 640 + ((nc - pc) + (nr - pr)) * 32 - 32
ay = realToFrac $ 360 + ((nr - pr) - (nc - pc)) * 16 - 58 ay = realToFrac $ 360 + ((nr - pr) - (nc - pc)) * 16 - 58
draw ud ax ay 64 74 (if isWallLike (aiVariation $ asId as) then factor else 1) as Types.draw ud ax ay 64 74 (if isWallLike (aiVariation $ asId as) then factor else 1) as
updateMap :: Double -> Affection UserData () updateMap :: UserData -> Double -> Affection ()
updateMap dt = do updateMap ud dt = do
ud <- getAffection osData <- liftIO $ readMVar (stateData ud)
if stateData ud == None if osData == None
then do then do
mstart <- liftIO $ tryTakeMVar (stateMVar ud) mstart <- liftIO $ tryTakeMVar (stateMVar ud)
case mstart of case mstart of
Just (nws, mendat) -> do 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" liftIO $ logIO A.Debug "Loaded game data"
Nothing -> return () Nothing -> return ()
else do 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 obstacleBounds <- efor allEnts $ do
with obstacle with obstacle
with pos with pos
@ -738,7 +744,8 @@ updateMap dt = do
fact' <- fromMaybe 1 <$> queryMaybe velFact fact' <- fromMaybe 1 <$> queryMaybe velFact
xyv2 <- queryMaybe xyvel xyv2 <- queryMaybe xyvel
stat <- query anim stat <- query anim
let an = assetAnimations ud Map.! asId stat let an = aAnim Map.! asId stat
mat = mapMat sData
ntime = asElapsedTime stat + dt ntime = asElapsedTime stat + dt
npos = pos' + fmap (* (dt * fact')) (fromMaybe (V2 0 0) vel') npos = pos' + fmap (* (dt * fact')) (fromMaybe (V2 0 0) vel')
dpos@(V2 dpr dpc) = npos - pos' dpos@(V2 dpr dpc) = npos - pos'
@ -755,16 +762,16 @@ updateMap dt = do
colldpos = dpos * Prelude.foldl colldpos = dpos * Prelude.foldl
(\acc a -> (\acc a ->
let ret = checkBoundsCollision2 pos' npos dt 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) (V2 1 1)
( (
concatMap nub $ concatMap
(\(dr, dc) -> (\(dr, dc) ->
let bs = (++) 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 (Prelude.map snd $ Prelude.filter
(\((V2 br bc), _) -> (\((V2 br bc), _) ->
floor pr + dr == floor br && floor pr + dr == floor br &&
@ -874,14 +881,12 @@ updateMap dt = do
objectAction dt t s e objectAction dt t s e
) tses ) tses
(nws2, _) <- yieldSystemT nws $ updateNPCs (nws2, _) <- yieldSystemT nws $ updateNPCs
(imgMat $ stateData ud) (imgMat sData)
(mapMat $ stateData ud) (mapMat sData)
nws nws
(Prelude.filter (V.filter
(\p -> pointType p /= RoomExit) (\p -> pointType p /= RoomExit)
(reachPoints $ stateData ud) (reachPoints sData)
) )
dt dt
putAffection ud void $ liftIO $ swapMVar (worldState ud) nws2
{ worldState = nws2
}

View file

@ -10,91 +10,74 @@ import qualified Data.Map.Strict as M
import qualified Data.Set as S import qualified Data.Set as S
import Data.List (find) import Data.List (find)
import Data.Maybe (fromJust, isJust) import Data.Maybe (fromJust, isJust)
import Data.String (fromString)
import Control.Monad
import Control.Concurrent.MVar
-- internal imports -- internal imports
import Types import Types
import Util 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 () _ -> 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 liftIO $ do
let ctx = nano ud
save ctx save ctx
beginPath ctx beginPath ctx
roundedRect ctx 440 310 400 100 10 roundedRect ctx 440 310 400 100 10

View file

@ -10,7 +10,9 @@ import Linear hiding (rotate, translation)
import qualified Data.Set as S import qualified Data.Set as S
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
import Data.Maybe (isNothing, isJust) import Data.String
import Control.Concurrent.MVar
import Control.Monad import Control.Monad
@ -21,108 +23,94 @@ import Util
import Menu.Adjust import Menu.Adjust
import MainGame.WorldMap 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 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 -- 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 mjoy <- joystickAutoConnect msg
maybe (return ()) (\joy -> do maybe (return ()) (\joy -> do
ident <- liftIO $ fromIntegral <$> SDL.getJoystickID joy 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 ) 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 Joystick joy -> do
njoys <- joystickAutoDisconnect [joy] msg njoys <- joystickAutoDisconnect [joy] msg
when (null njoys) $ do when (null njoys) $ do
liftIO $ logIO A.Debug $ "Joystick disconnected" 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 () _ -> 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)) { 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) { 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) { 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) { 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 Joystick _ -> do
when (arrowUp rels) adjustKbdUp when (arrowUp rels) adjustKbdUp
when (arrowDown rels) adjustKbdDown when (arrowDown rels) adjustKbdDown
@ -132,40 +120,36 @@ handleClicks (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft 1 pos@(V2 px py))
when (buttonSwitchMap rels) adjustKbdSwitchMap when (buttonSwitchMap rels) adjustKbdSwitchMap
when (buttonPlay rels) enterGame when (buttonPlay rels) enterGame
NoController -> do 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 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 when (buttonPlay rels) enterGame
where where
adjustKbdUp = do adjustKbdUp = do
fullClean fullClean ud
loadAdjust (ActUp 1) Keyboard loadMenu loadAdjust ud (ActUp 1) Keyboard (loadMenu ud)
adjustKbdDown = do adjustKbdDown = do
fullClean fullClean ud
loadAdjust (ActDown 1) Keyboard loadMenu loadAdjust ud (ActDown 1) Keyboard (loadMenu ud)
adjustKbdLeft = do adjustKbdLeft = do
fullClean fullClean ud
loadAdjust (ActLeft 1) Keyboard loadMenu loadAdjust ud (ActLeft 1) Keyboard (loadMenu ud)
adjustKbdRight = do adjustKbdRight = do
fullClean fullClean ud
loadAdjust (ActRight 1) Keyboard loadMenu loadAdjust ud (ActRight 1) Keyboard (loadMenu ud)
adjustKbdActivate = do adjustKbdActivate = do
fullClean fullClean ud
loadAdjust ActActivate Keyboard loadMenu loadAdjust ud ActActivate Keyboard (loadMenu ud)
adjustKbdSwitchMap = do adjustKbdSwitchMap = do
fullClean fullClean ud
loadAdjust ActSwitchMap Keyboard loadMenu loadAdjust ud ActSwitchMap Keyboard (loadMenu ud)
enterGame = do enterGame = do
fullClean fullClean ud
loadMap loadMap ud
arrowUp (V2 rx ry) = arrowUp (V2 rx ry) =
rx > 310 / 1280 && rx < 410 / 1280 && ry > 190 / 720 && ry < 290 / 720 rx > 310 / 1280 && rx < 410 / 1280 && ry > 190 / 720 && ry < 290 / 720
arrowDown (V2 rx ry) = 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 rx > 650 / 1280 && rx < 800 / 1280 && ry > 560 / 720 && ry < 610 / 720
kbdIcon (V2 rx ry) = kbdIcon (V2 rx ry) =
rx > 650 / 1280 && rx < 730 / 1280 && ry > 620 / 720 && ry < 700 / 720 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 _ _ _ _ -> 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 () _ -> 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 _ _ _ _ -> MenuData _ _ _ _ ->
liftIO $ do liftIO $ do
let ctx = nano ud let ctx = nano ud
controller = controls ud controller <- readMVar (controls ud)
save ctx save ctx
beginPath 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 case controller of
Joystick _ -> IconContrGreen Joystick _ -> IconContrGreen
_ -> IconContrBlue _ -> IconContrBlue
@ -218,17 +204,17 @@ drawMenu = do
closePath ctx closePath ctx
fill ctx fill ctx
beginPath 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 case controller of
Keyboard -> IconKbdGreen Keyboard -> IconKbdGreen
_ -> IconKbdBlue _ -> IconKbdBlue
) 1 ) 1
rect ctx 650 620 80 80 rect ctx 650 620 80 80
fillPaint ctx cpaint fillPaint ctx cpaint2
closePath ctx closePath ctx
fill ctx fill ctx
when (controller /= NoController) $ do when (controller /= NoController) $ do
let V2 vx vy = velocity $ stateData ud let V2 vx vy = velocity sData
beginPath ctx beginPath ctx
roundedRect ctx 140 110 1000 500 25 roundedRect ctx 140 110 1000 500 25
strokeWidth ctx 5 strokeWidth ctx 5
@ -239,7 +225,7 @@ drawMenu = do
mapM_ (\deg -> do mapM_ (\deg -> do
let V2 px py = fmap realToFrac $ let V2 px py = fmap realToFrac $
V2 360 360 - V2 50 50 + fmap realToFrac rot 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 V2 0 120 `rotVec` deg :: V2 Int
save ctx save ctx
translate ctx (px + 50) (py + 50) translate ctx (px + 50) (py + 50)
@ -253,7 +239,7 @@ drawMenu = do
roundedRect ctx 0 0 100 100 10 roundedRect ctx 0 0 100 100 10
closePath ctx closePath ctx
fill ctx fill ctx
case state ud of case curState of
Menu (Adjust (ActUp _) _) -> do Menu (Adjust (ActUp _) _) -> do
beginPath ctx beginPath ctx
fillColor ctx (rgb 0 255 0) fillColor ctx (rgb 0 255 0)
@ -275,7 +261,7 @@ drawMenu = do
roundedRect ctx 0 0 100 100 10 roundedRect ctx 0 0 100 100 10
closePath ctx closePath ctx
fill ctx fill ctx
case state ud of case curState of
Menu (Adjust (ActLeft _) _) -> do Menu (Adjust (ActLeft _) _) -> do
beginPath ctx beginPath ctx
fillColor ctx (rgb 0 255 0) fillColor ctx (rgb 0 255 0)
@ -297,7 +283,7 @@ drawMenu = do
roundedRect ctx 0 0 100 100 10 roundedRect ctx 0 0 100 100 10
closePath ctx closePath ctx
fill ctx fill ctx
case state ud of case curState of
Menu (Adjust (ActUp _) _) -> do Menu (Adjust (ActUp _) _) -> do
beginPath ctx beginPath ctx
fillColor ctx (rgb 0 255 0) fillColor ctx (rgb 0 255 0)
@ -319,7 +305,7 @@ drawMenu = do
roundedRect ctx 0 0 100 100 10 roundedRect ctx 0 0 100 100 10
closePath ctx closePath ctx
fill ctx fill ctx
case state ud of case curState of
Menu (Adjust (ActLeft _) _) -> do Menu (Adjust (ActLeft _) _) -> do
beginPath ctx beginPath ctx
fillColor ctx (rgb 0 255 0) fillColor ctx (rgb 0 255 0)
@ -335,20 +321,20 @@ drawMenu = do
_ -> _ ->
return () return ()
beginPath ctx 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 rect ctx 0 0 100 100
fillPaint ctx apaint fillPaint ctx apaint
closePath ctx closePath ctx
fill ctx fill ctx
restore ctx restore ctx
) [0, 90, 180, 270] ) [0, 90, 180, 270]
when (activate (stateData ud) > 0) $ do when (activate sData > 0) $ do
beginPath ctx beginPath ctx
fillColor ctx (rgb 255 128 0) fillColor ctx (rgb 255 128 0)
roundedRect ctx 650 160 150 50 10 roundedRect ctx 650 160 150 50 10
fill ctx fill ctx
closePath ctx closePath ctx
case state ud of case curState of
Menu (Adjust ActActivate _) -> do Menu (Adjust ActActivate _) -> do
beginPath ctx beginPath ctx
fillColor ctx (rgb 0 255 0) fillColor ctx (rgb 0 255 0)
@ -367,13 +353,13 @@ drawMenu = do
fillColor ctx (rgb 255 255 255) fillColor ctx (rgb 255 255 255)
textBox ctx 650 175 150 "Activate" textBox ctx 650 175 150 "Activate"
closePath ctx closePath ctx
when (switchMap (stateData ud) > 0) $ do when (switchMap sData > 0) $ do
beginPath ctx beginPath ctx
fillColor ctx (rgb 255 128 0) fillColor ctx (rgb 255 128 0)
roundedRect ctx 650 220 150 50 10 roundedRect ctx 650 220 150 50 10
fill ctx fill ctx
closePath ctx closePath ctx
case state ud of case curState of
Menu (Adjust ActSwitchMap _) -> do Menu (Adjust ActSwitchMap _) -> do
beginPath ctx beginPath ctx
fillColor ctx (rgb 0 255 0) fillColor ctx (rgb 0 255 0)

View file

@ -1,5 +1,6 @@
{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
module NPC where module NPC where
import Affection as A import Affection as A
@ -9,9 +10,12 @@ import Data.Ecstasy as E
import Data.Maybe import Data.Maybe
import Data.List (find) import Data.List (find)
import Data.List.Split (splitWhen) import Data.List.Split (splitWhen)
import qualified Data.Vector as V
import Data.String
import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Trans (lift) import Control.Monad.Trans (lift)
import Control.Monad.Trans.Resource (ResIO)
import Control.Concurrent.MVar import Control.Concurrent.MVar
import Control.Concurrent (forkIO) import Control.Concurrent (forkIO)
@ -30,7 +34,7 @@ import Object ()
getPosBounds getPosBounds
:: SystemT :: SystemT
Entity Entity
(AffectionState (AffectionData UserData) IO) (AffectionState AffectionData ResIO)
[(V2 Double, Boundaries Double)] [(V2 Double, Boundaries Double)]
getPosBounds = do getPosBounds = do
efor allEnts $ do efor allEnts $ do
@ -44,10 +48,10 @@ getPosBounds = do
updateNPCs updateNPCs
:: M.Matrix (Maybe ImgId) :: M.Matrix (Maybe ImgId)
-> M.Matrix TileState -> M.Matrix TileState
-> SystemState Entity (AffectionState (AffectionData UserData) IO) -> SystemState Entity (AffectionState AffectionData ResIO)
-> [ReachPoint] -> V.Vector ReachPoint
-> Double -> Double
-> SystemT Entity (AffectionState (AffectionData UserData) IO) () -> SystemT Entity (AffectionState AffectionData ResIO) ()
updateNPCs imgmat tsmat ws rrp dt = do updateNPCs imgmat tsmat ws rrp dt = do
updateStats dt updateStats dt
posbounds <- getPosBounds posbounds <- getPosBounds
@ -66,7 +70,7 @@ updateNPCs imgmat tsmat ws rrp dt = do
lvl <- query clearanceLvl lvl <- query clearanceLvl
stat <- query anim stat <- query anim
npcState' <- query npcMoveState npcState' <- query npcMoveState
let rp = filter ((lvl >=) . pointClearance) rrp let rp = V.filter ((lvl >=) . pointClearance) rrp
case npcState' of case npcState' of
NPCStanding ttl future -> do NPCStanding ttl future -> do
let nttl = ttl - dt let nttl = ttl - dt
@ -111,7 +115,9 @@ updateNPCs imgmat tsmat ws rrp dt = do
then standStill imgmat tsmat pos' rot' ws posbounds rp then standStill imgmat tsmat pos' rot' ws posbounds rp
else do else do
(_, accessibles) <- lift $ yieldSystemT ws (getObject pos') (_, accessibles) <- lift $ yieldSystemT ws (getObject pos')
liftIO $ logIO A.Verbose ("accessibles: " ++ show accessibles) liftIO $ logIO
A.Verbose
("accessibles: " <> fromString (show accessibles))
case accessibles of case accessibles of
[] -> error ("unknown reason to stop at " ++ show pos') [] -> error ("unknown reason to stop at " ++ show pos')
objects -> do objects -> do
@ -119,7 +125,7 @@ updateNPCs imgmat tsmat ws rrp dt = do
npcent <- queryEnt npcent <- queryEnt
let (oent, _, _) = objects !! rind let (oent, _, _) = objects !! rind
mdir = mdir =
pointDir <$> find (\a -> pointCoord a == fmap floor pos') rp pointDir <$> V.find (\a -> pointCoord a == fmap floor pos') rp
return (Just (oent, npcent, Nothing), unchanged return (Just (oent, npcent, Nothing), unchanged
{ rot = Set $ fromMaybe rot' mdir { rot = Set $ fromMaybe rot' mdir
, anim = Set stat , anim = Set stat
@ -194,7 +200,7 @@ standStill
-> Direction -> Direction
-> SystemState Entity m -> SystemState Entity m
-> [(V2 Double, Boundaries Double)] -> [(V2 Double, Boundaries Double)]
-> [ReachPoint] -> V.Vector ReachPoint
-> QueryT Entity m (Maybe (Ent, Ent, Maybe (MVar [[V2 Int]])), Entity 'SetterOf) -> QueryT Entity m (Maybe (Ent, Ent, Maybe (MVar [[V2 Int]])), Entity 'SetterOf)
standStill imgmat tsmat pos' rot' ws posbounds rp = do standStill imgmat tsmat pos' rot' ws posbounds rp = do
future <- liftIO $ newEmptyMVar future <- liftIO $ newEmptyMVar
@ -202,33 +208,33 @@ standStill imgmat tsmat pos' rot' ws posbounds rp = do
as <- query npcActionState as <- query npcActionState
targetRPs <- case as of targetRPs <- case as of
ASWork -> ASWork ->
let fltrd = filter (\p -> pointType p == Copier) rp let fltrd = V.filter (\p -> pointType p == Copier) rp
in in
((fltrd ++) . replicate (5 * length fltrd)) <$> (V.foldl V.snoc fltrd . V.replicate (5 * V.length fltrd)) <$>
query npcWorkplace query npcWorkplace
ASToilet -> do ASToilet -> do
let seekRP = filter (\p -> pointType p == Toilet) rp let seekRP = V.filter (\p -> pointType p == Toilet) rp
if null seekRP if V.null seekRP
then return $ filter (\p -> pointType p == Elevator) rp then return $ V.filter (\p -> pointType p == Elevator) rp
else return seekRP else return seekRP
ASDrink -> do ASDrink -> do
let seekRP = filter (\p -> pointType p == Drink) rp let seekRP = V.filter (\p -> pointType p == Drink) rp
if null seekRP if V.null seekRP
then return $ filter (\p -> pointType p == Elevator) rp then return $ V.filter (\p -> pointType p == Elevator) rp
else return seekRP else return seekRP
ASEat -> do ASEat -> do
let seekRP = filter (\p -> pointType p == Eat) rp let seekRP = V.filter (\p -> pointType p == Eat) rp
if null seekRP if V.null seekRP
then return $ filter (\p -> pointType p == Elevator) rp then return $ V.filter (\p -> pointType p == Elevator) rp
else return seekRP else return seekRP
ASRandWalk -> ASRandWalk ->
return $ filter (\p -> pointType p /= RoomExit) rp return $ V.filter (\p -> pointType p /= RoomExit) rp
_ <- liftIO $ forkIO $ _ <- liftIO $ forkIO $
getPath (fmap floor pos') future targetRPs imgmat tsmat posbounds getPath (fmap floor pos') future targetRPs imgmat tsmat posbounds
let mdir = let mdir =
pointDir <$> find (\a -> pointCoord a == fmap floor pos') rp pointDir <$> find (\a -> pointCoord a == fmap floor pos') rp
(_, accessibles) <- lift $ yieldSystemT ws (getObject pos') (_, accessibles) <- lift $ yieldSystemT ws (getObject pos')
liftIO $ logIO A.Verbose ("accessibles: " ++ show accessibles) liftIO $ logIO A.Verbose ("accessibles: " <> fromString (show accessibles))
case accessibles of case accessibles of
[] -> do [] -> do
ttl <- liftIO $ randomRIO (5, 30) ttl <- liftIO $ randomRIO (5, 30)
@ -258,7 +264,7 @@ standStill imgmat tsmat pos' rot' ws posbounds rp = do
updateStats updateStats
:: Double :: Double
-> SystemT Entity (AffectionState (AffectionData UserData) IO) () -> SystemT Entity (AffectionState AffectionData ResIO) ()
updateStats dt = updateStats dt =
emap allEnts $ do emap allEnts $ do
with npcStats with npcStats
@ -309,7 +315,7 @@ getObject npos = do
oacc <- query objAccess oacc <- query objAccess
ent <- queryEnt ent <- queryEnt
return (ent, pos', oacc) return (ent, pos', oacc)
liftIO $ logIO A.Verbose ("candidates: " ++ show candidates) liftIO $ logIO A.Verbose ("candidates: " <> fromString (show candidates))
return $ return $
filter (\(_, p, deltaors) -> filter (\(_, p, deltaors) ->
any (\(delta, _) -> fmap floor p + delta == fmap floor npos) deltaors any (\(delta, _) -> fmap floor p + delta == fmap floor npos) deltaors
@ -318,20 +324,32 @@ getObject npos = do
getPath getPath
:: V2 Int :: V2 Int
-> MVar [[V2 Int]] -> MVar [[V2 Int]]
-> [ReachPoint] -> V.Vector ReachPoint
-> M.Matrix (Maybe ImgId) -> M.Matrix (Maybe ImgId)
-> M.Matrix TileState -> M.Matrix TileState
-> [(V2 Double, Boundaries Double)] -> [(V2 Double, Boundaries Double)]
-> IO () -> IO ()
getPath pos' mvar rp imgmat tsmat 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' 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 case path of
Nothing -> do 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 [] putMVar mvar []
-- getPath pos' mvar rp imgmat posbounds -- getPath pos' mvar rp imgmat posbounds
Just p -> putMVar mvar (chewPath tsmat p) Just p -> putMVar mvar (chewPath tsmat p)
@ -346,10 +364,22 @@ getPathTo
-> IO () -> IO ()
getPathTo pos' mvar target imgmat tsmat posbounds = do getPathTo pos' mvar target imgmat tsmat posbounds = do
let path = astarAppl imgmat posbounds target pos' 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 case path of
Nothing -> do Nothing -> do
logIO A.Error ("No path from " ++ show pos' ++ " to " ++ show target) logIO
A.Error
("No path from " <>
fromString (show pos') <>
" to " <>
fromString (show target)
)
Just p -> putMVar mvar (chewPath tsmat p) Just p -> putMVar mvar (chewPath tsmat p)
simplifyPath :: [V2 Int] -> V2 Int -> [V2 Int] simplifyPath :: [V2 Int] -> V2 Int -> [V2 Int]

View file

@ -3,7 +3,7 @@ module Navigation where
import Affection as A import Affection as A
import Data.Matrix as M import Data.Matrix as M
import Data.Maybe (isJust, catMaybes) import Data.Maybe (isJust)
-- internal imports -- internal imports

View file

@ -3,14 +3,7 @@
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
module Object where module Object where
import Affection as A
import Control.Monad (when)
import Data.Ecstasy import Data.Ecstasy
import Data.Maybe
import Linear
-- internal imports -- internal imports

View file

@ -5,6 +5,8 @@ module Object.ActionTime where
import Affection as A import Affection as A
import Data.String
-- internal imports -- internal imports
import Types import Types
@ -14,7 +16,9 @@ instance ActionTime ObjType ObjState where
actionTime ObjComputer "off" = 0 actionTime ObjComputer "off" = 0
actionTime ObjComputer "on" = 20 actionTime ObjComputer "on" = 20
actionTime ObjComputer "hack" = 20 actionTime ObjComputer "hack" = 20
actionTime ObjComputer "hack" = 20
actionTime ObjDoor "open" = 2 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

View file

@ -6,11 +6,11 @@ module Object.Computer where
import Affection as A import Affection as A
import Control.Monad (when)
import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.IO.Class (MonadIO(..))
import Data.Ecstasy import Data.Ecstasy
import Data.Maybe import Data.Maybe
import Data.String
import Linear import Linear
@ -18,7 +18,7 @@ import Linear
import Types import Types
import Object.ActionTime import Object.ActionTime ()
computerObjectAction computerObjectAction
:: (Monad m, MonadIO m) :: (Monad m, MonadIO m)
@ -39,7 +39,7 @@ computerObjectAction dt t@ObjComputer s@"on" ent = do
mtime <- queryMaybe objStateTime mtime <- queryMaybe objStateTime
case mtime of case mtime of
Nothing -> do Nothing -> do
liftIO $ logIO Verbose ("Computer " ++ show ent ++ ": on!") liftIO $ logIO Verbose ("Computer " <> fromString (show ent) <> ": on!")
let dur = actionTime t s let dur = actionTime t s
return unchanged return unchanged
{ objStateTime = Set dur { objStateTime = Set dur
@ -77,7 +77,9 @@ computerObjectAction dt t@ObjComputer s@"hack" ent = do
mtime <- queryMaybe objStateTime mtime <- queryMaybe objStateTime
case mtime of case mtime of
Nothing -> do Nothing -> do
liftIO $ logIO Verbose ("Computer " ++ show ent ++ ": hacking!") liftIO $ logIO
Verbose
("Computer " <> fromString (show ent) <> ": hacking!")
return unchanged return unchanged
{ objStateTime = Set (actionTime t s) { objStateTime = Set (actionTime t s)
} }

View file

@ -10,11 +10,8 @@ import Control.Monad (when)
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Data.Ecstasy import Data.Ecstasy
import Data.Maybe
import Data.String (IsString(..)) import Data.String (IsString(..))
import Linear
import Types import Types
copierObjectAction copierObjectAction
@ -29,7 +26,8 @@ copierObjectAction dt t@ObjCopier s@"copying" ent = do
mtime <- queryMaybe objStateTime mtime <- queryMaybe objStateTime
case mtime of case mtime of
Nothing -> do Nothing -> do
liftIO $ logIO Verbose ("Copier " ++ show ent ++ ": copying!") liftIO $ logIO Verbose
("Copier " <> fromString (show ent) <> ": copying!")
return unchanged return unchanged
{ objStateTime = Set (actionTime t s) { objStateTime = Set (actionTime t s)
, objState = Set "copying" , objState = Set "copying"

View file

@ -7,18 +7,24 @@ module Object.Door where
import Affection as A import Affection as A
import Control.Monad (when) import Control.Monad (when)
import Control.Monad.IO.Class (MonadIO)
import Data.Ecstasy import Data.Ecstasy
import Data.Maybe import Data.Maybe
import Data.String
import Linear
-- internal imports -- internal imports
import Types import Types
import Object.ActionTime import Object.ActionTime ()
doorObjectAction :: (Eq a, IsString a, MonadIO m)
=> Double
-> ObjType
-> a
-> Ent
-> SystemT Entity m ()
doorObjectAction dt t@ObjDoor s@"open" ent = do doorObjectAction dt t@ObjDoor s@"open" ent = do
emap (anEnt ent) $ do emap (anEnt ent) $ do
mtime <- queryMaybe objStateTime mtime <- queryMaybe objStateTime
@ -38,17 +44,31 @@ doorObjectAction dt t@ObjDoor s@"open" ent = do
doorObjectAction _ _ _ _ = return () doorObjectAction _ _ _ _ = return ()
doorObjectTransition t@ObjDoor s _ ent (Just aent) = do doorObjectTransition :: (MonadIO m, Eq a, IsString a)
clearance <- head <$> efor (anEnt aent) (query clearanceLvl) => ObjType
-> a
-> 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 e <- efor (anEnt ent) $ do
dir <- query rot dir <- query rot
oclear <- query clearanceLvl oclear <- query clearanceLvl
mttl <- queryMaybe objStateTime mttl <- queryMaybe objStateTime
liftIO $ A.logIO A.Verbose (show aent ++ " is attempting to open door " ++ show ent) liftIO $ A.logIO
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) -- liftIO $ A.logIO A.Debug ("door clearance: " ++ show oclear ++ ", entity clearance: " ++ show clearance)
if clearance >= oclear if curClearance >= oclear
then do then do
liftIO $ A.logIO A.Verbose ("door " ++ show ent ++ " opens") liftIO $ A.logIO
A.Verbose
("door " <> fromString (show ent) <> " opens")
let nstat = AnimState let nstat = AnimState
(AnimId AnimDoor0 "open" dir) (AnimId AnimDoor0 "open" dir)
0 0

View file

@ -13,26 +13,26 @@ import MainGame.WorldMap
import MainGame.MindMap import MainGame.MindMap
import Util import Util
instance StateMachine State UserData where instance StateMachine UserData State where
smLoad Load = loadLoad smLoad Load = loadLoad
smLoad (Menu Connect) = loadMenu smLoad (Menu Connect) = loadMenu
smLoad (Menu (Adjust a c)) = loadAdjust a c loadMenu smLoad (Menu (Adjust a c)) = (\ud -> loadAdjust ud a c (loadMenu ud))
smLoad (Main _) = loadMap smLoad (Main _) = loadMap
smUpdate Load = updateLoad smUpdate Load = updateLoad
smUpdate (Menu Connect) = updateMenu smUpdate (Menu Connect) = updateMenu
smUpdate (Menu (Adjust _ _)) = const (return ()) smUpdate (Menu (Adjust _ _)) = const $ const (return ())
smUpdate (Main WorldMap) = updateMap smUpdate (Main WorldMap) = updateMap
smUpdate (Main MindMap) = updateMind smUpdate (Main MindMap) = updateMind
smDraw Load = drawLoad smDraw Load = drawLoad
smDraw (Menu Connect) = drawMenu smDraw (Menu Connect) = drawMenu
smDraw (Menu (Adjust _ _)) = drawMenu >> drawAdjust smDraw (Menu (Adjust _ _)) = (\ud -> drawMenu ud >> drawAdjust (nano ud))
smDraw (Main WorldMap) = drawMap smDraw (Main WorldMap) = drawMap
smDraw (Main MindMap) = drawMind 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 j =<<
consumeSDLEvents k =<< consumeSDLEvents k =<<
consumeSDLEvents w =<< consumeSDLEvents w =<<

View file

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

View file

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

View file

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

View file

@ -5,11 +5,10 @@ module Types.ObjClass where
import Affection import Affection
import Control.Monad.Trans.Resource (ResIO)
import Data.Ecstasy import Data.Ecstasy
import Types.Entity import Types.Entity
import Types.UserData
import Types.Direction
class ObjectAction otype ostate where class ObjectAction otype ostate where
objectAction objectAction
@ -17,7 +16,7 @@ class ObjectAction otype ostate where
-> otype -> otype
-> ostate -> ostate
-> Ent -> Ent
-> SystemT Entity (AffectionState (AffectionData UserData) IO) () -> SystemT Entity (AffectionState AffectionData ResIO) ()
objectTransition objectTransition
:: otype :: otype
@ -25,7 +24,7 @@ class ObjectAction otype ostate where
-> Bool -> Bool
-> Ent -> Ent
-> Maybe Ent -> Maybe Ent
-> SystemT Entity (AffectionState (AffectionData UserData) IO) (Entity 'SetterOf) -> SystemT Entity (AffectionState AffectionData ResIO) (Entity 'SetterOf)
class ActionTime otype ostate where class ActionTime otype ostate where
actionTime :: otype -> ostate -> Double actionTime :: otype -> ostate -> Double

View file

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

View file

@ -16,6 +16,7 @@ import qualified Data.Text as T
import Data.Ecstasy import Data.Ecstasy
import Control.Concurrent.MVar import Control.Concurrent.MVar
import Control.Monad.Trans.Resource
import Types.StateData import Types.StateData
import Types.ImgId import Types.ImgId
@ -24,27 +25,28 @@ import Types.Animation
import Types.Entity import Types.Entity
data UserData = UserData data UserData = UserData
{ state :: State { state :: MVar State
, subsystems :: Subsystems , 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 , 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 , stateMVar :: MVar
( SystemState Entity (AffectionState (AffectionData UserData) IO) ( SystemState Entity (AffectionState AffectionData ResIO)
, StateData , StateData
) )
, stateProgress :: MVar (Float, T.Text) , 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 data Controller
@ -133,14 +135,14 @@ data ActionMessage = ActionMessage
instance Message ActionMessage where instance Message ActionMessage where
msgTime (ActionMessage _ t) = t 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 partSubscribers (SubWindow t) = generalSubscribers t
@ -148,11 +150,11 @@ instance Participant SubWindow UserData where
partUnSubscribe (SubWindow t) = generalUnSubscribe t partUnSubscribe (SubWindow t) = generalUnSubscribe t
instance SDLSubsystem SubWindow UserData where instance SDLSubsystem SubWindow where
consumeSDLEvents = consumeSDLWindowEvents 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 partSubscribers (SubMouse t) = generalSubscribers t
@ -160,11 +162,11 @@ instance Participant SubMouse UserData where
partUnSubscribe (SubMouse t) = generalUnSubscribe t partUnSubscribe (SubMouse t) = generalUnSubscribe t
instance SDLSubsystem SubMouse UserData where instance SDLSubsystem SubMouse where
consumeSDLEvents = consumeSDLMouseEvents 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 partSubscribers (SubKeyboard t) = generalSubscribers t
@ -172,11 +174,11 @@ instance Participant SubKeyboard UserData where
partUnSubscribe (SubKeyboard t) = generalUnSubscribe t partUnSubscribe (SubKeyboard t) = generalUnSubscribe t
instance SDLSubsystem SubKeyboard UserData where instance SDLSubsystem SubKeyboard where
consumeSDLEvents = consumeSDLKeyboardEvents 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 partSubscribers (SubJoypad t) = generalSubscribers t
@ -184,11 +186,11 @@ instance Participant SubJoypad UserData where
partUnSubscribe (SubJoypad t) = generalUnSubscribe t partUnSubscribe (SubJoypad t) = generalUnSubscribe t
instance SDLSubsystem SubJoypad UserData where instance SDLSubsystem SubJoypad where
consumeSDLEvents = consumeSDLJoystickEvents 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 partSubscribers (SubTranslator t) = generalSubscribers t
@ -197,25 +199,25 @@ instance Participant SubTranslator UserData where
partUnSubscribe (SubTranslator t) = generalUnSubscribe t partUnSubscribe (SubTranslator t) = generalUnSubscribe t
generalSubscribers generalSubscribers
:: TVar [(UUID, msg -> Affection UserData ())] :: TVar [(UUID, msg -> Affection ())]
-> Affection UserData [(msg -> Affection UserData ())] -> Affection [(msg -> Affection ())]
generalSubscribers t = do generalSubscribers t = do
subTups <- liftIO $ readTVarIO t subTups <- liftIO $ readTVarIO t
return $ map snd subTups return $ map snd subTups
generalSubscribe generalSubscribe
:: TVar [(UUID, msg -> Affection UserData ())] :: TVar [(UUID, msg -> Affection ())]
-> (msg -> Affection UserData ()) -> (msg -> Affection ())
-> Affection UserData UUID -> Affection UUID
generalSubscribe t funct = do generalSubscribe t funct = do
uu <- genUUID uu <- genUUID
liftIO $ atomically $ modifyTVar' t ((uu, funct) :) liftIO $ atomically $ modifyTVar' t ((uu, funct) :)
return uu return uu
generalUnSubscribe generalUnSubscribe
:: TVar [(UUID, msg -> Affection UserData ())] :: TVar [(UUID, msg -> Affection ())]
-> UUID -> UUID
-> Affection UserData () -> Affection ()
generalUnSubscribe t uu = generalUnSubscribe t uu =
liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uu)) liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uu))
where where

View file

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

View file

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