Anagram finder in Ada

This is the Ada implementation of the anagram program. The problem and the solution is described in the main anagram article. Do read that article first.

This is traditional ADA, except for the use of Ada.Containers.Generic_Sort available in Ada 2012.

While Ada did not originally contain object-oriented constructs such as classes, these have been added. I have not used them, since the package mechanism suffices for this program.

The GNU Ada Translator, known as gnat is very good. The Ada program is as fast as the C and C++ programs, and it uses less memory.

Don’t use Ada. Hardly anyone does. It is almost extinct. I include it just for completeness.

The source code

The Ada Reference Manual does not specify how source code is to be divided into files. The convention is to have one file for each package specification, package body or global function. With GNU Ada, the source file passed to gnatmake contains the procedure that acts as the entry point, like main() in C. Since there must be exactly one procedure in that file, it can have any name.

AnagramFinder package specification

package AnagramFinder is
   procedure new_len(word_len : integer);
   procedure find_all;
   procedure get_file;
   procedure write_stats;
end AnagramFinder;

Main program

with Ada.Text_IO;              use Ada.Text_IO;
with Ada.Integer_Text_IO;      use Ada.Integer_Text_IO;
with Ada.Command_Line;         use Ada.Command_Line;

with AnagramFinder;

procedure anagram is
   from : integer := 6;
   to   : integer := 6;
begin
   if (argument_count > 0) then
      from:= integer'value(argument(1));
      to  := from;
   end if;
   if (argument_count > 1) then
      to := integer'value(argument(2));
   end if;

   AnagramFinder.get_file;

   for len in from..to loop
      if (len > from) then new_line; end if;
      put("len = ");
      put(len, 1);
      new_line;
      AnagramFinder.new_len(len);
      AnagramFinder.find_all;
   end loop;
   AnagramFinder.write_stats;
end;

AnagramFinder package body

with Ada.Text_IO;              use  Ada.Text_IO;
with Ada.Integer_Text_IO;      use  Ada.Integer_Text_IO;
with Ada.Characters.Handling;  use  Ada.Characters.Handling;

with Ada.Containers.Generic_Sort;

package body AnagramFinder is
   type Str is new string(1..20);                                        ----------- TYPES

   type Word is
      record
         offset  : integer;
         value   : Str;
         unified : Str;
      end record;

   type LetterCount        is array (character range 'A'..'Z') of integer;
   type WordListForSorting is array (positive  range <>      ) of Word;
                                                                         ----------- GLOBALS
   comparisons : integer := 0;
   len         : integer;
                                                                         ----------- CONSTANTS
   MINIMUM     : constant integer := 3;
   SPACES      : constant Str     := "                    ";
                                                                         ----------- put_str()
   procedure put_str(s : Str) is
   begin
         for i in 1..len loop put(s(i)); end loop;
   end;
   --------------------------------------------------------------------------------- AnagramFinder
   text        : string(1..256000);
   text_len    : integer := 0;
   low_offset  : integer;
   words       : WordListForSorting(1..256000);
   nwords      : integer;
   accepted    : array(1..20) of integer;
   naccepted   : integer;
                                                                      ----------- word_before()
   function word_before(a, b: in positive) return boolean is
   begin
      comparisons := comparisons + 1;
      for i in words(1).unified'range loop
         if (words(a).unified(i) < words(b).unified(i)) then return true;  end if;
         if (words(a).unified(i) > words(b).unified(i)) then return false; end if;
      end loop;
      return words(a).offset < words(b).offset;
   end;
                                                                      ----------- word_swap()
   procedure word_swap(a, b: in positive) is
      tmp : Word;
   begin
      tmp      := words(a);
      words(a) := words(b);
      words(b) := Tmp;
   end word_swap;
                                                                      ----------- sort_words()
   procedure sort_words is
      new Ada.Containers.Generic_Sort(positive, word_before, word_swap);
                                                                      ----------- new_len()
   function get_unified(letters : LetterCount) return Str;

   procedure new_len(word_len : integer) is
      ch      : character;
      front   : integer;
      value   : Str := SPACES;
      letters : LetterCount;
   begin
      len := word_len;
      for i in letters'range loop letters(i) := 0; end loop;
      nwords := 0;
      for i in 1..(len-1) loop
         ch          := text(i);
         letters(ch) := letters(ch) + 1;
         value  (i ) := ch;                        -- "FINDM "
      end loop;
      for back in 1..(text_len-len+1) loop
         nwords := nwords + 1;
         front  := back+len-1;

         letters(text(front))  := letters(text(front)) + 1;
         value(len)            := text(front);     -- "FINDME"

         words(nwords).offset  := back - 1;        -- zero-based
         words(nwords).value   := value;
         words(nwords).unified := get_unified(letters);

         value(1..(len-1))     := value(2..(len)); -- "INDMEE"
         letters(text(back ))  := letters(text(back )) - 1;
      end loop;
      sort_words(1, nwords);
   end;
                                                                      ----------- get_unified()
   function get_unified(letters : LetterCount) return Str is
      p     : integer := 1;
      rval  : str     := SPACES;
   begin
      for ch in letters'range loop
         for i in 1..letters(ch) loop
            rval(p) := ch;
            p := p+1;
         end loop;
      end loop;
      return rval;
   end;
                                                                      ----------- compare_values()
   function compare_values(a, b : integer) return integer is
   begin
      for i in 1..len loop
         if (words(a).value(i) < words(b).value(i)) then return -1; end if;
         if (words(a).value(i) > words(b).value(i)) then return +1; end if;
      end loop;
      return 0;
   end;
                                                                      ----------- print_one_result()
   procedure print_one_result is
   begin
      put(naccepted, 3);
      put(':');
      for i in 1..naccepted loop
         put(' ');
         put(words(accepted(i)).offset, 4);
         put(':');
         put_str(words(accepted(i)).value);
      end loop;
      new_line;
   end;
                                                                      ----------- add_candidate()
   procedure add_candidate(cand : integer) is
   begin
      if (words(cand).offset < low_offset) then return; end if;
      for i in 1..naccepted loop
         if (0 = compare_values(cand, accepted(i))) then return; end if;
      end loop;
      naccepted := naccepted + 1;
      accepted(naccepted) := cand;
      low_offset := words(cand).offset + len;
   end;
                                                                      ----------- add_range()
   procedure add_range(first, last : integer) is
   begin
      if (last - first + 1 >= MINIMUM) then
         naccepted   := 0;
         low_offset := 0;
         for i in first..last loop
            add_candidate(i);
         end loop;
         if (naccepted >= MINIMUM) then
            print_one_result;
         end if;
      end if;
   end;
                                                                      ----------- find_all()
   procedure find_all is
      first : integer := 1;
   begin
      for i in 2..(nwords) loop
         for j in 1..len loop
            if words(first).unified(j) /= words(i).unified(j) then
               add_range(first, i-1);
               first := i;
               exit;
            end if;
         end loop;
      end loop;
      add_range(first, nwords);
   end;
                                                                       ----------- get_file()
   procedure get_file is
      ch : character;
   begin
      while not end_of_file loop
         get(ch); -- raises ADA.IO_EXCEPTIONS.END_ERROR if last line is empty
         ch := to_upper(ch);
         if (ch in 'A'..'Z') then
            text_len       := text_len + 1;
            text(text_len) := ch;
         end if;
      end loop;
   end;
                                                                       ----------- write_stats()
   procedure write_stats is
   begin
      put("string length = ");    put(text_len,    5);
      put(", comparisons = ");    put(comparisons, 5);
      new_line;
   end;
end anagramfinder;

You can reach me by email at “lars dash 7 dot sdu dot se” or by telephone +46 705 189090

View source for the content of this page.