--  Program 2   May 2024



--  Sylvan Sorter 

-- This program is identical to that in Programming in Ada 2022
-- except for the added comments.


package Lists is

   -- This package declares facilities for manipulating lists of
   -- integer values.
   --    A list is represented by a value of the named type List. 
   -- This is an access to a Cell. The type Cell contains a 
   -- component Next which is of the anonymous type access Cell.
   -- An incomplete type is unnecessary.
   --    The subprograms Clear, Make_List and Append can be used
   -- to construct a list.
   --    The procedure Take_From_List decomposes a list into the
   -- value of its first element and the remainder of the list.  It
   -- is a precondition of Take_From_List that the parameter L is
   -- not null.  This condition can be checked for by calling the
   -- function Is_Empty.  However, in Ada 2022 it would be better
   -- to add a precondition so that the specification of 
   -- Take_From_List would be
   -- procedure Take_From_List(L: in out List: V: out Integer)
   --    with Pre => not Is_Empty(L);

   type List is private;

   function Is_Empty(L: List) return Boolean;
   procedure Clear(L: out List);
   function Make_List(V: Integer) return List;
   procedure Take_From_List(L: in out List; V: out Integer);
   procedure Append(First: in out List; Second: in List);

private

   type Cell is
      record
         Next: access Cell;
         Value: Integer;
      end record;

    type List is access all Cell;

end;

package body Lists is

   function Is_Empty(L: List) return Boolean is
      -- Test state of list.
   begin
      return L = null;
   end Is_Empty;

   procedure Clear(L: out List) is
      -- Make an empty list.
   begin
      L := null;
   end Clear;

   function Make_List(V: Integer) return List is
      -- Make a list of one element.
   begin
      return new Cell'(null, V);
   end Make_List;

   procedure Take_From_List(L: in out List; V: out Integer) is
      -- It is a precondition that the list L is not null.
      -- Note the conversion required to convert the component https://url.uk.m.mimecastprotect.com/s/I3p7CL866TRp3N7YfPiEiV?domain=l.next
      -- which is of an anonymous type to the named type List
   begin
      V := L.Value;
      L := List(https://url.uk.m.mimecastprotect.com/s/I3p7CL866TRp3N7YfPiEiV?domain=l.next);
   end Take_From_List;

   procedure Append(First: in out List; Second: in List) is
      -- Appends the Second list to the end of the First List. Note
      -- that the case when the First list is null has to
      -- be treated separately.
      -- The variable Local is of an anonymous type rather than of 
      -- the type List. No conversions are then required. The 
      -- argument is that we are just working down the list and it 
      -- is the internal view that matters.

      Local: access Cell := First; 
   begin
      if First = null then
         First := Second;
      else
         while https://url.uk.m.mimecastprotect.com/s/q3RfCMQDDfq0Jx76fWtdZh?domain=local.next /= null loop
            Local := Local.Next;  
         end loop;
         https://url.uk.m.mimecastprotect.com/s/q3RfCMQDDfq0Jx76fWtdZh?domain=local.next := Second;
      end if;
   end Append;

end Lists;

package Trees is

   -- This package declares facilities for the manipulation of
   -- binary trees whose elements are integer values.
   --    A tree is represented by a value of the type Tree which
   -- is simply an access type referring to a Node. The type Node
   -- contains components of type Tree. This structure requires an
   -- incomplete type declaration for Node but there are no 
   -- anonymous access types. If we had used the same style as for
   -- the type List then many conversions would be required in
   -- the various subprograms.
   --    The subprograms Clear and Insert can be used to construct
   -- a tree.
   --    The functions Left_Subtree, Right_Subtree and Node_Value
   -- return the two subtrees of the binary tree and the value at
   -- the root node respectively. It is a precondition of these
   -- functions that the parameter T is not null.  This condition
   -- can be checked for by calling the function Is_Empty.

   
   type Tree is private;

   function Is_Empty(T: Tree) return Boolean;
   procedure Clear(T: out Tree);
   procedure Insert(T: in out Tree; V: in Integer);
   function Depth(T: Tree) return Integer;
   function Left_Subtree(T: Tree) return Tree;
   function Right_Subtree(T: Tree) return Tree;
   function Node_Value(T: Tree) return Integer;

private

   type Node;                       -- incomplete type
   type Tree is access Node;
   type Node is
      record
         Left, Right: Tree;
         Value: Integer;
      end record;
end;

package body Trees is

   function Is_Empty(T: Tree) return Boolean is
   begin
      return T = null;
   end Is_Empty;

   procedure Clear(T: out Tree) is
   begin
      T := null;
   end Clear;

   procedure Insert(T: in out Tree; V: in Integer) is
      -- Adds a new node to the tree containing the value V.  If
      -- the tree was originally null then this value goes at the
      -- newly created root node. Otherwise it compares the new
      -- value with that at the root node and inserts it into the
      -- left subtree if it is less than that at the root node and 
      -- inserts it into the right subtree otherwise.
   begin
      if T = null then
         T := new Node'(null, null, V);
      elsif V < T.Value then
         Insert(T.Left, V); 
      else
         Insert(T.Right, V);
      end if;
   end Insert;

   function Depth(T: Tree) return Integer is
      -- Returns the depth of the tree which is zero if the
      -- tree is empty and otherwise is one more than the 
      -- maximum of the depths of the two subtrees.
   begin
      if T = null then return 0; end if;
      return 1 + Integer'Max(Depth(T.Left), Depth(T.Right)); 
   end Depth;

   function Left_Subtree(T: Tree) return Tree is
      -- It is a precondition that the tree T is not null.
   begin
      return T.Left;
   end Left_Subtree;

   function Right_Subtree(T: Tree) return Tree is
      -- It is a precondition that the tree T is not null.
   begin
      return T.Right; 
   end Right_Subtree;

   function Node_Value(T: Tree) return Integer is
      -- It is a precondition that the tree T is not null.
   begin
      return T.Value;
   end Node_Value;

end Trees;

package Page is

   -- This package declares a constant giving the width of the page
   -- and a subtype describing a line of text. This package
   -- is only used by the procedures Print_List and Print_Tree.

   Width: constant Integer := 40;
   subtype Line is String(1 .. Width);
end Page;

with Lists;  use Lists;
with Ada.Integer_Text_IO;  use Ada;
procedure Read_List(L: out List; Max_Value: out Integer) is

   -- Reads a sequence of values terminated by zero (or a negative
   -- value) and builds them into a list which is returned through
   -- the parameter L.  The maximum value of the integers read is 
   -- returned through Max_Value.

   Value: Integer;
begin
   Max_Value := 0;
   Clear(L);
   loop
      Integer_Text_IO.Get(Value);
      exit when Value <= 0;
      if Value > Max_Value then
         Max_Value := Value;
      end if;
      Append(L, Make_List(Value));
   end loop;
end Read_List;

function Num_Size(N: Integer) return Integer is
   -- Returns number of digits in decimal printed form of N
   -- plus a space
begin
   return Integer'Image(N)'Length;
end Num_Size;

with Page;
with Num_Size;
with Lists;  use Lists;
with Ada.Text_IO, Ada.Integer_Text_IO;  use Ada;
procedure Print_List(L: in List; Max_Value: in Integer) is

   -- Prints the values in the list in a tabular form.  The width of
   -- field for printing each value is the constant Field which is set
   -- according to the maximum value in the list.  If the
   -- next value would overflow the page width then a new line is
   -- started.
   --    A (shallow) copy of the list is made in Temp because the 
   -- parameter L is an in parameter and thus constant.

   Temp: List := L;
   Value: Integer;
   Count: Integer := 0;
   Field: constant Integer := Num_Size(Max_Value);
begin
   Text_IO.New_Line;
   loop
      exit when Is_Empty(Temp);
      Take_From_List(Temp, Value);
      Count := Count + Field;
      if Count > Page.Width then
         Text_IO.New_Line;
         Count := Field;
      end if;
      Integer_Text_IO.Put(Value, Field);
   end loop;
   Text_IO.New_Line(2);
end Print_List;

with Page;
with Num_Size;
with Trees;  use Trees;
with Ada.Text_IO;  use Ada;
procedure Print_Tree(T: in Tree; Max_Value: in Integer) is

   -- Prints the tree using a format depending upon the maximum
   -- value in the tree.

   -- The variable Max_Width gives the page width that would
   -- be required by the deepest part of the tree assuming at least
   -- one space between all values.  Max_Width is then compared with
   -- the actual page width and reduced to it if necessary.
   --    The array A is declared with upper bound sufficient to hold
   -- a character representation of the whole tree.  It is
   -- initialized to all spaces.

   Max_Width: Integer := Num_Size(Max_Value) * 2**(Depth(T)-1);
   A: array(1..4*Depth(T)-3) of Page.Line :=
          (others => (others => ' '));

   procedure Put(N, Row, Col, Width: Integer) is
      -- Puts the value N into the array A in the given row
      -- starting at the given column and centred within the given
      -- field width allowing at least one leading space.  If it
      -- will not fit then the field is filled with asterisks.

      Size: Integer := Num_Size(N);
      Offset: Integer := (Width - Size + 1)/2;
      Digit: Integer;
      Number: Integer := N;
   begin
      if Size > Width then
         for I in 1 .. Integer'Max(Width, 1) loop
            A(Row)(Col+I-1) := '*';
         end loop;
      else
         A(Row)(Col+Offset .. Col+Offset+Size-1) := Integer'Image(Number);
      end if;
   end Put;

   procedure Do_It(T: Tree; Row, Col, W: Integer) is
      -- Outputs the whole tree into the array A recursively.
      -- The node value is centred in the field of width W in row
      -- Row.  If the node has subtrees then row Row+1 contains
      -- a single vertical line under the node value.  The row Row+2
      -- contains appropriate horizontal lines (hyphens) and Row+3
      -- has vertical lines at appropriate places according to 
      -- which subtrees are present. Finally the subtrees are
      -- output by calling Do_It recursively with appropriate
      -- parameters.  The row number is 4 more than that of the
      -- parent call and the field width is one half of that
      -- of the parent call. Rounding is applied as necessary.

      Left: Tree := Left_Subtree(T);
      Right: Tree := Right_Subtree(T);
   begin
      Put(Node_Value(T), Row, Col, W);
      if not (Is_Empty(Left) and Is_Empty(Right)) then
         A(Row+1)(Col+W/2) := '|';
      end if;
      if not Is_Empty(Left) then
         A(Row+2)(Col+W/4 .. Col+W/2) := (others => '-');
         A(Row+3)(Col+W/4) := '|';
         Do_It(Left, Row+4, Col, W/2);
      end if;
      if not Is_Empty(Right) then
         A(Row+2)(Col+W/2 .. Col+3*W/4) := (others => '-');
         A(Row+3)(Col+3*W/4) := '|';
         Do_It(Right, Row+4, Col+W/2, (W+1)/2);
      end if;
   end Do_It;

begin
   if Max_Width > Page.Width then
      Max_Width := Page.Width;
   end if;
   Do_It(T, 1, 1, Max_Width);
   Text_IO.New_Line;
   for I in A'Range loop
      Text_IO.New_Line;
      Text_IO.Put(A(I));
   end loop;
   Text_IO.New_Line(2);
end Print_Tree;

with Lists;  use Lists;
with Trees; use Trees;
procedure Convert_List_To_Tree(L: in List; T: out Tree) is

   -- Converts a list into a tree by Take_From_List and Insert.

   Temp: List := L;
   Value: Integer;
begin
   Clear(T);
   loop
      exit when Is_Empty(Temp);
      Take_From_List(Temp, Value);
      Insert(T, Value);
   end loop;
end Convert_List_To_Tree;

with Lists;  use Lists;
with Trees; use Trees;
procedure Convert_Tree_To_List(T: in Tree; L: out List) is

   -- Converts a tree back into a list.  This results in the list
   -- being sorted. It does this by converting each subtree and then
   -- uses Append to join the various sublists together.

   Right_L: List;
begin
   If Is_Empty(T) then Clear(L); return; end if;
   Convert_Tree_To_List(Left_Subtree(T), L);
   Append(L, Make_List(Node_Value(T)));
   Convert_Tree_To_List(Right_Subtree(T), Right_L);
   Append(L, Right_L);
end Convert_Tree_To_List;

with Lists, Read_List, Print_List;
with Trees, Print_Tree;
with Convert_List_To_Tree;
with Convert_Tree_To_List;
with Ada.Text_IO;  use Ada.Text_IO;
procedure Sylvan_Sorter is
   The_List: Lists.List;
   The_Tree: Trees.Tree;
   Max_Value: Integer;
begin
   Put("Welcome to the Sylvan Sorter");
   New_Line(2);
   loop
      Put_Line("Enter list of positive integers ending with 0");
      Read_List(The_List, Max_Value);
      exit when Lists.Is_Empty(The_List);
      Print_List(The_List, Max_Value);
      Convert_List_To_Tree(The_List, The_Tree);
      Print_Tree(The_Tree, Max_Value);
      Convert_Tree_To_List(The_Tree, The_List);
      Print_List(The_List, Max_Value);
   end loop;
   New_Line;
   Put_Line("Finished");
   Skip_Line(2);
end Sylvan_Sorter;