src/mactex.lisp

   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                       ((symbolp x) (tex-stripdollar (or (get x 'reversealias) x)))
 256                       (t
 257                        (let ((x (if (member (marray-type x) '(array hash-table $functional))
 258                                     ($sconcat x)
 259                                   (format nil "~A" x))))
 260                          ;; Do not apply stringdisp here -- we are outputting a string
 261                          ;; only because we don't have a better way to handle Lisp arrays.
 262                          (tex-string (quote-chars 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   (tex-array-display-indices x l r))
 348
 349 (defun tex-array-display-indices (x l r)
 350   (let*
 351     ((base-symbol (caar x))
 352      (indices (cdr x))
 353      (display-indices (safe-mget base-symbol 'display-indices)))
 354     (if (or (not display-indices) (not (= (length display-indices) (length indices))))
 355       ;; Ignore DISPLAY-INDICES if it's empty, or nonempty and not the same size as INDICES.
 356       (tex-array-simple x l r)
 357       (let
 358         ((pre-subscripts (extract-indices indices display-indices '$presubscript))
 359          (pre-superscripts (extract-indices indices display-indices '$presuperscript))
 360          (post-subscripts (extract-indices indices display-indices '$postsubscript))
 361          (post-superscripts (extract-indices indices display-indices '$postsuperscript)))
 362         (when (or pre-subscripts pre-superscripts)
 363           (setq l (append l
 364                           (list "{}")
 365                           (if pre-subscripts (cons "_{" (tex-list pre-subscripts nil (list "}") ",")))
 366                           (if pre-superscripts (cons "^{" (tex-list pre-superscripts nil (list "}") ","))))))
 367         (when (or post-subscripts post-superscripts)
 368           (setq r (append (if post-subscripts (cons "_{" (tex-list post-subscripts nil (list "}") ",")))
 369                           (if post-superscripts  (cons "^{" (tex-list post-superscripts nil (list "}") ","))) r)))
 370         (tex-atom base-symbol l r)))))
 371
 372 (defun tex-array-simple (x l r)
 373   (let ((f))
 374     ;; I believe this test always fails; TEX-MQAPPLY calls TEX-ARRAY w/ X = second argument of MQAPPLY.
 375     (if (eq 'mqapply (caar x))
 376         (setq f (cadr x)
 377               x (cdr x)
 378               l (tex f (append l (list "\\left(")) (list "\\right)") 'mparen 'mparen))
 379         (setq f (caar x)
 380               l (tex f l nil lop 'mfunction)))
 381     (setq
 382      r (nconc (tex-list (cdr x) nil (list "}") ",") r))
 383     (nconc l (list "_{") r  )))
 384
 385 ;;
 386 ;; we could patch this so sin x rather than sin(x), but instead we made sin a prefix
 387 ;; operator
 388
 389 (defun tex-function (x l r op) op
 390        (setq l (tex (caar x) l nil 'mparen 'mparen)
 391              r (tex (cons '(mprogn) (cdr x)) nil r 'mparen 'mparen))
 392        (nconc l r))
 393
 394 ;; set up a list , separated by symbols (, * ...)  and then tack on the
 395 ;; ending item (e.g. "]" or perhaps ")"
 396
 397 (defun tex-list (x l r sym)
 398   (if (null x) r
 399       (do ((nl))
 400           ((null (cdr x))
 401            (setq nl (nconc nl (tex (car x)  l r 'mparen 'mparen)))
 402            nl)
 403         (setq nl (nconc nl (tex (car x)  l (list sym) 'mparen 'mparen))
 404               x (cdr x)
 405               l nil))))
 406
 407 (defun tex-prefix (x l r)
 408   (tex (cadr x) (append l (texsym (caar x))) r (caar x) rop))
 409
 410 (defun tex-infix (x l r)
 411   (twoargcheck x)
 412   (setq l (tex (cadr x) l nil lop (caar x)))
 413   (tex (caddr x) (append l (texsym (caar x))) r (caar x) rop))
 414
 415 (defun tex-postfix (x l r)
 416   (tex (cadr x) l (append (texsym (caar x)) r) lop (caar x)))
 417
 418 (defun tex-nary (x l r)
 419   (let* ((op (caar x)) (sym (texsym op)) (y (cdr x)) (ext-lop lop) (ext-rop rop))
 420     (cond ((null y)       (tex-function x l r t)) ; this should not happen
 421           ((null (cdr y)) (tex-function x l r t)) ; this should not happen, too
 422           (t (do ((nl) (lop ext-lop op) (rop op (if (null (cdr y)) ext-rop op)))
 423                  ((null (cdr y)) (setq nl (append nl (tex (car y)  l r lop rop))) nl)
 424                (setq nl (append nl (tex (car y) l sym lop rop))
 425                      y (cdr y)
 426                      l nil))))))
 427
 428 (defun tex-nofix (x l r) (tex (car (texsym (caar x))) l r (caar x) rop))
 429
 430 (defun tex-matchfix (x l r)
 431   (setq l (append l (car (texsym (caar x))))
 432     ;; car of texsym of a matchfix operator is the lead op
 433     r (append (list (nth 1 (texsym (caar x)))) r)
 434     ;; cdr is the trailing op
 435     x (tex-list (cdr x) nil r (or (nth 2 (texsym (caar x))) " , ")))
 436   (append l x))
 437
 438 (defun texsym (x)
 439   (or (get x 'texsym) (get x 'strsym)
 440       (get x 'dissym)
 441       (stripdollar x)))
 442
 443 (defun texword (x)
 444   (or (get x 'texword)
 445       (stripdollar x)))
 446
 447 (defprop bigfloat tex-bigfloat tex)
 448
 449 ; For 1.2345b678, generate TeX output 1.2345_B \times 10^{678} .
 450 ; If the exponent is 0, then ... \times 10^{0} is generated
 451 ; (no attempt to strip off zero exponent).
 452
 453 (defun tex-bigfloat (x l r)
 454   (let ((formatted (fpformat x)))
 455     ; There should always be a '|b| or '|B| in the FPFORMAT output.
 456     ; Play it safe -- check anyway.
 457     (if (or (find '|b| formatted) (find '|B| formatted))
 458       (let*
 459         ((spell-out-expt
 460            (append
 461              (apply #'append
 462                     (mapcar
 463                      #'(lambda (e) (if (or (eq e '|b|) (eq e '|B|))
 464                                        '("_B" | | "\\times" | | "10^{")
 465                                        (list e)))
 466                       formatted))
 467              '(|}|))))
 468         (append l spell-out-expt r))
 469       (append l formatted r))))
 470
 471 (defprop mprog "\\mathbf{block}\\;" texword)
 472 (defprop %erf "\\mathrm{erf}" texword)
 473 (defprop $erf "\\mathrm{erf}" texword) ;; etc for multicharacter names
 474 (defprop $true  "\\mathbf{true}"  texword)
 475 (defprop $false "\\mathbf{false}" texword)
 476 (defprop $done "\\mathbf{done}" texword)
 477
 478 (defprop mprogn tex-matchfix tex) ;; mprogn is (<progstmnt>, ...)
 479 (defprop mprogn (("\\left(") "\\right)") texsym)
 480
 481 (defprop mlist tex-matchfix tex)
 482 (defprop mlist (("\\left[ ")" \\right] ") texsym)
 483 (setf (get '%mlist 'tex) (get 'mlist 'tex))
 484 (setf (get '%mlist 'texsym) (get 'mlist 'texsym))
 485
 486 ;;absolute value
 487 (defprop mabs tex-matchfix tex)
 488 (defprop mabs (("\\left| ")"\\right| ") texsym)
 489
 490 (defprop mqapply tex-mqapply tex)
 491
 492 (defun tex-mqapply (x l r)
 493   (setq l (tex (cadr x) l (list "(" ) lop 'mfunction)
 494         r (tex-list (cddr x) nil (cons ")" r) ","))
 495   (append l r)) ;; fixed 9/24/87 RJF
 496
 497 (defprop $%i "i" texword)
 498 (defprop $%e "e" texword)
 499 (defprop $inf "\\infty " texword)
 500 (defprop $minf " -\\infty " texword)
 501 (defprop %laplace "\\mathcal{L}" texword)
 502
 503 (defprop $alpha "\\alpha" texword)
 504 (defprop $beta "\\beta" texword)
 505 (defprop $gamma "\\gamma" texword)
 506 (defprop %gamma "\\gamma" texword)
 507
 508 (defprop %gamma tex-gamma tex)
 509 (defun tex-gamma (x l r)
 510  (tex (cadr x) (append l '("\\Gamma\\left(")) (append '("\\right)") r) 'mparen 'mparen))
 511
 512 (defprop $%gamma "\\gamma" texword)
 513 (defprop %gamma_incomplete "\\Gamma" texword)
 514 (defprop %gamma_incomplete_regularized "Q" texword)
 515 (defprop %gamma_incomplete_generalized "\\Gamma" texword)
 516 (defprop $gamma_incomplete_lower "\\gamma" texword)
 517 (defprop $delta "\\delta" texword)
 518 (defprop $epsilon "\\varepsilon" texword)
 519 (defprop $zeta "\\zeta" texword)
 520 (defprop $eta "\\eta" texword)
 521 (defprop $theta "\\vartheta" texword)
 522 (defprop $iota "\\iota" texword)
 523 (defprop $kappa "\\kappa" texword)
 524 (defprop lambda "\\lambda" texword)
 525 (defprop $lambda "\\lambda" texword)
 526 (defprop $mu "\\mu" texword)
 527 (defprop $nu "\\nu" texword)
 528 (defprop $xi "\\xi" texword)
 529 (defprop $omicron " o" texword)
 530 (defprop $%pi "\\pi" texword)
 531 (defprop $pi "\\pi" texword)
 532 (defprop $rho "\\rho" texword)
 533 (defprop $sigma "\\sigma" texword)
 534 (defprop $tau "\\tau" texword)
 535 (defprop $upsilon "\\upsilon" texword)
 536 (defprop $phi "\\varphi" texword)
 537 (defprop $chi "\\chi" texword)
 538 (defprop $psi "\\psi" texword)
 539 (defprop $omega "\\omega" texword)
 540
 541 (defprop |$Alpha| "{\\rm A}" texword)
 542 (defprop |$Beta| "{\\rm B}" texword)
 543 (defprop |$Gamma| "\\Gamma" texword)
 544 (defprop |$Delta| "\\Delta" texword)
 545 (defprop |$Epsilon| "{\\rm E}" texword)
 546 (defprop |$Zeta| "{\\rm Z}" texword)
 547 (defprop |$Eta| "{\\rm H}" texword)
 548 (defprop |$Theta| "\\Theta" texword)
 549 (defprop |$Iota| "{\\rm I}" texword)
 550 (defprop |$Kappa| "{\\rm K}" texword)
 551 (defprop |$Lambda| "\\Lambda" texword)
 552 (defprop |$Mu| "{\\rm M}" texword)
 553 (defprop |$Nu| "{\\rm N}" texword)
 554 (defprop |$Xi| "\\Xi" texword)
 555 (defprop |$Omicron| "{\\rm O}" texword)
 556 (defprop |$Pi| "\\Pi" texword)
 557 (defprop |$Rho| "{\\rm P}" texword)
 558 (defprop |$Sigma| "\\Sigma" texword)
 559 (defprop |$Tau| "{\\rm T}" texword)
 560 (defprop |$Upsilon| "\\Upsilon" texword)
 561 (defprop |$Phi| "\\Phi" texword)
 562 (defprop |$Chi| "{\\rm X}" texword)
 563 (defprop |$Psi| "\\Psi" texword)
 564 (defprop |$Omega| "\\Omega" texword)
 565
 566 (defprop mquote tex-prefix tex)
 567 (defprop mquote ("\\mbox{{}'{}}") texsym)
 568
 569 (defprop msetq tex-infix tex)
 570 (defprop msetq (":") texsym)
 571
 572 (defprop mset tex-infix tex)
 573 (defprop mset ("::") texsym)
 574
 575 (defprop mdefine tex-infix tex)
 576 (defprop mdefine (":=") texsym)
 577
 578 (defprop mdefmacro tex-infix tex)
 579 (defprop mdefmacro ("::=") texsym)
 580
 581 (defprop marrow tex-infix tex)
 582 (defprop marrow ("\\rightarrow ") texsym)
 583
 584 (defprop mfactorial tex-postfix tex)
 585 (defprop mfactorial ("!") texsym)
 586
 587 (defprop mexpt tex-mexpt tex)
 588
 589 (defprop %sum 110. tex-rbp) ;; added by BLW, 1 Oct 2001
 590 (defprop %product 115. tex-rbp) ;; added by BLW, 1 Oct 2001
 591
 592 ;; If the number contains a exponent marker when printed, we need to
 593 ;; put parens around it.
 594 (defun numneedsparen (number)
 595   (unless (integerp number)
 596     (let ((r (exploden number)))
 597       (member 'e r :test #'string-equal))))
 598
 599 (defvar *tex-mexpt-trig-like-fns* '(%sin %cos %tan %csc %sec %cot %sinh %cosh %tanh %asin %acos %atan %asinh %acosh %atanh))
 600 (defun tex-mexpt-trig-like-fn-p (f)
 601   (member f *tex-mexpt-trig-like-fns*))
 602 (defun maybe-tex-mexpt-trig-like (x l r)
 603   ;; here is where we have to check for f(x)^b to be displayed
 604   ;; as f^b(x), as is the case for sin(x)^2 .
 605   ;; which should be sin^2 x rather than (sin x)^2 or (sin(x))^2.
 606   ;; yet we must not display (a+b)^2 as +^2(a,b)...
 607   ;; or (sin(x))^(-1) as sin^(-1)x, which would be arcsine x
 608   (let*
 609       ((fx (cadr x)) ; this is f(x)
 610        (f (and (not (atom fx)) (atom (caar fx)) (caar fx))) ; this is f [or nil]
 611        (bascdr (and f (cdr fx))) ; this is (x) [maybe (x,y..), or nil]
 612        (expon (caddr x)) ;; this is the exponent
 613        (doit (and
 614               f ; there is such a function
 615               (tex-mexpt-trig-like-fn-p f) ; f is trig-like
 616           ;; I THINK THIS NEXT TEST IS UNNECESSARY BECAUSE IF IT PASSES THE PRECEDING TEST, IT IS ACCEPTABLE. REVISIT.
 617               (member (get-first-char f) '(#\% #\$) :test #'char=) ;; insist it is a % or $ function
 618               (not (member 'array (cdar fx) :test #'eq)) ; fix for x[i]^2
 619           ;; I THINK THIS NEXT TEST IS UNNECESSARY BECAUSE NFORMAT CHANGES (...)^-1 TO 1/(...) AND (...)^(1/2) TO SQRT(...). REVISIT.
 620               (or (and (atom expon) (not (numberp expon))) ; f(x)^y is ok
 621                   (and (atom expon) (numberp expon) (> expon 0))))))
 622                                         ; f(x)^3 is ok, but not f(x)^-1, which could
 623                                         ; inverse of f, if written f^-1 x
 624                                         ; what else? f(x)^(1/2) is sqrt(f(x)), ??
 625     (cond (doit
 626            (setq l (tex `((mexpt) ,f ,expon) l nil 'mparen 'mparen))
 627            (if (and (null (cdr bascdr))
 628                     (eq (get f 'tex) 'tex-prefix))
 629                (setq r (tex (car bascdr) nil r f 'mparen))
 630                (setq r (tex (cons '(mprogn) bascdr) nil r 'mparen 'mparen)))
 631            (append l r))
 632           (t nil))) ; won't doit. fall through
 633   )
 634
 635 ;; insert left-angle-brackets for mncexpt. a^<n> is how a^^n looks.
 636 (defun tex-mexpt (x l r)
 637   (let((nc (eq (caar x) 'mncexpt))) ; true if a^^b rather than a^b
 638     (cond ;; this whole clause
 639       ;; should be deleted if this hack is unwanted and/or the
 640       ;; time it takes is of concern.
 641       ;; it shouldn't be too expensive.
 642       ((and (eq (caar x) 'mexpt)      ; don't do this hack for mncexpt
 643             (maybe-tex-mexpt-trig-like x l r)))  ; fall through if f is not trig-like
 644        (t (setq l (cond ((or ($bfloatp (cadr x))
 645                             (and (numberp (cadr x)) (numneedsparen (cadr x))))
 646                         ; ACTUALLY THIS TREATMENT IS NEEDED WHENEVER (CAAR X) HAS GREATER BINDING POWER THAN MTIMES ...
 647                         (tex (cadr x) (append l '("\\left(")) '("\\right)") lop (caar x)))
 648                        (t (tex (cadr x) l nil lop (caar x))))
 649                r (if (mmminusp (setq x (nformat (caddr x))))
 650                      ;; the change in base-line makes parens unnecessary
 651                      (if nc
 652                          (tex (cadr x) '("^ {-\\langle ") (cons "\\rangle }" r) 'mparen 'mparen)
 653                          (tex (cadr x) '("^ {- ") (cons " }" r) 'mminus 'mparen))
 654                      (if nc
 655                          (tex x (list "^{\\langle ") (cons "\\rangle}" r) 'mparen 'mparen)
 656                          (if (and (integerp x) (< x 10))
 657                              (tex x (list "^")(cons "" r) 'mparen 'mparen)
 658                              (tex x (list "^{")(cons "}" r) 'mparen 'mparen)))))
 659           (append l r)))))
 660
 661 (defprop mncexpt tex-mexpt tex)
 662
 663 (defprop mnctimes tex-nary tex)
 664 (defprop mnctimes ("\\cdot ") texsym)
 665
 666 (defprop mtimes tex-nary tex)
 667 (defprop mtimes ("\\,") texsym)
 668
 669 (defprop %sqrt tex-sqrt tex)
 670
 671 (defun tex-sqrt(x l r)
 672   ;; format as \\sqrt { } assuming implicit parens for sqr grouping
 673   (tex (cadr x) (append l  '("\\sqrt{")) (append '("}") r) 'mparen 'mparen))
 674
 675 ;; macsyma doesn't know about cube (or nth) roots,
 676 ;; but if it did, this is what it would look like.
 677 (defprop $cubrt tex-cubrt tex)
 678
 679 (defun tex-cubrt (x l r)
 680   (tex (cadr x) (append l  '("\\root 3 \\of{")) (append '("}") r) 'mparen 'mparen))
 681
 682 (defprop mquotient tex-mquotient tex)
 683 (defprop mquotient ("\\over") texsym)
 684
 685 (defun tex-mquotient (x l r)
 686   (twoargcheck x)
 687   (setq l (tex (cadr x) (append l '("{{")) nil 'mparen 'mparen)
 688                                         ;the divide bar groups things
 689         r (tex (caddr x) (list "}\\over{") (append '("}}")r) 'mparen 'mparen))
 690   (append l r))
 691
 692 (defprop $matrix tex-matrix tex)
 693
 694 ;; Tex dialects either offer a \pmatrix command or a pmatrix environment
 695 ;; so we let the TeX decide which one to use.
 696 (defun tex-matrix(x l r) ;;matrix looks like ((mmatrix)((mlist) a b) ...)
 697   (append l `("\\ifx\\endpmatrix\\undefined\\pmatrix{\\else\\begin{pmatrix}\\fi ")
 698           (mapcan #'(lambda(y)
 699                       (tex-list (cdr y) nil (list "\\cr ") "&"))
 700                   (cdr x))
 701           '("\\ifx\\endpmatrix\\undefined}\\else\\end{pmatrix}\\fi ") r))
 702
 703 ;; macsyma sum or prod is over integer range, not  low <= index <= high
 704 ;; TeX is lots more flexible .. but
 705
 706 (defprop %sum tex-sum tex)
 707 (defprop %lsum tex-lsum tex)
 708 (defprop %product tex-sum tex)
 709
 710 ;; easily extended to union, intersect, otherops
 711
 712 (defun tex-lsum(x l r)
 713   (let ((op (cond ((eq (caar x) '%lsum) "\\sum_{")
 714                   ;; extend here
 715                   ))
 716         ;; gotta be one of those above
 717         ;; 4th arg of tex is changed from mparen to (caar x)
 718         ;; to reflect the operator preceedance correctly.
 719         ;; This change improves the how to put paren.
 720         (s1 (tex (cadr x) nil nil (caar x) rop))        ;; summand
 721         (index ;; "index = lowerlimit"
 722          (tex `((min simp) , (caddr x), (cadddr x))  nil nil 'mparen 'mparen)))
 723     (append l `( ,op ,@index "}}{" ,@s1 "}") r)))
 724
 725 (defun tex-sum(x l r)
 726   (let ((op (cond ((eq (caar x) '%sum) "\\sum_{")
 727                   ((eq (caar x) '%product) "\\prod_{")
 728                   ;; extend here
 729                   ))
 730         ;; gotta be one of those above
 731         ;; 4th arg of tex is changed from mparen to (caar x)
 732         ;; to reflect the operator preceedance correctly.
 733         ;; This change improves the how to put paren.
 734         (s1 (tex (cadr x) nil nil (caar x) rop))        ;; summand
 735         (index ;; "index = lowerlimit"
 736          (tex `((mequal simp) ,(caddr x),(cadddr x)) nil nil 'mparen 'mparen))
 737         (toplim (tex (car(cddddr x)) nil nil 'mparen 'mparen)))
 738     (append l `( ,op ,@index "}^{" ,@toplim "}{" ,@s1 "}") r)))
 739
 740 (defprop %integrate tex-int tex)
 741 (defun tex-int (x l r)
 742   (let ((s1 (tex (cadr x) nil nil 'mparen 'mparen)) ;;integrand delims / & d
 743         (var (tex (caddr x) nil nil 'mparen rop))) ;; variable
 744     (cond((= (length x) 3)
 745           (append l `("\\int {" ,@s1 "}{\\;d" ,@var "}") r))
 746          (t ;; presumably length 5
 747           (let ((low (tex (nth 3 x) nil nil 'mparen 'mparen))
 748                 ;; 1st item is 0
 749                 (hi (tex (nth 4 x) nil nil 'mparen 'mparen)))
 750             (append l `("\\int_{" ,@low "}^{" ,@hi "}{" ,@s1 "\\;d" ,@var "}") r))))))
 751
 752 (defprop %limit tex-limit tex)
 753
 754 (defun tex-limit (x l r)
 755   (let*
 756      ;; limit function
 757     ((s1 (tex (cadr x) nil nil 'mparen rop))
 758      (direction (fifth x))
 759      ;; the thing underneath "limit"
 760      (subfun
 761        (subst (or (and (eq direction '$plus) "\\downarrow ")
 762                   (and (eq direction '$minus) "\\uparrow ")
 763                   "\\rightarrow ")
 764               '=
 765               (tex `((mequal simp) ,(caddr x),(cadddr x))
 766                    nil nil 'mparen 'mparen))))
 767     (append l `("\\lim_{" ,@subfun "}{" ,@s1 "}") r)))
 768
 769 (defprop %at tex-at tex)
 770
 771 ;; e.g.  at(diff(f(x)),x=a)
 772 (defun tex-at (x l r)
 773   (let ((s1 (tex (cadr x) nil nil lop rop))
 774         (sub (tex (caddr x) nil nil 'mparen 'mparen)))
 775     (append l '("\\left.") s1  '("\\right|_{") sub '("}") r)))
 776
 777 (defprop mbox tex-mbox tex)
 778
 779 ;; \boxed is defined in amsmath.sty,
 780 ;; \newcommand{\boxed}[1]{\fbox{\m@th$\displaystyle#1$}}
 781
 782 (defun tex-mbox (x l r)
 783   (append l '("\\boxed{") (tex (cadr x) nil nil 'mparen 'mparen) '("}") r))
 784
 785 (defprop mlabox tex-mlabox tex)
 786
 787 (defun tex-mlabox (x l r)
 788   (append l '("\\stackrel{") (tex (caddr x) nil nil 'mparen 'mparen)
 789           '("}{\\boxed{") (tex (cadr x) nil nil 'mparen 'mparen) '("}}") r))
 790
 791 ;;binomial coefficients
 792
 793 (defprop %binomial tex-choose tex)
 794
 795 (defun tex-choose (x l r)
 796   (append l
 797           '("{{")
 798           (tex (cadr x) nil nil 'mparen 'mparen)
 799           '("}\\choose{")
 800           (tex (caddr x) nil nil 'mparen 'mparen)
 801           '("}}")
 802           r))
 803
 804 (defprop rat tex-rat tex)
 805 (defun tex-rat(x l r) (tex-mquotient x l r))
 806
 807 (defprop mplus tex-mplus tex)
 808
 809 (defun tex-mplus (x l r)
 810                                         ;(declare (fixnum w))
 811   (cond ((member 'trunc (car x) :test #'eq) (setq r (cons "+\\cdots " r))))
 812   (cond ((null (cddr x))
 813          (if (null (cdr x))
 814              (tex-function x l r t)
 815              (tex (cadr x) (cons "+" l) r 'mplus rop)))
 816         (t (setq l (tex (cadr x) l nil lop 'mplus)
 817                  x (cddr x))
 818            (do ((nl l)  (dissym))
 819                ((null (cdr x))
 820                 (if (mmminusp (car x)) (setq l (cadar x) dissym (list "-"))
 821                     (setq l (car x) dissym (list "+")))
 822                 (setq r (tex l dissym r 'mplus rop))
 823                 (append nl r))
 824              (if (mmminusp (car x)) (setq l (cadar x) dissym (list "-"))
 825                  (setq l (car x) dissym (list "+")))
 826              (setq nl (append nl (tex l dissym nil 'mplus 'mplus))
 827                    x (cdr x))))))
 828
 829 (defprop mminus tex-prefix tex)
 830 (defprop mminus ("-") texsym)
 831
 832 ;; MIN = "Maxima in", apparently -- not to be confused with the least value of a set.
 833 ;; MIN is not known to the parser, although it seems stuff like "x in S" could make use of MIN.
 834
 835 (defprop min tex-infix tex)
 836 (defprop min ("\\in{") texsym)
 837 (defprop min 80. tex-lbp)
 838 (defprop min 80. tex-rbp)
 839
 840 (defprop mequal tex-infix tex)
 841 (defprop mequal (=) texsym)
 842
 843 (defprop mnotequal tex-infix tex)
 844 (defprop mnotequal ("\\neq ") texsym)
 845
 846 (defprop mgreaterp tex-infix tex)
 847 (defprop mgreaterp (>) texsym)
 848
 849 (defprop mgeqp tex-infix tex)
 850 (defprop mgeqp ("\\geq ") texsym)
 851
 852 (defprop mlessp tex-infix tex)
 853 (defprop mlessp (<) texsym)
 854
 855 (defprop mleqp tex-infix tex)
 856 (defprop mleqp ("\\leq ") texsym)
 857
 858 (defprop mnot tex-prefix tex)
 859 (defprop mnot ("\\neg ") texsym)
 860
 861 (defprop mand tex-nary tex)
 862 (defprop mand ("\\land ") texsym)
 863
 864 (defprop mor tex-nary tex)
 865 (defprop mor ("\\lor ") texsym)
 866
 867 ;; make sin(x) display as sin x , but sin(x+y) as sin(x+y)
 868 ;; etc
 869
 870 (defun tex-setup (x)
 871   (let((a (car x))
 872        (b (cadr x)))
 873     (setf (get a 'tex) 'tex-prefix)
 874     (setf (get a 'texword) b)   ;This means "sin" will always be roman
 875     (setf (get a 'texsym) (list b))
 876     (setf (get a 'tex-rbp) 130)))
 877
 878
 879 ;; I WONDER IF ALL BUILT-IN FUNCTIONS SHOULD BE SET IN ROMAN TYPE
 880 (defprop $atan2 "{\\rm atan2}" texword)
 881
 882 ;; JM 09/01 expand and re-order to follow table of "log-like" functions,
 883 ;; see table in Lamport, 2nd edition, 1994, p. 44, table 3.9.
 884 ;; I don't know if these are Latex-specific so you may have to define
 885 ;; them if you use plain Tex.
 886
 887 (mapc #'tex-setup
 888       '(
 889         (%acos "\\arccos ")
 890         (%asin "\\arcsin ")
 891         (%atan "\\arctan ")
 892
 893                                         ; Latex's arg(x) is ... ?
 894         (%cos "\\cos ")
 895         (%cosh "\\cosh ")
 896         (%cot "\\cot ")
 897         (%coth "\\coth ")
 898         (%csc "\\csc ")
 899                                         ; Latex's "deg" is ... ?
 900         (%determinant "\\det ")
 901         (%dim "\\dim ")
 902         (%exp "\\exp ")
 903         (%gcd "\\gcd ")
 904                                         ; Latex's "hom" is ... ?
 905         (%inf "\\inf ")            ; many will prefer "\\infty". Hmmm.
 906                                         ; Latex's "ker" is ... ?
 907                                         ; Latex's "lg" is ... ?
 908                                         ; lim is handled by tex-limit.
 909                                         ; Latex's "liminf" ... ?
 910                                         ; Latex's "limsup" ... ?
 911         (%ln "\\ln ")
 912         (%log "\\log ")
 913         (%max "\\max ")
 914         (%min "\\min ")
 915                                         ; Latex's "Pr" ... ?
 916         (%sec "\\sec ")
 917         (%sin "\\sin ")
 918         (%sinh "\\sinh ")
 919                                         ; Latex's "sup" ... ?
 920         (%tan "\\tan ")
 921         (%tanh "\\tanh ")
 922         ;; (%erf "{\\rm erf}") this would tend to set erf(x) as erf x. Unusual
 923                                         ;(%laplace "{\\cal L}")
 924
 925     ; Maxima built-in functions which do not have corresponding TeX symbols.
 926
 927     (%asec "{\\rm arcsec}\\; ")
 928     (%acsc "{\\rm arccsc}\\; ")
 929     (%acot "{\\rm arccot}\\; ")
 930
 931     (%sech "{\\rm sech}\\; ")
 932     (%csch "{\\rm csch}\\; ")
 933
 934     (%asinh "{\\rm asinh}\\; ")
 935     (%acosh "{\\rm acosh}\\; ")
 936     (%atanh "{\\rm atanh}\\; ")
 937
 938     (%asech "{\\rm asech}\\; ")
 939     (%acsch "{\\rm acsch}\\; ")
 940     (%acoth "{\\rm acoth}\\; ")
 941
 942         )) ;; etc
 943
 944 (defprop mcond tex-mcond tex)
 945 (defprop %mcond tex-mcond tex)
 946
 947 (defprop %del tex-prefix tex)
 948 (defprop %del ("d") texsym)
 949
 950 (defprop %derivative tex-derivative tex)
 951 (defun tex-derivative (x l r)
 952   (tex (if $derivabbrev
 953            (tex-dabbrev x)
 954            (tex-d x '$d)) l r lop rop ))
 955
 956 (defun tex-d(x dsym)                ;dsym should be $d or "$\\partial"
 957   ;; format the macsyma derivative form so it looks
 958   ;; sort of like a quotient times the deriva-dand.
 959   (let*
 960       ((arg (cadr x)) ;; the function being differentiated
 961        (difflist (cddr x)) ;; list of derivs e.g. (x 1 y 2)
 962        (ords (odds difflist 0)) ;; e.g. (1 2)
 963        (vars (odds difflist 1)) ;; e.g. (x y)
 964        (numer `((mexpt) ,dsym ((mplus) ,@ords))) ; d^n numerator
 965        (denom (cons '(mtimes)
 966                     (mapcan #'(lambda(b e)
 967                                 `(,dsym ,(simplifya `((mexpt) ,b ,e) nil)))
 968                             vars ords))))
 969     `((mtimes)
 970       ((mquotient) ,(simplifya numer nil) ,denom)
 971       ,arg)))
 972
 973 (defun tex-dabbrev (x)
 974   ;; Format diff(f,x,1,y,1) so that it looks like
 975   ;; f
 976   ;;  x y
 977   (let*
 978       ((arg (cadr x)) ;; the function being differentiated
 979        (difflist (cddr x)) ;; list of derivs e.g. (x 1 y 2)
 980        (ords (odds difflist 0)) ;; e.g. (1 2)
 981        (vars (odds difflist 1))) ;; e.g. (x y)
 982     (append
 983      (if (symbolp arg)
 984          `((,arg array))
 985          `((mqapply array) ,arg))
 986      (if (and (= (length vars) 1)
 987               (= (car ords) 1))
 988          vars
 989          `(((mtimes) ,@(mapcan #'(lambda (var ord)
 990                                    (make-list ord :initial-element var))
 991                                vars ords)))))))
 992
 993 (defun odds (list c)
 994   (ecase c
 995     (1 (loop for e in list by #'cddr collect e))         ;; get the odd terms  (first, third...)
 996     (0 (loop for e in (cdr list) by #'cddr collect e)))) ;; get the (second, fourth ... ) element
 997
 998 ;; The format of MCOND expressions is documented above the definition
 999 ;; of DIM-MCOND in displa.lisp.  Here are some examples:
1000 ;;
1001 ;;   ((%mcond) $a $b t nil)         <==>  'if a then b
1002 ;;   ((%mcond) $a $b t $d)          <==>  'if a then b else d
1003 ;;   ((%mcond) $a $b $c nil t nil)  <==>  'if a then b elseif c then false
1004 ;;   ((%mcond) $a $b $c $d t nil)   <==>  'if a then b elseif c then d
1005 ;;   ((%mcond) $a $b $c $d t $f)    <==>  'if a then b elseif c then d else f
1006 ;;
1007 ;; Note that DIM-MCOND omits display of the final "else" in three
1008 ;; cases illustrated below, so we do the same here:
1009 ;;
1010 ;;   ((%mcond) $a $b $c $d t $false)  <==>  '(if a then b elseif c then d)
1011 ;;   ((%mcond) $a $b $c $d t nil)     <==>   'if a then b elseif c then d
1012 ;;   ((%mcond) $a $b $c $d)            ==>   'if a then b elseif c then d
1013 ;;
1014 ;; The first two cases occur in practice, as can be seen by evaluating
1015 ;; ?print('(if a then b)) and ?print(if a then b).  The parser
1016 ;; produces the first case, which is transformed into the second case
1017 ;; during evaluation.  The third case is handled equivalently by the
1018 ;; evaluator and DIM-MCOND, and might plausibly be created by some
1019 ;; code, so we handle it here as well.
1020 ;;
1021 ;; The use of '$false (instead of nil) may be a hack that is no longer
1022 ;; needed.  For more information on this, search for $false in
1023 ;; PARSE-CONDITION of nparse.lisp and DIM-MCOND of displa.lisp.  Also
1024 ;; see the mailing list thread with subject "Bugs in tex-mcond" which
1025 ;; took place in January 2011.  -MHW
1026 ;;
1027 (defun tex-mcond (x l r)
1028   (labels
1029       ((recurse (x l)
1030          (append
1031           (tex (car x) l '("\\;\\mathbf{then}\\;") 'mparen 'mparen)
1032           (cond ((member (cddr x) '(() (t nil) (t $false)) :test #'equal)
1033                  (tex (second x) nil r 'mcond rop))
1034                 ((and (eq (third x) t) (null (nthcdr 4 x)))
1035                  (append
1036                   (tex (second x) nil nil 'mparen 'mparen)
1037                   (tex (fourth x) '("\\;\\mathbf{else}\\;") r 'mcond rop)))
1038                 (t (append
1039                     (tex (second x) nil nil 'mparen 'mparen)
1040                     (recurse (cddr x) '("\\;\\mathbf{elseif}\\;"))))))))
1041   (append l (recurse (cdr x) '("\\mathbf{if}\\;")))))
1042
1043 (defprop mdo tex-mdo tex)
1044 (defprop mdoin tex-mdoin tex)
1045
1046 (defprop %mdo tex-mdo tex)
1047 (defprop %mdoin tex-mdoin tex)
1048
1049 (defun tex-lbp(x)(cond((get x 'tex-lbp))(t(lbp x))))
1050 (defun tex-rbp(x)(cond((get x 'tex-rbp))(t(rbp x))))
1051
1052 ;; these aren't quite right
1053
1054 (defun tex-mdo (x l r)
1055   (tex-list (texmdo x) l r "\\;"))
1056
1057 (defun tex-mdoin (x l r)
1058   (tex-list (texmdoin x) l r "\\;"))
1059
1060 (defun texmdo (x)
1061   (nconc (cond ((second x) `("\\mathbf{for}" ,(second x))))
1062          (cond ((equal 1 (third x)) nil)
1063                ((third x)  `("\\mathbf{from}" ,(third x))))
1064          (cond ((equal 1 (fourth x)) nil)
1065                ((fourth x) `("\\mathbf{step}" ,(fourth x)))
1066                ((fifth x)  `("\\mathbf{next}" ,(fifth x))))
1067          (cond ((sixth x)  `("\\mathbf{thru}" ,(sixth x))))
1068          (cond ((null (seventh x)) nil)
1069                ((eq 'mnot (caar (seventh x)))
1070                 `("\\mathbf{while}" ,(cadr (seventh x))))
1071                (t `("\\mathbf{unless}" ,(seventh x))))
1072          `("\\mathbf{do}" ,(eighth x))))
1073
1074 (defun texmdoin (x)
1075   (nconc `("\\mathbf{for}" ,(second x) "\\mathbf{in}" ,(third x))
1076          (cond ((sixth x) `("\\mathbf{thru}" ,(sixth x))))
1077          (cond ((null (seventh x)) nil)
1078                ((eq 'mnot (caar (seventh x)))
1079                 `("\\mathbf{while}" ,(cadr (seventh x))))
1080                (t `("\\mathbf{unless}" ,(seventh x))))
1081          `("\\mathbf{do}" ,(eighth x))))
1082
1083 (defprop mtext tex-mtext tex)
1084 (defprop text-string tex-mtext tex)
1085 (defprop mlabel tex-mlabel tex)
1086 (defprop spaceout tex-spaceout tex)
1087
1088 ;; Additions by Marek Rychlik (rychlik@u.arizona.edu)
1089 ;; This stuff handles setting of LET rules
1090
1091 (defprop | --> | "\\longrightarrow " texsym)
1092 (defprop #.(intern (format nil " ~A " 'where)) "\\;\\mathbf{where}\\;" texsym)
1093
1094 ;; end of additions by Marek Rychlik
1095
1096 (defun tex-try-sym (x)
1097   (if (symbolp x)
1098       (let ((tx (get x 'texsym))) (if tx tx x))
1099       x))
1100
1101 (defun tex-mtext (x l r)
1102   (tex-list (map 'list #'tex-try-sym (cdr x)) l r ""))
1103
1104 (defun tex-mlabel (x l r)
1105   (tex (caddr x)
1106        (append l
1107                (if (cadr x)
1108                    (list (format nil "\\mbox{\\tt\\red(~A) \\black}" (tex-stripdollar (cadr x))))
1109                    nil))
1110        r 'mparen 'mparen))
1111
1112 (defun tex-spaceout (x l r)
1113   (append l (cons (format nil "\\hspace{~dmm}" (* 3 (cadr x))) r)))
1114
1115 ;; run some code initialize file before $tex is run
1116 (defmfun $texinit(file)
1117 (declare (ignore file))
1118   '$done)
1119
1120 ;; this just prints a \\end on the file;  this is something a TeXnician would
1121 ;; probably have no trouble spotting, and will generally be unnecessary, since
1122 ;; we anticipate almost all use of tex would be involved in inserting this
1123 ;; stuff into larger files that would have their own \\end or equivalent.
1124 (defmfun $texend(filename)
1125   (with-open-file (st (stripdollar filename)  :direction :output
1126                       :if-exists :append :if-does-not-exist :create)
1127     (format st "\\end~%"))
1128   '$done)
1129
1130 ;; Construct a Lisp function and attach it to the TEX property of
1131 ;; operator OP. The constructed function calls a Maxima function F
1132 ;; to generate TeX output for OP.
1133 ;; F must take 1 argument (an expression which has operator OP)
1134 ;; and must return a string (the TeX output).
1135
1136 (defun make-maxima-tex-glue (op f)
1137   (let
1138     ((glue-f (gensym))
1139      (f-body `(append l
1140                       (list
1141                         (let ((f-x (mfuncall ',f x)))
1142                           (if (stringp f-x) f-x
1143                             (merror (intl:gettext "tex: function ~s did not return a string.~%") ($sconcat ',f)))))
1144                       r)))
1145     (setf (symbol-function glue-f) (coerce `(lambda (x l r) ,f-body) 'function))
1146     (setf (get op 'tex) glue-f))
1147   f)
1148
1149 ;; Convenience function to allow user to process expression X
1150 ;; and get a string (TeX output for X) in return.
1151
1152 (defmfun $tex1 (x) (reduce #'strcat (tex x nil nil 'mparen 'mparen)))
1153
1154 ;; Undone and trickier:
1155 ;; handle reserved symbols stuff, just in case someone
1156 ;; has a macsyma variable named (yuck!!) \over  or has a name with
1157 ;; {} in it.
1158 ;; Maybe do some special hacking for standard notations for
1159 ;; hypergeometric fns, alternative summation notations  0<=n<=inf, etc.
1160
1161 ;;Undone and really pretty hard: line breaking
1162
1163 ;;  The texput function was written by Barton Willis.
1164
1165 (defmfun $texput (e s &optional tx)
1166
1167   (cond
1168     ((stringp e)
1169      (setq e ($verbify e)))
1170     ((not (symbolp e))
1171      (merror (intl:gettext "texput: first argument must be a string or a symbol; found: ~M") e)))
1172
1173   (setq s (if ($listp s) (margs s) (list s)))
1174
1175   (cond
1176     ((null tx)
1177      ;; texput was called as texput(op, foo) where foo is a string
1178      ;; or a symbol; when foo is a string, assign TEXWORD property,
1179      ;; when foo is a symbol, construct glue function to call
1180      ;; the Maxima function named by foo.
1181      (let ((s0 (nth 0 s)))
1182        (if (stringp s0)
1183          (progn
1184            (when (get e 'texsym) (putprop e (list s0) 'texsym))
1185            (putprop e s0 'texword))
1186          (make-maxima-tex-glue e s0)))) ;; assigns TEX property
1187         ((eq tx '$matchfix)
1188          (putprop e 'tex-matchfix 'tex)
1189          (cond ((< (length s) 2)
1190                 (merror (intl:gettext "texput: expected a list of two items for matchfix operator.")))
1191                ((= (length s) 2)
1192                 (putprop e (list (list (first s)) (second s)) 'texsym))
1193                (t
1194                 (putprop e (list (list (first s)) (second s) (third s)) 'texsym)))
1195          `((mlist) ,@s))
1196
1197         ((eq tx '$nofix)
1198          (putprop e 'tex-nofix 'tex)
1199          (putprop e s 'texsym)
1200          (when (get e 'texword) (putprop e (nth 0 s) 'texword))
1201          (car s))
1202
1203         ((eq tx '$prefix)
1204          (putprop e 'tex-prefix 'tex)
1205          (when (null (get e 'grind))
1206            (putprop e 180 'tex-rbp))
1207          (putprop e s 'texsym)
1208          (when (get e 'texword) (putprop e (nth 0 s) 'texword))
1209          (car s))
1210
1211         ((eq tx '$infix)
1212          (putprop e 'tex-infix 'tex)
1213          (when (null (get e 'grind))
1214            (putprop e 180 'tex-lbp)
1215            (putprop e 180 'tex-rbp))
1216          (putprop e  s 'texsym)
1217          (when (get e 'texword) (putprop e (nth 0 s) 'texword))
1218          (car s))
1219
1220         ((eq tx '$nary)
1221          (putprop e 'tex-nary 'tex)
1222          (when (null (get e 'grind))
1223            (putprop e 180 'tex-lbp)
1224            (putprop e 180 'tex-rbp))
1225          (putprop e s 'texsym)
1226          (when (get e 'texword) (putprop e (nth 0 s) 'texword))
1227          (car s))
1228
1229         ((eq tx '$postfix)
1230          (putprop e 'tex-postfix 'tex)
1231          (when (null (get e 'grind))
1232            (putprop e 180 'tex-lbp))
1233          (putprop e  s 'texsym)
1234          (when (get e 'texword) (putprop e (nth 0 s) 'texword))
1235          (car s))))