-- Chapter 25 - Program 2
with Ada.Text_IO, Ada.Integer_Text_IO, Unchecked_Deallocation;
use Ada.Text_IO, Ada.Integer_Text_IO;

procedure SortList is

   Data_String : constant STRING := "This tests ADA";

   type CHAR_REC;                 -- Incomplete declaration

   type CHAR_REC_POINT is access CHAR_REC;

   type CHAR_REC is               -- Complete declaration
      record
         One_Letter : CHARACTER;
         Next_Rec   : CHAR_REC_POINT;
      end record;

   Start : CHAR_REC_POINT;        -- Always points to start of list
   Last  : CHAR_REC_POINT;        -- Points to the end of the list

   procedure Free is new Unchecked_Deallocation(CHAR_REC,
                                                   CHAR_REC_POINT);

   pragma Controlled(CHAR_REC_POINT);

   procedure Traverse_List(Starting_Point : CHAR_REC_POINT) is
   Temp : CHAR_REC_POINT;         -- Moves through the list
   begin
      Put("In traverse routine.  --->");
      Temp := Starting_Point;
      if Temp = null then
         Put("No data in list.");
      else
         loop
            Put(Temp.One_Letter);
            Temp := Temp.Next_Rec;
            if Temp = null then exit; end if;
         end loop;
      end if;
      New_Line;
   end Traverse_List;

   procedure Store_Character(In_Char : CHARACTER) is
   Temp : CHAR_REC_POINT;         -- Moves through the list

      procedure Locate_And_Store is
      Search : CHAR_REC_POINT;
      Prior  : CHAR_REC_POINT;
      begin
         Search := Start;
         while In_Char > Search.One_Letter loop
            Prior := Search;
            Search := Search.Next_Rec;
            if Search = null then exit; end if;
         end loop;
         if Search = Start then   -- New character at head of list
            Temp.Next_Rec := Start;
            Start := Temp;
         elsif Search = null then -- New character at tail of list
            Last.Next_Rec := Temp;
            Last := Temp;
         else                     -- New character within list
            Temp.Next_Rec := Search;
            Prior.Next_Rec := Temp;
         end if;
      end Locate_And_Store;

   begin
      Temp := new CHAR_REC;
         Temp.One_Letter := In_Char; -- New record is now defined
                                     -- The system sets Next_Rec
                                     -- to the value of null
      if Start = null then
         Start := Temp;
         Last := Temp;
      else
         Locate_And_Store;
      end if;
      Traverse_List(Start);
   end Store_Character;

begin
            -- Store the characters in Data_String in a linked list
   for Index in Data_String'RANGE loop
      Store_Character(Data_String(Index));
   end loop;

            -- Traverse the final list
   New_Line;
   Put_Line("Now for the final traversal.");
   Traverse_List(Start);

            -- Deallocate the list now
   loop
      exit when Start = null;
      Last := Start.Next_Rec;
      Free(Start);
      Start := Last;
   end loop;

end SortList;




-- Result of execution
--
-- In traverse routine.  --->T
-- In traverse routine.  --->Th
-- In traverse routine.  --->Thi
-- In traverse routine.  --->This
-- In traverse routine.  ---> This
-- In traverse routine.  ---> Thist
-- In traverse routine.  ---> Tehist
-- In traverse routine.  ---> Tehisst
-- In traverse routine.  ---> Tehisstt
-- In traverse routine.  ---> Tehissstt
-- In traverse routine.  --->  Tehissstt
-- In traverse routine.  --->  ATehissstt
-- In traverse routine.  --->  ADTehissstt
-- In traverse routine.  --->  AADTehissstt
--
-- Now for the final traversal.
-- In traverse routine.  --->  AADTehissstt