module Data.Graph.Analysis.Algorithms.Common
(
componentsOf,
pathTree,
cliquesIn,
cliquesIn',
findRegular,
isRegular,
cyclesIn,
cyclesIn',
uniqueCycles,
uniqueCycles',
chainsIn,
chainsIn'
) where
import Data.Graph.Analysis.Types
import Data.Graph.Analysis.Utils
import Data.Graph.Inductive.Graph
import Data.Graph.Inductive.Query.DFS(components)
import Data.List(unfoldr, foldl', foldl1', intersect, (\\), delete, tails, nub)
import Data.Maybe(isJust)
import Control.Arrow(first)
componentsOf :: (DynGraph g) => g a b -> [g a b]
componentsOf = unfoldr splitComponent
splitComponent :: (DynGraph g) => g a b -> Maybe (g a b, g a b)
splitComponent g
| isEmpty g = Nothing
| otherwise = Just .
first buildGr .
extractNode .
first Just .
matchAny $ g
extractNode :: (DynGraph g) => Decomp g a b -> ([Context a b], g a b)
extractNode (Nothing,gr) = ([],gr)
extractNode (Just ctxt, gr)
| isEmpty gr = ([ctxt], empty)
| otherwise = first (ctxt:) $ foldl' nodeExtractor ([],gr) nbrs
where
nbrs = neighbors' ctxt
nodeExtractor :: (DynGraph g) => ([Context a b], g a b) -> Node
-> ([Context a b], g a b)
nodeExtractor cg@(cs,g) n
| gelem n g = first (++ cs) . extractNode $ match n g
| otherwise = cg
pathTree :: (DynGraph g) => Decomp g a b -> [NGroup]
pathTree (Nothing,_) = []
pathTree (Just ct,g)
| isEmpty g = []
| null sucs = [[n]]
| otherwise = (:) [n] . map (n:) . concatMap (subPathTree g') $ sucs
where
n = node' ct
sucs = suc' ct
ct' = makeLeaf ct
g' = ct' & g
subPathTree gr n' = pathTree $ match n' gr
makeLeaf :: Context a b -> Context a b
makeLeaf (p,n,a,_) = (p', n, a, [])
where
p' = filter (\(_,n') -> n' /= n) p
cliquesIn :: (DynGraph g) => g a b -> [[LNode a]]
cliquesIn gr = map (addLabels gr) (cliquesIn' gr)
cliquesIn' :: (DynGraph g) => g a b -> [NGroup]
cliquesIn' gr = filter (isClique gr') (findRegular gr')
where
gr' = mkSimple gr
isClique :: (Graph g) => g a b -> NGroup -> Bool
isClique _ [] = False
isClique gr ns = null .
foldl1' intersect .
map ((\\ ns) . twoCycle gr) $ ns
findRegular :: (Graph g) => g a b -> [[Node]]
findRegular = concat . unfoldr findRegularOf
findRegularOf :: (Graph g) => g a b -> Maybe ([[Node]], g a b)
findRegularOf g
| isEmpty g = Nothing
| otherwise = Just .
first (regularOf g . node') .
matchAny $ g
regularOf :: (Graph g) => g a b -> Node -> [[Node]]
regularOf gr n = map (n:) (alsoRegular gr crs)
where
crs = twoCycle gr n
alsoRegular :: (Graph g) => g a b -> [Node] -> [[Node]]
alsoRegular _ [] = []
alsoRegular _ [n] = [[n]]
alsoRegular g (n:ns) = [n] : rs ++ alsoRegular g ns
where
rs = map (n:) (alsoRegular g $ intersect crn ns)
crn = twoCycle g n
twoCycle :: (Graph g) => g a b -> Node -> [Node]
twoCycle gr n = filter (elem n . suc gr) (delete n $ suc gr n)
isRegular :: (Graph g) => g a b -> NGroup -> Bool
isRegular g ns = all allTwoCycle split
where
split = zip ns tns'
tns' = tail $ tails ns
allTwoCycle (n,rs) = null $ rs \\ twoCycle g n
cyclesIn :: (DynGraph g) => g a b -> [LNGroup a]
cyclesIn g = map (addLabels g) (cyclesIn' g)
cyclesIn' :: (DynGraph g) => g a b -> [NGroup]
cyclesIn' = concat . unfoldr findCycles . mkSimple
uniqueCycles :: (DynGraph g) => g a b -> [LNGroup a]
uniqueCycles g = map (addLabels g) (uniqueCycles' g)
uniqueCycles' :: (DynGraph g) => g a b -> [NGroup]
uniqueCycles' g = filter (not . isRegular g) (cyclesIn' g)
findCycles :: (DynGraph g) => g a b -> Maybe ([NGroup], g a b)
findCycles g
| isEmpty g = Nothing
| otherwise = Just . getCycles . matchAny $ g
where
getCycles (ctx,g') = (cyclesFor (ctx, g'), g')
cyclesFor :: (DynGraph g) => GDecomp g a b -> [NGroup]
cyclesFor = map init .
filter isCycle .
pathTree .
first Just
where
isCycle p = not (single p) && (head p == last p)
chainsIn :: (DynGraph g, Eq b) => g a b -> [LNGroup a]
chainsIn g = map (addLabels g)
$ chainsIn' g
chainsIn' :: (DynGraph g, Eq b) => g a b -> [NGroup]
chainsIn' g = filter (not . single)
. map (getChain g')
$ filterNodes' isChainStart g'
where
g' = oneWay $ mkSimple g
getChain :: (Graph g) => g a b -> Node -> NGroup
getChain g n = n : unfoldr (chainLink g) (chainNext g n)
chainLink :: (Graph g) => g a b -> Maybe Node
-> Maybe (Node, Maybe Node)
chainLink _ Nothing = Nothing
chainLink g (Just n)
| isEmpty g = Nothing
| not $ hasPrev g n = Nothing
| otherwise = Just (n, chainNext g n)
isChainStart :: (Graph g) => g a b -> Node -> Bool
isChainStart g n = hasNext g n
&& case (pre g n \\ [n]) of
[n'] -> not $ isChainStart g n'
_ -> True
chainFind :: (Graph g) => (g a b -> Node -> NGroup)
-> g a b -> Node -> Maybe Node
chainFind f g n = case (nub (f g n) \\ [n]) of
[n'] -> Just n'
_ -> Nothing
chainNext :: (Graph g) => g a b -> Node -> Maybe Node
chainNext = chainFind suc
hasNext :: (Graph g) => g a b -> Node -> Bool
hasNext g = isJust . chainNext g
hasPrev :: (Graph g) => g a b -> Node -> Bool
hasPrev g = isJust . chainFind pre g