Mathematica 337 418 372
After trying unsuccessfully to implement using Mathematica's LongestCommonSubsequencePositions
, I turned to pattern matching.
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]<>""]
The pattern-matching rule,
r={{a___,Longest[y__]},{y__,b___}}:> {{a,y},{y,b},{y},{a,y,b}}},
takes an ordered pair of words (represented as lists of characters) and returns: (1) the words,{a,y}
and {y,b}
followed by (2) the common substring,y
, that links the end of one word with the beginning of the other word, and, finally, the combined word {a,y,b}
that will replace the input words. See Belisarius for a related example: https://mathematica.stackexchange.com/questions/6144/looking-for-longest-common-substring-solution
Three consecutive underscore characters signify that the element is a sequence of zero or more characters.
Reverse
is employed later to ensure that both orders are tested. Those pairs that share linkable letters are returned unchanged and ignored.
Edit:
The following removes from the list words that are "buried" (i.e. fully contained) in another word, (in response to @flornquake's comment).
h=Complement[r,Cases[Join[p@r,p@Reverse@r],x_/;!StringFreeQ@@x:> x[[2]]]]
Example:
{{"D", "O", "L", "O", "R", "E"}, {"L", "O", "R", "E", "M"}} /. r
returns
{{"D", "O", "L", "O", "R", "E"}, {"L", "O", "R", "E", "M"}, {"L", "O",
"R", "E"}, {"D", "O", "L", "O", "R", "E", "M"}}
Usage
g[{"LOREM", "ORE", "R"}]
AbsoluteTiming[g[{"AD", "DO", "DOLOR", "DOLORE", "LOREM", "MAGNA", "SED", "ORE", "R"}]]
"LOREM"
{0.006256, "SEDOLOREMAGNAD"}