const fi='DOAN.INP';
      fo='DOAN.OUT';
      max=round(1e8)+8;
var s:ansistring;
    a:array[0..max] of longint;
    d:array[0..max] of longint;
    i,m,k,n:longint;
procedure nhap;
begin
        assign(input,fi);
        reset(input);
        read(s);
        close(input);
end;
procedure chuanhoa;
begin
        while (length(s)>0) and (s[1]=#32) do delete(s,1,1);
        while (length(s)>0) and (s[length(s)]=#32) do delete(s,length(s),1);
        while pos(#32#32,s) > 0 do delete(s,pos(#32#32,s),1);
end;
procedure taoa;
begin
        fillchar(a,sizeof(a),0);
        m:=0;
        s:=#32+s;
        n:=length(s);
        for i:=2 to n do
                if s[i-1]=#32 then
                        inc(m)
                else
                        if s[i]<>#32 then inc(a[m]);
end;
procedure taod;
begin
        fillchar(d,sizeof(d),0);
        k:=0;
        d[1]:=1;
        for i:=1 to m do
        begin
                if a[i]=a[i-1] then inc(d[k])
                else
                begin
                        inc(k);
                        inc(d[k]);
                end;
        end;
end;
procedure xuat;
var dmax:longint;
begin
        dmax:=0;
        for i:=0 to k do
                if d[i]>dmax then dmax:=d[i];
        assign(output,fo);
        rewrite(output);
        write(dmax);
        close(output);
end;
begin
        nhap;
        chuanhoa;
        taoa;
        taod;
        xuat;
end.

uses crt;
var s:string; a:array[1..1000]of longint;  i,t,n,max,j:longint;
begin
clrscr;
    write('s=');readln(s);  n:=length(s); t:=1;
     For i:=1 to n do
          If(s[i]<>' ')or(i=1)then
               a[t]:=a[t]+1 else inc(t);
    for i:=1 to t do
        begin
            j:=i;
            while a[j]=a[i] do inc(j);
            If j-i>max then max:=j-i;
        end;
    writeln(max);
readln
end.

Mình có gắng rút gọn nhất có thể rồi mong bạn vote cho m