{-# LANGUAGE NoMonomorphismRestriction #-}
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)
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
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
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]
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]
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]
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))
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]
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)]
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
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
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]
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))
(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) =
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
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)
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 :: ([(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 ]
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)
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'
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') =
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
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
cmpPartial' _ [] [] = Ordering
EQ
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))
(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) =
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
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)
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 :: ([(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 ]
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)
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'
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') =
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
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
cmpPartial' _ [] [] = Ordering
EQ