module Data.Graph.Inductive.Helper where
import Data.Graph.Inductive as Graph
import qualified Data.Map as Map
import Data.Maybe
import qualified Data.Set as Set
import qualified Data.Tree as Tree
import Safe
findRootPaths :: Graph gr => gr n e -> Graph.Context n e -> (Node, [[Node]])
findRootPaths = findRootPathsBy (\(_, node, _, _) -> node)
findRootPathsBy :: Graph gr => (Graph.Context n e -> a) -> gr n e -> Graph.Context n e -> (a, [[a]])
findRootPathsBy f graph ctx = (f ctx, findRootPathsRec [] ctx) where
findRootPathsRec path ctx'@(inward, _, _, _) = case inward of
[] -> [f ctx' : path]
a -> concatMap (findRootPathsRec (f ctx' : path) . context graph . snd) a
treeRootStatefulBy
:: Graph gr
=> (st -> Graph.Context n e -> (a, st))
-> st
-> gr n e
-> Graph.Context n e
-> Tree.Tree (a, st)
treeRootStatefulBy f st graph = trsbRec st where
trsbRec st' ctx'@(inward, _, _, _) =
let val = f st' ctx'
in Tree.Node val (trsbRec (snd val) . context graph . snd <$> inward)
cyclesOfGraph :: Graph gr => gr n l -> [[LNode n]]
cyclesOfGraph graph = fromMaybe []
. sequence
. fmap
( sequence
. fmap (\n -> (,) n <$> lab graph n))
. filter hasSome
. scc $ graph
cyclicSubgraphs :: forall gr n e. (DynGraph gr, Ord n, Ord e) => gr n e -> [gr n e]
cyclicSubgraphs graph = flip subgraph graph <$> filter hasSomeLI (scc graph) where
hasSomeLI :: [Node] -> Bool
hasSomeLI [] = False
hasSomeLI [n] = not . null $ filter (\(n1,n2,_) -> n == n1 && n1 == n2) (out graph n ++ inn graph n)
hasSomeLI _ = True
hasSome :: [a] -> Bool
hasSome [] = False
hasSome [_] = False
hasSome _ = True
hasSome' :: [Graph.Context n l] -> Bool
hasSome' [] = False
hasSome' [(_, noden, _, outward)] = any ((== noden) . snd) outward
hasSome' _ = True
buildFromNodes :: (DynGraph gr, Foldable t) => t a -> gr a ()
buildFromNodes =
fst . foldr (\n (gr, h : tl) -> (([], h, n, []) & gr, tl)) (Graph.empty, [(0 :: Node)..])
topsortWithCycles :: (Graph gr, Ord a) => gr a b -> [Either [a] a]
topsortWithCycles graph =
let
cycleMap = Map.fromList . concat $ (\cy -> zip cy (repeat (Set.fromList cy))) . fmap snd <$> cyclesOfGraph graph
tsorted = topsort' graph
sieveCycles [] = []
sieveCycles (h : tl) = case Map.lookup h cycleMap of
Nothing -> Right h : sieveCycles tl
Just cy -> Left (Set.toList cy) : sieveCycles (filter (`Set.notMember` cy) tl)
in sieveCycles tsorted
treeToPaths :: Tree.Tree a -> [[a]]
treeToPaths (Tree.Node l []) = [[l]]
treeToPaths (Tree.Node l sbf) = (l :) <$> concat (treeToPaths <$> sbf)
edgeyTopsort :: Graph gr => gr n e -> Maybe [(n, e)]
edgeyTopsort graph
| not (null (cyclesOfGraph graph)) = Nothing
| otherwise = Just (unvalidatedEdgeyTopsort graph)
unvalidatedEdgeyTopsort :: Graph gr => gr n e -> [(n, e)]
unvalidatedEdgeyTopsort graph =
let candidate = headMay $ gsel (null . inn') graph
in case flip match graph . node' <$> candidate of
Nothing -> []
Just (Nothing, _) -> []
Just (Just ctx, graph') -> fmap (\(_, _, l) -> (lab' ctx, l)) (out' ctx) ++ unvalidatedEdgeyTopsort graph'