From c804a2e013ee3e5a9b7ed07ea195b716f2cac8d6 Mon Sep 17 00:00:00 2001 From: nek0 Date: Tue, 25 Sep 2018 07:02:33 +0200 Subject: [PATCH] pre-release cleanup part II --- shell.nix | 28 ++- src/Affection.hs | 38 +--- src/Affection/Logging.hs | 24 ++- src/Affection/MessageBus/Class.hs | 9 +- src/Affection/MessageBus/Message/Class.hs | 4 +- .../MessageBus/Message/JoystickMessage.hs | 60 +++--- .../MessageBus/Message/KeyboardMessage.hs | 21 ++- .../MessageBus/Message/MouseMessage.hs | 53 +++--- .../MessageBus/Message/WindowMessage.hs | 98 +++++----- src/Affection/MessageBus/Util.hs | 3 - src/Affection/MouseInteractable.hs | 42 ----- src/Affection/StateMachine.hs | 6 + src/Affection/Subsystems/AffectionJoystick.hs | 16 +- src/Affection/Types.hs | 171 ++---------------- 14 files changed, 215 insertions(+), 358 deletions(-) delete mode 100644 src/Affection/MessageBus/Util.hs delete mode 100644 src/Affection/MouseInteractable.hs diff --git a/shell.nix b/shell.nix index 7004496..00f03df 100644 --- a/shell.nix +++ b/shell.nix @@ -25,9 +25,31 @@ let license = stdenv.lib.licenses.isc; }) {}; + sdl2Nek0 = with haskellPackages; callPackage( + { mkDerivation, base, bytestring, deepseq, exceptions, linear, SDL2 + , StateVar, stdenv, text, transformers, vector, weigh + }: + mkDerivation { + pname = "sdl2"; + version = "2.4.1.0"; + sha256 = "21a569c0c19f8ff2bbe1cf1d3eb32f65e8143806de353cedd240df5e9d088b5c"; + 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 ]; + doCheck = false; + description = "Both high- and low-level bindings to the SDL library (version 2.0.4+)."; + license = stdenv.lib.licenses.bsd3; + }) {}; + f = { mkDerivation, base, bytestring, clock, containers, deepseq , glib, linear, matrix, monad-loops, monad-parallel, mtl - , OpenGL, random, sdl2, stdenv, stm, text, uuid, vector + , OpenGL, random, stdenv, stm, text, uuid, vector }: mkDerivation { pname = "affection"; @@ -38,10 +60,10 @@ let isExecutable = true; libraryHaskellDepends = [ base bytestring clock containers glib linear monad-loops - monad-parallel mtl OpenGL sdl2 stm text uuid vector + monad-parallel mtl OpenGL sdl2Nek0 stm text uuid vector ]; executableHaskellDepends = [ - base containers deepseq linear matrix nanovgNeko OpenGL random sdl2 stm + base containers deepseq linear matrix nanovgNeko OpenGL random sdl2Nek0 stm ]; homepage = "https://github.com/nek0/affection#readme"; description = "A simple Game Engine using SDL"; diff --git a/src/Affection.hs b/src/Affection.hs index b8114db..a77e4e2 100644 --- a/src/Affection.hs +++ b/src/Affection.hs @@ -59,32 +59,6 @@ withAffection AffectionConfig{..} = do liftIO $ logIO Debug "Creating Window" window <- SDL.createWindow windowTitle windowConfig SDL.showWindow window - -- renderer <- SDL.createRenderer - -- window (-1) - -- SDL.defaultRenderer - -- { SDL.rendererTargetTexture = True - -- } - -- surface <- SDL.createRGBSurface - -- (case canvasSize of - -- Just (cw, ch) -> SDL.V2 - -- (CInt $ fromIntegral cw) - -- (CInt $ fromIntegral ch) - -- Nothing -> - -- SDL.windowInitialSize windowConfig - -- ) - -- SDL.RGBA8888 - -- texture <- SDL.createTexture - -- renderer - -- SDL.RGBA8888 - -- SDL.TextureAccessTarget - -- (case canvasSize of - -- Just (cw, ch) -> SDL.V2 - -- (CInt $ fromIntegral cw) - -- (CInt $ fromIntegral ch) - -- Nothing -> - -- SDL.windowInitialSize windowConfig - -- ) - -- SDL.rendererRenderTarget renderer $= Just texture _ <- SDL.glSetAttribute SDL.SDL_GL_SHARE_WITH_CURRENT_CONTEXT 1 context <- SDL.glCreateContext window let SDL.V2 (CInt rw) (CInt rh) = SDL.windowInitialSize windowConfig @@ -92,7 +66,7 @@ withAffection AffectionConfig{..} = do Just (cw, ch) -> (cw, ch) Nothing -> (fromIntegral rw, fromIntegral rh) SDL.setWindowMode window initScreenMode - SDL.swapInterval $= SDL.SynchronizedUpdates -- <- causes Problems with windows + -- SDL.swapInterval $= SDL.SynchronizedUpdates -- <- causes Problems with windows liftIO $ logIO Debug "Getting Time" -- get current time execTime <- getTime Monotonic @@ -134,7 +108,7 @@ withAffection AffectionConfig{..} = do } -- poll events evs <- preHandleEvents =<< liftIO SDL.pollEvents - -- mapM_ eventLoop evs + -- handle events eventLoop evs -- execute user defined update loop unless (pausedTime ad) (updateLoop dt) @@ -142,12 +116,8 @@ withAffection AffectionConfig{..} = do liftIO $ GL.clear [GL.ColorBuffer, GL.DepthBuffer, GL.StencilBuffer] drawLoop liftIO GL.flush - -- handle all new draw requests - ad2 <- get - -- actual drawing + -- actual displaying of newly drawn frame SDL.glSwapWindow window - -- SDL.copy renderer texture Nothing Nothing - -- SDL.present renderer -- save new time ad3 <- get when (sysTime ad == sysTime ad3) ( @@ -162,5 +132,5 @@ withAffection AffectionConfig{..} = do liftIO $ logIO Debug "Destroying Window" SDL.glDeleteContext context SDL.destroyWindow window - -- SDL.quit + -- SDL.quit -- <- This causes segfaults depending on hardware liftIO $ logIO Debug "This is the end" diff --git a/src/Affection/Logging.hs b/src/Affection/Logging.hs index b450774..e64ed7c 100644 --- a/src/Affection/Logging.hs +++ b/src/Affection/Logging.hs @@ -1,15 +1,23 @@ {-# LANGUAGE CPP #-} module Affection.Logging where +-- ^ This module defines the logging capability of Affection, whis is derived +-- from "Debug.Trace". import Debug.Trace +-- | The log level definition data LogLevel - = Verbose - | Debug - | Warn - | Error + = Verbose -- ^ Log everything + | Debug -- ^ Log Debug messages and above + | Warn -- ^ Log only Warnings and errors + | Error -- ^ Log only errors -log :: LogLevel -> String -> a -> a +-- | Pure logging function +log + :: LogLevel -- ^ Log level to log to + -> String -- ^ The message string + -> a -- ^ Arbitrary datatype to return + -> a -- ^ Returned data #if defined(VERBOSE) log Verbose s = trace ("VERBOSE: " ++ s) #endif @@ -24,7 +32,11 @@ log Error s = trace ("ERROR: " ++ s) #endif log _ _ = id -logIO :: LogLevel -> String -> IO () +-- | Manadic logging function residing in the 'IO' Monad +logIO + :: LogLevel -- ^ Log level to log to + -> String -- ^ The message string + -> IO () #if defined(VERBOSE) logIO Verbose s = traceIO ("VERBOSE: " ++ s) #endif diff --git a/src/Affection/MessageBus/Class.hs b/src/Affection/MessageBus/Class.hs index 93d826e..16ca2bc 100644 --- a/src/Affection/MessageBus/Class.hs +++ b/src/Affection/MessageBus/Class.hs @@ -3,11 +3,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ExistentialQuantification #-} -module Affection.MessageBus.Class - ( Participant(..) - , genUUID - , UUID - ) where +module Affection.MessageBus.Class where import Affection.MessageBus.Message import Affection.Types @@ -19,8 +15,9 @@ import Data.UUID.V4 import Affection.Logging +-- | This typeclass defines the behaviour of a participant in the message system class (Message (Mesg prt us), Show (Mesg prt us)) => Participant prt us where - type Mesg prt us :: * + type Mesg prt us :: * -- ^ Message datatype -- | Function to get the list of subscribers from the participant partSubscribers diff --git a/src/Affection/MessageBus/Message/Class.hs b/src/Affection/MessageBus/Message/Class.hs index bcb2651..3da6039 100644 --- a/src/Affection/MessageBus/Message/Class.hs +++ b/src/Affection/MessageBus/Message/Class.hs @@ -1,6 +1,6 @@ module Affection.MessageBus.Message.Class where -import Data.Word (Word32(..)) - +-- | Typeclass definition for messages class Message msg where + -- | return the time when the message was sent msgTime :: msg -> Double diff --git a/src/Affection/MessageBus/Message/JoystickMessage.hs b/src/Affection/MessageBus/Message/JoystickMessage.hs index efb3311..eb5c0e2 100644 --- a/src/Affection/MessageBus/Message/JoystickMessage.hs +++ b/src/Affection/MessageBus/Message/JoystickMessage.hs @@ -1,7 +1,8 @@ module Affection.MessageBus.Message.JoystickMessage ( JoystickMessage(..) + -- | Vector export + , Linear.V2 -- | SDL exports - , SDL.V2 , SDL.JoyHatPosition , SDL.JoyButtonState , SDL.JoyDeviceConnection @@ -20,41 +21,42 @@ import qualified SDL import Linear (V2(..)) +-- Datatype for handling all possible joystick events handed over from sdl2 data JoystickMessage - = MsgJoystickAxis - { msgJAWhen :: Double - , msgJAWhich :: Int32 - , msgJAAxis :: Word8 - , msgJAValue :: Int16 + = MsgJoystickAxis -- ^ Movement of a Joystick axis + { msgJAWhen :: Double -- ^ Time of event + , msgJAWhich :: Int32 -- ^ Joystick identifier + , msgJAAxis :: Word8 -- ^ Axis identifier + , msgJAValue :: Int16 -- ^ Axis value } - | MsgJoystickBall - { msgJBWhen :: Double - , msgJBWhich :: Int32 - , msgJBBall :: Word8 - , msgJBRelMotion :: SDL.V2 Int16 + | MsgJoystickBall -- ^ Movement of a joystick ball controller + { msgJBWhen :: Double -- ^ Time of event + , msgJBWhich :: Int32 -- ^ Joystick identifier + , msgJBBall :: Word8 -- ^ Ball identifier + , msgJBRelMotion :: V2 Int16 -- ^ Motion relative to previous position } - | MsgJoystickHat - { msgJHWhen :: Double - , msgJHWhich :: Int32 - , msgJHHat :: Word8 - , msgJHPosition :: SDL.JoyHatPosition + | MsgJoystickHat -- ^ Movement of joystick hat controller + { msgJHWhen :: Double -- Time of event + , msgJHWhich :: Int32 -- Joystick identifier + , msgJHHat :: Word8 -- Hat identifier + , msgJHPosition :: SDL.JoyHatPosition -- New hat position } - | MsgJoystickButton - { msgJBWhen :: Double - , msgJBWhich :: Int32 - , msgJBButton :: Word8 - , msgJBState :: SDL.JoyButtonState + | MsgJoystickButton -- ^ Joystick button event + { msgJBWhen :: Double -- Time of event + , msgJBWhich :: Int32 -- Joystick identifier + , msgJBButton :: Word8 -- Button identifier + , msgJBState :: SDL.JoyButtonState -- New Button state } - | MsgJoystickDevice - { msgJDWhen :: Double - , msgJDWhich :: Int32 - , msgJDConnection :: SDL.JoyDeviceConnection + | MsgJoystickDevice -- ^ Joystick device event + { 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 (MsgJoystickAxis t _ _ _) = t + msgTime (MsgJoystickBall t _ _ _) = t + msgTime (MsgJoystickHat t _ _ _) = t msgTime (MsgJoystickButton t _ _ _) = t - msgTime (MsgJoystickDevice t _ _) = t + msgTime (MsgJoystickDevice t _ _) = t diff --git a/src/Affection/MessageBus/Message/KeyboardMessage.hs b/src/Affection/MessageBus/Message/KeyboardMessage.hs index c2af0f1..30edb13 100644 --- a/src/Affection/MessageBus/Message/KeyboardMessage.hs +++ b/src/Affection/MessageBus/Message/KeyboardMessage.hs @@ -1,16 +1,23 @@ -module Affection.MessageBus.Message.KeyboardMessage where +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 - = MsgKeyboardEvent - { msgKbdWhen :: Double - , msgKbdWindow :: Maybe SDL.Window - , msgKbdKeyMotion :: SDL.InputMotion - , msgKbdKeyRepeat :: Bool - , msgKbdKeysym :: SDL.Keysym + = MsgKeyboardEvent -- ^ Arbitrary Keyboard event + { 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) diff --git a/src/Affection/MessageBus/Message/MouseMessage.hs b/src/Affection/MessageBus/Message/MouseMessage.hs index 1ed6300..0435650 100644 --- a/src/Affection/MessageBus/Message/MouseMessage.hs +++ b/src/Affection/MessageBus/Message/MouseMessage.hs @@ -1,4 +1,12 @@ -module Affection.MessageBus.Message.MouseMessage where +module Affection.MessageBus.Message.MouseMessage + ( MouseMessage(..) + -- | SDL reexports + , SDL.Window + , SDL.MouseDevice + , SDL.MouseButton + , SDL.InputMotion + , SDL.MouseScrollDirection + ) where import Affection.MessageBus.Message.Class @@ -9,30 +17,31 @@ import qualified SDL import Linear (V2(..)) +-- Datatype for handling mouse events handed down from SDL2 data MouseMessage - = MsgMouseMotion - { msgMMWhen :: Double - , msgMMWindow :: Maybe SDL.Window - , msgMMWhich :: SDL.MouseDevice - , msgMMState :: [SDL.MouseButton] - , msgMMPos :: V2 Int32 - , msgMMRelMotion :: V2 Int32 + = MsgMouseMotion -- ^ Mouse motion event + { 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 } - | MsgMouseButton - { msgMBWhen :: Double - , msgMBWindow :: Maybe SDL.Window - , msgMBMotion :: SDL.InputMotion - , msgMBWhich :: SDL.MouseDevice - , msgMBButton :: SDL.MouseButton - , msgMBClicks :: Word8 - , msgMBPos :: V2 Int32 + | MsgMouseButton -- ^ Mouse button event + { 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 } - | MsgMouseWheel - { msgMWWhen :: Double - , msgMWWhindow :: Maybe SDL.Window - , msgMWWhich :: SDL.MouseDevice - , msgMWPos :: V2 Int32 - , msgMWDIrection :: SDL.MouseScrollDirection + | MsgMouseWheel -- ^ Mouse wheel event + { 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) diff --git a/src/Affection/MessageBus/Message/WindowMessage.hs b/src/Affection/MessageBus/Message/WindowMessage.hs index 6e5356d..806b46c 100644 --- a/src/Affection/MessageBus/Message/WindowMessage.hs +++ b/src/Affection/MessageBus/Message/WindowMessage.hs @@ -1,4 +1,8 @@ -module Affection.MessageBus.Message.WindowMessage where +module Affection.MessageBus.Message.WindowMessage + ( WindowMessage(..) + -- | SDL reexports + , SDL.Window + ) where import Affection.MessageBus.Message.Class @@ -8,66 +12,66 @@ import qualified SDL import Linear (V2(..)) +-- | Datatype for handling Window events handed down rom SDL2 data WindowMessage - -- = MsgEngineReady Double - = MsgWindowShow - { msgWSWhen :: Double - , msgWSWindow :: SDL.Window + = MsgWindowShow -- ^ Window show event + { msgWSWhen :: Double -- ^ Message time + , msgWSWindow :: SDL.Window -- ^ Window identifier } - | MsgWindowHide - { msgWHWhen :: Double - , msgWHWindow :: SDL.Window + | MsgWindowHide -- ^ Window hide event + { msgWHWhen :: Double -- ^ Message time + , msgWHWindow :: SDL.Window -- ^ Window identifier } - | MsgWindowExpose - { msgWEWhen :: Double - , msgWEWindow :: SDL.Window + | MsgWindowExpose -- ^ Window expose event + { msgWEWhen :: Double -- ^ Message time + , msgWEWindow :: SDL.Window -- ^ Window identifier } - | MsgWindowMove - { msgWMWhen :: Double - , msgWMWindow :: SDL.Window - , msgWMNewPos :: V2 Int32 + | MsgWindowMove -- ^ Window move event + { msgWMWhen :: Double -- ^ Message time + , msgWMWindow :: SDL.Window -- ^ Window identifier + , msgWMNewPos :: V2 Int32 -- ^ New absolute window position } - | MsgWindowResize - { msgWRWhen :: Double - , msgWRWindow :: SDL.Window - , msgWRNewSize :: V2 Int32 + | MsgWindowResize -- ^ Window resize event + { msgWRWhen :: Double -- ^ Message time + , msgWRWindow :: SDL.Window -- ^ Window identifier + , msgWRNewSize :: V2 Int32 -- ^ New absolute window size } - | MsgWindowSizeChange - { msgWSCWhen :: Double - , msgWSCWindow :: SDL.Window - , msgWRNewSize :: V2 Int32 + | MsgWindowSizeChange -- ^ Window size change event + { msgWSCWhen :: Double -- ^ Message time + , msgWSCWindow :: SDL.Window -- ^ Window identifier + , msgWSCNewSize :: V2 Int32 -- ^ New absolute window size } - | MsgWindowMinimize - { msgWMinWhen :: Double - , msgWMinWindow :: SDL.Window + | MsgWindowMinimize -- ^ Window minimize event + { msgWMinWhen :: Double -- ^ Message time + , msgWMinWindow :: SDL.Window -- ^ Window identifier } - | MsgWindowMaximize - { msgWMaxWhen :: Double - , msgWMaxWindow :: SDL.Window + | MsgWindowMaximize -- ^ Window maximize event + { msgWMaxWhen :: Double -- ^ Message time + , msgWMaxWindow :: SDL.Window -- ^ Window identifier } - | MsgWindowRestore - { msgWRestWhen :: Double - , msgWRestWindow :: SDL.Window + | MsgWindowRestore -- ^ Window restore event + { msgWRestWhen :: Double -- ^ Message time + , msgWRestWindow :: SDL.Window -- ^ Window identifier } - | MsgWindowGainMouseFocus - { msgWGMFWhen :: Double - , msgWGMFWindow :: SDL.Window + | MsgWindowGainMouseFocus -- ^ Window gain mouse focus event + { msgWGMFWhen :: Double -- ^ Message Time + , msgWGMFWindow :: SDL.Window -- ^ Window identifier } - | MsgWindowLoseMouseFocus - { msgWLMFWhen :: Double - , msgWLMFWindow :: SDL.Window + | MsgWindowLoseMouseFocus -- ^ Window lose mouse focus event + { msgWLMFWhen :: Double -- ^ Message Time + , msgWLMFWindow :: SDL.Window -- ^ Window identifier } - | MsgWindowGainKeyboardFocus - { msgWGKFWhen :: Double - , msgWGKFWindow :: SDL.Window + | MsgWindowGainKeyboardFocus -- ^ Window gain keyboard focus event + { msgWGKFWhen :: Double -- ^ Message time + , msgWGKFWindow :: SDL.Window -- ^ Window identifier } - | MsgWindowLoseKeyboardFocus - { msgWLKFWhen :: Double - , msgWLKFWindow :: SDL.Window + | MsgWindowLoseKeyboardFocus -- ^ Window lose keyboard focus event + { msgWLKFWhen :: Double -- ^ Message time + , msgWLKFWindow :: SDL.Window -- ^ Window identifier } - | MsgWindowClose - { msgWCWhen :: Double - , msgWCWindow :: SDL.Window + | MsgWindowClose -- ^ Window close event + { msgWCWhen :: Double -- ^ Message time + , msgWCWindow :: SDL.Window -- ^ Window identifier } deriving (Show) diff --git a/src/Affection/MessageBus/Util.hs b/src/Affection/MessageBus/Util.hs deleted file mode 100644 index b2cae3e..0000000 --- a/src/Affection/MessageBus/Util.hs +++ /dev/null @@ -1,3 +0,0 @@ -module Affection.MessageBus.Util where - --- zuru zuru diff --git a/src/Affection/MouseInteractable.hs b/src/Affection/MouseInteractable.hs deleted file mode 100644 index e3a6436..0000000 --- a/src/Affection/MouseInteractable.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} - -module Affection.MouseInteractable where - -import Affection.Types - -import qualified SDL - --- class MouseHoverable a us where --- onHover :: a -> Affection us () - --- | Define a mouse clickable object -class MouseClickable a us where - onClick - :: a -- The object - -> SDL.MouseButton -- The clicked button - -> (Int, Int) -- The coordinates of the click - -> SDL.InputMotion -- The 'SDL.InputMotion' of the click - -> Int -- The number of clicks - -> Affection us () - --- | A helper function that checks wether provided clickables have been clicked. --- This function does not consume provided events, but passes them on. -handleMouseClicks - :: (Foldable t, MouseClickable clickable us) - => SDL.EventPayload -- ^ Piped event in - -> t clickable -- ^ 'MouseClickable' elemt to be checked - -> Affection us SDL.EventPayload -- ^ Unaltered event -handleMouseClicks e clickables = - case e of - SDL.MouseButtonEvent dat -> do - mapM_ (\clickable -> do - let SDL.P (SDL.V2 x y) = SDL.mouseButtonEventPos dat - onClick - clickable - (SDL.mouseButtonEventButton dat) - (fromIntegral x, fromIntegral y) - (SDL.mouseButtonEventMotion dat) - (fromIntegral $ SDL.mouseButtonEventClicks dat) - ) clickables - return e - _ -> return e diff --git a/src/Affection/StateMachine.hs b/src/Affection/StateMachine.hs index abbe3d9..c1b5413 100644 --- a/src/Affection/StateMachine.hs +++ b/src/Affection/StateMachine.hs @@ -6,9 +6,15 @@ import Affection.Types import qualified SDL +-- | Typeclass for simple scaffolding of a state machine class StateMachine a us where + -- | State load routine smLoad :: a -> Affection us () + -- | state update routine smUpdate :: a -> Double -> Affection us () + -- | State event handler routine smEvent :: a -> [SDL.EventPayload] -> Affection us () + -- | State draw routine smDraw :: a -> Affection us () + -- | State clean routine smClean :: a -> Affection us () diff --git a/src/Affection/Subsystems/AffectionJoystick.hs b/src/Affection/Subsystems/AffectionJoystick.hs index 64ad018..69691b6 100644 --- a/src/Affection/Subsystems/AffectionJoystick.hs +++ b/src/Affection/Subsystems/AffectionJoystick.hs @@ -77,7 +77,13 @@ consumeSDLJoystickEvents am = doConsume doConsume es _ -> fmap (e :) (doConsume es) -joystickAutoConnect :: JoystickMessage -> Affection us (Maybe SDL.Joystick) +-- | Helper function to automatically connect and open newly attached joystick +-- devices +joystickAutoConnect + :: JoystickMessage -- ^ Any 'JoystickMessage' will do, + -- but listens only on 'MsgJoystickDevice' messages + -> Affection us (Maybe SDL.Joystick) + -- ^ Returns a joystick descriptor, if successful joystickAutoConnect (MsgJoystickDevice _ which SDL.JoyDeviceAdded) = liftIO $ do [descr] <- V.toList <$> (return . V.filter (\(SDL.JoystickDevice _ id) -> id == CInt which) @@ -86,7 +92,13 @@ joystickAutoConnect (MsgJoystickDevice _ which SDL.JoyDeviceAdded) = liftIO $ do Just <$> SDL.openJoystick descr joystickAutoConnect _ = return Nothing -joystickAutoDisconnect :: [SDL.Joystick] -> JoystickMessage -> Affection us [SDL.Joystick] +-- | 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 us [SDL.Joystick] -- ^ Returns altered list of Joystick descriptors joystickAutoDisconnect js (MsgJoystickDevice _ which SDL.JoyDeviceRemoved) = liftIO $ do joyIds <- mapM SDL.getJoystickID js diff --git a/src/Affection/Types.hs b/src/Affection/Types.hs index ec83dee..0785d43 100644 --- a/src/Affection/Types.hs +++ b/src/Affection/Types.hs @@ -1,34 +1,20 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, DeriveFunctor #-} -module Affection.Types - -- ( Affection - -- , AffectionData(..) - -- , AffectionConfig(..) - -- , AffectionState(..) - -- -- , AffectionDraw(..) - -- -- , Draw(..) - -- , AffectionStateInner - -- -- , AffectionDrawInner(..) - -- , InitComponents(..) - -- -- , Loop(..) - -- -- , RGBA(..) - -- , DrawType(..) - -- , DrawRequest(..) - -- , RequestPersist(..) - -- , Angle(..) - -- -- , ConvertAngle(..) - -- -- | Particle system - -- , Particle(..) - -- , ParticleSystem(..) - -- , ParticleStorage(..) - -- -- | Convenience exports - -- , liftIO - -- , SDL.WindowConfig(..) - -- , SDL.defaultWindow - -- -- | GEGL reexports - -- , G.GeglRectangle(..) - -- , G.GeglBuffer(..) - -- ) - where +module Affection.Types + ( Affection(..) + , AffectionConfig(..) + , AffectionData(..) + , AffectionStateInner(..) + , AffectionState(..) + , InitComponents(..) + , Angle(..) + -- | SDL reexports + , SDL.WindowConfig(..) + , SDL.WindowMode(..) + , SDL.EventPayload(..) + , SDL.InitFlags(..) + , SDL.Window(..) + , SDL.GLContext(..) + ) where import qualified SDL.Init as SDL import qualified SDL.Video as SDL @@ -36,17 +22,11 @@ import qualified SDL.Event as SDL import qualified Data.Text as T import Data.Map.Strict as M --- import qualified GEGL as G --- import qualified BABL as B - import Control.Monad.IO.Class import Control.Monad.State.Strict import qualified Control.Monad.Parallel as MP import System.Clock (TimeSpec) --- import Control.Monad.Reader - --- import Control.Concurrent.MVar import Foreign.Ptr (Ptr) @@ -85,16 +65,11 @@ data InitComponents -- | Main type for defining the look, feel and action of the whole application. data AffectionData us = AffectionData - -- { affectionConfig :: AffectionConfig us -- ^ Application configuration. { quitEvent :: Bool -- ^ Loop breaker. , userState :: us -- ^ State data provided by user , drawWindow :: SDL.Window -- ^ SDL window , glContext :: SDL.GLContext -- ^ OpenGL rendering context - , windowRenderer :: SDL.Renderer -- ^ Internal renderer of window - , drawTexture :: SDL.Texture -- ^ SDL Texture to draw to - -- , drawFormat :: B.BablFormatPtr -- ^ Target format , screenMode :: SDL.WindowMode -- ^ current screen mode - -- , drawStack :: [DrawRequest] -- ^ Stack of 'DrawRequest's to be processed , drawDimensions :: (Int, Int) -- ^ Dimensions of target surface , drawStride :: Int -- ^ Stride of target buffer , drawCPP :: Int -- ^ Number of components per pixel @@ -102,25 +77,9 @@ data AffectionData us = AffectionData , 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? - -- , messageChannel :: Channel msg -- ^ The main broadcast channel to duplicate all others from } --- -- | This datatype stores information about areas of a 'G.GeglBuffer' to be updated --- data DrawRequest = DrawRequest --- { requestArea :: G.GeglRectangle -- ^ The area to update --- , requestBuffer :: G.GeglBuffer -- ^ Buffer to draw --- , requestPersist :: RequestPersist -- ^ Shall the drawRequest persist --- } --- --- data RequestPersist --- = Persist --- | Kill (Maybe G.GeglNode) --- --- -- | A type for storing 'DrawRequest' results to be executed frequently. TODO --- data DrawAsset = DrawAsset - -- | Inner 'StateT' monad for the update state --- type AffectionStateInner us m a = StateT (AffectionData us) m a type AffectionStateInner us a = StateT us a -- | Affection's state monad @@ -132,102 +91,4 @@ instance MP.MonadParallel m => MP.MonadParallel (AffectionState us m) type Affection us a = AffectionState (AffectionData us) IO a --- -- | Inner 'StateT' monad of Affection --- type AffectionInner us od a = StateT (AffectionState us od) IO a --- --- -- | Affection state monad --- newtype Affection us od a = Affection --- { runAffection :: AffectionInner us od a } --- deriving (Functor, Applicative, Monad, MonadState (AffectionState us od)) --- --- -- | Inner drawing monad of Affection. --- type AffectionDrawInner ds a = ReaderT (Draw ds) a --- --- -- | Affectiondrawinf reader monad. --- newtype AffectionDraw ds a = AffectionDraw --- { runDraw :: (ds -> a) } --- deriving (Functor, Applicative, Monad, MonadReader ds) --- --- -- | Loop state monad to hold elapsed time per frame --- newtype Loop f a = Loop --- { runLoop :: f -> (a, f) } --- deriving (Functor, Applicative, Monad, MonadState (Loop f)) - --- data RGBA = RGBA --- { r :: Int --- , g :: Int --- , b :: Int --- , a :: Int --- } - --- | Type for defining the draw type of draw functions -data DrawType - -- | Fill the specified area completely with color - = Fill - -- | only draw the outline of the area - | Line - { lineWidth :: Int -- ^ Width of line in pixels - } - type Angle = Double - --- -- | Type for defining angles --- data Angle --- = Rad Double -- ^ Angle in radians --- | Deg Double -- ^ Angle in degrees --- deriving (Show) --- --- -- | Typeclass for converting Angles from 'Deg' to 'Rad' and vice versa. --- class ConvertAngle a where --- toRad :: a -> a -- Convert to 'Rad' --- toDeg :: a -> a -- Convert to 'Deg' --- --- instance ConvertAngle Angle where --- toRad (Deg x) = Rad $ x * pi / 180 --- toRad x = x --- --- toDeg (Rad x) = Deg $ x * 180 / pi --- toDeg x = x --- --- instance Eq Angle where --- (==) (Deg x) (Deg y) = x == y --- (==) (Rad x) (Rad y) = x == y --- (==) dx@(Deg _) ry@(Rad _) = dx == toDeg ry --- (==) rx@(Rad _) dy@(Deg _) = toDeg rx == dy - --- -- | A single particle --- data Particle = Particle --- { particleTimeToLive :: Double --- -- ^ Time to live in seconds --- , particleCreation :: Double --- -- ^ Creation time of particle in seconds form program start --- , particlePosition :: (Double, Double) --- -- ^ Position of particle on canvas --- , particleRotation :: Angle --- -- ^ Particle rotation --- , particleVelocity :: (Int, Int) --- -- ^ particle velocity as vector of pixels per second --- , particlePitchRate :: Angle --- -- ^ Rotational velocity of particle in angle per second --- , particleRootNode :: G.GeglNode --- -- ^ Root 'G.GeglNode' of 'Particle' --- , particleNodeGraph :: Map String G.GeglNode --- -- ^ Node Graph of 'G.GeglNodes' per particle --- , particleStackCont :: G.GeglNode --- -- ^ 'G.GeglNode' to connect other 'Particle's to --- , particleDrawFlange :: G.GeglNode --- -- ^ 'G.GeglNode' to connect draw actions to --- } deriving (Eq) --- --- -- | The particle system --- data ParticleSystem = ParticleSystem --- { partSysParts :: ParticleStorage --- , partSysNode :: G.GeglNode --- , partSysBuffer :: G.GeglBuffer --- } --- --- -- | The particle storage datatype --- data ParticleStorage = ParticleStorage --- { partStorLatest :: Maybe Particle -- ^ The particle stored last --- , partStorList :: [Particle] -- ^ List of particles in ascending order of remaining lifetime --- }