it works only halfway

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)

examples/example00.hs

@@ -96,8 +96,8 @@ draw = do
   liftIO $ SDL.unlockSurface drawSurface
   liftIO $ SDL.updateWindowSurface drawWindow
 
-update :: Double -> Affection UserData ()
+update :: Double -> [SDL.Event] -> Affection UserData ()
-update sec = do
+update sec _ = do
   traceM "updating"
   ad <- get
   ud@UserData{..} <- getAffection

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 :: Double -> [SDL.Event] -> Affection UserData ()
-update sec = do
+update sec _ = do
   traceM "updating"
   -- liftIO $ delaySec 5
   ad <- get

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 :: Double -> [SDL.Event] -> Affection UserData ()
-update sec = do
+update sec evs = do
   traceM "updating"
   ad <- get
   ud <- getAffection
   traceM $ (show $ 1 / sec) ++ " FPS"
-  ev <- liftIO $ SDL.pollEvent
+  -- ev <- liftIO $ SDL.pollEvent
-  maybe (return ()) (\e ->
+  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 ()

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 :: Double -> [SDL.Event] -> Affection UserData ()
-update sec = do
+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 }

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
+  -- let surface = (flip SDL.Surface Nothing) rawSurfacePtr
-  rawSurfacePtr <- Raw.convertSurfaceFormat ptr (SDL.toNumber SDL.ABGR8888) 0
+  (oldSurf, surface) <- getSurfaces window
-  let surface = (flip SDL.Surface Nothing) rawSurfacePtr
+  let bablFormat = B.PixelFormat B.RGBA B.CFu8
-      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
-  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

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
+    mproducer <- liftIO $ G.gegl_node_get_producer
-    --   (particleStackCont pa)
+      (particleStackCont pa)
-    --   "input"
+      "input"
-    -- case mproducer of
+    case mproducer of
-    --   Just (producer, padname) -> do
+      Just (producer, padname) -> do
-    --     consumers <- liftIO $ G.gegl_node_get_consumers
+        consumers <- liftIO $ G.gegl_node_get_consumers
-    --       (particleStackCont pa)
+          (particleStackCont pa)
-    --       "output"
+          "output"
-    --     liftIO $ mapM_ (\(node, inpad)-> G.gegl_node_connect_to
+        liftIO $ mapM_ (\(node, inpad)-> G.gegl_node_connect_to
-    --       producer
+          producer
-    --       padname
+          padname
-    --       node
+          node
-    --       inpad
+          inpad
-    --       ) consumers
+          ) consumers
-    --   Nothing -> return ()
+      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_many (reverse $ map particleStackCont newList)
-    liftIO $ G.gegl_node_link
+  -- when (not $ isNothing $ partStorLatest $ partSysParts ps) $ 
-      (particleStackCont p)
+  --   liftIO $ G.gegl_node_link
-      (particleStackCont $ fromJust $ partStorLatest $ partSysParts ps)
+  --     (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

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
+    -- | Fill the specified area completely with color
-  | Line     -- ^ only draw the outline of the area
+  = 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