PROGRAM WordCount (Input,Output);
{$R+}

(* Create a word concordance of input file words. *)

CONST
   MaxWords = 500;      (* Max number of words allowed by program *)
   MaxString = 14;      (* Max number of characters allowed in a word *)
   Blank = ' ';

TYPE
   WordString = String[MaxString];
   WordRec = Record
       Word : WordString;    (*  A word *)
       Count : Integer;      (* number of times it occurs in text *)
   End;
   WordRange = 0..MaxWords;
   WordArray = ARRAY[WordRange] OF WordRec;


VAR
   Words : WordArray;
   Length : WordRange;





(*****************************************************************
Read a word from input.  Convert uppercase letters to lowercase.
Discard nonletters. *)

PROCEDURE ReadWord (Var Word : WordString);

Var
   I, J : 1..MaxString;
   Ch : Char;

Begin
   Read(Ch);
   (* skip over blanks and nonletters *)
   WHILE ((Ch = Blank) OR (NOT ((Ch IN ['a'..'z']) OR (Ch IN ['A'..'Z']))))
          AND NOT EOF DO
      Read(Ch);

   I := 1;                          (* load first letter *)
   IF Ch IN ['A'..'Z'] THEN
     Begin
       Ch := Chr (Ord(Ch) + 32);     (* convert to lowercase letter *)
       Word[I] := Ch;
     End
   ELSE
      IF Ch IN ['a'..'z'] THEN
         Word[I] := Ch
      ELSE
         Word[I] := Blank;

   (* read nonblanks, store letters *)
   WHILE (Ch <> Blank) AND NOT EOF AND NOT EOLN AND (I < MaxString) DO
     Begin
       Read(Ch);    (* next character *)
       IF Ch IN ['a'..'z'] THEN
         Begin
           I := I + 1;
           Word[I] := Ch;
         End
       ELSE
          IF Ch IN ['A'..'Z'] THEN
            Begin
              I := I + 1;
              Word[I] := Chr (Ord(Ch) + 32); (* convert to lowercase letter *)
            End;
     End;

     IF I < MaxString THEN
        FOR J := I+1 TO MaxString DO       (* pad rest of word with blanks *)
           Word[J] := Blank;
End;





(****************************************************************
Sequential Search array of Length for Word.  Return index of location
if found or next position if not found.  *)

PROCEDURE SearchPosition (Words : WordArray;
                          Word : WordString;
                          Length : WordRange;
                          Var Position : WordRange);
Var
   Found : Boolean;

Begin
   Found := False;
   Position := 1;
   WHILE (NOT Found) AND (Position <= Length) DO
      IF Words[Position].Word = Word THEN
         Found := True
      ELSE
         Position := Position + 1;
End;





(****************************************************************
Read the input, load array with words and number of times each
encountered in text. *)

PROCEDURE LoadWords (Var Words : WordArray;  Var Length : WordRange);

Var
   CurrentLength, Position : WordRange;
   Word : WordString;

Begin
   CurrentLength := 0;
   WHILE NOT EOF AND (CurrentLength < MaxWords) DO
     Begin
        ReadWord(Word);   (* get next word from input *)
        IF Word[1] <> Blank THEN      (* not empty word *)
          Begin
            (* find if in array already *)
            SearchPosition(Words,Word,CurrentLength,Position);

            IF Position = CurrentLength + 1 THEN     (* not in array yet *)
              Begin
               CurrentLength := CurrentLength + 1;
               Words[CurrentLength].Word := Word;
               Words[CurrentLength].Count := 1;
              End
            ELSE                                     (* already in array *)
               Words[Position].Count := Words[Position].Count + 1;
          End;
     End;
   Length := CurrentLength;
End;

(****************************************************************
Swap two WordRec records. *)

PROCEDURE Swap (Var WordRec1, WordRec2 : WordRec);

Var
   Temp : WordRec;

Begin
   Temp := WordRec1;
   WordRec1 := WordRec2;
   WordRec2 := Temp;
End;




(****************************************************************
Selection Sort the words alphabetically. *)

PROCEDURE SortWords (Var Words : WordArray;  Length : WordRange);

Var
   Pass, MinScan, MinIndex : WordRange;



Begin  (* SortWords *)
   FOR Pass := 1 TO Length - 1 DO
     Begin
        MinIndex := Pass;
        FOR MinScan := Pass + 1 TO Length DO
           IF Words[MinScan].Word < Words[MinIndex].Word THEN
              MinIndex := MinScan;
        Swap(Words[Pass],Words[MinIndex]);
     End;
End;






(****************************************************************
Display words and their counts. *)

PROCEDURE PrintWords (Words : WordArray; Length : WordRange);

Var
   I : WordRange;
   Displayed : Integer;

Begin
   Displayed := 0;
   FOR I := 1 TO Length DO
     Begin
       Write(Words[I].Count:2,' ',Words[I].Word);
       Displayed := Displayed + 1;
       IF Displayed = 4 THEN         (* 4 words per line of output *)
         Begin
            Writeln;
            Displayed := 0;
         End;
     End;
   Writeln;
End;




BEGIN
   LoadWords(Words,Length);
   SortWords(Words,Length);
   PrintWords(Words,Length);
END.