module Math.Combinatorics.GraphAuts (isVertexTransitive, isEdgeTransitive,
isArcTransitive, is2ArcTransitive, is3ArcTransitive, isnArcTransitive,
isDistanceTransitive,
graphAuts, incidenceAuts,
graphIsos, incidenceIsos,
isGraphIso, isIncidenceIso) where
import Data.Either (lefts)
import qualified Data.List as L
import qualified Data.Map as M
import qualified Data.Set as S
import Data.Maybe
import Math.Common.ListSet
import Math.Core.Utils (combinationsOf, pairs)
import Math.Combinatorics.Graph
import Math.Algebra.Group.PermutationGroup
import Math.Algebra.Group.SchreierSims as SS
isVertexTransitive :: (Ord t) => Graph t -> Bool
isVertexTransitive (G [] []) = True
isVertexTransitive g@(G (v:vs) es) = orbitV auts v == v:vs where
auts = graphAuts g
isEdgeTransitive :: (Ord t) => Graph t -> Bool
isEdgeTransitive (G _ []) = True
isEdgeTransitive g@(G vs (e:es)) = orbitE auts e == e:es where
auts = graphAuts g
arc ->^ g = map (.^ g) arc
isArcTransitive :: (Ord t) => Graph t -> Bool
isArcTransitive (G _ []) = True
isArcTransitive g@(G vs es) = orbit (->^) a auts == a:as where
a:as = L.sort $ es ++ map reverse es
auts = graphAuts g
isArcTransitive' g@(G (v:vs) es) =
orbitP auts v == v:vs &&
orbitP stab n == n:ns
where auts = graphAuts g
stab = dropWhile (\p -> v .^ p /= v) auts
n:ns = nbrs g v
findArcs g@(G vs es) x l = map reverse $ dfs [ ([x],0) ] where
dfs ( (z1:z2:zs,l') : nodes)
| l == l' = (z1:z2:zs) : dfs nodes
| otherwise = dfs $ [(w:z1:z2:zs,l'+1) | w <- nbrs g z1, w /= z2] ++ nodes
dfs ( ([z],l') : nodes)
| l == l' = [z] : dfs nodes
| otherwise = dfs $ [([w,z],l'+1) | w <- nbrs g z] ++ nodes
dfs [] = []
isnArcTransitive :: (Ord t) => Int -> Graph t -> Bool
isnArcTransitive _ (G [] []) = True
isnArcTransitive n g@(G (v:vs) es) =
orbitP auts v == v:vs &&
orbit (->^) a stab == a:as
where auts = graphAuts g
stab = dropWhile (\p -> v .^ p /= v) auts
a:as = findArcs g v n
is2ArcTransitive :: (Ord t) => Graph t -> Bool
is2ArcTransitive g = isnArcTransitive 2 g
is3ArcTransitive :: (Ord t) => Graph t -> Bool
is3ArcTransitive g = isnArcTransitive 3 g
isDistanceTransitive :: (Ord t) => Graph t -> Bool
isDistanceTransitive (G [] []) = True
isDistanceTransitive g@(G (v:vs) es)
| isConnected g =
orbitP auts v == v:vs &&
length stabOrbits == diameter g + 1
| otherwise = error "isDistanceTransitive: only defined for connected graphs"
where auts = graphAuts g
stab = dropWhile (\p -> v .^ p /= v) auts
stabOrbits = let os = orbits stab in os ++ map (:[]) ((v:vs) L.\\ concat os)
refine p1 p2 = filter (not . null) $ refine' p1 p2
refine' p1 p2 = concat [ [c1 `intersect` c2 | c2 <- p2] | c1 <- p1]
isGraphAut (G vs es) h = all (`S.member` es') [e -^ h | e <- es]
where es' = S.fromList es
adjLists (G vs es) = adjLists' M.empty es
where adjLists' nbrs ([u,v]:es) =
adjLists' (M.insertWith' (flip (++)) v [u] $ M.insertWith' (flip (++)) u [v] nbrs) es
adjLists' nbrs [] = nbrs
graphAuts1 (G vs es) = dfs [] vs vs
where dfs xys (x:xs) ys =
concat [dfs ((x,y):xys) xs (L.delete y ys) | y <- ys, isCompatible (x,y) xys]
dfs xys [] [] = [fromPairs xys]
isCompatible (x,y) xys = and [([x',x] `S.member` es') == (L.sort [y,y'] `S.member` es') | (x',y') <- xys]
es' = S.fromList es
graphAuts2 (G vs es) = graphAuts' [] vs
where graphAuts' us (v:vs) =
let uus = zip us us
in concat [take 1 $ dfs ((v,w):uus) vs (v : L.delete w vs) | w <- vs, isCompatible (v,w) uus]
++ graphAuts' (v:us) vs
graphAuts' _ [] = []
dfs xys (x:xs) ys =
concat [dfs ((x,y):xys) xs (L.delete y ys) | y <- ys, isCompatible (x,y) xys]
dfs xys [] [] = [fromPairs xys]
isCompatible (x,y) xys = and [([x',x] `S.member` es') == (L.sort [y,y'] `S.member` es') | (x',y') <- xys]
es' = S.fromList es
graphAuts3 g@(G vs es) = graphAuts' [] [vs] where
graphAuts' us ((x:ys):pt) =
let px = refine' (ys : pt) (dps M.! x)
p y = refine' ((x : L.delete y ys) : pt) (dps M.! y)
uus = zip us us
p' = L.sort $ filter (not . null) $ px
in concat [take 1 $ dfs ((x,y):uus) px (p y) | y <- ys]
++ graphAuts' (x:us) p'
graphAuts' us ([]:pt) = graphAuts' us pt
graphAuts' _ [] = []
dfs xys p1 p2
| map length p1 /= map length p2 = []
| otherwise =
let p1' = filter (not . null) p1
p2' = filter (not . null) p2
in if all isSingleton p1'
then let xys' = xys ++ zip (concat p1') (concat p2')
in if isCompatible xys' then [fromPairs' xys'] else []
else let (x:xs):p1'' = p1'
ys:p2'' = p2'
in concat [dfs ((x,y):xys)
(refine' (xs : p1'') (dps M.! x))
(refine' ((L.delete y ys):p2'') (dps M.! y))
| y <- ys]
isCompatible xys = and [([x,x'] `S.member` es') == (L.sort [y,y'] `S.member` es') | (x,y) <- xys, (x',y') <- xys, x < x']
dps = M.fromList [(v, distancePartition g v) | v <- vs]
es' = S.fromList es
isSingleton [_] = True
isSingleton _ = False
graphAuts4 g@(G vs es) = graphAuts' [] [vs] where
graphAuts' us p@((x:ys):pt) =
let p' = L.sort $ refine (ys:pt) (dps M.! x)
in level us p x ys []
++ graphAuts' (x:us) p'
graphAuts' us ([]:pt) = graphAuts' us pt
graphAuts' _ [] = []
level us p@(ph:pt) x (y:ys) hs =
let px = refine' (L.delete x ph : pt) (dps M.! x)
py = refine' (L.delete y ph : pt) (dps M.! y)
uus = zip us us
in case dfs ((x,y):uus) px py of
[] -> level us p x ys hs
h:_ -> let hs' = h:hs in h : level us p x (ys L.\\ (x .^^ hs')) hs'
level _ _ _ [] _ = []
dfs xys p1 p2
| map length p1 /= map length p2 = []
| otherwise =
let p1' = filter (not . null) p1
p2' = filter (not . null) p2
in if all isSingleton p1'
then let xys' = xys ++ zip (concat p1') (concat p2')
in if isCompatible xys' then [fromPairs' xys'] else []
else let (x:xs):p1'' = p1'
ys:p2'' = p2'
in concat [dfs ((x,y):xys)
(refine' (xs : p1'') (dps M.! x))
(refine' ((L.delete y ys):p2'') (dps M.! y))
| y <- ys]
isCompatible xys = and [([x,x'] `S.member` es') == (L.sort [y,y'] `S.member` es') | (x,y) <- xys, (x',y') <- xys, x < x']
dps = M.fromList [(v, distancePartition g v) | v <- vs]
es' = S.fromList es
eqgraph = G vs es where
vs = [1..14]
es = L.sort $ [[1,14],[2,13]] ++ [ [v1,v2] | [v1,v2] <- combinationsOf 2 vs, v1+1 == v2 || v1+3 == v2 && even v2]
toEquitable g cells = L.sort $ toEquitable' [] cells where
toEquitable' ls (r:rs) =
let (lls,lrs) = L.partition isSingleton $ map (splitNumNbrs r) ls
rs' = concatMap (splitNumNbrs r) rs
in if isSingleton r
then r : toEquitable' (concat lls) (concat lrs ++ rs')
else toEquitable' (r : concat lls) (concat lrs ++ rs')
toEquitable' ls [] = ls
splitNumNbrs t c = map (map snd) $ L.groupBy (\x y -> fst x == fst y) $ L.sort
[ (length ((nbrs_g M.! v) `intersect` t), v) | v <- c]
nbrs_g = M.fromList [(v, nbrs g v) | v <- vertices g]
toEquitable2 nbrs_g psrc ptrg = unzip $ L.sort $ toEquitable' [] (zip psrc ptrg) where
toEquitable' ls (r:rs) =
let ls' = map (splitNumNbrs nbrs_g r) ls
(lls,lrs) = L.partition isSingleton $ map fromJust ls'
rs' = map (splitNumNbrs nbrs_g r) rs
in if any isNothing ls' || any isNothing rs'
then []
else
toEquitable' (r : concat lls) (concat lrs ++ concatMap fromJust rs')
toEquitable' ls [] = ls
splitNumNbrs nbrs_g (t_src,t_trg) (c_src,c_trg) =
let src_split = L.groupBy (\x y -> fst x == fst y) $ L.sort
[ (length ((nbrs_g M.! v) `intersect` t_src), v) | v <- c_src]
trg_split = L.groupBy (\x y -> fst x == fst y) $ L.sort
[ (length ((nbrs_g M.! v) `intersect` t_trg), v) | v <- c_trg]
in if map length src_split == map length trg_split
&& map (fst . head) src_split == map (fst . head) trg_split
then Just $ zip (map (map snd) src_split) (map (map snd) trg_split)
else Nothing
graphAuts :: (Ord a) => Graph a -> [Permutation a]
graphAuts g = autsWithinComponents ++ isosBetweenComponents
where cs = map (inducedSubgraph g) (components g)
autsWithinComponents = concatMap graphAuts4 cs
isosBetweenComponents = map swapFromIso $ concat [take 1 (graphIsos ci cj) | (ci,cj) <- pairs cs]
swapFromIso xys = fromPairs (xys ++ map swap xys)
swap (x,y) = (y,x)
graphAutsCon g@(G vs es)
| isConnected g = graphAuts' [] (toEquitable g $ valencyPartition g)
| otherwise = error "graphAutsCon: graph is not connected"
where graphAuts' us p@((x:ys):pt) =
let p' = L.sort $ filter (not . null) $ refine' (ys:pt) (dps M.! x)
in level us p x ys []
++ graphAuts' (x:us) p'
graphAuts' us ([]:pt) = graphAuts' us pt
graphAuts' _ [] = []
level us p@(ph:pt) x (y:ys) hs =
let px = refine' (L.delete x ph : pt) (dps M.! x)
py = refine' (L.delete y ph : pt) (dps M.! y)
uus = zip us us
in case dfsEquitable (dps,es',nbrs_g) ((x,y):uus) px py of
[] -> level us p x ys hs
h:_ -> let hs' = h:hs in h : level us p x (ys L.\\ (x .^^ hs')) hs'
level _ _ _ [] _ = []
dps = M.fromList [(v, distancePartition g v) | v <- vs]
es' = S.fromList es
nbrs_g = M.fromList [(v, nbrs g v) | v <- vs]
dfsEquitable (dps,es',nbrs_g) xys p1 p2 = dfs xys p1 p2 where
dfs xys p1 p2
| map length p1 /= map length p2 = []
| otherwise =
let p1' = filter (not . null) p1
p2' = filter (not . null) p2
(p1e,p2e) = toEquitable2 nbrs_g p1' p2'
in if null p1e
then []
else
if all isSingleton p1e
then let xys' = xys ++ zip (concat p1e) (concat p2e)
in if isCompatible xys' then [fromPairs' xys'] else []
else let (x:xs):p1'' = p1e
ys:p2'' = p2e
in concat [dfs ((x,y):xys)
(refine' (xs : p1'') (dps M.! x))
(refine' ((L.delete y ys):p2'') (dps M.! y))
| y <- ys]
isCompatible xys = and [([x,x'] `S.member` es') == (L.sort [y,y'] `S.member` es') | (x,y) <- xys, (x',y') <- xys, x < x']
incidenceAuts :: (Ord p, Ord b) => Graph (Either p b) -> [Permutation p]
incidenceAuts g = autsWithinComponents ++ isosBetweenComponents
where cs = map (inducedSubgraph g) (components g)
autsWithinComponents = concatMap incidenceAutsCon cs
isosBetweenComponents = map swapFromIso $ concat [take 1 (incidenceIsos ci cj) | (ci,cj) <- pairs cs]
swapFromIso xys = fromPairs (xys ++ map swap xys)
swap (x,y) = (y,x)
incidenceAutsCon g@(G vs es)
| isConnected g = map points (incidenceAuts' [] [vs])
| otherwise = error "incidenceAutsCon: graph is not connected"
where points h = fromPairs [(x,y) | (Left x, Left y) <- toPairs h]
incidenceAuts' us p@((x@(Left _):ys):pt) =
let p' = L.sort $ refine (ys:pt) (dps M.! x)
in level us p x ys []
++ incidenceAuts' (x:us) p'
incidenceAuts' us ([]:pt) = incidenceAuts' us pt
incidenceAuts' _ (((Right _):_):_) = []
incidenceAuts' _ [] = []
level us p@(ph:pt) x (y@(Left _):ys) hs =
let px = refine' (L.delete x ph : pt) (dps M.! x)
py = refine' (L.delete y ph : pt) (dps M.! y)
uus = zip us us
in case dfsEquitable (dps,es',nbrs_g) ((x,y):uus) px py of
[] -> level us p x ys hs
h:_ -> let hs' = h:hs in h : level us p x (ys L.\\ (x .^^ hs')) hs'
level _ _ _ _ _ = []
dps = M.fromList [(v, distancePartition g v) | v <- vs]
es' = S.fromList es
nbrs_g = M.fromList [(v, nbrs g v) | v <- vs]
graphIsos g1 g2
| length cs1 /= length cs2 = []
| otherwise = graphIsos' cs1 cs2
where cs1 = map (inducedSubgraph g1) (components g1)
cs2 = map (inducedSubgraph g2) (components g2)
graphIsos' (ci:cis) cjs =
[iso ++ iso' | cj <- cjs,
iso <- graphIsosCon ci cj,
let cjs' = L.delete cj cjs,
iso' <- graphIsos' cis cjs']
graphIsos' [] [] = [[]]
graphIsosCon g1 g2
| isConnected g1 && isConnected g2
= concat [dfs [] (distancePartition g1 v1) (distancePartition g2 v2)
| v1 <- take 1 (vertices g1), v2 <- vertices g2]
| otherwise = error "graphIsosCon: either or both graphs are not connected"
where dfs xys p1 p2
| map length p1 /= map length p2 = []
| otherwise =
let p1' = filter (not . null) p1
p2' = filter (not . null) p2
in if all isSingleton p1'
then let xys' = xys ++ zip (concat p1') (concat p2')
in if isCompatible xys' then [xys'] else []
else let (x:xs):p1'' = p1'
ys:p2'' = p2'
in concat [dfs ((x,y):xys)
(refine' (xs : p1'') (dps1 M.! x))
(refine' ((L.delete y ys):p2'') (dps2 M.! y))
| y <- ys]
isCompatible xys = and [([x,x'] `S.member` es1) == (L.sort [y,y'] `S.member` es2) | (x,y) <- xys, (x',y') <- xys, x < x']
dps1 = M.fromList [(v, distancePartition g1 v) | v <- vertices g1]
dps2 = M.fromList [(v, distancePartition g2 v) | v <- vertices g2]
es1 = S.fromList $ edges g1
es2 = S.fromList $ edges g2
isGraphIso :: (Ord a, Ord b) => Graph a -> Graph b -> Bool
isGraphIso g1 g2 = (not . null) (graphIsos g1 g2)
isIso g1 g2 = (not . null) (graphIsos g1 g2)
incidenceIsos g1 g2
| length cs1 /= length cs2 = []
| otherwise = incidenceIsos' cs1 cs2
where cs1 = map (inducedSubgraph g1) (filter (not . null . lefts) $ components g1)
cs2 = map (inducedSubgraph g2) (filter (not . null . lefts) $ components g2)
incidenceIsos' (ci:cis) cjs =
[iso ++ iso' | cj <- cjs,
iso <- incidenceIsosCon ci cj,
let cjs' = L.delete cj cjs,
iso' <- incidenceIsos' cis cjs']
incidenceIsos' [] [] = [[]]
incidenceIsosCon g1 g2
| isConnected g1 && isConnected g2
= concat [dfs [] (distancePartition g1 v1) (distancePartition g2 v2)
| v1@(Left _) <- take 1 (vertices g1), v2@(Left _) <- vertices g2]
| otherwise = error "incidenceIsos: one or both graphs not connected"
where dfs xys p1 p2
| map length p1 /= map length p2 = []
| otherwise =
let p1' = filter (not . null) p1
p2' = filter (not . null) p2
in if all isSingleton p1'
then let xys' = xys ++ zip (concat p1') (concat p2')
in if isCompatible xys' then [[(x,y) | (Left x, Left y) <- xys']] else []
else let (x:xs):p1'' = p1'
ys:p2'' = p2'
in concat [dfs ((x,y):xys)
(refine' (xs : p1'') (dps1 M.! x))
(refine' ((L.delete y ys):p2'') (dps2 M.! y))
| y <- ys]
isCompatible xys = and [([x,x'] `S.member` es1) == (L.sort [y,y'] `S.member` es2) | (x,y) <- xys, (x',y') <- xys, x < x']
dps1 = M.fromList [(v, distancePartition g1 v) | v <- vertices g1]
dps2 = M.fromList [(v, distancePartition g2 v) | v <- vertices g2]
es1 = S.fromList $ edges g1
es2 = S.fromList $ edges g2
isIncidenceIso :: (Ord p1, Ord b1, Ord p2, Ord b2) =>
Graph (Either p1 b1) -> Graph (Either p2 b2) -> Bool
isIncidenceIso g1 g2 = (not . null) (incidenceIsos g1 g2)