home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Hall of Fame
/
HallofFameCDROM.cdr
/
prpascal
/
pibpict.lzh
/
PICTFORM.PAS
< prev
Wrap
Pascal/Delphi Source File
|
1986-01-16
|
27KB
|
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 (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 *);
(* ------------------------------------------------------------------------ *)
