From 46de809202e13cf69a2624d9a1b4124aa1f74c57 Mon Sep 17 00:00:00 2001 From: nek0 Date: Sat, 9 Sep 2017 16:47:24 +0200 Subject: [PATCH 1/3] switching to 3D --- affection.cabal | 1 + src/Affection.hs | 90 +++++++++++++++++++++++------------------- src/Affection/Types.hs | 1 + 3 files changed, 51 insertions(+), 41 deletions(-) diff --git a/affection.cabal b/affection.cabal index 7d65f3b..2ef28de 100644 --- a/affection.cabal +++ b/affection.cabal @@ -72,6 +72,7 @@ library , clock , glib , bytestring + , OpenGL -- , sdl2-image -- executable example00 diff --git a/src/Affection.hs b/src/Affection.hs index e3f9d4a..1f96651 100644 --- a/src/Affection.hs +++ b/src/Affection.hs @@ -2,6 +2,7 @@ {-# LANGUAGE BangPatterns #-} module Affection ( withAffection + , get , getAffection , putAffection -- , withWindow @@ -13,7 +14,7 @@ module Affection 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 @@ -39,6 +40,8 @@ import Affection.Actor as A import Affection.Animation as A import Affection.Util as A +import Graphics.Rendering.OpenGL as GL (clear, flush, ClearBuffer(..)) + import qualified BABL as B -- | Main function which bootstraps everything else. @@ -52,7 +55,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… @@ -63,35 +66,36 @@ 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 + 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) = 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 execTime <- getTime Monotonic @@ -99,15 +103,16 @@ withAffection AffectionConfig{..} = do { 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 + -- , drawStride = stride + -- , drawCPP = cpp , drawStack = [] , elapsedTime = 0 , deltaTime = 0 @@ -126,8 +131,8 @@ withAffection AffectionConfig{..} = do -- Measure time difference form last run now <- liftIO $ getTime Monotonic let lastTime = sysTime ad - -- clean draw requests from last run - MP.mapM_ (invalidateDrawRequest (drawStride ad) (drawCPP ad)) (drawStack ad) + -- -- clean draw requests from last run + -- MP.mapM_ (invalidateDrawRequest (drawStride ad) (drawCPP ad)) (drawStack ad) -- clean the renderer form last time -- SDL.clear renderer -- compute dt and update elapsedTime @@ -144,16 +149,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 <$> - MP.mapM (handleDrawRequest (drawStride ad) (drawCPP ad)) (drawStack ad2) - -- save all draw requests to clear in next run - put $ ad2 - { drawStack = clear } + -- clear <- catMaybes <$> + -- MP.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) ( @@ -163,7 +171,7 @@ withAffection AffectionConfig{..} = do ) ) ) initContainer - G.gegl_exit + -- G.gegl_exit cleanUp $ userState nState SDL.destroyWindow window SDL.quit diff --git a/src/Affection/Types.hs b/src/Affection/Types.hs index c94d2c5..800ad5f 100644 --- a/src/Affection/Types.hs +++ b/src/Affection/Types.hs @@ -86,6 +86,7 @@ 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 From 08c28fe6863d0ec6db75321e1ab2943a5ffdb114 Mon Sep 17 00:00:00 2001 From: nek0 Date: Tue, 3 Oct 2017 12:47:18 +0200 Subject: [PATCH 2/3] unBABL and unGEGL --- affection.cabal | 16 ++-- src/Affection.hs | 22 +++--- src/Affection/Draw.hs | 5 +- src/Affection/Types.hs | 163 +++++++++++++++++++++-------------------- 4 files changed, 104 insertions(+), 102 deletions(-) diff --git a/affection.cabal b/affection.cabal index 2ef28de..b7ca0f8 100644 --- a/affection.cabal +++ b/affection.cabal @@ -36,14 +36,14 @@ 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 default-extensions: OverloadedStrings @@ -60,12 +60,12 @@ library default-language: Haskell2010 ghc-options: -Wall -- Other library packages from which modules are imported. - build-depends: base >=4.9 && <4.10 + build-depends: base >=4.9 , sdl2 , text , mtl - , gegl - , babl + -- , gegl + -- , babl , monad-loops , monad-parallel , containers diff --git a/src/Affection.hs b/src/Affection.hs index 1f96651..b760c22 100644 --- a/src/Affection.hs +++ b/src/Affection.hs @@ -11,6 +11,7 @@ module Affection , module A ) where +import SDL (($=)) import qualified SDL import qualified SDL.Internal.Numbered as SDL (toNumber) import qualified SDL.Raw as Raw @@ -31,18 +32,18 @@ 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 Graphics.Rendering.OpenGL as GL (clear, flush, ClearBuffer(..)) -import qualified BABL as B +-- import qualified BABL as B -- | Main function which bootstraps everything else. withAffection @@ -87,7 +88,7 @@ withAffection AffectionConfig{..} = do -- ) -- -- make draw surface -- -- pixelFormat <- liftIO $ peek . Raw.surfaceFormat =<< peek ptr - let SDL.V2 (CInt rw) (CInt rh) = windowInitialSize windowConfig + 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) @@ -98,6 +99,7 @@ withAffection AffectionConfig{..} = do -- format <- B.babl_format bablFormat -- get current time SDL.setWindowMode window initScreenMode + SDL.swapInterval $= SDL.SynchronizedUpdates execTime <- getTime Monotonic initContainer <- (\x -> AffectionData { quitEvent = False @@ -113,7 +115,7 @@ withAffection AffectionConfig{..} = do , screenMode = initScreenMode -- , drawStride = stride -- , drawCPP = cpp - , drawStack = [] + -- , drawStack = [] , elapsedTime = 0 , deltaTime = 0 , sysTime = execTime @@ -139,8 +141,8 @@ withAffection AffectionConfig{..} = do 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 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/Types.hs b/src/Affection/Types.hs index 800ad5f..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 @@ -89,9 +90,9 @@ data AffectionData us = AffectionData , 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 @@ -101,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 @@ -191,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 +-- } From f7dac3e0b606957cec156e1738e29859670b4b59 Mon Sep 17 00:00:00 2001 From: nek0 Date: Wed, 15 Nov 2017 18:28:38 +0100 Subject: [PATCH 3/3] deparallelize --- src/Affection/Particle.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/Affection/Particle.hs b/src/Affection/Particle.hs index 0518cd3..637709f 100644 --- a/src/Affection/Particle.hs +++ b/src/Affection/Particle.hs @@ -13,7 +13,6 @@ import Affection.Types import Control.Monad import Control.Monad.State (get) -import qualified Control.Monad.Parallel as MP import Data.Maybe @@ -34,7 +33,7 @@ updateParticle -> Affection us [Particle] -- ^ processed 'Particle's updateParticle time func l = - catMaybes <$> MP.mapM (\p -> do + catMaybes <$> mapM (\p -> do now <- elapsedTime <$> get if particleCreation p + particleTimeToLive p < now then do @@ -124,7 +123,7 @@ drawParticleSystem sys draw = if not (null parts) then do liftIO $ G.gegl_node_link (particleStackCont $ head parts) (partSysNode sys) - MP.mapM_ (draw (partSysBuffer sys) (partSysNode sys)) parts + mapM_ (draw (partSysBuffer sys) (partSysNode sys)) parts else do _ <- liftIO $ G.gegl_node_disconnect (partSysNode sys) "input" return ()