content: {-# LANGUAGE MonadComprehensions, MultiParamTypeClasses #-}
  
  {- |
     Module      : Data.GraphViz.Algorithms
     Description : Various algorithms on Graphviz graphs.
     Copyright   : (c) Matthew Sackman, Ivan Lazar Miljenovic
     License     : 3-Clause BSD-style
     Maintainer  : Ivan.Miljenovic@gmail.com
  
     Defines various algorithms for use on 'DotRepr' graphs.  These are
     typically re-implementations of behaviour found in existing Graphviz
     tools but without the I/O requirement.
  
     Note that one way that these algorithms differ from those found in
     Graphviz is that the order of clusters is /not/ maintained, which may
     affect layout in some cases.
   -}
  module Data.GraphViz.Algorithms
         ( -- * Canonicalisation Options
           -- $options
           CanonicaliseOptions(..)
         , defaultCanonOptions
         , dotLikeOptions
           -- * Canonicalisation
           -- $canonicalisation
         , canonicalise
         , canonicaliseOptions
           -- * Dealing with transitive edges
           -- $transitive
         , transitiveReduction
         , transitiveReductionOptions
         ) where
  
  import Data.GraphViz.Attributes.Complete   (Attributes, defaultAttributeValue)
  import Data.GraphViz.Attributes.Same
  import Data.GraphViz.Internal.Util         (bool)
  import Data.GraphViz.Types
  import Data.GraphViz.Types.Canonical
  import Data.GraphViz.Types.Internal.Common
  
  import           Control.Arrow       (first, second, (***))
  import           Control.Monad       (unless)
  import           Control.Monad.State (State, execState, gets, modify)
  import qualified Data.DList          as DList
  import qualified Data.Foldable       as F
  import           Data.Function       (on)
  import           Data.List           (deleteBy, groupBy, partition, sortBy,
                                        (\\))
  import           Data.Map            (Map)
  import qualified Data.Map            as Map
  import           Data.Maybe          (fromMaybe, listToMaybe, mapMaybe)
  import           Data.Set            (Set)
  import qualified Data.Set            as Set
  
  -- -----------------------------------------------------------------------------
  
  {- $options
     For simplicity, many algorithms end up using the canonicalisation
     functions to create the new 'DotGraph'.  'CanonicaliseOptions' allows
     you to configure how the output is generated.
   -}
  
  data CanonicaliseOptions = COpts { -- | Place edges in the clusters
                                     --   where their nodes are rather
                                     --   than in the top-level graph.
                                     edgesInClusters :: Bool
                                     -- | Put common 'Attributes' as
                                     --   top-level 'GlobalAttributes'.
                                   , groupAttributes :: Bool
                                   }
                           deriving (Eq, Ord, Show, Read)
  
  defaultCanonOptions :: CanonicaliseOptions
  defaultCanonOptions = COpts { edgesInClusters = True
                              , groupAttributes = True
                              }
  
  -- | Options that are more like how @dot -Tcanon@ works.
  dotLikeOptions :: CanonicaliseOptions
  dotLikeOptions = COpts { edgesInClusters = True
                         , groupAttributes = False
                         }
  
  -- -----------------------------------------------------------------------------
  
  {- $canonicalisation
  
  These functions implement similar functionality to @dot -Tcanon@
  (i.e. creates a canonical form of any 'DotRepr' graph).  without
  requiring IO.
  
  Note that due to implementation specifics the behaviour is not
  identical; in particular:
  
  * Any specified 'Attributes' that equal the defaults are stripped out
    (unless required to override a previous attribute that doesn't apply
    here).
  
  * Grouping of attributes (when @'groupAttributes = True'@) is much
    more conservative; only those node/edge attributes that are common to
    /all/ nodes and edges within that cluster (and within sub-clusters)
    are made global.
  
  * Sub-graphs aren't kept, only clusters.
  
  * 'ColorScheme' Attributes are removed (as all @Color@ values embed
    any needed color scheme anyway) as the output order of attributes may
    change (and this matters for the Haskell side of things).
  
  In particular, note that this function will create a single explicit
  definition for every node in the original graph and place it in the
  appropriate position in the cluster hierarchy.  All edges are found in
  the deepest cluster that contains both nodes.
  
  -}
  
  -- | Canonicalise with some sensible defaults.
  canonicalise :: (DotRepr dg n) => dg n -> DotGraph n
  canonicalise = canonicaliseOptions defaultCanonOptions
  
  -- | As with 'canonicalise', but allow custom 'CanonicaliseOptions'.
  canonicaliseOptions :: (DotRepr dg n) => CanonicaliseOptions
                         -> dg n -> DotGraph n
  canonicaliseOptions opts dg = cdg { strictGraph   = graphIsStrict dg
                                    , directedGraph = graphIsDirected dg
                                    }
    where
      cdg = createCanonical opts (getID dg) gas cl nl es
  
      (gas, cl) = graphStructureInformationClean dg
      nl = nodeInformationClean True dg
      es = edgeInformationClean True dg
  
  type NodePath n = ([Maybe GraphID], DotNode n)
  type NodePaths n = [NodePath n]
  type EdgeClusters n = Map (Maybe GraphID) [DotEdge n]
  type EdgeLocations n = (EdgeClusters n, [DotEdge n])
  
  data CanonControl n = CC { cOpts    :: !CanonicaliseOptions
                           , isGraph  :: !Bool
                           , clusters :: !ClusterLookup
                           , clustEs  :: !(EdgeLocations n)
                           , topID    :: !(Maybe GraphID)
                           , topAttrs :: !Attributes
                           }
  
  createCanonical :: (Ord n) => CanonicaliseOptions -> Maybe GraphID -> GlobalAttributes
                     -> ClusterLookup -> NodeLookup n -> [DotEdge n] -> DotGraph n
  createCanonical opts gid gas cl nl es = promoteDSG $ makeGrouping cc ns
    where
      nUnlook (n,(p,as)) = (F.toList p, DotNode n as)
      -- DotNodes paired and sorted by their paths
      ns = sortBy (compLists `on` fst) . map nUnlook $ Map.toList nl
  
      es' = if edgesInClusters opts
            then edgeClusters nl es
            else (Map.empty, es)
  
      cc = CC { cOpts    = opts
              , isGraph  = True
              , clusters = cl
              , clustEs  = es'
              , topID    = gid
              , topAttrs = attrs gas
              }
  
  thisLevel :: NodePaths n -> (NodePaths n, [DotNode n])
  thisLevel = second (map snd) . span (not . null . fst)
  
  makeGrouping :: CanonControl n -> NodePaths n -> DotSubGraph n
  makeGrouping cc cns = DotSG { isCluster = True
                              , subGraphID = cID
                              , subGraphStmts = stmts
                              }
    where
      cID | isGraph cc = topID cc
          | otherwise  = head . fst . head $ cns
  
      (nestedNs, ns) = thisLevel
                       . bool (map $ first tail) id (isGraph cc)
                       $ cns
  
      es = bool (fromMaybe [] . Map.lookup cID . fst) snd (isGraph cc)
           $ clustEs cc
  
      gas | isGraph cc = topAttrs cc
          | otherwise  = attrs . snd $ clusters cc Map.! cID
  
      subGs = map (makeGrouping $ cc { isGraph = False })
              . groupBy ((==) `on` (listToMaybe . fst))
              $ nestedNs
  
      stmts = setGlobal (cOpts cc) gas
              $ DotStmts { attrStmts = []
                         , subGraphs = subGs
                         , nodeStmts = ns
                         , edgeStmts = es
                         }
  
  setGlobal :: CanonicaliseOptions
               -> Attributes -- Specified cluster attributes
               -> DotStatements n
               -> DotStatements n
  setGlobal opts as stmts = stmts { attrStmts = globs'
                                  , subGraphs = sgs'
                                  , nodeStmts = ns'
                                  , edgeStmts = es'
                                  }
    where
      sgs = subGraphs stmts
      sStmts = map subGraphStmts sgs
      ns = nodeStmts stmts
      es = edgeStmts stmts
  
      sGlobs = map (partitionGlobal . attrStmts) sStmts
  
      (sgas,snas,seas) = unzip3 sGlobs
  
      gas' = as -- Can't change graph attrs! Need these!
      nas' = getCommonGlobs opts nodeStmts snas sStmts $ map nodeAttributes ns
      eas' = getCommonGlobs opts edgeStmts seas sStmts $ map edgeAttributes es
  
      globs' = nonEmptyGAs [ GraphAttrs gas'
                           , NodeAttrs  nas'
                           , EdgeAttrs  eas'
                           ]
      ns' = map (\dn -> dn { nodeAttributes = nodeAttributes dn \\ nas' }) ns
      es' = map (\de -> de { edgeAttributes = edgeAttributes de \\ eas' }) es
  
      sgas' = updateGraphGlobs gas' sgas
      snas' = map (\\ nas') snas
      seas' = map (\\ eas') seas
  
      sGlobs' = zip3 sgas' snas' seas'
      sStmts' = zipWith (\ sSt sGl -> sSt { attrStmts = nonEmptyGAs $ unPartitionGlobal sGl })
                        sStmts
                        sGlobs'
  
      sgs' = zipWith (\ sg sSt -> sg { subGraphStmts = sSt }) sgs sStmts'
  
  updateGraphGlobs :: Attributes -> [Attributes] -> [Attributes]
  updateGraphGlobs gas = map go
    where
      gasS = Set.fromList gas
  
      override = toSAttr $ nonSameDefaults gas
  
      -- * Remove any identical values
      -- * Override any different values
      go = Set.toList
           . (`Set.difference` gasS) -- Remove identical values
           . unSameSet
           . (`Set.union` override) -- Keeps existing values of constructors
           . toSAttr
  
  nonSameDefaults :: Attributes -> Attributes
  nonSameDefaults = mapMaybe (\ a -> [ a' | a' <- defaultAttributeValue a, a' /= a] )
  
  getCommonGlobs :: CanonicaliseOptions
                    -> (DotStatements n -> [a])
                    -> [Attributes] -- ^ From sub-graphs
                    -> [DotStatements n] -- ^ Statements from the sub-graphs for testing.
                    -> [Attributes] -- ^ From nodes/edges
                    -> Attributes
  getCommonGlobs opts f sas stmts as
    | not $ groupAttributes opts = []
    | otherwise = case sas' ++ as of
                    []  -> []
                    [_] -> []
                    as' -> Set.toList . foldr1 Set.intersection
                           $ map Set.fromList as'
    where
      sas' = keepIfAny f sas stmts
  
  -- Used to distinguish between having empty list of global attributes
  -- for nodes or edges because there aren't any nodes/edges, or because
  -- there aren't any common attributes
  keepIfAny :: (DotStatements n -> [a]) -> [Attributes] -> [DotStatements n]
               -> [Attributes]
  keepIfAny f sas = map fst . filter snd . zip sas . map (hasAny f)
  
  hasAny      :: (DotStatements n -> [a]) -> DotStatements n -> Bool
  hasAny f ds = not (null $ f ds) || any (hasAny f . subGraphStmts) (subGraphs ds)
  
  promoteDSG     :: DotSubGraph n -> DotGraph n
  promoteDSG dsg = DotGraph { strictGraph     = undefined
                            , directedGraph   = undefined
                            , graphID         = subGraphID dsg
                            , graphStatements = subGraphStmts dsg
                            }
  
  -- Same as compare for lists, except shorter lists are GT
  compLists :: (Ord a) => [a] -> [a] -> Ordering
  compLists []     []     = EQ
  compLists []     _      = GT
  compLists _      []     = LT
  compLists (x:xs) (y:ys) = case compare x y of
                              EQ  -> compLists xs ys
                              oth -> oth
  
  nonEmptyGAs :: [GlobalAttributes] -> [GlobalAttributes]
  nonEmptyGAs = filter (not . null . attrs)
  
  -- Assign each edge into the cluster it belongs in.
  edgeClusters    :: (Ord n) => NodeLookup n -> [DotEdge n]
                     -> EdgeLocations n
  edgeClusters nl = (toM *** map snd) . partition (not . null . fst)
                    . map inClust
    where
      nl' = Map.map (F.toList . fst) nl
      -- DotEdge n -> (Path, DotEdge n)
      inClust de@(DotEdge n1 n2 _) = (flip (,) de)
                                     . map fst . takeWhile (uncurry (==))
                                     $ zip (nl' Map.! n1) (nl' Map.! n2)
      toM = Map.map DList.toList
            . Map.fromListWith (flip DList.append)
            . map (last *** DList.singleton)
  
  -- -----------------------------------------------------------------------------
  
  {- $transitive
  
     In large, cluttered graphs, it can often be difficult to see what
     is happening due to the number of edges being drawn.  As such, it is
     often useful to remove transitive edges from the graph before
     visualising it.
  
     For example, consider the following Dot graph:
  
     > digraph {
     >     a -> b;
     >     a -> c;
     >     b -> c;
     > }
  
     This graph has the transitive edge @a -> c@ (as we can reach @c@ from @a@ via @b@).
  
     Graphviz comes with the @tred@ program to perform these transitive
     reductions.  'transitiveReduction' and 'transitiveReductionOptions'
     are pure Haskell re-implementations of @tred@ with the following differences:
  
     * @tred@ prints a message to stderr if a cycle is detected; these
       functions do not.
  
     * @tred@ preserves the original structure of the graph; these
       functions use the canonicalisation functions above to create the new
       graph (rather than re-implement creation functions for each one).
  
     When a graph contains cycles, an arbitrary edge from that cycle is
     ignored whilst calculating the transitive reduction.  Multiple edges
     are also reduced (such that only the first edge between two nodes is
     kept).
  
     Note that transitive reduction only makes sense for directed graphs;
     for undirected graphs these functions are identical to the
     canonicalisation functions above.
  
     The caveats for the canonicalisation functions also apply.
   -}
  
  transitiveReduction :: (DotRepr dg n) => dg n -> DotGraph n
  transitiveReduction = transitiveReductionOptions defaultCanonOptions
  
  transitiveReductionOptions         :: (DotRepr dg n) => CanonicaliseOptions
                                        -> dg n -> DotGraph n
  transitiveReductionOptions opts dg = cdg { strictGraph = graphIsStrict dg
                                           , directedGraph = graphIsDirected dg
                                           }
    where
      cdg = createCanonical opts (getID dg) gas cl nl es'
      (gas, cl) = graphStructureInformationClean dg
      nl = nodeInformationClean True dg
      es = edgeInformationClean True dg
      es' | graphIsDirected dg = rmTransEdges es
          | otherwise          = es
  
  rmTransEdges    :: (Ord n) => [DotEdge n] -> [DotEdge n]
  rmTransEdges [] = []
  rmTransEdges es = concatMap (map snd . outgoing) $ Map.elems esM
    where
      tes = tagEdges es
  
      esMS = do edgeGraph tes
                ns <- getsMap Map.keys
                mapM_ (traverseTag zeroTag) ns
  
      esM = fst $ execState esMS (Map.empty, Set.empty)
  
  type Tag = Int
  type TagSet = Set Int
  type TaggedEdge n = (Tag, DotEdge n)
  
  -- A "nonsense" tag to use as an initial value
  zeroTag :: Tag
  zeroTag = 0
  
  tagEdges :: [DotEdge n] -> [TaggedEdge n]
  tagEdges = zip [(succ zeroTag)..]
  
  data TaggedValues n = TV { marked   :: Bool
                           , incoming :: [TaggedEdge n]
                           , outgoing :: [TaggedEdge n]
                           }
                      deriving (Eq, Ord, Show, Read)
  
  defTV :: TaggedValues n
  defTV = TV False [] []
  
  type TagMap n = Map n (TaggedValues n)
  
  type TagState n a = State (TagMap n, TagSet) a
  
  getMap :: TagState n (TagMap n)
  getMap = gets fst
  
  getsMap   :: (TagMap n -> a) -> TagState n a
  getsMap f = gets (f . fst)
  
  modifyMap   :: (TagMap n -> TagMap n) -> TagState n ()
  modifyMap f = modify (first f)
  
  getSet :: TagState n TagSet
  getSet = gets snd
  
  modifySet   :: (TagSet -> TagSet) -> TagState n ()
  modifySet f = modify (second f)
  
  -- Create the Map representing the graph from the edges.
  edgeGraph :: (Ord n) => [TaggedEdge n] -> TagState n ()
  edgeGraph = mapM_ addEdge . reverse
    where
      addEdge te = addVal f tvOut >> addVal t tvIn
        where
          e = snd te
          f = fromNode e
          t = toNode e
          addVal n tv = modifyMap (Map.insertWith mergeTV n tv)
          tvIn  = defTV { incoming = [te] }
          tvOut = defTV { outgoing = [te] }
          mergeTV tvNew tv  = tv { incoming = incoming tvNew ++ incoming tv
                                 , outgoing = outgoing tvNew ++ outgoing tv
                                 }
  
  -- Perform a DFS to determine whether or not to keep each edge.
  traverseTag     :: (Ord n) => Tag -> n -> TagState n ()
  traverseTag t n = do setMark True
                       checkIncoming
                       outEs <- getsMap (maybe [] outgoing . Map.lookup n)
                       mapM_ maybeRecurse outEs
                       setMark False
    where
      setMark mrk = modifyMap (Map.adjust (\tv -> tv { marked = mrk }) n)
  
      isMarked m n' = maybe False marked $ n' `Map.lookup` m
  
      checkIncoming = do m <- gets fst
                         let es = incoming $ m Map.! n
                             (keepEs, delEs) = partition (keepEdge m) es
                         modifyMap (Map.adjust (\tv -> tv {incoming = keepEs}) n)
                         modifySet (Set.union $ Set.fromList (map fst delEs))
                         mapM_ delOtherEdge delEs
        where
          keepEdge m (t',e) = t == t' || not (isMarked m $ fromNode e)
  
          delOtherEdge te = modifyMap (Map.adjust delE . fromNode $ snd te)
            where
              delE tv = tv {outgoing = deleteBy ((==) `on` fst) te $ outgoing tv}
  
      maybeRecurse (t',e) = do m <- getMap
                               delSet <- getSet
                               let n' = toNode e
                               unless (isMarked m n' || t' `Set.member` delSet)
                                 $ traverseTag t' n'
  