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-2021, 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 32with GNAT.Heap_Sort_G; 33with GNAT.Table; 34 35with System.OS_Lib; use System.OS_Lib; 36 37package 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 2235end System.Perfect_Hash_Generators; 2236