Source code in the ada programming language

generic
   type Data is private;
package Bin_Trees is

   type Tree_Type is private;

   function Empty(Tree: Tree_Type) return Boolean;
   function Left (Tree: Tree_Type) return Tree_Type;
   function Right(Tree: Tree_Type) return Tree_Type;
   function Item (Tree: Tree_Type) return Data;
   function Empty return Tree_Type;

   procedure Destroy_Tree(N: in out Tree_Type);
   function Tree(Value: Data) return Tree_Type;
   function Tree(Value: Data; Left, Right : Tree_Type) return Tree_Type;

private

   type Node;
   type Tree_Type is access Node;
   type Node is record
      Left, Right: Tree_Type := null;
      Item: Data;
   end record;

end Bin_Trees;


with Ada.Unchecked_Deallocation;

package body Bin_Trees is

   function Empty(Tree: Tree_Type) return Boolean is
   begin
      return Tree = null;
   end Empty;

   function Empty return Tree_Type is
   begin
      return null;
   end Empty;

   function Left (Tree: Tree_Type) return Tree_Type is
   begin
      return Tree.Left;
   end Left;

   function Right(Tree: Tree_Type) return Tree_Type is
   begin
      return Tree.Right;
   end Right;

   function Item (Tree: Tree_Type) return Data is
   begin
      return Tree.Item;
   end Item;

   procedure Destroy_Tree(N: in out Tree_Type) is
      procedure free is new Ada.Unchecked_Deallocation(Node, Tree_Type);
   begin
      if not Empty(N) then
         Destroy_Tree(N.Left);
         Destroy_Tree(N.Right);
         Free(N);
      end if;
   end Destroy_Tree;

   function Tree(Value: Data; Left, Right : Tree_Type) return Tree_Type is
      Temp : Tree_Type := new Node;
   begin
      Temp.all := (Left, Right, Value);
      return Temp;
   end Tree;

   function Tree(Value: Data) return Tree_Type is
   begin
      return Tree(Value, null, null);
   end Tree;

end Bin_Trees;


   generic
      with procedure Process_Data(Item: Data);
      with function Stop return Boolean;
      with procedure Finish;
   package Bin_Trees.Traverse is
      task Inorder_Task is
         entry Run(Tree: Tree_Type);
         -- this will call each Item in Tree and, at the very end, it will call Finish
         -- except when Stop becomes true; in this case, the task terminates
      end Inorder_Task;
   end Bin_Trees.Traverse;


   package body Bin_Trees.Traverse is
      task body Inorder_Task is
         procedure Inorder(Tree: Tree_Type) is
         begin
            if not Empty(Tree) and not Stop then
               Inorder(Tree.Left);
               if not Stop then
                  Process_Data(Item => Tree.Item);
               end if;
               if (not Stop) then
                  Inorder(Tree.Right);
               end if;
            end if;
         end Inorder;
         T: Tree_Type;
      begin
         accept Run(Tree: Tree_Type) do
            T := Tree;
         end Run;
         Inorder(T);
         Finish;
      end Inorder_Task;
   end Bin_Trees.Traverse;


with Ada.Text_IO, Bin_Trees.Traverse;

procedure Main is

   package B_Trees is new Bin_Trees(Character); use B_Trees;

   function Same_Fringe(T1, T2: Tree_Type) return Boolean is

      protected type Buffer_Type is
         entry Write(Item: Character);
         entry Write_Done;
         entry Read_And_Compare(Item: Character);
         entry Read_Done;
         entry Wait_For_The_End;
         function Early_Abort return Boolean;
         function The_Same return Boolean;
      private
         Current: Character;
         Readable: Boolean := False;
         Done: Boolean := False;
         Same: Boolean := True;
         Finished: Boolean := False;
      end Buffer_Type;

      protected body Buffer_Type is

         entry Write(Item: Character) when not Readable is
         begin
            Readable := True;
            Current  := Item;
         end Write;

         entry Write_Done when not Readable is
         begin
            Readable := True;
            Done     := True;
         end Write_Done;

         entry Read_And_Compare(Item: Character) when Readable is
         begin
            if Done then -- Producer is already out of items
               Same := False;
               Finished := True;
               -- Readable remains True, else Consumer might lock itself out
            elsif
              Item /= Current then
               Same := False;
               Finished := True;
               Readable := False;
            else
                 Readable := False;
            end if;
         end Read_And_Compare;

         entry Read_Done when Readable is
         begin
            Readable := False;
            Same     := Same and Done;
            Finished := True;
         end Read_Done;

         entry Wait_For_The_End when (Finished) or (not Same) is
         begin
            null; -- "when ..." is all we need
         end Wait_For_The_End;

         function The_Same return Boolean is
         begin
            return Same;
         end The_Same;

         function Early_Abort return Boolean is
         begin
            return not The_Same or Finished;
         end Early_Abort;

      end Buffer_Type;

      Buffer: Buffer_Type;

      -- some wrapper subprogram needed to instantiate the generics below

          procedure Prod_Write(Item: Character) is
          begin
             Buffer.Write(Item);
          end Prod_Write;

          function Stop return Boolean is
          begin
             return Buffer.Early_Abort;
          end Stop;

          procedure Prod_Stop is
          begin
             Buffer.Write_Done;
          end Prod_Stop;

          procedure Cons_Write(Item: Character) is
          begin
             Buffer.Read_And_Compare(Item);
          end Cons_Write;

          procedure Cons_Stop is
          begin
             Buffer.Read_Done;
          end Cons_Stop;

      package Producer is new B_Trees.Traverse(Prod_Write, Stop, Prod_Stop);
      package Consumer is new B_Trees.Traverse(Cons_Write, Stop, Cons_Stop);

   begin
      Producer.Inorder_Task.Run(T1);
      Consumer.Inorder_Task.Run(T2);
      Buffer.Wait_For_The_End;
      return Buffer.The_Same;
   end Same_Fringe;

   procedure Show_Preorder(Tree: Tree_Type; Prefix: String := "") is
      use Ada.Text_IO;
   begin
      if Prefix /= "" then
         Ada.Text_IO.Put(Prefix);
      end if;
      if not Empty(Tree) then
         Put("(" & Item(Tree));      Put(", ");
         Show_Preorder(Left(Tree));  Put(", ");
         Show_Preorder(Right(Tree)); Put(")");
      end if;
      if Prefix /= "" then
         New_Line;
      end if;
   end Show_Preorder;

   T_0: Tree_Type := Tree('a', Empty, Tree('b'));
   T: array(1 .. 5) of Tree_Type;

begin
   T(1) := Tree('d', Tree('c'), T_0);
   T(2)  := Tree('c', Empty, Tree('a', Tree('d'), Tree('b')));
   T(3)  := Tree('e', T(1), T(2));
   T(4)  := Tree('e', T(2), T(1));
   T(5)  := Tree('e', T_0, Tree('c', Tree('d'), T(1)));

   -- First display the trees you have (in preorder)
   for I in T'Range loop
      Show_Preorder(T(I), "Tree(" & Integer'Image(I) & " ) is ");
   end loop;
   Ada.Text_IO.New_Line;

   -- Now compare them, which have the same fringe?
   for I in T'Range loop
      for J in T'Range loop
         if Same_Fringe(T(J), T(I)) then
            Ada.Text_IO.Put("same(");
         else
            Ada.Text_IO.Put("DIFF(");
         end if;
         Ada.Text_IO.Put(Integer'Image(I) & "," & Integer'Image(J) & " ); ");
      end loop;
      Ada.Text_IO.New_Line;
   end loop;
end Main;