diff --git a/affection.cabal b/affection.cabal --- a/affection.cabal +++ b/affection.cabal @@ -6,7 +6,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.0.0.1 +version: 0.0.0.2 synopsis: A simple Game Engine using SDL description: This package contains Affection, a simple game engine written in Haskell using SDL and GEGL. diff --git a/examples/example00.hs b/examples/example00.hs --- a/examples/example00.hs +++ b/examples/example00.hs @@ -96,8 +96,8 @@ liftIO $ SDL.unlockSurface drawSurface liftIO $ SDL.updateWindowSurface drawWindow -update :: Double -> Affection UserData () -update sec = do +update :: Double -> [SDL.Event] -> Affection UserData () +update sec _ = do traceM "updating" ad <- get ud@UserData{..} <- getAffection diff --git a/examples/example01.hs b/examples/example01.hs --- a/examples/example01.hs +++ b/examples/example01.hs @@ -89,8 +89,8 @@ drawRect (nodeGraph M.! "nop") (G.RGB 1 0 0) Fill (G.GeglRectangle 10 10 500 500) foreground liftIO $ G.gegl_node_process $ nodeGraph M.! "sink" -update :: Double -> AffectionState (AffectionData UserData) IO () -update sec = do +update :: Double -> [SDL.Event] -> Affection UserData () +update sec _ = do traceM "updating" -- liftIO $ delaySec 5 ad <- get diff --git a/examples/example02.hs b/examples/example02.hs --- a/examples/example02.hs +++ b/examples/example02.hs @@ -98,14 +98,14 @@ ) coordinates liftIO $ G.gegl_node_process $ nodeGraph M.! "sink" -update :: Double -> AffectionState (AffectionData UserData) IO () -update sec = do +update :: Double -> [SDL.Event] -> Affection UserData () +update sec evs = do traceM "updating" ad <- get ud <- getAffection traceM $ (show $ 1 / sec) ++ " FPS" - ev <- liftIO $ SDL.pollEvent - maybe (return ()) (\e -> + -- ev <- liftIO $ SDL.pollEvent + mapM_ (\e -> case SDL.eventPayload e of SDL.MouseMotionEvent dat -> do let (SDL.P (SDL.V2 x y)) = SDL.mouseMotionEventPos dat @@ -119,7 +119,7 @@ } _ -> return () - ) ev + ) evs clean :: UserData -> IO () clean _ = return () diff --git a/examples/example03.hs b/examples/example03.hs --- a/examples/example03.hs +++ b/examples/example03.hs @@ -103,15 +103,15 @@ -- (G.GeglRectangle (x - 10) (y - 10) 20 20) -- ) $ coordinates ud -update :: Double -> AffectionState (AffectionData UserData) IO () -update sec = do +update :: Double -> [SDL.Event] -> Affection UserData () +update sec evs = do traceM "updating" ad <- get ud <- getAffection -- let newPart = updateParticles sec partUpd $ particles ud -- putAffection $ ud { particles = newPart } traceM $ (show $ 1 / sec) ++ " FPS" - ev <- liftIO $ SDL.pollEvents + -- ev <- liftIO $ SDL.pollEvents mapM_ (\e -> case SDL.eventPayload e of SDL.MouseMotionEvent dat -> @@ -171,7 +171,7 @@ } _ -> return () - ) ev + ) evs ud2 <- getAffection nps <- updateParticleSystem (partsys ud2) sec partUpd partDraw putAffection $ ud2 { partsys = nps } diff --git a/src/Affection.hs b/src/Affection.hs --- a/src/Affection.hs +++ b/src/Affection.hs @@ -18,16 +18,18 @@ import qualified Data.Text as T import Data.Maybe +import Data.IORef import System.Clock import Control.Monad.Loops import Control.Monad.State -import Control.Concurrent.MVar import Foreign.C.Types (CInt(..)) import Foreign.Storable (peek) +import Debug.Trace + import Affection.Types as A import Affection.Draw as A import Affection.Particle as A @@ -45,31 +47,38 @@ Only is -> SDL.initialize is G.gegl_init - execTime <- newMVar =<< getTime Monotonic + execTime <- newIORef =<< getTime Monotonic window <- SDL.createWindow windowTitle windowConfig - oldSurf@(SDL.Surface ptr _) <- SDL.getWindowSurface window + -- let surface = (flip SDL.Surface Nothing) rawSurfacePtr + (oldSurf, surface) <- getSurfaces window + let (SDL.Surface ptr _) = surface rawSurfacePtr <- Raw.convertSurfaceFormat ptr (SDL.toNumber SDL.ABGR8888) 0 - let surface = (flip SDL.Surface Nothing) rawSurfacePtr - bablFormat = B.PixelFormat B.RGBA B.CFu8 - pixels <- SDL.surfacePixels surface - format <- B.babl_format bablFormat - SDL.V2 (CInt rw) (CInt rh) <- SDL.surfaceDimensions surface - pixelFormat <- peek . Raw.surfaceFormat =<< peek rawSurfacePtr + pixelFormat <- liftIO $ peek . Raw.surfaceFormat =<< peek rawSurfacePtr + SDL.V2 (CInt rw) (CInt rh) <- liftIO $ SDL.surfaceDimensions surface let (w, h) = (fromIntegral rw, fromIntegral rh) - stride = fromIntegral (Raw.pixelFormatBytesPerPixel pixelFormat) * w - cpp = B.babl_components_per_pixel bablFormat + 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 initContainer <- (\x -> AffectionData { quitEvent = False , userState = x , drawWindow = window + , windowSurface = oldSurf , drawSurface = surface , drawFormat = format + , drawPixels = pixels + , drawDimensions = (w, h) + , drawStride = stride + , drawCPP = cpp , drawStack = [] , elapsedTime = 0 }) <$> loadState surface (_, nState) <- runStateT ( A.runState $ do preLoop - liftIO $ SDL.surfaceBlit surface Nothing oldSurf Nothing + pad <- get + liftIO $ SDL.surfaceBlit (drawSurface pad) Nothing (windowSurface pad) Nothing whileM_ (do current <- get return $ not $ A.quitEvent current @@ -77,38 +86,81 @@ (do -- Measure time difference form last run now <- liftIO $ getTime Monotonic - lastTime <- liftIO $ fromMaybe now <$> tryReadMVar execTime + lastTime <- liftIO $ readIORef execTime -- get state ad <- get -- clean draw requests from last run - mapM_ (invalidateDrawRequest pixels stride cpp) $ drawStack ad + mapM_ (invalidateDrawRequest (drawPixels ad) (drawStride ad) (drawCPP ad)) (drawStack ad) -- compute dt and update elapsedTime let dt = (fromIntegral $ toNanoSecs $ diffTimeSpec lastTime now) / (fromIntegral 10 ^ 9) put $ ad { drawStack = [] , elapsedTime = elapsedTime ad + dt } + -- poll events + evs <- preHandleEvents =<< liftIO SDL.pollEvents -- execute user defined update loop - updateLoop dt + updateLoop dt evs -- execute user defined draw loop drawLoop -- handle all new draw requests ad2 <- get - clear <- catMaybes <$> mapM (handleDrawRequest pixels stride cpp) (drawStack ad2) + clear <- catMaybes <$> + mapM (handleDrawRequest (drawPixels ad) (drawStride ad) (drawCPP ad)) (drawStack ad2) -- save all draw requests to clear in next run put $ ad2 { drawStack = clear } -- blit surface and update window - liftIO $ SDL.surfaceBlit surface Nothing oldSurf Nothing + liftIO $ SDL.surfaceBlit + (drawSurface ad2) + Nothing + (windowSurface ad2) + Nothing liftIO $ SDL.updateWindowSurface $ drawWindow ad2 -- save new time - _ <- liftIO $ swapMVar execTime $ now - return () + liftIO $ writeIORef execTime $ now ) ) initContainer G.gegl_exit cleanUp $ userState nState SDL.quit + +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 + return (oldSurf, surface) + +preHandleEvents :: [SDL.Event] -> Affection us [SDL.Event] +preHandleEvents evs = + catMaybes <$> mapM handle evs + where + handle e = + case SDL.eventPayload e of + SDL.WindowMovedEvent _ -> do + liftIO $ traceIO "I was moved" + putNewSurface + return Nothing + _ -> + return $ Just e + putNewSurface = do + ad <- get + (oldSurf, surface) <- liftIO $ getSurfaces $ drawWindow ad + pixels <- SDL.surfacePixels $ surface + SDL.V2 (CInt rw) (CInt rh) <- liftIO $ SDL.surfaceDimensions surface + let (SDL.Surface ptr _) = surface + rawSurfacePtr <- Raw.convertSurfaceFormat ptr (SDL.toNumber SDL.ABGR8888) 0 + pixelFormat <- liftIO $ peek . Raw.surfaceFormat =<< peek rawSurfacePtr + let (w, h) = (fromIntegral rw, fromIntegral rh) + stride = fromIntegral (Raw.pixelFormatBytesPerPixel pixelFormat) * w + put ad + { windowSurface = oldSurf + , drawSurface = surface + , drawPixels = pixels + , drawDimensions = (w, h) + , drawStride = stride + } -- | Return the userstate to the user getAffection :: Affection us us diff --git a/src/Affection/Particle.hs b/src/Affection/Particle.hs --- a/src/Affection/Particle.hs +++ b/src/Affection/Particle.hs @@ -39,21 +39,21 @@ now <- elapsedTime <$> get if particleCreation pa + particleTimeToLive pa < now then do - -- mproducer <- liftIO $ G.gegl_node_get_producer - -- (particleStackCont pa) - -- "input" - -- case mproducer of - -- Just (producer, padname) -> do - -- consumers <- liftIO $ G.gegl_node_get_consumers - -- (particleStackCont pa) - -- "output" - -- liftIO $ mapM_ (\(node, inpad)-> G.gegl_node_connect_to - -- producer - -- padname - -- node - -- inpad - -- ) consumers - -- Nothing -> return () + mproducer <- liftIO $ G.gegl_node_get_producer + (particleStackCont pa) + "input" + case mproducer of + Just (producer, padname) -> do + consumers <- liftIO $ G.gegl_node_get_consumers + (particleStackCont pa) + "output" + liftIO $ mapM_ (\(node, inpad)-> G.gegl_node_connect_to + producer + padname + node + inpad + ) consumers + Nothing -> return () liftIO $ G.gegl_node_drop $ particleRootNode pa return $ Nothing else do @@ -119,9 +119,9 @@ x <- catMaybes <$> mapM (updateParticle sec upd) (partStorList $ partSysParts sys) -- x <- catMaybes <$> foldM (updateParticle sec upd) [] (reverse $ psParts sys) when (not $ null x) $ do - liftIO $ G.gegl_node_link_many $ map particleStackCont (partStorList $ partSysParts sys) + -- liftIO $ G.gegl_node_link_many $ map particleStackCont (partStorList $ partSysParts sys) -- liftIO $ traceIO "linking last node to output" - liftIO $ G.gegl_node_link (particleStackCont $ last x) (partSysNode sys) + liftIO $ G.gegl_node_link (particleStackCont $ head x) (partSysNode sys) mapM_ (draw (partSysBuffer sys) (partSysNode sys)) x return $ sys { partSysParts = (partSysParts sys) @@ -141,10 +141,11 @@ insertParticle ps p = do now <- elapsedTime <$> get let newList = chronoInsert now (partStorList $ partSysParts ps) p - when (not $ isNothing $ partStorLatest $ partSysParts ps) $ - liftIO $ G.gegl_node_link - (particleStackCont p) - (particleStackCont $ fromJust $ partStorLatest $ partSysParts ps) + liftIO $ G.gegl_node_link_many (reverse $ map particleStackCont newList) + -- when (not $ isNothing $ partStorLatest $ partSysParts ps) $ + -- liftIO $ G.gegl_node_link + -- (particleStackCont p) + -- (particleStackCont $ fromJust $ partStorLatest $ partSysParts ps) return $ ps { partSysParts = (partSysParts ps) { partStorLatest = Just p @@ -160,10 +161,10 @@ -> [Particle] -- ^ Resulting list chronoInsert now [] np = [np] chronoInsert now [p] np = - if now + particleTimeToLive p < particleCreation np + if now + particleTimeToLive p < (particleCreation np + particleTimeToLive np) then p : [np] else np : [p] chronoInsert now l@(p:ps) np = - if now + particleTimeToLive p < particleCreation np + if now + particleTimeToLive p < (particleCreation np + particleTimeToLive np) then p : chronoInsert now ps np else np : l diff --git a/src/Affection/Types.hs b/src/Affection/Types.hs --- a/src/Affection/Types.hs +++ b/src/Affection/Types.hs @@ -31,6 +31,7 @@ import qualified SDL.Init as SDL import qualified SDL.Video as SDL +import qualified SDL.Event as SDL import qualified Data.Text as T import Data.Map @@ -43,6 +44,8 @@ -- import Control.Concurrent.MVar +import Foreign.Ptr (Ptr) + -- | Configuration for the aplication. needed at startup. data AffectionConfig us = AffectionConfig { initComponents :: InitComponents @@ -55,7 +58,7 @@ -- ^ Actions to be performed, before loop starts , drawLoop :: Affection us () -- ^ Function for updating graphics. - , updateLoop :: Double -> Affection us () + , updateLoop :: Double -> [SDL.Event] -> Affection us () -- ^ Main update function. Takes fractions of a second as input. , loadState :: SDL.Surface -> IO us -- ^ Provide your own load function to create this data. @@ -74,9 +77,14 @@ { quitEvent :: Bool -- ^ Loop breaker. , userState :: us -- ^ State data provided by user , drawWindow :: SDL.Window -- ^ SDL window + , windowSurface :: SDL.Surface -- ^ Internal surface of window , drawSurface :: SDL.Surface -- ^ SDL surface , drawFormat :: B.BablFormatPtr -- ^ Target format , drawStack :: [DrawRequest] -- ^ Stack of 'DrawRequest's to be processed + , 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 , clearStack :: [DrawRequest] -- ^ Stack of 'DrawRequest's to be invalidated , elapsedTime :: Double -- ^ Elapsed time in seconds } @@ -189,7 +197,7 @@ -- ^ 'G.GeglNode' to connect other 'Particle's to , particleDrawFlange :: G.GeglNode -- ^ 'G.GeglNode' to connect draw actions to - } + } deriving (Eq) -- | The particle system data ParticleSystem = ParticleSystem