Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > IT форум > Помощь студентам
Регистрация

Восстановить пароль
Повторная активизация e-mail

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 04.06.2023, 13:00   #1
Student_Dead1nS1de
Пользователь
 
Регистрация: 12.01.2023
Сообщений: 19
Счастье FreePascal, PascalABC, Pascalabc.net

Реализовать программу вычисления площади фигуры, ограниченной кривой x^3 - 2x^2 +4x +16 и осью оХ ( в положительной части по оси OY)
Вычисление интеграла с помощью метода левых прямоугольников.
Пределы интегрирования вводятся пользователем.
Также присутствует оценка погрешности.
Вот готовая программа
Код:
uses sysutils, wincrt, crt, graph;
const
  nvis = DarkGray;
  vis = LightGray;
  n = 7;
  x0 = -1.621;
  function f(x: real):real;
  begin
  f:= 1*x*x*x + (-2)*x*x +4*x + 16;
  end;
function g(x:real): real;
begin
 g:= (1/4*x*x*x*x) -((2/3)*x*x*x)+(2*x*x) + 16*x;
 end;
var
        menu: array[1..7] of string[60];
        item: integer;
        ch: char;
        x,y,la,Rspl, valid, i: integer;
        p,s,a,b,l,spl,spr, xy, inac: real;
procedure first;
begin
 clrscr;
 writeln('Function x^3 + (-2)*x^2 + 4*x + 16');
 writeln('The method of Left rectangles');
  writeln('Function root -1.621');
 writeln('To exit press <Enter>');
 repeat
 ch:= readkey; if ch = #0 then
 begin
 ch:= readkey;
 end;
 until ch = #13;
 end;
 procedure second;
 begin
 Clrscr;
 begin
         la:=0;
         repeat
         writeln(' The Left limit -2 do 100');
         readln(a);
 until(a>= -2) and (a<100);
 la:= 1;
 repeat
         writeln('The Right limit ', a:0:2, ' do 100');
         readln(b);
 until(b>a) and (b <= 100);
        writeln('To exit touch <Enter>');
        readln;
 end;
 end;

procedure third;
begin
clrscr;
if (la =0) then
begin
        writeln('Not all data is entered');
        readln;
end
else
begin
        valid:= 0;
        repeat
          writeln('Write the number of partition for 20 to 1000');
          readln(spl);
          //val(spl,spr,er);
        until (spl >= 20) and (spl<=1000);
        p:= (b -a)/spl;
        valid :=1;
        writeln('To exit touch <Enter>');
        readln;
   end;
end;


procedure fourth;
begin
  clrscr;
  if valid=0 then writeln('Not all data is entered')
  else
  begin
    if (b< x0) then
    begin
      s:=0;
      writeln('Square= ', s:0:5);
      end
    else
    begin
      if a>x0 then l:= a
      else
      begin
      l:= x0;
      a:= x0;
    end;
  p:=(b -a)/ spl;
  s:= 0;
  Rspl:= Round(spl);
  for i:= 1 to Rspl do
   begin
   s:= s+ f(l)*p;
   l:= l+p;
   end;
  writeln('Square=', s:0:4);
 xy:= g(b) - g(a);
 end;
end;
writeln('');
writeln('To exit touch <Enter>');
readln;
end;

procedure fifth;
begin
  clrscr;
  if(valid = 0) then begin
  writeln('Not all data is entered');
  readln;
  end
  else
  begin
    if a> x0 then begin
    inac:= ((abs(xy - s)/xy)*100);
    writeln('Absolute innaccuracy= ', abs(xy - s):0:6);
    //
    writeln('Relative inaccuracy= ', inac:5:3, '%')
    end
    else begin
      writeln('Absolute innaccuracy=0');
      writeln('Relative inaccuracy= 0%');
      end;
  writeln('To exit touch <Enter>');
  readln;
  end;
end;

procedure sixth;
const
    Zero: PointType = (x: 700; y:600);
    ScaleX: Integer= 33;
    ScaleY: Integer = 30;
    StartPoint: Integer = -5;
    EndPoint: Integer =5;
var
grDriver, grMode: integer;

 procedure Lines;
 var
 i: integer;
 s: string;
 begin
 SetColor(Green);
 SetLineStyle(SolidLn, NormWidth,1);
 SetColor(Green);
 for i:= -Zero.x div ScaleX to (GetMaxX - Zero.x) div ScaleX do
 begin
   Str(i,s); SetColor(White);OutTextXy(Zero.x + i* ScaleX +2, Zero.y,s)
   end;
  for i:= -Zero.y div ScaleY to (GetMaxY - Zero.y) div ScaleY do
  begin
   Str(-i, s);SetColor(White);OutTextXy(Zero.x + 2,Zero.y + i* ScaleY,s)
   end;
  SetColor(White);
  for i:= 1 to 60 do
  begin
  line(Zero.x + Round(i*ScaleX), Zero.y - 3, Zero.x + Round(i* ScaleX),Zero.y + 3);
  line(Zero.x -3,Zero.y + Round(i*ScaleY), Zero.x + 3, Zero.y + Round(i* ScaleY));
  line(Zero.x + Round(i*ScaleX), Zero.y - 3, Zero.x + Round(i* ScaleX),Zero.y + 3);
  line(Zero.x -3,Zero.y + Round(i*ScaleY), Zero.x + 3, Zero.y + Round(i* ScaleY));
  end;
 end;
Student_Dead1nS1de вне форума Ответить с цитированием
Старый 04.06.2023, 13:01   #2
Student_Dead1nS1de
Пользователь
 
Регистрация: 12.01.2023
Сообщений: 19
По умолчанию

Вот вторая часть, т.к. не влазеит,
Код:
procedure FDraw;
var x: real;
begin
  SetColor(Green);
  SetLineStyle(SolidLn, NormWidth,3);
  x:= StartPoint;
  MoveTo(Zero.x + Round(x * ScaleX), Zero.y - Round(f(x) * ScaleY));
    repeat
      x := x + (1 / ScaleX);
    LineTo(Zero.x + Round(x * ScaleX), Zero.y - Round(f(x) * ScaleY))
  until x>= EndPoint
end;

procedure hatch;
var x: real;
i: integer;
begin
  SetLineStyle(SolidLn, NormWidth,1);
  i:= Zero.x + Round(a* ScaleX);
  x:= a- 0.0671;
  repeat
   x:= x+ (5/ScaleX);
   SetColor(Green);
     if (Zero.y - Round(f(x) * ScaleY)) < (Zero.y - Round(f(EndPoint) * ScaleY)) then
        line(i, Zero.y, i, Zero.y - Round(f(EndPoint) * ScaleY))
      else
        line(i, Zero.y, i, Zero.y - Round(f(x) * ScaleY));
      i := i + 5;
      until(i> (Zero.x + Round(b* ScaleX)))
      end;
begin
clrscr;
grDriver:= Detect;
grMode := GetMaxMode;
InitGraph( grDriver, grMode,'');
repeat
 ClearDevice;
 FDraw;
 Lines;
 SetColor(White);
    line(840 + Zero.x, Zero.y, 810 + Zero.x, 15 + Zero.y);
    line(840 + Zero.x, Zero.y, 810 + Zero.x, Zero.y - 15);
    outtextXY(820 + Zero.x, Zero.y + 20, 'X');
    line(Zero.x, Zero.y - 600, Zero.x + 15, Zero.y - 570);
    line(Zero.x, Zero.y - 600, Zero.x - 15, Zero.y - 570);
    outtextXY(Zero.x - 30, Zero.y - 590, 'Y');
    if b> x0 then if a< x0 then
    begin a:= x0; hatch;
    end
    else hatch;
 SetLineStyle(DAshedLn, ThickWidth,3);  SetColor(Cyan);
 Line(Zero.x + Round(a * ScaleX), Zero.y + (-180 * ScaleY), Zero.x + Round(a * ScaleX), Zero.y + (180 * ScaleY));
 Line(Zero.x + Round(b * ScaleX), Zero.y + (-180 * ScaleY), Zero.x + Round(b * ScaleX), Zero.y + (180 * ScaleY));
  SetLineStyle(SolidLn, NormWidth,1);SetColor(White);
 Line(Zero.x -( 180*ScaleX), Zero.y, Zero.x +( 180*ScaleX), Zero.y);
 SetLineStyle(SolidLn, NormWidth,1);

 outTextXY(30,30, 'Function f(x)= x^3 -2*x^2 +4*x +(16)');
 outTextXY(30,40, 'LEFT,RIGHT - Approximation to OX');
 outTextXY(30,50, 'UP, Down - Approximation to OY');
 outTextXY(30,60, '-+ Scaling');
 outTextXY(30,70, 'ESC- Exit');

 Setcolor(white); {ось У }
 Line(Zero.x, Zero.y + 180*ScaleY,Zero.x, Zero.y - 180*ScaleX);
 ch:= wincrt.ReadKey;
 if ch = #0 then begin
 ch:= wincrt.Readkey;
  case ch of
    #77: if ScaleX < 150 then ScaleX:= ScaleX + 4 + 4;
    #75: if ScaleX > 25 then ScaleX:= ScaleX - 4 - 4;
    #72: if ScaleY < 150 then ScaleY:= ScaleY + 4 + 4;
    #80: if (ScaleY > 15) and (ScaleX > 15) then ScaleY:= ScaleY - 4 - 4 ;
    end;
  end
  else begin
    case ch of
    char(61): if  ScaleX< 150 then begin Inc(ScaleX,5); Inc(ScaleY,5)
    end;
    char(45): if (ScaleX > 15) and(ScaleY > 15) then begin Dec(ScaleX,5);Dec(ScaleY,5);end;
    char(27): break
    end;
  end
  until False;
  CloseGraph;
  Writeln('Touch <Enter> to continue');
  repeat
  ch:= readkey;
  until ch= #13
  end;

procedure MenuToScr;
var
i: integer;
begin
clrscr;
  for i:=1 to n do begin
    GoToXY(x,y+i -1);
    write(menu[i]);
    end;
    TextAttr:= vis;
    GoToXY(x,y + item -1);
    write(menu[item]);
    TextAttr:= nvis;
    end;
begin
  menu[1]:= ' Info ';
  menu[2]:= ' Write limits';
  menu[3]:= ' Write Partition';
  menu[4]:= ' Result ';
  menu[5]:= ' Inaccuracy ';
  menu[6]:= ' Visualisation ';
  menu[7]:= ' Exit ';
  item:=1;
  x:= 1;
  y:=1;
  TextAttr:= nvis;
  MenuToScr;
   repeat
    ch:= ReadKEy;
     if ch = #0 then begin
      ch:= ReadKey;
  case ch of
  #80:
  if item < n then begin
  gotoXY(x,y + item -1); write(menu[item]);
  item:= item + 1;
  TextAttr:= vis;
  gotoXY(x,y + item -1); write(menu[item]);
  TextAttr:= nvis;
  end
  else begin
   gotoXY(x,y + item -1); write(menu[item]);
   item:= 1;
   TextAttr:= vis;
   gotoXY(x,y + item -1); write(menu[item]);
   TextAttr:= nvis;
   end;
#72:
if item >1 then begin
 gotoXY(x,y + item -1); write(menu[item]);
  item:= item - 1;
  TextAttr:= vis;
  gotoXY(x,y + item -1); write(menu[item]);
  TextAttr:= nvis;
  end
  else  begin
   gotoXY(x,y + item -1); write(menu[item]);
   item:= 7;
   TextAttr:= vis;
   gotoXY(x,y + item -1); write(menu[item]);
   TextAttr:= nvis;
   end;
  end;
 end
else
if ch =#13 then begin
case item of
1: first;
2: second;
3: third;
4: fourth;
5: fifth;
6: sixth;
7: ch:= #27;
end;
MEnuToScr;
end;
until ch = #27;
end.
 end.
Student_Dead1nS1de вне форума Ответить с цитированием
Старый 05.06.2023, 17:06   #3
newerow1989
Я самый любопытный
Участник клуба
 
Аватар для newerow1989
 
Регистрация: 24.07.2012
Сообщений: 1,949
По умолчанию

А по-проще нельзя написать?
Вот код:
Код:
function f(x: real): real;
begin
   Result:=x*x*x-2*x*x+4*x+16;
end;

const dx = 0.001;
var a, b, x, y, s: real;
begin
   Write('a = '); Readln(a);
   Write('b = '); Readln(b);
   s:=0;
   x:=a+dx/2;
   while x<b do
   begin
      y:=f(x);
      if y>0 then
         s:=s+dx*y;
      x:=x+dx;
   end;
   Writeln('s = ', s:5:5);
   Readln;
end.
С запрограммированным приветом, Неверов Евгений!
Сайт: http://newerow1989.ru
[Паскаль] [Delphi]
newerow1989 вне форума Ответить с цитированием
Ответ


Купить рекламу на форуме - 42 тыс руб за месяц

Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
FreePascal, PascalABC, Pascalabc.net Student_Dead1nS1de Помощь студентам 1 06.03.2023 20:11
Преобразование кода из C в PascalABC.NET (символы и строки) - PascalABC.NET ParkerVans Помощь студентам 5 05.12.2017 10:09
PascalABC stalker161reg Помощь студентам 0 25.12.2013 15:18
PascalABC.net *stRong* Помощь студентам 2 10.06.2010 17:50
3D в PascalABC Рудко Дмитрий Паскаль, Turbo Pascal, PascalABC.NET 6 09.02.2010 13:02