{ Žâ§ë¢ë ¯à¨áë« âì ­  áª« ¤ ­¨âà®¬ ­¨â  nitromanit@mail.ru

  „ ­­ ï ãâ¨«¨â  á®¤¥à¦¨â äã­ªæ¨î ReadTimer á ¯®¬®éìî ª®â®à®©
  ¬®¦­® ¯à®ä¨«¨à®¢ âì (¨áá«¥¤®¢ âì ®â« ¦¨¢ ¥¬ãî ¯à®£à ¬¬ã ­ 
  ¡ëáâà®¤¥©áâ¢¨¥) ¨ ¯à®áâ® ¤¥« âì ¢à¥¬¥­­ë¥ § ¬¥àë ¢ ¯à®£à ¬¬ å,
  à¥£« ¬¥­â¨à®¢ âì ¤¢¨¦¥­¨ï ¯¥àá®­ ¦¥© ¢ è¨å ¨£à ¨ â ª ¤ «¨¥.
  Žáâ «ì­ë¥ äã­ªæ¨¨ å®âì ï ¨ á®§¤ « ­® á¥àì¥§­® ¯à¨¬¥­ïâì ­¥
  ¤®¢¥«®áì
}

unit profiler;

interface

 Uses crt;

function ReadTimer:longint;
function ReadOscelator:word;
function TimeReportStr(x:longint):string;
procedure TimeReport(msg:string;x:longint);
procedure Pause(p:longint);  {p=1/18.2 sec ; p=1092  -  1 mines }
procedure MemReport;
procedure print(x,y:byte;s:string);
procedure fill(l:byte;c:char;var s:string);
function PreStr(i:longint;l:byte):string;
function RetStr(i:longint):string;
procedure InitTestWindow(x,y,tcolor,bcolor,tinterval:byte;max:longint);
procedure TestWindow(i:longint);

implementation

var istime,startime,testmax:longint;
    testX,testY,testcolor,backcolor,timeint:byte;

function ReadTimer:longint;assembler;
asm
   push es
   push di
   mov ax,0040h
   mov es,ax
   mov di,006ch
   mov ax,es:[di]
   inc di
   inc di
   push ax
   mov ax,es:[di]
   mov dx,ax
   pop ax
   pop di
   pop es
end;

function ReadOscelator:word;assembler;
asm
   push dx
   mov dx,40h
   in al,dx
   xchg al,ah
   in al,dx
   xchg al,ah
   pop dx
end;

procedure Pause(p:longint);  {p=1/18.2 sec ; p=1092  -  1 mines }
var t1,t:longint;
begin
     t1:=readtimer;
     repeat
           t:=readtimer;
     until t=t1+p;
end;

procedure TimeReport(msg:string;x:longint);
begin
{m:=trunc(x/1092);
s:=trunc(x-(m*1092))/18.2;
s100:=(x-trunc(s*18.2)-(m*1092))*54.945054;
writeln(msg,': ',m:2:0,':',s:2:3,' sec');}
writeln(msg+TimeReportStr(x)+' sec');
end;

function TimeReportStr(x:longint):string;
var m,s,s100:real;
    sr1,sr2:string;
begin
m:=trunc(x/1092);
s:=trunc(x-(m*1092))/18.2;
{s100:=(x-trunc(s*18.2)-(m*1092))*54.945054;}
str(m:2:0,sr1);
str(s:2:3,sr2);
TimeReportStr:=sr1+':'+sr2;
end;

procedure MemReport;
begin
writeln('memory free ',memavail,' bytes ',maxavail);
end;

procedure print(x,y:byte;s:string);
begin
gotoXY(x,y);write(s);
end;

procedure fill(l:byte;c:char;var s:string);
var i:word;
begin
s[0]:=char(0);
for i:=1 to l do s:=s+c;
end;

function RetStr(i:longint):string;
var s:string;
begin
str(i,s);
RetStr:=s;
end;

function PreStr(i:longint;l:byte):string;
var s:string;
    o:word;
    sl:byte;
begin
str(i,s);
sl:=byte(s[0]);
if sl=l then begin PreStr:=s;exit;end;
for o:=1 to l-sl do s:=' '+s;
PreStr:=s;
end;

procedure InitTestWindow(x,y,tcolor,bcolor,tinterval:byte;max:longint);
begin
testX:=x;testY:=y;testcolor:=tcolor;backcolor:=bcolor;
timeint:=tinterval;testmax:=max;
istime:=readtimer;
startime:=istime;
end;

procedure TestWindow(i:longint);
var p,line:byte;
    mem,s2,m2,h2:word;
    r,h,m,m1,s1,sec:real;
    s:string;
    t:longint;
begin
t:=readtimer;
if istime>t then
   if i<testmax then exit;
istime:=t+timeint;
r:=i/testmax;
p:=trunc(100*r);line:=trunc(40*r);
t:=t-startime;
h:=trunc(t/65520);
h2:=trunc(h);
m1:=65520*h;
m:=trunc((t-m1)/1092);
m2:=trunc(m);
s1:=(t-m1-(m*1092));
sec:=trunc(s1/18.2);
s2:=trunc(sec);
mem:=trunc(memavail/1024);
textcolor(testcolor);
textbackground(backcolor);
print(testx,testy,'ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄTestingÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿');
print(testx,testy+1,'³ ²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²²    % ³');{Û}
fill(line,'Û',s);
print(testx+2,testy+1,s);print(testx+43,testy+1,prestr(p,3));
print(testx,testy+2,'³ Total'+prestr(testmax,16)+'                         ³');
print(testx,testy+3,'³ Index'+prestr(i,16)+'                         ³');
print(testx,testy+4,'³ Time'+prestr(h2,11)+':'+prestr(m2,2)+':'+prestr(s2,2)+' sec                     ³');
print(testx,testy+5,'³ Free memory'+prestr(mem,10)+' K                       ³');
print(testx,testy+6,'ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ');
textcolor(7);
textbackground(0);
end;

end.