home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / PASWIZ13.ZIP / SOURCE.ZIP / BCD.PAS next >
Encoding:
Pascal/Delphi Source File  |  1992-10-29  |  13.7 KB  |  581 lines
  1. {   +----------------------------------------------------------------------+
  2.     |                                                                      |
  3.     |        PasWiz  Copyright (c) 1990-1992  Thomas G. Hanlin III         |
  4.     |             3544 E. Southern Ave. #104,  Mesa, AZ 85204              |
  5.     |                                                                      |
  6.     |                     The Pascal Wizard's Library                      |
  7.     |                                                                      |
  8.     +----------------------------------------------------------------------+
  9.  
  10.  
  11.  
  12. BCD math:
  13.  
  14.    This collection of routines provides powerful support for BCD math.
  15.    Numbers may be up to 255 digits long, with a decimal point anywhere
  16.    you want it.  Trig and other advanced functions are provided as well
  17.    as the more prosaic multiply, divide, subtract, and add.
  18.  
  19. }
  20.  
  21.  
  22.  
  23. UNIT BCD;
  24.  
  25.  
  26.  
  27. INTERFACE
  28.  
  29.  
  30.  
  31. VAR
  32.    LeftD, RightD: Integer;
  33.  
  34.  
  35.  
  36. FUNCTION BCDAbs (Nr: String): String;
  37. FUNCTION BCDAdd (Nr1, Nr2: String): String;
  38. FUNCTION BCDCompare (Nr1, Nr2: String): Integer;
  39. FUNCTION BCDCos (Nr: String): String;
  40. FUNCTION BCDCot (Nr: String): String;
  41. FUNCTION BCDCsc (Nr: String): String;
  42. FUNCTION BCDDeg2Rad (Nr: String): String;
  43. FUNCTION BCDDiv (Nr1, Nr2: String): String;
  44. FUNCTION BCDe: String;
  45. FUNCTION BCDFact (Num: Integer): String;
  46. FUNCTION BCDFormat (Nr: String; FormatType, RightDigits: Integer): String;
  47. FUNCTION BCDFrac (Nr: String): String;
  48. FUNCTION BCDInt (Nr: String): String;
  49. FUNCTION BCDMul (Nr1, Nr2: String): String;
  50. FUNCTION BCDNeg (Nr: String): String;
  51. FUNCTION BCDpi: String;
  52. FUNCTION BCDPower (Nr: String; Power: Integer): String;
  53. FUNCTION BCDRad2Deg (Nr: String): String;
  54. FUNCTION BCDSec (Nr: String): String;
  55. FUNCTION BCDSet (NumSt: String): String;
  56. FUNCTION BCDSgn (Nr: String): Integer;
  57. FUNCTION BCDSin (Nr: String): String;
  58. FUNCTION BCDSqrt (Nr: String): String;
  59. FUNCTION BCDSub (Nr1, Nr2: String): String;
  60. FUNCTION BCDTan (Nr: String): String;
  61.  
  62.  
  63.  
  64.  
  65. { --------------------------------------------------------------------------- }
  66.  
  67.  
  68.  
  69. IMPLEMENTATION
  70.  
  71.  
  72.  
  73. {$F+}
  74.  
  75. { various helper routines in assembly language }
  76.  
  77. PROCEDURE BCDAdd1 (VAR Nr1: String; Nr2: String); external;
  78. PROCEDURE BCDDiv1L (VAR Nr: String); external;
  79. PROCEDURE BCDDiv1R (VAR Nr: String); external;
  80. PROCEDURE BCDMul1 (VAR Nr: String; Multiplier: Byte); external;
  81. PROCEDURE BCDSub1 (VAR Nr: String); external;
  82.  
  83. FUNCTION BCDAbs; external;
  84. FUNCTION BCDSgn; external;
  85.  
  86. {$L BCDABS}
  87. {$L BCDADD1}
  88. {$L BCDDIV1L}
  89. {$L BCDDIV1R}
  90. {$L BCDMUL1}
  91. {$L BCDSGN}
  92. {$L BCDSUB1}
  93.  
  94.  
  95.  
  96. { local function: complement a number }
  97. FUNCTION Complement (Nr: String): String;
  98. VAR
  99.    St: String;
  100. BEGIN
  101.    St := Nr;
  102.    BCDSub1(St);
  103.    Complement := St;
  104. END;
  105.  
  106.  
  107.  
  108. { local func: create a string of nulls }
  109. FUNCTION NullDupe (DupeCount: Integer): String;
  110. VAR
  111.    tmp: Integer;
  112.    St: String;
  113. BEGIN
  114.    St := '';
  115.    FOR tmp := 1 TO DupeCount DO
  116.       St := St + CHR(0);
  117.    NullDupe := St;
  118. END;
  119.  
  120.  
  121.  
  122. { addition }
  123. FUNCTION BCDAdd (Nr1, Nr2: String): String;
  124. VAR
  125.    Sign1, Sign2, N1, N2: String;
  126. BEGIN
  127.    Sign1 := Copy(Nr1, 1, 1);
  128.    Sign2 := Copy(Nr2, 1, 1);
  129.    N1 := Copy(Nr1, 2, 255);
  130.    N2 := Copy(Nr2, 2, 255);
  131.    IF (Sign1 = Sign2) THEN BEGIN
  132.       BCDAdd1 (N1, N2);
  133.       BCDAdd := Sign1 + N1; END
  134.    ELSE IF (Sign1 = '-') THEN
  135.       BCDAdd := BCDSub(Nr2, ' ' + N1)
  136.    ELSE
  137.       BCDAdd := BCDSub(Nr1, ' ' + N2);
  138. END;
  139.  
  140.  
  141.  
  142. { compare two numbers }
  143. FUNCTION BCDCompare (Nr1, Nr2: String): Integer;
  144. VAR
  145.    Sign1, Sign2: String;
  146. BEGIN
  147.    Sign1 := Copy(Nr1, 1, 1);
  148.    Sign2 := Copy(Nr2, 1, 1);
  149.    IF (Sign1 = Sign2) THEN
  150.       BCDCompare := BCDSgn(BCDSub(' ' + Copy(Nr1, 2, 255), ' ' + Copy(Nr2, 2, 255)))
  151.    ELSE IF (Sign1 = '-') THEN
  152.       BCDCompare := -1
  153.    ELSE
  154.       BCDCompare := 1;
  155. END;
  156.  
  157.  
  158.  
  159. { cosine }
  160. FUNCTION BCDCos (Nr: String): String;
  161. VAR
  162.    One, Two, St, Result, I, X2: String;
  163. BEGIN
  164.    One := BCDSet('1');
  165.    Two := BCDSet('2');
  166.    St := One;
  167.    Result := One;
  168.    I := Two;
  169.    X2 := BCDMul(Nr, Nr);
  170.    WHILE (BCDSgn(St) <> 0) DO BEGIN
  171.       St := BCDNeg(BCDDiv(BCDMul(St, X2), BCDMul(I, BCDSub(I, One))));
  172.       Result := BCDAdd(Result, St);
  173.       I := BCDAdd(I, Two);
  174.    END;
  175.    BCDCos := Result;
  176. END;
  177.  
  178.  
  179.  
  180. { cotangent }
  181. FUNCTION BCDCot (Nr: String): String;
  182. BEGIN
  183.    BCDCot := BCDDiv(BCDCos(Nr), BCDSin(Nr));
  184. END;
  185.  
  186.  
  187.  
  188. { cosecant }
  189. FUNCTION BCDCsc (Nr: String): String;
  190. BEGIN
  191.    BCDCsc := BCDDiv(BCDSet('1'), BCDSin(Nr));
  192. END;
  193.  
  194.  
  195.  
  196. { convert degrees to radians }
  197. FUNCTION BCDDeg2Rad (Nr: String): String;
  198. BEGIN
  199.    BCDDeg2Rad := BCDDiv(BCDMul(Nr, BCDpi), BCDSet('180'));
  200. END;
  201.  
  202.  
  203.  
  204. { division }
  205. FUNCTION BCDDiv (Nr1, Nr2: String): String;
  206. VAR
  207.    Sign1, Sign2, N1, N2, Result, ShiftTrack: String;
  208.    Flip, Ready: Boolean;
  209. BEGIN
  210.    IF (BCDSgn(Nr2) = 0) THEN
  211.       BCDDiv := ''
  212.    ELSE IF (BCDSgn(Nr1) = 0) THEN
  213.       BCDDiv := Nr1
  214.    ELSE BEGIN
  215.       Sign1 := Copy(Nr1, 1, 1);
  216.       Sign2 := Copy(Nr2, 1, 1);
  217.       N1 := BCDAbs(Nr1);
  218.       N2 := BCDAbs(Nr2);
  219.       Result := BCDSet('0');
  220.       ShiftTrack := BCDSet('1');
  221.       REPEAT
  222.          Flip := FALSE;
  223.          Ready := FALSE;
  224.          REPEAT
  225.             CASE BCDCompare(N2, N1) OF
  226.                -1: BEGIN
  227.                       BCDDiv1L(N2);
  228.                       BCDDiv1L(ShiftTrack);
  229.                       Flip := TRUE;
  230.                    END;
  231.                 0: Ready := TRUE;
  232.                 1: BEGIN
  233.                       BCDDiv1R(N2);
  234.                       BCDDiv1R(ShiftTrack);
  235.                       Ready := Flip;
  236.                    END;
  237.             END;
  238.             IF (BCDSgn(ShiftTrack) = 0) THEN Ready := TRUE;
  239.          UNTIL Ready;
  240.          Result := BCDAdd(Result, ShiftTrack);
  241.          N1 := BCDSub(N1, N2);
  242.       UNTIL ((BCDSgn(ShiftTrack) = 0) OR (BCDSgn(N1) = 0));
  243.       IF (Sign1 = Sign2) THEN
  244.          BCDDiv := Sign1 + Copy(Result, 2, 255)
  245.       ELSE
  246.          BCDDiv := '-' + Copy(Result, 2, 255);
  247.    END;
  248. END;
  249.  
  250.  
  251.  
  252. { the constant "e" }
  253. FUNCTION BCDe: String;
  254. VAR
  255.    St: String;
  256. BEGIN
  257.    St := '2.718281828459045235360287471352662497757247093699959574966';
  258.    St := St + '9676277240766303535475945713821785251664274274663919320031';
  259.    BCDe := BCDSet(St);
  260. END;
  261.  
  262.  
  263.  
  264. { factorial }
  265. FUNCTION BCDFact (Num: Integer): String;
  266. VAR
  267.    One, Result, Mult: String;
  268.    N: Integer;
  269. BEGIN
  270.    One := BCDSet('1');
  271.    Result := One;
  272.    Mult := BCDSet('2');
  273.    FOR N := 2 TO Num DO BEGIN
  274.       Result := BCDMul(Result, Mult);
  275.       Mult := BCDAdd(Mult, One);
  276.    END;
  277.    BCDFact := Result;
  278. END;
  279.  
  280.  
  281.  
  282. { format a number into a text string }
  283. FUNCTION BCDFormat (Nr: String; FormatType, RightDigits: Integer): String;
  284. VAR
  285.   L, R, Sign, T, St: String;
  286.   tmp, ch: Integer;
  287. BEGIN
  288.    Sign := Copy(Nr, 1, 1);
  289.    L := Copy(Nr, 2, LeftD);
  290.    R := Copy(Nr, Length(Nr) - RightD + 1, RightD);
  291.    WHILE (Copy(L, 1, 1) = CHR(0)) DO
  292.       L := Copy(L, 2, 255);
  293.    IF (L = '') THEN L := CHR(0);
  294.    IF (Odd(FormatType) AND (Length(L) > 3)) THEN BEGIN
  295.       T := Copy(L, 1, Length(L) - 3);
  296.       L := Copy(L, Length(L) - 2, 3);
  297.       WHILE (Length(T) > 3) DO BEGIN
  298.          L := Copy(T, Length(T) - 2, 3) + ',' + L;
  299.          T := Copy(T, 1, Length(T) - 3);
  300.       END;
  301.       L := T + ',' + L;
  302.       IF (Copy(L, 1, 1) = ',') THEN L := Copy(L, 2, 255);
  303.    END;
  304.    IF (Odd(FormatType SHR 1)) THEN L := '$' + L;
  305.    IF (Odd(FormatType SHR 3) AND (Sign = ' ')) THEN Sign := '+';
  306.    R := Copy(R, 1, Abs(RightDigits));
  307.    IF (RightDigits < 0) THEN
  308.       WHILE (Copy(R, Length(R), 1) = CHR(0)) DO
  309.          R := Copy(R, 1, Length(R) - 1);
  310.    IF (Odd(FormatType SHR 2)) THEN
  311.       R := R + Sign
  312.    ELSE
  313.       L := Sign + L;
  314.    St := L + '.' + R;
  315.    IF (RightDigits = 0) THEN BEGIN
  316.       tmp := Pos('.', St);
  317.       St := Copy(St, 1, tmp - 1) + Copy(St, tmp + 1, 255);
  318.    END;
  319.    FOR tmp := 1 TO Length(St) DO BEGIN
  320.       ch := ORD(St[tmp]);
  321.       IF (ch < 10) THEN St[tmp] := CHR(ch + 48);
  322.    END;
  323.    BCDFormat := St;
  324. END;
  325.  
  326.  
  327.  
  328. { keep only the digits to the right of the decimal point }
  329. FUNCTION BCDFrac (Nr: String): String;
  330. VAR
  331.    St: String;
  332.    tmp: Integer;
  333. BEGIN
  334.    St := BCDFormat(Nr, 0, RightD);
  335.    tmp := Pos('.', St);
  336.    IF (tmp > 0) THEN
  337.       St := '0' + Copy(St, tmp, 255)
  338.    ELSE
  339.       St := '0';
  340.    BCDFrac := BCDSet(St);
  341. END;
  342.  
  343.  
  344.  
  345. { keep only the digits to the left of the decimal point }
  346. FUNCTION BCDInt (Nr: String): String;
  347. BEGIN
  348.    BCDInt := BCDSet(BCDFormat(Nr, 0, 0));
  349. END;
  350.  
  351.  
  352.  
  353. { multiply }
  354. FUNCTION BCDMul (Nr1, Nr2: String): String;
  355. VAR
  356.    ch: Byte;
  357.    TotalD, tmp2, ShiftVal: Integer;
  358.    Sign, N1, N2, Total, St: String;
  359. BEGIN
  360.    TotalD := LeftD + RightD;
  361.    IF (Copy(Nr1, 1, 1) = Copy(Nr2, 1, 1)) THEN
  362.       Sign := ' '
  363.    ELSE
  364.       Sign := '-';
  365.    N1 := Copy(Nr1, 2, 255);
  366.    N2 := Copy(Nr2, 2, 255);
  367.    Total := BCDSet('0');
  368.    FOR tmp2 := Length(N2) DOWNTO 1 DO BEGIN
  369.       ch := ORD(N2[tmp2]);
  370.       IF (ch <> 0) THEN BEGIN
  371.          St := N1;
  372.          BCDMul1(St, ch);
  373.          IF (tmp2 > TotalD - RightD) THEN BEGIN
  374.             ShiftVal := RightD - (TotalD - tmp2);
  375.             St := ' ' + NullDupe(ShiftVal) + Copy(St, 1, Length(St) - ShiftVal);
  376.          END
  377.          ELSE BEGIN
  378.             ShiftVal := LeftD - tmp2;
  379.             St := ' ' + Copy(St, ShiftVal + 1, 255) + NullDupe(ShiftVal);
  380.          END;
  381.          Total := BCDAdd(Total, St);
  382.       END;
  383.    END;
  384.    BCDMul := Sign + Copy(Total, 2, 255);
  385. END;
  386.  
  387.  
  388.  
  389. { negate }
  390. FUNCTION BCDNeg (Nr: String): String;
  391. BEGIN
  392.    CASE BCDSgn(Nr) OF
  393.       -1: BCDNeg := ' ' + Copy(Nr, 2, 255);
  394.        0: BCDNeg := Nr;
  395.        1: BCDNeg := '-' + Copy(Nr, 2, 255);
  396.    END;
  397. END;
  398.  
  399.  
  400.  
  401. { the constant "pi" }
  402. FUNCTION BCDpi: String;
  403. VAR
  404.    St: String;
  405. BEGIN
  406.    St := '3.1415926535897932384626433832795028841971';
  407.    St := St + '6939937510582097494459230781640628620899';
  408.    St := St + '8628034825342117067982148086513282306647';
  409.    St := St + '0938446095505822317253594081284811174502';
  410.    St := St + '8410270193852110555964462294895493038196';
  411.    St := St + '4428810975665933446128475648233786783165';
  412.    St := St + '2712019091456';
  413.    BCDpi := BCDSet(St);
  414. END;
  415.  
  416.  
  417.  
  418. { raise a number to a power }
  419. FUNCTION BCDPower (Nr: String; Power: Integer): String;
  420. VAR
  421.    P: Integer;
  422.    Sign, PSeq, Result: String;
  423. BEGIN
  424.    IF (Power <= 0) THEN
  425.       BCDPower := BCDSet('1')
  426.    ELSE BEGIN
  427.       Sign := Copy(Nr, 1, 1);
  428.       P := Power;
  429.       Result := BCDSet('1');
  430.       PSeq := BCDAbs(Nr);
  431.       WHILE (P > 0) DO BEGIN
  432.          IF Odd(P) THEN Result := BCDMul(Result, PSeq);
  433.          P := P DIV 2;
  434.          PSeq := BCDMul(PSeq, PSeq);
  435.       END;
  436.       IF Odd(Power) THEN
  437.          BCDPower := Sign + Copy(Result, 2, 255)
  438.       ELSE
  439.          BCDPower := Result;
  440.    END;
  441. END;
  442.  
  443.  
  444.  
  445. { convert radians to degrees}
  446. FUNCTION BCDRad2Deg (Nr: String): String;
  447. BEGIN
  448.    BCDRad2Deg := BCDDiv(BCDMul(Nr, BCDSet('180')), BCDpi);
  449. END;
  450.  
  451.  
  452.  
  453. { secant }
  454. FUNCTION BCDSec (Nr: String): String;
  455. BEGIN
  456.    BCDSec := BCDDiv(BCDSet('1'), BCDCos(Nr));
  457. END;
  458.  
  459.  
  460.  
  461. { convert a text string to a BCD number }
  462. FUNCTION BCDSet (NumSt: String): String;
  463. VAR
  464.    tmp, ch: Integer;
  465.    St, Sign, L, R: String;
  466. BEGIN
  467.    St := NumSt;
  468.    WHILE (Copy(St, 1, 1) = ' ') DO
  469.       St := Copy(St, 2, 255);
  470.    WHILE (Copy(St, Length(St), 1) = ' ') DO
  471.       St := Copy(St, 1, Length(St) - 1);
  472.    FOR tmp := 1 TO Length(St) DO BEGIN
  473.       ch := ORD(St[tmp]);
  474.       IF ((ch >= 48) AND (ch <= 57)) THEN St[tmp] := CHR(ch - 48);
  475.    END;
  476.    IF (Copy(St, 1, 1) = '-') THEN BEGIN
  477.       Sign := '-';
  478.       St := Copy(St, 2, 255);
  479.    END
  480.    ELSE
  481.       Sign := ' ';
  482.    tmp := Pos('.', St);
  483.    IF (tmp > 0) THEN BEGIN
  484.       L := Copy(St, 1, tmp - 1);
  485.       R := Copy(St, tmp + 1, 255);
  486.    END
  487.    ELSE BEGIN
  488.       L := St;
  489.       R := '';
  490.    END;
  491.    L := NullDupe(LeftD) + L;
  492.    L := Copy(L, Length(L) - LeftD + 1, LeftD);
  493.    R := Copy(R + NullDupe(RightD), 1, RightD);
  494.    BCDSet := Sign + L + R;
  495. END;
  496.  
  497.  
  498.  
  499. { sine }
  500. FUNCTION BCDSin (Nr: String): String;
  501. VAR
  502.    St, Result, One, Two, I, X2: String;
  503. BEGIN
  504.    St := Nr;
  505.    Result := Nr;
  506.    One := BCDSet('1');
  507.    Two := BCDSet('2');
  508.    I := BCDSet('3');
  509.    X2 := BCDMul(Nr, Nr);
  510.    WHILE (BCDSgn(St) <> 0) DO BEGIN
  511.       St := BCDNeg(BCDDiv(BCDMul(St, X2), BCDMul(I, BCDSub(I, One))));
  512.       Result := BCDAdd(Result, St);
  513.       I := BCDAdd(I, Two);
  514.    END;
  515.    BCDSin := Result;
  516. END;
  517.  
  518.  
  519.  
  520. { square root }
  521. FUNCTION BCDSqrt (Nr: String): String;
  522. VAR
  523.    Two, Est1, Est2: String;
  524. BEGIN
  525.    IF (Copy(Nr, 1, 1) = '-') THEN
  526.       BCDSqrt := ''
  527.    ELSE BEGIN
  528.       Two := BCDSet('2');
  529.       Est2 := BCDDiv(Nr, Two);
  530.       REPEAT
  531.          Est1 := Est2;
  532.          Est2 := BCDDiv(BCDAdd(Est1, BCDDiv(Nr, Est1)), Two);
  533.       UNTIL (BCDCompare(Est1, Est2) = 0);
  534.       BCDSqrt := Est2;
  535.    END;
  536. END;
  537.  
  538.  
  539.  
  540. { subtraction }
  541. FUNCTION BCDSub (Nr1, Nr2: String): String;
  542. VAR
  543.    Sign1, Sign2, N1, N2: String;
  544. BEGIN
  545.    Sign1 := Copy(Nr1, 1, 1);
  546.    Sign2 := Copy(Nr2, 1, 1);
  547.    N1 := Copy(Nr1, 2, 255);
  548.    N2 := Copy(Nr2, 2, 255);
  549.    IF (Sign1 = Sign2) THEN BEGIN
  550.       BCDAdd1(N1, Complement(N2));
  551.       IF (ORD(N1[1]) = 9) THEN
  552.          IF (Sign1 = '-') THEN
  553.             N1 := ' ' + Complement(N1)
  554.          ELSE
  555.             N1 := '-' + Complement(N1)
  556.       ELSE
  557.          N1 := Sign1 + N1;
  558.       BCDSub := N1;
  559.    END
  560.    ELSE BEGIN
  561.       BCDAdd1(N1, N2);
  562.       BCDSub := Sign1 + N1;
  563.    END;
  564. END;
  565.  
  566.  
  567.  
  568. { tangent }
  569. FUNCTION BCDTan (Nr: String): String;
  570. BEGIN
  571.    BCDTan := BCDDiv(BCDSin(Nr), BCDCos(Nr));
  572. END;
  573.  
  574.  
  575.  
  576. { ----------------------- initialization code --------------------------- }
  577. BEGIN
  578.    LeftD := 20;          { digits to the left of the decimal }
  579.    RightD := 11;         { digits to the right of the decimal }
  580. END.
  581.