strings

uses
  SysUtils;

type
  arr = record
    a: array [0..25000] of integer;
  end;

var
  s: array [1..25000] of string;
  boo: array [1..25000] of boolean;
  i, k, j, t, h: integer;
  ff: arr;
  f: array [1..5, 0..25000] of integer;

function check(s, s1: string): boolean;
begin
  if (length(s) <> length(s1)) then check := false
  else
  begin
    while (length(s) > 0) and (pos(s[1], s1) <> 0) do
    begin
      delete(s1, pos(s[1], s1), 1);
      delete(s, 1, 1);
    end;
    check := (length(s) = 0);
  end;
end;

function sr(s, s1: string): boolean;
begin
  while (length(s) > 0) and (length(s1) > 0) and (s[1] = s1[1]) do
  begin
    delete(s, 1, 1);
    delete(s1, 1, 1);
  end;
  if (length(s) = 0) then sr := true
  else if (length(s1) = 0) then sr := false
  else sr := (ord(s[1]) < ord(s1[1]));
end;

procedure swap(var a, b: integer);
var
  c: integer;
begin
  c := a;
  a := b;
  b := c;
end;

function sort(f: arr; k: integer): arr;
var
  i, j: integer;
begin
  for i := 1 to k do
  for j := 2 to k do
    if (f.a[j - 1] <> 0) and (f.a[j] <> 0) and (not sr(s[f.a[j - 1]], s[f.a[j]])) then swap(f.a[j], f.a[j - 1]);
  sort := f;
end;

begin
  i := 1;
  while not eof do
  begin
    readln(s[i]);
    inc(i);
  end;
  k := i - 1;
  for i := 1 to k do
  begin
    if not boo[i] then
    begin
      t := 1;
      for j := 1 to k do
      if (check(s[i], s[j])) and not boo[j] then
      begin
        ff.a[t] := j;
        boo[j] := true;
        inc(t);
      end;
      ff := sort(ff, t - 1);
      ff.a[0] := t - 1;
      for h := 1 to 5 do
      if (f[h, 0] = 0) or((ff.a[0] > f[h, 0]) or ((ff.a[0] = f[h, 0]) and ( sr(s[ff.a[1]], s[f[h, 1]])))) then
      begin
        for j := 4 downto h do f[j + 1] := f[j];
        for j := 1 to ff.a[0] do f[h, j] := ff.a[j];
        f[h, 0] := ff.a[0];
        break;
      end;
    end;
  end;
  for i := 1 to 5 do
  if f[i, 0] <> 0 then
  begin
    write('Group of size ', f[i, 0], ': ');
    for j := 1 to f[i, 0] do write(s[f[i, j]], ' ');
    writeln('.');
  end;
end.