home *** CD-ROM | disk | FTP | other *** search
/ Simtel MSDOS 1992 December / simtel1292_SIMTEL_1292_Walnut_Creek.iso / msdos / pcmag / vol6n20.arc / PROFIL.ARC / CALCPRF.PAS < prev    next >
Pascal/Delphi Source File  |  1986-12-14  |  13KB  |  439 lines
  1. PROGRAM big_calculator;
  2.   (* ================================================================= *)
  3.   (* copyright 1985 by Neil J. Rubenking                               *)
  4.   (* This program does simple arithmetic on numbers of up to 254 digits*)
  5.   (* It was inspired by the BASIC program for the same purpose in the  *)
  6.   (* March 1985 BYTE magazine.  It could certainly be faster, but it   *)
  7.   (* just as certainly WORKS.  Compile to a .COM file and call from    *)
  8.   (* the command line, e.g.                                            *)
  9.   (*   CALC 123456789 * 987654321                                      *)
  10.   (*   CALC 19823746897698 / 872471234                                 *)
  11.   (*   CALC 50 ! {this takes a while!}                                 *)
  12.   (* ================================================================= *)
  13.  
  14. TYPE
  15.   numStr = STRING[255];
  16.   charset = SET OF Char;
  17. VAR
  18.   op, opRand, result, rem : NumStr;
  19.   operation : Char;
  20.  
  21.   FUNCTION RevString(A : numStr) : numStr;
  22.   VAR
  23.     N,L : Byte;
  24.   BEGIN
  25.     L := Length(A) + 1;
  26.     FOR N := 1 to (L DIV 2) DO
  27.       BEGIN
  28.         RevString[N] := A[L-N];
  29.         RevString[L-N] := A[N];
  30.       END;
  31.     RevString[0] := chr(L-1);
  32.   END;
  33.  
  34.   PROCEDURE SwapStr(VAR A, B : numStr);
  35.   VAR
  36.     T : numStr;
  37.   BEGIN
  38.     T := A; A := B; B := T;
  39.   END;
  40.  
  41.   PROCEDURE LCut(VAR S : numStr; Ch : Char);
  42.     { PURPOSE : Remove all LEADING occurrences of character CH from word S}
  43.   VAR P : Byte;
  44.   BEGIN
  45.     P := 0;
  46.     WHILE S[P+1] = Ch DO P := P+1;
  47.     IF P > 0 THEN Delete(S, 1, P);
  48.   END;
  49.  
  50.   PROCEDURE RPad(VAR S : numStr; Ch : Char);
  51.     { PURPOSE : Pad word S out to its maximum length with character CH }
  52.   BEGIN
  53.     FillChar(S[Length(S)+1], 255-Length(S), Ch);
  54.     S[0] := Chr(255);
  55.   END;
  56.  
  57.   FUNCTION SubChar(C1, C2 : Char; VAR borrow : Boolean) : Char;
  58.     { PURPOSE : Subtract one numeric character from another, set "borrow" to
  59.     true if borrowing was necessary. }
  60.   VAR
  61.     temp : Integer;
  62.   BEGIN
  63.     temp := Ord(C1)-Ord(C2);
  64.     borrow := temp < 0;
  65.     temp := (temp+20) MOD 10;
  66.     SubChar := Chr(temp+48);
  67.   END;
  68.  
  69.   FUNCTION AddChar(C1, C2 : Char; VAR carry : Boolean) : Char;
  70.     { PURPOSE : Add one numeric character to another, set "carry" to true
  71.     as appropriate.}
  72.   VAR
  73.     temp : Byte;
  74.   BEGIN
  75.     temp := Ord(C1)+Ord(C2)-96;
  76.     carry := temp >= 10;
  77.     temp := temp MOD 10;
  78.     AddChar := Chr(temp+48);
  79.   END;
  80.  
  81.   PROCEDURE RTrim(VAR S : numStr; CH : Char);
  82.     { PURPOSE : Trim off all TRAILING occurrences of character CH from word S.}
  83.   VAR P : Byte;
  84.   BEGIN
  85.     P := Length(S);
  86.     WHILE S[P] = Ch DO P := P-1;
  87.     S[0] := Chr(P);
  88.   END;
  89.  
  90.   PROCEDURE fWrite(VAR WW : numStr);
  91.     { PURPOSE : Write formatted numeric string -- commas every three places. }
  92.   VAR
  93.     posn : Byte;
  94.   BEGIN
  95.     LCut(WW, '0');
  96.     IF Length(WW) > 3 THEN
  97.       BEGIN
  98.         posn := ((Length(WW)-1) MOD 3)+1;
  99.         Write(Copy(WW, 1, posn), ',');
  100.         posn := posn+1;
  101.         WHILE posn <= Length(WW) DO
  102.           BEGIN
  103.             Write(Copy(WW, posn, 3));
  104.             IF posn+3 < Length(WW) THEN Write(',');
  105.             posn := posn+3;
  106.           END;
  107.       END
  108.     ELSE
  109.       Write(WW);
  110.   END;
  111.  
  112.   FUNCTION comp(VAR X, Y : numStr) : Char;
  113.     { PURPOSE : Compare X and Y, return "<" if X is less, ">" if greater, or
  114.     "=" if they are equal. }
  115.   BEGIN
  116.     LCut(X, '0');             { cut off any leading zeroes }
  117.     LCut(Y, '0');
  118.     IF Length(X) = Length(Y) THEN
  119.       BEGIN
  120.         IF X = Y THEN
  121.           comp := '='
  122.         ELSE
  123.           IF X > Y THEN comp := '>'
  124.           ELSE comp := '<'
  125.       END
  126.     ELSE
  127.       BEGIN
  128.         IF Length(X) > Length(Y) THEN comp := '>'
  129.         ELSE comp := '<'
  130.       END;
  131.   END;
  132.  
  133.   FUNCTION add(A, B : numStr) : numStr;
  134.     { PURPOSE : Returns the sum of A and B.  It reverses both strings and
  135.     adds the characters from start to finish, then reverses
  136.     the result.}
  137.   VAR
  138.     T : numStr;
  139.     posn : Byte;
  140.     carry : Boolean;
  141.   BEGIN
  142.     IF (Length(A) < 254) AND (Length(B) < 254) THEN
  143.       BEGIN
  144.         carry := False;
  145.         T := '';
  146.         RPad(T, ' ');
  147.         A := RevString(A);
  148.         B := RevString(B);
  149.         posn := 0;
  150.         WHILE (posn < Length(A)) AND (posn < Length(B)) DO
  151.           BEGIN
  152.             posn := posn+1;
  153.             IF carry THEN
  154.               T[posn] := AddChar(Succ(A[posn]), B[posn], carry)
  155.             ELSE T[posn] := AddChar(A[posn], B[posn], carry);
  156.           END;
  157.         IF posn < Length(A) THEN
  158.           WHILE posn < Length(A) DO
  159.             BEGIN
  160.               posn := posn+1;
  161.               IF carry THEN
  162.                 T[posn] := AddChar(Succ(A[posn]), '0', carry)
  163.               ELSE T[posn] := AddChar(A[posn], '0', carry)
  164.             END;
  165.         IF posn < Length(B) THEN
  166.           WHILE posn < Length(B) DO
  167.             BEGIN
  168.               posn := posn+1;
  169.               IF carry THEN
  170.                 T[posn] := AddChar(Succ(B[posn]), '0', carry)
  171.               ELSE T[posn] := AddChar(B[posn], '0', carry)
  172.             END;
  173.         IF carry THEN T[posn+1] := '1';
  174.         RTrim(T, ' ');
  175.         add := RevString(T);
  176.       END
  177.     ELSE
  178.       add := #7+'Operands must be 254 characters or less.';
  179.   END;
  180.  
  181.   FUNCTION sub(A, B : numStr) : numStr;
  182.     { PURPOSE : Subtract B from A.  Similar in action to "add" above.}
  183.   VAR
  184.     T : numStr;
  185.     posn : Byte;
  186.     borrow, minus : Boolean;
  187.   BEGIN
  188.     IF (Length(A) < 254) AND (Length(B) < 254) THEN
  189.       BEGIN
  190.         borrow := False;
  191.         minus := False;
  192.         IF comp(A, B) = '<' THEN
  193.           BEGIN
  194.             minus := True;
  195.             SwapStr(A, B);
  196.           END;
  197.         A := RevString(A);
  198.         B := RevString(B);
  199.         T := '';
  200.         RPad(T, ' ');
  201.         posn := 0;
  202.         WHILE (posn < Length(A)) AND (posn < Length(B)) DO
  203.           BEGIN
  204.             posn := posn+1;
  205.             IF borrow THEN
  206.               T[posn] := subChar(Pred(A[posn]), B[posn], borrow)
  207.             ELSE T[posn] := subChar(A[posn], B[posn], borrow);
  208.           END;
  209.         IF posn < Length(A) THEN
  210.           WHILE posn < Length(A) DO
  211.             BEGIN
  212.               posn := posn+1;
  213.               IF borrow THEN
  214.                 T[posn] := subChar(Pred(A[posn]), '0', borrow)
  215.               ELSE T[posn] := subChar(A[posn], '0', borrow);
  216.             END;
  217.         RTrim(T, ' ');
  218.         IF minus THEN T := T+'-';
  219.         sub := RevString(T);
  220.       END
  221.     ELSE
  222.       sub := #7+'Operands must be 254 characters or less.';
  223.   END;
  224.  
  225.   FUNCTION prod(A, B : numStr) : NumStr;
  226.     { PURPOSE : Returns the product of A and B.  It first selects the smaller of
  227.     the two as a multiplier and then finds the product by repeated
  228.     addition.  No, it doesn't repeat 12,345 times to multiply by
  229.     12,345 -- it does each digit and tacks on zeroes as needed.}
  230.   VAR
  231.     T1, T2 : numStr;
  232.     posn, times, N : Byte;
  233.   BEGIN
  234.     IF (Length(A)+Length(B)) < 254 THEN
  235.       BEGIN
  236.         IF comp(A, B) = '<' THEN
  237.           SwapStr(A, B);
  238.         B := RevString(B);
  239.         T2 := '0';
  240.         FOR posn := 1 TO Length(B) DO
  241.           BEGIN
  242.             times := Ord(B[posn])-48;
  243.             CASE times OF
  244.               0 : T1 := '0';
  245.               1 : T1 := A;
  246.             ELSE
  247.               T1 := A;
  248.               FOR N := 2 TO times DO
  249.                 T1 := add(T1, A);
  250.             END;
  251.             IF posn > 1 THEN
  252.               FOR N := 2 TO posn DO
  253.                 T1 := T1+'0';
  254.             T2 := add(T2, T1);
  255.           END;
  256.         prod := T2;
  257.       END
  258.     ELSE
  259.       prod := #7+'Overflow -- operand lengths must total 254 or less.';
  260.   END;
  261.  
  262.   FUNCTION fact(VAR A : numStr) : numStr;
  263.     { PURPOSE : Returns A factorial.  Note that this is NOT a lovely recursive
  264.     function -- you can fill the entire stack space of the computer
  265.     with copies of a recursive function when the numbers get big.}
  266.   VAR
  267.     T1, T2 : numStr;
  268.   BEGIN
  269.     T1 := '1';
  270.     T2 := '1';
  271.     IF (A <> '1') AND (A <> '0') THEN
  272.       WHILE T2 <> A DO
  273.         BEGIN
  274.           T2 := add(T2, '1');
  275.           T1 := prod(T1, T2);
  276.         END;
  277.     fact := T1;
  278.   END;
  279.  
  280.   FUNCTION divide(A, B : numStr; VAR remainder : numStr) : numStr;
  281.     { PURPOSE : Returns the quotient of A / B -- also the remainder.
  282.     Uses repeated subtraction}
  283.   VAR
  284.     T1, T2, T3 : numStr;
  285.   BEGIN
  286.     IF comp(A, B) = '=' THEN
  287.       BEGIN
  288.         divide := '1';
  289.         remainder := '0';
  290.       END
  291.     ELSE
  292.       BEGIN
  293.         T1 := B; T2 := '1'; T3 := '0';
  294.         WHILE comp(A, T1) = '>' DO
  295.           BEGIN
  296.             T1 := T1+'0';
  297.             T2 := T2+'0';
  298.           END;
  299.         WHILE NOT(comp(T1, B) = '=') DO
  300.           BEGIN
  301.             T1[0] := Pred(T1[0]);
  302.             T2[0] := Pred(T2[0]);
  303.             WHILE NOT(comp(A, T1) = '<') DO
  304.               BEGIN
  305.                 A := sub(A, T1);
  306.                 T3 := add(T3, T2);
  307.               END;
  308.           END;
  309.         divide := T3;
  310.         remainder := A;
  311.       END;
  312.   END;
  313.  
  314.  
  315.   FUNCTION AllNums(VAR A : numStr) : Boolean;
  316.     { PURPOSE : Returns true IFF a string is all numbers  }
  317.   VAR
  318.     N : Byte;
  319.     temp : Boolean;
  320.   BEGIN
  321.     temp := True;
  322.     N := 1;
  323.     WHILE (N <= Length(A)) AND Temp DO
  324.       BEGIN
  325.         IF NOT(A[N] IN ['0'..'9']) THEN temp := False;
  326.         N := N+1;
  327.       END;
  328.     AllNums := temp;
  329.   END;
  330.  
  331.  
  332.   FUNCTION GotParams : Boolean;
  333.     { PURPOSE : Returns true if parameters are correctly passed on the command
  334.     line -- and assigns them to the correct variables if so.}
  335.   VAR
  336.     temp : Boolean;
  337.   BEGIN
  338.     IF ParamCount > 1 THEN
  339.       BEGIN
  340.         op := ParamStr(1);
  341.         IF AllNums(op) THEN
  342.           BEGIN
  343.             operation := ParamStr(2);
  344.             operation := UpCase(operation);
  345.             IF operation IN ['+', '-', '*', '/', '!'] THEN
  346.               BEGIN
  347.                 IF operation <> '!' THEN
  348.                   BEGIN
  349.                     IF ParamCount > 2 THEN
  350.                       BEGIN
  351.                         opRand := ParamStr(3);
  352.                         IF AllNums(opRand) THEN temp := True
  353.                         ELSE
  354.                           BEGIN
  355.                             temp := False;
  356.                             WriteLn(opRand, ' is not all numeric.');
  357.                           END;
  358.                       END
  359.                     ELSE
  360.                       BEGIN
  361.                         temp := False;
  362.                         WriteLn(op, ' ', operation, ' what?');
  363.                       END;
  364.                   END
  365.                 ELSE
  366.                   temp := True;
  367.               END
  368.             ELSE
  369.               BEGIN
  370.                 temp := False;
  371.                 Write('Operations are +, -, *, /  and !');
  372.               END;
  373.           END
  374.         ELSE
  375.           BEGIN
  376.             temp := False;
  377.             WriteLn(op, ' is not all numeric.');
  378.           END;
  379.       END
  380.     ELSE
  381.       BEGIN
  382.         temp := False;
  383.         WriteLn('Enter "CALC ## op ##", where op is +,-,*,/ or !')
  384.       END;
  385.     GotParams := temp;
  386.   END;
  387.  
  388. procedure Calculate ; { This line added for use with profiler }
  389. BEGIN
  390.   IF GotParams THEN
  391.     BEGIN
  392.       CASE operation OF
  393.         '+' : BEGIN
  394.                 Write('       SUM: '); Flush(output);
  395.                 result := add(op, opRand);
  396.                 FWrite(result);
  397.               END;
  398.         '-' : BEGIN
  399.                 Write('DIFFERENCE: '); Flush(output);
  400.                 result := sub(op, opRand);
  401.                 FWrite(result);
  402.               END;
  403.         '*' : BEGIN
  404.                 Write('   PRODUCT: '); Flush(output);
  405.                 result := prod(op, opRand);
  406.                 FWrite(result);
  407.               END;
  408.         '/' : BEGIN
  409.                 Write(' QUOTIENT: '); Flush(output);
  410.                 result := divide(op, opRand, rem);
  411.                 FWrite(result);
  412.                 WriteLn;
  413.                 Write('REMAINDER: ');
  414.                 FWrite(rem);
  415.               END;
  416.         '!' : BEGIN
  417.                 Write(' FACTORIAL: '); Flush(output);
  418.                 result := fact(op);
  419.                 FWrite(result);
  420.               END;
  421.       END;
  422.     END;
  423. END;
  424.  
  425. { Everything from here to end added for use by profiler }
  426.  
  427. procedure dummy ;
  428. begin
  429. end;
  430.  
  431. {$I profile.inc}
  432.  
  433. begin
  434.   PRF_Init( CSeg, Ofs(RevString), Ofs(dummy) ) ;
  435.   PRF_Start ;
  436.   Calculate ;
  437.   PRF_Stop ;
  438. end.
  439.