;;; Copyright © 2006 Jeremy English <jhe@jeremyenglish.org>
;;;
;;; Permission to use, copy, modify, distribute, and sell this software and its
;;; documentation for any purpose is hereby granted without fee, provided that
;;; the above copyright notice appear in all copies and that both that
;;; copyright notice and this permission notice appear in supporting
;;; documentation.  No representations are made about the suitability of this
;;; software for any purpose.  It is provided "as is" without express or
;;; implied warranty.
;;;
;;; Created: 06-September-2006

;; A functional, as in paradigm, version of the infix calculator from
;; "Compiler Construction by Niklaus Wirth"

(defpackage "INFIX-CALC"
  (:use "CL")
  (:export "CALCULATE"))

(in-package :infix-calc)

(defun it-char= (a b)
    "Ignore Type Character Equal - A version of character equal that
will return false if the value passed is not a character"
    (if (and (characterp a) (characterp b))
        (char= a b)
        nil))

(defun char-spacep (x)
  (it-char= x #\space))

;;Scanner
(defun expression-to-list (char-list &optional id l)
  "Returns the expression with each token as an atom of a list."
           (cond
             ((null char-list)
              (if (> (length id) 0)
                  (let ((l2 (cons (read-from-string id) l)))
                    (remove-if #'char-spacep
                               (nreverse l2)))
                  (remove-if #'char-spacep
                             (nreverse l))))
             ((or
               (digit-char-p (car char-list))
               (char= (car char-list) #\.))
              (expression-to-list
               (cdr char-list)
               (concatenate 'string id (string (car char-list)))
               l))
             (t
              (expression-to-list
               (cdr char-list)
               ""
               (if (> (length id) 0)
                   (let ((l2 (cons (read-from-string id) l)))
                     (cons (car char-list) l2))
                   (cons (car char-list) l))))))



;;;  exp(v0) = term(v1) |
;;;      exp(v1) "+" term(v2) |
;;;      exp(v1) "-" term(v2).
;;;
;;;  term(v0) = factor(v1) |
;;;      term(v1) "*" factor(v2) |
;;;      term(v1) "/" factor(v2).
;;;
;;;  factor(v0) = number(v1) |
;;;      "(" exp(v1) ")".

;;Parser
(defun factor (scan)
  (if (numberp (car scan))
      (values (car scan) (cdr scan))
      (if (it-char= (car scan) #\()
          (progn
            (multiple-value-bind (val1 scan1)
                (expression (cdr scan))
              (if (it-char= (car scan1) #\))
                  (values val1 (cdr scan1))
                  (error
                   (format nil
                           "Expected a closing bracket got ~a"
                           (car scan1))))))
          (error "Expression Expected"))))

(defun term (scan0)
  (multiple-value-bind (val1 scan1)
      (factor scan0)
    (if (it-char= (car scan1) #\*)
        (multiple-value-bind (val2 scan2)
            (factor (cdr scan1))
          (term (cons (* val1 val2) scan2)))
        (if (it-char= (car scan1) #\/)
            (multiple-value-bind (val2 scan2)
                (factor (cdr scan1))
              (term (cons (/ val1 val2) scan2)))
            (values val1 scan1)))))

(defun expression (scan0)
  (multiple-value-bind (val1 scan1)
      (term scan0)
    (if (it-char= (car scan1) #\+)
        (multiple-value-bind (val2 scan2)
            (term (cdr scan1))
          (expression (cons (+ val1 val2) scan2)))
        (if (it-char= (car scan1) #\-)
            (multiple-value-bind (val2 scan2)
                (term (cdr scan1))
              (expression (cons (- val1 val2) scan2)))
            (values val1 scan1)))))

;; (defun calculate (s)
;;   (expression (expression-to-list (coerce s 'list) "" nil)))

(defmacro calculate (&rest body)
  `(expression
    (expression-to-list
     (coerce
      (format nil "~{~a~}" (quote ,body)) 'list))))