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
, containers
, mtl
, monad-parallel
else
buildable: False

View file

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

View file

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

View file

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