(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))))))
