Описание среды Delphi

Листинг 2. Процедуры прямого масштабирования

function II {х: real): integer;

begin

II:=I1+Trunc((12-I1) *(x-xl)/(x2-xl));

end;

function JJ(y: real): integer;

begin

JJ:=Jl+Trunc((J2-Jl)*(y-y2)/(yl-y2));

end;

Листинг 2. Процедуры обратного масштабирования

function XX (i: integer): real;

begin

end;

function YY(j: integer): real;

begin

YY:=yl+(j-j2)*(y2-yl)/(Jl-J2);

end;

Листинг 3. Процедура обработки нажатия клавиши мыши

procedure TForml. Image !MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

var i: integer; Min,r: real;

begin

Drawing:= True;

Imagel.Canvas.MoveTo(X, Y);

Num:=0; Min:=Sqr(XX(X)-xt[Num])+Sqr(YY(Y)-yt[Num]);

for i:=l to n do

begin

r:=Sqr(XX(X)-xt[i])+Sqr(YY(Y)-yt[i]);

if r<Min then begin Num:=i; Min:=r; end;

end;

Origin:= Point(II(Xt[Num]),JJ(Yt[Num]));

MovePt := Origin;

end;

Во время перемещения работает процедура ImageIMouseMove, в которой в режиме pmNotXor сначала стирается старое изображение кривой, а затем выводится новое.

Листинг 4. Процедура обработки перемещения мыши

procedure TForml.ImagelMouseMove(Sender: TObject;

Shift: TShiftState; X, Y: Integer);

begin

if Drawing then

begin

DrawShape(Origin, MovePt, pmNotXor);

MovePt := Point(X,Y);

xt[Num]:=XX(X); yt[Num]:=YY(Y);

DrawShape(Origin, MovePt, pmNotXor);

end;

end;

Заканчивается движение вызовом процедуры ImagelMouseUp, в которой прорисовывается линия в режиме ртСору и опускается флаг перемещения Drawing:=False

Листинг 5. Процедура обработки нажатия клавиши мыши

procedure TForml.ImagelMouseUp(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

begin

if Drawing then

begin

DrawShape(Origin, Point(X, Y), pmCopy);

Drawing:= False;

end;

end;

Приведем текст программы, использующей функцию Lagr для построения графика по множеству точек (хi, уi), i=0,l,...,n..

Листинг 6. Процедура

unit Unitl;

interface

uses

procedure TForml.Rectl(a,b: integer);

const c4=2;

begin

with Imagel.Canvas do RectAngle(a-c4,b-c4,a+c4,b+c4);

end;

Procedure TForml.SetLagr;

var i_: integer;

begin

with Imagel.Canvas do

begin

RectAngle(-1,-1,Width,Height);

{Построение осей координат}

MoveTo(II(0),JJ(Y1)); LineTo(II(0),JJ(Y2));

MoveTo(II(xl),JJ(0)); LineTo (II (x2),JJ(0));

{Построение графика функции}

h:=(xt[n]-xt[0])/m; u:=xt[0]; v:=Lagr(n,u,xt,yt);

MoveTo(lI(u),JJ(v))

for i:=l to m do

begin

u:=u+h; v:=Lagr(n,u,xt,yt);

LineTo(IKu),JJ(v));

end;

for i:=0 to n do Rectl(II(xt[i]),JJ(yt[i]));

end;

end;

procedure TForml.FormActivate(Sender: TObject);

begin

Drawing := False;

with Imagel do

begin

Il:=0; Jl:=0; I2:=Width; J2:=Height;

{окно на экране }

end;

SetLagr;

end;

procedure TForml.DrawShape(TopLeft,BottomRight: TPoint;

AMode: TPenMode);

var i: integer;

begin

with Imagel.Canvas do

begin

Pen.Mode := AMode; {Построение графика функции}

h:={xt[n]-xt[0])/m; u:=xt[0]; v:=Lagr(n,u/xt,yt);

MoveTo(II(u),JJ(v));

for i:=1 to m do

begin

u:=u+h; v:=Lagr(n,u,xt,yt);

LineTo(lI(u),JJ(v));

end;

for i:=0 to n do Rectl(II(xt[i]),JJ(yt[i]));

end;

end;

end.

Метод наименьших квадратов

Методом наименьших квадратов можно искать интерполяционную функцию F(x) среди многочленов степени М:

F(x){S(x)=a_ix^j} (1.2)

так, чтобы сумма квадратов отклонений была минимальна:

D=(a_jx^j _i-y_i) min (1.3)

При этом функция F(x), вообще говоря, не проходит через точки (хi, yi).

Для определения коэффициентов a_j, j=0,...,m запишем необходимые условия экстремума:

D = 0, R= 0,1,…,n (1.4)

a_R

или

x_i^R (a_jx^j _i - y_{i )}=0, R=1,…, m (1.5)

После преобразований получаем следующую систему линейных уравнений:

C_Rj a_j = B_R, R=0,…, m (1.6)

где

C_Rj = x_i ^R+j, B_R = x_i^R yⁱ. (1.7)

Для вычисления элементов матрицы линейных уравнений по формулам (1.7) и pешения этой системы методом Гаусса можно воспользоваться процедурой Gauss. Необходимо отметить, что система линейных уравнений для метода наименьших квадратов, как правило, хорошо обусловлена и не имеет нулевых элементов, а это позволяет максимально упростить алгоритм решения системы.

В процедуре Gauss параметры имеют следующий смысл: п+1 -- число точек;

m -- степень многочлена; х, у -- массивы узловых точек; с -- массив коэффициентов многочлена.

Листинг 7. Процедура

procedure Gauss(n,m: Byte; х,у: Vect; var c: Vect_m);

var A: Matr; b: Vect_M;

i,j,k,l: Byte; P: Real;

begin

{коэффициенты матрицы)

for j:=0 to m do

for k:=j to m do

begin

A[j,k]:=0;

for i:=0 to n do

begin

p:=l; for 1:=1 to j+k do p:=p*x[i];

A[j,k]:=A[j,k]+P;

end;

end;

{свободные члены}

for k:=0 to m do

begin

B[k]:=0;

for i: =0 to n do

begin

P:=y[i]; for 1:=1 to k do P:=P*x[i];

B[k]:=B[k]+P;

end;

end;

{решение системы: прямой ход}

for i:=0 to m-1 do

for j: = i + l to m do

begin

for k:=i+l to m do

A[k,j]:= A[k,j]- A[i,j]* A[k,j]/ A[i,i];

B[j]:=B[j]-B[i]*A[i,j]/A[i,i];

end;

{решение системы: обратный ход}

for j: =m downto 0 do

begin

c[j]:=B[j];

for k:=j+l to m do с [ j ]:=c [ j ] -A[k, j ] *c [k];

c[j]:=c[j]/A[j,j];

end;

end;

Ниже приводится текст программы, в которой для массива (хi,уi), i=0,...,n методом наименьших квадратов определяются коэффициенты многочлена четвертой степени и сроится график этого многочлена.

Листинг 8. Процедура

unit Unitl;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Buttons, ExtCtrls;

type

TForml = class(TForm)

Panell: TPanel;

Panel2: TPanel;

Imagel: TImage;

SpeedButtoril: TSpeedButton;

procedure SpeedButtonlClick(Sender: TObject);

procedure FormActivate(Sender: TObject);

private

{ Private declarations }

procedure Rectl(a,b: integer);

public

{ Public declarations }

end;

var

Forml: TForml;

const n=7; {n+1 - число узловых точек }

m=4; {степень многочлена }

type Vect = array[O..n] of real;

Vect_M = array[0..m] of Real;

Matr = array[0..m,0..m] of Real;

const p=50; {число точек между узловыми точками }

al=-l; a2=10; bl=-4; Ь2=10; {окно на бумаге }

{ координаты узловых точек }

х: Vect=(1.0,2.О,3.0,4.О,5.О, 6.О,7.5, 8. 8);

у: Vect=(1.0,2.3,3.4,2.5,3.7,4.8,3.2,2.1);

var i: Byte; Gr,Gm: Integer;

I1,J1,I2,J2: integer; {окно на экране

h, {шаг между узловыми точками }

u0,v0,u,v: Real; {x,y между узловыми точками }

с: Vect_M;

implementation

{$R *.DFM}

function F(m: Byte; x: Real; c: Vect_M): Real;

{Вычисление значения многочлена}

var i: Byte; y: Real;

begin

y:=0;

for i:=m downto 0 do y:=y*x+c[i];

F:=y;

end;

procedure TForml.SpeedButtonlClick(Sender: TObject);

begin

Close;

end;

procedure TForml.Rectl(a,b: integer);

const c4=2;

begin

with Imagel.Canvas do RectAngle(a-c4,b-c4,a+c4,b+c4);

end;

procedure TForml.FormActivate(Sender: TObject);

var i: integer;

begin

Gauss(n,m,x,y,c);

with Imagel.Canvas do

begin

Il:=0; Jl:=0; I2:=Width; J2:=Height;

{окно на экране }

MoveTo(II(al),JJ(0)); LineTo(II(a2),JJ(0));

MoveTo(IKO),JJ(bl));

LineTo(IKO),JJ(b2));

for i:=0 to n do Rectl(II(x[i]),JJ(y[i]));

{Построение графика функции}

h:=(x[n]-x[0])/p_; u:=x[0]; v:=F(m,u,c);

MoveTo(II (u), JJ(v)); for i:=l to p do begin

u:=u+h; v:=F (m,u,c);

LineTo (II (u),JJ (v));

end;

end;

end;

end.

Сплайны

Сплайн-функция интерполирует значения (х_i, yi) набором функций, каждая из которых определена на интервале [x_i-1,xj]:

* функция S(x) проходит через все точки (хi, yi): S(xi)=yi, i=0,...,n;

* на всем интервале [x₀,xn ] функция S(x) дважды непрерывно дифференцируема.

Будем считать, что на i-м интервале сплайн-функция определяется многочленом третьей степени:

S(x) = a(x-x)³ + b(x-x)² + c(x-x) + d,i=l,...n. (1.8)

Необходимо определить 4*п коэффициентов ai, bi, ci, di. Условия прохождения многочленов через узловые точки дают 2*n уравнений:

S(x) = d=y (1.9)

Sⁱ (xⁱ) = ⁱaD³ⁱ+bD² + cD +y =y , i=l,...,n,D =x -x, (1.10)

Условие гладкости первых производных во внутренних точках дает n-1 соотношений

S'(x)=S '(х)

с=3а D ²+2b D +с , i=l,...,n-l. (1.11)

Условие гладкости вторых производных дает еще n-1 соотношений

S"(x) = S "(x) (1.12)

или

2b =6a D +2b , i=l,...,n-l. (1.13)

Два недостающих условия следуют из условия обращения в ноль вторых ппо яых на границах интервала

S "(хО) = 0 и S "(х) = 0: 1 n n

6a D +2b =0,D =x -x

b=0

Из соотношений (1.12) и (1.13) найдем аi:

(b -b )/(3D ), i=2,3…,n,

a_i= i-1 i i

-b/(3D ), i=1. (1.14)

Подставим аi в соотношение

(b -b)D²/3+b D² + c D+у =у , i=2,…,n

2b D ² + c D = y -y , i=1

и найдем сi:

(y -y)/ D - D b /3-2 D b /3, i=2,…,n,

(y -y)/D -b D /3.

После исключения коэффициентов а_i и bi из соотношения (1.10) и преобразования для коэффициентов bi получаем трехдиагональную систему линейных уравнений:

2*(D1+D2)*b1 b2*D2 -(y1-y2) y0-y1 (1.17)

bi-1 Di 2(Di+Di+1) bi bi+1 Di+1 yi-yi+1 yi-1 -yi , i=2,…,n-1

Рассмотрим теперь решение трехдиагональной системы линейных уравнении:

Трехдиагональная система решается в два прохода: за первый проход элементы матрицы под диагональю преобразуются в 0, за второй, обратный, ход определяются x_i, i=l,...,n. Для решения трехдиагональных систем можно воспользоваться процедурой System_3D, которая получает массивы a,b,c,d: Vect=array[l..n] of Real и возвращает решение через массив d.

Листинг 9. Процедура

procedure System_3D(n: Byte; a,b,c: Vect; var d: Vect);

{решение трехдиагональных систем}

var i: Byte;

begin

{прямой ход}

for i:=2 to n do

begin

b[i]:=b[i]-c[i-1]*a[i]/b[i-1];

d[i]:=d[i]-d[i-1]*a[i]/b[i-1];

end;

{обратный ход}

d[n]:=d[n]/b[n];

for i:=n-l downto 1 do

end;

Для определения коэффициентов многочленов (1.8) по формулам (1.17), (1.16), (1.14) и (1.10) можно воспользоваться процедурой Sp(n: Byte; x,y: Vect; var a,b,c,d:Vect), которая получает число узловых точек n: Byte, массивы координат узловых точек х,у: Vect и возвращает коэффициенты многочленов третьей степени a,b,c,d: Vect.

Листинг 10. Процедура

procedure Sp(n: Byte; x,y: Vect; var a,b,c,d: Vect);

var i_: Byte;

delt, {x[i-l]-x[i]}

p,q,r,w: Vect; {коэффициенты системы}

begin

r->r i:=l to n do delt [i]: =x [i-1] -x[i];

{Вычисление коэффициентов для системы уравнений }

for i:=l to n-1 do

begin

w[i]: =-(y[i]-y[i+l]) /delt [i+l]+(y [i-1] -y[i])/delt[i];

p[i]:=delt[i]/3;

q[i]:=2*(delt[i]+Delt[i+l])/3;

r[i]:=delt[i+l]/3;

end;

{ Решение трехдиагональной системы уравнений}

System_3D(n-l,p_/q,r,w);

for i:=l to n-1 do b[i]:=w[i]; b[n]:=0;

{Вычисление остальных коэффициентов многочлена}

с[1]:=(y[0]-y[l])/delt[l]-2*b[l]*delt[l]/3;

а[1]:=-b[l]/(3*delt[l]); d[l]:=y[l];

for i:=2 to n do

begin

d[i]:=y[i]; a[i]: = (b[.i-l] -b[i]) / (3*delt [i]);

c[i]: = (y [i-1] -y[i]) /delt [i] -delt [i]*b '[i-1] /3-2*delt[i]*b[i]/3;

end;

end;

Ниже приводится текст программы, в которой задаются массивы координат узло вых точек, вычисляются коэффициенты для многочленов сплайна и строится графи функции по этим многочленам.

Листинг 11. Процедура

const n=7; {п+1 - число узловых точек } type Vect=array [0..n] of real;

const m=5; {число точек между узловыми точками }

al=-l; a2=10; bl=-5; Ь2=10; {окно на бумаге }

{ координаты узловых точек }

х: Vect=(1.0, 2. О, 3.0, 4. О, 5. О, 6. О, 7. 5, 8. 8);

у: Vect= (1.0,2.3,3.4,2.5,3.7,4.8,3.2,2.1);

var a,b,c,d: Vect; {коэффициенты многочленов } I1,J1,I2,J2: integer; {окно на экране }

h, {шаг между узловыми точками }

u,v: Real; {x,y между узловыми точками }

function F(i: Byte; u: Real): Real;

begin

F:=((a[i]*(u-x[i])+b[i])*(u-x[i])+c[i])*(u-x[i])+d[i];

end;

procedure TForml.FormActivate (Sender: TObject);

var i,J: integer;

begin

with Imagel.Canvas do

begin

Il:=0; Jl:=0; I2:=Width; J2:=Height;

{окно на экране }

Sp(n,x,y,a,b,c,d);

{вычисление коэффициентов многочлена}

{Оси системы координат и узловые точки}

MoveTo(II (al), JJ(0)); LineTo(II (a2), JJ(0));

MoveTo(II(0),JJ(bl)); LineTo(IKO),JJ(b2));

for i:=0 to n do Rectl (II (x[i]), JJ(y [i]));

{Построение графика функции}

for i:=l to n do

begin

h:=(x[i]-x[i-1])/m; u:=x[i-1]; v:=F(I,u);

MoveTo(II(u),JJ(v);

for j:=1 to m do

begin

u:=x[i-l]+j*h; v:=F(i,u); LineTo (II (u), JJ (v));

end;

end;

end;

end;

Кривые Безье и координатный указатель курсора

В следующем примере выполняется рисование кривой Безье и вместе с этим вводится координатный указатель курсора: на рисунке квадратиками отображены точки, по которым строится кривая Безье, оси координат, сама кривая и, самое интересное, куда бы вы ни поместили курсор, нажав на кнопку мыши и удерживая ее, вы видите в подкрашенном прямоугольнике координаты текущей точки в этой системе координат. После отпускания кнопки прямоугольник с координатами исчезает. Таким образом, применены два обработчика событий: на нажатие и отпускание кнопки мыши.

Как в пример г с многочленом Лагранжа, введены функции масштабирования и перевода из 6yмажных координат в экранные и обратно.

Листинг 12. Процедура

function TForml.II(х: real): integer;

begin

II:=Il+Trunc((12-11)*(x-xl)/(x2-xl));

end;

function TForml.JJ(y: real): integer;

begin

JJ:=Jl+Trunc((J2-Jl)*(y-y2)/(yl-y2));

end;

function TForml.XX(i: integer): real;

begin

XX:=xl+(i-Il)*(x2-xl)/(12-11);

end;

function TForml.YY(j: integer): real;

begin

YY:=yl+(j-j2)*(y2-yl)/(Jl-J2);

end;

Процедура ShowBezier, рисуя белый прямоугольник, очищает Imagel, рисует оси координат, затем в цикле рисует точки в виде маленьких прямоугольничков и готовит массив Po[0..n] of TPoint, необходимый для метода PolyBezier.

Листинг 13. Процедура

procedure TForml.ShowBezier;

const cl=2; var i: integer;

begin

with Imagel.Canvas do begin

Brush.Color:=clWhite;

RectAngle(-1,-1,Imagel.Width,Imagel.Height);

MoveTo(IKxl)., JJ(0)); LineTo (II (x2),JJ(0));

MoveTo(lKO), JJ(yl)); LineTo (11(0),JJ(y2));

for i:=0 to n do begin

RectAngle(II(xt[i])-cl,JJ(yt[i])-cl,II(xt[i])+cl,JJ(yt[i])+cl);

Po[i].x:=II(xt[i]); Po[i].y:=JJ(yt[i]);

end;

PolyBezier(Po);

end;

end;

При нажатии кнопки мыши вызывается обработчик события ImageIMouseDown, котором выводится прямоугольник с координатами курсора.

программа курсор система delphi

Листинг 14. Процедура

procedure TForml.ImagelMouseDown(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

var s,s0: string[6];

begin

with Imagel.Canvas do

begin

Brush.Color:=$009CE7FC;

RectAngle(x,y-20,x+50,y);

Str(XX{X):4:l,s); Str(YY(Y):4:l,s0);

TextOut(x+2,y-18,s+';'+sO);

end;

end;

При отпускании кнопки мыши вызывается обработчик события ImageIMouseUp, который перерисовывает кривые Безье (рис. 7).

Листинг 14. Процедура

procedure TForml.ImagelMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

begin

ShowBezier;

end;

В основном модуле в разделе описания констант заданы габариты бумажного окна, координаты десяти узловых точек. При активизации формы задаются габариты экранного окна.

Листинг 15. Процедура

unit Unitl;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Buttons, ExtCtrls;

type

TForml = class(TForm)

Panell: TPanel;

Panel2: TPanel;

Imagel: TImage;

SpeedButtonl: TSpeedButton;

SpeedButton2: TSpeedButton;

procedure SpeedButtonlClick(Sender: TObject);

procedure FormActivate(Sender: TObject);

Рис. 7 Кривые Безье

procedure ImagelMouseDown(Sender: TObject;

Button: TMouseButton;

Shift: TShiftState; X, У: Integer);

procedure ImagelMouseUp(Sender: TObject;

Button: TMouseButton; Shift:

TShiftState; X, Y: Integer);

procedure ImagelMouseMove(Sender: TObject;

Shift: TShiftState; X,Y: Integer);

private

{ Private declarations }

Drawing: Boolean;

Origin, MovePt: TPoint;

Num: integer;

procedure SetLagr; procedure Rectl (a,b: integer);

procedure DrawShape(TopLeft, BottomRight:

TPoint; AMode: TPenMode);

public

{ Public declarations }

end;

var Forml: TForml;

const n=7; {n+1 - число узловых точек }

type Vect=array[0..n] of real;

const m=50; {число точек между узловыми точками,}

xl=-l; x2=10; yl=-l; у2=10; {окно на бумаге }

{ координаты узловых точек }

xt: Vect=(1.0,2.0,3.0,4.0,5.0,6.0,7.5,8.8);

yt: Vect=(1.0,2.3,3.4,2.5,3.7,4.8, 3.2, 2.1);

var h, {шаг между узловыми точками }

u,v: Real; { х,у между узловыми точками }

I1,J1,I2,J2: integer; {окно на экране }

Ok: boolean;

Implementation

{$R *.DFM}

procedure TForml.SpeedButtonlClick(Sender: TObject);

begin

Close;

end;

end.

Код программы

Программа Лагранжа

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

Buttons, ExtCtrls;

type

TForm1 = class(TForm)

Image1: TImage;

SpeedButton1: TSpeedButton;

procedure Image1MouseUp(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X,

Y: Integer);

procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

procedure FormActivate(Sender: TObject);

procedure SpeedButton1Click(Sender: TObject);

private

{ Private declarations }

drawing:boolean;

origin,movept:tpoint;

num:integer;

procedure SetLagr;

procedure Rect1(a,b:integer);

procedure DrawShape(topleft,bottomright:tpoint;amode:tpenmode);

function xx(i:integer):real;

function yy(j:integer):real;

function ii(x:real):integer;

function jj(y:real):integer;

public

{ Public declarations }

end;

var

Form1: TForm1;

const n=7;

type vect=array[0..n] of real;

const m=50;

x1=-1;

x2=10;

y1=-1;

y2=10;

xt:vect=(1.0,2.0,3.0,4.0,5.0,6.0,7.5,8.8);

yt:vect=(1.0,2.3,3.4,2.5,3.7,4.8,3.2,2.1);

var h:real;

u,v:real;

i1,j1,i2,j2:integer;

ok:boolean;

function Lagr(n:byte;xt:real;x,y:vect):real;

implementation

{$R *.DFM}

procedure TForm1.Image1MouseUp(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

begin

if drawing then

begin

DrawShape(origin,point(x,y),pmcopy);

drawing:=false;

end;

end;

procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);

begin

if drawing then

begin

DrawShape(origin,movept,pmNotXor);

movept:=point(x,y);

xt[num]:=xx(x);

yt[num]:=yy(y);

DrawShape(origin,movept,pmNotXor);

end;

end;

procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

var i:integer;

min,r:real;

begin

drawing:=true;

image1.canvas.moveto(x,y);

num:=0;

min:=sqr(xx(x)-xt[num])+sqr(yy(y)-yt[num]);

for i:=1 to n do

begin

r:=sqr(xx(x)-xt[1])+sqr(yy(y)-yt[1]);

f r<min then

begin

num:=i;

min:=r;

end;

origin:=point(ii(xt[num]),jj(yt[num]));

movept:=origin;

end;

end;

procedure TForm1.FormActivate(Sender: TObject);

begin

drawing:=false;

with image1 do

begin

i1:=0;

j1:=0;

i2:=width;

j2:=height;

end;

setlagr;

end;

procedure tform1.DrawShape(topleft,bottomright:tpoint;amode:tpenmode);

var i:integer;

begin

with image1.canvas do

begin

pen.mode:=amode;

h:=(xt[n]-xt[0])/m;

u:=xt[0];

v:=lagr(n,u,xt,yt);

moveto(ii(u),jj(v));

for i:=1 to m do

begin

u:=u+h;

v:=lagr(n,u,xt,yt);

lineto(ii(u),jj(v));

end;

for i:=0 to n do

rect1(ii(xt[i]),jj(yt[i]));

end;

end;

function Lagr(n:Byte;xt:Real;x,y:Vect):Real;

var i,j:Byte;

S,P:Real;

begin

S:=0;

for i:=0 to n do

begin

P:=1;

for j:=0 to n do

if i<>j then P:=P*(xt-x[j])/(x[i]-x[j]);

S:=S+y[i]*P;

end;

Lagr:=S;

end;

function TForm1.II(x:Real):Integer;

begin

II:=I1+Trunc((I2-I1)*(x-x1)/(x2-x1));

end;

function TForm1.JJ(y:Real):Integer;

begin

JJ:=J1+Trunc((J2-J1)*(y-y2)/(y1-y2));

end;

//Процедуры обратного маштабирования

function TForm1.XX(i:Integer):Real;

begin

XX:=x1+(i-I1)*(x2-x1)/(I2-I1);

end;

function TForm1.YY(j:Integer):Real;

begin

YY:=y1+(j-j2)*(y2-y1)/(J1-J2);

end;

procedure TForm1.Rect1(a,b: integer);

const c4=2;

begin

with Image1.Canvas do RectAngle(a-c4,b-c4,a+c4,b+c4);

end;

procedure TForm1.SetLagr;

var i:integer;

begin

with Image1.Canvas do

begin

RectAngle(-1,-1,Width,Height);

{Построение осей координат}

MoveTo(II(0),JJ(y1));

LineTo(II(0),JJ(y2));

MoveTo(II(x1),JJ(0));

LineTo(II(x2),JJ(0));

{Построение графика функции}

h:=(xt[n]-xt[0])/m;

u:=xt[0];

v:=Lagr(n,u,xt,yt);

MoveTo(II(u),JJ(v));

For i:=1 to m do

begin

u:=u+h;

v:=Lagr(n,u,xt,yt);

LineTo(II(u),JJ(v));

end;

for I:=0 to n do Rect1(II(xt[i]),JJ(yt[i]));

end;

end;

procedure TForm1.SpeedButton1Click(Sender: TObject);

begin

close;

end;

end.

Программа Гаусс

unit gauss;

interface

uses

Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

Dialogs, Buttons, ExtCtrls;

type

TForm1 = class(TForm)

Image1: TImage;

SpeedButton1: TSpeedButton;

procedure FormActivate(Sender: TObject);

procedure SpeedButton1Click(Sender: TObject);

private

{ Private declarations }

procedure Rect1(a,b:integer);

public

{ Public declarations }

end;

var

Form1: TForm1;

const n=7; {n+1 степень узловых точек }

m=4; {степень многочлена }

type Vect=array[0..n]of real;

Vect_M =array[0..m]of real;

Matr=array[0..m, 0..m]of real;

const p=50; {число точек между узловыми точками }

a1=-1; a2=10; b1=-4; b2=10; {окна на бумаге}

{координаты узловых точек}

x: Vect=(1.0,2.0,3.0,4.0,5.0,6.0,7.5,8.8);

y: Vect=(1.0,2.3,3.4,2.5,3.7,4.8,3.2,2.1);

var i:Byte;Gr,Gm: integer;

I1,J1,I2,J2:integer; {окна наэкране}

h, {шаг между узловыми точками}

u0,v0,u,v:real; {x,y между узловыми точками}

c:Vect_M;

implementation

{$R *.dfm}

function F(m: Byte; x:real; c: Vect_M):Real;

{Вычисление значения многочлена}

var i: Byte; y: real;

begin

y:=0;

for i:=m downto 0 do y:=y*x+c[i];

F:=y;

end;

procedure TForm1.Rect1(a,b: integer);

const c4=2;

begin

with Image1.Canvas do RectAngle(a-c4,b-c4,a+c4,b+c4);

end;

procedure TForm1.FormActivate(Sender: TObject);

var i: integer;

begin

Gauss (n,m,x,y,c);

with Image1.Canvas do

begin

I1:=0;

J1:=0;

I2:= Width;

J2:= Height;

{окна на экране}

MoveTo(II(a1),JJ(0));

LineTo(II(a2),JJ(0));

MoveTo(II(0),JJ(b1));

LineTo(II(0),JJ(b2));

for i:=0 to n do

Rect1(II(x[i]),JJ(y[i]));

{Построение графика функции}

h:=(x[n]-x[0])/p;

u:=x[0];

v:=F(m,u,c);

MoveTo(II(u),JJ(v));

for i:=1 to p do

begin

u:=u+h;

v:=F(m,u,c);

LineTo(II(u),JJ(v));

end;

end;

procedure Gauss(n,m: Byte; x,y: Vect; var c: Vect_m);

var A: Matr; b: Vect_M;

i,j,k,l: Byte; P: Real;

begin

{коэфициенты матрицы}

for j:=0 to m do

for k:=j to m do

begin

A[j,k]:=0;

for i:=0 to n do

begin

p:=1;

for i:=1 to j+k do p:=p*x[i];

A[j,k]:=A[j,k]+P;

A[j,k]:=A[j,k];

end;

end;

{свободный член}

for k:=0 to m do

begin

B[k]:=0;

for i:=0 to n do

begin

P:=y[i]; for I:=1 to k do

P:-P*x[i];

B[k]:=B[k]+P;

end;

end;

{решение системы: прямой ход}

for i:=0 to m do

for j:=i+1 to m do

begin

for k:=i+1 to m do

A[k,j]:=A[k,j]-A[i,j]*A[k,i]/A[i,i];

B[j]:=B[j]-B[i]*A[i,j]/A[i,i];

end;

{решение системы: обратный ход }

for j:=m downto 0 do

begin

c[j]:=B[j];

for k:=j+1 to m do

c[j]:=c[j]-A[k,j]*c[k];

c[j]/A[j,j];

end;

end;

procedure TForm1.SpeedButton1Click(Sender: TObject);

begin

close;

end;

end.

Программа Кривые Безье

unit bezier;

interface

uses

Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

Dialogs, StdCtrls, Buttons, ExtCtrls;

type

TForm1 = class(TForm)

Panel1: TPanel;

Image1: TImage;

BitBtn1: TBitBtn;

procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

procedure Image1MouseUp(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

procedure FormActivate(Sender: TObject);

procedure BitBtn1Click(Sender: TObject);

private

{ Private declarations }

I1,J1,I2,J2:integer; {окна на экране}

Po: array [0..n] of TPoint;

function II(x:real):integer;

function JJ(y:real):integer;

function XX(i:integer):real;

function YY(j:integer):real;

procedure ShowBezier;

public

{ Public declarations }

end;

var

Form1: TForm1;

const n=9; {n+1- число узловых точек}

type Vect=array [0..n]of real;

const x1=-1; x2=11; y1=-1; y2=6;{окна на бумаге}

{координаты узловых точек}

xt: Vect=(1.0,2.0,3.0,4.0,5.0,6.0,7.5,8.8,9.2,10);

yt: Vect=(1.0,2.3,3.4,2.5,3.7,4.8,3.2,2.1,3,3.4);

implementation

{$R *.dfm}

procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

var s,s0: string[6];

begin

with Image1.Canvas do

begin

Brush.Color:=$009CE7FC;

RectAngle(x,y-20,x+50,y);

Str(XX(X):4:1,s);

Str(YY(Y):4:1,s0);

TextOut(x+2,y-18,s+';'+s0);

end;

end;

procedure TForm1.Image1MouseUp(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

begin

ShowBezier;

end;

procedure TForm1.FormActivate(Sender: TObject);

begin

with Image1 do begin

I1:=0;

J1:=0;

I2:=Width;

J2:=Height; {окна на бумаге}

end;

ShowBezier;

end;

function TForm1.II(x:real):integer;

begin

II:=I1+Trunc((I2-I1)*(x-x1)/(x2-x1));

end;

function TForm1.JJ(y:real):integer;

begin

JJ:=J1+Trunc((J2-J1)*(y-y2)/(y1-y2));

end;

function TForm1.XX(i:integer):real;

begin

XX:=x1+(i-I1)*(x2-x1)/(I2-I1);

end;

function TForm1.YY(j:integer):real;

begin

YY:=y1+(j-j2)*(y2-y1)/(J1-J2);

end;

procedure TForm1.ShowBezier;

const c1=2;

var i:integer;

begin

with Image1.Canvas do begin

Brush.Color:=clWhite;

RectAngle(-1,-1,Image1.Width,Image1.Height);

MoveTo(II(x1),JJ(0));

LineTo(II(x2),JJ(0));

MoveTo(II(0),JJ(y1));

LineTo(II(0),JJ(y2));

for i:=0 to n do

begin

RectAngle(II(xt[i])-c1,JJ(yt[i])-c1,II(xt[i])+c1,JJ(yt[i])+c1);

Po[i].x:=II(xt[i]);

Po[i].y:=JJ(yt[i]);

end;

PolyBezier(Po);

end;

end;

procedure TForm1.BitBtn1Click(Sender: TObject);

begin

close;

end;

end.

Размещено на Allbest.ru

...