share/simplification/stopex.mac

   1 /* -*-Macsyma-*- */
   2 eval_when(batch,ttyoff:true)$
   3 /*ASB;STOPEX 15
   4 2:48pm  Wednesday, 4 November 1981
   5 7:55pm  Saturday, 29 May 1982
   6   Added a DIAGEVAL_VERSION for this file.
   7 1:48pm  Saturday, 12 June 1982
   8   Changed loadflags to getversions, DEFINE_VARIABLE:'MODE.
   9 */
  10
  11 eval_when(translate,
  12           define_variable:'mode,
  13           modedeclare(function(freeofl),boolean))$
  14
  15 put('stopex,15,'diageval_version)$
  16 /*
  17 eval_when([batch,loadfile],
  18           if get('gnauto,'diageval_version)=false
  19           then load('[gnauto,fasl,dsk,dgval]))$
  20 */
  21
  22 /* GNU Maxima */
  23
  24 /* Commented out all local SPECIAL declarations.  For other changes,
  25    search for `Maxima:' below. -wj */
  26
  27 eval_when([batch,loadfile],
  28   if get('gnauto,'diageval_version)=false
  29   then load("genut"))$
  30
  31 eval_when(translate,
  32           declare_translated(exwrt_power1,varmult,distribute,exwrt_power,
  33                              freeofl,stopexpandl1,orpartitionl,ldelete,
  34                              stopexpandl))$
  35
  36 /* Switches  */
  37 define_variable(iforp,false,boolean)$
  38 define_variable(expandwrt_denom,false,boolean)$
  39 define_variable(expandwrt_nonrat,true,boolean)$
  40
  41 stopexpand(exp,[varlist]):=
  42   if atom(exp) or mapatom(exp)
  43   then exp
  44   else block([partswitch:true,inflag:true,piece],
  45              stopexpandl(exp,varlist))$
  46
  47 expandwrt(exp,[varlist]):=
  48   if atom(exp) or mapatom(exp)
  49   then exp
  50   else block([partswitch:true,inflag:true,piece],
  51              stopexpandl(exp,varlist))$
  52
  53 expandwrtl(exp,varlist):=stopexpandl(exp,varlist)$
  54
  55 stopexpandl(exp,varlist):=
  56   if atom(exp) or mapatom(exp)
  57   then exp
  58   else block([inflag:true,partswitch:true,piece,ip0dum],
  59              if (ip0dum:inpart(exp,0))="+"
  60              then map(lambda([termdum],stopexpandl(termdum,varlist)),exp)
  61              else block(
  62   [nonratdum,iforp:true,dendum],
  63   if expandwrt_nonrat
  64   then (nonratdum:
  65         ldelete(varlist,last(orpartitionl(showratvars(exp),"[",varlist))),
  66         for idum in nonratdum do
  67             if not atom(idum)
  68             then exp:subst(map(lambda([dum],stopexpandl(dum,varlist)),idum),
  69                            idum,exp)),
  70   if expandwrt_denom and (dendum:denom(exp))#1
  71   then exp:num(exp)/stopexpandl(dendum,varlist),
  72   stopexpandl1(exp,varlist)))$
  73
  74 stopexpandl1(exp,varlist):=
  75   if atom(exp) or mapatom(exp)
  76   then exp
  77   else block([ip0dum:inpart(exp,0),dum:1,varfound:false],
  78   modedeclare(varfound,boolean),
  79              if freeofl(varlist,exp)
  80              then exp
  81              else if freeof("+",exp) then return(exp),
  82              if ip0dum="+"
  83              then return(map(lambda([termdum],
  84                                     stopexpandl1(termdum,varlist)),exp))
  85              else if ip0dum="^"
  86                   then if inpart(exp,1,0)="+"
  87                        then exwrt_power(exp,varlist)
  88                        else exp
  89                   else if ip0dum="*"
  90                        then (for idum in exp do
  91                                  if not freeofl(varlist,idum)
  92                                  then (idum:stopexpandl1(idum,varlist),
  93                                        if varfound
  94                                        then dum:distribute(dum,idum,varlist)
  95                                        else (varfound:true,
  96                                              dum:varmult(dum,idum,varlist)))
  97                                  else if varfound
  98                                       then dum:varmult(idum,dum,varlist)
  99                                       else dum:dum*idum,
 100                              dum)
 101                        else if matrixp(exp) or listp(exp)
 102                             then matrixmap(lambda([dumm],
 103                                                   stopexpandl1(dumm,varlist)),
 104                                            exp)
 105                             else if ip0dum="." and expandwrt_nonrat
 106                                  then remove_nested_dots0l(map(lambda([dum],
 107                                                               stopexpandl1(dum,
 108                                                                      varlist)),
 109                                                                exp),
 110                                                            varlist)
 111                                  else exp)$
 112
 113 exwrt_power(exp,varlist):=block(
 114   [ip1dum,ip2dum1,exwrtlist,splitdum,fsplitdum],
 115   /* DECLARE(EXWRTLIST,SPECIAL), */
 116   if inpart(exp,0)#"^" then return(exp),
 117   if not freeofl(varlist,ip1dum:inpart(exp,1))
 118      and integerp(ip2dum1:inpart(exp,2))
 119      and (mode_identity(fixnum,ip2dum1))>1
 120      and inpart(ip1dum,0)="+"
 121   then (splitdum:orpartitionl(ip1dum,"+",varlist),
 122         if (fsplitdum:first(splitdum))#0
 123         then (exwrtlist:cons(1,exwrt_power1(last(splitdum),ip2dum1,varlist)),
 124               sum(varmult(fsplitdum^kdum*ip2dum1!/(kdum!*(ip2dum1-kdum)!),
 125                           first(exwrtlist:rest(exwrtlist)),
 126                           varlist),
 127                          /* Maxima: added MODE_IDENTITY for translator */
 128                   kdum,0,mode_identity(fixnum,ip2dum1)))
 129         else first(exwrt_power1(last(splitdum),ip2dum1,varlist)))
 130   else exp)$
 131
 132 exwrt_power1(exp,powerdum,varlist):=(
 133   modedeclare(powerdum,fixnum),
 134  block(
 135   [dum:[exp,1],firstdum:stopexpandl1(exp,varlist)],
 136   if powerdum=1 then return(dum),
 137   if inpart(exp,0)#"+"
 138   then for idum:2 thru powerdum do
 139            dum:cons(exp^idum,dum)
 140   else for idum:2 thru powerdum do
 141            dum:cons(firstdum:
 142                     map(lambda([dum],multthru(dum,firstdum)),exp),dum),
 143   dum))$
 144
 145 varmult(fact,exp,varlist):=block(
 146   [splitdum:orpartitionl(exp,"+",varlist)],
 147   fact*first(splitdum)+multthru(fact,last(splitdum)))$
 148
 149 distribute(exp1,exp2,varlist):=block(
 150   [splitexp1:orpartitionl(exp1,"+",varlist),
 151    splitexp2:orpartitionl(exp2,"+",varlist),
 152    fsplexp1,fsplexp2,lsplexp1,lsplexp2],
 153   lsplexp1:last(splitexp1),
 154   lsplexp2:last(splitexp2),
 155   (fsplexp1:first(splitexp1))*(fsplexp2:first(splitexp2))
 156   +(if fsplexp1#0
 157     then varmult(fsplexp1,stopexpandl1(lsplexp2,varlist),varlist)
 158     else 0)
 159   +(if fsplexp2#0
 160     then varmult(fsplexp2,stopexpandl1(lsplexp1,varlist),varlist)
 161     else 0)
 162   +(if inpart(lsplexp1,0)="+"
 163     then map(lambda([term],stopexpandl1(term*lsplexp2,varlist)),lsplexp1)
 164     else if inpart(lsplexp2,0)="+"
 165          then map(lambda([term],stopexpandl1(term*lsplexp1,varlist)),lsplexp2)
 166          else lsplexp1*lsplexp2))$
 167
 168 expandwrt_factored(exp,[varlist]):=
 169   if listp(exp) or matrixp(exp)
 170   then matrixmap(lambda([dum],apply('expandwrt_factored,cons(dum,varlist))),
 171                  exp)
 172   else block([iforp:true,piece,partswitch:true,inflag:true,dum],
 173              dum:orpartitionl(exp,"*",varlist),
 174              first(dum)*stopexpandl(last(dum),varlist))$
 175
 176 eval_when(batch,ttyoff:false)$