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

Merge branch 'messagebus' of ssh://gitea.chelnok.de:6667/nek0/affection into messagebus

Browse source
This commit is contained in:
nek0 2017-11-23 19:35:32 +01:00
commit f61377f43a
5 changed files with 156 additions and 135 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

15
affection.cabal
View file

@ -36,14 +36,14 @@ 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
default-extensions: OverloadedStrings default-extensions: OverloadedStrings
@ -64,14 +64,15 @@ 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
-- , 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

98
src/Affection.hs
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,18 @@ 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 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 +57,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 +68,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
@ -135,8 +142,8 @@ withAffection AffectionConfig{..} = do
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,7 +152,9 @@ 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 <$>
@ -154,7 +163,8 @@ withAffection AffectionConfig{..} = do
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 +174,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

5
src/Affection/Draw.hs
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

164
src/Affection/Types.hs
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
} -- }