Merge branch 'buffer-get'

This commit is contained in:
nek0 2016-12-26 14:18:02 +01:00
commit 44fdd2e766
10 changed files with 523 additions and 269 deletions

View file

@ -49,7 +49,7 @@ library
, UndecidableInstances
hs-source-dirs: src
default-language: Haskell2010
ghc-options: -Wall
ghc-options: -Wall -debug
-- Other library packages from which modules are imported.
build-depends: base >=4.9 && <4.10
, sdl2
@ -59,7 +59,9 @@ library
, gegl
, babl
, monad-loops
, containers
, clock
, glib
-- , sdl2-image
executable example00
@ -116,7 +118,7 @@ executable example02
executable example03
hs-source-dirs: examples
main-is: example03.hs
ghc-options: -threaded -Wall -auto-all -caf-all -rtsopts
ghc-options: -threaded -Wall -auto-all -caf-all -rtsopts -debug
default-language: Haskell2010
default-extensions: OverloadedStrings
if flag(examples)
@ -130,3 +132,21 @@ executable example03
, random
else
buildable: False
-- executable example04
-- hs-source-dirs: examples
-- main-is: example04.hs
-- ghc-options: -threaded -Wall -auto-all -caf-all -rtsopts
-- default-language: Haskell2010
-- default-extensions: OverloadedStrings
-- if flag(examples)
-- build-depends: base
-- , affection
-- , sdl2
-- , gegl
-- , babl
-- , containers
-- , mtl
-- , random
-- else
-- buildable: False

View file

@ -7,6 +7,8 @@ import qualified GEGL as G
import qualified BABL as B
import qualified Data.Map.Strict as M
import Control.Monad (when)
import Foreign.Storable (peek)
import Foreign.C.Types (CInt(..))
@ -36,7 +38,6 @@ main = do
data UserData = UserData
{ nodeGraph :: M.Map String G.GeglNode
, elapsedTime :: Double
}
load :: SDL.Surface -> IO UserData
@ -53,7 +54,7 @@ load _ = do
traceM "over"
text <- G.gegl_node_new_child root $ G.textOperation
[ G.Property "string" $ G.PropertyString "Hello world!"
, G.Property "color" $ G.PropertyColor $ G.RGBA 0 0 1 0.1
, G.Property "color" $ G.PropertyColor $ G.RGBA 0 0 1 0.5
, G.Property "size" $ G.PropertyDouble 40
]
traceM "text"
@ -69,7 +70,6 @@ load _ = do
traceM "loading complete"
return $ UserData
{ nodeGraph = myMap
, elapsedTime = 0
}
draw :: Affection UserData ()
@ -99,18 +99,10 @@ draw = do
update :: Double -> Affection UserData ()
update sec = do
traceM "updating"
-- liftIO $ delaySec 5
ad@AffectionData{..} <- get
let ud@UserData{..} = userState
traceM $ show elapsedTime
if elapsedTime < 5
then
put $ ad
{ userState = ud
{ elapsedTime = elapsedTime + sec
}
}
else
ad <- get
ud@UserData{..} <- getAffection
traceM $ (show $ 1 / sec) ++ " FPS"
when (elapsedTime ad > 5) $
put $ ad
{ quitEvent = True
}

View file

@ -7,6 +7,8 @@ import qualified GEGL as G
import qualified BABL as B
import qualified Data.Map.Strict as M
import Control.Monad (when)
import Foreign.Storable (peek)
import Foreign.C.Types
@ -37,7 +39,6 @@ main = do
data UserData = UserData
{ nodeGraph :: M.Map String G.GeglNode
, foreground :: G.GeglBuffer
, elapsedTime :: Double
}
load :: SDL.Surface -> IO UserData
@ -54,111 +55,48 @@ load _ = do
traceM "over"
buffer <- G.gegl_buffer_new (Just $ G.GeglRectangle 0 0 800 600) =<<
B.babl_format (B.PixelFormat B.RGBA B.CFfloat)
bufsrc <- G.gegl_node_new_child root $ G.bufferSourceOperation
sink <- G.gegl_node_new_child root $ G.Operation "gegl:copy-buffer"
[ G.Property "buffer" $ G.PropertyBuffer buffer
]
traceM "buffer-source"
G.gegl_node_link checkerboard over
G.gegl_node_connect_to bufsrc "output" over "aux"
nop <- G.gegl_node_new_child root $ G.Operation "gegl:nop" []
traceM "nop"
crop <- G.gegl_node_new_child root $ G.Operation "gegl:crop"
[ G.Property "width" $ G.PropertyDouble 800
, G.Property "height" $ G.PropertyDouble 600
]
G.gegl_node_link_many [checkerboard, over, crop, sink]
G.gegl_node_connect_to nop "output" over "aux"
traceM "connections made"
myMap <- return $ M.fromList
[ ("root" , root)
, ("over" , over)
, ("background" , checkerboard)
, ("foreground" , bufsrc)
, ("sink" , sink)
, ("nop" , nop)
]
let roi = G.GeglRectangle 0 0 20 20
-- G.iterateOver
-- buffer
-- roi
-- (B.PixelFormat B.RGBA B.CFfloat)
-- G.GeglAccessReadWrite
-- G.GeglAbyssNone
-- (\(G.Pixel px py pc) ->
-- let dsqr = (((10 - px) ^ 2) + ((10 - py) ^ 2))
-- (G.CVfloat (CFloat pr), G.CVfloat (CFloat pg), G.CVfloat (CFloat pb), G.CVfloat (CFloat pa)) = pc
-- dist = (sqrt (fromIntegral dsqr :: Float))
-- in if dsqr < 100
-- then
-- if dist < fromIntegral 9
-- then
-- G.Pixel px py
-- ( G.CVfloat $ CFloat 0
-- , G.CVfloat $ CFloat 0
-- , G.CVfloat $ CFloat 0
-- , G.CVfloat $ CFloat $ if pa < 1 then 1 else pa
-- )
-- else
-- let alpha = fromIntegral 10 - dist
-- dst_a = pa
-- a = alpha + dst_a * (1 - alpha)
-- a_term = dst_a * (1 - alpha)
-- red = 0 * alpha + pr * a_term
-- gre = 0 * alpha + pg * a_term
-- blu = 0 * alpha + pb * a_term
-- in
-- G.Pixel px py
-- ( G.CVfloat $ CFloat $ red / a
-- , G.CVfloat $ CFloat $ gre / a
-- , G.CVfloat $ CFloat $ blu / a
-- , G.CVfloat $ CFloat $ if pa < alpha then alpha else pa
-- )
-- else
-- G.Pixel px py pc
-- )
traceM "loading complete"
return $ UserData
{ nodeGraph = myMap
, foreground = buffer
, elapsedTime = 0
}
draw :: Affection UserData ()
draw = do
traceM "drawing"
UserData{..} <- getAffection
-- AffectionData{..} <- get
-- let UserData{..} = userState
-- -- liftIO $ SDL.lockSurface drawSurface
-- pixels <- liftIO $ SDL.surfacePixels drawSurface
-- let SDL.Surface rawSurfacePtr _ = drawSurface
-- rawSurface <- liftIO $ peek rawSurfacePtr
-- pixelFormat <- liftIO $ peek $ Raw.surfaceFormat rawSurface
-- format <- liftIO $ (B.babl_format $ B.PixelFormat B.RGBA B.CFu8)
-- SDL.V2 (CInt rw) (CInt rh) <- SDL.surfaceDimensions drawSurface
-- let (w, h) = (fromIntegral rw, fromIntegral rh)
drawRect foreground (nodeGraph M.! "over") (G.RGB 1 0 0) (Line 2) (G.GeglRectangle 10 10 500 500)
-- liftIO $ G.gegl_node_blit
-- (nodeGraph M.! "over" :: G.GeglNode)
-- 1
-- (G.GeglRectangle 0 0 w h)
-- format
-- pixels
-- (fromIntegral (Raw.pixelFormatBytesPerPixel pixelFormat) * w)
-- [G.GeglBlitDefault]
-- liftIO $ SDL.unlockSurface drawSurface
-- liftIO $ SDL.updateWindowSurface drawWindow
drawRect (nodeGraph M.! "nop") (G.RGB 1 0 0) Fill (G.GeglRectangle 10 10 500 500) foreground
liftIO $ G.gegl_node_process $ nodeGraph M.! "sink"
update :: Double -> AffectionState (AffectionData UserData) IO ()
update sec = do
traceM "updating"
-- liftIO $ delaySec 5
ad@AffectionData{..} <- get
let ud@UserData{..} = userState
ad <- get
ud@UserData{..} <- getAffection
traceM $ (show $ 1 / sec) ++ " FPS"
if elapsedTime < 20
then do
fg <- liftIO $ G.gegl_buffer_get_extent foreground
_ <- liftIO $ G.gegl_buffer_set_extent foreground $ fg
{ G.rectangleX = G.rectangleX fg + 1
, G.rectangleY = G.rectangleY fg + 1
}
put $ ad
{ userState = ud
{ elapsedTime = elapsedTime + sec
}
}
else
when (elapsedTime ad > 20) $
put $ ad
{ quitEvent = True
}

View file

@ -3,10 +3,13 @@
import Affection
import qualified SDL
import qualified GEGL as G
import qualified GEGL.FFI.Buffer as G
import qualified BABL as B
import qualified Data.Map.Strict as M
import Foreign.C.Types
import Foreign.Marshal.Utils (new)
import Foreign.Ptr (castPtr)
import Debug.Trace
@ -16,7 +19,7 @@ main = do
{ initComponents = All
, windowTitle = "Affection: example00"
, windowConfig = SDL.defaultWindow
, preLoop = drawInit
, preLoop = return ()
, drawLoop = draw
, updateLoop = update
, loadState = load
@ -42,20 +45,29 @@ load _ = do
traceM "checkerboard"
over <- G.gegl_node_new_child root G.defaultOverOperation
traceM "over"
buffer <- G.gegl_buffer_new (Just $ G.GeglRectangle 0 0 800 600) =<<
buffer@(G.GeglBuffer b) <- G.gegl_buffer_new (Just $ G.GeglRectangle 0 0 800 600) =<<
B.babl_format (B.PixelFormat B.RGBA B.CFfloat)
bufsrc <- G.gegl_node_new_child root $ G.bufferSourceOperation
bufPtr <- new b
sink <- G.gegl_node_new_child root $ G.Operation "gegl:copy-buffer"
[ G.Property "buffer" $ G.PropertyBuffer buffer
]
traceM "buffer-source"
G.gegl_node_link checkerboard over
G.gegl_node_connect_to bufsrc "output" over "aux"
traceM "buffer-sink"
nop <- G.gegl_node_new_child root $ G.Operation "gegl:nop" []
traceM "nop"
crop <- G.gegl_node_new_child root $ G.Operation "gegl:crop"
[ G.Property "width" $ G.PropertyDouble 800
, G.Property "height" $ G.PropertyDouble 600
]
G.gegl_node_link_many [checkerboard, over, crop, sink]
G.gegl_node_connect_to nop "output" over "aux"
traceM "connections made"
myMap <- return $ M.fromList
[ ("root" , root)
, ("over" , over)
, ("background" , checkerboard)
, ("foreground" , bufsrc)
, ("sink" , sink)
, ("nop" , nop)
, ("crop" , crop)
]
traceM "loading complete"
return $ UserData
@ -64,10 +76,10 @@ load _ = do
, coordinates = Nothing
}
drawInit :: Affection UserData ()
drawInit = do
UserData{..} <- getAffection
present (nodeGraph M.! "over") foreground (GeglRectangle 0 0 800 600) True
-- drawInit :: Affection UserData ()
-- drawInit = do
-- UserData{..} <- getAffection
-- present (nodeGraph M.! "over") foreground (GeglRectangle 0 0 800 600) True
draw :: Affection UserData ()
draw = do
@ -79,12 +91,13 @@ draw = do
liftIO $ clearArea foreground (GeglRectangle 0 0 w h)
maybe (return ()) (\(x, y) ->
drawRect
foreground
(nodeGraph M.! "over")
(nodeGraph M.! "nop")
(G.RGBA 1 0 0 0.5)
(Line 7)
(Fill)
(G.GeglRectangle (x - 10) (y - 10) 20 20)
foreground
) coordinates
liftIO $ G.gegl_node_process $ nodeGraph M.! "sink"
update :: Double -> AffectionState (AffectionData UserData) IO ()
update sec = do

View file

@ -4,8 +4,11 @@ import Affection
import qualified SDL
import qualified GEGL as G
import qualified BABL as B
import qualified Data.Map.Strict as M
import Control.Monad (when)
import Foreign.C.Types
import System.Random (randomRIO)
@ -29,7 +32,6 @@ main = do
data UserData = UserData
{ nodeGraph :: M.Map String G.GeglNode
, foreground :: G.GeglBuffer
, coordinates :: Maybe (Int, Int)
, partsys :: ParticleSystem
}
@ -45,37 +47,47 @@ load _ = do
traceM "checkerboard"
over <- G.gegl_node_new_child root G.defaultOverOperation
traceM "over"
buffer <- G.gegl_buffer_new (Just $ G.GeglRectangle 0 0 800 600) =<<
buffer@(G.GeglBuffer b) <- G.gegl_buffer_new (Just $ G.GeglRectangle 0 0 800 600) =<<
B.babl_format (B.PixelFormat B.RGBA B.CFfloat)
bufsrc <- G.gegl_node_new_child root $ G.bufferSourceOperation
[ G.Property "buffer" $ G.PropertyBuffer buffer
sink <- G.gegl_node_new_child root $ G.Operation "gegl:copy-buffer"
[G.Property "buffer" $ G.PropertyBuffer buffer
]
traceM "buffer-source"
G.gegl_node_link checkerboard over
G.gegl_node_connect_to bufsrc "output" over "aux"
traceM "buffer-sink"
nop <- G.gegl_node_new_child root $ G.Operation "gegl:nop" []
traceM "nop"
crop <- G.gegl_node_new_child root $ G.Operation "gegl:crop"
[ G.Property "width" $ G.PropertyDouble 800
, G.Property "height" $ G.PropertyDouble 600
]
traceM "crop"
G.gegl_node_link_many [checkerboard, over, crop, sink]
G.gegl_node_connect_to nop "output" over "aux"
traceM "connections made"
myMap <- return $ M.fromList
[ ("root" , root)
, ("over" , over)
, ("background" , checkerboard)
, ("foreground" , bufsrc)
, ("sink" , sink)
, ("nop" , nop)
, ("crop" , crop)
]
traceM "loading complete"
return $ UserData
{ nodeGraph = myMap
, foreground = buffer
, coordinates = Nothing
, partsys = ParticleSystem [] over buffer
, partsys = ParticleSystem (ParticleStorage Nothing []) nop buffer
}
drawInit :: Affection UserData ()
drawInit = do
UserData{..} <- getAffection
present (nodeGraph M.! "over") foreground (GeglRectangle 0 0 800 600) True
present (GeglRectangle 0 0 800 600) foreground True
draw :: Affection UserData ()
draw = do
traceM "drawing"
UserData{..} <- getAffection
liftIO $ G.gegl_node_process $ nodeGraph M.! "sink"
-- ad <- get
-- ud <- getAffection
-- drawParticles partDraw $ particles ud
@ -109,20 +121,47 @@ update sec = do
vx <- liftIO $ randomRIO (-20, 20)
vy <- liftIO $ randomRIO (-20, 20)
life <- liftIO $ randomRIO (1, 5)
r <- liftIO $ randomRIO (0,1)
g <- liftIO $ randomRIO (0,1)
b <- liftIO $ randomRIO (0,1)
tempRoot <- liftIO $ G.gegl_node_new
tempOver <- liftIO $ G.gegl_node_new_child tempRoot
G.defaultOverOperation
tempRect <- liftIO $ G.gegl_node_new_child tempRoot $ G.Operation
"gegl:rectangle"
[ G.Property "x" $ G.PropertyDouble $ fromIntegral x - 10
, G.Property "y" $ G.PropertyDouble $ fromIntegral y - 10
, G.Property "width" $ G.PropertyDouble 20
, G.Property "height" $ G.PropertyDouble 20
, G.Property "color" $ G.PropertyColor $ (G.RGBA r g b 0.5)
]
liftIO $ G.gegl_node_connect_to tempRect "output" tempOver "aux"
-- traceM $ "position is: " ++ show x ++ " " ++ show y
-- traceM $ "velocity is: " ++ show vx ++ " " ++ show vy
ips <- insertParticle (partsys ud) $
Particle
{ particleTimeToLive = life
, particleCreation = elapsedTime ad
, particlePosition = (fromIntegral x, fromIntegral y)
, particleRotation = Rad 0
, particleVelocity = (vx, vy)
, particlePitchRate = Rad 0
, particleRootNode = tempRoot
, particleNodeGraph = M.fromList
[ ("root", tempRoot)
, ("over", tempOver)
, ("rect", tempRect)
]
, particleStackCont = tempOver
, particleDrawFlange = tempOver
}
putAffection $ ud
{ coordinates = Just (fromIntegral x, fromIntegral y)
, partsys = (partsys ud)
{ psParts = (Particle
{ particleLife = life
, particlePosition = (fromIntegral x, fromIntegral y)
, particleRotation = Rad 0
, particleVelocity = (vx, vy)
, particlePitchRate = Rad 0
}) : (psParts $ partsys ud)
}
{ partsys = ips
}
-- when (not $ null $ psParts $ partsys ud) $
-- liftIO $ G.gegl_node_link
-- tempOver
-- (particleStackCont $ head $ psParts $ partsys ud)
else
return ()
SDL.WindowClosedEvent _ -> do
@ -140,22 +179,28 @@ update sec = do
clean :: UserData -> IO ()
clean _ = return ()
partUpd :: Double -> Particle -> Particle
partUpd sec p@Particle{..} =
p
partUpd :: Double -> Particle -> Affection UserData Particle
partUpd sec p@Particle{..} = do
let newX = (fst particlePosition) + sec * (fromIntegral $ fst particleVelocity)
newY = (snd particlePosition) + sec * (fromIntegral $ snd particleVelocity)
liftIO $ G.gegl_node_set (particleNodeGraph M.! "rect") $ G.Operation "gegl:rectangle"
[ G.Property "x" $ G.PropertyDouble $ newX - 10
, G.Property "y" $ G.PropertyDouble $ newY - 10
]
return p
{ particlePosition = (newX, newY)
, particleLife = particleLife - sec
}
where
newX = (fst particlePosition) + sec * (fromIntegral $ fst particleVelocity)
newY = (snd particlePosition) + sec * (fromIntegral $ snd particleVelocity)
partDraw :: G.GeglBuffer -> G.GeglNode -> Particle -> Affection UserData ()
partDraw buf node Particle{..} = do
ud <- getAffection
drawRect
present
(G.GeglRectangle (floor $ fst particlePosition - 10) (floor $ snd particlePosition - 10) 20 20)
buf
node
(G.RGBA 1 0 0 0.5)
(Line 5)
(G.GeglRectangle ((floor $ fst particlePosition) - 10) ((floor $ snd particlePosition) -10) 20 20)
False
-- ud <- getAffection
-- drawRect'
-- particleDrawFlange
-- (G.RGBA 1 0 0 0.5)
-- (Fill)
-- (G.GeglRectangle ((floor $ fst particlePosition) - 10) ((floor $ snd particlePosition) -10) 20 20)
-- buf

120
examples/example04.hs Normal file
View file

@ -0,0 +1,120 @@
{-# LANGUAGE RecordWildCards #-}
import Affection
import qualified SDL
import qualified GEGL as G
import qualified BABL as B
import qualified BABL.FFI.Format as B
import qualified Data.Map.Strict as M
import Foreign.C.Types
import Foreign.Ptr (castPtr, nullPtr)
import Foreign.Marshal.Utils (new)
import System.Random (randomRIO)
import Control.Monad (unless)
import Debug.Trace
main :: IO ()
main = do
conf <- return $ AffectionConfig
{ initComponents = All
, windowTitle = "Affection: example00"
, windowConfig = SDL.defaultWindow
, preLoop = return ()
, drawLoop = draw
, updateLoop = update
, loadState = load
, cleanUp = clean
}
withAffection conf
data UserData = UserData
{ nodeGraph :: M.Map String G.GeglNode
, coordinates :: Maybe (Int, Int)
}
load :: SDL.Surface -> IO UserData
load surface = do
traceM "loading"
root <- G.gegl_node_new
traceM "new root node"
checkerboard <- G.gegl_node_new_child root $ G.checkerboardOperation
[ G.Property "color1" $ G.PropertyColor $ G.RGBA 0.4 0.4 0.4 1
, G.Property "color2" $ G.PropertyColor $ G.RGBA 0.6 0.6 0.6 1
]
traceM "checkerboard"
over <- G.gegl_node_new_child root G.defaultOverOperation
traceM "over"
nop <- G.gegl_node_new_child root $ G.Operation "gegl:nop" []
traceM "nop"
crop <- G.gegl_node_new_child root $ G.Operation "gegl:crop"
[ G.Property "x" $ G.PropertyDouble 0
, G.Property "y" $ G.PropertyDouble 0
, G.Property "width" $ G.PropertyDouble 800
, G.Property "height" $ G.PropertyDouble 600
]
traceM "crop"
format <- B.babl_format $ B.PixelFormat B.RGBA B.CFu8
pixels <- liftIO $ new =<< SDL.surfacePixels surface
sink <- G.gegl_node_new_child root $ G.Operation "gegl:buffer-sink"
[ G.Property "buffer" $ G.PropertyPointer $ castPtr $ pixels
, G.Property "format" $ G.PropertyPointer $ nullPtr
]
traceM "sink"
G.gegl_node_link_many [checkerboard, over, crop, sink]
diw <- G.gegl_node_connect_to nop "output" over "aux"
unless diw (error "connect failed")
traceM "connections made"
myMap <- return $ M.fromList
[ ("root" , root)
, ("over" , over)
, ("background" , checkerboard)
, ("nop" , nop)
, ("crop" , crop)
, ("sink" , sink)
]
traceM "loading complete"
return $ UserData
{ nodeGraph = myMap
, coordinates = Nothing
}
update :: Double -> AffectionState (AffectionData UserData) IO ()
update sec = do
traceM "updating"
ad <- get
ud <- getAffection
traceM $ (show $ 1 / sec) ++ " FPS"
ev <- liftIO $ SDL.pollEvents
mapM_ (\e ->
case SDL.eventPayload e of
SDL.MouseButtonEvent dat -> do
let (SDL.P (SDL.V2 x y)) = SDL.mouseButtonEventPos dat
drawRect
(nodeGraph ud M.! "nop")
(G.RGBA 1 0 0 0.5)
Fill
(G.GeglRectangle (fromIntegral x - 10) (fromIntegral y - 10) 20 20)
traceM $ "drewn a rectangle at " ++ show x ++ " " ++ show y
SDL.WindowClosedEvent _ -> do
traceM "seeya!"
put $ ad
{ quitEvent = True
}
_ ->
return ()
) ev
draw :: Affection UserData ()
draw = do
ad <- get
ud <- getAffection
liftIO $ SDL.lockSurface $ drawSurface ad
liftIO $ G.gegl_node_process (nodeGraph ud M.! "sink")
liftIO $ SDL.unlockSurface $ drawSurface ad
clean :: UserData -> IO ()
clean _ = return ()

View file

@ -63,7 +63,9 @@ withAffection AffectionConfig{..} = do
, userState = x
, drawWindow = window
, drawSurface = surface
, drawFormat = format
, drawStack = []
, elapsedTime = 0
}) <$> loadState surface
(_, nState) <- runStateT ( A.runState $ do
preLoop
@ -79,17 +81,20 @@ withAffection AffectionConfig{..} = do
-- get state
ad <- get
-- clean draw requests from last run
mapM_ (invalidateDrawRequest pixels format stride cpp) $ drawStack ad
mapM_ (invalidateDrawRequest pixels stride cpp) $ drawStack ad
-- compute dt and update elapsedTime
let dt = (fromIntegral $ toNanoSecs $ diffTimeSpec lastTime now) / (fromIntegral 10 ^ 9)
put $ ad
{ drawStack = [] }
{ drawStack = []
, elapsedTime = elapsedTime ad + dt
}
-- execute user defined update loop
updateLoop dt
-- execute user defined draw loop
drawLoop
-- execute user defined update loop
updateLoop $ (fromIntegral $ toNanoSecs $ diffTimeSpec lastTime now) /
(fromIntegral 10 ^ 9)
-- handle all new draw requests
ad2 <- get
clear <- catMaybes <$> mapM (handleDrawRequest pixels format stride cpp) (drawStack ad2)
clear <- catMaybes <$> mapM (handleDrawRequest pixels stride cpp) (drawStack ad2)
-- save all draw requests to clear in next run
put $ ad2
{ drawStack = clear }

View file

@ -12,11 +12,13 @@ module Affection.Draw
import Affection.Types
import Foreign.Ptr (Ptr, plusPtr, nullPtr)
import Foreign
import Foreign.C.Types
import Control.Monad.State (get, put)
import Control.Monad (when)
import Control.Monad (when, unless)
import System.Glib.GObject
import qualified SDL
@ -26,123 +28,99 @@ import qualified GEGL as G
import Debug.Trace
-- | Draw a rectangle on target buffer
drawRect
:: G.GeglBuffer -- ^ Target buffer
-> G.GeglNode -- ^ Target node
-> G.Color -- ^ Color to draw in
-> DrawType -- ^ Draw type
-> GeglRectangle -- ^ Dimensions of Rectangle
:: G.GeglNode -- ^ Target Node
-> G.Color -- ^ Color to draw in
-> DrawType -- ^ Draw type
-> G.GeglRectangle -- ^ Dimensions of Rectangle
-> G.GeglBuffer -- ^ Final Buffer
-> Affection us ()
drawRect buf node color (Fill) rect@G.GeglRectangle{..} = do
liftIO $ G.pixelPoke buf rect (B.PixelFormat B.RGBA B.CFdouble) G.GeglAccessReadWrite G.GeglAbyssNone $
(\(x, y) ->
let col = unsafeColorize color
in
G.Pixel x y col
)
ad@AffectionData{..} <- get
drawRect node color Fill rect@GeglRectangle{..} buf = do
ad <- get
tempRoot <- liftIO $ G.gegl_node_new
opNode <- liftIO $ G.gegl_node_new_child tempRoot $ G.Operation "gegl:rectangle"
[ G.Property "x" $ G.PropertyDouble $ fromIntegral rectangleX
, G.Property "y" $ G.PropertyDouble $ fromIntegral rectangleY
, G.Property "width" $ G.PropertyDouble $ fromIntegral rectangleWidth
, G.Property "height" $ G.PropertyDouble $ fromIntegral rectangleHeight
, G.Property "color" $ G.PropertyColor color
]
diw <- liftIO $ G.gegl_node_connect_to opNode "output" node "input"
unless diw $ error "Affection.Draw.drawRect': connect failed"
put $ ad
{ drawStack = (DrawRequest node rect buf False) : drawStack
{ drawStack = (DrawRequest rect buf (Kill (Just tempRoot))) : drawStack ad
}
drawRect buf node color (Line size) rect@G.GeglRectangle{..} = do
liftIO $ G.pixelPoke buf rect (B.PixelFormat B.RGBA B.CFdouble) G.GeglAccessReadWrite G.GeglAbyssNone $
(\(x, y) ->
let col = unsafeColorize color
in if not ((x >= rectangleX + size && x < rectangleX + rectangleWidth - size) &&
(y >= rectangleY + size && y < rectangleY + rectangleHeight - size))
then
G.Pixel x y col
else
G.Pixel x y $ unsafeColorize $ G.RGBA 0 0 0 0
)
ad@AffectionData{..} <- get
put $ ad
{ drawStack = (DrawRequest node rect buf False) : drawStack
}
-- drawRect buf node color Fill (G.GeglRectangle rectangleX rectangleY rectangleWidth size)
-- drawRect buf node color Fill (G.GeglRectangle rectangleX rectangleY size rectangleHeight)
-- drawRect buf node color Fill (G.GeglRectangle (rectangleX + rectangleWidth - size) rectangleY size rectangleHeight)
-- drawRect buf node color Fill (G.GeglRectangle rectangleX (rectangleY + rectangleHeight - size) rectangleWidth size)
-- | force a blit of a specified area. Do not use often as it slows down the program
-- | Force update of a specific region on screen
present
:: G.GeglNode -- ^ Node to blit
-> G.GeglBuffer -- ^ BUffer to draw
-> G.GeglRectangle -- ^ Area to blit
-> Bool -- ^ Shall the drawing be cleared in the next run?
:: G.GeglRectangle -- ^ Area to be updated
-> G.GeglBuffer -- ^ Target buffer
-> Bool -- ^ Shall the 'DrawRequest' persist?
-> Affection us ()
present node buf rect pers = do
present rect buf kill = do
ad <- get
put $ ad
{ drawStack = (DrawRequest node rect buf pers) : drawStack ad
let k = if not kill then Kill Nothing else Yes
put ad
{ drawStack = (DrawRequest rect buf k) : drawStack ad
}
ad <- get
format <- liftIO $ B.babl_format $ B.PixelFormat B.RGBA B.CFu8
liftIO $ SDL.lockSurface $ drawSurface ad
liftIO $ G.gegl_node_blit
node
1
rect
format
nullPtr
0
[G.GeglBlitDefault]
liftIO $ SDL.unlockSurface $ drawSurface ad
liftIO $ SDL.updateWindowSurface $ drawWindow ad
-- | function for handling 'DrawRequest's and updating the output
handleDrawRequest
:: Ptr a -- ^ Pixel buffer to blit to
-> B.BablFormatPtr -- ^ format to blit in
-- -> B.BablFormatPtr -- ^ format to blit in
-> Int -- ^ Stride
-> Int -- ^ Components per Pixel
-> DrawRequest -- ^ 'DrawRequest' to handle
-> Affection us (Maybe DrawRequest)
handleDrawRequest pixels format stride cpp dr@DrawRequest{..} = do
handleDrawRequest pixels stride cpp dr@DrawRequest{..} = do
ad <- get
let surf = drawSurface ad
liftIO $ SDL.lockSurface surf
liftIO $ G.gegl_node_blit
requestNode
liftIO $ G.gegl_buffer_get
requestBuffer
(Just requestArea)
1
requestArea
format
(Just $ drawFormat ad)
(pixels `plusPtr`
(rectangleX requestArea * cpp + rectangleY requestArea * stride))
stride
[G.GeglBlitDefault]
G.GeglAbyssNone
liftIO $ SDL.unlockSurface surf
-- liftIO $ SDL.updateWindowSurface $ drawWindow ad
if requestPersist
then
return Nothing
else
return $ Just dr
case requestPersist of
Yes ->
return Nothing
Kill _ ->
return $ Just dr
-- | clear a previously drawn area
invalidateDrawRequest
:: Ptr a -- ^ Pixel buffer to blit to
-> B.BablFormatPtr -- ^ format to blit in
-- -> B.BablFormatPtr -- ^ format to blit in
-> Int -- ^ Stride
-> Int -- ^ Components per Pixel
-> DrawRequest -- ^ Drawrequest to invalidate
-> Affection us ()
invalidateDrawRequest pixels format stride cpp dr@DrawRequest{..} = do
invalidateDrawRequest pixels stride cpp dr@DrawRequest{..} = do
ad <- get
let !surf = drawSurface ad
let surf = drawSurface ad
liftIO $ clearArea requestBuffer requestArea
liftIO $ SDL.lockSurface surf
liftIO $ G.gegl_node_blit
requestNode
liftIO $ G.gegl_buffer_get
requestBuffer
(Just requestArea)
1
requestArea
format
(Just $ drawFormat ad)
(pixels `plusPtr`
(rectangleX requestArea * cpp + rectangleY requestArea * stride))
stride
[G.GeglBlitDefault]
G.GeglAbyssNone
liftIO $ SDL.unlockSurface surf
case requestPersist of
Kill (Just victim) ->
liftIO $ G.gegl_node_drop victim
_ ->
return ()
-- liftIO $ SDL.updateWindowSurface $ drawWindow ad
-- | compute color for a single pixel
@ -190,12 +168,6 @@ unsafeColorize col =
, G.CVdouble $ CDouble $ a
)
-- -- | Clear all data from a buffer
-- clear
-- :: G.GeglBuffer -- ^ Target buffer
-- -> IO ()
-- clear buf = clearArea buf =<< G.gegl_rectangle_infinite_plane
-- | Clear a specified area of a buffer from all data
clearArea
:: G.GeglBuffer -- ^ Target buffer

View file

@ -5,30 +5,103 @@ module Affection.Particle
( updateParticle
, drawParticles
, updateParticleSystem
, insertParticle
) where
import Affection.Types
import Data.Maybe (catMaybes)
import Control.Monad
import Control.Monad.State (get)
import Data.Maybe
import qualified GEGL as G
import Debug.Trace
-- This function updates particles through a specified function. Particle ageing
-- and death is being handled by 'updateParticles' itself and does not need to
-- bother you.
updateParticle
:: Double -- ^ Elapsed time in seconds
-> (Double -> Particle -> Particle) -- ^ Update function for a single 'Particle'
-- This Function should take the elapsed time
-- in seconds and the initial particle as arguments.
-> Particle -- ^ 'Particle' to be processed
-> Maybe Particle -- ^ resulting 'Particle'
updateParticle time funct p@Particle{..} =
if particleLife - time < 0
then
Nothing
else
Just $ funct time $ p { particleLife = particleLife - time }
:: Double
-- ^ Elapsed time in seconds
-> (Double -> Particle -> Affection us Particle)
-- ^ Update function for a single 'Particle'
-- This Function should take the elapsed time
-- in seconds and the initial particle as arguments.
-- -> [Maybe Particle]
-> Particle
-- ^ 'Particle' to be processed
-- -> Affection us [Maybe Particle]
-> Affection us (Maybe Particle)
-- ^ resulting 'Particle'
updateParticle time funct pa = do
now <- elapsedTime <$> get
if particleCreation pa + particleTimeToLive pa < now
then do
mproducer <- liftIO $ G.gegl_node_get_producer
(particleStackCont pa)
"input"
case mproducer of
Just (producer, padname) -> do
consumers <- liftIO $ G.gegl_node_get_consumers
(particleStackCont pa)
"output"
liftIO $ mapM_ (\(node, inpad)-> G.gegl_node_connect_to
producer
padname
node
inpad
) consumers
Nothing -> return ()
liftIO $ G.gegl_node_drop $ particleRootNode pa
return $ Nothing
else do
np <- Just <$> funct time pa
return $ np
-- updateParticle time funct acc@[p] pa = do
-- now <- elapsedTime <$> get
-- if particleCreation pa + particleTimeToLive pa > now
-- then do
-- liftIO $ G.gegl_node_drop $ particleRootNode pa
-- return $ Nothing : acc
-- else do
-- when (not $ isNothing p) $ do
-- -- liftIO $ traceIO "linking second node in list"
-- liftIO $ G.gegl_node_link
-- (particleStackCont pa)
-- (particleStackCont $ fromJust p)
-- np <- Just <$> funct time pa
-- return $ np : acc
-- updateParticle time funct acc@(p:ps) pa = do
-- now <- elapsedTime <$> get
-- if particleCreation pa + particleTimeToLive pa > now
-- then do
-- liftIO $ G.gegl_node_drop $ particleRootNode pa
-- return $ Nothing : acc
-- else do
-- when (isNothing p) $ do
-- let mnl = nextLiving ps
-- maybe
-- (return ())
-- (\nl -> do
-- -- liftIO $ traceIO "linking nth node on list"
-- liftIO $ G.gegl_node_link (particleStackCont pa) (particleStackCont nl))
-- mnl
-- np <- Just <$> funct time pa
-- return $ np : acc
-- | Get the next living particle from a list
nextLiving
:: [Maybe Particle]
-> Maybe Particle
nextLiving [] = Nothing
nextLiving acc = case catMaybes acc of
[] -> Nothing
ps -> Just $ head $ ps
-- if isNothing p
-- then nextLiving ps
-- else p
drawParticles
:: (Particle -> Affection us ())
@ -39,11 +112,57 @@ drawParticles = mapM_
updateParticleSystem
:: ParticleSystem
-> Double
-> (Double -> Particle -> Particle)
-> (Double -> Particle -> Affection us Particle)
-> (G.GeglBuffer -> G.GeglNode -> Particle -> Affection us ())
-> Affection us ParticleSystem
updateParticleSystem sys sec upd draw = do
let x = catMaybes $ map (updateParticle sec upd) (psParts sys)
mapM_ (draw (psBuffer sys) (psNode sys)) x
x <- catMaybes <$> mapM (updateParticle sec upd) (partStorList $ partSysParts sys)
-- x <- catMaybes <$> foldM (updateParticle sec upd) [] (reverse $ psParts sys)
when (not $ null x) $ do
-- liftIO $ traceIO "linking last node to output"
liftIO $ G.gegl_node_link (particleStackCont $ last x) (partSysNode sys)
mapM_ (draw (partSysBuffer sys) (partSysNode sys)) x
return $ sys
{ psParts = x }
{ partSysParts = (partSysParts sys)
{ partStorList = x
, partStorLatest =
if null x
then Nothing
else partStorLatest (partSysParts sys)
}
}
-- | Function for inserting a new 'Particle' into its 'PartileSystem'
insertParticle
:: ParticleSystem -- ^ 'ParticleSystem' to insert into
-> Particle -- ^ 'Particle' to insert
-> Affection us ParticleSystem -- ^ resulting new 'ParticleSystem'
insertParticle ps p = do
now <- elapsedTime <$> get
let newList = chronoInsert now (partStorList $ partSysParts ps) p
when (not $ isNothing $ partStorLatest $ partSysParts ps) $
liftIO $ G.gegl_node_link
(particleStackCont p)
(particleStackCont $ fromJust $ partStorLatest $ partSysParts ps)
return $ ps
{ partSysParts = (partSysParts ps)
{ partStorLatest = Just p
, partStorList = newList
}
}
-- | Insert a 'Particle' into its chronologically ordered list
chronoInsert
:: Double -- ^ Time in seconds from beginning of program execution
-> [Particle] -- ^ List to insert to
-> Particle -- ^ 'Particle' to insert
-> [Particle] -- ^ Resulting list
chronoInsert now [] np = [np]
chronoInsert now [p] np =
if now + particleTimeToLive p < particleCreation np
then p : [np]
else np : [p]
chronoInsert now l@(p:ps) np =
if now + particleTimeToLive p < particleCreation np
then p : chronoInsert now ps np
else np : l

View file

@ -13,11 +13,13 @@ module Affection.Types
, RGBA(..)
, DrawType(..)
, DrawRequest(..)
, RequestPersist(..)
, Angle(..)
, ConvertAngle(..)
-- | Particle system
, Particle(..)
, ParticleSystem(..)
, ParticleStorage(..)
-- | Convenience exports
, liftIO
, SDL.WindowConfig(..)
@ -30,7 +32,10 @@ module Affection.Types
import qualified SDL.Init as SDL
import qualified SDL.Video as SDL
import qualified Data.Text as T
import Data.Map
import qualified GEGL as G
import qualified BABL as B
import Control.Monad.IO.Class
import Control.Monad.State
@ -58,6 +63,11 @@ data AffectionConfig us = AffectionConfig
-- ^ Provide your own finisher function to clean your data.
}
-- | Components to initialize in SDL.
data InitComponents
= All
| Only [SDL.InitFlag]
-- | Main type for defining the look, feel and action of the whole application.
data AffectionData us = AffectionData
-- { affectionConfig :: AffectionConfig us -- ^ Application configuration.
@ -65,22 +75,25 @@ data AffectionData us = AffectionData
, userState :: us -- ^ State data provided by user
, drawWindow :: SDL.Window -- ^ SDL window
, drawSurface :: SDL.Surface -- ^ SDL surface
, drawFormat :: B.BablFormatPtr -- ^ Target format
, drawStack :: [DrawRequest] -- ^ Stack of 'DrawRequest's to be processed
, clearStack :: [DrawRequest] -- ^ Stack of 'DrawRequest's to be invalidated
, elapsedTime :: Double -- ^ Elapsed time in seconds
}
-- | This datatype stores information about areas of a 'G.GeglBuffer' to be updated
data DrawRequest = DrawRequest
{ requestNode :: G.GeglNode -- ^ The 'G.GeglNode' to blit
, requestArea :: G.GeglRectangle -- ^ The area to update
{ requestArea :: G.GeglRectangle -- ^ The area to update
, requestBuffer :: G.GeglBuffer -- ^ Buffer to draw
, requestPersist :: Bool -- ^ Shall the drawRequest persist
, requestPersist :: RequestPersist -- ^ Shall the drawRequest persist
}
-- | Components to initialize in SDL.
data InitComponents
= All
| Only [SDL.InitFlag]
data RequestPersist
= Yes
| 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
@ -154,20 +167,37 @@ instance Eq Angle where
-- | A single particle
data Particle = Particle
{ particleLife :: Double
{ particleTimeToLive :: Double
-- ^ Time to live in seconds
, particlePosition :: (Double, Double)
, particleCreation :: Double
-- ^ Creation time of particle in seconds form program start
, particlePosition :: (Double, Double)
-- ^ Position of particle on canvas
, particleRotation :: Angle
, particleRotation :: Angle
-- ^ Particle rotation
, particleVelocity :: (Int, Int)
, particleVelocity :: (Int, Int)
-- ^ particle velocity as vector of pixels per second
, particlePitchRate :: Angle
, particlePitchRate :: Angle
-- ^ Rotational velocity of particle in angle per second
} deriving (Show, Eq)
data ParticleSystem = ParticleSystem
{ psParts :: [Particle]
, psNode :: G.GeglNode
, psBuffer :: G.GeglBuffer
, 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
}
-- | 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
}