better actors

This commit is contained in:
nek0 2017-03-21 12:04:56 +01:00
parent 33ca2220ea
commit 85c6288f50
4 changed files with 74 additions and 21 deletions

View file

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

View file

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

View file

@ -1,12 +1,54 @@
{-# LANGUAGE RecordWildCards #-}
-- | This module implements the Actor, a Datastructure binding a 'G.GeglNode' -- | This module implements the Actor, a Datastructure binding a 'G.GeglNode'
-- to a game asset -- to a game asset
module Affection.Actor module Affection.Actor
( Actor(..) ( Actor(..)
, ActorProperty(..)
, updateProperties
, applyProperties
) where ) where
import qualified GEGL as G 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

View file

@ -33,7 +33,7 @@ import qualified SDL.Init as SDL
import qualified SDL.Video as SDL import qualified SDL.Video as SDL
import qualified SDL.Event as SDL import qualified SDL.Event as SDL
import qualified Data.Text as T import qualified Data.Text as T
import Data.Map import Data.Map.Strict as M
import qualified GEGL as G import qualified GEGL as G
import qualified BABL as B import qualified BABL as B