program sort;
uses crt,crt1;
label 101;
const
dn=100;
up=#72;
down=#80;
left=#75;
right=#77;
enter=#13;
bksp=#8;
delt=#83;
escape=#27;
insrt=#82;
type
date=record
  day,mth,yr:integer;
     end;
     seqc=array[1..dn] of date;
     psel=^sel;
     sel=record
           prev:psel;
           lemg,rimg:integer;
         end;
     symbol=record
              ch:char;
              atr:byte;
            end;
     screen=array[1..80,1..25] of symbol;
     summar=array[0..3] of string;
var
{all this from sorting}
	Q,P:date;
    s1,s2,s3,s4,s5,t1,t2,t3,t4,t5:seqc;
    size,i,swapcount,cmprcount:integer;
    var st:array[1..2,1..5] of integer;

	  c:char; b:boolean;
    x,y:byte;
    s:string;
    exitf,methf,mmf,modef:byte;
    lengf:integer;
    sar:summar;


{*SEQGEN*********************************************************************}
procedure seqgen(var seq1,seq2,seq3,seq4,seq5:seqc; size:integer);
var sloop,slp:integer;
begin
{sequence 1, / }
seq1[1].day:=1+random(31);
seq1[1].mth:=1+random(12);
seq1[1].yr:=1+random(1999);
for sloop:=2 to size do
begin
 seq1[sloop].day:=seq1[1].day;
 seq1[sloop].mth:=seq1[1].mth;
 seq1[sloop].yr:=seq1[sloop-1].yr+1;
end;
{sequence 2, \}
seq2[1].day:=1+random(31);
seq2[1].mth:=1+random(12);
seq2[1].yr:=1+random(1999);
for sloop:=2 to size do
begin
 seq2[sloop].day:=seq2[1].day;
 seq2[sloop].mth:=seq2[1].mth;
 seq2[sloop].yr:=seq2[sloop-1].yr-1;
end;
{sequence 3, /\/}
seq3[1].day:=1+random(31);
seq3[1].mth:=1+random(12);
seq3[1].yr:=1+random(1999);
slp:=1;
for sloop:=2 to size do
begin
 seq3[sloop].day:=seq3[1].day;
 seq3[sloop].mth:=seq3[1].mth;
 if sloop mod 2=0 then
   seq3[sloop].yr:=seq3[sloop-1].yr+slp
 else
   seq3[sloop].yr:=seq3[sloop-1].yr-slp;
 slp:=slp+1;
end;
{sequence 4,5 : random}
for sloop:=1 to size do
begin
  seq4[sloop].day:=1+random(31);
  seq4[sloop].mth:=1+random(12);
  seq4[sloop].yr:=1+random(1999);
  seq5[sloop].day:=1+random(31);
  seq5[sloop].mth:=1+random(12);
  seq5[sloop].yr:=1+random(1999);
end;
end;
{*END*OF*SEQGEN**************************************************************}
{*COMPARE********************************************************************}
function compare(e1,e2:date):integer; {-1~< 0~= 1 ~>  (false)}
begin
cmprcount:=cmprcount+1;
if (e1.yr=e2.yr)and(e1.mth=e2.mth)and(e1.day=e2.day)then
 begin compare:=0; exit; end;
if (e1.yr>e2.yr) or((e1.yr=e2.yr)and(e1.mth>e2.mth)) or
((e1.yr=e2.yr)and(e1.mth=e2.mth)and(e1.day>e2.day)) then
begin compare:=1; exit; end else compare:=-1;
end;
{*END*OF*COMPARE*************************************************************}
{*SWAP***********************************************************************}
procedure swap(var a,b:date);
var tmp:date;
begin
tmp:=b;
b:=a;
a:=tmp;
swapcount:=swapcount+1;
end;
{*END*OF*SWAP****************************************************************}
procedure qsort(var arr:seqc);forward;

function toint(s:string):integer;
var l,i:integer;
    c:char;
    d:integer;
    int:integer;
begin
  int:=0;
  i:=1;
  for l:=1 to length(s) do
  begin
    c:=s[length(s)+1-l];
    d:=ord(c)-ord('0');
    int:=int+d*i;
    i:=i*10;
  end;
  toint:=int;
end;

function tostr(num:integer):string;
var x1,x2,x3,x4:byte;
    ts:string;
begin
 tostr:='';
 ts:='';
 x1:=num div 1000;
 x2:=num mod 1000 div 100;
 x3:=num mod 100 div 10;
 x4:=num mod 10;
 ts:=chr(ord('0')+x1)+chr(ord('0')+x2)+chr(ord('0')+x3)+chr(ord('0')+x4);
 if ts[1]='0' then delete(ts,1,1);
 if ts[1]='0' then delete(ts,1,1);
 tostr:=ts;
end;

procedure wherexy(var x,y:byte); {gives xy of cursor }
begin                            {in a current window}
 x:=wherex;
 y:=wherey;
end;

procedure reset;
begin
textcolor(red);
textbackground(black);
end;

procedure savewin(var sc:screen);
var i,j,x1,x2,y1,y2:byte;
begin
  windcoord(x1,y1,x2,y2);
  window(1,1,80,25);
  for i:=1 to 80 do
  for j:=1 to 25 do
  begin
    sc[i,j].ch:=getch(i,j);
    sc[i,j].atr:=getattr(i,j);
  end;
  window(x1,y1,x2,y2);
end;

procedure loadwin(var sc:screen);
var i,j,x1,x2,y1,y2:byte;
begin
  windcoord(x1,y1,x2,y2);
  window(1,1,80,25);
  for i:=1 to 80 do
  for j:=1 to 25 do
  begin
    putch(i,j,sc[i,j].ch);
    putattr(i,j,sc[i,j].atr);
  end;
  window(x1,y1,x2,y2);
end;


procedure colorize(x1,y1,x2,y2,attr:byte);
var i,j:byte;
begin
  for i:=x1 to x2 do
  for j:=y1 to y2 do
  putattr(i,j,attr);
end;

procedure border(x1,y1,x2,y2:byte);
var i:byte;

begin
  putch(x1,y1,#218);
  putch(x2,y1,#191);
  putch(x1,y2,#192);
  putch(x2,y2,#217);
  for i:=x1+1 to x2-1 do
  begin
    putch(i,y1,#196);
    putch(i,y2,#196);
  end;
  for i:=y1+1 to y2-1 do
  begin
    putch(x1,i,#179);
    putch(x2,i,#179);
  end;
end;

procedure anykey;
var
x1,x2,y1,y2:byte;
i:integer;
s:string;
t:screen;
begin
  crsoff;
  s:='Press any key to continue';
  windcoord(x1,y1,x2,y2);
  window(1,25,80,25);
  savewin(t);
  for i:=1 to 80 do
  begin
    putattr(i,1,black+16*blue);
    putch(i,1,' ');
  end;
  window(25,25,50,25);
  for i:=1 to 25 do putch(i,1,s[i]);
  wait;
  loadwin(t);
  window(x1,y1,x2,y2);
end;

procedure ShowHelp(hs:string);
 var x1,y1,x2,y2,i:byte;
 begin
   crsoff;
   windcoord(x1,y1,x2,y2);
   window(1,1,80,25);
   for i:=1 to length(hs) do putch(i,25,hs[i]);
   for i:=length(hs)+1 to 80 do putch(i,25,' ');
   window(x1,y1,x2,y2);
 end;

procedure senderr(s:string);
var t:screen;
    i:byte;
    x1,x2,y1,y2:byte;
begin
  crsoff;
  savewin(t);
  windcoord(x1,y1,x2,y2);
  window(1,11,80,13);
  border(1,1,80,3);
  colorize(1,1,80,3,white+16*green);
  for i:=1 to length(s) do putch(i+1,2,s[i]);
  for i:=length(s)+1 to 78 do putch(i+1,2,' ');
  wait;
  loadwin(t);
  window(x1,y1,x2,y2);
end;

procedure putcursor(x,y,l:byte);
var i:byte;
begin
  crsoff;
  for i:=1 to l do
    putattr(x-1+i,y,black+16*white);
end;

procedure remcursor(x,y,l:byte);
var i:byte;
begin
  crsoff;
  for i:=1 to l do
    putattr(x-1+i,y,black+16*lightgray);
end;

procedure putstring(x,y:byte; s:string);
var i:byte;
begin
  crsoff;
  for i:=1 to length(s) do
  putch(x+i-1,y,s[i]);
end;

(*DrawMethod---OK-------------------------------------------------------------*)
procedure DrawMethod(var methf:byte);{x,y:size of window}
label 000,001;
const xs=25;
      ys=23;

var tmpwin:screen;
    c:char;
    b:boolean;
    cury:byte;
    var x1,x2,y1,y2:byte;

procedure putstring(x,y:byte; s:string);
var i:byte;
begin
  crsoff;
  for i:=1 to length(s) do
  putch(x+i-1,y,s[i]);
end;




begin
savewin(tmpwin);
windcoord(x1,y1,x2,y2);
crsoff;
window(2,2,3+xs,2+ys);

colorize(1,1,xs,ys,black+16*red);
border(1,1,xs,ys);
putstring(2,2,'Select Sorting Method');
putstring(2,3,'');
putstring(2,4,'');
putstring(2,5,'  Quicksort');

showhelp('up,down-move cursor, enter-confirm, escape-cancel');

cury:=5;
putcursor(3,cury,21);
000:;
while true do
begin
  inkey(c,b);
  if b=true then
  begin
    case c of
     up:begin
          remcursor(3,cury,21);
          if cury=5 then cury:=15;
          cury:=cury-2;
          putcursor(3,cury,21);
        end;
     down:begin
            remcursor(3,cury,21);
            if cury=13 then cury:=3;
            cury:=cury+2;
            putcursor(3,cury,21);
          end;
     enter:begin methf:=cury; break end;
     escape:goto 001;
    end;
   end;
  end;

  begin methf:=1; sar[1]:='qsort'; end;

end;
001:;
loadwin(tmpwin);
window(x1,y1,x2,y2);
end;
(*End Of DrawMode------OK---------------------------------------------------*)





{---FIELD-OPERATIONS---------------------------------------------------------}


{READFIELD-------OK----------------------------------------------------------}
procedure readfield(x,y,n:byte; stopkeys:string; var s:string; var key:char);
label 000,001;
var c:char;
    b:boolean;
    wx,wy:byte;
    tempstr:string;
    fins:boolean;{flag of insertion}
    i:integer;
    x1,x2,y1,y2:byte;
  procedure mvl;{OK}
    var x,y:byte;
    begin
      wherexy(x,y);
      gotoxy(x-1,y);
    end;

  procedure mvr;{OK}
    var x,y:byte;
    begin
      wherexy(x,y);
      gotoxy(x+1,y);
    end;

  procedure pins; begin fins:=not(fins); end; {OK}

  procedure del(var st:string; n:byte);{OK}
  var x1,i:byte;
        tc:char;
  begin
    x1:=wherex;
    if x1<n then
    begin
      for i:=x1 to n-1 do
      begin
(*      st[i-1]:=st[i];   {array shift 1 left}
        st[n]:=' ';       {                  }
*)      tc:=getch(i+1,1); {field shift 1 left}
        putch(i,1,tc);    {                  }
                          {                  }
      end;
      putch(n,1,' ');
      delete(st,x1,1);
    end;
  end;

  procedure backspace(var st:string; n:byte);{OK}
  var x1,i:byte;
        tc:char;
  begin
    x1:=wherex;
    if x1>1 then
    begin
      for i:=x1 to n do
      begin
        c:=getch(i,1); {field shift 1 left}
        putch(i-1,1,tc);{                  }
        putch(n,1,' '); {                  }
      end;
      delete(st,x1,1);
      gotoxy(x1-1,1);
    end;
  end;

  procedure inschr(c:char; var st:string);
  var x1,y1:byte;
  begin
    wherexy(x1,y1);
    putch(x1,y1,c);
    gotoxy(x1+1,y1);
(*  st[x1]:=c;      *)
    delete(st,x1,1);
    insert(c,st,x1);
  end;

  procedure wrtchr(c:char; n:byte; var st:string);
  var x1,i:byte;
      c1:char;
  begin
     x1:=wherex;
     for i:=n downto x1+1 do
     begin
(*     st[i]:=st[i-1];{array shift 1 right}
*)     c1:=getch(i-1,1);
       putch(i,1,c1);
     end;
     putch(x1,1,c);
     gotoxy(x1+1,1);
(*   st[x1]:=c;     *)
     insert(c,st,x1);
  end;

  function chex(c:char; sstr:string{; var key:char}):boolean;
  begin
    if Pos(c,sstr)<>0 then
    begin
      {key:=c;}
      chex:=true;
    end;
  end;

begin
windcoord(x1,y1,x2,y2);
window(x,y,x-1+n,y); {mark field}
{set cursor to start of field}
crson;
fins:=true;
tempstr:=s;
001:;
inkey(c,b);

if b=false then
    begin
      if (((ord(c)<=57)and(ord(c)>=48))or(ord(c)=46))then
      begin
        if fins then inschr(c,tempstr)
                else wrtchr(c,n,tempstr);
      end;
      goto 001;
    end
  else
  begin
    case c of
                      left:begin mvl; goto 001; end;
                     right:begin mvr; goto 001; end;
                      bksp:begin backspace(tempstr,n); goto 001; end;
                      delt:begin del(tempstr,n); goto 001; end;
      up,down,enter,escape:if chex(c,stopkeys)=true then key:=c else goto 001;
                     insrt:begin pins; goto 001; end;
    else goto 001;
  end;
  end;

000:;
tempstr:=copy(tempstr,1,n);
s:=tempstr;
window(x1,y1,x2,y2);
end;
{END OF READFIELD---OK-------------------------------------------------------}

{PUTFIELD-----------OK-------------------------------------------------------}
procedure putfield(x,y,n:byte; s:string);
var i:byte;
    ts:string;
    x1,x2,y1,y2:byte;
begin
windcoord(x1,y1,x2,y2);
  window(x,y,x+n-1,y);
  ts:=s;
  if length(ts)>n then ts:=copy(ts,1,n);
  for i:=1 to n do putch(i,1,ts[i]);
  gotoxy(n,1);
window(x1,y1,x2,y2);
end;
{END OF PUTFIELD------OK-----------------------------------------------------}

{GETFIELD-------------OK-----------------------------------------------------}
procedure getfield(x,y,n:byte; var s:string);
var x1,x2,y1,y2,i:byte;
begin
  windcoord(x1,y1,x2,y2);
  s:='';
  window(x,y,x+n-1,y);
  for i:=1 to n do s:=s+getch(i,1);
  window(x1,y1,x2,y2);
end;
{END OF GETFIELD------OK-----------------------------------------------------}

{PAINTFIELD-----------OK-----------------------------------------------------}
procedure paintfield(x,y,n,a:byte);
var i,x1,x2,y1,y2:byte;
begin
  windcoord(x1,y1,x2,y2);
  window(x,y,x+n-1,y);
  for i:=1 to n do putattr(i,1,a);
  window(x1,y1,x2,y2);
end;

{END OF PANINTFIELD-----OK---------------------------------------------------}

procedure DrawMode(var modef:byte);
 label 000;
 var tmpwin:screen;
     x1,y1,x2,y2:byte;
     c:char;
     cur:byte;

 procedure readkey(var c:char);
 var b:boolean;
 begin
   repeat
     inkey(c,b);
   until b=true;
 end;

begin
  cur:=4;
  crsoff;
  savewin(tmpwin);
  windcoord(x1,y1,x2,y2);

  window(6,2,30,10);
  colorize(1,1,24,9,black+16*red);
  border(1,1,24,9);
  showhelp('up,down-move cursor, enter-confirm, escape-cancel');

  putstring(8,1,'Select');
  putstring(4,4,'Work');
  putstring(4,7,'Debug');
  putcursor(4,cur,10);

  while true do
  begin
    readkey(c);
    case c of
        up:begin
             remcursor(4,cur,10);
             if cur=4 then cur:=10;
             cur:=cur-3;
             putcursor(4,cur,10);
           end;
      down:begin
             remcursor(4,cur,10);
             if cur=7 then cur:=1;
             cur:=cur+3;
             putcursor(4,cur,10);
           end;
     enter:begin
             case cur of
             4:begin
               modef:=1;
               sar[2]:='work';
               goto 000;
               end;
             7:begin
               modef:=2;
               sar[2]:='debug';
               goto 000;
               end;
             end;
           end;
    escape:goto 000;
       else;
       end;
     end;
000:;
  window(x1,y1,x2,y2);
  loadwin(tmpwin);
end;


procedure drawleng(var lengf:integer);
label 000;
var x1,y1,x2,y2:byte;
    tmpwin:screen;
    ts:string;
    c:char;

begin
  crsoff;
  ts:='';
  windcoord(x1,y1,x2,y2);
  savewin(tmpwin);

  window(22,2,44,12);
  colorize(1,1,22,10,black+16*red);
  border(1,1,22,10);
  putstring(3,2,'Enter Array Length');
  putstring(3,4,'max length for');
  putstring(3,5,'Work: 100');
  putstring(3,6,'Debug: 15');

  showhelp('Esc-cancel, Enter-confirm, left,right-move cursor');

  border(3,7,20,9);
  paintfield(25,9,16,white+16*black);
  readfield(37,9,4,enter+escape,ts,c);

  if c=enter then
  begin
    lengf:=toint(ts);
    goto 000;
  end;
  if c=escape then goto 000;

  wait;
000:;
  loadwin(tmpwin);
  window(x1,y1,x2,y2);
end;

procedure summary;
var x1,y1,x2,y2:byte;
    ts:string;
begin
  windcoord(x1,y1,x2,y2);
  window(60,3,80,23);
  colorize(1,1,20,20,black+16*red);
  border(1,1,20,20);
  crsoff;
  putstring(8,1,'Summary');

  putstring(4,4,'Method:');
  putstring(12,4,'qsort');

  putstring(4,6,'Mode:');
  case modef of
  0:putstring(10,6,'N/A  ');
  1:putstring(10,6,'Work ');
  2:putstring(10,6,'Debug');
  end;

  str(lengf,ts);

  putstring(4,8,'Length:');
  if lengf=0 then putstring(12,8,'N/A ')
             else begin
                  putstring(12,8,'    ');
                  putstring(12,8,ts);
                  end;

  window(x1,y1,x2,y2);
end;

(*Main Window---------------------------------------------------------------*)
procedure MainWindow(var mmf:byte);
label 000;
var
  top,bottom:string;
  slc:byte;
  c:char;
  b:boolean;

 procedure ShowMenu(ms:string);
 var i:byte;

 begin
   colorize(1,1,80,1,black+16*red);
   for i:=1 to length(ms) do putch(i,1,ms[i]);
 end;

 procedure readkey(var c:char);
 var b:boolean;
 begin
   crsoff;
   repeat
     inkey(c,b);
   until b=true;
 end;

 procedure putstring(x,y:byte; s:string);
 var i:byte;
 begin
   crsoff;
   for i:=1 to length(s) do
   putch(x+i-1,y,s[i]);
 end;


begin
  slc:=1;
  top:='   Method    Mode    Length   Start     Exit     ';
  bottom:='Left, Right to move around the menu, enter to choose';

  crsoff;                                  { Initial }
  window(1,1,80,25);                       {  menu   }
  colorize(1,1,80,1,black+16*red);   { look    }
  colorize(1,25,80,25,black+16*red); {         }
  colorize(1,2,80,24,red+16*black);  {         }
  showmenu(top);                           {         }
  showhelp(bottom);                        {         }
  putcursor(3,1,8);

  summary;
  crsoff;
  while true do
  begin
    inkey(c,b);
    if b=true then
    begin
      case c of
      left:begin
             remcursor(3+9*(slc-1),1,8);
             if slc=1 then slc:=6;
             slc:=slc-1;
             putcursor(3+9*(slc-1),1,8);

           end;
      right:begin
             remcursor(3+9*(slc-1),1,8);
             if slc=5 then slc:=0;
             slc:=slc+1;
             putcursor(3+9*(slc-1),1,8);

           end;
      enter:begin
              case slc of
              1:begin DrawMethod(methf); summary; end;
              2:begin DrawMode(modef); summary; end;
              3:begin DrawLeng(lengf); summary; end;
              4:begin exitf:=0; goto 000; end;
              5:begin exitf:=1; goto 000; end;
              end;

            end;
      end;

    end;
  end;
000:;
end;

(*End Of Main Window -------------------------------------------------------*)

function checkall:boolean;
label 000;
var x1,y1,x2,y2:byte;
    tmpwin:screen;

begin
windcoord(x1,y1,x2,y2);
savewin(tmpwin);
crsoff;
checkall:=true;


if modef=0 then
  begin
    senderr('Select mode');
    checkall:=false;
    goto 000;
  end;

if lengf=0 then
  begin
    senderr('Enter sequence length');
    checkall:=false;
    goto 000;
  end;

if modef=1 then
  if (lengf>100)or(lengf<=0) then
    begin
      senderr('Sequence length must be between 1 and 100');
      checkall:=false;
      goto 000;
    end;

if modef=2 then
  if (lengf>15)or(lengf<=0) then
    begin
      senderr('Sequence length must be between 1 and 15');
      checkall:=false;
      goto 000;
    end;

000:;
loadwin(tmpwin);
window(x1,y1,x2,y2);
end;
(*DrawWork*)
(*Quit*)

function date2str(dt:date):string;
  var ts:string;
  begin
    ts:='';
    ts:=tostr(dt.day)+'.'+tostr(dt.mth)+'.'+tostr(dt.yr);
    date2str:=ts;
  end;

{*QUICKSORT************************************************************}
{procedure qsort(var arr:seqc;l,r:integer);
var i,j,m,l,r:integer;
begin
if modef=2 then begin
  {output1}
  border(16,2,27,3+lengf);
  colorize(16,2,27,3+lengf,black+16*red);

  for i:=1 to lengf do
    putstring(17,2+i,date2str(arr[i]));
    wait;
  end;

  m:=l;            { pivot element (first in subarray) }
  i:=l+1; j:=r;

  if r-l=1 then                   { when a subarray is }
  begin                           { 2 datas long, swap }
    if compare(arr[l],arr[r])=1   { them if needed     }
    then swap(arr[l],arr[r]);     {                    }
  end                             {                    }
  else
  begin
    while i<j do                                     {  sequence        }
    begin                                            {    divides       }
      while compare(arr[i],arr[m])=-1 do i:=i+1;     {   subarray       }
      while compare(arr[m],arr[j])=-1 do j:=j-1;     {                  }
      if (i<j) and (compare(arr[i],arr[j])<>0) then  { at the end:      }
      begin                                          { j marks pivot    }
        swap(arr[i],arr[j]); i:=i+1; j:=j-1;         {                  }
      end;                                           { i usually marks  }
    end;                                             {   j+1            }
     if (i>=j)and(compare(arr[m],arr[j])>0)          {                  }
     then swap(arr[m],arr[j]);                       {                  }


     if (j>1)and(j-l>0) then { push left }
     qsort (arr,L,J-1);

     if (i<lengf)and(r-i>0) then  { push right }
     qsort (arr,i,r);

     if modef=2 then
     begin{output1}
     border(29,2,40,3+lengf);
     colorize(29,2,40,3+lengf,black+16*red);

     for i:=1 to lengf do
      putstring(30,2+i,date2str(arr[i]));
      wait;
     end;

  end;
end;
end;}

procedure quicksort(var a: seqc; l,r: integer);
  
  procedure sort(l,r: integer);
  var
    i,j,x,y: integer;
  begin
    i:=l; j:=r; x:=a[(l+r) DIV 2];
    repeat
      while a[i]<x do i:=i+1;
      while x<a[j] do j:=j-1;
      if i<=j then
      begin
        if a[i] > a[j] then BEGIN y:=a[i]; a[i]:=a[j]; a[j]:=y; END; {a[i]>a[j] - если хотим отсортировать массив по возрастанию}
        i:=i+1; j:=j-1;
      end;
    until i>j;
    if l<j then sort(l,j);
    if i<r then sort(i,r);
  end;
  
  begin {quicksort};
    sort(l,r);
  end;
{*END OF QUICKSORT**********************************}



procedure workmode;
lebel 1,3;
var x1,y1,x2,y2:byte;
    tmpwin:screen;

begin
  savewin(tmpwin);
  windcoord(x1,y1,x2,y2);
  crsoff;
  clrscr;
  randomize;
  seqgen(s1,s2,s3,s4,s5,lengf);
  swapcount:=0; cmprcount:=0;

  1:swapcount:=0; cmprcount:=0;
  qsort(s1,1,lengf);
  writeln(swapcount,' ',cmprcount);
  swapcount:=0; cmprcount:=0;
  qsort(s2,1,lengf);
  writeln(swapcount,' ',cmprcount);
  swapcount:=0; cmprcount:=0;
  qsort(s3,1,lengf);
  writeln(swapcount,' ',cmprcount);
  swapcount:=0; cmprcount:=0;
  qsort(s4,1,lengf);
  writeln(swapcount,' ',cmprcount);
  swapcount:=0; cmprcount:=0;
  qsort(s5,1,lengf);
  writeln(swapcount,' ',cmprcount);
  goto 3;

3:anykey;
  loadwin(tmpwin);
  window(x1,y1,x2,y2);

end;


procedure debugmode;

label 100,199,900,200;

var x1,x2,y1,y2:byte;
    tmpwin:screen;
    cp:byte;
    st:string;
    dates:seqc;
    k:char;
    c1:char; b1:boolean;
    b:boolean;
    i:integer;
  function date2str(dt:date):string;
  var ts:string;
  begin
    ts:='';
    ts:=tostr(dt.day)+'.'+tostr(dt.mth)+'.'+tostr(dt.yr);
    date2str:=ts;
  end;

  function parsedate(var d,m,y:integer; ds:string):boolean;
  var l,i:integer;
      d1,d2:integer;
      ts:string;
  begin
    parsedate:=true;
    l:=length(ds);
    d1:=pos('.',copy(ds,2,2)); {1st dot}(* d1={0,1,2} *)
    d2:=pos('.',copy(ds,4,3)); {2nd dot}(* d2={0,1,2,3} *)
    if (d1=0)or(d2=0) then {wrong dots!}
    begin
      parsedate:=false;
      exit;
    end;
    case d1 of
    1:case d2 of
      1:begin d1:=2; d2:=4; end;
      2:begin d1:=2; d2:=5; end;
      end;
    2:case d2 of
      2:begin d1:=3; d2:=5; end;
      3:begin d1:=3; d2:=6; end;
      end;
    end;{dots in string position}
    for i:=1 to d1-1 do
    if (ord(ds[i])<ord('0'))or(ord(ds[i])>ord('9')) then
    begin
      parsedate:=false;
      exit;
    end;
    for i:=d1+1 to d2-1 do
    if (ord(ds[i])<ord('0'))or(ord(ds[i])>ord('9')) then
    begin
      parsedate:=false;
      exit;
    end;
    for i:=d2+1 to l do
    if (ord(ds[i])<ord('0'))or(ord(ds[i])>ord('9')) then
    begin
      parsedate:=false;
      exit;
    end;
    ts:='';
    for i:=1 to d1-1 do ts:=ts+ds[i];
    d:=toint(ts);
    ts:='';
    for i:=d1+1 to d2-1 do ts:=ts+ds[i];
    m:=toint(ts);
    ts:='';
    for i:=d2+1 to l do ts:=ts+ds[i];
    y:=toint(ts);
  end;

  function checkdate(s:string):boolean;
  const minyear=1000;
        maxyear=3000;
  var d,m,y:integer;
  begin
    if parsedate(d,m,y,s)=false then
    begin
      checkdate:=false;
      exit;
    end;
    checkdate:=true;
{   writeln(d,m,y);
    wait;
}   if (y mod 4=0)and((y mod 100=0)and(y mod 400=0)) then
    begin
      {visokosny god}
      if ((m=2)and(d>29))or(d<1) then
      begin
        checkdate:=false;
        exit;
      end;
    end
    else
    begin
      if ((m=2)and(d>28))or(d<1) then
      begin
        checkdate:=false;
        exit;
      end;
    end;
    if (y<minyear)or(y>maxyear)then
    begin
      checkdate:=false; {za predely is4isleniya let}
      exit;
    end;
    if (m>12)or(m<1) then
    begin
      checkdate:=false; {za predely is4isleniya mesyacev}
      exit;
    end;
    if (d<1)or(d>31) then
    begin
      checkdate:=false;   {za predely is4isleniya dnej}
      exit;
    end;
    if ((m<=7)and(not odd(m)))or((m>=8)and(odd(m))) then
      if d=31 then
      begin
        checkdate:=false;  {31 den'}
        exit;
      end;
  end;

  function readdate(i:byte; var dar:seqc):char;{i-nomer v massive. 0..15}
  label 1;
  var str:string;
        k:char;
  begin
  1:readfield(3,4+i,10,up+down+escape+enter,str,k);
    if not checkdate(str) then
      begin
        senderr('Wrong Date');
        {readfield(3,4+i,10,up+down+enter+escape,str,k);}
        goto 1;
      end;
    anykey;
    readdate:=k;
    dar[i+1].day:=toint(copy(str,1,2));
    dar[i+1].mth:=toint(copy(str,4,2));
    dar[i+1].yr:=toint(copy(str,7,4));
  end;

  procedure putdate(i:byte; s:seqc);
  var d,m,y:string;
      td,tm,ty:string;
  begin
    if s[i+1].yr=0 then
      begin
        putfield(3,4+i,10,''); {o4istka polya}
        exit;
      end;
    str(s[i+1].day,td);
    str(s[i+1].mth,tm);
    str(s[i+1].yr,ty);
    if s[i+1].day<10 then d:='0'+td;
    if s[i+1].mth<10 then m:='0'+tm;
    y:=tm;
    putfield(3,4+i,10,d+'.'+m+'.'+y);
  end;

  procedure filldates(leng:integer; var Sq:seqc; var retc:boolean);
  label 0,1,99,2;              {0-exit, 1-next step}
  var sp:byte;
      td:date;
      str:string;
      k:char;
    procedure getdate(var dt:date; st:string);
    var d,m,y:integer;
        b:boolean;
    begin
      b:=parsedate(d,m,y,st);
      dt.day:=d;
      dt.mth:=m;
      dt.yr:=y;
    end;
  begin
  retc:=false;
  sp:=0;
  0:str:=date2str(sq[sp+1]);
  2:putfield(3,4+sp,10,str);
    readfield(3,4+sp,10,up+down+enter+escape,str,k);
    if k=up then
    begin
      if checkdate(str)=false then
        begin
          senderr('Wrong date');
          goto 2;
        end
      else
      begin
        getdate(sq[sp+1],str);
        if sp=0 then goto 0 else sp:=sp-1;
        goto 0;
      end;
    end;
    if (k=down)or(k=enter) then
    begin
      if checkdate(str)=false then
        begin
          senderr('Wrong date');
          goto 2;
        end
      else
      begin
        getdate(sq[sp+1],str);
        if sp+1=leng then goto 1 else sp:=sp+1;
        goto 0;
      end;
    end;
    if k=escape then
    begin
      retc:=false;
      goto 99;
    end;
1:retc:=true;
  goto 99;
99:;
  end;

begin
  savewin(tmpwin);
  windcoord(x1,y1,x2,y2);

  window(1,1,80,25);
  clrscr;
  crsoff;
  for cp:=0 to 15 do
  begin
    dates[cp+1].day:=0;
    dates[cp+1].mth:=0;
    dates[cp+1].yr:=0;
  end;

  colorize(1,1,14,24,black+16*lightgray);
  border(1,1,14,24);
  border(2,3,13,19);
  putstring(3,2,'DD.MM.YYYY');
  putstring(4,20,'START');
  putstring(4,22,'EDIT');
  cp:=0;{cursor pointer}
200:;
  filldates(lengf,dates,b);
  if b=false then goto 199
  else
  begin
    cp:=0;
100:b1:=false;
    crsoff;
    putcursor(4,20+cp,7);

    while not b1 do inkey(c1,b1);
    case c1 of
     up:
     begin
       remcursor(4,20+cp,7);
       if cp=0 then cp:=2
               else cp:=0;
       goto 100
     end;
     down:
     begin
       remcursor(4,20+cp,7);
       if cp=2 then cp:=0
               else cp:=2;
       goto 100
     end;
     enter:
     begin
       if cp=2 then
       begin remcursor(4,20+cp,7); goto 200; end;
     end;
     escape:goto 199;
     else begin goto 100; end;
    end;
  end;

  senderr('further work');
  qsort(dates,1,lengf);

  wait;
199:;
  loadwin(tmpwin);
  window(x1,y1,x2,y2);
end;

begin

textmode(3);
reset;
clrscr;
crsoff;
exitf:=0;
mmf:=0;
lengf:=0;
modef:=0;
methf:=0;

101:
MainWindow(mmf);
if (exitf=0) and (checkall=false) then goto 101;
if exitf=0 then
begin
  if modef=1 then
  begin workmode;
        goto 101;
  end;
  if modef=2 then
  begin debugmode;
        goto 101;
  end;

end;
reset;
clrscr;
end.