nek0/affection
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

pre-release cleanup part II

Browse source
This commit is contained in:
nek0 2018-09-25 07:02:33 +02:00
parent 8d20ab193b
commit c804a2e013
14 changed files with 215 additions and 358 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

28
shell.nix
View file

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

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

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

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

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

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

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

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

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

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

42
src/Affection/MouseInteractable.hs
View file

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

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

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

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