2599 lines
71 KiB
Ada
2599 lines
71 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- GNAT COMPILER COMPONENTS --
|
|
-- --
|
|
-- G N A T . P E R F E C T _ H A S H _ G E N E R A T O R S --
|
|
-- --
|
|
-- B o d y --
|
|
-- --
|
|
-- Copyright (C) 2002-2015, 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 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. --
|
|
-- --
|
|
-- 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.IO_Exceptions; use Ada.IO_Exceptions;
|
|
with Ada.Characters.Handling; use Ada.Characters.Handling;
|
|
with Ada.Directories;
|
|
|
|
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
|
|
|
|
-- 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.
|
|
|
|
-- 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
|
|
|
|
-- size (Tk) = max (for w in W) (length (w)) * size (used char set)
|
|
|
|
-- 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 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;
|
|
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;
|
|
|
|
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
|
|
|
|
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.
|
|
|
|
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.
|
|
|
|
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. 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.
|
|
|
|
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);
|
|
-- Use this line to provide buffered IO
|
|
|
|
procedure Add (C : Character);
|
|
procedure Add (S : String);
|
|
-- Add a character or a string in Line and update Last
|
|
|
|
procedure Put
|
|
(F : File_Descriptor;
|
|
S : String;
|
|
F1 : Natural;
|
|
L1 : Natural;
|
|
C1 : Natural;
|
|
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
|
|
-- semi-colon and writes the line into file F.
|
|
|
|
procedure New_Line (File : File_Descriptor);
|
|
-- Simulate Ada.Text_IO.New_Line with GNAT.OS_Lib
|
|
|
|
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);
|
|
-- Output a title and a used character set
|
|
|
|
procedure Put_Int_Vector
|
|
(File : File_Descriptor;
|
|
Title : String;
|
|
Vector : Integer;
|
|
Length : Natural);
|
|
-- Output a title and a vector
|
|
|
|
procedure Put_Int_Matrix
|
|
(File : File_Descriptor;
|
|
Title : String;
|
|
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);
|
|
-- Output a title and an edge table
|
|
|
|
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);
|
|
-- Output a title and a key table
|
|
|
|
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.
|
|
|
|
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 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.
|
|
|
|
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.
|
|
|
|
-----------------------------
|
|
-- Random Graph Generation --
|
|
-----------------------------
|
|
|
|
procedure Random (Seed : in out Natural);
|
|
-- Simulate Ada.Discrete_Numerics.Random
|
|
|
|
procedure Generate_Mapping_Table
|
|
(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;
|
|
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).
|
|
|
|
function Acyclic return Boolean;
|
|
-- 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:
|
|
-- h (w) = (g (f1 (w)) + g (f2 (w))) mod m
|
|
|
|
function Sum
|
|
(Word : Word_Type;
|
|
Table : Table_Id;
|
|
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
|
|
-- fk (w) = sum (for i in 1 .. length (w)) (Tk (i) * w (i)) mod n
|
|
-- Here NV = n
|
|
|
|
-------------------------------
|
|
-- Internal Table Management --
|
|
-------------------------------
|
|
|
|
function Allocate (N : Natural; S : Natural := 1) return Table_Id;
|
|
-- Allocate N * S ints from IT table
|
|
|
|
----------
|
|
-- Keys --
|
|
----------
|
|
|
|
Keys : Table_Id := No_Table;
|
|
NK : Natural := 0;
|
|
-- NK : Number of Keys
|
|
|
|
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 (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_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);
|
|
-- Get or Set the string position of the Pth selected character
|
|
|
|
-------------------
|
|
-- Used_Char_Set --
|
|
-------------------
|
|
|
|
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.
|
|
|
|
function Get_Used_Char (C : Character) return Natural;
|
|
procedure Set_Used_Char (C : Character; Item : Natural);
|
|
|
|
------------
|
|
-- Tables --
|
|
------------
|
|
|
|
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_Table (T : Integer; X, Y : Natural) return Natural;
|
|
procedure Set_Table (T : Integer; X, Y : Natural; Item : Natural);
|
|
|
|
-----------
|
|
-- Graph --
|
|
-----------
|
|
|
|
G : Table_Id := No_Table;
|
|
G_Len : Natural;
|
|
-- Values table to compute G
|
|
|
|
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 --
|
|
-----------
|
|
|
|
Edge_Size : constant := 3;
|
|
Edges : Table_Id := No_Table;
|
|
Edges_Len : Natural;
|
|
-- Edges : Edge table of the random graph G
|
|
|
|
function Get_Edges (F : Natural) return Edge_Type;
|
|
procedure Set_Edges (F : Natural; Item : Edge_Type);
|
|
|
|
--------------
|
|
-- Vertices --
|
|
--------------
|
|
|
|
Vertex_Size : constant := 2;
|
|
|
|
Vertices : Table_Id := No_Table;
|
|
-- Vertex table of the random graph G
|
|
|
|
NV : Natural;
|
|
-- Number of Vertices
|
|
|
|
function Get_Vertices (F : Natural) return Vertex_Type;
|
|
procedure Set_Vertices (F : Natural; Item : Vertex_Type);
|
|
-- Comments needed ???
|
|
|
|
K2V : Float;
|
|
-- Ratio between Keys and Vertices (parameter of Czech's algorithm)
|
|
|
|
Opt : Optimization;
|
|
-- Optimization mode (memory vs CPU)
|
|
|
|
Max_Key_Len : Natural := 0;
|
|
Min_Key_Len : Natural := 0;
|
|
-- Maximum and minimum of all the word length
|
|
|
|
S : Natural;
|
|
-- Seed
|
|
|
|
function Type_Size (L : Natural) return Natural;
|
|
-- Given the last L of an unsigned integer type T, return its size
|
|
|
|
-------------
|
|
-- Acyclic --
|
|
-------------
|
|
|
|
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.
|
|
|
|
--------------
|
|
-- Traverse --
|
|
--------------
|
|
|
|
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
|
|
|
|
-- Do not propagate to the edge representing the same key
|
|
|
|
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;
|
|
|
|
-- Start of processing for Acyclic
|
|
|
|
begin
|
|
-- Edges valid range is
|
|
|
|
for J in 1 .. Edges_Len - 1 loop
|
|
|
|
Edge := Get_Edges (J);
|
|
|
|
-- Mark X of E when it has not been already done
|
|
|
|
if Marks (Edge.X) = No_Vertex then
|
|
Marks (Edge.X) := Edge.X;
|
|
end if;
|
|
|
|
-- Traverse E when this has not already been done
|
|
|
|
if Marks (Edge.Y) = No_Vertex
|
|
and then not Traverse (J, Edge.X)
|
|
then
|
|
return False;
|
|
end if;
|
|
end loop;
|
|
|
|
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;
|
|
end Add;
|
|
|
|
---------
|
|
-- Add --
|
|
---------
|
|
|
|
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 := 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;
|
|
|
|
------------------------------
|
|
-- Apply_Position_Selection --
|
|
------------------------------
|
|
|
|
procedure Apply_Position_Selection is
|
|
begin
|
|
for J in 0 .. NK - 1 loop
|
|
declare
|
|
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.
|
|
|
|
for C in 0 .. Char_Pos_Set_Len - 1 loop
|
|
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. Be careful
|
|
-- to deallocate the old version to avoid memory leaks.
|
|
|
|
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;
|
|
|
|
-------------------------------
|
|
-- Assign_Values_To_Vertices --
|
|
-------------------------------
|
|
|
|
procedure Assign_Values_To_Vertices is
|
|
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.
|
|
|
|
------------
|
|
-- Assign --
|
|
------------
|
|
|
|
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;
|
|
|
|
-- Start of processing for Assign_Values_To_Vertices
|
|
|
|
begin
|
|
-- Value -1 denotes an uninitialized value as it is supposed to
|
|
-- be in the range 0 .. NK.
|
|
|
|
if G = No_Table then
|
|
G_Len := NV;
|
|
G := Allocate (G_Len, 1);
|
|
end if;
|
|
|
|
for J in 0 .. G_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 .. 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, 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 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;
|
|
-- 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_G.
|
|
|
|
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 each w, X = f1 (w) and Y = f2 (w)
|
|
|
|
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);
|
|
|
|
-- Discard T1 and T2 as soon as we discover a self loop
|
|
|
|
if X = Y then
|
|
Not_Acyclic := True;
|
|
exit;
|
|
end if;
|
|
|
|
-- We store (X, Y) and (Y, X) to ease assignment step
|
|
|
|
Set_Edges (2 * J + 1, (X, Y, J));
|
|
Set_Edges (2 * J + 2, (Y, X, J));
|
|
end loop;
|
|
|
|
-- Return an empty graph when self loop detected
|
|
|
|
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,
|
|
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.
|
|
|
|
Sorting.Sort (Edges_Len - 1);
|
|
|
|
if Verbose then
|
|
Put_Edges (Output, "Sorted Edge Table");
|
|
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
|
|
|
|
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;
|
|
|
|
------------
|
|
-- Define --
|
|
------------
|
|
|
|
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 := T1_Len;
|
|
Length_2 := T2_Len;
|
|
|
|
when Graph_Table =>
|
|
Item_Size := Type_Size (NK);
|
|
Length_1 := NV;
|
|
Length_2 := 0;
|
|
end case;
|
|
end Define;
|
|
|
|
--------------
|
|
-- Finalize --
|
|
--------------
|
|
|
|
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;
|
|
|
|
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;
|
|
|
|
T1_Len := 0;
|
|
T2_Len := 0;
|
|
|
|
G := No_Table;
|
|
G_Len := 0;
|
|
|
|
Edges := No_Table;
|
|
Edges_Len := 0;
|
|
|
|
Vertices := No_Table;
|
|
NV := 0;
|
|
|
|
NK := 0;
|
|
Max_Key_Len := 0;
|
|
Min_Key_Len := 0;
|
|
end Finalize;
|
|
|
|
----------------------------
|
|
-- Generate_Mapping_Table --
|
|
----------------------------
|
|
|
|
procedure Generate_Mapping_Table
|
|
(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 (Seed);
|
|
Set_Table (Tab, J, K, Seed mod NV);
|
|
end loop;
|
|
end loop;
|
|
end Generate_Mapping_Table;
|
|
|
|
-----------------------------
|
|
-- Generate_Mapping_Tables --
|
|
-----------------------------
|
|
|
|
procedure Generate_Mapping_Tables
|
|
(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 changed.
|
|
|
|
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;
|
|
|
|
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, 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,
|
|
T1_Len, T2_Len);
|
|
Put_Int_Matrix (Output, "Function Table 2", T2,
|
|
T1_Len, T2_Len);
|
|
end if;
|
|
end Generate_Mapping_Tables;
|
|
|
|
------------------
|
|
-- Get_Char_Pos --
|
|
------------------
|
|
|
|
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;
|
|
|
|
---------------
|
|
-- Get_Edges --
|
|
---------------
|
|
|
|
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;
|
|
|
|
---------------
|
|
-- Get_Graph --
|
|
---------------
|
|
|
|
function Get_Graph (N : Natural) return Integer is
|
|
begin
|
|
return IT.Table (G + N);
|
|
end Get_Graph;
|
|
|
|
-------------
|
|
-- Get_Key --
|
|
-------------
|
|
|
|
function Get_Key (N : Key_Id) return Key_Type is
|
|
K : Key_Type;
|
|
begin
|
|
K.Edge := IT.Table (Keys + N);
|
|
return K;
|
|
end Get_Key;
|
|
|
|
---------------
|
|
-- 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_Table;
|
|
|
|
-------------------
|
|
-- Get_Used_Char --
|
|
-------------------
|
|
|
|
function Get_Used_Char (C : Character) return Natural is
|
|
N : constant Natural := Used_Char_Set + Character'Pos (C);
|
|
begin
|
|
return IT.Table (N);
|
|
end Get_Used_Char;
|
|
|
|
------------------
|
|
-- Get_Vertices --
|
|
------------------
|
|
|
|
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;
|
|
|
|
-----------
|
|
-- Image --
|
|
-----------
|
|
|
|
function Image (Int : Integer; W : Natural := 0) return String is
|
|
B : String (1 .. 32);
|
|
L : Natural := 0;
|
|
|
|
procedure Img (V : Natural);
|
|
-- Compute image of V into B, starting at B (L), incrementing L
|
|
|
|
---------
|
|
-- Img --
|
|
---------
|
|
|
|
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;
|
|
|
|
-- Start of processing for Image
|
|
|
|
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;
|
|
|
|
-----------
|
|
-- 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;
|
|
|
|
-------------
|
|
-- Initial --
|
|
-------------
|
|
|
|
function Initial (K : Key_Id) return Word_Id is
|
|
begin
|
|
return K;
|
|
end Initial;
|
|
|
|
----------------
|
|
-- Initialize --
|
|
----------------
|
|
|
|
procedure Initialize
|
|
(Seed : Natural;
|
|
K_To_V : Float := Default_K_To_V;
|
|
Optim : Optimization := Memory_Space;
|
|
Tries : Positive := Default_Tries)
|
|
is
|
|
begin
|
|
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;
|
|
|
|
-- Initialize of computation variables
|
|
|
|
Keys := No_Table;
|
|
|
|
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;
|
|
|
|
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
|
|
Len : constant Natural := Value'Length;
|
|
|
|
begin
|
|
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) := New_Word (Value);
|
|
NK := NK + 1;
|
|
|
|
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 (File : File_Descriptor) is
|
|
begin
|
|
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 := Max_Key_Len;
|
|
|
|
T : array (1 .. M) of Boolean := (others => False);
|
|
|
|
function Parse_Index return Natural;
|
|
-- Parse argument starting at index N to find an index
|
|
|
|
-----------------
|
|
-- Parse_Index --
|
|
-----------------
|
|
|
|
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 Program_Error with "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;
|
|
|
|
-- Start of processing for Parse_Position_Selection
|
|
|
|
begin
|
|
-- Empty specification means all the positions
|
|
|
|
if L < N then
|
|
Char_Pos_Set_Len := M;
|
|
Char_Pos_Set := Allocate (Char_Pos_Set_Len);
|
|
|
|
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;
|
|
|
|
-- Detect a range
|
|
|
|
if N <= L and then Argument (N) = '-' then
|
|
N := N + 1;
|
|
Last := Parse_Index;
|
|
end if;
|
|
|
|
-- Include the positions in the selection
|
|
|
|
for J in First .. Last loop
|
|
T (J) := True;
|
|
end loop;
|
|
end;
|
|
|
|
exit when L < N;
|
|
|
|
if Argument (N) /= ',' then
|
|
raise Program_Error with "cannot read position argument";
|
|
end if;
|
|
|
|
N := N + 1;
|
|
end loop;
|
|
|
|
-- Compute position selection length
|
|
|
|
N := 0;
|
|
for J in T'Range loop
|
|
if T (J) then
|
|
N := N + 1;
|
|
end if;
|
|
end loop;
|
|
|
|
-- Fill position selection
|
|
|
|
Char_Pos_Set_Len := N;
|
|
Char_Pos_Set := Allocate (Char_Pos_Set_Len);
|
|
|
|
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;
|
|
|
|
-------------
|
|
-- Produce --
|
|
-------------
|
|
|
|
procedure Produce
|
|
(Pkg_Name : String := Default_Pkg_Name;
|
|
Use_Stdout : Boolean := False)
|
|
is
|
|
File : File_Descriptor := Standout;
|
|
|
|
Status : Boolean;
|
|
-- For call to Close
|
|
|
|
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 Type_Img (L : Natural) return String;
|
|
-- Return the larger unsigned type T such that T'Last < L
|
|
|
|
---------------
|
|
-- Array_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;
|
|
|
|
---------------
|
|
-- Range_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;
|
|
|
|
--------------
|
|
-- Type_Img --
|
|
--------------
|
|
|
|
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;
|
|
|
|
F : Natural;
|
|
L : Natural;
|
|
P : Natural;
|
|
|
|
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
|
|
|
|
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;
|
|
|
|
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);
|
|
|
|
if not Use_Stdout then
|
|
Close (File, Status);
|
|
|
|
if not Status then
|
|
raise Device_Error;
|
|
end if;
|
|
end if;
|
|
|
|
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;
|
|
|
|
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), 1, 0, 1, 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)), 1, 0, 1, F, L, J);
|
|
end loop;
|
|
|
|
New_Line (File);
|
|
|
|
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);
|
|
|
|
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, G_Len - 1)),
|
|
G, G_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 : ");
|
|
|
|
case Opt is
|
|
when CPU_Time =>
|
|
Put (File, Type_Img (256));
|
|
when Memory_Space =>
|
|
Put (File, "Natural");
|
|
end case;
|
|
|
|
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 := ");
|
|
|
|
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, " 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);
|
|
|
|
if not Use_Stdout then
|
|
Close (File, Status);
|
|
|
|
if not Status then
|
|
raise Device_Error;
|
|
end if;
|
|
end if;
|
|
end Produce;
|
|
|
|
---------
|
|
-- Put --
|
|
---------
|
|
|
|
procedure Put (File : File_Descriptor; Str : String) is
|
|
Len : constant Natural := Str'Length;
|
|
begin
|
|
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;
|
|
|
|
---------
|
|
-- 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;
|
|
-- Write current line, followed by LF
|
|
|
|
-----------
|
|
-- Flush --
|
|
-----------
|
|
|
|
procedure Flush is
|
|
begin
|
|
Put (F, Line (1 .. Last));
|
|
New_Line (F);
|
|
Last := 0;
|
|
end Flush;
|
|
|
|
-- Start of processing for Put
|
|
|
|
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
|
|
Add (" ");
|
|
|
|
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;
|
|
end if;
|
|
end if;
|
|
|
|
if C2 = F2 then
|
|
Add ('(');
|
|
|
|
if F2 = L2 then
|
|
Add ("0 .. 0 => ");
|
|
end if;
|
|
|
|
else
|
|
Add (' ');
|
|
end if;
|
|
|
|
Add (S);
|
|
|
|
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;
|
|
|
|
---------------
|
|
-- 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 --
|
|
----------------------
|
|
|
|
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;
|
|
Len_1 : Natural;
|
|
Len_2 : Natural)
|
|
is
|
|
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 Len_2 = 0 then
|
|
for J in F1 .. L1 loop
|
|
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
|
|
Ix := IT.Table (Table + J + K * Len_1);
|
|
Put (File, Image (Ix), F1, L1, J, F2, L2, K);
|
|
end loop;
|
|
end loop;
|
|
end if;
|
|
end Put_Int_Matrix;
|
|
|
|
--------------------
|
|
-- Put_Int_Vector --
|
|
--------------------
|
|
|
|
procedure Put_Int_Vector
|
|
(File : File_Descriptor;
|
|
Title : String;
|
|
Vector : 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 (Vector + J)), 1, 0, 1, F2, L2, J);
|
|
end loop;
|
|
end Put_Int_Vector;
|
|
|
|
----------------------
|
|
-- Put_Reduced_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, Trim_Trailing_Nuls (WT.Table (Reduced (J)).all),
|
|
F1, L1, J, 1, 3, 3);
|
|
end loop;
|
|
end Put_Reduced_Keys;
|
|
|
|
-----------------------
|
|
-- Put_Used_Char_Set --
|
|
-----------------------
|
|
|
|
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)), 1, 0, 1, F, L, Character'Pos (J));
|
|
end loop;
|
|
end Put_Used_Char_Set;
|
|
|
|
----------------------
|
|
-- Put_Vertex_Table --
|
|
----------------------
|
|
|
|
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;
|
|
|
|
------------
|
|
-- 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)
|
|
|
|
R : Natural;
|
|
Q : Natural;
|
|
X : Integer;
|
|
|
|
begin
|
|
R := Seed mod 127773;
|
|
Q := Seed / 127773;
|
|
X := 16807 * R - 2836 * Q;
|
|
|
|
Seed := (if X < 0 then X + 2147483647 else X);
|
|
end Random;
|
|
|
|
-------------
|
|
-- Reduced --
|
|
-------------
|
|
|
|
function Reduced (K : Key_Id) return Word_Id is
|
|
begin
|
|
return K + NK + 1;
|
|
end Reduced;
|
|
|
|
-----------------
|
|
-- 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
|
|
if L /= Len then
|
|
Free_Word (W);
|
|
S2 (1 .. L) := S1;
|
|
W := New_Word (S2);
|
|
end if;
|
|
end Resize_Word;
|
|
|
|
--------------------------
|
|
-- Select_Char_Position --
|
|
--------------------------
|
|
|
|
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 : 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 : Natural)
|
|
is
|
|
S : constant Vertex_Table_Type := Table (Table'First .. Last);
|
|
C : constant Natural := Pos;
|
|
-- 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 J in S'Range loop
|
|
if S (J).First = S (J).Last then
|
|
F := S (J).First;
|
|
L := S (J).Last;
|
|
Last := Last + 1;
|
|
Table (Last) := (F, L);
|
|
|
|
else
|
|
Offset := Reduced (S (J).First) - 1;
|
|
Sorting.Sort (S (J).Last - S (J).First + 1);
|
|
|
|
F := S (J).First;
|
|
L := F;
|
|
for N in S (J).First .. S (J).Last loop
|
|
|
|
-- For the last item, close the last subset
|
|
|
|
if N = S (J).Last then
|
|
Last := Last + 1;
|
|
Table (Last) := (F, N);
|
|
|
|
-- Two contiguous words are identical when they have the
|
|
-- same Cth character.
|
|
|
|
elsif WT.Table (Reduced (N))(C) =
|
|
WT.Table (Reduced (N + 1))(C)
|
|
then
|
|
L := N + 1;
|
|
|
|
-- Find a new subset of identical keys. Store the current
|
|
-- one and create a new subset.
|
|
|
|
else
|
|
Last := Last + 1;
|
|
Table (Last) := (F, L);
|
|
F := N + 1;
|
|
L := F;
|
|
end if;
|
|
end loop;
|
|
end if;
|
|
end loop;
|
|
end Build_Identical_Keys_Sets;
|
|
|
|
--------------------------
|
|
-- Count_Different_Keys --
|
|
--------------------------
|
|
|
|
function Count_Different_Keys
|
|
(Table : Vertex_Table_Type;
|
|
Last : Natural;
|
|
Pos : Natural) return Natural
|
|
is
|
|
N : array (Character) of Natural;
|
|
C : Character;
|
|
T : Natural := 0;
|
|
|
|
begin
|
|
-- For each subset, count the number of words that are still
|
|
-- 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
|
|
|
|
-- Count the occurrences of the different characters
|
|
|
|
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;
|
|
|
|
-- Update the number of different keys. Each character used
|
|
-- denotes a different key.
|
|
|
|
for J in N'Range loop
|
|
if N (J) > 0 then
|
|
T := T + 1;
|
|
end if;
|
|
end loop;
|
|
end loop;
|
|
|
|
return T;
|
|
end Count_Different_Keys;
|
|
|
|
-- Start of processing for Select_Char_Position
|
|
|
|
begin
|
|
-- Initialize the reduced words set
|
|
|
|
for K in 0 .. NK - 1 loop
|
|
WT.Table (Reduced (K)) := New_Word (WT.Table (Initial (K)).all);
|
|
end loop;
|
|
|
|
declare
|
|
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
|
|
for C in Sel_Position'Range loop
|
|
Sel_Position (C) := C;
|
|
end loop;
|
|
|
|
Same_Keys_Sets_Table (1) := (0, NK - 1);
|
|
|
|
loop
|
|
-- 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;
|
|
|
|
-- The first position should not exceed the minimum key length.
|
|
-- Otherwise, we may end up with an empty word once reduced.
|
|
|
|
Max_Sel_Pos :=
|
|
(if Last_Sel_Pos = 0 then Min_Key_Len else Max_Key_Len);
|
|
|
|
-- 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 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_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 .. 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 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) := Max_Diff_Sel_Pos;
|
|
exit;
|
|
end if;
|
|
end loop;
|
|
|
|
exit when Max_Differences = NK;
|
|
|
|
Build_Identical_Keys_Sets
|
|
(Same_Keys_Sets_Table,
|
|
Same_Keys_Sets_Last,
|
|
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);
|
|
|
|
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;
|
|
|
|
---------------
|
|
-- Set_Edges --
|
|
---------------
|
|
|
|
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;
|
|
|
|
---------------
|
|
-- Set_Graph --
|
|
---------------
|
|
|
|
procedure Set_Graph (N : Natural; Item : Integer) is
|
|
begin
|
|
IT.Table (G + N) := Item;
|
|
end Set_Graph;
|
|
|
|
-------------
|
|
-- Set_Key --
|
|
-------------
|
|
|
|
procedure Set_Key (N : Key_Id; Item : Key_Type) is
|
|
begin
|
|
IT.Table (Keys + N) := Item.Edge;
|
|
end Set_Key;
|
|
|
|
---------------
|
|
-- 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_Table;
|
|
|
|
-------------------
|
|
-- Set_Used_Char --
|
|
-------------------
|
|
|
|
procedure Set_Used_Char (C : Character; Item : Natural) is
|
|
N : constant Natural := Used_Char_Set + Character'Pos (C);
|
|
begin
|
|
IT.Table (N) := Item;
|
|
end Set_Used_Char;
|
|
|
|
------------------
|
|
-- Set_Vertices --
|
|
------------------
|
|
|
|
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;
|
|
|
|
---------
|
|
-- Sum --
|
|
---------
|
|
|
|
function Sum
|
|
(Word : Word_Type;
|
|
Table : Table_Id;
|
|
Opt : Optimization) return Natural
|
|
is
|
|
S : Natural := 0;
|
|
R : Natural;
|
|
|
|
begin
|
|
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;
|
|
|
|
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 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;
|
|
|
|
-----------
|
|
-- Value --
|
|
-----------
|
|
|
|
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_Table (T1, J, K);
|
|
|
|
when Function_Table_2 =>
|
|
return Get_Table (T2, J, K);
|
|
|
|
when Graph_Table =>
|
|
return Get_Graph (J);
|
|
|
|
end case;
|
|
end Value;
|
|
|
|
end GNAT.Perfect_Hash_Generators;
|