# Equivalence under common permutations

I have lists which consists of sublists of equal length. The outer list is regarded as a multiset (that is, permutations of the sublists don't matter, but repetitions do), but the order in the sublists does matter, except that if the same permutation is applied to each of the sublists, it also doesn't matter.

Now my problem is that I want to write a function that tests whether two lists are equivalent under those rules. An obvious solution would of course be to generate all "inner" permutations for one set and seek the other one in there (the outer permutations can then, of course, be gotten rid of through sorting), but I feel there should be a simpler (and more efficient) solution. But I don't seem to be able to figure it out.

To make some concrete examples, I'd like to get e.g. the following results:

equiv[{{1,1,1,2},{1,1,2,2},{2,2,2,2}},
{{2,1,1,1},{2,1,2,1},{2,2,2,2}}] == True

because you get the second from the first by exchanging the first and the last element in each sublist. On the other hand,

equiv[{{1,1,1,2},{1,1,2,2},{2,2,2,2}},
{{2,1,1,1},{1,1,2,2},{2,2,2,2}}] == False

because there's no common permutation which transforms the first to the second. Of course I also want

equiv[{{1,1,1,2},{1,1,2,2},{2,2,2,2}},
{{1,1,2,2},{2,2,2,2},{1,1,1,2}}] == True

because here only the sublists are permuted in the outer list. And also,

equiv[{{1,1,1,2},{1,1,2,2},{2,2,2,2}},
{{2,1,2,1},{2,1,1,1},{2,2,2,2}}] == True

because this just combines a permutation of the sublists with a common permutation of the elements in each list.

So what is the best way to write this equiv function above?

-

Here is my take on it, but the code isn't really very small / simple.

## The algorithm

### Main algorithm

The algorithm goes as follows:

• Split both lists into equivalent classes under sorting of inner lists. For each of outer lists, we will obtain a nested list of groups, and within each group, sublists will be equivalent modulo permutations.
• Group together equivalent groups from the first and second lists. At this point, we get a nested list, where each sublist should be a list of 2 equivalent groups, one from the first list and one from the second.
• For each pair of equivalent groups (of inner sublists of original lists), find all permutations which would transform all elements (sublists) of the first group, into some elements of the second one, in a one-to-one manner. If there is no such, the search stops, and the result is that original lists are not equivalent.
• Go through the found transforming permutations, and see if there is at least one, which is present for all equivalent groups. If there is, then the answer is true, and the original lists are equivalent. if not, then the answer is false.

### Algorithm to find transforming permutation for the two equivalence groups (which may or may not be equivalent to each other)

Here is the one I use here:

• One of the main ingredient is a function

getAllSortingPermutations[lst1_, lst2_]

which finds a set of all permutations which convert lst2 to lst1. It is assumed that the lists lst1 and lst2 contain the same elements. Note that there can be more than one such permutation, if there are duplicate elements in lst1 (and therefore lst2)

• Take the two equivalent groups of sub-lists. They must be the same length - otherwise we can stop and say that the original lists are not equivalent.

• Construct a matrix, where each element is a set of permutations, each of which converts i-th sublist of group 1 into j-th sublist of group 2:

Outer[getAllSortingPermutations, fstGroup, secGroup, 1, 1]

• "Tag" each pair {i,j} in this matrix by every such converting permutation, for each matrix element. Make sure that the set of j-s has zero intersection with a set of i-s (we want to interpret them as a different vertex of a graph later) - this is done by adding Length[group1] to the index j. Collect all pairs tagged by a given permutation, for all permutations.

• Interpret each pair {i,j} as an edge in a (bipartite) graph. For each permutation, construct such graph from the collected edges.

• Find the maximal matching (independent edge set) for each such graph.

• Select only those permutations where the length of the edge list for maximal matching is equal to the length of the first (or second) equivalent groups. In other words, select only those permutations which are able to transform entire group1 into group2, having a one-to-one correspondence between sublists in source (group1) and target (group2).

## The implementation

This is an auxiliary function to split a list into sublists of specified lengths (taken from this post of Mr.Wizard):

dynP[l_, p_] :=
MapThread[l[[# ;; #2]] &, {{0}~Join~Most@# + 1, #} &@Accumulate@p]

These are functions to split original lists in equivalent groups of sub-lists:

ClearAll[nform, equivClasses];
nform[x_List] := Sort[x];
equivClasses[x : {__List}] := Reap[Sow[#, {nform[#]}] & /@ x, _, List][[2]];
equivClasses[x : {__List}, y : {__List}] :=
Reap[
Sow[Last[#], {First[#]}] & /@ Join[equivClasses@x, equivClasses@y],
_,
List
][[2, All, 2]];

This is the function to find all permutations which transform lst2 into lst1:

ClearAll[getAllSortingPermutations];
getAllSortingPermutations[lst1_, lst2_] :=
Module[{ord1, ord2, allowedPerms, duplens},
ord1 = Ordering[lst1];
ord2 = Ordering[lst2];
duplens = Length /@ Split[lst1[[ord1]]];
allowedPerms = Flatten /@ Flatten[
Outer[List,
Sequence @@ Map[
Permutations,
dynP[Range[Length[lst1]], duplens]
],
1
],
Length[duplens] - 1
];
ord2[[Ordering@ord1[[#]]]] & /@ allowedPerms
];

This function constructs the permutation matrix between two groups:

ClearAll[getAllMutualSortingPermutationsMatrix];
getAllMutualSortingPermutationsMatrix[fstGroup : {__List}, secGroup : {__List}] :=
Outer[getAllSortingPermutations, fstGroup, secGroup, 1, 1];

This function constructs the permutation graphs, for each permutation:

ClearAll[constructPermutationGraphs];
constructPermutationGraphs[pmatrix_] :=
With[{
permsAndVertices =
Flatten[
MapIndexed[
{#2 + {0, Length[pmatrix]}, #1} &,
pmatrix,
{2}
],
1
]
},
Reap[
Sow @@@ permsAndVertices,
_,
{#1, Graph[UndirectedEdge @@@ #2]} &
][[2]]
];

This function combines the steps together, and finds all permutations, which can transform equivalence group1 from the first original list, to equivalence group2 from the second list:

ClearAll[getGroupSortingPermutations];
getGroupSortingPermutations[fstGroup : {__List}, secGroup : {__List}] /;
Length[fstGroup] == Length[secGroup] :=
Module[{pmatrix, pgraphs, len = Length[fstGroup]},
pmatrix = getAllMutualSortingPermutationsMatrix[fstGroup, secGroup];
pgraphs = constructPermutationGraphs[pmatrix];
Select[
pgraphs,
Length[FindIndependentEdgeSet[Last[#]]] == len &
][[All, 1]]
];

getSortingPermutations[_, _] = {};

In other words, this function implements the sub-algorithm described above.

This is the final function which brings this all together:

ClearAll[equivalentQ];
equivalentQ[fst:{__List},sec:{__List}] /; Length[fst]==Length[sec] &&
Length[DeleteDuplicates[Length/@Join[fst,sec]]]==1    :=
Module[{equivGroups,sortingPermsByEquivGroups,groupsByPerms},
equivGroups=equivClasses[fst,sec];
sortingPermsByEquivGroups=
Reap[
Scan[
(If[#1==={},Return[{}],Sow[#1]]&)[
getGroupSortingPermutations@@#1
]&,
equivGroups
]
];
If[
First[sortingPermsByEquivGroups]==={}
,
Return[False]
,
(*else*)
sortingPermsByEquivGroups = sortingPermsByEquivGroups[[2,1]]
];
groupsByPerms=
Reap[
Apply[
Sow,
MapIndexed[{First[#2],#1}&,sortingPermsByEquivGroups],
{1}
],
_,
List
][[2]];
MemberQ[groupsByPerms,{_,Range[Length[equivGroups]]}]
];

equivalentQ[_,_]=False;

## Benchmarks

This is the code I use to construct larger lists, where one is equivalent to the other:

testList1AuxLrg=Table[RandomInteger[{1,15},15],{10}];
testList1Lrg=
Flatten[
Table,
{
testList1AuxLrg,
List/@RandomInteger[{1,3},Length[testList1AuxLrg]]
}
],
1
];
testList2Lrg=
With[{rperm=RandomSample[Range[Length[First[testList1Lrg]]]]},
RandomSample[(#1[[rperm]]&)/@testList1Lrg]
];

In this case, we have sub-lists of 15 elements each, and the outer lists contain 17 such sublists:

testList1Lrg // Length

(* 17 *)

We now call our function:

equivalentQ[testList1Lrg, testList2Lrg] // AbsoluteTiming

(* {0.207570, True} *)

We will now randomly permute one of the sub-lists in one of the lists, and try again:

AbsoluteTiming[
equivalentQ[
testList1Lrg,
MapAt[
RandomSample,
testList2Lrg,
RandomInteger[{1,Length[testList2Lrg]}]
]
]
]

(* {0.082487, False} *)

## Notes

Probably, the algorithm can be further optimized in various places, so that certain decisions are made earlier. I wasn't concerned with the fine-tuning here.

Depending on the configurations of your lists, this may perform better of worse than your suggested algorithm. Specifically, this depends on the lengths of the sublists. For large enough lengths (like in my example, for instance), my version should be vastly faster, but for small lengths, I'd expect the simple one to be faster. I did not perform comparative benchmarks.

-
Wow. Just wow. Thank you! – celtschk Apr 12 '14 at 6:37
@celtschk Welcome :). I noticed you're back after a long time, so I thought you should get an answer for this such as to not be disappointed. And I liked the problem, it's quite interesting. Actually, I think your question deserved way more votes, it's a really good problem to showcase Mathematica's capabilities for rapid prototyping and algorithm development. – Leonid Shifrin Apr 12 '14 at 12:28