Simtel MSDOS - Coast to Coast/simteldosarchivecoasttocoast2.iso/calculat/doit.zip/DO_RPN.PAS

Pascal/Delphi Source File | 1989-09-24 | 16KB | 531 lines

{ $ DEFINE DEBUG}

Unit do_rpn;

(*
┌───────────────────────────────────────────────────────────────────────────┐
│                          Unidad DO_RPN.PAS                                │
├───────────────────────────────────────────────────────────────────────────┤
│   Versión             : 1.0                                               │
│   Computadora         : IBM-PC o compatible                               │
│   Lenguaje            : Turbo Pascal 5.5                                  │
│   Autor               : Bernardo Zamora Etcharren                         │
├──────────────────┬────────────────────────────────────────────────────────┤
│   Explanation :  │                                                        │
├──────────────────┘                                                        │
│   Unit that converts a string (fun_string) to its equivalente in rpn...   │
│   (rpn_string). It also uses the stack reserved for that purpose (s1),    │
│    with its associated pointer P1.                                        │
│                                                                           │
│    First, in stack 1 it puts the numbers, in the second the operations    │
│    and then it performs the conversion, leaving the result in stack 1.    │
│    operacion!!!.                                                          │
│                                                                           │
│    We need to check operation 3(3), we need to notice that when we finish │
│    and we check the stack!!                                               │
│                                                                           │
│   Also check user typing 'XX' as part of the function, the program        │
│    takes it as a lone 'X'.                                                │
│                                                                           │
│  IMPORTANT : we should substitute all nodes 'U', and '-' (meaning the     │
│  internal representation of unary minus [change-sign]) to the real        │
│  representation of CHS, propably #241 = '±' !!! (what do you think!!)     │
│                                                                           │
│                                                                           │
└───────────────────────────────────────────────────────────────────────────┘
*)


INTERFACE

Uses
  do_type;

Procedure convierte_a_polaca (var rpn: rpn_type);


IMPLEMENTATION

const
  CHANGE_SIGN = '±';   { symbol for change-sign operation }

var
  operaciones_simples : set of char; {*,+,-,/, son BINARIAS}
  numeros,
  operaciones,               { letters that make up the op_codes (unary)    }
  variables,                 { variable chars accepted (x,p,e..)            }
  parentesis    : set of char;

  auxstring,                 { auxiliary string for conversion              }
  sig_arg       : string;    { next word belonging to the expression        }
  valor         : real;      { value to evaluate                            }

  tipo_anterior : char;      { for the '-' unary                            }
  nodo          : do_element;
  s2            : do_stack;
  p2            : integer;   { pointer to first element in each stack       }



Procedure convierte_a_polaca (var rpn : rpn_type);


Procedure do_error(num:integer; s:string);
begin
  rpn.error := num;
  rpn.message := s;
end;


Procedure Inicializa;
var
  i : integer;
begin
  do_error(0,'');
  tipo_anterior := ' ';

  operaciones_simples := ['+','-','*','/','^'];
  numeros := ['0','1'..'9','.'];
  operaciones := ['A'..'Z']; { like Coseno, Seno... }
  variables := ['X'];
  parentesis := ['(','{','[',']','}',')'];

  rpn.p1:=0; p2:=0; { also contain the number of elements in stacks }
  { the rpn.s1[0] and s2[0] are empty, only used to check the operations
    made before more esily }
  for i:=0 to MAXSTACK do begin
    rpn.s1[i].tipo:=' ';
    s2[i].tipo:=' ';
  end;
end;


Procedure push(cual:integer); { cual = which stack (1 or 2) }
{ inserts the element NODO to the stack }
begin
  {$IFDEF DEBUG}
    writeln('pushing ',nodo.tipo,' to ',cual);
  {$ENDIF}
  case cual of
    1: begin
         inc(rpn.p1);
         rpn.s1[rpn.p1]:=nodo;
       end;
    2: begin
         inc(p2);
         s2[p2]:=nodo;
       end;
    else do_error(ERROR_PUSH,ERROR_PUSH_S);
  end;
end;


procedure pop(cual:integer);
{ returns the element in stack CUAL to variable NODO }
begin
  case cual of
  1: with rpn do begin
         nodo:=s1[p1];
         dec(p1);
         if p1<0 then begin
           p1:=0;
           do_error(ERROR_PARENTESIS,ERROR_PARENTESIS_S);
         end;
       end;
  2: begin
         nodo:=s2[p2];
         dec(p2);
         if p2<0 then begin
           p2:=0;
           do_error(ERROR_PARENTESIS,ERROR_PARENTESIS_S);
         end;
       end;
  else do_error(ERROR_POP,ERROR_POP_S);
  end;
  {$IFDEF DEBUG}
  writeln('poping ',nodo.tipo,' from ',cual);
  {$ENDIF}
end;


Procedure get_next_arg(var donde:integer);
{ gets next word }
var
  letra         : char;
  encontre_primera_letra:boolean;
  encontre_fin  : boolean;
  aux           : string; { auxiliary string to create the string to be returned }
begin
  aux:='';
  encontre_primera_letra:=false;
  repeat
    letra := auxstring[donde];
    if (letra<>' ') or (donde>=length(AuxString)) then
      encontre_primera_letra:=true;
    inc(donde);
  until encontre_primera_letra;
  dec(donde);
  { as it is over or we found a correct letter, we continue till finding
    the end or finding an space }
  encontre_fin:=false;
  if donde>=length(AuxString) then { we reached the end }
    encontre_fin:=true;
  while not encontre_fin do begin
    inc(donde);
    aux:=aux+letra;
    letra:=AuxString[donde];
    if (letra=' ') or (donde>=length(AuxString)) then
      encontre_fin:=true; { this can be optimized! }
  end;
  if letra<>' ' then aux:=aux+letra; { last letter }
  sig_arg:=aux;
end;


procedure verifica_II; { second sintax filter }
{ verifies all nodes as they are being created... }
var
  i             : integer;
  found_match   : boolean;
  aux           : string;            { for error messages }
  a,b           : string[MaxOpSize]; { auxiliar strings   }
begin
  { First : check if node is operation and it exists }
  found_match:=false;
  if nodo.tipo = 'U' then begin
    for i:=1 to MaxOperaciones do
      if nodo.operacion = arreglo[i] then
        found_match:=true;
    if not found_match then begin
      do_error(ERROR_UNRECOGNIZE,ERROR_UNRECOGNIZE_S);
      rpn.message := rpn.message + nodo.operacion;
    end;
  end;

  a:=nodo.operacion; {NUEVO NODO, b= NODO ANTERIOR}
  { Second : check for empty parenthesis }
  if nodo.tipo = 'P' then begin
    if (s2[p2].tipo= 'P') and (p2>0) then begin { there is another parenthesis }
      if ( b[1] in ['{','[','('] ) and
         ( a[1] in ['}',']',')'] ) then
        do_error(ERROR_PARENTESIS_VACIOS,ERROR_PARENTESIS_VACIOS_S);
      {$IFDEF DEBUG}
      writeln(' we made the comparision')
      {$ENDIF}
    end;
  end; {parenthesis}
  b:=nodo.operacion; { saved }

  { Third : for unary minus (-) check if the preceding node was a parenthesis
    (opening) or was the first node }
  if (nodo.tipo = 'O') and (nodo.operacion='-') then begin
    if rpn.p1+p2 = 0 then { It is the first node  } { ++ }
      nodo.tipo:='U'      { Now we know its unary }
    else if b[1] in ['}',']',')'] then
      nodo.tipo:='U';
    { Node before was parenthesis and p1+p2>0 }
  end;
end;



Function es_constante(arg:char; VAR num:real):boolean;
var
  i : integer;
begin
  es_constante:=false;
  for i:=1 to MaxConstantes do begin
    if constantes[i].letra=arg then begin
      es_constante:=true;
      num:=constantes[i].valor;
    end;
  end;
end;



procedure interpreta_arg;
{ checks to see if its Operation, Variable, Number and fills the node NODO }
var
  chistoso : integer; { returns error when converting number }
begin
  nodo.numero:=0;
  nodo.operacion:='?';
  {$IFDEF DEBUG}
  write('The expression [',sig_arg:MaxOp,'] is : ');
  {$ENDIF}
  if sig_arg[1] in numeros then begin
    nodo.tipo:='N';
    val(sig_arg,nodo.numero,chistoso);
    end
  else if (sig_arg[1] in variables) and (length(sig_arg)=1) then begin
    nodo.tipo:='V';
    nodo.operacion:=sig_arg[1];
    end
  else if (es_constante(sig_arg[1],nodo.numero)) and (length(sig_arg)=1) then begin
    nodo.tipo:='N';
    { the function constant(arg,value) changed the value of the node }
    end
  else if sig_arg[1] in operaciones then begin { unary operations }
    nodo.tipo:='U';
    nodo.operacion:=sig_arg;
    end
  else if sig_arg[1] in operaciones_simples then { binary operations }
    begin
    nodo.tipo:='O';
    nodo.operacion:=sig_arg[1];
    if sig_arg[1]='-' then begin { can be a unary minus [-] }
      if (rpn.p1=0 {no hay digitos antes}) or (tipo_anterior='O') then
        nodo.tipo := 'U';
    end;
    end
  else if sig_arg[1] in parentesis then begin
    nodo.tipo:='P';
    nodo.operacion:=sig_arg[1];
    end
  else begin
    nodo.tipo:='X';
    do_error(ERROR_UNRECOGNIZE,ERROR_UNRECOGNIZE_S);
    rpn.message := rpn.message + sig_arg;
  end;
  {$IFDEF DEBUG}
  with nodo do
    writeln('TP = [',tipo:1,']  NU = [',
    numero:7:2,']  OP = [',operacion:MaxOp,']');
  {$ENDIF}
  verifica_II; { checks the node }
  Tipo_anterior := 'X';
  { 'O'=ok, 'X'=no. Tells if next operation can be (-) unary }
  if (sig_arg[1] in ['(','[','{']) then
    Tipo_anterior :='O';
end;


procedure hace_la_operacion;
{ node contains the operation to insert in stack }
var
  aux,a2 : string[MaxOpSize]; { for operation inside parenthesis }
begin
  case nodo.tipo of
  'P': begin
         aux:=nodo.operacion;
         if (aux[1] in ['{','[','('] ) then
           push(2)
         else begin { closing parenthesis }
           if p2=0 then begin
             do_error(ERROR_EXTRA_PARENTESIS,ERROR_EXTRA_PARENTESIS_S);
             rpn.message := rpn.message + aux;
           end;
           a2:=s2[p2].operacion;
           {$IFDEF DEBUG}
           writeln('PG 12, compares ',a2,' with ',aux);
           {$ENDIF}
           if not ( ( (aux='}') and (a2='{') ) or
              ( (aux=')') and (a2='(') ) or
              ( (aux=']') and (a2='[') ) )
           then
             do_error(ERROR_WEIRD_PARENTESIS,ERROR_WEIRD_PARENTESIS_S);
           pop(2); { we kill the other parenthesis }
           if (p2<>0) and (s2[p2].tipo <> 'P')
           then begin { it's not empty, there is an operation }
             pop(2);   {QUITAMOS LA OPERACION Y LA PASAMOS AL 1,}
             push(1);  {NO IMPORTA SI ERA UNARIA O BINARIA}
             if (p2<>0) and  (s2[p2].tipo = 'O') then begin
               pop(2);  {AHORA PUEDE QUEDAR UNA BINARIA SOLAMENTE }
               push(1); {COMO : COS(x) "* SIN (" X)}
             end;
           end;
         end;
       end;
  'O','U': push(2);
  'N','V': begin
         if s2[p2].tipo='O' then begin
           push(1);
           pop(2);
           push(1);
         end else if s2[p2].tipo='U' then begin { ++ }
           push(1);
           pop(2);
           push(1)
         end else
           push(1)
       end;
  'X': begin
       end;
  end;
end;


procedure convierte_expresion_a_polaca;
var
  cont   : integer; { counter to see where we are inside the expression }
  letra  : char;
  aux    : string;
begin
  cont:=1;
  repeat
    get_next_arg(cont); { from here 'till hitting an space }
    interpreta_arg;
    hace_la_operacion;
  until (cont >= length(AuxString));
  { fix unary operations left floating around }
  while (p2<>0) and (s2[p2].tipo='U') do begin
    pop(2);
    push(1);
  end;
  if (p2<>0) and (rpn.error=0) then begin { we have an extra operation !! }
    do_error(ERROR_EXTRA_SYMBOL,ERROR_EXTRA_SYMBOL_S);
    rpn.message := rpn.message + s2[p2].operacion;
  end;
  if (rpn.p1=0) and (rpn.error=0) then { there are NO operations!! }
    do_error(ERROR_NO_OPERATION,ERROR_NO_OPERATION_S);
end;


Procedure Separa_expresion;
var
  aux        : string;
  letra      : char;
  tipo,
  tipo_antes : char;    { Letters, Numbers(w/point) and Operations }
  I          : integer;
begin
  {$IFDEF DEBUG}
  writeln('Original Expression = ',rpn.fun_string);
  {$ENDIF}
  aux:='';
  AuxString := ' ' + rpn.fun_string;
  tipo_antes := 'X';
  for i:=1 to length(AuxString) do begin
    letra:=UpCase(AuxString[i]);
    if letra in numeros then
      tipo := 'A'
    else if letra in operaciones_simples then
      tipo := 'B'
    else if letra in operaciones then
      tipo := 'C'
    else if letra in variables then
      tipo := 'D'
    else if letra in parentesis then begin
      tipo := 'E';
      aux := aux+' ';
    end
    else
      tipo := 'X';
    if tipo<>tipo_antes then
      aux:=aux+' ';
    aux:=aux+letra;
    tipo_antes:=tipo;
  end; { for all the expression }

  AuxString:=aux;
  repeat
    if AuxString[length(AuxString)]=' ' then
      AuxString:=copy(AuxString,1,length(AuxString)-1);
  until (AuxString[length(AuxString)]<>' ') ;
  while pos('  ',AuxString)>0 do
    Delete(AuxString,Pos('  ',AuxString),1);
  {$IFDEF DEBUG}
  writeln('New expression = ',AuxString);
  writeln;
  repeat until keypressed;
  {$ENDIF}
end;


procedure verifica_expresion_I;
var
  i,L            : integer;
  puros_espacios : boolean;
  a              : char;
begin
  puros_espacios:=true;
  L:=length(AuxString);
  if L>0 then begin

    { checks if it is only spaces}
    for i:=1 to length(AuxString) do
      if AuxString[i]<>' ' then puros_espacios:=false;
    if puros_espacios then
      do_error(ERROR_NO_OPERATION,ERROR_NO_OPERATION_S);

    { now we check if all letters are understandable }
    for i:=1 to length(AuxString) do begin
      a:=UpCase(AuxString[i]);
      if not ( (a in operaciones) or
               (a in variables  ) or
               (a in parentesis ) or
               (a in numeros    ) or
               (a = ' '         ) or
               (a in operaciones_simples) ) then begin
                   do_error(ERROR_UNRECOGNIZE,ERROR_UNRECOGNIZE_S);
                   rpn.message := rpn.message + a;
                 end;
    end;
  end
  else
    do_error(ERROR_NO_OPERATION,ERROR_NO_OPERATION_S);
end;


Procedure Crea_expresion;
var
  i : integer;

Function numero_correcto(x:real):string;
var ss:string;
begin
  str(x:10:10,ss);
  while (length(ss)>0) and (ss[1]=' ') do ss:=copy(ss,2,length(ss)-1);
  if pos('.',ss)>0 then begin
    while ss[length(ss)] in ['0','.'] do
      ss := copy(ss,1,length(ss)-1);
  end;
  numero_correcto := ss;
end;

begin
  with rpn do begin
    rpn_string := '';
    {$IFDEF DEBUG}
    writeln;
    write('The expression is : ');
    for i:=1 to p1 do begin
      if s1[i].tipo = 'N' then
        write('<',s1.[i].numero:7:2,'>==')
      else
        write('<',s1[i].operacion,'>==');
    end;
    {$ENDIF}
    for i:=1 to p1 do begin
      if s1[i].tipo ='N' then
        rpn_string := rpn_string + numero_correcto(s1[i].numero) + ' '
      else begin
        if (s1[i].operacion='-') and (s1[i].tipo='U') then
          rpn_string := rpn_string + CHANGE_SIGN
        else
          rpn_string := rpn_string + s1[i].operacion;
        if i<>p1 then rpn_string := rpn_string + ' ';
      end;
    end; { for i := 1 to rpn.p1 do }
  end; { with rpn do begin }
end;



BEGIN
  Inicializa;
  Separa_expresion;
  verifica_expresion_I; { Obvious mistakes }
  if rpn.error=0 then begin
      convierte_expresion_a_polaca; { here we also depurate_II and verify it }
    if rpn.error=0 then
      Crea_expresion; { fills rpn_string }
  end;
  {$IFDEF DEBUG}
  repeat until keypressed;
  {$ENDIF}
end;

begin
end.