diff --git a/examples/example00.hs b/examples/example00.hs index 551c881..844d545 100644 --- a/examples/example00.hs +++ b/examples/example00.hs @@ -106,7 +106,7 @@ update = do ad <- get ud@UserData{..} <- getAffection - sec <- getTick + sec <- getDelta traceM $ (show $ 1 / sec) ++ " FPS" when (elapsedTime ad > 5) $ put $ ad diff --git a/examples/example01.hs b/examples/example01.hs index 3c64519..b2e03a2 100644 --- a/examples/example01.hs +++ b/examples/example01.hs @@ -40,7 +40,7 @@ main = do data UserData = UserData { nodeGraph :: M.Map String G.GeglNode , foreground :: G.GeglBuffer - , lastTick :: Double + -- , lastTick :: Double } load :: SDL.Surface -> IO UserData @@ -82,7 +82,7 @@ load _ = do return $ UserData { nodeGraph = myMap , foreground = buffer - , lastTick = 0 + -- , lastTick = 0 } draw :: Affection UserData () @@ -96,13 +96,13 @@ update :: Affection UserData () update = do traceM "updating" ud <- getAffection - let last = lastTick ud - tick <- getTick - putAffection $ ud { lastTick = tick } - let dt = tick - last + -- let last = lastTick ud + -- tick <- getTick + -- putAffection $ ud { lastTick = tick } + dt <- getDelta traceM $ (show $ 1 / dt) ++ " FPS" - - when (tick > 20) $ + elapsed <- getElapsedTime + when (elapsed > 20) $ quit clean :: UserData -> IO () diff --git a/examples/example02.hs b/examples/example02.hs index 4d58f06..2870f78 100644 --- a/examples/example02.hs +++ b/examples/example02.hs @@ -10,7 +10,7 @@ import Debug.Trace main :: IO () main = do - conf <- return $ AffectionConfig + conf <- return AffectionConfig { initComponents = All , windowTitle = "Affection: example00" , windowConfig = SDL.defaultWindow @@ -77,7 +77,7 @@ load _ = do actorMap <- return $ M.fromList [ ("rect", rectActor) ] - return $ UserData + return UserData { nodeGraph = myMap , actors = actorMap , foreground = buffer @@ -100,13 +100,13 @@ update :: Affection UserData () update = do traceM "updating" - tick <- getTick + tick <- getElapsedTime 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 () handle (SDL.MouseMotionEvent dat) = do @@ -114,11 +114,11 @@ handle (SDL.MouseMotionEvent dat) = do ud <- getAffection nmap <- return $ M.adjust - (\a -> Actor (props $ do + (Actor (props $ do prop "y" (fromIntegral (y - 10) :: Double) prop "x" (fromIntegral (x - 10) :: Double) ) - (actorNode a) + . actorNode ) "rect" (actors ud) diff --git a/examples/example03.hs b/examples/example03.hs index 75dcccd..2c633fb 100644 --- a/examples/example03.hs +++ b/examples/example03.hs @@ -42,10 +42,14 @@ load _ = 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 - ] + rect <- G.gegl_node_new_child root $ G.Operation "gegl:rectangle" $ + props $ do + prop "x" (0 :: Double) + prop "y" (0 :: Double) + prop "width" (800 :: Double) + prop "height" (600 :: Double) + prop "color" $ G.RGB 0 0 0 + traceM "rect" traceM "checkerboard" over <- G.gegl_node_new_child root G.defaultOverOperation traceM "over" @@ -62,13 +66,12 @@ load _ = do , G.Property "height" $ G.PropertyDouble 600 ] traceM "crop" - G.gegl_node_link_many [checkerboard, over, crop, sink] + G.gegl_node_link_many [rect, 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) , ("sink" , sink) , ("nop" , nop) , ("crop" , crop) @@ -81,29 +84,21 @@ load _ = do } drawInit :: Affection UserData () -drawInit = do - UserData{..} <- getAffection - present (GeglRectangle 0 0 800 600) foreground True +drawInit = return () +-- drawInit = do +-- UserData{..} <- getAffection +-- present (GeglRectangle 0 0 800 600) foreground True draw :: Affection UserData () draw = do traceM "drawing" UserData{..} <- getAffection + drawParticleSystem partsys partDraw process $ nodeGraph M.! "sink" - -- ad <- get - -- ud <- getAffection - -- drawParticles partDraw $ particles ud - -- SDL.V2 (CInt rw) (CInt rh) <- SDL.surfaceDimensions $ drawSurface ad - -- let (w, h) = (fromIntegral rw, fromIntegral rh) - -- liftIO $ clearArea (foreground ud) (GeglRectangle 0 0 w h) - -- maybe (return ()) (\(x, y) -> - -- drawRect - -- (foreground ud) - -- (nodeGraph ud M.! "over") - -- (G.RGBA 1 0 0 0.5) - -- (Line 7) - -- (G.GeglRectangle (x - 10) (y - 10) 20 20) - -- ) $ coordinates ud + present + (G.GeglRectangle 0 0 800 600) + foreground + True update :: Affection UserData () update = do @@ -111,66 +106,61 @@ update = do ad <- get ud <- getAffection delta <- getDelta - -- let newPart = updateParticles delta partUpd $ particles ud - -- putAffection $ ud { particles = newPart } traceM $ (show $ 1 / delta) ++ " FPS" - -- ev <- liftIO $ SDL.pollEvents ud2 <- getAffection - !nps <- updateParticleSystem (partsys ud2) delta partUpd partDraw + !nps <- updateParticleSystem (partsys ud2) delta partUpd putAffection $ ud2 { partsys = nps } handle (SDL.MouseMotionEvent dat) = - if SDL.ButtonLeft `elem` SDL.mouseMotionEventState dat - then do - ad <- get - ud <- getAffection - let (SDL.P (SDL.V2 x y)) = SDL.mouseMotionEventPos dat - 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 - { partsys = ips - } - -- when (not $ null $ psParts $ partsys ud) $ - -- liftIO $ G.gegl_node_link - -- tempOver - -- (particleStackCont $ head $ psParts $ partsys ud) - else - return () + when (SDL.ButtonLeft `elem` SDL.mouseMotionEventState dat) + $ do + ad <- get + ud <- getAffection + let (SDL.P (SDL.V2 x y)) = SDL.mouseMotionEventPos dat + 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 + { partsys = ips + } + -- when (not $ null $ psParts $ partsys ud) $ + -- liftIO $ G.gegl_node_link + -- tempOver + -- (particleStackCont $ head $ psParts $ partsys ud) handle (SDL.WindowClosedEvent _) = do traceM "seeya!" @@ -180,7 +170,8 @@ handle _ = return () clean :: UserData -> IO () -clean _ = return () +clean ud = do + G.gegl_node_drop (nodeGraph ud M.! "root") partUpd :: Double -> Particle -> Affection UserData Particle partUpd sec p = do diff --git a/src/Affection.hs b/src/Affection.hs index b18bd48..dc82f06 100644 --- a/src/Affection.hs +++ b/src/Affection.hs @@ -9,7 +9,7 @@ module Affection , delaySec , get , put - , getTick + , getElapsedTime , getDelta , quit , module A @@ -81,8 +81,8 @@ withAffection AffectionConfig{..} = do pixelFormat <- liftIO $ peek . Raw.surfaceFormat =<< peek ptr SDL.V2 (CInt rw) (CInt rh) <- liftIO $ SDL.surfaceDimensions surface let (w, h) = (fromIntegral rw, fromIntegral rh) - stride = (fromIntegral $ Raw.pixelFormatBytesPerPixel pixelFormat) * w - pixels <- SDL.surfacePixels $ surface + stride = fromIntegral (Raw.pixelFormatBytesPerPixel pixelFormat) * w + pixels <- SDL.surfacePixels surface let bablFormat = B.PixelFormat B.RGBA B.CFu8 cpp = B.babl_components_per_pixel bablFormat format <- B.babl_format bablFormat @@ -116,9 +116,9 @@ withAffection AffectionConfig{..} = do -- clean draw requests from last run mapM_ (invalidateDrawRequest (drawPixels ad) (drawStride ad) (drawCPP ad)) (drawStack ad) -- clean the renderer form last time - SDL.clear renderer + -- SDL.clear renderer -- compute dt and update elapsedTime - let !dt = (fromIntegral $ toNanoSecs $ diffTimeSpec lastTime now) / (fromIntegral 10 ^ 9) + let !dt = fromIntegral (toNanoSecs $ diffTimeSpec lastTime now) / (10 ^ 9) !ne = elapsedTime ad + dt put $ ad { drawStack = [] @@ -147,7 +147,7 @@ withAffection AffectionConfig{..} = do -- clean the texture SDL.destroyTexture texture -- save new time - liftIO $ writeIORef execTime $ now + liftIO $ writeIORef execTime now ) ) initContainer G.gegl_exit @@ -159,7 +159,7 @@ getSurfaces :: SDL.Window -> IO (SDL.Surface, SDL.Surface) getSurfaces window = do oldSurf@(SDL.Surface ptr _) <- SDL.getWindowSurface window rawSurfacePtr <- Raw.convertSurfaceFormat ptr (SDL.toNumber SDL.ABGR8888) 0 - let surface = (flip SDL.Surface Nothing) rawSurfacePtr + let surface = SDL.Surface rawSurfacePtr Nothing return (oldSurf, surface) -- Prehandle SDL events in case any window events occur @@ -198,8 +198,8 @@ delaySec delaySec dur = SDL.delay (fromIntegral $ dur * 1000) -- | Get time since start but always the same in the current tick. -getTick :: Affection us Double -getTick = +getElapsedTime :: Affection us Double +getElapsedTime = elapsedTime <$> get getDelta :: Affection us Double diff --git a/src/Affection/Draw.hs b/src/Affection/Draw.hs index 7618d14..20620b6 100644 --- a/src/Affection/Draw.hs +++ b/src/Affection/Draw.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RecordWildCards, BangPatterns #-} +{-# LANGUAGE RecordWildCards #-} -- | Module for drawing primitives module Affection.Draw @@ -40,7 +40,7 @@ drawRect -> Affection us () drawRect node color Fill rect@GeglRectangle{..} buf = do ad <- get - tempRoot <- liftIO $ G.gegl_node_new + 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 @@ -51,7 +51,7 @@ drawRect node color Fill rect@GeglRectangle{..} buf = do diw <- liftIO $ G.gegl_node_connect_to opNode "output" node "input" unless diw $ error "Affection.Draw.drawRect: connect failed" put $ ad - { 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 @@ -64,7 +64,7 @@ present rect buf kill = do ad <- get let k = if not kill then Kill Nothing else Persist put ad - { drawStack = (DrawRequest rect buf k) : drawStack ad + { drawStack = DrawRequest rect buf k : drawStack ad } process @@ -106,20 +106,9 @@ handleDrawRequest pixels stride cpp dr@DrawRequest{..} = do let surf = drawSurface ad mrealRect <- liftIO $ G.gegl_rectangle_intersect requestArea - (G.GeglRectangle 0 0 (fst $ drawDimensions ad) (snd $ drawDimensions ad)) - maybe (return()) (\realRect -> do - liftIO $ SDL.lockSurface surf - 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 surf - -- liftIO $ SDL.updateWindowSurface $ drawWindow ad + (uncurry (G.GeglRectangle 0 0) (drawDimensions ad)) + maybe (return()) (\realRect -> + putToSurface pixels realRect stride cpp dr ) mrealRect case requestPersist of Persist -> @@ -139,21 +128,10 @@ invalidateDrawRequest pixels stride cpp dr@DrawRequest{..} = do ad <- get mrealRect <- liftIO $ G.gegl_rectangle_intersect requestArea - (G.GeglRectangle 0 0 (fst $ drawDimensions ad) (snd $ drawDimensions ad)) + (uncurry (G.GeglRectangle 0 0) (drawDimensions ad)) maybe (return()) (\realRect -> do - let surf = drawSurface ad liftIO $ clearArea requestBuffer realRect - liftIO $ SDL.lockSurface surf - 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 surf + putToSurface pixels realRect stride cpp dr ) mrealRect case requestPersist of Kill (Just victim) -> @@ -177,7 +155,7 @@ colorize (rr, rg, rb, ra) col = G.RGB r g b -> (r, g, b) ca = case col of G.RGBA _ _ _ a -> a - G.RGB _ _ _ -> 1 + G.RGB{} -> 1 alpha = ca dst_a = ba da = alpha + dst_a * (1 - alpha) @@ -189,7 +167,7 @@ colorize (rr, rg, rb, ra) col = ( G.CVdouble $ CDouble $ red / da , G.CVdouble $ CDouble $ gre / da , G.CVdouble $ CDouble $ blu / da - , G.CVdouble $ CDouble $ ca + , G.CVdouble $ CDouble ca ) unsafeColorize col = @@ -199,12 +177,12 @@ unsafeColorize col = G.RGB cr cg cb -> (cr, cg, cb) a = case col of G.RGBA _ _ _ ca -> ca - G.RGB _ _ _ -> 1 + G.RGB{} -> 1 in - ( G.CVdouble $ CDouble $ r - , G.CVdouble $ CDouble $ g - , G.CVdouble $ CDouble $ b - , G.CVdouble $ CDouble $ a + ( G.CVdouble $ CDouble r + , G.CVdouble $ CDouble g + , G.CVdouble $ CDouble b + , G.CVdouble $ CDouble a ) -- | Clear a specified area of a buffer from all data diff --git a/src/Affection/Property.hs b/src/Affection/Property.hs index 1caa42c..78e209f 100644 --- a/src/Affection/Property.hs +++ b/src/Affection/Property.hs @@ -1,7 +1,7 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} module Affection.Property - ( Props(..) + ( Props , prop , props ) where @@ -20,7 +20,7 @@ props = flip execState [] prop :: IsPropertyValue v => String -> v -> Props () prop k v = do ps <- get - put $ (G.Property k (toPropertyValue v)) : ps + put $ G.Property k (toPropertyValue v) : ps class IsPropertyValue v where toPropertyValue :: v -> G.PropertyValue