1;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
2
3(in-package :maxima)
4
5;; TeX-printing
6;; (c) copyright 1987, Richard J. Fateman
7;; small corrections and additions: Andrey Grozin, 2001
8;; additional additions: Judah Milgram (JM), September 2001
9;; additional corrections: Barton Willis (BLW), October 2001
10
11;; Usage: tex(d8,"/tmp/foo.tex"); tex(d10,"/tmp/foo.tex"); ..
12;; to append lines d8 and d10 to the tex file.  If given only
13;; one argument the result goes to standard output.
14
15;; Extract from permission letter to wfs:
16;; Date: Sat, 2 Apr 88 18:06:16 PST
17;; From: fateman%vangogh.Berkeley.EDU@ucbvax.Berkeley.EDU (Richard Fateman)
18;; To: wfs@rascal.ics.UTEXAS.EDU
19;; Subject: about tex...
20;; You have my permission to put it in NESC or give it to anyone
21;; else who might be interested in it....
22
23;; source language:
24;; There are changes by wfs to allow use inside MAXIMA which runs
25;; in COMMON LISP.  For original FRANZ LISP version contact rfw.
26
27;; intended environment: vaxima (Vax or Sun). Parser should be
28;; equivalent (in lbp/rbp data) to 1986 NESC Vaxima.
29;;;(provide 'tex)
30;;;(in-package 'tex)
31;;;(export '($tex $texinit))
32;;;;; we'd like to just
33;;;(import '(user::$bothcases user::lbp user::rbp user::nformat))
34;;;(use-package 'user)
35
36;; March, 1987
37
38;; Method:
39
40;; Producing TeX from a macsyma internal expression is done by
41;; a reversal of the parsing process.  Fundamentally, a
42;; traversal of the expression tree is produced by the tex programs,
43;; with appropriate substitutions and recognition of the
44;; infix / prefix / postfix / matchfix relations on symbols. Various
45;; changes are made to this so that TeX will like the results.
46;; It is important to understand the binding powers of the operators
47;; in Macsyma, in mathematics, and in TeX so that parentheses will
48;; be inserted when necessary. Because TeX has different kinds of
49;; groupings (e.g. in superscripts, within sqrts), not all
50;; parentheses are explicitly need.
51
52;;  Instructions:
53;; in macsyma, type tex(<expression>);  or tex(<label>); or
54;; tex(<expr-or-label>, <file-name>);  In the case of a label,
55;; a left-equation-number will be produced.
56;; in case a file-name is supplied, the output will be sent
57;; (perhaps appended) to that file.
58
59(declare-top (special lop rop $labels $inchar))
60
61(defvar *tex-environment-default* '("$$" . "$$"))
62
63(defmfun $set_tex_environment_default (env-open env-close)
64  (setq env-open ($sconcat env-open))
65  (setq env-close ($sconcat env-close))
66  (setq *tex-environment-default* `(,env-open . ,env-close))
67  ($get_tex_environment_default))
68
69(defmfun $get_tex_environment_default ()
70  `((mlist) ,(car *tex-environment-default*) ,(cdr *tex-environment-default*)))
71
72(defmfun $set_tex_environment (x env-open env-close)
73  (setq env-open ($sconcat env-open))
74  (setq env-close ($sconcat env-close))
75  (if (getopr x) (setq x (getopr x)))
76  (setf (get x 'tex-environment) `(,env-open . ,env-close))
77  ($get_tex_environment x))
78
79(defmfun $get_tex_environment (x)
80  (if (getopr x) (setq x (getopr x)))
81  (let ((e (get-tex-environment x)))
82    `((mlist) ,(car e) ,(cdr e))))
83
84(defun get-tex-environment (x)
85  (cond
86    ((symbolp x)
87     (or (get x 'tex-environment) *tex-environment-default*))
88    ((atom x)
89     *tex-environment-default*)
90    (t
91      (get-tex-environment (caar x)))))
92
93(setf (get 'mdefine 'tex-environment)
94      `(,(format nil "~%\\begin{verbatim}~%") . ,(format nil ";~%\\end{verbatim}~%")))
95
96(setf (get 'mdefmacro 'tex-environment)
97      `(,(format nil "~%\\begin{verbatim}~%") . ,(format nil ";~%\\end{verbatim}~%")))
98
99(setf (get 'mlabel 'tex-environment)
100      `(,(format nil "~%\\begin{verbatim}~%") . ,(format nil ";~%\\end{verbatim}~%")))
101
102;; top level command the result of tex'ing the expression x.
103;; Lots of messing around here to get C-labels verbatim printed
104;; and function definitions verbatim "ground"
105
106(defmspec $tex(l) ;; mexplabel, and optional filename or stream
107  ;;if filename or stream supplied but 'nil' then return a string
108  (let ((args (cdr l)))
109    (unless (member (length args) '(1 2))
110      (wna-err '$tex))
111    (cond ((and (cdr args) (null (cadr args)))
112	   (let ((*standard-output* (make-string-output-stream)))
113	     (apply 'tex1  args)
114	     (get-output-stream-string *standard-output*)
115	     )
116	   )
117	  (t (apply 'tex1  args)))))
118
119(defun quote-chars (sym ch-str)
120  (let* ((strsym (string sym))
121         (pos (position-if #'(lambda (c) (find c ch-str)) strsym)))
122    (if pos
123      (concatenate 'string (subseq strsym 0 pos) "\\" (subseq strsym pos (1+ pos))
124                           (quote-chars (subseq strsym (1+ pos)) ch-str))
125      strsym)))
126
127(defun quote-% (sym)
128  (quote-chars sym "$%&_"))
129
130(defun tex1 (mexplabel &optional filename-or-stream) ;; mexplabel, and optional filename or stream
131  (prog (mexp  texport x y itsalabel need-to-close-texport)
132     (reset-ccol)
133     ;; collect the file-name, if any, and open a port if needed
134     (setq filename-or-stream (meval filename-or-stream))
135     (setq texport
136       (cond
137         ((null filename-or-stream) *standard-output*)
138         ((eq filename-or-stream t) *standard-output*)
139         ((streamp filename-or-stream) filename-or-stream)
140         (t
141           (setq need-to-close-texport t)
142           (open (namestring (maxima-string filename-or-stream))
143                 :direction :output
144                 :if-exists :append
145                 :if-does-not-exist :create))))
146     ;; go back and analyze the first arg more thoroughly now.
147     ;; do a normal evaluation of the expression in macsyma
148     (setq mexp (meval mexplabel))
149     (cond ((member mexplabel $labels :test #'eq)	; leave it if it is a label
150	    (setq mexplabel (concatenate 'string "(" (print-invert-case (stripdollar mexplabel))
151					 ")"))
152	    (setq itsalabel t))
153	   (t (setq mexplabel nil)))	;flush it otherwise
154
155     ;; maybe it is a function?
156     (cond((symbolp (setq x mexp)) ;;exclude strings, numbers
157	   (setq x ($verbify x))
158	   (cond ((setq y (mget x 'mexpr))
159		  (setq mexp (list '(mdefine) (cons (list x) (cdadr y)) (caddr y))))
160		 ((setq y (mget x 'mmacro))
161		  (setq mexp (list '(mdefmacro) (cons (list x) (cdadr y)) (caddr y))))
162		 ((setq y (mget x 'aexpr))
163		  (setq mexp (list '(mdefine) (cons (list x 'array) (cdadr y)) (caddr y)))))))
164     (cond ((and (null(atom mexp))
165		 (member (caar mexp) '(mdefine mdefmacro) :test #'eq))
166	    (format texport (car (get-tex-environment (caar mexp))))
167	    (cond (mexplabel (format texport "~a " mexplabel)))
168	    (mgrind mexp texport)	;write expression as string
169	    (format texport (cdr (get-tex-environment (caar mexp)))))
170	   ((and
171	     itsalabel ;; but is it a user-command-label?
172         ;; THE FOLLOWING TESTS SEEM PRETTY STRANGE --
173         ;; WHY CHECK INITIAL SUBSTRING IF SYMBOL IS ON THE $LABELS LIST ??
174         ;; PROBABLY IT IS A HOLDOVER FROM THE DAYS WHEN LABELS WERE C AND D INSTEAD OF %I AND %O
175	     (<= (length (string $inchar)) (length (string mexplabel)))
176	     (string= (subseq (maybe-invert-string-case (string $inchar)) 1 (length (string $inchar)))
177		      (subseq (string mexplabel) 1 (length (string $inchar))))
178	     ;; Check to make sure it isn't an outchar in disguise
179	     (not
180	      (and
181	       (<= (length (string $outchar)) (length (string mexplabel)))
182	       (string= (subseq (maybe-invert-string-case (string $outchar)) 1 (length (string $outchar)))
183			(subseq (string mexplabel) 1 (length (string $outchar)))))))
184	    ;; aha, this is a C-line: do the grinding:
185	    (format texport (car (get-tex-environment 'mlabel)))
186        (format texport "~a" mexplabel)
187	    (mgrind mexp texport)	;write expression as string
188	    (format texport (cdr (get-tex-environment 'mlabel))))
189	   (t
190	    (if mexplabel (setq mexplabel (quote-% mexplabel)))
191					; display the expression for TeX now:
192        (myprinc (car (get-tex-environment mexp)) texport)
193	    (mapc #'(lambda (x) (myprinc x texport))
194		  ;;initially the left and right contexts are
195		  ;; empty lists, and there are implicit parens
196		  ;; around the whole expression
197		  (tex mexp nil nil 'mparen 'mparen))
198	    (cond (mexplabel
199		   (format texport "\\leqno{\\tt ~a}" mexplabel)))
200	    (format texport (cdr (get-tex-environment mexp)))))
201     (terpri texport)
202     (if need-to-close-texport
203	    (close texport))
204     (return mexplabel)))
205
206;;; myprinc is an intelligent low level printing routine.  it keeps track of
207;;; the size of the output for purposes of allowing the TeX file to
208;;; have a reasonable line-line. myprinc will break it at a space
209;;; once it crosses a threshold.
210;;; this has nothign to do with breaking the resulting equations.
211
212;;-      arg:    chstr -  string or number to princ
213;;-      scheme: This function keeps track of the current location
214;;-              on the line of the cursor and makes sure
215;;-              that a value is all printed on one line (and not divided
216;;-              by the crazy top level os routines)
217
218(let ((ccol 1))
219  (defun reset-ccol () (setq ccol 1))
220
221  (defun myprinc (chstr &optional (texport nil))
222    (prog (chlst)
223       (cond ((and (> (+ (length (setq chlst (exploden chstr))) ccol) 70.)
224                   (or (stringp chstr) (equal chstr '| |)))
225	      (terpri texport)      ;would have exceeded the line length
226	      (setq ccol 1.)
227	      (myprinc " " texport))) ; lead off with a space for safetyso we split it up.
228       (do ((ch chlst (cdr ch))
229	    (colc ccol (1+ colc)))
230	   ((null ch) (setq ccol colc))
231         (write-char (car ch) texport)))))
232
233(defun tex (x l r lop rop)
234  ;; x is the expression of interest; l is the list of strings to its
235  ;; left, r to its right. lop and rop are the operators on the left
236  ;; and right of x in the tree, and will determine if parens must
237  ;; be inserted
238  (setq x (nformat x))
239  (cond ((atom x) (tex-atom x l r))
240	((or (<= (tex-lbp (caar x)) (tex-rbp lop)) (> (tex-lbp rop) (tex-rbp (caar x))))
241	 (tex-paren x l r))
242	;; special check needed because macsyma notates arrays peculiarly
243	((member 'array (cdar x) :test #'eq) (tex-array x l r))
244	;; dispatch for object-oriented tex-ifiying
245	((get (caar x) 'tex) (funcall (get (caar x) 'tex) x l r))
246	(t (tex-function x l r nil))))
247
248(defun tex-atom (x l r)	;; atoms: note: can we lose by leaving out {}s ?
249  (append l
250	  (list (cond ((numberp x) (texnumformat x))
251		      ((and (symbolp x) (or (get x 'texword) (get (get x 'reversealias) 'texword))))
252                      ((stringp x)
253                       (tex-string (quote-% (if $stringdisp (concatenate 'string "``" x "''") x))))
254                      ((characterp x) (tex-char x))
255		      ((not ($mapatom x))
256		       (let ((x (if (member (marray-type x) '(array hash-table $functional))
257				    ($sconcat x)
258				  (format nil "~A" x))))
259			 (tex-string (quote-chars (if $stringdisp (concatenate 'string "``" x "''") x)
260						  "#$%&_"))))
261
262		      (t (tex-stripdollar (or (get x 'reversealias) x)))))
263	  r))
264
265(defun tex-string (x)
266  (cond ((equal x "") "")
267	((eql (elt x 0) #\\) x)
268	(t (concatenate 'string "\\mbox{ " x " }"))))
269
270(defun tex-char (x)
271  (if (eql x #\|) "\\mbox{\\verb/|/}"
272      (concatenate 'string "\\mbox{\\verb|" (string x) "|}")))
273
274;; Read forms from file F1 and output them to F2
275(defun tex-forms (f1 f2 &aux tem (eof *mread-eof-obj*))
276  (with-open-file (st f1)
277    (loop while (not (eq (setq tem (mread-raw st eof)) eof))
278	   do (tex1 (third tem) f2))))
279
280;; Detect and extract groups of trailing digits, e.g. foo_mm_nn.
281;; and then punt foo[mm, nn] to TEX-ARRAY.
282;; Otherwise, treat SYM as a simple symbol.
283
284(defun tex-stripdollar (sym)
285  (let
286    ((nn-list (extract-trailing-digits (symbol-name sym))))
287    (if nn-list
288      ;; SYM matches foo_mm_nn.
289      (apply #'concatenate 'string (tex-array `((,(intern (first nn-list)) 'array) ,@(rest nn-list)) nil nil))
290      ;; SYM is a simple symbol.
291      (let ((s (maybe-invert-string-case (quote-% (stripdollar sym)))))
292        (if (> (length s) 1)
293          (concatenate 'string "{\\it " s "}")
294          s)))))
295
296;; Given a string foo_mm_nn, return foo, mm, and nn,
297;; where mm and nn are integers (not strings of digits).
298;; Return NIL if argument doesn't have trailing digits.
299
300(defun extract-trailing-digits (s)
301  (let (nn-list)
302    ;; OK (loop while (funcall #.(maxima-nregex::regex-compile "[^_](__*)([0-9][0-9]*)$") s)
303    ;; NOPE (loop while (funcall #.(maxima-nregex::regex-compile "[^0-9_](_*)([0-9][0-9]*)$") s)
304    (loop with nn-string while
305          (or (and
306                (funcall #.(maxima-nregex::regex-compile "[^_](__*)([0-9][0-9]*)$") s)
307                (let*
308                  ((group-_ (aref maxima-nregex::*regex-groups* 1))
309                   (group-nn (aref maxima-nregex::*regex-groups* 2)))
310                  (setq nn-string (subseq s (first group-nn) (second group-nn)))
311                  (setq s (subseq s 0 (first group-_)))))
312              (and
313                (funcall #.(maxima-nregex::regex-compile "[^_]([0-9][0-9]*)$") s)
314                (let* ((group-nn (aref maxima-nregex::*regex-groups* 1)))
315                  (setq nn-string (subseq s (first group-nn) (second group-nn)))
316                  (setq s (subseq s 0 (first group-nn))))))
317          do (push (parse-integer nn-string) nn-list))
318    (and nn-list (cons s nn-list))))
319
320(defun strcat (&rest args)
321  (apply #'concatenate 'string (mapcar #'string args)))
322
323;; 10/14/87 RJF  convert 1.2e20 to 1.2 \cdot 10^{20}
324;; 03/30/01 RLT  make that 1.2 \times 10^{20}
325(defun texnumformat(atom)
326  (let (r firstpart exponent)
327    (cond ((integerp atom)
328	   (coerce (exploden atom) 'string))
329	  (t
330	   (setq r (exploden atom))
331	   (setq exponent (member 'e r :test #'string-equal)) ;; is it ddd.ddde+EE
332	   (cond
333         ((null exponent)
334		  (coerce r 'string))
335		 (t
336		  (setq firstpart
337			(nreverse (cdr (member 'e (reverse r) :test #'string-equal))))
338		  (strcat (apply #'strcat firstpart )
339			  " \\times 10^{"
340			  (apply #'strcat (cdr exponent))
341			  "}")))))))
342
343(defun tex-paren (x l r)
344  (tex x (append l '("\\left(")) (cons "\\right)" r) 'mparen 'mparen))
345
346(defun tex-array (x l r)
347  (let ((f))
348    (if (eq 'mqapply (caar x))
349	(setq f (cadr x)
350	      x (cdr x)
351	      l (tex f (append l (list "\\left(")) (list "\\right)") 'mparen 'mparen))
352	(setq f (caar x)
353	      l (tex f l nil lop 'mfunction)))
354    (setq
355     r (nconc (tex-list (cdr x) nil (list "}") ",") r))
356    (nconc l (list "_{") r  )))
357
358;; we could patch this so sin x rather than sin(x), but instead we made sin a prefix
359;; operator
360
361(defun tex-function (x l r op) op
362       (setq l (tex (caar x) l nil 'mparen 'mparen)
363	     r (tex (cons '(mprogn) (cdr x)) nil r 'mparen 'mparen))
364       (nconc l r))
365
366;; set up a list , separated by symbols (, * ...)  and then tack on the
367;; ending item (e.g. "]" or perhaps ")"
368
369(defun tex-list (x l r sym)
370  (if (null x) r
371      (do ((nl))
372	  ((null (cdr x))
373	   (setq nl (nconc nl (tex (car x)  l r 'mparen 'mparen)))
374	   nl)
375	(setq nl (nconc nl (tex (car x)  l (list sym) 'mparen 'mparen))
376	      x (cdr x)
377	      l nil))))
378
379(defun tex-prefix (x l r)
380  (tex (cadr x) (append l (texsym (caar x))) r (caar x) rop))
381
382(defun tex-infix (x l r)
383  (twoargcheck x)
384  (setq l (tex (cadr x) l nil lop (caar x)))
385  (tex (caddr x) (append l (texsym (caar x))) r (caar x) rop))
386
387(defun tex-postfix (x l r)
388  (tex (cadr x) l (append (texsym (caar x)) r) lop (caar x)))
389
390(defun tex-nary (x l r)
391  (let* ((op (caar x)) (sym (texsym op)) (y (cdr x)) (ext-lop lop) (ext-rop rop))
392    (cond ((null y)       (tex-function x l r t)) ; this should not happen
393          ((null (cdr y)) (tex-function x l r t)) ; this should not happen, too
394          (t (do ((nl) (lop ext-lop op) (rop op (if (null (cdr y)) ext-rop op)))
395                 ((null (cdr y)) (setq nl (append nl (tex (car y)  l r lop rop))) nl)
396	       (setq nl (append nl (tex (car y) l sym lop rop))
397		     y (cdr y)
398		     l nil))))))
399
400(defun tex-nofix (x l r) (tex (car (texsym (caar x))) l r (caar x) rop))
401
402(defun tex-matchfix (x l r)
403  (setq l (append l (car (texsym (caar x))))
404    ;; car of texsym of a matchfix operator is the lead op
405    r (append (list (nth 1 (texsym (caar x)))) r)
406    ;; cdr is the trailing op
407    x (tex-list (cdr x) nil r (or (nth 2 (texsym (caar x))) " , ")))
408  (append l x))
409
410(defun texsym (x)
411  (or (get x 'texsym) (get x 'strsym)
412      (get x 'dissym)
413      (stripdollar x)))
414
415(defun texword (x)
416  (or (get x 'texword)
417      (stripdollar x)))
418
419(defprop bigfloat tex-bigfloat tex)
420
421; For 1.2345b678, generate TeX output 1.2345_B \times 10^{678} .
422; If the exponent is 0, then ... \times 10^{0} is generated
423; (no attempt to strip off zero exponent).
424
425(defun tex-bigfloat (x l r)
426  (let ((formatted (fpformat x)))
427    ; There should always be a '|b| or '|B| in the FPFORMAT output.
428    ; Play it safe -- check anyway.
429    (if (or (find '|b| formatted) (find '|B| formatted))
430      (let*
431        ((spell-out-expt
432           (append
433             (apply #'append
434                    (mapcar
435                     #'(lambda (e) (if (or (eq e '|b|) (eq e '|B|))
436                                       '("_B" | | "\\times" | | "10^{")
437                                       (list e)))
438                      formatted))
439             '(|}|))))
440        (append l spell-out-expt r))
441      (append l formatted r))))
442
443(defprop mprog "\\mathbf{block}\\;" texword)
444(defprop %erf "\\mathrm{erf}" texword)
445(defprop $erf "\\mathrm{erf}" texword) ;; etc for multicharacter names
446(defprop $true  "\\mathbf{true}"  texword)
447(defprop $false "\\mathbf{false}" texword)
448(defprop $done "\\mathbf{done}" texword)
449
450(defprop mprogn tex-matchfix tex) ;; mprogn is (<progstmnt>, ...)
451(defprop mprogn (("\\left(") "\\right)") texsym)
452
453(defprop mlist tex-matchfix tex)
454(defprop mlist (("\\left[ ")" \\right] ") texsym)
455(setf (get '%mlist 'tex) (get 'mlist 'tex))
456(setf (get '%mlist 'texsym) (get 'mlist 'texsym))
457
458;;absolute value
459(defprop mabs tex-matchfix tex)
460(defprop mabs (("\\left| ")"\\right| ") texsym)
461
462(defprop mqapply tex-mqapply tex)
463
464(defun tex-mqapply (x l r)
465  (setq l (tex (cadr x) l (list "(" ) lop 'mfunction)
466	r (tex-list (cddr x) nil (cons ")" r) ","))
467  (append l r))	;; fixed 9/24/87 RJF
468
469(defprop $%i "i" texword)
470(defprop $%e "e" texword)
471(defprop $inf "\\infty " texword)
472(defprop $minf " -\\infty " texword)
473(defprop %laplace "\\mathcal{L}" texword)
474
475(defprop $alpha "\\alpha" texword)
476(defprop $beta "\\beta" texword)
477(defprop $gamma "\\gamma" texword)
478(defprop %gamma "\\gamma" texword)
479
480(defprop %gamma tex-gamma tex)
481(defun tex-gamma (x l r)
482 (tex (cadr x) (append l '("\\Gamma\\left(")) (append '("\\right)") r) 'mparen 'mparen))
483
484(defprop $%gamma "\\gamma" texword)
485(defprop %gamma_incomplete "\\Gamma" texword)
486(defprop %gamma_incomplete_regularized "Q" texword)
487(defprop %gamma_incomplete_generalized "\\Gamma" texword)
488(defprop $gamma_incomplete_lower "\\gamma" texword)
489(defprop $delta "\\delta" texword)
490(defprop $epsilon "\\varepsilon" texword)
491(defprop $zeta "\\zeta" texword)
492(defprop $eta "\\eta" texword)
493(defprop $theta "\\vartheta" texword)
494(defprop $iota "\\iota" texword)
495(defprop $kappa "\\kappa" texword)
496(defprop lambda "\\lambda" texword)
497(defprop $lambda "\\lambda" texword)
498(defprop $mu "\\mu" texword)
499(defprop $nu "\\nu" texword)
500(defprop $xi "\\xi" texword)
501(defprop $omicron " o" texword)
502(defprop $%pi "\\pi" texword)
503(defprop $pi "\\pi" texword)
504(defprop $rho "\\rho" texword)
505(defprop $sigma "\\sigma" texword)
506(defprop $tau "\\tau" texword)
507(defprop $upsilon "\\upsilon" texword)
508(defprop $phi "\\varphi" texword)
509(defprop $chi "\\chi" texword)
510(defprop $psi "\\psi" texword)
511(defprop $omega "\\omega" texword)
512
513(defprop |$Alpha| "{\\rm A}" texword)
514(defprop |$Beta| "{\\rm B}" texword)
515(defprop |$Gamma| "\\Gamma" texword)
516(defprop |$Delta| "\\Delta" texword)
517(defprop |$Epsilon| "{\\rm E}" texword)
518(defprop |$Zeta| "{\\rm Z}" texword)
519(defprop |$Eta| "{\\rm H}" texword)
520(defprop |$Theta| "\\Theta" texword)
521(defprop |$Iota| "{\\rm I}" texword)
522(defprop |$Kappa| "{\\rm K}" texword)
523(defprop |$Lambda| "\\Lambda" texword)
524(defprop |$Mu| "{\\rm M}" texword)
525(defprop |$Nu| "{\\rm N}" texword)
526(defprop |$Xi| "\\Xi" texword)
527(defprop |$Omicron| "{\\rm O}" texword)
528(defprop |$Pi| "\\Pi" texword)
529(defprop |$Rho| "{\\rm P}" texword)
530(defprop |$Sigma| "\\Sigma" texword)
531(defprop |$Tau| "{\\rm T}" texword)
532(defprop |$Upsilon| "\\Upsilon" texword)
533(defprop |$Phi| "\\Phi" texword)
534(defprop |$Chi| "{\\rm X}" texword)
535(defprop |$Psi| "\\Psi" texword)
536(defprop |$Omega| "\\Omega" texword)
537
538(defprop mquote tex-prefix tex)
539(defprop mquote ("\\mbox{{}'{}}") texsym)
540
541(defprop msetq tex-infix tex)
542(defprop msetq (":") texsym)
543
544(defprop mset tex-infix tex)
545(defprop mset ("::") texsym)
546
547(defprop mdefine tex-infix tex)
548(defprop mdefine (":=") texsym)
549
550(defprop mdefmacro tex-infix tex)
551(defprop mdefmacro ("::=") texsym)
552
553(defprop marrow tex-infix tex)
554(defprop marrow ("\\rightarrow ") texsym)
555
556(defprop mfactorial tex-postfix tex)
557(defprop mfactorial ("!") texsym)
558
559(defprop mexpt tex-mexpt tex)
560
561(defprop %sum 110. tex-rbp) ;; added by BLW, 1 Oct 2001
562(defprop %product 115. tex-rbp)	;; added by BLW, 1 Oct 2001
563
564;; If the number contains a exponent marker when printed, we need to
565;; put parens around it.
566(defun numneedsparen (number)
567  (unless (integerp number)
568    (let ((r (exploden number)))
569      (member 'e r :test #'string-equal))))
570
571(defvar *tex-mexpt-trig-like-fns* '(%sin %cos %tan %sinh %cosh %tanh %asin %acos %atan %asinh %acosh %atanh))
572(defun tex-mexpt-trig-like-fn-p (f)
573  (member f *tex-mexpt-trig-like-fns*))
574(defun maybe-tex-mexpt-trig-like (x l r)
575  ;; here is where we have to check for f(x)^b to be displayed
576  ;; as f^b(x), as is the case for sin(x)^2 .
577  ;; which should be sin^2 x rather than (sin x)^2 or (sin(x))^2.
578  ;; yet we must not display (a+b)^2 as +^2(a,b)...
579  ;; or (sin(x))^(-1) as sin^(-1)x, which would be arcsine x
580  (let*
581      ((fx (cadr x)) ; this is f(x)
582       (f (and (not (atom fx)) (atom (caar fx)) (caar fx))) ; this is f [or nil]
583       (bascdr (and f (cdr fx))) ; this is (x) [maybe (x,y..), or nil]
584       (expon (caddr x)) ;; this is the exponent
585       (doit (and
586	      f ; there is such a function
587	      (tex-mexpt-trig-like-fn-p f) ; f is trig-like
588	      (member (get-first-char f) '(#\% #\$) :test #'char=) ;; insist it is a % or $ function
589	      (not (member 'array (cdar fx) :test #'eq)) ; fix for x[i]^2
590	      (or (and (atom expon) (not (numberp expon))) ; f(x)^y is ok
591		  (and (atom expon) (numberp expon) (> expon 0))))))
592                                        ; f(x)^3 is ok, but not f(x)^-1, which could
593                                        ; inverse of f, if written f^-1 x
594                                        ; what else? f(x)^(1/2) is sqrt(f(x)), ??
595    (cond (doit
596	   (setq l (tex `((mexpt) ,f ,expon) l nil 'mparen 'mparen))
597	   (if (and (null (cdr bascdr))
598		    (eq (get f 'tex) 'tex-prefix))
599	       (setq r (tex (car bascdr) nil r f 'mparen))
600	       (setq r (tex (cons '(mprogn) bascdr) nil r 'mparen 'mparen)))
601	   (append l r))
602	  (t nil))) ; won't doit. fall through
603  )
604
605;; insert left-angle-brackets for mncexpt. a^<n> is how a^^n looks.
606(defun tex-mexpt (x l r)
607  (let((nc (eq (caar x) 'mncexpt))) ; true if a^^b rather than a^b
608    (cond ;; this whole clause
609      ;; should be deleted if this hack is unwanted and/or the
610      ;; time it takes is of concern.
611      ;; it shouldn't be too expensive.
612      ((and (eq (caar x) 'mexpt)      ; don't do this hack for mncexpt
613	    (maybe-tex-mexpt-trig-like x l r)))  ; fall through if f is not trig-like
614       (t (setq l (cond ((or ($bfloatp (cadr x))
615                            (and (numberp (cadr x)) (numneedsparen (cadr x))))
616                        ; ACTUALLY THIS TREATMENT IS NEEDED WHENEVER (CAAR X) HAS GREATER BINDING POWER THAN MTIMES ...
617                        (tex (cadr x) (append l '("\\left(")) '("\\right)") lop (caar x)))
618                       (t (tex (cadr x) l nil lop (caar x))))
619               r (if (mmminusp (setq x (nformat (caddr x))))
620                     ;; the change in base-line makes parens unnecessary
621                     (if nc
622                         (tex (cadr x) '("^ {-\\langle ") (cons "\\rangle }" r) 'mparen 'mparen)
623                         (tex (cadr x) '("^ {- ") (cons " }" r) 'mminus 'mparen))
624                     (if nc
625                         (tex x (list "^{\\langle ") (cons "\\rangle}" r) 'mparen 'mparen)
626                         (if (and (integerp x) (< x 10))
627                             (tex x (list "^")(cons "" r) 'mparen 'mparen)
628                             (tex x (list "^{")(cons "}" r) 'mparen 'mparen)))))
629	  (append l r)))))
630
631(defprop mncexpt tex-mexpt tex)
632
633(defprop mnctimes tex-nary tex)
634(defprop mnctimes ("\\cdot ") texsym)
635
636(defprop mtimes tex-nary tex)
637(defprop mtimes ("\\,") texsym)
638
639(defprop %sqrt tex-sqrt tex)
640
641(defun tex-sqrt(x l r)
642  ;; format as \\sqrt { } assuming implicit parens for sqr grouping
643  (tex (cadr x) (append l  '("\\sqrt{")) (append '("}") r) 'mparen 'mparen))
644
645;; macsyma doesn't know about cube (or nth) roots,
646;; but if it did, this is what it would look like.
647(defprop $cubrt tex-cubrt tex)
648
649(defun tex-cubrt (x l r)
650  (tex (cadr x) (append l  '("\\root 3 \\of{")) (append '("}") r) 'mparen 'mparen))
651
652(defprop mquotient tex-mquotient tex)
653(defprop mquotient ("\\over") texsym)
654
655(defun tex-mquotient (x l r)
656  (twoargcheck x)
657  (setq l (tex (cadr x) (append l '("{{")) nil 'mparen 'mparen)
658					;the divide bar groups things
659	r (tex (caddr x) (list "}\\over{") (append '("}}")r) 'mparen 'mparen))
660  (append l r))
661
662(defprop $matrix tex-matrix tex)
663
664;; Tex dialects either offer a \pmatrix command or a pmatrix environment
665;; so we let the TeX decide which one to use.
666(defun tex-matrix(x l r) ;;matrix looks like ((mmatrix)((mlist) a b) ...)
667  (append l `("\\ifx\\endpmatrix\\undefined\\pmatrix{\\else\\begin{pmatrix}\\fi ")
668	  (mapcan #'(lambda(y)
669		      (tex-list (cdr y) nil (list "\\cr ") "&"))
670		  (cdr x))
671	  '("\\ifx\\endpmatrix\\undefined}\\else\\end{pmatrix}\\fi ") r))
672
673;; macsyma sum or prod is over integer range, not  low <= index <= high
674;; TeX is lots more flexible .. but
675
676(defprop %sum tex-sum tex)
677(defprop %lsum tex-lsum tex)
678(defprop %product tex-sum tex)
679
680;; easily extended to union, intersect, otherops
681
682(defun tex-lsum(x l r)
683  (let ((op (cond ((eq (caar x) '%lsum) "\\sum_{")
684		  ;; extend here
685		  ))
686	;; gotta be one of those above
687	;; 4th arg of tex is changed from mparen to (caar x)
688	;; to reflect the operator preceedance correctly.
689	;; This change improves the how to put paren.
690	(s1 (tex (cadr x) nil nil (caar x) rop))	;; summand
691	(index ;; "index = lowerlimit"
692	 (tex `((min simp) , (caddr x), (cadddr x))  nil nil 'mparen 'mparen)))
693    (append l `( ,op ,@index "}}{" ,@s1 "}") r)))
694
695(defun tex-sum(x l r)
696  (let ((op (cond ((eq (caar x) '%sum) "\\sum_{")
697		  ((eq (caar x) '%product) "\\prod_{")
698		  ;; extend here
699		  ))
700	;; gotta be one of those above
701	;; 4th arg of tex is changed from mparen to (caar x)
702	;; to reflect the operator preceedance correctly.
703	;; This change improves the how to put paren.
704	(s1 (tex (cadr x) nil nil (caar x) rop))	;; summand
705	(index ;; "index = lowerlimit"
706	 (tex `((mequal simp) ,(caddr x),(cadddr x)) nil nil 'mparen 'mparen))
707	(toplim (tex (car(cddddr x)) nil nil 'mparen 'mparen)))
708    (append l `( ,op ,@index "}^{" ,@toplim "}{" ,@s1 "}") r)))
709
710(defprop %integrate tex-int tex)
711(defun tex-int (x l r)
712  (let ((s1 (tex (cadr x) nil nil 'mparen 'mparen)) ;;integrand delims / & d
713	(var (tex (caddr x) nil nil 'mparen rop))) ;; variable
714    (cond((= (length x) 3)
715	  (append l `("\\int {" ,@s1 "}{\\;d" ,@var "}") r))
716	 (t ;; presumably length 5
717	  (let ((low (tex (nth 3 x) nil nil 'mparen 'mparen))
718		;; 1st item is 0
719		(hi (tex (nth 4 x) nil nil 'mparen 'mparen)))
720	    (append l `("\\int_{" ,@low "}^{" ,@hi "}{" ,@s1 "\\;d" ,@var "}") r))))))
721
722(defprop %limit tex-limit tex)
723
724(defun tex-limit (x l r)
725  (let*
726     ;; limit function
727    ((s1 (tex (cadr x) nil nil 'mparen rop))
728     (direction (fifth x))
729     ;; the thing underneath "limit"
730     (subfun
731       (subst (or (and (eq direction '$plus) "\\downarrow ")
732                  (and (eq direction '$minus) "\\uparrow ")
733                  "\\rightarrow ")
734              '=
735              (tex `((mequal simp) ,(caddr x),(cadddr x))
736                   nil nil 'mparen 'mparen))))
737    (append l `("\\lim_{" ,@subfun "}{" ,@s1 "}") r)))
738
739(defprop %at tex-at tex)
740
741;; e.g.  at(diff(f(x)),x=a)
742(defun tex-at (x l r)
743  (let ((s1 (tex (cadr x) nil nil lop rop))
744	(sub (tex (caddr x) nil nil 'mparen 'mparen)))
745    (append l '("\\left.") s1  '("\\right|_{") sub '("}") r)))
746
747(defprop mbox tex-mbox tex)
748
749;; \boxed is defined in amsmath.sty,
750;; \newcommand{\boxed}[1]{\fbox{\m@th$\displaystyle#1$}}
751
752(defun tex-mbox (x l r)
753  (append l '("\\boxed{") (tex (cadr x) nil nil 'mparen 'mparen) '("}") r))
754
755(defprop mlabox tex-mlabox tex)
756
757(defun tex-mlabox (x l r)
758  (append l '("\\stackrel{") (tex (caddr x) nil nil 'mparen 'mparen)
759	  '("}{\\boxed{") (tex (cadr x) nil nil 'mparen 'mparen) '("}}") r))
760
761;;binomial coefficients
762
763(defprop %binomial tex-choose tex)
764
765(defun tex-choose (x l r)
766  (append l
767          '("{{")
768          (tex (cadr x) nil nil 'mparen 'mparen)
769          '("}\\choose{")
770          (tex (caddr x) nil nil 'mparen 'mparen)
771          '("}}")
772          r))
773
774(defprop rat tex-rat tex)
775(defun tex-rat(x l r) (tex-mquotient x l r))
776
777(defprop mplus tex-mplus tex)
778
779(defun tex-mplus (x l r)
780					;(declare (fixnum w))
781  (cond ((member 'trunc (car x) :test #'eq) (setq r (cons "+\\cdots " r))))
782  (cond ((null (cddr x))
783	 (if (null (cdr x))
784	     (tex-function x l r t)
785	     (tex (cadr x) (cons "+" l) r 'mplus rop)))
786	(t (setq l (tex (cadr x) l nil lop 'mplus)
787		 x (cddr x))
788	   (do ((nl l)  (dissym))
789	       ((null (cdr x))
790		(if (mmminusp (car x)) (setq l (cadar x) dissym (list "-"))
791		    (setq l (car x) dissym (list "+")))
792		(setq r (tex l dissym r 'mplus rop))
793		(append nl r))
794	     (if (mmminusp (car x)) (setq l (cadar x) dissym (list "-"))
795		 (setq l (car x) dissym (list "+")))
796	     (setq nl (append nl (tex l dissym nil 'mplus 'mplus))
797		   x (cdr x))))))
798
799(defprop mminus tex-prefix tex)
800(defprop mminus ("-") texsym)
801
802;; MIN = "Maxima in", apparently -- not to be confused with the least value of a set.
803;; MIN is not known to the parser, although it seems stuff like "x in S" could make use of MIN.
804
805(defprop min tex-infix tex)
806(defprop min ("\\in{") texsym)
807(defprop min 80. tex-lbp)
808(defprop min 80. tex-rbp)
809
810(defprop mequal tex-infix tex)
811(defprop mequal (=) texsym)
812
813(defprop mnotequal tex-infix tex)
814(defprop mnotequal ("\\neq ") texsym)
815
816(defprop mgreaterp tex-infix tex)
817(defprop mgreaterp (>) texsym)
818
819(defprop mgeqp tex-infix tex)
820(defprop mgeqp ("\\geq ") texsym)
821
822(defprop mlessp tex-infix tex)
823(defprop mlessp (<) texsym)
824
825(defprop mleqp tex-infix tex)
826(defprop mleqp ("\\leq ") texsym)
827
828(defprop mnot tex-prefix tex)
829(defprop mnot ("\\neg ") texsym)
830
831(defprop mand tex-nary tex)
832(defprop mand ("\\land ") texsym)
833
834(defprop mor tex-nary tex)
835(defprop mor ("\\lor ") texsym)
836
837;; make sin(x) display as sin x , but sin(x+y) as sin(x+y)
838;; etc
839
840(defun tex-setup (x)
841  (let((a (car x))
842       (b (cadr x)))
843    (setf (get a 'tex) 'tex-prefix)
844    (setf (get a 'texword) b)	;This means "sin" will always be roman
845    (setf (get a 'texsym) (list b))
846    (setf (get a 'tex-rbp) 130)))
847
848
849;; I WONDER IF ALL BUILT-IN FUNCTIONS SHOULD BE SET IN ROMAN TYPE
850(defprop $atan2 "{\\rm atan2}" texword)
851
852;; JM 09/01 expand and re-order to follow table of "log-like" functions,
853;; see table in Lamport, 2nd edition, 1994, p. 44, table 3.9.
854;; I don't know if these are Latex-specific so you may have to define
855;; them if you use plain Tex.
856
857(mapc #'tex-setup
858      '(
859	(%acos "\\arccos ")
860	(%asin "\\arcsin ")
861	(%atan "\\arctan ")
862
863					; Latex's arg(x) is ... ?
864	(%cos "\\cos ")
865	(%cosh "\\cosh ")
866	(%cot "\\cot ")
867	(%coth "\\coth ")
868	(%csc "\\csc ")
869					; Latex's "deg" is ... ?
870	(%determinant "\\det ")
871	(%dim "\\dim ")
872	(%exp "\\exp ")
873	(%gcd "\\gcd ")
874					; Latex's "hom" is ... ?
875	(%inf "\\inf ")		   ; many will prefer "\\infty". Hmmm.
876					; Latex's "ker" is ... ?
877					; Latex's "lg" is ... ?
878					; lim is handled by tex-limit.
879					; Latex's "liminf" ... ?
880					; Latex's "limsup" ... ?
881	(%ln "\\ln ")
882	(%log "\\log ")
883	(%max "\\max ")
884	(%min "\\min ")
885					; Latex's "Pr" ... ?
886	(%sec "\\sec ")
887	(%sin "\\sin ")
888	(%sinh "\\sinh ")
889					; Latex's "sup" ... ?
890	(%tan "\\tan ")
891	(%tanh "\\tanh ")
892	;; (%erf "{\\rm erf}") this would tend to set erf(x) as erf x. Unusual
893					;(%laplace "{\\cal L}")
894
895    ; Maxima built-in functions which do not have corresponding TeX symbols.
896
897    (%asec "{\\rm arcsec}\\; ")
898    (%acsc "{\\rm arccsc}\\; ")
899    (%acot "{\\rm arccot}\\; ")
900
901    (%sech "{\\rm sech}\\; ")
902    (%csch "{\\rm csch}\\; ")
903
904    (%asinh "{\\rm asinh}\\; ")
905    (%acosh "{\\rm acosh}\\; ")
906    (%atanh "{\\rm atanh}\\; ")
907
908    (%asech "{\\rm asech}\\; ")
909    (%acsch "{\\rm acsch}\\; ")
910    (%acoth "{\\rm acoth}\\; ")
911
912	)) ;; etc
913
914(defprop mcond tex-mcond tex)
915(defprop %mcond tex-mcond tex)
916
917(defprop %del tex-prefix tex)
918(defprop %del ("d") texsym)
919
920(defprop %derivative tex-derivative tex)
921(defun tex-derivative (x l r)
922  (tex (if $derivabbrev
923	   (tex-dabbrev x)
924	   (tex-d x '$d)) l r lop rop ))
925
926(defun tex-d(x dsym)		    ;dsym should be $d or "$\\partial"
927  ;; format the macsyma derivative form so it looks
928  ;; sort of like a quotient times the deriva-dand.
929  (let*
930      ((arg (cadr x)) ;; the function being differentiated
931       (difflist (cddr x)) ;; list of derivs e.g. (x 1 y 2)
932       (ords (odds difflist 0))	;; e.g. (1 2)
933       (vars (odds difflist 1))	;; e.g. (x y)
934       (numer `((mexpt) ,dsym ((mplus) ,@ords))) ; d^n numerator
935       (denom (cons '(mtimes)
936		    (mapcan #'(lambda(b e)
937				`(,dsym ,(simplifya `((mexpt) ,b ,e) nil)))
938			    vars ords))))
939    `((mtimes)
940      ((mquotient) ,(simplifya numer nil) ,denom)
941      ,arg)))
942
943(defun tex-dabbrev (x)
944  ;; Format diff(f,x,1,y,1) so that it looks like
945  ;; f
946  ;;  x y
947  (let*
948      ((arg (cadr x)) ;; the function being differentiated
949       (difflist (cddr x)) ;; list of derivs e.g. (x 1 y 2)
950       (ords (odds difflist 0))	;; e.g. (1 2)
951       (vars (odds difflist 1))) ;; e.g. (x y)
952    (append
953     (if (symbolp arg)
954	 `((,arg array))
955	 `((mqapply array) ,arg))
956     (if (and (= (length vars) 1)
957	      (= (car ords) 1))
958	 vars
959	 `(((mtimes) ,@(mapcan #'(lambda (var ord)
960				   (make-list ord :initial-element var))
961			       vars ords)))))))
962
963(defun odds (list c)
964  (ecase c
965    (1 (loop for e in list by #'cddr collect e))         ;; get the odd terms  (first, third...)
966    (0 (loop for e in (cdr list) by #'cddr collect e)))) ;; get the (second, fourth ... ) element
967
968;; The format of MCOND expressions is documented above the definition
969;; of DIM-MCOND in displa.lisp.  Here are some examples:
970;;
971;;   ((%mcond) $a $b t nil)         <==>  'if a then b
972;;   ((%mcond) $a $b t $d)          <==>  'if a then b else d
973;;   ((%mcond) $a $b $c nil t nil)  <==>  'if a then b elseif c then false
974;;   ((%mcond) $a $b $c $d t nil)   <==>  'if a then b elseif c then d
975;;   ((%mcond) $a $b $c $d t $f)    <==>  'if a then b elseif c then d else f
976;;
977;; Note that DIM-MCOND omits display of the final "else" in three
978;; cases illustrated below, so we do the same here:
979;;
980;;   ((%mcond) $a $b $c $d t $false)  <==>  '(if a then b elseif c then d)
981;;   ((%mcond) $a $b $c $d t nil)     <==>   'if a then b elseif c then d
982;;   ((%mcond) $a $b $c $d)            ==>   'if a then b elseif c then d
983;;
984;; The first two cases occur in practice, as can be seen by evaluating
985;; ?print('(if a then b)) and ?print(if a then b).  The parser
986;; produces the first case, which is transformed into the second case
987;; during evaluation.  The third case is handled equivalently by the
988;; evaluator and DIM-MCOND, and might plausibly be created by some
989;; code, so we handle it here as well.
990;;
991;; The use of '$false (instead of nil) may be a hack that is no longer
992;; needed.  For more information on this, search for $false in
993;; PARSE-CONDITION of nparse.lisp and DIM-MCOND of displa.lisp.  Also
994;; see the mailing list thread with subject "Bugs in tex-mcond" which
995;; took place in January 2011.  -MHW
996;;
997(defun tex-mcond (x l r)
998  (labels
999      ((recurse (x l)
1000	 (append
1001	  (tex (car x) l '("\\;\\mathbf{then}\\;") 'mparen 'mparen)
1002	  (cond ((member (cddr x) '(() (t nil) (t $false)) :test #'equal)
1003		 (tex (second x) nil r 'mcond rop))
1004		((and (eq (third x) t) (null (nthcdr 4 x)))
1005		 (append
1006		  (tex (second x) nil nil 'mparen 'mparen)
1007		  (tex (fourth x) '("\\;\\mathbf{else}\\;") r 'mcond rop)))
1008		(t (append
1009		    (tex (second x) nil nil 'mparen 'mparen)
1010		    (recurse (cddr x) '("\\;\\mathbf{elseif}\\;"))))))))
1011  (append l (recurse (cdr x) '("\\mathbf{if}\\;")))))
1012
1013(defprop mdo tex-mdo tex)
1014(defprop mdoin tex-mdoin tex)
1015
1016(defprop %mdo tex-mdo tex)
1017(defprop %mdoin tex-mdoin tex)
1018
1019(defun tex-lbp(x)(cond((get x 'tex-lbp))(t(lbp x))))
1020(defun tex-rbp(x)(cond((get x 'tex-rbp))(t(rbp x))))
1021
1022;; these aren't quite right
1023
1024(defun tex-mdo (x l r)
1025  (tex-list (texmdo x) l r "\\;"))
1026
1027(defun tex-mdoin (x l r)
1028  (tex-list (texmdoin x) l r "\\;"))
1029
1030(defun texmdo (x)
1031  (nconc (cond ((second x) `("\\mathbf{for}" ,(second x))))
1032	 (cond ((equal 1 (third x)) nil)
1033	       ((third x)  `("\\mathbf{from}" ,(third x))))
1034	 (cond ((equal 1 (fourth x)) nil)
1035	       ((fourth x) `("\\mathbf{step}" ,(fourth x)))
1036	       ((fifth x)  `("\\mathbf{next}" ,(fifth x))))
1037	 (cond ((sixth x)  `("\\mathbf{thru}" ,(sixth x))))
1038	 (cond ((null (seventh x)) nil)
1039	       ((eq 'mnot (caar (seventh x)))
1040		`("\\mathbf{while}" ,(cadr (seventh x))))
1041	       (t `("\\mathbf{unless}" ,(seventh x))))
1042	 `("\\mathbf{do}" ,(eighth x))))
1043
1044(defun texmdoin (x)
1045  (nconc `("\\mathbf{for}" ,(second x) "\\mathbf{in}" ,(third x))
1046	 (cond ((sixth x) `("\\mathbf{thru}" ,(sixth x))))
1047	 (cond ((null (seventh x)) nil)
1048	       ((eq 'mnot (caar (seventh x)))
1049		`("\\mathbf{while}" ,(cadr (seventh x))))
1050	       (t `("\\mathbf{unless}" ,(seventh x))))
1051	 `("\\mathbf{do}" ,(eighth x))))
1052
1053(defprop mtext tex-mtext tex)
1054(defprop text-string tex-mtext tex)
1055(defprop mlabel tex-mlabel tex)
1056(defprop spaceout tex-spaceout tex)
1057
1058;; Additions by Marek Rychlik (rychlik@u.arizona.edu)
1059;; This stuff handles setting of LET rules
1060
1061(defprop | --> | "\\longrightarrow " texsym)
1062(defprop #.(intern (format nil " ~A " 'where)) "\\;\\mathbf{where}\\;" texsym)
1063
1064;; end of additions by Marek Rychlik
1065
1066(defun tex-try-sym (x)
1067  (if (symbolp x)
1068      (let ((tx (get x 'texsym))) (if tx tx x))
1069      x))
1070
1071(defun tex-mtext (x l r)
1072  (tex-list (map 'list #'tex-try-sym (cdr x)) l r ""))
1073
1074(defun tex-mlabel (x l r)
1075  (tex (caddr x)
1076       (append l
1077	       (if (cadr x)
1078		   (list (format nil "\\mbox{\\tt\\red(~A) \\black}" (tex-stripdollar (cadr x))))
1079		   nil))
1080       r 'mparen 'mparen))
1081
1082(defun tex-spaceout (x l r)
1083  (append l (cons (format nil "\\hspace{~dmm}" (* 3 (cadr x))) r)))
1084
1085;; run some code initialize file before $tex is run
1086(defmfun $texinit(file)
1087(declare (ignore file))
1088  '$done)
1089
1090;; this just prints a \\end on the file;  this is something a TeXnician would
1091;; probably have no trouble spotting, and will generally be unnecessary, since
1092;; we anticipate almost all use of tex would be involved in inserting this
1093;; stuff into larger files that would have their own \\end or equivalent.
1094(defmfun $texend(filename)
1095  (with-open-file (st (stripdollar filename)  :direction :output
1096		      :if-exists :append :if-does-not-exist :create)
1097    (format st "\\end~%"))
1098  '$done)
1099
1100;; Construct a Lisp function and attach it to the TEX property of
1101;; operator OP. The constructed function calls a Maxima function F
1102;; to generate TeX output for OP.
1103;; F must take 1 argument (an expression which has operator OP)
1104;; and must return a string (the TeX output).
1105
1106(defun make-maxima-tex-glue (op f)
1107  (let
1108    ((glue-f (gensym))
1109     (f-body `(append l
1110                      (list
1111                        (let ((f-x (mfuncall ',f x)))
1112                          (if (stringp f-x) f-x
1113                            (merror (intl:gettext "tex: function ~s did not return a string.~%") ($sconcat ',f)))))
1114                      r)))
1115    (setf (symbol-function glue-f) (coerce `(lambda (x l r) ,f-body) 'function))
1116    (setf (get op 'tex) glue-f))
1117  f)
1118
1119;; Convenience function to allow user to process expression X
1120;; and get a string (TeX output for X) in return.
1121
1122(defmfun $tex1 (x) (reduce #'strcat (tex x nil nil 'mparen 'mparen)))
1123
1124;; Undone and trickier:
1125;; handle reserved symbols stuff, just in case someone
1126;; has a macsyma variable named (yuck!!) \over  or has a name with
1127;; {} in it.
1128;; Maybe do some special hacking for standard notations for
1129;; hypergeometric fns, alternative summation notations  0<=n<=inf, etc.
1130
1131;;Undone and really pretty hard: line breaking
1132
1133;;  The texput function was written by Barton Willis.
1134
1135(defmfun $texput (e s &optional tx)
1136
1137  (cond
1138    ((stringp e)
1139     (setq e ($verbify e)))
1140    ((not (symbolp e))
1141     (merror (intl:gettext "texput: first argument must be a string or a symbol; found: ~M") e)))
1142
1143  (setq s (if ($listp s) (margs s) (list s)))
1144
1145  (cond
1146    ((null tx)
1147     ;; texput was called as texput(op, foo) where foo is a string
1148     ;; or a symbol; when foo is a string, assign TEXWORD property,
1149     ;; when foo is a symbol, construct glue function to call
1150     ;; the Maxima function named by foo.
1151     (let ((s0 (nth 0 s)))
1152       (if (stringp s0)
1153         (putprop e s0 'texword)
1154         (make-maxima-tex-glue e s0)))) ;; assigns TEX property
1155	((eq tx '$matchfix)
1156	 (putprop e 'tex-matchfix 'tex)
1157	 (cond ((< (length s) 2)
1158		(merror (intl:gettext "texput: expected a list of two items for matchfix operator.")))
1159	       ((= (length s) 2)
1160		(putprop e (list (list (first s)) (second s)) 'texsym))
1161	       (t
1162		(putprop e (list (list (first s)) (second s) (third s)) 'texsym)))
1163	 `((mlist) ,@s))
1164
1165	((eq tx '$nofix)
1166	 (putprop e 'tex-nofix 'tex)
1167	 (putprop e s 'texsym)
1168	 (car s))
1169
1170	((eq tx '$prefix)
1171	 (putprop e 'tex-prefix 'tex)
1172	 (when (null (get e 'grind))
1173	   (putprop e 180 'tex-rbp))
1174	 (putprop e s 'texsym)
1175	 (car s))
1176
1177	((eq tx '$infix)
1178	 (putprop e 'tex-infix 'tex)
1179	 (when (null (get e 'grind))
1180	   (putprop e 180 'tex-lbp)
1181	   (putprop e 180 'tex-rbp))
1182	 (putprop e  s 'texsym)
1183	 (car s))
1184
1185	((eq tx '$nary)
1186	 (putprop e 'tex-nary 'tex)
1187	 (when (null (get e 'grind))
1188	   (putprop e 180 'tex-lbp)
1189	   (putprop e 180 'tex-rbp))
1190	 (putprop e s 'texsym)
1191	 (car s))
1192
1193	((eq tx '$postfix)
1194	 (putprop e 'tex-postfix 'tex)
1195	 (when (null (get e 'grind))
1196	   (putprop e 180 'tex-lbp))
1197	 (putprop e  s 'texsym)
1198	 (car s))))
1199