← Back to branch summary

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

« back to all changes in this revision

Viewing changes to share/simplification/stopex.mac

  • 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:
share/simplification/stopex.mac
1
1
/* -*-Macsyma-*- */
2
 
EVAL_WHEN(BATCH,TTYOFF:TRUE)$
 
2
eval_when(batch,ttyoff:true)$
3
3
/*ASB;STOPEX 15
4
4
2:48pm  Wednesday, 4 November 1981
5
5
7:55pm  Saturday, 29 May 1982
8
8
  Changed loadflags to getversions, DEFINE_VARIABLE:'MODE.
9
9
*/
10
10
 
11
 
EVAL_WHEN(TRANSLATE,
12
 
          TRANSCOMPILE:TRUE,
13
 
          DEFINE_VARIABLE:'MODE,
14
 
          MODEDECLARE(FUNCTION(FREEOFL),BOOLEAN))$
 
11
eval_when(translate,
 
12
          transcompile:true,
 
13
          define_variable:'mode,
 
14
          modedeclare(function(freeofl),boolean))$
15
15
 
16
 
PUT('STOPEX,15,'DIAGEVAL_VERSION)$
 
16
put('stopex,15,'diageval_version)$
17
17
/*
18
18
EVAL_WHEN([BATCH,LOADFILE],
19
19
          IF GET('GNAUTO,'DIAGEVAL_VERSION)=FALSE
26
26
   search for `Maxima:' below. -wj */
27
27
 
28
28
eval_when([batch,loadfile],
29
 
  if get('GNAUTO,'DIAGEVAL_VERSION)=false
 
29
  if get('gnauto,'diageval_version)=false
30
30
  then load("genut"))$
31
31
 
32
32
eval_when(translate,
33
 
          declare_translated(EXWRT_POWER1,VARMULT,DISTRIBUTE,EXWRT_POWER,
34
 
                             FREEOFL,STOPEXPANDL1,ORPARTITIONL,LDELETE,
35
 
                             STOPEXPANDL))$
 
33
          declare_translated(exwrt_power1,varmult,distribute,exwrt_power,
 
34
                             freeofl,stopexpandl1,orpartitionl,ldelete,
 
35
                             stopexpandl))$
36
36
 
37
37
/* Switches  */
38
 
DEFINE_VARIABLE(IFORP,FALSE,BOOLEAN)$
39
 
DEFINE_VARIABLE(EXPANDWRT_DENOM,FALSE,BOOLEAN)$
40
 
DEFINE_VARIABLE(EXPANDWRT_NONRAT,TRUE,BOOLEAN)$
41
 
 
42
 
STOPEXPAND(EXP,[VARLIST]):=
43
 
  IF ATOM(EXP) OR MAPATOM(EXP)
44
 
  THEN EXP
45
 
  ELSE BLOCK([PARTSWITCH:TRUE,INFLAG:TRUE,PIECE],
46
 
             STOPEXPANDL(EXP,VARLIST))$
47
 
 
48
 
EXPANDWRT(EXP,[VARLIST]):=
49
 
  IF ATOM(EXP) OR MAPATOM(EXP)
50
 
  THEN EXP
51
 
  ELSE BLOCK([PARTSWITCH:TRUE,INFLAG:TRUE,PIECE],
52
 
             STOPEXPANDL(EXP,VARLIST))$
53
 
 
54
 
EXPANDWRTL(EXP,VARLIST):=STOPEXPANDL(EXP,VARLIST)$
55
 
 
56
 
STOPEXPANDL(EXP,VARLIST):=  
57
 
  IF ATOM(EXP) OR MAPATOM(EXP)
58
 
  THEN EXP
59
 
  ELSE BLOCK([INFLAG:TRUE,PARTSWITCH:TRUE,PIECE,IP0DUM],
60
 
             IF (IP0DUM:INPART(EXP,0))="+"
61
 
             THEN MAP(LAMBDA([TERMDUM],STOPEXPANDL(TERMDUM,VARLIST)),EXP)
62
 
             ELSE BLOCK(
63
 
  [NONRATDUM,IFORP:TRUE,DENDUM],
64
 
  IF EXPANDWRT_NONRAT
65
 
  THEN (NONRATDUM:
66
 
        LDELETE(VARLIST,LAST(ORPARTITIONL(SHOWRATVARS(EXP),"[",VARLIST))),
67
 
        FOR IDUM IN NONRATDUM DO
68
 
            IF NOT ATOM(IDUM)
69
 
            THEN EXP:SUBST(MAP(LAMBDA([DUM],STOPEXPANDL(DUM,VARLIST)),IDUM),
70
 
                           IDUM,EXP)),
71
 
  IF EXPANDWRT_DENOM AND (DENDUM:DENOM(EXP))#1
72
 
  THEN EXP:NUM(EXP)/STOPEXPANDL(DENDUM,VARLIST),
73
 
  STOPEXPANDL1(EXP,VARLIST)))$
74
 
 
75
 
STOPEXPANDL1(EXP,VARLIST):=
76
 
  IF ATOM(EXP) OR MAPATOM(EXP)
77
 
  THEN EXP
78
 
  ELSE BLOCK([IP0DUM:INPART(EXP,0),DUM:1,VARFOUND:FALSE],
79
 
  MODEDECLARE(VARFOUND,BOOLEAN),
80
 
             IF FREEOFL(VARLIST,EXP)
81
 
             THEN EXP
82
 
             ELSE IF FREEOF("+",EXP) THEN RETURN(EXP),
83
 
             IF IP0DUM="+"
84
 
             THEN RETURN(MAP(LAMBDA([TERMDUM],
85
 
                                    STOPEXPANDL1(TERMDUM,VARLIST)),EXP))
86
 
             ELSE IF IP0DUM="^"
87
 
                  THEN IF INPART(EXP,1,0)="+"
88
 
                       THEN EXWRT_POWER(EXP,VARLIST)
89
 
                       ELSE EXP
90
 
                  ELSE IF IP0DUM="*"
91
 
                       THEN (FOR IDUM IN EXP DO
92
 
                                 IF NOT FREEOFL(VARLIST,IDUM)
93
 
                                 THEN (IDUM:STOPEXPANDL1(IDUM,VARLIST),
94
 
                                       IF VARFOUND
95
 
                                       THEN DUM:DISTRIBUTE(DUM,IDUM,VARLIST)
96
 
                                       ELSE (VARFOUND:TRUE,
97
 
                                             DUM:VARMULT(DUM,IDUM,VARLIST)))
98
 
                                 ELSE IF VARFOUND
99
 
                                      THEN DUM:VARMULT(IDUM,DUM,VARLIST)
100
 
                                      ELSE DUM:DUM*IDUM,
101
 
                             DUM)
102
 
                       ELSE IF MATRIXP(EXP) OR LISTP(EXP)
103
 
                            THEN MATRIXMAP(LAMBDA([DUMM],
104
 
                                                  STOPEXPANDL1(DUMM,VARLIST)),
105
 
                                           EXP)
106
 
                            ELSE IF IP0DUM="." AND EXPANDWRT_NONRAT
107
 
                                 THEN REMOVE_NESTED_DOTS0L(MAP(LAMBDA([DUM],
108
 
                                                              STOPEXPANDL1(DUM,
109
 
                                                                     VARLIST)),
110
 
                                                               EXP),
111
 
                                                           VARLIST)
112
 
                                 ELSE EXP)$
113
 
 
114
 
EXWRT_POWER(EXP,VARLIST):=BLOCK(
115
 
  [IP1DUM,IP2DUM1,EXWRTLIST,SPLITDUM,FSPLITDUM],
 
38
define_variable(iforp,false,boolean)$
 
39
define_variable(expandwrt_denom,false,boolean)$
 
40
define_variable(expandwrt_nonrat,true,boolean)$
 
41
 
 
42
stopexpand(exp,[varlist]):=
 
43
  if atom(exp) or mapatom(exp)
 
44
  then exp
 
45
  else block([partswitch:true,inflag:true,piece],
 
46
             stopexpandl(exp,varlist))$
 
47
 
 
48
expandwrt(exp,[varlist]):=
 
49
  if atom(exp) or mapatom(exp)
 
50
  then exp
 
51
  else block([partswitch:true,inflag:true,piece],
 
52
             stopexpandl(exp,varlist))$
 
53
 
 
54
expandwrtl(exp,varlist):=stopexpandl(exp,varlist)$
 
55
 
 
56
stopexpandl(exp,varlist):=  
 
57
  if atom(exp) or mapatom(exp)
 
58
  then exp
 
59
  else block([inflag:true,partswitch:true,piece,ip0dum],
 
60
             if (ip0dum:inpart(exp,0))="+"
 
61
             then map(lambda([termdum],stopexpandl(termdum,varlist)),exp)
 
62
             else block(
 
63
  [nonratdum,iforp:true,dendum],
 
64
  if expandwrt_nonrat
 
65
  then (nonratdum:
 
66
        ldelete(varlist,last(orpartitionl(showratvars(exp),"[",varlist))),
 
67
        for idum in nonratdum do
 
68
            if not atom(idum)
 
69
            then exp:subst(map(lambda([dum],stopexpandl(dum,varlist)),idum),
 
70
                           idum,exp)),
 
71
  if expandwrt_denom and (dendum:denom(exp))#1
 
72
  then exp:num(exp)/stopexpandl(dendum,varlist),
 
73
  stopexpandl1(exp,varlist)))$
 
74
 
 
75
stopexpandl1(exp,varlist):=
 
76
  if atom(exp) or mapatom(exp)
 
77
  then exp
 
78
  else block([ip0dum:inpart(exp,0),dum:1,varfound:false],
 
79
  modedeclare(varfound,boolean),
 
80
             if freeofl(varlist,exp)
 
81
             then exp
 
82
             else if freeof("+",exp) then return(exp),
 
83
             if ip0dum="+"
 
84
             then return(map(lambda([termdum],
 
85
                                    stopexpandl1(termdum,varlist)),exp))
 
86
             else if ip0dum="^"
 
87
                  then if inpart(exp,1,0)="+"
 
88
                       then exwrt_power(exp,varlist)
 
89
                       else exp
 
90
                  else if ip0dum="*"
 
91
                       then (for idum in exp do
 
92
                                 if not freeofl(varlist,idum)
 
93
                                 then (idum:stopexpandl1(idum,varlist),
 
94
                                       if varfound
 
95
                                       then dum:distribute(dum,idum,varlist)
 
96
                                       else (varfound:true,
 
97
                                             dum:varmult(dum,idum,varlist)))
 
98
                                 else if varfound
 
99
                                      then dum:varmult(idum,dum,varlist)
 
100
                                      else dum:dum*idum,
 
101
                             dum)
 
102
                       else if matrixp(exp) or listp(exp)
 
103
                            then matrixmap(lambda([dumm],
 
104
                                                  stopexpandl1(dumm,varlist)),
 
105
                                           exp)
 
106
                            else if ip0dum="." and expandwrt_nonrat
 
107
                                 then remove_nested_dots0l(map(lambda([dum],
 
108
                                                              stopexpandl1(dum,
 
109
                                                                     varlist)),
 
110
                                                               exp),
 
111
                                                           varlist)
 
112
                                 else exp)$
 
113
 
 
114
exwrt_power(exp,varlist):=block(
 
115
  [ip1dum,ip2dum1,exwrtlist,splitdum,fsplitdum],
116
116
  /* DECLARE(EXWRTLIST,SPECIAL), */
117
 
  IF INPART(EXP,0)#"^" THEN RETURN(EXP),
118
 
  IF NOT FREEOFL(VARLIST,IP1DUM:INPART(EXP,1))
119
 
     AND INTEGERP(IP2DUM1:INPART(EXP,2))
120
 
     AND (MODE_IDENTITY(FIXNUM,IP2DUM1))>1
121
 
     AND INPART(IP1DUM,0)="+"
122
 
  THEN (SPLITDUM:ORPARTITIONL(IP1DUM,"+",VARLIST),
123
 
        IF (FSPLITDUM:FIRST(SPLITDUM))#0
124
 
        THEN (EXWRTLIST:CONS(1,EXWRT_POWER1(LAST(SPLITDUM),IP2DUM1,VARLIST)),
125
 
              SUM(VARMULT(FSPLITDUM^KDUM*IP2DUM1!/(KDUM!*(IP2DUM1-KDUM)!),
126
 
                          FIRST(EXWRTLIST:REST(EXWRTLIST)),
127
 
                          VARLIST),
 
117
  if inpart(exp,0)#"^" then return(exp),
 
118
  if not freeofl(varlist,ip1dum:inpart(exp,1))
 
119
     and integerp(ip2dum1:inpart(exp,2))
 
120
     and (mode_identity(fixnum,ip2dum1))>1
 
121
     and inpart(ip1dum,0)="+"
 
122
  then (splitdum:orpartitionl(ip1dum,"+",varlist),
 
123
        if (fsplitdum:first(splitdum))#0
 
124
        then (exwrtlist:cons(1,exwrt_power1(last(splitdum),ip2dum1,varlist)),
 
125
              sum(varmult(fsplitdum^kdum*ip2dum1!/(kdum!*(ip2dum1-kdum)!),
 
126
                          first(exwrtlist:rest(exwrtlist)),
 
127
                          varlist),
128
128
                         /* Maxima: added MODE_IDENTITY for translator */
129
 
                  KDUM,0,MODE_IDENTITY(FIXNUM,IP2DUM1)))
130
 
        ELSE FIRST(EXWRT_POWER1(LAST(SPLITDUM),IP2DUM1,VARLIST)))
131
 
  ELSE EXP)$
132
 
 
133
 
EXWRT_POWER1(EXP,POWERDUM,VARLIST):=(
134
 
  MODEDECLARE(POWERDUM,FIXNUM),
135
 
 BLOCK(
136
 
  [DUM:[EXP,1],FIRSTDUM:STOPEXPANDL1(EXP,VARLIST)],
137
 
  IF POWERDUM=1 THEN RETURN(DUM),
138
 
  IF INPART(EXP,0)#"+"
139
 
  THEN FOR IDUM:2 THRU POWERDUM DO
140
 
           DUM:CONS(EXP^IDUM,DUM)
141
 
  ELSE FOR IDUM:2 THRU POWERDUM DO
142
 
           DUM:CONS(FIRSTDUM:
143
 
                    MAP(LAMBDA([DUM],MULTTHRU(DUM,FIRSTDUM)),EXP),DUM),
144
 
  DUM))$
145
 
 
146
 
VARMULT(FACT,EXP,VARLIST):=BLOCK(
147
 
  [SPLITDUM:ORPARTITIONL(EXP,"+",VARLIST)],
148
 
  FACT*FIRST(SPLITDUM)+MULTTHRU(FACT,LAST(SPLITDUM)))$
149
 
 
150
 
DISTRIBUTE(EXP1,EXP2,VARLIST):=BLOCK(
151
 
  [SPLITEXP1:ORPARTITIONL(EXP1,"+",VARLIST),
152
 
   SPLITEXP2:ORPARTITIONL(EXP2,"+",VARLIST),
153
 
   FSPLEXP1,FSPLEXP2,LSPLEXP1,LSPLEXP2],
154
 
  LSPLEXP1:LAST(SPLITEXP1),
155
 
  LSPLEXP2:LAST(SPLITEXP2),
156
 
  (FSPLEXP1:FIRST(SPLITEXP1))*(FSPLEXP2:FIRST(SPLITEXP2))
157
 
  +(IF FSPLEXP1#0
158
 
    THEN VARMULT(FSPLEXP1,STOPEXPANDL1(LSPLEXP2,VARLIST),VARLIST)
159
 
    ELSE 0)
160
 
  +(IF FSPLEXP2#0
161
 
    THEN VARMULT(FSPLEXP2,STOPEXPANDL1(LSPLEXP1,VARLIST),VARLIST)
162
 
    ELSE 0)
163
 
  +(IF INPART(LSPLEXP1,0)="+"
164
 
    THEN MAP(LAMBDA([TERM],STOPEXPANDL1(TERM*LSPLEXP2,VARLIST)),LSPLEXP1)
165
 
    ELSE IF INPART(LSPLEXP2,0)="+"
166
 
         THEN MAP(LAMBDA([TERM],STOPEXPANDL1(TERM*LSPLEXP1,VARLIST)),LSPLEXP2)
167
 
         ELSE LSPLEXP1*LSPLEXP2))$
168
 
 
169
 
EXPANDWRT_FACTORED(EXP,[VARLIST]):=
170
 
  IF LISTP(EXP) OR MATRIXP(EXP)
171
 
  THEN MATRIXMAP(LAMBDA([DUM],APPLY('EXPANDWRT_FACTORED,CONS(DUM,VARLIST))),
172
 
                 EXP)
173
 
  ELSE BLOCK([IFORP:TRUE,PIECE,PARTSWITCH:TRUE,INFLAG:TRUE,DUM],
174
 
             DUM:ORPARTITIONL(EXP,"*",VARLIST),
175
 
             FIRST(DUM)*STOPEXPANDL(LAST(DUM),VARLIST))$
176
 
 
177
 
EVAL_WHEN(BATCH,TTYOFF:FALSE)$
 
129
                  kdum,0,mode_identity(fixnum,ip2dum1)))
 
130
        else first(exwrt_power1(last(splitdum),ip2dum1,varlist)))
 
131
  else exp)$
 
132
 
 
133
exwrt_power1(exp,powerdum,varlist):=(
 
134
  modedeclare(powerdum,fixnum),
 
135
 block(
 
136
  [dum:[exp,1],firstdum:stopexpandl1(exp,varlist)],
 
137
  if powerdum=1 then return(dum),
 
138
  if inpart(exp,0)#"+"
 
139
  then for idum:2 thru powerdum do
 
140
           dum:cons(exp^idum,dum)
 
141
  else for idum:2 thru powerdum do
 
142
           dum:cons(firstdum:
 
143
                    map(lambda([dum],multthru(dum,firstdum)),exp),dum),
 
144
  dum))$
 
145
 
 
146
varmult(fact,exp,varlist):=block(
 
147
  [splitdum:orpartitionl(exp,"+",varlist)],
 
148
  fact*first(splitdum)+multthru(fact,last(splitdum)))$
 
149
 
 
150
distribute(exp1,exp2,varlist):=block(
 
151
  [splitexp1:orpartitionl(exp1,"+",varlist),
 
152
   splitexp2:orpartitionl(exp2,"+",varlist),
 
153
   fsplexp1,fsplexp2,lsplexp1,lsplexp2],
 
154
  lsplexp1:last(splitexp1),
 
155
  lsplexp2:last(splitexp2),
 
156
  (fsplexp1:first(splitexp1))*(fsplexp2:first(splitexp2))
 
157
  +(if fsplexp1#0
 
158
    then varmult(fsplexp1,stopexpandl1(lsplexp2,varlist),varlist)
 
159
    else 0)
 
160
  +(if fsplexp2#0
 
161
    then varmult(fsplexp2,stopexpandl1(lsplexp1,varlist),varlist)
 
162
    else 0)
 
163
  +(if inpart(lsplexp1,0)="+"
 
164
    then map(lambda([term],stopexpandl1(term*lsplexp2,varlist)),lsplexp1)
 
165
    else if inpart(lsplexp2,0)="+"
 
166
         then map(lambda([term],stopexpandl1(term*lsplexp1,varlist)),lsplexp2)
 
167
         else lsplexp1*lsplexp2))$
 
168
 
 
169
expandwrt_factored(exp,[varlist]):=
 
170
  if listp(exp) or matrixp(exp)
 
171
  then matrixmap(lambda([dum],apply('expandwrt_factored,cons(dum,varlist))),
 
172
                 exp)
 
173
  else block([iforp:true,piece,partswitch:true,inflag:true,dum],
 
174
             dum:orpartitionl(exp,"*",varlist),
 
175
             first(dum)*stopexpandl(last(dum),varlist))$
 
176
 
 
177
eval_when(batch,ttyoff:false)$