'------------------------------------------------------------------------------
' Evaluar funciones (04/Oct/07)
' Evaluar expresiones numéricas simples a partir de una cadena
' que pueden incluir funciones
'
'
' ©Guillermo 'guille' Som, 2007
'
' El espacio de nombre de esta librería es:
' elGuille.Developer
'------------------------------------------------------------------------------
Option Strict On
Option Compare Text
Imports Microsoft.VisualBasic
Imports System
Imports System.Collections.Generic
Imports System.Text
Imports System.Threading
Imports System.Globalization
Public Class EvaluarFunciones
Inherits EvaluarExpresiones
' Se debe poder evaluar algunas funciones predefinidas:
' La declaro Shared y Protected v.19 (12/Oct/07)
' para clasificarla en el constructor compartido
' Añado nuevas instrucciones (Exp, Sgn, Sign) v.30 (12/Oct/07)
Protected Shared funciones() As String = { _
"Max(", "Min(", "Round(", "Log(", "Log10(", _
"Sqr(", "Sqrt(", "Mod(", "Pow(", _
"Sum(", "Subst(", "Mult(", "Div(", "DivInt(", _
"Percent(", "Porcentaje(", _
"Suma(", "Resta(", "Multiplica(", "Divide(", _
"Fix(", "Int(", "Floor(", "Ceiling(", "Rnd(", _
"Abs(", "Pi(", "E(", _
"Atn(", "Atan(", "Cos(", "Sin(", "Tan(", _
"Sec(", "Cotan(", "Cosec(", _
"Fact(", "Factorial(", _
"BinToDec(", "OctToDec(", "DecToOct(", _
"Exp(", "Sign(", "Sgn("}
' Las funciones que no reciben parámetros v.30 (12/Oct/07)
Protected Shared funciones0() As String = {"pi", "rnd", "e"}
''' <summary>
''' Evalua las funciones que haya en la expresion
''' Esta función debe llamarse antes de evaluar las expresiones
''' ya que devolverá el valor
''' </summary>
''' <param name="expresion"></param>
''' <returns></returns>
''' <remarks></remarks>
Protected Overridable Function evaluaFunc(ByVal expresion As String) As String
' Para tener en cuenta los reemplazos realizados v.29 (12/Oct/07)
Dim expAnt As String = expresion.ToLower
Dim difLen As Integer = 0
Dim funcs As Dictionary(Of Integer, String) = funcIndices(expAnt)
If funcs.Count = 0 Then
Return expresion
End If
' ¡Mardito' roedore'! v.25 (12/Oct/07)
' con las puñeteras mayúsculas y minúsculas!!!
expresion = expAnt ' expresion.ToLower
' Evaluar cada una de las funciones que haya
' Una copia para realizar los cambios
Dim exp As New StringBuilder(expresion)
' Hay que tener en cuenta que una funcion puede recibir
' por parámetro a otra función
' y habrá que evaluar las expresiones que se usen como parámetros
' por ejemplo: Round(10 + Sqrt(12345) + 0.5)
For Each i As Integer In funcs.Keys
' Para tener en cuenta los reemplazos v.29 (12/Oct/07)
difLen = Len(expAnt) - Len(expresion)
Dim k As Integer = i
If difLen > 0 Then
k = i - difLen
If k <= 0 Then k = 1
End If
Dim args As String = extraerArgumentos(expresion, funcs(i), k, "[", "]")
Dim dblArgs() As Double
' Si tiene corchete, agruparlos v.35 (12/Oct/07)
If args.Contains("[") Then
Dim agp As AgruparPares = AgruparPares.CrearInstancia(args, "[", "]")
args = agp.TextoSustituido
' Evaluar los argumentos
' Comprobar si hay varios argumentos separados por comas
Dim argumentos() As String = args.Split(New Char() {","c}, _
StringSplitOptions.RemoveEmptyEntries)
ReDim dblArgs(0 To argumentos.Length - 1)
For j As Integer = 0 To argumentos.Length - 1
If argumentos(j).IndexOf(agp.MarcadorInicio) > -1 Then
Dim j1 As Integer
Do
j1 = argumentos(j).IndexOf(agp.MarcadorInicio)
If j1 > -1 Then
Dim marca As String = _
argumentos(j).Substring(j1 + agp.MarcadorInicio.Length, _
agp.LenFormato)
Dim index As Integer = CInt(marca)
argumentos(j) = _
argumentos(j).Replace( _
argumentos(j).Substring(j1, agp.LenMarcador), _
agp.Sustituciones(index))
End If
Loop While j1 > -1
dblArgs(j) = CDbl(Me.evaluaExp(argumentos(j)))
Else
dblArgs(j) = CDbl(Me.evaluaExp(argumentos(j)))
End If
Next
Else
' Evaluar los argumentos
' Comprobar si hay varios argumentos separados por comas
Dim argumentos() As String = args.Split(New Char() {","c}, _
StringSplitOptions.RemoveEmptyEntries)
ReDim dblArgs(0 To argumentos.Length - 1)
For j As Integer = 0 To argumentos.Length - 1
dblArgs(j) = CDbl(Me.evaluaExp(argumentos(j)))
Next
End If
Dim res As String
res = Evalua(funcs(i), dblArgs).ToString
If funcs(i).Contains("[") Then
exp.Replace((funcs(i) & args).ToLower & "]", res.ToLower)
' Cambiar también en expresion v.23 (12/Oct/07)
expresion = expresion.Replace((funcs(i) & args).ToLower & "]", res.ToLower)
'
' Estos dos casos, seguramente no se darán
ElseIf funcs(i).Contains("(") Then
exp.Replace((funcs(i) & args).ToLower & ")", res.ToLower)
' Cambiar también en expresion v.23 (12/Oct/07)
expresion = expresion.Replace((funcs(i) & args).ToLower & ")", res.ToLower)
Else
exp.Replace((funcs(i) & args).ToLower, res.ToLower)
' Cambiar también en expresion v.23 (12/Oct/07)
expresion = expresion.Replace((funcs(i) & args).ToLower, res.ToLower)
End If
Next
Return exp.ToString
End Function
''' <summary>
''' Busca todas las funciones que aparecen en el texto
''' y devuelve un diccionario con las posiciones y el nombre
''' </summary>
''' <param name="texto"></param>
''' <returns></returns>
''' <remarks>
''' 02/Oct/07
''' </remarks>
Protected Overridable Function funcIndices(ByVal texto As String) As Dictionary(Of Integer, String)
Dim lista As New Dictionary(Of Integer, String)
Dim sinParentesis As Boolean
For Each f As String In funciones
Dim p As Integer = 1
Dim f1 As String = f.Replace("(", "[")
Do
sinParentesis = False
Dim i As Integer = InStr(p, texto, f)
If i = 0 Then
i = InStr(p, texto, f1)
If i > 0 Then
' No lleva paréntesis
sinParentesis = True
'texto = texto.Replace(f1, f) & "]" '")"
End If
End If
If i = 0 Then Exit Do
' Comprobar que sea una palabra completa v.24 (12/Oct/07)
' ya que hallaba Porcentaje, pero usaba E
' Se comprueban más cosas... v.30 (12/Oct/07)
If separadorDelanteDetras(texto, i, f1) Then
Exit Do
End If
p = i + 1
lista.Add(i, f1)
Loop
Next
Return lista
End Function
''' <summary>
''' Devuelve True si no es la función indicada
''' Si tiene una letra delante o detrás devuelve True
''' Si tiene un separador delante o detrás, devuelve False
''' </summary>
''' <param name="texto">
''' Texto a analizar
''' </param>
''' <param name="i">
''' Posición desde la que se debe analizar
''' (donde está la función encontrada)
''' </param>
''' <param name="f1">
''' Nombre de la función
''' </param>
''' <returns></returns>
''' <remarks></remarks>
Protected Function separadorDelanteDetras(ByVal texto As String, _
ByVal i As Integer, _
ByVal f1 As String) As Boolean
' Si es la primera posición y tiene el corchete, v.32 (12/Oct/07)
' es que es completa
If texto = f1 OrElse (i = 1 AndAlso f1.EndsWith("[")) Then
Return False
End If
If i > 1 Then
' Si es una letra, es que no es esta función
If letras.IndexOf(Mid(texto, i - 1, 1)) > -1 Then
Return True
End If
End If
If i + Len(f1) <= Len(texto) Then
' Aunque puede ser que empiece igual, pero no sea
' por ejemplo cos y cosec
' Darlo por bueno si tiene separador delante o detrás
If letras.IndexOf(Mid(texto, i + Len(f1), 1)) > -1 Then
Return True
End If
End If
' comprobar si hay separador, blancos, etc.
' si no hay, devolver False
If i > 1 Then
' Usar letras ya que cualquier otra cosa, vale
' If separadores.IndexOf(Mid(texto, i - 1, 1)) > -1 Then
If letras.IndexOf(Mid(texto, i - 1, 1)) = -1 Then
Return False
End If
End If
If i + Len(f1) <= Len(texto) Then
If letras.IndexOf(Mid(texto, i + Len(f1), 1)) = -1 Then
Return False
End If
End If
' Aquí casi seguro que no llega, pero...
Return False
End Function
''' <summary>
''' Convierte las funciones del formato función(parámetros)
''' al formato función[parámetros]
''' Cambia los paréntesis por corchetes
''' </summary>
''' <param name="texto"></param>
''' <returns></returns>
''' <remarks></remarks>
Protected Overridable Function funcConvertir(ByVal texto As String) As String
Dim sb As New StringBuilder(texto.ToLower)
For Each f As String In funciones
Dim p As Integer = 1
Dim f2 As String = ""
Dim sinParentesis As Boolean = False
Do
Dim i As Integer = InStr(p, sb.ToString, f)
If i = 0 Then
' Quitarle el paréntesis a ver si...
f2 = f.TrimEnd("(".ToCharArray)
' Solo si es una de las funciones
' que no reciben parámetros
If Array.IndexOf(funciones0, f2) > -1 Then
i = InStr(p, sb.ToString, f2)
If i > 0 Then
sinParentesis = True
End If
End If
End If
If i = 0 Then Exit Do
p = i + 1
If sinParentesis Then
If separadorDelanteDetras(sb.ToString(), i, f2) Then
Exit Do
End If
'If i > 1 Then
' ' Si es una letra, es que no es esta función
' If letras.IndexOf(Mid(sb.ToString(), i - 1, 1)) > -1 Then
' Exit Do
' End If
'End If
sb.Replace(f2, f2 & "[]")
Continue Do
End If
' Buscar los parámetros
Dim args As String = extraerArgumentos(sb.ToString, f, i, "(", ")")
Dim f1 As String = f.Replace("(", "[")
Dim fCaseOrig As String = Mid(sb.ToString, i, Len(f))
If Len(args) = 0 Then
sb.Replace(fCaseOrig & ")", f1 & "]")
Else
sb.Replace(fCaseOrig & args & ")", f1 & args & "]")
End If
Loop
Next
Return sb.ToString
End Function
''' <summary>
''' Evalúa una expresión y devuelve el resultado
''' Las expresiones indicadas solo deben ser cifras y operaciones aritméticas
''' </summary>
''' <param name="expresion"></param>
''' <returns></returns>
''' <remarks>
''' </remarks>
Protected Overrides Function evaluaExp(ByVal expresion As String) As String
expresion = Trim(expresion)
If expresion.StartsWith("(") AndAlso expresion.EndsWith(")") Then
expresion = expresion.Substring(1, expresion.Length - 2)
ElseIf expresion.StartsWith("(") Then
expresion = expresion.Substring(1)
End If
Do While (expresion.IndexOfAny(cifras.ToCharArray) = 0 _
OrElse expresion.IndexOfAny(cifras.ToCharArray) = expresion.Length)
If expresion.StartsWith("(") AndAlso expresion.EndsWith(")") Then
expresion = expresion.Substring(1, expresion.Length - 2)
ElseIf expresion.StartsWith("(") Then
expresion = expresion.Substring(1)
ElseIf expresion.EndsWith(")") Then
expresion = Left(expresion, Len(expresion) - 1)
Else
Exit Do
End If
Loop
Dim exp As String = evaluaFunc(expresion)
' Puede llegar aquí y ser una función v.37 (12/Oct/07)
If exp.Contains("[") AndAlso exp.Contains("]") Then
exp = evaluaFunc(exp)
End If
Return MyBase.evaluaExp(exp)
End Function
''' <summary>
''' Estrae los argumentos de la función indicada
''' El formato debe ser función( argumentos )
''' Los argumentos deben estar entre paréntesis
''' </summary>
''' <param name="funcion"></param>
''' <param name="expresion"></param>
''' <param name="pIni">
''' Posición a partir de la que se debe bsucar la función
''' Ese valor es OBLIGATORIO y debe coincidir con la función evaluada
''' </param>
''' <returns></returns>
''' <remarks></remarks>
Protected Overridable Function extraerArgumentos(ByVal expresion As String, _
ByVal funcion As String, _
ByVal pIni As Integer, _
ByVal paramIni As String, _
ByVal paramFin As String) As String
Dim p, pFin As Integer
Dim pila As Integer
' Si no tiene los marcadores, salir v.34 (12/Oct/07)
If expresion.IndexOfAny((paramIni & paramFin).ToCharArray) = -1 Then
Return "" 'expresion
End If
' Si es una función sin parámetros v.36 (12/Oct/07)
If Array.IndexOf(funciones0, funcion) > -1 Then
Return ""
End If
' Ajustar la posición correctamente v.36 (12/Oct/07)
Dim j As Integer = InStr(expresion, funcion)
If j = 0 Then
Return ""
End If
If j > pIni Then
pIni = j
End If
Dim lenExpr As Integer = Len(expresion)
p = pIni
pila = 0
Do
p = p + 1
If p > lenExpr Then ' Len(expresion) Then ' usar la variable
Exit Do
End If
pFin = p
Dim c As String = Mid(expresion, p, 1)
Select Case c
Case paramIni
pila = pila + 1
Case paramFin
pila = pila - 1
If pila = 0 Then
Exit Do
End If
End Select
Loop
' Los argumentos estarán entre pIni y pFin
' (esto no incluye los paréntesis)
' pIni es la posición de inicio de la función
pIni = pIni + Len(funcion)
Return Mid(expresion, pIni, pFin - pIni)
End Function
'
'--------------------------------------------------------------------------
'
'--------------------------------------------------------------------------
'
''' <summary>
''' Método compartido principal para evaluar expresiones con funciones
''' </summary>
''' <param name="expresion"></param>
''' <param name="mostrarInfo"></param>
''' <returns></returns>
''' <remarks></remarks>
Public Overloads Shared Function Evaluar(ByVal expresion As String, _
ByVal mostrarInfo As Boolean _
) As String
Dim ef As New EvaluarFunciones
Dim res As String = ef.Evalua(expresion, mostrarInfo)
Return res 'ef.Evalua(expresion, mostrarInfo)
End Function
Public Overloads Shared Function Evaluar(ByVal expresion As String) As String
Return Evaluar(expresion, False)
End Function
''' <summary>
''' Devuelve una cadena con las funciones soportadas
''' separadas por comas
''' </summary>
''' <returns></returns>
''' <remarks>
''' v1.0.0.9
''' 11/Oct/07
''' </remarks>
Public Shared Function FuncionesSoportadas() As String
'Dim evf As New EvaluarFunciones
Dim sb As New StringBuilder
' Se clasifica en el constructor compartido v.19 (12/Oct/07)
'Dim f(0 To evf.funciones.Length - 1) As String
'Array.Copy(evf.funciones, f, f.Length)
'Array.Sort(f)
Dim n As Integer = 0
For Each letra As String In letras '.ToUpper
n = 0
For Each s As String In funciones
If s.StartsWith(letra) Then
sb.AppendFormat("{0}, ", s)
n = n + 1
Else
If s > letra Then Exit For
End If
Next
If n > 0 Then
sb.AppendLine()
End If
Next
Return sb.ToString().TrimEnd((" ," & vbCrLf).ToCharArray)
End Function
''' <summary>
''' Método de instancia principal para evaluar expresiones con funciones
''' </summary>
''' <param name="expresion"></param>
''' <param name="mostrarInfo"></param>
''' <returns></returns>
''' <remarks>
''' 09/Oct/07
''' </remarks>
Public Overrides Function Evalua(ByVal expresion As String, _
Optional ByVal mostrarInfo As Boolean = False _
) As String
' Comprobar si tiene funciones y cambiar los paréntesis por corchetes
' con idea de que no se procesen al agrupar los paréntesis
expresion = funcConvertir(expresion)
Dim exp As String = MyBase.Evalua(expresion, mostrarInfo)
'----------------------------------------------------------------------
' En realidad ya se cambia en la clase base, pero...
' De todas formas, como se ha cambiado el valor en el constructor
' esto NUNCA se cumplirá...
' Ya no se debe cambiar nada v.20 (12/Oct/07)
' se usa la cultura Invariant
' Aquí si se debe cambiar, v.27 (12/Oct/07)
' ya que esto es para devolverlo adecuado a la configuración regional
If sepDec = "," Then
exp = exp.Replace(".", ",")
End If
'----------------------------------------------------------------------
Return exp
End Function
''' <summary>
''' Evalúa una operación usando el mismo operador
''' </summary>
''' <param name="operador">
''' Ver la sobrecarga que recibe dos parámetros para los operadores aceptados
''' </param>
''' <param name="numeros">
''' Array de tipo Double con los valores a evaluar
''' </param>
''' <returns></returns>
''' <remarks></remarks>
Public Overrides Function Evalua(ByVal operador As String, _
ByVal ParamArray numeros() As Double) As Double
If operador.EndsWith("[") OrElse operador.EndsWith("(") Then
operador = Left(operador, Len(operador) - 1)
End If
Select Case operador.ToLower
Case "+", "sum", "suma"
Return Suma(numeros)
Case "-", "_", "subst", "resta"
Return Resta(numeros)
Case "*", "mult", "multiplica", "x"
Return Multiplica(numeros)
Case "/", "div", "divide" ', ":", "÷"
Return Divide(numeros)
Case "\", "divint"
Return DivideEnteros(numeros)
Case "^", "pow"
Return Math.Pow(numeros(0), numeros(1))
Case "sqrt", "sqr"
Return Math.Sqrt(numeros(0))
Case "log10"
Return Math.Log10(numeros(0))
Case "log"
If numeros.Length > 1 Then
Return Math.Log(numeros(0), numeros(1))
Else
Return Math.Log(numeros(0))
End If
Case "max"
Return Max(numeros)
Case "min"
Return Min(numeros)
Case "mod", "\u412?", "\u623?", "m"
Return numeros(0) Mod numeros(1)
Case "%", "percent", "porcentaje"
Return Porcentaje(numeros(0), numeros(1))
Case "round"
If numeros.Length > 1 Then
'Dim d As Double
'd = Math.Round(numeros(0), CInt(numeros(1)))
Return Math.Round(numeros(0), CInt(numeros(1)))
Else
Return Math.Round(numeros(0))
End If
Case "abs"
Return Math.Abs(numeros(0))
Case "atn", "atan"
Return Math.Atan(numeros(0))
Case "cos"
Return Math.Cos(numeros(0))
Case "sec"
Return 1 / Math.Cos(numeros(0))
Case "sin"
Return Math.Sin(numeros(0))
Case "cosec"
Return 1 / Math.Sin(numeros(0))
Case "tan"
Return Math.Tan(numeros(0))
Case "cotan"
Return 1 / Math.Tan(numeros(0))
Case "pi"
Return Math.PI
Case "e"
Return Math.E
' Nuevas instrucciones exp, sgn, sign v.30 (12/Oct/07)
Case "exp"
Return Math.Exp(numeros(0))
Case "sign", "sgn"
Return Math.Sign(numeros(0))
Case "floor"
Return Math.Floor(numeros(0))
Case "int"
Return Int(numeros(0))
Case "fix"
Return Fix(numeros(0))
Case "ceiling"
Return Math.Ceiling(numeros(0))
Case "fact", "factorial"
Return Factorial(numeros(0))
Case "rnd"
If numeros.Length > 1 Then
Return m_Rnd.Next(CInt(numeros(0)), CInt(numeros(1) + 1))
ElseIf numeros.Length = 1 Then
Return m_Rnd.NextDouble * numeros(0)
Else
Return m_Rnd.NextDouble
End If
' Funciones de conversión de tipos v.16 (12/Oct/07)
' No se puede usar Hex ni devolver Bin porque el valor devuelto
' es Double...
Case "bintodec"
Return BinToDec(numeros(0).ToString)
Case "octtodec"
'Return CDbl("&O" & numeros(0).ToString)
Return CDbl(OctToDec(numeros(0)))
Case "dectooct"
Return CDbl(DecToOct(numeros(0)))
End Select
End Function
'
'--------------------------------------------------------------------------
' Métodos de instancia protegidos (podían hacerse públicos, pero...)
'--------------------------------------------------------------------------
'
''' <summary>
''' Devuelve el mayor de la lista indicada
''' </summary>
''' <param name="parametros"></param>
''' <returns></returns>
''' <remarks></remarks>
Protected Function Max(ByVal ParamArray parametros() As Double) As Double
Array.Sort(parametros)
Return parametros(parametros.Length - 1)
End Function
''' <summary>
''' Devuelve el menor de la lista indicada
''' </summary>
''' <param name="parametros"></param>
''' <returns></returns>
''' <remarks></remarks>
Protected Function Min(ByVal ParamArray parametros() As Double) As Double
Array.Sort(parametros)
Return parametros(0)
End Function
''' <summary>
''' Calcula el factorial del número indicado
''' </summary>
''' <param name="num">
''' El valor del que se quiere calcular el factorial
''' Los valores mayores de 170 devuelven Infinito
''' (lo he comprobado)
''' </param>
''' <returns></returns>
''' <remarks></remarks>
Protected Function Factorial(ByVal num As Double) As Double
' Comprobaciones extras para el factorial v.38 (12/Oct/07)
' ya que no puede ser menor de 0
' y tampoco debería tener decimales
'If num > 170 Then
' Return Double.PositiveInfinity
'End If
Select Case num
Case Is < 2 '0, 1
Return 1
Case Is > 170
Return Double.PositiveInfinity
Case Else
num = CLng(num)
Return num * Factorial(num - 1)
End Select
End Function
' Usar InvariantCulture para evitar el follón de los decimales (12/Oct/07)
Shared Sub New()
Thread.CurrentThread.CurrentCulture = CultureInfo.InvariantCulture
' Clasificar el array de las funciones v.19 (12/Oct/07)
Array.Sort(funciones)
' Poner en minúsculas v.28 (12/Oct/07)
For i As Integer = 0 To funciones.Length - 1
funciones(i) = funciones(i).ToLower
Next
End Sub
End Class