Ah, it was a bone head mistake I was making! Now EVAL 2 bplus.bas has and, or and not working:
Code: Select all
' EVAL 2 bplus.bas for FB (B+=MGA) 2017-07-04
'based on successful: evalW 2.txt for JB [B+=MGA] 2017-03-11 repost with edits
' EVAL 1 - Just Basic Eval code translated and = > < >= <= <> binary's added
'EVAL 2 - add And and Or, Not
Const XMAX = 1200
Const YMAX = 720
Const PI = Acos(-1)
Const RAD = PI/180.0
Const DEG = 180/PI
ScreenRes XMAX, YMAX
Width XMAX\8, YMAX\16 ' Use 8*16 font
Declare Function Evaluate(e As String) As Double
Declare Function evalW(s As String) As Double
Declare Function wPrep(s As String) As String
Declare Function Wrd(s As String, wNumber As Integer) As String
Declare Function wCnt(s As String) As Integer
Declare Function wIn(s As String, Wrd As String) As Integer
Declare Function wSubst(s As String, first As Integer, last As Integer ,subst As String) As String
Common Shared As String EvalErr
Common Shared As Double DFlag, GlobalX
DFlag = 1 : GlobalX = 5 'changeable
Dim As String e
Dim As Double r
' tests
'e = "log(0)" 'err
'e = "exp(-694) " 'err
'e = "exp(-693) " ' 1.0812... E-301 bottom limit no error on my system, -708 on another test
'e = "exp( 709) " ' 8.21840... E+307no error on my system
'e = "sqr(-10)" 'err
'e = "-5 ^ 1.9" 'err
'e = "2*-3 - -4+-0.25" ' returns -2.25 OK but must isolate - meant for subtraction
'e = "1 + 2 * (3 + (4 * 5 + 6 * 7 * 8) - 9) / 10" ' returns 71 OK
'e = " 1 + 2*(3 - 2*(3 - 2)*((2 - 4)*5 - 22/(7 + 2*(3 - 1)) - 1)) + 1" ' returns 60 OK
'e = "1+1+(1+(1+(1+(1+(1+(1+(1+(1+(1+(1+(1+(1+(1+1/15)/14)/13)/12)/11)/10)/9)/8)/7)/6)/5)/4)/3)/2"
' returns euler's 2.718 281 828 458 994 464 285 469 58 OK for as far as it goes 2.718 281 828 458 995 last digit off by 1
'e = "(1.4 + 2^(19%4))/2" ' > 4.7 OK
'e = "e^2" ' > 7.3890...
'e = "PI/6" ' > .52...
'e = "x ^ (200/400)" ' > 2.23606 when sqr(x) x = 5
'e = "x^2 - 2*x - 15" ' > 0 when x = 5 good!
'e = "e^ 8" ' > 2980.958
'e = " log(2980.958)" ' > 8.000..
'e = "sin(x)^2 + cos(x)^2" ' > 1
'e = "atan(sin(30)/cos(30))" ' > 30 with DFlag = 1
'e = ".3 + 2*10^-8"
'e = "pi/6 < pi" 'yeah my first Boolean!
'e = "99 % 11 = 99 % 9"
'e = "23 >= 22"
e = "(99 % 9 = 0) and (not 23 < 22 or 5 < 3)"
'IMPORTANT NOTE: wrap - sign with spaces if meant for subtraction,
'if meant to signal neg number leave no space between it and number
Print e
r = Evaluate(e)
If EvalErr <> "" Then Print "Error: ";EvalErr Else Print "Expression = ";r
? "Done"
sleep
'this preps e string for actual evaluation function and makes call to it,
'checks results for error returns that or number if no error.
Function Evaluate(e As String) As Double
Dim As String c, b, subst
Dim As Integer i, po, p
b = "" 'rebuild string with padded spaces
'this makes sure ( ) + * / % ^ are wrapped with spaces, on your own with - sign
For i = 1 To Len(e) 'filter chars and count ()
c = LCase(Mid(e, i, 1))
If c = ")" Then
po = po - 1 : b = b + " ) "
ElseIf c = "(" Then
po = po + 1 : b = b + " ( "
ElseIf InStr("+*/%^", c) > 0 Then
b = b + " " + c + " "
ElseIf InStr(" -.0123456789abcdefghijklmnopqrstuvwxyz<>=", c) > 0 Then
b = b + c
EndIf
If po < 0 Then EvalErr = "Too many )" : Exit Function
Next
If po <> 0 Then EvalErr = "Unbalanced ()" : Exit Function
e = wPrep(b)
For i = 1 To 3
p = wIn(e, Wrd("x e pi", i))
While p > 0
Select Case i
Case 1 : subst = Str(GlobalX)
Case 2 : subst = Str(Exp(1))
Case 3 : subst = Str(PI)
End Select
e = wSubst(e, p, p, subst)
p = wIn(e, Wrd("x e pi", i))
Wend
Next
Evaluate = evalW(e)
End Function
' the recursive part of EVAL
Function evalW(s As String) As Double
Dim As Integer pop, lPlace, i, rPlace, wc, po, funPlace, recurs, p, o
Dim As String fun, w, test, inner, ops, op, middle
Dim As Double a, b, innerV, m
? "EvalW gets: ";s 'debug or fun to watch recursive calls in reverse
pop = wIn(s, "(") 'parenthesis open place
While pop > 0
If pop = 1 Then
fun = "" : lPlace = 1
Else
test = Wrd(s, pop - 1)
funPlace = wIn("sin cos tan asin acos atan log exp sqr rad deg", test)
If funPlace > 0 Then
fun = test : lPlace = pop - 1
Else
fun = "" : lPlace = pop
End If
End If
wc = wCnt(s) : po = 1
For i = pop + 1 To wc
If Wrd(s, i) = "(" Then po = po + 1
If Wrd(s, i) = ")" Then po = po - 1
If po = 0 Then rPlace = i : Exit For
Next
inner = ""
For i = (pop + 1) To (rPlace - 1)
w = Wrd(s, i)
inner = inner + w + " "
If wIn("( and or = < > <= >= <> + - * / % ^", w) > 0 Then recurs = 1
Next
If recurs Then innerV = evalW(inner) Else innerV = Val(inner)
Select Case fun
Case "" : m = innerV
Case "sin" : If DFlag Then m = Sin(RAD * innerV) Else m = Sin(innerV)
Case "cos" : If DFlag Then m = Cos(RAD * innerV) Else m = Cos(innerV)
Case "tan" : If DFlag Then m = Tan(RAD * innerV) Else m = Tan(innerV)
Case "asin" : If DFlag Then m = DEG * (Asin(innerV)) Else m = Asin(innerV)
Case "acos": If DFlag Then m = DEG * (acos(innerV)) Else m = acos(innerV)
Case "atan": If DFlag Then m = DEG * (Atn(innerV)) Else m = Atn(innerV)
Case "log"
If innerV > 0 Then
m = Log(innerV)
Else
EvalErr = "LOG only works on numbers > 0." : Exit Function
End If
Case "exp" 'the error limit is inconsistent in JB
If -693 <= innerV And innerV <= 709 Then 'your system may have different results
m = Exp(innerV)
Else
' what the heck???? 708 works fine all alone as limit ?????
EvalErr = "EXP only works for ABS(number) <= ??? using 693." : Exit Function
End If
Case "sqr"
If innerV >= 0 Then
m = Sqr(innerV)
Else
EvalErr = "SQR only works for numbers >= 0." : Exit Function
End If
Case "rad" : m = innerV * RAD
Case "deg" : m = innerV * DEG
Case Else : EvalErr = "Unidentified function " + fun : Exit Function
End Select
s = wSubst(s, lPlace, rPlace, Str(m))
pop = wIn(s, "(")
Wend
ops = "% ^ / * - + = < > <= >= <> and or not" 'all () cleared, now for binary ops (not not binary but is last!)
For o = 1 To 15
op = Wrd(ops, o)
p = wIn(s, op)
While p > 0
a = Val(Wrd(s, p - 1))
b = Val(Wrd(s, p + 1))
Select Case op
Case "%"
If b >= 2 Then
middle = Str(Int(a) Mod Int(b))
Else
EvalErr = "For a Mod b, b value < 2."
Exit Function
End If
Case "^"
If Int(b) = b Or a >= 0 Then
middle = Str(a ^ b)
Else
EvalErr = "For a ^ b, a needs to be >= 0 when b not integer."
Exit Function
End If
Case "/"
If b <> 0 Then
middle = Str(a / b)
Else
EvalErr = "Div by 0"
Exit Function
End If
Case "*" : middle = Str(a * b)
Case "-" : middle = Str(a - b)
Case "+" : middle = Str(a + b)
Case "=" : If a = b Then middle = "1" Else middle = "0"
Case "<" : If a < b Then middle = "1" Else middle = "0"
Case ">" : If a > b Then middle = "1" Else middle = "0"
Case "<=" : If a <= b Then middle = "1" Else middle = "0"
Case ">=" : If a >= b Then middle = "1" Else middle = "0"
Case "<>" : If a <> b Then middle = "1" Else middle = "0"
Case "and" : If a <> 0 And b <> 0 Then middle = "1" Else middle = "0"
Case "or" : If a <> 0 Or b <> 0 Then middle = "1" Else middle = "0"
Case "not" : If b = 0 Then middle = "1" Else middle = "0" 'use b as nothing should be left of not
End Select
s = wSubst(s, p - 1, p + 1, middle)
p = wIn(s, op)
Wend
Next
evalW = Val(s)
End Function
'return trimmed source string s with one space between each word
Function wPrep(s As String) As String
Dim p As Integer
s = Trim(s)
If Len(s) = 0 Then wPrep = "" : Exit Function
'remove all double or more spaces
p = InStr(s, " ")
While p > 0
s = Mid(s, 1, p) + Mid(s, p + 2, Len(s) - p - 1)
p = InStr(s, " ")
Wend
wPrep = s
End Function
' This duplicates JB word(string, wordNumber) base 1, space as default delimiter
' by returning the Nth word of source string s
' this function assumes s has been through wPrep
Function Wrd(s As String, wNumber As Integer) As String
Dim As String w
Dim As Integer i, c
's = wPrep(s)
If Len(s) = 0 Then Return ""
w = "" : c = 1
For i = 1 To Len(s)
If Mid(s, i, 1) = " " Then
If c = wNumber Then Return w
w = "" : c += 1
Else
w = w + Mid(s, i, 1)
End If
Next
If c <> wNumber Then Return " " Else Return w
End Function
'This function counts the words in source string s
'this function assumes s has been thru wPrep
Function wCnt(s As String) As Integer
Dim As Integer c, p, ip
's = wPrep(s)
If Len(s) = 0 Then wCnt = 0 : Exit Function
c = 1 : p = 1 : ip = InStr(p, s, " ")
While ip
c += 1 : p = ip + 1 : ip = InStr(p, s, " ")
Wend
wCnt = c
End Function
'Where is word In source s, 0 = Not In source
'this function assumes s has been thru wPrep
Function wIn(s As String, wd As String) As Integer
Dim As Integer wc, i
wc = wCnt(s) : wIn = 0
For i = 1 To wc
If Wrd(s, i) = wd Then wIn = i : Exit Function
Next
End Function
' substitute string in s to replace section first to last words inclusive
'this function assumes s has been thru wPrep
Function wSubst(s As String, first As Integer, last As Integer ,subst As String) As String
Dim As Integer wc, i, subF
Dim b As String
wc = wCnt(s) : b = ""
For i = 1 To wc
If first <= i And i <= last Then 'do this only once!
If subF = 0 Then b = b + subst + " " : subF = 1
Else
b = b + Wrd(s, i) + " "
End If
Next
wSubst = trim(b)
End Function
