{$S-,r-,n-}
{$M $ff02,1,1}

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

  This program calculates a formula using recursion.

}

unit CAL;

interface

uses
    crt, ERRORS;

function Evaluate (rcal : string) : real;
function upstring (tekst : string) : string;
function upstring0 (tekst : string) : string;
function LowerCase (Tekst : string) : string;

implementation

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

var
  answer : real;
  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;
  FoutMelding:= true;
  FoutTekst:= copy (cal, i - 5, 10) + ' error.';
  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 : real) : 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) : real;
var
  x : real;
  code : integer;
begin
  val(s, x, code);
  fval := x;
end;

function prevnum(var temp : string; i : integer) : real;
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) : real;
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) : real;
var
  i : integer;
  tot : real;
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) : real;
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 * round (prevnum(temp, length(temp))) and round (nextnum(cal,i)));
                temp := temp + s;
              end
              else
              if cal[i] = '(' then
              begin
                s := fstr(sign * round (prevnum(temp, (length(temp)))) and round (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 * round (prevnum(temp, length(temp))) or round (nextnum(cal,i)));
                temp := temp + s;
              end
              else
              if cal[i] = '(' then
              begin
                s := fstr(sign * round (prevnum(temp, length(temp))) or round (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(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 : real;

  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 : real) : real;
  var
    k, n : word;
    ans : real;
  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) : real;
  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) : real;
  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 : real) : real;
  begin
    asin := arctan(ratio / sqrt((1 - ratio) * (1 + ratio)));
  end;

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

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

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

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

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

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

      'N' : begin
              if next3 = 'OT(' then
              begin
                inc(i, 3);
                temp := temp + fstr(not(round((domuls(dopowers(dofuncs(getbrackets(cal, i))))))));
              end
              else
                error(cal, 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;

function UpString (Tekst : string) : string;
  var
      c, len : integer;
      Haakjes: boolean;
  begin
      c:= 2;
      len:= length (Tekst);
      Haakjes:= (Tekst[1] = '"');
      Tekst[1]:= upcase (Tekst[1]);
      repeat
        if Tekst[c] = '"' then Haakjes:= not Haakjes;
        if not Haakjes then Tekst[c]:= upcase (Tekst[c]);
        c:= c + 1;
      until c>len;
      UpString:= Tekst;
  end;

function LowerCase (Tekst : string) : string;
  var
    VerSchil : integer;
    c        : integer;
  begin
    Verschil:= ord ('A') - ord ('a');
    for c:= 1 to length (Tekst) do
      if Tekst[c] in ['A'..'Z'] then
        Tekst[c]:= char (byte(Tekst[c]) - Verschil);
    LowerCase:= Tekst;
  end;

function upstring0 (tekst : string) : string;
  var
    c : byte;
  begin
    for c:= 1 to length (Tekst) do
      Tekst[c]:= upcase (Tekst[c]);
    upstring0:= Tekst;
  end;

function Evaluate (rcal : string) : real;
var
    answer : real;
    p      : longint;
    c, d   : integer;
    temp   : string;
    Start  : integer;
begin
  answer:= 0;
  if not clean (rcal) then begin
    Evaluate:= answer;
    exit;
  end;
  rcal:= upstring (rcal);
  if pos('ERROR', rcal) > 0 then begin
    Evaluate:= 0;
    exit;
  end;
  p:= pos ('ASC', rcal);
  while p > 0 do begin
    c:= p+3;
    while (c <= length(rcal)) and (rcal[c] <> '(') do inc (c, 1);
    while (c <= length(rcal)) and (rcal[c] <> '"') do inc (c, 1);
    str (byte (rcal[c+1]), temp);
    while (c <= length(rcal)) and (rcal[c]<>')') do inc (c, 1);
    rcal:= copy (rcal, 1, p-1) + temp + copy (rcal, c+1, 255);
    p:= pos ('ASC', rcal);
  end;
  p:= pos ('LEN', rcal);
  while p > 0 do begin
    c:= p+3;
    while (c <= length(rcal)) and (rcal[c] <> '(') do inc (c, 1);
    while (c <= length(rcal)) and (rcal[c] <> '"') do inc (c, 1);
    c:= c+1;
    d:= c;
    while (d <= length(rcal)) and (rcal[d]<>'"') do inc (d, 1);
    d:= d-1;
    str (d-c+1, temp);
    c:= d+2;
    while (c <= length(rcal)) and (rcal[c]<>')') do inc (c, 1);
    rcal:= copy (rcal, 1, p-1) + temp + copy (rcal, c+1, 255);
    p:= pos ('LEN', rcal);
  end;
  p:= pos ('RANDOM', rcal);
  while p > 0 do begin
    Start:= p;
    p:= p +  6;
    while (p <= length(rcal)) and (rcal[p] <> '(') do
      inc (p, 1);
    p:= p + 1;
    temp:= '';
    while (p <= length(rcal)) and (rcal[p] <> ')') do begin
      temp:= temp + rcal[p];
      inc (p, 1);
    end;
    answer:= round (domuls(dopowers(dofuncs(temp))));
    answer:= round(random(round(answer))+1);
    str (round(answer), temp);
    delete (rcal, Start, p-Start+1);
    insert (temp, rcal, Start);
    p:= pos ('RANDOM', rcal);
  end;
  p:= pos ('AND', rcal);
  while (p > 0) do
    begin
      delete (rcal, p, 3);
      insert ('&', rcal, p);
      p:= pos ('AND', rcal);
    end;
  p:= pos ('OR', rcal);
  while (p > 0) do
    begin
      delete (rcal, p, 2);
      insert ('|', rcal, p);
      p:= pos ('OR', rcal);
    end;
  p:= pos ('<=', rcal);
  if p > 0 then begin
    if Evaluate (copy(rcal, 1, p-1)) <= Evaluate (copy(rcal, p+2, 255)) then
      Evaluate:= 1
        else Evaluate:= 0;
    exit;
  end;
  p:= pos ('>=', rcal);
  if p > 0 then begin
    if Evaluate (copy(rcal, 1, p-1)) >= Evaluate (copy(rcal, p+2, 255)) then
      Evaluate:= 1
        else Evaluate:= 0;
    exit;
  end;
  p:= pos ('=', rcal);
  if p > 0 then begin
    if Evaluate (copy(rcal, 1, p-1)) = Evaluate (copy(rcal, p+1, 255)) then
      Evaluate:= 1
        else Evaluate:= 0;
    exit;
  end;
  p:= pos ('<', rcal);
  if p > 0 then begin
    if Evaluate (copy(rcal, 1, p-1)) < Evaluate (copy(rcal, p+1, 255)) then
      Evaluate:= 1
        else Evaluate:= 0;
    exit;
  end;
  p:= pos ('>', rcal);
  if p > 0 then begin
    if Evaluate (copy(rcal, 1, p-1)) > Evaluate (copy(rcal, p+1, 255)) then
      Evaluate:= 1
        else Evaluate:= 0;
    exit;
  end;
  if clean(rcal) then
  begin
    answer := domuls(dopowers(dofuncs(rcal)));
  end;
  Evaluate:= answer
end;

begin
    nosound;
end.
+
+
+
+


