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