Updating configure.ac with new version number
[maxima/cygwin.git] / src / maxmin.lisp
blobc434b6f0fbe5de7ad7cb0ea3280cef515b8e6530
1 ;; Maxima functions for finding the maximum or minimum
2 ;; Copyright (C) 2005, 2007, 2021 Barton Willis
4 ;; Barton Willis
5 ;; Department of Mathematics
6 ;; University of Nebraska at Kearney
7 ;; Kearney NE 68847
8 ;; willisb@unk.edu
10 ;; This source code is licensed under the terms of the Lisp Lesser
11 ;; GNU Public License (LLGPL). The LLGPL consists of a preamble, published
12 ;; by Franz Inc. (http://opensource.franz.com/preamble.html), and the GNU
13 ;; Library General Public License (LGPL), version 2, or (at your option)
14 ;; any later version. When the preamble conflicts with the LGPL,
15 ;; the preamble takes precedence.
17 ;; This library is distributed in the hope that it will be useful,
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
20 ;; Library General Public License for details.
22 ;; You should have received a copy of the GNU Library General Public
23 ;; License along with this library; if not, write to the
24 ;; Free Software Foundation, Inc., 51 Franklin St, Fifth Floor,
25 ;; Boston, MA 02110-1301, USA.
27 (in-package :maxima)
28 (macsyma-module maxmin)
30 (eval-when (:compile-toplevel :load-toplevel :execute)
31 ($put '$maxmin 2 '$version) ;; Let's have version numbers 1,2,3,...
32 ;; Let's remove built-in symbols from list for user-defined properties.
33 (setq $props (remove '$maxmin $props)))
35 (defprop $max $max verb)
36 (defprop $min $min verb)
38 (setf (get '$max 'msimpind) (list '$max 'simp))
39 (setf (get '$min 'msimpind) (list '$min 'simp))
41 (defmvar $maxmin_effort 10)
42 (defun maxmin_effort-assign (xx y)
43 (declare (ignore xx))
44 (cond ((and (integerp y) (> y -1))
45 (setq $maxmin_effort y))
46 (t
47 (merror (intl:gettext "The value of maxmin_effort must be a nonnegative integer; found ~M ~%") y))))
49 (defprop $maxmin_effort maxmin_effort-assign assign)
51 ;; Return true if there is pi and pj in the CL list p such that
52 ;; x is between pi and pj. This means that either pi <= x <= pj or
53 ;; pj <= x <= pi. For example, 2x is between x and 3x.
55 ;; Strangely, sign((a-b)*(b-a)) --> pnz but sign(expand((a-b)*(b-a))) --> nz.
56 ;; To workaround this weirdness, we could call expand instead of factor on
57 ;; (mul (sub x pk) (sub qk x))), but let's not do that.
59 ;; The betweenp simplification is done last; this has some interesting effects:
60 ;; max(x^2,x^4,x^6,x^2+1) (standard simplification) --> max(x^4,x^6,x^2+1)
61 ;; (betweenp) --> max(x^4,x^6,x^2+1). If the betweenp simplification were done
62 ;; first, we'd have max(x^2,x^4,x^6,x^2+1) --> max(x^2,x^6,x^2+1) --> max(x^6,x^2+1).
64 ;; The function $factor refuses to factor an expression that has an exponent that
65 ;; exceeds factor_max_degree. I think this is a better heuristic than the conssize
66 ;; method used by factor-if-small (defined in compar.lisp). So let's use $factor, not
67 ;; factor-if-small. We could locally set the value of factor_max_degree, but let's not.
69 ;; Removing factor from (csign ($factor (mul (sub x pk) (sub qk x))) causes max
70 ;; to miss the simplification max(x^2,x^4,x^6) --> max(x^2, x^4). Arguably, csign
71 ;; should be more semantically neutral--until it is, let's keep factor in here.
73 (defun betweenp (x p)
74 (let ((q) (pk) (qk))
75 (catch 'done
76 (while p
77 (setq pk (pop p))
78 (setq q p)
79 (while q
80 (setq qk (pop q))
81 (when (member (csign ($factor (mul (sub x pk) (sub qk x)))) '($pos $pz) :test #'eq)
82 (throw 'done t)))))))
84 ;; Define a simplim%function to handle a limit of $max.
85 (defprop $max simplim$max simplim%function)
87 (defun simplim$max (expr var val)
88 (simplifya (cons '($max) (mapcar #'(lambda (e) (limit e var val 'think)) (cdr expr))) t))
90 (defprop $max simp-max operators)
92 ;; True iff e is a GRE expression of the form max(...)
93 (defun max-p (e)
94 (and (consp e) (eq (caar e) '$max)))
96 ;; True iff e is a GRE expression of the form min(...)
97 (defun min-p (e)
98 (and (consp e) (eq (caar e) '$min)))
100 ;; Undone: max(1-x,1+x) - max(x,-x) --> 1. Doing this is possible--we could
101 ;; simplify max(1-x,1+x) --> 1 + max(-x,x).
103 ;; Return either the maximum of the arguments of l or a simplified max nounform.
104 ;; When max(a1,a2, ..., am) simplifies to a nounform, say max(b1, b2, ... , bn), each
105 ;; bk is *explicitly* one of a1 ... am. Much the same when max(a1,a2, ..., am)
106 ;; simplifies to a non-nounform; thus, for example,
108 ;; max(cos(x)^2+sin(x)^2,-107) --> cos(x)^2 + sin(x)^2 (*not* 1).
110 ;; Since coeff is purely syntatic, we have
112 ;; (%i1) xxx : 42*x^(cos(a)^2+sin(a)^2) + x^(-107)$
113 ;; (%i2) coeff(xxx,x, hipow(xxx,x));
114 ;; (%o2) 42
116 ;; And this is, I think, what users want.
118 (defun simp-max (l tmp z)
119 (declare (ignore tmp))
120 (let ((acc nil) (sgn) (num-max nil) (issue-warning))
121 (setq l (cdr l))
123 ;; When maxmin_effort > 0, simplify each member of l and flatten (that is, do
124 ;; max(a,max(a,b)) -> max(a,b,c)). Additionally, we accumulate the largest real
125 ;; number. Since (mnump '$%i) --> false, we don't have to worry that num-max is
126 ;; complex. The effort for this step is O(n).
127 (when (> $maxmin_effort 0)
128 (dolist (li l)
129 (setq li (simplifya (specrepcheck li) z))
130 (cond
131 ((max-p li)
132 (setq acc (append acc (cdr li))))
133 ((mnump li)
134 (setq num-max (if (or (null num-max) (mgrp li num-max)) li num-max)))
135 ;; Removing minf & -inf now results in things like max(minf, %i*inf)-->%i*inf.
137 (push li acc))))
138 (when num-max
139 (push num-max acc))
140 (setq l acc))
142 ;; For inputs such as max(max(5,a), max(7,b), max(8,c), ...), the list
143 ;; l might contain many numbers. That could make some of the following
144 ;; simplifications slow. We could flag this case and redo the loop that
145 ;; looks for the largest number, or we could remove the mnump check from the first
146 ;; loop and separately make a loop that looks for the largest number.
148 ;; Sort and remove duplicates. The effort for this step is O(n logn)).
149 (when (> $maxmin_effort 0)
150 (setq l (sorted-remove-duplicates (sort l #'$orderlessp))))
152 ;; When maxmin_effort > 2, if e and -e are members of l, replace e & -e by
153 ;; abs(e).
154 (when (> $maxmin_effort 2)
155 (let ((pp) (qq) (nn))
156 (setq pp (simplifya (cons '($set) l) t))
157 (setq qq (simplifya (cons '($set) (mapcar #'limitneg l)) t))
158 (setq nn ($intersection pp qq))
159 (setq pp ($setdifference pp nn))
160 (when (not ($emptyp nn))
161 (setq nn (mapcar #'(lambda (s) (take '(mabs) s)) (cdr nn)))
162 (setq nn (simplifya (cons '($set) nn) t))
163 (setq pp ($union pp nn)))
164 (setq l (cdr pp))))
166 ;; Accumulate the maximum in the list acc. For each x in l, do:
167 ;; (a) if x is > or >= every member of acc, set acc to (x),
168 ;; (b) if x is < or <= to some member of acc, do nothing,
169 ;; (c) if neither 'a' or 'b', push x into acc,
170 ;; (d) if x cannot be compared to some member of acc, set issue-warning to true.
171 (when (> $maxmin_effort 1)
172 (setq acc nil)
173 (dolist (x l)
174 (catch 'done
175 (dolist (ai acc)
176 (setq sgn ($compare x ai))
177 (cond ((member sgn '(">" ">=") :test #'equal)
178 (setq acc (delete ai acc :test #'eq :from-end t :count 1)))
179 ((eq sgn '$notcomparable) (setq issue-warning t))
180 ((member sgn '("<" "=" "<=") :test #'equal)
181 (throw 'done t))))
182 (push x acc)))
183 (setq l acc))
185 ;; When issue-warning is false and maxmin_effort > 2, use the betweenp
186 ;; simplification.
187 (when (and (not issue-warning) (> $maxmin_effort 2))
188 (setq acc nil)
189 (setq sgn (cdr l))
190 (dolist (ai l)
191 (when (not (betweenp ai sgn))
192 (push ai acc))
193 (setq sgn `(,@(cdr sgn) ,ai)))
194 (setq l acc))
196 ;; Finally, do a few clean ups:
197 (setq l (if (not issue-warning) (delete '$minf l) l))
198 (cond ((null l) '$minf) ;max(emptyset) -> minf.
199 ((and (not issue-warning) (member '$inf l :test #'eq)) '$inf)
200 ((and (null (cdr l)) (lenient-extended-realp (car l)))
201 (car l)) ;singleton case: max(xx) --> xx
204 (t ;;nounform return
205 (cons (get '$max 'msimpind) (sort l #'$orderlessp))))))
207 ;; Return -x, but check for the special cases x = inf, minf, und, ind, and infinity.
208 ;; Also locally set negdistrib to true (this is what the function neg does). We could
209 ;; do -zeroa -> zerob and -zerob -> zeroa, I suppose.
211 ;; To catch more cases, replace this function body with ($limit (mul -1 x)).
212 ;; But ($limit (mul -1 x)) misses the case -ind --> ind & limit can be costly.
213 (defun limitneg (x)
214 (cond ((eq x '$minf) '$inf) ; -minf -> inf
215 ((eq x '$inf) '$minf) ; -inf -> minf
216 ((member x '($und $ind $infinity) :test #'eq) x) ;-und -> und, and ...
217 (t (let (($negdistrib t)) (mul -1 x))))) ; x -> -x
219 ;; Define a simplim%function to handle a limit of $min.
221 (defprop $min simplim$min simplim%function)
223 (defun simplim$min (expr var val)
224 (simplifya (cons '($min) (mapcar #'(lambda (e) (limit e var val 'think))
225 (cdr expr))) t))
227 (defprop $min simp-min operators)
229 ;; The function simp-min piggy-backs onto simp-max. That is, we use
230 ;; min(a,b,...) = -max(-a,-b,...).
231 (defun simp-min (l tmp z)
232 (declare (ignore tmp))
233 (let ((acc nil))
234 (setq l (cdr l))
235 (dolist (li l)
236 (setq li (simplifya (specrepcheck li) z))
237 ;; convert min(a, min(b,c)) --> min(a,b,c)
238 (cond ((min-p li)
239 (setq acc (append acc (cdr li))))
241 (push li acc))))
242 (setq l (mapcar #'limitneg acc))
243 (setq l (simplifya (cons '($max) l) t))
244 ;; Is the sort needed? I think so, but need a test that requires sorting...
245 (if (max-p l)
246 (cons (get '$min 'msimpind) (sort (mapcar #'limitneg (cdr l)) #'$orderlessp))
247 (limitneg l))))
249 ;; Several functions (derivdegree for example) use the maximin function. Here is
250 ;; a replacement that uses simp-min or simp-max.
252 (defun maximin (l op) (simplify `((,op) ,@l)))
254 (defmfun $lmax (e)
255 (simplify `(($max) ,@(require-list-or-set e '$lmax))))
257 (defmfun $lmin (e)
258 (simplify `(($min) ,@(require-list-or-set e '$lmin))))
260 ;; Return the narrowest comparison operator op (<, <=, =, >, >=) such that
261 ;; a op b evaluates to true. Return 'unknown' when either there is no such
262 ;; operator or when Maxima's sign function isn't powerful enough to determine
263 ;; such an operator; when Maxima is able to show that either argument is not
264 ;; real valued, return 'notcomparable.'
266 ;; The subtraction can be a problem--for example, compare(0.1, 1/10)
267 ;; evaluates to "=". But for flonum floats, I believe 0.1 > 1/10.
268 ;; If you want to convert flonum and big floats to exact rational
269 ;; numbers, use $rationalize.
271 ;; I think compare(asin(x), asin(x) + 1) should evaluate to < without
272 ;; being quizzed about the sign of x. Thus the call to lenient-extended-realp.
274 ;; Maxima's sign function doesn't know that zeroa > 0 and zerob < 0
276 (defmfun $compare (a b)
277 ;; Simplify expressions with infinities. Without these checks, we can get odd
278 ;; questions such as "Is 1 zero or nonzero?"
279 (setq a (ratdisrep a))
280 (setq b (ratdisrep b))
281 (when (amongl '($inf $minf $infinity) a)
282 (setq a ($limit a)))
283 (when (amongl '($inf $minf $infinity) b)
284 (setq b ($limit b)))
286 (cond
288 ;; We'll make compare(infinity, infinity) -> noncompareable, but
289 ;; compare(inf, inf) -> "=". Simiarly, an expression involving ind or und
290 ;; is notcompareable.
291 ((or (amongl '($infinity $ind $und) a)
292 (amongl '($infinity $ind $und) b))
293 '$notcomparable)
295 ;; Attempt to catch expressions that are not extended real number valued. We
296 ;; don't want to do call csign on 1+und - und, and conclude that 1+und > und.
297 ;; The check lenient-extended-realp only looks at the main operator of the
298 ;; expression. Thus lenient-extended-realp flags a<b as not real valued,
299 ;; but it fails to flag 107*(a<b).
301 ((or (not (lenient-extended-realp a))
302 (not (lenient-extended-realp b)))
303 (if (eq t (meqp a b)) "=" '$notcomparable))
305 (t (let ((sgn))
306 (setq a (sub a b))
307 (when (and (>= $maxmin_effort 10) (lenient-extended-realp a) (amongl '($minf $inf) a))
308 (setq a ($limit a)))
310 (when (>= $maxmin_effort 10)
311 (setq a (sratsimp ($trigreduce a))))
313 (setq sgn (csign ($rectform a)))
314 (cond
315 ((eq sgn '$neg) "<")
316 ((eq sgn '$nz) "<=")
317 ((eq sgn '$pz) ">=")
318 ((eq sgn '$pos) ">")
319 ((eq sgn '$pn) "#")
320 ((eq sgn '$zero) "=")
321 (t '$unknown))))))
324 ;; When it's fairly likely that the real domain of e is nonempty, return true;
325 ;; otherwise, return false. Even if z has been declared complex, the real domain
326 ;; of z is nonempty; thus (lenient-extended-realp z) --> true. When does this
327 ;; function lie? One example is acos(abs(x) + 2). The real domain of this
328 ;; expression is empty, yet lenient-extended-realp returns true for this input.
330 (defun lenient-extended-realp (e)
331 (and (not (mbagp e))
332 (not ($featurep e '$nonscalar))
333 (not (mrelationp e))
334 (not (arrayp e))
335 (not ($member e $arrays))
336 (not (amongl '($infinity $%i $und $ind $false $true t nil) e)))) ;; what else?
338 (defun lenient-realp (e)
339 (and ($freeof '$inf '$minf e) (lenient-extended-realp e)))
341 ;; Convert all floats and big floats in e to an exact rational representation.
343 (defmfun $rationalize (e)
344 (setq e (ratdisrep e))
345 (cond ((floatp e)
346 (let ((significand) (expon) (sign))
347 (multiple-value-setq (significand expon sign) (integer-decode-float e))
348 (cl-rat-to-maxima (* sign significand (expt 2 expon)))))
349 (($bfloatp e) (cl-rat-to-maxima (* (cadr e)(expt 2 (- (caddr e) (third (car e)))))))
350 (($mapatom e) e)
351 (t (simplify (cons (list (mop e)) (mapcar #'$rationalize (margs e)))))))