module Data.Graph.Automorphism(canonicGraph, canonicGraph0, autGenerators,
automorphisms, isIsomorphic, debugTree) where
import Data.Graph(Graph, Vertex)
import Data.Array
import Data.List (sort, isPrefixOf)
import Control.Monad.State
import Control.Monad.ST
import Data.Graph.Partition
import Data.Graph.Permutation
import Data.STRef
import Data.Tree
relabel :: Graph -> Partition -> Graph
relabel gr partition = applyPerm simplePermutation gr
where simplePermutation = array bnds (zip (map head partition) (range bnds))
bnds = bounds gr
initialPartition :: Graph -> Partition
initialPartition gr = refine gr pie pie
where pie = unitPartition $ bounds gr
splitPartition :: Partition -> [(Vertex, Partition)]
splitPartition [] = []
splitPartition (c1:cs1) =
if isSingleton c1
then [(v, c1:cs2) | (v,cs2) <- splitPartition cs1]
else [(v, c2:[v]:cs1) | (v, c2) <- splitCell c1]
splitCell :: Cell -> [(Vertex, Cell)]
splitCell [] = []
splitCell (v:c) = (v, c) : [(v2, v:c2) | (v2, c2) <- splitCell c]
childPartitions :: Graph -> Partition -> [(Vertex, Partition)]
childPartitions gr part =
[(n, refine gr p [[n]]) | (n,p) <- (splitPartition part)]
partitionTree :: Graph -> Tree Partition
partitionTree gr = tree (initialPartition gr)
where tree p = Node p (map (tree . snd) (childPartitions gr p))
annotateTree :: (a -> b) -> Tree a -> Tree (a,b)
annotateTree f = fmap f'
where f' x = (x, f x)
debugTree :: Graph -> IO ()
debugTree gr = putStrLn $ drawTree $ fmap show $ annotateTree (lambda gr) $ partitionTree gr
paths :: Tree t -> [[t]]
paths (Node x []) = [[x]]
paths (Node x cs) = map (x:) (concatMap paths cs)
canonicGraph0 :: Graph -> Graph
canonicGraph0 gr0 = snd . minimum . map fct . paths . partitionTree $ gr
where gr = fmap sort $ gr0
fct nu = (lambda_ gr nu, relabel gr (last nu))
forWhile :: Monad m => [a] -> m Bool -> (a -> m ()) -> m ()
forWhile [] _ _ = return ()
forWhile (v:vs) cond action = action v >> cond >>= \c -> when c (forWhile vs cond action)
firstNoCommon :: (Eq a) => [a] -> [a] -> Maybe a
firstNoCommon _ [] = Nothing
firstNoCommon [] (v:_) = Just v
firstNoCommon (v1:v1s) (v2:v2s)
| v1 == v2 = firstNoCommon v1s v2s
| otherwise = Just v2
maybeElem :: (Eq t) => Maybe t -> [t] -> Bool
maybeElem Nothing _ = True
maybeElem (Just v) l = v `elem` l
included :: Eq a => [a] -> [a] -> Bool
l1 `included` l2 = all (`elem` l2) l1
leftMostNode :: Graph -> Partition -> (Partition, [Indicator], [Vertex])
leftMostNode gr pi1 = case childPartitions gr pi1 of
((v1, pi2):_) -> let (nu, ls, path) = leftMostNode gr pi2
in (nu, lambda gr pi1 : ls, v1 : path)
[] -> (pi1, [lambda gr pi1], [])
nauty :: Graph -> ST s ([Permutation], Graph)
nauty gr0 =
do {
;let gr = fmap sort $ gr0
;let graphBounds = bounds gr
;let relabeling p1 p2 = permBetween graphBounds (map head p1) (map head p2)
;thetaRef <- newSTRef (listArray graphBounds (range graphBounds), range graphBounds)
;let root = initialPartition gr
;let (zeta, zetaLambda, zetaPath) = leftMostNode gr root
;let grZeta = relabel gr zeta
;rhoRef <- newSTRef (zeta, zetaLambda, grZeta)
;psi <- newSTRef []
;let
{
exploreNode nu nuPath nuLambda =
do {
;let
{foundTerminalNode =
do {
;let grNu = relabel gr nu
;(if (nuLambda, grNu) == (zetaLambda, grZeta)
then foundAutomorphism (relabeling zeta nu)
else do
{
(rho, rhoLambda, grRho) <- readSTRef rhoRef
;case compare (nuLambda, grNu) (rhoLambda, grRho) of
{
LT -> writeSTRef rhoRef (nu, nuLambda, grNu);
EQ -> foundAutomorphism (relabeling rho nu);
GT -> return ();
}
}
)
};
foundAutomorphism gamma =
do {
; modifySTRef psi (gamma:)
;(thetaOld, _) <- readSTRef thetaRef
;let theta = mergePerms gamma thetaOld
;writeSTRef thetaRef (theta, mcr $ orbitsFromPerm theta)
};
exploreSubnode (v, pie) =
do {
;automs <- readSTRef psi
;let fixingAutomsMcrs = [mcr (orbitsFromPerm gamma) |
gamma <- drop 1 automs, nuPath `included` fixed gamma]
;when ((v `elem`) `all` fixingAutomsMcrs)
(exploreNode pie (nuPath ++ [v]) (nuLambda ++ [lambda gr pie]))
};
test1 =
do {
;(_, mcrTheta) <- readSTRef thetaRef
;return (maybeElem (firstNoCommon zetaPath nuPath) mcrTheta)
};
};
;(_, rhoLambda, _) <- readSTRef rhoRef
;when (nuLambda <= rhoLambda || (nuLambda `isPrefixOf` zetaLambda)) $ do
{
;let childNodes = childPartitions gr nu
;(if null childNodes
then foundTerminalNode
else forWhile childNodes test1 exploreSubnode)
}
};
};
;exploreNode root [] [lambda gr root]
;autG <- readSTRef psi
;(_,_,canonicGr) <- readSTRef rhoRef
;return (autG, canonicGr)
}
automorphisms :: Graph -> ([Permutation], Graph)
automorphisms graph = runST (nauty graph)
canonicGraph :: Graph -> Graph
canonicGraph = snd . automorphisms
isIsomorphic :: Graph -> Graph -> Bool
isIsomorphic g1 g2 = canonicGraph g1 == canonicGraph g2
autGenerators :: Graph -> [Permutation]
autGenerators = fst . automorphisms