diff --git a/extern/affection/.gitignore b/extern/affection/.gitignore new file mode 100644 index 0000000..fa507cf --- /dev/null +++ b/extern/affection/.gitignore @@ -0,0 +1,18 @@ +*.hi +*.o +.hsenv* +.stack-work +.git +.cabal-sandbox/ +cabal.sandbox.config +dist/ +*.prof +*.aux +*.hp +*.ps +*.swp +.ghc* +cabal.project.local* +dist*/ +report.html +*.bak diff --git a/extern/affection/ChangeLog.md b/extern/affection/ChangeLog.md new file mode 100644 index 0000000..dd649b3 --- /dev/null +++ b/extern/affection/ChangeLog.md @@ -0,0 +1,5 @@ +# 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 new file mode 100644 index 0000000..31afd6d --- /dev/null +++ b/extern/affection/LICENSE @@ -0,0 +1,165 @@ + 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 new file mode 100644 index 0000000..4664f5f --- /dev/null +++ b/extern/affection/README.md @@ -0,0 +1,8 @@ +# ![Affection logo](./affection.svg) + +A simple Game Engine in Haskell using SDL + +## Disclaimer + +This Engine is not stable yet. Things may change. horribly. +Even minor version bumps may break the API. diff --git a/extern/affection/Setup.hs b/extern/affection/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/extern/affection/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/extern/affection/affection.cabal b/extern/affection/affection.cabal new file mode 100644 index 0000000..4a324e3 --- /dev/null +++ b/extern/affection/affection.cabal @@ -0,0 +1,180 @@ +name: affection + +-- The package version. See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented. +-- http://www.haskell.org/haskellwiki/Package_versioning_policy +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 0.0.0.10 +synopsis: A simple Game Engine using SDL +description: This package contains Affection, a simple game engine + written in Haskell using SDL. + This Engine is still work in progress and even minor + version bumps may contain breaking api changes. +homepage: https://github.com/nek0/affection#readme +license: LGPL-3 +license-file: LICENSE +author: nek0 +maintainer: nek0@chelnok.de +category: Game +build-type: Simple +extra-source-files: ChangeLog.md + +-- Extra files to be distributed with the package, such as examples or a +-- README. +-- extra-source-files: + +cabal-version: >=2.0 + +source-repository head + type: git + location: https://github.com/nek0/affection + +flag verbose + description: Enable verbose debug messages + default: False + manual: True + +flag debug + description: Enable debug messages + default: False + manual: True + +flag warn + description: Enable warning messages + default: False + manual: True + +flag error + description: Enable error messages + default: False + manual: True + +flag examples + description: Build example programs + default: False + +library + if flag(verbose) + cpp-options: -DVERBOSE + if flag(debug) + cpp-options: -DDEBUG + if flag(warn) + cpp-options: -DWARN + if flag(error) + cpp-options: -DERROR + exposed-modules: Affection + , Affection.Logging + , Affection.Types + , Affection.Class + , Affection.StateMachine + , Affection.Util + , Affection.MessageBus + , Affection.MessageBus.Class + , Affection.MessageBus.Message + , Affection.MessageBus.Message.Class + , Affection.MessageBus.Message.WindowMessage + , Affection.MessageBus.Message.KeyboardMessage + , Affection.MessageBus.Message.MouseMessage + , Affection.MessageBus.Message.JoystickMessage + , Affection.Subsystems + , Affection.Subsystems.Class + , Affection.Subsystems.AffectionWindow + , Affection.Subsystems.AffectionKeyboard + , Affection.Subsystems.AffectionMouse + , Affection.Subsystems.AffectionJoystick + default-extensions: OverloadedStrings + , TypeFamilies + , AllowAmbiguousTypes + + -- Modules included in this library but not exported. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: GADTs + -- , KindSignatures + -- , FlexibleInstances + -- , MultiParamTypeClasses + -- , UndecidableInstances + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + -- Other library packages from which modules are imported. + build-depends: base >=4.9 && < 5 + , sdl2 ^>= 2.5 + , linear + , text + , mtl + , monad-loops + , monad-parallel + , containers + , clock >= 0.8 + , glib + , bytestring + , OpenGL + , stm + , uuid + , vector + +-- This example shows the message system. only makes sense when compiling with +-- verbose flag. +executable example00 + hs-source-dirs: examples/example00 + main-is: Main.hs + ghc-options: -threaded -Wall + default-language: Haskell2010 + default-extensions: OverloadedStrings + if flag(examples) + build-depends: base >=4.9 && < 5 + , affection + , sdl2 ^>= 2.5 + , stm + else + buildable: False + +-- A small game of life implementation +executable example01 + hs-source-dirs: examples/example01 + main-is: Main.hs + other-modules: Types + ghc-options: -threaded -Wall + default-language: Haskell2010 + default-extensions: OverloadedStrings + if flag(examples) + build-depends: base >=4.9 && < 5 + , affection + , sdl2 ^>= 2.5 + , stm + , OpenGL + , random + , containers + , linear + , matrix + , nanovg >= 0.6.0.0 + , deepseq + else + buildable: False + +-- Another small game of life implementation +executable example02 + hs-source-dirs: examples/example02 + main-is: Main.hs + other-modules: Types + ghc-options: -threaded -Wall + default-language: Haskell2010 + default-extensions: OverloadedStrings + if flag(examples) + build-depends: base >=4.9 && < 5 + , affection + , sdl2 ^>= 2.5 + , stm + , OpenGL + , random + , containers + , linear + , matrix + , nanovg >= 0.6.0.0 + , deepseq + else + buildable: False diff --git a/extern/affection/affection.nix b/extern/affection/affection.nix new file mode 100644 index 0000000..9085818 --- /dev/null +++ b/extern/affection/affection.nix @@ -0,0 +1,18 @@ +{ mkDerivation, base, bytestring, clock, containers, glib, linear +, monad-loops, monad-parallel, mtl, OpenGL, sdl2, stdenv, stm, text +, uuid, vector +}: +mkDerivation { + pname = "affection"; + version = "0.0.0.9"; + src = ./.; + isLibrary = true; + isExecutable = true; + libraryHaskellDepends = [ + base bytestring clock containers glib linear monad-loops + monad-parallel mtl OpenGL sdl2 stm text uuid vector + ]; + homepage = "https://github.com/nek0/affection#readme"; + description = "A simple Game Engine using SDL"; + license = stdenv.lib.licenses.lgpl3; +} diff --git a/extern/affection/affection.svg b/extern/affection/affection.svg new file mode 100644 index 0000000..22cbb76 --- /dev/null +++ b/extern/affection/affection.svg @@ -0,0 +1,106 @@ + + + + + + + + image/svg+xml + + + + + + + + + + + + + + + + + diff --git a/extern/affection/cabal.project b/extern/affection/cabal.project new file mode 100644 index 0000000..aac861d --- /dev/null +++ b/extern/affection/cabal.project @@ -0,0 +1,4 @@ +constraints: affection +verbose +profiling: true +packages: + ./. diff --git a/extern/affection/default.nix b/extern/affection/default.nix new file mode 100644 index 0000000..225fc5f --- /dev/null +++ b/extern/affection/default.nix @@ -0,0 +1,18 @@ +{ pkgs ? import (import (builtins.fetchTarball https://github.com/input-output-hk/haskell.nix/archive/master.tar.gz)) +, haskellCompiler ? "ghc865" +}: + pkgs.haskell-nix.cabalProject { + src = pkgs.haskell-nix.haskellLib.cleanGit { src = pkgs.nix-gitignore.gitignoreSource [] ./.; }; + ghc = pkgs.buildPackages.pkgs.haskell-nix.compiler.${haskellCompiler}; + # pkg-def-extras = [ + # # Additional packages ontop of all those listed in `cabal.project` + # ]; + # modules = [ + # # Specific package overrides would go here for example: + # packages.cbors.package.ghcOptions = "-Werror"; + # packages.cbors.patches = [ ./one.patch ]; + # packages.cbors.flags.optimize-gmp = false; + # # It may be better to set flags in `cabal.project` instead + # # (`plan-to-nix` will include them as defaults). + # ]; + } diff --git a/extern/affection/examples/example00/Main.hs b/extern/affection/examples/example00/Main.hs new file mode 100644 index 0000000..3f8acfb --- /dev/null +++ b/extern/affection/examples/example00/Main.hs @@ -0,0 +1,196 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} + +module Main where + +import Affection as A + +import Control.Concurrent.STM +import Control.Concurrent.MVar +import Control.Monad + +import qualified SDL + +import Data.Maybe (isJust, fromJust) +import Data.String + +data StateData = StateData + { sdSubs :: Subsystems + , sdJoys :: MVar [SDL.Joystick] + , doNextStep :: MVar Bool + } + +instance Affectionate StateData where + loadState = load + preLoop = pre + handleEvents = handle + update = Main.update + draw = Main.draw + cleanUp = clean + hasNextStep = liftIO . readMVar . doNextStep + +data Subsystems = Subsystems + { subWindow :: Main.Window + , subMouse :: Main.Mouse + , subKeyboard :: Main.Keyboard + , subJoystick :: Main.Joystick + } + +newtype Window = Window (TVar [(UUID, WindowMessage -> Affection ())]) +newtype Mouse = Mouse (TVar [(UUID, MouseMessage -> Affection ())]) +newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection ())]) +newtype Joystick = Joystick (TVar [(UUID, JoystickMessage -> Affection ())]) + +instance Participant Main.Window where + type Mesg Main.Window = WindowMessage + + partSubscribers (Window t) = generalSubscribers t + + partSubscribe (Window t) = generalSubscribe t + + partUnSubscribe (Window t) = generalUnSubscribe t + +instance SDLSubsystem Main.Window where + consumeSDLEvents = consumeSDLWindowEvents + +instance Participant Mouse where + type Mesg Mouse = MouseMessage + + partSubscribers (Mouse t) = generalSubscribers t + + partSubscribe (Mouse t) = generalSubscribe t + + partUnSubscribe (Mouse t) = generalUnSubscribe t + +instance SDLSubsystem Mouse where + consumeSDLEvents = consumeSDLMouseEvents + +instance Participant Keyboard where + type Mesg Keyboard = KeyboardMessage + + partSubscribers (Keyboard t) = generalSubscribers t + + partSubscribe (Keyboard t) = generalSubscribe t + + partUnSubscribe (Keyboard t) = generalUnSubscribe t + +instance SDLSubsystem Keyboard where + consumeSDLEvents = consumeSDLKeyboardEvents + +instance Participant Joystick where + type Mesg Joystick = JoystickMessage + + partSubscribers (Joystick t) = generalSubscribers t + + partSubscribe (Joystick t) = generalSubscribe t + + partUnSubscribe (Joystick t) = generalUnSubscribe t + +instance SDLSubsystem Joystick where + consumeSDLEvents = consumeSDLJoystickEvents + +main :: IO () +main = do + logIO Debug "Starting" + let conf = AffectionConfig + { initComponents = All + , windowTitle = "affection: example00" + , windowConfigs = + [ + ( 0 + , SDL.defaultWindow + { SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL + { SDL.glProfile = SDL.Core SDL.Normal 3 3 + } + } + , SDL.Windowed + ) + ] + } :: AffectionConfig StateData + withAffection conf + +load :: IO StateData +load = + StateData <$> (Subsystems + <$> (Window <$> newTVarIO []) + <*> (Mouse <$> newTVarIO []) + <*> (Keyboard <$> newTVarIO []) + <*> (Joystick <$> newTVarIO []) + ) + <*> newMVar [] + <*> newMVar True + +pre :: StateData -> Affection () +pre sd = do + _ <- partSubscribe (subKeyboard $ sdSubs sd) (exitOnQ (doNextStep sd)) + _ <- partSubscribe (subWindow $ sdSubs sd) (exitOnWindowClose (doNextStep sd)) + _ <- partSubscribe (subJoystick $ sdSubs sd) (joyConnectDisconnect (sdJoys sd)) + return () + +exitOnQ :: MVar Bool -> KeyboardMessage -> Affection () +exitOnQ nextStep (MsgKeyboardEvent _ _ _ _ sym) = + case SDL.keysymKeycode sym of + SDL.KeycodeQ -> do + liftIO $ logIO Debug "Yo dog I heard..." + void $ liftIO $ swapMVar nextStep False + _ -> return () + +exitOnWindowClose :: MVar Bool -> WindowMessage -> Affection () +exitOnWindowClose nextStep wm = + case wm of + MsgWindowClose _ _ -> do + liftIO $ logIO Debug "I heard another one..." + void $ liftIO $ swapMVar nextStep False + _ -> return () + +joyConnectDisconnect :: MVar [SDL.Joystick] -> JoystickMessage -> Affection () +joyConnectDisconnect mvjs msg = do + mj <- joystickAutoConnect msg + when (isJust mj) $ do + js <- liftIO $ readMVar mvjs + void $ liftIO $ swapMVar mvjs (fromJust mj : js) + js <- liftIO $ readMVar mvjs + njs <- joystickAutoDisconnect js msg + liftIO $ putMVar mvjs njs + +handle :: StateData -> [SDL.EventPayload] -> Affection () +handle sd es = do + let (Subsystems a b c d) = sdSubs sd + leftovers <- consumeSDLEvents a + =<< consumeSDLEvents b + =<< consumeSDLEvents c + =<< consumeSDLEvents d es + mapM_ (\e -> liftIO $ logIO Verbose $ "LEFTOVER: " <> fromString (show e)) + leftovers + +update :: StateData -> Double -> Affection () +update _ _ = return () + +draw :: StateData -> Affection () +draw _ = return () + +clean :: StateData -> IO () +clean _ = return () + +generalSubscribers + :: TVar [(UUID, msg -> Affection ())] + -> Affection [msg -> Affection ()] +generalSubscribers t = do + subTups <- liftIO $ readTVarIO t + return $ map snd subTups + +generalSubscribe + :: TVar [(UUID, msg -> Affection ())] + -> (msg -> Affection()) + -> Affection UUID +generalSubscribe t funct = do + uuid <- genUUID + liftIO $ atomically $ modifyTVar' t ((uuid, funct) :) + return uuid + +generalUnSubscribe + :: TVar [(UUID, msg -> Affection ())] + -> UUID + -> Affection () +generalUnSubscribe t uuid = + liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid)) diff --git a/extern/affection/examples/example01/Main.hs b/extern/affection/examples/example01/Main.hs new file mode 100644 index 0000000..87484cd --- /dev/null +++ b/extern/affection/examples/example01/Main.hs @@ -0,0 +1,251 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ForeignFunctionInterface #-} + +import Affection as A +import qualified SDL + +import Control.Concurrent.STM +import Control.Concurrent.MVar +import Control.Monad +import Control.DeepSeq (deepseq) + +import Data.Matrix as M +import qualified Data.Set as S +import Data.String + +import System.Random (randomRIO) + +import NanoVG hiding (V2(..)) + +import Foreign.C.Types (CInt(..)) + +-- internal imports + +import Types + +instance Affectionate UserData where + loadState = load + preLoop = pre + handleEvents = handle + update = Main.update + draw = Main.draw + cleanUp = clean + hasNextStep = liftIO . readMVar . doNextStep + +foreign import ccall unsafe "glewInit" + glewInit :: IO CInt + +main :: IO () +main = do + logIO A.Debug "Starting" + let conf = AffectionConfig + { initComponents = All + , windowTitle = "affection: example01" + , windowConfigs = + [ + ( 0 + , SDL.defaultWindow + { SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL + { SDL.glProfile = SDL.Core SDL.Normal 3 3 + } + , SDL.windowInitialSize = SDL.V2 600 600 + , SDL.windowResizable = True + } + , SDL.Windowed + ) + ] + } :: AffectionConfig UserData + withAffection conf + +load :: IO UserData +load = do + -- emptyMatrix <- zero 60 60 + liftIO $ logIO A.Debug "init GLEW" + _ <- glewInit + liftIO $ logIO A.Debug "making random" + randList <- mapM (\_ -> randomRIO (0,1)) [0 .. (3599 :: Int)] + liftIO $ logIO A.Debug "creating context" + nanoCtx <- createGL3 (S.fromList [Antialias, StencilStrokes, NanoVG.Debug]) + let fullMatrix = fromList 60 60 randList + -- logIO A.Debug $ prettyMatrix fullMatrix + empty1 <- newTVarIO [] -- ([] :: [(UUID, WindowMessage -> Affection ())]) + empty3 <- newTVarIO [] -- ([] :: [(UUID, KeyboardMessage -> Affection ())]) + step <- newMVar True + (\life food time -> UserData + { subsystems = Subsystems + (Window empty1) + (Keyboard empty3) + , lifeMat = life + , foodMat = food + , timeMat = time + , nano = nanoCtx + , doNextStep = step + } + ) + <$> newMVar fullMatrix + <*> (newMVar (fromList 60 60 (repeat 10))) + <*> (newMVar (M.zero 60 60)) + +pre :: UserData -> Affection () +pre ud = do + void $ partSubscribe (subKeyboard $ subsystems ud) (exitOnEsc (doNextStep ud)) + void $ partSubscribe (subKeyboard $ subsystems ud) (reloadOnR ud) + void $ partSubscribe (subKeyboard $ subsystems ud) showFPS + void $ partSubscribe (subKeyboard $ subsystems ud) toggleFullScreen + void $ partSubscribe (subWindow $ subsystems ud) (exitOnWindowClose (doNextStep ud)) + void $ partSubscribe (subWindow $ subsystems ud) (fitViewport (600/600)) + +toggleFullScreen :: KeyboardMessage -> Affection () +toggleFullScreen (MsgKeyboardEvent _ _ SDL.Pressed False sym) + | SDL.keysymKeycode sym == SDL.KeycodeF11 = toggleScreen 0 + | otherwise = return () +toggleFullScreen _ = return () + +exitOnEsc :: MVar Bool -> KeyboardMessage -> Affection () +exitOnEsc step (MsgKeyboardEvent _ _ SDL.Pressed False sym) = + case SDL.keysymKeycode sym of + SDL.KeycodeEscape -> do + liftIO $ logIO A.Debug "Yo dog I heard..." + void $ liftIO $ swapMVar step False + _ -> return () +exitOnEsc _ _ = return () + +reloadOnR :: UserData -> KeyboardMessage -> Affection () +reloadOnR ud (MsgKeyboardEvent _ _ _ _ sym) = + case SDL.keysymKeycode sym of + SDL.KeycodeR -> reload ud + _ -> return () + +reload :: UserData -> Affection () +reload ud = do + randList <- liftIO $ mapM (\_ -> randomRIO (0,1)) [0 .. (3599 :: Int)] + let fullMatrix = fromList 60 60 randList + void $ liftIO $ swapMVar (lifeMat ud) fullMatrix + void $ liftIO $ swapMVar (foodMat ud) (fromList 60 60 (repeat 10)) + void $ liftIO $ swapMVar (timeMat ud) (M.zero 60 60) + +showFPS :: KeyboardMessage -> Affection () +showFPS (MsgKeyboardEvent _ _ _ _ sym) = + case SDL.keysymKeycode sym of + SDL.KeycodeF -> do + dt <- getDelta + liftIO $ logIO A.Debug $ "FPS: " <> fromString (show (1 / dt)) + _ -> return () + +exitOnWindowClose :: MVar Bool -> WindowMessage -> Affection () +exitOnWindowClose step wm = + case wm of + MsgWindowClose _ _ -> do + liftIO $ logIO A.Debug "I heard another one..." + void $ liftIO $ swapMVar step False + _ -> return () + +handle :: UserData -> [SDL.EventPayload] -> Affection () +handle ud es = do + let (Subsystems a b) = subsystems ud + _ <- consumeSDLEvents a =<< consumeSDLEvents b es + return () + +update :: UserData -> Double -> Affection () +update ud _ = do + -- liftIO $ logIO A.Debug ("FPS: " <> fromString (show (1/dt))) + pastLife <- liftIO $ readMVar (lifeMat ud) + pastFood <- liftIO $ readMVar (foodMat ud) + pastTime <- liftIO $ readMVar (timeMat ud) + newList <- mapM (\coord -> do + let x = (coord `mod` 60) + 1 + y = (coord `div` 60) + 1 + subm + | x == 1 && y == 1 = + (submatrix 60 60 60 60 pastLife <|> submatrix 60 60 1 2 pastLife) + <-> + (submatrix 1 2 60 60 pastLife <|> submatrix 1 2 1 2 pastLife) + | x == 1 && y == 60 = + (submatrix 59 60 60 60 pastLife <|> submatrix 59 60 1 2 pastLife) + <-> + (submatrix 1 1 60 60 pastLife <|> submatrix 1 1 1 2 pastLife) + | x == 60 && y == 1 = + (submatrix 60 60 59 60 pastLife <|> submatrix 60 60 1 1 pastLife) + <-> + (submatrix 1 2 59 60 pastLife <|> submatrix 1 2 1 1 pastLife) + | x == 60 && y == 60 = + (submatrix 59 60 59 60 pastLife <|> submatrix 59 60 1 1 pastLife) + <-> + (submatrix 1 1 59 60 pastLife <|> submatrix 1 1 1 1 pastLife) + | x == 1 = + (submatrix (y - 1) (y + 1) 60 60 pastLife) + <|> + (submatrix (y - 1) (y + 1) 1 2 pastLife) + | y == 1 = + (submatrix 60 60 (x - 1) (x + 1) pastLife) + <-> + (submatrix 1 2 (x - 1) (x + 1) pastLife) + | x == 60 = + (submatrix (y - 1) (y + 1) 59 60 pastLife) + <|> + (submatrix (y - 1) (y + 1) 1 1 pastLife) + | y == 60 = + (submatrix 59 60 (x -1 ) (x + 1) pastLife) + <-> + (submatrix 1 1 (x - 1) (x + 1) pastLife) + | otherwise = + (submatrix (y - 1) (y + 1) (x - 1) (x + 1) pastLife) + life = countLife subm + if pastLife M.! (y, x) == 1 + then if (life == 2 || life == 3) && pastFood M.! (y, x) > 0 + then return (1, (pastFood M.! (y, x)) - 1, 0) + else return (0, pastFood M.! (y, x), 0) + else if life == 3 && pastFood M.! (y, x) > 0 + then return (1, (pastFood M.! (y, x)) - 1, 0) + else return + ( (0 :: Word) + , if pastTime M.! (y, x) > 10 + then min 10 ((pastFood M.! (y, x)) + 1) + else min 10 (pastFood M.! (y, x)) + , pastTime M.! (y, x) + 1 + ) + ) [0..3599] + let newLifeMat = fromList 60 60 (map (\(x, _, _) -> x) newList) + newFoodMat = fromList 60 60 (map (\(_, x, _) -> x) newList) + newTimeMat = fromList 60 60 (map (\(_, _, x) -> x) newList) + if newLifeMat == M.zero 60 60 + then + reload ud + else do + ((newLifeMat, newFoodMat, newTimeMat) `deepseq` return ()) + void $ liftIO $ swapMVar (lifeMat ud) newLifeMat + void $ liftIO $ swapMVar (timeMat ud) newTimeMat + +countLife :: Matrix Word -> Word +countLife mat = res - (mat M.! (2, 2)) + where + res = foldr (flip (+)) 0 mat + +draw :: UserData -> Affection () +draw ud = do + life <- liftIO $ readMVar (lifeMat ud) + food <- liftIO $ readMVar (foodMat ud) + liftIO $ do + beginFrame (nano ud) 600 600 1 + save (nano ud) + mapM_ (\coord -> do + let x = coord `mod` 60 + y = coord `div` 60 + ctx = nano ud + mult = life M.! (x + 1, y + 1) + -- logIO A.Debug $ show mult + beginPath ctx + rect ctx (fromIntegral $ x * 10) (fromIntegral $ y * 10) 10 10 + if mult == 1 + then + fillColor ctx (rgba 255 255 255 255) + else + fillColor ctx (rgba 0 (fromIntegral $ 25 * (food M.! (x+1, y+1))) 0 255) + fill ctx + ) [0..3599] + restore (nano ud) + endFrame (nano ud) + +clean :: UserData -> IO () +clean _ = return () diff --git a/extern/affection/examples/example01/Types.hs b/extern/affection/examples/example01/Types.hs new file mode 100644 index 0000000..e56d7ae --- /dev/null +++ b/extern/affection/examples/example01/Types.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} + +module Types where + +import Affection + +import Data.Matrix as M + +import NanoVG + +import Control.Concurrent.STM +import Control.Concurrent.MVar + +data UserData = UserData + { lifeMat :: MVar (Matrix Word) + , foodMat :: MVar (Matrix Word) + , timeMat :: MVar (Matrix Word) + , subsystems :: Subsystems + , nano :: Context + , doNextStep :: MVar Bool + } + +data Subsystems = Subsystems + { subWindow :: Types.Window + , subKeyboard :: Types.Keyboard + } + +newtype Window = Window (TVar [(UUID, WindowMessage -> Affection ())]) + +newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection ())]) + +instance Participant Types.Window where + type Mesg Types.Window = WindowMessage + + partSubscribers (Window t) = do + subTups <- liftIO $ readTVarIO t + return $ map snd subTups + + partSubscribe (Window t) = generalSubscribe t + + partUnSubscribe (Window t) = generalUnSubscribe t + +instance SDLSubsystem Types.Window where + consumeSDLEvents = consumeSDLWindowEvents + +instance Participant Keyboard where + type Mesg Keyboard = KeyboardMessage + + partSubscribers (Keyboard t) = do + subTups <- liftIO $ readTVarIO t + return $ map snd subTups + + partSubscribe (Keyboard t) = generalSubscribe t + + partUnSubscribe (Keyboard t) = generalUnSubscribe t + +instance SDLSubsystem Keyboard where + consumeSDLEvents = consumeSDLKeyboardEvents + +generalSubscribe + :: TVar [(UUID, msg -> Affection ())] + -> (msg -> Affection ()) + -> Affection UUID +generalSubscribe t funct = do + uuid <- genUUID + liftIO $ atomically $ modifyTVar' t ((uuid, funct) :) + return uuid + +generalUnSubscribe + :: TVar [(UUID, msg -> Affection ())] + -> UUID + -> Affection () +generalUnSubscribe t uuid = + liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uuid)) + where + filterMsg :: (UUID, msg -> Affection ()) -> UUID -> Bool + filterMsg (u, _) p = u /= p diff --git a/extern/affection/examples/example02/Main.hs b/extern/affection/examples/example02/Main.hs new file mode 100644 index 0000000..7fc079e --- /dev/null +++ b/extern/affection/examples/example02/Main.hs @@ -0,0 +1,253 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ForeignFunctionInterface #-} + +import Affection as A +import qualified SDL + +import Control.Concurrent.STM +import Control.Concurrent.MVar +import Control.Monad +import Control.DeepSeq (deepseq) + +import Data.Matrix as M +import qualified Data.Set as S +import Data.String + +import System.Random (randomRIO) + +import NanoVG hiding (V2(..)) + +import Foreign.C.Types (CInt(..)) + +-- internal imports + +import Types + +instance Affectionate UserData where + loadState = load + preLoop = pre + handleEvents = handle + update = Main.update + draw = Main.draw + cleanUp = clean + hasNextStep = liftIO . readMVar . doNextStep + +foreign import ccall unsafe "glewInit" + glewInit :: IO CInt + +maxFood :: Word +maxFood = 255 + +main :: IO () +main = do + logIO A.Debug "Starting" + let conf = AffectionConfig + { initComponents = All + , windowTitle = "affection: example01" + , windowConfigs = + [ + ( 0 + , SDL.defaultWindow + { SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL + { SDL.glProfile = SDL.Core SDL.Normal 3 3 + } + , SDL.windowInitialSize = SDL.V2 600 600 + , SDL.windowResizable = True + } + , SDL.Windowed + ) + ] + } :: AffectionConfig UserData + withAffection conf + +load :: IO UserData +load = do + -- emptyMatrix <- zero 60 60 + liftIO $ logIO A.Debug "init GLEW" + _ <- glewInit + liftIO $ logIO A.Debug "making random" + randList <- mapM (\_ -> randomRIO (0,1)) [0 .. (3599 :: Int)] + liftIO $ logIO A.Debug "creating context" + nanoCtx <- createGL3 (S.fromList [Antialias, StencilStrokes, NanoVG.Debug]) + let fullMatrix = fromList 60 60 randList + -- logIO A.Debug $ prettyMatrix fullMatrix + empty1 <- newTVarIO [] -- ([] :: [(UUID, WindowMessage -> Affection ())]) + empty3 <- newTVarIO [] -- ([] :: [(UUID, KeyboardMessage -> Affection ())]) + (\life food time nextStep -> UserData + { subsystems = Subsystems + (Window empty1) + (Keyboard empty3) + , lifeMat = life + , foodMat = food + , timeMat = time + , nano = nanoCtx + , doNextStep = nextStep + } + ) + <$> newMVar fullMatrix + <*> newMVar (fromList 60 60 (repeat maxFood)) + <*> newMVar (M.zero 60 60) + <*> newMVar True + +pre :: UserData -> Affection () +pre ud = do + void $ partSubscribe (subKeyboard $ subsystems ud) (exitOnEsc (doNextStep ud)) + void $ partSubscribe (subKeyboard $ subsystems ud) (reloadOnR ud) + void $ partSubscribe (subKeyboard $ subsystems ud) showFPS + void $ partSubscribe (subKeyboard $ subsystems ud) toggleFullScreen + void $ partSubscribe (subWindow $ subsystems ud) (exitOnWindowClose (doNextStep ud)) + void $ partSubscribe (subWindow $ subsystems ud) (fitViewport (600/600)) + +toggleFullScreen :: KeyboardMessage -> Affection () +toggleFullScreen (MsgKeyboardEvent _ _ SDL.Pressed False sym) + | SDL.keysymKeycode sym == SDL.KeycodeF11 = toggleScreen 0 + | otherwise = return () +toggleFullScreen _ = return () + +exitOnEsc :: MVar Bool -> KeyboardMessage -> Affection () +exitOnEsc step (MsgKeyboardEvent _ _ SDL.Pressed False sym) = + case SDL.keysymKeycode sym of + SDL.KeycodeEscape -> do + liftIO $ logIO A.Debug "Yo dog I heard..." + void $ liftIO $ swapMVar step False + _ -> return () +exitOnEsc _ _ = return () + +reloadOnR :: UserData -> KeyboardMessage -> Affection () +reloadOnR ud (MsgKeyboardEvent _ _ _ _ sym) = + case SDL.keysymKeycode sym of + SDL.KeycodeR -> reload ud + _ -> return () + +reload :: UserData -> Affection () +reload ud = do + randList <- liftIO $ mapM (\_ -> randomRIO (0,1)) [0 .. (3599 :: Int)] + let fullMatrix = fromList 60 60 randList + void $ liftIO $ swapMVar (lifeMat ud) fullMatrix + void $ liftIO $ swapMVar (foodMat ud) (fromList 60 60 (repeat maxFood)) + void $ liftIO $ swapMVar (timeMat ud) (M.zero 60 60) + +showFPS :: KeyboardMessage -> Affection () +showFPS (MsgKeyboardEvent _ _ _ _ sym) = + case SDL.keysymKeycode sym of + SDL.KeycodeF -> do + dt <- getDelta + liftIO $ logIO A.Debug $ "FPS: " <> fromString (show (1 / dt)) + _ -> return () + +exitOnWindowClose :: MVar Bool -> WindowMessage -> Affection () +exitOnWindowClose step wm = + case wm of + MsgWindowClose _ _ -> do + liftIO $ logIO A.Debug "I heard another one..." + void $ liftIO $ swapMVar step False + _ -> return () + +handle :: UserData -> [SDL.EventPayload] -> Affection () +handle ud es = do + let (Subsystems a b) = subsystems ud + _ <- consumeSDLEvents a =<< consumeSDLEvents b es + return () + +update :: UserData -> Double -> Affection () +update ud _ = do + pastLife <- liftIO $ readMVar (lifeMat ud) + pastFood <- liftIO $ readMVar (foodMat ud) + pastTime <- liftIO $ readMVar (timeMat ud) + newList <- mapM (\coord -> do + let x = (coord `mod` 60) + 1 + y = (coord `div` 60) + 1 + subm + | x == 1 && y == 1 = + (submatrix 60 60 60 60 pastLife <|> submatrix 60 60 1 2 pastLife) + <-> + (submatrix 1 2 60 60 pastLife <|> submatrix 1 2 1 2 pastLife) + | x == 1 && y == 60 = + (submatrix 59 60 60 60 pastLife <|> submatrix 59 60 1 2 pastLife) + <-> + (submatrix 1 1 60 60 pastLife <|> submatrix 1 1 1 2 pastLife) + | x == 60 && y == 1 = + (submatrix 60 60 59 60 pastLife <|> submatrix 60 60 1 1 pastLife) + <-> + (submatrix 1 2 59 60 pastLife <|> submatrix 1 2 1 1 pastLife) + | x == 60 && y == 60 = + (submatrix 59 60 59 60 pastLife <|> submatrix 59 60 1 1 pastLife) + <-> + (submatrix 1 1 59 60 pastLife <|> submatrix 1 1 1 1 pastLife) + | x == 1 = + (submatrix (y - 1) (y + 1) 60 60 pastLife) + <|> + (submatrix (y - 1) (y + 1) 1 2 pastLife) + | y == 1 = + (submatrix 60 60 (x - 1) (x + 1) pastLife) + <-> + (submatrix 1 2 (x - 1) (x + 1) pastLife) + | x == 60 = + (submatrix (y - 1) (y + 1) 59 60 pastLife) + <|> + (submatrix (y - 1) (y + 1) 1 1 pastLife) + | y == 60 = + (submatrix 59 60 (x -1 ) (x + 1) pastLife) + <-> + (submatrix 1 1 (x - 1) (x + 1) pastLife) + | otherwise = + (submatrix (y - 1) (y + 1) (x - 1) (x + 1) pastLife) + life = countLife subm + if pastLife M.! (y, x) == 1 + then if (life == 2 || life == 3) && pastFood M.! (y, x) > 0 + then return (1, (pastFood M.! (y, x)) - 1, 0) + else return (0, pastFood M.! (y, x), 0) + else if life == 3 && pastFood M.! (y, x) > 0 + then return (1, (pastFood M.! (y, x)) - 1, 0) + else return + ( 0 :: Word + , if pastTime M.! (y, x) > 10 + then min maxFood ((pastFood M.! (y, x)) + 1) + else min maxFood (pastFood M.! (y, x)) + , pastTime M.! (y, x) + 1 + ) + ) [0..3599] + let newLifeMat = fromList 60 60 (map (\(x, _, _) -> x) newList) + newFoodMat = fromList 60 60 (map (\(_, x, _) -> x) newList) + newTimeMat = fromList 60 60 (map (\(_, _, x) -> x) newList) + if newLifeMat == M.zero 60 60 + then + reload ud + else do + ((newLifeMat, newFoodMat, newTimeMat) `deepseq` return ()) + void $ liftIO $ swapMVar (lifeMat ud) newLifeMat + void $ liftIO $ swapMVar (timeMat ud) newTimeMat + void $ liftIO $ swapMVar (foodMat ud) newFoodMat + +countLife :: Matrix Word -> Word +countLife mat = res - (mat M.! (2, 2)) + where + res = foldr (flip (+)) 0 mat + +draw :: UserData -> Affection () +draw ud = liftIO $ do + pastLife <- readMVar (lifeMat ud) + pastFood <- readMVar (foodMat ud) + beginFrame (nano ud) 600 600 1 + save (nano ud) + mapM_ (\coord -> do + let x = coord `mod` 60 + y = coord `div` 60 + ctx = nano ud + multiplicator = pastLife M.! (x + 1, y + 1) + -- logIO A.Debug $ show mult + beginPath ctx + rect ctx (fromIntegral $ x * 10) (fromIntegral $ y * 10) 10 10 + if multiplicator == 1 + then + fillColor ctx (rgba 255 255 255 255) + else + fillColor ctx (rgba 0 (fromIntegral $ (255 `div` maxFood) * (pastFood M.! (x+1, y+1))) 0 255) + fill ctx + ) [0..3599] + restore (nano ud) + endFrame (nano ud) + +clean :: UserData -> IO () +clean _ = return () diff --git a/extern/affection/examples/example02/Types.hs b/extern/affection/examples/example02/Types.hs new file mode 100644 index 0000000..e56d7ae --- /dev/null +++ b/extern/affection/examples/example02/Types.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} + +module Types where + +import Affection + +import Data.Matrix as M + +import NanoVG + +import Control.Concurrent.STM +import Control.Concurrent.MVar + +data UserData = UserData + { lifeMat :: MVar (Matrix Word) + , foodMat :: MVar (Matrix Word) + , timeMat :: MVar (Matrix Word) + , subsystems :: Subsystems + , nano :: Context + , doNextStep :: MVar Bool + } + +data Subsystems = Subsystems + { subWindow :: Types.Window + , subKeyboard :: Types.Keyboard + } + +newtype Window = Window (TVar [(UUID, WindowMessage -> Affection ())]) + +newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection ())]) + +instance Participant Types.Window where + type Mesg Types.Window = WindowMessage + + partSubscribers (Window t) = do + subTups <- liftIO $ readTVarIO t + return $ map snd subTups + + partSubscribe (Window t) = generalSubscribe t + + partUnSubscribe (Window t) = generalUnSubscribe t + +instance SDLSubsystem Types.Window where + consumeSDLEvents = consumeSDLWindowEvents + +instance Participant Keyboard where + type Mesg Keyboard = KeyboardMessage + + partSubscribers (Keyboard t) = do + subTups <- liftIO $ readTVarIO t + return $ map snd subTups + + partSubscribe (Keyboard t) = generalSubscribe t + + partUnSubscribe (Keyboard t) = generalUnSubscribe t + +instance SDLSubsystem Keyboard where + consumeSDLEvents = consumeSDLKeyboardEvents + +generalSubscribe + :: TVar [(UUID, msg -> Affection ())] + -> (msg -> Affection ()) + -> Affection UUID +generalSubscribe t funct = do + uuid <- genUUID + liftIO $ atomically $ modifyTVar' t ((uuid, funct) :) + return uuid + +generalUnSubscribe + :: TVar [(UUID, msg -> Affection ())] + -> UUID + -> Affection () +generalUnSubscribe t uuid = + liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uuid)) + where + filterMsg :: (UUID, msg -> Affection ()) -> UUID -> Bool + filterMsg (u, _) p = u /= p diff --git a/extern/affection/notes/TODO.md b/extern/affection/notes/TODO.md new file mode 100644 index 0000000..6a15c72 --- /dev/null +++ b/extern/affection/notes/TODO.md @@ -0,0 +1,9 @@ +# TODO + +Implement following things in approximately this Order: + +* Message bus -> DONE +* Console +* GUI +* Framework +* Everything else diff --git a/extern/affection/shell.nix b/extern/affection/shell.nix new file mode 100644 index 0000000..6d4b133 --- /dev/null +++ b/extern/affection/shell.nix @@ -0,0 +1,125 @@ +{ nixpkgs ? import {}, compiler ? "default", doBenchmark ? false }: + +let + + inherit (nixpkgs) pkgs; + + nanovg = with haskellPackages; callPackage ( + { mkDerivation, base, bytestring, c2hs, containers, glew + , hspec, inline-c, libGL, libGLU, QuickCheck, stdenv, text, vector + }: + mkDerivation { + pname = "nanovg"; + version = "0.6.0.0"; + sha256 = "e35a2772f2a2e71916013cab70eeb8eedd6f66b5490ddf7ce237c8c76895d496"; + revision = "1"; + editedCabalFile = "1lhfsq50r9bdby7mfscw8ih3wsz2m19lr2a2z9b6diaf5kz76vij"; + isLibrary = true; + isExecutable = true; + doCheck = false; + libraryHaskellDepends = [ base bytestring containers text vector ]; + librarySystemDepends = [ glew libGL libGLU ]; + libraryPkgconfigDepends = [ glew ]; + libraryToolDepends = [ c2hs ]; + testHaskellDepends = [ base containers hspec inline-c QuickCheck ]; + homepage = "https://github.com/cocreature/nanovg-hs"; + description = "Haskell bindings for nanovg"; + license = stdenv.lib.licenses.isc; + }) {}; + + glib = with haskellPackages; callPackage( + { mkDerivation, base, bytestring, Cabal, containers, glib + , stdenv, text, utf8-string, gtk2hs-buildtools + }: + mkDerivation { + pname = "glib"; + version = "0.13.8.0"; + sha256 = "9cce6fb44e3c30de2bd330a6902955e3a5fce7b6e9ce41a4afb70e3a7d6e61a2"; + setupHaskellDepends = [ base Cabal gtk2hs-buildtools ]; + libraryHaskellDepends = [ + base bytestring containers text utf8-string + ]; + libraryPkgconfigDepends = [ pkgs.glib ]; + homepage = "http://projects.haskell.org/gtk2hs/"; + description = "Binding to the GLIB library for Gtk2Hs"; + license = stdenv.lib.licenses.lgpl21; + }) {}; + + #gtk2hs-buildtools = with haskellPackages; callPackage( + # { mkDerivation, alex, array, base, Cabal, containers, directory + # , filepath, happy, hashtables, pretty, process, random, stdenv + # }: + # mkDerivation { + # pname = "gtk2hs-buildtools"; + # version = "0.13.4.0"; + # src = ../gtk2hs/tools; + # isLibrary = true; + # isExecutable = true; + # enableSeparateDataOutput = true; + # libraryHaskellDepends = [ + # array base Cabal containers directory filepath hashtables pretty + # process random + # ]; + # libraryToolDepends = [ alex happy ]; + # executableHaskellDepends = [ base ]; + # homepage = "http://projects.haskell.org/gtk2hs/"; + # description = "Tools to build the Gtk2Hs suite of User Interface libraries"; + # license = stdenv.lib.licenses.gpl2; + # }) {}; + + sdl2 = with haskellPackages; callPackage( + { mkDerivation, base, bytestring, deepseq, exceptions, linear, SDL2 + , StateVar, stdenv, text, transformers, vector, weigh + }: + mkDerivation { + pname = "sdl2"; + version = "2.5.1.0"; + sha256 = "fc1d3d4276b2c4f835a5311075abb240385aae7edad8760f6bda55ed8271ed20"; + isLibrary = true; + isExecutable = true; + enableSeparateDataOutput = true; + libraryHaskellDepends = [ + base bytestring exceptions linear StateVar text transformers vector + ]; + librarySystemDepends = [ SDL2 ]; + libraryPkgconfigDepends = [ SDL2 ]; + testHaskellDepends = [ base deepseq linear vector weigh ]; + description = "Both high- and low-level bindings to the SDL library (version 2.0.6+)."; + license = stdenv.lib.licenses.bsd3; + doCheck = false; + }) {}; + + f = { mkDerivation, base, bytestring, clock, containers, deepseq + , linear, matrix, monad-loops, monad-parallel, mtl + , OpenGL, random, stdenv, stm, text, uuid, vector + }: + mkDerivation { + pname = "affection"; + version = "0.0.0.9"; + src = ./.; + configureFlags = [ "-fexamples" ]; + isLibrary = true; + isExecutable = true; + libraryHaskellDepends = [ + base bytestring clock containers glib linear monad-loops + monad-parallel mtl OpenGL sdl2 stm text uuid vector + ]; + executableHaskellDepends = [ + base containers deepseq linear matrix nanovg OpenGL random sdl2 stm + ]; + homepage = "https://github.com/nek0/affection#readme"; + description = "A simple Game Engine using SDL"; + license = stdenv.lib.licenses.lgpl3; + }; + + haskellPackages = if compiler == "default" + then pkgs.haskellPackages + else pkgs.haskell.packages.${compiler}; + + variant = if doBenchmark then pkgs.haskell.lib.doBenchmark else pkgs.lib.id; + + drv = variant (haskellPackages.callPackage f {}); + +in + + if pkgs.lib.inNixShell then drv.env else drv diff --git a/extern/affection/src/Affection.hs b/extern/affection/src/Affection.hs new file mode 100644 index 0000000..2b1f908 --- /dev/null +++ b/extern/affection/src/Affection.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} +module Affection + ( withAffection + , get + , put + , liftIO + , module A + ) where + +import SDL (($=)) +import qualified SDL +import qualified SDL.Raw.Video as SDL (glSetAttribute) +import qualified SDL.Raw.Enum as SDL + +import System.Clock + +import Control.Monad.Loops +import Control.Monad.State.Strict + +import Affection.Types as A +import Affection.Class as A +import Affection.StateMachine as A +import Affection.Util as A +import Affection.MessageBus as A +import Affection.Subsystems as A + +import Affection.Logging as A + +import qualified Graphics.Rendering.OpenGL as GL (clear, flush, ClearBuffer(..)) + + +-- | Main function which bootstraps everything else. +withAffection + :: forall us. (Affectionate us) + => AffectionConfig us -- ^ Configuration of the Game and its engine. + -> IO () +withAffection AffectionConfig{..} = do + liftIO $ logIO Debug "Affection starting" + liftIO $ logIO Debug "Initializing SDL" + -- intialiaze SDL + case initComponents of + All -> + SDL.initializeAll + Only is -> + SDL.initialize is + -- give SDL render quality + SDL.HintRenderScaleQuality SDL.$= SDL.ScaleLinear + -- just checking… + do + renderQuality <- SDL.get SDL.HintRenderScaleQuality + when (renderQuality /= SDL.ScaleLinear) $ + logIO Warn "Linear texture filtering not enabled!" + -- construct window + liftIO $ logIO Debug "Creating Window(s)" + windows <- zip3 (map (\(x,_,_) -> x) windowConfigs) <$> + mapM + (\wc -> SDL.createWindow windowTitle ((\(_,y,_) -> y) wc)) + windowConfigs <*> + pure (map (\(_,_,z) -> z) windowConfigs) + + mapM_ (SDL.showWindow . (\(_,y,_) -> y)) windows + _ <- SDL.glSetAttribute SDL.SDL_GL_SHARE_WITH_CURRENT_CONTEXT 1 + contexts <- zip (map (\(x,_,_) -> x) windows) <$> + mapM (SDL.glCreateContext . (\(_,y,_) -> y)) windows + mapM_ (\w -> flip SDL.setWindowMode ((\(_,_,z) -> z) w) ((\(_,y,_) -> y) w)) windows + -- SDL.swapInterval $= SDL.SynchronizedUpdates -- <- causes Problems with windows + liftIO $ logIO Debug "Getting Time" + -- get current time + execTime <- getTime Monotonic + liftIO $ logIO Debug "Loading initial data container" + -- construct game data object from provided Affectionate instance + gameData <- loadState @us + -- build state container + let initContainer = AffectionData + { drawWindows = windows + , glContext = contexts + , elapsedTime = 0 + , deltaTime = 0 + , sysTime = execTime + , pausedTime = False + } + -- initialize and run state + (_, _) <- runStateT + (A.runState + (do + liftIO $ logIO Debug "Starting Loop" + -- run preLoop function from Affectionate + preLoop gameData + whileM_ (hasNextStep gameData) + (do + -- get state + ad <- get + -- Measure time difference form last run + now <- liftIO $ getTime Monotonic + let lastTime = sysTime ad + -- compute dt and update elapsedTime + let !dt = fromIntegral + (toNanoSecs $ diffTimeSpec lastTime now) / (10 ^ (9 :: Int)) + !ne = elapsedTime ad + dt + -- update state data object with new time values + put $ ad + { elapsedTime = ne + , deltaTime = dt + } + -- poll events + evs <- preHandleEvents =<< liftIO SDL.pollEvents + -- handle events + handleEvents gameData evs + -- execute user defined update loop + unless (pausedTime ad) (update gameData dt) + -- clear GL buffer >> execute user defined draw loop >> flush GL buffer + liftIO $ GL.clear [GL.ColorBuffer, GL.DepthBuffer, GL.StencilBuffer] + draw gameData + liftIO GL.flush + -- actual displaying of newly drawn frame + mapM_ (SDL.glSwapWindow . (\(_,y,_) -> y)) windows + -- save new time + ad3 <- get + when (sysTime ad == sysTime ad3) ( + put ad3 + { sysTime = now + } + ) + ) + ) + ) initContainer + liftIO $ logIO Debug "Loop ended. Cleaning" + cleanUp gameData + liftIO $ logIO Debug "Destroying Window" + mapM_ (SDL.glDeleteContext . snd) contexts + mapM_ (SDL.destroyWindow . (\(_,y,_) -> y)) windows + -- SDL.quit -- <- This causes segfaults depending on hardware + liftIO $ logIO Debug "This is the end" diff --git a/extern/affection/src/Affection/Class.hs b/extern/affection/src/Affection/Class.hs new file mode 100644 index 0000000..bb09229 --- /dev/null +++ b/extern/affection/src/Affection/Class.hs @@ -0,0 +1,21 @@ +module Affection.Class where + +import qualified SDL + +import Affection.Types as A + +class Affectionate a where + + loadState :: IO a + + preLoop :: a -> Affection () + + handleEvents :: a -> [SDL.EventPayload] -> Affection () + + update :: a -> Double -> Affection () + + draw :: a -> Affection () + + cleanUp :: a -> IO () + + hasNextStep :: a -> Affection Bool diff --git a/extern/affection/src/Affection/Logging.hs b/extern/affection/src/Affection/Logging.hs new file mode 100644 index 0000000..6155d2b --- /dev/null +++ b/extern/affection/src/Affection/Logging.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE CPP #-} +-- | This module defines the logging capability of Affection, whis is derived +-- from "Debug.Trace". +module Affection.Logging where + +import qualified Data.Text as T + +import Debug.Trace + +-- | The log level definition +data LogLevel + = Verbose -- ^ Log everything + | Debug -- ^ Log Debug messages and above + | Warn -- ^ Log only Warnings and errors + | Error -- ^ Log only errors + +-- | Pure logging function +log + :: LogLevel -- ^ Log level to log to + -> T.Text -- ^ The message string + -> a -- ^ Arbitrary datatype to return + -> a -- ^ Returned data +#if defined(VERBOSE) +log Verbose s = trace ("VERBOSE: " ++ T.unpack s) +#endif +#if defined(DEBUG) || defined(VERBOSE) +log Debug s = trace ("DEBUG: " ++ T.unpack s) +#endif +#if defined(WARN) || defined(DEBUG) || defined(VERBOSE) +log Warn s = trace ("WARN: " ++ T.unpack s) +#endif +#if defined(ERROR) || defined(WARN) || defined(DEBUG) || defined(VERBOSE) +log Error s = trace ("ERROR: " ++ T.unpack s) +#endif +log _ _ = id + +-- | Manadic logging function residing in the 'IO' Monad +logIO + :: LogLevel -- ^ Log level to log to + -> T.Text -- ^ The message string + -> IO () +#if defined(VERBOSE) +logIO Verbose s = traceIO ("VERBOSE: " ++ T.unpack s) +#endif +#if defined(DEBUG) || defined(VERBOSE) +logIO Debug s = traceIO ("DEBUG: " ++ T.unpack s) +#endif +#if defined(WARN) || defined(DEBUG) || defined(VERBOSE) +logIO Warn s = traceIO ("WARN: " ++ T.unpack s) +#endif +#if defined(ERROR) || defined(WARN) || defined(DEBUG) || defined(VERBOSE) +logIO Error s = traceIO ("ERROR: " ++ T.unpack s) +#endif +logIO _ _ = return () diff --git a/extern/affection/src/Affection/MessageBus.hs b/extern/affection/src/Affection/MessageBus.hs new file mode 100644 index 0000000..6ae83e4 --- /dev/null +++ b/extern/affection/src/Affection/MessageBus.hs @@ -0,0 +1,9 @@ +module Affection.MessageBus + ( module M + , module Msg + ) where + +import Affection.MessageBus.Class as M +import Affection.MessageBus.Message as M + +import Affection.MessageBus.Message as Msg diff --git a/extern/affection/src/Affection/MessageBus/Class.hs b/extern/affection/src/Affection/MessageBus/Class.hs new file mode 100644 index 0000000..9a16f94 --- /dev/null +++ b/extern/affection/src/Affection/MessageBus/Class.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ExistentialQuantification #-} +module Affection.MessageBus.Class + ( Participant(..) + , genUUID + , UUID + ) where + +import Affection.MessageBus.Message +import Affection.Types + +import Control.Monad.IO.Class (liftIO) + +import Data.UUID +import Data.UUID.V4 + +import Data.String as S (fromString) + +import Affection.Logging + +-- | This typeclass defines the behaviour of a participant in the message system +class (Message (Mesg prt), Show (Mesg prt)) => Participant prt where + -- | Message datatype + type Mesg prt :: * + + -- | Function to get the list of subscribers from the participant + partSubscribers + :: prt + -- ^ the 'Participant''s subscriber storage + -> Affection [Mesg prt -> Affection ()] + -- ^ List of Subscriber functions + + -- | Subscribe to the 'Participant''s events + partSubscribe + :: prt + -- ^ The 'Participant''s subscriber storage + -> (Mesg prt -> Affection ()) + -- ^ What to do in case of a 'Message' + -- (Subscriber function) + -> Affection UUID + -- ^ 'UUID' of the registered subscriber Function + + -- | Unsubscribe a Subscriber function from Participant + partUnSubscribe + :: prt + -- ^ The 'Participant''s subscriber storage to unsubscribe from + -> UUID + -- ^ The subscriber function's 'UUID' + -> Affection () + + -- | Get the 'Participant' to emit a 'Message' on all of its subscribers + partEmit + :: prt + -- ^ The 'Participant''s subscriber storage + -> Mesg prt + -- ^ The 'Message' to emit + -> Affection () + partEmit p m = do + liftIO $ logIO Verbose $ "Emitting message: " <> S.fromString (show m) + l <- partSubscribers p + mapM_ ($ m) l + +-- | Helper function to generate new 'UUID's +genUUID :: Affection UUID +genUUID = liftIO nextRandom diff --git a/extern/affection/src/Affection/MessageBus/Message.hs b/extern/affection/src/Affection/MessageBus/Message.hs new file mode 100644 index 0000000..abf0f0c --- /dev/null +++ b/extern/affection/src/Affection/MessageBus/Message.hs @@ -0,0 +1,9 @@ +module Affection.MessageBus.Message + ( module M + ) where + +import Affection.MessageBus.Message.Class as M +import Affection.MessageBus.Message.WindowMessage as M +import Affection.MessageBus.Message.KeyboardMessage as M +import Affection.MessageBus.Message.MouseMessage as M +import Affection.MessageBus.Message.JoystickMessage as M diff --git a/extern/affection/src/Affection/MessageBus/Message/Class.hs b/extern/affection/src/Affection/MessageBus/Message/Class.hs new file mode 100644 index 0000000..3da6039 --- /dev/null +++ b/extern/affection/src/Affection/MessageBus/Message/Class.hs @@ -0,0 +1,6 @@ +module Affection.MessageBus.Message.Class where + +-- | Typeclass definition for messages +class Message msg where + -- | return the time when the message was sent + msgTime :: msg -> Double diff --git a/extern/affection/src/Affection/MessageBus/Message/JoystickMessage.hs b/extern/affection/src/Affection/MessageBus/Message/JoystickMessage.hs new file mode 100644 index 0000000..45fb34e --- /dev/null +++ b/extern/affection/src/Affection/MessageBus/Message/JoystickMessage.hs @@ -0,0 +1,67 @@ +module Affection.MessageBus.Message.JoystickMessage + ( JoystickMessage(..) + -- | Vector export + , Linear.V2 + -- | SDL exports + , SDL.JoyHatPosition + , SDL.JoyButtonState + , SDL.JoyDeviceConnection + -- | Number exports + , Word8 + , Int16 + , Int32 + ) where + +import Affection.MessageBus.Message.Class + +import Data.Word (Word8) +import Data.Int (Int32, Int16) + +import qualified SDL + +import Linear (V2(..)) + +-- | Datatype for handling all possible joystick events handed over from sdl2 +data JoystickMessage + -- | Movement of a Joystick axis + = MsgJoystickAxis + { msgJAWhen :: Double -- ^ Time of event + , msgJAWhich :: Int32 -- ^ Joystick identifier + , msgJAAxis :: Word8 -- ^ Axis identifier + , msgJAValue :: Int16 -- ^ Axis value + } + -- | Movement of a joystick ball controller + | MsgJoystickBall + { msgJBWhen :: Double -- ^ Time of event + , msgJBWhich :: Int32 -- ^ Joystick identifier + , msgJBBall :: Word8 -- ^ Ball identifier + , msgJBRelMotion :: V2 Int16 -- ^ Motion relative to previous position + } + -- | Movement of joystick hat controller + | MsgJoystickHat + { msgJHWhen :: Double -- ^ Time of event + , msgJHWhich :: Int32 -- ^ Joystick identifier + , msgJHHat :: Word8 -- ^ Hat identifier + , msgJHPosition :: SDL.JoyHatPosition -- ^ New hat position + } + -- | Joystick button event + | MsgJoystickButton + { msgJBWhen :: Double -- ^ Time of event + , msgJBWhich :: Int32 -- ^ Joystick identifier + , msgJBButton :: Word8 -- ^ Button identifier + , msgJBState :: SDL.JoyButtonState -- ^ New Button state + } + -- | Joystick device event + | MsgJoystickDevice + { msgJDWhen :: Double -- ^ Time of event + , msgJDWhich :: Int32 -- ^ Joystick identifier + , msgJDConnection :: SDL.JoyDeviceConnection -- ^ Connection status + } + deriving (Show) + +instance Message JoystickMessage where + msgTime (MsgJoystickAxis t _ _ _) = t + msgTime (MsgJoystickBall t _ _ _) = t + msgTime (MsgJoystickHat t _ _ _) = t + msgTime (MsgJoystickButton t _ _ _) = t + msgTime (MsgJoystickDevice t _ _) = t diff --git a/extern/affection/src/Affection/MessageBus/Message/KeyboardMessage.hs b/extern/affection/src/Affection/MessageBus/Message/KeyboardMessage.hs new file mode 100644 index 0000000..9caef1f --- /dev/null +++ b/extern/affection/src/Affection/MessageBus/Message/KeyboardMessage.hs @@ -0,0 +1,26 @@ +module Affection.MessageBus.Message.KeyboardMessage + ( KeyboardMessage(..) + -- | SDL reexports + , SDL.Window + , SDL.InputMotion + , SDL.Keysym + ) where + +import Affection.MessageBus.Message.Class + +import qualified SDL + +-- | Dataatype for handling all keyboard events haded down from SDL2 +data KeyboardMessage + -- | Arbitrary Keyboard event + = MsgKeyboardEvent + { msgKbdWhen :: Double -- ^ Message time + , msgKbdWindow :: Maybe SDL.Window -- ^ Affected Window + , msgKbdKeyMotion :: SDL.InputMotion -- ^ Input motion of button (pressed/released) + , msgKbdKeyRepeat :: Bool -- ^ Is this a repeated event? + , msgKbdKeysym :: SDL.Keysym -- ^ The button's 'SDL.Keysym' + } + deriving (Show) + +instance Message KeyboardMessage where + msgTime (MsgKeyboardEvent t _ _ _ _) = t diff --git a/extern/affection/src/Affection/MessageBus/Message/MouseMessage.hs b/extern/affection/src/Affection/MessageBus/Message/MouseMessage.hs new file mode 100644 index 0000000..a13baff --- /dev/null +++ b/extern/affection/src/Affection/MessageBus/Message/MouseMessage.hs @@ -0,0 +1,54 @@ +module Affection.MessageBus.Message.MouseMessage + ( MouseMessage(..) + -- | SDL reexports + , SDL.Window + , SDL.MouseDevice + , SDL.MouseButton + , SDL.InputMotion + , SDL.MouseScrollDirection + ) where + +import Affection.MessageBus.Message.Class + +import Data.Word (Word8) +import Data.Int (Int32) + +import qualified SDL + +import Linear (V2(..)) + +-- Datatype for handling mouse events handed down from SDL2 +data MouseMessage + -- | Mouse motion event + = MsgMouseMotion + { msgMMWhen :: Double -- ^ Message time + , msgMMWindow :: Maybe SDL.Window -- ^ Focused window (if any) + , msgMMWhich :: SDL.MouseDevice -- ^ Mouse device identifier + , msgMMState :: [SDL.MouseButton] -- ^ List of pressed mouse buttons + , msgMMPos :: V2 Int32 -- ^ Absolute mouse positiom + , msgMMRelMotion :: V2 Int32 -- ^ Mouse movement relative to previous position + } + -- | Mouse button event + | MsgMouseButton + { msgMBWhen :: Double -- ^ Message time + , msgMBWindow :: Maybe SDL.Window -- ^ Focused window (if any) + , msgMBMotion :: SDL.InputMotion -- ^ Button's input motion + , msgMBWhich :: SDL.MouseDevice -- ^ Mouse device identifier + , msgMBButton :: SDL.MouseButton -- ^ Affected mouse button + , msgMBClicks :: Word8 -- ^ Number of clicks + , msgMBPos :: V2 Int32 -- ^ Absolute mouse position + } + -- | Mouse wheel event + | MsgMouseWheel + { msgMWWhen :: Double -- ^ Message time + , msgMWWhindow :: Maybe SDL.Window -- ^ Focused window (if any) + , msgMWWhich :: SDL.MouseDevice -- ^ Mouse device identifier + , msgMWPos :: V2 Int32 -- ^ Absolute mouse position + , msgMWDIrection :: SDL.MouseScrollDirection -- ^ Scroll direction + } + deriving (Show) + +instance Message MouseMessage where + msgTime (MsgMouseMotion t _ _ _ _ _) = t + msgTime (MsgMouseButton t _ _ _ _ _ _) = t + msgTime (MsgMouseWheel t _ _ _ _) = t diff --git a/extern/affection/src/Affection/MessageBus/Message/WindowMessage.hs b/extern/affection/src/Affection/MessageBus/Message/WindowMessage.hs new file mode 100644 index 0000000..994f023 --- /dev/null +++ b/extern/affection/src/Affection/MessageBus/Message/WindowMessage.hs @@ -0,0 +1,106 @@ +module Affection.MessageBus.Message.WindowMessage + ( WindowMessage(..) + -- | SDL reexports + , SDL.Window + ) where + +import Affection.MessageBus.Message.Class + +import Data.Int (Int32) + +import qualified SDL + +import Linear (V2(..)) + +-- | Datatype for handling Window events handed down rom SDL2 +data WindowMessage + -- | Window show event + = MsgWindowShow + { msgWSWhen :: Double -- ^ Message time + , msgWSWindow :: SDL.Window -- ^ Window identifier + } + -- | Window hide event + | MsgWindowHide + { msgWHWhen :: Double -- ^ Message time + , msgWHWindow :: SDL.Window -- ^ Window identifier + } + -- | Window expose event + | MsgWindowExpose + { msgWEWhen :: Double -- ^ Message time + , msgWEWindow :: SDL.Window -- ^ Window identifier + } + -- | Window move event + | MsgWindowMove + { msgWMWhen :: Double -- ^ Message time + , msgWMWindow :: SDL.Window -- ^ Window identifier + , msgWMNewPos :: V2 Int32 -- ^ New absolute window position + } + -- | Window resize event + | MsgWindowResize + { msgWRWhen :: Double -- ^ Message time + , msgWRWindow :: SDL.Window -- ^ Window identifier + , msgWRNewSize :: V2 Int32 -- ^ New absolute window size + } + -- | Window size change event + | MsgWindowSizeChange + { msgWSCWhen :: Double -- ^ Message time + , msgWSCWindow :: SDL.Window -- ^ Window identifier + , msgWSCNewSize :: V2 Int32 -- ^ New absolute window size + } + -- | Window minimize event + | MsgWindowMinimize + { msgWMinWhen :: Double -- ^ Message time + , msgWMinWindow :: SDL.Window -- ^ Window identifier + } + -- | Window maximize event + | MsgWindowMaximize + { msgWMaxWhen :: Double -- ^ Message time + , msgWMaxWindow :: SDL.Window -- ^ Window identifier + } + -- | Window restore event + | MsgWindowRestore + { msgWRestWhen :: Double -- ^ Message time + , msgWRestWindow :: SDL.Window -- ^ Window identifier + } + -- | Window gain mouse focus event + | MsgWindowGainMouseFocus + { msgWGMFWhen :: Double -- ^ Message Time + , msgWGMFWindow :: SDL.Window -- ^ Window identifier + } + -- | Window lose mouse focus event + | MsgWindowLoseMouseFocus + { msgWLMFWhen :: Double -- ^ Message Time + , msgWLMFWindow :: SDL.Window -- ^ Window identifier + } + -- | Window gain keyboard focus event + | MsgWindowGainKeyboardFocus + { msgWGKFWhen :: Double -- ^ Message time + , msgWGKFWindow :: SDL.Window -- ^ Window identifier + } + -- | Window lose keyboard focus event + | MsgWindowLoseKeyboardFocus + { msgWLKFWhen :: Double -- ^ Message time + , msgWLKFWindow :: SDL.Window -- ^ Window identifier + } + -- | Window close event + | MsgWindowClose + { msgWCWhen :: Double -- ^ Message time + , msgWCWindow :: SDL.Window -- ^ Window identifier + } + deriving (Show) + +instance Message WindowMessage where + msgTime (MsgWindowShow t _) = t + msgTime (MsgWindowHide t _) = t + msgTime (MsgWindowExpose t _) = t + msgTime (MsgWindowMove t _ _) = t + msgTime (MsgWindowResize t _ _) = t + msgTime (MsgWindowSizeChange t _ _) = t + msgTime (MsgWindowMinimize t _) = t + msgTime (MsgWindowMaximize t _) = t + msgTime (MsgWindowRestore t _) = t + msgTime (MsgWindowGainMouseFocus t _) = t + msgTime (MsgWindowLoseMouseFocus t _) = t + msgTime (MsgWindowGainKeyboardFocus t _) = t + msgTime (MsgWindowLoseKeyboardFocus t _) = t + msgTime (MsgWindowClose t _) = t diff --git a/extern/affection/src/Affection/StateMachine.hs b/extern/affection/src/Affection/StateMachine.hs new file mode 100644 index 0000000..7d9ab55 --- /dev/null +++ b/extern/affection/src/Affection/StateMachine.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + +module Affection.StateMachine where + +import Affection.Types + +import qualified SDL + +-- | Typeclass for simple scaffolding of a state machine +class StateMachine us a where + -- | State load routine + smLoad :: a -> us -> Affection () + -- | state update routine + smUpdate :: a -> us -> Double -> Affection () + -- | State event handler routine + smEvent :: a -> us -> [SDL.EventPayload] -> Affection () + -- | State draw routine + smDraw :: a -> us -> Affection () + -- | State clean routine + smClean :: a -> us -> Affection () diff --git a/extern/affection/src/Affection/Subsystems.hs b/extern/affection/src/Affection/Subsystems.hs new file mode 100644 index 0000000..e48fa3e --- /dev/null +++ b/extern/affection/src/Affection/Subsystems.hs @@ -0,0 +1,9 @@ +module Affection.Subsystems + ( module S + ) where + +import Affection.Subsystems.Class as S +import Affection.Subsystems.AffectionKeyboard as S +import Affection.Subsystems.AffectionWindow as S +import Affection.Subsystems.AffectionMouse as S +import Affection.Subsystems.AffectionJoystick as S diff --git a/extern/affection/src/Affection/Subsystems/AffectionJoystick.hs b/extern/affection/src/Affection/Subsystems/AffectionJoystick.hs new file mode 100644 index 0000000..9d75258 --- /dev/null +++ b/extern/affection/src/Affection/Subsystems/AffectionJoystick.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +module Affection.Subsystems.AffectionJoystick where + +import Affection.MessageBus +import Affection.Types +import Affection.Util +import Affection.Logging + +import Control.Monad (filterM) +import Control.Monad.IO.Class (liftIO) + +import qualified Data.Vector as V +import Data.String as S (fromString) + +import Foreign.C.Types (CInt(..)) + +import qualified SDL + +-- | Helper function that consumes all Joystick-related 'SDL.EventPayload's +-- and emits appropriate 'JoystickMessage's +consumeSDLJoystickEvents + :: forall am. (Participant am, Mesg am ~ JoystickMessage) + => am -- ^ The message system participant + -> [SDL.EventPayload] -- ^ Incoming events + -> Affection [SDL.EventPayload] -- ^ Leftover SDL events +consumeSDLJoystickEvents am = doConsume + where + doConsume + :: [SDL.EventPayload] + -> Affection [SDL.EventPayload] + doConsume [] = return [] + doConsume (e:es) = do + ts <- getElapsedTime + case e of + SDL.JoyAxisEvent dat -> do + partEmit am (MsgJoystickAxis + ts + (SDL.joyAxisEventWhich dat) + (SDL.joyAxisEventAxis dat) + (SDL.joyAxisEventValue dat) + ) + doConsume es + SDL.JoyBallEvent dat -> do + partEmit am (MsgJoystickBall + ts + (SDL.joyBallEventWhich dat) + (SDL.joyBallEventBall dat) + (SDL.joyBallEventRelMotion dat) + ) + doConsume es + SDL.JoyHatEvent dat -> do + partEmit am (MsgJoystickHat + ts + (SDL.joyHatEventWhich dat) + (SDL.joyHatEventHat dat) + (SDL.joyHatEventValue dat) + ) + doConsume es + SDL.JoyButtonEvent dat -> do + partEmit am (MsgJoystickButton + ts + (SDL.joyButtonEventWhich dat) + (SDL.joyButtonEventButton dat) + (SDL.joyButtonEventState dat) + ) + doConsume es + SDL.JoyDeviceEvent dat -> do + partEmit am (MsgJoystickDevice + ts + (SDL.joyDeviceEventWhich dat) + (SDL.joyDeviceEventConnection dat) + ) + doConsume es + _ -> fmap (e :) (doConsume es) + +-- | Helper function to automatically connect and open newly attached joystick +-- devices +joystickAutoConnect + :: JoystickMessage -- ^ Any 'JoystickMessage' will do, + -- but listens only on 'MsgJoystickDevice' messages + -> Affection (Maybe SDL.Joystick) + -- ^ Returns a joystick descriptor, if successful +joystickAutoConnect (MsgJoystickDevice _ which SDL.JoyDeviceAdded) = liftIO $ do + [descr] <- V.toList <$> + (V.filter (\(SDL.JoystickDevice _ i) -> i == CInt which) <$> + SDL.availableJoysticks) + logIO Verbose $ "Connecting Joystick " <> fromString (show which) <> " " <> + fromString (show descr) + Just <$> SDL.openJoystick descr +joystickAutoConnect _ = return Nothing + +-- | Helper function to automatically close and disconnect freshly detached +-- joystick devices +joystickAutoDisconnect + :: [SDL.Joystick] -- ^ List of Joystick descriptors + -> JoystickMessage -- ^ Any 'JoystickMessage' will do, but listens + -- specifically to 'MsgJoystickDevice' messages + -> Affection [SDL.Joystick] -- ^ Returns altered list of Joystick descriptors +joystickAutoDisconnect js (MsgJoystickDevice _ which SDL.JoyDeviceRemoved) = + liftIO $ do + joyIds <- mapM SDL.getJoystickID js + logIO Verbose $ "These are the Joysticks connected: " <> + fromString (show joyIds) + d <- filterM (\j -> fmap (== which) (SDL.getJoystickID j)) js + if not (null d) + then do + logIO Verbose $ "disconnected joysticks: " <> fromString (show $ head d) + logIO Verbose $ "Disconnecting Joystick " <> fromString (show which) + SDL.closeJoystick (head d) + njoys <- filterM (\j -> return $ head d /= j) js + logIO Verbose $ "returning joysticks: " <> fromString (show njoys) + return njoys + else do + logIO Error $ "Error while disconnecting Joystick" + return js +joystickAutoDisconnect js _ = return js diff --git a/extern/affection/src/Affection/Subsystems/AffectionKeyboard.hs b/extern/affection/src/Affection/Subsystems/AffectionKeyboard.hs new file mode 100644 index 0000000..a78ccda --- /dev/null +++ b/extern/affection/src/Affection/Subsystems/AffectionKeyboard.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +module Affection.Subsystems.AffectionKeyboard where + +import Affection.Types +import Affection.Util +import Affection.MessageBus + +import qualified SDL + +-- | Helper function that consumes all Keyboard-related 'SDL.EventPayload's +-- and emits appropriate 'KeyboardMessage's +consumeSDLKeyboardEvents + :: forall ak. (Participant ak, Mesg ak ~ KeyboardMessage) + => ak -- ^ The message system participant + -> [SDL.EventPayload] -- ^ Incoming events + -> Affection [SDL.EventPayload] -- ^ Leftover SDL Events +consumeSDLKeyboardEvents ak = doConsume + where + doConsume [] = return [] + doConsume (e:es) = do + ts <- getElapsedTime + case e of + SDL.KeyboardEvent dat -> do + partEmit ak (MsgKeyboardEvent + ts + (SDL.keyboardEventWindow dat) + (SDL.keyboardEventKeyMotion dat) + (SDL.keyboardEventRepeat dat) + (SDL.keyboardEventKeysym dat) + ) + doConsume es + _ -> fmap (e :) (doConsume es) diff --git a/extern/affection/src/Affection/Subsystems/AffectionMouse.hs b/extern/affection/src/Affection/Subsystems/AffectionMouse.hs new file mode 100644 index 0000000..6f6a599 --- /dev/null +++ b/extern/affection/src/Affection/Subsystems/AffectionMouse.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +module Affection.Subsystems.AffectionMouse where + +import Affection.MessageBus +import Affection.Types +import Affection.Util + +import Linear.Affine (unP) + +import qualified SDL + +-- | Helper funtion that consumes all Mouse-related 'SDL.Eventpayload's +-- and emits appropriate 'MouseMessage's +consumeSDLMouseEvents + :: forall am. (Participant am, Mesg am ~ MouseMessage) + => am -- ^ The message system participant + -> [SDL.EventPayload] -- ^ Incoming events + -> Affection [SDL.EventPayload] -- ^ Leftover SDL events +consumeSDLMouseEvents am = doConsume + where + doConsume + :: [SDL.EventPayload] + -> Affection [SDL.EventPayload] + doConsume [] = return [] + doConsume (e:es) = do + ts <- getElapsedTime + case e of + SDL.MouseMotionEvent dat -> do + partEmit am (MsgMouseMotion + ts + (SDL.mouseMotionEventWindow dat) + (SDL.mouseMotionEventWhich dat) + (SDL.mouseMotionEventState dat) + (unP $ SDL.mouseMotionEventPos dat) + (SDL.mouseMotionEventRelMotion dat) + ) + doConsume es + SDL.MouseButtonEvent dat -> do + partEmit am (MsgMouseButton + ts + (SDL.mouseButtonEventWindow dat) + (SDL.mouseButtonEventMotion dat) + (SDL.mouseButtonEventWhich dat) + (SDL.mouseButtonEventButton dat) + (SDL.mouseButtonEventClicks dat) + (unP $ SDL.mouseButtonEventPos dat) + ) + doConsume es + SDL.MouseWheelEvent dat -> do + partEmit am (MsgMouseWheel + ts + (SDL.mouseWheelEventWindow dat) + (SDL.mouseWheelEventWhich dat) + (SDL.mouseWheelEventPos dat) + (SDL.mouseWheelEventDirection dat) + ) + doConsume es + _ -> fmap (e :) (doConsume es) diff --git a/extern/affection/src/Affection/Subsystems/AffectionWindow.hs b/extern/affection/src/Affection/Subsystems/AffectionWindow.hs new file mode 100644 index 0000000..f59e00c --- /dev/null +++ b/extern/affection/src/Affection/Subsystems/AffectionWindow.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +module Affection.Subsystems.AffectionWindow where + +import Affection.Types +import Affection.Util +import Affection.MessageBus + +import qualified SDL + +-- | Helper function that consumes all Window-related 'SDL.EventPayload's +-- and emits appropriate 'WindowMessage's. +consumeSDLWindowEvents + :: forall aw. (Participant aw, Mesg aw ~ WindowMessage) + => aw -- ^ The message system participant + -> [SDL.EventPayload] -- ^ Incoming events + -> Affection [SDL.EventPayload] -- ^ Leftover SDL events +consumeSDLWindowEvents aw = doConsume + where + doConsume + :: (Mesg aw ~ WindowMessage) + => [SDL.EventPayload] + -> Affection [SDL.EventPayload] + doConsume [] = return [] + doConsume (e:es) = do + ts <- getElapsedTime + case e of + SDL.WindowShownEvent (SDL.WindowShownEventData window) -> do + partEmit aw (MsgWindowShow ts window) + doConsume es + SDL.WindowHiddenEvent (SDL.WindowHiddenEventData window) -> do + partEmit aw (MsgWindowHide ts window) + doConsume es + SDL.WindowExposedEvent (SDL.WindowExposedEventData window) -> do + partEmit aw (MsgWindowExpose ts window) + doConsume es + SDL.WindowMovedEvent (SDL.WindowMovedEventData window (SDL.P newPos)) -> do + partEmit aw (MsgWindowMove ts window newPos) + doConsume es + SDL.WindowResizedEvent (SDL.WindowResizedEventData window newSize) -> do + partEmit aw (MsgWindowResize ts window newSize) + doConsume es + SDL.WindowSizeChangedEvent (SDL.WindowSizeChangedEventData window size) -> do + partEmit aw (MsgWindowSizeChange ts window size) + doConsume es + SDL.WindowMinimizedEvent (SDL.WindowMinimizedEventData window) -> do + partEmit aw (MsgWindowMinimize ts window) + doConsume es + SDL.WindowMaximizedEvent (SDL.WindowMaximizedEventData window) -> do + partEmit aw (MsgWindowMaximize ts window) + doConsume es + SDL.WindowRestoredEvent (SDL.WindowRestoredEventData window) -> do + partEmit aw (MsgWindowRestore ts window) + doConsume es + SDL.WindowGainedMouseFocusEvent (SDL.WindowGainedMouseFocusEventData window) -> do + partEmit aw (MsgWindowGainMouseFocus ts window) + doConsume es + SDL.WindowLostMouseFocusEvent (SDL.WindowLostMouseFocusEventData window) -> do + partEmit aw (MsgWindowLoseMouseFocus ts window) + doConsume es + SDL.WindowGainedKeyboardFocusEvent (SDL.WindowGainedKeyboardFocusEventData window) -> do + partEmit aw (MsgWindowGainKeyboardFocus ts window) + doConsume es + SDL.WindowLostKeyboardFocusEvent (SDL.WindowLostKeyboardFocusEventData window) -> do + partEmit aw (MsgWindowLoseKeyboardFocus ts window) + doConsume es + SDL.WindowClosedEvent (SDL.WindowClosedEventData window) -> do + partEmit aw (MsgWindowClose ts window) + doConsume es + _ -> fmap (e :) (doConsume es) diff --git a/extern/affection/src/Affection/Subsystems/Class.hs b/extern/affection/src/Affection/Subsystems/Class.hs new file mode 100644 index 0000000..ec55ae3 --- /dev/null +++ b/extern/affection/src/Affection/Subsystems/Class.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +module Affection.Subsystems.Class where + +import Affection.Types + +import qualified SDL + +-- | This class denotes a Subsystem to be part of SDL +class SDLSubsystem s where + -- | Consume the given 'SDL.EventPayload's and return only those not + -- recognised + consumeSDLEvents :: s -> [SDL.EventPayload] -> Affection [SDL.EventPayload] diff --git a/extern/affection/src/Affection/Types.hs b/extern/affection/src/Affection/Types.hs new file mode 100644 index 0000000..a7d8eb4 --- /dev/null +++ b/extern/affection/src/Affection/Types.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveFunctor #-} +module Affection.Types + ( Affection + , AffectionConfig(..) + , AffectionData(..) + , AffectionStateInner + , AffectionState(..) + , InitComponents(..) + , Angle + -- | SDL reexports + , SDL.WindowConfig(..) + , SDL.WindowMode(..) + , SDL.EventPayload(..) + , SDL.InitFlag(..) + , SDL.Window + , SDL.GLContext + ) where + +import qualified SDL.Init as SDL +import qualified SDL.Video as SDL +import qualified SDL.Event as SDL +import qualified Data.Text as T + +import Control.Monad.IO.Class +import Control.Monad.State.Strict +import qualified Control.Monad.Parallel as MP + +import System.Clock (TimeSpec) + +-- | Configuration for the aplication. needed at startup. +data AffectionConfig us = AffectionConfig + { initComponents :: InitComponents + -- ^ SDL components to initialize at startup + , windowTitle :: T.Text + -- ^ Window title + , windowConfigs :: + [ + ( Word -- --^ Window identifier + , SDL.WindowConfig -- --^ Window config for given window + , SDL.WindowMode -- -- ^ Window mode to start in + ) + ] + -- ^ Window configurations + } + +-- | Components to initialize in SDL. +data InitComponents + = All + | Only [SDL.InitFlag] + +-- | Main type for defining the look, feel and action of the whole application. +data AffectionData = AffectionData + { drawWindows :: + [ + ( Word -- --^ Window identifier + , SDL.Window -- --^ Window linked with identifier + , SDL.WindowMode -- -- ^ current screen mode + ) + ] -- ^ SDL windows + , glContext :: + [ + ( Word -- --^ Window identifier + , SDL.GLContext -- --^ Associated OpenGL context + ) + ] -- ^ OpenGL rendering contexts + , elapsedTime :: Double -- ^ Elapsed time in seconds + , deltaTime :: Double -- ^ Elapsed time in seconds since last tick + , sysTime :: TimeSpec -- ^ System time (NOT the time on the clock) + , pausedTime :: Bool -- ^ Should the update loop be executed? + } + +-- | Inner 'StateT' monad for the update state +type AffectionStateInner sd a = StateT sd a + +-- | Affection's state monad +newtype AffectionState sd m a = AffectionState + { runState :: AffectionStateInner sd m a } + deriving (Functor, Applicative, Monad, MonadIO, MonadState sd) + +instance MP.MonadParallel m => MP.MonadParallel (AffectionState sd m) + +type Affection a = AffectionState AffectionData IO a + +type Angle = Double diff --git a/extern/affection/src/Affection/Util.hs b/extern/affection/src/Affection/Util.hs new file mode 100644 index 0000000..763f0ee --- /dev/null +++ b/extern/affection/src/Affection/Util.hs @@ -0,0 +1,86 @@ +module Affection.Util where + +import Affection.Types +import Affection.Logging +import Affection.MessageBus.Message.WindowMessage + +import SDL (($=)) +import qualified SDL +import qualified Graphics.Rendering.OpenGL as GL + +import System.Clock + +import Data.String (fromString) +import Data.List (find) + +import Control.Monad.State + +-- | Prehandle SDL events +preHandleEvents :: [SDL.Event] -> Affection [SDL.EventPayload] +preHandleEvents evs = + return $ map SDL.eventPayload evs + +-- | block a thread for a specified amount of time +delaySec + :: Int -- ^ Number of seconds + -> IO () +delaySec dur = SDL.delay (fromIntegral $ dur * 1000) + +-- | Get time since start but always the same in the current tick. +getElapsedTime :: Affection Double +getElapsedTime = gets elapsedTime + +-- | Get delta time (time elapsed from last frame) +getDelta :: Affection Double +getDelta = gets deltaTime + +-- | Toggle the Screen mode between 'SDL.Windowed' and 'SDL.FullscreenDesktop'. +-- Pauses the Engine in the process. +toggleScreen :: Word -> Affection () +toggleScreen windowIdent = do + ad <- get + let mwindow = find (\(ident, _, _) -> ident == windowIdent) (drawWindows ad) + case mwindow of + Just (ident, window, mode) -> do + newMode <- case mode of + SDL.FullscreenDesktop -> do + SDL.setWindowMode window SDL.Windowed + return SDL.Windowed + SDL.Windowed -> do + SDL.setWindowMode window SDL.FullscreenDesktop + return SDL.FullscreenDesktop + x -> do + liftIO $ logIO Warn ("Unexpected window mode: " <> fromString (show x)) + return x + now <- liftIO $ getTime Monotonic + put ad + { sysTime = now + , drawWindows = map + (\e@(lid, win, _) -> + if lid == ident + then (lid, win, newMode) + else e + ) + (drawWindows ad) + } + Nothing -> do + liftIO $ logIO Warn ("No window found with ident " <> fromString (show windowIdent)) + +-- | Fit the GL Viewport to Window size +fitViewport + :: Double -- ^ Image Ratio (width / height) + -> WindowMessage -- ^ Incoming Message. Listens only on + -- 'MsgWindowResize' and ignores all others. + -> Affection () +fitViewport ratio (MsgWindowResize _ _ (SDL.V2 w h)) = do + liftIO $ logIO Verbose "Fitting Viewport to size" + if (fromIntegral w / fromIntegral h) > ratio + then do + let nw = floor (fromIntegral h * ratio) + dw = floor ((fromIntegral w - fromIntegral nw) / 2 :: Double) + GL.viewport $= (GL.Position dw 0, GL.Size nw h) + else do + let nh = floor (fromIntegral w / ratio) + dh = floor ((fromIntegral h - fromIntegral nh) / 2 :: Double) + GL.viewport $= (GL.Position 0 dh, GL.Size w nh) +fitViewport _ _ = return ()