affection 0.0.0.1 → 0.0.0.2

raw patch · 8 files changed

+119/−58 lines, 8 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• affection.cabal +1/−1
• examples/example00.hs +2/−2
• examples/example01.hs +2/−2
• examples/example02.hs +5/−5
• examples/example03.hs +4/−4
• src/Affection.hs +71/−19
• src/Affection/Particle.hs +24/−23
• src/Affection/Types.hs +10/−2

@@ -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.

@@ -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

@@ -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

@@ -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 ()

@@ -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 }

@@ -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

@@ -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

@@ -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