old/PAS/Lagrange/L2.PAS

Uses CRT,GRAPH;
Const
 MinX : real = -10;
 MaxX : real = -9;
 MinY : real = MaxInt;
 MaxY : real = -MaxInt;
{---------------------}
 LagrTable = 10;
{---------------------}
 CStep = 1000;
 TVer = 0.01;
 ZX : longint = 250;
 ZY : longint = 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;
 ZX1,ZY1 : longint;
begin
  if MinX > 0 then
    ZX := round(Left  - MinX/(MaxX-MinX)*(Right-Left))
  else
   if MaxX < 0 then
     ZX := round(Right - MaxX/(MaxX-MinX)*(Right-Left))
   else
     ZX := round(Left + abs(MinX)/(MaxX-MinX)*(Right-Left));

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

  if (ZX > Left) AND (ZX < Right) then ZX1 := ZX
  else
   if ZX < LEFT then ZX1 := Left
                else ZX1 := Right;

  if (ZY > Top) AND (ZY < Bottom) then ZY1 := ZY
  else
   if ZY < Top  then ZY1 := Top
                else ZY1 := Bottom;

  SetColor(White);
  Line(Left,ZY1,Right+10,ZY1);
  Line(Right-5,ZY1-5,Right+10,ZY1);
  Line(Right-5,ZY1+5,Right+10,ZY1);
  Line(ZX1,Top-10,ZX1,Bottom);
  Line(ZX1,Top-10,ZX1-5,Top+5);
  Line(ZX1,Top-10,ZX1+5,Top+5);
  OutTextXY(ZX1-10,ZY1-10,'0');
  OutTextXY(ZX1-15,Top,'Y');
  OutTextXY(Right,ZY1+10,'X');
  Str(MaxX:0:2,S);
  OutTextXY(Right,ZY1-10,S);
  Str(MinX:0:2,S);
  if MinX<0 then OutTextXY(Left,ZY1-10,S);
  Str(MaxY:0:2,S);
  OutTextXY(ZX1+10,Top,S);
  Str(MinY:0:2,S);
  if MinY<0 then OutTextXY(ZX1+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);}
  if (MaxY-MinY) > (MaxX-MinX) then
   begin
    if MaxY*MinY < 0 then
      C := (Bottom-Top)/(MaxY-MinY)
    else
     if MaxY < 0 then C:=(Bottom-Top)/abs(MinY)
                 else C:=(Bottom-Top)/MaxY;
   end
  else
   begin
    if MaxX*MinX < 0 then
      C := (Right-Left)/(MaxX-MinX)
    else
     if MaxX < 0 then C := (Right-Left)/abs(MinX)
                 else C := (Right-Left)/MaxX;
   end;
  MoveTo(round(ZX + MinX*C),round(ZY-Lagr(MinX,T)*C));
  for i := 1 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.