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

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

Автор: Vit

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

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

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