← Back to branch summary

~ubuntu-branches/debian/squeeze/maxima/squeeze

« back to all changes in this revision

Viewing changes to src/sumcon.lisp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2006-10-18 14:52:42 UTC
  • mto: (1.1.5 upstream)
  • mto: This revision was merged to the branch mainline in revision 4.
  • Revision ID: james.westby@ubuntu.com-20061018145242-vzyrm5hmxr8kiosf
Import upstream version 5.10.0

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/sumcon.lisp
8
8
;;;     (c) Copyright 1982 Massachusetts Institute of Technology         ;;;
9
9
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
10
10
 
11
 
(in-package "MAXIMA")
 
11
(in-package :maxima)
12
12
(macsyma-module sumcon)
13
13
 
14
14
(declare-top (special $genindex $niceindicespref $sumexpand)
15
 
         #-cl
16
 
         (*lexpr $min $max))
17
 
 
18
 
(defmfun $sumcontract (e)  ; e is assumed to be simplified
19
 
       (cond ((atom e) e)
20
 
             ((eq (caar e) 'mplus)
21
 
              (do ((x (cdr e) (cdr x)) (sums) (notsums) (car-x))
22
 
                  ((null x) (cond ((null sums)
23
 
                                   (subst0 (cons '(mplus)
24
 
                                                 (nreverse notsums))
25
 
                                           e))
26
 
                                  (t (setq sums (sumcontract1 sums))
27
 
                                     (addn (cons sums notsums) t))))
28
 
                  (setq car-x (car x))
29
 
                  (cond ((atom car-x)
30
 
                         (setq notsums (cons car-x notsums)))
31
 
                        ((eq (caar car-x) '%sum)
32
 
                         (setq sums (cons (cons ($sumcontract (cadr car-x))
33
 
                                                (cddr car-x))
34
 
                                          sums)))
35
 
                        (t (setq notsums (cons car-x notsums))))))
36
 
             (t (recur-apply #'$sumcontract e))))
37
 
 
38
 
(defmfun $intosum (e)  ; e is assumed to be simplified
 
15
             #-cl
 
16
             (*lexpr $min $max))
 
17
 
 
18
(defmfun $sumcontract (e)              ; e is assumed to be simplified
 
19
  (cond ((atom e) e)
 
20
        ((eq (caar e) 'mplus)
 
21
         (do ((x (cdr e) (cdr x)) (sums) (notsums) (car-x))
 
22
             ((null x) (cond ((null sums)
 
23
                              (subst0 (cons '(mplus)
 
24
                                            (nreverse notsums))
 
25
                                      e))
 
26
                             (t (setq sums (sumcontract1 sums))
 
27
                                (addn (cons sums notsums) t))))
 
28
           (setq car-x (car x))
 
29
           (cond ((atom car-x)
 
30
                  (setq notsums (cons car-x notsums)))
 
31
                 ((eq (caar car-x) '%sum)
 
32
                  (setq sums (cons (cons ($sumcontract (cadr car-x))
 
33
                                         (cddr car-x))
 
34
                                   sums)))
 
35
                 (t (setq notsums (cons car-x notsums))))))
 
36
        (t (recur-apply #'$sumcontract e))))
 
37
 
 
38
(defmfun $intosum (e)                  ; e is assumed to be simplified
39
39
  (let (($sumexpand t))
40
 
       (cond ((atom e) e)
41
 
             ((eq (caar e) 'mtimes)     ;puts outside product inside
42
 
              (do ((x (cdr e) (cdr x)) (sum) (notsum))
43
 
                  ((null x) (cond ((null sum)
44
 
                                   (subst0 (cons '(mtimes)
45
 
                                                 (nreverse notsum))
46
 
                                           e))
47
 
                                  (t (simpsum
48
 
                                      (let ((new-index
49
 
                                             (cond ((free (cons nil notsum)
50
 
                                                          (caddr sum))
51
 
                                                    (caddr sum))
52
 
                                                   (t (get-free-index
53
 
                                                       (cons nil (cons sum notsum)))))))
54
 
                                           (setq sum (subst new-index (caddr sum) sum))
55
 
                                           (rplaca (cdr sum) (muln (cons (cadr sum) notsum) t))
56
 
                                           (rplacd (car sum) nil)
57
 
                                           sum)
58
 
                                      1 t))))
59
 
                  (cond ((atom (car x))
60
 
                         (setq notsum (cons (car x) notsum)))
61
 
                        ((eq (caaar x) '%sum)
62
 
                         (setq sum (if (null sum)
63
 
                                       (car x)
64
 
                                       (muln (list sum (car x)) t))))
65
 
                        (t (setq notsum (cons ($sumcontract (car x))
66
 
                                              notsum))))))
67
 
             (t (recur-apply #'$intosum e)))))
 
40
    (cond ((atom e) e)
 
41
          ((eq (caar e) 'mtimes)        ;puts outside product inside
 
42
           (do ((x (cdr e) (cdr x)) (sum) (notsum))
 
43
               ((null x) (cond ((null sum)
 
44
                                (subst0 (cons '(mtimes)
 
45
                                              (nreverse notsum))
 
46
                                        e))
 
47
                               (t (simpsum
 
48
                                   (let ((new-index
 
49
                                          (cond ((free (cons nil notsum)
 
50
                                                       (caddr sum))
 
51
                                                 (caddr sum))
 
52
                                                (t (get-free-index
 
53
                                                    (cons nil (cons sum notsum)))))))
 
54
                                     (setq sum (subst new-index (caddr sum) sum))
 
55
                                     (rplaca (cdr sum) (muln (cons (cadr sum) notsum) t))
 
56
                                     (rplacd (car sum) nil)
 
57
                                     sum)
 
58
                                   1 t))))
 
59
             (cond ((atom (car x))
 
60
                    (setq notsum (cons (car x) notsum)))
 
61
                   ((eq (caaar x) '%sum)
 
62
                    (setq sum (if (null sum)
 
63
                                  (car x)
 
64
                                  (muln (list sum (car x)) t))))
 
65
                   (t (setq notsum (cons ($sumcontract (car x))
 
66
                                         notsum))))))
 
67
          (t (recur-apply #'$intosum e)))))
68
68
 
69
69
(defun sumcontract1 (sums) (addn (sumcontract2 nil sums) t))
70
70
 
71
71
(defun sumcontract2 (result left)
72
 
       (cond ((null left) result)
73
 
             (t ((lambda (x) (sumcontract2 (append (car x) result)
74
 
                                           (cdr x)))
75
 
                 (sumcombine1 (car left) (cdr left))))))
 
72
  (cond ((null left) result)
 
73
        (t ((lambda (x) (sumcontract2 (append (car x) result)
 
74
                                      (cdr x)))
 
75
            (sumcombine1 (car left) (cdr left))))))
76
76
 
77
77
(defun sumcombine1 (pattern llist)
78
 
       (do ((sum pattern) (non-sums nil)
79
 
            (un-matched-sums nil) (try-this-one)
80
 
            (llist llist (cdr llist)))
81
 
           ((null llist) (cons (cons (simpsum (cons '(%sum) sum) 1 t)
82
 
                                    non-sums)
83
 
                              un-matched-sums))
84
 
           (setq try-this-one (car llist))
85
 
           (cond ((and (numberp (sub* (caddr sum) (caddr try-this-one)))
86
 
                       (numberp (sub* (cadddr sum) (cadddr try-this-one))))
87
 
                  ((lambda (x) (setq sum (cdar x)
88
 
                                     non-sums (cons (cdr x) non-sums)))
89
 
                   (sumcombine2 try-this-one sum)))
90
 
                 (t (setq un-matched-sums (cons try-this-one un-matched-sums))))))
 
78
  (do ((sum pattern) (non-sums nil)
 
79
       (un-matched-sums nil) (try-this-one)
 
80
       (llist llist (cdr llist)))
 
81
      ((null llist) (cons (cons (simpsum (cons '(%sum) sum) 1 t)
 
82
                                non-sums)
 
83
                          un-matched-sums))
 
84
    (setq try-this-one (car llist))
 
85
    (cond ((and (numberp (sub* (caddr sum) (caddr try-this-one)))
 
86
                (numberp (sub* (cadddr sum) (cadddr try-this-one))))
 
87
           ((lambda (x) (setq sum (cdar x)
 
88
                              non-sums (cons (cdr x) non-sums)))
 
89
            (sumcombine2 try-this-one sum)))
 
90
          (t (setq un-matched-sums (cons try-this-one un-matched-sums))))))
91
91
 
92
92
(defun sumcombine2 (sum1 sum2)
93
 
       ((lambda (e1 e2 i1 i2 l1 l2 h1 h2)
94
 
                ((lambda (newl newh newi extracted new-sum)
95
 
                         (setq e1 (subst newi i1 e1))
96
 
                         (setq e2 (subst newi i2 e2))
97
 
                         (setq new-sum (list '(%sum)
98
 
                                             (add2 e1 e2)
99
 
                                             newi
100
 
                                             newl
101
 
                                             newh))
102
 
                         (setq extracted
103
 
                               (addn
104
 
                                (mapcar #'dosum
105
 
                                        (list e1 e1 e2 e2)
106
 
                                        (list newi newi newi newi)
107
 
                                        (list l1 (add2 newh 1)
108
 
                                              l2 (add2 newh 1))
109
 
                                        (list (sub* newl 1) h1
110
 
                                              (sub* newl 1) h2)
111
 
                                        '(t t t t))
112
 
                                t))
113
 
                         (cons new-sum extracted))
114
 
                 ($max l1 l2) ($min h1 h2) (cond ((eq i1 i2) i1)
115
 
                                                 ((free e1 i2) i2)
116
 
                                                 ((free e2 i1) i1)
117
 
                                                 (t (get-free-index (list nil
118
 
                                                                          i1 i2
119
 
                                                                          e1 e2
120
 
                                                                          l1 l2
121
 
                                                                          h1 h2))))
122
 
                 nil nil))
123
 
        (car sum1) (car sum2)
124
 
        (cadr sum1) (cadr sum2)
125
 
        (caddr sum1) (caddr sum2)
126
 
        (cadddr sum1) (cadddr sum2)))
 
93
  ((lambda (e1 e2 i1 i2 l1 l2 h1 h2)
 
94
     ((lambda (newl newh newi extracted new-sum)
 
95
        (setq e1 (subst newi i1 e1))
 
96
        (setq e2 (subst newi i2 e2))
 
97
        (setq new-sum (list '(%sum)
 
98
                            (add2 e1 e2)
 
99
                            newi
 
100
                            newl
 
101
                            newh))
 
102
        (setq extracted
 
103
              (addn
 
104
               (mapcar #'dosum
 
105
                       (list e1 e1 e2 e2)
 
106
                       (list newi newi newi newi)
 
107
                       (list l1 (add2 newh 1)
 
108
                             l2 (add2 newh 1))
 
109
                       (list (sub* newl 1) h1
 
110
                             (sub* newl 1) h2)
 
111
                       '(t t t t))
 
112
               t))
 
113
        (cons new-sum extracted))
 
114
      (simplify `(($max) ,l1 ,l2)) (simplify `(($min) ,h1 ,h2))
 
115
      (cond ((eq i1 i2) i1)
 
116
            ((free e1 i2) i2)
 
117
            ((free e2 i1) i1)
 
118
            (t (get-free-index (list nil
 
119
                                     i1 i2
 
120
                                     e1 e2
 
121
                                     l1 l2
 
122
                                     h1 h2))))
 
123
      nil nil))
 
124
   (car sum1) (car sum2)
 
125
   (cadr sum1) (cadr sum2)
 
126
   (caddr sum1) (caddr sum2)
 
127
   (cadddr sum1) (cadddr sum2)))
127
128
 
128
129
(defmvar $niceindicespref '((mlist simp) $i $j $k $l $m $n))
129
130
 
130
131
(defun get-free-index (llist)
131
 
       (or (do ((try-list (cdr $niceindicespref) (cdr try-list)))
132
 
               ((null try-list))
133
 
               (if (free llist (car try-list)) (return (car try-list))))
134
 
           (do ((n 0 (f1+ n)) (try))
135
 
               (nil)
136
 
               (setq try (concat (cadr $niceindicespref) n))
137
 
               (if (free llist try) (return try)))))
 
132
  (or (do ((try-list (cdr $niceindicespref) (cdr try-list)))
 
133
          ((null try-list))
 
134
        (if (free llist (car try-list)) (return (car try-list))))
 
135
      (do ((n 0 (f1+ n)) (try))
 
136
          (nil)
 
137
        (setq try (concat (cadr $niceindicespref) n))
 
138
        (if (free llist try) (return try)))))
138
139
 
139
 
(defmfun $bashindices (e)  ; e is assumed to be simplified
140
 
       (let (($genindex '$j))
141
 
            (cond ((atom e) e)
142
 
                  ((memq (caar e) '(%sum %product))
143
 
                   (sumconsimp (subst (gensumindex) (caddr e) e)))
144
 
                  (t (recur-apply #'$bashindices e)))))
 
140
(defmfun $bashindices (e)              ; e is assumed to be simplified
 
141
  (let (($genindex '$j))
 
142
    (cond ((atom e) e)
 
143
          ((memq (caar e) '(%sum %product))
 
144
           (sumconsimp (subst (gensumindex) (caddr e) e)))
 
145
          (t (recur-apply #'$bashindices e)))))
145
146
 
146
147
(defmfun $niceindices (e)
147
148
  (if (atom e) e
148
 
               (let ((e (recur-apply #'$niceindices e)))
149
 
                    (if (memq (caar e) '(%sum %product))
150
 
                        (sumconsimp (subst (get-free-index e) (caddr e) e))
151
 
                        e))))
 
149
      (let ((e (recur-apply #'$niceindices e)))
 
150
        (if (memq (caar e) '(%sum %product))
 
151
            (sumconsimp (subst (get-free-index e) (caddr e) e))
 
152
            e))))
152
153
 
153
154
(defun sumconsimp (e)
154
155
  (if (and (not (atom e)) (memq (caar e) '(%sum %product)))