source: CGBLisp/trunk/src/printer.lisp@ 52

#|
        $Id: printer.lisp,v 1.3 2009/01/22 04:06:32 marek Exp $ 
  *--------------------------------------------------------------------------*
  |  Copyright (C) 1994, Marek Rychlik (e-mail: rychlik@math.arizona.edu)    |
  |    Department of Mathematics, University of Arizona, Tucson, AZ 85721    |
  |                                                                          |
  | Everyone is permitted to copy, distribute and modify the code in this    |
  | directory, as long as this copyright note is preserved verbatim.         |
  *--------------------------------------------------------------------------*
|#
(defpackage "PRINTER"
  (:export poly-print print-term print-monom)
  (:use "COMMON-LISP"))
  
(in-package "PRINTER")

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

(defun poly-print (plist vars &optional (stream t))
  "Prints a polynomial or  a list of polynomials PLIST using infix syntax compatible
with most software systems. The following data representations are assumed:
1) Polynomial list is ([ poly1 poly2 ...)
2) Polynomial is a list (term1 term2 ...)
3) Term is (monom . number)
4) Monom is (number1 number2 ...) and is a list of powers at corresponding 
variables
Variable names must be provided to the printer explicitly."
  (cond 
    ((and (symbolp (car plist)) (string= (symbol-name (car plist)) "["))
     (format stream "[ ")
     (poly-print-2 (rest plist) vars stream)
     (format stream " ]"))
    ;; Not a list but a single polynomial
    (t (poly-print-1 plist vars stream))))

(defun poly-print-1 (p vars &optional (stream t))
  "An auxillary function of POLY-PRINT. It prints a single polynomial P."
  (labels ((infix-sum (l &optional (beg t))
             (unless (endp l)
               (infix-term (first l) beg)
               (infix-sum (rest l) nil)))
           (infix-term (l &optional beg)
             (unless (zerop (cdr l))
               (case (cdr l)
                 (1 (unless beg (format stream " + "))
                    (infix-monom (first l) vars t))
                 (-1 (format stream " - ") (infix-monom (first l) vars t))
                 (otherwise
                  (cond
                    ((plusp (cdr l)) (unless beg (format stream " + ")))
                    ((minusp (cdr l)) (format stream " - ")))
                  (format stream "~d" (abs (cdr l)))
                  (infix-monom (first l) vars nil)))))
           (infix-monom (l vars &optional beg)
             (cond
               ((endp l) (when beg (format stream "~d" 1)))
               (t
                (unless (zerop (car l))
                  (unless beg (format stream " * "))
                  ;; if in x^n we have n=1 then print just x
                  (format stream "~a~:[^~d~;~*~]" (car vars)
                          (= (car l) 1) (car l)))
                (infix-monom (rest l) (rest vars) (and (zerop (car l)) beg)))
               )))
    (if (endp p)
        (format stream "0")
      (infix-sum p)))
  p)

(defun poly-print-2 (plist vars stream &optional (beg t))
  "An auxillary function of POLY-PRINT. It prints a comma-separated list of polynomials PLIST."
  (unless (endp plist)
    (unless beg (format stream ", "))
    (poly-print-1 (first plist) vars stream)
    (poly-print-2 (rest plist) vars stream nil)))


(defun print-term (l vars &optional (stream t) beg)
  "An auxillary function of POLY-PRINT. It prints a single term L."
  (unless (zerop (cdr l))
    (case (cdr l)
      (1 (unless beg (format stream " + "))
         (print-monom (first l) vars stream t))
      (-1 (format stream " - ") (print-monom (first l) vars stream t))
      (otherwise
       (cond
        ((plusp (cdr l)) (unless beg (format stream " + ")))
        ((minusp (cdr l)) (format stream " - ")))
       (format stream "~d" (abs (cdr l)))
       (print-monom (first l) vars stream nil)))))

(defun print-monom (l vars &optional (stream t) beg)
  "An auxillary function of POLY-PRINT. It prints a single monomial L."
  (cond
   ((endp l) (when beg (format stream "~d" 1)))
   (t
    (unless (zerop (car l))
      (unless beg (format stream " * "))
      ;; if in x^n we have n=1 then print just x
      (format stream "~a~:[^~d~;~*~]" (car vars)
              (= (car l) 1) (car l)))
    (print-monom (rest l) (rest vars) stream (and (zerop (car l)) beg)))
   ))