/newStructBase/units/phprpc/BigInt.pas
https://github.com/qriver/Delphi2010 · Pascal · 760 lines · 654 code · 60 blank · 46 comment · 88 complexity · d6d8b2a469ea5e40a47f1e9ddb782e30 MD5 · raw file
- {
- /**********************************************************\
- | |
- | The implementation of PHPRPC Protocol 3.0 |
- | |
- | BigInt.pas |
- | |
- | Release 3.0.2 |
- | Copyright by Team-PHPRPC |
- | |
- | WebSite: http://www.phprpc.org/ |
- | http://www.phprpc.net/ |
- | http://www.phprpc.com/ |
- | http://sourceforge.net/projects/php-rpc/ |
- | |
- | Authors: Ma Bingyao <andot@ujn.edu.cn> |
- | |
- | This file may be distributed and/or modified under the |
- | terms of the GNU General Public License (GPL) version |
- | 2.0 as published by the Free Software Foundation and |
- | appearing in the included file LICENSE. |
- | |
- \**********************************************************/
- /* BigInteger Variant Type
- *
- * Copyright: Ma Bingyao <andot@ujn.edu.cn>
- * Version: 3.0.2
- * LastModified: Oct 30, 2009
- * This library is free. You can redistribute it and/or modify it under GPL.
- */
- }
- unit BigInt;
- {$I PHPRPC.inc}
- interface
- uses Types;
- type
- TRadix = 2..36;
- { BigInteger variant creation utils }
- function VarBi: TVarType;
- function Zero: Variant;
- function One: Variant;
- procedure BigInteger(var V: Variant; const I: Int64); overload;
- function BigInteger(const I: Int64): Variant; overload;
- procedure BigInteger(var V: Variant; const S: string); overload;
- function BigInteger(const S: string): Variant; overload;
- function PowMod(var X, Y, Z: Variant): Variant; overload;
- function Rand(BitNumber: Integer; SetHighBit: Boolean): Variant;
- function BigIntToBinStr(const V: Variant): AnsiString;
- function BinStrToBigInt(const S: AnsiString): Variant;
- function BigIntToString(const V: Variant; Radix: TRadix = 10): AnsiString;
- implementation
- uses Variants, SysUtils, StrUtils, Math;
- type
- PLongWordArray = ^TLongWordArray;
- TLongWordArray = array [0..$7FFFFFF] of LongWord;
- TBiVarData = packed record
- VType: TVarType;
- Reserved1, Reserved2, Reserved3: Word;
- VData: PLongWordArray;
- VLength: LongInt;
- end;
- TBiVariantType = class(TCustomVariantType)
- public
- procedure Clear(var V: TVarData); override;
- function IsClear(const V: TVarData): Boolean; override;
- procedure Copy(var Dest: TVarData; const Source: TVarData;
- const Indirect: Boolean); override;
- procedure Cast(var Dest: TVarData; const Source: TVarData); override;
- procedure CastTo(var Dest: TVarData; const Source: TVarData;
- const AVarType: TVarType); override;
- procedure BinaryOp(var Left: TVarData; const Right: TVarData;
- const Op: TVarOp); override;
- procedure Compare(const Left, Right: TVarData;
- var Relationship: TVarCompareResult); override;
- end;
- var
- BiVariantType: TBiVariantType = nil;
- const
- CharacterSet: AnsiString = '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ';
- function ZeroFill(const S: string; N: Integer): string;
- var
- L: Integer;
- begin
- L := N - Length(S);
- if L > 0 then Result := StringOfChar('0', L) + S else Result := S;
- end;
- procedure SetLength(var V: TBiVarData; Count: Integer);
- begin
- ReallocMem(V.VData, SizeOf(LongWord) * Count);
- if Count > V.VLength then
- FillChar(V.VData[V.VLength], SizeOf(LongWord) * (Count - V.VLength), 0);
- V.VLength := Count;
- end;
- procedure FixLength(var V: TBiVarData);
- begin
- while (V.VLength > 1) and (V.VData[V.VLength - 1] = 0) do Dec(V.VLength);
- end;
- procedure Add(var A: TBiVarData; B: Word); overload;
- var
- I: Integer;
- begin
- FixLength(A);
- Inc(A.VData[0], B);
- if A.VData[0] > $FFFF then begin
- I := 0;
- if (A.VLength = 1) or (A.VData[A.VLength - 1] = $FFFF) then
- SetLength(A, A.VLength + 1);
- repeat
- A.VData[I] := A.VData[I] and $FFFF;
- Inc(I);
- Inc(A.VData[I]);
- until A.VData[I] <= $FFFF;
- FixLength(A);
- end;
- end;
- procedure Add(var A, B: TBiVarData); overload;
- var
- AL, BL, I, L, N: Integer;
- begin
- FixLength(A);
- FixLength(B);
- AL := A.VLength;
- BL := B.VLength;
- L := Max(AL, BL) + 1;
- SetLength(A, L);
- for I := 0 to Min(AL, BL) - 1 do Inc(A.VData[I], B.VData[I]);
- if AL < BL then
- for I := AL to BL - 1 do A.VData[I] := B.VData[I];
- I := 0;
- N := 0;
- while (I < L - 1) do begin
- if (A.VData[I] > $FFFF) then begin
- A.VData[I] := A.VData[I] and $FFFF;
- N := I + 1;
- Inc(A.VData[N]);
- end;
- Inc(I);
- end;
- if N = L - 1 then A.VLength := L else A.VLength := L - 1;
- end;
- procedure Mul(var A: TBiVarData; B: Word); overload;
- var
- Temp: LongWord;
- I: Integer;
- begin
- FixLength(A);
- if B = 0 then begin
- SetLength(A, 1);
- A.VData[0] := 0;
- Exit;
- end;
- if B = 1 then Exit;
- SetLength(A, A.VLength + 1);
- Temp := A.VData[0];
- A.VData[0] := 0;
- for I := 0 to A.VLength - 2 do begin
- Inc(A.VData[I], Temp * B);
- Temp := A.VData[I + 1];
- A.VData[I + 1] := A.VData[I] shr 16;
- A.VData[I] := A.VData[I] and $FFFF;
- end;
- FixLength(A);
- end;
- procedure Mul(var A, B: TBiVarData); overload;
- var
- R: PLongWordArray;
- L, I, J, K: Integer;
- begin
- FixLength(A);
- FixLength(B);
- if B.VLength = 1 then begin
- Mul(A, B.VData[0]);
- Exit;
- end;
- L := A.VLength + B.VLength;
- GetMem(R, SizeOf(LongWord) * L);
- FillChar(R^, SizeOf(LongWord) * L, 0);
- for I := 0 to A.VLength - 1 do for J := 0 to B.VLength - 1 do begin
- K := I + J;
- Inc(R[K], A.VData[I] * B.VData[J]);
- Inc(R[K + 1], R[K] shr 16);
- R[K] := R[K] and $FFFF;
- end;
- FreeMem(A.VData);
- A.VData := R;
- A.VLength := L;
- FixLength(A);
- end;
- function IntDivMod(var A: TBiVarData; B: Word): Word; overload;
- var
- R: LongWord;
- I: Integer;
- begin
- FixLength(A);
- if B = 0 then Error(reDivByZero);
- if B = 1 then begin
- Result := 0;
- Exit;
- end;
- R := 0;
- I := A.VLength;
- Dec(I);
- while I >= 0 do begin
- R := R shl 16;
- R := R or A.VData[I];
- A.VData[I] := R div B;
- R := R mod B;
- Dec(I);
- end;
- FixLength(A);
- Result := R;
- end;
- procedure LeftShift(var A: TBiVarData; B: Word);
- var
- W, X, C: Word;
- I, L: Integer;
- R: PLongWordArray;
- begin
- FixLength(A);
- // add one empty element for IntDivMod !
- if B = 0 then begin
- SetLength(A, A.VLength + 1);
- FixLength(A);
- Exit;
- end;
- W := B shr 4;
- B := B and 15;
- GetMem(R, SizeOf(LongWord) * (A.VLength + W + 1));
- FillChar(R^, SizeOf(LongWord) * (A.VLength + W + 1), 0);
- L := A.VLength;
- if B = 0 then
- Move(A.VData[0], R[W], SizeOf(LongWord) * L)
- else begin
- I := 0;
- C := 0;
- while I < L do begin
- X := A.VData[I];
- R[I + W] := Word(X shl B) or C;
- C := X shr (16 - B);
- Inc(I);
- end;
- R[I + W] := C;
- end;
- FreeMem(A.VData);
- A.VData := R;
- Inc(A.VLength, W + 1);
- FixLength(A);
- end;
- procedure RightShift(var A: TBiVarData; B: Word);
- var
- W, X, C: Word;
- L: Integer;
- R: PLongWordArray;
- begin
- FixLength(A);
- if B = 0 then Exit;
- W := B shr 4;
- B := B and 15;
- if W >= A.VLength then begin
- W := A.VLength - 1;
- B := 0;
- end;
- L := A.VLength - W;
- GetMem(R, SizeOf(LongWord) * L);
- FillChar(R^, SizeOf(LongWord) * L, 0);
- if B = 0 then
- Move(A.VData[W], R[0], SizeOf(LongWord) * L)
- else begin
- C := 0;
- Dec(L);
- while (L >= 0) do begin
- X := A.VData[L + W];
- R[L] := Word(X shr B) or C;
- C := X shl (16 - B);
- Dec(L);
- end;
- end;
- FreeMem(A.VData);
- A.VData := R;
- Dec(A.VLength, W);
- FixLength(A);
- end;
- function Compare(var A, B: TBiVarData): TVarCompareResult;
- var
- I: Integer;
- begin
- FixLength(A);
- FixLength(B);
- if A.VLength < B.VLength then Result := crLessThan
- else if A.VLength > B.VLength then Result := crGreaterThan
- else begin
- Result := crEqual;
- for I := A.VLength - 1 to 0 do begin
- if A.VData[I] < B.VData[I] then Result := crLessThan
- else if A.VData[I] > B.VData[I] then Result := crGreaterThan;
- end;
- end;
- end;
- procedure IntDivMod(var A, B: TBiVarData; out Q: TBiVarData); overload;
- var
- DP, NP, RP, RL, DL, I, P: Integer;
- T, S, Mask, Val: Word;
- Sum, B1, B2, D, QH, RH, MC: LongWord;
- begin
- if Compare(A, B) = crLessThan then begin
- Q.VType := A.VType;
- SetLength(Q, 1);
- Q.VData[0] := 0;
- Exit;
- end;
- if B.VLength = 1 then begin
- if Q.VType = VarBi then
- FreeMem(Q.VData)
- else
- Q.VType := VarBi;
- Q.VData := A.VData;
- Q.VLength := A.VLength;
- A.VData := nil;
- SetLength(A, 1);
- A.VData[0] := IntDivMod(Q, B.VData[0]);
- Exit;
- end;
- RL := A.VLength + 1;
- DL := B.VLength + 1;
- Mask := $8000;
- Val := B.VData[B.VLength - 1];
- S := 0;
- RP := A.VLength - B.VLength;
- while (Mask <> 0) and ((Val and Mask) = 0) do begin
- Inc(S);
- Mask := Mask shr 1;
- end;
- if Q.VType <> VarBi then begin
- Q.VType := VarBi;
- Q.VData := nil;
- Q.VLength := 0;
- end;
- SetLength(Q, A.VLength - B.VLength + 1);
- LeftShift(A, S);
- LeftShift(B, S);
- I := RL - B.VLength;
- P := RL - 1;
- B1 := B.VData[B.VLength - 1];
- B2 := B.VData[B.VLength - 2];
- while I > 0 do begin
- // maybe you will find P is out of range (P >= A.VLength),
- // but A has more elements than A.VLength (because of LeftShift) ,
- // so here is no mistake. it also appears in the following code.
- D := (A.VData[P] shl 16) + A.VData[P - 1];
- QH := D div B1;
- RH := D mod B1;
- repeat
- if (QH = $10000) or ((QH * B2) > ((RH shl 16) + A.VData[P - 2])) then begin
- Dec(QH);
- Inc(RH, B1);
- if (RH < $10000) then Continue;
- end;
- Break;
- until False;
- //
- // At this point, QH is either exact, or one too large
- // (more likely to be exact) so, we attempt to multiply the
- // divisor by QH, if we get a borrow, we just subtract
- // one from QH and add the divisor back.
- //
- DP := 0;
- NP := P - DL + 1;
- MC := 0;
- QH := QH and $FFFF;
- repeat
- Inc(MC, B.VData[DP] * QH);
- T := A.VData[NP];
- Dec(A.VData[NP], MC and $FFFF);
- A.VData[NP] := A.VData[NP] and $FFFF;
- MC := MC shr 16;
- if A.VData[NP] > T then Inc(MC);
- Inc(DP);
- Inc(NP);
- until DP >= DL;
- NP := P - DL + 1;
- DP := 0;
- // Overestimate
- if MC <> 0 then begin
- Dec(QH);
- Sum := 0;
- repeat
- Inc(Sum, A.VData[NP] + B.VData[DP]);
- A.VData[NP] := Sum and $FFFF;
- Sum := Sum shr 16;
- Inc(DP);
- Inc(NP);
- until DP >= DL;
- end;
- Q.VData[RP] := QH and $FFFF;
- Dec(RP);
- Dec(P);
- Dec(I);
- end;
- FixLength(Q);
- FixLength(A);
- if S <> 0 then RightShift(A, S);
- end;
- function BigIntToString(const V: Variant; Radix: TRadix): AnsiString;
- var
- T: Variant;
- R: Word;
- begin
- if V = Zero then
- Result := '0'
- else if V = One then
- Result := '1'
- else begin
- Result := '';
- T := V;
- while T <> Zero do begin
- R := IntDivMod(TBiVarData(T), Radix);
- Result := CharacterSet[R + 1] + Result;
- end;
- end;
- end;
- function VarBi: TVarType;
- begin
- Result := BiVariantType.VarType;
- end;
- function Zero: Variant;
- begin
- VarClear(Result);
- with TBiVarData(Result) do begin
- VType := VarBi;
- VData := nil;
- VLength := 0;
- SetLength(TBiVarData(Result), 1);
- end;
- end;
- function One: Variant;
- begin
- VarClear(Result);
- with TBiVarData(Result) do begin
- VType := VarBi;
- VData := nil;
- VLength := 0;
- SetLength(TBiVarData(Result), 1);
- VData[0] := 1;
- end;
- end;
- procedure BigInteger(var V: Variant; const I: Int64); overload;
- begin
- VarClear(V);
- with TBiVarData(V) do begin
- VType := VarBi;
- VData := nil;
- VLength := 0;
- if I > $FFFFFFFF then begin
- SetLength(TBiVarData(V), 4);
- VData[0] := I and $FFFF;
- VData[1] := (I shr 16) and $FFFF;
- VData[2] := (I shr 32) and $FFFF;
- VData[3] := (I shr 48) and $FFFF;
- if VData[3] = 0 then VLength := 3 else VLength := 4;
- end
- else if I > $FFFF then begin
- SetLength(TBiVarData(V), 2);
- VData[0] := I and $FFFF;
- VData[1] := (I shr 16) and $FFFF;
- VLength := 2;
- end
- else begin
- SetLength(TBiVarData(V), 1);
- VData[0] := I;
- VLength := 1;
- end;
- end;
- end;
- function BigInteger(const I: Int64): Variant; overload;
- begin
- BigInteger(Result, I);
- end;
- procedure BigInteger(var V: Variant; const S: string); overload;
- var
- I, SLen, ALen: Integer;
- Temp: string;
- begin
- BigInteger(V, 0);
- SLen := Length(S);
- Inc(SLen, 4 - (SLen mod 4));
- Temp := ZeroFill(S, SLen);
- ALen := SLen shr 2;
- for I := 0 to ALen - 1 do begin
- Mul(TBiVarData(V), 10000);
- Add(TBiVarData(V), StrToInt(MidStr(Temp, I shl 2 + 1, 4)));
- end;
- end;
- function BigInteger(const S: string): Variant; overload;
- begin
- BigInteger(Result, S);
- end;
- function PowMod(var X, Y, Z: Variant): Variant; overload;
- var
- A, B, C: Variant;
- N, I, J: Integer;
- Temp: LongWord;
- begin
- if VarType(X) = VarBi then A := X else VarCast(A, X, VarBi);
- if VarType(Y) = VarBi then B := Y else VarCast(B, Y, VarBi);
- if VarType(Z) = VarBi then C := Z else VarCast(C, Z, VarBi);
- with TBiVarData(B) do begin
- N := VLength;
- Result := One;
- for I := 0 to N - 2 do begin
- Temp := VData[I];
- for J := 0 to 15 do begin
- if (Temp and 1) <> 0 then Result := (Result * A) mod C;
- Temp := Temp shr 1;
- A := (A * A) mod C;
- end;
- end;
- Temp := VData[N - 1];
- while (Temp <> 0) do begin
- if (Temp and 1) <> 0 then Result := (Result * A) mod C;
- Temp := Temp shr 1;
- A := (A * A) mod C;
- end;
- end;
- end;
- function Rand(BitNumber: Integer; SetHighBit: Boolean): Variant;
- const
- LowBitMasks: array [0..15] of Word = ($0001, $0002, $0004, $0008,
- $0010, $0020, $0040, $0080,
- $0100, $0200, $0400, $0800,
- $1000, $2000, $4000, $8000);
- var
- I, R, Q: Integer;
- begin
- VarClear(Result);
- R := BitNumber mod 16;
- Q := BitNumber shr 4;
- with TBiVarData(Result) do begin
- VType := VarBi;
- VData := nil;
- VLength := 0;
- SetLength(TBiVarData(Result), Q + 1);
- for I := 0 to Q - 1 do VData[I] := Random($10000);
- if R <> 0 then begin
- VData[Q] := Random(LowBitMasks[R]);
- if SetHighBit then VData[Q] := VData[Q] or LowBitMasks[R - 1];
- end
- else begin
- VData[Q] := 0;
- if SetHighBit then VData[Q - 1] := VData[Q - 1] or $8000;
- end;
- end;
- FixLength(TBiVarData(Result));
- end;
- function BigIntToBinStr(const V: Variant): AnsiString;
- var
- N, I: Integer;
- begin
- with TBiVarData(V) do begin
- N := VLength;
- System.SetLength(Result, N * 2);
- for I := 0 to N - 1 do begin
- Result[(N - I) * 2] := AnsiChar(VData[I] and $FF);
- Result[(N - I) * 2 - 1] := AnsiChar((VData[I] shr 8) and $FF);
- end;
- end;
- end;
- function BinStrToBigInt(const S: AnsiString): Variant;
- var
- I, N: Integer;
- begin
- N := Length(S);
- if N = 0 then begin
- Result := Zero;
- Exit;
- end;
- VarClear(Result);
- with TBiVarData(Result) do begin
- VType := VarBi;
- VData := nil;
- VLength := 0;
- SetLength(TBiVarData(Result), (N + 1) shr 1);
- I := N;
- while I > 1 do begin
- VData[VLength - ((I + 1) shr 1)] := (Ord(S[I - 1]) shl 8) or Ord(S[I]);
- Dec(I, 2);
- end;
- if Odd(N) then VData[VLength - 1] := Ord(S[1]);
- end;
- end;
- { TBiVariantType }
- procedure TBiVariantType.BinaryOp(var Left: TVarData;
- const Right: TVarData; const Op: TVarOp);
- var
- TL, TR: TVarData;
- begin
- VarDataInit(TL);
- VarDataInit(TR);
- try
- VarDataCopy(TL, Left);
- VarDataCopy(TR, Right);
- case Op of
- opAdd:
- Add(TBiVarData(Left), TBiVarData(TR));
- opMultiply:
- Mul(TBiVarData(Left), TBiVarData(TR));
- opDivide, opIntDivide:
- IntDivMod(TBiVarData(TVarData(TL)), TBiVarData(TVarData(TR)), TBiVarData(Left));
- opModulus:
- IntDivMod(TBiVarData(Left), TBiVarData(TVarData(TR)), TBiVarData(TVarData(TL)));
- opShiftLeft:
- LeftShift(TBiVarData(Left), TBiVarData(TR).VData[0]);
- opShiftRight:
- RightShift(TBiVarData(Left), TBiVarData(TR).VData[0]);
- else
- RaiseInvalidOp;
- end;
- finally
- VarDataClear(TL);
- VarDataClear(TR);
- end;
- end;
- procedure TBiVariantType.Cast(var Dest: TVarData;
- const Source: TVarData);
- var
- LTemp: TVarData;
- begin
- if VarDataIsStr(Source) then begin
- BigInteger(Variant(Dest), VarToStr(Variant(Source)));
- end
- else begin
- VarDataInit(LTemp);
- try
- VarDataCastTo(LTemp, Source, varInt64);
- BigInteger(Variant(Dest), LTemp.VInt64);
- finally
- VarDataClear(LTemp);
- end;
- end;
- end;
- procedure TBiVariantType.CastTo(var Dest: TVarData;
- const Source: TVarData; const AVarType: TVarType);
- var
- S: AnsiString;
- begin
- if Source.VType = VarType then begin
- S := BigIntToString(Variant(Source));
- case AVarType of
- varOleStr:
- VarDataFromOleStr(Dest, WideString(StringToOleStr(S)));
- varString{$IFDEF DELPHI2009_UP}, varUString{$ENDIF}:
- VarDataFromStr(Dest, string(S));
- else
- RaiseCastError;
- end
- end
- else
- RaiseCastError;
- end;
- procedure TBiVariantType.Clear(var V: TVarData);
- begin
- V.VType := varEmpty;
- FreeMem(TBiVarData(V).VData);
- TBiVarData(V).VData := nil;
- TBiVarData(V).VLength := 0;
- end;
- procedure TBiVariantType.Compare(const Left, Right: TVarData;
- var Relationship: TVarCompareResult);
- var
- L, R: TBiVarData;
- begin
- if (Left.VType = VarType) and (Right.VType = VarType) then begin
- L := TBiVarData(Left);
- R := TBiVarData(Right);
- Relationship := BigInt.Compare(L, R);
- end
- else RaiseInvalidOp;
- end;
- procedure TBiVariantType.Copy(var Dest: TVarData;
- const Source: TVarData; const Indirect: Boolean);
- begin
- if Indirect and VarDataIsByRef(Source) then
- VarDataCopyNoInd(Dest, Source)
- else
- VarDataClear(Dest);
- Dest.VType := VarType;
- TBiVarData(Dest).VLength := TBiVarData(Source).VLength;
- GetMem(TBiVarData(Dest).VData, SizeOf(LongWord) * TBiVarData(Dest).VLength);
- Move(TBiVarData(Source).VData^, TBiVarData(Dest).VData^, SizeOf(LongWord) * TBiVarData(Dest).VLength);
- end;
- function TBiVariantType.IsClear(const V: TVarData): Boolean;
- begin
- Result := (TBiVarData(V).VData = nil) and (TBiVarData(V).VLength = 0);
- end;
- initialization
- Randomize;
- BiVariantType := TBiVariantType.Create;
- finalization
- FreeAndNil(BiVariantType);
- end.