share/multiadditive/multiadditive.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 Examples:
  12
  13 Declaring a function to be multiadditive makes it additive
  14 in all of its arguments; declaring a function to be additive
  15 makes it additive in just its first argument.  Examples:
  16
  17 (%i1) load("multiadditive")$
  18 (%i2) declare(f,multiadditive);
  19 (%o2) done
  20 (%i3) f(x+y,a+b);
  21 (%o3) f(y,b)+f(y,a)+f(x,b)+f(x,a)
  22 (%i4) f(x+y+z,a+b);
  23 (%o4) f(z,b)+f(z,a)+f(y,b)+f(y,a)+f(x,b)+f(x,a)
  24 (%i5) declare(g,additive)$
  25 (%i6) g(x+y,a+b);
  26 (%o6) g(y,b+a)+g(x,b+a)
  27
  28 The order of *opers-list matters. For example, if f is threadable and
  29 an involution, then f(f([1,2])) would simplify to f([f(1),f(2)]) if
  30 the threadable rule was used first, or it would simplify to [1,2] if
  31 the the involution rule was used first. A user doesn't have any control
  32 over the order the rules are applied. There is a user-level list $opproperties,
  33 but re-ordering $opproperties doesn't change the order the rules are applied.
  34 |#
  35
  36 ;; As of 2 June 2006, simplifya doesn't check for a subscripted function
  37 ;; before sending it to oper-apply. I don't think this is what we want:
  38 ;; declare(f,multiadditive), f[x+y] --> f[x] + f[y]. And f[x+y](a+b) --> error.
  39 ;; For now, these functions check for subscripted arguments.
  40 ;; TODO: MOVE THIS BUG FIX TO SIMPLIFYA OR OPER-APPLY !!
  41
  42 ;; When e is a mapatom, the function call (oper-apply e z) gives an
  43 ;; error. I think oper-apply should be changed so that its first
  44 ;; argument can be a mapatom. Till then:
  45 ;; TODO: MOVE THIS BUG FIX TO SIMPLIFYA OR OPER-APPLY !!
  46
  47 (defun protected-oper-apply (e z)
  48   (if ($mapatom e) e (oper-apply e z)))
  49
  50 (defun multiadditive (e)
  51   (cond ((and (not ($subvarp e)) (some #'(lambda (s) (op-equalp s 'mplus)) (margs e)))
  52          (let ((op (mop e)) (args (margs e)))
  53            (setq args (mapcar #'(lambda (s) (if (op-equalp s 'mplus) (margs s) (list s))) args))
  54            (setq args (apply 'cartesian-product args))
  55            (setq args (mapcar #'(lambda (s) (simplify `((,op) ,@s))) args))
  56            (reduce 'add args)))
  57         (t e)))
  58
  59 ;; ((op) bag) --> map(op bag).
  60
  61 (defun threadable (e)
  62   (let ((arg (margs e)) (fop) (bop)) ;; fop = function operator and bop = bag operator.
  63     (cond ((and (= 1 (length arg)) (not ($subvarp e))
  64                 (or (mbagp (first arg)) (op-equalp (first arg) '$set)))
  65            (setq arg (first arg))
  66            (setq fop (mop e))
  67            (setq bop (mop arg))
  68            `((,bop) ,@(mapcar #'(lambda (s) (mfuncall fop s)) (margs arg))))
  69           (t e))))
  70
  71 ;; ((op) ((op) x)) --> ((op) x).
  72 ;; Good test: declare(f,idempotent), f[5](x).
  73
  74 (defun idempotent (e)
  75   (if (and (not ($subvarp e))
  76          (= 1 (length (margs e)))
  77          (not ($mapatom (first (margs e))))
  78          (eq (mop e) (mop (first (margs e)))))
  79       (first (margs e)) e))
  80
  81 ;; ((op) ((op) x)) --> x.
  82 ;; Good test: declare(f,involution), f[5](x).
  83
  84 (defun involution (e)
  85   (if (and (not ($subvarp e))
  86          (= 1 (length (margs e)))
  87          (not ($mapatom (first (margs e))))
  88          (eq (mop e) (mop (first (margs e))))
  89          (= 1 (length (margs (first (margs e))))))
  90       (first (margs (first (margs e)))) e))
  91
  92