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