Add 'extern/affection/' from commit 'fc6bfa1ca5307e915d44eeac507ccc56ba01b487'
git-subtree-dir: extern/affection git-subtree-mainline:9e89962af0git-subtree-split:fc6bfa1ca5
This commit is contained in:
commit
58fd609095
37 changed files with 2573 additions and 0 deletions
18
extern/affection/.gitignore
vendored
Normal file
18
extern/affection/.gitignore
vendored
Normal file
|
|
@ -0,0 +1,18 @@
|
|||
*.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
|
||||
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 @@
|
|||
# 
|
||||
|
||||
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
|
||||
180
extern/affection/affection.cabal
vendored
Normal file
180
extern/affection/affection.cabal
vendored
Normal file
|
|
@ -0,0 +1,180 @@
|
|||
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
|
||||
, stm
|
||||
, uuid
|
||||
, vector
|
||||
|
||||
-- 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
|
||||
if flag(examples)
|
||||
build-depends: base >=4.9 && < 5
|
||||
, affection
|
||||
, sdl2 ^>= 2.5
|
||||
, stm
|
||||
else
|
||||
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
|
||||
if flag(examples)
|
||||
build-depends: base >=4.9 && < 5
|
||||
, affection
|
||||
, sdl2 ^>= 2.5
|
||||
, stm
|
||||
, OpenGL
|
||||
, random
|
||||
, containers
|
||||
, linear
|
||||
, matrix
|
||||
, nanovg >= 0.6.0.0
|
||||
, deepseq
|
||||
else
|
||||
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
|
||||
if flag(examples)
|
||||
build-depends: base >=4.9 && < 5
|
||||
, affection
|
||||
, sdl2 ^>= 2.5
|
||||
, stm
|
||||
, OpenGL
|
||||
, random
|
||||
, containers
|
||||
, linear
|
||||
, matrix
|
||||
, nanovg >= 0.6.0.0
|
||||
, deepseq
|
||||
else
|
||||
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
|
||||
9
extern/affection/notes/TODO.md
vendored
Normal file
9
extern/affection/notes/TODO.md
vendored
Normal file
|
|
@ -0,0 +1,9 @@
|
|||
# TODO
|
||||
|
||||
Implement following things in approximately this Order:
|
||||
|
||||
* Message bus -> DONE
|
||||
* Console
|
||||
* GUI
|
||||
* Framework
|
||||
* Everything else
|
||||
125
extern/affection/shell.nix
vendored
Normal file
125
extern/affection/shell.nix
vendored
Normal file
|
|
@ -0,0 +1,125 @@
|
|||
{ nixpkgs ? import <nixpkgs> {}, compiler ? "default", doBenchmark ? false }:
|
||||
|
||||
let
|
||||
|
||||
inherit (nixpkgs) pkgs;
|
||||
|
||||
nanovg = with haskellPackages; callPackage (
|
||||
{ mkDerivation, base, bytestring, c2hs, containers, glew
|
||||
, hspec, inline-c, libGL, libGLU, QuickCheck, stdenv, text, vector
|
||||
}:
|
||||
mkDerivation {
|
||||
pname = "nanovg";
|
||||
version = "0.6.0.0";
|
||||
sha256 = "e35a2772f2a2e71916013cab70eeb8eedd6f66b5490ddf7ce237c8c76895d496";
|
||||
revision = "1";
|
||||
editedCabalFile = "1lhfsq50r9bdby7mfscw8ih3wsz2m19lr2a2z9b6diaf5kz76vij";
|
||||
isLibrary = true;
|
||||
isExecutable = true;
|
||||
doCheck = false;
|
||||
libraryHaskellDepends = [ base bytestring containers text vector ];
|
||||
librarySystemDepends = [ glew libGL libGLU ];
|
||||
libraryPkgconfigDepends = [ glew ];
|
||||
libraryToolDepends = [ c2hs ];
|
||||
testHaskellDepends = [ base containers hspec inline-c QuickCheck ];
|
||||
homepage = "https://github.com/cocreature/nanovg-hs";
|
||||
description = "Haskell bindings for nanovg";
|
||||
license = stdenv.lib.licenses.isc;
|
||||
}) {};
|
||||
|
||||
glib = with haskellPackages; callPackage(
|
||||
{ mkDerivation, base, bytestring, Cabal, containers, glib
|
||||
, stdenv, text, utf8-string, gtk2hs-buildtools
|
||||
}:
|
||||
mkDerivation {
|
||||
pname = "glib";
|
||||
version = "0.13.8.0";
|
||||
sha256 = "9cce6fb44e3c30de2bd330a6902955e3a5fce7b6e9ce41a4afb70e3a7d6e61a2";
|
||||
setupHaskellDepends = [ base Cabal gtk2hs-buildtools ];
|
||||
libraryHaskellDepends = [
|
||||
base bytestring containers text utf8-string
|
||||
];
|
||||
libraryPkgconfigDepends = [ pkgs.glib ];
|
||||
homepage = "http://projects.haskell.org/gtk2hs/";
|
||||
description = "Binding to the GLIB library for Gtk2Hs";
|
||||
license = stdenv.lib.licenses.lgpl21;
|
||||
}) {};
|
||||
|
||||
#gtk2hs-buildtools = with haskellPackages; callPackage(
|
||||
# { mkDerivation, alex, array, base, Cabal, containers, directory
|
||||
# , filepath, happy, hashtables, pretty, process, random, stdenv
|
||||
# }:
|
||||
# mkDerivation {
|
||||
# pname = "gtk2hs-buildtools";
|
||||
# version = "0.13.4.0";
|
||||
# src = ../gtk2hs/tools;
|
||||
# isLibrary = true;
|
||||
# isExecutable = true;
|
||||
# enableSeparateDataOutput = true;
|
||||
# libraryHaskellDepends = [
|
||||
# array base Cabal containers directory filepath hashtables pretty
|
||||
# process random
|
||||
# ];
|
||||
# libraryToolDepends = [ alex happy ];
|
||||
# executableHaskellDepends = [ base ];
|
||||
# homepage = "http://projects.haskell.org/gtk2hs/";
|
||||
# description = "Tools to build the Gtk2Hs suite of User Interface libraries";
|
||||
# license = stdenv.lib.licenses.gpl2;
|
||||
# }) {};
|
||||
|
||||
sdl2 = with haskellPackages; callPackage(
|
||||
{ mkDerivation, base, bytestring, deepseq, exceptions, linear, SDL2
|
||||
, StateVar, stdenv, text, transformers, vector, weigh
|
||||
}:
|
||||
mkDerivation {
|
||||
pname = "sdl2";
|
||||
version = "2.5.1.0";
|
||||
sha256 = "fc1d3d4276b2c4f835a5311075abb240385aae7edad8760f6bda55ed8271ed20";
|
||||
isLibrary = true;
|
||||
isExecutable = true;
|
||||
enableSeparateDataOutput = true;
|
||||
libraryHaskellDepends = [
|
||||
base bytestring exceptions linear StateVar text transformers vector
|
||||
];
|
||||
librarySystemDepends = [ SDL2 ];
|
||||
libraryPkgconfigDepends = [ SDL2 ];
|
||||
testHaskellDepends = [ base deepseq linear vector weigh ];
|
||||
description = "Both high- and low-level bindings to the SDL library (version 2.0.6+).";
|
||||
license = stdenv.lib.licenses.bsd3;
|
||||
doCheck = false;
|
||||
}) {};
|
||||
|
||||
f = { mkDerivation, base, bytestring, clock, containers, deepseq
|
||||
, linear, matrix, monad-loops, monad-parallel, mtl
|
||||
, OpenGL, random, stdenv, stm, text, uuid, vector
|
||||
}:
|
||||
mkDerivation {
|
||||
pname = "affection";
|
||||
version = "0.0.0.9";
|
||||
src = ./.;
|
||||
configureFlags = [ "-fexamples" ];
|
||||
isLibrary = true;
|
||||
isExecutable = true;
|
||||
libraryHaskellDepends = [
|
||||
base bytestring clock containers glib linear monad-loops
|
||||
monad-parallel mtl OpenGL sdl2 stm text uuid vector
|
||||
];
|
||||
executableHaskellDepends = [
|
||||
base containers deepseq linear matrix nanovg OpenGL random sdl2 stm
|
||||
];
|
||||
homepage = "https://github.com/nek0/affection#readme";
|
||||
description = "A simple Game Engine using SDL";
|
||||
license = stdenv.lib.licenses.lgpl3;
|
||||
};
|
||||
|
||||
haskellPackages = if compiler == "default"
|
||||
then pkgs.haskellPackages
|
||||
else pkgs.haskell.packages.${compiler};
|
||||
|
||||
variant = if doBenchmark then pkgs.haskell.lib.doBenchmark else pkgs.lib.id;
|
||||
|
||||
drv = variant (haskellPackages.callPackage f {});
|
||||
|
||||
in
|
||||
|
||||
if pkgs.lib.inNixShell then drv.env else drv
|
||||
138
extern/affection/src/Affection.hs
vendored
Normal file
138
extern/affection/src/Affection.hs
vendored
Normal file
|
|
@ -0,0 +1,138 @@
|
|||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE ExplicitForAll #-}
|
||||
{-# 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 System.Clock
|
||||
|
||||
import Control.Monad.Loops
|
||||
import Control.Monad.State.Strict
|
||||
|
||||
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
|
||||
|
||||
import qualified Graphics.Rendering.OpenGL as GL (clear, flush, ClearBuffer(..))
|
||||
|
||||
|
||||
-- | Main function which bootstraps everything else.
|
||||
withAffection
|
||||
:: forall us. (Affectionate us)
|
||||
=> AffectionConfig us -- ^ Configuration of the Game and its engine.
|
||||
-> IO ()
|
||||
withAffection AffectionConfig{..} = 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…
|
||||
do
|
||||
renderQuality <- SDL.get SDL.HintRenderScaleQuality
|
||||
when (renderQuality /= SDL.ScaleLinear) $
|
||||
logIO Warn "Linear texture filtering not enabled!"
|
||||
-- construct window
|
||||
liftIO $ logIO Debug "Creating Window(s)"
|
||||
windows <- zip3 (map (\(x,_,_) -> x) windowConfigs) <$>
|
||||
mapM
|
||||
(\wc -> SDL.createWindow windowTitle ((\(_,y,_) -> y) wc))
|
||||
windowConfigs <*>
|
||||
pure (map (\(_,_,z) -> z) windowConfigs)
|
||||
|
||||
mapM_ (SDL.showWindow . (\(_,y,_) -> y)) windows
|
||||
_ <- SDL.glSetAttribute SDL.SDL_GL_SHARE_WITH_CURRENT_CONTEXT 1
|
||||
contexts <- zip (map (\(x,_,_) -> x) windows) <$>
|
||||
mapM (SDL.glCreateContext . (\(_,y,_) -> y)) windows
|
||||
mapM_ (\w -> flip SDL.setWindowMode ((\(_,_,z) -> z) w) ((\(_,y,_) -> y) w)) windows
|
||||
-- SDL.swapInterval $= SDL.SynchronizedUpdates -- <- causes Problems with windows
|
||||
liftIO $ logIO Debug "Getting Time"
|
||||
-- get current time
|
||||
execTime <- getTime Monotonic
|
||||
liftIO $ logIO Debug "Loading initial data container"
|
||||
-- construct game data object from provided Affectionate instance
|
||||
gameData <- loadState @us
|
||||
-- build state container
|
||||
let initContainer = AffectionData
|
||||
{ drawWindows = windows
|
||||
, glContext = contexts
|
||||
, elapsedTime = 0
|
||||
, deltaTime = 0
|
||||
, sysTime = execTime
|
||||
, pausedTime = False
|
||||
}
|
||||
-- initialize and run state
|
||||
(_, _) <- runStateT
|
||||
(A.runState
|
||||
(do
|
||||
liftIO $ logIO Debug "Starting Loop"
|
||||
-- run preLoop function from Affectionate
|
||||
preLoop gameData
|
||||
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
|
||||
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 . (\(_,y,_) -> y)) windows
|
||||
-- save new time
|
||||
ad3 <- get
|
||||
when (sysTime ad == sysTime ad3) (
|
||||
put ad3
|
||||
{ sysTime = now
|
||||
}
|
||||
)
|
||||
)
|
||||
)
|
||||
) initContainer
|
||||
liftIO $ logIO Debug "Loop ended. Cleaning"
|
||||
cleanUp gameData
|
||||
liftIO $ logIO Debug "Destroying Window"
|
||||
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"
|
||||
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 ()
|
||||
9
extern/affection/src/Affection/MessageBus.hs
vendored
Normal file
9
extern/affection/src/Affection/MessageBus.hs
vendored
Normal file
|
|
@ -0,0 +1,9 @@
|
|||
module Affection.MessageBus
|
||||
( module M
|
||||
, module Msg
|
||||
) where
|
||||
|
||||
import Affection.MessageBus.Class as M
|
||||
import Affection.MessageBus.Message as M
|
||||
|
||||
import Affection.MessageBus.Message as Msg
|
||||
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]
|
||||
84
extern/affection/src/Affection/Types.hs
vendored
Normal file
84
extern/affection/src/Affection/Types.hs
vendored
Normal file
|
|
@ -0,0 +1,84 @@
|
|||
{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveFunctor #-}
|
||||
module Affection.Types
|
||||
( Affection
|
||||
, AffectionConfig(..)
|
||||
, AffectionData(..)
|
||||
, AffectionStateInner
|
||||
, AffectionState(..)
|
||||
, 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 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 ::
|
||||
[
|
||||
( Word -- --^ Window identifier
|
||||
, SDL.Window -- --^ Window linked with identifier
|
||||
, SDL.WindowMode -- -- ^ current screen mode
|
||||
)
|
||||
] -- ^ SDL windows
|
||||
, glContext ::
|
||||
[
|
||||
( Word -- --^ Window identifier
|
||||
, SDL.GLContext -- --^ Associated OpenGL context
|
||||
)
|
||||
] -- ^ OpenGL rendering contexts
|
||||
, elapsedTime :: Double -- ^ Elapsed time in seconds
|
||||
, deltaTime :: Double -- ^ Elapsed time in seconds since last tick
|
||||
, sysTime :: TimeSpec -- ^ System time (NOT the time on the clock)
|
||||
, pausedTime :: Bool -- ^ Should the update loop be executed?
|
||||
}
|
||||
|
||||
-- | Inner 'StateT' monad for the update state
|
||||
type AffectionStateInner sd a = StateT sd a
|
||||
|
||||
-- | Affection's state monad
|
||||
newtype AffectionState sd m a = AffectionState
|
||||
{ runState :: AffectionStateInner sd m a }
|
||||
deriving (Functor, Applicative, Monad, MonadIO, MonadState sd)
|
||||
|
||||
instance MP.MonadParallel m => MP.MonadParallel (AffectionState sd m)
|
||||
|
||||
type Affection a = AffectionState AffectionData IO a
|
||||
|
||||
type Angle = Double
|
||||
86
extern/affection/src/Affection/Util.hs
vendored
Normal file
86
extern/affection/src/Affection/Util.hs
vendored
Normal file
|
|
@ -0,0 +1,86 @@
|
|||
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
|
||||
let mwindow = find (\(ident, _, _) -> ident == windowIdent) (drawWindows ad)
|
||||
case mwindow of
|
||||
Just (ident, window, mode) -> do
|
||||
newMode <- case mode of
|
||||
SDL.FullscreenDesktop -> do
|
||||
SDL.setWindowMode window SDL.Windowed
|
||||
return SDL.Windowed
|
||||
SDL.Windowed -> do
|
||||
SDL.setWindowMode window SDL.FullscreenDesktop
|
||||
return SDL.FullscreenDesktop
|
||||
x -> do
|
||||
liftIO $ logIO Warn ("Unexpected window mode: " <> fromString (show x))
|
||||
return x
|
||||
now <- liftIO $ getTime Monotonic
|
||||
put ad
|
||||
{ sysTime = now
|
||||
, drawWindows = map
|
||||
(\e@(lid, win, _) ->
|
||||
if lid == ident
|
||||
then (lid, win, newMode)
|
||||
else e
|
||||
)
|
||||
(drawWindows ad)
|
||||
}
|
||||
Nothing -> do
|
||||
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 ()
|
||||
Loading…
Reference in a new issue