[Back to MATH SWAG index] [Back to Main SWAG index] [Original]

    {$S-}
    {$M 65520,0,655360}
    {$N+}

    { Cal.pas by Colin Lamarre, 1991
      Email: lamarre@vir.com

      This program calculates a formula using recursion.

    }

    const
      digits : set of char = ['0'..'9', '.', 'E'];

    var
      answer : extended;
      rcal : string;
      print : boolean;
      i : integer;

    procedure error(cal : string; var i : integer);
    begin
      if print then
      begin
        writeln(copy(cal, i - 5, 10) + ' error.');
        print := false;
      end;
      i := length(cal) + 1;
    end;

    function clean(var toupper : string) : boolean;
    var
      i, l, r : integer;
      t : string;
    begin
      print := true;
      t := '';
      l := 0;
      r := 0;
      for i := 1 to length(toupper) do
        if toupper[i] <> ' ' then
        begin
          t := t + upcase(toupper[i]);
          if toupper[i] = '(' then
            l := l + 1;
          if toupper[i] = ')' then
            r := r + 1;
        end;
      if r <> l then
      begin
        writeln('Missing brackets');
        clean := false;
      end
      else
      begin
        if t = '' then
          toupper := '0'
        else
          toupper := t;
        clean := true;
      end;
    end;

    function fstr(x : extended) : string;
    var
      s : string;
    begin
      str(x:1:9, s);
      if s[1] = ' ' then
        delete(s, 1, 1);
      fstr := s;
    end;

    function fval(s : string) : extended;
    var
      x : extended;
      code : integer;
    begin
      val(s, x, code);
      fval := x;
    end;

    function prevnum(var temp : string; i : integer) : extended;
    var
      oldi : integer;
    begin
      oldi := i;
      while ((temp[i] in digits) or ((temp[i - 1] = 'E') and (temp[i] in ['+', '-']))) and (i >= 1) do
        dec(i);
      if (temp[i] in ['+', '-']) and ((i = 1) or (temp[i - 1] in ['+', '-', '*', '/'])) then
        dec(i);
      prevnum := fval(copy(temp, i + 1, oldi - i));
      delete(temp, i + 1, oldi - i);
    end;

    function signs(cal : string; var i : integer) : integer;
    var
      sign : integer;
    begin
      sign := 1;
      repeat
        if cal[i] = '-' then
        begin
          sign := sign * -1;
          inc(i);
        end
        else
        if cal[i] = '+' then
          inc(i);
      until not(cal[i] in ['-', '+']);
      signs := sign;
    end;

    function nextnum(cal : string; var i : integer) : extended;
    var
      temp : string;
      sign : integer;
    begin
      temp := '';
      sign := signs(cal, i);
      while (cal[i] in digits) and (i <= length(cal)) do
      begin
        temp := temp + cal[i];
        inc(i);
        if (cal[i - 1] = 'E') and (cal[i] in ['+', '-']) then
        begin
          temp := temp + cal[i];
          inc(i);
        end;
      end;
      nextnum := sign * fval(temp);
    end;

    function getbrackets(cal : string; var i : integer) : string;
    var
      count : integer;
      temp : string;
    begin
      count := 1;
      temp := '';
      repeat
        inc(i);
        if cal[i] = '(' then
          count := count + 1;
        if cal[i] = ')' then
          count := count - 1;
        temp := temp + cal[i];
      until (cal[i] = ')') and (count = 0);
      delete(temp, length(temp), 1);
      inc(i);
      getbrackets := temp;
    end;

    function doadd(temp : string) : extended;
    var
      i : integer;
      tot : extended;
    begin
      i := 1;
      tot := nextnum(temp, i);
      repeat
        inc(i);
        case temp[i - 1] of
          '+' : tot := tot + nextnum(temp, i);
          '-' : tot := tot - nextnum(temp, i);
        end;
      until i > length(temp);
      doadd := tot;
    end;

    function domuls(cal : string) : extended;
    var
      i, sign : integer;
      temp, s : string;
    begin
      i := 1;
      temp := '';
      repeat
        case cal[i] of
          '+', '-' : begin
                       temp := temp + cal[i];
                       inc(i);
                     end;

          '*' : begin
                  inc(i);
                  sign := signs(cal, i);
                  if cal[i] in digits then
                  begin
                    s := fstr(sign * prevnum(temp, length(temp)) * nextnum(cal,i));
                    temp := temp + s;
                  end
                  else
                  if cal[i] = '(' then
                  begin
                    s := fstr(sign * prevnum(temp, length(temp)) * domuls(getbrackets(cal, i)));
                    temp := temp + s;
                  end
                  else
                    error(cal, i);
                end;

          '/' : begin
                  inc(i);
                  sign := signs(cal, i);
                  if cal[i] in digits then
                  begin
                    s := fstr(sign * prevnum(temp, length(temp)) / nextnum(cal, i));
                    temp := temp + s;
                  end
                  else
                  if cal[i] = '(' then
                  begin
                    s := fstr(prevnum(temp, length(temp)) / (sign * domuls(getbrackets(cal, i))));
                    temp := temp + s;
                  end
                  else
                    error(cal, i);
                end;

          '0'..'9', '.' : while (cal[i] in digits) and (i <= length(cal)) do
                          begin
                            temp := temp + cal[i];
                            inc(i);
                            if (cal[i - 1] = 'E') and (cal[i] in ['+', '-']) then
                            begin
                              temp := temp + cal[i];
                              inc(i);
                            end;
                          end;

          '(' : temp := temp + fstr(domuls(getbrackets(cal, i)));

          else
            error(cal, i);
        end;
      until i > length(cal);
      domuls := doadd(temp);
    end;

    function dopowers(cal : string) : string;
    var
      i, c : integer;
      x, f : extended;

      function fcnt(var cal : string; var i : integer) : integer;
      var
        j : integer;
      begin
        j := 0;
        while cal[i] = '!' do
        begin
          inc(j);
          dec(i);
        end;
        inc(i);
        delete(cal, i, j);
        fcnt := j;
      end;

      function fact(x : extended) : extended;
      var
        k, n : word;
        ans : extended;
      begin
        ans := 1;
        if x < 0 then
          fact := ans / (x - x);
        n := trunc(x);
        for k := 2 to n do
          ans := k * ans;
        fact := ans;
      end;

      function getprev(var cal : string; var i : integer) : extended;
      var
        oldi, count : integer;
      begin
        dec(i);
        oldi := i;
        if cal[i] <> ')' then
        begin
          while ((cal[i] in digits) or ((cal[i - 1] = 'E') and (cal[i] in ['+', '-']))) and (i >= 1) do
            dec(i);
          if (cal[i] in ['+', '-']) and ((i = 1) or (cal[i - 1] in ['+', '-', '*', '/'])) then
            dec(i);
          getprev := fval(copy(cal, i + 1, oldi - i));
          delete(cal, i + 1, oldi - i);
        end
        else
        begin
          count := 1;
          while (cal[i] <> '(') and (count <> 0) and (i >= 1) do
          begin
            dec(i);
            if cal[i] = ')' then
              count := count + 1;
            if cal[i] = '(' then
              count := count - 1;
          end;
          getprev := domuls(dopowers(copy(cal, i + 1, oldi - i - 1)));
          delete(cal, i, oldi - i + 1);
          dec(i);
        end;
      end;

      function getnext(var cal : string; i : integer) : extended;
      var
        oldi, sign, count : integer;
        temp : string;
      begin
        oldi := i;
        inc(i);
        temp := '';
        sign := signs(cal, i);
        if cal[i] <> '(' then
        begin
          while (cal[i] in digits) and (i <= length(cal)) do
          begin
            temp := temp + cal[i];
            inc(i);
            if (cal[i - 1] = 'E') and (cal[i] in ['+', '-']) then
            begin
              temp := temp + cal[i];
              inc(i);
            end;
          end;
          getnext := sign * fval(temp);
          delete(cal, oldi, i - oldi);
        end
        else
        begin
          count := 1;
          temp := '';
          repeat
            inc(i);
            if cal[i] = '(' then
              count := count + 1;
            if cal[i] = ')' then
              count := count - 1;
            temp := temp + cal[i];
          until (cal[i] = ')') and (count = 0);
          delete(temp, length(temp), 1);
          getnext := sign * domuls(dopowers(temp));
          delete(cal, oldi, i - oldi + 1);
        end;
      end;

    begin
      i := length(cal);
      repeat
        case cal[i] of
          '^' : begin
                  x := getnext(cal, i);
                  if cal[i - 1] = '!' then
                  begin
                    dec(i);
                    c := fcnt(cal, i);
                    f := getprev(cal, i);
                    for c := 1 to c do
                      f := fact(f);
                    insert(fstr(exp(x * ln(f))), cal, i + 1);
                  end
                  else
                    insert(fstr(exp(x * ln(getprev(cal, i)))), cal, i + 1);
                end;

          '!' : begin
                  c := fcnt(cal, i);
                  f := getprev(cal, i);
                  for c := 1 to c do
                    f := fact(f);
                  insert(fstr(f), cal, i + 1);
                end;

          else
            dec(i);
        end;
      until i < 1;
      dopowers := cal;
    end;

    function dofuncs(cal : string) : string;
    var
      i : integer;
      temp : string;

      function next3 : string;
      begin
        next3 := cal[i + 1] + cal[i + 2] + cal[i + 3];
      end;

      function asin(ratio : extended) : extended;
      begin
        asin := arctan(ratio / sqrt((1 - ratio) * (1 + ratio)));
      end;

      function acos(ratio : extended) : extended;
      begin
        acos := arctan(sqrt((1 - ratio) * (1 + ratio)) / ratio);
      end;

      function atan(ratio : extended) : extended;
      begin
        atan := arctan(ratio);
      end;

      function tan(angle : extended) : extended;
      begin
        tan := sin(angle) / cos(angle);
      end;

      function cot(angle : extended) : extended;
      begin
        cot := cos(angle) / sin(angle);
      end;

      function log(x : extended) : extended;
      begin
        log := ln(x) / 2.302585093;
      end;

    begin
      i := 1;
      temp := '';
      repeat
        case cal[i] of
          '+', '-',
          '*', '/',
          '(', ')',
          '^', '!' : begin
                       temp := temp + cal[i];
                       inc(i);
                     end;

          'S' : begin
                  if next3 = 'IN(' then
                  begin
                    inc(i, 3);
                    temp := temp + fstr(sin(domuls(dopowers(dofuncs(getbrackets(cal, i))))));
                  end
                  else
                  if next3 + cal[i + 4] = 'QRT(' then
                  begin
                    inc(i, 4);
                    temp := temp + fstr(sqrt(domuls(dopowers(dofuncs(getbrackets(cal, i))))));
                  end
                  else
                    error(cal, i);
                end;

          'C' : begin
                  if next3 = 'OS(' then
                  begin
                    inc(i, 3);
                    temp := temp + fstr(cos(domuls(dopowers(dofuncs(getbrackets(cal, i))))));
                  end
                  else
                  if next3 = 'OT(' then
                  begin
                    inc(i, 3);
                    temp := temp + fstr(cot(domuls(dopowers(dofuncs(getbrackets(cal, i))))));
                  end
                  else
                    error(cal, i);
                end;

          'T' : begin
                  if next3 = 'AN(' then
                  begin
                    inc(i, 3);
                    temp := temp + fstr(tan(domuls(dopowers(dofuncs(getbrackets(cal, i))))));
                  end
                  else
                    error(cal, i);
                end;

          'A' : begin
                  if next3 + cal[i + 4] = 'TAN(' then
                  begin
                    inc(i, 4);
                    temp := temp + fstr(atan(domuls(dopowers(dofuncs(getbrackets(cal, i))))));
                  end
                  else
                  if next3 + cal[i + 4] = 'COS(' then
                  begin
                    inc(i, 4);
                    temp := temp + fstr(acos(domuls(dopowers(dofuncs(getbrackets(cal, i))))));
                  end
                  else
                  if next3 + cal[i + 4] = 'SIN(' then
                  begin
                    inc(i, 4);
                    temp := temp + fstr(asin(domuls(dopowers(dofuncs(getbrackets(cal, i))))));
                  end
                  else
                  if next3 = 'BS(' then
                  begin
                    inc(i, 3);
                    temp := temp + fstr(abs(domuls(dopowers(dofuncs(getbrackets(cal, i))))));
                  end
                  else
                    error(cal, i);
                end;

          'L' : begin
                  if next3 = 'OG(' then
                  begin
                    inc(i, 3);
                    temp := temp + fstr(log(domuls(dopowers(dofuncs(getbrackets(cal, i))))));
                  end
                  else
                  if cal[i + 1] + cal[i + 2] = 'N(' then
                  begin
                    inc(i, 2);
                    temp := temp + fstr(ln(domuls(dopowers(dofuncs(getbrackets(cal, i))))));
                  end
                  else
                    error(cal, i);
                end;

          'E' : if next3 = 'XP(' then
                begin
                  inc(i, 3);
                  temp := temp + fstr(exp(domuls(dopowers(dofuncs(getbrackets(cal, i))))));
                end;

          'P' : if cal[i + 1] = 'I' then
                begin
                  inc(i, 2);
                  temp := temp + fstr(pi);
                end
                else
                  error(cal, i);

          '0'..'9', '.' : while (cal[i] in digits) and (i <= length(cal)) do
                          begin
                            temp := temp + cal[i];
                            inc(i);
                            if (cal[i - 1] = 'E') and (cal[i] in ['+', '-']) then
                            begin
                              temp := temp + cal[i];
                              inc(i);
                            end;
                          end;

          else
            error(cal, i);
        end;
      until i > length(cal);
      dofuncs := temp;
    end;

    begin
      rcal := '';
      for i := 1 to paramcount do
        rcal := rcal + paramstr(i);

      if clean(rcal) then
      begin
        answer := domuls(dopowers(dofuncs(rcal)));
        if print then
          writeln(answer:1:9);
      end;

    end.

[Back to MATH SWAG index] [Back to Main SWAG index] [Original]