From 97186c5709182bc4b667211c7d1fd70fcdb7cb82 Mon Sep 17 00:00:00 2001 From: nek0 Date: Fri, 17 Feb 2017 17:15:06 +0100 Subject: [PATCH] it works only halfway --- affection.cabal | 11 ++++--- examples/example00.hs | 4 +-- examples/example01.hs | 4 +-- examples/example02.hs | 10 +++---- examples/example03.hs | 8 ++--- src/Affection.hs | 61 +++++++++++++++++++++++++++++++-------- src/Affection/Particle.hs | 47 +++++++++++++++--------------- src/Affection/Types.hs | 12 +++++--- 8 files changed, 101 insertions(+), 56 deletions(-) diff --git a/affection.cabal b/affection.cabal index bb0f82b..dd62652 100644 --- a/affection.cabal +++ b/affection.cabal @@ -6,9 +6,12 @@ name: affection -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.0.0.0 +version: 0.0.0.1 synopsis: A simple Game Engine using SDL -description: See homepage for description. +description: This package contains Affection, a simple game engine + written in Haskell using SDL and GEGL. + This Engine is still work in progress and even minor + version bumps may contain breaking api changes. homepage: https://github.com/nek0/affection#readme license: LGPL-3 license-file: LICENSE @@ -49,7 +52,7 @@ library , UndecidableInstances hs-source-dirs: src default-language: Haskell2010 - ghc-options: -Wall -debug + ghc-options: -Wall -- Other library packages from which modules are imported. build-depends: base >=4.9 && <4.10 , sdl2 @@ -118,7 +121,7 @@ executable example02 executable example03 hs-source-dirs: examples main-is: example03.hs - ghc-options: -threaded -Wall -auto-all -caf-all -rtsopts -debug + ghc-options: -threaded -Wall -auto-all -caf-all -rtsopts default-language: Haskell2010 default-extensions: OverloadedStrings if flag(examples) diff --git a/examples/example00.hs b/examples/example00.hs index f2569af..9d4808f 100644 --- a/examples/example00.hs +++ b/examples/example00.hs @@ -96,8 +96,8 @@ draw = do 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 index d13abd1..10351d9 100644 --- a/examples/example01.hs +++ b/examples/example01.hs @@ -89,8 +89,8 @@ draw = do 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 index b9dd1fb..a884b7f 100644 --- a/examples/example02.hs +++ b/examples/example02.hs @@ -98,14 +98,14 @@ draw = do ) 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 @@ update sec = do } _ -> return () - ) ev + ) evs clean :: UserData -> IO () clean _ = return () diff --git a/examples/example03.hs b/examples/example03.hs index 821fbca..8e4f5ca 100644 --- a/examples/example03.hs +++ b/examples/example03.hs @@ -103,15 +103,15 @@ draw = do -- (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 @@ update sec = do } _ -> 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 index 343e16e..6621f7f 100644 --- a/src/Affection.hs +++ b/src/Affection.hs @@ -28,6 +28,8 @@ 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 @@ -47,21 +49,15 @@ withAffection AffectionConfig{..} = do G.gegl_init execTime <- newMVar =<< getTime Monotonic window <- SDL.createWindow windowTitle windowConfig - oldSurf@(SDL.Surface ptr _) <- SDL.getWindowSurface window - 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 + -- let surface = (flip SDL.Surface Nothing) rawSurfacePtr + (oldSurf, surface) <- getSurfaces window + let bablFormat = B.PixelFormat B.RGBA B.CFu8 format <- B.babl_format bablFormat - SDL.V2 (CInt rw) (CInt rh) <- SDL.surfaceDimensions surface - pixelFormat <- peek . Raw.surfaceFormat =<< peek rawSurfacePtr - let (w, h) = (fromIntegral rw, fromIntegral rh) - stride = fromIntegral (Raw.pixelFormatBytesPerPixel pixelFormat) * w - cpp = B.babl_components_per_pixel bablFormat initContainer <- (\x -> AffectionData { quitEvent = False , userState = x , drawWindow = window + , windowSurface = oldSurf , drawSurface = surface , drawFormat = format , drawStack = [] @@ -81,6 +77,14 @@ withAffection AffectionConfig{..} = do -- get state ad <- get -- clean draw requests from last run + pixels <- SDL.surfacePixels $ drawSurface ad + (SDL.Surface ptr _) <- SDL.getWindowSurface window + rawSurfacePtr <- Raw.convertSurfaceFormat ptr (SDL.toNumber SDL.ABGR8888) 0 + 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 mapM_ (invalidateDrawRequest pixels stride cpp) $ drawStack ad -- compute dt and update elapsedTime let dt = (fromIntegral $ toNanoSecs $ diffTimeSpec lastTime now) / (fromIntegral 10 ^ 9) @@ -88,8 +92,10 @@ withAffection AffectionConfig{..} = do { 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 @@ -99,7 +105,11 @@ withAffection AffectionConfig{..} = do 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 @@ -110,6 +120,33 @@ withAffection AffectionConfig{..} = do 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 + put ad + { windowSurface = oldSurf + , drawSurface = surface + } + -- | Return the userstate to the user getAffection :: Affection us us getAffection = do diff --git a/src/Affection/Particle.hs b/src/Affection/Particle.hs index 075e820..b6b92b0 100644 --- a/src/Affection/Particle.hs +++ b/src/Affection/Particle.hs @@ -39,21 +39,21 @@ updateParticle time funct pa = do 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 @@ updateParticleSystem sys sec upd draw = do 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 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 @@ chronoInsert -> [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 index c197961..5f8bfdb 100644 --- a/src/Affection/Types.hs +++ b/src/Affection/Types.hs @@ -31,6 +31,7 @@ module Affection.Types 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 @@ -55,7 +56,7 @@ data AffectionConfig us = AffectionConfig -- ^ 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,6 +75,7 @@ data AffectionData us = AffectionData { 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 @@ -136,8 +138,10 @@ data RGBA = RGBA -- | Type for defining the draw type of draw functions data DrawType - = Fill -- ^ Fill the specified area completely with color - | Line -- ^ only draw the outline of the area + -- | Fill the specified area completely with color + = Fill + -- | only draw the outline of the area + | Line { lineWidth :: Int -- ^ Width of line in pixels } @@ -187,7 +191,7 @@ data Particle = Particle -- ^ '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