OpenCores
URL https://opencores.org/ocsvn/openrisc_me/openrisc_me/trunk

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [ada/] [g-pehage.adb] - Blame information for rev 281

Details | Compare with Previous | View Log

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

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.