;;; infix evaluator - jeremy english
;;;
;;; 1) Reverse the input string.
;;;
;;; 2) Examine the next element in the input.
;;;
;;; 3) If it is operand, add it to output string.
;;;
;;; 4) If it is Closing parenthesis, push it on stack.
;;;
;;; 5) If it is an operator, then
;;;
;;;      i) If stack is empty, push operator on stack.
;;;
;;;     ii) If the top of stack is closing parenthesis, push operator on
;;;         stack.
;;;
;;;    iii) If it has same or higher priority than the top of stack, push
;;;         operator on stack.
;;;
;;;     iv) Else pop the operator from the stack and add it to output
;;;         string, repeat step 5.
;;;
;;; 6) If it is a opening parenthesis, pop operators from stack and add
;;;    them to output string until a closing parenthesis is
;;;    encountered. Pop and discard the closing parenthesis.
;;;
;;; 7) If there is more input go to step 2
;;;
;;; 8) If there is no more input, unstack the remaining operators and add
;;;    them to output string.
;;;
;;; 9) Reverse the output string.

(defpackage "INFIX")
(in-package :infix)

(defun operatorp (c)
  (find c "+-*/"))

(defun grade (c)
  (if (or (char= c #\*) (char= c #\/)) 1 2))

(defun same-or-higher-priorityp (a b)
  (let ((score-a (grade a))
        (score-b (grade b)))
    (>= score-a score-b)))

(defun digit-period-p (c)
  (find c "1234567890."))

(defun split-by-one-space (string)
    "Returns a list of substrings of string
divided by ONE space each.
Note: Two consecutive spaces will be seen as
if there were an empty string between them."
    (loop for i = 0 then (1+ j)
          as j = (position #\Space string :start i)
          collect (subseq string i j)
          while j))

(defun split-on-space (s)
  (let ((l (split-by-one-space s)))
    (remove-if #'(lambda (x) (= (length x) 0)) l)))

(defun prefix->sexp (s)
  (let ((l (split-on-space s)))
        (labels ((convert (c)
                   (cond ((null c) nil)
                         ((operatorp (char c 0))
                          (concatenate 'string
                                       "(" c " "
                                       (convert (pop l)) " "
                                       (convert (pop l))
                                       ")"))
                         (t c))))
          (convert (pop l)))))

(Defun infix->prefix (s)
  (let ((rev (nreverse (coerce (space-infix-string s) 'list)))
        (output nil)
        (stack nil))

    (defun add-char (c)
      (let ((out
             (if (operatorp c)
                 (concatenate 'string " " (string c) " ")
                 (string c))))
          (setf output (concatenate 'string output out))))

    (labels ((process (rev)
;      (format t "X: ~a~%STACK: ~{~a ~}~%OUTPUT: ~a ~%" x stack output)
               (let ((x (car rev)))
                 (cond
                   ((null x) nil)
                   ((or (digit-period-p x) (char= x #\space))
                    (add-char x)
                    (process (cdr rev)))
                   ((char= x #\))
                    (push x stack)
                    (process (cdr rev)))
                   ((operatorp x)
                    (if (or (null stack)
                            (char= (first stack) #\))
                            (same-or-higher-priorityp x (first stack)))
                        (progn
                          (push x stack)
                          (process (cdr rev)))
                        (progn
                          (add-char (pop stack))
                          (process rev))))
                   ((char= x #\()
                    (do ((i (pop stack) (pop stack)))
                        ((char= i #\)))
                      (add-char i))
                    (process (cdr rev)))))))
      (process rev))
    (dolist (x stack)
      (add-char x))
    (nreverse output)))

(defun space-infix-string (s)
  (labels ((space-it (c l)
             (cond
               ((null c) (nreverse l))
               ((operatorp (car c))
                (space-it (cdr c)
                          (let ((m (cons #\space l)))
                            (cons (car c)  m))))
               (t (space-it (cdr c) (cons (car c) l))))))
     (coerce (space-it (coerce s 'list) nil) 'string)))

(defun infix->sexp (s)
  (prefix->sexp (infix->prefix s)))

(defmacro eval-infix (&rest body)
  `(eval
    (read-from-string
     (infix->sexp
      (format nil "~{~a~}" (quote ,body))))))