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