;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: Grobner; Base: 10 -*-
#|
  *--------------------------------------------------------------------------*
  |  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 "INFIX-PRINTER"
  (:use "COMMON-LISP"
	"INFIX"				;for operator-lessp
	)
  (:export infix-print))

(in-package "INFIX-PRINTER")

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

(defun infix-print-separated-list (lst sep stream op print-level
				   &optional (alt-op nil) (alt-sep alt-op)
				   &aux
				   (beg t)
				   (count 0)
				   true-sep)
  (cond
   ((endp lst) nil)

   ;; Handle *print-level* 
   ((and (numberp *print-level*)
	 (> print-level *print-level*))
    (format stream "#"))

   (t
    (dolist (arg lst)
      (setf true-sep sep)
      (incf count)

      (when (and alt-op
		 (> count 1)
		 (consp arg)
		 (eq alt-op (car arg)))
	(setf arg (cadr arg)
	      true-sep alt-sep))
      (if beg
	  (setf beg nil)
	  (format stream "~a" true-sep))
      
      ;; If *print-length* exceeded, print ellipsis
      (when (and (numberp *print-length*) (> count *print-length*))
	(format stream "...")
	(return-from infix-print-separated-list (values)))
      
      (infix-print arg stream op print-level))))
  (values))

(defun infix-print-arg-list (lst stream print-level)
  "Print a comma-separated list."
  (infix-print-separated-list lst '\, stream '\, print-level))

(defun infix-print (expr &optional (stream t) (op nil) (print-level 0))
  "Print an expression EXPR in infix notation to stream STREAM.
If OP is not nil, the expression is parenthesized if its operator
has lower precedence than OP."
  (cond 
    ;; Handle *print-level*
   ((and (numberp *print-level*)
	 (> print-level *print-level*))
    (format stream "#"))

   ;; Null expression is an error
   ((null expr)
    (error "Null expression."))

   ;; Atoms are printed using ~A format directive
   ((atom expr)
    (format stream "~a" expr))
   
   ;; Check if the operator of this expression has lower precedence
   ;; than the surrounding operator, and parenthesize if necessary
   ((and op (operator-lessp (car expr) op))
    (format stream "(")
    (infix-print expr stream nil (1+ print-level))
    (format stream ")"))

   ;; Unary minus needs special handling
   ((and (eq (car expr) '-) (endp (cddr expr)))
    (format stream "-")
    ;; Print the second element in product context
    (infix-print (cadr expr) stream '* (1+ print-level)))

   ;; All other operators
   (t 
    (case (car expr)

      ;; Arithmetic operators
      ((+ - * /)
       (infix-print-separated-list
	(cdr expr)
	(car expr)
	stream
	(car expr)
	(1+ print-level)
	(cond ((eq (car expr) '+) '-)
	      ((eq (car expr) '-) '-)
	      (t nil))))

      ;; Exponentials
      (expt
       (unless (= (length (cdr expr)) 2)
	 (error "expt must take 2 arguments."))
       (infix-print-separated-list
	(cdr expr)
	'^
	stream
	'^
	(1+ print-level)))

      ;; Assuming function call
      (otherwise		
       (cond
	 ;; Handle array references
	 ((eq (car expr) 'aref)
	  ;; Special syntax for subscripted variables
	  ;; consistent with the infix package.
	  (format stream "~a[" (cadr expr))
	  (infix-print-separated-list (cddr expr) '\, stream '\, (1+ print-level))
	  (format stream "]"))

	 ;; Handle lists
	 ((and (symbolp (car expr))
	       (string= (symbol-name (car expr)) "["))
	  (format stream "[")
	  (infix-print-separated-list (cdr expr) '\, stream '\, (1+ print-level))
	  (format stream "]"))


	 ;; Handle generic function call syntax
	 (t

	  (format stream "~a(" (car expr))
	  (infix-print-arg-list (cdr expr) stream (1+ print-level))
	  (format stream ")")))))))
  (values))

(defun infix-print-to-string (expr &optional (op nil) (print-level 0) &aux fstr)
  (with-output-to-string (s fstr)
    (infix-print expr s op print-level))
  fstr)