stbcd.pas

条码控件： 一维条码控件 二维条码控件 PDF417Barcode MaxiCodeBarcode

        {subtract divisor from current numerator position as many times as possible}
        if TB[N+1] = 0 then begin
          {no overflow digit in this position of numerator}
          for I := 0 to DivDigits-1 do begin
            DDigit := UB2[MantissaDigits-I];
            NDigit := TB[N-I];
            if DDigit < NDigit then
              {divisor still fits}
              break
            else if DDigit > NDigit then
              {divisor doesn't fit}
              goto StoreDigit;
          end;
        end;
        inc(DivIntoCount);

        {subtract divisor once from numerator}
        C := 0;
        for I := DivDigits-1 downto 0 do begin
          T := TB[N-I]-UB2[MantissaDigits-I]-C;
          if T < 0 then begin
            C := 1;
            inc(T, 10);
          end else
            C := 0;
          TB[N-I] := T;
        end;
        {reduce last digit for borrow}
        dec(TB[N+1], C);
      until False;

StoreDigit:
      {store this digit of result}
      UB1[R] := DivIntoCount;
      {next numerator digit}
      dec(N);
    end;
{$ENDIF}

    if UB1[SigDigits] <> 0 then begin
      {round away the temporary digit}
      RoundMantissa(UB1, 1);
      ShiftMantissaDown(UB1, 1);
      inc(E1);
    end;

    {compute exponent}
    N := E1-E2+ExpBias;
    if N > NoSignBit then
      {numeric overflow}
      RaiseBcdError(stscBcdOverflow);
    Pack(UB1, N, S1 xor S2, Result);
  end;
end;

function FastVal(const S : string) : TBcd;
  {-Internal routine to quickly convert a string constant to a Bcd}
  {Assumes no leading spaces,
   no leading '+',
   no leading '.',
   always contains decimal point defined by international DecimalSeparator,
   no invalid characters,
   no exponent,
   < MantissaDigits before decimal point}
var
  I, O, Digits, Exponent : Integer;
  Sign : Byte;
  Rounded : Boolean;
  UB : TUnpBcd;

  procedure AddDigit(Ch : Char);
  begin
    if O > 0 then begin
      UB[O] := Byte(Ch)-Byte('0');
      dec(O);
    end else if not Rounded then begin
      {got more significant digits than will fit, must round}
      Rounded := True;
      UB[0] := Byte(Ch)-Byte('0');
      RoundMantissa(UB, 0);
      if UB[SigDigits] <> 0 then begin
        ShiftMantissaDown(UB, 1);
        inc(Digits);
      end;
    end;
  end;

begin
  FillChar(UB, SizeOf(TUnpBcd), 0);

  O := MantissaDigits;
  Rounded := False;
  Digits := 0;

  {get sign if any}
  if S[1] = '-' then begin
    Sign := SignBit;
    I := 2;
  end else begin
    Sign := 0;
    I := 1;
  end;

  {skip leading zeros}
  while S[I] = '0' do
    inc(I);

  {add significant digits}
  while S[I] <> '.' do begin
    AddDigit(S[I]);
    inc(I);
    inc(Digits);
  end;

  {handle dot}
  inc(I);
  if Digits = 0 then
    {no digits before dot, skip zeros after dot}
    while (I <= length(S)) and (S[I] = '0') do begin
      inc(I);
      dec(Digits);
    end;

  {add significant digits}
  while I <= Length(S) do begin
    AddDigit(S[I]);
    if Rounded then
      break;
    inc(I);
  end;

  {compute final exponent}
  Exponent := Digits+ExpBias;

  if (Exponent <= 0) or IsZeroMantissa(UB) then
    {return zero}
    Exponent := 0;

  {Return packed result}
  Pack(UB, Exponent, Sign, Result);
end;

function ExpBcd(const B : TBcd) : TBcd;
var
  MI, Exponent : LongInt;
  B1, B2, B3, B4, B5 : TBcd;
begin
  if CmpBcd(B, FastVal('147.36')) > 0 then
    {numeric overflow}
    RaiseBcdError(stscBcdOverflow);

  if CmpBcd(B, FastVal('-145.06')) < 0 then begin
    {return zero}
    SetZero(Result);
    Exit;
  end;

  if B[0] = 0 then begin
    {return one}
    Result := FastVal('1.0');
    Exit;
  end;

{If BcdSize > 10, Delphi 2.0 generates a hint (if hints on) about B3 during compile}
{this can be ignored or you can suppress warnings in STDEFINE.INC}
{or suppress hints and warning for the IF..THEN block}

  if BcdSize <= 10 then begin
    {Burns (Cody-Waite) approximation}
    Exponent := RoundBcd(MulBcd(B, FastVal('0.868588963806503655')));
    MI := Exponent; {prevent D32 from generating a hint}
    B5 := LongBcd(MI);

    B3 := AddBcd(B, MulBcd(B5, FastVal('-1.151')));
    B1 := AddBcd(B3, MulBcd(B5, FastVal('-0.000292546497022842009')));
    B2 := MulBcd(B1, B1);

    B3 := MulBcd(B2, FastVal('42.0414268137450315'));
    B3 := MulBcd(B2, AddBcd(B3, FastVal('10097.4148724273918')));
    B4 := MulBcd(B1, AddBcd(B3, FastVal('333267.029226801611')));

    B3 := MulBcd(B2, AddBcd(B2, FastVal('841.243584514154545')));
    B3 := MulBcd(B2, AddBcd(B3, FastVal('75739.3346159883444')));
    B3 := AddBcd(B3, FastVal('666534.058453603223'));
    B3 := DivBcd(B4, SubBcd(B3, B4));
    Result := MulBcd(AddBcd(B3, FastVal('0.5')), FastVal('2.0'));

    if Odd(MI) then begin
      if MI < 0 then
        Result := DivBcd(Result, FastVal('3.16227766016837933'))
      else
        Result := MulBcd(Result, FastVal('3.16227766016837933'));
    end;

    inc(ShortInt(Result[0]), MI div 2);

  end else begin
    {series approximation}
    {compute B2, a number whose exp is close to 1.0}
    {and MI, a number whose exp is a power of 10}
    B2 := DivBcd(B, Ln10Bcd);
    if B[0] and SignBit <> 0 then
      B2 := SubBcd(B2, FastVal('0.5'))
    else
      B2 := AddBcd(B2, FastVal('0.5'));
    MI := TruncBcd(B2);
    B2 := SubBcd(B, MulBcd(IntBcd(B2), Ln10Bcd));

    {compute exp(B2)}
    B1 := FastVal('1.0');
    B4 := B1;
    Result := B1;
    B5 := B2;
    while B5[0] and NoSignBit > ExpBias-MantissaDigits-1 do begin
      Result := AddBcd(Result, B5);
      B4 := AddBcd(B4, B1);
      B5 := DivBcd(MulBcd(B5, B2), B4);
    end;

    {correct exponent for 10**MI}
    Exponent := Result[0] and NoSignBit;
    inc(Exponent, MI);
    if Exponent > NoSignBit then
      {numeric overflow}
      RaiseBcdError(stscBcdOverflow);
    if Exponent <= 0 then
      {underflow}
      SetZero(Result);
    Result[0] := Exponent;
  end;
end;

function ExtBcd(E : Extended) : TBcd;
var
  S : string;
begin
  Str(e:0:MantissaDigits, S);
  Result := ValBcd(FastValPrep(S));
end;

function StrGeneralBcd(const B : TBcd) : string;
var
  I, EndI, Exponent : Integer;

  procedure RemoveTrailingZeros(StartI, EndI : Integer);
  var
    I : Integer;
  begin
    I := StartI;
    while (I > 0) and (Result[I] = '0') and (Result[I] <> DecimalSeparator) do
      dec(I);
    if Result[I] = DecimalSeparator then
      dec(I);
    Delete(Result, I+1, EndI-I);
  end;

begin
  Exponent := B[0] and NoSignBit;

  if (Exponent = 0) or
  ((Exponent <= MantissaDigits+ExpBias) and (Exponent >= ExpBias-4)) then begin
    {use fixed point format for zero, digits to left of decimal point greater
     than or equal to MantissaDigits, or value greater than 0.00001}
    Result := StrBcd(B, 0, MantissaDigits);
    RemoveTrailingZeros(Length(Result), Length(Result));

  end else begin
    {otherwise use scientific format}
    Result := StrExpBcd(B, 0);
    if Result[1] = ' ' then
      Delete(Result, 1, 1);
    I := Length(Result)-1;
    EndI := I-3;
    while (I <= Length(Result)) and (Result[I] = '0') do
      Delete(Result, I, 1);
    if I > Length(Result) then begin
      {exponent was all zero}
      Delete(Result, Length(Result)-1, 2);
      I := Length(Result);
    end else
      {skip back over "e+"}
      I := EndI;
    RemoveTrailingZeros(I, EndI);
  end;
end;

function FormatBcd(const Format: string; const B : TBcd): string;
label
  Restart;
var
  SectNum, SectOfs, I, ExpDigits, ActPlaces : Integer;
  DigitCount, DecimalIndex, FirstDigit, LastDigit : Integer;
  DigitPlace, DigitDelta, Exponent : Integer;
  BufOfs, UBOfs : Integer;
  ThousandSep, Scientific : Boolean;
  Ch : Char;
  Sign : Byte;
  UB : TUnpBcd;
  SExponent : string[4];
  Buffer : array[0..255] of Char;

  function FindSection(SectNum : Integer) : Integer;
    {-Return the offset into Format for the given section number}
  var
    Ch : Char;
  begin
    if SectNum > 0 then begin
      Result := 1;
      while Result <= Length(Format) do begin
        Ch := Format[Result];
        case Ch of
          {labels in ASCII order so 32-bit compiler generates better code}
          '"', '''' : {skip literal}
            begin
              inc(Result);
              while (Result <= Length(Format)) and (Format[Result] <> Ch) do
                inc(Result);
              if Result > Length(Format) then
                break;
            end;
          ';' : {end of section}
            begin
              dec(SectNum);
              if SectNum = 0 then begin
                inc(Result);
                if (Result > Length(Format)) or (Format[Result] = ';') then
                  {empty section}
                  break
                else
                  {found the section, return its offset}
                  exit;
              end;
            end;
        end;
        inc(Result);
      end;
    end;

    {arrive here if desired section is empty, not found, or ill-formed}
    if (Length(Format) = 0) or (Format[1] = ';') then
      {first section is empty, use general format}
      Result := 0
    else
      {use first section}
      Result := 1;
  end;

  procedure ScanSection(SectOfs : Integer);
    {-Initialize DigitCount, DecimalIndex, ThousandSep,
      Scientific, FirstDigit, LastDigit}
  var
    FirstZero, LastZero : Integer;
    Ch : Char;
  begin
    FirstZero := 32767;
    LastZero := 0;
    DigitCount := 0;
    DecimalIndex := -1;
    ThousandSep := False;
    Scientific := False;

    repeat
      Ch := Format[SectOfs];
      case Ch of
        {labels in ASCII order so 32-bit compiler generates better code}
        '"' :
          begin
            inc(SectOfs);
            while (SectOfs <= Length(Format)) and (Format[SectOfs] <> Ch) do
              inc(SectOfs);
            if SectOfs > Length(Format) then
              break;
          end;

        '#' :
          inc(DigitCount);

        '''' :
          begin
            inc(SectOfs);
            while (SectOfs <= Length(Format)) and (Format[SectOfs] <> Ch) do
              inc(SectOfs);
            if SectOfs > Length(Format) then
              break;
          end;

        '0' :
          begin
            if DigitCount < FirstZero then
              FirstZero := DigitCount;
            inc(DigitCount);
            LastZero := DigitCount;
          end;

        ';' :
          break;

        'E', 'e' :
          if SectOfs < Length(Format) then begin
            inc(SectOfs);
            case Format[SectOfs] of
              '-', '+' :
                begin
                  Scientific := True;
                  repeat
                    inc(SectOfs);
                  until (SectOfs > Length(Format)) or (Format[SectOfs] <> '0');
                end;
            else
              {back up and look at character after 'e' again}
              dec(SectOfs);
            end;
          end;
      else
        if Ch = ThousandSeparator then
          ThousandSep := True;

        if Ch = DecimalSeparator  then
          if DecimalIndex = -1 then
            DecimalIndex := DigitCount;
      end;

      inc(SectOfs);
      if SectOfs > Length(Format) then
        break;
    until False;

    if DecimalIndex = -1 then
      DecimalIndex := DigitCount;
    LastDigit := DecimalIndex-LastZero;
    if LastDigit > 0 then
      LastDigit := 0;
    FirstDigit := DecimalIndex-FirstZero;
    if FirstDigit < 0 then
      FirstDigit := 0;
  end;

  procedure StoreChar(Ch : Char);
  begin
    if BufOfs >= SizeOf(Buffer) then
      {buffer overrun}
      RaiseBcdError(stscBcdBufOverflow);
    Buffer[BufOfs] := Ch;
    inc(BufOfs);
  end;

  procedure StoreDigitReally(ReadUB : Boolean);
  var
    BVal : Byte;
  begin
    if ReadUB then begin
      if UBOfs >= 0 then begin
        BVal := UB[UBOfs];
        dec(UBOfs);
      end else if DigitPlace <= LastDigit then begin
        dec(DigitPlace);
        Exit;
      end else
        BVal := 0;
    end else
      BVal := 0;

    if DigitPlace = 0 then begin
      StoreChar(DecimalSeparator);
      StoreChar(Char(BVal+Byte('0')));
    end else begin
      StoreChar(Char(BVal+Byte('0')));
      if ThousandSep then
        if DigitPlace > 1 then
          if DigitPlace mod 3 = 1 then
            StoreChar(ThousandSeparator);
    end;

    dec(DigitPlace);
  end;

  procedure StoreDigit;
  begin
    if DigitDelta = 0 then
      StoreDigitReally(True)
    else if DigitDelta < 0 then begin
      inc(DigitDelta);
      if DigitPlace <= FirstDigit then
        StoreDigitReally(False)
      else
        dec(DigitPlace);
    end else begin
      repeat
        StoreDigitReally(True);
        dec(DigitDelta);
      until DigitDelta = 0;
      StoreDigitReally(True);
    end;
  end;

begin
  Unpack(B, UB, Exponent, Sign);

Restart:
  if Exponent = 0 then
    {zero}
    SectNum := 2
  else if Sign <> 0 then
    {negative}
    SectNum := 1