Compare commits

..

1 commit

Author SHA1 Message Date
208ea1dd24 handle multiwin branch 2019-04-30 00:22:29 +02:00
34 changed files with 1179 additions and 1152 deletions

1
.envrc
View file

@ -1 +0,0 @@
use flake

2
.gitignore vendored
View file

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

Binary file not shown.

Binary file not shown.

Before

Width:  |  Height:  |  Size: 17 KiB

2
cabal.config Normal file
View file

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

3
cabal.project Normal file
View file

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

View file

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

View file

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

272
shell.nix
View file

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

View file

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

View file

@ -11,9 +11,7 @@ import Codec.Picture as CP
import Codec.Picture.Extra import Codec.Picture.Extra
import Control.Concurrent.STM import Control.Concurrent.STM
import Control.Concurrent.MVar
import Data.String
import qualified Data.Set as S import qualified Data.Set as S
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
import Data.ByteString.Lazy (toStrict) import Data.ByteString.Lazy (toStrict)
@ -37,26 +35,21 @@ init = do
<*> (SubTranslator <$> newTVarIO []) <*> (SubTranslator <$> newTVarIO [])
_ <- glewInit _ <- glewInit
nvg <- createGL3 (S.fromList [NanoVG.Debug, Antialias, StencilStrokes]) nvg <- createGL3 (S.fromList [NanoVG.Debug, Antialias, StencilStrokes])
UserData return UserData
<$> newMVar Load -- state { state = Load
<*> pure subs -- subsystems , subsystems = subs
<*> newMVar M.empty -- assetIcons , assetImages = M.empty
<*> newMVar M.empty -- assetImages , assetAnimations = M.empty
<*> newMVar M.empty -- assetFonts , assetFonts = M.empty
<*> newMVar M.empty -- assetAnimations , assetIcons = M.empty
<*> newMVar NoController -- controls , nano = nvg
<*> newMVar NoTranslation -- translation , uuid = []
<*> pure nvg -- nano , stateData = None
<*> newMVar [] -- uuid , threadContext = Nothing
<*> newEmptyMVar -- worldState <- , controls = NoController
<*> newMVar None -- stateData , translation = NoTranslation
<*> newEmptyMVar -- stateMVar <- , joyCache = []
<*> newEmptyMVar -- stateProgress <- }
<*> newMVar Nothing -- threadContext
<*> newMVar Nothing -- window
<*> newMVar [] -- joyCache
<*> newEmptyMVar -- joyUUID <-
<*> newMVar True -- doNextStep
loadPlayerSprite loadPlayerSprite
:: FilePath -- Path to spritemap :: FilePath -- Path to spritemap
@ -69,7 +62,7 @@ loadPlayerSprite fp w h nvg rids = do
eimg <- readImage fp eimg <- readImage fp
case eimg of case eimg of
Left err -> do Left err -> do
logIO Error (fromString err) logIO Error err
exitFailure exitFailure
Right dimg -> do Right dimg -> do
let img = convertRGBA8 dimg let img = convertRGBA8 dimg
@ -77,16 +70,10 @@ loadPlayerSprite fp w h nvg rids = do
mapM (\(num, i) -> do mapM (\(num, i) -> do
let cr = crop (num * w) (row * h) w h img let cr = crop (num * w) (row * h) w h img
mresimg <- mresimg <-
createImageMem nvg (S.singleton ImagePremultiplied) (toStrict $ encodePng cr) createImageMem nvg ImagePremultiplied (toStrict $ encodePng cr)
case mresimg of case mresimg of
Nothing -> do Nothing -> do
logIO logIO Error ("Failed to load: " ++ fp ++ " " ++ show i)
Error
("Failed to load: " <>
fromString fp <>
" " <>
fromString (show i)
)
exitFailure exitFailure
Just resimg -> return (i, resimg) Just resimg -> return (i, resimg)
) (zip [0..] ids) ) (zip [0..] ids)

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

@ -5,8 +5,6 @@ module Object.ActionTime where
import Affection as A import Affection as A
import Data.String
-- internal imports -- internal imports
import Types import Types
@ -16,9 +14,7 @@ instance ActionTime ObjType ObjState where
actionTime ObjComputer "off" = 0 actionTime ObjComputer "off" = 0
actionTime ObjComputer "on" = 20 actionTime ObjComputer "on" = 20
actionTime ObjComputer "hack" = 20 actionTime ObjComputer "hack" = 20
actionTime ObjComputer "hack" = 20
actionTime ObjDoor "open" = 2 actionTime ObjDoor "open" = 2
actionTime o s = A.log actionTime o s = A.log Error (show o ++ ": " ++ s ++ ": has not a time") 0
Error
(fromString (show o) <> ": " <> fromString s <> ": has not a time")
0

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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