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.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 :: Partition -> Graph -> Partition
initialPartition pie gr = refine gr (unitPartition $ bounds gr) pie
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 :: Partition -> Graph -> Tree Partition
partitionTree userPartition gr = tree (initialPartition userPartition 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 :: Partition -> Graph -> IO ()
debugTree userPartition gr = putStrLn $ drawTree $ fmap show $ annotateTree (lambda gr) $ partitionTree userPartition gr
paths :: Tree t -> [[t]]
paths (Node x []) = [[x]]
paths (Node x cs) = map (x:) (concatMap paths cs)
canonicGraph0 :: Partition -> Graph -> Graph
canonicGraph0 userPartition gr0 = snd . minimum . map fct . paths . partitionTree userPartition $ 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 :: Partition -> Graph -> ST s ([Permutation], Graph)
nauty userPartition 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 userPartition 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 :: Partition -> Graph -> ([Permutation], Graph)
automorphisms userPartition graph = runST (nauty userPartition graph)
canonicGraph :: Partition -> Graph -> Graph
canonicGraph p gr = snd $ automorphisms p gr
isIsomorphic :: Graph -> Graph -> Bool
isIsomorphic g1 g2 = bounds g1 == bounds g2 && canonicGraph p g1 == canonicGraph p g2
where p = unitPartition (bounds g1)
autGenerators :: Partition -> Graph -> [Permutation]
autGenerators userPartition gr = fst $ automorphisms userPartition gr
withUnitPartition f gr = f (unitPartition $ bounds gr) gr