Разработка программного обеспечения для решения уравнений с одной переменной методом Ньютона (касательных) (стр. 4 из 5)

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: &bsol;temp&bsol;my_stuff&bsol;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: &bsol;temp&bsol;my_stuff&bsol;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: &bsol;temp&bsol;my_stuff&bsol;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: &bsol;temp&bsol;my_stuff&bsol;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: &bsol;temp&bsol;my_stuff&bsol;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: &bsol;temp&bsol;my_stuff&bsol;E. txt');

ReWrite (f); Write (f, E); Close (f);

Assign (f, 'c: &bsol;temp&bsol;my_stuff&bsol;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);