with Ada.Exceptions; use Ada.Exceptions;
with Ada.IO_Exceptions; use Ada.IO_Exceptions;
with GNAT.Heap_Sort_A; use GNAT.Heap_Sort_A;
with GNAT.OS_Lib; use GNAT.OS_Lib;
with GNAT.Table;
package body GNAT.Perfect_Hash_Generators is
subtype Word_Id is Integer;
subtype Key_Id is Integer;
subtype Vertex_Id is Integer;
subtype Edge_Id is Integer;
subtype Table_Id is Integer;
No_Vertex : constant Vertex_Id := -1;
No_Edge : constant Edge_Id := -1;
No_Table : constant Table_Id := -1;
Max_Word_Length : constant := 32;
subtype Word_Type is String (1 .. Max_Word_Length);
Null_Word : constant Word_Type := (others => ASCII.NUL);
type Key_Type is record
Edge : Edge_Id;
end record;
type Vertex_Type is record
First : Edge_Id;
Last : Edge_Id;
end record;
type Edge_Type is record
X : Vertex_Id;
Y : Vertex_Id;
Key : Key_Id;
end record;
package WT is new GNAT.Table (Word_Type, Word_Id, 0, 32, 32);
package IT is new GNAT.Table (Integer, Integer, 0, 32, 32);
function Image (Int : Integer; W : Natural := 0) return String;
function Image (Str : String; W : Natural := 0) return String;
Output : File_Descriptor renames GNAT.OS_Lib.Standout;
Max : constant := 78;
Last : Natural := 0;
Line : String (1 .. Max);
procedure Add (C : Character);
procedure Add (S : String);
procedure Put
(F : File_Descriptor;
S : String;
F1 : Natural;
L1 : Natural;
C1 : Natural;
F2 : Natural;
L2 : Natural;
C2 : Natural);
procedure New_Line
(F : File_Descriptor);
procedure Put
(F : File_Descriptor;
S : String);
procedure Put_Used_Char_Set
(File : File_Descriptor;
Title : String);
procedure Put_Int_Vector
(File : File_Descriptor;
Title : String;
Root : Integer;
Length : Natural);
procedure Put_Int_Matrix
(File : File_Descriptor;
Title : String;
Table : Table_Id);
procedure Put_Edges
(File : File_Descriptor;
Title : String);
procedure Put_Initial_Keys
(File : File_Descriptor;
Title : String);
procedure Put_Reduced_Keys
(File : File_Descriptor;
Title : String);
procedure Put_Vertex_Table
(File : File_Descriptor;
Title : String);
procedure Apply_Position_Selection;
procedure Parse_Position_Selection (Argument : String);
procedure Select_Character_Set;
procedure Select_Char_Position;
procedure Random (Seed : in out Natural);
procedure Generate_Mapping_Table
(T : Table_Id;
L1 : Natural;
L2 : Natural;
S : in out Natural);
procedure Generate_Mapping_Tables
(Opt : Optimization;
S : in out Natural);
procedure Compute_Edges_And_Vertices (Opt : Optimization);
function Acyclic return Boolean;
procedure Assign_Values_To_Vertices;
function Sum
(Word : Word_Type;
Table : Table_Id;
Opt : Optimization)
return Natural;
function Allocate (N : Natural; S : Natural) return Table_Id;
Key_Size : constant := 1;
Keys : Table_Id := No_Table;
NK : Natural;
function Initial (K : Key_Id) return Word_Id;
pragma Inline (Initial);
function Reduced (K : Key_Id) return Word_Id;
pragma Inline (Reduced);
function Get_Key (F : Key_Id) return Key_Type;
procedure Set_Key (F : Key_Id; Item : Key_Type);
Char_Pos_Size : constant := 1;
Char_Pos_Set : Table_Id := No_Table;
Char_Pos_Set_Len : Natural;
function Get_Char_Pos (P : Natural) return Natural;
procedure Set_Char_Pos (P : Natural; Item : Natural);
Used_Char_Size : constant := 1;
Used_Char_Set : Table_Id := No_Table;
Used_Char_Set_Len : Natural;
function Get_Used_Char (C : Character) return Natural;
procedure Set_Used_Char (C : Character; Item : Natural);
Rand_Tab_Item_Size : constant := 1;
T1 : Table_Id := No_Table;
T2 : Table_Id := No_Table;
Rand_Tab_Len_1 : Natural;
Rand_Tab_Len_2 : Natural;
function Get_Rand_Tab (T : Integer; X, Y : Natural) return Natural;
procedure Set_Rand_Tab (T : Integer; X, Y : Natural; Item : Natural);
Graph_Item_Size : constant := 1;
G : Table_Id := No_Table;
Graph_Len : Natural;
function Get_Graph (F : Natural) return Integer;
procedure Set_Graph (F : Natural; Item : Integer);
Edge_Size : constant := 3;
Edges : Table_Id := No_Table;
Edges_Len : Natural;
function Get_Edges (F : Natural) return Edge_Type;
procedure Set_Edges (F : Natural; Item : Edge_Type);
Vertex_Size : constant := 2;
Vertices : Table_Id := No_Table;
NV : Natural;
function Get_Vertices (F : Natural) return Vertex_Type;
procedure Set_Vertices (F : Natural; Item : Vertex_Type);
K2V : Float;
Opt : Optimization;
MKL : Natural;
S : Natural;
function Type_Size (L : Natural) return Natural;
function Acyclic return Boolean
is
Marks : array (0 .. NV - 1) of Vertex_Id := (others => No_Vertex);
function Traverse
(Edge : Edge_Id;
Mark : Vertex_Id)
return Boolean;
function Traverse
(Edge : Edge_Id;
Mark : Vertex_Id)
return Boolean
is
E : constant Edge_Type := Get_Edges (Edge);
K : constant Key_Id := E.Key;
Y : constant Vertex_Id := E.Y;
M : constant Vertex_Id := Marks (E.Y);
V : Vertex_Type;
begin
if M = Mark then
return False;
elsif M = No_Vertex then
Marks (Y) := Mark;
V := Get_Vertices (Y);
for J in V.First .. V.Last loop
if Get_Edges (J).Key /= K
and then not Traverse (J, Mark)
then
return False;
end if;
end loop;
end if;
return True;
end Traverse;
Edge : Edge_Type;
begin
for J in 1 .. Edges_Len - 1 loop
Edge := Get_Edges (J);
if Marks (Edge.X) = No_Vertex then
Marks (Edge.X) := Edge.X;
end if;
if Marks (Edge.Y) = No_Vertex
and then not Traverse (J, Edge.X)
then
return False;
end if;
end loop;
return True;
end Acyclic;
procedure Add (C : Character) is
begin
Line (Last + 1) := C;
Last := Last + 1;
end Add;
procedure Add (S : String) is
Len : constant Natural := S'Length;
begin
Line (Last + 1 .. Last + Len) := S;
Last := Last + Len;
end Add;
function Allocate (N : Natural; S : Natural) return Table_Id is
L : constant Integer := IT.Last;
begin
IT.Set_Last (L + N * S);
return L + 1;
end Allocate;
procedure Apply_Position_Selection is
begin
WT.Set_Last (2 * NK - 1);
for J in 0 .. NK - 1 loop
declare
I_Word : constant Word_Type := WT.Table (Initial (J));
R_Word : Word_Type := Null_Word;
Index : Natural := I_Word'First - 1;
begin
for C in 0 .. Char_Pos_Set_Len - 1 loop
exit when I_Word (Get_Char_Pos (C)) = ASCII.NUL;
Index := Index + 1;
R_Word (Index) := I_Word (Get_Char_Pos (C));
end loop;
WT.Table (Reduced (J)) := R_Word;
Set_Key (J, (Edge => No_Edge));
end;
end loop;
end Apply_Position_Selection;
procedure Compute (Position : String := Default_Position) is
begin
Keys := Allocate (NK, Key_Size);
if Verbose then
Put_Initial_Keys (Output, "Initial Key Table");
end if;
if Position'Length /= 0 then
Parse_Position_Selection (Position);
else
Select_Char_Position;
end if;
if Verbose then
Put_Int_Vector
(Output, "Char Position Set", Char_Pos_Set, Char_Pos_Set_Len);
end if;
Apply_Position_Selection;
if Verbose then
Put_Reduced_Keys (Output, "Reduced Keys Table");
end if;
Select_Character_Set;
if Verbose then
Put_Used_Char_Set (Output, "Character Position Table");
end if;
loop
Generate_Mapping_Tables (Opt, S);
Compute_Edges_And_Vertices (Opt);
exit when 0 < Edges_Len and then Acyclic;
end loop;
Assign_Values_To_Vertices;
end Compute;
procedure Assign_Values_To_Vertices is
X : Vertex_Id;
procedure Assign (X : Vertex_Id);
procedure Assign (X : Vertex_Id)
is
E : Edge_Type;
V : constant Vertex_Type := Get_Vertices (X);
begin
for J in V.First .. V.Last loop
E := Get_Edges (J);
if Get_Graph (E.Y) = -1 then
Set_Graph (E.Y, (E.Key - Get_Graph (X)) mod NK);
Assign (E.Y);
end if;
end loop;
end Assign;
begin
if G = No_Table then
Graph_Len := NV;
G := Allocate (Graph_Len, Graph_Item_Size);
end if;
for J in 0 .. Graph_Len - 1 loop
Set_Graph (J, -1);
end loop;
for K in 0 .. NK - 1 loop
X := Get_Edges (Get_Key (K).Edge).X;
if Get_Graph (X) = -1 then
Set_Graph (X, 0);
Assign (X);
end if;
end loop;
for J in 0 .. Graph_Len - 1 loop
if Get_Graph (J) = -1 then
Set_Graph (J, 0);
end if;
end loop;
if Verbose then
Put_Int_Vector (Output, "Assign Values To Vertices", G, Graph_Len);
end if;
end Assign_Values_To_Vertices;
procedure Compute_Edges_And_Vertices (Opt : Optimization) is
X : Natural;
Y : Natural;
Key : Key_Type;
Edge : Edge_Type;
Vertex : Vertex_Type;
Not_Acyclic : Boolean := False;
procedure Move (From : Natural; To : Natural);
function Lt (L, R : Natural) return Boolean;
procedure Move (From : Natural; To : Natural) is
begin
Set_Edges (To, Get_Edges (From));
end Move;
function Lt (L, R : Natural) return Boolean is
EL : constant Edge_Type := Get_Edges (L);
ER : constant Edge_Type := Get_Edges (R);
begin
return EL.X < ER.X or else (EL.X = ER.X and then EL.Y < ER.Y);
end Lt;
begin
Edges_Len := 2 * NK + 1;
if Edges = No_Table then
Edges := Allocate (Edges_Len, Edge_Size);
end if;
if Vertices = No_Table then
Vertices := Allocate (NV, Vertex_Size);
end if;
for J in 0 .. NV - 1 loop
Set_Vertices (J, (No_Vertex, No_Vertex - 1));
end loop;
for J in 0 .. NK - 1 loop
Key := Get_Key (J);
Key.Edge := No_Edge;
Set_Key (J, Key);
X := Sum (WT.Table (Reduced (J)), T1, Opt);
Y := Sum (WT.Table (Reduced (J)), T2, Opt);
if X = Y then
Not_Acyclic := True;
exit;
end if;
Set_Edges (2 * J + 1, (X, Y, J));
Set_Edges (2 * J + 2, (Y, X, J));
end loop;
if Not_Acyclic then
Edges_Len := 0;
else
if Verbose then
Put_Edges (Output, "Unsorted Edge Table");
Put_Int_Matrix (Output, "Function Table 1", T1);
Put_Int_Matrix (Output, "Function Table 2", T2);
end if;
Sort
(Edges_Len - 1,
Move'Unrestricted_Access,
Lt'Unrestricted_Access);
if Verbose then
Put_Edges (Output, "Sorted Edge Table");
Put_Int_Matrix (Output, "Function Table 1", T1);
Put_Int_Matrix (Output, "Function Table 2", T2);
end if;
for E in 1 .. Edges_Len - 1 loop
Edge := Get_Edges (E);
Key := Get_Key (Edge.Key);
if Key.Edge = No_Edge then
Key.Edge := E;
Set_Key (Edge.Key, Key);
end if;
Vertex := Get_Vertices (Edge.X);
if Vertex.First = No_Edge then
Vertex.First := E;
end if;
Vertex.Last := E;
Set_Vertices (Edge.X, Vertex);
end loop;
if Verbose then
Put_Reduced_Keys (Output, "Key Table");
Put_Edges (Output, "Edge Table");
Put_Vertex_Table (Output, "Vertex Table");
end if;
end if;
end Compute_Edges_And_Vertices;
procedure Define
(Name : Table_Name;
Item_Size : out Natural;
Length_1 : out Natural;
Length_2 : out Natural)
is
begin
case Name is
when Character_Position =>
Item_Size := 8;
Length_1 := Char_Pos_Set_Len;
Length_2 := 0;
when Used_Character_Set =>
Item_Size := 8;
Length_1 := 256;
Length_2 := 0;
when Function_Table_1
| Function_Table_2 =>
Item_Size := Type_Size (NV);
Length_1 := Rand_Tab_Len_1;
Length_2 := Rand_Tab_Len_2;
when Graph_Table =>
Item_Size := Type_Size (NK);
Length_1 := NV;
Length_2 := 0;
end case;
end Define;
procedure Finalize is
begin
WT.Release;
IT.Release;
Keys := No_Table;
NK := 0;
Char_Pos_Set := No_Table;
Char_Pos_Set_Len := 0;
Used_Char_Set := No_Table;
Used_Char_Set_Len := 0;
T1 := No_Table;
T2 := No_Table;
Rand_Tab_Len_1 := 0;
Rand_Tab_Len_2 := 0;
G := No_Table;
Graph_Len := 0;
Edges := No_Table;
Edges_Len := 0;
Vertices := No_Table;
NV := 0;
end Finalize;
procedure Generate_Mapping_Table
(T : Integer;
L1 : Natural;
L2 : Natural;
S : in out Natural)
is
begin
for J in 0 .. L1 - 1 loop
for K in 0 .. L2 - 1 loop
Random (S);
Set_Rand_Tab (T, J, K, S mod NV);
end loop;
end loop;
end Generate_Mapping_Table;
procedure Generate_Mapping_Tables
(Opt : Optimization;
S : in out Natural)
is
begin
if T1 = No_Table and then T2 = No_Table then
declare
Used_Char_Last : Natural := 0;
Used_Char : Natural;
begin
if Opt = CPU_Time then
for P in reverse Character'Range loop
Used_Char := Get_Used_Char (P);
if Used_Char /= 0 then
Used_Char_Last := Used_Char;
exit;
end if;
end loop;
end if;
Rand_Tab_Len_1 := Char_Pos_Set_Len;
Rand_Tab_Len_2 := Used_Char_Last + 1;
T1 := Allocate (Rand_Tab_Len_1 * Rand_Tab_Len_2,
Rand_Tab_Item_Size);
T2 := Allocate (Rand_Tab_Len_1 * Rand_Tab_Len_2,
Rand_Tab_Item_Size);
end;
end if;
Generate_Mapping_Table (T1, Rand_Tab_Len_1, Rand_Tab_Len_2, S);
Generate_Mapping_Table (T2, Rand_Tab_Len_1, Rand_Tab_Len_2, S);
if Verbose then
Put_Used_Char_Set (Output, "Used Character Set");
Put_Int_Matrix (Output, "Function Table 1", T1);
Put_Int_Matrix (Output, "Function Table 2", T2);
end if;
end Generate_Mapping_Tables;
function Get_Char_Pos (P : Natural) return Natural is
N : constant Natural := Char_Pos_Set + P;
begin
return IT.Table (N);
end Get_Char_Pos;
function Get_Edges (F : Natural) return Edge_Type is
N : constant Natural := Edges + (F * Edge_Size);
E : Edge_Type;
begin
E.X := IT.Table (N);
E.Y := IT.Table (N + 1);
E.Key := IT.Table (N + 2);
return E;
end Get_Edges;
function Get_Graph (F : Natural) return Integer is
N : constant Natural := G + F * Graph_Item_Size;
begin
return IT.Table (N);
end Get_Graph;
function Get_Key (F : Key_Id) return Key_Type is
N : constant Natural := Keys + F * Key_Size;
K : Key_Type;
begin
K.Edge := IT.Table (N);
return K;
end Get_Key;
function Get_Rand_Tab (T : Integer; X, Y : Natural) return Natural is
N : constant Natural :=
T + ((Y * Rand_Tab_Len_1) + X) * Rand_Tab_Item_Size;
begin
return IT.Table (N);
end Get_Rand_Tab;
function Get_Used_Char (C : Character) return Natural is
N : constant Natural :=
Used_Char_Set + Character'Pos (C) * Used_Char_Size;
begin
return IT.Table (N);
end Get_Used_Char;
function Get_Vertices (F : Natural) return Vertex_Type is
N : constant Natural := Vertices + (F * Vertex_Size);
V : Vertex_Type;
begin
V.First := IT.Table (N);
V.Last := IT.Table (N + 1);
return V;
end Get_Vertices;
function Image (Int : Integer; W : Natural := 0) return String is
B : String (1 .. 32);
L : Natural := 0;
procedure Img (V : Natural);
procedure Img (V : Natural) is
begin
if V > 9 then
Img (V / 10);
end if;
L := L + 1;
B (L) := Character'Val ((V mod 10) + Character'Pos ('0'));
end Img;
begin
if Int < 0 then
L := L + 1;
B (L) := '-';
Img (-Int);
else
Img (Int);
end if;
return Image (B (1 .. L), W);
end Image;
function Image (Str : String; W : Natural := 0) return String is
Len : constant Natural := Str'Length;
Max : Natural := Len;
begin
if Max < W then
Max := W;
end if;
declare
Buf : String (1 .. Max) := (1 .. Max => ' ');
begin
for J in 0 .. Len - 1 loop
Buf (Max - Len + 1 + J) := Str (Str'First + J);
end loop;
return Buf;
end;
end Image;
function Initial (K : Key_Id) return Word_Id is
begin
return K;
end Initial;
procedure Initialize
(Seed : Natural;
K_To_V : Float := Default_K_To_V;
Optim : Optimization := CPU_Time)
is
begin
WT.Init;
IT.Init;
S := Seed;
Keys := No_Table;
NK := 0;
Char_Pos_Set := No_Table;
Char_Pos_Set_Len := 0;
K2V := K_To_V;
Opt := Optim;
MKL := 0;
end Initialize;
procedure Insert
(Value : String)
is
Word : Word_Type := Null_Word;
Len : constant Natural := Value'Length;
begin
Word (1 .. Len) := Value (Value'First .. Value'First + Len - 1);
WT.Set_Last (NK);
WT.Table (NK) := Word;
NK := NK + 1;
NV := Natural (Float (NK) * K2V);
if MKL < Len then
MKL := Len;
end if;
end Insert;
procedure New_Line (F : File_Descriptor) is
EOL : constant Character := ASCII.LF;
begin
if Write (F, EOL'Address, 1) /= 1 then
raise Program_Error;
end if;
end New_Line;
procedure Parse_Position_Selection (Argument : String) is
N : Natural := Argument'First;
L : constant Natural := Argument'Last;
M : constant Natural := MKL;
T : array (1 .. M) of Boolean := (others => False);
function Parse_Index return Natural;
function Parse_Index return Natural
is
C : Character := Argument (N);
V : Natural := 0;
begin
if C = '$' then
N := N + 1;
return M;
end if;
if C not in '0' .. '9' then
Raise_Exception
(Program_Error'Identity, "cannot read position argument");
end if;
while C in '0' .. '9' loop
V := V * 10 + (Character'Pos (C) - Character'Pos ('0'));
N := N + 1;
exit when L < N;
C := Argument (N);
end loop;
return V;
end Parse_Index;
begin
Char_Pos_Set_Len := 2 * NK;
if L < N then
Char_Pos_Set_Len := M;
Char_Pos_Set := Allocate (Char_Pos_Set_Len, Char_Pos_Size);
for C in 0 .. Char_Pos_Set_Len - 1 loop
Set_Char_Pos (C, C + 1);
end loop;
else
loop
declare
First, Last : Natural;
begin
First := Parse_Index;
Last := First;
if N <= L and then Argument (N) = '-' then
N := N + 1;
Last := Parse_Index;
end if;
for J in First .. Last loop
T (J) := True;
end loop;
end;
exit when L < N;
if Argument (N) /= ',' then
Raise_Exception
(Program_Error'Identity, "cannot read position argument");
end if;
N := N + 1;
end loop;
N := 0;
for J in T'Range loop
if T (J) then
N := N + 1;
end if;
end loop;
Char_Pos_Set_Len := N;
Char_Pos_Set := Allocate (Char_Pos_Set_Len, Char_Pos_Size);
N := 0;
for J in T'Range loop
if T (J) then
Set_Char_Pos (N, J);
N := N + 1;
end if;
end loop;
end if;
end Parse_Position_Selection;
procedure Produce (Pkg_Name : String := Default_Pkg_Name) is
File : File_Descriptor;
Status : Boolean;
function Type_Img (L : Natural) return String;
function Range_Img (F, L : Natural; T : String := "") return String;
function Array_Img (N, T, R1 : String; R2 : String := "") return String;
function Type_Img (L : Natural) return String is
S : constant String := Image (Type_Size (L));
U : String := "Unsigned_ ";
N : Natural := 9;
begin
for J in S'Range loop
N := N + 1;
U (N) := S (J);
end loop;
return U (1 .. N);
end Type_Img;
function Range_Img (F, L : Natural; T : String := "") return String is
FI : constant String := Image (F);
FL : constant Natural := FI'Length;
LI : constant String := Image (L);
LL : constant Natural := LI'Length;
TL : constant Natural := T'Length;
RI : String (1 .. TL + 7 + FL + 4 + LL);
Len : Natural := 0;
begin
if TL /= 0 then
RI (Len + 1 .. Len + TL) := T;
Len := Len + TL;
RI (Len + 1 .. Len + 7) := " range ";
Len := Len + 7;
end if;
RI (Len + 1 .. Len + FL) := FI;
Len := Len + FL;
RI (Len + 1 .. Len + 4) := " .. ";
Len := Len + 4;
RI (Len + 1 .. Len + LL) := LI;
Len := Len + LL;
return RI (1 .. Len);
end Range_Img;
function Array_Img
(N, T, R1 : String;
R2 : String := "")
return String
is
begin
Last := 0;
Add (" ");
Add (N);
Add (" : constant array (");
Add (R1);
if R2 /= "" then
Add (", ");
Add (R2);
end if;
Add (") of ");
Add (T);
Add (" :=");
return Line (1 .. Last);
end Array_Img;
F : Natural;
L : Natural;
P : Natural;
PLen : constant Natural := Pkg_Name'Length;
FName : String (1 .. PLen + 4);
begin
FName (1 .. PLen) := Pkg_Name;
for J in 1 .. PLen loop
if FName (J) in 'A' .. 'Z' then
FName (J) := Character'Val (Character'Pos (FName (J))
- Character'Pos ('A')
+ Character'Pos ('a'));
elsif FName (J) = '.' then
FName (J) := '-';
end if;
end loop;
FName (PLen + 1 .. PLen + 4) := ".ads";
File := Create_File (FName, Text);
Put (File, "package ");
Put (File, Pkg_Name);
Put (File, " is");
New_Line (File);
Put (File, " function Hash (S : String) return Natural;");
New_Line (File);
Put (File, "end ");
Put (File, Pkg_Name);
Put (File, ";");
New_Line (File);
Close (File, Status);
if not Status then
raise Device_Error;
end if;
FName (PLen + 4) := 'b';
File := Create_File (FName, Text);
Put (File, "with Interfaces; use Interfaces;");
New_Line (File);
New_Line (File);
Put (File, "package body ");
Put (File, Pkg_Name);
Put (File, " is");
New_Line (File);
New_Line (File);
if Opt = CPU_Time then
Put (File, Array_Img ("C", Type_Img (256), "Character"));
New_Line (File);
F := Character'Pos (Character'First);
L := Character'Pos (Character'Last);
for J in Character'Range loop
P := Get_Used_Char (J);
Put (File, Image (P), 0, 0, 0, F, L, Character'Pos (J));
end loop;
New_Line (File);
end if;
F := 0;
L := Char_Pos_Set_Len - 1;
Put (File, Array_Img ("P", "Natural", Range_Img (F, L)));
New_Line (File);
for J in F .. L loop
Put (File, Image (Get_Char_Pos (J)), 0, 0, 0, F, L, J);
end loop;
New_Line (File);
if Opt = CPU_Time then
Put_Int_Matrix
(File,
Array_Img ("T1", Type_Img (NV),
Range_Img (0, Rand_Tab_Len_1 - 1),
Range_Img (0, Rand_Tab_Len_2 - 1,
Type_Img (256))),
T1);
else
Put_Int_Matrix
(File,
Array_Img ("T1", Type_Img (NV),
Range_Img (0, Rand_Tab_Len_1 - 1)),
T1);
end if;
New_Line (File);
if Opt = CPU_Time then
Put_Int_Matrix
(File,
Array_Img ("T2", Type_Img (NV),
Range_Img (0, Rand_Tab_Len_1 - 1),
Range_Img (0, Rand_Tab_Len_2 - 1,
Type_Img (256))),
T2);
else
Put_Int_Matrix
(File,
Array_Img ("T2", Type_Img (NV),
Range_Img (0, Rand_Tab_Len_1 - 1)),
T2);
end if;
New_Line (File);
Put_Int_Vector
(File,
Array_Img ("G", Type_Img (NK),
Range_Img (0, Graph_Len - 1)),
G, Graph_Len);
New_Line (File);
Put (File, " function Hash (S : String) return Natural is");
New_Line (File);
Put (File, " F : constant Natural := S'First - 1;");
New_Line (File);
Put (File, " L : constant Natural := S'Length;");
New_Line (File);
Put (File, " F1, F2 : Natural := 0;");
New_Line (File);
Put (File, " J : ");
if Opt = CPU_Time then
Put (File, Type_Img (256));
else
Put (File, "Natural");
end if;
Put (File, ";");
New_Line (File);
Put (File, " begin");
New_Line (File);
Put (File, " for K in P'Range loop");
New_Line (File);
Put (File, " exit when L < P (K);");
New_Line (File);
Put (File, " J := ");
if Opt = CPU_Time then
Put (File, "C");
else
Put (File, "Character'Pos");
end if;
Put (File, " (S (P (K) + F));");
New_Line (File);
Put (File, " F1 := (F1 + Natural (T1 (K");
if Opt = CPU_Time then
Put (File, ", J");
end if;
Put (File, "))");
if Opt = Memory_Space then
Put (File, " * J");
end if;
Put (File, ") mod ");
Put (File, Image (NV));
Put (File, ";");
New_Line (File);
Put (File, " F2 := (F2 + Natural (T2 (K");
if Opt = CPU_Time then
Put (File, ", J");
end if;
Put (File, "))");
if Opt = Memory_Space then
Put (File, " * J");
end if;
Put (File, ") mod ");
Put (File, Image (NV));
Put (File, ";");
New_Line (File);
Put (File, " end loop;");
New_Line (File);
Put (File,
" return (Natural (G (F1)) + Natural (G (F2))) mod ");
Put (File, Image (NK));
Put (File, ";");
New_Line (File);
Put (File, " end Hash;");
New_Line (File);
New_Line (File);
Put (File, "end ");
Put (File, Pkg_Name);
Put (File, ";");
New_Line (File);
Close (File, Status);
if not Status then
raise Device_Error;
end if;
end Produce;
procedure Put (F : File_Descriptor; S : String) is
Len : constant Natural := S'Length;
begin
if Write (F, S'Address, Len) /= Len then
raise Program_Error;
end if;
end Put;
procedure Put
(F : File_Descriptor;
S : String;
F1 : Natural;
L1 : Natural;
C1 : Natural;
F2 : Natural;
L2 : Natural;
C2 : Natural)
is
Len : constant Natural := S'Length;
procedure Flush;
procedure Flush is
begin
Put (F, Line (1 .. Last));
New_Line (F);
Last := 0;
end Flush;
begin
if C1 = F1 and then C2 = F2 then
Last := 0;
end if;
if Last + Len + 3 > Max then
Flush;
end if;
if Last = 0 then
Line (Last + 1 .. Last + 5) := " ";
Last := Last + 5;
if F1 /= L1 then
if C1 = F1 and then C2 = F2 then
Add ('(');
else
Add (' ');
end if;
end if;
end if;
if C2 = F2 then
Add ('(');
else
Add (' ');
end if;
Line (Last + 1 .. Last + Len) := S;
Last := Last + Len;
if C2 = L2 then
Add (')');
if F1 = L1 then
Add (';');
Flush;
elsif C1 /= L1 then
Add (',');
Flush;
else
Add (')');
Add (';');
Flush;
end if;
else
Add (',');
end if;
end Put;
procedure Put_Used_Char_Set
(File : File_Descriptor;
Title : String)
is
F : constant Natural := Character'Pos (Character'First);
L : constant Natural := Character'Pos (Character'Last);
begin
Put (File, Title);
New_Line (File);
for J in Character'Range loop
Put
(File, Image (Get_Used_Char (J)), 0, 0, 0, F, L, Character'Pos (J));
end loop;
end Put_Used_Char_Set;
procedure Put_Int_Matrix
(File : File_Descriptor;
Title : String;
Table : Integer)
is
F1 : constant Natural := 0;
L1 : constant Natural := Rand_Tab_Len_1 - 1;
F2 : constant Natural := 0;
L2 : constant Natural := Rand_Tab_Len_2 - 1;
begin
Put (File, Title);
New_Line (File);
if L2 = F2 then
for J in F1 .. L1 loop
Put (File,
Image (Get_Rand_Tab (Table, J, F2)), 0, 0, 0, F1, L1, J);
end loop;
else
for J in F1 .. L1 loop
for K in F2 .. L2 loop
Put (File,
Image (Get_Rand_Tab (Table, J, K)), F1, L1, J, F2, L2, K);
end loop;
end loop;
end if;
end Put_Int_Matrix;
procedure Put_Int_Vector
(File : File_Descriptor;
Title : String;
Root : Integer;
Length : Natural)
is
F2 : constant Natural := 0;
L2 : constant Natural := Length - 1;
begin
Put (File, Title);
New_Line (File);
for J in F2 .. L2 loop
Put (File, Image (IT.Table (Root + J)), 0, 0, 0, F2, L2, J);
end loop;
end Put_Int_Vector;
procedure Put_Edges
(File : File_Descriptor;
Title : String)
is
E : Edge_Type;
F1 : constant Natural := 1;
L1 : constant Natural := Edges_Len - 1;
M : constant Natural := Max / 5;
begin
Put (File, Title);
New_Line (File);
for J in F1 .. L1 loop
E := Get_Edges (J);
Put (File, Image (J, M), F1, L1, J, 1, 4, 1);
Put (File, Image (E.X, M), F1, L1, J, 1, 4, 2);
Put (File, Image (E.Y, M), F1, L1, J, 1, 4, 3);
Put (File, Image (E.Key, M), F1, L1, J, 1, 4, 4);
end loop;
end Put_Edges;
procedure Put_Initial_Keys
(File : File_Descriptor;
Title : String)
is
F1 : constant Natural := 0;
L1 : constant Natural := NK - 1;
M : constant Natural := Max / 5;
K : Key_Type;
begin
Put (File, Title);
New_Line (File);
for J in F1 .. L1 loop
K := Get_Key (J);
Put (File, Image (J, M), F1, L1, J, 1, 3, 1);
Put (File, Image (K.Edge, M), F1, L1, J, 1, 3, 2);
Put (File, WT.Table (Initial (J)), F1, L1, J, 1, 3, 3);
end loop;
end Put_Initial_Keys;
procedure Put_Reduced_Keys
(File : File_Descriptor;
Title : String)
is
F1 : constant Natural := 0;
L1 : constant Natural := NK - 1;
M : constant Natural := Max / 5;
K : Key_Type;
begin
Put (File, Title);
New_Line (File);
for J in F1 .. L1 loop
K := Get_Key (J);
Put (File, Image (J, M), F1, L1, J, 1, 3, 1);
Put (File, Image (K.Edge, M), F1, L1, J, 1, 3, 2);
Put (File, WT.Table (Reduced (J)), F1, L1, J, 1, 3, 3);
end loop;
end Put_Reduced_Keys;
procedure Put_Vertex_Table
(File : File_Descriptor;
Title : String)
is
F1 : constant Natural := 0;
L1 : constant Natural := NV - 1;
M : constant Natural := Max / 4;
V : Vertex_Type;
begin
Put (File, Title);
New_Line (File);
for J in F1 .. L1 loop
V := Get_Vertices (J);
Put (File, Image (J, M), F1, L1, J, 1, 3, 1);
Put (File, Image (V.First, M), F1, L1, J, 1, 3, 2);
Put (File, Image (V.Last, M), F1, L1, J, 1, 3, 3);
end loop;
end Put_Vertex_Table;
procedure Random (Seed : in out Natural)
is
R : Natural;
Q : Natural;
X : Integer;
begin
R := Seed mod 127773;
Q := Seed / 127773;
X := 16807 * R - 2836 * Q;
if X < 0 then
Seed := X + 2147483647;
else
Seed := X;
end if;
end Random;
function Reduced (K : Key_Id) return Word_Id is
begin
return K + NK;
end Reduced;
procedure Select_Character_Set
is
Last : Natural := 0;
Used : array (Character) of Boolean := (others => False);
begin
for J in 0 .. NK - 1 loop
for K in 1 .. Max_Word_Length loop
exit when WT.Table (Initial (J))(K) = ASCII.NUL;
Used (WT.Table (Initial (J))(K)) := True;
end loop;
end loop;
Used_Char_Set_Len := 256;
Used_Char_Set := Allocate (Used_Char_Set_Len, Used_Char_Size);
for J in Used'Range loop
if Used (J) then
Set_Used_Char (J, Last);
Last := Last + 1;
else
Set_Used_Char (J, 0);
end if;
end loop;
end Select_Character_Set;
procedure Select_Char_Position is
type Vertex_Table_Type is array (Natural range <>) of Vertex_Type;
procedure Build_Identical_Keys_Sets
(Table : in out Vertex_Table_Type;
Last : in out Natural;
Pos : in Natural);
function Count_Identical_Keys
(Table : Vertex_Table_Type;
Last : Natural;
Pos : Natural)
return Natural;
Sel_Position : IT.Table_Type (1 .. MKL);
Last_Sel_Pos : Natural := 0;
procedure Build_Identical_Keys_Sets
(Table : in out Vertex_Table_Type;
Last : in out Natural;
Pos : in Natural)
is
S : constant Vertex_Table_Type := Table (1 .. Last);
C : constant Natural := Pos;
F : Integer;
L : Integer;
begin
Last := 0;
for J in S'Range loop
declare
Offset : Natural;
procedure Move (From : Natural; To : Natural);
function Lt (L, R : Natural) return Boolean;
procedure Move (From : Natural; To : Natural) is
Target, Source : Natural;
begin
if From = 0 then
Source := 0;
Target := Offset + To;
elsif To = 0 then
Source := Offset + From;
Target := 0;
else
Source := Offset + From;
Target := Offset + To;
end if;
WT.Table (Reduced (Target)) := WT.Table (Reduced (Source));
end Move;
function Lt (L, R : Natural) return Boolean is
C : constant Natural := Pos;
Left : Natural;
Right : Natural;
begin
if L = 0 then
Left := 0;
Right := Offset + R;
elsif R = 0 then
Left := Offset + L;
Right := 0;
else
Left := Offset + L;
Right := Offset + R;
end if;
return WT.Table (Reduced (Left))(C)
< WT.Table (Reduced (Right))(C);
end Lt;
begin
Offset := S (J).First - 1;
Sort
(S (J).Last - S (J).First + 1,
Move'Unrestricted_Access,
Lt'Unrestricted_Access);
F := -1;
L := -1;
for N in S (J).First .. S (J).Last - 1 loop
if WT.Table (Reduced (N))(C) =
WT.Table (Reduced (N + 1))(C)
then
if F = -1 then
F := N;
end if;
L := N + 1;
elsif F /= -1 then
Last := Last + 1;
Table (Last) := (F, L);
F := -1;
end if;
end loop;
if F /= -1 then
Last := Last + 1;
Table (Last) := (F, L);
end if;
end;
end loop;
end Build_Identical_Keys_Sets;
function Count_Identical_Keys
(Table : Vertex_Table_Type;
Last : Natural;
Pos : Natural)
return Natural
is
N : array (Character) of Natural;
C : Character;
T : Natural := 0;
begin
for S in 1 .. Last loop
N := (others => 0);
for K in Table (S).First .. Table (S).Last loop
C := WT.Table (Reduced (K))(Pos);
N (C) := N (C) + 1;
end loop;
for J in N'Range loop
if N (J) > 1 then
T := T + N (J);
end if;
end loop;
end loop;
return T;
end Count_Identical_Keys;
begin
for C in Sel_Position'Range loop
Sel_Position (C) := C;
end loop;
WT.Set_Last (2 * NK - 1);
for K in 0 .. NK - 1 loop
WT.Table (Reduced (K) + 1) := WT.Table (Initial (K));
end loop;
declare
Collisions : Natural;
Min_Collisions : Natural := NK;
Old_Collisions : Natural;
Min_Coll_Sel_Pos : Natural := 0; Min_Coll_Sel_Pos_Idx : Natural := 0; Same_Keys_Sets_Table : Vertex_Table_Type (1 .. NK);
Same_Keys_Sets_Last : Natural := 1;
begin
Same_Keys_Sets_Table (1) := (1, NK);
loop
Old_Collisions := Min_Collisions;
for J in Last_Sel_Pos + 1 .. Sel_Position'Last loop
Collisions := Count_Identical_Keys
(Same_Keys_Sets_Table,
Same_Keys_Sets_Last,
Sel_Position (J));
if Collisions < Min_Collisions then
Min_Collisions := Collisions;
Min_Coll_Sel_Pos := Sel_Position (J);
Min_Coll_Sel_Pos_Idx := J;
end if;
end loop;
if Old_Collisions = Min_Collisions then
Raise_Exception
(Program_Error'Identity, "some keys are identical");
end if;
Last_Sel_Pos := Last_Sel_Pos + 1;
Sel_Position (Last_Sel_Pos + 1 .. Min_Coll_Sel_Pos_Idx) :=
Sel_Position (Last_Sel_Pos .. Min_Coll_Sel_Pos_Idx - 1);
Sel_Position (Last_Sel_Pos) := Min_Coll_Sel_Pos;
for P in 1 .. Last_Sel_Pos - 1 loop
if Min_Coll_Sel_Pos < Sel_Position (P) then
Sel_Position (P + 1 .. Last_Sel_Pos) :=
Sel_Position (P .. Last_Sel_Pos - 1);
Sel_Position (P) := Min_Coll_Sel_Pos;
exit;
end if;
end loop;
exit when Min_Collisions = 0;
Build_Identical_Keys_Sets
(Same_Keys_Sets_Table,
Same_Keys_Sets_Last,
Min_Coll_Sel_Pos);
end loop;
end;
Char_Pos_Set_Len := Last_Sel_Pos;
Char_Pos_Set := Allocate (Char_Pos_Set_Len, Char_Pos_Size);
for C in 1 .. Last_Sel_Pos loop
Set_Char_Pos (C - 1, Sel_Position (C));
end loop;
end Select_Char_Position;
procedure Set_Char_Pos (P : Natural; Item : Natural) is
N : constant Natural := Char_Pos_Set + P;
begin
IT.Table (N) := Item;
end Set_Char_Pos;
procedure Set_Edges (F : Natural; Item : Edge_Type) is
N : constant Natural := Edges + (F * Edge_Size);
begin
IT.Table (N) := Item.X;
IT.Table (N + 1) := Item.Y;
IT.Table (N + 2) := Item.Key;
end Set_Edges;
procedure Set_Graph (F : Natural; Item : Integer) is
N : constant Natural := G + (F * Graph_Item_Size);
begin
IT.Table (N) := Item;
end Set_Graph;
procedure Set_Key (F : Key_Id; Item : Key_Type) is
N : constant Natural := Keys + F * Key_Size;
begin
IT.Table (N) := Item.Edge;
end Set_Key;
procedure Set_Rand_Tab (T : Integer; X, Y : Natural; Item : Natural) is
N : constant Natural :=
T + ((Y * Rand_Tab_Len_1) + X) * Rand_Tab_Item_Size;
begin
IT.Table (N) := Item;
end Set_Rand_Tab;
procedure Set_Used_Char (C : Character; Item : Natural) is
N : constant Natural :=
Used_Char_Set + Character'Pos (C) * Used_Char_Size;
begin
IT.Table (N) := Item;
end Set_Used_Char;
procedure Set_Vertices (F : Natural; Item : Vertex_Type) is
N : constant Natural := Vertices + (F * Vertex_Size);
begin
IT.Table (N) := Item.First;
IT.Table (N + 1) := Item.Last;
end Set_Vertices;
function Sum
(Word : Word_Type;
Table : Table_Id;
Opt : Optimization)
return Natural
is
S : Natural := 0;
R : Natural;
begin
if Opt = CPU_Time then
for J in 0 .. Rand_Tab_Len_1 - 1 loop
exit when Word (J + 1) = ASCII.NUL;
R := Get_Rand_Tab (Table, J, Get_Used_Char (Word (J + 1)));
S := (S + R) mod NV;
end loop;
else
for J in 0 .. Rand_Tab_Len_1 - 1 loop
exit when Word (J + 1) = ASCII.NUL;
R := Get_Rand_Tab (Table, J, 0);
S := (S + R * Character'Pos (Word (J + 1))) mod NV;
end loop;
end if;
return S;
end Sum;
function Type_Size (L : Natural) return Natural is
begin
if L <= 2 ** 8 then
return 8;
elsif L <= 2 ** 16 then
return 16;
else
return 32;
end if;
end Type_Size;
function Value
(Name : Table_Name;
J : Natural;
K : Natural := 0)
return Natural
is
begin
case Name is
when Character_Position =>
return Get_Char_Pos (J);
when Used_Character_Set =>
return Get_Used_Char (Character'Val (J));
when Function_Table_1 =>
return Get_Rand_Tab (T1, J, K);
when Function_Table_2 =>
return Get_Rand_Tab (T2, J, K);
when Graph_Table =>
return Get_Graph (J);
end case;
end Value;
end GNAT.Perfect_Hash_Generators;