From: Barton W. <wil...@us...> - 2006-06-01 22:26:34
|
Update of /cvsroot/maxima/maxima/share/contrib In directory sc8-pr-cvs7.sourceforge.net:/tmp/cvs-serv7602/share/contrib Modified Files: multiadditive.lisp Log Message: Fixing a bug in multiadditive. The Maxima function outermap didn't do what I thought it did. Index: multiadditive.lisp =================================================================== RCS file: /cvsroot/maxima/maxima/share/contrib/multiadditive.lisp,v retrieving revision 1.4 retrieving revision 1.5 diff -u -d -r1.4 -r1.5 --- multiadditive.lisp 31 May 2006 18:37:42 -0000 1.4 +++ multiadditive.lisp 1 Jun 2006 22:26:24 -0000 1.5 @@ -32,6 +32,19 @@ (defun protected-oper-apply (e z) (if ($mapatom e) e (oper-apply e z))) + +;; Code adapated from nset. Used by permission of the author ;) + +(defun cartesian-product (&rest b) + (cond ((null b) + nil) + (t + (let ((a) (acc (mapcar #'list (car b)))) + (setq b (cdr b)) + (dolist (bi b acc) + (setq a nil) + (dolist (bij bi (setq acc a)) + (setq a (append a (mapcar #'(lambda (x) `(,@x ,bij)) acc))))))))) (setq opers (cons '$multiadditive opers) *opers-list (cons '($multiadditive . multiadditive) *opers-list)) @@ -41,9 +54,10 @@ (defun multiadditive (e z) (cond ((some #'(lambda (s) (op-equalp s 'mplus)) (margs e)) (let ((op (mop e)) (args (margs e))) - (setq args (mapcar #'(lambda (s) (if (op-equalp s 'mplus) ($args s) `((mlist) ,s))) args)) - (setq args (mfuncall '$apply '$outermap ($cons op (cons '(mlist) args)))) - (reduce 'add (mapcar #'(lambda (s) (protected-oper-apply s z)) (margs ($flatten args)))))) + (setq args (mapcar #'(lambda (s) (if (op-equalp s 'mplus) (margs s) (list s))) args)) + (setq args (apply 'cartesian-product args)) + (setq args (mapcar #'(lambda (s) (simplify `((,op) ,@s))) args)) + (reduce 'add (mapcar #'(lambda (s) (protected-oper-apply s z)) args)))) (t (protected-oper-apply e z)))) (setq opers (cons '$threadable opers) |