Метод Шелла

{$r+}
uses crt,dos;
var max,Mi,Mj,bi,bj,q3:integer;
f1:file of char;
f2,f3:text;
q,q1:char;
s:string;
BOUND,t:integer;
a:array [1..30,1..1803] of char;
h_h,m_m,s_s,hund_h:word;
label B1,B2,B3,B4,B5,exit;
Function cmp(a1,a2:integer):byte;
var k:integer;
begin
cmp:=2;
for k:=1 to 20 do
begin
if ord(a[k,a1])>ord(a[k,a2]) then begin cmp:=1;break;end;
if ord(a[k,a1])<ord(a[k,a2]) then begin cmp:=0;break;end;
end;
end;
procedure mov(b1,b2:integer);
var
tmp: array [1..20] of char;
i1:integer;
begin
for i1:=1 to 20 do begin
tmp[i1]:=a[i1,b1];
a[i1,b1]:=a[i1,b2];
a[i1,b2]:=tmp[i1];
end;
 
end;
var i,j:integer;
begin
clrscr;
assign (f1,'D:\PO\1.txt');
assign (f2,'D:\PO\2.txt');
assign (f3,'D:\PO\3.txt');
reset (f1);
rewrite (f2);
rewrite (f3);
Mj:=1;
Mi:=1;
i:=1;
s:='1 ';
q1:='1';
while not eof(f1) do
begin
read (f1,q);
if (q <> (' ')) then
begin
if (q <> chr(10)) and (q <> chr(13)) then
s:=s+q;
a[Mi,Mj]:=q;
inc(Mi);
end
else if q1 <> ' ' then begin
if s='' then continue;
inc(i);
inc(Mj);
Mi:=1;
write (f2,s);
writeln(f2);
write (f2,i,' ');
s:='';
end;
q1:=q;
end;
{###################################################################}
{niinia ?1}
{###################################################################}
{niinia ?2}
{###################################################################}
{###################################################################}
{niinia ?3}
begin
writeln('__________________________________');
writeln('Sotirovka metodom prostih vstavok');
gettime(h_h,m_m,s_s,hund_h);
writeln('time ',h_h,':',m_m,':',s_s,'.',hund_h);
max:=1;
for j:=1803 downto 2 do
begin
for i:=1 to 1803 do
if cmp(i,max)=1 then max:=i;
mov(max,j);
end;
end;
gettime(h_h,m_m,s_s,hund_h);
writeln('time ',h_h,':',m_m,':',s_s,'.',hund_h);
writeln('__________________________________') ;
{###################################################################}
exit:
for mj:=1 to 1803 do
begin
for mi:=1 to 20 do
write(f3,a[Mi,Mj]);
writeln(f3);
end;
close (f1);
close (f2);
close (f3);
writeln('succesful! Press enter');
readln;
end.

{Сортировка одномерного массива методом Шелла}
procedure sortvec(var a:tvec;st,fn:integer;asc:boolean);
var
         i, j, k, s, m: integer;
         x: real;
begin
  for i:=st to fn-1 do begin
   k:=i;
   for j:=i+1 to fn do
     if ((a[j]<a[k]) and asc) or ((a[j]>a[k]) and not asc) then k:=j;
   if k<>i then begin
     x:=a[i];a[i]:=a[k];a[k]:=x;
   end;
  end;
end;