1------------------------------------------------------------------------------ 2-- GtkAda - Ada95 binding for Gtk+/Gnome -- 3-- -- 4-- Copyright (C) 2001-2015, AdaCore -- 5-- -- 6-- This library is free software; you can redistribute it and/or modify it -- 7-- under terms of the GNU General Public License as published by the Free -- 8-- Software Foundation; either version 3, or (at your option) any later -- 9-- version. This library is distributed in the hope that it will be useful, -- 10-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 11-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 12-- -- 13-- As a special exception under Section 7 of GPL version 3, you are granted -- 14-- additional permissions described in the GCC Runtime Library Exception, -- 15-- version 3.1, as published by the Free Software Foundation. -- 16-- -- 17-- You should have received a copy of the GNU General Public License and -- 18-- a copy of the GCC Runtime Library Exception along with this program; -- 19-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 20-- <http://www.gnu.org/licenses/>. -- 21-- -- 22------------------------------------------------------------------------------ 23 24with Unchecked_Deallocation; 25 26package body Glib.Graphs is 27 28 type Search_Color is (White, Gray, Black); 29 type Color_Array is array (Natural range <>) of Search_Color; 30 31 procedure Move_To_Next (E : in out Edge_Iterator); 32 -- nove the next matching edge, starting at the one pointed to by E 33 -- E should be the first potential candidate for the next item (ie should 34 -- already have been moved to the next edge). 35 36 ------------------ 37 -- Set_Directed -- 38 ------------------ 39 40 procedure Set_Directed (G : in out Graph; Directed : Boolean) is 41 begin 42 G.Directed := Directed; 43 end Set_Directed; 44 45 ----------------- 46 -- Is_Directed -- 47 ----------------- 48 49 function Is_Directed (G : Graph) return Boolean is 50 begin 51 return G.Directed; 52 end Is_Directed; 53 54 --------------- 55 -- Get_Index -- 56 --------------- 57 58 function Get_Index (V : access Vertex) return Natural is 59 begin 60 return V.Index; 61 end Get_Index; 62 63 --------------- 64 -- Max_Index -- 65 --------------- 66 67 function Max_Index (G : Graph) return Integer is 68 begin 69 return G.Last_Vertex_Index - 1; 70 end Max_Index; 71 72 ---------------- 73 -- Add_Vertex -- 74 ---------------- 75 76 procedure Add_Vertex (G : in out Graph; V : access Vertex'Class) is 77 begin 78 V.Index := G.Last_Vertex_Index; 79 G.Last_Vertex_Index := G.Last_Vertex_Index + 1; 80 G.Num_Vertices := G.Num_Vertices + 1; 81 Add (G.Vertices, V); 82 end Add_Vertex; 83 84 -------------- 85 -- Add_Edge -- 86 -------------- 87 88 procedure Add_Edge 89 (G : in out Graph; 90 E : access Edge'Class; 91 Source, Dest : access Vertex'Class) 92 is 93 pragma Unreferenced (G); 94 begin 95 pragma Assert (E.Src = null and then E.Dest = null); 96 E.Src := Vertex_Access (Source); 97 E.Dest := Vertex_Access (Dest); 98 Add (Source.Out_Edges, E); 99 Add (Dest.In_Edges, E); 100 end Add_Edge; 101 102 -------------- 103 -- Add_Edge -- 104 -------------- 105 106 procedure Add_Edge 107 (G : in out Graph; 108 Source, Dest : access Vertex'Class) 109 is 110 E : constant Edge_Access := new Edge; 111 begin 112 Add_Edge (G, E, Source, Dest); 113 end Add_Edge; 114 115 ------------ 116 -- Remove -- 117 ------------ 118 119 procedure Remove (G : in out Graph; E : access Edge'Class) is 120 pragma Unreferenced (G); 121 122 procedure Free is new Unchecked_Deallocation (Edge'Class, Edge_Access); 123 E2 : Edge_Access := Edge_Access (E); 124 125 begin 126 Remove (E.Src.Out_Edges, E); 127 Remove (E.Dest.In_Edges, E); 128 Destroy (E.all); 129 Free (E2); 130 end Remove; 131 132 ------------- 133 -- Destroy -- 134 ------------- 135 136 procedure Destroy (G : in out Graph) is 137 begin 138 Clear (G); 139 end Destroy; 140 141 ----------- 142 -- Clear -- 143 ----------- 144 145 procedure Clear (G : in out Graph) is 146 begin 147 while G.Vertices /= null loop 148 Remove (G, G.Vertices.V); 149 end loop; 150 end Clear; 151 152 ------------ 153 -- Remove -- 154 ------------ 155 156 procedure Remove (G : in out Graph; V : access Vertex'Class) is 157 procedure Free is new Unchecked_Deallocation 158 (Vertex'Class, Vertex_Access); 159 E : Edge_Iterator; 160 E2 : Edge_Access; 161 V2 : Vertex_Access := Vertex_Access (V); 162 begin 163 -- Destroy all outgoing edges 164 E := First (G, Src => Vertex_Access (V)); 165 while not At_End (E) loop 166 E2 := Get (E); 167 Next (E); 168 Remove (G, E2); 169 end loop; 170 171 -- Destroy all ingoing edges 172 E := First (G, Dest => Vertex_Access (V)); 173 while not At_End (E) loop 174 E2 := Get (E); 175 Next (E); 176 Remove (G, E2); -- ??? Could be more efficient, since we have 177 -- the pointer into the list directly 178 end loop; 179 180 -- Free the vertex 181 Internal_Remove (G, V); 182 Destroy (V.all); 183 Free (V2); 184 end Remove; 185 186 --------- 187 -- Add -- 188 --------- 189 190 procedure Add (List : in out Edge_List; E : access Edge'Class) is 191 L : Edge_List := List; 192 begin 193 -- Insert the item in the list so that items with equal ends are next to 194 -- each other. 195 196 while L /= null loop 197 if L.E.Src = E.Src and then L.E.Dest = E.Dest then 198 L.Next := new Edge_List_Record' 199 (E => Edge_Access (E), Next => L.Next); 200 return; 201 end if; 202 L := L.Next; 203 end loop; 204 205 List := new Edge_List_Record'(E => Edge_Access (E), Next => List); 206 end Add; 207 208 --------- 209 -- Add -- 210 --------- 211 212 procedure Add (List : in out Vertex_List; V : access Vertex'Class) is 213 begin 214 List := new Vertex_List_Record'(V => Vertex_Access (V), Next => List); 215 end Add; 216 217 ------------ 218 -- Remove -- 219 ------------ 220 221 procedure Remove (List : in out Edge_List; E : access Edge'Class) is 222 procedure Internal is new Unchecked_Deallocation 223 (Edge_List_Record, Edge_List); 224 Tmp : Edge_List := List; 225 Previous : Edge_List; 226 begin 227 while Tmp /= null 228 and then Tmp.E /= Edge_Access (E) 229 loop 230 Previous := Tmp; 231 Tmp := Tmp.Next; 232 end loop; 233 234 if Tmp /= null then 235 if Previous = null then 236 pragma Assert (Tmp = List); 237 Previous := List; 238 List := List.Next; 239 Internal (Previous); 240 else 241 Previous.Next := Tmp.Next; 242 Internal (Tmp); 243 end if; 244 end if; 245 end Remove; 246 247 ------------ 248 -- Remove -- 249 ------------ 250 251 procedure Internal_Remove (G : in out Graph; V : access Vertex'Class) is 252 procedure Internal is new Unchecked_Deallocation 253 (Vertex_List_Record, Vertex_List); 254 Tmp : Vertex_List := G.Vertices; 255 Previous : Vertex_List := null; 256 begin 257 while Tmp /= null 258 and then Tmp.V /= Vertex_Access (V) 259 loop 260 Previous := Tmp; 261 Tmp := Tmp.Next; 262 end loop; 263 264 if Tmp /= null then 265 if Previous = null then 266 -- The list contains only one item which is the one to be removed. 267 -- Once it has been removed the list must be reset to null. 268 pragma Assert (Tmp = G.Vertices, "Remove vertex"); 269 Previous := G.Vertices; 270 G.Vertices := G.Vertices.Next; 271 Internal (Previous); 272 else 273 Previous.Next := Tmp.Next; 274 Internal (Tmp); 275 end if; 276 G.Num_Vertices := G.Num_Vertices - 1; 277 end if; 278 end Internal_Remove; 279 280 ----------- 281 -- First -- 282 ----------- 283 284 function First (G : Graph) return Vertex_Iterator is 285 begin 286 return Vertex_Iterator (G.Vertices); 287 end First; 288 289 ---------- 290 -- Next -- 291 ---------- 292 293 procedure Next (V : in out Vertex_Iterator) is 294 begin 295 V := Vertex_Iterator (V.Next); 296 end Next; 297 298 ------------ 299 -- At_End -- 300 ------------ 301 302 function At_End (V : Vertex_Iterator) return Boolean is 303 begin 304 return V = null; 305 end At_End; 306 307 --------- 308 -- Get -- 309 --------- 310 311 function Get (V : Vertex_Iterator) return Vertex_Access is 312 begin 313 return V.V; 314 end Get; 315 316 ----------- 317 -- First -- 318 ----------- 319 320 function First (G : Graph; 321 Src, Dest : Vertex_Access := null; 322 Directed : Boolean := True) 323 return Edge_Iterator 324 is 325 Va : Edge_Iterator := 326 (Directed => Directed and then G.Directed, 327 Repeat_Count => 1, 328 Src => Src, 329 Dest => Dest, 330 Current_Vertex => null, 331 Current_Edge => null, 332 First_Pass => True); 333 334 begin 335 if Src /= null then 336 -- If Src /= null and then Dest = null then 337 -- Result is the whole list from Src.Out_Nodes 338 -- If not directed: add to it the list of Dest.Out_Nodes 339 -- Duplicates in the following case: a given node has two links 340 -- to and from Src, and the graph is not oriented. 341 -- Src <-----> B 342 -- Elsif Src /= null and then Dest /= null then 343 -- Result is the whole list from Src.Out_Nodes that match Dest 344 -- If not directed: add to it the list of Dest.In_Nodes that 345 -- match Src. 346 -- Duplicates when there is a link from src to dest, and one from 347 -- dest to src. 348 Va.Current_Edge := Src.Out_Edges; 349 350 elsif Dest = null then 351 -- If Src = null and then Dest = null then 352 -- Result is the concatenation for all edges of Edge.Out_Nodes 353 if G.Vertices /= null then 354 Va.Current_Vertex := G.Vertices; 355 Va.Current_Edge := G.Vertices.V.Out_Edges; 356 end if; 357 358 else 359 -- If Src = null and then Dest /= null then 360 -- Result is the whole list from Dest.In_Nodes 361 Va.Current_Edge := Dest.In_Edges; 362 end if; 363 364 Move_To_Next (Va); 365 return Va; 366 end First; 367 368 ------------------ 369 -- Move_To_Next -- 370 ------------------ 371 372 procedure Move_To_Next (E : in out Edge_Iterator) is 373 begin 374 if E.Src /= null then 375 if E.Dest = null then 376 if E.Current_Edge = null 377 and then not E.Directed 378 and then E.First_Pass 379 then 380 E.First_Pass := False; 381 E.Current_Edge := E.Src.In_Edges; 382 end if; 383 384 else 385 while E.Current_Edge /= null 386 and then (E.First_Pass or else E.Current_Edge.E.Src /= E.Dest) 387 and then (not E.First_Pass 388 or else E.Current_Edge.E.Dest /= E.Dest) 389 loop 390 E.Current_Edge := E.Current_Edge.Next; 391 end loop; 392 393 if E.Current_Edge = null 394 and then not E.Directed 395 and then E.First_Pass 396 then 397 E.First_Pass := False; 398 E.Current_Edge := E.Src.In_Edges; 399 Move_To_Next (E); 400 end if; 401 end if; 402 403 -- In the second pass, we must ignore the recursive links to the 404 -- item, since they have already been counted. 405 if not E.First_Pass then 406 while E.Current_Edge /= null 407 and then E.Current_Edge.E.Src = E.Current_Edge.E.Dest 408 loop 409 E.Current_Edge := E.Current_Edge.Next; 410 end loop; 411 end if; 412 413 elsif E.Dest = null then 414 if E.Current_Vertex /= null then 415 while E.Current_Edge = null loop 416 E.Current_Vertex := E.Current_Vertex.Next; 417 exit when E.Current_Vertex = null; 418 E.Current_Edge := E.Current_Vertex.V.Out_Edges; 419 end loop; 420 end if; 421 422 else 423 if E.Current_Edge = null 424 and then not E.Directed 425 and then E.First_Pass 426 then 427 E.First_Pass := False; 428 E.Current_Edge := E.Dest.Out_Edges; 429 end if; 430 431 -- In the second pass, we must ignore the recursive links to the 432 -- item, since they have already been counted. 433 if not E.First_Pass then 434 while E.Current_Edge /= null 435 and then E.Current_Edge.E.Src = E.Current_Edge.E.Dest 436 loop 437 E.Current_Edge := E.Current_Edge.Next; 438 end loop; 439 end if; 440 end if; 441 end Move_To_Next; 442 443 ---------- 444 -- Next -- 445 ---------- 446 447 procedure Next (E : in out Edge_Iterator) is 448 Save : constant Edge_Access := E.Current_Edge.E; 449 begin 450 E.Current_Edge := E.Current_Edge.Next; 451 Move_To_Next (E); 452 453 if E.Current_Edge /= null then 454 if E.Current_Edge.E.Src = Save.Src 455 and then E.Current_Edge.E.Dest = Save.Dest 456 then 457 E.Repeat_Count := E.Repeat_Count + 1; 458 else 459 E.Repeat_Count := 1; 460 end if; 461 else 462 E.Repeat_Count := 1; 463 end if; 464 end Next; 465 466 ------------ 467 -- At_End -- 468 ------------ 469 470 function At_End (E : Edge_Iterator) return Boolean is 471 begin 472 return E.Current_Vertex = null 473 and then E.Current_Edge = null; 474 end At_End; 475 476 ------------------ 477 -- Repeat_Count -- 478 ------------------ 479 480 function Repeat_Count (E : Edge_Iterator) return Positive is 481 begin 482 return E.Repeat_Count; 483 end Repeat_Count; 484 485 --------- 486 -- Get -- 487 --------- 488 489 function Get (E : Edge_Iterator) return Edge_Access is 490 begin 491 pragma Assert (not At_End (E)); 492 return E.Current_Edge.E; 493 end Get; 494 495 ------------- 496 -- Get_Src -- 497 ------------- 498 499 function Get_Src (E : access Edge) return Vertex_Access is 500 begin 501 return E.Src; 502 end Get_Src; 503 504 -------------- 505 -- Get_Dest -- 506 -------------- 507 508 function Get_Dest (E : access Edge) return Vertex_Access is 509 begin 510 return E.Dest; 511 end Get_Dest; 512 513 -------------------------- 514 -- Breadth_First_Search -- 515 -------------------------- 516 517 function Breadth_First_Search 518 (G : Graph; Root : access Vertex'Class) 519 return Breadth_Vertices_Array 520 is 521 Colors : Color_Array (0 .. G.Last_Vertex_Index - 1) := (others => White); 522 Distances : array (0 .. G.Last_Vertex_Index - 1) of Natural := 523 (others => Natural'Last); 524 Predecessors : Vertices_Array (0 .. G.Last_Vertex_Index - 1) := 525 (others => null); 526 Queue : Vertices_Array (0 .. G.Num_Vertices - 1); 527 Queue_Index : Integer := 0; 528 Queue_First : Integer := 0; 529 Result : Breadth_Vertices_Array (0 .. G.Num_Vertices - 1); 530 Result_Index : Natural := 0; 531 532 V, U : Vertex_Access; 533 Eit : Edge_Iterator; 534 begin 535 -- Initialize the root 536 Distances (Root.Index) := 0; 537 Queue (Queue_Index) := Vertex_Access (Root); 538 Queue_Index := Queue_Index + 1; 539 540 while Queue_First < Queue_Index loop 541 U := Queue (Queue_First); 542 Eit := First (G, Src => U); 543 while not At_End (Eit) loop 544 V := Get_Dest (Get (Eit)); 545 if V = U then 546 V := Get_Src (Get (Eit)); 547 end if; 548 549 if Colors (V.Index) = White then 550 Colors (V.Index) := Gray; 551 Distances (V.Index) := Distances (U.Index) + 1; 552 Predecessors (V.Index) := U; 553 Queue (Queue_Index) := V; 554 Queue_Index := Queue_Index + 1; 555 end if; 556 Next (Eit); 557 end loop; 558 Queue_First := Queue_First + 1; 559 Colors (U.Index) := Black; 560 Result (Result_Index) := 561 (U, Distances (U.Index), Predecessors (U.Index)); 562 Result_Index := Result_Index + 1; 563 end loop; 564 565 return Result (Result'First .. Result_Index - 1); 566 end Breadth_First_Search; 567 568 ------------------------ 569 -- Depth_First_Search -- 570 ------------------------ 571 572 function Depth_First_Search (G : Graph) return Depth_Vertices_Array is 573 Acyclic : aliased Boolean; 574 begin 575 return Depth_First_Search (G, Acyclic'Access); 576 end Depth_First_Search; 577 578 ------------------------ 579 -- Depth_First_Search -- 580 ------------------------ 581 582 function Depth_First_Search 583 (G : Graph; 584 Acyclic : access Boolean; 585 Reverse_Edge_Cb : Reverse_Edge_Callback := null; 586 Force_Undirected : Boolean := False) 587 return Depth_Vertices_Array 588 is 589 Colors : Color_Array (0 .. G.Last_Vertex_Index - 1) := (others => White); 590 Result : Depth_Vertices_Array (0 .. G.Num_Vertices - 1); 591 Result_Index : Integer := Result'Last; 592 Time : Natural := 0; 593 594 procedure Depth_First_Visit 595 (U : Vertex_Access; 596 Predecessor : Vertex_Access; 597 Edge : Edge_Access); 598 -- Process the node U 599 600 procedure Depth_First_Visit 601 (U : Vertex_Access; 602 Predecessor : Vertex_Access; 603 Edge : Edge_Access) 604 is 605 V : Vertex_Access; 606 Eit : Edge_Iterator; 607 Start_Search : constant Integer := Time + 1; 608 begin 609 Colors (U.Index) := Gray; 610 Time := Time + 1; 611 Eit := First (G, Src => U, Directed => not Force_Undirected); 612 613 while not At_End (Eit) loop 614 V := Get_Dest (Get (Eit)); 615 if V = U then 616 V := Get_Src (Get (Eit)); 617 end if; 618 619 if Colors (V.Index) = White then 620 -- ??? Would be nice to have a non-recursive implementation, to 621 -- ??? support larger graphs 622 Depth_First_Visit (V, Predecessor => U, Edge => Get (Eit)); 623 Next (Eit); 624 625 elsif not Force_Undirected and then Colors (V.Index) = Gray then 626 -- Make the graph acyclic by reversing the edge. 627 if Reverse_Edge_Cb /= null then 628 declare 629 E : constant Edge_Access := Get (Eit); 630 begin 631 -- We need to first move the iterator, otherwise it will 632 -- become invalid when the two edges have been reversed. 633 Next (Eit); 634 Reverse_Edge_Cb (G, E); 635 end; 636 else 637 Acyclic.all := False; 638 Next (Eit); 639 end if; 640 641 else 642 Next (Eit); 643 end if; 644 end loop; 645 646 Colors (U.Index) := Black; 647 Time := Time + 1; 648 Result (Result_Index) := 649 (U, 650 First_Discovered => Start_Search, 651 End_Search => Time, 652 Predecessor => Predecessor, 653 Edge => Edge); 654 Result_Index := Result_Index - 1; 655 end Depth_First_Visit; 656 657 U : Vertex_List; 658 begin 659 Acyclic.all := True; 660 U := G.Vertices; 661 while U /= null loop 662 if Colors (U.V.Index) = White then 663 Depth_First_Visit (U.V, Predecessor => null, Edge => null); 664 end if; 665 U := U.Next; 666 end loop; 667 return Result; 668 end Depth_First_Search; 669 670 ---------------- 671 -- Is_Acyclic -- 672 ---------------- 673 674 function Is_Acyclic (G : Graph) return Boolean is 675 Colors : Color_Array (0 .. G.Last_Vertex_Index - 1) := (others => White); 676 Acyclic : Boolean := True; 677 678 procedure Depth_First_Visit (U : Vertex_Access); 679 -- Process the node U 680 681 procedure Depth_First_Visit (U : Vertex_Access) is 682 V : Vertex_Access; 683 Eit : Edge_Iterator; 684 begin 685 Colors (U.Index) := Gray; 686 Eit := First (G, Src => U); 687 while not At_End (Eit) loop 688 V := Get_Dest (Get (Eit)); 689 if V = U then 690 V := Get_Src (Get (Eit)); 691 end if; 692 693 if Colors (V.Index) = White then 694 Depth_First_Visit (V); 695 if not Acyclic then 696 return; 697 end if; 698 elsif Colors (V.Index) = Gray then 699 Acyclic := False; 700 return; 701 end if; 702 Next (Eit); 703 end loop; 704 Colors (U.Index) := Black; 705 end Depth_First_Visit; 706 707 U : Vertex_List; 708 begin 709 pragma Assert (G.Directed); 710 711 U := G.Vertices; 712 while U /= null loop 713 if Colors (U.V.Index) = White then 714 Depth_First_Visit (U.V); 715 end if; 716 U := U.Next; 717 end loop; 718 return Acyclic; 719 end Is_Acyclic; 720 721 ---------- 722 -- Free -- 723 ---------- 724 725 procedure Free (List : in out Connected_Component_List) is 726 procedure Internal is new Unchecked_Deallocation 727 (Connected_Component, Connected_Component_List); 728 L : Connected_Component_List; 729 begin 730 while List /= null loop 731 L := List.Next; 732 Internal (List); 733 List := L; 734 end loop; 735 end Free; 736 737 ----------------------------------- 738 -- Strongly_Connected_Components -- 739 ----------------------------------- 740 741 function Strongly_Connected_Components (G : Graph) 742 return Connected_Component_List is 743 begin 744 return Strongly_Connected_Components (G, Depth_First_Search (G)); 745 end Strongly_Connected_Components; 746 747 ----------------------------------- 748 -- Strongly_Connected_Components -- 749 ----------------------------------- 750 -- Basically, we do another depth-first search, but on the transpose of 751 -- G (i.e with all edges inverted). 752 753 function Strongly_Connected_Components 754 (G : Graph; DFS : Depth_Vertices_Array) 755 return Connected_Component_List 756 is 757 Colors : Color_Array (0 .. G.Last_Vertex_Index - 1) := (others => White); 758 Result : Vertices_Array (0 .. G.Num_Vertices - 1); 759 Result_Index : Integer := Result'Last; 760 761 procedure Depth_First_Visit (U : Vertex_Access); 762 -- Process the node U 763 764 procedure Depth_First_Visit (U : Vertex_Access) is 765 V : Vertex_Access; 766 Eit : Edge_Iterator; 767 begin 768 Colors (U.Index) := Gray; 769 Eit := First (G, Dest => U); 770 while not At_End (Eit) loop 771 V := Get_Src (Get (Eit)); 772 if V = U then 773 V := Get_Dest (Get (Eit)); 774 end if; 775 776 if Colors (V.Index) = White then 777 -- ??? Would be nice to have a non-recursive implementation, to 778 -- ??? support larger graphs 779 Depth_First_Visit (V); 780 end if; 781 Next (Eit); 782 end loop; 783 Colors (U.Index) := Black; 784 Result (Result_Index) := U; 785 Result_Index := Result_Index - 1; 786 end Depth_First_Visit; 787 788 List : Connected_Component_List := null; 789 begin 790 pragma Assert (G.Directed); 791 for U in DFS'Range loop 792 if Colors (DFS (U).Vertex.Index) = White then 793 Depth_First_Visit (DFS (U).Vertex); 794 List := new Connected_Component' 795 (Num_Vertices => Result'Last - Result_Index, 796 Vertices => Result (Result_Index + 1 .. Result'Last), 797 Next => List); 798 Result_Index := Result'Last; 799 end if; 800 end loop; 801 return List; 802 end Strongly_Connected_Components; 803 804 ------------- 805 -- Kruskal -- 806 ------------- 807 808 function Kruskal (G : Graph) return Edges_Array is 809 Result : Edges_Array (0 .. G.Num_Vertices - 2); 810 Result_Index : Natural := Result'First; 811 Eit : Edge_Iterator; 812 U, V : Vertex_Access; 813 814 Sets : array (0 .. G.Last_Vertex_Index - 1) of Natural; 815 -- This is used to represent the sets that will contain the 816 -- vertices. Probably not the fastest method (the union operation is 817 -- quite slow), but the easiest to implement. 818 819 V_Set : Natural; 820 821 begin 822 -- First put all vertices in their own set 823 for S in Sets'Range loop 824 Sets (S) := S; 825 end loop; 826 827 -- ??? Should sort the edges by increasing weight 828 -- ??? and do the loop in that order 829 830 Eit := First (G, Src => Vertex_Access'(null)); 831 while not At_End (Eit) loop 832 U := Get_Src (Get (Eit)); 833 V := Get_Dest (Get (Eit)); 834 835 if Sets (U.Index) /= Sets (V.Index) then 836 Result (Result_Index) := Get (Eit); 837 Result_Index := Result_Index + 1; 838 839 -- Merge the two sets 840 V_Set := Sets (V.Index); 841 for S in Sets'Range loop 842 if Sets (S) = V_Set then 843 Sets (S) := Sets (U.Index); 844 end if; 845 end loop; 846 end if; 847 848 Next (Eit); 849 end loop; 850 851 return Result; 852 end Kruskal; 853 854 ------------ 855 -- Length -- 856 ------------ 857 858 function Length (List : Edge_List) return Natural is 859 E : Edge_List := List; 860 Count : Natural := 0; 861 begin 862 while E /= null loop 863 Count := Count + 1; 864 E := E.Next; 865 end loop; 866 return Count; 867 end Length; 868 869 --------------- 870 -- In_Degree -- 871 --------------- 872 873 function In_Degree (G : Graph; V : access Vertex'Class) return Natural is 874 pragma Unreferenced (G); 875 begin 876 return Length (V.In_Edges); 877 end In_Degree; 878 879 ---------------- 880 -- Out_Degree -- 881 ---------------- 882 883 function Out_Degree (G : Graph; V : access Vertex'Class) return Natural is 884 pragma Unreferenced (G); 885 begin 886 return Length (V.Out_Edges); 887 end Out_Degree; 888 889 ------------------- 890 -- Move_To_Front -- 891 ------------------- 892 893 procedure Move_To_Front (G : in out Graph; V : access Vertex'Class) is 894 Iter : Vertex_List := G.Vertices; 895 Tmp : Vertex_List; 896 begin 897 -- No or only one item => nothing to do 898 if G.Vertices = null 899 or else G.Vertices.V = Vertex_Access (V) 900 or else G.Vertices.Next = null 901 then 902 return; 903 end if; 904 905 while Iter.Next /= null and then Iter.Next.V /= Vertex_Access (V) loop 906 Iter := Iter.Next; 907 end loop; 908 909 if Iter.Next /= null then 910 Tmp := Iter.Next; 911 Iter.Next := Tmp.Next; 912 Tmp.Next := G.Vertices; 913 G.Vertices := Tmp; 914 end if; 915 end Move_To_Front; 916 917 ------------------ 918 -- Move_To_Back -- 919 ------------------ 920 921 procedure Move_To_Back (G : in out Graph; V : access Vertex'Class) is 922 Iter : Vertex_List; 923 Old : Vertex_List := null; 924 begin 925 if G.Vertices = null or else G.Vertices.Next = null then 926 return; 927 end if; 928 929 if G.Vertices.V = Vertex_Access (V) then 930 Old := G.Vertices; 931 G.Vertices := G.Vertices.Next; 932 end if; 933 934 Iter := G.Vertices; 935 936 while Iter.Next /= null loop 937 if Iter.Next.V = Vertex_Access (V) then 938 Old := Iter.Next; 939 Iter.Next := Old.Next; 940 else 941 Iter := Iter.Next; 942 end if; 943 end loop; 944 945 if Old /= null then 946 Old.Next := null; 947 Iter.Next := Old; 948 end if; 949 end Move_To_Back; 950 951 ----------------- 952 -- Revert_Edge -- 953 ----------------- 954 955 procedure Revert_Edge (G : Graph; E : Edge_Access) is 956 pragma Unreferenced (G); 957 958 Src : constant Vertex_Access := E.Src; 959 Dest : constant Vertex_Access := E.Dest; 960 961 begin 962 Remove (E.Src.Out_Edges, E); 963 Remove (E.Dest.In_Edges, E); 964 E.Src := Dest; 965 E.Dest := Src; 966 Add (E.Src.Out_Edges, E); 967 Add (E.Dest.In_Edges, E); 968 end Revert_Edge; 969 970end Glib.Graphs; 971