formula.pas

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

    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 + stringofchar(#0,sizeof(integer));
    pi := @(temp[ length(temp)-sizeof(integer)+1]);
    pi^ := ps1;
    pi := @(temp[ps2]);
    pi^ := length(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_POP + F_GO + stringofchar(#0,sizeof(integer));
    pi := @(temp[ length(temp)-sizeof(integer)+1]);
    pi^ := ps2 + sizeof(integer)-1;


    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;

// UNTILL
   F_UNTIL:
   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^ := 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_POP;
    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;
    temp := temp + stringofchar(#0,sizeof(integer));
    pi := @(temp[ length(temp)-sizeof(integer)+1]);
    pi^ := ps1;


    if chr(p) <> ')' then
    begin
     if ferror = ER_OK then ferror := ER_RIGHT;
     result := 0;
     exit;
    end;
    p := Parser;
   end;

// IF
   byte(F_IF):
   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_NOTENOUGH;
     result := 0;
     exit;
    end;
    temp := temp + F_IF;
    temp := temp + stringofchar(#0,sizeof(integer));
    ps := length(temp)-sizeof(integer)+1;
    S.Push(',');
    p := Form;
    while(S.Top()<>',') do
    begin
     temp := temp + S.Popex;
    end;
    S.Pop;
    if chr(p) <> ',' then
    begin
     result := 0;
     if ferror = ER_OK then ferror := ER_NOTENOUGH;
     exit;
    end;
    temp := temp + F_GO;
    temp := temp + stringofchar(#0,sizeof(integer));
    pi := @(temp[ps]);
    pi^ := length(temp);
    ps := length(temp)-sizeof(integer)+1;
    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;
    pi := @(temp[ps]);
    pi^ := length(temp);
    p := Parser;
   end;
// (...)
   byte('('):
   begin
     S.Push('(');
     p := Form;
     if p = 0 then
     begin
      result := 0;
      exit;
     end;
     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;
     if S.Top in [F_FUN, F_USERF, F_MFUN] then
     begin
      temp := temp + S.Pop + S.Pop + S.Top;
     end;
     p := Parser;
    end;
// FUNCTION
   byte(F_FUN):
    begin
     p := trunc(data);
     cnt := table[p].paramcount;
     S.Push(chr(cnt));
     S.Push(char(p));
     S.Push(F_FUN);
     module := table[p].module;
     func := nil;
     fnc := table[p].fun;
     p := CompileFunction;
     if p = 0 then
     begin
      result := 0;
      exit;
     end;
    end;
// USER FUNCTION
   byte(F_USERF):
    begin
     p := trunc(data);
     cnt := userfunc[p].paramcount;
     S.Push(char(cnt));
     S.Push(char(p));
     S.Push(F_USERF);
     module := userfunc[p].module;
     func := ATableItem(userfunc[p].funs);
     fnc := userfunc[p].fun;
     p := CompileFunction(p);
     if p = 0 then
     begin
      result := 0;
      exit;
     end;
    end;
// VAR
   F_VAR:
    begin
     temp := temp + chr(p);
     temp := temp + chr(trunc(data));
     p := Parser;
    end;
// GETVAR
   F_GETVAR:
   begin
    temp := temp + chr(p);
    temp := temp + stringofchar(#0,sizeof(integer));
    pi := @(temp[length(temp)-sizeof(integer)+1]);
    pi^ := length(tmp);
    temp := temp + tmp;
    p := Parser;
   end;
// DATA
   F_DATA:
    begin
     temp := temp + chr(p);
     temp := temp + stringofchar(#0,sizeof(double));
     u := @(temp[length(temp)-sizeof(double)+1]);
     u^ := data;
     p := Parser;
    end;
// STR
   F_STR:
    begin
     temp := temp + chr(p);
     temp := temp + stringofchar(#0,sizeof(integer));
     pi := @(temp[length(temp)-sizeof(integer)+1]);
     pi^ := length(tmp);
     temp := temp + tmp;
     p := Parser;
    end
   else
   begin
    result := 0;
    exit;
   end;
  end;

     if p = F_EOS then
     begin
      result :=  F_EOS;
      exit;
     end;
     if not isznak(chr(p)) then
     begin
       result := p;
       exit;
     end;

     while prior(chr(p),S.Top) do temp := temp + S.Popex;
     S.Push(chr(p));
     p := Form;
     if p = 0 then
     begin
       result := 0;
       exit;
     end
     else
     begin
      result := p;
      exit;
     end;
end;

procedure TArtFormula.IntCompute(compiled : string; num : byte; vals : PCalcArray);
var i,idx,l:integer;
    funs : ATableItem;
procedure Step;
begin
  case compiled[i] of
      '+': C.Plus;
      '-': C.Minus;
      '*': C.Mult;
      '/': C.Division;
      '%': C.cMod;
      '^': C.Pow;
      '\': C.cDiv;
      '&': C.cAnd;
      '|': C.cOr;
      F_XOR: C.cXOR;
      '@': C.PlusS;
      F_NE : C.NE;
      '=' : C.EQ;
      '<' : C.LT;
      F_LE : C.LE;
      '>' : C.GT;
      F_GE : C.GE;
      F_UMINUS: C.Uminus();
      '!': C.cNot();
      F_FUN:
        begin
         inc(i);
         idx := byte(compiled[i]);
         inc(i);
         C.DoFunction(table[idx].fun ,byte(compiled[i]));
        end;
      F_USERF:
        begin
         inc(i);
         idx := byte(compiled[i]);
         inc(i);
         C.DoFunction(userfunc[idx].fun, byte(compiled[i]))
        end;
      F_MFUN:
        begin
         inc(i);
         idx := byte(compiled[i]);
         inc(i);
         C.DoFunction(funs[idx].fun, byte(compiled[i]), true)
        end;
      chr(F_VAR):
       begin
          inc(i);
          C.Push(values[byte(compiled[i])]);
       end;
      chr(F_DATA):
       begin
         C.PushN((pdouble(@(compiled[i+1])))^);
         inc(i,sizeof(double));
       end;
      chr(F_GETVAR):
       begin
        idx := (pinteger(@(compiled[i+1])))^;
        inc(i, sizeof(integer));
        C.PushS(copy(compiled,i+1,idx));
        C.Item(0).typ := fdtgetvar;
        inc(i, idx);
       end;
      chr(F_STR):
       begin
         idx := (pinteger(@(compiled[i+1])))^;
         inc(i, sizeof(integer));
         C.PushS(copy(compiled,i+1,idx));
         inc(i, idx);
       end;
      F_GO:
       begin
         i := (pinteger(@(compiled[i+1])))^;
       end;
      F_IF:
       begin
         if C.PopN = 0 then
         begin
          i := (pinteger(@(compiled[i+1])))^;
         end
         else inc(i, sizeof(integer));
       end;
      F_POP: dec(C.pos);
      F_IDXF:
      begin
       inc(i);
       funs :=  ATableItem(userfunc[byte(compiled[i])].funs);
      end;
      F_IDXF1:
      begin
       inc(i);
       funs :=  ATableItem(funs[byte(compiled[i])].funs);
      end;
      F_RETURN:
      begin
       i := l+1;
      end;
      else raise FormulaException.Create('Wrong bytecode!');
     end;
end;
begin
 C.Clear;
 setlength(varnames, numofvar);
 setlength(values, numofvar);
 for i:=1 to num do values[i-1] := vals^[i-1];
 i := 1;
 l := length(compiled);
 ferror := ER_Ok;
 fstop := false;
 if fstep then
 while(i<=l) do
 begin
  if fstop then break;
  Application.ProcessMessages;
  Step;
  inc(i);
 end
 else
 while(i<=l) do
 begin
  case compiled[i] of
      '+': C.Plus;
      '-': C.Minus;
      '*': C.Mult;
      '/': C.Division;
      '%': C.cMod;
      '^': C.Pow;
      '\': C.cDiv;
      '&': C.cAnd;
      '|': C.cOr;
      F_XOR: C.cXOR;
      '@': C.PlusS;
      F_NE : C.NE;
      '=' : C.EQ;
      '<' : C.LT;
      F_LE : C.LE;
      '>' : C.GT;
      F_GE : C.GE;
      F_UMINUS: C.Uminus();
      '!': C.cNot();
      F_FUN:
        begin
         inc(i);
         idx := byte(compiled[i]);
         inc(i);
         C.DoFunction(table[idx].fun ,byte(compiled[i]));
        end;
      F_USERF:
        begin
         inc(i);
         idx := byte(compiled[i]);
         inc(i);
         C.DoFunction(userfunc[idx].fun, byte(compiled[i]))
        end;
      F_MFUN:
        begin
         inc(i);
         idx := byte(compiled[i]);
         inc(i);
         C.DoFunction(funs[idx].fun, byte(compiled[i]), true)
        end;
      chr(F_VAR):
       begin
          inc(i);
          C.Push(values[byte(compiled[i])]);
       end;
      chr(F_DATA):
       begin
         C.PushN((pdouble(@(compiled[i+1])))^);
         inc(i,sizeof(double));
       end;
      chr(F_GETVAR):
       begin
        idx := (pinteger(@(compiled[i+1])))^;
        inc(i, sizeof(integer));
        C.PushS(copy(compiled,i+1,idx));
        C.Item(0).typ := fdtgetvar;
        inc(i, idx);
       end;
      chr(F_STR):
       begin
         idx := (pinteger(@(compiled[i+1])))^;
         inc(i, sizeof(integer));
         C.PushS(copy(compiled,i+1,idx));
         inc(i, idx);
       end;
      F_GO:
       begin
         i := (pinteger(@(compiled[i+1])))^;
       end;
      F_IF:
       begin
         if C.PopN = 0 then
         begin
          i := (pinteger(@(compiled[i+1])))^;
         end
         else inc(i, sizeof(integer));
       end;
      F_POP: dec(C.pos);
      F_IDXF:
      begin
       inc(i);
       funs :=  ATableItem(userfunc[byte(compiled[i])].funs);
      end;
      F_IDXF1:
      begin
       inc(i);
       funs :=  ATableItem(funs[byte(compiled[i])].funs);
      end;
      F_RETURN:
      begin
       i := l+1;
      end;
      else raise FormulaException.Create('Wrong bytecode!');
     end;
  inc(i);
 end;
 fstop := false;
end;

function TArtFormula.Compute(num : byte; vals : PCalcArray):string;
begin
 IntCompute(fcompiled, num, vals);
 if fstop then result := '' else result := C.PopS;
end;

function TArtFormula.ComputeN(num : byte; vals : PCalcArray):double;
begin
 IntCompute(fcompiled, num, vals);
 if fstop then result := 0 else result := C.PopN;
end;

procedure Register;
begin
  RegisterComponents('Art', [TArtFormula]);
end;


end.