Maybe something for the math library... a WIP Math Parser!

[gbos]

: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.

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

[keeling]

Is there a means to get rid of the extra parentheses ?

Yes, there is!!!! Is called me fixing a bug

In the Update routine the line

Code:

do while (ReturnPriority <= GetPriority(OStack(OSP)))

Should be

Code:

Do While (ReturnPriority <= GetPriority(OStack(OSP)) And (OSP <> 0))

I had forgotten to check if the Operator Stack was empty.

Your test (fundemental trig identity) is now evaluated properly.

Waiting on the next bug now :-)

[Blitz]

Screw rpn man, recursive descent parser are the way to go. Simple as hell to code once you've got the grammar down. Like marzecs parser.

[keeling]

I like Marzecs' parser a lot. I've gotten a couple of good ideas from it as well.

I went with RPN because I understood the logic. I haven't messed with grammars before and to be honest it never occured to me to try it that way.

I will stick with the RPN method for a little while longer, just to see if I can (I already have variables working and constants working). However, in the end I will use which ever parser is faster, less buggy and easier to update. In each case this maybe Marzecs'.

[keeling]

The Code above has been updated to reflect a bug fix and basic variable and constant support (I don't like the way the constants are done yet).

[Antoni Gual]

Where can I find Marzec's parser?

[keeling]

its in this thread. Look under marzecTM

[Antoni Gual]

Sorry..

[marzecTM]

uhm it was not my intention to replace your rpn version. as long as it works i'd say go with it. but i guess the rdp version is easier to maintain. just google for ebnf grammars, lexer etc. you'll get a lot of info on the methods i used. it's really easy and you can add variable and constant stuff really easy and in a transparent way. uhm speaking of transparent i maybe should comment the code...

[Blitz]

rpn works for simple expressions. But when the expressions get more complex or if you want to expand it to a simple language rpn is just a pain. A recursive descent parser however, can parse anything simply and effeciently. And it's not complex at all compared to LL(k), LALR(k), LAR(k) parser which need huge state tables and are nearly impossible to maintain and debug.

And the nice thing about EBNF grammar is that each rule is translates to a simple function in a recursive descent parser. That keeps the complexity down.