nek0/tracer
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

Compare commits

base: nek0:master
Branches Tags
nek0:master
nek0:make_affectionate
nek0:police
nek0:multiwin_compat
nek0:axe
nek0:parallel-ecstasy
nek0:drawfilter
..
compare: nek0:parallel-ecstasy
Branches Tags
nek0:master
nek0:make_affectionate
nek0:police
nek0:multiwin_compat
nek0:axe
nek0:parallel-ecstasy
nek0:drawfilter

1 commit
master ... parallel-e

Author SHA1 Message Date
nek0
f30bd58fed deparallelize drawing 2019-03-07 16:43:00 +01:00
36 changed files with 1653 additions and 1637 deletions
Show stats Expand all files Collapse all files

1
.envrc
View file

@ -1 +0,0 @@
use flake

2
.gitignore vendored
View file

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

BIN
assets/policem.kra
View file

Binary file not shown.

BIN
assets/policem.png
View file

Binary file not shown.
Side by side

Before

Width:  |  Height:  |  Size: 17 KiB

2
cabal.config Normal file
View file

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

4
cabal.project Normal file
View file

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

84
flake.lock
View file

@ -1,84 +0,0 @@
{
"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
View file

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

645
src/Floorplan.hs
View file

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

49
src/Init.hs
View file

@ -11,9 +11,7 @@ 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)
@ -37,26 +35,21 @@ init = do
<*> (SubTranslator <$> newTVarIO []) <*> (SubTranslator <$> newTVarIO [])
_ <- glewInit _ <- glewInit
nvg <- createGL3 (S.fromList [NanoVG.Debug, Antialias, StencilStrokes]) nvg <- createGL3 (S.fromList [NanoVG.Debug, Antialias, StencilStrokes])
UserData return UserData
<$> newMVar Load -- state { state = Load
<*> pure subs -- subsystems , subsystems = subs
<*> newMVar M.empty -- assetIcons , assetImages = M.empty
<*> newMVar M.empty -- assetImages , assetAnimations = M.empty
<*> newMVar M.empty -- assetFonts , assetFonts = M.empty
<*> newMVar M.empty -- assetAnimations , assetIcons = M.empty
<*> newMVar NoController -- controls , nano = nvg
<*> newMVar NoTranslation -- translation , uuid = []
<*> pure nvg -- nano , stateData = None
<*> newMVar [] -- uuid , threadContext = Nothing
<*> newEmptyMVar -- worldState <- , controls = NoController
<*> newMVar None -- stateData , translation = NoTranslation
<*> newEmptyMVar -- stateMVar <- , joyCache = []
<*> 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
@ -69,7 +62,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 (fromString err) logIO Error err
exitFailure exitFailure
Right dimg -> do Right dimg -> do
let img = convertRGBA8 dimg let img = convertRGBA8 dimg
@ -77,16 +70,10 @@ 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 (S.singleton ImagePremultiplied) (toStrict $ encodePng cr) createImageMem nvg ImagePremultiplied (toStrict $ encodePng cr)
case mresimg of case mresimg of
Nothing -> do Nothing -> do
logIO logIO Error ("Failed to load: " ++ fp ++ " " ++ show i)
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)

2
src/Interior.hs
View file

@ -1,5 +1,7 @@
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

174
src/Load.hs
View file

@ -7,59 +7,57 @@ 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 import Control.Monad (when)
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
import Menu.Connect import Menu.Connect
import Types import Types
import MainGame.WorldMap
import Util import Util
loadLoad :: UserData -> Affection () loadLoad :: Affection UserData ()
loadLoad ud = do loadLoad = do
ad <- A.get ad <- A.get
wState <- liftIO $ readMVar (worldState ud) ud <- getAffection
curWin <- liftIO $ readMVar (window ud) progress <- liftIO $ newMVar (0, "Starting up")
tContext <- liftIO $ readMVar (threadContext ud) future <- liftIO newEmptyMVar
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
wState (worldState ud)
(fromJust curWin) (fromJust $ window ud)
(fromJust tContext) (fromJust $ threadContext ud)
(nano ud) (nano ud)
(stateMVar ud) future
(stateProgress ud) progress
SDL.glMakeCurrent (fromJust curWin) (acContext $ head $ glContext ad) SDL.glMakeCurrent (fromJust $ window ud) (glContext ad)
void $ liftIO $ swapMVar (state ud) Load putAffection ud
void $ liftIO $ swapMVar (assetFonts ud) (M.fromList { stateMVar = future
[ (FontBedstead, "bedstead") , stateProgress = progress
] , state = Load
) , assetFonts = M.fromList
[ (FontBedstead, "bedstead")
]
}
loadFork loadFork
:: SystemState Entity (AffectionState (AffectionData) ResIO) :: SystemState Entity (AffectionState (AffectionData UserData) IO)
-> SDL.Window -> SDL.Window
-> SDL.GLContext -> SDL.GLContext
-> Context -> Context
-> MVar -> MVar
( SystemState Entity (AffectionState (AffectionData) ResIO) ( SystemState Entity (AffectionState (AffectionData UserData) IO)
, StateData , StateData
) )
-> MVar (Float, T.Text) -> MVar (Float, T.Text)
@ -72,202 +70,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") (S.singleton ImagePremultiplied) mcontrblue <- createImage nvg (FileName "assets/icons/controller_blue.png") 0
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") (S.singleton ImagePremultiplied) mcontrgreen <- createImage nvg (FileName "assets/icons/controller_green.png") 0
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") (S.singleton ImagePremultiplied) mkbdblue <- createImage nvg (FileName "assets/icons/keyboard_blue.png") 0
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") (S.singleton ImagePremultiplied) mkbdgreen <- createImage nvg (FileName "assets/icons/keyboard_green.png") 0
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") (S.singleton ImagePremultiplied) marrow <- createImage nvg (FileName "assets/icons/arrow.png") 0
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") (S.singleton ImagePremultiplied) mwallasc <- createImage nvg (FileName "assets/walls/wall_asc.png") 0
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") (S.singleton ImagePremultiplied) mwalldesc <- createImage nvg (FileName "assets/walls/wall_desc.png") 0
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") (S.singleton ImagePremultiplied) mwallcornern <- createImage nvg (FileName "assets/walls/wall_corner_n.png") 0
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") (S.singleton ImagePremultiplied) mwallcornere <- createImage nvg (FileName "assets/walls/wall_corner_e.png") 0
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") (S.singleton ImagePremultiplied) mwallcorners <- createImage nvg (FileName "assets/walls/wall_corner_s.png") 0
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") (S.singleton ImagePremultiplied) mwallcornerw <- createImage nvg (FileName "assets/walls/wall_corner_w.png") 0
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") (S.singleton ImagePremultiplied) mwalltne <- createImage nvg (FileName "assets/walls/wall_t_ne.png") 0
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") (S.singleton ImagePremultiplied) mwalltse <- createImage nvg (FileName "assets/walls/wall_t_se.png") 0
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") (S.singleton ImagePremultiplied) mwalltsw <- createImage nvg (FileName "assets/walls/wall_t_sw.png") 0
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") (S.singleton ImagePremultiplied) mwalltnw <- createImage nvg (FileName "assets/walls/wall_t_nw.png") 0
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") (S.singleton ImagePremultiplied) mwallcross <- createImage nvg (FileName "assets/walls/wall_cross.png") 0
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") (S.singleton ImagePremultiplied) mmiscbox1 <- createImage nvg (FileName "assets/misc/box1.png") 0
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") (S.singleton ImagePremultiplied) mtableSW <- createImage nvg (FileName "assets/table/tableSW.png") 0
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") (S.singleton ImagePremultiplied) mtableSE <- createImage nvg (FileName "assets/table/tableSE.png") 0
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") (S.singleton ImagePremultiplied) mtableNE <- createImage nvg (FileName "assets/table/tableNE.png") 0
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") (S.singleton ImagePremultiplied) mtableNW <- createImage nvg (FileName "assets/table/tableNW.png") 0
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") (S.singleton ImagePremultiplied) mtablec1 <- createImage nvg (FileName "assets/table/tablec1.png") 0
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") (S.singleton ImagePremultiplied) mtablec2 <- createImage nvg (FileName "assets/table/tablec2.png") 0
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") (S.singleton ImagePremultiplied) mtablec3 <- createImage nvg (FileName "assets/table/tablec3.png") 0
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") (S.singleton ImagePremultiplied) mtablec4 <- createImage nvg (FileName "assets/table/tablec4.png") 0
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") (S.singleton ImagePremultiplied) mtableC <- createImage nvg (FileName "assets/table/tableCorner.png") 0
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") (S.singleton ImagePremultiplied) mmiscFlipchart <- createImage nvg (FileName "assets/misc/flipchart.png") 0
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") (S.singleton ImagePremultiplied) mmiscPlant1 <- createImage nvg (FileName "assets/misc/plant1.png") 0
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") (S.singleton ImagePremultiplied) mmiscPlant2 <- createImage nvg (FileName "assets/misc/plant2.png") 0
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") (S.singleton ImagePremultiplied) mmiscWatercooler <- createImage nvg (FileName "assets/misc/watercooler.png") 0
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") (S.singleton ImagePremultiplied) mmiscVending <- createImage nvg (FileName "assets/misc/vending.png") 0
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") (S.singleton ImagePremultiplied) mcabCoffeeSW <- createImage nvg (FileName "assets/cabinet/cabCoffeeSW.png") 0
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") (S.singleton ImagePremultiplied) mcabCoffeeSE <- createImage nvg (FileName "assets/cabinet/cabCoffeeSE.png") 0
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") (S.singleton ImagePremultiplied) mcabSinkSW <- createImage nvg (FileName "assets/cabinet/cabSinkSW.png") 0
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") (S.singleton ImagePremultiplied) mcabSinkSE <- createImage nvg (FileName "assets/cabinet/cabSinkSE.png") 0
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") (S.singleton ImagePremultiplied) mcabStoveSW <- createImage nvg (FileName "assets/cabinet/cabStoveSW.png") 0
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") (S.singleton ImagePremultiplied) mcabStoveSE <- createImage nvg (FileName "assets/cabinet/cabStoveSE.png") 0
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") (S.singleton ImagePremultiplied) mcabinetSW <- createImage nvg (FileName "assets/cabinet/cabinetSW.png") 0
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") (S.singleton ImagePremultiplied) mcabinetSE <- createImage nvg (FileName "assets/cabinet/cabinetSE.png") 0
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") (S.singleton ImagePremultiplied) mcabinetCorner <- createImage nvg (FileName "assets/cabinet/cabinetCorner.png") 0
let micons = let micons =
[ mcontrblue, mcontrgreen, mkbdblue, mkbdgreen, marrow [ mcontrblue, mcontrgreen, mkbdblue, mkbdgreen, marrow
] ]
@ -337,18 +335,6 @@ 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\""
@ -503,15 +489,11 @@ loadFork ws win glc nvg future progress = do
, AnimationConfig (0, 4*74) (64, 74) (0, -74) 5 0.25 APOnce , AnimationConfig (0, 4*74) (64, 74) (0, -74) 5 0.25 APOnce
) )
] ]
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "GL_Finish"
)))
finish
modifyMVar_ progress (return . (\(p, _) -> modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Handing over" , "Handing over"
))) )))
finish
putMVar future putMVar future
( ws ( ws
, LoadData , LoadData
@ -521,8 +503,6 @@ loadFork ws win glc nvg future progress = do
playerWalking ++ playerWalking ++
jdoemStanding ++ jdoemStanding ++
jdoemWalking ++ jdoemWalking ++
policemStanding ++
policemWalking ++
copierStand ++ copierStand ++
copierCopy ++ copierCopy ++
cornerComputerOff ++ cornerComputerOff ++
@ -545,24 +525,30 @@ loadFork ws win glc nvg future progress = do
} }
) )
drawLoad :: UserData -> Affection () drawLoad :: Affection UserData ()
drawLoad ud = do drawLoad = do
ud <- getAffection
progress <- liftIO $ readMVar (stateProgress ud) progress <- liftIO $ readMVar (stateProgress ud)
liftIO $ do liftIO $ do
logIO A.Verbose ("LoadProgress: " <> fromString (show progress)) logIO A.Verbose ("LoadProgress: " ++ show progress)
drawLoadScreen ud progress drawLoadScreen ud progress
updateLoad :: UserData -> Double -> Affection () updateLoad :: Double -> Affection UserData ()
updateLoad ud _ = do updateLoad _ = 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"
void $ liftIO $ swapMVar (assetImages ud) (loadAssetImages ld) putAffection ud
void $ liftIO $ swapMVar (assetAnimations ud) (loadAssetAnims ld) { assetImages = loadAssetImages ld
void $ liftIO $ swapMVar (assetIcons ud) (loadAssetIcons ld) , assetAnimations = loadAssetAnims ld
void $ liftIO $ swapMVar (stateData ud) None , assetIcons = loadAssetIcons ld
-- , state = Main WorldMap
-- , state = Menu Connect
, stateData = None
}
-- loadMap -- loadMap
loadMenu ud loadMenu
Nothing -> Nothing ->
return () return ()

160
src/Main.hs
View file

@ -4,6 +4,7 @@ module Main where
import Affection as A import Affection as A
import Data.Ecstasy import Data.Ecstasy
import Data.Ecstasy.Types
import qualified SDL import qualified SDL
@ -15,9 +16,7 @@ import Foreign.C.Types (CInt(..))
import Data.Maybe (fromJust) import Data.Maybe (fromJust)
import Control.Monad import Control.Monad (when)
import Control.Concurrent.MVar
import Control.Monad.Trans.Resource (allocate)
-- internal imports -- internal imports
@ -29,108 +28,101 @@ 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 = , windowConfig = SDL.defaultWindow
[ ( 0 { SDL.windowInitialSize = V2 1280 720
, SDL.defaultWindow , SDL.windowResizable = True
{ SDL.windowInitialSize = V2 1920 1080 , SDL.windowOpenGL = Just SDL.defaultOpenGL
, SDL.windowResizable = True { SDL.glProfile = SDL.Core SDL.Normal 3 3
, SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL }
{ SDL.glProfile = SDL.Core SDL.Normal 3 3 }
} , canvasSize = Nothing
} , preLoop = pre >> smLoad Load
, SDL.Windowed , eventLoop = handle
) , updateLoop = update
] , drawLoop = draw
} :: AffectionConfig UserData , loadState = Init.init
, cleanUp = clean
, initScreenMode = SDL.Windowed
}
withAffection config withAffection config
pre :: UserData -> Affection () pre :: Affection UserData ()
pre ud = do pre = do
ad <- A.get ad <- A.get
let (AffectionWindow awwindow _ _) = head $ drawWindows ad ud <- getAffection
threadCtx <- SDL.glCreateContext awwindow threadCtx <- SDL.glCreateContext (drawWindow ad)
SDL.glMakeCurrent awwindow (acContext $ head $ glContext ad) SDL.glMakeCurrent (drawWindow ad) (glContext ad)
let Subsystems w _ k j _ = subsystems ud let Subsystems w m k j t = subsystems ud
_ <- partSubscribe w (fitViewport (1920/1080)) _ <- partSubscribe w (fitViewport (1280/720))
_ <- partSubscribe w (exitOnWindowClose ud) _ <- partSubscribe w exitOnWindowClose
_ <- partSubscribe k toggleFullScreen _ <- partSubscribe k toggleFullScreen
_ <- partSubscribe k (quitGame ud) _ <- partSubscribe k quitGame
u <- partSubscribe j (cacheJoypad ud) u <- partSubscribe j cacheJoypad
(ws, _) <- yieldSystemT (0, defStorage) (return ()) (ws, _) <- yieldSystemT (SystemState 0 defStorage defHooks) (return ())
void $ liftIO $ swapMVar (threadContext ud) (Just threadCtx) putAffection ud
void $ liftIO $ swapMVar (window ud) (Just awwindow) { threadContext = Just threadCtx
void $ liftIO $ putMVar (worldState ud) ws , window = Just (drawWindow ad)
void $ liftIO $ putMVar (joyUUID ud) u , worldState = ws
, joyUUID = u
}
quitGame :: UserData -> KeyboardMessage -> Affection () quitGame :: KeyboardMessage -> Affection UserData ()
quitGame ud (MsgKeyboardEvent _ _ SDL.Pressed False sym) quitGame (MsgKeyboardEvent _ _ SDL.Pressed False sym)
| SDL.keysymKeycode sym == SDL.KeycodeEscape = | SDL.keysymKeycode sym == SDL.KeycodeEscape = quit
void $ liftIO $ swapMVar (doNextStep ud) False
| SDL.keysymKeycode sym == SDL.KeycodeF5 = do | SDL.keysymKeycode sym == SDL.KeycodeF5 = do
ad <- A.get ad <- A.get
curState <- liftIO $ readMVar (state ud) ud <- getAffection
when (curState == Main WorldMap || curState == Main MindMap) $ do when (state ud == Main WorldMap || state ud == Main MindMap) $ do
let Subsystems w m k j t = subsystems ud let Subsystems w m k j t = subsystems ud
curUUID <- liftIO $ readMVar (uuid ud) mapM_ (partUnSubscribe w) (uuid ud)
mapM_ (partUnSubscribe w) curUUID mapM_ (partUnSubscribe m) (uuid ud)
mapM_ (partUnSubscribe m) curUUID mapM_ (partUnSubscribe k) (uuid ud)
mapM_ (partUnSubscribe k) curUUID mapM_ (partUnSubscribe j) (uuid ud)
mapM_ (partUnSubscribe j) curUUID mapM_ (partUnSubscribe t) (uuid ud)
mapM_ (partUnSubscribe t) curUUID SDL.glMakeCurrent (drawWindow ad) (glContext ad)
SDL.glMakeCurrent (ws, _) <- yieldSystemT (SystemState 0 defStorage defHooks) (return ())
(awWindow $ head $ drawWindows ad) putAffection ud
(acContext $ head $ glContext ad) { worldState = ws
(ws, _) <- yieldSystemT (0, defStorage) (return ()) , state = Load
void $ liftIO $ swapMVar (worldState ud) ws }
void $ liftIO $ swapMVar (state ud) Load smLoad Load
smLoad Load ud | otherwise = return ()
| otherwise = return () quitGame _ = return ()
quitGame _ _ = return ()
toggleFullScreen :: KeyboardMessage -> Affection () toggleFullScreen :: KeyboardMessage -> Affection UserData ()
toggleFullScreen (MsgKeyboardEvent _ _ SDL.Pressed False sym) toggleFullScreen (MsgKeyboardEvent _ _ SDL.Pressed False sym)
| SDL.keysymKeycode sym == SDL.KeycodeF11 = toggleScreen 0 | SDL.keysymKeycode sym == SDL.KeycodeF11 = toggleScreen
| otherwise = return () | otherwise = return ()
toggleFullScreen _ = return () toggleFullScreen _ = return ()
update :: UserData -> Double -> Affection () update :: Double -> Affection UserData ()
update ud dt = do update dt = do
curState <- liftIO $ readMVar (state ud) ud <- getAffection
smUpdate curState ud dt smUpdate (state ud) dt
draw :: UserData -> Affection () draw :: Affection UserData ()
draw ud = do draw = do
curState <- liftIO $ readMVar (state ud) ud <- getAffection
liftIO $ beginFrame (nano ud) 1280 720 1 liftIO $ beginFrame (nano ud) 1280 720 1
smDraw curState ud smDraw (state ud)
liftIO $ endFrame (nano ud) liftIO $ endFrame (nano ud)
handle :: UserData -> [SDL.EventPayload] -> Affection () handle :: [SDL.EventPayload] -> Affection UserData ()
handle ud evs = do handle evs = do
s <- liftIO $ readMVar (state ud) s <- state <$> getAffection
smEvent s ud evs smEvent s evs
exitOnWindowClose :: UserData -> WindowMessage -> Affection () exitOnWindowClose :: WindowMessage -> Affection UserData ()
exitOnWindowClose ud (MsgWindowClose _ _) = do exitOnWindowClose (MsgWindowClose _ _) = do
liftIO $ logIO A.Debug "Window Closed" liftIO $ logIO A.Debug "Window Closed"
void $ liftIO $ swapMVar (doNextStep ud) False quit
exitOnWindowClose _ _ = return () exitOnWindowClose _ = return ()
clean :: UserData -> IO () clean :: UserData -> IO ()
clean ud = do clean ud =
tContext <- readMVar (threadContext ud) SDL.glDeleteContext $ fromJust $ threadContext ud
SDL.glDeleteContext $ fromJust tContext

290
src/MainGame/MindMap.hs
View file

@ -11,13 +11,9 @@ 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
@ -28,146 +24,145 @@ import Collision
import Util import Util
updateMind :: UserData -> Double -> Affection () updateMind :: Double -> Affection UserData ()
updateMind ud dt = do updateMind dt = do
wState <- liftIO $ readMVar (worldState ud) ud <- getAffection
sData <- liftIO $ readMVar (stateData ud) (nws, _) <- yieldSystemT (worldState ud) $ do
(nws, _) <- yieldSystemT wState $ do emap allEnts $ do
emap allEnts $ do with player
with player with xyvel
with xyvel with mmvel
with mmvel V2 rx ry <- query xyvel
V2 rx ry <- query xyvel -- let dr = (ry / sin (atan (1/2)) / 2) + rx
-- let dr = (ry / sin (atan (1/2)) / 2) + rx -- dc = rx - (ry / sin (atan (1/2)) / 2)
-- dc = rx - (ry / sin (atan (1/2)) / 2) let V2 dr dc = fmap (* 1.5) (V2 rx ry `rotVec` 45)
let V2 dr dc = fmap (* 1.5) (V2 rx ry `rotVec` 45) return $ unchanged
return $ unchanged { mmvel = Set $ 2 * V2 dr dc
{ mmvel = Set $ 2 * V2 dr dc }
} emap allEnts $ do
emap allEnts $ do with anim
with anim with mmpos
with mmpos stat <- query anim
stat <- query anim let an = assetAnimations ud Map.! asId stat
aAnims <- liftIO $ readMVar (assetAnimations ud) ntime = asElapsedTime stat + dt
let an = aAnims Map.! asId stat nstate = if ntime > fromIntegral (asCurrentFrame stat) *
ntime = asElapsedTime stat + dt (animDuration an / fromIntegral (length $ animSprites an))
nstate = if ntime > fromIntegral (asCurrentFrame stat) * then
(animDuration an / fromIntegral (length $ animSprites an)) let nframe = asCurrentFrame stat + 1
then in case animPlay an of
let nframe = asCurrentFrame stat + 1 APLoop ->
in case animPlay an of let (nnframe, nntime) =
APLoop -> if nframe >= length (animSprites an)
let (nnframe, nntime) = then (0, 0)
if nframe >= length (animSprites an) else (nframe, ntime)
then (0, 0) in stat
else (nframe, ntime) { asCurrentFrame = nnframe
in stat , asElapsedTime = nntime
{ asCurrentFrame = nnframe }
, asElapsedTime = nntime APOnce ->
} let nnframe = if nframe >= length (animSprites an)
APOnce -> then nframe - 1
let nnframe = if nframe >= length (animSprites an) else nframe
then nframe - 1 in stat
else nframe { asCurrentFrame = nnframe
in stat , asElapsedTime = ntime
{ asCurrentFrame = nnframe }
, asElapsedTime = ntime else
} stat
else { asElapsedTime = ntime
stat }
{ asElapsedTime = ntime return $ unchanged
} { anim = Set nstate
return $ unchanged }
{ anim = Set nstate emap allEnts $ do
} with player
emap allEnts $ do with mmvel
with player with mmpos
with mmvel with rot
with mmpos with anim
with rot pos'@(V2 pr pc) <- query mmpos
with anim vel' <- query mmvel
pos'@(V2 pr pc) <- query mmpos rot' <- query rot
vel' <- query mmvel stat <- query anim
rot' <- query rot let npos = pos' + fmap (* dt) vel'
stat <- query anim dpos@(V2 dpr dpc) = npos - pos'
let npos = pos' + fmap (* dt) vel' aId = asId stat
dpos@(V2 dpr dpc) = npos - pos' nstat = case aiName aId of
aId = asId stat "walking"
nstat = case aiName aId of | sqrt (colldpos `dot` colldpos) > 0 ->
"walking" stat
| sqrt (colldpos `dot` colldpos) > 0 -> { asId = aId
stat { aiDirection = fromMaybe rot' (direction vel')
{ asId = aId }
{ aiDirection = fromMaybe rot' (direction vel') }
} | otherwise ->
} stat
| otherwise -> { asId = aId
stat { aiDirection = fromMaybe rot' (direction vel')
{ asId = aId , aiName = "standing"
{ aiDirection = fromMaybe rot' (direction vel') }
, aiName = "standing" , asCurrentFrame = 0
} }
, asCurrentFrame = 0 "standing"
} | sqrt (colldpos `dot` colldpos) > 0 ->
"standing" stat
| sqrt (colldpos `dot` colldpos) > 0 -> { asId = aId
stat { aiDirection = fromMaybe rot' (direction vel')
{ asId = aId , aiName = "walking"
{ aiDirection = fromMaybe rot' (direction vel') }
, aiName = "walking" , asCurrentFrame = 0
} }
, asCurrentFrame = 0 | otherwise ->
} stat
| otherwise -> { asId = aId
stat { aiDirection = fromMaybe rot' (direction vel')
{ asId = aId }
{ aiDirection = fromMaybe rot' (direction vel') }
} x -> error ("unknown animation name" ++ x)
} lll = (,)
x -> error ("unknown animation name" ++ x) <$> (
lll = (,) if dpr < 0
<$> ( then [(floor dpr :: Int) .. 0]
if dpr < 0 else [0 .. (ceiling dpr :: Int)])
then [(floor dpr :: Int) .. 0] <*> (
else [0 .. (ceiling dpr :: Int)]) if dpc < 0
<*> ( then [(floor dpc :: Int) .. 0]
if dpc < 0 else [0 .. (ceiling dpc :: Int)])
then [(floor dpc :: Int) .. 0] colldpos = dpos * Prelude.foldl
else [0 .. (ceiling dpc :: Int)]) (\acc a -> let ret = checkBoundsCollision2 pos' npos dt acc a
colldpos = dpos * Prelude.foldl in A.log A.Verbose (show ret) ret)
(\acc a -> let ret = checkBoundsCollision2 pos' npos dt acc a (V2 1 1)
in A.log A.Verbose (fromString $ show ret) ret) (
(V2 1 1) concatMap
( (\(dr, dc) ->
concatMap let bs = maybe [] collisionObstacle (fromMaybe Nothing $ M.safeGet
(\(dr, dc) -> (fromIntegral $ floor pr + dr)
let bs = fromMaybe [] $ collisionObstacle <$> M.unsafeGet (fromIntegral $ floor pc + dc)
(fromIntegral $ floor pr + dr) (mmImgMat (stateData ud)))
(fromIntegral $ floor pc + dc) in Prelude.map (\(Boundaries (minr, minc) (maxr, maxc))->
(mmImgMat sData) Boundaries
in Prelude.map (\(Boundaries (minr, minc) (maxr, maxc))-> (minr + fromIntegral dr, minc + fromIntegral dc)
Boundaries (maxr + fromIntegral dr, maxc + fromIntegral dc)
(minr + fromIntegral dr, minc + fromIntegral dc) ) bs
(maxr + fromIntegral dr, maxc + fromIntegral dc) )
) bs lll -- (A.log A.Verbose (show lll ++ " " ++ show len) lll)
) )
lll -- (A.log A.Verbose (show lll ++ " " ++ show len) lll) ent = unchanged
) { mmpos = Set $ pos' + colldpos
ent = unchanged , rot = Set (fromMaybe rot' $ direction vel')
{ mmpos = Set $ pos' + colldpos , anim = Set nstat
, rot = Set (fromMaybe rot' $ direction vel') }
, anim = Set nstat return ent
} putAffection ud
return ent { worldState = nws
void $ liftIO $ swapMVar (worldState ud) nws }
drawMind :: UserData -> Affection () drawMind :: Affection UserData ()
drawMind ud = do drawMind = do
sData <- liftIO $ readMVar (stateData ud) ud <- getAffection
wState <- liftIO $ readMVar (worldState ud)
let ctx = nano ud let ctx = nano ud
dt <- getDelta dt <- getDelta
(_, (playerPos, posanims)) <- yieldSystemT wState $ do (_, (playerPos, posanims)) <- yieldSystemT (worldState ud) $ do
pc <- fmap head $ efor allEnts $ do pc <- fmap head $ efor allEnts $ do
with player with player
with mmpos with mmpos
@ -181,7 +176,7 @@ drawMind ud = 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 sData mat = mmImgMat (stateData ud)
cols = fromIntegral (ncols mat) cols = fromIntegral (ncols mat)
rows = fromIntegral (nrows mat) rows = fromIntegral (nrows mat)
tileWidth = 64 :: Double tileWidth = 64 :: Double
@ -189,8 +184,8 @@ drawMind ud = 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 $ sData) (nrows $ mmImgMat $ stateData ud)
(ncols $ mmImgMat $ sData) (ncols $ mmImgMat $ stateData ud)
((reverse . fst) ((reverse . fst)
(Prelude.foldl (Prelude.foldl
(\(done, proc) coord -> (\(done, proc) coord ->
@ -199,8 +194,8 @@ drawMind ud = do
) )
([], posanims) ([], posanims)
((,) ((,)
<$> [1 .. (nrows $ mmImgMat $ sData)] <$> [1 .. (nrows $ mmImgMat $ stateData ud)]
<*> [1 .. (ncols $ mmImgMat $ sData)] <*> [1 .. (ncols $ mmImgMat $ stateData ud)]
) )
) )
) )
@ -234,8 +229,7 @@ drawMind ud = do
(reverse $ zip [1..] ls)) (reverse $ zip [1..] ls))
(zip [1..] (toLists mat)) (zip [1..] (toLists mat))
fontSize ctx 20 fontSize ctx 20
aFonts <- readMVar (assetFonts ud) fontFace ctx (assetFonts ud Map.! FontBedstead)
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)))

476
src/MainGame/WorldMap.hs
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)
@ -23,9 +23,7 @@ import qualified Data.Text as T
import Data.Matrix as M 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 (sortOn, partition, find)
import qualified Data.Vector as V
import Data.String
import System.Random (randomRIO) import System.Random (randomRIO)
@ -44,49 +42,63 @@ import NPC
import Animation import Animation
import Collision import Collision
loadMap :: UserData -> Affection () loadMap :: Affection UserData ()
loadMap ud = do loadMap = do
ud <- getAffection
ad <- get ad <- get
let (Subsystems _ _ k j t) = subsystems ud let (Subsystems _ m k j t) = subsystems ud
uu0 <- partSubscribe k (emitKbdActionMessage ud) uu0 <- partSubscribe k emitKbdActionMessage
uu1 <- partSubscribe j (emitJoyActionMessage ud) uu1 <- partSubscribe j emitJoyActionMessage
uu2 <- partSubscribe t (movePlayer2 ud) uu2 <- partSubscribe t movePlayer2
uu3 <- partSubscribe t (playerInteract2 ud) uu3 <- partSubscribe t playerInteract2
uu4 <- partSubscribe t (changeMaps2 ud) uu4 <- partSubscribe t changeMaps2
void $ liftIO $ swapMVar (stateProgress ud) (0, "Ohai!") future <- liftIO newEmptyMVar
_ <- liftIO $ forkIO $ loadMapFork ud ad (stateMVar ud) (stateProgress ud) progress <- liftIO $ newMVar (0, "Ohai!")
void $ liftIO $ swapMVar (stateData ud) None _ <- liftIO $ forkIO $ loadMapFork ud ad future progress
void $ liftIO $ swapMVar (uuid ud) [ uu0, uu1, uu2, uu3, uu4 ] putAffection ud
void $ liftIO $ swapMVar (state ud) (Main WorldMap) { stateData = None
, uuid = [ uu0, uu1, uu2, uu3, uu4 ]
, stateMVar = future
, stateProgress = progress
, state = Main WorldMap
}
changeMaps :: UserData -> KeyboardMessage -> Affection () changeMaps :: KeyboardMessage -> Affection UserData ()
changeMaps ud (MsgKeyboardEvent _ _ SDL.Pressed False sym) changeMaps (MsgKeyboardEvent _ _ SDL.Pressed False sym)
| SDL.keysymKeycode sym == SDL.KeycodeF1 = do | SDL.keysymKeycode sym == SDL.KeycodeF1 = do
curState <- liftIO $ readMVar (state ud) ud <- getAffection
case curState of case state ud of
Main MindMap -> Main MindMap ->
void $ liftIO $ swapMVar (state ud) (Main WorldMap) putAffection ud
{ state = Main WorldMap
}
Main WorldMap -> Main WorldMap ->
void $ liftIO $ swapMVar (state ud) (Main MindMap) putAffection ud
{ state = Main MindMap
}
_ -> return () _ -> return ()
| otherwise = return () | otherwise = return ()
changeMaps _ _ = return () changeMaps _ = return ()
changeMaps2 :: UserData -> ActionMessage -> Affection () changeMaps2 :: ActionMessage -> Affection UserData ()
changeMaps2 ud (ActionMessage ActSwitchMap _) = do changeMaps2 (ActionMessage ActSwitchMap _) = do
curState <- liftIO $ readMVar (state ud) ud <- getAffection
case curState of case state ud of
Main MindMap -> Main MindMap ->
void $ liftIO $ swapMVar (state ud) (Main WorldMap) putAffection ud
{ state = Main WorldMap
}
Main WorldMap -> Main WorldMap ->
void $ liftIO $ swapMVar (state ud) (Main MindMap) putAffection ud
{ state = Main MindMap
}
_ -> return () _ -> return ()
changeMaps2 _ _ = return () changeMaps2 _ = return ()
loadMapFork loadMapFork
:: UserData :: UserData
-> AffectionData -> AffectionData UserData
-> MVar (SystemState Entity (AffectionState AffectionData ResIO), StateData) -> MVar (SystemState Entity (AffectionState (AffectionData UserData) IO), StateData)
-> MVar (Float, T.Text) -> MVar (Float, T.Text)
-> IO () -> IO ()
loadMapFork ud ad future progress = do loadMapFork ud ad future progress = do
@ -95,7 +107,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)]
(40, 40) (50, 50)
modifyMVar_ progress (return . (\(p, _) -> modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Building floor" , "Building floor"
@ -124,14 +136,13 @@ loadMapFork ud ad future progress = do
( p + increment ( p + increment
, "Placing furniture" , "Placing furniture"
))) )))
(!inter, !rawrps) <- placeInteriorIO mat imgmat exits (V.toList gr) (!inter, !rawrps) <- placeInteriorIO mat imgmat exits 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"
))) )))
wState <- liftIO $ readMVar (worldState ud) (nws, mmimgmat) <- evalStateT (runState (yieldSystemT (worldState ud) $ do
(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"
@ -147,12 +158,7 @@ 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"
@ -173,12 +179,7 @@ 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"
@ -193,12 +194,7 @@ 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"
@ -233,9 +229,7 @@ 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 liftIO $ A.logIO A.Debug $ "number of placed NPCs: " ++ show (length computers)
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"
@ -249,25 +243,22 @@ loadMapFork ud ad future progress = do
<*> (randomRIO (0, 1)) <*> (randomRIO (0, 1))
<*> (randomRIO (0, 1)) <*> (randomRIO (0, 1))
<*> (randomRIO (0, 1)) <*> (randomRIO (0, 1))
police <- liftIO $ randomRIO (0 :: Int, 9 :: Int) let room = head
let room = V.head (Prelude.filter
(V.filter
((inBounds $ pointCoord cpr) . bounds) ((inBounds $ pointCoord cpr) . bounds)
(V.fromList $ (Types.connects (head gr) ++ tail gr)
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))
, vel = Just (V2 0 0) , vel = Just (V2 0 0)
, velFact = Just fact , velFact = Just fact
, rot = Just SE , rot = Just SE
, npcMoveState = Just (NPCWalking [[pointCoord cpr]]) , npcMoveState = Just (NPCWalking [pointCoord cpr])
, npcWorkplace = Just cpr , npcWorkplace = Just cpr
, npcActionState = Just ASWork , npcActionState = Just ASWork
, npcStats = Just stats , npcStats = Just stats
, clearanceLvl = Just (clearance room) , clearanceLvl = Just (clearance room)
, anim = Just $ AnimState , anim = Just $ AnimState (AnimId AnimJDoeM "standing" SE) 0 0
(AnimId (if police == 0 then AnimPoliceM else AnimJDoeM) "standing" SE) 0 0
} }
) computers ) computers
liftIO $ modifyMVar_ progress (return . (\(p, _) -> liftIO $ modifyMVar_ progress (return . (\(p, _) ->
@ -275,18 +266,17 @@ loadMapFork ud ad future progress = do
, "Registering doors into WorldState" , "Registering doors into WorldState"
))) )))
mapM_ (\door -> do mapM_ (\door -> do
let rooms = V.foldl let rooms = Prelude.foldl
(\acc coord -> (\acc coord ->
let rs = V.filter ((inBounds coord) . bounds) graph let rs = Prelude.filter ((inBounds coord) . bounds) graph
in in
if not (V.null rs) if not (Prelude.null rs)
then (coord, V.head rs) `V.cons` acc then (coord, head rs) : acc
else acc else acc
) )
V.empty []
(V.fromList coords) coords
graph = V.fromList $ graph = Types.connects (head gr) ++ tail gr
(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
@ -295,19 +285,18 @@ loadMapFork ud ad future progress = do
, V2 0 (-1) , V2 0 (-1)
] ]
wall = Prelude.filter wall = Prelude.filter
(\ddelta -> (\delta ->
let V2 r c = door + ddelta let V2 r c = door + delta
in in
fromMaybe False (isWall <$> imgmat M.! (r, c))) fromMaybe False (isWall <$> imgmat M.! (r, c)))
deltas deltas
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 (V.maximum $ , clearanceLvl = Just (maximum $ 0 : Prelude.map clearance (Prelude.map snd rooms))
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)
@ -341,19 +330,19 @@ loadMapFork ud ad future progress = do
then Nothing then Nothing
else a) else a)
(M.toList inter) (M.toList inter)
void $ putMVar future (nws, MainData putMVar future (nws, MainData
{ mapMat = mat { mapMat = mat
, imgMat = retMat , imgMat = retMat
, reachPoints = V.fromList rps , reachPoints = rps
, mmImgMat = mmimgmat , mmImgMat = mmimgmat
, roomGraph = gr , roomGraph = gr
}) })
movePlayerKbd :: UserData -> KeyboardMessage -> Affection () movePlayerKbd :: KeyboardMessage -> Affection UserData ()
movePlayerKbd ud (MsgKeyboardEvent _ _ press False sym) movePlayerKbd (MsgKeyboardEvent _ _ press False sym)
| SDL.keysymKeycode sym == SDL.KeycodeW = do | SDL.keysymKeycode sym == SDL.KeycodeW = do
wState <- liftIO $ readMVar (worldState ud) ud <- getAffection
(nws, _) <- yieldSystemT wState $ (nws, _) <- yieldSystemT (worldState ud) $
emap allEnts $ do emap allEnts $ do
with player with player
(V2 vx _) <- query xyvel (V2 vx _) <- query xyvel
@ -363,10 +352,12 @@ movePlayerKbd ud (MsgKeyboardEvent _ _ press False sym)
return $ unchanged return $ unchanged
{ xyvel = Set $ V2 vx ry { xyvel = Set $ V2 vx ry
} }
void $ liftIO $ swapMVar (worldState ud) nws putAffection ud
{ worldState = nws
}
| SDL.keysymKeycode sym == SDL.KeycodeS = do | SDL.keysymKeycode sym == SDL.KeycodeS = do
wState <- liftIO $ readMVar (worldState ud) ud <- getAffection
(nws, _) <- yieldSystemT wState $ (nws, _) <- yieldSystemT (worldState ud) $
emap allEnts $ do emap allEnts $ do
with player with player
(V2 vx _) <- query xyvel (V2 vx _) <- query xyvel
@ -376,10 +367,12 @@ movePlayerKbd ud (MsgKeyboardEvent _ _ press False sym)
return $ unchanged return $ unchanged
{ xyvel = Set $ V2 vx ry { xyvel = Set $ V2 vx ry
} }
void $ liftIO $ swapMVar (worldState ud) nws putAffection ud
{ worldState = nws
}
| SDL.keysymKeycode sym == SDL.KeycodeA = do | SDL.keysymKeycode sym == SDL.KeycodeA = do
wState <- liftIO $ readMVar (worldState ud) ud <- getAffection
(nws, _) <- yieldSystemT wState $ (nws, _) <- yieldSystemT (worldState ud) $
emap allEnts $ do emap allEnts $ do
with player with player
(V2 _ vy) <- query xyvel (V2 _ vy) <- query xyvel
@ -389,10 +382,12 @@ movePlayerKbd ud (MsgKeyboardEvent _ _ press False sym)
return $ unchanged return $ unchanged
{ xyvel = Set $ V2 rx vy { xyvel = Set $ V2 rx vy
} }
void $ liftIO $ swapMVar (worldState ud) nws putAffection ud
{ worldState = nws
}
| SDL.keysymKeycode sym == SDL.KeycodeD = do | SDL.keysymKeycode sym == SDL.KeycodeD = do
wState <- liftIO $ readMVar (worldState ud) ud <- getAffection
(nws, _) <- yieldSystemT wState $ (nws, _) <- yieldSystemT (worldState ud) $
emap allEnts $ do emap allEnts $ do
with player with player
(V2 _ vy) <- query xyvel (V2 _ vy) <- query xyvel
@ -402,14 +397,16 @@ movePlayerKbd ud (MsgKeyboardEvent _ _ press False sym)
return $ unchanged return $ unchanged
{ xyvel = Set $ V2 rx vy { xyvel = Set $ V2 rx vy
} }
void $ liftIO $ swapMVar (worldState ud) nws putAffection ud
{ worldState = nws
}
| otherwise = return () | otherwise = return ()
movePlayerKbd _ _ = return () movePlayerKbd _ = return ()
movePlayer2 :: UserData -> ActionMessage -> Affection () movePlayer2 :: ActionMessage -> Affection UserData ()
movePlayer2 ud (ActionMessage mov _) = do movePlayer2 (ActionMessage mov _) = do
wState <- liftIO $ readMVar (worldState ud) ud <- getAffection
(nws, _) <- yieldSystemT wState $ (nws, _) <- yieldSystemT (worldState ud) $
emap allEnts $ do emap allEnts $ do
with player with player
V2 vx vy <- query xyvel V2 vx vy <- query xyvel
@ -421,12 +418,66 @@ movePlayer2 ud (ActionMessage mov _) = do
ActRight f -> V2 f vy ActRight f -> V2 f vy
_ -> V2 vx vy _ -> V2 vx vy
} }
void $ liftIO $ swapMVar (worldState ud) nws putAffection ud
{ worldState = nws
}
movePlayer2 _ = return ()
playerInteract2 :: UserData -> ActionMessage -> Affection () playerInteract :: MouseMessage -> Affection UserData ()
playerInteract2 ud (ActionMessage ActActivate _) = do playerInteract (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonRight _ m) = do
wState <- liftIO $ readMVar (worldState ud) ud <- getAffection
(nws, _) <- yieldSystemT wState $ do (V2 rx ry) <- liftIO $ (* V2 640 360) <$> relativizeMouseCoords m
let dr = ((ry / 32) / sin (atan 0.5) / 2) + (rx / 64)
dc = (rx / 64) - ((ry / 32) / sin (atan 0.5) / 2)
(nws, _) <- yieldSystemT (worldState ud) $ do
emap allEnts $ do
with player
with rot
rot' <- query rot
let ndir = direction (V2 dr dc)
return $ unchanged
{ rot = Set $ fromMaybe rot' ndir
}
pdata <- efor allEnts $ do
with player
with pos
with rot
pos' <- query pos
rot' <- query rot
ent <- queryEnt
return (pos', rot', ent)
let (ppos, pdir, pent) = head pdata
mrelEnts <- efor allEnts $ do
with pos
with objAccess
with objType
with objState
reldirs <- query objAccess
pos' <- query pos
otype <- query objType
ostate <- query objState
ent <- queryEnt
if any (\(rel, dir) -> ((fmap floor ppos :: V2 Int) == (fmap floor pos' :: V2 Int) ||
(fmap floor ppos :: V2 Int) == (fmap floor pos' :: V2 Int) + rel) &&
(fmap floor (ppos + V2 dr dc) :: V2 Int) == (fmap floor pos' ::V2 Int) &&
pdir == dir) reldirs
then return $ Just (otype, ostate, ent)
else return Nothing
let relEnts = catMaybes mrelEnts
liftIO $ A.logIO A.Debug ("relEnts: " ++ show relEnts)
-- liftIO $ A.logIO A.Debug ("dV2: " ++ show (V2 dr dc))
mapM_ (\(t, s, e) ->
setEntity e =<< objectTransition t s True e (Just pent)
) relEnts
putAffection ud
{ worldState = nws
}
playerInteract _ = return ()
playerInteract2 :: ActionMessage -> Affection UserData ()
playerInteract2 (ActionMessage ActActivate _) = do
ud <- getAffection
(nws, _) <- yieldSystemT (worldState ud) $ do
pdata <- efor allEnts $ do pdata <- efor allEnts $ do
with player with player
with pos with pos
@ -452,30 +503,31 @@ playerInteract2 ud (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: " <> fromString (show relEnts)) liftIO $ A.logIO A.Debug ("relEnts: " ++ 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
void $ liftIO $ swapMVar (worldState ud) nws putAffection ud
playerInteract2 _ _ = return () { worldState = nws
}
playerInteract2 _ = return ()
drawMap :: UserData -> Affection () drawMap :: Affection UserData ()
drawMap ud = do drawMap = do
sData <- liftIO $ readMVar (stateData ud) ud <- getAffection
wState <- liftIO $ readMVar (worldState ud)
let ctx = nano ud let ctx = nano ud
case sData of case stateData ud 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 wState $ do (_, dat) <- yieldSystemT (worldState ud) $ do
efor allEnts $ do efor allEnts $ do
with pos with pos
pos' <- query pos pos' <- query pos
player' <- queryMaybe player player <- queryMaybe player
stat <- queryMaybe anim stat <- queryMaybe anim
mbnds <- queryMaybe obstacle mbnds <- queryMaybe obstacle
t <- queryMaybe objType t <- queryMaybe objType
@ -483,7 +535,7 @@ drawMap ud = do
pa <- queryMaybe objPlayerActivated pa <- queryMaybe objPlayerActivated
ttl <- queryMaybe objStateTime ttl <- queryMaybe objStateTime
let maxt = fromMaybe 1 (actionTime <$> t <*> s) let maxt = fromMaybe 1 (actionTime <$> t <*> s)
first = if isJust player' first = if isJust player
then Just then Just
pos' pos'
else Nothing else Nothing
@ -512,10 +564,10 @@ drawMap ud = do
([], [], []) ([], [], [])
dat dat
V2 pr pc = playerPos V2 pr pc = playerPos
MainData _ _ _ _ gr = sData MainData _ _ _ _ gr = stateData ud
seekGraph = V.foldl V.snoc (Types.connects (V.head gr)) (V.tail gr) seekGraph = Types.connects (head gr) ++ tail gr
room = V.filter (inBounds (fmap floor playerPos) . bounds) seekGraph room = Prelude.filter (inBounds (fmap floor playerPos) . bounds) seekGraph
mat = imgMat sData mat = imgMat (stateData ud)
cols = fromIntegral (ncols mat) cols = fromIntegral (ncols mat)
rows = fromIntegral (nrows mat) rows = fromIntegral (nrows mat)
tileWidth = 64 :: Double tileWidth = 64 :: Double
@ -523,8 +575,8 @@ drawMap ud = 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 sData) (nrows $ mapMat $ stateData ud)
(ncols $ mapMat sData) (ncols $ mapMat $ stateData ud)
((reverse . fst) ((reverse . fst)
(Prelude.foldl (Prelude.foldl
(\(done, proc) coord -> (\(done, proc) coord ->
@ -533,8 +585,8 @@ drawMap ud = do
) )
([], posanims) ([], posanims)
((,) ((,)
<$> [1 .. (nrows $ mapMat sData)] <$> [1 .. (nrows $ mapMat $ stateData ud)]
<*> [1 .. (ncols $ mapMat sData)] <*> [1 .. (ncols $ mapMat $ stateData ud)]
) )
) )
) )
@ -563,37 +615,15 @@ drawMap ud = do
closePath ctx closePath ctx
fillColor ctx (rgb 255 255 255) fillColor ctx (rgb 255 255 255)
fill ctx fill ctx
let coordList = concatMap -- void $ sequence $ parMap rpar
(\(i, ls) -> Prelude.map mapM_
(\(j, t) -> ((i, j), t)) (\(i, ls) ->
(reverse $ zip [1..] ls) -- void $ sequence $ parMap rpar
) mapM_
(zip [1..] (toLists mat)) (\(j, t) -> drawTile ud ctx (partposanims M.! (i, j)) pr pc i j t)
filterList = Prelude.filter (reverse $ zip [1..] ls)
(\((frow, fcol), _) ->
((realToFrac (sx frow fcol) > -tileWidth &&
realToFrac (sy frow fcol) > -tileHeight) &&
((realToFrac (sx frow fcol) :: Double) < 1280 &&
(realToFrac ((sy frow fcol)- (74 - (realToFrac tileHeight :: CFloat))) :: Double) < 720))
)
coordList
!posanimList = Prelude.map
(\((row, col), tile) -> ((row, col), tile, partposanims M.! (row, col)))
filterList
sx row col = realToFrac $ 640 + ((fromIntegral col - pc) +
(fromIntegral row - pr)) * (tileWidth / 2) :: CFloat
sy row col = realToFrac $ 360 - (tileHeight / 2) + ((fromIntegral row - pr) -
(fromIntegral col - pc)) * (tileHeight / 2) :: CFloat
void $ sequence $ parMap rpar
-- mapM_
(\((row, col), tile, posanim) ->
drawTile ud ctx posanim pr pc row col tile
) )
posanimList (zip [1..] (toLists mat))
-- void $ sequence $ parMap rpar (\(i, ls) -> void $ sequence $ parMap rpar
-- (\(j, t) -> drawTile ud ctx (partposanims M.! (i, j)) pr pc i j t)
-- (reverse $ zip [1..] ls))
-- (zip [1..] (toLists mat))
mapM_ (\(V2 sr sc, pa, perc) -> when pa $ do mapM_ (\(V2 sr sc, pa, perc) -> when pa $ do
let lx = realToFrac $ 640 + ((sc - pc) + let lx = realToFrac $ 640 + ((sc - pc) +
(sr - pr)) * (tileWidth / 2) :: CFloat (sr - pr)) * (tileWidth / 2) :: CFloat
@ -612,20 +642,15 @@ drawMap ud = do
closePath ctx closePath ctx
) posActions ) posActions
fontSize ctx 20 fontSize ctx 20
aFonts <- readMVar (assetFonts ud) fontFace ctx (assetFonts ud Map.! FontBedstead)
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) <> if not (Prelude.null room) then T.pack (show $ clearance $ head room) else "0"
then T.pack (show $ clearance $ V.head room)
else "0"
) )
-- <> "\nFor answers call 6350"
)
drawTile drawTile
:: UserData :: UserData
@ -637,23 +662,25 @@ drawTile
-> Int -> Int
-> Maybe ImgId -> Maybe ImgId
-> IO () -> IO ()
drawTile ud ctx posanims pr pc row col img = do drawTile ud ctx posanims pr pc row col img =
let (bef, beh) = L.partition delimiter sorted when ((realToFrac x > -tileWidth && realToFrac y > -tileHeight) &&
aImages <- readMVar (assetImages ud) ((realToFrac x :: Double) < 1280 &&
save ctx (realToFrac (y - (74 - (realToFrac tileHeight :: CFloat))) :: Double) < 720)) $
mapM_ (flip drawAnim fact) beh do
maybe (return ()) (Types.draw ud x (y - 42) 64 74 let (bef, beh) = L.partition delimiter sorted
(if fromMaybe False (isWall <$> img) then fact else 1)) save ctx
((aImages Map.!) <$> case img of mapM_ drawAnim beh
Just ImgEmpty -> Nothing maybe (return ()) (draw ud x (y - 42) 64 74 fact)
_ -> img ((assetImages ud Map.!) <$> case img of
) Just ImgEmpty -> Nothing
mapM_ (flip drawAnim fact) bef _ -> img
restore ctx )
-- when (floor pr == row && floor pc == col) $ do mapM_ drawAnim bef
-- A.logIO A.Debug ("sorted: " ++ show sorted) restore ctx
-- A.logIO A.Debug ("beh: " ++ show beh) -- when (floor pr == row && floor pc == col) $ do
-- A.logIO A.Debug ("bef: " ++ show bef) -- A.logIO A.Debug ("sorted: " ++ show sorted)
-- A.logIO A.Debug ("beh: " ++ show beh)
-- 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) ||
@ -677,8 +704,7 @@ drawTile ud ctx posanims pr pc row col img = do
tileWidth = 64 :: Double tileWidth = 64 :: Double
tileHeight = 32 :: Double tileHeight = 32 :: Double
sorted = sortOn (\(V2 sr sc, _, mbnds) -> sorted = sortOn (\(V2 sr sc, _, mbnds) ->
let comp srow scol = let comp srow scol = (floor $ (1 - scol) * 100) + (floor $ srow * 100)
((floor $ (1 - scol) * 100) :: Int) + ((floor $ srow * 100) :: Int)
in in
case mbnds of case mbnds of
Just (Boundaries (minr, minc) (maxr, maxc)) -> Just (Boundaries (minr, minc) (maxr, maxc)) ->
@ -699,38 +725,38 @@ drawTile ud ctx posanims pr pc row col img = do
dist = distance (V2 (fromIntegral row) (fromIntegral col)) dist = distance (V2 (fromIntegral row) (fromIntegral col))
(V2 (realToFrac pr - 1) (realToFrac pc)) / 4 (V2 (realToFrac pr - 1) (realToFrac pc)) / 4
fact = fact =
if pr <= fromIntegral row + (if L.null maxrs then 0.5 else minimum maxrs) && if isWall (fromJust img) &&
pc >= fromIntegral col + (if L.null mincs then 0.5 else maximum mincs) (pr <= fromIntegral row + minimum maxrs &&
pc >= fromIntegral col + maximum mincs)
then min 1 dist then min 1 dist
else 1 else 1
mb = maybe [] collisionObstacle img mb = maybe [] collisionObstacle img
drawAnim (V2 nr nc, as, _) factor = do drawAnim (V2 nr nc, as, _) = 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
Types.draw ud ax ay 64 74 (if isWallLike (aiVariation $ asId as) then factor else 1) as draw ud ax ay 64 74 1 as
updateMap :: UserData -> Double -> Affection () updateMap :: Double -> Affection UserData ()
updateMap ud dt = do updateMap dt = do
osData <- liftIO $ readMVar (stateData ud) ud <- getAffection
if osData == None if stateData ud == 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
void $ liftIO $ swapMVar (worldState ud) nws putAffection ud
void $ liftIO $ swapMVar (stateData ud) mendat { worldState = nws
void $ liftIO $ swapMVar (state ud) (Main WorldMap) , stateData = mendat
updateMap ud 0.1 , state = Main WorldMap
updateMap ud 0.1 }
updateMap ud 0.1 updateMap 0.1
updateMap ud 19 updateMap 0.1
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
wState <- liftIO $ readMVar (worldState ud) (nws, _) <- yieldSystemT (worldState ud) $ do
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
@ -740,12 +766,11 @@ updateMap ud dt = do
emap allEnts $ do emap allEnts $ do
pos'@(V2 pr pc) <- query pos pos'@(V2 pr pc) <- query pos
vel' <- queryMaybe vel vel' <- queryMaybe vel
rot' <- fromMaybe N <$> queryMaybe rot rot' <- query rot
fact' <- fromMaybe 1 <$> queryMaybe velFact fact' <- fromMaybe 1 <$> queryMaybe velFact
xyv2 <- queryMaybe xyvel xyv2 <- queryMaybe xyvel
stat <- query anim stat <- query anim
let an = aAnim Map.! asId stat let an = assetAnimations ud 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'
@ -762,16 +787,16 @@ updateMap ud 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 (fromString $ show ret) ret) in A.log A.Verbose (show ret) ret)
(V2 1 1) (V2 1 1)
( (
nub $ concatMap concatMap
(\(dr, dc) -> (\(dr, dc) ->
let bs = (++) let bs = (++)
(fromMaybe [] $ collisionObstacle <$> M.unsafeGet (maybe [] collisionObstacle (fromMaybe Nothing $ M.safeGet
(min (nrows mat) $ max 1 $ fromIntegral $ floor pr + dr) (fromIntegral $ floor pr + dr)
(min (ncols mat) $ max 1 $ fromIntegral $ floor pc + dc) (fromIntegral $ floor pc + dc)
(imgMat sData)) (imgMat (stateData ud))))
(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 &&
@ -846,7 +871,7 @@ updateMap ud dt = do
{ aiDirection = fromMaybe rot' (direction velo) { aiDirection = fromMaybe rot' (direction velo)
} }
} }
_ -> nstat x -> nstat
ent = unchanged ent = unchanged
{ pos = Set $ pos' + colldpos { pos = Set $ pos' + colldpos
, rot = Set $ fromMaybe rot' (direction (fromMaybe (V2 0 0) vel')) , rot = Set $ fromMaybe rot' (direction (fromMaybe (V2 0 0) vel'))
@ -860,16 +885,16 @@ updateMap ud dt = do
Nothing -> Keep Nothing -> Keep
} }
return ent return ent
-- allRelEnts <- efor allEnts $ do allRelEnts <- efor allEnts $ do
-- with pos with pos
-- with rot with rot
-- with clearanceLvl with clearanceLvl
-- without objType without objType
-- pos' <- query pos pos' <- query pos
-- rot' <- query rot rot' <- query rot
-- clvl <- query clearanceLvl clvl <- query clearanceLvl
-- entn <- queryEnt entn <- queryEnt
-- return (entn, pos', rot', clvl) return (entn, pos', rot', clvl)
tses <- efor allEnts $ do tses <- efor allEnts $ do
with objType with objType
with objState with objState
@ -878,15 +903,16 @@ updateMap ud dt = do
e <- queryEnt e <- queryEnt
return (t, s, e) return (t, s, e)
mapM_ (\(t, s, e) -> mapM_ (\(t, s, e) ->
objectAction dt t s e objectAction allRelEnts dt t s e
) tses ) tses
(nws2, _) <- yieldSystemT nws $ updateNPCs (nws2, _) <- yieldSystemT nws $ updateNPCs
(imgMat sData) (imgMat $ stateData ud)
(mapMat sData)
nws nws
(V.filter (Prelude.filter
(\p -> pointType p /= RoomExit) (\p -> pointType p /= RoomExit)
(reachPoints sData) (reachPoints $ stateData ud)
) )
dt dt
void $ liftIO $ swapMVar (worldState ud) nws2 putAffection ud
{ worldState = nws2
}

133
src/Menu/Adjust.hs
View file

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

252
src/Menu/Connect.hs
View file

@ -10,9 +10,7 @@ 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.String import Data.Maybe (isNothing, isJust)
import Control.Concurrent.MVar
import Control.Monad import Control.Monad
@ -23,94 +21,108 @@ import Util
import Menu.Adjust import Menu.Adjust
import MainGame.WorldMap import MainGame.WorldMap
loadMenu :: UserData -> Affection () loadMenu :: Affection UserData ()
loadMenu ud = do loadMenu = 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 ud) uu1 <- partSubscribe j joystickConnect
uu2 <- partSubscribe j (joystickDisconnect ud) uu2 <- partSubscribe j joystickDisconnect
uu3 <- partSubscribe j (emitJoyActionMessage ud) uu3 <- partSubscribe j emitJoyActionMessage
uu4 <- partSubscribe k (emitKbdActionMessage ud) uu4 <- partSubscribe k emitKbdActionMessage
uu5 <- partSubscribe t (handleActionMessages ud) uu5 <- partSubscribe t handleActionMessages
uu6 <- partSubscribe m (handleClicks ud) uu6 <- partSubscribe m handleClicks
-- uu6 <- partSubscribe k emitKbdActionMessage -- uu6 <- partSubscribe k emitKbdActionMessage
juuid <- liftIO $ readMVar (joyUUID ud) partUnSubscribe j (joyUUID ud)
partUnSubscribe j juuid putAffection ud
cache <- liftIO $ readMVar (joyCache ud) { uuid = [ uu1, uu2, uu3, uu4, uu5, uu6 ]
void $ liftIO $ swapMVar (uuid ud) [ uu1, uu2, uu3, uu4, uu5, uu6 ] , state = Menu Connect
void $ liftIO $ swapMVar (state ud) (Menu Connect) , stateData = MenuData (V2 0 0) S 0 0
void $ liftIO $ swapMVar (stateData ud) (MenuData (V2 0 0) S 0 0) , joyCache = []
void $ liftIO $ swapMVar (joyCache ud) [] }
mapM_ (partEmit j) cache mapM_ (partEmit j) (joyCache ud)
joystickConnect :: UserData -> JoystickMessage -> Affection () joystickConnect :: JoystickMessage -> Affection UserData ()
joystickConnect ud msg = do joystickConnect msg = do
ctrls <- liftIO $ readMVar (controls ud) ud <- getAffection
when (ctrls == NoController) $ do when (controls ud == 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: " <> fromString (show (ident :: Int)) liftIO $ logIO A.Debug $ "Joystick connected: " ++ show ident
void $ liftIO $ swapMVar (controls ud) (Joystick joy) putAffection ud
void $ liftIO $ swapMVar (translation ud) (JoyTranslation defaultJoyTranslation) { controls = Joystick joy
, translation = JoyTranslation defaultJoyTranslation
}
) mjoy ) mjoy
joystickDisconnect :: UserData -> JoystickMessage -> Affection () joystickDisconnect :: JoystickMessage -> Affection UserData ()
joystickDisconnect ud msg = do joystickDisconnect msg = do
ctrls <- liftIO $ readMVar (controls ud) ud <- getAffection
case ctrls of case controls ud 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"
void $ liftIO $ swapMVar (controls ud) NoController putAffection ud
void $ liftIO $ swapMVar (translation ud) NoTranslation { controls = NoController
, translation = NoTranslation
}
_ -> return () _ -> return ()
handleActionMessages :: UserData -> ActionMessage -> Affection () handleActionMessages :: ActionMessage -> Affection UserData ()
handleActionMessages ud (ActionMessage ActActivate _) = do handleActionMessages (ActionMessage ActActivate _) = do
liftIO $ modifyMVar_ (stateData ud) (\dat -> return dat ud <- getAffection
{ activate = 0.5 putAffection ud
{ stateData = (stateData ud)
{ activate = 0.5
}
} }
) handleActionMessages (ActionMessage ActSwitchMap _) = do
handleActionMessages ud (ActionMessage ActSwitchMap _) = do ud <- getAffection
liftIO $ modifyMVar_ (stateData ud) (\dat -> return dat putAffection ud
{ switchMap = 0.5 { stateData = (stateData ud)
{ switchMap = 0.5
}
} }
) handleActionMessages (ActionMessage (ActUp f) _) = do
handleActionMessages ud (ActionMessage (ActUp f) _) = do ud <- getAffection
liftIO $ modifyMVar_ (stateData ud) (\dat -> let V2 vx _ = velocity $ stateData ud
let V2 vx _ = velocity dat putAffection ud
in return dat { stateData = (stateData ud)
{ velocity = (V2 vx (-f)) { velocity = (V2 vx (-f))
} }
) }
handleActionMessages ud (ActionMessage (ActDown f) _) = do handleActionMessages (ActionMessage (ActDown f) _) = do
liftIO $ modifyMVar_ (stateData ud) (\dat -> ud <- getAffection
let V2 vx _ = velocity dat let V2 vx _ = velocity $ stateData ud
in return dat putAffection ud
{ stateData = (stateData ud)
{ velocity = (V2 vx f) { velocity = (V2 vx f)
} }
) }
handleActionMessages ud (ActionMessage (ActLeft f) _) = do handleActionMessages (ActionMessage (ActLeft f) _) = do
liftIO $ modifyMVar_ (stateData ud) (\dat -> ud <- getAffection
let V2 _ vy = velocity dat let V2 _ vy = velocity $ stateData ud
in return dat putAffection ud
{ stateData = (stateData ud)
{ velocity = (V2 (-f) vy) { velocity = (V2 (-f) vy)
} }
) }
handleActionMessages ud (ActionMessage (ActRight f) _) = do handleActionMessages (ActionMessage (ActRight f) _) = do
liftIO $ modifyMVar_ (stateData ud) (\dat -> ud <- getAffection
let V2 _ vy = velocity dat let V2 _ vy = velocity $ stateData ud
in return dat putAffection ud
{ stateData = (stateData ud)
{ velocity = (V2 f vy) { velocity = (V2 f vy)
} }
) }
handleClicks :: UserData -> MouseMessage -> Affection () handleClicks :: MouseMessage -> Affection UserData ()
handleClicks ud (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft 1 cpos) = do handleClicks (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft 1 pos@(V2 px py)) = do
rels <- liftIO $ fmap ((/ 2) . (+ 1)) <$> (relativizeMouseCoords cpos) ud <- getAffection
ctrls <- liftIO $ readMVar (controls ud) rels@(V2 rx ry) <- liftIO $ fmap ((/ 2) . (+ 1)) <$> (relativizeMouseCoords pos)
case ctrls of case controls ud of
Joystick _ -> do Joystick _ -> do
when (arrowUp rels) adjustKbdUp when (arrowUp rels) adjustKbdUp
when (arrowDown rels) adjustKbdDown when (arrowDown rels) adjustKbdDown
@ -120,36 +132,40 @@ handleClicks ud (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft 1 cpos) = do
when (buttonSwitchMap rels) adjustKbdSwitchMap when (buttonSwitchMap rels) adjustKbdSwitchMap
when (buttonPlay rels) enterGame when (buttonPlay rels) enterGame
NoController -> do NoController -> do
when (kbdIcon rels) $ do when (kbdIcon rels) $
void $ liftIO $ swapMVar (controls ud) Keyboard putAffection ud
void $ liftIO $ swapMVar (translation ud) (KbdTranslation defaultKbdTranslation) { controls = Keyboard
, translation = KbdTranslation defaultKbdTranslation
}
Keyboard -> do Keyboard -> do
when (kbdIcon rels) $ do when (kbdIcon rels) $
void $ liftIO $ swapMVar (controls ud) NoController putAffection ud
void $ liftIO $ swapMVar (translation ud) NoTranslation { controls = NoController
, translation = NoTranslation
}
when (buttonPlay rels) enterGame when (buttonPlay rels) enterGame
where where
adjustKbdUp = do adjustKbdUp = do
fullClean ud fullClean
loadAdjust ud (ActUp 1) Keyboard (loadMenu ud) loadAdjust (ActUp 1) Keyboard loadMenu
adjustKbdDown = do adjustKbdDown = do
fullClean ud fullClean
loadAdjust ud (ActDown 1) Keyboard (loadMenu ud) loadAdjust (ActDown 1) Keyboard loadMenu
adjustKbdLeft = do adjustKbdLeft = do
fullClean ud fullClean
loadAdjust ud (ActLeft 1) Keyboard (loadMenu ud) loadAdjust (ActLeft 1) Keyboard loadMenu
adjustKbdRight = do adjustKbdRight = do
fullClean ud fullClean
loadAdjust ud (ActRight 1) Keyboard (loadMenu ud) loadAdjust (ActRight 1) Keyboard loadMenu
adjustKbdActivate = do adjustKbdActivate = do
fullClean ud fullClean
loadAdjust ud ActActivate Keyboard (loadMenu ud) loadAdjust ActActivate Keyboard loadMenu
adjustKbdSwitchMap = do adjustKbdSwitchMap = do
fullClean ud fullClean
loadAdjust ud ActSwitchMap Keyboard (loadMenu ud) loadAdjust ActSwitchMap Keyboard loadMenu
enterGame = do enterGame = do
fullClean ud fullClean
loadMap ud loadMap
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) =
@ -166,35 +182,33 @@ handleClicks ud (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft 1 cpos) = do
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 :: UserData -> Double -> Affection () updateMenu :: Double -> Affection UserData ()
updateMenu ud dt = do updateMenu dt = do
sData <- liftIO $ readMVar (stateData ud) ud <- getAffection
case sData of case stateData ud of
MenuData _ _ _ _ -> MenuData _ _ _ _ ->
void $ liftIO $ swapMVar (stateData ud) ( putAffection ud
MenuData { stateData = MenuData
(velocity sData) (velocity $ stateData ud)
(rotation sData) (rotation $ stateData ud)
(max 0 ((activate sData) - dt)) (max 0 ((activate $ stateData ud) - dt))
(max 0 ((switchMap sData) - dt)) (max 0 ((switchMap $ stateData ud) - dt))
) }
_ -> return () _ -> return ()
drawMenu :: UserData -> Affection () drawMenu :: Affection UserData ()
drawMenu ud = do drawMenu = do
sData <- liftIO $ readMVar (stateData ud) ud <- getAffection
curState <- liftIO $ readMVar (state ud) case stateData ud of
aIcons <- liftIO $ readMVar (assetIcons ud)
case sData of
MenuData _ _ _ _ -> MenuData _ _ _ _ ->
liftIO $ do liftIO $ do
let ctx = nano ud let ctx = nano ud
controller <- readMVar (controls ud) controller = controls ud
save ctx save ctx
beginPath ctx beginPath ctx
cpaint <- imagePattern ctx 550 620 80 80 0 (aIcons M.! cpaint <- imagePattern ctx 550 620 80 80 0 (assetIcons ud M.!
case controller of case controller of
Joystick _ -> IconContrGreen Joystick _ -> IconContrGreen
_ -> IconContrBlue _ -> IconContrBlue
@ -204,17 +218,17 @@ drawMenu ud = do
closePath ctx closePath ctx
fill ctx fill ctx
beginPath ctx beginPath ctx
cpaint2 <- imagePattern ctx 650 620 80 80 0 (aIcons M.! cpaint <- imagePattern ctx 650 620 80 80 0 (assetIcons ud 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 cpaint2 fillPaint ctx cpaint
closePath ctx closePath ctx
fill ctx fill ctx
when (controller /= NoController) $ do when (controller /= NoController) $ do
let V2 vx vy = velocity sData let V2 vx vy = velocity $ stateData ud
beginPath ctx beginPath ctx
roundedRect ctx 140 110 1000 500 25 roundedRect ctx 140 110 1000 500 25
strokeWidth ctx 5 strokeWidth ctx 5
@ -225,7 +239,7 @@ drawMenu ud = 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 = fmap (fromIntegral . floor) $ rot@(V2 rx ry) = 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)
@ -239,7 +253,7 @@ drawMenu ud = do
roundedRect ctx 0 0 100 100 10 roundedRect ctx 0 0 100 100 10
closePath ctx closePath ctx
fill ctx fill ctx
case curState of case state ud 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)
@ -261,7 +275,7 @@ drawMenu ud = do
roundedRect ctx 0 0 100 100 10 roundedRect ctx 0 0 100 100 10
closePath ctx closePath ctx
fill ctx fill ctx
case curState of case state ud 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)
@ -283,7 +297,7 @@ drawMenu ud = do
roundedRect ctx 0 0 100 100 10 roundedRect ctx 0 0 100 100 10
closePath ctx closePath ctx
fill ctx fill ctx
case curState of case state ud 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)
@ -305,7 +319,7 @@ drawMenu ud = do
roundedRect ctx 0 0 100 100 10 roundedRect ctx 0 0 100 100 10
closePath ctx closePath ctx
fill ctx fill ctx
case curState of case state ud 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)
@ -321,20 +335,20 @@ drawMenu ud = do
_ -> _ ->
return () return ()
beginPath ctx beginPath ctx
apaint <- imagePattern ctx 0 0 100 100 0 (aIcons M.! IconArrow) 1 apaint <- imagePattern ctx 0 0 100 100 0 (assetIcons ud 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 sData > 0) $ do when (activate (stateData ud) > 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 curState of case state ud 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)
@ -353,13 +367,13 @@ drawMenu ud = 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 sData > 0) $ do when (switchMap (stateData ud) > 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 curState of case state ud 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)

284
src/NPC.hs
View file

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

2
src/Navigation.hs
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) import Data.Maybe (isJust, catMaybes)
-- internal imports -- internal imports

15
src/Object.hs
View file

@ -3,7 +3,14 @@
{-# 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
@ -14,13 +21,13 @@ import Object.Copier
import Object.Door import Object.Door
instance ObjectAction ObjType ObjState where instance ObjectAction ObjType ObjState where
objectAction dt t@ObjCopier s ent = copierObjectAction dt t s ent objectAction relEnts dt t@ObjCopier s ent = copierObjectAction relEnts dt t s ent
objectAction dt t@ObjComputer s ent = computerObjectAction dt t s ent objectAction relEnts dt t@ObjComputer s ent = computerObjectAction relEnts dt t s ent
objectAction dt t@ObjDoor s ent = doorObjectAction dt t s ent objectAction relEnts dt t@ObjDoor s ent = doorObjectAction relEnts dt t s ent
objectAction _ _ _ _ = return () objectAction _ _ _ _ _ = return ()
objectTransition t@ObjCopier s pa ent aent = objectTransition t@ObjCopier s pa ent aent =
copierObjectTransition t s pa ent aent copierObjectTransition t s pa ent aent

8
src/Object/ActionTime.hs
View file

@ -5,8 +5,6 @@ module Object.ActionTime where
import Affection as A import Affection as A
import Data.String
-- internal imports -- internal imports
import Types import Types
@ -16,9 +14,7 @@ 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 actionTime o s = A.log Error (show o ++ ": " ++ s ++ ": has not a time") 0
Error
(fromString (show o) <> ": " <> fromString s <> ": has not a time")
0

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

13
src/Object/Copier.hs
View file

@ -10,24 +10,27 @@ 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
:: (Monad m, MonadIO m, ActionTime ObjType ObjState) :: (Monad m, MonadIO m, ActionTime ObjType ObjState)
=> Double => [(Ent, V2 Double, Direction, Word)]
-> Double
-> ObjType -> ObjType
-> ObjState -> ObjState
-> Ent -> Ent
-> SystemT Entity m () -> SystemT Entity m ()
copierObjectAction dt t@ObjCopier s@"copying" ent = do copierObjectAction _ dt t@ObjCopier s@"copying" ent = do
emap (anEnt ent) $ do emap (anEnt ent) $ do
mtime <- queryMaybe objStateTime mtime <- queryMaybe objStateTime
case mtime of case mtime of
Nothing -> do Nothing -> do
liftIO $ logIO Verbose liftIO $ logIO Verbose ("Copier " ++ show ent ++ ": copying!")
("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"
@ -43,7 +46,7 @@ copierObjectAction dt t@ObjCopier s@"copying" ent = do
Just ttl -> return (ttl < 0) Just ttl -> return (ttl < 0)
when (head trans) (setEntity ent =<< copierObjectTransition t s False ent Nothing) when (head trans) (setEntity ent =<< copierObjectTransition t s False ent Nothing)
copierObjectAction _ _ _ _ = return () copierObjectAction _ _ _ _ _ = return ()
copierObjectTransition copierObjectTransition
:: (Eq a, IsString a, MonadIO m) :: (Eq a, IsString a, MonadIO m)

80
src/Object/Door.hs
View file

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

12
src/StateMachine.hs
View file

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

5
src/Types/Animation.hs
View file

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

6
src/Types/Drawable.hs
View file

@ -4,8 +4,6 @@ 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(..))
@ -32,7 +30,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
anims <- readMVar (assetAnimations us) let anims = assetAnimations us
let a = anims Map.! asId as 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

30
src/Types/Interior.hs
View file

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

6
src/Types/Map.hs
View file

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

4
src/Types/NPCState.hs
View file

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

10
src/Types/ObjClass.hs
View file

@ -5,18 +5,20 @@ 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
:: Double :: [(Ent, V2 Double, Direction, Word)]
-> Double
-> otype -> otype
-> ostate -> ostate
-> Ent -> Ent
-> SystemT Entity (AffectionState AffectionData ResIO) () -> SystemT Entity (AffectionState (AffectionData UserData) IO) ()
objectTransition objectTransition
:: otype :: otype
@ -24,7 +26,7 @@ class ObjectAction otype ostate where
-> Bool -> Bool
-> Ent -> Ent
-> Maybe Ent -> Maybe Ent
-> SystemT Entity (AffectionState AffectionData ResIO) (Entity 'SetterOf) -> SystemT Entity (AffectionState (AffectionData UserData) IO) (Entity 'SetterOf)
class ActionTime otype ostate where class ActionTime otype ostate where
actionTime :: otype -> ostate -> Double actionTime :: otype -> ostate -> Double

5
src/Types/StateData.hs
View file

@ -2,7 +2,6 @@ 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)
@ -24,9 +23,9 @@ data StateData
| MainData | MainData
{ mapMat :: Matrix TileState { mapMat :: Matrix TileState
, imgMat :: Matrix (Maybe ImgId) , imgMat :: Matrix (Maybe ImgId)
, reachPoints :: V.Vector ReachPoint , reachPoints :: [ReachPoint]
, mmImgMat :: Matrix (Maybe ImgId) , mmImgMat :: Matrix (Maybe ImgId)
, roomGraph :: V.Vector Graph , roomGraph :: [Graph]
} }
| MenuData | MenuData
{ velocity :: V2 Double { velocity :: V2 Double

84
src/Types/UserData.hs
View file

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

108
src/Util.hs
View file

@ -10,11 +10,8 @@ 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 import Control.Monad (join, when)
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)
@ -198,14 +195,14 @@ naviGraph imgmat animBounds (V2 r c) =
(\acc (rr, cc) -> (\acc (rr, cc) ->
if null if null
(maybe [] collisionObstacle (maybe [] collisionObstacle
(M.unsafeGet (r + rr) (c + cc) imgmat) (join $ M.safeGet (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
(M.unsafeGet (r + oor) (c + ooc) imgmat)) ++ (join $ M.safeGet (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))
@ -223,8 +220,7 @@ 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
fonts <- readMVar (assetFonts ud) fontFace ctx (assetFonts ud Map.! FontBedstead)
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
@ -245,7 +241,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 (fromString err) logIO Error err
exitFailure exitFailure
Right dimg -> do Right dimg -> do
let img = convertRGBA8 dimg let img = convertRGBA8 dimg
@ -257,17 +253,11 @@ loadAnimationSprites fp nvg idconfs = do
mresimgs <- mapM mresimgs <- mapM
(\cr -> (\cr ->
createImageMem nvg createImageMem nvg
(S.singleton ImagePremultiplied) (toStrict $ encodePng cr)) ImagePremultiplied (toStrict $ encodePng cr))
crs crs
imgs <- if any isNothing mresimgs imgs <- if any isNothing mresimgs
then do then do
logIO logIO Error ("failed to load: " ++ fp ++ " " ++ show i)
Error
("failed to load: " <>
fromString fp <>
" " <>
fromString (show i)
)
exitFailure exitFailure
else else
return $ catMaybes mresimgs return $ catMaybes mresimgs
@ -307,47 +297,48 @@ 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 :: UserData -> JoystickMessage -> Affection () cacheJoypad :: JoystickMessage -> Affection UserData ()
cacheJoypad ud msg = do cacheJoypad msg = do
joy <- liftIO $ readMVar (joyCache ud) ud <- getAffection
void $ liftIO $ swapMVar (joyCache ud) (msg : joy) putAffection ud
{ joyCache = msg : joyCache ud
}
emitJoyActionMessage :: UserData -> JoystickMessage -> Affection () emitJoyActionMessage :: JoystickMessage -> Affection UserData ()
emitJoyActionMessage ud message = do emitJoyActionMessage (MsgJoystickAxis time _ axis val) = do
trans <- liftIO $ readMVar (translation ud) ud <- getAffection
case message of case translation ud of
MsgJoystickAxis time _ axis val -> do JoyTranslation tmap -> 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
case trans of vnormal = fromIntegral val / 32768
JoyTranslation tmap -> do sigvnormal = abs vnormal
case tmap Map.!? (ButtonAction but SDL.JoyButtonPressed) of align
Just act -> partEmit t (ActionMessage act time) | signum vnormal >= 0 = AxisPositive
_ -> return () | signum vnormal < 0 = AxisNegative
_ -> return () 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 () _ -> 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 :: UserData -> KeyboardMessage -> Affection () emitKbdActionMessage :: KeyboardMessage -> Affection UserData ()
emitKbdActionMessage ud (MsgKeyboardEvent time _ press False sym) = do emitKbdActionMessage (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
trans <- liftIO $ readMVar (translation ud) case (translation ud) of
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)
@ -357,12 +348,13 @@ emitKbdActionMessage ud (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 :: UserData -> Affection () fullClean :: Affection UserData ()
fullClean ud = do fullClean = do
ud <- getAffection
let Subsystems w m k j t = subsystems ud let Subsystems w m k j t = subsystems ud
toClean <- liftIO $ readMVar $ uuid ud toClean = uuid ud
mapM_ (\u -> do mapM_ (\u -> do
partUnSubscribe w u partUnSubscribe w u
partUnSubscribe m u partUnSubscribe m u
@ -370,4 +362,6 @@ fullClean ud = do
partUnSubscribe j u partUnSubscribe j u
partUnSubscribe t u partUnSubscribe t u
) toClean ) toClean
void $ liftIO $ swapMVar (uuid ud) [] putAffection ud
{ uuid = []
}

4
tracer-game.cabal
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.10 , affection == 0.0.0.9
, sdl2 >= 2.4.0.0 , sdl2 >= 2.4.0.0
, OpenGL , OpenGL
, nanovg >= 0.6.0.0 , nanovg >= 0.6.0.0
@ -79,8 +79,6 @@ executable tracer-game
, algebraic-graphs , algebraic-graphs
, mtl , mtl
, parallel , parallel
, split
, resourcet
hs-source-dirs: src hs-source-dirs: src
ghc-options: -Wall -threaded ghc-options: -Wall -threaded
default-language: Haskell2010 default-language: Haskell2010