;; Calculadora RPN
;; 2004jun24

(setq pilha ())
(setq mostra nil)

(defun poe  (obj) (setq pilha (cons obj pilha)))
(defun tira ()    (prog1 (car pilha) (setq pilha (cdr pilha))))

(setq operacoes
      '((+ . (poe (+ (tira) (tira))))
	(* . (poe (* (tira) (tira))))
	(- . (let ((arg2 (tira)) (arg1 (tira))) (poe (- arg1 arg2))))
	(/ . (let ((arg2 (tira)) (arg1 (tira))) (poe (/ arg1 arg2))))
	(sqrt . (poe (sqrt (tira))))
	(-> . (set (car args-extras) (tira)))
	))

(defun operacaop (simbolo) (assoc simbolo operacoes))
(defun operacao (simbolo) (cdr (assoc simbolo operacoes)))

(defun calcula (ops)
  (while ops
    (setq op  (car ops))
    (setq ops (cdr ops))
    (cond ((numberp op) (poe op))	            ; exemplo: 2
	  ((and (symbolp op) (operacaop op))        ; exemplo: +
	   (setq args-extras nil)
	   (eval (operacao op)))
	  ((and (symbolp op) (boundp op))           ; exemplo: pi
	   (poe (symbol-value op)))
	  ((and (listp op) op (operacaop (car op))) ; exemplo: (-> a)
	   (setq args-extras (cdr op))
	   (eval (operacao (car op))))
	  (t (error "Nao sei executar: %S" op)))
    (if mostra (insert (format "%S\n" (reverse pilha)))))
  pilha)

(setq operacoes-lisp
      '((+ . (let ((arg2 (tira)) (arg1 (tira))) (poe (list '+ arg1 arg2))))
	(* . (let ((arg2 (tira)) (arg1 (tira))) (poe (list '* arg1 arg2))))
	(- . (let ((arg2 (tira)) (arg1 (tira))) (poe (list '- arg1 arg2))))
	(/ . (let ((arg2 (tira)) (arg1 (tira))) (poe (list '/ arg1 arg2))))
	(sqrt . (poe (list 'sqrt (tira))))
	))

(setq operacoes-arit
      '((+ . (let ((arg2 (tira)) (arg1 (tira))) (poe (list arg1 '+ arg2))))
	(* . (let ((arg2 (tira)) (arg1 (tira))) (poe (list arg1 '* arg2))))
	(- . (let ((arg2 (tira)) (arg1 (tira))) (poe (list arg1 '- arg2))))
	(/ . (let ((arg2 (tira)) (arg1 (tira))) (poe (list arg1 '/ arg2))))
	(sqrt . (poe (list 'sqrt (tira))))
	))

(defun calcula-lisp (ops)
  (let ((operacoes operacoes-lisp))
    (calcula ops)))

(defun calcula-arit (ops)
  (let ((operacoes operacoes-arit))
    (calcula ops)))

;; (setq mostra t)
;; (setq mostra nil)

(progn
  (setq pilha ())
  (calcula-arit '(1 5 sqrt + 2 /))
  (car pilha))

(progn
  (setq pilha ())
  (calcula-lisp '(1 5 sqrt + 2 /))
  (setq expr (car pilha)))

;; expr
;; (eval expr)

(progn
  (setq pilha ())
  (calcula '(5 5 * 4 4 * - sqrt)))

(setq args-extras nil)