old/PAS/Integrir/trap.pas

Uses CRT,Graph;
CONST
  minX          = 59.0;
  maxX          = 60.0;
  ifWrite       = true;
  LenX          = maxX-minX;
  writeFrames   = 1000;
  BegX          = 80;
  BegY          = 400;
  SIZE_Y        = 320;
  SIZE_X        = 340;
  Eps           = 0.0001;
{---------------------------------------------------------------}
VAR
   Area                 : real;
   maxY                 : real;
   Ntr                  : longint;
{---------------------------------------------------------------}
Function F_X(X:real):real;
begin
{  F_X := sqrt(X)*(x);}
{   F_X := sqrt(40000-x*x);}
  F_X := sin(49*x*PI/180)*cos(12.5*x*PI/180)+1;
{  F_X := sin(X)*cos(X*PI/180)+1;}
{   F_X := 1/x+1;}
end;{F_X}
{---------------------------------------------------------------}
Procedure Init;
var
  grDriver   : Integer;
  grMode     : Integer;
  ErrCode    : Integer;
  value      : String;
  i          : word;
  cur        : real;

begin
  grDriver := Detect;
  InitGraph(grDriver, grMode,' ');
  ErrCode := GraphResult;
  if ErrCode <> grOk then
  begin
    Writeln('Graphics error: ', GraphErrorMsg(ErrCode));
    Halt(ErrCode);
  end;
  SetFillStyle(XHatchFill,Blue);
  Bar(0,0,GetMaxX,GetMaxY);
  SetFillStyle(SolidFill,Black);
  Bar(10,10,GetMaxX-10,GetMaxY-10);
  SetColor(Green);
  Rectangle(10,10,500,469);
  SetColor(white);
  Line(79,401,79,81);
  Line(79,81,75,88);
  Line(79,81,83,88);
  Line(79,401,419,401);
  Line(419,401,412,405);
  Line(419,401,412,397);
  SetTextJustify(CenterText,TopText);
  Str(minX:0:0,value);
  OutTextXY(79,408,value);
  Str(maxX:0:0,value);
  OutTextXY(419,408,value);
  SetTextJustify(RightText,CenterText);
  maxY := -MaxInt;
  for i := 0 to 1000 do
   begin
     cur := F_X(((lenX*i)/1000)+minx);
     if cur > maxY then
       maxY := cur;
{     if cur < minY then
       minY := cur; }
    end;
  Str(maxY:0:2,value);
  OutTextXY(76,85,value);
  OutTextXY(76,401,'0');
end;{Init}
{--------------------------------------------------------------}
Procedure WriteGraph;
var
  i:word;
  x:real;
  y:real;
begin
  SetColor(Magenta);
  MoveTo(BegX,round(BegY- ( (F_X(minX)/maxY)*SIZE_Y) ));
  for i := 1 to WriteFrames do
  begin
    x:=(lenX*i)/WriteFrames+minX;
    y:=F_X(X);
    LineTo(
           round(BegX + ((x-minX)/lenX)*SIZE_X ),
           round(BegY - (y/maxY)*SIZE_Y )
          );
  end;
end;{WriteGraph}
{--------------------------------------------------------------}
Procedure ShowTrap(x1,x2,y1,y2:real);
begin
  SetColor(Yellow);
  MoveTo(round(BegX + ((x1-minX)/lenX)*SIZE_X ),BegY);
  LineTo(round(BegX + ((x2-minX)/lenX)*SIZE_X ),BegY);
  LineTo(round(BegX + ((x2-minX)/lenX)*SIZE_X ),round(BegY - (y2/maxY)*SIZE_Y ));
  LineTo(round(BegX + ((x1-minX)/lenX)*SIZE_X ),round(BegY - (y1/maxY)*SIZE_Y ));
  LineTo(round(BegX + ((x1-minX)/lenX)*SIZE_X ),BegY);
end;{ShowTrap}
{--------------------------------------------------------------}
FuncTion ReDraw:char;
var
  val:string;
begin
 SetColor(Red);
 Bar(505,30,630,100);
 OutTextXY(510,40,'Last Area:');
 Str(Area:0:9,val);
 OutTextXY(510,50,val);

 OutTextXY(510,70,'Number:');
 Str(NTr,val);
 OutTextXY(510,80,val);
 redRaw := ReadKey;
 Bar(BEGX,BEGY,BEGX+SIZE_X,BEGY-SIZE_Y);
 WriteGraph;
end; {ReDraw}
{--------------------------------------------------------------}
Procedure CalcArea;
var
  LastAr : real;
  i      : longint;
  y1,y2  :real;
  c      : char;
begin
  LastAr := 0;
  Ntr    := 1;
if IfWrite then begin
  SetFillStyle(SolidFill,Black);
  SetTextJustify(LeftText,CenterText);
  ReDraw;
end;
  repeat
   LastAr := Area;
   Area   := 0;
   for i := 1 to Ntr do
    begin
      y1 := F_X((lenX*(i-1))/Ntr + minX);
      y2 := F_X((lenX*i)/Ntr + minX);
      if ifWrite then ShowTrap((lenX*(i-1))/Ntr + minX,(lenX*i)/Ntr + minX,y1,y2);
      Area := Area + ((y1+y2)/2)*(lenX/Ntr);
    end;
    if ifWrite then c:=ReDraw;
    Ntr:=Ntr shl 1;
    if ord(c)=27 then exit;
  until abs(Area-LastAr)<Eps;
end;{CalcArea}
{--------------------------------------------------------------}
VAR
   i : word;
BEGIN
if ifWrite then
 begin
  Init;
  WriteGraph;
 end;
  CalcArea;
if ifWrite then CloseGraph;
  WriteLn('Area: ',Area:0:4);
END.