{$S-,R-,I-,V-,B-}

{*********************************************************}
{*                    TPBCD.PAS 4.03                     *}
{*        Copyright (c) TurboPower Software 1987.        *}
{* Portions copyright (c) Sunny Hill Software 1985, 1986 *}
{*     and used under license to TurboPower Software     *}
{*                 All rights reserved.                  *}
{*********************************************************}

unit TpBCD;
  {-Binary Coded Decimal routines}

interface

const
  BCDsize = 10;
type
  BCD = array[1..BCDsize] of Byte;
const
  {Pi in BCD format}
  PiBcd : BCD = ($40, $24, $93, $97, $58, $53, $26, $59, $41, $31);

  {** conversion routines **}

procedure RealToBCD(R : Real; var B : BCD);
  {-Convert a real to a BCD}

procedure LongintToBCD(L : LongInt; var B : BCD);
  {-Convert a Longint to a BCD}

function BCDtoReal(B : BCD) : Real;
  {-Convert a BCD to a real}

function StrBCD(B : BCD; Width, Places : Byte) : string;
  {-Return a BCD as a string}

function StrExpBCD(B : BCD; Width : Byte) : string;
  {-Return B as a string in exponential format}

procedure ValBCD(S : string; var B : BCD; var Code : Word);
  {-Convert a string to a BCD}

procedure AbsBCD(B1 : BCD; var B2 : BCD);
  {-Returns absolute value of B1 in B2}

procedure FracBCD(B1 : BCD; var B2 : BCD);
  {-Returns the fractional part of B1 in B2}

procedure IntBCD(B1 : BCD; var B2 : BCD);
  {-Returns the integer part of B1 in B2}

function RoundBCD(B1 : BCD) : LongInt;
  {-Returns the value of B1 rounded to the nearest long integer}

function TruncBCD(B1 : BCD) : LongInt;
  {-Returns the greatest long integer less than or equal to B1}

function Form(Mask : string; B : BCD) : string;
  {-Returns a formatted string with digits from B merged into the Mask}

  {** simple arithmetic routines **}

procedure AddBCD(B1, B2 : BCD; var B3 : BCD);
  {-Add B1 to B2 and put result in B3}

procedure SubBCD(B1, B2 : BCD; var B3 : BCD);
  {-Subtract B2 from B1 and put result in B3}

procedure MultBCD(B1, B2 : BCD; var B3 : BCD);
  {-Multiply B1 by B2 and put result in B3}

procedure DivBCD(B1, B2 : BCD; var B3 : BCD);
  {-Divide B1 by B2 and put result in B3}

  {** comparison routines **}

function EqualBCD(B1, B2 : BCD) : Boolean;
  {-Returns true if B1 = B2}

function NotEqualBCD(B1, B2 : BCD) : Boolean;
  {-Returns true if B1 <> B2}

function GreaterBCD(B1, B2 : BCD) : Boolean;
  {-Returns true if B1 > B2}

function GreaterEqualBCD(B1, B2 : BCD) : Boolean;
  {-Returns true if B1 >= B2}

function LessBCD(B1, B2 : BCD) : Boolean;
  {-Returns true if B1 < B2}

function LessEqualBCD(B1, B2 : BCD) : Boolean;
  {-Returns true if B1 <= B2}

  {** transcendental functions **}

procedure ArcTanBCD(B1 : BCD; var B2 : BCD);
  {-Returns arc tangent of B1 in B2}

procedure CosBCD(B1 : BCD; var B2 : BCD);
  {-Returns cosine of B1 in B2}

procedure ExpBCD(B1 : BCD; var B2 : BCD);
  {-Returns the exponential of B1 in B2}

procedure LnBCD(B1 : BCD; var B2 : BCD);
  {-Returns the natural log of B1 in B2}

procedure SinBCD(B1 : BCD; var B2 : BCD);
  {-Returns the sine of B1 in B2}

procedure SqrBCD(B1 : BCD; var B2 : BCD);
  {-Returns the square of B1 in B2}

procedure SqrtBCD(B1 : BCD; var B2 : BCD);
  {-Returns the square root of B1 in B2}

  {==========================================================================}

implementation

var
  TempReal1,
  TempReal2 : array[1..2, 1..BCDsize] of Byte;
  TempReal3 : array[1..4, 1..BCDsize] of Byte;
  TempReal4,
  TempReal5,
  TempReal6 : BCD;

  {$L TPBCD.OBJ}
  {$L BCDTRANS.OBJ}

  {routines needed by BCDTRANS}
  procedure LoadTempReal2; external {TPBCD} ;
  procedure SetUsersReal; external {TPBCD} ;
  procedure MultPrimitive; external {TPBCD} ;
  procedure DivPrimitive; external {TPBCD} ;
  procedure AddPrimitive; external {TPBCD} ;
  procedure CopyTempToTemp; external {TPBCD} ;
  procedure CopyUsersTo2; external {TPBCD} ;
  procedure ActualIntBCD; external {TPBCD} ;

  {.$DEFINE debug}

  procedure SystemStr(R : Real; var S : string);
    {-Call the system Str routine to do work of Real to BCD conversion}
  begin
    Str(R, S);
  end;

  procedure SystemVal(S : string; var R : Real; var Code : Word);
    {-Call the system Val routine to do work of BCD to Real conversion}
  begin
    Val(S, R, Code);
  end;

  procedure RealToBCD(R : Real; var B : BCD);
    external {TPBCD} ;

  procedure LongintToBCD(L : LongInt; var B : BCD);
    external {TPBCD} ;

  function BCDtoReal(B : BCD) : Real;
    external {TPBCD} ;

  function StrBCD(B : BCD; Width, Places : Byte) : string;
    external {TPBCD} ;

  function StrExpBCD(B : BCD; Width : Byte) : string;
    external {TPBCD} ;

  procedure ValBCD(S : string; var B : BCD; var Code : Word);
    external {TPBCD} ;

  procedure AddBCD(B1, B2 : BCD; var B3 : BCD);
    external {TPBCD} ;

  procedure SubBCD(B1, B2 : BCD; var B3 : BCD);
    external {TPBCD} ;

  procedure MultBCD(B1, B2 : BCD; var B3 : BCD);
    external {TPBCD} ;

  procedure DivBCD(B1, B2 : BCD; var B3 : BCD);
    external {TPBCD} ;

  function EqualBCD(B1, B2 : BCD) : Boolean;
    external {TPBCD} ;

  function NotEqualBCD(B1, B2 : BCD) : Boolean;
    external {TPBCD} ;

  function GreaterBCD(B1, B2 : BCD) : Boolean;
    external {TPBCD} ;

  function GreaterEqualBCD(B1, B2 : BCD) : Boolean;
    external {TPBCD} ;

  function LessBCD(B1, B2 : BCD) : Boolean;
    external {TPBCD} ;

  function LessEqualBCD(B1, B2 : BCD) : Boolean;
    external {TPBCD} ;

  procedure AbsBCD(B1 : BCD; var B2 : BCD);
    external {TPBCD} ;

  procedure ArcTanBCD(B1 : BCD; var B2 : BCD);
    external {BCDTRANS} ;

  procedure CosBCD(B1 : BCD; var B2 : BCD);
    external {BCDTRANS} ;

  procedure ExpBCD(B1 : BCD; var B2 : BCD);
    external {BCDTRANS} ;

  procedure FracBCD(B1 : BCD; var B2 : BCD);
    external {TPBCD} ;

  procedure IntBCD(B1 : BCD; var B2 : BCD);
    external {TPBCD} ;

  procedure LnBCD(B1 : BCD; var B2 : BCD);
    external {BCDTRANS} ;

  procedure SinBCD(B1 : BCD; var B2 : BCD);
    external {BCDTRANS} ;

  procedure SqrBCD(B1 : BCD; var B2 : BCD);
    external {BCDTRANS} ;

  procedure SqrtBCD(B1 : BCD; var B2 : BCD);
    external {BCDTRANS} ;

  function RoundBCD(B1 : BCD) : LongInt;
    external {TPBCD} ;

  function TruncBCD(B1 : BCD) : LongInt;
    external {TPBCD} ;

  function Form(Mask : string; B : BCD) : string;
    {-Returns a formatted string with digits from B merged into the Mask}
  type
    FillType = (Blank, Asterisk, Zero);
  const
    FormChars : string[8] = '#@*$-+,.';
    PlusArray : array[Boolean] of Char = ('+', '-');
    MinusArray : array[Boolean] of Char = (' ', '-');
    FillArray : array[FillType] of Char = (' ', '*', '0');
  var
    ExpB : Byte absolute B;  {B's sign/exponent byte}
    S : string;              {temporary string}
    Filler : FillType;       {char for unused digit slots: ' ', '*', '0'}
    WontFit,                 {true if number won't fit in the mask}
    AddMinus,                {true if minus sign needs to be added}
    Dollar,                  {true if floating dollar sign is desired}
    Negative : Boolean;      {true if B is negative}
    StartF,                  {starting point of the numeric field}
    EndF,                    {end of numeric field}
    DotPos,                  {position of '.' in Mask}
    Digits,                  {total # of digits}
    Places,                  {# of digits after the '.'}
    Blanks,                  {# of blanks returned by StrBcd}
    FirstDigit,              {pos. of first digit returned by Str}
    Extras,                  {# of extra digits needed for special cases}
    DigitPtr : Byte;         {pointer into temporary string of digits}
    I : Word;
  label
    EndFound,
    RedoCase,
    Done;
  begin
    {check for empty string}
    if Length(Mask) = 0 then
      goto Done;

    {initialize variables}
    Filler := Blank;
    DotPos := 0;
    Places := 0;
    Digits := 0;
    Dollar := False;
    AddMinus := True;
    StartF := 1;

    {store the sign of the real and make it positive}
    Negative := (ExpB and $80) <> 0;
    ExpB := ExpB and $7F;

    {find the starting point for the field}
    while (StartF <= Length(Mask)) and (Pos(Mask[StartF], FormChars) = 0) do
      Inc(StartF);
    if StartF > Length(Mask) then
      goto Done;

    {find the end point for the field}
    for EndF := StartF to Length(Mask) do
      case Mask[EndF] of
        '*' : Filler := Asterisk;
        '@' : Filler := Zero;
        '$' : Dollar := True;
        '-',
        '+' : AddMinus := False;
        '#' : {ignore} ;
        ',',
        '.' : DotPos := EndF;
      else
        goto EndFound;
      end;

    {if we get here at all, the last char was part of the field}
    Inc(EndF);

EndFound:
    {if we jumped to here instead, it wasn't}
    Dec(EndF);

    {disallow Dollar if Filler is Zero}
    if Filler = Zero then
      Dollar := False;

    {we need an extra slot if Dollar is True}
    Extras := Ord(Dollar);

    {get total # of digits and # after the decimal point}
    for I := StartF to EndF do
      case Mask[I] of
        '#', '@',
        '*', '$' :
          begin
            Inc(Digits);
            if (I > DotPos) and (DotPos <> 0) then {***}
              Inc(Places);
          end;
      end;

    {need one more 'digit' if Places > 0}
    Inc(Digits, Ord(Places > 0));

    {also need an extra blank if (1) Negative is true, and (2) Filler is Blank,
     and (3) AddMinus is true}
    if Negative and AddMinus and (Filler = Blank) then
      Inc(Extras)
    else
      AddMinus := False;

    {translate the real to a string}
    S := StrBCD(B, Digits, Places);

    {$IFDEF Debug}
    WriteLn('"', Mask, '"');
    WriteLn('Length : ', Length(Mask), ' Start: ', StartF,
            ' End: ', EndF, ' DotPos: ', DotPos, ' Extras: ', Extras,
            ' Digits: ', Digits, ' Places: ', Places);
    WriteLn('"', S, '"');
    {$ENDIF}

    {count number of initial blanks}
    Blanks := 1;
    while S[Blanks] = ' ' do
      Inc(Blanks);
    FirstDigit := Blanks;
    Dec(Blanks);

    {the number won't fit if (a) S is longer than Digits or (b) the number of
     initial blanks is less than Extras}
    WontFit := (Length(S) > Digits) or (Blanks < Extras);

    {if it won't fit, fill decimal slots with '*'}
    if WontFit then begin
      for I := StartF to EndF do
        case Mask[I] of
          '#', '@', '*', '$' : Mask[I] := '*';
          '+' : Mask[I] := PlusArray[Negative];
          '-' : Mask[I] := MinusArray[Negative];
        end;
      goto Done;
    end;

    {fill initial blanks in S with Filler; insert floating dollar sign}
    if Blanks > 0 then begin
      FillChar(S[1], Blanks, FillArray[Filler]);

      {put floating dollar sign in last blank slot if necessary}
      if Dollar then begin
        S[Blanks] := '$';
        Dec(Extras);
        Dec(Blanks);
      end;

      {insert a minus sign if necessary}
      if AddMinus then
        S[Blanks] := '-';
    end;

    {put in the digits / signs}
    DigitPtr := Length(S);
    for I := EndF downto StartF do begin
RedoCase:
      case Mask[I] of
        '#', '@', '*', '$' :
          if DigitPtr <> 0 then begin
            Mask[I] := S[DigitPtr];
            Dec(DigitPtr);
            if (S[DigitPtr] = '.') and (DigitPtr <> 0) then
              Dec(DigitPtr);
          end
          else
            Mask[I] := FillArray[Filler];
        ',', '.' :
          if (I < DotPos) and (DigitPtr < FirstDigit) then begin
            Mask[I] := '#';
            goto RedoCase;
          end;
        '+' : Mask[I] := PlusArray[Negative];
        '-' : Mask[I] := MinusArray[Negative];
      end;
    end;

Done:
    Form := Mask;
  end;

{begin}
end.
