Common.hs

{- |
   Module      : Data.Graph.Analysis.Algorithms.Common
   Description : Algorithms for all graph types.
   Copyright   : (c) Ivan Lazar Miljenovic 2008
   License     : 2-Clause BSD
   Maintainer  : Ivan.Miljenovic@gmail.com

   Defines algorithms that work on both undirected and
   directed graphs.
 -}
module Data.Graph.Analysis.Algorithms.Common
    ( -- * Graph decomposition
      -- $connected
      componentsOf,
      pathTree,
      -- * Clique Detection
      -- $cliques
      cliquesIn,
      cliquesIn',
      findRegular,
      isRegular,
      -- * Cycle Detection
      -- $cycles
      cyclesIn,
      cyclesIn',
      uniqueCycles,
      uniqueCycles',
      -- * Chain detection
      -- $chains
      chainsIn,
      chainsIn'
    ) where

import Data.Graph.Analysis.Types
import Data.Graph.Analysis.Utils

import Data.Graph.Inductive.Graph
-- For linking purposes.  This will throw a warning.
import Data.Graph.Inductive.Query.DFS(components)
import Data.List
import Data.Maybe
import Control.Arrow

-- -----------------------------------------------------------------------------

{- $connected
   Finding connected components.

   Whilst the FGL library does indeed have a function 'components'
   that returns the connected components of a graph, it returns each
   component as a list of 'Node's.  This implementation instead
   returns each component as a /graph/, which is much more useful.

   Connected components are found by choosing a random node, then
   recursively extracting all neighbours of that node until no more
   nodes can be removed.

   Note that for directed graphs, these are known as the /weakly/
   connected components.
-}

-- | Find all connected components of a graph.
componentsOf :: (DynGraph g) => g a b -> [g a b]
componentsOf = unfoldr splitComponent

-- | Find the next component and split it off from the graph.
splitComponent :: (DynGraph g) => g a b -> Maybe (g a b, g a b)
splitComponent g
    | isEmpty g = Nothing
    | otherwise = Just .          -- Get the type right
                  first buildGr . -- Create the subgraph
                  extractNode .   -- Extract components of subgraph
                  first Just .    -- Getting the types right
                  matchAny $ g    -- Choose an arbitrary node to begin with

-- | Extract the given node and all nodes it is transitively
--   connected to from the graph.
extractNode :: (DynGraph g) => Decomp g a b -> ([Context a b], g a b)
extractNode (Nothing,gr) = ([],gr)
extractNode (Just ctxt, gr)
    | isEmpty gr = ([ctxt], empty)
    | otherwise  = first (ctxt:) $ foldl' nodeExtractor ([],gr) nbrs
    where
      nbrs = neighbors' ctxt

-- | Helper function for 'extractNode' above.
nodeExtractor :: (DynGraph g) => ([Context a b], g a b) -> Node
              -> ([Context a b], g a b)
nodeExtractor cg@(cs,g) n
    | gelem n g = first (++ cs) . extractNode $ match n g
    | otherwise = cg

-- -----------------------------------------------------------------------------

-- | Find all possible paths from this given node, avoiding loops,
--   cycles, etc.
pathTree             :: (DynGraph g) => Decomp g a b -> [NGroup]
pathTree (Nothing,_) = []
pathTree (Just ct,g)
    | isEmpty g = []
    | null sucs = [[n]]
    | otherwise = (:) [n] . map (n:) . concatMap (subPathTree g') $ sucs
    where
      n = node' ct
      sucs = suc' ct
      -- Avoid infinite loops by not letting it continue any further
      ct' = makeLeaf ct
      g' = ct' & g
      subPathTree gr n' = pathTree $ match n' gr

-- | Remove all outgoing edges
makeLeaf           :: Context a b -> Context a b
makeLeaf (p,n,a,_) = (p', n, a, [])
    where
      -- Ensure there isn't an edge (n,n)
      p' = filter (\(_,n') -> n' /= n) p

-- -----------------------------------------------------------------------------
{- $cliques
   Clique detection routines.  Find cliques by taking out a node, and
   seeing which other nodes are all common neighbours (by both 'pre'
   and 'suc').
 -}

-- | Finds all cliques (i.e. maximal complete subgraphs) in the given graph.
cliquesIn    :: (DynGraph g) => g a b -> [[LNode a]]
cliquesIn gr = map (addLabels gr) (cliquesIn' gr)

-- | Finds all cliques in the graph, without including labels.
cliquesIn'    :: (DynGraph g) => g a b -> [NGroup]
cliquesIn' gr = filter (isClique gr') (findRegular gr')
    where
      gr' = mkSimple gr

-- | Determine if the given list of nodes is indeed a clique,
--   and not a smaller subgraph of a clique.
isClique       :: (Graph g) => g a b -> NGroup -> Bool
isClique _  [] = False
isClique gr ns = null .
                 foldl1' intersect .
                 map ((\\ ns) . corecursive gr) $ ns

-- | Find all regular subgraphs of the given graph.
findRegular :: (Graph g) => g a b -> [[Node]]
findRegular = concat . unfoldr findRegularOf

-- | Extract the next regular subgraph of a graph.
findRegularOf :: (Graph g) => g a b -> Maybe ([[Node]], g a b)
findRegularOf g
    | isEmpty g = Nothing
    | otherwise = Just .
                  first (regularOf g . node') .
                  matchAny $ g

-- | Returns all regular subgraphs that include the given node.
regularOf      :: (Graph g) => g a b -> Node -> [[Node]]
regularOf gr n = map (n:) (alsoRegular gr crs)
    where
      crs = corecursive gr n

-- | Recursively find all regular subgraphs only containing nodes
--   in the given list.
alsoRegular          :: (Graph g) => g a b -> [Node] -> [[Node]]
alsoRegular _ []     = []
alsoRegular _ [n]    = [[n]]
alsoRegular g (n:ns) = [n] : rs ++ (alsoRegular g ns)
    where
      rs = map (n:) (alsoRegular g $ intersect crn ns)
      crn = corecursive g n

-- | Return all nodes that are co-recursive with the given node
--   (i.e. for n, find all n' such that n->n' and n'->n).
corecursive      :: (Graph g) => g a b -> Node -> [Node]
corecursive gr n = filter (elem n . suc gr) (delete n $ suc gr n)

-- | Determines if the list of nodes represents a regular subgraph.
isRegular      :: (Graph g) => g a b -> NGroup -> Bool
isRegular g ns = all allCorecursive split
    where
      -- Node + Rest of list
      split = zip ns tns'
      tns' = tail $ tails ns
      allCorecursive (n,rs) = null $ rs \\ (corecursive g n)

-- -----------------------------------------------------------------------------
{- $cycles
   Cycle detection.  Find cycles by finding all paths from a given
   node, and seeing if it reaches itself again.
 -}

-- | Find all cycles in the given graph.
cyclesIn   :: (DynGraph g) => g a b -> [LNGroup a]
cyclesIn g = map (addLabels g) (cyclesIn' g)

-- | Find all cycles in the given graph, returning just the nodes.
cyclesIn' :: (DynGraph g) => g a b -> [NGroup]
cyclesIn' = concat . unfoldr findCycles . mkSimple

-- | Find all cycles in the given graph, excluding those that are also cliques.
uniqueCycles   :: (DynGraph g) => g a b -> [LNGroup a]
uniqueCycles g = map (addLabels g) (uniqueCycles' g)

-- | Find all cycles in the given graph, excluding those that are also cliques.
uniqueCycles'   :: (DynGraph g) => g a b -> [NGroup]
uniqueCycles' g = filter (not . isRegular g) (cyclesIn' g)

-- | Find all cycles containing a chosen node.
findCycles :: (DynGraph g) => g a b -> Maybe ([NGroup], g a b)
findCycles g
    | isEmpty g = Nothing
    | otherwise = Just . getCycles . matchAny $ g
    where
      getCycles (ctx,g') = (cyclesFor (ctx, g'), g')

-- | Find all cycles for the given node.
cyclesFor :: (DynGraph g) => GDecomp g a b -> [NGroup]
cyclesFor = map init .
            filter isCycle .
            pathTree .
            first Just
    where
      isCycle p = (not $ single p) && ((head p) == (last p))

-- -----------------------------------------------------------------------------

{- $chains
   A chain is a path in a graph where for each interior node, there is
   exactly one predecessor and one successor node, i.e. that part of
   the graph forms a \"straight line\".  Furthermore, the initial node
   should have only one successor, and the final node should have only
   one predecessor.  Chains are found by recursively finding the next
   successor in the chain, until either a leaf node is reached or no
   more nodes match the criteria.
-}

-- | Find all chains in the given graph.
chainsIn   :: (DynGraph g, Eq b) => g a b -> [LNGroup a]
chainsIn g = map (addLabels g)
             $ chainsIn' g

-- | Find all chains in the given graph.
chainsIn'   :: (DynGraph g, Eq b) => g a b -> [NGroup]
chainsIn' g = filter (not . single) -- Remove trivial chains
              . map (getChain g')
              $ filterNodes' isChainStart g'
    where
      -- Try to make this work on two-element cycles, undirected
      -- graphs, etc.  Also remove multiple edges, etc.
      g' = oneWay $ mkSimple g

-- | Find the chain starting with the given 'Node'.
getChain     :: (Graph g) => g a b -> Node -> NGroup
getChain g n = n : (unfoldr (chainLink g) (chainNext g n))

-- | Find the next link in the chain.
chainLink :: (Graph g) => g a b -> Maybe Node
          -> Maybe (Node, Maybe Node)
chainLink _ Nothing = Nothing
chainLink g (Just n)
    | isEmpty g         = Nothing
    | not $ hasPrev g n = Nothing
    | otherwise         = Just (n, chainNext g n)

-- | Determines if the given node is the start of a chain.
isChainStart     :: (Graph g) => g a b -> Node -> Bool
isChainStart g n = (hasNext g n)
                   && case (pre g n \\ [n]) of
                        [n'] -> not $ isChainStart g n'
                        _    -> True

-- | Determine if the given node matches the chain criteria in the given
--   direction, and if so what the next node in that direction is.
chainFind         :: (Graph g) => (g a b -> Node -> NGroup)
                  -> g a b -> Node -> Maybe Node
chainFind f g n = case ((nub $ f g n) \\ [n]) of
                    [n'] -> Just n'
                    _    -> Nothing

-- | Find the next node in the chain.
chainNext :: (Graph g) => g a b -> Node -> Maybe Node
chainNext = chainFind suc

-- | Determines if this node matches the successor criteria for chains.
hasNext   :: (Graph g) => g a b -> Node -> Bool
hasNext g = isJust . chainNext g

-- | Determines if this node matches the predecessor criteria for chains.
hasPrev   :: (Graph g) => g a b -> Node -> Bool
hasPrev g = isJust . chainFind pre g