Hall of Fame/HallofFameCDROM.cdr/prpascal/pibpict.lzh/PICTFORM.PAS

Pascal/Delphi Source File | 1986-01-16 | 26.2 KB | 582 lines

(* ------------------------------------------------------------------------ *)
(*         Picture_Format --- Edit real number using picture format         *)
(* ------------------------------------------------------------------------ *)

Procedure Picture_Format(     X:       Real;
                              Picture: AnyStr;
                          Var Result:  AnyStr;
                          Var Ierr:    Integer    );

(* ------------------------------------------------------------------------ *)
(*                                                                          *)
(*        Procedure:  Picture_Format                                        *)
(*                                                                          *)
(*        Purpose:    Formats a floating-point number according to a        *)
(*                    picture format.                                       *)
(*                                                                          *)
(*        Calling Sequence:                                                 *)
(*                                                                          *)
(*           Picture_Format(     X:       Real;                             *)
(*                               Picture: AnyStr;                           *)
(*                           Var Result:  AnyStr;                           *)
(*                           Var Ierr:    Integer    );                     *)
(*                                                                          *)
(*             Type 'AnyStr' should be defined in the caller as             *)
(*             String[255].                                                 *)
(*                                                                          *)
(*             X       --- Number to be encoded                             *)
(*             Picture --- Picture to use in formatting X (see below)       *)
(*             Result  --- Resultant formatted version of X                 *)
(*             Ierr    --- Error flag                                       *)
(*                         = 0:  Conversion successful                      *)
(*                         = 1:  X was negative, but no picture character   *)
(*                               for a sign found.  'Result' contains the   *)
(*                               successful conversion of ABS( X ).         *)
(*                         = 2:  Incorrect picture character found, or      *)
(*                               legitimate character found in incorrect    *)
(*                               position (e.g., leading comma).            *)
(*                               No conversion done, and 'Result' contains  *)
(*                               the null string.                           *)
(*                         = 3:  More than one decimal point in picture.    *)
(*                               No conversion is done, and 'Result' is     *)
(*                               the null string.                           *)
(*                                                                          *)
(*        Calls:                                                            *)
(*                                                                          *)
(*           Builtin only.                                                  *)
(*                                                                          *)
(*        Method:                                                           *)
(*                                                                          *)
(*           The number X is converted to a string of digits and fill       *)
(*           characters under control of the picture.                       *)
(*                                                                          *)
(*        Restrictions:                                                     *)
(*                                                                          *)
(*           The picture may not exceed 80 characters in length.            *)
(*                                                                          *)
(*        Description of Picture Format Characters                          *)
(*        ----------------------------------------                          *)
(*                                                                          *)
(*           The picture format implemented by this routine resembles the   *)
(*           picture formats available in PL/1 or Cobol.  It also resembles *)
(*           the ED/EDMK machine instructions of IBM 360/370 machines.      *)
(*                                                                          *)
(*           The available picture characters are:                          *)
(*                                                                          *)
(*             Character                M e a n i n g                       *)
(*             ---------    ---------------------------------------------   *)
(*                                                                          *)
(*                 9         Digit select.  The next digit is inserted into *)
(*                           the result, even if it is a leading zero.  The *)
(*                           first appearance of a 9 turns on the signifi-  *)
(*                           indicator, meaning that all following digits,  *)
(*                           even leading zeros, will be significant.       *)
(*                                                                          *)
(*                 B         Insert a blank in the result.                  *)
(*                                                                          *)
(*                 Z         Digit select like '9', but if the digit is a   *)
(*                           leading zero, a blank is inserted instead.     *)
(*                                                                          *)
(*                 S         Inserts sign into the result, either '+' or    *)
(*                           '-', depending upon the sign of X.             *)
(*                                                                          *)
(*                 *         Field protection -- replaces leading zeros.    *)
(*                                                                          *)
(*                 +         If '+' appears last or as part of the initial  *)
(*                           string, it selects the sign of X (either '+'   *)
(*                           or '-').  For X > 0, a '+' is output; for      *)
(*                           X <= 0, a blank is output. Otherwise, '+' acts *)
(*                           as a literal, and is placed directly in the    *)
(*                           output.                                        *)
(*                                                                          *)
(*                 -         If '-' appears last or as part of the initial  *)
(*                           string, it selects the sign of X.  For X < 0,  *)
(*                           a '-' is output; for X >= 0, a blank.  If '-'  *)
(*                           appears elsewhere, it acts as a literal, and   *)
(*                           is placed directly in the output.              *)
(*                                                                          *)
(*                 .         Selects the decimal point.  Only one allowed   *)
(*                           in the picture.                                *)
(*                                                                          *)
(*                 $         Replaces leading zeros with blanks and a       *)
(*                           dollar sign.                                   *)
(*                                                                          *)
(*                 ,         Inserts comma in result if a digit appears to  *)
(*                           left, else next character to left in picture   *)
(*                           is used instead.  Note:  except for leading,   *)
(*                           trailing, and adjacent commas, comma placement *)
(*                           is not checked.                                *)
(*                                                                          *)
(*                 /         Inserts '/' in result.                         *)
(*                                                                          *)
(*                 (         Replaces leading zeros with blanks and a '('   *)
(*                           if the number is negative.                     *)
(*                                                                          *)
(*                 )         Selects ')' if the number is negative.         *)
(*                           Must be last character in picture.             *)
(*                                                                          *)
(*                CR         Inserts 'CR' in result if number is NEGATIVE.  *)
(*                           Must appear at end of picture.                 *)
(*                                                                          *)
(*                DB         Inserts 'DB' in result if number is NEGATIVE.  *)
(*                           Must appear at end of picture.                 *)
(*                                                                          *)
(*           Floating Characters                                            *)
(*           -------------------                                            *)
(*                                                                          *)
(*           The characters (,$,+,-,S  may 'float'.  This means that the    *)
(*           RIGHTMOST appearance of one of these characters in the picture *)
(*           replaces the first leading zero to the left of the leftmost    *)
(*           significant digit.                                             *)
(*                                                                          *)
(*           Other appearances to the left of the one actually used to      *)
(*           replace a leading zero are replaced by leading blanks.         *)
(*                                                                          *)
(*           Treatment of Sign Characters                                   *)
(*           ----------------------------                                   *)
(*                                                                          *)
(*           The rightmost appearance of a sign dictates the placement of   *)
(*           the sign, and overrides any appearance of a sign request to    *)
(*           the left.  This allows for trailing signs as well as initial   *)
(*           signs -- but only one appears in the edited result (the        *)
(*           rightmost).                                                    *)
(*                                                                          *)
(*           Embedded '+' or '-' signs are treated as literals, not signs.  *)
(*           This provides, for example, for formatting social security     *)
(*           numbers with a '-' separating the three parts.                 *)
(*                                                                          *)
(*           A trailing DB or CR is considered a sign request.  Thus,       *)
(*           other signs to the left are not inserted into the result.      *)
(*                                                                          *)
(* ------------------------------------------------------------------------ *)
(*                                                                          *)
(*        Author:  Philip R. Burns                                          *)
(*        Date:    February, 1985.                                          *)
(*        Version: 1.0                                                      *)
(*                                                                          *)
(*        Notice:  You are free to use this routine in code you write.      *)
(*                 If you do, please give proper credit.                    *)
(*                                                                          *)
(*        Bugs:    Report bugs and/or enhancements to me on one of the      *)
(*                 following two Chicago area BBSs:                         *)
(*                                                                          *)
(*                 Gene Plantz's IBBS      [phone]                   *)
(*                 Ron Fox's RBBS          [phone]                   *)
(*                                                                          *)
(* ------------------------------------------------------------------------ *)


Const                              (* Maximum length of a picture *)
   MaxPic = 80;

Const
                                   (* Valid picture characters *)

   PiChar: Array[1..17] of Char = '9BSZ*+-.$,/()CRDB';

Var
                                   (* Number of decimal places in result *)
   Ndec:       Integer;
                                   (* Location of decimal point in result *)
   Decloc:     Integer;
                                   (* Length of picture *)
   Lpic:       Integer;
                                   (* Current picture character code *)
   Code:       Byte;
                                   (* Result character *)
   Rchar:      Char;
                                   (* Sign character *)
   Sign_Char:  Char;
                                   (* Length of coded/edited picture *)
   LPicCod:    Integer;
                                   (* Encoded picture *)

   PicCod:     Array[ 1 .. MaxPic ] Of Byte;

                                   (* Last signif. digit already found    *)
   Qdigs:      Boolean;
                                   (* Digits from now on are significant  *)
   Qsig:       Boolean;
                                   (* Sign already inserted in result     *)
   Qsused:     Boolean;
                                   (* $ already inserted in result field  *)
   Qdused:     Boolean;
                                   (* ( already inserted in result field  *)
   Qlpuse:     Boolean;
                                   (* Decimal point found in picture      *)
   Qdecf:      Boolean;
                                   (* Holds converted digits of number    *)
   Digits:     String[40];
                                   (* Next digit to be inserted in result *)
   CurDig:     Integer;
                                   (* General scratch variables           *)
   I:          Integer;
   J:          Byte;
   LastJ:      Byte;
   Ch:         Char;

Label 9001;                        (* Error exit *)
Label 55;                          (* For commas *)

Procedure GetNextDigit;

(* ------------------------------------------------------------------------ *)
(*                                                                          *)
(*     Procedure:  GetNextDigit                                             *)
(*                                                                          *)
(*     Purpose:    Selects the next digit of fill character to be inserted  *)
(*                 in the edited result.                                    *)
(*                                                                          *)
(* ------------------------------------------------------------------------ *)

Var
   Rchar2:    Char;

Begin (* GetNextDigit *)

   If NOT Qdigs THEN
      Begin

         Rchar2 := Digits[ CurDig ];

         While( NOT ( Rchar2 In ['0'..'9',' '] ) ) Do
            Begin
               If CurDig > 1 Then
                  Begin
                     CurDig := CurDig - 1;
                     Rchar2 := Digits[ CurDig ];
                  End
               Else
                  Begin
                     Rchar2 := ' ';
                     Qdigs  := TRUE;
                  End;
            End;

         CurDig := CurDig - 1;

         If ( NOT QDIGS ) And ( RChar2 <> ' ' ) Then
            Rchar := Rchar2;

      End;

   Qsused := Qsused OR (  RChar  = Sign_Char );
   Qdigs  := Qdigs  OR (  RChar2 = ' '       );
   Qdused := Qdused OR (  RChar  = '$'       );
   Qlpuse := Qlpuse OR (  RChar  = '('       );

End   (* GetNextDigit *);

(* ------------------------------------------------------------------------ *)

Begin (* Picture_Format *)

                                   (* Initialize result to null string. *)
   Result  := '';
                                   (* We only look at the first MaxPic  *)
                                   (* characters of the picture.        *)

   Lpic    := LENGTH( Picture );
   If Lpic > MaxPic Then Lpic := MaxPic;

                                   (* Other initializations *)
   Decloc  := 0;
   LastJ   := 0;
   LPicCod := 0;
   Ierr    := 0;
   Qdecf   := FALSE;

                                   (* Scan the picture and convert it *)
                                   (* to control codes.  Stop if any  *)
                                   (* errors are found.               *)

   For I := 1 TO Lpic Do
      Begin
                                   (* Get next character in picture.  *)

         Ch     := UpCase( Picture[I] );

                                   (* Get corresponding control code. *)

         J := POS( Ch , PiChar );

                                   (* If valid picture character, some *)
                                   (* editing may be required.         *)
         If J <> 0 Then
            Begin

               Case Ch Of
                                   (* If decimal point already found,  *)
                                   (* trailing digits must be signif.  *)

                  'Z': If Qdecf Then J := 1;

                                   (* Check comma placement.           *)

                  ',': If ( I     = 1    ) OR
                          ( I     = Lpic ) OR
                          ( LastJ = 10 )   OR
                          Qdecf Then
                           Begin
                              Ierr := 2;
                              GOTO 9001;
                           End;

                                   (* Check for duplicate decimal point. *)

                  '.': If DecLoc = 0 Then
                          Begin
                             DecLoc := I;
                             Qdecf  := TRUE;
                          End
                       Else
                          Begin
                             Ierr := 3;
                             GOTO 9001;
                          End;

                                    (* Remove floating ( if positive X *)

                  '(': If X > 0.0 Then J := 4;

                                    (* Remove trailing ) if positive X *)

                  ')': If ( I <> LPic ) Then
                          Begin
                             Ierr := 2;
                             GOTO 9001;
                          End
                       Else If X > 0.0 Then J := 0;

                                   (* Fix up CR and DB.   *)

                  'R': If ( LastJ <> 14 ) Then
                          Begin
                             Ierr := 2;
                             GOTO 9001;
                          End;

                  'B': If ( LastJ = 16 ) Then  J := 17;

               End (* Case *);

               If J > 0 Then
                  Begin
                     LpicCod           := LpicCod + 1;
                     PicCod[ LpicCod ] := J;
                  End;

            End

         Else (* Bad Picture Character *)
            Begin
               Ierr := 2;
               GOTO 9001;
            End;

         If J > 0 Then LastJ := J;

      End;

                                   (* Find Number Digits after Decimal Point *)

   Ndec   := 0;

   If ( Decloc <> 0 ) AND ( Decloc <> LPicCod ) Then
      Begin

         J := Decloc + 1;

         For I := J To LPicCod Do
            If ( PicCod[I] = 1 ) OR
               ( PicCod[I] = 4 ) Then
               Ndec   := Ndec + 1;

      End;

                                   (* Convert number to character form *)

   STR( ABS( X ) : 40 : Ndec , Digits );

                                   (* Point to last digit in conversion *)
   CurDig    := 40;

                                   (* Remember sign of number *)

   If X >= 0 Then
      Sign_Char := '+'
   Else
      Sign_Char := '-';

                                   (* Set conversion flags. *)
   Qdigs  := FALSE;
   Qsig   := TRUE;
   Qsused := FALSE;
   Qdused := FALSE;
   Qlpuse := ( X >= 0.0 );

                                  (* Begin editing process.  Insert digits  *)
                                  (* into result field under control of     *)
                                  (* picture.                               *)

   For I := 1 To LPicCod DO
      Begin    (* Picture Formatting *);

         J      := LPicCod - I + 1;
         Code   := PicCod[J];
         Rchar  := PiChar[ Code ];

55:
         Case Code Of
                                   (* Select a digit*)
             1 :  Begin
                     Rchar  := '0';
                     GetNextDigit;
                  End;

             2 :  Rchar := ' ';    (* Insert a blank *)

             3 :  Begin            (* Insert explicit sign *)

                     Rchar := Sign_Char;

                     If ( J = LpicCod ) Then
                        QsUsed := TRUE
                     Else If ( J = 1 ) Then
                        Begin
                           If QsUsed Then Rchar := ' ';
                           QsUsed := TRUE;
                        End
                     Else If ( PicCod[ J - 1 ] = Code ) OR
                             ( PicCod[ J - 1 ] = 10   ) OR
                             ( PicCod[ J - 1 ] = 7    ) Then
                        Begin
                           If QsUsed Then Rchar := ' ';
                           GetNextDigit;
                        End;

                  End;

                                   (* Select signif. digit or blank *)
             4 :  Begin
                     Rchar  := ' ';
                     GetNextDigit;
                  End;

             5 :  Begin            (* Field protection              *)
                     GetNextDigit;
                  End;

             6 :  Begin            (* Plus sign.                    *)

                     Rchar := Sign_Char;

                     If ( J = LpicCod ) Then
                        Begin
                           QsUsed := TRUE;
                           If ( X < 0.0 ) Then Rchar := ' ';
                        End
                     Else If ( J = 1 ) Then
                        Begin
                           If QsUsed Then Rchar := ' ';
                           QsUsed := TRUE;
                        End
                     Else If ( PicCod[ J - 1 ] = Code ) OR
                             ( PicCod[ J - 1 ] = 10   ) OR
                             ( PicCod[ J - 1 ] = 7    ) Then
                        Begin
                           If QsUsed Then Rchar := ' ';
                           GetNextDigit;
                        End
                     Else
                        Rchar := PiChar[6];

                  End;

             7:   Begin            (* Minus sign *)

                     Rchar := Sign_Char;

                     If ( J = LpicCod ) Then
                        Begin
                           QsUsed := TRUE;
                           If ( X >= 0.0 ) Then Rchar := ' ';
                        End
                     Else If ( J = 1 ) Then
                        Begin
                           If ( NOT QsUsed ) AND ( X < 0.0 ) Then
                              Rchar := Sign_Char
                           Else
                              Rchar := ' ';
                           QsUsed := TRUE;
                        End
                     Else If ( PicCod[ J - 1 ] = Code ) OR
                             ( PicCod[ J - 1 ] = 10   ) OR
                             ( PicCod[ J - 1 ] = 6    ) Then
                        Begin
                           If QsUsed Then Rchar := ' ';
                           GetNextDigit;
                        End
                     Else
                        Rchar := PiChar[7];

                  End   (* - *);

                                   (* Decimal point.  Digits from here on   *)
                                   (* may not be significant.               *)
             8 :  Qsig := FALSE;

                                   (* Floating dollar sign           *)

             9 :  If Qdused Then Rchar := ' '
                  Else GetNextDigit;

            10 :  Begin            (* Comma *)

                     If ( NOT ( Digits[ CurDig ] In ['0'..'9'] ) ) AND
                        ( PicCod[ J - 1 ] <> 1 ) Then
                        Begin
                           Code  := PicCod[ J - 1 ];
                           Rchar := PiChar[ Code ];
                           GOTO 55;
                        End;

                  End   (* , *);

                                   (* / *)

            11 :  If Qdigs THEN Rchar := ' ';

                                   (* Floating left parenthesis *)

            12 :  If Qlpuse Then Rchar := ' '
                  Else GetNextDigit;

                                   (* Right parenthesis *)

            13 :  If X >= 0.0 Then Rchar := ' ';

                                   (* CR and DB *)
        14..17 :  Begin
                     If X >= 0.0 Then Rchar := ' ';
                     QsUsed := TRUE;
                  End;

         End  (* Case *);

                                   (* Insert next character into result *)
         Res := Rchar + Res;

      End (* Picture Formatting *);
                                   (* If number was negative, but sign *)
                                   (* never inserted, report error 1.  *)

   If ( X < 0 ) AND ( NOT QsUsed ) Then Ierr := 1;

9001: ;

End  (* Picture_Format *);

(* ------------------------------------------------------------------------ *)