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:drawfilter
Branches Tags
nek0:master
nek0:make_affectionate
nek0:police
nek0:multiwin_compat
nek0:axe
nek0:parallel-ecstasy
nek0:drawfilter

No commits in common. "master" and "drawfilter" have entirely different histories.
master ... drawfilter

36 changed files with 1639 additions and 1607 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
dist/
dist-newstyle/
.direnv/
*.prof
*.aux
*.hp
@ -19,4 +18,3 @@ dist-newstyle/
*.eventlog
*.*~
.*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

3
cabal.project Normal file
View file

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

645
src/Floorplan.hs
View file

@ -6,8 +6,7 @@ import Data.Matrix (Matrix(..))
import qualified Data.Matrix as M
import qualified Data.Text as T
import Data.Maybe
import qualified Data.Vector as V
import Data.String
import Data.List (intersect)
import Linear (V2(..))
@ -26,7 +25,7 @@ buildHallFloorIO
:: FloorConfig
-> MVar (Float, T.Text)
-> Float
-> IO (Matrix TileState, V.Vector Graph)
-> IO (Matrix TileState, [Graph])
buildHallFloorIO fc progress increment = do
rand <- newStdGen
modifyMVar_ progress (return . (\(p, _) ->
@ -78,12 +77,8 @@ buildHallFloorIO fc progress increment = do
( p + increment
, "Assigned room clearances"
)))
A.logIO
A.Debug
("length accessGraph: " <> fromString (show $ length accessGraph))
A.logIO
A.Debug
("length doorgraph: " <> fromString (show $ length doorgraph))
A.logIO A.Debug ("length accessGraph: " ++ show (length accessGraph))
A.logIO A.Debug ("length doorgraph: " ++ show (length doorgraph))
return (facils, accessGraph)
emptyFloor :: FloorConfig -> Matrix TileState
@ -128,8 +123,10 @@ placeHalls rng fc input =
(fst (matmin b) + 10, fst (matmax b) - 10) agen
(col, g2) = randomR
(snd (matmin b) + 10, snd (matmax b) - 10) g1
-- (nw, g3) = randomR (2, wmax) g2
(nbs, nmat) = buildHall cross 3 b amat
in
-- if hallRatio nmat < 0.33 && wmax - 1 >= 2
if wmax - 1 >= 3 &&
all (\(Boundaries (minr, minc) (maxr, maxc)) ->
maxr - minr > 3 && maxc - minc > 3) nbs
@ -137,6 +134,10 @@ placeHalls rng fc input =
else (g2, nmat)
) (rand, mat) bs
boundSize :: Boundaries Int -> Int
boundSize (Boundaries mi ma) =
(fst ma - fst mi) * (snd ma - snd mi)
buildHall
:: (V2 Int)
-> Int
@ -178,106 +179,101 @@ hallRatio mat =
buildInnerWalls :: StdGen -> Matrix TileState -> (StdGen, Matrix TileState)
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)
(rng, input) (tups input)
floodSearchReplace
:: StdGen
-> (Int, Int)
-> Matrix TileState
-> (StdGen, Matrix TileState)
floodSearchReplace gn coord@(row, col) mat
| mat M.! coord == Unde =
let maxRow = doRow row
doRow r
| M.safeGet (r + 1) col mat == Just Unde = doRow (r + 1)
| otherwise = r
maxCol = doCol col
doCol c
| M.safeGet row (c + 1) mat == Just Unde = doCol (c + 1)
| otherwise = c
(cr, g1) = randomR
( if maxRow - 3 < row + 3
then (row + 2, row + 2)
else (row + 3, maxRow - 3)
) gn
(cc, g2) = randomR
( if maxCol - 3 < col + 3
then (col + 2, col + 2)
else (col + 3,maxCol - 3)
) g1
(nngen, nnmat) =
if (cr - 2 > row && cr + 2 < maxRow)
&& (cc - 2 > col && cc + 2 < maxCol)
then
doCross
g2
(cr, cc)
coord
(Boundaries coord (maxRow, maxCol))
mat
else
let btups = (,)
<$> [fst coord .. maxRow]
<*> [snd coord .. maxCol]
in
( g2
, foldl
(\acc coords ->
M.setElem (replaceTile (acc M.! coords) Offi) coords acc
) mat btups
)
in (nngen, nnmat)
| otherwise = (gn, mat)
doCross
:: RandomGen t
=> t
-> (Int, Int)
-> (Int, Int)
-> Boundaries Int
-> Matrix TileState
-> (t, Matrix TileState)
doCross gen cd@(xr, xc) coord@(row, col) b imat =
let nbs = map (uncurry Boundaries) bs
bs =
[ (matmin b, cd)
, ((fst (matmin b), col), (row, snd (matmax b)))
, ((row, snd (matmin b)), (fst (matmax b), col))
, (cd, matmax b)
]
(ngen, crosses) = foldl
(\(agen, acc) (minb, maxb) ->
let (fc, gg1) = randomR (fst minb, fst maxb) agen
(fr, gg2) = randomR (snd minb, snd maxb) gg1
in (gg2, acc ++ [(fc, fr)])
) (gen, []) bs
horz = M.mapRow (\icol cur ->
if icol >= snd (matmin b) && icol <= snd (matmax b)
then replaceTile cur Wall
else cur
) xr imat
vert = M.mapCol (\irow cur ->
if irow >= fst (matmin b) && irow <= fst (matmax b)
then replaceTile cur Wall
else cur
) xc horz
omat = foldl
(\acc coords ->
M.setElem (replaceTile (acc M.! coords) Offi) coords acc
) vert btups
btups = (,)
<$> [fst (matmin b) .. fst (matmax b)]
<*> [snd (matmin b) .. snd (matmax b)]
in if size b >= 16
then foldl
(\(agen, amat) (acr, nb) -> doCross agen acr coord nb amat)
(ngen, omat)
(zip crosses nbs)
else
(gen, omat)
closeOffices :: Matrix TileState -> Matrix TileState
closeOffices input =
let tups mat = (,) <$> [2 .. nrows mat - 1] <*> [2 .. ncols mat - 1]
@ -315,28 +311,26 @@ buildFacilities
-> Matrix TileState
-> (StdGen, Matrix TileState)
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 ->
let (numfac, ngen) = randomR (0 :: Int, 1 :: Int) agen
facil = if numfac == 1 then Kitc else Toil
in (ngen, facilFlood facil acc x)
in (ngen, flood facil acc x)
) (gen, input) nearests
facilFlood :: TileState -> Matrix TileState -> (Int, Int) -> Matrix TileState
facilFlood ts mat coords@(cr, cc) =
let cur = mat M.! coords
altered = M.setElem ts coords mat
in
if cur == ts || cur /= Offi
then mat
else foldl (facilFlood ts)
altered
[ (cr + 1, cc)
, (cr - 1, cc)
, (cr, cc + 1)
, (cr, cc - 1)
]
findNearestOffice
:: Matrix TileState
-> (V2 Int)
@ -352,119 +346,104 @@ findNearestOffice mat (V2 rrr ccc) =
else acc
) (fst $ head inlist) inlist
buildDoorsGraph :: Matrix TileState -> IO (V.Vector Graph)
buildDoorsGraph :: Matrix TileState -> IO [Graph]
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
weedOut vect = if V.null vect
then
return V.empty
else
case V.head vect of
hall@(GHall _) ->
(hall `V.cons`) <$> weedOut (V.tail vect)
g@(GRoom neighs _ _ _) -> do
let filtered = V.filter ((== Offi) . snd) neighs
rand <- randomRIO (0, length filtered -1) :: IO Int
let nneigh = filtered V.! rand `V.cons` V.empty
rest <- weedOut (V.tail vect)
return (g { neighbs = nneigh } `V.cons` rest)
weedOut (hall@(GHall _):gs) = (hall :) <$> weedOut gs
weedOut (g@(GRoom neighs _ _ _):gs) = do
let filtered = filter ((== Offi) . snd) neighs
rand <- randomRIO (0, length filtered -1) :: IO Int
let nneigh = filtered !! rand : []
rest <- weedOut gs
return (g { neighbs = nneigh } : rest)
weedOut [] = return []
buildGraph
:: Matrix TileState
-> Matrix TileState
-> V.Vector Graph
-> (Int, Int)
-> V.Vector Graph
buildGraph amat mat root coord@(br, bc)
| bc > ncols amat - 1 =
buildGraph amat mat root (br + 1, 1)
| br > nrows amat - 1 =
root
| M.safeGet br bc amat == Just Offi =
let roomcoords = flood amat [coord] coord
b = Boundaries
(minimum (map fst roomcoords), minimum (map snd roomcoords))
(maximum (map fst roomcoords), maximum (map snd roomcoords))
neighs = V.map (\(a, bx) -> (a, fromJust bx)) (V.filter ((/=Nothing) . snd)
$ V.fromList
[ (North, M.safeGet (fst (matmin b) - 2) (snd (matmin b)) amat)
, (South, M.safeGet (fst (matmax b) + 2) (snd (matmin b)) amat)
, (West, M.safeGet (fst (matmin b)) (snd (matmin b) - 2) amat)
, (East, M.safeGet (fst (matmin b)) (snd (matmax b) + 2) amat)
])
in
if Hall `V.elem` V.map snd neighs
then
let nroot =
if GRoom neighs b 0 Offi `V.notElem` connects (V.head root)
then
GHall
{ connects = connects (V.head root) `V.snoc`
GRoom neighs b 0 Offi
} `V.cons` V.tail root
else root
in buildGraph amat mat nroot (br, 1 + snd (matmax b))
else
let nroot = if GRoom neighs b 0 Offi `V.elem` root
then root
else root `V.snoc` GRoom neighs b 0 Offi
in buildGraph amat mat nroot (br, 1 + snd (matmax b))
| otherwise =
buildGraph amat mat root (br, maxCol br (bc + 1))
where
maxCol r c
| M.safeGet r (c + 1) mat == Just Offi = maxCol r (c + 1)
| otherwise = c
flood :: Matrix TileState -> [(Int, Int)] -> (Int, Int) -> [(Int,Int)]
flood amat acc (fr, fc) =
let ncoords = [] ++
(if (fr + 1, fc) `notElem` acc &&
M.safeGet (fr + 1) fc amat == Just Offi
then [(fr + 1, fc)]
else []) ++
(if (fr - 1, fc) `notElem` acc &&
M.safeGet (fr - 1) fc amat == Just Offi
then [(fr - 1, fc)]
else []) ++
(if (fr, fc - 1) `notElem` acc &&
M.safeGet fr (fc - 1) amat == Just Offi
then [(fr, fc - 1)]
else []) ++
(if (fr, fc + 1) `notElem` acc &&
M.safeGet fr (fc + 1) amat == Just Offi
then [(fr, fc + 1)]
else [])
in foldl (flood amat) (acc ++ ncoords) ncoords
assignClearance :: V.Vector Graph -> M.Matrix TileState -> IO (V.Vector Graph)
assignClearance :: [Graph] -> M.Matrix TileState -> IO [Graph]
assignClearance graph imat =
V.foldM doAssignClearance V.empty graph
foldM doAssignClearance [] graph
where
doAssignClearance acc (GHall conns) = do
ret <- GHall <$> V.foldM (\facc a -> do
res <- reassign True facc a
return (facc `V.snoc` res)
) V.empty conns
return (ret `V.cons` acc)
ret <- GHall <$> foldM (\acc a -> do
res <- reassign True acc a
return (acc ++ [res])
) [] conns
return (ret : acc)
doAssignClearance acc room = do
ret <- reassign False acc room
return (acc `V.snoc` ret)
reassign :: Bool -> V.Vector Graph -> Graph -> IO Graph
reassign p acc room@(GRoom ns b _ _) =
return (acc ++ [ret])
reassign :: Bool -> [Graph] -> Graph -> IO Graph
reassign p acc room@(GRoom ns b c t) =
if p
then do
if actualRoomType b imat == Offi
then do
let neigh = V.filter (all ((/= Hall) . snd) . neighbs) $
V.fromList $ catMaybes $ V.toList $
(V.map
(\n -> findNeighbor n b onlyrooms)
let neigh = filter (all ((/= Hall) . snd) . neighbs) $
catMaybes
(map
(\n -> findNeighbor n b imat onlyrooms)
nonhalls
)
onlyrooms = V.tail graph
onlyrooms = tail graph
nonhalls = ns -- filter ((/= Hall) . snd) ns
if not (null neigh) && any ((Offi /=) . flip actualRoomType imat . bounds) neigh
then
@ -477,22 +456,19 @@ assignClearance graph imat =
if actualRoomType b imat == Offi
then do
let neigh =
V.fromList $ catMaybes $ V.toList $
(V.map
(\n -> findNeighbor n b onlyrooms)
catMaybes
(map
(\n -> findNeighbor n b imat onlyrooms)
nonhalls
)
onlyrooms = connects (V.head acc)
onlyrooms = connects (head acc)
nonhalls = ns -- filter ((/= Hall) . snd) ns
ret <- if null neigh
then doRandomAssign room
else doBoundedAssign room (clearance $ V.head neigh)
else doBoundedAssign room (clearance $ head neigh)
return ret
else
return room
reassign _ _ (GHall _) = do
logIO A.Error "cannot reassign Hallways!"
error "*dies*"
actualRoomType :: Boundaries Int -> M.Matrix TileState -> TileState
actualRoomType (Boundaries (minrow, mincol) (maxrow, maxcol)) imat =
@ -514,12 +490,8 @@ doBoundedAssign g b = do
{ clearance = c
}
findNeighbor
:: (GraphDirection, TileState)
-> Boundaries Int
-> V.Vector Graph
-> Maybe Graph
findNeighbor (dir, _) bnds ingraph
findNeighbor :: (GraphDirection, TileState) -> Boundaries Int -> M.Matrix TileState -> [Graph] -> Maybe Graph
findNeighbor (dir, _) bnds imat ingraph
| dir == North =
let row = fst (matmin bnds) - 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
in postprocess row col
where
neighTile row col = imat M.! (row, col)
postprocess row col =
let filtered = V.filter
let filtered = filter
(inBounds (V2 row col) . bounds)
ingraph
in
if V.null filtered
then Nothing
else if V.length filtered == 1
then
case V.head filtered of
a@(GRoom _ _ _ _) -> Just a
_ -> error "findNeighbor: Not a GRoom result"
else
error "findNeighbor: Non-Singleton filter result"
findNeighbor (_, _) _ _ =
A.log A.Error "*confused from indirection*" (error "*dies*")
case filtered of
[a@(GRoom _ _ _ ts)] -> Just a
-- if ts == neighTile row col
-- then Just a
-- else error "findNeighbor: Query Result does not match"
[] -> Nothing
_ -> error "findNeighbor: Non-singleton filter result"
buildDoors :: Matrix TileState -> V.Vector Graph -> IO (Matrix TileState)
buildDoors = V.foldM placeDoors
placeDoors :: Matrix TileState -> Graph -> IO (Matrix TileState)
placeDoors amat (GHall conns) =
foldM placeDoors amat conns
placeDoors amat (GRoom neighs bs _ _) =
if Hall `V.elem` V.map snd neighs
then do
let halls = V.filter ((== Hall) . snd) neighs
idx <- randomRIO (0, length halls - 1)
let (dir, _) = halls V.! idx
case dir of
North ->
inRow
amat
(fst (matmin bs) - 1)
(snd (matmin bs), snd (matmax bs))
South ->
inRow
amat
(fst (matmax bs) + 1)
(snd (matmin bs), snd (matmax bs))
West ->
inCol
amat
(fst (matmin bs), fst (matmax bs))
(snd (matmin bs) - 1)
East ->
inCol
amat
(fst (matmin bs), fst (matmax bs))
(snd (matmax bs) + 1)
else do
idx <- randomRIO (0, length neighs - 1)
let (dir, _) = neighs V.! idx
case dir of
North ->
inRow
amat
(fst (matmin bs) - 1)
(snd (matmin bs), snd (matmax bs))
South ->
inRow
amat
(fst (matmax bs) + 1)
(snd (matmin bs), snd (matmax bs))
West ->
inCol
amat
(fst (matmin bs), fst (matmax bs))
(snd (matmin bs) - 1)
East ->
inCol
amat
(fst (matmin bs), fst (matmax bs))
(snd (matmax bs) + 1)
inRow :: Matrix TileState -> Int -> (Int, Int) -> IO (Matrix TileState)
inRow mat row cols = do
col <- randomRIO cols
let tile = mat M.! (row, col)
if tile == Wall
&& length (filter
(== Wall)
(M.toList (M.submatrix (row - 1) (row + 1) col col mat)))
== 1
then
if Door `elem` M.toList (uncurry (M.submatrix row row) cols mat)
then return mat
else
return $ M.setElem Door (row, col) mat
else
inRow mat row cols
inCol :: Matrix TileState -> (Int, Int) -> Int -> IO (Matrix TileState)
inCol mat rows col = do
row <- randomRIO rows
let tile = mat M.! (row, col)
if tile == Wall
&& length (filter
(== Wall)
(M.toList (M.submatrix row row (col - 1) (col + 1) mat)))
== 1
then
if Door `elem` M.toList (uncurry M.submatrix rows col col mat)
then return mat
else
return $ M.setElem Door (row, col) mat
else
inCol mat rows col
buildDoors :: Matrix TileState -> [Graph] -> IO (Matrix TileState)
buildDoors = foldM placeDoors
where
placeDoors :: Matrix TileState -> Graph -> IO (Matrix TileState)
placeDoors amat (GHall conns) =
foldM placeDoors amat conns
placeDoors amat (GRoom neighs bs _ _) =
if Hall `elem` map snd neighs
then do
let halls = filter ((== Hall) . snd) neighs
idx <- randomRIO (0, length halls - 1)
let (dir, _) = halls !! idx
case dir of
North ->
inRow
amat
(fst (matmin bs) - 1)
(snd (matmin bs), snd (matmax bs))
South ->
inRow
amat
(fst (matmax bs) + 1)
(snd (matmin bs), snd (matmax bs))
West ->
inCol
amat
(fst (matmin bs), fst (matmax bs))
(snd (matmin bs) - 1)
East ->
inCol
amat
(fst (matmin bs), fst (matmax bs))
(snd (matmax bs) + 1)
else do
idx <- randomRIO (0, length neighs - 1)
let (dir, _) = neighs !! idx
case dir of
North ->
inRow
amat
(fst (matmin bs) - 1)
(snd (matmin bs), snd (matmax bs))
South ->
inRow
amat
(fst (matmax bs) + 1)
(snd (matmin bs), snd (matmax bs))
West ->
inCol
amat
(fst (matmin bs), fst (matmax bs))
(snd (matmin bs) - 1)
East ->
inCol
amat
(fst (matmin bs), fst (matmax bs))
(snd (matmax bs) + 1)
inRow :: Matrix TileState -> Int -> (Int, Int) -> IO (Matrix TileState)
inRow mat row cols = do
col <- randomRIO cols
let tile = mat M.! (row, col)
if tile == Wall
&& length (filter
(== Wall)
(M.toList (M.submatrix (row - 1) (row + 1) col col mat)))
== 1
then
if Door `elem` M.toList (uncurry (M.submatrix row row) cols mat)
then return mat
else
return $ M.setElem Door (row, col) mat
else
inRow mat row cols
inCol :: Matrix TileState -> (Int, Int) -> Int -> IO (Matrix TileState)
inCol mat rows col = do
row <- randomRIO rows
let tile = mat M.! (row, col)
if tile == Wall
&& length (filter
(== Wall)
(M.toList (M.submatrix row row (col - 1) (col + 1) mat)))
== 1
then
if Door `elem` M.toList (uncurry M.submatrix rows col col mat)
then return mat
else
return $ M.setElem Door (row, col) mat
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 Control.Concurrent.STM
import Control.Concurrent.MVar
import Data.String
import qualified Data.Set as S
import qualified Data.Map.Strict as M
import Data.ByteString.Lazy (toStrict)
@ -37,26 +35,21 @@ init = do
<*> (SubTranslator <$> newTVarIO [])
_ <- glewInit
nvg <- createGL3 (S.fromList [NanoVG.Debug, Antialias, StencilStrokes])
UserData
<$> newMVar Load -- state
<*> pure subs -- subsystems
<*> newMVar M.empty -- assetIcons
<*> newMVar M.empty -- assetImages
<*> newMVar M.empty -- assetFonts
<*> newMVar M.empty -- assetAnimations
<*> newMVar NoController -- controls
<*> newMVar NoTranslation -- translation
<*> pure nvg -- nano
<*> newMVar [] -- uuid
<*> newEmptyMVar -- worldState <-
<*> newMVar None -- stateData
<*> newEmptyMVar -- stateMVar <-
<*> newEmptyMVar -- stateProgress <-
<*> newMVar Nothing -- threadContext
<*> newMVar Nothing -- window
<*> newMVar [] -- joyCache
<*> newEmptyMVar -- joyUUID <-
<*> newMVar True -- doNextStep
return UserData
{ state = Load
, subsystems = subs
, assetImages = M.empty
, assetAnimations = M.empty
, assetFonts = M.empty
, assetIcons = M.empty
, nano = nvg
, uuid = []
, stateData = None
, threadContext = Nothing
, controls = NoController
, translation = NoTranslation
, joyCache = []
}
loadPlayerSprite
:: FilePath -- Path to spritemap
@ -69,7 +62,7 @@ loadPlayerSprite fp w h nvg rids = do
eimg <- readImage fp
case eimg of
Left err -> do
logIO Error (fromString err)
logIO Error err
exitFailure
Right dimg -> do
let img = convertRGBA8 dimg
@ -77,16 +70,10 @@ loadPlayerSprite fp w h nvg rids = do
mapM (\(num, i) -> do
let cr = crop (num * w) (row * h) w h img
mresimg <-
createImageMem nvg (S.singleton ImagePremultiplied) (toStrict $ encodePng cr)
createImageMem nvg ImagePremultiplied (toStrict $ encodePng cr)
case mresimg of
Nothing -> do
logIO
Error
("Failed to load: " <>
fromString fp <>
" " <>
fromString (show i)
)
logIO Error ("Failed to load: " ++ fp ++ " " ++ show i)
exitFailure
Just resimg -> return (i, resimg)
) (zip [0..] ids)

2
src/Interior.hs
View file

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

174
src/Load.hs
View file

@ -7,59 +7,57 @@ import Graphics.Rendering.OpenGL.GL.FlushFinish (finish)
import Control.Concurrent (forkIO)
import Control.Concurrent.MVar
import Control.Monad
import Control.Monad.Trans.Resource (ResIO)
import Control.Monad (when)
import qualified Data.Map as M
import qualified Data.Text as T
import Data.Ecstasy
import Data.Maybe
import qualified Data.Set as S
import Data.String
import System.Exit (exitFailure)
import NanoVG hiding (V2(..))
import NanoVG.Internal.Image
-- internal imports
import Menu.Connect
import Types
import MainGame.WorldMap
import Util
loadLoad :: UserData -> Affection ()
loadLoad ud = do
loadLoad :: Affection UserData ()
loadLoad = do
ad <- A.get
wState <- liftIO $ readMVar (worldState ud)
curWin <- liftIO $ readMVar (window ud)
tContext <- liftIO $ readMVar (threadContext ud)
let progress = (0, "Starting up")
void $ liftIO $ putMVar (stateProgress ud) progress
ud <- getAffection
progress <- liftIO $ newMVar (0, "Starting up")
future <- liftIO newEmptyMVar
_ <- liftIO $ createFont (nano ud) "bedstead"
(FileName "assets/font/Bedstead-Semicondensed.ttf")
_ <- liftIO $ forkIO $
loadFork
wState
(fromJust curWin)
(fromJust tContext)
(worldState ud)
(fromJust $ window ud)
(fromJust $ threadContext ud)
(nano ud)
(stateMVar ud)
(stateProgress ud)
SDL.glMakeCurrent (fromJust curWin) (acContext $ head $ glContext ad)
void $ liftIO $ swapMVar (state ud) Load
void $ liftIO $ swapMVar (assetFonts ud) (M.fromList
[ (FontBedstead, "bedstead")
]
)
future
progress
SDL.glMakeCurrent (fromJust $ window ud) (glContext ad)
putAffection ud
{ stateMVar = future
, stateProgress = progress
, state = Load
, assetFonts = M.fromList
[ (FontBedstead, "bedstead")
]
}
loadFork
:: SystemState Entity (AffectionState (AffectionData) ResIO)
:: SystemState Entity (AffectionState (AffectionData UserData) IO)
-> SDL.Window
-> SDL.GLContext
-> Context
-> MVar
( SystemState Entity (AffectionState (AffectionData) ResIO)
( SystemState Entity (AffectionState (AffectionData UserData) IO)
, StateData
)
-> MVar (Float, T.Text)
@ -72,202 +70,202 @@ loadFork ws win glc nvg future progress = do
( p + increment
, "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, _) ->
( p + increment
, "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, _) ->
( p + increment
, "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, _) ->
( p + increment
, "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, _) ->
( p + increment
, "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, _) ->
( p + increment
, "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, _) ->
( p + increment
, "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, _) ->
( p + increment
, "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, _) ->
( p + increment
, "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, _) ->
( p + increment
, "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, _) ->
( p + increment
, "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, _) ->
( p + increment
, "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, _) ->
( p + increment
, "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, _) ->
( p + increment
, "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, _) ->
( p + increment
, "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, _) ->
( p + increment
, "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, _) ->
( p + increment
, "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, _) ->
( p + increment
, "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, _) ->
( p + increment
, "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, _) ->
( p + increment
, "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, _) ->
( p + increment
, "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, _) ->
( p + increment
, "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, _) ->
( p + increment
, "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, _) ->
( p + increment
, "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, _) ->
( p + increment
, "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, _) ->
( p + increment
, "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, _) ->
( p + increment
, "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, _) ->
( p + increment
, "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, _) ->
( p + increment
, "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, _) ->
( p + increment
, "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, _) ->
( p + increment
, "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, _) ->
( p + increment
, "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, _) ->
( p + increment
, "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, _) ->
( p + increment
, "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, _) ->
( p + increment
, "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, _) ->
( p + increment
, "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, _) ->
( p + increment
, "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, _) ->
( p + increment
, "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, _) ->
( p + increment
, "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, _) ->
( p + increment
, "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 =
[ mcontrblue, mcontrgreen, mkbdblue, mkbdgreen, marrow
]
@ -337,18 +335,6 @@ loadFork ws win glc nvg future progress = do
)))
jdoemWalking <- loadAnimationSprites "assets/jdoem.png" nvg
(zip (walkIds AnimJDoeM) walkConfigs)
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Loading Animation \"policem: standing\""
)))
policemStanding <- loadAnimationSprites "assets/policem.png" nvg
(zip (standIds AnimPoliceM) standConfigs)
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Loading Animation \"policem: walking\""
)))
policemWalking <- loadAnimationSprites "assets/policem.png" nvg
(zip (walkIds AnimPoliceM) walkConfigs)
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Loading Animation \"copier: stand\""
@ -503,15 +489,11 @@ loadFork ws win glc nvg future progress = do
, 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, _) ->
( p + increment
, "Handing over"
)))
finish
putMVar future
( ws
, LoadData
@ -521,8 +503,6 @@ loadFork ws win glc nvg future progress = do
playerWalking ++
jdoemStanding ++
jdoemWalking ++
policemStanding ++
policemWalking ++
copierStand ++
copierCopy ++
cornerComputerOff ++
@ -545,24 +525,30 @@ loadFork ws win glc nvg future progress = do
}
)
drawLoad :: UserData -> Affection ()
drawLoad ud = do
drawLoad :: Affection UserData ()
drawLoad = do
ud <- getAffection
progress <- liftIO $ readMVar (stateProgress ud)
liftIO $ do
logIO A.Verbose ("LoadProgress: " <> fromString (show progress))
logIO A.Verbose ("LoadProgress: " ++ show progress)
drawLoadScreen ud progress
updateLoad :: UserData -> Double -> Affection ()
updateLoad ud _ = do
updateLoad :: Double -> Affection UserData ()
updateLoad _ = do
ud <- getAffection
mwsld <- liftIO $ tryTakeMVar (stateMVar ud)
case mwsld of
Just (_, ld) -> do
liftIO $ logIO A.Debug "loaded assets, entering menu"
void $ liftIO $ swapMVar (assetImages ud) (loadAssetImages ld)
void $ liftIO $ swapMVar (assetAnimations ud) (loadAssetAnims ld)
void $ liftIO $ swapMVar (assetIcons ud) (loadAssetIcons ld)
void $ liftIO $ swapMVar (stateData ud) None
putAffection ud
{ assetImages = loadAssetImages ld
, assetAnimations = loadAssetAnims ld
, assetIcons = loadAssetIcons ld
-- , state = Main WorldMap
-- , state = Menu Connect
, stateData = None
}
-- loadMap
loadMenu ud
loadMenu
Nothing ->
return ()

155
src/Main.hs
View file

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

290
src/MainGame/MindMap.hs
View file

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

438
src/MainGame/WorldMap.hs
View file

@ -11,8 +11,8 @@ import qualified SDL
import NanoVG hiding (V2(..))
import Control.Monad (when, void)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.State.Strict (evalStateT)
import Control.Monad.Trans.Resource (ResIO, runResourceT)
import Control.Concurrent.MVar
import Control.Concurrent (forkIO)
import Control.Parallel.Strategies hiding (dot)
@ -23,9 +23,7 @@ import qualified Data.Text as T
import Data.Matrix as M
import Data.Ecstasy as E
import Data.Maybe
import Data.List as L
import qualified Data.Vector as V
import Data.String
import Data.List as L (sortOn, partition, find)
import System.Random (randomRIO)
@ -44,49 +42,63 @@ import NPC
import Animation
import Collision
loadMap :: UserData -> Affection ()
loadMap ud = do
loadMap :: Affection UserData ()
loadMap = do
ud <- getAffection
ad <- get
let (Subsystems _ _ k j t) = subsystems ud
uu0 <- partSubscribe k (emitKbdActionMessage ud)
uu1 <- partSubscribe j (emitJoyActionMessage ud)
uu2 <- partSubscribe t (movePlayer2 ud)
uu3 <- partSubscribe t (playerInteract2 ud)
uu4 <- partSubscribe t (changeMaps2 ud)
void $ liftIO $ swapMVar (stateProgress ud) (0, "Ohai!")
_ <- liftIO $ forkIO $ loadMapFork ud ad (stateMVar ud) (stateProgress ud)
void $ liftIO $ swapMVar (stateData ud) None
void $ liftIO $ swapMVar (uuid ud) [ uu0, uu1, uu2, uu3, uu4 ]
void $ liftIO $ swapMVar (state ud) (Main WorldMap)
let (Subsystems _ m k j t) = subsystems ud
uu0 <- partSubscribe k emitKbdActionMessage
uu1 <- partSubscribe j emitJoyActionMessage
uu2 <- partSubscribe t movePlayer2
uu3 <- partSubscribe t playerInteract2
uu4 <- partSubscribe t changeMaps2
future <- liftIO newEmptyMVar
progress <- liftIO $ newMVar (0, "Ohai!")
_ <- liftIO $ forkIO $ loadMapFork ud ad future progress
putAffection ud
{ stateData = None
, uuid = [ uu0, uu1, uu2, uu3, uu4 ]
, stateMVar = future
, stateProgress = progress
, state = Main WorldMap
}
changeMaps :: UserData -> KeyboardMessage -> Affection ()
changeMaps ud (MsgKeyboardEvent _ _ SDL.Pressed False sym)
changeMaps :: KeyboardMessage -> Affection UserData ()
changeMaps (MsgKeyboardEvent _ _ SDL.Pressed False sym)
| SDL.keysymKeycode sym == SDL.KeycodeF1 = do
curState <- liftIO $ readMVar (state ud)
case curState of
ud <- getAffection
case state ud of
Main MindMap ->
void $ liftIO $ swapMVar (state ud) (Main WorldMap)
putAffection ud
{ state = Main WorldMap
}
Main WorldMap ->
void $ liftIO $ swapMVar (state ud) (Main MindMap)
putAffection ud
{ state = Main MindMap
}
_ -> return ()
| otherwise = return ()
changeMaps _ _ = return ()
changeMaps _ = return ()
changeMaps2 :: UserData -> ActionMessage -> Affection ()
changeMaps2 ud (ActionMessage ActSwitchMap _) = do
curState <- liftIO $ readMVar (state ud)
case curState of
changeMaps2 :: ActionMessage -> Affection UserData ()
changeMaps2 (ActionMessage ActSwitchMap _) = do
ud <- getAffection
case state ud of
Main MindMap ->
void $ liftIO $ swapMVar (state ud) (Main WorldMap)
putAffection ud
{ state = Main WorldMap
}
Main WorldMap ->
void $ liftIO $ swapMVar (state ud) (Main MindMap)
putAffection ud
{ state = Main MindMap
}
_ -> return ()
changeMaps2 _ _ = return ()
changeMaps2 _ = return ()
loadMapFork
:: UserData
-> AffectionData
-> MVar (SystemState Entity (AffectionState AffectionData ResIO), StateData)
-> AffectionData UserData
-> MVar (SystemState Entity (AffectionState (AffectionData UserData) IO), StateData)
-> MVar (Float, T.Text)
-> IO ()
loadMapFork ud ad future progress = do
@ -95,7 +107,7 @@ loadMapFork ud ad future progress = do
fc = FloorConfig
(V2 10 10)
[(V2 5 5), (V2 5 20)]
(40, 40)
(50, 50)
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Building floor"
@ -124,14 +136,13 @@ loadMapFork ud ad future progress = do
( p + increment
, "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
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Creating WorldState"
)))
wState <- liftIO $ readMVar (worldState ud)
(nws, mmimgmat) <- runResourceT $ evalStateT (runState (yieldSystemT wState $ do
(nws, mmimgmat) <- evalStateT (runState (yieldSystemT (worldState ud) $ do
liftIO $ modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Registering copiers into WorldState"
@ -147,12 +158,7 @@ loadMapFork ud ad future progress = do
, objType = Just ObjCopier
, objState = Just "idle"
}
)
(A.log
A.Debug
("number of copiers: " <> fromString (show $ length copiers))
copiers
)
) (A.log A.Debug ("number of copiers: " ++ show (length copiers)) copiers)
liftIO $ modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Registering computers into WorldState"
@ -173,12 +179,7 @@ loadMapFork ud ad future progress = do
, objType = Just ObjComputer
, objState = Just "off"
}
)
(A.log
A.Debug
("number of computers: " <> fromString (show $ length computers))
computers
)
) (A.log A.Debug ("number of computers: " ++ show (length computers)) computers)
liftIO $ modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Registering toilets into WorldState"
@ -193,12 +194,7 @@ loadMapFork ud ad future progress = do
, objAccess = Just [(V2 0 (-1), dir)]
, objType = Just ObjToilet
}
)
(A.log
A.Debug
("number of toilets: " <> fromString (show $ length toilets))
toilets
)
) (A.log A.Debug ("number of toilets: " ++ show (length toilets)) toilets)
liftIO $ modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Preparing MindMap graph"
@ -233,9 +229,7 @@ loadMapFork ud ad future progress = do
, clearanceLvl = Just 0
, anim = Just $ AnimState (AnimId AnimIntruder "standing" SE) 0 0
}
liftIO $ A.logIO
A.Debug
("number of placed NPCs: " <> fromString (show $ length computers))
liftIO $ A.logIO A.Debug $ "number of placed NPCs: " ++ show (length computers)
liftIO $ modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Registering NPCs into WorldState"
@ -249,25 +243,22 @@ loadMapFork ud ad future progress = do
<*> (randomRIO (0, 1))
<*> (randomRIO (0, 1))
<*> (randomRIO (0, 1))
police <- liftIO $ randomRIO (0 :: Int, 9 :: Int)
let room = V.head
(V.filter
let room = head
(Prelude.filter
((inBounds $ pointCoord cpr) . bounds)
(V.fromList $
V.toList (Types.connects (V.head gr)) ++ (V.toList (V.tail gr)))
(Types.connects (head gr) ++ tail gr)
)
void $ createEntity $ newEntity
{ pos = Just (fmap ((+ 0.5) . fromIntegral) (pointCoord cpr))
, vel = Just (V2 0 0)
, velFact = Just fact
, rot = Just SE
, npcMoveState = Just (NPCWalking [[pointCoord cpr]])
, npcMoveState = Just (NPCWalking [pointCoord cpr])
, npcWorkplace = Just cpr
, npcActionState = Just ASWork
, npcStats = Just stats
, clearanceLvl = Just (clearance room)
, anim = Just $ AnimState
(AnimId (if police == 0 then AnimPoliceM else AnimJDoeM) "standing" SE) 0 0
, anim = Just $ AnimState (AnimId AnimJDoeM "standing" SE) 0 0
}
) computers
liftIO $ modifyMVar_ progress (return . (\(p, _) ->
@ -275,18 +266,17 @@ loadMapFork ud ad future progress = do
, "Registering doors into WorldState"
)))
mapM_ (\door -> do
let rooms = V.foldl
let rooms = Prelude.foldl
(\acc coord ->
let rs = V.filter ((inBounds coord) . bounds) graph
let rs = Prelude.filter ((inBounds coord) . bounds) graph
in
if not (V.null rs)
then (coord, V.head rs) `V.cons` acc
if not (Prelude.null rs)
then (coord, head rs) : acc
else acc
)
V.empty
(V.fromList coords)
graph = V.fromList $
(V.toList $ Types.connects (V.head gr)) ++ (V.toList $ V.tail gr)
[]
coords
graph = Types.connects (head gr) ++ tail gr
coords = Prelude.map (door +) deltas
deltas =
[ V2 0 1
@ -295,19 +285,18 @@ loadMapFork ud ad future progress = do
, V2 0 (-1)
]
wall = Prelude.filter
(\ddelta ->
let V2 r c = door + ddelta
(\delta ->
let V2 r c = door + delta
in
fromMaybe False (isWall <$> imgmat M.! (r, c)))
deltas
orientation
| head wall == V2 0 1 || head wall == V2 0 (-1) = NW
| head wall == V2 1 0 || head wall == V2 (-1) 0 = NE
| otherwise = error ("strange wall: " ++ show wall)
| otherwise = error ("strange wall: " ++ show wall)
void $ createEntity $ newEntity
{ pos = Just (fmap ((+ 0.5) . fromIntegral) door)
, clearanceLvl = Just (V.maximum $
0 `V.cons` V.map clearance (V.map snd rooms))
, clearanceLvl = Just (maximum $ 0 : Prelude.map clearance (Prelude.map snd rooms))
, anim = Just $ AnimState (AnimId AnimDoor0 "shut" orientation) 0 1
, obstacle = Just $ case orientation of
NW -> Boundaries (4/9, 0) (5/9, 1)
@ -341,19 +330,19 @@ loadMapFork ud ad future progress = do
then Nothing
else a)
(M.toList inter)
void $ putMVar future (nws, MainData
putMVar future (nws, MainData
{ mapMat = mat
, imgMat = retMat
, reachPoints = V.fromList rps
, reachPoints = rps
, mmImgMat = mmimgmat
, roomGraph = gr
})
movePlayerKbd :: UserData -> KeyboardMessage -> Affection ()
movePlayerKbd ud (MsgKeyboardEvent _ _ press False sym)
movePlayerKbd :: KeyboardMessage -> Affection UserData ()
movePlayerKbd (MsgKeyboardEvent _ _ press False sym)
| SDL.keysymKeycode sym == SDL.KeycodeW = do
wState <- liftIO $ readMVar (worldState ud)
(nws, _) <- yieldSystemT wState $
ud <- getAffection
(nws, _) <- yieldSystemT (worldState ud) $
emap allEnts $ do
with player
(V2 vx _) <- query xyvel
@ -363,10 +352,12 @@ movePlayerKbd ud (MsgKeyboardEvent _ _ press False sym)
return $ unchanged
{ xyvel = Set $ V2 vx ry
}
void $ liftIO $ swapMVar (worldState ud) nws
putAffection ud
{ worldState = nws
}
| SDL.keysymKeycode sym == SDL.KeycodeS = do
wState <- liftIO $ readMVar (worldState ud)
(nws, _) <- yieldSystemT wState $
ud <- getAffection
(nws, _) <- yieldSystemT (worldState ud) $
emap allEnts $ do
with player
(V2 vx _) <- query xyvel
@ -376,10 +367,12 @@ movePlayerKbd ud (MsgKeyboardEvent _ _ press False sym)
return $ unchanged
{ xyvel = Set $ V2 vx ry
}
void $ liftIO $ swapMVar (worldState ud) nws
putAffection ud
{ worldState = nws
}
| SDL.keysymKeycode sym == SDL.KeycodeA = do
wState <- liftIO $ readMVar (worldState ud)
(nws, _) <- yieldSystemT wState $
ud <- getAffection
(nws, _) <- yieldSystemT (worldState ud) $
emap allEnts $ do
with player
(V2 _ vy) <- query xyvel
@ -389,10 +382,12 @@ movePlayerKbd ud (MsgKeyboardEvent _ _ press False sym)
return $ unchanged
{ xyvel = Set $ V2 rx vy
}
void $ liftIO $ swapMVar (worldState ud) nws
putAffection ud
{ worldState = nws
}
| SDL.keysymKeycode sym == SDL.KeycodeD = do
wState <- liftIO $ readMVar (worldState ud)
(nws, _) <- yieldSystemT wState $
ud <- getAffection
(nws, _) <- yieldSystemT (worldState ud) $
emap allEnts $ do
with player
(V2 _ vy) <- query xyvel
@ -402,14 +397,16 @@ movePlayerKbd ud (MsgKeyboardEvent _ _ press False sym)
return $ unchanged
{ xyvel = Set $ V2 rx vy
}
void $ liftIO $ swapMVar (worldState ud) nws
putAffection ud
{ worldState = nws
}
| otherwise = return ()
movePlayerKbd _ _ = return ()
movePlayerKbd _ = return ()
movePlayer2 :: UserData -> ActionMessage -> Affection ()
movePlayer2 ud (ActionMessage mov _) = do
wState <- liftIO $ readMVar (worldState ud)
(nws, _) <- yieldSystemT wState $
movePlayer2 :: ActionMessage -> Affection UserData ()
movePlayer2 (ActionMessage mov _) = do
ud <- getAffection
(nws, _) <- yieldSystemT (worldState ud) $
emap allEnts $ do
with player
V2 vx vy <- query xyvel
@ -421,12 +418,66 @@ movePlayer2 ud (ActionMessage mov _) = do
ActRight f -> V2 f vy
_ -> V2 vx vy
}
void $ liftIO $ swapMVar (worldState ud) nws
putAffection ud
{ worldState = nws
}
movePlayer2 _ = return ()
playerInteract2 :: UserData -> ActionMessage -> Affection ()
playerInteract2 ud (ActionMessage ActActivate _) = do
wState <- liftIO $ readMVar (worldState ud)
(nws, _) <- yieldSystemT wState $ do
playerInteract :: MouseMessage -> Affection UserData ()
playerInteract (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonRight _ m) = do
ud <- getAffection
(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
with player
with pos
@ -452,30 +503,31 @@ playerInteract2 ud (ActionMessage ActActivate _) = do
then return $ Just (otype, ostate, ent)
else return Nothing
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))
mapM_ (\(t, s, e) ->
setEntity e =<< objectTransition t s True e (Just pent)
) relEnts
void $ liftIO $ swapMVar (worldState ud) nws
playerInteract2 _ _ = return ()
putAffection ud
{ worldState = nws
}
playerInteract2 _ = return ()
drawMap :: UserData -> Affection ()
drawMap ud = do
sData <- liftIO $ readMVar (stateData ud)
wState <- liftIO $ readMVar (worldState ud)
drawMap :: Affection UserData ()
drawMap = do
ud <- getAffection
let ctx = nano ud
case sData of
case stateData ud of
None -> liftIO $ do
progress <- readMVar (stateProgress ud)
drawLoadScreen ud progress
_ -> do
dt <- getDelta
(_, dat) <- yieldSystemT wState $ do
(_, dat) <- yieldSystemT (worldState ud) $ do
efor allEnts $ do
with pos
pos' <- query pos
player' <- queryMaybe player
player <- queryMaybe player
stat <- queryMaybe anim
mbnds <- queryMaybe obstacle
t <- queryMaybe objType
@ -483,7 +535,7 @@ drawMap ud = do
pa <- queryMaybe objPlayerActivated
ttl <- queryMaybe objStateTime
let maxt = fromMaybe 1 (actionTime <$> t <*> s)
first = if isJust player'
first = if isJust player
then Just
pos'
else Nothing
@ -512,10 +564,10 @@ drawMap ud = do
([], [], [])
dat
V2 pr pc = playerPos
MainData _ _ _ _ gr = sData
seekGraph = V.foldl V.snoc (Types.connects (V.head gr)) (V.tail gr)
room = V.filter (inBounds (fmap floor playerPos) . bounds) seekGraph
mat = imgMat sData
MainData _ _ _ _ gr = stateData ud
seekGraph = Types.connects (head gr) ++ tail gr
room = Prelude.filter (inBounds (fmap floor playerPos) . bounds) seekGraph
mat = imgMat (stateData ud)
cols = fromIntegral (ncols mat)
rows = fromIntegral (nrows mat)
tileWidth = 64 :: Double
@ -523,8 +575,8 @@ drawMap ud = do
x = realToFrac $ 640 + ((1 - pc) + (1 - pr)) * (tileWidth / 2)
y = realToFrac $ 360 + ((1 - pr) - (1 - pc)) * (tileHeight / 2)
partposanims = M.fromList
(nrows $ mapMat sData)
(ncols $ mapMat sData)
(nrows $ mapMat $ stateData ud)
(ncols $ mapMat $ stateData ud)
((reverse . fst)
(Prelude.foldl
(\(done, proc) coord ->
@ -533,8 +585,8 @@ drawMap ud = do
)
([], posanims)
((,)
<$> [1 .. (nrows $ mapMat sData)]
<*> [1 .. (ncols $ mapMat sData)]
<$> [1 .. (nrows $ mapMat $ stateData ud)]
<*> [1 .. (ncols $ mapMat $ stateData ud)]
)
)
)
@ -570,7 +622,7 @@ drawMap ud = do
)
(zip [1..] (toLists mat))
filterList = Prelude.filter
(\((frow, fcol), _) ->
(\((frow, fcol), tile) ->
((realToFrac (sx frow fcol) > -tileWidth &&
realToFrac (sy frow fcol) > -tileHeight) &&
((realToFrac (sx frow fcol) :: Double) < 1280 &&
@ -585,7 +637,6 @@ drawMap ud = do
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
)
@ -612,20 +663,15 @@ drawMap ud = do
closePath ctx
) posActions
fontSize ctx 20
aFonts <- readMVar (assetFonts ud)
fontFace ctx (aFonts Map.! FontBedstead)
fontFace ctx (assetFonts ud Map.! FontBedstead)
textAlign ctx (S.fromList [AlignCenter,AlignTop])
fillColor ctx (rgb 255 128 0)
textBox ctx 0 0 200 (
"FPS: "
<> T.pack (Prelude.take 5 $ show (1/dt))
<> " Clearance: "
<> (if not (Prelude.null room)
then T.pack (show $ clearance $ V.head room)
else "0"
<> if not (Prelude.null room) then T.pack (show $ clearance $ head room) else "0"
)
-- <> "\nFor answers call 6350"
)
drawTile
:: UserData
@ -637,23 +683,22 @@ drawTile
-> Int
-> Maybe ImgId
-> IO ()
drawTile ud ctx posanims pr pc row col img = do
let (bef, beh) = L.partition delimiter sorted
aImages <- readMVar (assetImages ud)
save ctx
mapM_ (flip drawAnim fact) beh
maybe (return ()) (Types.draw ud x (y - 42) 64 74
(if fromMaybe False (isWall <$> img) then fact else 1))
((aImages Map.!) <$> case img of
Just ImgEmpty -> Nothing
_ -> img
)
mapM_ (flip drawAnim fact) bef
restore ctx
-- when (floor pr == row && floor pc == col) $ do
-- A.logIO A.Debug ("sorted: " ++ show sorted)
-- A.logIO A.Debug ("beh: " ++ show beh)
-- A.logIO A.Debug ("bef: " ++ show bef)
drawTile ud ctx posanims pr pc row col img =
do
let (bef, beh) = L.partition delimiter sorted
save ctx
mapM_ drawAnim beh
maybe (return ()) (draw ud x (y - 42) 64 74 fact)
((assetImages ud Map.!) <$> case img of
Just ImgEmpty -> Nothing
_ -> img
)
mapM_ drawAnim bef
restore ctx
-- when (floor pr == row && floor pc == col) $ do
-- A.logIO A.Debug ("sorted: " ++ show sorted)
-- A.logIO A.Debug ("beh: " ++ show beh)
-- A.logIO A.Debug ("bef: " ++ show bef)
where
delimiter (V2 nr nc, as, mbnds) =
animFloats (asId as) ||
@ -677,8 +722,7 @@ drawTile ud ctx posanims pr pc row col img = do
tileWidth = 64 :: Double
tileHeight = 32 :: Double
sorted = sortOn (\(V2 sr sc, _, mbnds) ->
let comp srow scol =
((floor $ (1 - scol) * 100) :: Int) + ((floor $ srow * 100) :: Int)
let comp srow scol = (floor $ (1 - scol) * 100) + (floor $ srow * 100)
in
case mbnds of
Just (Boundaries (minr, minc) (maxr, maxc)) ->
@ -699,38 +743,38 @@ drawTile ud ctx posanims pr pc row col img = do
dist = distance (V2 (fromIntegral row) (fromIntegral col))
(V2 (realToFrac pr - 1) (realToFrac pc)) / 4
fact =
if pr <= fromIntegral row + (if L.null maxrs then 0.5 else minimum maxrs) &&
pc >= fromIntegral col + (if L.null mincs then 0.5 else maximum mincs)
if isWall (fromJust img) &&
(pr <= fromIntegral row + minimum maxrs &&
pc >= fromIntegral col + maximum mincs)
then min 1 dist
else 1
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
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 ud dt = do
osData <- liftIO $ readMVar (stateData ud)
if osData == None
updateMap :: Double -> Affection UserData ()
updateMap dt = do
ud <- getAffection
if stateData ud == None
then do
mstart <- liftIO $ tryTakeMVar (stateMVar ud)
case mstart of
Just (nws, mendat) -> do
void $ liftIO $ swapMVar (worldState ud) nws
void $ liftIO $ swapMVar (stateData ud) mendat
void $ liftIO $ swapMVar (state ud) (Main WorldMap)
updateMap ud 0.1
updateMap ud 0.1
updateMap ud 0.1
updateMap ud 19
putAffection ud
{ worldState = nws
, stateData = mendat
, state = Main WorldMap
}
updateMap 0.1
updateMap 0.1
updateMap 0.1
updateMap 19
liftIO $ logIO A.Debug "Loaded game data"
Nothing -> return ()
else do
wState <- liftIO $ readMVar (worldState ud)
sData <- liftIO $ readMVar (stateData ud)
aAnim <- liftIO $ readMVar (assetAnimations ud)
(nws, _) <- yieldSystemT wState $ do
(nws, _) <- yieldSystemT (worldState ud) $ do
obstacleBounds <- efor allEnts $ do
with obstacle
with pos
@ -740,12 +784,11 @@ updateMap ud dt = do
emap allEnts $ do
pos'@(V2 pr pc) <- query pos
vel' <- queryMaybe vel
rot' <- fromMaybe N <$> queryMaybe rot
rot' <- query rot
fact' <- fromMaybe 1 <$> queryMaybe velFact
xyv2 <- queryMaybe xyvel
stat <- query anim
let an = aAnim Map.! asId stat
mat = mapMat sData
let an = assetAnimations ud Map.! asId stat
ntime = asElapsedTime stat + dt
npos = pos' + fmap (* (dt * fact')) (fromMaybe (V2 0 0) vel')
dpos@(V2 dpr dpc) = npos - pos'
@ -762,16 +805,16 @@ updateMap ud dt = do
colldpos = dpos * Prelude.foldl
(\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)
(
nub $ concatMap
concatMap
(\(dr, dc) ->
let bs = (++)
(fromMaybe [] $ collisionObstacle <$> M.unsafeGet
(min (nrows mat) $ max 1 $ fromIntegral $ floor pr + dr)
(min (ncols mat) $ max 1 $ fromIntegral $ floor pc + dc)
(imgMat sData))
(maybe [] collisionObstacle (fromMaybe Nothing $ M.safeGet
(fromIntegral $ floor pr + dr)
(fromIntegral $ floor pc + dc)
(imgMat (stateData ud))))
(Prelude.map snd $ Prelude.filter
(\((V2 br bc), _) ->
floor pr + dr == floor br &&
@ -846,7 +889,7 @@ updateMap ud dt = do
{ aiDirection = fromMaybe rot' (direction velo)
}
}
_ -> nstat
x -> nstat
ent = unchanged
{ pos = Set $ pos' + colldpos
, rot = Set $ fromMaybe rot' (direction (fromMaybe (V2 0 0) vel'))
@ -860,16 +903,16 @@ updateMap ud dt = do
Nothing -> Keep
}
return ent
-- allRelEnts <- efor allEnts $ do
-- with pos
-- with rot
-- with clearanceLvl
-- without objType
-- pos' <- query pos
-- rot' <- query rot
-- clvl <- query clearanceLvl
-- entn <- queryEnt
-- return (entn, pos', rot', clvl)
allRelEnts <- efor allEnts $ do
with pos
with rot
with clearanceLvl
without objType
pos' <- query pos
rot' <- query rot
clvl <- query clearanceLvl
entn <- queryEnt
return (entn, pos', rot', clvl)
tses <- efor allEnts $ do
with objType
with objState
@ -878,15 +921,16 @@ updateMap ud dt = do
e <- queryEnt
return (t, s, e)
mapM_ (\(t, s, e) ->
objectAction dt t s e
objectAction allRelEnts dt t s e
) tses
(nws2, _) <- yieldSystemT nws $ updateNPCs
(imgMat sData)
(mapMat sData)
(imgMat $ stateData ud)
nws
(V.filter
(Prelude.filter
(\p -> pointType p /= RoomExit)
(reachPoints sData)
(reachPoints $ stateData ud)
)
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 Data.List (find)
import Data.Maybe (fromJust, isJust)
import Data.String (fromString)
import Control.Monad
import Control.Concurrent.MVar
-- internal imports
import Types
import Util
loadAdjust :: UserData -> Action -> Controller -> Affection () -> Affection ()
loadAdjust ud sub contr switchBack = do
let Subsystems _ _ _ j _ = subsystems ud
uu1 <- partSubscribe j (joyListener ud switchBack)
void $ liftIO $ swapMVar (state ud) (Menu (Adjust sub contr))
void $ liftIO $ swapMVar (uuid ud) [uu1]
loadAdjust :: Action -> Controller -> Affection UserData () -> Affection UserData ()
loadAdjust sub contr switchBack = do
ud <- getAffection
let Subsystems w m k j t = subsystems ud
uu1 <- partSubscribe j (joyListener switchBack)
putAffection ud
{ state = Menu (Adjust sub contr)
, uuid = [ uu1 ]
}
joyListener :: UserData -> Affection () -> JoystickMessage -> Affection ()
joyListener ud switchBack message = do
curState <- liftIO $ readMVar (state ud)
trans <- liftIO $ readMVar (translation ud)
case message of
MsgJoystickAxis _ _ axis val -> do
let align
| val > 0 = AxisPositive
| val < 0 = AxisNegative
| otherwise = A.log A.Error "Can not assign neitral axis align" (error "*dies*")
case trans of
JoyTranslation tmap -> do
let (Menu (Adjust cact (Joystick _))) = curState
act = case cact of
ActUp _ -> ActUp 1
ActDown _ -> ActDown 1
ActLeft _ -> ActLeft 1
ActRight _ -> ActRight 1
x -> A.log A.Error (fromString (show x) <> " is a non-movement action!") (error "*dies*")
k = fst <$> find (\(_, v) -> v == act) (M.assocs tmap)
void $ liftIO $ swapMVar (translation ud) (JoyTranslation $
M.insert (AxisAction (fromIntegral axis) align) act $
if isJust k then M.delete (fromJust k) tmap else tmap
)
fullClean ud
switchBack
_ -> return ()
MsgJoystickButton _ _ but SDL.JoyButtonPressed -> do
case trans of
JoyTranslation tmap -> do
case curState of
Menu (Adjust (ActUp _) (Joystick _)) -> return ()
Menu (Adjust (ActDown _) (Joystick _)) -> return ()
Menu (Adjust (ActLeft _) (Joystick _)) -> return ()
Menu (Adjust (ActRight _) (Joystick _)) -> return ()
Menu (Adjust (act) (Joystick _)) -> do
let k = fst <$> find (\(_, v) -> v == act) (M.assocs tmap)
void $ liftIO $ swapMVar (translation ud) (JoyTranslation $
M.insert (ButtonAction but SDL.JoyButtonPressed) act $
if isJust k then M.delete (fromJust k) tmap else tmap
)
_ -> return ()
fullClean ud
switchBack
x -> A.log A.Error (fromString (show x) <> " is a non-joystick translation!") (error "*dies*")
joyListener :: Affection UserData () -> JoystickMessage -> Affection UserData ()
joyListener switchBack (MsgJoystickAxis _ _ axis val) = do
ud <- getAffection
liftIO $ logIO A.Debug ("switching " ++ show (state ud) ++ " to " ++ show axis)
let trans = translation ud
align
| val > 0 = AxisPositive
| val < 0 = AxisNegative
| otherwise = A.log A.Error "Can not assign neitral axis align" (error "*dies*")
case trans of
JoyTranslation tmap -> do
case state ud of
Menu (Adjust (ActUp s) (Joystick _)) -> do
let k = fst <$> find (\(_, v) -> v == ActUp 1) (M.assocs tmap)
putAffection ud
{ translation = JoyTranslation $
M.insert (AxisAction (fromIntegral axis) align) (ActUp 1) $
if isJust k then M.delete (fromJust k) (tmap) else tmap
}
Menu (Adjust (ActDown s) (Joystick _)) -> do
let k = fst <$> find (\(_, v) -> v == ActDown 1) (M.assocs tmap)
putAffection ud
{ translation = JoyTranslation $
M.insert (AxisAction (fromIntegral axis) align) (ActDown 1) $
if isJust k then M.delete (fromJust k) (tmap) else tmap
}
Menu (Adjust (ActLeft s) (Joystick _)) -> do
let k = fst <$> find (\(_, v) -> v == ActLeft 1) (M.assocs tmap)
putAffection ud
{ translation = JoyTranslation $
M.insert (AxisAction (fromIntegral axis) align) (ActLeft 1) $
if isJust k then M.delete (fromJust k) (tmap) else tmap
}
Menu (Adjust (ActRight s) (Joystick _)) -> do
let k = fst <$> find (\(_, v) -> v == ActRight 1) (M.assocs tmap)
putAffection ud
{ translation = JoyTranslation $
M.insert (AxisAction (fromIntegral axis) align) (ActRight 1) $
if isJust k then M.delete (fromJust k) (tmap) else tmap
}
fullClean
switchBack
_ -> return ()
joyListener switchBack (MsgJoystickButton _ _ but SDL.JoyButtonPressed) = do
ud <- getAffection
case translation ud of
JoyTranslation tmap -> do
case state ud of
Menu (Adjust (ActUp _) (Joystick _)) -> return ()
Menu (Adjust (ActDown _) (Joystick _)) -> return ()
Menu (Adjust (ActLeft _) (Joystick _)) -> return ()
Menu (Adjust (ActRight _) (Joystick _)) -> return ()
Menu (Adjust (act) (Joystick _)) -> do
let k = fst <$> find (\(_, v) -> v == act) (M.assocs tmap)
putAffection ud
{ translation = JoyTranslation $
M.insert (ButtonAction but SDL.JoyButtonPressed) act $
if isJust k then M.delete (fromJust k) tmap else tmap
}
_ -> return ()
fullClean
switchBack
joyListener _ _ = return ()
drawAdjust :: Context -> Affection ()
drawAdjust ctx = do
drawAdjust :: Affection UserData ()
drawAdjust = do
ud <- getAffection
liftIO $ do
let ctx = nano ud
save ctx
beginPath ctx
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.Map.Strict as M
import Data.String
import Control.Concurrent.MVar
import Data.Maybe (isNothing, isJust)
import Control.Monad
@ -23,94 +21,108 @@ import Util
import Menu.Adjust
import MainGame.WorldMap
loadMenu :: UserData -> Affection ()
loadMenu ud = do
loadMenu :: Affection UserData ()
loadMenu = do
ud <- getAffection
ad <- get
let (Subsystems _ m k j t) = subsystems ud
uu1 <- partSubscribe j (joystickConnect ud)
uu2 <- partSubscribe j (joystickDisconnect ud)
uu3 <- partSubscribe j (emitJoyActionMessage ud)
uu4 <- partSubscribe k (emitKbdActionMessage ud)
uu5 <- partSubscribe t (handleActionMessages ud)
uu6 <- partSubscribe m (handleClicks ud)
uu1 <- partSubscribe j joystickConnect
uu2 <- partSubscribe j joystickDisconnect
uu3 <- partSubscribe j emitJoyActionMessage
uu4 <- partSubscribe k emitKbdActionMessage
uu5 <- partSubscribe t handleActionMessages
uu6 <- partSubscribe m handleClicks
-- uu6 <- partSubscribe k emitKbdActionMessage
juuid <- liftIO $ readMVar (joyUUID ud)
partUnSubscribe j juuid
cache <- liftIO $ readMVar (joyCache ud)
void $ liftIO $ swapMVar (uuid ud) [ uu1, uu2, uu3, uu4, uu5, uu6 ]
void $ liftIO $ swapMVar (state ud) (Menu Connect)
void $ liftIO $ swapMVar (stateData ud) (MenuData (V2 0 0) S 0 0)
void $ liftIO $ swapMVar (joyCache ud) []
mapM_ (partEmit j) cache
partUnSubscribe j (joyUUID ud)
putAffection ud
{ uuid = [ uu1, uu2, uu3, uu4, uu5, uu6 ]
, state = Menu Connect
, stateData = MenuData (V2 0 0) S 0 0
, joyCache = []
}
mapM_ (partEmit j) (joyCache ud)
joystickConnect :: UserData -> JoystickMessage -> Affection ()
joystickConnect ud msg = do
ctrls <- liftIO $ readMVar (controls ud)
when (ctrls == NoController) $ do
joystickConnect :: JoystickMessage -> Affection UserData ()
joystickConnect msg = do
ud <- getAffection
when (controls ud == NoController) $ do
mjoy <- joystickAutoConnect msg
maybe (return ()) (\joy -> do
ident <- liftIO $ fromIntegral <$> SDL.getJoystickID joy
liftIO $ logIO A.Debug $ "Joystick connected: " <> fromString (show (ident :: Int))
void $ liftIO $ swapMVar (controls ud) (Joystick joy)
void $ liftIO $ swapMVar (translation ud) (JoyTranslation defaultJoyTranslation)
liftIO $ logIO A.Debug $ "Joystick connected: " ++ show ident
putAffection ud
{ controls = Joystick joy
, translation = JoyTranslation defaultJoyTranslation
}
) mjoy
joystickDisconnect :: UserData -> JoystickMessage -> Affection ()
joystickDisconnect ud msg = do
ctrls <- liftIO $ readMVar (controls ud)
case ctrls of
joystickDisconnect :: JoystickMessage -> Affection UserData ()
joystickDisconnect msg = do
ud <- getAffection
case controls ud of
Joystick joy -> do
njoys <- joystickAutoDisconnect [joy] msg
when (null njoys) $ do
liftIO $ logIO A.Debug $ "Joystick disconnected"
void $ liftIO $ swapMVar (controls ud) NoController
void $ liftIO $ swapMVar (translation ud) NoTranslation
putAffection ud
{ controls = NoController
, translation = NoTranslation
}
_ -> return ()
handleActionMessages :: UserData -> ActionMessage -> Affection ()
handleActionMessages ud (ActionMessage ActActivate _) = do
liftIO $ modifyMVar_ (stateData ud) (\dat -> return dat
{ activate = 0.5
handleActionMessages :: ActionMessage -> Affection UserData ()
handleActionMessages (ActionMessage ActActivate _) = do
ud <- getAffection
putAffection ud
{ stateData = (stateData ud)
{ activate = 0.5
}
}
)
handleActionMessages ud (ActionMessage ActSwitchMap _) = do
liftIO $ modifyMVar_ (stateData ud) (\dat -> return dat
{ switchMap = 0.5
handleActionMessages (ActionMessage ActSwitchMap _) = do
ud <- getAffection
putAffection ud
{ stateData = (stateData ud)
{ switchMap = 0.5
}
}
)
handleActionMessages ud (ActionMessage (ActUp f) _) = do
liftIO $ modifyMVar_ (stateData ud) (\dat ->
let V2 vx _ = velocity dat
in return dat
handleActionMessages (ActionMessage (ActUp f) _) = do
ud <- getAffection
let V2 vx _ = velocity $ stateData ud
putAffection ud
{ stateData = (stateData ud)
{ velocity = (V2 vx (-f))
}
)
handleActionMessages ud (ActionMessage (ActDown f) _) = do
liftIO $ modifyMVar_ (stateData ud) (\dat ->
let V2 vx _ = velocity dat
in return dat
}
handleActionMessages (ActionMessage (ActDown f) _) = do
ud <- getAffection
let V2 vx _ = velocity $ stateData ud
putAffection ud
{ stateData = (stateData ud)
{ velocity = (V2 vx f)
}
)
handleActionMessages ud (ActionMessage (ActLeft f) _) = do
liftIO $ modifyMVar_ (stateData ud) (\dat ->
let V2 _ vy = velocity dat
in return dat
}
handleActionMessages (ActionMessage (ActLeft f) _) = do
ud <- getAffection
let V2 _ vy = velocity $ stateData ud
putAffection ud
{ stateData = (stateData ud)
{ velocity = (V2 (-f) vy)
}
)
handleActionMessages ud (ActionMessage (ActRight f) _) = do
liftIO $ modifyMVar_ (stateData ud) (\dat ->
let V2 _ vy = velocity dat
in return dat
}
handleActionMessages (ActionMessage (ActRight f) _) = do
ud <- getAffection
let V2 _ vy = velocity $ stateData ud
putAffection ud
{ stateData = (stateData ud)
{ velocity = (V2 f vy)
}
)
}
handleClicks :: UserData -> MouseMessage -> Affection ()
handleClicks ud (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft 1 cpos) = do
rels <- liftIO $ fmap ((/ 2) . (+ 1)) <$> (relativizeMouseCoords cpos)
ctrls <- liftIO $ readMVar (controls ud)
case ctrls of
handleClicks :: MouseMessage -> Affection UserData ()
handleClicks (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft 1 pos@(V2 px py)) = do
ud <- getAffection
rels@(V2 rx ry) <- liftIO $ fmap ((/ 2) . (+ 1)) <$> (relativizeMouseCoords pos)
case controls ud of
Joystick _ -> do
when (arrowUp rels) adjustKbdUp
when (arrowDown rels) adjustKbdDown
@ -120,36 +132,40 @@ handleClicks ud (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft 1 cpos) = do
when (buttonSwitchMap rels) adjustKbdSwitchMap
when (buttonPlay rels) enterGame
NoController -> do
when (kbdIcon rels) $ do
void $ liftIO $ swapMVar (controls ud) Keyboard
void $ liftIO $ swapMVar (translation ud) (KbdTranslation defaultKbdTranslation)
when (kbdIcon rels) $
putAffection ud
{ controls = Keyboard
, translation = KbdTranslation defaultKbdTranslation
}
Keyboard -> do
when (kbdIcon rels) $ do
void $ liftIO $ swapMVar (controls ud) NoController
void $ liftIO $ swapMVar (translation ud) NoTranslation
when (kbdIcon rels) $
putAffection ud
{ controls = NoController
, translation = NoTranslation
}
when (buttonPlay rels) enterGame
where
adjustKbdUp = do
fullClean ud
loadAdjust ud (ActUp 1) Keyboard (loadMenu ud)
fullClean
loadAdjust (ActUp 1) Keyboard loadMenu
adjustKbdDown = do
fullClean ud
loadAdjust ud (ActDown 1) Keyboard (loadMenu ud)
fullClean
loadAdjust (ActDown 1) Keyboard loadMenu
adjustKbdLeft = do
fullClean ud
loadAdjust ud (ActLeft 1) Keyboard (loadMenu ud)
fullClean
loadAdjust (ActLeft 1) Keyboard loadMenu
adjustKbdRight = do
fullClean ud
loadAdjust ud (ActRight 1) Keyboard (loadMenu ud)
fullClean
loadAdjust (ActRight 1) Keyboard loadMenu
adjustKbdActivate = do
fullClean ud
loadAdjust ud ActActivate Keyboard (loadMenu ud)
fullClean
loadAdjust ActActivate Keyboard loadMenu
adjustKbdSwitchMap = do
fullClean ud
loadAdjust ud ActSwitchMap Keyboard (loadMenu ud)
fullClean
loadAdjust ActSwitchMap Keyboard loadMenu
enterGame = do
fullClean ud
loadMap ud
fullClean
loadMap
arrowUp (V2 rx ry) =
rx > 310 / 1280 && rx < 410 / 1280 && ry > 190 / 720 && ry < 290 / 720
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
kbdIcon (V2 rx ry) =
rx > 650 / 1280 && rx < 730 / 1280 && ry > 620 / 720 && ry < 700 / 720
handleClicks _ _ = return ()
handleClicks _ = return ()
updateMenu :: UserData -> Double -> Affection ()
updateMenu ud dt = do
sData <- liftIO $ readMVar (stateData ud)
case sData of
updateMenu :: Double -> Affection UserData ()
updateMenu dt = do
ud <- getAffection
case stateData ud of
MenuData _ _ _ _ ->
void $ liftIO $ swapMVar (stateData ud) (
MenuData
(velocity sData)
(rotation sData)
(max 0 ((activate sData) - dt))
(max 0 ((switchMap sData) - dt))
)
putAffection ud
{ stateData = MenuData
(velocity $ stateData ud)
(rotation $ stateData ud)
(max 0 ((activate $ stateData ud) - dt))
(max 0 ((switchMap $ stateData ud) - dt))
}
_ -> return ()
drawMenu :: UserData -> Affection ()
drawMenu ud = do
sData <- liftIO $ readMVar (stateData ud)
curState <- liftIO $ readMVar (state ud)
aIcons <- liftIO $ readMVar (assetIcons ud)
case sData of
drawMenu :: Affection UserData ()
drawMenu = do
ud <- getAffection
case stateData ud of
MenuData _ _ _ _ ->
liftIO $ do
let ctx = nano ud
controller <- readMVar (controls ud)
controller = controls ud
save 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
Joystick _ -> IconContrGreen
_ -> IconContrBlue
@ -204,17 +218,17 @@ drawMenu ud = do
closePath ctx
fill 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
Keyboard -> IconKbdGreen
_ -> IconKbdBlue
) 1
rect ctx 650 620 80 80
fillPaint ctx cpaint2
fillPaint ctx cpaint
closePath ctx
fill ctx
when (controller /= NoController) $ do
let V2 vx vy = velocity sData
let V2 vx vy = velocity $ stateData ud
beginPath ctx
roundedRect ctx 140 110 1000 500 25
strokeWidth ctx 5
@ -225,7 +239,7 @@ drawMenu ud = do
mapM_ (\deg -> do
let V2 px py = fmap realToFrac $
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
save ctx
translate ctx (px + 50) (py + 50)
@ -239,7 +253,7 @@ drawMenu ud = do
roundedRect ctx 0 0 100 100 10
closePath ctx
fill ctx
case curState of
case state ud of
Menu (Adjust (ActUp _) _) -> do
beginPath ctx
fillColor ctx (rgb 0 255 0)
@ -261,7 +275,7 @@ drawMenu ud = do
roundedRect ctx 0 0 100 100 10
closePath ctx
fill ctx
case curState of
case state ud of
Menu (Adjust (ActLeft _) _) -> do
beginPath ctx
fillColor ctx (rgb 0 255 0)
@ -283,7 +297,7 @@ drawMenu ud = do
roundedRect ctx 0 0 100 100 10
closePath ctx
fill ctx
case curState of
case state ud of
Menu (Adjust (ActUp _) _) -> do
beginPath ctx
fillColor ctx (rgb 0 255 0)
@ -305,7 +319,7 @@ drawMenu ud = do
roundedRect ctx 0 0 100 100 10
closePath ctx
fill ctx
case curState of
case state ud of
Menu (Adjust (ActLeft _) _) -> do
beginPath ctx
fillColor ctx (rgb 0 255 0)
@ -321,20 +335,20 @@ drawMenu ud = do
_ ->
return ()
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
fillPaint ctx apaint
closePath ctx
fill ctx
restore ctx
) [0, 90, 180, 270]
when (activate sData > 0) $ do
when (activate (stateData ud) > 0) $ do
beginPath ctx
fillColor ctx (rgb 255 128 0)
roundedRect ctx 650 160 150 50 10
fill ctx
closePath ctx
case curState of
case state ud of
Menu (Adjust ActActivate _) -> do
beginPath ctx
fillColor ctx (rgb 0 255 0)
@ -353,13 +367,13 @@ drawMenu ud = do
fillColor ctx (rgb 255 255 255)
textBox ctx 650 175 150 "Activate"
closePath ctx
when (switchMap sData > 0) $ do
when (switchMap (stateData ud) > 0) $ do
beginPath ctx
fillColor ctx (rgb 255 128 0)
roundedRect ctx 650 220 150 50 10
fill ctx
closePath ctx
case curState of
case state ud of
Menu (Adjust ActSwitchMap _) -> do
beginPath ctx
fillColor ctx (rgb 0 255 0)

284
src/NPC.hs
View file

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

2
src/Navigation.hs
View file

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

15
src/Object.hs
View file

@ -3,7 +3,14 @@
{-# LANGUAGE FlexibleInstances #-}
module Object where
import Affection as A
import Control.Monad (when)
import Data.Ecstasy
import Data.Maybe
import Linear
-- internal imports
@ -14,13 +21,13 @@ import Object.Copier
import Object.Door
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 =
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 Data.String
-- internal imports
import Types
@ -16,9 +14,7 @@ instance ActionTime ObjType ObjState where
actionTime ObjComputer "off" = 0
actionTime ObjComputer "on" = 20
actionTime ObjComputer "hack" = 20
actionTime ObjComputer "hack" = 20
actionTime ObjDoor "open" = 2
actionTime o s = A.log
Error
(fromString (show o) <> ": " <> fromString s <> ": has not a time")
0
actionTime o s = A.log Error (show o ++ ": " ++ 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 Control.Monad (when)
import Control.Monad.IO.Class (MonadIO(..))
import Data.Ecstasy
import Data.Maybe
import Data.String
import Linear
@ -18,16 +18,17 @@ import Linear
import Types
import Object.ActionTime ()
import Object.ActionTime
computerObjectAction
:: (Monad m, MonadIO m)
=> Double
=> [(Ent, V2 Double, Direction, Word)]
-> Double
-> ObjType
-> ObjState
-> Ent
-> SystemT Entity m ()
computerObjectAction dt t@ObjComputer s@"on" ent = do
computerObjectAction _ dt t@ObjComputer s@"on" ent = do
pent <- efor (anEnt ent) $ do
with objUsedBy
query objUsedBy
@ -39,7 +40,7 @@ computerObjectAction dt t@ObjComputer s@"on" ent = do
mtime <- queryMaybe objStateTime
case mtime of
Nothing -> do
liftIO $ logIO Verbose ("Computer " <> fromString (show ent) <> ": on!")
liftIO $ logIO Verbose ("Computer " ++ show ent ++ ": on!")
let dur = actionTime t s
return unchanged
{ objStateTime = Set dur
@ -65,7 +66,7 @@ computerObjectAction dt t@ObjComputer s@"on" ent = do
(\tpa -> setEntity ent =<< computerObjectTransition t s tpa ent Nothing)
(head trans)
computerObjectAction dt t@ObjComputer s@"hack" ent = do
computerObjectAction _ dt t@ObjComputer s@"hack" ent = do
aent <- efor (anEnt ent) $ do
with objUsedBy
query objUsedBy
@ -77,9 +78,7 @@ computerObjectAction dt t@ObjComputer s@"hack" ent = do
mtime <- queryMaybe objStateTime
case mtime of
Nothing -> do
liftIO $ logIO
Verbose
("Computer " <> fromString (show ent) <> ": hacking!")
liftIO $ logIO Verbose ("Computer " ++ show ent ++ ": hacking!")
return unchanged
{ 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)
(head trans)
computerObjectAction _ _ _ _ = return ()
computerObjectAction _ _ _ _ _ = return ()
computerObjectTransition
:: (Monad m, MonadIO m)
@ -113,8 +112,7 @@ computerObjectTransition
-> Maybe Ent
-> SystemT Entity m (Entity 'SetterOf)
computerObjectTransition ObjComputer "off" pa ent (Just aent) = do
ldir <- efor (anEnt aent) (query rot)
let dir = head ldir
[dir] <- efor (anEnt aent) (query rot)
e <- efor (anEnt ent) $ do
solved <- queryMaybe objSolved
if pa

13
src/Object/Copier.hs
View file

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

80
src/Object/Door.hs
View file

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

12
src/StateMachine.hs
View file

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

5
src/Types/Animation.hs
View file

@ -46,10 +46,5 @@ data AnimationName
| AnimComputer
| AnimToilet
| AnimJDoeM
| AnimPoliceM
| AnimDoor0
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 Control.Concurrent.MVar
import NanoVG
import Foreign.C.Types (CFloat(..))
@ -32,7 +30,7 @@ instance NanoDrawable UserData Image where
instance NanoDrawable UserData AnimState where
draw us x y w h alpha as = do
anims <- readMVar (assetAnimations us)
let a = anims Map.! asId as
let anims = assetAnimations us
a = anims Map.! asId as
img = (animSprites a !! asCurrentFrame as) :: Image
draw us x y w h alpha img

30
src/Types/Interior.hs
View file

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

6
src/Types/Map.hs
View file

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

4
src/Types/NPCState.hs
View file

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

10
src/Types/ObjClass.hs
View file

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

5
src/Types/StateData.hs
View file

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

84
src/Types/UserData.hs
View file

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

108
src/Util.hs
View file

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

4
tracer-game.cabal
View file

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