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[
MapThread[
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.
