1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49
|
module Main where
import Data.Graph
import qualified Data.Set as S
import Data.Array
import Data.List
import Control.Arrow
import Data.Maybe
import Data.Tree
import qualified Data.Map as M
addEdges g es = buildG b es'
where b = bounds g
es' = es ++ edges g
pairs xs = concat [ [(x,y),(y,x)] | x:ys <- tails xs, y <- ys ]
reduceToSCC g = (g', translate)
where
roots = map rootLabel . scc $ g
m = M.fromList couples
couples = zip [1..] roots
translate = (m M.!)
g' = buildG (1, M.size m)
$ [ (x,y) | ((x,x'),(y,y')) <- pairs couples, path g x' y' ]
applyReduce f g = map (tr *** tr) . f $ g'
where (g', tr) = reduceToSCC g
smallestForSC g = applyReduce edgesToAdd g
where edgesToAdd g' | length (vertices g') == 1 = []
| isConnected = newEdge : (smallestForSC $ addEdges g' [newEdge])
| otherwise = edgesForConn ++ (smallestForSC $ addEdges g' edgesForConn)
where
isConnected = null $ drop 1 comp
comp = map flatten $ components g'
newEdge = (outVertex &&& inVertex) (head comp)
outVertex = fromJust . find ((==0) . (outdegree g' !))
inVertex = fromJust . find ((==0) . (indegree g' !))
edgesForConn = map (outVertex *** inVertex) $ zip comp (tail comp ++ [head comp])
graph1 = buildG (1,5) [(1,2),(1,3),(3,4),(4,1)]
graph2 = buildG (1,7) [(1,2),(1,3),(2,4),(4,5),(3,5),(6,3),(6,7),(7,5),(4,1)]
main = do
print $ smallestForSC graph1
print $ smallestForSC graph2 |
Partager