Mathematica 337 418 372
Setelah gagal mencoba menerapkan menggunakan Mathematica LongestCommonSubsequencePositions
, saya beralih ke pencocokan pola.
v=Length;
p[t_]:=Subsets[t,{2}];
f[w_]:=Module[{c,x,s=Flatten,r={{a___,Longest[y__]},{y__,b___}}:>{{a,y},{y,b},{y},{a,y,b}}},
c=p@w;
x=SortBy[Cases[s[{#/.r,(Reverse@#)/.r}&/@c,1],{_,_,_,_}],v[#[[3]]]&][[-1]];
Append[Complement[w,{x[[1]],x[[2]]}],x[[4]]]]
g[r_]:=With[{h=Complement[r,Cases[Join[p@r,p@Reverse@r],y_/;!StringFreeQ@@y:>y[[2]]]]},
FixedPoint[f,Characters/@h,v@h-1]<>""]
Aturan pencocokan pola,
r={{a___,Longest[y__]},{y__,b___}}:> {{a,y},{y,b},{y},{a,y,b}}},
mengambil pasangan kata yang diurutkan (diwakili sebagai daftar karakter) dan mengembalikan: (1) kata-kata, {a,y}
dan {y,b}
diikuti oleh (2) substring yang umum y
,, yang menghubungkan akhir satu kata dengan awal kata lain, dan, akhirnya, kata gabungan {a,y,b}
itu akan menggantikan kata input. Lihat Belisarius untuk contoh terkait: /mathematica/6144/looking-for-longest-common-substring-sution
Tiga karakter garis bawah berturut-turut menandakan bahwa elemen tersebut adalah urutan dari nol atau lebih karakter.
Reverse
digunakan kemudian untuk memastikan bahwa kedua pesanan diuji. Pasangan-pasangan yang berbagi surat-surat yang dapat ditautkan dikembalikan tidak berubah dan diabaikan.
Edit :
Berikut ini menghapus dari daftar kata-kata yang "dikubur" (yaitu sepenuhnya terkandung) dengan kata lain, (sebagai tanggapan terhadap komentar @ flornquake).
h=Complement[r,Cases[Join[p@r,p@Reverse@r],x_/;!StringFreeQ@@x:> x[[2]]]]
Contoh :
{{"D", "O", "L", "O", "R", "E"}, {"L", "O", "R", "E", "M"}} /. r
kembali
{{"D", "O", "L", "O", "R", "E"}, {"L", "O", "R", "E", "M"}, { "L", "O", "R", "E"}, {"D", "O", "L", "O", "R", "E", "M"}}
Pemakaian
g[{"LOREM", "ORE", "R"}]
AbsoluteTiming[g[{"AD", "DO", "DOLOR", "DOLORE", "LOREM", "MAGNA", "SED", "ORE", "R"}]]
"LOREM"
{0,006256, "SEDOLOREMAGNAD"}