Click here to Skip to main content
Click here to Skip to main content
Add your own
alternative version

A Calculation Engine for .NET

, 1 Sep 2013 CPOL
A calculation engine that is small, fast, and extensible.
''' <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

By viewing downloads associated with this article you agree to the Terms of Service and the article's licence.

If a file you wish to view isn't highlighted, and is a text file (not binary), please let us know and we'll add colourisation support for it.

License

This article, along with any associated source code and files, is licensed under The Code Project Open License (CPOL)

Share

About the Author

Bernardo Castilho
Chief Technology Officer ComponentOne
United States United States
No Biography provided

| Advertise | Privacy | Mobile
Web01 | 2.8.141015.1 | Last Updated 1 Sep 2013
Article Copyright 2011 by Bernardo Castilho
Everything else Copyright © CodeProject, 1999-2014
Terms of Service
Layout: fixed | fluid