Infix arithmetic evaluation in Scheme

infix.scm

#lang r5rs
(#%require schemeunit)

(define (any pred lst)
  (if (null? lst)
      #f
      (or (pred (car lst)) (any pred (cdr lst)))))

(define (list-contains? el lst)
  (any (lambda (el*) (equal? el el*)) lst))

; a list of lists of operators. lists are evaluated in order, so this also
; determines operator precedence
(define infix-operators
  (list
    (list modulo quotient remainder gcd lcm)
    (list * /)
    (list + -)
    ; now this is interesting: because scheme is dynamically typed, we aren't
    ; limited to any one type of function
    (list < > = <= >=)))

;;; evaluates `terms` as a basic infix expression
(define (! . terms)
  ; evaluate one group of operators in the list of terms
  (define (!** terms stack operators odd?)
    ; why `odd?`? because scheme's list-iteration is forwards-only and
    ; list-construction is prepend-only, every other group of operators is
    ; actually evaluated backwards which, for operators like / and -, can be a
    ; big deal! therefore, we keep this flipped `odd?` counter to track if we
    ; should flip our arguments or not
    (define (calc op a b)
      (if odd? (op a b) (op b a)))

    (cond ((null? terms) stack) ; base case
          ; operator we can evaluate -- pop operator and operand, then recurse
          ((and (> (length stack) 1) (list-contains? (car stack) operators))
           (let ((op (car stack))
                 (fst (car terms))
                 (snd (cadr stack)))
             (!** (cdr terms)
                  (cons (calc op fst snd) (cddr stack))
                  operators
                  (not odd?))))
          ; otherwise just keep building the stack
          (else (!** (cdr terms)
                     (cons (car terms) stack)
                     operators
                     (not odd?)))))

  ; evaluate a list of groups of operators in the list of terms
  (define (!* terms operator-groups odd?)
    (if (null? operator-groups)
        terms ; finished processing operator groups
        ; evaluate another group -- separating operators into groups allows
        ; operator precedence
        (!* (!** terms '() (car operator-groups) odd?)
            (cdr operator-groups)
            (not odd?))))

  (car (!* terms infix-operators #f)))

(check = (! 5 - 6)          -1)
(check = (! 2 * 3)           6)
(check = (! 2 * 3 + 2)       8)
(check = (! 2 * 3 + 4 * 5)  26)
(check = (! 0 - 4)          -4)
(check = (! 4 + 3 * 2 - 19) -9)

; also works for inequalities!
(check eq? (! 4 + 3 * 2 - 19 < 0 - 4) #t)
(check eq? (! -2 * 2 = 0 - 4)         #t)