affection/src/Affection/Actor.hs

{-# LANGUAGE RecordWildCards #-}

-- | This module implements the Actor, a Datastructure binding a 'G.GeglNode'
-- to a game asset
module Affection.Actor
  ( Actor(..)
  , ActorProperty(..)
  , updateProperties
  , applyProperties
  , getProperty
  ) where

import qualified GEGL as G

import qualified Data.Map.Strict as M
import Data.List
import qualified Control.Monad.Parallel as MP

import Affection.Types

data (Show a, Ord a) => Actor a = Actor
  { actorProperties :: [ActorProperty a]
  , actorNodes      :: M.Map a G.GeglNode
  , actorFlange     :: G.GeglNode
  } deriving (Show, Eq)

data (Show a, Ord a) => ActorProperty a = ActorProperty
  { apName    :: String
  , apValue   :: G.PropertyValue
  , apMapping :: Maybe (a, String)
  } deriving (Show, Eq)

updateProperties :: (Show a, 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 :: (Show a, Ord a) => Actor a -> Affection us ()
applyProperties Actor{..} =
  MP.mapM_ (\(ActorProperty{..}) ->
    maybe (return ()) (\m ->
      liftIO $ G.gegl_node_set (actorNodes M.! fst m) $ G.Operation "" $
        (G.Property (snd m) apValue) : []
      ) apMapping
    ) actorProperties

getProperty :: (Show a, Ord a) => String -> Actor a -> Maybe G.PropertyValue
getProperty name act =
  case find (\a -> name == apName a) $ actorProperties act of
    Just p -> Just $ apValue p
    Nothing -> Nothing