content: 
  -- A program for extracting strongly connected components from a .dot
  -- file created by auxprogs/gen-mdg.
  
  -- How to use: one of the following:
  
  -- compile to an exe:   ghc -o dottoscc DotToScc.hs
  --    and then    ./dottoscc name_of_file.dot
  
  -- or interpret with runhugs:
  --    runhugs DotToScc.hs name_of_file.dot
  
  -- or run within hugs:
  --    hugs DotToScc.hs
  --    Main> imain "name_of_file.dot"
  
  
  module Main where
  
  import System
  import List ( sort, nub )
  
  usage :: IO ()
  usage = putStrLn "usage: dottoscc <name_of_file.dot>"
  
  main :: IO ()
  main = do args <- getArgs
            if length args /= 1
             then usage
             else imain (head args)
  
  imain :: String -> IO ()
  imain dot_file_name
     = do edges <- read_dot_file dot_file_name
          let sccs = gen_sccs edges
          let pretty = showPrettily sccs
          putStrLn pretty
       where
          showPrettily :: [[String]] -> String
          showPrettily = unlines . concatMap showScc
  
          showScc elems
             = let n = length elems 
               in
                  [""]
                  ++ (if n > 1 then ["   -- " 
                                     ++ show n ++ " modules in cycle"] 
                               else [])
                  ++ map ("   " ++) elems
  
  
  -- Read a .dot file and return a list of edges
  read_dot_file :: String{-filename-} -> IO [(String,String)]
  read_dot_file dot_file_name
     = do bytes <- readFile dot_file_name
          let linez = lines bytes
          let edges = [(s,d) | Just (s,d) <- map maybe_mk_edge linez]
          return edges
       where
          -- identify lines of the form "text1 -> text2" and return
          -- text1 and text2
          maybe_mk_edge :: String -> Maybe (String, String)
          maybe_mk_edge str
             = case words str of
                  [text1, "->", text2] -> Just (text1, text2)
                  other                -> Nothing
  
  
  -- Take the list of edges and return a topologically sorted list of
  -- sccs
  gen_sccs :: [(String,String)] -> [[String]]
  gen_sccs raw_edges
     = let clean_edges = sort (nub raw_edges)
           nodes       = nub (concatMap (\(s,d) -> [s,d]) clean_edges)
           ins  v      = [u | (u,w) <- clean_edges, v==w]
           outs v      = [w | (u,w) <- clean_edges, v==u]
           components  = map (sort.utSetToList) (deScc ins outs nodes)
       in
           components
  
  
  --------------------------------------------------------------------
  --------------------------------------------------------------------
  --------------------------------------------------------------------
  
  -- Graph-theoretic stuff that does the interesting stuff.
  
  -- ==========================================================--
  --
  deScc :: (Ord a) =>
           (a -> [a]) -> -- The "ins"  map
           (a -> [a]) -> -- The "outs" map
           [a]        -> -- The root vertices
           [Set a]       -- The topologically sorted components
  
  deScc ins outs
     = spanning . depthFirst
       where depthFirst = snd . deDepthFirstSearch outs (utSetEmpty, [])
             spanning   = snd . deSpanningSearch   ins  (utSetEmpty, [])
  
  
  -- =========================================================--
  --
  deDepthFirstSearch :: (Ord a) =>
                        (a -> [a])   -> -- The map,
                        (Set a, [a]) -> -- state: visited set,
                                        --      current sequence of vertices
                        [a]          -> -- input vertices sequence
                        (Set a, [a])    -- final state
  
  deDepthFirstSearch
     = foldl . search
       where
       search relation (visited, sequence) vertex
        | utSetElementOf vertex visited   = (visited,          sequence )
        | otherwise                       = (visited', vertex: sequence')
          where
          (visited', sequence')
           = deDepthFirstSearch relation
                             (utSetUnion visited (utSetSingleton vertex), sequence)
                             (relation vertex)
  
  
  -- ==========================================================--
  --
  deSpanningSearch   :: (Ord a) =>
                        (a -> [a])       -> -- The map
                        (Set a, [Set a]) -> -- Current state: visited set,
                                            --  current sequence of vertice sets
                        [a]              -> -- Input sequence of vertices
                        (Set a, [Set a])    -- Final state
  
  deSpanningSearch
     = foldl . search
       where
       search relation (visited, utSetSequence) vertex
        | utSetElementOf vertex visited   = (visited,          utSetSequence )
        | otherwise = (visited', utSetFromList (vertex: sequence): utSetSequence)
          where
           (visited', sequence)
              = deDepthFirstSearch relation
                            (utSetUnion visited (utSetSingleton vertex), [])
                            (relation vertex)
  
  
  
  
  
  --------------------------------------------------------------------
  --------------------------------------------------------------------
  --------------------------------------------------------------------
  -- Most of this set stuff isn't needed.
  
  
  -- ====================================--
  -- === set                          ===--
  -- ====================================--
  
  data Set e = MkSet [e]
  
  -- ==========================================================--
  --
  unMkSet :: (Ord a) => Set a -> [a]
  
  unMkSet (MkSet s) = s
  
  
  -- ==========================================================--
  --
  utSetEmpty :: (Ord a) => Set a
  
  utSetEmpty = MkSet []
  
  
  -- ==========================================================--
  --
  utSetIsEmpty :: (Ord a) => Set a -> Bool
  
  utSetIsEmpty (MkSet s) = s == []
  
  
  -- ==========================================================--
  --
  utSetSingleton :: (Ord a) => a -> Set a
  
  utSetSingleton x = MkSet [x]
  
  
  -- ==========================================================--
  --
  utSetFromList :: (Ord a) => [a] -> Set a
  
  utSetFromList x = (MkSet . rmdup . sort) x
                    where rmdup []       = []
                          rmdup [x]      = [x]
                          rmdup (x:y:xs) | x==y       = rmdup (y:xs)
                                         | otherwise  = x: rmdup (y:xs)
  
  
  -- ==========================================================--
  --
  utSetToList :: (Ord a) => Set a -> [a]
  
  utSetToList (MkSet xs) = xs
  
  
  
  -- ==========================================================--
  --
  utSetUnion :: (Ord a) => Set a -> Set a -> Set a
  
  utSetUnion (MkSet [])     (MkSet [])            = (MkSet [])
  utSetUnion (MkSet [])     (MkSet (b:bs))        = (MkSet (b:bs))
  utSetUnion (MkSet (a:as)) (MkSet [])            = (MkSet (a:as))
  utSetUnion (MkSet (a:as)) (MkSet (b:bs))
      | a < b   = MkSet (a: (unMkSet (utSetUnion (MkSet as) (MkSet (b:bs)))))
      | a == b  = MkSet (a: (unMkSet (utSetUnion (MkSet as) (MkSet bs))))
      | a > b   = MkSet (b: (unMkSet (utSetUnion (MkSet (a:as)) (MkSet bs))))
  
  
  -- ==========================================================--
  --
  utSetIntersection :: (Ord a) => Set a -> Set a -> Set a
  
  utSetIntersection (MkSet [])     (MkSet [])     = (MkSet [])
  utSetIntersection (MkSet [])     (MkSet (b:bs)) = (MkSet [])
  utSetIntersection (MkSet (a:as)) (MkSet [])     = (MkSet [])
  utSetIntersection (MkSet (a:as)) (MkSet (b:bs))
      | a < b   = utSetIntersection (MkSet as) (MkSet (b:bs))
      | a == b  = MkSet (a: (unMkSet (utSetIntersection (MkSet as) (MkSet bs))))
      | a > b   = utSetIntersection (MkSet (a:as)) (MkSet bs)
  
  
  -- ==========================================================--
  --
  utSetSubtraction :: (Ord a) => Set a -> Set a -> Set a
  
  utSetSubtraction (MkSet [])     (MkSet [])      = (MkSet [])
  utSetSubtraction (MkSet [])     (MkSet (b:bs))  = (MkSet [])
  utSetSubtraction (MkSet (a:as)) (MkSet [])      = (MkSet (a:as))
  utSetSubtraction (MkSet (a:as)) (MkSet (b:bs))
      | a < b   = MkSet (a: (unMkSet (utSetSubtraction (MkSet as) (MkSet (b:bs)))))
      | a == b  = utSetSubtraction (MkSet as) (MkSet bs)
      | a > b   = utSetSubtraction (MkSet (a:as)) (MkSet bs)
  
  
  -- ==========================================================--
  --
  utSetElementOf :: (Ord a) => a -> Set a -> Bool
  
  utSetElementOf x (MkSet [])       = False
  utSetElementOf x (MkSet (y:ys))   = x==y || (x>y && utSetElementOf x (MkSet ys))
  
  
  
  -- ==========================================================--
  --
  utSetSubsetOf :: (Ord a) => Set a -> Set a -> Bool
  
  utSetSubsetOf (MkSet [])        (MkSet bs) = True
  utSetSubsetOf (MkSet (a:as))    (MkSet bs)
      = utSetElementOf a (MkSet bs) && utSetSubsetOf (MkSet as) (MkSet bs)
  
  
  -- ==========================================================--
  --
  utSetUnionList :: (Ord a) => [Set a] -> Set a
  
  utSetUnionList setList = foldl utSetUnion utSetEmpty setList
  
  
  