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