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
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
@ -64,14 +64,15 @@ library
, sdl2
, text
, mtl
, gegl
, babl
-- , gegl
-- , babl
, monad-loops
, monad-parallel
, containers
, clock
, glib
, bytestring
, OpenGL
-- , sdl2-image
-- 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 #-}
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,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 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 +57,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 +68,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
@ -135,8 +142,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
@ -145,7 +152,9 @@ 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 <$>
@ -154,7 +163,8 @@ withAffection AffectionConfig{..} = do
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 +174,7 @@ withAffection AffectionConfig{..} = do
)
)
) initContainer
G.gegl_exit
-- G.gegl_exit
cleanUp $ userState nState
SDL.destroyWindow window
SDL.quit

5
src/Affection/Draw.hs
View file

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

164
src/Affection/Types.hs
View file

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