source: branches/f4grobner/symbolic-polynomial.lisp@ 4026

;;; -*-  Mode: Lisp -*- 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                                                                              
;;;  Copyright (C) 1999, 2002, 2009, 2015 Marek Rychlik <rychlik@u.arizona.edu>          
;;;                                                                              
;;;  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 2 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, write to the Free Software                 
;;;  Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.  
;;;                                                                              
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defpackage "SYMBOLIC-POLYNOMIAL"
  (:use :cl :utils :monom :polynomial :infix :infix-printer)
  (:export "SYMBOLIC-POLY" "READ-INFIX-FORM" "STRING->POLY" "POLY->STRING" "->INFIX")
  (:documentation "Implements symbolic polynomials. A symbolic
polynomial is polynomial which uses symbolic variables for reading and
printing in standard human-readable (infix) form."))

(in-package :symbolic-polynomial)

(defclass symbolic-poly (poly)
  ((vars :initform nil 
         :initarg :vars 
         :accessor symbolic-poly-vars)
   )
  (:default-initargs :termlist nil :vars nil))

(defmethod print-object ((self symbolic-poly) stream)
  (print-unreadable-object (self stream :type t :identity t)
    (with-accessors ((dimension poly-dimension)
                     (termlist poly-termlist) 
                     (order poly-term-order)
                     (vars symbolic-poly-vars))
        self
      (format stream "DIMENSION=~A TERMLIST=~A ORDER=~A VARS=~A" 
              dimension termlist order vars))))


(defmethod universal-equalp ((self symbolic-poly) (other symbolic-poly))
  (when (universal-equalp (symbolic-poly-vars self) (symbolic-poly-vars other))
    (call-next-method)))

(defmethod universal-equalp ((self symbol) (other symbol))
  (eq self other))

(defmethod update-instance-for-different-class :after ((old poly) (new  symbolic-poly) &key)
  "After adding variables to NEW, we need to make sure that the number
of variables given by POLY-DIMENSION is consistent with VARS."
  (assert (= (length (symbolic-poly-vars new)) (poly-dimension new))))


#|
(defun poly-eval-scalar (expr 
                         &aux 
                           (order #'lex>))
  "Evaluate a scalar expression EXPR in ring RING."
  (declare (type ring ring))
  (poly-lc (poly-eval expr nil ring order)))
|#


(defun read-infix-form (&key (stream t))
  "Parser of infix expressions with integer/rational coefficients
The parser will recognize two kinds of polynomial expressions:

- polynomials in fully expanded forms with coefficients
  written in front of symbolic expressions; constants can be optionally
  enclosed in (); for example, the infix form
        X^2-Y^2+(-4/3)*U^2*W^3-5
  parses to
        (+ (- (EXPT X 2) (EXPT Y 2)) (* (- (/ 4 3)) (EXPT U 2) (EXPT W 3)) (- 5))

- lists of polynomials; for example
        [X-Y, X^2+3*Z]          
  parses to
          (:[ (- X Y) (+ (EXPT X 2) (* 3 Z)))
  where the first symbol [ marks a list of polynomials.

-other infix expressions, for example
        [(X-Y)*(X+Y)/Z,(X+1)^2]
parses to:
        (:[ (/ (* (- X Y) (+ X Y)) Z) (EXPT (+ X 1) 2))
Currently this function is implemented using M. Kantrowitz's INFIX package."
  (read-from-string
   (concatenate 'string
                "#I(" 
                (with-output-to-string (s)
                  (loop
                     (multiple-value-bind (line eof)
                         (read-line stream t)
                       (format s "~A" line)
                       (when eof (return)))))
                ")")))

(defun read-poly (vars &key
                         (stream t) 
                         (order #'lex>))
  "Reads an expression in prefix form from a stream STREAM.
The expression read from the strem should represent a polynomial or a
list of polynomials in variables VARS, over the ring RING.  The
polynomial or list of polynomials is returned, with terms in each
polynomial ordered according to monomial order ORDER."
  (poly-eval (read-infix-form :stream stream) vars order))

(defun string->poly (str vars 
                     &optional
                       (order #'lex>))
  "Converts a string STR to a polynomial in variables VARS."
  (with-input-from-string (s str)
    (change-class (read-poly vars :stream s :order order) 'symbolic-poly :vars vars)))

(defun poly->alist (p)
  "Convert a polynomial P to an association list. Thus, the format of the
returned value is  ((MONOM[0] . COEFF[0]) (MONOM[1] . COEFF[1]) ...), where
MONOM[I] is a list of exponents in the monomial and COEFF[I] is the
corresponding coefficient in the ring."
  (cond
    ((poly-p p)
     (mapcar #'->list (poly-termlist p)))
    ((and (consp p) (eq (car p) :[))
     (cons :[ (mapcar #'poly->alist (cdr p))))))

(defun string->alist (str vars
                      &optional
                        (order #'lex>))
  "Convert a string STR representing a polynomial or polynomial list to
an association list (... (MONOM . COEFF) ...)."
  (poly->alist (string->poly str vars order)))

(defun poly-equal-no-sugar-p (p q)
  "Compare polynomials for equality, ignoring sugar."
  (declare (type poly p q))
  (equalp (poly-termlist p) (poly-termlist q)))

(defun poly-set-equal-no-sugar-p (p q)
  "Compare polynomial sets P and Q for equality, ignoring sugar."
  (null (set-exclusive-or  p q :test #'poly-equal-no-sugar-p )))

(defun poly-list-equal-no-sugar-p (p q)
  "Compare polynomial lists P and Q for equality, ignoring sugar."
  (every #'poly-equal-no-sugar-p p q))

(defmethod ->sexp :around ((self symbolic-poly) &optional (vars (symbolic-poly-vars self)))
  "Convert a symbolic polynomial SELF to infix form, using variables VARS. The default
value of VARS is the corresponding slot value of SELF."
  (call-next-method self vars))

(defgeneric poly->string (self &optional vars)
  (:documentation "Render polynomial SELF as a string, using symbolic variables VARS.")
  (:method ((self poly) &optional (vars nil))
    ;; Ensure that the number of variables matches the dimension
    (assert (= (length vars) (poly-dimension self)))
    (infix-print (->sexp self vars)))
  (:method ((self symbolic-poly) &optional (vars (symbolic-poly-vars self)))
    (infix-print (->sexp self vars))))