Var
 s:String;
 i,j,k,n,len:Integer;
 Words:Array[1..100] Of String;

Const
 Separators = [' ',',','.','!','?']; {Дополнить по желанию}

Begin
 ReadLn(s);
 n:=1;
 i:=1;
 While i<Length(s) Do
 Begin
   While (i<Length(s)) And (s[i] In Separators) Do
     Inc(i);
   If Length(s)<i Then
     Break;
   j:=i;
   While (j<Length(s)) And (s[j] In Separators) Do
     Inc(j);
   i:=j;
   Words[n]:=Copy(s,i,j-i);
   Inc(n)
 End;
 WriteLn('Total ',n,' words.');
 If n=0 Then
   Halt;
 For i:=1 To n-1 Do
 Begin
   Len:=Length(Words[i]);
   k:=i;
   For j:=i+1 To n Do
     If Length(Words[j])<Len Then
     Begin
       Len:=Length(Words[j]);
       k:=j
     End;
     If k<>i Then
     Begin
       s:=Words[i];
       Words[i]:=Words[k];
       Words[k]:=s
     End
 End;
 i:=1;
 While i<n Do
 Begin
   j:=i+1;
   While (j<n) And (Length(Words[j])=Length(Words[i])) Do
   Begin
     WriteLn(Words[j]);
     Inc(j)
   End;
   If j<>i+1 Then
   Begin
     WriteLn(Words[i]);
     WriteLn('-----------');
     WriteLn('Words Of Length ',Length(Words[i]))
   End;
   i:=j
 End
End.

program words;
const letters=['a'..'z'];
var s : string;
   keys : array[0..5, 0..255] of byte;
   i, l, n : integer;
begin
   Write('Enter string > '); readLn(s);
   i := 1; n := length(s);
   while i <= n do
   begin l := 0;
       while not (s[i] in letters) and (i <= n) do inc(i);
       while (s[i] in letters) and (i <= n) do
       begin
           inc(l);
           inc(i)
       end;
       inc(keys[0, l]); keys[keys[0, l], l] := i - l;
   end;

   for i := 1 to 255 do
       if keys[0,i] > 1 then
          writeLn(keys[0,i], ' words with length ', i);

   ReadLn;
end.