Merge pull request #3 from nek0/messagebus

Messagebus
This commit is contained in:
rys ostrovid 2017-11-26 14:48:43 +01:00 committed by GitHub
commit 90161d6501
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
6 changed files with 187 additions and 141 deletions

View file

@ -36,15 +36,16 @@ flag examples
library library
exposed-modules: Affection exposed-modules: Affection
, Affection.Draw -- , Affection.Draw
, Affection.Particle -- , Affection.Particle
, Affection.Types , Affection.Types
, Affection.StateMachine , Affection.StateMachine
, Affection.MouseInteractable , Affection.MouseInteractable
, Affection.Property -- , Affection.Property
, Affection.Actor -- , Affection.Actor
, Affection.Animation -- , Affection.Animation
, Affection.Util , Affection.Util
, Affection.MessageBus
default-extensions: OverloadedStrings default-extensions: OverloadedStrings
-- Modules included in this library but not exported. -- Modules included in this library but not exported.
@ -64,14 +65,16 @@ library
, sdl2 , sdl2
, text , text
, mtl , mtl
, gegl -- , gegl
, babl -- , babl
, monad-loops , monad-loops
, monad-parallel , monad-parallel
, containers , containers
, clock , clock
, glib , glib
, bytestring , bytestring
, OpenGL
, stm
-- , sdl2-image -- , sdl2-image
-- executable example00 -- executable example00

9
notes/TODO.md Normal file
View file

@ -0,0 +1,9 @@
# TODO
Implement following things in approximately this Order:
* Message bus
* Console
* GUI
* Framework
* Everything else

View file

@ -2,6 +2,7 @@
{-# LANGUAGE BangPatterns #-} {-# LANGUAGE BangPatterns #-}
module Affection module Affection
( withAffection ( withAffection
, get
, getAffection , getAffection
, putAffection , putAffection
-- , withWindow -- , withWindow
@ -12,10 +13,11 @@ module Affection
, module A , module A
) where ) where
import SDL (($=))
import qualified SDL import qualified SDL
import qualified SDL.Internal.Numbered as SDL (toNumber) import qualified SDL.Internal.Numbered as SDL (toNumber)
import qualified SDL.Raw as Raw import qualified SDL.Raw as Raw
import qualified GEGL as G -- import qualified GEGL as G
import Data.Maybe import Data.Maybe
import Data.IORef import Data.IORef
@ -31,16 +33,19 @@ import Foreign.Storable (peek)
import Debug.Trace import Debug.Trace
import Affection.Types as A import Affection.Types as A
import Affection.Draw as A -- import Affection.Draw as A
import Affection.Particle as A -- import Affection.Particle as A
import Affection.StateMachine as A import Affection.StateMachine as A
import Affection.MouseInteractable as A import Affection.MouseInteractable as A
import Affection.Property as A -- import Affection.Property as A
import Affection.Actor as A -- import Affection.Actor as A
import Affection.Animation as A -- import Affection.Animation as A
import Affection.Util as A import Affection.Util as A
import Affection.MessageBus as A
import qualified BABL as B import Graphics.Rendering.OpenGL as GL (clear, flush, ClearBuffer(..))
-- import qualified BABL as B
-- | Main function which bootstraps everything else. -- | Main function which bootstraps everything else.
withAffection withAffection
@ -53,7 +58,7 @@ withAffection AffectionConfig{..} = do
SDL.initializeAll SDL.initializeAll
Only is -> Only is ->
SDL.initialize is SDL.initialize is
G.gegl_init -- G.gegl_init
-- give SDL render quality -- give SDL render quality
SDL.HintRenderScaleQuality SDL.$= SDL.ScaleLinear SDL.HintRenderScaleQuality SDL.$= SDL.ScaleLinear
-- just checking… -- just checking…
@ -64,52 +69,55 @@ withAffection AffectionConfig{..} = do
-- construct window -- construct window
window <- SDL.createWindow windowTitle windowConfig window <- SDL.createWindow windowTitle windowConfig
SDL.showWindow window SDL.showWindow window
-- create renderer context <- SDL.glCreateContext(window)
renderer <- SDL.createRenderer -- -- create renderer
window -- renderer <- SDL.createRenderer
(-1) -- window
SDL.defaultRenderer -- (-1)
-- make draw texture -- SDL.defaultRenderer
texture <- SDL.createTexture -- -- make draw texture
renderer -- texture <- SDL.createTexture
SDL.ABGR8888 -- renderer
SDL.TextureAccessStreaming -- SDL.ABGR8888
(case canvasSize of -- SDL.TextureAccessStreaming
Just (cw, ch) -> (SDL.V2 -- (case canvasSize of
(CInt $ fromIntegral cw) -- Just (cw, ch) -> (SDL.V2
(CInt $ fromIntegral ch) -- (CInt $ fromIntegral cw)
) -- (CInt $ fromIntegral ch)
Nothing -> -- )
SDL.windowInitialSize windowConfig -- Nothing ->
) -- SDL.windowInitialSize windowConfig
-- make draw surface -- )
-- pixelFormat <- liftIO $ peek . Raw.surfaceFormat =<< peek ptr -- -- make draw surface
let SDL.V2 (CInt rw) (CInt rh) = windowInitialSize windowConfig -- -- pixelFormat <- liftIO $ peek . Raw.surfaceFormat =<< peek ptr
let SDL.V2 (CInt rw) (CInt rh) = SDL.windowInitialSize windowConfig
(w, h) = case canvasSize of (w, h) = case canvasSize of
Just (cw, ch) -> (cw, ch) Just (cw, ch) -> (cw, ch)
Nothing -> (fromIntegral rw, fromIntegral rh) Nothing -> (fromIntegral rw, fromIntegral rh)
-- stride = fromIntegral (Raw.pixelFormatBytesPerPixel pixelFormat) * w -- -- stride = fromIntegral (Raw.pixelFormatBytesPerPixel pixelFormat) * w
bablFormat = B.PixelFormat B.RGBA B.CFu8 -- bablFormat = B.PixelFormat B.RGBA B.CFu8
cpp = B.babl_components_per_pixel bablFormat -- cpp = B.babl_components_per_pixel bablFormat
!stride = cpp * w -- !stride = cpp * w
format <- B.babl_format bablFormat -- format <- B.babl_format bablFormat
-- get current time -- get current time
SDL.setWindowMode window initScreenMode SDL.setWindowMode window initScreenMode
SDL.swapInterval $= SDL.SynchronizedUpdates
execTime <- getTime Monotonic execTime <- getTime Monotonic
initContainer <- (\x -> AffectionData initContainer <- (\x -> AffectionData
{ quitEvent = False { quitEvent = False
, userState = x , userState = x
, drawWindow = window , drawWindow = window
, windowRenderer = renderer , glContext = context
, drawTexture = texture -- , windowRenderer = renderer
, drawFormat = format -- , drawTexture = texture
-- , drawFormat = format
, drawDimensions = case canvasSize of , drawDimensions = case canvasSize of
Just (cw, ch) -> (cw, ch) Just (cw, ch) -> (cw, ch)
Nothing -> (w, h) Nothing -> (w, h)
, screenMode = initScreenMode , screenMode = initScreenMode
, drawStride = stride -- , drawStride = stride
, drawCPP = cpp -- , drawCPP = cpp
, drawStack = [] -- , drawStack = []
, elapsedTime = 0 , elapsedTime = 0
, deltaTime = 0 , deltaTime = 0
, sysTime = execTime , sysTime = execTime
@ -128,15 +136,15 @@ withAffection AffectionConfig{..} = do
now <- liftIO $ getTime Monotonic now <- liftIO $ getTime Monotonic
let lastTime = sysTime ad let lastTime = sysTime ad
-- clean draw requests from last run -- clean draw requests from last run
mapM_ (invalidateDrawRequest (drawStride ad) (drawCPP ad)) (drawStack ad) -- mapM_ (invalidateDrawRequest (drawStride ad) (drawCPP ad)) (drawStack ad)
-- clean the renderer form last time -- clean the renderer form last time
-- SDL.clear renderer -- SDL.clear renderer
-- compute dt and update elapsedTime -- compute dt and update elapsedTime
let !dt = fromIntegral (toNanoSecs $ diffTimeSpec lastTime now) / (10 ^ 9) let !dt = fromIntegral (toNanoSecs $ diffTimeSpec lastTime now) / (10 ^ 9)
!ne = elapsedTime ad + dt !ne = elapsedTime ad + dt
put $ ad put $ ad
{ drawStack = [] -- { drawStack = []
, elapsedTime = ne { elapsedTime = ne
, deltaTime = dt , deltaTime = dt
} }
-- poll events -- poll events
@ -145,16 +153,19 @@ withAffection AffectionConfig{..} = do
-- execute user defined update loop -- execute user defined update loop
unless (pausedTime ad) (updateLoop dt) unless (pausedTime ad) (updateLoop dt)
-- execute user defined draw loop -- execute user defined draw loop
liftIO $ GL.clear [ColorBuffer, DepthBuffer]
drawLoop drawLoop
liftIO $ flush
-- handle all new draw requests -- handle all new draw requests
ad2 <- get ad2 <- get
clear <- catMaybes <$> -- clear <- catMaybes <$>
mapM (handleDrawRequest (drawStride ad) (drawCPP ad)) (drawStack ad2) -- mapM (handleDrawRequest (drawStride ad) (drawCPP ad)) (drawStack ad2)
-- save all draw requests to clear in next run -- -- save all draw requests to clear in next run
put $ ad2 -- put $ ad2
{ drawStack = clear } -- { drawStack = clear }
-- actual drawing -- actual drawing
SDL.present (windowRenderer ad2) SDL.glSwapWindow window
-- SDL.present (windowRenderer ad2)
-- save new time -- save new time
ad3 <- get ad3 <- get
when (sysTime ad == sysTime ad3) ( when (sysTime ad == sysTime ad3) (
@ -164,7 +175,7 @@ withAffection AffectionConfig{..} = do
) )
) )
) initContainer ) initContainer
G.gegl_exit -- G.gegl_exit
cleanUp $ userState nState cleanUp $ userState nState
SDL.destroyWindow window SDL.destroyWindow window
SDL.quit SDL.quit

View file

@ -28,9 +28,8 @@ import System.Glib.GObject
import qualified SDL import qualified SDL
import qualified BABL as B -- import qualified BABL as B
-- import qualified GEGL as G
import qualified GEGL as G
import Debug.Trace import Debug.Trace

View file

@ -0,0 +1,22 @@
module Affection.MessageBus where
import Control.Concurrent.STM as STM
import Data.IORef
class Message msg where
msgPayload :: msg -> Maybe a
type Channel msg = TChan msg
class Participant prt where
partChannel :: (Message msg) => prt -> IORef (Channel msg)
partConnectChannel :: (Message msg) => prt -> (Channel msg) -> IO ()
partListen :: (Message msg) => prt -> IO msg
partBroadcast :: (Message msg) => prt -> msg -> IO ()
newBroadcastChannel :: IO (Channel msg)
newBroadcastChannel = atomically $ newBroadcastTChan

View file

@ -1,33 +1,34 @@
{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveFunctor #-} {-# LANGUAGE GeneralizedNewtypeDeriving, DeriveFunctor #-}
module Affection.Types module Affection.Types
( Affection -- ( Affection
, AffectionData(..) -- , AffectionData(..)
, AffectionConfig(..) -- , AffectionConfig(..)
, AffectionState(..) -- , AffectionState(..)
-- , AffectionDraw(..) -- -- , AffectionDraw(..)
-- , Draw(..) -- -- , Draw(..)
, AffectionStateInner -- , AffectionStateInner
-- , AffectionDrawInner(..) -- -- , AffectionDrawInner(..)
, InitComponents(..) -- , InitComponents(..)
-- , Loop(..) -- -- , Loop(..)
-- , RGBA(..) -- -- , RGBA(..)
, DrawType(..) -- , DrawType(..)
, DrawRequest(..) -- , DrawRequest(..)
, RequestPersist(..) -- , RequestPersist(..)
, Angle(..) -- , Angle(..)
-- , ConvertAngle(..) -- -- , ConvertAngle(..)
-- | Particle system -- -- | Particle system
, Particle(..) -- , Particle(..)
, ParticleSystem(..) -- , ParticleSystem(..)
, ParticleStorage(..) -- , ParticleStorage(..)
-- | Convenience exports -- -- | Convenience exports
, liftIO -- , liftIO
, SDL.WindowConfig(..) -- , SDL.WindowConfig(..)
, SDL.defaultWindow -- , SDL.defaultWindow
-- | GEGL reexports -- -- | GEGL reexports
, G.GeglRectangle(..) -- , G.GeglRectangle(..)
, G.GeglBuffer(..) -- , G.GeglBuffer(..)
) where -- )
where
import qualified SDL.Init as SDL import qualified SDL.Init as SDL
import qualified SDL.Video as SDL import qualified SDL.Video as SDL
@ -35,8 +36,8 @@ import qualified SDL.Event as SDL
import qualified Data.Text as T import qualified Data.Text as T
import Data.Map.Strict as M import Data.Map.Strict as M
import qualified GEGL as G -- import qualified GEGL as G
import qualified BABL as B -- import qualified BABL as B
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.State import Control.Monad.State
@ -86,11 +87,12 @@ data AffectionData us = AffectionData
{ quitEvent :: Bool -- ^ Loop breaker. { quitEvent :: Bool -- ^ Loop breaker.
, userState :: us -- ^ State data provided by user , userState :: us -- ^ State data provided by user
, drawWindow :: SDL.Window -- ^ SDL window , drawWindow :: SDL.Window -- ^ SDL window
, glContext :: SDL.GLContext -- ^ OpenGL rendering context
, windowRenderer :: SDL.Renderer -- ^ Internal renderer of window , windowRenderer :: SDL.Renderer -- ^ Internal renderer of window
, drawTexture :: SDL.Texture -- ^ SDL Texture to draw to , drawTexture :: SDL.Texture -- ^ SDL Texture to draw to
, drawFormat :: B.BablFormatPtr -- ^ Target format -- , drawFormat :: B.BablFormatPtr -- ^ Target format
, screenMode :: SDL.WindowMode -- ^ current screen mode , screenMode :: SDL.WindowMode -- ^ current screen mode
, drawStack :: [DrawRequest] -- ^ Stack of 'DrawRequest's to be processed -- , drawStack :: [DrawRequest] -- ^ Stack of 'DrawRequest's to be processed
, drawDimensions :: (Int, Int) -- ^ Dimensions of target surface , drawDimensions :: (Int, Int) -- ^ Dimensions of target surface
, drawStride :: Int -- ^ Stride of target buffer , drawStride :: Int -- ^ Stride of target buffer
, drawCPP :: Int -- ^ Number of components per pixel , drawCPP :: Int -- ^ Number of components per pixel
@ -100,19 +102,19 @@ data AffectionData us = AffectionData
, pausedTime :: Bool -- ^ Should the update loop be executed? , pausedTime :: Bool -- ^ Should the update loop be executed?
} }
-- | This datatype stores information about areas of a 'G.GeglBuffer' to be updated -- -- | This datatype stores information about areas of a 'G.GeglBuffer' to be updated
data DrawRequest = DrawRequest -- data DrawRequest = DrawRequest
{ requestArea :: G.GeglRectangle -- ^ The area to update -- { requestArea :: G.GeglRectangle -- ^ The area to update
, requestBuffer :: G.GeglBuffer -- ^ Buffer to draw -- , requestBuffer :: G.GeglBuffer -- ^ Buffer to draw
, requestPersist :: RequestPersist -- ^ Shall the drawRequest persist -- , requestPersist :: RequestPersist -- ^ Shall the drawRequest persist
} -- }
--
data RequestPersist -- data RequestPersist
= Persist -- = Persist
| Kill (Maybe G.GeglNode) -- | Kill (Maybe G.GeglNode)
--
-- | A type for storing 'DrawRequest' results to be executed frequently. TODO -- -- | A type for storing 'DrawRequest' results to be executed frequently. TODO
data DrawAsset = DrawAsset -- data DrawAsset = DrawAsset
-- | Inner 'StateT' monad for the update state -- | Inner 'StateT' monad for the update state
-- type AffectionStateInner us m a = StateT (AffectionData us) m a -- type AffectionStateInner us m a = StateT (AffectionData us) m a
@ -190,39 +192,39 @@ type Angle = Double
-- (==) dx@(Deg _) ry@(Rad _) = dx == toDeg ry -- (==) dx@(Deg _) ry@(Rad _) = dx == toDeg ry
-- (==) rx@(Rad _) dy@(Deg _) = toDeg rx == dy -- (==) rx@(Rad _) dy@(Deg _) = toDeg rx == dy
-- | A single particle -- -- | A single particle
data Particle = Particle -- data Particle = Particle
{ particleTimeToLive :: Double -- { particleTimeToLive :: Double
-- ^ Time to live in seconds -- -- ^ Time to live in seconds
, particleCreation :: Double -- , particleCreation :: Double
-- ^ Creation time of particle in seconds form program start -- -- ^ Creation time of particle in seconds form program start
, particlePosition :: (Double, Double) -- , particlePosition :: (Double, Double)
-- ^ Position of particle on canvas -- -- ^ Position of particle on canvas
, particleRotation :: Angle -- , particleRotation :: Angle
-- ^ Particle rotation -- -- ^ Particle rotation
, particleVelocity :: (Int, Int) -- , particleVelocity :: (Int, Int)
-- ^ particle velocity as vector of pixels per second -- -- ^ particle velocity as vector of pixels per second
, particlePitchRate :: Angle -- , particlePitchRate :: Angle
-- ^ Rotational velocity of particle in angle per second -- -- ^ Rotational velocity of particle in angle per second
, particleRootNode :: G.GeglNode -- , particleRootNode :: G.GeglNode
-- ^ Root 'G.GeglNode' of 'Particle' -- -- ^ Root 'G.GeglNode' of 'Particle'
, particleNodeGraph :: Map String G.GeglNode -- , particleNodeGraph :: Map String G.GeglNode
-- ^ Node Graph of 'G.GeglNodes' per particle -- -- ^ Node Graph of 'G.GeglNodes' per particle
, particleStackCont :: G.GeglNode -- , particleStackCont :: G.GeglNode
-- ^ 'G.GeglNode' to connect other 'Particle's to -- -- ^ 'G.GeglNode' to connect other 'Particle's to
, particleDrawFlange :: G.GeglNode -- , particleDrawFlange :: G.GeglNode
-- ^ 'G.GeglNode' to connect draw actions to -- -- ^ 'G.GeglNode' to connect draw actions to
} deriving (Eq) -- } deriving (Eq)
--
-- | The particle system -- -- | The particle system
data ParticleSystem = ParticleSystem -- data ParticleSystem = ParticleSystem
{ partSysParts :: ParticleStorage -- { partSysParts :: ParticleStorage
, partSysNode :: G.GeglNode -- , partSysNode :: G.GeglNode
, partSysBuffer :: G.GeglBuffer -- , partSysBuffer :: G.GeglBuffer
} -- }
--
-- | The particle storage datatype -- -- | The particle storage datatype
data ParticleStorage = ParticleStorage -- data ParticleStorage = ParticleStorage
{ partStorLatest :: Maybe Particle -- ^ The particle stored last -- { partStorLatest :: Maybe Particle -- ^ The particle stored last
, partStorList :: [Particle] -- ^ List of particles in ascending order of remaining lifetime -- , partStorList :: [Particle] -- ^ List of particles in ascending order of remaining lifetime
} -- }