03-06-2005, 07:46 PM
:bounce: Ok i made it work in FB. It even gives the same answers as excel in bizarre inputs like -2^-2/-3*+-3/3-3+-3. It is easy to add other functions in EvaluateTheFunctionD. Just follow the cos sin tan examples.
Edit : Also added syntax error check and support of functions with more than one arguments.
Edit : Also added syntax error check and support of functions with more than one arguments.
Code:
'' *********************************************************
'' Additional string functions
'' ReplaceStr Replace$
'' TallyStr Tally
'' FieldStr Field$
'' *********************************************************
Function ReplaceStr(TheString as string, RWhat as string, RWith as string) as string
Dim tempv as string
tempv=""
Dim lw as integer
lw=Len(RWhat)
Dim i as integer
for i=1 to Len(TheString)
if mid$(TheString,i,lw)=RWhat then
tempv=tempv+RWith
i=i+lw-1
else
tempv=tempv+mid$(TheString,i,1)
end if
Next i
ReplaceStr=tempv
End Function
Function TallyStr(TheString as string, RWhat as string) as integer
Dim i,j as integer
j=0
Dim lw as integer
lw=Len(RWhat)
for i=1 to Len(TheString)
if mid$(TheString,i,lw)=RWhat then
j=j+1
i=i+lw-1
else
end if
Next i
TallyStr=j
End Function
Function FieldStr(TheString as string, RWhat as String, index as integer) as string
Dim jindex as integer
jindex=TallyStr(TheString,RWhat)
If jindex+1< index then
FieldStr=""
Exit Function
end if
Dim a(jindex+1) as integer
Dim i,j as integer
j=1
Dim lw as integer
lw=Len(RWhat)
for i=1 to Len(TheString)
if mid$(TheString,i,lw)=RWhat then
a(j)=i
j=j+1
i=i+lw-1
else
end if
Next i
If index=0 then
FieldStr=""
Exit Function
End if
If Index=jindex+1 then
FieldStr=mid$(TheString,a(index-1)+lw,len(TheString)-a(index-1)-lw)
Exit Function
End if
If index=1 then
FieldStr=mid$(TheString,1,a(1)-1)
Exit Function
End if
FieldStr=mid$(TheString,a(index-1)+lw,a(index)-a(index-1)-lw)
End Function
'' *********************************************************
'' Additional math functions
'' *********************************************************
Function fact(arg1 as integer) as double
''factorial
Dim ct as integer
Dim tempval as double
if arg1<0 then
fact=-999999 ''Error
Exit Function
End if
if arg1=0 or arg1=1 then
fact=1
exit function
end if
ct=1
tempval=1
do
ct=ct+1
if arg1>=ct then
tempval=tempval*ct
else
exit do
end if
loop
fact=tempval
End Function
Function snorm(z As Double) as double
''cumulative normal
Dim pi as double
pi=3.14159265358979
Dim a1 as double,a2 as double,a3 as double,a4 as double,a5 as double,k as double,w as double
a1 = 0.31938153
a2 = -0.356563782
a3 = 1.781477937
a4 = -1.821255978
a5 = 1.330274429
If 0 > z Then w = -1 Else w = 1
k = 1 / (1 + 0.2316419 * w * z)
snorm = 0.5 + w * (0.5 - 1 / Sqr(2 * pi) * Exp(-z ^ 2 / 2) * (a1 * k + a2 * k ^ 2 + a3 * k ^ 3 + a4 * k ^ 4 + a5 * k ^ 5))
End Function
Function snormInv(p as double) as double
Dim Minz as double,Maxz as double,zVal as double,pVal as double,prec as double
prec = 1e-06
Minz = -6.0
Maxz = 6.0
zVal = 0.0
While (Maxz - Minz) > prec
pVal = snorm(zVal)
If pVal > p Then
Maxz = zVal
Else
Minz = zVal
End If
zVal = (Maxz + Minz) * 0.5
Wend
snorminv = zVal
End Function
Function Combin(arg1 as double,arg2 as double) as double
''Returns the available Combinations
''arg1 -> number n
''arg2 -> number k
Dim tempvalue1 as double, tempvalue2 as double
Dim ct as integer
if int(arg1)<0 or int(arg2)<0 or int(arg1)<int(arg2) then
Combin=0
''TheError=1
Exit Function
end if
if int(arg2)=0 then
Combin=1
Exit Function
end if
tempvalue2=1
tempvalue1=1
for ct=1 to int(arg2)
tempvalue2=tempvalue2*ct
next ct
for ct=(int(arg1)-int(arg2)+1) to int(arg1)
tempvalue1=tempvalue1*ct
next ct
Combin=tempvalue1/tempvalue2
End Function
Function Permut(arg1 as double,arg2 as double) as double
''Returns the available Permutations
''arg1 -> number n
''arg2 -> number k
Dim tempvalue1 as double
Dim ct as integer
if int(arg1)<0 or int(arg2)<0 or int(arg1)<int(arg2) then
Permut=0
''TheError=1
Exit Function
end if
if int(arg2)=0 then
Permut=1
Exit Function
end if
tempvalue1=1
for ct=(int(arg1)-int(arg2)+1) to int(arg1)
tempvalue1=tempvalue1*ct
next ct
Permut=tempvalue1
End Function
'' Error Codes
Dim shared TheError
' 1 Division by zero
' 2 Unknown Function
' 3 Invalid Function argument
'' Syntax Errors
FUNCTION WhatIsIt(a$,b$) as string
' n number
' o operator
' pm + - operator
' l left bracket
' r right bracket
' f function
' s something else
if asc(a$)>47 and asc(a$)<58 then
WhatIsIt="n"
Exit Function
End if
if a$="." then
WhatIsIt="n"
Exit Function
End if
if a$="e" and b$="n" then
WhatIsIt="n"
Exit Function
End if
if a$="+" then
WhatIsIt="pm"
Exit Function
End if
if a$="-" then
WhatIsIt="pm"
Exit Function
End if
if a$="*" then
WhatIsIt="o"
Exit Function
End if
if a$="/" then
WhatIsIt="o"
Exit Function
End if
if a$="^" then
WhatIsIt="o"
Exit Function
End if
if a$=";" then
WhatIsIt="o"
Exit Function
End if
if a$="(" then
WhatIsIt="l"
Exit Function
End if
if a$=")" then
WhatIsIt="r"
Exit Function
End if
if asc(a$)>96 and asc(a$)<123 then
WhatIsIt="f"
Exit Function
End if
WhatIsIt="s"
End Function
Function SyntaxError (pass$) as string
dim formula$
formula$=pass$
if formula$="" then
SyntaxError="ok"
Exit Function
end if
if TallyStr(formula$,"(") <> TallyStr(formula$,")") then
SyntaxError="Missing parenthesis. Please correct syntax."
Exit Function
end if
formula$ = LCASE$(formula$)
formula$ = ReplaceStr(formula$," ","")
formula$ = ReplaceStr(formula$,",",".")
Dim x%
Dim e$
Dim l$
Dim p$
l$="l"
for x%=1 to LEN(formula$)
e$=mid$(formula$,x%,1)
p$=WhatIsIt(e$,l$)
if p$="s" then
SyntaxError="Syntax Error 1. Step "+str$(x%)
Exit Function
End if
if p$="n" and (l$="r" or l$="f") then
SyntaxError="Syntax Error 2. Step "+str$(x%)
Exit Function
End if
if p$="o" and (l$="o" or l$="pm" or l$="l" or l$="f") then
SyntaxError="Syntax Error 3. Step "+str$(x%)
Exit Function
End if
if p$="pm" and l$="f" then
SyntaxError="Syntax Error 4. Step "+str$(x%)
Exit Function
End if
if p$="l" and (l$="n" or l$="r") then
SyntaxError="Syntax Error 5. Step "+str$(x%)
Exit Function
End if
if p$="r" and (l$="o" or l$="pm" or l$="f") then
SyntaxError="Syntax Error 6. Step "+str$(x%)
Exit Function
End if
if p$="f" and (l$="n" or l$="r") then
SyntaxError="Syntax Error 7. Step "+str$(x%)
Exit Function
End if
l$=p$
Next x%
if l$="o" or l$="pm" or l$="l" or l$="f" then
SyntaxError="Syntax Error 8. Step "+str$(x%)
Exit Function
End if
SyntaxError="ok"
End Function
Function EvaluateTheString2(MathExp as string) as double
Dim TheString as string
TheString=MathExp
Dim a(100) as double
Dim ap(100) as integer
if TheString="" then
EvaluateTheString2=0
Exit Function
End if
TheString=LCase$(TheString)
TheString="+"+TheString
TheString=ReplaceStr(TheString," ","")
TheString=ReplaceStr(TheString,"++","+")
TheString=ReplaceStr(TheString,"-+","-")
TheString=ReplaceStr(TheString,"--","+")
TheString=ReplaceStr(TheString,"/- ","/+-")
TheString=ReplaceStr(TheString,"*-","*+-")
TheString=ReplaceStr(TheString,"^-","^+-")
Dim i,x,dx,ct,j,maxi as integer
Dim e$
Dim s as double
i=0
maxi=0
x=0
e$=""
s=0
do
x=x+1
e$=mid$(TheString,x,1)
if e$="" then exit do
if e$="0" or e$="1" or e$="2" or e$="3" or e$="4" or e$="5" or e$="6" or e$="7" or e$="8" or e$="9" or e$="." then
dx=0
do
dx=dx+1
e$=mid$(TheString,x+dx,1)
if ((e$="+" or e$="-") and (mid$(TheString,x+dx-1,1)<>"e")) or e$="^" or e$="*" or e$="/" or e$="" then
i=i+1
a(i)=val(mid$(TheString,x,dx))
exit do
end if
loop
x=x+dx
end if
if e$="+" then
dx=0
do
dx=dx+1
e$=mid$(TheString,x+dx,1)
if ((e$="+" or (e$="-" and dx<>1)) and mid$(TheString,x+dx-1,1)<>"e") or e$="^" or e$="*" or e$="/" or e$="" then
i=i+1
a(i)=val(mid$(TheString,x+1,dx-1))
exit do
end if
loop
x=x+dx-1
end if
if e$="^" then ap(i)=3
if e$="*" then ap(i)=2
if e$="/" then ap(i)=1
if e$="-" then 'ap(i)=ap(i)+4
if ap(i)=3 then ap(i)=7
if ap(i)=2 then ap(i)=6
if ap(i)=1 then ap(i)=5
if ap(i)=4 then ap(i)=0
if ap(i)=0 then ap(i)=4
end if
loop
maxi=i
'calculate "^"
ct=0
do
ct=ct+1
if ct=i then exit do
if ap(ct)=3 then
a(ct)=a(ct)^a(ct+1)
for j=ct+1 to i-1
a(j)=a(j+1)
ap(j-1)=ap(j)
next j
i=i-1
ct=0
end if
if ap(ct)=7 then
a(ct)=a(ct)^(-a(ct+1))
for j=ct+1 to i-1
a(j)=a(j+1)
ap(j-1)=ap(j)
next j
i=i-1
ct=0
end if
loop
'calculate "*" & "/"
ct=0
do
ct=ct+1
if ct=i then exit do
if ap(ct)=2 then
a(ct)=a(ct)*a(ct+1)
for j=ct+1 to i-1
a(j)=a(j+1)
ap(j-1)=ap(j)
next j
i=i-1
ct=0
end if
if ap(ct)=6 then
a(ct)=a(ct)*(-a(ct+1))
for j=ct+1 to i-1
a(j)=a(j+1)
ap(j-1)=ap(j)
next j
i=i-1
ct=0
end if
if ap(ct)=1 then
if a(ct+1)=0 then
'Division by zero!
TheError=1
Exit Function
End if
a(ct)=a(ct)/a(ct+1)
for j=ct+1 to i-1
a(j)=a(j+1)
ap(j-1)=ap(j)
next j
i=i-1
ct=0
end if
if ap(ct)=5 then
if a(ct+1)=0 then
'Division by zero!
TheError=1
Exit Function
End if
a(ct)=a(ct)/(-a(ct+1))
for j=ct+1 to i-1
a(j)=a(j+1)
ap(j-1)=ap(j)
next j
i=i-1
ct=0
end if
loop
for ct=2 to i
if ap(ct-1)=0 then
s=s+a(ct)
else
s=s-a(ct)
end if
next ct
s=s+a(1)
EvaluateTheString2=s
End Function
Function EvaluateTheFunctionD(TheString as string,TheNumber as double) as double
DIM MathString$(11)
MathString$(1) = "sin"
MathString$(2) = "cos"
MathString$(3) = "tan"
MathString$(4) = "log"
MathString$(5) = "exp"
MathString$(6) = "rnd"
MathString$(7) = "sqr"
MathString$(8) = "abs"
MathString$(9) = "fact"
MathString$(10) = "snorm"
MathString$(11) = "snorminv"
Dim i as integer,ct as integer,HaveFound as integer,itemparg as integer
Dim insertval as double
HaveFound=0
FOR i = 1 TO 11
IF MathString$(i)=TheString THEN 'it doesnt work the other way around
HaveFound=1
SELECT CASE i
CASE 1
if abs(sin(TheNumber))<1e-12 then
insertval=0
else
insertval=sin(TheNumber)
end if
CASE 2
if abs(cos(TheNumber))<1e-12 then
insertval=0
else
insertval=cos(TheNumber)
end if
CASE 3
if abs(cos(TheNumber))<1e-12 then
TheError=3 ' invalid argument
EvaluateTheFunctionD=0
Exit Function
else
insertval = tan(TheNumber)
end if
CASE 4
insertval=log(TheNumber)
CASE 5
insertval=exp(TheNumber)
CASE 6
insertval=rnd(TheNumber)
CASE 7
If TheNumber<0 then
TheError=3 ' invalid argument
EvaluateTheFunctionD=0
Exit Function
else
insertval=sqr(TheNumber)
end if
CASE 8
insertval=abs(TheNumber)
CASE 9
itemparg=int(TheNumber)
If itemparg<0 then
TheError=3 ' invalid argument
EvaluateTheFunctionD=0
Exit Function
else
insertval=fact(itemparg)
end if
CASE 10
insertval=snorm(TheNumber)
CASE 11
insertval=snorminv(TheNumber)
END SELECT
Exit For
END IF
NEXT i
If HaveFound=0 then
TheError=2 ' unknown function
EvaluateTheFunctionD=0
Exit Function
End if
EvaluateTheFunctionD=insertval
End Function
Function EvaluateTheFunctionDD(TheString as string,TheArg as string) as double
DIM Arg(10) as double
DIM MathString$(3)
MathString$(1) = "power" 'error tracking to be fixed
MathString$(2) = "permut"
MathString$(3) = "combin"
Dim i as integer,ct as integer,HaveFound as integer
Dim insertval as double
HaveFound=0
for i = 1 to 3
IF MathString$(i)=TheString THEN 'it doesnt work the other way around
HaveFound=1
SELECT CASE i
CASE 1
Arg(1)=val(FieldStr ( TheArg, ";" , 1 ))
Arg(2)=val(FieldStr ( TheArg, ";" , 2 ))
insertval=Arg(1)^Arg(2)
CASE 2
Arg(1)=val(FieldStr ( TheArg, ";" , 1 ))
Arg(2)=val(FieldStr ( TheArg, ";" , 2 ))
insertval=permut(Arg(1),Arg(2))
CASE 3
Arg(1)=val(FieldStr ( TheArg, ";" , 1 ))
Arg(2)=val(FieldStr ( TheArg, ";" , 2 ))
insertval=combin(Arg(1),Arg(2))
END SELECT
Exit For
END IF
NEXT i
If HaveFound=0 then
TheError=2 ' unknown function
EvaluateTheFunctionDD=0
Exit Function
End if
EvaluateTheFunctionDD=insertval
End Function
Function EvaluateFunction(Fun as string,Arg as string) as double
' It returns the evaluation of a function
' Currently it supports functions with one argument
if TALLYStr(Arg,";")=0 then
EvaluateFunction=EvaluateTheFunctionD(Fun,EvaluateTheString2(Arg))
else
EvaluateFunction=EvaluateTheFunctionDD(Fun,Arg)
end if
End Function
Function EvaluatePar(MathExp as string) as string
'Call this function only if there is a parenthesis!!
'This function will find the first ")" and it will match it with a "(" and give as a substitution answer
Dim TheString as string
TheString=MathExp
Dim e$
Dim tempval as double
Dim i as integer,ib as integer,tempasc as integer,TSLen as integer,parl as integer,parr as integer
TSLen=len(TheString)
parl=1
parr=TSLen
for i=1 to TSLen
e$=mid$(TheString,i,1)
if e$="" then exit for
if e$="(" then
parl=i
ib=i
end if
if e$=")" then
parr=i
exit for
end if
Next i
if ib>1 then
do
tempasc=asc(mid$(TheString,ib-1,1))
if tempasc>96 and tempasc<123 then
ib=ib-1
else
exit do
end if
loop
end if
if ib<parl then 'its a function
tempval=EvaluateFunction(mid$(TheString,ib,parl-ib),mid$(TheString,parl+1,parr-parl-1))
else 'its a math expression
tempval=EvaluateTheString2(mid$(TheString,parl+1,parr-parl-1))
end if
if TheError<>0 then EvaluatePar=""
EvaluatePar=left$(TheString,ib-1)+str$(tempval)+right$(TheString,TSLen-parr)
End Function
Function EvaluateTheString(arg as string) as string
' This Function returns a string with the answer for the math expression
Dim TheString$
TheString$=arg
TheString$=LCase$(TheString$)
if SyntaxError(TheString$)="ok" then
While TallyStr(TheString$,")") >0
TheString$=EvaluatePar(TheString$)
'if TheString$="Error!" or TheString$="Division by zero!" then Function=TheString$
WEND
EvaluateTheString=str$(EvaluateTheString2(TheString$))
else
EvaluateTheString=SyntaxError(TheString$)
end if
End Function
Print "Example: cos(2)+2 = " ; EvaluateTheString("cos(2)+2")
Print "Example: exp(cos(2)) = ";EvaluateTheString("exp(cos(2))")
Print "Example: snorminv(0.1+exp(cos(2))) = ";EvaluateTheString("snorminv(0.1+exp(cos(2)))")
Print "Example: (sin(1))^2+(cos(1))^2 =";EvaluateTheString("(sin(1))^2+(cos(1))^2")
Print "Example (it behaves like excel in this one): -(-1^2) = ";EvaluateTheString("-(-1^2)")
Print "Example (it behaves like excel in this one): -2^-2/-3*+-3/3-3+-3 = ";EvaluateTheString("-2^-2/-3*+-3/3-3+-3")
Print "Example functions with more than one arguments: power(2;3) = ";EvaluateTheString("power(2;3)")
Print "Example it detects syntax errors: (cos)(2+3) = ";EvaluateTheString("(cos)(2+3)")
Print
Dim MathExp as string
Dim Answer as string
TheError=0
Input "Math Expression... ";MathExp
Answer=EvaluateTheString(MathExp)
if TheError=0 then
Print Answer
else
If TheError=1 then Print "Division by zero"
If TheError=2 then Print "Unknown Function"
If TheError=3 then Print "Invalid Function argument"
end if
sleep