Merge pull request #3 from nek0/messagebus

Messagebus

affection.cabal

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

notes/TODO.md

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

src/Affection.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE BangPatterns #-}
 module Affection
     ( withAffection
+    , get
     , getAffection
     , putAffection
     -- , withWindow
@@ -12,10 +13,11 @@ module Affection
     , module A
     ) where
 
+import SDL (($=))
 import qualified SDL
 import qualified SDL.Internal.Numbered as SDL (toNumber)
 import qualified SDL.Raw as Raw
-import qualified GEGL as G
+-- import qualified GEGL as G
 
 import Data.Maybe
 import Data.IORef
@@ -31,16 +33,19 @@ import Foreign.Storable (peek)
 import Debug.Trace
 
 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.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.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.
 withAffection
@@ -53,7 +58,7 @@ withAffection AffectionConfig{..} = do
       SDL.initializeAll
     Only is ->
       SDL.initialize is
-  G.gegl_init
+  -- G.gegl_init
   -- give SDL render quality
   SDL.HintRenderScaleQuality SDL.$= SDL.ScaleLinear
   -- just checking…
@@ -64,52 +69,55 @@ withAffection AffectionConfig{..} = do
   -- construct window
   window <- SDL.createWindow windowTitle windowConfig
   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
         Just (cw, ch) -> (cw, ch)
         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
   SDL.setWindowMode window initScreenMode
+  SDL.swapInterval $= SDL.SynchronizedUpdates
   execTime <- getTime Monotonic
   initContainer <- (\x -> AffectionData
     { quitEvent       = False
     , userState       = x
     , drawWindow      = window
-    , windowRenderer  = renderer
+    , glContext       = context
-    , drawTexture     = texture
+    -- , windowRenderer  = renderer
-    , drawFormat      = format
+    -- , drawTexture     = texture
+    -- , drawFormat      = format
     , drawDimensions  = case canvasSize of
         Just (cw, ch) -> (cw, ch)
         Nothing       -> (w, h)
     , screenMode      = initScreenMode
-    , drawStride      = stride
+    -- , drawStride      = stride
-    , drawCPP         = cpp
+    -- , drawCPP         = cpp
-    , drawStack       = []
+    -- , drawStack       = []
     , elapsedTime     = 0
     , deltaTime       = 0
     , sysTime         = execTime
@@ -128,15 +136,15 @@ withAffection AffectionConfig{..} = do
         now      <- liftIO $ getTime Monotonic
         let lastTime = sysTime ad
         -- 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
         -- SDL.clear renderer
         -- compute dt and update elapsedTime
         let !dt = fromIntegral (toNanoSecs $ diffTimeSpec lastTime now) / (10 ^ 9)
             !ne = elapsedTime ad + dt
         put $ ad
-          { drawStack = []
+          -- { drawStack = []
-          , elapsedTime = ne
+          { elapsedTime = ne
           , deltaTime = dt
           }
         -- poll events
@@ -145,16 +153,19 @@ withAffection AffectionConfig{..} = do
         -- execute user defined update loop
         unless (pausedTime ad) (updateLoop dt)
         -- execute user defined draw loop
+        liftIO $ GL.clear [ColorBuffer, DepthBuffer]
         drawLoop
+        liftIO $ flush
         -- handle all new draw requests
         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
-        SDL.present (windowRenderer ad2)
+        SDL.glSwapWindow window
+        -- SDL.present (windowRenderer ad2)
         -- save new time
         ad3 <- get
         when (sysTime ad == sysTime ad3) (
@@ -164,7 +175,7 @@ withAffection AffectionConfig{..} = do
           )
       )
     ) initContainer
-  G.gegl_exit
+  -- G.gegl_exit
   cleanUp $ userState nState
   SDL.destroyWindow window
   SDL.quit

src/Affection/Draw.hs

@@ -28,9 +28,8 @@ import System.Glib.GObject
 
 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
 

src/Affection/MessageBus.hs

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

src/Affection/Types.hs

@@ -1,33 +1,34 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving, DeriveFunctor #-}
 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.Video as SDL
@@ -35,8 +36,8 @@ 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 GEGL as G
-import qualified BABL as B
+-- import qualified BABL as B
 
 import Control.Monad.IO.Class
 import Control.Monad.State
@@ -86,11 +87,12 @@ data AffectionData us = AffectionData
   { 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
+  -- , drawFormat      :: B.BablFormatPtr    -- ^ Target format
   , 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
   , drawStride      :: Int                -- ^ Stride of target buffer
   , drawCPP         :: Int                -- ^ Number of components per pixel
@@ -100,19 +102,19 @@ data AffectionData us = AffectionData
   , 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
 -- type AffectionStateInner us m a = StateT (AffectionData us) m a
@@ -190,39 +192,39 @@ type Angle = Double
 --   (==) dx@(Deg _) ry@(Rad _) = dx == toDeg ry
 --   (==) 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
-  }
+--   }