{-# 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CanonicaliseOptions -> CanonicaliseOptions -> Bool
$c/= :: CanonicaliseOptions -> CanonicaliseOptions -> Bool
== :: CanonicaliseOptions -> CanonicaliseOptions -> Bool
$c== :: CanonicaliseOptions -> CanonicaliseOptions -> Bool
Eq, Eq 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
min :: CanonicaliseOptions -> CanonicaliseOptions -> CanonicaliseOptions
$cmin :: CanonicaliseOptions -> CanonicaliseOptions -> CanonicaliseOptions
max :: CanonicaliseOptions -> CanonicaliseOptions -> CanonicaliseOptions
$cmax :: CanonicaliseOptions -> CanonicaliseOptions -> CanonicaliseOptions
>= :: CanonicaliseOptions -> CanonicaliseOptions -> Bool
$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
compare :: CanonicaliseOptions -> CanonicaliseOptions -> Ordering
$ccompare :: CanonicaliseOptions -> CanonicaliseOptions -> Ordering
Ord, Int -> CanonicaliseOptions -> ShowS
[CanonicaliseOptions] -> ShowS
CanonicaliseOptions -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CanonicaliseOptions] -> ShowS
$cshowList :: [CanonicaliseOptions] -> ShowS
show :: CanonicaliseOptions -> String
$cshow :: CanonicaliseOptions -> String
showsPrec :: Int -> CanonicaliseOptions -> ShowS
$cshowsPrec :: Int -> CanonicaliseOptions -> ShowS
Show, ReadPrec [CanonicaliseOptions]
ReadPrec CanonicaliseOptions
Int -> ReadS CanonicaliseOptions
ReadS [CanonicaliseOptions]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [CanonicaliseOptions]
$creadListPrec :: ReadPrec [CanonicaliseOptions]
readPrec :: ReadPrec CanonicaliseOptions
$creadPrec :: ReadPrec CanonicaliseOptions
readList :: ReadS [CanonicaliseOptions]
$creadList :: ReadS [CanonicaliseOptions]
readsPrec :: Int -> ReadS CanonicaliseOptions
$creadsPrec :: Int -> ReadS 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 = 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 :: Bool
strictGraph   = forall (dg :: * -> *) n. DotRepr dg n => dg n -> Bool
graphIsStrict dg n
dg
                                  , directedGraph :: Bool
directedGraph = forall (dg :: * -> *) n. DotRepr dg n => dg n -> Bool
graphIsDirected dg n
dg
                                  }
  where
    cdg :: DotGraph n
cdg = forall n.
Ord n =>
CanonicaliseOptions
-> Maybe GraphID
-> GlobalAttributes
-> ClusterLookup
-> NodeLookup n
-> [DotEdge n]
-> DotGraph n
createCanonical CanonicaliseOptions
opts (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) = forall (dg :: * -> *) n.
DotRepr dg n =>
dg n -> (GlobalAttributes, ClusterLookup)
graphStructureInformationClean dg n
dg
    nl :: NodeLookup n
nl = forall (dg :: * -> *) n.
DotRepr dg n =>
Bool -> dg n -> NodeLookup n
nodeInformationClean Bool
True dg n
dg
    es :: [DotEdge n]
es = 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 = forall n. DotSubGraph n -> DotGraph n
promoteDSG forall a b. (a -> b) -> a -> b
$ forall n. CanonControl n -> NodePaths n -> DotSubGraph n
makeGrouping CanonControl n
cc [([Maybe GraphID], DotNode n)]
ns
  where
    nUnlook :: (n, (t a, Attributes)) -> ([a], DotNode n)
nUnlook (n
n,(t a
p,Attributes
as)) = (forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList t a
p, forall n. n -> Attributes -> DotNode n
DotNode n
n Attributes
as)
    -- DotNodes paired and sorted by their paths
    ns :: [([Maybe GraphID], DotNode n)]
ns = forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a. Ord a => [a] -> [a] -> Ordering
compLists forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a b. (a, b) -> a
fst) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall {t :: * -> *} {n} {a}.
Foldable t =>
(n, (t a, Attributes)) -> ([a], DotNode n)
nUnlook forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList NodeLookup n
nl

    es' :: EdgeLocations n
es' = if CanonicaliseOptions -> Bool
edgesInClusters CanonicaliseOptions
opts
          then forall n. Ord n => NodeLookup n -> [DotEdge n] -> EdgeLocations n
edgeClusters NodeLookup n
nl [DotEdge n]
es
          else (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 = forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 | forall n. CanonControl n -> Bool
isGraph CanonControl n
cc = forall n. CanonControl n -> Maybe GraphID
topID CanonControl n
cc
        | Bool
otherwise  = forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
head forall a b. (a -> b) -> a -> b
$ NodePaths n
cns

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

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

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

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

    stmts :: DotStatements n
stmts = forall n.
CanonicaliseOptions
-> Attributes -> DotStatements n -> DotStatements n
setGlobal (forall n. CanonControl n -> CanonicaliseOptions
cOpts CanonControl n
cc) Attributes
gas
            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 :: [GlobalAttributes]
attrStmts = [GlobalAttributes]
globs'
                                , subGraphs :: [DotSubGraph n]
subGraphs = [DotSubGraph n]
sgs'
                                , nodeStmts :: [DotNode n]
nodeStmts = [DotNode n]
ns'
                                , edgeStmts :: [DotEdge n]
edgeStmts = [DotEdge n]
es'
                                }
  where
    sgs :: [DotSubGraph n]
sgs = forall n. DotStatements n -> [DotSubGraph n]
subGraphs DotStatements n
stmts
    sStmts :: [DotStatements n]
sStmts = forall a b. (a -> b) -> [a] -> [b]
map forall n. DotSubGraph n -> DotStatements n
subGraphStmts [DotSubGraph n]
sgs
    ns :: [DotNode n]
ns = forall n. DotStatements n -> [DotNode n]
nodeStmts DotStatements n
stmts
    es :: [DotEdge n]
es = forall n. DotStatements n -> [DotEdge n]
edgeStmts DotStatements n
stmts

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

    ([Attributes]
sgas,[Attributes]
snas,[Attributes]
seas) = 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' = forall n a.
CanonicaliseOptions
-> (DotStatements n -> [a])
-> [Attributes]
-> [DotStatements n]
-> [Attributes]
-> Attributes
getCommonGlobs CanonicaliseOptions
opts forall n. DotStatements n -> [DotNode n]
nodeStmts [Attributes]
snas [DotStatements n]
sStmts forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall n. DotNode n -> Attributes
nodeAttributes [DotNode n]
ns
    eas' :: Attributes
eas' = forall n a.
CanonicaliseOptions
-> (DotStatements n -> [a])
-> [Attributes]
-> [DotStatements n]
-> [Attributes]
-> Attributes
getCommonGlobs CanonicaliseOptions
opts forall n. DotStatements n -> [DotEdge n]
edgeStmts [Attributes]
seas [DotStatements n]
sStmts forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map 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' = forall a b. (a -> b) -> [a] -> [b]
map (\DotNode n
dn -> DotNode n
dn { nodeAttributes :: Attributes
nodeAttributes = forall n. DotNode n -> Attributes
nodeAttributes DotNode n
dn forall a. Eq a => [a] -> [a] -> [a]
\\ Attributes
nas' }) [DotNode n]
ns
    es' :: [DotEdge n]
es' = forall a b. (a -> b) -> [a] -> [b]
map (\DotEdge n
de -> DotEdge n
de { edgeAttributes :: Attributes
edgeAttributes = forall n. DotEdge n -> Attributes
edgeAttributes DotEdge n
de forall a. Eq a => [a] -> [a] -> [a]
\\ Attributes
eas' }) [DotEdge n]
es

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

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

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

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

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

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

nonSameDefaults :: Attributes -> Attributes
nonSameDefaults :: Attributes -> Attributes
nonSameDefaults = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\ Attribute
a -> [ Attribute
a' | Attribute
a' <- Attribute -> Maybe Attribute
defaultAttributeValue Attribute
a, Attribute
a' 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 forall a b. (a -> b) -> a -> b
$ CanonicaliseOptions -> Bool
groupAttributes CanonicaliseOptions
opts = []
  | Bool
otherwise = case [Attributes]
sas' forall a. [a] -> [a] -> [a]
++ [Attributes]
as of
                  []  -> []
                  [Attributes
_] -> []
                  [Attributes]
as' -> forall a. Set a -> [a]
Set.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 forall a. Ord a => Set a -> Set a -> Set a
Set.intersection
                         forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Ord a => [a] -> Set a
Set.fromList [Attributes]
as'
  where
    sas' :: [Attributes]
sas' = 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 = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [a] -> [b] -> [(a, b)]
zip [Attributes]
sas forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (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 (forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ DotStatements n -> [a]
f DotStatements n
ds) Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall n a. (DotStatements n -> [a]) -> DotStatements n -> Bool
hasAny DotStatements n -> [a]
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. DotSubGraph n -> DotStatements n
subGraphStmts) (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     = forall a. HasCallStack => a
undefined
                          , directedGraph :: Bool
directedGraph   = forall a. HasCallStack => a
undefined
                          , graphID :: Maybe GraphID
graphID         = forall n. DotSubGraph n -> Maybe GraphID
subGraphID DotSubGraph n
dsg
                          , graphStatements :: DotStatements n
graphStatements = 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 forall a. Ord a => a -> a -> Ordering
compare a
x a
y of
                            Ordering
EQ  -> forall a. Ord a => [a] -> [a] -> Ordering
compLists [a]
xs [a]
ys
                            Ordering
oth -> Ordering
oth

nonEmptyGAs :: [GlobalAttributes] -> [GlobalAttributes]
nonEmptyGAs :: [GlobalAttributes] -> [GlobalAttributes]
nonEmptyGAs = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null 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 = (forall {b'}. [([Maybe GraphID], b')] -> Map (Maybe GraphID) [b']
toM forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)
                  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map DotEdge n -> ([Maybe GraphID], DotEdge n)
inClust
  where
    nl' :: Map n [Maybe GraphID]
nl' = forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
_) = (forall a b c. (a -> b -> c) -> b -> a -> c
flip (,) DotEdge n
de)
                                   forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. Eq a => a -> a -> Bool
(==))
                                   forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip (Map n [Maybe GraphID]
nl' forall k a. Ord k => Map k a -> k -> a
Map.! n
n1) (Map n [Maybe GraphID]
nl' forall k a. Ord k => Map k a -> k -> a
Map.! n
n2)
    toM :: [([Maybe GraphID], b')] -> Map (Maybe GraphID) [b']
toM = forall a b k. (a -> b) -> Map k a -> Map k b
Map.map forall a. DList a -> [a]
DList.toList
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. DList a -> DList a -> DList a
DList.append)
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a. [a] -> a
last forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** 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 = 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 :: Bool
strictGraph = forall (dg :: * -> *) n. DotRepr dg n => dg n -> Bool
graphIsStrict dg n
dg
                                         , directedGraph :: Bool
directedGraph = forall (dg :: * -> *) n. DotRepr dg n => dg n -> Bool
graphIsDirected dg n
dg
                                         }
  where
    cdg :: DotGraph n
cdg = forall n.
Ord n =>
CanonicaliseOptions
-> Maybe GraphID
-> GlobalAttributes
-> ClusterLookup
-> NodeLookup n
-> [DotEdge n]
-> DotGraph n
createCanonical CanonicaliseOptions
opts (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) = forall (dg :: * -> *) n.
DotRepr dg n =>
dg n -> (GlobalAttributes, ClusterLookup)
graphStructureInformationClean dg n
dg
    nl :: NodeLookup n
nl = forall (dg :: * -> *) n.
DotRepr dg n =>
Bool -> dg n -> NodeLookup n
nodeInformationClean Bool
True dg n
dg
    es :: [DotEdge n]
es = forall (dg :: * -> *) n.
DotRepr dg n =>
Bool -> dg n -> [DotEdge n]
edgeInformationClean Bool
True dg n
dg
    es' :: [DotEdge n]
es' | forall (dg :: * -> *) n. DotRepr dg n => dg n -> Bool
graphIsDirected dg n
dg = 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 = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. TaggedValues n -> [TaggedEdge n]
outgoing) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
Map.elems TagMap n
esM
  where
    tes :: [TaggedEdge n]
tes = forall n. [DotEdge n] -> [TaggedEdge n]
tagEdges [DotEdge n]
es

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

    esM :: TagMap n
esM = forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall s a. State s a -> s -> s
execState StateT (TagMap n, TagSet) Identity ()
esMS (forall k a. Map k a
Map.empty, 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 = forall a b. [a] -> [b] -> [(a, b)]
zip [(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
forall n. Eq n => TaggedValues n -> TaggedValues n -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TaggedValues n -> TaggedValues n -> Bool
$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
Eq, TaggedValues n -> TaggedValues n -> Bool
TaggedValues n -> TaggedValues n -> Ordering
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
min :: TaggedValues n -> TaggedValues n -> TaggedValues n
$cmin :: forall n.
Ord n =>
TaggedValues n -> TaggedValues n -> TaggedValues n
max :: TaggedValues n -> TaggedValues n -> TaggedValues n
$cmax :: forall n.
Ord n =>
TaggedValues n -> TaggedValues n -> TaggedValues n
>= :: 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
$c< :: forall n. Ord n => TaggedValues n -> TaggedValues n -> Bool
compare :: TaggedValues n -> TaggedValues n -> Ordering
$ccompare :: forall n. Ord n => TaggedValues n -> TaggedValues n -> Ordering
Ord, Int -> TaggedValues n -> ShowS
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
showList :: [TaggedValues n] -> ShowS
$cshowList :: forall n. Show n => [TaggedValues n] -> ShowS
show :: TaggedValues n -> String
$cshow :: forall n. Show n => TaggedValues n -> String
showsPrec :: Int -> TaggedValues n -> ShowS
$cshowsPrec :: forall n. Show n => Int -> TaggedValues n -> ShowS
Show, ReadPrec [TaggedValues n]
ReadPrec (TaggedValues n)
ReadS [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
readListPrec :: ReadPrec [TaggedValues n]
$creadListPrec :: forall n. Read n => ReadPrec [TaggedValues n]
readPrec :: ReadPrec (TaggedValues n)
$creadPrec :: forall n. Read n => ReadPrec (TaggedValues n)
readList :: ReadS [TaggedValues n]
$creadList :: forall n. Read n => ReadS [TaggedValues n]
readsPrec :: Int -> ReadS (TaggedValues n)
$creadsPrec :: forall n. Read n => Int -> ReadS (TaggedValues n)
Read)

defTV :: TaggedValues n
defTV :: forall n. TaggedValues n
defTV = 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 = forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets 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 = forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (TagMap n -> a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (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 = forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a, b) -> b
snd

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

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

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

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