formula.pas

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

(*

ArtFormula v1.1 


--------------------------------------------------------------------------------

ArtFormula package contains two nonvisual Delphi component for symbolic
expression parsing and evaluation. Provides runtime scripting engine for
automating your programs.

TArtFormula description 

Properties: 

property Error : TFormulaError; - returns current error code. 

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

property ErrPos : integer; - returns position of error. 

property ErrLine : integer; - returns the line with error.

property ErrStrPos : integer; - returns the position of error inside source
string.

property Stop : boolean; - set Stop to true during computation to stop. 

property Compiled : string; - byte code of compiled source string. 

Published properties: 

property UnQuotedString : boolean; - if true, ArtFormula will consider unknown
identifiers as string literals.

property TestUsedVars : boolean; - if true, ArtFormula will test whether all
external variables, passed as vars parameter of Compile or Test procedure, are
used in source expression.

property CaseSensitive : boolean; - if true, ArtFormula will distinguish case
of characters in variables name. Note: functions names are always case
insensitive.

property Step : boolean; - if true, you can stop computation, by setting Stop
property to true. If false you can't stop computation until it ends.

property CaseSensitiveString : boolean; - if true, ArtFormula will distinguish
case of string characters in comparison operations and in pos function.

property ExternGetVar : boolean; - if set, ArtFormula will use GetVarValue and
GetVarsCount events to evaluate unspecified external variables.

property VarNameLiterals : string; - defines set of literals, allowed for
variable names.

Methods: 

procedure SetVar(name : string; value : PCalcItem); - sets value of variable,
given by name parameter.

function GetVar(name : string) : PCalcItem; - returns value of variable. 

function IncVar(name : string) : PCalcItem; - increments value of a variable. 

function DecVar(name : string) : PCalcItem; - decrements value of a variable. 

procedure AddVar(name : string; value : PCalcItem); - adds internal variable. 

procedure AddUserConstant(name, value : string); - adds new constant. 

function AddUserFunction(name : string; paramcount:integer;
fun : pformulafunction; ismodule:boolean=false):PTableItem; - adds user
function.

function AddModuleFunction(module: PTableItem; name : string;
paramcount:integer; fun : pformulafunction; ismodule:boolean=false):PTableItem;
- adds module function.

function Test(instr : string; num : byte = 0; vars : PStringArray = nil) :
boolean; - tests syntax of source code represented by instr. External variable
names are passed as vars parameter, num specifies number of external variables.
Returns true if there are no errors.

function Compile(instr : string; num : byte = 0; vars : PStringArray = nil) :
string; - compiles source string and returns compiled byte code. On error raises
exception.

function ComputeN(num : byte = 0; vals : PCalcArray = nil) : double; - compute
previously compiled program and returns result as numeric value. Values of
extern variables are passed in vals parameter, the number of values is passed in
num value.

function Compute(num : byte = 0; vals : PCalcArray = nil) : string; - compute
previously compiled program and returns result as string value.

function ComputeStrN(instr : string; num : byte = 0; vars : PStringArray = nil;
vals : PCalcArray = nil) : double; - compiles and computes source string.
Returns result as numeric value.

function ComputeStr(instr : string; num : byte = 0; vars : PStringArray = nil;
vals : PCalcArray = nil) : string; - compiles and computes source string.
Returns result as string value.

procedure StartGetVars(n : integer); - starts new parameters evaluation for
variable argument list function.

function GetNextVar(var x : TCalcItem) : boolean; - evaluates next variable
argument list function parameter. Returns false for last value.

Events:

property GetVarsCount : TArtFormulaGetVarsCountProc;
TArtFormulaGetVarsCountProc = procedure(Vname:string; var count:integer) of
object;
If you set ExternGetVars all unknown identifiers will treated as external
variables. To evaluate them you should implement GetVarsCount and GetVarValue
event handlers. GetVarsCount should return in count parameter number of values
associated with Vname variable.

property GetVarValue : TArtFormulaGetVarProc;
TArtFormulaGetVarProc = procedure(Vname:string; n : integer; var Val:string) of
object;
GetVarValue should return in Val parameter n-th value associated with Vname
variable. n will change from 0 to count-1 where count returned by GetVarsCount
event.

Note. Using GetVarsCount and GetVarValue you can implement for example range
calculation in spreadsheet application when one parameter passed in variant
argument list function associated with number of cells.

Note. For fixed argument list function ArtFormula will evaluate only first value
associated with variable.

--------------------------------------------------------------------------------
Author 
Artem V. Parlyuk, e-mail:[e-mail], http://artsoft.nm.ru 

--------------------------------------------------------------------------------
License and disclaimer agreement 
IMPORTANT - READ CAREFULLY

This license and disclaimer statement constitutes a legal agreement
("License Agreement") between you (either as an individual or a single
entity) and Artem Parlyuk (the "Author"), for this software product in
this particular case TArtFormula Delphi package ("Software"), including
any software, media, and accompanying on-line or printed documentation.

BY DOWNLOADING, INSTALLING, COPYING, OR OTHERWISE USING THE SOFTWARE,
YOU AGREE TO BE BOUND BY ALL OF THE TERMS AND CONDITIONS OF THIS LICENSE
AND DISCLAIMER AGREEMENT. If you do not agree with the terms and
conditions of this agreement, you must promptly cease all use of the
software and destroy all copies of this software and all of its component
parts in your possession or under your control.

This Software is owned by Author and is protected by copyright law
and international copyright treaty.

This Software is freeware. You are granted the permission to use
Software in your own applications for private or commercial purposes,
provided your software contains the copyright notice "TArtFormula
Delphi package Copyright (c) by Artem Parlyuk" and link to the Author
site (http://artsoft.nm.ru) and Author e-mail (mailto:[e-mail]) .

You can freely distribute copies of the main archive as long as no
alterations are made to the contents and no charge is raised except
a reasonable fee for distributing costs. You may not remove copyright
notices from copies of the Software. You may not claim this Software
as written by anyone but Author, Artem Parlyuk.

The author has taken all possible care to ensure the software is
error-free, however the author disavows any potential liability
arising from any use of the software. This software is provided
"as is" and without any warranties expressed or implied, including,
but not limited to, implied warranties of fitness for a particular
purpose, and non-infringement. You expressly acknowledge and agree
that use of the Software is at your sole risk.

In no event shall the author be liable for any damages whatsoever
(including, without limitation, damages for loss of business profits,
business interruption, loss of business information, or other pecuniary
loss) arising out of the use of or inability to use this software or
documentation, even if the author has been advised of the possibility
of such damages.

Any feedback given to the Author will be treated as non-confidential.
The Author may use any feedback free of charge without limitation.

*)

unit formula;

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;
 TArtFormula = class;

 TFormulaCalc = class;

 TFormulaDataType = (fdtnumber, fdtstring, fdtgetvar);

 TCalcItem = record
   data : double;
   str : string;
   typ : TFormulaDataType;
 end;

 TCalcArray = array of TCalcItem;
 PCalcItem = ^TCalcItem;
 PCalcArray = ^TCalcArray;

 pformulafunction = function(var Calc : TFormulaCalc):TCalcItem;

 PTableItem = ^FTableItem;

 FTableItem = record
      name : string;
      paramcount : integer;
      fun : pformulafunction;
      module : boolean;
      funs : array of PTableItem;
 end;

 ATableItem = array of PTableItem;
 PATableItem = ^ATableItem;

 TFormulaStack = class
 protected
  max,pos : integer;
  data : array of char;
  Parent : TArtFormula;
 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;
 end;

 TFormulaCalc = class
 protected
  max,pos : integer;
  data : TCalcArray;
  fParent : TArtFormula;
 public
  property Parent : TArtFormula read fParent;
  constructor Create(i:integer=256);
  destructor Free;
  property Num : integer read pos;

  procedure Clear;
  function TopN: double;
  function TopS: String;
  procedure PushN(n:double);
  procedure PushS(s:string);
  procedure Push(var x: TCalcItem);
  function PopN : double;
  function PopS : string;
  function ItemN(i:integer):double;
  function ItemS(i:integer):string;
  function Item(i:integer):PCalcItem;
  procedure Plus;
  procedure PlusS;
  procedure Minus;
  procedure Mult;
  procedure cDiv;
  procedure Division;
  procedure cMod;
  procedure Pow;
  procedure EQ;
  procedure NE;
  procedure LE;
  procedure LT;
  procedure GE;
  procedure GT;
  procedure cAND;
  procedure cOR;
  procedure cXOR;
  procedure cNOT;
  procedure Uminus;
  procedure DoFunction(fun:pformulafunction; cnt:integer; module : boolean = false);
end;

 StringArray = array of String;
 PStringArray = ^StringArray;

 TConstItem = record
  name, value : string;
 end;

TArtFormulaGetVarProc =  procedure(Vname:string; n : integer; var Val:string; wantnumber:boolean=false) of object;
TArtFormulaGetVarsCountProc =  procedure(Vname:string; var count:integer; wantnumbe:boolean=false) of object;

TArtFormula = class(TComponent)
  protected
   offset, soffset, pos, numofvar, spos, lines : integer;
   ferror : TFormulaError;
   fstop : boolean;
   fstep : boolean;
   fexgetvar : boolean;
   fgetvar :  TArtFormulaGetVarProc;
   fgetvarscount : TArtFormulaGetVarsCountProc;
   ftestused : boolean;
   fcasesensitive, fcasesensitivestring : boolean;
   funquotedstring : boolean;
   fvarname : string;
   S : TFormulaStack;
   C : TFormulaCalc;
   input : string;
   temp,tmp : string;
   varnames : StringArray;
   values : TCalcArray;
   data : double;

   ncnt, gvcnt, gvpos, npos : integer;
   vals : array of string;


   usedvars : array of boolean;
   userfunc : ATableItem;
   ConstTable : array of TConstItem;
   formula_err : TFormulaError;
   fcompiled : string;
   function Parser(flag:boolean=false; unq : boolean = false; getident : boolean = false) : integer;
   function Form: integer;
   function ErrString: string;
   function FindVar(name : string): integer;
   function GetPos:integer;
   function GetSPos:integer;
   procedure IntCompute(compiled : string; num : byte; vals : PCalcArray);
  public
   constructor Create(AOwner: TComponent); override;
   destructor Free;

   procedure SetVar(name : string; value : PCalcItem);
   function GetVar(name : string) : PCalcItem;
   function IncVar(name : string) : PCalcItem;
   function DecVar(name : string) : PCalcItem;
   procedure AddVar(name : string; value : PCalcItem);

   procedure StartGetVars(n : integer);
   function GetNextVar(var x : TCalcItem; wantnumber : boolean=false) : boolean;

   function AddUserFunction(name : string; paramcount:integer; fun : pformulafunction; ismodule:boolean=false):PTableItem;
   function AddModuleFunction(module: PTableItem; name : string; paramcount:integer; fun : pformulafunction; ismodule:boolean=false):PTableItem;
   procedure AddUserConstant(name, value : string);

   property Error : TFormulaError read ferror;
   property ErrPos : integer read GetSpos;
   property ErrLine : integer read lines;
   property ErrStrPos : integer read GetPos;
   property Stop : boolean write fstop;
   property Compiled : string read fcompiled write fcompiled;

   function Test(instr : string; num : byte = 0; vars : PStringArray = nil) : boolean;
   function Compile(instr : string; num : byte = 0; vars : PStringArray = nil) : string;

   function ComputeN(num : byte = 0; vals : PCalcArray = nil) : double;
   function Compute(num : byte = 0; vals : PCalcArray = nil) : string;
   function ComputeStrN(instr : string; num : byte = 0; vars : PStringArray = nil; vals : PCalcArray = nil) : double;
   function ComputeStr(instr : string; num : byte = 0; vars : PStringArray = nil; vals : PCalcArray = nil) : string;

   published

   property UnQuotedString : boolean read funquotedstring write funquotedstring;
   property TestUsedVars : boolean read ftestused write ftestused default false;
   property CaseSensitive : boolean read fcasesensitive write fcasesensitive default false;
   property Step : boolean read fstep write fstep;
   property CaseSensitiveString : boolean read fcasesensitivestring write fcasesensitivestring default true;
   property ExternGetVar : boolean read fexgetvar write fexgetvar;
   property VarNameLiterals : string read fvarname write fvarname;
   property GetVarValue : TArtFormulaGetVarProc read fgetvar write fgetvar;
   property GetVarsCount : TArtFormulaGetVarsCountProc read fgetvarscount write fgetvarscount;
end;

function getN(var x : TCalcItem; AF : TArtFormula = nil) : double;
function getS(var x : TCalcItem; AF : TArtFormula = nil) : string;
procedure setN(var x : TCalcItem; n:double);
procedure setS(var x : TCalcItem; s:string);

procedure Register;

implementation

{$J+}

uses math, formulaf, forms;

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;
 F_XOR = #247;
 F_STR = 246;
 F_FUN = #245;
 F_IF = #244;
 F_WHILE = 243;
 F_GO = #242;
 F_POP = #241;
 F_LET = 240;
 F_UNTIL = 239;
 F_FOR = 238;
 F_INC = 237;
 F_DEC = 236;
 F_IDENT = 235;
 F_MFUN = #234;
 F_IDXF = #233;
 F_IDXF1 = #232;
 F_GETVAR = 231;
 F_RETURN = #0;

 IDX_SET = 0;
 IDX_VAL = 1;
 IDX_INC = 5;
 IDX_DEC = 6;

 NUMFUN = 72;

const
 table : array [0..NUMFUN-1] of FTableItem =
(
 (name:'SET';paramcount:2;fun:myset),
 (name:'VAL';paramcount:1;fun:myval),
 (name:'DEFINE';paramcount:2;fun:myvar),
 (name:'BLOCK';paramcount:-1;fun:myblock),
 (name:'DEFINES';paramcount:-1;fun:myvars),
 (name:'INC'; paramcount:1;fun:myinc),
 (name:'DEC'; paramcount:1;fun:mydec),
 (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:'RANDOMIZE';paramcount:0;fun:myrandomize),
 (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:'CONCAT';paramcount:-1;fun:myconcat),
 (name:'SUMOFSQUARES';paramcount:-1;fun:mysumofsquares),
 (name:'COUNT';paramcount:-1;fun:mycount),
 (name:'VARIANCE';paramcount:-1;fun:myvariance),
 (name:'VARIANCEP';paramcount:-1;fun:myvarp),
 (name:'IFF';paramcount:3;fun:myiff),
 (name:'CHR';paramcount:1;fun:mychr),
 (name:'LENGTH';paramcount:1;fun:mylength),
 (name:'TRIM';paramcount:1;fun:mytrim),
 (name:'TRIMLEFT';paramcount:1;fun:mytrimleft),
 (name:'TRIMRIGHT';paramcount:1;fun:mytrimright),
 (name:'UPPERCASE';paramcount:1;fun:myuppercase),
 (name:'LOWERCASE';paramcount:1;fun:mylowercase),
 (name:'MIDSTR';paramcount:3;fun:mymidstr),
 (name:'LEFTSTR';paramcount:2;fun:myleftstr),
 (name:'RIGHTSTR';paramcount:2;fun:myrightstr),
 (name:'POS';paramcount:2;fun:mypos),
 (name:'DATE';paramcount:1;fun:mydate),
 (name:'NOW';paramcount:0;fun:mynow),
 (name:'DAYOFWEEK';paramcount:1;fun:myweek),
 (name:'YEAR';paramcount:1;fun:myyear),
 (name:'MONTH';paramcount:1;fun:mymonth),
 (name:'DAY';paramcount:1;fun:myday),
 (name:'HOUR';paramcount:1;fun:myhour),
 (name:'MINUTE';paramcount:1;fun:myminute),
 (name:'SECOND';paramcount:1;fun:mysecond),
 (name:'MILLISECOND';paramcount:1;fun:mymillisecond),
 (name:'ISLEAPYEAR';paramcount:1;fun:myleapyear),
 (name:'ENCODEDATE';paramcount:3;fun:myencodedate),
 (name:'FORMAT';paramcount:2;fun:myformat),
 (name:'FORMATF';paramcount:2;fun:myformatf),
 (name:'FORMATDATE';paramcount:2;fun:myformatdate),
 (name:'ISNUMBER';paramcount:1;fun:myisnumber),
 (name:'CODE';paramcount:1;fun:mycode),
 (name:'STRINGOFCHAR';paramcount:2;fun:mystring),
 (name:'INPUT';paramcount:3;fun:myinput),
 (name:'MSG';paramcount:3;fun:mymsg)
 );

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

function getN(var x : TCalcItem; AF : TArtFormula) : double;
var val:string;
begin
 if x.typ = fdtgetvar then
 //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,val);
   result := strtofloat(val);
 end
 else if x.typ = fdtnumber then result := x.data
 else result := strtofloat(x.str);
end;

procedure setN(var x : TCalcItem; n:double);
begin
 x.typ := fdtnumber;
 x.data := n;
end;

function getS(var x : TCalcItem; AF : TArtFormula) : string;
begin
 if x.typ = fdtgetvar then