home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / compar.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  50.2 KB  |  1,508 lines
  1. ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;;     The data in this file contains enhancments.                    ;;;;;
  4. ;;;                                                                    ;;;;;
  5. ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
  6. ;;;     All rights reserved                                            ;;;;;
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;;     (c) Copyright 1982 Massachusetts Institute of Technology         ;;;
  9. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10.  
  11. (in-package "MAXIMA")
  12. (macsyma-module compar)
  13.  
  14. (LOAD-MACSYMA-MACROS MRGMAC)
  15.  
  16. (DECLARE-TOP(SPECIAL $FLOAT2BF $RADEXPAND $RATPRINT $RATSIMPEXPONS $LISTCONSTVARS
  17.           SUCCESS %INITIALLEARNFLAG $PROPS *X* $%ENUMER)
  18.      ;; Variables defined in DB
  19.      (SPECIAL CONTEXT CURRENT DOBJECTS DBTRACE +LABS)
  20.      (*EXPR $BFLOAT SIGN RETRIEVE WNA-ERR $LISTOFVARS))
  21.  
  22. (DEFMVAR $CONTEXT '$INITIAL
  23.      "Whenever a user assumes a new fact, it is placed in the context
  24. named as the current value of the variable CONTEXT.  Similarly, FORGET
  25. references the current value of CONTEXT.  To add or zl-DELETE a fact from a
  26. different context, one must bind CONTEXT to the intended context and then
  27. perform the desired additions or deletions.  The context specified by the
  28. value of CONTEXT is automatically activated.  All of MACSYMA's built-in
  29. relational knowledge is contained in the default context GLOBAL."
  30.      NO-RESET)
  31.  
  32. (DEFMVAR $CONTEXTS '((MLIST) $INITIAL $GLOBAL)
  33.      "A list of the currently active contexts."
  34.      NO-RESET)
  35.  
  36. (DEFMVAR $ACTIVECONTEXTS '((MLIST))
  37.      "A list of the currently activated contexts"
  38.      NO-RESET)
  39.  
  40. (DEFMVAR SIGN-IMAG-ERRP T
  41.      "If T errors out in case COMPAR meets up with an imaginary quantity.
  42.       If NIL THROWs in that case."
  43.      NO-RESET)
  44.  
  45. (DEFMVAR COMPLEXSIGN NIL
  46.      "If T, COMPAR attempts to work in a complex mode.
  47.       This scheme is only very partially developed at this time."
  48.      NO-RESET)
  49.  
  50. (DEFMVAR $PREDERROR T)
  51. (DEFMVAR $SIGNBFLOAT T)
  52. (DEFMVAR $ASKEXP)
  53. (DEFMVAR LIMITP)
  54. (DEFMVAR $ASSUME_POS NIL)
  55. (DEFMVAR $ASSUME_POS_PRED NIL)
  56.  
  57. (DEFMVAR FACTORED NIL)
  58. (DEFMVAR LOCALS NIL)
  59. (DEFMVAR PATEVALLED NIL)
  60. (DEFMVAR SIGN NIL)
  61. (DEFMVAR MINUS NIL)
  62. (DEFMVAR ODDS NIL)
  63. (DEFMVAR EVENS NIL)
  64. (DEFMVAR LHS NIL)
  65. (DEFMVAR RHS NIL)
  66.  
  67. ;; This variable is also initialized in DB for its own purposes.  
  68. ;; COMPAR is loaded after DB.
  69. (setq context '$global)
  70.  
  71. ;; Load-time environment for COMPAR.  $CONTEXT and $CONTEXTS will be 
  72. ;; reset at the end of the file via a call to ($newcontext '$initial).
  73. (setq $context '$global $contexts '((mlist) $global))
  74.  
  75. ;(defun ask macro (x) `(retrieve (list '(mtext) . ,(cdr x)) nil))
  76. ;(defun pow macro (x) `(power . ,(cdr x)))
  77.  
  78. ;(macro ask  (x) `(retrieve (list '(mtext) . ,(cdr x))  nil))
  79. ;(macro pow (x) `(power . ,(cdr x)))
  80.  
  81. (defmacro ask (&rest x) `(retrieve (list '(mtext) . , x) nil))
  82.  
  83. (defmacro pow (&rest x) `(power . , x))
  84.  
  85.  
  86.  
  87.  
  88. (defun lmul (l) (simplify (cons '(mtimes) l)))
  89.  
  90. (defun conssize (x)
  91.        (cond
  92.     ((atom x) 0)
  93.     (t (setq x (cdr x))
  94.        (do ((sz 1))
  95.            ((null x) sz)
  96.            (setq sz (f+ 1 (conssize (car x)) sz) x (cdr x))))))
  97.  
  98. ;;;  Functions for creating, activating, manipulating, and killing contexts
  99.  
  100. (DEFMFUN $context flush
  101.        flush ;Ignored
  102.        (merror "The CONTEXT function no longer exists."))
  103.  
  104. ;;; This "turns on" a context, making its facts visible.
  105.  
  106. (DEFMFUN $activate n 
  107.   (do ((i 1 (f1+ i))) ((> i n))
  108.       (cond ((not (symbolp (arg i))) (nc-err))
  109.         ((memq (arg i) (cdr $activecontexts)))
  110.         ((memq (arg i) (cdr $contexts))
  111.          (setq $activecontexts (mcons (arg i) $activecontexts))
  112.          (activate (arg i)))
  113.         (t (merror "There is no context with the name ~:M" (arg i)))))
  114.   '$DONE)
  115.  
  116. ;;; This "turns off" a context, keeping the facts, but making them 
  117. ;;; invisible
  118.  
  119. (DEFMFUN $deactivate n 
  120.   (do ((i 1 (f1+ i))) ((> i n))
  121.       (cond ((not (symbolp (arg i))) (nc-err))
  122.         ((memq (arg i) (cdr $contexts))
  123.          (setq $activecontexts ($delete (arg i) $activecontexts))
  124.          (deactivate (arg i)))
  125.         (t (merror "There is no context with the name ~:M" (arg i)))))
  126.   '$DONE)
  127.  
  128. ;;; This function of 0 or 1 argument prints out a list of the facts
  129. ;;; in the specified context.  No argument implies the current context.
  130.  
  131. (DEFMFUN $facts n
  132.        (cond ((equal n 0) (facts1 $context))
  133.          ((equal n 1) (facts1 (arg n)))
  134.          (t (merror "FACTS takes zero or one argument only."))))
  135.        
  136. ;(defun facts1 (con)
  137. ;       (contextmark)
  138. ;       (do ((l (get con 'data) (cdr l)) (nl))
  139. ;       ((null l) (cons '(mlist) nl))
  140. ;       (cond ((visiblep (car l))
  141. ;          (setq nl (cons (intext (caaar l) (cdaar l)) nl))))))
  142. ;Update from F302 --gsb
  143. (defun facts1 (con)
  144.   (contextmark)
  145.   (do ((l (zl-get con 'data) (cdr l)) (nl) (u))
  146.       ((null l) (cons '(mlist) nl))
  147.     (when (visiblep (car l))
  148.       (setq u (intext (caaar l) (cdaar l)))
  149.       (if (not (memalike u nl)) (setq nl (cons u nl))))))
  150.  
  151. (defun intext (rel body)
  152.   (setq body (mapcar #'doutern body))
  153.   (cond ((eq 'kind rel) (cons '($kind) body))
  154.     ((eq 'par rel) (cons '($par) body))
  155.     ((eq 'mgrp rel) (cons '(mgreaterp) body))
  156.     ((eq 'mgqp rel) (cons '(mgeqp) body))
  157.     ((eq 'meqp rel) (cons '($equal) body))
  158.     ((eq 'mnqp rel) (list '(mnot) (cons '($equal) body)))))
  159.  
  160. (defprop $context asscontext assign)
  161.  
  162. ;;; This function switches contexts, creating one if necessary.
  163.  
  164. (defun asscontext (x y) x ;Ignored
  165.        (cond ((not (symbolp y)) (nc-err))
  166.          ((memq y $contexts) (setq context y $context y))
  167.          (t ($newcontext y))))
  168.  
  169. ;;; This function actually creates a context whose subcontext is $GLOBAL.
  170. ;;; It also switches contexts to the newly created one.
  171.  
  172. (DEFMFUN $newcontext (x)
  173.        (cond ((not (symbolp x)) (nc-err))
  174.          ((memq x $contexts)
  175.           (mtell "Context ~M already exists." x) nil)
  176.          (t (setq $contexts (mcons x $contexts))
  177.         (putprop x '($global) 'subc)
  178.         (setq context x $context x))))
  179.  
  180. ;;; This function creates a supercontext.  If given one argument, it
  181. ;;; makes the current context be the subcontext of the argument.  If
  182. ;;; given more than one argument, the first is assumed the name of the
  183. ;;; supercontext and the rest are the subcontexts. 
  184.  
  185. (DEFMSPEC $supcontext (x) (SETQ x (CDR x))
  186.    (cond ((null x) (merror "You must supply a name for the context."))
  187.      ((caddr x) (merror "SUPCONTEXT takes either one or two arguments."))
  188.      ((not (symbolp (car x))) (nc-err))
  189.      ((memq (car x) $contexts)
  190.       (merror "Context ~M already exists." (car x)))
  191.      ((and (cadr x) (not (memq (cadr x) $contexts)))
  192.       (merror "Nonexistent context ~M." (cadr x)))
  193.      (t (setq $contexts (mcons (car x) $contexts))
  194.         (putprop (car x) (ncons (or (cadr x) $context)) 'subc)
  195.         (setq context (car x) $context (car x)))))
  196.    
  197. ;;; This function kills a context or a list of contexts
  198.    
  199. (defmfun $killcontext n
  200.   (do ((i 1 (f1+ i))) ((> i n))
  201.       (if (symbolp (arg i)) (killcontext (arg i)) (nc-err)))
  202.   (if (and (= n 1) (eq (arg 1) '$global)) '$not_done '$done))
  203.  
  204. (defun killallcontexts ()
  205.        (mapcar #'killcontext (cdr $contexts))
  206.        (setq $context '$initial context '$initial current '$initial  
  207.          $contexts '((mlist) $initial $global) dobjects ())
  208.             ;The DB variables
  209.             ;conmark, conunmrk, conindex, connumber, and contexts
  210.             ;concern garbage-collectible contexts, and so we're
  211.             ;better off not resetting them.
  212.        (defprop $global 1 cmark) (defprop $initial 1 cmark)     
  213.        (defprop $initial ($global) subc))
  214.  
  215. (defun killcontext (x)
  216.        (cond ((not (memq x $contexts))
  217.           (mtell "The context ~M doesn't exist." x))
  218.          ((eq x '$global) '$global)
  219.          ((eq x '$initial)
  220.           (mapc #'remov (zl-get '$initial 'data))
  221.           (remprop '$initial 'data)
  222.           '$initial)
  223.          ((and (not (eq $context x)) (contextmark) (< 0 (zl-get x 'cmark)))
  224.           (mtell "The context ~M is currently active." x))
  225.          (t (setq $contexts ($delete x $contexts))
  226.         (cond ((and (eq x $context)
  227.                 (equal ;;replace eq ?? wfs
  228.                   (zl-get x 'subc) '($global)))
  229.                (setq $context '$initial)
  230.                (setq context '$initial))
  231.               ((eq x $context)
  232.                (setq $context (car (zl-get x 'subc)))
  233.                (setq context (car (zl-get x 'subc)))))
  234.         (killc x)
  235.         x)))
  236.          
  237. (defun nc-err () (merror "Contexts must be symbolic atoms."))
  238.  
  239. (defmspec $is (form) (mevalp (fexprcheck form)))
  240.  
  241. (defmfun is (pred) (let (($prederror t)) (mevalp pred)))
  242.  
  243. ;; =>* N.B. *<=
  244. ;; The function IS-BOOLE-CHECK, used by the translator, depends
  245. ;; on some stuff in here.  Check it out in the transl module
  246. ;; ACALL before proceeding.
  247.  
  248. (defmfun mevalp (pat)
  249.   (let (patevalled ans)
  250.     (setq ans (mevalp1 pat))
  251.     (cond ((memq ans '(#.(NOT ()) ()))
  252.        ans)
  253.       ($prederror (pre-err patevalled))
  254.       (t '$unknown))))
  255.  
  256. (defun mevalp1 (pat)
  257.   (cond ((and (not (atom pat)) (memq (caar pat) '(mnot mand mor)))
  258.      (cond ((eq 'mnot (caar pat)) (is-mnot (cadr pat)))
  259.            ((eq 'mand (caar pat)) (is-mand (cdr pat)))
  260.            (t (is-mor (cdr pat)))))
  261.     ((atom (setq patevalled (meval pat))) patevalled)
  262.     ((memq (caar patevalled) '(mnot mand mor)) (mevalp1 patevalled))
  263.     (t (mevalp2 (caar patevalled) (cadr patevalled) (caddr patevalled)))))
  264.  
  265. (defmfun mevalp2 (pred arg1 arg2)
  266.   (cond ((eq 'mequal pred) (like arg1 arg2))
  267.     ((eq '$equal pred) (meqp arg1 arg2))
  268.     ((eq 'mnotequal pred) (not (like arg1 arg2)))
  269.     ((eq '$notequal pred) (mnqp arg1 arg2))
  270.     ((eq 'mgreaterp pred) (mgrp arg1 arg2))
  271.     ((eq 'mlessp pred) (mgrp arg2 arg1))
  272.     ((eq 'mgeqp pred) (mgqp arg1 arg2))
  273.     ((eq 'mleqp pred) (mgqp arg2 arg1))
  274.     (t (isp (munformat patevalled)))))
  275.  
  276. (defmfun pre-err (pat)
  277.   (merror "MACSYMA was unable to evaluate the predicate:~%~M" pat))
  278.  
  279. (defun is-mnot (pred)
  280.   (setq pred (mevalp pred))
  281.   (cond ((eq t pred) nil)
  282.     ((not pred))
  283.     (t (pred-reverse pred))))
  284.  
  285. (defmfun pred-reverse (pred)
  286.   (cond ((atom pred) (list '(mnot) pred))
  287.     ((eq 'mnot (caar pred)) (cadr pred))
  288.     ((eq 'mgreaterp (caar pred)) (cons '(mleqp) (cdr pred)))
  289.     ((eq 'mgeqp (caar pred)) (cons '(mlessp) (cdr pred)))
  290.     ((eq 'mequal (caar pred)) (cons '(mnotequal) (cdr pred)))
  291.     ((eq '$equal (caar pred)) (cons '($notequal) (cdr pred)))
  292.     ((eq '$notequal (caar pred)) (cons '($equal) (cdr pred)))
  293.     ((eq 'mnotequal (caar pred)) (cons '(mequal) (cdr pred)))
  294.     ((eq 'mleqp (caar pred)) (cons '(mgreaterp) (cdr pred)))
  295.     ((eq 'mlessp (caar pred)) (cons '(mgeqp) (cdr pred)))
  296.     (t (list '(mnot) pred))))
  297.  
  298. (defun is-mand (pl)
  299.   (do ((dummy) (npl))
  300.       ((null pl) (cond ((null npl))
  301.                ((null (cdr npl)) (car npl))
  302.                (t (cons '(mand) (nreverse npl)))))
  303.       (setq dummy (mevalp (car pl)) pl (cdr pl))
  304.       (cond ((eq t dummy))
  305.         ((null dummy) (return nil))
  306.         (t (setq npl (cons dummy npl))))))
  307.  
  308. (defun is-mor (pl)
  309.   (do ((dummy) (npl))
  310.       ((null pl) (cond ((null npl) nil)
  311.                ((null (cdr npl)) (car npl))
  312.                (t (cons '(mor) (nreverse npl)))))
  313.       (setq dummy (mevalp (car pl)) pl (cdr pl))
  314.       (cond ((eq t dummy) (return t))
  315.         ((null dummy))
  316.         (t (setq npl (cons dummy npl))))))
  317.  
  318. (DEFMSPEC $assume (x) (SETQ x (CDR x))
  319.   (do ((nl)) ((null x) (cons '(mlist) (nreverse nl)))
  320.       (cond ((atom (car x)) (setq nl (cons (assume (meval (car x))) nl)))
  321.         ((eq 'mand (caaar x))
  322.          (mapc #'(lambda (l) (setq nl (cons (assume (meval l)) nl)))
  323.            (cdar x)))
  324.         ((eq 'mnot (caaar x))
  325.          (setq nl (cons (assume (meval (pred-reverse (cadar x)))) nl)))
  326.         ((eq 'mor (caaar x))
  327.          (merror "ASSUME: Macsyma is unable to handle assertions involving 'OR'."))
  328.         ((eq (caaar x) 'mequal)
  329.          (merror "ASSUME: = means syntactic equality in Macsyma.
  330. Maybe you want to use EQUAL."))
  331.         ((eq (caaar x) 'mnotequal)
  332.          (merror "ASSUME: # means syntactic unequality in Macsyma.
  333. Maybe you want to use NOT EQUAL."))
  334.         (t (setq nl (cons (assume (meval (car x))) nl))))
  335.       (setq x (cdr x))))
  336.  
  337. (defmfun assume (pat)
  338.   (if (and (not (atom pat))
  339.        (eq (caar pat) 'mnot)
  340.        (eq (caaadr pat) '$equal))
  341.       (setq pat `(($notequal) ,@(cdadr pat))))
  342.   (let ((dummy (let (patevalled $assume_pos) (mevalp1 pat))))
  343.        (cond ((eq dummy t) '$redundant)
  344.          ((null dummy) '$inconsistent)
  345.          ((atom dummy) '$meaningless)
  346.          (t (learn pat t)))))
  347.  
  348. (defmfun learn (pat flag)
  349.   (cond ((atom pat))
  350.     ((zl-get (caar pat) (if flag 'learn 'unlearn))
  351.      (funcall (zl-get (caar pat) (if flag 'learn 'unlearn)) pat))
  352.     ((eq (caar pat) 'mgreaterp) (daddgr flag (sub (cadr pat) (caddr pat))))
  353.     ((eq (caar pat) 'mgeqp) (daddgq flag (sub (cadr pat) (caddr pat))))
  354.     ((memq (caar pat) '(mequal $equal))
  355.      (daddeq flag (sub (cadr pat) (caddr pat))))
  356.     ((memq (caar pat) '(mnotequal $notequal))
  357.      (daddnq flag (sub (cadr pat) (caddr pat))))
  358.     ((eq (caar pat) 'mleqp) (daddgq flag (sub (caddr pat) (cadr pat))))
  359.     ((eq (caar pat) 'mlessp) (daddgr flag (sub (caddr pat) (cadr pat))))
  360.     (flag (true* (munformat pat)))
  361.     (t (untrue (munformat pat)))))
  362.  
  363. (defmacro def-learn ( name pat flag)
  364.   `(progn
  365.    #+lispm (si:record-source-file-name ',name 'def-learn)
  366.     (learn ,pat ,flag)))
  367.  
  368. (DEFMSPEC $forget (x) (SETQ x (CDR x))
  369.   (do ((nl)) ((null x) (cons '(mlist) (nreverse nl)))
  370.       (cond ((atom (car x)) (setq nl (cons (forget (meval (car x))) nl)))
  371.         ((eq 'mand (caaar x))
  372.          (mapc #'(lambda (l) (setq nl (cons (forget (meval l)) nl)))
  373.            (cdar x)))
  374.         ((eq 'mnot (caaar x))
  375.          (setq nl (cons (forget (meval (pred-reverse (cadar x)))) nl)))
  376.         ((eq 'mor (caaar x))
  377.          (merror "MACSYMA is unable to handle assertions involving 'OR'."))
  378.         (t (setq nl (cons (forget (meval (car x))) nl))))
  379.       (setq x (cdr x))))
  380.  
  381. (defmfun forget (pat)
  382.  (cond (($listp pat) 
  383.     (cons '(mlist simp) (mapcar #'forget1 (cdr pat))))
  384.        (t (forget1 pat))))
  385.  
  386. (defun forget1 (pat)
  387.   (cond ((and (not (atom pat))
  388.           (eq (caar pat) 'mnot)
  389.           (eq (caaadr pat) '$equal))
  390.      (setq pat `(($notequal) ,@(cdadr pat)))))
  391.   (learn pat nil))
  392.  
  393. (defmfun restore-facts (factl)  ; used by SAVE
  394.  (dolist (fact factl)
  395.      (cond ((eq (caar fact) '$kind)
  396.         (declarekind (cadr fact) (caddr fact))
  397.         (add2lnc (getop (cadr fact)) $props))
  398.            ((eq (caar fact) '$par))
  399.            (t (assume fact)))))
  400.  
  401.  
  402. ;(defun compare macro (x) `(sign1 (sub* ,(cadr x) ,(caddr x))))
  403. (defmacro compare (a b) `(sign1 (sub* ,a ,b)))
  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. (defmfun maximum (l) (maximin l '$max))
  412.  
  413. (defmfun minimum (l) (maximin l '$min))
  414.  
  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.  
  434. (defmspec mnot (form) (setq form (cdr form))
  435.  (let ((x (mevalp (car form))))
  436.       (if (eq x '$unknown) x (not x))))
  437.  
  438. (defmspec mand (form) (setq form (cdr form))
  439.   (do ((l form (cdr l)) (x)) ((null l) t)
  440.       (cond ((not (setq x (mevalp (car l)))) (return nil))
  441.         ((eq x '$unknown) (return x)))))
  442.  
  443. (defmspec mor (form) (setq form (cdr form))
  444.   (do ((l form (cdr l)) (x)) ((null l) nil)
  445.       (cond ((eq (setq x (mevalp (car l))) '$unknown) (return x))
  446.         (x (return t)))))
  447.  
  448. ;;;Toplevel functions- $ASKSIGN, $SIGN.
  449. ;;;Switches- LIMITP If TRUE $ASKSIGN and $SIGN will look for special
  450. ;;;             symbols such as EPSILON, $INF, $MINF and attempt
  451. ;;;             to do the correct thing. In addition calls to
  452. ;;;             $REALPART and $IMAGPART are made to assure that    
  453. ;;;             the expression is real.
  454. ;;;
  455. ;;;          if NIL $ASKSIGN and $SIGN assume the expression
  456. ;;;             given is real unless it contains an $%I, in which
  457. ;;;             case they call $RECTFORM.
  458.  
  459. (setq limitp nil)
  460.  
  461. (defmfun $asksign (exp)
  462.   (let (sign minus odds evens factored)
  463.        (asksign01 (cond (limitp (restorelim exp))
  464.             ((among '$%i exp) ($rectform exp))
  465.             (t exp)))))
  466.  
  467. (defmfun asksign-p-or-n (e)
  468.  (unwind-protect (prog2 (assume `(($notequal) ,e 0)) 
  469.             ($asksign e))
  470.          (forget `(($notequal) ,e 0))))
  471.  
  472. (defun asksign01 (a)
  473.        (let ((e (sign-prep a)))
  474.         (cond ((eq e '$pnz) '$pnz)
  475.           ((memq (setq e (asksign1 e)) '($pos $neg)) e)
  476.           (limitp (eps-sign a))
  477.           (t '$zero))))
  478.  
  479. (defmfun csign (x)  ;; csign returns t if x appears to be complex.
  480.             ;; Else, it returns the sign.
  481.   (or (not (free x '$%i))
  482.       (let (sign-imag-errp limitp) (catch 'sign-imag-err ($sign x)))))
  483.  
  484. (defmfun $sign (x)
  485.   (let (sign minus odds evens factored)
  486.        (sign01 (cond (limitp (restorelim x))
  487.              ((not (free x '$%i)) ($rectform x))
  488.              (t x)))))
  489.  
  490. (defun sign01 (a)
  491.   (let ((e (sign-prep a)))
  492.        (cond ((eq e '$pnz) '$pnz)
  493.          (t (setq e (sign1 e))
  494.         (if (and limitp (eq e '$zero)) (eps-sign a) e)))))
  495.  
  496. ;;; Preparation for asking questions from DEFINT or LIMIT.
  497. (defun sign-prep (x)
  498.        (if limitp
  499.        (let (((rpart . ipart) (trisplit x)))
  500.         (cond ((and (equal (sratsimp ipart) 0)
  501.                 (free rpart '$infinity))
  502.                (setq x (nmr (sratsimp rpart)))
  503.                (if (free x 'prin-inf)
  504.                x
  505.                ($limit x 'prin-inf '$inf '$minus)))
  506.               (t '$PNZ)))  ; Confess ignorance if COMPLEX.
  507.        x))
  508.  
  509. ;;; Do substitutions for special symbols.
  510. (defmfun nmr (a) 
  511.   (if (not (free a '$zeroa)) (setq a ($limit a '$zeroa 0 '$plus)))
  512.   (if (not (free a '$zerob)) (setq a ($limit a '$zerob 0 '$minus)))
  513.   (if (not (free a 'z**)) (setq a ($limit a 'z** 0 '$plus)))
  514.   (if (not (free a '*z*)) (setq a ($limit a '*z* 0 '$plus)))
  515.   (if (not (free a 'epsilon)) (setq a ($limit a 'epsilon 0 '$plus)))
  516.   a)  ;;; Give A back.
  517.  
  518. ;;; Get the sign of EPSILON-like terms.  Could be made MUCH hairier.
  519. (defun eps-sign (b)
  520.   (let (temp1 temp2 temp3 free1 free2 free3)
  521.        (cond ((not (free b '$zeroa))
  522.           (setq temp1 (eps-coef-sign b '$zeroa)))
  523.          (t (setq free1 t)))
  524.        (cond ((not (free b '$zerob))
  525.           (setq temp2 (eps-coef-sign b '$zerob)))
  526.          (t (setq free2 t)))
  527.        (cond ((not (free b 'epsilon))
  528.           (setq temp3 (eps-coef-sign b 'epsilon)))
  529.          (t (setq free3 t)))
  530.        (cond ((and free1 free2 free3) '$zero)
  531.          ((or (not (null temp1)) (not (null temp2)) (not (null temp3)))
  532.           (cond ((and (null temp1) (null temp2)) temp3)
  533.             ((and (null temp2) (null temp3)) temp1)
  534.             ((and (null temp1) (null temp3)) temp2)
  535.             (t (merror 
  536.             "~%ASKSIGN: Internal error. See Maintainers.")))))))
  537.  
  538. (defun eps-coef-sign (exp epskind)
  539.   (let ((eps-power ($lopow exp epskind)) eps-coef)
  540.     (cond ((and (not (equal eps-power 0))
  541.         (not (equal (setq eps-coef (ratcoeff exp epskind eps-power))
  542.                 0))
  543.         (eq (ask-integer eps-power '$integer) '$yes))
  544.        (cond ((eq (ask-integer eps-power '$even) '$yes)
  545.           ($asksign eps-coef))
  546.          ((eq (ask-integer eps-power '$odd) '$yes)
  547.           (setq eps-coef ($asksign eps-coef))
  548.           (cond ((or (and (eq eps-coef '$pos)
  549.                   (or (eq epskind 'epsilon)
  550.                       (eq epskind '$zeroa)))
  551.                  (and (eq eps-coef '$neg)
  552.                   (or (alike epskind (mul2* -1 'epsilon))
  553.                       (eq epskind '$zerob))))
  554.              '$pos)
  555.             (t '$neg)))
  556.          (t (merror "~%ASKSIGN or SIGN: Insufficient information.~%"))))
  557.       (t (let ((deriv (sdiff exp epskind)) deriv-sign)
  558.           (cond ((not (eq (setq deriv-sign ($asksign deriv)) '$zero))
  559.              (total-sign epskind deriv-sign))
  560.             ((not 
  561.               (eq (let ((deriv (sdiff deriv epskind)))
  562.                    (setq deriv-sign ($asksign deriv)))
  563.                   '$zero))
  564.              deriv-sign)
  565.             (t (merror "~%ASKSIGN or SIGN: Insufficient data.~%"))))))))
  566.  
  567. ;;; The above code does a partial Taylor series analysis of something 
  568. ;;; that isn't a polynomial.
  569.  
  570. (defun total-sign (epskind factor-sign)
  571.        (cond ((or (eq epskind '$zeroa) (eq epskind 'epsilon))
  572.           (cond ((eq factor-sign '$pos) '$pos)
  573.             ((eq factor-sign '$neg) '$neg)
  574.             ((eq factor-sign '$zero) '$zero)))
  575.          ((eq epskind '$zerob)
  576.           (cond ((eq factor-sign '$pos) '$neg)
  577.             ((eq factor-sign '$neg) '$pos)
  578.             ((eq factor-sign '$zero) '$zero)))))
  579.  
  580. (defun asksign (x)
  581.   (setq x ($asksign x))
  582.   (cond ((eq '$pos x) '$positive)
  583.     ((eq '$neg x) '$negative)
  584.     ((eq '$PNZ x) '$pnz) ;COMPLEX expression encountered here.
  585.     (t '$zero)))
  586.  
  587. (defun asksign1 ($askexp)
  588.   (let ($radexpand) (sign1 $askexp))
  589.   (cond ((memq sign '($pos $neg $zero)) sign)
  590.     ((null odds)
  591.      (setq $askexp (lmul evens)
  592.            sign (cdr (assol $askexp locals)))
  593.      (do () (nil)
  594.          (cond ((zl-MEMBER sign '($zero $z |$z| 0 0.0))
  595.             (tdzero $askexp) (setq sign '$zero) (return t))
  596.            ((memq sign '($pn $nonzero $n |$n| $nz $nonz $non0))
  597.             (tdpn $askexp) (setq sign '$pos) (return t))
  598.            ((memq sign '($pos $p |$p| $positive))
  599.             (tdpos $askexp) (setq sign '$pos) (return t))
  600.            ((memq sign '($neg $n |$n| $negative))
  601.             (tdneg $askexp) (setq sign '$pos) (return t)))
  602.          (setq sign (ask "Is  " $askexp "  zero or nonzero?")))
  603.      (if minus (flip sign) sign))
  604.     (t (if minus (setq sign (flip sign)))
  605.        (setq $askexp (lmul (nconc odds (mapcar #'(lambda (l) (pow l 2))
  606.                            evens))))
  607.        (do ((dom (cond ((eq '$pz sign) "  positive or zero?")
  608.                ((eq '$nz sign) "  negative or zero?")
  609.                ((eq '$pn sign) "  positive or negative?")
  610.                (t "  positive, negative, or zero?")))
  611.         (ans (cdr (assol $askexp locals)))) (nil)
  612.            (cond ((and (memq ans '($pos $p |$p| $positive))
  613.                (memq sign '($pz $pn $pnz)))
  614.               (tdpos $askexp) (setq sign '$pos) (return t))
  615.              ((and (memq ans '($neg $n |$n| $negative))
  616.                (memq sign '($nz $pn $pnz)))
  617.               (tdneg $askexp) (setq sign '$neg) (return t))
  618.              ((and (zl-MEMBER ans '($zero $z |$z| 0 0.0))
  619.                (memq sign '($pz $nz $pnz)))
  620.               (tdzero $askexp) (setq sign '$zero) (return t)))
  621.            (setq ans (ask "Is  " $askexp dom)))
  622.        (if minus (flip sign) sign))))
  623.  
  624. (defun clearsign ()
  625.   (do () ((null locals))
  626.       (cond ((eq '$pos (cdar locals)) (daddgr nil (caar locals)))
  627.         ((eq '$neg (cdar locals)) (daddgr nil (neg (caar locals))))
  628.         ((eq '$zero (cdar locals)) (daddeq nil (caar locals)))
  629.         ((eq '$pn (cdar locals)) (daddnq nil (caar locals)))
  630.         ((eq '$pz (cdar locals)) (daddgq nil (caar locals)))
  631.         ((eq '$nz (cdar locals)) (daddgq nil (neg (caar locals)))))
  632.       (setq locals (cdr locals))))
  633.  
  634. (defmfun like (x y) (alike1 (specrepcheck x) (specrepcheck y)))
  635.  
  636. (defmfun meqp (x y)
  637.   (cond ((like x y))
  638.     (t (compare x y)
  639.        (cond ((eq '$zero sign))
  640.          ((memq sign '($pos $neg $pn)) nil)
  641.          (t (c-$zero odds evens))))))
  642.  
  643. (defmfun mgrp (x y)
  644.   (compare x y)
  645.   (cond ((eq '$pos sign))
  646.     ((memq sign '($neg $zero $nz)) nil)
  647.     (t (c-$pos odds evens))))
  648.  
  649. (defun mlsp (x y) (mgrp y x))
  650.  
  651. (defmfun mgqp (x y)
  652.   (compare x y)
  653.   (cond ((memq sign '($pos $zero $pz)) t)
  654.     ((eq '$neg sign) nil)
  655.     ((eq '$nz sign) (c-$zero odds evens))
  656.     ((eq '$pn sign) (c-$pos odds evens))
  657.     (t (c-$pz odds evens))))
  658.  
  659. (defmfun mnqp (x y)
  660.   (cond ((like x y) nil)
  661.     (t (compare x y)
  662.        (cond ((memq sign '($pos $neg $pn)) t)
  663.          ((eq sign '$zero) nil)
  664.          ((eq sign '$pz) (c-$pos odds evens))
  665.          ((eq sign '$nz)
  666.           (c-$pos (mapcar #'neg odds) (mapcar #'neg evens)))
  667.          (t (c-$pn odds evens))))))
  668.  
  669. (defun c-$pn (o e) (list '(mnot) (c-$zero o e)))
  670.  
  671. (defun c-$zero (o e) (list '($equal) (lmul (nconc o e)) 0))
  672.  
  673. (defun c-$pos (o e)
  674.   (cond ((null o) (list '(mnot) (list '($equal) (lmul e) 0)))
  675.     ((null e) (list '(mgreaterp) (lmul o) 0))
  676.     (t (setq e (mapcar #'(lambda (l) (pow l 2)) e))
  677.        (list '(mgreaterp) (lmul (nconc o e)) 0))))
  678.  
  679. (defun c-$pz (o e)
  680.   (cond ((null o) (list '(mnot) (list '($equal) (lmul e) 0)))
  681.     ((null e) (list '(mgeqp) (lmul o) 0))
  682.     (t (setq e (mapcar #'(lambda (l) (pow l 2)) e))
  683.        (list '(mgeqp) (lmul (nconc o e)) 0))))
  684.  
  685. ;;; These functions are for old translated files to work 6/4/76.
  686. ; (defprop greater mgrp expr)
  687. ; (defprop geq mgqp expr)
  688. ; (defprop equals meqp expr)
  689.  
  690. (defun sign* (x) (let (sign minus odds evens) (sign1 x)))
  691.  
  692. ;(defun sign1 (x)
  693. ;  (if (not (free x '$inf))
  694. ;      (let (($listconstvars t) l)
  695. ;       (setq l ($listofvars x))
  696. ;       (if (and (null (cddr l)) (eq (cadr l) '$inf))
  697. ;           (setq x (infsimp x)))))
  698. ; ; (setq x (infsimp* x))
  699. ;  
  700. ;  (if (eq x '$UND) (if limitp '$PNZ (merror "SIGN called on UND.")))
  701. ;  (prog (dum exp)
  702. ;    (setq dum (constp x) exp x)
  703. ;    (cond ((or (numberp x) (ratnump x)))
  704. ;          ((eq dum 'bigfloat)
  705. ;           (if (prog2 (setq dum ($bfloat x)) ($bfloatp dum))
  706. ;           (setq exp dum)))
  707. ;          ((eq dum 'float)
  708. ;           (if (and (setq dum (numer x)) (numberp dum)) (setq exp dum)))
  709. ;          ((and (memq dum '(numer symbol))
  710. ;            (prog2 (setq dum (numer x))
  711. ;               (or (null dum)
  712. ;                   (and (numberp dum)
  713. ;                    (prog2 (setq exp dum)
  714. ;                       (lessp (abs dum) 1.0e-6))))))
  715. ;           (cond ($signbfloat
  716. ;              (and (setq dum ($bfloat x)) ($bfloatp dum) (setq exp dum)))
  717. ;             (t (setq sign '$pnz evens nil odds (ncons x) minus nil)
  718. ;            (return sign)))))
  719. ;    (or (and (not (atom x)) (not (mnump x)) (equal x exp)
  720. ;         (let (s o e m lhs rhs)
  721. ;              (compsplt x)
  722. ;              (dcompare lhs rhs)
  723. ;              (cond ((memq sign '($pos $neg $zero)))
  724. ;                ((eq sign '$pnz) nil)
  725. ;                (t (setq s sign o odds e evens m minus)
  726. ;                   (sign x)
  727. ;                   (if (not (strongp sign s))
  728. ;                   (if (and (eq sign '$pnz) (eq s '$pn))
  729. ;;                       (setq sign s)
  730. ;                       (setq sign s odds o evens e minus m)))
  731. ;                   t))))
  732. ;        (sign exp))
  733. ;    (return sign)))
  734.  
  735. (defmfun infsimp* (e)
  736.   (if (or (atom e) (and (free e '$inf) (free e '$minf))) e (infsimp e)))
  737.  
  738. (defun sign1 (x)
  739.   (setq x (infsimp* x))
  740.   (if (eq x '$UND) (if limitp '$PNZ (merror "SIGN called on UND.")))
  741.   (prog (dum exp)
  742.     (setq dum (constp x) exp x)
  743.     (cond ((or (numberp x) (ratnump x)))
  744.           ((eq dum 'bigfloat)
  745.            (if (prog2 (setq dum ($bfloat x)) ($bfloatp dum))
  746.            (setq exp dum)))
  747.           ((eq dum 'float)
  748.            (if (and (setq dum (numer x)) (numberp dum)) (setq exp dum)))
  749.           ((and (memq dum '(numer symbol))
  750.             (prog2 (setq dum (numer x))
  751.                (or (null dum)
  752.                    (and (numberp dum)
  753.                     (prog2 (setq exp dum)
  754.                        (lessp (abs dum) 1.0e-6))))))
  755.            (cond ($signbfloat
  756.               (and (setq dum ($bfloat x)) ($bfloatp dum) (setq exp dum)))
  757.              (t (setq sign '$pnz evens nil odds (ncons x) minus nil)
  758.             (return sign)))))
  759.     (or (and (not (atom x)) (not (mnump x)) (equal x exp)
  760.          (let (s o e m lhs rhs)
  761.               (compsplt x)
  762.               (dcompare lhs rhs)
  763.               (cond ((memq sign '($pos $neg $zero)))
  764.                 ((eq sign '$pnz) nil)
  765.                 (t (setq s sign o odds e evens m minus)
  766.                    (sign x)
  767.                    (if (not (strongp sign s))
  768.                    (if (and (eq sign '$pnz) (eq s '$pn))
  769.                        (setq sign s)
  770.                        (setq sign s odds o evens e minus m)))
  771.                    t))))
  772.         (sign exp))
  773.     (return sign)))
  774.  
  775. (defun numer (x)
  776.   (let ($ratsimpexpons)
  777.        (car (errset (meval `(($ev) ,x $numer $%enumer)) nil))))
  778.  
  779. (defun constp (x)
  780.    (cond ((floatp x) 'float)
  781.      ((numberp x) 'numer)
  782.      ((symbolp x) (if (memq x '($%pi $%e $%phi $%gamma)) 'symbol))
  783.      ((eq (caar x) 'rat) 'numer)
  784.      ((eq (caar x) 'bigfloat) 'bigfloat)
  785.      ((specrepp x) (constp (specdisrep x)))
  786.      (t (do ((l (cdr x) (cdr l)) (dum) (ans 'numer))
  787.         ((null l) ans)
  788.         (setq dum (constp (car l)))
  789.         (cond ((eq dum 'float) (return 'float))
  790.               ((eq dum 'numer))
  791.               ((eq dum 'bigfloat) (setq ans 'bigfloat))
  792.               ((eq dum 'symbol)
  793.                (if (eq ans 'numer) (setq ans 'symbol)))
  794.               (t (return nil)))))))
  795.  
  796. (defmfun sign (x)
  797.   (cond ((mnump x) (setq sign (rgrp x 0) minus nil odds nil evens nil))
  798.     ((atom x) (if (eq x '$%i) (imag-err x)) (sign-any x))
  799.     ((eq (caar x) 'mtimes) (sign-mtimes x))
  800.     ((eq (caar x) 'mplus) (sign-mplus x))
  801.     ((eq (caar x) 'mexpt) (sign-mexpt x))
  802.     ((eq (caar x) '%log) (compare (cadr x) 1))
  803.     ((eq (caar x) 'mabs) (sign-mabs x))
  804.     ((memq (caar x) '(%csc %csch))
  805.      (sign (inv* (cons (ncons (zl-get (caar x) 'recip)) (cdr x)))))
  806.     ((specrepp x) (sign (specdisrep x)))
  807.     ((kindp (caar x) '$posfun) (sign-posfun x))
  808.     ((or (memq (caar x) '(%signum %erf))
  809.          (and (kindp (caar x) '$oddfun) (kindp (caar x) '$increasing)))
  810.      (sign-oddinc x))
  811.     (t (sign-any x))))
  812.  
  813. (defun sign-any (x)
  814.   (dcompare x 0)
  815.   (if (and $assume_pos
  816.        (memq sign '($pnz $pz $pn))
  817.        (if $assume_pos_pred (let ((*x* x)) (is '(($assume_pos_pred) *x*)))
  818.                 (mapatom x)))
  819.       (setq sign '$pos))
  820.   (setq minus nil evens nil 
  821.     odds (if (not (memq sign '($pos $neg $zero))) (ncons x))))
  822.  
  823. (defun sign-mtimes (x)
  824.   (setq x (cdr x))
  825.   (do ((s '$pos) (m) (o) (e)) ((null x) (setq sign s minus m odds o evens e))
  826.       (sign1 (car x))
  827.       (cond ((eq sign '$zero) (return t))
  828.         ((eq sign '$pos))
  829.         ((eq sign '$neg) (setq s (flip s) m (not m)))
  830.         ((prog2 (setq m (not (eq m minus)) o (nconc odds o) e (nconc evens e))
  831.             nil))
  832.         ((eq s sign))
  833.         ((eq s '$pos) (setq s sign))
  834.         ((eq s '$neg) (setq s (flip sign)))
  835.         ((or (and (eq s '$pz) (eq sign '$nz))
  836.          (and (eq s '$nz) (eq sign '$pz)))
  837.          (setq s '$nz))
  838.         (t (setq s '$pnz)))
  839.       (setq x (cdr x))))
  840.  
  841. (defun sign-mplus (x &aux s o e m)
  842.   (cond ((signdiff x))
  843.     ((prog2 (setq s sign e evens o odds m minus) nil))
  844.     ((signsum x))
  845.     ((prog2 (cond ((strongp s sign))    
  846.               (t (setq s sign e evens o odds m minus)))
  847.         nil))
  848.     ((and (not factored) (signfactor x)))
  849.     ((strongp sign s))
  850.     (t (setq sign s evens e odds o minus m))))
  851.  
  852. ;(defun signdiff (x)
  853. ;  (setq sign '$pnz)
  854. ;  (compsplt x)
  855. ;  (let (dum)
  856. ;       (cond ((or (equal rhs 0) (mplusp lhs)) nil)
  857. ;         ((and (memq (constp rhs) '(numer symbol))
  858. ;           (numberp (setq dum (numer rhs)))
  859. ;           (prog2 (setq rhs dum) nil)))
  860. ;         ((mplusp rhs) nil)
  861. ;         ((and (dcompare lhs rhs) (memq sign '($pos $neg $zero))))
  862. ;         ((and (not (atom lhs)) (not (atom rhs))
  863. ;           (eq (caar lhs) (caar rhs))
  864. ;           (kindp (caar lhs) '$increasing))
  865. ;          (sign (sub (cadr lhs) (cadr rhs)))
  866. ;          t)
  867. ;         ((signdiff-special lhs rhs)))))
  868. ;Update from F302 --gsb
  869. (defun signdiff (x)
  870.   (setq sign '$pnz)
  871.   (compsplt x)
  872.   (if (and (mplusp lhs) (equal rhs 0)
  873.        (null (cdddr lhs))
  874.        (negp (cadr lhs)) (not (negp (caddr lhs))))
  875.       (setq rhs (neg (cadr lhs)) lhs (caddr lhs)))
  876.   (let (dum)
  877.        (cond ((or (equal rhs 0) (mplusp lhs)) nil)
  878.          ((and (memq (constp rhs) '(numer symbol))
  879.            (numberp (setq dum (numer rhs)))
  880.            (prog2 (setq rhs dum) nil)))
  881.          ((mplusp rhs) nil)
  882.          ((and (dcompare lhs rhs) (memq sign '($pos $neg $zero))))
  883.          ((and (not (atom lhs)) (not (atom rhs))
  884.            (eq (caar lhs) (caar rhs))
  885.            (kindp (caar lhs) '$increasing))
  886.           (sign (sub (cadr lhs) (cadr rhs)))
  887.           t)
  888.     ((and (not (atom lhs)) (eq (caar lhs) 'mabs)
  889.           (alike1 (cadr lhs) rhs))
  890.      (setq sign '$pz minus nil odds nil evens nil) t)
  891.          ((signdiff-special lhs rhs)))))
  892.  
  893. (defun signdiff-special (xlhs xrhs)
  894.   (when (or (and (numberp xrhs) (minusp xrhs)
  895.          (not (atom xlhs)) (eq (sign* xlhs) '$pos))
  896.               ; e.g. sign(a^3+%pi-1) where a>0
  897.         (and (mexptp xlhs)  ; e.g. sign(%e^x-1) where x>0
  898.          (memq (sign* (sub 1 xrhs)) '($pos $zero $pz))
  899.          (eq (sign* (caddr xlhs)) '$pos)
  900.          (eq (sign* (sub (cadr xlhs) 1)) '$pos))
  901.         (and (mexptp xlhs) (mexptp xrhs)  ; e.g. sign(2^x-2^y) where x>y
  902.          (alike1 (cadr xlhs) (cadr xrhs))
  903.          (eq (sign* (sub (cadr xlhs) 1)) '$pos)
  904.          (eq (sign* (sub (caddr xlhs) (caddr xrhs))) '$pos)))
  905.     (setq sign '$pos minus nil odds nil evens nil) t))
  906.  
  907. (defun signsum (x)
  908.   (do ((l (cdr x) (cdr l)) (s '$zero))
  909.       ((null l) (setq sign s minus nil odds (list x) evens nil) t)
  910.       (sign (car l))
  911.       (cond ((or (and (eq sign '$zero)
  912.               (setq x (sub x (car l))))            
  913.          (and (eq s sign) (not (eq s '$pn))) ; $PN + $PN = $PNZ
  914.          (and (eq s '$pos) (eq sign '$pz))
  915.          (and (eq s '$neg) (eq sign '$nz))))
  916.         ((or (and (memq sign '($pz $pos)) (memq s '($zero $pz)))
  917.          (and (memq sign '($nz $neg)) (memq s '($zero $nz)))
  918.          (and (eq sign '$pn) (eq s '$zero)))         
  919.          (setq s sign))
  920.         (t (setq sign '$pnz odds (list x) evens nil minus nil)
  921.            (return nil)))))
  922.  
  923. (defun signfactor (x)
  924.   (let (y (factored t))
  925.        (setq y (factor-if-small x))
  926.        (cond ((or (mplusp y) (> (conssize y) 50.))
  927.           (prog2 (setq sign '$pnz) nil))
  928.          (t (sign y)))))
  929.  
  930. (defun factor-if-small (x)
  931.   (if (< (conssize x) 51.) (let ($ratprint) (factor x)) x))
  932.  
  933. ;(defun sign-mexpt (x)
  934. ; (let* ((expt (caddr x)) (base1 (cadr x))
  935. ;    (sign-expt (sign1 expt)) (sign-base (sign1 base1))
  936. ;    (evod (evod expt)))
  937. ;       (cond ((and (eq sign-base '$zero)
  938. ;           (memq sign-expt '($zero $neg)))
  939. ;          (dbzs-err x))
  940. ;         ((eq sign-expt '$zero) (setq sign '$pos) (tdzero (sub x 1)))
  941. ;         ((eq sign-base '$pos))
  942. ;         ((eq sign-base '$zero) (tdpos expt))
  943. ;         ((eq evod '$even)
  944. ;          (cond ((eq sign-expt '$neg)
  945. ;             (setq sign '$pos minus nil evens (ncons base1) odds nil)
  946. ;             (tdpn base1))
  947. ;            ((memq sign-base '($pn $neg))
  948. ;             (setq sign '$pos minus nil
  949. ;               evens (nconc odds evens)
  950. ;               odds nil))
  951. ;            (t (setq sign '$pz minus nil
  952. ;                 evens (nconc odds evens)
  953. ;                 odds nil))))
  954. ;         ((and (memq sign-expt '($neg $nz))
  955. ;           (memq sign-base '($nz $pz $pnz)))
  956. ;          (tdpn base1)
  957. ;          (setq sign (cond ((eq sign-base '$pnz) '$pn)
  958. ;                   ((eq sign-base '$pz) '$pos)
  959. ;                   ((eq sign-expt '$neg) '$neg)
  960. ;                   (t '$pn))))  
  961. ;         ((memq sign-expt '($pz $nz $pnz))
  962. ;          (cond ((eq sign-base '$neg)
  963. ;             (setq odds (ncons x) sign '$pn))))
  964. ;         ((eq sign-expt '$pn))
  965. ;         (t (cond ((ratnump expt)
  966. ;               (cond ((mevenp (cadr expt))
  967. ;                  (cond ((memq sign-base '($pn $neg))
  968. ;                     (setq sign-base '$pos))
  969. ;                    ((memq sign-base '($pnz $nz))
  970. ;                     (setq sign-base '$pz)))
  971. ;                  (setq evens (nconc odds evens)
  972. ;                    odds nil minus nil))
  973. ;                 ((mevenp (caddr expt))
  974. ;                  (cond ((eq sign-base '$neg)
  975. ;                     (imag-err x))
  976. ;                    ((eq sign-base '$pn)
  977. ;                     (setq sign-base '$pos)
  978. ;                     (tdpos base1))
  979. ;                    ((eq sign-base '$nz)
  980. ;                     (setq sign-base '$zero)
  981. ;                     (tdzero base1))
  982. ;                    (t (setq sign-base '$pz)
  983. ;                       (tdpz base1)))))))
  984. ;        (cond ((eq sign-expt '$neg)
  985. ;               (cond ((eq sign-base '$zero) (dbzs-err x))
  986. ;                 ((eq sign-base '$pz)
  987. ;                  (setq sign-base '$pos)
  988. ;                  (tdpos base1))
  989. ;                 ((eq sign-base '$nz)
  990. ;                  (setq sign-base '$neg)
  991. ;                  (tdneg base1))
  992. ;                 ((eq sign-base '$pnz)
  993. ;                  (setq sign-base '$pn)
  994. ;                  (tdpn base1)))))
  995. ;        (setq sign sign-base)))))
  996. ;Update from F302 --gsb
  997. (defmvar complexsign nil)
  998. (defun sign-mexpt (x)
  999.  (let* ((expt (caddr x)) (base1 (cadr x))
  1000.     (sign-expt (sign1 expt)) (sign-base (sign1 base1))
  1001.     (evod (evod expt)))
  1002.        (cond ((and (eq sign-base '$zero)
  1003.            (memq sign-expt '($zero $neg)))
  1004.           (dbzs-err x))
  1005.          ((eq sign-expt '$zero) (setq sign '$pos) (tdzero (sub x 1)))
  1006.          ((eq sign-base '$pos))
  1007.          ((eq sign-base '$zero) (tdpos expt))
  1008.          ((eq evod '$even)
  1009.           (cond ((eq sign-expt '$neg)
  1010.              (setq sign '$pos minus nil evens (ncons base1) odds nil)
  1011.              (tdpn base1))
  1012.             ((memq sign-base '($pn $neg))
  1013.              (setq sign '$pos minus nil
  1014.                evens (nconc odds evens)
  1015.                odds nil))
  1016.             (t (setq sign '$pz minus nil
  1017.                  evens (nconc odds evens)
  1018.                  odds nil))))
  1019.          ((and (memq sign-expt '($neg $nz))
  1020.            (memq sign-base '($nz $pz $pnz)))
  1021.           (tdpn base1)
  1022.           (setq sign (cond ((eq sign-base '$pnz) '$pn)
  1023.                    ((eq sign-base '$pz) '$pos)
  1024.                    ((eq sign-expt '$neg) '$neg)
  1025.                    (t '$pn))))  
  1026.          ((memq sign-expt '($pz $nz $pnz))
  1027.           (cond ((eq sign-base '$neg)
  1028.              (setq odds (ncons x) sign '$pn))))
  1029.          ((eq sign-expt '$pn))
  1030.          (t (cond ((ratnump expt)
  1031.                (cond ((mevenp (cadr expt))
  1032.                   (cond ((memq sign-base '($pn $neg))
  1033.                      (setq sign-base '$pos))
  1034.                     ((memq sign-base '($pnz $nz))
  1035.                      (setq sign-base '$pz)))
  1036.                   (setq evens (nconc odds evens)
  1037.                     odds nil minus nil))
  1038.                  ((mevenp (caddr expt))
  1039.                   (cond (complexsign
  1040.                      (setq sign-base (setq sign-expt '$pnz)))
  1041.                     ((eq sign-base '$neg) (imag-err x))
  1042.                     ((eq sign-base '$pn)
  1043.                      (setq sign-base '$pos)
  1044.                      (tdpos base1))
  1045.                     ((eq sign-base '$nz)
  1046.                      (setq sign-base '$zero)
  1047.                      (tdzero base1))
  1048.                     (t (setq sign-base '$pz)
  1049.                        (tdpz base1)))))))
  1050.         (cond ((eq sign-expt '$neg)
  1051.                (cond ((eq sign-base '$zero) (dbzs-err x))
  1052.                  ((eq sign-base '$pz)
  1053.                   (setq sign-base '$pos)
  1054.                   (tdpos base1))
  1055.                  ((eq sign-base '$nz)
  1056.                   (setq sign-base '$neg)
  1057.                   (tdneg base1))
  1058.                  ((eq sign-base '$pnz)
  1059.                   (setq sign-base '$pn)
  1060.                   (tdpn base1)))))
  1061.         (setq sign sign-base)))))
  1062.     
  1063. (defun sign-mabs (x)
  1064.   (sign (cadr x))
  1065.   (cond ((memq sign '($pos $zero)))
  1066.     ((memq sign '($neg $pn)) (setq sign '$pos))
  1067.     (t (setq sign '$pz minus nil evens (nconc odds evens) odds nil))))
  1068.  
  1069. (defun sign-posfun (x) x ;Ignored
  1070.        (setq sign '$pos minus nil odds nil evens nil))
  1071.  
  1072. (defun sign-oddinc (x) (sign (cadr x)))
  1073.  
  1074. (defun imag-err (x)
  1075.  (if sign-imag-errp (merror "SIGN called on an imaginary argument:~%~M" x)
  1076.             (throw 'sign-imag-err t)))
  1077.  
  1078. (defun dbzs-err (x) (merror "Division by zero detected in SIGN:~%~M" x))
  1079.  
  1080. (defmfun $featurep (e ind)
  1081.   (cond ((not (symbolp ind))
  1082.      (merror "~M is not a symbolic atom - FEATUREP." ind))
  1083.     ((eq ind '$integer) (MAXIMA-INTEGERP e))
  1084.     ((eq ind '$noninteger) (nonintegerp e))
  1085.     ((eq ind '$even) (mevenp e))
  1086.     ((eq ind '$odd) (moddp e))
  1087.     ((eq ind '$real)
  1088.      (if (atom e)
  1089.          (or (numberp e) (kindp e '$real) (numberp (numer e)))
  1090.          (free ($rectform e) '$%i)))
  1091.     ((eq ind '$complex) t)
  1092.     ((symbolp e) (kindp e ind))))
  1093.  
  1094. (defmfun MAXIMA-INTEGERP (e)
  1095.   (cond ((integerp e))
  1096.     ((mnump e) nil)
  1097.     ((atom e) (kindp e '$integer))
  1098.     ((eq (caar e) 'mrat) (and (integerp (cadr e)) (equal (cddr e) 1)))
  1099.     ((memq (caar e) '(mtimes mplus)) (intp e))
  1100.     ((eq (caar e) 'mexpt) (intp-mexpt e))))
  1101.  
  1102. (defmfun nonintegerp (e)
  1103.   (let (num)
  1104.     (cond ((integerp e) nil)
  1105.       ((mnump e) t)
  1106.       ((atom e) (kindp e '$noninteger))
  1107.       ((specrepp e) (nonintegerp (specdisrep e)))
  1108.       ((and (eq (caar e) 'mplus) (ratnump (cadr e)) (intp (cdr e))) t)
  1109.       ((and (integerp (setq num ($num e)))
  1110.         (prog2 (setq e ($denom e)) 
  1111.                (or (eq (csign (sub e num)) '$pos)
  1112.                (eq (csign (add2 e num)) '$neg))))
  1113.        t))))
  1114.  
  1115. (defun intp (l)
  1116.   (setq l (cdr l))
  1117.   (do () ((null l) t)
  1118.       (if (MAXIMA-INTEGERP (car l)) (setq l (cdr l)) (return nil))))
  1119.  
  1120. (defun intp-mexpt (e)
  1121.   (and (integerp (caddr e)) (not (minusp (caddr e))) (MAXIMA-INTEGERP (cadr e))))
  1122.  
  1123.  
  1124. (defmfun mevenp (e)
  1125.   (cond ((integerp e) (not (oddp e)))
  1126.     ((mnump e) nil)
  1127.     (t (eq '$even (evod e)))))
  1128.  
  1129. (defmfun moddp (e)
  1130.   (cond ((integerp e) (oddp e))
  1131.     ((mnump e) nil)
  1132.     (t (eq '$odd (evod e)))))
  1133.  
  1134. (defmfun evod (e)
  1135.   (cond ((integerp e) (if (oddp e) '$odd '$even))
  1136.     ((mnump e) nil)
  1137.     ((atom e) (cond ((kindp e '$odd) '$odd) ((kindp e '$even) '$even)))
  1138.     ((eq 'mtimes (caar e)) (evod-mtimes e))
  1139.     ((eq 'mplus (caar e)) (evod-mplus e))
  1140.     ((eq 'mexpt (caar e)) (evod-mexpt e))))
  1141.  
  1142. (defun evod-mtimes (x)
  1143.   (do ((l (cdr x) (cdr l)) (flag '$odd))
  1144.       ((null l) flag)
  1145.       (setq x (evod (car l)))
  1146.       (cond ((eq '$odd x))
  1147.         ((eq '$even x) (setq flag '$even))
  1148.         ((MAXIMA-INTEGERP (car l)) (cond ((eq '$odd flag) (setq flag nil))))
  1149.         (t (return nil)))))
  1150.  
  1151. (defun evod-mplus (x)
  1152.   (do ((l (cdr x) (cdr l)) (flag))
  1153.       ((null l) (cond (flag '$odd) (t '$even)))
  1154.       (setq x (evod (car l)))
  1155.       (cond ((eq '$odd x) (setq flag (not flag)))
  1156.         ((eq '$even x))
  1157.         (t (return nil)))))
  1158.  
  1159. (defun evod-mexpt (x)
  1160.   (cond ((and (integerp (caddr x)) (not (minusp (caddr x)))) (evod (cadr x)))))
  1161.  
  1162.  
  1163. (declare-top (special mgqp mlqp))
  1164.  
  1165. (defmode cl () (atom (selector +labs) (selector -labs) (selector data)))
  1166.  
  1167. ;(defun c-dobj macro (x) `(list . ,(cdr x)))
  1168.  
  1169. (defmacro c-dobj (&rest x) `(list . , x))
  1170.  
  1171. (defun dcompare (x y)
  1172.   (setq odds (list (sub x y)) evens nil minus nil
  1173.     sign (cond ((eq x y) '$zero)
  1174.            ((or (eq '$inf x) (eq '$minf y)) '$pos)
  1175.            ((or (eq '$minf x) (eq '$inf y)) '$neg)
  1176.            (t (dcomp x y)))))
  1177.  
  1178. (defun dcomp (x y) 
  1179.   (let (mgqp mlqp)
  1180.     (setq x (dinternp x) y (dinternp y))
  1181.     (cond ((or (null x) (null y)) '$pnz)
  1182.       ((progn (clear) (deq x y) (sel y +labs)))
  1183.       (t '$pnz))))
  1184.  
  1185.  
  1186. (defun deq (x y)
  1187.   (cond ((dmark x '$zero) nil)
  1188.     ((eq x y))
  1189.     (t (do ((l (sel x data) (cdr l))) ((null l))
  1190.            (if (and (visiblep (car l)) (deqf x y (car l))) (return t))))))
  1191.  
  1192. (defun deqf (x y f)
  1193.   (cond ((eq 'meqp (caar f))
  1194.      (if (eq x (cadar f)) (deq (caddar f) y) (deq (cadar f) y)))
  1195.     ((eq 'mgrp (caar f))
  1196.      (if (eq x (cadar f)) (dgr (caddar f) y) (dls (cadar f) y)))
  1197.     ((eq 'mgqp (caar f))
  1198.      (if (eq x (cadar f)) (dgq (caddar f) y) (dlq (cadar f) y)))
  1199.     ((eq 'mnqp (caar f))
  1200.      (if (eq x (cadar f)) (dnq (caddar f) y) (dnq (cadar f) y)))))
  1201.  
  1202. (defun dgr (x y)
  1203.   (cond ((dmark x '$pos) nil)
  1204.     ((eq x y))
  1205.     (t (do ((l (sel x data) (cdr l))) ((null l))
  1206.            (if (or mlqp (and (visiblep (car l)) (dgrf x y (car l)))) (return t))))))
  1207.  
  1208. (defun dgrf (x y f)
  1209.   (cond ((eq 'mgrp (caar f)) (if (eq x (cadar f)) (dgr (caddar f) y)))
  1210.     ((eq 'mgqp (caar f)) (if (eq x (cadar f)) (dgr (caddar f) y)))
  1211.     ((eq 'meqp (caar f))
  1212.      (if (eq x (cadar f)) (dgr (caddar f) y) (dgr (cadar f) y)))))
  1213.  
  1214. (defun dls (x y)
  1215.   (cond ((dmark x '$neg) nil)
  1216.     ((eq x y))
  1217.     (t (do ((l (sel x data) (cdr l))) ((null l))
  1218.            (if (or mgqp (and (visiblep (car l)) (dlsf x y (car l)))) (return t))))))
  1219.  
  1220. (defun dlsf (x y f)
  1221.   (cond ((eq 'mgrp (caar f)) (if (eq x (caddar f)) (dls (cadar f) y)))
  1222.     ((eq 'mgqp (caar f)) (if (eq x (caddar f)) (dls (cadar f) y)))
  1223.     ((eq 'meqp (caar f))
  1224.      (if (eq x (cadar f)) (dls (caddar f) y) (dls (cadar f) y)))))
  1225.  
  1226. (defun dgq (x y)
  1227.   (cond ((memq (sel x +labs) '($pos $zero)) nil)
  1228.     ((eq '$nz (sel x +labs)) (deq x y))
  1229.     ((eq '$pn (sel x +labs)) (dgr x y))
  1230.     ((dmark x '$pz) nil)
  1231.     ((eq x y) (setq mgqp t) nil)
  1232.     (t (do ((l (sel x data) (cdr l))) ((null l))
  1233.            (if (and (visiblep (car l)) (dgqf x y (car l))) (return t))))))
  1234.  
  1235. (defun dgqf (x y f)
  1236.   (cond ((eq 'mgrp (caar f)) (if (eq x (cadar f)) (dgr (caddar f) y)))
  1237.     ((eq 'mgqp (caar f)) (if (eq x (cadar f)) (dgq (caddar f) y)))
  1238.     ((eq 'meqp (caar f))
  1239.      (if (eq x (cadar f)) (dgq (caddar f) y) (dgq (cadar f) y)))))
  1240.  
  1241. (defun dlq (x y)
  1242.   (cond ((memq (sel x +labs) '($neg $zero)) nil)
  1243.     ((eq '$pz (sel x +labs)) (deq x y))
  1244.     ((eq '$pn (sel x +labs)) (dgr x y))
  1245.     ((dmark x '$nz) nil)
  1246.     ((eq x y) (setq mlqp t) nil)
  1247.     (t (do ((l (sel x data) (cdr l))) ((null l))
  1248.            (if (and (visiblep (car l)) (dlqf x y (car l))) (return t))))))
  1249.  
  1250. (defun dlqf (x y f)
  1251.   (cond ((eq 'mgrp (caar f)) (if (eq x (caddar f)) (dls (cadar f) y)))
  1252.     ((eq 'mgqp (caar f)) (if (eq x (caddar f)) (dlq (cadar f) y)))
  1253.     ((eq 'meqp (caar f))
  1254.      (if (eq x (cadar f)) (dlq (caddar f) y) (dlq (cadar f) y)))))
  1255.  
  1256. (defun dnq (x y)
  1257.   (cond ((memq (sel x +labs) '($pos $neg)) nil)
  1258.     ((eq '$pz (sel x +labs)) (dgr x y))
  1259.     ((eq '$nz (sel x +labs)) (dls x y))
  1260.     ((dmark x '$pn) nil)
  1261.     ((eq x y) nil)
  1262.     (t (do ((l (sel x data) (cdr l))) ((null l))
  1263.            (if (and (visiblep (car l)) (dnqf x y (car l))) (return t))))))
  1264.  
  1265. (defun dnqf (x y f)
  1266.   (cond ((eq 'meqp (caar f))
  1267.      (if (eq x (cadar f)) (dnq (caddar f) y) (dnq (cadar f) y)))))
  1268.  
  1269.  
  1270. (defun dmark (x m  &aux #+lispm (default-cons-area working-storage-area ))
  1271.   (cond ((eq m (sel x +labs)))
  1272.     ((and dbtrace (PROG1 t (mtell "marking ~M ~M"
  1273.                       (if (atom x) x (car x))
  1274.                       m))
  1275.           nil))
  1276.     (t (setq +labs (cons x +labs)) (_ (sel x +labs) m) nil)))
  1277.  
  1278. (defun daddgr (flag x)
  1279.    (let (lhs rhs)
  1280.     (compsplt x)
  1281.     (mdata flag 'mgrp (dintern lhs) (dintern rhs))
  1282.     (if (or (mnump lhs) (constant lhs))
  1283.         (list '(mlessp) rhs lhs)
  1284.         (list '(mgreaterp) lhs rhs))))
  1285.  
  1286. (defun daddgq (flag x)
  1287.    (let (lhs rhs)
  1288.     (compsplt x)
  1289.     (mdata flag 'mgqp (dintern lhs) (dintern rhs))
  1290.     (if (or (mnump lhs) (constant lhs))
  1291.         (list '(mleqp) rhs lhs)
  1292.         (list '(mgeqp) lhs rhs))))
  1293.  
  1294. (defun daddeq (flag x)
  1295.    (let (lhs rhs)
  1296.     (compsplt-eq x)
  1297.     (mdata flag 'meqp (dintern lhs) (dintern rhs))
  1298.     (list '($equal) lhs rhs)))
  1299.  
  1300. (defun daddnq (flag x)
  1301.    (let (lhs rhs)
  1302.     (compsplt-eq x)
  1303.     (cond ((and (mtimesp lhs) (equal rhs 0))
  1304.            (dolist (term (cdr lhs)) (daddnq flag term)))
  1305.           ((and (mexptp lhs) (mexptp rhs)
  1306.             (integerp (caddr lhs)) (integerp (caddr rhs))
  1307.             (equal (caddr lhs) (caddr rhs)))
  1308.            (mdata flag 'mnqp (dintern (cadr lhs)) (dintern (cadr rhs)))
  1309.            (cond ((not (oddp (caddr lhs)))
  1310.               (mdata flag 'mnqp (dintern (cadr lhs))
  1311.                     (dintern (neg (cadr rhs)))))))
  1312.           (t (mdata flag 'mnqp (dintern lhs) (dintern rhs))))
  1313.     (list '(mnot) (list '($equal) lhs rhs))))
  1314.  
  1315. (defun tdpos (x) (daddgr t x) (setq locals (cons (cons x '$pos) locals)))
  1316.  
  1317. (defun tdneg (x) (daddgr t (neg x)) (setq locals (cons (cons x '$neg) locals)))
  1318.  
  1319. (defun tdzero (x) (daddeq t x) (setq locals (cons (cons x '$zero) locals)))
  1320.  
  1321. (defun tdpn (x) (daddnq t x) (setq locals (cons (cons x '$pn) locals)))
  1322.  
  1323. (defun tdpz (x) (daddgq t x) (setq locals (cons (cons x '$pz) locals)))
  1324.  
  1325. (defun compsplt-eq (x)
  1326.   (compsplt x)
  1327.   (if (equal lhs 0) (setq lhs rhs rhs 0))
  1328.   (if (and (equal rhs 0)
  1329.        (or (mexptp lhs)
  1330.            (and (not (atom lhs))
  1331.             (kindp (caar lhs) '$oddfun)
  1332.             (kindp (caar lhs) '$increasing))))
  1333.       (setq lhs (cadr lhs))))
  1334.  
  1335. (defun mdata (flag r x y) (if flag (mfact r x y) (mkill r x y)))
  1336.  
  1337. (defun mfact (r x y &aux #+lispm (default-cons-area working-storage-area ))
  1338.   (let ((f (datum (list r x y))))
  1339.        (cntxt f context)
  1340.        (addf f x)
  1341.        (addf f y)))
  1342.  
  1343. (defun mkill (r x y)
  1344.   (let ((f (car (datum (list r x y)))))
  1345.        (kcntxt f context)
  1346.        (MAXIMA-REMF f x)
  1347.        (MAXIMA-REMF f y)))
  1348.  
  1349. (defun mkind (x y) (kind (dintern x) (dintern y)))
  1350.  
  1351. (defmfun rgrp (x y)
  1352.   (cond ((or ($bfloatp x) ($bfloatp y))
  1353.      (setq x (let (($float2bf t)) (cadr ($bfloat (sub x y)))) y 0))
  1354.     ((numberp x)
  1355.      (cond ((numberp y))
  1356.            (t (setq x (times x (caddr y)) y (cadr y)))))
  1357.     ((numberp y) (setq y (times (caddr x) y) x (cadr x)))
  1358.     (t (let ((dummy x))
  1359.         (setq x (times (cadr x) (caddr y)))
  1360.         (setq y (times (caddr dummy) (cadr y))))))
  1361.   (cond ((greaterp x y) '$pos)
  1362.     ((greaterp y x) '$neg)
  1363.     (t '$zero)))
  1364.  
  1365. (defun mcons (x l) (cons (car l) (cons x (cdr l))))
  1366.  
  1367. (defun flip (s) 
  1368.   (cond ((eq '$pos s) '$neg)
  1369.     ((eq '$neg s) '$pos)
  1370.     ((eq '$pz s) '$nz)
  1371.     ((eq '$nz s) '$pz)
  1372.     (t s)))
  1373.  
  1374. (defun strongp (x y)
  1375.   (cond ((eq '$pnz y))
  1376.     ((eq '$pnz x) nil)
  1377.     ((memq y '($pz $nz $pn)))))
  1378.  
  1379. (defun munformat (form)
  1380.   (if (atom form) form (cons (caar form) (mapcar #'munformat (cdr form)))))
  1381.  
  1382. (defmfun declarekind (var prop)  ; This function is for $DECLARE to use.
  1383.   (let (prop2)
  1384.        (cond ((truep (list 'kind var prop)) t)
  1385.          ((or (falsep (list 'kind var prop))
  1386.           (and (setq prop2 (assq prop '(($integer . $noninteger)
  1387.                         ($noninteger . $integer)
  1388.                         ($increasing . $decreasing)
  1389.                         ($decreasing . $increasing)
  1390.                         ($symmetric . $antisymmetric)
  1391.                         ($antisymmetric . $symmetric)
  1392.                         ($oddfun . $evenfun)
  1393.                         ($evenfun . $oddfun))))
  1394.                (truep (list 'kind var (cdr prop2)))))
  1395.           (merror "Inconsistent Declaration: ~:M" `(($DECLARE) ,var ,prop)))
  1396.          (t (mkind var prop) t))))
  1397.  
  1398. ;;;  These functions reformat expressions to be stored in the data base.
  1399.  
  1400. (defun compsplt (x)
  1401.   (cond ((atom x) (setq lhs x rhs 0))
  1402.     ((atom (car x)) (setq lhs x rhs 0))
  1403.     ((not (null (cdr (symbols x)))) (compsplt2 x))
  1404.     (t (compsplt1 x))))
  1405.  
  1406. (defun compsplt1 (x)
  1407.    (do ((exp (list x 0)) (success nil))
  1408.        ((or success (symbols (cadr exp))) (setq lhs (car exp) rhs (cadr exp)))
  1409.        (cond ((atom (car exp)) (setq success t))
  1410.          ((eq (caaar exp) 'mplus)  (setq exp (splitsum exp)))
  1411.          ((eq (caaar exp) 'mtimes) (setq exp (splitprod exp)))
  1412.          (t (setq success t)))))
  1413.  
  1414. (defun compsplt2 (x)
  1415.    (cond ((or (atom x) (atom (car x)))  ; If x is an atom or a single level
  1416.       (setq lhs x rhs 0))        ;    list then we won't change it any.
  1417.      ((negp x)        ; If x is a negative expression but not a 
  1418.       (setq lhs 0 rhs (neg x)))  ; sum, then get rid of the negative sign.
  1419.      ((or (cdddr x)            ; If x is not a sum, or is a sum
  1420.           (not (eq (caar x) 'mplus))     ; with more than 2 terms, or has
  1421.           (intersect* (symbols (cadr x)) (symbols (caddr x))))
  1422.              ; some symbols common to both summands, then do nothing.
  1423.       (setq lhs x rhs 0))
  1424.      ((and (or (negp (cadr x)) (mnump (cadr x)))
  1425.            (not (negp (caddr x))))
  1426.       (setq lhs (caddr x) rhs (neg (cadr x))))
  1427.      ((and (not (negp (cadr x)))
  1428.            (or (negp (caddr x)) (mnump (caddr x))))
  1429.       (setq lhs (cadr x) rhs (neg (caddr x))))
  1430.      ((and (negp (cadr x)) (negp (caddr x)))
  1431.       (setq lhs 0 rhs (neg x)))
  1432.      (t (setq lhs x rhs 0))))
  1433.  
  1434. (defun negp (x) (and (mtimesp x) (mnegp (cadr x))))
  1435.              
  1436. (defun splitsum (exp)
  1437.    (do ((llist (cdar exp) (cdr llist)) (lhs (car exp)) (rhs (cadr exp)))
  1438.        ((null llist) (if (mplusp lhs) (setq success t))
  1439.             (list lhs rhs))
  1440.        (cond ((memq '$inf llist) (setq rhs (add2 '$inf (sub* rhs (addn llist t)))
  1441.                       lhs (add2 '$inf (sub* lhs (addn llist t)))
  1442.                       llist nil))
  1443.          ((memq '$minf llist) (setq rhs
  1444.                        (add2 '$minf (sub* rhs (addn llist t)))
  1445.                        lhs
  1446.                        (add2 '$minf (sub* lhs (addn llist t)))
  1447.                        llist nil))
  1448.          ((null (symbols (car llist))) (setq lhs (sub lhs (car llist))
  1449.                         rhs (sub rhs (car llist)))))))
  1450.  
  1451. (defun splitprod (exp)
  1452.   (do ((flipsign) (lhs (car exp)) (rhs (cadr exp)) (llist (cdar exp) (cdr llist))
  1453.           (sign) (minus) (evens) (odds))
  1454.       ((null llist) (if (mtimesp lhs) (setq success t))
  1455.            (cond (flipsign (compsplt (sub lhs rhs))
  1456.                    (setq success t)
  1457.                    (list rhs lhs))
  1458.              (t (list lhs rhs))))
  1459.       (when (null (symbols (car llist)))
  1460.         (sign (car llist))
  1461.         (if (eq sign '$neg) (setq flipsign (not flipsign)))
  1462.         (if (memq sign '($pos $neg))
  1463.         (setq lhs (div lhs (car llist)) rhs (div rhs (car llist)))))))
  1464.  
  1465. (defun symbols (x)
  1466.   (let (($listconstvars %initiallearnflag)) (cdr ($listofvars x))))
  1467.  
  1468. ;; %initiallearnflag is only necessary so that %PI, %E, etc. can be LEARNed.
  1469.  
  1470. (eval-when (load)
  1471. (setq %initiallearnflag t)
  1472. (def-learn $%e `((mequal) $%e ,(mget '$%e '$numer)) t)
  1473. (def-learn $%pi `((mequal) $%pi ,(mget '$%pi '$numer)) t)
  1474. (def-learn $%phi `((mequal) $%phi ,(mget '$%phi '$numer)) t)
  1475. (def-learn $%gamma `((mequal) $%gamma ,(mget '$%gamma '$numer)) t)
  1476.  
  1477. ;(learn `((mequal) $%e ,(mget '$%e '$numer)) t)
  1478. ;(learn `((mequal) $%pi ,(mget '$%pi '$numer)) t)
  1479. ;(learn `((mequal) $%phi ,(mget '$%phi '$numer)) t)
  1480. ;(learn `((mequal) $%gamma ,(mget '$%gamma '$numer)) t)
  1481. (setq %initiallearnflag nil)
  1482.  
  1483. (mapc #'TRUE*
  1484.       '((par ($even $odd) $integer)
  1485.     (kind $integer $rational)
  1486.     (par ($rational $irrational) $real)
  1487.     (par ($real $imaginary) $complex)
  1488.     
  1489.     (kind %log $increasing)
  1490.     (kind %atan $increasing) (kind %atan $oddfun)
  1491.     (kind $delta $evenfun)
  1492.     (kind %sinh $increasing) (kind %sinh $oddfun)
  1493.     (kind %cosh $posfun)
  1494.     (kind %tanh $increasing) (kind %tanh $oddfun)
  1495.     (kind %coth $oddfun)
  1496.     (kind %csch $oddfun)
  1497.     (kind %sech $posfun)
  1498.     (kind $li $complex)
  1499.     (kind %cabs $complex)
  1500.     (kind $zeta $posfun)))
  1501.  
  1502. ($newcontext '$initial)  ; Create an initial context for the user
  1503.               ; which is a subcontext of $global.
  1504.  
  1505. )
  1506.  
  1507.  
  1508.