File : shuffle_text_tokens.adb

------------------------------------------------------------------------------
--  Demonstration code to read a text, split it into tokens, and shuffle them.
------------------------------------------------------------------------------
--  This version does not pollute the stack, prevents heap memory leaks.      
------------------------------------------------------------------------------

with Ada.Text_IO; use Ada.Text_IO;
with Ada.Strings.Maps, Ada.Strings.Fixed; use Ada.Strings;
with Ada.Strings.Unbounded;
with Ada.Numerics.Discrete_Random;
with Ada.Calendar;
with Unchecked_Deallocation;

procedure shuffle_text_tokens is
   
   type Token is record
      first, last : Positive;    --  Slice marker of an external string
      output : Boolean;          --  Tag to prevent double output of tokens
   end record;
   
   --  The list of all tokens is an simple array of all tokens.
   --  It's not possible to hold an array of Strings, because Strings are
   --  unconstrained.
   type Tokens is array (Positive range <>) of Token;
   
   --  The empty array required for iteration start.
   --  Even the array does not contain any elements, Ada requires a dummy
   --  definition structure.
   no_tokens : constant Tokens (1 .. 0) := (others => (1, 1, False));
   
   --  Read the whole text from standard input into a single string.
   --  Note, that the String size is returned, too!  You do not need
   --  to guess how large the array might be.
   function get_whole_text return String;
   
   --  Split a string into a array of tokens. Note, that the array size is
   --  returned, too! You do not need to guess how large the array might be.
   function split (line : String) return Tokens;

   --  Implementation of get_whole_text.
   --  A chunk of Characters is read at once from the current line.
   --  Get_Line uses two out parameters, but all constrained parameters are
   --  always "in" parameter for there own constraints. So the Get_Line
   --  procedure learns about the size of the chunk. Because the constraints
   --  als always "in", they can't be changed. Get_Line returns the really
   --  filled amount as a second out parameter, and fills the chunk partially.
   --  This chunk is added to a dynamic string. On EOF a LF is inserted.
   --  On EOT the Get_Line function raises End_Error which terminates the
   --  endless loop and returns the result. The dynamic string type is
   --  finalized on end of the routine giving back all the required memory.
   function get_whole_text return String is
      buff : String (1 .. 100);
      last : Natural;
      use Ada.Strings.Unbounded;
      res  : Unbounded_String := Null_Unbounded_String;
   begin
      loop
         Get_Line (buff, last);
         Append (res, buff (buff'First .. last));
         if last < buff'Last then
            Append (res, ASCII.LF);
         end if;
      end loop;
   exception
      when End_Error =>
         return To_String (res);
   end get_whole_text;
   
   --  Implementation of split.
   --  Scans the string for tokens using Ada.Strings.Fixed.Find_Token.
   --  The out parameter "last" is used a the iteration variable.
   --  In order to prevent head exhaustion, the allocated array is freed as
   --  soon as possible (remalloc would be more efficient). Automatic garbage
   --  colletion by limiting the pool size (Tokens_Access'Storage_Size) is
   --  not possible, because the token array can be arbitary large.
   function split (line : String) return Tokens is
      first : Positive;
      last  : Natural := line'First - 1;
      type Tokens_Access is access Tokens;
      procedure Free is new Unchecked_Deallocation (Tokens, Tokens_Access);
      res : Tokens_Access := new Tokens'(no_tokens);
      seperators : constant Maps.Character_Set :=
        Maps.To_Set (" .,:;?!" & ASCII.HT & ASCII.LF);
   begin
      loop
         Fixed.Find_Token (
           Source => line (last + 1 .. line'Last),
           Set    => seperators,
           Test   => Outside,
           First  => first,
           Last   => last
         );
         exit when last = 0;
         declare
            oldres : Tokens_Access := res;
         begin
            res := new Tokens'(oldres.all & Token'(first, last, False));
            Free (oldres);
         end;
      end loop;
      return res.all;
   end split;
   
   --  Read in the whole text into a variable which should be immutable.
   --  The required size (constraint) comes from the defining return value.
   text : constant String := get_whole_text;
   
   --  Split the whole text into an array of tokens.
   --  The required size (constraint) comes from the defining return value.
   toks : Tokens := split (text);
   
   --  Initialize a random generator for the offset range of the toks array.
   subtype Tokens_Range is Natural range toks'First .. toks'Last;
   package Tokens_Random is new Ada.Numerics.Discrete_Random (Tokens_Range);
   gen   : Tokens_Random.Generator;
   pos   : Tokens_Range;
   count : Tokens_Range;

   --  Start "real" work. A substantially amount of work is already done
   --  by initializing the variables "text" and "toks".
begin
   --  Initialize the Random Generator with the current time.
   Tokens_Random.Reset (gen,
     Integer (Ada.Calendar.Seconds (Ada.Calendar.Clock)));
   
   --  A hand coded loop with a delayed increment.
   --  Constraint Error is raised when no tokens are found at all.
   count := Tokens_Range'First;
   loop
      pos := Tokens_Random.Random (gen);
      if not toks (pos).output then
         Put (text (toks (pos).first .. toks (pos).last));
         toks (pos).output := True;
         count := Tokens_Range'Succ (count); -- Constraint_Error = Last Item
         Put (' ');
      end if;
   end loop;

exception
   when Constraint_Error =>
      New_Line;
end shuffle_text_tokens;