Parse Math expressions, find roots in VB
' Visual Basic 6 module
'-------------------------- Math.bas ---------------------------
' Math expression parser that supports +, -, *, /, ^ (power),
' @ (logarithm), functions (exp, ln, sin, cos, tan, asin, acos,
' atan, sinh, cosh, tanh, int, frac, abs, sqrt), brackets
' Validate expression syntax, evaluate functions, derive functions
' Find roots using bisection method and Newton method
'-------------------------- Math.bas ---------------------------
' Copyright Ionut Alex. Chitu, http://deadline.3x.ro
'
' Public functions:
' Function Error_Message(ByVal N As Integer) As String
'
' N = Code number
' Returns the associated error message
'
' Sub Check_Syntax(ByVal S As String, ByVal WithX as Boolean,
' ByRef Function_Error As Integer, ByRef i1 As Integer)
'
' S = function text
' WithX = can contain x variable?
' Function_Error = error code, 0=no error
' i1 = position in function text of the error
'
' Function Evaluate(ByVal S As String, ByVal x As Double,
' ByRef Function_Error As Integer) As Double
'
' S = function text
' x = value of the variable
' Function_Error = error code, 0=no error
' Returns the result of evaluation
'
' Function Derive (ByVal S As String, ByVal X As Double,
' ByRef Function_Error As Integer) As Double
'
' S = function text
' X = value of the variable
' Function_Error = error code, 0=no error
' Returns the result of numerical derivative
'
' Function Find_root_Newton(ByVal S As String, ByVal x0 As Double, _
' ByVal eps As Double, ByRef FErr As Integer) As Double
'
' S = function text
' x0 = estimation of the root
' eps = precision of the root
' FErr = error code, 0=no error
' Returns the root close to x0
'
' Function Find_root_bisection(ByVal S As String, ByVal a As Double, _
' ByVal b As Double, ByVal eps As Double, _
' ByRef Err As Integer) As Double
'
' S = function text
' a, b = interval where to search the root
' eps = precision of the root
' Err = (out) error code, 0=no error
' Returns a root that lies in [a, b]
'
'
' Example (copy-paste this code in a form load event in VB6):
' Dim fun as String, Err as Integer, pos as Integer
' Dim x as Double, y as Double
' fun="sin(x)+2*cos(x^2)"
' x=0
' Check_Syntax fun, True, Err, pos
' If Err=0 then
' y=Evaluate(fun, x, Err)
' If Err=0 then
' MsgBox "f(" & CStr(x) & ")=" & CStr(y), vbInformation, fun
' Else
' MsgBox Error_Message(Err)
' End If
' Else
' MsgBox Error_Message(Err)
' End If
'
'-------------------------------------------------------------------
Option Explicit 'always use this option in vb
Private Const Pi As Double = 3.14159265358979
Private Const e As Double = 2.71828182845905
Private argX As String
Private Const evNumber = 1
Private Const evConstant = 2
Private Const evFunction = 5
Private Const evLeftBracket = 6
Private Const evRightBracket = 7
Private Const evOperand = 8
Private Const evElse = 16
Public Function Error_Message(n As Integer) As String
Select Case n
Case 0
Error_Message = "No error !"
Case 1
Error_Message = "Error evaluating power function."
Case 2
Error_Message = "Error evaluating logarithm. The argument must be > 0."
Case 3
Error_Message = "Error evaluating tangent."
Case 4
Error_Message = "Error evaluating square root. The argument must be >= 0."
Case 5
Error_Message = "Error evaluating arcsine. The argument must be in [-1, 1]."
Case 6
Error_Message = "Error evaluating arccosine. The argument must be in [-1, 1]."
Case 7
Error_Message = "Division by zero."
Case 11
Error_Message = "Unexpected end of parenthesis."
Case 12
Error_Message = "Operators must be followed by number, constant, function."
Case 13
Error_Message = "Function must be followed by parenthesis."
Case 14
Error_Message = "An error occured in evaluation"
Case 15
Error_Message = "Expression expected."
Case 16
Error_Message = "Unknown function."
Case 17
Error_Message = "Enter the value for which you want to evaluate the function."
Case 18
Error_Message = "An error occured in evaluation"
End Select
End Function
Private Function IsNum(ByVal s As String) As Boolean
IsNum = IsNumeric(s) Or (s = ".") Or (s = ",")
End Function
Private Function Lexical_Unit(ByVal c As String) As Integer
c = LCase$(c)
If IsNum(c) Then
Lexical_Unit = evNumber
Else
Select Case c
Case argX, "e", "pi"
Lexical_Unit = evConstant
Case "ln", "abs", "exp", "sqrt", "int", "frac", _
"sin", "cos", "tan", "asin", "acos", "atan", _
"sinh", "cosh", "tanh"
Lexical_Unit = evFunction
Case "("
Lexical_Unit = evLeftBracket
Case ")"
Lexical_Unit = evRightBracket
Case "+", "-", "*", "/", "^", "@"
Lexical_Unit = evOperand
Case Else
Lexical_Unit = evElse
End Select
End If
End Function
Public Sub Next_Token(ByVal S As String, ByVal k As Integer, _
ByRef i1 As Integer, ByRef i2 As Integer)
Dim s1 As String, s2 As String
Dim other_token As Boolean
Do While Mid$(S, k, 1) = " "
k = k + 1
Loop
i1 = k
s1 = LCase$(Mid$(S, k, 1))
Do
s2 = LCase$(Mid$(S, k + 1, 1))
other_token = (s1 <> s2) And Not (IsNum(s1) And IsNum(s2)) And _
Not ((s1 >= "a") And (s1 <= "z") And (s2 >= "a") And (s2 <= "z"))
k = k + 1
s1 = s2
Loop Until other_token Or ((s1 = "(") And (s2 = "(")) Or ((s1 = ")") And (s2 = ")"))
i2 = k - 1
End Sub
Public Sub Check_Syntax(ByVal S As String, ByVal WithX As Boolean, _
ByRef Function_Error As Integer, ByRef i1 As Integer)
Dim one As Integer, two As Integer, brackets As Integer
Dim k As Integer, i2 As Integer, Si As String, Sk As String
i1 = 2
i2 = 1
argX = IIf(WithX, "x", "")
Function_Error = IIf(Trim(S) = "", 17, 0)
If Function_Error = 17 Then Exit Sub
S = "(" + S + ")"
Si = "("
k = i2 + 1
one = 6 ' Lexical_Unit ("(")
brackets = 1
Do While k <= Len(S)
Next_Token S, k, i1, i2
Sk = Mid$(S, i1, i2 - i1 + 1)
k = i2 + 1
two = Lexical_Unit(Sk)
If two = 16 Then
Function_Error = 16
Exit Sub
End If
Select Case Sk
Case "(": brackets = brackets + 1
Case ")": brackets = brackets - 1
End Select
If brackets < 0 Then
Function_Error = 11
Exit Sub
End If
Select Case one
Case evNumber
If Not ((two = evConstant) Or (two = evLeftBracket) Or _
(two = evRightBracket) Or (two = evOperand)) Then Function_Error = 12
Case evConstant
If Not ((two = evLeftBracket) Or (two = evRightBracket) Or (two = evOperand)) Then Function_Error = 12
Case evFunction
If (two <> evLeftBracket) Then Function_Error = 13
Case evLeftBracket
If (two = evRightBracket) Or ((two = evOperand) And (Sk <> "-")) Then Function_Error = 14
Case evRightBracket
If (two <> evOperand) And (two <> evRightBracket) Then Function_Error = 15
Case evOperand
If (two = evRightBracket) Or (two = evOperand) Then Function_Error = 14
Case evElse
Function_Error = 16
End Select
If Function_Error > 0 Then Exit Sub
Si = Sk
one = two
Loop
If brackets <> 0 Then Function_Error = 11
End Sub
Private Function Priority(ByVal c As String) As Integer
Dim P As Integer
c = Left$(c, 1)
Select Case c
Case "(", ")": P = 0 'Priority 0 : brackets
Case "+", "-": P = 1 'Priority 1 : aditive operators
Case "*", "/": P = 2 'Priority 2 : multiplicative operators
Case "^", "@": P = 3 'Priority 3 : exponential operators (a @ b -> log(a), base=b)
Case "a" To "z", "A" To "Z": P = 4 'Priority 4 : math functions, constants
End Select
Priority = P
End Function
Public Function Evaluate(ByVal S As String, ByVal x As Double, _
ByRef Function_Error As Integer) As Double
' parse expression and evaluate function
On Error GoTo Overflow
Dim opd(200) As Double, op(200) As String
Dim top1 As Integer, top2 As Integer, i As Integer, k As Integer
Dim value As Double, x1 As Double, x2 As Double
Dim i1 As Integer, i2 As Integer, Si As String, Sk As String, S0 As String
Function_Error = 0
argX = "x"
top1 = 0
top2 = 1
op(top2) = "("
S = S + ")"
i = 1
Si = "("
Do While (i <= Len(S)) And (top2 > 0)
Next_Token S, i, i1, i2
Sk = Si
Si = Mid$(S, i1, i2 - i1 + 1)
i = i2 + 1
If IsNum(Si) Then
top1 = top1 + 1
opd(top1) = Val(Replace$(Si, ",", "."))
value = opd(top1)
Else
Select Case LCase$(Si)
Case "(": top2 = top2 + 1: op(top2) = "("
Case argX, "pi", "e":
top1 = top1 + 1
S0 = LCase$(Si)
Select Case S0
Case argX: opd(top1) = x
Case "pi": opd(top1) = Pi
Case "e": opd(top1) = e
End Select
If IsNum(Sk) Then
top2 = top2 + 1
op(top2) = "*"
End If
Case Else
Do While (top2 > 0) And (op(top2) <> "(") And (op(top2) <> ")") _
And (Priority(op(top2)) >= Priority(Si))
If top1 >= 2 Then x1 = opd(top1 - 1)
x2 = opd(top1)
Select Case LCase$(op(top2))
Case "+": value = x1 + x2
Case "-": value = x1 - x2
Case "~": value = -x2 'unary minus
Case "*": value = x1 * x2
Case "/":
If x2 <> 0 Then
value = x1 / x2
Else: Function_Error = 7: Evaluate = 0: Exit Function
End If
Case "^":
If ((x1 < 0) And (x2 <> Int(x2)) Or _
((x1 = 0) And (x2 = 0))) Then
Function_Error = 1: Evaluate = 0: Exit Function
Else: value = x1 ^ x2
End If
Case "@": 'logarithm
If (x1 > 0) And (x2 > 0) And (x2 <> 1) Then
value = Log(x1) / Log(x2)
Else
If x2 = 1 Then
value = Log(x1)
Else: Function_Error = 2: Evaluate = 0: Exit Function
End If
End If
Case "sin": value = Sin(x2)
Case "cos": value = Cos(x2)
Case "tan":
If Cos(x2) <> 0 Then
value = Tan(x2)
Else: Function_Error = 3: Evaluate = 0: Exit Function
End If
Case "asin":
If (x2 > -1) And (x2 < 1) Then
value = Atn(x2 / Sqr(1 - x2 * x2))
ElseIf x2 = -1 Then
value = -Pi / 2
ElseIf x2 = 1 Then
value = Pi / 2
Else: Function_Error = 5: Evaluate = 0: Exit Function
End If
Case "acos":
If (x2 > 0) And (x2 <= 1) Then
value = Atn(Sqr(1 - x2 * x2) / x2)
ElseIf (x2 < 0) And (x2 >= -1) Then
value = Atn(Sqr(1 - x2 * x2) / x2) + Pi
ElseIf x2 = 0 Then
value = Pi / 2
Else: Function_Error = 6: Evaluate = 0: Exit Function
End If
Case "atan": value = Atn(x2)
Case "sinh": value = (Exp(x2) - Exp(-x2)) * 0.5
Case "cosh": value = (Exp(x2) + Exp(-x2)) * 0.5
Case "tanh": value = (Exp(x2) - Exp(-x2)) / (Exp(x2) + Exp(-x2))
Case "ln":
If x2 > 0 Then
value = Log(x2)
Else: Function_Error = 2: Evaluate = 0: Exit Function
End If
Case "exp": value = Exp(x2)
Case "abs": value = Abs(x2)
Case "sqrt":
If x2 >= 0 Then
value = Sqr(x2)
Else: Function_Error = 4: Evaluate = 0: Exit Function
End If
Case "int": value = Int(x2)
Case "frac": value = x2 - Int(x2)
End Select
If ((LCase$(Mid$(op(top2), 1, 1)) < "a") Or _
(LCase$(Mid$(op(top2), 1, 1)) > argX)) _
And (op(top2) <> "~") Then top1 = top1 - 1
opd(top1) = value
top2 = top2 - 1
Loop
If top2 > 0 Then
If (op(top2) <> "(") Or (Si <> ")") Then
top2 = top2 + 1
op(top2) = IIf((Sk = "(") And (Si = "-"), "~", Si)
Else
top2 = top2 - 1
End If
End If
End Select
End If
Loop
Evaluate = opd(1)
Exit Function
Overflow:
Function_Error = 18 'overflow
MsgBox "overflow"
End Function
Public Function Derive (ByVal S As String, ByVal x As Double, _
ByRef Function_Error As Integer) As Double
' ================================================================
' f(x-2h)-8f(x-h)+8f(x+h)-f(x+2h)
' f'(x) = ------------------------------- (derivative formula)
' 12 h
' =================================================================
Dim v1 As Double, v2 As Double, v3 As Double, v4 As Double
Dim FErr As Integer
Const h as Double = 0.000456
Derive = 0
Function_Error = 1
v1 = Evaluate(S, x - 2 * h, FErr)
If FErr <> 0 Then Exit Function
v2 = Evaluate(S, x - h, FErr)
If FErr <> 0 Then Exit Function
v3 = Evaluate(S, x + h, FErr)
If FErr <> 0 Then Exit Function
v4 = Evaluate(S, x + 2 * h, FErr)
If FErr <> 0 Then Exit Function
Function_Error = 0
Derive = (v1 - 8 * v2 + 8 * v3 - v4) / (12 * h)
End Function
Function Find_root_Newton(ByVal S As String, ByVal x0 As Double, _
ByVal eps As Double, FErr As Integer) As Double
' solve equations using Newton method
On Error Resume Next
Dim x1 As Double, v1 As Double, v2 As Double
Dim FErr1 As Integer, FErr2 As Integer
Dim steps As Integer
FErr = 0
x1 = x0
steps = 0
Do
x0 = x1
v1 = Evaluate(S, x0, FErr1)
v2 = Derive(S, x0, FErr2)
If (FErr1 * FErr2 > 0) Or (v2 = 0) Then
Find_root_Newton = 0
FErr = 1
Exit Function
Else
x1 = x0 - v1 / v2
End If
steps = steps + 1
Loop Until (Abs(x1 - x0) < eps) Or (steps = 100)
If Evaluate(S, x1, FErr1) < eps Then
Find_root_Newton = x1
Else
Find_root_Newton = 0
FErr = 2
End If
End Function
Function Find_root_bisection(ByVal S As String, ByVal a As Double, _
ByVal b As Double, ByVal eps As Double, _
ByRef Err As Integer) As Double
' solve equations using bisection method
On Error Resume Next
Dim ya As Double, yc As Double, c As Double
Dim steps As Integer, FErr As Integer
Err = 0
Do
c = (a + b) / 2
ya = Evaluate(S, a, FErr)
yc = Evaluate(S, c, FErr)
If ya = 0 Then
Find_root_bisection = a
Exit Function
ElseIf yc = 0 Then
Find_root_bisection = c
Exit Function
End If
If ya * yc < 0 Then
b = c
Else
a = c
End If
Loop Until (Abs(b - a) < eps)
Find_root_bisection = c
End Function
评论