{-| Module : Data.Graph.Automorphism Copyright : (c) Jean-Philippe Bernardy 2003 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) 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 a graph, given a discrete partition relabel :: Graph -> Partition -> Graph relabel gr partition = applyPerm simplePermutation gr where simplePermutation = array bnds (zip (map head partition) (range bnds)) bnds = bounds gr ----------------------------------------------- -- The following manages the nests of partitions initialPartition :: Graph -> Partition initialPartition gr = refine gr pi pi where pi = unitPartition (bounds gr) discretePartition :: Graph -> Partition discretePartition gr = map (: []) (range $ bounds gr) splittingCell :: Partition -> Cell splittingCell = head . filter (not . isSingleton) 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 [x,y,z] = [(x,[y,z]), (y,[x,z]), (z, [x,y])] 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 gr = putStrLn $ drawTree $ fmap show $ annotateTree (lambda gr) $ partitionTree gr ----------------------------------------- -- Simple version of the Nauty algorithm -- (No use of automorphism information) -- | All paths from root to leaves paths (Node x []) = [[x]] paths (Node x cs) = map (x:) (concatMap paths cs) -- | Returns a canonic labeling of the graph (slow -- but dead simple implementation). -- This implementation serves documentation and debugging purposes. 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)) ------------------------------------ -- Nauty algorithm 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 _ [] = Nothing firstNoCommon [] (v:_) = Just v firstNoCommon (v1:v1s) (v2:v2s) | v1 == v2 = firstNoCommon v1s v2s | otherwise = Just v2 maybeElem Nothing l = True maybeElem (Just v) l = v `elem` l -- tells if l1 is included in l2 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], []) -- 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 :: 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) -- return the relabelling defined by the mapping between two discrete partitions ;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 :: Partition -> [Vertex] -> [Indicator] -> ST s (); 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); -- "better" solution found EQ -> foundAutomorphism (relabeling rho nu); -- no better, but use automorphism GT -> return (); -- no luck } } ) }; foundAutomorphism gamma = do { -- update psi ; modifySTRef psi (gamma:) -- update theta ;(thetaOld, _) <- readSTRef thetaRef ;let theta = mergePerms gamma thetaOld ;writeSTRef thetaRef (theta, mcr $ orbitsFromPerm theta) }; -- exploreSubnode :: (Vertex, Partition) -> ST s (); exploreSubnode (v, pi) = do { ;automs <- readSTRef psi -- pruning is explained on pages 60-61. ;let fixingAutomsMcrs = [mcr (orbitsFromPerm gamma) | gamma <- drop 1 automs, nuPath `included` fixed gamma] -- drop the 1st automorphism because it is always identity ;when ((v `elem`) `all` fixingAutomsMcrs) (exploreNode pi (nuPath ++ [v]) (nuLambda ++ [lambda gr pi])) }; 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) } -- | Given a graph, return generators of its automorphism group, and its canonic labeling automorphisms :: Graph -> ([Permutation], Graph) automorphisms graph = runST (nauty graph) -- | Return the canonic version of a graph. canonicGraph :: Graph -> Graph canonicGraph = snd . automorphisms -- | Tells whether two graphs are isomorphic isIsomorphic :: Graph -> Graph -> Bool isIsomorphic g1 g2 = canonicGraph g1 == canonicGraph g2 -- | Returns generators of the automorphism group autGenerators :: Graph -> [Permutation] autGenerators = fst . automorphisms