From: Srinivas Palthepu
Subject: Prefix <==> Infix Symbolic expressioons.
Date: 
Message-ID: <1991Nov1.073746.5497@ncst.ernet.in>
In Article 1202 of comp.lang.lisp: ·······@unccvax.uncc.edu (m. mcknight)
Writes:

+ Continuing with my project I have encountered yet another problem.  I need to
+ take lists in the LISP prefix notation and convert them into a more normal
+ english type notation.  This only has to work with math formulas.  
+ For Example:
+ 
+     (prefix-to-infix  '(+ a (* b c)))
+ 
+ would return: A+(B*C)
+ 
+     (+ (* (/ x (- y 3)) 5 z)
+ 
+ would return: x/(y+3)*5+z
+ 
+ Notice how the extra ()'s need to be deleted and there aren't any spaces in
+ the output.

+If anyone can shed some light on this for me I would greatly appreciate it.
+Any suggestion or actual code can be used.  Thanks.

Here is the code whihc will provbably help you. 
NOTE the output of these routines are in LISP list form. If
You want in a string form without BRACes at the ends and SPACES in between 
symbosl you have to do some simple conversions like output using 
apropriate FORMAT macro directives.

I am posting on the net because I thought it migth be interesting to 
others also.


-srini 
______________________________________________________________________________
 P Srinivas,                                Email : ········@ncst.ernet.in 
 National Centre for Software Technology,   Phone : +91 (22) 620 1606
 Gulmohar Cross Rd No. 9,                   Telex : 011-78260 NCST IN
 Juhu, Bombay 400 049                         Fax : +91 (22) 620 0590
------------------------------------------------------------------------------
;;;-*- mode:common-lisp ;  package: user -*-
;;; -------------------------------------------------------------------------
;;;  Package : user
;;;  File    : expression.lsp
;;;  Author  : P Srinivas  (········@ncst.ernet.in)
;;;  Date    : 5-JUN-1989  :   Modified 13-JUN-1989
;;;------------------------------------------------------------------------


;;;; PREFIX <==> PREFIX conversion routines.


;;; This set of functions allows one to convert symbolic expressions from
;;; infix to prefix and prefix to infix. There are two main functions
;;; for this. The precedance is defined by the weights. You can change 
;;; The name of the operator for converting infic to prefix. This
;;; is useful in some case e.g the `power' operator '^' is used in
;;; infix for rasing spomething to the power of something else.
;;; Whereas in prefix form it uses `expt' instead. So  (a + b) ^ 2
;;; in infix is converted to (expt (+ a b) 2) in prefix. You
;;; can change this by hacking the code in `INITIALIZE-OPERATORS'

;;; It also allows us to keep the `atmoic' expressions in the expressions
;;; (i.e., 'a' and 'b' in (a+b) ^ 2 kind of expressions) to be other
;;; than juts symbols and numbers. In particular it presves any
;;; pattern variables represented by '(> ``some symbol'') as atmoic
;;; entities in an expression.
;;;

;;; IMPORATNT:
;;;    Incase there are some extra braces in the infix form you should
;;; calll `MERGE-EXPRESSION' with prefix expression as argument before
;;; calling PREFIX-2-INFIX which will merge commutative operators and
;;; returns a merged expression. 
;;; For example:
;;;
;;;   lisp> (prefix-2-infix '(*  (+ 3 a) (* b 6)))
;;;   ((3 + A) * (B * 6))
;;;   lisp> (prefix-2-infix (merge-expression '(*  (+ 3 a) (* b 6))))
;;;   ((3 + A) * B * 6)
;;;
;;; Ofcourse you can use MERGE-EXPRESSION independantly also to
;;; merge commutative operators.
;;;
;;; Some part of the code is taken from LISP by Winston and Horn

;;; Any bugs please send mail to   
;;; ·········@ncst.ernet.in' (internet)
;;; `...!uunet!shakti!srinivas' (UUCP)

(defun prefix-2-infix(expression)
  "* PREFIX-2-INFIX  
     Converts EXPRESSION from prefix to infix form"
  (cond ((null expression) nil)
        ((atom expression) (list expression))
        ((and (= (length expression) 2)
              (unary-p (first expression)))
         (append (list (first expression)) 
                 (list (prefix-2-infix (second expression)))))
        ((and (= (length expression) 3)
              (member (first expression) '(expt)))
         (append
              (prefix-2-infix (second expression))
              (list '^)
              (prefix-2-infix (third expression))))
        ((not (unary-p (first expression)))
         (let ((result nil)
               (operator (first expression))
               (operatorlist ()))
              (dolist (elem (cdr expression) result)
                      (if result (setq operatorlist (list operator))
                                 (setq operatorlist nil))
                      (if (and (listp elem)
                               (<= (get (first elem) 'weight)
                                  (get operator 'weight)))
                               (setq result 
                                        (append result operatorlist
                                            (list (prefix-2-infix elem))))
                               (setq result 
                                        (append result operatorlist
                                            (prefix-2-infix elem)))))))))

(defun unary-p (item)
  (member item '(sqrt expt sin cos tan cot sec cosec 
                   arcsin arccos arctan arccot arcsec arccosec ))) 


(defun infix-2-prefix (expression)
  "* INFIX-2-PREFIX
     Converts EXPRESSION from infix to prefix format."
  (cond ((or (atomic-p expression) (atom expression)) expression)
        (T (infix-aux expression nil nil))))


(defun infix-aux (form operators operands)
  (cond ((operator-p (car form))	; Is it an operator?
         (infix-iter (cdr form) 
		     (cons (car form) operators) ; Push into operators stack
		     operands)) 
        (T (infix-iter (cdr form)	;work on CDR
		       operators 
		       (cons (infix-2-prefix (car form)) operands)))))
					;recur on CAR


(defun infix-iter (form operators operands)
  (cond ((and (null form) (null operators)) ;finished?
	 (car operands))
        ((and (not (null form)) 
              (operator-p (car form))
              (or (null operators)
                  (> (weight (car form))
                     (weight (car operators)))
		  ))
         (infix-aux (cdr form )
                    (cons (car form) operators)
                    operands))
        ((and (not (null form))
              (listp (car form))
              (not (atomic-p (car form))))
         (infix-iter (cdr form)
                     operators
                     (cons (infix-2-prefix (car form))
                           operands)))
        (T  (infix-iter form 
                        (cdr operators)
			(put-compound-prefix-expression-in-operands 
			 (car operators)
			 operands)))))

(defun put-compound-prefix-expression-in-operands (operator operands)
  (let ((arity (get operator 'arity))
	(opcode (get operator 'opcode)))
    (cons (cons opcode (reverse (subseq operands 0 arity)))
	  (nthcdr arity operands))))

(defun weight(operator)
  (get operator 'weight))

(defun opcode(operator)
  (get operator 'opcode))

(defun operator-p(elem)
  (member elem '(= + - * / ^ sqrt root sin cos tan cot sec cosec --)
	  :test #'equal))

(defun trig-operator-p (oper)
  (member oper '(sin cos tan cosec sec cot) :test #'equal))

(defun commutative-p (op)
  (member op '(+ *)  :test #'equal))

(defun non-commutative-p (op)
  (member op '(/ -)  :test #'equal))

(defun merge-expression(expr)
  (cond ((or (null expr) (atom expr) (atomic-p expr)) expr)
	((commutative-p (car expr))
	 (merge-commutative expr))
	((non-commutative-p (car expr))
	 (merge-non-commutative expr))
	(t (let ((result nil))
	     (dolist (one (cdr expr) (cons (car expr) (reverse result)))
	       (push (merge-expression one) result))))))

(defun merge-commutative(expr)
  (cond ((or (null expr) (atom expr) (atomic-p expr)) expr)
	((commutative-p (car expr))
	 (cons (car expr)
	       (merge-commutative-list (cdr expr) (car expr))))
	(T
	 (let ((result (list (car expr))))
	   (dolist (one (cdr expr) result)
	     (setq result
	       `(,@result  ,(merge-expression one))))))))


(defun merge-commutative-list (expr-list oper)
  (cond ((null expr-list) expr-list)
	(T (let ((next-expr (merge-expression
			     (car expr-list))))
	     (if (and (listp next-expr)
		      (eql (car next-expr) oper))
		 (append (cdr next-expr)
			 (merge-commutative-list (cdr expr-list) oper))
	       (cons next-expr
		     (merge-commutative-list (cdr expr-list) oper)))))))

(defun merge-? (oper first second)
  (if (or (and (not (or (atom first) (atomic-p first)))
	       (equal oper (car first)))
	  (and (not (or (atom second) (atomic-p second)))
	       (equal oper (car second))))
      (merge-expression
       (list oper first second))
    (list oper first second)))

;;; This function is not used by 'i-2-p' functions but are
;;; put here. To be shifted later.
(defun merge-non-commutative (expr)
  (cond ((or (null expr) (atom expr) (atomic-p expr)) expr)
	((non-commutative-p (car expr))
	 (let ((first-arg (second expr))
	       (second-arg (third expr)))
	   (cond ((and (or (atom first-arg) (atomic-p first-arg))
		       (or (atom second-arg) (atomic-p second-arg)))
		  expr)
		 ((or (atom first-arg) (atomic-p first-arg))
		  (if (equal (car expr) (car second-arg))
		      (merge-? (car expr)
			       (merge-expression
				(add-complement (car expr)
						first-arg
						(third second-arg)))
			       (merge-expression (second second-arg)))
		    (merge-? (car expr) first-arg
			     (merge-expression second-arg))))
                 ((or (atom second-arg) (atomic-p second-arg))
		  (if (equal (car expr) (car first-arg))
		      (merge-? (car expr)
			       (merge-expression (second first-arg))
			       (merge-expression
				(add-complement (car expr)
						(third first-arg)
						second-arg)))
		    (merge-? (car expr)
			     (merge-expression first-arg)
			     second-arg)))
		 (T
		  (cond ((and (equal (car expr) (car first-arg))
			      (equal (car expr) (car second-arg)))
			 (merge-? (car expr)
				  (merge-expression
				   (add-complement (car expr)
						   (second first-arg)
						   (second second-arg)))
				  (merge-expression
				   (add-complement (car expr)
						   (third first-arg)
						   (third second-arg)))))
			((equal (car expr) (car first-arg))
			 (merge-? (car expr)
				  (second first-arg)
				  (merge-expression
				   (add-complement (car expr)
						   (third first-arg)
						   second-arg))))
			((equal (car expr) (car second-arg))
			 (merge-? (car expr)
				  (merge-expression
				   (add-complement (car expr)
						   (third second-arg)
						   first-arg))
				  (second second-arg)))
			(T (merge-? (car expr)
				    (merge-expression first-arg)
				    (merge-expression second-arg))))))))
	(T  (merge-? (car expr)
		     (merge-expression first-arg)
		     (merge-expression second-arg)))))


(defun atomic-p (exp)
  (or (symbolp exp)
      (numberp exp)
      (and (listp exp)
	   (= (list-length exp) 2)
	   (equal (first exp) '>)
	   (sumbolp (second exp)))))



(defun add-complement (oper new-arg expr)
  (list (get-complement-oper oper)
	new-arg
	expr))

(defun get-complement-oper (oper)
  (case oper
    (* '/)
    (/ '*)
    (+ '-)
    (- '+)))

(defun initialize-operators()
  (progn (setf (get '= 'weight) 0)
	 (setf (get '+ 'weight) 1)
	 (setf (get '- 'weight) 1)
	 (setf (get '* 'weight) 2)
	 (setf (get '/ 'weight) 2)
	 (setf (get '^ 'weight) 3)
	 (setf (get 'expt 'weight) 3)
	 (setf (get 'sqrt 'weight) 3)
	 (setf (get 'root 'weight) 3)
	 (setf (get 'sin 'weight) 4)
	 (setf (get 'cos 'weight) 4)
	 (setf (get 'tan 'weight) 4)
	 (setf (get 'cot 'weight) 4)
	 (setf (get 'sec 'weight) 4)
	 (setf (get 'cosec 'weight) 4)
         (setf (get '-- 'weight) 4)	; temporarily unary minus

	 (setf (get '= 'opcode) '=)
	 (setf (get '+ 'opcode) '+)
	 (setf (get '- 'opcode) '-)
	 (setf (get '* 'opcode) '*)
	 (setf (get '/ 'opcode) '/)
	 (setf (get '^ 'opcode) 'expt)
	 (setf (get 'sin 'opcode) 'sin)
	 (setf (get 'cos 'opcode) 'cos)
	 (setf (get 'tan 'opcode) 'tan)
	 (setf (get 'cot 'opcode) 'cot)
	 (setf (get 'sec 'opcode) 'sec)
	 (setf (get 'cosec 'opcode) 'cosec)
         (setf (get '-- 'opcode) '--)	; temporarily unary minus

	 (setf (get '= 'arity) 2)
	 (setf (get '+ 'arity) 2)
	 (setf (get '- 'arity) 2)
	 (setf (get '* 'arity) 2)
	 (setf (get '/ 'arity) 2)
	 (setf (get '^ 'arity) 2)
	 (setf (get 'expt 'arity) 2)
	 (setf (get 'sqrt 'arity) 1)
	 (setf (get 'root 'arity) 2)
	 (setf (get 'sin 'arity) 1)
	 (setf (get 'cos 'arity) 1)
	 (setf (get 'tan 'arity) 1)
	 (setf (get 'cot 'arity) 1)
	 (setf (get 'sec 'arity) 1)
	 (setf (get 'cosec 'arity) 1)
         (setf (get '-- 'arity) 1)	; temporarily unary minus

	 ))
(initialize-operators)
-- 
______________________________________________________________________________
 P Srinivas,                                Email : ········@ncst.ernet.in 
 National Centre for Software Technology,   Phone : +91 (22) 620 1606
 Gulmohar Cross Rd No. 9,                   Telex : 011-78260 NCST IN