''' <summary>
''' CalcEngine parses strings and returns Expression objects that can
''' be evaluated.
''' </summary>
''' <remarks>
''' <para>This class has three extensibility points:</para>
''' <para>Use the <b>DataContext</b> property to add an object's properties to the engine scope.</para>
''' <para>Use the <b>RegisterFunction</b> method to define custom functions.</para>
''' <para>Override the <b>GetExternalObject</b> method to add arbitrary variables to the engine scope.</para>
''' <para>The code was translated from C# using the Reflector, so it is not as clear as one might
''' expect. Sorry for that...</para>
''' </remarks>
Public Class CalcEngine
' Fields
Private _cache As ExpressionCache
Private _ci As System.Globalization.CultureInfo
Private _dataContext As Object
Private _decimal As Char
Private _percent As Char
Private _listSep As Char
Private _expr As String
Private _fnTbl As Dictionary(Of String, FunctionDefinition)
Private _idChars As String
Private _len As Integer
Private _optimize As Boolean
Private _ptr As Integer
Private _tkTbl As Dictionary(Of Object, Token)
Private _token As Token
Private _vars As Dictionary(Of String, Object)
' Methods
Public Sub New()
CultureInfo = System.Globalization.CultureInfo.InvariantCulture
_tkTbl = GetSymbolTable()
_fnTbl = GetFunctionTable
_vars = New Dictionary(Of String, Object)(StringComparer.OrdinalIgnoreCase)
_cache = New ExpressionCache(Me)
_optimize = True
End Sub
Private Sub AddToken(ByVal symbol As Object, ByVal id As TKID, ByVal type As TKTYPE)
Dim token As New Token(symbol, id, type)
_tkTbl.Add(symbol, token)
End Sub
Public Function Evaluate(ByVal expression As String) As Object
Dim x As Expression
If (_cache Is Nothing) Then x = Parse(expression) Else x = _cache.Item(expression)
Return x.Evaluate
End Function
Public Overridable Function GetExternalObject(ByVal identifier As String) As Object
Return Nothing
End Function
Private Function GetFunctionTable() As Dictionary(Of String, FunctionDefinition)
If (_fnTbl Is Nothing) Then
_fnTbl = New Dictionary(Of String, FunctionDefinition)(StringComparer.InvariantCultureIgnoreCase)
Logical.Register(Me)
MathTrig.Register(Me)
Text.Register(Me)
Statistical.Register(Me)
End If
Return _fnTbl
End Function
Private Function GetMember() As Token
Dim pos As Integer = _ptr
Dim tk As Token = _token
GetToken()
If (_token.ID <> TKID.PERIOD) Then
_ptr = pos
_token = tk
Return Nothing
End If
GetToken()
If (_token.Type <> TKTYPE.IDENTIFIER) Then
CalcEngine.Throw("Identifier expected")
End If
Return _token
End Function
Private Function GetParameters() As List(Of Expression)
Dim pos As Integer = _ptr
Dim tk As Token = _token
GetToken()
If (_token.ID <> TKID.OPEN) Then
_ptr = pos
_token = tk
Return Nothing
End If
pos = _ptr
GetToken()
If (_token.ID = TKID.CLOSE) Then
Return Nothing
End If
_ptr = pos
Dim parms As New List(Of Expression)
Dim expr As Expression = ParseExpression
parms.Add(expr)
Do While (_token.ID = TKID.COMMA)
expr = ParseExpression
parms.Add(expr)
Loop
If (_token.ID <> TKID.CLOSE) Then
CalcEngine.Throw()
End If
Return parms
End Function
Private Function GetSymbolTable() As Dictionary(Of Object, Token)
If (_tkTbl Is Nothing) Then
_tkTbl = New Dictionary(Of Object, Token)
AddToken("+"c, TKID.ADD, TKTYPE.ADDSUB)
AddToken("-"c, TKID.SUB, TKTYPE.ADDSUB)
AddToken("("c, TKID.OPEN, TKTYPE.GROUP)
AddToken(")"c, TKID.CLOSE, TKTYPE.GROUP)
AddToken("*"c, TKID.MUL, TKTYPE.MULDIV)
AddToken("."c, TKID.PERIOD, TKTYPE.GROUP)
AddToken("/"c, TKID.DIV, TKTYPE.MULDIV)
AddToken("\"c, TKID.DIVINT, TKTYPE.MULDIV)
AddToken("="c, TKID.EQ, TKTYPE.COMPARE)
AddToken(">"c, TKID.GT, TKTYPE.COMPARE)
AddToken("<"c, TKID.LT, TKTYPE.COMPARE)
AddToken("^"c, TKID.POWER, TKTYPE.POWER)
AddToken("<>", TKID.NE, TKTYPE.COMPARE)
AddToken(">=", TKID.GE, TKTYPE.COMPARE)
AddToken("<=", TKID.LE, TKTYPE.COMPARE)
' list separator is localized, not necessarily a comma
' so it can't be on the static table
'AddToken(","c, TKID.COMMA, TKTYPE.GROUP)
End If
Return _tkTbl
End Function
Private Sub GetToken()
' skip whitespace
Do While (_ptr < _len) AndAlso (_expr(_ptr) <= " "c)
_ptr += 1
Loop
' detect expression end
If (_ptr >= _len) Then
_token = New Token(Nothing, TKID.END, TKTYPE.GROUP)
Else
Dim i As Integer
Dim lit As String
Dim c As Char = _expr(_ptr)
Dim isLetter As Boolean = ((c >= "a"c) AndAlso (c <= "z"c)) OrElse ((c >= "A"c) AndAlso (c <= "Z"c))
Dim isDigit As Boolean = (c >= "0"c) AndAlso (c <= "9"c)
If (Not isLetter AndAlso Not isDigit) Then
Dim cnxt As Char = ChrW(0)
If _ptr + 1 < _len Then
cnxt = _expr(_ptr + 1)
End If
Dim nxt As Integer = "0123456789".IndexOf(cnxt)
Dim isNumber As Boolean = ((c = _decimal) AndAlso (nxt >= &H30)) AndAlso (nxt <= &H39)
If Not isNumber Then
If c = _listSep Then
_token = New Token(c, TKID.COMMA, TKTYPE.GROUP)
_ptr += 1
Return
End If
Dim tk As Token
If _tkTbl.TryGetValue(c, tk) Then
_token = tk
_ptr += 1
If (((_ptr < _len) AndAlso ((c = ">"c) OrElse (c = "<"c))) AndAlso _tkTbl.TryGetValue(_expr.Substring((_ptr - 1), 2), tk)) Then
_token = tk
_ptr += 1
End If
Return
End If
End If
End If
If (Not isDigit AndAlso (c <> _decimal)) Then
If (c <> """"c) Then
If (c <> "#"c) Then
If ((Not isLetter AndAlso (c <> "_"c)) AndAlso ((_idChars Is Nothing) OrElse (_idChars.IndexOf(c) < 0))) Then
CalcEngine.Throw("Identifier expected.")
End If
i = 1
Do While ((i + _ptr) < _len)
c = _expr((_ptr + i))
isLetter = (((c >= "a"c) AndAlso (c <= "z"c)) OrElse ((c >= "A"c) AndAlso (c <= "Z"c)))
isDigit = ((c >= "0"c) AndAlso (c <= "9"c))
If (((Not isLetter AndAlso Not isDigit) AndAlso (c <> "_"c)) AndAlso ((_idChars Is Nothing) OrElse (_idChars.IndexOf(c) < 0))) Then
Exit Do
End If
i += 1
Loop
Dim id As String = _expr.Substring(_ptr, i)
_ptr = _ptr + i
_token = New Token(id, TKID.ATOM, TKTYPE.IDENTIFIER)
Return
End If
i = 1
Do While ((i + _ptr) < _len)
c = _expr(_ptr + i)
If (c = "#"c) Then
Exit Do
End If
i += 1
Loop
If (c <> "#"c) Then
CalcEngine.Throw("Can't find final date delimiter ('#').")
End If
lit = _expr.Substring(_ptr + 1, i - 1)
_ptr = _ptr + i + 1
_token = New Token(DateTime.Parse(lit, _ci), TKID.ATOM, TKTYPE.LITERAL)
Return
End If
i = 1
Do While i + _ptr < _len
c = _expr(_ptr + i)
If (c = """"c) Then
Dim cNext As Char
If (i + _ptr) < (_len - 1) Then cNext = _expr(((_ptr + i) + 1)) Else cNext = " "c
If (cNext <> """"c) Then
Exit Do
End If
i += 1
End If
i += 1
Loop
Else
Dim sci As Boolean = False
Dim pct As Boolean = False
Dim div As Double = -1
Dim val As Double = 0
i = 0
Do While ((i + _ptr) < _len)
c = _expr((_ptr + i))
If ((c >= "0"c) AndAlso (c <= "9"c)) Then
val = ((val * 10) + "0123456789".IndexOf(c))
If (div > -1) Then
div = (div * 10)
End If
ElseIf ((c = _decimal) AndAlso (div < 0)) Then
div = 1
ElseIf Not (((c <> "E"c) AndAlso (c <> "e"c)) OrElse sci) Then
sci = True
c = _expr(((_ptr + i) + 1))
If ((c = "+"c) OrElse (c = "-"c)) Then
i += 1
End If
Else
If (c = _percent) Then
pct = True
i += 1
End If
Exit Do
End If
i += 1
Loop
If Not sci Then
If (div > 1) Then
val = (val / CDbl(div))
End If
If pct Then
val = (val / 100)
End If
Else
val = CalcEngine.ParseDouble(_expr.Substring(_ptr, i), _ci)
End If
_token = New Token(val, TKID.ATOM, TKTYPE.LITERAL)
_ptr = (_ptr + i)
Return
End If
If (c <> """"c) Then
CalcEngine.Throw("Can't find final quote.")
End If
lit = _expr.Substring((_ptr + 1), (i - 1))
_ptr = (_ptr + (i + 1))
_token = New Token(lit.Replace("""""", """"), TKID.ATOM, TKTYPE.LITERAL)
End If
End Sub
Public Function Parse(ByVal expression As String) As Expression
_expr = expression
_len = _expr.Length
_ptr = 0
If ((_len > 0) AndAlso (_expr(0) = "="c)) Then
_ptr += 1
End If
Dim expr As Expression = ParseExpression
If (_token.ID <> TKID.END) Then
CalcEngine.Throw()
End If
If _optimize Then
expr = expr.Optimize
End If
Return expr
End Function
Private Function ParseAddSub() As Expression
Dim x As Expression = ParseMulDiv
Do While (_token.Type = TKTYPE.ADDSUB)
Dim t As Token = _token
GetToken()
Dim exprArg As Expression = ParseMulDiv
x = New BinaryExpression(t, x, exprArg)
Loop
Return x
End Function
Private Function ParseAtom() As Expression
Dim x As Expression = Nothing
Dim fnDef As FunctionDefinition = Nothing
Select Case _token.Type
Case TKTYPE.GROUP
If (_token.ID <> TKID.OPEN) Then
CalcEngine.Throw("Expression expected.")
End If
GetToken()
x = ParseCompare
If (_token.ID <> TKID.CLOSE) Then
CalcEngine.Throw("Unbalanced parenthesis.")
End If
Exit Select
Case TKTYPE.LITERAL
x = New Expression(_token)
Exit Select
Case TKTYPE.IDENTIFIER
Dim id As String = CStr(_token.Value)
If Not _fnTbl.TryGetValue(id, fnDef) Then
If _vars.ContainsKey(id) Then
x = New VariableExpression(_vars, id)
Else
Dim xObj As Object = GetExternalObject(id)
If (Not xObj Is Nothing) Then
x = New XObjectExpression(xObj)
ElseIf (Not DataContext Is Nothing) Then
Dim list As New List(Of BindingInfo)
Dim t As Token = _token
Do While (Not t Is Nothing)
list.Add(New BindingInfo(CStr(t.Value), GetParameters))
t = GetMember
Loop
x = New BindingExpression(Me, list, _ci)
Else
CalcEngine.Throw("Unexpected identifier")
End If
End If
Exit Select
End If
Dim p As List(Of Expression) = GetParameters
Dim pCnt As Integer
If (p Is Nothing) Then pCnt = 0 Else pCnt = p.Count
If ((fnDef.ParmMin <> -1) AndAlso (pCnt < fnDef.ParmMin)) Then
CalcEngine.Throw("Too few parameters.")
End If
If ((fnDef.ParmMax <> -1) AndAlso (pCnt > fnDef.ParmMax)) Then
CalcEngine.Throw("Too many parameters.")
End If
x = New FunctionExpression(fnDef, p)
Exit Select
End Select
If (x Is Nothing) Then
CalcEngine.Throw()
End If
GetToken()
Return x
End Function
Private Function ParseCompare() As Expression
Dim x As Expression = ParseAddSub
Do While (_token.Type = TKTYPE.COMPARE)
Dim t As Token = _token
GetToken()
Dim exprArg As Expression = ParseAddSub
x = New BinaryExpression(t, x, exprArg)
Loop
Return x
End Function
Private Shared Function ParseDouble(ByVal str As String, ByVal ci As System.Globalization.CultureInfo) As Double
If ((str.Length > 0) AndAlso (str((str.Length - 1)) = ci.NumberFormat.PercentSymbol(0))) Then
str = str.Substring(0, (str.Length - 1))
Return (Double.Parse(str, System.Globalization.NumberStyles.Any, ci) / 100)
End If
Return Double.Parse(str, System.Globalization.NumberStyles.Any, ci)
End Function
Private Function ParseExpression() As Expression
GetToken()
Return ParseCompare
End Function
Private Function ParseMulDiv() As Expression
Dim x As Expression = ParsePower
Do While (_token.Type = TKTYPE.MULDIV)
Dim t As Token = _token
GetToken()
Dim a As Expression = ParsePower
x = New BinaryExpression(t, x, a)
Loop
Return x
End Function
Private Function ParsePower() As Expression
Dim x As Expression = ParseUnary
Do While (_token.Type = TKTYPE.POWER)
Dim t As Token = _token
GetToken()
Dim a As Expression = ParseUnary
x = New BinaryExpression(t, x, a)
Loop
Return x
End Function
Private Function ParseUnary() As Expression
If (_token.ID = TKID.ADD) OrElse (_token.ID = TKID.SUB) Then
Dim t As Token = _token
GetToken()
Return New UnaryExpression(t, ParseAtom)
End If
Return ParseAtom
End Function
Public Sub RegisterFunction(ByVal functionName As String, ByVal parmCount As Integer, ByVal fn As CalcEngineFunction)
RegisterFunction(functionName, parmCount, parmCount, fn)
End Sub
Public Sub RegisterFunction(ByVal functionName As String, ByVal parmMin As Integer, ByVal parmMax As Integer, ByVal fn As CalcEngineFunction)
_fnTbl.Add(functionName, New FunctionDefinition(parmMin, parmMax, fn))
End Sub
Private Shared Sub [Throw]()
CalcEngine.Throw("Syntax error.")
End Sub
Private Shared Sub [Throw](ByVal msg As String)
Throw New Exception(msg)
End Sub
' Properties
Public Property CacheExpressions As Boolean
Get
Return (Not _cache Is Nothing)
End Get
Set(ByVal value As Boolean)
If (value <> CacheExpressions) Then
_cache = IIf(value, New ExpressionCache(Me), Nothing)
End If
End Set
End Property
Public Property CultureInfo As System.Globalization.CultureInfo
Get
Return _ci
End Get
Set(ByVal value As System.Globalization.CultureInfo)
_ci = value
_decimal = _ci.NumberFormat.NumberDecimalSeparator(0)
_percent = _ci.NumberFormat.PercentSymbol(0)
_listSep = _ci.TextInfo.ListSeparator(0)
End Set
End Property
Public Overridable Property DataContext As Object
Get
Return _dataContext
End Get
Set(ByVal value As Object)
_dataContext = value
End Set
End Property
Public ReadOnly Property Functions As Dictionary(Of String, FunctionDefinition)
Get
Return _fnTbl
End Get
End Property
Public Property IdentifierChars As String
Get
Return _idChars
End Get
Set(ByVal value As String)
_idChars = value
End Set
End Property
Public Property OptimizeExpressions As Boolean
Get
Return _optimize
End Get
Set(ByVal value As Boolean)
_optimize = value
End Set
End Property
Public ReadOnly Property Variables As Dictionary(Of String, Object)
Get
Return _vars
End Get
End Property
End Class
''' <summary>
''' Delegate that represents CalcEngine functions.
''' </summary>
''' <param name="parms">List of <see cref="Expression"/> objects that represent the
''' parameters to be used in the function call.</param>
''' <returns>The function result.</returns>
Public Delegate Function CalcEngineFunction(ByVal parms As List(Of Expression)) As Object
Submit an article or tip