program ladder(input, output);

label 999;

const
  NONE = -1;
  wordLength = 5;
  maxSteps = 99;
  maxWords = 4200;
  infinite = 99999;

type
  dictIndex = -1..maxWords;
  fixedLength = packed array [1..wordLength] of char;
  wordStatus = record
                 dist: integer;
                 prev: dictIndex;
                 word: fixedLength;
               end;
  dictionary = array [dictIndex] of wordStatus;

var
  lastWord: dictIndex;
  dict: dictionary;
  first, last: fixedLength;
  firstIdx, lastIdx: dictIndex;
  dictfile: text;

procedure InitVars;
begin
  lastWord := -1;
{  reset(input, 'TT:'); }
{  rewrite(output, 'TT:'); }
  reset(dictFile, 'word5');
end;

procedure ResetVars;
var each:dictIndex;
begin
  for each := 0 to lastWord do begin
    with dict[each] do begin
      prev := NONE;
      dist := infinite;
    end;
  end;
end;

procedure ReadDict(var dict: dictionary);
var i: 1..wordLength;
begin
  while (not eof(dictfile)) and (lastWord < maxWords) do begin
    lastWord := lastWord + 1;
    with dict[lastWord] do begin
      for i := 1 to wordLength do Read(dictfile, word[i]); ReadLn(dictfile);
{     WriteLn('Added word ', word);}
      prev := NONE;
      dist := infinite;
    end;
  end;
{ WriteLn('End of file - Dictionary Read OK');}
end;

function Idx(word: fixedLength): dictIndex;
label 999;
var mid, l, r: dictIndex;
begin
  r := lastWord; l := 0; mid := l; Idx := -1;
  while l<=r do begin
    mid := (l+r) div 2;
    if word >= dict[mid].word then begin
      if word=dict[mid].word then begin
        Idx := mid;
        goto 999;
      end;
      l := mid+1;
    end else begin
      r := mid-1;
    end;
  end;
999:
end;

procedure ReadWord(var word: fixedLength);
var i: 1..wordLength;
begin
{ WriteLn('Reading a word...');}
  for i := 1 to wordLength do begin
    Read(word[i]);
{    WriteLn('Word[', i, '] = ', ORD(word[i]));}
  end;
  ReadLn;
{  WriteLn('Word is <', word, '>');}
end;

procedure FindLadders(last, root: dictIndex);
label 999;
var
  word: fixedLength;
  chpos: 1..wordLength;
  level: 0..999;
  test, neighbour: dictIndex;
  ch, other: char;
begin
  dict[root].dist := 0;
  for level := 1 to maxSteps do begin
    for test := 0 to lastWord do begin;
      if dict[test].dist = pred(level) then begin
        word := dict[test].word;
        for chpos := 1 to wordLength do begin
          ch := word[chpos];
          for other := 'a' to 'z' do begin
            if ch <> other  then begin
              word[chpos] := other;
              neighbour := Idx(word);
              if (neighbour <> -1) and (dict[neighbour].dist > level)
              then begin
                dict[neighbour].dist := level;
                dict[neighbour].prev := test;
                WriteLn(dict[test].word, ' -> ', word);
              end;
            end;
          end;
          word[chpos] := ch;
        end;
      end
    end;
    if dict[last].dist <> infinite then begin
      WriteLn(level, ' step path found!');
      goto 999;
    end;
    writeln('Finished level ', level);
  end;
999:
end;

procedure PrintLadders(root, last: dictIndex);
var prev: dictIndex;
begin
  if dict[root].dist = infinite then begin
    writeln('No path found between ', dict[root].word,
                             ' and ', dict[last].word);
  end else begin
    writeln(dict[root].word);
    repeat
      prev := dict[root].prev;
      writeln(dict[prev].word);
      root := prev;
    until root = last;
  end;
end;

begin
  InitVars;
  ReadDict(dict);
  repeat
    repeat
      Write('From: ');
      ReadWord(first);
      firstIdx := Idx(first);
      if firstIdx=-1 then WriteLn(first, ' is not in the dictionary');
    until firstIdx <> -1;
    repeat
      Write('To:   ');
      ReadWord(last);
      lastIdx := Idx(last);
      if lastIdx=-1 then WriteLn(last, ' is not in the dictionary');
    until lastIdx <> -1;
    FindLadders(firstIdx, lastIdx);
    PrintLadders(firstIdx, lastIdx);
    ResetVars;
  until false;
999:
end.