Decomposition.hs

-- Quick and dirty:
--
-- Modular decomposition of a digraph into a set of subgraphs such that, in
-- each subgraph $s$, from a specific base vertex $b$, there exists a path to
-- every other vertex in $s$, and no path to base vertices in the rest of the
-- supergraph.

import Control.Applicative ((<$>),(<*>))
import Data.Graph.Wrapper (Graph, vertices, vertex, fromVerticesEdges, reachableVertices, edges)
import Data.List (intersect, union, find)

isSubgraphOf :: Eq i => Graph i v -> Graph i v -> Bool
a `isSubgraphOf` b = and -- Doesn't check data, but that's okay.
  [ vertices a `intersect` vertices b == vertices a
  , edges a `intersect` edges b == edges a
  ]

reachableSubgraph :: Ord i => i -> Graph i v -> Graph i v
reachableSubgraph v g  = fromVerticesEdges ((,) <*> vertex g <$> vs) es
  where vs = reachableVertices g v 
        es = (\(a,b) -> a `elem` vs && b `elem` vs) `filter` edges g

decompose :: Ord i => Graph i v -> [Graph i v]
decompose = decompose' [] []

decompose' :: Ord i => [i] -> [Graph i v] -> Graph i v -> [Graph i v]
decompose' seenVertices components graph = case find (`notElem` seenVertices) (vertices graph) of
  Nothing     -> components
  Just vertex -> decompose' ((>>=) components' vertices `union` seenVertices) components' graph
    where components' | any (reachable `isSubgraphOf`) components = components
                      | otherwise = reachable : filter (not . (`isSubgraphOf` reachable)) components
          reachable = reachableSubgraph vertex graph

Use this instead:

decompose graph = map (reachableSubgraph graph) . filter ((==0) . indegree graph) $ vertices graph

It's simpler, and more efficient in every regard.