it works. what do you want more?

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

View file

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

View file

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

View file

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

View file

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