by RedSting71 (9 Submissions)
Category: Math/Dates
Compatability: VB 6.0
Difficulty: Unknown Difficulty
Originally Published: Fri 19th July 2002
Date Added: Mon 8th February 2021
Rating: 
(1 Votes)
Finds the solution to any polynomial equation using Newton's Method... very effective and easy
API Declarations
'The function to call is Solve(), will return answer
'The polynomial is an equation set equal to 0
'Guess is an initial guess, doesn't have to be close to the actual answer, but should be decent; as a rule of thumb, just go with "1"
'Solve("x^2-2", "x", "1") - will solve the equation x^2 - 2 = 0 for x, using 1 as the value of x(1)
'If you're not familiar with Newton's Method, buy a book on numerical analysis
VBcoders
'Define variables
Dim X As String
Dim der As String
Dim der2 As String
Dim equation as string
Dim equation2 As String
Dim bottom As String
Dim top As String
i = 0
X = guess
'Get the equation
Equation = polynomial
'Get the derivative
der = GetDerivative(polynomial, variable)
'Begin iteration process
Do: DoEvents
'Get equation, substitute X, solve
equation2 = ReplaceExpressionVariable(equation, variable, X)
top = EvaluateExpression(equation2)
'Substitute X in derivative and solve
der2 = ReplaceExpressionVariable(der, variable, X)
bottom = EvaluateExpression(der2)
'Get new approximation of X
X = X - top / bottom
'Add one to iteration count
i = i + 1
'You can change this value, but 10 iterations is sufficient most of the time
Loop Until i = 10
Solve = X
End Function
Function ReplaceExpressionVariable(szExpression As String, szVar As String, szVarVal As String) As String
Dim szTemp As String
Dim szExpressionParts() As String
Dim loop1 As Long
'put parens arounf negative var vals
If Val(szVarVal) < 0 Then
szVarVal = "(" & szVarVal & ")"
End If
'strip the spaces
szTemp = Replace(szExpression, " ", "")
'split the expression
szExpressionParts = Split(szTemp, szVar)
'loop throught the expression parts to find variable without co-efficients
For loop1 = LBound(szExpressionParts, 1) To UBound(szExpressionParts, 1) - 1
If Len(szExpressionParts(loop1)) > 0 Then
If Not (IsNumeric(Right(szExpressionParts(loop1), 1))) Then
szExpressionParts(loop1) = szExpressionParts(loop1) & "1"
End If
Else
szExpressionParts(loop1) = 1
End If
Next loop1
'put the parts back together in a string
szTemp = Join(szExpressionParts, "*" & szVarVal)
'put spaces between the opperators
szTemp = Replace(szTemp, "+", " + ")
szTemp = Replace(szTemp, "-", " - ")
szTemp = Replace(szTemp, "*", " * ")
szTemp = Replace(szTemp, "/", " / ")
szTemp = Replace(szTemp, "^", " ^ ")
'return the value
ReplaceExpressionVariable = szTemp
End Function
Function EvaluateExpression(szExpression As String) As String
Dim iLeftParenLoc As Integer
Dim iRightParenLoc As Integer
Dim iLeftParenCount As Integer
Dim iRightParenCount As Integer
Dim szTempExpression As String
Dim szNewExpression As String
Dim szParenExpression As String
Dim iExpressionLen As Integer
Dim szChar As String
Dim iOpperatorLoc As Integer
Dim iOpperatorLoc2 As Integer
Dim szLeftExpression As String
Dim szRightExpression As String
Dim iLeftBound As Integer
Dim iRightBound As Integer
Dim szOpperator As String
Dim loop1 As Integer
Dim loop2 As Integer
szTempExpression = Trim(szExpression)
iLeftParenLoc = InStr(szTempExpression, "(")
iExpressionLen = Len(szTempExpression)
Do While iLeftParenLoc > 0
For loop1 = iLeftParenLoc To iExpressionLen
szChar = Mid(szTempExpression, loop1, 1)
If szChar = "(" Then
iLeftParenCount = iLeftParenCount + 1
ElseIf szChar = ")" Then
iRightParenCount = iRightParenCount + 1
Else
szParenExpression = szParenExpression & szChar
End If
If iLeftParenCount = iRightParenCount Then
iRightParenLoc = loop1
Exit For
End If
Next
szParenExpression = Mid(szTempExpression, iLeftParenLoc + 1, iRightParenLoc - iLeftParenLoc - 1)
szTempExpression = left(szTempExpression, iLeftParenLoc - 1) & CStr(EvaluateExpression(szParenExpression)) & Right(szTempExpression, iExpressionLen - iRightParenLoc)
iLeftParenCount = 0
iRightParenCount = 0
iExpressionLen = Len(szTempExpression)
iLeftParenLoc = InStr(szTempExpression, "(")
Loop
For loop1 = 0 To 2
If loop1 = 0 Then
szOpperator = "^"
iOpperatorLoc = InStr(szTempExpression, " ^ ")
ElseIf loop1 = 1 Then
szOpperator = "*"
iOpperatorLoc = InStr(szTempExpression, " * ")
iOpperatorLoc2 = InStr(szTempExpression, " / ")
If (iOpperatorLoc2 < iOpperatorLoc And iOpperatorLoc2 <> 0) Or (iOpperatorLoc = 0 And iOpperatorLoc2 <> 0) Then
iOpperatorLoc = iOpperatorLoc2
szOpperator = "/"
End If
ElseIf loop1 = 2 Then
szOpperator = "+"
iOpperatorLoc = CInt(InStr(szTempExpression, " + "))
iOpperatorLoc2 = CInt(InStr(szTempExpression, " - "))
If (iOpperatorLoc2 < iOpperatorLoc And iOpperatorLoc2 <> 0) Or (iOpperatorLoc = 0 And iOpperatorLoc2 <> 0) Then
iOpperatorLoc = iOpperatorLoc2
szOpperator = "-"
End If
End If
Do While iOpperatorLoc > 0
iOpperatorLoc = iOpperatorLoc
For loop2 = iOpperatorLoc - 1 To 1 Step -1
szChar = Mid(szTempExpression, loop2, 1)
If szChar = " " Then
Exit For
End If
Next
iLeftBound = loop2
For loop2 = iOpperatorLoc + 3 To iExpressionLen
szChar = Mid(szTempExpression, loop2, 1)
If szChar = " " Then
Exit For
End If
Next
iRightBound = loop2
szLeftExpression = Trim(Mid(szTempExpression, iLeftBound + 1, iOpperatorLoc - (iLeftBound + 1)))
szRightExpression = Trim(Mid(szTempExpression, iOpperatorLoc + 3, iRightBound - (iOpperatorLoc + 3)))
Select Case szOpperator
Case "^"
szNewExpression = CStr(Val(szLeftExpression) ^ Val(szRightExpression))
Case "*"
szNewExpression = CStr(Val(szLeftExpression) * Val(szRightExpression))
Case "/"
szNewExpression = CStr(Val(szLeftExpression) / Val(szRightExpression))
Case "+"
szNewExpression = CStr(Val(szLeftExpression) + Val(szRightExpression))
Case "-"
szNewExpression = CStr(Val(szLeftExpression) - Val(szRightExpression))
End Select
szTempExpression = left(szTempExpression, iLeftBound) & szNewExpression & Right(szTempExpression, iExpressionLen - iRightBound + 1)
iExpressionLen = Len(szTempExpression)
'iOpperatorLoc = InStr(szTempExpression, szOpperators(loop1))
If loop1 = 0 Then
szOpperator = "^"
iOpperatorLoc = InStr(szTempExpression, " ^ ")
ElseIf loop1 = 1 Then
szOpperator = "*"
iOpperatorLoc = InStr(szTempExpression, " * ")
iOpperatorLoc2 = InStr(szTempExpression, " / ")
If (iOpperatorLoc2 < iOpperatorLoc And iOpperatorLoc2 <> 0) Or (iOpperatorLoc = 0 And iOpperatorLoc2 <> 0) Then
iOpperatorLoc = iOpperatorLoc2
szOpperator = "/"
End If
ElseIf loop1 = 2 Then
szOpperator = "+"
iOpperatorLoc = InStr(szTempExpression, " + ")
iOpperatorLoc2 = InStr(szTempExpression, " - ")
If (iOpperatorLoc2 < iOpperatorLoc And iOpperatorLoc2 <> 0) Or (iOpperatorLoc = 0 And iOpperatorLoc2 <> 0) Then
iOpperatorLoc = iOpperatorLoc2
szOpperator = "-"
End If
End If
Loop
Next
EvaluateExpression = Val(szTempExpression)
End Function
Function GetDerivative(strExpression As String, strVariable As String) As String
Dim strSimpleExpressions() As String
Dim strTemp As String
Dim loop1 As Long
'remove spaces
strTemp = Replace(strExpression, " ", "")
'temporarily replace negavtive exponents
strTemp = Replace(strTemp, "^-", "#negex#")
'convert subtracted simple expressions to add negative
strTemp = Replace(strTemp, "-", "+-")
'restore negavtive exponents
strTemp = Replace(strTemp, "#negex#", "^-")
'split the expression into an array of simple expressions
strSimpleExpressions = Split(strTemp, "+")
'loop through the array, replacing each element(simple expression) with its derivative
For loop1 = 0 To UBound(strSimpleExpressions)
strSimpleExpressions(loop1) = GetSimpleDerivative(strSimpleExpressions(loop1), strVariable)
Next
'rebuild the string
strTemp = Join(strSimpleExpressions, "+")
'temporarily replace negavtive exponents
strTemp = Replace(strTemp, "^-", "#negex#")
'convert add negative to subtracted simple expressions
strTemp = Replace(strTemp, "+-", "-")
'insert spaces around subtraction
strTemp = Replace(strTemp, "-", " - ")
'restore negavtive exponents
strTemp = Replace(strTemp, "#negex#", "^-")
'insert spaces around addition
strTemp = Replace(strTemp, "+", " + ")
'return derivative expression
GetDerivative = strTemp
End Function
Function GetSimpleDerivative(strExpression As String, strVariable As String) As String
Dim strParts() As String
Dim strCoEfficient As String
Dim strExponent As String
'if the variable is in the expression
If InStr(1, strExpression, strVariable) > 0 Then
'split the expression by the variable
strParts = Split(Trim(strExpression), strVariable)
'get the coefficient
strCoEfficient = Trim(strParts(0))
'if there is not co-effiocient, assume it is 1
If strCoEfficient = "" Then strCoEfficient = "1"
'make -x = -1x
If strCoEfficient = "-" Then strCoEfficient = "-1"
'strim leading and trainling spaces
strExponent = Trim(strParts(1))
'if the exponent part contains an ^
If InStr(1, strExponent, "^") > 0 Then
'split it out to find the exponent number
strExponent = Trim(Split(strExponent, "^")(1))
If strExponent <> "1" Then
'calculate the new coefficient, append the variable
GetSimpleDerivative = CStr(Val(strCoEfficient) * Val(strExponent)) & strVariable
'decriment the exponent
strExponent = Val(strExponent - 1)
' if the new exponent is not 1, append it
If strExponent <> "1" Then
GetSimpleDerivative = GetSimpleDerivative & "^" & strExponent
End If
Else 'otherwise (exponent is 1)
'return just the coefficient
GetSimpleDerivative = strCoEfficient
End If
Else 'otherwise (no exponent)
'return just the coefficient
GetSimpleDerivative = strCoEfficient
End If
Else 'othewise (no variable, just a constant)
'return 0
GetSimpleDerivative = "0"
End If
End Function
No comments have been posted about Finds the solution to any polynomial equation using Newton's Method... very effective and easy. Why not be the first to post a comment about Finds the solution to any polynomial equation using Newton's Method... very effective and easy.
