{-# 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.
                                   CanonicaliseOptions -> Bool
edgesInClusters :: Bool
                                   -- | Put common 'Attributes' as
                                   --   top-level 'GlobalAttributes'.
                                 , CanonicaliseOptions -> Bool
groupAttributes :: Bool
                                 }
                         deriving (CanonicaliseOptions -> CanonicaliseOptions -> Bool
(CanonicaliseOptions -> CanonicaliseOptions -> Bool)
-> (CanonicaliseOptions -> CanonicaliseOptions -> Bool)
-> Eq CanonicaliseOptions
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CanonicaliseOptions -> CanonicaliseOptions -> Bool
== :: CanonicaliseOptions -> CanonicaliseOptions -> Bool
$c/= :: CanonicaliseOptions -> CanonicaliseOptions -> Bool
/= :: CanonicaliseOptions -> CanonicaliseOptions -> Bool
Eq, Eq CanonicaliseOptions
Eq CanonicaliseOptions =>
(CanonicaliseOptions -> CanonicaliseOptions -> Ordering)
-> (CanonicaliseOptions -> CanonicaliseOptions -> Bool)
-> (CanonicaliseOptions -> CanonicaliseOptions -> Bool)
-> (CanonicaliseOptions -> CanonicaliseOptions -> Bool)
-> (CanonicaliseOptions -> CanonicaliseOptions -> Bool)
-> (CanonicaliseOptions
    -> CanonicaliseOptions -> CanonicaliseOptions)
-> (CanonicaliseOptions
    -> CanonicaliseOptions -> CanonicaliseOptions)
-> Ord CanonicaliseOptions
CanonicaliseOptions -> CanonicaliseOptions -> Bool
CanonicaliseOptions -> CanonicaliseOptions -> Ordering
CanonicaliseOptions -> CanonicaliseOptions -> CanonicaliseOptions
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: CanonicaliseOptions -> CanonicaliseOptions -> Ordering
compare :: CanonicaliseOptions -> CanonicaliseOptions -> Ordering
$c< :: CanonicaliseOptions -> CanonicaliseOptions -> Bool
< :: CanonicaliseOptions -> CanonicaliseOptions -> Bool
$c<= :: CanonicaliseOptions -> CanonicaliseOptions -> Bool
<= :: CanonicaliseOptions -> CanonicaliseOptions -> Bool
$c> :: CanonicaliseOptions -> CanonicaliseOptions -> Bool
> :: CanonicaliseOptions -> CanonicaliseOptions -> Bool
$c>= :: CanonicaliseOptions -> CanonicaliseOptions -> Bool
>= :: CanonicaliseOptions -> CanonicaliseOptions -> Bool
$cmax :: CanonicaliseOptions -> CanonicaliseOptions -> CanonicaliseOptions
max :: CanonicaliseOptions -> CanonicaliseOptions -> CanonicaliseOptions
$cmin :: CanonicaliseOptions -> CanonicaliseOptions -> CanonicaliseOptions
min :: CanonicaliseOptions -> CanonicaliseOptions -> CanonicaliseOptions
Ord, Int -> CanonicaliseOptions -> ShowS
[CanonicaliseOptions] -> ShowS
CanonicaliseOptions -> String
(Int -> CanonicaliseOptions -> ShowS)
-> (CanonicaliseOptions -> String)
-> ([CanonicaliseOptions] -> ShowS)
-> Show CanonicaliseOptions
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CanonicaliseOptions -> ShowS
showsPrec :: Int -> CanonicaliseOptions -> ShowS
$cshow :: CanonicaliseOptions -> String
show :: CanonicaliseOptions -> String
$cshowList :: [CanonicaliseOptions] -> ShowS
showList :: [CanonicaliseOptions] -> ShowS
Show, ReadPrec [CanonicaliseOptions]
ReadPrec CanonicaliseOptions
Int -> ReadS CanonicaliseOptions
ReadS [CanonicaliseOptions]
(Int -> ReadS CanonicaliseOptions)
-> ReadS [CanonicaliseOptions]
-> ReadPrec CanonicaliseOptions
-> ReadPrec [CanonicaliseOptions]
-> Read CanonicaliseOptions
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS CanonicaliseOptions
readsPrec :: Int -> ReadS CanonicaliseOptions
$creadList :: ReadS [CanonicaliseOptions]
readList :: ReadS [CanonicaliseOptions]
$creadPrec :: ReadPrec CanonicaliseOptions
readPrec :: ReadPrec CanonicaliseOptions
$creadListPrec :: ReadPrec [CanonicaliseOptions]
readListPrec :: ReadPrec [CanonicaliseOptions]
Read)

defaultCanonOptions :: CanonicaliseOptions
defaultCanonOptions :: CanonicaliseOptions
defaultCanonOptions = COpts { edgesInClusters :: Bool
edgesInClusters = Bool
True
                            , groupAttributes :: Bool
groupAttributes = Bool
True
                            }

-- | Options that are more like how @dot -Tcanon@ works.
dotLikeOptions :: CanonicaliseOptions
dotLikeOptions :: CanonicaliseOptions
dotLikeOptions = COpts { edgesInClusters :: Bool
edgesInClusters = Bool
True
                       , groupAttributes :: Bool
groupAttributes = Bool
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 :: forall (dg :: * -> *) n. DotRepr dg n => dg n -> DotGraph n
canonicalise = CanonicaliseOptions -> dg n -> DotGraph n
forall (dg :: * -> *) n.
DotRepr dg n =>
CanonicaliseOptions -> dg n -> DotGraph n
canonicaliseOptions CanonicaliseOptions
defaultCanonOptions

-- | As with 'canonicalise', but allow custom 'CanonicaliseOptions'.
canonicaliseOptions :: (DotRepr dg n) => CanonicaliseOptions
                       -> dg n -> DotGraph n
canonicaliseOptions :: forall (dg :: * -> *) n.
DotRepr dg n =>
CanonicaliseOptions -> dg n -> DotGraph n
canonicaliseOptions CanonicaliseOptions
opts dg n
dg = DotGraph n
cdg { strictGraph   = graphIsStrict dg
                                  , directedGraph = graphIsDirected dg
                                  }
  where
    cdg :: DotGraph n
cdg = CanonicaliseOptions
-> Maybe GraphID
-> GlobalAttributes
-> ClusterLookup
-> NodeLookup n
-> [DotEdge n]
-> DotGraph n
forall n.
Ord n =>
CanonicaliseOptions
-> Maybe GraphID
-> GlobalAttributes
-> ClusterLookup
-> NodeLookup n
-> [DotEdge n]
-> DotGraph n
createCanonical CanonicaliseOptions
opts (dg n -> Maybe GraphID
forall (dg :: * -> *) n. DotRepr dg n => dg n -> Maybe GraphID
getID dg n
dg) GlobalAttributes
gas ClusterLookup
cl NodeLookup n
nl [DotEdge n]
es

    (GlobalAttributes
gas, ClusterLookup
cl) = dg n -> (GlobalAttributes, ClusterLookup)
forall (dg :: * -> *) n.
DotRepr dg n =>
dg n -> (GlobalAttributes, ClusterLookup)
graphStructureInformationClean dg n
dg
    nl :: NodeLookup n
nl = Bool -> dg n -> NodeLookup n
forall (dg :: * -> *) n.
DotRepr dg n =>
Bool -> dg n -> NodeLookup n
nodeInformationClean Bool
True dg n
dg
    es :: [DotEdge n]
es = Bool -> dg n -> [DotEdge n]
forall (dg :: * -> *) n.
DotRepr dg n =>
Bool -> dg n -> [DotEdge n]
edgeInformationClean Bool
True dg n
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 { forall n. CanonControl n -> CanonicaliseOptions
cOpts    :: !CanonicaliseOptions
                         , forall n. CanonControl n -> Bool
isGraph  :: !Bool
                         , forall n. CanonControl n -> ClusterLookup
clusters :: !ClusterLookup
                         , forall n. CanonControl n -> EdgeLocations n
clustEs  :: !(EdgeLocations n)
                         , forall n. CanonControl n -> Maybe GraphID
topID    :: !(Maybe GraphID)
                         , forall n. CanonControl n -> Attributes
topAttrs :: !Attributes
                         }

createCanonical :: (Ord n) => CanonicaliseOptions -> Maybe GraphID -> GlobalAttributes
                   -> ClusterLookup -> NodeLookup n -> [DotEdge n] -> DotGraph n
createCanonical :: forall n.
Ord n =>
CanonicaliseOptions
-> Maybe GraphID
-> GlobalAttributes
-> ClusterLookup
-> NodeLookup n
-> [DotEdge n]
-> DotGraph n
createCanonical CanonicaliseOptions
opts Maybe GraphID
gid GlobalAttributes
gas ClusterLookup
cl NodeLookup n
nl [DotEdge n]
es = DotSubGraph n -> DotGraph n
forall n. DotSubGraph n -> DotGraph n
promoteDSG (DotSubGraph n -> DotGraph n) -> DotSubGraph n -> DotGraph n
forall a b. (a -> b) -> a -> b
$ CanonControl n -> NodePaths n -> DotSubGraph n
forall n. CanonControl n -> NodePaths n -> DotSubGraph n
makeGrouping CanonControl n
cc NodePaths n
ns
  where
    nUnlook :: (n, (t a, Attributes)) -> ([a], DotNode n)
nUnlook (n
n,(t a
p,Attributes
as)) = (t a -> [a]
forall a. t a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList t a
p, n -> Attributes -> DotNode n
forall n. n -> Attributes -> DotNode n
DotNode n
n Attributes
as)
    -- DotNodes paired and sorted by their paths
    ns :: NodePaths n
ns = (([Maybe GraphID], DotNode n)
 -> ([Maybe GraphID], DotNode n) -> Ordering)
-> NodePaths n -> NodePaths n
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ([Maybe GraphID] -> [Maybe GraphID] -> Ordering
forall a. Ord a => [a] -> [a] -> Ordering
compLists ([Maybe GraphID] -> [Maybe GraphID] -> Ordering)
-> (([Maybe GraphID], DotNode n) -> [Maybe GraphID])
-> ([Maybe GraphID], DotNode n)
-> ([Maybe GraphID], DotNode n)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ([Maybe GraphID], DotNode n) -> [Maybe GraphID]
forall a b. (a, b) -> a
fst) (NodePaths n -> NodePaths n)
-> ([(n, (Seq (Maybe GraphID), Attributes))] -> NodePaths n)
-> [(n, (Seq (Maybe GraphID), Attributes))]
-> NodePaths n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((n, (Seq (Maybe GraphID), Attributes))
 -> ([Maybe GraphID], DotNode n))
-> [(n, (Seq (Maybe GraphID), Attributes))] -> NodePaths n
forall a b. (a -> b) -> [a] -> [b]
map (n, (Seq (Maybe GraphID), Attributes))
-> ([Maybe GraphID], DotNode n)
forall {t :: * -> *} {n} {a}.
Foldable t =>
(n, (t a, Attributes)) -> ([a], DotNode n)
nUnlook ([(n, (Seq (Maybe GraphID), Attributes))] -> NodePaths n)
-> [(n, (Seq (Maybe GraphID), Attributes))] -> NodePaths n
forall a b. (a -> b) -> a -> b
$ NodeLookup n -> [(n, (Seq (Maybe GraphID), Attributes))]
forall k a. Map k a -> [(k, a)]
Map.toList NodeLookup n
nl

    es' :: EdgeLocations n
es' = if CanonicaliseOptions -> Bool
edgesInClusters CanonicaliseOptions
opts
          then NodeLookup n -> [DotEdge n] -> EdgeLocations n
forall n. Ord n => NodeLookup n -> [DotEdge n] -> EdgeLocations n
edgeClusters NodeLookup n
nl [DotEdge n]
es
          else (Map (Maybe GraphID) [DotEdge n]
forall k a. Map k a
Map.empty, [DotEdge n]
es)

    cc :: CanonControl n
cc = CC { cOpts :: CanonicaliseOptions
cOpts    = CanonicaliseOptions
opts
            , isGraph :: Bool
isGraph  = Bool
True
            , clusters :: ClusterLookup
clusters = ClusterLookup
cl
            , clustEs :: EdgeLocations n
clustEs  = EdgeLocations n
es'
            , topID :: Maybe GraphID
topID    = Maybe GraphID
gid
            , topAttrs :: Attributes
topAttrs = GlobalAttributes -> Attributes
attrs GlobalAttributes
gas
            }

thisLevel :: NodePaths n -> (NodePaths n, [DotNode n])
thisLevel :: forall n. NodePaths n -> (NodePaths n, [DotNode n])
thisLevel = ([([Maybe GraphID], DotNode n)] -> [DotNode n])
-> ([([Maybe GraphID], DotNode n)], [([Maybe GraphID], DotNode n)])
-> ([([Maybe GraphID], DotNode n)], [DotNode n])
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ((([Maybe GraphID], DotNode n) -> DotNode n)
-> [([Maybe GraphID], DotNode n)] -> [DotNode n]
forall a b. (a -> b) -> [a] -> [b]
map ([Maybe GraphID], DotNode n) -> DotNode n
forall a b. (a, b) -> b
snd) (([([Maybe GraphID], DotNode n)], [([Maybe GraphID], DotNode n)])
 -> ([([Maybe GraphID], DotNode n)], [DotNode n]))
-> ([([Maybe GraphID], DotNode n)]
    -> ([([Maybe GraphID], DotNode n)],
        [([Maybe GraphID], DotNode n)]))
-> [([Maybe GraphID], DotNode n)]
-> ([([Maybe GraphID], DotNode n)], [DotNode n])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Maybe GraphID], DotNode n) -> Bool)
-> [([Maybe GraphID], DotNode n)]
-> ([([Maybe GraphID], DotNode n)], [([Maybe GraphID], DotNode n)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Bool -> Bool
not (Bool -> Bool)
-> (([Maybe GraphID], DotNode n) -> Bool)
-> ([Maybe GraphID], DotNode n)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe GraphID] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Maybe GraphID] -> Bool)
-> (([Maybe GraphID], DotNode n) -> [Maybe GraphID])
-> ([Maybe GraphID], DotNode n)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Maybe GraphID], DotNode n) -> [Maybe GraphID]
forall a b. (a, b) -> a
fst)

makeGrouping :: CanonControl n -> NodePaths n -> DotSubGraph n
makeGrouping :: forall n. CanonControl n -> NodePaths n -> DotSubGraph n
makeGrouping CanonControl n
cc NodePaths n
cns = DotSG { isCluster :: Bool
isCluster = Bool
True
                            , subGraphID :: Maybe GraphID
subGraphID = Maybe GraphID
cID
                            , subGraphStmts :: DotStatements n
subGraphStmts = DotStatements n
stmts
                            }
  where
    cID :: Maybe GraphID
cID | CanonControl n -> Bool
forall n. CanonControl n -> Bool
isGraph CanonControl n
cc = CanonControl n -> Maybe GraphID
forall n. CanonControl n -> Maybe GraphID
topID CanonControl n
cc
        | Bool
otherwise  = [Maybe GraphID] -> Maybe GraphID
forall a. HasCallStack => [a] -> a
head ([Maybe GraphID] -> Maybe GraphID)
-> (NodePaths n -> [Maybe GraphID]) -> NodePaths n -> Maybe GraphID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Maybe GraphID], DotNode n) -> [Maybe GraphID]
forall a b. (a, b) -> a
fst (([Maybe GraphID], DotNode n) -> [Maybe GraphID])
-> (NodePaths n -> ([Maybe GraphID], DotNode n))
-> NodePaths n
-> [Maybe GraphID]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodePaths n -> ([Maybe GraphID], DotNode n)
forall a. HasCallStack => [a] -> a
head (NodePaths n -> Maybe GraphID) -> NodePaths n -> Maybe GraphID
forall a b. (a -> b) -> a -> b
$ NodePaths n
cns

    (NodePaths n
nestedNs, [DotNode n]
ns) = NodePaths n -> (NodePaths n, [DotNode n])
forall n. NodePaths n -> (NodePaths n, [DotNode n])
thisLevel
                     (NodePaths n -> (NodePaths n, [DotNode n]))
-> (NodePaths n -> NodePaths n)
-> NodePaths n
-> (NodePaths n, [DotNode n])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NodePaths n -> NodePaths n)
-> (NodePaths n -> NodePaths n)
-> Bool
-> NodePaths n
-> NodePaths n
forall a. a -> a -> Bool -> a
bool ((([Maybe GraphID], DotNode n) -> ([Maybe GraphID], DotNode n))
-> NodePaths n -> NodePaths n
forall a b. (a -> b) -> [a] -> [b]
map ((([Maybe GraphID], DotNode n) -> ([Maybe GraphID], DotNode n))
 -> NodePaths n -> NodePaths n)
-> (([Maybe GraphID], DotNode n) -> ([Maybe GraphID], DotNode n))
-> NodePaths n
-> NodePaths n
forall a b. (a -> b) -> a -> b
$ ([Maybe GraphID] -> [Maybe GraphID])
-> ([Maybe GraphID], DotNode n) -> ([Maybe GraphID], DotNode n)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first [Maybe GraphID] -> [Maybe GraphID]
forall a. HasCallStack => [a] -> [a]
tail) NodePaths n -> NodePaths n
forall a. a -> a
id (CanonControl n -> Bool
forall n. CanonControl n -> Bool
isGraph CanonControl n
cc)
                     (NodePaths n -> (NodePaths n, [DotNode n]))
-> NodePaths n -> (NodePaths n, [DotNode n])
forall a b. (a -> b) -> a -> b
$ NodePaths n
cns

    es :: [DotEdge n]
es = ((Map (Maybe GraphID) [DotEdge n], [DotEdge n]) -> [DotEdge n])
-> ((Map (Maybe GraphID) [DotEdge n], [DotEdge n]) -> [DotEdge n])
-> Bool
-> (Map (Maybe GraphID) [DotEdge n], [DotEdge n])
-> [DotEdge n]
forall a. a -> a -> Bool -> a
bool ([DotEdge n] -> Maybe [DotEdge n] -> [DotEdge n]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [DotEdge n] -> [DotEdge n])
-> ((Map (Maybe GraphID) [DotEdge n], [DotEdge n])
    -> Maybe [DotEdge n])
-> (Map (Maybe GraphID) [DotEdge n], [DotEdge n])
-> [DotEdge n]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe GraphID
-> Map (Maybe GraphID) [DotEdge n] -> Maybe [DotEdge n]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Maybe GraphID
cID (Map (Maybe GraphID) [DotEdge n] -> Maybe [DotEdge n])
-> ((Map (Maybe GraphID) [DotEdge n], [DotEdge n])
    -> Map (Maybe GraphID) [DotEdge n])
-> (Map (Maybe GraphID) [DotEdge n], [DotEdge n])
-> Maybe [DotEdge n]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (Maybe GraphID) [DotEdge n], [DotEdge n])
-> Map (Maybe GraphID) [DotEdge n]
forall a b. (a, b) -> a
fst) (Map (Maybe GraphID) [DotEdge n], [DotEdge n]) -> [DotEdge n]
forall a b. (a, b) -> b
snd (CanonControl n -> Bool
forall n. CanonControl n -> Bool
isGraph CanonControl n
cc)
         ((Map (Maybe GraphID) [DotEdge n], [DotEdge n]) -> [DotEdge n])
-> (Map (Maybe GraphID) [DotEdge n], [DotEdge n]) -> [DotEdge n]
forall a b. (a -> b) -> a -> b
$ CanonControl n -> (Map (Maybe GraphID) [DotEdge n], [DotEdge n])
forall n. CanonControl n -> EdgeLocations n
clustEs CanonControl n
cc

    gas :: Attributes
gas | CanonControl n -> Bool
forall n. CanonControl n -> Bool
isGraph CanonControl n
cc = CanonControl n -> Attributes
forall n. CanonControl n -> Attributes
topAttrs CanonControl n
cc
        | Bool
otherwise  = GlobalAttributes -> Attributes
attrs (GlobalAttributes -> Attributes)
-> (([Seq (Maybe GraphID)], GlobalAttributes) -> GlobalAttributes)
-> ([Seq (Maybe GraphID)], GlobalAttributes)
-> Attributes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Seq (Maybe GraphID)], GlobalAttributes) -> GlobalAttributes
forall a b. (a, b) -> b
snd (([Seq (Maybe GraphID)], GlobalAttributes) -> Attributes)
-> ([Seq (Maybe GraphID)], GlobalAttributes) -> Attributes
forall a b. (a -> b) -> a -> b
$ CanonControl n -> ClusterLookup
forall n. CanonControl n -> ClusterLookup
clusters CanonControl n
cc ClusterLookup
-> Maybe GraphID -> ([Seq (Maybe GraphID)], GlobalAttributes)
forall k a. Ord k => Map k a -> k -> a
Map.! Maybe GraphID
cID

    subGs :: [DotSubGraph n]
subGs = (NodePaths n -> DotSubGraph n) -> [NodePaths n] -> [DotSubGraph n]
forall a b. (a -> b) -> [a] -> [b]
map (CanonControl n -> NodePaths n -> DotSubGraph n
forall n. CanonControl n -> NodePaths n -> DotSubGraph n
makeGrouping (CanonControl n -> NodePaths n -> DotSubGraph n)
-> CanonControl n -> NodePaths n -> DotSubGraph n
forall a b. (a -> b) -> a -> b
$ CanonControl n
cc { isGraph = False })
            ([NodePaths n] -> [DotSubGraph n])
-> (NodePaths n -> [NodePaths n]) -> NodePaths n -> [DotSubGraph n]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Maybe GraphID], DotNode n)
 -> ([Maybe GraphID], DotNode n) -> Bool)
-> NodePaths n -> [NodePaths n]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (Maybe (Maybe GraphID) -> Maybe (Maybe GraphID) -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Maybe (Maybe GraphID) -> Maybe (Maybe GraphID) -> Bool)
-> (([Maybe GraphID], DotNode n) -> Maybe (Maybe GraphID))
-> ([Maybe GraphID], DotNode n)
-> ([Maybe GraphID], DotNode n)
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ([Maybe GraphID] -> Maybe (Maybe GraphID)
forall a. [a] -> Maybe a
listToMaybe ([Maybe GraphID] -> Maybe (Maybe GraphID))
-> (([Maybe GraphID], DotNode n) -> [Maybe GraphID])
-> ([Maybe GraphID], DotNode n)
-> Maybe (Maybe GraphID)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Maybe GraphID], DotNode n) -> [Maybe GraphID]
forall a b. (a, b) -> a
fst))
            (NodePaths n -> [DotSubGraph n]) -> NodePaths n -> [DotSubGraph n]
forall a b. (a -> b) -> a -> b
$ NodePaths n
nestedNs

    stmts :: DotStatements n
stmts = CanonicaliseOptions
-> Attributes -> DotStatements n -> DotStatements n
forall n.
CanonicaliseOptions
-> Attributes -> DotStatements n -> DotStatements n
setGlobal (CanonControl n -> CanonicaliseOptions
forall n. CanonControl n -> CanonicaliseOptions
cOpts CanonControl n
cc) Attributes
gas
            (DotStatements n -> DotStatements n)
-> DotStatements n -> DotStatements n
forall a b. (a -> b) -> a -> b
$ DotStmts { attrStmts :: [GlobalAttributes]
attrStmts = []
                       , subGraphs :: [DotSubGraph n]
subGraphs = [DotSubGraph n]
subGs
                       , nodeStmts :: [DotNode n]
nodeStmts = [DotNode n]
ns
                       , edgeStmts :: [DotEdge n]
edgeStmts = [DotEdge n]
es
                       }

setGlobal :: CanonicaliseOptions
             -> Attributes -- Specified cluster attributes
             -> DotStatements n
             -> DotStatements n
setGlobal :: forall n.
CanonicaliseOptions
-> Attributes -> DotStatements n -> DotStatements n
setGlobal CanonicaliseOptions
opts Attributes
as DotStatements n
stmts = DotStatements n
stmts { attrStmts = globs'
                                , subGraphs = sgs'
                                , nodeStmts = ns'
                                , edgeStmts = es'
                                }
  where
    sgs :: [DotSubGraph n]
sgs = DotStatements n -> [DotSubGraph n]
forall n. DotStatements n -> [DotSubGraph n]
subGraphs DotStatements n
stmts
    sStmts :: [DotStatements n]
sStmts = (DotSubGraph n -> DotStatements n)
-> [DotSubGraph n] -> [DotStatements n]
forall a b. (a -> b) -> [a] -> [b]
map DotSubGraph n -> DotStatements n
forall n. DotSubGraph n -> DotStatements n
subGraphStmts [DotSubGraph n]
sgs
    ns :: [DotNode n]
ns = DotStatements n -> [DotNode n]
forall n. DotStatements n -> [DotNode n]
nodeStmts DotStatements n
stmts
    es :: [DotEdge n]
es = DotStatements n -> [DotEdge n]
forall n. DotStatements n -> [DotEdge n]
edgeStmts DotStatements n
stmts

    sGlobs :: [(Attributes, Attributes, Attributes)]
sGlobs = (DotStatements n -> (Attributes, Attributes, Attributes))
-> [DotStatements n] -> [(Attributes, Attributes, Attributes)]
forall a b. (a -> b) -> [a] -> [b]
map ([GlobalAttributes] -> (Attributes, Attributes, Attributes)
partitionGlobal ([GlobalAttributes] -> (Attributes, Attributes, Attributes))
-> (DotStatements n -> [GlobalAttributes])
-> DotStatements n
-> (Attributes, Attributes, Attributes)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DotStatements n -> [GlobalAttributes]
forall n. DotStatements n -> [GlobalAttributes]
attrStmts) [DotStatements n]
sStmts

    ([Attributes]
sgas,[Attributes]
snas,[Attributes]
seas) = [(Attributes, Attributes, Attributes)]
-> ([Attributes], [Attributes], [Attributes])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 [(Attributes, Attributes, Attributes)]
sGlobs

    gas' :: Attributes
gas' = Attributes
as -- Can't change graph attrs! Need these!
    nas' :: Attributes
nas' = CanonicaliseOptions
-> (DotStatements n -> [DotNode n])
-> [Attributes]
-> [DotStatements n]
-> [Attributes]
-> Attributes
forall n a.
CanonicaliseOptions
-> (DotStatements n -> [a])
-> [Attributes]
-> [DotStatements n]
-> [Attributes]
-> Attributes
getCommonGlobs CanonicaliseOptions
opts DotStatements n -> [DotNode n]
forall n. DotStatements n -> [DotNode n]
nodeStmts [Attributes]
snas [DotStatements n]
sStmts ([Attributes] -> Attributes) -> [Attributes] -> Attributes
forall a b. (a -> b) -> a -> b
$ (DotNode n -> Attributes) -> [DotNode n] -> [Attributes]
forall a b. (a -> b) -> [a] -> [b]
map DotNode n -> Attributes
forall n. DotNode n -> Attributes
nodeAttributes [DotNode n]
ns
    eas' :: Attributes
eas' = CanonicaliseOptions
-> (DotStatements n -> [DotEdge n])
-> [Attributes]
-> [DotStatements n]
-> [Attributes]
-> Attributes
forall n a.
CanonicaliseOptions
-> (DotStatements n -> [a])
-> [Attributes]
-> [DotStatements n]
-> [Attributes]
-> Attributes
getCommonGlobs CanonicaliseOptions
opts DotStatements n -> [DotEdge n]
forall n. DotStatements n -> [DotEdge n]
edgeStmts [Attributes]
seas [DotStatements n]
sStmts ([Attributes] -> Attributes) -> [Attributes] -> Attributes
forall a b. (a -> b) -> a -> b
$ (DotEdge n -> Attributes) -> [DotEdge n] -> [Attributes]
forall a b. (a -> b) -> [a] -> [b]
map DotEdge n -> Attributes
forall n. DotEdge n -> Attributes
edgeAttributes [DotEdge n]
es

    globs' :: [GlobalAttributes]
globs' = [GlobalAttributes] -> [GlobalAttributes]
nonEmptyGAs [ Attributes -> GlobalAttributes
GraphAttrs Attributes
gas'
                         , Attributes -> GlobalAttributes
NodeAttrs  Attributes
nas'
                         , Attributes -> GlobalAttributes
EdgeAttrs  Attributes
eas'
                         ]
    ns' :: [DotNode n]
ns' = (DotNode n -> DotNode n) -> [DotNode n] -> [DotNode n]
forall a b. (a -> b) -> [a] -> [b]
map (\DotNode n
dn -> DotNode n
dn { nodeAttributes = nodeAttributes dn \\ nas' }) [DotNode n]
ns
    es' :: [DotEdge n]
es' = (DotEdge n -> DotEdge n) -> [DotEdge n] -> [DotEdge n]
forall a b. (a -> b) -> [a] -> [b]
map (\DotEdge n
de -> DotEdge n
de { edgeAttributes = edgeAttributes de \\ eas' }) [DotEdge n]
es

    sgas' :: [Attributes]
sgas' = Attributes -> [Attributes] -> [Attributes]
updateGraphGlobs Attributes
gas' [Attributes]
sgas
    snas' :: [Attributes]
snas' = (Attributes -> Attributes) -> [Attributes] -> [Attributes]
forall a b. (a -> b) -> [a] -> [b]
map (Attributes -> Attributes -> Attributes
forall a. Eq a => [a] -> [a] -> [a]
\\ Attributes
nas') [Attributes]
snas
    seas' :: [Attributes]
seas' = (Attributes -> Attributes) -> [Attributes] -> [Attributes]
forall a b. (a -> b) -> [a] -> [b]
map (Attributes -> Attributes -> Attributes
forall a. Eq a => [a] -> [a] -> [a]
\\ Attributes
eas') [Attributes]
seas

    sGlobs' :: [(Attributes, Attributes, Attributes)]
sGlobs' = [Attributes]
-> [Attributes]
-> [Attributes]
-> [(Attributes, Attributes, Attributes)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Attributes]
sgas' [Attributes]
snas' [Attributes]
seas'
    sStmts' :: [DotStatements n]
sStmts' = (DotStatements n
 -> (Attributes, Attributes, Attributes) -> DotStatements n)
-> [DotStatements n]
-> [(Attributes, Attributes, Attributes)]
-> [DotStatements n]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\ DotStatements n
sSt (Attributes, Attributes, Attributes)
sGl -> DotStatements n
sSt { attrStmts = nonEmptyGAs $ unPartitionGlobal sGl })
                      [DotStatements n]
sStmts
                      [(Attributes, Attributes, Attributes)]
sGlobs'

    sgs' :: [DotSubGraph n]
sgs' = (DotSubGraph n -> DotStatements n -> DotSubGraph n)
-> [DotSubGraph n] -> [DotStatements n] -> [DotSubGraph n]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\ DotSubGraph n
sg DotStatements n
sSt -> DotSubGraph n
sg { subGraphStmts = sSt }) [DotSubGraph n]
sgs [DotStatements n]
sStmts'

updateGraphGlobs :: Attributes -> [Attributes] -> [Attributes]
updateGraphGlobs :: Attributes -> [Attributes] -> [Attributes]
updateGraphGlobs Attributes
gas = (Attributes -> Attributes) -> [Attributes] -> [Attributes]
forall a b. (a -> b) -> [a] -> [b]
map Attributes -> Attributes
go
  where
    gasS :: Set Attribute
gasS = Attributes -> Set Attribute
forall a. Ord a => [a] -> Set a
Set.fromList Attributes
gas

    override :: SAttrs
override = Attributes -> SAttrs
toSAttr (Attributes -> SAttrs) -> Attributes -> SAttrs
forall a b. (a -> b) -> a -> b
$ Attributes -> Attributes
nonSameDefaults Attributes
gas

    -- * Remove any identical values
    -- * Override any different values
    go :: Attributes -> Attributes
go = Set Attribute -> Attributes
forall a. Set a -> [a]
Set.toList
         (Set Attribute -> Attributes)
-> (Attributes -> Set Attribute) -> Attributes -> Attributes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set Attribute -> Set Attribute -> Set Attribute
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set Attribute
gasS) -- Remove identical values
         (Set Attribute -> Set Attribute)
-> (Attributes -> Set Attribute) -> Attributes -> Set Attribute
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SAttrs -> Set Attribute
unSameSet
         (SAttrs -> Set Attribute)
-> (Attributes -> SAttrs) -> Attributes -> Set Attribute
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SAttrs -> SAttrs -> SAttrs
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` SAttrs
override) -- Keeps existing values of constructors
         (SAttrs -> SAttrs)
-> (Attributes -> SAttrs) -> Attributes -> SAttrs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attributes -> SAttrs
toSAttr

nonSameDefaults :: Attributes -> Attributes
nonSameDefaults :: Attributes -> Attributes
nonSameDefaults = (Attribute -> Maybe Attribute) -> Attributes -> Attributes
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\ Attribute
a -> [ Attribute
a' | Attribute
a' <- Attribute -> Maybe Attribute
defaultAttributeValue Attribute
a, Attribute
a' Attribute -> Attribute -> Bool
forall a. Eq a => a -> a -> Bool
/= Attribute
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 :: forall n a.
CanonicaliseOptions
-> (DotStatements n -> [a])
-> [Attributes]
-> [DotStatements n]
-> [Attributes]
-> Attributes
getCommonGlobs CanonicaliseOptions
opts DotStatements n -> [a]
f [Attributes]
sas [DotStatements n]
stmts [Attributes]
as
  | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ CanonicaliseOptions -> Bool
groupAttributes CanonicaliseOptions
opts = []
  | Bool
otherwise = case [Attributes]
sas' [Attributes] -> [Attributes] -> [Attributes]
forall a. [a] -> [a] -> [a]
++ [Attributes]
as of
                  []  -> []
                  [Attributes
_] -> []
                  [Attributes]
as' -> Set Attribute -> Attributes
forall a. Set a -> [a]
Set.toList (Set Attribute -> Attributes)
-> ([Set Attribute] -> Set Attribute)
-> [Set Attribute]
-> Attributes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set Attribute -> Set Attribute -> Set Attribute)
-> [Set Attribute] -> Set Attribute
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Set Attribute -> Set Attribute -> Set Attribute
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection
                         ([Set Attribute] -> Attributes) -> [Set Attribute] -> Attributes
forall a b. (a -> b) -> a -> b
$ (Attributes -> Set Attribute) -> [Attributes] -> [Set Attribute]
forall a b. (a -> b) -> [a] -> [b]
map Attributes -> Set Attribute
forall a. Ord a => [a] -> Set a
Set.fromList [Attributes]
as'
  where
    sas' :: [Attributes]
sas' = (DotStatements n -> [a])
-> [Attributes] -> [DotStatements n] -> [Attributes]
forall n a.
(DotStatements n -> [a])
-> [Attributes] -> [DotStatements n] -> [Attributes]
keepIfAny DotStatements n -> [a]
f [Attributes]
sas [DotStatements n]
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 :: forall n a.
(DotStatements n -> [a])
-> [Attributes] -> [DotStatements n] -> [Attributes]
keepIfAny DotStatements n -> [a]
f [Attributes]
sas = ((Attributes, Bool) -> Attributes)
-> [(Attributes, Bool)] -> [Attributes]
forall a b. (a -> b) -> [a] -> [b]
map (Attributes, Bool) -> Attributes
forall a b. (a, b) -> a
fst ([(Attributes, Bool)] -> [Attributes])
-> ([DotStatements n] -> [(Attributes, Bool)])
-> [DotStatements n]
-> [Attributes]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Attributes, Bool) -> Bool)
-> [(Attributes, Bool)] -> [(Attributes, Bool)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Attributes, Bool) -> Bool
forall a b. (a, b) -> b
snd ([(Attributes, Bool)] -> [(Attributes, Bool)])
-> ([DotStatements n] -> [(Attributes, Bool)])
-> [DotStatements n]
-> [(Attributes, Bool)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Attributes] -> [Bool] -> [(Attributes, Bool)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Attributes]
sas ([Bool] -> [(Attributes, Bool)])
-> ([DotStatements n] -> [Bool])
-> [DotStatements n]
-> [(Attributes, Bool)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DotStatements n -> Bool) -> [DotStatements n] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map ((DotStatements n -> [a]) -> DotStatements n -> Bool
forall n a. (DotStatements n -> [a]) -> DotStatements n -> Bool
hasAny DotStatements n -> [a]
f)

hasAny      :: (DotStatements n -> [a]) -> DotStatements n -> Bool
hasAny :: forall n a. (DotStatements n -> [a]) -> DotStatements n -> Bool
hasAny DotStatements n -> [a]
f DotStatements n
ds = Bool -> Bool
not ([a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([a] -> Bool) -> [a] -> Bool
forall a b. (a -> b) -> a -> b
$ DotStatements n -> [a]
f DotStatements n
ds) Bool -> Bool -> Bool
|| (DotSubGraph n -> Bool) -> [DotSubGraph n] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((DotStatements n -> [a]) -> DotStatements n -> Bool
forall n a. (DotStatements n -> [a]) -> DotStatements n -> Bool
hasAny DotStatements n -> [a]
f (DotStatements n -> Bool)
-> (DotSubGraph n -> DotStatements n) -> DotSubGraph n -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DotSubGraph n -> DotStatements n
forall n. DotSubGraph n -> DotStatements n
subGraphStmts) (DotStatements n -> [DotSubGraph n]
forall n. DotStatements n -> [DotSubGraph n]
subGraphs DotStatements n
ds)

promoteDSG     :: DotSubGraph n -> DotGraph n
promoteDSG :: forall n. DotSubGraph n -> DotGraph n
promoteDSG DotSubGraph n
dsg = DotGraph { strictGraph :: Bool
strictGraph     = Bool
forall a. HasCallStack => a
undefined
                          , directedGraph :: Bool
directedGraph   = Bool
forall a. HasCallStack => a
undefined
                          , graphID :: Maybe GraphID
graphID         = DotSubGraph n -> Maybe GraphID
forall n. DotSubGraph n -> Maybe GraphID
subGraphID DotSubGraph n
dsg
                          , graphStatements :: DotStatements n
graphStatements = DotSubGraph n -> DotStatements n
forall n. DotSubGraph n -> DotStatements n
subGraphStmts DotSubGraph n
dsg
                          }

-- Same as compare for lists, except shorter lists are GT
compLists :: (Ord a) => [a] -> [a] -> Ordering
compLists :: forall a. Ord a => [a] -> [a] -> Ordering
compLists []     []     = Ordering
EQ
compLists []     [a]
_      = Ordering
GT
compLists [a]
_      []     = Ordering
LT
compLists (a
x:[a]
xs) (a
y:[a]
ys) = case a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
x a
y of
                            Ordering
EQ  -> [a] -> [a] -> Ordering
forall a. Ord a => [a] -> [a] -> Ordering
compLists [a]
xs [a]
ys
                            Ordering
oth -> Ordering
oth

nonEmptyGAs :: [GlobalAttributes] -> [GlobalAttributes]
nonEmptyGAs :: [GlobalAttributes] -> [GlobalAttributes]
nonEmptyGAs = (GlobalAttributes -> Bool)
-> [GlobalAttributes] -> [GlobalAttributes]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (GlobalAttributes -> Bool) -> GlobalAttributes -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attributes -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Attributes -> Bool)
-> (GlobalAttributes -> Attributes) -> GlobalAttributes -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GlobalAttributes -> Attributes
attrs)

-- Assign each edge into the cluster it belongs in.
edgeClusters    :: (Ord n) => NodeLookup n -> [DotEdge n]
                   -> EdgeLocations n
edgeClusters :: forall n. Ord n => NodeLookup n -> [DotEdge n] -> EdgeLocations n
edgeClusters NodeLookup n
nl = ([([Maybe GraphID], DotEdge n)] -> EdgeClusters n
forall {b'}. [([Maybe GraphID], b')] -> Map (Maybe GraphID) [b']
toM ([([Maybe GraphID], DotEdge n)] -> EdgeClusters n)
-> ([([Maybe GraphID], DotEdge n)] -> [DotEdge n])
-> ([([Maybe GraphID], DotEdge n)], [([Maybe GraphID], DotEdge n)])
-> (EdgeClusters n, [DotEdge n])
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** (([Maybe GraphID], DotEdge n) -> DotEdge n)
-> [([Maybe GraphID], DotEdge n)] -> [DotEdge n]
forall a b. (a -> b) -> [a] -> [b]
map ([Maybe GraphID], DotEdge n) -> DotEdge n
forall a b. (a, b) -> b
snd) (([([Maybe GraphID], DotEdge n)], [([Maybe GraphID], DotEdge n)])
 -> (EdgeClusters n, [DotEdge n]))
-> ([DotEdge n]
    -> ([([Maybe GraphID], DotEdge n)],
        [([Maybe GraphID], DotEdge n)]))
-> [DotEdge n]
-> (EdgeClusters n, [DotEdge n])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Maybe GraphID], DotEdge n) -> Bool)
-> [([Maybe GraphID], DotEdge n)]
-> ([([Maybe GraphID], DotEdge n)], [([Maybe GraphID], DotEdge n)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (Bool -> Bool
not (Bool -> Bool)
-> (([Maybe GraphID], DotEdge n) -> Bool)
-> ([Maybe GraphID], DotEdge n)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe GraphID] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Maybe GraphID] -> Bool)
-> (([Maybe GraphID], DotEdge n) -> [Maybe GraphID])
-> ([Maybe GraphID], DotEdge n)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Maybe GraphID], DotEdge n) -> [Maybe GraphID]
forall a b. (a, b) -> a
fst)
                  ([([Maybe GraphID], DotEdge n)]
 -> ([([Maybe GraphID], DotEdge n)],
     [([Maybe GraphID], DotEdge n)]))
-> ([DotEdge n] -> [([Maybe GraphID], DotEdge n)])
-> [DotEdge n]
-> ([([Maybe GraphID], DotEdge n)], [([Maybe GraphID], DotEdge n)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DotEdge n -> ([Maybe GraphID], DotEdge n))
-> [DotEdge n] -> [([Maybe GraphID], DotEdge n)]
forall a b. (a -> b) -> [a] -> [b]
map DotEdge n -> ([Maybe GraphID], DotEdge n)
inClust
  where
    nl' :: Map n [Maybe GraphID]
nl' = ((Seq (Maybe GraphID), Attributes) -> [Maybe GraphID])
-> NodeLookup n -> Map n [Maybe GraphID]
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Seq (Maybe GraphID) -> [Maybe GraphID]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (Seq (Maybe GraphID) -> [Maybe GraphID])
-> ((Seq (Maybe GraphID), Attributes) -> Seq (Maybe GraphID))
-> (Seq (Maybe GraphID), Attributes)
-> [Maybe GraphID]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Seq (Maybe GraphID), Attributes) -> Seq (Maybe GraphID)
forall a b. (a, b) -> a
fst) NodeLookup n
nl
    -- DotEdge n -> (Path, DotEdge n)
    inClust :: DotEdge n -> ([Maybe GraphID], DotEdge n)
inClust de :: DotEdge n
de@(DotEdge n
n1 n
n2 Attributes
_) = (([Maybe GraphID] -> DotEdge n -> ([Maybe GraphID], DotEdge n))
-> DotEdge n -> [Maybe GraphID] -> ([Maybe GraphID], DotEdge n)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (,) DotEdge n
de)
                                   ([Maybe GraphID] -> ([Maybe GraphID], DotEdge n))
-> ([(Maybe GraphID, Maybe GraphID)] -> [Maybe GraphID])
-> [(Maybe GraphID, Maybe GraphID)]
-> ([Maybe GraphID], DotEdge n)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Maybe GraphID, Maybe GraphID) -> Maybe GraphID)
-> [(Maybe GraphID, Maybe GraphID)] -> [Maybe GraphID]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe GraphID, Maybe GraphID) -> Maybe GraphID
forall a b. (a, b) -> a
fst ([(Maybe GraphID, Maybe GraphID)] -> [Maybe GraphID])
-> ([(Maybe GraphID, Maybe GraphID)]
    -> [(Maybe GraphID, Maybe GraphID)])
-> [(Maybe GraphID, Maybe GraphID)]
-> [Maybe GraphID]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Maybe GraphID, Maybe GraphID) -> Bool)
-> [(Maybe GraphID, Maybe GraphID)]
-> [(Maybe GraphID, Maybe GraphID)]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile ((Maybe GraphID -> Maybe GraphID -> Bool)
-> (Maybe GraphID, Maybe GraphID) -> Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Maybe GraphID -> Maybe GraphID -> Bool
forall a. Eq a => a -> a -> Bool
(==))
                                   ([(Maybe GraphID, Maybe GraphID)] -> ([Maybe GraphID], DotEdge n))
-> [(Maybe GraphID, Maybe GraphID)] -> ([Maybe GraphID], DotEdge n)
forall a b. (a -> b) -> a -> b
$ [Maybe GraphID]
-> [Maybe GraphID] -> [(Maybe GraphID, Maybe GraphID)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Map n [Maybe GraphID]
nl' Map n [Maybe GraphID] -> n -> [Maybe GraphID]
forall k a. Ord k => Map k a -> k -> a
Map.! n
n1) (Map n [Maybe GraphID]
nl' Map n [Maybe GraphID] -> n -> [Maybe GraphID]
forall k a. Ord k => Map k a -> k -> a
Map.! n
n2)
    toM :: [([Maybe GraphID], b')] -> Map (Maybe GraphID) [b']
toM = (DList b' -> [b'])
-> Map (Maybe GraphID) (DList b') -> Map (Maybe GraphID) [b']
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map DList b' -> [b']
forall a. DList a -> [a]
DList.toList
          (Map (Maybe GraphID) (DList b') -> Map (Maybe GraphID) [b'])
-> ([([Maybe GraphID], b')] -> Map (Maybe GraphID) (DList b'))
-> [([Maybe GraphID], b')]
-> Map (Maybe GraphID) [b']
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DList b' -> DList b' -> DList b')
-> [(Maybe GraphID, DList b')] -> Map (Maybe GraphID) (DList b')
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith ((DList b' -> DList b' -> DList b')
-> DList b' -> DList b' -> DList b'
forall a b c. (a -> b -> c) -> b -> a -> c
flip DList b' -> DList b' -> DList b'
forall a. DList a -> DList a -> DList a
DList.append)
          ([(Maybe GraphID, DList b')] -> Map (Maybe GraphID) (DList b'))
-> ([([Maybe GraphID], b')] -> [(Maybe GraphID, DList b')])
-> [([Maybe GraphID], b')]
-> Map (Maybe GraphID) (DList b')
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Maybe GraphID], b') -> (Maybe GraphID, DList b'))
-> [([Maybe GraphID], b')] -> [(Maybe GraphID, DList b')]
forall a b. (a -> b) -> [a] -> [b]
map ([Maybe GraphID] -> Maybe GraphID
forall a. HasCallStack => [a] -> a
last ([Maybe GraphID] -> Maybe GraphID)
-> (b' -> DList b')
-> ([Maybe GraphID], b')
-> (Maybe GraphID, DList b')
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** b' -> DList b'
forall a. a -> DList a
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 :: forall (dg :: * -> *) n. DotRepr dg n => dg n -> DotGraph n
transitiveReduction = CanonicaliseOptions -> dg n -> DotGraph n
forall (dg :: * -> *) n.
DotRepr dg n =>
CanonicaliseOptions -> dg n -> DotGraph n
transitiveReductionOptions CanonicaliseOptions
defaultCanonOptions

transitiveReductionOptions         :: (DotRepr dg n) => CanonicaliseOptions
                                      -> dg n -> DotGraph n
transitiveReductionOptions :: forall (dg :: * -> *) n.
DotRepr dg n =>
CanonicaliseOptions -> dg n -> DotGraph n
transitiveReductionOptions CanonicaliseOptions
opts dg n
dg = DotGraph n
cdg { strictGraph = graphIsStrict dg
                                         , directedGraph = graphIsDirected dg
                                         }
  where
    cdg :: DotGraph n
cdg = CanonicaliseOptions
-> Maybe GraphID
-> GlobalAttributes
-> ClusterLookup
-> NodeLookup n
-> [DotEdge n]
-> DotGraph n
forall n.
Ord n =>
CanonicaliseOptions
-> Maybe GraphID
-> GlobalAttributes
-> ClusterLookup
-> NodeLookup n
-> [DotEdge n]
-> DotGraph n
createCanonical CanonicaliseOptions
opts (dg n -> Maybe GraphID
forall (dg :: * -> *) n. DotRepr dg n => dg n -> Maybe GraphID
getID dg n
dg) GlobalAttributes
gas ClusterLookup
cl NodeLookup n
nl [DotEdge n]
es'
    (GlobalAttributes
gas, ClusterLookup
cl) = dg n -> (GlobalAttributes, ClusterLookup)
forall (dg :: * -> *) n.
DotRepr dg n =>
dg n -> (GlobalAttributes, ClusterLookup)
graphStructureInformationClean dg n
dg
    nl :: NodeLookup n
nl = Bool -> dg n -> NodeLookup n
forall (dg :: * -> *) n.
DotRepr dg n =>
Bool -> dg n -> NodeLookup n
nodeInformationClean Bool
True dg n
dg
    es :: [DotEdge n]
es = Bool -> dg n -> [DotEdge n]
forall (dg :: * -> *) n.
DotRepr dg n =>
Bool -> dg n -> [DotEdge n]
edgeInformationClean Bool
True dg n
dg
    es' :: [DotEdge n]
es' | dg n -> Bool
forall (dg :: * -> *) n. DotRepr dg n => dg n -> Bool
graphIsDirected dg n
dg = [DotEdge n] -> [DotEdge n]
forall n. Ord n => [DotEdge n] -> [DotEdge n]
rmTransEdges [DotEdge n]
es
        | Bool
otherwise          = [DotEdge n]
es

rmTransEdges    :: (Ord n) => [DotEdge n] -> [DotEdge n]
rmTransEdges :: forall n. Ord n => [DotEdge n] -> [DotEdge n]
rmTransEdges [] = []
rmTransEdges [DotEdge n]
es = (TaggedValues n -> [DotEdge n]) -> [TaggedValues n] -> [DotEdge n]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (((Int, DotEdge n) -> DotEdge n)
-> [(Int, DotEdge n)] -> [DotEdge n]
forall a b. (a -> b) -> [a] -> [b]
map (Int, DotEdge n) -> DotEdge n
forall a b. (a, b) -> b
snd ([(Int, DotEdge n)] -> [DotEdge n])
-> (TaggedValues n -> [(Int, DotEdge n)])
-> TaggedValues n
-> [DotEdge n]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TaggedValues n -> [(Int, DotEdge n)]
forall n. TaggedValues n -> [TaggedEdge n]
outgoing) ([TaggedValues n] -> [DotEdge n])
-> [TaggedValues n] -> [DotEdge n]
forall a b. (a -> b) -> a -> b
$ Map n (TaggedValues n) -> [TaggedValues n]
forall k a. Map k a -> [a]
Map.elems Map n (TaggedValues n)
esM
  where
    tes :: [(Int, DotEdge n)]
tes = [DotEdge n] -> [(Int, DotEdge n)]
forall n. [DotEdge n] -> [TaggedEdge n]
tagEdges [DotEdge n]
es

    esMS :: StateT (Map n (TaggedValues n), TagSet) Identity ()
esMS = do [(Int, DotEdge n)]
-> StateT (Map n (TaggedValues n), TagSet) Identity ()
forall n. Ord n => [TaggedEdge n] -> TagState n ()
edgeGraph [(Int, DotEdge n)]
tes
              [n]
ns <- (Map n (TaggedValues n) -> [n]) -> TagState n [n]
forall n a. (TagMap n -> a) -> TagState n a
getsMap Map n (TaggedValues n) -> [n]
forall k a. Map k a -> [k]
Map.keys
              (n -> StateT (Map n (TaggedValues n), TagSet) Identity ())
-> [n] -> StateT (Map n (TaggedValues n), TagSet) Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Int -> n -> StateT (Map n (TaggedValues n), TagSet) Identity ()
forall n. Ord n => Int -> n -> TagState n ()
traverseTag Int
zeroTag) [n]
ns

    esM :: Map n (TaggedValues n)
esM = (Map n (TaggedValues n), TagSet) -> Map n (TaggedValues n)
forall a b. (a, b) -> a
fst ((Map n (TaggedValues n), TagSet) -> Map n (TaggedValues n))
-> (Map n (TaggedValues n), TagSet) -> Map n (TaggedValues n)
forall a b. (a -> b) -> a -> b
$ StateT (Map n (TaggedValues n), TagSet) Identity ()
-> (Map n (TaggedValues n), TagSet)
-> (Map n (TaggedValues n), TagSet)
forall s a. State s a -> s -> s
execState StateT (Map n (TaggedValues n), TagSet) Identity ()
esMS (Map n (TaggedValues n)
forall k a. Map k a
Map.empty, TagSet
forall a. Set a
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 :: Int
zeroTag = Int
0

tagEdges :: [DotEdge n] -> [TaggedEdge n]
tagEdges :: forall n. [DotEdge n] -> [TaggedEdge n]
tagEdges = [Int] -> [DotEdge n] -> [(Int, DotEdge n)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Int -> Int
forall a. Enum a => a -> a
succ Int
zeroTag)..]

data TaggedValues n = TV { forall n. TaggedValues n -> Bool
marked   :: Bool
                         , forall n. TaggedValues n -> [TaggedEdge n]
incoming :: [TaggedEdge n]
                         , forall n. TaggedValues n -> [TaggedEdge n]
outgoing :: [TaggedEdge n]
                         }
                    deriving (TaggedValues n -> TaggedValues n -> Bool
(TaggedValues n -> TaggedValues n -> Bool)
-> (TaggedValues n -> TaggedValues n -> Bool)
-> Eq (TaggedValues n)
forall n. Eq n => TaggedValues n -> TaggedValues n -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall n. Eq n => TaggedValues n -> TaggedValues n -> Bool
== :: TaggedValues n -> TaggedValues n -> Bool
$c/= :: forall n. Eq n => TaggedValues n -> TaggedValues n -> Bool
/= :: TaggedValues n -> TaggedValues n -> Bool
Eq, Eq (TaggedValues n)
Eq (TaggedValues n) =>
(TaggedValues n -> TaggedValues n -> Ordering)
-> (TaggedValues n -> TaggedValues n -> Bool)
-> (TaggedValues n -> TaggedValues n -> Bool)
-> (TaggedValues n -> TaggedValues n -> Bool)
-> (TaggedValues n -> TaggedValues n -> Bool)
-> (TaggedValues n -> TaggedValues n -> TaggedValues n)
-> (TaggedValues n -> TaggedValues n -> TaggedValues n)
-> Ord (TaggedValues n)
TaggedValues n -> TaggedValues n -> Bool
TaggedValues n -> TaggedValues n -> Ordering
TaggedValues n -> TaggedValues n -> TaggedValues n
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall n. Ord n => Eq (TaggedValues n)
forall n. Ord n => TaggedValues n -> TaggedValues n -> Bool
forall n. Ord n => TaggedValues n -> TaggedValues n -> Ordering
forall n.
Ord n =>
TaggedValues n -> TaggedValues n -> TaggedValues n
$ccompare :: forall n. Ord n => TaggedValues n -> TaggedValues n -> Ordering
compare :: TaggedValues n -> TaggedValues n -> Ordering
$c< :: forall n. Ord n => TaggedValues n -> TaggedValues n -> Bool
< :: TaggedValues n -> TaggedValues n -> Bool
$c<= :: forall n. Ord n => TaggedValues n -> TaggedValues n -> Bool
<= :: TaggedValues n -> TaggedValues n -> Bool
$c> :: forall n. Ord n => TaggedValues n -> TaggedValues n -> Bool
> :: TaggedValues n -> TaggedValues n -> Bool
$c>= :: forall n. Ord n => TaggedValues n -> TaggedValues n -> Bool
>= :: TaggedValues n -> TaggedValues n -> Bool
$cmax :: forall n.
Ord n =>
TaggedValues n -> TaggedValues n -> TaggedValues n
max :: TaggedValues n -> TaggedValues n -> TaggedValues n
$cmin :: forall n.
Ord n =>
TaggedValues n -> TaggedValues n -> TaggedValues n
min :: TaggedValues n -> TaggedValues n -> TaggedValues n
Ord, Int -> TaggedValues n -> ShowS
[TaggedValues n] -> ShowS
TaggedValues n -> String
(Int -> TaggedValues n -> ShowS)
-> (TaggedValues n -> String)
-> ([TaggedValues n] -> ShowS)
-> Show (TaggedValues n)
forall n. Show n => Int -> TaggedValues n -> ShowS
forall n. Show n => [TaggedValues n] -> ShowS
forall n. Show n => TaggedValues n -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall n. Show n => Int -> TaggedValues n -> ShowS
showsPrec :: Int -> TaggedValues n -> ShowS
$cshow :: forall n. Show n => TaggedValues n -> String
show :: TaggedValues n -> String
$cshowList :: forall n. Show n => [TaggedValues n] -> ShowS
showList :: [TaggedValues n] -> ShowS
Show, ReadPrec [TaggedValues n]
ReadPrec (TaggedValues n)
Int -> ReadS (TaggedValues n)
ReadS [TaggedValues n]
(Int -> ReadS (TaggedValues n))
-> ReadS [TaggedValues n]
-> ReadPrec (TaggedValues n)
-> ReadPrec [TaggedValues n]
-> Read (TaggedValues n)
forall n. Read n => ReadPrec [TaggedValues n]
forall n. Read n => ReadPrec (TaggedValues n)
forall n. Read n => Int -> ReadS (TaggedValues n)
forall n. Read n => ReadS [TaggedValues n]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: forall n. Read n => Int -> ReadS (TaggedValues n)
readsPrec :: Int -> ReadS (TaggedValues n)
$creadList :: forall n. Read n => ReadS [TaggedValues n]
readList :: ReadS [TaggedValues n]
$creadPrec :: forall n. Read n => ReadPrec (TaggedValues n)
readPrec :: ReadPrec (TaggedValues n)
$creadListPrec :: forall n. Read n => ReadPrec [TaggedValues n]
readListPrec :: ReadPrec [TaggedValues n]
Read)

defTV :: TaggedValues n
defTV :: forall n. TaggedValues n
defTV = Bool -> [TaggedEdge n] -> [TaggedEdge n] -> TaggedValues n
forall n.
Bool -> [TaggedEdge n] -> [TaggedEdge n] -> TaggedValues n
TV Bool
False [] []

type TagMap n = Map n (TaggedValues n)

type TagState n a = State (TagMap n, TagSet) a

getMap :: TagState n (TagMap n)
getMap :: forall n. TagState n (TagMap n)
getMap = ((TagMap n, TagSet) -> TagMap n)
-> StateT (TagMap n, TagSet) Identity (TagMap n)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (TagMap n, TagSet) -> TagMap n
forall a b. (a, b) -> a
fst

getsMap   :: (TagMap n -> a) -> TagState n a
getsMap :: forall n a. (TagMap n -> a) -> TagState n a
getsMap TagMap n -> a
f = ((TagMap n, TagSet) -> a) -> StateT (TagMap n, TagSet) Identity a
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (TagMap n -> a
f (TagMap n -> a)
-> ((TagMap n, TagSet) -> TagMap n) -> (TagMap n, TagSet) -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TagMap n, TagSet) -> TagMap n
forall a b. (a, b) -> a
fst)

modifyMap   :: (TagMap n -> TagMap n) -> TagState n ()
modifyMap :: forall n. (TagMap n -> TagMap n) -> TagState n ()
modifyMap TagMap n -> TagMap n
f = ((TagMap n, TagSet) -> (TagMap n, TagSet))
-> StateT (TagMap n, TagSet) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((TagMap n -> TagMap n) -> (TagMap n, TagSet) -> (TagMap n, TagSet)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first TagMap n -> TagMap n
f)

getSet :: TagState n TagSet
getSet :: forall n. TagState n TagSet
getSet = ((TagMap n, TagSet) -> TagSet)
-> StateT (TagMap n, TagSet) Identity TagSet
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (TagMap n, TagSet) -> TagSet
forall a b. (a, b) -> b
snd

modifySet   :: (TagSet -> TagSet) -> TagState n ()
modifySet :: forall n. (TagSet -> TagSet) -> TagState n ()
modifySet TagSet -> TagSet
f = ((TagMap n, TagSet) -> (TagMap n, TagSet))
-> StateT (TagMap n, TagSet) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((TagSet -> TagSet) -> (TagMap n, TagSet) -> (TagMap n, TagSet)
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second TagSet -> TagSet
f)

-- Create the Map representing the graph from the edges.
edgeGraph :: (Ord n) => [TaggedEdge n] -> TagState n ()
edgeGraph :: forall n. Ord n => [TaggedEdge n] -> TagState n ()
edgeGraph = ((Int, DotEdge n) -> StateT (TagMap n, TagSet) Identity ())
-> [(Int, DotEdge n)] -> StateT (TagMap n, TagSet) Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Int, DotEdge n) -> StateT (TagMap n, TagSet) Identity ()
forall {n}.
Ord n =>
(Int, DotEdge n) -> StateT (TagMap n, TagSet) Identity ()
addEdge ([(Int, DotEdge n)] -> StateT (TagMap n, TagSet) Identity ())
-> ([(Int, DotEdge n)] -> [(Int, DotEdge n)])
-> [(Int, DotEdge n)]
-> StateT (TagMap n, TagSet) Identity ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Int, DotEdge n)] -> [(Int, DotEdge n)]
forall a. [a] -> [a]
reverse
  where
    addEdge :: (Int, DotEdge n) -> StateT (TagMap n, TagSet) Identity ()
addEdge (Int, DotEdge n)
te = n -> TaggedValues n -> StateT (TagMap n, TagSet) Identity ()
forall {n}. Ord n => n -> TaggedValues n -> TagState n ()
addVal n
f TaggedValues n
tvOut StateT (TagMap n, TagSet) Identity ()
-> StateT (TagMap n, TagSet) Identity ()
-> StateT (TagMap n, TagSet) Identity ()
forall a b.
StateT (TagMap n, TagSet) Identity a
-> StateT (TagMap n, TagSet) Identity b
-> StateT (TagMap n, TagSet) Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> n -> TaggedValues n -> StateT (TagMap n, TagSet) Identity ()
forall {n}. Ord n => n -> TaggedValues n -> TagState n ()
addVal n
t TaggedValues n
tvIn
      where
        e :: DotEdge n
e = (Int, DotEdge n) -> DotEdge n
forall a b. (a, b) -> b
snd (Int, DotEdge n)
te
        f :: n
f = DotEdge n -> n
forall n. DotEdge n -> n
fromNode DotEdge n
e
        t :: n
t = DotEdge n -> n
forall n. DotEdge n -> n
toNode DotEdge n
e
        addVal :: n -> TaggedValues n -> TagState n ()
addVal n
n TaggedValues n
tv = (TagMap n -> TagMap n) -> TagState n ()
forall n. (TagMap n -> TagMap n) -> TagState n ()
modifyMap ((TaggedValues n -> TaggedValues n -> TaggedValues n)
-> n -> TaggedValues n -> TagMap n -> TagMap n
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith TaggedValues n -> TaggedValues n -> TaggedValues n
forall {n}. TaggedValues n -> TaggedValues n -> TaggedValues n
mergeTV n
n TaggedValues n
tv)
        tvIn :: TaggedValues n
tvIn  = TaggedValues n
forall n. TaggedValues n
defTV { incoming = [te] }
        tvOut :: TaggedValues n
tvOut = TaggedValues n
forall n. TaggedValues n
defTV { outgoing = [te] }
        mergeTV :: TaggedValues n -> TaggedValues n -> TaggedValues n
mergeTV TaggedValues n
tvNew TaggedValues n
tv  = TaggedValues n
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 :: forall n. Ord n => Int -> n -> TagState n ()
traverseTag Int
t n
n = do Bool -> TagState n ()
setMark Bool
True
                     TagState n ()
checkIncoming
                     [TaggedEdge n]
outEs <- (TagMap n -> [TaggedEdge n]) -> TagState n [TaggedEdge n]
forall n a. (TagMap n -> a) -> TagState n a
getsMap ([TaggedEdge n]
-> (TaggedValues n -> [TaggedEdge n])
-> Maybe (TaggedValues n)
-> [TaggedEdge n]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] TaggedValues n -> [TaggedEdge n]
forall n. TaggedValues n -> [TaggedEdge n]
outgoing (Maybe (TaggedValues n) -> [TaggedEdge n])
-> (TagMap n -> Maybe (TaggedValues n))
-> TagMap n
-> [TaggedEdge n]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. n -> TagMap n -> Maybe (TaggedValues n)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup n
n)
                     (TaggedEdge n -> TagState n ()) -> [TaggedEdge n] -> TagState n ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ TaggedEdge n -> TagState n ()
forall {n}.
Ord n =>
(Int, DotEdge n) -> StateT (TagMap n, TagSet) Identity ()
maybeRecurse [TaggedEdge n]
outEs
                     Bool -> TagState n ()
setMark Bool
False
  where
    setMark :: Bool -> TagState n ()
setMark Bool
mrk = (TagMap n -> TagMap n) -> TagState n ()
forall n. (TagMap n -> TagMap n) -> TagState n ()
modifyMap ((TaggedValues n -> TaggedValues n) -> n -> TagMap n -> TagMap n
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust (\TaggedValues n
tv -> TaggedValues n
tv { marked = mrk }) n
n)

    isMarked :: Map k (TaggedValues n) -> k -> Bool
isMarked Map k (TaggedValues n)
m k
n' = Bool -> (TaggedValues n -> Bool) -> Maybe (TaggedValues n) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False TaggedValues n -> Bool
forall n. TaggedValues n -> Bool
marked (Maybe (TaggedValues n) -> Bool) -> Maybe (TaggedValues n) -> Bool
forall a b. (a -> b) -> a -> b
$ k
n' k -> Map k (TaggedValues n) -> Maybe (TaggedValues n)
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map k (TaggedValues n)
m

    checkIncoming :: TagState n ()
checkIncoming = do TagMap n
m <- ((TagMap n, TagSet) -> TagMap n)
-> StateT (TagMap n, TagSet) Identity (TagMap n)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (TagMap n, TagSet) -> TagMap n
forall a b. (a, b) -> a
fst
                       let es :: [TaggedEdge n]
es = TaggedValues n -> [TaggedEdge n]
forall n. TaggedValues n -> [TaggedEdge n]
incoming (TaggedValues n -> [TaggedEdge n])
-> TaggedValues n -> [TaggedEdge n]
forall a b. (a -> b) -> a -> b
$ TagMap n
m TagMap n -> n -> TaggedValues n
forall k a. Ord k => Map k a -> k -> a
Map.! n
n
                           ([TaggedEdge n]
keepEs, [TaggedEdge n]
delEs) = (TaggedEdge n -> Bool)
-> [TaggedEdge n] -> ([TaggedEdge n], [TaggedEdge n])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (TagMap n -> TaggedEdge n -> Bool
forall {k} {n}.
Ord k =>
Map k (TaggedValues n) -> (Int, DotEdge k) -> Bool
keepEdge TagMap n
m) [TaggedEdge n]
es
                       (TagMap n -> TagMap n) -> TagState n ()
forall n. (TagMap n -> TagMap n) -> TagState n ()
modifyMap ((TaggedValues n -> TaggedValues n) -> n -> TagMap n -> TagMap n
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust (\TaggedValues n
tv -> TaggedValues n
tv {incoming = keepEs}) n
n)
                       (TagSet -> TagSet) -> TagState n ()
forall n. (TagSet -> TagSet) -> TagState n ()
modifySet (TagSet -> TagSet -> TagSet
forall a. Ord a => Set a -> Set a -> Set a
Set.union (TagSet -> TagSet -> TagSet) -> TagSet -> TagSet -> TagSet
forall a b. (a -> b) -> a -> b
$ [Int] -> TagSet
forall a. Ord a => [a] -> Set a
Set.fromList ((TaggedEdge n -> Int) -> [TaggedEdge n] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map TaggedEdge n -> Int
forall a b. (a, b) -> a
fst [TaggedEdge n]
delEs))
                       (TaggedEdge n -> TagState n ()) -> [TaggedEdge n] -> TagState n ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ TaggedEdge n -> TagState n ()
forall {n}.
Ord n =>
(Int, DotEdge n) -> StateT (TagMap n, TagSet) Identity ()
delOtherEdge [TaggedEdge n]
delEs
      where
        keepEdge :: Map k (TaggedValues n) -> (Int, DotEdge k) -> Bool
keepEdge Map k (TaggedValues n)
m (Int
t',DotEdge k
e) = Int
t Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
t' Bool -> Bool -> Bool
|| Bool -> Bool
not (Map k (TaggedValues n) -> k -> Bool
forall {k} {n}. Ord k => Map k (TaggedValues n) -> k -> Bool
isMarked Map k (TaggedValues n)
m (k -> Bool) -> k -> Bool
forall a b. (a -> b) -> a -> b
$ DotEdge k -> k
forall n. DotEdge n -> n
fromNode DotEdge k
e)

        delOtherEdge :: (Int, DotEdge n) -> TagState n ()
delOtherEdge (Int, DotEdge n)
te = (TagMap n -> TagMap n) -> TagState n ()
forall n. (TagMap n -> TagMap n) -> TagState n ()
modifyMap ((TaggedValues n -> TaggedValues n) -> n -> TagMap n -> TagMap n
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust TaggedValues n -> TaggedValues n
delE (n -> TagMap n -> TagMap n)
-> (DotEdge n -> n) -> DotEdge n -> TagMap n -> TagMap n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DotEdge n -> n
forall n. DotEdge n -> n
fromNode (DotEdge n -> TagMap n -> TagMap n)
-> DotEdge n -> TagMap n -> TagMap n
forall a b. (a -> b) -> a -> b
$ (Int, DotEdge n) -> DotEdge n
forall a b. (a, b) -> b
snd (Int, DotEdge n)
te)
          where
            delE :: TaggedValues n -> TaggedValues n
delE TaggedValues n
tv = TaggedValues n
tv {outgoing = deleteBy ((==) `on` fst) te $ outgoing tv}

    maybeRecurse :: (Int, DotEdge n) -> StateT (TagMap n, TagSet) Identity ()
maybeRecurse (Int
t',DotEdge n
e) = do TagMap n
m <- TagState n (TagMap n)
forall n. TagState n (TagMap n)
getMap
                             TagSet
delSet <- TagState n TagSet
forall n. TagState n TagSet
getSet
                             let n' :: n
n' = DotEdge n -> n
forall n. DotEdge n -> n
toNode DotEdge n
e
                             Bool
-> StateT (TagMap n, TagSet) Identity ()
-> StateT (TagMap n, TagSet) Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TagMap n -> n -> Bool
forall {k} {n}. Ord k => Map k (TaggedValues n) -> k -> Bool
isMarked TagMap n
m n
n' Bool -> Bool -> Bool
|| Int
t' Int -> TagSet -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` TagSet
delSet)
                               (StateT (TagMap n, TagSet) Identity ()
 -> StateT (TagMap n, TagSet) Identity ())
-> StateT (TagMap n, TagSet) Identity ()
-> StateT (TagMap n, TagSet) Identity ()
forall a b. (a -> b) -> a -> b
$ Int -> n -> StateT (TagMap n, TagSet) Identity ()
forall n. Ord n => Int -> n -> TagState n ()
traverseTag Int
t' n
n'