From afd7f8da37d4f8ce142eb1c6ebbe70c805af28f3 Mon Sep 17 00:00:00 2001 From: nek0 Date: Mon, 11 Jul 2022 13:16:38 +0200 Subject: [PATCH] remove subtree --- extern/affection/.gitignore | 20 -- extern/affection/ChangeLog.md | 5 - extern/affection/LICENSE | 165 ------------ extern/affection/README.md | 8 - extern/affection/Setup.hs | 2 - extern/affection/affection.cabal | 182 ------------- extern/affection/affection.nix | 18 -- extern/affection/affection.svg | 106 -------- extern/affection/cabal.project | 4 - extern/affection/examples/example00/Main.hs | 196 -------------- extern/affection/examples/example01/Main.hs | 251 ----------------- extern/affection/examples/example01/Types.hs | 78 ------ extern/affection/examples/example02/Main.hs | 253 ------------------ extern/affection/examples/example02/Types.hs | 78 ------ extern/affection/hie.yaml | 2 - extern/affection/shell.nix | 7 - extern/affection/src/Affection.hs | 204 -------------- extern/affection/src/Affection/Class.hs | 21 -- extern/affection/src/Affection/Logging.hs | 54 ---- extern/affection/src/Affection/MessageBus.hs | 6 - .../src/Affection/MessageBus/Class.hs | 68 ----- .../src/Affection/MessageBus/Message.hs | 9 - .../src/Affection/MessageBus/Message/Class.hs | 6 - .../MessageBus/Message/JoystickMessage.hs | 67 ----- .../MessageBus/Message/KeyboardMessage.hs | 26 -- .../MessageBus/Message/MouseMessage.hs | 54 ---- .../MessageBus/Message/WindowMessage.hs | 106 -------- .../affection/src/Affection/StateMachine.hs | 20 -- extern/affection/src/Affection/Subsystems.hs | 9 - .../Affection/Subsystems/AffectionJoystick.hs | 119 -------- .../Affection/Subsystems/AffectionKeyboard.hs | 35 --- .../Affection/Subsystems/AffectionMouse.hs | 61 ----- .../Affection/Subsystems/AffectionWindow.hs | 74 ----- .../src/Affection/Subsystems/Class.hs | 13 - extern/affection/src/Affection/Types.hs | 87 ------ extern/affection/src/Affection/Util.hs | 89 ------ 36 files changed, 2503 deletions(-) delete mode 100644 extern/affection/.gitignore delete mode 100644 extern/affection/ChangeLog.md delete mode 100644 extern/affection/LICENSE delete mode 100644 extern/affection/README.md delete mode 100644 extern/affection/Setup.hs delete mode 100644 extern/affection/affection.cabal delete mode 100644 extern/affection/affection.nix delete mode 100644 extern/affection/affection.svg delete mode 100644 extern/affection/cabal.project delete mode 100644 extern/affection/examples/example00/Main.hs delete mode 100644 extern/affection/examples/example01/Main.hs delete mode 100644 extern/affection/examples/example01/Types.hs delete mode 100644 extern/affection/examples/example02/Main.hs delete mode 100644 extern/affection/examples/example02/Types.hs delete mode 100644 extern/affection/hie.yaml delete mode 100644 extern/affection/shell.nix delete mode 100644 extern/affection/src/Affection.hs delete mode 100644 extern/affection/src/Affection/Class.hs delete mode 100644 extern/affection/src/Affection/Logging.hs delete mode 100644 extern/affection/src/Affection/MessageBus.hs delete mode 100644 extern/affection/src/Affection/MessageBus/Class.hs delete mode 100644 extern/affection/src/Affection/MessageBus/Message.hs delete mode 100644 extern/affection/src/Affection/MessageBus/Message/Class.hs delete mode 100644 extern/affection/src/Affection/MessageBus/Message/JoystickMessage.hs delete mode 100644 extern/affection/src/Affection/MessageBus/Message/KeyboardMessage.hs delete mode 100644 extern/affection/src/Affection/MessageBus/Message/MouseMessage.hs delete mode 100644 extern/affection/src/Affection/MessageBus/Message/WindowMessage.hs delete mode 100644 extern/affection/src/Affection/StateMachine.hs delete mode 100644 extern/affection/src/Affection/Subsystems.hs delete mode 100644 extern/affection/src/Affection/Subsystems/AffectionJoystick.hs delete mode 100644 extern/affection/src/Affection/Subsystems/AffectionKeyboard.hs delete mode 100644 extern/affection/src/Affection/Subsystems/AffectionMouse.hs delete mode 100644 extern/affection/src/Affection/Subsystems/AffectionWindow.hs delete mode 100644 extern/affection/src/Affection/Subsystems/Class.hs delete mode 100644 extern/affection/src/Affection/Types.hs delete mode 100644 extern/affection/src/Affection/Util.hs 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 @@ - - - - - - - - image/svg+xml - - - - - - - - - - - - - - - - - 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 ()