formulan.pas

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

(*
This unit is part of TArtFormula package.
See formula.pas for notes, License and disclaimer agreement.

(c) Artem V. Parlyuk, e-mail:[e-mail], http://artsoft.nm.ru
*)
unit formulan;

interface
uses SysUtils, classes;

type

 TFormulaError = (ER_Ok, ER_ILLEGAL, ER_UNKNOWN, ER_RIGHT, ER_LEFT, ER_SYNTAX, ER_VARS,
   ER_NOTENOUGH);

 FormulaException = class(Exception)
 end;
 TArtFormulaN = class;

 TFormulaStackN = class
 protected
  max,pos : integer;
  data : array of char;
  Parent : TArtFormulaN;
 public
  constructor Create(i:integer=256);
  destructor Free;
  property Num : integer read pos;
  function Top : char;
  procedure Push(c : char);
  function Pop:char;
  function PopEx : string;
  function Item(i:integer) : char;
 end;

 pformulafunctionN = function(pos : integer; var data : array of double) : double;

 StringArray = array of String;
 DoubleArray = array of double;
 PStringArray = ^StringArray;
 PDoubleArray = ^DoubleArray;

 FTableItem = record
      name : string;
      paramcount : integer;
      fun : pformulafunctionN;
 end;

 TConstItem = record
  name, value : string;
 end;

TArtFormulaN = class(TComponent)
  protected
   max,cpos : integer;
   cdata : array of double;
   pos, numofvar : integer;
   ferror : TFormulaError;
   ftestused : boolean;
   fcompiled : string;
   fcasesensitive : boolean;
   S : TFormulaStackN;
   input : string;
   temp : string;
   varnames : PStringArray;
   data : double;
   usedvars : array of boolean;
   userfunc : array of FTableItem;
   ConstTable : array of TConstItem;
   formula_err : TFormulaError;
   function Parser(flag:boolean=false) : integer;
   function Form: integer;
   function ErrString: string;
  public
   property Error : TFormulaError read ferror;
   property ErrPos : integer read pos;
   property Compiled : string read fcompiled;

   constructor Create(AOwner: TComponent); override;
   destructor Free;

   procedure AddUserFunction(name : string; paramcount:integer; fun : pformulafunctionN);
   procedure AddUserConstant(name, value : string);

   function Test(instr : string; num : byte = 0; vars : PStringArray = nil) : boolean;
   function Compile(instr : string; num : byte = 0; vars : PStringArray = nil) : string;
   function Compute(vals : PDoubleArray = nil) : double;
   function ComputeStr(instr : string; num : byte = 0; vars : PStringArray = nil; vals : pdoublearray = nil) : double;
  published
   property TestUsed : boolean read ftestused write ftestused;
   property CaseSensitive : boolean read fcasesensitive write fcasesensitive;
end;

procedure Register;

implementation

{$J+}

uses math, formulanf;

const
 F_EOS = -1;
 F_DATA = 254;
 F_VAR = 253;
 F_NE = #252;
 F_UMINUS = #251;
 F_GE = #250;
 F_LE = #249;
 F_USERF = #248;

 NUMFUN = 33;

const
 table : array [0..NUMFUN-1] of FTableItem =
(
 (name:''),
 (name:'SIN'; paramcount:1;fun:mysin),
 (name:'COS';paramcount:1;fun:mycos),
 (name:'TAN';paramcount:1;fun:mytan),
 (name:'LOG';paramcount:1;fun:mylog),
 (name:'LG';paramcount:1;fun:mylg),
 (name:'EXP';paramcount:1;fun:myexp),
 (name:'SQRT';paramcount:1;fun:mysqrt),
 (name:'INT';paramcount:1;fun:myint),
 (name:'FRAC';paramcount:1;fun:myfrac),
 (name:'ABS';paramcount:1;fun:myabs),
 (name:'ATAN';paramcount:1;fun:myatan),
 (name:'ASIN';paramcount:1;fun:myasin),
 (name:'ACOS';paramcount:1;fun:myacos),
 (name:'ASINH';paramcount:1;fun:myasinh),
 (name:'ACOSH';paramcount:1;fun:myacosh),
 (name:'ATANH';paramcount:1;fun:myatanh),
 (name:'COSH';paramcount:1;fun:mycosh),
 (name:'SINH';paramcount:1;fun:mysinh),
 (name:'TANH';paramcount:1;fun:mytanh),
 (name:'SIGN';paramcount:1;fun:mysign),
 (name:'RND';paramcount:0;fun:myrnd),
 (name:'MAX';paramcount:-1;fun:mymax),
 (name:'MIN';paramcount:-1;fun:mymin),
 (name:'AVG';paramcount:-1;fun:myavg),
 (name:'STDDEV';paramcount:-1;fun:mystddev),
 (name:'STDDEVP';paramcount:-1;fun:mystddevp),
 (name:'SUM';paramcount:-1;fun:mysum),
 (name:'SUMOFSQUARES';paramcount:-1;fun:mysumofsquares),
 (name:'COUNT';paramcount:-1;fun:mycount),
 (name:'VARIANCE';paramcount:-1;fun:myvar),
 (name:'VARIANCEP';paramcount:-1;fun:myvarp),
 (name:'IFF';paramcount:3;fun:myiff)
 );

function isznak(c : char) : boolean;
begin
 result := c in ['+','-','*','/','%','^','>','<','=','&','|',F_NE,F_LE,F_GE];
end;

function isfun(c : char) : boolean;
begin
 result := ((c > #0)and(byte(c) < NUMFUN));
end;


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

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

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

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

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

function TFormulaStackN.PopEx : string;
begin
if pos > 0 then
begin
 dec(pos);
 if data[pos] = F_USERF then
 begin
  result := F_USERF + data[pos-1] + chr(Parent.userfunc[byte(data[pos-1])].paramcount);
  dec(pos);
 end
 else
 if isfun(data[pos]) then
  result := data[pos] + chr(table[byte(data[pos])].paramcount)
 else result := data[pos];
end
else result := #0;
end;


function TFormulaStackN.Item(i:integer) : char;
begin
 if (i >= 0) and (i < pos) then result := data[i]
 else result := #0;
end;

function prior(a,b : char) : boolean;
var pa,pb:integer;
begin
 if isfun(a) 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 ['|','&'] 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 isfun(b) 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 ['|','&'] then pb := 6
 else if b in ['<','>','=',F_NE,F_GE,F_LE] then pb := 7
 else if b in ['(',')'] then pb := 8
 else pb := 100;

 result := pa >= pb;

end;

destructor TArtFormulaN.Free;
begin
 S.Free;
 usedvars := nil;
 userfunc := nil;
 cdata := nil;
 inherited Free;
end;

constructor TArtFormulaN.Create(AOwner: TComponent);
begin
 inherited Create(AOwner);
 pos := 1;
 ferror := ER_Ok;
 input :=#0;
 usedvars := nil;
 S := TFormulaStackN.Create();
 S.Parent := self;
 max := 128;
 cpos := 0;
 setlength(cdata,128);
 AddUserConstant('PI','3.1415926535897932385');
 AddUserConstant('FALSE','0');
 AddUserConstant('TRUE','1');
end;

procedure TArtFormulaN.AddUserFunction(name : string; paramcount:integer; fun : pformulafunctionN);
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);
 userfunc[i].name := uppercase(name);
 userfunc[i].paramcount := paramcount;
 userfunc[i].fun := fun;
end;

procedure TArtFormulaN.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 TArtFormulaN.Parser(flag:boolean): integer;
var tmp,s : string;
    i : integer;
    c : char;
begin
 ferror := ER_Ok;
 c := input[pos];
 tmp := '';
 if c in [' ',#9,#10,#13] then
 begin
  repeat
   inc(pos);
   c := input[pos];
  until not (c in [' ',#9,#10,#13]);
 end;

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

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

 if flag then
 begin
  result := byte(c);
  exit;
 end;

 if(((c >= 'A')and(c <= 'Z'))or((c >= 'a')and(c <= 'z'))) 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);
   c := input[pos];
  until not(((c >= 'A')and(c <= 'Z'))or((c >= 'a')and(c <= 'z'))or
        ((c <= '9')and(c >= '0')));

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

  for i := 1 to NUMFUN - 1 do
   if uppercase(tmp) = table[i].name then
   begin
      result := 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;
  ferror := ER_UNKNOWN;
  result := 0;
  exit;
 end;


 if((c>='0')and (c<='9')) then
 begin
  repeat
   tmp := tmp + c;
   inc(pos);
   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);
  c := input[pos];
  while((c>='0')and(c<='9')) do
  begin
   tmp := tmp + c;
   inc(pos);
   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);
  c := input[pos];
  if((c = '+')or(c = '-')) then
  begin
   tmp := tmp + c;
   inc(pos);
   c := input[pos];
  end;

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

 if c  in ['%','+','-','(',')','*','/', '^', ',','!','=','&','|'] then
 begin
  inc(pos);
  result := byte(c);
  exit;
 end;

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

  if c = '<' then
 begin
  inc(pos);
  if input[pos] = '=' then
  begin
   inc(pos);