Работа с очень большими числами

Материал из DRKB


Это модуль для работы с очень большими числами без потери точности. Модуль даёт возможность манипулирования с 10000 и более значащими цифрами в числах. В модуле реализованы сложение, вычитание, умножение, деление, возведение в целую степень и факториал. Все функции в качестве аргументов принимают длинные строки и результат выдают тоже в виде строки.


Просьба связаться со мной, если кто хочет доработать модуль и расширить функциональность.


unit UMathServices;

interface

type
  TProgress = procedure(Done: real);

{ Собственно экспортные функции }
function ulFact(First: string): string;
function ulSum(First, Second: string): string;
function ulSub(First, Second: string): string;
function ulMPL(First, Second: string): string;
function ulPower(First, Second: string): string;
{ Precision - не истинная точность а количество знаков учитываемых после запятой
  сверх тех которые значимы. Все знаки уже существующие в делимом и делителе
  в любом случае учитываются }
function UlDiv(First, Second: string; Precision: Integer): string;

{ Call back function for long operations }
var
  OnProgress: TProgress;

implementation

uses SysUtils;

type
  TMathArray = array of Integer;

type
  TNumber = record
    int, frac: TMathArray;
    sign: Boolean;
  end;

var
  n1, n2: TNumber;


procedure Str2Number(s: string; var n: TNumber);
var
  i, j, l: Integer;
begin
  if s = '' then
  begin
    SetLength(n.int, 0);
    SetLength(n.frac, 0);
    exit;
  end;
  l := Length(s);
  if s[1] = '-' then
  begin
    s := Copy(s, 2, l);
    l := l - 1;
    n.sign := False;
  end
  else
    n.sign := True;
  j := pos('.', s);
  if j > 0 then
  begin
    SetLength(n.int, j - 1);
    for i := 1 to j - 1 do n.int[i - 1] := StrToInt(s[j - i]);
    SetLength(n.frac, l - j);
    for i := 1 to l - j do n.frac[i - 1] := StrToInt(s[l - i + 1]);
  end
  else
  begin
    SetLength(n.int, l);
    for i := 1 to l do n.int[i - 1] := StrToInt(s[l - i + 1]);
    SetLength(n.frac, 0);
  end;
end;

function Num2Array(var n: TNumber; var a: TMathArray): Integer;
var
  i: Integer;
begin
  Result := Length(n.frac);
  SetLength(a, Length(n.int) + Result);
  for i := 0 to Length(a) - 1 do
    if i < Result then
      a[i] := n.frac[i]
    else
      a[i] := n.int[i - Result];
end;

procedure MultiplyArray(var a1, a2, a: TMathArray);
var
  i, j: Integer;
  b: Boolean;
begin
  { checking for zero, 1 }
  for i := Length(a2) - 1 downto 0 do
  begin
    for j := Length(a1) - 1 downto 0 do
    begin
      a[j + i] := a[j + i] + (a2[i] * a1[j]);
    end;
  end;
  repeat
    b := True;
    for i := 0 to Length(a) - 1 do
      if a[i] > 9 then
      begin
        b := False;
        try
          a[i + 1] := a[i + 1] + 1;
        except
          SetLength(a, Length(a) + 1);
          a[i + 1] := a[i + 1] + 1;
        end;
        a[i] := a[i] - 10;
      end;
  until b;
end;

procedure Array2Num(var n: TNumber; var a: TMathArray; frac: Integer; sign: Boolean);
var
  i: Integer;
begin
  SetLength(n.frac, frac);
  SetLength(n.int, Length(a) - frac);
  for i := 0 to Length(a) - 1 do
  begin
    if i < frac then n.frac[i] := a[i]
    else
      n.int[i - frac] := a[i];
  end;
  n.sign := sign;
end;

function Number2Str(var n: TNumber): string;
var
  i: Integer;
  s: string;
begin
  Result := '';
  for i := 0 to high(n.int) do Result := IntToStr(n.int[i]) + Result;
  if Length(n.frac) <> 0 then
  begin
    for i := 0 to high(n.frac) do s := IntToStr(n.frac[i]) + s;
    Result := Result + '.' + s;
  end;
  while (Length(Result) > 1) and (Result[1] = '0') do Delete(Result, 1, 1);
  if pos('.', Result) > 0 then
    while (Length(Result) > 1) and (Result[Length(Result)] = '0') do
      Delete(Result, Length(Result), 1);
  if not n.sign then Result := '-' + Result;
  SetLength(n.int, 0);
  SetLength(n.frac, 0);
end;

procedure DisposeNumber(var n: TNumber);
begin
  SetLength(n.int, 0);
  SetLength(n.frac, 0);
end;


function ulFact(First: string): string;
var
  n1, n2: TNumber;
  i: Integer;
  a, a1, a2: TMathArray;
  max: Integer;
begin
  Str2Number('1', n1);
  Str2Number('1', n2);
  Num2Array(n1, a1);
  Num2Array(n2, a2);
  max := StrToInt(First);
  for i := 1 to StrToInt(First) do
  begin
    if Assigned(OnProgress) then OnProgress((i / max) * 100);
    SetLength(a, Length(a1) + Length(a2) + 1);
    MultiplyArray(a1, a2, a);
    SetLength(a1, 0);
    SetLength(a2, 0);
    a1 := a;
    Str2Number(IntToStr(i), n2);
    Num2Array(n2, a2);
  end;
  Array2Num(n1, a1, 0, True);
  Result := Number2Str(n1);
  DisposeNumber(n1);
end;

function ulPower(First, Second: string): string;
var
  i, j, c: Integer;
  a, a1, a2: TMathArray;
var
  n1: TNumber;
  max: Integer;
begin
  j := StrToInt(Second);
  if j = 0 then
  begin
    Result := '1';
    exit;
  end
  else
  if j = 1 then
  begin
    Result := First;
    exit;
  end;

  max := j - 1;
  Str2Number(First, n1);
  c := Num2Array(n1, a1);
  SetLength(a, 0);
  SetLength(a2, 0);
  a2 := a1;
  for i := 1 to j - 1 do
  begin
    if Assigned(OnProgress) then OnProgress((i / max) * 100);
    SetLength(a, 0);
    SetLength(a, Length(a1) + Length(a2) + 1);
    MultiplyArray(a1, a2, a);
    SetLength(a2, 0);
    a2 := a;
  end;
  SetLength(a1, 0);
  SetLength(a2, 0);
  c := c * j;
  if n1.sign then
    Array2Num(n1, a, c, True)
  else
  if Odd(j) then Array2Num(n1, a, c, False)
  else
    Array2Num(n1, a, c, True);
  SetLength(a, 0);
  Result := Number2Str(n1);
  DisposeNumber(n1);
end;

procedure MultiplyNumbers(var n1, n2: TNumber);
var
  i: Integer;
  a, a1, a2: TMathArray;
begin
  i := Num2Array(n1, a1) + Num2Array(n2, a2);
  SetLength(a, Length(a1) + Length(a2) + 1);
  MultiplyArray(a1, a2, a);
  SetLength(a1, 0);
  SetLength(a2, 0);
  Array2Num(n1, a, i, n1.sign = n2.sign);
  DisposeNumber(n2);
  SetLength(a, 0);
end;

function ulMPL(First, Second: string): string;
var
  n1, n2: TNumber;
begin
  Str2Number(First, n1);
  Str2Number(Second, n2);
  MultiplyNumbers(n1, n2);
  Result := Number2Str(n1);
  DisposeNumber(n1);
end;

procedure AlignNumbers(var n1, n2: TNumber);
var
  i1, i2, i: Integer;
begin
  i1 := Length(n1.int);
  i2 := Length(n2.int);
  if i1 > i2 then SetLength(n2.int, i1);
  if i2 > i1 then SetLength(n1.int, i2);

  i1 := Length(n1.frac);
  i2 := Length(n2.frac);

  if i1 > i2 then
  begin
    SetLength(n2.frac, i1);
    for i := i1 - 1 downto 0 do
    begin
      if i - (i1 - i2) > 0 then
        n2.frac[i] := n2.frac[i - (i1 - i2)]
      else
        n2.frac[i] := 0;
    end;
  end;
  if i2 > i1 then
  begin
    SetLength(n1.frac, i2);
    for i := i2 - 1 downto 0 do
    begin
      if i - (i2 - i1) > 0 then
        n1.frac[i] := n1.frac[i - (i2 - i1)]
      else
        n1.frac[i] := 0;
    end;
  end;
end;

function SubInteger(a1, a2: TMathArray): Integer;
var
  i: Integer;
  b: Boolean;
begin
  Result := 0;
  if Length(a1) = 0 then exit;
  for i := 0 to Length(a1) - 1 do
    a1[i] := a1[i] - a2[i];
  repeat
    b := True;
    for i := 0 to Length(a1) - 1 do
      if a1[i] < 0 then
      begin
        b := False;
        if i = Length(a1) - 1 then
        begin
          Result := -1;
          a1[i] := a1[i] + 10;
          b := True;
        end
        else
        begin
          a1[i + 1] := a1[i + 1] - 1;
          a1[i] := a1[i] + 10;
        end;
      end;
  until b;
end;

procedure AssignNumber(out n1: TNumber; const n2: TNumber);
var
  i: Integer;
begin
  SetLength(n1.int, Length(n2.int));
  for i := 0 to Length(n2.int) - 1 do
    n1.int[i] := n2.int[i];
  SetLength(n1.frac, Length(n2.frac));
  for i := 0 to Length(n2.frac) - 1 do
    n1.frac[i] := n2.frac[i];
  n1.sign := n2.sign;
end;

procedure SubNumber(var n1, n2: TNumber);
var
  i: Integer;
  n: TNumber;
begin
  AlignNumbers(n1, n2);
  i := subInteger(n1.frac, n2.frac);
  n1.int[0] := n1.int[0] + i;
  DisposeNumber(n);
  AssignNumber(n, n1);
  i := subInteger(n1.int, n2.int);
  if i < 0 then
  begin
    subInteger(n2.int, n.int);
    AssignNumber(n1, n2);
  end
  else
  begin
    DisposeNumber(n2);
  end;
end;

function SumInteger(a1, a2: TMathArray): Integer;
var
  i: Integer;
  b: Boolean;
begin
  Result := 0;
  if Length(a1) = 0 then exit;
  for i := 0 to Length(a1) - 1 do a1[i] := a1[i] + a2[i];
  repeat
    b := True;
    for i := 0 to Length(a1) - 1 do
      if a1[i] > 9 then
      begin
        b := False;
        if i = Length(a1) - 1 then
        begin
          Result := 1;
          a1[i] := a1[i] - 10;
          b := True;
        end
        else
        begin
          a1[i + 1] := a1[i + 1] + 1;
          a1[i] := a1[i] - 10;
        end;
      end;
  until b;
end;

procedure SumNumber(var n1, n2: TNumber);
var
  i: Integer;
begin
  AlignNumbers(n1, n2);
  i := sumInteger(n1.frac, n2.frac);
  n1.int[0] := n1.int[0] + i;
  i := sumInteger(n1.int, n2.int);
  if i > 0 then
  begin
    SetLength(n1.int, Length(n1.int) + 1);
    n1.int[Length(n1.int) - 1] := i;
  end;
  DisposeNumber(n2);
end;

procedure SumNumbers(var n1, n2: TNumber);
begin
  if n1.sign and n2.sign then
  begin
    SumNumber(n1, n2);
    n1.sign := True;
  end
  else
  if (not n1.sign) and (not n2.sign) then
  begin
    SumNumber(n1, n2);
    n1.sign := False;
  end
  else
  if (not n1.sign) and n2.sign then
  begin
    SubNumber(n2, n1);
    AssignNumber(n1, n2);
  end
  else
  begin
    SubNumber(n1, n2);
  end;
end;

function ulSum(First, Second: string): string;
begin
  Str2Number(First, n1);
  Str2Number(Second, n2);
  SumNumbers(n1, n2);
  Result := Number2Str(n1);
  DisposeNumber(n1);
end;

function ulSub(First, Second: string): string;
begin
  Str2Number(First, n1);
  Str2Number(Second, n2);
  n2.sign := not n2.sign;
  SumNumbers(n1, n2);
  Result := Number2Str(n1);
  DisposeNumber(n1);
end;

function DupChr(const X: char; Count: Integer): AnsiString;
begin
  if Count > 0 then
  begin
    SetLength(Result, Count);
    if Length(Result) = Count then
      FillChar(Result[1], Count, X);
  end;
end;

function StrCmp(X, Y: AnsiString): Integer;
var
  I, J: Integer;
begin
  I := Length(X);
  J := Length(Y);
  if I = 0 then
  begin
    Result := J;
    Exit;
  end;
  if J = 0 then
  begin
    Result := I;
    Exit;
  end;
  if X[1] = #45 then
  begin
    if Y[1] = #45 then
    begin
      X := Copy(X, 2, I);
      Y := Copy(Y, 2, J);
    end
    else
    begin
      Result := -1;
      Exit;
    end;
  end
  else if Y[1] = #45 then
  begin
    Result := 1;
    Exit;
  end;
  Result := I - J;
  if Result = 0 then Result := CompareStr(X, Y);
end;

function StrDiv(X, Y: AnsiString): AnsiString;
var
  I, J: Integer;
  S, V: Boolean;
  T1, T2: AnsiString;
  R: string;
  max: Integer;
begin
  Result := #48;
  R := #48;
  I := Length(X);
  J := Length(Y);
  S := False;
  V := False;
  if I = 0 then Exit;
  if (J = 0) or (Y[1] = #48) then
  begin
    Result := '';
    R := '';
    Exit;
  end;
  if X[1] = #45 then
  begin
    Dec(I);
    V := True;
    X := Copy(X, 2, I);
    if Y[1] = #45 then
    begin
      Dec(J);
      Y := Copy(Y, 2, J);
    end
    else
      S := True;
  end
  else if Y[1] = #45 then
  begin
    Dec(J);
    Y := Copy(Y, 2, J);
    S := True;
  end;
  Dec(I, J);
  if I < 0 then
  begin
    R := X;
    Exit;
  end;
  T2 := DupChr(#48, I);
  T1 := Y + T2;
  T2 := #49 + T2;
  max := Length(T1);
  while Length(T1) >= J do
  begin
    while StrCmp(X, T1) >= 0 do
    begin
      X := UlSub(X, T1);
      Result := UlSum(Result, T2);
    end;
    SetLength(T1, Length(T1) - 1);
    SetLength(T2, Length(T2) - 1);
    if Assigned(OnProgress) then OnProgress(100 - (Length(T1) / max) * 100);
  end;
  R := X;
  if S then if Result[1] <> #48 then Result := #45 + Result;
  if V then if R[1] <> #48 then R := #45 + R;
end;

function Mul10(First: string; Second: Integer): string;
var
  s: string;
  i, j: Integer;
begin
  if pos('.', First) = 0 then
  begin
    s := '';
    for i := 0 to Second - 1 do s := s + '0';
    Result := First + s;
  end
  else
  begin
    s := '';
    j := Length(First) - pos('.', First);
    if (second - j) > 0 then
      for i := 0 to Second - j - 1 do s := s + '0';
    First := First + s;
    j := pos('.', First);
    First := StringReplace(First, '.', '', []);
    insert('.', First, j + second);
    while (Length(First) > 0) and (First[Length(First)] = '0') do
      Delete(First, Length(First), 1);
    while (Length(First) > 0) and (First[Length(First)] = '.') do
      Delete(First, Length(First), 1);
    Result := First;
  end;
end;

function Div10(First: string; Second: Integer): string;
var
  s: string;
  i: Integer;
begin
  s := '';
  for i := 0 to Second do s := s + '0';
  s := s + First;
  Insert('.', s, Length(s) - Second + 1);
  while (Length(s) > 0) and (s[1] = '0') do Delete(s, 1, 1);
  if pos('.', s) > 0 then
    while (Length(s) > 0) and (s[Length(s)] = '0') do Delete(s, Length(s), 1);
  if (Length(s) > 0) and (s[Length(s)] = '.') then Delete(s, Length(s), 1);
  Result := s;
end;

function UlDiv(First, Second: string; Precision: Integer): string;
begin
  First := Mul10(First, Precision);
  Result := Div10(StrDiv(First, Second), Precision);
end;

end.


Author: Vit
Source: Взято с Vingrad.ru http://forum.vingrad.ru
ID: 04066