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

Previous  Top  Next

    
 

 

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

 

Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org)

 

 

 

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

 

Code:

unit UMathServices;

{©Drkb v.3(2007): www.drkb.ru,

®Vit (Vitaly Nevzorov) - nevzorov@yahoo.com}

 

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;

function UlDiv(First, Second:String; Precision:integer):String;   {Precision - не истинная точность а количество знаков учитываемых после запятой сверх тех которые значимы. Все знаки уже существующие в делимом и делителе в любом случае учитываются}

 

{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.

 

 

©Drkb::04066

Взято с Vingrad.ru http://forum.vingrad.ru