gcc/ada/libgnat/s-pehage.adb

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