Преобразование из инфиксной нотации в Обратную польскую запись

Девиз функциональны программистов - "Больше думай меньше пиши" как ниде хорошо оправдывает себя в следующем примере: Преобразование из инфиксной нотации в Обратную польскую запись.

Код Delphi:

program calc;

{$apptype console}

type
real=double;

const
prs='+-*/(';
pri:array [1..5] of byte = (1,1,2,2,0);

var
s1,s2:string;
q:array[0..500] of real;
w:array[0..500] of char;
n,len,len2,i,j:longint;
t:real;
ch:char;

procedure push(x:real);
begin
  inc(len);
  q[len]:=x;
end;

function pop:real;
begin
  pop:=q[len];
  q[len]:=0;
  dec(len);
end;

procedure pushc(x:char);
begin
  inc(len2);
  w[len2]:=x;
end;

function popc:char;
begin
  popc:=w[len2];
  w[len2]:=#0;
  dec(len2);
end;

function oper(s1,s2:real;s3:char):real;
var
s:string;
x,y,z:real;
tmp:integer;
begin
  x:=s1;
  y:=s2;
  case s3 of
    '+':z:=x+y;
    '-':z:=x-y;
    '*':z:=x*y;
    '/':z:=x/y;
  end;
  oper:=z;
end;

procedure prechange(var s:string);
var
i:longint;
begin
  if s[1]='-' then s:='0'+s;
  i:=1;
  while i<=n do if (s[i]='(')and(s[i+1]='-') then insert('0',s,i+1) else inc(i);
end;

function change(s:string):string;
var
i:longint;
rezs:string;
c:boolean;
begin
  c:=false;
  for i:=1 to n do begin
    if not(s[i] in ['+','-','*','/','(',')']) then begin
      if c then rezs:=rezs+' ';
      rezs:=rezs+s[i];
      c:=false;
    end
    else begin
      c:=true;
      if s[i]='(' then pushc(s[i]) else
      if s[i]=')' then begin
        while w[len2]<>'(' do begin
          rezs:=rezs+' '+popc;
        end;
        popc;
      end else
      if s[i] in ['+','-','*','/'] then begin
        while pri[pos(w[len2],prs)]>=pri[pos(s[i],prs)] do rezs:=rezs+' '+popc;
        pushc(s[i]);
      end;
    end;
  end;
  while len2<>0 do rezs:=rezs+' '+popc;
  change:=rezs;
end;

function count(s:string):real;
var
ss:string;
x,s1,s2:real;
chh,s3:char;
p,i,j:longint;
tmp:integer;
begin
  i:=0;
  repeat
    j:=i+1;
    repeat inc(i) until s[i]=' ';
    ss:=copy(s,j,i-j);
    chh:=ss[1];
    if not(chh in ['+','-','*','/']) then begin
      val(ss,p,tmp);
      push(p);
    end
    else begin
      s2:=pop;
      s1:=pop;
      s3:=chh;
      push(oper(s1,s2,s3));
    end;
  until i>=n;
  x:=pop;
  count:=x;
end;

procedure writeL(x:real);
var
y,a,b:longint;
q:real;
begin
  y:=trunc(x);
  b:=0;
  if abs(x-y)<(1e-12) then
  writeln(y)
  else begin
    if y>0 then a:=round(ln(y)/ln(10))+1 else a:=1;
    q:=x;
    repeat
      q:=q*10;
      inc(b);
    until abs(q-trunc(q))<(1e-12);
    writeln(x:a+b:b);
  end;
end;

begin

repeat
    writeln('Enter expression');
    readln(s1);
    n:=length(s1);
    prechange(s1);
    n:=length(s1);
    s2:=change(s1);
    if s2[1]=' ' then delete(s2,1,1);
    s2:=s2+' ';
    n:=length(s2);
    t:=count(s2);
    writeL(t);
    writeln('One more expression?(Y/N)');
    readln(ch);
until upcase(ch)='N';

end.

Colored with dumpz.org

Colored with dumpz.org

Код Haskell:

calc :: String -> [Float]
 calc = foldl f [] . words
   where
     f (x:y:zs) "+" = (y + x):zs
     f (x:y:zs) "-" = (y - x):zs
     f (x:y:zs) "*" = (y * x):zs
     f (x:y:zs) "/" = (y / x):zs
     f xs y         = read y : xs

Colored with dumpz.org

Colored with dumpz.org