Работа с очень большими числами
Материал из 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