it works. what do you want more?
This commit is contained in:
nek0
parent
4c7918d9df
commit
538f5c0f7e
4 changed files with 145 additions and 126 deletions
|
|
@ -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,88 +145,79 @@ 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
|
||||
_ -> xpos
|
||||
)
|
||||
"rect"
|
||||
(actors ud)
|
||||
nmap <- return $ M.adjust
|
||||
(updateProperties $ props $ prop "x" $
|
||||
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"
|
||||
(actors ud)
|
||||
putAffection ud
|
||||
{ actors = nmap
|
||||
, updateActors = (nmap M.! "rect") : updateActors ud
|
||||
}
|
||||
ud2 <- getAffection
|
||||
(G.PropertyDouble xpos2) <-
|
||||
return $ apValue $ fromJust $ L.find (\a -> "x" == apName a) $
|
||||
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
|
||||
if xpos2 - fromIntegral (cameraX ud2) < 50
|
||||
then return $
|
||||
if cameraX ud2 - leg < 0 && code == SDL.KeycodeLeft
|
||||
then cameraX ud2
|
||||
else cameraX ud2 - leg
|
||||
else
|
||||
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
|
||||
putAffection ud
|
||||
{ actors = nmap
|
||||
, updateActors = (nmap M.! "rect") : updateActors ud
|
||||
{ keyDown = Just $ SDL.keysymKeycode $ SDL.keyboardEventKeysym dat
|
||||
}
|
||||
else do
|
||||
(G.PropertyDouble bgPos) <-
|
||||
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
|
||||
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
|
||||
else
|
||||
xpos - 20
|
||||
SDL.KeycodeRight ->
|
||||
if xpos < 40
|
||||
then
|
||||
xpos + 20
|
||||
else
|
||||
xpos
|
||||
_ -> xpos
|
||||
)
|
||||
"rect"
|
||||
nmap
|
||||
else
|
||||
putAffection ud
|
||||
{ actors = nmap2
|
||||
, updateActors = (nmap2 M.! "background") : (nmap2 M.! "rect") : updateActors ud
|
||||
{ keyDown = Nothing
|
||||
}
|
||||
|
||||
handle (SDL.WindowClosedEvent _) = do
|
||||
|
|
|
|||
|
|
@ -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
|
||||
)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -242,7 +269,6 @@ clearArea = G.gegl_buffer_clear
|
|||
-- | Clear the whole drawing area
|
||||
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)
|
||||
ad <- get
|
||||
let (w, h) = drawDimensions ad
|
||||
liftIO $ clearArea buffer (GeglRectangle 0 0 w h)
|
||||
|
|
|
|||
|
|
@ -59,13 +59,13 @@ data AffectionConfig us = AffectionConfig
|
|||
-- ^ size of the texture canvas
|
||||
, preLoop :: Affection us ()
|
||||
-- ^ Actions to be performed, before loop starts
|
||||
, eventLoop :: SDL.EventPayload -> Affection us ()
|
||||
, eventLoop :: SDL.EventPayload -> Affection us ()
|
||||
-- ^ Main update function. Takes fractions of a second as input.
|
||||
, updateLoop :: Double -> Affection us ()
|
||||
-- ^ 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
|
||||
|
|
|
|||
Loading…
Reference in a new issue