;;;; shunting.lisp

(in-package #:shunting)

;; wikipedia https://en.wikipedia.org/wiki/Shunting_yard_algorithm

;; Used to keep attributes for an operator, higher rank = more immediacy
;; in application

(defclass op-details ()
  ((rank       :initarg :rank       :reader rank       :initform 0)
   (fn         :initarg :fn         :reader fn)
   (left-assoc :initarg :left-assoc :reader left-assoc :initform t)
   (num-args   :initarg :num-args   :reader num-args   :initform 2)))

;; Function to skip the make-instance malarky
(defun make-op-details (&rest inits &key &allow-other-keys)
  (apply #'make-instance 'op-details inits))

;; Hash tables are cleaner with Alexandria but keeping it 0 dependency
(defparameter *operators-LOL*
  (let ((temp (make-hash-table :test 'eq)))
    (loop :for (key value)
            :in `((- ,(make-op-details :rank 0 :fn #'-))
                  (+ ,(make-op-details :rank 0 :fn #'+))
                  (/ ,(make-op-details :rank 1 :fn #'/))
                  (* ,(make-op-details :rank 1 :fn #'*))
                  (^ ,(make-op-details :rank 2 :fn #'expt :left-assoc nil)))
          :do (setf (gethash key temp) value))
    temp))

(defun operatorp (symbol)
  "If symbol is a member of the *operators-LOL* table's keys return true."
  (or (gethash symbol *operators-LOL*)))

;;; properties

(defun op-props (symbol)
  (assert (operatorp symbol))
  (gethash symbol *operators-LOL*))

(defun op-rank (symbol)
  (rank (op-props symbol)))

(defun op-fn(symbol)
  (fn (op-props symbol)))

(defun op-left-assoc (symbol)
  (left-assoc (op-props symbol)))

(defun op-num-args (symbol)
  (num-args (op-props symbol)))

;;; These two paren modifiers are for order of ops, using parens causes a mess
(defun left-paren-p (symbol)
  (eq symbol '[))

(defun right-paren-p (symbol)
  (eq symbol ']))

;;; Custom queue via Paul Graham
(defun make-queue () (cons nil nil))

(defun enqueue (obj q)
  (if (null (car q))
      (setf (cdr q) (setf (car q) (list obj)))
      (setf (cdr (cdr q)) (list obj)
            (cdr q) (cdr (cdr q))))
  (car q))

(defun dequeue (q)
  (pop (car q)))

(defun queue-to-list (q)
  (car q))

(defun RPN-eval (rpn-queue)
  (loop :with the-stack := nil
        :for token :in (queue-to-list rpn-queue)
        :for fn-args := nil
        :do (cond ((numberp token)
                   (push token the-stack))
                  ((operatorp token)
                   (dotimes (_ (op-num-args token))
                     (push (pop the-stack) fn-args))
                   (push (apply (op-fn token) fn-args) the-stack)))
        :finally (return (car the-stack))))

;; Direct translation from Wikipedia
;; It's uh ... stateful and whilish - hold my ALGOL
;; TODO break out logic for operatorp and right-paren-p
(defun infix-to-RPN (input)
  (loop :with output-queue := (make-queue)
        :with operator-stack := nil
        :for token :in input
        :do (cond ((numberp token) ; Numbers go on output
                   (enqueue token output-queue))
                  ((functionp token) ; Functions go on operator stack
                   (push token operator-stack))
                  ((operatorp token) ; Drain all higher ops into output
                   (loop :for op2 := (car operator-stack)
                         :while op2
                         :while (not (left-paren-p op2))
                         :while (let* ((token-rank (op-rank token))
                                       (op2-rank (op-rank op2))
                                       (token-left (op-left-assoc token)))
                                  (or (> op2-rank token-rank)
                                      (and (= op2-rank token-rank) token-left)))
                         :do (enqueue (pop operator-stack) output-queue))
                   (push token operator-stack))
                  ((left-paren-p token) ; Start grouping
                   (push '[ operator-stack))
                  ((right-paren-p token) ; Eval group backwards
                   (loop :while operator-stack
                         :for op2 := (car operator-stack)
                         :while (not (left-paren-p op2))
                         :do (assert (not (null operator-stack)))
                             (enqueue (pop operator-stack) output-queue))
                   (assert (left-paren-p (car operator-stack)))
                   (pop operator-stack)
                   (when (functionp (car operator-stack))
                     (enqueue (pop operator-stack) output-queue))))
        :finally (loop :while operator-stack
                       :do (enqueue (pop operator-stack) output-queue))
                 (return output-queue)))