#| Copyright 2006, 2007 by Barton Willis

  This is free software; you can redistribute it and/or
  modify it under the terms of the GNU General Public License,
  http://www.gnu.org/copyleft/gpl.html.

 This software has NO WARRANTY, not even the implied warranty of
 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

If you need to use a Maxima expression in a Common Lisp (CL) program,
the function 'common_lisp' might be useful to you. Basically,
'common_lisp' converts a Maxima expression into a Lisp lambda form.
It converts Maxima operators into their closest Common Lisp 
counterparts. Thus Maxima addition is converted into the Common 
Lisp '+' function. Thus the lambda form generated by common_lisp
should work OK with numerical inputs, but not symbolic inputs.

Maxima has comprehensive Maxima to CL translator. For any thing
more complicated than a single Maxima expression, you'll want
to use the Maxima to CL translator.

A few examples might be the easiest way to explain what 
'common_lisp' does:

(%i1) common_lisp(a+b*c);
(LAMBDA (A B C) (+ (* B C) A)) 
(%o1) done
(%i2) common_lisp(cos(x+b) - f(z));
(LAMBDA (B X Z) (+ (COS (+ B X)) (- (F Z)))) 
(%o2) done

The function 'to_cl' doesn't generate a lambda form:

(%i1) to_cl('(x : x + 1, x * x))$
(PROGN (SETQ X (+ 1 X)) (EXPT X 2)) 

(%i2) to_cl('(f(x) := (x : x + 1, x * x)))$
(DEFUN $F (X) (PROGN (SETQ X (+ X 1)) (* X X))) 

The function common_lisp should work correctly for polynomials, trig-like 
functions, block constructs, conditionals, compound statements, and
 'for' and 'while' loops. 

The function 'cl_eval' evaluates the generated CL code; for example

(%i1) 'block([acc : 0], for k : 1 thru 100 do acc : acc + 1.0/k, acc)$
(%i2) [ev(%),cl_eval(%)];
(%o2) [5.187377517639621,5.187377517639621]
(%i3) 'block([acc : 0], for k : 1 thru 100 while acc < 1.78 do acc : acc + 1.0/k, acc :
  acc + 1.2, acc+12.7)$
(%i4) [ev(%),cl_eval(%)];
(%o4) [15.73333333333333,15.73333333333333]

|#

(defun $common_lisp (e)
  (let (($listconstvars nil) (vars nil))
    (setq vars (delete 't (margs ($listofvars e)))) ;; listofvars('if x < 0 then 0 else 1) --> [x, true]
    (print `(lambda ,(sort (mapcar 'stripdollar vars) 'string<) 
	      ,(expr-to-cl (nformat ($ratdisrep e)))))
    '$done))
 
(defun $to_cl (e)
  (print (expr-to-cl (nformat ($ratdisrep e))))
  '$done)

(defun $cl_eval (e)
  (eval (expr-to-cl (nformat ($ratdisrep e)))))

(setf (get 'mplus 'cl-function) '+)
(setf (get 'mminus 'cl-function) '-)
(setf (get 'mtimes 'cl-function) '*)
(setf (get 'mquotient 'cl-function) '/)
(setf (get 'mexpt 'cl-function) 'expt)
(setf (get 'mlessp 'cl-function) '<)
(setf (get 'mgreaterp 'cl-function) '>)
(setf (get 'mgeqp 'cl-function) '>=)
(setf (get 'mleqp 'cl-function) '<=)
(setf (get 'mprogn 'cl-function) 'progn)
(setf (get 'mabs 'cl-function) 'abs)
(setf (get 'msetq 'cl-function) 'setq)
(setf (get 'mnot 'cl-function) 'not)
(setf (get 'mand 'cl-function) 'and)
(setf (get 'mor 'cl-function) 'or)

(setf (get 'lambda 'cl-translation-function) 'lambda-tr)
(setf (get 'mprog 'cl-translation-function) 'block-tr)
(setf (get 'mcond 'cl-translation-function) 'cond-tr)
(setf (get 'mdefine 'cl-translation-function) 'mdefine-tr)
(setf (get 'mdo 'cl-translation-function) 'mdo-tr)

(defun lambda-tr (&rest f)
  `(lambda (,@(mapcar 'expr-to-cl (margs (first f)))) ,(expr-to-cl (second f))))

(defun block-tr (&rest f)
  (let ((acc nil) (f1))
    (setq f1 (margs (first f)))
    (dolist (ai f1)
      (push (if (op-equalp ai 'msetq) (mapcar 'expr-to-cl (margs ai)) (list (expr-to-cl ai))) acc))
    (setq acc (list (reverse acc)))
    `(let ,@acc ,@(mapcar #'expr-to-cl (cdr f)))))

(defun cond-tr (&rest f)
  (let ((acc nil) (f1) (f2))
    (while f
      (setq f1 (expr-to-cl (pop f)))
      (setq f2 (expr-to-cl (pop f)))
      (push (list f1 f2) acc))
    `(cond ,@(reverse acc))))

(defun mdefine-tr (&rest f)
  `(defun ,(caaar f) ,(mapcar 'expr-to-cl (cdar f)) ,(expr-to-cl (cadr f))))
      
(defun mdo-tr (&rest f)
  (let ((k) (lo) (inc) (pred) (hi) (body) (op))
    (setq k (expr-to-cl (nth 0 f)))
    (setq lo (expr-to-cl (nth 1 f)))
    (setq d (expr-to-cl (nth 2 f)))
    (setq hi (expr-to-cl (nth 4 f))) ;; skips (nth 3 f)?
    (setq pred (expr-to-cl (nth 5 f)))
    (setq body (expr-to-cl (nth 6 f)))
   
    (cond ((and (null lo) (null hi) (null d)) `(do () (,pred (quote $done)) ,body))
	  (t
	   (setq d (or d 1))
	   (setq op (if (> d 0) '> '<))
	   (setq pred (if pred `((or (,op ,k ,hi) ,pred) (quote $done)) `((,op ,k ,hi) (quote $done))))
	   (setq body (expr-to-cl (nth 6 f)))
	   `(do ((,k ,lo (incf ,k ,d))) ,pred ,body)))))
       		
(defun mapatom-expr-to-cl (e)
  (cond ((eq e '$%i) (complex 0 1))
	((member e '($true t) :test #'eq) 't)
	((member e '($false nil) :test #'eq) 'nil)
	((integerp e) e)
	(($ratnump e) `(/ ,($num e) ,($denom e)))
	((eq e '$%pi) pi)
	(($constantp e) ($float e)) ;; converts big floats to doubles
	(t (stripdollar e))))
	
(defun expr-to-cl (e)
  (cond(($mapatom e) (mapatom-expr-to-cl e))
       ((get (mop e) 'cl-translation-function) 
	(apply (get (mop e) 'cl-translation-function) (margs e)))
       (t 
	`(,(or (get (mop e) 'cl-function) (stripdollar (mop e))) ,@(mapcar 'expr-to-cl (margs e))))))