module Data.Teams.Graph
(
Vertex (..)
, Time , Variable (..) , Factor (..) , Node
, Edge , EdgeType (..)
, Team
, mkVertex , mkReward , mkNonReward , mkDynamics , mkControl
, (.$.) , (.|.)
, mkTeam , mkTeamTime , mkTeamTimeBy
, selNodes , variables, rewards, factors, controls
, parents , children , ancestors , ancestoral , descendants
, futureNodes , pastNodes
, printTeam , showTeam , graphToDot , printGraph
, label, labels
) where
import qualified Data.Graph.Inductive as G
import qualified Data.GraphViz as G
import Data.Maybe (fromJust)
import Data.List (nub, intercalate, delete)
import Text.Printf (printf)
type Time = Int
data Variable = Reward String
| NonReward String
deriving (Eq, Ord, Show)
data Factor = Dynamics String
| Control String
deriving (Eq, Ord, Show)
mkVertex :: (String -> a) -> String -> Time -> a
mkVertex t s = t . (s ++ ) . show
mkReward :: String -> Time -> Variable
mkReward = mkVertex Reward
mkNonReward :: String -> Time -> Variable
mkNonReward = mkVertex NonReward
mkDynamics :: String -> Time -> Factor
mkDynamics = mkVertex Dynamics
mkControl :: String -> Time -> Factor
mkControl = mkVertex Control
type Node = Either Factor Variable
class Vertex a where
name :: a -> String
names :: [a] -> String
isReward :: a -> Bool
isNonReward :: a -> Bool
isVariable :: a -> Bool
isDynamics :: a -> Bool
isControl :: a -> Bool
isFactor :: a -> Bool
attribute :: a -> [G.Attribute]
names xs = "[" ++ intercalate ", " (map name xs) ++ "]"
isVariable = or . sequence [isReward, isNonReward]
isFactor = or . sequence [isControl, isDynamics]
instance Vertex Variable where
name (Reward a) = a
name (NonReward a) = a
isReward (Reward _) = True
isReward (NonReward _) = False
isNonReward (Reward _) = False
isNonReward (NonReward _) = True
isDynamics _ = False
isControl _ = False
attribute (Reward a) = [G.Style G.Filled, G.FillColor (G.RGB 0 255 0)
, G.Shape G.Circle
, G.Label a]
attribute (NonReward a) = [G.Shape G.Circle
, G.Label a]
instance Vertex Factor where
name (Dynamics a) = a
name (Control a) = a
isDynamics (Dynamics _) = True
isDynamics (Control _) = False
isControl (Dynamics _) = False
isControl (Control _) = True
isReward _ = False
isNonReward _ = False
attribute (Dynamics a) = [G.Shape G.Rectangle
, G.Label a]
attribute (Control a) = [G.Style G.Filled, G.FillColor (G.RGB 255 0 0)
, G.Shape G.Rectangle
, G.Label a]
instance (Vertex a, Vertex b) => Vertex (Either a b) where
name = either name name
isReward = either isReward isReward
isNonReward = either isNonReward isNonReward
isDynamics = either isDynamics isDynamics
isControl = either isControl isControl
attribute = either attribute attribute
type Edge = (Node, Node, EdgeType)
data EdgeType = Influence | Belief deriving (Eq, Ord, Show)
edgeAttribute :: EdgeType -> [G.Attribute]
edgeAttribute _ = []
(.$.) :: Factor -> (Variable, [Variable]) -> [Edge]
(.$.) f (x,ys) = (Left f, Right x, Influence)
: map (\y -> (Right y, Left f, Influence)) ys
(.|.) :: Variable -> [Variable] -> (Variable, [Variable])
(.|.) x ys = (x,ys)
infixr 4 .|.
infixr 6 .$.
type Team = G.Gr Node EdgeType
mkTeam :: [Edge] -> Team
mkTeam es = G.mkGraph nodes edges where
(nodes,nodeMap) = G.mkNodes G.new . nub . concatMap (\(a,b,_) -> [a,b]) $ es
edges = fromJust . G.mkEdges nodeMap $ es
mkTeamTime :: (Time -> [Edge]) -> Time -> Team
mkTeamTime dyn = mkTeamTimeBy [] dyn (const [])
mkTeamTimeBy :: [Edge] -> (Time -> [Edge]) -> (Time -> [Edge]) -> Time -> Team
mkTeamTimeBy start dyn stop horizon = mkTeam nodes where
nodes = start ++ concatMap dyn [1..horizon] ++ stop horizon
selNodes :: G.Graph gr => (a -> Bool) -> gr a b -> [G.Node]
selNodes p = map G.node' . G.gsel (p.G.lab')
variables :: Team -> [G.Node]
variables = selNodes isVariable
rewards :: Team -> [G.Node]
rewards = selNodes isReward
controls :: Team -> [G.Node]
controls = selNodes isControl
factors :: Team -> [G.Node]
factors = selNodes isFactor
parents :: Team -> G.Node -> [G.Node]
parents = G.pre
children :: Team -> G.Node -> [G.Node]
children = G.suc
descendants :: Team -> G.Node -> [G.Node]
descendants team idx = idx `delete` G.reachable idx team
ancestors :: Team -> G.Node -> [G.Node]
ancestors team idx = idx `delete` G.reachable idx (G.grev team)
ancestoral :: Team -> [G.Node] -> [G.Node]
ancestoral team = nub . concatMap (flip G.reachable (G.grev team))
futureNodes :: Team -> (Node -> Bool) -> G.Node -> [G.Node]
futureNodes team p = filter (p . label team) . descendants team
pastNodes :: Team -> (Node -> Bool) -> G.Node -> [G.Node]
pastNodes team p = filter (p . label team) . ancestors team
printTeam :: Team -> IO ()
printTeam = putStr . showTeam
showTeam :: Team -> String
showTeam team = showTeamBy team isDynamics "Dynamics:" ++ "\n"
++ showTeamBy team isControl "Control :" ++ "\n"
showTeamBy :: Team -> (Node -> Bool) -> String -> String
showTeamBy team p str = if null equations
then ""
else unlines (header ++ equations)
where header = [str, map (const '=') str]
equations = map showFactor . filter (p.snd) . G.labNodes $ team
showFactor (idx,lab) = printf "%s.$.(%s.|.%s)" (name lab)
(names.labels team $ suc)
(names.labels team $ pre)
where suc = G.suc team idx
pre = G.pre team idx
graphToDot :: Team -> G.DotGraph
graphToDot team = G.graphToDot team [] (attribute.snd)
(edgeAttribute. \(_,_,b) -> b)
printGraph :: Team -> FilePath -> IO Bool
printGraph team = G.runGraphviz (graphToDot team) G.Pdf
label :: G.Graph gr => gr a b -> G.Node -> a
label gr = fromJust . G.lab gr
labels :: G.Graph gr => gr a b -> [G.Node] -> [a]
labels = map . label