Приложение 1.
PROGRAM AFAR;
Uses crt,graph;
Type
TypeRez=array[0..640] of real;
Strng=String [23];
Comp=record
rl:real;
im:real
end;
Const
OneGrd=pi/180;
lambda=10.;
discreet=Pi/16;
stpscn=pi/180;
Var
Window:ViewPortType;
Lft,Rgt,Sum,Disc:comp;
Driver,Regim,n,maxi,tp,cnl:Integer;
WkI,i,si,Xmax,Ymax,xc,yc:integer;
Pdet,phdet,l,CurVal,WkR,Fx,Sf,Step,dist,d,r,r1,range,maxrez,StatErr,kl,tt:real;
ch,ch1:char;
buf:Strng;
rez:TypeRez;
phr:Array [-10..10]of Real;
spd:Array [-10..10,1..2]of real;
ErrArray:Array[-10..10,1..2]of integer;
ExitCode:Boolean;
Procedure InSwitch(var sw:char);
Begin
Repeat
sw:=ReadKey;
Until sw in [chr(27),' ','+','-','*','/','r','l','n','d','s','p','q','w']
End;
Procedure Screen;
var
i:integer;
Buf:strng;
RngGrad:real;
Begin
SetWriteMode(CopyPut);
SetViewPort(Xmax-301,ymax-60,Xmax,Ymax,ClipOn);
ClearViewPort;
setcolor(green);
str(d,buf);
delete(Buf,6,12);
delete(Buf,8,2);
OutTextXY(0,50,'l:('+buf+')sm');
str(r1,buf);
delete(Buf,6,12);
delete(Buf,8,2);
OutTextXY(0,40,'r:('+buf+')m');
str(n,buf);
OutTextXY(0,30,'n:('+buf+')');
setcolor(yellow);
str((maxrez/OneGrd),buf);
delete(Buf,6,12);
delete(Buf,8,2);
OutTextXY(0,20,'Max. Value: '+buf);
str(pi/range*2,buf);
delete(Buf,6,12);
delete(Buf,8,2);
delete(Buf,1,1);
OutTextXY(0,10,'Range:'+chr(241)+'Pi/'+buf);
RngGrad:=180*range/2/Pi;
str(RngGrad,buf);
delete(Buf,6,12);
delete(Buf,8,2);
OutTextXY(155,10,'='+buf+chr(248));
str(CurVal,buf);
delete(Buf,6,12);
delete(Buf,8,2);
OutTextXY(0,0,'Current Value: '+buf);
With Window do SetViewPort(x1,y1,x2,y2,clip)
end;
Procedure Axes;
var
i,y:integer;
Begin
setcolor(magenta);
line(0,yc,xmax,yc);
line(xc,0,xc,ymax);
SetColor(Yellow);
For i:=1 to 3 do
Begin
y:=i*(Ymax+1)div 8;
line(xc-2,y,xc+2,y);
y:=(i+4)*(Ymax+1)div 8;
line(xc-2,y,xc+2,y);
y:=i*(Xmax+1)div 8;
line(y,yc-2,y,yc+2);
y:=(i+4)*(Xmax+1)div 8;
line(y,yc-2,y,yc+2)
End
End;
Procedure Max(x:TypeRez;var maxrez:real);
var
I:integer;
Begin
maxrez:=1e-10;
for i:=0 to 639 do
if abs(x[i])>maxrez then maxrez:=abs(x[i])
end;
Procedure Draw50(Rx:TypeRez);
var
I,y:integer;
koef:real;
Begin
SetWriteMode(CopyPut);
setcolor(magenta);
line(0,yc,xmax,yc);
line(0,0,0,ymax);
SetColor(Yellow);
For i:=0 to 50 do
Begin
line(i*12,yc-3,i*12,yc+3)
End;
Max(Rx,maxrez);
koef:=yc/maxrez;
MoveTo(0,yc-trunc(Rx[0]*koef));
for i:=0 to 50 do
begin
y:=yc-trunc(Rx[i]*koef);
lineto(i*12,y)
end;
End;
Procedure Draw(x:TypeRez);
var
I,y:integer;
koef:real;
Begin
SetWriteMode(CopyPut);
Axes;
SetColor(white);
Max(x,maxrez);
koef:=yc/maxrez;
MoveTo(0,yc-trunc(x[0]*koef));
for i:=1 to 639 do
begin
y:=yc-trunc(x[i]*koef);
lineto(i,y)
end;
end;
Procedure InpRange;
var
CurX:integer;
OldRange:real;
ch,ch1:char;
Begin
ExitCode:=False;
CurX:=xc;
OldRange:=Range;
Repeat
SetWriteMode(XORPut);
SetColor(LightGreen);
Line(CurX,0,CurX,ymax);
ch:=ReadKey;
Line(CurX,0,CurX,ymax);
If Ord(ch)=0 Then
Begin
Ch1:=ReadKey;
Case ch1 Of
Chr(75):If CurX>0 Then CurX:=CurX-1;
Chr(77):If CurX<Xmax Then CurX:=CurX+1;
Chr(83):if CurX>10 Then CurX:=CurX-10;
Chr(81):If CurX<Xmax-10 Then CurX:=CurX+10
End;
Range:=abs(CurX-xc)*OldRange/xc;
If Range=0 Then Range:=1e-10;
CurVal:=rez[CurX];
Screen
End;
Until (Ch=Chr(13)) or (Ch=Chr(27));
If Ch=Chr(27) Then
Begin
ExitCode:=True;
Range:=OldRange
end;
SetWriteMode(CopyPut);
End;
Procedure InputInt(var x,error:integer);
var
ch:char;
Buf:string[4];
begin
ch:=' ';
Buf:='';
While ord(ch)<>13 do
Begin
ch:=ReadKey;
If ord(ch)>32 Then
Begin
OutText(ch);
Buf:=Buf+ch
End
End;
Val(Buf,x,error)
End;
Procedure Inputreal(var x:real;var error:integer);
var
ch:char;
Buf:string[15];
begin
ch:=' ';
Buf:='';
While ord(ch)<>13 do
Begin
ch:=ReadKey;
If Ord(ch)>32 Then
Begin
OutText(ch);
Buf:=Buf+ch;
End
End;
Val(Buf,x,error)
End;
Procedure Input(tp:char;x,y:word;var int:integer;var ext:real);
var
error:integer;
Begin
Case tp of
'r':Repeat
Screen;
SetViewPort(Xmax-301,ymax-60,Xmax,Ymax,ClipOn);
MoveTo(x,y);
OutText('>');
InputReal(ext,error);
Until error=0;
'i':Repeat
Screen;
SetViewPort(Xmax-301,ymax-60,Xmax,Ymax,ClipOn);
MoveTo(x,y);
OutText('>');
InputInt(int,error);
Until error=0
End;
With Window do SetViewPort(x1,y1,x2,y2,clip)
End;
Procedure ErrInput;
var
i,i1,x,y,xm:integer;
buf:strng;
ch,ch1:char;
Procedure Cursor;
Begin
LineRel(0,10);
LineRel(10,0);
LineRel(0,-10);
LineRel(-10,0)
End;
Begin
ExitCode:=False;
SetTextStyle(2,0,4);
xm:=250;
SetViewPort(0,Ymax-51,xm,Ymax,ClipOn);
x:=30;
y:=10;
i1:=1;
Repeat
ClearViewPort;
SetColor(Green);
OutTextXY(0,0,'i:');
OutTextXY(0,10,'a:');
OutTextXY(0,30,'i:');
OutTextXY(0,40,'a:');
For i:=0 to n do
Begin
str(i-n,buf);
OutTextXY(30+20*i,0,buf);
str(ErrArray[i-n,cnl],buf);
OutTextXY(30+20*i,10,buf);
str(i,buf);
OutTextXY(30+20*i,30,buf);
str(ErrArray[i,cnl],buf);
OutTextXY(30+20*i,40,buf);
End;
SetWriteMode(XORPut);
SetColor(Cyan);
MoveTo(x-3,y+1);
Cursor;
ch:=ReadKey;
MoveTo(x-3,y+1);
Cursor;
Case Ch Of
chr(0):
Begin
Ch1:=ReadKey;
Case ch1 Of
Chr(75):If X>30 Then X:=X-20;
Chr(77):If X<xm-20 Then X:=X+20;
Chr(72):If y>10 Then
Begin
Y:=y-30;
i1:=1
end;
Chr(80):If y<40 Then
Begin
Y:=y+30;
i1:=0
End
End
End;
Chr(32):
Begin
i:=(x-30) div 20-n*i1;
ErrArray[i,cnl]:=1-ErrArray[i,cnl];
End;
End;
SetWriteMode(CopyPut);
Until (ch=Chr(13)) or (ch=chr(27));
With Window do SetViewPort(x1,y1,x2,y2,clip);
If ch=chr(27) then ExitCode:=true
End;
Function TAN(x:real):real;
Begin
tan:=sin(x)/cos(x)
End;
function SIGN(x:real):integer;
begin
if x<0 then sign:=-1
else sign:=1
end;
Procedure PhaseRasp(t:real);
var i:integer;
sint:real;
Begin
sint:=kl*d*sin(t);
for i:=-n to n do phr[i]:=i*sint
End;
Procedure SpaceDist(t,r:real);
var
i,nmb:integer;
Fi,cost,sint,ri:real;
begin
sint:=sin(t);
cost:=cos(t);
for i:=-n to n do
begin
ri:=sqrt(sqr(R*sint-i*d)+sqr(r*cost));
Fi:=arctan((r*sin(t)+i*d)/r/cos(t));
spd[i,1]:=kl*i*d*sin(fi)
end
end;
Procedure Discrt(tp:integer);
var
OldPh,dPh:real;
ksi,i,j:integer;
Begin
dph:=0;
For i:=-n to n do
begin
If i=1 Then ksi:=-1
Else Ksi:=1;
OldPh:=phr[i];
case tp of
1:phr[i]:=trunc(phr[i]/discreet)*discreet;
2:phr[i]:=trunc((phr[i]+dph*ksi)/discreet)*discreet
end;
dPh:=OldPh-phr[i]
end
end;
Procedure Chanel(cnl:integer;var can:comp);
var