-- --
-- B o d y --
-- --
--- Copyright (C) 2002-2004 Ada Core Technologies, Inc. --
+-- Copyright (C) 2002-2011, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
--- As a special exception, if other files instantiate generics from this --
--- unit, or you link this unit with other files to produce an executable, --
--- this unit does not by itself cause the resulting executable to be --
--- covered by the GNU General Public License. This exception does not --
--- however invalidate any other reasons why the executable file might be --
--- covered by the GNU Public License. --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-with Ada.Exceptions; use Ada.Exceptions;
-with Ada.IO_Exceptions; use Ada.IO_Exceptions;
+with Ada.IO_Exceptions; use Ada.IO_Exceptions;
+with Ada.Characters.Handling; use Ada.Characters.Handling;
+with Ada.Directories;
-with GNAT.Heap_Sort_A; use GNAT.Heap_Sort_A;
+with GNAT.Heap_Sort_G;
with GNAT.OS_Lib; use GNAT.OS_Lib;
with GNAT.Table;
package body GNAT.Perfect_Hash_Generators is
- -- We are using the algorithm of J. Czech as described in Zbigniew
- -- J. Czech, George Havas, and Bohdan S. Majewski ``An Optimal
- -- Algorithm for Generating Minimal Perfect Hash Functions'',
- -- Information Processing Letters, 43(1992) pp.257-264, Oct.1992
+ -- We are using the algorithm of J. Czech as described in Zbigniew J.
+ -- Czech, George Havas, and Bohdan S. Majewski ``An Optimal Algorithm for
+ -- Generating Minimal Perfect Hash Functions'', Information Processing
+ -- Letters, 43(1992) pp.257-264, Oct.1992
- -- This minimal perfect hash function generator is based on random
- -- graphs and produces a hash function of the form:
+ -- This minimal perfect hash function generator is based on random graphs
+ -- and produces a hash function of the form:
-- h (w) = (g (f1 (w)) + g (f2 (w))) mod m
- -- where f1 and f2 are functions that map strings into integers,
- -- and g is a function that maps integers into [0, m-1]. h can be
- -- order preserving. For instance, let W = {w_0, ..., w_i, ...,
- -- w_m-1}, h can be defined such that h (w_i) = i.
+ -- where f1 and f2 are functions that map strings into integers, and g is
+ -- a function that maps integers into [0, m-1]. h can be order preserving.
+ -- For instance, let W = {w_0, ..., w_i, ..., w_m-1}, h can be defined
+ -- such that h (w_i) = i.
- -- This algorithm defines two possible constructions of f1 and
- -- f2. Method b) stores the hash function in less memory space at
- -- the expense of greater CPU time.
+ -- This algorithm defines two possible constructions of f1 and f2. Method
+ -- b) stores the hash function in less memory space at the expense of
+ -- greater CPU time.
-- a) fk (w) = sum (for i in 1 .. length (w)) (Tk (i, w (i))) mod n
-- b) fk (w) = sum (for i in 1 .. length (w)) (Tk (i) * w (i)) mod n
- -- size (Tk) = max (for w in W) (length (w)) but the table
- -- lookups are replaced by multiplications.
-
- -- where Tk values are randomly generated. n is defined later on
- -- but the algorithm recommends to use a value a little bit
- -- greater than 2m. Note that for large values of m, the main
- -- memory space requirements comes from the memory space for
- -- storing function g (>= 2m entries).
-
- -- Random graphs are frequently used to solve difficult problems
- -- that do not have polynomial solutions. This algorithm is based
- -- on a weighted undirected graph. It comprises two steps: mapping
- -- and assigment.
-
- -- In the mapping step, a graph G = (V, E) is constructed, where V
- -- = {0, 1, ..., n-1} and E = {(for w in W) (f1 (w), f2 (w))}. In
- -- order for the assignment step to be successful, G has to be
- -- acyclic. To have a high probability of generating an acyclic
- -- graph, n >= 2m. If it is not acyclic, Tk have to be regenerated.
-
- -- In the assignment step, the algorithm builds function g. As G
- -- is acyclic, there is a vertex v1 with only one neighbor v2. Let
- -- w_i be the word such that v1 = f1 (w_i) and v2 = f2 (w_i). Let
- -- g (v1) = 0 by construction and g (v2) = (i - g (v1)) mod n (or
- -- to be general, (h (i) - g (v1) mod n). If word w_j is such that
- -- v2 = f1 (w_j) and v3 = f2 (w_j), g (v3) = (j - g (v2)) mod n
- -- (or to be general, (h (j) - g (v2)) mod n). If w_i has no
- -- neighbor, then another vertex is selected. The algorithm
- -- traverses G to assign values to all the vertices. It cannot
- -- assign a value to an already assigned vertex as G is acyclic.
+ -- size (Tk) = max (for w in W) (length (w)) but the table lookups are
+ -- replaced by multiplications.
+
+ -- where Tk values are randomly generated. n is defined later on but the
+ -- algorithm recommends to use a value a little bit greater than 2m. Note
+ -- that for large values of m, the main memory space requirements comes
+ -- from the memory space for storing function g (>= 2m entries).
+
+ -- Random graphs are frequently used to solve difficult problems that do
+ -- not have polynomial solutions. This algorithm is based on a weighted
+ -- undirected graph. It comprises two steps: mapping and assignment.
+
+ -- In the mapping step, a graph G = (V, E) is constructed, where = {0, 1,
+ -- ..., n-1} and E = {(for w in W) (f1 (w), f2 (w))}. In order for the
+ -- assignment step to be successful, G has to be acyclic. To have a high
+ -- probability of generating an acyclic graph, n >= 2m. If it is not
+ -- acyclic, Tk have to be regenerated.
+
+ -- In the assignment step, the algorithm builds function g. As G is
+ -- acyclic, there is a vertex v1 with only one neighbor v2. Let w_i be
+ -- the word such that v1 = f1 (w_i) and v2 = f2 (w_i). Let g (v1) = 0 by
+ -- construction and g (v2) = (i - g (v1)) mod n (or h (i) - g (v1) mod n).
+ -- If word w_j is such that v2 = f1 (w_j) and v3 = f2 (w_j), g (v3) = (j -
+ -- g (v2)) mod (or to be general, (h (j) - g (v2)) mod n). If w_i has no
+ -- neighbor, then another vertex is selected. The algorithm traverses G to
+ -- assign values to all the vertices. It cannot assign a value to an
+ -- already assigned vertex as G is acyclic.
subtype Word_Id is Integer;
subtype Key_Id is Integer;
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);
- -- Store keyword in a word. Note that the length of word is
- -- limited to 32 characters.
+ type Word_Type is new String_Access;
+ procedure Free_Word (W : in out Word_Type) renames Free;
+ function New_Word (S : String) return Word_Type;
+
+ procedure Resize_Word (W : in out Word_Type; Len : Natural);
+ -- Resize string W to have a length Len
type Key_Type is record
Edge : Edge_Id;
end record;
- -- A key corresponds to an edge in the algorithm graph.
+ -- A key corresponds to an edge in the algorithm graph
type Vertex_Type is record
First : Edge_Id;
Last : Edge_Id;
end record;
- -- A vertex can be involved in several edges. First and Last are
- -- the bounds of an array of edges stored in a global edge table.
+ -- A vertex can be involved in several edges. First and Last are the bounds
+ -- of an array of edges stored in a global edge table.
type Edge_Type is record
X : Vertex_Id;
Y : Vertex_Id;
Key : Key_Id;
end record;
- -- An edge is a peer of vertices. In the algorithm, a key
- -- is associated to an edge.
+ -- An edge is a peer of vertices. In the algorithm, a key is associated to
+ -- an edge.
package WT is new GNAT.Table (Word_Type, Word_Id, 0, 32, 32);
package IT is new GNAT.Table (Integer, Integer, 0, 32, 32);
- -- The two main tables. IT is used to store several tables of
- -- components containing only integers.
+ -- The two main tables. WT is used to store the words in their initial
+ -- version and in their reduced version (that is words reduced to their
+ -- significant characters). As an instance of GNAT.Table, WT does not
+ -- initialize string pointers to null. This initialization has to be done
+ -- manually when the table is allocated. IT is used to store several
+ -- tables of components containing only integers.
function Image (Int : Integer; W : Natural := 0) return String;
function Image (Str : String; W : Natural := 0) return String;
- -- Return a string which includes string Str or integer Int
- -- preceded by leading spaces if required by width W.
+ -- Return a string which includes string Str or integer Int preceded by
+ -- leading spaces if required by width W.
+
+ function Trim_Trailing_Nuls (Str : String) return String;
+ -- Return Str with trailing NUL characters removed
Output : File_Descriptor renames GNAT.OS_Lib.Standout;
-- Shortcuts
+ EOL : constant Character := ASCII.LF;
+
Max : constant := 78;
Last : Natural := 0;
Line : String (1 .. Max);
F2 : Natural;
L2 : Natural;
C2 : Natural);
- -- Write string S into file F as a element of an array of one or
- -- two dimensions. Fk (resp. Lk and Ck) indicates the first (resp
- -- last and current) index in the k-th dimension. If F1 = L1 the
- -- array is considered as a one dimension array. This dimension is
- -- described by F2 and L2. This routine takes care of all the
- -- parenthesis, spaces and commas needed to format correctly the
- -- array. Moreover, the array is well indented and is wrapped to
- -- fit in a 80 col line. When the line is full, the routine writes
- -- it into file F. When the array is completed, the routine adds a
+ -- Write string S into file F as a element of an array of one or two
+ -- dimensions. Fk (resp. Lk and Ck) indicates the first (resp last and
+ -- current) index in the k-th dimension. If F1 = L1 the array is considered
+ -- as a one dimension array. This dimension is described by F2 and L2. This
+ -- routine takes care of all the parenthesis, spaces and commas needed to
+ -- format correctly the array. Moreover, the array is well indented and is
+ -- wrapped to fit in a 80 col line. When the line is full, the routine
+ -- writes it into file F. When the array is completed, the routine adds
-- semi-colon and writes the line into file F.
- procedure New_Line
- (F : File_Descriptor);
+ procedure New_Line (File : File_Descriptor);
-- Simulate Ada.Text_IO.New_Line with GNAT.OS_Lib
- procedure Put
- (F : File_Descriptor;
- S : String);
+ procedure Put (File : File_Descriptor; Str : String);
-- Simulate Ada.Text_IO.Put with GNAT.OS_Lib
- procedure Put_Used_Char_Set
- (File : File_Descriptor;
- Title : String);
+ procedure Put_Used_Char_Set (File : File_Descriptor; Title : String);
-- Output a title and a used character set
procedure Put_Int_Vector
(File : File_Descriptor;
Title : String;
- Root : Integer;
+ Vector : Integer;
Length : Natural);
-- Output a title and a vector
procedure Put_Int_Matrix
(File : File_Descriptor;
Title : String;
- Table : Table_Id);
- -- Output a title and a matrix. When the matrix has only one
- -- non-empty dimension, it is output as a vector.
+ Table : Table_Id;
+ Len_1 : Natural;
+ Len_2 : Natural);
+ -- Output a title and a matrix. When the matrix has only one non-empty
+ -- dimension (Len_2 = 0), output a vector.
- procedure Put_Edges
- (File : File_Descriptor;
- Title : String);
+ procedure Put_Edges (File : File_Descriptor; Title : String);
-- Output a title and an edge table
- procedure Put_Initial_Keys
- (File : File_Descriptor;
- Title : String);
+ procedure Put_Initial_Keys (File : File_Descriptor; Title : String);
-- Output a title and a key table
- procedure Put_Reduced_Keys
- (File : File_Descriptor;
- Title : String);
+ procedure Put_Reduced_Keys (File : File_Descriptor; Title : String);
-- Output a title and a key table
- procedure Put_Vertex_Table
- (File : File_Descriptor;
- Title : String);
+ procedure Put_Vertex_Table (File : File_Descriptor; Title : String);
-- Output a title and a vertex table
+ function Ada_File_Base_Name (Pkg_Name : String) return String;
+ -- Return the base file name (i.e. without .ads/.adb extension) for an
+ -- Ada source file containing the named package, using the standard GNAT
+ -- file-naming convention. For example, if Pkg_Name is "Parent.Child", we
+ -- return "parent-child".
+
----------------------------------
-- Character Position Selection --
----------------------------------
- -- We reduce the maximum key size by selecting representative
- -- positions in these keys. We build a matrix with one word per
- -- line. We fill the remaining space of a line with ASCII.NUL. The
- -- heuristic selects the position that induces the minimum number
- -- of collisions. If there are collisions, select another position
- -- on the reduced key set responsible of the collisions. Apply the
- -- heuristic until there is no more collision.
+ -- We reduce the maximum key size by selecting representative positions
+ -- in these keys. We build a matrix with one word per line. We fill the
+ -- remaining space of a line with ASCII.NUL. The heuristic selects the
+ -- position that induces the minimum number of collisions. If there are
+ -- collisions, select another position on the reduced key set responsible
+ -- of the collisions. Apply the heuristic until there is no more collision.
procedure Apply_Position_Selection;
-- Apply Position selection and build the reduced key table
procedure Parse_Position_Selection (Argument : String);
- -- Parse Argument and compute the position set. Argument is a
- -- list of substrings separated by commas. Each substring
- -- represents a position or a range of positions (like x-y).
+ -- Parse Argument and compute the position set. Argument is list of
+ -- substrings separated by commas. Each substring represents a position
+ -- or a range of positions (like x-y).
procedure Select_Character_Set;
- -- Define an optimized used character set like Character'Pos in
- -- order not to allocate tables of 256 entries.
+ -- Define an optimized used character set like Character'Pos in order not
+ -- to allocate tables of 256 entries.
procedure Select_Char_Position;
- -- Find a min char position set in order to reduce the max key
- -- length. The heuristic selects the position that induces the
- -- minimum number of collisions. If there are collisions, select
- -- another position on the reduced key set responsible of the
- -- collisions. Apply the heuristic until there is no collision.
+ -- Find a min char position set in order to reduce the max key length. The
+ -- heuristic selects the position that induces the minimum number of
+ -- collisions. If there are collisions, select another position on the
+ -- reduced key set responsible of the collisions. Apply the heuristic until
+ -- there is no collision.
-----------------------------
-- Random Graph Generation --
-----------------------------
procedure Random (Seed : in out Natural);
- -- Simulate Ada.Discrete_Numerics.Random.
+ -- Simulate Ada.Discrete_Numerics.Random
procedure Generate_Mapping_Table
- (T : Table_Id;
- L1 : Natural;
- L2 : Natural;
- S : in out Natural);
- -- Random generation of the tables below. T is already allocated.
+ (Tab : Table_Id;
+ L1 : Natural;
+ L2 : Natural;
+ Seed : in out Natural);
+ -- Random generation of the tables below. T is already allocated
procedure Generate_Mapping_Tables
- (Opt : Optimization;
- S : in out Natural);
- -- Generate the mapping tables T1 and T2. They are used to define :
- -- fk (w) = sum (for i in 1 .. length (w)) (Tk (i, w (i))) mod n.
- -- Keys, NK and Chars are used to compute the matrix size.
+ (Opt : Optimization;
+ Seed : in out Natural);
+ -- Generate the mapping tables T1 and T2. They are used to define fk (w) =
+ -- sum (for i in 1 .. length (w)) (Tk (i, w (i))) mod n. Keys, NK and Chars
+ -- are used to compute the matrix size.
---------------------------
-- Algorithm Computation --
---------------------------
procedure Compute_Edges_And_Vertices (Opt : Optimization);
- -- Compute the edge and vertex tables. These are empty when a self
- -- loop is detected (f1 (w) = f2 (w)). The edge table is sorted by
- -- X value and then Y value. Keys is the key table and NK the
- -- number of keys. Chars is the set of characters really used in
- -- Keys. NV is the number of vertices recommended by the
- -- algorithm. T1 and T2 are the mapping tables needed to compute
- -- f1 (w) and f2 (w).
+ -- Compute the edge and vertex tables. These are empty when a self loop is
+ -- detected (f1 (w) = f2 (w)). The edge table is sorted by X value and then
+ -- Y value. Keys is the key table and NK the number of keys. Chars is the
+ -- set of characters really used in Keys. NV is the number of vertices
+ -- recommended by the algorithm. T1 and T2 are the mapping tables needed to
+ -- compute f1 (w) and f2 (w).
function Acyclic return Boolean;
- -- Return True when the graph is acyclic. Vertices is the current
- -- vertex table and Edges the current edge table.
+ -- Return True when the graph is acyclic. Vertices is the current vertex
+ -- table and Edges the current edge table.
procedure Assign_Values_To_Vertices;
- -- Execute the assignment step of the algorithm. Keys is the
- -- current key table. Vertices and Edges represent the random
- -- graph. G is the result of the assignment step such that:
+ -- Execute the assignment step of the algorithm. Keys is the current key
+ -- table. Vertices and Edges represent the random graph. G is the result of
+ -- the assignment step such that:
-- h (w) = (g (f1 (w)) + g (f2 (w))) mod m
function Sum
(Word : Word_Type;
Table : Table_Id;
- Opt : Optimization)
- return Natural;
+ Opt : Optimization) return Natural;
-- For an optimization of CPU_Time return
-- fk (w) = sum (for i in 1 .. length (w)) (Tk (i, w (i))) mod n
-- For an optimization of Memory_Space return
-- Internal Table Management --
-------------------------------
- function Allocate (N : Natural; S : Natural) return Table_Id;
- -- procedure Deallocate (N : Natural; S : Natural);
+ function Allocate (N : Natural; S : Natural := 1) return Table_Id;
+ -- Allocate N * S ints from IT table
----------
-- Keys --
----------
- Key_Size : constant := 1;
- Keys : Table_Id := No_Table;
- NK : Natural;
+ Keys : Table_Id := No_Table;
+ NK : Natural := 0;
-- NK : Number of Keys
function Initial (K : Key_Id) return Word_Id;
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);
- -- Comments needed here ???
+ function Get_Key (N : Key_Id) return Key_Type;
+ procedure Set_Key (N : Key_Id; Item : Key_Type);
+ -- Get or Set Nth element of Keys table
------------------
-- Char_Pos_Set --
------------------
- Char_Pos_Size : constant := 1;
Char_Pos_Set : Table_Id := No_Table;
Char_Pos_Set_Len : Natural;
-- Character Selected Position Set
function Get_Char_Pos (P : Natural) return Natural;
procedure Set_Char_Pos (P : Natural; Item : Natural);
- -- Comments needed here ???
+ -- Get or Set the string position of the Pth selected character
-------------------
-- Used_Char_Set --
-------------------
- Used_Char_Size : constant := 1;
Used_Char_Set : Table_Id := No_Table;
Used_Char_Set_Len : Natural;
- -- Used Character Set : Define a new character mapping. When all
- -- the characters are not present in the keys, in order to reduce
- -- the size of some tables, we redefine the character mapping.
+ -- Used Character Set : Define a new character mapping. When all the
+ -- characters are not present in the keys, in order to reduce the size
+ -- of some tables, we redefine the character mapping.
function Get_Used_Char (C : Character) return Natural;
procedure Set_Used_Char (C : Character; Item : Natural);
- -------------------
- -- Random Tables --
- -------------------
+ ------------
+ -- Tables --
+ ------------
- 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;
+ T1 : Table_Id := No_Table;
+ T2 : Table_Id := No_Table;
+ T1_Len : Natural;
+ T2_Len : Natural;
-- T1 : Values table to compute F1
-- T2 : Values table to compute F2
- function Get_Rand_Tab (T : Integer; X, Y : Natural) return Natural;
- procedure Set_Rand_Tab (T : Integer; X, Y : Natural; Item : Natural);
+ function Get_Table (T : Integer; X, Y : Natural) return Natural;
+ procedure Set_Table (T : Integer; X, Y : Natural; Item : Natural);
- ------------------
- -- Random Graph --
- ------------------
+ -----------
+ -- Graph --
+ -----------
- Graph_Item_Size : constant := 1;
- G : Table_Id := No_Table;
- Graph_Len : Natural;
- -- G : Values table to compute G
+ G : Table_Id := No_Table;
+ G_Len : Natural;
+ -- Values table to compute G
- function Get_Graph (F : Natural) return Integer;
- procedure Set_Graph (F : Natural; Item : Integer);
- -- Comments needed ???
+ NT : Natural := Default_Tries;
+ -- Number of tries running the algorithm before raising an error
+
+ function Get_Graph (N : Natural) return Integer;
+ procedure Set_Graph (N : Natural; Item : Integer);
+ -- Get or Set Nth element of graph
-----------
-- Edges --
Opt : Optimization;
-- Optimization mode (memory vs CPU)
- MKL : Natural;
- -- Maximum of all the word length
+ Max_Key_Len : Natural := 0;
+ Min_Key_Len : Natural := 0;
+ -- Maximum and minimum of all the word length
S : Natural;
-- Seed
-- Acyclic --
-------------
- function Acyclic return Boolean
- is
+ 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;
- -- Propagate Mark from X to Y. X is already marked. Mark Y and
- -- propagate it to the edges of Y except the one representing
- -- the same key. Return False when Y is marked with Mark.
+ function Traverse (Edge : Edge_Id; Mark : Vertex_Id) return Boolean;
+ -- Propagate Mark from X to Y. X is already marked. Mark Y and propagate
+ -- it to the edges of Y except the one representing the same key. Return
+ -- False when Y is marked with Mark.
--------------
-- Traverse --
--------------
- function Traverse
- (Edge : Edge_Id;
- Mark : Vertex_Id)
- return Boolean
- is
+ 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;
for J in V.First .. V.Last loop
- -- Do not propagate to the edge representing the same key.
+ -- Do not propagate to the edge representing the same key
if Get_Edges (J).Key /= K
and then not Traverse (J, Mark)
return True;
end Acyclic;
+ ------------------------
+ -- Ada_File_Base_Name --
+ ------------------------
+
+ function Ada_File_Base_Name (Pkg_Name : String) return String is
+ begin
+ -- Convert to lower case, then replace '.' with '-'
+
+ return Result : String := To_Lower (Pkg_Name) do
+ for J in Result'Range loop
+ if Result (J) = '.' then
+ Result (J) := '-';
+ end if;
+ end loop;
+ end return;
+ end Ada_File_Base_Name;
+
---------
-- Add --
---------
procedure Add (C : Character) is
+ pragma Assert (C /= ASCII.NUL);
begin
Line (Last + 1) := C;
Last := Last + 1;
procedure Add (S : String) is
Len : constant Natural := S'Length;
-
begin
+ for J in S'Range loop
+ pragma Assert (S (J) /= ASCII.NUL);
+ null;
+ end loop;
+
Line (Last + 1 .. Last + Len) := S;
Last := Last + Len;
end Add;
-- Allocate --
--------------
- function Allocate (N : Natural; S : Natural) return Table_Id is
+ function Allocate (N : Natural; S : Natural := 1) return Table_Id is
L : constant Integer := IT.Last;
-
begin
IT.Set_Last (L + N * S);
+
+ -- Initialize, so debugging printouts don't trip over uninitialized
+ -- components.
+
+ for J in L + 1 .. IT.Last loop
+ IT.Table (J) := -1;
+ end loop;
+
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;
+ IW : constant String := WT.Table (Initial (J)).all;
+ RW : String (1 .. IW'Length) := (others => ASCII.NUL);
+ N : Natural := IW'First - 1;
begin
- -- Select the characters of Word included in the
- -- position selection.
+ -- Select the characters of Word included in the position
+ -- selection.
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));
+ exit when IW (Get_Char_Pos (C)) = ASCII.NUL;
+ N := N + 1;
+ RW (N) := IW (Get_Char_Pos (C));
end loop;
- -- Build the new table with the reduced word
+ -- Build the new table with the reduced word. Be careful
+ -- to deallocate the old version to avoid memory leaks.
- WT.Table (Reduced (J)) := R_Word;
+ Free_Word (WT.Table (Reduced (J)));
+ WT.Table (Reduced (J)) := New_Word (RW);
Set_Key (J, (Edge => No_Edge));
end;
end loop;
end Apply_Position_Selection;
- -------------
- -- Compute --
- -------------
-
- 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;
-
- -- Perform Czech's algorithm
-
- loop
- Generate_Mapping_Tables (Opt, S);
- Compute_Edges_And_Vertices (Opt);
-
- -- When graph is not empty (no self-loop from previous
- -- operation) and not acyclic.
-
- exit when 0 < Edges_Len and then Acyclic;
- end loop;
-
- Assign_Values_To_Vertices;
- end Compute;
-
-------------------------------
-- Assign_Values_To_Vertices --
-------------------------------
procedure Assign_Values_To_Vertices is
- X : Vertex_Id;
+ X : Vertex_Id;
procedure Assign (X : Vertex_Id);
- -- Execute assignment on X's neighbors except the vertex that
- -- we are coming from which is already assigned.
+ -- Execute assignment on X's neighbors except the vertex that we are
+ -- coming from which is already assigned.
------------
-- Assign --
------------
- procedure Assign (X : Vertex_Id)
- is
+ 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);
-- Start of processing for Assign_Values_To_Vertices
begin
- -- Value -1 denotes an unitialized value as it is supposed to
+ -- Value -1 denotes an uninitialized value as it is supposed to
-- be in the range 0 .. NK.
if G = No_Table then
- Graph_Len := NV;
- G := Allocate (Graph_Len, Graph_Item_Size);
+ G_Len := NV;
+ G := Allocate (G_Len, 1);
end if;
- for J in 0 .. Graph_Len - 1 loop
+ for J in 0 .. G_Len - 1 loop
Set_Graph (J, -1);
end loop;
end if;
end loop;
- for J in 0 .. Graph_Len - 1 loop
+ for J in 0 .. G_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);
+ Put_Int_Vector (Output, "Assign Values To Vertices", G, G_Len);
end if;
end Assign_Values_To_Vertices;
+ -------------
+ -- Compute --
+ -------------
+
+ procedure Compute (Position : String := Default_Position) is
+ Success : Boolean := False;
+
+ begin
+ if NK = 0 then
+ raise Program_Error with "keywords set cannot be empty";
+ end if;
+
+ 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;
+
+ -- Perform Czech's algorithm
+
+ for J in 1 .. NT loop
+ Generate_Mapping_Tables (Opt, S);
+ Compute_Edges_And_Vertices (Opt);
+
+ -- When graph is not empty (no self-loop from previous operation) and
+ -- not acyclic.
+
+ if 0 < Edges_Len and then Acyclic then
+ Success := True;
+ exit;
+ end if;
+ end loop;
+
+ if not Success then
+ raise Too_Many_Tries;
+ end if;
+
+ Assign_Values_To_Vertices;
+ end Compute;
+
--------------------------------
-- Compute_Edges_And_Vertices --
--------------------------------
procedure Move (From : Natural; To : Natural);
function Lt (L, R : Natural) return Boolean;
- -- Subprograms needed for GNAT.Heap_Sort_A
-
- ----------
- -- Move --
- ----------
-
- procedure Move (From : Natural; To : Natural) is
- begin
- Set_Edges (To, Get_Edges (From));
- end Move;
+ -- Subprograms needed for GNAT.Heap_Sort_G
--------
-- Lt --
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;
+ ----------
+ -- Move --
+ ----------
+
+ procedure Move (From : Natural; To : Natural) is
+ begin
+ Set_Edges (To, Get_Edges (From));
+ end Move;
+
+ package Sorting is new GNAT.Heap_Sort_G (Move, Lt);
+
-- Start of processing for Compute_Edges_And_Vertices
begin
- -- We store edges from 1 to 2 * NK and leave
- -- zero alone in order to use GNAT.Heap_Sort_A.
+ -- We store edges from 1 to 2 * NK and leave zero alone in order to use
+ -- GNAT.Heap_Sort_G.
Edges_Len := 2 * NK + 1;
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);
+ Put_Int_Matrix (Output, "Function Table 1", T1,
+ T1_Len, T2_Len);
+ Put_Int_Matrix (Output, "Function Table 2", T2,
+ T1_Len, T2_Len);
end if;
- -- Enforce consistency between edges and keys. Construct
- -- Vertices and compute the list of neighbors of a vertex
- -- First .. Last as Edges is sorted by X and then Y. To
- -- compute the neighbor list, sort the edges.
+ -- Enforce consistency between edges and keys. Construct Vertices and
+ -- compute the list of neighbors of a vertex First .. Last as Edges
+ -- is sorted by X and then Y. To compute the neighbor list, sort the
+ -- edges.
- Sort
- (Edges_Len - 1,
- Move'Unrestricted_Access,
- Lt'Unrestricted_Access);
+ Sorting.Sort (Edges_Len - 1);
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);
+ Put_Int_Matrix (Output, "Function Table 1", T1,
+ T1_Len, T2_Len);
+ Put_Int_Matrix (Output, "Function Table 2", T2,
+ T1_Len, T2_Len);
end if;
-- Edges valid range is 1 .. 2 * NK
when Function_Table_1
| Function_Table_2 =>
Item_Size := Type_Size (NV);
- Length_1 := Rand_Tab_Len_1;
- Length_2 := Rand_Tab_Len_2;
+ Length_1 := T1_Len;
+ Length_2 := T2_Len;
when Graph_Table =>
Item_Size := Type_Size (NK);
procedure Finalize is
begin
+ if Verbose then
+ Put (Output, "Finalize");
+ New_Line (Output);
+ end if;
+
+ -- Deallocate all the WT components (both initial and reduced ones) to
+ -- avoid memory leaks.
+
+ for W in 0 .. WT.Last loop
+
+ -- Note: WT.Table (NK) is a temporary variable, do not free it since
+ -- this would cause a double free.
+
+ if W /= NK then
+ Free_Word (WT.Table (W));
+ end if;
+ end loop;
+
WT.Release;
IT.Release;
+ -- Reset all variables for next usage
+
Keys := No_Table;
- NK := 0;
Char_Pos_Set := No_Table;
Char_Pos_Set_Len := 0;
T1 := No_Table;
T2 := No_Table;
- Rand_Tab_Len_1 := 0;
- Rand_Tab_Len_2 := 0;
+ T1_Len := 0;
+ T2_Len := 0;
- G := No_Table;
- Graph_Len := 0;
+ G := No_Table;
+ G_Len := 0;
Edges := No_Table;
Edges_Len := 0;
- Vertices := No_Table;
- NV := 0;
+ Vertices := No_Table;
+ NV := 0;
+
+ NK := 0;
+ Max_Key_Len := 0;
+ Min_Key_Len := 0;
end Finalize;
----------------------------
----------------------------
procedure Generate_Mapping_Table
- (T : Integer;
- L1 : Natural;
- L2 : Natural;
- S : in out Natural)
+ (Tab : Integer;
+ L1 : Natural;
+ L2 : Natural;
+ Seed : 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);
+ Random (Seed);
+ Set_Table (Tab, J, K, Seed mod NV);
end loop;
end loop;
end Generate_Mapping_Table;
-----------------------------
procedure Generate_Mapping_Tables
- (Opt : Optimization;
- S : in out Natural)
+ (Opt : Optimization;
+ Seed : in out Natural)
is
begin
- -- If T1 and T2 are already allocated no need to do it
- -- twice. Reuse them as their size has not changes.
+ -- If T1 and T2 are already allocated no need to do it twice. Reuse them
+ -- as their size has not changed.
if T1 = No_Table and then T2 = No_Table then
declare
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);
+ T1_Len := Char_Pos_Set_Len;
+ T2_Len := Used_Char_Last + 1;
+ T1 := Allocate (T1_Len * T2_Len);
+ T2 := Allocate (T1_Len * T2_Len);
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);
+ Generate_Mapping_Table (T1, T1_Len, T2_Len, Seed);
+ Generate_Mapping_Table (T2, T1_Len, T2_Len, Seed);
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);
+ Put_Int_Matrix (Output, "Function Table 1", T1,
+ T1_Len, T2_Len);
+ Put_Int_Matrix (Output, "Function Table 2", T2,
+ T1_Len, T2_Len);
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);
-- Get_Graph --
---------------
- function Get_Graph (F : Natural) return Integer is
- N : constant Natural := G + F * Graph_Item_Size;
-
+ function Get_Graph (N : Natural) return Integer is
begin
- return IT.Table (N);
+ return IT.Table (G + N);
end Get_Graph;
-------------
-- Get_Key --
-------------
- function Get_Key (F : Key_Id) return Key_Type is
- N : constant Natural := Keys + F * Key_Size;
+ function Get_Key (N : Key_Id) return Key_Type is
K : Key_Type;
-
begin
- K.Edge := IT.Table (N);
+ K.Edge := IT.Table (Keys + N);
return K;
end Get_Key;
- ------------------
- -- Get_Rand_Tab --
- ------------------
-
- 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;
+ ---------------
+ -- Get_Table --
+ ---------------
+ function Get_Table (T : Integer; X, Y : Natural) return Natural is
+ N : constant Natural := T + (Y * T1_Len) + X;
begin
return IT.Table (N);
- end Get_Rand_Tab;
+ end Get_Table;
-------------------
-- Get_Used_Char --
-------------------
function Get_Used_Char (C : Character) return Natural is
- N : constant Natural :=
- Used_Char_Set + Character'Pos (C) * Used_Char_Size;
-
+ N : constant Natural := Used_Char_Set + Character'Pos (C);
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);
procedure Initialize
(Seed : Natural;
K_To_V : Float := Default_K_To_V;
- Optim : Optimization := CPU_Time)
+ Optim : Optimization := Memory_Space;
+ Tries : Positive := Default_Tries)
is
begin
- WT.Init;
+ if Verbose then
+ Put (Output, "Initialize");
+ New_Line (Output);
+ end if;
+
+ -- Deallocate the part of the table concerning the reduced words.
+ -- Initial words are already present in the table. We may have reduced
+ -- words already there because a previous computation failed. We are
+ -- currently retrying and the reduced words have to be deallocated.
+
+ for W in Reduced (0) .. WT.Last loop
+ Free_Word (WT.Table (W));
+ end loop;
+
IT.Init;
- S := Seed;
+
+ -- Initialize of computation variables
Keys := No_Table;
- NK := 0;
Char_Pos_Set := No_Table;
Char_Pos_Set_Len := 0;
- K2V := K_To_V;
- Opt := Optim;
- MKL := 0;
+ Used_Char_Set := No_Table;
+ Used_Char_Set_Len := 0;
+
+ T1 := No_Table;
+ T2 := No_Table;
+
+ T1_Len := 0;
+ T2_Len := 0;
+
+ G := No_Table;
+ G_Len := 0;
+
+ Edges := No_Table;
+ Edges_Len := 0;
+
+ Vertices := No_Table;
+ NV := 0;
+
+ S := Seed;
+ K2V := K_To_V;
+ Opt := Optim;
+ NT := Tries;
+
+ if K2V <= 2.0 then
+ raise Program_Error with "K to V ratio cannot be lower than 2.0";
+ end if;
+
+ -- Do not accept a value of K2V too close to 2.0 such that once
+ -- rounded up, NV = 2 * NK because the algorithm would not converge.
+
+ NV := Natural (Float (NK) * K2V);
+ if NV <= 2 * NK then
+ NV := 2 * NK + 1;
+ end if;
+
+ Keys := Allocate (NK);
+
+ -- Resize initial words to have all of them at the same size
+ -- (so the size of the largest one).
+
+ for K in 0 .. NK - 1 loop
+ Resize_Word (WT.Table (Initial (K)), Max_Key_Len);
+ end loop;
+
+ -- Allocated the table to store the reduced words. As WT is a
+ -- GNAT.Table (using C memory management), pointers have to be
+ -- explicitly initialized to null.
+
+ WT.Set_Last (Reduced (NK - 1));
+
+ -- Note: Reduced (0) = NK + 1
+
+ WT.Table (NK) := null;
+
+ for W in 0 .. NK - 1 loop
+ WT.Table (Reduced (W)) := null;
+ end loop;
end Initialize;
------------
-- Insert --
------------
- procedure Insert
- (Value : String)
- is
- Word : Word_Type := Null_Word;
+ procedure Insert (Value : String) is
Len : constant Natural := Value'Length;
begin
- Word (1 .. Len) := Value (Value'First .. Value'First + Len - 1);
+ if Verbose then
+ Put (Output, "Inserting """ & Value & """");
+ New_Line (Output);
+ end if;
+
+ for J in Value'Range loop
+ pragma Assert (Value (J) /= ASCII.NUL);
+ null;
+ end loop;
+
WT.Set_Last (NK);
- WT.Table (NK) := Word;
+ WT.Table (NK) := New_Word (Value);
NK := NK + 1;
- NV := Natural (Float (NK) * K2V);
- if MKL < Len then
- MKL := Len;
+ if Max_Key_Len < Len then
+ Max_Key_Len := Len;
+ end if;
+
+ if Min_Key_Len = 0 or else Len < Min_Key_Len then
+ Min_Key_Len := Len;
end if;
end Insert;
-- New_Line --
--------------
- procedure New_Line (F : File_Descriptor) is
- EOL : constant Character := ASCII.LF;
-
+ procedure New_Line (File : File_Descriptor) is
begin
- if Write (F, EOL'Address, 1) /= 1 then
+ if Write (File, EOL'Address, 1) /= 1 then
raise Program_Error;
end if;
end New_Line;
+ --------------
+ -- New_Word --
+ --------------
+
+ function New_Word (S : String) return Word_Type is
+ begin
+ return new String'(S);
+ end New_Word;
+
------------------------------
-- Parse_Position_Selection --
------------------------------
procedure Parse_Position_Selection (Argument : String) is
N : Natural := Argument'First;
L : constant Natural := Argument'Last;
- M : constant Natural := MKL;
+ M : constant Natural := Max_Key_Len;
T : array (1 .. M) of Boolean := (others => False);
-- Parse_Index --
-----------------
- function Parse_Index return Natural
- is
+ function Parse_Index return Natural is
C : Character := Argument (N);
V : Natural := 0;
end if;
if C not in '0' .. '9' then
- Raise_Exception
- (Program_Error'Identity, "cannot read position argument");
+ raise Program_Error with "cannot read position argument";
end if;
while C in '0' .. '9' loop
-- Start of processing for Parse_Position_Selection
begin
- Char_Pos_Set_Len := 2 * NK;
-
-- Empty specification means all the positions
if L < N then
Char_Pos_Set_Len := M;
- Char_Pos_Set := Allocate (Char_Pos_Set_Len, Char_Pos_Size);
+ Char_Pos_Set := Allocate (Char_Pos_Set_Len);
for C in 0 .. Char_Pos_Set_Len - 1 loop
Set_Char_Pos (C, C + 1);
exit when L < N;
if Argument (N) /= ',' then
- Raise_Exception
- (Program_Error'Identity, "cannot read position argument");
+ raise Program_Error with "cannot read position argument";
end if;
N := N + 1;
-- Fill position selection
Char_Pos_Set_Len := N;
- Char_Pos_Set := Allocate (Char_Pos_Set_Len, Char_Pos_Size);
+ Char_Pos_Set := Allocate (Char_Pos_Set_Len);
N := 0;
for J in T'Range loop
-- Produce --
-------------
- procedure Produce (Pkg_Name : String := Default_Pkg_Name) is
- File : File_Descriptor;
+ procedure Produce
+ (Pkg_Name : String := Default_Pkg_Name;
+ Use_Stdout : Boolean := False)
+ is
+ File : File_Descriptor := Standout;
Status : Boolean;
- -- For call to Close;
+ -- For call to Close
- function Type_Img (L : Natural) return String;
- -- Return the larger unsigned type T such that T'Last < L
+ function Array_Img (N, T, R1 : String; R2 : String := "") return String;
+ -- Return string "N : constant array (R1[, R2]) of T;"
function Range_Img (F, L : Natural; T : String := "") return String;
-- Return string "[T range ]F .. L"
- function Array_Img (N, T, R1 : String; R2 : String := "") return String;
- -- Return string "N : constant array (R1[, R2]) of T;"
+ function Type_Img (L : Natural) return String;
+ -- Return the larger unsigned type T such that T'Last < L
- --------------
- -- Type_Img --
- --------------
-
- function Type_Img (L : Natural) return String is
- S : constant String := Image (Type_Size (L));
- U : String := "Unsigned_ ";
- N : Natural := 9;
+ ---------------
+ -- Array_Img --
+ ---------------
+ function Array_Img
+ (N, T, R1 : String;
+ R2 : String := "") return String
+ is
begin
- for J in S'Range loop
- N := N + 1;
- U (N) := S (J);
- end loop;
+ Last := 0;
+ Add (" ");
+ Add (N);
+ Add (" : constant array (");
+ Add (R1);
- return U (1 .. N);
- end Type_Img;
+ if R2 /= "" then
+ Add (", ");
+ Add (R2);
+ end if;
+
+ Add (") of ");
+ Add (T);
+ Add (" :=");
+ return Line (1 .. Last);
+ end Array_Img;
---------------
-- Range_Img --
return RI (1 .. Len);
end Range_Img;
- ---------------
- -- Array_Img --
- ---------------
+ --------------
+ -- Type_Img --
+ --------------
- function Array_Img
- (N, T, R1 : String;
- R2 : String := "")
- return String
- is
- begin
- Last := 0;
- Add (" ");
- Add (N);
- Add (" : constant array (");
- Add (R1);
+ function Type_Img (L : Natural) return String is
+ S : constant String := Image (Type_Size (L));
+ U : String := "Unsigned_ ";
+ N : Natural := 9;
- if R2 /= "" then
- Add (", ");
- Add (R2);
- end if;
+ begin
+ for J in S'Range loop
+ N := N + 1;
+ U (N) := S (J);
+ end loop;
- Add (") of ");
- Add (T);
- Add (" :=");
- return Line (1 .. Last);
- end Array_Img;
+ return U (1 .. N);
+ end Type_Img;
F : Natural;
L : Natural;
P : Natural;
- PLen : constant Natural := Pkg_Name'Length;
- FName : String (1 .. PLen + 4);
+ FName : String := Ada_File_Base_Name (Pkg_Name) & ".ads";
+ -- Initially, the name of the spec file, then modified to be the name of
+ -- the body file. Not used if Use_Stdout is True.
-- Start of processing for Produce
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";
+ if Verbose and then not Use_Stdout then
+ Put (Output,
+ "Producing " & Ada.Directories.Current_Directory & "/" & FName);
+ New_Line (Output);
+ end if;
+
+ if not Use_Stdout then
+ File := Create_File (FName, Binary);
+
+ if File = Invalid_FD then
+ raise Program_Error with "cannot create: " & FName;
+ end if;
+ end if;
- File := Create_File (FName, Text);
Put (File, "package ");
Put (File, Pkg_Name);
Put (File, " is");
Put (File, Pkg_Name);
Put (File, ";");
New_Line (File);
- Close (File, Status);
- if not Status then
- raise Device_Error;
+ if not Use_Stdout then
+ Close (File, Status);
+
+ if not Status then
+ raise Device_Error;
+ end if;
end if;
- FName (PLen + 4) := 'b';
+ if not Use_Stdout then
+
+ -- Set to body file name
+
+ FName (FName'Last) := 'b';
+
+ File := Create_File (FName, Binary);
+
+ if File = Invalid_FD then
+ raise Program_Error with "cannot create: " & FName;
+ end if;
+ end if;
- File := Create_File (FName, Text);
Put (File, "with Interfaces; use Interfaces;");
New_Line (File);
New_Line (File);
for J in Character'Range loop
P := Get_Used_Char (J);
- Put (File, Image (P), 0, 0, 0, F, L, Character'Pos (J));
+ Put (File, Image (P), 1, 0, 1, F, L, Character'Pos (J));
end loop;
New_Line (File);
New_Line (File);
for J in F .. L loop
- Put (File, Image (Get_Char_Pos (J)), 0, 0, 0, F, L, J);
+ Put (File, Image (Get_Char_Pos (J)), 1, 0, 1, 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;
+ case Opt is
+ when CPU_Time =>
+ Put_Int_Matrix
+ (File,
+ Array_Img ("T1", Type_Img (NV),
+ Range_Img (0, T1_Len - 1),
+ Range_Img (0, T2_Len - 1, Type_Img (256))),
+ T1, T1_Len, T2_Len);
+
+ when Memory_Space =>
+ Put_Int_Matrix
+ (File,
+ Array_Img ("T1", Type_Img (NV),
+ Range_Img (0, T1_Len - 1)),
+ T1, T1_Len, 0);
+ end case;
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;
+ case Opt is
+ when CPU_Time =>
+ Put_Int_Matrix
+ (File,
+ Array_Img ("T2", Type_Img (NV),
+ Range_Img (0, T1_Len - 1),
+ Range_Img (0, T2_Len - 1, Type_Img (256))),
+ T2, T1_Len, T2_Len);
+
+ when Memory_Space =>
+ Put_Int_Matrix
+ (File,
+ Array_Img ("T2", Type_Img (NV),
+ Range_Img (0, T1_Len - 1)),
+ T2, T1_Len, 0);
+ end case;
New_Line (File);
Put_Int_Vector
(File,
Array_Img ("G", Type_Img (NK),
- Range_Img (0, Graph_Len - 1)),
- G, Graph_Len);
+ Range_Img (0, G_Len - 1)),
+ G, G_Len);
New_Line (File);
Put (File, " function Hash (S : String) return Natural is");
Put (File, " J : ");
- if Opt = CPU_Time then
- Put (File, Type_Img (256));
- else
- Put (File, "Natural");
- end if;
+ case Opt is
+ when CPU_Time =>
+ Put (File, Type_Img (256));
+ when Memory_Space =>
+ Put (File, "Natural");
+ end case;
Put (File, ";");
New_Line (File);
New_Line (File);
Put (File, " J := ");
- if Opt = CPU_Time then
- Put (File, "C");
- else
- Put (File, "Character'Pos");
- end if;
+ case Opt is
+ when CPU_Time =>
+ Put (File, "C");
+ when Memory_Space =>
+ Put (File, "Character'Pos");
+ end case;
Put (File, " (S (P (K) + F));");
New_Line (File);
Put (File, Pkg_Name);
Put (File, ";");
New_Line (File);
- Close (File, Status);
- if not Status then
- raise Device_Error;
+ if not Use_Stdout then
+ Close (File, Status);
+
+ if not Status then
+ raise Device_Error;
+ end if;
end if;
end Produce;
-- Put --
---------
- procedure Put (F : File_Descriptor; S : String) is
- Len : constant Natural := S'Length;
-
+ procedure Put (File : File_Descriptor; Str : String) is
+ Len : constant Natural := Str'Length;
begin
- if Write (F, S'Address, Len) /= Len then
+ for J in Str'Range loop
+ pragma Assert (Str (J) /= ASCII.NUL);
+ null;
+ end loop;
+
+ if Write (File, Str'Address, Len) /= Len then
raise Program_Error;
end if;
end Put;
Len : constant Natural := S'Length;
procedure Flush;
+ -- Write current line, followed by LF
-----------
-- Flush --
Last := 0;
end if;
- if Last + Len + 3 > Max then
+ if Last + Len + 3 >= Max then
Flush;
end if;
if Last = 0 then
- Line (Last + 1 .. Last + 5) := " ";
- Last := Last + 5;
+ Add (" ");
- if F1 /= L1 then
+ if F1 <= L1 then
if C1 = F1 and then C2 = F2 then
Add ('(');
+
+ if F1 = L1 then
+ Add ("0 .. 0 => ");
+ end if;
+
else
Add (' ');
end if;
if C2 = F2 then
Add ('(');
+
+ if F2 = L2 then
+ Add ("0 .. 0 => ");
+ end if;
+
else
Add (' ');
end if;
- Line (Last + 1 .. Last + Len) := S;
- Last := Last + Len;
+ Add (S);
if C2 = L2 then
Add (')');
- if F1 = L1 then
+ if F1 > L1 then
Add (';');
Flush;
+
elsif C1 /= L1 then
Add (',');
Flush;
+
else
Add (')');
Add (';');
end if;
end Put;
- -----------------------
- -- Put_Used_Char_Set --
- -----------------------
+ ---------------
+ -- Put_Edges --
+ ---------------
- 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);
+ 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 Character'Range loop
- Put
- (File, Image (Get_Used_Char (J)), 0, 0, 0, F, L, Character'Pos (J));
+ -- Edges valid range is 1 .. Edge_Len - 1
+
+ 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_Used_Char_Set;
+ end Put_Edges;
- ----------
- -- Put --
- ----------
+ ----------------------
+ -- Put_Initial_Keys --
+ ----------------------
+
+ 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, Trim_Trailing_Nuls (WT.Table (Initial (J)).all),
+ F1, L1, J, 1, 3, 3);
+ end loop;
+ end Put_Initial_Keys;
+
+ --------------------
+ -- Put_Int_Matrix --
+ --------------------
procedure Put_Int_Matrix
(File : File_Descriptor;
Title : String;
- Table : Integer)
+ Table : Integer;
+ Len_1 : Natural;
+ Len_2 : Natural)
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;
+ F1 : constant Integer := 0;
+ L1 : constant Integer := Len_1 - 1;
+ F2 : constant Integer := 0;
+ L2 : constant Integer := Len_2 - 1;
+ Ix : Natural;
begin
Put (File, Title);
New_Line (File);
- if L2 = F2 then
+ if Len_2 = 0 then
for J in F1 .. L1 loop
- Put (File,
- Image (Get_Rand_Tab (Table, J, F2)), 0, 0, 0, F1, L1, J);
+ Ix := IT.Table (Table + J);
+ Put (File, Image (Ix), 1, 0, 1, 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);
+ Ix := IT.Table (Table + J + K * Len_1);
+ Put (File, Image (Ix), F1, L1, J, F2, L2, K);
end loop;
end loop;
end if;
procedure Put_Int_Vector
(File : File_Descriptor;
Title : String;
- Root : Integer;
+ Vector : Integer;
Length : Natural)
is
F2 : constant Natural := 0;
New_Line (File);
for J in F2 .. L2 loop
- Put (File, Image (IT.Table (Root + J)), 0, 0, 0, F2, L2, J);
+ Put (File, Image (IT.Table (Vector + J)), 1, 0, 1, F2, L2, J);
end loop;
end Put_Int_Vector;
- ---------------
- -- Put_Edges --
- ---------------
-
- 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);
-
- -- Edges valid range is 1 .. Edge_Len - 1
-
- 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;
-
- ---------------------------
- -- Put_Initial_Keys --
- ---------------------------
+ ----------------------
+ -- Put_Reduced_Keys --
+ ----------------------
- procedure Put_Initial_Keys
- (File : File_Descriptor;
- Title : String)
- is
+ 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 := 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);
+ Put (File, Trim_Trailing_Nuls (WT.Table (Reduced (J)).all),
+ F1, L1, J, 1, 3, 3);
end loop;
- end Put_Initial_Keys;
+ end Put_Reduced_Keys;
- ---------------------------
- -- Put_Reduced_Keys --
- ---------------------------
+ -----------------------
+ -- Put_Used_Char_Set --
+ -----------------------
- 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;
+ 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 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);
+ for J in Character'Range loop
+ Put
+ (File, Image (Get_Used_Char (J)), 1, 0, 1, F, L, Character'Pos (J));
end loop;
- end Put_Reduced_Keys;
+ end Put_Used_Char_Set;
----------------------
-- Put_Vertex_Table --
----------------------
- procedure Put_Vertex_Table
- (File : File_Descriptor;
- Title : String)
- is
+ procedure Put_Vertex_Table (File : File_Descriptor; Title : String) is
F1 : constant Natural := 0;
L1 : constant Natural := NV - 1;
M : constant Natural := Max / 4;
-- Random --
------------
- procedure Random (Seed : in out Natural)
- is
- -- Park & Miller Standard Minimal using Schrage's algorithm to
- -- avoid overflow: Xn+1 = 16807 * Xn mod (2 ** 31 - 1)
+ procedure Random (Seed : in out Natural) is
+
+ -- Park & Miller Standard Minimal using Schrage's algorithm to avoid
+ -- overflow: Xn+1 = 16807 * Xn mod (2 ** 31 - 1)
R : Natural;
Q : Natural;
Q := Seed / 127773;
X := 16807 * R - 2836 * Q;
- if X < 0 then
- Seed := X + 2147483647;
- else
- Seed := X;
- end if;
+ Seed := (if X < 0 then X + 2147483647 else X);
end Random;
-------------
function Reduced (K : Key_Id) return Word_Id is
begin
- return K + NK;
+ return K + NK + 1;
end Reduced;
- --------------------------
- -- Select_Character_Set --
- --------------------------
-
- procedure Select_Character_Set
- is
- Last : Natural := 0;
- Used : array (Character) of Boolean := (others => False);
+ -----------------
+ -- Resize_Word --
+ -----------------
+ procedure Resize_Word (W : in out Word_Type; Len : Natural) is
+ S1 : constant String := W.all;
+ S2 : String (1 .. Len) := (others => ASCII.NUL);
+ L : constant Natural := S1'Length;
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;
+ if L /= Len then
+ Free_Word (W);
+ S2 (1 .. L) := S1;
+ W := New_Word (S2);
+ end if;
+ end Resize_Word;
--------------------------
-- Select_Char_Position --
procedure Build_Identical_Keys_Sets
(Table : in out Vertex_Table_Type;
Last : in out Natural;
- Pos : in Natural);
- -- Build a list of keys subsets that are identical with the
- -- current position selection plus Pos. Once this routine is
- -- called, reduced words are sorted by subsets and each item
- -- (First, Last) in Sets defines the range of identical keys.
-
- function Count_Identical_Keys
- (Table : Vertex_Table_Type;
- Last : Natural;
- Pos : Natural)
- return Natural;
- -- For each subset in Sets, count the number of identical keys
- -- if we add Pos to the current position selection.
-
- Sel_Position : IT.Table_Type (1 .. MKL);
+ Pos : Natural);
+ -- Build a list of keys subsets that are identical with the current
+ -- position selection plus Pos. Once this routine is called, reduced
+ -- words are sorted by subsets and each item (First, Last) in Sets
+ -- defines the range of identical keys.
+ -- Need comment saying exactly what Last is ???
+
+ function Count_Different_Keys
+ (Table : Vertex_Table_Type;
+ Last : Natural;
+ Pos : Natural) return Natural;
+ -- For each subset in Sets, count the number of different keys if we add
+ -- Pos to the current position selection.
+
+ Sel_Position : IT.Table_Type (1 .. Max_Key_Len);
Last_Sel_Pos : Natural := 0;
+ Max_Sel_Pos : Natural := 0;
-------------------------------
-- Build_Identical_Keys_Sets --
procedure Build_Identical_Keys_Sets
(Table : in out Vertex_Table_Type;
Last : in out Natural;
- Pos : in Natural)
+ Pos : Natural)
is
- S : constant Vertex_Table_Type := Table (1 .. Last);
+ S : constant Vertex_Table_Type := Table (Table'First .. Last);
C : constant Natural := Pos;
- -- Shortcuts
+ -- Shortcuts (why are these not renames ???)
F : Integer;
L : Integer;
-- First and last words of a subset
+ Offset : Natural;
+ -- GNAT.Heap_Sort assumes that the first array index is 1. Offset
+ -- defines the translation to operate.
+
+ function Lt (L, R : Natural) return Boolean;
+ procedure Move (From : Natural; To : Natural);
+ -- Subprograms needed by GNAT.Heap_Sort_G
+
+ --------
+ -- Lt --
+ --------
+
+ function Lt (L, R : Natural) return Boolean is
+ C : constant Natural := Pos;
+ Left : Natural;
+ Right : Natural;
+
+ begin
+ if L = 0 then
+ Left := NK;
+ Right := Offset + R;
+ elsif R = 0 then
+ Left := Offset + L;
+ Right := NK;
+ else
+ Left := Offset + L;
+ Right := Offset + R;
+ end if;
+
+ return WT.Table (Left)(C) < WT.Table (Right)(C);
+ end Lt;
+
+ ----------
+ -- Move --
+ ----------
+
+ procedure Move (From : Natural; To : Natural) is
+ Target, Source : Natural;
+
+ begin
+ if From = 0 then
+ Source := NK;
+ Target := Offset + To;
+ elsif To = 0 then
+ Source := Offset + From;
+ Target := NK;
+ else
+ Source := Offset + From;
+ Target := Offset + To;
+ end if;
+
+ WT.Table (Target) := WT.Table (Source);
+ WT.Table (Source) := null;
+ end Move;
+
+ package Sorting is new GNAT.Heap_Sort_G (Move, Lt);
+
+ -- Start of processing for Build_Identical_Key_Sets
+
begin
Last := 0;
- -- For each subset in S, extract the new subsets we have by
- -- adding C in the position selection.
+ -- For each subset in S, extract the new subsets we have by adding C
+ -- in the position selection.
for J in S'Range loop
- declare
- Offset : Natural;
- -- GNAT.Heap_Sort assumes that the first array index
- -- is 1. Offset defines the translation to operate.
-
- procedure Move (From : Natural; To : Natural);
- function Lt (L, R : Natural) return Boolean;
- -- Subprograms needed by GNAT.Heap_Sort_A
-
- ----------
- -- Move --
- ----------
-
- 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;
+ if S (J).First = S (J).Last then
+ F := S (J).First;
+ L := S (J).Last;
+ Last := Last + 1;
+ Table (Last) := (F, L);
- WT.Table (Reduced (Target)) := WT.Table (Reduced (Source));
- end Move;
-
- --------
- -- Lt --
- --------
-
- 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;
+ else
+ Offset := Reduced (S (J).First) - 1;
+ Sorting.Sort (S (J).Last - S (J).First + 1);
- -- Start of processing for Build_Identical_Key_Sets
+ F := S (J).First;
+ L := F;
+ for N in S (J).First .. S (J).Last loop
- begin
- Offset := S (J).First - 1;
- Sort
- (S (J).Last - S (J).First + 1,
- Move'Unrestricted_Access,
- Lt'Unrestricted_Access);
+ -- For the last item, close the last subset
- F := -1;
- L := -1;
- for N in S (J).First .. S (J).Last - 1 loop
+ if N = S (J).Last then
+ Last := Last + 1;
+ Table (Last) := (F, N);
- -- Two contiguous words are identical
+ -- Two contiguous words are identical when they have the
+ -- same Cth character.
- if WT.Table (Reduced (N))(C) =
- WT.Table (Reduced (N + 1))(C)
+ elsif WT.Table (Reduced (N))(C) =
+ WT.Table (Reduced (N + 1))(C)
then
- -- This is the first word of the subset
-
- if F = -1 then
- F := N;
- end if;
-
L := N + 1;
- -- This is the last word of the subset
+ -- Find a new subset of identical keys. Store the current
+ -- one and create a new subset.
- elsif F /= -1 then
+ else
Last := Last + 1;
Table (Last) := (F, L);
- F := -1;
+ F := N + 1;
+ L := F;
end if;
end loop;
-
- -- This is the last word of the subset and of the set
-
- if F /= -1 then
- Last := Last + 1;
- Table (Last) := (F, L);
- end if;
- end;
+ end if;
end loop;
end Build_Identical_Keys_Sets;
--------------------------
- -- Count_Identical_Keys --
+ -- Count_Different_Keys --
--------------------------
- function Count_Identical_Keys
- (Table : Vertex_Table_Type;
- Last : Natural;
- Pos : Natural)
- return Natural
+ function Count_Different_Keys
+ (Table : Vertex_Table_Type;
+ Last : Natural;
+ Pos : Natural) return Natural
is
N : array (Character) of Natural;
C : Character;
begin
-- For each subset, count the number of words that are still
- -- identical when we include Sel_Position (Last_Sel_Pos) in
- -- the position selection. Only focus on this position as the
- -- other positions already produce identical keys.
+ -- different when we include Pos in the position selection. Only
+ -- focus on this position as the other positions already produce
+ -- identical keys.
for S in 1 .. Last loop
N (C) := N (C) + 1;
end loop;
- -- Add to the total when there are two identical keys
+ -- Update the number of different keys. Each character used
+ -- denotes a different key.
for J in N'Range loop
- if N (J) > 1 then
- T := T + N (J);
+ if N (J) > 0 then
+ T := T + 1;
end if;
end loop;
end loop;
return T;
- end Count_Identical_Keys;
+ end Count_Different_Keys;
-- Start of processing for Select_Char_Position
begin
- for C in Sel_Position'Range loop
- Sel_Position (C) := C;
- end loop;
-
- -- Initialization of Words
-
- WT.Set_Last (2 * NK - 1);
+ -- Initialize the reduced words set
for K in 0 .. NK - 1 loop
- WT.Table (Reduced (K) + 1) := WT.Table (Initial (K));
+ WT.Table (Reduced (K)) := New_Word (WT.Table (Initial (K)).all);
end loop;
declare
- Collisions : Natural;
- Min_Collisions : Natural := NK;
- Old_Collisions : Natural;
- Min_Coll_Sel_Pos : Natural := 0; -- init to kill warning
- Min_Coll_Sel_Pos_Idx : Natural := 0; -- init to kill warning
+ Differences : Natural;
+ Max_Differences : Natural := 0;
+ Old_Differences : Natural;
+ Max_Diff_Sel_Pos : Natural := 0; -- init to kill warning
+ Max_Diff_Sel_Pos_Idx : Natural := 0; -- init to kill warning
Same_Keys_Sets_Table : Vertex_Table_Type (1 .. NK);
Same_Keys_Sets_Last : Natural := 1;
begin
- Same_Keys_Sets_Table (1) := (1, NK);
+ for C in Sel_Position'Range loop
+ Sel_Position (C) := C;
+ end loop;
+
+ Same_Keys_Sets_Table (1) := (0, NK - 1);
loop
- -- Preserve minimum identical keys and check later on
- -- that this value is strictly decrementing. Otherwise,
- -- it means that two keys are stricly identical.
+ -- Preserve maximum number of different keys and check later on
+ -- that this value is strictly incrementing. Otherwise, it means
+ -- that two keys are strictly identical.
+
+ Old_Differences := Max_Differences;
- Old_Collisions := Min_Collisions;
+ -- The first position should not exceed the minimum key length.
+ -- Otherwise, we may end up with an empty word once reduced.
- -- Find which position reduces the most of collisions
+ Max_Sel_Pos :=
+ (if Last_Sel_Pos = 0 then Min_Key_Len else Max_Key_Len);
- for J in Last_Sel_Pos + 1 .. Sel_Position'Last loop
- Collisions := Count_Identical_Keys
+ -- Find which position increases more the number of differences
+
+ for J in Last_Sel_Pos + 1 .. Max_Sel_Pos loop
+ Differences := Count_Different_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;
+ if Verbose then
+ Put (Output,
+ "Selecting position" & Sel_Position (J)'Img &
+ " results in" & Differences'Img &
+ " differences");
+ New_Line (Output);
+ end if;
+
+ if Differences > Max_Differences then
+ Max_Differences := Differences;
+ Max_Diff_Sel_Pos := Sel_Position (J);
+ Max_Diff_Sel_Pos_Idx := J;
end if;
end loop;
- if Old_Collisions = Min_Collisions then
- Raise_Exception
- (Program_Error'Identity, "some keys are identical");
+ if Old_Differences = Max_Differences then
+ raise Program_Error with "some keys are identical";
end if;
-- Insert selected position and sort Sel_Position table
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;
+ Sel_Position (Last_Sel_Pos + 1 .. Max_Diff_Sel_Pos_Idx) :=
+ Sel_Position (Last_Sel_Pos .. Max_Diff_Sel_Pos_Idx - 1);
+ Sel_Position (Last_Sel_Pos) := Max_Diff_Sel_Pos;
for P in 1 .. Last_Sel_Pos - 1 loop
- if Min_Coll_Sel_Pos < Sel_Position (P) then
+ if Max_Diff_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;
+ Sel_Position (P) := Max_Diff_Sel_Pos;
exit;
end if;
end loop;
- exit when Min_Collisions = 0;
+ exit when Max_Differences = NK;
Build_Identical_Keys_Sets
(Same_Keys_Sets_Table,
Same_Keys_Sets_Last,
- Min_Coll_Sel_Pos);
+ Max_Diff_Sel_Pos);
+
+ if Verbose then
+ Put (Output,
+ "Selecting position" & Max_Diff_Sel_Pos'Img &
+ " results in" & Max_Differences'Img &
+ " differences");
+ New_Line (Output);
+ Put (Output, "--");
+ New_Line (Output);
+ for J in 1 .. Same_Keys_Sets_Last loop
+ for K in
+ Same_Keys_Sets_Table (J).First ..
+ Same_Keys_Sets_Table (J).Last
+ loop
+ Put (Output,
+ Trim_Trailing_Nuls (WT.Table (Reduced (K)).all));
+ New_Line (Output);
+ end loop;
+ Put (Output, "--");
+ New_Line (Output);
+ end loop;
+ end if;
end loop;
end;
Char_Pos_Set_Len := Last_Sel_Pos;
- Char_Pos_Set := Allocate (Char_Pos_Set_Len, Char_Pos_Size);
+ Char_Pos_Set := Allocate (Char_Pos_Set_Len);
for C in 1 .. Last_Sel_Pos loop
Set_Char_Pos (C - 1, Sel_Position (C));
end loop;
end Select_Char_Position;
+ --------------------------
+ -- Select_Character_Set --
+ --------------------------
+
+ procedure Select_Character_Set is
+ Last : Natural := 0;
+ Used : array (Character) of Boolean := (others => False);
+ Char : Character;
+
+ begin
+ for J in 0 .. NK - 1 loop
+ for K in 0 .. Char_Pos_Set_Len - 1 loop
+ Char := WT.Table (Initial (J))(Get_Char_Pos (K));
+ exit when Char = ASCII.NUL;
+ Used (Char) := True;
+ end loop;
+ end loop;
+
+ Used_Char_Set_Len := 256;
+ Used_Char_Set := Allocate (Used_Char_Set_Len);
+
+ 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;
+
------------------
-- Set_Char_Pos --
------------------
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;
-- Set_Graph --
---------------
- procedure Set_Graph (F : Natural; Item : Integer) is
- N : constant Natural := G + (F * Graph_Item_Size);
-
+ procedure Set_Graph (N : Natural; Item : Integer) is
begin
- IT.Table (N) := Item;
+ IT.Table (G + N) := Item;
end Set_Graph;
-------------
-- Set_Key --
-------------
- procedure Set_Key (F : Key_Id; Item : Key_Type) is
- N : constant Natural := Keys + F * Key_Size;
-
+ procedure Set_Key (N : Key_Id; Item : Key_Type) is
begin
- IT.Table (N) := Item.Edge;
+ IT.Table (Keys + N) := Item.Edge;
end Set_Key;
- ------------------
- -- Set_Rand_Tab --
- ------------------
-
- 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;
+ ---------------
+ -- Set_Table --
+ ---------------
+ procedure Set_Table (T : Integer; X, Y : Natural; Item : Natural) is
+ N : constant Natural := T + ((Y * T1_Len) + X);
begin
IT.Table (N) := Item;
- end Set_Rand_Tab;
+ end Set_Table;
-------------------
-- Set_Used_Char --
-------------------
procedure Set_Used_Char (C : Character; Item : Natural) is
- N : constant Natural :=
- Used_Char_Set + Character'Pos (C) * Used_Char_Size;
-
+ N : constant Natural := Used_Char_Set + Character'Pos (C);
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;
function Sum
(Word : Word_Type;
Table : Table_Id;
- Opt : Optimization)
- return Natural
+ 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;
+ case Opt is
+ when CPU_Time =>
+ for J in 0 .. T1_Len - 1 loop
+ exit when Word (J + 1) = ASCII.NUL;
+ R := Get_Table (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;
+ when Memory_Space =>
+ for J in 0 .. T1_Len - 1 loop
+ exit when Word (J + 1) = ASCII.NUL;
+ R := Get_Table (Table, J, 0);
+ S := (S + R * Character'Pos (Word (J + 1))) mod NV;
+ end loop;
+ end case;
return S;
end Sum;
+ ------------------------
+ -- Trim_Trailing_Nuls --
+ ------------------------
+
+ function Trim_Trailing_Nuls (Str : String) return String is
+ begin
+ for J in reverse Str'Range loop
+ if Str (J) /= ASCII.NUL then
+ return Str (Str'First .. J);
+ end if;
+ end loop;
+
+ return Str;
+ end Trim_Trailing_Nuls;
+
---------------
-- Type_Size --
---------------
function Value
(Name : Table_Name;
- J : Natural;
- K : Natural := 0)
- return Natural
+ J : Natural;
+ K : Natural := 0) return Natural
is
begin
case Name is
return Get_Used_Char (Character'Val (J));
when Function_Table_1 =>
- return Get_Rand_Tab (T1, J, K);
+ return Get_Table (T1, J, K);
when Function_Table_2 =>
- return Get_Rand_Tab (T2, J, K);
+ return Get_Table (T2, J, K);
when Graph_Table =>
return Get_Graph (J);
OSDN Git Service
