How to make formula programmable ?

Dear Sir,
How to let user define formula for their own?
For Example:
S=@Price  P=Profit% F=Freight% I=Insurance% C=Commision%. These vars are not changeable, user can set values of their own.

The formula can be defined by user as:
(S*(1+P)+F)*(1+I)  or (S/(1-P)+F)/(1-I)/(1-C) or (S*(1+P)+F)*(1+C) or .......... (as they wish)

Thanks for your help!

daniel710624Asked:
Who is Participating?
 
Russell LibbyConnect With a Mentor Software Engineer, Advisory Commented:
If your looking for something a little smaller for math parsing, you can use the following code

Russell

---

example usage:

var  dblResult:     Double;
begin

  // Set variables
  //    S=@Price  P=Profit% F=Freight% I=Insurance% C=Commision%
  //
  SetVar('S', 120.99);
  SetVar('P', 45.99);
  SetVar('F', 5.99);
  SetVar('I', 1.20);
  SetVar('C', 3.45);

  // Evaluate expressions
  if Evaluate('(S*(1+P)+F)*(1+I)', dblResult) then ShowMessage(FloatToStr(dblResult));
  if Evaluate('(S/(1-P)+F)/(1-I)/(1-C)', dblResult) then ShowMessage(FloatToStr(dblResult));
  if Evaluate('(S*(1+P)+F)*(1+C)', dblResult) then ShowMessage(FloatToStr(dblResult));

end;


--- Eval.pas ---

unit Eval;
////////////////////////////////////////////////////////////////////////////////
//
//   Unit        :  EVAL
//   Classes     :  TEvalExpr
//   Author      :  rllibby
//   Date        :  02.17.2004
//
//   Description :  Numeric expression parser with support for variables A-Z.
//                  All data is treated as double type, and support for common
//                  functions such as Cos, Sin, Tan, etc have also been included.
//
////////////////////////////////////////////////////////////////////////////////
interface

////////////////////////////////////////////////////////////////////////////////
//   Include units
////////////////////////////////////////////////////////////////////////////////
uses
  Windows, SysUtils, Classes;

////////////////////////////////////////////////////////////////////////////////
//   Node definitions for hashing elements
////////////////////////////////////////////////////////////////////////////////
type
  PHashNode         =  ^THashNode;
  THashNode         =  packed record
     Item:          PChar;
     Data:          Pointer;
     Next:          PHashNode;
  end;

////////////////////////////////////////////////////////////////////////////////
//   Hashing constants
////////////////////////////////////////////////////////////////////////////////
const
  HASH_SIZE         =  521;

////////////////////////////////////////////////////////////////////////////////
//   Callback for optional freeing of the data items
////////////////////////////////////////////////////////////////////////////////
type
  THashDeallocator  =  procedure(Sender: TObject; P: Pointer) of object;

////////////////////////////////////////////////////////////////////////////////
//   Hash class definition
////////////////////////////////////////////////////////////////////////////////
type
  THash             =  class(TObject)
  private
     // Private declarations
     FHash:         Array [0..Pred(HASH_SIZE)] of PHashNode;
     FDeallocator:  THashDeallocator;
     FCareCase:     Boolean;
     FCount:        Integer;
  protected
     // Protected declarations
     function       NewNode(Item: PChar; Data: Pointer): PHashNode;
  public
     // Public declarations
     constructor    Create(Deallocator: THashDeallocator = nil);
     destructor     Destroy; override;
     procedure      Clear;
     function       Delete(Item: PChar): Boolean;
     function       Extract(Item: PChar; out Data: Pointer): Boolean;
     function       Add(Item: PChar; Data: Pointer): Boolean;
     function       Find(Item: PChar; out Data: Pointer): Boolean;
     property       Count: Integer read FCount;
     property       CaseSensitive: Boolean read FCareCase write FCareCase;
  end;

////////////////////////////////////////////////////////////////////////////////
//   Hashing functions
////////////////////////////////////////////////////////////////////////////////
function   HashFunc(Key: PChar; CareCase: Boolean): Integer;
function   HashCompare(Item1, Item2: PChar; CareCase: Boolean): Boolean;

////////////////////////////////////////////////////////////////////////////////
//   Assembly opcodes for expression evaluation
////////////////////////////////////////////////////////////////////////////////
const
  // Operations requiring 2 numbers
  OP_EQ             =  01;
  OP_LEQ            =  02;
  OP_GEQ            =  03;
  OP_LT             =  04;
  OP_GT             =  05;
  OP_NEQ            =  06;
  OP_ADD            =  07;
  OP_SUB            =  08;
  OP_DIV            =  09;
  OP_MULT           =  10;
  OP_MOD            =  11;
  OP_OR             =  12;
  OP_XOR            =  13;
  OP_AND            =  14;
  OP_SHL            =  15;
  OP_SHR            =  16;
  // Operations requiring 1 number
  OP_NEG            =  17;
  OP_NOT            =  18;
  OP_ABS            =  19;
  OP_SIN            =  20;
  OP_COS            =  21;
  OP_TAN            =  22;
  OP_ATAN           =  23;
  OP_EXP            =  24;
  OP_SQRT           =  25;
  OP_INT            =  26;
  // Special
  OP_PI             =  27;
  OP_MI             =  28;
  OP_MW             =  29;
  OP_MB             =  30;
  // Load operations
  OP_LVN            =  31;
  OP_LCN            =  32;

////////////////////////////////////////////////////////////////////////////////
//   Max limits for structures
////////////////////////////////////////////////////////////////////////////////
const
  MAX_NUM           =  32;
  MAX_STACK         =  64;
  MAX_ASM           =  124;

////////////////////////////////////////////////////////////////////////////////
//   Token constants for parsing
////////////////////////////////////////////////////////////////////////////////
type
  TEvalToken        =  (tokEq,     tokLeq,  tokLt,   tokGeq,  tokGt,   tokNeq,
                        tokAdd,    tokSub,  tokDiv,  tokMult, tokMod,  tokOr,
                        tokAnd,    tokXor,  tokNot,  tokShl,  tokShr,  tokAbs,
                        tokSin,    tokCos,  tokTan,  tokAtan, tokVar,  tokLp,
                        tokRp,     tokExp,  tokNum,  tokSqrt, tokInt,  tokPi,
                        tokMi,     tokMw,   tokMb,   tokEnd);

////////////////////////////////////////////////////////////////////////////////
//   Evaluation stack data type
////////////////////////////////////////////////////////////////////////////////
type
  TEvalStack        =  Array [0..Pred(MAX_STACK)] of Double;

////////////////////////////////////////////////////////////////////////////////
//   Data space for constants
////////////////////////////////////////////////////////////////////////////////
type
  TEvalConsts       =  Array [0..Pred(MAX_NUM)] of Double;

////////////////////////////////////////////////////////////////////////////////
//   Psuedo assembly instruction and program space definition
////////////////////////////////////////////////////////////////////////////////
type
  TEvalAsm          =  packed record
     cbAL:          Byte;
     cbDL:          Byte;
  end;
  TEvalPgm          =  Array [0..Pred(MAX_ASM)] of TEvalAsm;

////////////////////////////////////////////////////////////////////////////////
//   Token parser data type
////////////////////////////////////////////////////////////////////////////////
type
  TEvalParse        =  packed record
     etIdent:       TEvalToken;
     cbVar:         Byte;
     dblVal:        Double;
  end;

////////////////////////////////////////////////////////////////////////////////
//   Compiled expression type
////////////////////////////////////////////////////////////////////////////////
type
  TEvalCompile      =  packed record
     cbAsm:         Integer;
     epAsm:         TEvalPgm;
     cbConsts:      Integer;
     ecConsts:      TEvalConsts;
  end;

////////////////////////////////////////////////////////////////////////////////
//   Exception class for evaluation
////////////////////////////////////////////////////////////////////////////////
type
  EEvalException    =  class(Exception);

////////////////////////////////////////////////////////////////////////////////
//   Resource strings for exceptions
////////////////////////////////////////////////////////////////////////////////
resourcestring
  SUnexpected       =  'Unexpected character encountered';
  SInvalidIdent     =  'Invalid identifier encountered';
  SInvalidNum       =  'Invalid number';
  SAsmOverflow      =  'Too many operations for a single expression';
  SNumOverflow      =  'Too many constant numbers for a single expression';
  SCloseParen       =  'Closing parentheses missing';
  SOpenParen        =  'Open parentheses missing';
  SSyntaxError      =  'Syntax error in expression';
  SUnderflow        =  'Stack underflow';
  SOverflow         =  'Stack overflow';

////////////////////////////////////////////////////////////////////////////////
//   Expression evaluator class
////////////////////////////////////////////////////////////////////////////////
type
  TExprEval         =  class(TObject)
  private
     // Private declarations
     FExpression:   PChar;
     FParse:        PChar;
     FCompiled:     TEvalCompile;
     FToken:        TEvalParse;
  protected
     // Protected declarations
     function       StoreConst(dblVal: Double): Byte;
     procedure      GenOpCode(cbAL, cbDL: Byte);
     procedure      Parse;
     procedure      ParseNext;
     procedure      ParseLevel1;
     procedure      ParseLevel2;
     procedure      ParseLevel3;
     procedure      ParseLevel4;
  public
     // Public declarations
     constructor    Create(Expression: PChar);
     destructor     Destroy; override;
     function       Evaluate: Double;
     property       Expression: PChar read FExpression;
  end;

////////////////////////////////////////////////////////////////////////////////
//   Variable class for use in expression evaluation
////////////////////////////////////////////////////////////////////////////////
type
  TVariables        =  Array ['A'..'Z'] of Double;

////////////////////////////////////////////////////////////////////////////////
//   Functions for expression handling
////////////////////////////////////////////////////////////////////////////////
function   Evaluate(lpszExpression: PChar; var Value: Double): Boolean;
function   GetVar(Variable: Char; var Value: Double): Boolean;
function   SetVar(Variable: Char; Value: Double): Boolean;
function   LastEvalError: PChar;
procedure  ClearVars;

implementation

////////////////////////////////////////////////////////////////////////////////
//   Protected variables
////////////////////////////////////////////////////////////////////////////////
var
  hshIdent:         THash;
  lpVars:           TVariables;
  lpError:          Array [0..255] of Char;

function TExprEval.Evaluate: Double;
var  esStack:       TEvalStack;
     dwCount:       Integer;
     dwOffset:      Integer;
     dwStack:       Integer;
begin

  // Clear the stack
  dwStack:=0;

  // Start executing the instructions
  for dwCount:=0 to Pred(FCompiled.cbAsm) do
  begin
     // Get the instruction and offset
     case FCompiled.epAsm[dwCount].cbAL of
        // 2 number ops
        OP_EQ..OP_SHR     :
        begin
           // Check stack for underflow
           if (dwStack < 2) then raise EEvalException.CreateRes(@SUnderflow);
           // Decrement the stack count
           Dec(dwStack);
           dwOffset:=Pred(dwStack);
           // Perform the operation
           case FCompiled.epAsm[dwCount].cbAL of
              OP_EQ    :  esStack[dwOffset]:=Integer(esStack[dwOffset] = esStack[dwStack]);
              OP_LEQ   :  esStack[dwOffset]:=Integer(esStack[dwOffset] <= esStack[dwStack]);
              OP_GEQ   :  esStack[dwOffset]:=Integer(esStack[dwOffset] >= esStack[dwStack]);
              OP_LT    :  esStack[dwOffset]:=Integer(esStack[dwOffset] < esStack[dwStack]);
              OP_GT    :  esStack[dwOffset]:=Integer(esStack[dwOffset] > esStack[dwStack]);
              OP_NEQ   :  esStack[dwOffset]:=Integer(esStack[dwOffset] <> esStack[dwStack]);
              OP_ADD   :  esStack[dwOffset]:=esStack[dwOffset] + esStack[dwStack];
              OP_SUB   :  esStack[dwOffset]:=esStack[dwOffset] - esStack[dwStack];
              OP_DIV   :  esStack[dwOffset]:=esStack[dwOffset] / esStack[dwStack];
              OP_MULT  :  esStack[dwOffset]:=esStack[dwOffset] * esStack[dwStack];
              OP_MOD   :  esStack[dwOffset]:=Trunc(esStack[dwOffset]) mod Trunc(esStack[dwStack]);
              OP_OR    :  esStack[dwOffset]:=Trunc(esStack[dwOffset]) or Trunc(esStack[dwStack]);
              OP_XOR   :  esStack[dwOffset]:=Trunc(esStack[dwOffset]) xor Trunc(esStack[dwStack]);
              OP_AND   :  esStack[dwOffset]:=Trunc(esStack[dwOffset]) and Trunc(esStack[dwStack]);
              OP_SHL   :  esStack[dwOffset]:=Trunc(esStack[dwOffset]) shl Trunc(esStack[dwStack]);
              OP_SHR   :  esStack[dwOffset]:=Trunc(esStack[dwOffset]) shr Trunc(esStack[dwStack]);
           end;
        end;
        // Operation on current stack item
        OP_NEG..OP_INT    :
        begin
           // Check stack for underflow
           if (dwStack < 1) then raise EEvalException.CreateRes(@SUnderflow);
           dwOffset:=Pred(dwStack);
           // Perform the operation
           case FCompiled.epAsm[dwCount].cbAL of
              OP_NEG   :  esStack[dwOffset]:=esStack[dwOffset] * -1;
              OP_NOT   :  esStack[dwOffset]:=not(Trunc(esStack[dwOffset]));
              OP_ABS   :  esStack[dwOffset]:=Abs(esStack[dwOffset]);
              OP_SIN   :  esStack[dwOffset]:=Sin(esStack[dwOffset]);
              OP_COS   :  esStack[dwOffset]:=Cos(esStack[dwOffset]);
              OP_TAN   :  esStack[dwOffset]:=Sin(esStack[dwOffset]) / Cos(esStack[dwOffset]);
              OP_ATAN  :  esStack[dwOffset]:=ArcTan(esStack[dwOffset]);
              OP_EXP   :  esStack[dwOffset]:=Exp(esStack[dwOffset]);
              OP_SQRT  :  esStack[dwOffset]:=Sqrt(esStack[dwOffset]);
              OP_INT   :  esStack[dwOffset]:=Trunc(esStack[dwOffset]);
           end;
        end;
        // Special
        OP_PI,
        OP_MI,
        OP_MW,
        OP_MB             :
        begin
           // Push special value on the stack
           case FCompiled.epAsm[dwCount].cbAL of
              OP_PI    :  esStack[dwStack]:=pi;
              OP_MI    :  esStack[dwStack]:=MaxInt;
              OP_MW    :  esStack[dwStack]:=MaxWord;
              OP_MB    :  esStack[dwStack]:=MaxByte;
           end;
           // Increment the stack
           Inc(dwStack);
           // Check stack overflow
           if (dwStack > Pred(MAX_STACK)) then raise EEvalException.CreateRes(@SOverflow);
        end;
        // Loading operation
        OP_LVN..OP_LCN    :
        begin
           // Get the index for the item
           dwOffset:=FCompiled.epAsm[dwCount].cbDL;
           // Load either global var or constant number
           case FCompiled.epAsm[dwCount].cbAL of
              OP_LVN   :  esStack[dwStack]:=lpVars[Chr(65+dwOffset)];
              OP_LCN   :  esStack[dwStack]:=FCompiled.ecConsts[dwOffset];
           end;
           // Increment the stack
           Inc(dwStack);
           // Check stack overflow
           if (dwStack > Pred(MAX_STACK)) then raise EEvalException.CreateRes(@SOverflow);
        end;
     end;
  end;

  // Stack count should be one at this stage
  if (dwStack = 1) then
     // Push the item from the stack
     result:=esStack[0]
  else
     result:=0;

end;

procedure TExprEval.ParseLevel4;
var  etIdent:       TEvalToken;
begin

  // Low level expression evaluator
  case FToken.etIdent of
     // Negate
     tokSub      :
     begin
        // Seed the next token
        ParseNext;
        // Build factor
        ParseLevel4;
        // Generate code for negate
        GenOpCode(OP_NEG, 0);
     end;
     // Variable load
     tokVar      :
     begin
        // Generate code to load the variable
        GenOpCode(OP_LVN, FToken.cbVar);
        // Seed the next token
        ParseNext;
     end;
     // Constant number load
     tokNum      :
     begin
        // Store the number in the static data table
        FToken.cbVar:=StoreConst(FToken.dblVal);
        // Generate code to push constant number stored in code
        GenOpCode(OP_LCN, FToken.cbVar);
        // Seed the next token
        ParseNext;
     end;
     // Left paren
     tokLp       :
     begin
        // Seed the next token
        ParseNext;
        // Build the sub expression
        ParseLevel1;
        // Better be sitting at a right paren
        if (FToken.etIdent <> tokRp) then raise EEvalException.CreateRes(@SCloseParen);
        // Seed the next token
        ParseNext;
     end;
     // Single parameter functions
     tokNot,
     tokAbs,
     tokSin,
     tokCos,
     tokTan,
     tokAtan,
     tokExp,
     tokSqrt,
     tokInt      :
     begin
        // Hold the token identifier
        etIdent:=FToken.etIdent;
        // Seed next token
        ParseNext;
        // Check open parens
        if (FToken.etIdent <> tokLp) then raise EEvalException.CreateRes(@SOpenParen);
        // Seed next token
        ParseNext;
        // Build numeric expression
        ParseLevel1;
        // Better be sitting at a right paren
        if (FToken.etIdent <> tokRp) then raise EEvalException.CreateRes(@SCloseParen);
        // Seed the next token
        ParseNext;
        // Generate code
        case etIdent of
           tokNot   :  GenOpCode(OP_NOT, 0);
           tokAbs   :  GenOpCode(OP_ABS, 0);
           tokSin   :  GenOpCode(OP_SIN, 0);
           tokCos   :  GenOpCode(OP_COS, 0);
           tokTan   :  GenOpCode(OP_TAN, 0);
           tokAtan  :  GenOpCode(OP_ATAN, 0);
           tokExp   :  GenOpCode(OP_EXP, 0);
           tokSqrt  :  GenOpCode(OP_SQRT, 0);
           tokInt   :  GenOpCode(OP_INT, 0);
        end;
     end;
     // Special
     tokPi,
     tokMi,
     tokMw,
     tokMb       :
     begin
        // Generate code
        case FToken.etIdent of
           tokPi    :  GenOpCode(OP_PI, 0);
           tokMi    :  GenOpCode(OP_MI, 0);
           tokMw    :  GenOpCode(OP_MW, 0);
           tokMb    :  GenOpCode(OP_MB, 0);
        end;
        // Seed the next token
        ParseNext;
     end;
  else
     // Syntax error
     raise EEvalException.CreateRes(@SSyntaxError);
  end;

end;

procedure TExprEval.ParseLevel3;
var  etIdent:       TEvalToken;
begin

  // Build factor
  ParseLevel4;

  // Handle /, *, %, >>, <<, and
  while (FToken.etIdent in [tokMult, tokDiv, tokMod, tokShr, tokShl, tokAnd]) do
  begin
     // Hold the identifier
     etIdent:=FToken.etIdent;
     // Seed the next token
     ParseNext;
     // Build factor
     ParseLevel4;
     // Generate code
     case etIdent of
        tokMult  :  GenOpCode(OP_MULT, 0);
        tokDiv   :  GenOpCode(OP_DIV, 0);
        tokMod   :  GenOpCode(OP_MOD, 0);
        tokShl   :  GenOpCode(OP_SHL, 0);
        tokShr   :  GenOpCode(OP_SHR, 0);
        tokAnd   :  GenOpCode(OP_AND, 0);
     end;
  end;

end;

procedure TExprEval.ParseLevel2;
var  etIdent:       TEvalToken;
begin

  // Handle + and - numbers
  if (FToken.etIdent in [tokAdd, tokSub]) then
  begin
     // Hold the identifier
     etIdent:=FToken.etIdent;
     // Seed the next token
     ParseNext;
     // Build term
     ParseLevel3;
     // Generate code for negate
     if (etIdent = tokSub) then GenOpCode(OP_NEG, 0);
  end
  else
     // Build term
     ParseLevel3;

  // Handle +, -, or, xor
  while (FToken.etIdent in [tokAdd, tokSub, tokOr, tokXor]) do
  begin
     // Hold the identifier
     etIdent:=FToken.etIdent;
     // Seed the next token
     ParseNext;
     // Build next term
     ParseLevel3;
     // Generate code
     case etIdent of
        tokAdd   :  GenOpCode(OP_ADD, 0);
        tokSub   :  GenOpCode(OP_SUB, 0);
        tokOr    :  GenOpCode(OP_OR, 0);
        tokXor   :  GenOpCode(OP_XOR, 0);
     end;
  end;

end;

procedure TExprEval.ParseLevel1;
var  etIdent:       TEvalToken;
begin

  // Build a simple expression
  ParseLevel2;

  // What kind of token?
  if (FToken.etIdent in [tokEq, tokNeq, tokLeq, tokLt, tokGeq, tokGt]) then
  begin
     // Save the identifier
     etIdent:=FToken.etIdent;
     // Seed the next token
     ParseNext;
     // Build another simple expression
     ParseLevel2;
     // Generate asm code
     case etIdent of
        tokEq    :  GenOpCode(OP_EQ, 0);
        tokLt    :  GenOpCode(OP_LT, 0);
        tokLeq   :  GenOpCode(OP_LEQ, 0);
        tokGt    :  GenOpCode(OP_GT, 0);
        tokGeq   :  GenOpCode(OP_GEQ, 0);
        tokNeq   :  GenOpCode(OP_NEQ, 0);
     end;
  end;

end;

procedure TExprEval.Parse;
var  lpszMark:      PChar;
begin

  // Lock the parse point
  lpszMark:=FParse;

  // Seed the first token
  ParseNext;

  // Check for "=" and allow it, example: " = 5.4 + 3"
  if (FToken.etIdent = tokEq) then
     // Ignore the extraneous equal symbol
     ParseNext
  else
  begin
     // Need to check for an assignment operation
     if (FToken.etIdent = tokVar) then
     begin
        // Parse next


     end;
  end;

  // Repeat until we get to the end of the expression
  while (FToken.etIdent <> tokEnd) do ParseLevel1;

end;

procedure TExprEval.ParseNext;
var  lpszIdent:  PChar;
     lpIdent:    Pointer;
     dwError:    Integer;
     cMark:      Char;
begin

  // Clear the current token
  ZeroMemory(@FToken, SizeOf(TEvalParse));

  // Check current parse point
  if (FParse = nil) or (FParse^ = #0) then
     // End of expression
     FToken.etIdent:=tokEnd
  else
  begin
     // Skip white space
     while (FParse^ in [#9, #10, #13, #32]) do Inc(FParse);
     // Get next token
     case FParse^ of
        // End of expression
        #0       :  FToken.etIdent:=tokEnd;
        // Mod
        '%'      :  FToken.etIdent:=tokMod;
        // Left paren
        '('      :  FToken.etIdent:=tokLp;
        // Right paren
        ')'      :  FToken.etIdent:=tokRp;
        // Multiply
        '*'      :  FToken.etIdent:=tokMult;
        // Add
        '+'      :  FToken.etIdent:=tokAdd;
        // Subtract
        '-'      :  FToken.etIdent:=tokSub;
        // Divide
        '/'      :  FToken.etIdent:=tokDiv;
        // Numeric number (numbers cannot start with a .)
        '0'..'9' :
        begin
           // Hold the identifier start
           lpszIdent:=FParse;
           // Find the end of the number, or a period
           while (FParse^ in ['.', '0'..'9']) do Inc(FParse);
           // Hold the current char and mark
           cMark:=FParse^;
           FParse^:=#0;
           // Convert to number
           FToken.etIdent:=tokNum;
           Val(lpszIdent, FToken.dblVal, dwError);
           // Check conversion
           if (dwError > 0) then raise EEvalException.CreateRes(@SInvalidNum);
           // Reset the mark point and skip back one in the parse stream
           FParse^:=cMark;
           Dec(FParse);
        end;
        // Less than
        '<'      :
        begin
           // Move to next char in stream
           Inc(FParse);
           // Check next character
           case FParse^ of
              // Less than equals
              '='   :  FToken.etIdent:=tokLeq;
              // Not equals
              '>'   :  FToken.etIdent:=tokNeq;
              // Shift left
              '<'   :  FToken.etIdent:=tokShl;
           else
              // Less than
              FToken.etIdent:=tokLt;
              Dec(FParse);
           end;
        end;
        // Equals
        '='      :  FToken.etIdent:=tokEq;
        // Greater than
        '>'      :
        begin
           // Move to next char in stream
           Inc(FParse);
           // Check next character
           case FParse^ of
              // Greater than equals
              '='   :  FToken.etIdent:=tokGeq;
              // Shift right
              '>'   :  FToken.etIdent:=tokShr;
           else
              // Greater than
              FToken.etIdent:=tokGt;
              Dec(FParse);
           end;
        end;
        // Identifier
        'A'..'Z',
        'a'..'z' :
        begin
           // Hold the identifier start
           lpszIdent:=FParse;
           // Find the end of the identifier
           while (FParse^ in ['A'..'Z', 'a'..'z']) do Inc(FParse);
           // Hold the current char and mark
           cMark:=FParse^;
           FParse^:=#0;
           // Check identifier
           if (StrLen(lpszIdent) = 1) then
           begin
              // This is a variable
              lpszIdent^:=UpCase(lpszIdent^);
              FToken.etIdent:=tokVar;
              FToken.cbVar:=Byte(lpszIdent^)-Byte('A');
           end
           else
           begin
              // Has to be an identifier
              if hshIdent.Find(lpszIdent, lpIdent) then
                 // Found in hash table
                 FToken.etIdent:=TEvalToken(lpIdent)
              else
                 // Invalid identifier
                 raise EEvalException.CreateRes(@SInvalidIdent);
           end;
           // Reset the mark point and skip back one in the parse stream
           FParse^:=cMark;
           Dec(FParse);
        end;
     else
        // Invalid chararcter
        raise EEvalException.CreateRes(@SUnexpected);
     end;
     // Push next in parse stream
     Inc(FParse);
  end;

end;

function TExprEval.StoreConst(dblVal: Double): Byte;
begin

  // Store the constant number
  FCompiled.ecConsts[FCompiled.cbConsts]:=dblVal;

  // Return the index of the constant that was added
  result:=FCompiled.cbConsts;

  // Increment the const counter
  Inc(FCompiled.cbConsts);

  // Check for overflow
  if (FCompiled.cbConsts >= MAX_NUM) then raise EEvalException.CreateRes(@SNumOverflow);

end;

procedure TExprEval.GenOpCode(cbAL, cbDL: Byte);
begin

  // Add the next assembly instruction
  FCompiled.epAsm[FCompiled.cbAsm].cbAL:=cbAL;
  FCompiled.epAsm[FCompiled.cbAsm].cbDL:=cbDL;

  // Increment the instruction
  Inc(FCompiled.cbAsm);

  // Check for overflow
  if (FCompiled.cbAsm >= MAX_ASM) then raise EEvalException.CreateRes(@SAsmOverflow);

end;

constructor TExprEval.Create(Expression: PChar);
begin

  // Perform inherited
  inherited Create;

  // Clear the internal structures
  ZeroMemory(@FCompiled, SizeOf(TEvalCompile));
  ZeroMemory(@FToken, SizeOf(TEvalParse));

  // Copy the expression over and set parse point
  FExpression:=StrCopy(AllocMem(Succ(StrLen(Expression))), Expression);
  FParse:=FExpression;

  // Parse
  Parse;

end;

destructor TExprEval.Destroy;
begin

  // Clean up
  FreeMem(FExpression);

  // Perform inherited
  inherited Destroy;

end;

function LastEvalError: PChar;
begin

  // Return the last error string
  result:=@lpError;

end;

function Evaluate(lpszExpression: PChar; var Value: Double): Boolean;
begin

  // Creates a one shot evaluation object to handle the compilation and execution
  try
     // Clear the error string
     ZeroMemory(@lpError, SizeOf(lpError));
     // Create object
     with TExprEval.Create(lpszExpression) do
     begin
        // Perform the evaluation
        Value:=Evaluate;
        // Done
        Free;
     end;
     // Success
     result:=True;
  except
     // Catch exceptions
     on E: Exception do
     begin
        // Copy the exception error message
        StrPCopy(@lpError, E.Message);
        // Failure
        result:=False;
     end;
  end;

end;

procedure ClearVars;
begin

  // Clear all variables
  ZeroMemory(@lpVars, SizeOf(TVariables));

end;

function GetVar(Variable: Char; var Value: Double): Boolean;
begin

  // Range check
  result:=(UpCase(Variable) in ['A'..'Z']);

  // Return value if success
  if result then Value:=lpVars[UpCase(Variable)];

end;

function SetVar(Variable: Char; Value: Double): Boolean;
begin

  // Range check
  result:=(UpCase(Variable) in ['A'..'Z']);

  // Set variable if success
  if result then lpVars[UpCase(Variable)]:=Value;

end;

function HashCompare(Item1, Item2: PChar; CareCase: Boolean): Boolean;
begin

  // Null assignment checks
  if (Item1 = nil) then
     // Check for Item2 being nil
     result:=(Item2 = nil)
  else if (Item2 = nil) then
     // Item1 is not null, so no possible match
     result:=False
  // Check case
  else if CareCase then
     // Case sensitive compare
     result:=(StrComp(Item1, Item2) = 0)
  else
     // In-case sensitive compare
     result:=(StrIComp(Item1, Item2) = 0);

end;

function HashFunc(Key: PChar; CareCase: Boolean): Integer;
var  bChar:         Byte;
begin

  // Set starting result
  result:=0;

  // Generate hash index for key
  while (Key^ > #0) do
  begin
     if CareCase then
        bChar:=Byte(Key^)
     else if (Key^ in ['A'..'Z']) then
        bChar:=Byte(Key^)+32
     else
        bChar:=Byte(Key^);
     Inc(result, (result shl 3) + bChar);
     Inc(Key);
  end;

  // Keep result in bounds of array
  result:=LongWord(result) mod HASH_SIZE;

end;

////////////////////////////////////////////////////////////////////////////////
//   THash
////////////////////////////////////////////////////////////////////////////////
constructor THash.Create(Deallocator: THashDeallocator = nil);
begin

  // Perform inherited
  inherited Create;

  // Set default values
  ZeroMemory(@FHash, SizeOf(FHash));
  FDeallocator:=Deallocator;
  FCareCase:=True;
  FCount:=0;

end;

destructor THash.Destroy;
begin

  // Resource protection
  try
     // Clear the hash
     Clear;
  finally
     // Perform inherited
     inherited Destroy;
  end;

end;

procedure THash.Clear;
var  phNode1:       PHashNode;
     phNode2:       PHashNode;
     dwIndex:       Integer;
begin

  // Resource protection
  try
     // Iterate the array and clear the hash nodes
     for dwIndex:=0 to Pred(HASH_SIZE) do
     begin
        // Get bucket node
        phNode1:=FHash[dwIndex];
        // Walk the nodes
        while Assigned(phNode1) do
        begin
           // Get pointer to next item
           phNode2:=phNode1^.Next;
           // Free memory for node name
           if Assigned(phNode1^.Item) then FreeMem(phNode1^.Item);
           // Callback
           if (Assigned(phNode1^.Data) and Assigned(FDeallocator)) then FDeallocator(Self, phNode1^.Data);
           // Free node item
           FreeMem(phNode1);
           // Set iterator to next item
           phNode1:=phNode2;
        end;
     end;
  finally
     // Clear all top level buckets
     for dwIndex:=0 to Pred(HASH_SIZE) do FHash[dwIndex]:=nil;
     // Reset the count
     FCount:=0;
  end;

end;

function THash.Extract(Item: PChar; out Data: Pointer): Boolean;
var  phNode1:       PHashNode;
     phNode2:       PHashNode;
     dwIndex:       Integer;
begin

  // Get the hash index
  dwIndex:=HashFunc(Item, FCareCase);

  // Get the hash bucket item
  phNode1:=FHash[dwIndex];

  // Did top level item exist?
  if Assigned(phNode1) then
  begin
     // Prepare for loop
     phNode2:=phNode1;
     // Walk the nodes
     while Assigned(phNode2) do
     begin
        // Match key
        if HashCompare(phNode2^.Item, Item, FCareCase) then break;
        // Save current node
        phNode1:=phNode2;
        // Move to the next node in the chain
        phNode2:=phNode2^.Next;
     end;
     // Check to see if the node is still set
     if Assigned(phNode2) then
     begin
        // Set out param data value
        Data:=phNode2^.Data;
        // Check to see if this is the top level item
        if (phNode2 = phNode1) then
           // Link next node into the bucket
           FHash[dwIndex]:=phNode2^.Next
        else
           // Link over this node
           phNode1^.Next:=phNode2^.Next;
        // Free memory for node name
        if Assigned(phNode2^.Item) then FreeMem(phNode2^.Item);
        // Free the node
        FreeMem(phNode2);
        // Decrement the node count
        Dec(FCount);
        // Success
        result:=True;
     end
     else
        // Did not find the node
        result:=False;
  end
  else
     // No nodes in bucket
     result:=False;

end;

function THash.Delete(Item: PChar): Boolean;
var  lpData:        Pointer;
begin

  // Extract the item
  result:=Extract(Item, lpData);

  // Check result, perform callback if needed
  if (result and Assigned(lpData) and Assigned(FDeallocator)) then FDeallocator(Self, lpData);

end;

function THash.Add(Item: PChar; Data: Pointer): Boolean;
var  phNode1:          PHashNode;
     phNode2:          PHashNode;
     dwIndex:          Integer;
begin

  // Get the hash bucket item index
  dwIndex:=HashFunc(Item, FCareCase);

  // Resource protection
  try
     // Get the hash bucket item
     phNode1:=FHash[dwIndex];
     // Is the bucket empty
     if (phNode1 = nil) then
        // Add new cell item
        FHash[dwIndex]:=NewNode(Item, Data)
     else
     begin
        // Save current node
        phNode2:=phNode1;
        // Walk nodes
        while Assigned(phNode2) do
        begin
           // Match the key
           if HashCompare(phNode2^.Item, Item, FCareCase) then
           begin
              // Check for data change
              if (phNode2^.Data <> Data) then
              begin
                 // Callback
                 if (Assigned(phNode2^.Data) and Assigned(FDeallocator)) then FDeallocator(Self, phNode2^.Data);
                 // Set new data item
                 phNode2^.Data:=Data;
              end;
              // Break loop
              break;
           end;
           // Save current node
           phNode1:=phNode2;
           // Walk next node
           phNode2:=phNode2^.Next;
        end;
        // Do we need to add a new item to the end of the chain?
        if (phNode2 = nil) then
        begin
           // Create hash node
           phNode2:=NewNode(Item, Data);
           // Link the node in
           phNode1^.Next:=phNode2;
        end;
     end;
  finally
     // Always success
     result:=True;
  end;

end;

function THash.Find(Item: PChar; out Data: Pointer): Boolean;
var  phNode:        PHashNode;
begin

  // Get the hash bucket item
  phNode:=FHash[HashFunc(Item, FCareCase)];

  // Resource protection
  try
     // Walk the items
     while Assigned(phNode) do
     begin
        // Compare the key
        if HashCompare(phNode^.Item, Item, FCareCase) then
        begin
           // Key exists, set out return data
           Data:=phNode^.Data;
           break;
        end;
        // Walk the next item
        phNode:=phNode^.Next;
     end;
  finally
     // Success if node is assigned
     result:=Assigned(phNode);
  end;

end;

function THash.NewNode(Item: PChar; Data: Pointer): PHashNode;
begin

  // Allocate memory for new node
  result:=AllocMem(SizeOf(THashNode));

  // Set the structure fields
  result^.Item:=StrCopy(AllocMem(Succ(StrLen(Item))), Item);
  result^.Data:=Data;

  // Increment the count
  Inc(FCount);

end;

initialization

  // Initialize all variables to zero
  ZeroMemory(@lpVars, SizeOf(TVariables));

  // Clear the error string
  ZeroMemory(@lpError, SizeOf(lpError));

  // Create identifier hash table and load
  hshIdent:=THash.Create(nil);
  with hshIdent do
  begin
     CaseSensitive:=False;
     Add('and', Pointer(tokAnd));
     Add('or', Pointer(tokOr));
     Add('xor', Pointer(tokXor));
     Add('not', Pointer(tokNot));
     Add('abs', Pointer(tokAbs));
     Add('sin', Pointer(tokSin));
     Add('cos', Pointer(tokCos));
     Add('tan', Pointer(tokTan));
     Add('atan', Pointer(tokAtan));
     Add('exp', Pointer(tokExp));
     Add('sqrt', Pointer(tokSqrt));
     Add('int', Pointer(tokInt));
     Add('pi', Pointer(tokPi));
     Add('maxint', Pointer(tokMi));
     Add('maxword', Pointer(tokMw));
     Add('maxbyte', Pointer(tokMb));
  end;

finalization

  // Free the identifier hash table
  hshIdent.Free;

end.

0
 
JeePeeTeeCommented:
0
 
mikelittlewoodCommented:
nice bit of code that rllibby, something I might be able to use for user-defineable functions/calcs myself.
0
 
daniel710624Author Commented:
So appreciate for you help, rllibby!
This is really helpful, Thanks for your generosity for sharing with me!
0
 
daniel710624Author Commented:
By the way! Do you have any idea about this question, rllibby?
http://www.experts-exchange.com/Programming/Programming_Languages/Delphi/Q_22075751.html
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.