; Copyright (C) 2014 by Alexandru Cojocaru

; This program is free software: you can redistribute it and/or modify
; it under the terms of the GNU General Public License as published by
; the Free Software Foundation, either version 3 of the License, or
; (at your option) any later version.

; This program is distributed in the hope that it will be useful,
; but WITHOUT ANY WARRANTY; without even the implied warranty of
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
; GNU General Public License for more details.

; You should have received a copy of the GNU General Public License
; along with this program.  If not, see <http://www.gnu.org/licenses/>.


(use-modules (ice-9 eval-string) (ice-9 rdelim) (rnrs io ports))

(define (next-token)
  (let ((t (read-delimited " ")))
    (if (eof-object? t)
        ""
        t)))

(define precassoc (list `(^ . (4 right ,expt))
                        `(* . (3 left ,*))
                        `(/ . (3 left ,/))
                        `(+ . (2 left ,+))
                        `(- . (2 left ,-))))

(define (opprec op)
  (cond ((assoc op precassoc) => cadr)))
(define (opassoc op)
  (cond ((assoc op precassoc) => caddr)))
(define (opfun op)
  (cond ((assoc op precassoc) => cadddr)))
(define (opdefined? op)
  (assoc op precassoc))


(define (shunting-yard)
  (let l ((outq '()) (opst '()))
    (let ((t (next-token)))
      (let ((et (false-if-exception (with-input-from-string t read))))
        (cond
         ((number? et)
          (l (cons et outq) opst))
         ((symbol? et)
          (if (not (opdefined? et))
              (error "unknown operator" et)
              (let l2 ((outq outq) (opst opst))
                (let ((o1 et) (o2 (false-if-exception (car opst))))
                  (if (and o2
                           (or
                            (and (eqv? (opassoc o1) 'left) (= (opprec o1) (opprec o2)))
                            (< (opprec o1) (opprec o2))))
                      (l2 (cons o2 outq) (cdr opst))
                      (l outq (cons o1 opst)))))))
         ((string=? t "(")
          (l outq (cons #\( opst)))
         ((string=? t ")")
          (let l2 ((outq outq) (opst opst))
            (let ((op (false-if-exception (car opst))))
              (if op
                  (if (not (equal? op #\())
                      (l2 (cons op outq) (cdr opst))
                      (l outq (cdr opst)))
                  (error "mismatched right parenthesis")))))
         ((eof-object? et)
          (let l2 ((outq outq) (opst opst))
            (if (null? opst)
                (reverse outq)
                (let ((op (car opst)))
                  (if (equal? op #\()
                      (error "mismatched left parenthesis")
                      (l2 (cons op outq) (cdr opst)))))))
         (else
          (error "unknown token" t)))))))


(define (rpn-eval q)
  (let l ((q q) (st '()))
    (if (null? q)
        (if (not (null? (cdr st)))
            (error "more than one element left on stack")
            (car st))
        (let ((t (car q)))
          (cond
           ((number? t)
            (l (cdr q) (cons t st)))
           ((symbol? t)
            (let ((o2 (car st)) (o1 (cadr st)))
              (l (cdr q) (cons ((opfun t) o1 o2) (cddr st)))))
           (else (error "unknown token" t)))))))

(define (calc-eval str)
  (rpn-eval (with-input-from-string str shunting-yard)))

;; try
;; (calc-eval "5 - 3 + 1") => 3
;; (calc-eval "5 ^ 5 * 2") => 6250