无限进制的处理

(*//
标题:无限进制处理
说明:使用于数学领域进制之间相互转换和计算
设计:Zswang
日期:2005-01-15
支持:wjhu111@21cn.com
//*)
 
uses Math;
 
const
  cScaleChar: array[0..35] of Char = '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ';
 
function StringToCharSet( //字符串集合
  mString: string //源字符串
): TSysCharSet; //返回字符串中包含的集合
var
  I: Integer;
begin
  Result := [];
  for I := 1 to Length(mString) do Include(Result, mString[I]);
end; { StringToCharSet }
 
function StrLeft( //取左边的字符串
  mStr: string; //原字符串
  mDelimiter: string; //分隔符
  mIgnoreCase: Boolean = False //是否忽略大小写
): string; //返回第一个分隔符左边的字符串
begin
  if mIgnoreCase then
    Result := Copy(mStr, 1, Pos(UpperCase(mDelimiter), UpperCase(mStr)) - 1)
  else Result := Copy(mStr, 1, Pos(mDelimiter, mStr) - 1);
end; { StrLeft }
 
function StrRight( //取右边的字符串
  mStr: string; //原字符串
  mDelimiter: string; //分隔符
  mIgnoreCase: Boolean = False //是否忽略大小写
): string; //返回第一个分隔符右边的字符串
begin
  if mIgnoreCase then
  begin
    if Pos(UpperCase(mDelimiter), UpperCase(mStr)) > 0 then
      Result := Copy(mStr, Pos(UpperCase(mDelimiter), UpperCase(mStr)) +
        Length(mDelimiter), MaxInt)
    else Result := '';
  end else
  begin
    if Pos(mDelimiter, mStr) > 0 then
      Result := Copy(mStr, Pos(mDelimiter, mStr) + Length(mDelimiter), MaxInt)
    else Result := '';
  end;
end; { StrRight }
 
function IntegerFullZero( //对齐前补0
  mInteger: string; //整数字符串
  mLength: Integer //总长度
): string; //返回补0后的整数字符串
begin
  Result := StringOfChar('0', mLength - Length(mInteger)) + mInteger;
end; { IntegerFullZero }
 
function IntegerCompare( //比较两个整数
  mIntegerA: string; //整数1
  mIntegerB: string //整数2
): Integer; //返回比较的值 +1、0、-1
var
  I: Integer;
begin
  I := Max(Length(mIntegerA), Length(mIntegerB)); //整数部分最大
  mIntegerA := IntegerFullZero(mIntegerA, I);
  mIntegerB := IntegerFullZero(mIntegerB, I);
  Result := CompareText(mIntegerA, mIntegerB);
end; { IntegerCompare }
 
function IntegerFormat( //清除无效的0
  mInteger: string //整数字符串
): string; //返回处理后的整数字符串
begin
  Result := UpperCase(mInteger);
  if Result = '' then Result := '0';
  while (Pos('0', Result) = 1) and (Result <> '0') do Delete(Result, 1, 1); //排除整数前无效的0
end; { IntegerFormat }
 
function IntegerAdd( //无限整数加法
  mIntegerA: string; //整数1
  mIntegerB: string; //整数2
  mScale: Byte = 10 //进制
): string; //返回两个整数的和
var
  I: Integer;
  T: Integer;
begin
  Result := '';
  if mScale < 2 then Exit;
  mIntegerA := IntegerFormat(mIntegerA);
  mIntegerB := IntegerFormat(mIntegerB);
  if StringToCharSet(mIntegerA + mIntegerB) -
    [cScaleChar[0]..cScaleChar[mScale - 1]] <> [] then Exit;
  I := Max(Length(mIntegerA), Length(mIntegerB)); //整数部分最大
  mIntegerA := IntegerFullZero(mIntegerA, I); //对齐前补0
  mIntegerB := IntegerFullZero(mIntegerB, I); //对齐前补0
  T := 0; //进位数初始
  for I := I downto 1 do //从后向前扫描
  begin
    T := (Pos(Copy(mIntegerA, I, 1), cScaleChar) - 1) + T; //累加当前数位
    T := (Pos(Copy(mIntegerB, I, 1), cScaleChar) - 1) + T; //累加当前数位
    Result := cScaleChar[T mod mScale] + Result; //计算当前数位上的数字
    T := T div mScale; //计算进位数
  end;
  if T <> 0 then Result := cScaleChar[T mod mScale] + Result; //处理进位数
  while (Pos('0', Result) = 1) and (Result <> '0') do Delete(Result, 1, 1); //排除整数前无效的0
end; { IntegerAdd }
 
function IntegerSub( //无限整数减法
  mIntegerA: string; //整数1
  mIntegerB: string; //整数2
  mScale: Byte = 10 //进制
): string; //返回两个整数的积
var
  I: Integer;
  T: Integer;
begin
  Result := '';
  if mScale < 2 then Exit;
  mIntegerA := IntegerFormat(mIntegerA);
  mIntegerB := IntegerFormat(mIntegerB);
  if StringToCharSet(mIntegerA + mIntegerB) -
    [cScaleChar[0]..cScaleChar[mScale - 1]] <> [] then Exit;
  I := Max(Length(mIntegerA), Length(mIntegerB)); //整数部分最大
  mIntegerA := IntegerFullZero(mIntegerA, I); //对齐前补0
  mIntegerB := IntegerFullZero(mIntegerB, I); //对齐前补0
  if mIntegerA < mIntegerB then Exit;
  T := 0; //进位数初始
  for I := I downto 1 do //从后向前扫描
  begin
    T := (Pos(Copy(mIntegerA, I, 1), cScaleChar) - 1) - T; //累加当前数位
    T := T - (Pos(Copy(mIntegerB, I, 1), cScaleChar) - 1); //累加当前数位
    Result := cScaleChar[(T + mScale) mod mScale] + Result; //计算当前数位上的数字
    if T >= 0 then T := 0 else T := 1;
  end;
  while (Pos('0', Result) = 1) and (Result <> '0') do Delete(Result, 1, 1); //排除整数前无效的0
end; { IntegerSub }
 
function IntegerMult( //无限整数乘法
  mIntegerA: string; //整数1
  mIntegerB: string; //整数2
  mScale: Byte = 10 //进制
): string; //返回两个整数的积
  function fMult( //无限位数乘法子函数
    mInteger: string; //整数
    mByte: Byte //位数
  ): string; //返回位数和整数的积
  var
    I: Integer;
    T: Integer;
  begin
    Result := '';
    T := 0;
    for I := Length(mInteger) downto 1 do //从后向前扫描
    begin
      T := (Pos(Copy(mInteger, I, 1), cScaleChar) - 1) * mByte + T; //累加当前数位
      Result := cScaleChar[T mod mScale] + Result; //计算当前数位上的数字
      T := T div mScale; //计算进位数
    end;
    if T <> 0 then Result := cScaleChar[T mod mScale] + Result; //处理进位数
  end; { fMult }
var
  I: Integer;
  T: string;
begin
  Result := '';
  if mScale < 2 then Exit;
  mIntegerA := IntegerFormat(mIntegerA);
  mIntegerB := IntegerFormat(mIntegerB);
  if StringToCharSet(mIntegerA + mIntegerB) -
    [cScaleChar[0]..cScaleChar[mScale - 1]] <> [] then Exit;
  T := '';
  for I := Length(mIntegerB) downto 1 do
  begin
    Result := IntegerAdd(Result,
      fMult(mIntegerA, (Pos(Copy(mIntegerB, I, 1), cScaleChar) - 1)) + T, mScale);
    T := T + '0';
  end;
  Result := IntegerFormat(Result);
end; { InfiniteMult }
 
function IntegerDivMod( //无限整数除法
  mIntegerA: string; //整数1
  mIntegerB: string; //整数2
  var nDiv: string; //返回除数
  var nMod: string; //返回余数
  mScale: Byte = 10 //进制
): Boolean; //返回两个整数的积
var
  T: string;
  K: string;
begin
  Result := False;
  if mScale < 2 then Exit;
  mIntegerA := IntegerFormat(mIntegerA);
  mIntegerB := IntegerFormat(mIntegerB);
  if StringToCharSet(mIntegerA + mIntegerB) -
    [cScaleChar[0]..cScaleChar[mScale - 1]] <> [] then Exit;
  if mIntegerB = '0' then Exit;
  Result := True;
  nDiv := '0';
  while IntegerCompare(mIntegerA, mIntegerB) >= 0 do
  begin
    T := mIntegerB;
    K := '1';
    while IntegerCompare(mIntegerA, T + '0') >= 0 do
    begin
      T := T + '0';
      K := K + '0';
    end;
    mIntegerA := IntegerSub(mIntegerA, T, mScale);
    nDiv := IntegerAdd(nDiv, K, mScale);
  end;
  nMod := mIntegerA;
end; { IntegerDivMod }
 
function IntegerFactorial( //无限整数的阶乘
  mInteger: Integer; //整数
  mScale: Byte = 10 //进制
): string; //返回整数的阶乘
var
  I: Integer;
  T: string;
begin
  Result := '';
  if mScale < 2 then Exit;
  Result := '1';
  T := '0';
  for I := 1 to mInteger do
  begin
    T := IntegerAdd(T, '1', mScale);
    Result := IntegerMult(Result, T, mScale);
  end;
end; { InfiniteFactorial }
 
function IntegerPower( //无限整数的次方
  mBase: string; //指数
  mExponent: Integer; //幂数
  mScale: Byte = 10 //进制
): string; //返回Base的Exponent次方
var
  I: Integer;
begin
  Result := '';
  if mScale < 2 then Exit;
  mBase := IntegerFormat(mBase);
  if StringToCharSet(mBase) -
    [cScaleChar[0]..cScaleChar[mScale - 1]] <> [] then Exit;
  Result := '1';
  for I := 1 to mExponent do
    Result := IntegerMult(Result, mBase, mScale);
end; { IntegerPower }
 
function IntegerDigit( //进制间的转换
  mIntegerFrom: string; //来源整数
  mScaleFrom: Byte; //来源进制
  mScaleTo: Byte //目标进制
): string; //返回处理后的整数字符串
  function fIntegerDigit( //进制间的转换
    mIntegerFrom: Char //来源整数
  ): string; //返回处理后的整数字符串
  var
    T: string;
  begin
    Result := '0';
    T := '0';
    while IntegerCompare(T, mIntegerFrom) < 0 do
    begin
      Result := IntegerAdd(Result, '1', mScaleTo);
      T := IntegerAdd(T, '1', mScaleFrom);
    end;
  end;
var
  I, L: Integer;
  vBase: string;
  T: string;
begin
  Result := '';
  if (mScaleFrom < 2) or (mScaleTo < 2) then Exit;
  mIntegerFrom := IntegerFormat(mIntegerFrom);
  if StringToCharSet(mIntegerFrom) -
    [cScaleChar[0]..cScaleChar[mScaleFrom - 1]] <> [] then Exit;
  if mScaleFrom = mScaleTo then
  begin
    Result := mIntegerFrom;
    Exit;
  end;
  Result := '0';
  if mIntegerFrom = '0' then Exit;
  vBase := '1';
  T := '1';
  while IntegerCompare(T, cScaleChar[mScaleFrom - 1]) <= 0 do
  begin
    vBase := IntegerAdd(vBase, '1', mScaleTo);
    T := IntegerAdd(T, '1', mScaleFrom);
  end;
  L := Length(mIntegerFrom);
  for I := 1 to L do
  begin
    Result := IntegerAdd(
      Result,
      IntegerMult(
        fIntegerDigit(
          mIntegerFrom[L - I + 1]
        ),
        IntegerPower(
          vBase,
          I - 1,
          mScaleTo
        ),
        mScaleTo)
      mScaleTo
    );
  end;
end; { IntegerDigit }
 
function Numberexpression_r(mNumber: string): string;
var
  vExponent: Integer;
  vBase: string;
  L: Integer;
begin
  Result := '';
  vBase := StrLeft(mNumber, 'e', True);
  vExponent := StrToIntDef(StrRight(mNumber, 'e', True), 0);
  L := Length(StrRight(vBase, '.'));
  vBase := StringReplace(vBase, '.', '', [rfReplaceAll]);
  Result := vBase + StringOfChar('0', vExponent - L);
end; { NumberExpression }
 
//Example
procedure TForm1.Edit1Change(Sender: TObject);
var
  vDiv, vMod: string;
begin
  Edit3.Text := IntegerAdd(Edit1.Text, Edit2.Text, 10);
  Edit4.Text := IntegerMult(Edit1.Text, Edit2.Text, 10);
  Edit5.Text := IntegerSub(Edit1.Text, Edit2.Text, 10);
  IntegerDivMod(Edit1.Text, Edit2.Text, vDiv, vMod, 10);
  Edit6.Text := vDiv;
  Edit7.Text := vMod;
  Edit8.Text := IntegerDigit(Edit1.Text, 36, 23);
  Edit9.Text := IntegerDigit(Edit8.Text, 23, 36);
  CheckBox1.Checked :=
    IntegerCompare(IntegerAdd(IntegerMult(vDiv, Edit2.Text), vMod), Edit1.Text) = 0;
end;
 
procedure TForm1.Button1Click(Sender: TObject);
begin
  Memo1.Text := IntegerFactorial(1000, 20); // 计算1000的阶乘用20进制表示
end;