Скачиваний:
9
Добавлен:
10.05.2015
Размер:
11.43 Кб
Скачать
{------------------------} UNIT GNK; {------------------------}

{------------------------} INTERFACE {------------------------}

FUNCTION AVER(V,M,S:real):real;
FUNCTION GAUSS(M,S:real):real;
FUNCTION MAX(var Mas:array of real):real;
FUNCTION MIN(var Mas:array of real):real;
FUNCTION VER(X,M,S:real):real;
PROCEDURE PV(i,N:word;YK,YPK:real;var C:word;var V2:real);
PROCEDURE DIS(M:word;var X,Y,Xdis,Ydis:array of real);
PROCEDURE FLF(W,T:real;var X,Yo,Y:array of real);
PROCEDURE GKLF(T:real;var Ax,Ay,X,Yo:array of real);
PROCEDURE GF(K1,K2:word;T,W,B1,B2,Ma,Sa,Mp,Sp:real;
var X,Y,G:array of real);
TYPE S_60 =string[60];
PROCEDURE GRA(K,E:word;var T1,F1,T2,F2:array of real;S1,S2,S3:S_60);
PROCEDURE IDF(K:word;Wif:real;var Xdis,Ydis,X,Yif,FO:array of real);
PROCEDURE KVN(KU:word;Q,Ymin,Yi:real;var NUK:word;var YK:real);
PROCEDURE SAG(KS:word;V1,M,S,Ymin,Ymax:real;var KU:word;var Q:real);
PROCEDURE ShowGra(K,E:word;var T1,F1,T2,F2:array of real;S1,S2,S3:S_60);

{------------------------} IMPLEMENTATION {------------------------}

USES CRT,DOS,GRAPH;
CONST Porog:real = 1e-6;
VAR F_bgi:PathStr;

PROCEDURE PV;
CONST
dY=1e-5;
BEGIN
if i=1 then C:=0;
if abs(YPK-YK)<=dY then inc(C);
if i=N then V2:=C/i
END;

FUNCTION AVER(V,M,S:real):real;
VAR
a,b,x,vi:real;
BEGIN
a:=0;b:=6;
x:=(a+b)/2;
vi:=VER(x,0,1);
while (b-a>Porog) and (abs(vi-v)>Porog) do
begin
if vi>v then b:=x else a:=x;
x:=(a+b)/2;
vi:=VER(x,0,1);
end;
AVER:=x*S+M
END;

FUNCTION GAUSS(M,S:real):real;
VAR
a,b,c,d:real;
BEGIN
repeat
a:=2*random-1;
b:=2*random-1;
c:=sqr(a)+sqr(b)
until c<1;
d:=sqrt((-2)*ln(c)/c);
Gauss:=M+S*a*d
END;

FUNCTION MAX(var Mas:array of real):real;
VAR
i :word;
ma:real;
BEGIN
ma:=Mas[0];
for i:=1 to High(Mas) do if Mas[i]>ma then ma:=Mas[i];
MAX:=ma
END;

FUNCTION MIN(var Mas:array of real):real;
VAR
i :word;
mi:real;
BEGIN
mi:=Mas[0];
for i:=1 to High(Mas) do if Mas[i]<mi then mi:=Mas[i];
MIN:=mi
END;

FUNCTION VER(X,M,S:real):real;
CONST
B:array[0..5] of real = (0.2316419 , 0.31938153 ,-0.356563782,
1.781477937,-1.821255978, 1.330274429);
VAR
t,p:real;
BEGIN
X:=(X-M)/S;
t:=1+B[0]*X;
p:=1-(exp(-X*X/2)/sqrt(2*pi))*(B[1]+(B[2]+(B[3]+(B[4]+B[5]/t)/t)/t)/t)/t;
VER:=2*p-1
END;

PROCEDURE DIS(M:word;var X,Y,Xdis,Ydis:array of real);
VAR
i,j:word;
BEGIN
if (High(X)<>High(Y)) or (High(Xdis)<>High(Ydis)) then
begin writeln('ЋиЁЎЄ  ў ®Ўа йҐ­ЁЁ Є DIS');halt end;
j:=0;
for i:=0 to High(Xdis) do
begin
Xdis[i]:=X[j];
Ydis[i]:=Y[j];
j:=j+M+1;if j>High(X) then j:=High(X)
end
END;

PROCEDURE FLF(W,T:real;var X,Yo,Y:array of real);
VAR
i,j :word;
a0,a,b,wj,dx:real;
BEGIN
if (High(X)<>High(Yo)) or (High(X)<>High(Y)) then
begin writeln('ЋиЁЎЄ  ў ®Ўа йҐ­ЁЁ Є FLF');halt end;
dx:=T/High(X);
a0:=0;for i:=0 to High(X) do a0:=a0+Yo[i]*dx;a0:=a0/T;
for i:=0 to High(X) do Y[i]:=a0;
j:=1;wj:=2*Pi*j/T;
while wj<=W do
begin
a:=0;b:=0;
for i:=0 to High(X) do
begin
a:=a+Yo[i]*cos(wj*X[i])*dx;
b:=b+Yo[i]*sin(wj*X[i])*dx
end;
a:=2*a/T;b:=2*b/T;
for i:=0 to High(X) do
Y[i]:=Y[i]+a*cos(wj*X[i])+b*sin(wj*X[i]);
inc(j);wj:=2*Pi*j/T
end
END;

PROCEDURE GKLF(T:real;var Ax,Ay,X,Yo:array of real);
VAR
i,j :word;
k,b,dx:real;
BEGIN
if (High(X)<>High(Yo)) or (High(Ax)<>High(Ay)) then
begin writeln('ЋиЁЎЄ  ў ®Ўа йҐ­ЁЁ Є GKLF');halt end;
dx:=T/High(X);
X[0]:=Ax[0];
Yo[0]:=Ay[0];
j:=0;
for i:=1 to High(X) do
begin
X[i]:=X[i-1]+dx;
if (j<High(Ax)) and (X[i]>=Ax[j+1]) then inc(j);
if j<High(Ax)
then k:=(Ay[j+1]-Ay[j])/(Ax[j+1]-Ax[j])
else if Ax[0]+T-Ax[j]<>0 then k:=(Ay[0]-Ay[j])/(Ax[0]+T-Ax[j]) else
k:=(Ay[0]-Ay[j])/0.00001;
b:=Ay[j]-k*Ax[j];
Yo[i]:=k*X[i]+b
end
END;

PROCEDURE GF(K1,K2:word;T,W,B1,B2,Ma,Sa,Mp,Sp:real;
var X,Y,G:array of real);
CONST
S1='ђҐ§г«мвЁагой п дг­ЄжЁп.';
S2='‘㬬Ёа㥬 п Ј а¬®­ЁЄ .';
VAR
Gd,Gm:integer;
i,j,Xo,Yo:word;
a,p,wj,dx,dT,dF:real;
BEGIN
if K2<>0 then begin Gd:=0;InitGraph(Gd,Gm,F_bgi) end;
dx:=T/High(X);
X[0]:=0;for i:=1 to High(X) do X[i]:=X[i-1]+dx;
for i:=0 to High(X) do Y[i]:=0;
j:=1;wj:=2*Pi*j/T;
while wj<=W do
begin
if K1=0
then begin a:=B1/j;p:=B2/j end
else begin a:=Gauss(Ma,Sa);p:=Gauss(Mp,Sp) end;
for i:=0 to High(X) do
begin
G[i]:=a*cos(wj*X[i]-p);
Y[i]:=Y[i]+G[i]
end;
if K2<>0 then ShowGra(1,0,X,Y,X,G,S1,S2,'');
inc(j);wj:=2*Pi*j/T
end;
if K2<>0 then CloseGraph
END;

PROCEDURE GRA(K,E:word;var T1,F1,T2,F2:array of real;S1,S2,S3:S_60);
VAR
Xo,Yo:word;
dT,dF:real;
Gd,Gm:integer;
BEGIN
Gd:=0;InitGraph(Gd,Gm,F_bgi);
ShowGra(K,E,T1,F1,T2,F2,S1,S2,S3);
CloseGraph
END;

PROCEDURE IDF(K:word;Wif:real;var Xdis,Ydis,X,Yif,FO:array of real);
VAR
i,j,Xo,Yo:word;
alfa,dT,dF:real;
Gd,Gm:integer;
CONST
S1='ђҐ§г«мвЁагой п дг­ЄжЁп.';
S2='‘㬬Ёа㥬 п дг­ЄжЁп ®вбзҐв .';
BEGIN
if (High(X)<>High(Yif)) or (High(X)<>High(FO)) or (High(Xdis)<>High(Ydis))
then begin writeln('ЋиЁЎЄ  ў ®Ўа йҐ­ЁЁ Є IDF');halt end;
if K<>0 then begin Gd:=0;InitGraph(Gd,Gm,F_bgi) end;
for i:=0 to High(X) do Yif[i]:=0;
for j:=0 to High(Xdis) do
begin
for i:=0 to High(X) do
begin
alfa:=Wif*(X[i]-Xdis[j]);
if abs(alfa)<Porog
then FO[i]:=Ydis[j]
else FO[i]:=Ydis[j]*sin(alfa)/alfa;
Yif[i]:=Yif[i]+FO[i]
end;
if K<>0 then ShowGra(1,0,X,Yif,X,FO,S1,S2,'');
end;
if K<>0 then CloseGraph
END;

PROCEDURE KVN(KU:word;Q,Ymin,Yi:real;var NUK:word;var YK:real);
VAR
k:word;
BEGIN
k:=0;
repeat
YK:=Ymin+Q+2*Q*k;
k:=k+1
until (Yi<=YK+Q) or (k>=KU);
NUK:=k-1
END;

PROCEDURE SAG(KS:word;V1,M,S,Ymin,Ymax:real;var KU:word;var Q:real);
BEGIN
if KS=0
then begin
Q:=AVER(V1,M,S);
KU:=round((Ymax-Ymin)/(2*Q))
end
else if KU=0 then Q:=0 else Q:=((Ymax-Ymin)/KU)/2
END;

PROCEDURE ShowGra(K,E:word;var T1,F1,T2,F2:array of real;S1,S2,S3:S_60);
CONST
cg=0; {梥в д®­  - зҐа­л©}
cc=15; {梥⠪®®а¤Ё­ в­ле ®бҐ© - ЎҐ«л©}
c1=10; {梥⠣а дЁЄ  ЇҐаў®© дг­ЄжЁЁ - §Ґ«Ґ­л©}
c2=9; {梥⠣а дЁЄ  ЇҐаў®© дг­ЄжЁЁ - бЁ­Ё©}
c3=4; {梥⠣а дЁЄ  дг­ЄжЁЁ а §­®бвЁ - Єа б­л©}
VAR
VXmin,VXmax,VYmin,VYmax:word;
tx:string;
i:word;
Tmin,Tmax,Fmin,Fmax,p:real;

FUNCTION VideoX(t:real):word;
BEGIN
if Tmin=Tmax
then VideoX:=(VXmin+VXmax) div 2
else VideoX:=VXmin+trunc((VXmax-VXmin)*(t-Tmin)/(Tmax-Tmin))
END;

FUNCTION VideoY(f:real):word;
BEGIN
if Fmin=Fmax
then VideoY:=(VYmin+VYmax) div 2
else VideoY:=VYmin+trunc((VYmax-VYmin)*(Fmax-f)/(Fmax-Fmin))
END;

{-- Їа®жҐ¤га  ShowNep Ї®Є §лў Ґв F(T) Є Є ­ҐЇаҐалў­го дг­ЄжЁо --}
PROCEDURE ShowNep(var T,F:array of real);
VAR
i:word;
BEGIN
SetLineStyle(0,0,3);
MoveTo(VideoX(T[0]),VideoY(F[0]));
for i:=1 to High(T) do
LineTo(VideoX(T[i]),VideoY(F[i]));
END;

{-- Їа®жҐ¤га  ShowDis Ї®Є §лў Ґв F(T) Є Є ¤ЁбЄаҐв­го дг­ЄжЁо --}
PROCEDURE ShowDis(var T,F:array of real);
VAR
i:word;
BEGIN
SetLineStyle(0,0,1);
for i:=0 to High(T) do
Line(VideoX(T[i]),VideoY(0),VideoX(T[i]),VideoY(F[i]));
END;

{-- Їа®жҐ¤га  ShowKvn Ї®Є §лў Ґв F(T) Є Є Єў ­в®ў ­­го дг­ЄжЁо --}
PROCEDURE ShowKvn(var T,F:array of real);
VAR
i:word;
BEGIN
SetLineStyle(0,0,1);
MoveTo(VideoX(T[0]),VideoY(F[0]));
for i:=1 to High(T) do
begin
LineTo(VideoX((T[i-1]+T[i])/2),GetY);
LineTo(GetX,VideoY(F[i]));
LineTo(VideoX(T[i]),GetY)
end
END;

{-- Їа®жҐ¤га  ShowNepEr Ї®Є §лў Ґв ®иЁЎЄг F2(T)-F1(T)
Є Є ­ҐЇаҐалў­го дг­ЄжЁо --}
PROCEDURE ShowNepEr(var T,F1,F2:array of real);
VAR
i:word;
BEGIN
SetLineStyle(0,0,3);
MoveTo(VideoX(T[0]),VideoY(F2[0]-F1[0]));
for i:=1 to High(T) do
LineTo(VideoX(T[i]),VideoY(F2[i]-F1[i]));
END;

{-- Їа®жҐ¤га  ShowKvnEr Ї®Є §лў Ґв ®иЁЎЄг F2(T)-F1(T)
Є Є Єў ­в®ў ­­го дг­ЄжЁо --}
PROCEDURE ShowKvnEr(var T,F1,F2:array of real);
VAR
i:word;
BEGIN
SetLineStyle(0,0,1);
MoveTo(VideoX(T[0]),VideoY(F2[0]-F1[0]));
for i:=1 to High(T) do
begin
LineTo(VideoX((T[i-1]+T[i])/2),GetY);
LineTo(GetX,VideoY(F2[i]-F1[i]));
LineTo(VideoX(T[i]),GetY)
end
END;

BEGIN
VXmin:=15;VXmax:=GetMaxX-20;
VYmin:=20;VYmax:=GetMaxY-50;
Tmin:=Min(T1);p:=Min(T2);if p<Tmin then Tmin:=p;
Tmax:=Max(T1);p:=Max(T2);if p>Tmax then Tmax:=p;
Fmin:=Min(F1);p:=Min(F2);if p<Fmin then Fmin:=p;
Fmax:=Max(F1);p:=Max(F2);if p>Fmax then Fmax:=p;
if (K in [1,3,6]) and (E<>0) then
for i:=0 to High(F1) do
begin
p:=F2[i]-F1[i];
if p<Fmin then Fmin:=p;
if p>Fmax then Fmax:=p
end;
Setcolor(cc);Setbkcolor(cg);SetLineStyle(0,0,1);
{---- Ї®бв஥­ЁҐ Є®®а¤Ё­ в­ле ®бҐ© ----}
line(VXmin-5,VideoY(0),VXmax+8,VideoY(0));
line(VXmax+5,VideoY(0)-1,VXmax+5,VideoY(0)+1);
outtextxy(VXmax+11,VideoY(0)-4,'x');
line(VideoX(0),VYmin-8,VideoX(0),VYmax+5);
line(VideoX(0)-1,VYmin-5,VideoX(0)+1,VYmin-5);
outtextxy(VideoX(0)-12,VYmin-18,'F(x)');
{---- ўлў®¤ дг­ЄжЁЁ F1(T) ----}
Setcolor(c1);OutTextXY(10,GetMaxY-40,S1);
case K of
1,2,3 : ShowNep(T1,F1);
4,5 : ShowDis(T1,F1);
6 : ShowKvn(T1,F1)
end;
{---- ўлў®¤ дг­ЄжЁЁ F2(T) ----}
Setcolor(c2);OutTextXY(10,GetMaxY-30,S2);
case K of
1 : ShowNep(T2,F2);
2,4 : ShowDis(T2,F2);
3,5,6 : ShowKvn(T2,F2)
end;
{---- ўлў®¤ а §­®бвЁ F2(T)-F1(T) ----}
if (K in [1,3,6]) and (E<>0) then
begin
Setcolor(c3);OutTextXY(10,GetMaxY-20,S3);
case K of
1,3 : begin ShowNepEr(T1,F1,F2) end;
6 : begin ShowKvnEr(T1,F1,F2) end
end
end;
{---- ўлў®¤ б®®ЎйҐ­Ёп ® Ј®в®ў­®бвЁ Є Їа®¤®«¦Ґ­Ёо а Ў®вл ----}
tx:='¤«п Їа®¤®«¦Ґ­Ёп а Ў®вл ­ ¦¬ЁвҐ «оЎго Є« ўЁиг';
Setcolor(cc);
outtextxy((GetMaxX div 2)-176,GetMaxY-10,tx);
while keypressed do tx:=readkey;tx:=readkey;
ClearDevice
END;

BEGIN
F_bgi:=FSearch('egavga.bgi','D:\TP\BGI;E:\TP\BGI');
Delete(F_bgi,Pos('egavga.bgi',F_bgi),10);
randomize
END.
Соседние файлы в папке UNITS
  • #
    10.05.201518.77 Кб9FKT.PAS
  • #
    10.05.201516.58 Кб9FKT.TPU
  • #
    10.05.201511.43 Кб9GNK.PAS
  • #
    10.05.201519.92 Кб10GNK.TPU
  • #
    10.05.201515.58 Кб9GNK2.PAS
  • #
    10.05.201512.11 Кб9GNK2.TPU
  • #
    10.05.201512.64 Кб9GNK4.TPU