old/PAS/Lagrange/larg.pas

Uses CRT,GRAPH;
Const
 MinX : real = -1;
 MaxX : real = 9;
 MinY : real = MaxInt;
 MaxY : real = -MaxInt;
{---------------------}
 LagrTable = 10;
{---------------------}
 CStep = 1000;
 TVer = 0.01;
 ZX : word = 250;
 ZY : word = 200;
 Left  = 30;
 Right = 400;
 Top   = 20;
 Bottom = 400;
{-----------------------------}
Type
 LD = array [0..LagrTable] of record
  x,y : real;
 end;
 TB = array [0..LagrTable] of boolean;
var
  Thresh : real;
  Pts : LD;
  BegiP,
  EndiP : TB;

Function Func(x: real): real;
Begin
{ Func := ln(abs(x));}
{  Func := Sin(x)*x;}
   Func := 1.4*x+2;
{  Func := X*X/10 * sin (x/2)}
End;
{-----------------------------}
Function Lagr(X:real; var T : TB):real;
var
 i,j,n : word;
 c,ret : real;
begin
  n := LagrTable;
  ret:=0;
  for i := 0 to n do if T[i] then
   begin
    c:=1;
    for j := 0 to n do
     if (j <> i) AND T[j] then C := C  * (X-Pts[j].X) / (Pts[i].X-Pts[j].X);
    ret := ret + Pts[i].Y*C;
   end;
  Lagr := ret;
end;
{-----------------------------}
Procedure SetMinMax(var T:tb);
var
 c:real;
 i:word;
begin
  if MaxX < MinX then
   begin
    C := MaxX;MaxX := MinX;MinX := C;
   end;
  for i := 0 to Cstep do
   begin
     C := Lagr(MinX+i/CStep*(MaxX-MinX),T);
     if C > MaxY then MaxY:=C;
     if C < MinY then MinY:=C;
   end;
end;
{-----------------------------}
Procedure InitG;
Var
  grDriver: Integer;
  grMode: Integer;
  i : integer;
Begin
  grDriver := Detect;
  InitGraph(grDriver, grMode,'');
  if GraphResult <> grOk then
   begin
     WriteLn('Graph error!');
     Halt(255);
   end;
End;{InitG}
{---------------------------------}
Procedure DrawAxis;
var
 i : integer;
 s : string;
begin
  if (MinX < 0) AND (MaxX > 0) then
   begin
     ZX := round(Left + abs(MinX)/(MaxX-MinX)*(Right-Left));
   end
  else
   if MinX >= 0 then ZX := Left
                else ZX := Right;

  if (MinY < 0) AND (MaxY > 0) then
   begin
     ZY := round(Bottom - abs(MinY)/(MaxY-MinY)*(Bottom-Top));
   end
  else
   if MinY >= 0 then ZY := Bottom
                else ZY := Top;

  SetColor(White);
  Line(Left,ZY,Right+10,ZY);
  Line(Right-5,ZY-5,Right+10,ZY);
  Line(Right-5,ZY+5,Right+10,ZY);
  Line(ZX,Top-10,ZX,Bottom);
  Line(ZX,Top-10,ZX-5,Top+5);
  Line(ZX,Top-10,ZX+5,Top+5);
  OutTextXY(ZX-10,ZY-10,'0');
  OutTextXY(ZX-15,Top,'Y');
  OutTextXY(Right,ZY+10,'X');
  Str(MaxX:0:2,S);
  OutTextXY(Right,ZY-10,S);
  Str(MinX:0:2,S);
  if MinX<0 then OutTextXY(Left,ZY-10,S);
  Str(MaxY:0:2,S);
  OutTextXY(ZX+10,Top,S);
  Str(MinY:0:2,S);
  if MinY<0 then OutTextXY(ZX+10,Bottom,S);
end;
{--------------------}
Procedure LoadData;
var
 i : longint;
begin
  for i := 0 to LagrTable do
   begin
     Pts[i].x := MinX + i/LagrTable*(MaxX-MinX);
     Pts[i].y := Func(Pts[i].x);
     BegiP[i] := true;
     EndiP[i] := true;
   end;
end;
{--------------------}
Procedure FillTable(var T : TB);
var
 i:word;
 ax,ay : string;
begin
  SetFillStyle(SolidFill,Black);
  Bar(440,30,630,380);
  SetColor(Cyan);
  Rectangle(440,30,630,380);
  SetColor(Blue);
  for i := 0 to LagrTable do if T[i] then
   begin
     Str(Pts[i].x:0:2,aX); aX:='X'+Chr(i+$30)+'='+aX;
     Str(Pts[i].y:0:2,aY); aY:='Y'+Chr(i+$30)+'='+aY;
     SetTextJustify(LeftText,CenterText);
     OutTextXY(450,round(50 + i/LagrTable*300),aX);
     OutTextXY(550,round(50 + i/LagrTable*300),aY);
   end;
end;
{-----------------------------}
Procedure DrawLagr(var T : TB);
Var
 C : real;
 i : word;
 x, y : real;
Begin
  if (MaxY-MinY) > (MaxX-MinX) then
    C := (Bottom-Top)/(MaxY-MinY)
  else
    C := (Right-Left)/(MaxX-MinX);

  MoveTo(round(ZX+MinX*C),round(ZY-Lagr(MinX,T)*C));
  for i := 0 to CStep do
   begin
     x:=MinX + i/CStep*(MaxX-MinX);
     y:=Lagr(X,T);
     LineTo(round(ZX+X*C),round(ZY-Y*C));
   end;
End;{DrawLagr}
{-------------}
Function Check(var T1, T2 : TB):boolean;
var
 i : word;
 x, y1, y2 : real;
Begin
  Check := true;
  for i := 0 to CStep do
   begin
     x:=MinX + i/CStep*(MaxX-MinX);
     y1:=Lagr(X,T1);
     y2:=Lagr(X,T2);
     if abs(y1-y2) > Thresh then
      begin
       Check := false;
       Exit;
      end;
   end;
end;

var
 CKick  : word;
 ifDel  : boolean;
 cS     : word;

Begin
  LoadData;
  InitG;
  SetMinMax(BegIp);
  Thresh := TVer * (MaxY-MinY);
  DrawAxis;
{  WriteGraph(CStep);}
  FillTable(BegIp);
  SetColor(Green);
  DrawLagr(BegIp);
  CKick :=0;
  repeat
    ifDel := false;
    for cS := 0 to LagrTable do if EndiP[cS] then
      begin
        EndiP[cS] := false;
        if Check(BegiP,EndiP) then
         begin
           inc(CKick);
           ifDel := true;
         end
        else
         EndiP[cs] := true;
      end;
  until not ifDel;

  ReadKey;
  FillTable(EndiP);
  SetColor(White);
  DrawLagr(EndiP);
  ReadLn;
  CloseGraph;
  WriteLn('‚모­ãâ® â®ç¥ª - ',CKick);
End.