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

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


    Implementation of equitable partitioning of graphs + indicator function.

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

-}
{-# OPTIONS_GHC -Wwarn=incomplete-uni-patterns #-}
module Data.Graph.Partition(Cell, Partition, refine, isSingleton,
                            unitPartition, isDiscrete, mcr,
                            Indicator, lambda, lambda_, fixedInOrbits) where

import Data.Graph
import Data.List
import Data.Array((!), range, bounds)
import Data.Int
import Data.Bits
import qualified Data.Map as Map

-- | A cell is represented by its list of vertices,
-- with the invariant that the list is sorted
type Cell = [Vertex]

-- | A partition is its list of cells
type Partition = [Cell]

-- Tells whether a list has a single element.
isSingleton :: [a] -> Bool
isSingleton :: forall a. [a] -> Bool
isSingleton [a
_] = Bool
True
isSingleton [a]
_ = Bool
False

-- | The unit partition of a range.
unitPartition :: (Vertex, Vertex) -> Partition
unitPartition :: (Vertex, Vertex) -> Partition
unitPartition (Vertex, Vertex)
bnds = [(Vertex, Vertex) -> [Vertex]
forall a. Ix a => (a, a) -> [a]
range (Vertex, Vertex)
bnds]

-- | Is the partition discrete ?
isDiscrete :: Partition -> Bool
isDiscrete :: Partition -> Bool
isDiscrete = ([Vertex] -> Bool) -> Partition -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all [Vertex] -> Bool
forall a. [a] -> Bool
isSingleton

-- | Refines a Partition wrt to another Partition, given a graph.
-- (explained on pages 50-52)
-- This is equivalent to partition the graph's DFA in equivalent states.
-- @refine gr p q@ refines @p@ wrt. @q@ in @gr@.
refine :: Graph -> Partition -> Partition -> Partition
refine :: Graph -> Partition -> Partition -> Partition
refine Graph
_  Partition
p [] = Partition
p
refine Graph
gr Partition
p ([Vertex]
w:Partition
ws) = Graph -> Partition -> Partition -> Partition
refine Graph
gr Partition
p' Partition
alpha
  where (Partition
p', Partition
alpha) = Partition -> Partition -> (Partition, Partition)
refineCells Partition
p Partition
ws

        refineCells :: Partition -> Partition -> (Partition, Partition)
refineCells [] Partition
q = ([], Partition
q)
        refineCells ([Vertex]
c:Partition
cs) Partition
q = (Partition
rc Partition -> Partition -> Partition
forall a. [a] -> [a] -> [a]
++ Partition
rcs, Partition
xxq)
          where (Partition
rc, Partition
xq) = [Vertex] -> Partition -> (Partition, Partition)
refineCell [Vertex]
c Partition
q
                (Partition
rcs, Partition
xxq) = Partition -> Partition -> (Partition, Partition)
refineCells Partition
cs Partition
xq

        refineCell :: Cell -> [Cell] -> (Partition, [Cell])
        refineCell :: [Vertex] -> Partition -> (Partition, Partition)
refineCell [Vertex
v] Partition
alph = ([[Vertex
v]], Partition
alph)
        refineCell [Vertex]
c Partition
alph
         | Partition -> Bool
forall a. [a] -> Bool
isSingleton Partition
xs = ([[Vertex]
c], Partition
alph)
         | Bool
otherwise = (Partition
xs, Partition
alph' Partition -> Partition -> Partition
forall a. [a] -> [a] -> [a]
++ Partition
smallXs)
          where
                xs :: Partition
xs = [Vertex] -> [Vertex] -> Partition
refineCellByOneCell [Vertex]
c [Vertex]
w
                alph' :: Partition
alph' = ([Vertex] -> Bool) -> [Vertex] -> Partition -> Partition
forall a. (a -> Bool) -> a -> [a] -> [a]
replace ([Vertex]
c [Vertex] -> [Vertex] -> Bool
forall a. Eq a => a -> a -> Bool
==) [Vertex]
largeXt Partition
alph
                ([Vertex]
largeXt, Partition
smallXs) = Partition -> ([Vertex], Partition)
forall a. [[a]] -> ([a], [[a]])
extractLargest Partition
xs

        -- splits a cell in groups of equal degrees with respect to another cell.
        refineCellByOneCell :: Cell -> Cell -> Partition
        refineCellByOneCell :: [Vertex] -> [Vertex] -> Partition
refineCellByOneCell [Vertex]
refinedCell [Vertex]
referenceCell =
          (Vertex -> Vertex) -> [Vertex] -> Partition
forall k a. Ord k => (a -> k) -> [a] -> [[a]]
groupSortBy (Graph -> [Vertex] -> Vertex -> Vertex
degreeCellVertex Graph
gr [Vertex]
referenceCell) [Vertex]
refinedCell

replace :: (a->Bool) -> a -> [a] -> [a]
replace :: forall a. (a -> Bool) -> a -> [a] -> [a]
replace a -> Bool
_ a
_   [] = []
replace a -> Bool
f a
rep (a
l:[a]
ls)
  | a -> Bool
f a
l = a
repa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ls
  | Bool
otherwise = a
la -> [a] -> [a]
forall a. a -> [a] -> [a]
:(a -> Bool) -> a -> [a] -> [a]
forall a. (a -> Bool) -> a -> [a] -> [a]
replace a -> Bool
f a
rep [a]
ls

-- TODO: try if the below is faster.
-- replace f a = map (\x -> if f x then a else x)

extractLargest :: [[a]] -> ([a], [[a]])
extractLargest :: forall a. [[a]] -> ([a], [[a]])
extractLargest [[a]]
list = ([a]
largest, [[a]]
before [[a]] -> [[a]] -> [[a]]
forall a. [a] -> [a] -> [a]
++ [[a]]
after)
  where ([[a]]
before, [a]
largest:[[a]]
after) = ([a] -> Bool) -> [[a]] -> ([[a]], [[a]])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break [a] -> Bool
forall {t :: * -> *} {a}. Foldable t => t a -> Bool
hasMaxLength [[a]]
list
        hasMaxLength :: t a -> Bool
hasMaxLength t a
el = t a -> Vertex
forall a. t a -> Vertex
forall (t :: * -> *) a. Foldable t => t a -> Vertex
length t a
el Vertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
== Vertex
maxLength
        maxLength :: Vertex
maxLength = [Vertex] -> Vertex
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Vertex] -> Vertex) -> [Vertex] -> Vertex
forall a b. (a -> b) -> a -> b
$ ([a] -> Vertex) -> [[a]] -> [Vertex]
forall a b. (a -> b) -> [a] -> [b]
map [a] -> Vertex
forall a. [a] -> Vertex
forall (t :: * -> *) a. Foldable t => t a -> Vertex
length [[a]]
list

groupSortBy :: Ord k => (a -> k) -> [a] -> [[a]]

--groupSortBy key list = map (map snd) $ groupBy fstEq $ sortBy fstComp $ [(key v, v) | v <- list]
--    where fstComp x y = compare (fst x) (fst y)
--        fstEq x y = fst x == fst y

groupSortBy :: forall k a. Ord k => (a -> k) -> [a] -> [[a]]
groupSortBy a -> k
f [a]
list = ((k, [a]) -> [a]) -> [(k, [a])] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map (k, [a]) -> [a]
forall a b. (a, b) -> b
snd ([(k, [a])] -> [[a]]) -> [(k, [a])] -> [[a]]
forall a b. (a -> b) -> a -> b
$ Map k [a] -> [(k, [a])]
forall k a. Map k a -> [(k, a)]
Map.toList (Map k [a] -> [(k, [a])]) -> Map k [a] -> [(k, [a])]
forall a b. (a -> b) -> a -> b
$ ([a] -> [a] -> [a]) -> [(k, [a])] -> Map k [a]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++) [(a -> k
f a
v, [a
v]) | a
v <- [a]
list]
-- TODO: for some reason replacing map snd $ Map.toList by Map.elems makes the program slower. Investigate.

mcr :: Partition -> [Vertex]
mcr :: Partition -> [Vertex]
mcr = ([Vertex] -> Vertex) -> Partition -> [Vertex]
forall a b. (a -> b) -> [a] -> [b]
map [Vertex] -> Vertex
forall a. HasCallStack => [a] -> a
head

-- | Returns vertices fixes in the given orbits
fixedInOrbits :: Partition -> [Vertex]
fixedInOrbits :: Partition -> [Vertex]
fixedInOrbits Partition
part = ([Vertex] -> Vertex) -> Partition -> [Vertex]
forall a b. (a -> b) -> [a] -> [b]
map [Vertex] -> Vertex
forall a. HasCallStack => [a] -> a
head (Partition -> [Vertex]) -> Partition -> [Vertex]
forall a b. (a -> b) -> a -> b
$ ([Vertex] -> Bool) -> Partition -> Partition
forall a. (a -> Bool) -> [a] -> [a]
filter [Vertex] -> Bool
forall a. [a] -> Bool
isSingleton Partition
part

isNeighbour :: Graph -> Vertex -> Vertex -> Bool
isNeighbour :: Graph -> Vertex -> Vertex -> Bool
isNeighbour Graph
gr Vertex
n1 Vertex
n2 = Vertex
n2 Vertex -> [Vertex] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (Graph
grGraph -> Vertex -> [Vertex]
forall i e. Ix i => Array i e -> i -> e
!Vertex
n1)

-- TODO: try to keep graph sorted and use the below instead of elem.
-- elemInSorted :: Ord a => a -> [a] -> Bool
-- elemInSorted _ [] = False
-- elemInSorted y (h:t) = case compare y h of
--                          LT -> elemInSorted y t
--                          EQ -> True
--                          GT -> False

-- | degree of a cell wrt a node
degreeCellVertex :: Graph -> Cell -> Vertex -> Int
degreeCellVertex :: Graph -> [Vertex] -> Vertex -> Vertex
degreeCellVertex Graph
gr [Vertex]
cell Vertex
vertex = (Vertex -> Bool) -> [Vertex] -> Vertex
forall {t :: * -> *} {b} {t}.
(Foldable t, Num b) =>
(t -> Bool) -> t t -> b
count (Graph -> Vertex -> Vertex -> Bool
isNeighbour Graph
gr Vertex
vertex) [Vertex]
cell
    where count :: (t -> Bool) -> t t -> b
count t -> Bool
p = (t -> b -> b) -> b -> t t -> b
forall a b. (a -> b -> b) -> b -> t a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\t
v->if t -> Bool
p t
v then (b -> b -> b
forall a. Num a => a -> a -> a
+b
1) else b -> b
forall a. a -> a
id) b
0




----------------------------------------
-- The indicator function


type Indicator = Int32

-- | An order-insensitive hash
oih :: [Indicator] -> Indicator
oih :: [Indicator] -> Indicator
oih = (Indicator -> Indicator -> Indicator)
-> Indicator -> [Indicator] -> Indicator
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Indicator -> Indicator -> Indicator
forall a. Bits a => a -> a -> a
xor Indicator
0

-- | An order-sensitive hash
osh :: [Indicator] -> Indicator
osh :: [Indicator] -> Indicator
osh = (Indicator -> Indicator -> Indicator)
-> Indicator -> [Indicator] -> Indicator
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Indicator
x Indicator
y -> Indicator
97 Indicator -> Indicator -> Indicator
forall a. Num a => a -> a -> a
* Indicator
y Indicator -> Indicator -> Indicator
forall a. Num a => a -> a -> a
+ Indicator
x Indicator -> Indicator -> Indicator
forall a. Num a => a -> a -> a
+ Indicator
1230497) Indicator
1

-- | An indicator function.
-- @lambda@ must be insensitive to automorphisms relabeling of the graph for the Automorphism module to work.
lambda :: Graph -> Partition -> Indicator
lambda :: Graph -> Partition -> Indicator
lambda Graph
gr Partition
nu
    = [Indicator] -> Indicator
osh [[Indicator] -> Indicator
oih ([Indicator] -> Indicator) -> [Indicator] -> Indicator
forall a b. (a -> b) -> a -> b
$ (Vertex -> Indicator) -> [Vertex] -> [Indicator]
forall a b. (a -> b) -> [a] -> [b]
map (Vertex -> Indicator
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Vertex -> Indicator) -> (Vertex -> Vertex) -> Vertex -> Indicator
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph -> [Vertex] -> Vertex -> Vertex
degreeCellVertex Graph
gr [Vertex]
c) ((Vertex, Vertex) -> [Vertex]
forall a. Ix a => (a, a) -> [a]
range ((Vertex, Vertex) -> [Vertex]) -> (Vertex, Vertex) -> [Vertex]
forall a b. (a -> b) -> a -> b
$ Graph -> (Vertex, Vertex)
forall i e. Array i e -> (i, i)
bounds Graph
gr) | [Vertex]
c <- Partition
nu]

-- prop_lambda gr pi gamma = lambda gr pi == lambda (applyPerm gamma gr) (applyPermPart gamma pi)
--  where gamma is an automorphism of gr

lambda_ :: Graph -> [Partition] -> [Indicator]
lambda_ :: Graph -> [Partition] -> [Indicator]
lambda_ Graph
gr = (Partition -> Indicator) -> [Partition] -> [Indicator]
forall a b. (a -> b) -> [a] -> [b]
map (Graph -> Partition -> Indicator
lambda Graph
gr)