share/misc/declin.mac

   1 /* -*- Macsyma -*- */
   2 eval_when(batch,ttyoff:true)$
   3 /*ASB;DECLIN 6
   4 12:28pm  Saturday, 13 March 1982
   5   Removed GETSYMBOL and PUTSYMBOL to GENUT.  Not recompiled.
   6 7:42pm  Saturday, 29 May 1982
   7   Added a DIAGEVAL_VERSION for this file.
   8 1:18pm  Saturday, 12 June 1982
   9   Changed loadflags to getversions, DEFINE_VARIABLE:'MODE.
  10 */
  11
  12 eval_when(batch,
  13           if get('debug,'version)=false and status(feature,its)=true
  14           then load('[debug,fasl,dsk,dgval]))$
  15
  16 /* can't be translated in DOE-MACSYMA without extra files
  17 EVAL_WHEN([TRANSLATE],
  18           IF GET('GRAPH,'VERSION)=FALSE AND INDEPENDENT#TRUE
  19           THEN LOAD(graph),
  20           DEFINE_VARIABLE:'MODE,
  21           MODEDECLARE(FUNCTION(NULLLISTP,ZEROLISTP,LCLINEARP1,LCLINEARP2,
  22                                LCPRED,ONEONLY),
  23                       BOOLEAN),
  24           DECLARE([GNAUTOLOAD,OPDUM,LINPREDDUM,LINPOSNS],SPECIAL))$
  25 */
  26 put('declin,6,'version)$
  27 /* don't have this file in DOE-MACSYMA
  28 EVAL_WHEN(LOADFILE,
  29           IF GET('GNAUTO,'VERSION)=FALSE
  30           THEN LOAD(['GNAUTO,'FASL,'DSK,'DGVAL]))$
  31 */
  32
  33 /* GNU Maxima */
  34
  35 /* Commented out all local SPECIAL declarations.
  36    Replaced PUTSYMBOL by PUT and GETSYMBOL by GET (there were no PUT or GET).
  37    For other changes, search for `Maxima:' below. -wj */
  38
  39 eval_when([batch,loadfile],
  40   if get('gnauto,'diageval_version)=false
  41   then load("simplification/genut"))$
  42
  43 eval_when(translate,
  44           declare_translated(unscramble,factorargs,linopprod,linopprod0,
  45                              rloiewl,predpartition,zerolistp,explicitfactor,
  46                              orpartitionlist,linopsum2,lclinearp,linopsum1,
  47                              linopprod1,setlist,findasymbol,noopsubst,
  48                              linopsum0,lcpred,lclinearp1,nulllistp),
  49           mode_declare(function(nulllistp,zerolistp,lclinearp1,lclinearp2,
  50                                 lcpred,oneonly),boolean))$
  51
  52 define_variable(messdeclin1,
  53                 "contains an undeclared operator--linsimp.",
  54                 any)$
  55
  56 lclinearp(list,opdum):=block(
  57   [yesopsdum:last(partition(list,opdum))],
  58   is(nulllistp(yesopsdum) or lclinearp1(apply("+",yesopsdum),opdum)))$
  59
  60 lclinearp1(exp,opdum):=
  61   lcpred(lambda([dum],lclinearp1(dum,opdum)),
  62          lambda([dum],is(inpart(dum,0)=opdum)),exp)$
  63
  64 linsimp(exp,opdum1,[opdumlist]):=
  65   if opdumlist=[]
  66   then linopsum0(exp,opdum1)
  67   else apply('linsimp,cons(linopsum0(exp,opdum1),opdumlist))$
  68
  69 linopsum0(exp,opdum):=block(
  70   [linposns,getdum,linpreddum,lvarsdum:listofvars(exp),substflag:false,newdum,
  71    ansdum,piece,inflag:true,partswitch:true],
  72   modedeclare(substflag,boolean),
  73   if (getdum:get(opdum,'linear_operator))=false
  74   then error(opdum,messdeclin1),
  75   if member(opdum,lvarsdum)
  76   then (substflag:true,
  77         exp:noopsubst(newdum:findasymbol(lvarsdum),opdum,exp)),
  78   setlist(getdum,'linposns,'linpreddum),
  79     ansdum:linopprod1(subst(lambda([[sulist]],
  80                               if freeof(opdum,sulist)
  81                               then apply("+",sulist)
  82                               else linopsum1(sulist,opdum)),"+",exp),
  83                     opdum,linposns,linpreddum),
  84   if not substflag
  85   then ansdum
  86   else subst(opdum,newdum,ansdum))$
  87
  88 linopsum1(list,opdum):=block(
  89   [ansdum,linopansdum],
  90   if not lclinearp(list,opdum) then return(apply("+",list)),
  91   setlist(partition(list,opdum),'ansdum,'linopansdum),
  92   apply("+",ansdum)
  93   +if length(linopansdum)<2
  94    then first(linopansdum)
  95    else linopsum2([first(linopansdum)],rest(linopansdum),opdum))$
  96 \f
  97 linopsum2(examineddum,unexaminedyetdum,opdum):=block(
  98   [cofexdum,cofunexdum,exdum,unexdum,lexdum:1,exfoundflag:false,argsundum,
  99    argsexadum,lunexdum,argsundum456,undum,exadum,newargsdum,fnewargsdum],
 100   modedeclare([lunexdum,lexdum],fixnum,exfoundflag,boolean),
 101   setlist(orpartitionlist(examineddum,"*",opdum),'cofexdum,'exdum),
 102   setlist(orpartitionlist(unexaminedyetdum,"*",opdum),
 103           'cofunexdum,'unexdum),
 104   lunexdum:length(unexdum),
 105   for idum thru lunexdum do
 106      (argsundum456:inpart(argsundum:
 107                           args(undum:inpart(unexdum,idum)),
 108                           apply('allbut,linposns)),
 109       for jdum thru lexdum do
 110          (exadum:inpart(exdum,jdum),
 111           if argsundum456=inpart(argsexadum:args(exadum),
 112                                  apply('allbut,linposns))
 113           then (newargsdum:
 114                 explicitfactor(inpart(argsundum,linposns)
 115                                 *inpart(cofunexdum,idum)
 116                                 +inpart(argsexadum,linposns)
 117                                 *inpart(cofexdum,jdum)),
 118                 if zerolistp(last(newargsdum))
 119                 then (exdum:inpart(exdum,allbut(jdum)),
 120                       cofexdum:inpart(cofexdum,allbut(jdum)),
 121                       lexdum:lexdum-1,
 122                       return(exfoundflag:true)),
 123                 fnewargsdum:
 124                 maplist(lambda([dum],apply("*",dum)),
 125                         predpartition(rloiewl("*",first(newargsdum)),
 126                                       linpreddum)),
 127                 cofexdum:substinpart(first(fnewargsdum),cofexdum,jdum),
 128                 exdum:substinpart(apply(opdum,
 129                                         append(last(newargsdum)
 130                                                 *last(fnewargsdum),
 131                                                argsundum456)),
 132                                   exdum,jdum),
 133                 return(exfoundflag:true))),
 134       if not exfoundflag
 135       then (exdum:endcons(undum,exdum),
 136             cofexdum:endcons(inpart(cofunexdum,idum),cofexdum),
 137             lexdum:lexdum+1)
 138       else exfoundflag:false),
 139   apply("+",cofexdum*exdum))$
 140
 141 linopprod(exp,opdum1,[opdumlist]):=
 142   if opdumlist=[]
 143   then linopprod0(exp,opdum1)
 144   else linopprod(linopprod0(exp,opdum1),first(opdumlist),rest(opdumlist))$
 145
 146 linopprod0(exp,opdum):=block(
 147   [linposns,getdum,linpreddum,newdum,lvarsdum:listofvars(exp),
 148    piece,inflag:true,partswitch:true],
 149   if (getdum:get(opdum,'linear_operator))=false
 150   then error(opdum,messdeclin1),
 151   setlist(getdum,'linposns,'linpreddum),
 152   if member(opdum,lvarsdum)
 153   then subst(opdum,newdum:findasymbol(lvarsdum),
 154              linopprod1(noopsubst(newdum,opdum,exp),opdum,linposns,linpreddum))
 155   else linopprod1(exp,opdum,linposns,linpreddum))$
 156
 157 linopprod1(exp,opdum,linposns,linpreddum):=
 158   subst(lambda([[arglist]],factorargs(arglist,opdum,linposns,linpreddum)),
 159                 opdum,exp)$
 160
 161 findasymbol(lvarsdum):=block(
 162   [newdum:?gensym()],
 163   if not member(newdum,lvarsdum)
 164   then newdum
 165   else findasymbol(lvarsdum))$
 166
 167 noopsubst(expdum1,expdum2,expdum3):=block(
 168   [opsubst:false],
 169   subst(expdum1,expdum2,expdum3))$
 170
 171 factorargs(argsdum,opdum,linposns,linpreddum):=block(
 172   [newargsdum:explicitfactor(inpart(argsdum,linposns)),lastnewargsdum,
 173    fnewargsdum],
 174   if zerolistp(lastnewargsdum:last(newargsdum)) then return(0),
 175   fnewargsdum:maplist('listtoprod,
 176                       predpartition(rloiewl("*",first(newargsdum)),
 177                                     linpreddum)),
 178   if orderlessp(last(fnewargsdum),-last(fnewargsdum))
 179   then fnewargsdum:-fnewargsdum,
 180   apply(opdum,unscramble(argsdum,lastnewargsdum*last(fnewargsdum),linposns))
 181         *first(fnewargsdum))$
 182
 183 unscramble(list,newlist,linposns):=block(
 184   [llist:length(newlist)],
 185   modedeclare(llist,fixnum),
 186   for idum thru llist do
 187       list:substinpart(inpart(newlist,idum),list,inpart(linposns,idum)),
 188   list)$
 189
 190 declare_linear_operator(opdum,linposns,predicate):=block(
 191   [piece,inflag:true,partswitch:true],
 192   put(opdum,[linposns,predicate],'linear_operator))$
 193 \f
 194 sym&&
 195
 196 /* symmetry declarations */
 197
 198 declare_symmetry(opdum,symfcn,symsortfcn,symtype):=block(
 199   [piece,inflag:true,partswitch:true],
 200   put(opdum,[symfcn,symsortfcn],symtype))$
 201
 202 applysymmetry(exp,opdum,symtype):=block(
 203   [getdum:get(opdum,symtype),piece,inflag:true,partswitch:true],
 204   if getdum=false then return(exp),
 205   subst(lambda([[arglist]],
 206                apply('aplsym1,append(getdum,[arglist,opdum]))),
 207         opdum,exp))$
 208
 209 aplsym1(symfcn,symsortfcn,list,opdum):=block(
 210   [allsyms:apply(symfcn,[apply(opdum,list)]),allsymsdum,exitblock:false],
 211   modedeclare(exitblock,boolean),
 212   allsymsdum:allsyms,
 213   for idum in allsyms do
 214       if member(-idum,allsymsdum:rest(allsymsdum))
 215       then return(exitblock:true),
 216   if exitblock
 217   then 0
 218   else first(sort(allsyms,symsortfcn)))$
 219
 220 declare_zero(opdum,preddum,zerotype):=block(
 221   [piece,inflag:true,partswitch:true],
 222   put(opdum,preddum,zerotype))$
 223
 224 applyzero(exp,opdum,zerotype):=block(
 225   [getdum:get(opdum,zerotype),piece,inflag:true,partswitch:true],
 226   if getdum=false then return(exp),
 227   subst(lambda([[arglist]],if mode_identity(boolean,apply(getdum,[arglist]))
 228                            then 0
 229                            else apply(opdum,arglist)),
 230         opdum,exp))$
 231
 232 dev&&
 233 eval_when(batch,
 234           if development=true
 235           then (declare_linear_operator(f,[1,2,3],kpred),
 236                 declare_symmetry(f,fsym,sort,all),
 237                 fsym(fesp):=[inpart(fesp,[2,3,1,5,6,4]),
 238                              inpart(fesp,[3,1,2,6,4,5]),
 239                              inpart(fesp,[1,2,3,4,5,6]),
 240                              -inpart(fesp,[3,2,1,6,5,4]),
 241                              -inpart(fesp,[2,1,3,5,4,6]),
 242                              -inpart(fesp,[1,3,2,4,6,5])],
 243                 t1():=linsimp(f(a,b,c,d,e,h)-f(a,b,c,d,h,e),f),
 244                 kpred(exp):=freeofl([k1,k2,k3,k4],exp)))$
 245
 246 eval_when(batch,ttyoff:false)$