Compare commits

...

51 commits

Author SHA1 Message Date
nek0 01183a2465 fix flake and update 2023-11-24 18:55:42 +01:00
Amedeo Molnár 009cd6fac7 adjust flake to include haskell build inputs 2023-04-20 10:32:27 +02:00
nek0 13700f1b55 update flake 2023-04-20 07:04:45 +02:00
nek0 c044dc89da add .envrc 2023-04-20 06:59:47 +02:00
nek0 367ba034b6 ignore result symlink 2023-03-25 21:49:13 +01:00
nek0 3bc7faa7cd update flake 2023-03-25 13:52:56 +01:00
nek0 df2cfcf411 update flake 2022-12-27 19:40:55 +01:00
nek0 a7ce6f36a1 update flake 2022-12-01 22:09:04 +01:00
nek0 07edd99d0a remove ballast 2022-12-01 14:34:38 +01:00
nek0 dd8556ee2b some update 2022-09-14 20:10:20 +02:00
nek0 66f9d07905 flakify complete 2022-09-14 19:49:03 +02:00
nek0 518e27d1a8 flakify 2022-09-14 19:03:04 +02:00
nek0 cd2a0f3706 update to new affection 2022-08-04 18:13:53 +02:00
nek0 eecfe82abd follow NanoVG changes 2022-02-18 21:34:02 +01:00
nek0 f8ea2785bf modernize shell.nix 2022-02-18 21:33:40 +01:00
nek0 f678b216d6 add policeman 2020-05-12 16:24:36 +02:00
nek0 0cc3195455 add missing library 2020-05-12 16:22:21 +02:00
nek0 cdd5db2b73 finish porting process 2020-05-05 10:26:16 +02:00
nek0 a33fec68d4 bump module Load to affection 0.0.0.10 2020-05-05 09:13:39 +02:00
nek0 eea0ec07fd bumped module Floorplan to affection 0.0.0.10 2020-05-05 07:13:15 +02:00
nek0 ace1f0ce8c bumped module Menu.Adjust to affection 0.0.0.10 2020-05-05 07:05:59 +02:00
nek0 81e16c4428 bump module NPC to affection 0.0.0.10 2020-05-05 06:31:36 +02:00
nek0 8f2366502b bump module Util to affection 0.0.0.10 2020-05-05 06:29:35 +02:00
nek0 808ab1db06 fix more UserData stuff 2020-05-05 01:23:40 +02:00
nek0 adf5eefcdc bump UserData object and Util 2020-05-05 01:12:53 +02:00
nek0 83b3bbcd9b hunt warnings 2020-05-05 01:03:59 +02:00
nek0 c110f29c8f port module Types.ObjClass 2020-05-05 00:53:46 +02:00
nek0 55f688e9be port module Types.UserData 2020-05-05 00:52:24 +02:00
nek0 7a5e30c6ed bump affection version 2020-05-05 00:48:05 +02:00
nek0 d9a8045daa updated shell.nix 2019-11-12 00:49:54 +01:00
nek0 f61bc52ca6 Get tiles in an unsafe manner 2019-11-02 09:44:50 +01:00
nek0 7f1de2ae15 textify 2019-10-28 18:20:34 +01:00
nek0 42126a972d fix logging 2019-10-28 17:26:21 +01:00
nek0 7c59021aee various speed optimizations 2019-10-20 10:53:53 +02:00
nek0 3cb28f396b remove old commented out code 2019-03-31 05:29:41 +02:00
nek0 97cdf46170 move door output to verbose 2019-03-31 05:28:19 +02:00
rys ostrovid 6d051f6c5e
Merge pull request #3 from nek0/axe
Axe
2019-03-29 15:59:34 +01:00
nek0 d3212425d5 it's dead, jim 2019-03-29 15:56:34 +01:00
nek0 1c95794285 *insert screechy music* 2019-03-29 12:30:47 +01:00
nek0 e206062dfc lets hack it to pieces 2019-03-28 21:00:44 +01:00
nek0 9cdec48044 hunting warnings 2019-03-28 20:59:31 +01:00
nek0 daac9470e5 satisfy MonadFail 2019-03-28 20:20:43 +01:00
nek0 d7151cb11f fix animations 2019-03-28 11:26:16 +01:00
nek0 8438454477 satisfy monadFail 2019-03-15 01:50:38 +01:00
nek0 abb3ad3cd3 doors are now opened by NPCs and the player, not automatically. 2019-03-15 01:41:18 +01:00
nek0 0fcd4a10b2 add dining tables and clean tables 2019-03-09 20:37:20 +01:00
nek0 77b9a0a46e draw doors like walls 2019-03-09 20:36:21 +01:00
nek0 d9735e72e9 de-parallelize drawing 2019-03-07 16:32:01 +01:00
rys ostrovid 6452804270
Merge pull request #2 from nek0/drawfilter
Drawfilter
2019-03-07 15:17:32 +01:00
nek0 8ec9f9cb6f prefilter drawing elements 2019-03-07 15:13:40 +01:00
nek0 b2e9af5efd back to old ecstasy 2019-03-07 09:51:34 +01:00
36 changed files with 1638 additions and 1649 deletions

1
.envrc Normal file
View file

@ -0,0 +1 @@
use flake

2
.gitignore vendored
View file

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

BIN
assets/policem.kra Normal file

Binary file not shown.

BIN
assets/policem.png Normal file

Binary file not shown.

After

Width:  |  Height:  |  Size: 17 KiB

View file

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

View file

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

84
flake.lock Normal file
View file

@ -0,0 +1,84 @@
{
"nodes": {
"affection-src": {
"inputs": {
"flake-utils": [
"flake-utils"
],
"nixpkgs": [
"nixpkgs"
]
},
"locked": {
"lastModified": 1700847735,
"narHash": "sha256-hSHgLPZwWP7tPoUhH2GLQ4GvHvVGFiXIM0CLps+O5KE=",
"ref": "refs/heads/master",
"rev": "d0465fa3e1d122503439df7c2de9d16598fc0cf5",
"revCount": 306,
"type": "git",
"url": "https://gitea.nek0.eu/nek0/affection"
},
"original": {
"type": "git",
"url": "https://gitea.nek0.eu/nek0/affection"
}
},
"flake-utils": {
"inputs": {
"systems": "systems"
},
"locked": {
"lastModified": 1694529238,
"narHash": "sha256-zsNZZGTGnMOf9YpHKJqMSsa0dXbfmxeoJ7xHlrt+xmY=",
"owner": "numtide",
"repo": "flake-utils",
"rev": "ff7b65b44d01cf9ba6a71320833626af21126384",
"type": "github"
},
"original": {
"owner": "numtide",
"repo": "flake-utils",
"type": "github"
}
},
"nixpkgs": {
"locked": {
"lastModified": 1700844339,
"narHash": "sha256-VRlPYk0eRn1ao75hoA99LGehYhxZH5RlkP1YXpVROHM=",
"owner": "NixOS",
"repo": "nixpkgs",
"rev": "33576fdfce2d11204067d6cfa99a2f990ef2169a",
"type": "github"
},
"original": {
"owner": "NixOS",
"repo": "nixpkgs",
"type": "github"
}
},
"root": {
"inputs": {
"affection-src": "affection-src",
"flake-utils": "flake-utils",
"nixpkgs": "nixpkgs"
}
},
"systems": {
"locked": {
"lastModified": 1681028828,
"narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=",
"owner": "nix-systems",
"repo": "default",
"rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e",
"type": "github"
},
"original": {
"owner": "nix-systems",
"repo": "default",
"type": "github"
}
}
},
"root": "root",
"version": 7
}

46
flake.nix Normal file
View file

@ -0,0 +1,46 @@
{
description = "A game stub written in Haskell";
inputs = {
nixpkgs.url = "github:NixOS/nixpkgs";
flake-utils.url = "github:numtide/flake-utils";
affection-src = {
url = "git+https://gitea.nek0.eu/nek0/affection";
inputs = {
nixpkgs.follows = "nixpkgs";
flake-utils.follows = "flake-utils";
};
};
};
outputs = { self, nixpkgs, flake-utils, affection-src }:
flake-utils.lib.eachDefaultSystem (system:
let
pkgs = nixpkgs.legacyPackages.${system};
haskellPackages = pkgs.haskellPackages;
jailbreakUnbreak = pkg:
pkgs.haskell.lib.doJailbreak (pkg.overrideAttrs (_: { meta = { }; }));
packageName = "tracer-game";
in rec {
packages.${packageName} = # (ref:haskell-package-def)
haskellPackages.callCabal2nix packageName self rec {
affection = affection-src.defaultPackage.${system};
};
defaultPackage = self.packages.${system}.${packageName};
devShell = haskellPackages.shellFor {
packages = p: [ defaultPackage ];
withHoogle = true;
buildInputs = with haskellPackages; [
haskell-language-server
ghcid
cabal-install
] ++ (builtins.attrValues self.packages.${system});
};
});
}

272
shell.nix
View file

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

View file

@ -6,7 +6,8 @@ import Data.Matrix (Matrix(..))
import qualified Data.Matrix as M
import qualified Data.Text as T
import Data.Maybe
import Data.List (intersect)
import qualified Data.Vector as V
import Data.String
import Linear (V2(..))
@ -25,7 +26,7 @@ buildHallFloorIO
:: FloorConfig
-> MVar (Float, T.Text)
-> Float
-> IO (Matrix TileState, [Graph])
-> IO (Matrix TileState, V.Vector Graph)
buildHallFloorIO fc progress increment = do
rand <- newStdGen
modifyMVar_ progress (return . (\(p, _) ->
@ -77,8 +78,12 @@ buildHallFloorIO fc progress increment = do
( p + increment
, "Assigned room clearances"
)))
A.logIO A.Debug ("length accessGraph: " ++ show (length accessGraph))
A.logIO A.Debug ("length doorgraph: " ++ show (length doorgraph))
A.logIO
A.Debug
("length accessGraph: " <> fromString (show $ length accessGraph))
A.logIO
A.Debug
("length doorgraph: " <> fromString (show $ length doorgraph))
return (facils, accessGraph)
emptyFloor :: FloorConfig -> Matrix TileState
@ -123,10 +128,8 @@ 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
@ -134,10 +137,6 @@ 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
@ -179,101 +178,106 @@ hallRatio mat =
buildInnerWalls :: StdGen -> Matrix TileState -> (StdGen, Matrix TileState)
buildInnerWalls rng input =
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]
let 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]
@ -311,26 +315,28 @@ buildFacilities
-> Matrix TileState
-> (StdGen, Matrix TileState)
buildFacilities gen fc input =
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)
let 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, flood facil acc x)
in (ngen, facilFlood 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)
@ -346,104 +352,119 @@ findNearestOffice mat (V2 rrr ccc) =
else acc
) (fst $ head inlist) inlist
buildDoorsGraph :: Matrix TileState -> IO [Graph]
buildDoorsGraph :: Matrix TileState -> IO (V.Vector Graph)
buildDoorsGraph mat =
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)
weedOut (buildGraph mat mat (V.singleton (GHall V.empty)) (2, 2))
where
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 []
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)
assignClearance :: [Graph] -> M.Matrix TileState -> IO [Graph]
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 imat =
foldM doAssignClearance [] graph
V.foldM doAssignClearance V.empty graph
where
doAssignClearance acc (GHall conns) = do
ret <- GHall <$> foldM (\acc a -> do
res <- reassign True acc a
return (acc ++ [res])
) [] conns
return (ret : acc)
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)
doAssignClearance acc room = do
ret <- reassign False acc room
return (acc ++ [ret])
reassign :: Bool -> [Graph] -> Graph -> IO Graph
reassign p acc room@(GRoom ns b c t) =
return (acc `V.snoc` ret)
reassign :: Bool -> V.Vector Graph -> Graph -> IO Graph
reassign p acc room@(GRoom ns b _ _) =
if p
then do
if actualRoomType b imat == Offi
then do
let neigh = filter (all ((/= Hall) . snd) . neighbs) $
catMaybes
(map
(\n -> findNeighbor n b imat onlyrooms)
let neigh = V.filter (all ((/= Hall) . snd) . neighbs) $
V.fromList $ catMaybes $ V.toList $
(V.map
(\n -> findNeighbor n b onlyrooms)
nonhalls
)
onlyrooms = tail graph
onlyrooms = V.tail graph
nonhalls = ns -- filter ((/= Hall) . snd) ns
if not (null neigh) && any ((Offi /=) . flip actualRoomType imat . bounds) neigh
then
@ -456,19 +477,22 @@ assignClearance graph imat =
if actualRoomType b imat == Offi
then do
let neigh =
catMaybes
(map
(\n -> findNeighbor n b imat onlyrooms)
V.fromList $ catMaybes $ V.toList $
(V.map
(\n -> findNeighbor n b onlyrooms)
nonhalls
)
onlyrooms = connects (head acc)
onlyrooms = connects (V.head acc)
nonhalls = ns -- filter ((/= Hall) . snd) ns
ret <- if null neigh
then doRandomAssign room
else doBoundedAssign room (clearance $ head neigh)
else doBoundedAssign room (clearance $ V.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 =
@ -490,8 +514,12 @@ doBoundedAssign g b = do
{ clearance = c
}
findNeighbor :: (GraphDirection, TileState) -> Boundaries Int -> M.Matrix TileState -> [Graph] -> Maybe Graph
findNeighbor (dir, _) bnds imat ingraph
findNeighbor
:: (GraphDirection, TileState)
-> Boundaries Int
-> V.Vector Graph
-> Maybe Graph
findNeighbor (dir, _) bnds ingraph
| dir == North =
let row = fst (matmin bnds) - 2
col = snd (matmin bnds) + ((snd (matmax bnds) - snd (matmin bnds)) `div` 2)
@ -509,106 +537,111 @@ findNeighbor (dir, _) bnds imat ingraph
col = snd (matmin bnds) - 2
in postprocess row col
where
neighTile row col = imat M.! (row, col)
postprocess row col =
let filtered = filter
let filtered = V.filter
(inBounds (V2 row col) . bounds)
ingraph
in
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"
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*")
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
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

View file

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

View file

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

View file

@ -7,57 +7,59 @@ import Graphics.Rendering.OpenGL.GL.FlushFinish (finish)
import Control.Concurrent (forkIO)
import Control.Concurrent.MVar
import Control.Monad (when)
import Control.Monad
import Control.Monad.Trans.Resource (ResIO)
import qualified Data.Map as M
import qualified Data.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 :: Affection UserData ()
loadLoad = do
loadLoad :: UserData -> Affection ()
loadLoad ud = do
ad <- A.get
ud <- getAffection
progress <- liftIO $ newMVar (0, "Starting up")
future <- liftIO newEmptyMVar
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
_ <- liftIO $ createFont (nano ud) "bedstead"
(FileName "assets/font/Bedstead-Semicondensed.ttf")
_ <- liftIO $ forkIO $
loadFork
(worldState ud)
(fromJust $ window ud)
(fromJust $ threadContext ud)
wState
(fromJust curWin)
(fromJust tContext)
(nano ud)
future
progress
SDL.glMakeCurrent (fromJust $ window ud) (glContext ad)
putAffection ud
{ stateMVar = future
, stateProgress = progress
, state = Load
, assetFonts = M.fromList
[ (FontBedstead, "bedstead")
]
}
(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")
]
)
loadFork
:: SystemState Entity (AffectionState (AffectionData UserData) IO)
:: SystemState Entity (AffectionState (AffectionData) ResIO)
-> SDL.Window
-> SDL.GLContext
-> Context
-> MVar
( SystemState Entity (AffectionState (AffectionData UserData) IO)
( SystemState Entity (AffectionState (AffectionData) ResIO)
, StateData
)
-> MVar (Float, T.Text)
@ -70,202 +72,202 @@ loadFork ws win glc nvg future progress = do
( p + increment
, "Loading icon \"conntroller_blue\""
)))
mcontrblue <- createImage nvg (FileName "assets/icons/controller_blue.png") 0
mcontrblue <- createImage nvg (FileName "assets/icons/controller_blue.png") (S.singleton ImagePremultiplied)
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Loading icon \"controller_blue\""
)))
mcontrgreen <- createImage nvg (FileName "assets/icons/controller_green.png") 0
mcontrgreen <- createImage nvg (FileName "assets/icons/controller_green.png") (S.singleton ImagePremultiplied)
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Loading icon \"controller_green\""
)))
mkbdblue <- createImage nvg (FileName "assets/icons/keyboard_blue.png") 0
mkbdblue <- createImage nvg (FileName "assets/icons/keyboard_blue.png") (S.singleton ImagePremultiplied)
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Loading icon \"keyboard_blue\""
)))
mkbdgreen <- createImage nvg (FileName "assets/icons/keyboard_green.png") 0
mkbdgreen <- createImage nvg (FileName "assets/icons/keyboard_green.png") (S.singleton ImagePremultiplied)
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Loading icon \"keyboard_green\""
)))
marrow <- createImage nvg (FileName "assets/icons/arrow.png") 0
marrow <- createImage nvg (FileName "assets/icons/arrow.png") (S.singleton ImagePremultiplied)
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Loading asset \"wall_asc\""
)))
mwallasc <- createImage nvg (FileName "assets/walls/wall_asc.png") 0
mwallasc <- createImage nvg (FileName "assets/walls/wall_asc.png") (S.singleton ImagePremultiplied)
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Loading asset \"wall_desc\""
)))
mwalldesc <- createImage nvg (FileName "assets/walls/wall_desc.png") 0
mwalldesc <- createImage nvg (FileName "assets/walls/wall_desc.png") (S.singleton ImagePremultiplied)
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Loading asset \"wall_corner_n\""
)))
mwallcornern <- createImage nvg (FileName "assets/walls/wall_corner_n.png") 0
mwallcornern <- createImage nvg (FileName "assets/walls/wall_corner_n.png") (S.singleton ImagePremultiplied)
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Loading asset \"wall_corner_e\""
)))
mwallcornere <- createImage nvg (FileName "assets/walls/wall_corner_e.png") 0
mwallcornere <- createImage nvg (FileName "assets/walls/wall_corner_e.png") (S.singleton ImagePremultiplied)
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Loading asset \"wall_corner_s\""
)))
mwallcorners <- createImage nvg (FileName "assets/walls/wall_corner_s.png") 0
mwallcorners <- createImage nvg (FileName "assets/walls/wall_corner_s.png") (S.singleton ImagePremultiplied)
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Loading asset \"wall_corner_w\""
)))
mwallcornerw <- createImage nvg (FileName "assets/walls/wall_corner_w.png") 0
mwallcornerw <- createImage nvg (FileName "assets/walls/wall_corner_w.png") (S.singleton ImagePremultiplied)
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Loading asset \"wall_t_ne\""
)))
mwalltne <- createImage nvg (FileName "assets/walls/wall_t_ne.png") 0
mwalltne <- createImage nvg (FileName "assets/walls/wall_t_ne.png") (S.singleton ImagePremultiplied)
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Loading asset \"wall_t_se\""
)))
mwalltse <- createImage nvg (FileName "assets/walls/wall_t_se.png") 0
mwalltse <- createImage nvg (FileName "assets/walls/wall_t_se.png") (S.singleton ImagePremultiplied)
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Loading asset \"wall_t_sw\""
)))
mwalltsw <- createImage nvg (FileName "assets/walls/wall_t_sw.png") 0
mwalltsw <- createImage nvg (FileName "assets/walls/wall_t_sw.png") (S.singleton ImagePremultiplied)
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Loading asset \"wall_t_nw\""
)))
mwalltnw <- createImage nvg (FileName "assets/walls/wall_t_nw.png") 0
mwalltnw <- createImage nvg (FileName "assets/walls/wall_t_nw.png") (S.singleton ImagePremultiplied)
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Loading asset \"wall_cross\""
)))
mwallcross <- createImage nvg (FileName "assets/walls/wall_cross.png") 0
mwallcross <- createImage nvg (FileName "assets/walls/wall_cross.png") (S.singleton ImagePremultiplied)
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Loading asset \"box1\""
)))
mmiscbox1 <- createImage nvg (FileName "assets/misc/box1.png") 0
mmiscbox1 <- createImage nvg (FileName "assets/misc/box1.png") (S.singleton ImagePremultiplied)
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Loading asset \"tableSW\""
)))
mtableSW <- createImage nvg (FileName "assets/table/tableSW.png") 0
mtableSW <- createImage nvg (FileName "assets/table/tableSW.png") (S.singleton ImagePremultiplied)
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Loading asset \"tableSE\""
)))
mtableSE <- createImage nvg (FileName "assets/table/tableSE.png") 0
mtableSE <- createImage nvg (FileName "assets/table/tableSE.png") (S.singleton ImagePremultiplied)
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Loading asset \"tableNE\""
)))
mtableNE <- createImage nvg (FileName "assets/table/tableNE.png") 0
mtableNE <- createImage nvg (FileName "assets/table/tableNE.png") (S.singleton ImagePremultiplied)
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Loading asset \"tableNW\""
)))
mtableNW <- createImage nvg (FileName "assets/table/tableNW.png") 0
mtableNW <- createImage nvg (FileName "assets/table/tableNW.png") (S.singleton ImagePremultiplied)
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Loading asset \"tableC1\""
)))
mtablec1 <- createImage nvg (FileName "assets/table/tablec1.png") 0
mtablec1 <- createImage nvg (FileName "assets/table/tablec1.png") (S.singleton ImagePremultiplied)
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Loading asset \"tableC2\""
)))
mtablec2 <- createImage nvg (FileName "assets/table/tablec2.png") 0
mtablec2 <- createImage nvg (FileName "assets/table/tablec2.png") (S.singleton ImagePremultiplied)
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Loading asset \"tableC3\""
)))
mtablec3 <- createImage nvg (FileName "assets/table/tablec3.png") 0
mtablec3 <- createImage nvg (FileName "assets/table/tablec3.png") (S.singleton ImagePremultiplied)
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Loading asset \"tableC4\""
)))
mtablec4 <- createImage nvg (FileName "assets/table/tablec4.png") 0
mtablec4 <- createImage nvg (FileName "assets/table/tablec4.png") (S.singleton ImagePremultiplied)
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Loading asset \"tableCorner\""
)))
mtableC <- createImage nvg (FileName "assets/table/tableCorner.png") 0
mtableC <- createImage nvg (FileName "assets/table/tableCorner.png") (S.singleton ImagePremultiplied)
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Loading asset \"flipchart\""
)))
mmiscFlipchart <- createImage nvg (FileName "assets/misc/flipchart.png") 0
mmiscFlipchart <- createImage nvg (FileName "assets/misc/flipchart.png") (S.singleton ImagePremultiplied)
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Loading asset \"plant1\""
)))
mmiscPlant1 <- createImage nvg (FileName "assets/misc/plant1.png") 0
mmiscPlant1 <- createImage nvg (FileName "assets/misc/plant1.png") (S.singleton ImagePremultiplied)
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Loading asset \"plant2\""
)))
mmiscPlant2 <- createImage nvg (FileName "assets/misc/plant2.png") 0
mmiscPlant2 <- createImage nvg (FileName "assets/misc/plant2.png") (S.singleton ImagePremultiplied)
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Loading asset \"watercooler\""
)))
mmiscWatercooler <- createImage nvg (FileName "assets/misc/watercooler.png") 0
mmiscWatercooler <- createImage nvg (FileName "assets/misc/watercooler.png") (S.singleton ImagePremultiplied)
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Loading asset \"vending machine\""
)))
mmiscVending <- createImage nvg (FileName "assets/misc/vending.png") 0
mmiscVending <- createImage nvg (FileName "assets/misc/vending.png") (S.singleton ImagePremultiplied)
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Loading asset \"Cabinet with Coffee machine SW\""
)))
mcabCoffeeSW <- createImage nvg (FileName "assets/cabinet/cabCoffeeSW.png") 0
mcabCoffeeSW <- createImage nvg (FileName "assets/cabinet/cabCoffeeSW.png") (S.singleton ImagePremultiplied)
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Loading asset \"Cabinet with Coffee machine SE\""
)))
mcabCoffeeSE <- createImage nvg (FileName "assets/cabinet/cabCoffeeSE.png") 0
mcabCoffeeSE <- createImage nvg (FileName "assets/cabinet/cabCoffeeSE.png") (S.singleton ImagePremultiplied)
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Loading asset \"Cabinet with sink SW\""
)))
mcabSinkSW <- createImage nvg (FileName "assets/cabinet/cabSinkSW.png") 0
mcabSinkSW <- createImage nvg (FileName "assets/cabinet/cabSinkSW.png") (S.singleton ImagePremultiplied)
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Loading asset \"Cabinet with sink SE\""
)))
mcabSinkSE <- createImage nvg (FileName "assets/cabinet/cabSinkSE.png") 0
mcabSinkSE <- createImage nvg (FileName "assets/cabinet/cabSinkSE.png") (S.singleton ImagePremultiplied)
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Loading asset \"Cabinet with stove SW\""
)))
mcabStoveSW <- createImage nvg (FileName "assets/cabinet/cabStoveSW.png") 0
mcabStoveSW <- createImage nvg (FileName "assets/cabinet/cabStoveSW.png") (S.singleton ImagePremultiplied)
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Loading asset \"Cabinet with stove SE\""
)))
mcabStoveSE <- createImage nvg (FileName "assets/cabinet/cabStoveSE.png") 0
mcabStoveSE <- createImage nvg (FileName "assets/cabinet/cabStoveSE.png") (S.singleton ImagePremultiplied)
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Loading asset \"cabinet SW\""
)))
mcabinetSW <- createImage nvg (FileName "assets/cabinet/cabinetSW.png") 0
mcabinetSW <- createImage nvg (FileName "assets/cabinet/cabinetSW.png") (S.singleton ImagePremultiplied)
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Loading asset \"cabinet SE\""
)))
mcabinetSE <- createImage nvg (FileName "assets/cabinet/cabinetSE.png") 0
mcabinetSE <- createImage nvg (FileName "assets/cabinet/cabinetSE.png") (S.singleton ImagePremultiplied)
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Loading asset \"cabinet corner\""
)))
mcabinetCorner <- createImage nvg (FileName "assets/cabinet/cabinetCorner.png") 0
mcabinetCorner <- createImage nvg (FileName "assets/cabinet/cabinetCorner.png") (S.singleton ImagePremultiplied)
let micons =
[ mcontrblue, mcontrgreen, mkbdblue, mkbdgreen, marrow
]
@ -335,6 +337,18 @@ loadFork ws win glc nvg future progress = do
)))
jdoemWalking <- loadAnimationSprites "assets/jdoem.png" nvg
(zip (walkIds AnimJDoeM) walkConfigs)
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Loading Animation \"policem: standing\""
)))
policemStanding <- loadAnimationSprites "assets/policem.png" nvg
(zip (standIds AnimPoliceM) standConfigs)
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Loading Animation \"policem: walking\""
)))
policemWalking <- loadAnimationSprites "assets/policem.png" nvg
(zip (walkIds AnimPoliceM) walkConfigs)
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Loading Animation \"copier: stand\""
@ -491,9 +505,13 @@ loadFork ws win glc nvg future progress = do
]
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Handing over"
, "GL_Finish"
)))
finish
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Handing over"
)))
putMVar future
( ws
, LoadData
@ -503,6 +521,8 @@ loadFork ws win glc nvg future progress = do
playerWalking ++
jdoemStanding ++
jdoemWalking ++
policemStanding ++
policemWalking ++
copierStand ++
copierCopy ++
cornerComputerOff ++
@ -525,30 +545,24 @@ loadFork ws win glc nvg future progress = do
}
)
drawLoad :: Affection UserData ()
drawLoad = do
ud <- getAffection
drawLoad :: UserData -> Affection ()
drawLoad ud = do
progress <- liftIO $ readMVar (stateProgress ud)
liftIO $ do
logIO A.Verbose ("LoadProgress: " ++ show progress)
logIO A.Verbose ("LoadProgress: " <> fromString (show progress))
drawLoadScreen ud progress
updateLoad :: Double -> Affection UserData ()
updateLoad _ = do
ud <- getAffection
updateLoad :: UserData -> Double -> Affection ()
updateLoad ud _ = do
mwsld <- liftIO $ tryTakeMVar (stateMVar ud)
case mwsld of
Just (_, ld) -> do
liftIO $ logIO A.Debug "loaded assets, entering menu"
putAffection ud
{ assetImages = loadAssetImages ld
, assetAnimations = loadAssetAnims ld
, assetIcons = loadAssetIcons ld
-- , state = Main WorldMap
-- , state = Menu Connect
, stateData = None
}
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
-- loadMap
loadMenu
loadMenu ud
Nothing ->
return ()

View file

@ -4,7 +4,6 @@ module Main where
import Affection as A
import Data.Ecstasy
import Data.Ecstasy.Types
import qualified SDL
@ -16,7 +15,9 @@ import Foreign.C.Types (CInt(..))
import Data.Maybe (fromJust)
import Control.Monad (when)
import Control.Monad
import Control.Concurrent.MVar
import Control.Monad.Trans.Resource (allocate)
-- internal imports
@ -28,101 +29,108 @@ 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"
, 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
}
{ 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
withAffection config
pre :: Affection UserData ()
pre = do
pre :: UserData -> Affection ()
pre ud = do
ad <- A.get
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
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)
_ <- partSubscribe k toggleFullScreen
_ <- 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
}
_ <- 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
quitGame :: KeyboardMessage -> Affection UserData ()
quitGame (MsgKeyboardEvent _ _ SDL.Pressed False sym)
| SDL.keysymKeycode sym == SDL.KeycodeEscape = quit
quitGame :: UserData -> KeyboardMessage -> Affection ()
quitGame ud (MsgKeyboardEvent _ _ SDL.Pressed False sym)
| SDL.keysymKeycode sym == SDL.KeycodeEscape =
void $ liftIO $ swapMVar (doNextStep ud) False
| SDL.keysymKeycode sym == SDL.KeycodeF5 = do
ad <- A.get
ud <- getAffection
when (state ud == Main WorldMap || state ud == Main MindMap) $ do
curState <- liftIO $ readMVar (state ud)
when (curState == Main WorldMap || curState == Main MindMap) $ do
let Subsystems w m k j t = subsystems ud
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 ()
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 ()
toggleFullScreen :: KeyboardMessage -> Affection UserData ()
toggleFullScreen :: KeyboardMessage -> Affection ()
toggleFullScreen (MsgKeyboardEvent _ _ SDL.Pressed False sym)
| SDL.keysymKeycode sym == SDL.KeycodeF11 = toggleScreen
| SDL.keysymKeycode sym == SDL.KeycodeF11 = toggleScreen 0
| otherwise = return ()
toggleFullScreen _ = return ()
update :: Double -> Affection UserData ()
update dt = do
ud <- getAffection
smUpdate (state ud) dt
update :: UserData -> Double -> Affection ()
update ud dt = do
curState <- liftIO $ readMVar (state ud)
smUpdate curState ud dt
draw :: Affection UserData ()
draw = do
ud <- getAffection
draw :: UserData -> Affection ()
draw ud = do
curState <- liftIO $ readMVar (state ud)
liftIO $ beginFrame (nano ud) 1280 720 1
smDraw (state ud)
smDraw curState ud
liftIO $ endFrame (nano ud)
handle :: [SDL.EventPayload] -> Affection UserData ()
handle evs = do
s <- state <$> getAffection
smEvent s evs
handle :: UserData -> [SDL.EventPayload] -> Affection ()
handle ud evs = do
s <- liftIO $ readMVar (state ud)
smEvent s ud evs
exitOnWindowClose :: WindowMessage -> Affection UserData ()
exitOnWindowClose (MsgWindowClose _ _) = do
exitOnWindowClose :: UserData -> WindowMessage -> Affection ()
exitOnWindowClose ud (MsgWindowClose _ _) = do
liftIO $ logIO A.Debug "Window Closed"
quit
exitOnWindowClose _ = return ()
void $ liftIO $ swapMVar (doNextStep ud) False
exitOnWindowClose _ _ = return ()
clean :: UserData -> IO ()
clean ud =
SDL.glDeleteContext $ fromJust $ threadContext ud
clean ud = do
tContext <- readMVar (threadContext ud)
SDL.glDeleteContext $ fromJust tContext

View file

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

View file

@ -11,8 +11,8 @@ import qualified SDL
import NanoVG hiding (V2(..))
import Control.Monad (when, void)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.State.Strict (evalStateT)
import Control.Monad.Trans.Resource (ResIO, runResourceT)
import Control.Concurrent.MVar
import Control.Concurrent (forkIO)
import Control.Parallel.Strategies hiding (dot)
@ -23,7 +23,9 @@ import qualified Data.Text as T
import Data.Matrix as M
import Data.Ecstasy as E
import Data.Maybe
import Data.List as L (sortOn, partition, find)
import Data.List as L
import qualified Data.Vector as V
import Data.String
import System.Random (randomRIO)
@ -42,63 +44,49 @@ import NPC
import Animation
import Collision
loadMap :: Affection UserData ()
loadMap = do
ud <- getAffection
loadMap :: UserData -> Affection ()
loadMap ud = do
ad <- get
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
}
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)
changeMaps :: KeyboardMessage -> Affection UserData ()
changeMaps (MsgKeyboardEvent _ _ SDL.Pressed False sym)
changeMaps :: UserData -> KeyboardMessage -> Affection ()
changeMaps ud (MsgKeyboardEvent _ _ SDL.Pressed False sym)
| SDL.keysymKeycode sym == SDL.KeycodeF1 = do
ud <- getAffection
case state ud of
curState <- liftIO $ readMVar (state ud)
case curState of
Main MindMap ->
putAffection ud
{ state = Main WorldMap
}
void $ liftIO $ swapMVar (state ud) (Main WorldMap)
Main WorldMap ->
putAffection ud
{ state = Main MindMap
}
void $ liftIO $ swapMVar (state ud) (Main MindMap)
_ -> return ()
| otherwise = return ()
changeMaps _ = return ()
changeMaps _ _ = return ()
changeMaps2 :: ActionMessage -> Affection UserData ()
changeMaps2 (ActionMessage ActSwitchMap _) = do
ud <- getAffection
case state ud of
changeMaps2 :: UserData -> ActionMessage -> Affection ()
changeMaps2 ud (ActionMessage ActSwitchMap _) = do
curState <- liftIO $ readMVar (state ud)
case curState of
Main MindMap ->
putAffection ud
{ state = Main WorldMap
}
void $ liftIO $ swapMVar (state ud) (Main WorldMap)
Main WorldMap ->
putAffection ud
{ state = Main MindMap
}
void $ liftIO $ swapMVar (state ud) (Main MindMap)
_ -> return ()
changeMaps2 _ = return ()
changeMaps2 _ _ = return ()
loadMapFork
:: UserData
-> AffectionData UserData
-> MVar (SystemState Entity (AffectionState (AffectionData UserData) IO), StateData)
-> AffectionData
-> MVar (SystemState Entity (AffectionState AffectionData ResIO), StateData)
-> MVar (Float, T.Text)
-> IO ()
loadMapFork ud ad future progress = do
@ -107,7 +95,7 @@ loadMapFork ud ad future progress = do
fc = FloorConfig
(V2 10 10)
[(V2 5 5), (V2 5 20)]
(50, 50)
(40, 40)
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Building floor"
@ -136,13 +124,14 @@ loadMapFork ud ad future progress = do
( p + increment
, "Placing furniture"
)))
(!inter, !rawrps) <- placeInteriorIO mat imgmat exits gr
(!inter, !rawrps) <- placeInteriorIO mat imgmat exits (V.toList gr)
let !rps = ReachPoint Elevator (fcElevator fc) SE 0 : rawrps
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Creating WorldState"
)))
(nws, mmimgmat) <- evalStateT (runState (yieldSystemT (worldState ud) $ do
wState <- liftIO $ readMVar (worldState ud)
(nws, mmimgmat) <- runResourceT $ evalStateT (runState (yieldSystemT wState $ do
liftIO $ modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Registering copiers into WorldState"
@ -158,7 +147,12 @@ loadMapFork ud ad future progress = do
, objType = Just ObjCopier
, objState = Just "idle"
}
) (A.log A.Debug ("number of copiers: " ++ show (length copiers)) copiers)
)
(A.log
A.Debug
("number of copiers: " <> fromString (show $ length copiers))
copiers
)
liftIO $ modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Registering computers into WorldState"
@ -179,7 +173,12 @@ loadMapFork ud ad future progress = do
, objType = Just ObjComputer
, objState = Just "off"
}
) (A.log A.Debug ("number of computers: " ++ show (length computers)) computers)
)
(A.log
A.Debug
("number of computers: " <> fromString (show $ length computers))
computers
)
liftIO $ modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Registering toilets into WorldState"
@ -194,7 +193,12 @@ loadMapFork ud ad future progress = do
, objAccess = Just [(V2 0 (-1), dir)]
, objType = Just ObjToilet
}
) (A.log A.Debug ("number of toilets: " ++ show (length toilets)) toilets)
)
(A.log
A.Debug
("number of toilets: " <> fromString (show $ length toilets))
toilets
)
liftIO $ modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Preparing MindMap graph"
@ -229,7 +233,9 @@ 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: " ++ show (length computers)
liftIO $ A.logIO
A.Debug
("number of placed NPCs: " <> fromString (show $ length computers))
liftIO $ modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Registering NPCs into WorldState"
@ -243,22 +249,25 @@ loadMapFork ud ad future progress = do
<*> (randomRIO (0, 1))
<*> (randomRIO (0, 1))
<*> (randomRIO (0, 1))
let room = head
(Prelude.filter
police <- liftIO $ randomRIO (0 :: Int, 9 :: Int)
let room = V.head
(V.filter
((inBounds $ pointCoord cpr) . bounds)
(Types.connects (head gr) ++ tail gr)
(V.fromList $
V.toList (Types.connects (V.head gr)) ++ (V.toList (V.tail gr)))
)
void $ createEntity $ newEntity
{ 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 AnimJDoeM "standing" SE) 0 0
, anim = Just $ AnimState
(AnimId (if police == 0 then AnimPoliceM else AnimJDoeM) "standing" SE) 0 0
}
) computers
liftIO $ modifyMVar_ progress (return . (\(p, _) ->
@ -266,17 +275,18 @@ loadMapFork ud ad future progress = do
, "Registering doors into WorldState"
)))
mapM_ (\door -> do
let rooms = Prelude.foldl
let rooms = V.foldl
(\acc coord ->
let rs = Prelude.filter ((inBounds coord) . bounds) graph
let rs = V.filter ((inBounds coord) . bounds) graph
in
if not (Prelude.null rs)
then (coord, head rs) : acc
if not (V.null rs)
then (coord, V.head rs) `V.cons` acc
else acc
)
[]
coords
graph = Types.connects (head gr) ++ tail gr
V.empty
(V.fromList coords)
graph = V.fromList $
(V.toList $ Types.connects (V.head gr)) ++ (V.toList $ V.tail gr)
coords = Prelude.map (door +) deltas
deltas =
[ V2 0 1
@ -285,18 +295,19 @@ loadMapFork ud ad future progress = do
, V2 0 (-1)
]
wall = Prelude.filter
(\delta ->
let V2 r c = door + delta
(\ddelta ->
let V2 r c = door + ddelta
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 (maximum $ 0 : Prelude.map clearance (Prelude.map snd rooms))
, clearanceLvl = Just (V.maximum $
0 `V.cons` V.map clearance (V.map snd rooms))
, anim = Just $ AnimState (AnimId AnimDoor0 "shut" orientation) 0 1
, obstacle = Just $ case orientation of
NW -> Boundaries (4/9, 0) (5/9, 1)
@ -330,19 +341,19 @@ loadMapFork ud ad future progress = do
then Nothing
else a)
(M.toList inter)
putMVar future (nws, MainData
void $ putMVar future (nws, MainData
{ mapMat = mat
, imgMat = retMat
, reachPoints = rps
, reachPoints = V.fromList rps
, mmImgMat = mmimgmat
, roomGraph = gr
})
movePlayerKbd :: KeyboardMessage -> Affection UserData ()
movePlayerKbd (MsgKeyboardEvent _ _ press False sym)
movePlayerKbd :: UserData -> KeyboardMessage -> Affection ()
movePlayerKbd ud (MsgKeyboardEvent _ _ press False sym)
| SDL.keysymKeycode sym == SDL.KeycodeW = do
ud <- getAffection
(nws, _) <- yieldSystemT (worldState ud) $
wState <- liftIO $ readMVar (worldState ud)
(nws, _) <- yieldSystemT wState $
emap allEnts $ do
with player
(V2 vx _) <- query xyvel
@ -352,12 +363,10 @@ movePlayerKbd (MsgKeyboardEvent _ _ press False sym)
return $ unchanged
{ xyvel = Set $ V2 vx ry
}
putAffection ud
{ worldState = nws
}
void $ liftIO $ swapMVar (worldState ud) nws
| SDL.keysymKeycode sym == SDL.KeycodeS = do
ud <- getAffection
(nws, _) <- yieldSystemT (worldState ud) $
wState <- liftIO $ readMVar (worldState ud)
(nws, _) <- yieldSystemT wState $
emap allEnts $ do
with player
(V2 vx _) <- query xyvel
@ -367,12 +376,10 @@ movePlayerKbd (MsgKeyboardEvent _ _ press False sym)
return $ unchanged
{ xyvel = Set $ V2 vx ry
}
putAffection ud
{ worldState = nws
}
void $ liftIO $ swapMVar (worldState ud) nws
| SDL.keysymKeycode sym == SDL.KeycodeA = do
ud <- getAffection
(nws, _) <- yieldSystemT (worldState ud) $
wState <- liftIO $ readMVar (worldState ud)
(nws, _) <- yieldSystemT wState $
emap allEnts $ do
with player
(V2 _ vy) <- query xyvel
@ -382,12 +389,10 @@ movePlayerKbd (MsgKeyboardEvent _ _ press False sym)
return $ unchanged
{ xyvel = Set $ V2 rx vy
}
putAffection ud
{ worldState = nws
}
void $ liftIO $ swapMVar (worldState ud) nws
| SDL.keysymKeycode sym == SDL.KeycodeD = do
ud <- getAffection
(nws, _) <- yieldSystemT (worldState ud) $
wState <- liftIO $ readMVar (worldState ud)
(nws, _) <- yieldSystemT wState $
emap allEnts $ do
with player
(V2 _ vy) <- query xyvel
@ -397,16 +402,14 @@ movePlayerKbd (MsgKeyboardEvent _ _ press False sym)
return $ unchanged
{ xyvel = Set $ V2 rx vy
}
putAffection ud
{ worldState = nws
}
void $ liftIO $ swapMVar (worldState ud) nws
| otherwise = return ()
movePlayerKbd _ = return ()
movePlayerKbd _ _ = return ()
movePlayer2 :: ActionMessage -> Affection UserData ()
movePlayer2 (ActionMessage mov _) = do
ud <- getAffection
(nws, _) <- yieldSystemT (worldState ud) $
movePlayer2 :: UserData -> ActionMessage -> Affection ()
movePlayer2 ud (ActionMessage mov _) = do
wState <- liftIO $ readMVar (worldState ud)
(nws, _) <- yieldSystemT wState $
emap allEnts $ do
with player
V2 vx vy <- query xyvel
@ -418,66 +421,12 @@ movePlayer2 (ActionMessage mov _) = do
ActRight f -> V2 f vy
_ -> V2 vx vy
}
putAffection ud
{ worldState = nws
}
movePlayer2 _ = return ()
void $ liftIO $ swapMVar (worldState ud) nws
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
playerInteract2 :: UserData -> ActionMessage -> Affection ()
playerInteract2 ud (ActionMessage ActActivate _) = do
wState <- liftIO $ readMVar (worldState ud)
(nws, _) <- yieldSystemT wState $ do
pdata <- efor allEnts $ do
with player
with pos
@ -503,31 +452,30 @@ playerInteract2 (ActionMessage ActActivate _) = do
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 ("relEnts: " <> fromString (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
}
playerInteract2 _ = return ()
void $ liftIO $ swapMVar (worldState ud) nws
playerInteract2 _ _ = return ()
drawMap :: Affection UserData ()
drawMap = do
ud <- getAffection
drawMap :: UserData -> Affection ()
drawMap ud = do
sData <- liftIO $ readMVar (stateData ud)
wState <- liftIO $ readMVar (worldState ud)
let ctx = nano ud
case stateData ud of
case sData of
None -> liftIO $ do
progress <- readMVar (stateProgress ud)
drawLoadScreen ud progress
_ -> do
dt <- getDelta
(_, dat) <- yieldSystemT (worldState ud) $ do
(_, dat) <- yieldSystemT wState $ do
efor allEnts $ do
with pos
pos' <- query pos
player <- queryMaybe player
player' <- queryMaybe player
stat <- queryMaybe anim
mbnds <- queryMaybe obstacle
t <- queryMaybe objType
@ -535,7 +483,7 @@ drawMap = 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
@ -564,10 +512,10 @@ drawMap = do
([], [], [])
dat
V2 pr pc = playerPos
MainData _ _ _ _ gr = stateData ud
seekGraph = Types.connects (head gr) ++ tail gr
room = Prelude.filter (inBounds (fmap floor playerPos) . bounds) seekGraph
mat = imgMat (stateData ud)
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
cols = fromIntegral (ncols mat)
rows = fromIntegral (nrows mat)
tileWidth = 64 :: Double
@ -575,8 +523,8 @@ drawMap = do
x = realToFrac $ 640 + ((1 - pc) + (1 - pr)) * (tileWidth / 2)
y = realToFrac $ 360 + ((1 - pr) - (1 - pc)) * (tileHeight / 2)
partposanims = M.fromList
(nrows $ mapMat $ stateData ud)
(ncols $ mapMat $ stateData ud)
(nrows $ mapMat sData)
(ncols $ mapMat sData)
((reverse . fst)
(Prelude.foldl
(\(done, proc) coord ->
@ -585,8 +533,8 @@ drawMap = do
)
([], posanims)
((,)
<$> [1 .. (nrows $ mapMat $ stateData ud)]
<*> [1 .. (ncols $ mapMat $ stateData ud)]
<$> [1 .. (nrows $ mapMat sData)]
<*> [1 .. (ncols $ mapMat sData)]
)
)
)
@ -615,10 +563,37 @@ drawMap = do
closePath ctx
fillColor ctx (rgb 255 255 255)
fill ctx
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))
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
)
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))
mapM_ (\(V2 sr sc, pa, perc) -> when pa $ do
let lx = realToFrac $ 640 + ((sc - pc) +
(sr - pr)) * (tileWidth / 2) :: CFloat
@ -637,15 +612,20 @@ drawMap = do
closePath ctx
) posActions
fontSize ctx 20
fontFace ctx (assetFonts ud Map.! FontBedstead)
aFonts <- readMVar (assetFonts ud)
fontFace ctx (aFonts 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 $ head room) else "0"
<> (if not (Prelude.null room)
then T.pack (show $ clearance $ V.head room)
else "0"
)
-- <> "\nFor answers call 6350"
)
drawTile
:: UserData
@ -657,25 +637,23 @@ drawTile
-> Int
-> Maybe ImgId
-> IO ()
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)
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)
where
delimiter (V2 nr nc, as, mbnds) =
animFloats (asId as) ||
@ -699,7 +677,8 @@ drawTile ud ctx posanims pr pc row col img =
tileWidth = 64 :: Double
tileHeight = 32 :: Double
sorted = sortOn (\(V2 sr sc, _, mbnds) ->
let comp srow scol = (floor $ (1 - scol) * 100) + (floor $ srow * 100)
let comp srow scol =
((floor $ (1 - scol) * 100) :: Int) + ((floor $ srow * 100) :: Int)
in
case mbnds of
Just (Boundaries (minr, minc) (maxr, maxc)) ->
@ -720,38 +699,38 @@ drawTile ud ctx posanims pr pc row col img =
dist = distance (V2 (fromIntegral row) (fromIntegral col))
(V2 (realToFrac pr - 1) (realToFrac pc)) / 4
fact =
if isWall (fromJust img) &&
(pr <= fromIntegral row + minimum maxrs &&
pc >= fromIntegral col + maximum mincs)
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)
then min 1 dist
else 1
mb = maybe [] collisionObstacle img
drawAnim (V2 nr nc, as, _) = do
drawAnim (V2 nr nc, as, _) factor = do
let ax = realToFrac $ 640 + ((nc - pc) + (nr - pr)) * 32 - 32
ay = realToFrac $ 360 + ((nr - pr) - (nc - pc)) * 16 - 58
draw ud ax ay 64 74 1 as
Types.draw ud ax ay 64 74 (if isWallLike (aiVariation $ asId as) then factor else 1) as
updateMap :: Double -> Affection UserData ()
updateMap dt = do
ud <- getAffection
if stateData ud == None
updateMap :: UserData -> Double -> Affection ()
updateMap ud dt = do
osData <- liftIO $ readMVar (stateData ud)
if osData == None
then do
mstart <- liftIO $ tryTakeMVar (stateMVar ud)
case mstart of
Just (nws, mendat) -> do
putAffection ud
{ worldState = nws
, stateData = mendat
, state = Main WorldMap
}
updateMap 0.1
updateMap 0.1
updateMap 0.1
updateMap 19
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
liftIO $ logIO A.Debug "Loaded game data"
Nothing -> return ()
else do
(nws, _) <- yieldSystemT (worldState ud) $ do
wState <- liftIO $ readMVar (worldState ud)
sData <- liftIO $ readMVar (stateData ud)
aAnim <- liftIO $ readMVar (assetAnimations ud)
(nws, _) <- yieldSystemT wState $ do
obstacleBounds <- efor allEnts $ do
with obstacle
with pos
@ -761,11 +740,12 @@ updateMap dt = do
emap allEnts $ do
pos'@(V2 pr pc) <- query pos
vel' <- queryMaybe vel
rot' <- query rot
rot' <- fromMaybe N <$> queryMaybe rot
fact' <- fromMaybe 1 <$> queryMaybe velFact
xyv2 <- queryMaybe xyvel
stat <- query anim
let an = assetAnimations ud Map.! asId stat
let an = aAnim Map.! asId stat
mat = mapMat sData
ntime = asElapsedTime stat + dt
npos = pos' + fmap (* (dt * fact')) (fromMaybe (V2 0 0) vel')
dpos@(V2 dpr dpc) = npos - pos'
@ -782,16 +762,16 @@ updateMap dt = do
colldpos = dpos * Prelude.foldl
(\acc a ->
let ret = checkBoundsCollision2 pos' npos dt acc a
in A.log A.Verbose (show ret) ret)
in A.log A.Verbose (fromString $ show ret) ret)
(V2 1 1)
(
concatMap
nub $ concatMap
(\(dr, dc) ->
let bs = (++)
(maybe [] collisionObstacle (fromMaybe Nothing $ M.safeGet
(fromIntegral $ floor pr + dr)
(fromIntegral $ floor pc + dc)
(imgMat (stateData ud))))
(fromMaybe [] $ collisionObstacle <$> M.unsafeGet
(min (nrows mat) $ max 1 $ fromIntegral $ floor pr + dr)
(min (ncols mat) $ max 1 $ fromIntegral $ floor pc + dc)
(imgMat sData))
(Prelude.map snd $ Prelude.filter
(\((V2 br bc), _) ->
floor pr + dr == floor br &&
@ -866,7 +846,7 @@ updateMap dt = do
{ aiDirection = fromMaybe rot' (direction velo)
}
}
x -> nstat
_ -> nstat
ent = unchanged
{ pos = Set $ pos' + colldpos
, rot = Set $ fromMaybe rot' (direction (fromMaybe (V2 0 0) vel'))
@ -880,16 +860,16 @@ updateMap 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
@ -898,16 +878,15 @@ updateMap dt = do
e <- queryEnt
return (t, s, e)
mapM_ (\(t, s, e) ->
objectAction allRelEnts dt t s e
objectAction dt t s e
) tses
(nws2, _) <- yieldSystemT nws $ updateNPCs
(imgMat $ stateData ud)
(imgMat sData)
(mapMat sData)
nws
(Prelude.filter
(V.filter
(\p -> pointType p /= RoomExit)
(reachPoints $ stateData ud)
(reachPoints sData)
)
dt
putAffection ud
{ worldState = nws2
}
void $ liftIO $ swapMVar (worldState ud) nws2

View file

@ -10,91 +10,74 @@ 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 :: 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 ]
}
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]
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
}
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 ()
fullClean
switchBack
joyListener _ _ = 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*")
_ -> return ()
drawAdjust :: Affection UserData ()
drawAdjust = do
ud <- getAffection
drawAdjust :: Context -> Affection ()
drawAdjust ctx = do
liftIO $ do
let ctx = nano ud
save ctx
beginPath ctx
roundedRect ctx 440 310 400 100 10

View file

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

View file

@ -1,5 +1,6 @@
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
module NPC where
import Affection as A
@ -8,9 +9,13 @@ 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)
@ -29,7 +34,7 @@ import Object ()
getPosBounds
:: SystemT
Entity
(AffectionState (AffectionData UserData) IO)
(AffectionState AffectionData ResIO)
[(V2 Double, Boundaries Double)]
getPosBounds = do
efor allEnts $ do
@ -42,11 +47,12 @@ getPosBounds = do
updateNPCs
:: M.Matrix (Maybe ImgId)
-> SystemState Entity (AffectionState (AffectionData UserData) IO)
-> [ReachPoint]
-> M.Matrix TileState
-> SystemState Entity (AffectionState AffectionData ResIO)
-> V.Vector ReachPoint
-> Double
-> SystemT Entity (AffectionState (AffectionData UserData) IO) ()
updateNPCs imgmat ws rrp dt = do
-> SystemT Entity (AffectionState AffectionData ResIO) ()
updateNPCs imgmat tsmat ws rrp dt = do
updateStats dt
posbounds <- getPosBounds
moent <- catMaybes <$> eover allEnts (do
@ -62,8 +68,9 @@ updateNPCs imgmat ws rrp dt = do
pos' <- query pos
rot' <- query rot
lvl <- query clearanceLvl
stat <- query anim
npcState' <- query npcMoveState
let rp = filter ((lvl >=) . pointClearance) rrp
let rp = V.filter ((lvl >=) . pointClearance) rrp
case npcState' of
NPCStanding ttl future -> do
let nttl = ttl - dt
@ -102,77 +109,48 @@ updateNPCs imgmat ws rrp dt = do
})
NPCWalking path ->
if not (null path)
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')
})
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')
})
else 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
standStill imgmat tsmat pos' rot' ws posbounds rp
)
mapM_ (\(oent, npcent, mfuture) -> do
mts <- efor (anEnt oent) $ do
with objType
with objState
@ -205,14 +183,88 @@ updateNPCs imgmat ws rrp dt = do
let ttl = case head mntns of
Just (nt, ns) -> actionTime nt ns
Nothing -> 1
return unchanged
{ npcMoveState = Set $ NPCStanding ttl future
}
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
{ 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
})
updateStats
:: Double
-> SystemT Entity (AffectionState (AffectionData UserData) IO) ()
-> SystemT Entity (AffectionState AffectionData ResIO) ()
updateStats dt =
emap allEnts $ do
with npcStats
@ -263,7 +315,7 @@ getObject npos = do
oacc <- query objAccess
ent <- queryEnt
return (ent, pos', oacc)
liftIO $ logIO A.Verbose ("candidates: " ++ show candidates)
liftIO $ logIO A.Verbose ("candidates: " <> fromString (show candidates))
return $
filter (\(_, p, deltaors) ->
any (\(delta, _) -> fmap floor p + delta == fmap floor npos) deltaors
@ -271,35 +323,77 @@ getObject npos = do
getPath
:: V2 Int
-> MVar [V2 Int]
-> [ReachPoint]
-> MVar [[V2 Int]]
-> V.Vector ReachPoint
-> M.Matrix (Maybe ImgId)
-> M.Matrix TileState
-> [(V2 Double, Boundaries Double)]
-> IO ()
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)
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)
path = astarAppl imgmat posbounds ntarget pos'
logIO A.Verbose ("seeking path from " ++ show pos' ++ " to " ++ show ntarget)
logIO
A.Verbose
("seeking path from " <>
fromString (show pos') <>
" to " <>
fromString (show ntarget)
)
case path of
Nothing -> do
logIO A.Error ("No path from " ++ show pos' ++ " to " ++ show ntarget)
logIO
A.Error
("No path from " <>
fromString (show pos') <>
" to " <>
fromString ( show ntarget)
)
putMVar mvar []
-- getPath pos' mvar rp imgmat posbounds
Just p -> putMVar mvar p
Just p -> putMVar mvar (chewPath tsmat 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 posbounds = do
getPathTo pos' mvar target imgmat tsmat posbounds = do
let path = astarAppl imgmat posbounds target pos'
logIO A.Verbose ("seeking path from " ++ show pos' ++ " to " ++ show target)
logIO
A.Verbose
("seeking path from " <>
fromString (show pos') <>
" to " <>
fromString (show target)
)
case path of
Nothing -> do
logIO A.Error ("No path from " ++ show pos' ++ " to " ++ show target)
Just p -> putMVar mvar p
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

View file

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

View file

@ -3,14 +3,7 @@
{-# LANGUAGE FlexibleInstances #-}
module Object where
import Affection as A
import Control.Monad (when)
import Data.Ecstasy
import Data.Maybe
import Linear
-- internal imports
@ -21,13 +14,13 @@ import Object.Copier
import Object.Door
instance ObjectAction ObjType ObjState where
objectAction relEnts dt t@ObjCopier s ent = copierObjectAction relEnts dt t s ent
objectAction dt t@ObjCopier s ent = copierObjectAction dt t s ent
objectAction relEnts dt t@ObjComputer s ent = computerObjectAction relEnts dt t s ent
objectAction dt t@ObjComputer s ent = computerObjectAction dt t s ent
objectAction relEnts dt t@ObjDoor s ent = doorObjectAction relEnts dt t s ent
objectAction dt t@ObjDoor s ent = doorObjectAction dt t s ent
objectAction _ _ _ _ _ = return ()
objectAction _ _ _ _ = return ()
objectTransition t@ObjCopier s pa ent aent =
copierObjectTransition t s pa ent aent

View file

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

View file

@ -6,11 +6,11 @@ module Object.Computer where
import Affection as A
import Control.Monad (when)
import Control.Monad.IO.Class (MonadIO(..))
import Data.Ecstasy
import Data.Maybe
import Data.String
import Linear
@ -18,17 +18,16 @@ import Linear
import Types
import Object.ActionTime
import Object.ActionTime ()
computerObjectAction
:: (Monad m, MonadIO m)
=> [(Ent, V2 Double, Direction, Word)]
-> Double
=> 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
@ -40,7 +39,7 @@ computerObjectAction _ dt t@ObjComputer s@"on" ent = do
mtime <- queryMaybe objStateTime
case mtime of
Nothing -> do
liftIO $ logIO Verbose ("Computer " ++ show ent ++ ": on!")
liftIO $ logIO Verbose ("Computer " <> fromString (show ent) <> ": on!")
let dur = actionTime t s
return unchanged
{ objStateTime = Set dur
@ -66,7 +65,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
@ -78,7 +77,9 @@ computerObjectAction _ dt t@ObjComputer s@"hack" ent = do
mtime <- queryMaybe objStateTime
case mtime of
Nothing -> do
liftIO $ logIO Verbose ("Computer " ++ show ent ++ ": hacking!")
liftIO $ logIO
Verbose
("Computer " <> fromString (show ent) <> ": hacking!")
return unchanged
{ objStateTime = Set (actionTime t s)
}
@ -101,7 +102,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)
@ -112,7 +113,8 @@ computerObjectTransition
-> Maybe Ent
-> SystemT Entity m (Entity 'SetterOf)
computerObjectTransition ObjComputer "off" pa ent (Just aent) = do
[dir] <- efor (anEnt aent) (query rot)
ldir <- efor (anEnt aent) (query rot)
let dir = head ldir
e <- efor (anEnt ent) $ do
solved <- queryMaybe objSolved
if pa

View file

@ -10,27 +10,24 @@ 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)
=> [(Ent, V2 Double, Direction, Word)]
-> Double
=> 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 " ++ show ent ++ ": copying!")
liftIO $ logIO Verbose
("Copier " <> fromString (show ent) <> ": copying!")
return unchanged
{ objStateTime = Set (actionTime t s)
, objState = Set "copying"
@ -46,7 +43,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)

View file

@ -7,19 +7,25 @@ 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 Linear
import Data.String
-- internal imports
import Types
import Object.ActionTime
import Object.ActionTime ()
doorObjectAction _ dt t@ObjDoor s@"open" ent = do
doorObjectAction :: (Eq a, IsString a, MonadIO m)
=> Double
-> ObjType
-> a
-> Ent
-> SystemT Entity m ()
doorObjectAction dt t@ObjDoor s@"open" ent = do
emap (anEnt ent) $ do
mtime <- queryMaybe objStateTime
case mtime of
@ -36,49 +42,33 @@ 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 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)
doorObjectAction _ _ _ _ = return ()
doorObjectAction _ _ _ _ _ = return ()
doorObjectTransition t@ObjDoor s@"shut" _ ent (Just aent) = do
[clearance] <- efor (anEnt aent) (query clearanceLvl)
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)
e <- efor (anEnt ent) $ do
dir <- query rot
oclear <- query clearanceLvl
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
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
then do
liftIO $ A.logIO A.Verbose ("door " ++ show oclear ++ " opens")
liftIO $ A.logIO
A.Verbose
("door " <> fromString (show ent) <> " opens")
let nstat = AnimState
(AnimId AnimDoor0 "open" dir)
0
@ -86,8 +76,9 @@ doorObjectTransition t@ObjDoor s@"shut" _ ent (Just aent) = do
return unchanged
{ objState = Set "open"
, objStateTime = Set (actionTime t ("open" :: String))
, objUsedBy = Set aent
, anim = Set nstat
, anim = if fromMaybe True (fmap (0 >) mttl)
then Set nstat
else Keep
, obstacle = Unset
}
else
@ -108,7 +99,6 @@ 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)

View file

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

View file

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

View file

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

View file

@ -34,6 +34,7 @@ data Cluster
| ClusterWatercooler
| ClusterVending
| ClusterCabinets
| ClusterBreakroomTable
deriving (Enum, Bounded, Show)
-- row -> NS; col -> WE
@ -72,18 +73,6 @@ 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]
@ -232,12 +221,14 @@ 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]
@ -250,13 +241,10 @@ 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
]
@ -292,6 +280,12 @@ 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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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