nek0/vulkan-tutorial
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Add 'extern/affection/' from commit '9b7b1c6167b4fa516b91759ca86139ede07f231d'

Browse source 
git-subtree-dir: extern/affection
git-subtree-mainline: f422f94794
git-subtree-split: 9b7b1c6167
This commit is contained in:
nek0 2022-07-09 20:36:04 +02:00
commit 8c037f69ce
35 changed files with 2441 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

20
extern/affection/.gitignore vendored Normal file
View file

@ -0,0 +1,20 @@
*.hi
*.o
.hsenv*
.stack-work
.git
.cabal-sandbox/
cabal.sandbox.config
dist/
*.prof
*.aux
*.hp
*.ps
*.swp
.ghc*
cabal.project.local*
dist*/
report.html
*.bak
.direnv/
.envrc

5
extern/affection/ChangeLog.md vendored Normal file
View 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
View 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
View file

@ -0,0 +1,8 @@
# ![Affection logo](./affection.svg)
A simple Game Engine in Haskell using SDL
## Disclaimer
This Engine is not stable yet. Things may change. horribly.
Even minor version bumps may break the API.

2
extern/affection/Setup.hs vendored Normal file
View file

@ -0,0 +1,2 @@
import Distribution.Simple
main = defaultMain

181
extern/affection/affection.cabal vendored Normal file
View file

@ -0,0 +1,181 @@
name: affection
-- The package version. See the Haskell package versioning policy (PVP)
-- for standards guiding when and how versions should be incremented.
-- http://www.haskell.org/haskellwiki/Package_versioning_policy
-- PVP summary: +-+------- breaking API changes
-- | | +----- non-breaking API additions
-- | | | +--- code changes with no API change
version: 0.0.0.10
synopsis: A simple Game Engine using SDL
description: This package contains Affection, a simple game engine
written in Haskell using SDL.
This Engine is still work in progress and even minor
version bumps may contain breaking api changes.
homepage: https://github.com/nek0/affection#readme
license: LGPL-3
license-file: LICENSE
author: nek0
maintainer: nek0@chelnok.de
category: Game
build-type: Simple
extra-source-files: ChangeLog.md
-- Extra files to be distributed with the package, such as examples or a
-- README.
-- extra-source-files:
cabal-version: >=2.0
source-repository head
type: git
location: https://github.com/nek0/affection
flag verbose
description: Enable verbose debug messages
default: False
manual: True
flag debug
description: Enable debug messages
default: False
manual: True
flag warn
description: Enable warning messages
default: False
manual: True
flag error
description: Enable error messages
default: False
manual: True
flag examples
description: Build example programs
default: False
library
if flag(verbose)
cpp-options: -DVERBOSE
if flag(debug)
cpp-options: -DDEBUG
if flag(warn)
cpp-options: -DWARN
if flag(error)
cpp-options: -DERROR
exposed-modules: Affection
, Affection.Logging
, Affection.Types
, Affection.Class
, Affection.StateMachine
, Affection.Util
, Affection.MessageBus
, Affection.MessageBus.Class
, Affection.MessageBus.Message
, Affection.MessageBus.Message.Class
, Affection.MessageBus.Message.WindowMessage
, Affection.MessageBus.Message.KeyboardMessage
, Affection.MessageBus.Message.MouseMessage
, Affection.MessageBus.Message.JoystickMessage
, Affection.Subsystems
, Affection.Subsystems.Class
, Affection.Subsystems.AffectionWindow
, Affection.Subsystems.AffectionKeyboard
, Affection.Subsystems.AffectionMouse
, Affection.Subsystems.AffectionJoystick
default-extensions: OverloadedStrings
, TypeFamilies
, AllowAmbiguousTypes
-- Modules included in this library but not exported.
-- other-modules:
-- LANGUAGE extensions used by modules in this package.
-- other-extensions: GADTs
-- , KindSignatures
-- , FlexibleInstances
-- , MultiParamTypeClasses
-- , UndecidableInstances
hs-source-dirs: src
default-language: Haskell2010
ghc-options: -Wall
-- Other library packages from which modules are imported.
build-depends: base >=4.9 && < 5
, sdl2 ^>= 2.5
, linear
, text
, mtl
, monad-loops
, monad-parallel
, containers
, clock >= 0.8
, glib
, bytestring
, OpenGL
, OpenGLRaw
, stm
, uuid
, vector
-- 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
View 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
View file

File diff suppressed because one or more lines are too long
Side by side

After

Width:  |  Height:  |  Size: 14 KiB

4
extern/affection/cabal.project vendored Normal file
View file

@ -0,0 +1,4 @@
constraints: affection +verbose
profiling: true
packages:
./.

196
extern/affection/examples/example00/Main.hs vendored Normal file
View 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
View 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
View 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
View 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
View file

@ -0,0 +1,78 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
module Types where
import Affection
import Data.Matrix as M
import NanoVG
import Control.Concurrent.STM
import Control.Concurrent.MVar
data UserData = UserData
{ lifeMat :: MVar (Matrix Word)
, foodMat :: MVar (Matrix Word)
, timeMat :: MVar (Matrix Word)
, subsystems :: Subsystems
, nano :: Context
, doNextStep :: MVar Bool
}
data Subsystems = Subsystems
{ subWindow :: Types.Window
, subKeyboard :: Types.Keyboard
}
newtype Window = Window (TVar [(UUID, WindowMessage -> Affection ())])
newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection ())])
instance Participant Types.Window where
type Mesg Types.Window = WindowMessage
partSubscribers (Window t) = do
subTups <- liftIO $ readTVarIO t
return $ map snd subTups
partSubscribe (Window t) = generalSubscribe t
partUnSubscribe (Window t) = generalUnSubscribe t
instance SDLSubsystem Types.Window where
consumeSDLEvents = consumeSDLWindowEvents
instance Participant Keyboard where
type Mesg Keyboard = KeyboardMessage
partSubscribers (Keyboard t) = do
subTups <- liftIO $ readTVarIO t
return $ map snd subTups
partSubscribe (Keyboard t) = generalSubscribe t
partUnSubscribe (Keyboard t) = generalUnSubscribe t
instance SDLSubsystem Keyboard where
consumeSDLEvents = consumeSDLKeyboardEvents
generalSubscribe
:: TVar [(UUID, msg -> Affection ())]
-> (msg -> Affection ())
-> Affection UUID
generalSubscribe t funct = do
uuid <- genUUID
liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
return uuid
generalUnSubscribe
:: TVar [(UUID, msg -> Affection ())]
-> UUID
-> Affection ()
generalUnSubscribe t uuid =
liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uuid))
where
filterMsg :: (UUID, msg -> Affection ()) -> UUID -> Bool
filterMsg (u, _) p = u /= p

7
extern/affection/shell.nix vendored Normal file
View file

@ -0,0 +1,7 @@
{ pkgs ? import <nixpkgs> {}}:
let
affection = pkgs.haskellPackages.callCabal2nix "affection" (gitignore ./.) {};
gitignore = dir: pkgs.nix-gitignore.gitignoreSource [] dir;
in
affection.env

151
extern/affection/src/Affection.hs vendored Normal file
View file

@ -0,0 +1,151 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE Strict #-}
{-# 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 qualified Graphics.Rendering.OpenGL as GL (clear, flush, ClearBuffer(..))
import qualified Graphics.GL as GLRaw
import Foreign.Marshal.Array
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8
import System.Clock
import Control.Monad.Loops
import Control.Monad.State.Strict
-- internal imports
import Affection.Types as A
import Affection.Class as A
import Affection.StateMachine as A
import Affection.Util as A
import Affection.MessageBus as A
import Affection.Subsystems as A
import Affection.Logging as A
-- | Main function which bootstraps everything else.
withAffection
:: forall us. (Affectionate us)
=> AffectionConfig us -- ^ Configuration of the Game and its engine.
-> IO ()
withAffection AffectionConfig{..} = 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
-- sync updates with monitor
-- SDL.swapInterval $= SDL.SynchronizedUpdates -- <- causes Problems with windows
liftIO $ logIO Debug "Getting Time"
-- print current used GL Version
version <- peekArray0 (0 :: Word8) =<< GLRaw.glGetString GLRaw.GL_VERSION
print (B.pack version)
-- 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 "Running Pre-Loop stage"
-- run preLoop function from Affectionate
preLoop gameData
liftIO $ logIO Debug "Starting Loop"
whileM_ (hasNextStep gameData)
(do
-- get state
ad <- get
-- Measure time difference form last run
now <- liftIO $ getTime Monotonic
let lastTime = sysTime ad
-- compute dt and update elapsedTime
let dt = fromIntegral
(toNanoSecs $ diffTimeSpec lastTime now) / (10 ^ (9 :: Int))
ne = elapsedTime ad + dt
-- update state data object with new time values
put $ ad
{ elapsedTime = ne
, deltaTime = dt
}
-- poll events
liftIO SDL.pumpEvents
evs <- preHandleEvents =<< liftIO SDL.pollEvents
-- handle events
handleEvents gameData evs
-- execute user defined update loop
unless (pausedTime ad) (update gameData dt)
-- clear GL buffer >> execute user defined draw loop >> flush GL buffer
liftIO $ GL.clear [GL.ColorBuffer, GL.DepthBuffer, GL.StencilBuffer]
draw gameData
liftIO GL.flush
-- actual displaying of newly drawn frame
mapM_ (SDL.glSwapWindow . (\(_,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
View 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
View file

@ -0,0 +1,54 @@
{-# LANGUAGE CPP #-}
-- | This module defines the logging capability of Affection, whis is derived
-- from "Debug.Trace".
module Affection.Logging where
import qualified Data.Text as T
import Debug.Trace
-- | The log level definition
data LogLevel
= Verbose -- ^ Log everything
| Debug -- ^ Log Debug messages and above
| Warn -- ^ Log only Warnings and errors
| Error -- ^ Log only errors
-- | Pure logging function
log
:: LogLevel -- ^ Log level to log to
-> T.Text -- ^ The message string
-> a -- ^ Arbitrary datatype to return
-> a -- ^ Returned data
#if defined(VERBOSE)
log Verbose s = trace ("VERBOSE: " ++ T.unpack s)
#endif
#if defined(DEBUG) || defined(VERBOSE)
log Debug s = trace ("DEBUG: " ++ T.unpack s)
#endif
#if defined(WARN) || defined(DEBUG) || defined(VERBOSE)
log Warn s = trace ("WARN: " ++ T.unpack s)
#endif
#if defined(ERROR) || defined(WARN) || defined(DEBUG) || defined(VERBOSE)
log Error s = trace ("ERROR: " ++ T.unpack s)
#endif
log _ _ = id
-- | Manadic logging function residing in the 'IO' Monad
logIO
:: LogLevel -- ^ Log level to log to
-> T.Text -- ^ The message string
-> IO ()
#if defined(VERBOSE)
logIO Verbose s = traceIO ("VERBOSE: " ++ T.unpack s)
#endif
#if defined(DEBUG) || defined(VERBOSE)
logIO Debug s = traceIO ("DEBUG: " ++ T.unpack s)
#endif
#if defined(WARN) || defined(DEBUG) || defined(VERBOSE)
logIO Warn s = traceIO ("WARN: " ++ T.unpack s)
#endif
#if defined(ERROR) || defined(WARN) || defined(DEBUG) || defined(VERBOSE)
logIO Error s = traceIO ("ERROR: " ++ T.unpack s)
#endif
logIO _ _ = return ()

6
extern/affection/src/Affection/MessageBus.hs vendored Normal file
View file

@ -0,0 +1,6 @@
module Affection.MessageBus
( module M
) where
import Affection.MessageBus.Class as M
import Affection.MessageBus.Message as M

68
extern/affection/src/Affection/MessageBus/Class.hs vendored Normal file
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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 ()