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

Это модуль для работы с очень большими числами без потери точности. Модуль даёт возможность манипулирования с 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
Category:Алгоритмы
Category:Математика