formula.pas

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

 //raise FormulaException.Create('Can''t compute extern variable!');
 begin
   if (Af=nil) or not Assigned(AF.getvarvalue) then
       raise FormulaException.Create('GetVarValue not set!');
   Af.getvarvalue(x.str,0,result);
 end
 else if x.typ = fdtstring then result := x.str
 else result := floattostr(x.data);
end;

procedure setS(var x : TCalcItem;s:string);
begin
 x.typ := fdtstring;
 x.str := s;
end;

constructor TFormulaStack.Create(i : integer = 256);
begin
 max := i;
 pos := 0;
 setlength(data,i);
end;

destructor TFormulaStack.Free;
begin
 data := nil;
end;

function TFormulaStack.Top : char;
begin
 if pos > 0 then result := data[pos - 1]
 else result := #0;
end;

procedure TFormulaStack.Push(c : char);
begin
 if pos = max then
 begin
  inc(max, 256);
  setlength(data,max);
 end;
 data[pos] := c;
 inc(pos);
end;

function TFormulaStack.Pop : char;
begin
if pos > 0 then
begin
 dec(pos);
 result := data[pos];
end
else result := #0;
end;

function TFormulaStack.PopEx : string;
begin
if pos > 0 then
begin
 dec(pos);
 if data[pos] in [F_MFUN, F_USERF, F_FUN] then
 begin
  result := data[pos] + data[pos-1] + data[pos-2];
  dec(pos,2);
 end
 else
 if data[pos] = F_FUN then
 begin
  result := F_FUN + data[pos-1] + data[pos-2];
  dec(pos);
 end
 else result := data[pos];
end
else result := #0;
end;


// Calculator

destructor TFormulaCalc.Free;
var i : integer;
begin
 for i := 0 to high(data) do freeandnil(data[i]);
 data := nil;
end;

constructor TFormulaCalc.Create(i:integer = 256);
begin
 max := i;
 pos := 0;
 setlength(data,i);
end;

procedure TFormulaCalc.Clear;
begin
  pos := 0;
end;

function TFormulaCalc.TopN: double;
begin
 result := getN(data[pos - 1],parent)
end;

function TFormulaCalc.TopS: string;
begin
 result := getS(data[pos - 1],parent)
end;

procedure TFormulaCalc.PushN(n:double);
begin
 if pos = max then
 begin
  inc(max,256);
  setlength(data,max);
 end;
 data[pos].data := n;
 data[pos].typ := fdtnumber;
 inc(pos);
end;

procedure TFormulaCalc.Push(var x:TCalcItem);
begin
 if pos = max then
 begin
  inc(max,256);
  setlength(data,max);
 end;

 data[pos].typ := x.typ;
 if x.typ = fdtnumber then
  data[pos].data := x.data
 else
  data[pos].str := x.str;
 inc(pos);
end;

procedure TFormulaCalc.PushS(s:string);
begin
 if pos = max then
 begin
  inc(max,256);
  setlength(data,max);
 end;

 data[pos].str := s;
 data[pos].typ := fdtstring;
 inc(pos);
end;

function TFormulaCalc.PopN : double;
begin
   dec(pos);
   result := getN(data[pos],parent);
end;

function TFormulaCalc.PopS : string;
begin
   dec(pos);
   result := getS(data[pos],parent);
end;

function TFormulaCalc.ItemN(i:integer):double;
begin
 result := getN(data[pos-i-1],parent)
end;

function TFormulaCalc.Item(i:integer):PCalcItem;
begin
 result := @data[pos-i-1]
end;

function TFormulaCalc.ItemS(i:integer):string;
begin
 result := getS(data[pos-i-1],parent)
end;

procedure TFormulaCalc.Plus;
begin
 dec(pos);
 try
  data[pos-1].data := getN(data[pos-1],parent) + getN(data[pos],parent);
  data[pos-1].typ := fdtnumber;     
 except
  data[pos-1].str := getS(data[pos-1],parent) + getS(data[pos],parent);
  data[pos-1].typ := fdtstring;
 end;
end;

procedure TFormulaCalc.PlusS;
begin
 dec(pos);
 data[pos-1].str := getS(data[pos-1],parent) + getS(data[pos],parent);
 data[pos-1].typ := fdtstring;
end;

procedure TFormulaCalc.EQ;
var t : double;
begin
  dec(pos);
  try
   t := ifthen(getN(data[pos-1],parent)=getN(data[pos],parent),1,0)
  except
   if Parent.fcasesensitivestring then
    t := ifthen(getS(data[pos-1],parent)=getS(data[pos],parent),1,0)
   else
    t := ifthen(AnsiUpperCase(getS(data[pos-1],parent))=AnsiUpperCase(getS(data[pos],parent)),1,0);
  end;
  data[pos-1].data := t;
  data[pos-1].typ := fdtnumber;
end;

procedure TFormulaCalc.NE;
var t : double;
begin
  dec(pos);
  try
   t := ifthen(getN(data[pos-1],parent)<>getN(data[pos],parent),1,0)
  except
   if Parent.fcasesensitivestring then
    t := ifthen(getS(data[pos-1],parent)<>getS(data[pos],parent),1,0)
   else
    t := ifthen(AnsiUpperCase(getS(data[pos-1],parent))<>AnsiUpperCase(getS(data[pos],parent)),1,0);
  end;
  data[pos-1].data := t;
  data[pos-1].typ := fdtnumber;
end;

procedure TFormulaCalc.LE;
var t : double;
begin
  dec(pos);
  try
   t := ifthen(getN(data[pos-1],parent)<=getN(data[pos],parent),1,0)
  except
   if Parent.fcasesensitivestring then
    t := ifthen(getS(data[pos-1],parent)<=getS(data[pos],parent),1,0)
   else
    t := ifthen(AnsiUpperCase(getS(data[pos-1],parent))<=AnsiUpperCase(getS(data[pos],parent)),1,0);
  end;
  data[pos-1].data := t;
  data[pos-1].typ := fdtnumber;
end;

procedure TFormulaCalc.LT;
var t : double;
begin
  dec(pos);
  try
   t := ifthen(getN(data[pos-1],parent)<getN(data[pos],parent),1,0)
  except
   if Parent.fcasesensitivestring then
    t := ifthen(getS(data[pos-1],parent)<getS(data[pos],parent),1,0)
   else
    t := ifthen(AnsiUpperCase(getS(data[pos-1],parent))<AnsiUpperCase(getS(data[pos],parent)),1,0);
  end;
  data[pos-1].data := t;
  data[pos-1].typ := fdtnumber;
end;

procedure TFormulaCalc.GE;
var t : double;
begin
  dec(pos);
  try
   t := ifthen(getN(data[pos-1],parent)>=getN(data[pos],parent),1,0)
  except
   if Parent.fcasesensitivestring then
    t := ifthen(getS(data[pos-1],parent)>=getS(data[pos],parent),1,0)
   else
    t := ifthen(AnsiUpperCase(getS(data[pos-1],parent))>=AnsiUpperCase(getS(data[pos],parent)),1,0);
  end;
  data[pos-1].data := t;
  data[pos-1].typ := fdtnumber;
end;

procedure TFormulaCalc.GT;
var t : double;
begin
  dec(pos);
  try
   t := ifthen(getN(data[pos-1],parent)>getN(data[pos],parent),1,0)
  except
   if Parent.fcasesensitivestring then
    t := ifthen(getS(data[pos-1],parent)>getS(data[pos],parent),1,0)
   else
    t := ifthen(AnsiUpperCase(getS(data[pos-1],parent))>AnsiUpperCase(getS(data[pos],parent)),1,0);
  end;
  data[pos-1].data := t;
  data[pos-1].typ := fdtnumber;
end;

procedure TFormulaCalc.cAND;
begin
 dec(pos);
 data[pos-1].data := ifthen((getN(data[pos-1],parent)<>0) and (getN(data[pos],parent)<>0),1,0);
 data[pos-1].typ := fdtnumber;
end;

procedure TFormulaCalc.cOR;
begin
 dec(pos);
 data[pos-1].data := ifthen((getN(data[pos-1],parent)<>0) or (getN(data[pos],parent)<>0),1,0);
 data[pos-1].typ := fdtnumber;
end;

procedure TFormulaCalc.cXOR;
begin
 dec(pos);
 data[pos-1].data := ifthen((getN(data[pos-1],parent)<>0) xor (getN(data[pos],parent)<>0),1,0);
 data[pos-1].typ := fdtnumber;
end;

procedure TFormulaCalc.Minus;
begin
 dec(pos);
 data[pos-1].data := getN(data[pos-1],parent) - getN(data[pos],parent);
 data[pos-1].typ := fdtnumber;
end;

procedure TFormulaCalc.Mult;
begin
  dec(pos);
  data[pos-1].data := getN(data[pos-1],parent) * getN(data[pos],parent);
  data[pos-1].typ := fdtnumber;
end;

procedure TFormulaCalc.Division;
begin
   dec(pos);
   data[pos-1].data := getN(data[pos-1],parent) / getN(data[pos],parent);
   data[pos-1].typ := fdtnumber;
end;

procedure TFormulaCalc.cDiv;
begin
   dec(pos);
   data[pos-1].data := trunc(getN(data[pos-1],parent)) Div trunc(getN(data[pos],parent));
   data[pos-1].typ := fdtnumber;
end;

procedure TFormulaCalc.cMod;
begin
   dec(pos);
   data[pos-1].data := trunc(getN(data[pos-1],parent)) mod trunc(getN(data[pos],parent));
   data[pos-1].typ := fdtnumber;
end;

procedure TFormulaCalc.Pow;
begin
   dec(pos);
   data[pos-1].data := power(getN(data[pos-1],parent),getN(data[pos],parent));
   data[pos-1].typ := fdtnumber;
end;

procedure TFormulaCalc.Uminus;
begin
   data[pos-1].data := -getN(data[pos-1],parent);
   data[pos-1].typ := fdtnumber;
end;

procedure TFormulaCalc.cNot;
begin
   data[pos-1].data := ifthen(getN(data[pos-1],parent)=0,1,0);
   data[pos-1].typ := fdtnumber;
end;

procedure TFormulaCalc.DoFunction(fun : pformulafunction; cnt : integer; module:boolean);
begin
    if cnt = 255 then cnt := trunc(getN(data[pos-1],parent)+1);
    if module then inc(cnt);
    if (cnt = 0) then
    begin
     PushN(0);
     cnt := 1;
    end;
    data[pos-cnt] := fun(Self);
    dec(pos,cnt-1);
end;

function prior(a,b : char) : boolean;
var pa,pb:integer;
begin
 if (a = F_FUN) or (a = F_USERF) or (a = F_MFUN) then pa := 1
 else if a = '^' then pa := 2
 else if a in ['!',F_UMINUS] then pa := 3
 else if a in ['*','/','%','\'] then pa := 4
 else if a in ['+','-','@'] then pa := 5
 else if a in ['|','&',F_XOR] then pa := 6
 else if a in ['<','>','=',F_NE,F_GE,F_LE] then pa := 7
 else if a in ['(',')'] then pa := 8
 else pa := 100;

 if (b = F_FUN) or (b = F_USERF) or (b = F_MFUN) then pb := 1
 else if b = '^' then pb := 2
 else if b in ['!',F_UMINUS] then pb := 3
 else if b in ['*','/','%','\'] then pb := 4
 else if b in ['+','-','@'] then pb := 5
 else if b in ['<','>','=',F_NE,F_GE,F_LE] then pb := 6
 else if b in ['|','&',F_XOR] then pb := 7
 else if b in ['(',')'] then pb := 8
 else pb := 100;

 result := pa >= pb;

end;

destructor TArtFormula.Free;
begin
 S.Free;
 C.Free;
 usedvars := nil;
 userfunc := nil;
 varnames := nil;
 values := nil;
 inherited Free;
end;

constructor TArtFormula.Create(AOwner: TComponent);
begin
 inherited Create(AOwner);
 pos := 1;
 spos := 1;
 lines := 1;
 soffset := 0;
 offset := 0;
 ferror := ER_Ok;
 input :=#0;
 usedvars := nil;
 S := TFormulaStack.Create;
 S.Parent := self;
 C := TFormulaCalc.Create;
 C.fParent := self;
 fcasesensitivestring := true;
 fvarname := '_ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz';
 AddUserConstant('FALSE','0');
 AddUserConstant('TRUE','1');
 AddUserConstant('DIV','\');
 AddUserConstant('MOD','%');
 AddUserConstant('AND','&');
 AddUserConstant('OR','|');
 AddUserConstant('NOT','!');
 AddUserConstant('BEGIN','BLOCK(');
 AddUserConstant('END',')');
 AddUserConstant('ENDD','))');
 AddUserConstant('VAR','DEFINES(');
 AddUserConstant('IF','CONDITION(');
 AddUserConstant('THEN',',BLOCK(');
 AddUserConstant('ELSE','),BLOCK(');
 AddUserConstant('ENDIF','),0)');
 AddUserConstant('WHILE','LOOP(');
 AddUserConstant('DO',',BLOCK(');
 AddUserConstant('WEND','))');
 AddUserConstant('FOR','SERIES(');
 AddUserConstant('NEXT','))');
 AddUserConstant('REPEAT','TILL(BLOCK(');
 AddUserConstant('UNTIL','),');
end;

function TArtFormula.GetPos:integer;
begin
 result := pos + offset;
end;

function TArtFormula.GetSPos:integer;
begin
 result := spos + soffset;
end;


procedure TArtFormula.StartGetVars(n : integer);
begin
 npos := 1;
 ncnt := n;
 gvpos := 0;
 gvcnt := 0;
end;

function TArtFormula.GetNextVar(var x : TCalcItem; wantnumber:boolean) : boolean;
var nm:string;
    i:integer;
begin
 if gvcnt > 0 then
 begin
  setS(x,vals[gvpos]);
  inc(gvpos);
  if gvpos = gvcnt then gvcnt := 0;
 end
 else
 if C.Item(npos).typ <> fdtgetvar then
 begin
   x := C.Item(npos)^;
   inc(npos);
 end
 else
 begin
   if not Assigned(fgetvar) or not Assigned(fgetvarscount) then
       raise FormulaException.Create('GetVarsCount or GetVarValue not set!');
   nm := C.item(npos).str;
   fGetVarsCount(nm,gvcnt,wantnumber);
   if gvcnt = 0 then raise FormulaException.Create('"'+nm+'" returns zero vars!');
   setlength(vals,gvcnt);
   for i:=gvcnt-1 downto 0 do fGetVar(nm,i,vals[gvcnt-i-1],wantnumber);
   inc(npos);
   gvpos := 1;
   setS(x,vals[0]);
   if gvcnt = 1 then gvcnt := 0;
 end;
 result := (npos <= ncnt) or (gvcnt <> 0);
end;



procedure TArtFormula.SetVar(name : string; value : PCalcItem);
var idx : integer;
begin
 idx := FindVar(name);
 if idx = -1 then raise FormulaException.Create('Variable '+name+' dose not exists');
 Values[idx] := value^;
end;

function TArtFormula.GetVar(name : string) : PCalcItem;
var idx : integer;
begin
 idx := FindVar(name);
 if idx = -1 then raise FormulaException.Create('Variable '+name+' dose not exists');
 result := @(Values[idx]);
end;

function TArtFormula.IncVar(name : string) : PCalcItem;
var idx : integer;
begin
 idx := FindVar(name);
 if idx = -1 then raise FormulaException.Create('Variable dose not exists');
 SetN(Values[idx],getN(Values[idx],self)+1);
 result := @(Values[idx]);
end;

function TArtFormula.DecVar(name : string) : PCalcItem;
var idx : integer;