Menu
▾
▴
[Maxima-commits] CVS: maxima/src newinv.lisp,1.4,1.5
|
From: Andreas E. <ar...@us...> - 2007-03-28 17:27:55
|
Update of /cvsroot/maxima/maxima/src In directory sc8-pr-cvs7.sourceforge.net:/tmp/cvs-serv16024 Modified Files: newinv.lisp Log Message: replaced store with setf. Index: newinv.lisp =================================================================== RCS file: /cvsroot/maxima/maxima/src/newinv.lisp,v retrieving revision 1.4 retrieving revision 1.5 diff -u -d -r1.4 -r1.5 --- newinv.lisp 7 Nov 2005 17:37:11 -0000 1.4 +++ newinv.lisp 28 Mar 2007 17:27:51 -0000 1.5 @@ -9,42 +9,42 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :maxima) + (macsyma-module newinv) -(declare-top(special *ptr* *ptc* *iar* *nonz* detl* *r0 mul* $sparse *det* *rr* ax)) -(declare-top (fixnum *r0)) +(declare-top (special *ptr* *ptc* *iar* *nonz* detl* *r0 mul* $sparse *det* *rr* ax)) (defun multbk (l ax m) (prog (e) - (do ((j (f1+ m) (f1+ j))) ((> j (f* 2 m))) + (do ((j (1+ m) (1+ j))) + ((> j (* 2 m))) (setq e (car l) l (cdr l)) - (do ((i 1 (f1+ i))) ((> i m)) - (store (aref ax i j) - (rattimes e (aref ax i j) t)))))) + (do ((i 1 (1+ i))) ((> i m)) + (setf (aref ax i j) (rattimes e (aref ax i j) t)))))) (defun ctimemt (x y) (prog (c) - loop (cond ((null y) (return c))) + loop (cond ((null y) (return c))) (setq c (nconc c (list (timesrow x (car y)))) y (cdr y)) (go loop))) (defun stora (ax m ei r) - (declare(fixnum m r )) + (declare (fixnum m r)) (prog (det (i 0) (j 0) ro mat) - (declare(fixnum i j )) + (declare(fixnum i j)) (setq i 0) - loop0 (cond ((null ei)(return nil))) + loop0 (cond ((null ei) (return nil))) (setq mat (car ei) ei (cdr ei)) (setq det (caar mat) mat (cdr mat)) loop (setq j r) - (cond ((null mat)(go loop0))) - (setq i (f1+ i) ro (car mat) mat (cdr mat)) + (cond ((null mat) (go loop0))) + (setq i (1+ i) ro (car mat) mat (cdr mat)) loop2 (cond ((null ro) (go loop))) - (setq j (f1+ j)) - (store (aref ax i (f+ m j)) (ratreduce (caar ro) det)) - (store (aref ax (aref *ptr* i) (aref *ptc* j)) nil) + (incf j) + (setf (aref ax i (+ m j)) (ratreduce (caar ro) det)) + (setf (aref ax (aref *ptr* i) (aref *ptc* j)) nil) (setq ro (cdr ro)) (go loop2))) @@ -56,28 +56,26 @@ (stora ax m (append co (list d)) r) (setq detl* (cons (car d) detl*)) (return (cons (list d) - (mapcar (function - (lambda (x y) - (nconc x (list y)))) + (mapcar #'(lambda (x y) (nconc x (list y))) ri (nreverse *rr*)))))) (setq e (car ei) ei (cdr ei)) (setq co (cons (bmhk e d co r detl*) co)) (go loop))) (defun obmtrx (ax r s i j) - (declare(fixnum r s i j )) + (declare (fixnum r s i j )) (prog (ans (dj 0) (ds 0) dr d) (declare(fixnum ds dj)) (setq ds s dj j) - loop (cond((= i 0) (return ans))) + loop (cond ((= i 0) (return ans))) loop1 (cond ((= j 0) (setq j dj s ds ans (cons (nreverse dr) ans)) - (setq dr nil r (f1- r) i (f1- i)) + (setq dr nil r (1- r) i (1- i)) (go loop))) - (setq s (f1+ s) j (f1- j)) - (setq d (aref ax (aref *ptr* r) (aref *ptc* s))) + (setq s (1+ s) j (1- j)) + (setq d (aref ax (aref *ptr* r) (aref *ptc* s))) (cond ((or *nonz* (equal d 0)) nil) (t (setq *nonz* t))) (setq dr (cons d dr)) @@ -90,9 +88,9 @@ (setq da (reverse da)) (setq c (obmtrx ax *r0 c0 (length(cdr a)) (length b))) (setq *rr* (cons c *rr*)) - (cond ((null *nonz*)(return (cons '(1 . 1) c)))) + (cond ((null *nonz*) (return (cons '(1 . 1) c)))) (setq sum (multmat c b)) - (setq *r0 (f- *r0 (length (cdr a)))) + (setq *r0 (- *r0 (length (cdr a)))) loop (cond ((null da) (go on))) (setq x (car da) y(car nc) dy (car y) y (cdr y)) (setq x (multmat x y)) @@ -103,41 +101,42 @@ on (setq det (cons (ptimes (pminus (caar a)) (car det)) 1)) (return (cons det (multmat(cdr a) sum))))) -(declare-top(special bl)) -(comment tmlattice returns the block structure in the form of a list of blocks - each in the form of ((i1 j1) (i2 j2) etc)) +(declare-top (special bl)) + +;; tmlattice returns the block structure in the form of a list of blocks +;; each in the form of ((i1 j1) (i2 j2) etc)) (defun newinv (ax m n) (declare (fixnum m n )) (prog (j mmat bl d bm detl* dm ipdm dm2 r i ei) - ;(DECLARE (FIXNUM J R BM DM DM2 )) (declare (special bl)) ;Why? I don't know why. --gsb - (do ((i m (f1- i))) ((= i 0)) + (do ((i m (1- i))) + ((= i 0)) (declare (fixnum i)) - (setq mmat(cons (aref ax i (f+ i m)) mmat))) - (setq *ptr* (*array nil t (f1+ m))) - (setq *ptc* (*array nil t (f1+ m))) + (setq mmat (cons (aref ax i (+ i m)) mmat))) + (setq *ptr* (make-array (1+ m))) + (setq *ptc* (make-array (1+ m))) (setq bl (tmlattice ax '*ptr* '*ptc* m)) (cond ((null bl) (merror "Singular"))) - (setq bl (mapcar 'length bl)) - (setq bm (apply 'max bl)) ;Chancey. Consider mapping. - (setq *iar* (*array nil t (f1+ bm) (f1+ (f* 2 bm)))) + (setq bl (mapcar #'length bl)) + (setq bm (apply #'max bl)) ;Chancey. Consider mapping. + (setq *iar* (make-array (list (1+ bm) (1+ (* 2 bm))))) (setq r 0) loop1 (cond ((null bl) (tmunpivot ax '*ptr* '*ptc* m n) (return (multbk mmat ax m)))) (setq i (car bl)) (setq dm i) - (setq dm2 (f* 2 dm)) - loop2 (cond ((= i 0)(go inv))) - (setq j dm2 ipdm(f+ i dm)) - loop3 (cond ((= j 0) (setq i (f1- i)) (go loop2))) - (store (aref *iar* i j) - (cond ((> j dm) - (cond ((= j ipdm) '(1 . 1)) - (t '(0 . 1)))) - (t (aref ax (aref *ptr* (f+ r i)) (aref *ptc*(f+ r j)))))) - (setq j (f1- j)) + (setq dm2 (* 2 dm)) + loop2 (cond ((= i 0) (go inv))) + (setq j dm2 ipdm (+ i dm)) + loop3 (cond ((= j 0) (setq i (1- i)) (go loop2))) + (setf (aref *iar* i j) + (cond ((> j dm) + (cond ((= j ipdm) '(1 . 1)) + (t '(0 . 1)))) + (t (aref ax (aref *ptr* (+ r i)) (aref *ptc*(+ r j)))))) + (decf j) (go loop3) inv (cond ((= r 0) (setq ei (tmlin '*iar* dm dm dm)) @@ -146,11 +145,10 @@ (setq ei (list ei))(go next))) (setq d (tmlin '*iar* dm dm dm)) (setq d (cons (caar d) (cdr d))) - (setq ei(prodhk ei d r m)) + (setq ei (prodhk ei d r m)) (setq d nil) - next (setq r(f+ r (car bl))) + next (incf r (car bl)) (setq bl (cdr bl)) (go loop1))) -#-nil -(declare-top(unspecial bl *nonz* detl* *r0 mul* *det* *rr* ax)) +(declare-top (unspecial bl *nonz* detl* *r0 mul* *det* *rr* ax)) |