 |
Option Explicit
Private Sub Command1_Click()
Dim clsExpr As Expression
Set clsExpr = New Expression
clsExpr.AddVariable "e", Exp(1)
clsExpr.AddVariable "pi", Atn(1) * 4
clsExpr.ExpressionString = Text1.Text
If clsExpr.SolveExpression Then
MsgBox Text1.Text & " = " & clsExpr.Result
Else
MsgBox "Fehler beim Parsen!"
End If
End Sub
Private Sub Bench()
Const fnc As String = "((2.71828*3.14159)^0.5-10+0.0777176346777) / -10"
Const itr As Long = 10000
Dim i As Long
Dim d As Double
Dim obj As Object
Set obj = CreateObject("ScriptControl")
obj.Language = "VBScript"
obj.AddCode "sub main()" & vbCrLf & _
"x = " & fnc & vbCrLf & _
"end sub"
d = Timer
For i = 1 To itr
obj.run "main"
Next
MsgBox "ScriptCtrl: " & (Timer - d) * 1000 & " ms", , "Benchmark"
Dim clsExpr As Expression
Set clsExpr = New Expression
clsExpr.ExpressionString = fnc
d = Timer
For i = 1 To itr
clsExpr.SolveExpression
Next
MsgBox "Expression: " & (Timer - d) * 1000 & " ms", , "Benchmark"
Set obj = Nothing
Set clsExpr = Nothing
End Sub
Private Sub Form_Load()
Bench
End Sub
Option Explicit
Private Type Token
Type As TokenType
content As Double
varidx As Long
End Type
Private Type Variable
Name As String
content As Double
End Type
Private Enum TokenType
token_unk = &H0
token_val = &H1
token_end = &H2
token_var = &H3
token_add = &H2B
token_sub = &H2D
token_mul = &H2A
token_div = &H2F
token_pow = &H5E
token_parl = &H28
token_parr = &H29
End Enum
Private m_strExpr As String
Private m_lngPos As Long
Private m_tkn() As Token
Private m_lngCurTkn As Long
Private m_vars() As Variable
Private m_lngVars As Long
Private m_dblResult As Double
Public Function AddVariable(ByVal strVar As String, ByVal value As Double) As Boolean
Dim i As Long
For i = 0 To m_lngVars - 1
If StrComp(strVar, m_vars(i).Name, vbTextCompare) = 0 Then
Exit Function
End If
Next
ReDim Preserve m_vars(m_lngVars) As Variable
m_vars(m_lngVars).Name = strVar
m_vars(m_lngVars).content = value
m_lngVars = m_lngVars + 1
AddVariable = True
End Function
Public Function RemVariable(ByVal strVar As String) As Boolean
Dim i As Long
Dim j As Long
For i = 0 To m_lngVars - 1
If StrComp(strVar, m_vars(i).Name, vbTextCompare) = 0 Then
For j = i + 1 To m_lngVars - 1
m_vars(j - 1) = m_vars(j)
Next
m_lngVars = m_lngVars - 1
If m_lngVars = 0 Then
Erase m_vars
Else
ReDim Preserve m_vars(m_lngVars - 1) As Variable
End If
RemVariable = True
Exit For
End If
Next
End Function
Public Property Get VarCount() As Long
VarCount = m_lngVars
End Property
Public Property Get VariableName(ByVal idx As Long) As String
VariableName = m_vars(idx).Name
End Property
Public Property Get VariableValue(ByVal idx As Long) As Double
VariableValue = m_vars(idx).content
End Property
Public Property Let VariableValue(ByVal idx As Long, ByVal dblVal As Double)
m_vars(idx).content = dblVal
End Property
Public Property Get Result() As Double
Result = m_dblResult
End Property
Public Property Get ExpressionString() As String
ExpressionString = m_strExpr
End Property
Public Property Let ExpressionString(ByVal strExpr As String)
Dim i As Long
m_strExpr = strExpr
m_lngPos = 1
Do
ReDim Preserve m_tkn(i) As Token
m_tkn(i) = GetToken()
i = i + 1
Loop Until m_tkn(i - 1).Type = token_end
End Property
Public Function SolveExpression() As Boolean
If Len(m_strExpr) > 0 Then
m_lngCurTkn = 0
m_dblResult = 0
If Expression(m_dblResult) Then SolveExpression = Match(token_end)
End If
End Function
Private Function Expression(dblRet As Double) As Boolean
Dim dblRHS As Double
If Not Term(dblRet) Then Exit Function
Do
If Match(token_add) Then
If Not Term(dblRHS) Then Exit Function
dblRet = dblRet + dblRHS
ElseIf Match(token_sub) Then
If Not Term(dblRHS) Then Exit Function
dblRet = dblRet - dblRHS
Else
Exit Do
End If
Loop
Expression = True
End Function
Private Function Term(dblRet As Double) As Boolean
Dim dblRHS As Double
If Not Factor(dblRet) Then Exit Function
Do
If Match(token_mul) Then
If Not Factor(dblRHS) Then Exit Function
dblRet = dblRet * dblRHS
ElseIf Match(token_div) Then
If Not Factor(dblRHS) Then Exit Function
dblRet = dblRet / dblRHS
Else
Exit Do
End If
Loop
Term = True
End Function
Private Function Factor(dblRet As Double) As Boolean
Dim dblRHS As Double
With m_tkn(m_lngCurTkn)
Select Case .Type
Case token_sub
m_lngCurTkn = m_lngCurTkn + 1
If Not Factor(dblRet) Then Exit Function
dblRet = -dblRet
Case token_add
m_lngCurTkn = m_lngCurTkn + 1
If Not Factor(dblRet) Then Exit Function
Case token_val
dblRet = .content
m_lngCurTkn = m_lngCurTkn + 1
Case token_var
dblRet = m_vars(.varidx).content
m_lngCurTkn = m_lngCurTkn + 1
Case token_parl
m_lngCurTkn = m_lngCurTkn + 1
If Not Expression(dblRet) Then Exit Function
If Not Match(token_parr) Then Exit Function
Case Else
Exit Function
End Select
End With
Do While Match(token_pow)
If Not Factor(dblRHS) Then Exit Function
dblRet = dblRet ^ dblRHS
Loop
Factor = True
End Function
Private Function Match(ByVal tk As TokenType) As Boolean
If tk = m_tkn(m_lngCurTkn).Type Then
m_lngCurTkn = m_lngCurTkn + 1
Match = True
End If
End Function
Private Function GetToken() As Token
Dim blnGotToken As Boolean
Dim strChr As String
If m_lngPos > Len(m_strExpr) Then
GetToken.Type = token_end
Exit Function
End If
Do While Not blnGotToken
strChr = Mid$(m_strExpr, m_lngPos, 1)
Select Case strChr
Case " "
Case "+", "-", "*", "/", "^", "(", ")"
GetToken.Type = Asc(strChr)
blnGotToken = True
Case "a" To "z", "A" To "Z":
Dim strStr As String
Dim i As Long
Do While m_lngPos <= Len(m_strExpr)
If strChr Like "[a-zA-Z0-9]" Then
strStr = strStr & strChr
m_lngPos = m_lngPos + 1
strChr = Mid$(m_strExpr, m_lngPos, 1)
Else
m_lngPos = m_lngPos - 1
Exit Do
End If
Loop
For i = 0 To m_lngVars - 1
If StrComp(m_vars(i).Name, strStr, vbTextCompare) = 0 Then
GetToken.Type = token_var
GetToken.varidx = i
Exit For
End If
Next
If i = m_lngVars Then GetToken.Type = token_unk
blnGotToken = True
Case "0" To "9"
Dim strValue As String
Dim blnGotDot As Boolean
Do While m_lngPos <= Len(m_strExpr)
Select Case True
Case IsNumeric(strChr)
strValue = strValue & strChr
Case strChr = "."
If Not blnGotDot Then
strValue = strValue & "."
blnGotDot = True
Else
Exit Do
End If
Case Else
Exit Do
End Select
m_lngPos = m_lngPos + 1
strChr = Mid$(m_strExpr, m_lngPos, 1)
Loop
GetToken.Type = token_val
GetToken.content = Val(strValue)
m_lngPos = m_lngPos - 1
blnGotToken = True
Case Else
GetToken.Type = token_unk
blnGotToken = True
End Select
m_lngPos = m_lngPos + 1
Loop
End Function
|
