module Data.Graph.Analysis.Algorithms.Directed
(
endNode, endNode',
endBy, endBy',
rootsOf, rootsOf',
isRoot, isRoot',
leavesOf, leavesOf',
isLeaf, isLeaf',
singletonsOf, singletonsOf',
isSingleton, isSingleton',
coreOf,
levelGraph,
levelGraphFrom,
minLevel,
accessibleFrom,
accessibleFrom',
accessibleOnlyFrom,
accessibleOnlyFrom',
leafMinPaths,
leafMinPaths'
) where
import Data.Graph.Analysis.Types
import Data.Graph.Analysis.Utils
import Data.Graph.Inductive.Graph
import Data.Graph.Inductive.Query.BFS(esp)
import Data.List(minimumBy, unfoldr)
import Data.Maybe(fromMaybe)
import Data.Function(on)
import qualified Data.Map as M
import Data.Map(Map)
import qualified Data.Set as S
import Data.Set(Set)
import Control.Monad(ap)
endNode :: (Graph g) => (g a b -> Node -> NGroup)
-> g a b -> LNode a -> Bool
endNode f g = endNode' f g . node
endNode' :: (Graph g) => (g a b -> Node -> NGroup) -> g a b -> Node
-> Bool
endNode' f g n = case (f g n) of
[] -> True
[n'] -> n' == n
_ -> False
endBy :: (Graph g) => (g a b -> Node -> NGroup) -> g a b -> LNGroup a
endBy = filterNodes . endNode
endBy' :: (Graph g) => (g a b -> Node -> NGroup) -> g a b -> NGroup
endBy' = filterNodes' . endNode'
rootsOf :: (Graph g) => g a b -> LNGroup a
rootsOf = endBy pre
rootsOf' :: (Graph g) => g a b -> NGroup
rootsOf' = endBy' pre
isRoot :: (Graph g) => g a b -> LNode a -> Bool
isRoot = endNode pre
isRoot' :: (Graph g) => g a b -> Node -> Bool
isRoot' = endNode' pre
leavesOf :: (Graph g) => g a b -> LNGroup a
leavesOf = endBy suc
leavesOf' :: (Graph g) => g a b -> NGroup
leavesOf' = endBy' suc
isLeaf :: (Graph g) => g a b -> LNode a -> Bool
isLeaf = endNode suc
isLeaf' :: (Graph g) => g a b -> Node -> Bool
isLeaf' = endNode' suc
singletonsOf :: (Graph g) => g a b -> LNGroup a
singletonsOf = endBy neighbors
singletonsOf' :: (Graph g) => g a b -> NGroup
singletonsOf' = endBy' neighbors
isSingleton :: (Graph g) => g a b -> LNode a -> Bool
isSingleton = endNode neighbors
isSingleton' :: (Graph g) => g a b -> Node -> Bool
isSingleton' = endNode' neighbors
coreOf :: (DynGraph g, Eq a, Eq b) => g a b -> g a b
coreOf = fixPointGraphs stripEnds
where
stripEnds gr' = delNodes roots . delNodes leaves $ gr'
where
roots = rootsOf' gr'
leaves = leavesOf' gr'
levelGraph :: (Ord a, DynGraph g) => g a b -> g (GenCluster a) b
levelGraph g = levelGraphFrom (rootsOf' g) g
levelGraphFrom :: (Ord a, DynGraph g) => NGroup -> g a b
-> g (GenCluster a) b
levelGraphFrom rs g = gmap addLbl g
where
lvls = zip [minLevel..] . map S.toList $ graphLevels rs g
lvMap = M.fromList
$ concatMap (\(l,ns) -> map (flip (,) l) ns) lvls
mkLbl n l = GC { clust = getLevel n
, nLbl = l
}
addLbl (p,n,l,s) = (p, n, mkLbl n l, s)
getLevel n = fromMaybe (pred minLevel) $ n `M.lookup` lvMap
minLevel :: Int
minLevel = 0
type NSet = Set Node
graphLevels :: (Graph g) => NGroup -> g a b -> [NSet]
graphLevels = flip graphLevels' . S.fromList
graphLevels' :: (Graph g) => g a b -> NSet -> [NSet]
graphLevels' g = unfoldr getNextLevel . flip (,) g
getNextLevel :: (Graph g) => (NSet, g a b)
-> Maybe (NSet, (NSet, g a b))
getNextLevel (ns,g)
| S.null ns = Nothing
| otherwise = Just (ns, (ns', g'))
where
g' = delNodes (S.toList ns) g
ns' = flip S.difference ns
. S.unions . map getSuc
$ S.toList ns
getSuc = S.fromList . suc g
leafMinPaths :: (Graph g) => g a b -> [LNGroup a]
leafMinPaths g = map (lfMinPth g rs) ls
where
rs = rootsOf' g
ls = leavesOf' g
leafMinPaths' :: (Graph g) => g a b -> [NGroup]
leafMinPaths' = map (map node) . leafMinPaths
lfMinPth :: (Graph g) => g a b -> [Node] -> Node -> LNGroup a
lfMinPth g rs l = addLabels g
. snd
. minimumBy (compare `on` fst)
. addLengths
$ map (\ r -> esp r l g) rs
accessibleFrom :: (Graph g) => g a b -> [Node] -> [Node]
accessibleFrom g = S.toList . accessibleFrom' g . S.fromList
accessibleFrom' :: (Graph g) => g a b -> Set Node -> Set Node
accessibleFrom' g = S.unions . graphLevels' g
accessibleOnlyFrom :: (Graph g) => g a b -> [Node] -> [Node]
accessibleOnlyFrom g = S.toList . accessibleOnlyFrom' g . S.fromList
accessibleOnlyFrom' :: (Graph g) => g a b -> Set Node -> Set Node
accessibleOnlyFrom' g = M.keysSet
. fixPoint keepOnlyInternal
. setKeys (pre g)
. accessibleFrom' g
setKeys :: (Ord a) => (a -> b) -> Set a -> Map a b
setKeys f = M.fromDistinctAscList . map (ap (,) f) . S.toAscList
keepOnlyInternal :: Map Node NGroup -> Map Node NGroup
keepOnlyInternal = M.filter =<< onlyInternalPred
onlyInternalPred :: Map Node NGroup -> NGroup -> Bool
onlyInternalPred = all . flip M.member