Solved

How to make formula programmable ?

Posted on 2006-12-01
5
195 Views
Last Modified: 2010-04-05
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!

0
Comment
Question by:daniel710624
5 Comments
 
LVL 4

Expert Comment

by:JeePeeTee
Comment Utility
0
 
LVL 26

Accepted Solution

by:
Russell Libby earned 500 total points
Comment Utility
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
 
LVL 15

Expert Comment

by:mikelittlewood
Comment Utility
nice bit of code that rllibby, something I might be able to use for user-defineable functions/calcs myself.
0
 

Author Comment

by:daniel710624
Comment Utility
So appreciate for you help, rllibby!
This is really helpful, Thanks for your generosity for sharing with me!
0
 

Author Comment

by:daniel710624
Comment Utility
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

Featured Post

How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

Join & Write a Comment

Creating an auto free TStringList The TStringList is a basic and frequently used object in Delphi. On many occasions, you may want to create a temporary list, process some items in the list and be done with the list. In such cases, you have to…
Hello everybody This Article will show you how to validate number with TEdit control, What's the TEdit control? TEdit is a standard Windows edit control on a form, it allows to user to write, read and copy/paste single line of text. Usua…
Internet Business Fax to Email Made Easy - With eFax Corporate (http://www.enterprise.efax.com), you'll receive a dedicated online fax number, which is used the same way as a typical analog fax number. You'll receive secure faxes in your email, fr…
This video shows how to remove a single email address from the Outlook 2010 Auto Suggestion memory. NOTE: For Outlook 2016 and 2013 perform the exact same steps. Open a new email: Click the New email button in Outlook. Start typing the address: …

728 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

10 Experts available now in Live!

Get 1:1 Help Now