better actors

affection.cabal

@@ -119,6 +119,7 @@ executable example02
                      , babl
                      , containers
                      , mtl
+                     , monad-parallel
   else
     buildable:       False
 

examples/example02.hs

@@ -5,6 +5,7 @@ import qualified SDL
 import qualified GEGL as G
 import qualified BABL as B
 import qualified Data.Map.Strict as M
+import qualified Control.Monad.Parallel as MP
 
 import Debug.Trace
 
@@ -24,10 +25,11 @@ main = do
   withAffection conf
 
 data UserData = UserData
-  { nodeGraph   :: M.Map String G.GeglNode
+  { nodeGraph    :: M.Map String G.GeglNode
-  , actors      :: M.Map String Actor
+  , actors       :: M.Map String (Actor String)
-  , foreground  :: G.GeglBuffer
+  , foreground   :: G.GeglBuffer
-  , lastTick    :: Double
+  , lastTick     :: Double
+  , updateActors :: [Actor String]
   }
 
 load :: SDL.Surface -> IO UserData
@@ -63,7 +65,13 @@ load _ = do
       prop "height" (600::Double)
   G.gegl_node_link_many [checkerboard, over, crop, sink]
   _ <- G.gegl_node_connect_to rect "output" over "aux"
-  let rectActor = Actor rectProps rect
+  rectActor <- return $ Actor (map
+    (\p -> ActorProperty
+      (G.propertyName p)
+      (G.propertyValue p)
+      (Just "rect")
+      )rectProps
+    ) (M.singleton "rect" rect)
   traceM "connections made"
   myMap <- return $ M.fromList
     [ ("root"        , root)
@@ -78,10 +86,11 @@ load _ = do
     [ ("rect", rectActor)
     ]
   return UserData
-    { nodeGraph = myMap
+    { nodeGraph    = myMap
-    , actors    = actorMap
+    , actors       = actorMap
-    , foreground = buffer
+    , foreground   = buffer
-    , lastTick = 0
+    , lastTick     = 0
+    , updateActors = []
     }
 
 -- drawInit :: Affection UserData ()
@@ -91,8 +100,11 @@ load _ = do
 
 draw :: Affection UserData ()
 draw = do
-  UserData{..} <- getAffection
+  ud@UserData{..} <- getAffection
-  mapM_ (\(Actor ps node) -> liftIO $ G.gegl_node_set node $ G.Operation "" ps) actors
+  MP.mapM_ applyProperties updateActors
+  putAffection ud
+    { updateActors = []
+    }
   process (nodeGraph M.! "sink")
   present (GeglRectangle 0 0 800 600) foreground True
 
@@ -114,16 +126,14 @@ handle (SDL.MouseMotionEvent dat) = do
   ud <- getAffection
   
   nmap <- return $ M.adjust
-    (Actor (props $ do
+    (updateProperty ("y", G.PropertyDouble (fromIntegral (y - 10))) .
-      prop "y" (fromIntegral (y - 10) :: Double)
+      updateProperty ("x", G.PropertyDouble (fromIntegral (x - 10)))
-      prop "x" (fromIntegral (x - 10) :: Double)
-      )
-      . actorNode
       )
     "rect"
     (actors ud)
   putAffection ud
-    { actors = nmap
+    { actors       = nmap
+    , updateActors = (actors ud M.! "rect") : []
     }
   -- liftIO $ G.gegl_node_set (nodeGraph ud M.! "rect") $ G.Operation "" $
   --   props $ do

src/Affection/Actor.hs

@@ -1,12 +1,54 @@
+{-# LANGUAGE RecordWildCards #-}
+
 -- | This module implements the Actor, a Datastructure binding a 'G.GeglNode'
 -- to a game asset
 module Affection.Actor
  ( Actor(..)
+ , ActorProperty(..)
+ , updateProperties
+ , applyProperties
  ) where
 
 import qualified GEGL as G
 
-data Actor = Actor
+import qualified Data.Map.Strict as M
-  { actorProperties :: [G.Property]
+import Data.List
-  , actorNode       :: G.GeglNode
+import qualified Control.Monad.Parallel as MP
+
+import Affection.Types
+
+data Ord a => Actor a = Actor
+  { actorProperties :: [ActorProperty a]
+  , actorNodes      :: M.Map a G.GeglNode
   }
+
+data Ord a => ActorProperty a = ActorProperty
+  { apName    :: String
+  , apValue   :: G.PropertyValue
+  , apMapping :: Maybe a
+  }
+
+updateProperties :: Ord a => [G.Property] -> Actor a -> Actor a
+updateProperties ps act@Actor{..} =
+  act
+    { actorProperties =
+        foldl (\acc (G.Property name val) -> newProp name val acc) actorProperties ps
+    }
+  where
+    newProp name val acc = nubBy (\a b -> apName a == apName b) $ (getProp name)
+      { apValue = val
+      } : acc
+    getProp n = getProp' n actorProperties
+    getProp' n []     = error $ "no ActorProperty found: " ++ n
+    getProp' n (p:ps)
+      | apName p == n = p
+      | otherwise     = getProp' n ps
+
+applyProperties :: Ord a => Actor a -> Affection us ()
+applyProperties Actor{..} =
+  MP.mapM_ (\(ActorProperty{..}) ->
+    maybe (return ()) (\m ->
+      liftIO $ G.gegl_node_set (actorNodes M.! m) $ G.Operation "" $
+        (G.Property apName apValue) : []
+      ) apMapping
+    ) actorProperties

src/Affection/Types.hs

@@ -33,7 +33,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
+import Data.Map.Strict as M
 
 import qualified GEGL as G
 import qualified BABL as B