;;; Lisplab, level0-infpre.lisp
;;; Infix to prefix conversion utility.

;;; Copyright (C) 2009 Joern Inge Vestgaarden
;;;
;;; 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.,
;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.

;;;; Syntax: 
;;;   Works directly on lisp lists, not on strings.
;;;   The cost is that all operators must be separated by spaces, 
;;;   i.e. 1 + 2, not 1+2. 
;;;   
;;;   Unlike most infix utilities, the infix conversion
;;;   does not interpret +,*, etc. as binary operators,
;;;   but as list separted by the operator
;;;   i.e. (1 + 2 + 3) -> (+ 1 2 3) not (+ (+ 1 2) 3). 
;;;
;;;   The order of the operators determine precedence. 
;;;
;;;; Examples:
;;;   (1 + 2 * exp (-1 * x) * 3) -> (+ 1 (* 2 (exp (* -1 x)) 3))
;;; 

(in-package :lisplab)

(defvar *separators* '(.+ + .- - .* * ./ / .^ ^) 
  "Default operators for the math macros") 

(defmacro w/infix (&body body)
  "Converts infix to prefix"
  (infix->prefix body *separators*))     

(defun remove-brackets (lst)
  "Reduses lists with just one item to the item itself"
  (do ((result lst (car result)))
      ((or (not (consp result))
	   (not (null (cdr result)))) result)))

(defun separate-list (lst separator test)
  "Returns list of sub-sequences defined by separator"
  (if (not (consp lst))
      lst
      (let ((result (cons separator nil)) (end 0) (sub)
	    (lst (if (funcall test (car lst) separator)
		     (cdr lst)
		     lst)))
	(do () ((null lst) result)
	  (setf end 
		(position separator lst :test test))
	  (setf sub
		(cons (subseq lst 0 end) nil))
	  (setf result 
		(append result sub))
	  (setf lst 
		(if end 
		    (nthcdr (+ 1 end) lst)
		    nil)))
	(setf (cdr result) (mapcar #'remove-brackets (cdr result)))
	result)))

(defun separate-tree (lst separator test)
  "Apply separate-list on all sublists"
  (if (or (not (consp lst)) (eql (first lst) 'quote))
      lst
      (progn
	(setf lst (mapcar #'(lambda (x) 
			      (if (not (consp x))
				  x
				  (separate-tree x separator test)))
			  lst))
	(if (not (find separator (rest lst)))
	    lst
	    (separate-list lst separator test)))))

(defun infix->prefix (infix-expr separators &key (test #'eql))
  "Converts an infix expression to prefix"
  (let ((result infix-expr))
    (dolist (sep separators)
      (setf result (separate-tree result sep test)))
    (remove-brackets result)))

(defun insert-between (lst sep)
  (if (or (not (consp lst))
	  (not (rest lst)))
      lst
    (cons (first lst) (mapcan #'(lambda (x) (list sep x)) (rest lst)))))

(defun prefix->infix (prefix-expr separators &key (test #'eql))
  "Converts a prefix expression to infix"
  (let ((in-expr (mapcar #'(lambda (x)
			     (remove-brackets (if (listp x)
					      (prefix->infix x separators)
					    x)))
			 prefix-expr)))
    (if (or (not (listp in-expr))
	    (not (member (first in-expr) separators :test test)))
	in-expr
      (insert-between (rest in-expr) (first in-expr)))))