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

it works. what do you want more?

Browse source
This commit is contained in:
nek0 2017-03-23 04:34:04 +01:00
parent 4c7918d9df
commit 538f5c0f7e
4 changed files with 145 additions and 126 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

129
examples/example04.hs
View file

@ -10,6 +10,8 @@ import Data.Maybe (fromJust)
import Control.Monad (when)
import qualified Control.Monad.Parallel as MP
import Foreign.C.Types
import Debug.Trace
main :: IO ()
@ -32,8 +34,9 @@ data UserData = UserData
{ nodeGraph :: M.Map String G.GeglNode
, actors :: M.Map String (Actor String)
, foreground :: G.GeglBuffer
, lastTick :: Double
, updateActors :: [Actor String]
, keyDown :: Maybe SDL.Keycode
, cameraX :: Int
}
load :: IO UserData
@ -56,7 +59,7 @@ load = do
traceM "background"
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.gegl_buffer_new (Just $ G.GeglRectangle 0 0 3289 600) =<<
B.babl_format (B.PixelFormat B.RGBA B.CFfloat)
sink <- G.gegl_node_new_child root $ G.Operation "gegl:copy-buffer" $
props $
@ -72,8 +75,8 @@ load = do
traceM "rect"
crop <- G.gegl_node_new_child root $ G.Operation "gegl:crop" $
props $ do
prop "width" (800::Double)
prop "height" (600::Double)
prop "width" (3289 :: Double)
prop "height" (600 :: Double)
G.gegl_node_link_many [bg, bgTrans, bgScale, over, crop, sink]
_ <- G.gegl_node_connect_to rect "output" over "aux"
rectActor <- return $ Actor (map
@ -122,14 +125,17 @@ load = do
{ nodeGraph = myMap
, actors = actorMap
, foreground = buffer
, lastTick = 0
, updateActors = []
, keyDown = Nothing
, cameraX = 0
}
-- drawInit :: Affection UserData ()
-- drawInit = do
-- UserData{..} <- getAffection
-- present (GeglRectangle 0 0 800 600) foreground True
drawInit :: Affection UserData ()
drawInit = do
ad <- get
ud <- getAffection
process (nodeGraph ud M.! "sink")
present (GeglRectangle 0 0 3289 600) (foreground ud) True
draw :: Affection UserData ()
draw = do
@ -139,34 +145,36 @@ draw = do
{ updateActors = []
}
process (nodeGraph M.! "sink")
present (GeglRectangle 0 0 800 600) foreground True
present (GeglRectangle cameraX 0 800 600) foreground True
render
(Just $ G.GeglRectangle cameraX 0 800 600)
Nothing
update :: Affection UserData ()
update = do
update :: Double -> Affection UserData ()
update dt = do
traceM "updating"
tick <- getElapsedTime
ud <- getAffection
putAffection $ ud { lastTick = tick }
let dt = tick - lastTick ud
return ()
traceM $ show (1 / dt) ++ " FPS"
handle :: SDL.EventPayload -> Affection UserData ()
handle (SDL.KeyboardEvent dat) =
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $ do
ud <- getAffection
maybe (return ()) (\code -> do
let vel = 400 -- velocity in Pixels per second
leg = floor (vel * dt)
(G.PropertyDouble xpos) <-
return $ apValue $ fromJust $ L.find (\a -> "x" == apName a) $
actorProperties $ actors ud M.! "rect"
if xpos >= 40 && xpos <= 760
then do
nmap <- return $ M.adjust
(updateProperties $ props $ prop "x" $
case SDL.keysymKeycode $ SDL.keyboardEventKeysym dat of
SDL.KeycodeLeft -> xpos - 20
SDL.KeycodeRight -> xpos + 20
case code of
SDL.KeycodeLeft ->
if xpos > 0
then xpos - fromIntegral leg
else xpos
SDL.KeycodeRight ->
if xpos < 3269
then xpos + fromIntegral leg
else xpos
_ -> xpos
)
"rect"
@ -175,52 +183,41 @@ handle (SDL.KeyboardEvent dat) =
{ actors = nmap
, updateActors = (nmap M.! "rect") : updateActors ud
}
else do
(G.PropertyDouble bgPos) <-
ud2 <- getAffection
(G.PropertyDouble xpos2) <-
return $ apValue $ fromJust $ L.find (\a -> "x" == apName a) $
actorProperties $ actors ud M.! "background"
nmap <- return $ M.adjust
(updateProperties $ props $ prop "x" $
if xpos < 40
then
case SDL.keysymKeycode $ SDL.keyboardEventKeysym dat of
SDL.KeycodeLeft ->
if bgPos <= 0 then bgPos + 20 else bgPos
SDL.KeycodeRight ->
bgPos
_ -> bgPos
actorProperties $ actors ud M.! "rect"
ncx <-
if xpos2 - fromIntegral (cameraX ud2) > 750
then return $
if cameraX ud2 + leg > 2489 && code == SDL.KeycodeRight
then cameraX ud2
else cameraX ud2 + leg
else
case SDL.keysymKeycode $ SDL.keyboardEventKeysym dat of
SDL.KeycodeLeft ->
bgPos
SDL.KeycodeRight ->
if bgPos >= -2489 then bgPos - 20 else bgPos
_ -> bgPos
)
"background"
(actors ud)
nmap2 <- return $ M.adjust
(updateProperties $ props $ prop "x" $
case SDL.keysymKeycode $ SDL.keyboardEventKeysym dat of
SDL.KeycodeLeft ->
if xpos < 40
then
xpos
if xpos2 - fromIntegral (cameraX ud2) < 50
then return $
if cameraX ud2 - leg < 0 && code == SDL.KeycodeLeft
then cameraX ud2
else cameraX ud2 - leg
else
xpos - 20
SDL.KeycodeRight ->
if xpos < 40
return $ cameraX ud2
putAffection ud2
{ cameraX = ncx
}
) (keyDown ud)
handle :: SDL.EventPayload -> Affection UserData ()
handle (SDL.KeyboardEvent dat) =
when (not (SDL.keyboardEventRepeat dat)) $ do
ud <- getAffection
if (SDL.keyboardEventKeyMotion dat == SDL.Pressed)
then
xpos + 20
else
xpos
_ -> xpos
)
"rect"
nmap
putAffection ud
{ actors = nmap2
, updateActors = (nmap2 M.! "background") : (nmap2 M.! "rect") : updateActors ud
{ keyDown = Just $ SDL.keysymKeycode $ SDL.keyboardEventKeysym dat
}
else
putAffection ud
{ keyDown = Nothing
}
handle (SDL.WindowClosedEvent _) = do

14
src/Affection.hs
View file

@ -114,7 +114,7 @@ withAffection AffectionConfig{..} = do
, drawStack = []
, elapsedTime = 0
, dt = 0
}) <$> loadState surface
}) <$> loadState
(_, nState) <- runStateT ( A.runState $ do
preLoop
whileM_ (do
@ -128,7 +128,7 @@ withAffection AffectionConfig{..} = do
-- get state
ad <- get
-- clean draw requests from last run
mapM_ (invalidateDrawRequest (drawPixels ad) (drawStride ad) (drawCPP ad)) (drawStack ad)
mapM_ (invalidateDrawRequest (drawStride ad) (drawCPP ad)) (drawStack ad)
-- clean the renderer form last time
-- SDL.clear renderer
-- compute dt and update elapsedTime
@ -143,23 +143,19 @@ withAffection AffectionConfig{..} = do
evs <- preHandleEvents =<< liftIO SDL.pollEvents
MP.mapM_ eventLoop evs
-- execute user defined update loop
updateLoop
updateLoop dt
-- execute user defined draw loop
drawLoop
-- handle all new draw requests
ad2 <- get
clear <- catMaybes <$>
mapM (handleDrawRequest (drawPixels ad) (drawStride ad) (drawCPP ad)) (drawStack ad2)
mapM (handleDrawRequest (drawStride ad) (drawCPP ad)) (drawStack ad2)
-- save all draw requests to clear in next run
put $ ad2
{ drawStack = clear }
-- get texture from surface
-- texture <- SDL.createTextureFromSurface (windowRenderer ad2) (drawSurface ad2)
-- actual drawing
SDL.copy (windowRenderer ad2) texture Nothing Nothing
-- SDL.copy (windowRenderer ad2) texture Nothing Nothing
SDL.present (windowRenderer ad2)
-- clean the texture
-- SDL.destroyTexture texture
-- save new time
liftIO $ writeIORef execTime now
)

94
src/Affection/Draw.hs
View file

@ -6,8 +6,9 @@ module Affection.Draw
, clear
, handleDrawRequest
, invalidateDrawRequest
, present
, process
, present
, render
, clearArea
) where
@ -56,7 +57,13 @@ drawRect node color Fill rect@GeglRectangle{..} buf = do
{ drawStack = DrawRequest rect buf (Kill (Just tempRoot)) : drawStack ad
}
-- | Force update of a specific region on screen
-- | Process a node graph
process
:: G.GeglNode
-> Affection us ()
process = liftIO . G.gegl_node_process
-- | Update of a specific region on the texture
present
:: G.GeglRectangle -- ^ Area to be updated
-> G.GeglBuffer -- ^ Target buffer
@ -69,31 +76,51 @@ present rect buf kill = do
{ drawStack = DrawRequest rect buf k : drawStack ad
}
process
:: G.GeglNode
-- | Render the Texture or a clipping thereof. The clipping will be stretched
-- to fit the render target.
render
:: Maybe G.GeglRectangle
-- ^ Area of the texture to render.
-- Pass 'Nothing' to render the whole texture.
-> Maybe G.GeglRectangle
-- ^ Area of render target to draw to.
-- Pass 'Nothing' to render to the whole render target.
-> Affection us ()
process = liftIO . G.gegl_node_process
render msrc mtgt =
do
AffectionData{..} <- get
SDL.copy
windowRenderer
drawTexture
src
tgt
where
toSdlRect (G.GeglRectangle x y w h) = SDL.Rectangle
(SDL.P $ SDL.V2 (CInt $ fromIntegral x) (CInt $ fromIntegral y))
(SDL.V2 (CInt $ fromIntegral w) (CInt $ fromIntegral h))
src = maybe Nothing (Just . toSdlRect) msrc
tgt = maybe Nothing (Just . toSdlRect) mtgt
putToSurface
:: Ptr a
-> G.GeglRectangle
-> Int
-> Int
-> DrawRequest
-> Affection us ()
putToSurface pixels realRect stride cpp DrawRequest{..} = do
ad <- get
liftIO $ SDL.lockSurface $ drawSurface ad
liftIO $ G.gegl_buffer_get
requestBuffer
(Just realRect)
1
(Just $ drawFormat ad)
(pixels `plusPtr`
(rectangleX realRect * cpp + rectangleY realRect * stride))
stride
G.GeglAbyssNone
liftIO $ SDL.unlockSurface $ drawSurface ad
-- putToSurface
-- :: Ptr a
-- -> G.GeglRectangle
-- -> Int
-- -> Int
-- -> DrawRequest
-- -> Affection us ()
-- putToSurface pixels realRect stride cpp DrawRequest{..} = do
-- ad <- get
-- liftIO $ SDL.lockSurface $ drawSurface ad
-- liftIO $ G.gegl_buffer_get
-- requestBuffer
-- (Just realRect)
-- 1
-- (Just $ drawFormat ad)
-- (pixels `plusPtr`
-- (rectangleX realRect * cpp + rectangleY realRect * stride))
-- stride
-- G.GeglAbyssNone
-- liftIO $ SDL.unlockSurface $ drawSurface ad
putToTexture
:: G.GeglRectangle
@ -140,15 +167,15 @@ putToTexture realRect stride cpp DrawRequest{..} = do
-- | function for handling 'DrawRequest's and updating the output
handleDrawRequest
:: Ptr a -- ^ Pixel buffer to blit to
-- :: Ptr a -- ^ Pixel buffer to blit to
-- -> B.BablFormatPtr -- ^ format to blit in
-> Int -- ^ Stride
:: Int -- ^ Stride
-> Int -- ^ Components per Pixel
-> DrawRequest -- ^ 'DrawRequest' to handle
-> Affection us (Maybe DrawRequest)
handleDrawRequest pixels stride cpp dr@DrawRequest{..} = do
handleDrawRequest stride cpp dr@DrawRequest{..} = do
ad <- get
let surf = drawSurface ad
-- let surf = drawSurface ad
mrealRect <- liftIO $ G.gegl_rectangle_intersect
requestArea
(uncurry (G.GeglRectangle 0 0) (drawDimensions ad))
@ -164,13 +191,13 @@ handleDrawRequest pixels stride cpp dr@DrawRequest{..} = do
-- | clear a previously drawn area
invalidateDrawRequest
:: Ptr a -- ^ Pixel buffer to blit to
-- :: Ptr a -- ^ Pixel buffer to blit to
-- -> B.BablFormatPtr -- ^ format to blit in
-> Int -- ^ Stride
:: Int -- ^ Stride
-> Int -- ^ Components per Pixel
-> DrawRequest -- ^ Drawrequest to invalidate
-> Affection us ()
invalidateDrawRequest pixels stride cpp dr@DrawRequest{..} = do
invalidateDrawRequest stride cpp dr@DrawRequest{..} = do
ad <- get
mrealRect <- liftIO $ G.gegl_rectangle_intersect
requestArea
@ -243,6 +270,5 @@ clearArea = G.gegl_buffer_clear
clear :: G.GeglBuffer -> Affection us ()
clear buffer = do
ad <- get
SDL.V2 (CInt rw) (CInt rh) <- SDL.surfaceDimensions $ drawSurface ad
let (w, h) = (fromIntegral rw, fromIntegral rh)
let (w, h) = drawDimensions ad
liftIO $ clearArea buffer (GeglRectangle 0 0 w h)

6
src/Affection/Types.hs
View file

@ -65,7 +65,7 @@ data AffectionConfig us = AffectionConfig
-- ^ Main update function. Takes fractions of a second as input.
, drawLoop :: Affection us ()
-- ^ Function for updating graphics.
, loadState :: SDL.Surface -> IO us
, loadState :: IO us
-- ^ Provide your own load function to create this data.
, cleanUp :: us -> IO ()
-- ^ Provide your own finisher function to clean your data.
@ -83,11 +83,11 @@ data AffectionData us = AffectionData
, userState :: us -- ^ State data provided by user
, drawWindow :: SDL.Window -- ^ SDL window
, windowRenderer :: SDL.Renderer -- ^ Internal renderer of window
, drawSurface :: SDL.Surface -- ^ SDL surface
-- , drawSurface :: SDL.Surface -- ^ SDL surface
, drawTexture :: SDL.Texture -- ^ SDL Texture to draw to
, drawFormat :: B.BablFormatPtr -- ^ Target format
, drawStack :: [DrawRequest] -- ^ Stack of 'DrawRequest's to be processed
, drawPixels :: Ptr () -- ^ Destination Pixel buffer
-- , drawPixels :: Ptr () -- ^ Destination Pixel buffer
, drawDimensions :: (Int, Int) -- ^ Dimensions of target surface
, drawStride :: Int -- ^ Stride of target buffer
, drawCPP :: Int -- ^ Number of components per pixel