Найти слова, содержащие соответственно наибольшее и наименьшее количество заглавных латинских букв, и поменять их местами

[smilegirl73]

Задание: составить программу заданной обработки массива слов. В процессе обработки использовать множественных тип данных. Заполнение исходных данных – с клавиатуры. Исходный и обработанный массив выводить на экран.

Дан массив из n слов произвольной длины (длина слова не превышает 80 символов). Слова могут содержать латинские буквы и цифры. Найти слова, содержащие соответственно наибольшее и наименьшее количество заглавных латинских букв, и поменять их местами.

Не могу исправить ошибку - почему-то в программе меняются слова, где нет латинских букв
program test;
uses crt;
const nmax=50;
ds=['0'..'9','A'..'Z','a'..'z'];
zg=['A'..'Z'];
var s:array[1..nmax] of string[80];
x:string[80];
n,i,j,imx,imn,mx,mn,k,k1,p:integer;
begin
clrscr;
repeat
write('Kol-vo slov do ',nmax,', n=');
readln(n);
until n in [1..nmax];
writeln;
writeln('Vvedite slova: ');
for i:=1 to n do
begin
repeat
k:=0;
write('Slovo ',i,' - ');
readln(s[i]);
for j:=1 to length(s[i]) do
if not(s[i][j] in ds) then k:=1;
if k=1 then writeln('Vvedeny nedopustimye simvoly, povtorite vvod.');
until k=0;
end;
k1:=0; {посчитаемв первом слове}
for i:=1 to length(s[1]) do
if s[1][i] in zg then k1:=k1+1;
mx:=k1;mn:=k1;{это макс и мин}
imx:=1;imn:=1;
p:=0;{пусть везде одинаково}
for i:=2 to n do
begin
k:=0;
for j:=1 to length(s[i]) do
if s[i][j] in zg then k:=k+1;
if k>mx then
begin
mx:=k;
imx:=i;
end;
if k<mn then
begin
mn:=k;
imn:=i;
end;
if k<>k1 then p:=1;{если не равео первому, то разное}
end;
if mx=0 then write('V slovah net zaglavnyh bukv')
else if p=0 then write('Vo vseh slovah ravnoe chislo zaglavnyh bukv')
else
begin
writeln('Bolshe vsego zaglavnyh bukv v slove: ',s[imx]);
writeln('Menshe vsego zaglavnyh bukv v slove: ',s[imn]);
x:=s[imx];
s[imx]:=s[imn];
s[imn]:=x;
writeln('Rezultat:');
for i:=1 to n do
write(s[i],' ');
end;
readln
end.