home *** CD-ROM | disk | FTP | other *** search
/ POINT Software Programming / PPROG1.ISO / basic / baswiz19 / examples / eval.bas < prev    next >
Encoding:
BASIC Source File  |  1993-01-29  |  11.1 KB  |  396 lines
  1. '   +----------------------------------------------------------------------+
  2. '   |                                                                      |
  3. '   |        BASWIZ  Copyright (c) 1990-1993  Thomas G. Hanlin III         |
  4. '   |                                                                      |
  5. '   |                      The BASIC Wizard's Library                      |
  6. '   |                                                                      |
  7. '   +----------------------------------------------------------------------+
  8.  
  9.  
  10. ' ----- These are external routines -----
  11.    DECLARE FUNCTION ArcCosS! (Nr AS SINGLE)
  12.    DECLARE FUNCTION ArcSinS! (Nr AS SINGLE)
  13.  
  14. ' ----- These are internal routines -----
  15.    DECLARE FUNCTION Expr0! (Expr$, ErrCode%)
  16.    DECLARE FUNCTION Factor0! (Expr$, ErrCode%)
  17.    DECLARE FUNCTION Term0! (Expr$, ErrCode%)
  18.    DECLARE FUNCTION IsDigit0% (Expr$)
  19.    DECLARE FUNCTION ParensOk0% (Expr$)
  20.    DECLARE SUB AddParen0 (Expr$, Posn%, WhichWay%)
  21.    DECLARE SUB FixPrecedence0 (Expr$)
  22.  
  23.  
  24.  
  25. ' ----- This is the main evaluation routine -----
  26. SUB Evaluate (Expression$, Result!, ErrCode%)
  27.    Expr$ = UCASE$(Expression$)
  28.    WHILE INSTR(Expr$, " ")
  29.       tmp% = INSTR(Expr$, " ")
  30.       Expr$ = LEFT$(Expr$, tmp% - 1) + MID$(Expr$, tmp% + 1)
  31.    WEND
  32.    WHILE INSTR(Expr$, "**")
  33.       tmp% = INSTR(Expr$, "**")
  34.       Expr$ = LEFT$(Expr$, tmp% - 1) + "^" + MID$(Expr$, tmp% + 2)
  35.    WEND
  36.    IF LEN(Expr$) THEN
  37.       IF ParensOk0%(Expr$) THEN
  38.          ErrCode% = 0
  39.          FixPrecedence0 Expr$
  40.          Result! = Expr0!(Expr$, ErrCode%)
  41.       ELSE
  42.          ErrCode% = 4
  43.       END IF
  44.    ELSE
  45.       ErrCode% = 8
  46.    END IF
  47. END SUB
  48.  
  49.  
  50.  
  51. ' ----- This adds parentheses to force evaluation by normal algebraic
  52. ' ----- precedence (negation, exponentiation, multiplication and division,
  53. ' ----- addition and subtraction)
  54. SUB AddParen0 (Expr$, Posn%, WhichWay%)
  55.    P% = Posn%
  56.    IF WhichWay% < 0 THEN
  57.       Done% = 0
  58.       DO
  59.          P% = P% - 1
  60.          IF P% < 1 THEN
  61.             Expr$ = "(" + Expr$
  62.             Done% = -1
  63.          ELSE
  64.             ch$ = MID$(Expr$, P%, 1)
  65.             IF INSTR("^*/+-", ch$) THEN
  66.                Expr$ = LEFT$(Expr$, P%) + "(" + MID$(Expr$, P% + 1)
  67.                Done% = -1
  68.             ELSEIF ch$ = ")" THEN
  69.                Depth% = 1
  70.                DO
  71.                   P% = P% - 1
  72.                   IF P% > 0 THEN
  73.                      ch$ = MID$(Expr$, P%, 1)
  74.                      IF ch$ = "(" THEN
  75.                         Depth% = Depth% - 1
  76.                      ELSEIF ch$ = ")" THEN
  77.                         Depth% = Depth% + 1
  78.                      END IF
  79.                   ELSE
  80.                      Depth% = 0
  81.                   END IF
  82.                LOOP WHILE Depth%
  83.                IF P% < 1 THEN P% = 1
  84.                Expr$ = LEFT$(Expr$, P%) + "(" + MID$(Expr$, P% + 1)
  85.                Done% = -1
  86.             END IF
  87.          END IF
  88.       LOOP UNTIL Done%
  89.    ELSE
  90.       Done% = 0
  91.       DO
  92.          P% = P% + 1
  93.          IF P% > LEN(Expr$) THEN
  94.             Expr$ = Expr$ + ")"
  95.             Done% = -1
  96.          ELSE
  97.             ch$ = MID$(Expr$, P%, 1)
  98.             IF INSTR("^*/+-", ch$) THEN
  99.                Expr$ = LEFT$(Expr$, P% - 1) + ")" + MID$(Expr$, P%)
  100.                Done% = -1
  101.             ELSEIF ch$ = "(" THEN
  102.                Depth% = 1
  103.                DO
  104.                   P% = P% + 1
  105.                   IF P% <= LEN(Expr$) THEN
  106.                      ch$ = MID$(Expr$, P%, 1)
  107.                      IF ch$ = ")" THEN
  108.                         Depth% = Depth% - 1
  109.                      ELSEIF ch$ = "(" THEN
  110.                         Depth% = Depth% + 1
  111.                      END IF
  112.                   ELSE
  113.                      Depth% = 0
  114.                   END IF
  115.                LOOP WHILE Depth%
  116.                IF P% > LEN(Expr$) THEN P% = LEN(Expr$)
  117.                Expr$ = LEFT$(Expr$, P% - 1) + ")" + MID$(Expr$, P%)
  118.                Done% = -1
  119.             END IF
  120.          END IF
  121.       LOOP UNTIL Done%
  122.    END IF
  123. END SUB
  124.  
  125.  
  126.  
  127. ' ----- This is the heart of the expression evaluator.
  128. ' ----- It is a recursive function.
  129. FUNCTION Expr0! (Expr$, ErrCode%)
  130.    LVal! = Factor0!(Expr$, ErrCode%)
  131.    IF ErrCode% = 0 THEN
  132.       SELECT CASE LEFT$(Expr$, 1)
  133.          CASE "+"
  134.             Expr$ = MID$(Expr$, 2)
  135.             LVal! = LVal! + Expr0!(Expr$, ErrCode%)
  136.          CASE "-"
  137.             Expr$ = MID$(Expr$, 2)
  138.             LVal! = LVal! - Expr0!(Expr$, ErrCode%)
  139.          CASE "*"
  140.             Expr$ = MID$(Expr$, 2)
  141.             LVal! = LVal! * Expr0!(Expr$, ErrCode%)
  142.          CASE "/"
  143.             Expr$ = MID$(Expr$, 2)
  144.             tmp! = Expr0!(Expr$, ErrCode%)
  145.             IF tmp! = 0! THEN
  146.                ErrCode% = 9
  147.             ELSE
  148.                LVal! = LVal! / tmp!
  149.             END IF
  150.          CASE "^"
  151.             Expr$ = MID$(Expr$, 2)
  152.             LVal! = LVal! ^ Expr0!(Expr$, ErrCode%)
  153.          CASE ")"
  154.             Expr$ = MID$(Expr$, 2)
  155.          CASE ELSE
  156.       END SELECT
  157.    END IF
  158.    Expr0! = LVal!
  159. END FUNCTION
  160.  
  161.  
  162.  
  163. ' ----- A recursive evaluation helper, this gets the leftmost term that
  164. ' ----- can be dealt with at this point in the evaluation.
  165. FUNCTION Factor0! (Expr$, ErrCode%)
  166.    RVal! = 0!
  167.    IF LEFT$(Expr$, 1) = "-" THEN
  168.       Negate% = -1
  169.       Expr$ = MID$(Expr$, 2)
  170.    ELSE
  171.       Negate% = 0
  172.    END IF
  173.    IF LEFT$(Expr$, 1) = "(" THEN
  174.       Expr$ = MID$(Expr$, 2)
  175.       RVal! = Expr0!(Expr$, ErrCode%)
  176.    ELSE
  177.       RVal! = Term0!(Expr$, ErrCode%)
  178.    END IF
  179.    IF Negate% THEN
  180.       Factor0! = -RVal!
  181.    ELSE
  182.       Factor0! = RVal!
  183.    END IF
  184. END FUNCTION
  185.  
  186.  
  187.  
  188. ' ----- Since the evaluation function doesn't naturally evaluate expressions
  189. ' ----- using algebraic precedence, but does understand parentheses...
  190. ' ----- This routine adds parentheses to force the proper precedence.
  191. SUB FixPrecedence0 (Expr$)
  192.    Expr$ = "(" + Expr$ + ")"
  193.    ex% = 1
  194.    DO
  195.       ex% = INSTR(ex%, Expr$, "-")
  196.       IF ex% THEN
  197.          ch% = ASC(MID$(Expr$, ex% - 1, 1))
  198.          IF NOT (ch% > 47 AND ch% < 58 OR ch% > 64 AND ch% < 91 OR ch% > 96 AND ch% < 123) THEN
  199.             ' if not alphanumeric, must be negation-- use top priority
  200.             AddParen0 Expr$, ex%, 1
  201.             AddParen0 Expr$, ex%, -1
  202.          END IF
  203.          ex% = ex% + 2
  204.       END IF
  205.    LOOP WHILE ex%
  206.  
  207.    ex% = 1
  208.    DO
  209.       ch$ = MID$(Expr$, ex%, 1)
  210.       IF ch$ = LCASE$(ch$) THEN
  211.          ex% = ex% + 1
  212.       ELSE
  213.          AddParen0 Expr$, ex%, 1
  214.          AddParen0 Expr$, ex%, -1
  215.          ex% = ex% + 2
  216.       END IF
  217.    LOOP UNTIL ex% > LEN(Expr$)
  218.  
  219.    ex% = 1
  220.    DO
  221.       ch$ = MID$(Expr$, ex%, 1)
  222.       IF ch$ = "^" THEN
  223.          AddParen0 Expr$, ex%, 1
  224.          AddParen0 Expr$, ex%, -1
  225.          ex% = ex% + 2
  226.       ELSE
  227.          ex% = ex% + 1
  228.       END IF
  229.    LOOP UNTIL ex% > LEN(Expr$)
  230.    ex% = 1
  231.    DO
  232.       ch$ = MID$(Expr$, ex%, 1)
  233.       IF ch$ = "*" OR ch$ = "/" THEN
  234.          AddParen0 Expr$, ex%, 1
  235.          AddParen0 Expr$, ex%, -1
  236.          ex% = ex% + 2
  237.       ELSE
  238.          ex% = ex% + 1
  239.       END IF
  240.    LOOP UNTIL ex% > LEN(Expr$)
  241.    ex% = 1
  242.    DO
  243.       ch$ = MID$(Expr$, ex%, 1)
  244.       IF ch$ = "+" OR ch$ = "-" THEN
  245.          AddParen0 Expr$, ex%, 1
  246.          AddParen0 Expr$, ex%, -1
  247.          ex% = ex% + 2
  248.       ELSE
  249.          ex% = ex% + 1
  250.       END IF
  251.    LOOP UNTIL ex% > LEN(Expr$)
  252.    Expr$ = MID$(Expr$, 2, LEN(Expr$) - 2)
  253. END SUB
  254.  
  255.  
  256.  
  257. ' ----- Determines whether a character may be construed as being numeric.
  258. FUNCTION IsDigit0% (Expr$)
  259.    IF LEN(Expr$) THEN
  260.       IsDigit0% = (INSTR("0123456789.", LEFT$(Expr$, 1)) > 0)
  261.    ELSE
  262.       IsDigit0% = 0
  263.    END IF
  264. END FUNCTION
  265.  
  266.  
  267.  
  268. ' ----- Checks to make sure parentheses are balanced.
  269. FUNCTION ParensOk0% (Expr$)
  270.    FOR tmp% = 1 TO LEN(Expr$)
  271.       ch$ = MID$(Expr$, tmp%, 1)
  272.       IF ch$ = "(" THEN
  273.          L% = L% + 1
  274.       ELSEIF ch$ = ")" THEN
  275.          R% = R% + 1
  276.       END IF
  277.    NEXT
  278.    ParensOk0% = (L% = R%)
  279. END FUNCTION
  280.  
  281.  
  282.  
  283. ' ----- This grabs a term from the expression.
  284. FUNCTION Term0! (Expr$, ErrCode%)
  285.    RVal! = 0!
  286.    ch$ = LEFT$(Expr$, 1)
  287.    IF ch$ <> LCASE$(ch$) THEN
  288.       TermName$ = ""
  289.       DO
  290.          TermName$ = TermName$ + ch$
  291.          Expr$ = MID$(Expr$, 2)
  292.          ch$ = LEFT$(Expr$, 1)
  293.       LOOP UNTIL ch$ = LCASE$(ch$)
  294.       SELECT CASE TermName$
  295.          CASE "ABS"
  296.             IF ch$ = "(" THEN
  297.                Expr$ = MID$(Expr$, 2)
  298.                RVal! = ABS(Expr0!(Expr$, ErrCode%))
  299.             ELSE
  300.                ErrCode% = 1
  301.             END IF
  302.          CASE "ACOS"
  303.             IF ch$ = "(" THEN
  304.                Expr$ = MID$(Expr$, 2)
  305.                RVal! = ArcCosS!(Expr0!(Expr$, ErrCode%))
  306.             ELSE
  307.                ErrCode% = 1
  308.             END IF
  309.          CASE "ASIN"
  310.             IF ch$ = "(" THEN
  311.                Expr$ = MID$(Expr$, 2)
  312.                RVal! = ArcSinS!(Expr0!(Expr$, ErrCode%))
  313.             ELSE
  314.                ErrCode% = 1
  315.             END IF
  316.          CASE "ATAN"
  317.             IF ch$ = "(" THEN
  318.                Expr$ = MID$(Expr$, 2)
  319.                RVal! = ATN(Expr0!(Expr$, ErrCode%))
  320.             ELSE
  321.                ErrCode% = 1
  322.             END IF
  323.          CASE "COS"
  324.             IF ch$ = "(" THEN
  325.                Expr$ = MID$(Expr$, 2)
  326.                RVal! = COS(Expr0!(Expr$, ErrCode%))
  327.             ELSE
  328.                ErrCode% = 1
  329.             END IF
  330.          CASE "FRAC"
  331.             IF ch$ = "(" THEN
  332.                Expr$ = MID$(Expr$, 2)
  333.                RVal! = Expr0!(Expr$, ErrCode%)
  334.                t$ = STR$(RVal!)
  335.                tmp = INSTR(t$, ".")
  336.                IF tmp THEN
  337.                   RVal! = CSNG(VAL(MID$(t$, tmp)))
  338.                ELSE
  339.                   RVal! = 0!
  340.                END IF
  341.             ELSE
  342.                ErrCode% = 1
  343.             END IF
  344.          CASE "INT"
  345.             IF ch$ = "(" THEN
  346.                Expr$ = MID$(Expr$, 2)
  347.                RVal! = INT(Expr0!(Expr$, ErrCode%))
  348.             ELSE
  349.                ErrCode% = 1
  350.             END IF
  351.          CASE "LOG"
  352.             IF ch$ = "(" THEN
  353.                Expr$ = MID$(Expr$, 2)
  354.                RVal! = LOG(Expr0!(Expr$, ErrCode%))
  355.             ELSE
  356.                ErrCode% = 1
  357.             END IF
  358.          CASE "PI"
  359.             RVal! = 3.141593
  360.          CASE "SIN"
  361.             IF ch$ = "(" THEN
  362.                Expr$ = MID$(Expr$, 2)
  363.                RVal! = SIN(Expr0!(Expr$, ErrCode%))
  364.             ELSE
  365.                ErrCode% = 1
  366.             END IF
  367.          CASE "SQR"
  368.             IF ch$ = "(" THEN
  369.                Expr$ = MID$(Expr$, 2)
  370.                RVal! = SQR(Expr0!(Expr$, ErrCode%))
  371.             ELSE
  372.                ErrCode% = 1
  373.             END IF
  374.          CASE "TAN"
  375.             IF ch$ = "(" THEN
  376.                Expr$ = MID$(Expr$, 2)
  377.                RVal! = TAN(Expr0!(Expr$, ErrCode%))
  378.             ELSE
  379.                ErrCode% = 1
  380.             END IF
  381.          CASE ELSE
  382.             ErrCode% = 3
  383.       END SELECT
  384.    ELSEIF IsDigit0%(Expr$) THEN
  385.       tmp$ = ""
  386.       DO WHILE IsDigit0%(Expr$)
  387.          tmp$ = tmp$ + LEFT$(Expr$, 1)
  388.          Expr$ = MID$(Expr$, 2)
  389.       LOOP
  390.       RVal! = VAL(tmp$)
  391.    ELSE
  392.       ErrCode% = 2
  393.    END IF
  394.    Term0! = RVal!
  395. END FUNCTION
  396.