program Anagram(input, output);
const
  filler = '~';
  MaxWords = 100; MaxLength = 15;
type
  string = packed array [0..MaxLength] of char;
  DictRange = 0..MaxWords;
  Dict = array [DictRange] of string;
var
  dictfile: text;
  word, canonical: string;
  canonlist, wordlist: Dict;
  lastword,
  tot, each, index: integer;

procedure SortLine(var s1, s2: string);
var i, j: integer; temp: char;
begin
  for i := 0 to Maxlength do begin
    s1[i] := s2[i];
  end;
  for i := 0 to MaxLength do begin                      {N^2/2 - yecH!}
    for j := i to Maxlength do begin
      if s1[j] < s1[i] then begin
        temp := s1[i]; s1[i] := s1[j]; s1[j] := temp;
      end;
    end;
  end;
end {Sortline};

procedure SortFile(var s1, s2: Dict);
var i, j: integer; temp: string;
begin
  for i := 0 to lastword do begin                      {N^2/2 - yecH!}
    for j := i to lastword do begin
      if s1[j] < s1[i] then begin
        temp := s1[i]; s1[i] := s1[j]; s1[j] := temp;
        temp := s2[i]; s2[i] := s2[j]; s2[j] := temp;
      end;
    end;
  end;
end {SortFile};

procedure WriteWord(var s: string);
var i: integer;
begin
  for i := 0 to Maxlength do begin
    if s[i] <> filler then Write(s[i]);
  end;
end;

procedure ReadDictionary(var c, w: Dict;  var last: integer);
var i: integer;
begin
  last := -1;
  while not eof(dictfile) do begin
    last := last+1;
    for i:=0 to MaxLength do begin
      w[last][i] := dictfile^;
      if w[last][i] = ' ' then begin
        w[last][i] := filler;
      end else begin
        Get(dictfile); 
      end;
    end;
    ReadLn(dictfile);
    SortLine(c[last], w[last]); {Argh!!! Spaces come first!!!}
  end;
end {ReadDictionary};

procedure PrintDict;
var last: integer;
begin
  for last := 0 to lastword do begin
    write('Word: ');
    WriteWord(wordlist[last]);
    Write(', Anagram: ');
    WriteWord(canonlist[last]);
    WriteLn;
  end;
end {PrintDict};

function Matches(s1, s2: string): boolean;
var i: integer;
begin
  Matches := true;
  for i:= 0 to MaxLength do begin
    if s1[i] <> s2[i] then Matches := False;
  end;
end {Matches};

function Locate(s: string): integer;
var i: integer; found: boolean;
begin
  Locate := -1; found := false;
  i := 0;
  while i <= lastword do begin
    if (not found) and Matches(s, canonlist[i]) then begin
      Locate := i; found := true;
    end;
    i := i+1;
  end;
end {Locate};

function Getuserword(var w: string): boolean;
var i: integer;
begin
  Write('Word: ');
  for i := 0 to MaxLength do begin
    w[i] := input^;
    if w[i] = ' ' then begin
      w[i] := filler;
    end else begin
      Get(input); 
    end;
  end;
  readln;
  getUserWord := w[0] <> filler;
end {getUserWord};

begin
  reset(dictfile, 'Anagram-txt');
  ReadDictionary(canonlist, wordlist, lastword);
  WriteLn('Before sorting...');
  PrintDict;
  SortFile(canonlist, wordlist);
  WriteLn('after sorting');
  PrintDict;
  while GetUserWord(word) do begin
    SortLine(canonical, word);
    index := Locate(canonical);
    if index < 0 then begin
      Write('There are no anagrams of ');
      WriteWord(word);
      WriteLn(' in my dictionary.')
    end else begin
      tot := index;
      while  (tot <= lastword) and
          Matches(canonical, canonlist[tot]) do begin
        tot := tot+1;
      end;
      tot := tot-index;
      if tot > 1 then begin
        Write('The ', tot, ' anagrams I know of ');
        WriteWord(word);
        Write(' are ');
        for each := index to index+tot-1 do begin
          WriteWord(wordlist[each]);
          if each<>index+tot-1 then Write(', ');
        end;
        WriteLn;
      end else begin
        Write('The only anagram I can find of ');
        WriteWord(word);
        Write(' is ');
        WriteWord(wordlist[index]);
        WriteLn;
      end;
    end;
  end;
end {Anagram}.