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


{-# LANGUAGE NoMonomorphismRestriction, TupleSections, DeriveFunctor #-}

module Math.Combinatorics.GraphAuts (isVertexTransitive, isEdgeTransitive,
                                     isArcTransitive, is2ArcTransitive, is3ArcTransitive, is4ArcTransitive, isnArcTransitive,
                                     isDistanceTransitive,
                                     graphAuts, incidenceAuts, graphAuts7, graphAuts8, incidenceAuts2,
                                     isGraphAut, isIncidenceAut,
                                     graphIsos, incidenceIsos,
                                     isGraphIso, isIncidenceIso) where

import Data.Either (lefts, rights, partitionEithers)
import qualified Data.List as L
import qualified Data.Map.Strict as M
import qualified Data.Set as S
import Data.Maybe
import Data.Ord (comparing)
import qualified Data.Foldable as Foldable
import qualified Data.Sequence as Seq

import Math.Common.ListSet
import Math.Core.Utils (combinationsOf, intersectAsc, pairs, picks, (^-))
import Math.Combinatorics.Graph
-- import Math.Combinatorics.StronglyRegularGraph

-- import Math.Combinatorics.Hypergraph -- can't import this, creates circular dependency

import Math.Algebra.Group.PermutationGroup
import Math.Algebra.Group.SchreierSims as SS


-- The code for finding automorphisms - "graphAuts" - follows later on in file



-- TRANSITIVITY PROPERTIES OF GRAPHS


-- |A graph is vertex-transitive if its automorphism group acts transitively on the vertices. Thus, given any two distinct vertices, there is an automorphism mapping one to the other.

isVertexTransitive :: (Ord t) => Graph t -> Bool
isVertexTransitive :: Graph t -> Bool
isVertexTransitive (G [] []) = Bool
True -- null graph is trivially vertex transitive

isVertexTransitive g :: Graph t
g@(G (v :: t
v:vs :: [t]
vs) es :: [[t]]
es) = [Permutation t] -> t -> [t]
forall t. Ord t => [Permutation t] -> t -> [t]
orbitV [Permutation t]
auts t
v [t] -> [t] -> Bool
forall a. Eq a => a -> a -> Bool
== t
vt -> [t] -> [t]
forall a. a -> [a] -> [a]
:[t]
vs where
    auts :: [Permutation t]
auts = Graph t -> [Permutation t]
forall a. Ord a => Graph a -> [Permutation a]
graphAuts Graph t
g

-- |A graph is edge-transitive if its automorphism group acts transitively on the edges. Thus, given any two distinct edges, there is an automorphism mapping one to the other.

isEdgeTransitive :: (Ord t) => Graph t -> Bool
isEdgeTransitive :: Graph t -> Bool
isEdgeTransitive (G _ []) = Bool
True
isEdgeTransitive g :: Graph t
g@(G vs :: [t]
vs (e :: [t]
e:es :: [[t]]
es)) = [Permutation t] -> [t] -> [[t]]
forall a. Ord a => [Permutation a] -> [a] -> [[a]]
orbitE [Permutation t]
auts [t]
e [[t]] -> [[t]] -> Bool
forall a. Eq a => a -> a -> Bool
== [t]
e[t] -> [[t]] -> [[t]]
forall a. a -> [a] -> [a]
:[[t]]
es where
    auts :: [Permutation t]
auts = Graph t -> [Permutation t]
forall a. Ord a => Graph a -> [Permutation a]
graphAuts Graph t
g

arc :: [b]
arc ->^ :: [b] -> Permutation b -> [b]
->^ g :: Permutation b
g = (b -> b) -> [b] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (b -> Permutation b -> b
forall a. Ord a => a -> Permutation a -> a
.^ Permutation b
g) [b]
arc
-- unlike edges/blocks, arcs are directed, so the action on them does not sort


-- Godsil & Royle 59-60

-- |A graph is arc-transitive (or flag-transitive) if its automorphism group acts transitively on arcs. (An arc is an ordered pair of adjacent vertices.)

isArcTransitive :: (Ord t) => Graph t -> Bool
isArcTransitive :: Graph t -> Bool
isArcTransitive (G _ []) = Bool
True -- empty graphs are trivially arc transitive

isArcTransitive g :: Graph t
g@(G vs :: [t]
vs es :: [[t]]
es) = ([t] -> Permutation t -> [t]) -> [t] -> [Permutation t] -> [[t]]
forall t1 t2. Ord t1 => (t1 -> t2 -> t1) -> t1 -> [t2] -> [t1]
orbit [t] -> Permutation t -> [t]
forall b. Ord b => [b] -> Permutation b -> [b]
(->^) [t]
a [Permutation t]
auts [[t]] -> [[t]] -> Bool
forall a. Eq a => a -> a -> Bool
== [t]
a[t] -> [[t]] -> [[t]]
forall a. a -> [a] -> [a]
:[[t]]
as where
-- isArcTransitive g@(G vs es) = closure [a] [ ->^ h | h <- auts] == a:as where

    a :: [t]
a:as :: [[t]]
as = [[t]] -> [[t]]
forall a. Ord a => [a] -> [a]
L.sort ([[t]] -> [[t]]) -> [[t]] -> [[t]]
forall a b. (a -> b) -> a -> b
$ [[t]]
es [[t]] -> [[t]] -> [[t]]
forall a. [a] -> [a] -> [a]
++ ([t] -> [t]) -> [[t]] -> [[t]]
forall a b. (a -> b) -> [a] -> [b]
map [t] -> [t]
forall a. [a] -> [a]
reverse [[t]]
es
    auts :: [Permutation t]
auts = Graph t -> [Permutation t]
forall a. Ord a => Graph a -> [Permutation a]
graphAuts Graph t
g

isArcTransitive' :: Graph a -> Bool
isArcTransitive' g :: Graph a
g@(G (v :: a
v:vs :: [a]
vs) es :: [[a]]
es) =
    [Permutation a] -> a -> [a]
forall t. Ord t => [Permutation t] -> t -> [t]
orbitP [Permutation a]
auts a
v [a] -> [a] -> Bool
forall a. Eq a => a -> a -> Bool
== a
va -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
vs Bool -> Bool -> Bool
&& -- isVertexTransitive g

    [Permutation a] -> a -> [a]
forall t. Ord t => [Permutation t] -> t -> [t]
orbitP [Permutation a]
stab a
n [a] -> [a] -> Bool
forall a. Eq a => a -> a -> Bool
== a
na -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ns
    where auts :: [Permutation a]
auts = Graph a -> [Permutation a]
forall a. Ord a => Graph a -> [Permutation a]
graphAuts Graph a
g
          stab :: [Permutation a]
stab = (Permutation a -> Bool) -> [Permutation a] -> [Permutation a]
forall a. (a -> Bool) -> [a] -> [a]
filter (\p :: Permutation a
p -> a
v a -> Permutation a -> a
forall a. Ord a => a -> Permutation a -> a
.^ Permutation a
p a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
v) [Permutation a]
auts -- relies on v being the first base for the SGS returned by graphAuts

          -- stab = dropWhile (\p -> v .^ p /= v) auts -- we know that graphAuts are returned in this order

          n :: a
n:ns :: [a]
ns = Graph a -> a -> [a]
forall a. Eq a => Graph a -> a -> [a]
nbrs Graph a
g a
v

-- execution time of both of the above is dominated by the time to calculate the graph auts, so their performance is similar



-- then k n, kb n n, q n, other platonic solids, petersen graph, heawood graph, pappus graph, desargues graph are all arc-transitive



-- find arcs of length l from x using dfs - results returned in order

-- an arc is a sequence of vertices connected by edges, no doubling back, but self-crossings allowed

findArcs :: Graph a -> a -> b -> [[a]]
findArcs g :: Graph a
g@(G vs :: [a]
vs es :: [[a]]
es) x :: a
x l :: b
l = ([a] -> [a]) -> [[a]] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map [a] -> [a]
forall a. [a] -> [a]
reverse ([[a]] -> [[a]]) -> [[a]] -> [[a]]
forall a b. (a -> b) -> a -> b
$ [([a], b)] -> [[a]]
dfs [ ([a
x],0) ] where
    dfs :: [([a], b)] -> [[a]]
dfs ( (z1 :: a
z1:z2 :: a
z2:zs :: [a]
zs,l' :: b
l') : nodes :: [([a], b)]
nodes)
        | b
l b -> b -> Bool
forall a. Eq a => a -> a -> Bool
== b
l'   = (a
z1a -> [a] -> [a]
forall a. a -> [a] -> [a]
:a
z2a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
zs) [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [([a], b)] -> [[a]]
dfs [([a], b)]
nodes
        | Bool
otherwise = [([a], b)] -> [[a]]
dfs ([([a], b)] -> [[a]]) -> [([a], b)] -> [[a]]
forall a b. (a -> b) -> a -> b
$ [(a
wa -> [a] -> [a]
forall a. a -> [a] -> [a]
:a
z1a -> [a] -> [a]
forall a. a -> [a] -> [a]
:a
z2a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
zs,b
l'b -> b -> b
forall a. Num a => a -> a -> a
+1) | a
w <- Graph a -> a -> [a]
forall a. Eq a => Graph a -> a -> [a]
nbrs Graph a
g a
z1, a
w a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
z2] [([a], b)] -> [([a], b)] -> [([a], b)]
forall a. [a] -> [a] -> [a]
++ [([a], b)]
nodes
    dfs ( ([z :: a
z],l' :: b
l') : nodes :: [([a], b)]
nodes)
        | b
l b -> b -> Bool
forall a. Eq a => a -> a -> Bool
== b
l'   = [a
z] [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [([a], b)] -> [[a]]
dfs [([a], b)]
nodes
        | Bool
otherwise = [([a], b)] -> [[a]]
dfs ([([a], b)] -> [[a]]) -> [([a], b)] -> [[a]]
forall a b. (a -> b) -> a -> b
$ [([a
w,a
z],b
l'b -> b -> b
forall a. Num a => a -> a -> a
+1) | a
w <- Graph a -> a -> [a]
forall a. Eq a => Graph a -> a -> [a]
nbrs Graph a
g a
z] [([a], b)] -> [([a], b)] -> [([a], b)]
forall a. [a] -> [a] -> [a]
++ [([a], b)]
nodes
    dfs [] = []

-- note that a graph with triangles can't be 3-arc transitive, etc, because an aut can't map a self-crossing arc to a non-self-crossing arc


-- |A graph is n-arc-transitive if its automorphism group is transitive on n-arcs. (An n-arc is an ordered sequence (v0,...,vn) of adjacent vertices, with crossings allowed but not doubling back.)

isnArcTransitive :: (Ord t) => Int -> Graph t -> Bool
isnArcTransitive :: Int -> Graph t -> Bool
isnArcTransitive _ (G [] []) = Bool
True
isnArcTransitive n :: Int
n g :: Graph t
g@(G (v :: t
v:vs :: [t]
vs) es :: [[t]]
es) =
    [Permutation t] -> t -> [t]
forall t. Ord t => [Permutation t] -> t -> [t]
orbitP [Permutation t]
auts t
v [t] -> [t] -> Bool
forall a. Eq a => a -> a -> Bool
== t
vt -> [t] -> [t]
forall a. a -> [a] -> [a]
:[t]
vs Bool -> Bool -> Bool
&& -- isVertexTransitive g

    ([t] -> Permutation t -> [t]) -> [t] -> [Permutation t] -> [[t]]
forall t1 t2. Ord t1 => (t1 -> t2 -> t1) -> t1 -> [t2] -> [t1]
orbit [t] -> Permutation t -> [t]
forall b. Ord b => [b] -> Permutation b -> [b]
(->^) [t]
a [Permutation t]
stab [[t]] -> [[t]] -> Bool
forall a. Eq a => a -> a -> Bool
== [t]
a[t] -> [[t]] -> [[t]]
forall a. a -> [a] -> [a]
:[[t]]
as
    -- closure [a] [ ->^ h | h <- stab] == a:as

    where auts :: [Permutation t]
auts = Graph t -> [Permutation t]
forall a. Ord a => Graph a -> [Permutation a]
graphAuts Graph t
g
          stab :: [Permutation t]
stab = (Permutation t -> Bool) -> [Permutation t] -> [Permutation t]
forall a. (a -> Bool) -> [a] -> [a]
filter (\p :: Permutation t
p -> t
v t -> Permutation t -> t
forall a. Ord a => a -> Permutation a -> a
.^ Permutation t
p t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
v) [Permutation t]
auts -- relies on v being the first base for the SGS returned by graphAuts

          -- stab = dropWhile (\p -> v .^ p /= v) auts -- we know that graphAuts are returned in this order

          a :: [t]
a:as :: [[t]]
as = Graph t -> t -> Int -> [[t]]
forall b a. (Eq b, Eq a, Num b) => Graph a -> a -> b -> [[a]]
findArcs Graph t
g t
v Int
n

is2ArcTransitive :: (Ord t) => Graph t -> Bool
is2ArcTransitive :: Graph t -> Bool
is2ArcTransitive g :: Graph t
g = Int -> Graph t -> Bool
forall t. Ord t => Int -> Graph t -> Bool
isnArcTransitive 2 Graph t
g

is3ArcTransitive :: (Ord t) => Graph t -> Bool
is3ArcTransitive :: Graph t -> Bool
is3ArcTransitive g :: Graph t
g = Int -> Graph t -> Bool
forall t. Ord t => Int -> Graph t -> Bool
isnArcTransitive 3 Graph t
g

-- The incidence graphs of the projective planes PG(2,Fq) are 4-arc-transitive

is4ArcTransitive :: (Ord t) => Graph t -> Bool
is4ArcTransitive :: Graph t -> Bool
is4ArcTransitive g :: Graph t
g = Int -> Graph t -> Bool
forall t. Ord t => Int -> Graph t -> Bool
isnArcTransitive 4 Graph t
g

-- Godsil & Royle 66-7

-- |A graph is distance transitive if given any two ordered pairs of vertices (u,u') and (v,v') with d(u,u') == d(v,v'),

-- there is an automorphism of the graph that takes (u,u') to (v,v')

isDistanceTransitive :: (Ord t) => Graph t -> Bool
isDistanceTransitive :: Graph t -> Bool
isDistanceTransitive (G [] []) = Bool
True
isDistanceTransitive g :: Graph t
g@(G (v :: t
v:vs :: [t]
vs) es :: [[t]]
es)
    | Graph t -> Bool
forall t. Ord t => Graph t -> Bool
isConnected Graph t
g =
        [Permutation t] -> t -> [t]
forall t. Ord t => [Permutation t] -> t -> [t]
orbitP [Permutation t]
auts t
v [t] -> [t] -> Bool
forall a. Eq a => a -> a -> Bool
== t
vt -> [t] -> [t]
forall a. a -> [a] -> [a]
:[t]
vs Bool -> Bool -> Bool
&& -- isVertexTransitive g

        [[t]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[t]]
stabOrbits Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Graph t -> Int
forall t. Ord t => Graph t -> Int
diameter Graph t
g Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1 -- the orbits under the stabiliser of v coincide with the distance partition from v

    | Bool
otherwise = [Char] -> Bool
forall a. HasCallStack => [Char] -> a
error "isDistanceTransitive: only implemented for connected graphs"
    where auts :: [Permutation t]
auts = Graph t -> [Permutation t]
forall a. Ord a => Graph a -> [Permutation a]
graphAuts Graph t
g
          stab :: [Permutation t]
stab = (Permutation t -> Bool) -> [Permutation t] -> [Permutation t]
forall a. (a -> Bool) -> [a] -> [a]
filter (\p :: Permutation t
p -> t
v t -> Permutation t -> t
forall a. Ord a => a -> Permutation a -> a
.^ Permutation t
p t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
v) [Permutation t]
auts -- relies on v being the first base for the SGS returned by graphAuts

          -- stab = dropWhile (\p -> v .^ p /= v) auts -- we know that graphAuts are returned in this order

          stabOrbits :: [[t]]
stabOrbits = let os :: [[t]]
os = [Permutation t] -> [[t]]
forall a. Ord a => [Permutation a] -> [[a]]
orbits [Permutation t]
stab in [[t]]
os [[t]] -> [[t]] -> [[t]]
forall a. [a] -> [a] -> [a]
++ (t -> [t]) -> [t] -> [[t]]
forall a b. (a -> b) -> [a] -> [b]
map (t -> [t] -> [t]
forall a. a -> [a] -> [a]
:[]) ((t
vt -> [t] -> [t]
forall a. a -> [a] -> [a]
:[t]
vs) [t] -> [t] -> [t]
forall a. Eq a => [a] -> [a] -> [a]
L.\\ [[t]] -> [t]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[t]]
os) -- include fixed point orbits



-- GRAPH AUTOMORPHISMS


-- |Is the permutation an automorphism of the graph?

isGraphAut :: Ord t => Graph t -> Permutation t -> Bool
isGraphAut :: Graph t -> Permutation t -> Bool
isGraphAut (G vs :: [t]
vs es :: [[t]]
es) h :: Permutation t
h = ([t] -> Bool) -> [[t]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ([t] -> Set [t] -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set [t]
es') [[t]
e [t] -> Permutation t -> [t]
forall b. Ord b => [b] -> Permutation b -> [b]
-^ Permutation t
h | [t]
e <- [[t]]
es]
    where es' :: Set [t]
es' = [[t]] -> Set [t]
forall a. Ord a => [a] -> Set a
S.fromList [[t]]
es
-- this works best on sparse graphs, where p(edge) < 1/2

-- if p(edge) > 1/2, it would be better to test on the complement of the graph


-- |Is the permutation an automorphism of the incidence structure represented by the graph?

-- (Note that an incidence graph colours points as Left, blocks as Right, and a permutation

-- that swaps points and blocks, even if it is an automorphism of the graph, does not represent

-- an automorphism of the incidence structure. Instead, a point-block crossover is called a duality.)

isIncidenceAut :: (Ord p, Ord b) => Graph (Either p b) -> Permutation (Either p b) -> Bool
isIncidenceAut :: Graph (Either p b) -> Permutation (Either p b) -> Bool
isIncidenceAut (G vs :: [Either p b]
vs es :: [[Either p b]]
es) h :: Permutation (Either p b)
h = ([Either p b] -> Bool) -> [[Either p b]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ([Either p b] -> Set [Either p b] -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set [Either p b]
es') [[Either p b]
e [Either p b] -> Permutation (Either p b) -> [Either p b]
forall b. Ord b => [b] -> Permutation b -> [b]
->^ Permutation (Either p b)
h | [Either p b]
e <- [[Either p b]]
es]
    -- using ->^ instead of -^ excludes dualities, since each edge is of the form [Left p, Right b]

    where es' :: Set [Either p b]
es' = [[Either p b]] -> Set [Either p b]
forall a. Ord a => [a] -> Set a
S.fromList [[Either p b]]
es

-- Calculate a map consisting of neighbour lists for each vertex in the graph

-- If a vertex has no neighbours then it is left out of the map

adjLists :: Graph a -> Map a [a]
adjLists (G vs :: [a]
vs es :: [[a]]
es) = Map a [a] -> [[a]] -> Map a [a]
forall a. Ord a => Map a [a] -> [[a]] -> Map a [a]
adjLists' Map a [a]
forall k a. Map k a
M.empty [[a]]
es
    where adjLists' :: Map a [a] -> [[a]] -> Map a [a]
adjLists' nbrs :: Map a [a]
nbrs ([u :: a
u,v :: a
v]:es :: [[a]]
es) =
              Map a [a] -> [[a]] -> Map a [a]
adjLists' (([a] -> [a] -> [a]) -> a -> [a] -> Map a [a] -> Map a [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]
(++)) a
v [a
u] (Map a [a] -> Map a [a]) -> Map a [a] -> Map a [a]
forall a b. (a -> b) -> a -> b
$ ([a] -> [a] -> [a]) -> a -> [a] -> Map a [a] -> Map a [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]
(++)) a
u [a
v] Map a [a]
nbrs) [[a]]
es
          adjLists' nbrs :: Map a [a]
nbrs [] = Map a [a]
nbrs


-- ALTERNATIVE VERSIONS OF GRAPH AUTS

-- (showing how we got to the final version)


data SearchTree a = T Bool a [SearchTree a] deriving (SearchTree a -> SearchTree a -> Bool
(SearchTree a -> SearchTree a -> Bool)
-> (SearchTree a -> SearchTree a -> Bool) -> Eq (SearchTree a)
forall a. Eq a => SearchTree a -> SearchTree a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SearchTree a -> SearchTree a -> Bool
$c/= :: forall a. Eq a => SearchTree a -> SearchTree a -> Bool
== :: SearchTree a -> SearchTree a -> Bool
$c== :: forall a. Eq a => SearchTree a -> SearchTree a -> Bool
Eq, Eq (SearchTree a)
Eq (SearchTree a) =>
(SearchTree a -> SearchTree a -> Ordering)
-> (SearchTree a -> SearchTree a -> Bool)
-> (SearchTree a -> SearchTree a -> Bool)
-> (SearchTree a -> SearchTree a -> Bool)
-> (SearchTree a -> SearchTree a -> Bool)
-> (SearchTree a -> SearchTree a -> SearchTree a)
-> (SearchTree a -> SearchTree a -> SearchTree a)
-> Ord (SearchTree a)
SearchTree a -> SearchTree a -> Bool
SearchTree a -> SearchTree a -> Ordering
SearchTree a -> SearchTree a -> SearchTree a
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 a. Ord a => Eq (SearchTree a)
forall a. Ord a => SearchTree a -> SearchTree a -> Bool
forall a. Ord a => SearchTree a -> SearchTree a -> Ordering
forall a. Ord a => SearchTree a -> SearchTree a -> SearchTree a
min :: SearchTree a -> SearchTree a -> SearchTree a
$cmin :: forall a. Ord a => SearchTree a -> SearchTree a -> SearchTree a
max :: SearchTree a -> SearchTree a -> SearchTree a
$cmax :: forall a. Ord a => SearchTree a -> SearchTree a -> SearchTree a
>= :: SearchTree a -> SearchTree a -> Bool
$c>= :: forall a. Ord a => SearchTree a -> SearchTree a -> Bool
> :: SearchTree a -> SearchTree a -> Bool
$c> :: forall a. Ord a => SearchTree a -> SearchTree a -> Bool
<= :: SearchTree a -> SearchTree a -> Bool
$c<= :: forall a. Ord a => SearchTree a -> SearchTree a -> Bool
< :: SearchTree a -> SearchTree a -> Bool
$c< :: forall a. Ord a => SearchTree a -> SearchTree a -> Bool
compare :: SearchTree a -> SearchTree a -> Ordering
$ccompare :: forall a. Ord a => SearchTree a -> SearchTree a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (SearchTree a)
Ord, Int -> SearchTree a -> ShowS
[SearchTree a] -> ShowS
SearchTree a -> [Char]
(Int -> SearchTree a -> ShowS)
-> (SearchTree a -> [Char])
-> ([SearchTree a] -> ShowS)
-> Show (SearchTree a)
forall a. Show a => Int -> SearchTree a -> ShowS
forall a. Show a => [SearchTree a] -> ShowS
forall a. Show a => SearchTree a -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [SearchTree a] -> ShowS
$cshowList :: forall a. Show a => [SearchTree a] -> ShowS
show :: SearchTree a -> [Char]
$cshow :: forall a. Show a => SearchTree a -> [Char]
showsPrec :: Int -> SearchTree a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> SearchTree a -> ShowS
Show, a -> SearchTree b -> SearchTree a
(a -> b) -> SearchTree a -> SearchTree b
(forall a b. (a -> b) -> SearchTree a -> SearchTree b)
-> (forall a b. a -> SearchTree b -> SearchTree a)
-> Functor SearchTree
forall a b. a -> SearchTree b -> SearchTree a
forall a b. (a -> b) -> SearchTree a -> SearchTree b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> SearchTree b -> SearchTree a
$c<$ :: forall a b. a -> SearchTree b -> SearchTree a
fmap :: (a -> b) -> SearchTree a -> SearchTree b
$cfmap :: forall a b. (a -> b) -> SearchTree a -> SearchTree b
Functor)
-- The boolean indicates whether or not this is a terminal / solution node


leftDepth :: SearchTree a -> p
leftDepth (T _ _ []) = 1
leftDepth (T _ _ (t :: SearchTree a
t:ts :: [SearchTree a]
ts)) = 1 p -> p -> p
forall a. Num a => a -> a -> a
+ SearchTree a -> p
leftDepth SearchTree a
t

leftWidths :: SearchTree a -> [Int]
leftWidths (T _ _ []) = []
leftWidths (T _ _ ts :: [SearchTree a]
ts@(t :: SearchTree a
t:_)) = [SearchTree a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SearchTree a]
ts Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: SearchTree a -> [Int]
leftWidths SearchTree a
t

graphAutsEdgeSearchTree :: Graph a -> SearchTree [(a, a)]
graphAutsEdgeSearchTree (G vs :: [a]
vs es :: [[a]]
es) = [(a, a)] -> [a] -> [a] -> SearchTree [(a, a)]
dfs [] [a]
vs [a]
vs where
    dfs :: [(a, a)] -> [a] -> [a] -> SearchTree [(a, a)]
dfs xys :: [(a, a)]
xys (x :: a
x:xs :: [a]
xs) yys :: [a]
yys = Bool -> [(a, a)] -> [SearchTree [(a, a)]] -> SearchTree [(a, a)]
forall a. Bool -> a -> [SearchTree a] -> SearchTree a
T Bool
False [(a, a)]
xys [[(a, a)] -> [a] -> [a] -> SearchTree [(a, a)]
dfs ((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]
yys, [(a, a)] -> (a, a) -> Bool
isCompatible [(a, a)]
xys (a
x,a
y)]
    dfs xys :: [(a, a)]
xys [] [] = Bool -> [(a, a)] -> [SearchTree [(a, a)]] -> SearchTree [(a, a)]
forall a. Bool -> a -> [SearchTree a] -> SearchTree a
T Bool
True [(a, a)]
xys []
    isCompatible :: [(a, a)] -> (a, a) -> Bool
isCompatible xys :: [(a, a)]
xys (x' :: a
x',y' :: a
y') = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [([a
x,a
x'] [a] -> Set [a] -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set [a]
es') Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== ([a] -> [a]
forall a. Ord a => [a] -> [a]
L.sort [a
y,a
y'] [a] -> Set [a] -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set [a]
es') | (x :: a
x,y :: a
y) <- [(a, a)]
xys]
    es' :: Set [a]
es' = [[a]] -> Set [a]
forall a. Ord a => [a] -> Set a
S.fromList [[a]]
es

graphAuts1 :: Graph a -> [Permutation a]
graphAuts1 = ([(a, a)] -> Permutation a) -> [[(a, a)]] -> [Permutation a]
forall a b. (a -> b) -> [a] -> [b]
map [(a, a)] -> Permutation a
forall a. Ord a => [(a, a)] -> Permutation a
fromPairs ([[(a, a)]] -> [Permutation a])
-> (Graph a -> [[(a, a)]]) -> Graph a -> [Permutation a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SearchTree [(a, a)] -> [[(a, a)]]
forall b. SearchTree b -> [b]
terminals (SearchTree [(a, a)] -> [[(a, a)]])
-> (Graph a -> SearchTree [(a, a)]) -> Graph a -> [[(a, a)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph a -> SearchTree [(a, a)]
forall a. Ord a => Graph a -> SearchTree [(a, a)]
graphAutsEdgeSearchTree

terminals :: SearchTree b -> [b]
terminals (T False _ ts :: [SearchTree b]
ts) = (SearchTree b -> [b]) -> [SearchTree b] -> [b]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap SearchTree b -> [b]
terminals [SearchTree b]
ts
terminals (T True xys :: b
xys _) = [b
xys]

-- Using Lemma 9.1.1 from Seress p203 to prune the search tree

-- Because auts form a group, it is sufficient to expand only each leftmost branch of the tree in full.

-- For every other branch, it is sufficient to find a single representative, since the other elements

-- can then be obtained by multiplication in the group (using the leftmost elements).

-- In effect, we are finding a transversal generating set.

-- Note however, that this transversal generating set is relative to whatever base order the tree uses,

-- so for clarity, the tree should use natural vertex order.

transversalTerminals :: SearchTree a -> [a]
transversalTerminals (T False _ (t :: SearchTree a
t:ts :: [SearchTree a]
ts)) = (SearchTree a -> [a]) -> [SearchTree a] -> [a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take 1 ([a] -> [a]) -> (SearchTree a -> [a]) -> SearchTree a -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SearchTree a -> [a]
transversalTerminals) [SearchTree a]
ts [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ SearchTree a -> [a]
transversalTerminals SearchTree a
t
-- transversalTerminals (T False _ (t:ts)) = transversalTerminals t ++ concatMap (take 1 . transversalTerminals) ts

transversalTerminals (T True xys :: a
xys _) = [a
xys]
transversalTerminals _ = []

graphAuts2 :: Graph a -> [Permutation a]
graphAuts2 = (Permutation a -> Bool) -> [Permutation a] -> [Permutation a]
forall a. (a -> Bool) -> [a] -> [a]
filter (Permutation a -> Permutation a -> Bool
forall a. Eq a => a -> a -> Bool
/=1) ([Permutation a] -> [Permutation a])
-> (Graph a -> [Permutation a]) -> Graph a -> [Permutation a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(a, a)] -> Permutation a) -> [[(a, a)]] -> [Permutation a]
forall a b. (a -> b) -> [a] -> [b]
map [(a, a)] -> Permutation a
forall a. Ord a => [(a, a)] -> Permutation a
fromPairs ([[(a, a)]] -> [Permutation a])
-> (Graph a -> [[(a, a)]]) -> Graph a -> [Permutation a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SearchTree [(a, a)] -> [[(a, a)]]
forall b. SearchTree b -> [b]
transversalTerminals (SearchTree [(a, a)] -> [[(a, a)]])
-> (Graph a -> SearchTree [(a, a)]) -> Graph a -> [[(a, a)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph a -> SearchTree [(a, a)]
forall a. Ord a => Graph a -> SearchTree [(a, a)]
graphAutsEdgeSearchTree
-- init because last is identity


isSingleton :: [a] -> Bool
isSingleton [_] = Bool
True
isSingleton _ = Bool
False

intersectCells :: [[a]] -> [[a]] -> [[a]]
intersectCells p1 :: [[a]]
p1 p2 :: [[a]]
p2 = [[[a]]] -> [[a]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [[a]
c1 [a] -> [a] -> [a]
forall a. Ord a => [a] -> [a] -> [a]
`intersectAsc` [a]
c2 | [a]
c2 <- [[a]]
p2] | [a]
c1 <- [[a]]
p1]
-- Intersection preserves ordering within cells but not between cells

-- eg the cell [1,2,3,4] could be refined to [2,4],[1,3]



graphAutsDistancePartitionSearchTree :: Graph a -> SearchTree [(a, a)]
graphAutsDistancePartitionSearchTree g :: Graph a
g@(G vs :: [a]
vs es :: [[a]]
es) = [(a, a)] -> ([[a]], [[a]]) -> SearchTree [(a, a)]
dfs [] ([[a]
vs],[[a]
vs]) where
    dfs :: [(a, a)] -> ([[a]], [[a]]) -> SearchTree [(a, a)]
dfs xys :: [(a, a)]
xys (srcPart :: [[a]]
srcPart,trgPart :: [[a]]
trgPart)
        | ([a] -> Bool) -> [[a]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all [a] -> Bool
forall a. [a] -> Bool
isSingleton [[a]]
srcPart =
             let xys' :: [(a, a)]
xys' = [a] -> [a] -> [(a, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[a]]
srcPart) ([[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[a]]
trgPart)
             in Bool -> [(a, a)] -> [SearchTree [(a, a)]] -> SearchTree [(a, a)]
forall a. Bool -> a -> [SearchTree a] -> SearchTree a
T ([(a, a)] -> Bool
isCompatible [(a, a)]
xys') ([(a, a)]
xys[(a, a)] -> [(a, a)] -> [(a, a)]
forall a. [a] -> [a] -> [a]
++[(a, a)]
xys') []
             -- Since the xys' are distance-compatible with the xys, they are certainly edge-compatible.

             -- However, we do need to check that the xys' are edge-compatible with each other.

        | Bool
otherwise = let (x :: a
x:xs :: [a]
xs):srcCells :: [[a]]
srcCells = [[a]]
srcPart
                          yys :: [a]
yys   :trgCells :: [[a]]
trgCells = [[a]]
trgPart
                          srcPart' :: [[a]]
srcPart' = [[a]] -> [[a]] -> [[a]]
forall a. Ord a => [[a]] -> [[a]] -> [[a]]
intersectCells ([a]
xs [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [[a]]
srcCells) (Map a [[a]]
dps Map a [[a]] -> a -> [[a]]
forall k a. Ord k => Map k a -> k -> a
M.! a
x)
                      in Bool -> [(a, a)] -> [SearchTree [(a, a)]] -> SearchTree [(a, a)]
forall a. Bool -> a -> [SearchTree a] -> SearchTree a
T Bool
False [(a, a)]
xys -- the L.sort in the following line is so that we traverse vertices in natural order

                         [[(a, a)] -> ([[a]], [[a]]) -> SearchTree [(a, a)]
dfs ((a
x,a
y)(a, a) -> [(a, a)] -> [(a, a)]
forall a. a -> [a] -> [a]
:[(a, a)]
xys) (([([a], [a])] -> ([[a]], [[a]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([([a], [a])] -> ([[a]], [[a]]))
-> ([([a], [a])] -> [([a], [a])]) -> [([a], [a])] -> ([[a]], [[a]])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [([a], [a])] -> [([a], [a])]
forall a. Ord a => [a] -> [a]
L.sort) ([[a]] -> [[a]] -> [([a], [a])]
forall a b. [a] -> [b] -> [(a, b)]
zip (([a] -> Bool) -> [[a]] -> [[a]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ([a] -> Bool) -> [a] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [[a]]
srcPart') (([a] -> Bool) -> [[a]] -> [[a]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ([a] -> Bool) -> [a] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [[a]]
trgPart')))
                         | (y :: a
y,ys :: [a]
ys) <- [a] -> [(a, [a])]
forall a. [a] -> [(a, [a])]
picks [a]
yys,
                           let trgPart' :: [[a]]
trgPart' = [[a]] -> [[a]] -> [[a]]
forall a. Ord a => [[a]] -> [[a]] -> [[a]]
intersectCells ([a]
ys [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [[a]]
trgCells) (Map a [[a]]
dps Map a [[a]] -> a -> [[a]]
forall k a. Ord k => Map k a -> k -> a
M.! a
y),
                           ([a] -> Int) -> [[a]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[a]]
srcPart' [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]]
trgPart']
    isCompatible :: [(a, a)] -> Bool
isCompatible xys :: [(a, a)]
xys = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [([a
x,a
x'] [a] -> Set [a] -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set [a]
es') Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== ([a] -> [a]
forall a. Ord a => [a] -> [a]
L.sort [a
y,a
y'] [a] -> Set [a] -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set [a]
es') | (x :: a
x,y :: a
y) <- [(a, a)]
xys, (x' :: a
x',y' :: a
y') <- [(a, a)]
xys, a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
x']
    es' :: Set [a]
es' = [[a]] -> Set [a]
forall a. Ord a => [a] -> Set a
S.fromList [[a]]
es
    dps :: Map a [[a]]
dps = [(a, [[a]])] -> Map a [[a]]
forall k a. Eq k => [(k, a)] -> Map k a
M.fromAscList [(a
v, [a] -> Set [a] -> a -> [[a]]
forall a. Ord a => [a] -> Set [a] -> a -> [[a]]
distancePartitionS [a]
vs Set [a]
es' a
v) | a
v <- [a]
vs]

graphAuts3 :: Graph a -> [Permutation a]
graphAuts3 = (Permutation a -> Bool) -> [Permutation a] -> [Permutation a]
forall a. (a -> Bool) -> [a] -> [a]
filter (Permutation a -> Permutation a -> Bool
forall a. Eq a => a -> a -> Bool
/=1) ([Permutation a] -> [Permutation a])
-> (Graph a -> [Permutation a]) -> Graph a -> [Permutation a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(a, a)] -> Permutation a) -> [[(a, a)]] -> [Permutation a]
forall a b. (a -> b) -> [a] -> [b]
map [(a, a)] -> Permutation a
forall a. Ord a => [(a, a)] -> Permutation a
fromPairs ([[(a, a)]] -> [Permutation a])
-> (Graph a -> [[(a, a)]]) -> Graph a -> [Permutation a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SearchTree [(a, a)] -> [[(a, a)]]
forall b. SearchTree b -> [b]
transversalTerminals (SearchTree [(a, a)] -> [[(a, a)]])
-> (Graph a -> SearchTree [(a, a)]) -> Graph a -> [[(a, a)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph a -> SearchTree [(a, a)]
forall a. Ord a => Graph a -> SearchTree [(a, a)]
graphAutsDistancePartitionSearchTree

-- Whereas transversalTerminals produced a transversal generating set, here we produce a strong generating set.

-- In particular, if we have already found (3 4), and then we find (1 2 3),

-- then there is no need to look for (1 3 ...) or (1 4 ...), since it is clear that such elements exist

-- as products of those we have already found.

strongTerminals :: SearchTree [(a, a)] -> [Permutation a]
strongTerminals = [Permutation a] -> SearchTree [(a, a)] -> [Permutation a]
forall a.
Ord a =>
[Permutation a] -> SearchTree [(a, a)] -> [Permutation a]
strongTerminals' [] where
    strongTerminals' :: [Permutation a] -> SearchTree [(a, a)] -> [Permutation a]
strongTerminals' gs :: [Permutation a]
gs (T False xys :: [(a, a)]
xys ts :: [SearchTree [(a, a)]]
ts) =
        case [(a, a)] -> Maybe (a, a)
forall a. [a] -> Maybe a
listToMaybe ([(a, a)] -> Maybe (a, a)) -> [(a, a)] -> Maybe (a, a)
forall a b. (a -> b) -> a -> b
$ [(a, a)] -> [(a, a)]
forall a. [a] -> [a]
reverse ([(a, a)] -> [(a, a)]) -> [(a, a)] -> [(a, a)]
forall a b. (a -> b) -> a -> b
$ ((a, a) -> Bool) -> [(a, a)] -> [(a, a)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(x :: a
x,y :: a
y) -> a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
y) [(a, a)]
xys of -- the first vertex that isn't fixed

        Nothing -> ([Permutation a] -> SearchTree [(a, a)] -> [Permutation a])
-> [Permutation a] -> [SearchTree [(a, a)]] -> [Permutation a]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl' (\hs :: [Permutation a]
hs t :: SearchTree [(a, a)]
t -> [Permutation a] -> SearchTree [(a, a)] -> [Permutation a]
strongTerminals' [Permutation a]
hs SearchTree [(a, a)]
t) [Permutation a]
gs [SearchTree [(a, a)]]
ts
        Just (x :: a
x,y :: a
y) -> if a
y a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (a
x a -> [Permutation a] -> [a]
forall a. Ord a => a -> [Permutation a] -> [a]
.^^ [Permutation a]
gs)
                      then [Permutation a]
gs
                      -- Since we're not on the leftmost spine, we can stop as soon as we find one new element

                      else [Permutation a] -> [SearchTree [(a, a)]] -> [Permutation a]
find1New [Permutation a]
gs [SearchTree [(a, a)]]
ts
                      -- else L.foldl' (\hs t -> if hs /= gs then hs else strongTerminals' hs t) gs ts

    strongTerminals' gs :: [Permutation a]
gs (T True xys :: [(a, a)]
xys []) = [(a, a)] -> Permutation a
forall a. Ord a => [(a, a)] -> Permutation a
fromPairs [(a, a)]
xys Permutation a -> [Permutation a] -> [Permutation a]
forall a. a -> [a] -> [a]
: [Permutation a]
gs
    find1New :: [Permutation a] -> [SearchTree [(a, a)]] -> [Permutation a]
find1New gs :: [Permutation a]
gs (t :: SearchTree [(a, a)]
t:ts :: [SearchTree [(a, a)]]
ts) = let hs :: [Permutation a]
hs = [Permutation a] -> SearchTree [(a, a)] -> [Permutation a]
strongTerminals' [Permutation a]
gs SearchTree [(a, a)]
t
                         in if Int -> [Permutation a] -> [Permutation a]
forall a. Int -> [a] -> [a]
take 1 [Permutation a]
gs [Permutation a] -> [Permutation a] -> Bool
forall a. Eq a => a -> a -> Bool
/= Int -> [Permutation a] -> [Permutation a]
forall a. Int -> [a] -> [a]
take 1 [Permutation a]
hs -- we know a new element would be placed at the front

                            then [Permutation a]
hs
                            else [Permutation a] -> [SearchTree [(a, a)]] -> [Permutation a]
find1New [Permutation a]
gs [SearchTree [(a, a)]]
ts
    find1New gs :: [Permutation a]
gs [] = [Permutation a]
gs

-- |Given a graph g, @graphAuts g@ returns a strong generating set for the automorphism group of g.

graphAuts :: (Ord a) => Graph a -> [Permutation a]
graphAuts :: Graph a -> [Permutation a]
graphAuts = (Permutation a -> Bool) -> [Permutation a] -> [Permutation a]
forall a. (a -> Bool) -> [a] -> [a]
filter (Permutation a -> Permutation a -> Bool
forall a. Eq a => a -> a -> Bool
/=1) ([Permutation a] -> [Permutation a])
-> (Graph a -> [Permutation a]) -> Graph a -> [Permutation a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SearchTree [(a, a)] -> [Permutation a]
forall a. Ord a => SearchTree [(a, a)] -> [Permutation a]
strongTerminals (SearchTree [(a, a)] -> [Permutation a])
-> (Graph a -> SearchTree [(a, a)]) -> Graph a -> [Permutation a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph a -> SearchTree [(a, a)]
forall a. Ord a => Graph a -> SearchTree [(a, a)]
graphAutsDistancePartitionSearchTree


-- Using colourings (M.Map vertex colour, M.Map colour [vertex]), in place of partitions ([[vertex]])

-- This turns out to be slower than using partitions.

-- Updating the colour partition incrementally seems to be much less efficient than just recalculating it each time

-- (Recalculating each time is O(n), incrementally updating is O(n^2)?)

graphAutsDistanceColouringSearchTree :: Graph a -> SearchTree [(a, a)]
graphAutsDistanceColouringSearchTree g :: Graph a
g@(G vs :: [a]
vs es :: [[a]]
es) = [(a, a)]
-> (Map a [Integer], Map [Integer] [a])
-> (Map a [Integer], Map [Integer] [a])
-> SearchTree [(a, a)]
forall a.
(Num a, Enum a, Ord a) =>
[(a, a)]
-> (Map a [a], Map [a] [a])
-> (Map a [a], Map [a] [a])
-> SearchTree [(a, a)]
dfs [] (Map a [Integer], Map [Integer] [a])
forall a a. (Map a [a], Map [a] [a])
unitCol (Map a [Integer], Map [Integer] [a])
forall a a. (Map a [a], Map [a] [a])
unitCol where
    unitCol :: (Map a [a], Map [a] [a])
unitCol = ([(a, [a])] -> Map a [a]
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(a, [a])] -> Map a [a]) -> [(a, [a])] -> Map a [a]
forall a b. (a -> b) -> a -> b
$ (a -> (a, [a])) -> [a] -> [(a, [a])]
forall a b. (a -> b) -> [a] -> [b]
map (,[]) [a]
vs, [a] -> [a] -> Map [a] [a]
forall k a. k -> a -> Map k a
M.singleton [] [a]
vs) -- "unit colouring"

    dfs :: [(a, a)]
-> (Map a [a], Map [a] [a])
-> (Map a [a], Map [a] [a])
-> SearchTree [(a, a)]
dfs xys :: [(a, a)]
xys srcColouring :: (Map a [a], Map [a] [a])
srcColouring@(srcVmap :: Map a [a]
srcVmap,srcCmap :: Map [a] [a]
srcCmap) trgColouring :: (Map a [a], Map [a] [a])
trgColouring@(trgVmap :: Map a [a]
trgVmap,trgCmap :: Map [a] [a]
trgCmap)
        -- ( | M.map length srcCmap /= M.map length trgCmap = T False xys [] )

        | ([a] -> Bool) -> [[a]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all [a] -> Bool
forall a. [a] -> Bool
isSingleton (Map [a] [a] -> [[a]]
forall k a. Map k a -> [a]
M.elems Map [a] [a]
srcCmap) = -- discrete colouring

             let xys' :: [(a, a)]
xys' = [a] -> [a] -> [(a, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[a]] -> [a]) -> [[a]] -> [a]
forall a b. (a -> b) -> a -> b
$ Map [a] [a] -> [[a]]
forall k a. Map k a -> [a]
M.elems Map [a] [a]
srcCmap) ([[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[a]] -> [a]) -> [[a]] -> [a]
forall a b. (a -> b) -> a -> b
$ Map [a] [a] -> [[a]]
forall k a. Map k a -> [a]
M.elems Map [a] [a]
trgCmap)
             in Bool -> [(a, a)] -> [SearchTree [(a, a)]] -> SearchTree [(a, a)]
forall a. Bool -> a -> [SearchTree a] -> SearchTree a
T ([(a, a)] -> Bool
isCompatible [(a, a)]
xys') ([(a, a)] -> [(a, a)]
forall a. [a] -> [a]
reverse [(a, a)]
xys'[(a, a)] -> [(a, a)] -> [(a, a)]
forall a. [a] -> [a] -> [a]
++[(a, a)]
xys) []
             -- Since the xys' are distance-compatible with the xys, they are certainly edge-compatible.

             -- However, we do need to check that the xys' are edge-compatible with each other.

        | Bool
otherwise = let (x :: a
x,c :: [a]
c) = Map a [a] -> (a, [a])
forall k a. Map k a -> (k, a)
M.findMin Map a [a]
srcVmap
                          (xVmap :: Map a [a]
xVmap,xCmap :: Map [a] [a]
xCmap) = Map a (Map a [a], Map [a] [a])
forall a a.
(Ord a, Num a, Num a, Enum a, Enum a) =>
Map a (Map a [a], Map [a] [a])
dcs Map a (Map a [a], Map [a] [a]) -> a -> (Map a [a], Map [a] [a])
forall k a. Ord k => Map k a -> k -> a
M.! a
x
                          ys :: [a]
ys = Map [a] [a]
trgCmap Map [a] [a] -> [a] -> [a]
forall k a. Ord k => Map k a -> k -> a
M.! [a]
c
                          srcVmap' :: Map a [a]
srcVmap' = a -> Map a [a] -> Map a [a]
forall k a. Ord k => k -> Map k a -> Map k a
M.delete a
x (Map a [a] -> Map a [a] -> Map a [a]
forall k a. Ord k => Map k [a] -> Map k [a] -> Map k [a]
intersectColouring Map a [a]
srcVmap Map a [a]
forall a. (Num a, Enum a) => Map a [a]
xVmap)
                          srcCmap' :: Map [a] [a]
srcCmap' = Map a [a] -> Map [a] [a]
forall k a. Ord k => Map a k -> Map k [a]
colourPartition Map a [a]
srcVmap'
                          -- srcCmap' = M.fromAscList [(c1++c2, cell) | (c1,srcCell) <- M.assocs srcCmap, (c2,xCell) <- M.assocs xCmap,

                          --                                            let cell = L.delete x (intersectAsc srcCell xCell),

                          --                                            (not . null) cell]

                      in Bool -> [(a, a)] -> [SearchTree [(a, a)]] -> SearchTree [(a, a)]
forall a. Bool -> a -> [SearchTree a] -> SearchTree a
T Bool
False [(a, a)]
xys
                         [[(a, a)]
-> (Map a [a], Map [a] [a])
-> (Map a [a], Map [a] [a])
-> SearchTree [(a, a)]
dfs ((a
x,a
y)(a, a) -> [(a, a)] -> [(a, a)]
forall a. a -> [a] -> [a]
:[(a, a)]
xys) (Map a [a]
srcVmap',Map [a] [a]
srcCmap') (Map a [a]
trgVmap',Map [a] [a]
trgCmap')
                         | a
y <- [a]
ys,
                           let (yVmap :: Map a [a]
yVmap,yCmap :: Map [a] [a]
yCmap) = Map a (Map a [a], Map [a] [a])
forall a a.
(Ord a, Num a, Num a, Enum a, Enum a) =>
Map a (Map a [a], Map [a] [a])
dcs Map a (Map a [a], Map [a] [a]) -> a -> (Map a [a], Map [a] [a])
forall k a. Ord k => Map k a -> k -> a
M.! a
y,
                           let trgVmap' :: Map a [a]
trgVmap' = a -> Map a [a] -> Map a [a]
forall k a. Ord k => k -> Map k a -> Map k a
M.delete a
y (Map a [a] -> Map a [a] -> Map a [a]
forall k a. Ord k => Map k [a] -> Map k [a] -> Map k [a]
intersectColouring Map a [a]
trgVmap Map a [a]
forall a. (Num a, Enum a) => Map a [a]
yVmap),
                           let trgCmap' :: Map [a] [a]
trgCmap' = Map a [a] -> Map [a] [a]
forall k a. Ord k => Map a k -> Map k [a]
colourPartition Map a [a]
trgVmap',
                           -- let trgCmap' = M.fromAscList [(c1++c2, cell) | (c1,trgCell) <- M.assocs trgCmap, (c2,yCell) <- M.assocs yCmap,

                           --                                                let cell = L.delete y (intersectAsc trgCell yCell),

                           --                                                (not . null) cell],

                           ([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]
srcCmap' Map [a] Int -> Map [a] Int -> Bool
forall a. Eq a => a -> a -> Bool
== ([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]
trgCmap' ]
    isCompatible :: [(a, a)] -> Bool
isCompatible xys :: [(a, a)]
xys = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [([a
x,a
x'] [a] -> Set [a] -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set [a]
es') Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== ([a] -> [a]
forall a. Ord a => [a] -> [a]
L.sort [a
y,a
y'] [a] -> Set [a] -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set [a]
es') | (x :: a
x,y :: a
y) <- [(a, a)]
xys, (x' :: a
x',y' :: a
y') <- [(a, a)]
xys, a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
x']
    es' :: Set [a]
es' = [[a]] -> Set [a]
forall a. Ord a => [a] -> Set a
S.fromList [[a]]
es
    dcs :: Map a (Map a [a], Map [a] [a])
dcs = [(a, (Map a [a], Map [a] [a]))] -> Map a (Map a [a], Map [a] [a])
forall k a. Eq k => [(k, a)] -> Map k a
M.fromAscList [(a
v, a -> (Map a [a], Map [a] [a])
forall a a.
(Ord a, Num a, Num a, Enum a, Enum a) =>
a -> (Map a [a], Map [a] [a])
distanceColouring a
v) | a
v <- [a]
vs]
    distanceColouring :: a -> (Map a [a], Map [a] [a])
distanceColouring u :: a
u = let dp :: [[a]]
dp = [a] -> Set [a] -> a -> [[a]]
forall a. Ord a => [a] -> Set [a] -> a -> [[a]]
distancePartitionS [a]
vs Set [a]
es' a
u
                              vmap :: Map a [a]
vmap = [(a, [a])] -> Map a [a]
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(a
v,[a
c]) | (cell :: [a]
cell,c :: a
c) <- [[a]] -> [a] -> [([a], a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [[a]]
dp [0..], a
v <- [a]
cell]
                              cmap :: Map [a] [a]
cmap = [([a], [a])] -> Map [a] [a]
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([([a], [a])] -> Map [a] [a]) -> [([a], [a])] -> Map [a] [a]
forall a b. (a -> b) -> a -> b
$ [[a]] -> [[a]] -> [([a], [a])]
forall a b. [a] -> [b] -> [(a, b)]
zip ((a -> [a]) -> [a] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map (a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[]) [0..]) [[a]]
dp
                          in (Map a [a]
forall a. (Num a, Enum a) => Map a [a]
vmap, Map [a] [a]
forall a. (Ord a, Num a, Enum a) => Map [a] [a]
cmap)

{-
-- If we are going to recalculate the colour partition each time anyway,
-- then we don't need to carry it around, and can simplify the code
graphAutsDistanceColouringSearchTree g@(G vs es) = dfs [] initCol initCol where
    initCol = M.fromList $ map (,[]) vs
    dfs xys srcCol trgCol
        | M.map length srcPart /= M.map length trgPart = T False xys []
        | all isSingleton (M.elems srcPart) =
             let xys' = zip (concat $ M.elems srcPart) (concat $ M.elems trgPart)
             in T (isCompatible xys') (reverse xys'++xys) []
             -- Since the xys' are distance-compatible with the xys, they are certainly edge-compatible.
             -- However, we do need to check that the xys' are edge-compatible with each other.
        | otherwise = let (x,c) = M.findMin srcCol
                          ys = trgPart M.! c
                          srcCol' = M.delete x $ intersectColouring srcCol (dcs M.! x)
                      in T False xys
                         [dfs ((x,y):xys) srcCol' trgCol'
                         | y <- ys,
                           let trgCol' = M.delete y (intersectColouring trgCol (dcs M.! y))]
        where srcPart = colourPartition srcCol
              trgPart = colourPartition trgCol
    isCompatible xys = and [([x,x'] `S.member` es') == (L.sort [y,y'] `S.member` es') | (x,y) <- xys, (x',y') <- xys, x < x']
    es' = S.fromList es
    dcs = M.fromAscList [(v, distanceColouring v) | v <- vs]
    distanceColouring u = M.fromList [(v,[c]) | (cell,c) <- zip (distancePartitionS vs es' u) [0..], v <- cell]
-}
distanceColouring :: Graph k -> k -> Map k [a]
distanceColouring (G vs :: [k]
vs es :: [[k]]
es) u :: k
u = [(k, [a])] -> Map k [a]
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(k
v,[a
c]) | (cell :: [k]
cell,c :: a
c) <- [[k]] -> [a] -> [([k], a)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([k] -> Set [k] -> k -> [[k]]
forall a. Ord a => [a] -> Set [a] -> a -> [[a]]
distancePartitionS [k]
vs Set [k]
es' k
u) [0..], k
v <- [k]
cell]
    where es' :: Set [k]
es' = [[k]] -> Set [k]
forall a. Ord a => [a] -> Set a
S.fromList [[k]]
es

intersectColouring :: Map k [a] -> Map k [a] -> Map k [a]
intersectColouring c1 :: Map k [a]
c1 c2 :: Map k [a]
c2 = ([a] -> [a] -> [a]) -> Map k [a] -> Map k [a] -> Map k [a]
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
M.intersectionWith [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++) Map k [a]
c1 Map k [a]
c2

colourPartition :: Map a k -> Map k [a]
colourPartition c :: Map a k
c = ((a, k) -> Map k [a] -> Map k [a])
-> Map k [a] -> [(a, k)] -> Map k [a]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
L.foldr (\(k :: a
k,v :: k
v) m :: Map k [a]
m -> ([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]
forall a. [a] -> [a] -> [a]
(++) k
v [a
k] Map k [a]
m) Map k [a]
forall k a. Map k a
M.empty (Map a k -> [(a, k)]
forall k a. Map k a -> [(k, a)]
M.assocs Map a k
c)



-- Based on McKay’s Canonical Graph Labeling Algorithm, by Stephen G. Hartke and A. J. Radcliffe

-- (http://www.math.unl.edu/~aradcliffe1/Papers/Canonical.pdf)


equitableRefinement :: Graph a -> [[a]] -> [[a]]
equitableRefinement g :: Graph a
g@(G vs :: [a]
vs es :: [[a]]
es) p :: [[a]]
p = Set [a] -> [[a]] -> [[a]]
forall a. Ord a => Set [a] -> [[a]] -> [[a]]
equitableRefinement' ([[a]] -> Set [a]
forall a. Ord a => [a] -> Set a
S.fromList [[a]]
es) [[a]]
p

equitableRefinement' :: Set [a] -> [[a]] -> [[a]]
equitableRefinement' edgeset :: Set [a]
edgeset partition :: [[a]]
partition = [[a]] -> [[a]]
go [[a]]
partition where
    go :: [[a]] -> [[a]]
go cells :: [[a]]
cells = let splits :: [([[a]], [[a]])]
splits = [[[a]]] -> [[[a]]] -> [([[a]], [[a]])]
forall a b. [a] -> [b] -> [(a, b)]
L.zip ([[a]] -> [[[a]]]
forall a. [a] -> [[a]]
L.inits [[a]]
cells) ([[a]] -> [[[a]]]
forall a. [a] -> [[a]]
L.tails [[a]]
cells)
                   shatterPairs :: [([(a, Int)], [[a]], [[a]])]
shatterPairs = [([a] -> [Int] -> [(a, Int)]
forall a b. [a] -> [b] -> [(a, b)]
L.zip [a]
ci [Int]
counts,[[a]]
ls,[[a]]
rs) | (ls :: [[a]]
ls,ci :: [a]
ci:rs :: [[a]]
rs) <- [([[a]], [[a]])]
splits, [a]
cj <- [[a]]
cells,
                                                             let counts :: [Int]
counts = (a -> Int) -> [a] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ([a] -> a -> Int
nbrCount [a]
cj) [a]
ci, [Int] -> Bool
forall a. Eq a => [a] -> Bool
isShatter [Int]
counts]
               in case [([(a, Int)], [[a]], [[a]])]
shatterPairs of -- by construction, the lexicographic least (i,j) comes first

                  [] -> [[a]]
cells
                  (vcs :: [(a, Int)]
vcs,ls :: [[a]]
ls,rs :: [[a]]
rs):_ -> let fragments :: [[a]]
fragments = [(a, Int)] -> [[a]]
forall b b. Ord b => [(b, b)] -> [[b]]
shatter [(a, Int)]
vcs 
                                   in [[a]] -> [[a]]
go ([[a]]
ls [[a]] -> [[a]] -> [[a]]
forall a. [a] -> [a] -> [a]
++ [[a]]
fragments [[a]] -> [[a]] -> [[a]]
forall a. [a] -> [a] -> [a]
++ [[a]]
rs)
    isShatter :: [a] -> Bool
isShatter (c :: a
c:cs :: [a]
cs) = (a -> Bool) -> [a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
c) [a]
cs
    shatter :: [(b, b)] -> [[b]]
shatter vcs :: [(b, b)]
vcs = ([(b, b)] -> [b]) -> [[(b, b)]] -> [[b]]
forall a b. (a -> b) -> [a] -> [b]
map (((b, b) -> b) -> [(b, b)] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (b, b) -> b
forall a b. (a, b) -> a
fst) ([[(b, b)]] -> [[b]]) -> [[(b, b)]] -> [[b]]
forall a b. (a -> b) -> a -> b
$ ((b, b) -> (b, b) -> Bool) -> [(b, b)] -> [[(b, b)]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
L.groupBy (\x :: (b, b)
x y :: (b, b)
y -> (b, b) -> b
forall a b. (a, b) -> b
snd (b, b)
x b -> b -> Bool
forall a. Eq a => a -> a -> Bool
== (b, b) -> b
forall a b. (a, b) -> b
snd (b, b)
y) ([(b, b)] -> [[(b, b)]]) -> [(b, b)] -> [[(b, b)]]
forall a b. (a -> b) -> a -> b
$ ((b, b) -> (b, b) -> Ordering) -> [(b, b)] -> [(b, b)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
L.sortBy (((b, b) -> b) -> (b, b) -> (b, b) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (b, b) -> b
forall a b. (a, b) -> b
snd) ([(b, b)] -> [(b, b)]) -> [(b, b)] -> [(b, b)]
forall a b. (a -> b) -> a -> b
$ [(b, b)]
vcs
    -- Memoizing here results in about 10% speed improvement. Not worth it for loss of generality (ie requiring HasTrie instances)

    -- nbrCount = memo2 nbrCount'

    -- How many neighbours in cell does vertex have

    nbrCount :: [a] -> a -> Int
nbrCount cell :: [a]
cell vertex :: a
vertex = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter (a -> a -> Bool
isEdge a
vertex) [a]
cell)
    isEdge :: a -> a -> Bool
isEdge u :: a
u v :: a
v = [a] -> [a]
forall a. Ord a => [a] -> [a]
L.sort [a
u,a
v] [a] -> Set [a] -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set [a]
edgeset

equitablePartitionSearchTree :: Graph a -> [[a]] -> SearchTree ([[a]], [a])
equitablePartitionSearchTree g :: Graph a
g@(G vs :: [a]
vs es :: [[a]]
es) p :: [[a]]
p = [a] -> [[a]] -> SearchTree ([[a]], [a])
dfs [] [[a]]
p where
    dfs :: [a] -> [[a]] -> SearchTree ([[a]], [a])
dfs bs :: [a]
bs p :: [[a]]
p = let p' :: [[a]]
p' = Set [a] -> [[a]] -> [[a]]
forall a. Ord a => Set [a] -> [[a]] -> [[a]]
equitableRefinement' Set [a]
es' [[a]]
p in
               if ([a] -> Bool) -> [[a]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all [a] -> Bool
forall a. [a] -> Bool
isSingleton [[a]]
p'
               then Bool
-> ([[a]], [a])
-> [SearchTree ([[a]], [a])]
-> SearchTree ([[a]], [a])
forall a. Bool -> a -> [SearchTree a] -> SearchTree a
T Bool
True ([[a]]
p',[a]
bs) []
               else Bool
-> ([[a]], [a])
-> [SearchTree ([[a]], [a])]
-> SearchTree ([[a]], [a])
forall a. Bool -> a -> [SearchTree a] -> SearchTree a
T Bool
False ([[a]]
p',[a]
bs) [[a] -> [[a]] -> SearchTree ([[a]], [a])
dfs (a
ba -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
bs) [[a]]
p'' | (b :: a
b,p'' :: [[a]]
p'') <- [[a]] -> [[a]] -> [(a, [[a]])]
forall a. [[a]] -> [[a]] -> [(a, [[a]])]
splits [] [[a]]
p']
    -- For now, we just split the first non-singleton cell we find

    splits :: [[a]] -> [[a]] -> [(a, [[a]])]
splits ls :: [[a]]
ls (r :: [a]
r:rs :: [[a]]
rs) | [a] -> Bool
forall a. [a] -> Bool
isSingleton [a]
r = [[a]] -> [[a]] -> [(a, [[a]])]
splits ([a]
r[a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
:[[a]]
ls) [[a]]
rs
                     | Bool
otherwise = let ls' :: [[a]]
ls' = [[a]] -> [[a]]
forall a. [a] -> [a]
reverse [[a]]
ls in [(a
x, [[a]]
ls' [[a]] -> [[a]] -> [[a]]
forall a. [a] -> [a] -> [a]
++ [a
x][a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
:[a]
xs[a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
:[[a]]
rs) | (x :: a
x,xs :: [a]
xs) <- [a] -> [(a, [a])]
forall a. [a] -> [(a, [a])]
picks [a]
r]
    es' :: Set [a]
es' = [[a]] -> Set [a]
forall a. Ord a => [a] -> Set a
S.fromList [[a]]
es


{-
-- Using Data.Sequence instead of list for the partitions
-- Makes no difference to speed (in fact slightly slower)
equitableRefinementSeq' edgeset partition = go partition where
    go cells = let splits = Seq.zip (Seq.inits cells) (Seq.tails cells)
                   shatterPairs = [(L.zip ci counts,ls,rs') | (ls,rs) <- Foldable.toList splits, (not . Seq.null) rs, let ci Seq.:< rs' = Seq.viewl rs,
                                                              cj <- Foldable.toList cells,
                                                              let counts = map (nbrCount cj) ci, isShatter counts]
               in case shatterPairs of -- by construction, the lexicographic least (i,j) comes first
                  [] -> cells
                  (vcs,ls,rs):_ -> let fragments = Seq.fromList (shatter vcs) 
                                   in go (ls Seq.>< fragments Seq.>< rs)
    isShatter (c:cs) = any (/= c) cs
    shatter vcs = map (map fst) $ L.groupBy (\x y -> snd x == snd y) $ L.sortBy (comparing snd) $ vcs
    -- How many neighbours in cell does vertex have
    nbrCount cell vertex = length (filter (isEdge vertex) cell)
    isEdge u v = L.sort [u,v] `S.member` edgeset

equitablePartitionSeqSearchTree g@(G vs es) p = dfs [] (Seq.fromList p) where
    dfs bs p = let p' = equitableRefinementSeq' es' p in
               if Foldable.all isSingleton p'
               then T True (Foldable.toList p',bs) []
               else T False (Foldable.toList p',bs) [dfs (b:bs) p'' | (b,p'') <- splits p']
    -- For now, we just split the first non-singleton cell we find
    splits cells = case Seq.findIndexL (not . isSingleton) cells of
                   Just i -> let (ls,rs) = Seq.splitAt i cells
                                 r Seq.:< rs' = Seq.viewl rs
                             in [(x, ls Seq.>< ([x] Seq.<| xs Seq.<| rs')) | (x,xs) <- picks r]
                   Nothing -> error "Not possible, as we know there are non-singleton cells"
    es' = S.fromList es
-}

-- In this version, whenever we have an equitable partition, we separate out all the singleton cells and put them to one side.

-- (Since the partition is equitable, singleton cells have already done any work they are going to do in shattering other cells,

-- so they will no longer play any part.)

-- This seems to result in about 20% speedup.

equitablePartitionSearchTree2 :: Graph a -> [[a]] -> SearchTree ([[a]], [a])
equitablePartitionSearchTree2 g :: Graph a
g@(G vs :: [a]
vs es :: [[a]]
es) p :: [[a]]
p = [a] -> ([[a]], [[a]]) -> SearchTree ([[a]], [a])
dfs [] ([],[[a]]
p) where
    dfs :: [a] -> ([[a]], [[a]]) -> SearchTree ([[a]], [a])
dfs bs :: [a]
bs (ss :: [[a]]
ss,cs :: [[a]]
cs) = let (ss' :: [[a]]
ss',cs' :: [[a]]
cs') = ([a] -> Bool) -> [[a]] -> ([[a]], [[a]])
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition [a] -> Bool
forall a. [a] -> Bool
isSingleton ([[a]] -> ([[a]], [[a]])) -> [[a]] -> ([[a]], [[a]])
forall a b. (a -> b) -> a -> b
$ Set [a] -> [[a]] -> [[a]]
forall a. Ord a => Set [a] -> [[a]] -> [[a]]
equitableRefinement' Set [a]
es' [[a]]
cs
                         ss'' :: [[a]]
ss'' = [[a]]
ss[[a]] -> [[a]] -> [[a]]
forall a. [a] -> [a] -> [a]
++[[a]]
ss'
                     in case [[a]]
cs' of
                        [] -> Bool
-> ([[a]], [a])
-> [SearchTree ([[a]], [a])]
-> SearchTree ([[a]], [a])
forall a. Bool -> a -> [SearchTree a] -> SearchTree a
T Bool
True ([[a]]
ss'',[a]
bs) []
                        -- We just split the first non-singleton cell

                        -- c:cs'' -> T False (ss''++cs',bs) [dfs (x:bs) (ss'',[x]:xs:cs'') | (x,xs) <- picks c]

                        c :: [a]
c:cs'' :: [[a]]
cs'' -> Bool
-> ([[a]], [a])
-> [SearchTree ([[a]], [a])]
-> SearchTree ([[a]], [a])
forall a. Bool -> a -> [SearchTree a] -> SearchTree a
T Bool
False ([[a]]
cs'[[a]] -> [[a]] -> [[a]]
forall a. [a] -> [a] -> [a]
++[[a]]
ss'',[a]
bs) [[a] -> ([[a]], [[a]]) -> SearchTree ([[a]], [a])
dfs (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
bs) ([[a]]
ss'',[a
x][a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
:[a]
xs[a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
:[[a]]
cs'') | (x :: a
x,xs :: [a]
xs) <- [a] -> [(a, [a])]
forall a. [a] -> [(a, [a])]
picks [a]
c]
    es' :: Set [a]
es' = [[a]] -> Set [a]
forall a. Ord a => [a] -> Set a
S.fromList [[a]]
es
-- TODO: On the first level, we can use a stronger partitioning function (eg distance partitions, + see nauty manual, vertex invariants)


equitableDistancePartitionSearchTree :: Graph a -> [[a]] -> SearchTree ([[a]], [a])
equitableDistancePartitionSearchTree g :: Graph a
g@(G vs :: [a]
vs es :: [[a]]
es) p :: [[a]]
p = [a] -> [[a]] -> SearchTree ([[a]], [a])
dfs [] [[a]]
p where
    dfs :: [a] -> [[a]] -> SearchTree ([[a]], [a])
dfs bs :: [a]
bs p :: [[a]]
p = let p' :: [[a]]
p' = Set [a] -> [[a]] -> [[a]]
forall a. Ord a => Set [a] -> [[a]] -> [[a]]
equitableRefinement' Set [a]
es' [[a]]
p in
               if ([a] -> Bool) -> [[a]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all [a] -> Bool
forall a. [a] -> Bool
isSingleton [[a]]
p'
               then Bool
-> ([[a]], [a])
-> [SearchTree ([[a]], [a])]
-> SearchTree ([[a]], [a])
forall a. Bool -> a -> [SearchTree a] -> SearchTree a
T Bool
True ([[a]]
p',[a]
bs) []
               else Bool
-> ([[a]], [a])
-> [SearchTree ([[a]], [a])]
-> SearchTree ([[a]], [a])
forall a. Bool -> a -> [SearchTree a] -> SearchTree a
T Bool
False ([[a]]
p',[a]
bs) [[a] -> [[a]] -> SearchTree ([[a]], [a])
dfs (a
ba -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
bs) [[a]]
p'' | (b :: a
b,p'' :: [[a]]
p'') <- [[a]] -> [[a]] -> [(a, [[a]])]
splits [] [[a]]
p']
    -- For now, we just split the first non-singleton cell we find

    splits :: [[a]] -> [[a]] -> [(a, [[a]])]
splits ls :: [[a]]
ls (r :: [a]
r:rs :: [[a]]
rs) | [a] -> Bool
forall a. [a] -> Bool
isSingleton [a]
r = [[a]] -> [[a]] -> [(a, [[a]])]
splits ([a]
r[a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
:[[a]]
ls) [[a]]
rs
                     | Bool
otherwise = [(a
x, [[a]]
p'') | let ls' :: [[a]]
ls' = [[a]] -> [[a]]
forall a. [a] -> [a]
reverse [[a]]
ls,
                                               (x :: a
x,xs :: [a]
xs) <- [a] -> [(a, [a])]
forall a. [a] -> [(a, [a])]
picks [a]
r,
                                               let p' :: [[a]]
p' = [[a]]
ls' [[a]] -> [[a]] -> [[a]]
forall a. [a] -> [a] -> [a]
++ [a
x][a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
:[a]
xs[a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
:[[a]]
rs,
                                               let p'' :: [[a]]
p'' = ([a] -> Bool) -> [[a]] -> [[a]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ([a] -> Bool) -> [a] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) ([[a]] -> [[a]] -> [[a]]
forall a. Ord a => [[a]] -> [[a]] -> [[a]]
intersectCells [[a]]
p' (Map a [[a]]
dps Map a [[a]] -> a -> [[a]]
forall k a. Ord k => Map k a -> k -> a
M.! a
x))]
    es' :: Set [a]
es' = [[a]] -> Set [a]
forall a. Ord a => [a] -> Set a
S.fromList [[a]]
es
    dps :: Map a [[a]]
dps = [(a, [[a]])] -> Map a [[a]]
forall k a. Eq k => [(k, a)] -> Map k a
M.fromAscList [(a
v, [a] -> Set [a] -> a -> [[a]]
forall a. Ord a => [a] -> Set [a] -> a -> [[a]]
distancePartitionS [a]
vs Set [a]
es' a
v) | a
v <- [a]
vs]


{-
-- This is just fmap (\(p,bs) -> (p,bs,trace p)) t
equitablePartitionTracedSearchTree g@(G vs es) trace p = dfs [] p where
    dfs bs p = let p' = equitableRefinement' es' p
               in if all isSingleton p'
                  then T True (p',bs,trace p') []
                  else T False (p',bs,trace p') [dfs (b:bs) p'' | (b,p'') <- splits [] p']
    -- For now, we just split the first non-singleton cell we find
    splits ls (r:rs) | isSingleton r = splits (r:ls) rs
                     | otherwise = let ls' = reverse ls in [(x, ls' ++ [x]:xs:rs) | (x,xs) <- picks r]
    es' = S.fromList es
-}

-- Intended as a node invariant

trace1 :: [t a] -> [(Int, Int)]
trace1 p :: [t a]
p = ([Int] -> (Int, Int)) -> [[Int]] -> [(Int, Int)]
forall a b. (a -> b) -> [a] -> [b]
map (\xs :: [Int]
xs@(x :: Int
x:_) -> (Int
x, [Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
xs)) ([[Int]] -> [(Int, Int)]) -> [[Int]] -> [(Int, Int)]
forall a b. (a -> b) -> a -> b
$ [Int] -> [[Int]]
forall a. Eq a => [a] -> [[a]]
L.group ([Int] -> [[Int]]) -> [Int] -> [[Int]]
forall a b. (a -> b) -> a -> b
$ [Int] -> [Int]
forall a. Ord a => [a] -> [a]
L.sort ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ (t a -> Int) -> [t a] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [t a]
p

equitablePartitionGraphSearchTree :: Graph a -> SearchTree ([[a]], [a])
equitablePartitionGraphSearchTree g :: Graph a
g@(G vs :: [a]
vs es :: [[a]]
es) = Graph a -> [[a]] -> SearchTree ([[a]], [a])
forall a. Ord a => Graph a -> [[a]] -> SearchTree ([[a]], [a])
equitablePartitionSearchTree Graph a
g [[a]]
unitPartition
    where unitPartition :: [[a]]
unitPartition = [[a]
vs]

-- The incidence graph has vertices that are coloured left (points) or right (blocks).

-- We are not interested in dualities (automorphisms that swap points and blocks), so we look for colour-preserving automorphisms

equitablePartitionIncidenceSearchTree :: Graph (Either a b) -> SearchTree ([[Either a b]], [Either a b])
equitablePartitionIncidenceSearchTree g :: Graph (Either a b)
g@(G vs :: [Either a b]
vs es :: [[Either a b]]
es) = Graph (Either a b)
-> [[Either a b]] -> SearchTree ([[Either a b]], [Either a b])
forall a. Ord a => Graph a -> [[a]] -> SearchTree ([[a]], [a])
equitablePartitionSearchTree Graph (Either a b)
g [[Either a b]]
lrPartition
    where (lefts :: [a]
lefts, rights :: [b]
rights) = [Either a b] -> ([a], [b])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either a b]
vs
          lrPartition :: [[Either a b]]
lrPartition = [(a -> Either a b) -> [a] -> [Either a b]
forall a b. (a -> b) -> [a] -> [b]
map a -> Either a b
forall a b. a -> Either a b
Left [a]
lefts, (b -> Either a b) -> [b] -> [Either a b]
forall a b. (a -> b) -> [a] -> [b]
map b -> Either a b
forall a b. b -> Either a b
Right [b]
rights]

leftLeaf :: SearchTree (t [a], [a]) -> ([a], [a])
leftLeaf (T False _ (t :: SearchTree (t [a], [a])
t:ts :: [SearchTree (t [a], [a])]
ts)) = SearchTree (t [a], [a]) -> ([a], [a])
leftLeaf SearchTree (t [a], [a])
t
leftLeaf (T True (p :: t [a]
p,bs :: [a]
bs) []) = (t [a] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat t [a]
p, [a] -> [a]
forall a. [a] -> [a]
reverse [a]
bs)
{-
leftSpine (T False x (t:ts)) = x : leftSpine t
leftSpine (T True x []) = [x]
-}
allLeaves :: SearchTree (t [a], [a]) -> [([a], [a])]
allLeaves (T False _ ts :: [SearchTree (t [a], [a])]
ts) = (SearchTree (t [a], [a]) -> [([a], [a])])
-> [SearchTree (t [a], [a])] -> [([a], [a])]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap SearchTree (t [a], [a]) -> [([a], [a])]
allLeaves [SearchTree (t [a], [a])]
ts
allLeaves (T True (p :: t [a]
p,bs :: [a]
bs) []) = [(t [a] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat t [a]
p, [a] -> [a]
forall a. [a] -> [a]
reverse [a]
bs)]

{-
partitionTransversals tree = [fromPairs (zip canonical partition) | partition <- findTransversals tree] where
    (_,canonical) = leftLeaf tree
    findTransversals (T False _ (t:ts)) = concatMap (take 1 . findTransversals) ts ++ findTransversals t
    findTransversals (T True (_,partition) []) = [concat partition]

graphAuts5 = partitionTransversals . equitablePartitionGraphSearchTree
-}
-- NOT WORKING

partitionBSGS0 :: Graph a -> SearchTree ([[a]], [a]) -> ([a], [Permutation a])
partitionBSGS0 g :: Graph a
g@(G vs :: [a]
vs es :: [[a]]
es) t :: SearchTree ([[a]], [a])
t = ([a]
bs, SearchTree ([[a]], [a]) -> [Permutation a]
forall b. SearchTree ([[a]], b) -> [Permutation a]
findLevels SearchTree ([[a]], [a])
t) where
    (p1 :: [a]
p1,bs :: [a]
bs) = SearchTree ([[a]], [a]) -> ([a], [a])
forall (t :: * -> *) a a.
Foldable t =>
SearchTree (t [a], [a]) -> ([a], [a])
leftLeaf SearchTree ([[a]], [a])
t
    g1 :: Permutation a
g1 = [(a, a)] -> Permutation a
forall a. Ord a => [(a, a)] -> Permutation a
fromPairs ([(a, a)] -> Permutation a) -> [(a, a)] -> Permutation a
forall a b. (a -> b) -> a -> b
$ [a] -> [a] -> [(a, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [a]
p1 [a]
vs
    g1' :: Permutation a
g1' = Permutation a
g1Permutation a -> Integer -> Permutation a
forall a b. (Num a, HasInverses a, Integral b) => a -> b -> a
^-1
    es1 :: Set [a]
es1 = [[a]] -> Set [a]
forall a. Ord a => [a] -> Set a
S.fromList ([[a]] -> Set [a]) -> [[a]] -> Set [a]
forall a b. (a -> b) -> a -> b
$ Graph a -> [[a]]
forall a. Graph a -> [[a]]
edges (Graph a -> [[a]]) -> Graph a -> [[a]]
forall a b. (a -> b) -> a -> b
$ (a -> a) -> Graph a -> Graph a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a -> Permutation a -> a
forall a. Ord a => a -> Permutation a -> a
.^ Permutation a
g1) Graph a
g -- the edges of the isomorph corresponding to p1. (S.fromList makes it unnecessary to call nf.)

    findLevels :: SearchTree ([[a]], b) -> [Permutation a]
findLevels (T True (partition :: [[a]]
partition,_) []) = []
    findLevels (T False (partition :: [[a]]
partition,_) (t :: SearchTree ([[a]], b)
t:ts :: [SearchTree ([[a]], b)]
ts)) =
        let hs :: [Permutation a]
hs = SearchTree ([[a]], b) -> [Permutation a]
findLevels SearchTree ([[a]], b)
t
            -- TODO: It might be better to use the b that is added in t to find the cell that splits

            cell :: [a]
cell@(v :: a
v:vs :: [a]
vs) = [[a]] -> [a]
forall a. [a] -> a
head ([[a]] -> [a]) -> [[a]] -> [a]
forall a b. (a -> b) -> a -> b
$ ([a] -> Bool) -> [[a]] -> [[a]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ([a] -> Bool) -> [a] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Bool
forall a. [a] -> Bool
isSingleton) [[a]]
partition -- the cell that is going to split

        in a
-> [Permutation a]
-> [(a, SearchTree ([[a]], b))]
-> [Permutation a]
forall (t :: * -> *) b.
Foldable t =>
a
-> [Permutation a]
-> [(a, SearchTree (t [a], b))]
-> [Permutation a]
findLevel a
v [Permutation a]
hs ([a] -> [SearchTree ([[a]], b)] -> [(a, SearchTree ([[a]], b))]
forall a b. [a] -> [b] -> [(a, b)]
zip [a]
vs [SearchTree ([[a]], b)]
ts)
    findLevel :: a
-> [Permutation a]
-> [(a, SearchTree (t [a], b))]
-> [Permutation a]
findLevel v :: a
v hs :: [Permutation a]
hs ((v' :: a
v',t' :: SearchTree (t [a], b)
t'):vts :: [(a, SearchTree (t [a], b))]
vts) = if a
v' a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` a
v a -> [Permutation a] -> [a]
forall a. Ord a => a -> [Permutation a] -> [a]
.^^ [Permutation a]
hs
                                   then a
-> [Permutation a]
-> [(a, SearchTree (t [a], b))]
-> [Permutation a]
findLevel a
v [Permutation a]
hs [(a, SearchTree (t [a], b))]
vts
                                   else let h :: [Permutation a]
h = SearchTree (t [a], b) -> [Permutation a]
forall (t :: * -> *) b.
Foldable t =>
SearchTree (t [a], b) -> [Permutation a]
find1New SearchTree (t [a], b)
t' in a
-> [Permutation a]
-> [(a, SearchTree (t [a], b))]
-> [Permutation a]
findLevel a
v ([Permutation a]
h[Permutation a] -> [Permutation a] -> [Permutation a]
forall a. [a] -> [a] -> [a]
++[Permutation a]
hs) [(a, SearchTree (t [a], b))]
vts
    findLevel _ hs :: [Permutation a]
hs [] = [Permutation a]
hs
    find1New :: SearchTree (t [a], b) -> [Permutation a]
find1New (T False _ ts :: [SearchTree (t [a], b)]
ts) = Int -> [Permutation a] -> [Permutation a]
forall a. Int -> [a] -> [a]
take 1 ([Permutation a] -> [Permutation a])
-> [Permutation a] -> [Permutation a]
forall a b. (a -> b) -> a -> b
$ (SearchTree (t [a], b) -> [Permutation a])
-> [SearchTree (t [a], b)] -> [Permutation a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap SearchTree (t [a], b) -> [Permutation a]
find1New [SearchTree (t [a], b)]
ts
    -- There is a leaf for every aut, but not necessarily an aut for every leaf, so we must check we have an aut

    -- (For example, incidenceGraphPG 2 f8 has leaf nodes which do not correspond to auts.)

    find1New (T True (partition :: t [a]
partition,_) []) = let h :: Permutation a
h = [(a, a)] -> Permutation a
forall a. Ord a => [(a, a)] -> Permutation a
fromPairs ([(a, a)] -> Permutation a) -> [(a, a)] -> Permutation a
forall a b. (a -> b) -> a -> b
$ [a] -> [a] -> [(a, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip (t [a] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat t [a]
partition) [a]
vs
                                             g' :: Graph a
g' = (a -> a) -> Graph a -> Graph a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a -> Permutation a -> a
forall a. Ord a => a -> Permutation a -> a
.^ Permutation a
h) Graph a
g
                                         in if ([a] -> Bool) -> [[a]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ([a] -> Set [a] -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set [a]
es1) (Graph a -> [[a]]
forall a. Graph a -> [[a]]
edges Graph a
g') then [Permutation a
hPermutation a -> Permutation a -> Permutation a
forall a. Num a => a -> a -> a
*Permutation a
g1'] else []
    -- isAut h = all (`S.member` es') [e -^ h | e <- es]

    -- es' = S.fromList es


-- Given a partition search tree, return a base and strong generating set for graph automorphism group.

partitionBSGS :: Graph a -> SearchTree ([[a]], [a]) -> ([a], [Permutation a])
partitionBSGS g :: Graph a
g@(G vs :: [a]
vs es :: [[a]]
es) t :: SearchTree ([[a]], [a])
t = ([a]
bs, SearchTree ([[a]], [a]) -> [Permutation a]
forall b. SearchTree ([[a]], b) -> [Permutation a]
findLevels SearchTree ([[a]], [a])
t) where
    (canonical :: [a]
canonical,bs :: [a]
bs) = SearchTree ([[a]], [a]) -> ([a], [a])
forall (t :: * -> *) a a.
Foldable t =>
SearchTree (t [a], [a]) -> ([a], [a])
leftLeaf SearchTree ([[a]], [a])
t
    findLevels :: SearchTree ([[a]], b) -> [Permutation a]
findLevels (T True (partition :: [[a]]
partition,_) []) = []
    findLevels (T False (partition :: [[a]]
partition,_) (t :: SearchTree ([[a]], b)
t:ts :: [SearchTree ([[a]], b)]
ts)) =
        let hs :: [Permutation a]
hs = SearchTree ([[a]], b) -> [Permutation a]
findLevels SearchTree ([[a]], b)
t
            -- TODO: It might be better to use the b that is added in t to find the cell that splits

            cell :: [a]
cell@(v :: a
v:vs :: [a]
vs) = [[a]] -> [a]
forall a. [a] -> a
head ([[a]] -> [a]) -> [[a]] -> [a]
forall a b. (a -> b) -> a -> b
$ ([a] -> Bool) -> [[a]] -> [[a]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ([a] -> Bool) -> [a] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Bool
forall a. [a] -> Bool
isSingleton) [[a]]
partition -- the cell that is going to split

        in a
-> [Permutation a]
-> [(a, SearchTree ([[a]], b))]
-> [Permutation a]
forall (t :: * -> *) b.
Foldable t =>
a
-> [Permutation a]
-> [(a, SearchTree (t [a], b))]
-> [Permutation a]
findLevel a
v [Permutation a]
hs ([a] -> [SearchTree ([[a]], b)] -> [(a, SearchTree ([[a]], b))]
forall a b. [a] -> [b] -> [(a, b)]
zip [a]
vs [SearchTree ([[a]], b)]
ts)
    findLevel :: a
-> [Permutation a]
-> [(a, SearchTree (t [a], b))]
-> [Permutation a]
findLevel v :: a
v hs :: [Permutation a]
hs ((v' :: a
v',t' :: SearchTree (t [a], b)
t'):vts :: [(a, SearchTree (t [a], b))]
vts) = if a
v' a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` a
v a -> [Permutation a] -> [a]
forall a. Ord a => a -> [Permutation a] -> [a]
.^^ [Permutation a]
hs -- TODO: Memoize this orbit

                                   then a
-> [Permutation a]
-> [(a, SearchTree (t [a], b))]
-> [Permutation a]
findLevel a
v [Permutation a]
hs [(a, SearchTree (t [a], b))]
vts
                                   else let h :: [Permutation a]
h = SearchTree (t [a], b) -> [Permutation a]
forall (t :: * -> *) b.
Foldable t =>
SearchTree (t [a], b) -> [Permutation a]
find1New SearchTree (t [a], b)
t' in a
-> [Permutation a]
-> [(a, SearchTree (t [a], b))]
-> [Permutation a]
findLevel a
v ([Permutation a]
h[Permutation a] -> [Permutation a] -> [Permutation a]
forall a. [a] -> [a] -> [a]
++[Permutation a]
hs) [(a, SearchTree (t [a], b))]
vts
    findLevel _ hs :: [Permutation a]
hs [] = [Permutation a]
hs
    find1New :: SearchTree (t [a], b) -> [Permutation a]
find1New (T False _ ts :: [SearchTree (t [a], b)]
ts) = Int -> [Permutation a] -> [Permutation a]
forall a. Int -> [a] -> [a]
take 1 ([Permutation a] -> [Permutation a])
-> [Permutation a] -> [Permutation a]
forall a b. (a -> b) -> a -> b
$ (SearchTree (t [a], b) -> [Permutation a])
-> [SearchTree (t [a], b)] -> [Permutation a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap SearchTree (t [a], b) -> [Permutation a]
find1New [SearchTree (t [a], b)]
ts
    -- Some leaf nodes correspond to different isomorphs of the graph, and hence don't yield automorphisms

    find1New (T True (partition :: t [a]
partition,_) []) = let h :: Permutation a
h = [(a, a)] -> Permutation a
forall a. Ord a => [(a, a)] -> Permutation a
fromPairs ([(a, a)] -> Permutation a) -> [(a, a)] -> Permutation a
forall a b. (a -> b) -> a -> b
$ [a] -> [a] -> [(a, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [a]
canonical (t [a] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat t [a]
partition)
                                         in (Permutation a -> Bool) -> [Permutation a] -> [Permutation a]
forall a. (a -> Bool) -> [a] -> [a]
filter Permutation a -> Bool
isAut [Permutation a
h]
    isAut :: Permutation a -> Bool
isAut h :: Permutation a
h = ([a] -> Bool) -> [[a]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ([a] -> Set [a] -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set [a]
es') [[a]
e [a] -> Permutation a -> [a]
forall b. Ord b => [b] -> Permutation b -> [b]
-^ Permutation a
h | [a]
e <- [[a]]
es]
    es' :: Set [a]
es' = [[a]] -> Set [a]
forall a. Ord a => [a] -> Set a
S.fromList [[a]]
es
-- The tree for g1 has leaf nodes of two different isomorphs, as does the tree for incidenceGraphPG 2 f8


-- Returns auts as Right, different isomorphs as Left

-- (Must be used with the tree which doesn't put singletons to end)

partitionBSGS3 :: Graph a
-> SearchTree ([[a]], [a])
-> ([a], [Either (Permutation a) (Permutation a)])
partitionBSGS3 g :: Graph a
g@(G vs :: [a]
vs es :: [[a]]
es) t :: SearchTree ([[a]], [a])
t = ([a]
bs, SearchTree ([[a]], [a]) -> [Either (Permutation a) (Permutation a)]
forall b.
SearchTree ([[a]], b) -> [Either (Permutation a) (Permutation a)]
findLevels SearchTree ([[a]], [a])
t) where
    (p1 :: [a]
p1,bs :: [a]
bs) = SearchTree ([[a]], [a]) -> ([a], [a])
forall (t :: * -> *) a a.
Foldable t =>
SearchTree (t [a], [a]) -> ([a], [a])
leftLeaf SearchTree ([[a]], [a])
t
    findLevels :: SearchTree ([[a]], b) -> [Either (Permutation a) (Permutation a)]
findLevels (T True (partition :: [[a]]
partition,_) []) = []
    findLevels (T False (partition :: [[a]]
partition,_) (t :: SearchTree ([[a]], b)
t:ts :: [SearchTree ([[a]], b)]
ts)) =
        let hs :: [Either (Permutation a) (Permutation a)]
hs = SearchTree ([[a]], b) -> [Either (Permutation a) (Permutation a)]
findLevels SearchTree ([[a]], b)
t
            -- TODO: It might be better to use the b that is added in t to find the cell that splits

            cell :: [a]
cell@(v :: a
v:vs :: [a]
vs) = [[a]] -> [a]
forall a. [a] -> a
head ([[a]] -> [a]) -> [[a]] -> [a]
forall a b. (a -> b) -> a -> b
$ ([a] -> Bool) -> [[a]] -> [[a]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ([a] -> Bool) -> [a] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Bool
forall a. [a] -> Bool
isSingleton) [[a]]
partition -- the cell that is going to split

        in a
-> [Either (Permutation a) (Permutation a)]
-> [(a, SearchTree ([[a]], b))]
-> [Either (Permutation a) (Permutation a)]
forall (t :: * -> *) b.
Foldable t =>
a
-> [Either (Permutation a) (Permutation a)]
-> [(a, SearchTree (t [a], b))]
-> [Either (Permutation a) (Permutation a)]
findLevel a
v [Either (Permutation a) (Permutation a)]
hs ([a] -> [SearchTree ([[a]], b)] -> [(a, SearchTree ([[a]], b))]
forall a b. [a] -> [b] -> [(a, b)]
zip [a]
vs [SearchTree ([[a]], b)]
ts)
    findLevel :: a
-> [Either (Permutation a) (Permutation a)]
-> [(a, SearchTree (t [a], b))]
-> [Either (Permutation a) (Permutation a)]
findLevel v :: a
v hs :: [Either (Permutation a) (Permutation a)]
hs ((v' :: a
v',t' :: SearchTree (t [a], b)
t'):vts :: [(a, SearchTree (t [a], b))]
vts) = if a
v' a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` a
v a -> [Permutation a] -> [a]
forall a. Ord a => a -> [Permutation a] -> [a]
.^^ [Either (Permutation a) (Permutation a)] -> [Permutation a]
forall a b. [Either a b] -> [b]
rights [Either (Permutation a) (Permutation a)]
hs
                                   then a
-> [Either (Permutation a) (Permutation a)]
-> [(a, SearchTree (t [a], b))]
-> [Either (Permutation a) (Permutation a)]
findLevel a
v [Either (Permutation a) (Permutation a)]
hs [(a, SearchTree (t [a], b))]
vts
                                   else let h :: [Either (Permutation a) (Permutation a)]
h = SearchTree (t [a], b) -> [Either (Permutation a) (Permutation a)]
forall (t :: * -> *) b.
Foldable t =>
SearchTree (t [a], b) -> [Either (Permutation a) (Permutation a)]
find1New SearchTree (t [a], b)
t' in a
-> [Either (Permutation a) (Permutation a)]
-> [(a, SearchTree (t [a], b))]
-> [Either (Permutation a) (Permutation a)]
findLevel a
v ([Either (Permutation a) (Permutation a)]
h[Either (Permutation a) (Permutation a)]
-> [Either (Permutation a) (Permutation a)]
-> [Either (Permutation a) (Permutation a)]
forall a. [a] -> [a] -> [a]
++[Either (Permutation a) (Permutation a)]
hs) [(a, SearchTree (t [a], b))]
vts
    findLevel _ hs :: [Either (Permutation a) (Permutation a)]
hs [] = [Either (Permutation a) (Permutation a)]
hs
    find1New :: SearchTree (t [a], b) -> [Either (Permutation a) (Permutation a)]
find1New (T False _ ts :: [SearchTree (t [a], b)]
ts) = Int
-> [Either (Permutation a) (Permutation a)]
-> [Either (Permutation a) (Permutation a)]
forall a. Int -> [a] -> [a]
take 1 ([Either (Permutation a) (Permutation a)]
 -> [Either (Permutation a) (Permutation a)])
-> [Either (Permutation a) (Permutation a)]
-> [Either (Permutation a) (Permutation a)]
forall a b. (a -> b) -> a -> b
$ (SearchTree (t [a], b) -> [Either (Permutation a) (Permutation a)])
-> [SearchTree (t [a], b)]
-> [Either (Permutation a) (Permutation a)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap SearchTree (t [a], b) -> [Either (Permutation a) (Permutation a)]
find1New [SearchTree (t [a], b)]
ts
    -- There is a leaf for every aut, but not necessarily an aut for every leaf, so we must check we have an aut

    -- (For example, incidenceGraphPG 2 f8 has leaf nodes which do not correspond to auts.)

    find1New (T True (partition :: t [a]
partition,_) []) = let h :: Permutation a
h = [(a, a)] -> Permutation a
forall a. Ord a => [(a, a)] -> Permutation a
fromPairs ([(a, a)] -> Permutation a) -> [(a, a)] -> Permutation a
forall a b. (a -> b) -> a -> b
$ [a] -> [a] -> [(a, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [a]
p1 (t [a] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat t [a]
partition)
                                         in if Permutation a -> Bool
isAut Permutation a
h then [Permutation a -> Either (Permutation a) (Permutation a)
forall a b. b -> Either a b
Right Permutation a
h] else [Permutation a -> Either (Permutation a) (Permutation a)
forall a b. a -> Either a b
Left Permutation a
h]
    isAut :: Permutation a -> Bool
isAut h :: Permutation a
h = ([a] -> Bool) -> [[a]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ([a] -> Set [a] -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set [a]
es') [[a]
e [a] -> Permutation a -> [a]
forall b. Ord b => [b] -> Permutation b -> [b]
-^ Permutation a
h | [a]
e <- [[a]]
es]
    es' :: Set [a]
es' = [[a]] -> Set [a]
forall a. Ord a => [a] -> Set a
S.fromList [[a]]
es
-- TODO: I think we are only justified in doing find1New (ie only finding 1) if we *do* find an aut.

-- If we don't, we should potentially keep looking in that subtree

-- (See section 6 of paper. If we find isomorphic leaves, then the two subtrees of their common parent are isomorphic,

-- so no need to continue searching the second.)



-- This is using a node invariant to do more pruning.

-- However, seems to be much slower on very regular graphs (where perhaps there is no pruning to be done)

-- (This suggests that perhaps using fmap is not good - perhaps a space leak?)

-- (Or perhaps it's just that calculating and comparing the node invariants is expensive)

-- TODO: Perhaps use something simpler, like just the number of cells in the partition

partitionBSGS2 :: Graph a -> SearchTree ([[a]], [a]) -> ([a], [Permutation a])
partitionBSGS2 g :: Graph a
g@(G vs :: [a]
vs es :: [[a]]
es) t :: SearchTree ([[a]], [a])
t = ([a]
bs, SearchTree ([[a]], [a], Int) -> [Permutation a]
forall c b. Eq c => SearchTree ([[a]], b, c) -> [Permutation a]
findLevels SearchTree ([[a]], [a], Int)
t') where
    t' :: SearchTree ([[a]], [a], Int)
t' = (([[a]], [a]) -> ([[a]], [a], Int))
-> SearchTree ([[a]], [a]) -> SearchTree ([[a]], [a], Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(p :: [[a]]
p,bs :: [a]
bs) -> ([[a]]
p,[a]
bs,[[a]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
trace1 [[a]]
p)) SearchTree ([[a]], [a])
t
    trace1 :: t a -> Int
trace1 = t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length -- the number of cells in the partition

    (canonical :: [a]
canonical,bs :: [a]
bs) = SearchTree ([[a]], [a]) -> ([a], [a])
forall (t :: * -> *) a a.
Foldable t =>
SearchTree (t [a], [a]) -> ([a], [a])
leftLeaf SearchTree ([[a]], [a])
t
    findLevels :: SearchTree ([[a]], b, c) -> [Permutation a]
findLevels (T True (partition :: [[a]]
partition,_,_) []) = []
    findLevels (T False (partition :: [[a]]
partition,_,_) (t :: SearchTree ([[a]], b, c)
t:ts :: [SearchTree ([[a]], b, c)]
ts)) =
        let (T _ (_,_,trace :: c
trace) _) = SearchTree ([[a]], b, c)
t
            hs :: [Permutation a]
hs = SearchTree ([[a]], b, c) -> [Permutation a]
findLevels SearchTree ([[a]], b, c)
t
            -- TODO: It might be better to use the b that is added in t to find the cell that splits

            cell :: [a]
cell@(v :: a
v:vs :: [a]
vs) = [[a]] -> [a]
forall a. [a] -> a
head ([[a]] -> [a]) -> [[a]] -> [a]
forall a b. (a -> b) -> a -> b
$ ([a] -> Bool) -> [[a]] -> [[a]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ([a] -> Bool) -> [a] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Bool
forall a. [a] -> Bool
isSingleton) [[a]]
partition -- the cell that is going to split

            vts :: [(a, SearchTree ([[a]], b, c))]
vts = ((a, SearchTree ([[a]], b, c)) -> Bool)
-> [(a, SearchTree ([[a]], b, c))]
-> [(a, SearchTree ([[a]], b, c))]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(_,T _ (_,_,trace' :: c
trace') _) -> c
trace c -> c -> Bool
forall a. Eq a => a -> a -> Bool
== c
trace') ([(a, SearchTree ([[a]], b, c))]
 -> [(a, SearchTree ([[a]], b, c))])
-> [(a, SearchTree ([[a]], b, c))]
-> [(a, SearchTree ([[a]], b, c))]
forall a b. (a -> b) -> a -> b
$ [a]
-> [SearchTree ([[a]], b, c)] -> [(a, SearchTree ([[a]], b, c))]
forall a b. [a] -> [b] -> [(a, b)]
zip [a]
vs [SearchTree ([[a]], b, c)]
ts
        in a
-> [Permutation a]
-> [(a, SearchTree ([[a]], b, c))]
-> [Permutation a]
forall (t :: * -> *) b c.
Foldable t =>
a
-> [Permutation a]
-> [(a, SearchTree (t [a], b, c))]
-> [Permutation a]
findLevel a
v [Permutation a]
hs [(a, SearchTree ([[a]], b, c))]
vts
    findLevel :: a
-> [Permutation a]
-> [(a, SearchTree (t [a], b, c))]
-> [Permutation a]
findLevel v :: a
v hs :: [Permutation a]
hs ((v' :: a
v',t' :: SearchTree (t [a], b, c)
t'):vts :: [(a, SearchTree (t [a], b, c))]
vts) = if a
v' a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` a
v a -> [Permutation a] -> [a]
forall a. Ord a => a -> [Permutation a] -> [a]
.^^ [Permutation a]
hs
                                   then a
-> [Permutation a]
-> [(a, SearchTree (t [a], b, c))]
-> [Permutation a]
findLevel a
v [Permutation a]
hs [(a, SearchTree (t [a], b, c))]
vts
                                   else let h :: [Permutation a]
h = SearchTree (t [a], b, c) -> [Permutation a]
forall (t :: * -> *) b c.
Foldable t =>
SearchTree (t [a], b, c) -> [Permutation a]
find1New SearchTree (t [a], b, c)
t' in a
-> [Permutation a]
-> [(a, SearchTree (t [a], b, c))]
-> [Permutation a]
findLevel a
v ([Permutation a]
h[Permutation a] -> [Permutation a] -> [Permutation a]
forall a. [a] -> [a] -> [a]
++[Permutation a]
hs) [(a, SearchTree (t [a], b, c))]
vts
    findLevel _ hs :: [Permutation a]
hs [] = [Permutation a]
hs
    find1New :: SearchTree (t [a], b, c) -> [Permutation a]
find1New (T False _ ts :: [SearchTree (t [a], b, c)]
ts) = Int -> [Permutation a] -> [Permutation a]
forall a. Int -> [a] -> [a]
take 1 ([Permutation a] -> [Permutation a])
-> [Permutation a] -> [Permutation a]
forall a b. (a -> b) -> a -> b
$ (SearchTree (t [a], b, c) -> [Permutation a])
-> [SearchTree (t [a], b, c)] -> [Permutation a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap SearchTree (t [a], b, c) -> [Permutation a]
find1New [SearchTree (t [a], b, c)]
ts
    -- There is a leaf for every aut, but not necessarily an aut for every leaf, so we must check we have an aut

    -- (For example, incidenceGraphPG 2 f8 has leaf nodes which do not correspond to auts.)

    -- (The graph g1, below, shows a simple example where this will happen.)

    find1New (T True (partition :: t [a]
partition,_,_) []) = let h :: Permutation a
h = [(a, a)] -> Permutation a
forall a. Ord a => [(a, a)] -> Permutation a
fromPairs ([(a, a)] -> Permutation a) -> [(a, a)] -> Permutation a
forall a b. (a -> b) -> a -> b
$ [a] -> [a] -> [(a, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [a]
canonical (t [a] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat t [a]
partition)
                                           in (Permutation a -> Bool) -> [Permutation a] -> [Permutation a]
forall a. (a -> Bool) -> [a] -> [a]
filter Permutation a -> Bool
isAut [Permutation a
h]
    isAut :: Permutation a -> Bool
isAut h :: Permutation a
h = ([a] -> Bool) -> [[a]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ([a] -> Set [a] -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set [a]
es') [[a]
e [a] -> Permutation a -> [a]
forall b. Ord b => [b] -> Permutation b -> [b]
-^ Permutation a
h | [a]
e <- [[a]]
es]
    es' :: Set [a]
es' = [[a]] -> Set [a]
forall a. Ord a => [a] -> Set a
S.fromList [[a]]
es


graphAuts7 :: Graph a -> ([a], [Permutation a])
graphAuts7 g :: Graph a
g = (Graph a -> SearchTree ([[a]], [a]) -> ([a], [Permutation a])
forall a a.
Ord a =>
Graph a -> SearchTree ([[a]], [a]) -> ([a], [Permutation a])
partitionBSGS Graph a
g) (Graph a -> SearchTree ([[a]], [a])
forall a. Ord a => Graph a -> SearchTree ([[a]], [a])
equitablePartitionGraphSearchTree Graph a
g)

-- This is faster on kneser graphs, but slower on incidenceGraphPG

graphAuts8 :: Graph a -> ([a], [Permutation a])
graphAuts8 g :: Graph a
g = (Graph a -> SearchTree ([[a]], [a]) -> ([a], [Permutation a])
forall a a.
Ord a =>
Graph a -> SearchTree ([[a]], [a]) -> ([a], [Permutation a])
partitionBSGS Graph a
g) (Graph a -> [[a]] -> SearchTree ([[a]], [a])
forall a. Ord a => Graph a -> [[a]] -> SearchTree ([[a]], [a])
equitableDistancePartitionSearchTree Graph a
g [Graph a -> [a]
forall a. Graph a -> [a]
vertices Graph a
g])

-- This is a graph where the node invariant should cause pruning.

-- The initial equitable partition will be [[1..8],[9,10]], because it can do no better than distinguish by degree

-- However, vertices 1..4 and vertices 5..8 are in fact different (there is no aut that takes one set to the other),

-- so the subtrees starting 1..4 have a different invariant to those starting 5..8

g1 :: Graph a
g1 = [a] -> [[a]] -> Graph a
forall a. [a] -> [[a]] -> Graph a
G [1..10] [[1,2],[1,3],[1,9],[2,4],[2,10],[3,4],[3,9],[4,10],[5,6],[5,8],[5,9],[6,7],[6,10],[7,8],[7,9],[8,10]]

g1' :: Graph a
g1' = Graph a -> Graph a
forall a. Ord a => Graph a -> Graph a
nf (Graph a -> Graph a) -> Graph a -> Graph a
forall a b. (a -> b) -> a -> b
$ (a -> a) -> Graph a -> Graph a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\x :: a
x -> if a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= 4 then a
xa -> a -> a
forall a. Num a => a -> a -> a
+4 else if a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= 8 then a
xa -> a -> a
forall a. Num a => a -> a -> a
-4 else a
x) Graph a
forall a. (Num a, Enum a) => Graph a
g1
-- G [1..10] [[1,2],[1,4],[1,9],[2,3],[2,10],[3,4],[3,9],[4,10],[5,6],[5,7],[5,9],[6,8],[6,10],[7,8],[7,9],[8,10]]


g2 :: Graph a
g2 = [a] -> [[a]] -> Graph a
forall a. [a] -> [[a]] -> Graph a
G [1..12] [[1,2],[1,4],[1,11],[2,3],[2,12],[3,4],[3,11],[4,12],[5,6],[5,8],[5,11],[6,9],[6,12],[7,8],[7,10],[7,11],[8,12],[9,10],[9,11],[10,12]]

-- NOT WORKING: This fails to find the isomorphism between g1 and g1' above.

-- Instead of using left leaf, we need to find the canonical isomorph, as described in the paper.

-- (In a graph where not all leaves lead to automorphisms, we might happen to end up with non-isomorphic left leaves)

maybeGraphIso :: Graph k -> Graph a -> Maybe (Map k a)
maybeGraphIso g1 :: Graph k
g1 g2 :: Graph a
g2 = let (vs1 :: [k]
vs1,_) = (SearchTree ([[k]], [k]) -> ([k], [k])
forall (t :: * -> *) a a.
Foldable t =>
SearchTree (t [a], [a]) -> ([a], [a])
leftLeaf (SearchTree ([[k]], [k]) -> ([k], [k]))
-> (Graph k -> SearchTree ([[k]], [k])) -> Graph k -> ([k], [k])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph k -> SearchTree ([[k]], [k])
forall a. Ord a => Graph a -> SearchTree ([[a]], [a])
equitablePartitionGraphSearchTree) Graph k
g1
                          (vs2 :: [a]
vs2,_) = (SearchTree ([[a]], [a]) -> ([a], [a])
forall (t :: * -> *) a a.
Foldable t =>
SearchTree (t [a], [a]) -> ([a], [a])
leftLeaf (SearchTree ([[a]], [a]) -> ([a], [a]))
-> (Graph a -> SearchTree ([[a]], [a])) -> Graph a -> ([a], [a])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph a -> SearchTree ([[a]], [a])
forall a. Ord a => Graph a -> SearchTree ([[a]], [a])
equitablePartitionGraphSearchTree) Graph a
g2
                          f :: Map k a
f = [(k, a)] -> Map k a
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([k] -> [a] -> [(k, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [k]
vs1 [a]
vs2)
                      in if [k] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [k]
vs1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
vs2 Bool -> Bool -> Bool
&& (Graph a -> Graph a
forall a. Ord a => Graph a -> Graph a
nf (Graph a -> Graph a) -> (Graph k -> Graph a) -> Graph k -> Graph a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (k -> a) -> Graph k -> Graph a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Map k a
f Map k a -> k -> a
forall k a. Ord k => Map k a -> k -> a
M.!)) Graph k
g1 Graph a -> Graph a -> Bool
forall a. Eq a => a -> a -> Bool
== Graph a
g2 then Map k a -> Maybe (Map k a)
forall a. a -> Maybe a
Just Map k a
f else Maybe (Map k a)
forall a. Maybe a
Nothing


-- AUTS OF INCIDENCE STRUCTURE VIA INCIDENCE GRAPH


-- This code is nearly identical to the corresponding graphAuts code, with two exceptions:

-- 1. We start by partitioning into lefts and rights.

-- This avoids left-right crossover auts, which while they are auts of the graph,

-- are not auts of the incidence structure

-- 2. When labelling the nodes, we filter out Right blocks, and unLeft the Left points

incidenceAutsDistancePartitionSearchTree :: Graph (Either b b) -> SearchTree [(b, b)]
incidenceAutsDistancePartitionSearchTree g :: Graph (Either b b)
g@(G vs :: [Either b b]
vs es :: [[Either b b]]
es) = [(Either b b, Either b b)]
-> ([[Either b b]], [[Either b b]]) -> SearchTree [(b, b)]
dfs [] ([[Either b b]]
lrPart, [[Either b b]]
lrPart) where
    dfs :: [(Either b b, Either b b)]
-> ([[Either b b]], [[Either b b]]) -> SearchTree [(b, b)]
dfs xys :: [(Either b b, Either b b)]
xys (srcPart :: [[Either b b]]
srcPart,trgPart :: [[Either b b]]
trgPart)
        | ([Either b b] -> Bool) -> [[Either b b]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all [Either b b] -> Bool
forall a. [a] -> Bool
isSingleton [[Either b b]]
srcPart =
             let xys' :: [(Either b b, Either b b)]
xys' = [Either b b] -> [Either b b] -> [(Either b b, Either b b)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([[Either b b]] -> [Either b b]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Either b b]]
srcPart) ([[Either b b]] -> [Either b b]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Either b b]]
trgPart)
             in Bool -> [(b, b)] -> [SearchTree [(b, b)]] -> SearchTree [(b, b)]
forall a. Bool -> a -> [SearchTree a] -> SearchTree a
T ([(Either b b, Either b b)] -> Bool
isCompatible [(Either b b, Either b b)]
xys') ([(Either b b, Either b b)] -> [(b, b)]
forall a b b b. [(Either a b, Either b b)] -> [(a, b)]
unLeft ([(Either b b, Either b b)] -> [(b, b)])
-> [(Either b b, Either b b)] -> [(b, b)]
forall a b. (a -> b) -> a -> b
$ [(Either b b, Either b b)]
xys[(Either b b, Either b b)]
-> [(Either b b, Either b b)] -> [(Either b b, Either b b)]
forall a. [a] -> [a] -> [a]
++[(Either b b, Either b b)]
xys') []
             -- Since the xys' are distance-compatible with the xys, they are certainly edge-compatible.

             -- However, we do need to check that the xys' are edge-compatible with each other.

        | Bool
otherwise = let (x :: Either b b
x:xs :: [Either b b]
xs):srcCells :: [[Either b b]]
srcCells = [[Either b b]]
srcPart
                          yys :: [Either b b]
yys   :trgCells :: [[Either b b]]
trgCells = [[Either b b]]
trgPart
                          srcPart' :: [[Either b b]]
srcPart' = [[Either b b]] -> [[Either b b]] -> [[Either b b]]
forall a. Ord a => [[a]] -> [[a]] -> [[a]]
intersectCells ([Either b b]
xs [Either b b] -> [[Either b b]] -> [[Either b b]]
forall a. a -> [a] -> [a]
: [[Either b b]]
srcCells) (Map (Either b b) [[Either b b]]
dps Map (Either b b) [[Either b b]] -> Either b b -> [[Either b b]]
forall k a. Ord k => Map k a -> k -> a
M.! Either b b
x)
                      in Bool -> [(b, b)] -> [SearchTree [(b, b)]] -> SearchTree [(b, b)]
forall a. Bool -> a -> [SearchTree a] -> SearchTree a
T Bool
False ([(Either b b, Either b b)] -> [(b, b)]
forall a b b b. [(Either a b, Either b b)] -> [(a, b)]
unLeft [(Either b b, Either b b)]
xys) -- the L.sort in the following line is so that we traverse vertices in natural order

                         [[(Either b b, Either b b)]
-> ([[Either b b]], [[Either b b]]) -> SearchTree [(b, b)]
dfs ((Either b b
x,Either b b
y)(Either b b, Either b b)
-> [(Either b b, Either b b)] -> [(Either b b, Either b b)]
forall a. a -> [a] -> [a]
:[(Either b b, Either b b)]
xys) (([([Either b b], [Either b b])] -> ([[Either b b]], [[Either b b]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([([Either b b], [Either b b])]
 -> ([[Either b b]], [[Either b b]]))
-> ([([Either b b], [Either b b])]
    -> [([Either b b], [Either b b])])
-> [([Either b b], [Either b b])]
-> ([[Either b b]], [[Either b b]])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [([Either b b], [Either b b])] -> [([Either b b], [Either b b])]
forall a. Ord a => [a] -> [a]
L.sort) ([[Either b b]] -> [[Either b b]] -> [([Either b b], [Either b b])]
forall a b. [a] -> [b] -> [(a, b)]
zip (([Either b b] -> Bool) -> [[Either b b]] -> [[Either b b]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ([Either b b] -> Bool) -> [Either b b] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either b b] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [[Either b b]]
srcPart') (([Either b b] -> Bool) -> [[Either b b]] -> [[Either b b]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ([Either b b] -> Bool) -> [Either b b] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either b b] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [[Either b b]]
trgPart')))
                         | (y :: Either b b
y,ys :: [Either b b]
ys) <- [Either b b] -> [(Either b b, [Either b b])]
forall a. [a] -> [(a, [a])]
picks [Either b b]
yys,
                           let trgPart' :: [[Either b b]]
trgPart' = [[Either b b]] -> [[Either b b]] -> [[Either b b]]
forall a. Ord a => [[a]] -> [[a]] -> [[a]]
intersectCells ([Either b b]
ys [Either b b] -> [[Either b b]] -> [[Either b b]]
forall a. a -> [a] -> [a]
: [[Either b b]]
trgCells) (Map (Either b b) [[Either b b]]
dps Map (Either b b) [[Either b b]] -> Either b b -> [[Either b b]]
forall k a. Ord k => Map k a -> k -> a
M.! Either b b
y),
                           ([Either b b] -> Int) -> [[Either b b]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [Either b b] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Either b b]]
srcPart' [Int] -> [Int] -> Bool
forall a. Eq a => a -> a -> Bool
== ([Either b b] -> Int) -> [[Either b b]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [Either b b] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Either b b]]
trgPart']
    isCompatible :: [(Either b b, Either b b)] -> Bool
isCompatible xys :: [(Either b b, Either b b)]
xys = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [([Either b b
x,Either b b
x'] [Either b b] -> Set [Either b b] -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set [Either b b]
es') Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== ([Either b b] -> [Either b b]
forall a. Ord a => [a] -> [a]
L.sort [Either b b
y,Either b b
y'] [Either b b] -> Set [Either b b] -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set [Either b b]
es') | (x :: Either b b
x,y :: Either b b
y) <- [(Either b b, Either b b)]
xys, (x' :: Either b b
x',y' :: Either b b
y') <- [(Either b b, Either b b)]
xys, Either b b
x Either b b -> Either b b -> Bool
forall a. Ord a => a -> a -> Bool
< Either b b
x']
    (lefts :: [b]
lefts, rights :: [b]
rights) = [Either b b] -> ([b], [b])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either b b]
vs
    lrPart :: [[Either b b]]
lrPart = [(b -> Either b b) -> [b] -> [Either b b]
forall a b. (a -> b) -> [a] -> [b]
map b -> Either b b
forall a b. a -> Either a b
Left [b]
lefts, (b -> Either b b) -> [b] -> [Either b b]
forall a b. (a -> b) -> [a] -> [b]
map b -> Either b b
forall a b. b -> Either a b
Right [b]
rights] -- Partition the vertices into left and right, to exclude crossover auts

    unLeft :: [(Either a b, Either b b)] -> [(a, b)]
unLeft xys :: [(Either a b, Either b b)]
xys = [(a
x,b
y) | (Left x :: a
x, Left y :: b
y) <- [(Either a b, Either b b)]
xys] -- also filters out Rights

    es' :: Set [Either b b]
es' = [[Either b b]] -> Set [Either b b]
forall a. Ord a => [a] -> Set a
S.fromList [[Either b b]]
es
    dps :: Map (Either b b) [[Either b b]]
dps = [(Either b b, [[Either b b]])] -> Map (Either b b) [[Either b b]]
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Either b b
v, [Either b b] -> Set [Either b b] -> Either b b -> [[Either b b]]
forall a. Ord a => [a] -> Set [a] -> a -> [[a]]
distancePartitionS [Either b b]
vs Set [Either b b]
es' Either b b
v) | Either b b
v <- [Either b b]
vs]

-- |Given the incidence graph of an incidence structure between points and blocks

-- (for example, a set system),

-- @incidenceAuts g@ returns a strong generating set for the automorphism group of the incidence structure.

-- The generators are represented as permutations of the points.

-- The incidence graph should be represented with the points on the left and the blocks on the right.

incidenceAuts :: (Ord p, Ord b) => Graph (Either p b) -> [Permutation p]
incidenceAuts :: Graph (Either p b) -> [Permutation p]
incidenceAuts = (Permutation p -> Bool) -> [Permutation p] -> [Permutation p]
forall a. (a -> Bool) -> [a] -> [a]
filter (Permutation p -> Permutation p -> Bool
forall a. Eq a => a -> a -> Bool
/= [[p]] -> Permutation p
forall a. Ord a => [[a]] -> Permutation a
p []) ([Permutation p] -> [Permutation p])
-> (Graph (Either p b) -> [Permutation p])
-> Graph (Either p b)
-> [Permutation p]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SearchTree [(p, p)] -> [Permutation p]
forall a. Ord a => SearchTree [(a, a)] -> [Permutation a]
strongTerminals (SearchTree [(p, p)] -> [Permutation p])
-> (Graph (Either p b) -> SearchTree [(p, p)])
-> Graph (Either p b)
-> [Permutation p]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph (Either p b) -> SearchTree [(p, p)]
forall b b.
(Ord b, Ord b) =>
Graph (Either b b) -> SearchTree [(b, b)]
incidenceAutsDistancePartitionSearchTree


-- TODO: Filter out rights, map unLeft - to bs and gs

incidenceAuts2 :: Graph (Either a b) -> ([Either a b], [Permutation (Either a b)])
incidenceAuts2 g :: Graph (Either a b)
g = (Graph (Either a b)
-> SearchTree ([[Either a b]], [Either a b])
-> ([Either a b], [Permutation (Either a b)])
forall a a.
Ord a =>
Graph a -> SearchTree ([[a]], [a]) -> ([a], [Permutation a])
partitionBSGS Graph (Either a b)
g) (Graph (Either a b) -> SearchTree ([[Either a b]], [Either a b])
forall a b.
(Ord a, Ord b) =>
Graph (Either a b) -> SearchTree ([[Either a b]], [Either a b])
equitablePartitionIncidenceSearchTree Graph (Either a b)
g)
    where unLeft :: Either a b -> a
unLeft (Left x :: a
x) = a
x
          -- map (\g -> fromPairs . map (\(Left x, Left y) -> (x,y)) . filter (\(x,y) -> isLeft x) . toPairs) gs



-- GRAPH ISOMORPHISMS


-- !! not yet using equitable partitions, so could probably be more efficient


-- graphIsos :: (Ord a, Ord b) => Graph a -> Graph b -> [[(a,b)]]

graphIsos :: Graph a -> Graph a -> [[(a, a)]]
graphIsos g1 :: Graph a
g1 g2 :: Graph a
g2
    | [Graph a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Graph a]
cs1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [Graph a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Graph a]
cs2 = []
    | Bool
otherwise = [Graph a] -> [Graph a] -> [[(a, a)]]
forall a a. (Ord a, Ord a) => [Graph a] -> [Graph a] -> [[(a, a)]]
graphIsos' [Graph a]
cs1 [Graph a]
cs2
    where cs1 :: [Graph a]
cs1 = ([a] -> Graph a) -> [[a]] -> [Graph a]
forall a b. (a -> b) -> [a] -> [b]
map (Graph a -> [a] -> Graph a
forall a. Eq a => Graph a -> [a] -> Graph a
inducedSubgraph Graph a
g1) (Graph a -> [[a]]
forall a. Ord a => Graph a -> [[a]]
components Graph a
g1)
          cs2 :: [Graph a]
cs2 = ([a] -> Graph a) -> [[a]] -> [Graph a]
forall a b. (a -> b) -> [a] -> [b]
map (Graph a -> [a] -> Graph a
forall a. Eq a => Graph a -> [a] -> Graph a
inducedSubgraph Graph a
g2) (Graph a -> [[a]]
forall a. Ord a => Graph a -> [[a]]
components Graph a
g2)
          graphIsos' :: [Graph a] -> [Graph a] -> [[(a, a)]]
graphIsos' (ci :: Graph a
ci:cis :: [Graph a]
cis) cjs :: [Graph a]
cjs =
              [[(a, a)]
iso [(a, a)] -> [(a, a)] -> [(a, a)]
forall a. [a] -> [a] -> [a]
++ [(a, a)]
iso' | (cj :: Graph a
cj,cjs' :: [Graph a]
cjs') <- [Graph a] -> [(Graph a, [Graph a])]
forall a. [a] -> [(a, [a])]
picks [Graph a]
cjs,
                             [(a, a)]
iso <- Graph a -> Graph a -> [[(a, a)]]
forall a a. (Ord a, Ord a) => Graph a -> Graph a -> [[(a, a)]]
graphIsosCon Graph a
ci Graph a
cj,
                             [(a, a)]
iso' <- [Graph a] -> [Graph a] -> [[(a, a)]]
graphIsos' [Graph a]
cis [Graph a]
cjs']
          graphIsos' [] [] = [[]]

-- isos between connected graphs

graphIsosCon :: Graph a -> Graph a -> [[(a, a)]]
graphIsosCon g1 :: Graph a
g1 g2 :: Graph a
g2 
    | Graph a -> Bool
forall t. Ord t => Graph t -> Bool
isConnected Graph a
g1 Bool -> Bool -> Bool
&& Graph a -> Bool
forall t. Ord t => Graph t -> Bool
isConnected Graph a
g2
        = [[[(a, a)]]] -> [[(a, a)]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(a, a)] -> [[a]] -> [[a]] -> [[(a, a)]]
dfs [] (Graph a -> a -> [[a]]
forall a. Ord a => Graph a -> a -> [[a]]
distancePartition Graph a
g1 a
v1) (Graph a -> a -> [[a]]
forall a. Ord a => Graph a -> a -> [[a]]
distancePartition Graph a
g2 a
v2)
                 | a
v1 <- Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take 1 (Graph a -> [a]
forall a. Graph a -> [a]
vertices Graph a
g1), a
v2 <- Graph a -> [a]
forall a. Graph a -> [a]
vertices Graph a
g2]
                 -- the take 1 handles the case where g1 is the null graph

    | Bool
otherwise = [Char] -> [[(a, a)]]
forall a. HasCallStack => [Char] -> a
error "graphIsosCon: either or both graphs are not connected"
    where dfs :: [(a, a)] -> [[a]] -> [[a]] -> [[(a, a)]]
dfs xys :: [(a, a)]
xys p1 :: [[a]]
p1 p2 :: [[a]]
p2
              | ([a] -> Int) -> [[a]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[a]]
p1 [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]]
p2 = []
              | Bool
otherwise =
                  let p1' :: [[a]]
p1' = ([a] -> Bool) -> [[a]] -> [[a]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ([a] -> Bool) -> [a] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [[a]]
p1
                      p2' :: [[a]]
p2' = ([a] -> Bool) -> [[a]] -> [[a]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ([a] -> Bool) -> [a] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [[a]]
p2
                  in if ([a] -> Bool) -> [[a]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all [a] -> Bool
forall a. [a] -> Bool
isSingleton [[a]]
p1'
                     then let xys' :: [(a, a)]
xys' = [(a, a)]
xys [(a, a)] -> [(a, a)] -> [(a, a)]
forall a. [a] -> [a] -> [a]
++ [a] -> [a] -> [(a, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[a]]
p1') ([[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[a]]
p2')
                          in if [(a, a)] -> Bool
isCompatible [(a, a)]
xys' then [[(a, a)]
xys'] else []
                     else let (x :: a
x:xs :: [a]
xs):p1'' :: [[a]]
p1'' = [[a]]
p1'
                              ys :: [a]
ys:p2'' :: [[a]]
p2'' = [[a]]
p2'
                          in [[[(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]] -> [[a]] -> [[a]]
forall a. Ord a => [[a]] -> [[a]] -> [[a]]
intersectCells ([a]
xs [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [[a]]
p1'') (Map a [[a]]
dps1 Map a [[a]] -> a -> [[a]]
forall k a. Ord k => Map k a -> k -> a
M.! a
x))
                                         ([[a]] -> [[a]] -> [[a]]
forall a. Ord a => [[a]] -> [[a]] -> [[a]]
intersectCells ([a]
ys'[a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [[a]]
p2'') (Map a [[a]]
dps2 Map a [[a]] -> a -> [[a]]
forall k a. Ord k => Map k a -> k -> a
M.! a
y))
                                         | (y :: a
y,ys' :: [a]
ys') <- [a] -> [(a, [a])]
forall a. [a] -> [(a, [a])]
picks [a]
ys]
          isCompatible :: [(a, a)] -> Bool
isCompatible xys :: [(a, a)]
xys = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [([a
x,a
x'] [a] -> Set [a] -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set [a]
es1) Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== ([a] -> [a]
forall a. Ord a => [a] -> [a]
L.sort [a
y,a
y'] [a] -> Set [a] -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set [a]
es2) | (x :: a
x,y :: a
y) <- [(a, a)]
xys, (x' :: a
x',y' :: a
y') <- [(a, a)]
xys, a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
x']
          dps1 :: Map a [[a]]
dps1 = [(a, [[a]])] -> Map a [[a]]
forall k a. Eq k => [(k, a)] -> Map k a
M.fromAscList [(a
v, [a] -> Set [a] -> a -> [[a]]
forall a. Ord a => [a] -> Set [a] -> a -> [[a]]
distancePartitionS [a]
vs1 Set [a]
es1 a
v) | a
v <- [a]
vs1]
          dps2 :: Map a [[a]]
dps2 = [(a, [[a]])] -> Map a [[a]]
forall k a. Eq k => [(k, a)] -> Map k a
M.fromAscList [(a
v, [a] -> Set [a] -> a -> [[a]]
forall a. Ord a => [a] -> Set [a] -> a -> [[a]]
distancePartitionS [a]
vs2 Set [a]
es2 a
v) | a
v <- [a]
vs2]
          -- dps1 = M.fromList [(v, distancePartition g1 v) | v <- vertices g1]

          -- dps2 = M.fromList [(v, distancePartition g2 v) | v <- vertices g2]

          vs1 :: [a]
vs1 = Graph a -> [a]
forall a. Graph a -> [a]
vertices Graph a
g1
          vs2 :: [a]
vs2 = Graph a -> [a]
forall a. Graph a -> [a]
vertices Graph a
g2
          es1 :: Set [a]
es1 = [[a]] -> Set [a]
forall a. Ord a => [a] -> Set a
S.fromList ([[a]] -> Set [a]) -> [[a]] -> Set [a]
forall a b. (a -> b) -> a -> b
$ Graph a -> [[a]]
forall a. Graph a -> [[a]]
edges Graph a
g1
          es2 :: Set [a]
es2 = [[a]] -> Set [a]
forall a. Ord a => [a] -> Set a
S.fromList ([[a]] -> Set [a]) -> [[a]] -> Set [a]
forall a b. (a -> b) -> a -> b
$ Graph a -> [[a]]
forall a. Graph a -> [[a]]
edges Graph a
g2


-- |Are the two graphs isomorphic?

isGraphIso :: (Ord a, Ord b) => Graph a -> Graph b -> Bool
isGraphIso :: Graph a -> Graph b -> Bool
isGraphIso g1 :: Graph a
g1 g2 :: Graph b
g2 = (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) (Graph a -> Graph b -> [[(a, b)]]
forall a a. (Ord a, Ord a) => Graph a -> Graph a -> [[(a, a)]]
graphIsos Graph a
g1 Graph b
g2)
-- !! If we're only interested in seeing whether or not two graphs are iso,

-- !! then the cost of calculating distancePartitions may not be warranted

-- !! (see Math.Combinatorics.Poset: orderIsos01 versus orderIsos)



-- the following differs from graphIsos in only two ways

-- we avoid Left, Right crossover isos, by insisting that a Left is taken to a Left (first two lines)

-- we return only the action on the Lefts, and unLeft it

-- incidenceIsos :: (Ord p1, Ord b1, Ord p2, Ord b2) =>

--     Graph (Either p1 b1) -> Graph (Either p2 b2) -> [[(p1,p2)]]


incidenceIsos :: Graph (Either a b) -> Graph (Either b b) -> [[(a, b)]]
incidenceIsos g1 :: Graph (Either a b)
g1 g2 :: Graph (Either b b)
g2
    | [Graph (Either a b)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Graph (Either a b)]
cs1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [Graph (Either b b)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Graph (Either b b)]
cs2 = []
    | Bool
otherwise = [Graph (Either a b)] -> [Graph (Either b b)] -> [[(a, b)]]
forall a b b b.
(Ord a, Ord b, Ord b, Ord b) =>
[Graph (Either a b)] -> [Graph (Either b b)] -> [[(a, b)]]
incidenceIsos' [Graph (Either a b)]
cs1 [Graph (Either b b)]
cs2
    where cs1 :: [Graph (Either a b)]
cs1 = ([Either a b] -> Graph (Either a b))
-> [[Either a b]] -> [Graph (Either a b)]
forall a b. (a -> b) -> [a] -> [b]
map (Graph (Either a b) -> [Either a b] -> Graph (Either a b)
forall a. Eq a => Graph a -> [a] -> Graph a
inducedSubgraph Graph (Either a b)
g1) (([Either a b] -> Bool) -> [[Either a b]] -> [[Either a b]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ([Either a b] -> Bool) -> [Either a b] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([a] -> Bool) -> ([Either a b] -> [a]) -> [Either a b] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either a b] -> [a]
forall a b. [Either a b] -> [a]
lefts) ([[Either a b]] -> [[Either a b]])
-> [[Either a b]] -> [[Either a b]]
forall a b. (a -> b) -> a -> b
$ Graph (Either a b) -> [[Either a b]]
forall a. Ord a => Graph a -> [[a]]
components Graph (Either a b)
g1)
          cs2 :: [Graph (Either b b)]
cs2 = ([Either b b] -> Graph (Either b b))
-> [[Either b b]] -> [Graph (Either b b)]
forall a b. (a -> b) -> [a] -> [b]
map (Graph (Either b b) -> [Either b b] -> Graph (Either b b)
forall a. Eq a => Graph a -> [a] -> Graph a
inducedSubgraph Graph (Either b b)
g2) (([Either b b] -> Bool) -> [[Either b b]] -> [[Either b b]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ([Either b b] -> Bool) -> [Either b b] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [b] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([b] -> Bool) -> ([Either b b] -> [b]) -> [Either b b] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either b b] -> [b]
forall a b. [Either a b] -> [a]
lefts) ([[Either b b]] -> [[Either b b]])
-> [[Either b b]] -> [[Either b b]]
forall a b. (a -> b) -> a -> b
$ Graph (Either b b) -> [[Either b b]]
forall a. Ord a => Graph a -> [[a]]
components Graph (Either b b)
g2)
          incidenceIsos' :: [Graph (Either a b)] -> [Graph (Either b b)] -> [[(a, b)]]
incidenceIsos' (ci :: Graph (Either a b)
ci:cis :: [Graph (Either a b)]
cis) cjs :: [Graph (Either b b)]
cjs =
              [[(a, b)]
iso [(a, b)] -> [(a, b)] -> [(a, b)]
forall a. [a] -> [a] -> [a]
++ [(a, b)]
iso' | (cj :: Graph (Either b b)
cj,cjs' :: [Graph (Either b b)]
cjs') <- [Graph (Either b b)]
-> [(Graph (Either b b), [Graph (Either b b)])]
forall a. [a] -> [(a, [a])]
picks [Graph (Either b b)]
cjs,
                             [(a, b)]
iso <- Graph (Either a b) -> Graph (Either b b) -> [[(a, b)]]
forall a b b b.
(Ord a, Ord b, Ord b, Ord b) =>
Graph (Either a b) -> Graph (Either b b) -> [[(a, b)]]
incidenceIsosCon Graph (Either a b)
ci Graph (Either b b)
cj,
                             [(a, b)]
iso' <- [Graph (Either a b)] -> [Graph (Either b b)] -> [[(a, b)]]
incidenceIsos' [Graph (Either a b)]
cis [Graph (Either b b)]
cjs']
          incidenceIsos' [] [] = [[]]

incidenceIsosCon :: Graph (Either a b) -> Graph (Either b b) -> [[(a, b)]]
incidenceIsosCon g1 :: Graph (Either a b)
g1 g2 :: Graph (Either b b)
g2
    | Graph (Either a b) -> Bool
forall t. Ord t => Graph t -> Bool
isConnected Graph (Either a b)
g1 Bool -> Bool -> Bool
&& Graph (Either b b) -> Bool
forall t. Ord t => Graph t -> Bool
isConnected Graph (Either b b)
g2
        = [[[(a, b)]]] -> [[(a, b)]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Either a b, Either b b)]
-> [[Either a b]] -> [[Either b b]] -> [[(a, b)]]
dfs [] (Graph (Either a b) -> Either a b -> [[Either a b]]
forall a. Ord a => Graph a -> a -> [[a]]
distancePartition Graph (Either a b)
g1 Either a b
v1) (Graph (Either b b) -> Either b b -> [[Either b b]]
forall a. Ord a => Graph a -> a -> [[a]]
distancePartition Graph (Either b b)
g2 Either b b
v2)
                 | v1 :: Either a b
v1@(Left _) <- Int -> [Either a b] -> [Either a b]
forall a. Int -> [a] -> [a]
take 1 (Graph (Either a b) -> [Either a b]
forall a. Graph a -> [a]
vertices Graph (Either a b)
g1), v2 :: Either b b
v2@(Left _) <- Graph (Either b b) -> [Either b b]
forall a. Graph a -> [a]
vertices Graph (Either b b)
g2]
                 -- g1 may have no vertices

    | Bool
otherwise = [Char] -> [[(a, b)]]
forall a. HasCallStack => [Char] -> a
error "incidenceIsos: one or both graphs not connected"
    where dfs :: [(Either a b, Either b b)]
-> [[Either a b]] -> [[Either b b]] -> [[(a, b)]]
dfs xys :: [(Either a b, Either b b)]
xys p1 :: [[Either a b]]
p1 p2 :: [[Either b b]]
p2
              | ([Either a b] -> Int) -> [[Either a b]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [Either a b] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Either a b]]
p1 [Int] -> [Int] -> Bool
forall a. Eq a => a -> a -> Bool
/= ([Either b b] -> Int) -> [[Either b b]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [Either b b] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Either b b]]
p2 = []
              | Bool
otherwise =
                  let p1' :: [[Either a b]]
p1' = ([Either a b] -> Bool) -> [[Either a b]] -> [[Either a b]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ([Either a b] -> Bool) -> [Either a b] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either a b] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [[Either a b]]
p1
                      p2' :: [[Either b b]]
p2' = ([Either b b] -> Bool) -> [[Either b b]] -> [[Either b b]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ([Either b b] -> Bool) -> [Either b b] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either b b] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [[Either b b]]
p2
                  in if ([Either a b] -> Bool) -> [[Either a b]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all [Either a b] -> Bool
forall a. [a] -> Bool
isSingleton [[Either a b]]
p1'
                     then let xys' :: [(Either a b, Either b b)]
xys' = [(Either a b, Either b b)]
xys [(Either a b, Either b b)]
-> [(Either a b, Either b b)] -> [(Either a b, Either b b)]
forall a. [a] -> [a] -> [a]
++ [Either a b] -> [Either b b] -> [(Either a b, Either b b)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([[Either a b]] -> [Either a b]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Either a b]]
p1') ([[Either b b]] -> [Either b b]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Either b b]]
p2')
                          in if [(Either a b, Either b b)] -> Bool
isCompatible [(Either a b, Either b b)]
xys' then [[(a
x,b
y) | (Left x, Left y) <- [(Either a b, Either b b)]
xys']] else []
                     else let (x :: Either a b
x:xs :: [Either a b]
xs):p1'' :: [[Either a b]]
p1'' = [[Either a b]]
p1'
                              ys :: [Either b b]
ys:p2'' :: [[Either b b]]
p2'' = [[Either b b]]
p2'
                          in [[[(a, b)]]] -> [[(a, b)]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Either a b, Either b b)]
-> [[Either a b]] -> [[Either b b]] -> [[(a, b)]]
dfs ((Either a b
x,Either b b
y)(Either a b, Either b b)
-> [(Either a b, Either b b)] -> [(Either a b, Either b b)]
forall a. a -> [a] -> [a]
:[(Either a b, Either b b)]
xys)
                                         ([[Either a b]] -> [[Either a b]] -> [[Either a b]]
forall a. Ord a => [[a]] -> [[a]] -> [[a]]
intersectCells ([Either a b]
xs [Either a b] -> [[Either a b]] -> [[Either a b]]
forall a. a -> [a] -> [a]
: [[Either a b]]
p1'') (Map (Either a b) [[Either a b]]
dps1 Map (Either a b) [[Either a b]] -> Either a b -> [[Either a b]]
forall k a. Ord k => Map k a -> k -> a
M.! Either a b
x))
                                         ([[Either b b]] -> [[Either b b]] -> [[Either b b]]
forall a. Ord a => [[a]] -> [[a]] -> [[a]]
intersectCells ([Either b b]
ys'[Either b b] -> [[Either b b]] -> [[Either b b]]
forall a. a -> [a] -> [a]
: [[Either b b]]
p2'') (Map (Either b b) [[Either b b]]
dps2 Map (Either b b) [[Either b b]] -> Either b b -> [[Either b b]]
forall k a. Ord k => Map k a -> k -> a
M.! Either b b
y))
                                         | (y :: Either b b
y,ys' :: [Either b b]
ys') <- [Either b b] -> [(Either b b, [Either b b])]
forall a. [a] -> [(a, [a])]
picks [Either b b]
ys]
          isCompatible :: [(Either a b, Either b b)] -> Bool
isCompatible xys :: [(Either a b, Either b b)]
xys = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [([Either a b
x,Either a b
x'] [Either a b] -> Set [Either a b] -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set [Either a b]
es1) Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== ([Either b b] -> [Either b b]
forall a. Ord a => [a] -> [a]
L.sort [Either b b
y,Either b b
y'] [Either b b] -> Set [Either b b] -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set [Either b b]
es2) | (x :: Either a b
x,y :: Either b b
y) <- [(Either a b, Either b b)]
xys, (x' :: Either a b
x',y' :: Either b b
y') <- [(Either a b, Either b b)]
xys, Either a b
x Either a b -> Either a b -> Bool
forall a. Ord a => a -> a -> Bool
< Either a b
x']
          dps1 :: Map (Either a b) [[Either a b]]
dps1 = [(Either a b, [[Either a b]])] -> Map (Either a b) [[Either a b]]
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Either a b
v, Graph (Either a b) -> Either a b -> [[Either a b]]
forall a. Ord a => Graph a -> a -> [[a]]
distancePartition Graph (Either a b)
g1 Either a b
v) | Either a b
v <- Graph (Either a b) -> [Either a b]
forall a. Graph a -> [a]
vertices Graph (Either a b)
g1]
          dps2 :: Map (Either b b) [[Either b b]]
dps2 = [(Either b b, [[Either b b]])] -> Map (Either b b) [[Either b b]]
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Either b b
v, Graph (Either b b) -> Either b b -> [[Either b b]]
forall a. Ord a => Graph a -> a -> [[a]]
distancePartition Graph (Either b b)
g2 Either b b
v) | Either b b
v <- Graph (Either b b) -> [Either b b]
forall a. Graph a -> [a]
vertices Graph (Either b b)
g2]
          es1 :: Set [Either a b]
es1 = [[Either a b]] -> Set [Either a b]
forall a. Ord a => [a] -> Set a
S.fromList ([[Either a b]] -> Set [Either a b])
-> [[Either a b]] -> Set [Either a b]
forall a b. (a -> b) -> a -> b
$ Graph (Either a b) -> [[Either a b]]
forall a. Graph a -> [[a]]
edges Graph (Either a b)
g1
          es2 :: Set [Either b b]
es2 = [[Either b b]] -> Set [Either b b]
forall a. Ord a => [a] -> Set a
S.fromList ([[Either b b]] -> Set [Either b b])
-> [[Either b b]] -> Set [Either b b]
forall a b. (a -> b) -> a -> b
$ Graph (Either b b) -> [[Either b b]]
forall a. Graph a -> [[a]]
edges Graph (Either b b)
g2

-- |Are the two incidence structures represented by these incidence graphs isomorphic?

isIncidenceIso :: (Ord p1, Ord b1, Ord p2, Ord b2) =>
     Graph (Either p1 b1) -> Graph (Either p2 b2) -> Bool
isIncidenceIso :: Graph (Either p1 b1) -> Graph (Either p2 b2) -> Bool
isIncidenceIso g1 :: Graph (Either p1 b1)
g1 g2 :: Graph (Either p2 b2)
g2 = (Bool -> Bool
not (Bool -> Bool) -> ([[(p1, p2)]] -> Bool) -> [[(p1, p2)]] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[(p1, p2)]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) (Graph (Either p1 b1) -> Graph (Either p2 b2) -> [[(p1, p2)]]
forall a b b b.
(Ord b, Ord b, Ord a, Ord b) =>
Graph (Either a b) -> Graph (Either b b) -> [[(a, b)]]
incidenceIsos Graph (Either p1 b1)
g1 Graph (Either p2 b2)
g2)