diff --git a/extern/affection/.gitignore b/extern/affection/.gitignore
deleted file mode 100644
index 237cc52..0000000
--- a/extern/affection/.gitignore
+++ /dev/null
@@ -1,20 +0,0 @@
-*.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
diff --git a/extern/affection/ChangeLog.md b/extern/affection/ChangeLog.md
deleted file mode 100644
index dd649b3..0000000
--- a/extern/affection/ChangeLog.md
+++ /dev/null
@@ -1,5 +0,0 @@
-# Revision history for affection
-
-## 0.0.0.7 -- 2017-12-23
-
-* Release with working scaffold for engine subsystems.
diff --git a/extern/affection/LICENSE b/extern/affection/LICENSE
deleted file mode 100644
index 31afd6d..0000000
--- a/extern/affection/LICENSE
+++ /dev/null
@@ -1,165 +0,0 @@
- GNU LESSER GENERAL PUBLIC LICENSE
- Version 3, 29 June 2007
-
- Copyright (C) 2007 Free Software Foundation, Inc.
- 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.
diff --git a/extern/affection/README.md b/extern/affection/README.md
deleted file mode 100644
index 4664f5f..0000000
--- a/extern/affection/README.md
+++ /dev/null
@@ -1,8 +0,0 @@
-# ![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.
diff --git a/extern/affection/Setup.hs b/extern/affection/Setup.hs
deleted file mode 100644
index 9a994af..0000000
--- a/extern/affection/Setup.hs
+++ /dev/null
@@ -1,2 +0,0 @@
-import Distribution.Simple
-main = defaultMain
diff --git a/extern/affection/affection.cabal b/extern/affection/affection.cabal
deleted file mode 100644
index c5772cf..0000000
--- a/extern/affection/affection.cabal
+++ /dev/null
@@ -1,182 +0,0 @@
-name: affection
-
--- The package version. See the Haskell package versioning policy (PVP)
--- for standards guiding when and how versions should be incremented.
--- http://www.haskell.org/haskellwiki/Package_versioning_policy
--- PVP summary: +-+------- breaking API changes
--- | | +----- non-breaking API additions
--- | | | +--- code changes with no API change
-version: 0.0.0.10
-synopsis: A simple Game Engine using SDL
-description: This package contains Affection, a simple game engine
- written in Haskell using SDL.
- This Engine is still work in progress and even minor
- version bumps may contain breaking api changes.
-homepage: https://github.com/nek0/affection#readme
-license: LGPL-3
-license-file: LICENSE
-author: nek0
-maintainer: nek0@chelnok.de
-category: Game
-build-type: Simple
-extra-source-files: ChangeLog.md
-
--- Extra files to be distributed with the package, such as examples or a
--- README.
--- extra-source-files:
-
-cabal-version: >=2.0
-
-source-repository head
- type: git
- location: https://github.com/nek0/affection
-
-flag verbose
- description: Enable verbose debug messages
- default: False
- manual: True
-
-flag debug
- description: Enable debug messages
- default: False
- manual: True
-
-flag warn
- description: Enable warning messages
- default: False
- manual: True
-
-flag error
- description: Enable error messages
- default: False
- manual: True
-
-flag examples
- description: Build example programs
- default: False
-
-library
- if flag(verbose)
- cpp-options: -DVERBOSE
- if flag(debug)
- cpp-options: -DDEBUG
- if flag(warn)
- cpp-options: -DWARN
- if flag(error)
- cpp-options: -DERROR
- exposed-modules: Affection
- , Affection.Logging
- , Affection.Types
- , Affection.Class
- , Affection.StateMachine
- , Affection.Util
- , Affection.MessageBus
- , Affection.MessageBus.Class
- , Affection.MessageBus.Message
- , Affection.MessageBus.Message.Class
- , Affection.MessageBus.Message.WindowMessage
- , Affection.MessageBus.Message.KeyboardMessage
- , Affection.MessageBus.Message.MouseMessage
- , Affection.MessageBus.Message.JoystickMessage
- , Affection.Subsystems
- , Affection.Subsystems.Class
- , Affection.Subsystems.AffectionWindow
- , Affection.Subsystems.AffectionKeyboard
- , Affection.Subsystems.AffectionMouse
- , Affection.Subsystems.AffectionJoystick
- default-extensions: OverloadedStrings
- , TypeFamilies
- , AllowAmbiguousTypes
-
- -- Modules included in this library but not exported.
- -- other-modules:
-
- -- LANGUAGE extensions used by modules in this package.
- -- other-extensions: GADTs
- -- , KindSignatures
- -- , FlexibleInstances
- -- , MultiParamTypeClasses
- -- , UndecidableInstances
- hs-source-dirs: src
- default-language: Haskell2010
- ghc-options: -Wall
- -- Other library packages from which modules are imported.
- build-depends: base >=4.9 && < 5
- , sdl2 >= 2.5
- , linear
- , text
- , mtl
- , monad-loops
- , monad-parallel
- , containers
- , clock >= 0.8
- , glib
- , bytestring
- , OpenGL
- , OpenGLRaw
- , stm
- , uuid
- , vector
- , resourcet
-
--- This example shows the message system. only makes sense when compiling with
--- verbose flag.
-executable example00
- hs-source-dirs: examples/example00
- main-is: Main.hs
- ghc-options: -threaded -Wall
- default-language: Haskell2010
- default-extensions: OverloadedStrings
- 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
diff --git a/extern/affection/affection.nix b/extern/affection/affection.nix
deleted file mode 100644
index 9085818..0000000
--- a/extern/affection/affection.nix
+++ /dev/null
@@ -1,18 +0,0 @@
-{ 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;
-}
diff --git a/extern/affection/affection.svg b/extern/affection/affection.svg
deleted file mode 100644
index 22cbb76..0000000
--- a/extern/affection/affection.svg
+++ /dev/null
@@ -1,106 +0,0 @@
-
-
diff --git a/extern/affection/cabal.project b/extern/affection/cabal.project
deleted file mode 100644
index 7659ea4..0000000
--- a/extern/affection/cabal.project
+++ /dev/null
@@ -1,4 +0,0 @@
-constraints: affection +verbose +examples
-profiling: true
-packages:
- ./.
diff --git a/extern/affection/examples/example00/Main.hs b/extern/affection/examples/example00/Main.hs
deleted file mode 100644
index 3f8acfb..0000000
--- a/extern/affection/examples/example00/Main.hs
+++ /dev/null
@@ -1,196 +0,0 @@
-{-# 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))
diff --git a/extern/affection/examples/example01/Main.hs b/extern/affection/examples/example01/Main.hs
deleted file mode 100644
index 87484cd..0000000
--- a/extern/affection/examples/example01/Main.hs
+++ /dev/null
@@ -1,251 +0,0 @@
-{-# 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 ()
diff --git a/extern/affection/examples/example01/Types.hs b/extern/affection/examples/example01/Types.hs
deleted file mode 100644
index e56d7ae..0000000
--- a/extern/affection/examples/example01/Types.hs
+++ /dev/null
@@ -1,78 +0,0 @@
-{-# 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
diff --git a/extern/affection/examples/example02/Main.hs b/extern/affection/examples/example02/Main.hs
deleted file mode 100644
index 7fc079e..0000000
--- a/extern/affection/examples/example02/Main.hs
+++ /dev/null
@@ -1,253 +0,0 @@
-{-# 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 ()
diff --git a/extern/affection/examples/example02/Types.hs b/extern/affection/examples/example02/Types.hs
deleted file mode 100644
index e56d7ae..0000000
--- a/extern/affection/examples/example02/Types.hs
+++ /dev/null
@@ -1,78 +0,0 @@
-{-# 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
diff --git a/extern/affection/hie.yaml b/extern/affection/hie.yaml
deleted file mode 100644
index 04cd243..0000000
--- a/extern/affection/hie.yaml
+++ /dev/null
@@ -1,2 +0,0 @@
-cradle:
- cabal:
diff --git a/extern/affection/shell.nix b/extern/affection/shell.nix
deleted file mode 100644
index a4f6bdd..0000000
--- a/extern/affection/shell.nix
+++ /dev/null
@@ -1,7 +0,0 @@
-{ pkgs ? import {}}:
-
-let
- affection = pkgs.haskellPackages.callCabal2nix "affection" (gitignore ./.) {};
- gitignore = dir: pkgs.nix-gitignore.gitignoreSource [] dir;
-in
- affection.env
diff --git a/extern/affection/src/Affection.hs b/extern/affection/src/Affection.hs
deleted file mode 100644
index e99f1e9..0000000
--- a/extern/affection/src/Affection.hs
+++ /dev/null
@@ -1,204 +0,0 @@
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE Strict #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE TypeApplications #-}
-module Affection
- ( withAffection
- , get
- , put
- , liftIO
- , module A
- ) where
-
-import SDL (($=))
-import qualified SDL
-import qualified SDL.Raw.Video as SDL (glSetAttribute)
-import qualified SDL.Raw.Enum as SDL
-
-import qualified Graphics.Rendering.OpenGL as GL (clear, flush, ClearBuffer(..))
-import qualified Graphics.GL as GLRaw
-
-import Foreign.Marshal.Array
-
-import qualified Data.ByteString as B
-
-import Data.String (fromString)
-
-import System.Clock
-
-import Control.Monad.Loops
-import Control.Monad.State.Strict
-import Control.Monad.Trans.Resource
-
--- internal imports
-
-import Affection.Types as A
-import Affection.Class as A
-import Affection.StateMachine as A
-import Affection.Util as A
-import Affection.MessageBus as A
-import Affection.Subsystems as A
-
-import Affection.Logging as A
-
--- | Main function which bootstraps everything else.
-withAffection
- :: forall us. (Affectionate us)
- => AffectionConfig us -- ^ Configuration of the Game and its engine.
- -> IO ()
-withAffection AffectionConfig{..} = runResourceT $ do
- liftIO $ logIO Debug "Affection starting"
- liftIO $ logIO Debug "Initializing SDL"
-
- -- intialiaze SDL
- case initComponents of
- All ->
- SDL.initializeAll
- Only is ->
- SDL.initialize is
-
- -- give SDL render quality
- SDL.HintRenderScaleQuality SDL.$= SDL.ScaleLinear
-
- -- just checking…
- renderQuality <- SDL.get SDL.HintRenderScaleQuality
- when (renderQuality /= SDL.ScaleLinear) $
- liftIO $ logIO Warn "Linear texture filtering not enabled!"
- void $ liftIO (logIO Debug . fromString . show <$> (SDL.version :: IO (Integer, Integer, Integer)))
-
- -- construct window
- liftIO $ logIO Debug "Creating Window(s)"
- windows <-
- mapM
- (\(_, sdlWindowConfig, mode) -> do
- (windowKey, window) <-
- allocate
- (SDL.createWindow windowTitle sdlWindowConfig)
- (\window -> do
- logIO Debug "Destroying Window"
- SDL.destroyWindow window
- )
- return $ AffectionWindow window windowKey mode
- )
- windowConfigs
-
- -- Show windows
- mapM_ (SDL.showWindow . awWindow) windows
-
- -- set modes of windows
- mapM_ (\(AffectionWindow window _ mode) -> SDL.setWindowMode window mode) windows
-
- -- Make GL context shareable
- void $ SDL.glSetAttribute SDL.SDL_GL_SHARE_WITH_CURRENT_CONTEXT 1
-
- -- Create OpenGL contexts
- contexts <-
- mapM
- (\(AffectionWindow window _ _) -> do
- (contextKey, context) <-
- allocate
- (SDL.glCreateContext window)
- (\context -> do
- logIO Debug "Destroying context"
- SDL.glDeleteContext context
- )
- return $ AffectionContext context contextKey
- )
- windows
-
- -- sync updates with monitor
- -- SDL.swapInterval $= SDL.SynchronizedUpdates -- <- causes Problems with windows
-
- -- print current used GL Version
- version <- liftIO $ peekArray0 (0 :: Word8) =<< GLRaw.glGetString GLRaw.GL_VERSION
- liftIO $ print (B.pack version)
-
- -- get current time
- liftIO $ logIO Debug "Getting Time"
- execTime <- liftIO $ getTime Monotonic
- liftIO $ logIO Debug "Loading initial data container"
-
- -- construct game data object from provided Affectionate instance
- (gameDataKey, gameData) <-
- allocate
- (liftIO $ loadState @us)
- (liftIO . cleanUp)
- -- build state container
- let initContainer = AffectionData
- { drawWindows = windows
- , glContext = contexts
- , elapsedTime = 0
- , deltaTime = 0
- , sysTime = execTime
- , pausedTime = False
- }
-
- -- initialize and run state
- void $ liftIO $ runAffection initContainer
- (do
- liftIO $ logIO Debug "Running Pre-Loop stage"
-
- -- run preLoop function from Affectionate
- preLoop gameData
- liftIO $ logIO Debug "Starting Loop"
- whileM_ (hasNextStep gameData)
- (do
- -- get state
- ad <- get
-
- -- Measure time difference form last run
- now <- liftIO $ getTime Monotonic
- let lastTime = sysTime ad
-
- -- compute dt and update elapsedTime
- let dt = fromIntegral
- (toNanoSecs $ diffTimeSpec lastTime now) / (10 ^ (9 :: Int))
- ne = elapsedTime ad + dt
-
- -- update state data object with new time values
- put $ ad
- { elapsedTime = ne
- , deltaTime = dt
- }
-
- -- poll events
- liftIO SDL.pumpEvents
- evs <- preHandleEvents =<< liftIO SDL.pollEvents
-
- -- handle events
- handleEvents gameData evs
-
- -- execute user defined update loop
- unless (pausedTime ad) (update gameData dt)
-
- -- clear GL buffer >> execute user defined draw loop >> flush GL buffer
- liftIO $ GL.clear [GL.ColorBuffer, GL.DepthBuffer, GL.StencilBuffer]
- draw gameData
- liftIO GL.flush
-
- -- actual displaying of newly drawn frame
- mapM_ (SDL.glSwapWindow . awWindow) windows
-
- -- save new time
- ad3 <- get
- when (sysTime ad == sysTime ad3) (
- put ad3
- { sysTime = now
- }
- )
- )
- )
- -- Cleanup works
- liftIO $ logIO Debug "Loop ended. Cleaning"
- release gameDataKey
- -- mapM_ (SDL.glDeleteContext . snd) contexts
- -- mapM_ (SDL.destroyWindow . (\(_,y,_) -> y)) windows
- -- SDL.quit -- <- This causes segfaults depending on hardware
- liftIO $ logIO Debug "This is the end"
-
-runAffection
- :: AffectionData
- -> AffectionState AffectionData ResIO a
- -> IO (a, AffectionData)
-runAffection initialState a = runResourceT $ runStateT (A.runState a) initialState
diff --git a/extern/affection/src/Affection/Class.hs b/extern/affection/src/Affection/Class.hs
deleted file mode 100644
index bb09229..0000000
--- a/extern/affection/src/Affection/Class.hs
+++ /dev/null
@@ -1,21 +0,0 @@
-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
diff --git a/extern/affection/src/Affection/Logging.hs b/extern/affection/src/Affection/Logging.hs
deleted file mode 100644
index 6155d2b..0000000
--- a/extern/affection/src/Affection/Logging.hs
+++ /dev/null
@@ -1,54 +0,0 @@
-{-# 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 ()
diff --git a/extern/affection/src/Affection/MessageBus.hs b/extern/affection/src/Affection/MessageBus.hs
deleted file mode 100644
index 86a1ca1..0000000
--- a/extern/affection/src/Affection/MessageBus.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-module Affection.MessageBus
- ( module M
- ) where
-
-import Affection.MessageBus.Class as M
-import Affection.MessageBus.Message as M
diff --git a/extern/affection/src/Affection/MessageBus/Class.hs b/extern/affection/src/Affection/MessageBus/Class.hs
deleted file mode 100644
index 9a16f94..0000000
--- a/extern/affection/src/Affection/MessageBus/Class.hs
+++ /dev/null
@@ -1,68 +0,0 @@
-{-# 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
diff --git a/extern/affection/src/Affection/MessageBus/Message.hs b/extern/affection/src/Affection/MessageBus/Message.hs
deleted file mode 100644
index abf0f0c..0000000
--- a/extern/affection/src/Affection/MessageBus/Message.hs
+++ /dev/null
@@ -1,9 +0,0 @@
-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
diff --git a/extern/affection/src/Affection/MessageBus/Message/Class.hs b/extern/affection/src/Affection/MessageBus/Message/Class.hs
deleted file mode 100644
index 3da6039..0000000
--- a/extern/affection/src/Affection/MessageBus/Message/Class.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-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
diff --git a/extern/affection/src/Affection/MessageBus/Message/JoystickMessage.hs b/extern/affection/src/Affection/MessageBus/Message/JoystickMessage.hs
deleted file mode 100644
index 45fb34e..0000000
--- a/extern/affection/src/Affection/MessageBus/Message/JoystickMessage.hs
+++ /dev/null
@@ -1,67 +0,0 @@
-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
diff --git a/extern/affection/src/Affection/MessageBus/Message/KeyboardMessage.hs b/extern/affection/src/Affection/MessageBus/Message/KeyboardMessage.hs
deleted file mode 100644
index 9caef1f..0000000
--- a/extern/affection/src/Affection/MessageBus/Message/KeyboardMessage.hs
+++ /dev/null
@@ -1,26 +0,0 @@
-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
diff --git a/extern/affection/src/Affection/MessageBus/Message/MouseMessage.hs b/extern/affection/src/Affection/MessageBus/Message/MouseMessage.hs
deleted file mode 100644
index a13baff..0000000
--- a/extern/affection/src/Affection/MessageBus/Message/MouseMessage.hs
+++ /dev/null
@@ -1,54 +0,0 @@
-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
diff --git a/extern/affection/src/Affection/MessageBus/Message/WindowMessage.hs b/extern/affection/src/Affection/MessageBus/Message/WindowMessage.hs
deleted file mode 100644
index 994f023..0000000
--- a/extern/affection/src/Affection/MessageBus/Message/WindowMessage.hs
+++ /dev/null
@@ -1,106 +0,0 @@
-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
diff --git a/extern/affection/src/Affection/StateMachine.hs b/extern/affection/src/Affection/StateMachine.hs
deleted file mode 100644
index 7d9ab55..0000000
--- a/extern/affection/src/Affection/StateMachine.hs
+++ /dev/null
@@ -1,20 +0,0 @@
-{-# 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 ()
diff --git a/extern/affection/src/Affection/Subsystems.hs b/extern/affection/src/Affection/Subsystems.hs
deleted file mode 100644
index e48fa3e..0000000
--- a/extern/affection/src/Affection/Subsystems.hs
+++ /dev/null
@@ -1,9 +0,0 @@
-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
diff --git a/extern/affection/src/Affection/Subsystems/AffectionJoystick.hs b/extern/affection/src/Affection/Subsystems/AffectionJoystick.hs
deleted file mode 100644
index 9d75258..0000000
--- a/extern/affection/src/Affection/Subsystems/AffectionJoystick.hs
+++ /dev/null
@@ -1,119 +0,0 @@
-{-# 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
diff --git a/extern/affection/src/Affection/Subsystems/AffectionKeyboard.hs b/extern/affection/src/Affection/Subsystems/AffectionKeyboard.hs
deleted file mode 100644
index a78ccda..0000000
--- a/extern/affection/src/Affection/Subsystems/AffectionKeyboard.hs
+++ /dev/null
@@ -1,35 +0,0 @@
-{-# 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)
diff --git a/extern/affection/src/Affection/Subsystems/AffectionMouse.hs b/extern/affection/src/Affection/Subsystems/AffectionMouse.hs
deleted file mode 100644
index 6f6a599..0000000
--- a/extern/affection/src/Affection/Subsystems/AffectionMouse.hs
+++ /dev/null
@@ -1,61 +0,0 @@
-{-# 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)
diff --git a/extern/affection/src/Affection/Subsystems/AffectionWindow.hs b/extern/affection/src/Affection/Subsystems/AffectionWindow.hs
deleted file mode 100644
index f59e00c..0000000
--- a/extern/affection/src/Affection/Subsystems/AffectionWindow.hs
+++ /dev/null
@@ -1,74 +0,0 @@
-{-# 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)
diff --git a/extern/affection/src/Affection/Subsystems/Class.hs b/extern/affection/src/Affection/Subsystems/Class.hs
deleted file mode 100644
index ec55ae3..0000000
--- a/extern/affection/src/Affection/Subsystems/Class.hs
+++ /dev/null
@@ -1,13 +0,0 @@
-{-# 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]
diff --git a/extern/affection/src/Affection/Types.hs b/extern/affection/src/Affection/Types.hs
deleted file mode 100644
index e4fd82a..0000000
--- a/extern/affection/src/Affection/Types.hs
+++ /dev/null
@@ -1,87 +0,0 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveFunctor #-}
-module Affection.Types
- ( Affection
- , AffectionConfig(..)
- , AffectionData(..)
- , AffectionStateInner
- , AffectionState(..)
- , AffectionWindow(..)
- , AffectionContext(..)
- , InitComponents(..)
- , Angle
- -- | SDL reexports
- , SDL.WindowConfig(..)
- , SDL.WindowMode(..)
- , SDL.EventPayload(..)
- , SDL.InitFlag(..)
- , SDL.Window
- , SDL.GLContext
- ) where
-
-import qualified SDL.Init as SDL
-import qualified SDL.Video as SDL
-import qualified SDL.Event as SDL
-import qualified Data.Text as T
-
-import Control.Monad.IO.Class
-import Control.Monad.State.Strict
-import Control.Monad.Trans.Resource
-import qualified Control.Monad.Parallel as MP
-
-import System.Clock (TimeSpec)
-
--- | Configuration for the aplication. needed at startup.
-data AffectionConfig us = AffectionConfig
- { initComponents :: InitComponents
- -- ^ SDL components to initialize at startup
- , windowTitle :: T.Text
- -- ^ Window title
- , windowConfigs ::
- [
- ( Word -- --^ Window identifier
- , SDL.WindowConfig -- --^ Window config for given window
- , SDL.WindowMode -- -- ^ Window mode to start in
- )
- ]
- -- ^ Window configurations
- }
-
--- | Components to initialize in SDL.
-data InitComponents
- = All
- | Only [SDL.InitFlag]
-
--- | Main type for defining the look, feel and action of the whole application.
-data AffectionData = AffectionData
- { drawWindows :: [ AffectionWindow ] -- ^ SDL windows
- , glContext :: [ AffectionContext ] -- ^ OpenGL rendering contexts
- , elapsedTime :: Double -- ^ Elapsed time in seconds
- , deltaTime :: Double -- ^ Elapsed time in seconds since last tick
- , sysTime :: TimeSpec -- ^ System time (NOT the time on the clock)
- , pausedTime :: Bool -- ^ Should the update loop be executed?
- }
-
--- | Inner 'StateT' monad for the update state
-type AffectionStateInner sd m = StateT sd m
-
--- | Affection's state monad
-newtype AffectionState sd m a = AffectionState
- { runState :: AffectionStateInner sd m a }
- deriving (Functor, Applicative, Monad, MonadIO, MonadState sd, MonadResource)
-
-instance MP.MonadParallel m => MP.MonadParallel (AffectionState sd m)
-
-type Affection a = AffectionState AffectionData ResIO a
-
-type Angle = Double
-
-data AffectionWindow = AffectionWindow
- { awWindow :: SDL.Window
- , awReleaseKey :: ReleaseKey
- , awMode :: SDL.WindowMode
- }
-
-data AffectionContext = AffectionContext
- { acContext :: SDL.GLContext
- , acReleaseKey :: ReleaseKey
- }
diff --git a/extern/affection/src/Affection/Util.hs b/extern/affection/src/Affection/Util.hs
deleted file mode 100644
index 465620c..0000000
--- a/extern/affection/src/Affection/Util.hs
+++ /dev/null
@@ -1,89 +0,0 @@
-module Affection.Util where
-
-import Affection.Types
-import Affection.Logging
-import Affection.MessageBus.Message.WindowMessage
-
-import SDL (($=))
-import qualified SDL
-import qualified Graphics.Rendering.OpenGL as GL
-
-import System.Clock
-
-import Data.String (fromString)
-import Data.List (find)
-
-import Control.Monad.State
-
--- | Prehandle SDL events
-preHandleEvents :: [SDL.Event] -> Affection [SDL.EventPayload]
-preHandleEvents evs =
- return $ map SDL.eventPayload evs
-
--- | block a thread for a specified amount of time
-delaySec
- :: Int -- ^ Number of seconds
- -> IO ()
-delaySec dur = SDL.delay (fromIntegral $ dur * 1000)
-
--- | Get time since start but always the same in the current tick.
-getElapsedTime :: Affection Double
-getElapsedTime = gets elapsedTime
-
--- | Get delta time (time elapsed from last frame)
-getDelta :: Affection Double
-getDelta = gets deltaTime
-
--- | Toggle the Screen mode between 'SDL.Windowed' and 'SDL.FullscreenDesktop'.
--- Pauses the Engine in the process.
-toggleScreen :: Word -> Affection ()
-toggleScreen windowIdent = do
- ad <- get
- (stop, alteredWindowList) <- foldM
- (\(stop, resWindows) (num, aw@(AffectionWindow window _ mode)) -> do
- if stop || num == windowIdent
- then do
- newMode <- case mode of
- SDL.FullscreenDesktop -> do
- liftIO $ SDL.setWindowMode window SDL.Windowed
- return SDL.Windowed
- SDL.Windowed -> do
- liftIO $ SDL.setWindowMode window SDL.FullscreenDesktop
- return SDL.FullscreenDesktop
- x -> do
- liftIO $ logIO Warn ("Unexpected window mode: " <> fromString (show x))
- return x
- return (True, resWindows ++ [aw { awMode = newMode }])
- else
- return (stop, resWindows ++ [aw])
- )
- (False, [])
- (zip [0..] (drawWindows ad))
- if stop
- then do
- now <- liftIO $ getTime Monotonic
- put ad
- { sysTime = now
- , drawWindows = alteredWindowList
- }
- else
- liftIO $ logIO Warn ("No window found with ident " <> fromString (show windowIdent))
-
--- | Fit the GL Viewport to Window size
-fitViewport
- :: Double -- ^ Image Ratio (width / height)
- -> WindowMessage -- ^ Incoming Message. Listens only on
- -- 'MsgWindowResize' and ignores all others.
- -> Affection ()
-fitViewport ratio (MsgWindowResize _ _ (SDL.V2 w h)) = do
- liftIO $ logIO Verbose "Fitting Viewport to size"
- if (fromIntegral w / fromIntegral h) > ratio
- then do
- let nw = floor (fromIntegral h * ratio)
- dw = floor ((fromIntegral w - fromIntegral nw) / 2 :: Double)
- GL.viewport $= (GL.Position dw 0, GL.Size nw h)
- else do
- let nh = floor (fromIntegral w / ratio)
- dh = floor ((fromIntegral h - fromIntegral nh) / 2 :: Double)
- GL.viewport $= (GL.Position 0 dh, GL.Size w nh)
-fitViewport _ _ = return ()