formula.pas

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

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.FindVar(name : string): integer;
var i : integer;
begin
 result := -1;
 for i := 0 to high(varnames) do
  if fcasesensitive then
  begin
   if varnames[i] = name then
   begin
    result := i;
    break;
   end
  end
  else
   if uppercase(varnames[i]) = uppercase(name) then
   begin
    result := i;
    break;
   end;
end;

procedure TArtFormula.AddVar(name : string; value : PCalcItem);
var idx : integer;
begin
 idx := FindVar(name);
 if idx <> -1 then raise FormulaException.Create('Variable already exists');
 idx := high(varnames) + 1;
 setlength(varnames,idx+1);
 setlength(values,idx+1);
 Values[idx] := value^;
 varnames[idx] := name;
end;

function TArtFormula.AddModuleFunction(module: PTableItem; name : string; paramcount:integer; fun : pformulafunction; ismodule:boolean):PTableItem;
var i:integer;
begin
 for i := 0 to high(module.funs) do
  if uppercase(name) = module.funs[i].name then
  raise FormulaException.Create('Function already defined');
 i := high(module.funs)+1;
 if i = 255 then raise FormulaException.Create('To many functions defined');
 setlength(module.funs,i+1);
 new(module.funs[i]);
 module.funs[i].name := uppercase(name);
 module.funs[i].paramcount := paramcount;
 module.funs[i].fun := fun;
 module.funs[i].module := ismodule;
 result := module.funs[i];
end;

function TArtFormula.AddUserFunction(name : string; paramcount:integer; fun : pformulafunction; ismodule : boolean):PTableItem;
var i:integer;
begin
 for i := 0 to high(table) do
  if uppercase(name) = table[i].name then
  raise FormulaException.Create('Function already defined');
 for i := 0 to high(userfunc) do
  if uppercase(name) = userfunc[i].name then
  raise FormulaException.Create('Function already defined');
 i := high(userfunc)+1;
 if i = 255 then raise FormulaException.Create('To many user functions defined');
 setlength(userfunc,i+1);
 new(userfunc[i]);
 userfunc[i].name := uppercase(name);
 userfunc[i].paramcount := paramcount;
 userfunc[i].fun := fun;
 userfunc[i].module := ismodule;
 result := userfunc[i];
end;

procedure TArtFormula.AddUserConstant(name,value : string);
var i:integer;
begin
 for i := 0 to high(consttable) do
  if uppercase(name) = consttable[i].name then
  raise FormulaException.Create('Constant already defined');
 i := high(consttable)+1;
 setlength(consttable,i+1);
 consttable[i].name := uppercase(name);
 consttable[i].value := value;
end;

function TArtFormula.Parser(flag:boolean; unq:boolean; getident:boolean): integer;
var oldpos,oldspos,oldlines : integer;
function Internal : integer;
var s : string;
    i : integer;
    c : char;
begin
 try
  ferror := ER_Ok;
  c := input[pos];
  tmp := '';
  if c in [' ',#13,#10,#9] then
  begin
   repeat
    if c = #10 then
    begin
     spos := 1;
     inc(lines);
     soffset := 0;
    end;
    inc(pos);
    inc(spos);
    c := input[pos]
   until not (c in [' ',#13,#10,#9]);
  end;

 if c = '{' then
 begin
  inc(pos);
  inc(spos);
  c := input[pos];
  while (c <> '}') and (c <> #0) do
  begin
   inc(pos);
   inc(spos);
   c := input[pos];
   if c = #10 then
   begin
    spos := 1;
    inc(lines);
   end;
  end;
  while (c = '}') or (c in [' ',#13,#10,#9]) do
  begin
   if c = #10 then
    begin
     spos := 1;
     inc(lines);
    end;
   inc(pos);
   inc(spos);
   c := input[pos];
  end;
 end;

 if (c = '/') and (input[pos+1] = '/') then
 begin
  while not (c in [#10,#0]) do
  begin
   inc(pos);
   c := input[pos];
  end;
  spos := 1;
  inc(lines);
  inc(pos);
  result := Parser(flag, unq, getident);
  exit;
 end;

 if c = #0 then
 begin
  result := F_EOS;
  exit;
 end;

 if (c = '"') or (c = '''') or (c = '#') then
 begin
  while (c = '"') or (c = '''') or (c = '#') do
  begin
   inc(pos);
   inc(spos);
   if (c = '''') or (c = '"') then
   begin
    while input[pos] <> c do
    begin
     tmp := tmp + input[pos];
     inc(pos);
     inc(spos);
     if (input[pos] = c) and (input[pos+1] = c) then
     begin
      tmp := tmp + c;
      inc(pos,2);
      inc(spos,2);
     end;
    end;
    inc(pos);
    inc(spos);
   end
   else
   begin
    s := '';
    while input[pos] in ['0'..'9'] do
    begin
     s := s + input[pos];
     inc(pos);
     inc(spos);
    end;
    tmp := tmp + chr(strtoint(s));
   end;
   c := input[pos];
  end;
  result := F_STR;
  exit;
 end;

 if system.pos(c,fvarname)>0  then
 begin
  repeat
   if not fcasesensitive and (c >= 'a')and(c <= 'z') then
     c := chr(ord(c) + ord('A') - ord('a'));
   tmp := tmp + c;
   inc(pos);
   inc(spos);
   c := input[pos];
  until (system.pos(c,fvarname)=0) and not (c in ['0'..'9']);

  if uppercase(tmp) = 'XOR' then
  begin
   result :=  byte(F_XOR);
   exit;
  end;

  if uppercase(tmp) = 'PI' then
  begin
   result :=  F_DATA;
   data := Pi;
   exit;
  end;

  if uppercase(tmp) = 'CONDITION' then
  begin
   result := byte(F_IF);
   exit;
  end;

  if uppercase(tmp) = 'LOOP' then
  begin
   result := byte(F_WHILE);
   exit;
  end;

  if uppercase(tmp) = 'TILL' then
  begin
   result := byte(F_UNTIL);
   exit;
  end;

  if uppercase(tmp) = 'SERIES' then
  begin
   result := byte(F_FOR);
   exit;
  end;

  if uppercase(tmp) = 'RETURN' then
  begin
   result := byte(F_RETURN);
   exit;
  end;

  for i := 0 to high(ConstTable) do
  begin
   if uppercase(tmp) = consttable[i].name then
   begin
    input := copy(input,1,pos-1-length(tmp))+ consttable[i].value + copy(input,pos,length(input)-pos+1);
    pos := pos - length(tmp);
    spos := spos - length(tmp);
    soffset := soffset + length(tmp) - length(consttable[i].value);
    offset := offset + length(tmp) - length(consttable[i].value);
    result := Parser;
    exit;
   end;
  end;

  if getident then
  begin
   result := F_IDENT;
   exit;
  end;

  for i := 0 to NUMFUN - 1 do
   if uppercase(tmp) = table[i].name then
   begin
      result := byte(F_FUN);
      data := i;
      exit;
   end;

  for i := 0 to high(userfunc) do
   if uppercase(tmp) = userfunc[i].name then
   begin
      result := byte(F_USERF);
      data := i;
      exit;
   end;

  for i := 0 to numofvar - 1 do
  begin
   if not fcasesensitive then s := uppercase(varnames[i])
   else s := varnames[i];
   if tmp = s then
    begin
      data := i;
      usedvars[i] := true;
      result := F_VAR;
      exit;
    end;
  end;

  if fexgetvar then
  begin
   result := byte(F_GETVAR);
   exit;
  end;

  if funquotedstring or unq then
  begin
   result := F_STR;
   exit;
  end;
  ferror := ER_UNKNOWN;
  dec(pos);
  dec(spos);
  result := 0;
  exit;
 end;

 if c = '$' then
 begin
  inc(pos);
  inc(spos);
  c := input[pos];

  tmp := '$';
  if c in ['0'..'9'] then
  begin
   tmp := tmp +c;
   inc(pos);
   inc(spos);
   c := input[pos];
   while c in ['0'..'9','a'..'f','A'..'F'] do
   begin
    tmp := tmp + c;
    inc(pos);
    inc(spos);
    c := input[pos];
   end;
  end;
  if tmp = '$' then
  begin
   result := byte('$');
   exit;
  end;
  data := strtoint(tmp);
  result := F_DATA;
  exit;
 end;


 if((c>='0')and (c<='9')) then
 begin
  repeat
   tmp := tmp + c;
   inc(pos);
   inc(spos);
   c := input[pos];
  until not((c>='0')and(c<='9'));

  if(c <> '.') then
  begin
   data := strtofloat(tmp);
   result := F_DATA;
   exit;
  end;

  tmp := tmp + c;
  inc(pos);
  inc(spos);
  c := input[pos];
  while((c>='0')and(c<='9')) do
  begin
   tmp := tmp + c;
   inc(pos);
   inc(spos);
   c := input[pos];
  end;

  if((c <> 'E')and(c <> 'e')) then
  begin
   data := strtofloat(tmp);
   result := F_DATA;
   exit;
  end;

  tmp := tmp + c;
  inc(pos);
  inc(spos);
  c := input[pos];
  if((c = '+')or(c = '-')) then
  begin
   tmp := tmp + c;
   inc(pos);
   inc(spos);
   c := input[pos];
  end;

  while((c>='0')and(c<='9')) do
  begin
    tmp := tmp + c;
    inc(pos);
    inc(spos);
    c := input[pos];
  end
 end;

 if c  in ['%','+','-','[',']','(',')','.','*','/', '^',';',',','!','=','&','|','@','\'] then
 begin
  inc(pos);
  inc(spos);
  if c = ';' then c := ',';
  if (c = ',') and (Parser(true) = byte(')')) then
  begin
   c := chr(Parser);
  end
  else
  if (c = '+') and (Parser(true) = byte('+')) then
  begin
   Parser;
   c := chr(F_INC);
  end
  else
  if (c = '-') and (Parser(true) = byte('-')) then
  begin
   Parser;
   c := chr(F_DEC);
  end;
  result := byte(c);
  exit;
 end;

 if c = ':' then
 begin
  inc(pos);
  inc(spos);
  if input[pos] = '=' then
  begin
   inc(pos);
   inc(spos);
   result := byte(F_LET);
   exit;
  end;
  result := 0;
  ferror := ER_SYNTAX;
  exit;
 end;

 if c = '>' then
 begin
  inc(pos);
  inc(spos);
  if input[pos] = '=' then
  begin
   inc(pos);
   inc(spos);
   result := byte(F_GE);
   exit;
  end;
  result := byte(c);
  exit;
 end;

  if c = '<' then
 begin
  inc(pos);
  inc(spos);
  if input[pos] = '=' then
  begin
   inc(pos);
   inc(spos);
   result := byte(F_LE);
   exit;
  end;
  if input[pos] = '>' then
  begin
   inc(pos);
   inc(spos);
   result := byte(F_NE);
   exit;
  end;
  result := byte(c);
  exit;
 end;

 except
  ferror := ER_SYNTAX;
  result := 0;
  exit;
 end;
 ferror := ER_ILLEGAL;
 result := 0;
 exit;
end;
begin
 if flag then
 begin
  oldpos := pos;
  oldspos := spos;
  oldlines := lines;
 end;
 result := Internal;
 if flag then
 begin
  pos := oldpos;
  spos := oldspos;
  lines := oldlines;
 end;
end;


const err_strings : array [TFormulaError] of string =
('Ok', 'Illegal character', 'Unknown identifier', '")" expected', '"(" expected',
  'Syntax error', 'Variable not used','Not enough parameters');

function TArtFormula.ErrString : string;
begin
 result := err_strings[ferror];
 case ferror of
 ER_ILLEGAL: result := result + ' '''+input[pos]+'''';
 ER_UNKNOWN: result := result + ' '''+tmp+'''';
 end;
end;

function TArtFormula.Compile(instr : string; num : byte; vars : PStringArray) : string;
var ch: char;
begin
 ch := decimalseparator;
 decimalseparator := '.';
 S.pos := 0;
 C.Clear;
 if not Test(instr, num, vars) then