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 / emacs / emaxima.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  24.4 KB  |  783 lines
  1. ;;; This was stolen from imaxima, by Jesper Harder
  2. ;;; http://purl.org/harder/imaxima.tar.gz
  3.  
  4. (in-package "MAXIMA")
  5.  
  6. (DEFUN MAIN-PROMPT ()
  7.   (FORMAT () "(~A~D) "
  8.     (STRIPDOLLAR $INCHAR) $LINENUM))
  9.  
  10. ;(DEFUN BREAK-PROMPT ()
  11. ;  (declare (special $prompt))
  12. ;  (format nil "~A" (STRIPDOLLAR $PROMPT)))
  13.  
  14. (DEFMFUN DISPLA (FORM &aux #+kcl(form form))
  15.   (IF (OR (NOT #.TTYOFF) #.WRITEFILEP)
  16.       (cond #+Franz ($typeset (apply #'$photot (list form)))
  17.             ((eq $display2d '$emaxima) (latex form))
  18.         ($DISPLAY2D
  19.          (LET ((DISPLAYP T)
  20.            (LINEARRAY (IF DISPLAYP (MAKE-array 80.) LINEARRAY))
  21.            (MRATP (CHECKRAT FORM))
  22.            (#.WRITEFILEP #.WRITEFILEP)
  23.            (MAXHT     1) (MAXDP   0) (WIDTH   0)
  24.            (HEIGHT    0) (DEPTH   0) (LEVEL   0) (SIZE   2)
  25.            (BREAK     0) (RIGHT   0) (LINES   1) BKPT
  26.            (BKPTWD    0) (BKPTHT  1) (BKPTDP  0) (BKPTOUT 0)
  27.            (BKPTLEVEL 0) IN-P
  28.            (MOREFLUSH D-MOREFLUSH)
  29.            MORE-^W
  30.            (MOREMSG D-MOREMSG))
  31.            (UNWIND-PROTECT
  32.         (PROGN (SETQ FORM (DIMENSION FORM
  33.                          NIL 'MPAREN 'MPAREN 0 0))
  34.                (CHECKBREAK FORM WIDTH)
  35.                (OUTPUT FORM (IF (AND (NOT $LEFTJUST) (= 2 LINES))
  36.                     (f- LINEL (f- WIDTH BKPTOUT))
  37.                     0))
  38.                (IF (AND SMART-TTY (NOT (AND SCROLLP (NOT $CURSORDISP)))
  39.                 (> (CAR (CURSORPOS)) (f- TTYHEIGHT 3)))
  40.                (LET (#.writefilep) (MTERPRI))))
  41.          ;; make sure the linearray gets cleared out.
  42.          (CLEAR-LINEARRAY))))
  43.         (T (LINEAR-DISPLA FORM)))))
  44.  
  45. (defun break-dbm-loop (at)
  46.   (let* (
  47.      (*quit-tags* (cons (cons *break-level* *quit-tag*) *quit-tags*))
  48.      (*break-level* (if (not at) *break-level* (cons t *break-level*)))
  49.      (*quit-tag* (cons nil nil))
  50.      (*break-env* *break-env*)
  51.      (*mread-prompt* "")
  52.      (*diff-bindlist* nil)
  53.      (*diff-mspeclist* nil)
  54.      val
  55.      )
  56.     (declare (special *mread-prompt* ))
  57.     (and (consp at) (set-env at))
  58.     (cond ((null at)
  59.        ($frame 0 nil)))
  60.     (catch 'step-continue
  61.       (catch *quit-tag*
  62.     (unwind-protect
  63.         (do () (())
  64.         (format *debug-io*
  65.             "~&~@[(~a:~a) ~]"  (unless (stringp at) "dbm")
  66.             (length *quit-tags*))
  67.         (setq val
  68.               (catch 'macsyma-quit
  69.             (let ((res (dbm-read *debug-io*  nil *top-eof* t)))
  70.               (declare (special *mread-prompt*))
  71.               (cond ((and (consp res) (keywordp (car res)))
  72.                  (let ((value (break-call (car res)
  73.                               (cdr res) 'break-command)))
  74.                    (cond ((eq value :resume) (return)))
  75.                    ))
  76.                 (t
  77.                  (setq $__ (nth 2 res))
  78.                  (setq $% (meval* $__))
  79.                  (SETQ $_ $__)
  80.                  (displa $%)
  81.                  ))
  82.               nil
  83.               )))
  84.         (and (eql val 'top)
  85.              (throw-macsyma-top))
  86.               )
  87.      (restore-bindings)
  88.     )))))
  89.  
  90. (setq $display2d 'true)
  91.  
  92. ;; TeX-printing
  93. ;; (c) copyright 1987, Richard J. Fateman
  94. ;; Small changes for interfacing with TeXmacs: Andrey Grozin, 2001
  95. ;; Yet more small changes for interfacing with imaxima: Jesper Harder 2001
  96.  
  97. (declare-top
  98.      (special lop rop ccol $gcprint $inchar)
  99.      (*expr tex-lbp tex-rbp))
  100. (defconstant texport t)
  101.  
  102. ;;; myprinc is an intelligent low level printing routine.  it keeps track of 
  103. ;;; the size of the output for purposes of allowing the TeX file to
  104. ;;; have a reasonable line-line. myprinc will break it at a space 
  105. ;;; once it crosses a threshold.
  106. ;;; this has nothign to do with breaking the resulting equations.
  107.  
  108. ;-      arg:    chstr -  string or number to princ
  109. ;-      scheme: This function keeps track of the current location
  110. ;-              on the line of the cursor and makes sure
  111. ;-              that a value is all printed on one line (and not divided
  112. ;-              by the crazy top level os routines)
  113.  
  114. (defun myprinc (chstr)
  115.        (prog (chlst) 
  116.               (cond ((greaterp (plus (length (setq chlst (exploden chstr)))
  117.                                  ccol)
  118.                            70.)
  119.                   (terpri texport)      ;would have exceeded the line length
  120.                       (setq ccol 1.)
  121.               (myprinc " ")   ; lead off with a space for safety
  122.                       )) ;so we split it up.
  123.              (do ((ch chlst (cdr ch))
  124.                   (colc ccol (add1 colc)))
  125.                  ((null ch) (setq ccol colc))
  126.                  (tyo (car ch) texport))))
  127.  
  128. (defun myterpri nil
  129.   (cond (texport (terpri texport))
  130.     (t (mterpri)))
  131.     (setq ccol 1))
  132.  
  133. (defun tex (x l r lop rop)
  134.     ;; x is the expression of interest; l is the list of strings to its
  135.     ;; left, r to its right. lop and rop are the operators on the left
  136.     ;; and right of x in the tree, and will determine if parens must
  137.     ;; be inserted
  138.     (setq x (nformat x))
  139.     (cond ((atom x) (tex-atom x l r))
  140.           ((or (<= (tex-lbp (caar x)) (tex-rbp lop)) (> (tex-lbp rop) (tex-rbp (caar x))))
  141.            (tex-paren x l r))
  142.           ;; special check needed because macsyma notates arrays peculiarly
  143.           ((memq 'array (cdar x)) (tex-array x l r))
  144.           ;; dispatch for object-oriented tex-ifiying
  145.           ((get (caar x) 'tex) (funcall (get (caar x) 'tex) x l r))
  146.           (t (tex-function x l r nil))))
  147.  
  148. (defun tex-atom (x l r) ;; atoms: note: can we lose by leaving out {}s ?
  149.   (append l 
  150.       (list (cond ((numberp x) (texnumformat x))
  151.               ((and (symbolp x) (get x 'texword)))
  152.                       ((stringp x) (texstring x))
  153.                       ((characterp x) (texchar x))
  154.               (t (tex-stripdollar x))))
  155.       
  156.       r))
  157.  
  158. (defun texstring (x)
  159.   (cond ((equal x "") "")
  160.     ((eql (elt x 0) #\\) x)
  161. ;;     (t (concatenate 'string "\\mbox{{}" x "{}}")))) ;; jah: 
  162.     (t (concatenate 'string "\\verb| " x " |"))))
  163.  
  164. (defun texchar (x)
  165.   (if (eql x #\|) "\\verb/|/"
  166.     (concatenate 'string "\\verb|" (string x) "|"))) ;; jah: \mbox{\verb} is illegal
  167.  
  168. (defun myquote (str)
  169.   (let ((var "") (charlist
  170.           '((#\{ . "\\left\\{\\right.")
  171.             (#\} . "\\left\\}\\right.")
  172.             (#\# . "\\#")
  173.             (#\$ . "\\$")
  174.             (#\% . "\\%")
  175.             (#\& . "\\&")
  176.             (#\_ . "\\_"))))
  177.     (dotimes (i (length str))
  178.       (let ((chari (elt str i)))
  179.     (setq var (concatenate 'string var 
  180.                    (or (cdr (assoc chari charlist))
  181.                    (string chari))))))
  182.   var))
  183.  
  184. (defun tex-stripdollar (sym)
  185.   (or (symbolp sym) (return-from tex-stripdollar sym))
  186.   (let* ((name (symbol-name sym))
  187.       (pname (if (memq (elt name 0) '(#\$ #\&)) (subseq name 1) name))
  188.       (l (length pname)))
  189.     (cond
  190.      ((eql l 1) (myquote pname))
  191.      (t (concatenate 'string "\\mathrm{" (myquote pname) "}")))))
  192.  
  193. (defun texnumformat(atom)  ;; 10/14/87 RJF  convert 1.2e20 to 1.2 \cdot 10^{20}
  194.   (let(r firstpart exponent)
  195.        (cond ((integerp atom)atom)
  196.          (t (setq r (explode atom))
  197.         (setq exponent (memq 'e r)) ;; is it ddd.ddde+EE
  198.         (cond ((null exponent) atom); it is not. go with it as given
  199.               (t (setq firstpart (nreverse (cdr (memq 'e (reverse r)))))
  200.              (strcat (apply #'strcat firstpart )
  201.                      "\\cdot 10^{"
  202.                      (apply #'strcat (cdr exponent))
  203.                      "}")))))))
  204.  
  205. (defun tex-paren (x l r) 
  206.   (tex x (append l '("\\left(")) (cons "\\right)" r) 'mparen 'mparen))
  207.  
  208. (defun tex-array (x l r)
  209.   (let ((f))
  210.        (if (eq 'mqapply (caar x))
  211.        (setq f (cadr x) 
  212.          x (cdr x))
  213.        (setq f (caar x)))
  214.        (setq l (tex (texword f) l nil lop 'mfunction)
  215.          
  216.          r (nconc (tex-list (cdr x) nil (list "}") ",") r)) 
  217.        (nconc l (list "_{") r  )))
  218.  
  219. ;; we could patch this so sin x rather than sin(x), but instead we made sin a prefix
  220. ;; operator
  221.  
  222. (defun tex-function (x l r op) op
  223.     (setq l (tex (texword (caar x)) l nil 'mparen 'mparen)
  224.           r (tex (cons '(mprogn) (cdr x)) nil r 'mparen 'mparen))
  225.     (nconc l r))
  226.  
  227. ;; set up a list , separated by symbols (, * ...)  and then tack on the
  228. ;; ending item (e.g. "]" or perhaps ")"
  229.  
  230. (defun tex-list (x l r sym)
  231.   (if (null x) r
  232.       (do ((nl))
  233.       ((null (cdr x))
  234.        (setq nl (nconc nl (tex (car x)  l r 'mparen 'mparen)))
  235.        nl)
  236. ;      (setq nl (nconc nl (tex (car x)  l (list sym) 'mparen 'mparen))
  237.       (setq nl (nconc nl (tex (car x)  l (list (concat sym "\\linebreak[0]")) 'mparen 'mparen))
  238.           x (cdr x) 
  239.           l nil))))
  240.  
  241. (defun tex-prefix (x l r)
  242.   (tex (cadr x) (append l (texsym (caar x))) r (caar x) rop))
  243.  
  244. (defun tex-infix (x l r)
  245.   ;; check for 2 args
  246.   (if (or (null (cddr x)) (cdddr x)) (wna-err (caar x)))
  247.   (setq l (tex (cadr x) l nil lop (caar x)))
  248.   (tex (caddr x) (append l (texsym (caar x))) r (caar x) rop))
  249.   
  250. (defun tex-postfix (x l r)
  251.   (tex (cadr x) l (append (texsym (caar x)) r) lop (caar x)))
  252.  
  253. (defun tex-nary (x l r)
  254.   (let* ((op (caar x)) (sym (texsym op)) (y (cdr x)) (ext-lop lop) (ext-rop rop))
  255.     (cond ((null y)       (tex-function x l r t)) ; this should not happen
  256.           ((null (cdr y)) (tex-function x l r t)) ; this should not happen, too
  257.           (t (do ((nl) (lop ext-lop op) (rop op (if (null (cdr y)) ext-rop op)))
  258.                  ((null (cdr y)) (setq nl (nconc nl (tex (car y)  l r lop rop))) nl)
  259.              (setq nl (nconc nl (tex (car y)  l (list sym)   lop rop))
  260.                y (cdr y) 
  261.                l nil))))))
  262.  
  263. (defun tex-nofix (x l r) (tex (caar x) l r (caar x) rop))
  264.  
  265. (defun tex-matchfix (x l r)
  266.   (setq l (append l (car (texsym (caar x))))
  267.     ;; car of texsym of a matchfix operator is the lead op
  268.     r (append (cdr (texsym (caar x))) r) 
  269.     ;; cdr is the trailing op
  270.     x (tex-list (cdr x) nil r ","))
  271.   (append l x))
  272.  
  273. (defun texsym (x) (or (get x 'texsym) (get x 'strsym)(get x 'dissym)
  274.               (stripdollar x)))
  275.  
  276. (defun texword (x)(or (get x 'texword) (stripdollar x)))
  277.  
  278. (defprop bigfloat tex-bigfloat tex)
  279.  
  280. (defun tex-bigfloat (x l r) (fpformat x))
  281.  
  282. (defprop mprog "\\mathbf{block}\\;" texword)
  283. (defprop %erf "\\mathrm{erf}" texword)
  284. (defprop $erf "\\mathrm{erf}" texword) ;; etc for multicharacter names
  285. (defprop $true  "\\mathbf{true}"  texword)
  286. (defprop $false "\\mathbf{false}" texword)
  287.  
  288. (defprop mprogn tex-matchfix tex) ;; mprogn is (<progstmnt>, ...)
  289. (defprop mprogn (("\\left(") "\\right)") texsym)
  290.  
  291. (defprop mlist tex-matchfix tex)
  292. (defprop mlist (("\\left[ ")" \\right] ") texsym)
  293.  
  294. ;;absolute value
  295. (defprop mabs tex-matchfix tex)
  296. (defprop mabs (("\\left| ")"\\right| ") texsym)
  297.  
  298. (defprop mqapply tex-mqapply tex)
  299.  
  300. (defun tex-mqapply (x l r)
  301.   (setq l (tex (cadr x) l (list "(" ) lop 'mfunction)
  302.     r (tex-list (cddr x) nil (cons ")" r) ","))
  303.   (append l r));; fixed 9/24/87 RJF
  304.  
  305. (defprop $%i "i" texword)
  306. (defprop $%pi "\\pi" texword)
  307. (defprop $%e "e" texword)
  308. (defprop $inf "\\infty " texword)
  309. (defprop $minf " -\\infty " texword)
  310. (defprop %laplace "\\mathcal{L}" texword) ;; jah
  311. (defprop $alpha "\\alpha" texword)
  312. (defprop $beta "\\beta" texword)
  313. (defprop $gamma "\\gamma" texword)
  314. (defprop %gamma "\\Gamma" texword)
  315. (defprop $%gamma "\\gamma" texword)
  316. (defprop $delta "\\delta" texword)
  317. (defprop $epsilon "\\varepsilon" texword)
  318. (defprop $zeta "\\zeta" texword)
  319. (defprop $eta "\\eta" texword)
  320. (defprop $theta "\\vartheta" texword)
  321. (defprop $iota "\\iota" texword)
  322. (defprop $kappa "\\varkappa" texword)
  323. ;(defprop $lambda "\\lambda" texword)
  324. (defprop $mu "\\mu" texword)
  325. (defprop $nu "\\nu" texword)
  326. (defprop $xi "\\xi" texword)
  327. (defprop $pi "\\pi" texword)
  328. (defprop $rho "\\rho" texword)
  329. (defprop $sigma "\\sigma" texword)
  330. (defprop $tau "\\tau" texword)
  331. (defprop $upsilon "\\upsilon" texword)
  332. (defprop $phi "\\varphi" texword)
  333. (defprop $chi "\\chi" texword)
  334. (defprop $psi "\\psi" texword)
  335. (defprop $omega "\\omega" texword)
  336.  
  337. (defprop mquote tex-prefix tex)
  338. (defprop mquote ("'") texsym)
  339. (defprop mquote 201. tex-rbp)
  340.  
  341. (defprop msetq tex-infix tex)
  342. (defprop msetq (":") texsym)
  343. (defprop msetq 180. tex-rbp)
  344. (defprop msetq 20. tex-rbp)
  345.  
  346. (defprop mset tex-infix tex)
  347. (defprop mset ("::") texsym)
  348. (defprop mset 180. tex-lbp)
  349. (defprop mset 20. tex-rbp)
  350.  
  351. (defprop mdefine tex-infix tex)
  352. (defprop mdefine (":=") texsym)
  353. (defprop mdefine 180. tex-lbp)
  354. (defprop mdefine 20. tex-rbp)
  355.  
  356. (defprop mdefmacro tex-infix tex)
  357. (defprop mdefmacro ("::=") texsym)
  358. (defprop mdefmacro 180. tex-lbp)
  359. (defprop mdefmacro 20. tex-rbp)
  360.  
  361. (defprop marrow tex-infix tex)
  362. (defprop marrow ("\\rightarrow ") texsym)
  363. (defprop marrow 25 tex-lbp)
  364. (defprop marrow 25 tex-rbp)
  365.  
  366. (defprop mfactorial tex-postfix tex)
  367. (defprop mfactorial ("!") texsym)
  368. (defprop mfactorial 160. tex-lbp)
  369.  
  370. (defprop mexpt tex-mexpt tex)
  371. (defprop mexpt 140. tex-lbp)
  372. (defprop mexpt 139. tex-rbp)
  373.  
  374. ;; insert left-angle-brackets for mncexpt. a^<n> is how a^^n looks.
  375. (defun tex-mexpt (x l r)
  376.   (let((nc (eq (caar x) 'mncexpt))); true if a^^b rather than a^b
  377.      ;; here is where we have to check for f(x)^b to be displayed
  378.      ;; as f^b(x), as is the case for sin(x)^2 .
  379.      ;; which should be sin^2 x rather than (sin x)^2 or (sin(x))^2. 
  380.      ;; yet we must not display (a+b)^2 as +^2(a,b)...
  381.      ;; or (sin(x))^(-1) as sin^(-1)x, which would be arcsine x
  382.      (cond ;; this whole clause
  383.        ;; should be deleted if this hack is unwanted and/or the
  384.        ;; time it takes is of concern.
  385.        ;; it shouldn't be too expensive.
  386.        ((and (eq (caar x) 'mexpt) ; don't do this hack for mncexpt
  387.          (let* 
  388.           ((fx (cadr x)); this is f(x)
  389.            (f (and (not (atom fx)) (atom (caar fx)) (caar fx))) ; this is f [or nil]
  390.            (bascdr (and f (cdr fx))) ; this is (x) [maybe (x,y..), or nil]
  391.            (expon (caddr x)) ;; this is the exponent
  392.            (doit (and 
  393.               f ; there is such a function
  394.               (memq (getchar f 1) '(% $)) ;; insist it is a % or $ function
  395.               (not (memq f '(%sum %lsum %product %derivative 
  396.                           %integrate %limit))) ;; what else? what a hack...
  397.               (or (and (atom expon) (not (numberp expon))) ; f(x)^y is ok
  398.                   (and (atom expon) (numberp expon) (> expon 0))))))
  399.                   ; f(x)^3 is ok, but not f(x)^-1, which could 
  400.                   ; inverse of f, if written f^-1 x
  401.                   ; what else? f(x)^(1/2) is sqrt(f(x)), ??
  402.           (cond (doit
  403.             (setq l (tex `((mexpt) ,f ,expon) l nil 'mparen 'mparen))
  404.             (setq r (tex
  405.                                  (if (and (null (cdr bascdr)) (eq (get f 'tex) 'tex-prefix))
  406.                                      (car bascdr) (cons '(mprogn) bascdr))
  407.                                  nil r f rop)))
  408.                 (t nil))))) ; won't doit. fall through
  409.       (t (setq l (tex (cadr x) l nil lop (caar x))
  410.            r (if (mmminusp (setq x (nformat (caddr x))))
  411.             ;; the change in base-line makes parens unnecessary
  412.             (if nc
  413.             (tex (cadr x) '("^ {-\\langle ")(cons "\\rangle }" r) 'mparen 'mparen)
  414.             (tex (cadr x) '("^ {- ")(cons " }" r) 'mparen 'mparen))
  415.             (if nc
  416.             (tex x (list "^{\\langle ")(cons "\\rangle}" r) 'mparen 'mparen)
  417.             (tex x (list "^{")(cons "}" r) 'mparen 'mparen))))))
  418.       (append l r)))
  419.  
  420. (defprop mncexpt tex-mexpt tex)
  421.  
  422. (defprop mncexpt 135. tex-lbp)
  423. (defprop mncexpt 134. tex-rbp)
  424.  
  425. (defprop mnctimes tex-nary tex)
  426. (defprop mnctimes "\\cdot " texsym)
  427. (defprop mnctimes 110. tex-lbp)
  428. (defprop mnctimes 109. tex-rbp)
  429.  
  430. (defprop mtimes tex-nary tex)
  431. (defprop mtimes "\\*" texsym)
  432. (defprop mtimes 120. tex-lbp)
  433. (defprop mtimes 120. tex-rbp)
  434.  
  435. (defprop %sqrt tex-sqrt tex)
  436.  
  437. (defun tex-sqrt(x l r)
  438.   ;; format as \\sqrt { } assuming implicit parens for sqr grouping
  439.   (tex (cadr x) (append l  '("\\sqrt{")) (append '("}") r) 'mparen 'mparen))
  440.  
  441. ;; macsyma doesn't know about cube (or nth) roots,
  442. ;; but if it did, this is what it would look like.
  443. (defprop $cubrt tex-cubrt tex)
  444.  
  445. (defun tex-cubrt (x l r)
  446.   (tex (cadr x) (append l  '("\\root 3 \\of{")) (append '("}") r) 'mparen 'mparen))
  447.  
  448. (defprop mquotient tex-mquotient tex)
  449. (defprop mquotient ("\\over") texsym)
  450. (defprop mquotient 122. tex-lbp) ;;dunno about this
  451. (defprop mquotient 123. tex-rbp) 
  452.  
  453. (defun tex-mquotient (x l r)
  454.   (if (or (null (cddr x)) (cdddr x)) (wna-err (caar x)))
  455.   (setq l (tex (cadr x) (append l '("{{")) nil 'mparen 'mparen)
  456.     ;the divide bar groups things
  457.     r (tex (caddr x) (list "}\\over{") (append '("}}")r) 'mparen 'mparen))
  458.   (append l r))
  459.  
  460. (defprop $matrix tex-matrix tex)
  461.  
  462. (defun tex-matrix(x l r) ;;matrix looks like ((mmatrix)((mlist) a b) ...)
  463.   (append l `("\\pmatrix{")
  464.      (mapcan #'(lambda(y)
  465.               (tex-list (cdr y) nil (list "\\cr ") "&")) 
  466.          (cdr x))
  467.      '("}") r))
  468.  
  469. ;; macsyma sum or prod is over integer range, not  low <= index <= high
  470. ;; TeX is lots more flexible .. but
  471.  
  472. (defprop %sum tex-sum tex)
  473. (defprop %lsum tex-lsum tex)
  474. (defprop %product tex-sum tex)
  475.  
  476. ;; easily extended to union, intersect, otherops
  477.  
  478. (defun tex-lsum(x l r)
  479.   (let ((op (cond ((eq (caar x) '%lsum) "\\sum_{")
  480.           ;; extend here
  481.           ))
  482.     ;; gotta be one of those above 
  483.     (s1 (tex (cadr x) nil nil 'mparen rop));; summand
  484.     (index ;; "index = lowerlimit"
  485.            (tex `((min simp) , (caddr x), (cadddr x))  nil nil 'mparen 'mparen)))
  486.        (append l `( ,op ,@index "}}{" ,@s1 "}") r)))
  487.  
  488. (defun tex-sum(x l r)
  489.   (let ((op (cond ((eq (caar x) '%sum) "\\sum_{")
  490.           ((eq (caar x) '%product) "\\prod_{")
  491.           ;; extend here
  492.           ))
  493.     ;; gotta be one of those above 
  494.     (s1 (tex (cadr x) nil nil 'mparen rop));; summand
  495.     (index ;; "index = lowerlimit"
  496.            (tex `((mequal simp) ,(caddr x),(cadddr x)) nil nil 'mparen 'mparen))
  497.     (toplim (tex (car(cddddr x)) nil nil 'mparen 'mparen)))
  498.        (append l `( ,op ,@index "}^{" ,@toplim "}{" ,@s1 "}") r)))
  499.  
  500. (defprop %integrate tex-int tex)
  501. (defun tex-int (x l r)
  502.   (let ((s1 (tex (cadr x) nil nil 'mparen 'mparen));;integrand delims / & d
  503.     (var (tex (caddr x) nil nil 'mparen rop))) ;; variable
  504.        (cond((= (length x) 3)
  505.          (append l `("\\int {" ,@s1 "}{\\;d" ,@var "}") r))
  506.         (t ;; presumably length 5
  507.            (let ((low (tex (nth 3 x) nil nil 'mparen 'mparen))
  508.              ;; 1st item is 0
  509.              (hi (tex (nth 4 x) nil nil 'mparen 'mparen)))
  510.             (append l `("\\int_{" ,@low "}^{" ,@hi "}{" ,@s1 "\\;d" ,@var "}") r))))))
  511.  
  512. (defprop %limit tex-limit tex)
  513.  
  514. (defun tex-limit(x l r) ;; ignoring direction, last optional arg to limit
  515.   (let ((s1 (tex (cadr x) nil nil 'mparen rop));; limitfunction
  516.     (subfun ;; the thing underneath "limit"
  517.      (subst "\\rightarrow " '=
  518.         (tex `((mequal simp) ,(caddr x),(cadddr x))
  519.              nil nil 'mparen 'mparen))))
  520.        (append l `("\\lim_{" ,@subfun "}{" ,@s1 "}") r)))
  521.  
  522. (defprop %at tex-at tex)
  523.  
  524. ;; e.g.  at(diff(f(x)),x=a)
  525. (defun tex-at (x l r)
  526.   (let ((s1 (tex (cadr x) nil nil lop rop))
  527.     (sub (tex (caddr x) nil nil 'mparen 'mparen)))
  528.        (append l '("\\left.") s1  '("\\right|_{") sub '("}") r)))
  529.  
  530. ;; (defprop mbox tex-mbox tex)
  531.  
  532. ;; (defun tex-mbox (x l r)
  533. ;;   (append l '("\\fbox{") (tex (cadr x) nil nil 'mparen 'mparen) '("}"))) ; jh
  534.  
  535. ;;binomial coefficients
  536.  
  537. (defprop %binomial tex-choose tex)
  538.        
  539. (defun tex-choose (x l r)
  540.   `(,@l 
  541.     "\\pmatrix{" 
  542.     ,@(tex (cadr x) nil nil 'mparen 'mparen)
  543.     "\\\\"
  544.     ,@(tex (caddr x) nil nil 'mparen 'mparen)
  545.     "}"
  546.     ,@r))
  547.  
  548.  
  549. (defprop rat tex-rat tex) 
  550. (defprop rat 120. tex-lbp)
  551. (defprop rat 121. tex-rbp)
  552. (defun tex-rat(x l r) (tex-mquotient x l r))
  553.  
  554. (defprop mplus tex-mplus tex)
  555. (defprop mplus 100. tex-lbp)
  556. (defprop mplus 100. tex-rbp)
  557.  
  558. (defun tex-mplus (x l r)
  559.  ;(declare (fixnum w))
  560.  (cond ((memq 'trunc (car x))(setq r (cons "+\\cdots " r))))
  561.  (cond ((null (cddr x))
  562.     (if (null (cdr x))
  563.         (tex-function x l r t)
  564.         (tex (cadr x) (cons "+" l) r 'mplus rop)))
  565.        (t (setq l (tex (cadr x) l nil lop 'mplus) 
  566.         x (cddr x))
  567.       (do ((nl l)  (dissym))
  568.           ((null (cdr x))
  569.            (if (mmminusp (car x)) (setq l (cadar x) dissym (list "-"))
  570.            (setq l (car x) dissym (list "+")))
  571.            (setq r (tex l dissym r 'mplus rop))
  572.            (append nl r))
  573.           (if (mmminusp (car x)) (setq l (cadar x) dissym (list "-"))
  574.           (setq l (car x) dissym (list "+")))
  575.           (setq nl (append nl (tex l dissym nil 'mplus 'mplus))
  576.             x (cdr x))))))
  577.  
  578. (defprop mminus tex-prefix tex)
  579. (defprop mminus ("-") texsym)
  580. (defprop mminus 100. tex-rbp)
  581. (defprop mminus 100. tex-lbp)
  582.  
  583. (defprop min tex-infix tex)
  584. (defprop min ("\\in{") texsym)
  585. (defprop min 80. tex-lbp)
  586. (defprop min 80. tex-rbp)
  587.  
  588. (defprop mequal tex-infix tex)
  589. (defprop mequal (=) texsym)
  590. (defprop mequal 80. tex-lbp)
  591. (defprop mequal 80. tex-rbp)
  592.  
  593. (defprop mnotequal tex-infix tex)
  594. (defprop mnotequal 80. tex-lbp)
  595. (defprop mnotequal 80. tex-rbp)
  596.  
  597. (defprop mgreaterp tex-infix tex)
  598. (defprop mgreaterp (>) texsym)
  599. (defprop mgreaterp 80. tex-lbp)
  600. (defprop mgreaterp 80. tex-rbp)
  601.  
  602. (defprop mgeqp tex-infix tex)
  603. (defprop mgeqp ("\\geq") texsym)
  604. (defprop mgeqp 80. tex-lbp)
  605. (defprop mgeqp 80. tex-rbp)
  606.  
  607. (defprop mlessp tex-infix tex)
  608. (defprop mlessp (<) texsym)
  609. (defprop mlessp 80. tex-lbp)
  610. (defprop mlessp 80. tex-rbp)
  611.  
  612. (defprop mleqp tex-infix tex)
  613. (defprop mleqp ("\\leq") texsym)
  614. (defprop mleqp 80. tex-lbp)
  615. (defprop mleqp 80. tex-rbp)
  616.  
  617. (defprop mnot tex-prefix tex)
  618. (defprop mnot ("\\not ") texsym)
  619. (defprop mnot 70. tex-rbp)
  620.  
  621. (defprop mand tex-nary tex)
  622. (defprop mand ("\\and") texsym)
  623. (defprop mand 60. tex-lbp)
  624. (defprop mand 60. tex-rbp)
  625.  
  626. (defprop mor tex-nary tex)
  627. (defprop mor ("\\or") texsym)
  628.  
  629. ;; make sin(x) display as sin x , but sin(x+y) as sin(x+y)
  630. ;; etc
  631.  
  632. (defun tex-setup (x)
  633.   (let((a (car x))
  634.        (b (cadr x)))
  635.       (setf (get a 'tex) 'tex-prefix)
  636.       (setf (get a 'texword) b)  ;This means "sin" will always be roman
  637.       (setf (get a 'texsym) (list b))
  638.       (setf (get a 'tex-rbp) 130)))
  639.  
  640. (mapc #'tex-setup 
  641.   '( (%sin "\\sin ")
  642.      (%cos "\\cos ")
  643.      (%tan "\\tan ")
  644.      (%cot "\\cot ")
  645.      (%sec "\\sec ")
  646.      (%csc "\\csc ")
  647.      (%asin "\\arcsin ")
  648.      (%acos "\\arccos ")
  649.      (%atan "\\arctan ")
  650.      (%sinh "\\sinh ")
  651.      (%cosh "\\cosh ")
  652.      (%tanh "\\tanh ")
  653.      (%coth "\\coth ")
  654.      (%sech "{\\rm sech}") ;; jah
  655.      (%ln "\\ln ")
  656.      (%log "\\log ")
  657.     ;; (%erf "{\\rm erf}") this would tend to set erf(x) as erf x. Unusual
  658.      ;(%laplace "{\\cal L}")
  659.      )) ;; etc
  660.  
  661. (defprop mor tex-nary tex)
  662. (defprop mor 50. tex-lbp)
  663. (defprop mor 50. tex-rbp)
  664.  
  665. (defprop mcond tex-mcond tex)
  666. (defprop mcond 25. tex-lbp)
  667. (defprop mcond 25. tex-rbp)
  668. (defprop %derivative tex-derivative tex)
  669. (defun tex-derivative (x l r)
  670.   (tex (tex-d x '$|d|) l r lop rop ))
  671.  
  672. (defun tex-d(x dsym) ;dsym should be $d or "$d\\partial"
  673.   ;; format the macsyma derivative form so it looks
  674.   ;; sort of like a quotient times the deriva-dand.
  675.   (let*
  676.    ((arg (cadr x)) ;; the function being differentiated
  677.     (difflist (cddr x)) ;; list of derivs e.g. (x 1 y 2)
  678.     (ords (odds difflist 0)) ;; e.g. (1 2)
  679.     (vars (odds difflist 1)) ;; e.g. (x y)
  680.     (numer `((mexpt) $|d| ((mplus) ,@ords))) ; d^n numerator
  681.     (denom (cons '(mtimes)
  682.          (mapcan #'(lambda(b e)
  683.                   `(,dsym ,(simplifya `((mexpt) ,b ,e) nil)))
  684.              vars ords))))
  685.    `((mtimes)
  686.      ((mquotient) ,(simplifya numer nil) ,denom)
  687.      ,arg)))
  688.  
  689. (defun odds(n c) 
  690.   ;; if c=1, get the odd terms  (first, third...)
  691.   (cond ((null n) nil) 
  692.     ((= c 1)(cons (car n)(odds (cdr n) 0)))
  693.     ((= c 0)(odds (cdr n) 1))))
  694.  
  695. (defun tex-mcond (x l r)
  696.   (append l
  697.     (tex (cadr x) '("\\mathbf{if}\\;")
  698.       '("\\;\\mathbf{then}\\;") 'mparen 'mparen)
  699.     (if (eql (fifth x) '$false)
  700.       (tex (caddr x) nil r 'mcond rop)
  701.       (append (tex (caddr x) nil nil 'mparen 'mparen)
  702.         (tex (fifth x) '("\\;\\mathbf{else}\\;") r 'mcond rop)))))
  703.  
  704. (defprop mdo tex-mdo tex)
  705. (defprop mdo 30. tex-lbp)
  706. (defprop mdo 30. tex-rbp)
  707. (defprop mdoin tex-mdoin tex)
  708. (defprop mdoin 30. tex-rbp)
  709.  
  710. (defun tex-lbp(x)(cond((get x 'tex-lbp))(t(lbp x))))
  711. (defun tex-rbp(x)(cond((get x 'tex-rbp))(t(lbp x))))
  712.  
  713. ;; these aren't quite right
  714.  
  715. (defun tex-mdo (x l r)
  716.   (tex-list (texmdo x) l r "\\;"))
  717.  
  718. (defun tex-mdoin (x l r)
  719.   (tex-list (texmdoin x) l r "\\;"))
  720.  
  721. (defun texmdo (x)
  722.    (nconc (cond ((second x) `("\\mathbf{for}" ,(second x))))
  723.      (cond ((equal 1 (third x)) nil)
  724.            ((third x)  `("\\mathbf{from}" ,(third x))))
  725.      (cond ((equal 1 (fourth x)) nil)
  726.            ((fourth x) `("\\mathbf{step}" ,(fourth x)))
  727.            ((fifth x)  `("\\mathbf{next}" ,(fifth x))))
  728.      (cond ((sixth x)  `("\\mathbf{thru}" ,(sixth x))))
  729.      (cond ((null (seventh x)) nil)
  730.            ((eq 'mnot (caar (seventh x)))
  731.         `("\\mathbf{while}" ,(cadr (seventh x))))
  732.            (t `("\\mathbf{unless}" ,(seventh x))))
  733.      `("\\mathbf{do}" ,(eighth x))))
  734.  
  735. (defun texmdoin (x)
  736.   (nconc `("\\mathbf{for}" ,(second x) $|in| ,(third x))
  737.      (cond ((sixth x) `("\\mathbf{thru}" ,(sixth x))))
  738.      (cond ((null (seventh x)) nil)
  739.            ((eq 'mnot (caar (seventh x)))
  740.         `("\\mathbf{while}" ,(cadr (seventh x))))
  741.            (t `("\\mathbf{unless}" ,(seventh x))))
  742.      `("\\mathbf{do}" ,(eighth x))))
  743.  
  744.  
  745. ;; Undone and trickier:
  746. ;; handle reserved symbols stuff, just in case someone
  747. ;; has a macsyma variable named (yuck!!) \over  or has a name with 
  748. ;; {} in it.
  749. ;; Maybe do some special hacking for standard notations for 
  750. ;; hypergeometric fns, alternative summation notations  0<=n<=inf, etc.
  751.  
  752. ;;Undone and really pretty hard: line breaking
  753.  
  754. (defprop mtext tex-mtext tex)
  755. (defprop text-string tex-mtext tex)
  756. (defprop mlable tex-mlable tex)
  757. (defprop spaceout tex-spaceout tex)
  758.  
  759. (defun tex-mtext (x l r) (tex-list (cdr x) l r ""))
  760.  
  761. (defun tex-mlable (x l r)
  762.   (tex (caddr x)
  763.     (append l
  764.       (if (cadr x)
  765.       (list (format nil "(~A) " (stripdollar (cadr x))))
  766.         nil))
  767.     r 'mparen 'mparen))
  768.  
  769. (defun tex-spaceout (x l r)
  770.   (append l (list "\\verb|" (make-string (cadr x) :initial-element #\space) "|") r))
  771.  
  772. ; jh: verb & mbox
  773.  
  774. (defun latex (x)
  775.   (let ((ccol 1))
  776.     (mapc #'myprinc
  777.       (if (and (listp x) (cdr x) (stringp (cadr x))
  778.            (equal (string-right-trim '(#\Space) (cadr x)) "Is"))
  779.           (tex x '("") '("") 'mparen 'mparen)
  780.         (tex x '("") '("
  781. ") 'mparen 'mparen)))
  782.     ))
  783.