home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / basic / library / qb_pds / math / parser / parser.bas
Encoding:
BASIC Source File  |  1994-05-01  |  18.7 KB  |  541 lines
  1. '**************************************************************************************************
  2. '*                                                                                                *
  3. '*                    ÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑ                      *
  4. '*                    SCANNER, PARSER & EVALUATOR FOR MATHEMATICAL FUNCTIONS                      *
  5. '*                    ÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑÑ                      *
  6. '*                                                                                                *
  7. '* WAHT IT DOES:                                                                                  *
  8. '* -------------                                                                                  *
  9. '* Anyone, who ever wanted to give in a mathematical expression in runtime (i. e. not the direct  *
  10. '* way in the program code itself) knows, that this is a very hard job, because when you give in  *
  11. '* such an expression while your program is running, it will treat your expression as if it was   *
  12. '* any normal kind of text string. But what it should do is just 'understand' your formular.      *
  13. '* So you have have to establish a small (sometimes it can get really big, of course!) interpre-  *
  14. '* ter for mathematical formulas with brackets, operator hierarchie or only for normal number     *
  15. '* chrunching, perhaps for your own calculator. That's just what it does!                         *
  16. '*                                                                                                *
  17. '* HOW TO WRITE FORMULAS:                                                                         *
  18. '* ----------------------                                                                         *
  19. '* These routines read and analyse any mathematical expression in Infix notation and evaluate it. *
  20. '* You can use one variable x, any of the operators +, -, *, /, ^ and use up to 10 levels of      *
  21. '* brackets. Within each level 10 brackets on the same level are allowed. You can use             *
  22. '* many special mathematical functions which are predefined inside this program for your own      *
  23. '* use. Furthermore can you input the symbols '╣' and 'e', they are converted to their real       *
  24. '* values. It is possible to use any of the three kinds of Brackets (), [] and {}. The program    *
  25. '* will treat them all the same.                                                                  *
  26. '* A special feature is the treatment of the '*' operator in conjunction with variables and       *
  27. '* functions. You are allowed to omit this operator in all those special cases where the normal   *
  28. '* mathematical conventions allow you to do it. Here is a list of all those special cases, in     *
  29. '* which you don't need the '*' operator. You can omit '*' between:                               *
  30. '* a) values (left) and x:                                 2x = 2*x                               *
  31. '* b) x and x:                                             xx = x*x                               *
  32. '* c) values (left) and brackets:                      2(x-4) = of 2*(x-4)                        *
  33. '* d) x and brackets (both sides):           x(3-x) or (3-x)x = x*(3-x) or (3-x)*x                *
  34. '* e) brackets:                                    (x-2)(x+4) = (x-2)*(x+4)                       *
  35. '* f) values (left) and functions:                    4sin(x) = 4*sin(x)                          *
  36. '* g) x and functions (both sides):          xln(x) or ln(x)x = x*ln(x) or ln(x)*x                *
  37. '* h) brackets and functions (both sides):        (2-x)cos(x) = (2-x)*cos(x)                      *
  38. '* i) functions and funktions:                   sin(x)cos(x) = sin(x)*cos(x)                     *
  39. '* The following cases are not supported (you also should not use them in normal mathematical     *
  40. '* notation, because it leads to misunderstandings): (x-4)3¡(x-4)*3, x2¡x*2, ln(x)4¡ln(x)*4 !     *
  41. '* You can use negative Exponents with the '^' operator without brackets: x^-3 = x^(-3).          *
  42. '* You are allowed to write with small letters or with capital letters or all mixed up, it does   *
  43. '* not matter at all, because the input expression will be converted to capital letters anyway.   *
  44. '* At least there are no problems with any number of spaces between symbols and values. They all  *
  45. '* will be truncated just at the beginning of the program.                                        *
  46. '* I think this additions will please anyone who is used to write mathematical expressions. You   *
  47. '* can do it just the way you used to do.                                                         *
  48. '* I didn't implement lot's of error routines because you should create them for your special     *
  49. '* program needs (may be you use special filter functions in FUTURE Basic etc.). So please        *
  50. '* take care of those things when you use this code for your own purpose.                         *
  51. '*                                                                                                *
  52. '* GENERAL NOTICE AND COPYRIGHT:                                                                  *
  53. '* -----------------------------                                                                  *
  54. '* Though I'm no friend of any special code ownership (I know about some 'shareware' programmers  *
  55. '* who take money for their code.) you first should be aware that I worked very hard to get this  *
  56. '* peace of software do what it should do. I'm no novice but I'm still learning and learning...   *
  57. '* So my understanding of this kind of general programming roundtables is, that we all together   *
  58. '* should share our own ideas with others, so that we can learn from each other. I don't like     *
  59. '* these special guys who always want to hide their ideas from others. It's only a matter of      *
  60. '* time that another will have the same inspiration and solve this programming problems anyway.   *
  61. '* But there is one situation in which I think you should be honest and give some contribution to *
  62. '* the author of programming code, that is when you go commercial with you program and use parts  *
  63. '* or whole units of programming code from other authors. On the other hand I'm always interes-   *
  64. '* ted in your opinion about what I have done. And believe me, I will always try to do just the   *
  65. '* same and give you my response when I took some peace of code from you. So please give me some  *
  66. '* response, otherwise it's useless for me to be a member of CompuServe, because in that case     *
  67. '* this information service whould only be a special kind of grocery store for me.                *
  68. '* Thanks for your patience to follow me so far.                                                  *
  69. '* Detlef Reimers                                                                                 *
  70. '* 2000 Hamburg 61, Suentelstrasse 7 (Germany)                                                    *
  71. '* CompuServe #1100015,1146                                                                       *
  72. '*                                                                                                *
  73. '* PRINTING THIS CODE:                                                                            *
  74. '* -------------------                                                                            *
  75. '* I have a 15 inch monitor and therefore this text has a great width. If you want to print it    *
  76. '* out fine, just choose 90% scaling and letter size and everything will fit into the page width. *
  77. '**************************************************************************************************
  78.  
  79. WINDOW OFF:WINDOW 1,"Parser",(2,40)-(637,860),257
  80.  
  81. ' -----------------------------------------------------------------------------------------------
  82.  
  83. "Start"
  84.  
  85. DIM Op$(30)                             ' operators & functions
  86. DIM T$(10,10)                           ' sub expressions in brackets
  87. DIM 16 Z$(10,10,20)                     ' strings for values and x
  88. DIM 2 O$(10,10,20)                      ' original operators
  89. DIM 2 P$(10,10,20)                      ' temporèry operators
  90. DIM N!(10,10,20)                        ' original values
  91. DIM M!(10,10,20)                        ' temporèry values
  92. DIM Num(10,10)                          ' number of values inside the brackets
  93. DIM K(10)                               ' number of brackets
  94. DIM F&(48)                              ' math functions
  95. DIM N(4)                                ' string positions
  96. DIM N$(2)                               ' search strings
  97.  
  98.  
  99. ' -----------------------------------------------------------------------------------------------
  100.  
  101. DATA   SIN,    COS,    TAN,    COT,    SINH,  COSH,  TANH,  COTH,  ASIN,  ACOS,   ATAN,  ACOT
  102. DATA   ASINH,  ACOSH,  ATANH,  ACOTH,  LN,    EXP,   SQR,   FAK,   INT,   FRAC,   ABS,   SGN
  103. DATA   A,      B,      C,      D,      F,     G,     H,     I,     J,     K,      L,     M
  104. DATA   N,      O,      P,      Q,      R,     S,     T,     U,     V,     W,      Y,     Z
  105.  
  106. ' -----------------------------------------------------------------------------------------------
  107.  
  108. RESTORE
  109.  
  110. FOR I=1 TO 48
  111.   READ PSTR$(F&(I))
  112. NEXT I
  113.  
  114. FOR I=25 TO 48
  115.   Op$(I-24)=PSTR$(F&(I))
  116. NEXT I
  117.  
  118. Op$(25)="^":Op$(26)="^":Op$(27)="*":Op$(28)="/":Op$(29)="+":Op$(30)="-"
  119.  
  120. ' -----------------------------------------------------------------------------------------------
  121.  
  122. LONG FN Term
  123.  
  124.   Term$=UCASE$(Term$)
  125.  
  126. LONG IF LEN(Term$)>1
  127.   DO
  128.     Len=LEN(Term$)
  129.     N=INSTR(1,Term$," ")
  130.     LONG IF N
  131.       Term$=LEFT$(Term$,N-1)+RIGHT$(Term$,Len-N)
  132.     END IF
  133.   UNTIL N=0
  134.  
  135.   Len=LEN(Term$)
  136.  
  137.   FOR I=1 TO 4
  138.  
  139.     DO
  140.       N(1)=INSTR(1,Term$,"[")
  141.       N(2)=INSTR(1,Term$,"{")
  142.       N(3)=INSTR(1,Term$,"]")
  143.       N(4)=INSTR(1,Term$,"}")
  144.       LONG IF N(I)
  145.         IF I<3 THEN MID$(Term$,N(I),1)="(" ELSE MID$(Term$,N(I),1)=")"
  146.       END IF
  147.     UNTIL N(I)=0
  148.  
  149.   NEXT I
  150.  
  151.   FOR I=1 TO 2
  152.  
  153.     DO
  154.       FOR J=1 TO Len
  155.       Len=LEN(Term$)
  156.         N(1)=INSTR(J,Term$,"X")
  157.         N(2)=INSTR(J,Term$,"(")
  158.         N$=MID$(Term$,N(I)-1,1)
  159.         LONG IF (N$>="0" AND N$<="9") OR N$="X" OR N$=")"
  160.           IF N(I)>1 THEN Term$=LEFT$(Term$,N(I)-1)+"*"+RIGHT$(Term$,Len-(N(I)-1))
  161.         END IF
  162.       NEXT J
  163.     UNTIL (N$<"0" OR N$>"9") AND N$<>"X" AND N$<>")"
  164.  
  165.   NEXT I
  166. END IF
  167.  
  168. END FN
  169.  
  170. ' -----------------------------------------------------------------------------------------------
  171.  
  172. LONG FN Substitute
  173.  
  174. LONG IF LEN(Term$)>2
  175.   FOR I=24 TO 1 STEP -1
  176.     S$=PSTR$(F&(I))
  177.     LenS=LEN(S$)
  178.  
  179.     DO
  180.       Len=LEN(Term$)
  181.       N=INSTR(1,Term$,S$)
  182.       LONG IF N
  183.         Term$=LEFT$(Term$,N-1)+"1"+PSTR$(F&(I+24))+RIGHT$(Term$,Len-LenS-(N-1))
  184.       END IF
  185.     UNTIL N=0
  186.  
  187.   NEXT I
  188.  
  189.   FOR I=1 TO 26
  190.     LONG IF CHR$(64+I)<>"X" AND CHR$(64+I)<>"E"
  191.  
  192.       DO
  193.         FOR J=1 TO Len
  194.         Len=LEN(Term$)
  195.           N=INSTR(J,Term$,CHR$(64+I))
  196.           N$=MID$(Term$,N-2,1)
  197.           LONG IF (N$>="0" AND N$<="9") OR N$="X" OR N$=")"
  198.             IF N>2 THEN Term$=LEFT$(Term$,N-2)+"*"+RIGHT$(Term$,Len-(N-2))
  199.           END IF
  200.         NEXT J
  201.       UNTIL (N$<"0" OR N$>"9") AND N$<>"X" AND N$<>")"
  202.  
  203.     END IF
  204.   NEXT I
  205. END IF
  206.  
  207. END FN
  208.  
  209. ' -----------------------------------------------------------------------------------------------
  210.  
  211. LONG FN Brackets
  212.  
  213.   Max=1
  214.   Auf=0
  215.   Zu=0
  216.   S=1
  217.   K(1)=1
  218.   Length=LEN(Term$)
  219.  
  220.   FOR I=1 TO Length
  221.     S$=MID$(Term$,I,1)
  222.  
  223.     SELECT S$
  224.     CASE "("
  225.       T$(S,K(S))=T$(S,K(S))+"Ñ"
  226.       Auf=Auf+1
  227.       S=S+1
  228.       K(S)=K(S)+1
  229.       IF S>Max THEN Max=S
  230.     CASE ")"
  231.       Zu=Zu+1
  232.       S=S-1
  233.     CASE ELSE
  234.       T$(S,K(S))=T$(S,K(S))+S$
  235.     END SELECT
  236.  
  237.   NEXT I
  238.  
  239.   IF Auf<>Zu THEN PRINT "Bracket error":BEEP:GOTO "New"
  240.  
  241. END FN
  242.  
  243. ' -----------------------------------------------------------------------------------------------
  244.  
  245. LONG FN Scanner
  246.  
  247.   FOR S=1 TO Max
  248.     FOR N=1 TO K(S)
  249.  
  250.       J=1:K=1
  251.       Length=LEN(T$(S,N))
  252.       Z$(N,S,J)=""
  253.  
  254.       FOR I=1 TO Length
  255.         S$=MID$(T$(S,N),I,1)
  256.  
  257.         LONG IF VAL(S$) OR S$="0" OR S$="." OR S$="X" OR S$="╣" OR S$="E" OR S$="Ñ"
  258.  
  259.           IF I=2 AND MID$(T$(S,N),1,1)="-" THEN Z$(S,N,J)="-"+Z$(S,N,J)
  260.           IF MID$(T$(S,N),I-2,2)="^-" THEN Z$(S,N,J)="-"+Z$(S,N,J)
  261.           Z$(S,N,J)=Z$(S,N,J)+S$
  262.  
  263.           LONG IF Z$(S,N,J)="E" OR Z$(S,N,J)="-E" OR Z$(S,N,J)="╣" OR Z$(S,N,J)="-╣"
  264.             IF Z$(S,N,J)= "E" THEN N!(S,N,J)= 2.718281828
  265.             IF Z$(S,N,J)="-E" THEN N!(S,N,J)=-2.718281828
  266.             IF Z$(S,N,J)= "╣" THEN N!(S,N,J)= 3.141592654
  267.             IF Z$(S,N,J)="-╣" THEN N!(S,N,J)=-3.141592654
  268.           XELSE
  269.             N!(S,N,J)=VAL(Z$(S,N,J))
  270.           END IF
  271.  
  272.         XELSE
  273.  
  274.           LONG IF S$="+" OR S$="-" OR S$="*" OR S$="/" OR S$="^"
  275.             LONG IF MID$(T$(S,N),I-1,1)<>"^" AND I<>1
  276.               O$(S,N,K)=S$
  277.               K=K+1
  278.             END IF
  279.           XELSE
  280.             LONG IF S$>="A" AND S$<="Z"
  281.               O$(S,N,K)=S$
  282.               K=K+1
  283.             XELSE
  284.               PRINT "Variable error":BEEP:GOTO "New"
  285.             END IF
  286.           END IF
  287.  
  288.           LONG IF Z$(S,N,J)<>""
  289.             J=J+1
  290.           END IF
  291.  
  292.         END IF
  293.  
  294.       NEXT I
  295.       Num(S,N)=J
  296.  
  297.     NEXT N
  298.   NEXT S
  299.  
  300. END FN
  301.  
  302. ' -----------------------------------------------------------------------------------------------
  303.  
  304. LONG FN Fak(n)
  305.  
  306.   LONG IF n=0
  307.     Fak=1
  308.   XELSE
  309.     Fak=n*FN Fak(n-1)
  310.   END IF
  311.  
  312. END FN
  313.  
  314. ' -----------------------------------------------------------------------------------------------
  315.  
  316. LONG FN Function
  317.  
  318.   FOR L=1 TO 29 STEP 2
  319.     I=0
  320.  
  321.     DO
  322.       I=I+1
  323.  
  324.       LONG IF P$(S,N,I)=Op$(L) OR P$(S,N,I)=Op$(L+1)
  325.         X1!=M!(S,N,I):X2!=M!(S,N,I+1)
  326.  
  327.         SELECT P$(S,N,I)
  328.         CASE "+"
  329.           M!(S,N,I)=X1!+X2!
  330.         CASE "-"
  331.           M!(S,N,I)=X1!-X2!
  332.         CASE "*"
  333.           M!(S,N,I)=X1!*X2!
  334.         CASE "/"
  335.           M!(S,N,I)=X1!/X2!
  336.         CASE "^"
  337.           M!(S,N,I)=X1!^X2!
  338.         CASE "A"
  339.           M!(S,N,I)=SIN(X2!)                                'sin
  340.         CASE "B"
  341.           M!(S,N,I)=COS(X2!)                                'cos
  342.         CASE "C"
  343.           M!(S,N,I)=TAN(X2!)                                'tan
  344.         CASE "D"
  345.           M!(S,N,I)=1/TAN(X2!)                              'cot
  346.         CASE "F"
  347.           M!(S,N,I)=(EXP(X2!)-EXP(-X2!))/2                  'sinh
  348.         CASE "G"
  349.           M!(S,N,I)=(EXP(X2!)+EXP(-X2!))/2                  'cosh
  350.         CASE "H"
  351.           M!(S,N,I)=(EXP(X2!)-1)/(EXP(X2!)+1)               'tanh
  352.         CASE "I"
  353.           M!(S,N,I)=(EXP(X2!)+1)/(EXP(X2!)-1)               'coth
  354.         CASE "J"
  355.           M!(S,N,I)=ATN(X2!/SQR(1-X2!*X2!))                 'arcsin
  356.         CASE "K"
  357.           M!(S,N,I)=ATN(1)*2-ATN(X2!/SQR(1-X2!*X2!))        'arccos
  358.         CASE "L"
  359.           M!(S,N,I)=ATN(X2!)                                'arctan
  360.         CASE "M"
  361.           M!(S,N,I)=ATN(1)*2-ATN(X2!)                       'arccot
  362.         CASE "N"
  363.           M!(S,N,I)=LOG(X2!+SQR(X2!*X2!+1))                 'arcsinh
  364.         CASE "O"
  365.           M!(S,N,I)=LOG(X2!+SQR(X2!*X2!-1))                 'arccosh
  366.         CASE "P"
  367.           M!(S,N,I)=LOG((1+X2!)/(1-X2!))/2                  'arctanh
  368.         CASE "Q"
  369.           M!(S,N,I)=LOG((X2!+1)/(X2!-1))/2                  'arctanh
  370.         CASE "R"
  371.           M!(S,N,I)=LOG(X2!)                                'ln x
  372.         CASE "S"
  373.           M!(S,N,I)=EXP(X2!)                                'e^x
  374.         CASE "T"
  375.           M!(S,N,I)=SQR(X2!)                                'square root
  376.         CASE "U"
  377.           M!(S,N,I)=FN Fak(X2!)                             'fakultèt
  378.         CASE "V"
  379.           M!(S,N,I)=INT(X2!)                                'integer
  380.         CASE "W"
  381.           M!(S,N,I)=FRAC(X2!)                               'fraction
  382.         CASE "Y"
  383.           M!(S,N,I)=ABS(X2!)                                'absolut
  384.         CASE "Z"
  385.           M!(S,N,I)=SGN(X2!)                                'signum
  386.         CASE ELSE
  387.           PRINT "Operator error":BEEP:GOTO "New"
  388.         END SELECT
  389.  
  390.         old&=VARPTR(M!(S,N,I+2))
  391.         max&=VARPTR(M!(S,N,Nmax))
  392.         new&=VARPTR(M!(S,N,I+1))
  393.         Length=max&-old&+4
  394.         BLOCKMOVE old&,new&,Length
  395.  
  396.         old&=VARPTR(P$(S,N,I+1))
  397.         max&=VARPTR(P$(S,N,Nmax))
  398.         new&=VARPTR(P$(S,N,I))
  399.         Length=max&-old&+3
  400.         BLOCKMOVE old&,new&,Length
  401.  
  402.         Nmax=Nmax-1
  403.         I=0
  404.  
  405.       END IF
  406.  
  407.     UNTIL I>=Nmax-1
  408.  
  409.   NEXT L
  410. END FN
  411.  
  412. ' -----------------------------------------------------------------------------------------------
  413.  
  414. LONG FN Parser
  415.  
  416.   FOR S=Max TO 1 STEP -1
  417.     W=0
  418.     FOR N=1 TO K(S)
  419.  
  420.       FOR J=1 TO Num(S,N)
  421.  
  422.         SELECT Z$(S,N,J)
  423.         CASE "X"
  424.           N!(S,N,J)=x!
  425.         CASE "-X"
  426.           N!(S,N,J)=-x!
  427.         CASE "Ñ"
  428.           W=W+1
  429.           N!(S,N,J)=M!(S+1,W,1)
  430.         CASE "-Ñ"
  431.           W=W+1
  432.           N!(S,N,J)=-M!(S+1,W,1)
  433.         END SELECT
  434.  
  435.         Nmax=Num(S,N)
  436.         old&=VARPTR(N!(S,N,1))
  437.         max&=VARPTR(N!(S,N,Nmax))
  438.         new&=VARPTR(M!(S,N,1))
  439.         Length=max&-old&+4
  440.         BLOCKMOVE old&,new&,Length
  441.  
  442.         old&=VARPTR(O$(S,N,1))
  443.         max&=VARPTR(O$(S,N,Nmax-1))
  444.         new&=VARPTR(P$(S,N,1))
  445.         Length=max&-old&+3
  446.         BLOCKMOVE old&,new&,Length
  447.  
  448.         FN Function
  449.  
  450.       NEXT J
  451.  
  452.     NEXT N
  453.   NEXT S
  454.  
  455. END FN
  456.  
  457. ' -----------------------------------------------------------------------------------------------
  458.  
  459. LONG FN Print
  460.  
  461.   CLS
  462.   PRINT
  463.   PRINT In$
  464.   PRINT STRING$(LEN(Term$),"-")
  465.   PRINT
  466.  
  467.   FOR S=1 TO Max
  468.  
  469.     FOR N=1 TO K(S)
  470.       PRINT T$(S,N),"=";M!(S,N,1)
  471.       FOR I=1 TO Num(S,N)
  472.         PRINT S;N;I,Z$(S,N,I);STRING$(20-POS(0)," ");O$(S,N,I)
  473.       NEXT I
  474.       PRINT STRING$(21,"-")
  475.     NEXT N
  476.  
  477.   NEXT S
  478.  
  479.   PRINT "X","=";x!
  480.  
  481. END FN
  482.  
  483. ' -----------------------------------------------------------------------------------------------
  484.  
  485. LONG FN Evaluate
  486.  
  487.   CLS
  488.   PRINT
  489.   PRINT In$
  490.   PRINT STRING$(LEN(Term$),"-")
  491.   PRINT
  492.   PRINT "Input a value (Return quits, e and ╣ possible)"
  493.   PRINT
  494.   INPUT "X=";X$
  495.  
  496.   IF X$="" THEN "New"
  497.   IF X$="╣" OR X$="╕" THEN X$="3.141592654"
  498.   IF X$="e" OR X$="E" THEN X$="2.718281828"
  499.   x!=VAL(X$)
  500.  
  501.   FN Parser
  502.   FN Print
  503.  
  504.   DO
  505.   UNTIL MOUSE(3) OR LEN(INKEY$)
  506.  
  507.   FN Evaluate
  508.  
  509. END FN
  510.  
  511. ' -----------------------------------------------------------------------------------------------
  512.  
  513. "Input"
  514.  
  515.   CLS
  516.   PRINT
  517.   PRINT "Please input expression (Return quits)"
  518.   PRINT
  519.   INPUT "Term: ";Term$
  520.   IF Term$="" THEN END
  521.  
  522.   
  523.   FN Term
  524.   FN Substitute
  525.   In$=Term$
  526.   FN Brackets
  527.   FN Scanner
  528.   FN Evaluate
  529.  
  530. "New"
  531.   CLS
  532.   CLEAR
  533.   PRINT
  534.   PRINT "New formula? (y / n) ";
  535.   DO
  536.     I$=INKEY$  
  537.   UNTIL I$<>""
  538.   IF I$="y" OR I$="Y" THEN "Start"
  539.  
  540. END
  541.