mirror of
https://github.com/PDP-10/its.git
synced 2026-01-20 01:45:49 +00:00
149 lines
4.6 KiB
Common Lisp
149 lines
4.6 KiB
Common Lisp
;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
|
||
;;; (c) Copyright 1982 Massachusetts Institute of Technology ;;;
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
||
(macsyma-module sumcon)
|
||
|
||
(declare (special $genindex $niceindicespref $sumexpand)
|
||
(*lexpr $min $max))
|
||
|
||
(defmfun $sumcontract (e) ; e is assumed to be simplified
|
||
(cond ((atom e) e)
|
||
((eq (caar e) 'mplus)
|
||
(do ((x (cdr e) (cdr x)) (sums) (notsums) (car-x))
|
||
((null x) (cond ((null sums)
|
||
(subst0 (cons '(mplus)
|
||
(nreverse notsums))
|
||
e))
|
||
(t (setq sums (sumcontract1 sums))
|
||
(addn (cons sums notsums) t))))
|
||
(setq car-x (car x))
|
||
(cond ((atom car-x)
|
||
(setq notsums (cons car-x notsums)))
|
||
((eq (caar car-x) '%sum)
|
||
(setq sums (cons (cons ($sumcontract (cadr car-x))
|
||
(cddr car-x))
|
||
sums)))
|
||
(t (setq notsums (cons car-x notsums))))))
|
||
(t (recur-apply #'$sumcontract e))))
|
||
|
||
(defmfun $intosum (e) ; e is assumed to be simplified
|
||
(let (($sumexpand t))
|
||
(cond ((atom e) e)
|
||
((eq (caar e) 'mtimes) ;puts outside product inside
|
||
(do ((x (cdr e) (cdr x)) (sum) (notsum))
|
||
((null x) (cond ((null sum)
|
||
(subst0 (cons '(mtimes)
|
||
(nreverse notsum))
|
||
e))
|
||
(t (simpsum
|
||
(let ((new-index
|
||
(cond ((free (cons nil notsum)
|
||
(caddr sum))
|
||
(caddr sum))
|
||
(t (get-free-index
|
||
(cons nil (cons sum notsum)))))))
|
||
(setq sum (subst new-index (caddr sum) sum))
|
||
(rplaca (cdr sum) (muln (cons (cadr sum) notsum) t))
|
||
(rplacd (car sum) nil)
|
||
sum)
|
||
1 t))))
|
||
(cond ((atom (car x))
|
||
(setq notsum (cons (car x) notsum)))
|
||
((eq (caaar x) '%sum)
|
||
(setq sum (if (null sum)
|
||
(car x)
|
||
(muln (list sum (car x)) t))))
|
||
(t (setq notsum (cons ($sumcontract (car x))
|
||
notsum))))))
|
||
(t (recur-apply #'$intosum e)))))
|
||
|
||
(defun sumcontract1 (sums) (addn (sumcontract2 nil sums) t))
|
||
|
||
(defun sumcontract2 (result left)
|
||
(cond ((null left) result)
|
||
(t ((lambda (x) (sumcontract2 (append (car x) result)
|
||
(cdr x)))
|
||
(sumcombine1 (car left) (cdr left))))))
|
||
|
||
(defun sumcombine1 (pattern list)
|
||
(do ((sum pattern) (non-sums nil)
|
||
(un-matched-sums nil) (try-this-one)
|
||
(list list (cdr list)))
|
||
((null list) (cons (cons (simpsum (cons '(%sum) sum) 1 t)
|
||
non-sums)
|
||
un-matched-sums))
|
||
(setq try-this-one (car list))
|
||
(cond ((and (numberp (sub* (caddr sum) (caddr try-this-one)))
|
||
(numberp (sub* (cadddr sum) (cadddr try-this-one))))
|
||
((lambda (x) (setq sum (cdar x)
|
||
non-sums (cons (cdr x) non-sums)))
|
||
(sumcombine2 try-this-one sum)))
|
||
(t (setq un-matched-sums (cons try-this-one un-matched-sums))))))
|
||
|
||
(defun sumcombine2 (sum1 sum2)
|
||
((lambda (e1 e2 i1 i2 l1 l2 h1 h2)
|
||
((lambda (newl newh newi extracted new-sum)
|
||
(setq e1 (subst newi i1 e1))
|
||
(setq e2 (subst newi i2 e2))
|
||
(setq new-sum (list '(%sum)
|
||
(add2 e1 e2)
|
||
newi
|
||
newl
|
||
newh))
|
||
(setq extracted
|
||
(addn
|
||
(mapcar #'dosum
|
||
(list e1 e1 e2 e2)
|
||
(list newi newi newi newi)
|
||
(list l1 (add2 newh 1)
|
||
l2 (add2 newh 1))
|
||
(list (sub* newl 1) h1
|
||
(sub* newl 1) h2)
|
||
'(t t t t))
|
||
t))
|
||
(cons new-sum extracted))
|
||
($max l1 l2) ($min h1 h2) (cond ((eq i1 i2) i1)
|
||
((free e1 i2) i2)
|
||
((free e2 i1) i1)
|
||
(t (get-free-index (list nil
|
||
i1 i2
|
||
e1 e2
|
||
l1 l2
|
||
h1 h2))))
|
||
nil nil))
|
||
(car sum1) (car sum2)
|
||
(cadr sum1) (cadr sum2)
|
||
(caddr sum1) (caddr sum2)
|
||
(cadddr sum1) (cadddr sum2)))
|
||
|
||
(defmvar $niceindicespref '((mlist simp) $i $j $k $l $m $n))
|
||
|
||
(defun get-free-index (list)
|
||
(or (do ((try-list (cdr $niceindicespref) (cdr try-list)))
|
||
((null try-list))
|
||
(if (free list (car try-list)) (return (car try-list))))
|
||
(do ((n 0 (1+ n)) (try))
|
||
(nil)
|
||
(setq try (concat (cadr $niceindicespref) n))
|
||
(if (free list try) (return try)))))
|
||
|
||
(defmfun $bashindices (e) ; e is assumed to be simplified
|
||
(let (($genindex '$j))
|
||
(cond ((atom e) e)
|
||
((memq (caar e) '(%sum %product))
|
||
(sumconsimp (subst (gensumindex) (caddr e) e)))
|
||
(t (recur-apply #'$bashindices e)))))
|
||
|
||
(defmfun $niceindices (e)
|
||
(if (atom e) e
|
||
(let ((e (recur-apply #'$niceindices e)))
|
||
(if (memq (caar e) '(%sum %product))
|
||
(sumconsimp (subst (get-free-index e) (caddr e) e))
|
||
e))))
|
||
|
||
(defun sumconsimp (e)
|
||
(if (and (not (atom e)) (memq (caar e) '(%sum %product)))
|
||
(list* (car e) (sumconsimp (cadr e)) (cddr e))
|
||
(resimplify e)))
|
||
|