(uiop:define-package :st-buchberger/src/parser
 (:nicknames :parser)
 (:export #:polynomial #:term #:term-monomial #:*zero-polynomial*
  #:term-coefficient #:monomial-indeterminates #:polynomial-terms
  #:parse-polynomial #:parse-term #:parse-coefficient
  #:parse-monomial #:parse-expt-symbol))

(in-package :st-buchberger/src/parser)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Grammar
;; =======
;;
;; polynomial  : term
;;             | "(" "-" term+ ")"
;;             | "(" "+" term* ")"
;;
;; term        : coefficient
;;             | monomial
;;             | "(" "*" coefficient monomial ")"
;;             | "(" "-" term ")"
;;
;; coefficient : rational
;;
;; monomial    : expt-symbol
;;             | "(" expt-symbol+ ")"
;;
;; expt-symbol : symbol
;;             | "(" "expt" symbol non-negative-integer ")"
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defstruct polynomial
  terms)

(defstruct term
  coefficient
  monomial)

(defstruct monomial
  "Association list whose keys are indeterminates (symbols) and the
corresponding values are the powers."
  indeterminates)

(defparameter *zero-polynomial*
  (make-polynomial :terms (list (make-term :coefficient 0
                                           :monomial (make-monomial
                                                      :indeterminates nil))))
  "Representation of the zero polynomial.")

(defun parse-polynomial (sexp)
  "Parse polynomial in SEXP."
  (cond
    ((null sexp)
     (error "Invalid expression: ~S." sexp))
    ((and (consp sexp) (eq (first sexp) '+))
     (if (zerop (length (rest sexp)))
         *zero-polynomial*
         (make-polynomial :terms (loop :for x :in (rest sexp)
                                       :collect (parse-term x)))))
    ((and (consp sexp) (eq (first sexp) '-))
     (case (length (rest sexp))
       (0 *zero-polynomial*)
       (1 (make-polynomial :terms (list (parse-term sexp))))
       (t (make-polynomial :terms (loop :for x :in (rest sexp)
                                        :for term := (parse-term x)
                                        :for i :from 0
                                        :when (plusp i) :do
                                          (setf (term-coefficient term)
                                                (- (term-coefficient term)))
                                        :collect term)))))
    (t (make-polynomial :terms (list (parse-term sexp))))))

(defun parse-term (sexp)
  "Parse term in SEXP."
  (cond
    ((atom sexp)
     (if (numberp sexp)
         (make-term :coefficient (parse-coefficient sexp)
                    :monomial (make-monomial :indeterminates nil))
         (make-term :coefficient 1 :monomial (parse-monomial sexp))))
    ((consp sexp)
     (destructuring-bind (first . rest) sexp
       (case first
         (* (let ((coeff (car rest)))
              (if (numberp coeff)
                  (make-term :coefficient (parse-coefficient coeff)
                             :monomial (parse-monomial (cdr rest)))
                  (make-term :coefficient 1
                             :monomial (parse-monomial rest)))))
         (- (let ((term (apply #'parse-term rest)))
              (setf (term-coefficient term) (- (term-coefficient term)))
              term))
         (t (make-term :coefficient 1
                       :monomial (parse-monomial sexp))))))))

(defun parse-coefficient (sexp)
  "Parse coefficient in SEXP."
  (unless (and (numberp sexp) (typep sexp 'rational))
    (error "Invalid coefficient: ~S." sexp))
  sexp)

(defun parse-monomial (sexp)
  "Parse monomial in SEXP."
  (make-monomial
   :indeterminates (if (atom sexp)
                       (list (parse-expt-symbol sexp))
                       (if (eq (car sexp) 'expt)
                           (list (parse-expt-symbol sexp))
                           (loop :for x :in sexp
                                 :collect (parse-expt-symbol x))))))

(defun parse-expt-symbol (sexp)
  "Parse (possibly exponentiated) symbol in SEXP."
  (flet ((error-invalid-expt-symbol (sexp)
           (error "Invalid (possibly exponentiated) symbol: ~S." sexp)))
    (cond
      ((atom sexp)
       (unless (symbolp sexp)
         (error-invalid-expt-symbol sexp))
       (cons sexp 1))
      (t
       (destructuring-bind (op symbol power) sexp
         (unless (and (eq op 'expt)
                      (symbolp symbol)
                      (typep power '(integer 0)))
           (error-invalid-expt-symbol sexp))
         (cons symbol power))))))