formula.pas

ArtFormula package contains two nonvisual Delphi component for symbolic expression parsing and evalu

 begin
  decimalseparator := ch;
  raise FormulaException.Create(ErrString);
 end;
 fcompiled := temp+#0;
 result := fcompiled;
 decimalseparator := ch;
end;


function TArtFormula.ComputeStrN(instr : string; num : byte; vars : PStringArray; vals : PCalcArray) : double;
begin
 Compile(instr, num, vars);
 result := ComputeN(num, vals);
end;

function TArtFormula.ComputeStr(instr : string; num : byte; vars : PStringArray; vals : PCalcArray) : string;
begin
 Compile(instr, num, vars);
 result := Compute(num, vals);
end;

function TArtFormula.Test(instr : string; num : byte; vars : PStringArray) : boolean;
var i:integer;
begin
  fcompiled := '';
  if num > 0 then
  begin
   setlength(usedvars,num);
   setlength(varnames,num);
   setlength(values,num);
   for i:=0 to num-1 do
   begin
    usedvars[i] := false;
    varnames[i] := vars^[i];
   end;
  end;
  input := instr+#0;
  pos := 1;
  spos := 1;
  lines := 1;
  soffset := 0;
  offset := 0;
  numofvar := num;
  temp := '';
 if Form <> F_EOS then
 begin
  if ferror = ER_Ok then ferror := ER_SYNTAX;
  result := false;
  exit;
 end;

 while S.Top <> #0 do
 begin
  temp := temp + S.Popex;
 end;

 if ftestused then
 for i:=0 to num-1 do
  if usedvars[i] = false then
  begin
   ferror := ER_VARS;
   result := false;
   exit;
  end;

 if length(temp) = 0 then
  result := false
 else
  result := true;
end;

function TArtFormula.Form:integer;
var p : integer;
    u : ^double;
    pi : pinteger;
    cnt,ps,ps1,ps2:integer;
    module : boolean;
    func : ATableItem;
    fnc : pformulafunction;

function CompileFunction(x : integer = 0; idxf : string = '') : integer;
var i:integer;
    str : string;
begin
   p := Parser;
   if not (module and (chr(p) = '.')) then
   begin
    if cnt = 0 then
    begin
     if chr(p) = '(' then
     begin
      if chr(Parser) <> ')' then
      begin
       if ferror = ER_OK then ferror := ER_RIGHT;
       result := 0;
       exit;
      end;
      p := Parser;
     end;
     if @fnc = nil then
     begin
       ferror := ER_SYNTAX;
       result := 0;
       exit;
     end;
     temp := temp + idxf + S.PopEx;
     if chr(p) <> '.' then
     begin
      result := p;
      exit;
     end;
    end
    else
    begin
     if(chr(p) <> '(') then
     begin
      if ferror = ER_OK then ferror := ER_LEFT;
      result := 0;
      exit;
     end;
     S.Push('(');
     if cnt > 0 then
     for i := 1 to cnt do
     begin
      S.Push(',');
      p := Form;
      if p = 0 then
      begin
       result := 0;
       exit;
      end;
      while(S.Top <> ',') do
      begin
       temp := temp + S.Popex;
      end;
      if (chr(p) <> ',') and (i<cnt) then
      begin
       if ferror = ER_OK then ferror := ER_NOTENOUGH;
       result := 0;
       exit;
      end;
      S.Pop;
     end
     else if cnt = -1 then
     begin
      p := Parser(true);
      cnt := 0;
      while chr(p) <> ')' do
      begin
       inc(cnt);
       S.Push(',');
       p := Form;
       if p = 0 then
       begin
        result := 0;
        exit;
       end;
       while(S.Top <> ',') do
       begin
        temp := temp + S.Popex;
       end;
       S.Pop;
       if (p <> byte(',')) and (p <> byte(')')) then
       begin
        result := 0;
        exit;
       end;
      end;
      temp := temp + chr(F_DATA);
      temp := temp + stringofchar(#0,sizeof(double));
      u := @(temp[length(temp)-sizeof(double)+1]);
      u^ := cnt;
     end
     else p := Parser;

     if cnt = 0 then p := Parser;

     if chr(p) <> ')' then
     begin
       if ferror = ER_OK then ferror := ER_RIGHT;
      result := 0;
      exit;
     end;
     while(S.Top <> '(') do
     begin
      temp := temp + S.Popex;
     end;
     S.Pop;
     temp := temp + idxf + S.PopEx;
     p := Parser;
     if chr(p) <> '.' then
     begin
      result := p;
      exit;
     end;
    end
   end
   else
   begin
    S.PopEx;
    temp := temp + chr(F_DATA) + stringofchar(#0,sizeof(double));
   end;

   p := Parser(false,false,true);
   if p <> F_IDENT then
   begin
       if ferror = ER_OK then ferror := ER_SYNTAX;
       result := 0;
       exit;
   end;
   if func = nil then
   begin
       ferror := ER_UNKNOWN;
       result := 0;
       exit;
   end;

   str := tmp;
   p := Parser(true);
   tmp := str;
   if p = F_LET then
    str := 'set'+str;

   for i := 0 to high(func) do
   begin
    if UpperCase(str) = func[i].name then
    begin
     cnt := func[i].paramcount;
     S.Push(chr(cnt));
     S.Push(chr(i));
     S.Push(char(F_MFUN));
     if idxf = '' then
        idxf := F_IDXF + chr(x)
     else
        idxf := idxf + F_IDXF1 + chr(x);
     case p of
      F_LET:
      begin
       Parser;
       if cnt <> 1 then
       begin
        ferror := ER_SYNTAX;
        result := 0;
        exit;
       end;

       S.Push('(');

       result := Form;

       while(S.Top <> '(') do
       begin
        temp := temp + S.Popex;
       end;
       S.Pop;
       if result <> 0 then
        temp := temp + idxf + S.PopEx;
      end;
      byte('('):
      begin
       module := func[i].module;
       fnc := func[i].fun;
       func := ATableItem(func[i].funs);
       result := CompileFunction(i, idxf)
      end;
      else
      begin
       if cnt <> 0 then
       begin
        ferror := ER_SYNTAX;
        result := 0;
        exit;
       end;
       temp := temp + idxf + S.PopEx;
       result := Parser;
      end;
     end;
     exit;
    end;
   end;

   ferror := ER_UNKNOWN;
   result := 0;
end;

begin
  p := Parser;
  if p = F_EOS then
  begin
   result := 0;
   exit;
  end;

   if chr(p) = '+' then p := Parser;

   case p of
   byte('-'):
   begin
     S.Push(F_UMINUS);
     p := Form;
   end;
// Not
   byte('!'):
   begin
     S.Push('!');
     p := Form;
   end;
// SET or VAL
   byte('$'):
   begin
    p := Parser(false,true);
    if (p = F_VAR) or (p = F_STR) then
    begin
     temp := temp + chr(F_STR);
     temp := temp + stringofchar(#0,sizeof(integer));
     pi := @(temp[length(temp)-sizeof(integer)+1]);
     pi^ := length(tmp);
     temp := temp + tmp;

     p := Parser(true);

     if chr(p) = '[' then
     begin
      Parser;
      S.Push('(');
      p := Form;
      while(S.Top()<>'(') do
      begin
       temp := temp + S.Popex;
      end;
      S.Pop;

      while chr(p) <> ']' do
      begin
       if chr(p) <> ',' then
       begin
       if ferror = ER_OK then ferror := ER_SYNTAX;
        result := 0;
        exit;
       end;
       temp := temp + '@' + chr(F_STR) + #1#0#0#0 + '_@';

       S.Push('(');
       p := Form;
       while(S.Top()<>'(') do
       begin
         temp := temp + S.Popex;
       end;
       S.Pop;
      end;

      temp := temp + '@';
     end
    end
    else
    if p = byte('(') then
    begin
      S.Push('(');
      p := Form;
      while(S.Top()<>'(') do
      begin
       temp := temp + S.Popex;
      end;
      S.Pop;
      if chr(p) <> ')' then
      begin
       if ferror = ER_OK then ferror := ER_RIGHT;
       result := 0;
       exit;
      end;
    end
    else
    begin
       if ferror = ER_OK then ferror := ER_SYNTAX;
      result := 0;
      exit;
    end;

     p := Parser;
     case p of
     F_LET:
     begin
      S.Push('(');
      p := Form;
      while(S.Top()<>'(') do
      begin
       temp := temp + S.Popex;
      end;
      S.Pop;
      temp := temp + F_FUN + chr(IDX_SET) + #2;
     end;
     F_INC:
     begin
      temp := temp + F_FUN + chr(IDX_INC) + #1;
      p := Parser;
     end;
     F_DEC:
     begin
      temp := temp + F_FUN + chr(IDX_DEC) + #1;
      p := Parser;
     end;
     else
     begin
      temp := temp + F_FUN + chr(IDX_VAL) + #1;
     end;
    end;
   end;
// RETURN
   byte(F_RETURN):
   begin
    if(chr(Parser) <> '(') then
    begin
     if ferror = ER_OK then  ferror := ER_LEFT;
     result := 0;
     exit;
    end;
    S.Push('(');
    p := Form;
    while(S.Top()<>'(') do
    begin
     temp := temp + S.Popex;
    end;
    S.Pop;
    if chr(p) <> ')' then
    begin
     if ferror = ER_OK then ferror := ER_RIGHT;
     result := 0;
     exit;
    end;
    temp := temp + F_RETURN;
    p := Parser;
   end;
// WHILE
   F_WHILE:
   begin
    if(chr(Parser) <> '(') then
    begin
     if ferror = ER_OK then  ferror := ER_LEFT;
     result := 0;
     exit;
    end;
    temp := temp + chr(F_DATA);
    temp := temp + stringofchar(#0,sizeof(double));
    u := @(temp[length(temp)-sizeof(double)+1]);
    u^ := -1.0;
    ps1 := length(temp);
    temp := temp + chr(F_DATA);
    temp := temp + stringofchar(#0,sizeof(double));
    u := @(temp[length(temp)-sizeof(double)+1]);
    u^ := 1.0;
    temp := temp + '+';

    S.Push('(');
    p := Form;
    while(S.Top()<>'(') do
    begin
     temp := temp + S.Popex;
    end;
    S.Pop;
    temp := temp + F_IF;
    temp := temp + stringofchar(#0,sizeof(integer));
    ps := length(temp)-sizeof(integer)+1;
    if chr(p) <> ',' then
    begin
     if ferror = ER_OK then  ferror := ER_NOTENOUGH;
     result := 0;
     exit;
    end;
    S.Push(',');
    p := Form;
    while(S.Top()<>',') do
    begin
     temp := temp + S.Popex;
    end;
    S.Pop;
    temp := temp + F_POP + F_GO;
    temp := temp + stringofchar(#0,sizeof(integer));
    pi := @(temp[ length(temp)-sizeof(integer)+1]);
    pi^ := ps1;

    pi := @(temp[ps]);
    pi^ := length(temp);
    if chr(p) <> ')' then
    begin
     if ferror = ER_OK then ferror := ER_RIGHT;
     result := 0;
     exit;
    end;
    p := Parser;
   end;

// FOR
   F_FOR:
   begin
    if(chr(Parser) <> '(') then
    begin
       if ferror = ER_OK then ferror := ER_LEFT;
     result := 0;
     exit;
    end;

    S.Push('(');
    p := Form;
    while(S.Top()<>'(') do
    begin
     temp := temp + S.Popex;
    end;
    S.Pop;

    temp := temp + F_POP + chr(F_DATA);
    temp := temp + stringofchar(#0,sizeof(double));
    u := @(temp[length(temp)-sizeof(double)+1]);
    u^ := -1.0;
    ps1 := length(temp);
    temp := temp + chr(F_DATA);
    temp := temp + stringofchar(#0,sizeof(double));
    u := @(temp[length(temp)-sizeof(double)+1]);
    u^ := 1.0;
    temp := temp + '+';

    if chr(p) <> ',' then
    begin
     if ferror = ER_OK then ferror := ER_NOTENOUGH;
     result := 0;
     exit;
    end;
    S.Push(',');
    p := Form;
    while(S.Top()<>',') do
    begin
     temp := temp + S.Popex;
    end;
    S.Pop;
    temp := temp + F_IF + stringofchar(#0,sizeof(integer));
    ps := length(temp)-sizeof(integer)+1;

    temp := temp + F_GO + stringofchar(#0,sizeof(integer));
    ps2 := length(temp)-sizeof(integer)+1;