source: branches/f4grobner/parse.lisp@ 1013

;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: Grobner; Base: 10 -*-

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                                                                              
;;;  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.  
;;;                                                                              
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Parser of infix notation. This package enables input
;; of polynomials in human-readable notation outside of Maxima,
;; which is very useful for debugging.
;;
;; NOTE: This package is adapted from CGBLisp.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defpackage "PARSE"
  (:use :cl :order :monom :term :polynomial :ring)
  (:export "PARSE PARSE-TO-ALIST" "PARSE-STRING-TO-ALIST" 
           "PARSE-TO-SORTED-ALIST" "PARSE-STRING-TO-SORTED-ALIST" "^" "["
           "POLY-EVAL"
           ))

(in-package "PARSE")

(proclaim '(optimize (speed 0) (space 0) (safety 3) (debug 3)))

;; The function PARSE yields the representations as above.  The two functions
;; PARSE-TO-ALIST and PARSE-STRING-TO-ALIST parse polynomials to the alist
;; representations. For example
;;
;; >(parse)x^2-y^2+(-4/3)*u^2*w^3-5 --->
;; (+ (* 1 (^ X 2)) (* -1 (^ Y 2)) (* -4/3 (^ U 2) (^ W 3)) (* -5))
;;
;; >(parse-to-alist '(x y u w))x^2-y^2+(-4/3)*u^2*w^3-5 --->
;; (((0 0 2 3) . -4/3) ((0 2 0 0) . -1) ((2 0 0 0) . 1) ((0 0 0 0) . -5))
;;
;; >(parse-string-to-alist "x^2-y^2+(-4/3)*u^2*w^3-5" '(x y u w)) --->
;; (((0 0 2 3) . -4/3) ((0 2 0 0) . -1) ((2 0 0 0) . 1) ((0 0 0 0) . -5))
;;
;; >(parse-string-to-alist "[x^2-y^2+(-4/3)*u^2*w^3-5,y]" '(x y u w))
;; ([ (((0 0 2 3) . -4/3) ((0 2 0 0) . -1) ((2 0 0 0) . 1)
;;     ((0 0 0 0) . -5))
;;    (((0 1 0 0) . 1)))
;; The functions PARSE-TO-SORTED-ALIST and PARSE-STRING-TO-SORTED-ALIST
;; in addition sort terms by the predicate defined in the ORDER package
;; For instance:
;; >(parse-to-sorted-alist '(x y u w))x^2-y^2+(-4/3)*u^2*w^3-5
;; (((2 0 0 0) . 1) ((0 2 0 0) . -1) ((0 0 2 3) . -4/3) ((0 0 0 0) . -5))
;; >(parse-to-sorted-alist '(x y u w) t #'grlex>)x^2-y^2+(-4/3)*u^2*w^3-5
;; (((0 0 2 3) . -4/3) ((2 0 0 0) . 1) ((0 2 0 0) . -1) ((0 0 0 0) . -5))

;;(eval-when (compile)
;;  (proclaim '(optimize safety)))

(defun convert-number (number-or-poly n)
  "Returns NUMBER-OR-POLY, if it is a polynomial. If it is a number,
it converts it to the constant monomial in N variables. If the result
is a number then convert it to a polynomial in N variables."
  (if (numberp number-or-poly)
      (make-poly-from-termlist (list (make-term (make-monom :dimension n) number-or-poly)))
      number-or-poly))

(defun $poly+ (ring-and-order p q n)
  "Add two polynomials P and Q, where each polynomial is either a
numeric constant or a polynomial in internal representation. If the
result is a number then convert it to a polynomial in N variables."
  (poly-add ring-and-order (convert-number p n) (convert-number q n)))

(defun $poly- (ring-and-order p q n)
  "Subtract two polynomials P and Q, where each polynomial is either a
numeric constant or a polynomial in internal representation. If the
result is a number then convert it to a polynomial in N variables."
  (poly-sub ring-and-order (convert-number p n) (convert-number q n)))

(defun $minus-poly (ring p n)
  "Negation of P is a polynomial is either a numeric constant or a
polynomial in internal representation. If the result is a number then
convert it to a polynomial in N variables."
  (poly-uminus ring (convert-number p n)))

(defun $poly* (ring-and-order p q n)
  "Multiply two polynomials P and Q, where each polynomial is either a
numeric constant or a polynomial in internal representation. If the
result is a number then convert it to a polynomial in N variables."
  (poly-mul ring-and-order (convert-number p n) (convert-number q n)))

(defun $poly/ (ring p q)
  "Divide a polynomials P which is either a numeric constant or a
polynomial in internal representation, by a number Q."
  (if (numberp p)
      (common-lisp:/ p q)
      (scalar-times-poly ring (common-lisp:/ q) p)))
    
(defun $poly-expt (ring-and-order p l n)
  "Raise polynomial P, which is a polynomial in internal
representation or a numeric constant, to power L. If P is a number,
convert the result to a polynomial in N variables."
  (poly-expt ring-and-order (convert-number p n) l))

(defun parse (&optional stream)
  "Parser of infis 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)))))
     ")")))

;; Translate output from parse to a pure list form
;; assuming variables are VARS

(defun alist-form (plist vars)
  "Translates an expression PLIST, which should be a list of polynomials
in variables VARS, to an alist representation of a polynomial.
It returns the alist. See also PARSE-TO-ALIST."
  (cond
   ((endp plist) nil)
   ((eql (first plist) '[)
    (cons '[ (mapcar #'(lambda (x) (alist-form x vars)) (rest plist))))
   (t
    (assert (eql (car plist) '+))
    (alist-form-1 (rest plist) vars))))

(defun alist-form-1 (p vars
                         &aux (ht (make-hash-table
                                   :test #'equal :size 16))
                         stack)
  (dolist (term p)
    (assert (eql (car term) '*))
    (incf  (gethash (powers (cddr term) vars) ht 0) (second term)))
  (maphash #'(lambda (key value) (unless (zerop value)
                                   (push (cons key value) stack))) ht)
  stack)
    
(defun powers (monom vars
                     &aux (tab (pairlis vars (make-list (length vars)
                                                        :initial-element 0))))
  (dolist (e monom (mapcar #'(lambda (v) (cdr (assoc v tab))) vars))
    (assert (equal (first e) '^))
    (assert (integerp (third e)))
    (assert (= (length e) 3))
    (let ((x (assoc (second e) tab)))
      (if (null x) (error "Variable ~a not in the list of variables." 
                         (second e))
        (incf (cdr x) (third e))))))
  

;; New implementation based on the INFIX package of Mark Kantorowitz
(defun parse-to-alist (vars &optional stream)
  "Parse an expression already in prefix form to an association list form
according to the internal CGBlisp polynomial syntax: a polynomial is an
alist of pairs (MONOM . COEFFICIENT). For example:
  (WITH-INPUT-FROM-STRING (S \"X^2-Y^2+(-4/3)*U^2*W^3-5\")
        (PARSE-TO-ALIST '(X Y U W) S))
evaluates to
(((0 0 2 3) . -4/3) ((0 2 0 0) . -1) ((2 0 0 0) . 1) ((0 0 0 0) . -5))"
  (poly-eval (parse stream) vars))


(defun parse-string-to-alist (str vars)
  "Parse string STR and return a polynomial as a sorted association
list of pairs (MONOM . COEFFICIENT). For example:
(parse-string-to-alist \"[x^2-y^2+(-4/3)*u^2*w^3-5,y]\" '(x y u w))
 ([ (((0 0 2 3) . -4/3) ((0 2 0 0) . -1) ((2 0 0 0) . 1)
     ((0 0 0 0) . -5))
    (((0 1 0 0) . 1)))
The functions PARSE-TO-SORTED-ALIST and PARSE-STRING-TO-SORTED-ALIST
sort terms by the predicate defined in the ORDER package."
  (with-input-from-string (stream str)
    (parse-to-alist vars stream)))


(defun parse-to-sorted-alist (vars &optional (order #'lex>) (stream t))
  "Parses streasm STREAM and returns a polynomial represented as 
a sorted alist. For example:
(WITH-INPUT-FROM-STRING (S \"X^2-Y^2+(-4/3)*U^2*W^3-5\")
  (PARSE-TO-SORTED-ALIST '(X Y U W) S))
returns
(((2 0 0 0) . 1) ((0 2 0 0) . -1) ((0 0 2 3) . -4/3) ((0 0 0 0) . -5))
and
(WITH-INPUT-FROM-STRING (S \"X^2-Y^2+(-4/3)*U^2*W^3-5\")
  (PARSE-TO-SORTED-ALIST '(X Y U W) T #'GRLEX>) S)
returns
(((0 0 2 3) . -4/3) ((2 0 0 0) . 1) ((0 2 0 0) . -1) ((0 0 0 0) . -5))"
  (sort-poly (parse-to-alist vars stream) order))

(defun parse-string-to-sorted-alist (str vars &optional (order #'lex>))
  "Parse a string to a sorted alist form, the internal representation
of polynomials used by our system."
  (with-input-from-string (stream str)
    (parse-to-sorted-alist vars order stream)))

(defun sort-poly-1 (p order)
  "Sort the terms of a single polynomial P using an admissible monomial order ORDER.
Returns the sorted polynomial. Destructively modifies P."
  (sort p order :key #'first))

;; Sort a polynomial or polynomial list
(defun sort-poly (poly-or-poly-list &optional (order #'lex>))
  "Sort POLY-OR-POLY-LIST, which could be either a single polynomial
or a list of polynomials in internal alist representation, using
admissible monomial order ORDER. Each polynomial is sorted using
SORT-POLY-1."
  (cond
   ((eql poly-or-poly-list :syntax-error) nil)
   ((null poly-or-poly-list) nil)
   ((eql (car poly-or-poly-list) '[)
    (cons '[ (mapcar #'(lambda (p) (sort-poly-1 p order)) 
                     (rest poly-or-poly-list))))
   (t (sort-poly-1 poly-or-poly-list order))))

(defun poly-eval-1 (ring-and-order expr vars
                    &aux
                      (ring (ro-ring ring-and-order))
                      (n (length vars))
                      (basis (monom-basis (length vars))))
  "Evaluate an expression EXPR as polynomial by substituting operators
+ - * expt with corresponding polynomial operators and variables VARS
with monomials (1 0 ... 0), (0 1 ... 0) etc.  We use special versions
of binary operators $poly+, $poly-, $minus-poly, $poly* and $poly-expt
which work like the corresponding functions in the POLY package, but
accept scalars as arguments as well."
  (cond
    ((numberp expr)
     (cond
       ((zerop expr) NIL)
       (t (make-poly-from-termlist (list (make-monom :dimension n) expr)))))
    ((symbolp expr)
     (make-monom :initial-exponents (nth (position expr vars) basis)) )
    ((consp expr)
     (case (car expr)
       (expt
        (if (= (length expr) 3)
            ($poly-expt (poly-eval-1 ring-and-order (cadr expr) vars)
                        (caddr expr)
                        n)
            (error "Too many arguments to EXPT")))
       (/
        (if (and (= (length expr) 3)
                 (numberp (caddr expr)))
            ($poly/ ring (cadr expr) (caddr expr))
            (error "The second argument to / must be a number")))
       (otherwise
        (let ((r (mapcar
                  #'(lambda (e) (poly-eval-1 ring-and-order e vars))
                  (cdr expr))))
          (ecase (car expr)
            (+ (reduce #'(lambda (p q) ($poly+ ring-and-order p q n)) r))
            (-
             (if (endp (cdr r))
                 ($minus-poly ring (car r) n)
                 ($poly- ring-and-order
                         (car r)
                         (reduce #'(lambda (p q) ($poly+ ring-and-order p q n)) (cdr r))
                         n)))
            (*
             (reduce #'(lambda (p q) ($poly* ring-and-order p q n)) r))
            )))))))

             
(defun poly-eval (expr vars 
                  &optional (order #'lex>) (ring *coefficient-ring*)
                  &aux 
                    (ring-and-order (make-ring-and-order ring order)))
  "Evaluate an expression EXPR, which should be a polynomial
expression or a list of polynomial expressions (a list of expressions
marked by prepending keyword :[ to it) given in lisp prefix notation,
in variables VARS, which should be a list of symbols. The result of
the evaluation is a polynomial or a list of polynomials (marked by
prepending symbol '[) in the internal alist form. This evaluator is
used by the PARSE package to convert input from strings directly to
internal form."
  (cond
   ((numberp expr)
    (unless (zerop expr)
      (make-poly-from-termlist 
       (list (make-term (make-monom :dimension (length vars)) expr)))))
   ((or (symbolp expr) (not (eq (car expr) :[)))
    (poly-eval-1 ring-and-order expr vars))
   (t (cons '[ (mapcar #'(lambda (p) (poly-eval-1 ring-and-order p vars)) (rest expr))))))


;; Return the standard basis of the monomials in n variables
(defun monom-basis (n &aux
                      (basis
                       (copy-tree
                        (make-list n :initial-element
                                   (list (cons
                                          (make-list
                                           n
                                           :initial-element 0)
                                          1))))))
  "Generate a list of monomials ((1 0 ... 0) (0 1 0 ... 0) ... (0 0 ... 1)
which correspond to linear monomials X1, X2, ... XN."
  (dotimes (i n basis)
    (setf (elt (caar (elt basis i)) i) 1)))