1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
|
#|
Copyright 2006 by Barton Willis
This is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License,
http://www.gnu.org/copyleft/gpl.html.
This software has NO WARRANTY, not even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
Examples:
Declaring a function to be multiadditive makes it additive
in all of its arguments; declaring a function to be additive
makes it additive in just its first argument. Examples:
(%i1) load("multiadditive")$
(%i2) declare(f,multiadditive);
(%o2) done
(%i3) f(x+y,a+b);
(%o3) f(y,b)+f(y,a)+f(x,b)+f(x,a)
(%i4) f(x+y+z,a+b);
(%o4) f(z,b)+f(z,a)+f(y,b)+f(y,a)+f(x,b)+f(x,a)
(%i5) declare(g,additive)$
(%i6) g(x+y,a+b);
(%o6) g(y,b+a)+g(x,b+a)
The order of *opers-list matters. For example, if f is threadable and
an involution, then f(f([1,2])) would simplify to f([f(1),f(2)]) if
the threadable rule was used first, or it would simplify to [1,2] if
the the involution rule was used first. A user doesn't have any control
over the order the rules are applied. There is a user-level list $opproperties,
but re-ordering $opproperties doesn't change the order the rules are applied.
|#
;; As of 2 June 2006, simplifya doesn't check for a subscripted function
;; before sending it to oper-apply. I don't think this is what we want:
;; declare(f,multiadditive), f[x+y] --> f[x] + f[y]. And f[x+y](a+b) --> error.
;; For now, these functions check for subscripted arguments.
;; When e is a mapatom, the function call (oper-apply e z) gives an
;; error. I think oper-apply should be changed so that its first
;; argument can be a mapatom. Till then:
(defun protected-oper-apply (e z)
(if ($mapatom e) e (oper-apply e z)))
;; Code adapted from nset. Used by permission of the author ;)
(defun cartesian-product (&rest b)
(cond ((null b)
nil)
(t
(let ((a) (acc (mapcar #'list (car b))))
(setq b (cdr b))
(dolist (bi b acc)
(setq a nil)
(dolist (bij bi (setq acc a))
(setq a (append a (mapcar #'(lambda (x) `(,@x ,bij)) acc)))))))))
(setq opers (cons '$multiadditive opers)
*opers-list (cons '($multiadditive . multiadditive) *opers-list))
(setq $opproperties ($cons '$multiadditive $opproperties))
(defun multiadditive (e z)
(cond ((and (not ($subvarp e)) (some #'(lambda (s) (op-equalp s 'mplus)) (margs e)))
(let ((op (mop e)) (args (margs e)))
(setq args (mapcar #'(lambda (s) (if (op-equalp s 'mplus) (margs s) (list s))) args))
(setq args (apply 'cartesian-product args))
(setq args (mapcar #'(lambda (s) (simplify `((,op) ,@s))) args))
(reduce 'add (mapcar #'(lambda (s) (protected-oper-apply s z)) args))))
(t (protected-oper-apply e z))))
(setq opers (cons '$threadable opers)
*opers-list (cons '($threadable . threadable) *opers-list))
(setq $opproperties ($cons '$threadable $opproperties))
;; ((op) bag) --> map(op bag).
(defun threadable (e z)
(let ((arg (margs e)) (fop) (bop)) ;; fop = function operator and bop = bag operator.
(cond ((and (= 1 (length arg)) (not ($subvarp e))
(or (mbagp (first arg)) (op-equalp (first arg) '$set)))
(setq arg (first arg))
(setq fop (mop e))
(setq bop (mop arg))
(simplify `((,bop) ,@(mapcar #'(lambda (s) (protected-oper-apply (mfuncall fop s) z))
(margs arg)))))
(t (protected-oper-apply e z)))))
;(setq opers (cons '$idempotent opers)
; *opers-list (cons '($idempotent . idempotent) *opers-list))
(setq opers (cons '$idempotent opers)
*opers-list `(,@*opers-list ($idempotent . idempotent)))
(setq $opproperties ($cons '$idempotent $opproperties))
;; ((op) ((op) x)) --> ((op) x).
;; Good test: declare(f,idempotent), f[5](x).
(defun idempotent (e z)
(protected-oper-apply (if (and (not ($subvarp e))
(= 1 (length (margs e)))
(not ($mapatom (first (margs e))))
(eq (mop e) (mop (first (margs e)))))
(first (margs e)) e) z))
(setq opers (cons '$involution opers)
*opers-list (cons '($involution . involution) *opers-list))
(setq $opproperties ($cons '$involution $opproperties))
;; ((op) ((op) x)) --> x.
;; Good test: declare(f,involution), f[5](x).
(defun involution (e z)
(protected-oper-apply (if (and (not ($subvarp e))
(= 1 (length (margs e)))
(not ($mapatom (first (margs e))))
(eq (mop e) (mop (first (margs e))))
(= 1 (length (margs (first (margs e))))))
(first (margs (first (margs e)))) e) z))
|
