Интерпретация введённой функции

[Гость]

Такое дело:
Пользователь вводит функцию. В ней действия: корень, скобки и всякие + - / *. Возникла проблема по её интерпретации. С этими скобками замучался, когда они вложенные и всё такое. Да и вообще трудно что-то очень.
Может есть у кого опыт в этом деле или контрол кто подскажет. Спасибо заранее, в общем.

[Andrey Fedorov]

Юзай Microsoft Script Control. И пущай твой юзер хоть модули пишет...

[Гость]

А это встроенный контрол?
Азы не подскажите заранее, или там легко всё?

[Jenizix]

58i, у меня есть класс для вычисления выражений в строковой форме... типа пользователь вводит какойнить пример например (2*(3+3))/4 ,жмет ок, а ему ответ!

[Jenizix]

А вот и он:

Код: Выделить всё

Option Explicit
Private Const MyName As String = "ExpressionClass"

'Класс для вычисления выражений в строковой форме
'(c) Гергерт Сергей, 2003

'Магадан, 04.07.2003 01:10
'Всё, иду спать...

Private Const Plus As String = "+"
Private Const Minus As String = "-"

Private Const Mult As String = "*"
Private Const Div As String = "/"
Private Const DivInt As String = "\"

Private Const Power As String = "^"

Private Const LeftPar As String = "("
Private Const RightPar As String = ")"

Public Enum ExprErrors
  exprNoError
  exprErrorParentheses
  exprErrorInvalidExpression
  exprErrorUnknownFunction
End Enum

Public Function Value(ByVal E As String) As Double
  Dim i As Long
  Dim tmpLng As Long, tmpStr As String
 
  E = LCase$(Replace(E, " ", vbNullString))
  E = Replace(E, RightPar + LeftPar, RightPar + Mult + LeftPar)
 
  'Сначал убедимся, что скобки расставлены верно.
  'Идём слева направо. Открывающая скобка - плюс 1,
  'закрывающая - минус 1. Всё время должно быть >=0, а в конце =0
 
  For i = 1 To Len(E)
    tmpStr = Mid$(E, i, 1)
    If tmpStr = LeftPar Then
      tmpLng = tmpLng + 1
    ElseIf tmpStr = RightPar Then
      tmpLng = tmpLng - 1
    End If
    If tmpLng < 0 Then Err.Raise exprErrorParentheses, MyName, "Parentheses do not match"
  Next
  If tmpLng Then Err.Raise exprErrorParentheses, MyName, "Parentheses do not match"
 
  Value = CalcSummand(E)
End Function

Private Function CalcSummand(S As String) As Double
  Dim i As Long, minPrior As Byte, minPriorPos As Long
  Dim NestingLevel As Long, tmpStr As String
 
  'Не пустая ли строка?
  If Len(S) = 0 Then Exit Function 'выходим с нулём
 
  'Проверяем, не являются ли самые внешние скобки лишними
  Do While LISP(S)
  Loop
 
  'Ищем первый оператор с минимальным приоритетом на текущем уровне вложенности
  minPrior = 2
  For i = 1 To Len(S)
    Select Case Mid$(S, i, 1)
    Case LeftPar
      NestingLevel = NestingLevel + 1
    Case RightPar
      NestingLevel = NestingLevel - 1
    Case Plus, Minus
      If NestingLevel = 0 Then
        minPrior = 0
        minPriorPos = i
        Exit For
      End If
    Case Mult, Div, DivInt
      If NestingLevel = 0 Then
        If minPrior = 2 Then
          minPrior = 1
          minPriorPos = i
        Else
          If minPriorPos = 0 Then minPriorPos = i
        End If
      End If
    Case Power
      If NestingLevel = 0 Then
        If minPrior = 2 And minPriorPos = 0 Then minPriorPos = i
      End If
    End Select
  Next
 
  If minPriorPos = 0 Then
    'Сие означает, что операторов на текущем уровне вложенности нет.
    'Это, в свою очередь, означает, что либо операнд есть число,
    'либо он есть функция.
    CalcSummand = IsFunction(S)
    If CalcSummand >= 0 Then
      Exit Function 'операнд был числом, и он вычислен
    Else
      'Операнд был функцией. Других вариантов нет, т.к. ошибка генерится в IsFunction
      'Переменная minPriorPos нам больше не нужна по прямому назначению.
      'Поэтому заюзаем её для других целей. Просто очень капризная рекурсия
      'в VB, стэк экономим-с...
      minPriorPos = InStr(S, LeftPar)
      tmpStr = Left$(S, minPriorPos - 1)
      'Вот почему нельзя вызывать CallByName от модуля?
      'Сколько бы гемора исчезло...
     
      Select Case tmpStr
      Case "abs"
        CalcSummand = Abs(CalcSummand(Mid$(S, minPriorPos + 1, Len(S) - minPriorPos - 1)))
      Case "atn"
        CalcSummand = Atn(CalcSummand(Mid$(S, minPriorPos + 1, Len(S) - minPriorPos - 1)))
      Case "cos"
        CalcSummand = Cos(CalcSummand(Mid$(S, minPriorPos + 1, Len(S) - minPriorPos - 1)))
      Case "exp"
        CalcSummand = Exp(CalcSummand(Mid$(S, minPriorPos + 1, Len(S) - minPriorPos - 1)))
      Case "log"
        CalcSummand = Log(CalcSummand(Mid$(S, minPriorPos + 1, Len(S) - minPriorPos - 1)))
      Case "sgn"
        CalcSummand = Sgn(CalcSummand(Mid$(S, minPriorPos + 1, Len(S) - minPriorPos - 1)))
      Case "sin"
        CalcSummand = Sin(CalcSummand(Mid$(S, minPriorPos + 1, Len(S) - minPriorPos - 1)))
      Case "sqr"
        CalcSummand = Sqr(CalcSummand(Mid$(S, minPriorPos + 1, Len(S) - minPriorPos - 1)))
      Case "tan"
        CalcSummand = Tan(CalcSummand(Mid$(S, minPriorPos + 1, Len(S) - minPriorPos - 1)))
      Case Else
        Err.Raise exprErrorUnknownFunction, MyName, "Unknown function " + UCase$(tmpStr) + " detected"
      End Select
    End If
  Else
    'Нашли искомый оператор. Рекурсия...
    If minPriorPos = 1 Then 'выражение типа -expr
      tmpStr = Left$(S, 1)
      If tmpStr = Plus Or tmpStr = Minus Then
        CalcSummand = IIf(tmpStr = Minus, -1, 1) * CalcSummand(Mid$(S, 2))
      Else
        Err.Raise exprErrorInvalidExpression, MyName, "Expression is invalid"
      End If
    Else                    'обычное a +-*/\^ b
      Select Case Mid$(S, minPriorPos, 1)
      Case Plus
        CalcSummand = CalcSummand(Left$(S, minPriorPos - 1)) + CalcSummand(Right$(S, Len(S) - minPriorPos))
      Case Minus
        CalcSummand = CalcSummand(Left$(S, minPriorPos - 1)) - CalcSummand(Right$(S, Len(S) - minPriorPos))
      Case Mult
        CalcSummand = CalcSummand(Left$(S, minPriorPos - 1)) * CalcSummand(Right$(S, Len(S) - minPriorPos))
      Case Div
        'Ошибку деления на ноль VB сгенерит и без нас...
        CalcSummand = CalcSummand(Left$(S, minPriorPos - 1)) / CalcSummand(Right$(S, Len(S) - minPriorPos))
      Case DivInt
        CalcSummand = CalcSummand(Left$(S, minPriorPos - 1)) \ CalcSummand(Right$(S, Len(S) - minPriorPos))
      Case Power
        CalcSummand = CalcSummand(Left$(S, minPriorPos - 1)) ^ CalcSummand(Right$(S, Len(S) - minPriorPos))
      Case Else
        'В принципе, этого возникать не должно никогда...
        Err.Raise exprErrorInvalidExpression, MyName, "Expression is invalid"
      End Select
    End If
  End If
End Function

Private Function LISP(ByRef S As String) As Boolean
  Dim i As Long, tmp As Long
 
  'LISP = Lots of Idiot Silly Parentheses!
  'Фанаты языка LISP в шоке и готовят помидоры...
 
  'Если уровень скобок по ходу выражения опустится до нуля,
  'и это будет не конец выражения, то начальные и конечные
  'скобки нужны, поскольку принадлежат разным группам.
  'Иначе их можно удалить.
 
  If Left$(S, 1) = LeftPar And Right$(S, 1) = RightPar Then
    For i = 1 To Len(S)
      If Mid$(S, i, 1) = LeftPar Then
        tmp = tmp + 1
      ElseIf Mid$(S, i, 1) = RightPar Then
        tmp = tmp - 1
        If tmp = 0 And i <> Len(S) Then Exit Function
      End If
    Next
  Else
 
    Exit Function
  End If
 
  'Скобки нужно удалить
  S = Mid$(S, 2, Len(S) - 2)
  LISP = True
End Function

Private Function IsFunction(F As String) As Double
  'Функция - несколько подряд идущих букв и выражение в скобках.
  'И больше ничего! Выражение типа "функция + функция" сюда попадать не должно,
  'по логике основной части программы
  Dim i As Long
 
  'правильность скобок гарантируется вызывающим кодом, поэтому достаточно
  'проверить наличие одной, а не обоих
  i = InStr(F, LeftPar)
  If i = 0 Then
    'Явно не функция. Может, число?
    For i = 1 To Len(F)
      If InStr("0123456789.", Mid$(F, i, 1)) = 0 Then Exit For
    Next
    If i = Len(F) + 1 Then IsFunction = Val(F) Else Err.Raise exprErrorInvalidExpression, MyName, "Expression is invalid"
    'логика программы такова, что отрицательное число вычисляется
    'как (-)(expression), поэтому здесь всегда результат положительный,
    'и можно использовать отрицательные числа как флаги
    Exit Function
  End If
 
  'левая (а значит, и правая) скобки есть, и это не начальные ненужные скобки.
  'Слева от левой скобки должнно быть имя функции. Его правильность будет
  'анализировать вызывающий код
  IsFunction = -1 'Флаг, что функция
End Function


[Andrey Fedorov]

А это встроенный контрол?

Да. Родной.

Азы не подскажите заранее, или там легко всё?

Все достаточно легко.
Help приложен.

[GSerg]

Jenizix
Во-первых, это писал я, а во-вторых, там есть баги
Настоятельно не советую этим кодом пользоваться.

[Faust]

Гы. Я, помнится, когда в такую ситуацию попал, глюпый был, несмышлёный, о мощных контролах не знал... Как результат - юзал обратную польскую нотацию. Рекомендую!

[skord]

Jenizix
Во-первых, это писал я, а во-вторых, там есть баги
Настоятельно не советую этим кодом пользоваться.

Помню... Были баги