RosettaCodeData/Task/Superpermutation-minimisation/Mathematica/superpermutation-minimisati...

34 lines
1.1 KiB
Plaintext

ClearAll[OverlapDistance, ConstructDistances]
OverlapDistance[{s1_List, s2_List}] := OverlapDistance[s1, s2]
OverlapDistance[s1_List, s2_List] := Module[{overlaprange, overlap, l},
overlaprange = {Min[Length[s1], Length[s2]], 0};
l = LengthWhile[Range[Sequence @@ overlaprange, -1], Take[s1, -#] =!= Take[s2, #] &];
overlap = overlaprange[[1]] - l;
<|"Overlap" -> overlap, "Distance" -> Length[s2] - overlap|>
]
ConstructDistances[perms_List] := Module[{sel, OD, fullseq},
OD = BlockMap[OverlapDistance, perms, 2, 1];
fullseq =
Fold[Join[#1, Drop[#2[[2]], #2[[1]]["Overlap"]]] &,
First[perms], {OD, Rest[perms]} // Transpose];
fullseq
]
Dynamic[Length[perms]]
Do[
n = i;
perms = Permutations[Range[n]];
{start, perms} = TakeDrop[perms, 1];
While[Length[perms] > 0,
last = Last[start];
dists =
Table[<|"Index" -> i, OverlapDistance[last, perms[[i]]]|>, {i,
Length[perms]}];
sel = First[TakeSmallestBy[dists, #["Distance"] &, 1]];
AppendTo[start, perms[[sel["Index"]]]];
perms = Delete[perms, sel["Index"]];
];
Print[{n, Length@ConstructDistances[start]}]
,
{i, 1, 7}
]