{- |
Description :  HetsAPIs interface for refinment trees.
Copyright   :  (c) Otto-von-Guericke University of Magdeburg
License     :  GPLv2 or higher, see LICENSE.txt
-}
module HetsAPI.Refinement (
    RefinementTreeNode(..),
    RefinementTreeLink(..),
    getRefinementTree,
    getAvailableSpecificationsForRefinement
)

where

import Static.DevGraph (DGraph (specRoots), RTNodeLab, RTLinkLab, refTree, rtl_type, RTLinkType (..))

import qualified Common.Lib.Graph as Graph
import Data.Graph.Inductive (mkGraph, Node, suc, subgraph, labNodes, out, inn, labEdges, LNode, LEdge, nodes)
import qualified Data.Map as Map
import qualified Data.Set as Set

data RefinementTreeNode = RefinementTreeNode {
        RefinementTreeNode -> Bool
isRootNode :: !Bool,
        RefinementTreeNode -> RTNodeLab
rtNodeLab :: !RTNodeLab
    }

getRefinementTreeNode :: Graph.Gr RTNodeLab RTLinkLab -> LNode RTNodeLab -> LNode RefinementTreeNode
getRefinementTreeNode :: Gr RTNodeLab RTLinkLab
-> LNode RTNodeLab -> LNode RefinementTreeNode
getRefinementTreeNode graph :: Gr RTNodeLab RTLinkLab
graph (x :: Node
x, lab :: RTNodeLab
lab) = (Node
x, Bool -> RTNodeLab -> RefinementTreeNode
RefinementTreeNode (Node -> Gr RTNodeLab RTLinkLab -> Bool
forall a. Node -> Gr a RTLinkLab -> Bool
isRoot Node
x Gr RTNodeLab RTLinkLab
graph) RTNodeLab
lab)

type RefinementTreeLink = RTLinkLab

getRefinementTreeEdge' :: (RTLinkLab -> Bool)
    -> [LEdge RTLinkLab]
    -> [LEdge RefinementTreeLink]
getRefinementTreeEdge' :: (RTLinkLab -> Bool) -> [LEdge RTLinkLab] -> [LEdge RTLinkLab]
getRefinementTreeEdge' fn :: RTLinkLab -> Bool
fn = (LEdge RTLinkLab -> Bool) -> [LEdge RTLinkLab] -> [LEdge RTLinkLab]
forall a. (a -> Bool) -> [a] -> [a]
filter (\ (_, _, e :: RTLinkLab
e) -> RTLinkLab -> Bool
fn RTLinkLab
e)

roots :: String -> DGraph -> Maybe (Set.Set Node)
roots :: String -> DGraph -> Maybe (Set Node)
roots rspName :: String
rspName = ([Node] -> Set Node) -> Maybe [Node] -> Maybe (Set Node)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Node] -> Set Node
forall a. Ord a => [a] -> Set a
Set.fromList (Maybe [Node] -> Maybe (Set Node))
-> (DGraph -> Maybe [Node]) -> DGraph -> Maybe (Set Node)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Map String [Node] -> Maybe [Node]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
rspName (Map String [Node] -> Maybe [Node])
-> (DGraph -> Map String [Node]) -> DGraph -> Maybe [Node]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DGraph -> Map String [Node]
specRoots

isRoot :: Node -> Graph.Gr a RTLinkLab -> Bool
isRoot :: Node -> Gr a RTLinkLab -> Bool
isRoot n :: Node
n rTree :: Gr a RTLinkLab
rTree = (LEdge RTLinkLab -> Bool) -> [LEdge RTLinkLab] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\ (_, _, llab :: RTLinkLab
llab) -> RTLinkLab -> RTLinkType
rtl_type RTLinkLab
llab RTLinkType -> RTLinkType -> Bool
forall a. Eq a => a -> a -> Bool
== RTLinkType
RTComp) (
            Gr a RTLinkLab -> Node -> [LEdge RTLinkLab]
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Node -> [LEdge b]
out Gr a RTLinkLab
rTree Node
n) Bool -> Bool -> Bool
&& Bool -> Bool
not
            ((LEdge RTLinkLab -> Bool) -> [LEdge RTLinkLab] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\ (_, _, llab :: RTLinkLab
llab) -> RTLinkLab -> RTLinkType
rtl_type RTLinkLab
llab RTLinkType -> RTLinkType -> Bool
forall a. Eq a => a -> a -> Bool
== RTLinkType
RTComp) ([LEdge RTLinkLab] -> Bool) -> [LEdge RTLinkLab] -> Bool
forall a b. (a -> b) -> a -> b
$
            Gr a RTLinkLab -> Node -> [LEdge RTLinkLab]
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Node -> [LEdge b]
inn Gr a RTLinkLab
rTree Node
n)

ccomp :: String -> DGraph -> Maybe (Set.Set Node)
ccomp :: String -> DGraph -> Maybe (Set Node)
ccomp rspName :: String
rspName dg :: DGraph
dg = do
    Set Node
roots' <- String -> DGraph -> Maybe (Set Node)
roots String
rspName DGraph
dg
    Set Node -> Maybe (Set Node)
forall (m :: * -> *) a. Monad m => a -> m a
return (Set Node -> Maybe (Set Node)) -> Set Node -> Maybe (Set Node)
forall a b. (a -> b) -> a -> b
$ Set Node -> Gr RTNodeLab RTLinkLab -> Set Node
forall a b. Set Node -> Gr a b -> Set Node
getConnectedComps Set Node
roots' (Gr RTNodeLab RTLinkLab -> Set Node)
-> Gr RTNodeLab RTLinkLab -> Set Node
forall a b. (a -> b) -> a -> b
$ DGraph -> Gr RTNodeLab RTLinkLab
refTree DGraph
dg

getConnectedComps :: Set.Set Node -> Graph.Gr a b -> Set.Set Node
getConnectedComps :: Set Node -> Gr a b -> Set Node
getConnectedComps nodes0 :: Set Node
nodes0 tree :: Gr a b
tree =
    let nodes1 :: Set Node
nodes1 = Set (Set Node) -> Set Node
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions (Set (Set Node) -> Set Node) -> Set (Set Node) -> Set Node
forall a b. (a -> b) -> a -> b
$ (Node -> Set Node) -> Set Node -> Set (Set Node)
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map ([Node] -> Set Node
forall a. Ord a => [a] -> Set a
Set.fromList ([Node] -> Set Node) -> (Node -> [Node]) -> Node -> Set Node
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Gr a b -> Node -> [Node]
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Node -> [Node]
suc Gr a b
tree) Set Node
nodes0 in
        if Set Node -> Set Node -> Bool
forall a. Ord a => Set a -> Set a -> Bool
Set.isSubsetOf Set Node
nodes1 Set Node
nodes0
        then Set Node
nodes0
        else Set Node -> Gr a b -> Set Node
forall a b. Set Node -> Gr a b -> Set Node
getConnectedComps ((Set Node -> Node -> Set Node) -> Set Node -> Set Node -> Set Node
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ((Node -> Set Node -> Set Node) -> Set Node -> Node -> Set Node
forall a b c. (a -> b -> c) -> b -> a -> c
flip Node -> Set Node -> Set Node
forall a. Ord a => a -> Set a -> Set a
Set.insert) Set Node
nodes0 Set Node
nodes1) Gr a b
tree

getRefinementTree :: String -> DGraph -> Maybe (Graph.Gr RefinementTreeNode RefinementTreeLink)
getRefinementTree :: String -> DGraph -> Maybe (Gr RefinementTreeNode RTLinkLab)
getRefinementTree rspName :: String
rspName dg :: DGraph
dg = do
    [Node]
ccomp' <- Set Node -> [Node]
forall a. Set a -> [a]
Set.toList (Set Node -> [Node]) -> Maybe (Set Node) -> Maybe [Node]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> DGraph -> Maybe (Set Node)
ccomp String
rspName DGraph
dg
    let
        nods :: [LNode RefinementTreeNode]
nods = (LNode RTNodeLab -> LNode RefinementTreeNode)
-> [LNode RTNodeLab] -> [LNode RefinementTreeNode]
forall a b. (a -> b) -> [a] -> [b]
map (Gr RTNodeLab RTLinkLab
-> LNode RTNodeLab -> LNode RefinementTreeNode
getRefinementTreeNode (Gr RTNodeLab RTLinkLab
 -> LNode RTNodeLab -> LNode RefinementTreeNode)
-> Gr RTNodeLab RTLinkLab
-> LNode RTNodeLab
-> LNode RefinementTreeNode
forall a b. (a -> b) -> a -> b
$ DGraph -> Gr RTNodeLab RTLinkLab
refTree DGraph
dg) [LNode RTNodeLab]
vertices
        nodeAliases :: Map Node Node
nodeAliases = [(Node, Node)] -> Map Node Node
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Node, Node)] -> Map Node Node)
-> [(Node, Node)] -> Map Node Node
forall a b. (a -> b) -> a -> b
$ [Node] -> [Node] -> [(Node, Node)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Gr RTNodeLab RTLinkLab -> [Node]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [Node]
nodes Gr RTNodeLab RTLinkLab
rTree) (LNode RefinementTreeNode -> Node
forall a b. (a, b) -> a
fst (LNode RefinementTreeNode -> Node)
-> [LNode RefinementTreeNode] -> [Node]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LNode RefinementTreeNode]
nods)
        rTree :: Gr RTNodeLab RTLinkLab
rTree = [Node] -> Gr RTNodeLab RTLinkLab -> Gr RTNodeLab RTLinkLab
forall (gr :: * -> * -> *) a b.
DynGraph gr =>
[Node] -> gr a b -> gr a b
subgraph [Node]
ccomp' (DGraph -> Gr RTNodeLab RTLinkLab
refTree DGraph
dg)
        vertices :: [LNode RTNodeLab]
vertices = Gr RTNodeLab RTLinkLab -> [LNode RTNodeLab]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LNode a]
labNodes Gr RTNodeLab RTLinkLab
rTree
        arcs :: [LEdge RTLinkLab]
arcs = Gr RTNodeLab RTLinkLab -> [LEdge RTLinkLab]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LEdge b]
labEdges Gr RTNodeLab RTLinkLab
rTree
        edges' :: [LEdge RTLinkLab]
edges' = [LEdge RTLinkLab]
arcListR [LEdge RTLinkLab] -> [LEdge RTLinkLab] -> [LEdge RTLinkLab]
forall a. [a] -> [a] -> [a]
++ [LEdge RTLinkLab]
arcListC
        edges :: [LEdge RTLinkLab]
edges = [( Map Node Node
nodeAliases Map Node Node -> Node -> Node
forall k a. Ord k => Map k a -> k -> a
Map.! Node
s, Map Node Node
nodeAliases Map Node Node -> Node -> Node
forall k a. Ord k => Map k a -> k -> a
Map.! Node
t, RTLinkLab
l) | (s :: Node
s, t :: Node
t, l :: RTLinkLab
l) <- [LEdge RTLinkLab]
edges']
        arcListR :: [LEdge RTLinkLab]
arcListR = (RTLinkLab -> Bool) -> [LEdge RTLinkLab] -> [LEdge RTLinkLab]
getRefinementTreeEdge' (RTLinkType -> RTLinkType -> Bool
forall a. Eq a => a -> a -> Bool
(==) RTLinkType
RTComp (RTLinkType -> Bool)
-> (RTLinkLab -> RTLinkType) -> RTLinkLab -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RTLinkLab -> RTLinkType
rtl_type) [LEdge RTLinkLab]
arcs
        arcListC :: [LEdge RTLinkLab]
arcListC = (RTLinkLab -> Bool) -> [LEdge RTLinkLab] -> [LEdge RTLinkLab]
getRefinementTreeEdge' (RTLinkType -> RTLinkType -> Bool
forall a. Eq a => a -> a -> Bool
(==) RTLinkType
RTRefine (RTLinkType -> Bool)
-> (RTLinkLab -> RTLinkType) -> RTLinkLab -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RTLinkLab -> RTLinkType
rtl_type) [LEdge RTLinkLab]
arcs
    Gr RefinementTreeNode RTLinkLab
-> Maybe (Gr RefinementTreeNode RTLinkLab)
forall (m :: * -> *) a. Monad m => a -> m a
return (Gr RefinementTreeNode RTLinkLab
 -> Maybe (Gr RefinementTreeNode RTLinkLab))
-> Gr RefinementTreeNode RTLinkLab
-> Maybe (Gr RefinementTreeNode RTLinkLab)
forall a b. (a -> b) -> a -> b
$ [LNode RefinementTreeNode]
-> [LEdge RTLinkLab] -> Gr RefinementTreeNode RTLinkLab
forall (gr :: * -> * -> *) a b.
Graph gr =>
[LNode a] -> [LEdge b] -> gr a b
mkGraph [LNode RefinementTreeNode]
nods [LEdge RTLinkLab]
edges

getAvailableSpecificationsForRefinement :: DGraph -> [String]
getAvailableSpecificationsForRefinement :: DGraph -> [String]
getAvailableSpecificationsForRefinement = Map String [Node] -> [String]
forall k a. Map k a -> [k]
Map.keys (Map String [Node] -> [String])
-> (DGraph -> Map String [Node]) -> DGraph -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DGraph -> Map String [Node]
specRoots