Compare commits
29 commits
Author | SHA1 | Date | |
---|---|---|---|
|
01183a2465 | ||
![]() |
009cd6fac7 | ||
|
13700f1b55 | ||
|
c044dc89da | ||
|
367ba034b6 | ||
|
3bc7faa7cd | ||
|
df2cfcf411 | ||
|
a7ce6f36a1 | ||
|
07edd99d0a | ||
|
dd8556ee2b | ||
|
66f9d07905 | ||
|
518e27d1a8 | ||
|
cd2a0f3706 | ||
|
eecfe82abd | ||
|
f8ea2785bf | ||
|
f678b216d6 | ||
|
0cc3195455 | ||
|
cdd5db2b73 | ||
|
a33fec68d4 | ||
|
eea0ec07fd | ||
|
ace1f0ce8c | ||
|
81e16c4428 | ||
|
8f2366502b | ||
|
808ab1db06 | ||
|
adf5eefcdc | ||
|
83b3bbcd9b | ||
|
c110f29c8f | ||
|
55f688e9be | ||
|
7a5e30c6ed |
2
.gitignore
vendored
2
.gitignore
vendored
|
@ -8,6 +8,7 @@
|
|||
cabal.sandbox.config
|
||||
dist/
|
||||
dist-newstyle/
|
||||
.direnv/
|
||||
*.prof
|
||||
*.aux
|
||||
*.hp
|
||||
|
@ -18,3 +19,4 @@ dist-newstyle/
|
|||
*.eventlog
|
||||
*.*~
|
||||
.*autosave.kra
|
||||
result
|
||||
|
|
BIN
assets/policem.kra
Normal file
BIN
assets/policem.kra
Normal file
Binary file not shown.
BIN
assets/policem.png
Normal file
BIN
assets/policem.png
Normal file
Binary file not shown.
After Width: | Height: | Size: 17 KiB |
|
@ -1,2 +0,0 @@
|
|||
constraints: affection +verbose
|
||||
profiling: True
|
|
@ -1,4 +0,0 @@
|
|||
packages:
|
||||
./
|
||||
../affection
|
||||
profiling: True
|
84
flake.lock
Normal file
84
flake.lock
Normal file
|
@ -0,0 +1,84 @@
|
|||
{
|
||||
"nodes": {
|
||||
"affection-src": {
|
||||
"inputs": {
|
||||
"flake-utils": [
|
||||
"flake-utils"
|
||||
],
|
||||
"nixpkgs": [
|
||||
"nixpkgs"
|
||||
]
|
||||
},
|
||||
"locked": {
|
||||
"lastModified": 1700847735,
|
||||
"narHash": "sha256-hSHgLPZwWP7tPoUhH2GLQ4GvHvVGFiXIM0CLps+O5KE=",
|
||||
"ref": "refs/heads/master",
|
||||
"rev": "d0465fa3e1d122503439df7c2de9d16598fc0cf5",
|
||||
"revCount": 306,
|
||||
"type": "git",
|
||||
"url": "https://gitea.nek0.eu/nek0/affection"
|
||||
},
|
||||
"original": {
|
||||
"type": "git",
|
||||
"url": "https://gitea.nek0.eu/nek0/affection"
|
||||
}
|
||||
},
|
||||
"flake-utils": {
|
||||
"inputs": {
|
||||
"systems": "systems"
|
||||
},
|
||||
"locked": {
|
||||
"lastModified": 1694529238,
|
||||
"narHash": "sha256-zsNZZGTGnMOf9YpHKJqMSsa0dXbfmxeoJ7xHlrt+xmY=",
|
||||
"owner": "numtide",
|
||||
"repo": "flake-utils",
|
||||
"rev": "ff7b65b44d01cf9ba6a71320833626af21126384",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "numtide",
|
||||
"repo": "flake-utils",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"nixpkgs": {
|
||||
"locked": {
|
||||
"lastModified": 1700844339,
|
||||
"narHash": "sha256-VRlPYk0eRn1ao75hoA99LGehYhxZH5RlkP1YXpVROHM=",
|
||||
"owner": "NixOS",
|
||||
"repo": "nixpkgs",
|
||||
"rev": "33576fdfce2d11204067d6cfa99a2f990ef2169a",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "NixOS",
|
||||
"repo": "nixpkgs",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"root": {
|
||||
"inputs": {
|
||||
"affection-src": "affection-src",
|
||||
"flake-utils": "flake-utils",
|
||||
"nixpkgs": "nixpkgs"
|
||||
}
|
||||
},
|
||||
"systems": {
|
||||
"locked": {
|
||||
"lastModified": 1681028828,
|
||||
"narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=",
|
||||
"owner": "nix-systems",
|
||||
"repo": "default",
|
||||
"rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "nix-systems",
|
||||
"repo": "default",
|
||||
"type": "github"
|
||||
}
|
||||
}
|
||||
},
|
||||
"root": "root",
|
||||
"version": 7
|
||||
}
|
46
flake.nix
Normal file
46
flake.nix
Normal file
|
@ -0,0 +1,46 @@
|
|||
{
|
||||
description = "A game stub written in Haskell";
|
||||
|
||||
inputs = {
|
||||
nixpkgs.url = "github:NixOS/nixpkgs";
|
||||
flake-utils.url = "github:numtide/flake-utils";
|
||||
affection-src = {
|
||||
url = "git+https://gitea.nek0.eu/nek0/affection";
|
||||
inputs = {
|
||||
nixpkgs.follows = "nixpkgs";
|
||||
flake-utils.follows = "flake-utils";
|
||||
};
|
||||
};
|
||||
};
|
||||
|
||||
outputs = { self, nixpkgs, flake-utils, affection-src }:
|
||||
flake-utils.lib.eachDefaultSystem (system:
|
||||
let
|
||||
pkgs = nixpkgs.legacyPackages.${system};
|
||||
|
||||
haskellPackages = pkgs.haskellPackages;
|
||||
|
||||
jailbreakUnbreak = pkg:
|
||||
pkgs.haskell.lib.doJailbreak (pkg.overrideAttrs (_: { meta = { }; }));
|
||||
|
||||
packageName = "tracer-game";
|
||||
in rec {
|
||||
packages.${packageName} = # (ref:haskell-package-def)
|
||||
haskellPackages.callCabal2nix packageName self rec {
|
||||
affection = affection-src.defaultPackage.${system};
|
||||
};
|
||||
|
||||
defaultPackage = self.packages.${system}.${packageName};
|
||||
|
||||
devShell = haskellPackages.shellFor {
|
||||
packages = p: [ defaultPackage ];
|
||||
withHoogle = true;
|
||||
buildInputs = with haskellPackages; [
|
||||
haskell-language-server
|
||||
ghcid
|
||||
cabal-install
|
||||
] ++ (builtins.attrValues self.packages.${system});
|
||||
};
|
||||
});
|
||||
}
|
||||
|
110
shell.nix
110
shell.nix
|
@ -1,102 +1,14 @@
|
|||
{ nixpkgs ? import <nixpkgs> {}, compiler ? "default", doBenchmark ? false }:
|
||||
{ pkgs ? import <nixpkgs> {}}:
|
||||
|
||||
let
|
||||
|
||||
inherit (nixpkgs) pkgs;
|
||||
|
||||
affection = with haskellPackages; callPackage(
|
||||
{ mkDerivation, base, bytestring, clock, containers, glib, linear
|
||||
, monad-loops, monad-parallel, mtl, OpenGL, sdl2, stdenv, stm, text
|
||||
, uuid, vector
|
||||
}:
|
||||
mkDerivation {
|
||||
pname = "affection";
|
||||
version = "0.0.0.9";
|
||||
src = ../affection;
|
||||
isLibrary = true;
|
||||
isExecutable = true;
|
||||
libraryHaskellDepends = [
|
||||
base bytestring clock containers glib linear monad-loops
|
||||
monad-parallel mtl OpenGL sdl2 stm text uuid vector
|
||||
];
|
||||
homepage = "https://github.com/nek0/affection#readme";
|
||||
description = "A simple Game Engine using SDL";
|
||||
license = stdenv.lib.licenses.lgpl3;
|
||||
doHaddock = false;
|
||||
}) {};
|
||||
|
||||
algebraic-graphs = with haskellPackages; callPackage(
|
||||
{ mkDerivation, array, base, base-compat, base-orphans, containers
|
||||
, deepseq, extra, inspection-testing, mtl, QuickCheck, stdenv
|
||||
}:
|
||||
mkDerivation {
|
||||
pname = "algebraic-graphs";
|
||||
version = "0.4";
|
||||
sha256 = "c905d32a6178a11e3c8096dbbf3bd19e570e87362c51fdc8653b43a51e46d3b7";
|
||||
libraryHaskellDepends = [
|
||||
array base base-compat containers deepseq mtl
|
||||
];
|
||||
testHaskellDepends = [
|
||||
array base base-compat base-orphans containers extra
|
||||
inspection-testing QuickCheck
|
||||
];
|
||||
homepage = "https://github.com/snowleopard/alga";
|
||||
description = "A library for algebraic graph construction and transformation";
|
||||
license = stdenv.lib.licenses.mit;
|
||||
doCheck = false;
|
||||
}) {};
|
||||
|
||||
nanovg = with haskellPackages; callPackage(
|
||||
{ mkDerivation, base, bytestring, c2hs, containers, glew
|
||||
, hspec, inline-c, libGL, libGLU, QuickCheck, stdenv, text, vector
|
||||
}:
|
||||
mkDerivation {
|
||||
pname = "nanovg";
|
||||
version = "0.6.0.0";
|
||||
sha256 = "e35a2772f2a2e71916013cab70eeb8eedd6f66b5490ddf7ce237c8c76895d496";
|
||||
revision = "1";
|
||||
editedCabalFile = "1lhfsq50r9bdby7mfscw8ih3wsz2m19lr2a2z9b6diaf5kz76vij";
|
||||
configureFlags = [ "-fgl3" ];
|
||||
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";
|
||||
license = stdenv.lib.licenses.isc;
|
||||
doCheck = false;
|
||||
}) {};
|
||||
|
||||
f = { mkDerivation, astar, base
|
||||
, bytestring, containers, ecstasy, JuicyPixels, JuicyPixels-extra
|
||||
, linear, matrix, mtl, OpenGL, parallel, random, sdl2
|
||||
, split, stdenv, stm, text, unordered-containers, vector
|
||||
}:
|
||||
mkDerivation {
|
||||
pname = "tracer-game";
|
||||
version = "0.0.0.0";
|
||||
src = ./.;
|
||||
isLibrary = false;
|
||||
isExecutable = true;
|
||||
executableHaskellDepends = [
|
||||
affection algebraic-graphs astar base bytestring containers ecstasy
|
||||
JuicyPixels JuicyPixels-extra linear matrix mtl nanovg OpenGL
|
||||
parallel random sdl2 split stm text unordered-containers vector
|
||||
];
|
||||
license = stdenv.lib.licenses.gpl3;
|
||||
};
|
||||
|
||||
haskellPackages = if compiler == "default"
|
||||
then pkgs.haskellPackages
|
||||
else pkgs.haskell.packages.${compiler};
|
||||
|
||||
variant = if doBenchmark then pkgs.haskell.lib.doBenchmark else pkgs.lib.id;
|
||||
|
||||
drv = variant (haskellPackages.callPackage f {});
|
||||
|
||||
# create a modified haskell package set with my package inside it and broken dependencies
|
||||
# jailbroken.
|
||||
hpkgs = pkgs.haskellPackages.override {
|
||||
overrides = hself: hsuper: {
|
||||
tracer-game = hself.callCabal2nix "tracer-game" (gitignore ./.) {};
|
||||
affection = hself.callCabal2nix "affection" (gitignore ../affection) {};
|
||||
};
|
||||
};
|
||||
gitignore = dir: pkgs.nix-gitignore.gitignoreSource [] dir;
|
||||
in
|
||||
|
||||
if pkgs.lib.inNixShell then drv.env else drv
|
||||
hpkgs.tracer-game.env
|
||||
|
|
|
@ -322,6 +322,7 @@ buildFacilities gen fc input =
|
|||
in (ngen, facilFlood facil acc x)
|
||||
) (gen, input) nearests
|
||||
|
||||
facilFlood :: TileState -> Matrix TileState -> (Int, Int) -> Matrix TileState
|
||||
facilFlood ts mat coords@(cr, cc) =
|
||||
let cur = mat M.! coords
|
||||
altered = M.setElem ts coords mat
|
||||
|
@ -417,6 +418,7 @@ buildGraph amat mat root coord@(br, bc)
|
|||
| otherwise = c
|
||||
|
||||
|
||||
flood :: Matrix TileState -> [(Int, Int)] -> (Int, Int) -> [(Int,Int)]
|
||||
flood amat acc (fr, fc) =
|
||||
let ncoords = [] ++
|
||||
(if (fr + 1, fc) `notElem` acc &&
|
||||
|
@ -488,6 +490,9 @@ assignClearance graph imat =
|
|||
return ret
|
||||
else
|
||||
return room
|
||||
reassign _ _ (GHall _) = do
|
||||
logIO A.Error "cannot reassign Hallways!"
|
||||
error "*dies*"
|
||||
|
||||
actualRoomType :: Boundaries Int -> M.Matrix TileState -> TileState
|
||||
actualRoomType (Boundaries (minrow, mincol) (maxrow, maxcol)) imat =
|
||||
|
@ -546,6 +551,8 @@ findNeighbor (dir, _) bnds ingraph
|
|||
_ -> 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 = V.foldM placeDoors
|
||||
|
|
38
src/Init.hs
38
src/Init.hs
|
@ -11,6 +11,7 @@ import Codec.Picture as CP
|
|||
import Codec.Picture.Extra
|
||||
|
||||
import Control.Concurrent.STM
|
||||
import Control.Concurrent.MVar
|
||||
|
||||
import Data.String
|
||||
import qualified Data.Set as S
|
||||
|
@ -36,21 +37,26 @@ init = do
|
|||
<*> (SubTranslator <$> newTVarIO [])
|
||||
_ <- glewInit
|
||||
nvg <- createGL3 (S.fromList [NanoVG.Debug, Antialias, StencilStrokes])
|
||||
return UserData
|
||||
{ state = Load
|
||||
, subsystems = subs
|
||||
, assetImages = M.empty
|
||||
, assetAnimations = M.empty
|
||||
, assetFonts = M.empty
|
||||
, assetIcons = M.empty
|
||||
, nano = nvg
|
||||
, uuid = []
|
||||
, stateData = None
|
||||
, threadContext = Nothing
|
||||
, controls = NoController
|
||||
, translation = NoTranslation
|
||||
, joyCache = []
|
||||
}
|
||||
UserData
|
||||
<$> newMVar Load -- state
|
||||
<*> pure subs -- subsystems
|
||||
<*> newMVar M.empty -- assetIcons
|
||||
<*> newMVar M.empty -- assetImages
|
||||
<*> newMVar M.empty -- assetFonts
|
||||
<*> newMVar M.empty -- assetAnimations
|
||||
<*> newMVar NoController -- controls
|
||||
<*> newMVar NoTranslation -- translation
|
||||
<*> pure nvg -- nano
|
||||
<*> newMVar [] -- uuid
|
||||
<*> newEmptyMVar -- worldState <-
|
||||
<*> newMVar None -- stateData
|
||||
<*> newEmptyMVar -- stateMVar <-
|
||||
<*> newEmptyMVar -- stateProgress <-
|
||||
<*> newMVar Nothing -- threadContext
|
||||
<*> newMVar Nothing -- window
|
||||
<*> newMVar [] -- joyCache
|
||||
<*> newEmptyMVar -- joyUUID <-
|
||||
<*> newMVar True -- doNextStep
|
||||
|
||||
loadPlayerSprite
|
||||
:: FilePath -- Path to spritemap
|
||||
|
@ -71,7 +77,7 @@ loadPlayerSprite fp w h nvg rids = do
|
|||
mapM (\(num, i) -> do
|
||||
let cr = crop (num * w) (row * h) w h img
|
||||
mresimg <-
|
||||
createImageMem nvg ImagePremultiplied (toStrict $ encodePng cr)
|
||||
createImageMem nvg (S.singleton ImagePremultiplied) (toStrict $ encodePng cr)
|
||||
case mresimg of
|
||||
Nothing -> do
|
||||
logIO
|
||||
|
|
|
@ -1,7 +1,5 @@
|
|||
module Interior where
|
||||
|
||||
import qualified Affection as A
|
||||
|
||||
import Data.Matrix as M
|
||||
import qualified Data.Map.Strict as Map
|
||||
import Data.List as L
|
||||
|
|
170
src/Load.hs
170
src/Load.hs
|
@ -7,17 +7,20 @@ import Graphics.Rendering.OpenGL.GL.FlushFinish (finish)
|
|||
|
||||
import Control.Concurrent (forkIO)
|
||||
import Control.Concurrent.MVar
|
||||
import Control.Monad (when)
|
||||
import Control.Monad
|
||||
import Control.Monad.Trans.Resource (ResIO)
|
||||
|
||||
import qualified Data.Map as M
|
||||
import qualified Data.Text as T
|
||||
import Data.Ecstasy
|
||||
import Data.Maybe
|
||||
import qualified Data.Set as S
|
||||
import Data.String
|
||||
|
||||
import System.Exit (exitFailure)
|
||||
|
||||
import NanoVG hiding (V2(..))
|
||||
import NanoVG.Internal.Image
|
||||
|
||||
-- internal imports
|
||||
|
||||
|
@ -25,39 +28,38 @@ import Menu.Connect
|
|||
import Types
|
||||
import Util
|
||||
|
||||
loadLoad :: Affection UserData ()
|
||||
loadLoad = do
|
||||
loadLoad :: UserData -> Affection ()
|
||||
loadLoad ud = do
|
||||
ad <- A.get
|
||||
ud <- getAffection
|
||||
progress <- liftIO $ newMVar (0, "Starting up")
|
||||
future <- liftIO newEmptyMVar
|
||||
wState <- liftIO $ readMVar (worldState ud)
|
||||
curWin <- liftIO $ readMVar (window ud)
|
||||
tContext <- liftIO $ readMVar (threadContext ud)
|
||||
let progress = (0, "Starting up")
|
||||
void $ liftIO $ putMVar (stateProgress ud) progress
|
||||
_ <- liftIO $ createFont (nano ud) "bedstead"
|
||||
(FileName "assets/font/Bedstead-Semicondensed.ttf")
|
||||
_ <- liftIO $ forkIO $
|
||||
loadFork
|
||||
(worldState ud)
|
||||
(fromJust $ window ud)
|
||||
(fromJust $ threadContext ud)
|
||||
wState
|
||||
(fromJust curWin)
|
||||
(fromJust tContext)
|
||||
(nano ud)
|
||||
future
|
||||
progress
|
||||
SDL.glMakeCurrent (fromJust $ window ud) (snd $ head $ glContext ad)
|
||||
putAffection ud
|
||||
{ stateMVar = future
|
||||
, stateProgress = progress
|
||||
, state = Load
|
||||
, assetFonts = M.fromList
|
||||
[ (FontBedstead, "bedstead")
|
||||
]
|
||||
}
|
||||
(stateMVar ud)
|
||||
(stateProgress ud)
|
||||
SDL.glMakeCurrent (fromJust curWin) (acContext $ head $ glContext ad)
|
||||
void $ liftIO $ swapMVar (state ud) Load
|
||||
void $ liftIO $ swapMVar (assetFonts ud) (M.fromList
|
||||
[ (FontBedstead, "bedstead")
|
||||
]
|
||||
)
|
||||
|
||||
loadFork
|
||||
:: SystemState Entity (AffectionState (AffectionData UserData) IO)
|
||||
:: SystemState Entity (AffectionState (AffectionData) ResIO)
|
||||
-> SDL.Window
|
||||
-> SDL.GLContext
|
||||
-> Context
|
||||
-> MVar
|
||||
( SystemState Entity (AffectionState (AffectionData UserData) IO)
|
||||
( SystemState Entity (AffectionState (AffectionData) ResIO)
|
||||
, StateData
|
||||
)
|
||||
-> MVar (Float, T.Text)
|
||||
|
@ -70,202 +72,202 @@ loadFork ws win glc nvg future progress = do
|
|||
( p + increment
|
||||
, "Loading icon \"conntroller_blue\""
|
||||
)))
|
||||
mcontrblue <- createImage nvg (FileName "assets/icons/controller_blue.png") 0
|
||||
mcontrblue <- createImage nvg (FileName "assets/icons/controller_blue.png") (S.singleton ImagePremultiplied)
|
||||
modifyMVar_ progress (return . (\(p, _) ->
|
||||
( p + increment
|
||||
, "Loading icon \"controller_blue\""
|
||||
)))
|
||||
mcontrgreen <- createImage nvg (FileName "assets/icons/controller_green.png") 0
|
||||
mcontrgreen <- createImage nvg (FileName "assets/icons/controller_green.png") (S.singleton ImagePremultiplied)
|
||||
modifyMVar_ progress (return . (\(p, _) ->
|
||||
( p + increment
|
||||
, "Loading icon \"controller_green\""
|
||||
)))
|
||||
mkbdblue <- createImage nvg (FileName "assets/icons/keyboard_blue.png") 0
|
||||
mkbdblue <- createImage nvg (FileName "assets/icons/keyboard_blue.png") (S.singleton ImagePremultiplied)
|
||||
modifyMVar_ progress (return . (\(p, _) ->
|
||||
( p + increment
|
||||
, "Loading icon \"keyboard_blue\""
|
||||
)))
|
||||
mkbdgreen <- createImage nvg (FileName "assets/icons/keyboard_green.png") 0
|
||||
mkbdgreen <- createImage nvg (FileName "assets/icons/keyboard_green.png") (S.singleton ImagePremultiplied)
|
||||
modifyMVar_ progress (return . (\(p, _) ->
|
||||
( p + increment
|
||||
, "Loading icon \"keyboard_green\""
|
||||
)))
|
||||
marrow <- createImage nvg (FileName "assets/icons/arrow.png") 0
|
||||
marrow <- createImage nvg (FileName "assets/icons/arrow.png") (S.singleton ImagePremultiplied)
|
||||
modifyMVar_ progress (return . (\(p, _) ->
|
||||
( p + increment
|
||||
, "Loading asset \"wall_asc\""
|
||||
)))
|
||||
mwallasc <- createImage nvg (FileName "assets/walls/wall_asc.png") 0
|
||||
mwallasc <- createImage nvg (FileName "assets/walls/wall_asc.png") (S.singleton ImagePremultiplied)
|
||||
modifyMVar_ progress (return . (\(p, _) ->
|
||||
( p + increment
|
||||
, "Loading asset \"wall_desc\""
|
||||
)))
|
||||
mwalldesc <- createImage nvg (FileName "assets/walls/wall_desc.png") 0
|
||||
mwalldesc <- createImage nvg (FileName "assets/walls/wall_desc.png") (S.singleton ImagePremultiplied)
|
||||
modifyMVar_ progress (return . (\(p, _) ->
|
||||
( p + increment
|
||||
, "Loading asset \"wall_corner_n\""
|
||||
)))
|
||||
mwallcornern <- createImage nvg (FileName "assets/walls/wall_corner_n.png") 0
|
||||
mwallcornern <- createImage nvg (FileName "assets/walls/wall_corner_n.png") (S.singleton ImagePremultiplied)
|
||||
modifyMVar_ progress (return . (\(p, _) ->
|
||||
( p + increment
|
||||
, "Loading asset \"wall_corner_e\""
|
||||
)))
|
||||
mwallcornere <- createImage nvg (FileName "assets/walls/wall_corner_e.png") 0
|
||||
mwallcornere <- createImage nvg (FileName "assets/walls/wall_corner_e.png") (S.singleton ImagePremultiplied)
|
||||
modifyMVar_ progress (return . (\(p, _) ->
|
||||
( p + increment
|
||||
, "Loading asset \"wall_corner_s\""
|
||||
)))
|
||||
mwallcorners <- createImage nvg (FileName "assets/walls/wall_corner_s.png") 0
|
||||
mwallcorners <- createImage nvg (FileName "assets/walls/wall_corner_s.png") (S.singleton ImagePremultiplied)
|
||||
modifyMVar_ progress (return . (\(p, _) ->
|
||||
( p + increment
|
||||
, "Loading asset \"wall_corner_w\""
|
||||
)))
|
||||
mwallcornerw <- createImage nvg (FileName "assets/walls/wall_corner_w.png") 0
|
||||
mwallcornerw <- createImage nvg (FileName "assets/walls/wall_corner_w.png") (S.singleton ImagePremultiplied)
|
||||
modifyMVar_ progress (return . (\(p, _) ->
|
||||
( p + increment
|
||||
, "Loading asset \"wall_t_ne\""
|
||||
)))
|
||||
mwalltne <- createImage nvg (FileName "assets/walls/wall_t_ne.png") 0
|
||||
mwalltne <- createImage nvg (FileName "assets/walls/wall_t_ne.png") (S.singleton ImagePremultiplied)
|
||||
modifyMVar_ progress (return . (\(p, _) ->
|
||||
( p + increment
|
||||
, "Loading asset \"wall_t_se\""
|
||||
)))
|
||||
mwalltse <- createImage nvg (FileName "assets/walls/wall_t_se.png") 0
|
||||
mwalltse <- createImage nvg (FileName "assets/walls/wall_t_se.png") (S.singleton ImagePremultiplied)
|
||||
modifyMVar_ progress (return . (\(p, _) ->
|
||||
( p + increment
|
||||
, "Loading asset \"wall_t_sw\""
|
||||
)))
|
||||
mwalltsw <- createImage nvg (FileName "assets/walls/wall_t_sw.png") 0
|
||||
mwalltsw <- createImage nvg (FileName "assets/walls/wall_t_sw.png") (S.singleton ImagePremultiplied)
|
||||
modifyMVar_ progress (return . (\(p, _) ->
|
||||
( p + increment
|
||||
, "Loading asset \"wall_t_nw\""
|
||||
)))
|
||||
mwalltnw <- createImage nvg (FileName "assets/walls/wall_t_nw.png") 0
|
||||
mwalltnw <- createImage nvg (FileName "assets/walls/wall_t_nw.png") (S.singleton ImagePremultiplied)
|
||||
modifyMVar_ progress (return . (\(p, _) ->
|
||||
( p + increment
|
||||
, "Loading asset \"wall_cross\""
|
||||
)))
|
||||
mwallcross <- createImage nvg (FileName "assets/walls/wall_cross.png") 0
|
||||
mwallcross <- createImage nvg (FileName "assets/walls/wall_cross.png") (S.singleton ImagePremultiplied)
|
||||
modifyMVar_ progress (return . (\(p, _) ->
|
||||
( p + increment
|
||||
, "Loading asset \"box1\""
|
||||
)))
|
||||
mmiscbox1 <- createImage nvg (FileName "assets/misc/box1.png") 0
|
||||
mmiscbox1 <- createImage nvg (FileName "assets/misc/box1.png") (S.singleton ImagePremultiplied)
|
||||
modifyMVar_ progress (return . (\(p, _) ->
|
||||
( p + increment
|
||||
, "Loading asset \"tableSW\""
|
||||
)))
|
||||
mtableSW <- createImage nvg (FileName "assets/table/tableSW.png") 0
|
||||
mtableSW <- createImage nvg (FileName "assets/table/tableSW.png") (S.singleton ImagePremultiplied)
|
||||
modifyMVar_ progress (return . (\(p, _) ->
|
||||
( p + increment
|
||||
, "Loading asset \"tableSE\""
|
||||
)))
|
||||
mtableSE <- createImage nvg (FileName "assets/table/tableSE.png") 0
|
||||
mtableSE <- createImage nvg (FileName "assets/table/tableSE.png") (S.singleton ImagePremultiplied)
|
||||
modifyMVar_ progress (return . (\(p, _) ->
|
||||
( p + increment
|
||||
, "Loading asset \"tableNE\""
|
||||
)))
|
||||
mtableNE <- createImage nvg (FileName "assets/table/tableNE.png") 0
|
||||
mtableNE <- createImage nvg (FileName "assets/table/tableNE.png") (S.singleton ImagePremultiplied)
|
||||
modifyMVar_ progress (return . (\(p, _) ->
|
||||
( p + increment
|
||||
, "Loading asset \"tableNW\""
|
||||
)))
|
||||
mtableNW <- createImage nvg (FileName "assets/table/tableNW.png") 0
|
||||
mtableNW <- createImage nvg (FileName "assets/table/tableNW.png") (S.singleton ImagePremultiplied)
|
||||
modifyMVar_ progress (return . (\(p, _) ->
|
||||
( p + increment
|
||||
, "Loading asset \"tableC1\""
|
||||
)))
|
||||
mtablec1 <- createImage nvg (FileName "assets/table/tablec1.png") 0
|
||||
mtablec1 <- createImage nvg (FileName "assets/table/tablec1.png") (S.singleton ImagePremultiplied)
|
||||
modifyMVar_ progress (return . (\(p, _) ->
|
||||
( p + increment
|
||||
, "Loading asset \"tableC2\""
|
||||
)))
|
||||
mtablec2 <- createImage nvg (FileName "assets/table/tablec2.png") 0
|
||||
mtablec2 <- createImage nvg (FileName "assets/table/tablec2.png") (S.singleton ImagePremultiplied)
|
||||
modifyMVar_ progress (return . (\(p, _) ->
|
||||
( p + increment
|
||||
, "Loading asset \"tableC3\""
|
||||
)))
|
||||
mtablec3 <- createImage nvg (FileName "assets/table/tablec3.png") 0
|
||||
mtablec3 <- createImage nvg (FileName "assets/table/tablec3.png") (S.singleton ImagePremultiplied)
|
||||
modifyMVar_ progress (return . (\(p, _) ->
|
||||
( p + increment
|
||||
, "Loading asset \"tableC4\""
|
||||
)))
|
||||
mtablec4 <- createImage nvg (FileName "assets/table/tablec4.png") 0
|
||||
mtablec4 <- createImage nvg (FileName "assets/table/tablec4.png") (S.singleton ImagePremultiplied)
|
||||
modifyMVar_ progress (return . (\(p, _) ->
|
||||
( p + increment
|
||||
, "Loading asset \"tableCorner\""
|
||||
)))
|
||||
mtableC <- createImage nvg (FileName "assets/table/tableCorner.png") 0
|
||||
mtableC <- createImage nvg (FileName "assets/table/tableCorner.png") (S.singleton ImagePremultiplied)
|
||||
modifyMVar_ progress (return . (\(p, _) ->
|
||||
( p + increment
|
||||
, "Loading asset \"flipchart\""
|
||||
)))
|
||||
mmiscFlipchart <- createImage nvg (FileName "assets/misc/flipchart.png") 0
|
||||
mmiscFlipchart <- createImage nvg (FileName "assets/misc/flipchart.png") (S.singleton ImagePremultiplied)
|
||||
modifyMVar_ progress (return . (\(p, _) ->
|
||||
( p + increment
|
||||
, "Loading asset \"plant1\""
|
||||
)))
|
||||
mmiscPlant1 <- createImage nvg (FileName "assets/misc/plant1.png") 0
|
||||
mmiscPlant1 <- createImage nvg (FileName "assets/misc/plant1.png") (S.singleton ImagePremultiplied)
|
||||
modifyMVar_ progress (return . (\(p, _) ->
|
||||
( p + increment
|
||||
, "Loading asset \"plant2\""
|
||||
)))
|
||||
mmiscPlant2 <- createImage nvg (FileName "assets/misc/plant2.png") 0
|
||||
mmiscPlant2 <- createImage nvg (FileName "assets/misc/plant2.png") (S.singleton ImagePremultiplied)
|
||||
modifyMVar_ progress (return . (\(p, _) ->
|
||||
( p + increment
|
||||
, "Loading asset \"watercooler\""
|
||||
)))
|
||||
mmiscWatercooler <- createImage nvg (FileName "assets/misc/watercooler.png") 0
|
||||
mmiscWatercooler <- createImage nvg (FileName "assets/misc/watercooler.png") (S.singleton ImagePremultiplied)
|
||||
modifyMVar_ progress (return . (\(p, _) ->
|
||||
( p + increment
|
||||
, "Loading asset \"vending machine\""
|
||||
)))
|
||||
mmiscVending <- createImage nvg (FileName "assets/misc/vending.png") 0
|
||||
mmiscVending <- createImage nvg (FileName "assets/misc/vending.png") (S.singleton ImagePremultiplied)
|
||||
modifyMVar_ progress (return . (\(p, _) ->
|
||||
( p + increment
|
||||
, "Loading asset \"Cabinet with Coffee machine SW\""
|
||||
)))
|
||||
mcabCoffeeSW <- createImage nvg (FileName "assets/cabinet/cabCoffeeSW.png") 0
|
||||
mcabCoffeeSW <- createImage nvg (FileName "assets/cabinet/cabCoffeeSW.png") (S.singleton ImagePremultiplied)
|
||||
modifyMVar_ progress (return . (\(p, _) ->
|
||||
( p + increment
|
||||
, "Loading asset \"Cabinet with Coffee machine SE\""
|
||||
)))
|
||||
mcabCoffeeSE <- createImage nvg (FileName "assets/cabinet/cabCoffeeSE.png") 0
|
||||
mcabCoffeeSE <- createImage nvg (FileName "assets/cabinet/cabCoffeeSE.png") (S.singleton ImagePremultiplied)
|
||||
modifyMVar_ progress (return . (\(p, _) ->
|
||||
( p + increment
|
||||
, "Loading asset \"Cabinet with sink SW\""
|
||||
)))
|
||||
mcabSinkSW <- createImage nvg (FileName "assets/cabinet/cabSinkSW.png") 0
|
||||
mcabSinkSW <- createImage nvg (FileName "assets/cabinet/cabSinkSW.png") (S.singleton ImagePremultiplied)
|
||||
modifyMVar_ progress (return . (\(p, _) ->
|
||||
( p + increment
|
||||
, "Loading asset \"Cabinet with sink SE\""
|
||||
)))
|
||||
mcabSinkSE <- createImage nvg (FileName "assets/cabinet/cabSinkSE.png") 0
|
||||
mcabSinkSE <- createImage nvg (FileName "assets/cabinet/cabSinkSE.png") (S.singleton ImagePremultiplied)
|
||||
modifyMVar_ progress (return . (\(p, _) ->
|
||||
( p + increment
|
||||
, "Loading asset \"Cabinet with stove SW\""
|
||||
)))
|
||||
mcabStoveSW <- createImage nvg (FileName "assets/cabinet/cabStoveSW.png") 0
|
||||
mcabStoveSW <- createImage nvg (FileName "assets/cabinet/cabStoveSW.png") (S.singleton ImagePremultiplied)
|
||||
modifyMVar_ progress (return . (\(p, _) ->
|
||||
( p + increment
|
||||
, "Loading asset \"Cabinet with stove SE\""
|
||||
)))
|
||||
mcabStoveSE <- createImage nvg (FileName "assets/cabinet/cabStoveSE.png") 0
|
||||
mcabStoveSE <- createImage nvg (FileName "assets/cabinet/cabStoveSE.png") (S.singleton ImagePremultiplied)
|
||||
modifyMVar_ progress (return . (\(p, _) ->
|
||||
( p + increment
|
||||
, "Loading asset \"cabinet SW\""
|
||||
)))
|
||||
mcabinetSW <- createImage nvg (FileName "assets/cabinet/cabinetSW.png") 0
|
||||
mcabinetSW <- createImage nvg (FileName "assets/cabinet/cabinetSW.png") (S.singleton ImagePremultiplied)
|
||||
modifyMVar_ progress (return . (\(p, _) ->
|
||||
( p + increment
|
||||
, "Loading asset \"cabinet SE\""
|
||||
)))
|
||||
mcabinetSE <- createImage nvg (FileName "assets/cabinet/cabinetSE.png") 0
|
||||
mcabinetSE <- createImage nvg (FileName "assets/cabinet/cabinetSE.png") (S.singleton ImagePremultiplied)
|
||||
modifyMVar_ progress (return . (\(p, _) ->
|
||||
( p + increment
|
||||
, "Loading asset \"cabinet corner\""
|
||||
)))
|
||||
mcabinetCorner <- createImage nvg (FileName "assets/cabinet/cabinetCorner.png") 0
|
||||
mcabinetCorner <- createImage nvg (FileName "assets/cabinet/cabinetCorner.png") (S.singleton ImagePremultiplied)
|
||||
let micons =
|
||||
[ mcontrblue, mcontrgreen, mkbdblue, mkbdgreen, marrow
|
||||
]
|
||||
|
@ -335,6 +337,18 @@ loadFork ws win glc nvg future progress = do
|
|||
)))
|
||||
jdoemWalking <- loadAnimationSprites "assets/jdoem.png" nvg
|
||||
(zip (walkIds AnimJDoeM) walkConfigs)
|
||||
modifyMVar_ progress (return . (\(p, _) ->
|
||||
( p + increment
|
||||
, "Loading Animation \"policem: standing\""
|
||||
)))
|
||||
policemStanding <- loadAnimationSprites "assets/policem.png" nvg
|
||||
(zip (standIds AnimPoliceM) standConfigs)
|
||||
modifyMVar_ progress (return . (\(p, _) ->
|
||||
( p + increment
|
||||
, "Loading Animation \"policem: walking\""
|
||||
)))
|
||||
policemWalking <- loadAnimationSprites "assets/policem.png" nvg
|
||||
(zip (walkIds AnimPoliceM) walkConfigs)
|
||||
modifyMVar_ progress (return . (\(p, _) ->
|
||||
( p + increment
|
||||
, "Loading Animation \"copier: stand\""
|
||||
|
@ -491,9 +505,13 @@ loadFork ws win glc nvg future progress = do
|
|||
]
|
||||
modifyMVar_ progress (return . (\(p, _) ->
|
||||
( p + increment
|
||||
, "Handing over"
|
||||
, "GL_Finish"
|
||||
)))
|
||||
finish
|
||||
modifyMVar_ progress (return . (\(p, _) ->
|
||||
( p + increment
|
||||
, "Handing over"
|
||||
)))
|
||||
putMVar future
|
||||
( ws
|
||||
, LoadData
|
||||
|
@ -503,6 +521,8 @@ loadFork ws win glc nvg future progress = do
|
|||
playerWalking ++
|
||||
jdoemStanding ++
|
||||
jdoemWalking ++
|
||||
policemStanding ++
|
||||
policemWalking ++
|
||||
copierStand ++
|
||||
copierCopy ++
|
||||
cornerComputerOff ++
|
||||
|
@ -525,30 +545,24 @@ loadFork ws win glc nvg future progress = do
|
|||
}
|
||||
)
|
||||
|
||||
drawLoad :: Affection UserData ()
|
||||
drawLoad = do
|
||||
ud <- getAffection
|
||||
drawLoad :: UserData -> Affection ()
|
||||
drawLoad ud = do
|
||||
progress <- liftIO $ readMVar (stateProgress ud)
|
||||
liftIO $ do
|
||||
logIO A.Verbose ("LoadProgress: " <> fromString (show progress))
|
||||
drawLoadScreen ud progress
|
||||
|
||||
updateLoad :: Double -> Affection UserData ()
|
||||
updateLoad _ = do
|
||||
ud <- getAffection
|
||||
updateLoad :: UserData -> Double -> Affection ()
|
||||
updateLoad ud _ = do
|
||||
mwsld <- liftIO $ tryTakeMVar (stateMVar ud)
|
||||
case mwsld of
|
||||
Just (_, ld) -> do
|
||||
liftIO $ logIO A.Debug "loaded assets, entering menu"
|
||||
putAffection ud
|
||||
{ assetImages = loadAssetImages ld
|
||||
, assetAnimations = loadAssetAnims ld
|
||||
, assetIcons = loadAssetIcons ld
|
||||
-- , state = Main WorldMap
|
||||
-- , state = Menu Connect
|
||||
, stateData = None
|
||||
}
|
||||
void $ liftIO $ swapMVar (assetImages ud) (loadAssetImages ld)
|
||||
void $ liftIO $ swapMVar (assetAnimations ud) (loadAssetAnims ld)
|
||||
void $ liftIO $ swapMVar (assetIcons ud) (loadAssetIcons ld)
|
||||
void $ liftIO $ swapMVar (stateData ud) None
|
||||
-- loadMap
|
||||
loadMenu
|
||||
loadMenu ud
|
||||
Nothing ->
|
||||
return ()
|
||||
|
|
135
src/Main.hs
135
src/Main.hs
|
@ -15,7 +15,9 @@ import Foreign.C.Types (CInt(..))
|
|||
|
||||
import Data.Maybe (fromJust)
|
||||
|
||||
import Control.Monad (when)
|
||||
import Control.Monad
|
||||
import Control.Concurrent.MVar
|
||||
import Control.Monad.Trans.Resource (allocate)
|
||||
|
||||
-- internal imports
|
||||
|
||||
|
@ -27,6 +29,15 @@ import Util
|
|||
foreign import ccall unsafe "glewInit"
|
||||
glewInit :: IO CInt
|
||||
|
||||
instance Affectionate UserData where
|
||||
preLoop = (\ud -> pre ud >> smLoad Load ud)
|
||||
handleEvents = handle
|
||||
update = Main.update
|
||||
draw = Main.draw
|
||||
loadState = Init.init
|
||||
cleanUp = clean
|
||||
hasNextStep = liftIO . readMVar . doNextStep
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
let config = AffectionConfig
|
||||
|
@ -35,99 +46,91 @@ main = do
|
|||
, windowConfigs =
|
||||
[ ( 0
|
||||
, SDL.defaultWindow
|
||||
{ SDL.windowInitialSize = V2 1280 720
|
||||
{ SDL.windowInitialSize = V2 1920 1080
|
||||
, SDL.windowResizable = True
|
||||
, SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL
|
||||
{ SDL.glProfile = SDL.Core SDL.Normal 3 3
|
||||
}
|
||||
}
|
||||
, SDL.Windowed
|
||||
)
|
||||
]
|
||||
, canvasSize = Nothing
|
||||
, preLoop = pre >> smLoad Load
|
||||
, eventLoop = handle
|
||||
, updateLoop = update
|
||||
, drawLoop = draw
|
||||
, loadState = Init.init
|
||||
, cleanUp = clean
|
||||
, initScreenMode = SDL.Windowed
|
||||
}
|
||||
} :: AffectionConfig UserData
|
||||
withAffection config
|
||||
|
||||
pre :: Affection UserData ()
|
||||
pre = do
|
||||
pre :: UserData -> Affection ()
|
||||
pre ud = do
|
||||
ad <- A.get
|
||||
ud <- getAffection
|
||||
threadCtx <- SDL.glCreateContext (snd $ head $ drawWindows ad)
|
||||
SDL.glMakeCurrent (snd $ head $ drawWindows ad) (snd $ head $ glContext ad)
|
||||
let Subsystems w m k j t = subsystems ud
|
||||
_ <- partSubscribe w (fitViewport (1280/720))
|
||||
_ <- partSubscribe w exitOnWindowClose
|
||||
let (AffectionWindow awwindow _ _) = head $ drawWindows ad
|
||||
threadCtx <- SDL.glCreateContext awwindow
|
||||
SDL.glMakeCurrent awwindow (acContext $ head $ glContext ad)
|
||||
let Subsystems w _ k j _ = subsystems ud
|
||||
_ <- partSubscribe w (fitViewport (1920/1080))
|
||||
_ <- partSubscribe w (exitOnWindowClose ud)
|
||||
_ <- partSubscribe k toggleFullScreen
|
||||
_ <- partSubscribe k quitGame
|
||||
u <- partSubscribe j cacheJoypad
|
||||
_ <- partSubscribe k (quitGame ud)
|
||||
u <- partSubscribe j (cacheJoypad ud)
|
||||
(ws, _) <- yieldSystemT (0, defStorage) (return ())
|
||||
putAffection ud
|
||||
{ threadContext = Just threadCtx
|
||||
, window = Just (snd $ head $ drawWindows ad)
|
||||
, worldState = ws
|
||||
, joyUUID = u
|
||||
}
|
||||
void $ liftIO $ swapMVar (threadContext ud) (Just threadCtx)
|
||||
void $ liftIO $ swapMVar (window ud) (Just awwindow)
|
||||
void $ liftIO $ putMVar (worldState ud) ws
|
||||
void $ liftIO $ putMVar (joyUUID ud) u
|
||||
|
||||
quitGame :: KeyboardMessage -> Affection UserData ()
|
||||
quitGame (MsgKeyboardEvent _ _ SDL.Pressed False sym)
|
||||
| SDL.keysymKeycode sym == SDL.KeycodeEscape = quit
|
||||
quitGame :: UserData -> KeyboardMessage -> Affection ()
|
||||
quitGame ud (MsgKeyboardEvent _ _ SDL.Pressed False sym)
|
||||
| SDL.keysymKeycode sym == SDL.KeycodeEscape =
|
||||
void $ liftIO $ swapMVar (doNextStep ud) False
|
||||
| SDL.keysymKeycode sym == SDL.KeycodeF5 = do
|
||||
ad <- A.get
|
||||
ud <- getAffection
|
||||
when (state ud == Main WorldMap || state ud == Main MindMap) $ do
|
||||
curState <- liftIO $ readMVar (state ud)
|
||||
when (curState == Main WorldMap || curState == Main MindMap) $ do
|
||||
let Subsystems w m k j t = subsystems ud
|
||||
mapM_ (partUnSubscribe w) (uuid ud)
|
||||
mapM_ (partUnSubscribe m) (uuid ud)
|
||||
mapM_ (partUnSubscribe k) (uuid ud)
|
||||
mapM_ (partUnSubscribe j) (uuid ud)
|
||||
mapM_ (partUnSubscribe t) (uuid ud)
|
||||
curUUID <- liftIO $ readMVar (uuid ud)
|
||||
mapM_ (partUnSubscribe w) curUUID
|
||||
mapM_ (partUnSubscribe m) curUUID
|
||||
mapM_ (partUnSubscribe k) curUUID
|
||||
mapM_ (partUnSubscribe j) curUUID
|
||||
mapM_ (partUnSubscribe t) curUUID
|
||||
SDL.glMakeCurrent
|
||||
(snd $ head $ drawWindows ad)
|
||||
(snd $ head $ glContext ad)
|
||||
(awWindow $ head $ drawWindows ad)
|
||||
(acContext $ head $ glContext ad)
|
||||
(ws, _) <- yieldSystemT (0, defStorage) (return ())
|
||||
putAffection ud
|
||||
{ worldState = ws
|
||||
, state = Load
|
||||
}
|
||||
smLoad Load
|
||||
| otherwise = return ()
|
||||
quitGame _ = return ()
|
||||
void $ liftIO $ swapMVar (worldState ud) ws
|
||||
void $ liftIO $ swapMVar (state ud) Load
|
||||
smLoad Load ud
|
||||
| otherwise = return ()
|
||||
quitGame _ _ = return ()
|
||||
|
||||
toggleFullScreen :: KeyboardMessage -> Affection UserData ()
|
||||
toggleFullScreen :: KeyboardMessage -> Affection ()
|
||||
toggleFullScreen (MsgKeyboardEvent _ _ SDL.Pressed False sym)
|
||||
| SDL.keysymKeycode sym == SDL.KeycodeF11 = toggleScreen
|
||||
| SDL.keysymKeycode sym == SDL.KeycodeF11 = toggleScreen 0
|
||||
| otherwise = return ()
|
||||
toggleFullScreen _ = return ()
|
||||
|
||||
update :: Double -> Affection UserData ()
|
||||
update dt = do
|
||||
ud <- getAffection
|
||||
smUpdate (state ud) dt
|
||||
update :: UserData -> Double -> Affection ()
|
||||
update ud dt = do
|
||||
curState <- liftIO $ readMVar (state ud)
|
||||
smUpdate curState ud dt
|
||||
|
||||
draw :: Affection UserData ()
|
||||
draw = do
|
||||
ud <- getAffection
|
||||
draw :: UserData -> Affection ()
|
||||
draw ud = do
|
||||
curState <- liftIO $ readMVar (state ud)
|
||||
liftIO $ beginFrame (nano ud) 1280 720 1
|
||||
smDraw (state ud)
|
||||
smDraw curState ud
|
||||
liftIO $ endFrame (nano ud)
|
||||
|
||||
handle :: [SDL.EventPayload] -> Affection UserData ()
|
||||
handle evs = do
|
||||
s <- state <$> getAffection
|
||||
smEvent s evs
|
||||
handle :: UserData -> [SDL.EventPayload] -> Affection ()
|
||||
handle ud evs = do
|
||||
s <- liftIO $ readMVar (state ud)
|
||||
smEvent s ud evs
|
||||
|
||||
exitOnWindowClose :: WindowMessage -> Affection UserData ()
|
||||
exitOnWindowClose (MsgWindowClose _ _) = do
|
||||
exitOnWindowClose :: UserData -> WindowMessage -> Affection ()
|
||||
exitOnWindowClose ud (MsgWindowClose _ _) = do
|
||||
liftIO $ logIO A.Debug "Window Closed"
|
||||
quit
|
||||
exitOnWindowClose _ = return ()
|
||||
void $ liftIO $ swapMVar (doNextStep ud) False
|
||||
exitOnWindowClose _ _ = return ()
|
||||
|
||||
clean :: UserData -> IO ()
|
||||
clean ud =
|
||||
SDL.glDeleteContext $ fromJust $ threadContext ud
|
||||
clean ud = do
|
||||
tContext <- readMVar (threadContext ud)
|
||||
SDL.glDeleteContext $ fromJust tContext
|
||||
|
|
|
@ -15,6 +15,9 @@ import Data.String
|
|||
|
||||
import NanoVG hiding (V2(..))
|
||||
|
||||
import Control.Concurrent.MVar
|
||||
import Control.Monad
|
||||
|
||||
-- internal imports
|
||||
|
||||
import Types
|
||||
|
@ -25,145 +28,146 @@ import Collision
|
|||
|
||||
import Util
|
||||
|
||||
updateMind :: Double -> Affection UserData ()
|
||||
updateMind dt = do
|
||||
ud <- getAffection
|
||||
(nws, _) <- yieldSystemT (worldState ud) $ do
|
||||
emap allEnts $ do
|
||||
with player
|
||||
with xyvel
|
||||
with mmvel
|
||||
V2 rx ry <- query xyvel
|
||||
-- let dr = (ry / sin (atan (1/2)) / 2) + rx
|
||||
-- dc = rx - (ry / sin (atan (1/2)) / 2)
|
||||
let V2 dr dc = fmap (* 1.5) (V2 rx ry `rotVec` 45)
|
||||
return $ unchanged
|
||||
{ mmvel = Set $ 2 * V2 dr dc
|
||||
}
|
||||
emap allEnts $ do
|
||||
with anim
|
||||
with mmpos
|
||||
stat <- query anim
|
||||
let an = assetAnimations ud Map.! asId stat
|
||||
ntime = asElapsedTime stat + dt
|
||||
nstate = if ntime > fromIntegral (asCurrentFrame stat) *
|
||||
(animDuration an / fromIntegral (length $ animSprites an))
|
||||
then
|
||||
let nframe = asCurrentFrame stat + 1
|
||||
in case animPlay an of
|
||||
APLoop ->
|
||||
let (nnframe, nntime) =
|
||||
if nframe >= length (animSprites an)
|
||||
then (0, 0)
|
||||
else (nframe, ntime)
|
||||
in stat
|
||||
{ asCurrentFrame = nnframe
|
||||
, asElapsedTime = nntime
|
||||
}
|
||||
APOnce ->
|
||||
let nnframe = if nframe >= length (animSprites an)
|
||||
then nframe - 1
|
||||
else nframe
|
||||
in stat
|
||||
{ asCurrentFrame = nnframe
|
||||
, asElapsedTime = ntime
|
||||
}
|
||||
else
|
||||
stat
|
||||
{ asElapsedTime = ntime
|
||||
}
|
||||
return $ unchanged
|
||||
{ anim = Set nstate
|
||||
}
|
||||
emap allEnts $ do
|
||||
with player
|
||||
with mmvel
|
||||
with mmpos
|
||||
with rot
|
||||
with anim
|
||||
pos'@(V2 pr pc) <- query mmpos
|
||||
vel' <- query mmvel
|
||||
rot' <- query rot
|
||||
stat <- query anim
|
||||
let npos = pos' + fmap (* dt) vel'
|
||||
dpos@(V2 dpr dpc) = npos - pos'
|
||||
aId = asId stat
|
||||
nstat = case aiName aId of
|
||||
"walking"
|
||||
| sqrt (colldpos `dot` colldpos) > 0 ->
|
||||
stat
|
||||
{ asId = aId
|
||||
{ aiDirection = fromMaybe rot' (direction vel')
|
||||
}
|
||||
}
|
||||
| otherwise ->
|
||||
stat
|
||||
{ asId = aId
|
||||
{ aiDirection = fromMaybe rot' (direction vel')
|
||||
, aiName = "standing"
|
||||
}
|
||||
, asCurrentFrame = 0
|
||||
}
|
||||
"standing"
|
||||
| sqrt (colldpos `dot` colldpos) > 0 ->
|
||||
stat
|
||||
{ asId = aId
|
||||
{ aiDirection = fromMaybe rot' (direction vel')
|
||||
, aiName = "walking"
|
||||
}
|
||||
, asCurrentFrame = 0
|
||||
}
|
||||
| otherwise ->
|
||||
stat
|
||||
{ asId = aId
|
||||
{ aiDirection = fromMaybe rot' (direction vel')
|
||||
}
|
||||
}
|
||||
x -> error ("unknown animation name" ++ x)
|
||||
lll = (,)
|
||||
<$> (
|
||||
if dpr < 0
|
||||
then [(floor dpr :: Int) .. 0]
|
||||
else [0 .. (ceiling dpr :: Int)])
|
||||
<*> (
|
||||
if dpc < 0
|
||||
then [(floor dpc :: Int) .. 0]
|
||||
else [0 .. (ceiling dpc :: Int)])
|
||||
colldpos = dpos * Prelude.foldl
|
||||
(\acc a -> let ret = checkBoundsCollision2 pos' npos dt acc a
|
||||
in A.log A.Verbose (fromString $ show ret) ret)
|
||||
(V2 1 1)
|
||||
(
|
||||
concatMap
|
||||
(\(dr, dc) ->
|
||||
let bs = fromMaybe [] $ collisionObstacle <$> M.unsafeGet
|
||||
(fromIntegral $ floor pr + dr)
|
||||
(fromIntegral $ floor pc + dc)
|
||||
(mmImgMat (stateData ud))
|
||||
in Prelude.map (\(Boundaries (minr, minc) (maxr, maxc))->
|
||||
Boundaries
|
||||
(minr + fromIntegral dr, minc + fromIntegral dc)
|
||||
(maxr + fromIntegral dr, maxc + fromIntegral dc)
|
||||
) bs
|
||||
)
|
||||
lll -- (A.log A.Verbose (show lll ++ " " ++ show len) lll)
|
||||
)
|
||||
ent = unchanged
|
||||
{ mmpos = Set $ pos' + colldpos
|
||||
, rot = Set (fromMaybe rot' $ direction vel')
|
||||
, anim = Set nstat
|
||||
}
|
||||
return ent
|
||||
putAffection ud
|
||||
{ worldState = nws
|
||||
}
|
||||
updateMind :: UserData -> Double -> Affection ()
|
||||
updateMind ud dt = do
|
||||
wState <- liftIO $ readMVar (worldState ud)
|
||||
sData <- liftIO $ readMVar (stateData ud)
|
||||
(nws, _) <- yieldSystemT wState $ do
|
||||
emap allEnts $ do
|
||||
with player
|
||||
with xyvel
|
||||
with mmvel
|
||||
V2 rx ry <- query xyvel
|
||||
-- let dr = (ry / sin (atan (1/2)) / 2) + rx
|
||||
-- dc = rx - (ry / sin (atan (1/2)) / 2)
|
||||
let V2 dr dc = fmap (* 1.5) (V2 rx ry `rotVec` 45)
|
||||
return $ unchanged
|
||||
{ mmvel = Set $ 2 * V2 dr dc
|
||||
}
|
||||
emap allEnts $ do
|
||||
with anim
|
||||
with mmpos
|
||||
stat <- query anim
|
||||
aAnims <- liftIO $ readMVar (assetAnimations ud)
|
||||
let an = aAnims Map.! asId stat
|
||||
ntime = asElapsedTime stat + dt
|
||||
nstate = if ntime > fromIntegral (asCurrentFrame stat) *
|
||||
(animDuration an / fromIntegral (length $ animSprites an))
|
||||
then
|
||||
let nframe = asCurrentFrame stat + 1
|
||||
in case animPlay an of
|
||||
APLoop ->
|
||||
let (nnframe, nntime) =
|
||||
if nframe >= length (animSprites an)
|
||||
then (0, 0)
|
||||
else (nframe, ntime)
|
||||
in stat
|
||||
{ asCurrentFrame = nnframe
|
||||
, asElapsedTime = nntime
|
||||
}
|
||||
APOnce ->
|
||||
let nnframe = if nframe >= length (animSprites an)
|
||||
then nframe - 1
|
||||
else nframe
|
||||
in stat
|
||||
{ asCurrentFrame = nnframe
|
||||
, asElapsedTime = ntime
|
||||
}
|
||||
else
|
||||
stat
|
||||
{ asElapsedTime = ntime
|
||||
}
|
||||
return $ unchanged
|
||||
{ anim = Set nstate
|
||||
}
|
||||
emap allEnts $ do
|
||||
with player
|
||||
with mmvel
|
||||
with mmpos
|
||||
with rot
|
||||
with anim
|
||||
pos'@(V2 pr pc) <- query mmpos
|
||||
vel' <- query mmvel
|
||||
rot' <- query rot
|
||||
stat <- query anim
|
||||
let npos = pos' + fmap (* dt) vel'
|
||||
dpos@(V2 dpr dpc) = npos - pos'
|
||||
aId = asId stat
|
||||
nstat = case aiName aId of
|
||||
"walking"
|
||||
| sqrt (colldpos `dot` colldpos) > 0 ->
|
||||
stat
|
||||
{ asId = aId
|
||||
{ aiDirection = fromMaybe rot' (direction vel')
|
||||
}
|
||||
}
|
||||
| otherwise ->
|
||||
stat
|
||||
{ asId = aId
|
||||
{ aiDirection = fromMaybe rot' (direction vel')
|
||||
, aiName = "standing"
|
||||
}
|
||||
, asCurrentFrame = 0
|
||||
}
|
||||
"standing"
|
||||
| sqrt (colldpos `dot` colldpos) > 0 ->
|
||||
stat
|
||||
{ asId = aId
|
||||
{ aiDirection = fromMaybe rot' (direction vel')
|
||||
, aiName = "walking"
|
||||
}
|
||||
, asCurrentFrame = 0
|
||||
}
|
||||
| otherwise ->
|
||||
stat
|
||||
{ asId = aId
|
||||
{ aiDirection = fromMaybe rot' (direction vel')
|
||||
}
|
||||
}
|
||||
x -> error ("unknown animation name" ++ x)
|
||||
lll = (,)
|
||||
<$> (
|
||||
if dpr < 0
|
||||
then [(floor dpr :: Int) .. 0]
|
||||
else [0 .. (ceiling dpr :: Int)])
|
||||
<*> (
|
||||
if dpc < 0
|
||||
then [(floor dpc :: Int) .. 0]
|
||||
else [0 .. (ceiling dpc :: Int)])
|
||||
colldpos = dpos * Prelude.foldl
|
||||
(\acc a -> let ret = checkBoundsCollision2 pos' npos dt acc a
|
||||
in A.log A.Verbose (fromString $ show ret) ret)
|
||||
(V2 1 1)
|
||||
(
|
||||
concatMap
|
||||
(\(dr, dc) ->
|
||||
let bs = fromMaybe [] $ collisionObstacle <$> M.unsafeGet
|
||||
(fromIntegral $ floor pr + dr)
|
||||
(fromIntegral $ floor pc + dc)
|
||||
(mmImgMat sData)
|
||||
in Prelude.map (\(Boundaries (minr, minc) (maxr, maxc))->
|
||||
Boundaries
|
||||
(minr + fromIntegral dr, minc + fromIntegral dc)
|
||||
(maxr + fromIntegral dr, maxc + fromIntegral dc)
|
||||
) bs
|
||||
)
|
||||
lll -- (A.log A.Verbose (show lll ++ " " ++ show len) lll)
|
||||
)
|
||||
ent = unchanged
|
||||
{ mmpos = Set $ pos' + colldpos
|
||||
, rot = Set (fromMaybe rot' $ direction vel')
|
||||
, anim = Set nstat
|
||||
}
|
||||
return ent
|
||||
void $ liftIO $ swapMVar (worldState ud) nws
|
||||
|
||||
drawMind :: Affection UserData ()
|
||||
drawMind = do
|
||||
ud <- getAffection
|
||||
drawMind :: UserData -> Affection ()
|
||||
drawMind ud = do
|
||||
sData <- liftIO $ readMVar (stateData ud)
|
||||
wState <- liftIO $ readMVar (worldState ud)
|
||||
let ctx = nano ud
|
||||
dt <- getDelta
|
||||
(_, (playerPos, posanims)) <- yieldSystemT (worldState ud) $ do
|
||||
(_, (playerPos, posanims)) <- yieldSystemT wState $ do
|
||||
pc <- fmap head $ efor allEnts $ do
|
||||
with player
|
||||
with mmpos
|
||||
|
@ -177,7 +181,7 @@ drawMind = do
|
|||
return (pos', stat, mbnds)
|
||||
return (pc, posanims)
|
||||
let V2 pr pc = playerPos
|
||||
mat = mmImgMat (stateData ud)
|
||||
mat = mmImgMat sData
|
||||
cols = fromIntegral (ncols mat)
|
||||
rows = fromIntegral (nrows mat)
|
||||
tileWidth = 64 :: Double
|
||||
|
@ -185,8 +189,8 @@ drawMind = do
|
|||
x = realToFrac $ 640 + ((1 - pc) + (1 - pr)) * (tileWidth / 2)
|
||||
y = realToFrac $ 360 + ((1 - pr) - (1 - pc)) * (tileHeight / 2)
|
||||
partposanims = M.fromList
|
||||
(nrows $ mmImgMat $ stateData ud)
|
||||
(ncols $ mmImgMat $ stateData ud)
|
||||
(nrows $ mmImgMat $ sData)
|
||||
(ncols $ mmImgMat $ sData)
|
||||
((reverse . fst)
|
||||
(Prelude.foldl
|
||||
(\(done, proc) coord ->
|
||||
|
@ -195,8 +199,8 @@ drawMind = do
|
|||
)
|
||||
([], posanims)
|
||||
((,)
|
||||
<$> [1 .. (nrows $ mmImgMat $ stateData ud)]
|
||||
<*> [1 .. (ncols $ mmImgMat $ stateData ud)]
|
||||
<$> [1 .. (nrows $ mmImgMat $ sData)]
|
||||
<*> [1 .. (ncols $ mmImgMat $ sData)]
|
||||
)
|
||||
)
|
||||
)
|
||||
|
@ -230,7 +234,8 @@ drawMind = do
|
|||
(reverse $ zip [1..] ls))
|
||||
(zip [1..] (toLists mat))
|
||||
fontSize ctx 20
|
||||
fontFace ctx (assetFonts ud Map.! FontBedstead)
|
||||
aFonts <- readMVar (assetFonts ud)
|
||||
fontFace ctx (aFonts Map.! FontBedstead)
|
||||
textAlign ctx (S.fromList [AlignCenter,AlignTop])
|
||||
fillColor ctx (rgb 255 128 0)
|
||||
textBox ctx 0 0 200 ("FPS: " `T.append` T.pack (Prelude.take 5 $ show (1/dt)))
|
||||
|
|
|
@ -11,8 +11,8 @@ import qualified SDL
|
|||
import NanoVG hiding (V2(..))
|
||||
|
||||
import Control.Monad (when, void)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Monad.State.Strict (evalStateT)
|
||||
import Control.Monad.Trans.Resource (ResIO, runResourceT)
|
||||
import Control.Concurrent.MVar
|
||||
import Control.Concurrent (forkIO)
|
||||
import Control.Parallel.Strategies hiding (dot)
|
||||
|
@ -44,63 +44,49 @@ import NPC
|
|||
import Animation
|
||||
import Collision
|
||||
|
||||
loadMap :: Affection UserData ()
|
||||
loadMap = do
|
||||
ud <- getAffection
|
||||
loadMap :: UserData -> Affection ()
|
||||
loadMap ud = do
|
||||
ad <- get
|
||||
let (Subsystems _ _ k j t) = subsystems ud
|
||||
uu0 <- partSubscribe k emitKbdActionMessage
|
||||
uu1 <- partSubscribe j emitJoyActionMessage
|
||||
uu2 <- partSubscribe t movePlayer2
|
||||
uu3 <- partSubscribe t playerInteract2
|
||||
uu4 <- partSubscribe t changeMaps2
|
||||
future <- liftIO newEmptyMVar
|
||||
progress <- liftIO $ newMVar (0, "Ohai!")
|
||||
_ <- liftIO $ forkIO $ loadMapFork ud ad future progress
|
||||
putAffection ud
|
||||
{ stateData = None
|
||||
, uuid = [ uu0, uu1, uu2, uu3, uu4 ]
|
||||
, stateMVar = future
|
||||
, stateProgress = progress
|
||||
, state = Main WorldMap
|
||||
}
|
||||
uu0 <- partSubscribe k (emitKbdActionMessage ud)
|
||||
uu1 <- partSubscribe j (emitJoyActionMessage ud)
|
||||
uu2 <- partSubscribe t (movePlayer2 ud)
|
||||
uu3 <- partSubscribe t (playerInteract2 ud)
|
||||
uu4 <- partSubscribe t (changeMaps2 ud)
|
||||
void $ liftIO $ swapMVar (stateProgress ud) (0, "Ohai!")
|
||||
_ <- liftIO $ forkIO $ loadMapFork ud ad (stateMVar ud) (stateProgress ud)
|
||||
void $ liftIO $ swapMVar (stateData ud) None
|
||||
void $ liftIO $ swapMVar (uuid ud) [ uu0, uu1, uu2, uu3, uu4 ]
|
||||
void $ liftIO $ swapMVar (state ud) (Main WorldMap)
|
||||
|
||||
changeMaps :: KeyboardMessage -> Affection UserData ()
|
||||
changeMaps (MsgKeyboardEvent _ _ SDL.Pressed False sym)
|
||||
changeMaps :: UserData -> KeyboardMessage -> Affection ()
|
||||
changeMaps ud (MsgKeyboardEvent _ _ SDL.Pressed False sym)
|
||||
| SDL.keysymKeycode sym == SDL.KeycodeF1 = do
|
||||
ud <- getAffection
|
||||
case state ud of
|
||||
curState <- liftIO $ readMVar (state ud)
|
||||
case curState of
|
||||
Main MindMap ->
|
||||
putAffection ud
|
||||
{ state = Main WorldMap
|
||||
}
|
||||
void $ liftIO $ swapMVar (state ud) (Main WorldMap)
|
||||
Main WorldMap ->
|
||||
putAffection ud
|
||||
{ state = Main MindMap
|
||||
}
|
||||
void $ liftIO $ swapMVar (state ud) (Main MindMap)
|
||||
_ -> return ()
|
||||
| otherwise = return ()
|
||||
changeMaps _ = return ()
|
||||
changeMaps _ _ = return ()
|
||||
|
||||
changeMaps2 :: ActionMessage -> Affection UserData ()
|
||||
changeMaps2 (ActionMessage ActSwitchMap _) = do
|
||||
ud <- getAffection
|
||||
case state ud of
|
||||
changeMaps2 :: UserData -> ActionMessage -> Affection ()
|
||||
changeMaps2 ud (ActionMessage ActSwitchMap _) = do
|
||||
curState <- liftIO $ readMVar (state ud)
|
||||
case curState of
|
||||
Main MindMap ->
|
||||
putAffection ud
|
||||
{ state = Main WorldMap
|
||||
}
|
||||
void $ liftIO $ swapMVar (state ud) (Main WorldMap)
|
||||
Main WorldMap ->
|
||||
putAffection ud
|
||||
{ state = Main MindMap
|
||||
}
|
||||
void $ liftIO $ swapMVar (state ud) (Main MindMap)
|
||||
_ -> return ()
|
||||
changeMaps2 _ = return ()
|
||||
changeMaps2 _ _ = return ()
|
||||
|
||||
loadMapFork
|
||||
:: UserData
|
||||
-> AffectionData UserData
|
||||
-> MVar (SystemState Entity (AffectionState (AffectionData UserData) IO), StateData)
|
||||
-> AffectionData
|
||||
-> MVar (SystemState Entity (AffectionState AffectionData ResIO), StateData)
|
||||
-> MVar (Float, T.Text)
|
||||
-> IO ()
|
||||
loadMapFork ud ad future progress = do
|
||||
|
@ -109,7 +95,7 @@ loadMapFork ud ad future progress = do
|
|||
fc = FloorConfig
|
||||
(V2 10 10)
|
||||
[(V2 5 5), (V2 5 20)]
|
||||
(50, 50)
|
||||
(40, 40)
|
||||
modifyMVar_ progress (return . (\(p, _) ->
|
||||
( p + increment
|
||||
, "Building floor"
|
||||
|
@ -144,7 +130,8 @@ loadMapFork ud ad future progress = do
|
|||
( p + increment
|
||||
, "Creating WorldState"
|
||||
)))
|
||||
(nws, mmimgmat) <- evalStateT (runState (yieldSystemT (worldState ud) $ do
|
||||
wState <- liftIO $ readMVar (worldState ud)
|
||||
(nws, mmimgmat) <- runResourceT $ evalStateT (runState (yieldSystemT wState $ do
|
||||
liftIO $ modifyMVar_ progress (return . (\(p, _) ->
|
||||
( p + increment
|
||||
, "Registering copiers into WorldState"
|
||||
|
@ -262,6 +249,7 @@ loadMapFork ud ad future progress = do
|
|||
<*> (randomRIO (0, 1))
|
||||
<*> (randomRIO (0, 1))
|
||||
<*> (randomRIO (0, 1))
|
||||
police <- liftIO $ randomRIO (0 :: Int, 9 :: Int)
|
||||
let room = V.head
|
||||
(V.filter
|
||||
((inBounds $ pointCoord cpr) . bounds)
|
||||
|
@ -278,7 +266,8 @@ loadMapFork ud ad future progress = do
|
|||
, npcActionState = Just ASWork
|
||||
, npcStats = Just stats
|
||||
, clearanceLvl = Just (clearance room)
|
||||
, anim = Just $ AnimState (AnimId AnimJDoeM "standing" SE) 0 0
|
||||
, anim = Just $ AnimState
|
||||
(AnimId (if police == 0 then AnimPoliceM else AnimJDoeM) "standing" SE) 0 0
|
||||
}
|
||||
) computers
|
||||
liftIO $ modifyMVar_ progress (return . (\(p, _) ->
|
||||
|
@ -352,7 +341,7 @@ loadMapFork ud ad future progress = do
|
|||
then Nothing
|
||||
else a)
|
||||
(M.toList inter)
|
||||
putMVar future (nws, MainData
|
||||
void $ putMVar future (nws, MainData
|
||||
{ mapMat = mat
|
||||
, imgMat = retMat
|
||||
, reachPoints = V.fromList rps
|
||||
|
@ -360,11 +349,11 @@ loadMapFork ud ad future progress = do
|
|||
, roomGraph = gr
|
||||
})
|
||||
|
||||
movePlayerKbd :: KeyboardMessage -> Affection UserData ()
|
||||
movePlayerKbd (MsgKeyboardEvent _ _ press False sym)
|
||||
movePlayerKbd :: UserData -> KeyboardMessage -> Affection ()
|
||||
movePlayerKbd ud (MsgKeyboardEvent _ _ press False sym)
|
||||
| SDL.keysymKeycode sym == SDL.KeycodeW = do
|
||||
ud <- getAffection
|
||||
(nws, _) <- yieldSystemT (worldState ud) $
|
||||
wState <- liftIO $ readMVar (worldState ud)
|
||||
(nws, _) <- yieldSystemT wState $
|
||||
emap allEnts $ do
|
||||
with player
|
||||
(V2 vx _) <- query xyvel
|
||||
|
@ -374,12 +363,10 @@ movePlayerKbd (MsgKeyboardEvent _ _ press False sym)
|
|||
return $ unchanged
|
||||
{ xyvel = Set $ V2 vx ry
|
||||
}
|
||||
putAffection ud
|
||||
{ worldState = nws
|
||||
}
|
||||
void $ liftIO $ swapMVar (worldState ud) nws
|
||||
| SDL.keysymKeycode sym == SDL.KeycodeS = do
|
||||
ud <- getAffection
|
||||
(nws, _) <- yieldSystemT (worldState ud) $
|
||||
wState <- liftIO $ readMVar (worldState ud)
|
||||
(nws, _) <- yieldSystemT wState $
|
||||
emap allEnts $ do
|
||||
with player
|
||||
(V2 vx _) <- query xyvel
|
||||
|
@ -389,12 +376,10 @@ movePlayerKbd (MsgKeyboardEvent _ _ press False sym)
|
|||
return $ unchanged
|
||||
{ xyvel = Set $ V2 vx ry
|
||||
}
|
||||
putAffection ud
|
||||
{ worldState = nws
|
||||
}
|
||||
void $ liftIO $ swapMVar (worldState ud) nws
|
||||
| SDL.keysymKeycode sym == SDL.KeycodeA = do
|
||||
ud <- getAffection
|
||||
(nws, _) <- yieldSystemT (worldState ud) $
|
||||
wState <- liftIO $ readMVar (worldState ud)
|
||||
(nws, _) <- yieldSystemT wState $
|
||||
emap allEnts $ do
|
||||
with player
|
||||
(V2 _ vy) <- query xyvel
|
||||
|
@ -404,12 +389,10 @@ movePlayerKbd (MsgKeyboardEvent _ _ press False sym)
|
|||
return $ unchanged
|
||||
{ xyvel = Set $ V2 rx vy
|
||||
}
|
||||
putAffection ud
|
||||
{ worldState = nws
|
||||
}
|
||||
void $ liftIO $ swapMVar (worldState ud) nws
|
||||
| SDL.keysymKeycode sym == SDL.KeycodeD = do
|
||||
ud <- getAffection
|
||||
(nws, _) <- yieldSystemT (worldState ud) $
|
||||
wState <- liftIO $ readMVar (worldState ud)
|
||||
(nws, _) <- yieldSystemT wState $
|
||||
emap allEnts $ do
|
||||
with player
|
||||
(V2 _ vy) <- query xyvel
|
||||
|
@ -419,16 +402,14 @@ movePlayerKbd (MsgKeyboardEvent _ _ press False sym)
|
|||
return $ unchanged
|
||||
{ xyvel = Set $ V2 rx vy
|
||||
}
|
||||
putAffection ud
|
||||
{ worldState = nws
|
||||
}
|
||||
void $ liftIO $ swapMVar (worldState ud) nws
|
||||
| otherwise = return ()
|
||||
movePlayerKbd _ = return ()
|
||||
movePlayerKbd _ _ = return ()
|
||||
|
||||
movePlayer2 :: ActionMessage -> Affection UserData ()
|
||||
movePlayer2 (ActionMessage mov _) = do
|
||||
ud <- getAffection
|
||||
(nws, _) <- yieldSystemT (worldState ud) $
|
||||
movePlayer2 :: UserData -> ActionMessage -> Affection ()
|
||||
movePlayer2 ud (ActionMessage mov _) = do
|
||||
wState <- liftIO $ readMVar (worldState ud)
|
||||
(nws, _) <- yieldSystemT wState $
|
||||
emap allEnts $ do
|
||||
with player
|
||||
V2 vx vy <- query xyvel
|
||||
|
@ -440,14 +421,12 @@ movePlayer2 (ActionMessage mov _) = do
|
|||
ActRight f -> V2 f vy
|
||||
_ -> V2 vx vy
|
||||
}
|
||||
putAffection ud
|
||||
{ worldState = nws
|
||||
}
|
||||
void $ liftIO $ swapMVar (worldState ud) nws
|
||||
|
||||
playerInteract2 :: ActionMessage -> Affection UserData ()
|
||||
playerInteract2 (ActionMessage ActActivate _) = do
|
||||
ud <- getAffection
|
||||
(nws, _) <- yieldSystemT (worldState ud) $ do
|
||||
playerInteract2 :: UserData -> ActionMessage -> Affection ()
|
||||
playerInteract2 ud (ActionMessage ActActivate _) = do
|
||||
wState <- liftIO $ readMVar (worldState ud)
|
||||
(nws, _) <- yieldSystemT wState $ do
|
||||
pdata <- efor allEnts $ do
|
||||
with player
|
||||
with pos
|
||||
|
@ -478,22 +457,21 @@ playerInteract2 (ActionMessage ActActivate _) = do
|
|||
mapM_ (\(t, s, e) ->
|
||||
setEntity e =<< objectTransition t s True e (Just pent)
|
||||
) relEnts
|
||||
putAffection ud
|
||||
{ worldState = nws
|
||||
}
|
||||
playerInteract2 _ = return ()
|
||||
void $ liftIO $ swapMVar (worldState ud) nws
|
||||
playerInteract2 _ _ = return ()
|
||||
|
||||
drawMap :: Affection UserData ()
|
||||
drawMap = do
|
||||
ud <- getAffection
|
||||
drawMap :: UserData -> Affection ()
|
||||
drawMap ud = do
|
||||
sData <- liftIO $ readMVar (stateData ud)
|
||||
wState <- liftIO $ readMVar (worldState ud)
|
||||
let ctx = nano ud
|
||||
case stateData ud of
|
||||
case sData of
|
||||
None -> liftIO $ do
|
||||
progress <- readMVar (stateProgress ud)
|
||||
drawLoadScreen ud progress
|
||||
_ -> do
|
||||
dt <- getDelta
|
||||
(_, dat) <- yieldSystemT (worldState ud) $ do
|
||||
(_, dat) <- yieldSystemT wState $ do
|
||||
efor allEnts $ do
|
||||
with pos
|
||||
pos' <- query pos
|
||||
|
@ -534,10 +512,10 @@ drawMap = do
|
|||
([], [], [])
|
||||
dat
|
||||
V2 pr pc = playerPos
|
||||
MainData _ _ _ _ gr = stateData ud
|
||||
MainData _ _ _ _ gr = sData
|
||||
seekGraph = V.foldl V.snoc (Types.connects (V.head gr)) (V.tail gr)
|
||||
room = V.filter (inBounds (fmap floor playerPos) . bounds) seekGraph
|
||||
mat = imgMat (stateData ud)
|
||||
mat = imgMat sData
|
||||
cols = fromIntegral (ncols mat)
|
||||
rows = fromIntegral (nrows mat)
|
||||
tileWidth = 64 :: Double
|
||||
|
@ -545,8 +523,8 @@ drawMap = do
|
|||
x = realToFrac $ 640 + ((1 - pc) + (1 - pr)) * (tileWidth / 2)
|
||||
y = realToFrac $ 360 + ((1 - pr) - (1 - pc)) * (tileHeight / 2)
|
||||
partposanims = M.fromList
|
||||
(nrows $ mapMat $ stateData ud)
|
||||
(ncols $ mapMat $ stateData ud)
|
||||
(nrows $ mapMat sData)
|
||||
(ncols $ mapMat sData)
|
||||
((reverse . fst)
|
||||
(Prelude.foldl
|
||||
(\(done, proc) coord ->
|
||||
|
@ -555,8 +533,8 @@ drawMap = do
|
|||
)
|
||||
([], posanims)
|
||||
((,)
|
||||
<$> [1 .. (nrows $ mapMat $ stateData ud)]
|
||||
<*> [1 .. (ncols $ mapMat $ stateData ud)]
|
||||
<$> [1 .. (nrows $ mapMat sData)]
|
||||
<*> [1 .. (ncols $ mapMat sData)]
|
||||
)
|
||||
)
|
||||
)
|
||||
|
@ -634,17 +612,20 @@ drawMap = do
|
|||
closePath ctx
|
||||
) posActions
|
||||
fontSize ctx 20
|
||||
fontFace ctx (assetFonts ud Map.! FontBedstead)
|
||||
aFonts <- readMVar (assetFonts ud)
|
||||
fontFace ctx (aFonts Map.! FontBedstead)
|
||||
textAlign ctx (S.fromList [AlignCenter,AlignTop])
|
||||
fillColor ctx (rgb 255 128 0)
|
||||
textBox ctx 0 0 200 (
|
||||
"FPS: "
|
||||
<> T.pack (Prelude.take 5 $ show (1/dt))
|
||||
<> " Clearance: "
|
||||
<> if not (Prelude.null room)
|
||||
<> (if not (Prelude.null room)
|
||||
then T.pack (show $ clearance $ V.head room)
|
||||
else "0"
|
||||
)
|
||||
-- <> "\nFor answers call 6350"
|
||||
)
|
||||
|
||||
drawTile
|
||||
:: UserData
|
||||
|
@ -656,23 +637,23 @@ drawTile
|
|||
-> Int
|
||||
-> Maybe ImgId
|
||||
-> IO ()
|
||||
drawTile ud ctx posanims pr pc row col img =
|
||||
do
|
||||
let (bef, beh) = L.partition delimiter sorted
|
||||
save ctx
|
||||
mapM_ (flip drawAnim fact) beh
|
||||
maybe (return ()) (draw ud x (y - 42) 64 74
|
||||
(if fromMaybe False (isWall <$> img) then fact else 1))
|
||||
((assetImages ud Map.!) <$> case img of
|
||||
Just ImgEmpty -> Nothing
|
||||
_ -> img
|
||||
)
|
||||
mapM_ (flip drawAnim fact) bef
|
||||
restore ctx
|
||||
-- when (floor pr == row && floor pc == col) $ do
|
||||
-- A.logIO A.Debug ("sorted: " ++ show sorted)
|
||||
-- A.logIO A.Debug ("beh: " ++ show beh)
|
||||
-- A.logIO A.Debug ("bef: " ++ show bef)
|
||||
drawTile ud ctx posanims pr pc row col img = do
|
||||
let (bef, beh) = L.partition delimiter sorted
|
||||
aImages <- readMVar (assetImages ud)
|
||||
save ctx
|
||||
mapM_ (flip drawAnim fact) beh
|
||||
maybe (return ()) (Types.draw ud x (y - 42) 64 74
|
||||
(if fromMaybe False (isWall <$> img) then fact else 1))
|
||||
((aImages Map.!) <$> case img of
|
||||
Just ImgEmpty -> Nothing
|
||||
_ -> img
|
||||
)
|
||||
mapM_ (flip drawAnim fact) bef
|
||||
restore ctx
|
||||
-- when (floor pr == row && floor pc == col) $ do
|
||||
-- A.logIO A.Debug ("sorted: " ++ show sorted)
|
||||
-- A.logIO A.Debug ("beh: " ++ show beh)
|
||||
-- A.logIO A.Debug ("bef: " ++ show bef)
|
||||
where
|
||||
delimiter (V2 nr nc, as, mbnds) =
|
||||
animFloats (asId as) ||
|
||||
|
@ -726,29 +707,30 @@ drawTile ud ctx posanims pr pc row col img =
|
|||
drawAnim (V2 nr nc, as, _) factor = do
|
||||
let ax = realToFrac $ 640 + ((nc - pc) + (nr - pr)) * 32 - 32
|
||||
ay = realToFrac $ 360 + ((nr - pr) - (nc - pc)) * 16 - 58
|
||||
draw ud ax ay 64 74 (if isWallLike (aiVariation $ asId as) then factor else 1) as
|
||||
Types.draw ud ax ay 64 74 (if isWallLike (aiVariation $ asId as) then factor else 1) as
|
||||
|
||||
updateMap :: Double -> Affection UserData ()
|
||||
updateMap dt = do
|
||||
ud <- getAffection
|
||||
if stateData ud == None
|
||||
updateMap :: UserData -> Double -> Affection ()
|
||||
updateMap ud dt = do
|
||||
osData <- liftIO $ readMVar (stateData ud)
|
||||
if osData == None
|
||||
then do
|
||||
mstart <- liftIO $ tryTakeMVar (stateMVar ud)
|
||||
case mstart of
|
||||
Just (nws, mendat) -> do
|
||||
putAffection ud
|
||||
{ worldState = nws
|
||||
, stateData = mendat
|
||||
, state = Main WorldMap
|
||||
}
|
||||
updateMap 0.1
|
||||
updateMap 0.1
|
||||
updateMap 0.1
|
||||
updateMap 19
|
||||
void $ liftIO $ swapMVar (worldState ud) nws
|
||||
void $ liftIO $ swapMVar (stateData ud) mendat
|
||||
void $ liftIO $ swapMVar (state ud) (Main WorldMap)
|
||||
updateMap ud 0.1
|
||||
updateMap ud 0.1
|
||||
updateMap ud 0.1
|
||||
updateMap ud 19
|
||||
liftIO $ logIO A.Debug "Loaded game data"
|
||||
Nothing -> return ()
|
||||
else do
|
||||
(nws, _) <- yieldSystemT (worldState ud) $ do
|
||||
wState <- liftIO $ readMVar (worldState ud)
|
||||
sData <- liftIO $ readMVar (stateData ud)
|
||||
aAnim <- liftIO $ readMVar (assetAnimations ud)
|
||||
(nws, _) <- yieldSystemT wState $ do
|
||||
obstacleBounds <- efor allEnts $ do
|
||||
with obstacle
|
||||
with pos
|
||||
|
@ -762,8 +744,8 @@ updateMap dt = do
|
|||
fact' <- fromMaybe 1 <$> queryMaybe velFact
|
||||
xyv2 <- queryMaybe xyvel
|
||||
stat <- query anim
|
||||
let an = assetAnimations ud Map.! asId stat
|
||||
mat = mapMat (stateData ud)
|
||||
let an = aAnim Map.! asId stat
|
||||
mat = mapMat sData
|
||||
ntime = asElapsedTime stat + dt
|
||||
npos = pos' + fmap (* (dt * fact')) (fromMaybe (V2 0 0) vel')
|
||||
dpos@(V2 dpr dpc) = npos - pos'
|
||||
|
@ -789,7 +771,7 @@ updateMap dt = do
|
|||
(fromMaybe [] $ collisionObstacle <$> M.unsafeGet
|
||||
(min (nrows mat) $ max 1 $ fromIntegral $ floor pr + dr)
|
||||
(min (ncols mat) $ max 1 $ fromIntegral $ floor pc + dc)
|
||||
(imgMat (stateData ud)))
|
||||
(imgMat sData))
|
||||
(Prelude.map snd $ Prelude.filter
|
||||
(\((V2 br bc), _) ->
|
||||
floor pr + dr == floor br &&
|
||||
|
@ -899,14 +881,12 @@ updateMap dt = do
|
|||
objectAction dt t s e
|
||||
) tses
|
||||
(nws2, _) <- yieldSystemT nws $ updateNPCs
|
||||
(imgMat $ stateData ud)
|
||||
(mapMat $ stateData ud)
|
||||
(imgMat sData)
|
||||
(mapMat sData)
|
||||
nws
|
||||
(V.filter
|
||||
(\p -> pointType p /= RoomExit)
|
||||
(reachPoints $ stateData ud)
|
||||
(reachPoints sData)
|
||||
)
|
||||
dt
|
||||
putAffection ud
|
||||
{ worldState = nws2
|
||||
}
|
||||
void $ liftIO $ swapMVar (worldState ud) nws2
|
||||
|
|
|
@ -10,98 +10,74 @@ import qualified Data.Map.Strict as M
|
|||
import qualified Data.Set as S
|
||||
import Data.List (find)
|
||||
import Data.Maybe (fromJust, isJust)
|
||||
import Data.String
|
||||
import Data.String (fromString)
|
||||
|
||||
import Control.Monad
|
||||
|
||||
import Control.Concurrent.MVar
|
||||
|
||||
-- internal imports
|
||||
|
||||
import Types
|
||||
import Util
|
||||
|
||||
loadAdjust :: Action -> Controller -> Affection UserData () -> Affection UserData ()
|
||||
loadAdjust sub contr switchBack = do
|
||||
ud <- getAffection
|
||||
let Subsystems w m k j t = subsystems ud
|
||||
uu1 <- partSubscribe j (joyListener switchBack)
|
||||
putAffection ud
|
||||
{ state = Menu (Adjust sub contr)
|
||||
, uuid = [ uu1 ]
|
||||
}
|
||||
loadAdjust :: UserData -> Action -> Controller -> Affection () -> Affection ()
|
||||
loadAdjust ud sub contr switchBack = do
|
||||
let Subsystems _ _ _ j _ = subsystems ud
|
||||
uu1 <- partSubscribe j (joyListener ud switchBack)
|
||||
void $ liftIO $ swapMVar (state ud) (Menu (Adjust sub contr))
|
||||
void $ liftIO $ swapMVar (uuid ud) [uu1]
|
||||
|
||||
joyListener :: Affection UserData () -> JoystickMessage -> Affection UserData ()
|
||||
joyListener switchBack (MsgJoystickAxis _ _ axis val) = do
|
||||
ud <- getAffection
|
||||
liftIO $ logIO
|
||||
A.Debug
|
||||
("switching " <>
|
||||
fromString (show $ state ud) <>
|
||||
" to " <>
|
||||
fromString (show axis)
|
||||
)
|
||||
let trans = translation ud
|
||||
align
|
||||
| val > 0 = AxisPositive
|
||||
| val < 0 = AxisNegative
|
||||
| otherwise = A.log A.Error "Can not assign neitral axis align" (error "*dies*")
|
||||
case trans of
|
||||
JoyTranslation tmap -> do
|
||||
case state ud of
|
||||
Menu (Adjust (ActUp s) (Joystick _)) -> do
|
||||
let k = fst <$> find (\(_, v) -> v == ActUp 1) (M.assocs tmap)
|
||||
putAffection ud
|
||||
{ translation = JoyTranslation $
|
||||
M.insert (AxisAction (fromIntegral axis) align) (ActUp 1) $
|
||||
if isJust k then M.delete (fromJust k) (tmap) else tmap
|
||||
}
|
||||
Menu (Adjust (ActDown s) (Joystick _)) -> do
|
||||
let k = fst <$> find (\(_, v) -> v == ActDown 1) (M.assocs tmap)
|
||||
putAffection ud
|
||||
{ translation = JoyTranslation $
|
||||
M.insert (AxisAction (fromIntegral axis) align) (ActDown 1) $
|
||||
if isJust k then M.delete (fromJust k) (tmap) else tmap
|
||||
}
|
||||
Menu (Adjust (ActLeft s) (Joystick _)) -> do
|
||||
let k = fst <$> find (\(_, v) -> v == ActLeft 1) (M.assocs tmap)
|
||||
putAffection ud
|
||||
{ translation = JoyTranslation $
|
||||
M.insert (AxisAction (fromIntegral axis) align) (ActLeft 1) $
|
||||
if isJust k then M.delete (fromJust k) (tmap) else tmap
|
||||
}
|
||||
Menu (Adjust (ActRight s) (Joystick _)) -> do
|
||||
let k = fst <$> find (\(_, v) -> v == ActRight 1) (M.assocs tmap)
|
||||
putAffection ud
|
||||
{ translation = JoyTranslation $
|
||||
M.insert (AxisAction (fromIntegral axis) align) (ActRight 1) $
|
||||
if isJust k then M.delete (fromJust k) (tmap) else tmap
|
||||
}
|
||||
fullClean
|
||||
switchBack
|
||||
_ -> return ()
|
||||
joyListener switchBack (MsgJoystickButton _ _ but SDL.JoyButtonPressed) = do
|
||||
ud <- getAffection
|
||||
case translation ud of
|
||||
JoyTranslation tmap -> do
|
||||
case state ud of
|
||||
Menu (Adjust (ActUp _) (Joystick _)) -> return ()
|
||||
Menu (Adjust (ActDown _) (Joystick _)) -> return ()
|
||||
Menu (Adjust (ActLeft _) (Joystick _)) -> return ()
|
||||
Menu (Adjust (ActRight _) (Joystick _)) -> return ()
|
||||
Menu (Adjust (act) (Joystick _)) -> do
|
||||
let k = fst <$> find (\(_, v) -> v == act) (M.assocs tmap)
|
||||
putAffection ud
|
||||
{ translation = JoyTranslation $
|
||||
M.insert (ButtonAction but SDL.JoyButtonPressed) act $
|
||||
if isJust k then M.delete (fromJust k) tmap else tmap
|
||||
}
|
||||
joyListener :: UserData -> Affection () -> JoystickMessage -> Affection ()
|
||||
joyListener ud switchBack message = do
|
||||
curState <- liftIO $ readMVar (state ud)
|
||||
trans <- liftIO $ readMVar (translation ud)
|
||||
case message of
|
||||
MsgJoystickAxis _ _ axis val -> do
|
||||
let align
|
||||
| val > 0 = AxisPositive
|
||||
| val < 0 = AxisNegative
|
||||
| otherwise = A.log A.Error "Can not assign neitral axis align" (error "*dies*")
|
||||
case trans of
|
||||
JoyTranslation tmap -> do
|
||||
let (Menu (Adjust cact (Joystick _))) = curState
|
||||
act = case cact of
|
||||
ActUp _ -> ActUp 1
|
||||
ActDown _ -> ActDown 1
|
||||
ActLeft _ -> ActLeft 1
|
||||
ActRight _ -> ActRight 1
|
||||
x -> A.log A.Error (fromString (show x) <> " is a non-movement action!") (error "*dies*")
|
||||
k = fst <$> find (\(_, v) -> v == act) (M.assocs tmap)
|
||||
void $ liftIO $ swapMVar (translation ud) (JoyTranslation $
|
||||
M.insert (AxisAction (fromIntegral axis) align) act $
|
||||
if isJust k then M.delete (fromJust k) tmap else tmap
|
||||
)
|
||||
fullClean ud
|
||||
switchBack
|
||||
_ -> return ()
|
||||
fullClean
|
||||
switchBack
|
||||
joyListener _ _ = return ()
|
||||
MsgJoystickButton _ _ but SDL.JoyButtonPressed -> do
|
||||
case trans of
|
||||
JoyTranslation tmap -> do
|
||||
case curState of
|
||||
Menu (Adjust (ActUp _) (Joystick _)) -> return ()
|
||||
Menu (Adjust (ActDown _) (Joystick _)) -> return ()
|
||||
Menu (Adjust (ActLeft _) (Joystick _)) -> return ()
|
||||
Menu (Adjust (ActRight _) (Joystick _)) -> return ()
|
||||
Menu (Adjust (act) (Joystick _)) -> do
|
||||
let k = fst <$> find (\(_, v) -> v == act) (M.assocs tmap)
|
||||
void $ liftIO $ swapMVar (translation ud) (JoyTranslation $
|
||||
M.insert (ButtonAction but SDL.JoyButtonPressed) act $
|
||||
if isJust k then M.delete (fromJust k) tmap else tmap
|
||||
)
|
||||
_ -> return ()
|
||||
fullClean ud
|
||||
switchBack
|
||||
x -> A.log A.Error (fromString (show x) <> " is a non-joystick translation!") (error "*dies*")
|
||||
_ -> return ()
|
||||
|
||||
drawAdjust :: Affection UserData ()
|
||||
drawAdjust = do
|
||||
ud <- getAffection
|
||||
drawAdjust :: Context -> Affection ()
|
||||
drawAdjust ctx = do
|
||||
liftIO $ do
|
||||
let ctx = nano ud
|
||||
save ctx
|
||||
beginPath ctx
|
||||
roundedRect ctx 440 310 400 100 10
|
||||
|
|
|
@ -10,9 +10,10 @@ import Linear hiding (rotate, translation)
|
|||
|
||||
import qualified Data.Set as S
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Maybe (isNothing, isJust)
|
||||
import Data.String
|
||||
|
||||
import Control.Concurrent.MVar
|
||||
|
||||
import Control.Monad
|
||||
|
||||
-- internal imports
|
||||
|
@ -22,108 +23,94 @@ import Util
|
|||
import Menu.Adjust
|
||||
import MainGame.WorldMap
|
||||
|
||||
loadMenu :: Affection UserData ()
|
||||
loadMenu = do
|
||||
ud <- getAffection
|
||||
ad <- get
|
||||
loadMenu :: UserData -> Affection ()
|
||||
loadMenu ud = do
|
||||
let (Subsystems _ m k j t) = subsystems ud
|
||||
uu1 <- partSubscribe j joystickConnect
|
||||
uu2 <- partSubscribe j joystickDisconnect
|
||||
uu3 <- partSubscribe j emitJoyActionMessage
|
||||
uu4 <- partSubscribe k emitKbdActionMessage
|
||||
uu5 <- partSubscribe t handleActionMessages
|
||||
uu6 <- partSubscribe m handleClicks
|
||||
uu1 <- partSubscribe j (joystickConnect ud)
|
||||
uu2 <- partSubscribe j (joystickDisconnect ud)
|
||||
uu3 <- partSubscribe j (emitJoyActionMessage ud)
|
||||
uu4 <- partSubscribe k (emitKbdActionMessage ud)
|
||||
uu5 <- partSubscribe t (handleActionMessages ud)
|
||||
uu6 <- partSubscribe m (handleClicks ud)
|
||||
-- uu6 <- partSubscribe k emitKbdActionMessage
|
||||
partUnSubscribe j (joyUUID ud)
|
||||
putAffection ud
|
||||
{ uuid = [ uu1, uu2, uu3, uu4, uu5, uu6 ]
|
||||
, state = Menu Connect
|
||||
, stateData = MenuData (V2 0 0) S 0 0
|
||||
, joyCache = []
|
||||
}
|
||||
mapM_ (partEmit j) (joyCache ud)
|
||||
juuid <- liftIO $ readMVar (joyUUID ud)
|
||||
partUnSubscribe j juuid
|
||||
cache <- liftIO $ readMVar (joyCache ud)
|
||||
void $ liftIO $ swapMVar (uuid ud) [ uu1, uu2, uu3, uu4, uu5, uu6 ]
|
||||
void $ liftIO $ swapMVar (state ud) (Menu Connect)
|
||||
void $ liftIO $ swapMVar (stateData ud) (MenuData (V2 0 0) S 0 0)
|
||||
void $ liftIO $ swapMVar (joyCache ud) []
|
||||
mapM_ (partEmit j) cache
|
||||
|
||||
joystickConnect :: JoystickMessage -> Affection UserData ()
|
||||
joystickConnect msg = do
|
||||
ud <- getAffection
|
||||
when (controls ud == NoController) $ do
|
||||
joystickConnect :: UserData -> JoystickMessage -> Affection ()
|
||||
joystickConnect ud msg = do
|
||||
ctrls <- liftIO $ readMVar (controls ud)
|
||||
when (ctrls == NoController) $ do
|
||||
mjoy <- joystickAutoConnect msg
|
||||
maybe (return ()) (\joy -> do
|
||||
ident <- liftIO $ fromIntegral <$> SDL.getJoystickID joy
|
||||
liftIO $ logIO A.Debug $ "Joystick connected: " <> fromString (show ident)
|
||||
putAffection ud
|
||||
{ controls = Joystick joy
|
||||
, translation = JoyTranslation defaultJoyTranslation
|
||||
}
|
||||
liftIO $ logIO A.Debug $ "Joystick connected: " <> fromString (show (ident :: Int))
|
||||
void $ liftIO $ swapMVar (controls ud) (Joystick joy)
|
||||
void $ liftIO $ swapMVar (translation ud) (JoyTranslation defaultJoyTranslation)
|
||||
) mjoy
|
||||
|
||||
joystickDisconnect :: JoystickMessage -> Affection UserData ()
|
||||
joystickDisconnect msg = do
|
||||
ud <- getAffection
|
||||
case controls ud of
|
||||
joystickDisconnect :: UserData -> JoystickMessage -> Affection ()
|
||||
joystickDisconnect ud msg = do
|
||||
ctrls <- liftIO $ readMVar (controls ud)
|
||||
case ctrls of
|
||||
Joystick joy -> do
|
||||
njoys <- joystickAutoDisconnect [joy] msg
|
||||
when (null njoys) $ do
|
||||
liftIO $ logIO A.Debug $ "Joystick disconnected"
|
||||
putAffection ud
|
||||
{ controls = NoController
|
||||
, translation = NoTranslation
|
||||
}
|
||||
void $ liftIO $ swapMVar (controls ud) NoController
|
||||
void $ liftIO $ swapMVar (translation ud) NoTranslation
|
||||
_ -> return ()
|
||||
|
||||
handleActionMessages :: ActionMessage -> Affection UserData ()
|
||||
handleActionMessages (ActionMessage ActActivate _) = do
|
||||
ud <- getAffection
|
||||
putAffection ud
|
||||
{ stateData = (stateData ud)
|
||||
{ activate = 0.5
|
||||
}
|
||||
handleActionMessages :: UserData -> ActionMessage -> Affection ()
|
||||
handleActionMessages ud (ActionMessage ActActivate _) = do
|
||||
liftIO $ modifyMVar_ (stateData ud) (\dat -> return dat
|
||||
{ activate = 0.5
|
||||
}
|
||||
handleActionMessages (ActionMessage ActSwitchMap _) = do
|
||||
ud <- getAffection
|
||||
putAffection ud
|
||||
{ stateData = (stateData ud)
|
||||
{ switchMap = 0.5
|
||||
}
|
||||
)
|
||||
handleActionMessages ud (ActionMessage ActSwitchMap _) = do
|
||||
liftIO $ modifyMVar_ (stateData ud) (\dat -> return dat
|
||||
{ switchMap = 0.5
|
||||
}
|
||||
handleActionMessages (ActionMessage (ActUp f) _) = do
|
||||
ud <- getAffection
|
||||
let V2 vx _ = velocity $ stateData ud
|
||||
putAffection ud
|
||||
{ stateData = (stateData ud)
|
||||
)
|
||||
handleActionMessages ud (ActionMessage (ActUp f) _) = do
|
||||
liftIO $ modifyMVar_ (stateData ud) (\dat ->
|
||||
let V2 vx _ = velocity dat
|
||||
in return dat
|
||||
{ velocity = (V2 vx (-f))
|
||||
}
|
||||
}
|
||||
handleActionMessages (ActionMessage (ActDown f) _) = do
|
||||
ud <- getAffection
|
||||
let V2 vx _ = velocity $ stateData ud
|
||||
putAffection ud
|
||||
{ stateData = (stateData ud)
|
||||
)
|
||||
handleActionMessages ud (ActionMessage (ActDown f) _) = do
|
||||
liftIO $ modifyMVar_ (stateData ud) (\dat ->
|
||||
let V2 vx _ = velocity dat
|
||||
in return dat
|
||||
{ velocity = (V2 vx f)
|
||||
}
|
||||
}
|
||||
handleActionMessages (ActionMessage (ActLeft f) _) = do
|
||||
ud <- getAffection
|
||||
let V2 _ vy = velocity $ stateData ud
|
||||
putAffection ud
|
||||
{ stateData = (stateData ud)
|
||||
)
|
||||
handleActionMessages ud (ActionMessage (ActLeft f) _) = do
|
||||
liftIO $ modifyMVar_ (stateData ud) (\dat ->
|
||||
let V2 _ vy = velocity dat
|
||||
in return dat
|
||||
{ velocity = (V2 (-f) vy)
|
||||
}
|
||||
}
|
||||
handleActionMessages (ActionMessage (ActRight f) _) = do
|
||||
ud <- getAffection
|
||||
let V2 _ vy = velocity $ stateData ud
|
||||
putAffection ud
|
||||
{ stateData = (stateData ud)
|
||||
)
|
||||
handleActionMessages ud (ActionMessage (ActRight f) _) = do
|
||||
liftIO $ modifyMVar_ (stateData ud) (\dat ->
|
||||
let V2 _ vy = velocity dat
|
||||
in return dat
|
||||
{ velocity = (V2 f vy)
|
||||
}
|
||||
}
|
||||
)
|
||||
|
||||
handleClicks :: MouseMessage -> Affection UserData ()
|
||||
handleClicks (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft 1 pos@(V2 px py)) = do
|
||||
ud <- getAffection
|
||||
rels@(V2 rx ry) <- liftIO $ fmap ((/ 2) . (+ 1)) <$> (relativizeMouseCoords pos)
|
||||
case controls ud of
|
||||
handleClicks :: UserData -> MouseMessage -> Affection ()
|
||||
handleClicks ud (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft 1 cpos) = do
|
||||
rels <- liftIO $ fmap ((/ 2) . (+ 1)) <$> (relativizeMouseCoords cpos)
|
||||
ctrls <- liftIO $ readMVar (controls ud)
|
||||
case ctrls of
|
||||
Joystick _ -> do
|
||||
when (arrowUp rels) adjustKbdUp
|
||||
when (arrowDown rels) adjustKbdDown
|
||||
|
@ -133,40 +120,36 @@ handleClicks (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft 1 pos@(V2 px py))
|
|||
when (buttonSwitchMap rels) adjustKbdSwitchMap
|
||||
when (buttonPlay rels) enterGame
|
||||
NoController -> do
|
||||
when (kbdIcon rels) $
|
||||
putAffection ud
|
||||
{ controls = Keyboard
|
||||
, translation = KbdTranslation defaultKbdTranslation
|
||||
}
|
||||
when (kbdIcon rels) $ do
|
||||
void $ liftIO $ swapMVar (controls ud) Keyboard
|
||||
void $ liftIO $ swapMVar (translation ud) (KbdTranslation defaultKbdTranslation)
|
||||
Keyboard -> do
|
||||
when (kbdIcon rels) $
|
||||
putAffection ud
|
||||
{ controls = NoController
|
||||
, translation = NoTranslation
|
||||
}
|
||||
when (kbdIcon rels) $ do
|
||||
void $ liftIO $ swapMVar (controls ud) NoController
|
||||
void $ liftIO $ swapMVar (translation ud) NoTranslation
|
||||
when (buttonPlay rels) enterGame
|
||||
where
|
||||
adjustKbdUp = do
|
||||
fullClean
|
||||
loadAdjust (ActUp 1) Keyboard loadMenu
|
||||
fullClean ud
|
||||
loadAdjust ud (ActUp 1) Keyboard (loadMenu ud)
|
||||
adjustKbdDown = do
|
||||
fullClean
|
||||
loadAdjust (ActDown 1) Keyboard loadMenu
|
||||
fullClean ud
|
||||
loadAdjust ud (ActDown 1) Keyboard (loadMenu ud)
|
||||
adjustKbdLeft = do
|
||||
fullClean
|
||||
loadAdjust (ActLeft 1) Keyboard loadMenu
|
||||
fullClean ud
|
||||
loadAdjust ud (ActLeft 1) Keyboard (loadMenu ud)
|
||||
adjustKbdRight = do
|
||||
fullClean
|
||||
loadAdjust (ActRight 1) Keyboard loadMenu
|
||||
fullClean ud
|
||||
loadAdjust ud (ActRight 1) Keyboard (loadMenu ud)
|
||||
adjustKbdActivate = do
|
||||
fullClean
|
||||
loadAdjust ActActivate Keyboard loadMenu
|
||||
fullClean ud
|
||||
loadAdjust ud ActActivate Keyboard (loadMenu ud)
|
||||
adjustKbdSwitchMap = do
|
||||
fullClean
|
||||
loadAdjust ActSwitchMap Keyboard loadMenu
|
||||
fullClean ud
|
||||
loadAdjust ud ActSwitchMap Keyboard (loadMenu ud)
|
||||
enterGame = do
|
||||
fullClean
|
||||
loadMap
|
||||
fullClean ud
|
||||
loadMap ud
|
||||
arrowUp (V2 rx ry) =
|
||||
rx > 310 / 1280 && rx < 410 / 1280 && ry > 190 / 720 && ry < 290 / 720
|
||||
arrowDown (V2 rx ry) =
|
||||
|
@ -183,33 +166,35 @@ handleClicks (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft 1 pos@(V2 px py))
|
|||
rx > 650 / 1280 && rx < 800 / 1280 && ry > 560 / 720 && ry < 610 / 720
|
||||
kbdIcon (V2 rx ry) =
|
||||
rx > 650 / 1280 && rx < 730 / 1280 && ry > 620 / 720 && ry < 700 / 720
|
||||
handleClicks _ = return ()
|
||||
handleClicks _ _ = return ()
|
||||
|
||||
updateMenu :: Double -> Affection UserData ()
|
||||
updateMenu dt = do
|
||||
ud <- getAffection
|
||||
case stateData ud of
|
||||
updateMenu :: UserData -> Double -> Affection ()
|
||||
updateMenu ud dt = do
|
||||
sData <- liftIO $ readMVar (stateData ud)
|
||||
case sData of
|
||||
MenuData _ _ _ _ ->
|
||||
putAffection ud
|
||||
{ stateData = MenuData
|
||||
(velocity $ stateData ud)
|
||||
(rotation $ stateData ud)
|
||||
(max 0 ((activate $ stateData ud) - dt))
|
||||
(max 0 ((switchMap $ stateData ud) - dt))
|
||||
}
|
||||
void $ liftIO $ swapMVar (stateData ud) (
|
||||
MenuData
|
||||
(velocity sData)
|
||||
(rotation sData)
|
||||
(max 0 ((activate sData) - dt))
|
||||
(max 0 ((switchMap sData) - dt))
|
||||
)
|
||||
_ -> return ()
|
||||
|
||||
drawMenu :: Affection UserData ()
|
||||
drawMenu = do
|
||||
ud <- getAffection
|
||||
case stateData ud of
|
||||
drawMenu :: UserData -> Affection ()
|
||||
drawMenu ud = do
|
||||
sData <- liftIO $ readMVar (stateData ud)
|
||||
curState <- liftIO $ readMVar (state ud)
|
||||
aIcons <- liftIO $ readMVar (assetIcons ud)
|
||||
case sData of
|
||||
MenuData _ _ _ _ ->
|
||||
liftIO $ do
|
||||
let ctx = nano ud
|
||||
controller = controls ud
|
||||
controller <- readMVar (controls ud)
|
||||
save ctx
|
||||
beginPath ctx
|
||||
cpaint <- imagePattern ctx 550 620 80 80 0 (assetIcons ud M.!
|
||||
cpaint <- imagePattern ctx 550 620 80 80 0 (aIcons M.!
|
||||
case controller of
|
||||
Joystick _ -> IconContrGreen
|
||||
_ -> IconContrBlue
|
||||
|
@ -219,17 +204,17 @@ drawMenu = do
|
|||
closePath ctx
|
||||
fill ctx
|
||||
beginPath ctx
|
||||
cpaint <- imagePattern ctx 650 620 80 80 0 (assetIcons ud M.!
|
||||
cpaint2 <- imagePattern ctx 650 620 80 80 0 (aIcons M.!
|
||||
case controller of
|
||||
Keyboard -> IconKbdGreen
|
||||
_ -> IconKbdBlue
|
||||
) 1
|
||||
rect ctx 650 620 80 80
|
||||
fillPaint ctx cpaint
|
||||
fillPaint ctx cpaint2
|
||||
closePath ctx
|
||||
fill ctx
|
||||
when (controller /= NoController) $ do
|
||||
let V2 vx vy = velocity $ stateData ud
|
||||
let V2 vx vy = velocity sData
|
||||
beginPath ctx
|
||||
roundedRect ctx 140 110 1000 500 25
|
||||
strokeWidth ctx 5
|
||||
|
@ -240,7 +225,7 @@ drawMenu = do
|
|||
mapM_ (\deg -> do
|
||||
let V2 px py = fmap realToFrac $
|
||||
V2 360 360 - V2 50 50 + fmap realToFrac rot
|
||||
rot@(V2 rx ry) = fmap (fromIntegral . floor) $
|
||||
rot = fmap (fromIntegral . floor) $
|
||||
V2 0 120 `rotVec` deg :: V2 Int
|
||||
save ctx
|
||||
translate ctx (px + 50) (py + 50)
|
||||
|
@ -254,7 +239,7 @@ drawMenu = do
|
|||
roundedRect ctx 0 0 100 100 10
|
||||
closePath ctx
|
||||
fill ctx
|
||||
case state ud of
|
||||
case curState of
|
||||
Menu (Adjust (ActUp _) _) -> do
|
||||
beginPath ctx
|
||||
fillColor ctx (rgb 0 255 0)
|
||||
|
@ -276,7 +261,7 @@ drawMenu = do
|
|||
roundedRect ctx 0 0 100 100 10
|
||||
closePath ctx
|
||||
fill ctx
|
||||
case state ud of
|
||||
case curState of
|
||||
Menu (Adjust (ActLeft _) _) -> do
|
||||
beginPath ctx
|
||||
fillColor ctx (rgb 0 255 0)
|
||||
|
@ -298,7 +283,7 @@ drawMenu = do
|
|||
roundedRect ctx 0 0 100 100 10
|
||||
closePath ctx
|
||||
fill ctx
|
||||
case state ud of
|
||||
case curState of
|
||||
Menu (Adjust (ActUp _) _) -> do
|
||||
beginPath ctx
|
||||
fillColor ctx (rgb 0 255 0)
|
||||
|
@ -320,7 +305,7 @@ drawMenu = do
|
|||
roundedRect ctx 0 0 100 100 10
|
||||
closePath ctx
|
||||
fill ctx
|
||||
case state ud of
|
||||
case curState of
|
||||
Menu (Adjust (ActLeft _) _) -> do
|
||||
beginPath ctx
|
||||
fillColor ctx (rgb 0 255 0)
|
||||
|
@ -336,20 +321,20 @@ drawMenu = do
|
|||
_ ->
|
||||
return ()
|
||||
beginPath ctx
|
||||
apaint <- imagePattern ctx 0 0 100 100 0 (assetIcons ud M.! IconArrow) 1
|
||||
apaint <- imagePattern ctx 0 0 100 100 0 (aIcons M.! IconArrow) 1
|
||||
rect ctx 0 0 100 100
|
||||
fillPaint ctx apaint
|
||||
closePath ctx
|
||||
fill ctx
|
||||
restore ctx
|
||||
) [0, 90, 180, 270]
|
||||
when (activate (stateData ud) > 0) $ do
|
||||
when (activate sData > 0) $ do
|
||||
beginPath ctx
|
||||
fillColor ctx (rgb 255 128 0)
|
||||
roundedRect ctx 650 160 150 50 10
|
||||
fill ctx
|
||||
closePath ctx
|
||||
case state ud of
|
||||
case curState of
|
||||
Menu (Adjust ActActivate _) -> do
|
||||
beginPath ctx
|
||||
fillColor ctx (rgb 0 255 0)
|
||||
|
@ -368,13 +353,13 @@ drawMenu = do
|
|||
fillColor ctx (rgb 255 255 255)
|
||||
textBox ctx 650 175 150 "Activate"
|
||||
closePath ctx
|
||||
when (switchMap (stateData ud) > 0) $ do
|
||||
when (switchMap sData > 0) $ do
|
||||
beginPath ctx
|
||||
fillColor ctx (rgb 255 128 0)
|
||||
roundedRect ctx 650 220 150 50 10
|
||||
fill ctx
|
||||
closePath ctx
|
||||
case state ud of
|
||||
case curState of
|
||||
Menu (Adjust ActSwitchMap _) -> do
|
||||
beginPath ctx
|
||||
fillColor ctx (rgb 0 255 0)
|
||||
|
|
|
@ -15,6 +15,7 @@ import Data.String
|
|||
|
||||
import Control.Monad.IO.Class (MonadIO(..))
|
||||
import Control.Monad.Trans (lift)
|
||||
import Control.Monad.Trans.Resource (ResIO)
|
||||
import Control.Concurrent.MVar
|
||||
import Control.Concurrent (forkIO)
|
||||
|
||||
|
@ -33,7 +34,7 @@ import Object ()
|
|||
getPosBounds
|
||||
:: SystemT
|
||||
Entity
|
||||
(AffectionState (AffectionData UserData) IO)
|
||||
(AffectionState AffectionData ResIO)
|
||||
[(V2 Double, Boundaries Double)]
|
||||
getPosBounds = do
|
||||
efor allEnts $ do
|
||||
|
@ -47,10 +48,10 @@ getPosBounds = do
|
|||
updateNPCs
|
||||
:: M.Matrix (Maybe ImgId)
|
||||
-> M.Matrix TileState
|
||||
-> SystemState Entity (AffectionState (AffectionData UserData) IO)
|
||||
-> SystemState Entity (AffectionState AffectionData ResIO)
|
||||
-> V.Vector ReachPoint
|
||||
-> Double
|
||||
-> SystemT Entity (AffectionState (AffectionData UserData) IO) ()
|
||||
-> SystemT Entity (AffectionState AffectionData ResIO) ()
|
||||
updateNPCs imgmat tsmat ws rrp dt = do
|
||||
updateStats dt
|
||||
posbounds <- getPosBounds
|
||||
|
@ -263,7 +264,7 @@ standStill imgmat tsmat pos' rot' ws posbounds rp = do
|
|||
|
||||
updateStats
|
||||
:: Double
|
||||
-> SystemT Entity (AffectionState (AffectionData UserData) IO) ()
|
||||
-> SystemT Entity (AffectionState AffectionData ResIO) ()
|
||||
updateStats dt =
|
||||
emap allEnts $ do
|
||||
with npcStats
|
||||
|
|
|
@ -3,7 +3,7 @@ module Navigation where
|
|||
import Affection as A
|
||||
|
||||
import Data.Matrix as M
|
||||
import Data.Maybe (isJust, catMaybes)
|
||||
import Data.Maybe (isJust)
|
||||
|
||||
-- internal imports
|
||||
|
||||
|
|
|
@ -3,14 +3,7 @@
|
|||
{-# LANGUAGE FlexibleInstances #-}
|
||||
module Object where
|
||||
|
||||
import Affection as A
|
||||
|
||||
import Control.Monad (when)
|
||||
|
||||
import Data.Ecstasy
|
||||
import Data.Maybe
|
||||
|
||||
import Linear
|
||||
|
||||
-- internal imports
|
||||
|
||||
|
|
|
@ -16,7 +16,6 @@ instance ActionTime ObjType ObjState where
|
|||
actionTime ObjComputer "off" = 0
|
||||
actionTime ObjComputer "on" = 20
|
||||
actionTime ObjComputer "hack" = 20
|
||||
actionTime ObjComputer "hack" = 20
|
||||
actionTime ObjDoor "open" = 2
|
||||
|
||||
actionTime o s = A.log
|
||||
|
|
|
@ -6,7 +6,6 @@ module Object.Computer where
|
|||
|
||||
import Affection as A
|
||||
|
||||
import Control.Monad (when)
|
||||
import Control.Monad.IO.Class (MonadIO(..))
|
||||
|
||||
import Data.Ecstasy
|
||||
|
@ -19,7 +18,7 @@ import Linear
|
|||
|
||||
import Types
|
||||
|
||||
import Object.ActionTime
|
||||
import Object.ActionTime ()
|
||||
|
||||
computerObjectAction
|
||||
:: (Monad m, MonadIO m)
|
||||
|
|
|
@ -10,11 +10,8 @@ import Control.Monad (when)
|
|||
import Control.Monad.IO.Class
|
||||
|
||||
import Data.Ecstasy
|
||||
import Data.Maybe
|
||||
import Data.String (IsString(..))
|
||||
|
||||
import Linear
|
||||
|
||||
import Types
|
||||
|
||||
copierObjectAction
|
||||
|
|
|
@ -7,19 +7,24 @@ module Object.Door where
|
|||
import Affection as A
|
||||
|
||||
import Control.Monad (when)
|
||||
import Control.Monad.IO.Class (MonadIO)
|
||||
|
||||
import Data.Ecstasy
|
||||
import Data.Maybe
|
||||
import Data.String
|
||||
|
||||
import Linear
|
||||
|
||||
-- internal imports
|
||||
|
||||
import Types
|
||||
|
||||
import Object.ActionTime
|
||||
import Object.ActionTime ()
|
||||
|
||||
doorObjectAction :: (Eq a, IsString a, MonadIO m)
|
||||
=> Double
|
||||
-> ObjType
|
||||
-> a
|
||||
-> Ent
|
||||
-> SystemT Entity m ()
|
||||
doorObjectAction dt t@ObjDoor s@"open" ent = do
|
||||
emap (anEnt ent) $ do
|
||||
mtime <- queryMaybe objStateTime
|
||||
|
@ -39,8 +44,15 @@ doorObjectAction dt t@ObjDoor s@"open" ent = do
|
|||
|
||||
doorObjectAction _ _ _ _ = return ()
|
||||
|
||||
doorObjectTransition t@ObjDoor s _ ent (Just aent) = do
|
||||
clearance <- head <$> efor (anEnt aent) (query clearanceLvl)
|
||||
doorObjectTransition :: (MonadIO m, Eq a, IsString a)
|
||||
=> ObjType
|
||||
-> a
|
||||
-> p
|
||||
-> Ent
|
||||
-> Maybe Ent
|
||||
-> SystemT Entity m (Entity 'SetterOf)
|
||||
doorObjectTransition t@ObjDoor _ _ ent (Just aent) = do
|
||||
curClearance <- head <$> efor (anEnt aent) (query clearanceLvl)
|
||||
e <- efor (anEnt ent) $ do
|
||||
dir <- query rot
|
||||
oclear <- query clearanceLvl
|
||||
|
@ -52,7 +64,7 @@ doorObjectTransition t@ObjDoor s _ ent (Just aent) = do
|
|||
fromString (show ent)
|
||||
)
|
||||
-- liftIO $ A.logIO A.Debug ("door clearance: " ++ show oclear ++ ", entity clearance: " ++ show clearance)
|
||||
if clearance >= oclear
|
||||
if curClearance >= oclear
|
||||
then do
|
||||
liftIO $ A.logIO
|
||||
A.Verbose
|
||||
|
|
|
@ -13,26 +13,26 @@ import MainGame.WorldMap
|
|||
import MainGame.MindMap
|
||||
import Util
|
||||
|
||||
instance StateMachine State UserData where
|
||||
instance StateMachine UserData State where
|
||||
smLoad Load = loadLoad
|
||||
smLoad (Menu Connect) = loadMenu
|
||||
smLoad (Menu (Adjust a c)) = loadAdjust a c loadMenu
|
||||
smLoad (Menu (Adjust a c)) = (\ud -> loadAdjust ud a c (loadMenu ud))
|
||||
smLoad (Main _) = loadMap
|
||||
|
||||
smUpdate Load = updateLoad
|
||||
smUpdate (Menu Connect) = updateMenu
|
||||
smUpdate (Menu (Adjust _ _)) = const (return ())
|
||||
smUpdate (Menu (Adjust _ _)) = const $ const (return ())
|
||||
smUpdate (Main WorldMap) = updateMap
|
||||
smUpdate (Main MindMap) = updateMind
|
||||
|
||||
smDraw Load = drawLoad
|
||||
smDraw (Menu Connect) = drawMenu
|
||||
smDraw (Menu (Adjust _ _)) = drawMenu >> drawAdjust
|
||||
smDraw (Menu (Adjust _ _)) = (\ud -> drawMenu ud >> drawAdjust (nano ud))
|
||||
smDraw (Main WorldMap) = drawMap
|
||||
smDraw (Main MindMap) = drawMind
|
||||
|
||||
smEvent _ evs = do
|
||||
Subsystems w m k j _ <- subsystems <$> getAffection
|
||||
smEvent _ ud evs = do
|
||||
let Subsystems w m k j _ = subsystems ud
|
||||
_ <- consumeSDLEvents j =<<
|
||||
consumeSDLEvents k =<<
|
||||
consumeSDLEvents w =<<
|
||||
|
|
|
@ -46,6 +46,7 @@ data AnimationName
|
|||
| AnimComputer
|
||||
| AnimToilet
|
||||
| AnimJDoeM
|
||||
| AnimPoliceM
|
||||
| AnimDoor0
|
||||
deriving (Show, Eq, Ord, Enum)
|
||||
|
||||
|
|
|
@ -4,6 +4,8 @@ module Types.Drawable where
|
|||
|
||||
import qualified Data.Map.Strict as Map
|
||||
|
||||
import Control.Concurrent.MVar
|
||||
|
||||
import NanoVG
|
||||
|
||||
import Foreign.C.Types (CFloat(..))
|
||||
|
@ -30,7 +32,7 @@ instance NanoDrawable UserData Image where
|
|||
|
||||
instance NanoDrawable UserData AnimState where
|
||||
draw us x y w h alpha as = do
|
||||
let anims = assetAnimations us
|
||||
a = anims Map.! asId as
|
||||
anims <- readMVar (assetAnimations us)
|
||||
let a = anims Map.! asId as
|
||||
img = (animSprites a !! asCurrentFrame as) :: Image
|
||||
draw us x y w h alpha img
|
||||
|
|
|
@ -5,11 +5,10 @@ module Types.ObjClass where
|
|||
|
||||
import Affection
|
||||
|
||||
import Control.Monad.Trans.Resource (ResIO)
|
||||
import Data.Ecstasy
|
||||
|
||||
import Types.Entity
|
||||
import Types.UserData
|
||||
import Types.Direction
|
||||
|
||||
class ObjectAction otype ostate where
|
||||
objectAction
|
||||
|
@ -17,7 +16,7 @@ class ObjectAction otype ostate where
|
|||
-> otype
|
||||
-> ostate
|
||||
-> Ent
|
||||
-> SystemT Entity (AffectionState (AffectionData UserData) IO) ()
|
||||
-> SystemT Entity (AffectionState AffectionData ResIO) ()
|
||||
|
||||
objectTransition
|
||||
:: otype
|
||||
|
@ -25,7 +24,7 @@ class ObjectAction otype ostate where
|
|||
-> Bool
|
||||
-> Ent
|
||||
-> Maybe Ent
|
||||
-> SystemT Entity (AffectionState (AffectionData UserData) IO) (Entity 'SetterOf)
|
||||
-> SystemT Entity (AffectionState AffectionData ResIO) (Entity 'SetterOf)
|
||||
|
||||
class ActionTime otype ostate where
|
||||
actionTime :: otype -> ostate -> Double
|
||||
|
|
|
@ -16,6 +16,7 @@ import qualified Data.Text as T
|
|||
import Data.Ecstasy
|
||||
|
||||
import Control.Concurrent.MVar
|
||||
import Control.Monad.Trans.Resource
|
||||
|
||||
import Types.StateData
|
||||
import Types.ImgId
|
||||
|
@ -24,27 +25,28 @@ import Types.Animation
|
|||
import Types.Entity
|
||||
|
||||
data UserData = UserData
|
||||
{ state :: State
|
||||
{ state :: MVar State
|
||||
, subsystems :: Subsystems
|
||||
, assetIcons :: M.Map IconId Image
|
||||
, assetImages :: M.Map ImgId Image
|
||||
, assetFonts :: M.Map FontId T.Text
|
||||
, assetAnimations :: M.Map AnimId Animation
|
||||
, controls :: Controller -- Maybe SDL.Joystick
|
||||
, translation :: Translation
|
||||
, assetIcons :: MVar (M.Map IconId Image)
|
||||
, assetImages :: MVar (M.Map ImgId Image)
|
||||
, assetFonts :: MVar (M.Map FontId T.Text)
|
||||
, assetAnimations :: MVar (M.Map AnimId Animation)
|
||||
, controls :: MVar Controller
|
||||
, translation :: MVar Translation
|
||||
, nano :: Context
|
||||
, uuid :: [UUID]
|
||||
, worldState :: SystemState Entity (AffectionState (AffectionData UserData) IO)
|
||||
, stateData :: StateData
|
||||
, uuid :: MVar [UUID]
|
||||
, worldState :: MVar (SystemState Entity (AffectionState AffectionData ResIO))
|
||||
, stateData :: MVar StateData
|
||||
, stateMVar :: MVar
|
||||
( SystemState Entity (AffectionState (AffectionData UserData) IO)
|
||||
( SystemState Entity (AffectionState AffectionData ResIO)
|
||||
, StateData
|
||||
)
|
||||
, stateProgress :: MVar (Float, T.Text)
|
||||
, threadContext :: Maybe SDL.GLContext
|
||||
, window :: Maybe SDL.Window
|
||||
, joyCache :: [JoystickMessage]
|
||||
, joyUUID :: UUID
|
||||
, threadContext :: MVar (Maybe SDL.GLContext)
|
||||
, window :: MVar (Maybe SDL.Window)
|
||||
, joyCache :: MVar [JoystickMessage]
|
||||
, joyUUID :: MVar UUID
|
||||
, doNextStep :: MVar Bool
|
||||
}
|
||||
|
||||
data Controller
|
||||
|
@ -133,14 +135,14 @@ data ActionMessage = ActionMessage
|
|||
instance Message ActionMessage where
|
||||
msgTime (ActionMessage _ t) = t
|
||||
|
||||
newtype SubWindow = SubWindow (TVar [(UUID, WindowMessage -> Affection UserData())])
|
||||
newtype SubMouse = SubMouse (TVar [(UUID, MouseMessage -> Affection UserData ())])
|
||||
newtype SubKeyboard = SubKeyboard (TVar [(UUID, KeyboardMessage -> Affection UserData ())])
|
||||
newtype SubJoypad = SubJoypad (TVar [(UUID, JoystickMessage -> Affection UserData ())])
|
||||
newtype SubTranslator = SubTranslator (TVar [(UUID, ActionMessage -> Affection UserData ())])
|
||||
newtype SubWindow = SubWindow (TVar [(UUID, WindowMessage -> Affection())])
|
||||
newtype SubMouse = SubMouse (TVar [(UUID, MouseMessage -> Affection ())])
|
||||
newtype SubKeyboard = SubKeyboard (TVar [(UUID, KeyboardMessage -> Affection ())])
|
||||
newtype SubJoypad = SubJoypad (TVar [(UUID, JoystickMessage -> Affection ())])
|
||||
newtype SubTranslator = SubTranslator (TVar [(UUID, ActionMessage -> Affection ())])
|
||||
|
||||
instance Participant SubWindow UserData where
|
||||
type Mesg SubWindow UserData = WindowMessage
|
||||
instance Participant SubWindow where
|
||||
type Mesg SubWindow = WindowMessage
|
||||
|
||||
partSubscribers (SubWindow t) = generalSubscribers t
|
||||
|
||||
|
@ -148,11 +150,11 @@ instance Participant SubWindow UserData where
|
|||
|
||||
partUnSubscribe (SubWindow t) = generalUnSubscribe t
|
||||
|
||||
instance SDLSubsystem SubWindow UserData where
|
||||
instance SDLSubsystem SubWindow where
|
||||
consumeSDLEvents = consumeSDLWindowEvents
|
||||
|
||||
instance Participant SubMouse UserData where
|
||||
type Mesg SubMouse UserData = MouseMessage
|
||||
instance Participant SubMouse where
|
||||
type Mesg SubMouse = MouseMessage
|
||||
|
||||
partSubscribers (SubMouse t) = generalSubscribers t
|
||||
|
||||
|
@ -160,11 +162,11 @@ instance Participant SubMouse UserData where
|
|||
|
||||
partUnSubscribe (SubMouse t) = generalUnSubscribe t
|
||||
|
||||
instance SDLSubsystem SubMouse UserData where
|
||||
instance SDLSubsystem SubMouse where
|
||||
consumeSDLEvents = consumeSDLMouseEvents
|
||||
|
||||
instance Participant SubKeyboard UserData where
|
||||
type Mesg SubKeyboard UserData = KeyboardMessage
|
||||
instance Participant SubKeyboard where
|
||||
type Mesg SubKeyboard = KeyboardMessage
|
||||
|
||||
partSubscribers (SubKeyboard t) = generalSubscribers t
|
||||
|
||||
|
@ -172,11 +174,11 @@ instance Participant SubKeyboard UserData where
|
|||
|
||||
partUnSubscribe (SubKeyboard t) = generalUnSubscribe t
|
||||
|
||||
instance SDLSubsystem SubKeyboard UserData where
|
||||
instance SDLSubsystem SubKeyboard where
|
||||
consumeSDLEvents = consumeSDLKeyboardEvents
|
||||
|
||||
instance Participant SubJoypad UserData where
|
||||
type Mesg SubJoypad UserData = JoystickMessage
|
||||
instance Participant SubJoypad where
|
||||
type Mesg SubJoypad = JoystickMessage
|
||||
|
||||
partSubscribers (SubJoypad t) = generalSubscribers t
|
||||
|
||||
|
@ -184,11 +186,11 @@ instance Participant SubJoypad UserData where
|
|||
|
||||
partUnSubscribe (SubJoypad t) = generalUnSubscribe t
|
||||
|
||||
instance SDLSubsystem SubJoypad UserData where
|
||||
instance SDLSubsystem SubJoypad where
|
||||
consumeSDLEvents = consumeSDLJoystickEvents
|
||||
|
||||
instance Participant SubTranslator UserData where
|
||||
type Mesg SubTranslator UserData = ActionMessage
|
||||
instance Participant SubTranslator where
|
||||
type Mesg SubTranslator = ActionMessage
|
||||
|
||||
partSubscribers (SubTranslator t) = generalSubscribers t
|
||||
|
||||
|
@ -197,25 +199,25 @@ instance Participant SubTranslator UserData where
|
|||
partUnSubscribe (SubTranslator t) = generalUnSubscribe t
|
||||
|
||||
generalSubscribers
|
||||
:: TVar [(UUID, msg -> Affection UserData ())]
|
||||
-> Affection UserData [(msg -> Affection UserData ())]
|
||||
:: TVar [(UUID, msg -> Affection ())]
|
||||
-> Affection [(msg -> Affection ())]
|
||||
generalSubscribers t = do
|
||||
subTups <- liftIO $ readTVarIO t
|
||||
return $ map snd subTups
|
||||
|
||||
generalSubscribe
|
||||
:: TVar [(UUID, msg -> Affection UserData ())]
|
||||
-> (msg -> Affection UserData ())
|
||||
-> Affection UserData UUID
|
||||
:: TVar [(UUID, msg -> Affection ())]
|
||||
-> (msg -> Affection ())
|
||||
-> Affection UUID
|
||||
generalSubscribe t funct = do
|
||||
uu <- genUUID
|
||||
liftIO $ atomically $ modifyTVar' t ((uu, funct) :)
|
||||
return uu
|
||||
|
||||
generalUnSubscribe
|
||||
:: TVar [(UUID, msg -> Affection UserData ())]
|
||||
:: TVar [(UUID, msg -> Affection ())]
|
||||
-> UUID
|
||||
-> Affection UserData ()
|
||||
-> Affection ()
|
||||
generalUnSubscribe t uu =
|
||||
liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uu))
|
||||
where
|
||||
|
|
93
src/Util.hs
93
src/Util.hs
|
@ -12,7 +12,9 @@ import Data.Maybe
|
|||
import qualified Data.Text as T
|
||||
import Data.String
|
||||
|
||||
import Control.Monad (join, when)
|
||||
import Control.Monad
|
||||
|
||||
import Control.Concurrent.MVar
|
||||
|
||||
import qualified SDL
|
||||
import qualified Graphics.Rendering.OpenGL as GL hiding (get)
|
||||
|
@ -221,7 +223,8 @@ drawLoadScreen ud (progress, msg) = do
|
|||
save ctx
|
||||
fillColor ctx (rgb 255 128 0)
|
||||
fontSize ctx 100
|
||||
fontFace ctx (assetFonts ud Map.! FontBedstead)
|
||||
fonts <- readMVar (assetFonts ud)
|
||||
fontFace ctx (fonts Map.! FontBedstead)
|
||||
textAlign ctx (S.fromList [AlignCenter, AlignTop])
|
||||
textBox ctx 0 300 1280 "Loading"
|
||||
beginPath ctx
|
||||
|
@ -254,7 +257,7 @@ loadAnimationSprites fp nvg idconfs = do
|
|||
mresimgs <- mapM
|
||||
(\cr ->
|
||||
createImageMem nvg
|
||||
ImagePremultiplied (toStrict $ encodePng cr))
|
||||
(S.singleton ImagePremultiplied) (toStrict $ encodePng cr))
|
||||
crs
|
||||
imgs <- if any isNothing mresimgs
|
||||
then do
|
||||
|
@ -304,48 +307,47 @@ rotVec (V2 x y) deg = V2 nx ny
|
|||
dtor :: (Num a, Floating a) => a -> a
|
||||
dtor = (pi / 180 *)
|
||||
|
||||
cacheJoypad :: JoystickMessage -> Affection UserData ()
|
||||
cacheJoypad msg = do
|
||||
ud <- getAffection
|
||||
putAffection ud
|
||||
{ joyCache = msg : joyCache ud
|
||||
}
|
||||
cacheJoypad :: UserData -> JoystickMessage -> Affection ()
|
||||
cacheJoypad ud msg = do
|
||||
joy <- liftIO $ readMVar (joyCache ud)
|
||||
void $ liftIO $ swapMVar (joyCache ud) (msg : joy)
|
||||
|
||||
emitJoyActionMessage :: JoystickMessage -> Affection UserData ()
|
||||
emitJoyActionMessage (MsgJoystickAxis time _ axis val) = do
|
||||
ud <- getAffection
|
||||
case translation ud of
|
||||
JoyTranslation tmap -> do
|
||||
emitJoyActionMessage :: UserData -> JoystickMessage -> Affection ()
|
||||
emitJoyActionMessage ud message = do
|
||||
trans <- liftIO $ readMVar (translation ud)
|
||||
case message of
|
||||
MsgJoystickAxis time _ axis val -> do
|
||||
case trans of
|
||||
JoyTranslation tmap -> do
|
||||
let Subsystems _ _ _ _ t = subsystems ud
|
||||
vnormal = fromIntegral val / 32768
|
||||
sigvnormal = abs vnormal
|
||||
align
|
||||
| signum vnormal >= 0 = AxisPositive
|
||||
| signum vnormal < 0 = AxisNegative
|
||||
case tmap Map.!? (AxisAction axis align) of
|
||||
Just (ActUp _) -> partEmit t (ActionMessage (ActUp sigvnormal) time)
|
||||
Just (ActDown _) -> partEmit t (ActionMessage (ActDown sigvnormal) time)
|
||||
Just (ActLeft _) -> partEmit t (ActionMessage (ActLeft sigvnormal) time)
|
||||
Just (ActRight _) -> partEmit t (ActionMessage (ActRight sigvnormal) time)
|
||||
_ -> return ()
|
||||
_ -> return ()
|
||||
MsgJoystickButton time _ but SDL.JoyButtonPressed -> do
|
||||
let Subsystems _ _ _ _ t = subsystems ud
|
||||
vnormal = fromIntegral val / 32768
|
||||
sigvnormal = abs vnormal
|
||||
align
|
||||
| signum vnormal >= 0 = AxisPositive
|
||||
| signum vnormal < 0 = AxisNegative
|
||||
case tmap Map.!? (AxisAction axis align) of
|
||||
Just (ActUp _) -> partEmit t (ActionMessage (ActUp sigvnormal) time)
|
||||
Just (ActDown _) -> partEmit t (ActionMessage (ActDown sigvnormal) time)
|
||||
Just (ActLeft _) -> partEmit t (ActionMessage (ActLeft sigvnormal) time)
|
||||
Just (ActRight _) -> partEmit t (ActionMessage (ActRight sigvnormal) time)
|
||||
_ -> return ()
|
||||
case trans of
|
||||
JoyTranslation tmap -> do
|
||||
case tmap Map.!? (ButtonAction but SDL.JoyButtonPressed) of
|
||||
Just act -> partEmit t (ActionMessage act time)
|
||||
_ -> return ()
|
||||
_ -> return ()
|
||||
_ -> return ()
|
||||
emitJoyActionMessage (MsgJoystickButton time _ but SDL.JoyButtonPressed) = do
|
||||
ud <- getAffection
|
||||
let Subsystems _ _ _ _ t = subsystems ud
|
||||
case (translation ud) of
|
||||
JoyTranslation tmap -> do
|
||||
case tmap Map.!? (ButtonAction but SDL.JoyButtonPressed) of
|
||||
Just act -> partEmit t (ActionMessage act time)
|
||||
_ -> return ()
|
||||
_ -> return ()
|
||||
emitJoyActionMessage _ = return ()
|
||||
|
||||
emitKbdActionMessage :: KeyboardMessage -> Affection UserData ()
|
||||
emitKbdActionMessage (MsgKeyboardEvent time _ press False sym) = do
|
||||
ud <- getAffection
|
||||
emitKbdActionMessage :: UserData -> KeyboardMessage -> Affection ()
|
||||
emitKbdActionMessage ud (MsgKeyboardEvent time _ press False sym) = do
|
||||
let Subsystems _ _ _ _ t = subsystems ud
|
||||
val = if press == SDL.Pressed then 1 else 0
|
||||
case (translation ud) of
|
||||
trans <- liftIO $ readMVar (translation ud)
|
||||
case trans of
|
||||
KbdTranslation tmap -> do
|
||||
case tmap Map.!? SDL.keysymKeycode sym of
|
||||
Just (ActUp _) -> partEmit t (ActionMessage (ActUp val) time)
|
||||
|
@ -355,13 +357,12 @@ emitKbdActionMessage (MsgKeyboardEvent time _ press False sym) = do
|
|||
Just act -> when (press == SDL.Pressed) (partEmit t (ActionMessage act time))
|
||||
_ -> return ()
|
||||
_ -> return ()
|
||||
emitKbdActionMessage _ = return ()
|
||||
emitKbdActionMessage _ _ = return ()
|
||||
|
||||
fullClean :: Affection UserData ()
|
||||
fullClean = do
|
||||
ud <- getAffection
|
||||
fullClean :: UserData -> Affection ()
|
||||
fullClean ud = do
|
||||
let Subsystems w m k j t = subsystems ud
|
||||
toClean = uuid ud
|
||||
toClean <- liftIO $ readMVar $ uuid ud
|
||||
mapM_ (\u -> do
|
||||
partUnSubscribe w u
|
||||
partUnSubscribe m u
|
||||
|
@ -369,6 +370,4 @@ fullClean = do
|
|||
partUnSubscribe j u
|
||||
partUnSubscribe t u
|
||||
) toClean
|
||||
putAffection ud
|
||||
{ uuid = []
|
||||
}
|
||||
void $ liftIO $ swapMVar (uuid ud) []
|
||||
|
|
|
@ -59,7 +59,7 @@ executable tracer-game
|
|||
, DataKinds
|
||||
-- other-extensions:
|
||||
build-depends: base >=4.10 && <5
|
||||
, affection == 0.0.0.9
|
||||
, affection == 0.0.0.10
|
||||
, sdl2 >= 2.4.0.0
|
||||
, OpenGL
|
||||
, nanovg >= 0.6.0.0
|
||||
|
@ -80,6 +80,7 @@ executable tracer-game
|
|||
, mtl
|
||||
, parallel
|
||||
, split
|
||||
, resourcet
|
||||
hs-source-dirs: src
|
||||
ghc-options: -Wall -threaded
|
||||
default-language: Haskell2010
|
||||
|
|
Loading…
Reference in a new issue