Here is a method that uses several sweeps over the lists. asically liner in complexity (there is a hidden log(n) factor but it's easy to get rid of it). I'll illustrate with your example, then wrap the thing in a Module
and show some larger ones
In[724]:= x = {a, b, c, d, e, f, r, e, t};
y = {f, a, c, f, b, a, b, f, g};
Record positions of x
elements.
In[755]:= xValsAndPositions =
Reap[MapIndexed[Sow[{#1, #2[[1]]}, #1] &, x]][[2]]
(* Out[755]= {{{a, 1}}, {{b, 2}}, {{c, 3}}, {{d, 4}}, {{e, 5}, {e,
8}}, {{f, 6}}, {{r, 7}}, {{t, 9}}} *)
In[756]:= valAndIndexList =
Map[{#[[1, 1]], #[[All, 2]]} &, xValsAndPositions]
(* Out[756]= {{a, {1}}, {b, {2}}, {c, {3}}, {d, {4}}, {e, {5,
8}}, {f, {6}}, {r, {7}}, {t, {9}}} *)
Create a lookup table from this. Also throw in indexing to first ocurrence positions for later use.
In[757]:= Scan[(indexList[#[[1]]] = {1, #[[2]]}) &, valAndIndexList]
Have look at the internals of this table.
In[758]:= DownValues[indexList]
(* Out[758]= {HoldPattern[indexList[a]] :> {1, {1}},
HoldPattern[indexList[b]] :> {1, {2}},
HoldPattern[indexList[c]] :> {1, {3}},
HoldPattern[indexList[d]] :> {1, {4}},
HoldPattern[indexList[e]] :> {1, {5, 8}},
HoldPattern[indexList[f]] :> {1, {6}},
HoldPattern[indexList[r]] :> {1, {7}},
HoldPattern[indexList[t]] :> {1, {9}}} *)
Now figure out landing positions for elements in the y
list.
In[759]:= yPositions = Table[
If[ListQ[index = indexList[y[[i]]]] &&
index[[1]] <= Length[index[[2]]],
indexList[y[[i]]] = {index[[1]] + 1, index[[2]]};
index[[2, index[[1]]]],
0],
{i, Length[y]}]
(* Out[759]= {6, 1, 3, 0, 2, 0, 0, 0, 0} *)
Extract the "missing" positions.
In[760]:= missingPositions = Complement[Range[Length[y]], yPositions]
(* Out[760]= {4, 5, 7, 8, 9} *)
Merge the two lists.
In[763]:= k = 0;
finalYPositions =
Table[If[yPositions[[j]] === 0, k++; missingPositions[[k]],
yPositions[[j]]], {j, Length[yPositions]}]
(* Out[764]= {6, 1, 3, 4, 2, 5, 7, 8, 9} *)
Use this to get our result.
In[767]:= y[[Ordering[finalYPositions]]]
(*Out[767]= {a, b, c, f, a, f, b, f, g} *)
Here is the full function.
reorderByHamming[x_List, y_List] := Module[
{xValsAndPositions, valAndIndexList, indexList, yPositions, index,
missingPositions, k, finalPositions},
xValsAndPositions =
Reap[MapIndexed[Sow[{#1, #2[[1]]}, #1] &, x]][[2]];
valAndIndexList = Map[{#[[1, 1]], #[[All, 2]]} &, xValsAndPositions];
Scan[(indexList[#[[1]]] = {1, #[[2]]}) &, valAndIndexList];
yPositions = Table[
If[ListQ[index = indexList[y[[i]]]] &&
index[[1]] <= Length[index[[2]]],
indexList[y[[i]]] = {index[[1]] + 1, index[[2]]};
index[[2, index[[1]]]],
0],
{i, Length[y]}];
missingPositions = Complement[Range[Length[y]], yPositions];
k = 0;
finalPositions =
Table[If[yPositions[[j]] === 0, k++; missingPositions[[k]],
yPositions[[j]]], {j, Length[yPositions]}];
Clear[indexList];
y[[Ordering[finalPositions]]]
]
We'll illustrate on a pair of lists that we expect to have a "good" reordering (low Hamming distance).
SeedRandom[111111]
x = RandomInteger[10, 30]
y = RandomInteger[10, 30]
(* Out[782]= {10, 0, 8, 9, 9, 6, 10, 2, 4, 8, 2, 8, 9, 7, 9, 3, 1, 3, 6, \
3, 10, 10, 7, 9, 6, 3, 0, 6, 2, 8}
Out[783]= {5, 5, 6, 1, 6, 2, 0, 8, 0, 5, 1, 9, 3, 1, 6, 3, 5, 3, 9, \
8, 2, 10, 8, 4, 7, 4, 2, 9, 9, 8} *)
Do the reordering.
yNew = reorderByHamming[x, y]
(* Out[785]= {10, 0, 8, 9, 9, 6, 5, 2, 4, 8, 2, 8, 9, 7, 9, 3, 1, 3, 6, \
3, 5, 5, 1, 1, 6, 5, 0, 4, 2, 8} *)
Check the result for quality.
HammingDistance[x, yNew]
(* Out[787]= 7 *)
Here is a bigger example.
SeedRandom[111111]
n = 10^5;
x = RandomInteger[10, n];
y = RandomInteger[10, n];
Timing[yNew = reorderByHamming[x, y];]
HammingDistance[x, y]
HammingDistance[x, yNew]
(* Out[806]= {3.26563, Null}
Out[807]= 90988
Out[808]= 760 *)
Could be faster but at least it's not outrageously slow. As for the result, we start with the expected roughly 10% agreement between the lists, and end with agreement to better than 99%.