Mathematica 337 418 372
После неудачных попыток реализовать с помощью Mathematica LongestCommonSubsequencePositions
, я обратился к сопоставлению с образцом.
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]<>""]
Правило сопоставления с образцом,
r={{a___,Longest[y__]},{y__,b___}}:> {{a,y},{y,b},{y},{a,y,b}}},
принимает упорядоченную пару слов (представленных в виде списков символов) и возвращает: (1) слова, {a,y}
а {y,b}
затем (2) общую подстроку y
, которая связывает конец одного слова с началом другого слова, и, наконец, объединенное слово {a,y,b}
, которое заменит входные слова. См. Велизарий для соответствующего примера: /mathematica/6144/looking-for-longest-common-substring-solution
Три последовательных символа подчеркивания означают, что элемент представляет собой последовательность из нуля или более символов.
Reverse
используется позже, чтобы убедиться, что оба заказа проверены. Те пары, которые разделяют связываемые буквы, возвращаются без изменений и игнорируются.
Редактировать :
Следующее удаляет из списка слова, которые «похоронены» (то есть полностью содержатся) в другом слове (в ответ на комментарий @ flornquake).
h=Complement[r,Cases[Join[p@r,p@Reverse@r],x_/;!StringFreeQ@@x:> x[[2]]]]
Пример :
{{"D", "O", "L", "O", "R", "E"}, {"L", "O", "R", "E", "M"}} /. r
возвращается
{{"D", "O", "L", "O", "R", "E"}, {"L", "O", "R", "E", "M"}, { "L", "O", "R", "E"}, {"D", "O", "L", "O", "R", "E", "M"}}
использование
g[{"LOREM", "ORE", "R"}]
AbsoluteTiming[g[{"AD", "DO", "DOLOR", "DOLORE", "LOREM", "MAGNA", "SED", "ORE", "R"}]]
"Lorem"
{0.006256, "СЕДОЛОРЕМАГНАД"}