--  Program 5   May 2024




--  Wild Words 

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


with Ada.Strings.Bounded;
use Ada.Strings.Bounded;
package Lines is

   -- This contains an instantiation of Generic_Bounded_Length
   -- which is internal to Ada.Strings.Bounded.
   --    The subtype B_String is declared as an abbreviation for
   -- Bounded_String.
   --    The function "+" is declared as a tiny abbreviation for
   -- To_Bounded_String and is mainly used in aggregates. 

   Line_Length: constant := 70;
   package Bounded_Lines is
      new Generic_Bounded_Length(Line_Length);
   use Bounded_Lines;

   subtype B_String is Bounded_String;
   type BS_Array is
      array (Positive range <>) of B_String;

   function "+" (S: String) return B_String;
end;

package body Lines is
   function "+" (S: String) return B_String is
   begin
      return To_Bounded_String(S);
   end "+";
end Lines;

with Lines; use Lines;
package Rules is
   use Bounded_Lines;
   Letter_Freq: constant
      array (Character) of Integer :=
   ('a' => 9, 'b' => 2, 'c' => 2, 'd' => 4,
    'e' =>12, 'f' => 2, 'g' => 3, 'h' => 2,
    'i' => 9, 'j' => 1, 'k' => 1, 'l' => 4,
    'm' => 2, 'n' => 6, 'o' => 8, 'p' => 2,
    'q' => 1, 'r' => 6, 's' => 4, 't' => 6,
    'u' => 4, 'v' => 2, 'w' => 2, 'x' => 1,
    'y' => 2, 'z' => 1, others => 0);
          -- frequencies as in Scrabble

   function Letter_Tot return Integer;
   function Word_OK(W: B_String) return Boolean;

end Rules;

with Ada.Strings.Maps;
use Ada.Strings.Maps;  use Ada.Strings;
package body Rules is

   Vowels: constant String := "aeiouy";
   Consonants: constant String :=
       "bcdfghjklmnpqrstvwxyz";

   Short_Words: constant BS_Array :=
   (+"a", +"i", +"o",
    +"am", +"an", +"as", +"at", +"be", +"by", +"do",
    +"eh", +"go", +"he", +"if", +"in", +"is", +"it",
    +"me", +"my", +"no", +"of", +"on", +"or", +"ox",
    +"so", +"up", +"us", +"we", +"ye");

   Four_Letters: constant
       array (Positive range <>) of String(1 .. 4) :=
      ("blow", "dash", "drat");  -- add your own!

   Starts: constant BS_Array :=
    (+"bl", +"br", +"ch", +"cl", +"cr", +"dr", +"dw",
     +"fl", +"fr", +"gh", +"gl", +"gn", +"gr", +"kl",
     +"kn", +"kr", +"mn", +"ph", +"pl", +"pn", +"pr",
     +"ps", +"pt", +"rh", +"sc", +"sh", +"sk", +"sl",
     +"sm", +"sn", +"sp", +"sq", +"st", +"th", +"tr",
     +"wh", +"wr",
     +"chr", +"phl", +"phr", +"sch", +"scl", +"scr",
     +"shr", +"sph", +"spl", +"spr", +"str", +"thr");

   function Letter_Tot return Integer is
      Total: Integer := 0;
   begin
      for C in Character loop
         Total := Total + Letter_Freq(C);
      end loop;
      return Total;
   end Letter_Tot;

   function Word_OK(W: B_String) return Boolean is
      -- This carries out various checks to see whether the word
      -- W is acceptable.

      First_Seq, Last_Seq: Integer;
   begin

      -- A word of length 1 or 2 must be listed in the array
      -- Short_Words.

      if Length(W) <= 2 then
         for I in Short_Words'Range loop
            if W = Short_Words(I) then
               return True;
            end if;
         end loop;
         return False;  -- non-English word
      end if;

      -- The four letter words in the array Four_Letters are
      -- forbidden.

      for I in Four_Letters'Range loop
         if W = Four_Letters(I) then
            return False;  -- coarse slang
         end if;
      end loop;

      -- A q must be followed by a u.  This is checked by comparing
      -- the number of instances of q with the number of instances
      -- of qu.

      if Count(W, "q") /= Count(W, "qu") then
         return False;  -- q without u
      end if;

      -- Every word must have at least one vowel including y as
      -- a vowel.

      if Count(W, To_Set(Vowels)) = 0 then
         return False;  -- no vowels
      end if;

      -- Every word must have at least one consonant including y as
      -- a consonant.

      if Count(W, To_Set(Consonants)) = 0 then
         return False;  -- no consonants
      end if;

      -- If a word starts with a sequence of consonants 
      -- (excluding y) then the sequence must be in the array
      -- Starts.
      --    The index of the start and end of the first sequence
      -- are given by calling Find_Token and are returned in
      -- First_Seq and Last_Seq.

      Find_Token(W, To_Set(Consonants) - To_Set('y'),
                                Inside, First_Seq, Last_Seq);
      if First_Seq = 1 and Last_Seq > 1 then
         for I in Starts'Range loop
            if Slice(W, First_Seq, Last_Seq) = Starts(I) then
               return True;
            end if;
         end loop;
         return False;  -- illegal start
      end if;
      return True;
   end Word_OK;

end Rules;

package Bag is
   procedure Start;
   procedure Draw(C: out Character);
   function Dice return Integer;
end;

with Ada.Numerics.Discrete_Random;
use Ada.Numerics;
with Rules;  use Rules;
package body Bag is
   subtype Letter_Range is Integer range 1 .. Letter_Tot;
   Letters: array (Letter_Range) of Character;

   package Letter_Random is
         new Discrete_Random(Letter_Range);
   Letter_Gen: Letter_Random.Generator;

   subtype Die_Range is Integer range 1 .. 6;

   package Die_Random is
         new Discrete_Random(Die_Range);
   Die_Gen: Die_Random.Generator;

   procedure Start is
      L: Integer := 0;
   begin
      Letter_Random.Reset(Letter_Gen);
      Die_Random.Reset(Die_Gen);
      for C in Character loop
          for I in 1 .. Letter_Freq(C) loop
             L := L + 1; Letters(L) := C;
          end loop;
      end loop;
   end Start;

   procedure Draw(C: out Character) is
      use Letter_Random;
   begin
      C := Letters(Random(Letter_Gen));
   end Draw;

   function Dice return Integer is
      use Die_Random;
   begin
      return Random(Die_Gen) + Random(Die_Gen);
   end Dice;

end Bag;

with Lines;  use Lines;
package Story is
   use Bounded_Lines;

   Done: exception;

   procedure Start;
   procedure Add_Word(A_Word: in B_String);
   procedure Add_Stop;
   procedure New_Para;
   function Is_A_Good_One return Boolean;
private
   Para_Indent: constant := 3;
   Max_Lines: constant := 1000;
   Text: array (1 .. Max_Lines) of B_String;
   Line_No: Integer;
   New_Sentence: Boolean;
end Story;

with Ada.Characters.Handling;
use Ada.Characters.Handling;
with Ada.Strings.Maps;
use Ada.Strings.Maps;
use Ada.Strings;
package body Story is

   procedure Start is
   begin
      Text := (others => Null_Bounded_String);
      Line_No := 1;
      New_Sentence := True;
   end Start;

   procedure Increment_Line is
      -- This increments the line count.  If the line number has 
      -- already reached the maximum then any partial sentence is
      -- discarded.  This is done by searching backwards for a stop
      -- by using Index. If a last stop is found on the current line
      -- then the text after the stop to the end of the line (if
      -- any) is deleted by Delete and the exception Done is raised.
      -- If no stop is found on the current line then the line is
      -- set to null and the previous line searched for a stop.

      Last_Stop: Integer;
   begin
      if Line_No < Max_Lines then
         Line_No := Line_No + 1;
      else
         -- discard partial sentence if any
         loop
            Last_Stop := Index(Text(Line_No), To_Set('.'),
                                        Going => Backward);
            if Last_Stop /= 0 then
               if Last_Stop /= Length(Text(Line_No)) then
                  Delete(Text(Line_No), Last_Stop+1,
                                   Length(Text(Line_No)));
               end if;
               raise Done;
            end if;
            Text(Line_No) := Null_Bounded_String;
            Line_No := Line_No - 1;
          end loop;
      end if;
   end Increment_Line;

   procedure Add_Word(A_Word: in B_String) is
      -- This adds a word to the story.  If it is a new sentence
      -- or the word is I or O then it is first capitalized by using
      -- Replace_Element.
      --    The function Index_Non_Blank is used to see whether
      -- there are any existing words on the current line. If not
      -- then the word is simply appended to the line (the line
      -- might be empty or it might have three spaces being the
      -- start of a new paragraph).  If there are words on the
      -- current line then a check is made to ensure that the
      -- new word together with a space before it will fit on
      -- the line.  If they will then a Space and the new word are
      -- added to the line.  If they will not fit then a new line
      -- is started and set to just the new word.

      W: B_String := A_Word;
      This_Line: B_String renames Text(Line_No);
   begin
      if New_Sentence or W = "i" or W = "o" then
         Replace_Element(W, 1, To_Upper(Element(W, 1)));
      end if;
      if Index_Non_Blank(This_Line) = 0 then
         Append(This_Line, W);
      elsif Length(This_Line) + Length(W) < Line_Length then
         Append(This_Line, Space & W);
      else
         Increment_Line;
         Text(Line_No) := W;
      end if;
      New_Sentence := False;
   end Add_Word;

   procedure Add_Stop is
      -- This adds a stop to the end of a sentence.
      --    If there is room on the current line then the stop
      -- is just added by Append.  However, if the current line is
      -- full the last word is removed from it and placed on a new
      -- line together with the stop.
      --    The beginning of the last word is found by searching
      -- backwards for a Space using Index.  The function Slice is
      -- then used to extract the word as a string, it is then
      -- converted to a bounded string using "+" and the stop
      -- appended using "&". The result is then assigned to the next
      -- line.  Finally the original word is deleted from the
      -- original line.

      This_Line: B_String renames Text(Line_No);
      Last_Space: Integer;
   begin
      if Length(This_Line) < Line_Length then
         Append(This_Line, '.');
      else
         Last_Space := Index(This_Line, To_Set(Space),
                                        Going => Backward);
         Increment_Line;
         Text(Line_No) := +Slice(This_Line, Last_Space+1,
                                Length(This_Line)) & '.';
         Delete(This_Line, Last_Space, Length(This_Line));
      end if;
      New_Sentence := True;
   end Add_Stop;

   procedure New_Para is
   begin
      Increment_Line;
      Text(Line_No) := Para_Indent * Space;
   end New_Para;

   function Is_A_Good_One return Boolean is separate;

end Story;

with Ada.Strings.Maps.Constants;
use Ada.Strings.Maps.Constants;
with Ada.Text_IO;  use Ada.Text_IO;
separate(Story)
function Is_A_Good_One return Boolean is

   -- This searches through the whole story looking for one of the
   -- words in the local array Names.
   --    Each line of text is searched in sequence for each word in
   -- turn using Index.  Note that Translate and Lower_Case_Map
   -- are used in order that the search works entirely in terms
   -- of lower case letters.  Remember that the words in Names are
   -- capitalized and the start of each sentence is also
   -- capitalized; it is thus easier to do everything in one case.
   --    If a match is found then we have to check that it is a word
   -- on its own and not just part of a larger word. This check is
   -- performed by testing to see that the adjacent characters 
   -- are not letters unless the sequence is at the end of a line.
   --    Finally if these checks pass then a confirmatory message 
   -- is output giving the word found and the line of text
   -- containing it.

   Names: constant BS_Array :=
      (+"Lear", +"Puck", +"Hamlet", +"Belch");

   I, J: Integer;  -- start and end of sequence
begin
   for L in Text'Range loop
      for K in Names'Range loop
         I := Index(Text(L), To_String(Translate
             (Names(K), Lower_Case_Map)),
               Forward, Lower_Case_Map);
         if I > 0 then
              -- now check not part of larger word
            J := I + Length(Names(K)) - 1;
            if (I = 1 or else not Is_Letter(Element
                            (Text(L), I-1)) ) and
               (J = Length(Text(L)) or else
                              not Is_Letter(Element
                            (Text(L), J+1)) ) then
               Put_Line(To_String(Names(K)) & " found in");
               Put_Line(To_String(Text(L)));
               return True;
            end if;
         end if;
      end loop;
   end loop;
   return False;
end Is_A_Good_One;

with Ada.Text_IO;  use Ada.Text_IO;
procedure Story.Print is
begin
   for I in Text'Range loop
      Put_Line(To_String(Text(I)));
   end loop;
end Story.Print;

with Rules, Bag, Story, Lines;  use Lines;
procedure Process_Paragraph is

   -- This produces a paragraph.  The dice are "rolled" to determine
   -- word length, sentence length and paragraph size.  The word
   -- length ranges from 1 to 11, the sentence length from 4 to 14 
   -- and the number of sentences in a paragraph from 1 to 6.
   --    Characters are drawn from the bag to make a word of the
   -- required length.  The word is then checked for validity.  If
   -- it is rejected then another word of the same length is made
   -- and tried.

   use Bounded_Lines;
   The_Word: B_String;
   The_Char: Character;
   Chars_In_Word: Integer;
begin
   for S in 1 .. Bag.Dice/2 loop
      for W in 1 .. Bag.Dice+2 loop
         Chars_In_Word := Bag.Dice-1;
         loop
            The_Word := Null_Bounded_String;
            for C in 1 .. Chars_In_Word loop
               Bag.Draw(The_Char);
               Append(The_Word, The_Char);
            end loop;
            exit when Rules.Word_OK(The_Word);
         end loop;
         Story.Add_Word(The_Word);
      end loop;
      Story.Add_Stop;
   end loop;
   Story.New_Para;
end Process_Paragraph;

with Bag, Story.Print, Process_Paragraph;
with Ada.Text_IO;  use Ada.Text_IO;
procedure Wild_Words is
begin
   Put_Line("Welcome to the Wild Word Processor");
   Bag.Start;
   loop
      Story.Start;
      loop
         begin
            Process_Paragraph;
         exception
            when Story.Done => exit;
         end;
      end loop;
     exit when Story.Is_A_Good_One;
     Put_Line("Wretched animal - try again.");
   end loop;
   Put_Line("Well done - have a banana!");
   Skip_Line;  Story.Print;  Skip_Line;
end Wild_Words;