Type TSVec = array of String;
  ...

  procedure AddToSVec(s: String; var v: TSVec);
  // добавление строки в массив
    var n: Integer;
  begin
    n:= Length(v); SetLength(v,n+1); v[n]:= s;
  end;

  function CutOnWords(s: String): TSVec;
  // резка строки слов на массив слов
    var i,n: Integer; q: String;
  begin
    Result:= Nil; q:= ''; s:= s+' '; n:= Length(s);
    for i:= 1 to n do
    if s[i] = ' ' then
      begin
      if Trim(q) <> '' then AddToSVec(Trim(q),Result);
      q:='';
      end else q:= q+s[i];
  end;


  function Permatate(a: TSVec): boolean;
  // метод эффективных перестановок
  var i,j,n: Integer;
//-------------------------------------------------------
  function Compare(a,b: String): boolean;
  // сравнение слов
  begin
    Result:= (Length(a)>0) and (Length(b)>0) and (a[Length(a)] = b[1]);
  end;

  function IsChain: boolean;
  // массив - готовая цепочка?
    var i: Integer;
  begin
    Result:= true;
    for i:= 0 to n-2 do
    if not Compare(a[i],a[i+1]) then
      begin Result:= false; exit; end;
  end;

  procedure Permute(i,j: Integer);
  // перестановка 2-х элементов
    var s: String;
  begin
    if i<>j then
    begin s:= a[i]; a[i]:= a[j]; a[j]:= s; end;
  end;

  procedure Perm(m: Integer);
  // рекурсивная процедура перестановок строк в массиве
    var j: Integer;
  begin
    if Result then exit;
    Result:= false;
    for j:= m+1 to n-1 do
    if not Result then
      if Compare(a[m],a[j]) then
      begin
        Permute(j,m+1);
        Result:= IsChain;
        if (m<n-2) and not Result then Perm(m+1);
      end;
  end;
//-------------------------------------------------------
begin
  n:= Length(a); Result:= n<2;
  if Result then exit;
  for i:= 0 to n-1 do
  for j:= 0 to n-1 do
    if not Result then
    if i <> j then
      if Compare(a[i],a[j]) then
      begin
        if (n=2) and (i=1) and (j=0) then Permute(i,j) else
        begin Permute(i,0); Permute(j,1); end;
        Result:= IsChain;
        Perm(1);
        if Result then exit;
      end;
end;

  function SumWords(a: TSVec): String;
    var i: Integer;
  begin
    Result:='';
    for i:= 0 to Length(a)-1 do
    Result:= Result+' '+a[i];
  end;

procedure TForm1.Button2Click(Sender: TObject);
  var a: TSVec; s: String;
begin
  s:= ' олег анна  оля лес лос атолл болото село якоб гена ';
  a:= CutOnWords(s);
  if Permatate(a) then ShowMessage(SumWords(a)) else
  ShowMessage('Нет цепочки слов.');
  a:= Nil;
end;

Type TSVec = array of String;
      TIVec = array of Integer;
...
procedure CopyIVec(var a,b: TIVec);
  var n: Integer;
begin
  n:= Length(a); SetLength(b,n);
  Move(a[0],b[0],n*SizeOf(Integer));
end;

function Compare(a,b: String): boolean;
begin
  Result:= (Length(a)>0) and (Length(b)>0) and (a[Length(a)] = b[1]);
end;

function ExistsInIVec(i: Integer; v: TIVec): boolean;
  var n,j: Integer;
begin
  Result:= false; n:= Length(v)-1;
  for j:= 0 to n do
  if v[j] = i then
    begin Result:= true; exit; end;
end;

procedure AddToIVec(j: Integer; var v: TIVec);
  var n: Integer;
begin
  n:= Length(v); SetLength(v,n+1); v[n]:= j;
end;

procedure AddToSVec(s: String; var v: TSVec);
  var n: Integer;
begin
  n:= Length(v); SetLength(v,n+1); v[n]:= s;
end;

function FindChain(a: TSVec; var b: TIVec): boolean;
var NeedRecurse: boolean; t: TIVec; n,i: Integer;
// ------------------------------------------------
procedure Recurse(s: String; t: TIVec);
  var j,k1,z: Integer; g: TIVec;
begin
  z:= Length(t);
  for j:= 0 to n-1 do
  if NeedRecurse then
    if (T[z-1]<>j) then
    if Compare(a[T[z-1]],a[j]) then
      if not ExistsInIVec(j,T) then
      begin
        CopyIVec(t,g);
        AddToIVec(j,g);
        k1:= z+1;
        if k1 = n then
        begin
          NeedRecurse:= false;
          CopyIVec(g,b);
        end;
        if NeedRecurse then Recurse(s+' '+a[j],g);
        g:= Nil;
      end;
end;
// ------------------------------------------------
begin
  NeedRecurse:= true; n:= Length(a); Result:= n<2;
  if not Result then
  begin
    for i:= 0 to n-1 do
    if NeedRecurse then
      begin
      t:= Nil;
      AddToIVec(i,t);
      Recurse(a[i]+' ',t);
      end;
    t:= Nil;
    Result:= not NeedRecurse;
  end;
end;

function CutOnWords(s: String): TSVec;
  var i,n: Integer; q: String;
begin
  Result:= Nil; q:= ''; s:= s+' '; n:= Length(s);
  for i:= 1 to n do
  if s[i] = ' ' then
    begin
    if Trim(q) <> '' then AddToSVec(Trim(q),Result);
    q:='';
    end else q:= q+s[i];
end;

function SumWords(a: TSVec; v: TIVec): String;
  var i: Integer;
begin
  Result:='';
  for i:= 0 to Length(a)-1 do
  Result:= Result+' '+a[v[i]];
end;

procedure TForm1.Button1Click(Sender: TObject);
  var a: TSVec; IndVec: TIVec; n,i: Integer; s: String;
begin
  s:= ' олег анна  оля лес лос атолл болото село якоб гена ';
  a:= CutOnWords(s);
  if FindChain(a,IndVec) then ShowMessage(SumWords(a,IndVec))
  else ShowMessage('Нет цепочки слов.');
  IndVec:= Nil; a:= Nil;
end;

function WordsInLine(Words: TStrings): string;
type
PWord = ^TWord;
TWord = record
  ind: integer; //индекс в Words
  used: boolean;
  conti: array of PWord; //продолжения
end;
var
Graph: array of TWord; //граф
Solution: array of integer; //решение
function Check(left,right: integer): boolean;
begin
result:= Words[ left ][length(Words[ left ])]=Words[ right ][1];
end;
procedure MakeGraph;
var
i,j: integer;
begin
SetLength(Graph,Words.Count);
SetLength(Solution,Words.Count);
//поиск связей
for i:= 0 to Words.Count-1 do begin
  Graph[i].ind:= i;
  Graph[i].used:= false;
  for j:= 0 to Words.Count-1 do
  if i<>j then
    if Check(i,j) then begin
    SetLength(Graph[i].conti,High(Graph[i].conti)+2);
    Graph[i].conti[High(Graph[i].conti)]:= @Graph[j];
    end;
end;
end;
function Step(cur: PWord; N: integer): boolean;
var
i: integer;
begin
cur.used:= true; //блокируем это слово
Solution[N]:= cur.ind; //запоминаем решение
if N=Words.Count-1 then begin
  //конец
  result:= true;
  exit;
end;
result:= false;
for i:= 0 to High(cur.conti) do
if not cur.conti[i].used then begin
  result:= Step(cur.conti[i],N+1);
  if result then exit;//конец
end;
cur.used:= false; //разблокируем
end;
var
i,j: integer;
begin
MakeGraph;
for i:= 0 to Words.Count-1 do
  if Step(@Graph[i],0) then begin
  result:= '';
  for j:= 0 to Words.Count-1 do
    result:= result+Words[Solution[j]]+', ';
    delete(result,length(result)-1,2);
  exit;
  end;
result:= 'нет';
end;