share/contrib/opsubst.lisp

   1 #|
   2   Copyright 2006 by Barton Willis
   3
   4   This is free software; you can redistribute it and/or
   5   modify it under the terms of the GNU General Public License,
   6   http://www.gnu.org/copyleft/gpl.html.
   7
   8  This software has NO WARRANTY, not even the implied warranty of
   9  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  10
  11 Usage: The function 'opsubst' is similar to the function 'subst', except that
  12 'opsubst' only makes substitutions for the operators in an expression. Specifically,
  13
  14  opsubst(f,g,e) --> When 'f' is an operator in the expression e, substitute 'g'
  15                     for 'f' in the expression 'e'.
  16  opsubst(g=f,e) --> opsubst(f,g,e).
  17  opsubst([],e) --> e.
  18  opsubst([g1=f1, g2=f2, ..., gn=fn],e) --> opsubst([g2=f2,...,gn=fn], opsubst(f1=f1, e)).
  19
  20  Examples:
  21
  22 (%i1) opsubst(f,g,g(g(x)));
  23 (%o1) f(f(x))
  24 (%i2) opsubst(f,g,g(g));
  25 (%o2) f(g)
  26 (%i3) opsubst(f,g[x],g[x](z));
  27 (%o3) f(z)
  28 (%i4) opsubst(g[x],f, f(z));
  29 (%o4) g[x](z)
  30 (%i5) opsubst(tan, sin, sin(sin));
  31 (%o5) tan(SIN)
  32 (%i6) opsubst([f=g,g=h],f(x));
  33 (%o6) h(x)
  34
  35 To determine the operator, 'opsubst' sets 'inflag' to true. This means
  36 'opsubst' substitutes for the internal, not the displayed, operator.
  37 Since Maxima does not internally use the unary negation or division
  38 operators, substituting for these operators will not work; examples:
  39
  40 (%i1) opsubst("+","-",a-b);
  41 (%o1) a-b
  42 (%i2) opsubst("f","-",-a);
  43 (%o2) -a
  44 (%i3) opsubst("^^","/",a/b);
  45 (%o3) a/b
  46
  47 The internal representation of -a*b is *(-1,a,b); thus
  48
  49 (%i4) opsubst("[","*", -a*b);
  50 (%o4) [-1,a,b]
  51
  52 If opsubst did not locally set 'inflag' to true, we'd have:
  53
  54 (%i1) opsubst("[","*", -a*b), listarith : true;
  55 (%o1) [-a,-b]
  56 (%i2) opsubst("[","*", -a*b), listarith : false;
  57 (%o2) -[a,b]
  58
  59 So opsubst("*","[", opsubst("[","*", -a*b)) # -a*b. There is
  60 nothing wrong with this; however, With 'inflag' set to true,
  61 we have (regardless of the value of listarith)
  62
  63 (%i1) opsubst("[","*", -a*b);
  64 (%o1) [-1,a,b]
  65 (%i2) opsubst("*","[",%);
  66 (%o2) -a*b
  67
  68 To me, it seems that it is better to substitute for the internal
  69 rather than the displayed operator. But do not be mislead by this
  70 example, the equation
  71
  72    opsubst(f,g,opsubst(g,f,e)) = e
  73
  74 is not an identity.
  75
  76 When either the first or second arguments of 'opsubst' are not Maxima
  77 symbols, generally some other function will signal an error; for
  78 example
  79
  80 (%i5) opsubst(a+b,f, f(x));
  81 Improper name or value in functional position:b+a
  82
  83 However, the first two arguments to 'opsubst' can be
  84 subscripted:
  85
  86 (%i6) opsubst(g[5],f, f(x));
  87 (%o6) g[5](x)
  88
  89 |#
  90
  91 ;; Applies op to args and simplifies the result. The function my-take isn't supposed
  92 ;; to evaluate args. I think the maxima 'take' macro doesn't handle subscripted
  93 ;; operators correctly--this function my-take should be OK with subscripted operators.
  94 ;; (Also the take macro special-cases a few operators for the simplification function. Yeech.)
  95
  96 (defun my-take (op args)
  97   (simplify (if (and (consp op) (member 'array (car op))) `((mqapply) ,op ,@args) `((,op) ,@args))))
  98
  99 (defun $opsubst (&rest q)
 100   (let ((e))
 101     (cond ((= 3 (length q)) (apply 'op-subst q))
 102           ((= 2 (length q))
 103            (setq e (second q))
 104            (setq q (if ($listp (first q)) (margs (first q)) (list (first q))))
 105            (dolist (qi q e)
 106              (if (op-equalp qi 'mequal) (setq e (op-subst ($rhs qi) ($lhs qi) e))
 107                (merror "Expected an expression of the form `a = b'; instead found ~:M" qi))))
 108           (t (wna-err '$opsubst)))))
 109
 110 ;; If op is a string, verbify it; otherwise, return op. Without this transformation,
 111 ;; things like opsubst("[",f, f(a,b,c)) would fail. Notice that subst(f[1] = "[", f[1](1,2,3))
 112 ;; doesn't work correctly.
 113
 114 (defun verbify-string (op)
 115   (if (stringp op) ($verbify op) op))
 116
 117 ;; If op is a symbol, verbify it; otherwise, return op.
 118
 119 (defun safe-verbify (op)
 120   (if (symbolp op) ($verbify op) op))
 121
 122 (defun op-subst (f g e)
 123   (setq f (verbify-string f))
 124   (setq g (verbify-string g))
 125
 126   (let (($inflag t))
 127     (if ($mapatom e) e
 128       (my-take (if (like (safe-verbify g) (safe-verbify (mop e))) f (mop e))
 129                (mapcar #'(lambda (s) (op-subst f g s)) (margs ($args e)))))))
 130
 131 ;; If prd(e) evaluates to true, do the substitution opsubst(id, e). The
 132 ;; first argument should be an equation of the form symbol = symbol | lambda form
 133 ;; or a list of such equations.
 134
 135 (defun $opsubstif (id prd e)
 136   (setq id (if ($listp id) (margs id) (list id)))
 137   (dolist (qi id)
 138     (if (op-equalp qi 'mequal) (setq e (op-subst-if (verbify-string ($rhs qi))
 139                                                     (verbify-string ($lhs qi)) prd e))
 140       (merror "Expected an expression of the form `a = b'; instead found ~:M" qi)))
 141   e)
 142
 143 (defun op-subst-if (fn fo prd e)
 144   (let (($inflag t) ($prederror nil))
 145     (cond (($mapatom e) e)
 146           (t
 147            (my-take (if (and (like (safe-verbify fo) (safe-verbify (mop e)))
 148                              (eq t (mevalp (mfuncall prd ($args e))))) fn (mop e))
 149                     (mapcar #'(lambda (s) (op-subst-if fn fo prd s)) (margs ($args e))))))))
 150
 151 ;; Return a list of all the arguments to the operator 'op.' Each argument is
 152 ;; a list (what 'args' would return).  Examples:
 153
 154 ;; (%i1) gatherargs(f(x) + f(y),'f);
 155 ;; (%o1) [[x],[y]]
 156
 157 ;; In the expression 42 + f(f(x)), both x and f(x) are arguments to f; thus
 158
 159 ;; (%i2) gatherargs(42 + f(f(x)),'f);
 160 ;; (%o2) [[f(x)],[x]]
 161
 162 ;; (%i3) gatherargs(f^2 + %pi,'f);
 163 ;; (%o3) []
 164
 165
 166 (defun $gatherargs (e op)
 167   `((mlist) ,@(gatherargs e op)))
 168
 169 (defun gatherargs (e op)
 170   (if ($mapatom e) nil
 171     (append (if (op-equalp e op ($nounify op) ($verbify op)) `(((mlist) ,@(margs e))))
 172             (mapcan #'(lambda (s) (gatherargs s op)) (margs e)))))
 173
 174 (defun $gatherops (e)
 175   ($setify `((mlist) ,@(gatherops e))))
 176
 177 (defun gatherops (e)
 178   (if ($mapatom e) nil (cons ($op e) (mapcan #'gatherops (margs e)))))
 179
 180
 181
 182