I need a fast and easy way to parse a math expression that only contains addition and multiplication, the numbers can have decimals.
the result is a whole number, so the decimals are only used inside the parser. here's my take:
Code:
Private Function doMath&(ByVal Exp$)
Dim i&, j&, a&, b&, am!, bm!, rm!, f$
f = "x"
For j = 1 To 2
Do
i = InStr(1, Exp, f)
If i = 0 Then
Exit Do
Else
a = i - 1
b = i + 1
Do
If Mid(Exp, a, 1) = "+" Then Exit Do Else a = a - 1
Loop Until a = 0
Do
If Mid(Exp, b, 1) = "+" Then Exit Do Else b = b + 1
Loop Until b > Len(Exp)
am = CSng(Mid(Exp, a + 1, i - a - 1))
bm = CSng(Mid(Exp, i + 1, b - i - 1))
If j = 1 Then rm = am * bm Else rm = am + bm
Exp = Left(Exp, a) & CStr(rm) & Mid(Exp, b)
End If
Loop
f = "+"
Next j
doMath = CLng(Exp)
End Function
and no, it should not require a reference/component/ocx. maybe a windows API (need to be available xp to 10)
so my question is, if theres a better way to do it, smarter and faster?
as I wrote, only * and +, but if you include / - and its better I dont mind, but Its not required.
the importance is speed more than length of code.
I just put together a sample grammar for VbPeg that impl +/- and mul/div on doubles along with parentheses for explicit operations precedence and then compiled the parser to cCalc2.cls.
In the sample project the grammar is called from Sub Main evaluating command line arguments and dumping the result (double value) and optionally an error from the expression parser (string).
At 497 LOC this parser seems a bit bloated for your case but works reasonable w/o external deps, here are samples of error reporting along w/ intermediate results on failure:
C:\Work\Temp\vbpeg\test\calc2>Project1.exe ((1+2)*3)/2***
Result: 4.5
Error: Extra characters: ***
You can also use VbPeg's `-public` or `-private` options to generates a public/private class module from the sample grammar (instead of a global .bas) for better encapsulation.
Code:
Usage: VbPeg.exe [options] <in_file.peg>
Options:
-o OUTFILE write result to OUTFILE [default: stdout]
-tree output parse tree
-ir output intermediate represetation
-public emit public VB6 class module
-private emit private VB6 class module
-module NAME VB6 class/module name [default: OUTFILE]
-userdata TYPE parser context's UserData member data-type [default: Variant]
-q in quiet operation outputs only errors
doing more tests, using Byref speed up the parsing a lot,
also, copying char by char is faster than using mid$() strangely enough.
also slipping it to multiple functions makes it a bit faster as well.
edit: byref is not an option, destroys the string as Schmidt pointed out!
Here is a simple evaluating expression-parser, which can do a bit more than just "plus and mul"
(it is not performance-optimized, but quite short code-wise - able to support even simple function-calls):
Into a *.bas-Module
Code:
Option Explicit
Public Function Eval(ByVal Expr As String)
Dim L As String, R As String
Do While HandleParentheses(Expr): Loop
If 0 Then
ElseIf Spl(Expr, "Or", L, R) Then: Eval = Eval(L) Or Eval(R)
ElseIf Spl(Expr, "And", L, R) Then: Eval = Eval(L) And Eval(R)
ElseIf Spl(Expr, ">=", L, R) Then: Eval = Eval(L) >= Eval(R)
ElseIf Spl(Expr, "<=", L, R) Then: Eval = Eval(L) <= Eval(R)
ElseIf Spl(Expr, "=", L, R) Then: Eval = Eval(L) = Eval(R)
ElseIf Spl(Expr, ">", L, R) Then: Eval = Eval(L) > Eval(R)
ElseIf Spl(Expr, "<", L, R) Then: Eval = Eval(L) < Eval(R)
ElseIf Spl(Expr, "Like", L, R) Then: Eval = Eval(L) Like Eval(R)
ElseIf Spl(Expr, "&", L, R) Then: Eval = Eval(L) & Eval(R)
ElseIf Spl(Expr, "-", L, R) Then: Eval = Eval(L) - Eval(R)
ElseIf Spl(Expr, "+", L, R) Then: Eval = Eval(L) + Eval(R)
ElseIf Spl(Expr, "Mod", L, R) Then: Eval = Eval(L) Mod Eval(R)
ElseIf Spl(Expr, "\", L, R) Then: Eval = Eval(L) \ Eval(R)
ElseIf Spl(Expr, "*", L, R) Then: Eval = Eval(L) * Eval(R)
ElseIf Spl(Expr, "/", L, R) Then: Eval = Eval(L) / Eval(R)
ElseIf Spl(Expr, "^", L, R) Then: Eval = Eval(L) ^ Eval(R)
ElseIf Trim(Expr) >= "A" Then: Eval = Fnc(Expr)
ElseIf Len(Expr) Then: Eval = IIf(InStr(Expr, "'"), _
Replace(Trim(Expr), "'", ""), Val(Expr))
End If
End Function
Private Function HandleParentheses(Expr As String) As Boolean
Dim P As Long, i As Long, C As Long
P = InStr(Expr, "(")
If P Then HandleParentheses = True Else Exit Function
For i = P To Len(Expr)
If Mid(Expr, i, 1) = "(" Then C = C + 1
If Mid(Expr, i, 1) = ")" Then C = C - 1
If C = 0 Then Exit For
Next i
Expr = Left(Expr, P - 1) & Str(Eval(Mid(Expr, P + 1, i - P - 1))) & Mid(Expr, i + 1)
End Function
Private Function Spl(Expr As String, Op$, L$, R$) As Boolean
Dim P As Long
P = InStrRev(Expr, Op, , 1)
If P Then Spl = True Else Exit Function
If P < InStrRev(Expr, "'") And InStr("*-", Op) Then P = InStrRev(Expr, "'", P) - 1
R = Mid(Expr, P + Len(Op))
L = Trim(Left$(Expr, IIf(P > 0, P - 1, 0)))
Select Case Right(L, 1)
Case "", "+", "*", "/", "A" To "z": Spl = False
Case "-": R = "-" & R
End Select
End Function
Private Function Fnc(Expr As String)
Expr = LCase(Trim(Expr))
Select Case Left(Expr, 3)
Case "abs": Fnc = Abs(Val(Mid$(Expr, 4)))
Case "sin": Fnc = Sin(Val(Mid$(Expr, 4)))
Case "cos": Fnc = Cos(Val(Mid$(Expr, 4)))
Case "atn": Fnc = Atn(Val(Mid$(Expr, 4)))
Case "log": Fnc = Log(Val(Mid$(Expr, 4)))
Case "exp": Fnc = Exp(Val(Mid$(Expr, 4)))
'etc...
End Select
End Function
Form-Code (with a few testcases - comparing outputs with the VB6-expression-solver)
Code:
Option Explicit
'just a group of Test-calls for the simple Evaluator (in comparison to VB-outputs)
'the VB6-resolved expression is always located directly below the Eval-String to
'be able to compare the test-expressions more easily ...
'(results are printed side-by-side and should come out the same in all test-cases)
Private Sub Form_Load()
'simple operator-precedence without parentheses
Debug.Print Eval("3 + 5 * 9 + 7 + 2 * 5"), _
3 + 5 * 9 + 7 + 2 * 5
Debug.Print Eval("1 + 6 / 3 - 7"), _
1 + 6 / 3 - 7
'unary-operator test
Debug.Print Eval("-1 + -6 / 3 - -7 "), _
-1 + -6 / 3 - -7
'simple parentheses test
Debug.Print Eval("-14 / 7 * -(1 + 2)"), _
-14 / 7 * -(1 + 2)
'a complex case, including exponent-handling
Debug.Print Eval("((1 + -2) * -3 + 4) * 2 / 7 * 216 ^ (-1 / -3) "), _
((1 + -2) * -3 + 4) * 2 / 7 * 216 ^ (-1 / -3)
'operator-precedence (mainly to test Mod and Div operators)
Debug.Print Eval("27 / 3 Mod (5 \ 2) + 23"), _
27 / 3 Mod (5 \ 2) + 23
'function-calls
Debug.Print Eval("43 + -(-2 - 3) * Abs(Cos(4 * Atn(1)))"), _
43 + -(-2 - 3) * Abs(Cos(4 * Atn(1)))
'simple case, but mixed with a string-concat (math-ops have precedence)
Debug.Print Eval("5 + 3 & 2"), _
5 + 3 & 2
'simple case of a string-concat (notation for string-literals as in SQL)
Debug.Print Eval("'abc ' & '123 ' & 'xyz'"), _
"abc " & "123 " & "xyz"
'simple comparison-ops follow... (starting with a string-comparison)
Debug.Print Eval("'abc' > '123'"), _
"abc" > "123"
'comparison of numbers... math-ops have precedence
Debug.Print Eval("3 = 1 + 2"), _
3 = 1 + 2
'comparison of strings per Like-Operator...
Debug.Print Eval("'abc' Like '*b*'"), _
"abc" Like "*b*"
'comparison of strings per Like-Operator (using the "in-range" notation)
Debug.Print Eval("'3xB..foo' Like '[1-5]?[A-C]*o'"), _
"3xB..foo" Like "[1-5]?[A-C]*o"
'and here logical comparisons, involving the And-Operator (a mix of String- and Value-Compares)
Debug.Print Eval("'foobar' Like 'foo*' And 'foobar' Like '*bar' And (1 + 2) * 4 - 1 = 11"), _
"foobar" Like "foo*" And "foobar" Like "*bar" And (1 + 2) * 4 - 1 = 11
End Sub
thx for the evaluator, its quite neat and includes a lot of equations.
added it to one project to try the speed, but the result time is not satisfactory, so i tried to strip down your code to just work with + & * to see if i could increase performance.
this is the stripped down version:
Code:
Public Function Eval(Expr As String)
Dim L As String, R As String
If 0 Then
ElseIf Spl(Expr, "+", L, R) Then: Eval = Eval(L) + Eval(R)
ElseIf Spl(Expr, "*", L, R) Then: Eval = Eval(L) * Eval(R)
ElseIf Len(Expr) Then: Eval = Val(Expr)
End If
End Function
Private Function Spl(Expr As String, Op$, L$, R$) As Boolean
Dim P As Long
P = InStrRev(Expr, Op, , 1)
If P Then Spl = True Else Exit Function
R = Mid(Expr, P + Len(Op))
L = Trim(Left$(Expr, IIf(P > 0, P - 1, 0)))
Select Case Right(L, 1)
Case "", "+", "*": Spl = False
End Select
End Function
still comparing the code im using, its a bit slower.
doing 1.000.000 evaluations.
my code: average 160 milliseconds
your stripped down: average 19500 milliseconds.
my code:
Code:
Private Function solveAdd$(Expr$)
Dim X&, i&, a&, b&, s$, teA$, teB$
X = InStr(1, Expr, "+")
a = X - 1
b = X + 1
Do
s = Mid$(Expr, a, 1)
If s = "+" Then Exit Do Else teA = s & teA: a = a - 1
Loop Until a = 0
Do
s = Mid$(Expr, b, 1)
If s = "+" Then Exit Do Else teB = teB & s: b = b + 1
Loop Until b > Len(Expr)
solveAdd = Left(Expr, a) & CStr(CSng(teA) + CSng(teB)) & Mid(Expr, b)
End Function
Private Function solveMul$(Expr$)
Dim X&, i&, a&, b&, s$, teA$, teB$
X = InStr(1, Expr, "x")
a = X - 1
b = X + 1
Do
s = Mid$(Expr, a, 1)
If s = "x" Or s = "+" Then Exit Do Else teA = s & teA: a = a - 1
Loop Until a = 0
Do
s = Mid$(Expr, b, 1)
If s = "x" Or s = "+" Then Exit Do Else teB = teB & s: b = b + 1
Loop Until b > Len(Expr)
solveMul = Left(Expr, a) & CStr(CSng(teA) * CSng(teB)) & Mid(Expr, b)
End Function
Public Function doMath&(Expr$)
Do
If InStr(Expr, "x") = 0 Then Exit Do Else Expr = solveMul(Expr)
Loop
Do
If InStr(Expr, "+") = 0 Then Exit Do Else Expr = solveAdd(Expr)
Loop
doMath = CLng(Expr)
End Function
as I only need + * x
the reason I only need + and x is because its different formulas inside the game.
its information and part of the string have a "formula" that need to be converted into numbers before it show.
it could look like this: &Lx0,75& or &Lx5& or &Lx0,5+20& where L is a number of the current level, so I use another function to find the &___& and do the Replace of L than I call the math parser.
yeah, the result is not saying anything as its based on your computer specs, but the comparison do.
that is why i need as fast possible, im sure that even Olaf's eval works in the game, its not that I need to call it 1 million times haha...
but its more that that, theres a lot going on in a game, so I always try to find the fastest solution for anything.
so far the method I use is good. I don't need division because, 5 / 2 is equal to 5 * 0,5 and Im the one adding the formulas.
anyway, your suggestions are not in vain, olaf' eval is very neat and if this thread stick around Im sure others could have use for it.
or even use the one I posted, to add / and - is not that hard.
Option Explicit
Private Sub Command1_Click()
Dim scrObj As Object
Dim xResult$
Dim xText$
'Text1= '3+5*9+7+2*5
xText = Text1.Text
Set scrObj = CreateObject("ScriptControl")
scrObj.Language = "VBScript"
scrObj.ExecuteStatement ("xResult = " & xText)
xResult = scrObj.Eval("xResult")
Text2.Text = "the result from " & xText & " is " & xResult
End Sub
Private Sub Form_Load()
Text1.Text = "3+5*9+7+2*5"
End Sub
regards
Chris
to hunt a species to extinction is not logical !
since 2010 the number of Tigers are rising again in 2016 - 3900 were counted. with Baby Callas it's 3901, my wife and I had 2-3 months the privilege of raising a Baby Tiger.
yeah, we can use scriptcontrol, word, database, ocx, etc to evaluate, but I posted that I didn't want to use that, just pure vb.
anyway, to try the speed, I added the scrObj on its own to just call it once.
so the only lines are scrObj.ExecuteStatement ("xResult = " & xText) and the result.
comparison: 10,000 loops. took around 6 milliseconds using my code and 140-150 milliseconds using ScriptControl.
... tried to strip down your code to just work with + & * to see if i could increase performance.
this is the stripped down version:
Code:
Public Function Eval(Expr As String)
Dim L As String, R As String
If 0 Then
ElseIf Spl(Expr, "+", L, R) Then: Eval = Eval(L) + Eval(R)
ElseIf Spl(Expr, "*", L, R) Then: Eval = Eval(L) * Eval(R)
ElseIf Len(Expr) Then: Eval = Val(Expr)
End If
End Function
Private Function Spl(Expr As String, Op$, L$, R$) As Boolean
Dim P As Long
P = InStrRev(Expr, Op, , 1)
If P Then Spl = True Else Exit Function
R = Mid(Expr, P + Len(Op))
L = Trim(Left$(Expr, IIf(P > 0, P - 1, 0)))
Select Case Right(L, 1)
Case "", "+", "*": Spl = False
End Select
End Function
A better "stripped down"-version could look this way:
Code:
Public Function Eval(Expr As String) As Double
Dim L As String, R As String
If Spl(Expr, "+", L, R) Then Eval = Eval(L) + Eval(R): Exit Function
If Spl(Expr, "*", L, R) Then Eval = Eval(L) * Eval(R): Exit Function
If Len(Expr) Then Eval = Val(Expr)
End Function
Private Function Spl(Expr As String, Op$, L$, R$) As Long
Spl = InStrRev(Expr, Op)
If Spl Then R = Mid$(Expr, Spl + Len(Op)): L = Left$(Expr, Spl - 1)
End Function
With that change, my test-results (doing 100000 iterations) come out as:
- Eval (0.85 sec)
- doMath (1.45 sec)
So your code is about 2 times slower - here is the test-code I was using (in a Form):
Code:
Option Explicit
Private Sub Form_Click()
AutoRedraw = True: Cls
Dim i As Long, T!, Result
T = Timer
For i = 1 To 100000
Result = Eval("3+5*9+7+2*5+3")
Next
Print "Eval", Timer - T, Result
T = Timer
For i = 1 To 100000
Result = doMath("3+5x9+7+2x5+3")
Next
Print "doMath", Timer - T, Result
End Sub
Edit:
And another speedup (about factor 2 again) can be achieved, when the Spl-Subfunction-calls are avoided:
Code:
Public Function Eval(Expr As String) As Double 'that's all what is needed
Dim P As Long
P = InStr(Expr, "+"): If P Then Eval = Eval(Left$(Expr, P - 1)) + Eval(Mid$(Expr, P + 1)): Exit Function
P = InStr(Expr, "*"): If P Then Eval = Eval(Left$(Expr, P - 1)) * Eval(Mid$(Expr, P + 1)): Exit Function
If Len(Expr) Then Eval = Val(Expr)
End Function
hmm, not sure how you got those numbers. trying in my project i get
(1,000,000) loops, 325 from doMath and 5765 from (new) Eval
maybe you can take a look.
edit: I did change doMath a bit, as you can see in the posts, i figure out that Byref and Copy single ascii is faster than Byval and using Mid$.
This class isn't super-rich. It handles only +, -, *, /, and ^ but it does do ( and ) as well as hex and octal and can be used locale-blind or locale-aware, even for a specific locale. Whitespace toleration seems pretty good.
Not fully tested. Not a performance screamer but probably good enough for many purposes.
Should be possible to add more operators and even named variables (by adding an = assignment operator). VFormat class also included, to balance locale handling (output as well as input).
Reposted
Changes made to a Property name (and the demo Form UI to match).
Bug in parsing ")" corrected.
Operators for integer divide \ and modulus % added though I could be happier about using % instead of Mod but right now I didn't want to add multicharacter operators.
Replaced VarXXX() OLE API calls by VB6 operations.
Other minor optimizations such as replacing some Select Case statements with On x GoTo statements. Those are slightly quicker but not really all that much so they may be a dubious choice.
Last edited by dilettante; Mar 18th, 2018 at 02:46 PM.
By using the test-routine I've posted in #12 (you should try it).
Originally Posted by baka
trying in my project i get
(1,000,000) loops, 325 from doMath and 5765 from (new) Eval
maybe you can take a look.
I did that - and what you do in your test-loop is:
Not taking into account, that your routine *does* destroy the (ByRef) Input-Value - in a way,
that already after the first round, you will not evaluate "the original expression-formula" (6+4x6+8+2x7) anymore,
but the result (52) as the new "to evaluate input" instead.
My testcode in #12 did avoid this, by using a String-Literal for the expression (which will get "passed along" unchanged then, in the test-loop).
An easy fix for that (in your test-code) would be, when you change the signature of your Public Function to:
Public Function doMath&(ByVal Expr$)
Then you will get the same results as I was getting with my test-routine:
- doMath being about 3 times slower in IDE-(PCode)-Mode
- and about factor 3.5 - 4 slower when native compiled with all options
@Olaf: Impressively short code!
FYI, tweaked a test case to "-1 + -6 / 3 - --7" and got a diff in the test results in immediate window.
Thanks, the (also slightly performance-optimized) version below can now handle that case of "multiple-unary-minus":
Code:
Option Explicit
Public Function Eval(ByVal Expr As String)
Do While HandleParentheses(Expr): Loop
Dim L As String, R As String
If Spl(Expr, "Or", L, R) Then: Eval = Eval(L) Or Eval(R): Exit Function
If Spl(Expr, "And", L, R) Then: Eval = Eval(L) And Eval(R): Exit Function
If Spl(Expr, ">=", L, R) Then: Eval = Eval(L) >= Eval(R): Exit Function
If Spl(Expr, "<=", L, R) Then: Eval = Eval(L) <= Eval(R): Exit Function
If Spl(Expr, "=", L, R) Then: Eval = Eval(L) = Eval(R): Exit Function
If Spl(Expr, ">", L, R) Then: Eval = Eval(L) > Eval(R): Exit Function
If Spl(Expr, "<", L, R) Then: Eval = Eval(L) < Eval(R): Exit Function
If Spl(Expr, "Like", L, R) Then Eval = Eval(L) Like Eval(R): Exit Function
If Spl(Expr, "&", L, R) Then: Eval = Eval(L) & Eval(R): Exit Function
If Spl(Expr, "-", L, R) Then: Eval = Eval(L) - Eval(R): Exit Function
If Spl(Expr, "+", L, R) Then: Eval = Eval(L) + Eval(R): Exit Function
If Spl(Expr, "Mod", L, R) Then: Eval = Eval(L) Mod Eval(R): Exit Function
If Spl(Expr, "\", L, R) Then: Eval = Eval(L) \ Eval(R): Exit Function
If Spl(Expr, "*", L, R) Then: Eval = Eval(L) * Eval(R): Exit Function
If Spl(Expr, "/", L, R) Then: Eval = Eval(L) / Eval(R): Exit Function
If Spl(Expr, "^", L, R) Then: Eval = Eval(L) ^ Eval(R): Exit Function
If Trim$(Expr) >= "A" Then: Eval = Fnc(Trim$(Expr)): Exit Function
If InStr(Expr, "'") Then Eval = Replace(Trim$(Expr), "'", ""): Exit Function
If Len(Expr) Then Eval = Val(Replace(Expr, "--", ""))
End Function
Private Function HandleParentheses(Expr As String) As Boolean
Dim P As Long, i As Long, C As Long
P = InStr(Expr, "(")
If P Then HandleParentheses = True Else Exit Function
For i = P To Len(Expr)
If Mid$(Expr, i, 1) = "(" Then C = C + 1
If Mid$(Expr, i, 1) = ")" Then C = C - 1
If C = 0 Then Exit For
Next i
Expr = Left$(Expr, P - 1) & Str(Eval(Mid$(Expr, P + 1, i - P - 1))) & Mid$(Expr, i + 1)
End Function
Private Function Spl(Expr As String, Op$, L$, R$) As Boolean
Dim P As Long
P = InStrRev(Expr, Op, , 1)
If P Then Spl = True Else Exit Function
If P < InStrRev(Expr, "'") And InStr("*-", Op) Then P = InStrRev(Expr, "'", P) - 1
L = Trim$(Left$(Expr, P - 1)): R = Mid$(Expr, P + Len(Op))
Do
Select Case Right$(L, 1)
Case "", "+", "*", "/", "A" To "z": Spl = False: Exit Do
Case "-": L = Trim$(Left$(L, Len(L) - 1)): R = "-" & R
Case Else: Exit Do
End Select
Loop
End Function
Private Function Fnc(Expr As String)
Select Case LCase$(Left$(Expr, 3))
Case "abs": Fnc = Abs(Val(Mid$(Expr, 4)))
Case "sin": Fnc = Sin(Val(Mid$(Expr, 4)))
Case "cos": Fnc = Cos(Val(Mid$(Expr, 4)))
Case "atn": Fnc = Atn(Val(Mid$(Expr, 4)))
Case "log": Fnc = Log(Val(Mid$(Expr, 4)))
Case "exp": Fnc = Exp(Val(Mid$(Expr, 4)))
'etc...
End Select
End Function
that explained why it go so fast Schmidt! thanks for finding that error.
in my test project, doing 1M loops, doMath makes to 7731 and your Eval to 2409.
this thread should definitely go to codebank, especially Schmidt's code its very good.
I should have named the property "ReturnedTypes" something like "ParsedTypes" because it applies to the parsed numeric values in the expression rather than the calculated result. This can have an impact on the calculation's final data type, but it does not specify what type or types the result should be limited to.
very impressive dilettante. i can't understand anything on the source code but its superfast and can do a lot!
definitely a keeper if you need an expression evaluator.
Once I am comfortable that the logic has been debugged more thoroughly I might combine the parsing and evaluation, eliminating the queue itself entirely using a second small operand stack instead of reusing the one stack there now. That may run even faster if evaluation is coded inline, saving a procedure call for each parsed token. Not sure I'll revisit this further though.
There may be refinements or alternatives to the shunting algorithm (or better coding) that will run faster. Perhaps the oleaut32.dll value parsing could be replaced with something less generalized using inline code. That could be both faster and far more portable for non-Windows usage. Coping with locale conventions would seem to be of value, especially for programs processing user input. Chopping that out as a requirement would make VB6-code number parsing a lot simpler. Dropping the handling of E-notation for real number values and "thousands separators" simplifies things more. Making everything Double values instead of Variant could speed things a bit more.
But my days of tinkering with compiler and interpreter construction are far behind me. I haven't taken a serious look at this stuff since school back in the 1970s.
Ripping out the On X GoTo statements and putting Select Case back in would be a little slower. But not by much and it might make the code a bit clearer for anyone who wanted to study it or re-engineer it. There are a lot of unused OLE Const values that could be ripped out as well.
@dilettante: FYI, latest VEval 2.0.zip seems to fail on "1 + -(1)" w/ "Bad Expression"
Here is my try on the shunting-yard algorithm
Code:
Option Explicit
Private Declare Function ArrPtr Lib "msvbvm60" Alias "VarPtr" (Ptr() As Any) As Long
Private Declare Sub GetMem4 Lib "msvbvm60" (Source As Any, Destination As Any)
Private Function SimpleEval(sText As String) As Double
Const TOK_FINAL As Long = 0
Const TOK_RPAREN As Long = 1
Const TOK_ADD As Long = 2
Const TOK_MOD As Long = 3
Const TOK_IDIV As Long = 4
Const TOK_MUL As Long = 5
Const TOK_UNARY As Long = 6
Const TOK_POWER As Long = 7
Const TOK_LPAREN As Long = 8
Const TOK_NUM As Long = 9
Const TOK_WHITE As Long = 10
Static aLookup(0 To 255) As Long
Dim uSafeArray(0 To 5) As Long
Dim aTextBuf() As Integer
Dim lPos As Long
Dim nChar As Long
Dim nNumChar As Long
Dim lNumSize As Long
Dim aValStack(0 To 1000) As Double
Dim lValIdx As Long
Dim aOpStack(0 To 1000) As Long
Dim lOpIdx As Long
Dim lTokPreced As Long
Dim lPrevPreced As Long
On Error GoTo EH
'--- one-time init of token type lookup
If aLookup(32) = 0 Then
For nChar = 0 To UBound(aLookup)
Select Case nChar
Case 40 ' "("
aLookup(nChar) = TOK_LPAREN
Case 41 ' ")"
aLookup(nChar) = TOK_RPAREN
Case 43, 45 ' "+", "-"
aLookup(nChar) = TOK_ADD
Case 42, 47 ' "*", "/"
aLookup(nChar) = TOK_MUL
Case 94 ' "^"
aLookup(nChar) = TOK_POWER
Case 92 ' "\"
aLookup(nChar) = TOK_IDIV
Case 37 ' "%"
aLookup(nChar) = TOK_MOD
Case 48 To 57, 46 ' "0" To "9", "."
aLookup(nChar) = TOK_NUM
Case 32, 10, 13 ' " ", vbCrLf
aLookup(nChar) = TOK_WHITE
Case Else
aLookup(nChar) = TOK_WHITE
End Select
Next
End If
'--- point aTextBuf -> sText w/o copying
uSafeArray(0) = 1 ' cDims
uSafeArray(1) = 2 ' cbElements
uSafeArray(3) = StrPtr(sText) ' pvData
uSafeArray(4) = Len(sText) + 1 ' cElements
Call GetMem4(VarPtr(uSafeArray(0)), ByVal ArrPtr(aTextBuf))
For lPos = 0 To Len(sText) - 1
nChar = aTextBuf(lPos)
If nChar >= 256 Then
GoTo Continue
End If
lTokPreced = aLookup(nChar)
If lTokPreced = TOK_NUM Then
For lNumSize = 1 To 100
nNumChar = aTextBuf(lPos + lNumSize)
If nNumChar >= 256 Or aLookup(nNumChar And &HFF&) <> TOK_NUM Then
Exit For
End If
Next
lValIdx = lValIdx + 1
aValStack(lValIdx) = Val(Mid$(sText, lPos + 1, lNumSize))
lTokPreced = TOK_NUM
lPos = lPos + lNumSize - 1
ElseIf lTokPreced = TOK_ADD Then
If lPrevPreced >= TOK_ADD And lPrevPreced < TOK_NUM Then
lTokPreced = TOK_UNARY
End If
ElseIf lTokPreced = TOK_WHITE Then
GoTo Continue
End If
If lTokPreced >= TOK_ADD And lTokPreced < TOK_NUM Then
If lTokPreced <> TOK_UNARY Then '--- right assoc
GoSub EvalOpStack
End If
lOpIdx = lOpIdx + 1
aOpStack(lOpIdx) = lTokPreced * &H10000 + nChar
End If
lPrevPreced = lTokPreced
Continue:
Next
lTokPreced = TOK_FINAL
GoSub EvalOpStack
SimpleEval = aValStack(lValIdx)
EH:
'--- un-peek sText
Call GetMem4(0&, ByVal ArrPtr(aTextBuf))
Exit Function
EvalOpStack:
For lOpIdx = lOpIdx To 1 Step -1
If aOpStack(lOpIdx) < lTokPreced * &H10000 Then
Exit For
End If
lValIdx = lValIdx - 1
Select Case aOpStack(lOpIdx) And &HFFFF&
Case 43 ' "+"
If aOpStack(lOpIdx) > TOK_UNARY * &H10000 Then
lValIdx = lValIdx + 1
Else
aValStack(lValIdx) = aValStack(lValIdx) + aValStack(lValIdx + 1)
End If
Case 45 ' "-"
If aOpStack(lOpIdx) > TOK_UNARY * &H10000 Then
lValIdx = lValIdx + 1
aValStack(lValIdx) = -aValStack(lValIdx)
Else
aValStack(lValIdx) = aValStack(lValIdx) - aValStack(lValIdx + 1)
End If
Case 42 ' "*"
aValStack(lValIdx) = aValStack(lValIdx) * aValStack(lValIdx + 1)
Case 47 ' "/"
aValStack(lValIdx) = aValStack(lValIdx) / aValStack(lValIdx + 1)
Case 94 ' "^"
aValStack(lValIdx) = aValStack(lValIdx) ^ aValStack(lValIdx + 1)
Case 92 ' "\"
aValStack(lValIdx) = aValStack(lValIdx) \ aValStack(lValIdx + 1)
Case 37 ' "%"
aValStack(lValIdx) = aValStack(lValIdx) Mod aValStack(lValIdx + 1)
Case 40 ' "("
lValIdx = lValIdx + 1
If lTokPreced = TOK_RPAREN Then
lOpIdx = lOpIdx - 1
Exit For
ElseIf lTokPreced > TOK_RPAREN Then
Exit For
End If
End Select
Next
Return
End Function
Private Sub Form_Load()
Debug.Assert SimpleEval("(3.5) + 2.9 * (2 + -(1 + 2))") = (3.5) + 2.9 * (2 + -(1 + 2))
Debug.Assert SimpleEval("2 \ 3 / 3") = 2 \ 3 / 3
Debug.Assert SimpleEval("2 ^ -3 ^ 4") = 2 ^ -3 ^ 4
Debug.Assert SimpleEval("2 ^ 3 \ 5 ^ 2 / 5 / 3") = 2 ^ 3 \ 5 ^ 2 / 5 / 3
Dim sExpr As String
Dim dblTimer As Double
Dim lIdx As Long
Dim dblResult As Double
sExpr = "(3.5) + 2.9 * (2 + -(1 + 2))"
dblTimer = Timer
For lIdx = 1 To 100000
dblResult = SimpleEval(sExpr)
Next
Debug.Print "SimpleEval: " & dblResult, Format$(Timer - dblTimer, "0.000")
End Sub
This supports same operators w/ no variables but is about as fast as VEval class and is ~150 LOC in total.
cheers,
</wqw>
Last edited by wqweto; Mar 21st, 2018 at 10:21 AM.
I was dealing with unary minus in a trivial and naive way. I'll have to look at correcting that.
Ok, I replaced post #21 version 2.0 attachment with version 2.1 which seems to fix that issue. If I'm lucky I haven't broken something else with that patch.
Last edited by dilettante; Mar 20th, 2018 at 10:03 AM.
The precedence fix should be easy enough. I think exponentiation needs to be handled as right-associative so I can look at that too. See Operator associativity.
I haven't followed every word of this thread, but y'all are bumping up against a problem I've fought in the past: negation.
In some math books, it's taught that negation has the highest order of precedence. However, that's not how most (if not all) programming languages work. Furthermore, we must distinguish between a variable containing a negative value and a negated variable (or constant or literal constant). In other words, there's a fundamental difference between the two printed Debug statements in the following:
Code:
Dim i As Long
Dim j As Long
i = -5
j = 5
Debug.Print i ^ 2
Debug.Print -j ^ 2
To fully understand negation, we must conceptualize a negative one variable (or constant)...
Code:
Const NegOne = -1
Now, with this constant, we can conceptualize negation as a number times this constant. For instance, in the above, we can conceptualize...
Code:
Dim i As Long
Dim j As Long
Const NegOne = -1
i = NegOne * 5
j = 5
Debug.Print i ^ 2
Debug.Print NegOne * j ^ 2
And now, we can "see" that the precedence order of operations makes perfect sense. Every negation must be "conceptualized" as the number being multiplied by -1 (with the -1 on the left-hand-side, as is the negation symbol).
And, I suppose these expression evaluators should work the same way.
Best Regards,
Elroy
Last edited by Elroy; Mar 21st, 2018 at 05:32 PM.
Any software I post in these forums written by me is provided "AS IS" without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. To all, peace and happiness.
Hit a deer last night and the insurance co. totaled out my car so I'm dealing with all of that right now.
Oh crud. Sorry to hear that, dilettante. I've hit three deer in the past, and one coyote. Two of the deer and the coyote were all in the same car, Chrysler Sebring. In fact, both deer, they hit me more than me hitting them. I finally figured out that a good horn does wonders to shake them out of their headlight daze.
Best of luck with getting everything sorted.
Elroy
Any software I post in these forums written by me is provided "AS IS" without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. To all, peace and happiness.
Eh, this was on a country road at 55 MPH at a point where the road is narrow and trees and brush are in quite close. Little more than a flash and the deer was right there, and I was watching intently for just this thing too.
At least the (old) car was wedge-shaped enough that the deer rolled up the hood, the windshield, and over the roof. Until I got to a phone at a 24 hour gas station (didn't have my cellphone with me) I expected minor damage. Turned out the hood was pretty messed up though it stayed down but the right headlamp cluster was gone. Minor coolant leak, but driveable. Didn't pop any airbags.
Got a repair estimate, then the insurance appraiser came out and said "It's dead, Jim" i.e. totaled. If I had made it to May the car would be 16 years old. Longer than I was with my ex wife, sad to see a "member of the family" go like that.
By the time I got home today in a new car the tow truck was just hauling the old car from my driveway. Almost done aside from getting a lien-release letter I can't find my copy of so I can turn it over to the salvage yard with the title. Well that and getting the bad news from my insurance about my new premium rates when I get my token compensation.
Amazing what they think you need in a car these days. Web browser? Seriously? BTW: this new car was built in a UK plant. Just glad to be in the position to whip out the checkbook for this sort of thing. A lot of people would be tempted to pay the $400 buyout and then get the old car duct-taped back together.
I'll have to baby it through the break-in period so I can put 300K miles on this one too. I just need to avoid making the turbo kick in and be easy on braking.
Too late I remembered I had about $5 in toll change I forgot to grab when I cleaned out the old buggy. At least I had just renewed my registration so I won't have to pay the higher rates on the new car for the next 11 months or so.
I'll add that though the collision didn't bother me the money has left me more than a little rattled, being cheaper than Jack Benny. But I'd been casually car shopping for years and I did all the math as well as understanding how bad a choice it is to repair cars post-collision. Been there, done that before... after a semi tractor drove over my previous car while it was parked in a grocery store parking lot. That one I drove home too, but after repairs it was never quite right and I got rid of it.
Last edited by dilettante; Mar 21st, 2018 at 10:32 PM.
And now, we can "see" that the precedence order of operations makes perfect sense. Every negation must be "conceptualized" as the number being multiplied by -1 (with the -1 on the left-hand-side, as is the negation symbol).
And, I suppose these expression evaluators should work the same way.
All 3 return different results and you didn't mention using parens at all. It's obviously not just syntactic substition.
The correct precedence seems to be Debug.Print 2 ^ (NegOne * j ^ 2)
cheers,
</wqw>
Yeah, I actually thought about that after I made that post. When a negation actually IS the exponent, it apparently does have a higher precedence. However, your example is just weird. Although, with enough thought, it does make sense, sort of. It places a double-condition on negation. Basically, the expression is evaluated for negation to see if anything can be executed with negation having lower precedence. And then, it's re-evaluated to see if it can be evaluated with negation having higher precedence. And apparently, that's independent of any left-to-right evaluation. And that's basically what you outlined in your last sentence.
Best Regards,
Elroy
Any software I post in these forums written by me is provided "AS IS" without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. To all, peace and happiness.
Reply With Quote
Originally Posted by baka
