Jan 11 16:31 1996 splay_tree_package.ads Page 1 -- Generic Package Specification for Splay_Tree_Package -- -- Requires: -- Instantiated with any private type and -- a "<" function for that type and -- a Put procedure for that type -- Types defined: -- Tree_Ptr private type -- Splay_Tree limited private type -- Exceptions defined: -- Item_Not_Found raised when searches or deletions fail -- Operations defined: -- (* throws Item_Not_Found) -- Initialize and Finalize are defined for Splay_Tree -- Delete * removes item from splay tree -- Find * splays item -- Insert insert item into splay tree -- Make_Empty make splay tree empty -- Print_Tree print splay tree in sorted order -- Retrieve * returns item in root of splay tree with Ada.Finalization; with Text_IO; use Text_IO; generic type Element_Type is private; with function "<" ( Left, Right: Element_Type ) return Boolean; with procedure Put( Element: Element_Type ); package Splay_Tree_Package is type Tree_Ptr is private; type Splay_Tree is new Ada.Finalization.Limited_Controlled with private; procedure Initialize( T: in out Splay_Tree ); procedure Finalize( T: in out Splay_Tree ); procedure Delete( X: Element_Type; T: in out Splay_Tree ); procedure Find( X: Element_Type; T: in out Splay_Tree ); procedure Insert( X: Element_Type; T: in out Splay_Tree ); procedure Make_Empty( T: in out Splay_Tree ); procedure Print_Tree( T: Splay_Tree ); function Retrieve( T: Splay_Tree ) return Element_Type; Item_Not_Found : exception; private type Tree_Node; type Tree_Ptr is access Tree_Node; type Splay_Tree is new Ada.Finalization.Limited_Controlled with record Root : Tree_Ptr; Null_Node : Tree_Ptr; end record; type Tree_Node is record Jan 11 16:31 1996 splay_tree_package.ads Page 2 Element : Element_Type; Left : Tree_Ptr; Right : Tree_Ptr; end record; end Splay_Tree_Package; Jan 11 16:33 1996 splay_tree_package.adb Page 1 -- Implementation of Splay_Tree_Package with Unchecked_Deallocation; package body Splay_Tree_Package is procedure Dispose is new Unchecked_Deallocation( Tree_Node, Tree_Ptr ); function "="( Left, Right: Element_Type ) return Boolean; procedure Splay( X: Element_Type; P: in out Tree_Ptr; The_Null_Node: in out Tree_Ptr ); -- THE VISIBLE ROUTINES procedure Initialize( T: in out Splay_Tree ) is begin T.Null_Node := new Tree_Node; T.Null_Node.Left := T.Null_Node; T.Null_Node.Right := T.Null_Node; T.Root := T.Null_Node; end Initialize; procedure Finalize( T: in out Splay_Tree ) is begin Make_Empty( T ); Dispose( T.Null_Node ); end Finalize; procedure Delete( X: Element_Type; T: in out Splay_Tree ) is New_Tree: Tree_Ptr; begin Find( X, T ); -- Splay X to the root, propogate exception if T.Root.Left = T.Null_Node then New_Tree := T.Root.Right; else -- Find the maximum in the left subtree -- Splay it to the root and then attach right child New_Tree := T.Root.Left; Splay( X, New_Tree, T.Null_Node ); New_Tree.Right := T.Root.Right; end if; Dispose( T.Root ); T.Root := New_Tree; end Delete; procedure Find( X: Element_Type; T: in out Splay_Tree ) is begin Splay( X, T.Root, T.Null_Node ); if T.Root.Element /= X then raise Item_Not_Found; end if; end Find; Jan 11 16:33 1996 splay_tree_package.adb Page 2 New_Node : Tree_Ptr := null; procedure Insert( X: Element_Type; T: in out Splay_Tree ) is begin if New_Node = null then New_Node := new Tree_Node'( X, null, null ); end if; if T.Root = T.Null_node then New_Node.Left := T.Null_Node; New_Node.Right := T.Null_Node; T.Root := New_Node; else Splay( X, T.Root, T.Null_Node ); if X < T.Root.Element then New_Node.Left := T.Root.Left; New_Node.Right := T.Root; T.Root.Left := T.Null_Node; T.Root := New_Node; elsif T.Root.Element < X then New_Node.Right := T.Root.Right; New_Node.Left := T.Root; T.Root.Right := T.Null_Node; T.Root := New_Node; else return; -- Duplicates are ignored end if; end if; New_Node := null; end Insert; procedure Make_Empty( T: in out Splay_Tree ) is procedure Make_Empty( P: in out Tree_Ptr ) is begin if P /= T.Null_Node then Make_Empty( P.Left ); Make_Empty( P.Right ); Dispose( P ); end if; end Make_Empty; begin Make_Empty( T.Root ); end Make_Empty; procedure Print_Tree( T: Splay_Tree ) is procedure Print_Tree( P: Tree_Ptr ) is begin if P /= T.Null_Node then Print_Tree( P.Left ); Put( P.Element ); New_Line; Print_Tree( P.Right ); end if; Jan 11 16:33 1996 splay_tree_package.adb Page 3 end Print_Tree; begin Print_Tree( T.Root ); end Print_Tree; function Retrieve( T: Splay_Tree ) return Element_Type is begin if T.Root = T.Null_Node then raise Item_Not_Found; end if; return T.Root.Element; end Retrieve; -- INTERNAL ROUTINES -- "=" to make tree code look nicer function "="( Left, Right: Element_Type ) return Boolean is begin return not ( Right < Left ) and then not ( Left < Right ); end "="; procedure Rotate_With_Left_Child( K2: in out Tree_Ptr ) is K1 : Tree_Ptr := K2.Left; begin K2.Left := K1.Right; K1.Right := K2; K2 := K1; end Rotate_With_Left_Child; procedure Rotate_With_Right_Child( K1: in out Tree_Ptr ) is K2 : Tree_Ptr := K1.Right; begin K1.Right := K2.Left; K2.Left := K1; K1 := K2; end Rotate_With_Right_Child; Header : Tree_Ptr := new Tree_Node; procedure Splay( X: Element_Type; P: in out Tree_Ptr; The_Null_Node: in out Tree_Ptr ) is Left_Tree_Max : Tree_Ptr := Header; Right_Tree_Min : Tree_Ptr := Header; begin Header.Left := The_Null_Node; Header.Right := The_Null_Node; -- Copy X to Null_Node to guarantee match The_Null_Node.Element := X; loop if X < P.Element then if X < P.Left.Element then Rotate_With_Left_Child( P ); end if; exit when P.Left = The_Null_Node; Jan 11 16:33 1996 splay_tree_package.adb Page 4 -- Link right Right_Tree_Min.Left := P; Right_Tree_Min := P; P := P.Left; elsif P.Element < X then if P.Right.Element < X then Rotate_With_Right_Child( P ); end if; exit when P.Right = The_Null_Node; -- Link left Left_Tree_Max.Right := P; Left_Tree_Max := P; P := P.Right; else exit; end if; end loop; Left_Tree_Max.Right := P.Left; Right_Tree_Min.Left := P.Right; P.Left := Header.Right; P.Right := Header.Left; end Splay; end Splay_Tree_Package; Dec 12 13:53 1995 splay_test.adb Page 1 -- Simple test routine for Splay trees with Splay_Tree_Package; with Ada.Text_IO; use Ada.Text_IO; with Ada.Integer_Text_IO; use Ada.Integer_Text_IO; -- Main procedure starts here procedure Splay_Test is procedure Put_Int( X: Integer ); -- Now we instantiate the search tree package package Int_Tree is new Splay_Tree_Package( Integer, "<", Put_Int ); use Int_Tree; -- Rest of main continues here T : Splay_Tree; J : Integer; P : Tree_Ptr; procedure Put_Int( X: Integer ) is begin Integer_Text_IO.Put( X ); end Put_Int; begin for i in 51..10000 loop Insert( 2*I, T ); Insert( 2*I - 1, T ); end loop; for i in 1 ..100 loop Insert( I, T ); end loop; for I in 1..20000 loop begin Find( I, T ); exception when Item_Not_Found => Put( I ); Put_Line( " : Find failed unexpectedly!" ); end; end loop; -- Put( "Min: " ); Put( Retrieve( Find_Min( T ) ) ); New_Line; -- Put( "Max: " ); Put( Retrieve( Find_Max( T ) ) ); New_Line; for I in 10..19990 loop begin Delete( I, T ); exception when Item_Not_Found => Put( I ); Put_Line( " : Delete failed unexpectedly!" ); end; Dec 12 13:53 1995 splay_test.adb Page 2 end loop; Print_Tree( T ); end Splay_Test; Jan 11 16:35 1996 red_black_tree_package.ads Page 1 -- Generic Package Specification for Red_Black_Tree_Package -- -- Requires: -- Instantiated with any private type and -- a "<" function for that type and -- a Put procedure for that type -- a meaningful value of negative infinity -- Types defined: -- Tree_Ptr private type -- Red_Black_Tree limited private type -- Exceptions defined: -- Item_Not_Found raised when searches or deletions fail -- Operations defined: -- (* throws Item_Not_Found) -- Initialize and Finalize are defined for Red_Black_Tree -- Find * returns Tree_Ptr of item in red black tree -- Find_Max * returns Tree_Ptr of maximum item in red black tree -- Find_Min * returns Tree_Ptr of minimum item in red black tree -- Insert insert item into red black tree -- Make_Empty make red black tree empty -- Print_Tree print red black tree in sorted order -- Retrieve * returns item in Tree_Ptr passed as parameter with Ada.Finalization; with Text_IO; use Text_IO; generic type Element_Type is private; with function "<" ( Left, Right: Element_Type ) return Boolean; with procedure Put( Element: Element_Type ); Negative_Infinity : in Element_Type; package Red_Black_Tree_Package is type Tree_Ptr is private; type Red_Black_Tree is new Ada.Finalization.Limited_Controlled with private; procedure Initialize( T: in out Red_Black_Tree ); procedure Finalize( T: in out Red_Black_Tree ); function Find( X: Element_Type; T: Red_Black_Tree ) return Tree_Ptr; function Find_Min( T: Red_Black_Tree ) return Tree_Ptr; function Find_Max( T: Red_Black_Tree ) return Tree_Ptr; procedure Insert( X: Element_Type; T: in out Red_Black_Tree ); procedure Make_Empty( T: in out Red_Black_Tree ); procedure Print_Tree( T: Red_Black_Tree ); function Retrieve( P: Tree_Ptr ) return Element_Type; Item_Not_Found : exception; private type Color_Type is ( Red, Black ); type Tree_Node; type Tree_Ptr is access Tree_Node; type Red_Black_Tree is new Ada.Finalization.Limited_Controlled with record Jan 11 16:35 1996 red_black_tree_package.ads Page 2 Header : Tree_Ptr; Null_Node : Tree_Ptr; end record; type Tree_Node is record Element : Element_Type; Left : Tree_Ptr; Right : Tree_Ptr; Color : Color_Type := Black; end record; end Red_Black_Tree_Package; Jan 11 16:36 1996 red_black_tree_package.adb Page 1 -- Implementation of Red_Black_Tree_Package with Unchecked_Deallocation; package body Red_Black_Tree_Package is procedure Dispose is new Unchecked_Deallocation( Tree_Node, Tree_Ptr ); function "="( Left, Right: Element_Type ) return Boolean; procedure Rotate( Item: Element_Type; The_Parent: in out Tree_Ptr; The_Current: out Tree_Ptr ); -- THE VISIBLE ROUTINES procedure Initialize( T: in out Red_Black_Tree ) is begin T.Null_Node := new Tree_Node; T.Null_Node.Left := T.Null_Node; T.Null_Node.Right := T.Null_Node; T.Header := new Tree_Node'( Negative_Infinity, T.Null_Node, T.Null_Node, Black ); end Initialize; procedure Finalize( T: in out Red_Black_Tree ) is begin Make_Empty( T ); Dispose( T.Header ); Dispose( T.Null_Node ); end Finalize; function Find( X: Element_Type; T: Red_Black_Tree ) return Tree_Ptr is Current : Tree_Ptr := T.Header.Right; begin while Current /= T.Null_Node loop if X < Current.Element then Current := Current.Left; elsif Current.Element < X then Current := Current.Right; else return Current; end if; end loop; raise Item_Not_Found; end Find; function Find_Min( T: Red_Black_Tree ) return Tree_Ptr is Ptr : Tree_Ptr := T.Header.Right; begin if Ptr = T.Null_Node then raise Item_Not_Found; else while Ptr.Left /= T.Null_Node loop Jan 11 16:36 1996 red_black_tree_package.adb Page 2 Ptr := Ptr.Left; end loop; end if; return Ptr; end Find_Min; function Find_Max( T: Red_Black_Tree ) return Tree_Ptr is Ptr : Tree_Ptr := T.Header.Right; begin if Ptr = T.Null_Node then raise Item_Not_Found; else while Ptr.Right /= T.Null_Node loop Ptr := Ptr.Right; end loop; end if; return Ptr; end Find_Max; procedure Insert( X: Element_Type; T: in out Red_Black_Tree )is Current : Tree_Ptr := T.Header; Parent : Tree_Ptr := T.Header; Grand : Tree_Ptr := T.Header; Great : Tree_Ptr; procedure Handle_Reorient( Item: Element_Type ) is begin Current.Color := Red; Current.Left.Color := Black; Current.Right.Color := Black; if Parent.Color = Red then -- Have to rotate Grand.Color := Red; if ( Item < Grand.Element ) /= ( Item < Parent.Element ) then Rotate( Item, Grand, Parent ); end if; Rotate( Item, Great, Current ); Current.Color := Black; end if; T.Header.Right.Color := Black; -- Back root black end Handle_Reorient; begin -- Top down pass T.Null_Node.Element := X; while Current.Element /= X loop Great := Grand; Grand := Parent; Parent := Current; if X < Current.Element then Current := Current.Left; else Current := Current.Right; Jan 11 16:36 1996 red_black_tree_package.adb Page 3 end if; if Current.Left.Color = Red and then Current.Right.Color = Red then Handle_Reorient( X ); end if; end loop; if Current = T.Null_Node then Current := new Tree_Node'( X, T.Null_Node, T.Null_Node, Red ); if X < Parent.Element then Parent.Left := Current; else Parent.Right := Current; end if; Handle_Reorient( X ); end if; end Insert; procedure Make_Empty( T: in out Red_Black_Tree ) is procedure Make_Empty( P: in out Tree_Ptr ) is begin if P /= T.Null_Node then Make_Empty( P.Left ); Make_Empty( P.Right ); Dispose( P ); end if; end Make_Empty; begin Make_Empty( T.Header.Right ); T.Header.Right := T.Null_Node; end Make_Empty; procedure Print_Tree( T: Red_Black_Tree ) is procedure Print_Tree( P: Tree_Ptr ) is begin if P /= T.Null_Node then Print_Tree( P.Left ); Put( P.Element ); New_Line; Print_Tree( P.Right ); end if; end Print_Tree; begin Print_Tree( T.Header.Right ); end Print_Tree; function Retrieve( P: Tree_Ptr ) return Element_Type is begin return P.Element; end Retrieve; -- INTERNAL ROUTINES -- "=" to make tree code look nicer function "="( Left, Right: Element_Type ) return Boolean is begin return not( Right < Left ) and then not( Left < Right ); end "="; Jan 11 16:36 1996 red_black_tree_package.adb Page 4 procedure Rotate_With_Left_Child( K2: in out Tree_Ptr ) is K1 : Tree_Ptr := K2.Left; begin K2.Left := K1.Right; K1.Right := K2; K2 := K1; end Rotate_With_Left_Child; procedure Rotate_With_Right_Child( K1: in out Tree_Ptr ) is K2 : Tree_Ptr := K1.Right; begin K1.Right := K2.Left; K2.Left := K1; K1 := K2; end Rotate_With_Right_Child; procedure Rotate( Item: Element_Type; The_Parent: in out Tree_Ptr; The_Current: out Tree_Ptr ) is begin if Item < The_Parent.Element then if Item < The_Parent.Left.Element then Rotate_With_Left_Child( The_Parent.Left ); else Rotate_With_Right_Child( The_Parent.Left ); end if; The_Current := The_Parent.Left; else if Item < The_Parent.Right.Element then Rotate_With_Left_Child( The_Parent.Right ); else Rotate_With_Right_Child( The_Parent.Right ); end if; The_Current := The_Parent.Right; end if; end Rotate; end Red_Black_Tree_Package; Dec 12 15:54 1995 red_black_test.adb Page 1 -- Simple test routine for Red_Black trees with Red_Black_Tree_Package; with Ada.Text_IO; use Ada.Text_IO; with Ada.Integer_Text_IO; use Ada.Integer_Text_IO; -- Main procedure starts here procedure Red_Black_Test is procedure Put_Int( X: Integer ); -- Now we instantiate the search tree package package Int_Tree is new Red_Black_Tree_Package( Integer, "<", Put_Int, Integer'First ); use Int_Tree; -- Rest of main continues here T : Red_Black_Tree; J : Integer; P : Tree_Ptr; procedure Put_Int( X: Integer ) is begin Integer_Text_IO.Put( X ); end Put_Int; begin for i in 51..10000 loop Insert( 2*I, T ); Insert( 2*I - 1, T ); end loop; for i in 1 ..100 loop Insert( I, T ); end loop; for I in 1..20000 loop begin P := Find( I, T ); exception when Item_Not_Found => Put( I ); Put_Line( " : Find failed unexpectedly!" ); end; end loop; Put( "Min: " ); Put( Retrieve( Find_Min( T ) ) ); New_Line; Put( "Max: " ); Put( Retrieve( Find_Max( T ) ) ); New_Line; Make_Empty( T ); Put_Line( "Finished Make_Empty" ); Print_Tree( T ); Dec 12 15:54 1995 red_black_test.adb Page 2 Put_Line( "Finished Print_Tree" ); Insert( 8, T ); Insert( 1, T ); Insert( 6, T ); Insert( 2, T ); Insert( 4, T ); Insert( 3, T ); Insert( 9, T ); Insert( 5, T ); Insert( 7, T ); Insert( 10, T ); -- for I in 10..19990 loop -- begin -- Delete( I, T ); -- exception -- when Item_Not_Found => -- Put( I ); Put_Line( " : Delete failed unexpectedly!" ); -- end; -- end loop; Print_Tree( T ); end Red_Black_Test; Jan 11 16:37 1996 aa_tree_package.ads Page 1 -- Generic Package Specification for AA_Tree_Package -- -- Requires: -- Instantiated with any private type and -- a "<" function for that type and -- a Put procedure for that type -- Types defined: -- Tree_Ptr private type -- AA_Tree limited private type -- Exceptions defined: -- Item_Not_Found raised when searches or deletions fail -- Operations defined: -- (* throws Item_Not_Found) -- Initialize and Finalize are defined for AA_Tree -- Delete * removes item from AA tree -- Find * returns Tree_Ptr of item in AA tree -- Find_Max * returns Tree_Ptr of maximum item in AA tree -- Find_Min * returns Tree_Ptr of minimum item in AA tree -- Insert insert item into AA tree -- Make_Empty make an AA tree empty -- Print_Tree print AA tree in sorted order -- Retrieve * returns item in Tree_Ptr passed as parameter with Ada.Finalization; with Text_IO; use Text_IO; generic type Element_Type is private; with function "<" ( Left, Right: Element_Type ) return Boolean; with procedure Put( Element: Element_Type ); package AA_Tree_Package is type Tree_Ptr is private; type AA_Tree is new Ada.Finalization.Limited_Controlled with private; procedure Initialize( T: in out AA_Tree ); procedure Finalize( T: in out AA_Tree ); procedure Delete( X: Element_Type; T: in out AA_Tree ); function Find( X: Element_Type; T: AA_Tree ) return Tree_Ptr; function Find_Min( T: AA_Tree ) return Tree_Ptr; function Find_Max( T: AA_Tree ) return Tree_Ptr; procedure Insert( X: Element_Type; T: in out AA_Tree ); procedure Make_Empty( T: in out AA_Tree ); procedure Print_Tree( T: AA_Tree ); function Retrieve( P: Tree_Ptr ) return Element_Type; Item_Not_Found : exception; private type Tree_Node; type Tree_Ptr is access Tree_Node; type AA_Tree is new Ada.Finalization.Limited_Controlled with record Root : Tree_Ptr; Null_Node : Tree_Ptr; Jan 11 16:37 1996 aa_tree_package.ads Page 2 end record; type Tree_Node is record Element : Element_Type; Left : Tree_Ptr; Right : Tree_Ptr; Level : Integer; end record; end AA_Tree_Package; Jan 11 16:37 1996 aa_tree_package.adb Page 1 -- Implementation of AA_Tree_Package with Unchecked_Deallocation; package body AA_Tree_Package is procedure Dispose is new Unchecked_Deallocation( Tree_Node, Tree_Ptr ); function "="( Left, Right: Element_Type ) return Boolean; procedure Skew( P: in out Tree_Ptr ); procedure Split( P: in out Tree_Ptr ); -- THE VISIBLE ROUTINES procedure Initialize( T: in out AA_Tree ) is begin T.Null_Node := new Tree_Node; T.Null_Node.Left := T.Null_Node; T.Null_Node.Right := T.Null_Node; T.Null_Node.Level := 0; T.Root := T.Null_Node; end Initialize; procedure Finalize( T: in out AA_Tree ) is begin Make_Empty( T ); Dispose( T.Null_Node ); end Finalize; procedure Delete( X: Element_Type; T: in out AA_Tree ) is Delete_Ptr : Tree_Ptr; Last_Ptr : Tree_Ptr; procedure Delete( X: Element_Type; P: in out Tree_Ptr ) is begin if P /= T.Null_Node then -- Search down the tree and set Last_Ptr and Delete_Ptr Last_Ptr := P; if X < P.Element then Delete( X, P.Left ); else Delete_Ptr := P; Delete( X, P.Right ); end if; -- If at bottom of the tree and X is present, remove it if P = Last_Ptr then if Delete_Ptr /= T.Null_Node and then X = Delete_Ptr.Element then Delete_Ptr.Element := P.Element; Delete_Ptr := T.Null_Node; P := P.Right; Dispose( Last_Ptr ); else Jan 11 16:37 1996 aa_tree_package.adb Page 2 raise Item_Not_Found; end if; -- Otherwise, we are not at the bottom; rebalance else if P.Left.Level < P.Level - 1 or else P.Right.Level < P.Level - 1 then P.Level := P.Level - 1; if P.Right.Level > P.Level then P.Right.Level := P.Level; end if; Skew( P ); Skew( P.Right ); Skew( P.Right.Right ); Split( P ); Split( P.Right ); end if; end if; end if; -- P /= T.Null_Node end Delete; -- Recursive routine begin Delete( X, T.Root ); end Delete; function Find( X: Element_Type; T: AA_Tree ) return Tree_Ptr is Current : Tree_Ptr := T.Root; begin while Current /= T.Null_Node loop if X < Current.Element then Current := Current.Left; elsif Current.Element < X then Current := Current.Right; else return Current; end if; end loop; raise Item_Not_Found; end Find; function Find_Min( T: AA_Tree ) return Tree_Ptr is Ptr : Tree_Ptr := T.Root; begin if Ptr = T.Null_Node then raise Item_Not_Found; else while Ptr.Left /= T.Null_Node loop Ptr := Ptr.Left; end loop; end if; return Ptr; end Find_Min; Jan 11 16:37 1996 aa_tree_package.adb Page 3 function Find_Max( T: AA_Tree ) return Tree_Ptr is Ptr : Tree_Ptr := T.Root; begin if Ptr = T.Null_Node then raise Item_Not_Found; else while Ptr.Right /= T.Null_Node loop Ptr := Ptr.Right; end loop; end if; return Ptr; end Find_Max; procedure Insert( X: Element_Type; T: in out AA_Tree )is procedure Insert( X: Element_Type; P: in out Tree_Ptr )is begin if P = T.Null_Node then P := new Tree_Node'( X, T.Null_Node, T.Null_Node, 0 ); elsif X < P.Element then Insert( X, P.Left ); elsif P.Element < X then Insert( X, P.Right ); else return; -- Do nothing for duplicates end if; Skew( P ); Split ( P ); end Insert; begin Insert( X, T.Root ); end Insert; procedure Make_Empty( T: in out AA_Tree ) is procedure Make_Empty( P: in out Tree_Ptr ) is begin if P /= T.Null_Node then Make_Empty( P.Left ); Make_Empty( P.Right ); Dispose( P ); end if; end Make_Empty; begin Make_Empty( T.Root ); T.Root.Left := T.Null_Node; T.Root.Right := T.Null_Node; end Make_Empty; procedure Print_Tree( T: AA_Tree ) is procedure Print_Tree( P: Tree_Ptr ) is begin if P /= T.Null_Node then Print_Tree( P.Left ); Jan 11 16:37 1996 aa_tree_package.adb Page 4 Put( P.Element ); New_Line; Print_Tree( P.Right ); end if; end Print_Tree; begin Print_Tree( T.Root ); end Print_Tree; function Retrieve( P: Tree_Ptr ) return Element_Type is begin return P.Element; end Retrieve; -- INTERNAL ROUTINES -- "=" to make tree code look nicer function "="( Left, Right: Element_Type ) return Boolean is begin return not( Right < Left ) and then not( Left < Right ); end "="; procedure Rotate_With_Left_Child( K2: in out Tree_Ptr ) is K1 : Tree_Ptr := K2.Left; begin K2.Left := K1.Right; K1.Right := K2; K2 := K1; end Rotate_With_Left_Child; procedure Rotate_With_Right_Child( K1: in out Tree_Ptr ) is K2 : Tree_Ptr := K1.Right; begin K1.Right := K2.Left; K2.Left := K1; K1 := K2; end Rotate_With_Right_Child; procedure Skew( P: in out Tree_Ptr ) is begin if P.Left.Level = P.Level then Rotate_With_Left_Child( P ); end if; end Skew; procedure Split( P: in out Tree_Ptr ) is begin if P.Right.Right.Level = P.Level then Rotate_With_Right_Child( P ); P.Level := P.Level + 1; end if; end Split; end AA_Tree_Package; Dec 12 12:49 1995 aa_test.adb Page 1 -- Simple test routine for AA trees with AA_Tree_Package; with Ada.Text_IO; use Ada.Text_IO; with Ada.Integer_Text_IO; use Ada.Integer_Text_IO; -- Main procedure starts here procedure AA_Test is procedure Put_Int( X: Integer ); -- Now we instantiate the search tree package package Int_Tree is new AA_Tree_Package( Integer, "<", Put_Int ); use Int_Tree; -- Rest of main continues here T : AA_Tree; J : Integer; P : Tree_Ptr; procedure Put_Int( X: Integer ) is begin Integer_Text_IO.Put( X ); end Put_Int; begin for i in 51..10000 loop Insert( 2*I, T ); Insert( 2*I - 1, T ); end loop; for i in 1 ..100 loop Insert( I, T ); end loop; for I in 1..20000 loop begin P := Find( I, T ); exception when Item_Not_Found => Put( I ); Put_Line( " : Find failed unexpectedly!" ); end; end loop; Put( "Min: " ); Put( Retrieve( Find_Min( T ) ) ); New_Line; Put( "Max: " ); Put( Retrieve( Find_Max( T ) ) ); New_Line; for I in 10..19990 loop begin Delete( I, T ); exception when Item_Not_Found => Put( I ); Put_Line( " : Delete failed unexpectedly!" ); end; end loop; Dec 12 12:49 1995 aa_test.adb Page 2 Print_Tree( T ); end AA_Test; Jan 11 16:38 1996 pairing_heap.ads Page 1 -- Generic Package Specification for Pairing_Heap -- Implements a priority queue -- Requires: -- Instantiated with any private type and -- ">" function defined for that type and -- a value of negative infinity for that type -- Types defined: -- Position private type -- Priority_Queue limited private type -- Exceptions defined: -- Bad_Decresae_Key raised for illegal Drecrease_Key -- Underflow raised for Delete_Min or Find_Min -- on empty priority queue -- Operations defined: -- Initialize and Finalize are defined -- Decrease_Key lower value of item in given position -- Delete_Min delete and show minimum element in priority queue -- Find_Min return minimum element in priority queue -- Insert add a new element to priority queue; return position -- Is_Empty returns true if priority queue is empty -- Is_Full returns true if priority queue is full -- Make_Empty make a priority queue empty with Ada.Finalization; generic type Element_Type is private; with function ">" ( Left, Right: Element_Type ) return Boolean; package Pairing_Heap is type Position is private; type Priority_Queue is new Ada.Finalization.Limited_Controlled with private; procedure Decrease_Key( P: Position; New_Value: Element_Type; H: in out Priority_Queue ); procedure Delete_Min ( X: out Element_Type; H: in out Priority_Queue ); function Find_Min ( H: Priority_Queue ) return Element_Type; procedure Insert ( X: Element_Type; H: in out Priority_Queue; P: out Position ); function Is_Empty ( H: Priority_Queue ) return Boolean; function Is_Full ( H: Priority_Queue ) return Boolean; procedure Make_Empty( H: in out Priority_Queue ); Bad_Decrease_Key : exception; Underflow: exception; private type Pair_Node; type Position is access Pair_Node; type Pair_Node is record Element : Element_Type; Left_Child : Position; Next_Sibling : Position; Prev : Position; end record; type Priority_Queue is new Ada.Finalization.Limited_Controlled with record Jan 11 16:38 1996 pairing_heap.ads Page 2 Current_Size : Natural := 0; Root : Position; end record; end Pairing_Heap; Dec 12 19:15 1995 pairing_heap.adb Page 1 -- Implementation of Pairing_Heap with Unchecked_Deallocation; package body Pairing_Heap is procedure Dispose is new Unchecked_Deallocation( Pair_Node, Position ); function Combine_Siblings( The_First_Sibling: Position; Max_Size: Integer) return Position; procedure Compare_And_Link( First : in out Position; Second : Position ); procedure Decrease_Key( P: Position; New_Value: Element_Type; H: in out Priority_Queue ) is begin if New_Value > P.Element then raise Bad_Decrease_Key; end if; P.Element := New_Value; if P /= H.Root then if P.Next_Sibling /= null then P.Next_Sibling.Prev := P.Prev; end if; if P.Prev.Left_Child = P then P.Prev.Left_Child := P.Next_Sibling; else P.Prev.Next_Sibling := P.Next_Sibling; end if; P.Next_Sibling := null; Compare_And_Link( H.Root, P ); end if; end Decrease_Key; -- Remove minimum item from Priority_Queue H -- Place it in X; raise Item_Not_Found if empty procedure Delete_Min( X: out Element_Type; H: in out Priority_Queue ) is Old_Root : Position := H.Root; begin if Is_Empty( H ) then raise Underflow; end if; X := H.Root.Element; if H.Root.Left_Child = null then H.Root := null; else H.Root := Combine_Siblings( H.Root.Left_Child, H.Current_Size ); end if; Dispose( Old_Root ); H.Current_Size := H.Current_size - 1; end Delete_Min; -- Return minimum item in Priority_Queue H -- Raise Item_Not_Found if empty function Find_Min( H: Priority_Queue ) return Element_Type is Dec 12 19:15 1995 pairing_heap.adb Page 2 begin if Is_Empty( H ) then raise Underflow; else return H.Root.Element; end if; end Find_Min; -- Return true if Priority_Queue H is empty, false otherwise function Is_Empty( H : Priority_Queue ) return Boolean is begin return H.Current_Size = 0; end Is_Empty; -- Return true if Priority_Queue H is full, false otherwise -- In this implementation, H is never full function Is_Full( H : Priority_Queue ) return Boolean is begin return false; end Is_Full; -- Insert item X into priority queue H -- Uses the fact that H.Element( 0 ) is the sentinel Min_Element -- Raises Over_Flow if already full procedure Insert( X: Element_Type; H: in out Priority_Queue; P: out Position ) is New_Node : Position := new Pair_Node'( X, null, null, null ); begin H.Current_Size := H.Current_Size + 1; if H.Root = null then H.Root := New_Node; else Compare_And_Link( H.Root, New_Node ); end if; P := New_Node; end Insert; -- Make priority queue H empty procedure Make_Empty( H: in out Priority_Queue ) is procedure Make_Empty( P: in out Position ) is begin if P /= null then Make_Empty( P.Left_Child ); Make_Empty( P.Next_Sibling ); Dispose( P ); end if; end Make_Empty; begin Make_Empty( H.Root ); H.Current_Size := 0; H.Root := null; end Make_Empty; function Combine_Siblings( The_First_Sibling: Position; Max_Size: Integer ) Dec 12 19:15 1995 pairing_heap.adb Page 3 return Position is type Array_Of_Position is array( Integer range <> ) of Position; Tree_Array : Array_Of_Position( 1..Max_Size ); Num_Siblings : Integer := 1; First_Sibling : Position := The_First_Sibling; I : Integer := 1; J : Integer; begin if First_Sibling.Next_Sibling = null then return First_Sibling; end if; while First_Sibling /= null loop Tree_Array( Num_Siblings ) := First_Sibling; First_Sibling.Prev.Next_Sibling := null; -- break links First_Sibling := First_Sibling.Next_Sibling; Num_Siblings := Num_Siblings + 1; end loop; Tree_Array( Num_Siblings ) := null; -- Combine the subtrees two at a time, going left to right while I < Num_Siblings loop Compare_And_Link( Tree_Array( i ), Tree_Array( i + 1 ) ); I := I + 2; end loop; J := I - 2; -- J has the result of the last Compare_And_Link -- If an odd number of trees, get the last one if J = Num_Siblings - 2 then Compare_And_Link( Tree_Array( J ), Tree_Array( J + 2 ) ); end if; -- Now go right to left, merging last tree with -- next to last. The result becomes the new last. while J >= 3 loop Compare_And_Link( Tree_Array( J - 2 ), Tree_Array( J ) ); J := J - 2; end loop; return Tree_Array( 1 ); end Combine_Siblings; procedure Compare_And_Link( First : in out Position; Second : Position ) is begin if Second = null then return; end if; if First.Element > Second.Element then -- Attach First as leftmost child of Second Second.Prev := First.Prev; First.Prev := Second; First.Next_Sibling := Second.Left_Child; if First.Next_Sibling /= null then Dec 12 19:15 1995 pairing_heap.adb Page 4 First.Next_Sibling.Prev := First; end if; Second.Left_Child := First; First := Second; -- Second becomes new root else -- Atttach second as leftmost child of first Second.Prev := First; First.Next_Sibling := Second.Next_Sibling; if First.Next_Sibling /= null then First.Next_Sibling.Prev := First; end if; Second.Next_Sibling := First.Left_Child; if Second.Next_Sibling /= null then Second.Next_Sibling.Prev := Second; end if; First.Left_Child := Second; end if; end Compare_And_Link; end Pairing_Heap; Dec 12 19:18 1995 pair_test.adb Page 1 -- Pairing_Heap test routine with Pairing_Heap; with Ada.Text_IO, Ada.Integer_Text_IO; use Ada.Text_IO, Ada.Integer_Text_IO; procedure Pair_Test is package Heap is new Pairing_Heap( Integer, ">" ); use Heap; Queue_Of_Integers: Priority_Queue; Top_E : Integer; J : Integer := 1; P : Position; begin for Loop_Counter in reverse 10_001..20_000 loop Insert( Loop_Counter, Queue_Of_Integers, P ); Decrease_Key( P, Loop_Counter - 10_000, Queue_Of_Integers ); end loop; while not Is_Empty( Queue_Of_Integers ) loop Delete_Min( Top_E, Queue_Of_Integers ); if Top_E /= J then Put_Line( "Oops!!" ); end if; J := J + 1; end loop; Delete_Min( Top_E, Queue_Of_Integers ); exception when Underflow => Put_Line( "Underflow" ); end Pair_Test;