{- | 
    Module      :  Data.Graph.Automorphism
    Copyright   :  (c) Jean-Philippe Bernardy 2003, 2008
    License     :  GPL

    Maintainer  :  JeanPhilippe.Bernardy@gmail.com
    Stability   :  proposal
    Portability :  GHC


   implementation of the canonic labeling of graphs + automorphism group.

  The implementation is based on:
  Brendan D. McKay, PRACTICAL GRAPH ISOMORPHISM,
  in Congressus Numerantium,
  Vol. 30 (1981), pp. 45-87.


NOTE: Usage of implicit automorphisms, as described on page 62, is not implemented here.

TODO:
  - as GHC 6.6, use Sequence instead of appends at end.
  - skip first automorphism found; it is identity.
  - try not relabeling the graphs

-}

module Data.Graph.Automorphism(canonicGraph, canonicGraph0, autGenerators,
                               automorphisms, isIsomorphic, debugTree, withUnitPartition) where

import Data.Graph(Graph, Vertex)
import Data.Array
import Data.List (sort, isPrefixOf)
import Control.Monad (when)
import Control.Monad.ST
import Data.Graph.Partition
import Data.Graph.Permutation
import Data.STRef
import Data.Tree

-- relabel a graph, given a discrete partition
relabel :: Graph -> Partition -> Graph
relabel :: Graph -> Partition -> Graph
relabel Graph
gr Partition
partition = Permutation -> Graph -> Graph
applyPerm Permutation
simplePermutation Graph
gr
    where simplePermutation :: Permutation
simplePermutation = (Vertex, Vertex) -> [(Vertex, Vertex)] -> Permutation
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array (Vertex, Vertex)
bnds ([Vertex] -> [Vertex] -> [(Vertex, Vertex)]
forall a b. [a] -> [b] -> [(a, b)]
zip (([Vertex] -> Vertex) -> Partition -> [Vertex]
forall a b. (a -> b) -> [a] -> [b]
map [Vertex] -> Vertex
forall a. HasCallStack => [a] -> a
head Partition
partition) ((Vertex, Vertex) -> [Vertex]
forall a. Ix a => (a, a) -> [a]
range (Vertex, Vertex)
bnds))
          bnds :: (Vertex, Vertex)
bnds = Graph -> (Vertex, Vertex)
forall i e. Array i e -> (i, i)
bounds Graph
gr


-----------------------------------------------
-- The following manages the nests of partitions

initialPartition :: Partition -> Graph -> Partition
initialPartition :: Partition -> Graph -> Partition
initialPartition Partition
pie Graph
gr = Graph -> Partition -> Partition -> Partition
refine Graph
gr ((Vertex, Vertex) -> Partition
unitPartition ((Vertex, Vertex) -> Partition) -> (Vertex, Vertex) -> Partition
forall a b. (a -> b) -> a -> b
$ Graph -> (Vertex, Vertex)
forall i e. Array i e -> (i, i)
bounds Graph
gr) Partition
pie

{- Not currently used:
discretePartition :: Graph -> Partition
discretePartition gr = map (: []) (range $ bounds gr)

splittingCell :: Partition -> Cell
splittingCell = head . filter (not . isSingleton)
-}

splitPartition :: Partition -> [(Vertex, Partition)]
splitPartition :: Partition -> [(Vertex, Partition)]
splitPartition [] = []
splitPartition ([Vertex]
c1:Partition
cs1) =
    if [Vertex] -> Bool
forall a. [a] -> Bool
isSingleton [Vertex]
c1
        then [(Vertex
v, [Vertex]
c1[Vertex] -> Partition -> Partition
forall a. a -> [a] -> [a]
:Partition
cs2) | (Vertex
v,Partition
cs2) <- Partition -> [(Vertex, Partition)]
splitPartition Partition
cs1]
        else [(Vertex
v, [Vertex]
c2[Vertex] -> Partition -> Partition
forall a. a -> [a] -> [a]
:[Vertex
v][Vertex] -> Partition -> Partition
forall a. a -> [a] -> [a]
:Partition
cs1) | (Vertex
v, [Vertex]
c2) <- [Vertex] -> [(Vertex, [Vertex])]
splitCell [Vertex]
c1]


-- splitCell [x,y,z] = [(x,[y,z]), (y,[x,z]), (z, [x,y])]
splitCell :: Cell -> [(Vertex, Cell)]
splitCell :: [Vertex] -> [(Vertex, [Vertex])]
splitCell [] = []
splitCell (Vertex
v:[Vertex]
c) = (Vertex
v, [Vertex]
c) (Vertex, [Vertex]) -> [(Vertex, [Vertex])] -> [(Vertex, [Vertex])]
forall a. a -> [a] -> [a]
: [(Vertex
v2, Vertex
vVertex -> [Vertex] -> [Vertex]
forall a. a -> [a] -> [a]
:[Vertex]
c2) | (Vertex
v2, [Vertex]
c2) <- [Vertex] -> [(Vertex, [Vertex])]
splitCell [Vertex]
c]


childPartitions :: Graph -> Partition -> [(Vertex, Partition)]
childPartitions :: Graph -> Partition -> [(Vertex, Partition)]
childPartitions Graph
gr Partition
part =
    [(Vertex
n, Graph -> Partition -> Partition -> Partition
refine Graph
gr Partition
p [[Vertex
n]]) | (Vertex
n,Partition
p) <- Partition -> [(Vertex, Partition)]
splitPartition Partition
part]

partitionTree :: Partition -> Graph -> Tree Partition
partitionTree :: Partition -> Graph -> Tree Partition
partitionTree Partition
userPartition Graph
gr = Partition -> Tree Partition
tree (Partition -> Graph -> Partition
initialPartition Partition
userPartition Graph
gr)
    where tree :: Partition -> Tree Partition
tree Partition
p = Partition -> [Tree Partition] -> Tree Partition
forall a. a -> [Tree a] -> Tree a
Node Partition
p (((Vertex, Partition) -> Tree Partition)
-> [(Vertex, Partition)] -> [Tree Partition]
forall a b. (a -> b) -> [a] -> [b]
map (Partition -> Tree Partition
tree (Partition -> Tree Partition)
-> ((Vertex, Partition) -> Partition)
-> (Vertex, Partition)
-> Tree Partition
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Vertex, Partition) -> Partition
forall a b. (a, b) -> b
snd) (Graph -> Partition -> [(Vertex, Partition)]
childPartitions Graph
gr Partition
p))

annotateTree :: (a -> b) -> Tree a -> Tree (a,b)
annotateTree :: forall a b. (a -> b) -> Tree a -> Tree (a, b)
annotateTree a -> b
f = (a -> (a, b)) -> Tree a -> Tree (a, b)
forall a b. (a -> b) -> Tree a -> Tree b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> (a, b)
f'
    where f' :: a -> (a, b)
f' a
x = (a
x, a -> b
f a
x)

debugTree :: Partition -> Graph -> IO ()
debugTree :: Partition -> Graph -> IO ()
debugTree Partition
userPartition Graph
gr = String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Tree String -> String
drawTree (Tree String -> String) -> Tree String -> String
forall a b. (a -> b) -> a -> b
$ ((Partition, Indicator) -> String)
-> Tree (Partition, Indicator) -> Tree String
forall a b. (a -> b) -> Tree a -> Tree b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Partition, Indicator) -> String
forall a. Show a => a -> String
show (Tree (Partition, Indicator) -> Tree String)
-> Tree (Partition, Indicator) -> Tree String
forall a b. (a -> b) -> a -> b
$ (Partition -> Indicator)
-> Tree Partition -> Tree (Partition, Indicator)
forall a b. (a -> b) -> Tree a -> Tree (a, b)
annotateTree (Graph -> Partition -> Indicator
lambda Graph
gr) (Tree Partition -> Tree (Partition, Indicator))
-> Tree Partition -> Tree (Partition, Indicator)
forall a b. (a -> b) -> a -> b
$ Partition -> Graph -> Tree Partition
partitionTree Partition
userPartition Graph
gr

-----------------------------------------
-- Simple version of the Nauty algorithm
-- (No use of automorphism information)

-- | All paths from root to leaves
paths :: Tree t -> [[t]]
paths :: forall t. Tree t -> [[t]]
paths (Node t
x []) = [[t
x]]
paths (Node t
x [Tree t]
cs) = ([t] -> [t]) -> [[t]] -> [[t]]
forall a b. (a -> b) -> [a] -> [b]
map (t
xt -> [t] -> [t]
forall a. a -> [a] -> [a]
:) ((Tree t -> [[t]]) -> [Tree t] -> [[t]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Tree t -> [[t]]
forall t. Tree t -> [[t]]
paths [Tree t]
cs)

-- | Returns a canonic labeling of the graph (slow -- but dead simple implementation).
-- This implementation serves documentation and debugging purposes.
canonicGraph0 :: Partition -> Graph -> Graph
canonicGraph0 :: Partition -> Graph -> Graph
canonicGraph0 Partition
userPartition Graph
gr0 = ([Indicator], Graph) -> Graph
forall a b. (a, b) -> b
snd (([Indicator], Graph) -> Graph)
-> (Graph -> ([Indicator], Graph)) -> Graph -> Graph
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [([Indicator], Graph)] -> ([Indicator], Graph)
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ([([Indicator], Graph)] -> ([Indicator], Graph))
-> (Graph -> [([Indicator], Graph)])
-> Graph
-> ([Indicator], Graph)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Partition] -> ([Indicator], Graph))
-> [[Partition]] -> [([Indicator], Graph)]
forall a b. (a -> b) -> [a] -> [b]
map [Partition] -> ([Indicator], Graph)
fct ([[Partition]] -> [([Indicator], Graph)])
-> (Graph -> [[Partition]]) -> Graph -> [([Indicator], Graph)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree Partition -> [[Partition]]
forall t. Tree t -> [[t]]
paths (Tree Partition -> [[Partition]])
-> (Graph -> Tree Partition) -> Graph -> [[Partition]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Partition -> Graph -> Tree Partition
partitionTree Partition
userPartition (Graph -> Graph) -> Graph -> Graph
forall a b. (a -> b) -> a -> b
$ Graph
gr
    where gr :: Graph
gr = [Vertex] -> [Vertex]
forall a. Ord a => [a] -> [a]
sort ([Vertex] -> [Vertex]) -> Graph -> Graph
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Graph
gr0
          fct :: [Partition] -> ([Indicator], Graph)
fct [Partition]
nu = (Graph -> [Partition] -> [Indicator]
lambda_ Graph
gr [Partition]
nu, Graph -> Partition -> Graph
relabel Graph
gr ([Partition] -> Partition
forall a. HasCallStack => [a] -> a
last [Partition]
nu))



------------------------------------
-- Nauty algorithm

forWhile :: Monad m => [a] -> m Bool -> (a -> m ()) -> m ()
forWhile :: forall (m :: * -> *) a.
Monad m =>
[a] -> m Bool -> (a -> m ()) -> m ()
forWhile []     m Bool
_    a -> m ()
_      = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
forWhile (a
v:[a]
vs) m Bool
cond a -> m ()
action = a -> m ()
action a
v m () -> m Bool -> m Bool
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m Bool
cond m Bool -> (Bool -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
c -> Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
c ([a] -> m Bool -> (a -> m ()) -> m ()
forall (m :: * -> *) a.
Monad m =>
[a] -> m Bool -> (a -> m ()) -> m ()
forWhile [a]
vs m Bool
cond a -> m ()
action)

firstNoCommon :: (Eq a) => [a] -> [a] -> Maybe a
firstNoCommon :: forall a. Eq a => [a] -> [a] -> Maybe a
firstNoCommon [a]
_ [] = Maybe a
forall a. Maybe a
Nothing
firstNoCommon [] (a
v:[a]
_) = a -> Maybe a
forall a. a -> Maybe a
Just a
v
firstNoCommon (a
v1:[a]
v1s) (a
v2:[a]
v2s)
    | a
v1 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
v2 = [a] -> [a] -> Maybe a
forall a. Eq a => [a] -> [a] -> Maybe a
firstNoCommon [a]
v1s [a]
v2s
    | Bool
otherwise = a -> Maybe a
forall a. a -> Maybe a
Just a
v2

maybeElem :: (Eq t) => Maybe t -> [t] -> Bool
maybeElem :: forall t. Eq t => Maybe t -> [t] -> Bool
maybeElem Maybe t
Nothing [t]
_  = Bool
True
maybeElem (Just t
v) [t]
l = t
v t -> [t] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [t]
l

-- tells if l1 is included in l2
included :: Eq a => [a] -> [a] -> Bool
[a]
l1 included :: forall a. Eq a => [a] -> [a] -> Bool
`included` [a]
l2 = (a -> Bool) -> [a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (a -> [a] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [a]
l2) [a]
l1

leftMostNode :: Graph -> Partition -> (Partition, [Indicator], [Vertex])
leftMostNode :: Graph -> Partition -> (Partition, [Indicator], [Vertex])
leftMostNode Graph
gr Partition
pi1 = case Graph -> Partition -> [(Vertex, Partition)]
childPartitions Graph
gr Partition
pi1 of
    ((Vertex
v1, Partition
pi2):[(Vertex, Partition)]
_) -> let (Partition
nu, [Indicator]
ls, [Vertex]
path) = Graph -> Partition -> (Partition, [Indicator], [Vertex])
leftMostNode Graph
gr Partition
pi2
                         in (Partition
nu, Graph -> Partition -> Indicator
lambda Graph
gr Partition
pi1 Indicator -> [Indicator] -> [Indicator]
forall a. a -> [a] -> [a]
: [Indicator]
ls, Vertex
v1 Vertex -> [Vertex] -> [Vertex]
forall a. a -> [a] -> [a]
: [Vertex]
path)
    [] -> (Partition
pi1, [Graph -> Partition -> Indicator
lambda Graph
gr Partition
pi1], [])


-- nu = current node
-- zeta = 1st terminal node
-- rho = best guess at the node leading to canonical labelling
-- Lambda = indicator function for a node (usually written xLambda)
-- theta = orbit partiton of the automorphism group found yet
-- gamma = automorphism found
-- psi = store for automorphisms (gamma) found, in the form of (fix gamma, mcr gamma)

-- returns the graph relabelled, canonically. See McKay for details.
nauty :: Partition -> Graph -> ST s ([Permutation], Graph)
nauty :: forall s. Partition -> Graph -> ST s ([Permutation], Graph)
nauty Partition
userPartition Graph
gr0 =
    do {
       ;let gr :: Graph
gr = [Vertex] -> [Vertex]
forall a. Ord a => [a] -> [a]
sort ([Vertex] -> [Vertex]) -> Graph -> Graph
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Graph
gr0
       ;let graphBounds :: (Vertex, Vertex)
graphBounds = Graph -> (Vertex, Vertex)
forall i e. Array i e -> (i, i)
bounds Graph
gr
       ;let relabeling :: Partition -> Partition -> Permutation
relabeling Partition
p1 Partition
p2 = (Vertex, Vertex) -> [Vertex] -> [Vertex] -> Permutation
permBetween (Vertex, Vertex)
graphBounds (([Vertex] -> Vertex) -> Partition -> [Vertex]
forall a b. (a -> b) -> [a] -> [b]
map [Vertex] -> Vertex
forall a. HasCallStack => [a] -> a
head Partition
p1) (([Vertex] -> Vertex) -> Partition -> [Vertex]
forall a b. (a -> b) -> [a] -> [b]
map [Vertex] -> Vertex
forall a. HasCallStack => [a] -> a
head Partition
p2)
       -- return the relabelling defined by the mapping between two discrete partitions
       ;STRef s (Permutation, [Vertex])
thetaRef <- (Permutation, [Vertex]) -> ST s (STRef s (Permutation, [Vertex]))
forall a s. a -> ST s (STRef s a)
newSTRef ((Vertex, Vertex) -> [Vertex] -> Permutation
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Vertex, Vertex)
graphBounds ((Vertex, Vertex) -> [Vertex]
forall a. Ix a => (a, a) -> [a]
range (Vertex, Vertex)
graphBounds), (Vertex, Vertex) -> [Vertex]
forall a. Ix a => (a, a) -> [a]
range (Vertex, Vertex)
graphBounds)
       ;let root :: Partition
root = Partition -> Graph -> Partition
initialPartition Partition
userPartition Graph
gr
       ;let (Partition
zeta, [Indicator]
zetaLambda, [Vertex]
zetaPath) = Graph -> Partition -> (Partition, [Indicator], [Vertex])
leftMostNode Graph
gr Partition
root
       ;let grZeta :: Graph
grZeta = Graph -> Partition -> Graph
relabel Graph
gr Partition
zeta
       ;STRef s (Partition, [Indicator], Graph)
rhoRef <- (Partition, [Indicator], Graph)
-> ST s (STRef s (Partition, [Indicator], Graph))
forall a s. a -> ST s (STRef s a)
newSTRef (Partition
zeta, [Indicator]
zetaLambda, Graph
grZeta)
       ;STRef s [Permutation]
psi <- [Permutation] -> ST s (STRef s [Permutation])
forall a s. a -> ST s (STRef s a)
newSTRef []
       ;let
        {
--       exploreNode :: Partition -> [Vertex] -> [Indicator] -> ST s ();
         exploreNode :: Partition -> [Vertex] -> [Indicator] -> ST s ()
exploreNode Partition
nu [Vertex]
nuPath [Indicator]
nuLambda =
         do {
            ;let
            {foundTerminalNode :: ST s ()
foundTerminalNode =
             do {
                ;let grNu :: Graph
grNu = Graph -> Partition -> Graph
relabel Graph
gr Partition
nu
                ;(if ([Indicator]
nuLambda, Graph
grNu) ([Indicator], Graph) -> ([Indicator], Graph) -> Bool
forall a. Eq a => a -> a -> Bool
== ([Indicator]
zetaLambda, Graph
grZeta)
                  then Permutation -> ST s ()
foundAutomorphism (Partition -> Partition -> Permutation
relabeling Partition
zeta Partition
nu)
                  else do
                        {
                         (Partition
rho, [Indicator]
rhoLambda, Graph
grRho) <- STRef s (Partition, [Indicator], Graph)
-> ST s (Partition, [Indicator], Graph)
forall s a. STRef s a -> ST s a
readSTRef STRef s (Partition, [Indicator], Graph)
rhoRef
                        ;case ([Indicator], Graph) -> ([Indicator], Graph) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ([Indicator]
nuLambda, Graph
grNu) ([Indicator]
rhoLambda, Graph
grRho) of
                           {
                            Ordering
LT -> STRef s (Partition, [Indicator], Graph)
-> (Partition, [Indicator], Graph) -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s (Partition, [Indicator], Graph)
rhoRef (Partition
nu, [Indicator]
nuLambda, Graph
grNu); -- "better" solution found
                            Ordering
EQ -> Permutation -> ST s ()
foundAutomorphism (Partition -> Partition -> Permutation
relabeling Partition
rho Partition
nu); -- no better, but use automorphism
                            Ordering
GT -> () -> ST s ()
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return (); -- no luck
                           }
                        }
                 )
                };

             foundAutomorphism :: Permutation -> ST s ()
foundAutomorphism Permutation
gamma =
             do {
                 -- update psi
                ; STRef s [Permutation]
-> ([Permutation] -> [Permutation]) -> ST s ()
forall s a. STRef s a -> (a -> a) -> ST s ()
modifySTRef STRef s [Permutation]
psi (Permutation
gammaPermutation -> [Permutation] -> [Permutation]
forall a. a -> [a] -> [a]
:)
                 -- update theta
                ;(Permutation
thetaOld, [Vertex]
_) <- STRef s (Permutation, [Vertex]) -> ST s (Permutation, [Vertex])
forall s a. STRef s a -> ST s a
readSTRef STRef s (Permutation, [Vertex])
thetaRef
                ;let theta :: Permutation
theta = Permutation -> Permutation -> Permutation
mergePerms Permutation
gamma Permutation
thetaOld
                ;STRef s (Permutation, [Vertex])
-> (Permutation, [Vertex]) -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s (Permutation, [Vertex])
thetaRef (Permutation
theta, Partition -> [Vertex]
mcr (Partition -> [Vertex]) -> Partition -> [Vertex]
forall a b. (a -> b) -> a -> b
$ Permutation -> Partition
orbitsFromPerm Permutation
theta)
                };

--           exploreSubnode :: (Vertex, Partition) -> ST s ();
             exploreSubnode :: (Vertex, Partition) -> ST s ()
exploreSubnode (Vertex
v, Partition
pie) =
             do {
                ;[Permutation]
automs <- STRef s [Permutation] -> ST s [Permutation]
forall s a. STRef s a -> ST s a
readSTRef STRef s [Permutation]
psi
                -- pruning is explained on pages 60-61.
                ;let fixingAutomsMcrs :: Partition
fixingAutomsMcrs = [Partition -> [Vertex]
mcr (Permutation -> Partition
orbitsFromPerm Permutation
gamma) |
                                         Permutation
gamma <- Vertex -> [Permutation] -> [Permutation]
forall a. Vertex -> [a] -> [a]
drop Vertex
1 [Permutation]
automs, [Vertex]
nuPath [Vertex] -> [Vertex] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`included` Permutation -> [Vertex]
fixed Permutation
gamma]
                                        -- drop the 1st automorphism because it is always identity
                ;Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Vertex
v Vertex -> [Vertex] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`) ([Vertex] -> Bool) -> Partition -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
`all` Partition
fixingAutomsMcrs)
                          (Partition -> [Vertex] -> [Indicator] -> ST s ()
exploreNode Partition
pie ([Vertex]
nuPath [Vertex] -> [Vertex] -> [Vertex]
forall a. [a] -> [a] -> [a]
++ [Vertex
v]) ([Indicator]
nuLambda [Indicator] -> [Indicator] -> [Indicator]
forall a. [a] -> [a] -> [a]
++ [Graph -> Partition -> Indicator
lambda Graph
gr Partition
pie]))
                };

             test1 :: ST s Bool
test1 =
             do {
                ;(Permutation
_, [Vertex]
mcrTheta) <- STRef s (Permutation, [Vertex]) -> ST s (Permutation, [Vertex])
forall s a. STRef s a -> ST s a
readSTRef STRef s (Permutation, [Vertex])
thetaRef
                ;Bool -> ST s Bool
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Vertex -> [Vertex] -> Bool
forall t. Eq t => Maybe t -> [t] -> Bool
maybeElem ([Vertex] -> [Vertex] -> Maybe Vertex
forall a. Eq a => [a] -> [a] -> Maybe a
firstNoCommon [Vertex]
zetaPath [Vertex]
nuPath) [Vertex]
mcrTheta)
                };

            };
            ;(Partition
_, [Indicator]
rhoLambda, Graph
_) <- STRef s (Partition, [Indicator], Graph)
-> ST s (Partition, [Indicator], Graph)
forall s a. STRef s a -> ST s a
readSTRef STRef s (Partition, [Indicator], Graph)
rhoRef
            ;Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Indicator]
nuLambda [Indicator] -> [Indicator] -> Bool
forall a. Ord a => a -> a -> Bool
<= [Indicator]
rhoLambda Bool -> Bool -> Bool
|| ([Indicator]
nuLambda [Indicator] -> [Indicator] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [Indicator]
zetaLambda)) (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$ do
              {
              ;let childNodes :: [(Vertex, Partition)]
childNodes = Graph -> Partition -> [(Vertex, Partition)]
childPartitions Graph
gr Partition
nu
              ;(if [(Vertex, Partition)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Vertex, Partition)]
childNodes
                then ST s ()
foundTerminalNode
                else [(Vertex, Partition)]
-> ST s Bool -> ((Vertex, Partition) -> ST s ()) -> ST s ()
forall (m :: * -> *) a.
Monad m =>
[a] -> m Bool -> (a -> m ()) -> m ()
forWhile [(Vertex, Partition)]
childNodes ST s Bool
test1 (Vertex, Partition) -> ST s ()
exploreSubnode)
              }
            };
        };
       ;Partition -> [Vertex] -> [Indicator] -> ST s ()
exploreNode Partition
root [] [Graph -> Partition -> Indicator
lambda Graph
gr Partition
root]
       ;[Permutation]
autG <- STRef s [Permutation] -> ST s [Permutation]
forall s a. STRef s a -> ST s a
readSTRef STRef s [Permutation]
psi
       ;(Partition
_,[Indicator]
_,Graph
canonicGr) <- STRef s (Partition, [Indicator], Graph)
-> ST s (Partition, [Indicator], Graph)
forall s a. STRef s a -> ST s a
readSTRef STRef s (Partition, [Indicator], Graph)
rhoRef
       ;([Permutation], Graph) -> ST s ([Permutation], Graph)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Permutation]
autG, Graph
canonicGr)
       }



-- | Given a graph, return generators of its automorphism group, and its canonic labeling
automorphisms :: Partition -> Graph -> ([Permutation], Graph)
automorphisms :: Partition -> Graph -> ([Permutation], Graph)
automorphisms Partition
userPartition Graph
graph = (forall s. ST s ([Permutation], Graph)) -> ([Permutation], Graph)
forall a. (forall s. ST s a) -> a
runST (Partition -> Graph -> ST s ([Permutation], Graph)
forall s. Partition -> Graph -> ST s ([Permutation], Graph)
nauty Partition
userPartition Graph
graph)

-- | Return the canonic version of a graph.
canonicGraph :: Partition -> Graph -> Graph
canonicGraph :: Partition -> Graph -> Graph
canonicGraph Partition
p Graph
gr = ([Permutation], Graph) -> Graph
forall a b. (a, b) -> b
snd (([Permutation], Graph) -> Graph)
-> ([Permutation], Graph) -> Graph
forall a b. (a -> b) -> a -> b
$ Partition -> Graph -> ([Permutation], Graph)
automorphisms Partition
p Graph
gr

-- | Tells whether two graphs are isomorphic
isIsomorphic :: Graph -> Graph -> Bool
isIsomorphic :: Graph -> Graph -> Bool
isIsomorphic Graph
g1 Graph
g2 = Graph -> (Vertex, Vertex)
forall i e. Array i e -> (i, i)
bounds Graph
g1 (Vertex, Vertex) -> (Vertex, Vertex) -> Bool
forall a. Eq a => a -> a -> Bool
== Graph -> (Vertex, Vertex)
forall i e. Array i e -> (i, i)
bounds Graph
g2 Bool -> Bool -> Bool
&& Partition -> Graph -> Graph
canonicGraph Partition
p Graph
g1 Graph -> Graph -> Bool
forall a. Eq a => a -> a -> Bool
== Partition -> Graph -> Graph
canonicGraph Partition
p Graph
g2
    where p :: Partition
p = (Vertex, Vertex) -> Partition
unitPartition (Graph -> (Vertex, Vertex)
forall i e. Array i e -> (i, i)
bounds Graph
g1)
          

-- | Returns generators of the automorphism group
autGenerators :: Partition -> Graph -> [Permutation]
autGenerators :: Partition -> Graph -> [Permutation]
autGenerators Partition
userPartition Graph
gr = ([Permutation], Graph) -> [Permutation]
forall a b. (a, b) -> a
fst (([Permutation], Graph) -> [Permutation])
-> ([Permutation], Graph) -> [Permutation]
forall a b. (a -> b) -> a -> b
$ Partition -> Graph -> ([Permutation], Graph)
automorphisms Partition
userPartition Graph
gr

withUnitPartition
  :: (Partition -> Array Vertex e -> t)
  -> Array Vertex e
  -> t
withUnitPartition :: forall e t.
(Partition -> Array Vertex e -> t) -> Array Vertex e -> t
withUnitPartition Partition -> Array Vertex e -> t
f Array Vertex e
gr = Partition -> Array Vertex e -> t
f ((Vertex, Vertex) -> Partition
unitPartition ((Vertex, Vertex) -> Partition) -> (Vertex, Vertex) -> Partition
forall a b. (a -> b) -> a -> b
$ Array Vertex e -> (Vertex, Vertex)
forall i e. Array i e -> (i, i)
bounds Array Vertex e
gr) Array Vertex e
gr