Compare commits
No commits in common. "master" and "affectionate_class" have entirely different histories.
master
...
affectiona
14 changed files with 277 additions and 317 deletions
1
.envrc
1
.envrc
|
@ -1 +0,0 @@
|
||||||
use flake
|
|
2
.gitignore
vendored
2
.gitignore
vendored
|
@ -16,5 +16,3 @@ cabal.project.local*
|
||||||
dist*/
|
dist*/
|
||||||
report.html
|
report.html
|
||||||
*.bak
|
*.bak
|
||||||
.direnv/
|
|
||||||
result
|
|
||||||
|
|
|
@ -16,7 +16,7 @@ homepage: https://github.com/nek0/affection#readme
|
||||||
license: LGPL-3
|
license: LGPL-3
|
||||||
license-file: LICENSE
|
license-file: LICENSE
|
||||||
author: nek0
|
author: nek0
|
||||||
maintainer: nek0@nek0.eu
|
maintainer: nek0@chelnok.de
|
||||||
category: Game
|
category: Game
|
||||||
build-type: Simple
|
build-type: Simple
|
||||||
extra-source-files: ChangeLog.md
|
extra-source-files: ChangeLog.md
|
||||||
|
@ -29,7 +29,7 @@ cabal-version: >=2.0
|
||||||
|
|
||||||
source-repository head
|
source-repository head
|
||||||
type: git
|
type: git
|
||||||
location: https://gitea.nek0.eu/nek0/affection.git
|
location: https://github.com/nek0/affection
|
||||||
|
|
||||||
flag verbose
|
flag verbose
|
||||||
description: Enable verbose debug messages
|
description: Enable verbose debug messages
|
||||||
|
@ -99,10 +99,10 @@ library
|
||||||
-- , UndecidableInstances
|
-- , UndecidableInstances
|
||||||
hs-source-dirs: src
|
hs-source-dirs: src
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
ghc-options: -threaded -Wall
|
ghc-options: -Wall
|
||||||
-- Other library packages from which modules are imported.
|
-- Other library packages from which modules are imported.
|
||||||
build-depends: base >=4.9 && < 5
|
build-depends: base >=4.9 && < 5
|
||||||
, sdl2 >= 2.5
|
, sdl2 ^>= 2.5
|
||||||
, linear
|
, linear
|
||||||
, text
|
, text
|
||||||
, mtl
|
, mtl
|
||||||
|
@ -113,11 +113,9 @@ library
|
||||||
, glib
|
, glib
|
||||||
, bytestring
|
, bytestring
|
||||||
, OpenGL
|
, OpenGL
|
||||||
, OpenGLRaw
|
|
||||||
, stm
|
, stm
|
||||||
, uuid
|
, uuid
|
||||||
, vector
|
, vector
|
||||||
, resourcet
|
|
||||||
|
|
||||||
-- This example shows the message system. only makes sense when compiling with
|
-- This example shows the message system. only makes sense when compiling with
|
||||||
-- verbose flag.
|
-- verbose flag.
|
||||||
|
@ -127,11 +125,12 @@ executable example00
|
||||||
ghc-options: -threaded -Wall
|
ghc-options: -threaded -Wall
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
default-extensions: OverloadedStrings
|
default-extensions: OverloadedStrings
|
||||||
build-depends: base >=4.9 && < 5
|
if flag(examples)
|
||||||
, affection
|
build-depends: base >=4.9 && < 5
|
||||||
, sdl2 >= 2.5
|
, affection
|
||||||
, stm
|
, sdl2 ^>= 2.5
|
||||||
if !flag(examples)
|
, stm
|
||||||
|
else
|
||||||
buildable: False
|
buildable: False
|
||||||
|
|
||||||
-- A small game of life implementation
|
-- A small game of life implementation
|
||||||
|
@ -142,18 +141,19 @@ executable example01
|
||||||
ghc-options: -threaded -Wall
|
ghc-options: -threaded -Wall
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
default-extensions: OverloadedStrings
|
default-extensions: OverloadedStrings
|
||||||
build-depends: base >=4.9 && < 5
|
if flag(examples)
|
||||||
, affection
|
build-depends: base >=4.9 && < 5
|
||||||
, sdl2 >= 2.5
|
, affection
|
||||||
, stm
|
, sdl2 ^>= 2.5
|
||||||
, OpenGL
|
, stm
|
||||||
, random
|
, OpenGL
|
||||||
, containers
|
, random
|
||||||
, linear
|
, containers
|
||||||
, matrix
|
, linear
|
||||||
, nanovg >= 0.6.0.0
|
, matrix
|
||||||
, deepseq
|
, nanovg >= 0.6.0.0
|
||||||
if !flag(examples)
|
, deepseq
|
||||||
|
else
|
||||||
buildable: False
|
buildable: False
|
||||||
|
|
||||||
-- Another small game of life implementation
|
-- Another small game of life implementation
|
||||||
|
@ -164,16 +164,17 @@ executable example02
|
||||||
ghc-options: -threaded -Wall
|
ghc-options: -threaded -Wall
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
default-extensions: OverloadedStrings
|
default-extensions: OverloadedStrings
|
||||||
build-depends: base >=4.9 && < 5
|
if flag(examples)
|
||||||
, affection
|
build-depends: base >=4.9 && < 5
|
||||||
, sdl2 >= 2.5
|
, affection
|
||||||
, stm
|
, sdl2 ^>= 2.5
|
||||||
, OpenGL
|
, stm
|
||||||
, random
|
, OpenGL
|
||||||
, containers
|
, random
|
||||||
, linear
|
, containers
|
||||||
, matrix
|
, linear
|
||||||
, nanovg >= 0.6.0.0
|
, matrix
|
||||||
, deepseq
|
, nanovg >= 0.6.0.0
|
||||||
if !flag(examples)
|
, deepseq
|
||||||
|
else
|
||||||
buildable: False
|
buildable: False
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
packages: ./*.cabal
|
constraints: affection +verbose
|
||||||
|
profiling: true
|
||||||
package affection
|
packages:
|
||||||
flags: +examples
|
./.
|
||||||
|
|
18
default.nix
Normal file
18
default.nix
Normal file
|
@ -0,0 +1,18 @@
|
||||||
|
{ pkgs ? import <nixpkgs> (import (builtins.fetchTarball https://github.com/input-output-hk/haskell.nix/archive/master.tar.gz))
|
||||||
|
, haskellCompiler ? "ghc865"
|
||||||
|
}:
|
||||||
|
pkgs.haskell-nix.cabalProject {
|
||||||
|
src = pkgs.haskell-nix.haskellLib.cleanGit { src = pkgs.nix-gitignore.gitignoreSource [] ./.; };
|
||||||
|
ghc = pkgs.buildPackages.pkgs.haskell-nix.compiler.${haskellCompiler};
|
||||||
|
# pkg-def-extras = [
|
||||||
|
# # Additional packages ontop of all those listed in `cabal.project`
|
||||||
|
# ];
|
||||||
|
# modules = [
|
||||||
|
# # Specific package overrides would go here for example:
|
||||||
|
# packages.cbors.package.ghcOptions = "-Werror";
|
||||||
|
# packages.cbors.patches = [ ./one.patch ];
|
||||||
|
# packages.cbors.flags.optimize-gmp = false;
|
||||||
|
# # It may be better to set flags in `cabal.project` instead
|
||||||
|
# # (`plan-to-nix` will include them as defaults).
|
||||||
|
# ];
|
||||||
|
}
|
60
flake.lock
60
flake.lock
|
@ -1,60 +0,0 @@
|
||||||
{
|
|
||||||
"nodes": {
|
|
||||||
"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": {
|
|
||||||
"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
|
|
||||||
}
|
|
54
flake.nix
54
flake.nix
|
@ -1,54 +0,0 @@
|
||||||
{
|
|
||||||
description = "A game stub written in Haskell";
|
|
||||||
|
|
||||||
inputs = {
|
|
||||||
nixpkgs.url = "github:NixOS/nixpkgs";
|
|
||||||
flake-utils.url = "github:numtide/flake-utils";
|
|
||||||
};
|
|
||||||
|
|
||||||
outputs = { self, nixpkgs, flake-utils }:
|
|
||||||
flake-utils.lib.eachDefaultSystem (system:
|
|
||||||
let
|
|
||||||
pkgs = nixpkgs.legacyPackages.${system};
|
|
||||||
|
|
||||||
haskellPackages = pkgs.haskellPackages;
|
|
||||||
|
|
||||||
jailbreakUnbreak = pkg:
|
|
||||||
pkgs.haskell.lib.doJailbreak (pkg.overrideAttrs (_: { meta = { }; }));
|
|
||||||
|
|
||||||
packageName = "affection";
|
|
||||||
in rec {
|
|
||||||
packages.${packageName} = # (ref:haskell-package-def)
|
|
||||||
haskellPackages.callCabal2nixWithOptions packageName self "--flag examples" {
|
|
||||||
# Dependency overrides go here
|
|
||||||
};
|
|
||||||
|
|
||||||
defaultPackage = self.packages.${system}.${packageName};
|
|
||||||
|
|
||||||
apps = {
|
|
||||||
example00 = {
|
|
||||||
type = "app";
|
|
||||||
program = "${self.packages.${system}.${packageName}}/bin/example00";
|
|
||||||
};
|
|
||||||
example01 = {
|
|
||||||
type = "app";
|
|
||||||
program = "${self.packages.${system}.${packageName}}/bin/example01";
|
|
||||||
};
|
|
||||||
example02 = {
|
|
||||||
type = "app";
|
|
||||||
program = "${self.packages.${system}.${packageName}}/bin/example02";
|
|
||||||
};
|
|
||||||
};
|
|
||||||
|
|
||||||
devShell = haskellPackages.shellFor {
|
|
||||||
packages = p: [ defaultPackage ];
|
|
||||||
withHoogle = true;
|
|
||||||
buildInputs = with haskellPackages; [
|
|
||||||
haskell-language-server
|
|
||||||
ghcid
|
|
||||||
cabal-install
|
|
||||||
] ++ (builtins.attrValues self.packages.${system});
|
|
||||||
};
|
|
||||||
});
|
|
||||||
}
|
|
||||||
|
|
9
notes/TODO.md
Normal file
9
notes/TODO.md
Normal file
|
@ -0,0 +1,9 @@
|
||||||
|
# TODO
|
||||||
|
|
||||||
|
Implement following things in approximately this Order:
|
||||||
|
|
||||||
|
* Message bus -> DONE
|
||||||
|
* Console
|
||||||
|
* GUI
|
||||||
|
* Framework
|
||||||
|
* Everything else
|
126
shell.nix
126
shell.nix
|
@ -1,7 +1,125 @@
|
||||||
{ pkgs ? import <nixpkgs> {}}:
|
{ nixpkgs ? import <nixpkgs> {}, compiler ? "default", doBenchmark ? false }:
|
||||||
|
|
||||||
let
|
let
|
||||||
affection = pkgs.haskellPackages.callCabal2nix "affection" (gitignore ./.) {};
|
|
||||||
gitignore = dir: pkgs.nix-gitignore.gitignoreSource [] dir;
|
inherit (nixpkgs) pkgs;
|
||||||
|
|
||||||
|
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";
|
||||||
|
isLibrary = true;
|
||||||
|
isExecutable = true;
|
||||||
|
doCheck = false;
|
||||||
|
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;
|
||||||
|
}) {};
|
||||||
|
|
||||||
|
glib = with haskellPackages; callPackage(
|
||||||
|
{ mkDerivation, base, bytestring, Cabal, containers, glib
|
||||||
|
, stdenv, text, utf8-string, gtk2hs-buildtools
|
||||||
|
}:
|
||||||
|
mkDerivation {
|
||||||
|
pname = "glib";
|
||||||
|
version = "0.13.8.0";
|
||||||
|
sha256 = "9cce6fb44e3c30de2bd330a6902955e3a5fce7b6e9ce41a4afb70e3a7d6e61a2";
|
||||||
|
setupHaskellDepends = [ base Cabal gtk2hs-buildtools ];
|
||||||
|
libraryHaskellDepends = [
|
||||||
|
base bytestring containers text utf8-string
|
||||||
|
];
|
||||||
|
libraryPkgconfigDepends = [ pkgs.glib ];
|
||||||
|
homepage = "http://projects.haskell.org/gtk2hs/";
|
||||||
|
description = "Binding to the GLIB library for Gtk2Hs";
|
||||||
|
license = stdenv.lib.licenses.lgpl21;
|
||||||
|
}) {};
|
||||||
|
|
||||||
|
#gtk2hs-buildtools = with haskellPackages; callPackage(
|
||||||
|
# { mkDerivation, alex, array, base, Cabal, containers, directory
|
||||||
|
# , filepath, happy, hashtables, pretty, process, random, stdenv
|
||||||
|
# }:
|
||||||
|
# mkDerivation {
|
||||||
|
# pname = "gtk2hs-buildtools";
|
||||||
|
# version = "0.13.4.0";
|
||||||
|
# src = ../gtk2hs/tools;
|
||||||
|
# isLibrary = true;
|
||||||
|
# isExecutable = true;
|
||||||
|
# enableSeparateDataOutput = true;
|
||||||
|
# libraryHaskellDepends = [
|
||||||
|
# array base Cabal containers directory filepath hashtables pretty
|
||||||
|
# process random
|
||||||
|
# ];
|
||||||
|
# libraryToolDepends = [ alex happy ];
|
||||||
|
# executableHaskellDepends = [ base ];
|
||||||
|
# homepage = "http://projects.haskell.org/gtk2hs/";
|
||||||
|
# description = "Tools to build the Gtk2Hs suite of User Interface libraries";
|
||||||
|
# license = stdenv.lib.licenses.gpl2;
|
||||||
|
# }) {};
|
||||||
|
|
||||||
|
sdl2 = with haskellPackages; callPackage(
|
||||||
|
{ mkDerivation, base, bytestring, deepseq, exceptions, linear, SDL2
|
||||||
|
, StateVar, stdenv, text, transformers, vector, weigh
|
||||||
|
}:
|
||||||
|
mkDerivation {
|
||||||
|
pname = "sdl2";
|
||||||
|
version = "2.5.1.0";
|
||||||
|
sha256 = "fc1d3d4276b2c4f835a5311075abb240385aae7edad8760f6bda55ed8271ed20";
|
||||||
|
isLibrary = true;
|
||||||
|
isExecutable = true;
|
||||||
|
enableSeparateDataOutput = true;
|
||||||
|
libraryHaskellDepends = [
|
||||||
|
base bytestring exceptions linear StateVar text transformers vector
|
||||||
|
];
|
||||||
|
librarySystemDepends = [ SDL2 ];
|
||||||
|
libraryPkgconfigDepends = [ SDL2 ];
|
||||||
|
testHaskellDepends = [ base deepseq linear vector weigh ];
|
||||||
|
description = "Both high- and low-level bindings to the SDL library (version 2.0.6+).";
|
||||||
|
license = stdenv.lib.licenses.bsd3;
|
||||||
|
doCheck = false;
|
||||||
|
}) {};
|
||||||
|
|
||||||
|
f = { mkDerivation, base, bytestring, clock, containers, deepseq
|
||||||
|
, linear, matrix, monad-loops, monad-parallel, mtl
|
||||||
|
, OpenGL, random, stdenv, stm, text, uuid, vector
|
||||||
|
}:
|
||||||
|
mkDerivation {
|
||||||
|
pname = "affection";
|
||||||
|
version = "0.0.0.9";
|
||||||
|
src = ./.;
|
||||||
|
configureFlags = [ "-fexamples" ];
|
||||||
|
isLibrary = true;
|
||||||
|
isExecutable = true;
|
||||||
|
libraryHaskellDepends = [
|
||||||
|
base bytestring clock containers glib linear monad-loops
|
||||||
|
monad-parallel mtl OpenGL sdl2 stm text uuid vector
|
||||||
|
];
|
||||||
|
executableHaskellDepends = [
|
||||||
|
base containers deepseq linear matrix nanovg OpenGL random sdl2 stm
|
||||||
|
];
|
||||||
|
homepage = "https://github.com/nek0/affection#readme";
|
||||||
|
description = "A simple Game Engine using SDL";
|
||||||
|
license = stdenv.lib.licenses.lgpl3;
|
||||||
|
};
|
||||||
|
|
||||||
|
haskellPackages = if compiler == "default"
|
||||||
|
then pkgs.haskellPackages
|
||||||
|
else pkgs.haskell.packages.${compiler};
|
||||||
|
|
||||||
|
variant = if doBenchmark then pkgs.haskell.lib.doBenchmark else pkgs.lib.id;
|
||||||
|
|
||||||
|
drv = variant (haskellPackages.callPackage f {});
|
||||||
|
|
||||||
in
|
in
|
||||||
affection.env
|
|
||||||
|
if pkgs.lib.inNixShell then drv.env else drv
|
||||||
|
|
132
src/Affection.hs
132
src/Affection.hs
|
@ -1,5 +1,6 @@
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
{-# LANGUAGE Strict #-}
|
{-# LANGUAGE BangPatterns #-}
|
||||||
|
{-# LANGUAGE ExplicitForAll #-}
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
{-# LANGUAGE RankNTypes #-}
|
{-# LANGUAGE RankNTypes #-}
|
||||||
{-# LANGUAGE TypeApplications #-}
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
@ -16,22 +17,10 @@ import qualified SDL
|
||||||
import qualified SDL.Raw.Video as SDL (glSetAttribute)
|
import qualified SDL.Raw.Video as SDL (glSetAttribute)
|
||||||
import qualified SDL.Raw.Enum as SDL
|
import qualified SDL.Raw.Enum as SDL
|
||||||
|
|
||||||
import qualified Graphics.Rendering.OpenGL as GL (clear, flush, ClearBuffer(..))
|
|
||||||
import qualified Graphics.GL as GLRaw
|
|
||||||
|
|
||||||
import Foreign.Marshal.Array
|
|
||||||
|
|
||||||
import qualified Data.ByteString as B
|
|
||||||
|
|
||||||
import Data.String (fromString)
|
|
||||||
|
|
||||||
import System.Clock
|
import System.Clock
|
||||||
|
|
||||||
import Control.Monad.Loops
|
import Control.Monad.Loops
|
||||||
import Control.Monad.State.Strict
|
import Control.Monad.State.Strict
|
||||||
import Control.Monad.Trans.Resource
|
|
||||||
|
|
||||||
-- internal imports
|
|
||||||
|
|
||||||
import Affection.Types as A
|
import Affection.Types as A
|
||||||
import Affection.Class as A
|
import Affection.Class as A
|
||||||
|
@ -42,88 +31,50 @@ import Affection.Subsystems as A
|
||||||
|
|
||||||
import Affection.Logging as A
|
import Affection.Logging as A
|
||||||
|
|
||||||
|
import qualified Graphics.Rendering.OpenGL as GL (clear, flush, ClearBuffer(..))
|
||||||
|
|
||||||
|
|
||||||
-- | Main function which bootstraps everything else.
|
-- | Main function which bootstraps everything else.
|
||||||
withAffection
|
withAffection
|
||||||
:: forall us. (Affectionate us)
|
:: forall us. (Affectionate us)
|
||||||
=> AffectionConfig us -- ^ Configuration of the Game and its engine.
|
=> AffectionConfig us -- ^ Configuration of the Game and its engine.
|
||||||
-> IO ()
|
-> IO ()
|
||||||
withAffection AffectionConfig{..} = runResourceT $ do
|
withAffection AffectionConfig{..} = do
|
||||||
liftIO $ logIO Debug "Affection starting"
|
liftIO $ logIO Debug "Affection starting"
|
||||||
liftIO $ logIO Debug "Initializing SDL"
|
liftIO $ logIO Debug "Initializing SDL"
|
||||||
|
|
||||||
-- intialiaze SDL
|
-- intialiaze SDL
|
||||||
case initComponents of
|
case initComponents of
|
||||||
All ->
|
All ->
|
||||||
SDL.initializeAll
|
SDL.initializeAll
|
||||||
Only is ->
|
Only is ->
|
||||||
SDL.initialize is
|
SDL.initialize is
|
||||||
|
|
||||||
-- give SDL render quality
|
-- give SDL render quality
|
||||||
SDL.HintRenderScaleQuality SDL.$= SDL.ScaleLinear
|
SDL.HintRenderScaleQuality SDL.$= SDL.ScaleLinear
|
||||||
|
|
||||||
-- just checking…
|
-- just checking…
|
||||||
renderQuality <- SDL.get SDL.HintRenderScaleQuality
|
do
|
||||||
when (renderQuality /= SDL.ScaleLinear) $
|
renderQuality <- SDL.get SDL.HintRenderScaleQuality
|
||||||
liftIO $ logIO Warn "Linear texture filtering not enabled!"
|
when (renderQuality /= SDL.ScaleLinear) $
|
||||||
void $ liftIO (logIO Debug . fromString . show <$> (SDL.version :: IO (Integer, Integer, Integer)))
|
logIO Warn "Linear texture filtering not enabled!"
|
||||||
|
|
||||||
-- construct window
|
-- construct window
|
||||||
liftIO $ logIO Debug "Creating Window(s)"
|
liftIO $ logIO Debug "Creating Window(s)"
|
||||||
windows <-
|
windows <- zip3 (map (\(x,_,_) -> x) windowConfigs) <$>
|
||||||
mapM
|
mapM
|
||||||
(\(_, sdlWindowConfig, mode) -> do
|
(\wc -> SDL.createWindow windowTitle ((\(_,y,_) -> y) wc))
|
||||||
(windowKey, window) <-
|
windowConfigs <*>
|
||||||
allocate
|
pure (map (\(_,_,z) -> z) windowConfigs)
|
||||||
(SDL.createWindow windowTitle sdlWindowConfig)
|
|
||||||
(\window -> do
|
|
||||||
logIO Debug "Destroying Window"
|
|
||||||
SDL.destroyWindow window
|
|
||||||
)
|
|
||||||
return $ AffectionWindow window windowKey mode
|
|
||||||
)
|
|
||||||
windowConfigs
|
|
||||||
|
|
||||||
-- Show windows
|
mapM_ (SDL.showWindow . (\(_,y,_) -> y)) windows
|
||||||
mapM_ (SDL.showWindow . awWindow) windows
|
_ <- SDL.glSetAttribute SDL.SDL_GL_SHARE_WITH_CURRENT_CONTEXT 1
|
||||||
|
contexts <- zip (map (\(x,_,_) -> x) windows) <$>
|
||||||
-- set modes of windows
|
mapM (SDL.glCreateContext . (\(_,y,_) -> y)) windows
|
||||||
mapM_ (\(AffectionWindow window _ mode) -> SDL.setWindowMode window mode) windows
|
mapM_ (\w -> flip SDL.setWindowMode ((\(_,_,z) -> z) w) ((\(_,y,_) -> y) w)) windows
|
||||||
|
|
||||||
-- Make GL context shareable
|
|
||||||
void $ SDL.glSetAttribute SDL.SDL_GL_SHARE_WITH_CURRENT_CONTEXT 1
|
|
||||||
|
|
||||||
-- Create OpenGL contexts
|
|
||||||
contexts <-
|
|
||||||
mapM
|
|
||||||
(\(AffectionWindow window _ _) -> do
|
|
||||||
(contextKey, context) <-
|
|
||||||
allocate
|
|
||||||
(SDL.glCreateContext window)
|
|
||||||
(\context -> do
|
|
||||||
logIO Debug "Destroying context"
|
|
||||||
SDL.glDeleteContext context
|
|
||||||
)
|
|
||||||
return $ AffectionContext context contextKey
|
|
||||||
)
|
|
||||||
windows
|
|
||||||
|
|
||||||
-- sync updates with monitor
|
|
||||||
-- SDL.swapInterval $= SDL.SynchronizedUpdates -- <- causes Problems with windows
|
-- SDL.swapInterval $= SDL.SynchronizedUpdates -- <- causes Problems with windows
|
||||||
|
|
||||||
-- print current used GL Version
|
|
||||||
version <- liftIO $ peekArray0 (0 :: Word8) =<< GLRaw.glGetString GLRaw.GL_VERSION
|
|
||||||
liftIO $ print (B.pack version)
|
|
||||||
|
|
||||||
-- get current time
|
|
||||||
liftIO $ logIO Debug "Getting Time"
|
liftIO $ logIO Debug "Getting Time"
|
||||||
execTime <- liftIO $ getTime Monotonic
|
-- get current time
|
||||||
|
execTime <- getTime Monotonic
|
||||||
liftIO $ logIO Debug "Loading initial data container"
|
liftIO $ logIO Debug "Loading initial data container"
|
||||||
|
|
||||||
-- construct game data object from provided Affectionate instance
|
-- construct game data object from provided Affectionate instance
|
||||||
(gameDataKey, gameData) <-
|
gameData <- loadState @us
|
||||||
allocate
|
|
||||||
(liftIO $ loadState @us)
|
|
||||||
(liftIO . cleanUp)
|
|
||||||
-- build state container
|
-- build state container
|
||||||
let initContainer = AffectionData
|
let initContainer = AffectionData
|
||||||
{ drawWindows = windows
|
{ drawWindows = windows
|
||||||
|
@ -133,53 +84,41 @@ withAffection AffectionConfig{..} = runResourceT $ do
|
||||||
, sysTime = execTime
|
, sysTime = execTime
|
||||||
, pausedTime = False
|
, pausedTime = False
|
||||||
}
|
}
|
||||||
|
|
||||||
-- initialize and run state
|
-- initialize and run state
|
||||||
void $ liftIO $ runAffection initContainer
|
(_, _) <- runStateT
|
||||||
|
(A.runState
|
||||||
(do
|
(do
|
||||||
liftIO $ logIO Debug "Running Pre-Loop stage"
|
liftIO $ logIO Debug "Starting Loop"
|
||||||
|
|
||||||
-- run preLoop function from Affectionate
|
-- run preLoop function from Affectionate
|
||||||
preLoop gameData
|
preLoop gameData
|
||||||
liftIO $ logIO Debug "Starting Loop"
|
|
||||||
whileM_ (hasNextStep gameData)
|
whileM_ (hasNextStep gameData)
|
||||||
(do
|
(do
|
||||||
-- get state
|
-- get state
|
||||||
ad <- get
|
ad <- get
|
||||||
|
|
||||||
-- Measure time difference form last run
|
-- Measure time difference form last run
|
||||||
now <- liftIO $ getTime Monotonic
|
now <- liftIO $ getTime Monotonic
|
||||||
let lastTime = sysTime ad
|
let lastTime = sysTime ad
|
||||||
|
|
||||||
-- compute dt and update elapsedTime
|
-- compute dt and update elapsedTime
|
||||||
let dt = fromIntegral
|
let !dt = fromIntegral
|
||||||
(toNanoSecs $ diffTimeSpec lastTime now) / (10 ^ (9 :: Int))
|
(toNanoSecs $ diffTimeSpec lastTime now) / (10 ^ (9 :: Int))
|
||||||
ne = elapsedTime ad + dt
|
!ne = elapsedTime ad + dt
|
||||||
|
|
||||||
-- update state data object with new time values
|
-- update state data object with new time values
|
||||||
put $ ad
|
put $ ad
|
||||||
{ elapsedTime = ne
|
{ elapsedTime = ne
|
||||||
, deltaTime = dt
|
, deltaTime = dt
|
||||||
}
|
}
|
||||||
|
|
||||||
-- poll events
|
-- poll events
|
||||||
liftIO SDL.pumpEvents
|
|
||||||
evs <- preHandleEvents =<< liftIO SDL.pollEvents
|
evs <- preHandleEvents =<< liftIO SDL.pollEvents
|
||||||
|
|
||||||
-- handle events
|
-- handle events
|
||||||
handleEvents gameData evs
|
handleEvents gameData evs
|
||||||
|
|
||||||
-- execute user defined update loop
|
-- execute user defined update loop
|
||||||
unless (pausedTime ad) (update gameData dt)
|
unless (pausedTime ad) (update gameData dt)
|
||||||
|
|
||||||
-- clear GL buffer >> execute user defined draw loop >> flush GL buffer
|
-- clear GL buffer >> execute user defined draw loop >> flush GL buffer
|
||||||
liftIO $ GL.clear [GL.ColorBuffer, GL.DepthBuffer, GL.StencilBuffer]
|
liftIO $ GL.clear [GL.ColorBuffer, GL.DepthBuffer, GL.StencilBuffer]
|
||||||
draw gameData
|
draw gameData
|
||||||
liftIO GL.flush
|
liftIO GL.flush
|
||||||
|
|
||||||
-- actual displaying of newly drawn frame
|
-- actual displaying of newly drawn frame
|
||||||
mapM_ (SDL.glSwapWindow . awWindow) windows
|
mapM_ (SDL.glSwapWindow . (\(_,y,_) -> y)) windows
|
||||||
|
|
||||||
-- save new time
|
-- save new time
|
||||||
ad3 <- get
|
ad3 <- get
|
||||||
when (sysTime ad == sysTime ad3) (
|
when (sysTime ad == sysTime ad3) (
|
||||||
|
@ -189,16 +128,11 @@ withAffection AffectionConfig{..} = runResourceT $ do
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
-- Cleanup works
|
) initContainer
|
||||||
liftIO $ logIO Debug "Loop ended. Cleaning"
|
liftIO $ logIO Debug "Loop ended. Cleaning"
|
||||||
release gameDataKey
|
cleanUp gameData
|
||||||
-- mapM_ (SDL.glDeleteContext . snd) contexts
|
liftIO $ logIO Debug "Destroying Window"
|
||||||
-- mapM_ (SDL.destroyWindow . (\(_,y,_) -> y)) windows
|
mapM_ (SDL.glDeleteContext . snd) contexts
|
||||||
|
mapM_ (SDL.destroyWindow . (\(_,y,_) -> y)) windows
|
||||||
-- SDL.quit -- <- This causes segfaults depending on hardware
|
-- SDL.quit -- <- This causes segfaults depending on hardware
|
||||||
liftIO $ logIO Debug "This is the end"
|
liftIO $ logIO Debug "This is the end"
|
||||||
|
|
||||||
runAffection
|
|
||||||
:: AffectionData
|
|
||||||
-> AffectionState AffectionData ResIO a
|
|
||||||
-> IO (a, AffectionData)
|
|
||||||
runAffection initialState a = runResourceT $ runStateT (A.runState a) initialState
|
|
||||||
|
|
|
@ -1,6 +1,9 @@
|
||||||
module Affection.MessageBus
|
module Affection.MessageBus
|
||||||
( module M
|
( module M
|
||||||
|
, module Msg
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Affection.MessageBus.Class as M
|
import Affection.MessageBus.Class as M
|
||||||
import Affection.MessageBus.Message as M
|
import Affection.MessageBus.Message as M
|
||||||
|
|
||||||
|
import Affection.MessageBus.Message as Msg
|
||||||
|
|
|
@ -7,14 +7,14 @@ import Affection.Types
|
||||||
import qualified SDL
|
import qualified SDL
|
||||||
|
|
||||||
-- | Typeclass for simple scaffolding of a state machine
|
-- | Typeclass for simple scaffolding of a state machine
|
||||||
class StateMachine us a where
|
class StateMachine a where
|
||||||
-- | State load routine
|
-- | State load routine
|
||||||
smLoad :: a -> us -> Affection ()
|
smLoad :: a -> Affection ()
|
||||||
-- | state update routine
|
-- | state update routine
|
||||||
smUpdate :: a -> us -> Double -> Affection ()
|
smUpdate :: a -> Double -> Affection ()
|
||||||
-- | State event handler routine
|
-- | State event handler routine
|
||||||
smEvent :: a -> us -> [SDL.EventPayload] -> Affection ()
|
smEvent :: a -> [SDL.EventPayload] -> Affection ()
|
||||||
-- | State draw routine
|
-- | State draw routine
|
||||||
smDraw :: a -> us -> Affection ()
|
smDraw :: a -> Affection ()
|
||||||
-- | State clean routine
|
-- | State clean routine
|
||||||
smClean :: a -> us -> Affection ()
|
smClean :: a -> Affection ()
|
||||||
|
|
|
@ -5,8 +5,6 @@ module Affection.Types
|
||||||
, AffectionData(..)
|
, AffectionData(..)
|
||||||
, AffectionStateInner
|
, AffectionStateInner
|
||||||
, AffectionState(..)
|
, AffectionState(..)
|
||||||
, AffectionWindow(..)
|
|
||||||
, AffectionContext(..)
|
|
||||||
, InitComponents(..)
|
, InitComponents(..)
|
||||||
, Angle
|
, Angle
|
||||||
-- | SDL reexports
|
-- | SDL reexports
|
||||||
|
@ -25,7 +23,6 @@ import qualified Data.Text as T
|
||||||
|
|
||||||
import Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
import Control.Monad.State.Strict
|
import Control.Monad.State.Strict
|
||||||
import Control.Monad.Trans.Resource
|
|
||||||
import qualified Control.Monad.Parallel as MP
|
import qualified Control.Monad.Parallel as MP
|
||||||
|
|
||||||
import System.Clock (TimeSpec)
|
import System.Clock (TimeSpec)
|
||||||
|
@ -53,35 +50,35 @@ data InitComponents
|
||||||
|
|
||||||
-- | Main type for defining the look, feel and action of the whole application.
|
-- | Main type for defining the look, feel and action of the whole application.
|
||||||
data AffectionData = AffectionData
|
data AffectionData = AffectionData
|
||||||
{ drawWindows :: [ AffectionWindow ] -- ^ SDL windows
|
{ drawWindows ::
|
||||||
, glContext :: [ AffectionContext ] -- ^ OpenGL rendering contexts
|
[
|
||||||
, elapsedTime :: Double -- ^ Elapsed time in seconds
|
( Word -- --^ Window identifier
|
||||||
, deltaTime :: Double -- ^ Elapsed time in seconds since last tick
|
, SDL.Window -- --^ Window linked with identifier
|
||||||
, sysTime :: TimeSpec -- ^ System time (NOT the time on the clock)
|
, SDL.WindowMode -- -- ^ current screen mode
|
||||||
, pausedTime :: Bool -- ^ Should the update loop be executed?
|
)
|
||||||
|
] -- ^ SDL windows
|
||||||
|
, glContext ::
|
||||||
|
[
|
||||||
|
( Word -- --^ Window identifier
|
||||||
|
, SDL.GLContext -- --^ Associated OpenGL context
|
||||||
|
)
|
||||||
|
] -- ^ OpenGL rendering contexts
|
||||||
|
, elapsedTime :: Double -- ^ Elapsed time in seconds
|
||||||
|
, deltaTime :: Double -- ^ Elapsed time in seconds since last tick
|
||||||
|
, sysTime :: TimeSpec -- ^ System time (NOT the time on the clock)
|
||||||
|
, pausedTime :: Bool -- ^ Should the update loop be executed?
|
||||||
}
|
}
|
||||||
|
|
||||||
-- | Inner 'StateT' monad for the update state
|
-- | Inner 'StateT' monad for the update state
|
||||||
type AffectionStateInner sd m = StateT sd m
|
type AffectionStateInner sd a = StateT sd a
|
||||||
|
|
||||||
-- | Affection's state monad
|
-- | Affection's state monad
|
||||||
newtype AffectionState sd m a = AffectionState
|
newtype AffectionState sd m a = AffectionState
|
||||||
{ runState :: AffectionStateInner sd m a }
|
{ runState :: AffectionStateInner sd m a }
|
||||||
deriving (Functor, Applicative, Monad, MonadIO, MonadState sd, MonadResource)
|
deriving (Functor, Applicative, Monad, MonadIO, MonadState sd)
|
||||||
|
|
||||||
instance MP.MonadParallel m => MP.MonadParallel (AffectionState sd m)
|
instance MP.MonadParallel m => MP.MonadParallel (AffectionState sd m)
|
||||||
|
|
||||||
type Affection a = AffectionState AffectionData ResIO a
|
type Affection a = AffectionState AffectionData IO a
|
||||||
|
|
||||||
type Angle = Double
|
type Angle = Double
|
||||||
|
|
||||||
data AffectionWindow = AffectionWindow
|
|
||||||
{ awWindow :: SDL.Window
|
|
||||||
, awReleaseKey :: ReleaseKey
|
|
||||||
, awMode :: SDL.WindowMode
|
|
||||||
}
|
|
||||||
|
|
||||||
data AffectionContext = AffectionContext
|
|
||||||
{ acContext :: SDL.GLContext
|
|
||||||
, acReleaseKey :: ReleaseKey
|
|
||||||
}
|
|
||||||
|
|
|
@ -39,35 +39,32 @@ getDelta = gets deltaTime
|
||||||
toggleScreen :: Word -> Affection ()
|
toggleScreen :: Word -> Affection ()
|
||||||
toggleScreen windowIdent = do
|
toggleScreen windowIdent = do
|
||||||
ad <- get
|
ad <- get
|
||||||
(stop, alteredWindowList) <- foldM
|
let mwindow = find (\(ident, _, _) -> ident == windowIdent) (drawWindows ad)
|
||||||
(\(stop, resWindows) (num, aw@(AffectionWindow window _ mode)) -> do
|
case mwindow of
|
||||||
if stop || num == windowIdent
|
Just (ident, window, mode) -> do
|
||||||
then do
|
newMode <- case mode of
|
||||||
newMode <- case mode of
|
SDL.FullscreenDesktop -> do
|
||||||
SDL.FullscreenDesktop -> do
|
SDL.setWindowMode window SDL.Windowed
|
||||||
liftIO $ SDL.setWindowMode window SDL.Windowed
|
return SDL.Windowed
|
||||||
return SDL.Windowed
|
SDL.Windowed -> do
|
||||||
SDL.Windowed -> do
|
SDL.setWindowMode window SDL.FullscreenDesktop
|
||||||
liftIO $ SDL.setWindowMode window SDL.FullscreenDesktop
|
return SDL.FullscreenDesktop
|
||||||
return SDL.FullscreenDesktop
|
x -> do
|
||||||
x -> do
|
liftIO $ logIO Warn ("Unexpected window mode: " <> fromString (show x))
|
||||||
liftIO $ logIO Warn ("Unexpected window mode: " <> fromString (show x))
|
return x
|
||||||
return x
|
now <- liftIO $ getTime Monotonic
|
||||||
return (True, resWindows ++ [aw { awMode = newMode }])
|
put ad
|
||||||
else
|
{ sysTime = now
|
||||||
return (stop, resWindows ++ [aw])
|
, drawWindows = map
|
||||||
)
|
(\e@(lid, win, _) ->
|
||||||
(False, [])
|
if lid == ident
|
||||||
(zip [0..] (drawWindows ad))
|
then (lid, win, newMode)
|
||||||
if stop
|
else e
|
||||||
then do
|
)
|
||||||
now <- liftIO $ getTime Monotonic
|
(drawWindows ad)
|
||||||
put ad
|
}
|
||||||
{ sysTime = now
|
Nothing -> do
|
||||||
, drawWindows = alteredWindowList
|
liftIO $ logIO Warn ("No window found with ident " <> fromString (show windowIdent))
|
||||||
}
|
|
||||||
else
|
|
||||||
liftIO $ logIO Warn ("No window found with ident " <> fromString (show windowIdent))
|
|
||||||
|
|
||||||
-- | Fit the GL Viewport to Window size
|
-- | Fit the GL Viewport to Window size
|
||||||
fitViewport
|
fitViewport
|
||||||
|
|
Loading…
Reference in a new issue