share/contrib/tocl.lisp

   1 #| Copyright 2006, 2007 by Barton Willis
   2
   3   This is free software; you can redistribute it and/or
   4   modify it under the terms of the GNU General Public License,
   5   http://www.gnu.org/copyleft/gpl.html.
   6
   7  This software has NO WARRANTY, not even the implied warranty of
   8  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
   9
  10 If you need to use a Maxima expression in a Common Lisp (CL) program,
  11 the function 'common_lisp' might be useful to you. Basically,
  12 'common_lisp' converts a Maxima expression into a Lisp lambda form.
  13 It converts Maxima operators into their closest Common Lisp
  14 counterparts. Thus Maxima addition is converted into the Common
  15 Lisp '+' function. Thus the lambda form generated by common_lisp
  16 should work OK with numerical inputs, but not symbolic inputs.
  17
  18 Maxima has comprehensive Maxima to CL translator. For any thing
  19 more complicated than a single Maxima expression, you'll want
  20 to use the Maxima to CL translator.
  21
  22 A few examples might be the easiest way to explain what
  23 'common_lisp' does:
  24
  25 (%i1) common_lisp(a+b*c);
  26 (LAMBDA (A B C) (+ (* B C) A))
  27 (%o1) done
  28 (%i2) common_lisp(cos(x+b) - f(z));
  29 (LAMBDA (B X Z) (+ (COS (+ B X)) (- (F Z))))
  30 (%o2) done
  31
  32 The function 'to_cl' doesn't generate a lambda form:
  33
  34 (%i1) to_cl('(x : x + 1, x * x))$
  35 (PROGN (SETQ X (+ 1 X)) (EXPT X 2))
  36
  37 (%i2) to_cl('(f(x) := (x : x + 1, x * x)))$
  38 (DEFUN $F (X) (PROGN (SETQ X (+ X 1)) (* X X)))
  39
  40 The function common_lisp should work correctly for polynomials, trig-like
  41 functions, block constructs, conditionals, compound statements, and
  42  'for' and 'while' loops.
  43
  44 The function 'cl_eval' evaluates the generated CL code; for example
  45
  46 (%i1) 'block([acc : 0], for k : 1 thru 100 do acc : acc + 1.0/k, acc)$
  47 (%i2) [ev(%),cl_eval(%)];
  48 (%o2) [5.187377517639621,5.187377517639621]
  49 (%i3) 'block([acc : 0], for k : 1 thru 100 while acc < 1.78 do acc : acc + 1.0/k, acc :
  50   acc + 1.2, acc+12.7)$
  51 (%i4) [ev(%),cl_eval(%)];
  52 (%o4) [15.73333333333333,15.73333333333333]
  53
  54 |#
  55
  56 (defun $common_lisp (e)
  57   (let (($listconstvars nil) (vars nil))
  58     (setq vars (delete 't (margs ($listofvars e)))) ;; listofvars('if x < 0 then 0 else 1) --> [x, true]
  59     (print `(lambda ,(sort (mapcar 'stripdollar vars) 'string<)
  60               ,(expr-to-cl (nformat ($ratdisrep e)))))
  61     '$done))
  62
  63 (defun $to_cl (e)
  64   (print (expr-to-cl (nformat ($ratdisrep e))))
  65   '$done)
  66
  67 (defun $cl_eval (e)
  68   (eval (expr-to-cl (nformat ($ratdisrep e)))))
  69
  70 (setf (get 'mplus 'cl-function) '+)
  71 (setf (get 'mminus 'cl-function) '-)
  72 (setf (get 'mtimes 'cl-function) '*)
  73 (setf (get 'mquotient 'cl-function) '/)
  74 (setf (get 'mexpt 'cl-function) 'expt)
  75 (setf (get 'mlessp 'cl-function) '<)
  76 (setf (get 'mgreaterp 'cl-function) '>)
  77 (setf (get 'mgeqp 'cl-function) '>=)
  78 (setf (get 'mleqp 'cl-function) '<=)
  79 (setf (get 'mprogn 'cl-function) 'progn)
  80 (setf (get 'mabs 'cl-function) 'abs)
  81 (setf (get 'msetq 'cl-function) 'setq)
  82 (setf (get 'mnot 'cl-function) 'not)
  83 (setf (get 'mand 'cl-function) 'and)
  84 (setf (get 'mor 'cl-function) 'or)
  85
  86 (setf (get 'lambda 'cl-translation-function) 'lambda-tr)
  87 (setf (get 'mprog 'cl-translation-function) 'block-tr)
  88 (setf (get 'mcond 'cl-translation-function) 'cond-tr)
  89 (setf (get 'mdefine 'cl-translation-function) 'mdefine-tr)
  90 (setf (get 'mdo 'cl-translation-function) 'mdo-tr)
  91
  92 (defun lambda-tr (&rest f)
  93   `(lambda (,@(mapcar 'expr-to-cl (margs (first f)))) ,(expr-to-cl (second f))))
  94
  95 (defun block-tr (&rest f)
  96   (let ((acc nil) (f1))
  97     (setq f1 (margs (first f)))
  98     (dolist (ai f1)
  99       (push (if (op-equalp ai 'msetq) (mapcar 'expr-to-cl (margs ai)) (list (expr-to-cl ai))) acc))
 100     (setq acc (list (reverse acc)))
 101     `(let ,@acc ,@(mapcar #'expr-to-cl (cdr f)))))
 102
 103 (defun cond-tr (&rest f)
 104   (let ((acc nil) (f1) (f2))
 105     (while f
 106       (setq f1 (expr-to-cl (pop f)))
 107       (setq f2 (expr-to-cl (pop f)))
 108       (push (list f1 f2) acc))
 109     `(cond ,@(reverse acc))))
 110
 111 (defun mdefine-tr (&rest f)
 112   `(defun ,(caaar f) ,(mapcar 'expr-to-cl (cdar f)) ,(expr-to-cl (cadr f))))
 113
 114 (defun mdo-tr (&rest f)
 115   (let ((k) (lo) (inc) (pred) (hi) (body) (op))
 116     (setq k (expr-to-cl (nth 0 f)))
 117     (setq lo (expr-to-cl (nth 1 f)))
 118     (setq inc (expr-to-cl (nth 2 f)))
 119     (setq hi (expr-to-cl (nth 4 f))) ;; skips (nth 3 f)?
 120     (setq pred (expr-to-cl (nth 5 f)))
 121     (setq body (expr-to-cl (nth 6 f)))
 122
 123     (cond ((and (null lo) (null hi) (null inc)) `(do () (,pred (quote $done)) ,body))
 124           (t
 125            (setq inc (or inc 1))
 126            (setq op (if (> inc 0) '> '<))
 127            (setq pred (if pred `((or (,op ,k ,hi) ,pred) (quote $done)) `((,op ,k ,hi) (quote $done))))
 128            (setq body (expr-to-cl (nth 6 f)))
 129            `(do ((,k ,lo (incf ,k ,inc))) ,pred ,body)))))
 130
 131 (defun mapatom-expr-to-cl (e)
 132   (cond ((eq e '$%i) (complex 0 1))
 133         ((member e '($true t) :test #'eq) 't)
 134         ((member e '($false nil) :test #'eq) 'nil)
 135         ((integerp e) e)
 136         (($ratnump e) `(/ ,($num e) ,($denom e)))
 137         ((eq e '$%pi) pi)
 138         (($constantp e) ($float e)) ;; converts big floats to doubles
 139         (t (stripdollar e))))
 140
 141 (defun expr-to-cl (e)
 142   (cond(($mapatom e) (mapatom-expr-to-cl e))
 143        ((get (mop e) 'cl-translation-function)
 144         (apply (get (mop e) 'cl-translation-function) (margs e)))
 145        (t
 146         `(,(or (get (mop e) 'cl-function) (stripdollar (mop e))) ,@(mapcar 'expr-to-cl (margs e))))))