Добавил:
Опубликованный материал нарушает ваши авторские права? Сообщите нам.
Вуз: Предмет: Файл:
SOME / 2 / PROGRAM.DOC
Скачиваний:
2
Добавлен:
16.04.2013
Размер:
27.14 Кб
Скачать

Приложение 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

Соседние файлы в папке 2