home *** CD-ROM | disk | FTP | other *** search
/ Simtel MSDOS - Coast to Coast / simteldosarchivecoasttocoast2.iso / calculat / doit.zip / DO_EVAL.PAS next >
Pascal/Delphi Source File  |  1989-09-24  |  9KB  |  255 lines

  1. { $ DEFINE DEBUG}
  2. Unit Do_eval;
  3.  
  4. (*
  5. ┌───────────────────────────────────────────────────────────────────────────┐
  6. │                         Unidad DO_EVAL.PAS                                │
  7. ├───────────────────────────────────────────────────────────────────────────┤
  8. │   Versión             : 1.0                                               │
  9. │   Computadora         : IBM-PC o compatible                               │
  10. │   Lenguaje            : Turbo Pascal 5.5                                  │
  11. │   Autor               : Bernardo Zamora Etcharren                         │
  12. ├──────────────────┬────────────────────────────────────────────────────────┤
  13. │   Explanation :  │                                                        │
  14. ├──────────────────┘                                                        │
  15. │   This unit evaluates a function already converted to RPN.                │
  16. │                                                                           │
  17. │                                                                           │
  18. └───────────────────────────────────────────────────────────────────────────┘
  19. *)
  20.  
  21. INTERFACE
  22.  
  23.  
  24. Uses
  25.   do_type;
  26.  
  27.  
  28. Function evalua_polaca(var rpn : rpn_type; valor : real):real;
  29.  
  30.  
  31. IMPLEMENTATION
  32.  
  33.  
  34. uses
  35.   do_mate;
  36.  
  37. var
  38.   i        : integer;
  39.   stack    : array[1..100] of real;
  40.   stk      : integer;    { stack counter                                 }
  41.   aux,aux2 : real;
  42.   auxtxt   : string;     { for the messages generated by the operation   }
  43.   nodo     : do_element;
  44.  
  45.  
  46. Function evalua_polaca(var rpn : rpn_type; valor : real):real;
  47.  
  48.  
  49. Procedure do_Error(num:integer; ss:string);
  50. { updates error value and error string }
  51. begin
  52.   rpn.message := ss;
  53.   rpn.error := num;
  54. end;
  55.  
  56.  
  57. Function Pop : real;
  58. begin
  59.   pop:=stack[stk];
  60.   dec(stk);
  61. end;
  62.  
  63.  
  64. Procedure Push(x:real);
  65. begin
  66.   inc(stk);
  67.   stack[stk]:=x;
  68. end;
  69.  
  70.  
  71.  
  72. { MAIN evalua_polaca }
  73. begin
  74.   with RPN do begin
  75.     error := 0;  message := '';  { zero initial conditions }
  76.     stk:=0;
  77.     evalua_polaca:=0;
  78.     {$IFDEF DEBUG}
  79.     writeln;
  80.     {$ENDIF}
  81.     for i:=1 to p1 do begin
  82.       {$IFDEF DEBUG}
  83.       writeln('A ver que hago con un ',s1[i].tipo);
  84.       {$ENDIF}
  85.       case s1[i].tipo of
  86.       'P':{parentesis}
  87.            {$IFDEF DEBUG}
  88.            writeln('ERROR, check EVALUATE unit.') { thsi SHOULDN'T happen!! }
  89.            {$ENDIF}
  90.            ;
  91.       'U':{operacion unaria}
  92.            begin
  93.              if      s1[i].operacion = 'SIN' then
  94.                push(sin(pop))
  95.              else if s1[i].operacion = 'COS' then
  96.                push(cos(pop))
  97.              else if s1[i].operacion = 'TAN' then begin
  98.                aux:=pop;
  99.                if abs(aux)<>pi then push(tan(aux))
  100.                else do_error(ERROR_TANGENTE,ERROR_TANGENTE_S);
  101.              end else if s1[i].operacion = 'COT' then begin
  102.                aux:=tan(pop);
  103.                if aux<>0 then push(1/aux)
  104.                else do_error(ERROR_COTANGENTE,ERROR_COTANGENTE_S);
  105.              end else if s1[i].operacion = 'SEC' then begin
  106.                aux:=cos(pop);
  107.                if aux<>0 then push(1/aux)
  108.                else do_error(ERROR_SECANTE,ERROR_SECANTE_S);
  109.              end else if s1[i].operacion = 'CSC' then begin
  110.                aux:=sin(pop);
  111.                if aux<>0 then push(1/aux)
  112.                else do_error(ERROR_COSECANTE,ERROR_COSECANTE_S);
  113.              end
  114.  
  115.              else if s1[i].operacion = 'LN' then begin
  116.                aux:=pop;
  117.                if aux>0.001 then push(ln(aux))
  118.                else do_error(ERROR_LN,ERROR_LN_S);
  119.              end else if s1[i].operacion = 'LOG' then begin
  120.                aux:=pop;
  121.                if aux>0 then push(log(aux))
  122.                else do_error(ERROR_LOG,ERROR_LOG_S);
  123.              end
  124.  
  125.              else if s1[i].operacion = 'FRAC' then
  126.                push(frac(pop))
  127.              else if s1[i].operacion = 'INT' then
  128.                push(int(pop)) { why not using trunc ?? don't know!! }
  129.              else if s1[i].operacion = 'ABS' then
  130.                push(abs(pop))
  131.              else if s1[i].operacion = 'ROUND' then
  132.                push(round(pop))
  133.              else if s1[i].operacion = 'SGN' then
  134.                push(sgn(pop))
  135.  
  136.              else if s1[i].operacion = 'SQRT' then begin
  137.                aux:=pop;
  138.                if aux>=0 then push(sqrt(aux))
  139.                else do_error(ERROR_SQRT,ERROR_SQRT_S);
  140.              end
  141.  
  142.              else if s1[i].operacion = 'ASIN' then begin
  143.                aux:=pop;
  144.                aux:=-aux*aux+1;
  145.                if aux>0 then { strictly greater }
  146.                  push( arctan (aux / (sqrt(aux)) ) )
  147.                else do_error(ERROR_SIN_INV,ERROR_SIN_INV_S);
  148.              end else if s1[i].operacion = 'ACOS' then begin
  149.                aux:=pop;
  150.                aux:=-aux*aux+1;
  151.                if aux>0 then { strictly greater }
  152.                  push(arctan ( aux / (sqrt(aux)) + 1.5708))
  153.                else do_error(ERROR_COS_INV,ERROR_COS_INV_S);
  154.              end else if s1[i].operacion = 'ATAN' then
  155.                push(arctan(pop))
  156.              else if s1[i].operacion = 'ACOT' then begin
  157.                aux:=pop;
  158.                push(arctan(aux)+1.5708)
  159.              end else if s1[i].operacion = 'ASEC' then begin
  160.                aux:=pop;
  161.                aux2:=aux*aux-1;
  162.                if aux2>0 then { strictly greater }
  163.                  push( arctan( aux / sqrt (aux2) ) + sgn(sgn(aux)-1) * 1.5708)
  164.                else do_error(ERROR_SEC_INV,ERROR_SEC_INV_S);
  165.              end else if s1[i].operacion = 'ACSC' then begin
  166.                aux:=pop;
  167.                aux2:=aux*aux-1;
  168.                if aux2>0 then { strictly greater }
  169.                  push(arctan(aux/sqrt(aux2))+(sgn(aux)-1)*1.5708)
  170.                else do_error(ERROR_CSC_INV,ERROR_CSC_INV_S);
  171.              end
  172.  
  173.              else if s1[i].operacion = 'SINH' then begin
  174.                aux:=pop;
  175.                push( (exp(aux)-exp(-aux))/2 )
  176.              end else if s1[i].operacion = 'COSH' then begin
  177.                aux:=pop;
  178.                push( (exp(aux)+exp(-aux))/2 )
  179.              end else if s1[i].operacion = 'TANH' then begin
  180.                aux:=pop;
  181.                aux2:=exp(aux)+exp(-aux);
  182.                if aux2<>0 then
  183.                  push( (exp(aux)-exp(-aux))/aux2)
  184.                else do_error(ERROR_TAN_HIP,ERROR_TAN_HIP_S);
  185.              end else if s1[i].operacion = 'COTH' then begin
  186.                aux:=pop;
  187.                aux2:=exp(aux)-exp(-aux);
  188.                if aux2<>0 then
  189.                  push((exp(aux)+exp(-aux))/aux2)
  190.                else do_error(ERROR_COT_HIP,ERROR_COT_HIP_S);
  191.              end else if s1[i].operacion = 'SECH' then begin
  192.                aux:=pop;
  193.                aux:=exp(aux) + exp(-aux);
  194.                if aux<>0 then
  195.                  push(2/aux)
  196.                else do_error(ERROR_SEC_HIP,ERROR_SEC_HIP_S);
  197.              end else if s1[i].operacion = 'CSCH' then begin
  198.                aux:=pop;
  199.                aux:=exp(aux) - exp(-aux);
  200.                if aux<>0 then
  201.                  push(2/aux)
  202.                else do_error(ERROR_CSC_HIP,ERROR_CSC_HIP_S);
  203.              end
  204.  
  205.              else if s1[i].operacion = 'GRADOS' then
  206.                push(grados(pop))
  207.              else if s1[i].operacion = 'RAD' then
  208.                push(rad(pop))
  209.  
  210.              else if s1[i].operacion = '-' then
  211.                push(-(pop))
  212.              else if s1[i].operacion = 'EXP' then
  213.                push(exp(pop))
  214.  
  215.            end; { 'U - unary operation }
  216.       'O':{binary operation}
  217.             case s1[i].operacion[1] of
  218.             '+': push (pop + pop);
  219.             '-': begin
  220.                    aux := -pop;
  221.                    push (aux + pop);
  222.                  end;
  223.             '*': push (pop * pop);
  224.             '/': begin aux:=pop;
  225.                    if aux<>0 then
  226.                      push ( (1/aux) * pop)
  227.                    else do_error(ERROR_X_ENTRE_0,ERROR_X_ENTRE_0_S);
  228.                  end;
  229.             '^': begin
  230.                    aux:=pop; { The exponent }
  231.                    if abs(aux)=int(aux) then { Exponent positive integer }
  232.                      push ( ALAI(pop,trunc(aux)) )
  233.                    else begin { Exponent fraccionary or negative }
  234.                      aux2:=pop; { The base }
  235.                      if aux2>0 then
  236.                        push(ALA(aux2,aux))
  237.                      else do_error(ERROR_EXP_Y_BASE_NEG,ERROR_EXP_Y_BASE_NEG_S);
  238.                    end;
  239.                  end;
  240.             end;
  241.       'N':{constant number}
  242.            push(s1[i].numero);
  243.       'V':{variable that is to be substituted}
  244.            push(valor);
  245.       end; {case}
  246.     end;
  247.     aux:=pop;
  248.     if error=0 then evalua_polaca := aux;
  249.     { This last line if_not_error is VITAL 'cause if not present it makes
  250.       a POP of garbage.. discovered trying y=sqrt(1-x) }
  251.   end; { with rpn do }
  252. end;
  253.  
  254. begin
  255. end.