Want to win a PS4? Go Premium and enter to win our High-Tech Treats giveaway. Enter to Win

x
Solved

# How to make formula programmable ?

Posted on 2006-12-01
Medium Priority
204 Views
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)

0
Question by:daniel710624
[X]
###### Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

• Help others & share knowledge
• Earn cash & points

LVL 4

Expert Comment

ID: 18052959
0

LVL 26

Accepted Solution

Russell Libby earned 2000 total points
ID: 18053710
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       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_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;
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;
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_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;
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;
tokVar      :
begin
// Generate code to load the variable
GenOpCode(OP_LVN, FToken.cbVar);
// Seed the next token
ParseNext;
end;
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
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;
// Subtract
'-'      :  FToken.etIdent:=tokSub;
// Divide
'/'      :  FToken.etIdent:=tokDiv;
'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
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
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);
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;
end;

finalization

// Free the identifier hash table
hshIdent.Free;

end.

0

LVL 15

Expert Comment

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

Author Comment

ID: 18066084
So appreciate for you help, rllibby!
This is really helpful, Thanks for your generosity for sharing with me!
0

Author Comment

ID: 18066103
http://www.experts-exchange.com/Programming/Programming_Languages/Delphi/Q_22075751.html
0

## Featured Post

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Introduction The parallel port is a very commonly known port, it was widely used to connect a printer to the PC, if you look at the back of your computer, for those who don't have newer computers, there will be a port with 25 pins and a small print…
In my programming career I have only very rarely run into situations where operator overloading would be of any use in my work.  Normally those situations involved math with either overly large numbers (hundreds of thousands of digits or accuracy re…
Have you created a query with information for a calendar? ... and then, abra-cadabra, the calendar is done?! I am going to show you how to make that happen. Visualize your data!  ... really see it To use the code to create a calendar from a q…
Want to learn how to record your desktop screen without having to use an outside camera. Click on this video and learn how to use the cool google extension called "Screencastify"! Step 1: Open a new google tab Step 2: Go to the left hand upper corn…
###### Suggested Courses
Course of the Month10 days, 2 hours left to enroll