gcc/ada/g-pehage.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --        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           --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --            Copyright (C) 2002-2005 Ada Core Technologies, Inc.           --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNAT was originally developed  by the GNAT team at  New York University. --
  30 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 with Ada.Exceptions;    use Ada.Exceptions;
  35 with Ada.IO_Exceptions; use Ada.IO_Exceptions;
  36
  37 with GNAT.Heap_Sort_A; use GNAT.Heap_Sort_A;
  38 with GNAT.OS_Lib;      use GNAT.OS_Lib;
  39 with GNAT.Table;
  40
  41 package body GNAT.Perfect_Hash_Generators is
  42
  43    --  We are using the algorithm of J. Czech as described in Zbigniew J.
  44    --  Czech, George Havas, and Bohdan S. Majewski ``An Optimal Algorithm for
  45    --  Generating Minimal Perfect Hash Functions'', Information Processing
  46    --  Letters, 43(1992) pp.257-264, Oct.1992
  47
  48    --  This minimal perfect hash function generator is based on random graphs
  49    --  and produces a hash function of the form:
  50
  51    --             h (w) = (g (f1 (w)) + g (f2 (w))) mod m
  52
  53    --  where f1 and f2 are functions that map strings into integers, and g is a
  54    --  function that maps integers into [0, m-1]. h can be order preserving.
  55    --  For instance, let W = {w_0, ..., w_i, ...,
  56    --  w_m-1}, h can be defined such that h (w_i) = i.
  57
  58    --  This algorithm defines two possible constructions of f1 and f2. Method
  59    --  b) stores the hash function in less memory space at the expense of
  60    --  greater CPU time.
  61
  62    --  a) fk (w) = sum (for i in 1 .. length (w)) (Tk (i, w (i))) mod n
  63
  64    --     size (Tk) = max (for w in W) (length (w)) * size (used char set)
  65
  66    --  b) fk (w) = sum (for i in 1 .. length (w)) (Tk (i) * w (i)) mod n
  67
  68    --     size (Tk) = max (for w in W) (length (w)) but the table lookups are
  69    --     replaced by multiplications.
  70
  71    --  where Tk values are randomly generated. n is defined later on but the
  72    --  algorithm recommends to use a value a little bit greater than 2m. Note
  73    --  that for large values of m, the main memory space requirements comes
  74    --  from the memory space for storing function g (>= 2m entries).
  75
  76    --  Random graphs are frequently used to solve difficult problems that do
  77    --  not have polynomial solutions. This algorithm is based on a weighted
  78    --  undirected graph. It comprises two steps: mapping and assigment.
  79
  80    --  In the mapping step, a graph G = (V, E) is constructed, where = {0, 1,
  81    --  ..., n-1} and E = {(for w in W) (f1 (w), f2 (w))}. In order for the
  82    --  assignment step to be successful, G has to be acyclic. To have a high
  83    --  probability of generating an acyclic graph, n >= 2m. If it is not
  84    --  acyclic, Tk have to be regenerated.
  85
  86    --  In the assignment step, the algorithm builds function g. As is acyclic,
  87    --  there is a vertex v1 with only one neighbor v2. Let w_i be the word such
  88    --  that v1 = f1 (w_i) and v2 = f2 (w_i). Let g (v1) = 0 by construction and
  89    --  g (v2) = (i - g (v1)) mod n (or to be general, (h (i) - g (v1) mod n).
  90    --  If word w_j is such that v2 = f1 (w_j) and v3 = f2 (w_j), g (v3) = (j -
  91    --  g (v2)) mod (or to be general, (h (j) - g (v2)) mod n). If w_i has no
  92    --  neighbor, then another vertex is selected. The algorithm traverses G to
  93    --  assign values to all the vertices. It cannot assign a value to an
  94    --  already assigned vertex as G is acyclic.
  95
  96    subtype Word_Id   is Integer;
  97    subtype Key_Id    is Integer;
  98    subtype Vertex_Id is Integer;
  99    subtype Edge_Id   is Integer;
 100    subtype Table_Id  is Integer;
 101
 102    No_Vertex : constant Vertex_Id := -1;
 103    No_Edge   : constant Edge_Id   := -1;
 104    No_Table  : constant Table_Id  := -1;
 105
 106    Max_Word_Length : constant := 32;
 107    subtype Word_Type is String (1 .. Max_Word_Length);
 108    Null_Word : constant Word_Type := (others => ASCII.NUL);
 109    --  Store keyword in a word. Note that the length of word is limited to 32
 110    --  characters.
 111
 112    type Key_Type is record
 113       Edge : Edge_Id;
 114    end record;
 115    --  A key corresponds to an edge in the algorithm graph
 116
 117    type Vertex_Type is record
 118       First : Edge_Id;
 119       Last  : Edge_Id;
 120    end record;
 121    --  A vertex can be involved in several edges. First and Last are the bounds
 122    --  of an array of edges stored in a global edge table.
 123
 124    type Edge_Type is record
 125       X   : Vertex_Id;
 126       Y   : Vertex_Id;
 127       Key : Key_Id;
 128    end record;
 129    --  An edge is a peer of vertices. In the algorithm, a key is associated to
 130    --  an edge.
 131
 132    package WT is new GNAT.Table (Word_Type, Word_Id, 0, 32, 32);
 133    package IT is new GNAT.Table (Integer, Integer, 0, 32, 32);
 134    --  The two main tables. IT is used to store several tables of components
 135    --  containing only integers.
 136
 137    function Image (Int : Integer; W : Natural := 0) return String;
 138    function Image (Str : String;  W : Natural := 0) return String;
 139    --  Return a string which includes string Str or integer Int preceded by
 140    --  leading spaces if required by width W.
 141
 142    Output : File_Descriptor renames GNAT.OS_Lib.Standout;
 143    --  Shortcuts
 144
 145    EOL : constant Character := ASCII.LF;
 146
 147    Max  : constant := 78;
 148    Last : Natural  := 0;
 149    Line : String (1 .. Max);
 150    --  Use this line to provide buffered IO
 151
 152    procedure Add (C : Character);
 153    procedure Add (S : String);
 154    --  Add a character or a string in Line and update Last
 155
 156    procedure Put
 157      (F  : File_Descriptor;
 158       S  : String;
 159       F1 : Natural;
 160       L1 : Natural;
 161       C1 : Natural;
 162       F2 : Natural;
 163       L2 : Natural;
 164       C2 : Natural);
 165    --  Write string S into file F as a element of an array of one or two
 166    --  dimensions. Fk (resp. Lk and Ck) indicates the first (resp last and
 167    --  current) index in the k-th dimension. If F1 = L1 the array is considered
 168    --  as a one dimension array. This dimension is described by F2 and L2. This
 169    --  routine takes care of all the parenthesis, spaces and commas needed to
 170    --  format correctly the array. Moreover, the array is well indented and is
 171    --  wrapped to fit in a 80 col line. When the line is full, the routine
 172    --  writes it into file F. When the array is completed, the routine adds
 173    --  semi-colon and writes the line into file F.
 174
 175    procedure New_Line
 176      (File : File_Descriptor);
 177    --  Simulate Ada.Text_IO.New_Line with GNAT.OS_Lib
 178
 179    procedure Put
 180      (File : File_Descriptor;
 181       Str  : String);
 182    --  Simulate Ada.Text_IO.Put with GNAT.OS_Lib
 183
 184    procedure Put_Used_Char_Set
 185      (File  : File_Descriptor;
 186       Title : String);
 187    --  Output a title and a used character set
 188
 189    procedure Put_Int_Vector
 190      (File   : File_Descriptor;
 191       Title  : String;
 192       Vector : Integer;
 193       Length : Natural);
 194    --  Output a title and a vector
 195
 196    procedure Put_Int_Matrix
 197      (File  : File_Descriptor;
 198       Title : String;
 199       Table : Table_Id;
 200       Len_1 : Natural;
 201       Len_2 : Natural);
 202    --  Output a title and a matrix. When the matrix has only one non-empty
 203    --  dimension (Len_2 = 0), output a vector.
 204
 205    procedure Put_Edges
 206      (File  : File_Descriptor;
 207       Title : String);
 208    --  Output a title and an edge table
 209
 210    procedure Put_Initial_Keys
 211      (File  : File_Descriptor;
 212       Title : String);
 213    --  Output a title and a key table
 214
 215    procedure Put_Reduced_Keys
 216      (File  : File_Descriptor;
 217       Title : String);
 218    --  Output a title and a key table
 219
 220    procedure Put_Vertex_Table
 221      (File  : File_Descriptor;
 222       Title : String);
 223    --  Output a title and a vertex table
 224
 225    ----------------------------------
 226    -- Character Position Selection --
 227    ----------------------------------
 228
 229    --  We reduce the maximum key size by selecting representative positions
 230    --  in these keys. We build a matrix with one word per line. We fill the
 231    --  remaining space of a line with ASCII.NUL. The heuristic selects the
 232    --  position that induces the minimum number of collisions. If there are
 233    --  collisions, select another position on the reduced key set responsible
 234    --  of the collisions. Apply the heuristic until there is no more collision.
 235
 236    procedure Apply_Position_Selection;
 237    --  Apply Position selection and build the reduced key table
 238
 239    procedure Parse_Position_Selection (Argument : String);
 240    --  Parse Argument and compute the position set. Argument is list of
 241    --  substrings separated by commas. Each substring represents a position
 242    --  or a range of positions (like x-y).
 243
 244    procedure Select_Character_Set;
 245    --  Define an optimized used character set like Character'Pos in order not
 246    --  to allocate tables of 256 entries.
 247
 248    procedure Select_Char_Position;
 249    --  Find a min char position set in order to reduce the max key length. The
 250    --  heuristic selects the position that induces the minimum number of
 251    --  collisions. If there are collisions, select another position on the
 252    --  reduced key set responsible of the collisions. Apply the heuristic until
 253    --  there is no collision.
 254
 255    -----------------------------
 256    -- Random Graph Generation --
 257    -----------------------------
 258
 259    procedure Random (Seed : in out Natural);
 260    --  Simulate Ada.Discrete_Numerics.Random
 261
 262    procedure Generate_Mapping_Table
 263      (Tab  : Table_Id;
 264       L1   : Natural;
 265       L2   : Natural;
 266       Seed : in out Natural);
 267    --  Random generation of the tables below. T is already allocated
 268
 269    procedure Generate_Mapping_Tables
 270      (Opt  : Optimization;
 271       Seed : in out Natural);
 272    --  Generate the mapping tables T1 and T2. They are used to define fk (w) =
 273    --  sum (for i in 1 .. length (w)) (Tk (i, w (i))) mod n. Keys, NK and Chars
 274    --  are used to compute the matrix size.
 275
 276    ---------------------------
 277    -- Algorithm Computation --
 278    ---------------------------
 279
 280    procedure Compute_Edges_And_Vertices (Opt : Optimization);
 281    --  Compute the edge and vertex tables. These are empty when a self loop is
 282    --  detected (f1 (w) = f2 (w)). The edge table is sorted by X value and then
 283    --  Y value. Keys is the key table and NK the number of keys. Chars is the
 284    --  set of characters really used in Keys. NV is the number of vertices
 285    --  recommended by the algorithm. T1 and T2 are the mapping tables needed to
 286    --  compute f1 (w) and f2 (w).
 287
 288    function Acyclic return Boolean;
 289    --  Return True when the graph is acyclic. Vertices is the current vertex
 290    --  table and Edges the current edge table.
 291
 292    procedure Assign_Values_To_Vertices;
 293    --  Execute the assignment step of the algorithm. Keys is the current key
 294    --  table. Vertices and Edges represent the random graph. G is the result of
 295    --  the assignment step such that:
 296    --    h (w) = (g (f1 (w)) + g (f2 (w))) mod m
 297
 298    function Sum
 299      (Word  : Word_Type;
 300       Table : Table_Id;
 301       Opt   : Optimization) return Natural;
 302    --  For an optimization of CPU_Time return
 303    --    fk (w) = sum (for i in 1 .. length (w)) (Tk (i, w (i))) mod n
 304    --  For an optimization of Memory_Space return
 305    --    fk (w) = sum (for i in 1 .. length (w)) (Tk (i) * w (i)) mod n
 306    --  Here NV = n
 307
 308    -------------------------------
 309    -- Internal Table Management --
 310    -------------------------------
 311
 312    function  Allocate (N : Natural; S : Natural := 1) return Table_Id;
 313    --  Allocate N * S ints from IT table
 314
 315    procedure Free_Tmp_Tables;
 316    --  Deallocate the tables used by the algorithm (but not the keys table)
 317
 318    ----------
 319    -- Keys --
 320    ----------
 321
 322    Keys : Table_Id := No_Table;
 323    NK   : Natural  := 0;
 324    --  NK : Number of Keys
 325
 326    function Initial (K : Key_Id) return Word_Id;
 327    pragma Inline (Initial);
 328
 329    function Reduced (K : Key_Id) return Word_Id;
 330    pragma Inline (Reduced);
 331
 332    function  Get_Key (N : Key_Id) return Key_Type;
 333    procedure Set_Key (N : Key_Id; Item : Key_Type);
 334    --  Get or Set Nth element of Keys table
 335
 336    ------------------
 337    -- Char_Pos_Set --
 338    ------------------
 339
 340    Char_Pos_Set     : Table_Id := No_Table;
 341    Char_Pos_Set_Len : Natural;
 342    --  Character Selected Position Set
 343
 344    function  Get_Char_Pos (P : Natural) return Natural;
 345    procedure Set_Char_Pos (P : Natural; Item : Natural);
 346    --  Get or Set the string position of the Pth selected character
 347
 348    -------------------
 349    -- Used_Char_Set --
 350    -------------------
 351
 352    Used_Char_Set     : Table_Id := No_Table;
 353    Used_Char_Set_Len : Natural;
 354    --  Used Character Set : Define a new character mapping. When all the
 355    --  characters are not present in the keys, in order to reduce the size
 356    --  of some tables, we redefine the character mapping.
 357
 358    function  Get_Used_Char (C : Character) return Natural;
 359    procedure Set_Used_Char (C : Character; Item : Natural);
 360
 361    ------------
 362    -- Tables --
 363    ------------
 364
 365    T1     : Table_Id := No_Table;
 366    T2     : Table_Id := No_Table;
 367    T1_Len : Natural;
 368    T2_Len : Natural;
 369    --  T1  : Values table to compute F1
 370    --  T2  : Values table to compute F2
 371
 372    function  Get_Table (T : Integer; X, Y : Natural) return Natural;
 373    procedure Set_Table (T : Integer; X, Y : Natural; Item : Natural);
 374
 375    -----------
 376    -- Graph --
 377    -----------
 378
 379    G     : Table_Id := No_Table;
 380    G_Len : Natural;
 381    --  Values table to compute G
 382
 383    NT : Natural := Default_Tries;
 384    --  Number of tries running the algorithm before raising an error
 385
 386    function  Get_Graph (N : Natural) return Integer;
 387    procedure Set_Graph (N : Natural; Item : Integer);
 388    --  Get or Set Nth element of graph
 389
 390    -----------
 391    -- Edges --
 392    -----------
 393
 394    Edge_Size : constant := 3;
 395    Edges     : Table_Id := No_Table;
 396    Edges_Len : Natural;
 397    --  Edges  : Edge table of the random graph G
 398
 399    function  Get_Edges (F : Natural) return Edge_Type;
 400    procedure Set_Edges (F : Natural; Item : Edge_Type);
 401
 402    --------------
 403    -- Vertices --
 404    --------------
 405
 406    Vertex_Size : constant := 2;
 407
 408    Vertices : Table_Id := No_Table;
 409    --  Vertex table of the random graph G
 410
 411    NV : Natural;
 412    --  Number of Vertices
 413
 414    function  Get_Vertices (F : Natural) return Vertex_Type;
 415    procedure Set_Vertices (F : Natural; Item : Vertex_Type);
 416    --  Comments needed ???
 417
 418    K2V : Float;
 419    --  Ratio between Keys and Vertices (parameter of Czech's algorithm)
 420
 421    Opt : Optimization;
 422    --  Optimization mode (memory vs CPU)
 423
 424    Max_Key_Len : Natural := 0;
 425    Min_Key_Len : Natural := Max_Word_Length;
 426    --  Maximum and minimum of all the word length
 427
 428    S : Natural;
 429    --  Seed
 430
 431    function Type_Size (L : Natural) return Natural;
 432    --  Given the last L of an unsigned integer type T, return its size
 433
 434    -------------
 435    -- Acyclic --
 436    -------------
 437
 438    function Acyclic return Boolean is
 439       Marks : array (0 .. NV - 1) of Vertex_Id := (others => No_Vertex);
 440
 441       function Traverse
 442         (Edge : Edge_Id;
 443          Mark : Vertex_Id) return Boolean;
 444       --  Propagate Mark from X to Y. X is already marked. Mark Y and propagate
 445       --  it to the edges of Y except the one representing the same key. Return
 446       --  False when Y is marked with Mark.
 447
 448       --------------
 449       -- Traverse --
 450       --------------
 451
 452       function Traverse
 453         (Edge : Edge_Id;
 454          Mark : Vertex_Id) return Boolean
 455       is
 456          E : constant Edge_Type := Get_Edges (Edge);
 457          K : constant Key_Id    := E.Key;
 458          Y : constant Vertex_Id := E.Y;
 459          M : constant Vertex_Id := Marks (E.Y);
 460          V : Vertex_Type;
 461
 462       begin
 463          if M = Mark then
 464             return False;
 465
 466          elsif M = No_Vertex then
 467             Marks (Y) := Mark;
 468             V := Get_Vertices (Y);
 469
 470             for J in V.First .. V.Last loop
 471
 472                --  Do not propagate to the edge representing the same key
 473
 474                if Get_Edges (J).Key /= K
 475                  and then not Traverse (J, Mark)
 476                then
 477                   return False;
 478                end if;
 479             end loop;
 480          end if;
 481
 482          return True;
 483       end Traverse;
 484
 485       Edge  : Edge_Type;
 486
 487    --  Start of processing for Acyclic
 488
 489    begin
 490       --  Edges valid range is
 491
 492       for J in 1 .. Edges_Len - 1 loop
 493
 494          Edge := Get_Edges (J);
 495
 496          --  Mark X of E when it has not been already done
 497
 498          if Marks (Edge.X) = No_Vertex then
 499             Marks (Edge.X) := Edge.X;
 500          end if;
 501
 502          --  Traverse E when this has not already been done
 503
 504          if Marks (Edge.Y) = No_Vertex
 505            and then not Traverse (J, Edge.X)
 506          then
 507             return False;
 508          end if;
 509       end loop;
 510
 511       return True;
 512    end Acyclic;
 513
 514    ---------
 515    -- Add --
 516    ---------
 517
 518    procedure Add (C : Character) is
 519    begin
 520       Line (Last + 1) := C;
 521       Last := Last + 1;
 522    end Add;
 523
 524    ---------
 525    -- Add --
 526    ---------
 527
 528    procedure Add (S : String) is
 529       Len : constant Natural := S'Length;
 530    begin
 531       Line (Last + 1 .. Last + Len) := S;
 532       Last := Last + Len;
 533    end Add;
 534
 535    --------------
 536    -- Allocate --
 537    --------------
 538
 539    function  Allocate (N : Natural; S : Natural := 1) return Table_Id is
 540       L : constant Integer := IT.Last;
 541    begin
 542       IT.Set_Last (L + N * S);
 543       return L + 1;
 544    end Allocate;
 545
 546    ------------------------------
 547    -- Apply_Position_Selection --
 548    ------------------------------
 549
 550    procedure Apply_Position_Selection is
 551    begin
 552       WT.Set_Last (2 * NK);
 553       for J in 0 .. NK - 1 loop
 554          declare
 555             I_Word : constant Word_Type := WT.Table (Initial (J));
 556             R_Word : Word_Type := Null_Word;
 557             Index  : Natural   := I_Word'First - 1;
 558
 559          begin
 560             --  Select the characters of Word included in the position
 561             --  selection.
 562
 563             for C in 0 .. Char_Pos_Set_Len - 1 loop
 564                exit when I_Word (Get_Char_Pos (C)) = ASCII.NUL;
 565                Index := Index + 1;
 566                R_Word (Index) := I_Word (Get_Char_Pos (C));
 567             end loop;
 568
 569             --  Build the new table with the reduced word
 570
 571             WT.Table (Reduced (J)) := R_Word;
 572             Set_Key (J, (Edge => No_Edge));
 573          end;
 574       end loop;
 575    end Apply_Position_Selection;
 576
 577    -------------------------------
 578    -- Assign_Values_To_Vertices --
 579    -------------------------------
 580
 581    procedure Assign_Values_To_Vertices is
 582       X  : Vertex_Id;
 583
 584       procedure Assign (X : Vertex_Id);
 585       --  Execute assignment on X's neighbors except the vertex that we are
 586       --  coming from which is already assigned.
 587
 588       ------------
 589       -- Assign --
 590       ------------
 591
 592       procedure Assign (X : Vertex_Id)
 593       is
 594          E : Edge_Type;
 595          V : constant Vertex_Type := Get_Vertices (X);
 596       begin
 597          for J in V.First .. V.Last loop
 598             E := Get_Edges (J);
 599             if Get_Graph (E.Y) = -1 then
 600                Set_Graph (E.Y, (E.Key - Get_Graph (X)) mod NK);
 601                Assign (E.Y);
 602             end if;
 603          end loop;
 604       end Assign;
 605
 606    --  Start of processing for Assign_Values_To_Vertices
 607
 608    begin
 609       --  Value -1 denotes an unitialized value as it is supposed to
 610       --  be in the range 0 .. NK.
 611
 612       if G = No_Table then
 613          G_Len := NV;
 614          G := Allocate (G_Len, 1);
 615       end if;
 616
 617       for J in 0 .. G_Len - 1 loop
 618          Set_Graph (J, -1);
 619       end loop;
 620
 621       for K in 0 .. NK - 1 loop
 622          X := Get_Edges (Get_Key (K).Edge).X;
 623
 624          if Get_Graph (X) = -1 then
 625             Set_Graph (X, 0);
 626             Assign (X);
 627          end if;
 628       end loop;
 629
 630       for J in 0 .. G_Len - 1 loop
 631          if Get_Graph (J) = -1 then
 632             Set_Graph (J, 0);
 633          end if;
 634       end loop;
 635
 636       if Verbose then
 637          Put_Int_Vector (Output, "Assign Values To Vertices", G, G_Len);
 638       end if;
 639    end Assign_Values_To_Vertices;
 640
 641    -------------
 642    -- Compute --
 643    -------------
 644
 645    procedure Compute
 646      (Position : String := Default_Position)
 647    is
 648       Success : Boolean := False;
 649
 650    begin
 651       NV := Natural (K2V * Float (NK));
 652
 653       Keys := Allocate (NK);
 654
 655       if Verbose then
 656          Put_Initial_Keys (Output, "Initial Key Table");
 657       end if;
 658
 659       if Position'Length /= 0 then
 660          Parse_Position_Selection (Position);
 661       else
 662          Select_Char_Position;
 663       end if;
 664
 665       if Verbose then
 666          Put_Int_Vector
 667            (Output, "Char Position Set", Char_Pos_Set, Char_Pos_Set_Len);
 668       end if;
 669
 670       Apply_Position_Selection;
 671
 672       if Verbose then
 673          Put_Reduced_Keys (Output, "Reduced Keys Table");
 674       end if;
 675
 676       Select_Character_Set;
 677
 678       if Verbose then
 679          Put_Used_Char_Set (Output, "Character Position Table");
 680       end if;
 681
 682       --  Perform Czech's algorithm
 683
 684       for J in 1 .. NT loop
 685          Generate_Mapping_Tables (Opt, S);
 686          Compute_Edges_And_Vertices (Opt);
 687
 688          --  When graph is not empty (no self-loop from previous operation) and
 689          --  not acyclic.
 690
 691          if 0 < Edges_Len and then Acyclic then
 692             Success := True;
 693             exit;
 694          end if;
 695       end loop;
 696
 697       if not Success then
 698          raise Too_Many_Tries;
 699       end if;
 700
 701       Assign_Values_To_Vertices;
 702    end Compute;
 703
 704    --------------------------------
 705    -- Compute_Edges_And_Vertices --
 706    --------------------------------
 707
 708    procedure Compute_Edges_And_Vertices (Opt : Optimization) is
 709       X           : Natural;
 710       Y           : Natural;
 711       Key         : Key_Type;
 712       Edge        : Edge_Type;
 713       Vertex      : Vertex_Type;
 714       Not_Acyclic : Boolean := False;
 715
 716       procedure Move (From : Natural; To : Natural);
 717       function Lt (L, R : Natural) return Boolean;
 718       --  Subprograms needed for GNAT.Heap_Sort_A
 719
 720       --------
 721       -- Lt --
 722       --------
 723
 724       function Lt (L, R : Natural) return Boolean is
 725          EL : constant Edge_Type := Get_Edges (L);
 726          ER : constant Edge_Type := Get_Edges (R);
 727       begin
 728          return EL.X < ER.X or else (EL.X = ER.X and then EL.Y < ER.Y);
 729       end Lt;
 730
 731       ----------
 732       -- Move --
 733       ----------
 734
 735       procedure Move (From : Natural; To : Natural) is
 736       begin
 737          Set_Edges (To, Get_Edges (From));
 738       end Move;
 739
 740    --  Start of processing for Compute_Edges_And_Vertices
 741
 742    begin
 743       --  We store edges from 1 to 2 * NK and leave zero alone in order to use
 744       --  GNAT.Heap_Sort_A.
 745
 746       Edges_Len := 2 * NK + 1;
 747
 748       if Edges = No_Table then
 749          Edges := Allocate (Edges_Len, Edge_Size);
 750       end if;
 751
 752       if Vertices = No_Table then
 753          Vertices := Allocate (NV, Vertex_Size);
 754       end if;
 755
 756       for J in 0 .. NV - 1 loop
 757          Set_Vertices (J, (No_Vertex, No_Vertex - 1));
 758       end loop;
 759
 760       --  For each w, X = f1 (w) and Y = f2 (w)
 761
 762       for J in 0 .. NK - 1 loop
 763          Key := Get_Key (J);
 764          Key.Edge := No_Edge;
 765          Set_Key (J, Key);
 766
 767          X := Sum (WT.Table (Reduced (J)), T1, Opt);
 768          Y := Sum (WT.Table (Reduced (J)), T2, Opt);
 769
 770          --  Discard T1 and T2 as soon as we discover a self loop
 771
 772          if X = Y then
 773             Not_Acyclic := True;
 774             exit;
 775          end if;
 776
 777          --  We store (X, Y) and (Y, X) to ease assignment step
 778
 779          Set_Edges (2 * J + 1, (X, Y, J));
 780          Set_Edges (2 * J + 2, (Y, X, J));
 781       end loop;
 782
 783       --  Return an empty graph when self loop detected
 784
 785       if Not_Acyclic then
 786          Edges_Len := 0;
 787
 788       else
 789          if Verbose then
 790             Put_Edges      (Output, "Unsorted Edge Table");
 791             Put_Int_Matrix (Output, "Function Table 1", T1,
 792                             T1_Len, T2_Len);
 793             Put_Int_Matrix (Output, "Function Table 2", T2,
 794                             T1_Len, T2_Len);
 795          end if;
 796
 797          --  Enforce consistency between edges and keys. Construct Vertices and
 798          --  compute the list of neighbors of a vertex First .. Last as Edges
 799          --  is sorted by X and then Y. To compute the neighbor list, sort the
 800          --  edges.
 801
 802          Sort
 803            (Edges_Len - 1,
 804             Move'Unrestricted_Access,
 805             Lt'Unrestricted_Access);
 806
 807          if Verbose then
 808             Put_Edges      (Output, "Sorted Edge Table");
 809             Put_Int_Matrix (Output, "Function Table 1", T1,
 810                             T1_Len, T2_Len);
 811             Put_Int_Matrix (Output, "Function Table 2", T2,
 812                             T1_Len, T2_Len);
 813          end if;
 814
 815          --  Edges valid range is 1 .. 2 * NK
 816
 817          for E in 1 .. Edges_Len - 1 loop
 818             Edge := Get_Edges (E);
 819             Key  := Get_Key (Edge.Key);
 820
 821             if Key.Edge = No_Edge then
 822                Key.Edge := E;
 823                Set_Key (Edge.Key, Key);
 824             end if;
 825
 826             Vertex := Get_Vertices (Edge.X);
 827
 828             if Vertex.First = No_Edge then
 829                Vertex.First := E;
 830             end if;
 831
 832             Vertex.Last := E;
 833             Set_Vertices (Edge.X, Vertex);
 834          end loop;
 835
 836          if Verbose then
 837             Put_Reduced_Keys (Output, "Key Table");
 838             Put_Edges        (Output, "Edge Table");
 839             Put_Vertex_Table (Output, "Vertex Table");
 840          end if;
 841       end if;
 842    end Compute_Edges_And_Vertices;
 843
 844    ------------
 845    -- Define --
 846    ------------
 847
 848    procedure Define
 849      (Name      : Table_Name;
 850       Item_Size : out Natural;
 851       Length_1  : out Natural;
 852       Length_2  : out Natural)
 853    is
 854    begin
 855       case Name is
 856          when Character_Position =>
 857             Item_Size := 8;
 858             Length_1  := Char_Pos_Set_Len;
 859             Length_2  := 0;
 860
 861          when Used_Character_Set =>
 862             Item_Size := 8;
 863             Length_1  := 256;
 864             Length_2  := 0;
 865
 866          when Function_Table_1
 867            |  Function_Table_2 =>
 868             Item_Size := Type_Size (NV);
 869             Length_1  := T1_Len;
 870             Length_2  := T2_Len;
 871
 872          when Graph_Table =>
 873             Item_Size := Type_Size (NK);
 874             Length_1  := NV;
 875             Length_2  := 0;
 876       end case;
 877    end Define;
 878
 879    --------------
 880    -- Finalize --
 881    --------------
 882
 883    procedure Finalize is
 884    begin
 885       Free_Tmp_Tables;
 886
 887       WT.Release;
 888       IT.Release;
 889
 890       NK := 0;
 891       Max_Key_Len := 0;
 892       Min_Key_Len := Max_Word_Length;
 893    end Finalize;
 894
 895    ---------------------
 896    -- Free_Tmp_Tables --
 897    ---------------------
 898
 899    procedure Free_Tmp_Tables is
 900    begin
 901       IT.Init;
 902
 903       Keys := No_Table;
 904
 905       Char_Pos_Set     := No_Table;
 906       Char_Pos_Set_Len := 0;
 907
 908       Used_Char_Set     := No_Table;
 909       Used_Char_Set_Len := 0;
 910
 911       T1 := No_Table;
 912       T2 := No_Table;
 913
 914       T1_Len := 0;
 915       T2_Len := 0;
 916
 917       G     := No_Table;
 918       G_Len := 0;
 919
 920       Edges     := No_Table;
 921       Edges_Len := 0;
 922
 923       Vertices := No_Table;
 924       NV       := 0;
 925    end Free_Tmp_Tables;
 926
 927    ----------------------------
 928    -- Generate_Mapping_Table --
 929    ----------------------------
 930
 931    procedure Generate_Mapping_Table
 932      (Tab  : Integer;
 933       L1   : Natural;
 934       L2   : Natural;
 935       Seed : in out Natural)
 936    is
 937    begin
 938       for J in 0 .. L1 - 1 loop
 939          for K in 0 .. L2 - 1 loop
 940             Random (Seed);
 941             Set_Table (Tab, J, K, Seed mod NV);
 942          end loop;
 943       end loop;
 944    end Generate_Mapping_Table;
 945
 946    -----------------------------
 947    -- Generate_Mapping_Tables --
 948    -----------------------------
 949
 950    procedure Generate_Mapping_Tables
 951      (Opt  : Optimization;
 952       Seed : in out Natural)
 953    is
 954    begin
 955       --  If T1 and T2 are already allocated no need to do it twice. Reuse them
 956       --  as their size has not changed.
 957
 958       if T1 = No_Table and then T2 = No_Table then
 959          declare
 960             Used_Char_Last : Natural := 0;
 961             Used_Char      : Natural;
 962
 963          begin
 964             if Opt = CPU_Time then
 965                for P in reverse Character'Range loop
 966                   Used_Char := Get_Used_Char (P);
 967                   if Used_Char /= 0 then
 968                      Used_Char_Last := Used_Char;
 969                      exit;
 970                   end if;
 971                end loop;
 972             end if;
 973
 974             T1_Len := Char_Pos_Set_Len;
 975             T2_Len := Used_Char_Last + 1;
 976             T1 := Allocate (T1_Len * T2_Len);
 977             T2 := Allocate (T1_Len * T2_Len);
 978          end;
 979       end if;
 980
 981       Generate_Mapping_Table (T1, T1_Len, T2_Len, Seed);
 982       Generate_Mapping_Table (T2, T1_Len, T2_Len, Seed);
 983
 984       if Verbose then
 985          Put_Used_Char_Set (Output, "Used Character Set");
 986          Put_Int_Matrix (Output, "Function Table 1", T1,
 987                         T1_Len, T2_Len);
 988          Put_Int_Matrix (Output, "Function Table 2", T2,
 989                         T1_Len, T2_Len);
 990       end if;
 991    end Generate_Mapping_Tables;
 992
 993    ------------------
 994    -- Get_Char_Pos --
 995    ------------------
 996
 997    function Get_Char_Pos (P : Natural) return Natural is
 998       N : constant Natural := Char_Pos_Set + P;
 999    begin
1000       return IT.Table (N);
1001    end Get_Char_Pos;
1002
1003    ---------------
1004    -- Get_Edges --
1005    ---------------
1006
1007    function Get_Edges (F : Natural) return Edge_Type is
1008       N : constant Natural := Edges + (F * Edge_Size);
1009       E : Edge_Type;
1010    begin
1011       E.X   := IT.Table (N);
1012       E.Y   := IT.Table (N + 1);
1013       E.Key := IT.Table (N + 2);
1014       return E;
1015    end Get_Edges;
1016
1017    ---------------
1018    -- Get_Graph --
1019    ---------------
1020
1021    function Get_Graph (N : Natural) return Integer is
1022    begin
1023       return IT.Table (G + N);
1024    end Get_Graph;
1025
1026    -------------
1027    -- Get_Key --
1028    -------------
1029
1030    function Get_Key (N : Key_Id) return Key_Type is
1031       K : Key_Type;
1032    begin
1033       K.Edge := IT.Table (Keys + N);
1034       return K;
1035    end Get_Key;
1036
1037    ---------------
1038    -- Get_Table --
1039    ---------------
1040
1041    function Get_Table (T : Integer; X, Y : Natural) return Natural is
1042       N : constant Natural := T + (Y * T1_Len) + X;
1043    begin
1044       return IT.Table (N);
1045    end Get_Table;
1046
1047    -------------------
1048    -- Get_Used_Char --
1049    -------------------
1050
1051    function Get_Used_Char (C : Character) return Natural is
1052       N : constant Natural := Used_Char_Set + Character'Pos (C);
1053    begin
1054       return IT.Table (N);
1055    end Get_Used_Char;
1056
1057    ------------------
1058    -- Get_Vertices --
1059    ------------------
1060
1061    function Get_Vertices (F : Natural) return Vertex_Type is
1062       N : constant Natural := Vertices + (F * Vertex_Size);
1063       V : Vertex_Type;
1064    begin
1065       V.First := IT.Table (N);
1066       V.Last  := IT.Table (N + 1);
1067       return V;
1068    end Get_Vertices;
1069
1070    -----------
1071    -- Image --
1072    -----------
1073
1074    function Image (Int : Integer; W : Natural := 0) return String is
1075       B : String (1 .. 32);
1076       L : Natural := 0;
1077
1078       procedure Img (V : Natural);
1079       --  Compute image of V into B, starting at B (L), incrementing L
1080
1081       ---------
1082       -- Img --
1083       ---------
1084
1085       procedure Img (V : Natural) is
1086       begin
1087          if V > 9 then
1088             Img (V / 10);
1089          end if;
1090
1091          L := L + 1;
1092          B (L) := Character'Val ((V mod 10) + Character'Pos ('0'));
1093       end Img;
1094
1095    --  Start of processing for Image
1096
1097    begin
1098       if Int < 0 then
1099          L := L + 1;
1100          B (L) := '-';
1101          Img (-Int);
1102       else
1103          Img (Int);
1104       end if;
1105
1106       return Image (B (1 .. L), W);
1107    end Image;
1108
1109    -----------
1110    -- Image --
1111    -----------
1112
1113    function Image (Str : String; W : Natural := 0) return String is
1114       Len : constant Natural := Str'Length;
1115       Max : Natural := Len;
1116
1117    begin
1118       if Max < W then
1119          Max := W;
1120       end if;
1121
1122       declare
1123          Buf : String (1 .. Max) := (1 .. Max => ' ');
1124
1125       begin
1126          for J in 0 .. Len - 1 loop
1127             Buf (Max - Len + 1 + J) := Str (Str'First + J);
1128          end loop;
1129
1130          return Buf;
1131       end;
1132    end Image;
1133
1134    -------------
1135    -- Initial --
1136    -------------
1137
1138    function Initial (K : Key_Id) return Word_Id is
1139    begin
1140       return K;
1141    end Initial;
1142
1143    ----------------
1144    -- Initialize --
1145    ----------------
1146
1147    procedure Initialize
1148      (Seed   : Natural;
1149       K_To_V : Float        := Default_K_To_V;
1150       Optim  : Optimization := CPU_Time;
1151       Tries  : Positive     := Default_Tries)
1152    is
1153    begin
1154       --  Free previous tables (the settings may have changed between two runs)
1155
1156       Free_Tmp_Tables;
1157
1158       if K_To_V <= 2.0 then
1159          Put (Output, "K to V ratio cannot be lower than 2.0");
1160          New_Line (Output);
1161          raise Program_Error;
1162       end if;
1163
1164       S    := Seed;
1165       K2V  := K_To_V;
1166       Opt  := Optim;
1167       NT   := Tries;
1168    end Initialize;
1169
1170    ------------
1171    -- Insert --
1172    ------------
1173
1174    procedure Insert
1175      (Value : String)
1176    is
1177       Word : Word_Type := Null_Word;
1178       Len  : constant Natural := Value'Length;
1179
1180    begin
1181       Word (1 .. Len) := Value (Value'First .. Value'First + Len - 1);
1182       WT.Set_Last (NK);
1183       WT.Table (NK) := Word;
1184       NK := NK + 1;
1185       NV := Natural (Float (NK) * K2V);
1186
1187       --  Do not accept a value of K2V too close to 2.0 such that once rounded
1188       --  up, NV = 2 * NK because the algorithm would not converge.
1189
1190       if NV <= 2 * NK then
1191          NV := 2 * NK + 1;
1192       end if;
1193
1194       if Max_Key_Len < Len then
1195          Max_Key_Len := Len;
1196       end if;
1197
1198       if Len < Min_Key_Len then
1199          Min_Key_Len := Len;
1200       end if;
1201    end Insert;
1202
1203    --------------
1204    -- New_Line --
1205    --------------
1206
1207    procedure New_Line (File : File_Descriptor) is
1208    begin
1209       if Write (File, EOL'Address, 1) /= 1 then
1210          raise Program_Error;
1211       end if;
1212    end New_Line;
1213
1214    ------------------------------
1215    -- Parse_Position_Selection --
1216    ------------------------------
1217
1218    procedure Parse_Position_Selection (Argument : String) is
1219       N : Natural          := Argument'First;
1220       L : constant Natural := Argument'Last;
1221       M : constant Natural := Max_Key_Len;
1222
1223       T : array (1 .. M) of Boolean := (others => False);
1224
1225       function Parse_Index return Natural;
1226       --  Parse argument starting at index N to find an index
1227
1228       -----------------
1229       -- Parse_Index --
1230       -----------------
1231
1232       function Parse_Index return Natural is
1233          C : Character := Argument (N);
1234          V : Natural   := 0;
1235
1236       begin
1237          if C = '$' then
1238             N := N + 1;
1239             return M;
1240          end if;
1241
1242          if C not in '0' .. '9' then
1243             Raise_Exception
1244               (Program_Error'Identity, "cannot read position argument");
1245          end if;
1246
1247          while C in '0' .. '9' loop
1248             V := V * 10 + (Character'Pos (C) - Character'Pos ('0'));
1249             N := N + 1;
1250             exit when L < N;
1251             C := Argument (N);
1252          end loop;
1253
1254          return V;
1255       end Parse_Index;
1256
1257    --  Start of processing for Parse_Position_Selection
1258
1259    begin
1260
1261       --  Empty specification means all the positions
1262
1263       if L < N then
1264          Char_Pos_Set_Len := M;
1265          Char_Pos_Set := Allocate (Char_Pos_Set_Len);
1266
1267          for C in 0 .. Char_Pos_Set_Len - 1 loop
1268             Set_Char_Pos (C, C + 1);
1269          end loop;
1270
1271       else
1272          loop
1273             declare
1274                First, Last : Natural;
1275
1276             begin
1277                First := Parse_Index;
1278                Last  := First;
1279
1280                --  Detect a range
1281
1282                if N <= L and then Argument (N) = '-' then
1283                   N := N + 1;
1284                   Last := Parse_Index;
1285                end if;
1286
1287                --  Include the positions in the selection
1288
1289                for J in First .. Last loop
1290                   T (J) := True;
1291                end loop;
1292             end;
1293
1294             exit when L < N;
1295
1296             if Argument (N) /= ',' then
1297                Raise_Exception
1298                  (Program_Error'Identity, "cannot read position argument");
1299             end if;
1300
1301             N := N + 1;
1302          end loop;
1303
1304          --  Compute position selection length
1305
1306          N := 0;
1307          for J in T'Range loop
1308             if T (J) then
1309                N := N + 1;
1310             end if;
1311          end loop;
1312
1313          --  Fill position selection
1314
1315          Char_Pos_Set_Len := N;
1316          Char_Pos_Set := Allocate (Char_Pos_Set_Len);
1317
1318          N := 0;
1319          for J in T'Range loop
1320             if T (J) then
1321                Set_Char_Pos (N, J);
1322                N := N + 1;
1323             end if;
1324          end loop;
1325       end if;
1326    end Parse_Position_Selection;
1327
1328    -------------
1329    -- Produce --
1330    -------------
1331
1332    procedure Produce (Pkg_Name  : String := Default_Pkg_Name) is
1333       File     : File_Descriptor;
1334
1335       Status : Boolean;
1336       --  For call to Close
1337
1338       function Array_Img (N, T, R1 : String; R2 : String := "") return String;
1339       --  Return string "N : constant array (R1[, R2]) of T;"
1340
1341       function Range_Img (F, L : Natural; T : String := "") return String;
1342       --  Return string "[T range ]F .. L"
1343
1344       function Type_Img (L : Natural) return String;
1345       --  Return the larger unsigned type T such that T'Last < L
1346
1347       ---------------
1348       -- Array_Img --
1349       ---------------
1350
1351       function Array_Img
1352         (N, T, R1 : String;
1353          R2       : String := "") return String
1354       is
1355       begin
1356          Last := 0;
1357          Add ("   ");
1358          Add (N);
1359          Add (" : constant array (");
1360          Add (R1);
1361
1362          if R2 /= "" then
1363             Add (", ");
1364             Add (R2);
1365          end if;
1366
1367          Add (") of ");
1368          Add (T);
1369          Add (" :=");
1370          return Line (1 .. Last);
1371       end Array_Img;
1372
1373       ---------------
1374       -- Range_Img --
1375       ---------------
1376
1377       function Range_Img (F, L : Natural; T : String := "") return String is
1378          FI  : constant String  := Image (F);
1379          FL  : constant Natural := FI'Length;
1380          LI  : constant String  := Image (L);
1381          LL  : constant Natural := LI'Length;
1382          TL  : constant Natural := T'Length;
1383          RI  : String (1 .. TL + 7 + FL + 4 + LL);
1384          Len : Natural := 0;
1385
1386       begin
1387          if TL /= 0 then
1388             RI (Len + 1 .. Len + TL) := T;
1389             Len := Len + TL;
1390             RI (Len + 1 .. Len + 7) := " range ";
1391             Len := Len + 7;
1392          end if;
1393
1394          RI (Len + 1 .. Len + FL) := FI;
1395          Len := Len + FL;
1396          RI (Len + 1 .. Len + 4) := " .. ";
1397          Len := Len + 4;
1398          RI (Len + 1 .. Len + LL) := LI;
1399          Len := Len + LL;
1400          return RI (1 .. Len);
1401       end Range_Img;
1402
1403       --------------
1404       -- Type_Img --
1405       --------------
1406
1407       function Type_Img (L : Natural) return String is
1408          S : constant String := Image (Type_Size (L));
1409          U : String  := "Unsigned_  ";
1410          N : Natural := 9;
1411
1412       begin
1413          for J in S'Range loop
1414             N := N + 1;
1415             U (N) := S (J);
1416          end loop;
1417
1418          return U (1 .. N);
1419       end Type_Img;
1420
1421       F : Natural;
1422       L : Natural;
1423       P : Natural;
1424
1425       PLen  : constant Natural := Pkg_Name'Length;
1426       FName : String (1 .. PLen + 4);
1427
1428    --  Start of processing for Produce
1429
1430    begin
1431       FName (1 .. PLen) := Pkg_Name;
1432       for J in 1 .. PLen loop
1433          if FName (J) in 'A' .. 'Z' then
1434             FName (J) := Character'Val (Character'Pos (FName (J))
1435                                         - Character'Pos ('A')
1436                                         + Character'Pos ('a'));
1437
1438          elsif FName (J) = '.' then
1439             FName (J) := '-';
1440          end if;
1441       end loop;
1442
1443       FName (PLen + 1 .. PLen + 4) := ".ads";
1444
1445       File := Create_File (FName, Text);
1446       Put      (File, "package ");
1447       Put      (File, Pkg_Name);
1448       Put      (File, " is");
1449       New_Line (File);
1450       Put      (File, "   function Hash (S : String) return Natural;");
1451       New_Line (File);
1452       Put      (File, "end ");
1453       Put      (File, Pkg_Name);
1454       Put      (File, ";");
1455       New_Line (File);
1456       Close    (File, Status);
1457
1458       if not Status then
1459          raise Device_Error;
1460       end if;
1461
1462       FName (PLen + 4) := 'b';
1463
1464       File := Create_File (FName, Text);
1465       Put      (File, "with Interfaces; use Interfaces;");
1466       New_Line (File);
1467       New_Line (File);
1468       Put      (File, "package body ");
1469       Put      (File, Pkg_Name);
1470       Put      (File, " is");
1471       New_Line (File);
1472       New_Line (File);
1473
1474       if Opt = CPU_Time then
1475          Put      (File, Array_Img ("C", Type_Img (256), "Character"));
1476          New_Line (File);
1477
1478          F := Character'Pos (Character'First);
1479          L := Character'Pos (Character'Last);
1480
1481          for J in Character'Range loop
1482             P := Get_Used_Char (J);
1483             Put (File, Image (P), 1, 0, 1, F, L, Character'Pos (J));
1484          end loop;
1485
1486          New_Line (File);
1487       end if;
1488
1489       F := 0;
1490       L := Char_Pos_Set_Len - 1;
1491
1492       Put      (File, Array_Img ("P", "Natural", Range_Img (F, L)));
1493       New_Line (File);
1494
1495       for J in F .. L loop
1496          Put (File, Image (Get_Char_Pos (J)), 1, 0, 1, F, L, J);
1497       end loop;
1498
1499       New_Line (File);
1500
1501       if Opt = CPU_Time then
1502          Put_Int_Matrix
1503            (File,
1504             Array_Img ("T1", Type_Img (NV),
1505                        Range_Img (0, T1_Len - 1),
1506                        Range_Img (0, T2_Len - 1, Type_Img (256))),
1507             T1, T1_Len, T2_Len);
1508
1509       else
1510          Put_Int_Matrix
1511            (File,
1512             Array_Img ("T1", Type_Img (NV),
1513                        Range_Img (0, T1_Len - 1)),
1514             T1, T1_Len, 0);
1515       end if;
1516
1517       New_Line (File);
1518
1519       if Opt = CPU_Time then
1520          Put_Int_Matrix
1521            (File,
1522             Array_Img ("T2", Type_Img (NV),
1523                        Range_Img (0, T1_Len - 1),
1524                        Range_Img (0, T2_Len - 1, Type_Img (256))),
1525             T2, T1_Len, T2_Len);
1526
1527       else
1528          Put_Int_Matrix
1529            (File,
1530             Array_Img ("T2", Type_Img (NV),
1531                        Range_Img (0, T1_Len - 1)),
1532             T2, T1_Len, 0);
1533       end if;
1534
1535       New_Line (File);
1536
1537       Put_Int_Vector
1538         (File,
1539          Array_Img ("G", Type_Img (NK),
1540                     Range_Img (0, G_Len - 1)),
1541          G, G_Len);
1542       New_Line (File);
1543
1544       Put      (File, "   function Hash (S : String) return Natural is");
1545       New_Line (File);
1546       Put      (File, "      F : constant Natural := S'First - 1;");
1547       New_Line (File);
1548       Put      (File, "      L : constant Natural := S'Length;");
1549       New_Line (File);
1550       Put      (File, "      F1, F2 : Natural := 0;");
1551       New_Line (File);
1552
1553       Put (File, "      J : ");
1554
1555       if Opt = CPU_Time then
1556          Put (File, Type_Img (256));
1557       else
1558          Put (File, "Natural");
1559       end if;
1560
1561       Put (File, ";");
1562       New_Line (File);
1563
1564       Put      (File, "   begin");
1565       New_Line (File);
1566       Put      (File, "      for K in P'Range loop");
1567       New_Line (File);
1568       Put      (File, "         exit when L < P (K);");
1569       New_Line (File);
1570       Put      (File, "         J  := ");
1571
1572       if Opt = CPU_Time then
1573          Put (File, "C");
1574       else
1575          Put (File, "Character'Pos");
1576       end if;
1577
1578       Put      (File, " (S (P (K) + F));");
1579       New_Line (File);
1580
1581       Put (File, "         F1 := (F1 + Natural (T1 (K");
1582
1583       if Opt = CPU_Time then
1584          Put (File, ", J");
1585       end if;
1586
1587       Put (File, "))");
1588
1589       if Opt = Memory_Space then
1590          Put (File, " * J");
1591       end if;
1592
1593       Put      (File, ") mod ");
1594       Put      (File, Image (NV));
1595       Put      (File, ";");
1596       New_Line (File);
1597
1598       Put (File, "         F2 := (F2 + Natural (T2 (K");
1599
1600       if Opt = CPU_Time then
1601          Put (File, ", J");
1602       end if;
1603
1604       Put (File, "))");
1605
1606       if Opt = Memory_Space then
1607          Put (File, " * J");
1608       end if;
1609
1610       Put      (File, ") mod ");
1611       Put      (File, Image (NV));
1612       Put      (File, ";");
1613       New_Line (File);
1614
1615       Put      (File, "      end loop;");
1616       New_Line (File);
1617
1618       Put      (File,
1619                 "      return (Natural (G (F1)) + Natural (G (F2))) mod ");
1620
1621       Put      (File, Image (NK));
1622       Put      (File, ";");
1623       New_Line (File);
1624       Put      (File, "   end Hash;");
1625       New_Line (File);
1626       New_Line (File);
1627       Put      (File, "end ");
1628       Put      (File, Pkg_Name);
1629       Put      (File, ";");
1630       New_Line (File);
1631       Close    (File, Status);
1632
1633       if not Status then
1634          raise Device_Error;
1635       end if;
1636    end Produce;
1637
1638    ---------
1639    -- Put --
1640    ---------
1641
1642    procedure Put (File : File_Descriptor; Str : String) is
1643       Len : constant Natural := Str'Length;
1644
1645    begin
1646       if Write (File, Str'Address, Len) /= Len then
1647          raise Program_Error;
1648       end if;
1649    end Put;
1650
1651    ---------
1652    -- Put --
1653    ---------
1654
1655    procedure Put
1656      (F  : File_Descriptor;
1657       S  : String;
1658       F1 : Natural;
1659       L1 : Natural;
1660       C1 : Natural;
1661       F2 : Natural;
1662       L2 : Natural;
1663       C2 : Natural)
1664    is
1665       Len : constant Natural := S'Length;
1666
1667       procedure Flush;
1668       --  Write current line, followed by LF
1669
1670       -----------
1671       -- Flush --
1672       -----------
1673
1674       procedure Flush is
1675       begin
1676          Put (F, Line (1 .. Last));
1677          New_Line (F);
1678          Last := 0;
1679       end Flush;
1680
1681    --  Start of processing for Put
1682
1683    begin
1684       if C1 = F1 and then C2 = F2 then
1685          Last := 0;
1686       end if;
1687
1688       if Last + Len + 3 > Max then
1689          Flush;
1690       end if;
1691
1692       if Last = 0 then
1693          Line (Last + 1 .. Last + 5) := "     ";
1694          Last := Last + 5;
1695
1696          if F1 <= L1 then
1697             if C1 = F1 and then C2 = F2 then
1698                Add ('(');
1699                if F1 = L1 then
1700                   Add ("0 .. 0 => ");
1701                end if;
1702             else
1703                Add (' ');
1704             end if;
1705          end if;
1706       end if;
1707
1708       if C2 = F2 then
1709          Add ('(');
1710          if F2 = L2 then
1711             Add ("0 .. 0 => ");
1712          end if;
1713       else
1714          Add (' ');
1715       end if;
1716
1717       Line (Last + 1 .. Last + Len) := S;
1718       Last := Last + Len;
1719
1720       if C2 = L2 then
1721          Add (')');
1722
1723          if F1 > L1 then
1724             Add (';');
1725             Flush;
1726          elsif C1 /= L1 then
1727             Add (',');
1728             Flush;
1729          else
1730             Add (')');
1731             Add (';');
1732             Flush;
1733          end if;
1734
1735       else
1736          Add (',');
1737       end if;
1738    end Put;
1739
1740    ---------------
1741    -- Put_Edges --
1742    ---------------
1743
1744    procedure Put_Edges
1745      (File  : File_Descriptor;
1746       Title : String)
1747    is
1748       E  : Edge_Type;
1749       F1 : constant Natural := 1;
1750       L1 : constant Natural := Edges_Len - 1;
1751       M  : constant Natural := Max / 5;
1752
1753    begin
1754       Put (File, Title);
1755       New_Line (File);
1756
1757       --  Edges valid range is 1 .. Edge_Len - 1
1758
1759       for J in F1 .. L1 loop
1760          E := Get_Edges (J);
1761          Put (File, Image (J, M),     F1, L1, J, 1, 4, 1);
1762          Put (File, Image (E.X, M),   F1, L1, J, 1, 4, 2);
1763          Put (File, Image (E.Y, M),   F1, L1, J, 1, 4, 3);
1764          Put (File, Image (E.Key, M), F1, L1, J, 1, 4, 4);
1765       end loop;
1766    end Put_Edges;
1767
1768    ----------------------
1769    -- Put_Initial_Keys --
1770    ----------------------
1771
1772    procedure Put_Initial_Keys
1773      (File  : File_Descriptor;
1774       Title : String)
1775    is
1776       F1 : constant Natural := 0;
1777       L1 : constant Natural := NK - 1;
1778       M  : constant Natural := Max / 5;
1779       K  : Key_Type;
1780
1781    begin
1782       Put (File, Title);
1783       New_Line (File);
1784
1785       for J in F1 .. L1 loop
1786          K := Get_Key (J);
1787          Put (File, Image (J, M),           F1, L1, J, 1, 3, 1);
1788          Put (File, Image (K.Edge, M),      F1, L1, J, 1, 3, 2);
1789          Put (File, WT.Table (Initial (J)), F1, L1, J, 1, 3, 3);
1790       end loop;
1791    end Put_Initial_Keys;
1792
1793    --------------------
1794    -- Put_Int_Matrix --
1795    --------------------
1796
1797    procedure Put_Int_Matrix
1798      (File   : File_Descriptor;
1799       Title  : String;
1800       Table  : Integer;
1801       Len_1  : Natural;
1802       Len_2  : Natural)
1803    is
1804       F1 : constant Integer := 0;
1805       L1 : constant Integer := Len_1 - 1;
1806       F2 : constant Integer := 0;
1807       L2 : constant Integer := Len_2 - 1;
1808       I  : Natural;
1809
1810    begin
1811       Put (File, Title);
1812       New_Line (File);
1813
1814       if Len_2 = 0 then
1815          for J in F1 .. L1 loop
1816             I := IT.Table (Table + J);
1817             Put (File, Image (I), 1, 0, 1, F1, L1, J);
1818          end loop;
1819
1820       else
1821          for J in F1 .. L1 loop
1822             for K in F2 .. L2 loop
1823                I := IT.Table (Table + J + K * Len_1);
1824                Put (File, Image (I), F1, L1, J, F2, L2, K);
1825             end loop;
1826          end loop;
1827       end if;
1828    end Put_Int_Matrix;
1829
1830    --------------------
1831    -- Put_Int_Vector --
1832    --------------------
1833
1834    procedure Put_Int_Vector
1835      (File   : File_Descriptor;
1836       Title  : String;
1837       Vector : Integer;
1838       Length : Natural)
1839    is
1840       F2 : constant Natural := 0;
1841       L2 : constant Natural := Length - 1;
1842
1843    begin
1844       Put (File, Title);
1845       New_Line (File);
1846
1847       for J in F2 .. L2 loop
1848          Put (File, Image (IT.Table (Vector + J)), 1, 0, 1, F2, L2, J);
1849       end loop;
1850    end Put_Int_Vector;
1851
1852    ----------------------
1853    -- Put_Reduced_Keys --
1854    ----------------------
1855
1856    procedure Put_Reduced_Keys
1857      (File  : File_Descriptor;
1858       Title : String)
1859    is
1860       F1 : constant Natural := 0;
1861       L1 : constant Natural := NK - 1;
1862       M  : constant Natural := Max / 5;
1863       K  : Key_Type;
1864
1865    begin
1866       Put (File, Title);
1867       New_Line (File);
1868
1869       for J in F1 .. L1 loop
1870          K := Get_Key (J);
1871          Put (File, Image (J, M),           F1, L1, J, 1, 3, 1);
1872          Put (File, Image (K.Edge, M),      F1, L1, J, 1, 3, 2);
1873          Put (File, WT.Table (Reduced (J)), F1, L1, J, 1, 3, 3);
1874       end loop;
1875    end Put_Reduced_Keys;
1876
1877    -----------------------
1878    -- Put_Used_Char_Set --
1879    -----------------------
1880
1881    procedure Put_Used_Char_Set
1882      (File  : File_Descriptor;
1883       Title : String)
1884    is
1885       F : constant Natural := Character'Pos (Character'First);
1886       L : constant Natural := Character'Pos (Character'Last);
1887
1888    begin
1889       Put (File, Title);
1890       New_Line (File);
1891
1892       for J in Character'Range loop
1893          Put
1894            (File, Image (Get_Used_Char (J)), 1, 0, 1, F, L, Character'Pos (J));
1895       end loop;
1896    end Put_Used_Char_Set;
1897
1898    ----------------------
1899    -- Put_Vertex_Table --
1900    ----------------------
1901
1902    procedure Put_Vertex_Table
1903      (File  : File_Descriptor;
1904       Title : String)
1905    is
1906       F1 : constant Natural := 0;
1907       L1 : constant Natural := NV - 1;
1908       M  : constant Natural := Max / 4;
1909       V  : Vertex_Type;
1910
1911    begin
1912       Put (File, Title);
1913       New_Line (File);
1914
1915       for J in F1 .. L1 loop
1916          V := Get_Vertices (J);
1917          Put (File, Image (J, M),       F1, L1, J, 1, 3, 1);
1918          Put (File, Image (V.First, M), F1, L1, J, 1, 3, 2);
1919          Put (File, Image (V.Last, M),  F1, L1, J, 1, 3, 3);
1920       end loop;
1921    end Put_Vertex_Table;
1922
1923    ------------
1924    -- Random --
1925    ------------
1926
1927    procedure Random (Seed : in out Natural)
1928    is
1929       --  Park & Miller Standard Minimal using Schrage's algorithm to avoid
1930       --  overflow: Xn+1 = 16807 * Xn mod (2 ** 31 - 1)
1931
1932       R : Natural;
1933       Q : Natural;
1934       X : Integer;
1935
1936    begin
1937       R := Seed mod 127773;
1938       Q := Seed / 127773;
1939       X := 16807 * R - 2836 * Q;
1940
1941       if X < 0 then
1942          Seed := X + 2147483647;
1943       else
1944          Seed := X;
1945       end if;
1946    end Random;
1947
1948    -------------
1949    -- Reduced --
1950    -------------
1951
1952    function Reduced (K : Key_Id) return Word_Id is
1953    begin
1954       return K + NK + 1;
1955    end Reduced;
1956
1957    --------------------------
1958    -- Select_Char_Position --
1959    --------------------------
1960
1961    procedure Select_Char_Position is
1962
1963       type Vertex_Table_Type is array (Natural range <>) of Vertex_Type;
1964
1965       procedure Build_Identical_Keys_Sets
1966         (Table : in out Vertex_Table_Type;
1967          Last  : in out Natural;
1968          Pos   : in Natural);
1969       --  Build a list of keys subsets that are identical with the current
1970       --  position selection plus Pos. Once this routine is called, reduced
1971       --  words are sorted by subsets and each item (First, Last) in Sets
1972       --  defines the range of identical keys.
1973
1974       function Count_Different_Keys
1975         (Table : Vertex_Table_Type;
1976          Last  : Natural;
1977          Pos   : Natural) return Natural;
1978       --  For each subset in Sets, count the number of different keys if we add
1979       --  Pos to the current position selection.
1980
1981       Sel_Position : IT.Table_Type (1 .. Max_Key_Len);
1982       Last_Sel_Pos : Natural := 0;
1983       Max_Sel_Pos  : Natural := 0;
1984
1985       -------------------------------
1986       -- Build_Identical_Keys_Sets --
1987       -------------------------------
1988
1989       procedure Build_Identical_Keys_Sets
1990         (Table : in out Vertex_Table_Type;
1991          Last  : in out Natural;
1992          Pos   : in Natural)
1993       is
1994          S : constant Vertex_Table_Type := Table (1 .. Last);
1995          C : constant Natural           := Pos;
1996          --  Shortcuts
1997
1998          F : Integer;
1999          L : Integer;
2000          --  First and last words of a subset
2001
2002          Offset : Natural;
2003          --  GNAT.Heap_Sort assumes that the first array index is 1. Offset
2004          --  defines the translation to operate.
2005
2006          function Lt (L, R : Natural) return Boolean;
2007          procedure Move (From : Natural; To : Natural);
2008          --  Subprograms needed by GNAT.Heap_Sort_A
2009
2010          --------
2011          -- Lt --
2012          --------
2013
2014          function Lt (L, R : Natural) return Boolean is
2015             C     : constant Natural := Pos;
2016             Left  : Natural;
2017             Right : Natural;
2018
2019          begin
2020             if L = 0 then
2021                Left  := Reduced (0) - 1;
2022                Right := Offset + R;
2023             elsif R = 0 then
2024                Left  := Offset + L;
2025                Right := Reduced (0) - 1;
2026             else
2027                Left  := Offset + L;
2028                Right := Offset + R;
2029             end if;
2030
2031             return WT.Table (Left)(C) < WT.Table (Right)(C);
2032          end Lt;
2033
2034          ----------
2035          -- Move --
2036          ----------
2037
2038          procedure Move (From : Natural; To : Natural) is
2039             Target, Source : Natural;
2040
2041          begin
2042             if From = 0 then
2043                Source := Reduced (0) - 1;
2044                Target := Offset + To;
2045             elsif To = 0 then
2046                Source := Offset + From;
2047                Target := Reduced (0) - 1;
2048             else
2049                Source := Offset + From;
2050                Target := Offset + To;
2051             end if;
2052
2053             WT.Table (Target) := WT.Table (Source);
2054          end Move;
2055
2056          --  Start of processing for Build_Identical_Key_Sets
2057
2058       begin
2059          Last := 0;
2060
2061          --  For each subset in S, extract the new subsets we have by adding C
2062          --  in the position selection.
2063
2064          for J in S'Range loop
2065             if S (J).First = S (J).Last then
2066                F := S (J).First;
2067                L := S (J).Last;
2068                Last := Last + 1;
2069                Table (Last) := (F, L);
2070
2071             else
2072                Offset := Reduced (S (J).First) - 1;
2073                Sort
2074                  (S (J).Last - S (J).First + 1,
2075                   Move'Unrestricted_Access,
2076                   Lt'Unrestricted_Access);
2077
2078                F := S (J).First;
2079                L := F;
2080                for N in S (J).First .. S (J).Last loop
2081
2082                   --  For the last item, close the last subset
2083
2084                   if N = S (J).Last then
2085                      Last := Last + 1;
2086                      Table (Last) := (F, N);
2087
2088                   --  Two contiguous words are identical when they have the
2089                   --  same Cth character.
2090
2091                   elsif WT.Table (Reduced (N))(C) =
2092                         WT.Table (Reduced (N + 1))(C)
2093                   then
2094                      L := N + 1;
2095
2096                   --  Find a new subset of identical keys. Store the current
2097                   --  one and create a new subset.
2098
2099                   else
2100                      Last := Last + 1;
2101                      Table (Last) := (F, L);
2102                      F := N + 1;
2103                      L := F;
2104                   end if;
2105                end loop;
2106             end if;
2107          end loop;
2108       end Build_Identical_Keys_Sets;
2109
2110       --------------------------
2111       -- Count_Different_Keys --
2112       --------------------------
2113
2114       function Count_Different_Keys
2115         (Table : Vertex_Table_Type;
2116          Last  : Natural;
2117          Pos   : Natural) return Natural
2118       is
2119          N : array (Character) of Natural;
2120          C : Character;
2121          T : Natural := 0;
2122
2123       begin
2124          --  For each subset, count the number of words that are still
2125          --  different when we include Pos in the position selection. Only
2126          --  focus on this position as the other positions already produce
2127          --  identical keys.
2128
2129          for S in 1 .. Last loop
2130
2131             --  Count the occurrences of the different characters
2132
2133             N := (others => 0);
2134             for K in Table (S).First .. Table (S).Last loop
2135                C := WT.Table (Reduced (K))(Pos);
2136                N (C) := N (C) + 1;
2137             end loop;
2138
2139             --  Update the number of different keys. Each character used
2140             --  denotes a different key.
2141
2142             for J in N'Range loop
2143                if N (J) > 0 then
2144                   T := T + 1;
2145                end if;
2146             end loop;
2147          end loop;
2148
2149          return T;
2150       end Count_Different_Keys;
2151
2152    --  Start of processing for Select_Char_Position
2153
2154    begin
2155       --  Initialize the reduced words set
2156
2157       WT.Set_Last (2 * NK);
2158       for K in 0 .. NK - 1 loop
2159          WT.Table (Reduced (K)) := WT.Table (Initial (K));
2160       end loop;
2161
2162       declare
2163          Differences          : Natural;
2164          Max_Differences      : Natural := 0;
2165          Old_Differences      : Natural;
2166          Max_Diff_Sel_Pos     : Natural := 0; -- init to kill warning
2167          Max_Diff_Sel_Pos_Idx : Natural := 0; -- init to kill warning
2168          Same_Keys_Sets_Table : Vertex_Table_Type (1 .. NK);
2169          Same_Keys_Sets_Last  : Natural := 1;
2170
2171       begin
2172          for C in Sel_Position'Range loop
2173             Sel_Position (C) := C;
2174          end loop;
2175
2176          Same_Keys_Sets_Table (1) := (0, NK - 1);
2177
2178          loop
2179             --  Preserve maximum number of different keys and check later on
2180             --  that this value is strictly incrementing. Otherwise, it means
2181             --  that two keys are stricly identical.
2182
2183             Old_Differences := Max_Differences;
2184
2185             --  The first position should not exceed the minimum key length.
2186             --  Otherwise, we may end up with an empty word once reduced.
2187
2188             if Last_Sel_Pos = 0 then
2189                Max_Sel_Pos := Min_Key_Len;
2190             else
2191                Max_Sel_Pos := Max_Key_Len;
2192             end if;
2193
2194             --  Find which position increases more the number of differences
2195
2196             for J in Last_Sel_Pos + 1 .. Max_Sel_Pos loop
2197                Differences := Count_Different_Keys
2198                  (Same_Keys_Sets_Table,
2199                   Same_Keys_Sets_Last,
2200                   Sel_Position (J));
2201
2202                if Verbose then
2203                   Put (Output,
2204                        "Selecting position" & Sel_Position (J)'Img &
2205                          " results in" & Differences'Img &
2206                          " differences");
2207                   New_Line (Output);
2208                end if;
2209
2210                if Differences > Max_Differences then
2211                   Max_Differences      := Differences;
2212                   Max_Diff_Sel_Pos     := Sel_Position (J);
2213                   Max_Diff_Sel_Pos_Idx := J;
2214                end if;
2215             end loop;
2216
2217             if Old_Differences = Max_Differences then
2218                Raise_Exception
2219                  (Program_Error'Identity, "some keys are identical");
2220             end if;
2221
2222             --  Insert selected position and sort Sel_Position table
2223
2224             Last_Sel_Pos := Last_Sel_Pos + 1;
2225             Sel_Position (Last_Sel_Pos + 1 .. Max_Diff_Sel_Pos_Idx) :=
2226               Sel_Position (Last_Sel_Pos .. Max_Diff_Sel_Pos_Idx - 1);
2227             Sel_Position (Last_Sel_Pos) := Max_Diff_Sel_Pos;
2228
2229             for P in 1 .. Last_Sel_Pos - 1 loop
2230                if Max_Diff_Sel_Pos < Sel_Position (P) then
2231                   Sel_Position (P + 1 .. Last_Sel_Pos) :=
2232                     Sel_Position (P .. Last_Sel_Pos - 1);
2233                   Sel_Position (P) := Max_Diff_Sel_Pos;
2234                   exit;
2235                end if;
2236             end loop;
2237
2238             exit when Max_Differences = NK;
2239
2240             Build_Identical_Keys_Sets
2241               (Same_Keys_Sets_Table,
2242                Same_Keys_Sets_Last,
2243                Max_Diff_Sel_Pos);
2244
2245             if Verbose then
2246                Put (Output,
2247                     "Selecting position" & Max_Diff_Sel_Pos'Img &
2248                       " results in" & Max_Differences'Img &
2249                       " differences");
2250                New_Line (Output);
2251                Put (Output, "--");
2252                New_Line (Output);
2253                for J in 1 .. Same_Keys_Sets_Last loop
2254                   for K in
2255                     Same_Keys_Sets_Table (J).First ..
2256                     Same_Keys_Sets_Table (J).Last
2257                   loop
2258                      Put (Output, WT.Table (Reduced (K)));
2259                      New_Line (Output);
2260                   end loop;
2261                   Put (Output, "--");
2262                   New_Line (Output);
2263                end loop;
2264             end if;
2265          end loop;
2266       end;
2267
2268       Char_Pos_Set_Len := Last_Sel_Pos;
2269       Char_Pos_Set := Allocate (Char_Pos_Set_Len);
2270
2271       for C in 1 .. Last_Sel_Pos loop
2272          Set_Char_Pos (C - 1, Sel_Position (C));
2273       end loop;
2274    end Select_Char_Position;
2275
2276    --------------------------
2277    -- Select_Character_Set --
2278    --------------------------
2279
2280    procedure Select_Character_Set
2281    is
2282       Last : Natural := 0;
2283       Used : array (Character) of Boolean := (others => False);
2284       Char : Character;
2285
2286    begin
2287       for J in 0 .. NK - 1 loop
2288          for K in 0 .. Char_Pos_Set_Len - 1 loop
2289             Char := WT.Table (Initial (J))(Get_Char_Pos (K));
2290             exit when Char = ASCII.NUL;
2291             Used (Char) := True;
2292          end loop;
2293       end loop;
2294
2295       Used_Char_Set_Len := 256;
2296       Used_Char_Set := Allocate (Used_Char_Set_Len);
2297
2298       for J in Used'Range loop
2299          if Used (J) then
2300             Set_Used_Char (J, Last);
2301             Last := Last + 1;
2302          else
2303             Set_Used_Char (J, 0);
2304          end if;
2305       end loop;
2306    end Select_Character_Set;
2307
2308    ------------------
2309    -- Set_Char_Pos --
2310    ------------------
2311
2312    procedure Set_Char_Pos (P : Natural; Item : Natural) is
2313       N : constant Natural := Char_Pos_Set + P;
2314    begin
2315       IT.Table (N) := Item;
2316    end Set_Char_Pos;
2317
2318    ---------------
2319    -- Set_Edges --
2320    ---------------
2321
2322    procedure Set_Edges (F : Natural; Item : Edge_Type) is
2323       N : constant Natural := Edges + (F * Edge_Size);
2324    begin
2325       IT.Table (N)     := Item.X;
2326       IT.Table (N + 1) := Item.Y;
2327       IT.Table (N + 2) := Item.Key;
2328    end Set_Edges;
2329
2330    ---------------
2331    -- Set_Graph --
2332    ---------------
2333
2334    procedure Set_Graph (N : Natural; Item : Integer) is
2335    begin
2336       IT.Table (G + N) := Item;
2337    end Set_Graph;
2338
2339    -------------
2340    -- Set_Key --
2341    -------------
2342
2343    procedure Set_Key (N : Key_Id; Item : Key_Type) is
2344    begin
2345       IT.Table (Keys + N) := Item.Edge;
2346    end Set_Key;
2347
2348    ---------------
2349    -- Set_Table --
2350    ---------------
2351
2352    procedure Set_Table (T : Integer; X, Y : Natural; Item : Natural) is
2353       N : constant Natural := T + ((Y * T1_Len) + X);
2354    begin
2355       IT.Table (N) := Item;
2356    end Set_Table;
2357
2358    -------------------
2359    -- Set_Used_Char --
2360    -------------------
2361
2362    procedure Set_Used_Char (C : Character; Item : Natural) is
2363       N : constant Natural := Used_Char_Set + Character'Pos (C);
2364    begin
2365       IT.Table (N) := Item;
2366    end Set_Used_Char;
2367
2368    ------------------
2369    -- Set_Vertices --
2370    ------------------
2371
2372    procedure Set_Vertices (F : Natural; Item : Vertex_Type) is
2373       N : constant Natural := Vertices + (F * Vertex_Size);
2374    begin
2375       IT.Table (N)     := Item.First;
2376       IT.Table (N + 1) := Item.Last;
2377    end Set_Vertices;
2378
2379    ---------
2380    -- Sum --
2381    ---------
2382
2383    function Sum
2384      (Word  : Word_Type;
2385       Table : Table_Id;
2386       Opt   : Optimization) return Natural
2387    is
2388       S : Natural := 0;
2389       R : Natural;
2390
2391    begin
2392       if Opt = CPU_Time then
2393          for J in 0 .. T1_Len - 1 loop
2394             exit when Word (J + 1) = ASCII.NUL;
2395             R := Get_Table (Table, J, Get_Used_Char (Word (J + 1)));
2396             S := (S + R) mod NV;
2397          end loop;
2398
2399       else
2400          for J in 0 .. T1_Len - 1 loop
2401             exit when Word (J + 1) = ASCII.NUL;
2402             R := Get_Table (Table, J, 0);
2403             S := (S + R * Character'Pos (Word (J + 1))) mod NV;
2404          end loop;
2405       end if;
2406
2407       return S;
2408    end Sum;
2409
2410    ---------------
2411    -- Type_Size --
2412    ---------------
2413
2414    function Type_Size (L : Natural) return Natural is
2415    begin
2416       if L <= 2 ** 8 then
2417          return 8;
2418       elsif L <= 2 ** 16 then
2419          return 16;
2420       else
2421          return 32;
2422       end if;
2423    end Type_Size;
2424
2425    -----------
2426    -- Value --
2427    -----------
2428
2429    function Value
2430      (Name : Table_Name;
2431       J    : Natural;
2432       K    : Natural := 0) return Natural
2433    is
2434    begin
2435       case Name is
2436          when Character_Position =>
2437             return Get_Char_Pos (J);
2438
2439          when Used_Character_Set =>
2440             return Get_Used_Char (Character'Val (J));
2441
2442          when Function_Table_1 =>
2443             return Get_Table (T1, J, K);
2444
2445          when  Function_Table_2 =>
2446             return Get_Table (T2, J, K);
2447
2448          when Graph_Table =>
2449             return Get_Graph (J);
2450
2451       end case;
2452    end Value;
2453
2454 end GNAT.Perfect_Hash_Generators;