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