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 / outmis.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  30.4 KB  |  959 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.  
  9. (in-package "MAXIMA")
  10. ;    ** (c) Copyright 1982 Massachusetts Institute of Technology **
  11.  
  12. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  13. ;;;                                                                ;;;
  14. ;;;                Miscellaneous Out-of-core Files                 ;;;
  15. ;;;                                                                ;;;
  16. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  17.  
  18. (macsyma-module outmis)
  19.  
  20. (declare-top (FIXNUM NN))
  21.  
  22. #+ITS (DECLARE (SPECIAL TTY-FILE))
  23.  
  24. (declare-top (SPLITFILE STATUS))
  25.  
  26. #+(or ITS Multics TOPS-20)
  27. (declare-top (SPECIAL LINEL MATHLAB-GROUP-MEMBERS)
  28.      (*EXPR STRIPDOLLAR MEVAL)
  29.      (*LEXPR CONCAT))
  30.  
  31.  
  32.  
  33. #+(or ITS Multics TOPS-20)
  34. (PROGN 'COMPILE
  35.  
  36. ;;; These are used by $SEND when sending to logged in Mathlab members
  37. #-Multics
  38. (SETQ MATHLAB-GROUP-MEMBERS
  39.       '(JPG ELLEN GJC RZ KMP WGD MERMAN))
  40.  
  41. ;;; IOTA is a macro for doing file I/O binding, guaranteeing that
  42. ;;;  the files it loads will get closed.
  43. ;;;  Usage: (IOTA ((<variable1> <filename1> <modes1>)
  44. ;;;                (<variable2> <filename2> <modes2>) ...)
  45. ;;;          <body>)
  46. ;;;  Opens <filenameN> with <modesN> binding it to <variableN>. Closes
  47. ;;;   any <variableN> which still has an open file or SFA in it when
  48. ;;;   PDL unwinding is done.
  49. ;;; No IOTA on Multics yet,
  50. #-Multics
  51. (EVAL-WHEN (EVAL COMPILE)
  52.            (COND ((NOT (STATUS FEATURE IOTA))
  53.                   (LOAD #+ITS '((DSK LIBLSP) IOTA FASL)
  54.             #-ITS '((LISP) IOTA FASL)))))
  55.  
  56. ;;; TEXT-OUT
  57. ;;;  Prints a list of TEXT onto STREAM.
  58. ;;;
  59. ;;;  TEXT must be a list of things to be printed onto STREAM.
  60. ;;;    For each element in TEXT, A, if A is a symbol with first
  61. ;;;    character "&", it will be fullstripped and PRINC'd into the
  62. ;;;    stream; otherwise it will be $DISP'd onto STREAM (by binding
  63. ;;;    OUTFILES and just calling $DISP normally).
  64. ;;;
  65. ;;;  STREAM must be an already-open file object.
  66.  
  67. (DEFUN TEXT-OUT (TEXT STREAM)
  68.   (DO ((A TEXT (CDR A))
  69.        (|^R| T)
  70.        (|^W| T)
  71.        (LINEL 69.)
  72.        (OUTFILES (NCONS STREAM)))
  73.       ((NULL A))
  74.     (COND ((AND (SYMBOLP (CAR A))
  75.         (EQ (GETCHAR (CAR A) 1.) '|&|))
  76.        (PRINC (STRIPDOLLAR (CAR A)) STREAM))
  77.       (T (TERPRI STREAM)
  78.          (MEVAL `(($DISP) ($STRING ,(CAR A))))))
  79.        (TERPRI STREAM)))
  80.  
  81. ;;; MAIL
  82. ;;;  Sends mail to a recipient, TO, via the normal ITS mail protocol
  83. ;;;  by writing out to DSK:.MAIL.;MAIL > and letting COMSAT pick it 
  84. ;;;  up and deliver it. Format for what goes in the MAIL > file should
  85. ;;;  be kept up to date with what is documented in KSC;?RQFMT >
  86. ;;;
  87. ;;;  TO must be a name (already STRIPDOLLAR'd) to whom the mail should
  88. ;;;    be delivered.
  89. ;;;
  90. ;;;  TEXT-LIST is a list of Macsyma strings and/or general expressions
  91. ;;;    which will compose the message.
  92.  
  93. #+(OR LISPM ITS) ;Do these both at once.
  94. (DEFUN MAIL (TO TEXT-LIST)
  95.   (IOTA ((STREAM  "DSK:.MAIL.;MAIL >" 'OUT))
  96.     (mformat stream
  97.        "FROM-PROGRAM:Macsyma
  98. AUTHOR:~A
  99. FROM-UNAME:~A
  100. RCPT:~A
  101. TEXT;-1~%"
  102.        (STATUS USERID)
  103.        (STATUS UNAME)
  104.        (NCONS TO))
  105.     (TEXT-OUT TEXT-LIST STREAM)))
  106.  
  107. ;;; This code is new and untested. Please report bugs -kmp
  108. ;#+TOPS-20 
  109. ;(DEFUN MAIL (TO TEXT-LIST)
  110. ;  (IOTA ((STREAM "MAIL:/[--NETWORK-MAIL--/]..-1"
  111. ;         '(OUT ASCII DSK BLOCK NODEFAULT)))
  112. ;    (MFORMAT STREAM
  113. ;      "/ ~A
  114. ;~A
  115. ;/
  116. ;From: ~A at ~A~%"
  117. ;      (STATUS SITE) TO (STATUS USERID) (STATUS SITE))
  118. ;    (COND ((NOT (EQ (STATUS USERID) (STATUS UNAME)))
  119. ;       (MFORMAT STREAM "Sender: ~A at ~A~%" (STATUS UNAME) (STATUS SITE))))
  120. ;    (MFORMAT STREAM "Date: ~A
  121. ;TO:   ~A~%~%"
  122. ;        (TIME-AND-DATE) TO)
  123. ;    (TEXT-OUT TEXT-LIST STREAM)))
  124.  
  125. #+Multics
  126. (defvar macsyma-mail-count 0 "The number of messages sent so far")
  127. #+Multics
  128. (progn 'compile
  129. (DEFUN MAIL (TO TEXT-LIST)
  130.   (let* ((open-file ())
  131.      (macsyma-unique-id (macsyma-unique-id 'unsent
  132.                            (increment macsyma-mail-count)))
  133.      (file-name (catenate (pathname-util "pd")
  134.                   ">macsyma_mail." macsyma-unique-id)))
  135.     (unwind-protect
  136.       (progn
  137.        (setq open-file (open file-name '(out ascii block dsk)))
  138.        (text-out text-list open-file)
  139.        (close open-file)
  140.        (cline (catenate "send_mail " to " -input_file " file-name
  141.                     " -no_subject")))
  142.       (deletef open-file))))
  143.  
  144. (defun macsyma-unique-id (prefix number)
  145.   (implode (append (explode prefix) (list number))))
  146. )
  147.  
  148. ;;; $BUG
  149. ;;;  With no args, gives info on itself. With any positive number of
  150. ;;;  args, mails all args to MACSYMA via the MAX-MAIL command.
  151. ;;;  Returns $DONE
  152.  
  153. (DEFMSPEC $BUG (X) (SETQ X (CDR X))
  154.        (COND ((NULL X)
  155.           (MDESCRIBE '$BUG))
  156.          (T 
  157.           (MAX-MAIL 'BUG X)))
  158.        '$DONE)
  159.  
  160. #+MULTICS
  161. (DEFMACRO CHECK-AND-STRIP-ADDRESS (ADDRESS)
  162.   `(COND ((EQUAL (GETCHARN ,ADDRESS 1) #\&)
  163.       (STRIPDOLLAR ,ADDRESS))
  164.      (T (MERROR "Mail: Address field must be a string"))))
  165. #-MULTICS
  166. (DEFMACRO CHECK-AND-STRIP-ADDRESS (ADDRESS)
  167.   `(STRIPDOLLAR ,ADDRESS))
  168.  
  169. ;;; $MAIL
  170. ;;;  With no args, gives info on itself.
  171. ;;;  With 1 arg, sends the MAIL to Macsyma. Like bug, only doesn't
  172. ;;;   tag the mail as a bug to be fixed.
  173. ;;;  With 2 or more args, assumes that arg1 is a recipient and other
  174. ;;;   args are the text to be MAIL'd.
  175. ;;; Works for Multics, ITS, and TOPS-20.
  176.  
  177. (DEFMSPEC $MAIL (X) (SETQ X (CDR X)) 
  178.   (COND ((NULL X)
  179.      (MDESCRIBE '$MAIL))
  180.     ((= (LENGTH X) 1.)
  181.      (MAX-MAIL 'MAIL X))
  182.     (T (LET ((NAME (CHECK-AND-STRIP-ADDRESS (CAR X))))
  183.          (MAIL NAME (CDR X))
  184.     #-Multics(MFORMAT NIL "~&;MAIL'd to ~A~%" NAME))))
  185. ;;;On Multics Mailer will do this.
  186.        '$DONE)
  187.  
  188. ;;; MAX-MAIL
  189. ;;;  Mails TEXT-LIST to MACSYMA mail. Normal ITS mail header 
  190. ;;;  is suppressed. Header comes out as:
  191. ;;;  From <Name> via <Source> command. <Date>
  192. ;;;
  193. ;;;  SOURCE is the name of the originating command (eg, BUG or 
  194. ;;;    MAIL) to be printed in the header of the message.
  195. ;;;
  196. ;;;  TEXT-LIST is a list of expressions making up the message.
  197.  
  198. #+(OR LISPM ITS)
  199. (DEFUN MAX-MAIL (SOURCE TEXT-LIST)
  200.  (IOTA ((MAIL-FILE "DSK:.MAIL.;_MAXIM >" '(OUT ASCII DSK BLOCK)))
  201.    (LINEL MAIL-FILE 69.)
  202.    (MFORMAT MAIL-FILE
  203.       "FROM-PROGRAM:Macsyma
  204. HEADER-FORCE:NULL
  205. TO:(MACSYMA)
  206. SENT-BY:~A
  207. TEXT;-1
  208. From ~A via ~A command. ~A~%"
  209.       (STATUS UNAME) 
  210.       (STATUS USERID)
  211.       SOURCE
  212.       (TIME-AND-DATE))
  213.    (TEXT-OUT TEXT-LIST MAIL-FILE)
  214.    (RENAMEF MAIL-FILE "MAIL >"))
  215.  (MFORMAT NIL "~&;Sent to MACSYMA~%")
  216.  '$DONE)
  217.  
  218. ;;; This code is new and untested. Please report bugs -kmp
  219. ;#+TOPS-20 
  220. ;(DEFUN MAX-MAIL (SOURCE TEXT-LIST)
  221. ;  (IOTA ((MAIL-FILE "MAIL:/[--NETWORK-MAIL--/]..-1"
  222. ;            '(OUT ASCII DSK BLOCK NODEFAULT)))
  223. ;    (MFORMAT MAIL-FILE
  224. ;         "/ MIT-MC
  225. ;BUG-MACSYMA
  226. ;/ From ~A at ~A via ~A command. ~A~%"
  227. ;      (STATUS USERID) (STATUS SITE) SOURCE (TIME-AND-DATE))
  228. ;    (TEXT-OUT TEXT-LIST MAIL-FILE)
  229. ;    (MFORMAT NIL "~%;Sent to MACSYMA")))
  230.  
  231. #+Multics
  232. (defun max-mail (source text-list)
  233.   (let ((address (cond ((eq source 'mail)
  234.             (setq source "Multics-Macsyma-Consultant -at MIT-MC"))
  235.                (t (setq source "Multics-Macsyma-Bugs -at MIT-MC")))))
  236.     (mail address text-list)))
  237.  
  238. ); END of (or ITS Multics TOPS-20) conditionalization.
  239.  
  240.  
  241. ;; On ITS, this returns a list of user ids for some random reason.  On other
  242. ;; systems, just print who's logged in.  We pray that nobody uses this list for
  243. ;; value.
  244.  
  245. #+ITS
  246. (PROGN 'COMPILE
  247. (DEFMFUN $who nil
  248.   (do ((tty*)
  249.        (wholist nil (cond ((eq (getchar tty* 1)  ;just consoles, not device
  250.                    'D)
  251.                wholist)
  252.               (t (LET ((UNAME (READUNAME)))
  253.                    (COND ((MEMQ UNAME WHOLIST) WHOLIST)
  254.                      (T (CONS UNAME WHOLIST)))))))
  255.        (ur (crunit))
  256.        (tty-file ((lambda (tty-file)
  257.             (readline tty-file)       ;blank line
  258.             tty-file)  ;get rid of cruft
  259.           (open '((tty) |.file.| |(dir)|) 'single))))
  260.       ((progn (readline tty-file)
  261.           (setq tty* (read tty-file))
  262.           (eq tty* 'free))
  263.        (close tty-file)
  264.        (apply 'crunit ur)
  265.        (cons '(mlist simp) wholist))))
  266.  
  267. ;;; $SEND
  268. ;;;  With no args, gives info about itself.
  269. ;;;  With one arg, sends the info to any logged in Macsyma users.
  270. ;;;  With 2 or more args, assumes that arg1 is a recipient and
  271. ;;;   args 2 on are a list of expressions to make up the message.
  272.  
  273. (DEFMSPEC $SEND (X) (SETQ X (CDR X)) 
  274.        (COND ((NULL X)
  275.           (MDESCRIBE '$SEND))
  276.          ((= (LENGTH X) 1.)
  277.           (MAX-SEND X))
  278.          (T
  279.           (MSEND (STRIPDOLLAR (CAR X)) (CDR X) T)))
  280.        '$DONE)
  281.  
  282. ;;; MSEND
  283. ;;;  Sends mail to a recipient, TO, by opening the CLI: device on the
  284. ;;;  recipient's HACTRN.
  285. ;;;
  286. ;;;  TO must be a name (already FULLSTRIP'd) to whom the mail should
  287. ;;;    be delivered. A header is printed of the form:
  288. ;;;    [MESSAGE FROM MACSYMA USER <Uname>  <time/date>] (To: <Recipient>)
  289. ;;;
  290. ;;;  TEXT-LIST is a list of Macsyma strings and/or general expressions
  291. ;;;    which will compose the message.
  292. ;;;
  293. ;;;  MAIL? is a flag that says whether the text should be forwarded
  294. ;;;    as mail to the recipient if the send fails. Since the only current
  295. ;;;    use for this is when sending to all of Mathlab, a value of NIL
  296. ;;;    for this flag assumes a <Recipient> in the header should be
  297. ;;;    "Mathlab Members" rather than the real name of the recipient.
  298. ;;;    An additional flag might be used to separate these functions
  299. ;;;    at some later time, but this should suffice for now.
  300.  
  301. (DEFUN MSEND (TO TEXT-LIST MAIL?)
  302.   (COND ((EQ TO (STATUS UNAME))
  303.      (MERROR "You cannot SEND to yourself.  Use MAIL.")
  304.      ())
  305.     ((ERRSET (IOTA ((STREAM (LIST '(CLI *) TO 'HACTRN) 'OUT))
  306.             (MFORMAT STREAM
  307.                "[Message from MACSYMA User ~A] (To: ~A) ~A~%"
  308.                (STATUS UNAME)
  309.                (COND (MAIL? TO)
  310.                  (T "Mathlab Members"))
  311.                (DAYTIME))
  312.             (TEXT-OUT TEXT-LIST STREAM))
  313.          NIL)
  314.      (MFORMAT NIL "~&;Sent to ~A~%" TO)
  315.      T)
  316.     (MAIL? (COND ((PROBE-FILE (LIST '(USR *) TO 'HACTRN))
  317.               (MFORMAT NIL "~&;~A isn't accepting message.~%" TO))
  318.              (T (MFORMAT NIL "~&;~A isn't logged in.~%" TO)))
  319.            (MAIL TO TEXT-LIST)
  320.            (MFORMAT NIL "~&;Message MAIL'd.~%")
  321.            () )
  322.     (T ())))
  323.  
  324. ;;; MAX-SEND
  325. ;;;  Send TEXT-LIST to any Mathlab members logged in.
  326. ;;;  If no one on the list is logged in, or if the only logged in
  327. ;;;  members are long idle, this command will forward the message
  328. ;;;  to MACSYMA mail automatically (notifying the user).
  329. ;;; 
  330. ;;;  TEXT-LIST is a list of expressions or strings making up the
  331. ;;;    message.
  332.  
  333.  
  334. (DEFUN MAX-SEND (TEXT-LIST)                ;
  335.   (LET ((SUCCESS NIL)
  336.     (PEOPLE (zl-DELETE (STATUS UNAME) (CDR ($WHO)))))
  337.        (DO ((PERSON))
  338.        ((NULL PEOPLE))
  339.      (SETQ PERSON (PROG1 (CAR PEOPLE)
  340.                  (SETQ PEOPLE (CDR PEOPLE))))
  341.      (COND ((MEMQ PERSON MATHLAB-GROUP-MEMBERS)
  342.         (LET ((RESULT (MSEND PERSON TEXT-LIST NIL)))
  343.              (SETQ SUCCESS
  344.                (OR SUCCESS
  345.                    (AND (< (IDLE-TIME PERSON) 9000.)
  346.                     RESULT
  347.                     T)))
  348.              (COND ((AND RESULT (> (IDLE-TIME PERSON) 9000.))
  349.                 (MFORMAT NIL
  350.                      " (but he//she is idle a long time)")))
  351.              (COND (RESULT (TERPRI)))))))
  352.        (COND ((NOT SUCCESS)
  353.           (MFORMAT NIL "There's no one around to help, so I have mailed
  354. your message to MACSYMA. Someone will get back
  355. to you about the problem.")
  356.           (MAX-MAIL 'SEND TEXT-LIST)))
  357.         '$DONE))
  358.  
  359. (DEFUN READUNAME NIL 
  360.        (TYI TTY-FILE)
  361.        (DO ((I 1. (f1+ I)) (L) (N))
  362.        ((> I 6.) (IMPLODE (NREVERSE L)))
  363.        (SETQ N (TYI TTY-FILE))
  364.        (OR (= N 32.) (SETQ L (CONS N L)))))
  365.  
  366. ;;; IDLE-TIME
  367. ;;;  Given an arg of UNAME (already FULLSTRIP'd) returns the idle-time
  368. ;;;  of that user.
  369.  
  370. (defMACRO 6BIT (&rest X) (CAR (PNGET (CAR X) 6.)))
  371.  
  372. (DEFUN IDLE-TIME (UNAME)
  373.   (IOTA ((USR-FILE (LIST '(USR *) UNAME 'HACTRN)))
  374.     (LET ((TTY-NUMBER (SYSCALL 1 'USRVAR USR-FILE (6BIT CNSL))))
  375.       (CLOSE USR-FILE)
  376.       (COND ((ATOM TTY-NUMBER)
  377.          (MFORMAT NIL "USRVAR BUG in SEND. Please report this.
  378. Mention MAXIMA-ERROR code: ~A~%Thank you." TTY-NUMBER)
  379.          100000.)
  380.         (T
  381.          (LET ((IDLE-TIME (SYSCALL 1 'TTYVAR
  382.                        (f+ (CAR TTY-NUMBER) #O 400000)
  383.                        (6BIT IDLTIM))))
  384.           (COND ((ATOM IDLE-TIME)
  385.              (MFORMAT NIL
  386.                "TTYVAR bug in SEND.  Please report this.
  387. Mention MAXIMA-ERROR code:  ~A~%Thank you." IDLE-TIME)
  388.              100000.)
  389.             (T (CAR IDLE-TIME)))))))))
  390.  
  391. ) ;End of PROGN 'Compile for WHO on ITS.
  392.  
  393. #+Multics
  394. (DEFMFUN $WHO ()
  395.   (CLINE "who -long")
  396.   '$DONE)
  397.  
  398. ;Turn sends into MAIL on foreign hosts.
  399. #+(or Multics TOPS-20 LISPM)
  400. (progn 'compile
  401. #+Multics
  402. (defmacro check-sendee-and-strip (sendee)
  403.   `(cond ((eq (getcharn ,sendee 1) #\&)
  404.       (stripdollar ,sendee))
  405.      (t (merror "Send: 1st argument to SEND must be a string"))))
  406. #-Multics
  407. (defmacro check-sendee-and-strip (sendee)
  408.   `(stripdollar ,sendee))
  409.      
  410. (DEFMSPEC $SEND (X) (SETQ X (CDR X)) 
  411.  
  412.         (COND ((NULL X)
  413.            (MDESCRIBE '$SEND))
  414. ;;;O.K. we gotta get the documentation to agree with what we're doin' here.
  415.           ((= (LENGTH X) 1.)
  416.            (MAX-MAIL 'SEND X))
  417.           (T (LET ((NAME (check-sendee-and-strip (CAR X))))
  418.                (MAIL NAME (CDR X))
  419.           #-Multics(MFORMAT NIL "~&;MAIL'd to ~A~%" NAME))))
  420.         '$DONE)
  421. )
  422.  
  423.  
  424. (declare-top (SPLITFILE ISOLAT)
  425.      (SPECIAL *XVAR $EXPTISOLATE $LABELS $DISPFLAG ERRORSW)
  426.      (FIXNUM (GETLABCHARN))) 
  427.  
  428. (DEFMVAR $EXPTISOLATE NIL)
  429. (DEFMVAR $ISOLATE_WRT_TIMES NIL)
  430.  
  431. (DEFMFUN $ISOLATE (E *XVAR) (SETQ *XVAR (GETOPR *XVAR)) (ISO1 E)) 
  432.  
  433. (DEFUN ISO1 (E) 
  434.  (COND ((SPECREPP E) (ISO1 (SPECDISREP E)))
  435.        ((AND (FREE E 'MPLUS) (OR (NULL $ISOLATE_WRT_TIMES) (FREE E 'MTIMES))) E)
  436.        ((FREEOF *XVAR E) (MGEN2 E))
  437.        ((ALIKE1 *XVAR E) *XVAR)
  438.        ((MEMQ (CAAR E) '(MPLUS MTIMES)) (ISO2 E))
  439.        ((EQ (CAAR E) 'MEXPT)
  440.     (COND ((NULL (ATOM (CADR E))) (LIST (CAR E) (ISO1 (CADR E)) (CADDR E)))
  441.           ((OR (ALIKE1 (CADR E) *XVAR) (NOT $EXPTISOLATE)) E)
  442.           (T (LET ((X ($RAT (CADDR E) *XVAR)) (U 0) (H 0))
  443.               (SETQ U (RATDISREP ($RATNUMER X)) X (RATDISREP ($RATDENOM X)))
  444.               (IF (NOT (EQUAL X 1))
  445.               (SETQ U ($MULTTHRU (LIST '(MEXPT) X -1) U)))
  446.               (IF (MPLUSP U)
  447.               (SETQ U ($PARTITION U *XVAR) H (CADR U) U (CADDR U)))
  448.               (SETQ U (POWER* (CADR E) (ISO1 U)))
  449.               (COND ((NOT (EQUAL H 0))
  450.                  (MUL2* (MGEN2 (POWER* (CADR E) H)) U))
  451.                 (T U))))))
  452.          (T (CONS (CAR E) (MAPCAR #'ISO1 (CDR E))))))
  453.  
  454. (DEFUN ISO2 (E) 
  455.        (PROG (HASIT DOESNT OP) 
  456.          (SETQ OP (NCONS (CAAR E)))
  457.          (DO ((I (CDR E) (CDR I))) ((NULL I))
  458.          (COND ((FREEOF *XVAR (CAR I)) (SETQ DOESNT (CONS (CAR I) DOESNT)))
  459.                (T (SETQ HASIT (CONS (ISO1 (CAR I)) HASIT)))))
  460.          (COND ((NULL DOESNT) (GO RET))
  461.            ((AND (NULL (CDR DOESNT)) (ATOM (CAR DOESNT))) (GO RET))
  462.            ((PROG2 (SETQ DOESNT (SIMPLIFY (CONS OP DOESNT)))
  463.                (AND (FREE DOESNT 'MPLUS)
  464.                 (OR (NULL $ISOLATE_WRT_TIMES)
  465.                     (FREE DOESNT 'MTIMES)))))
  466.            (T (SETQ DOESNT (MGEN2 DOESNT))))
  467.          (SETQ DOESNT (NCONS DOESNT))
  468.     RET  (RETURN (SIMPLIFYA (CONS OP (NCONC HASIT DOESNT)) NIL)))) 
  469.  
  470. (DEFUN MGEN2 (H)
  471.  (COND ((MEMSIMILARL H (CDR $LABELS) (GETLABCHARN $LINECHAR)))
  472.        (T (SETQ H (DISPLINE H)) (AND $DISPFLAG (MTERPRI)) H))) 
  473.  
  474. (DEFUN MEMSIMILARL (ITEM LIST LINECHAR) 
  475.        (COND ((NULL LIST) NIL)
  476.          ((AND (char= (GETLABCHARN (CAR LIST)) LINECHAR)
  477.            (BOUNDP (CAR LIST))
  478.            (MEMSIMILAR ITEM (CAR LIST) (SYMBOL-VALUE (CAR LIST)))))
  479.          (T (MEMSIMILARL ITEM (CDR LIST) LINECHAR)))) 
  480.  
  481. (DEFUN MEMSIMILAR (ITEM1 ITEM2 ITEM2EV) 
  482.  (COND ((EQUAL ITEM2EV 0) NIL)
  483.        ((ALIKE1 ITEM1 ITEM2EV) ITEM2)
  484.        (T (LET ((ERRORSW T) R)
  485.            (SETQ R (CATCH 'ERRORSW (DIV ITEM2EV ITEM1)))
  486.            (AND (MNUMP R) (NOT (ZEROP R)) (DIV ITEM2 R))))))
  487.  
  488. (DEFMFUN $PICKAPART (X LEV)
  489.  (SETQ X (FORMAT1 X))
  490.  (COND ((NOT (FIXNUMP LEV))
  491.     (MERROR "Improper 2nd argument to PICKAPART:~%~M" LEV))
  492.        ((OR (ATOM X) (AND (EQ (CAAR X) 'MMINUS) (ATOM (CADR X)))) X)
  493.        ((= LEV 0) (MGEN2 X))
  494.        ((AND (ATOM (CDR X)) (CDR X)) X)
  495.        (T (CONS (CAR X) (MAPCAR #'(LAMBDA (Y) ($PICKAPART Y (f1- LEV))) (CDR X)))))) 
  496.  
  497. (DEFMFUN $REVEAL (E LEV) 
  498.  (SETQ E (FORMAT1 E))
  499.  (COND ((AND (EQ (ml-typep LEV) 'fixnum) (> LEV 0)) (REVEAL E 1 LEV))
  500.        (T (MERROR "Second argument to REVEAL must be positive integer."))))
  501.  
  502. (DEFUN SIMPLE (X) (OR (ATOM X) (MEMQ (CAAR X) '(RAT BIGFLOAT)))) 
  503.  
  504. (DEFUN REVEAL (E NN LEV) 
  505.  (COND ((SIMPLE E) E)
  506.        ((= NN LEV)
  507.     (COND ((EQ (CAAR E) 'MPLUS) (CONS '(|&Sum| SIMP) (NCONS (LENGTH (CDR E)))))
  508.           ((EQ (CAAR E) 'MTIMES) (CONS '(|&Product| SIMP) (NCONS (LENGTH (CDR E)))))
  509.           ((EQ (CAAR E) 'MEXPT) '|&Expt|)
  510.           ((EQ (CAAR E) 'MQUOTIENT) '|&Quotient|)
  511.           ((EQ (CAAR E) 'MMINUS) '|&Negterm|)
  512.           (T (GETOP (MOP E)))))
  513.        (T (LET ((U (COND ((MEMQ 'SIMP (CDAR E)) (CAR E))
  514.              (T (CONS (CAAR E) (CONS 'SIMP (CDAR E))))))
  515.         (V (MAPCAR #'(LAMBDA (X) (REVEAL (FORMAT1 X) (f1+ NN) LEV))
  516.                (MARGS E))))
  517.            (COND ((EQ (CAAR E) 'MQAPPLY) (CONS U (CONS (CADR E) V)))
  518.              ((EQ (CAAR E) 'MPLUS) (CONS U (NREVERSE V)))
  519.              (T (CONS U V)))))))
  520.  
  521. (declare-top (SPLITFILE PROPFN)
  522.      (SPECIAL ATVARS MUNBOUND $PROPS $GRADEFS $FEATURES OPERS
  523.           $CONTEXTS $ACTIVECONTEXTS $ALIASES)) 
  524.  
  525. (DEFMSPEC $PROPERTIES (X)
  526.   (NONSYMCHK (SETQ X (GETOPR (FEXPRCHECK X))) '$PROPERTIES)
  527.   (LET ((U (PROPERTIES X)) (V (OR (GET X 'NOUN) (GET X 'VERB))))
  528.        (IF V (NCONC U (CDR (PROPERTIES V))) U)))
  529.  
  530. (DEFUN PROPERTIES (X)
  531.   (DO ((Y (SYMBOL-PLIST X) (CDDR Y))
  532.        (L (CONS '(MLIST SIMP) (AND (BOUNDP X)
  533.                    (IF (OPTIONP X) (NCONS '|&System Value|)
  534.                            (NCONS '$VALUE)))))
  535.        (PROP))
  536.       ((NULL Y)
  537.        
  538.        (IF (MEMQ X (CDR $FEATURES)) (NCONC L (NCONS '$FEATURE)))
  539.        (IF (MEMQ X (CDR $CONTEXTS)) (NCONC L (NCONS '$CONTEXT)))
  540.        (IF (MEMQ X (CDR $ACTIVECONTEXTS))
  541.        (NCONC L (NCONS '$ACTIVECONTEXT)))
  542.        (COND  ((NULL (SYMBOL-PLIST X))
  543.            (IF (FBOUNDP X) (NCONC L (LIST '|&System Function|)))))
  544.         L)
  545.       ;; TOP-LEVEL PROPERTIES 
  546.       (COND ((SETQ PROP (ASSQ (CAR Y)
  547.                   '((BINDTEST . $BINDTEST)
  548.                 (SP2 . $DEFTAYLOR) (SP2SUBS . $DEFTAYLOR)
  549.                 (ASSIGN . |&Assign Property|)
  550.                 (NONARRAY . $NONARRAY) (GRAD . $GRADEF)
  551.                 (NOUN . $NOUN) (EVFUN . $EVFUN) (SPECIAL . $SPECIAL)
  552.                 (EVFLAG . $EVFLAG) (OP . $OPERATOR) (ALPHABET . $ALPHABETIC))))
  553.          (NCONC L (NCONS (CDR PROP))))
  554.         ((SETQ PROP (MEMQ (CAR Y) OPERS)) (NCONC L (LIST (CAR PROP))))
  555.         ((AND (EQ (CAR Y) 'OPERATORS) (NOT (EQ (CADR Y) 'SIMPARGS1)))
  556.      (NCONC L (LIST '$RULE)))
  557.      ((AND (MEMQ (CAR Y) '(FEXPR FSUBR MFEXPR*S MFEXPR*))
  558.          (NCONC L (NCONS '|&Special Evaluation Form|))
  559.          NIL))
  560.      ((AND #-cl(MEMQ (CAR Y) '(SUBR FSUBR LSUBR EXPR FEXPR MACRO
  561.                     TRANSLATED-MMACRO SPECSIMP MFEXPR*S))
  562.            #+cl 
  563.            (or (get (car y) 'mfexpr*) (fboundp x))
  564.            (NOT (MEMQ '|&System Function| L)))
  565.       (NCONC L
  566.          (LIST (COND ((GET X 'TRANSLATED) '$TRANSFUN)
  567.                  ((MGETL X '($RULE RULEOF)) '$RULE)
  568.                  (T '|&System Function|)))))
  569.      ((AND (EQ (CAR Y) 'AUTOLOAD) (NOT (MEMQ '|&System Function| L)))
  570.       (NCONC L (NCONS (IF (MEMQ X (CDR $PROPS))
  571.                   '|&User Autoload Function|
  572.                   '|&System Function|))))
  573.      ((AND (EQ (CAR Y) 'REVERSEALIAS) (MEMQ (CAR Y) (CDR $ALIASES)))
  574.       (NCONC L (NCONS '$ALIAS)))
  575.      ((EQ (CAR Y) 'DATA)
  576.       (NCONC L (CONS '|&Database Info| (CDR ($FACTS X)))))
  577.      ((EQ (CAR Y) 'MPROPS)
  578.      ;; PROPS PROPERTIES
  579.       (DO ((Y
  580.          (CDADR Y)
  581.          (CDDR Y)))
  582.          ((NULL Y))
  583.          (COND ((SETQ PROP (ASSQ (CAR Y)
  584.                      '((MEXPR . $FUNCTION)
  585.                      (MMACRO . $MACRO)
  586.                      (HASHAR . |&Hashed Array|)
  587.                      (AEXPR . |&Array Function|)
  588.                      (ATVALUES . $ATVALUE)
  589.                      ($ATOMGRAD . $ATOMGRAD)
  590.                      ($NUMER . $NUMER)
  591.                      (DEPENDS . $DEPENDENCY)
  592.                      ($CONSTANT . $CONSTANT)
  593.                      ($NONSCALAR . $NONSCALAR)
  594.                      ($SCALAR . $SCALAR)
  595.                      (MATCHDECLARE . $MATCHDECLARE)
  596.                      (MODE . $MODEDECLARE))))
  597.             (NCONC L (LIST (CDR PROP))))
  598.          ((EQ (CAR Y) 'array)
  599.             (NCONC L
  600.              (LIST (COND ((GET X 'array) '|&Complete Array|)
  601.                      (T '|&Declared Array|)))))
  602.          ((AND (EQ (CAR Y) '$PROPS) (CDADR Y))
  603.             (NCONC L
  604.              (DO ((Y (CDADR Y) (CDDR Y))
  605.                   (L (LIST '(MLIST) '|&User Properties|)))
  606.                  ((NULL Y) (LIST L))
  607.                  (NCONC L (LIST (CAR Y))))))))))))
  608.  
  609.  
  610. (DEFMSPEC $PROPVARS (X)
  611.   (SETQ X (FEXPRCHECK X))
  612.   (DO ((ITEML (CDR $PROPS) (CDR ITEML)) (PROPVARS (NCONS '(MLIST))))
  613.       ((NULL ITEML) PROPVARS)
  614.     (AND (AMONG X (MEVAL (LIST '($PROPERTIES) (CAR ITEML))))
  615.      (NCONC PROPVARS (NCONS (CAR ITEML))))))
  616.  
  617. (DEFMSPEC $PRINTPROPS (R) (SETQ R (CDR R))
  618.   (IF (NULL (CDR R)) (MERROR "PRINTPROPS takes two arguments."))
  619.   (LET ((S (CADR R)))
  620.     (SETQ R (CAR R))
  621.     (SETQ R (COND ((ATOM R)
  622.            (COND ((EQ R '$ALL)
  623.               (COND ((EQ S '$GRADEF) (MAPCAR 'CAAR (CDR $GRADEFS)))
  624.                 (T (CDR (MEVAL (LIST '($PROPVARS) S))))))
  625.              (T (NCONS R))))
  626.           (T (CDR R))))
  627.     (COND ((EQ S '$ATVALUE) (DISPATVALUES R))
  628.       ((EQ S '$ATOMGRAD) (DISPATOMGRADS R))
  629.       ((EQ S '$GRADEF) (DISPGRADEFS R))
  630.       ((EQ S '$MATCHDECLARE) (DISPMATCHDECLARES R))
  631.       (T (MERROR "UNKNOWN PROPERTY - PRINTPROPS:  ~:M" S)))))
  632.  
  633. (DEFUN DISPATVALUES (L) 
  634.        (DO ((L
  635.        L
  636.        (CDR L)))
  637.        ((NULL L))
  638.        (DO ((LL
  639.            (MGET (CAR L) 'ATVALUES)
  640.            (CDR LL)))
  641.            ((NULL LL))
  642.            (MTELL-OPEN
  643.         "~M~%"
  644.         (LIST '(MLABLE) NIL 
  645.               (LIST '(MEQUAL)
  646.                 (ATDECODE (CAR L) (CAAR LL) (CADAR LL))
  647.                 (CADDAR LL)))
  648.            )))
  649.        '$DONE)
  650.  
  651. (declare-top (FIXNUM N))
  652.  
  653. (DEFUN ATDECODE (FUN DL VL) 
  654.        (SETQ VL (copy-top-level VL))
  655.        (ATVARSCHK VL)
  656.        ((LAMBDA (EQS NVARL) (COND ((NOT (MEMQ NIL (MAPCAR #'(LAMBDA (X) (SIGNP E X)) DL)))
  657.                    (DO ((VL VL (CDR VL)) (VARL ATVARS (CDR VARL)))
  658.                        ((NULL VL))
  659.                        (AND (EQ (CAR VL) MUNBOUND) (RPLACA VL (CAR VARL))))
  660.                    (CONS (LIST FUN) VL))
  661.                   (T (SETQ FUN (CONS (LIST FUN)
  662.                              (DO ((N (LENGTH VL) (f1- N))
  663.                               (VARL ATVARS (CDR VARL))
  664.                               (L NIL (CONS (CAR VARL) L)))
  665.                              ((ZEROP N) (NREVERSE L)))))
  666.                      (DO ((VL VL (CDR VL)) (VARL ATVARS (CDR VARL)))
  667.                      ((NULL VL))
  668.                      (AND (NOT (EQ (CAR VL) MUNBOUND))
  669.                           (SETQ EQS (CONS (LIST '(MEQUAL) (CAR VARL) (CAR VL)) EQS))))
  670.                      (SETQ EQS (CONS '(MLIST) (NREVERSE EQS)))
  671.                      (DO ((VARL ATVARS (CDR VARL)) (DL DL (CDR DL)))
  672.                      ((NULL DL) (SETQ NVARL (NREVERSE NVARL)))
  673.                      (AND (NOT (ZEROP (CAR DL)))
  674.                           (SETQ NVARL (CONS (CAR DL) (CONS (CAR VARL) NVARL)))))
  675.                      (LIST '(%AT) (CONS '(%DERIVATIVE) (CONS FUN NVARL)) EQS))))
  676.     NIL NIL)) 
  677.  
  678. (DEFUN DISPATOMGRADS (L) 
  679.        (DO ((I
  680.        L
  681.        (CDR I)))
  682.        ((NULL I))
  683.        (DO ((J
  684.            (MGET (CAR I) '$ATOMGRAD)
  685.            (CDR J)))
  686.            ((NULL J))
  687.            (MTELL-OPEN "~M~%"
  688.                (LIST '(MLABLE)
  689.                  NIL
  690.                  (LIST '(MEQUAL)
  691.                        (LIST '(%DERIVATIVE)
  692.                          (CAR I) (CAAR J) 1.)
  693.                        (CDAR J))))
  694.            ))
  695.        '$DONE) 
  696.  
  697. (DEFUN DISPGRADEFS (L) 
  698.        (DO ((I
  699.        L
  700.        (CDR I)))
  701.        ((NULL I))
  702.        (SETQ L (GET (CAR I) 'GRAD))
  703.        (DO ((J (CAR L) (CDR J)) (K (CDR L) (CDR K)) (THING (CONS (NCONS (CAR I)) (CAR L))))
  704.            ((OR (NULL K) (NULL J)))
  705.          (MTELL-OPEN "~M~%"
  706.              (LIST '(MLABLE)
  707.                  NIL
  708.                  (LIST '(MEQUAL) (LIST '(%DERIVATIVE) THING (CAR J) 1.) (CAR K))))
  709.            ))
  710.        '$DONE) 
  711.  
  712. (DEFUN DISPMATCHDECLARES (L) 
  713.   (DO ((I L (CDR I)) (RET))
  714.       ((NULL I) (CONS '(MLIST) RET))
  715.       (SETQ L (CAR (MGET (CAR I) 'MATCHDECLARE)))
  716.       (SETQ RET (CONS (APPEND (COND ((ATOM L) (NCONS (NCONS L))) (T L))
  717.                   (NCONS (CAR I)))
  718.               RET))))
  719.  
  720.  
  721. (declare-top (SPLITFILE CHANGV)
  722.      (SPECIAL TRANS OVAR NVAR TFUN INVFUN $PROGRAMMODE NFUN
  723.           *ROOTS *FAILURES VARLIST GENVAR $RATFAC)
  724.      #-cl
  725.      (*LEXPR $LIMIT $SOLVE SOLVABLE)) 
  726.  
  727. (DEFMFUN $CHANGEVAR (EXPR TRANS NVAR OVAR) 
  728.   (LET (INVFUN NFUN $RATFAC)
  729.     (COND ((OR (ATOM EXPR) (EQ (CAAR EXPR) 'RAT) (EQ (CAAR EXPR) 'MRAT))  EXPR)
  730.       ((ATOM TRANS) (MERROR "2nd arg must not be atomic"))
  731.       ((NULL (ATOM NVAR)) (MERROR "3rd arg must be atomic"))
  732.       ((NULL (ATOM OVAR)) (MERROR "4th arg must be atomic")))
  733.     (SETQ TFUN (SOLVABLE (SETQ TRANS (MEQHK TRANS)) OVAR))
  734.     (CHANGEVAR EXPR)))
  735.  
  736. (DEFUN SOLVABLE (L VAR &OPTIONAL (ERRSWITCH NIL))
  737.  (LET (*ROOTS *FAILURES)
  738.    (SOLVE L VAR 1)
  739.    (COND (*ROOTS ($RHS (CAR *ROOTS)))
  740.      (ERRSWITCH
  741.       (MERROR "Unable to solve for ~M" VAR)
  742.       )
  743.      (T NIL))))
  744.  
  745. (DEFUN CHANGEVAR (EXPR)
  746.        (COND ((ATOM EXPR) EXPR)
  747.          ((OR (NOT (MEMQ (CAAR EXPR) '(%INTEGRATE %SUM %PRODUCT)))
  748.           (NOT (ALIKE1 (CADDR EXPR) OVAR)))
  749.           (RECUR-APPLY #'CHANGEVAR EXPR))
  750.          (T (LET ((DERIV (IF TFUN (SDIFF TFUN NVAR)
  751.                  (NEG (DIV (SDIFF TRANS NVAR) ;IMPLICIT DIFF.
  752.                        (SDIFF TRANS OVAR))))))
  753.           (COND ((AND (MEMQ (CAAR EXPR) '(%SUM %PRODUCT))
  754.                   (NOT (EQUAL DERIV 1)))
  755.              (MERROR "Illegal change in summation or product"))
  756.             ((SETQ NFUN ($RADCAN   ;NIL IF KERNSUBST FAILS
  757.                      (IF TFUN
  758.                      (MUL (MAXIMA-SUBSTITUTE TFUN OVAR (CADR EXPR))
  759.                           DERIV)
  760.                      (KERNSUBST ($RATSIMP (MUL (CADR EXPR)
  761.                                    DERIV))
  762.                             TRANS OVAR)))) 
  763.              (COND     ;; DEFINITE INTEGRAL,SUMMATION, OR PRODUCT
  764.               ((CDDDR EXPR)
  765.                (OR INVFUN (SETQ INVFUN (SOLVABLE TRANS NVAR T)))
  766.                (LIST (NCONS (CAAR EXPR))    ;THIS WAS CHANGED
  767.                  NFUN            ;FROM '(%INTEGRATE)
  768.                  NVAR
  769.                  ($LIMIT INVFUN OVAR (CADDDR EXPR) '$PLUS)
  770.                  ($LIMIT INVFUN
  771.                      OVAR
  772.                      (CAR (CDDDDR EXPR))
  773.                      '$MINUS)))
  774.               (T                ;INDEFINITE INTEGRAL
  775.                (LIST '(%INTEGRATE) NFUN NVAR))))
  776.             (T EXPR)))))) 
  777.  
  778. (DEFUN KERNSUBST (EXPR FORM OVAR)
  779.   (LET (VARLIST GENVAR NVARLIST)
  780.     (NEWVAR EXPR)
  781.     (SETQ NVARLIST (MAPCAR #'(LAMBDA (X) (IF (FREEOF OVAR X) X
  782.                          (SOLVABLE FORM X)))
  783.                VARLIST))
  784.     (IF (MEMQ NIL NVARLIST) NIL
  785.     (PROG2 (SETQ EXPR (RATREP* EXPR)
  786.              VARLIST NVARLIST)
  787.            (RDIS (CDR EXPR))))))
  788.       
  789.  
  790. (declare-top (SPLITFILE FACSUM) (SPECIAL $LISTCONSTVARS FACFUN)) 
  791.  
  792. (DEFMFUN $FACTORSUM (E) (FACTORSUM0 E '$FACTOR)) 
  793.  
  794. (DEFMFUN $GFACTORSUM (E) (FACTORSUM0 E '$GFACTOR)) 
  795.  
  796. (DEFUN FACTORSUM0 (E FACFUN) 
  797.        (COND ((MPLUSP (SETQ E (FUNCALL FACFUN E)))
  798.           (FACTORSUM1 (CDR E)))
  799.          (T (FACTORSUM2 E)))) 
  800.  
  801. (DEFUN FACTORSUM1 (E) 
  802.        (PROG (F LV LLV LEX CL LT C) 
  803.     LOOP (SETQ F (CAR E))
  804.          (SETQ LV (CDR ($SHOWRATVARS F)))
  805.          (COND ((NULL LV) (SETQ CL (CONS F CL)) (GO SKIP)))
  806.          (DO ((Q LLV (CDR Q)) (R LEX (CDR R)))
  807.          ((NULL Q))
  808.          (COND ((INTERSECT (CAR Q) LV)
  809.             (RPLACA Q (UNION* (CAR Q) LV))
  810.             (RPLACA R (CONS F (CAR R)))
  811.             (RETURN (SETQ LV NIL)))))
  812.          (OR LV (GO SKIP))
  813.          (SETQ LLV (CONS LV LLV) LEX (CONS (NCONS F) LEX))
  814.     SKIP (AND (SETQ E (CDR E)) (GO LOOP))
  815.          (OR CL (GO SKIP2))
  816.          (DO ((Q LLV (CDR Q)) (R LEX (CDR R)))
  817.          ((NULL Q))
  818.          (COND ((AND (NULL (CDAR Q)) (CDAR R))
  819.             (RPLACA R (NCONC CL (CAR R)))
  820.             (RETURN (SETQ CL NIL)))))
  821.     SKIP2(SETQ LLV NIL LV NIL)
  822.          (DO ((R 
  823.           LEX
  824.           (CDR R)))
  825.           ((NULL R))
  826.           (COND ((CDAR R)
  827.              (SETQ LLV
  828.                (CONS (FACTORSUM2 (FUNCALL FACFUN (CONS '(MPLUS)
  829.                                (CAR R))))
  830.                  LLV)))
  831.             ((OR (NOT (MTIMESP (SETQ F (CAAR R))))
  832.              (NOT (MNUMP (SETQ C (CADR F)))))
  833.              (SETQ LLV (CONS F LLV)))
  834.             (T (DO ((Q LT (CDR Q)) (S LV (CDR S)))
  835.                ((NULL Q))
  836.                (COND ((ALIKE1 (CAR S) C)
  837.                   (RPLACA Q (CONS (DCON F) (CAR Q)))
  838.                   (RETURN (SETQ F NIL)))))
  839.                (AND F
  840.                 (SETQ LV (CONS C LV) 
  841.                   LT (CONS (NCONS (DCON F)) LT))))))
  842.          (SETQ 
  843.           LEX
  844.           (MAPCAR #'(LAMBDA (S Q) 
  845.                    (SIMPTIMES (LIST '(MTIMES)
  846.                         S
  847.                         (COND ((CDR Q)
  848.                                (CONS '(MPLUS)
  849.                                  Q))
  850.                               (T (CAR Q))))
  851.                       1.
  852.                       NIL))
  853.               LV
  854.               LT))
  855.          (RETURN (SIMPLUS (CONS '(MPLUS)
  856.                     (NCONC CL LEX LLV))
  857.                   1.
  858.                   NIL)))) 
  859.  
  860. (DEFUN DCON (MT) 
  861.        (COND ((CDDDR MT) (CONS (CAR MT) (CDDR MT))) (T (CADDR MT)))) 
  862.  
  863. (DEFUN FACTORSUM2 (E) 
  864.        (COND ((NOT (MTIMESP E)) E)
  865.          (T (CONS '(MTIMES)
  866.               (MAPCAR #'(LAMBDA (F) 
  867.                        (COND ((MPLUSP F)
  868.                           (FACTORSUM1 (CDR F)))
  869.                          (T F)))
  870.                   (CDR E)))))) 
  871.  
  872. (declare-top (SPLITFILE COMBF) (SPECIAL $COMBINEFLAG))
  873. (defmvar $combineflag t)
  874.  
  875. (DEFMFUN $COMBINE (E) 
  876.  (COND ((OR (ATOM E) (EQ (CAAR E) 'RAT)) E)
  877.        ((EQ (CAAR E) 'MPLUS) (COMBINE (CDR E)))
  878.        (T (RECUR-APPLY #'$COMBINE E)))) 
  879.  
  880. (DEFUN COMBINE (E) 
  881.        (PROG (TERM R LD SW NNU D LN XL) 
  882.     AGAIN(SETQ TERM (CAR E) E (CDR E))
  883.          (WHEN (OR (NOT (OR (RATNUMP TERM) (MTIMESP TERM) (MEXPTP TERM)))
  884.                (EQUAL (SETQ D ($DENOM TERM)) 1))
  885.            (SETQ R (CONS TERM R))
  886.            (GO END))
  887.          (SETQ NNU ($NUM TERM))
  888.          (AND $COMBINEFLAG (INTEGERP D) (SETQ XL (CONS TERM XL)) (GO END))
  889.          (DO ((Q LD (CDR Q)) (P LN (CDR P)))
  890.          ((NULL Q))
  891.          (COND ((ALIKE1 (CAR Q) D)
  892.             (RPLACA P (CONS NNU (CAR P)))
  893.             (RETURN (SETQ SW T)))))
  894.          (AND SW (GO SKIP))
  895.          (SETQ LD (CONS D LD) LN (CONS (NCONS NNU) LN))
  896.     SKIP (SETQ SW NIL)
  897.     END  (AND E (GO AGAIN))
  898.          (AND XL (SETQ XL (COND ((CDR XL) ($XTHRU (ADDN XL T)))
  899.                     (T (CAR XL)))))
  900.          (MAPC 
  901.           #'(LAMBDA (NU DE) 
  902.                 (SETQ R (CONS (MUL2 (ADDN NU NIL) (POWER* DE -1)) R)))
  903.           LN LD)
  904.          (RETURN (ADDN (IF XL (CONS XL R) R) NIL))))
  905.  
  906. (declare-top (SPLITFILE FACOUT) (FIXNUM NUM))
  907.  
  908. (DEFMFUN $FACTOROUT NUM
  909.   (PROG (E VL EL FL CL L F X)
  910.     (SETQ E (ARG 1) VL (LISTIFY (f- 1 NUM)))
  911.     (AND (NULL VL)(MERROR "FACTOROUT called on only one argument"))
  912.     (AND (NOT (MPLUSP E)) (RETURN E))
  913.     (OR (NULL VL) (MPLUSP E) (RETURN E))
  914.     (SETQ E (CDR E))
  915. LOOP    (SETQ F (CAR E) E (CDR E))
  916.     (AND (NOT (MTIMESP F))(SETQ F (LIST '(MTIMES) 1 F)))
  917.     (SETQ FL NIL CL NIL)
  918.     (DO ((I (CDR F) (CDR I))) ((NULL I))
  919.       (COND ((AND (NOT (NUMBERP (CAR I)))
  920.               (APPLY '$FREEOF (APPEND VL (NCONS (CAR I)))))
  921.          (SETQ FL (CONS (CAR I) FL)))
  922.             (T (SETQ CL (CONS (CAR I) CL)))))
  923.     (AND (NULL FL) (SETQ EL (CONS F EL)) (GO END))
  924.     (SETQ FL (COND ((CDR FL) (SIMPTIMES (CONS '(MTIMES) FL) 1 NIL))
  925.             (T (CAR FL))))
  926.     (SETQ CL (COND ((NULL CL) 1)
  927.                ((CDR CL) (SIMPTIMES (CONS '(MTIMES) CL) 1 T))
  928.                (T (CAR CL))))
  929.     (SETQ X T) (DO ((I L (CDR I)))((NULL I))
  930.     (COND ((ALIKE1 (CAAR I) FL) (RPLACD (CAR I) (CONS CL (CDAR I))) (SETQ I NIL X NIL))))
  931.        (AND X (SETQ L (CONS (LIST FL CL) L)))
  932. END    (AND E (GO LOOP))
  933.     (DO ((I L (CDR I))) ((NULL I))
  934.         (SETQ EL (CONS (SIMPTIMES (LIST '(MTIMES) (CAAR I)
  935.                  ($FACTORSUM (SIMPLUS (CONS '(MPLUS) (CDAR I)) 1 NIL))) 1 NIL) EL)))
  936.     (RETURN (ADDN EL NIL))))
  937.  
  938. (declare-top (SPLITFILE SCREEN))
  939. ;; This splitfile contains primitives for manipulating the screen from MACSYMA
  940. ;; This stuff should just be stuck in STATUS.
  941.  
  942. ;; $PAUSE(); does default --PAUSE--
  943. ;; $PAUSE("--FOO--") uses --FOO-- instead of --PAUSE
  944. ;; $PAUSE("--FOO--","--BAR--") is like above, but uses --BAR-- instead of
  945. ;;                   --CONTINUED--
  946.  
  947.  
  948. (declare-top (SPECIAL MOREMSG MORECONTINUE))
  949.  
  950. (DEFMFUN $PAUSE (&OPTIONAL (MORE-MSG MOREMSG) (MORE-CONTINUE MORECONTINUE))
  951.    (LET ((MOREMSG (STRIPDOLLAR MORE-MSG))
  952.      (MORECONTINUE (STRIPDOLLAR MORE-CONTINUE)))
  953.      (MORE-FUN NIL)
  954.      '$DONE))
  955.  
  956. ;; $CLEARSCREEN clears the screen.  It takes no arguments.
  957.  
  958. (DEFMFUN $CLEARSCREEN () (CURSORPOS 'C) '$DONE)
  959.