Browse Source

pre-release cleanup part II

master
nek0 3 years ago
parent
commit
c804a2e013
  1. 28
      shell.nix
  2. 38
      src/Affection.hs
  3. 24
      src/Affection/Logging.hs
  4. 9
      src/Affection/MessageBus/Class.hs
  5. 4
      src/Affection/MessageBus/Message/Class.hs
  6. 60
      src/Affection/MessageBus/Message/JoystickMessage.hs
  7. 21
      src/Affection/MessageBus/Message/KeyboardMessage.hs
  8. 53
      src/Affection/MessageBus/Message/MouseMessage.hs
  9. 98
      src/Affection/MessageBus/Message/WindowMessage.hs
  10. 3
      src/Affection/MessageBus/Util.hs
  11. 42
      src/Affection/MouseInteractable.hs
  12. 6
      src/Affection/StateMachine.hs
  13. 16
      src/Affection/Subsystems/AffectionJoystick.hs
  14. 171
      src/Affection/Types.hs

28
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";

38
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"

24
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

9
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

4
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

60
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

21
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)

53
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)

98
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)

3
src/Affection/MessageBus/Util.hs

@ -1,3 +0,0 @@
module Affection.MessageBus.Util where
-- zuru zuru

42
src/Affection/MouseInteractable.hs

@ -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

6
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 ()

16
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

171
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
-- }

Loading…
Cancel
Save