1------------------------------------------------------------------------------ 2-- -- 3-- GNAT LIBRARY COMPONENTS -- 4-- -- 5-- A D A . C O N T A I N E R S . F O R M A L _ O R D E R E D _ S E T S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2010-2015, Free Software Foundation, 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 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 28with Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations; 29pragma Elaborate_All 30 (Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations); 31 32with Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys; 33pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys); 34 35with Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations; 36pragma Elaborate_All 37 (Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations); 38 39with System; use type System.Address; 40 41package body Ada.Containers.Formal_Ordered_Sets with 42 SPARK_Mode => Off 43is 44 45 ------------------------------ 46 -- Access to Fields of Node -- 47 ------------------------------ 48 49 -- These subprograms provide functional notation for access to fields 50 -- of a node, and procedural notation for modifiying these fields. 51 52 function Color (Node : Node_Type) return Red_Black_Trees.Color_Type; 53 pragma Inline (Color); 54 55 function Left_Son (Node : Node_Type) return Count_Type; 56 pragma Inline (Left_Son); 57 58 function Parent (Node : Node_Type) return Count_Type; 59 pragma Inline (Parent); 60 61 function Right_Son (Node : Node_Type) return Count_Type; 62 pragma Inline (Right_Son); 63 64 procedure Set_Color 65 (Node : in out Node_Type; 66 Color : Red_Black_Trees.Color_Type); 67 pragma Inline (Set_Color); 68 69 procedure Set_Left (Node : in out Node_Type; Left : Count_Type); 70 pragma Inline (Set_Left); 71 72 procedure Set_Right (Node : in out Node_Type; Right : Count_Type); 73 pragma Inline (Set_Right); 74 75 procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type); 76 pragma Inline (Set_Parent); 77 78 ----------------------- 79 -- Local Subprograms -- 80 ----------------------- 81 82 -- Comments needed??? 83 84 generic 85 with procedure Set_Element (Node : in out Node_Type); 86 procedure Generic_Allocate 87 (Tree : in out Tree_Types.Tree_Type'Class; 88 Node : out Count_Type); 89 90 procedure Free (Tree : in out Set; X : Count_Type); 91 92 procedure Insert_Sans_Hint 93 (Container : in out Set; 94 New_Item : Element_Type; 95 Node : out Count_Type; 96 Inserted : out Boolean); 97 98 procedure Insert_With_Hint 99 (Dst_Set : in out Set; 100 Dst_Hint : Count_Type; 101 Src_Node : Node_Type; 102 Dst_Node : out Count_Type); 103 104 function Is_Greater_Element_Node 105 (Left : Element_Type; 106 Right : Node_Type) return Boolean; 107 pragma Inline (Is_Greater_Element_Node); 108 109 function Is_Less_Element_Node 110 (Left : Element_Type; 111 Right : Node_Type) return Boolean; 112 pragma Inline (Is_Less_Element_Node); 113 114 function Is_Less_Node_Node (L, R : Node_Type) return Boolean; 115 pragma Inline (Is_Less_Node_Node); 116 117 procedure Replace_Element 118 (Tree : in out Set; 119 Node : Count_Type; 120 Item : Element_Type); 121 122 -------------------------- 123 -- Local Instantiations -- 124 -------------------------- 125 126 package Tree_Operations is 127 new Red_Black_Trees.Generic_Bounded_Operations 128 (Tree_Types, 129 Left => Left_Son, 130 Right => Right_Son); 131 132 use Tree_Operations; 133 134 package Element_Keys is 135 new Red_Black_Trees.Generic_Bounded_Keys 136 (Tree_Operations => Tree_Operations, 137 Key_Type => Element_Type, 138 Is_Less_Key_Node => Is_Less_Element_Node, 139 Is_Greater_Key_Node => Is_Greater_Element_Node); 140 141 package Set_Ops is 142 new Red_Black_Trees.Generic_Bounded_Set_Operations 143 (Tree_Operations => Tree_Operations, 144 Set_Type => Set, 145 Assign => Assign, 146 Insert_With_Hint => Insert_With_Hint, 147 Is_Less => Is_Less_Node_Node); 148 149 --------- 150 -- "=" -- 151 --------- 152 153 function "=" (Left, Right : Set) return Boolean is 154 Lst : Count_Type; 155 Node : Count_Type; 156 ENode : Count_Type; 157 158 begin 159 if Length (Left) /= Length (Right) then 160 return False; 161 end if; 162 163 if Is_Empty (Left) then 164 return True; 165 end if; 166 167 Lst := Next (Left, Last (Left).Node); 168 169 Node := First (Left).Node; 170 while Node /= Lst loop 171 ENode := Find (Right, Left.Nodes (Node).Element).Node; 172 if ENode = 0 173 or else Left.Nodes (Node).Element /= Right.Nodes (ENode).Element 174 then 175 return False; 176 end if; 177 178 Node := Next (Left, Node); 179 end loop; 180 181 return True; 182 end "="; 183 184 ------------ 185 -- Assign -- 186 ------------ 187 188 procedure Assign (Target : in out Set; Source : Set) is 189 procedure Append_Element (Source_Node : Count_Type); 190 191 procedure Append_Elements is 192 new Tree_Operations.Generic_Iteration (Append_Element); 193 194 -------------------- 195 -- Append_Element -- 196 -------------------- 197 198 procedure Append_Element (Source_Node : Count_Type) is 199 SN : Node_Type renames Source.Nodes (Source_Node); 200 201 procedure Set_Element (Node : in out Node_Type); 202 pragma Inline (Set_Element); 203 204 function New_Node return Count_Type; 205 pragma Inline (New_Node); 206 207 procedure Insert_Post is 208 new Element_Keys.Generic_Insert_Post (New_Node); 209 210 procedure Unconditional_Insert_Sans_Hint is 211 new Element_Keys.Generic_Unconditional_Insert (Insert_Post); 212 213 procedure Unconditional_Insert_Avec_Hint is 214 new Element_Keys.Generic_Unconditional_Insert_With_Hint 215 (Insert_Post, 216 Unconditional_Insert_Sans_Hint); 217 218 procedure Allocate is new Generic_Allocate (Set_Element); 219 220 -------------- 221 -- New_Node -- 222 -------------- 223 224 function New_Node return Count_Type is 225 Result : Count_Type; 226 begin 227 Allocate (Target, Result); 228 return Result; 229 end New_Node; 230 231 ----------------- 232 -- Set_Element -- 233 ----------------- 234 235 procedure Set_Element (Node : in out Node_Type) is 236 begin 237 Node.Element := SN.Element; 238 end Set_Element; 239 240 -- Local variables 241 242 Target_Node : Count_Type; 243 244 -- Start of processing for Append_Element 245 246 begin 247 Unconditional_Insert_Avec_Hint 248 (Tree => Target, 249 Hint => 0, 250 Key => SN.Element, 251 Node => Target_Node); 252 end Append_Element; 253 254 -- Start of processing for Assign 255 256 begin 257 if Target'Address = Source'Address then 258 return; 259 end if; 260 261 if Target.Capacity < Source.Length then 262 raise Constraint_Error 263 with "Target capacity is less than Source length"; 264 end if; 265 266 Tree_Operations.Clear_Tree (Target); 267 Append_Elements (Source); 268 end Assign; 269 270 ------------- 271 -- Ceiling -- 272 ------------- 273 274 function Ceiling (Container : Set; Item : Element_Type) return Cursor is 275 Node : constant Count_Type := Element_Keys.Ceiling (Container, Item); 276 277 begin 278 if Node = 0 then 279 return No_Element; 280 end if; 281 282 return (Node => Node); 283 end Ceiling; 284 285 ----------- 286 -- Clear -- 287 ----------- 288 289 procedure Clear (Container : in out Set) is 290 begin 291 Tree_Operations.Clear_Tree (Container); 292 end Clear; 293 294 ----------- 295 -- Color -- 296 ----------- 297 298 function Color (Node : Node_Type) return Red_Black_Trees.Color_Type is 299 begin 300 return Node.Color; 301 end Color; 302 303 -------------- 304 -- Contains -- 305 -------------- 306 307 function Contains 308 (Container : Set; 309 Item : Element_Type) return Boolean 310 is 311 begin 312 return Find (Container, Item) /= No_Element; 313 end Contains; 314 315 ---------- 316 -- Copy -- 317 ---------- 318 319 function Copy (Source : Set; Capacity : Count_Type := 0) return Set is 320 Node : Count_Type; 321 N : Count_Type; 322 Target : Set (Count_Type'Max (Source.Capacity, Capacity)); 323 324 begin 325 if 0 < Capacity and then Capacity < Source.Capacity then 326 raise Capacity_Error; 327 end if; 328 329 if Length (Source) > 0 then 330 Target.Length := Source.Length; 331 Target.Root := Source.Root; 332 Target.First := Source.First; 333 Target.Last := Source.Last; 334 Target.Free := Source.Free; 335 336 Node := 1; 337 while Node <= Source.Capacity loop 338 Target.Nodes (Node).Element := 339 Source.Nodes (Node).Element; 340 Target.Nodes (Node).Parent := 341 Source.Nodes (Node).Parent; 342 Target.Nodes (Node).Left := 343 Source.Nodes (Node).Left; 344 Target.Nodes (Node).Right := 345 Source.Nodes (Node).Right; 346 Target.Nodes (Node).Color := 347 Source.Nodes (Node).Color; 348 Target.Nodes (Node).Has_Element := 349 Source.Nodes (Node).Has_Element; 350 Node := Node + 1; 351 end loop; 352 353 while Node <= Target.Capacity loop 354 N := Node; 355 Formal_Ordered_Sets.Free (Tree => Target, X => N); 356 Node := Node + 1; 357 end loop; 358 end if; 359 360 return Target; 361 end Copy; 362 363 --------------------- 364 -- Current_To_Last -- 365 --------------------- 366 367 function Current_To_Last (Container : Set; Current : Cursor) return Set is 368 Curs : Cursor := First (Container); 369 C : Set (Container.Capacity) := Copy (Container, Container.Capacity); 370 Node : Count_Type; 371 372 begin 373 if Curs = No_Element then 374 Clear (C); 375 return C; 376 end if; 377 378 if Current /= No_Element and not Has_Element (Container, Current) then 379 raise Constraint_Error; 380 end if; 381 382 while Curs.Node /= Current.Node loop 383 Node := Curs.Node; 384 Delete (C, Curs); 385 Curs := Next (Container, (Node => Node)); 386 end loop; 387 388 return C; 389 end Current_To_Last; 390 391 ------------ 392 -- Delete -- 393 ------------ 394 395 procedure Delete (Container : in out Set; Position : in out Cursor) is 396 begin 397 if not Has_Element (Container, Position) then 398 raise Constraint_Error with "Position cursor has no element"; 399 end if; 400 401 pragma Assert (Vet (Container, Position.Node), 402 "bad cursor in Delete"); 403 404 Tree_Operations.Delete_Node_Sans_Free (Container, 405 Position.Node); 406 Formal_Ordered_Sets.Free (Container, Position.Node); 407 Position := No_Element; 408 end Delete; 409 410 procedure Delete (Container : in out Set; Item : Element_Type) is 411 X : constant Count_Type := Element_Keys.Find (Container, Item); 412 413 begin 414 if X = 0 then 415 raise Constraint_Error with "attempt to delete element not in set"; 416 end if; 417 418 Tree_Operations.Delete_Node_Sans_Free (Container, X); 419 Formal_Ordered_Sets.Free (Container, X); 420 end Delete; 421 422 ------------------ 423 -- Delete_First -- 424 ------------------ 425 426 procedure Delete_First (Container : in out Set) is 427 X : constant Count_Type := Container.First; 428 begin 429 if X /= 0 then 430 Tree_Operations.Delete_Node_Sans_Free (Container, X); 431 Formal_Ordered_Sets.Free (Container, X); 432 end if; 433 end Delete_First; 434 435 ----------------- 436 -- Delete_Last -- 437 ----------------- 438 439 procedure Delete_Last (Container : in out Set) is 440 X : constant Count_Type := Container.Last; 441 begin 442 if X /= 0 then 443 Tree_Operations.Delete_Node_Sans_Free (Container, X); 444 Formal_Ordered_Sets.Free (Container, X); 445 end if; 446 end Delete_Last; 447 448 ---------------- 449 -- Difference -- 450 ---------------- 451 452 procedure Difference (Target : in out Set; Source : Set) is 453 begin 454 Set_Ops.Set_Difference (Target, Source); 455 end Difference; 456 457 function Difference (Left, Right : Set) return Set is 458 begin 459 if Left'Address = Right'Address then 460 return Empty_Set; 461 end if; 462 463 if Length (Left) = 0 then 464 return Empty_Set; 465 end if; 466 467 if Length (Right) = 0 then 468 return Left.Copy; 469 end if; 470 471 return S : Set (Length (Left)) do 472 Assign (S, Set_Ops.Set_Difference (Left, Right)); 473 end return; 474 end Difference; 475 476 ------------- 477 -- Element -- 478 ------------- 479 480 function Element (Container : Set; Position : Cursor) return Element_Type is 481 begin 482 if not Has_Element (Container, Position) then 483 raise Constraint_Error with "Position cursor has no element"; 484 end if; 485 486 pragma Assert (Vet (Container, Position.Node), 487 "bad cursor in Element"); 488 489 return Container.Nodes (Position.Node).Element; 490 end Element; 491 492 ------------------------- 493 -- Equivalent_Elements -- 494 ------------------------- 495 496 function Equivalent_Elements (Left, Right : Element_Type) return Boolean is 497 begin 498 if Left < Right 499 or else Right < Left 500 then 501 return False; 502 else 503 return True; 504 end if; 505 end Equivalent_Elements; 506 507 --------------------- 508 -- Equivalent_Sets -- 509 --------------------- 510 511 function Equivalent_Sets (Left, Right : Set) return Boolean is 512 function Is_Equivalent_Node_Node 513 (L, R : Node_Type) return Boolean; 514 pragma Inline (Is_Equivalent_Node_Node); 515 516 function Is_Equivalent is 517 new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node); 518 519 ----------------------------- 520 -- Is_Equivalent_Node_Node -- 521 ----------------------------- 522 523 function Is_Equivalent_Node_Node (L, R : Node_Type) return Boolean is 524 begin 525 if L.Element < R.Element then 526 return False; 527 elsif R.Element < L.Element then 528 return False; 529 else 530 return True; 531 end if; 532 end Is_Equivalent_Node_Node; 533 534 -- Start of processing for Equivalent_Sets 535 536 begin 537 return Is_Equivalent (Left, Right); 538 end Equivalent_Sets; 539 540 ------------- 541 -- Exclude -- 542 ------------- 543 544 procedure Exclude (Container : in out Set; Item : Element_Type) is 545 X : constant Count_Type := Element_Keys.Find (Container, Item); 546 begin 547 if X /= 0 then 548 Tree_Operations.Delete_Node_Sans_Free (Container, X); 549 Formal_Ordered_Sets.Free (Container, X); 550 end if; 551 end Exclude; 552 553 ---------- 554 -- Find -- 555 ---------- 556 557 function Find (Container : Set; Item : Element_Type) return Cursor is 558 Node : constant Count_Type := Element_Keys.Find (Container, Item); 559 560 begin 561 if Node = 0 then 562 return No_Element; 563 end if; 564 565 return (Node => Node); 566 end Find; 567 568 ----------- 569 -- First -- 570 ----------- 571 572 function First (Container : Set) return Cursor is 573 begin 574 if Length (Container) = 0 then 575 return No_Element; 576 end if; 577 578 return (Node => Container.First); 579 end First; 580 581 ------------------- 582 -- First_Element -- 583 ------------------- 584 585 function First_Element (Container : Set) return Element_Type is 586 Fst : constant Count_Type := First (Container).Node; 587 begin 588 if Fst = 0 then 589 raise Constraint_Error with "set is empty"; 590 end if; 591 592 declare 593 N : Tree_Types.Nodes_Type renames Container.Nodes; 594 begin 595 return N (Fst).Element; 596 end; 597 end First_Element; 598 599 ----------------------- 600 -- First_To_Previous -- 601 ----------------------- 602 603 function First_To_Previous 604 (Container : Set; 605 Current : Cursor) return Set 606 is 607 Curs : Cursor := Current; 608 C : Set (Container.Capacity) := Copy (Container, Container.Capacity); 609 Node : Count_Type; 610 611 begin 612 if Curs = No_Element then 613 return C; 614 615 elsif not Has_Element (Container, Curs) then 616 raise Constraint_Error; 617 618 else 619 while Curs.Node /= 0 loop 620 Node := Curs.Node; 621 Delete (C, Curs); 622 Curs := Next (Container, (Node => Node)); 623 end loop; 624 625 return C; 626 end if; 627 end First_To_Previous; 628 629 ----------- 630 -- Floor -- 631 ----------- 632 633 function Floor (Container : Set; Item : Element_Type) return Cursor is 634 begin 635 declare 636 Node : constant Count_Type := Element_Keys.Floor (Container, Item); 637 638 begin 639 if Node = 0 then 640 return No_Element; 641 end if; 642 643 return (Node => Node); 644 end; 645 end Floor; 646 647 ---------- 648 -- Free -- 649 ---------- 650 651 procedure Free (Tree : in out Set; X : Count_Type) is 652 begin 653 Tree.Nodes (X).Has_Element := False; 654 Tree_Operations.Free (Tree, X); 655 end Free; 656 657 ---------------------- 658 -- Generic_Allocate -- 659 ---------------------- 660 661 procedure Generic_Allocate 662 (Tree : in out Tree_Types.Tree_Type'Class; 663 Node : out Count_Type) 664 is 665 procedure Allocate is 666 new Tree_Operations.Generic_Allocate (Set_Element); 667 begin 668 Allocate (Tree, Node); 669 Tree.Nodes (Node).Has_Element := True; 670 end Generic_Allocate; 671 672 ------------------ 673 -- Generic_Keys -- 674 ------------------ 675 676 package body Generic_Keys with SPARK_Mode => Off is 677 678 ----------------------- 679 -- Local Subprograms -- 680 ----------------------- 681 682 function Is_Greater_Key_Node 683 (Left : Key_Type; 684 Right : Node_Type) return Boolean; 685 pragma Inline (Is_Greater_Key_Node); 686 687 function Is_Less_Key_Node 688 (Left : Key_Type; 689 Right : Node_Type) return Boolean; 690 pragma Inline (Is_Less_Key_Node); 691 692 -------------------------- 693 -- Local Instantiations -- 694 -------------------------- 695 696 package Key_Keys is 697 new Red_Black_Trees.Generic_Bounded_Keys 698 (Tree_Operations => Tree_Operations, 699 Key_Type => Key_Type, 700 Is_Less_Key_Node => Is_Less_Key_Node, 701 Is_Greater_Key_Node => Is_Greater_Key_Node); 702 703 ------------- 704 -- Ceiling -- 705 ------------- 706 707 function Ceiling (Container : Set; Key : Key_Type) return Cursor is 708 Node : constant Count_Type := Key_Keys.Ceiling (Container, Key); 709 710 begin 711 if Node = 0 then 712 return No_Element; 713 end if; 714 715 return (Node => Node); 716 end Ceiling; 717 718 -------------- 719 -- Contains -- 720 -------------- 721 722 function Contains (Container : Set; Key : Key_Type) return Boolean is 723 begin 724 return Find (Container, Key) /= No_Element; 725 end Contains; 726 727 ------------ 728 -- Delete -- 729 ------------ 730 731 procedure Delete (Container : in out Set; Key : Key_Type) is 732 X : constant Count_Type := Key_Keys.Find (Container, Key); 733 734 begin 735 if X = 0 then 736 raise Constraint_Error with "attempt to delete key not in set"; 737 end if; 738 739 Delete_Node_Sans_Free (Container, X); 740 Formal_Ordered_Sets.Free (Container, X); 741 end Delete; 742 743 ------------- 744 -- Element -- 745 ------------- 746 747 function Element (Container : Set; Key : Key_Type) return Element_Type is 748 Node : constant Count_Type := Key_Keys.Find (Container, Key); 749 750 begin 751 if Node = 0 then 752 raise Constraint_Error with "key not in set"; 753 end if; 754 755 declare 756 N : Tree_Types.Nodes_Type renames Container.Nodes; 757 begin 758 return N (Node).Element; 759 end; 760 end Element; 761 762 --------------------- 763 -- Equivalent_Keys -- 764 --------------------- 765 766 function Equivalent_Keys (Left, Right : Key_Type) return Boolean is 767 begin 768 if Left < Right 769 or else Right < Left 770 then 771 return False; 772 else 773 return True; 774 end if; 775 end Equivalent_Keys; 776 777 ------------- 778 -- Exclude -- 779 ------------- 780 781 procedure Exclude (Container : in out Set; Key : Key_Type) is 782 X : constant Count_Type := Key_Keys.Find (Container, Key); 783 begin 784 if X /= 0 then 785 Delete_Node_Sans_Free (Container, X); 786 Formal_Ordered_Sets.Free (Container, X); 787 end if; 788 end Exclude; 789 790 ---------- 791 -- Find -- 792 ---------- 793 794 function Find (Container : Set; Key : Key_Type) return Cursor is 795 Node : constant Count_Type := Key_Keys.Find (Container, Key); 796 begin 797 return (if Node = 0 then No_Element else (Node => Node)); 798 end Find; 799 800 ----------- 801 -- Floor -- 802 ----------- 803 804 function Floor (Container : Set; Key : Key_Type) return Cursor is 805 Node : constant Count_Type := Key_Keys.Floor (Container, Key); 806 begin 807 return (if Node = 0 then No_Element else (Node => Node)); 808 end Floor; 809 810 ------------------------- 811 -- Is_Greater_Key_Node -- 812 ------------------------- 813 814 function Is_Greater_Key_Node 815 (Left : Key_Type; 816 Right : Node_Type) return Boolean 817 is 818 begin 819 return Key (Right.Element) < Left; 820 end Is_Greater_Key_Node; 821 822 ---------------------- 823 -- Is_Less_Key_Node -- 824 ---------------------- 825 826 function Is_Less_Key_Node 827 (Left : Key_Type; 828 Right : Node_Type) return Boolean 829 is 830 begin 831 return Left < Key (Right.Element); 832 end Is_Less_Key_Node; 833 834 --------- 835 -- Key -- 836 --------- 837 838 function Key (Container : Set; Position : Cursor) return Key_Type is 839 begin 840 if not Has_Element (Container, Position) then 841 raise Constraint_Error with 842 "Position cursor has no element"; 843 end if; 844 845 pragma Assert (Vet (Container, Position.Node), 846 "bad cursor in Key"); 847 848 declare 849 N : Tree_Types.Nodes_Type renames Container.Nodes; 850 begin 851 return Key (N (Position.Node).Element); 852 end; 853 end Key; 854 855 ------------- 856 -- Replace -- 857 ------------- 858 859 procedure Replace 860 (Container : in out Set; 861 Key : Key_Type; 862 New_Item : Element_Type) 863 is 864 Node : constant Count_Type := Key_Keys.Find (Container, Key); 865 begin 866 if not Has_Element (Container, (Node => Node)) then 867 raise Constraint_Error with 868 "attempt to replace key not in set"; 869 else 870 Replace_Element (Container, Node, New_Item); 871 end if; 872 end Replace; 873 874 end Generic_Keys; 875 876 ----------------- 877 -- Has_Element -- 878 ----------------- 879 880 function Has_Element (Container : Set; Position : Cursor) return Boolean is 881 begin 882 if Position.Node = 0 then 883 return False; 884 else 885 return Container.Nodes (Position.Node).Has_Element; 886 end if; 887 end Has_Element; 888 889 ------------- 890 -- Include -- 891 ------------- 892 893 procedure Include (Container : in out Set; New_Item : Element_Type) is 894 Position : Cursor; 895 Inserted : Boolean; 896 897 begin 898 Insert (Container, New_Item, Position, Inserted); 899 900 if not Inserted then 901 declare 902 N : Tree_Types.Nodes_Type renames Container.Nodes; 903 begin 904 N (Position.Node).Element := New_Item; 905 end; 906 end if; 907 end Include; 908 909 ------------ 910 -- Insert -- 911 ------------ 912 913 procedure Insert 914 (Container : in out Set; 915 New_Item : Element_Type; 916 Position : out Cursor; 917 Inserted : out Boolean) 918 is 919 begin 920 Insert_Sans_Hint (Container, New_Item, Position.Node, Inserted); 921 end Insert; 922 923 procedure Insert 924 (Container : in out Set; 925 New_Item : Element_Type) 926 is 927 Position : Cursor; 928 Inserted : Boolean; 929 930 begin 931 Insert (Container, New_Item, Position, Inserted); 932 933 if not Inserted then 934 raise Constraint_Error with 935 "attempt to insert element already in set"; 936 end if; 937 end Insert; 938 939 ---------------------- 940 -- Insert_Sans_Hint -- 941 ---------------------- 942 943 procedure Insert_Sans_Hint 944 (Container : in out Set; 945 New_Item : Element_Type; 946 Node : out Count_Type; 947 Inserted : out Boolean) 948 is 949 procedure Set_Element (Node : in out Node_Type); 950 951 function New_Node return Count_Type; 952 pragma Inline (New_Node); 953 954 procedure Insert_Post is 955 new Element_Keys.Generic_Insert_Post (New_Node); 956 957 procedure Conditional_Insert_Sans_Hint is 958 new Element_Keys.Generic_Conditional_Insert (Insert_Post); 959 960 procedure Allocate is new Generic_Allocate (Set_Element); 961 962 -------------- 963 -- New_Node -- 964 -------------- 965 966 function New_Node return Count_Type is 967 Result : Count_Type; 968 begin 969 Allocate (Container, Result); 970 return Result; 971 end New_Node; 972 973 ----------------- 974 -- Set_Element -- 975 ----------------- 976 977 procedure Set_Element (Node : in out Node_Type) is 978 begin 979 Node.Element := New_Item; 980 end Set_Element; 981 982 -- Start of processing for Insert_Sans_Hint 983 984 begin 985 Conditional_Insert_Sans_Hint 986 (Container, 987 New_Item, 988 Node, 989 Inserted); 990 end Insert_Sans_Hint; 991 992 ---------------------- 993 -- Insert_With_Hint -- 994 ---------------------- 995 996 procedure Insert_With_Hint 997 (Dst_Set : in out Set; 998 Dst_Hint : Count_Type; 999 Src_Node : Node_Type; 1000 Dst_Node : out Count_Type) 1001 is 1002 Success : Boolean; 1003 pragma Unreferenced (Success); 1004 1005 procedure Set_Element (Node : in out Node_Type); 1006 1007 function New_Node return Count_Type; 1008 pragma Inline (New_Node); 1009 1010 procedure Insert_Post is 1011 new Element_Keys.Generic_Insert_Post (New_Node); 1012 1013 procedure Insert_Sans_Hint is 1014 new Element_Keys.Generic_Conditional_Insert (Insert_Post); 1015 1016 procedure Local_Insert_With_Hint is 1017 new Element_Keys.Generic_Conditional_Insert_With_Hint 1018 (Insert_Post, Insert_Sans_Hint); 1019 1020 procedure Allocate is new Generic_Allocate (Set_Element); 1021 1022 -------------- 1023 -- New_Node -- 1024 -------------- 1025 1026 function New_Node return Count_Type is 1027 Result : Count_Type; 1028 begin 1029 Allocate (Dst_Set, Result); 1030 return Result; 1031 end New_Node; 1032 1033 ----------------- 1034 -- Set_Element -- 1035 ----------------- 1036 1037 procedure Set_Element (Node : in out Node_Type) is 1038 begin 1039 Node.Element := Src_Node.Element; 1040 end Set_Element; 1041 1042 -- Start of processing for Insert_With_Hint 1043 1044 begin 1045 Local_Insert_With_Hint 1046 (Dst_Set, 1047 Dst_Hint, 1048 Src_Node.Element, 1049 Dst_Node, 1050 Success); 1051 end Insert_With_Hint; 1052 1053 ------------------ 1054 -- Intersection -- 1055 ------------------ 1056 1057 procedure Intersection (Target : in out Set; Source : Set) is 1058 begin 1059 Set_Ops.Set_Intersection (Target, Source); 1060 end Intersection; 1061 1062 function Intersection (Left, Right : Set) return Set is 1063 begin 1064 if Left'Address = Right'Address then 1065 return Left.Copy; 1066 end if; 1067 1068 return S : Set (Count_Type'Min (Length (Left), Length (Right))) do 1069 Assign (S, Set_Ops.Set_Intersection (Left, Right)); 1070 end return; 1071 end Intersection; 1072 1073 -------------- 1074 -- Is_Empty -- 1075 -------------- 1076 1077 function Is_Empty (Container : Set) return Boolean is 1078 begin 1079 return Length (Container) = 0; 1080 end Is_Empty; 1081 1082 ----------------------------- 1083 -- Is_Greater_Element_Node -- 1084 ----------------------------- 1085 1086 function Is_Greater_Element_Node 1087 (Left : Element_Type; 1088 Right : Node_Type) return Boolean 1089 is 1090 begin 1091 -- Compute e > node same as node < e 1092 1093 return Right.Element < Left; 1094 end Is_Greater_Element_Node; 1095 1096 -------------------------- 1097 -- Is_Less_Element_Node -- 1098 -------------------------- 1099 1100 function Is_Less_Element_Node 1101 (Left : Element_Type; 1102 Right : Node_Type) return Boolean 1103 is 1104 begin 1105 return Left < Right.Element; 1106 end Is_Less_Element_Node; 1107 1108 ----------------------- 1109 -- Is_Less_Node_Node -- 1110 ----------------------- 1111 1112 function Is_Less_Node_Node (L, R : Node_Type) return Boolean is 1113 begin 1114 return L.Element < R.Element; 1115 end Is_Less_Node_Node; 1116 1117 --------------- 1118 -- Is_Subset -- 1119 --------------- 1120 1121 function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is 1122 begin 1123 return Set_Ops.Set_Subset (Subset, Of_Set => Of_Set); 1124 end Is_Subset; 1125 1126 ---------- 1127 -- Last -- 1128 ---------- 1129 1130 function Last (Container : Set) return Cursor is 1131 begin 1132 return (if Length (Container) = 0 1133 then No_Element 1134 else (Node => Container.Last)); 1135 end Last; 1136 1137 ------------------ 1138 -- Last_Element -- 1139 ------------------ 1140 1141 function Last_Element (Container : Set) return Element_Type is 1142 begin 1143 if Last (Container).Node = 0 then 1144 raise Constraint_Error with "set is empty"; 1145 end if; 1146 1147 declare 1148 N : Tree_Types.Nodes_Type renames Container.Nodes; 1149 begin 1150 return N (Last (Container).Node).Element; 1151 end; 1152 end Last_Element; 1153 1154 -------------- 1155 -- Left_Son -- 1156 -------------- 1157 1158 function Left_Son (Node : Node_Type) return Count_Type is 1159 begin 1160 return Node.Left; 1161 end Left_Son; 1162 1163 ------------ 1164 -- Length -- 1165 ------------ 1166 1167 function Length (Container : Set) return Count_Type is 1168 begin 1169 return Container.Length; 1170 end Length; 1171 1172 ---------- 1173 -- Move -- 1174 ---------- 1175 1176 procedure Move (Target : in out Set; Source : in out Set) is 1177 N : Tree_Types.Nodes_Type renames Source.Nodes; 1178 X : Count_Type; 1179 1180 begin 1181 if Target'Address = Source'Address then 1182 return; 1183 end if; 1184 1185 if Target.Capacity < Length (Source) then 1186 raise Constraint_Error with -- ??? 1187 "Source length exceeds Target capacity"; 1188 end if; 1189 1190 Clear (Target); 1191 1192 loop 1193 X := Source.First; 1194 exit when X = 0; 1195 1196 Insert (Target, N (X).Element); -- optimize??? 1197 1198 Tree_Operations.Delete_Node_Sans_Free (Source, X); 1199 Formal_Ordered_Sets.Free (Source, X); 1200 end loop; 1201 end Move; 1202 1203 ---------- 1204 -- Next -- 1205 ---------- 1206 1207 function Next (Container : Set; Position : Cursor) return Cursor is 1208 begin 1209 if Position = No_Element then 1210 return No_Element; 1211 end if; 1212 1213 if not Has_Element (Container, Position) then 1214 raise Constraint_Error; 1215 end if; 1216 1217 pragma Assert (Vet (Container, Position.Node), 1218 "bad cursor in Next"); 1219 return (Node => Tree_Operations.Next (Container, Position.Node)); 1220 end Next; 1221 1222 procedure Next (Container : Set; Position : in out Cursor) is 1223 begin 1224 Position := Next (Container, Position); 1225 end Next; 1226 1227 ------------- 1228 -- Overlap -- 1229 ------------- 1230 1231 function Overlap (Left, Right : Set) return Boolean is 1232 begin 1233 return Set_Ops.Set_Overlap (Left, Right); 1234 end Overlap; 1235 1236 ------------ 1237 -- Parent -- 1238 ------------ 1239 1240 function Parent (Node : Node_Type) return Count_Type is 1241 begin 1242 return Node.Parent; 1243 end Parent; 1244 1245 -------------- 1246 -- Previous -- 1247 -------------- 1248 1249 function Previous (Container : Set; Position : Cursor) return Cursor is 1250 begin 1251 if Position = No_Element then 1252 return No_Element; 1253 end if; 1254 1255 if not Has_Element (Container, Position) then 1256 raise Constraint_Error; 1257 end if; 1258 1259 pragma Assert (Vet (Container, Position.Node), 1260 "bad cursor in Previous"); 1261 1262 declare 1263 Node : constant Count_Type := 1264 Tree_Operations.Previous (Container, Position.Node); 1265 begin 1266 return (if Node = 0 then No_Element else (Node => Node)); 1267 end; 1268 end Previous; 1269 1270 procedure Previous (Container : Set; Position : in out Cursor) is 1271 begin 1272 Position := Previous (Container, Position); 1273 end Previous; 1274 1275 ------------- 1276 -- Replace -- 1277 ------------- 1278 1279 procedure Replace (Container : in out Set; New_Item : Element_Type) is 1280 Node : constant Count_Type := Element_Keys.Find (Container, New_Item); 1281 1282 begin 1283 if Node = 0 then 1284 raise Constraint_Error with 1285 "attempt to replace element not in set"; 1286 end if; 1287 1288 Container.Nodes (Node).Element := New_Item; 1289 end Replace; 1290 1291 --------------------- 1292 -- Replace_Element -- 1293 --------------------- 1294 1295 procedure Replace_Element 1296 (Tree : in out Set; 1297 Node : Count_Type; 1298 Item : Element_Type) 1299 is 1300 pragma Assert (Node /= 0); 1301 1302 function New_Node return Count_Type; 1303 pragma Inline (New_Node); 1304 1305 procedure Local_Insert_Post is 1306 new Element_Keys.Generic_Insert_Post (New_Node); 1307 1308 procedure Local_Insert_Sans_Hint is 1309 new Element_Keys.Generic_Conditional_Insert (Local_Insert_Post); 1310 1311 procedure Local_Insert_With_Hint is 1312 new Element_Keys.Generic_Conditional_Insert_With_Hint 1313 (Local_Insert_Post, 1314 Local_Insert_Sans_Hint); 1315 1316 NN : Tree_Types.Nodes_Type renames Tree.Nodes; 1317 1318 -------------- 1319 -- New_Node -- 1320 -------------- 1321 1322 function New_Node return Count_Type is 1323 N : Node_Type renames NN (Node); 1324 begin 1325 N.Element := Item; 1326 N.Color := Red; 1327 N.Parent := 0; 1328 N.Right := 0; 1329 N.Left := 0; 1330 return Node; 1331 end New_Node; 1332 1333 Hint : Count_Type; 1334 Result : Count_Type; 1335 Inserted : Boolean; 1336 1337 -- Start of processing for Insert 1338 1339 begin 1340 if Item < NN (Node).Element 1341 or else NN (Node).Element < Item 1342 then 1343 null; 1344 1345 else 1346 NN (Node).Element := Item; 1347 return; 1348 end if; 1349 1350 Hint := Element_Keys.Ceiling (Tree, Item); 1351 1352 if Hint = 0 then 1353 null; 1354 1355 elsif Item < NN (Hint).Element then 1356 if Hint = Node then 1357 NN (Node).Element := Item; 1358 return; 1359 end if; 1360 1361 else 1362 pragma Assert (not (NN (Hint).Element < Item)); 1363 raise Program_Error with "attempt to replace existing element"; 1364 end if; 1365 1366 Tree_Operations.Delete_Node_Sans_Free (Tree, Node); 1367 1368 Local_Insert_With_Hint 1369 (Tree => Tree, 1370 Position => Hint, 1371 Key => Item, 1372 Node => Result, 1373 Inserted => Inserted); 1374 1375 pragma Assert (Inserted); 1376 pragma Assert (Result = Node); 1377 end Replace_Element; 1378 1379 procedure Replace_Element 1380 (Container : in out Set; 1381 Position : Cursor; 1382 New_Item : Element_Type) 1383 is 1384 begin 1385 if not Has_Element (Container, Position) then 1386 raise Constraint_Error with 1387 "Position cursor has no element"; 1388 end if; 1389 1390 pragma Assert (Vet (Container, Position.Node), 1391 "bad cursor in Replace_Element"); 1392 1393 Replace_Element (Container, Position.Node, New_Item); 1394 end Replace_Element; 1395 1396 --------------- 1397 -- Right_Son -- 1398 --------------- 1399 1400 function Right_Son (Node : Node_Type) return Count_Type is 1401 begin 1402 return Node.Right; 1403 end Right_Son; 1404 1405 --------------- 1406 -- Set_Color -- 1407 --------------- 1408 1409 procedure Set_Color 1410 (Node : in out Node_Type; 1411 Color : Red_Black_Trees.Color_Type) 1412 is 1413 begin 1414 Node.Color := Color; 1415 end Set_Color; 1416 1417 -------------- 1418 -- Set_Left -- 1419 -------------- 1420 1421 procedure Set_Left (Node : in out Node_Type; Left : Count_Type) is 1422 begin 1423 Node.Left := Left; 1424 end Set_Left; 1425 1426 ---------------- 1427 -- Set_Parent -- 1428 ---------------- 1429 1430 procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type) is 1431 begin 1432 Node.Parent := Parent; 1433 end Set_Parent; 1434 1435 --------------- 1436 -- Set_Right -- 1437 --------------- 1438 1439 procedure Set_Right (Node : in out Node_Type; Right : Count_Type) is 1440 begin 1441 Node.Right := Right; 1442 end Set_Right; 1443 1444 ------------------ 1445 -- Strict_Equal -- 1446 ------------------ 1447 1448 function Strict_Equal (Left, Right : Set) return Boolean is 1449 LNode : Count_Type := First (Left).Node; 1450 RNode : Count_Type := First (Right).Node; 1451 1452 begin 1453 if Length (Left) /= Length (Right) then 1454 return False; 1455 end if; 1456 1457 while LNode = RNode loop 1458 if LNode = 0 then 1459 return True; 1460 end if; 1461 1462 if Left.Nodes (LNode).Element /= Right.Nodes (RNode).Element then 1463 exit; 1464 end if; 1465 1466 LNode := Next (Left, LNode); 1467 RNode := Next (Right, RNode); 1468 end loop; 1469 1470 return False; 1471 end Strict_Equal; 1472 1473 -------------------------- 1474 -- Symmetric_Difference -- 1475 -------------------------- 1476 1477 procedure Symmetric_Difference (Target : in out Set; Source : Set) is 1478 begin 1479 Set_Ops.Set_Symmetric_Difference (Target, Source); 1480 end Symmetric_Difference; 1481 1482 function Symmetric_Difference (Left, Right : Set) return Set is 1483 begin 1484 if Left'Address = Right'Address then 1485 return Empty_Set; 1486 end if; 1487 1488 if Length (Right) = 0 then 1489 return Left.Copy; 1490 end if; 1491 1492 if Length (Left) = 0 then 1493 return Right.Copy; 1494 end if; 1495 1496 return S : Set (Length (Left) + Length (Right)) do 1497 Assign (S, Set_Ops.Set_Symmetric_Difference (Left, Right)); 1498 end return; 1499 end Symmetric_Difference; 1500 1501 ------------ 1502 -- To_Set -- 1503 ------------ 1504 1505 function To_Set (New_Item : Element_Type) return Set is 1506 Node : Count_Type; 1507 Inserted : Boolean; 1508 begin 1509 return S : Set (Capacity => 1) do 1510 Insert_Sans_Hint (S, New_Item, Node, Inserted); 1511 pragma Assert (Inserted); 1512 end return; 1513 end To_Set; 1514 1515 ----------- 1516 -- Union -- 1517 ----------- 1518 1519 procedure Union (Target : in out Set; Source : Set) is 1520 begin 1521 Set_Ops.Set_Union (Target, Source); 1522 end Union; 1523 1524 function Union (Left, Right : Set) return Set is 1525 begin 1526 if Left'Address = Right'Address then 1527 return Left.Copy; 1528 end if; 1529 1530 if Length (Left) = 0 then 1531 return Right.Copy; 1532 end if; 1533 1534 if Length (Right) = 0 then 1535 return Left.Copy; 1536 end if; 1537 1538 return S : Set (Length (Left) + Length (Right)) do 1539 Assign (S, Source => Left); 1540 Union (S, Right); 1541 end return; 1542 end Union; 1543 1544end Ada.Containers.Formal_Ordered_Sets; 1545