Курсовая работа: Разработка программного обеспечения для решения уравнений с одной переменной методом Ньютона (касательных)
begin
If number=0 then OutTextXY(300, 20, 'Введите сначала данные в уравнение!!! ') else
begin
ClearDevice;
SetBKColor (black);
case number of
1: grand: =('y(x) =*ln(*x) ');
2: begin grand: =('y(x) =*sqr(x) +*x+');
str (c: 0: 2, gr); insert (gr, grand, 17); end;
end;
str (b: 0: 2, gr); insert (gr, grand, (6+number*4));
str (a: 0: 2, gr); insert (gr, grand, 6);
OutTextXY (300, 40, grand);
y1: =0; y2: =0;
x: =m;
Repeat
y: =f (x);
if y < y1 then y1: =y;
if y > y2 then y2: =y;
x: =x+0.01;
Until (x >= n);
my: =250/abs (y2-y1);
If (abs (m) > abs (n)) then mx: =250/abs (m) else
mx: =250/abs (n);
y0: =360-abs (Round (y1*my));
setka (y0, y2);
SetColor (blue);
Line (320, 360, 320, 90);
Line (70, y0, 590, y0);
Line (320, 90, 317, 93); Line (320, 90, 323, 93);
Line (590, y0, 587, y0-3); Line (590, y0, 587, y0+3);
OutTextXY (595, y0-5, 'x'); OutTextXY (315, 80, 'y');
OutTextXY (400, 450, 'Нажмите "Ввод" для выхода');
If Abs (m) > Abs (n) then y1: =Abs (m) else y1: =Abs (n);
SetColor (Red);
str (mass [i]: 5: 4, grand);
OutTextXY (300+Round ((250/y1) *mass [i]), 400, grand);
Line (320+Round ((250/y1) *mass [i]), y0, 320+Round ((250/y1) *mass [i]), 390);
For l: =1 to i-1 do
begin
SetColor (2+l);
Line (320+Round ((250/y1) *mass [l]), y0+10, 320+Round ((250/y1) *mass [l]), y0-10);
end;
x: =m;
Repeat
y: =f (x);
PutPixel (320+Round (x*mx), y0-Round (y*my), 15);
x: =x+0.01;
Until (x >= n);
ReadLn;
pro;
end;
end;
{***************************************************************************}
{***************************************************************************}
procedure load_file_1;
var mistake: byte;
k: char;
st: string;
f: text;
begin
Repeat
If number = 1 then
WriteLn (' Введите промежутки [m, n] одного знака') else
WriteLn (' Введите промежутки [m, n] ');
WriteLn ('Нажмите "1" для ввода данных с клавиатуры');
WriteLn ('Нажмите "2" для ввода данных из файла');
k: =ReadKey;
Case k of
'1': begin
WriteLn (' Ввод: ');
{$I-}
ReadLn (m, n);
{$I+}
mistake: =IOResult;
If mistake <> 0 then WriteLn ('Ошибка ввода');
end;
'2': begin
WriteLn (' Нажмите "1" для указания расположения своего файла');
WriteLn (' Нажмите "2" для ввода из файла, созданного автоматически');
k: =ReadKey;
If k = '1' then begin
WriteLn ('Введите путь к файлу с расширением. txt');
ReadLn (st);
Assign (f, st);
end else
If k = '2' then assign (f, 'c: \temp\my_stuff\m_n. txt');
{$I-}
Reset (f);
{$I+}
mistake: =IOResult;
If mistake <> 0 then
WriteLn ('Файла не существует') else
begin
{$I-}
Read (f, m, n);
{$I+}
mistake: =IOResult; Close (f); If mistake <> 0 then
WriteLn ('Информация в файле не соответствует нужному типу') else
begin
WriteLn (m: 0: 2);
WriteLn (n: 0: 2);
end;
end; WriteLn ('Нажмите "Ввод для продолжения"'); ReadLn;
end;
end;
Until mistake = 0;
end;
{***************************************************************************}
procedure load_file_2;
var mistake: byte;
k: char;
st: string;
f: text;
begin
Repeat
WriteLn ('Нажмите "1" для ввода с клавиатуры');
WriteLn ('Нажмите "2" для ввода данных из файла');
k: =ReadKey;
Case k of
'1': begin
WriteLn (' Ввод: ');
If number = 1 then {$I-} ReadLn (a, b) {$I+} else
If number = 2 then {$I-} ReadLn (a, b, c) {$I-};
mistake: =IOResult;
If mistake <> 0 then WriteLn ('Ошибка ввода');
end;
'2': begin
WriteLn (' Нажмите "1" для указания расположения своего файла');
WriteLn (' Нажмите "2" для ввода из файла, созданного автоматически');
k: =ReadKey;
If k = '1' then begin
WriteLn ('Введите путь к файлу расширением. txt');
ReadLn (st);
assign (f, st);
end else
If k = '2' then assign (f, 'c: \temp\my_stuff\a_b_c. txt');
{$I-}
Reset (f);
{$I+}
mistake: =IOResult;
If mistake <> 0 then
WriteLn ('Файла не существует') else
begin
If number = 1 then {$I-} Read (f, a, b) {$I+} else
{$I-} Read (f, a, b, c); {$I+}
mistake: =IOResult; Close (f); If mistake <> 0 then
WriteLn ('Информация в файле не соответствует нужному типу') else
begin
WriteLn (a: 0: 2);
WriteLn (b: 0: 2);
If number = 2 then WriteLn (c: 0: 2);
end;
end; WriteLn ('Нажмите "Ввод для продолжения"'); ReadLn;
end;
end;
Until mistake = 0;
end;
{***************************************************************************}
procedure load_file_3 (var E: real);
var mistake: byte;
k: char;
st: string;
f: text;
begin
Repeat
WriteLn ('Нажмите "1" для ввода данных с клавиатуры');
WriteLn ('Нажмите "2" для ввода данных из файла');
k: =ReadKey;
Case k of
'1': begin
WriteLn (' Ввод: ');
{$I-}
ReadLn (E);
{$I+}
mistake: =IOResult;
If mistake <> 0 then WriteLn ('Ошибка ввода');
end;
'2': begin
WriteLn (' Нажмите "1" для указания расположения своего файла');
WriteLn (' Нажмите "2" для ввода из файла, созданного автоматически');
k: =ReadKey;
If k = '1' then begin
WriteLn ('Введите путь к файлу с расширением. txt');
ReadLn (st);
assign (f, st);
end else
If k = '2' then assign (f, 'c: \temp\my_stuff\E. txt');
{$I-}
Reset (f);
{$I+}
mistake: =IOResult;
If mistake <> 0 then
WriteLn ('Файла не существует') else
begin
{$I-}
Read (f, E);
{$I+}
mistake: =IOResult; Close (f); If mistake <> 0 then
WriteLn ('Информация в файле не соответствует нужному типу') else
begin
WriteLn (E: 0: 3);
end;
end; WriteLn ('Нажмите "Ввод для продолжения"'); ReadLn;
end;
end;
Until mistake = 0;
end;
{***************************************************************************}
procedure save_file (E: real);
var k: char;
mistake: byte;
f: text;
st: string;
begin
Repeat
WriteLn (' Если хотите сохранить данные и результаты нажмите "1"');
WriteLn (' Если не хотите сохранять данные и результаты нажмите "2"');
k: =ReadKey;
Case k of
'1': begin
WriteLn (' Если хотите сохранить данные в указанные вами файлы нажмите "1"');
WriteLn (' Если хотите, чтобы сохранение произошло автоматически нажмите "2"');
k: =ReadKey;
If k = '1' then begin
Repeat
WriteLn ('Введите путь и имя файла c для сохранения промежутков [m, n] ');
ReadLn (st);
Assign (f, st);
{$I-}
ReWrite (f);
{$I+}
mistake: =IOResult;
If mistake <> 0 then WriteLn ('Файл не может быть создан') else
begin
Write (f, m: 3, n: 3); Close (f); WriteLn ('Информация сохранена. Нажмите "Ввод"'); ReadLn;
end;
Until mistake = 0;
Repeat
If number = 1 then
WriteLn ('Введите путь и имя файла для сохранения коэффициентов "a", "b"')
else
If number = 2 then
WriteLn ('Введите путь и имя файла для сохранения коэффициентов "a", "b", "c"');
ReadLn (st);
Assign (f, st);
{$I-}
ReWrite (f);
{$I+}
mistake: =IOResult;
If mistake <> 0 then WriteLn ('Файл не может быть создан') else
begin
If number = 1 then begin
Write (f, a: 3, b: 3); Close (f); WriteLn ('Информация сохранена. Нажмите "Ввод"'); ReadLn;
end else
If number = 2 then begin
Write (f, a: 3, b: 3, c: 3); Close (f); WriteLn ('Информация сохранена. Нажмите "Ввод"'); ReadLn;
end;
end;
Until mistake = 0;
Repeat
WriteLn ('Введите путь и имя файла для сохранения погрешности "Е"');
ReadLn (st);
Assign (f, st);
{$I-}
ReWrite (f);
{$I+}
mistake: =IOResult;
If mistake <> 0 then WriteLn ('Файл не может быть создан') else
begin
Write (f, E: 3); Close (f); WriteLn ('Информация сохранена. Нажмите "Ввод"'); ReadLn;
end;
Until mistake = 0;
Repeat
WriteLn ('Введите путь и имя файла для сохранения корня');
ReadLn (st);
Assign (f, st);
{$I-}
ReWrite (f);
{$I+}
mistake: =IOResult;
If mistake <> 0 then WriteLn ('Файл не может быть создан') else
begin
Write (f, mass [i]: 3); Close (f); WriteLn ('Информация сохранена. Нажмите "Ввод"'); ReadLn;
end;
Until mistake = 0;
end else
If k = '2' then begin
Assign (f, 'c: \temp\my_stuff\m_n. txt');
{$I-} ReWrite (f); {$I+}
mistake: =IOResult;
If mistake <> 0 then WriteLn ('Каталога для сохранения не существует') else
begin
Write (f, m, n); Close (f);
Assign (f, 'c: \temp\my_stuff\a_b_c. txt');
ReWrite (f); If number = 1 then Write (f, a, b) else
Write (f, a, b, c); Close (f);
Assign (f, 'c: \temp\my_stuff\E. txt');
ReWrite (f); Write (f, E); Close (f);
Assign (f, 'c: \temp\my_stuff\x. txt');
ReWrite (f); Write (f, mass [i]); Close (f);
WriteLn ('Информация сохранена. Нажмите "Ввод"'); ReadLn;
end;
end;
end;
'2': mistake: =0;
end;
Until mistake = 0;
end;
{***************************************************************************}
{***************************************************************************}
procedure equation_1;
var mistake, code_of: byte;
E, x1, root: real;
bool_of: boolean;
k: char;
{***************************************************************************}
begin
closegraph;
bool_of: =false;
Repeat
number: =1;
clrscr;
WriteLn (' Уравнение вида: y(x) =a*ln(b*x) ');
Repeat
load_file_1;
If m > n then begin
WriteLn ('Введите "m" < "n" ');
WriteLn ('Нажмите "Ввод" для подолжения'); ReadLn;
end else
If (m < 0) and (n >0) or (m = 0) or (n = 0) then
begin
WriteLn ('"m" и "n" должны быть одного знака и неравные 0');
WriteLn ('Нажмите "Ввод" для продолжения'); ReadLn;
end;
Until (((m < 0) and (n < 0)) or ((m > 0) and (n > 0))) and (m <= n);
Repeat
WriteLn ('Введите коэффициенты уравнения "a", "b"');
load_file_2;
If m*b <= 0 then begin
WriteLn ('попробуйте ввести "b" другого знака и неравное 0');
WriteLn ('Нажмите "Ввод" для продолжения'); ReadLn;
end;
Until m*b > 0;
If a = 0 then begin
WriteLn ('Все "x" на промежутке [',m: 0: 1,'; ',n: 0: 1,'] - решения уравнения');
number: =0; end else
begin
Repeat
WriteLn ('Введите погрешность "E"');
load_file_3 (E);
If E <= 0 then begin WriteLn ('Введите "Е" больше 0');
WriteLn ('Нажмите "Ввод" для продолжения"');
end;
Until E > 0;
i: =1;
If (a*ln(b*m) *(-a/sqr(m))) > 0 then begin mass [i]: =m; code_of: =1 end else
If (a*ln(b*n) *(-a/sqr(n))) > 0 then begin mass [i]: =n; code_of: =1 end else
begin WriteLn ('Уравнение не имеет корней'); number: =0; code_of: =0; end;
If code_of = 1 then
begin
Repeat
x1: =mass [i] -a*ln(b*mass [i]) /(a/mass [i]);
root: =Abs (x1-mass [i]);
i: =i+1;
mass [i]: =x1;
Until root < E;
If (x1 < m) or (x1 > n) then
begin WriteLn ('Уравнение не имеет корней'); number: =0; code_of: =0; end else
WriteLn ('Корнем уравнения y(x) =', a: 0: 1, '*ln(', b: 0: 1, '*x) является: ', x1: 5: 4);
end;
end;
WriteLn ('Нажмите "Ввод"'); ReadLn; If code_of = 1 then save_file (E) else
WriteLn ('Так как уравнение не имеет корней, то сохранение не выполняется');
WriteLn ('Если хотите выйти, то нажмите "ESC"');
WriteLn ('Если хотите ввести другие данные, то нажмите "Ввод"');
k: =ReadKey;
code_of: =ord (k);
case code_of of
27: begin
bool_of: =true; graphica;
end;
13: bool_of: =false;
end;
Until bool_of;
end;
{***************************************************************************}
{***************************************************************************}
procedure equation_2;
var mistake, code_of: byte;
E, x1, root: real;
bool_of: boolean;
k: char;
{***************************************************************************}
begin
closegraph;
bool_of: =false;
Repeat
number: =2;
clrscr;
WriteLn (' Уравнение вида: y(x) =a*x^2+b*x+c');
Repeat
load_file_1;
If m > n then WriteLn ('Введите "m" < "n" ');
Until (m <= n);
WriteLn ('Введите коэффициенты уравнения "a", "b", "c"');
load_file_2;
If (a = 0) and (b = 0) and (c = 0) then begin
WriteLn ('Все "х" на промежутке [',m: 0: 1,'; ',n: 0: 1,'] - решения уравнения');
number: =0; end else
begin
Repeat
WriteLn ('Введите погрешность "Е"');
load_file_3 (E);
If E <= 0 then begin WriteLn ('Введите E > 0');
WriteLn ('Нажмите "Ввод" для продолжения');
end;
Until E > 0;
i: =1;
If (a*sqr(n) +b*n+c) *(2*a) >= 0 then begin mass [i]: =n; code_of: =1 end else
If (a*sqr(m) +b*m+c) *(2*a) >= 0 then begin mass [i]: =m; code_of: =1 end else
begin WriteLn ('Уравнение не имеет корней'); number: =0; code_of: =0; end;
If code_of = 1 then
begin
Repeat
x1: =mass [i] -((a*sqr(mass [i]) +b*mass [i] +c) /(2*a*mass [i] +b));
root: =Abs (x1-mass [i]);
i: =i+1;
mass [i]: =x1;
Until (root < E);
If (x1 < m) or (x1 > n) then
begin WriteLn ('Уравнение не имеет корней'); number: =0; code_of: =0; end else
WriteLn ('Корнем уравнения y(x) =', a: 0: 1, '*x^2+', b: 0: 1, '*x+', c: 0: 1, ' является: ', x1: 0: 4);
end;
end;
WriteLn ('Нажмите "Ввод"'); ReadLn; If code_of = 1 then save_file (E) else
WriteLn ('Так как уравнение не имеет корней, то сохранение не выполняется');
WriteLn ('Если хотите выйти, то нажмите "ESC"');
WriteLn ('Если хотите ввести другие данные, то нажмите "Ввод"');
k: =ReadKey;
code_of: =ord (k);
case code_of of
27: begin
bool_of: =true; graphica;
end;
13: bool_of: =false;
end;
Until bool_of;
end;
{***************************************************************************}
procedure key (p1: byte);
Var y1, y2: integer;
name: string;
i: byte;
begin
ClearDevice;
SetColor (white);
OutTextXY (250, 435, '"Ввод" - вход "z", "x" - перемещение по меню');
y1: =15;
y2: =70;
for i: =1 to 5 do
begin
Setcolor (blue);
Rectangle (16, y1-1, 251, y2-1);
RecTangle (17, y1-2, 252, y2-2);
RecTangle (18, y1-3, 253, y2-3);
SetFillStyle (1,lightblue);
Bar (15, y1, 250, y2);
case i of
1: Name: ='Cправка';
2: Name: ='y=a*ln(b*x) ';
3: Name: ='y=a*x^2+b*x+c';
4: Name: ='Построение графика';
5: Name: ='Выход';
end;
SetColor (white);
OutTextXY (45, y1+25, Name);
y1: =20+y2;
y2: =75+y2;
end;
SetColor (white);
p1: =p1-1;
Rectangle (18, 19+75*p1, 246, 66+75*p1);
end;
{***************************************************************************}
procedure help;
var st: string;
f: text;
y: integer;
mistake: byte;
begin
ClearDevice;
Assign (f, 'c: \temp\My_stuff\help. asc');
{$I-}
Reset (f);
{$I+}
mistake: =IOResult; SetTextStyle (0, 0, 0);
If mistake <> 0 then OutTextXY (250, 220, 'Файла не существует') else
begin
y: =0;
Repeat
y: =15+y;
ReadLn (f, st);
OutTextXY (45, y, st);
Until EOf (f);
Close (f);
end;
OutTextXY (400, 450, 'Нажмите "Ввод" для выхода');
ReadLn; pro;
end;
{***************************************************************************}
procedure eat (p2: byte; var bool: boolean);
begin
if p2=1 then help else
if p2=2 then equation_1 else
if p2=3 then equation_2 else
if p2=4 then groffunc else
if p2=5 then bool: =true;
end;
{***************************************************************************}
procedure pro;
var p, code: byte;
k: char;
bool: boolean;
begin
ClearDevice;
p: =1;
key (p);
bool: =false;
repeat
SetBKColor(lightgray);
SetTextStyle (1, 0, 4); SetColor (blue);
OutTextXY (390, 130, 'МЕНЮ');
SetTextStyle (0, 0, 0);
k: =ReadKey;
code: =ord (k);
Case code of
122: begin
p: =p-1; if p=0 then p: =5;
key (p);
end;
120: begin
p: =p+1; if p=6 then p: =1;
key (p);
end;
13: eat (p, bool);
end;
until bool;
CloseGraph;
end;
{***************************************************************************}
begin
title;
number: =0;
graphica;
end.
