-- Copyright (c) 2011, David Amos. All rights reserved.

{-# LANGUAGE NoMonomorphismRestriction #-}

-- |A module for working with directed graphs (digraphs).
-- Some of the functions are specifically for working with directed acyclic graphs (DAGs),
-- that is, directed graphs containing no cycles.
module Math.Combinatorics.Digraph where

import Data.List as L
import qualified Data.Map.Strict as M
import qualified Data.Set as S

import Math.Core.Utils (picks, toSet)

-- |A digraph is represented as DG vs es, where vs is the list of vertices, and es is the list of edges.
-- Edges are directed: an edge (u,v) means an edge from u to v.
-- A digraph is considered to be in normal form if both es and vs are in ascending order.
-- This is the preferred form, and some functions will only work for digraphs in normal form.
data Digraph v = DG [v] [(v,v)] deriving (Digraph v -> Digraph v -> Bool
(Digraph v -> Digraph v -> Bool)
-> (Digraph v -> Digraph v -> Bool) -> Eq (Digraph v)
forall v. Eq v => Digraph v -> Digraph v -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Digraph v -> Digraph v -> Bool
$c/= :: forall v. Eq v => Digraph v -> Digraph v -> Bool
== :: Digraph v -> Digraph v -> Bool
$c== :: forall v. Eq v => Digraph v -> Digraph v -> Bool
Eq,Eq (Digraph v)
Eq (Digraph v) =>
(Digraph v -> Digraph v -> Ordering)
-> (Digraph v -> Digraph v -> Bool)
-> (Digraph v -> Digraph v -> Bool)
-> (Digraph v -> Digraph v -> Bool)
-> (Digraph v -> Digraph v -> Bool)
-> (Digraph v -> Digraph v -> Digraph v)
-> (Digraph v -> Digraph v -> Digraph v)
-> Ord (Digraph v)
Digraph v -> Digraph v -> Bool
Digraph v -> Digraph v -> Ordering
Digraph v -> Digraph v -> Digraph v
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 v. Ord v => Eq (Digraph v)
forall v. Ord v => Digraph v -> Digraph v -> Bool
forall v. Ord v => Digraph v -> Digraph v -> Ordering
forall v. Ord v => Digraph v -> Digraph v -> Digraph v
min :: Digraph v -> Digraph v -> Digraph v
$cmin :: forall v. Ord v => Digraph v -> Digraph v -> Digraph v
max :: Digraph v -> Digraph v -> Digraph v
$cmax :: forall v. Ord v => Digraph v -> Digraph v -> Digraph v
>= :: Digraph v -> Digraph v -> Bool
$c>= :: forall v. Ord v => Digraph v -> Digraph v -> Bool
> :: Digraph v -> Digraph v -> Bool
$c> :: forall v. Ord v => Digraph v -> Digraph v -> Bool
<= :: Digraph v -> Digraph v -> Bool
$c<= :: forall v. Ord v => Digraph v -> Digraph v -> Bool
< :: Digraph v -> Digraph v -> Bool
$c< :: forall v. Ord v => Digraph v -> Digraph v -> Bool
compare :: Digraph v -> Digraph v -> Ordering
$ccompare :: forall v. Ord v => Digraph v -> Digraph v -> Ordering
$cp1Ord :: forall v. Ord v => Eq (Digraph v)
Ord,Int -> Digraph v -> ShowS
[Digraph v] -> ShowS
Digraph v -> String
(Int -> Digraph v -> ShowS)
-> (Digraph v -> String)
-> ([Digraph v] -> ShowS)
-> Show (Digraph v)
forall v. Show v => Int -> Digraph v -> ShowS
forall v. Show v => [Digraph v] -> ShowS
forall v. Show v => Digraph v -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Digraph v] -> ShowS
$cshowList :: forall v. Show v => [Digraph v] -> ShowS
show :: Digraph v -> String
$cshow :: forall v. Show v => Digraph v -> String
showsPrec :: Int -> Digraph v -> ShowS
$cshowsPrec :: forall v. Show v => Int -> Digraph v -> ShowS
Show)

instance Functor Digraph where
    -- |If f is not order-preserving, then you should call nf afterwards
    fmap :: (a -> b) -> Digraph a -> Digraph b
fmap f :: a -> b
f (DG vs :: [a]
vs es :: [(a, a)]
es) = [b] -> [(b, b)] -> Digraph b
forall v. [v] -> [(v, v)] -> Digraph v
DG ((a -> b) -> [a] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map a -> b
f [a]
vs) (((a, a) -> (b, b)) -> [(a, a)] -> [(b, b)]
forall a b. (a -> b) -> [a] -> [b]
map (\(u :: a
u,v :: a
v)->(a -> b
f a
u, a -> b
f a
v)) [(a, a)]
es)

nf :: Digraph v -> Digraph v
nf (DG vs :: [v]
vs es :: [(v, v)]
es) = [v] -> [(v, v)] -> Digraph v
forall v. [v] -> [(v, v)] -> Digraph v
DG ([v] -> [v]
forall a. Ord a => [a] -> [a]
L.sort [v]
vs) ([(v, v)] -> [(v, v)]
forall a. Ord a => [a] -> [a]
L.sort [(v, v)]
es)

vertices :: Digraph v -> [v]
vertices (DG vs :: [v]
vs _) = [v]
vs

edges :: Digraph v -> [(v, v)]
edges (DG _ es :: [(v, v)]
es) = [(v, v)]
es


-- Is it valid to call them predecessors / successors in the case when the digraph contains cycles?

predecessors :: Digraph a -> a -> [a]
predecessors (DG _ es :: [(a, a)]
es) v :: a
v = [a
u | (u :: a
u,v' :: a
v') <- [(a, a)]
es, a
v' a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
v]

successors :: Digraph a -> a -> [a]
successors (DG _ es :: [(a, a)]
es) u :: a
u = [a
v | (u' :: a
u',v :: a
v) <- [(a, a)]
es, a
u' a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
u]

-- Calculate maps of predecessor and successor lists for each vertex in a digraph.
-- If a vertex has no predecessors (respectively successors), then it is left out of the relevant map
adjLists :: Digraph a -> (Map a [a], Map a [a])
adjLists (DG vs :: [a]
vs es :: [(a, a)]
es) = (Map a [a], Map a [a]) -> [(a, a)] -> (Map a [a], Map a [a])
forall a k.
(Ord a, Ord k) =>
(Map a [k], Map k [a]) -> [(k, a)] -> (Map a [k], Map k [a])
adjLists' (Map a [a]
forall k a. Map k a
M.empty, Map a [a]
forall k a. Map k a
M.empty) [(a, a)]
es
    where adjLists' :: (Map a [k], Map k [a]) -> [(k, a)] -> (Map a [k], Map k [a])
adjLists' (preds :: Map a [k]
preds,succs :: Map k [a]
succs) ((u :: k
u,v :: a
v):es :: [(k, a)]
es) =
              (Map a [k], Map k [a]) -> [(k, a)] -> (Map a [k], Map k [a])
adjLists' (([k] -> [k] -> [k]) -> a -> [k] -> Map a [k] -> Map a [k]
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith (([k] -> [k] -> [k]) -> [k] -> [k] -> [k]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [k] -> [k] -> [k]
forall a. [a] -> [a] -> [a]
(++)) a
v [k
u] Map a [k]
preds, ([a] -> [a] -> [a]) -> k -> [a] -> Map k [a] -> Map k [a]
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith (([a] -> [a] -> [a]) -> [a] -> [a] -> [a]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++)) k
u [a
v] Map k [a]
succs) [(k, a)]
es
          adjLists' (preds :: Map a [k]
preds,succs :: Map k [a]
succs) [] = (Map a [k]
preds, Map k [a]
succs)


digraphIsos1 :: Digraph a -> Digraph a -> [[(a, a)]]
digraphIsos1 (DG vsa :: [a]
vsa esa :: [(a, a)]
esa) (DG vsb :: [a]
vsb esb :: [(a, a)]
esb)
    | [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
vsa Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
vsb = []
    | [(a, a)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(a, a)]
esa Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [(a, a)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(a, a)]
esb = []
    | Bool
otherwise = [(a, a)] -> [a] -> [a] -> [[(a, a)]]
digraphIsos' [] [a]
vsa [a]
vsb
    where digraphIsos' :: [(a, a)] -> [a] -> [a] -> [[(a, a)]]
digraphIsos' xys :: [(a, a)]
xys [] [] = [[(a, a)]
xys]
          digraphIsos' xys :: [(a, a)]
xys (x :: a
x:xs :: [a]
xs) ys :: [a]
ys =
              [[[(a, a)]]] -> [[(a, a)]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [(a, a)] -> [a] -> [a] -> [[(a, a)]]
digraphIsos' ((a
x,a
y)(a, a) -> [(a, a)] -> [(a, a)]
forall a. a -> [a] -> [a]
:[(a, a)]
xys) [a]
xs [a]
ys'
                     | (y :: a
y,ys' :: [a]
ys') <- [a] -> [(a, [a])]
forall a. [a] -> [(a, [a])]
picks [a]
ys, (a, a) -> [(a, a)] -> Bool
isCompatible (a
x,a
y) [(a, a)]
xys]
          isCompatible :: (a, a) -> [(a, a)] -> Bool
isCompatible (x :: a
x,y :: a
y) xys :: [(a, a)]
xys = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ ((a
x,a
x') (a, a) -> [(a, a)] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [(a, a)]
esa) Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== ((a
y,a
y') (a, a) -> [(a, a)] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [(a, a)]
esb)
                                      Bool -> Bool -> Bool
&& ((a
x',a
x) (a, a) -> [(a, a)] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [(a, a)]
esa) Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== ((a
y',a
y) (a, a) -> [(a, a)] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [(a, a)]
esb)
                                       | (x' :: a
x',y' :: a
y') <- [(a, a)]
xys ]

digraphIsos2 :: Digraph k -> Digraph k -> [[(k, k)]]
digraphIsos2 a :: Digraph k
a b :: Digraph k
b
    | [k] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Digraph k -> [k]
forall v. Digraph v -> [v]
vertices Digraph k
a) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [k] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Digraph k -> [k]
forall v. Digraph v -> [v]
vertices Digraph k
b) = []
    | [Int] -> [Int]
forall a. Ord a => [a] -> [a]
L.sort (Map k Int -> [Int]
forall k a. Map k a -> [a]
M.elems Map k Int
indega) [Int] -> [Int] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Int] -> [Int]
forall a. Ord a => [a] -> [a]
L.sort (Map k Int -> [Int]
forall k a. Map k a -> [a]
M.elems Map k Int
indegb) = [] 
    | [Int] -> [Int]
forall a. Ord a => [a] -> [a]
L.sort (Map k Int -> [Int]
forall k a. Map k a -> [a]
M.elems Map k Int
outdega) [Int] -> [Int] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Int] -> [Int]
forall a. Ord a => [a] -> [a]
L.sort (Map k Int -> [Int]
forall k a. Map k a -> [a]
M.elems Map k Int
outdegb) = [] 
    | Bool
otherwise = [(k, k)] -> [k] -> [k] -> [[(k, k)]]
dfs [] (Digraph k -> [k]
forall v. Digraph v -> [v]
vertices Digraph k
a) (Digraph k -> [k]
forall v. Digraph v -> [v]
vertices Digraph k
b)
    where (preda :: Map k [k]
preda,succa :: Map k [k]
succa) = Digraph k -> (Map k [k], Map k [k])
forall a. Ord a => Digraph a -> (Map a [a], Map a [a])
adjLists Digraph k
a
          (predb :: Map k [k]
predb,succb :: Map k [k]
succb) = Digraph k -> (Map k [k], Map k [k])
forall a. Ord a => Digraph a -> (Map a [a], Map a [a])
adjLists Digraph k
b
          indega :: Map k Int
indega = ([k] -> Int) -> Map k [k] -> Map k Int
forall a b k. (a -> b) -> Map k a -> Map k b
M.map [k] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Map k [k]
preda
          indegb :: Map k Int
indegb = ([k] -> Int) -> Map k [k] -> Map k Int
forall a b k. (a -> b) -> Map k a -> Map k b
M.map [k] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Map k [k]
predb
          outdega :: Map k Int
outdega = ([k] -> Int) -> Map k [k] -> Map k Int
forall a b k. (a -> b) -> Map k a -> Map k b
M.map [k] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Map k [k]
succa
          outdegb :: Map k Int
outdegb = ([k] -> Int) -> Map k [k] -> Map k Int
forall a b k. (a -> b) -> Map k a -> Map k b
M.map [k] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Map k [k]
succb
          isCompatible :: (k, k) -> [(k, k)] -> Bool
isCompatible (x :: k
x,y :: k
y) xys :: [(k, k)]
xys = (Int -> k -> Map k Int -> Int
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault 0 k
x Map k Int
indega) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== (Int -> k -> Map k Int -> Int
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault 0 k
y Map k Int
indegb)
                                Bool -> Bool -> Bool
&& (Int -> k -> Map k Int -> Int
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault 0 k
x Map k Int
outdega) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== (Int -> k -> Map k Int -> Int
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault 0 k
y Map k Int
outdegb)
                                Bool -> Bool -> Bool
&& [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ (k
x' k -> [k] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [k]
predx) Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== (k
y' k -> [k] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [k]
predy)
                                      Bool -> Bool -> Bool
&& (k
x' k -> [k] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [k]
succx) Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== (k
y' k -> [k] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [k]
succy)
                                       | let predx :: [k]
predx = [k] -> k -> Map k [k] -> [k]
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault [] k
x Map k [k]
preda, let predy :: [k]
predy = [k] -> k -> Map k [k] -> [k]
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault [] k
y Map k [k]
predb,
                                         let succx :: [k]
succx = [k] -> k -> Map k [k] -> [k]
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault [] k
x Map k [k]
succa, let succy :: [k]
succy = [k] -> k -> Map k [k] -> [k]
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault [] k
y Map k [k]
succb,
                                         (x' :: k
x',y' :: k
y') <- [(k, k)]
xys]
          dfs :: [(k, k)] -> [k] -> [k] -> [[(k, k)]]
dfs xys :: [(k, k)]
xys [] [] = [[(k, k)]
xys]
          dfs xys :: [(k, k)]
xys (x :: k
x:xs :: [k]
xs) ys :: [k]
ys =
              [[[(k, k)]]] -> [[(k, k)]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [(k, k)] -> [k] -> [k] -> [[(k, k)]]
dfs ((k
x,k
y)(k, k) -> [(k, k)] -> [(k, k)]
forall a. a -> [a] -> [a]
:[(k, k)]
xys) [k]
xs [k]
ys'
                     | (y :: k
y,ys' :: [k]
ys') <- [k] -> [(k, [k])]
forall a. [a] -> [(a, [a])]
picks [k]
ys, (k, k) -> [(k, k)] -> Bool
isCompatible (k
x,k
y) [(k, k)]
xys]

-- For DAGs, can almost certainly do better than the above by using the height partition
-- However see remarks in Poset on orderIsos:
-- What is most efficient will depend on whether you want to list all of them, or just find out whether there are any or not
-- Could also try refining the height partition by (indegree,outdegree)


-- doesn't check whether input is a dag
-- if not, then the output will not contain all the vs
heightPartitionDAG :: Digraph k -> [[k]]
heightPartitionDAG dag :: Digraph k
dag@(DG vs :: [k]
vs es :: [(k, k)]
es) = Set k -> [k] -> [[k]]
heightPartition' Set k
forall a. Set a
S.empty [k
v | k
v <- [k]
vs, k
v k -> Map k [k] -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`M.notMember` Map k [k]
preds] -- ie vertices with no predecessors
    where (preds :: Map k [k]
preds,succs :: Map k [k]
succs) = Digraph k -> (Map k [k], Map k [k])
forall a. Ord a => Digraph a -> (Map a [a], Map a [a])
adjLists Digraph k
dag
          heightPartition' :: Set k -> [k] -> [[k]]
heightPartition' interior :: Set k
interior boundary :: [k]
boundary
              | [k] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [k]
boundary = []
              | Bool
otherwise = let interior' :: Set k
interior' = Set k -> Set k -> Set k
forall a. Ord a => Set a -> Set a -> Set a
S.union Set k
interior (Set k -> Set k) -> Set k -> Set k
forall a b. (a -> b) -> a -> b
$ [k] -> Set k
forall a. Ord a => [a] -> Set a
S.fromList [k]
boundary
                                boundary' :: [k]
boundary' = [k] -> [k]
forall a. Ord a => [a] -> [a]
toSet [k
v | k
u <- [k]
boundary, k
v <- [k] -> k -> Map k [k] -> [k]
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault [] k
u Map k [k]
succs,
                                                       (k -> Bool) -> [k] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (k -> Set k -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set k
interior') (Map k [k]
preds Map k [k] -> k -> [k]
forall k a. Ord k => Map k a -> k -> a
M.! k
v) ]
                            in [k]
boundary [k] -> [[k]] -> [[k]]
forall a. a -> [a] -> [a]
: Set k -> [k] -> [[k]]
heightPartition' Set k
interior' [k]
boundary'

isDAG :: Digraph a -> Bool
isDAG dag :: Digraph a
dag@(DG vs :: [a]
vs _) = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
vs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Digraph a -> [[a]]
forall k. Ord k => Digraph k -> [[k]]
heightPartitionDAG Digraph a
dag))

-- Only valid for DAGs, not for digraphs in general
dagIsos :: Digraph a -> Digraph a -> [[(a, a)]]
dagIsos dagA :: Digraph a
dagA@(DG vsA :: [a]
vsA esA :: [(a, a)]
esA) dagB :: Digraph a
dagB@(DG vsB :: [a]
vsB esB :: [(a, a)]
esB)
    | [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
vsA Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[a]]
heightPartA) = String -> [[(a, a)]]
forall a. HasCallStack => String -> a
error "dagIsos: dagA is not a DAG"
    | [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
vsB Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[a]]
heightPartB) = String -> [[(a, a)]]
forall a. HasCallStack => String -> a
error "dagIsos: dagB is not a DAG"
    | ([a] -> Int) -> [[a]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[a]]
heightPartA [Int] -> [Int] -> Bool
forall a. Eq a => a -> a -> Bool
/= ([a] -> Int) -> [[a]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[a]]
heightPartB = []
    | Bool
otherwise = [(a, a)] -> [[a]] -> [[a]] -> [[(a, a)]]
dfs [] [[a]]
heightPartA [[a]]
heightPartB
    where heightPartA :: [[a]]
heightPartA = Digraph a -> [[a]]
forall k. Ord k => Digraph k -> [[k]]
heightPartitionDAG Digraph a
dagA
          heightPartB :: [[a]]
heightPartB = Digraph a -> [[a]]
forall k. Ord k => Digraph k -> [[k]]
heightPartitionDAG Digraph a
dagB
          (predsA :: Map a [a]
predsA,_) = Digraph a -> (Map a [a], Map a [a])
forall a. Ord a => Digraph a -> (Map a [a], Map a [a])
adjLists Digraph a
dagA
          (predsB :: Map a [a]
predsB,_) = Digraph a -> (Map a [a], Map a [a])
forall a. Ord a => Digraph a -> (Map a [a], Map a [a])
adjLists Digraph a
dagB
          dfs :: [(a, a)] -> [[a]] -> [[a]] -> [[(a, a)]]
dfs xys :: [(a, a)]
xys [] [] = [[(a, a)]
xys]
          dfs xys :: [(a, a)]
xys ([]:las :: [[a]]
las) ([]:lbs :: [[a]]
lbs) = [(a, a)] -> [[a]] -> [[a]] -> [[(a, a)]]
dfs [(a, a)]
xys [[a]]
las [[a]]
lbs
          dfs xys :: [(a, a)]
xys ((x :: a
x:xs :: [a]
xs):las :: [[a]]
las) (ys :: [a]
ys:lbs :: [[a]]
lbs) =
              [[[(a, a)]]] -> [[(a, a)]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [(a, a)] -> [[a]] -> [[a]] -> [[(a, a)]]
dfs ((a
x,a
y)(a, a) -> [(a, a)] -> [(a, a)]
forall a. a -> [a] -> [a]
:[(a, a)]
xys) ([a]
xs[a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
:[[a]]
las) ([a]
ys' [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [[a]]
lbs)
                     | (y :: a
y,ys' :: [a]
ys') <- [a] -> [(a, [a])]
forall a. [a] -> [(a, [a])]
picks [a]
ys, (a, a) -> [(a, a)] -> Bool
isCompatible (a
x,a
y) [(a, a)]
xys]
          isCompatible :: (a, a) -> [(a, a)] -> Bool
isCompatible (x :: a
x,y :: a
y) xys :: [(a, a)]
xys =
              let preds_x :: [a]
preds_x = [a] -> a -> Map a [a] -> [a]
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault [] a
x Map a [a]
predsA
                  preds_y :: [a]
preds_y = [a] -> a -> Map a [a] -> [a]
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault [] a
y Map a [a]
predsB
              in [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ (a
x' a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [a]
preds_x) Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== (a
y' a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [a]
preds_y) | (x' :: a
x',y' :: a
y') <- [(a, a)]
xys]
              -- and [ ((x',x) `elem` esA) == ((y',y) `elem` esB)
              --     | (x',y') <- xys ]
          -- we only need to check predecessors, not successors, because we proceeding by height ordering

-- can probably do better by intersecting the height partition with the (indegree,outdegree) partition
-- (although on very symmetrical posets such as B n, this won't help at all)

-- |Are the two DAGs isomorphic?
isDagIso :: (Ord a, Ord b) => Digraph a -> Digraph b -> Bool
isDagIso :: Digraph a -> Digraph b -> Bool
isDagIso dagA :: Digraph a
dagA dagB :: Digraph b
dagB = (Bool -> Bool
not (Bool -> Bool) -> ([[(a, b)]] -> Bool) -> [[(a, b)]] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[(a, b)]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) (Digraph a -> Digraph b -> [[(a, b)]]
forall a a. (Ord a, Ord a) => Digraph a -> Digraph a -> [[(a, a)]]
dagIsos Digraph a
dagA Digraph b
dagB)


perms :: [a] -> [[a]]
perms [] = [[]]
perms (x :: a
x:xs :: [a]
xs) = [[a]
ls [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a
x] [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
rs | [a]
ps <- [a] -> [[a]]
perms [a]
xs, (ls :: [a]
ls,rs :: [a]
rs) <- [[a]] -> [[a]] -> [([a], [a])]
forall a b. [a] -> [b] -> [(a, b)]
zip ([a] -> [[a]]
forall a. [a] -> [[a]]
inits [a]
ps) ([a] -> [[a]]
forall a. [a] -> [[a]]
tails [a]
ps)]
-- or use L.permutations

{-
-- orderings compatible with the height partition
heightOrderingsDAG dag@(DG vs es) = heightOrderings' [[]] (heightPartitionDAG dag)
    where heightOrderings' initsegs (level:levels) =
              let addsegs = perms level
                  initsegs' = [init ++ add | init <- initsegs, add <- addsegs]
              in heightOrderings' initsegs' levels
          heightOrderings' segs [] = segs
-}

isoRepDAG1 :: Digraph k -> Digraph Int
isoRepDAG1 dag :: Digraph k
dag@(DG vs :: [k]
vs es :: [(k, k)]
es) = [Map k Int] -> Int -> [[k]] -> Digraph Int
isoRepDAG' [Map k Int
forall k a. Map k a
M.empty] 1 (Digraph k -> [[k]]
forall k. Ord k => Digraph k -> [[k]]
heightPartitionDAG Digraph k
dag)
    where isoRepDAG' :: [Map k Int] -> Int -> [[k]] -> Digraph Int
isoRepDAG' initmaps :: [Map k Int]
initmaps j :: Int
j (level :: [k]
level:levels :: [[k]]
levels) =
              let j' :: Int
j' = Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [k] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [k]
level
                  addmaps :: [Map k Int]
addmaps = [[(k, Int)] -> Map k Int
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([k] -> [Int] -> [(k, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [k]
ps [Int
j..]) | [k]
ps <- [k] -> [[k]]
forall a. [a] -> [[a]]
perms [k]
level]
                  initmaps' :: [Map k Int]
initmaps' = [Map k Int
init Map k Int -> Map k Int -> Map k Int
forall k a. Ord k => Map k a -> Map k a -> Map k a
+++ Map k Int
add | Map k Int
init <- [Map k Int]
initmaps, Map k Int
add <- [Map k Int]
addmaps]
              in [Map k Int] -> Int -> [[k]] -> Digraph Int
isoRepDAG' [Map k Int]
initmaps' Int
j' [[k]]
levels
          isoRepDAG' maps :: [Map k Int]
maps _ [] = [Int] -> [(Int, Int)] -> Digraph Int
forall v. [v] -> [(v, v)] -> Digraph v
DG [1..[k] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [k]
vs] ([[(Int, Int)]] -> [(Int, Int)]
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [[(Int, Int)] -> [(Int, Int)]
forall a. Ord a => [a] -> [a]
L.sort (((k, k) -> (Int, Int)) -> [(k, k)] -> [(Int, Int)]
forall a b. (a -> b) -> [a] -> [b]
map (\(u :: k
u,v :: k
v) -> (Map k Int
m Map k Int -> k -> Int
forall k a. Ord k => Map k a -> k -> a
M.! k
u, Map k Int
m Map k Int -> k -> Int
forall k a. Ord k => Map k a -> k -> a
M.! k
v)) [(k, k)]
es) | Map k Int
m <- [Map k Int]
maps])
          initmap :: Map k a
initmap +++ :: Map k a -> Map k a -> Map k a
+++ addmap :: Map k a
addmap = Map k a -> Map k a -> Map k a
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union Map k a
initmap Map k a
addmap

-- For example
-- > isoRepDAG1 (DG ['a'..'e'] [('a','c'),('a','d'),('b','d'),('b','e'),('d','e')])
-- ([1,2,3,4,5],[(1,3),(1,4),(2,3),(2,5),(3,5)])
-- > isoRepDAG1 (DG ['a'..'e'] [('a','d'),('a','e'),('b','c'),('b','d'),('d','e')])
-- ([1,2,3,4,5],[(1,3),(1,4),(2,3),(2,5),(3,5)])


-- Find the minimum height-preserving numberings of the vertices, using dfs
isoRepDAG2 :: Digraph a -> [(a, b)]
isoRepDAG2 dag :: Digraph a
dag@(DG vs :: [a]
vs es :: [(a, a)]
es) = [[(a, b)]] -> [(a, b)]
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ([[(a, b)]] -> [(a, b)]) -> [[(a, b)]] -> [(a, b)]
forall a b. (a -> b) -> a -> b
$ [(a, b)] -> [[a]] -> [[b]] -> [[(a, b)]]
forall a b. [(a, b)] -> [[a]] -> [[b]] -> [[(a, b)]]
dfs [] [[a]]
srclevels [[b]]
forall a. (Num a, Enum a) => [[a]]
trglevels
    where -- (preds,succs) = adjLists dag
          srclevels :: [[a]]
srclevels = Digraph a -> [[a]]
forall k. Ord k => Digraph k -> [[k]]
heightPartitionDAG Digraph a
dag
          trglevels :: [[a]]
trglevels = [[a]] -> [[a]]
forall a. [a] -> [a]
reverse ([[a]] -> [[a]]) -> [[a]] -> [[a]]
forall a b. (a -> b) -> a -> b
$ ([[a]], [a]) -> [[a]]
forall a b. (a, b) -> a
fst (([[a]], [a]) -> [[a]]) -> ([[a]], [a]) -> [[a]]
forall a b. (a -> b) -> a -> b
$ (([[a]], [a]) -> [a] -> ([[a]], [a]))
-> ([[a]], [a]) -> [[a]] -> ([[a]], [a])
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
                      (\(tls :: [[a]]
tls,is :: [a]
is) sl :: [a]
sl -> let (js :: [a]
js,ks :: [a]
ks) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
sl) [a]
is in ([a]
js[a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
:[[a]]
tls,[a]
ks))
                      ([],[1..]) [[a]]
srclevels
          dfs :: [(a, b)] -> [[a]] -> [[b]] -> [[(a, b)]]
dfs xys :: [(a, b)]
xys [] [] = [[(a, b)]
xys]
          dfs xys :: [(a, b)]
xys ([]:sls :: [[a]]
sls) ([]:tls :: [[b]]
tls) = [(a, b)] -> [[a]] -> [[b]] -> [[(a, b)]]
dfs [(a, b)]
xys [[a]]
sls [[b]]
tls
          dfs xys :: [(a, b)]
xys ((x :: a
x:xs :: [a]
xs):sls :: [[a]]
sls) (ys :: [b]
ys:tls :: [[b]]
tls) =
              [[[(a, b)]]] -> [[(a, b)]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [(a, b)] -> [[a]] -> [[b]] -> [[(a, b)]]
dfs ((a
x,b
y)(a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
:[(a, b)]
xys) ([a]
xs[a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
:[[a]]
sls) ([b]
ys' [b] -> [[b]] -> [[b]]
forall a. a -> [a] -> [a]
: [[b]]
tls) | (y :: b
y,ys' :: [b]
ys') <- [b] -> [(b, [b])]
forall a. [a] -> [(a, [a])]
picks [b]
ys]
              -- not applying any compatibility condition yet


-- Find the height-respecting numbering of the vertices which leads to the minimal numbering of the edges
-- So this is calculating the same function as isoRepDAG1, but more efficiently
-- Uses dfs with pruning, rather than exhaustive search
isoRepDAG3 :: Digraph v -> Digraph Int
isoRepDAG3 dag :: Digraph v
dag@(DG vs :: [v]
vs es :: [(v, v)]
es) = ([(Int, Int)], (Int, Int), Map v Int, ([[v]], [[Int]]))
-> [([(Int, Int)], (Int, Int), Map v Int, ([[v]], [[Int]]))]
-> Digraph Int
dfs ([(Int, Int)], (Int, Int), Map v Int, ([[v]], [[Int]]))
forall a b a a k a.
(Num a, Num b, Num a, Enum a) =>
([a], (a, b), Map k a, ([[v]], [[a]]))
root [([(Int, Int)], (Int, Int), Map v Int, ([[v]], [[Int]]))
forall a b a a k a.
(Num a, Num b, Num a, Enum a) =>
([a], (a, b), Map k a, ([[v]], [[a]]))
root]
    where n :: Int
n = [v] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [v]
vs
          root :: ([a], (a, b), Map k a, ([[v]], [[a]]))
root = ([],(1,0),Map k a
forall k a. Map k a
M.empty,([[v]]
srclevels,[[a]]
forall a. (Num a, Enum a) => [[a]]
trglevels)) -- root of the search tree
          (preds :: Map v [v]
preds,succs :: Map v [v]
succs) = Digraph v -> (Map v [v], Map v [v])
forall a. Ord a => Digraph a -> (Map a [a], Map a [a])
adjLists Digraph v
dag
          srclevels :: [[v]]
srclevels = Digraph v -> [[v]]
forall k. Ord k => Digraph k -> [[k]]
heightPartitionDAG Digraph v
dag
          trglevels :: [[a]]
trglevels = [[a]] -> [[a]]
forall a. [a] -> [a]
reverse ([[a]] -> [[a]]) -> [[a]] -> [[a]]
forall a b. (a -> b) -> a -> b
$ ([[a]], [a]) -> [[a]]
forall a b. (a, b) -> a
fst (([[a]], [a]) -> [[a]]) -> ([[a]], [a]) -> [[a]]
forall a b. (a -> b) -> a -> b
$ (([[a]], [a]) -> [v] -> ([[a]], [a]))
-> ([[a]], [a]) -> [[v]] -> ([[a]], [a])
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
                      (\(tls :: [[a]]
tls,is :: [a]
is) sl :: [v]
sl -> let (js :: [a]
js,ks :: [a]
ks) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt ([v] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [v]
sl) [a]
is in ([a]
js[a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
:[[a]]
tls,[a]
ks))
                      ([],[1..]) [[v]]
srclevels
          dfs :: ([(Int, Int)], (Int, Int), Map v Int, ([[v]], [[Int]]))
-> [([(Int, Int)], (Int, Int), Map v Int, ([[v]], [[Int]]))]
-> Digraph Int
dfs best :: ([(Int, Int)], (Int, Int), Map v Int, ([[v]], [[Int]]))
best (node :: ([(Int, Int)], (Int, Int), Map v Int, ([[v]], [[Int]]))
node:stack :: [([(Int, Int)], (Int, Int), Map v Int, ([[v]], [[Int]]))]
stack) =
              -- node : -- for debugging
              case ([(Int, Int)], (Int, Int), Map v Int, ([[v]], [[Int]]))
-> ([(Int, Int)], (Int, Int), Map v Int, ([[v]], [[Int]]))
-> Ordering
forall a b b c d c d.
(Ord a, Ord b) =>
([(a, b)], b, c, d) -> ([(a, b)], (a, b), c, d) -> Ordering
cmpPartial ([(Int, Int)], (Int, Int), Map v Int, ([[v]], [[Int]]))
best ([(Int, Int)], (Int, Int), Map v Int, ([[v]], [[Int]]))
node of
              LT -> ([(Int, Int)], (Int, Int), Map v Int, ([[v]], [[Int]]))
-> [([(Int, Int)], (Int, Int), Map v Int, ([[v]], [[Int]]))]
-> Digraph Int
dfs ([(Int, Int)], (Int, Int), Map v Int, ([[v]], [[Int]]))
best [([(Int, Int)], (Int, Int), Map v Int, ([[v]], [[Int]]))]
stack                      -- ie prune the search tree at this node
              GT -> ([(Int, Int)], (Int, Int), Map v Int, ([[v]], [[Int]]))
-> [([(Int, Int)], (Int, Int), Map v Int, ([[v]], [[Int]]))]
-> Digraph Int
dfs ([(Int, Int)], (Int, Int), Map v Int, ([[v]], [[Int]]))
node (([(Int, Int)], (Int, Int), Map v Int, ([[v]], [[Int]]))
-> [([(Int, Int)], (Int, Int), Map v Int, ([[v]], [[Int]]))]
forall a b.
(Ord a, Num a) =>
([(a, a)], (a, b), Map v a, ([[v]], [[a]]))
-> [([(a, a)], (a, a), Map v a, ([[v]], [[a]]))]
successors ([(Int, Int)], (Int, Int), Map v Int, ([[v]], [[Int]]))
node [([(Int, Int)], (Int, Int), Map v Int, ([[v]], [[Int]]))]
-> [([(Int, Int)], (Int, Int), Map v Int, ([[v]], [[Int]]))]
-> [([(Int, Int)], (Int, Int), Map v Int, ([[v]], [[Int]]))]
forall a. [a] -> [a] -> [a]
++ [([(Int, Int)], (Int, Int), Map v Int, ([[v]], [[Int]]))]
stack) -- ie replace best with this node
              EQ -> ([(Int, Int)], (Int, Int), Map v Int, ([[v]], [[Int]]))
-> [([(Int, Int)], (Int, Int), Map v Int, ([[v]], [[Int]]))]
-> Digraph Int
dfs ([(Int, Int)], (Int, Int), Map v Int, ([[v]], [[Int]]))
best (([(Int, Int)], (Int, Int), Map v Int, ([[v]], [[Int]]))
-> [([(Int, Int)], (Int, Int), Map v Int, ([[v]], [[Int]]))]
forall a b.
(Ord a, Num a) =>
([(a, a)], (a, b), Map v a, ([[v]], [[a]]))
-> [([(a, a)], (a, a), Map v a, ([[v]], [[a]]))]
successors ([(Int, Int)], (Int, Int), Map v Int, ([[v]], [[Int]]))
node [([(Int, Int)], (Int, Int), Map v Int, ([[v]], [[Int]]))]
-> [([(Int, Int)], (Int, Int), Map v Int, ([[v]], [[Int]]))]
-> [([(Int, Int)], (Int, Int), Map v Int, ([[v]], [[Int]]))]
forall a. [a] -> [a] -> [a]
++ [([(Int, Int)], (Int, Int), Map v Int, ([[v]], [[Int]]))]
stack)
          -- dfs best [] = [best] -- !! for debugging
          dfs best :: ([(Int, Int)], (Int, Int), Map v Int, ([[v]], [[Int]]))
best@(es' :: [(Int, Int)]
es',_,_,_) [] = [Int] -> [(Int, Int)] -> Digraph Int
forall v. [v] -> [(v, v)] -> Digraph v
DG [1..Int
n] [(Int, Int)]
es'
          successors :: ([(a, a)], (a, b), Map v a, ([[v]], [[a]]))
-> [([(a, a)], (a, a), Map v a, ([[v]], [[a]]))]
successors (es :: [(a, a)]
es,_,_,([],[])) = []
          successors (es :: [(a, a)]
es,(i :: a
i,j :: b
j),m :: Map v a
m,([]:sls :: [[v]]
sls,[]:tls :: [[a]]
tls)) = ([(a, a)], (a, b), Map v a, ([[v]], [[a]]))
-> [([(a, a)], (a, a), Map v a, ([[v]], [[a]]))]
successors ([(a, a)]
es,(a
i,b
j),Map v a
m,([[v]]
sls,[[a]]
tls))
          successors (es :: [(a, a)]
es,(i :: a
i,j :: b
j),m :: Map v a
m,(xs :: [v]
xs:sls :: [[v]]
sls,(y :: a
y:ys :: [a]
ys):tls :: [[a]]
tls)) =
              [ ([(a, a)]
es', (a
i',a
y), Map v a
m', (v -> [v] -> [v]
forall a. Eq a => a -> [a] -> [a]
L.delete v
x [v]
xs [v] -> [[v]] -> [[v]]
forall a. a -> [a] -> [a]
: [[v]]
sls, [a]
ys [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [[a]]
tls))
              | v
x <- [v]
xs,
                let m' :: Map v a
m' = v -> a -> Map v a -> Map v a
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert v
x a
y Map v a
m,
                let es' :: [(a, a)]
es' = [(a, a)] -> [(a, a)]
forall a. Ord a => [a] -> [a]
L.sort ([(a, a)] -> [(a, a)]) -> [(a, a)] -> [(a, a)]
forall a b. (a -> b) -> a -> b
$ [(a, a)]
es [(a, a)] -> [(a, a)] -> [(a, a)]
forall a. [a] -> [a] -> [a]
++ [(Map v a
m Map v a -> v -> a
forall k a. Ord k => Map k a -> k -> a
M.! v
u, a
y) | v
u <- [v] -> v -> Map v [v] -> [v]
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault [] v
x Map v [v]
preds],
                let i' :: a
i' = Map v a -> a -> a
forall t. (Num t, Eq t) => Map v t -> t -> t
nextunfinished Map v a
m' a
i ]
          -- a vertex is considered finished when all its successors have assignments in the map
          nextunfinished :: Map v t -> t -> t
nextunfinished m :: Map v t
m i :: t
i =
              case [v
v | (v :: v
v,i' :: t
i') <- Map v t -> [(v, t)]
forall k a. Map k a -> [(k, a)]
M.assocs Map v t
m, t
i' t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
i] of
              [] -> t
i
              [u :: v
u] -> if (v -> Bool) -> [v] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (v -> Map v t -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`M.member` Map v t
m) ([v] -> v -> Map v [v] -> [v]
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault [] v
u Map v [v]
succs)
                     then Map v t -> t -> t
nextunfinished Map v t
m (t
it -> t -> t
forall a. Num a => a -> a -> a
+1) -- i is finished: all successors already have assignments in the map
                     else t
i
          cmpPartial :: ([(a, b)], b, c, d) -> ([(a, b)], (a, b), c, d) -> Ordering
cmpPartial (es :: [(a, b)]
es,_,_,_) (es' :: [(a, b)]
es',(i' :: a
i',j' :: b
j'),_,_) = 
              (a, b) -> [(a, b)] -> [(a, b)] -> Ordering
forall a b.
(Ord a, Ord b) =>
(a, b) -> [(a, b)] -> [(a, b)] -> Ordering
cmpPartial' (a
i',b
j') [(a, b)]
es [(a, b)]
es'
              -- where j' = maximum $ 0 : map snd es'
          cmpPartial' :: (a, b) -> [(a, b)] -> [(a, b)] -> Ordering
cmpPartial' (i' :: a
i',j' :: b
j') ((u :: a
u,v :: b
v):es :: [(a, b)]
es) ((u' :: a
u',v' :: b
v'):es' :: [(a, b)]
es') =
          -- Any new e' that can be added to es' must be greater than (i',j')
          -- (we don't care about possible extensions of es, because we're not extending them)
              case (a, b) -> (a, b) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (a
u,b
v) (a
u',b
v') of
              EQ -> (a, b) -> [(a, b)] -> [(a, b)] -> Ordering
cmpPartial' (a
i',b
j') [(a, b)]
es [(a, b)]
es'
              LT -> if (a
u,b
v) (a, b) -> (a, b) -> Bool
forall a. Ord a => a -> a -> Bool
<= (a
i',b
j') then Ordering
LT else Ordering
EQ
              GT -> Ordering
GT -- always replace best if you beat it
                       -- (even if it could improve, it's not going to as we're not progressing it)
          cmpPartial' (i' :: a
i',j' :: b
j') ((u :: a
u,v :: b
v):es :: [(a, b)]
es) [] = if (a
u,b
v) (a, b) -> (a, b) -> Bool
forall a. Ord a => a -> a -> Bool
<= (a
i',b
j') then Ordering
LT else Ordering
EQ
          cmpPartial' _ [] ((u' :: a
u',v' :: b
v'):es' :: [(a, b)]
es') = Ordering
GT -- always extend an existing partial best
          cmpPartial' _ [] [] = Ordering
EQ


-- Now we seek a numbering of the vertices which respects height-ordering,
-- and within each height level respects (indegree,outdegree) ordering.
-- We seek the numbering which minimises the resulting edge list.


-- |Given a directed acyclic graph (DAG), return a canonical representative for its isomorphism class.
-- @isoRepDAG dag@ is isomorphic to @dag@. It follows that if @isoRepDAG dagA == isoRepDAG dagB@ then @dagA@ is isomorphic to @dagB@.
-- Conversely, @isoRepDAG dag@ is the minimal element in the isomorphism class, subject to some constraints.
-- It follows that if @dagA@ is isomorphic to @dagB@, then @isoRepDAG dagA == isoRepDAG dagB@.
--
-- The algorithm of course is faster on some DAGs than others: roughly speaking,
-- it prefers \"tall\" DAGs (long chains) to \"wide\" DAGs (long antichains),
-- and it prefers asymmetric DAGs (ie those with smaller automorphism groups).
isoRepDAG :: (Ord a) => Digraph a -> Digraph Int
isoRepDAG :: Digraph a -> Digraph Int
isoRepDAG dag :: Digraph a
dag@(DG vs :: [a]
vs es :: [(a, a)]
es) = ([(Int, Int)], (Int, Int), Map a Int, ([[a]], [[Int]]))
-> [([(Int, Int)], (Int, Int), Map a Int, ([[a]], [[Int]]))]
-> Digraph Int
dfs ([(Int, Int)], (Int, Int), Map a Int, ([[a]], [[Int]]))
forall a b a a k a.
(Num a, Num b, Num a, Enum a) =>
([a], (a, b), Map k a, ([[a]], [[a]]))
root [([(Int, Int)], (Int, Int), Map a Int, ([[a]], [[Int]]))
forall a b a a k a.
(Num a, Num b, Num a, Enum a) =>
([a], (a, b), Map k a, ([[a]], [[a]]))
root]
    where n :: Int
n = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
vs
          root :: ([a], (a, b), Map k a, ([[a]], [[a]]))
root = ([],(1,0),Map k a
forall k a. Map k a
M.empty,([[a]]
srclevels,[[a]]
forall a. (Num a, Enum a) => [[a]]
trglevels)) -- root of the search tree
          (preds :: Map a [a]
preds,succs :: Map a [a]
succs) = Digraph a -> (Map a [a], Map a [a])
forall a. Ord a => Digraph a -> (Map a [a], Map a [a])
adjLists Digraph a
dag
          indegs :: Map a Int
indegs = ([a] -> Int) -> Map a [a] -> Map a Int
forall a b k. (a -> b) -> Map k a -> Map k b
M.map [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Map a [a]
preds
          outdegs :: Map a Int
outdegs = ([a] -> Int) -> Map a [a] -> Map a Int
forall a b k. (a -> b) -> Map k a -> Map k b
M.map [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Map a [a]
succs
          byDegree :: [a] -> [[a]]
byDegree vs :: [a]
vs = (([((Int, Int), a)] -> [a]) -> [[((Int, Int), a)]] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map (([((Int, Int), a)] -> [a]) -> [[((Int, Int), a)]] -> [[a]])
-> ((((Int, Int), a) -> a) -> [((Int, Int), a)] -> [a])
-> (((Int, Int), a) -> a)
-> [[((Int, Int), a)]]
-> [[a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((Int, Int), a) -> a) -> [((Int, Int), a)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map) ((Int, Int), a) -> a
forall a b. (a, b) -> b
snd ([[((Int, Int), a)]] -> [[a]]) -> [[((Int, Int), a)]] -> [[a]]
forall a b. (a -> b) -> a -> b
$ (((Int, Int), a) -> ((Int, Int), a) -> Bool)
-> [((Int, Int), a)] -> [[((Int, Int), a)]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
L.groupBy (\(du :: (Int, Int)
du,u :: a
u) (dv :: (Int, Int)
dv,v :: a
v) -> (Int, Int)
du (Int, Int) -> (Int, Int) -> Bool
forall a. Eq a => a -> a -> Bool
== (Int, Int)
dv) ([((Int, Int), a)] -> [[((Int, Int), a)]])
-> [((Int, Int), a)] -> [[((Int, Int), a)]]
forall a b. (a -> b) -> a -> b
$ [((Int, Int), a)] -> [((Int, Int), a)]
forall a. Ord a => [a] -> [a]
L.sort
                        [( (Int -> a -> Map a Int -> Int
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault 0 a
v Map a Int
indegs, Int -> a -> Map a Int -> Int
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault 0 a
v Map a Int
outdegs), a
v) | a
v <- [a]
vs]
          srclevels :: [[a]]
srclevels = ([a] -> [[a]]) -> [[a]] -> [[a]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [a] -> [[a]]
byDegree ([[a]] -> [[a]]) -> [[a]] -> [[a]]
forall a b. (a -> b) -> a -> b
$ Digraph a -> [[a]]
forall k. Ord k => Digraph k -> [[k]]
heightPartitionDAG Digraph a
dag
          trglevels :: [[a]]
trglevels = [[a]] -> [[a]]
forall a. [a] -> [a]
reverse ([[a]] -> [[a]]) -> [[a]] -> [[a]]
forall a b. (a -> b) -> a -> b
$ ([[a]], [a]) -> [[a]]
forall a b. (a, b) -> a
fst (([[a]], [a]) -> [[a]]) -> ([[a]], [a]) -> [[a]]
forall a b. (a -> b) -> a -> b
$ (([[a]], [a]) -> [a] -> ([[a]], [a]))
-> ([[a]], [a]) -> [[a]] -> ([[a]], [a])
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
                      (\(tls :: [[a]]
tls,is :: [a]
is) sl :: [a]
sl -> let (js :: [a]
js,ks :: [a]
ks) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
sl) [a]
is in ([a]
js[a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
:[[a]]
tls,[a]
ks))
                      ([],[1..]) [[a]]
srclevels
          dfs :: ([(Int, Int)], (Int, Int), Map a Int, ([[a]], [[Int]]))
-> [([(Int, Int)], (Int, Int), Map a Int, ([[a]], [[Int]]))]
-> Digraph Int
dfs best :: ([(Int, Int)], (Int, Int), Map a Int, ([[a]], [[Int]]))
best (node :: ([(Int, Int)], (Int, Int), Map a Int, ([[a]], [[Int]]))
node:stack :: [([(Int, Int)], (Int, Int), Map a Int, ([[a]], [[Int]]))]
stack) =
              -- node : -- for debugging
              case ([(Int, Int)], (Int, Int), Map a Int, ([[a]], [[Int]]))
-> ([(Int, Int)], (Int, Int), Map a Int, ([[a]], [[Int]]))
-> Ordering
forall a b b c d c d.
(Ord a, Ord b) =>
([(a, b)], b, c, d) -> ([(a, b)], (a, b), c, d) -> Ordering
cmpPartial ([(Int, Int)], (Int, Int), Map a Int, ([[a]], [[Int]]))
best ([(Int, Int)], (Int, Int), Map a Int, ([[a]], [[Int]]))
node of
              LT -> ([(Int, Int)], (Int, Int), Map a Int, ([[a]], [[Int]]))
-> [([(Int, Int)], (Int, Int), Map a Int, ([[a]], [[Int]]))]
-> Digraph Int
dfs ([(Int, Int)], (Int, Int), Map a Int, ([[a]], [[Int]]))
best [([(Int, Int)], (Int, Int), Map a Int, ([[a]], [[Int]]))]
stack                      -- ie prune the search tree at this node
              GT -> ([(Int, Int)], (Int, Int), Map a Int, ([[a]], [[Int]]))
-> [([(Int, Int)], (Int, Int), Map a Int, ([[a]], [[Int]]))]
-> Digraph Int
dfs ([(Int, Int)], (Int, Int), Map a Int, ([[a]], [[Int]]))
node (([(Int, Int)], (Int, Int), Map a Int, ([[a]], [[Int]]))
-> [([(Int, Int)], (Int, Int), Map a Int, ([[a]], [[Int]]))]
forall a b.
(Ord a, Num a) =>
([(a, a)], (a, b), Map a a, ([[a]], [[a]]))
-> [([(a, a)], (a, a), Map a a, ([[a]], [[a]]))]
successors ([(Int, Int)], (Int, Int), Map a Int, ([[a]], [[Int]]))
node [([(Int, Int)], (Int, Int), Map a Int, ([[a]], [[Int]]))]
-> [([(Int, Int)], (Int, Int), Map a Int, ([[a]], [[Int]]))]
-> [([(Int, Int)], (Int, Int), Map a Int, ([[a]], [[Int]]))]
forall a. [a] -> [a] -> [a]
++ [([(Int, Int)], (Int, Int), Map a Int, ([[a]], [[Int]]))]
stack) -- ie replace best with this node
              EQ -> ([(Int, Int)], (Int, Int), Map a Int, ([[a]], [[Int]]))
-> [([(Int, Int)], (Int, Int), Map a Int, ([[a]], [[Int]]))]
-> Digraph Int
dfs ([(Int, Int)], (Int, Int), Map a Int, ([[a]], [[Int]]))
best (([(Int, Int)], (Int, Int), Map a Int, ([[a]], [[Int]]))
-> [([(Int, Int)], (Int, Int), Map a Int, ([[a]], [[Int]]))]
forall a b.
(Ord a, Num a) =>
([(a, a)], (a, b), Map a a, ([[a]], [[a]]))
-> [([(a, a)], (a, a), Map a a, ([[a]], [[a]]))]
successors ([(Int, Int)], (Int, Int), Map a Int, ([[a]], [[Int]]))
node [([(Int, Int)], (Int, Int), Map a Int, ([[a]], [[Int]]))]
-> [([(Int, Int)], (Int, Int), Map a Int, ([[a]], [[Int]]))]
-> [([(Int, Int)], (Int, Int), Map a Int, ([[a]], [[Int]]))]
forall a. [a] -> [a] -> [a]
++ [([(Int, Int)], (Int, Int), Map a Int, ([[a]], [[Int]]))]
stack)
          -- dfs best [] = [best] -- !! for debugging
          dfs best :: ([(Int, Int)], (Int, Int), Map a Int, ([[a]], [[Int]]))
best@(es' :: [(Int, Int)]
es',_,_,_) [] = [Int] -> [(Int, Int)] -> Digraph Int
forall v. [v] -> [(v, v)] -> Digraph v
DG [1..Int
n] [(Int, Int)]
es'
          successors :: ([(a, a)], (a, b), Map a a, ([[a]], [[a]]))
-> [([(a, a)], (a, a), Map a a, ([[a]], [[a]]))]
successors (es :: [(a, a)]
es,_,_,([],[])) = []
          successors (es :: [(a, a)]
es,(i :: a
i,j :: b
j),m :: Map a a
m,([]:sls :: [[a]]
sls,[]:tls :: [[a]]
tls)) = ([(a, a)], (a, b), Map a a, ([[a]], [[a]]))
-> [([(a, a)], (a, a), Map a a, ([[a]], [[a]]))]
successors ([(a, a)]
es,(a
i,b
j),Map a a
m,([[a]]
sls,[[a]]
tls))
          successors (es :: [(a, a)]
es,(i :: a
i,j :: b
j),m :: Map a a
m,(xs :: [a]
xs:sls :: [[a]]
sls,(y :: a
y:ys :: [a]
ys):tls :: [[a]]
tls)) =
              [ ([(a, a)]
es', (a
i',a
y), Map a a
m', (a -> [a] -> [a]
forall a. Eq a => a -> [a] -> [a]
L.delete a
x [a]
xs [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [[a]]
sls, [a]
ys [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [[a]]
tls))
              | a
x <- [a]
xs,
                let m' :: Map a a
m' = a -> a -> Map a a -> Map a a
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert a
x a
y Map a a
m,
                let es' :: [(a, a)]
es' = [(a, a)] -> [(a, a)]
forall a. Ord a => [a] -> [a]
L.sort ([(a, a)] -> [(a, a)]) -> [(a, a)] -> [(a, a)]
forall a b. (a -> b) -> a -> b
$ [(a, a)]
es [(a, a)] -> [(a, a)] -> [(a, a)]
forall a. [a] -> [a] -> [a]
++ [(Map a a
m Map a a -> a -> a
forall k a. Ord k => Map k a -> k -> a
M.! a
u, a
y) | a
u <- [a] -> a -> Map a [a] -> [a]
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault [] a
x Map a [a]
preds],
                let i' :: a
i' = Map a a -> a -> a
forall t. (Num t, Eq t) => Map a t -> t -> t
nextunfinished Map a a
m' a
i ]
          -- a vertex is considered finished when all its successors have assignments in the map
          nextunfinished :: Map a t -> t -> t
nextunfinished m :: Map a t
m i :: t
i =
              case [a
v | (v :: a
v,i' :: t
i') <- Map a t -> [(a, t)]
forall k a. Map k a -> [(k, a)]
M.assocs Map a t
m, t
i' t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
i] of
              [] -> t
i
              [u :: a
u] -> if (a -> Bool) -> [a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (a -> Map a t -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`M.member` Map a t
m) ([a] -> a -> Map a [a] -> [a]
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault [] a
u Map a [a]
succs)
                     then Map a t -> t -> t
nextunfinished Map a t
m (t
it -> t -> t
forall a. Num a => a -> a -> a
+1) -- i is finished: all successors already have assignments in the map
                     else t
i
          cmpPartial :: ([(a, b)], b, c, d) -> ([(a, b)], (a, b), c, d) -> Ordering
cmpPartial (es :: [(a, b)]
es,_,_,_) (es' :: [(a, b)]
es',(i' :: a
i',j' :: b
j'),_,_) = 
              (a, b) -> [(a, b)] -> [(a, b)] -> Ordering
forall a b.
(Ord a, Ord b) =>
(a, b) -> [(a, b)] -> [(a, b)] -> Ordering
cmpPartial' (a
i',b
j') [(a, b)]
es [(a, b)]
es'
              -- where j' = maximum $ 0 : map snd es'
          cmpPartial' :: (a, b) -> [(a, b)] -> [(a, b)] -> Ordering
cmpPartial' (i' :: a
i',j' :: b
j') ((u :: a
u,v :: b
v):es :: [(a, b)]
es) ((u' :: a
u',v' :: b
v'):es' :: [(a, b)]
es') =
          -- Any new e' that can be added to es' must be greater than (i',j')
          -- (we don't care about possible extensions of es, because we're not extending them)
              case (a, b) -> (a, b) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (a
u,b
v) (a
u',b
v') of
              EQ -> (a, b) -> [(a, b)] -> [(a, b)] -> Ordering
cmpPartial' (a
i',b
j') [(a, b)]
es [(a, b)]
es'
              LT -> if (a
u,b
v) (a, b) -> (a, b) -> Bool
forall a. Ord a => a -> a -> Bool
<= (a
i',b
j') then Ordering
LT else Ordering
EQ
              GT -> Ordering
GT -- always replace best if you beat it
                       -- (even if it could improve, it's not going to as we're not progressing it)
          cmpPartial' (i' :: a
i',j' :: b
j') ((u :: a
u,v :: b
v):es :: [(a, b)]
es) [] = if (a
u,b
v) (a, b) -> (a, b) -> Bool
forall a. Ord a => a -> a -> Bool
<= (a
i',b
j') then Ordering
LT else Ordering
EQ
          cmpPartial' _ [] ((u' :: a
u',v' :: b
v'):es' :: [(a, b)]
es') = Ordering
GT -- always extend an existing partial best
          cmpPartial' _ [] [] = Ordering
EQ