From 85c6288f5050bb6094c461b67f8c2fc194f6898a Mon Sep 17 00:00:00 2001 From: nek0 Date: Tue, 21 Mar 2017 12:04:56 +0100 Subject: [PATCH] better actors --- affection.cabal | 1 + examples/example02.hs | 44 +++++++++++++++++++++++--------------- src/Affection/Actor.hs | 48 +++++++++++++++++++++++++++++++++++++++--- src/Affection/Types.hs | 2 +- 4 files changed, 74 insertions(+), 21 deletions(-) diff --git a/affection.cabal b/affection.cabal index a63cb4d..1ec0293 100644 --- a/affection.cabal +++ b/affection.cabal @@ -119,6 +119,7 @@ executable example02 , babl , containers , mtl + , monad-parallel else buildable: False diff --git a/examples/example02.hs b/examples/example02.hs index 2870f78..633ff55 100644 --- a/examples/example02.hs +++ b/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 - , actors :: M.Map String Actor - , foreground :: G.GeglBuffer - , lastTick :: Double + { nodeGraph :: M.Map String G.GeglNode + , actors :: M.Map String (Actor String) + , foreground :: G.GeglBuffer + , 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 - , actors = actorMap - , foreground = buffer - , lastTick = 0 + { nodeGraph = myMap + , actors = actorMap + , foreground = buffer + , lastTick = 0 + , updateActors = [] } -- drawInit :: Affection UserData () @@ -91,8 +100,11 @@ load _ = do draw :: Affection UserData () draw = do - UserData{..} <- getAffection - mapM_ (\(Actor ps node) -> liftIO $ G.gegl_node_set node $ G.Operation "" ps) actors + ud@UserData{..} <- getAffection + 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 - prop "y" (fromIntegral (y - 10) :: Double) - prop "x" (fromIntegral (x - 10) :: Double) - ) - . actorNode + (updateProperty ("y", G.PropertyDouble (fromIntegral (y - 10))) . + updateProperty ("x", G.PropertyDouble (fromIntegral (x - 10))) ) "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 diff --git a/src/Affection/Actor.hs b/src/Affection/Actor.hs index 2e2a5bf..cd773c6 100644 --- a/src/Affection/Actor.hs +++ b/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 - { actorProperties :: [G.Property] - , actorNode :: G.GeglNode +import qualified Data.Map.Strict as M +import Data.List +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 diff --git a/src/Affection/Types.hs b/src/Affection/Types.hs index a0fad1d..d659cb4 100644 --- a/src/Affection/Types.hs +++ b/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