Решить уравнение - Pascal (80478)

uses crt;
 
type BigReal = record mant: extended; expt: int64 end;
     Matrix = array of array of longint;
     rt = array [1..2] of BigReal;
 
procedure WriteBigReal(a: BigReal);
begin
  if a.mant >= 0
    then write('+')
    else write('-');
  write(abs(a.mant):0:17, 'e');
  if a.expt >= 0 then write('+');
  write(a.expt)
end;
 
procedure Normalize(var a: BigReal);
begin
  if a.mant = 0
    then a.expt := 0
    else begin
      while abs(a.mant) >= 10 do
        begin
          inc(a.expt);
          a.mant /= 10
        end;
      while abs(a.mant) < 1 do
        begin
          dec(a.expt);
          a.mant *= 10
        end
    end
end;
 
procedure Scale(var a: BigReal; n: int64);
var i: int64;
begin
  i := 1;
  while i <= n do
    begin
      inc(i);
      inc(a.expt);
      a.mant /= 10
    end
end;
 
function IntToBigReal(n: longint): BigReal;
begin
  Result.mant := n;
  Normalize(Result)
end;
 
procedure align(var a, b: BigReal);
var diff: int64;
begin
  diff := a.expt - b.expt;
  if diff > 20
    then begin
      b.mant := 0;
      b.expt := a.expt
    end
    else if diff < -20
      then begin
        a.mant := 0;
        a.expt := b.expt
      end
      else if diff > 0
        then Scale(b, diff)
        else if diff < 0
          then Scale(a, -diff)
end;
 
operator *(a, b: BigReal)c: BigReal;
begin
  c.mant := a.mant * b.mant;
  c.expt := a.expt + b.expt;
  normalize(c)
end;
 
operator /(a, b: BigReal)c: BigReal;
begin
  if b.mant = 0
    then begin
      write('Ошибка: попытка деления на ноль.');
      readln;
      halt
    end;
  c.mant := a.mant / b.mant;
  c.expt := a.expt - b.expt;
  normalize(c)
end;
 
operator +(a, b: BigReal)c: BigReal;
begin
  align(a, b);
  c.mant := a.mant + b.mant;
  c.expt := a.expt;
  normalize(c)
end;
 
operator -(a, b: BigReal)c: BigReal;
begin
  align(a, b);
  c.mant := a.mant - b.mant;
  c.expt := a.expt;
  normalize(c)
end;
 
function SqrtBigReal(a: BigReal): BigReal;
begin
  if a.mant < 0
    then begin
      write('Ошибка: попытка вычисления квадратного корня из отрицательного числа.');
      readln;
      halt
    end;
  if odd(a.expt)
    then begin
      dec(a.expt);
      a.mant *= 10
    end;
  Result.mant := sqrt(a.mant);
  Result.expt := a.expt div 2;
end;
 
function Factorial(n: longint): BigReal;
const one: BigReal = (mant: 1; expt: 0);
var i: integer;
begin
  if n < 0
    then begin
      write('Ошибка: попытка вычисления факториала от отрицательного числа.');
      readln;
      halt
    end;
  Result := one;
  for i := 2 to n do
    begin
      Result.mant := Result.mant * i;
      Normalize(Result)
    end;
end;
 
const q = 1; //количество значащих цифр в элементах массива
      r = round(exp(q * ln(10))) - 1;
 
procedure Generate(var x: Matrix);
var i, j: longint;
begin
  for i := low(x) to high(x) do
    for j := low(x[low(x)]) to high(x[low(x)]) do
      x[i, j] := -r + random(2 * r + 1)
end;
 
procedure WriteMatrix(s: string; var x: Matrix);
var i, j: longint;
begin
  writeln('Матрица ', s, ':');
  textcolor(LightGray);
  for i := 0 to high(x) do
    begin
      for j := 0 to high(x[0]) do
        begin
          write(x[i, j]:q + 2);
          if j = high(x) - i then textcolor(Yellow)
        end;
      textcolor(LightGray);
      writeln
    end
end;
 
procedure Preprocessing(s: string; var x: Matrix; x_r: integer; var quantity, sum_abs: longint);
var c: char;
    i, j: integer;
begin
  setlength(x, x_r, x_r);
  generate(x);
  WriteMatrix(s, x);
  quantity := x_r * (x_r - 1) div 2;
  writeln('Количество элементов матрицы ниже побочной диагонали: ', quantity);
  sum_abs := 0;
  for i := 1 to high(x) do
    for j := high(x) - i + 1 to high(x) do
      sum_abs += abs(x[i, j]);
  writeln('Сумма их модулей: ', sum_abs);
  write('Нажмите <Enter> для продолжения работы', #13);
  {c := }readkey;
  writeln('                                      ')
end;
 
procedure CompileRoots(a, b, c: BigReal; var x: rt; var n: integer);
const mone: BigReal = (mant: -1; expt: 0);
      two: BigReal = (mant: 2; expt: 0);
      mtwo: BigReal = (mant: -2; expt: 0);
      four: BigReal = (mant: 4; expt: 0);
var d, d1: BigReal;
begin
  if (b.mant = 0) and (c.mant <> 0)
    then n := 4
    else if (a.mant = 0) and (b.mant = 0) and (c.mant = 0)
      then n := 3
      else if (a.mant = 0) and (b.mant <> 0)
        then begin
          n := 1;
          c.mant *= -1;
          x[1] := c / b
        end
        else begin
          d := b * b - four * a * c;
          if d.mant < 0
            then n := 0
            else if d.mant = 0
              then begin
                n := 1;
                x[1] := (b / a) / mtwo
              end
              else begin
                n := 2;
                d := SqrtBigReal(d);
                x[1] := ((b - d) / a) / mtwo;
                x[2] := ((b + d) / a) / mtwo;
              end
        end
end;
 
const z_r = 6;
      w_r = 11;
      v_r = 12;
 
var z, w, v: Matrix;
    a, b, c, d, k, m: longint;
    p2, p1, p0: BigReal;
    roots: rt;
    n, i: integer;
begin
  randomize;
  Preprocessing('Z', z, z_r, a, b);
  Preprocessing('W', w, w_r, c, d);
  Preprocessing('V', v, v_r, k, m);
  p2 := Factorial(a * b);
  p1 := Factorial(c * d);
  p0 := Factorial(k * m);
  writeln('Уравнение:');
  WriteBigReal(p2);
  writeln(' * x^2');
  WriteBigReal(p1);
  writeln(' * x');
  WriteBigReal(p0);
  writeln(' = 0');
  CompileRoots(p2, p1, p0, roots, n);
  case n of
    1: begin
         writeln('Уравнение имеет один корень:');
         write('x[1] = ');
         WriteBigReal(roots[1]);
         writeln
       end;
    2: begin
         writeln('Уравнение имеет два корня:');
         for i := 1 to 2 do
           begin
             write('x[', i, '] = ');
             WriteBigReal(roots[i]);
             writeln
           end
       end;
    3: writeln('Уравнение имеет бесконечное множество корней')
    else writeln('уравнение не имеет корней')
  end;
  write('Нажмите <Enter> для выхода');
  readln
end.