Compare commits
1 commit
master
...
parallel-e
| Author | SHA1 | Date | |
|---|---|---|---|
| f30bd58fed |
36 changed files with 1653 additions and 1637 deletions
1
.envrc
1
.envrc
|
|
@ -1 +0,0 @@
|
|||
use flake
|
||||
2
.gitignore
vendored
2
.gitignore
vendored
|
|
@ -8,7 +8,6 @@
|
|||
cabal.sandbox.config
|
||||
dist/
|
||||
dist-newstyle/
|
||||
.direnv/
|
||||
*.prof
|
||||
*.aux
|
||||
*.hp
|
||||
|
|
@ -19,4 +18,3 @@ dist-newstyle/
|
|||
*.eventlog
|
||||
*.*~
|
||||
.*autosave.kra
|
||||
result
|
||||
|
|
|
|||
Binary file not shown.
Binary file not shown.
|
Before Width: | Height: | Size: 17 KiB |
2
cabal.config
Normal file
2
cabal.config
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
constraints: affection +debug
|
||||
profiling: True
|
||||
4
cabal.project
Normal file
4
cabal.project
Normal file
|
|
@ -0,0 +1,4 @@
|
|||
packages:
|
||||
./
|
||||
../ecstasy/
|
||||
profiling: True
|
||||
84
flake.lock
84
flake.lock
|
|
@ -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
46
flake.nix
|
|
@ -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
272
shell.nix
|
|
@ -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
645
src/Floorplan.hs
|
|
@ -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
49
src/Init.hs
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
174
src/Load.hs
|
|
@ -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 ()
|
||||
|
|
|
|||
160
src/Main.hs
160
src/Main.hs
|
|
@ -4,6 +4,7 @@ module Main where
|
|||
import Affection as A
|
||||
|
||||
import Data.Ecstasy
|
||||
import Data.Ecstasy.Types
|
||||
|
||||
import qualified SDL
|
||||
|
||||
|
|
@ -15,9 +16,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 +28,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)
|
||||
(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
|
||||
_ <- partSubscribe k quitGame
|
||||
u <- partSubscribe j cacheJoypad
|
||||
(ws, _) <- yieldSystemT (SystemState 0 defStorage defHooks) (return ())
|
||||
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)
|
||||
(ws, _) <- yieldSystemT (0, defStorage) (return ())
|
||||
void $ liftIO $ swapMVar (worldState ud) ws
|
||||
void $ liftIO $ swapMVar (state ud) Load
|
||||
smLoad Load ud
|
||||
| otherwise = return ()
|
||||
quitGame _ _ = return ()
|
||||
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 (SystemState 0 defStorage defHooks) (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
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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)]
|
||||
)
|
||||
)
|
||||
)
|
||||
|
|
@ -563,37 +615,15 @@ drawMap ud = do
|
|||
closePath ctx
|
||||
fillColor ctx (rgb 255 255 255)
|
||||
fill ctx
|
||||
let coordList = concatMap
|
||||
(\(i, ls) -> Prelude.map
|
||||
(\(j, t) -> ((i, j), t))
|
||||
(reverse $ zip [1..] ls)
|
||||
)
|
||||
(zip [1..] (toLists mat))
|
||||
filterList = Prelude.filter
|
||||
(\((frow, fcol), _) ->
|
||||
((realToFrac (sx frow fcol) > -tileWidth &&
|
||||
realToFrac (sy frow fcol) > -tileHeight) &&
|
||||
((realToFrac (sx frow fcol) :: Double) < 1280 &&
|
||||
(realToFrac ((sy frow fcol)- (74 - (realToFrac tileHeight :: CFloat))) :: Double) < 720))
|
||||
)
|
||||
coordList
|
||||
!posanimList = Prelude.map
|
||||
(\((row, col), tile) -> ((row, col), tile, partposanims M.! (row, col)))
|
||||
filterList
|
||||
sx row col = realToFrac $ 640 + ((fromIntegral col - pc) +
|
||||
(fromIntegral row - pr)) * (tileWidth / 2) :: CFloat
|
||||
sy row col = realToFrac $ 360 - (tileHeight / 2) + ((fromIntegral row - pr) -
|
||||
(fromIntegral col - pc)) * (tileHeight / 2) :: CFloat
|
||||
void $ sequence $ parMap rpar
|
||||
-- mapM_
|
||||
(\((row, col), tile, posanim) ->
|
||||
drawTile ud ctx posanim pr pc row col tile
|
||||
-- void $ sequence $ parMap rpar
|
||||
mapM_
|
||||
(\(i, ls) ->
|
||||
-- void $ sequence $ parMap rpar
|
||||
mapM_
|
||||
(\(j, t) -> drawTile ud ctx (partposanims M.! (i, j)) pr pc i j t)
|
||||
(reverse $ zip [1..] ls)
|
||||
)
|
||||
posanimList
|
||||
-- void $ sequence $ parMap rpar (\(i, ls) -> void $ sequence $ parMap rpar
|
||||
-- (\(j, t) -> drawTile ud ctx (partposanims M.! (i, j)) pr pc i j t)
|
||||
-- (reverse $ zip [1..] ls))
|
||||
-- (zip [1..] (toLists mat))
|
||||
(zip [1..] (toLists mat))
|
||||
mapM_ (\(V2 sr sc, pa, perc) -> when pa $ do
|
||||
let lx = realToFrac $ 640 + ((sc - pc) +
|
||||
(sr - pr)) * (tileWidth / 2) :: CFloat
|
||||
|
|
@ -612,20 +642,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 +662,25 @@ 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 =
|
||||
when ((realToFrac x > -tileWidth && realToFrac y > -tileHeight) &&
|
||||
((realToFrac x :: Double) < 1280 &&
|
||||
(realToFrac (y - (74 - (realToFrac tileHeight :: CFloat))) :: Double) < 720)) $
|
||||
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 +704,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 +725,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 +766,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 +787,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 +871,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 +885,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 +903,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
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
284
src/NPC.hs
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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 =<<
|
||||
|
|
|
|||
|
|
@ -46,10 +46,5 @@ data AnimationName
|
|||
| AnimComputer
|
||||
| AnimToilet
|
||||
| AnimJDoeM
|
||||
| AnimPoliceM
|
||||
| AnimDoor0
|
||||
deriving (Show, Eq, Ord, Enum)
|
||||
|
||||
isWallLike :: AnimationName -> Bool
|
||||
isWallLike AnimDoor0 = True
|
||||
isWallLike _ = False
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
108
src/Util.hs
|
|
@ -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 = []
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue