← Back to branch summary

~ubuntu-branches/ubuntu/karmic/maxima/karmic

« back to all changes in this revision

Viewing changes to src/compar.lisp

  • Committer: Bazaar Package Importer
  • Author(s): Barry deFreese
  • Date: 2006-07-06 17:04:52 UTC
  • mfrom: (1.1.4 upstream)
  • Revision ID: james.westby@ubuntu.com-20060706170452-j9ypoqc1kjfnz221
Tags: 5.9.3-1ubuntu1
* Re-sync with Debian
* Comment out backward-delete-char-untabify in maxima.el (Closes Malone #5273)
* debian/control: build-dep automake -> automake1.9 (Closes BTS: #374663)

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/compar.lisp
8
8
;;;     (c) Copyright 1982 Massachusetts Institute of Technology         ;;;
9
9
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
10
10
 
11
 
(in-package "MAXIMA")
 
11
(in-package :maxima)
12
12
(macsyma-module compar)
13
13
 
14
14
(load-macsyma-macros mrgmac)
402
402
;;(defun compare macro (x) `(sign1 (sub* ,(cadr x) ,(caddr x))))
403
403
(defmacro compare (a b) `(sign1 (sub* ,a ,b)))
404
404
 
405
 
(defmfun $compare (x y) (compare x y) sign)
406
 
 
407
 
(defmfun $max n (if (= n 0) (wna-err '$max) (maximin (listify n) '$max)))
408
 
 
409
 
(defmfun $min n (if (= n 0) (wna-err '$min) (maximin (listify n) '$min)))
410
 
 
411
405
(defmfun maximum (l) (maximin l '$max))
412
406
 
413
407
(defmfun minimum (l) (maximin l '$min))
414
408
 
415
 
(defmfun maximin (l sw)
416
 
  (if (dolist (x l) (if (not (atom x)) (return t)))
417
 
      (setq l (total-nary (cons (ncons sw) l))))
418
 
  (do ((ll nil nil) (reject nil nil) (nl) (arg) (xarg))
419
 
      ((null l) (if (null (cdr nl)) (car nl) (cons (ncons sw) (sort nl 'great))))
420
 
    (dolist (x (cdr l))
421
 
      (compare (car l) x)
422
 
      (cond ((eq sign '$zero)
423
 
             (setq arg (specrepcheck (car l)) xarg (specrepcheck x))
424
 
             (if (and (not (alike1 arg xarg)) (great xarg arg))
425
 
                 (setq reject t ll (cons x ll))))
426
 
            ((memq sign '($pos $pz))
427
 
             (if (eq sw '$min) (setq reject t ll (cons x ll))))
428
 
            ((memq sign '($neg $nz))
429
 
             (if (eq sw '$max) (setq reject t ll (cons x ll))))
430
 
            (t (setq ll (cons x ll)))))
431
 
    (if (not reject) (setq nl (cons (car l) nl)))
432
 
    (setq l (nreverse ll))))
433
409
 
434
410
(defmspec mnot (form) (setq form (cdr form))
435
411
          (let ((x (mevalp (car form))))
1079
1055
 
1080
1056
(defun dbzs-err (x) (merror "Division by zero detected in `sign':~%~M" x))
1081
1057
 
 
1058
;; Return true iff e is an expression with operator op1, op2,...,or opn. 
 
1059
 
 
1060
(defun op-equalp (e &rest op)
 
1061
  (and (consp e) (consp (car e)) (some #'(lambda (s) (equal (caar e) s)) op)))
 
1062
 
 
1063
;; Return true iff the operator of e is a Maxima relation operator.
 
1064
 
 
1065
(defun mrelationp (a)
 
1066
  (op-equalp a 'mlessp 'mleqp 'mequal 'mgeqp 'mgreaterp))
 
1067
 
 
1068
;; This version of featurep applies ratdisrep to the first argument.  This
 
1069
;; change allows things like featurep(rat(n),integer) --> true when n has
 
1070
;; been declared an integer.
 
1071
 
1082
1072
(defmfun $featurep (e ind)
1083
 
  (cond ((not (symbolp ind))
1084
 
         (merror "~M is not a symbolic atom - `featurep'." ind))
 
1073
  (setq e ($ratdisrep e))
 
1074
  (cond ((not (symbolp ind)) (merror "The second argument to 'featurep' must be a symbol"))
1085
1075
        ((eq ind '$integer) (maxima-integerp e))
1086
1076
        ((eq ind '$noninteger) (nonintegerp e))
1087
1077
        ((eq ind '$even) (mevenp e))
1093
1083
        ((eq ind '$complex) t)
1094
1084
        ((symbolp e) (kindp e ind))))
1095
1085
 
1096
 
(defmfun maxima-integerp (e)
1097
 
  (cond ((integerp e))
1098
 
        ((mnump e) nil)
1099
 
        ((atom e) (kindp e '$integer))
1100
 
        ((eq (caar e) 'mrat) (and (integerp (cadr e)) (equal (cddr e) 1)))
1101
 
        ((memq (caar e) '(mtimes mplus)) (intp e))
1102
 
        ((eq (caar e) 'mexpt) (intp-mexpt e))))
 
1086
;; Give a function the maps-integers-to-integers property when it is integer
 
1087
;; valued on the integers; give it the integer-valued property when its 
 
1088
;; range is a subset of the integers. What have I missed?
 
1089
 
 
1090
(setf (get 'mplus 'maps-integers-to-integers) t)
 
1091
(setf (get 'mtimes 'maps-integers-to-integers) t)
 
1092
(setf (get 'mabs 'maps-integers-to-integers) t)
 
1093
(setf (get '$max 'maps-integers-to-integers) t)
 
1094
(setf (get '$min 'maps-integers-to-integers) t)
 
1095
 
 
1096
(setf (get '$floor 'integer-valued) t)
 
1097
(setf (get '$ceiling 'integer-valued) t)
 
1098
(setf (get '%signum  'integer-valued) t)
 
1099
(setf (get '$signum 'integer-valued) t)
 
1100
(setf (get '$charfun 'integer-valued) t)
 
1101
 
 
1102
(defun maxima-integerp (x)
 
1103
  (let ((x-op (if (and (consp x) (consp (car x))) (mop x) nil)) ($prederror nil))
 
1104
    (cond ((integerp x))
 
1105
          ((mnump x) nil)
 
1106
          ((and (symbolp x) (or (kindp x '$integer) (kindp x '$even) (kindp x '$odd))))
 
1107
          ((and (eq x-op 'mrat) (integerp (cadr x)) (equal (cddr x) 1)))
 
1108
          ((and x-op (or ($featurep ($verbify x-op) '$integervalued) (get x-op 'integer-valued))))
 
1109
          ((and (get x-op 'maps-integers-to-integers) (every #'maxima-integerp (margs x))))
 
1110
          ((and (eq x-op 'mfactorial) (not (mevalp (mlsp (first (margs x)) 0)))))
 
1111
         
 
1112
          ((and (eq x-op 'mtimes)
 
1113
                (mnump (first (margs x)))
 
1114
                (integerp (mul 2 (first (margs x))))
 
1115
                (every 'maxima-integerp (rest (margs x)))
 
1116
                (some #'(lambda (s) ($featurep s '$even)) (rest (margs x)))))
 
1117
 
 
1118
          ((and (eq x-op 'mexpt) (every #'maxima-integerp (margs x)) 
 
1119
                (eq nil (mevalp (mlsp (nth 2 x) 0))))))))
1103
1120
 
1104
1121
(defmfun nonintegerp (e)
1105
1122
  (let (num)
1133
1150
        ((mnump e) nil)
1134
1151
        (t (eq '$odd (evod e)))))
1135
1152
 
 
1153
;; An extended evod that recognizes that abs(even) is even and
 
1154
;; abs(odd) is odd.
 
1155
 
1136
1156
(defmfun evod (e)
1137
1157
  (cond ((integerp e) (if (oddp e) '$odd '$even))
1138
1158
        ((mnump e) nil)
1139
1159
        ((atom e) (cond ((kindp e '$odd) '$odd) ((kindp e '$even) '$even)))
1140
1160
        ((eq 'mtimes (caar e)) (evod-mtimes e))
1141
1161
        ((eq 'mplus (caar e)) (evod-mplus e))
 
1162
        ((eq 'mabs (caar e)) (evod (cadr e))) ;; extra code
1142
1163
        ((eq 'mexpt (caar e)) (evod-mexpt e))))
1143
1164
 
1144
1165
(defun evod-mtimes (x)
1498
1519
          (kind %csch $oddfun)
1499
1520
          (kind %sech $posfun)
1500
1521
          (kind $li $complex)
1501
 
          (kind %cabs $complex)
1502
 
          (kind $zeta $posfun)))
 
1522
          (kind %cabs $complex)))
1503
1523
 
1504
1524
  ($newcontext '$initial)     ; Create an initial context for the user
1505
1525
                                        ; which is a subcontext of $global.