home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / TOOL_INC.ZIP / RPNCALC.INC < prev    next >
Encoding:
Text File  |  1988-01-29  |  4.7 KB  |  181 lines
  1.  
  2. (*
  3.  * MISC_rpn_calc - post-fix calculator
  4.  *
  5.  * This is a utility library to implement a simple post-fix (rpn)
  6.  * calculator that can be used when runtime defined calculations
  7.  * need to be made.
  8.  *
  9.  *)
  10.  
  11. function MISC_rpn_calc (initial_value:      real;
  12.                         formula:            anystring): real;
  13.                            {apply RPN calculator to formula with initial_value
  14.                              on top of stack. returns final top of stack}
  15.  
  16. const
  17.    stack_limit =       10;    {maximum stack depth}
  18.  
  19.  
  20. var
  21.    stack:              array [1.. stack_limit] of real;
  22.    top:                integer;
  23.    word:               anystring;
  24.    c:                  char;
  25.    i:                  integer;
  26.    code:               integer;
  27.    v1,
  28.    v2:                 real;
  29.  
  30.  
  31.    procedure push (v:                  real);
  32.                               {push v on top of the stack}
  33.    begin
  34.       top := top + 1;
  35.  
  36.       if top > stack_limit then
  37.       begin
  38.          MISC_fatal_error('RPN Stack overflow, formula: ' + formula);
  39.          top := top -1;
  40.       end;
  41.  
  42.       stack[top]:= v;
  43.    end;
  44.  
  45.  
  46.    function pop: real;        {pop a value off the top of stack}
  47.    begin
  48.  
  49.       if top < 1 then
  50.       begin
  51.          MISC_fatal_error('RPN Stack underflow, formula: ' + formula);
  52.          top := top + 1;
  53.       end;
  54.  
  55.       pop := stack [top];
  56.       top := top - 1;
  57.    end;
  58.  
  59.    function scannum(word: anystring; radix: integer): real;
  60.    var
  61.       i:  integer;
  62.       n:  real;
  63.       d:  integer;
  64.  
  65.    begin
  66.       n := 0.0;
  67.       for i := 2 to length(word) do
  68.       begin
  69.          d := ord(upcase(word[i])) - ord('0');
  70.          if d > 9 then
  71.             d := d - 7;
  72.          n := n * int(radix) + int(d);
  73.       end;
  74.  
  75.       scannum := n;
  76.    end;
  77.  
  78.    function binval(word: anystring): real;
  79.    begin
  80.       binval := scannum(word,2);
  81.    end;
  82.  
  83.    function hexval(word: anystring): real;
  84.    begin
  85.       hexval := scannum(word,16);
  86.    end;
  87.  
  88.    function tan(r: real): real;
  89.    begin
  90.       tan := sin(r) / cos(r);
  91.    end;
  92.  
  93. begin                         {MISC_rpn_calc}
  94.  
  95.    top := 0;
  96.    push(initial_value);
  97.    word := '';
  98.  
  99.    for i := 1 to length (formula) do
  100.                               {scan the formula string}
  101.    begin
  102.       c := formula [i];
  103.  
  104.       if c <> ' ' then
  105.          word := word + upcase(c);
  106.  
  107.       if (c = ' ') or (i = length (formula)) then
  108.                                  {if at the end of a word or at the end
  109.                                    of the formula}
  110.       begin
  111.  
  112.          case word [1] of       {check for and process each operator}
  113.  
  114.             '+':  push(pop + pop);
  115.  
  116.             '*':  push(pop * pop);
  117.  
  118.             '-':  begin
  119.                      if (length(word) > 1) and (word[2] in ['0'..'9']) then
  120.                      begin
  121.                         val(word, v1, code);
  122.                         push(v1);
  123.                      end
  124.                      else
  125.                      begin
  126.                         v1 := pop;
  127.                         v2 := pop;
  128.                         push(v2 - v1);
  129.                      end;
  130.                   end;
  131.  
  132.             '/':  begin
  133.                      v1 := pop;
  134.                      v2 := pop;
  135.                      push(v2 / v1);
  136.                   end;
  137.  
  138.             '\':  begin
  139.                      v1 := pop;
  140.                      if v1 <> 0.0 then
  141.                         push(1.0 / v1)
  142.                      else
  143.                         push(0.0);
  144.                   end;
  145.  
  146.             'H':  push(hexval(word));
  147.  
  148.             'B':  push(binval(word));
  149.  
  150.             '.','0'..'9':              {numbers are pushed on the stack}
  151.                   begin
  152.                      val(word, v1, code);
  153.                      push(v1);
  154.                   end;
  155.  
  156.             else
  157.                if word = 'PI'   then push(pi)        else
  158.                if word = 'SIN'  then push(sin(pop))  else
  159.                if word = 'COS'  then push(cos(pop))  else
  160.                if word = 'TAN'  then push(tan(pop))  else
  161.                if word = 'EXP'  then push(exp(pop))  else
  162.                if word = 'INT'  then push(int(pop))  else
  163.                if word = 'SQRT' then push(sqrt(pop)) else
  164.                if word = 'LN'   then push(ln(pop))   else
  165.                if word = 'E'    then push(exp(1.0))
  166.                else
  167.                   MISC_fatal_error('Unknown RPN word: ' + word +
  168.                                    ' in formula: ' + formula);
  169.          end;
  170.  
  171.          word := '';                {consume the word and scan for more
  172.                                       words}
  173.  
  174.       end;
  175.    end;
  176.  
  177.    MISC_rpn_calc := pop;
  178.  
  179. end;                       {MISC_rpn_calc}
  180.  
  181.