- Код: Выделить всё
program labikthree;
uses wincrt,graph,crt;
const xr=5;yr=5;ac=14;pa=7; q=5;
var rk:char; menu:array [1..q] of string; n,n1:int64;h, kor,acrt,bcrt,yc:real;
place:integer; i:longint;gd,gm:integer;
x0,y0,x2,y2, x, y, xLeft, yLeft,h1, xRight, yRight,maxx,k,maxy,a,b,x3,y3,x4,toc1,toc2,toc3,toc4: int64;
ag,a1,b1,a2,b2, bg, fmin,c,z,d,fmax, x1, y1, mx, my, dx, dy,step, num: real; s:string;
Procedure Information;
begin clrscr;
Textcolor(13);
gotoxy(5,1); writeln('Calculate the area of bounded line shape: -2*x^3+(-1)*x^2+(51)*x+(-714)');
gotoxy(5,2); writeln('The curve crosses the x-axix at ', kor:0:2);
gotoxy(5,3); writeln('The area is calculated by the method of right rectangles');
gotoxy(5,4); writeln('Integration limits are entered by user');
gotoxy(5,5); writeln('Error calculation is organized');
gotoxy(5,6); writeln('Use the arrows to move around the menu');
gotoxy(5,7); writeln('Press ENTER to start');
readln();
end;
//--------------------------------------------------------------------------------
Procedure MenuToScr;
var i:byte;
begin
clrscr;
TextColor(pa);
i:=1;
for i:=1 to q do
begin
gotoxy(xr,yr+i-1);write(menu[i]);
end;
Textcolor(ac);
gotoxy(xr,yr+place-1);write(menu[place]);
TextColor(pa);
end;
//-------------------------------------------------------------------------------
Procedure Input(var acrt:real;var bcrt:real;var n:int64);
var k:real;
begin
clrscr;
TextColor(11);
writeln(' Required to find the area above the x-axis');
writeln('Function above the axis to ', kor:0:2 ,' function below the x-axis from ', kor:0:2);
TextColor(14);
writeln('If you enter the integration limit more than', kor:0:2 , ' then the area will be = 0');
writeln('To visualize the graphics mode, enter the limits from -35 for -9');
Normvideo;
writeln();
writeln('Enter the left intergration limit, the number is not more than 1000 and not less than -1000 ');
readln(acrt);
while (acrt<-1000) or (acrt>1000) do
begin
TextColor(12);
writeln('Wrong input, repeat again');
NormVideo;
readln(acrt);
end;
writeln('Enter the right intergration limit, the number is not more than 1000 and not less than -1000 ');
readln(bcrt);
while (bcrt<-1000) or (bcrt>1000) do
begin
TextColor(12);
writeln('Wrong input, repeat again');
NormVideo;
readln(bcrt);
end;
if acrt>bcrt
then
begin
TextColor(12);
writeln('Incorret intergration limits');
Normvideo;
k:=bcrt;
bcrt:=acrt;
acrt:=k;
end;
writeln('Enter the number of segments, the number is not more than 1000000 and not less than 0');
readln(n);
while (n<=0) or (n>1000000) do
begin
TextColor(12);
writeln('Wrong input, repeat again');
NormVideo;
readln(n);
end;
if acrt>kor then
begin
acrt:=0;
bcrt:=0;
end
else
begin
if bcrt>kor then bcrt:=kor;
h:=(bcrt-acrt)/n;
end;
n1:=n;
readln();
end;
//---------------------------------------------------------------------
Function Fu(x:real):real;
begin
fu:=-2*x*x*x+(-1)*x*x+51*x+(-714);
end;
Function Per(x:real):real;
begin
per:=-(2/4)*x*x*x*x + (-1/3)*x*x*x+(51/2)*x*x-714*x;
end;
Procedure Dixot(var v:real);
//-------------------------------------------------------------------------------
var q,w,t,c,e:real;
begin
q:=-100;
w:=100;
e:=0.0001;
c:=(q+w)/2;
while abs(q-w)>e do
begin
t:=Fu(q)*Fu(c);
if t <0 then
w:=c
else
q:=c;
c:=(q+w)/2;
end;
v:=(q+w)/2;
end;
//----------------------------------------------------------------------------
Procedure Integral( acrt:real; bcrt:real; n: longint);
var x:real;i:longint;S1,S2,p,ap:real;
begin
clrscr;
writeln('Calculation area of the shape using the right-hand rectangle method');
S1:=0;
i:=1;
for i:=1 to n do
begin
x:=acrt+i*h;
s1:=s1+Fu(x)*h;
end;
writeln('Area is equal ','= ' , s1:0:6);
writeln();
writeln('Calculate the area of analytical methods and consider the error');
begin
S2:=per(bcrt)-per(acrt);
p:=abs(s1-s2);
if p=0 then ap:=0
else ap:= (p/s2)*100;
writeln('analytical method' ,' = ', S2:0:6);
writeln();
writeln('calculation error = +- ', p:0:5);
writeln();
writeln('absolute calculating error =' , ap:0:5, '%' );
end;
readln();
end;
//-----------------------------------------------------------------------------------
Procedure Ris;
begin
xleft := maxx;
yLeft := maxy;
xRight := 900 - maxx;
yRight := GetMaxY - maxy;
a1:=-50;b1:=50;
mx:=(Xright-Xleft)/(b-a);
my := (yRight - yLeft) / (fmax - fmin);
x0 := 900 div 2;
y0 := getmaxy div 2;
line(xLeft, y0, xRight + 25, y0);
line(x0, yLeft-25, x0, yRight);
line(xright+25,y0,xright+10,y0-8);
line(xright+25,y0,xright+10,y0+8);
line(x0,yleft-25,x0-8,yleft-10);
line(x0,yleft-25,x0+8,yleft-10);
SetColor(4);
SetTextStyle(1, 0, 1);
OutTextXY(xRight + 20, y0 - 25, 'X');
OutTextXY(x0 - 15, yLeft - 35, 'Y');
SetColor(14);
n := round((b - a) / dx) + 1;
for i := 1 to n do
begin
num := a + (i - 1) * dx;
x := xLeft + trunc(mx*(num-a));
Line(x, y0 -3, x, y0 +3);
str(Num:0:0, s);
if abs(num) > 1E-15 then
OutTextXY(x - TextWidth(s) div 2, y0 + 10, s);
end;
n := round((fmax - fmin) / dy) + 1;
for i := 1 to n do
begin
num := fMin + (i - 1) * dy;
y := yRight - trunc(my * (num - fmin));
Line(x0 - 3, y, x0 + 3, y);
str(num:0:0, s);
if abs(num) > 1E-15 then
OutTextXY(x0 + 7, y - TextHeight(s) div 2, s)
end;
OutTextXY(x0 - 10, y0 + 10, '0');
//-------------------------------------------------------------------
x1:=a1;
while x1<= b1 do
begin
y1:=Fu(x1);
x:=x0+round(mx*x1);
y:=y0-round(my*y1);
if (y<=yright) and (y>=yleft) then
putpixel(x,y,14);
x1:= x1+0.001;
end;
begin
setcolor(14);
x2:=trunc(a2*mx);
y2:=trunc(Fu(a2)*my);
toc1:=x0+x2;
toc2:=y0-y2;
moveto(x0+x2,y0);
lineto(x0+x2,y0-y2);
x2:=trunc(b2*mx);
y2:=trunc(Fu(b2)*my);
toc3:=x0+x2;
toc4:=y0-y2;
moveto(x0+x2,y0);
lineto(x0+x2,y0-y2);
line(toc1,toc2,toc3,toc4);
line(toc1,y0,toc3,y0);
setfillstyle(3,13);
floodfill(toc1+1,y0-1,14);
end;
c:=a2;z:=(b2-a2)/k;
while c<=b2 do
begin
h1:=trunc((z)*mx);
x2:= trunc((c)*mx);
y2:=trunc(Fu(c)*my);
moveto(x0+x2,y0);
Lineto(x0+x2,y0-y2);
lineto(x0+x2+h1,y0-y2);
lineto(x0+x2+h1,y0);
lineto(x0+x2,y0);
c:=c+z;
end;
end;
Procedure cl;
begin
clearviewport;
end;
//-------------------------------------------------------------------------------------
procedure gravik;
var
i: byte;
s: string;
rk:char;
begin
clrscr;
if (acrt<-30) or (bcrt>-8) or (n1>50) then begin writeln('Enter limit a> -30 and limit b<-8 and n<50'); writeln('Imccoret for graph,repeat');readln(); input(acrt,bcrt,n); end
else begin
a2:=round(acrt);b2:=round(bcrt); k:=n1;
Gd := Detect;
//etgraphmode(getgraphmode);
InitGraph(Gd, Gm, '');
//setgraphmode(getgraphmode);
setcolor(1);
Settextstyle(2,2,1);
s:= 'Function =-2*x^3-1*x^2+51*x-714';
OuttextXy(1000,40,S);
x0 := Getmaxx div 2;
y0 := getmaxy div 2;
setcolor(10);
settextstyle(2,2,2);
Outtextxy(1100,100,'SCALING');
settextstyle(1,3,2);
Outtextxy(920,150,'ZOOM Ox + = 9 ');
Outtextxy(1150,150,'ZOOM Ox - = 6 ');
Outtextxy(920,180,'ZOOM Oy + = 7 ');
Outtextxy(1150,180,'ZOOM Oy - = 4 ');
Outtextxy(920,210,'NORM Ox = 3 ');
Outtextxy(1150,210,'NORM Oy = 1 ');
Outtextxy(920,240,'Z00M + = + ');
Outtextxy(1150,240,'ZOOM - = - ');
setcolor(1);
settextstyle(2,2,2);
setcolor(2);
Outtextxy(1050,330,'IND. SCALING');
Outtextxy(920,360,'ZOOM X+ = V');
Outtextxy(1150,360,'ZOOM Y+ = N');
Outtextxy(920,390,'ZOOM X- = B');
Outtextxy(1150,390,'ZOOM Y- = C');
Outtextxy(1050,420,'NORM XY = M ');
setcolor(1);
setcolor(5);
outtextxy(1000,450,'NORM Graph = ENTER');
setcolor(1);
Settextstyle(2,2,1);
s:= 'FOR EXIT PUT ESCAPE';
OuttextXy(1000,500,S);
maxx:=100;
maxy:=50;
a:=-50;
b:=50;
dx:=b/5;
fmin := -50000; fmax := 50000;dy:=5000;
setviewport(0,0,900,getmaxy,clipon);
setcolor(14);
Ris;
repeat
rk:=readkey;
case rk of
#43: if (b<450) and (fmax<100000) then
begin
cl;
a:=a-100;
b:=b+100;
dx:=b/10;
fmin:=fmin-10000;
fmax:=fmax+10000;
dy:=fmax/10;
end;
#45: if (b>50) and (fmax>40000) then
begin
cl;
a:=a+100;
b:=b-100;
dx:=b/10;
fmin:=fmin+10000;
fmax:=fmax-10000;
dy:=fmax/10;
end;
#57: if b<450 then
begin
cl;
a:=a-100;
b:=b+100;
dx:=b/10;
end;
#54: if b>50 then
begin
cl;
a:=a+100;
b:=b-100;
dx:=b/10;
end;
#51: begin cl; a:=-50;b:=50;dx:=b/10; end;
#55: if fmax<100000 then
begin
cl;
fmin:=fmin-10000;
fmax:=fmax+10000;
dy:=fmax/10;
end;
#52: if fmax > 40000 then
begin
cl;
fmin:=fmin+10000;
fmax:=fmax-10000;
dy:=fmax/10;
end;
#49: begin cl; fmax:=50000;fmin:=-50000; dy:=fmax/10; end;
#13: begin cl;fmax:=50000;fmin:=-50000; dy:=fmax/10; a:=-50;b:=50;dx:=b/10;maxx:=100; maxy:=50; end;
#99: if maxx < 200 then
begin
cl;
maxx:=maxx+50;
end;
#118: if maxx>100 then
begin
cl;
maxx:=maxx-50;
end;
#110: if maxy>50 then
begin
cl;
maxy:=maxy-50;
end;
#98: if maxy<150 then
begin
cl;
maxy:=maxy+30;
end;
#109: begin cl;maxx:=100; maxy:=50; end;
end;
Ris;
until rk=#27;
restorecrtmode;
end;
end;
//-------------------------------------------------------------------------------------------
begin
restorecrtmode;
clrscr;
Dixot(kor);
menu[1]:='1) Information';
menu[2]:='2) Input of data';
menu[3]:='3) Right rectangle calculation and calculation of measurement error';
menu[4]:='4) Graph';
menu[5]:='5) Exit';
place:=1;
MenuToScr;
repeat
rk:=readkey;
// restorecrtmode;
if rk=#0
then
begin
rk:=readkey;
case rk of
#80: if place=q
then
begin
gotoxy(xr,yr+place-1);write(menu[place]);
TextColor(ac);
place:=1;
gotoxy(xr,yr+place-1);write(menu[place]);
TextColor(pa);
end
else
begin
gotoxy(xr,yr+place-1);write(menu[place]);
TextColor(ac);
place:=place+1;
gotoxy(xr,yr+place-1);write(menu[place]);
TextColor(pa);
end;
#72: if place=1 then
begin
gotoxy(xr,yr+place-1);write(menu[place]);
TextColor(ac);
place:=q;
gotoxy(xr,yr+place-1);write(menu[place]);
TextColor(pa);
end
else
begin
gotoxy(xr,yr+place-1);write(menu[place]);
TextColor(ac);
place:=place-1;
gotoxy(xr,yr+place-1);write(menu[place]);
TextColor(pa);
end;
end;
end
else
begin
if rk=#13
then
begin
case place of
1: Information;
2: Input(acrt,bcrt,n);
3: Integral(acrt,bcrt,n);
4: gravik;
5: rk:=#27;
end
end;
MenuToScr;
end;
until rk=#27;
end.
- Код: Выделить всё
[code][/code]
). Если Вы хотите совместить всё это типа два-в-одном, то у Вас принципиальная ошибка проектирования и эту ошибку программно не исправить. Не исключено, что можно каким-то таинственным способом сделать так, чтобы при переходе в графический режим, у Вас не образовывалось новое окно. Но проблема в том, что Вы используете методику, которой сорок лет исполняется в обед. Я вот, к примеру, старый лысый дедушка, помню ещё живого Мао Дзедуна, но и то, как на новом компе с новой операционкой эмулировать совмещение двух режимов в одном окне, сказать Вам не могу. Чего уж ожидать от присутствующей здесь молодёжи, которая подобной некрофилией сроду не интересовалась... 
