diff --git a/examples/example04.hs b/examples/example04.hs index a9ff1cb..55a78a9 100644 --- a/examples/example04.hs +++ b/examples/example04.hs @@ -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 diff --git a/src/Affection.hs b/src/Affection.hs index 2152e59..a2266f2 100644 --- a/src/Affection.hs +++ b/src/Affection.hs @@ -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 ) diff --git a/src/Affection/Draw.hs b/src/Affection/Draw.hs index 9a1ac08..c02cd1e 100644 --- a/src/Affection/Draw.hs +++ b/src/Affection/Draw.hs @@ -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) diff --git a/src/Affection/Types.hs b/src/Affection/Types.hs index 63f356c..6cb0c92 100644 --- a/src/Affection/Types.hs +++ b/src/Affection/Types.hs @@ -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