diff --git a/affection.cabal b/affection.cabal index 251ce66..84e6563 100644 --- a/affection.cabal +++ b/affection.cabal @@ -36,15 +36,16 @@ flag examples library exposed-modules: Affection - , Affection.Draw - , Affection.Particle + -- , Affection.Draw + -- , Affection.Particle , Affection.Types , Affection.StateMachine , Affection.MouseInteractable - , Affection.Property - , Affection.Actor - , Affection.Animation + -- , Affection.Property + -- , Affection.Actor + -- , 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 - , babl + -- , gegl + -- , babl , monad-loops , monad-parallel , containers , clock , glib , bytestring + , OpenGL + , stm -- , sdl2-image -- executable example00 diff --git a/notes/TODO.md b/notes/TODO.md new file mode 100644 index 0000000..db88493 --- /dev/null +++ b/notes/TODO.md @@ -0,0 +1,9 @@ +# TODO + +Implement following things in approximately this Order: + +* Message bus +* Console +* GUI +* Framework +* Everything else diff --git a/src/Affection.hs b/src/Affection.hs index 6d49ada..5c22a32 100644 --- a/src/Affection.hs +++ b/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.Particle as A +-- import Affection.Draw as A +-- import Affection.Particle as A import Affection.StateMachine as A import Affection.MouseInteractable as A -import Affection.Property as A -import Affection.Actor as A -import Affection.Animation as A +-- import Affection.Property as A +-- import Affection.Actor 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 - renderer <- SDL.createRenderer - window - (-1) - SDL.defaultRenderer - -- make draw texture - texture <- SDL.createTexture - renderer - SDL.ABGR8888 - SDL.TextureAccessStreaming - (case canvasSize of - Just (cw, ch) -> (SDL.V2 - (CInt $ fromIntegral cw) - (CInt $ fromIntegral ch) - ) - Nothing -> - SDL.windowInitialSize windowConfig - ) - -- make draw surface - -- pixelFormat <- liftIO $ peek . Raw.surfaceFormat =<< peek ptr - let SDL.V2 (CInt rw) (CInt rh) = windowInitialSize windowConfig + context <- SDL.glCreateContext(window) + -- -- create renderer + -- renderer <- SDL.createRenderer + -- window + -- (-1) + -- SDL.defaultRenderer + -- -- make draw texture + -- texture <- SDL.createTexture + -- renderer + -- SDL.ABGR8888 + -- SDL.TextureAccessStreaming + -- (case canvasSize of + -- Just (cw, ch) -> (SDL.V2 + -- (CInt $ fromIntegral cw) + -- (CInt $ fromIntegral ch) + -- ) + -- Nothing -> + -- SDL.windowInitialSize windowConfig + -- ) + -- -- make draw surface + -- -- 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 - bablFormat = B.PixelFormat B.RGBA B.CFu8 - cpp = B.babl_components_per_pixel bablFormat - !stride = cpp * w - format <- B.babl_format bablFormat + -- -- stride = fromIntegral (Raw.pixelFormatBytesPerPixel pixelFormat) * w + -- bablFormat = B.PixelFormat B.RGBA B.CFu8 + -- cpp = B.babl_components_per_pixel bablFormat + -- !stride = cpp * w + -- 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 - , drawTexture = texture - , drawFormat = format + , glContext = context + -- , windowRenderer = renderer + -- , drawTexture = texture + -- , drawFormat = format , drawDimensions = case canvasSize of Just (cw, ch) -> (cw, ch) Nothing -> (w, h) , screenMode = initScreenMode - , drawStride = stride - , drawCPP = cpp - , drawStack = [] + -- , drawStride = stride + -- , drawCPP = cpp + -- , 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 = [] - , elapsedTime = ne + -- { drawStack = [] + { 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 <$> - mapM (handleDrawRequest (drawStride ad) (drawCPP ad)) (drawStack ad2) - -- save all draw requests to clear in next run - put $ ad2 - { drawStack = clear } + -- clear <- catMaybes <$> + -- mapM (handleDrawRequest (drawStride ad) (drawCPP ad)) (drawStack ad2) + -- -- save all draw requests to clear in next run + -- put $ ad2 + -- { 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 diff --git a/src/Affection/Draw.hs b/src/Affection/Draw.hs index 21c4cd8..e533f7e 100644 --- a/src/Affection/Draw.hs +++ b/src/Affection/Draw.hs @@ -28,9 +28,8 @@ import System.Glib.GObject import qualified SDL -import qualified BABL as B - -import qualified GEGL as G +-- import qualified BABL as B +-- import qualified GEGL as G import Debug.Trace diff --git a/src/Affection/MessageBus.hs b/src/Affection/MessageBus.hs new file mode 100644 index 0000000..2fcbaf8 --- /dev/null +++ b/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 diff --git a/src/Affection/Types.hs b/src/Affection/Types.hs index c94d2c5..df107dc 100644 --- a/src/Affection/Types.hs +++ b/src/Affection/Types.hs @@ -1,33 +1,34 @@ {-# 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 + -- ( 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 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 BABL as B +-- import qualified GEGL as G +-- 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 -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 +-- -- | 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 @@ -190,39 +192,39 @@ type Angle = Double -- (==) 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 - } +-- -- | 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 +-- }