Merge branch 'buffer-get'
This commit is contained in:
nek0
commit
44fdd2e766
10 changed files with 523 additions and 269 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
120
examples/example04.hs
Normal 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 ()
|
||||
|
|
@ -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 }
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
}
|
||||
|
|
|
|||
Loading…
Reference in a new issue