old/PAS/Lagrange/L3.PAS

Uses CRT,GRAPH;
Const
 MinX : real = 1;
 MaxX : real = 10;
 MinY : real = MaxInt;
 MaxY : real = -MaxInt;
{---------------------}
 LagrTable = 20;
{---------------------}
 CStep = 1000;
 TVer = 0.01;
 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
  SetColor(White);
  Line(Left,Bottom,Right+10,Bottom);
  Line(Right-5,Bottom-5,Right+10,Bottom);
  Line(Right-5,Bottom+5,Right+10,Bottom);
  Line(Left,Top-10,Left,Bottom);
  Line(Left,Top-10,Left-5,Top+5);
  Line(Left,Top-10,Left+5,Top+5);
  OutTextXY(Left-15,Top,'Y');
  OutTextXY(Right,Bottom+10,'X');
  Str(MaxX:0:2,S);
  OutTextXY(Right,Bottom-10,S);
  Str(MinX:0:2,S);
  OutTextXY(Left,Bottom-10,S);
  Str(MaxY:0:2,S);
  OutTextXY(Left+10,Top,S);
  Str(MinY:0:2,S);
  OutTextXY(Left+10,Bottom,S);
end;
{--------------------}
Procedure LoadData;
var
 i : longint;
begin
  for i := 0 to LagrTable do
   begin
     Pts[i].x := MinX + sqrt(i)/Sqrt(LagrTable)*(MaxX-MinX);
{     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,j:word;
 ax,ay : string;
begin
  SetFillStyle(SolidFill,Black);
  Bar(440,30,630,380);
  SetColor(Cyan);
  Rectangle(440,30,630,380);
  SetColor(Blue);
  j := 0;
  for i := 0 to LagrTable do if T[i] then
   begin
     Str(Pts[i].x:0:2,aX); aX:='X'+Chr(j+$30)+'='+aX;
     Str(Pts[i].y:0:2,aY); aY:='Y'+Chr(j+$30)+'='+aY;
     SetTextJustify(LeftText,CenterText);
     OutTextXY(450,round(50 + i/LagrTable*300),aX);
     OutTextXY(550,round(50 + i/LagrTable*300),aY);
     inc(j);
   end;
end;
{-----------------------------}
Procedure DrawLagr(var T : TB);
Var
 Cx,Cy : real;
 i : word;
 x, y : real;
Begin
  Cx := (Right-Left) / (MaxX-MinX);
  Cy := (Bottom-Top) / (MaxY-MinY);

  MoveTo(Left,round(Bottom-(Lagr(MinX,T)-MinY)*Cy));
  for i := 0 to CStep do
   begin
     x:=MinX + i/CStep*(MaxX-MinX);
     y:=Lagr(X,T);
     LineTo(round(Left+(X-MinX)*Cx),round(Bottom-(Y-MinY)*Cy));
   end;
  SetColor(Red);
  for i:=0 to Lagrtable do if T[i] then
    Circle(round(Left+(Pts[i].X-MinX)*Cx),round(Bottom-(Pts[i].y-MinY)*Cy),2);
End;{DrawLagr}
{-------------}
Function Check(var T1, T2 : TB):boolean;
var
 i : word;
 x, y1, y2 : real;
 Step : word;
Begin
  Check := true;
  Step := CStep div 10;
  for i := 0 to Step do
   begin
     x:=MinX + i/Step*(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;
  for cS := 1 to LagrTable-1 do
  begin
    EndiP[cS] := false;
    if Check(BegiP,EndiP) then
{    if abs(Lagr(Pts[cS].X,BegIP)-Lagr(Pts[cS].X,EndIP)) < Thresh then}
     inc(CKick)
    else
     EndiP[cs] := true;
  end;

  ReadKey;
  FillTable(EndiP);
  SetColor(White);
  DrawLagr(EndiP);
  ReadLn;
  CloseGraph;
  WriteLn('Выкинуто точек - ',CKick);
End.