this is just one more recursive descent parser.
In contrast to the code in the following post, this one evaluates mathematical expressions.
For more details see comments in the code.
//edit 2015-04-23:
Yesterday I had forgotten to translate some error messages into English. Now fixed.
//edit 2015-04-26:
- added functions Ceil(), Trunc(), and Floor()
- some cosmetic changes
Code: Select all
; -- Recursive descent parser for evaluating mathematical expressions.
; works in ASCII mode and in Unicode mode
; <http://www.purebasic.fr/english/viewtopic.php?f=12&t=62125>
; o First version: 2008-07-30
; o Current version: 2015-04-26 (tested with PB 5.31)
; by Little John
; -- Notes
; o The syntax is checked rather strictly.
; o All built-in PB constants as well as self-defined constants
; can be evaluated (examples are given).
; For doing so, add the appropriate code to the procedure Const().
; o All built-in PB functions as well as self-written functions
; can be evaluated (examples are given).
; For doing so, add the appropriate code to the procedure Func().
; o The power operator "^" is handled correctly (right associative).
; o 0^0 yields 1 here, as with PB and many other programming languages.
; In mathematics, it has been discussed for a long time about the
; value of 0^0, see e.g.:
; <http://mathworld.wolfram.com/Zero.html>
; <http://mathforum.org/dr.math/faq/faq.0.to.0.power.html>
; <http://en.wikipedia.org/wiki/Exponentiation#Zero_to_the_power_of_zero>
DeclareModule Eval
;-- Error messages
#Err_BadSyntax = "Syntax error"
#Err_MissingOperator = "Missing operator"
#Err_NoClosingBracket = "Missing )"
#Err_NoOpeningBracket = "Missing ("
#Err_UnknownOperator = "Unknown operator: "
#Err_InvalidDecNumber = "Invalid decimal number"
#Err_InvalidHexNumber = "Invalid hex number"
#Err_ParameterMismatch = "(): Parameter count mismatch"
#Err_UnknownFunction = "Unknown function: "
#Err_UnknownConstant = "Unknown constant: "
#Err_NegativeBase = "Negative base with non-integer exponent"
#Err_DivisionByZero = "Division by zero"
#Err_Sqr = "Square root of negative number"
#Err_Log = "Logarithm of number <= 0"
#Err_LogBase = "Logarithm to base <= 0 or 1"
;-- Main function
Declare.s Calc(expr.s)
EndDeclareModule
Module Eval
EnableExplicit
;-- Token types
Enumeration
#Unknown
#Operator
#DecNumber
#HexNumber
#Identifier
EndEnumeration
;-- Token definitions
#OpRel = "<=<>="
#OpChars = #OpRel + "+-*/^),"
#Letters = "abcdefghijklmnopqrstuvwxyz_"
#DecDigits = "0123456789"
#HexDigits = #DecDigits + "abcdef"
#AlphaNum = #Letters + #DecDigits
;-- Constants
#E = 2.7182818284590452
Structure Tokens
Str.s
Typ.i
EndStructure
Global Dim TokenArray.Tokens(0)
Global Token.s, Error.s
Global TokenType.i
;-----------------------------------------------------------------------
Procedure NextToken (expr.s="")
; in : expr : expression to be evaluated
; out: Token : current token
; TokenType: type of current token
Static formula.s, fLen.i, posn.i
Protected left.i
If expr <> "" ; only on first call
formula = expr
fLen = Len(formula)
posn = 1
EndIf
While posn <= fLen And Mid(formula, posn, 1) = " "
posn + 1
Wend
Token = Mid(formula, posn, 1)
posn + 1
left = posn
If FindString(#OpChars, Token)
If posn <= fLen And FindString(#OpRel, Token) <> 0 And
FindString(#OpRel, Mid(formula, posn, 1)) <> 0
Token + Mid(formula, posn, 1)
posn + 1
EndIf
TokenType = #Operator
ElseIf FindString(#Letters, Token)
While posn <= fLen And FindString(#AlphaNum, Mid(formula, posn, 1)) <> 0
posn + 1
Wend
Token + Mid(formula, left, posn-left)
TokenType = #Identifier
ElseIf FindString(#DecDigits, Token)
While posn <= fLen And FindString(#DecDigits, Mid(formula, posn, 1)) <> 0
posn + 1
Wend
Token + Mid(formula, left, posn-left)
TokenType = #DecNumber
ElseIf Token = "$"
While posn <= fLen And FindString(#HexDigits, Mid(formula, posn, 1)) <> 0
posn + 1
Wend
Token + Mid(formula, left, posn-left)
TokenType = #HexNumber
Else
TokenType = #Unknown
EndIf
EndProcedure
Procedure Scan (expr.s)
;-- Split the whole expression in advance into separate tokens,
; and store them in TokenArray().
Protected index
Dim TokenArray.Tokens(Len(expr)*2) ; so the array is always big enough
index = 0
NextToken(expr)
While Token <> ""
TokenArray(index)\Str = Token
TokenArray(index)\Typ = TokenType
index + 1
NextToken()
Wend
EndProcedure
Procedure GetToken (idx=-1)
;-- get the next token from TokenArray()
Static index
If idx <> -1 ; only on first call
index = idx
EndIf
Token = TokenArray(index)\Str
TokenType = TokenArray(index)\Typ
index + 1
EndProcedure
;-----------------------------------------------------------------------
Procedure.d Arith (op.s, v.d, r.d)
Protected ret.d = #False
If Error <> ""
ProcedureReturn ret
EndIf
Select op
Case "<"
If v < r
ret = #True
EndIf
Case ">"
If v > r
ret = #True
EndIf
Case "="
If v = r
ret = #True
EndIf
Case "<>"
If v <> r
ret = #True
EndIf
Case "<="
If v <= r
ret = #True
EndIf
Case ">="
If v >= r
ret = #True
EndIf
Case "+"
ret = v + r
Case "-"
ret = v - r
Case "*"
ret = v * r
Case "/"
If r = 0
Error = #Err_DivisionByZero
Else
ret = v / r
EndIf
Case "^"
If v < 0 And r <> Int(r)
Error = #Err_NegativeBase
ElseIf v = 0 And r < 0
Error = #Err_DivisionByZero
Else
ret = Pow(v, r)
EndIf
Default
Error = #Err_UnknownOperator + op
EndSelect
ProcedureReturn ret
EndProcedure
;-- self-written functions (with as many arguments as appropriate)
Macro Ceil (_x_)
; -- round towards positive infinity
; gives the smallest integer greater than or equal to x
Round(_x_, #PB_Round_Up)
EndMacro
Macro Trunc (_x_)
; -- round towards zero
; discards the noninteger part of x
IntQ(_x_)
EndMacro
Macro Floor (_x_)
; -- round towards negative infinity
; gives the greatest integer less than or equal to x
Round(_x_, #PB_Round_Down)
EndMacro
Procedure.d Min (List args.d())
; in : List of real numbers
; out: Smallest number in the list
Protected ret.d
ret = args()
While NextElement(args())
If ret > args()
ret = args()
EndIf
Wend
ProcedureReturn ret
EndProcedure
Procedure.d Max (List args.d())
; in : List of real numbers
; out: Biggest number in the list
Protected ret.d
ret = args()
While NextElement(args())
If ret < args()
ret = args()
EndIf
Wend
ProcedureReturn ret
EndProcedure
Procedure.d Sum (List args.d())
; in : List of real numbers
; out: Sum of all numbers in the list
Protected ret.d
ret = args()
While NextElement(args())
ret + args()
Wend
ProcedureReturn ret
EndProcedure
;-----------------------------------------------------------------------
Procedure.d Const (name.s)
Protected ret.d
Select name
Case "pi"
ret = #PI
Case "e"
ret = #E
Default
Error = #Err_UnknownConstant + name
EndSelect
ProcedureReturn ret
EndProcedure
Procedure.d Func (name.s, List args.d())
; Add here the appropriate code for all functions that shall be evaluated
; (built-in PB functions or self-written functions).
; It is not necessary to check for an empty list of arguments here,
; since that will raise a syntax error anyway.
Protected ret.d
FirstElement(args())
Select name
Case "sqr"
If ListSize(args()) > 1
Error = name + #Err_ParameterMismatch
ElseIf args() < 0
Error = #Err_Sqr
Else
ret = Sqr(args())
EndIf
Case "log"
If ListSize(args()) > 2
Error = name + #Err_ParameterMismatch
ElseIf args() <= 0
Error = #Err_Log
Else
ret = Log(args()) ; Default base is 'e'.
If ListSize(args()) = 2 ; If a different base is given ...
NextElement(args())
If args() <= 0 Or args() = 1
Error = #Err_LogBase
Else
ret / Log(args())
EndIf
EndIf
EndIf
Case "ceil"
If ListSize(args()) > 1
Error = name + #Err_ParameterMismatch
Else
ret = Ceil(args())
EndIf
Case "trunc"
If ListSize(args()) > 1
Error = name + #Err_ParameterMismatch
Else
ret = Trunc(args())
EndIf
Case "floor"
If ListSize(args()) > 1
Error = name + #Err_ParameterMismatch
Else
ret = Floor(args())
EndIf
Case "min"
ret = Min(args())
Case "max"
ret = Max(args())
Case "sum"
ret = Sum(args())
Default
Error = #Err_UnknownFunction + name
EndSelect
ProcedureReturn ret
EndProcedure
;-----------------------------------------------------------------------
;-- recursive procedures
Declare.d Expression()
Procedure.d Factor()
Protected op.s
Protected v.d
If TokenType = #DecNumber
op = Token
GetToken()
If Token <> "."
v = Val(op)
Else
GetToken()
If TokenType = #DecNumber
v = ValD(op + "." + Token)
Else
Error = #Err_InvalidDecNumber
EndIf
GetToken()
EndIf
ElseIf TokenType = #HexNumber
If Len(Token) > 1
v = Val(Token)
Else
Error = #Err_InvalidHexNumber
EndIf
GetToken()
ElseIf TokenType = #Identifier
op = Token
GetToken()
If Token = "("
;-- get list of function arguments
Protected NewList args.d()
Repeat
GetToken()
AddElement(args())
args() = Expression()
Until Token <> ","
If Token <> ")" And Error = ""
Error = #Err_NoClosingBracket
EndIf
v = Func(op, args())
GetToken()
Else
v = Const(op)
EndIf
ElseIf Token = "("
GetToken()
v = Expression()
If Token <> ")" And Error = ""
Error = #Err_NoClosingBracket
EndIf
GetToken()
Else
Error = #Err_BadSyntax
EndIf
If Token <> "" And FindString(#OpChars, Token) = 0 And Error = ""
If TokenType = #DecNumber Or TokenType = #HexNumber Or
TokenType = #Identifier Or Token = "("
Error = #Err_MissingOperator
Else
Error = #Err_UnknownOperator + Token
EndIf
EndIf
ProcedureReturn v
EndProcedure
Procedure.d Power()
Protected v.d, r.d
v = Factor()
If Token = "^"
GetToken()
r = Power()
v = Arith("^", v, r)
EndIf
ProcedureReturn v
EndProcedure
Procedure.d Term()
Protected op.s
Protected v.d, r.d
v = Power()
op = Token
While op = "*" Or op = "/"
GetToken()
r = Power()
v = Arith(op, v, r)
op = Token
Wend
ProcedureReturn v
EndProcedure
Procedure.d Signed()
Protected op.s
Protected v.d
op = ""
If Token = "+" Or Token = "-"
op = Token
GetToken()
EndIf
v = Term()
If op = "-"
v = -v
EndIf
ProcedureReturn v
EndProcedure
Procedure.d SingleExpression()
Protected op.s
Protected v.d, r.d
v = Signed()
op = Token
While op = "+" Or op = "-"
GetToken()
r = Term()
v = Arith(op, v, r)
op = Token
Wend
ProcedureReturn v
EndProcedure
Procedure.d Expression()
Protected op.s
Protected v.d, r.d
v = SingleExpression()
op = Token
While FindString(#OpRel, op) <> 0
GetToken()
r = SingleExpression()
v = Arith(op, v, r)
op = Token
Wend
ProcedureReturn v
EndProcedure
;-----------------------------------------------------------------------
Procedure.s Calc (expr.s)
; * Main function *
; in : expression to be evaluated
; out: result (1st character is '-' or a decimal digit)
; or
; error message (1st character is a letter)
Protected v.d
Scan(LCase(expr))
Error = ""
GetToken(0)
v = Expression()
If Error <> ""
ProcedureReturn Error
ElseIf Token = ")"
ProcedureReturn #Err_NoOpeningBracket
ElseIf Token = ","
ProcedureReturn #Err_BadSyntax
Else ; no error
ProcedureReturn StrD(v) ; return result
EndIf
EndProcedure
EndModule
CompilerIf #PB_Compiler_IsMainFile
; -- Module demo
Debug Eval::Calc("-1 < 7")
Debug Eval::Calc(" 1 > -7")
Debug Eval::Calc(" 4 = 5")
Debug Eval::Calc(" 4 <> 5")
Debug Eval::Calc(" 4 <= 5")
Debug Eval::Calc(" 4 >= 5")
Debug Eval::Calc("(4+2) = 6")
Debug Eval::Calc(" 4+2 = 6")
Debug Eval::Calc("6 = (4+2)")
Debug Eval::Calc("6 = 4+2")
Debug ""
Debug Eval::Calc(" 2+3+4")
Debug Eval::Calc(" 2-3*4")
Debug Eval::Calc(" +2+3*4")
Debug Eval::Calc(" -2+3*4")
Debug Eval::Calc(" 12*2")
Debug Eval::Calc(" -3*4")
Debug Eval::Calc("(2+3)*4")
Debug ""
Debug Eval::Calc("4^3^2")
Debug Eval::Calc("4^(3^2)")
Debug Eval::Calc("(4^3)^2")
Debug ""
Debug Eval::Calc("Ceil ( 3.2)")
Debug Eval::Calc("Ceil (-3.8)")
Debug Eval::Calc("Trunc( 4.7)")
Debug Eval::Calc("Trunc(-4.7)")
Debug Eval::Calc("Floor( 3.8)")
Debug Eval::Calc("Floor(-3.2)")
CompilerEndIf-------------------------------------------------
My best tricks & tips from 15+ years
Create arrays elegantly
Extended date library
Save JSON data with object members well-arranged
Evaluate and process math expressions
Functions for sets
Statistics with R
Thue-Morse sequence
Natural sorting
Sort array indexes and parallel arrays
Time profiling
VectorIcons
Generate focus events
