share/simplification/genut.mac

   1 /* genut.mac -*- mode: Maxima; -*- */
   2
   3 /* Copyright (C) 2002 Wolfgang Jenkner <wjenkner@inode.at>
   4  *
   5  * This file is part of GNU Maxima.
   6  *
   7  * This program is free software; you can redistribute it and/or
   8  * modify it under the terms of the GNU General Public License as
   9  * published by the Free Software Foundation; either version 2 of
  10  * the License, or (at your option) any later version.
  11  *
  12  * This program is distributed in the hope that it will be
  13  * useful, but WITHOUT ANY WARRANTY; without even the implied
  14  * warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
  15  * PURPOSE.  See the GNU General Public License for more details.
  16  *
  17  * Commentary:
  18  * Utility functions needed for stopex, facexp, facex1, declin and disol.
  19  *
  20  * History:
  21  * The original version seems to be lost. However, the headers of
  22  * some of the files above (and of rncomb.mac) suggest the following
  23  * story (please tell me if you know more about it):
  24  *
  25  * The files mentioned above were developed by ASB (who is this/are they?)
  26  * at least between November 1981 and May 1983.  The now missing functions
  27  * used to live in a file called GENUT (also written by ASB?).  This file
  28  * (or at least the functionality it implements) became part of the Symbolics
  29  * branch of Macsyma but it didn't get into DOE Macsyma (although they were
  30  * aware of its existence since they did have the files depending on it).
  31  *
  32  * Note that facexp contains also some functions (mentioned at the end of
  33  * facexp.usg) which rely on some tensor package called DIAGEVAL to which
  34  * GENUT seems to be somehow related.  However, in this case, neither the
  35  * package itself nor any description seems to be extant in Maxima.
  36  *
  37  * v. 0.1 (March 2002):
  38  *   First public version.
  39  *
  40  * v. 1.0 = CVS:1.1 (June 2002):
  41  *   Changes for translation.
  42  *   Rewrote some functions and added comments.
  43  *   Added missing functions for declin.
  44  *   Except for bug fixes, genut seems to be complete.  Note that, as
  45  *   far as I can tell, the tensor manipulation functions mentioned
  46  *   above were never, and will never be, supported by genut.
  47  *
  48  *   For more recent changes, please see the file `ChangeLog' in the
  49  *   top-level directory of the Maxima distribution.
  50  */
  51
  52 /* Note that we have to use upper case for function or variable names
  53    which are to be used by old code (because FOO is translated to $FOO
  54    and foo to |$foo|). */
  55
  56 eval_when(translate,
  57           declare_translated(orpartition,orpartitionl,nonumfactor,
  58                              genut_prodmap,listofops_nonratl,setlist,
  59                              predpartition),
  60           mode_declare(function(nulllistp,freeofl,zerolistp,lcpred),boolean))$
  61
  62 nulllistp(exp) :=
  63   is(exp=[])$
  64
  65 zerolistp(list) :=
  66   catch(for exp in list do if exp#0 then throw(false),true)$
  67
  68 freeofl(varl,exp) :=
  69   catch(for var in varl do if not freeof(var,exp) then throw(false),true)$
  70
  71 /* Note that PARTITION(EXP,VAR) gives an error when EXP is atomic.
  72    This is quite reasonable since the function can't know which kind
  73    of neutral element it is supposed to return.
  74    The argument list of ORPARTITION supplies an operator and hence
  75    this missing piece of information.  More generally, EXP is somehow
  76    coerced to have OP as main operator.  Otherwise this function behaves
  77    just like PARTITION. */
  78
  79 orpartition(exp,op,var) :=
  80   if not(atom(exp)) and inpart(exp,0)=op
  81   then partition(exp,var)
  82   else if freeof(var,exp)
  83        then [exp,apply(op,[])]
  84        else [apply(op,[]),exp]$
  85
  86 /* Same thing for a list of variables. */
  87
  88 orpartitionl(exp,op,varl) :=
  89   block([free,notfree,partit],
  90     free:exp,
  91     notfree:apply(op,[]),
  92     for var in varl do
  93       (partit:orpartition(free,op,var),
  94       free:first(partit),
  95       notfree:if op="["
  96               then append(notfree,last(partit))
  97               else apply(op,[notfree,last(partit)])),
  98       [free,notfree])$
  99
 100 orpartitionlist(list,op,[vars]) :=
 101   block([partitl:map(lambda([exp],orpartitionl(exp,op,vars)),list)],
 102     [map('first,partitl),map('last,partitl)])$
 103
 104 ldelete(varl,exp) :=
 105   (for var in varl do exp:delete(var,exp),exp)$
 106
 107 listtosum(list) :=
 108   apply("+",list)$
 109
 110 listtoprod(list) :=
 111   apply("*",list)$
 112
 113 /* The following mimics the behaviour of APPEND.  Note, however, that
 114    INTERSECT_LIST takes exactly two arguments */
 115
 116 intersect_list(exp1,exp2) :=
 117   (if atom(exp1)
 118   then error(concat("argument value `", exp1, "' to `intersect_list' was atomic")),
 119   if atom(exp2)
 120   then error(concat("argument value `", exp2, "' to `intersect_list' was atomic")),
 121   block([op:inpart(exp1,0)],
 122   if op#inpart(exp2,0)
 123   then error("Arguments to `intersect_list' are not compatible."),
 124   block([inflag:true,cap:[]],
 125     for term in exp1 do
 126       if member(term,exp2)
 127       then cap:endcons(term,cap),
 128     apply(op,cap))))$
 129
 130 setlist(lst,l1,l2) :=
 131   (l1::first(lst),l2::last(lst))$
 132
 133 nonumfactor(exp) :=
 134   if numberp(exp)
 135   then exp
 136   else factor(exp)$
 137
 138 /* If a non-trivial factorisation is not found you might prefer to retain
 139    the expression in its original shape.  Recall that you can arrange for
 140    this function to be called instead of NONUMFACTOR by setting FACSUM's
 141    AUTOMATIC property: put('facsum,'nonumfactor_alt,'automatic) */
 142
 143 nonumfactor_alt(exp) :=
 144   block([dum:nonumfactor(exp)],
 145   if atom(dum) or inpart(dum,0)="+"
 146   then exp
 147   else dum)$
 148
 149 /* Better not. Aliasing is too weird, e.g, DECLARE(FOO,NOUN) would
 150    be displayed as DECLARE(FOO, FORMAL).
 151 alias(FORMAL,NOUN);
 152 */
 153
 154 /* LST is an alternating list of operators and associated functions.
 155    OP_FCN_LIST is used to pass LST to recursive calls to OPMAP. */
 156
 157 /* The change from ampersand symbols to CL strings breaks opmap (the call to
 158 ?getf in particular).
 159
 160 opmap(exp,lst) :=
 161   if atom(exp)
 162   then exp
 163   else block([fun:?getf(?cdr(lst),inpart(exp,0))],
 164     if fun#false
 165     then block([op_fcn_list:lst],
 166       apply(fun,[exp]))
 167     else exp)$
 168 */
 169
 170 opmap(exp, lst) := block([op_fcn_list : lst, e_op, x, fun : false, inflag : true],
 171   if mapatom(exp) then exp
 172   else (
 173     e_op : op(exp),
 174     while lst # [ ] do (
 175       x : first(lst),
 176       lst : rest(lst),
 177       if x = e_op and lst # [ ] then (
 178         fun : first(lst),
 179         lst : [ ])),
 180       if fun = false then exp else apply(fun, [exp])))$
 181
 182 iflopmap(op,fun,exp) :=
 183   if op="*"
 184   then genut_prodmap(fun,exp)
 185   else if atom(exp)
 186        then exp
 187        else if inpart(exp,0)=op
 188             then map(fun,exp)
 189             else apply(fun,[exp])$
 190
 191 genut_prodmap(fun,exp):=
 192   if atom(exp)
 193   then exp
 194   else block([mop:inpart(exp,0)],
 195          if mop="*"
 196          then map(lambda([exp],genut_prodmap(fun,exp)),exp)
 197          else if mop="^" and askinteger(inpart(exp,2))='yes
 198               then substinpart(genut_prodmap(fun,inpart(exp,1)),exp,1)
 199               else apply(fun,[exp]))$
 200
 201 /* Returns a list of the sub-expressions of EXP which have one of the
 202    operators in OPL as main operator. */
 203
 204 listofops_nonrat(exp,[opl]) :=
 205   listofops_nonratl(exp,opl,[])$
 206
 207 listofops_nonratl(exp,opl,lst) :=
 208   block(if atom(exp) then return(lst),
 209     if member(inpart(exp,0), opl)
 210     then return(cons(exp,lst))
 211     else for expdum in exp do
 212       lst:listofops_nonratl(expdum,opl,lst),
 213     lst)$
 214
 215 /* Extracts a common factor from the list of expressions EXPL and
 216    returns it as first element COMMON of a list.  The second element
 217    is a list OTHER such that EXPL = COMMON * OTHER. */
 218
 219 explicitfactor(expl) :=
 220   block([vars:map(lambda([dum],?gensym()),expl),common,other],
 221     setlist(orpartitionl(factor(expl . vars),"*",vars),'common,'other),
 222     [common,map(lambda([var],coeff(other,var)),vars)])$
 223
 224 /* Don't ask.  It's only used once, in declin.mac. */
 225
 226 lcpred(linp,is_op,exp) :=
 227   if atom(exp)
 228   then false
 229   else if apply(is_op,[exp])
 230        then true
 231        else if inpart(exp,0)="*"
 232             then is(length(last(predpartition(exp,is_op)))=1)
 233             else if inpart(exp,0)="+"
 234                  then is(first(predpartition(exp,linp))=[])
 235                  else false$
 236
 237 /* The following two functions are copied from rncomb.mac */
 238
 239 rloiewl(op,exp):=block(
 240   [partswitch:true,inflag:true,piece],
 241   if inpart(exp,0)=op
 242   then args(exp)
 243   else [exp])$
 244
 245 predpartition(list,predicate):=block(
 246   [nolist:[],yeslist:[]],
 247   for idum in reverse(list) do
 248       if mode_identity(boolean,apply(predicate,[idum]))
 249       then yeslist:cons(idum,yeslist)
 250       else nolist:cons(idum,nolist),
 251   [nolist,yeslist])$
 252
 253 /* a sort of `provide' */
 254 put('gnauto,true,'diageval_version)$
 255
 256 /* genut.mac ends here */