(* ------------------------------------------------------------------------ *) (* 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 (312) 882 4227 *) (* Ron Fox's RBBS (312) 940 6496 *) (* *) (* ------------------------------------------------------------------------ *) 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 *); (* ------------------------------------------------------------------------ *) u(dxe(dxe(dxe(dxe(dx