Compare commits
20 commits
Author | SHA1 | Date | |
---|---|---|---|
nek0 | 51e8de7451 | ||
nek0 | 75c67a0c5a | ||
nek0 | 5cf9a906db | ||
nek0 | abaf864c91 | ||
nek0 | 5bef189c30 | ||
nek0 | efbb9b4c5e | ||
nek0 | 76225dff4b | ||
nek0 | eda79eb626 | ||
nek0 | 04d6905de1 | ||
nek0 | b56ed86e45 | ||
nek0 | af0dcc16da | ||
nek0 | 81a76d4eb3 | ||
nek0 | 1b8d754cd6 | ||
nek0 | 60d38217c8 | ||
nek0 | 17978b0bd7 | ||
nek0 | 9aef49da94 | ||
nek0 | 9f47b192a5 | ||
nek0 | c574671244 | ||
nek0 | 01c152c1a5 | ||
nek0 | f5782fc935 |
2
.gitignore
vendored
2
.gitignore
vendored
|
@ -14,5 +14,3 @@ dist/
|
||||||
*.prof
|
*.prof
|
||||||
*.ps
|
*.ps
|
||||||
*.html
|
*.html
|
||||||
.direnv/
|
|
||||||
result
|
|
||||||
|
|
|
@ -1,5 +1,6 @@
|
||||||
packages:
|
packages:
|
||||||
./
|
./
|
||||||
|
./extern/*
|
||||||
|
|
||||||
constraints:
|
constraints:
|
||||||
affection +verbose
|
affection +verbose
|
||||||
|
|
20
extern/affection/.gitignore
vendored
Normal file
20
extern/affection/.gitignore
vendored
Normal file
|
@ -0,0 +1,20 @@
|
||||||
|
*.hi
|
||||||
|
*.o
|
||||||
|
.hsenv*
|
||||||
|
.stack-work
|
||||||
|
.git
|
||||||
|
.cabal-sandbox/
|
||||||
|
cabal.sandbox.config
|
||||||
|
dist/
|
||||||
|
*.prof
|
||||||
|
*.aux
|
||||||
|
*.hp
|
||||||
|
*.ps
|
||||||
|
*.swp
|
||||||
|
.ghc*
|
||||||
|
cabal.project.local*
|
||||||
|
dist*/
|
||||||
|
report.html
|
||||||
|
*.bak
|
||||||
|
.direnv/
|
||||||
|
.envrc
|
5
extern/affection/ChangeLog.md
vendored
Normal file
5
extern/affection/ChangeLog.md
vendored
Normal file
|
@ -0,0 +1,5 @@
|
||||||
|
# Revision history for affection
|
||||||
|
|
||||||
|
## 0.0.0.7 -- 2017-12-23
|
||||||
|
|
||||||
|
* Release with working scaffold for engine subsystems.
|
165
extern/affection/LICENSE
vendored
Normal file
165
extern/affection/LICENSE
vendored
Normal file
|
@ -0,0 +1,165 @@
|
||||||
|
GNU LESSER GENERAL PUBLIC LICENSE
|
||||||
|
Version 3, 29 June 2007
|
||||||
|
|
||||||
|
Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>
|
||||||
|
Everyone is permitted to copy and distribute verbatim copies
|
||||||
|
of this license document, but changing it is not allowed.
|
||||||
|
|
||||||
|
|
||||||
|
This version of the GNU Lesser General Public License incorporates
|
||||||
|
the terms and conditions of version 3 of the GNU General Public
|
||||||
|
License, supplemented by the additional permissions listed below.
|
||||||
|
|
||||||
|
0. Additional Definitions.
|
||||||
|
|
||||||
|
As used herein, "this License" refers to version 3 of the GNU Lesser
|
||||||
|
General Public License, and the "GNU GPL" refers to version 3 of the GNU
|
||||||
|
General Public License.
|
||||||
|
|
||||||
|
"The Library" refers to a covered work governed by this License,
|
||||||
|
other than an Application or a Combined Work as defined below.
|
||||||
|
|
||||||
|
An "Application" is any work that makes use of an interface provided
|
||||||
|
by the Library, but which is not otherwise based on the Library.
|
||||||
|
Defining a subclass of a class defined by the Library is deemed a mode
|
||||||
|
of using an interface provided by the Library.
|
||||||
|
|
||||||
|
A "Combined Work" is a work produced by combining or linking an
|
||||||
|
Application with the Library. The particular version of the Library
|
||||||
|
with which the Combined Work was made is also called the "Linked
|
||||||
|
Version".
|
||||||
|
|
||||||
|
The "Minimal Corresponding Source" for a Combined Work means the
|
||||||
|
Corresponding Source for the Combined Work, excluding any source code
|
||||||
|
for portions of the Combined Work that, considered in isolation, are
|
||||||
|
based on the Application, and not on the Linked Version.
|
||||||
|
|
||||||
|
The "Corresponding Application Code" for a Combined Work means the
|
||||||
|
object code and/or source code for the Application, including any data
|
||||||
|
and utility programs needed for reproducing the Combined Work from the
|
||||||
|
Application, but excluding the System Libraries of the Combined Work.
|
||||||
|
|
||||||
|
1. Exception to Section 3 of the GNU GPL.
|
||||||
|
|
||||||
|
You may convey a covered work under sections 3 and 4 of this License
|
||||||
|
without being bound by section 3 of the GNU GPL.
|
||||||
|
|
||||||
|
2. Conveying Modified Versions.
|
||||||
|
|
||||||
|
If you modify a copy of the Library, and, in your modifications, a
|
||||||
|
facility refers to a function or data to be supplied by an Application
|
||||||
|
that uses the facility (other than as an argument passed when the
|
||||||
|
facility is invoked), then you may convey a copy of the modified
|
||||||
|
version:
|
||||||
|
|
||||||
|
a) under this License, provided that you make a good faith effort to
|
||||||
|
ensure that, in the event an Application does not supply the
|
||||||
|
function or data, the facility still operates, and performs
|
||||||
|
whatever part of its purpose remains meaningful, or
|
||||||
|
|
||||||
|
b) under the GNU GPL, with none of the additional permissions of
|
||||||
|
this License applicable to that copy.
|
||||||
|
|
||||||
|
3. Object Code Incorporating Material from Library Header Files.
|
||||||
|
|
||||||
|
The object code form of an Application may incorporate material from
|
||||||
|
a header file that is part of the Library. You may convey such object
|
||||||
|
code under terms of your choice, provided that, if the incorporated
|
||||||
|
material is not limited to numerical parameters, data structure
|
||||||
|
layouts and accessors, or small macros, inline functions and templates
|
||||||
|
(ten or fewer lines in length), you do both of the following:
|
||||||
|
|
||||||
|
a) Give prominent notice with each copy of the object code that the
|
||||||
|
Library is used in it and that the Library and its use are
|
||||||
|
covered by this License.
|
||||||
|
|
||||||
|
b) Accompany the object code with a copy of the GNU GPL and this license
|
||||||
|
document.
|
||||||
|
|
||||||
|
4. Combined Works.
|
||||||
|
|
||||||
|
You may convey a Combined Work under terms of your choice that,
|
||||||
|
taken together, effectively do not restrict modification of the
|
||||||
|
portions of the Library contained in the Combined Work and reverse
|
||||||
|
engineering for debugging such modifications, if you also do each of
|
||||||
|
the following:
|
||||||
|
|
||||||
|
a) Give prominent notice with each copy of the Combined Work that
|
||||||
|
the Library is used in it and that the Library and its use are
|
||||||
|
covered by this License.
|
||||||
|
|
||||||
|
b) Accompany the Combined Work with a copy of the GNU GPL and this license
|
||||||
|
document.
|
||||||
|
|
||||||
|
c) For a Combined Work that displays copyright notices during
|
||||||
|
execution, include the copyright notice for the Library among
|
||||||
|
these notices, as well as a reference directing the user to the
|
||||||
|
copies of the GNU GPL and this license document.
|
||||||
|
|
||||||
|
d) Do one of the following:
|
||||||
|
|
||||||
|
0) Convey the Minimal Corresponding Source under the terms of this
|
||||||
|
License, and the Corresponding Application Code in a form
|
||||||
|
suitable for, and under terms that permit, the user to
|
||||||
|
recombine or relink the Application with a modified version of
|
||||||
|
the Linked Version to produce a modified Combined Work, in the
|
||||||
|
manner specified by section 6 of the GNU GPL for conveying
|
||||||
|
Corresponding Source.
|
||||||
|
|
||||||
|
1) Use a suitable shared library mechanism for linking with the
|
||||||
|
Library. A suitable mechanism is one that (a) uses at run time
|
||||||
|
a copy of the Library already present on the user's computer
|
||||||
|
system, and (b) will operate properly with a modified version
|
||||||
|
of the Library that is interface-compatible with the Linked
|
||||||
|
Version.
|
||||||
|
|
||||||
|
e) Provide Installation Information, but only if you would otherwise
|
||||||
|
be required to provide such information under section 6 of the
|
||||||
|
GNU GPL, and only to the extent that such information is
|
||||||
|
necessary to install and execute a modified version of the
|
||||||
|
Combined Work produced by recombining or relinking the
|
||||||
|
Application with a modified version of the Linked Version. (If
|
||||||
|
you use option 4d0, the Installation Information must accompany
|
||||||
|
the Minimal Corresponding Source and Corresponding Application
|
||||||
|
Code. If you use option 4d1, you must provide the Installation
|
||||||
|
Information in the manner specified by section 6 of the GNU GPL
|
||||||
|
for conveying Corresponding Source.)
|
||||||
|
|
||||||
|
5. Combined Libraries.
|
||||||
|
|
||||||
|
You may place library facilities that are a work based on the
|
||||||
|
Library side by side in a single library together with other library
|
||||||
|
facilities that are not Applications and are not covered by this
|
||||||
|
License, and convey such a combined library under terms of your
|
||||||
|
choice, if you do both of the following:
|
||||||
|
|
||||||
|
a) Accompany the combined library with a copy of the same work based
|
||||||
|
on the Library, uncombined with any other library facilities,
|
||||||
|
conveyed under the terms of this License.
|
||||||
|
|
||||||
|
b) Give prominent notice with the combined library that part of it
|
||||||
|
is a work based on the Library, and explaining where to find the
|
||||||
|
accompanying uncombined form of the same work.
|
||||||
|
|
||||||
|
6. Revised Versions of the GNU Lesser General Public License.
|
||||||
|
|
||||||
|
The Free Software Foundation may publish revised and/or new versions
|
||||||
|
of the GNU Lesser General Public License from time to time. Such new
|
||||||
|
versions will be similar in spirit to the present version, but may
|
||||||
|
differ in detail to address new problems or concerns.
|
||||||
|
|
||||||
|
Each version is given a distinguishing version number. If the
|
||||||
|
Library as you received it specifies that a certain numbered version
|
||||||
|
of the GNU Lesser General Public License "or any later version"
|
||||||
|
applies to it, you have the option of following the terms and
|
||||||
|
conditions either of that published version or of any later version
|
||||||
|
published by the Free Software Foundation. If the Library as you
|
||||||
|
received it does not specify a version number of the GNU Lesser
|
||||||
|
General Public License, you may choose any version of the GNU Lesser
|
||||||
|
General Public License ever published by the Free Software Foundation.
|
||||||
|
|
||||||
|
If the Library as you received it specifies that a proxy can decide
|
||||||
|
whether future versions of the GNU Lesser General Public License shall
|
||||||
|
apply, that proxy's public statement of acceptance of any version is
|
||||||
|
permanent authorization for you to choose that version for the
|
||||||
|
Library.
|
8
extern/affection/README.md
vendored
Normal file
8
extern/affection/README.md
vendored
Normal file
|
@ -0,0 +1,8 @@
|
||||||
|
# ![Affection logo](./affection.svg)
|
||||||
|
|
||||||
|
A simple Game Engine in Haskell using SDL
|
||||||
|
|
||||||
|
## Disclaimer
|
||||||
|
|
||||||
|
This Engine is not stable yet. Things may change. horribly.
|
||||||
|
Even minor version bumps may break the API.
|
2
extern/affection/Setup.hs
vendored
Normal file
2
extern/affection/Setup.hs
vendored
Normal file
|
@ -0,0 +1,2 @@
|
||||||
|
import Distribution.Simple
|
||||||
|
main = defaultMain
|
179
extern/affection/affection.cabal
vendored
Normal file
179
extern/affection/affection.cabal
vendored
Normal file
|
@ -0,0 +1,179 @@
|
||||||
|
name: affection
|
||||||
|
|
||||||
|
-- The package version. See the Haskell package versioning policy (PVP)
|
||||||
|
-- for standards guiding when and how versions should be incremented.
|
||||||
|
-- http://www.haskell.org/haskellwiki/Package_versioning_policy
|
||||||
|
-- PVP summary: +-+------- breaking API changes
|
||||||
|
-- | | +----- non-breaking API additions
|
||||||
|
-- | | | +--- code changes with no API change
|
||||||
|
version: 0.0.0.10
|
||||||
|
synopsis: A simple Game Engine using SDL
|
||||||
|
description: This package contains Affection, a simple game engine
|
||||||
|
written in Haskell using SDL.
|
||||||
|
This Engine is still work in progress and even minor
|
||||||
|
version bumps may contain breaking api changes.
|
||||||
|
homepage: https://github.com/nek0/affection#readme
|
||||||
|
license: LGPL-3
|
||||||
|
license-file: LICENSE
|
||||||
|
author: nek0
|
||||||
|
maintainer: nek0@chelnok.de
|
||||||
|
category: Game
|
||||||
|
build-type: Simple
|
||||||
|
extra-source-files: ChangeLog.md
|
||||||
|
|
||||||
|
-- Extra files to be distributed with the package, such as examples or a
|
||||||
|
-- README.
|
||||||
|
-- extra-source-files:
|
||||||
|
|
||||||
|
cabal-version: >=2.0
|
||||||
|
|
||||||
|
source-repository head
|
||||||
|
type: git
|
||||||
|
location: https://github.com/nek0/affection
|
||||||
|
|
||||||
|
flag verbose
|
||||||
|
description: Enable verbose debug messages
|
||||||
|
default: False
|
||||||
|
manual: True
|
||||||
|
|
||||||
|
flag debug
|
||||||
|
description: Enable debug messages
|
||||||
|
default: False
|
||||||
|
manual: True
|
||||||
|
|
||||||
|
flag warn
|
||||||
|
description: Enable warning messages
|
||||||
|
default: False
|
||||||
|
manual: True
|
||||||
|
|
||||||
|
flag error
|
||||||
|
description: Enable error messages
|
||||||
|
default: False
|
||||||
|
manual: True
|
||||||
|
|
||||||
|
flag examples
|
||||||
|
description: Build example programs
|
||||||
|
default: False
|
||||||
|
|
||||||
|
library
|
||||||
|
if flag(verbose)
|
||||||
|
cpp-options: -DVERBOSE
|
||||||
|
if flag(debug)
|
||||||
|
cpp-options: -DDEBUG
|
||||||
|
if flag(warn)
|
||||||
|
cpp-options: -DWARN
|
||||||
|
if flag(error)
|
||||||
|
cpp-options: -DERROR
|
||||||
|
exposed-modules: Affection
|
||||||
|
, Affection.Logging
|
||||||
|
, Affection.Types
|
||||||
|
, Affection.Class
|
||||||
|
, Affection.StateMachine
|
||||||
|
, Affection.Util
|
||||||
|
, Affection.MessageBus
|
||||||
|
, Affection.MessageBus.Class
|
||||||
|
, Affection.MessageBus.Message
|
||||||
|
, Affection.MessageBus.Message.Class
|
||||||
|
, Affection.MessageBus.Message.WindowMessage
|
||||||
|
, Affection.MessageBus.Message.KeyboardMessage
|
||||||
|
, Affection.MessageBus.Message.MouseMessage
|
||||||
|
, Affection.MessageBus.Message.JoystickMessage
|
||||||
|
, Affection.Subsystems
|
||||||
|
, Affection.Subsystems.Class
|
||||||
|
, Affection.Subsystems.AffectionWindow
|
||||||
|
, Affection.Subsystems.AffectionKeyboard
|
||||||
|
, Affection.Subsystems.AffectionMouse
|
||||||
|
, Affection.Subsystems.AffectionJoystick
|
||||||
|
default-extensions: OverloadedStrings
|
||||||
|
, TypeFamilies
|
||||||
|
, AllowAmbiguousTypes
|
||||||
|
|
||||||
|
-- Modules included in this library but not exported.
|
||||||
|
-- other-modules:
|
||||||
|
|
||||||
|
-- LANGUAGE extensions used by modules in this package.
|
||||||
|
-- other-extensions: GADTs
|
||||||
|
-- , KindSignatures
|
||||||
|
-- , FlexibleInstances
|
||||||
|
-- , MultiParamTypeClasses
|
||||||
|
-- , UndecidableInstances
|
||||||
|
hs-source-dirs: src
|
||||||
|
default-language: Haskell2010
|
||||||
|
ghc-options: -Wall
|
||||||
|
-- Other library packages from which modules are imported.
|
||||||
|
build-depends: base >=4.9 && < 5
|
||||||
|
, sdl2 >= 2.5
|
||||||
|
, linear
|
||||||
|
, text
|
||||||
|
, mtl
|
||||||
|
, monad-loops
|
||||||
|
, monad-parallel
|
||||||
|
, containers
|
||||||
|
, clock >= 0.8
|
||||||
|
, glib
|
||||||
|
, bytestring
|
||||||
|
, OpenGL
|
||||||
|
, OpenGLRaw
|
||||||
|
, stm
|
||||||
|
, uuid
|
||||||
|
, vector
|
||||||
|
, resourcet
|
||||||
|
|
||||||
|
-- This example shows the message system. only makes sense when compiling with
|
||||||
|
-- verbose flag.
|
||||||
|
executable example00
|
||||||
|
hs-source-dirs: examples/example00
|
||||||
|
main-is: Main.hs
|
||||||
|
ghc-options: -threaded -Wall
|
||||||
|
default-language: Haskell2010
|
||||||
|
default-extensions: OverloadedStrings
|
||||||
|
build-depends: base >=4.9 && < 5
|
||||||
|
, affection
|
||||||
|
, sdl2 >= 2.5
|
||||||
|
, stm
|
||||||
|
if !flag(examples)
|
||||||
|
buildable: False
|
||||||
|
|
||||||
|
-- A small game of life implementation
|
||||||
|
executable example01
|
||||||
|
hs-source-dirs: examples/example01
|
||||||
|
main-is: Main.hs
|
||||||
|
other-modules: Types
|
||||||
|
ghc-options: -threaded -Wall
|
||||||
|
default-language: Haskell2010
|
||||||
|
default-extensions: OverloadedStrings
|
||||||
|
build-depends: base >=4.9 && < 5
|
||||||
|
, affection
|
||||||
|
, sdl2 >= 2.5
|
||||||
|
, stm
|
||||||
|
, OpenGL
|
||||||
|
, random
|
||||||
|
, containers
|
||||||
|
, linear
|
||||||
|
, matrix
|
||||||
|
, nanovg >= 0.6.0.0
|
||||||
|
, deepseq
|
||||||
|
if !flag(examples)
|
||||||
|
buildable: False
|
||||||
|
|
||||||
|
-- Another small game of life implementation
|
||||||
|
executable example02
|
||||||
|
hs-source-dirs: examples/example02
|
||||||
|
main-is: Main.hs
|
||||||
|
other-modules: Types
|
||||||
|
ghc-options: -threaded -Wall
|
||||||
|
default-language: Haskell2010
|
||||||
|
default-extensions: OverloadedStrings
|
||||||
|
build-depends: base >=4.9 && < 5
|
||||||
|
, affection
|
||||||
|
, sdl2 >= 2.5
|
||||||
|
, stm
|
||||||
|
, OpenGL
|
||||||
|
, random
|
||||||
|
, containers
|
||||||
|
, linear
|
||||||
|
, matrix
|
||||||
|
, nanovg >= 0.6.0.0
|
||||||
|
, deepseq
|
||||||
|
if !flag(examples)
|
||||||
|
buildable: False
|
18
extern/affection/affection.nix
vendored
Normal file
18
extern/affection/affection.nix
vendored
Normal file
|
@ -0,0 +1,18 @@
|
||||||
|
{ 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 = ./.;
|
||||||
|
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;
|
||||||
|
}
|
106
extern/affection/affection.svg
vendored
Normal file
106
extern/affection/affection.svg
vendored
Normal file
File diff suppressed because one or more lines are too long
After Width: | Height: | Size: 14 KiB |
4
extern/affection/cabal.project
vendored
Normal file
4
extern/affection/cabal.project
vendored
Normal file
|
@ -0,0 +1,4 @@
|
||||||
|
constraints: affection +verbose
|
||||||
|
profiling: true
|
||||||
|
packages:
|
||||||
|
./.
|
18
extern/affection/default.nix
vendored
Normal file
18
extern/affection/default.nix
vendored
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).
|
||||||
|
# ];
|
||||||
|
}
|
196
extern/affection/examples/example00/Main.hs
vendored
Normal file
196
extern/affection/examples/example00/Main.hs
vendored
Normal file
|
@ -0,0 +1,196 @@
|
||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
|
||||||
|
module Main where
|
||||||
|
|
||||||
|
import Affection as A
|
||||||
|
|
||||||
|
import Control.Concurrent.STM
|
||||||
|
import Control.Concurrent.MVar
|
||||||
|
import Control.Monad
|
||||||
|
|
||||||
|
import qualified SDL
|
||||||
|
|
||||||
|
import Data.Maybe (isJust, fromJust)
|
||||||
|
import Data.String
|
||||||
|
|
||||||
|
data StateData = StateData
|
||||||
|
{ sdSubs :: Subsystems
|
||||||
|
, sdJoys :: MVar [SDL.Joystick]
|
||||||
|
, doNextStep :: MVar Bool
|
||||||
|
}
|
||||||
|
|
||||||
|
instance Affectionate StateData where
|
||||||
|
loadState = load
|
||||||
|
preLoop = pre
|
||||||
|
handleEvents = handle
|
||||||
|
update = Main.update
|
||||||
|
draw = Main.draw
|
||||||
|
cleanUp = clean
|
||||||
|
hasNextStep = liftIO . readMVar . doNextStep
|
||||||
|
|
||||||
|
data Subsystems = Subsystems
|
||||||
|
{ subWindow :: Main.Window
|
||||||
|
, subMouse :: Main.Mouse
|
||||||
|
, subKeyboard :: Main.Keyboard
|
||||||
|
, subJoystick :: Main.Joystick
|
||||||
|
}
|
||||||
|
|
||||||
|
newtype Window = Window (TVar [(UUID, WindowMessage -> Affection ())])
|
||||||
|
newtype Mouse = Mouse (TVar [(UUID, MouseMessage -> Affection ())])
|
||||||
|
newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection ())])
|
||||||
|
newtype Joystick = Joystick (TVar [(UUID, JoystickMessage -> Affection ())])
|
||||||
|
|
||||||
|
instance Participant Main.Window where
|
||||||
|
type Mesg Main.Window = WindowMessage
|
||||||
|
|
||||||
|
partSubscribers (Window t) = generalSubscribers t
|
||||||
|
|
||||||
|
partSubscribe (Window t) = generalSubscribe t
|
||||||
|
|
||||||
|
partUnSubscribe (Window t) = generalUnSubscribe t
|
||||||
|
|
||||||
|
instance SDLSubsystem Main.Window where
|
||||||
|
consumeSDLEvents = consumeSDLWindowEvents
|
||||||
|
|
||||||
|
instance Participant Mouse where
|
||||||
|
type Mesg Mouse = MouseMessage
|
||||||
|
|
||||||
|
partSubscribers (Mouse t) = generalSubscribers t
|
||||||
|
|
||||||
|
partSubscribe (Mouse t) = generalSubscribe t
|
||||||
|
|
||||||
|
partUnSubscribe (Mouse t) = generalUnSubscribe t
|
||||||
|
|
||||||
|
instance SDLSubsystem Mouse where
|
||||||
|
consumeSDLEvents = consumeSDLMouseEvents
|
||||||
|
|
||||||
|
instance Participant Keyboard where
|
||||||
|
type Mesg Keyboard = KeyboardMessage
|
||||||
|
|
||||||
|
partSubscribers (Keyboard t) = generalSubscribers t
|
||||||
|
|
||||||
|
partSubscribe (Keyboard t) = generalSubscribe t
|
||||||
|
|
||||||
|
partUnSubscribe (Keyboard t) = generalUnSubscribe t
|
||||||
|
|
||||||
|
instance SDLSubsystem Keyboard where
|
||||||
|
consumeSDLEvents = consumeSDLKeyboardEvents
|
||||||
|
|
||||||
|
instance Participant Joystick where
|
||||||
|
type Mesg Joystick = JoystickMessage
|
||||||
|
|
||||||
|
partSubscribers (Joystick t) = generalSubscribers t
|
||||||
|
|
||||||
|
partSubscribe (Joystick t) = generalSubscribe t
|
||||||
|
|
||||||
|
partUnSubscribe (Joystick t) = generalUnSubscribe t
|
||||||
|
|
||||||
|
instance SDLSubsystem Joystick where
|
||||||
|
consumeSDLEvents = consumeSDLJoystickEvents
|
||||||
|
|
||||||
|
main :: IO ()
|
||||||
|
main = do
|
||||||
|
logIO Debug "Starting"
|
||||||
|
let conf = AffectionConfig
|
||||||
|
{ initComponents = All
|
||||||
|
, windowTitle = "affection: example00"
|
||||||
|
, windowConfigs =
|
||||||
|
[
|
||||||
|
( 0
|
||||||
|
, SDL.defaultWindow
|
||||||
|
{ SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL
|
||||||
|
{ SDL.glProfile = SDL.Core SDL.Normal 3 3
|
||||||
|
}
|
||||||
|
}
|
||||||
|
, SDL.Windowed
|
||||||
|
)
|
||||||
|
]
|
||||||
|
} :: AffectionConfig StateData
|
||||||
|
withAffection conf
|
||||||
|
|
||||||
|
load :: IO StateData
|
||||||
|
load =
|
||||||
|
StateData <$> (Subsystems
|
||||||
|
<$> (Window <$> newTVarIO [])
|
||||||
|
<*> (Mouse <$> newTVarIO [])
|
||||||
|
<*> (Keyboard <$> newTVarIO [])
|
||||||
|
<*> (Joystick <$> newTVarIO [])
|
||||||
|
)
|
||||||
|
<*> newMVar []
|
||||||
|
<*> newMVar True
|
||||||
|
|
||||||
|
pre :: StateData -> Affection ()
|
||||||
|
pre sd = do
|
||||||
|
_ <- partSubscribe (subKeyboard $ sdSubs sd) (exitOnQ (doNextStep sd))
|
||||||
|
_ <- partSubscribe (subWindow $ sdSubs sd) (exitOnWindowClose (doNextStep sd))
|
||||||
|
_ <- partSubscribe (subJoystick $ sdSubs sd) (joyConnectDisconnect (sdJoys sd))
|
||||||
|
return ()
|
||||||
|
|
||||||
|
exitOnQ :: MVar Bool -> KeyboardMessage -> Affection ()
|
||||||
|
exitOnQ nextStep (MsgKeyboardEvent _ _ _ _ sym) =
|
||||||
|
case SDL.keysymKeycode sym of
|
||||||
|
SDL.KeycodeQ -> do
|
||||||
|
liftIO $ logIO Debug "Yo dog I heard..."
|
||||||
|
void $ liftIO $ swapMVar nextStep False
|
||||||
|
_ -> return ()
|
||||||
|
|
||||||
|
exitOnWindowClose :: MVar Bool -> WindowMessage -> Affection ()
|
||||||
|
exitOnWindowClose nextStep wm =
|
||||||
|
case wm of
|
||||||
|
MsgWindowClose _ _ -> do
|
||||||
|
liftIO $ logIO Debug "I heard another one..."
|
||||||
|
void $ liftIO $ swapMVar nextStep False
|
||||||
|
_ -> return ()
|
||||||
|
|
||||||
|
joyConnectDisconnect :: MVar [SDL.Joystick] -> JoystickMessage -> Affection ()
|
||||||
|
joyConnectDisconnect mvjs msg = do
|
||||||
|
mj <- joystickAutoConnect msg
|
||||||
|
when (isJust mj) $ do
|
||||||
|
js <- liftIO $ readMVar mvjs
|
||||||
|
void $ liftIO $ swapMVar mvjs (fromJust mj : js)
|
||||||
|
js <- liftIO $ readMVar mvjs
|
||||||
|
njs <- joystickAutoDisconnect js msg
|
||||||
|
liftIO $ putMVar mvjs njs
|
||||||
|
|
||||||
|
handle :: StateData -> [SDL.EventPayload] -> Affection ()
|
||||||
|
handle sd es = do
|
||||||
|
let (Subsystems a b c d) = sdSubs sd
|
||||||
|
leftovers <- consumeSDLEvents a
|
||||||
|
=<< consumeSDLEvents b
|
||||||
|
=<< consumeSDLEvents c
|
||||||
|
=<< consumeSDLEvents d es
|
||||||
|
mapM_ (\e -> liftIO $ logIO Verbose $ "LEFTOVER: " <> fromString (show e))
|
||||||
|
leftovers
|
||||||
|
|
||||||
|
update :: StateData -> Double -> Affection ()
|
||||||
|
update _ _ = return ()
|
||||||
|
|
||||||
|
draw :: StateData -> Affection ()
|
||||||
|
draw _ = return ()
|
||||||
|
|
||||||
|
clean :: StateData -> IO ()
|
||||||
|
clean _ = return ()
|
||||||
|
|
||||||
|
generalSubscribers
|
||||||
|
:: TVar [(UUID, msg -> Affection ())]
|
||||||
|
-> Affection [msg -> Affection ()]
|
||||||
|
generalSubscribers t = do
|
||||||
|
subTups <- liftIO $ readTVarIO t
|
||||||
|
return $ map snd subTups
|
||||||
|
|
||||||
|
generalSubscribe
|
||||||
|
:: TVar [(UUID, msg -> Affection ())]
|
||||||
|
-> (msg -> Affection())
|
||||||
|
-> Affection UUID
|
||||||
|
generalSubscribe t funct = do
|
||||||
|
uuid <- genUUID
|
||||||
|
liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
|
||||||
|
return uuid
|
||||||
|
|
||||||
|
generalUnSubscribe
|
||||||
|
:: TVar [(UUID, msg -> Affection ())]
|
||||||
|
-> UUID
|
||||||
|
-> Affection ()
|
||||||
|
generalUnSubscribe t uuid =
|
||||||
|
liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid))
|
251
extern/affection/examples/example01/Main.hs
vendored
Normal file
251
extern/affection/examples/example01/Main.hs
vendored
Normal file
|
@ -0,0 +1,251 @@
|
||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
{-# LANGUAGE ForeignFunctionInterface #-}
|
||||||
|
|
||||||
|
import Affection as A
|
||||||
|
import qualified SDL
|
||||||
|
|
||||||
|
import Control.Concurrent.STM
|
||||||
|
import Control.Concurrent.MVar
|
||||||
|
import Control.Monad
|
||||||
|
import Control.DeepSeq (deepseq)
|
||||||
|
|
||||||
|
import Data.Matrix as M
|
||||||
|
import qualified Data.Set as S
|
||||||
|
import Data.String
|
||||||
|
|
||||||
|
import System.Random (randomRIO)
|
||||||
|
|
||||||
|
import NanoVG hiding (V2(..))
|
||||||
|
|
||||||
|
import Foreign.C.Types (CInt(..))
|
||||||
|
|
||||||
|
-- internal imports
|
||||||
|
|
||||||
|
import Types
|
||||||
|
|
||||||
|
instance Affectionate UserData where
|
||||||
|
loadState = load
|
||||||
|
preLoop = pre
|
||||||
|
handleEvents = handle
|
||||||
|
update = Main.update
|
||||||
|
draw = Main.draw
|
||||||
|
cleanUp = clean
|
||||||
|
hasNextStep = liftIO . readMVar . doNextStep
|
||||||
|
|
||||||
|
foreign import ccall unsafe "glewInit"
|
||||||
|
glewInit :: IO CInt
|
||||||
|
|
||||||
|
main :: IO ()
|
||||||
|
main = do
|
||||||
|
logIO A.Debug "Starting"
|
||||||
|
let conf = AffectionConfig
|
||||||
|
{ initComponents = All
|
||||||
|
, windowTitle = "affection: example01"
|
||||||
|
, windowConfigs =
|
||||||
|
[
|
||||||
|
( 0
|
||||||
|
, SDL.defaultWindow
|
||||||
|
{ SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL
|
||||||
|
{ SDL.glProfile = SDL.Core SDL.Normal 3 3
|
||||||
|
}
|
||||||
|
, SDL.windowInitialSize = SDL.V2 600 600
|
||||||
|
, SDL.windowResizable = True
|
||||||
|
}
|
||||||
|
, SDL.Windowed
|
||||||
|
)
|
||||||
|
]
|
||||||
|
} :: AffectionConfig UserData
|
||||||
|
withAffection conf
|
||||||
|
|
||||||
|
load :: IO UserData
|
||||||
|
load = do
|
||||||
|
-- emptyMatrix <- zero 60 60
|
||||||
|
liftIO $ logIO A.Debug "init GLEW"
|
||||||
|
_ <- glewInit
|
||||||
|
liftIO $ logIO A.Debug "making random"
|
||||||
|
randList <- mapM (\_ -> randomRIO (0,1)) [0 .. (3599 :: Int)]
|
||||||
|
liftIO $ logIO A.Debug "creating context"
|
||||||
|
nanoCtx <- createGL3 (S.fromList [Antialias, StencilStrokes, NanoVG.Debug])
|
||||||
|
let fullMatrix = fromList 60 60 randList
|
||||||
|
-- logIO A.Debug $ prettyMatrix fullMatrix
|
||||||
|
empty1 <- newTVarIO [] -- ([] :: [(UUID, WindowMessage -> Affection ())])
|
||||||
|
empty3 <- newTVarIO [] -- ([] :: [(UUID, KeyboardMessage -> Affection ())])
|
||||||
|
step <- newMVar True
|
||||||
|
(\life food time -> UserData
|
||||||
|
{ subsystems = Subsystems
|
||||||
|
(Window empty1)
|
||||||
|
(Keyboard empty3)
|
||||||
|
, lifeMat = life
|
||||||
|
, foodMat = food
|
||||||
|
, timeMat = time
|
||||||
|
, nano = nanoCtx
|
||||||
|
, doNextStep = step
|
||||||
|
}
|
||||||
|
)
|
||||||
|
<$> newMVar fullMatrix
|
||||||
|
<*> (newMVar (fromList 60 60 (repeat 10)))
|
||||||
|
<*> (newMVar (M.zero 60 60))
|
||||||
|
|
||||||
|
pre :: UserData -> Affection ()
|
||||||
|
pre ud = do
|
||||||
|
void $ partSubscribe (subKeyboard $ subsystems ud) (exitOnEsc (doNextStep ud))
|
||||||
|
void $ partSubscribe (subKeyboard $ subsystems ud) (reloadOnR ud)
|
||||||
|
void $ partSubscribe (subKeyboard $ subsystems ud) showFPS
|
||||||
|
void $ partSubscribe (subKeyboard $ subsystems ud) toggleFullScreen
|
||||||
|
void $ partSubscribe (subWindow $ subsystems ud) (exitOnWindowClose (doNextStep ud))
|
||||||
|
void $ partSubscribe (subWindow $ subsystems ud) (fitViewport (600/600))
|
||||||
|
|
||||||
|
toggleFullScreen :: KeyboardMessage -> Affection ()
|
||||||
|
toggleFullScreen (MsgKeyboardEvent _ _ SDL.Pressed False sym)
|
||||||
|
| SDL.keysymKeycode sym == SDL.KeycodeF11 = toggleScreen 0
|
||||||
|
| otherwise = return ()
|
||||||
|
toggleFullScreen _ = return ()
|
||||||
|
|
||||||
|
exitOnEsc :: MVar Bool -> KeyboardMessage -> Affection ()
|
||||||
|
exitOnEsc step (MsgKeyboardEvent _ _ SDL.Pressed False sym) =
|
||||||
|
case SDL.keysymKeycode sym of
|
||||||
|
SDL.KeycodeEscape -> do
|
||||||
|
liftIO $ logIO A.Debug "Yo dog I heard..."
|
||||||
|
void $ liftIO $ swapMVar step False
|
||||||
|
_ -> return ()
|
||||||
|
exitOnEsc _ _ = return ()
|
||||||
|
|
||||||
|
reloadOnR :: UserData -> KeyboardMessage -> Affection ()
|
||||||
|
reloadOnR ud (MsgKeyboardEvent _ _ _ _ sym) =
|
||||||
|
case SDL.keysymKeycode sym of
|
||||||
|
SDL.KeycodeR -> reload ud
|
||||||
|
_ -> return ()
|
||||||
|
|
||||||
|
reload :: UserData -> Affection ()
|
||||||
|
reload ud = do
|
||||||
|
randList <- liftIO $ mapM (\_ -> randomRIO (0,1)) [0 .. (3599 :: Int)]
|
||||||
|
let fullMatrix = fromList 60 60 randList
|
||||||
|
void $ liftIO $ swapMVar (lifeMat ud) fullMatrix
|
||||||
|
void $ liftIO $ swapMVar (foodMat ud) (fromList 60 60 (repeat 10))
|
||||||
|
void $ liftIO $ swapMVar (timeMat ud) (M.zero 60 60)
|
||||||
|
|
||||||
|
showFPS :: KeyboardMessage -> Affection ()
|
||||||
|
showFPS (MsgKeyboardEvent _ _ _ _ sym) =
|
||||||
|
case SDL.keysymKeycode sym of
|
||||||
|
SDL.KeycodeF -> do
|
||||||
|
dt <- getDelta
|
||||||
|
liftIO $ logIO A.Debug $ "FPS: " <> fromString (show (1 / dt))
|
||||||
|
_ -> return ()
|
||||||
|
|
||||||
|
exitOnWindowClose :: MVar Bool -> WindowMessage -> Affection ()
|
||||||
|
exitOnWindowClose step wm =
|
||||||
|
case wm of
|
||||||
|
MsgWindowClose _ _ -> do
|
||||||
|
liftIO $ logIO A.Debug "I heard another one..."
|
||||||
|
void $ liftIO $ swapMVar step False
|
||||||
|
_ -> return ()
|
||||||
|
|
||||||
|
handle :: UserData -> [SDL.EventPayload] -> Affection ()
|
||||||
|
handle ud es = do
|
||||||
|
let (Subsystems a b) = subsystems ud
|
||||||
|
_ <- consumeSDLEvents a =<< consumeSDLEvents b es
|
||||||
|
return ()
|
||||||
|
|
||||||
|
update :: UserData -> Double -> Affection ()
|
||||||
|
update ud _ = do
|
||||||
|
-- liftIO $ logIO A.Debug ("FPS: " <> fromString (show (1/dt)))
|
||||||
|
pastLife <- liftIO $ readMVar (lifeMat ud)
|
||||||
|
pastFood <- liftIO $ readMVar (foodMat ud)
|
||||||
|
pastTime <- liftIO $ readMVar (timeMat ud)
|
||||||
|
newList <- mapM (\coord -> do
|
||||||
|
let x = (coord `mod` 60) + 1
|
||||||
|
y = (coord `div` 60) + 1
|
||||||
|
subm
|
||||||
|
| x == 1 && y == 1 =
|
||||||
|
(submatrix 60 60 60 60 pastLife <|> submatrix 60 60 1 2 pastLife)
|
||||||
|
<->
|
||||||
|
(submatrix 1 2 60 60 pastLife <|> submatrix 1 2 1 2 pastLife)
|
||||||
|
| x == 1 && y == 60 =
|
||||||
|
(submatrix 59 60 60 60 pastLife <|> submatrix 59 60 1 2 pastLife)
|
||||||
|
<->
|
||||||
|
(submatrix 1 1 60 60 pastLife <|> submatrix 1 1 1 2 pastLife)
|
||||||
|
| x == 60 && y == 1 =
|
||||||
|
(submatrix 60 60 59 60 pastLife <|> submatrix 60 60 1 1 pastLife)
|
||||||
|
<->
|
||||||
|
(submatrix 1 2 59 60 pastLife <|> submatrix 1 2 1 1 pastLife)
|
||||||
|
| x == 60 && y == 60 =
|
||||||
|
(submatrix 59 60 59 60 pastLife <|> submatrix 59 60 1 1 pastLife)
|
||||||
|
<->
|
||||||
|
(submatrix 1 1 59 60 pastLife <|> submatrix 1 1 1 1 pastLife)
|
||||||
|
| x == 1 =
|
||||||
|
(submatrix (y - 1) (y + 1) 60 60 pastLife)
|
||||||
|
<|>
|
||||||
|
(submatrix (y - 1) (y + 1) 1 2 pastLife)
|
||||||
|
| y == 1 =
|
||||||
|
(submatrix 60 60 (x - 1) (x + 1) pastLife)
|
||||||
|
<->
|
||||||
|
(submatrix 1 2 (x - 1) (x + 1) pastLife)
|
||||||
|
| x == 60 =
|
||||||
|
(submatrix (y - 1) (y + 1) 59 60 pastLife)
|
||||||
|
<|>
|
||||||
|
(submatrix (y - 1) (y + 1) 1 1 pastLife)
|
||||||
|
| y == 60 =
|
||||||
|
(submatrix 59 60 (x -1 ) (x + 1) pastLife)
|
||||||
|
<->
|
||||||
|
(submatrix 1 1 (x - 1) (x + 1) pastLife)
|
||||||
|
| otherwise =
|
||||||
|
(submatrix (y - 1) (y + 1) (x - 1) (x + 1) pastLife)
|
||||||
|
life = countLife subm
|
||||||
|
if pastLife M.! (y, x) == 1
|
||||||
|
then if (life == 2 || life == 3) && pastFood M.! (y, x) > 0
|
||||||
|
then return (1, (pastFood M.! (y, x)) - 1, 0)
|
||||||
|
else return (0, pastFood M.! (y, x), 0)
|
||||||
|
else if life == 3 && pastFood M.! (y, x) > 0
|
||||||
|
then return (1, (pastFood M.! (y, x)) - 1, 0)
|
||||||
|
else return
|
||||||
|
( (0 :: Word)
|
||||||
|
, if pastTime M.! (y, x) > 10
|
||||||
|
then min 10 ((pastFood M.! (y, x)) + 1)
|
||||||
|
else min 10 (pastFood M.! (y, x))
|
||||||
|
, pastTime M.! (y, x) + 1
|
||||||
|
)
|
||||||
|
) [0..3599]
|
||||||
|
let newLifeMat = fromList 60 60 (map (\(x, _, _) -> x) newList)
|
||||||
|
newFoodMat = fromList 60 60 (map (\(_, x, _) -> x) newList)
|
||||||
|
newTimeMat = fromList 60 60 (map (\(_, _, x) -> x) newList)
|
||||||
|
if newLifeMat == M.zero 60 60
|
||||||
|
then
|
||||||
|
reload ud
|
||||||
|
else do
|
||||||
|
((newLifeMat, newFoodMat, newTimeMat) `deepseq` return ())
|
||||||
|
void $ liftIO $ swapMVar (lifeMat ud) newLifeMat
|
||||||
|
void $ liftIO $ swapMVar (timeMat ud) newTimeMat
|
||||||
|
|
||||||
|
countLife :: Matrix Word -> Word
|
||||||
|
countLife mat = res - (mat M.! (2, 2))
|
||||||
|
where
|
||||||
|
res = foldr (flip (+)) 0 mat
|
||||||
|
|
||||||
|
draw :: UserData -> Affection ()
|
||||||
|
draw ud = do
|
||||||
|
life <- liftIO $ readMVar (lifeMat ud)
|
||||||
|
food <- liftIO $ readMVar (foodMat ud)
|
||||||
|
liftIO $ do
|
||||||
|
beginFrame (nano ud) 600 600 1
|
||||||
|
save (nano ud)
|
||||||
|
mapM_ (\coord -> do
|
||||||
|
let x = coord `mod` 60
|
||||||
|
y = coord `div` 60
|
||||||
|
ctx = nano ud
|
||||||
|
mult = life M.! (x + 1, y + 1)
|
||||||
|
-- logIO A.Debug $ show mult
|
||||||
|
beginPath ctx
|
||||||
|
rect ctx (fromIntegral $ x * 10) (fromIntegral $ y * 10) 10 10
|
||||||
|
if mult == 1
|
||||||
|
then
|
||||||
|
fillColor ctx (rgba 255 255 255 255)
|
||||||
|
else
|
||||||
|
fillColor ctx (rgba 0 (fromIntegral $ 25 * (food M.! (x+1, y+1))) 0 255)
|
||||||
|
fill ctx
|
||||||
|
) [0..3599]
|
||||||
|
restore (nano ud)
|
||||||
|
endFrame (nano ud)
|
||||||
|
|
||||||
|
clean :: UserData -> IO ()
|
||||||
|
clean _ = return ()
|
78
extern/affection/examples/example01/Types.hs
vendored
Normal file
78
extern/affection/examples/example01/Types.hs
vendored
Normal file
|
@ -0,0 +1,78 @@
|
||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
|
||||||
|
module Types where
|
||||||
|
|
||||||
|
import Affection
|
||||||
|
|
||||||
|
import Data.Matrix as M
|
||||||
|
|
||||||
|
import NanoVG
|
||||||
|
|
||||||
|
import Control.Concurrent.STM
|
||||||
|
import Control.Concurrent.MVar
|
||||||
|
|
||||||
|
data UserData = UserData
|
||||||
|
{ lifeMat :: MVar (Matrix Word)
|
||||||
|
, foodMat :: MVar (Matrix Word)
|
||||||
|
, timeMat :: MVar (Matrix Word)
|
||||||
|
, subsystems :: Subsystems
|
||||||
|
, nano :: Context
|
||||||
|
, doNextStep :: MVar Bool
|
||||||
|
}
|
||||||
|
|
||||||
|
data Subsystems = Subsystems
|
||||||
|
{ subWindow :: Types.Window
|
||||||
|
, subKeyboard :: Types.Keyboard
|
||||||
|
}
|
||||||
|
|
||||||
|
newtype Window = Window (TVar [(UUID, WindowMessage -> Affection ())])
|
||||||
|
|
||||||
|
newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection ())])
|
||||||
|
|
||||||
|
instance Participant Types.Window where
|
||||||
|
type Mesg Types.Window = WindowMessage
|
||||||
|
|
||||||
|
partSubscribers (Window t) = do
|
||||||
|
subTups <- liftIO $ readTVarIO t
|
||||||
|
return $ map snd subTups
|
||||||
|
|
||||||
|
partSubscribe (Window t) = generalSubscribe t
|
||||||
|
|
||||||
|
partUnSubscribe (Window t) = generalUnSubscribe t
|
||||||
|
|
||||||
|
instance SDLSubsystem Types.Window where
|
||||||
|
consumeSDLEvents = consumeSDLWindowEvents
|
||||||
|
|
||||||
|
instance Participant Keyboard where
|
||||||
|
type Mesg Keyboard = KeyboardMessage
|
||||||
|
|
||||||
|
partSubscribers (Keyboard t) = do
|
||||||
|
subTups <- liftIO $ readTVarIO t
|
||||||
|
return $ map snd subTups
|
||||||
|
|
||||||
|
partSubscribe (Keyboard t) = generalSubscribe t
|
||||||
|
|
||||||
|
partUnSubscribe (Keyboard t) = generalUnSubscribe t
|
||||||
|
|
||||||
|
instance SDLSubsystem Keyboard where
|
||||||
|
consumeSDLEvents = consumeSDLKeyboardEvents
|
||||||
|
|
||||||
|
generalSubscribe
|
||||||
|
:: TVar [(UUID, msg -> Affection ())]
|
||||||
|
-> (msg -> Affection ())
|
||||||
|
-> Affection UUID
|
||||||
|
generalSubscribe t funct = do
|
||||||
|
uuid <- genUUID
|
||||||
|
liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
|
||||||
|
return uuid
|
||||||
|
|
||||||
|
generalUnSubscribe
|
||||||
|
:: TVar [(UUID, msg -> Affection ())]
|
||||||
|
-> UUID
|
||||||
|
-> Affection ()
|
||||||
|
generalUnSubscribe t uuid =
|
||||||
|
liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uuid))
|
||||||
|
where
|
||||||
|
filterMsg :: (UUID, msg -> Affection ()) -> UUID -> Bool
|
||||||
|
filterMsg (u, _) p = u /= p
|
253
extern/affection/examples/example02/Main.hs
vendored
Normal file
253
extern/affection/examples/example02/Main.hs
vendored
Normal file
|
@ -0,0 +1,253 @@
|
||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
{-# LANGUAGE ForeignFunctionInterface #-}
|
||||||
|
|
||||||
|
import Affection as A
|
||||||
|
import qualified SDL
|
||||||
|
|
||||||
|
import Control.Concurrent.STM
|
||||||
|
import Control.Concurrent.MVar
|
||||||
|
import Control.Monad
|
||||||
|
import Control.DeepSeq (deepseq)
|
||||||
|
|
||||||
|
import Data.Matrix as M
|
||||||
|
import qualified Data.Set as S
|
||||||
|
import Data.String
|
||||||
|
|
||||||
|
import System.Random (randomRIO)
|
||||||
|
|
||||||
|
import NanoVG hiding (V2(..))
|
||||||
|
|
||||||
|
import Foreign.C.Types (CInt(..))
|
||||||
|
|
||||||
|
-- internal imports
|
||||||
|
|
||||||
|
import Types
|
||||||
|
|
||||||
|
instance Affectionate UserData where
|
||||||
|
loadState = load
|
||||||
|
preLoop = pre
|
||||||
|
handleEvents = handle
|
||||||
|
update = Main.update
|
||||||
|
draw = Main.draw
|
||||||
|
cleanUp = clean
|
||||||
|
hasNextStep = liftIO . readMVar . doNextStep
|
||||||
|
|
||||||
|
foreign import ccall unsafe "glewInit"
|
||||||
|
glewInit :: IO CInt
|
||||||
|
|
||||||
|
maxFood :: Word
|
||||||
|
maxFood = 255
|
||||||
|
|
||||||
|
main :: IO ()
|
||||||
|
main = do
|
||||||
|
logIO A.Debug "Starting"
|
||||||
|
let conf = AffectionConfig
|
||||||
|
{ initComponents = All
|
||||||
|
, windowTitle = "affection: example01"
|
||||||
|
, windowConfigs =
|
||||||
|
[
|
||||||
|
( 0
|
||||||
|
, SDL.defaultWindow
|
||||||
|
{ SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL
|
||||||
|
{ SDL.glProfile = SDL.Core SDL.Normal 3 3
|
||||||
|
}
|
||||||
|
, SDL.windowInitialSize = SDL.V2 600 600
|
||||||
|
, SDL.windowResizable = True
|
||||||
|
}
|
||||||
|
, SDL.Windowed
|
||||||
|
)
|
||||||
|
]
|
||||||
|
} :: AffectionConfig UserData
|
||||||
|
withAffection conf
|
||||||
|
|
||||||
|
load :: IO UserData
|
||||||
|
load = do
|
||||||
|
-- emptyMatrix <- zero 60 60
|
||||||
|
liftIO $ logIO A.Debug "init GLEW"
|
||||||
|
_ <- glewInit
|
||||||
|
liftIO $ logIO A.Debug "making random"
|
||||||
|
randList <- mapM (\_ -> randomRIO (0,1)) [0 .. (3599 :: Int)]
|
||||||
|
liftIO $ logIO A.Debug "creating context"
|
||||||
|
nanoCtx <- createGL3 (S.fromList [Antialias, StencilStrokes, NanoVG.Debug])
|
||||||
|
let fullMatrix = fromList 60 60 randList
|
||||||
|
-- logIO A.Debug $ prettyMatrix fullMatrix
|
||||||
|
empty1 <- newTVarIO [] -- ([] :: [(UUID, WindowMessage -> Affection ())])
|
||||||
|
empty3 <- newTVarIO [] -- ([] :: [(UUID, KeyboardMessage -> Affection ())])
|
||||||
|
(\life food time nextStep -> UserData
|
||||||
|
{ subsystems = Subsystems
|
||||||
|
(Window empty1)
|
||||||
|
(Keyboard empty3)
|
||||||
|
, lifeMat = life
|
||||||
|
, foodMat = food
|
||||||
|
, timeMat = time
|
||||||
|
, nano = nanoCtx
|
||||||
|
, doNextStep = nextStep
|
||||||
|
}
|
||||||
|
)
|
||||||
|
<$> newMVar fullMatrix
|
||||||
|
<*> newMVar (fromList 60 60 (repeat maxFood))
|
||||||
|
<*> newMVar (M.zero 60 60)
|
||||||
|
<*> newMVar True
|
||||||
|
|
||||||
|
pre :: UserData -> Affection ()
|
||||||
|
pre ud = do
|
||||||
|
void $ partSubscribe (subKeyboard $ subsystems ud) (exitOnEsc (doNextStep ud))
|
||||||
|
void $ partSubscribe (subKeyboard $ subsystems ud) (reloadOnR ud)
|
||||||
|
void $ partSubscribe (subKeyboard $ subsystems ud) showFPS
|
||||||
|
void $ partSubscribe (subKeyboard $ subsystems ud) toggleFullScreen
|
||||||
|
void $ partSubscribe (subWindow $ subsystems ud) (exitOnWindowClose (doNextStep ud))
|
||||||
|
void $ partSubscribe (subWindow $ subsystems ud) (fitViewport (600/600))
|
||||||
|
|
||||||
|
toggleFullScreen :: KeyboardMessage -> Affection ()
|
||||||
|
toggleFullScreen (MsgKeyboardEvent _ _ SDL.Pressed False sym)
|
||||||
|
| SDL.keysymKeycode sym == SDL.KeycodeF11 = toggleScreen 0
|
||||||
|
| otherwise = return ()
|
||||||
|
toggleFullScreen _ = return ()
|
||||||
|
|
||||||
|
exitOnEsc :: MVar Bool -> KeyboardMessage -> Affection ()
|
||||||
|
exitOnEsc step (MsgKeyboardEvent _ _ SDL.Pressed False sym) =
|
||||||
|
case SDL.keysymKeycode sym of
|
||||||
|
SDL.KeycodeEscape -> do
|
||||||
|
liftIO $ logIO A.Debug "Yo dog I heard..."
|
||||||
|
void $ liftIO $ swapMVar step False
|
||||||
|
_ -> return ()
|
||||||
|
exitOnEsc _ _ = return ()
|
||||||
|
|
||||||
|
reloadOnR :: UserData -> KeyboardMessage -> Affection ()
|
||||||
|
reloadOnR ud (MsgKeyboardEvent _ _ _ _ sym) =
|
||||||
|
case SDL.keysymKeycode sym of
|
||||||
|
SDL.KeycodeR -> reload ud
|
||||||
|
_ -> return ()
|
||||||
|
|
||||||
|
reload :: UserData -> Affection ()
|
||||||
|
reload ud = do
|
||||||
|
randList <- liftIO $ mapM (\_ -> randomRIO (0,1)) [0 .. (3599 :: Int)]
|
||||||
|
let fullMatrix = fromList 60 60 randList
|
||||||
|
void $ liftIO $ swapMVar (lifeMat ud) fullMatrix
|
||||||
|
void $ liftIO $ swapMVar (foodMat ud) (fromList 60 60 (repeat maxFood))
|
||||||
|
void $ liftIO $ swapMVar (timeMat ud) (M.zero 60 60)
|
||||||
|
|
||||||
|
showFPS :: KeyboardMessage -> Affection ()
|
||||||
|
showFPS (MsgKeyboardEvent _ _ _ _ sym) =
|
||||||
|
case SDL.keysymKeycode sym of
|
||||||
|
SDL.KeycodeF -> do
|
||||||
|
dt <- getDelta
|
||||||
|
liftIO $ logIO A.Debug $ "FPS: " <> fromString (show (1 / dt))
|
||||||
|
_ -> return ()
|
||||||
|
|
||||||
|
exitOnWindowClose :: MVar Bool -> WindowMessage -> Affection ()
|
||||||
|
exitOnWindowClose step wm =
|
||||||
|
case wm of
|
||||||
|
MsgWindowClose _ _ -> do
|
||||||
|
liftIO $ logIO A.Debug "I heard another one..."
|
||||||
|
void $ liftIO $ swapMVar step False
|
||||||
|
_ -> return ()
|
||||||
|
|
||||||
|
handle :: UserData -> [SDL.EventPayload] -> Affection ()
|
||||||
|
handle ud es = do
|
||||||
|
let (Subsystems a b) = subsystems ud
|
||||||
|
_ <- consumeSDLEvents a =<< consumeSDLEvents b es
|
||||||
|
return ()
|
||||||
|
|
||||||
|
update :: UserData -> Double -> Affection ()
|
||||||
|
update ud _ = do
|
||||||
|
pastLife <- liftIO $ readMVar (lifeMat ud)
|
||||||
|
pastFood <- liftIO $ readMVar (foodMat ud)
|
||||||
|
pastTime <- liftIO $ readMVar (timeMat ud)
|
||||||
|
newList <- mapM (\coord -> do
|
||||||
|
let x = (coord `mod` 60) + 1
|
||||||
|
y = (coord `div` 60) + 1
|
||||||
|
subm
|
||||||
|
| x == 1 && y == 1 =
|
||||||
|
(submatrix 60 60 60 60 pastLife <|> submatrix 60 60 1 2 pastLife)
|
||||||
|
<->
|
||||||
|
(submatrix 1 2 60 60 pastLife <|> submatrix 1 2 1 2 pastLife)
|
||||||
|
| x == 1 && y == 60 =
|
||||||
|
(submatrix 59 60 60 60 pastLife <|> submatrix 59 60 1 2 pastLife)
|
||||||
|
<->
|
||||||
|
(submatrix 1 1 60 60 pastLife <|> submatrix 1 1 1 2 pastLife)
|
||||||
|
| x == 60 && y == 1 =
|
||||||
|
(submatrix 60 60 59 60 pastLife <|> submatrix 60 60 1 1 pastLife)
|
||||||
|
<->
|
||||||
|
(submatrix 1 2 59 60 pastLife <|> submatrix 1 2 1 1 pastLife)
|
||||||
|
| x == 60 && y == 60 =
|
||||||
|
(submatrix 59 60 59 60 pastLife <|> submatrix 59 60 1 1 pastLife)
|
||||||
|
<->
|
||||||
|
(submatrix 1 1 59 60 pastLife <|> submatrix 1 1 1 1 pastLife)
|
||||||
|
| x == 1 =
|
||||||
|
(submatrix (y - 1) (y + 1) 60 60 pastLife)
|
||||||
|
<|>
|
||||||
|
(submatrix (y - 1) (y + 1) 1 2 pastLife)
|
||||||
|
| y == 1 =
|
||||||
|
(submatrix 60 60 (x - 1) (x + 1) pastLife)
|
||||||
|
<->
|
||||||
|
(submatrix 1 2 (x - 1) (x + 1) pastLife)
|
||||||
|
| x == 60 =
|
||||||
|
(submatrix (y - 1) (y + 1) 59 60 pastLife)
|
||||||
|
<|>
|
||||||
|
(submatrix (y - 1) (y + 1) 1 1 pastLife)
|
||||||
|
| y == 60 =
|
||||||
|
(submatrix 59 60 (x -1 ) (x + 1) pastLife)
|
||||||
|
<->
|
||||||
|
(submatrix 1 1 (x - 1) (x + 1) pastLife)
|
||||||
|
| otherwise =
|
||||||
|
(submatrix (y - 1) (y + 1) (x - 1) (x + 1) pastLife)
|
||||||
|
life = countLife subm
|
||||||
|
if pastLife M.! (y, x) == 1
|
||||||
|
then if (life == 2 || life == 3) && pastFood M.! (y, x) > 0
|
||||||
|
then return (1, (pastFood M.! (y, x)) - 1, 0)
|
||||||
|
else return (0, pastFood M.! (y, x), 0)
|
||||||
|
else if life == 3 && pastFood M.! (y, x) > 0
|
||||||
|
then return (1, (pastFood M.! (y, x)) - 1, 0)
|
||||||
|
else return
|
||||||
|
( 0 :: Word
|
||||||
|
, if pastTime M.! (y, x) > 10
|
||||||
|
then min maxFood ((pastFood M.! (y, x)) + 1)
|
||||||
|
else min maxFood (pastFood M.! (y, x))
|
||||||
|
, pastTime M.! (y, x) + 1
|
||||||
|
)
|
||||||
|
) [0..3599]
|
||||||
|
let newLifeMat = fromList 60 60 (map (\(x, _, _) -> x) newList)
|
||||||
|
newFoodMat = fromList 60 60 (map (\(_, x, _) -> x) newList)
|
||||||
|
newTimeMat = fromList 60 60 (map (\(_, _, x) -> x) newList)
|
||||||
|
if newLifeMat == M.zero 60 60
|
||||||
|
then
|
||||||
|
reload ud
|
||||||
|
else do
|
||||||
|
((newLifeMat, newFoodMat, newTimeMat) `deepseq` return ())
|
||||||
|
void $ liftIO $ swapMVar (lifeMat ud) newLifeMat
|
||||||
|
void $ liftIO $ swapMVar (timeMat ud) newTimeMat
|
||||||
|
void $ liftIO $ swapMVar (foodMat ud) newFoodMat
|
||||||
|
|
||||||
|
countLife :: Matrix Word -> Word
|
||||||
|
countLife mat = res - (mat M.! (2, 2))
|
||||||
|
where
|
||||||
|
res = foldr (flip (+)) 0 mat
|
||||||
|
|
||||||
|
draw :: UserData -> Affection ()
|
||||||
|
draw ud = liftIO $ do
|
||||||
|
pastLife <- readMVar (lifeMat ud)
|
||||||
|
pastFood <- readMVar (foodMat ud)
|
||||||
|
beginFrame (nano ud) 600 600 1
|
||||||
|
save (nano ud)
|
||||||
|
mapM_ (\coord -> do
|
||||||
|
let x = coord `mod` 60
|
||||||
|
y = coord `div` 60
|
||||||
|
ctx = nano ud
|
||||||
|
multiplicator = pastLife M.! (x + 1, y + 1)
|
||||||
|
-- logIO A.Debug $ show mult
|
||||||
|
beginPath ctx
|
||||||
|
rect ctx (fromIntegral $ x * 10) (fromIntegral $ y * 10) 10 10
|
||||||
|
if multiplicator == 1
|
||||||
|
then
|
||||||
|
fillColor ctx (rgba 255 255 255 255)
|
||||||
|
else
|
||||||
|
fillColor ctx (rgba 0 (fromIntegral $ (255 `div` maxFood) * (pastFood M.! (x+1, y+1))) 0 255)
|
||||||
|
fill ctx
|
||||||
|
) [0..3599]
|
||||||
|
restore (nano ud)
|
||||||
|
endFrame (nano ud)
|
||||||
|
|
||||||
|
clean :: UserData -> IO ()
|
||||||
|
clean _ = return ()
|
78
extern/affection/examples/example02/Types.hs
vendored
Normal file
78
extern/affection/examples/example02/Types.hs
vendored
Normal file
|
@ -0,0 +1,78 @@
|
||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
|
||||||
|
module Types where
|
||||||
|
|
||||||
|
import Affection
|
||||||
|
|
||||||
|
import Data.Matrix as M
|
||||||
|
|
||||||
|
import NanoVG
|
||||||
|
|
||||||
|
import Control.Concurrent.STM
|
||||||
|
import Control.Concurrent.MVar
|
||||||
|
|
||||||
|
data UserData = UserData
|
||||||
|
{ lifeMat :: MVar (Matrix Word)
|
||||||
|
, foodMat :: MVar (Matrix Word)
|
||||||
|
, timeMat :: MVar (Matrix Word)
|
||||||
|
, subsystems :: Subsystems
|
||||||
|
, nano :: Context
|
||||||
|
, doNextStep :: MVar Bool
|
||||||
|
}
|
||||||
|
|
||||||
|
data Subsystems = Subsystems
|
||||||
|
{ subWindow :: Types.Window
|
||||||
|
, subKeyboard :: Types.Keyboard
|
||||||
|
}
|
||||||
|
|
||||||
|
newtype Window = Window (TVar [(UUID, WindowMessage -> Affection ())])
|
||||||
|
|
||||||
|
newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection ())])
|
||||||
|
|
||||||
|
instance Participant Types.Window where
|
||||||
|
type Mesg Types.Window = WindowMessage
|
||||||
|
|
||||||
|
partSubscribers (Window t) = do
|
||||||
|
subTups <- liftIO $ readTVarIO t
|
||||||
|
return $ map snd subTups
|
||||||
|
|
||||||
|
partSubscribe (Window t) = generalSubscribe t
|
||||||
|
|
||||||
|
partUnSubscribe (Window t) = generalUnSubscribe t
|
||||||
|
|
||||||
|
instance SDLSubsystem Types.Window where
|
||||||
|
consumeSDLEvents = consumeSDLWindowEvents
|
||||||
|
|
||||||
|
instance Participant Keyboard where
|
||||||
|
type Mesg Keyboard = KeyboardMessage
|
||||||
|
|
||||||
|
partSubscribers (Keyboard t) = do
|
||||||
|
subTups <- liftIO $ readTVarIO t
|
||||||
|
return $ map snd subTups
|
||||||
|
|
||||||
|
partSubscribe (Keyboard t) = generalSubscribe t
|
||||||
|
|
||||||
|
partUnSubscribe (Keyboard t) = generalUnSubscribe t
|
||||||
|
|
||||||
|
instance SDLSubsystem Keyboard where
|
||||||
|
consumeSDLEvents = consumeSDLKeyboardEvents
|
||||||
|
|
||||||
|
generalSubscribe
|
||||||
|
:: TVar [(UUID, msg -> Affection ())]
|
||||||
|
-> (msg -> Affection ())
|
||||||
|
-> Affection UUID
|
||||||
|
generalSubscribe t funct = do
|
||||||
|
uuid <- genUUID
|
||||||
|
liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
|
||||||
|
return uuid
|
||||||
|
|
||||||
|
generalUnSubscribe
|
||||||
|
:: TVar [(UUID, msg -> Affection ())]
|
||||||
|
-> UUID
|
||||||
|
-> Affection ()
|
||||||
|
generalUnSubscribe t uuid =
|
||||||
|
liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uuid))
|
||||||
|
where
|
||||||
|
filterMsg :: (UUID, msg -> Affection ()) -> UUID -> Bool
|
||||||
|
filterMsg (u, _) p = u /= p
|
7
extern/affection/shell.nix
vendored
Normal file
7
extern/affection/shell.nix
vendored
Normal file
|
@ -0,0 +1,7 @@
|
||||||
|
{ pkgs ? import <nixpkgs> {}}:
|
||||||
|
|
||||||
|
let
|
||||||
|
affection = pkgs.haskellPackages.callCabal2nix "affection" (gitignore ./.) {};
|
||||||
|
gitignore = dir: pkgs.nix-gitignore.gitignoreSource [] dir;
|
||||||
|
in
|
||||||
|
affection.env
|
204
extern/affection/src/Affection.hs
vendored
Normal file
204
extern/affection/src/Affection.hs
vendored
Normal file
|
@ -0,0 +1,204 @@
|
||||||
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
|
{-# LANGUAGE Strict #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
{-# LANGUAGE RankNTypes #-}
|
||||||
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
module Affection
|
||||||
|
( withAffection
|
||||||
|
, get
|
||||||
|
, put
|
||||||
|
, liftIO
|
||||||
|
, module A
|
||||||
|
) where
|
||||||
|
|
||||||
|
import SDL (($=))
|
||||||
|
import qualified SDL
|
||||||
|
import qualified SDL.Raw.Video as SDL (glSetAttribute)
|
||||||
|
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 Control.Monad.Loops
|
||||||
|
import Control.Monad.State.Strict
|
||||||
|
import Control.Monad.Trans.Resource
|
||||||
|
|
||||||
|
-- internal imports
|
||||||
|
|
||||||
|
-- internal imports
|
||||||
|
|
||||||
|
import Affection.Types as A
|
||||||
|
import Affection.Class as A
|
||||||
|
import Affection.StateMachine as A
|
||||||
|
import Affection.Util as A
|
||||||
|
import Affection.MessageBus as A
|
||||||
|
import Affection.Subsystems as A
|
||||||
|
|
||||||
|
import Affection.Logging as A
|
||||||
|
|
||||||
|
-- | Main function which bootstraps everything else.
|
||||||
|
withAffection
|
||||||
|
:: forall us. (Affectionate us)
|
||||||
|
=> AffectionConfig us -- ^ Configuration of the Game and its engine.
|
||||||
|
-> IO ()
|
||||||
|
withAffection AffectionConfig{..} = runResourceT $ do
|
||||||
|
liftIO $ logIO Debug "Affection starting"
|
||||||
|
liftIO $ logIO Debug "Initializing SDL"
|
||||||
|
|
||||||
|
-- intialiaze SDL
|
||||||
|
case initComponents of
|
||||||
|
All ->
|
||||||
|
SDL.initializeAll
|
||||||
|
Only is ->
|
||||||
|
SDL.initialize is
|
||||||
|
|
||||||
|
-- give SDL render quality
|
||||||
|
SDL.HintRenderScaleQuality SDL.$= SDL.ScaleLinear
|
||||||
|
|
||||||
|
-- just checking…
|
||||||
|
renderQuality <- SDL.get SDL.HintRenderScaleQuality
|
||||||
|
when (renderQuality /= SDL.ScaleLinear) $
|
||||||
|
liftIO $ logIO Warn "Linear texture filtering not enabled!"
|
||||||
|
void $ liftIO (logIO Debug . fromString . show <$> (SDL.version :: IO (Integer, Integer, Integer)))
|
||||||
|
|
||||||
|
-- construct window
|
||||||
|
liftIO $ logIO Debug "Creating Window(s)"
|
||||||
|
windows <-
|
||||||
|
mapM
|
||||||
|
(\(_, sdlWindowConfig, mode) -> do
|
||||||
|
(windowKey, window) <-
|
||||||
|
allocate
|
||||||
|
(SDL.createWindow windowTitle sdlWindowConfig)
|
||||||
|
(\window -> do
|
||||||
|
logIO Debug "Destroying Window"
|
||||||
|
SDL.destroyWindow window
|
||||||
|
)
|
||||||
|
return $ AffectionWindow window windowKey mode
|
||||||
|
)
|
||||||
|
windowConfigs
|
||||||
|
|
||||||
|
-- Show windows
|
||||||
|
mapM_ (SDL.showWindow . awWindow) windows
|
||||||
|
|
||||||
|
-- set modes of windows
|
||||||
|
mapM_ (\(AffectionWindow window _ mode) -> SDL.setWindowMode window mode) 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
|
||||||
|
|
||||||
|
-- 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"
|
||||||
|
execTime <- liftIO $ getTime Monotonic
|
||||||
|
liftIO $ logIO Debug "Loading initial data container"
|
||||||
|
|
||||||
|
-- construct game data object from provided Affectionate instance
|
||||||
|
(gameDataKey, gameData) <-
|
||||||
|
allocate
|
||||||
|
(liftIO $ loadState @us)
|
||||||
|
(liftIO . cleanUp)
|
||||||
|
-- build state container
|
||||||
|
let initContainer = AffectionData
|
||||||
|
{ drawWindows = windows
|
||||||
|
, glContext = contexts
|
||||||
|
, elapsedTime = 0
|
||||||
|
, deltaTime = 0
|
||||||
|
, sysTime = execTime
|
||||||
|
, pausedTime = False
|
||||||
|
}
|
||||||
|
|
||||||
|
-- initialize and run state
|
||||||
|
void $ liftIO $ runAffection initContainer
|
||||||
|
(do
|
||||||
|
liftIO $ logIO Debug "Running Pre-Loop stage"
|
||||||
|
-- run preLoop function from Affectionate
|
||||||
|
preLoop gameData
|
||||||
|
liftIO $ logIO Debug "Starting Loop"
|
||||||
|
whileM_ (hasNextStep gameData)
|
||||||
|
(do
|
||||||
|
-- get state
|
||||||
|
ad <- get
|
||||||
|
|
||||||
|
-- Measure time difference form last run
|
||||||
|
now <- liftIO $ getTime Monotonic
|
||||||
|
let lastTime = sysTime ad
|
||||||
|
|
||||||
|
-- compute dt and update elapsedTime
|
||||||
|
let dt = fromIntegral
|
||||||
|
(toNanoSecs $ diffTimeSpec lastTime now) / (10 ^ (9 :: Int))
|
||||||
|
ne = elapsedTime ad + dt
|
||||||
|
-- update state data object with new time values
|
||||||
|
put $ ad
|
||||||
|
{ elapsedTime = ne
|
||||||
|
, deltaTime = dt
|
||||||
|
}
|
||||||
|
|
||||||
|
-- poll events
|
||||||
|
liftIO SDL.pumpEvents
|
||||||
|
evs <- preHandleEvents =<< liftIO SDL.pollEvents
|
||||||
|
|
||||||
|
-- handle events
|
||||||
|
handleEvents gameData evs
|
||||||
|
|
||||||
|
-- execute user defined update loop
|
||||||
|
unless (pausedTime ad) (update gameData dt)
|
||||||
|
|
||||||
|
-- clear GL buffer >> execute user defined draw loop >> flush GL buffer
|
||||||
|
liftIO $ GL.clear [GL.ColorBuffer, GL.DepthBuffer, GL.StencilBuffer]
|
||||||
|
draw gameData
|
||||||
|
liftIO GL.flush
|
||||||
|
|
||||||
|
-- actual displaying of newly drawn frame
|
||||||
|
mapM_ (SDL.glSwapWindow . awWindow) windows
|
||||||
|
|
||||||
|
-- save new time
|
||||||
|
ad3 <- get
|
||||||
|
when (sysTime ad == sysTime ad3) (
|
||||||
|
put ad3
|
||||||
|
{ sysTime = now
|
||||||
|
}
|
||||||
|
)
|
||||||
|
)
|
||||||
|
)
|
||||||
|
-- Cleanup works
|
||||||
|
liftIO $ logIO Debug "Loop ended. Cleaning"
|
||||||
|
release gameDataKey
|
||||||
|
-- mapM_ (SDL.glDeleteContext . snd) contexts
|
||||||
|
-- mapM_ (SDL.destroyWindow . (\(_,y,_) -> y)) windows
|
||||||
|
-- SDL.quit -- <- This causes segfaults depending on hardware
|
||||||
|
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
|
21
extern/affection/src/Affection/Class.hs
vendored
Normal file
21
extern/affection/src/Affection/Class.hs
vendored
Normal file
|
@ -0,0 +1,21 @@
|
||||||
|
module Affection.Class where
|
||||||
|
|
||||||
|
import qualified SDL
|
||||||
|
|
||||||
|
import Affection.Types as A
|
||||||
|
|
||||||
|
class Affectionate a where
|
||||||
|
|
||||||
|
loadState :: IO a
|
||||||
|
|
||||||
|
preLoop :: a -> Affection ()
|
||||||
|
|
||||||
|
handleEvents :: a -> [SDL.EventPayload] -> Affection ()
|
||||||
|
|
||||||
|
update :: a -> Double -> Affection ()
|
||||||
|
|
||||||
|
draw :: a -> Affection ()
|
||||||
|
|
||||||
|
cleanUp :: a -> IO ()
|
||||||
|
|
||||||
|
hasNextStep :: a -> Affection Bool
|
54
extern/affection/src/Affection/Logging.hs
vendored
Normal file
54
extern/affection/src/Affection/Logging.hs
vendored
Normal file
|
@ -0,0 +1,54 @@
|
||||||
|
{-# LANGUAGE CPP #-}
|
||||||
|
-- | This module defines the logging capability of Affection, whis is derived
|
||||||
|
-- from "Debug.Trace".
|
||||||
|
module Affection.Logging where
|
||||||
|
|
||||||
|
import qualified Data.Text as T
|
||||||
|
|
||||||
|
import Debug.Trace
|
||||||
|
|
||||||
|
-- | The log level definition
|
||||||
|
data LogLevel
|
||||||
|
= Verbose -- ^ Log everything
|
||||||
|
| Debug -- ^ Log Debug messages and above
|
||||||
|
| Warn -- ^ Log only Warnings and errors
|
||||||
|
| Error -- ^ Log only errors
|
||||||
|
|
||||||
|
-- | Pure logging function
|
||||||
|
log
|
||||||
|
:: LogLevel -- ^ Log level to log to
|
||||||
|
-> T.Text -- ^ The message string
|
||||||
|
-> a -- ^ Arbitrary datatype to return
|
||||||
|
-> a -- ^ Returned data
|
||||||
|
#if defined(VERBOSE)
|
||||||
|
log Verbose s = trace ("VERBOSE: " ++ T.unpack s)
|
||||||
|
#endif
|
||||||
|
#if defined(DEBUG) || defined(VERBOSE)
|
||||||
|
log Debug s = trace ("DEBUG: " ++ T.unpack s)
|
||||||
|
#endif
|
||||||
|
#if defined(WARN) || defined(DEBUG) || defined(VERBOSE)
|
||||||
|
log Warn s = trace ("WARN: " ++ T.unpack s)
|
||||||
|
#endif
|
||||||
|
#if defined(ERROR) || defined(WARN) || defined(DEBUG) || defined(VERBOSE)
|
||||||
|
log Error s = trace ("ERROR: " ++ T.unpack s)
|
||||||
|
#endif
|
||||||
|
log _ _ = id
|
||||||
|
|
||||||
|
-- | Manadic logging function residing in the 'IO' Monad
|
||||||
|
logIO
|
||||||
|
:: LogLevel -- ^ Log level to log to
|
||||||
|
-> T.Text -- ^ The message string
|
||||||
|
-> IO ()
|
||||||
|
#if defined(VERBOSE)
|
||||||
|
logIO Verbose s = traceIO ("VERBOSE: " ++ T.unpack s)
|
||||||
|
#endif
|
||||||
|
#if defined(DEBUG) || defined(VERBOSE)
|
||||||
|
logIO Debug s = traceIO ("DEBUG: " ++ T.unpack s)
|
||||||
|
#endif
|
||||||
|
#if defined(WARN) || defined(DEBUG) || defined(VERBOSE)
|
||||||
|
logIO Warn s = traceIO ("WARN: " ++ T.unpack s)
|
||||||
|
#endif
|
||||||
|
#if defined(ERROR) || defined(WARN) || defined(DEBUG) || defined(VERBOSE)
|
||||||
|
logIO Error s = traceIO ("ERROR: " ++ T.unpack s)
|
||||||
|
#endif
|
||||||
|
logIO _ _ = return ()
|
6
extern/affection/src/Affection/MessageBus.hs
vendored
Normal file
6
extern/affection/src/Affection/MessageBus.hs
vendored
Normal file
|
@ -0,0 +1,6 @@
|
||||||
|
module Affection.MessageBus
|
||||||
|
( module M
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Affection.MessageBus.Class as M
|
||||||
|
import Affection.MessageBus.Message as M
|
68
extern/affection/src/Affection/MessageBus/Class.hs
vendored
Normal file
68
extern/affection/src/Affection/MessageBus/Class.hs
vendored
Normal file
|
@ -0,0 +1,68 @@
|
||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||||
|
{-# LANGUAGE ExistentialQuantification #-}
|
||||||
|
module Affection.MessageBus.Class
|
||||||
|
( Participant(..)
|
||||||
|
, genUUID
|
||||||
|
, UUID
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Affection.MessageBus.Message
|
||||||
|
import Affection.Types
|
||||||
|
|
||||||
|
import Control.Monad.IO.Class (liftIO)
|
||||||
|
|
||||||
|
import Data.UUID
|
||||||
|
import Data.UUID.V4
|
||||||
|
|
||||||
|
import Data.String as S (fromString)
|
||||||
|
|
||||||
|
import Affection.Logging
|
||||||
|
|
||||||
|
-- | This typeclass defines the behaviour of a participant in the message system
|
||||||
|
class (Message (Mesg prt), Show (Mesg prt)) => Participant prt where
|
||||||
|
-- | Message datatype
|
||||||
|
type Mesg prt :: *
|
||||||
|
|
||||||
|
-- | Function to get the list of subscribers from the participant
|
||||||
|
partSubscribers
|
||||||
|
:: prt
|
||||||
|
-- ^ the 'Participant''s subscriber storage
|
||||||
|
-> Affection [Mesg prt -> Affection ()]
|
||||||
|
-- ^ List of Subscriber functions
|
||||||
|
|
||||||
|
-- | Subscribe to the 'Participant''s events
|
||||||
|
partSubscribe
|
||||||
|
:: prt
|
||||||
|
-- ^ The 'Participant''s subscriber storage
|
||||||
|
-> (Mesg prt -> Affection ())
|
||||||
|
-- ^ What to do in case of a 'Message'
|
||||||
|
-- (Subscriber function)
|
||||||
|
-> Affection UUID
|
||||||
|
-- ^ 'UUID' of the registered subscriber Function
|
||||||
|
|
||||||
|
-- | Unsubscribe a Subscriber function from Participant
|
||||||
|
partUnSubscribe
|
||||||
|
:: prt
|
||||||
|
-- ^ The 'Participant''s subscriber storage to unsubscribe from
|
||||||
|
-> UUID
|
||||||
|
-- ^ The subscriber function's 'UUID'
|
||||||
|
-> Affection ()
|
||||||
|
|
||||||
|
-- | Get the 'Participant' to emit a 'Message' on all of its subscribers
|
||||||
|
partEmit
|
||||||
|
:: prt
|
||||||
|
-- ^ The 'Participant''s subscriber storage
|
||||||
|
-> Mesg prt
|
||||||
|
-- ^ The 'Message' to emit
|
||||||
|
-> Affection ()
|
||||||
|
partEmit p m = do
|
||||||
|
liftIO $ logIO Verbose $ "Emitting message: " <> S.fromString (show m)
|
||||||
|
l <- partSubscribers p
|
||||||
|
mapM_ ($ m) l
|
||||||
|
|
||||||
|
-- | Helper function to generate new 'UUID's
|
||||||
|
genUUID :: Affection UUID
|
||||||
|
genUUID = liftIO nextRandom
|
9
extern/affection/src/Affection/MessageBus/Message.hs
vendored
Normal file
9
extern/affection/src/Affection/MessageBus/Message.hs
vendored
Normal file
|
@ -0,0 +1,9 @@
|
||||||
|
module Affection.MessageBus.Message
|
||||||
|
( module M
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Affection.MessageBus.Message.Class as M
|
||||||
|
import Affection.MessageBus.Message.WindowMessage as M
|
||||||
|
import Affection.MessageBus.Message.KeyboardMessage as M
|
||||||
|
import Affection.MessageBus.Message.MouseMessage as M
|
||||||
|
import Affection.MessageBus.Message.JoystickMessage as M
|
6
extern/affection/src/Affection/MessageBus/Message/Class.hs
vendored
Normal file
6
extern/affection/src/Affection/MessageBus/Message/Class.hs
vendored
Normal file
|
@ -0,0 +1,6 @@
|
||||||
|
module Affection.MessageBus.Message.Class where
|
||||||
|
|
||||||
|
-- | Typeclass definition for messages
|
||||||
|
class Message msg where
|
||||||
|
-- | return the time when the message was sent
|
||||||
|
msgTime :: msg -> Double
|
67
extern/affection/src/Affection/MessageBus/Message/JoystickMessage.hs
vendored
Normal file
67
extern/affection/src/Affection/MessageBus/Message/JoystickMessage.hs
vendored
Normal file
|
@ -0,0 +1,67 @@
|
||||||
|
module Affection.MessageBus.Message.JoystickMessage
|
||||||
|
( JoystickMessage(..)
|
||||||
|
-- | Vector export
|
||||||
|
, Linear.V2
|
||||||
|
-- | SDL exports
|
||||||
|
, SDL.JoyHatPosition
|
||||||
|
, SDL.JoyButtonState
|
||||||
|
, SDL.JoyDeviceConnection
|
||||||
|
-- | Number exports
|
||||||
|
, Word8
|
||||||
|
, Int16
|
||||||
|
, Int32
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Affection.MessageBus.Message.Class
|
||||||
|
|
||||||
|
import Data.Word (Word8)
|
||||||
|
import Data.Int (Int32, Int16)
|
||||||
|
|
||||||
|
import qualified SDL
|
||||||
|
|
||||||
|
import Linear (V2(..))
|
||||||
|
|
||||||
|
-- | Datatype for handling all possible joystick events handed over from sdl2
|
||||||
|
data JoystickMessage
|
||||||
|
-- | Movement of a Joystick axis
|
||||||
|
= MsgJoystickAxis
|
||||||
|
{ msgJAWhen :: Double -- ^ Time of event
|
||||||
|
, msgJAWhich :: Int32 -- ^ Joystick identifier
|
||||||
|
, msgJAAxis :: Word8 -- ^ Axis identifier
|
||||||
|
, msgJAValue :: Int16 -- ^ Axis value
|
||||||
|
}
|
||||||
|
-- | Movement of a joystick ball controller
|
||||||
|
| MsgJoystickBall
|
||||||
|
{ msgJBWhen :: Double -- ^ Time of event
|
||||||
|
, msgJBWhich :: Int32 -- ^ Joystick identifier
|
||||||
|
, msgJBBall :: Word8 -- ^ Ball identifier
|
||||||
|
, msgJBRelMotion :: V2 Int16 -- ^ Motion relative to previous position
|
||||||
|
}
|
||||||
|
-- | Movement of joystick hat controller
|
||||||
|
| MsgJoystickHat
|
||||||
|
{ msgJHWhen :: Double -- ^ Time of event
|
||||||
|
, msgJHWhich :: Int32 -- ^ Joystick identifier
|
||||||
|
, msgJHHat :: Word8 -- ^ Hat identifier
|
||||||
|
, msgJHPosition :: SDL.JoyHatPosition -- ^ New hat position
|
||||||
|
}
|
||||||
|
-- | Joystick button event
|
||||||
|
| MsgJoystickButton
|
||||||
|
{ msgJBWhen :: Double -- ^ Time of event
|
||||||
|
, msgJBWhich :: Int32 -- ^ Joystick identifier
|
||||||
|
, msgJBButton :: Word8 -- ^ Button identifier
|
||||||
|
, msgJBState :: SDL.JoyButtonState -- ^ New Button state
|
||||||
|
}
|
||||||
|
-- | Joystick device event
|
||||||
|
| MsgJoystickDevice
|
||||||
|
{ msgJDWhen :: Double -- ^ Time of event
|
||||||
|
, msgJDWhich :: Int32 -- ^ Joystick identifier
|
||||||
|
, msgJDConnection :: SDL.JoyDeviceConnection -- ^ Connection status
|
||||||
|
}
|
||||||
|
deriving (Show)
|
||||||
|
|
||||||
|
instance Message JoystickMessage where
|
||||||
|
msgTime (MsgJoystickAxis t _ _ _) = t
|
||||||
|
msgTime (MsgJoystickBall t _ _ _) = t
|
||||||
|
msgTime (MsgJoystickHat t _ _ _) = t
|
||||||
|
msgTime (MsgJoystickButton t _ _ _) = t
|
||||||
|
msgTime (MsgJoystickDevice t _ _) = t
|
26
extern/affection/src/Affection/MessageBus/Message/KeyboardMessage.hs
vendored
Normal file
26
extern/affection/src/Affection/MessageBus/Message/KeyboardMessage.hs
vendored
Normal file
|
@ -0,0 +1,26 @@
|
||||||
|
module Affection.MessageBus.Message.KeyboardMessage
|
||||||
|
( KeyboardMessage(..)
|
||||||
|
-- | SDL reexports
|
||||||
|
, SDL.Window
|
||||||
|
, SDL.InputMotion
|
||||||
|
, SDL.Keysym
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Affection.MessageBus.Message.Class
|
||||||
|
|
||||||
|
import qualified SDL
|
||||||
|
|
||||||
|
-- | Dataatype for handling all keyboard events haded down from SDL2
|
||||||
|
data KeyboardMessage
|
||||||
|
-- | Arbitrary Keyboard event
|
||||||
|
= MsgKeyboardEvent
|
||||||
|
{ msgKbdWhen :: Double -- ^ Message time
|
||||||
|
, msgKbdWindow :: Maybe SDL.Window -- ^ Affected Window
|
||||||
|
, msgKbdKeyMotion :: SDL.InputMotion -- ^ Input motion of button (pressed/released)
|
||||||
|
, msgKbdKeyRepeat :: Bool -- ^ Is this a repeated event?
|
||||||
|
, msgKbdKeysym :: SDL.Keysym -- ^ The button's 'SDL.Keysym'
|
||||||
|
}
|
||||||
|
deriving (Show)
|
||||||
|
|
||||||
|
instance Message KeyboardMessage where
|
||||||
|
msgTime (MsgKeyboardEvent t _ _ _ _) = t
|
54
extern/affection/src/Affection/MessageBus/Message/MouseMessage.hs
vendored
Normal file
54
extern/affection/src/Affection/MessageBus/Message/MouseMessage.hs
vendored
Normal file
|
@ -0,0 +1,54 @@
|
||||||
|
module Affection.MessageBus.Message.MouseMessage
|
||||||
|
( MouseMessage(..)
|
||||||
|
-- | SDL reexports
|
||||||
|
, SDL.Window
|
||||||
|
, SDL.MouseDevice
|
||||||
|
, SDL.MouseButton
|
||||||
|
, SDL.InputMotion
|
||||||
|
, SDL.MouseScrollDirection
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Affection.MessageBus.Message.Class
|
||||||
|
|
||||||
|
import Data.Word (Word8)
|
||||||
|
import Data.Int (Int32)
|
||||||
|
|
||||||
|
import qualified SDL
|
||||||
|
|
||||||
|
import Linear (V2(..))
|
||||||
|
|
||||||
|
-- Datatype for handling mouse events handed down from SDL2
|
||||||
|
data MouseMessage
|
||||||
|
-- | Mouse motion event
|
||||||
|
= MsgMouseMotion
|
||||||
|
{ msgMMWhen :: Double -- ^ Message time
|
||||||
|
, msgMMWindow :: Maybe SDL.Window -- ^ Focused window (if any)
|
||||||
|
, msgMMWhich :: SDL.MouseDevice -- ^ Mouse device identifier
|
||||||
|
, msgMMState :: [SDL.MouseButton] -- ^ List of pressed mouse buttons
|
||||||
|
, msgMMPos :: V2 Int32 -- ^ Absolute mouse positiom
|
||||||
|
, msgMMRelMotion :: V2 Int32 -- ^ Mouse movement relative to previous position
|
||||||
|
}
|
||||||
|
-- | Mouse button event
|
||||||
|
| MsgMouseButton
|
||||||
|
{ msgMBWhen :: Double -- ^ Message time
|
||||||
|
, msgMBWindow :: Maybe SDL.Window -- ^ Focused window (if any)
|
||||||
|
, msgMBMotion :: SDL.InputMotion -- ^ Button's input motion
|
||||||
|
, msgMBWhich :: SDL.MouseDevice -- ^ Mouse device identifier
|
||||||
|
, msgMBButton :: SDL.MouseButton -- ^ Affected mouse button
|
||||||
|
, msgMBClicks :: Word8 -- ^ Number of clicks
|
||||||
|
, msgMBPos :: V2 Int32 -- ^ Absolute mouse position
|
||||||
|
}
|
||||||
|
-- | Mouse wheel event
|
||||||
|
| MsgMouseWheel
|
||||||
|
{ msgMWWhen :: Double -- ^ Message time
|
||||||
|
, msgMWWhindow :: Maybe SDL.Window -- ^ Focused window (if any)
|
||||||
|
, msgMWWhich :: SDL.MouseDevice -- ^ Mouse device identifier
|
||||||
|
, msgMWPos :: V2 Int32 -- ^ Absolute mouse position
|
||||||
|
, msgMWDIrection :: SDL.MouseScrollDirection -- ^ Scroll direction
|
||||||
|
}
|
||||||
|
deriving (Show)
|
||||||
|
|
||||||
|
instance Message MouseMessage where
|
||||||
|
msgTime (MsgMouseMotion t _ _ _ _ _) = t
|
||||||
|
msgTime (MsgMouseButton t _ _ _ _ _ _) = t
|
||||||
|
msgTime (MsgMouseWheel t _ _ _ _) = t
|
106
extern/affection/src/Affection/MessageBus/Message/WindowMessage.hs
vendored
Normal file
106
extern/affection/src/Affection/MessageBus/Message/WindowMessage.hs
vendored
Normal file
|
@ -0,0 +1,106 @@
|
||||||
|
module Affection.MessageBus.Message.WindowMessage
|
||||||
|
( WindowMessage(..)
|
||||||
|
-- | SDL reexports
|
||||||
|
, SDL.Window
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Affection.MessageBus.Message.Class
|
||||||
|
|
||||||
|
import Data.Int (Int32)
|
||||||
|
|
||||||
|
import qualified SDL
|
||||||
|
|
||||||
|
import Linear (V2(..))
|
||||||
|
|
||||||
|
-- | Datatype for handling Window events handed down rom SDL2
|
||||||
|
data WindowMessage
|
||||||
|
-- | Window show event
|
||||||
|
= MsgWindowShow
|
||||||
|
{ msgWSWhen :: Double -- ^ Message time
|
||||||
|
, msgWSWindow :: SDL.Window -- ^ Window identifier
|
||||||
|
}
|
||||||
|
-- | Window hide event
|
||||||
|
| MsgWindowHide
|
||||||
|
{ msgWHWhen :: Double -- ^ Message time
|
||||||
|
, msgWHWindow :: SDL.Window -- ^ Window identifier
|
||||||
|
}
|
||||||
|
-- | Window expose event
|
||||||
|
| MsgWindowExpose
|
||||||
|
{ msgWEWhen :: Double -- ^ Message time
|
||||||
|
, msgWEWindow :: SDL.Window -- ^ Window identifier
|
||||||
|
}
|
||||||
|
-- | Window move event
|
||||||
|
| MsgWindowMove
|
||||||
|
{ msgWMWhen :: Double -- ^ Message time
|
||||||
|
, msgWMWindow :: SDL.Window -- ^ Window identifier
|
||||||
|
, msgWMNewPos :: V2 Int32 -- ^ New absolute window position
|
||||||
|
}
|
||||||
|
-- | Window resize event
|
||||||
|
| MsgWindowResize
|
||||||
|
{ msgWRWhen :: Double -- ^ Message time
|
||||||
|
, msgWRWindow :: SDL.Window -- ^ Window identifier
|
||||||
|
, msgWRNewSize :: V2 Int32 -- ^ New absolute window size
|
||||||
|
}
|
||||||
|
-- | Window size change event
|
||||||
|
| MsgWindowSizeChange
|
||||||
|
{ msgWSCWhen :: Double -- ^ Message time
|
||||||
|
, msgWSCWindow :: SDL.Window -- ^ Window identifier
|
||||||
|
, msgWSCNewSize :: V2 Int32 -- ^ New absolute window size
|
||||||
|
}
|
||||||
|
-- | Window minimize event
|
||||||
|
| MsgWindowMinimize
|
||||||
|
{ msgWMinWhen :: Double -- ^ Message time
|
||||||
|
, msgWMinWindow :: SDL.Window -- ^ Window identifier
|
||||||
|
}
|
||||||
|
-- | Window maximize event
|
||||||
|
| MsgWindowMaximize
|
||||||
|
{ msgWMaxWhen :: Double -- ^ Message time
|
||||||
|
, msgWMaxWindow :: SDL.Window -- ^ Window identifier
|
||||||
|
}
|
||||||
|
-- | Window restore event
|
||||||
|
| MsgWindowRestore
|
||||||
|
{ msgWRestWhen :: Double -- ^ Message time
|
||||||
|
, msgWRestWindow :: SDL.Window -- ^ Window identifier
|
||||||
|
}
|
||||||
|
-- | Window gain mouse focus event
|
||||||
|
| MsgWindowGainMouseFocus
|
||||||
|
{ msgWGMFWhen :: Double -- ^ Message Time
|
||||||
|
, msgWGMFWindow :: SDL.Window -- ^ Window identifier
|
||||||
|
}
|
||||||
|
-- | Window lose mouse focus event
|
||||||
|
| MsgWindowLoseMouseFocus
|
||||||
|
{ msgWLMFWhen :: Double -- ^ Message Time
|
||||||
|
, msgWLMFWindow :: SDL.Window -- ^ Window identifier
|
||||||
|
}
|
||||||
|
-- | Window gain keyboard focus event
|
||||||
|
| MsgWindowGainKeyboardFocus
|
||||||
|
{ msgWGKFWhen :: Double -- ^ Message time
|
||||||
|
, msgWGKFWindow :: SDL.Window -- ^ Window identifier
|
||||||
|
}
|
||||||
|
-- | Window lose keyboard focus event
|
||||||
|
| MsgWindowLoseKeyboardFocus
|
||||||
|
{ msgWLKFWhen :: Double -- ^ Message time
|
||||||
|
, msgWLKFWindow :: SDL.Window -- ^ Window identifier
|
||||||
|
}
|
||||||
|
-- | Window close event
|
||||||
|
| MsgWindowClose
|
||||||
|
{ msgWCWhen :: Double -- ^ Message time
|
||||||
|
, msgWCWindow :: SDL.Window -- ^ Window identifier
|
||||||
|
}
|
||||||
|
deriving (Show)
|
||||||
|
|
||||||
|
instance Message WindowMessage where
|
||||||
|
msgTime (MsgWindowShow t _) = t
|
||||||
|
msgTime (MsgWindowHide t _) = t
|
||||||
|
msgTime (MsgWindowExpose t _) = t
|
||||||
|
msgTime (MsgWindowMove t _ _) = t
|
||||||
|
msgTime (MsgWindowResize t _ _) = t
|
||||||
|
msgTime (MsgWindowSizeChange t _ _) = t
|
||||||
|
msgTime (MsgWindowMinimize t _) = t
|
||||||
|
msgTime (MsgWindowMaximize t _) = t
|
||||||
|
msgTime (MsgWindowRestore t _) = t
|
||||||
|
msgTime (MsgWindowGainMouseFocus t _) = t
|
||||||
|
msgTime (MsgWindowLoseMouseFocus t _) = t
|
||||||
|
msgTime (MsgWindowGainKeyboardFocus t _) = t
|
||||||
|
msgTime (MsgWindowLoseKeyboardFocus t _) = t
|
||||||
|
msgTime (MsgWindowClose t _) = t
|
20
extern/affection/src/Affection/StateMachine.hs
vendored
Normal file
20
extern/affection/src/Affection/StateMachine.hs
vendored
Normal file
|
@ -0,0 +1,20 @@
|
||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
|
|
||||||
|
module Affection.StateMachine where
|
||||||
|
|
||||||
|
import Affection.Types
|
||||||
|
|
||||||
|
import qualified SDL
|
||||||
|
|
||||||
|
-- | Typeclass for simple scaffolding of a state machine
|
||||||
|
class StateMachine us a where
|
||||||
|
-- | State load routine
|
||||||
|
smLoad :: a -> us -> Affection ()
|
||||||
|
-- | state update routine
|
||||||
|
smUpdate :: a -> us -> Double -> Affection ()
|
||||||
|
-- | State event handler routine
|
||||||
|
smEvent :: a -> us -> [SDL.EventPayload] -> Affection ()
|
||||||
|
-- | State draw routine
|
||||||
|
smDraw :: a -> us -> Affection ()
|
||||||
|
-- | State clean routine
|
||||||
|
smClean :: a -> us -> Affection ()
|
9
extern/affection/src/Affection/Subsystems.hs
vendored
Normal file
9
extern/affection/src/Affection/Subsystems.hs
vendored
Normal file
|
@ -0,0 +1,9 @@
|
||||||
|
module Affection.Subsystems
|
||||||
|
( module S
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Affection.Subsystems.Class as S
|
||||||
|
import Affection.Subsystems.AffectionKeyboard as S
|
||||||
|
import Affection.Subsystems.AffectionWindow as S
|
||||||
|
import Affection.Subsystems.AffectionMouse as S
|
||||||
|
import Affection.Subsystems.AffectionJoystick as S
|
119
extern/affection/src/Affection/Subsystems/AffectionJoystick.hs
vendored
Normal file
119
extern/affection/src/Affection/Subsystems/AffectionJoystick.hs
vendored
Normal file
|
@ -0,0 +1,119 @@
|
||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
module Affection.Subsystems.AffectionJoystick where
|
||||||
|
|
||||||
|
import Affection.MessageBus
|
||||||
|
import Affection.Types
|
||||||
|
import Affection.Util
|
||||||
|
import Affection.Logging
|
||||||
|
|
||||||
|
import Control.Monad (filterM)
|
||||||
|
import Control.Monad.IO.Class (liftIO)
|
||||||
|
|
||||||
|
import qualified Data.Vector as V
|
||||||
|
import Data.String as S (fromString)
|
||||||
|
|
||||||
|
import Foreign.C.Types (CInt(..))
|
||||||
|
|
||||||
|
import qualified SDL
|
||||||
|
|
||||||
|
-- | Helper function that consumes all Joystick-related 'SDL.EventPayload's
|
||||||
|
-- and emits appropriate 'JoystickMessage's
|
||||||
|
consumeSDLJoystickEvents
|
||||||
|
:: forall am. (Participant am, Mesg am ~ JoystickMessage)
|
||||||
|
=> am -- ^ The message system participant
|
||||||
|
-> [SDL.EventPayload] -- ^ Incoming events
|
||||||
|
-> Affection [SDL.EventPayload] -- ^ Leftover SDL events
|
||||||
|
consumeSDLJoystickEvents am = doConsume
|
||||||
|
where
|
||||||
|
doConsume
|
||||||
|
:: [SDL.EventPayload]
|
||||||
|
-> Affection [SDL.EventPayload]
|
||||||
|
doConsume [] = return []
|
||||||
|
doConsume (e:es) = do
|
||||||
|
ts <- getElapsedTime
|
||||||
|
case e of
|
||||||
|
SDL.JoyAxisEvent dat -> do
|
||||||
|
partEmit am (MsgJoystickAxis
|
||||||
|
ts
|
||||||
|
(SDL.joyAxisEventWhich dat)
|
||||||
|
(SDL.joyAxisEventAxis dat)
|
||||||
|
(SDL.joyAxisEventValue dat)
|
||||||
|
)
|
||||||
|
doConsume es
|
||||||
|
SDL.JoyBallEvent dat -> do
|
||||||
|
partEmit am (MsgJoystickBall
|
||||||
|
ts
|
||||||
|
(SDL.joyBallEventWhich dat)
|
||||||
|
(SDL.joyBallEventBall dat)
|
||||||
|
(SDL.joyBallEventRelMotion dat)
|
||||||
|
)
|
||||||
|
doConsume es
|
||||||
|
SDL.JoyHatEvent dat -> do
|
||||||
|
partEmit am (MsgJoystickHat
|
||||||
|
ts
|
||||||
|
(SDL.joyHatEventWhich dat)
|
||||||
|
(SDL.joyHatEventHat dat)
|
||||||
|
(SDL.joyHatEventValue dat)
|
||||||
|
)
|
||||||
|
doConsume es
|
||||||
|
SDL.JoyButtonEvent dat -> do
|
||||||
|
partEmit am (MsgJoystickButton
|
||||||
|
ts
|
||||||
|
(SDL.joyButtonEventWhich dat)
|
||||||
|
(SDL.joyButtonEventButton dat)
|
||||||
|
(SDL.joyButtonEventState dat)
|
||||||
|
)
|
||||||
|
doConsume es
|
||||||
|
SDL.JoyDeviceEvent dat -> do
|
||||||
|
partEmit am (MsgJoystickDevice
|
||||||
|
ts
|
||||||
|
(SDL.joyDeviceEventWhich dat)
|
||||||
|
(SDL.joyDeviceEventConnection dat)
|
||||||
|
)
|
||||||
|
doConsume es
|
||||||
|
_ -> fmap (e :) (doConsume es)
|
||||||
|
|
||||||
|
-- | Helper function to automatically connect and open newly attached joystick
|
||||||
|
-- devices
|
||||||
|
joystickAutoConnect
|
||||||
|
:: JoystickMessage -- ^ Any 'JoystickMessage' will do,
|
||||||
|
-- but listens only on 'MsgJoystickDevice' messages
|
||||||
|
-> Affection (Maybe SDL.Joystick)
|
||||||
|
-- ^ Returns a joystick descriptor, if successful
|
||||||
|
joystickAutoConnect (MsgJoystickDevice _ which SDL.JoyDeviceAdded) = liftIO $ do
|
||||||
|
[descr] <- V.toList <$>
|
||||||
|
(V.filter (\(SDL.JoystickDevice _ i) -> i == CInt which) <$>
|
||||||
|
SDL.availableJoysticks)
|
||||||
|
logIO Verbose $ "Connecting Joystick " <> fromString (show which) <> " " <>
|
||||||
|
fromString (show descr)
|
||||||
|
Just <$> SDL.openJoystick descr
|
||||||
|
joystickAutoConnect _ = return Nothing
|
||||||
|
|
||||||
|
-- | Helper function to automatically close and disconnect freshly detached
|
||||||
|
-- joystick devices
|
||||||
|
joystickAutoDisconnect
|
||||||
|
:: [SDL.Joystick] -- ^ List of Joystick descriptors
|
||||||
|
-> JoystickMessage -- ^ Any 'JoystickMessage' will do, but listens
|
||||||
|
-- specifically to 'MsgJoystickDevice' messages
|
||||||
|
-> Affection [SDL.Joystick] -- ^ Returns altered list of Joystick descriptors
|
||||||
|
joystickAutoDisconnect js (MsgJoystickDevice _ which SDL.JoyDeviceRemoved) =
|
||||||
|
liftIO $ do
|
||||||
|
joyIds <- mapM SDL.getJoystickID js
|
||||||
|
logIO Verbose $ "These are the Joysticks connected: " <>
|
||||||
|
fromString (show joyIds)
|
||||||
|
d <- filterM (\j -> fmap (== which) (SDL.getJoystickID j)) js
|
||||||
|
if not (null d)
|
||||||
|
then do
|
||||||
|
logIO Verbose $ "disconnected joysticks: " <> fromString (show $ head d)
|
||||||
|
logIO Verbose $ "Disconnecting Joystick " <> fromString (show which)
|
||||||
|
SDL.closeJoystick (head d)
|
||||||
|
njoys <- filterM (\j -> return $ head d /= j) js
|
||||||
|
logIO Verbose $ "returning joysticks: " <> fromString (show njoys)
|
||||||
|
return njoys
|
||||||
|
else do
|
||||||
|
logIO Error $ "Error while disconnecting Joystick"
|
||||||
|
return js
|
||||||
|
joystickAutoDisconnect js _ = return js
|
35
extern/affection/src/Affection/Subsystems/AffectionKeyboard.hs
vendored
Normal file
35
extern/affection/src/Affection/Subsystems/AffectionKeyboard.hs
vendored
Normal file
|
@ -0,0 +1,35 @@
|
||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
module Affection.Subsystems.AffectionKeyboard where
|
||||||
|
|
||||||
|
import Affection.Types
|
||||||
|
import Affection.Util
|
||||||
|
import Affection.MessageBus
|
||||||
|
|
||||||
|
import qualified SDL
|
||||||
|
|
||||||
|
-- | Helper function that consumes all Keyboard-related 'SDL.EventPayload's
|
||||||
|
-- and emits appropriate 'KeyboardMessage's
|
||||||
|
consumeSDLKeyboardEvents
|
||||||
|
:: forall ak. (Participant ak, Mesg ak ~ KeyboardMessage)
|
||||||
|
=> ak -- ^ The message system participant
|
||||||
|
-> [SDL.EventPayload] -- ^ Incoming events
|
||||||
|
-> Affection [SDL.EventPayload] -- ^ Leftover SDL Events
|
||||||
|
consumeSDLKeyboardEvents ak = doConsume
|
||||||
|
where
|
||||||
|
doConsume [] = return []
|
||||||
|
doConsume (e:es) = do
|
||||||
|
ts <- getElapsedTime
|
||||||
|
case e of
|
||||||
|
SDL.KeyboardEvent dat -> do
|
||||||
|
partEmit ak (MsgKeyboardEvent
|
||||||
|
ts
|
||||||
|
(SDL.keyboardEventWindow dat)
|
||||||
|
(SDL.keyboardEventKeyMotion dat)
|
||||||
|
(SDL.keyboardEventRepeat dat)
|
||||||
|
(SDL.keyboardEventKeysym dat)
|
||||||
|
)
|
||||||
|
doConsume es
|
||||||
|
_ -> fmap (e :) (doConsume es)
|
61
extern/affection/src/Affection/Subsystems/AffectionMouse.hs
vendored
Normal file
61
extern/affection/src/Affection/Subsystems/AffectionMouse.hs
vendored
Normal file
|
@ -0,0 +1,61 @@
|
||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
module Affection.Subsystems.AffectionMouse where
|
||||||
|
|
||||||
|
import Affection.MessageBus
|
||||||
|
import Affection.Types
|
||||||
|
import Affection.Util
|
||||||
|
|
||||||
|
import Linear.Affine (unP)
|
||||||
|
|
||||||
|
import qualified SDL
|
||||||
|
|
||||||
|
-- | Helper funtion that consumes all Mouse-related 'SDL.Eventpayload's
|
||||||
|
-- and emits appropriate 'MouseMessage's
|
||||||
|
consumeSDLMouseEvents
|
||||||
|
:: forall am. (Participant am, Mesg am ~ MouseMessage)
|
||||||
|
=> am -- ^ The message system participant
|
||||||
|
-> [SDL.EventPayload] -- ^ Incoming events
|
||||||
|
-> Affection [SDL.EventPayload] -- ^ Leftover SDL events
|
||||||
|
consumeSDLMouseEvents am = doConsume
|
||||||
|
where
|
||||||
|
doConsume
|
||||||
|
:: [SDL.EventPayload]
|
||||||
|
-> Affection [SDL.EventPayload]
|
||||||
|
doConsume [] = return []
|
||||||
|
doConsume (e:es) = do
|
||||||
|
ts <- getElapsedTime
|
||||||
|
case e of
|
||||||
|
SDL.MouseMotionEvent dat -> do
|
||||||
|
partEmit am (MsgMouseMotion
|
||||||
|
ts
|
||||||
|
(SDL.mouseMotionEventWindow dat)
|
||||||
|
(SDL.mouseMotionEventWhich dat)
|
||||||
|
(SDL.mouseMotionEventState dat)
|
||||||
|
(unP $ SDL.mouseMotionEventPos dat)
|
||||||
|
(SDL.mouseMotionEventRelMotion dat)
|
||||||
|
)
|
||||||
|
doConsume es
|
||||||
|
SDL.MouseButtonEvent dat -> do
|
||||||
|
partEmit am (MsgMouseButton
|
||||||
|
ts
|
||||||
|
(SDL.mouseButtonEventWindow dat)
|
||||||
|
(SDL.mouseButtonEventMotion dat)
|
||||||
|
(SDL.mouseButtonEventWhich dat)
|
||||||
|
(SDL.mouseButtonEventButton dat)
|
||||||
|
(SDL.mouseButtonEventClicks dat)
|
||||||
|
(unP $ SDL.mouseButtonEventPos dat)
|
||||||
|
)
|
||||||
|
doConsume es
|
||||||
|
SDL.MouseWheelEvent dat -> do
|
||||||
|
partEmit am (MsgMouseWheel
|
||||||
|
ts
|
||||||
|
(SDL.mouseWheelEventWindow dat)
|
||||||
|
(SDL.mouseWheelEventWhich dat)
|
||||||
|
(SDL.mouseWheelEventPos dat)
|
||||||
|
(SDL.mouseWheelEventDirection dat)
|
||||||
|
)
|
||||||
|
doConsume es
|
||||||
|
_ -> fmap (e :) (doConsume es)
|
74
extern/affection/src/Affection/Subsystems/AffectionWindow.hs
vendored
Normal file
74
extern/affection/src/Affection/Subsystems/AffectionWindow.hs
vendored
Normal file
|
@ -0,0 +1,74 @@
|
||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
|
{-# LANGUAGE RankNTypes #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||||
|
module Affection.Subsystems.AffectionWindow where
|
||||||
|
|
||||||
|
import Affection.Types
|
||||||
|
import Affection.Util
|
||||||
|
import Affection.MessageBus
|
||||||
|
|
||||||
|
import qualified SDL
|
||||||
|
|
||||||
|
-- | Helper function that consumes all Window-related 'SDL.EventPayload's
|
||||||
|
-- and emits appropriate 'WindowMessage's.
|
||||||
|
consumeSDLWindowEvents
|
||||||
|
:: forall aw. (Participant aw, Mesg aw ~ WindowMessage)
|
||||||
|
=> aw -- ^ The message system participant
|
||||||
|
-> [SDL.EventPayload] -- ^ Incoming events
|
||||||
|
-> Affection [SDL.EventPayload] -- ^ Leftover SDL events
|
||||||
|
consumeSDLWindowEvents aw = doConsume
|
||||||
|
where
|
||||||
|
doConsume
|
||||||
|
:: (Mesg aw ~ WindowMessage)
|
||||||
|
=> [SDL.EventPayload]
|
||||||
|
-> Affection [SDL.EventPayload]
|
||||||
|
doConsume [] = return []
|
||||||
|
doConsume (e:es) = do
|
||||||
|
ts <- getElapsedTime
|
||||||
|
case e of
|
||||||
|
SDL.WindowShownEvent (SDL.WindowShownEventData window) -> do
|
||||||
|
partEmit aw (MsgWindowShow ts window)
|
||||||
|
doConsume es
|
||||||
|
SDL.WindowHiddenEvent (SDL.WindowHiddenEventData window) -> do
|
||||||
|
partEmit aw (MsgWindowHide ts window)
|
||||||
|
doConsume es
|
||||||
|
SDL.WindowExposedEvent (SDL.WindowExposedEventData window) -> do
|
||||||
|
partEmit aw (MsgWindowExpose ts window)
|
||||||
|
doConsume es
|
||||||
|
SDL.WindowMovedEvent (SDL.WindowMovedEventData window (SDL.P newPos)) -> do
|
||||||
|
partEmit aw (MsgWindowMove ts window newPos)
|
||||||
|
doConsume es
|
||||||
|
SDL.WindowResizedEvent (SDL.WindowResizedEventData window newSize) -> do
|
||||||
|
partEmit aw (MsgWindowResize ts window newSize)
|
||||||
|
doConsume es
|
||||||
|
SDL.WindowSizeChangedEvent (SDL.WindowSizeChangedEventData window size) -> do
|
||||||
|
partEmit aw (MsgWindowSizeChange ts window size)
|
||||||
|
doConsume es
|
||||||
|
SDL.WindowMinimizedEvent (SDL.WindowMinimizedEventData window) -> do
|
||||||
|
partEmit aw (MsgWindowMinimize ts window)
|
||||||
|
doConsume es
|
||||||
|
SDL.WindowMaximizedEvent (SDL.WindowMaximizedEventData window) -> do
|
||||||
|
partEmit aw (MsgWindowMaximize ts window)
|
||||||
|
doConsume es
|
||||||
|
SDL.WindowRestoredEvent (SDL.WindowRestoredEventData window) -> do
|
||||||
|
partEmit aw (MsgWindowRestore ts window)
|
||||||
|
doConsume es
|
||||||
|
SDL.WindowGainedMouseFocusEvent (SDL.WindowGainedMouseFocusEventData window) -> do
|
||||||
|
partEmit aw (MsgWindowGainMouseFocus ts window)
|
||||||
|
doConsume es
|
||||||
|
SDL.WindowLostMouseFocusEvent (SDL.WindowLostMouseFocusEventData window) -> do
|
||||||
|
partEmit aw (MsgWindowLoseMouseFocus ts window)
|
||||||
|
doConsume es
|
||||||
|
SDL.WindowGainedKeyboardFocusEvent (SDL.WindowGainedKeyboardFocusEventData window) -> do
|
||||||
|
partEmit aw (MsgWindowGainKeyboardFocus ts window)
|
||||||
|
doConsume es
|
||||||
|
SDL.WindowLostKeyboardFocusEvent (SDL.WindowLostKeyboardFocusEventData window) -> do
|
||||||
|
partEmit aw (MsgWindowLoseKeyboardFocus ts window)
|
||||||
|
doConsume es
|
||||||
|
SDL.WindowClosedEvent (SDL.WindowClosedEventData window) -> do
|
||||||
|
partEmit aw (MsgWindowClose ts window)
|
||||||
|
doConsume es
|
||||||
|
_ -> fmap (e :) (doConsume es)
|
13
extern/affection/src/Affection/Subsystems/Class.hs
vendored
Normal file
13
extern/affection/src/Affection/Subsystems/Class.hs
vendored
Normal file
|
@ -0,0 +1,13 @@
|
||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
|
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||||
|
module Affection.Subsystems.Class where
|
||||||
|
|
||||||
|
import Affection.Types
|
||||||
|
|
||||||
|
import qualified SDL
|
||||||
|
|
||||||
|
-- | This class denotes a Subsystem to be part of SDL
|
||||||
|
class SDLSubsystem s where
|
||||||
|
-- | Consume the given 'SDL.EventPayload's and return only those not
|
||||||
|
-- recognised
|
||||||
|
consumeSDLEvents :: s -> [SDL.EventPayload] -> Affection [SDL.EventPayload]
|
87
extern/affection/src/Affection/Types.hs
vendored
Normal file
87
extern/affection/src/Affection/Types.hs
vendored
Normal file
|
@ -0,0 +1,87 @@
|
||||||
|
{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveFunctor #-}
|
||||||
|
module Affection.Types
|
||||||
|
( Affection
|
||||||
|
, AffectionConfig(..)
|
||||||
|
, AffectionData(..)
|
||||||
|
, AffectionStateInner
|
||||||
|
, AffectionState(..)
|
||||||
|
, AffectionWindow(..)
|
||||||
|
, AffectionContext(..)
|
||||||
|
, InitComponents(..)
|
||||||
|
, Angle
|
||||||
|
-- | SDL reexports
|
||||||
|
, SDL.WindowConfig(..)
|
||||||
|
, SDL.WindowMode(..)
|
||||||
|
, SDL.EventPayload(..)
|
||||||
|
, SDL.InitFlag(..)
|
||||||
|
, SDL.Window
|
||||||
|
, SDL.GLContext
|
||||||
|
) where
|
||||||
|
|
||||||
|
import qualified SDL.Init as SDL
|
||||||
|
import qualified SDL.Video as SDL
|
||||||
|
import qualified SDL.Event as SDL
|
||||||
|
import qualified Data.Text as T
|
||||||
|
|
||||||
|
import Control.Monad.IO.Class
|
||||||
|
import Control.Monad.State.Strict
|
||||||
|
import Control.Monad.Trans.Resource
|
||||||
|
import qualified Control.Monad.Parallel as MP
|
||||||
|
|
||||||
|
import System.Clock (TimeSpec)
|
||||||
|
|
||||||
|
-- | Configuration for the aplication. needed at startup.
|
||||||
|
data AffectionConfig us = AffectionConfig
|
||||||
|
{ initComponents :: InitComponents
|
||||||
|
-- ^ SDL components to initialize at startup
|
||||||
|
, windowTitle :: T.Text
|
||||||
|
-- ^ Window title
|
||||||
|
, windowConfigs ::
|
||||||
|
[
|
||||||
|
( Word -- --^ Window identifier
|
||||||
|
, SDL.WindowConfig -- --^ Window config for given window
|
||||||
|
, SDL.WindowMode -- -- ^ Window mode to start in
|
||||||
|
)
|
||||||
|
]
|
||||||
|
-- ^ Window configurations
|
||||||
|
}
|
||||||
|
|
||||||
|
-- | Components to initialize in SDL.
|
||||||
|
data InitComponents
|
||||||
|
= All
|
||||||
|
| Only [SDL.InitFlag]
|
||||||
|
|
||||||
|
-- | Main type for defining the look, feel and action of the whole application.
|
||||||
|
data AffectionData = AffectionData
|
||||||
|
{ drawWindows :: [ AffectionWindow ] -- ^ SDL windows
|
||||||
|
, glContext :: [ AffectionContext ] -- ^ 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
|
||||||
|
type AffectionStateInner sd m = StateT sd m
|
||||||
|
|
||||||
|
-- | Affection's state monad
|
||||||
|
newtype AffectionState sd m a = AffectionState
|
||||||
|
{ runState :: AffectionStateInner sd m a }
|
||||||
|
deriving (Functor, Applicative, Monad, MonadIO, MonadState sd, MonadResource)
|
||||||
|
|
||||||
|
instance MP.MonadParallel m => MP.MonadParallel (AffectionState sd m)
|
||||||
|
|
||||||
|
type Affection a = AffectionState AffectionData ResIO a
|
||||||
|
|
||||||
|
type Angle = Double
|
||||||
|
|
||||||
|
data AffectionWindow = AffectionWindow
|
||||||
|
{ awWindow :: SDL.Window
|
||||||
|
, awReleaseKey :: ReleaseKey
|
||||||
|
, awMode :: SDL.WindowMode
|
||||||
|
}
|
||||||
|
|
||||||
|
data AffectionContext = AffectionContext
|
||||||
|
{ acContext :: SDL.GLContext
|
||||||
|
, acReleaseKey :: ReleaseKey
|
||||||
|
}
|
89
extern/affection/src/Affection/Util.hs
vendored
Normal file
89
extern/affection/src/Affection/Util.hs
vendored
Normal file
|
@ -0,0 +1,89 @@
|
||||||
|
module Affection.Util where
|
||||||
|
|
||||||
|
import Affection.Types
|
||||||
|
import Affection.Logging
|
||||||
|
import Affection.MessageBus.Message.WindowMessage
|
||||||
|
|
||||||
|
import SDL (($=))
|
||||||
|
import qualified SDL
|
||||||
|
import qualified Graphics.Rendering.OpenGL as GL
|
||||||
|
|
||||||
|
import System.Clock
|
||||||
|
|
||||||
|
import Data.String (fromString)
|
||||||
|
import Data.List (find)
|
||||||
|
|
||||||
|
import Control.Monad.State
|
||||||
|
|
||||||
|
-- | Prehandle SDL events
|
||||||
|
preHandleEvents :: [SDL.Event] -> Affection [SDL.EventPayload]
|
||||||
|
preHandleEvents evs =
|
||||||
|
return $ map SDL.eventPayload evs
|
||||||
|
|
||||||
|
-- | block a thread for a specified amount of time
|
||||||
|
delaySec
|
||||||
|
:: Int -- ^ Number of seconds
|
||||||
|
-> IO ()
|
||||||
|
delaySec dur = SDL.delay (fromIntegral $ dur * 1000)
|
||||||
|
|
||||||
|
-- | Get time since start but always the same in the current tick.
|
||||||
|
getElapsedTime :: Affection Double
|
||||||
|
getElapsedTime = gets elapsedTime
|
||||||
|
|
||||||
|
-- | Get delta time (time elapsed from last frame)
|
||||||
|
getDelta :: Affection Double
|
||||||
|
getDelta = gets deltaTime
|
||||||
|
|
||||||
|
-- | Toggle the Screen mode between 'SDL.Windowed' and 'SDL.FullscreenDesktop'.
|
||||||
|
-- Pauses the Engine in the process.
|
||||||
|
toggleScreen :: Word -> Affection ()
|
||||||
|
toggleScreen windowIdent = do
|
||||||
|
ad <- get
|
||||||
|
(stop, alteredWindowList) <- foldM
|
||||||
|
(\(stop, resWindows) (num, aw@(AffectionWindow window _ mode)) -> do
|
||||||
|
if stop || num == windowIdent
|
||||||
|
then do
|
||||||
|
newMode <- case mode of
|
||||||
|
SDL.FullscreenDesktop -> do
|
||||||
|
liftIO $ SDL.setWindowMode window SDL.Windowed
|
||||||
|
return SDL.Windowed
|
||||||
|
SDL.Windowed -> do
|
||||||
|
liftIO $ SDL.setWindowMode window SDL.FullscreenDesktop
|
||||||
|
return SDL.FullscreenDesktop
|
||||||
|
x -> do
|
||||||
|
liftIO $ logIO Warn ("Unexpected window mode: " <> fromString (show x))
|
||||||
|
return x
|
||||||
|
return (True, resWindows ++ [aw { awMode = newMode }])
|
||||||
|
else
|
||||||
|
return (stop, resWindows ++ [aw])
|
||||||
|
)
|
||||||
|
(False, [])
|
||||||
|
(zip [0..] (drawWindows ad))
|
||||||
|
if stop
|
||||||
|
then do
|
||||||
|
now <- liftIO $ getTime Monotonic
|
||||||
|
put ad
|
||||||
|
{ sysTime = now
|
||||||
|
, drawWindows = alteredWindowList
|
||||||
|
}
|
||||||
|
else
|
||||||
|
liftIO $ logIO Warn ("No window found with ident " <> fromString (show windowIdent))
|
||||||
|
|
||||||
|
-- | Fit the GL Viewport to Window size
|
||||||
|
fitViewport
|
||||||
|
:: Double -- ^ Image Ratio (width / height)
|
||||||
|
-> WindowMessage -- ^ Incoming Message. Listens only on
|
||||||
|
-- 'MsgWindowResize' and ignores all others.
|
||||||
|
-> Affection ()
|
||||||
|
fitViewport ratio (MsgWindowResize _ _ (SDL.V2 w h)) = do
|
||||||
|
liftIO $ logIO Verbose "Fitting Viewport to size"
|
||||||
|
if (fromIntegral w / fromIntegral h) > ratio
|
||||||
|
then do
|
||||||
|
let nw = floor (fromIntegral h * ratio)
|
||||||
|
dw = floor ((fromIntegral w - fromIntegral nw) / 2 :: Double)
|
||||||
|
GL.viewport $= (GL.Position dw 0, GL.Size nw h)
|
||||||
|
else do
|
||||||
|
let nh = floor (fromIntegral w / ratio)
|
||||||
|
dh = floor ((fromIntegral h - fromIntegral nh) / 2 :: Double)
|
||||||
|
GL.viewport $= (GL.Position 0 dh, GL.Size w nh)
|
||||||
|
fitViewport _ _ = return ()
|
42
extern/flake.lock
vendored
Normal file
42
extern/flake.lock
vendored
Normal file
|
@ -0,0 +1,42 @@
|
||||||
|
{
|
||||||
|
"nodes": {
|
||||||
|
"flake-utils": {
|
||||||
|
"locked": {
|
||||||
|
"lastModified": 1667395993,
|
||||||
|
"narHash": "sha256-nuEHfE/LcWyuSWnS8t12N1wc105Qtau+/OdUAjtQ0rA=",
|
||||||
|
"owner": "numtide",
|
||||||
|
"repo": "flake-utils",
|
||||||
|
"rev": "5aed5285a952e0b949eb3ba02c12fa4fcfef535f",
|
||||||
|
"type": "github"
|
||||||
|
},
|
||||||
|
"original": {
|
||||||
|
"owner": "numtide",
|
||||||
|
"repo": "flake-utils",
|
||||||
|
"type": "github"
|
||||||
|
}
|
||||||
|
},
|
||||||
|
"nixpkgs": {
|
||||||
|
"locked": {
|
||||||
|
"lastModified": 1669901374,
|
||||||
|
"narHash": "sha256-lObvfluyiZ9cgCMgKSrUOjzbx9Oap9949jlnNRPPYqg=",
|
||||||
|
"owner": "NixOS",
|
||||||
|
"repo": "nixpkgs",
|
||||||
|
"rev": "1c5443f6cdce419174f198141bd76a3fd9502950",
|
||||||
|
"type": "github"
|
||||||
|
},
|
||||||
|
"original": {
|
||||||
|
"owner": "NixOS",
|
||||||
|
"repo": "nixpkgs",
|
||||||
|
"type": "github"
|
||||||
|
}
|
||||||
|
},
|
||||||
|
"root": {
|
||||||
|
"inputs": {
|
||||||
|
"flake-utils": "flake-utils",
|
||||||
|
"nixpkgs": "nixpkgs"
|
||||||
|
}
|
||||||
|
}
|
||||||
|
},
|
||||||
|
"root": "root",
|
||||||
|
"version": 7
|
||||||
|
}
|
61
extern/flake.nix
vendored
Normal file
61
extern/flake.nix
vendored
Normal file
|
@ -0,0 +1,61 @@
|
||||||
|
{
|
||||||
|
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 = packages.${packageName}.env;
|
||||||
|
devShell = pkgs.mkShell {
|
||||||
|
buildInputs = with haskellPackages; [
|
||||||
|
haskell-language-server
|
||||||
|
ghcid
|
||||||
|
cabal-install
|
||||||
|
];
|
||||||
|
nativeBuildInputs = with pkgs; [
|
||||||
|
pkg-config
|
||||||
|
glib
|
||||||
|
SDL2
|
||||||
|
freetype
|
||||||
|
glew
|
||||||
|
];
|
||||||
|
inputsFrom = builtins.attrValues self.packages.${system};
|
||||||
|
};
|
||||||
|
});
|
||||||
|
}
|
||||||
|
|
61
flake.lock
61
flake.lock
|
@ -1,31 +1,28 @@
|
||||||
{
|
{
|
||||||
"nodes": {
|
"nodes": {
|
||||||
"affection-src": {
|
"affection-local": {
|
||||||
"inputs": {
|
"inputs": {
|
||||||
"flake-utils": "flake-utils",
|
"flake-utils": "flake-utils",
|
||||||
"nixpkgs": "nixpkgs"
|
"nixpkgs": "nixpkgs"
|
||||||
},
|
},
|
||||||
"locked": {
|
"locked": {
|
||||||
"lastModified": 1679777510,
|
"lastModified": 1,
|
||||||
"narHash": "sha256-FXtXhmUWtBt8944WIAXgB3OuIT446vUvfmccobXu6ts=",
|
"narHash": "sha256-jml+z0oNeFXjYreNdEMVmYPuFlDmxuYyXBZQ573Tido=",
|
||||||
"ref": "refs/heads/master",
|
"path": "./extern/affection",
|
||||||
"rev": "445b5807e021ff6fb70fdfa3f7e6a0a2b2221609",
|
"type": "path"
|
||||||
"revCount": 300,
|
|
||||||
"type": "git",
|
|
||||||
"url": "https://gitea.nek0.eu/nek0/affection"
|
|
||||||
},
|
},
|
||||||
"original": {
|
"original": {
|
||||||
"type": "git",
|
"path": "./extern/affection",
|
||||||
"url": "https://gitea.nek0.eu/nek0/affection"
|
"type": "path"
|
||||||
}
|
}
|
||||||
},
|
},
|
||||||
"flake-utils": {
|
"flake-utils": {
|
||||||
"locked": {
|
"locked": {
|
||||||
"lastModified": 1678901627,
|
"lastModified": 1667395993,
|
||||||
"narHash": "sha256-U02riOqrKKzwjsxc/400XnElV+UtPUQWpANPlyazjH0=",
|
"narHash": "sha256-nuEHfE/LcWyuSWnS8t12N1wc105Qtau+/OdUAjtQ0rA=",
|
||||||
"owner": "numtide",
|
"owner": "numtide",
|
||||||
"repo": "flake-utils",
|
"repo": "flake-utils",
|
||||||
"rev": "93a2b84fc4b70d9e089d029deacc3583435c2ed6",
|
"rev": "5aed5285a952e0b949eb3ba02c12fa4fcfef535f",
|
||||||
"type": "github"
|
"type": "github"
|
||||||
},
|
},
|
||||||
"original": {
|
"original": {
|
||||||
|
@ -35,15 +32,12 @@
|
||||||
}
|
}
|
||||||
},
|
},
|
||||||
"flake-utils_2": {
|
"flake-utils_2": {
|
||||||
"inputs": {
|
|
||||||
"systems": "systems"
|
|
||||||
},
|
|
||||||
"locked": {
|
"locked": {
|
||||||
"lastModified": 1681202837,
|
"lastModified": 1667395993,
|
||||||
"narHash": "sha256-H+Rh19JDwRtpVPAWp64F+rlEtxUWBAQW28eAi3SRSzg=",
|
"narHash": "sha256-nuEHfE/LcWyuSWnS8t12N1wc105Qtau+/OdUAjtQ0rA=",
|
||||||
"owner": "numtide",
|
"owner": "numtide",
|
||||||
"repo": "flake-utils",
|
"repo": "flake-utils",
|
||||||
"rev": "cfacdce06f30d2b68473a46042957675eebb3401",
|
"rev": "5aed5285a952e0b949eb3ba02c12fa4fcfef535f",
|
||||||
"type": "github"
|
"type": "github"
|
||||||
},
|
},
|
||||||
"original": {
|
"original": {
|
||||||
|
@ -54,11 +48,11 @@
|
||||||
},
|
},
|
||||||
"nixpkgs": {
|
"nixpkgs": {
|
||||||
"locked": {
|
"locked": {
|
||||||
"lastModified": 1679747397,
|
"lastModified": 1669901374,
|
||||||
"narHash": "sha256-btdjcq9pGJyKNbU5qQpKfWdEwoj+uazeSpchJjHrt3k=",
|
"narHash": "sha256-lObvfluyiZ9cgCMgKSrUOjzbx9Oap9949jlnNRPPYqg=",
|
||||||
"owner": "NixOS",
|
"owner": "NixOS",
|
||||||
"repo": "nixpkgs",
|
"repo": "nixpkgs",
|
||||||
"rev": "e235465058f37b1a4f222957352c1e373905521d",
|
"rev": "1c5443f6cdce419174f198141bd76a3fd9502950",
|
||||||
"type": "github"
|
"type": "github"
|
||||||
},
|
},
|
||||||
"original": {
|
"original": {
|
||||||
|
@ -69,11 +63,11 @@
|
||||||
},
|
},
|
||||||
"nixpkgs_2": {
|
"nixpkgs_2": {
|
||||||
"locked": {
|
"locked": {
|
||||||
"lastModified": 1681963077,
|
"lastModified": 1671901901,
|
||||||
"narHash": "sha256-8uJm8D6bJ7HEUkeHiWYbSfYKKhEIcgCsp/FQaGTS8RM=",
|
"narHash": "sha256-dTeqgnX1HfTeQ3+VtCXB3/t/ilE5iWmjYucwgSvpwnQ=",
|
||||||
"owner": "NixOS",
|
"owner": "NixOS",
|
||||||
"repo": "nixpkgs",
|
"repo": "nixpkgs",
|
||||||
"rev": "7ddf6698abe1eec2479590144701ca88fe2fcfe9",
|
"rev": "b1a9ae8dfd85d144ff1b268d6c7b47934358c9a1",
|
||||||
"type": "github"
|
"type": "github"
|
||||||
},
|
},
|
||||||
"original": {
|
"original": {
|
||||||
|
@ -84,25 +78,10 @@
|
||||||
},
|
},
|
||||||
"root": {
|
"root": {
|
||||||
"inputs": {
|
"inputs": {
|
||||||
"affection-src": "affection-src",
|
"affection-local": "affection-local",
|
||||||
"flake-utils": "flake-utils_2",
|
"flake-utils": "flake-utils_2",
|
||||||
"nixpkgs": "nixpkgs_2"
|
"nixpkgs": "nixpkgs_2"
|
||||||
}
|
}
|
||||||
},
|
|
||||||
"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",
|
"root": "root",
|
||||||
|
|
|
@ -4,10 +4,10 @@
|
||||||
inputs = {
|
inputs = {
|
||||||
nixpkgs.url = "github:NixOS/nixpkgs";
|
nixpkgs.url = "github:NixOS/nixpkgs";
|
||||||
flake-utils.url = "github:numtide/flake-utils";
|
flake-utils.url = "github:numtide/flake-utils";
|
||||||
affection-src.url = "git+https://gitea.nek0.eu/nek0/affection";
|
affection-local.url = "path:./extern/affection";
|
||||||
};
|
};
|
||||||
|
|
||||||
outputs = { self, nixpkgs, flake-utils, affection-src }:
|
outputs = { self, nixpkgs, flake-utils, affection-local }:
|
||||||
flake-utils.lib.eachDefaultSystem (system:
|
flake-utils.lib.eachDefaultSystem (system:
|
||||||
let
|
let
|
||||||
pkgs = nixpkgs.legacyPackages.${system};
|
pkgs = nixpkgs.legacyPackages.${system};
|
||||||
|
@ -22,7 +22,7 @@
|
||||||
packages.${packageName} = # (ref:haskell-package-def)
|
packages.${packageName} = # (ref:haskell-package-def)
|
||||||
haskellPackages.callCabal2nix packageName self rec {
|
haskellPackages.callCabal2nix packageName self rec {
|
||||||
# Dependency overrides go here
|
# Dependency overrides go here
|
||||||
affection = affection-src.defaultPackage.${system};
|
affection = affection-local.defaultPackage.${system};
|
||||||
};
|
};
|
||||||
|
|
||||||
defaultPackage = self.packages.${system}.${packageName};
|
defaultPackage = self.packages.${system}.${packageName};
|
||||||
|
|
63
shell.nix
63
shell.nix
|
@ -1,16 +1,53 @@
|
||||||
{ pkgs ? import <nixpkgs> {}}:
|
{ nixpkgs ? import <nixpkgs> {}, compiler ? "default", doBenchmark ? false }:
|
||||||
|
|
||||||
let
|
let
|
||||||
# create a modified haskell package set with my package inside it and broken dependencies
|
|
||||||
# jailbroken.
|
inherit (nixpkgs) pkgs;
|
||||||
hpkgs = pkgs.haskellPackages.override {
|
|
||||||
overrides = hself: hsuper: {
|
affection = with haskellPackages; callPackage(
|
||||||
pituicat = hself.callCabal2nix "mateamt" (gitignore ./.) {};
|
{ mkDerivation, base, bytestring, clock, containers, glib, linear
|
||||||
affection = hself.callCabal2nix "affection" (gitignore ./extern/affection) {};
|
, monad-loops, monad-parallel, mtl, OpenGL, sdl2, stdenv, stm, text
|
||||||
#pg-transact = with pkgs.haskell.lib;
|
, uuid, vector
|
||||||
# doJailbreak (unmarkBroken (dontCheck hsuper.pg-transact));
|
}:
|
||||||
};
|
mkDerivation {
|
||||||
};
|
pname = "affection";
|
||||||
gitignore = dir: pkgs.nix-gitignore.gitignoreSource [] dir;
|
version = "0.0.0.10";
|
||||||
|
src = ./extern/affection;
|
||||||
|
configureFlags = [ "-fverbose" ];
|
||||||
|
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 = pkgs.lib.licenses.lgpl3;
|
||||||
|
}) {};
|
||||||
|
|
||||||
|
f = { mkDerivation, aeson, base, bytestring, containers, derive-storable
|
||||||
|
, JuicyPixels, JuicyPixels-extra, linear, monad-loops, OpenGL, OpenGLRaw
|
||||||
|
, stdenv, sdl2, StateVar, stm, text, vector}:
|
||||||
|
mkDerivation {
|
||||||
|
pname = "pituicat";
|
||||||
|
version = "0.0.0.0";
|
||||||
|
src = ./.;
|
||||||
|
isLibrary = false;
|
||||||
|
isExecutable = true;
|
||||||
|
executableHaskellDepends = [ aeson affection base bytestring containers
|
||||||
|
derive-storable JuicyPixels JuicyPixels-extra linear monad-loops OpenGL
|
||||||
|
OpenGLRaw sdl2 StateVar stm text vector];
|
||||||
|
license = pkgs.lib.licenses.gpl3;
|
||||||
|
};
|
||||||
|
|
||||||
|
haskellPackages = if compiler == "default"
|
||||||
|
then pkgs.haskellPackages
|
||||||
|
else pkgs.haskell.packages.${compiler};
|
||||||
|
|
||||||
|
variant = if doBenchmark then pkgs.haskell.lib.doBenchmark else pkgs.lib.id;
|
||||||
|
|
||||||
|
drv = variant (haskellPackages.callPackage f {});
|
||||||
|
|
||||||
in
|
in
|
||||||
hpkgs.pituicat.env
|
|
||||||
|
if pkgs.lib.inNixShell then drv.env else drv
|
||||||
|
|
|
@ -46,25 +46,24 @@ readLayer (_, path) (V2 tx ty) = do
|
||||||
let width = imageWidth img
|
let width = imageWidth img
|
||||||
height = imageHeight img
|
height = imageHeight img
|
||||||
layer = V.foldl
|
layer = V.foldl
|
||||||
(\acc (py, px) -> case (pixelAt img px py) of
|
(\acc (py, px) -> case pixelAt img px py of
|
||||||
(PixelRGBA8 r g b _) -> if r >= 253
|
(PixelRGBA8 r g b _) -> if r >= 253
|
||||||
then
|
then
|
||||||
acc `V.snoc` Tile
|
acc `V.snoc` Tile
|
||||||
(V2 (fromIntegral px) (fromIntegral py))
|
(V2 (fromIntegral px) (fromIntegral py))
|
||||||
( (V2
|
( V2
|
||||||
((255 - fromIntegral g) * (32 / tx))
|
((255 - fromIntegral g) * (32 / tx))
|
||||||
(1 - (255 - fromIntegral b + 1) * (32 / ty))
|
(1 - (255 - fromIntegral b + 1) * (32 / ty))
|
||||||
)
|
, V2
|
||||||
, (V2
|
|
||||||
((255 - fromIntegral g + 1) * (32 / tx))
|
((255 - fromIntegral g + 1) * (32 / tx))
|
||||||
(1 - (255 - fromIntegral b) * (32 / ty))
|
(1 - (255 - fromIntegral b) * (32 / ty))
|
||||||
)
|
|
||||||
)
|
)
|
||||||
(case r of
|
(case r of
|
||||||
255 -> Solid
|
255 -> Solid
|
||||||
254 -> Platform
|
254 -> Platform
|
||||||
_ -> Decoration
|
_ -> Decoration
|
||||||
)
|
)
|
||||||
|
False
|
||||||
else
|
else
|
||||||
acc
|
acc
|
||||||
)
|
)
|
||||||
|
|
|
@ -6,20 +6,16 @@ import Affection as A
|
||||||
|
|
||||||
import Linear
|
import Linear
|
||||||
|
|
||||||
import Data.String (fromString)
|
|
||||||
|
|
||||||
import Data.List (sortBy)
|
|
||||||
|
|
||||||
-- internal imports
|
-- internal imports
|
||||||
|
|
||||||
import Physics.Classes.Mass
|
import Physics.Classes.Mass
|
||||||
|
|
||||||
data CollisionResult time direction
|
data CollisionResult direction
|
||||||
= NoCollision
|
= NoCollision
|
||||||
| CollisionImminent
|
-- | CollisionImminent
|
||||||
{ collisionTime :: time
|
-- { collisionTime :: time
|
||||||
, collisionDirection :: direction
|
-- , collisionDirection :: direction
|
||||||
}
|
-- }
|
||||||
| OverlapCollision
|
| OverlapCollision
|
||||||
{ collisionDepth :: direction
|
{ collisionDepth :: direction
|
||||||
}
|
}
|
||||||
|
@ -28,6 +24,33 @@ data CollisionResult time direction
|
||||||
-- | Typeclass for implementing collision results on objects.
|
-- | Typeclass for implementing collision results on objects.
|
||||||
class (Show c, Mass c) => Collidible c where
|
class (Show c, Mass c) => Collidible c where
|
||||||
|
|
||||||
|
-- | Final position of the object in the previous timestep
|
||||||
|
prevPosition :: c -> V2 Double
|
||||||
|
|
||||||
|
-- | Aggregated impact forces in a simulation step
|
||||||
|
impactForces :: c -> V2 Double
|
||||||
|
|
||||||
|
-- | Overwrite the impact forces of the mass object
|
||||||
|
impactForcesUpdater :: c -> (V2 Double -> c)
|
||||||
|
|
||||||
|
-- | reset impact forces vector at the beginning of a simulation step
|
||||||
|
resetImpactForces :: c -> c
|
||||||
|
resetImpactForces c = impactForcesUpdater c (V2 0 0)
|
||||||
|
|
||||||
|
-- | Add a impact force to the impact forces acting on the mass object
|
||||||
|
addImpactForce
|
||||||
|
:: c
|
||||||
|
-> V2 Double
|
||||||
|
-> c
|
||||||
|
addImpactForce c force =
|
||||||
|
impactForcesUpdater c (impactForces c + force)
|
||||||
|
|
||||||
|
-- | Flag indicating a collision during the current time step
|
||||||
|
collisionOccured :: c -> Bool
|
||||||
|
|
||||||
|
-- | Update the collision occurence flag
|
||||||
|
updateCollisionOccurence :: c -> Bool -> c
|
||||||
|
|
||||||
-- | returns the bottom left and top right corners relative to the objects
|
-- | returns the bottom left and top right corners relative to the objects
|
||||||
-- positional vector of the axis aligned bounding box (AABB) serving here
|
-- positional vector of the axis aligned bounding box (AABB) serving here
|
||||||
-- as collision boundaries.
|
-- as collision boundaries.
|
||||||
|
@ -39,233 +62,75 @@ class (Show c, Mass c) => Collidible c where
|
||||||
|
|
||||||
collisionCheck
|
collisionCheck
|
||||||
:: (Collidible other)
|
:: (Collidible other)
|
||||||
=> Double -- ^ Time step length
|
=> c -- ^ First object
|
||||||
-> c -- ^ First object
|
|
||||||
-> other -- ^ second object
|
-> other -- ^ second object
|
||||||
-> CollisionResult Double (V2 Int) -- ^ Do the objects collide?
|
-> CollisionResult (V2 Double) -- ^ Do the objects collide?
|
||||||
collisionCheck dt m1 m2 =
|
collisionCheck m1 m2 =
|
||||||
let d1@(V2 d1x d1y) = velocity m1
|
let (V2 p1x p1y) = position m1
|
||||||
d2@(V2 d2x d2y) = velocity m2
|
(V2 p2x p2y) = position m2
|
||||||
p1@(V2 p1x p1y) = position m1
|
(V2 b1minx b1miny, V2 b1maxx b1maxy) = boundary m1
|
||||||
p2@(V2 p2x p2y) = position m2
|
(V2 b2minx b2miny, V2 b2maxx b2maxy) = boundary m2
|
||||||
(m1b1@(V2 m1b1x m1b1y), m1b2@(V2 m1b2x m1b2y)) = boundary m1
|
getCoordinates
|
||||||
(m2b1@(V2 m2b1x m2b1y), m2b2@(V2 m2b2x m2b2y)) = boundary m2
|
| p1x <= p2x && p1y <= p2y =
|
||||||
(V2 pm1b1x pm1b1y, V2 pm1b2x pm1b2y) = (p1 +) <$> boundary m1
|
let x1 = p1x + b1maxx
|
||||||
(V2 pm2b1x pm2b1y, V2 pm2b2x pm2b2y) = (p2 +) <$> boundary m2
|
y1 = p1y + b1maxy
|
||||||
m1p1@(V2 m1p1x m1p1y) = p1 + m1b1
|
x2 = p2x + b2minx
|
||||||
m1p2 = p1 + V2 m1b1x m1b2y
|
y2 = p2y + b2minx
|
||||||
m1p3@(V2 m1p3x m1p3y) = p1 + m1b2
|
in (x1, y1, x2, y2)
|
||||||
m1p4@(V2 m1p4x _) = p1 + V2 m1b2x m1b1y
|
| p1x > p2x && p1y <= p2y =
|
||||||
m2p1@(V2 m2p1x m2p1y) = p2 + m2b1
|
let x1 = p1x + b1minx
|
||||||
m2p2 = p2 + V2 m2b1x m2b2y
|
y1 = p1y + b1maxy
|
||||||
m2p3@(V2 m2p3x m2p3y) = p2 + m2b2
|
x2 = p2x + b2maxx
|
||||||
m2p4 = p2 + V2 m2b2x m2b1y
|
y2 = p2y + b2miny
|
||||||
(V2 b1minx b1miny, V2 b1maxx b1maxy) =
|
in (x1, y1, x2, y2)
|
||||||
( V2
|
| p1x <= p2x && p1y > p2y =
|
||||||
((\(V2 x _) -> x) (if d1x < 0 then m1p1 + ((dt *) <$> d1) else m1p1))
|
let x1 = p1x + b1maxx
|
||||||
((\(V2 _ y) -> y) (if d1y < 0 then m1p1 + ((dt *) <$> d1) else m1p1))
|
y1 = p1y + b1miny
|
||||||
, V2
|
x2 = p2x + b2minx
|
||||||
((\(V2 x _) -> x) (if d1x < 0 then m1p3 else m1p3 + ((dt *) <$> d1)))
|
y2 = p2y + b2maxy
|
||||||
((\(V2 _ y) -> y) (if d1y < 0 then m1p3 else m1p3 + ((dt *) <$> d1)))
|
in (x1, y1, x2, y2)
|
||||||
)
|
| otherwise =
|
||||||
(V2 b2minx b2miny, V2 b2maxx b2maxy) =
|
let x1 = p1x + b1minx
|
||||||
( V2
|
y1 = p1y + b1miny
|
||||||
((\(V2 x _) -> x) (if d2x < 0 then m2p1 + ((dt *) <$> d2) else m2p1))
|
x2 = p2x + b2maxx
|
||||||
((\(V2 _ y) -> y) (if d2y < 0 then m2p1 + ((dt *) <$> d2) else m2p1))
|
y2 = p2y + b2maxy
|
||||||
, V2
|
in (x1, y1, x2, y2)
|
||||||
((\(V2 x _) -> x) (if d2x < 0 then m2p3 else m2p3 + ((dt *) <$> d2)))
|
(ox1, oy1, ox2, oy2) = getCoordinates
|
||||||
((\(V2 _ y) -> y) (if d2y < 0 then m2p3 else m2p3 + ((dt *) <$> d2)))
|
|
||||||
)
|
|
||||||
broadphaseOverlap =
|
|
||||||
let in2 =
|
|
||||||
(b1minx > b2minx && b1minx < b2maxx &&
|
|
||||||
b1miny > b2miny && b1miny < b2maxy) ||
|
|
||||||
(b1maxx > b2minx && b1maxx < b2maxx &&
|
|
||||||
b1miny > b2miny && b1miny < b2maxy) ||
|
|
||||||
(b1minx > b2minx && b1minx < b2maxx &&
|
|
||||||
b1maxy > b2miny && b1maxy < b2maxy) ||
|
|
||||||
(b1maxx > b2minx && b1maxx < b2maxx &&
|
|
||||||
b1maxy > b2miny && b1maxy < b2maxy)
|
|
||||||
in1 =
|
|
||||||
(b2minx > b1minx && b2minx < b1maxx &&
|
|
||||||
b2miny > b1miny && b2miny < b1maxy) ||
|
|
||||||
(b2maxx > b1minx && b2maxx < b1maxx &&
|
|
||||||
b2miny > b1miny && b2miny < b1maxy) ||
|
|
||||||
(b2minx > b1minx && b2minx < b1maxx &&
|
|
||||||
b2maxy > b1miny && b2maxy < b1maxy) ||
|
|
||||||
(b2maxx > b1minx && b2maxx < b1maxx &&
|
|
||||||
b2maxy > b1miny && b2maxy < b1maxy)
|
|
||||||
in
|
|
||||||
in2 || in1
|
|
||||||
overlap =
|
|
||||||
let in1 =
|
|
||||||
(pm1b1x > pm2b1x && pm1b1x < pm2b2x &&
|
|
||||||
pm1b1y > pm2b1y && pm1b1y < pm2b2y) ||
|
|
||||||
(pm1b2x > pm2b1x && pm1b2x < pm2b2x &&
|
|
||||||
pm1b1y > pm2b1y && pm1b1y < pm2b2y) ||
|
|
||||||
(pm1b1x > pm2b1x && pm1b2x < pm2b2x &&
|
|
||||||
pm1b2y > pm2b1y && pm1b2y < pm2b2y) ||
|
|
||||||
(pm1b2x > pm2b1x && pm1b2x < pm2b2x &&
|
|
||||||
pm1b2y > pm2b1y && pm1b2y < pm2b2y)
|
|
||||||
in2 =
|
|
||||||
(pm2b1x > pm1b1x && pm2b1x < pm1b2x &&
|
|
||||||
pm2b1y > pm1b1y && pm2b1y < pm1b2y) ||
|
|
||||||
(pm2b2x > pm1b1x && pm2b2x < pm1b2x &&
|
|
||||||
pm2b1y > pm1b1y && pm2b1y < pm1b2y) ||
|
|
||||||
(pm2b1x > pm1b1x && pm2b2x < pm1b2x &&
|
|
||||||
pm2b2y > pm1b1y && pm2b2y < pm1b2y) ||
|
|
||||||
(pm2b2x > pm1b1x && pm2b2x < pm1b2x &&
|
|
||||||
pm2b2y > pm1b1y && pm2b2y < pm1b2y)
|
|
||||||
in
|
|
||||||
in2 || in1
|
|
||||||
tx =
|
|
||||||
let p1x = (\(V2 x _) -> x) (if d1x < 0 then m1p1 else m1p4)
|
|
||||||
p2x = (\(V2 x _) -> x) (if d1x < 0 then m2p4 else m2p1)
|
|
||||||
in
|
|
||||||
if d2x - d1x == 0 then dt else (p1x - p2x) / (d2x - d1x)
|
|
||||||
ty =
|
|
||||||
let p1y = (\(V2 _ y) -> y) (if d1y < 0 then m1p1 else m1p2)
|
|
||||||
p2y = (\(V2 _ y) -> y) (if d1y < 0 then m2p2 else m2p1)
|
|
||||||
in
|
|
||||||
if d2y - d1y == 0 then dt else (p1y - p2y) / (d2y - d1y)
|
|
||||||
in
|
in
|
||||||
if broadphaseOverlap
|
if ox2 - ox1 < 0 || oy2 - oy1 < 0
|
||||||
then
|
then OverlapCollision
|
||||||
let coll xdir =
|
(V2
|
||||||
let (p11, p12, p21, p22)
|
(min 0 (ox2 - ox1) * (- 1))
|
||||||
| xdir =
|
(min 0 (oy2 - oy1) * (- 1))
|
||||||
if d1x < 0
|
)
|
||||||
then
|
else
|
||||||
(m1p1, m1p2, m2p4, m2p3)
|
NoCollision
|
||||||
else
|
|
||||||
(m1p4, m1p3, m2p1, m2p2)
|
|
||||||
| otherwise =
|
|
||||||
if d1y < 0
|
|
||||||
then
|
|
||||||
(m1p1, m1p4, m2p2, m2p3)
|
|
||||||
else
|
|
||||||
(m1p2, m1p3, m2p1, m2p4)
|
|
||||||
vselector (V2 x y) = if xdir then y else x
|
|
||||||
tick = if xdir then tx else ty
|
|
||||||
g1s = vselector $ p11 + ((tick *) <$> d1)
|
|
||||||
g1e = vselector $ p12 + ((tick *) <$> d1)
|
|
||||||
g2s = vselector $ p21 + ((tick *) <$> d2)
|
|
||||||
g2e = vselector $ p22 + ((tick *) <$> d2)
|
|
||||||
s11 = (g1s - g2s) / (g2e - g2s)
|
|
||||||
s12 = (g1e - g2s) / (g2e - g2s)
|
|
||||||
s21 = (g2s - g1s) / (g1e - g1s)
|
|
||||||
s22 = (g2e - g1s) / (g1e - g1s)
|
|
||||||
in
|
|
||||||
any (\x -> x > 0 && x < 1) [s11, s12, s21 ,s22]
|
|
||||||
res = case (tx < dt, ty < dt, tx < ty, coll True, coll False) of
|
|
||||||
(True, _, True, True, _) ->
|
|
||||||
CollisionImminent tx (V2 (floor $ signum d1x) 0)
|
|
||||||
(_, True, False, _, True) ->
|
|
||||||
CollisionImminent ty (V2 0 (floor $ signum d1y))
|
|
||||||
(True, _, False, True, False) ->
|
|
||||||
CollisionImminent tx (V2 (floor $ signum d1x) 0)
|
|
||||||
(_, True, True, False, True) ->
|
|
||||||
CollisionImminent ty (V2 0 (floor $ signum d1y))
|
|
||||||
(_, _, _, False, False) ->
|
|
||||||
NoCollision
|
|
||||||
(_, _, True, _, _) ->
|
|
||||||
A.log A.Debug "CORNER CASE!" NoCollision
|
|
||||||
(False, False, _, _, _) ->
|
|
||||||
NoCollision
|
|
||||||
x -> error $
|
|
||||||
"Unhandled combination of collision check results: "
|
|
||||||
<> fromString (show x)
|
|
||||||
in
|
|
||||||
case res of
|
|
||||||
CollisionImminent _ _ ->
|
|
||||||
res
|
|
||||||
NoCollision ->
|
|
||||||
if overlap
|
|
||||||
then
|
|
||||||
let xoverlap = floor (maximum (filter (0 >)
|
|
||||||
[ pm2b2x - pm2b1x
|
|
||||||
, pm2b1x - pm1b2x
|
|
||||||
]))
|
|
||||||
yoverlap = floor (maximum (filter (0 >)
|
|
||||||
[ pm2b1y - pm1b2y
|
|
||||||
, pm2b2y - pm1b1y
|
|
||||||
]))
|
|
||||||
in
|
|
||||||
if xoverlap < yoverlap
|
|
||||||
then
|
|
||||||
if xoverlap < 0
|
|
||||||
then OverlapCollision
|
|
||||||
(V2 xoverlap 0)
|
|
||||||
else
|
|
||||||
NoCollision
|
|
||||||
else
|
|
||||||
if yoverlap < 0
|
|
||||||
then OverlapCollision
|
|
||||||
(V2 0 yoverlap)
|
|
||||||
else NoCollision
|
|
||||||
else NoCollision
|
|
||||||
_ -> A.log
|
|
||||||
A.Error
|
|
||||||
"Premature overlap collision detection"
|
|
||||||
NoCollision
|
|
||||||
else
|
|
||||||
NoCollision
|
|
||||||
|
|
||||||
-- | This Function is called for every collision on both colliding objects.
|
-- | This Function is called for every collision on both colliding objects.
|
||||||
collide
|
collide
|
||||||
:: (Collidible other)
|
:: (Collidible other)
|
||||||
=> c -- ^ Original object
|
=> c -- ^ Original object
|
||||||
-> [(other, CollisionResult Double (V2 Int))] -- ^ Collision partners and results
|
-> [(other, CollisionResult (V2 Double))] -- ^ Collision partners and results
|
||||||
-> Double -- ^ Timestep length
|
-> Double -- ^ Timestep length
|
||||||
-> c -- ^ Updated original object
|
-> c -- ^ Updated original object
|
||||||
collide coll1 collrs = elasticCollision 0.9 coll1 (head collrs)
|
collide coll1 collrs dt =
|
||||||
|
foldl (\acc a -> elasticCollision 0.9 acc a dt) coll1 collrs
|
||||||
|
|
||||||
-- | Implementation of a dampened elastic collision used as default collision
|
-- | Implementation of a dampened elastic collision used as default collision
|
||||||
-- implementation of the collision reaction
|
-- implementation of the collision reaction
|
||||||
elasticCollision
|
elasticCollision
|
||||||
:: (Collidible c1, Collidible c2)
|
:: (Collidible c1, Collidible c2)
|
||||||
=> Double
|
=> Double -- ^ Restitution coefficient
|
||||||
-> c1
|
-> c1 -- ^ First collision partner
|
||||||
-> (c2, CollisionResult Double (V2 Int))
|
-> (c2, CollisionResult (V2 Double)) -- ^ Second collision partner with collision result
|
||||||
-> Double -- ^ Timestep length
|
-> Double -- ^ Timestep length
|
||||||
-> c1
|
-> c1 -- ^ Updated first collision partner
|
||||||
elasticCollision _ mo1 (_, NoCollision) _ = mo1
|
elasticCollision _ mo1 (_, NoCollision) _ = mo1
|
||||||
elasticCollision damping mo1 (mo2, CollisionImminent ddt (V2 dirx diry)) dt =
|
elasticCollision restitution mo1 (mo2, OverlapCollision depth) dt =
|
||||||
let v1@(V2 v1x v1y) = velocity mo1
|
let dvel = (velocity mo1 - velocity mo2) * normalize depth
|
||||||
(V2 v2x v2y) = velocity mo2
|
j = (restitution + 1) * (- (dvel `dot` dvel)) /
|
||||||
p1 = position mo1
|
(1 / mass mo1 + 1 / mass mo2)
|
||||||
m1 = mass mo1
|
fi = (* (j / dt)) <$> normalize depth
|
||||||
m2 = mass mo2
|
|
||||||
v1x' = 2 * (m1 * v1x + m2 * v2x) / (m1 + m2) - v1x
|
|
||||||
v1y' = 2 * (m1 * v1y + m2 * v2y) / (m1 + m2) - v1y
|
|
||||||
nvel = if m1 == recip 0
|
|
||||||
then V2 0 0
|
|
||||||
else (damping *) <$>
|
|
||||||
if m2 == recip 0
|
|
||||||
then
|
|
||||||
if dirx /= 0
|
|
||||||
then V2 (-v1x) v1y
|
|
||||||
else V2 v1x (-v1y)
|
|
||||||
else V2 v1x' v1y'
|
|
||||||
in
|
in
|
||||||
velocityUpdater
|
positionUpdater (addImpactForce (updateCollisionOccurence mo1 True) fi)
|
||||||
mo1
|
(position mo1 - depth)
|
||||||
nvel
|
|
||||||
elasticCollision damping mo1 (mo2, OverlapCollision depth) dt =
|
|
||||||
let m1 = mass mo1
|
|
||||||
m2 = mass mo2
|
|
||||||
(V2 dx dy) = (/ dt) . fromIntegral <$> depth
|
|
||||||
v1x' = 2 * (m1 * dx + m2 * (-dx)) / (m1 + m2) - dx
|
|
||||||
v1y' = 2 * (m1 * dy + m2 * (-dy)) / (m1 + m2) - dy
|
|
||||||
nvel = if m1 == recip 0
|
|
||||||
then V2 0 0
|
|
||||||
else (damping *) <$>
|
|
||||||
if m2 == recip 0
|
|
||||||
then
|
|
||||||
if dx /= 0
|
|
||||||
then V2 (-v1x') v1y'
|
|
||||||
else V2 v1x' (-v1y')
|
|
||||||
else
|
|
||||||
V2 v1x' v1y'
|
|
||||||
in
|
|
||||||
velocityUpdater mo1 nvel
|
|
||||||
|
|
|
@ -9,11 +9,11 @@ class Mass m where
|
||||||
-- | The mass of the mass object.
|
-- | The mass of the mass object.
|
||||||
mass :: m -> Double
|
mass :: m -> Double
|
||||||
|
|
||||||
-- | Retrieve the acceleration of the mass object.
|
-- | Retrieve the position of the mass object.
|
||||||
acceleration :: m -> V2 Double
|
position :: m -> V2 Double
|
||||||
|
|
||||||
-- | Overwrite the acceleration of the mass object.
|
-- | Overwrite the position of the mass object.
|
||||||
accelerationUpdater :: m -> (V2 Double -> m)
|
positionUpdater :: m -> (V2 Double -> m)
|
||||||
|
|
||||||
-- | retrieve the velocity of the mass object.
|
-- | retrieve the velocity of the mass object.
|
||||||
velocity :: m -> V2 Double
|
velocity :: m -> V2 Double
|
||||||
|
@ -21,42 +21,42 @@ class Mass m where
|
||||||
-- | Overwrite the velocity of the mass object.
|
-- | Overwrite the velocity of the mass object.
|
||||||
velocityUpdater :: m -> (V2 Double -> m)
|
velocityUpdater :: m -> (V2 Double -> m)
|
||||||
|
|
||||||
-- | Retrieve the position of the mass object.
|
-- | Total force acting on a particle in one simulation step
|
||||||
position :: m -> V2 Double
|
forces :: m -> V2 Double
|
||||||
|
|
||||||
-- | Overwrite the position of the mass object.
|
-- | Overwrite the forces acting on a particle
|
||||||
positionUpdater :: m -> (V2 Double -> m)
|
forcesUpdater :: m -> (V2 Double -> m)
|
||||||
|
|
||||||
-- | The update function to let a mass react to gravitational pull.
|
-- | Reset forces vector for the begining of a new simulation step
|
||||||
-- Apply all accelerations before calling the default implementation of
|
resetForces :: m -> m
|
||||||
-- this function, since it will add the gravitational pull to already
|
resetForces m = forcesUpdater m (V2 0 0)
|
||||||
-- existing accelerations.
|
|
||||||
gravitate
|
-- | Calculate the loads or forces acting on the mass object except for
|
||||||
:: V2 Double -- ^ Vector of gravitational acceleration
|
-- collision forces.
|
||||||
-> m -- ^ Original mass object
|
addLoads
|
||||||
|
:: m -- ^ The mass object
|
||||||
|
-> V2 Double -- ^ force to be aggregated acting on the particle (e.g.: gravity)
|
||||||
|
-> m -- ^ Resulting mass object
|
||||||
|
addLoads m vec =
|
||||||
|
forcesUpdater m (forces m + vec)
|
||||||
|
|
||||||
|
-- | Euler integration updates
|
||||||
|
updateByEuler
|
||||||
|
:: m -- ^ The mass object
|
||||||
|
-> Double -- ^ Time step in fraction of a second
|
||||||
|
-> m -- ^ Resulting mass object
|
||||||
|
updateByEuler m dt =
|
||||||
|
let acc = (/ mass m) <$> forces m
|
||||||
|
dvel = (* dt) <$> acc
|
||||||
|
nvel = velocity m + dvel
|
||||||
|
dpos = (* dt) <$> nvel
|
||||||
|
npos = position m + dpos
|
||||||
|
in
|
||||||
|
resetForces $ positionUpdater (velocityUpdater m nvel) npos
|
||||||
|
|
||||||
|
calculateLoads
|
||||||
|
:: m -- ^ Original mass object
|
||||||
|
-> V2 Double -- ^ Gravitational force vector
|
||||||
-> m -- ^ Updated mass object
|
-> m -- ^ Updated mass object
|
||||||
gravitate g m =
|
calculateLoads =
|
||||||
let acc = acceleration m + g
|
addLoads
|
||||||
in
|
|
||||||
accelerationUpdater m acc
|
|
||||||
|
|
||||||
-- | Apply acceleration to mass object und thus change its velocity
|
|
||||||
accelerate
|
|
||||||
:: Double -- ^ Time step duration
|
|
||||||
-> m -- ^ Original mass object
|
|
||||||
-> m -- ^ Updated mass object
|
|
||||||
accelerate dt m =
|
|
||||||
let vel = velocity m + ((dt *) <$> acceleration m)
|
|
||||||
in
|
|
||||||
velocityUpdater m vel
|
|
||||||
|
|
||||||
-- | Apply velocity to mass object and thus change its position
|
|
||||||
-- Changes in position smaller than around half a pixel per second are ignored.
|
|
||||||
move
|
|
||||||
:: Double -- ^ Time step duration
|
|
||||||
-> m -- ^ Original mass object
|
|
||||||
-> m -- ^ Updated mass object
|
|
||||||
move dt m =
|
|
||||||
let dpos = (dt *) <$> velocity m
|
|
||||||
in
|
|
||||||
positionUpdater m (position m + dpos)
|
|
||||||
|
|
|
@ -78,6 +78,9 @@ load level progress = do
|
||||||
(V2 0 0)
|
(V2 0 0)
|
||||||
(V2 0 0)
|
(V2 0 0)
|
||||||
(V2 0 0)
|
(V2 0 0)
|
||||||
|
(V2 0 0)
|
||||||
|
(V2 0 0)
|
||||||
|
(V2 0 0)
|
||||||
100
|
100
|
||||||
tex
|
tex
|
||||||
False
|
False
|
||||||
|
@ -85,13 +88,18 @@ load level progress = do
|
||||||
ViewRight
|
ViewRight
|
||||||
[]
|
[]
|
||||||
False
|
False
|
||||||
|
False
|
||||||
oil = PowerUp
|
oil = PowerUp
|
||||||
(realToFrac <$> (startpos + V2 200 0))
|
(realToFrac <$> (startpos + V2 200 0))
|
||||||
(V2 0 0)
|
(V2 0 0)
|
||||||
(V2 0 0)
|
(V2 0 0)
|
||||||
|
(V2 0 0)
|
||||||
5000
|
5000
|
||||||
tex
|
tex
|
||||||
(EffectHolder 5 SpeedUp)
|
(EffectHolder 5 SpeedUp)
|
||||||
|
(V2 0 0)
|
||||||
|
(V2 0 0)
|
||||||
|
False
|
||||||
|
|
||||||
|
|
||||||
bind shader
|
bind shader
|
||||||
|
|
|
@ -5,6 +5,8 @@ module Scenes.Test.Update where
|
||||||
|
|
||||||
import Affection as A
|
import Affection as A
|
||||||
|
|
||||||
|
import Linear
|
||||||
|
|
||||||
import Control.Concurrent.STM
|
import Control.Concurrent.STM
|
||||||
|
|
||||||
import Data.List (sortOn)
|
import Data.List (sortOn)
|
||||||
|
@ -21,6 +23,7 @@ import Scenes.Test.Types
|
||||||
import Classes
|
import Classes
|
||||||
import Types
|
import Types
|
||||||
import Physics
|
import Physics
|
||||||
|
import Util
|
||||||
|
|
||||||
update
|
update
|
||||||
:: Test
|
:: Test
|
||||||
|
@ -55,10 +58,10 @@ update level dt = liftIO $ do
|
||||||
let partners =
|
let partners =
|
||||||
V.foldl
|
V.foldl
|
||||||
(\jacc (qInd, tangible2) ->
|
(\jacc (qInd, tangible2) ->
|
||||||
let res = collisionCheck dt tangible1 tangible2
|
let res = collisionCheck tangible1 tangible2
|
||||||
in
|
in
|
||||||
case res of
|
case res of
|
||||||
c@(CollisionImminent _ _) ->
|
c@(OverlapCollision _) ->
|
||||||
if qInd /= index
|
if qInd /= index
|
||||||
then jacc `V.snoc` (qInd, c)
|
then jacc `V.snoc` (qInd, c)
|
||||||
else jacc
|
else jacc
|
||||||
|
@ -71,7 +74,9 @@ update level dt = liftIO $ do
|
||||||
then iacc
|
then iacc
|
||||||
else iacc `V.snoc`
|
else iacc `V.snoc`
|
||||||
( index
|
( index
|
||||||
, sortOn (collisionTime . snd) (V.toList partners)
|
, sortOn
|
||||||
|
((\v -> collisionDepth v `dot` collisionDepth v) . snd)
|
||||||
|
(V.toList partners)
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
V.empty
|
V.empty
|
||||||
|
@ -93,7 +98,10 @@ update level dt = liftIO $ do
|
||||||
d
|
d
|
||||||
dt
|
dt
|
||||||
in
|
in
|
||||||
inter
|
resetImpactForces $ flip updateCollisionOccurence False $
|
||||||
|
if collisionOccured inter
|
||||||
|
then addLoads inter (impactForces inter)
|
||||||
|
else addLoads inter constG
|
||||||
)
|
)
|
||||||
digest
|
digest
|
||||||
in
|
in
|
||||||
|
@ -112,11 +120,11 @@ update level dt = liftIO $ do
|
||||||
(\acc@(castAcc, pAcc, _) input ->
|
(\acc@(castAcc, pAcc, _) input ->
|
||||||
case input of
|
case input of
|
||||||
TCast c ->
|
TCast c ->
|
||||||
(castAcc `V.snoc` move dt c, pAcc, mnewCat)
|
(castAcc `V.snoc` updateByEuler c dt, pAcc, mnewCat)
|
||||||
TPowerUp p ->
|
TPowerUp p ->
|
||||||
(castAcc, pAcc `V.snoc` move dt p, mnewCat)
|
(castAcc, pAcc `V.snoc` updateByEuler p dt, mnewCat)
|
||||||
TPlayer ncat ->
|
TPlayer ncat ->
|
||||||
(castAcc, pAcc, Just (move dt ncat))
|
(castAcc, pAcc, Just (updateByEuler ncat dt))
|
||||||
TTile _ ->
|
TTile _ ->
|
||||||
acc
|
acc
|
||||||
)
|
)
|
||||||
|
@ -125,144 +133,3 @@ update level dt = liftIO $ do
|
||||||
writeTVar (testCast level) newCast
|
writeTVar (testCast level) newCast
|
||||||
writeTVar (testPowerups level) newPowerups
|
writeTVar (testPowerups level) newPowerups
|
||||||
writeTVar (testPlayer level) mnewCat
|
writeTVar (testPlayer level) mnewCat
|
||||||
|
|
||||||
-- oldCast <- V.map (\(Cast c) -> Cast $ perform dt c) <$>
|
|
||||||
-- readTVar (testCast level)
|
|
||||||
-- oldCat <- perform dt <$> fromJust <$> readTVar (testPlayer level)
|
|
||||||
-- modifyTVar (testCast level) $ \cast ->
|
|
||||||
-- let playedCast =
|
|
||||||
-- V.map
|
|
||||||
-- (\(Cast c) -> Cast (perform dt c))
|
|
||||||
-- cast
|
|
||||||
-- collidedCast =
|
|
||||||
-- V.map
|
|
||||||
-- (\(Cast c1) ->
|
|
||||||
-- let partners = V.foldl
|
|
||||||
-- (\acc@(Cast _, ires) (Cast c2) ->
|
|
||||||
-- let res = collisionCheck dt c1 c2
|
|
||||||
-- in
|
|
||||||
-- if res /= NoCollision &&
|
|
||||||
-- collisionTime res < collisionTime ires
|
|
||||||
-- then (Cast c2, res)
|
|
||||||
-- else acc
|
|
||||||
-- )
|
|
||||||
-- (Cast c1, NoCollision)
|
|
||||||
-- playedCast
|
|
||||||
-- in
|
|
||||||
-- if null partners
|
|
||||||
-- then Cast c1
|
|
||||||
-- else
|
|
||||||
-- uncurry
|
|
||||||
-- (\(Cast c2) result -> Cast $ collide c1 c2 result)
|
|
||||||
-- partners
|
|
||||||
-- )
|
|
||||||
-- playedCast
|
|
||||||
-- wallCast (Cast c) =
|
|
||||||
-- Cast $ performWorldCollision c layer dt
|
|
||||||
-- walledCast =
|
|
||||||
-- V.map wallCast collidedCast
|
|
||||||
-- cattedCast = V.map
|
|
||||||
-- (\(Cast c) ->
|
|
||||||
-- Cast $ collide c oldCat $ collisionCheck dt c oldCat
|
|
||||||
-- )
|
|
||||||
-- walledCast
|
|
||||||
-- in
|
|
||||||
-- V.map
|
|
||||||
-- (\(Cast c) -> Cast $
|
|
||||||
-- move dt c
|
|
||||||
-- )
|
|
||||||
-- walledCast
|
|
||||||
-- releasedEffects <- stateTVar (testPowerups level) $ \pus ->
|
|
||||||
-- let living = V.foldl
|
|
||||||
-- (\acc pu ->
|
|
||||||
-- let npu = perform dt pu
|
|
||||||
-- in
|
|
||||||
-- if puTTL npu > 0
|
|
||||||
-- then npu `V.cons` acc
|
|
||||||
-- else acc
|
|
||||||
-- )
|
|
||||||
-- V.empty
|
|
||||||
-- pus
|
|
||||||
-- indexCollected = V.filter ((/= NoCollision) . snd) $
|
|
||||||
-- V.zip (V.fromList [0..length living])
|
|
||||||
-- (V.map
|
|
||||||
-- (collisionCheck dt oldCat)
|
|
||||||
-- living
|
|
||||||
-- )
|
|
||||||
-- collected = V.foldl
|
|
||||||
-- (\acc (ind, _) ->
|
|
||||||
-- (living V.! ind) `V.cons` acc
|
|
||||||
-- )
|
|
||||||
-- V.empty
|
|
||||||
-- indexCollected
|
|
||||||
-- differ = V.foldl
|
|
||||||
-- (\acc life -> if life `V.elem` collected
|
|
||||||
-- then acc
|
|
||||||
-- else life `V.cons` acc
|
|
||||||
-- )
|
|
||||||
-- V.empty
|
|
||||||
-- living
|
|
||||||
-- fin = V.map
|
|
||||||
-- (\pu -> move dt $ performWorldCollision pu layer dt)
|
|
||||||
-- differ
|
|
||||||
-- in
|
|
||||||
-- (collected, fin)
|
|
||||||
-- modifyTVar
|
|
||||||
-- (testPlayer level) $ \(Just pituicat) ->
|
|
||||||
-- let playedCat = perform dt pituicat
|
|
||||||
-- castCat =
|
|
||||||
-- let allPartners = V.zip (V.fromList [0..V.length oldCast])
|
|
||||||
-- (V.map
|
|
||||||
-- (\(Cast c) -> collisionCheck dt playedCat c)
|
|
||||||
-- oldCast
|
|
||||||
-- )
|
|
||||||
-- filtered = (V.filter ((/= NoCollision) . snd) allPartners)
|
|
||||||
-- partner = V.minimumBy
|
|
||||||
-- (\(_, e) (_, f) -> collisionTime e `compare` collisionTime f)
|
|
||||||
-- filtered
|
|
||||||
-- in
|
|
||||||
-- if V.null filtered
|
|
||||||
-- then
|
|
||||||
-- playedCat
|
|
||||||
-- else
|
|
||||||
-- uncurry
|
|
||||||
-- (\(Cast c) cr -> collide playedCat c cr)
|
|
||||||
-- (oldCast V.! fst partner, snd partner)
|
|
||||||
-- walledCat = performWorldCollision castCat layer dt
|
|
||||||
-- affectedCat = walledCat
|
|
||||||
-- { pcEffects = pcEffects walledCat ++
|
|
||||||
-- map puEffect (V.toList releasedEffects)
|
|
||||||
-- }
|
|
||||||
-- in Just $ move dt affectedCat
|
|
||||||
|
|
||||||
-- performWorldCollision
|
|
||||||
-- :: (Collidible c)
|
|
||||||
-- => c -- ^ Cast member to check
|
|
||||||
-- -> Layer -- ^ The walk layer of the level
|
|
||||||
-- -> Double -- ^ Tick length
|
|
||||||
-- -> c -- ^ Updated cast member
|
|
||||||
-- performWorldCollision c layer dt =
|
|
||||||
-- let partner = V.foldl
|
|
||||||
-- (\acc@(part, cr) tile ->
|
|
||||||
-- let res = collisionCheck dt c tile
|
|
||||||
-- ret = if cr == NoCollision && res == NoCollision
|
|
||||||
-- then
|
|
||||||
-- acc
|
|
||||||
-- else
|
|
||||||
-- if cr == NoCollision && res /= NoCollision
|
|
||||||
-- then (tile, res)
|
|
||||||
-- else
|
|
||||||
-- if cr /= NoCollision && res == NoCollision
|
|
||||||
-- then
|
|
||||||
-- acc
|
|
||||||
-- else
|
|
||||||
-- if collisionTime cr < collisionTime res
|
|
||||||
-- then acc
|
|
||||||
-- else (tile, res)
|
|
||||||
-- in
|
|
||||||
-- ret
|
|
||||||
-- )
|
|
||||||
-- (V.head layer, collisionCheck dt c $ V.head layer)
|
|
||||||
-- layer
|
|
||||||
-- in
|
|
||||||
-- (uncurry (collide c) partner) dt
|
|
||||||
|
|
|
@ -16,22 +16,32 @@ instance Mass Cast where
|
||||||
|
|
||||||
mass (Cast a) = mass a
|
mass (Cast a) = mass a
|
||||||
|
|
||||||
acceleration (Cast a) = acceleration a
|
|
||||||
|
|
||||||
accelerationUpdater (Cast a) = Cast . accelerationUpdater a
|
|
||||||
|
|
||||||
velocity (Cast a) = velocity a
|
velocity (Cast a) = velocity a
|
||||||
|
|
||||||
velocityUpdater (Cast a) = Cast . velocityUpdater a
|
velocityUpdater (Cast a) = Cast . velocityUpdater a
|
||||||
|
|
||||||
|
forces (Cast a) = forces a
|
||||||
|
|
||||||
|
forcesUpdater (Cast a) = Cast . forcesUpdater a
|
||||||
|
|
||||||
position (Cast a) = position a
|
position (Cast a) = position a
|
||||||
|
|
||||||
positionUpdater (Cast a) = Cast . positionUpdater a
|
positionUpdater (Cast a) = Cast . positionUpdater a
|
||||||
|
|
||||||
instance Collidible Cast where
|
instance Collidible Cast where
|
||||||
|
|
||||||
|
prevPosition (Cast c) = prevPosition c
|
||||||
|
|
||||||
|
impactForces (Cast c) = impactForces c
|
||||||
|
|
||||||
|
impactForcesUpdater (Cast c) = Cast . impactForcesUpdater c
|
||||||
|
|
||||||
|
collisionOccured (Cast c) = collisionOccured c
|
||||||
|
|
||||||
|
updateCollisionOccurence (Cast c) = Cast . updateCollisionOccurence c
|
||||||
|
|
||||||
boundary (Cast c) = boundary c
|
boundary (Cast c) = boundary c
|
||||||
|
|
||||||
collisionCheck dt (Cast c1) c2 = collisionCheck dt c1 c2
|
collisionCheck (Cast c1) c2 = collisionCheck c1 c2
|
||||||
|
|
||||||
collide (Cast c1) res dt = Cast $ collide c1 res dt
|
collide (Cast c1) res dt = Cast $ collide c1 res dt
|
||||||
|
|
|
@ -41,6 +41,7 @@ data Tile = Tile
|
||||||
{ tilePosition :: V2 Word -- ^
|
{ tilePosition :: V2 Word -- ^
|
||||||
, tileOffset :: (V2 Float, V2 Float) -- ^ Graphics offset on 'TileMap'
|
, tileOffset :: (V2 Float, V2 Float) -- ^ Graphics offset on 'TileMap'
|
||||||
, tileType :: TileType -- ^ Type of tile
|
, tileType :: TileType -- ^ Type of tile
|
||||||
|
, tileCollided :: Bool
|
||||||
}
|
}
|
||||||
deriving (Eq, Show)
|
deriving (Eq, Show)
|
||||||
|
|
||||||
|
@ -48,7 +49,7 @@ instance Drawable Tile where
|
||||||
|
|
||||||
-- type VertexList Tile = V.Vector
|
-- type VertexList Tile = V.Vector
|
||||||
|
|
||||||
toVertices (Tile (V2 x y) (V2 u1 v1, V2 u2 v2) _) =
|
toVertices (Tile (V2 x y) (V2 u1 v1, V2 u2 v2) _ _) =
|
||||||
( V.fromList [ 0, 1, 2, 2, 3, 0 ]
|
( V.fromList [ 0, 1, 2, 2, 3, 0 ]
|
||||||
, V.fromList
|
, V.fromList
|
||||||
[ newVertex
|
[ newVertex
|
||||||
|
@ -76,12 +77,12 @@ instance Drawable Tile where
|
||||||
|
|
||||||
instance Mass Tile where
|
instance Mass Tile where
|
||||||
|
|
||||||
|
forces _ = V2 0 0
|
||||||
|
|
||||||
|
forcesUpdater t _ = t
|
||||||
|
|
||||||
mass _ = recip 0
|
mass _ = recip 0
|
||||||
|
|
||||||
acceleration _ = V2 0 0
|
|
||||||
|
|
||||||
accelerationUpdater t = const t
|
|
||||||
|
|
||||||
velocity _ = V2 0 0
|
velocity _ = V2 0 0
|
||||||
|
|
||||||
velocityUpdater t = const t
|
velocityUpdater t = const t
|
||||||
|
@ -95,6 +96,18 @@ instance Mass Tile where
|
||||||
|
|
||||||
instance Collidible Tile where
|
instance Collidible Tile where
|
||||||
|
|
||||||
|
prevPosition t = position t
|
||||||
|
|
||||||
|
impactForces _ = V2 0 0
|
||||||
|
|
||||||
|
impactForcesUpdater t _ = t
|
||||||
|
|
||||||
|
collisionOccured t = tileCollided t
|
||||||
|
|
||||||
|
updateCollisionOccurence t coll = t
|
||||||
|
{ tileCollided = coll
|
||||||
|
}
|
||||||
|
|
||||||
boundary _ =
|
boundary _ =
|
||||||
( V2 (-16) (-16)
|
( V2 (-16) (-16)
|
||||||
, V2 16 16
|
, V2 16 16
|
||||||
|
|
|
@ -31,7 +31,10 @@ catMoveVelocity = 100
|
||||||
|
|
||||||
data Pituicat = Pituicat
|
data Pituicat = Pituicat
|
||||||
{ pcPos :: V2 Double
|
{ pcPos :: V2 Double
|
||||||
|
, pcPrevPos :: V2 Double
|
||||||
, pcVel :: V2 Double
|
, pcVel :: V2 Double
|
||||||
|
, pcForces :: V2 Double
|
||||||
|
, pcImpactForces :: V2 Double
|
||||||
, pcMoveVel :: V2 Double
|
, pcMoveVel :: V2 Double
|
||||||
, pcTMoveVel :: V2 Double
|
, pcTMoveVel :: V2 Double
|
||||||
, pcAcc :: V2 Double
|
, pcAcc :: V2 Double
|
||||||
|
@ -42,6 +45,7 @@ data Pituicat = Pituicat
|
||||||
, pcViewDirection :: ViewDirection
|
, pcViewDirection :: ViewDirection
|
||||||
, pcEffects :: [EffectHolder]
|
, pcEffects :: [EffectHolder]
|
||||||
, pcXColl :: Bool
|
, pcXColl :: Bool
|
||||||
|
, pcCollisionOcc :: Bool
|
||||||
}
|
}
|
||||||
deriving (Eq, Show)
|
deriving (Eq, Show)
|
||||||
|
|
||||||
|
@ -50,7 +54,7 @@ data ViewDirection = ViewLeft | ViewRight
|
||||||
|
|
||||||
instance Drawable Pituicat where
|
instance Drawable Pituicat where
|
||||||
|
|
||||||
toVertices (Pituicat (V2 x y) _ _ _ _ _ _ _ _ vd _ _) =
|
toVertices (Pituicat (V2 x y) _ _ _ _ _ _ _ _ _ _ _ vd _ _ _) =
|
||||||
( V.fromList [0, 1, 2, 2, 3, 0]
|
( V.fromList [0, 1, 2, 2, 3, 0]
|
||||||
, V.fromList
|
, V.fromList
|
||||||
[ newVertex
|
[ newVertex
|
||||||
|
@ -103,7 +107,7 @@ instance Actor Pituicat where
|
||||||
not (any ((SpeedUp ==) . effectReleased) (pcEffects p))
|
not (any ((SpeedUp ==) . effectReleased) (pcEffects p))
|
||||||
then 1
|
then 1
|
||||||
else 2
|
else 2
|
||||||
physCat = (accelerate dt . gravitate constG)
|
physCat =
|
||||||
(p
|
(p
|
||||||
{ pcAcc = V2 0 0
|
{ pcAcc = V2 0 0
|
||||||
, pcTMoveVel =
|
, pcTMoveVel =
|
||||||
|
@ -149,13 +153,6 @@ instance Mass Pituicat where
|
||||||
|
|
||||||
mass _ = 100
|
mass _ = 100
|
||||||
|
|
||||||
acceleration = pcAcc
|
|
||||||
|
|
||||||
accelerationUpdater cat =
|
|
||||||
\accel -> cat
|
|
||||||
{ pcAcc = accel
|
|
||||||
}
|
|
||||||
|
|
||||||
velocity =
|
velocity =
|
||||||
pcVel
|
pcVel
|
||||||
|
|
||||||
|
@ -164,6 +161,12 @@ instance Mass Pituicat where
|
||||||
{ pcVel = vel
|
{ pcVel = vel
|
||||||
}
|
}
|
||||||
|
|
||||||
|
forces = pcForces
|
||||||
|
|
||||||
|
forcesUpdater c force = c
|
||||||
|
{ pcForces = force
|
||||||
|
}
|
||||||
|
|
||||||
position = pcPos
|
position = pcPos
|
||||||
|
|
||||||
positionUpdater cat =
|
positionUpdater cat =
|
||||||
|
@ -171,15 +174,22 @@ instance Mass Pituicat where
|
||||||
{ pcPos = pos
|
{ pcPos = pos
|
||||||
}
|
}
|
||||||
|
|
||||||
move dt cat =
|
|
||||||
let dpos = (dt *) <$> velocity cat
|
|
||||||
mpos = (dt *) <$>
|
|
||||||
(if pcXColl cat then V2 (-1) 1 else V2 1 1) * pcMoveVel cat
|
|
||||||
in
|
|
||||||
positionUpdater cat (position cat + dpos + mpos)
|
|
||||||
|
|
||||||
instance Collidible Pituicat where
|
instance Collidible Pituicat where
|
||||||
|
|
||||||
|
impactForces = pcImpactForces
|
||||||
|
|
||||||
|
impactForcesUpdater c force = c
|
||||||
|
{ pcImpactForces = force
|
||||||
|
}
|
||||||
|
|
||||||
|
collisionOccured = pcCollisionOcc
|
||||||
|
|
||||||
|
updateCollisionOccurence c coll = c
|
||||||
|
{ pcCollisionOcc = coll
|
||||||
|
}
|
||||||
|
|
||||||
|
prevPosition = pcPrevPos
|
||||||
|
|
||||||
boundary cat =
|
boundary cat =
|
||||||
if pcViewDirection cat == ViewRight
|
if pcViewDirection cat == ViewRight
|
||||||
then
|
then
|
||||||
|
@ -196,25 +206,25 @@ instance Collidible Pituicat where
|
||||||
}
|
}
|
||||||
collide cat collrs@((_, NoCollision):_) _ = cat
|
collide cat collrs@((_, NoCollision):_) _ = cat
|
||||||
{ pcXColl = any
|
{ pcXColl = any
|
||||||
(\(_, CollisionImminent _ (V2 cx _)) -> cx /= 0)
|
(\(_, OverlapCollision (V2 cx _)) -> cx /= 0)
|
||||||
(filter ((NoCollision /= ) . snd) collrs)
|
(filter ((NoCollision /= ) . snd) collrs)
|
||||||
}
|
}
|
||||||
collide cat collrs@(collr@(_, OverlapCollision direction):_) dt =
|
collide cat collrs@(collr@(_, OverlapCollision direction):_) dt =
|
||||||
elasticCollision 0.3 cat collr dt
|
elasticCollision 0.3 cat collr dt
|
||||||
collide cat collrs@(collr@(other, CollisionImminent ddt (V2 dirx diry)):_) dt =
|
-- collide cat collrs@(collr@(other, OverlapCollision (V2 dirx diry)):_) dt =
|
||||||
let ncat = elasticCollision 0.3 cat collr dt
|
-- let ncat = elasticCollision 0.3 cat collr dt
|
||||||
vel@(V2 vx vy) = velocity ncat
|
-- vel@(V2 vx vy) = velocity ncat
|
||||||
moveVel@(V2 mx my) = pcMoveVel cat
|
-- moveVel@(V2 mx my) = pcMoveVel cat
|
||||||
nvel = V2
|
-- nvel = V2
|
||||||
(if abs mx > abs vx
|
-- (if abs mx > abs vx
|
||||||
then 0
|
-- then 0
|
||||||
else signum vx * (abs vx - abs mx)
|
-- else signum vx * (abs vx - abs mx)
|
||||||
)
|
-- )
|
||||||
((\(V2 _ y) -> y) (if diry /= 0 then pcVel ncat else pcVel cat))
|
-- ((\(V2 _ y) -> y) (if diry /= 0 then pcVel ncat else pcVel cat))
|
||||||
grounded =
|
-- grounded =
|
||||||
diry == -1 && abs (vy * ddt) < 2
|
-- diry == -1 && abs (vy * ddt) < 2
|
||||||
in
|
-- in
|
||||||
ncat
|
-- ncat
|
||||||
{ pcGrounded = grounded
|
-- { pcGrounded = grounded
|
||||||
, pcXColl = not grounded && diry /= 0
|
-- , pcXColl = not grounded && diry /= 0
|
||||||
}
|
-- }
|
||||||
|
|
|
@ -17,21 +17,23 @@ import Graphics.Types.Texture
|
||||||
import Graphics.Classes.Drawable
|
import Graphics.Classes.Drawable
|
||||||
import Graphics.Classes.Bindable
|
import Graphics.Classes.Bindable
|
||||||
|
|
||||||
import Util
|
|
||||||
|
|
||||||
data PowerUp = PowerUp
|
data PowerUp = PowerUp
|
||||||
{ puPos :: V2 Double
|
{ puPos :: V2 Double
|
||||||
, puVel :: V2 Double
|
, puPrevPos :: V2 Double
|
||||||
, puAcc :: V2 Double
|
, puVel :: V2 Double
|
||||||
, puTTL :: Double
|
, puAcc :: V2 Double
|
||||||
, puTexture :: Texture
|
, puTTL :: Double
|
||||||
, puEffect :: EffectHolder
|
, puTexture :: Texture
|
||||||
|
, puEffect :: EffectHolder
|
||||||
|
, puForces :: V2 Double
|
||||||
|
, puImpactForces :: V2 Double
|
||||||
|
, puCollided :: Bool
|
||||||
}
|
}
|
||||||
deriving (Eq, Show)
|
deriving (Eq, Show)
|
||||||
|
|
||||||
instance Drawable PowerUp where
|
instance Drawable PowerUp where
|
||||||
|
|
||||||
toVertices (PowerUp (V2 x y) _ _ _ _ _) =
|
toVertices (PowerUp (V2 x y) _ _ _ _ _ _ _ _ _) =
|
||||||
( V.fromList [0, 1, 2, 2, 3, 0]
|
( V.fromList [0, 1, 2, 2, 3, 0]
|
||||||
, V.fromList
|
, V.fromList
|
||||||
[ newVertex
|
[ newVertex
|
||||||
|
@ -66,7 +68,7 @@ instance Prop PowerUp where
|
||||||
instance Actor PowerUp where
|
instance Actor PowerUp where
|
||||||
|
|
||||||
perform dt o =
|
perform dt o =
|
||||||
let phys = (accelerate dt . gravitate constG)
|
let phys =
|
||||||
o
|
o
|
||||||
{ puAcc = V2 0 0
|
{ puAcc = V2 0 0
|
||||||
, puTTL = puTTL o - dt
|
, puTTL = puTTL o - dt
|
||||||
|
@ -78,12 +80,11 @@ instance Mass PowerUp where
|
||||||
|
|
||||||
mass _ = 0.1
|
mass _ = 0.1
|
||||||
|
|
||||||
acceleration = puAcc
|
forces = puForces
|
||||||
|
|
||||||
accelerationUpdater o =
|
forcesUpdater p force = p
|
||||||
\acc -> o
|
{ puForces = force
|
||||||
{ puAcc = acc
|
}
|
||||||
}
|
|
||||||
|
|
||||||
velocity = puVel
|
velocity = puVel
|
||||||
|
|
||||||
|
@ -101,6 +102,20 @@ instance Mass PowerUp where
|
||||||
|
|
||||||
instance Collidible PowerUp where
|
instance Collidible PowerUp where
|
||||||
|
|
||||||
|
prevPosition = puPrevPos
|
||||||
|
|
||||||
|
impactForces = puImpactForces
|
||||||
|
|
||||||
|
impactForcesUpdater p force = p
|
||||||
|
{ puImpactForces = force
|
||||||
|
}
|
||||||
|
|
||||||
|
collisionOccured = puCollided
|
||||||
|
|
||||||
|
updateCollisionOccurence p coll = p
|
||||||
|
{ puCollided = coll
|
||||||
|
}
|
||||||
|
|
||||||
boundary _ =
|
boundary _ =
|
||||||
( V2 (-20) (-20)
|
( V2 (-20) (-20)
|
||||||
, V2 20 20
|
, V2 20 20
|
||||||
|
|
|
@ -28,15 +28,15 @@ instance Mass Tangible where
|
||||||
mass (TPowerUp a) = mass a
|
mass (TPowerUp a) = mass a
|
||||||
mass (TTile a) = mass a
|
mass (TTile a) = mass a
|
||||||
|
|
||||||
acceleration (TPlayer a) = acceleration a
|
forces (TPlayer a) = forces a
|
||||||
acceleration (TCast a) = acceleration a
|
forces (TCast a) = forces a
|
||||||
acceleration (TPowerUp a) = acceleration a
|
forces (TPowerUp a) = forces a
|
||||||
acceleration (TTile a) = acceleration a
|
forces (TTile a) = forces a
|
||||||
|
|
||||||
accelerationUpdater (TPlayer a) = TPlayer . accelerationUpdater a
|
forcesUpdater (TPlayer a) = TPlayer . forcesUpdater a
|
||||||
accelerationUpdater (TCast a) = TCast . accelerationUpdater a
|
forcesUpdater (TCast a) = TCast . forcesUpdater a
|
||||||
accelerationUpdater (TPowerUp a) = TPowerUp . accelerationUpdater a
|
forcesUpdater (TPowerUp a) = TPowerUp . forcesUpdater a
|
||||||
accelerationUpdater (TTile a) = TTile . accelerationUpdater a
|
forcesUpdater (TTile a) = TTile . forcesUpdater a
|
||||||
|
|
||||||
velocity (TPlayer a) = velocity a
|
velocity (TPlayer a) = velocity a
|
||||||
velocity (TCast a) = velocity a
|
velocity (TCast a) = velocity a
|
||||||
|
@ -60,15 +60,40 @@ instance Mass Tangible where
|
||||||
|
|
||||||
instance Collidible Tangible where
|
instance Collidible Tangible where
|
||||||
|
|
||||||
boundary (TPlayer c) = boundary c
|
boundary (TPlayer c) = boundary c
|
||||||
boundary (TCast c) = boundary c
|
boundary (TCast c) = boundary c
|
||||||
boundary (TPowerUp c) = boundary c
|
boundary (TPowerUp c) = boundary c
|
||||||
boundary (TTile c) = boundary c
|
boundary (TTile c) = boundary c
|
||||||
|
|
||||||
collisionCheck dt (TPlayer c1) c2 = collisionCheck dt c1 c2
|
prevPosition (TPlayer c) = prevPosition c
|
||||||
collisionCheck dt (TCast c1) c2 = collisionCheck dt c1 c2
|
prevPosition (TCast c) = prevPosition c
|
||||||
collisionCheck dt (TPowerUp c1) c2 = collisionCheck dt c1 c2
|
prevPosition (TPowerUp c) = prevPosition c
|
||||||
collisionCheck dt (TTile c1) c2 = collisionCheck dt c1 c2
|
prevPosition (TTile c) = prevPosition c
|
||||||
|
|
||||||
|
impactForces (TPlayer c) = impactForces c
|
||||||
|
impactForces (TCast c) = impactForces c
|
||||||
|
impactForces (TPowerUp c) = impactForces c
|
||||||
|
impactForces (TTile c) = impactForces c
|
||||||
|
|
||||||
|
collisionOccured (TPlayer c) = collisionOccured c
|
||||||
|
collisionOccured (TCast c) = collisionOccured c
|
||||||
|
collisionOccured (TPowerUp c) = collisionOccured c
|
||||||
|
collisionOccured (TTile c) = collisionOccured c
|
||||||
|
|
||||||
|
impactForcesUpdater (TPlayer c) = TPlayer . impactForcesUpdater c
|
||||||
|
impactForcesUpdater (TCast c) = TCast . impactForcesUpdater c
|
||||||
|
impactForcesUpdater (TPowerUp c) = TPowerUp . impactForcesUpdater c
|
||||||
|
impactForcesUpdater (TTile c) = TTile . impactForcesUpdater c
|
||||||
|
|
||||||
|
updateCollisionOccurence (TPlayer c) = TPlayer . updateCollisionOccurence c
|
||||||
|
updateCollisionOccurence (TCast c) = TCast . updateCollisionOccurence c
|
||||||
|
updateCollisionOccurence (TPowerUp c) = TPowerUp . updateCollisionOccurence c
|
||||||
|
updateCollisionOccurence (TTile c) = TTile . updateCollisionOccurence c
|
||||||
|
|
||||||
|
collisionCheck (TPlayer c1) c2 = collisionCheck c1 c2
|
||||||
|
collisionCheck (TCast c1) c2 = collisionCheck c1 c2
|
||||||
|
collisionCheck (TPowerUp c1) c2 = collisionCheck c1 c2
|
||||||
|
collisionCheck (TTile c1) c2 = collisionCheck c1 c2
|
||||||
|
|
||||||
collide (TPlayer c1) res dt = TPlayer $ collide c1 res dt
|
collide (TPlayer c1) res dt = TPlayer $ collide c1 res dt
|
||||||
collide (TCast c1) res dt = TCast $ collide c1 res dt
|
collide (TCast c1) res dt = TCast $ collide c1 res dt
|
||||||
|
|
|
@ -3,20 +3,18 @@ module Util where
|
||||||
import Affection
|
import Affection
|
||||||
|
|
||||||
import qualified SDL
|
import qualified SDL
|
||||||
import qualified SDL.Internal.Numbered as SDL
|
|
||||||
|
|
||||||
import Linear
|
import Linear
|
||||||
|
|
||||||
-- internal imports
|
-- internal imports
|
||||||
|
|
||||||
import Types.Application
|
import Types.Application
|
||||||
import Types.Subsystems
|
|
||||||
|
|
||||||
globalKeyHandle
|
globalKeyHandle
|
||||||
:: GameData
|
:: GameData
|
||||||
-> KeyboardMessage
|
-> KeyboardMessage
|
||||||
-> Affection ()
|
-> Affection ()
|
||||||
globalKeyHandle gd mesg@(MsgKeyboardEvent time win motion repeat keysym) =
|
globalKeyHandle _ mesg@MsgKeyboardEvent {} =
|
||||||
case mesg of
|
case mesg of
|
||||||
MsgKeyboardEvent
|
MsgKeyboardEvent
|
||||||
_
|
_
|
||||||
|
|
Loading…
Reference in a new issue