home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 24 / CD_ASCQ_24_0995.iso / vrac / homonlib.zip / EVALUATE.BAS < prev    next >
BASIC Source File  |  1995-04-13  |  13KB  |  302 lines
  1. DEFINT A-Z
  2.  
  3. ' $INCLUDE: 'TRUEFALS.INC'
  4.  
  5. DECLARE FUNCTION Evaluate$ (formula$)
  6. DECLARE FUNCTION EvalNum (n$)           'Used only by Evaluate$()
  7.  
  8.  
  9. 'Error handling:
  10.  
  11. DIM SHARED EvalCode
  12.  
  13. EvalHandler:
  14.      EvalCode = ERR
  15.      RESUME NEXT
  16.  
  17. FUNCTION EvalNum (n$) STATIC
  18. '****************************************************************************
  19. 'This is a custom IsNum() just for Evaluate$().  Because the n$ argument will
  20. ' always be only 1 character in length, it can be simplified.  Also,
  21. ' Evaluate() considers a decimal point numeric, unlike IsNum().
  22. '****************************************************************************
  23.  
  24. IF INSTR("0123456789.", n$) THEN
  25.      EvalNum = TRUE
  26. ELSE
  27.      EvalNum = FALSE
  28. END IF
  29.  
  30. END FUNCTION
  31.  
  32. FUNCTION Evaluate$ (formula$)
  33. '****************************************************************************
  34. 'This is a special function.  It evaluates a "formula" and returns a string
  35. ' of the value.  If an error is found within the formula (or Evaluate$ is
  36. ' just unable to handle it), Evaluate$ will return a string with a leading
  37. ' asterisk followed by a description of the error.  The best way to see what
  38. ' it does is just to experiment.  By no means am I sure that this function is
  39. ' completely bulletproof, but it will stand up to most expressions whose
  40. ' value doesn't exceed a few trillion.  This function is a good example of
  41. ' recursion if you are interested.
  42. '
  43. 'Example:  formula$ = "10*4-(36/3)"
  44. '          newval$ = Evaluate$(formula$)
  45. '          IF left$(newval$,1)="*" then
  46. '              PRINT "An error occurred!"
  47. '              PRINT newval$                 '(Error description)
  48. '          ELSE
  49. '              PRINT "The value of ";formula$;" is:"; VAL(newval$)
  50. '          END IF
  51. '
  52. 'Note: MUST be compiled with the /X switch.
  53. '
  54. '****************************************************************************
  55.  
  56. '                     *** Preliminary Error Checking ***
  57.  
  58. f$ = formula$                           'Use a temp var for the formula.
  59. x$ = " "                                'A little optimizer.
  60.  
  61. DO WHILE INSTR(f$, x$) > 0              'Remove any spaces from it.
  62.      x = INSTR(f$, x$)                  '(See function Squeeze$())
  63.      y$ = LEFT$(f$, x - 1)
  64.      z$ = MID$(f$, x + 1)
  65.      f$ = y$ + z$
  66. LOOP
  67.  
  68. IF f$ = "" THEN                         'Evaluate a null string as zero.
  69.      Evaluate$ = "0"
  70.      EXIT FUNCTION
  71. END IF
  72.  
  73. DO WHILE LEFT$(f$, 2) = "--"            'Check for leading double-minuses and
  74.      f$ = RIGHT$(f$, LEN(f$) - 2)       'remove them (because -- = +).
  75. LOOP
  76.  
  77. DO WHILE LEFT$(f$, 1) = "+"             'Check for leading positive signs and
  78.      f$ = RIGHT$(f$, LEN(f$) - 1)       'remove them.
  79. LOOP
  80.  
  81. y$ = "": z$ = ""
  82. FOR x = 1 TO LEN(f$)                              'Make sure the formula
  83.      x$ = MID$(f$, x, 1)                          'contains only valid
  84.      SELECT CASE ASC(x$)                          'characters by checking
  85.           CASE 48 TO 57                           'each one's ASCII code.
  86.                'OK - 0123456789
  87.           CASE 45
  88.                'OK - subtraction/negation symbol: -         'Not allowed more
  89.                IF x$ = y$ AND z = 1 THEN EvalCode = 2       'than 2 in a row
  90.                IF x = LEN(f$) THEN EvalCode = 2             'or last.
  91.           CASE 40, 41
  92.                'OK - left & right parentheses: ()           'Must have some-
  93.                IF x$ = ")" AND y$ = "(" THEN EvalCode = 3   'thing between!
  94.           CASE 46
  95.                'OK - decimal point: .                  'Not allowed to have
  96.                IF x$ = y$ THEN EvalCode = 2            'two adjacent decimals
  97.                IF x = LEN(f$) THEN EvalCode = 2        'or in last position.
  98.           CASE 43
  99.                'OK - plus: +                           'Not allowed adjacent
  100.                IF y = 1 THEN EvalCode = 2              'to another operator
  101.                IF x = LEN(f$) THEN EvalCode = 2        'or in last position.
  102.           CASE 37, 42, 43, 47, 92, 94
  103.                'OK - operators: % * / \ ^              'Not allowed in first
  104.                IF x = 1 THEN EvalCode = 2              'position, adjacent to
  105.                IF y > 0 THEN EvalCode = 2              'another operator, or
  106.                IF x = LEN(f$) THEN EvalCode = 2        'in last position.
  107.           CASE ELSE
  108.                'NOT OK - is some other character!
  109.                EvalCode = 1
  110.      END SELECT
  111.      IF EvalCode > 0 THEN GOTO EvalErrorExit
  112.      z$ = y$                                      'Record the two previous
  113.      z = y                                        'characters and whether
  114.      y$ = x$                                      'they were an operator or
  115.      SELECT CASE ASC(y$)                          'a left parentheses.
  116.           CASE 40      'Left parentheses
  117.                y = 2
  118.           CASE 45, 37, 42, 43, 47, 92, 94
  119.                y = 1   'An operator
  120.           CASE ELSE
  121.                y = 0   'Something else
  122.      END SELECT
  123. NEXT x
  124.  
  125. y$ = "": y = 0: z = 0
  126. FOR x = 1 TO LEN(f$)                                   'Check for mismatched
  127.      x$ = MID$(f$, x, 1)                               ' parentheses: unequal
  128.      IF x$ = "(" THEN                                  ' numbers of each or
  129.           y = y + 1                                    ' ending with a left
  130.           y$ = x$                                      ' parentheses.
  131.      ELSEIF x$ = ")" THEN
  132.           z = z + 1
  133.           y$ = x$
  134.      END IF
  135. NEXT x
  136. IF y <> z OR y$ = "(" THEN EvalCode = 3: GOTO EvalErrorExit
  137.  
  138. '                 *** Evaluate between parentheses first ***
  139.  
  140. DO
  141.      start = 0
  142.      FOR x = 1 TO LEN(f$)
  143.           x$ = MID$(f$, x, 1)
  144.           IF x$ = "(" THEN                        'Find a complete pair.
  145.                start = x
  146.           ELSEIF x$ = ")" THEN
  147.                IF start = 0 THEN                  'Not allowed to have a )
  148.                     EvalCode = 3                  'without a ( !
  149.                     GOTO EvalErrorExit
  150.                END IF
  151.                y = x - start - 1                  'Extract the expression
  152.                mf$ = MID$(f$, start + 1, y)       'between the parentheses
  153.                lf$ = LEFT$(f$, start - 1)         'and recurse the function
  154.                rf$ = RIGHT$(f$, LEN(f$) - x)      'to get its value.  Then
  155.                mf$ = Evaluate$(mf$)               '(assuming no errors) put
  156.                IF LEFT$(mf$, 1) = "*" THEN        'the formula back together,
  157.                     Evaluate$ = mf$               'replacing the parentheses
  158.                     EXIT FUNCTION                 'with the value of the
  159.                END IF                             'expression.
  160.                f$ = lf$ + mf$ + rf$
  161.                EXIT FOR                           'Start at the beginning
  162.           END IF                                  ' of the formula again.
  163.      NEXT x
  164. LOOP UNTIL start = 0               'Loop until no more parentheses are found.
  165.  
  166. '                  *** Evaluate the rest of the formula ***
  167.  
  168. FOR pass = 1 TO 4                       'Make four passes through the
  169.      SELECT CASE pass                   ' formula, performing calculations
  170.           CASE 1                        ' in order of operator precedence.
  171.                op1$ = "^"
  172.                op2$ = "^"               'Exponentiation only first
  173.           CASE 2
  174.                op1$ = "*"               'Multiplication & Division second
  175.                op2$ = "/"
  176.           CASE 3
  177.                op1$ = "\"               'Integer and Modulus Division third
  178.                op2$ = "%"
  179.           CASE 4
  180.                op1$ = "+"               'Addition and Subtraction last
  181.                op2$ = "-"
  182.      END SELECT
  183.      DO
  184.           op = 0
  185.           FOR x = 1 TO LEN(f$)               'Search for desired operators.
  186.                x$ = MID$(f$, x, 1)
  187.                IF x$ = op1$ OR x$ = op2$ AND x > 1 THEN     'Beware of the
  188.                     op = x                                  ' leading minus!
  189.                     GOSUB EvalCalcs          'Found one!  Do the math and
  190.                     EXIT FOR                 'start from the beginning again.
  191.                END IF
  192.           NEXT x
  193.      LOOP UNTIL op = 0                  'Go through the formula until none of
  194. NEXT pass                               ' the specified operators are found.
  195.  
  196. Evaluate$ = f$                          'Return the boiled down formula.
  197. EXIT FUNCTION
  198.  
  199. '   *** The following section is where the values on either side of ***
  200. '   ***   the operator are parsed out and the actual math occurs.   ***
  201.  
  202. EvalCalcs:
  203.  
  204.      operator$ = MID$(f$, op, 1)        'Pull the operator.
  205.  
  206.      v1$ = "": lf = 1                   'Pull the first value:
  207.      FOR y = (op - 1) TO 1 STEP -1      'Look to the left of the operator
  208.           y$ = MID$(f$, y, 1)           ' one char at a time until the next
  209.           IF EvalNum(y$) THEN           ' operator (or beginning) is found.
  210.                v1$ = y$ + v1$           'Add the numeric character to the
  211.                lf = y                   ' first value and record position.
  212.           ELSEIF y$ <> "-" THEN
  213.                EXIT FOR                 'Found a non-minus operator - stop.
  214.           ELSEIF y$ = "-" THEN
  215.                IF y = 1 THEN
  216.                     v1$ = y$ + v1$      'Leading minus in first position.
  217.                     lf = 1              'Add it, record position and stop.
  218.                     EXIT FOR
  219.                ELSEIF EvalNum(MID$(f$, y - 1, 1)) THEN
  220.                     EXIT FOR            'Next char is a number - stop.
  221.                END IF                   '(We were checking for double negs.)
  222.           END IF
  223.      NEXT y
  224.                                         'Pull the second value:
  225.      v2$ = MID$(f$, op + 1, 1)          'Take the very next character in case
  226.      rf = op + 1                        ' it is a leading minus sign
  227.      FOR y = (op + 2) TO LEN(f$)        'Look to the right of the operator
  228.           y$ = MID$(f$, y, 1)           ' one char at a time until the next
  229.           IF EvalNum(y$) THEN           ' operator (or the end) is found.
  230.                v2$ = v2$ + y$           'Add the numeric character to the
  231.                rf = y                   'second value and record position.
  232.           ELSE
  233.                EXIT FOR                 'Next operator found - stop looking.
  234.           END IF
  235.      NEXT y
  236.  
  237.      ecode = 0                          'Prepare to trap any math errors.
  238.      ON ERROR GOTO EvalHandler
  239.      v1# = VAL(v1$)                     'Convert the strings into double-
  240.      v2# = VAL(v2$)                     ' precision values.
  241.      SELECT CASE operator$              'Perform the actual math depending on
  242.           CASE "+"                      ' the operator.
  243.                v# = v1# + v2#
  244.           CASE "-"
  245.                v# = v1# - v2#
  246.           CASE "*"
  247.                v# = v1# * v2#
  248.           CASE "/"
  249.                v# = v1# / v2#
  250.           CASE "\"
  251.                v# = v1# \ v2#
  252.           CASE "%"
  253.                v# = v1# MOD v2#
  254.           CASE "^"
  255.                v# = v1# ^ v2#
  256.      END SELECT
  257.      ON ERROR GOTO 0                    'Disable error trapping.
  258.      IF EvalCode > 0 THEN               'Exit if any errors occurred.
  259.           GOTO EvalErrorExit
  260.      END IF
  261.  
  262.      mf$ = LTRIM$(STR$(v#))             'Turn the result back into a string
  263.  
  264.      IF INSTR(mf$, "D") > 0 THEN        'Make sure value has not been
  265.           EvalCode = 6                  ' converted into scientific notation
  266.           GOTO EvalErrorExit            ' by QuickBasic's math routines
  267.      END IF                             ' becuase VAL() cant handle it (and I
  268.                                         ' don't care to deal with it just
  269.                                         ' yet!).
  270.   
  271.      lf$ = LEFT$(f$, lf - 1)            'Pull the strings from around the
  272.      rf$ = RIGHT$(f$, LEN(f$) - rf)     ' calculation and put them back
  273.      f$ = lf$ + mf$ + rf$               ' together, replacing the calculation
  274.                                         ' with its value.
  275.      RETURN
  276.  
  277. '     *** In case of an error, the error code is translated into a ***
  278. '     *** meaningful phrase and the function returns the message.  ***
  279.  
  280. EvalErrorExit:
  281.  
  282.      x$ = "* ERROR" + STR$(EvalCode) + " * "
  283.      SELECT CASE EvalCode
  284.           CASE 1
  285.                x$ = x$ + "Invalid character in position" + STR$(x) + ": " + f$
  286.           CASE 2
  287.                x$ = x$ + "Invalid placement of operator in position" + STR$(x) + ": " + f$
  288.           CASE 3
  289.                x$ = x$ + "Formula contains mismatched parentheses."
  290.           CASE 6
  291.                x$ = x$ + "Overflow - values too large or too small"
  292.           CASE 11
  293.                x$ = x$ + "Division by zero"
  294.           CASE ELSE
  295.                x$ = x$ + "Unexpected error"
  296.      END SELECT
  297.      Evaluate$ = x$                'Return a string beginning with * so the
  298.      EXIT FUNCTION                 ' user can easily determine if an error
  299.                                    ' occurred. i.e.: IF LEFT$(r$,1)="*"...
  300. END FUNCTION
  301.  
  302.