1
;; This is mostly from texmacs-maxima-5.9.2.lisp
2
;; Small changes to mactex.lisp for interfacing with TeXmacs
3
;; Andrey Grozin, 2001-2005
4
8
(special lop rop $gcprint $inchar)
5
9
(*expr tex-lbp tex-rbp))
9
(STRIPDOLLAR $INCHAR) $LINENUM))
11
;(DEFUN BREAK-PROMPT ()
12
; (declare (special $prompt))
13
; (format nil "~A" (STRIPDOLLAR $PROMPT)))
15
(defun break-dbm-loop (at)
17
(*quit-tags* (cons (cons *break-level* *quit-tag*) *quit-tags*))
18
(*break-level* (if (not at) *break-level* (cons t *break-level*)))
19
(*quit-tag* (cons nil nil))
20
(*break-env* *break-env*)
23
(*diff-mspeclist* nil)
26
(declare (special *mread-prompt* ))
27
(and (consp at) (set-env at))
35
"~&~@[(~a:~a) ~]" (unless (stringp at) "dbm")
39
(let ((res (dbm-read *debug-io* nil *top-eof* t)))
40
(declare (special *mread-prompt*))
41
(cond ((and (consp res) (keywordp (car res)))
42
(let ((value (break-call (car res)
43
(cdr res) 'break-command)))
44
(cond ((eq value :resume) (return)))
47
(setq $__ (nth 2 res))
48
(setq $% (meval* $__))
60
;(setq $display2d 'true)
63
;; (c) copyright 1987, Richard J. Fateman
64
;; Small changes for interfacing with TeXmacs: Andrey Grozin, 2001
65
;; Yet more small changes for interfacing with imaxima: Jesper Harder 2001
66
;; Even more small changes for emaxima: Jay Belanger 2003
69
(defun tex (x l r lop rop)
70
;; x is the expression of interest; l is the list of strings to its
71
;; left, r to its right. lop and rop are the operators on the left
72
;; and right of x in the tree, and will determine if parens must
75
(cond ((atom x) (tex-atom x l r))
76
((or (<= (tex-lbp (caar x)) (tex-rbp lop)) (> (tex-lbp rop) (tex-rbp (caar x))))
78
;; special check needed because macsyma notates arrays peculiarly
79
((memq 'array (cdar x)) (tex-array x l r))
80
;; dispatch for object-oriented tex-ifiying
81
((get (caar x) 'tex) (funcall (get (caar x) 'tex) x l r))
82
(t (tex-function x l r nil))))
84
(defun tex-atom (x l r) ;; atoms: note: can we lose by leaving out {}s ?
86
(list (cond ((numberp x) (texnumformat x))
87
((and (symbolp x) (get x 'texword)))
88
((stringp x) (texstring x))
89
((characterp x) (texchar x))
90
(t (tex-stripdollar x))))
95
(cond ((equal x "") "")
96
((eql (elt x 0) #\\) x)
97
;; (t (concatenate 'string "\\mbox{{}" x "{}}")))) ;; jah:
98
(t (concatenate 'string "\\verb| " x " |"))))
101
(if (eql x #\|) "\\verb/|/"
102
(concatenate 'string "\\verb|" (string x) "|"))) ;; jah: \mbox{\verb} is illegal
105
(let ((var "") (charlist
106
'((#\{ . "\\left\\{\\right.")
107
(#\} . "\\left\\}\\right.")
113
(dotimes (i (length str))
114
(let ((chari (elt str i)))
115
(setq var (concatenate 'string var
116
(or (cdr (assoc chari charlist))
13
(print-invert-case (stripdollar $inchar)) $linenum))
120
15
(defun tex-stripdollar (sym)
121
16
(or (symbolp sym) (return-from tex-stripdollar sym))
122
(let* ((name (symbol-name sym))
123
(pname (if (memq (elt name 0) '(#\$ #\&)) (subseq name 1) name))
126
((eql l 1) (myquote pname))
127
(t (concatenate 'string "\\mathrm{" (myquote pname) "}")))))
129
(defun strcat (&rest args)
130
(apply #'concatenate 'string (mapcar #'string args)))
132
;; 10/14/87 RJF convert 1.2e20 to 1.2 \cdot 10^{20}
133
;; 03/30/01 RLT make that 1.2 \times 10^{20}
134
(defun texnumformat(atom)
135
(let (r firstpart exponent)
136
(cond ((integerp atom)
139
(setq r (explode atom))
140
(setq exponent (member 'e r :test #'string-equal));; is it ddd.ddde+EE
141
(cond ((null exponent)
142
;; it is not. go with it as given
146
(nreverse (cdr (member 'e (reverse r) :test #'string-equal))))
147
(strcat (apply #'strcat firstpart )
149
(apply #'strcat (cdr exponent))
152
(defun tex-paren (x l r)
153
(tex x (append l '("\\left(")) (cons "\\right)" r) 'mparen 'mparen))
155
(defun tex-array (x l r)
157
(if (eq 'mqapply (caar x))
162
;; subscript is an atom -- don't use \isubscript
164
(setq l (tex (texword f) l nil lop 'mfunction)
165
r (nconc (tex-list (cdr x) nil (list "}") ",") r))
166
(nconc l (list "_{") r))
167
(setq l (tex (texword f) (append l (list "\\isubscript{")) nil lop 'mfunction)
168
r (nconc (tex-list (cdr x) nil (list "}") ",") r))
169
(nconc l (list "}{") r ))))
171
;; we could patch this so sin x rather than sin(x), but instead we made sin a prefix
174
(defun tex-function (x l r op) op
175
(setq l (tex (texword (caar x)) l nil 'mparen 'mparen)
176
r (tex (cons '(mprogn) (cdr x)) nil r 'mparen 'mparen))
179
;; set up a list , separated by symbols (, * ...) and then tack on the
180
;; ending item (e.g. "]" or perhaps ")"
182
(defun tex-list (x l r sym)
186
(setq nl (nconc nl (tex (car x) l r 'mparen 'mparen)))
188
;; (setq nl (nconc nl (tex (car x) l (list sym) 'mparen 'mparen))
189
(setq nl (nconc nl (tex (car x) l (list (concatenate 'string sym "\\linebreak[0]")) 'mparen 'mparen))
193
(defun tex-prefix (x l r)
194
(tex (cadr x) (append l (texsym (caar x))) r (caar x) rop))
196
(defun tex-infix (x l r)
198
(if (or (null (cddr x)) (cdddr x)) (wna-err (caar x)))
199
(setq l (tex (cadr x) l nil lop (caar x)))
200
(tex (caddr x) (append l (texsym (caar x))) r (caar x) rop))
202
(defun tex-postfix (x l r)
203
(tex (cadr x) l (append (texsym (caar x)) r) lop (caar x)))
205
(defun tex-nary (x l r)
206
(let* ((op (caar x)) (sym (texsym op)) (y (cdr x)) (ext-lop lop) (ext-rop rop))
207
(cond ((null y) (tex-function x l r t)) ; this should not happen
208
((null (cdr y)) (tex-function x l r t)) ; this should not happen, too
209
(t (do ((nl) (lop ext-lop op) (rop op (if (null (cdr y)) ext-rop op)))
210
((null (cdr y)) (setq nl (nconc nl (tex (car y) l r lop rop))) nl)
211
(setq nl (nconc nl (tex (car y) l (list sym) lop rop))
215
(defun tex-nofix (x l r) (tex (caar x) l r (caar x) rop))
217
(defun tex-matchfix (x l r)
218
(setq l (append l (car (texsym (caar x))))
219
;; car of texsym of a matchfix operator is the lead op
220
r (append (cdr (texsym (caar x))) r)
221
;; cdr is the trailing op
222
x (tex-list (cdr x) nil r ","))
225
(defun texsym (x) (or (get x 'texsym) (get x 'strsym)(get x 'dissym)
228
(defun texword (x)(or (get x 'texword) (stripdollar x)))
230
(defprop bigfloat tex-bigfloat tex)
232
(defun tex-bigfloat (x l r) (fpformat x))
234
(defprop mprog "\\mathbf{block}\\;" texword)
235
(defprop %erf "\\mathrm{erf}" texword)
236
(defprop $erf "\\mathrm{erf}" texword) ;; etc for multicharacter names
237
(defprop $true "\\mathbf{true}" texword)
238
(defprop $false "\\mathbf{false}" texword)
240
(defprop mprogn tex-matchfix tex) ;; mprogn is (<progstmnt>, ...)
241
(defprop mprogn (("\\left(") "\\right)") texsym)
243
(defprop mlist tex-matchfix tex)
244
(defprop mlist (("\\left[ ")" \\right] ") texsym)
247
(defprop mabs tex-matchfix tex)
248
(defprop mabs (("\\left| ")"\\right| ") texsym)
250
(defprop mqapply tex-mqapply tex)
252
(defun tex-mqapply (x l r)
253
(setq l (tex (cadr x) l (list "(" ) lop 'mfunction)
254
r (tex-list (cddr x) nil (cons ")" r) ","))
255
(append l r));; fixed 9/24/87 RJF
257
(defprop $%i "i" texword)
258
(defprop $%pi "\\pi" texword)
259
(defprop $%e "e" texword)
260
(defprop $inf "\\infty " texword)
261
(defprop $minf " -\\infty " texword)
262
(defprop %laplace "\\mathcal{L}" texword) ;; jah
263
(defprop $alpha "\\alpha" texword)
264
(defprop $beta "\\beta" texword)
265
(defprop $gamma "\\gamma" texword)
266
(defprop %gamma "\\Gamma" texword)
267
(defprop $%gamma "\\gamma" texword)
268
(defprop $delta "\\delta" texword)
269
(defprop $epsilon "\\varepsilon" texword)
270
(defprop $zeta "\\zeta" texword)
271
(defprop $eta "\\eta" texword)
272
(defprop $theta "\\vartheta" texword)
273
(defprop $iota "\\iota" texword)
274
(defprop $kappa "\\varkappa" texword)
275
;(defprop $lambda "\\lambda" texword)
276
(defprop $mu "\\mu" texword)
277
(defprop $nu "\\nu" texword)
278
(defprop $xi "\\xi" texword)
279
(defprop $pi "\\pi" texword)
280
(defprop $rho "\\rho" texword)
281
(defprop $sigma "\\sigma" texword)
282
(defprop $tau "\\tau" texword)
283
(defprop $upsilon "\\upsilon" texword)
284
(defprop $phi "\\varphi" texword)
285
(defprop $chi "\\chi" texword)
286
(defprop $psi "\\psi" texword)
287
(defprop $omega "\\omega" texword)
289
(defprop mquote tex-prefix tex)
290
(defprop mquote ("'") texsym)
291
(defprop mquote 201. tex-rbp)
293
(defprop msetq tex-infix tex)
294
(defprop msetq (":") texsym)
295
(defprop msetq 180. tex-rbp)
296
(defprop msetq 20. tex-rbp)
298
(defprop mset tex-infix tex)
299
(defprop mset ("::") texsym)
300
(defprop mset 180. tex-lbp)
301
(defprop mset 20. tex-rbp)
303
(defprop mdefine tex-infix tex)
304
(defprop mdefine (":=") texsym)
305
(defprop mdefine 180. tex-lbp)
306
(defprop mdefine 20. tex-rbp)
308
(defprop mdefmacro tex-infix tex)
309
(defprop mdefmacro ("::=") texsym)
310
(defprop mdefmacro 180. tex-lbp)
311
(defprop mdefmacro 20. tex-rbp)
313
(defprop marrow tex-infix tex)
314
(defprop marrow ("\\rightarrow ") texsym)
315
(defprop marrow 25 tex-lbp)
316
(defprop marrow 25 tex-rbp)
318
(defprop mfactorial tex-postfix tex)
319
(defprop mfactorial ("!") texsym)
320
(defprop mfactorial 160. tex-lbp)
322
(defprop mexpt tex-mexpt tex)
323
(defprop mexpt 140. tex-lbp)
324
(defprop mexpt 139. tex-rbp)
326
;; insert left-angle-brackets for mncexpt. a^<n> is how a^^n looks.
17
(let* ((name (quote-% (print-invert-case sym)))
18
(name1 (if (memq (elt name 0) '(#\$ #\&)) (subseq name 1) name))
20
(if (eql l 1) name1 (concatenate 'string "\\mathrm{" name1 "}"))))
23
;; Also, we should output f(x)^2, not f^2(x)
327
25
(defun tex-mexpt (x l r)
328
(let((nc (eq (caar x) 'mncexpt))); true if a^^b rather than a^b
329
;; here is where we have to check for f(x)^b to be displayed
330
;; as f^b(x), as is the case for sin(x)^2 .
331
;; which should be sin^2 x rather than (sin x)^2 or (sin(x))^2.
332
;; yet we must not display (a+b)^2 as +^2(a,b)...
333
;; or (sin(x))^(-1) as sin^(-1)x, which would be arcsine x
334
(cond ;; this whole clause
335
;; should be deleted if this hack is unwanted and/or the
336
;; time it takes is of concern.
337
;; it shouldn't be too expensive.
338
((and (eq (caar x) 'mexpt) ; don't do this hack for mncexpt
340
((fx (cadr x)); this is f(x)
341
(f (and (not (atom fx)) (atom (caar fx)) (caar fx))) ; this is f [or nil]
342
(bascdr (and f (cdr fx))) ; this is (x) [maybe (x,y..), or nil]
343
(expon (caddr x)) ;; this is the exponent
345
f ; there is such a function
346
(memq (getchar f 1) '(% $)) ;; insist it is a % or $ function
347
(not (memq f '(%sum %lsum %product %derivative
348
%integrate %limit))) ;; what else? what a hack...
349
(or (and (atom expon) (not (numberp expon))) ; f(x)^y is ok
350
(and (atom expon) (numberp expon) (> expon 0))))))
351
; f(x)^3 is ok, but not f(x)^-1, which could
352
; inverse of f, if written f^-1 x
353
; what else? f(x)^(1/2) is sqrt(f(x)), ??
355
(setq l (append (tex f l nil lop 'mexpt)
356
(tex expon (list "^{")
357
(cons " }" nil) 'mparen 'mparen)))
358
(if (and (null (cdr bascdr))
359
(eq (get f 'tex) 'tex-prefix))
360
(setq r (tex (car bascdr) nil r f 'mparen))
361
(setq r (tex (cons '(mprogn) bascdr) nil r 'mparen 'mparen)))
363
(t nil))))) ; won't doit. fall through
366
;; Don't use \iexpt when exponent is an atom
368
(setq l (tex (cadr x) l nil lop (caar x))
369
r (if (mmminusp (setq x (nformat (caddr x))))
370
;; the change in base-line makes parens unnecessary
372
(tex (cadr x) '("^ {-\\langle ")(cons "\\rangle }" r) 'mparen 'mparen)
373
(tex (cadr x) '("^ {- ")(cons " }" r) 'mparen 'mparen))
375
(tex x (list "^{\\langle ")(cons "\\rangle}" r) 'mparen 'mparen)
376
(tex x (list "^{")(cons "}" r) 'mparen 'mparen))))
378
(setq l (tex (cadr x) (append l (list "\\iexpt{")) nil lop (caar x))
379
r (if (mmminusp (setq x (nformat (caddr x))))
380
;; the change in base-line makes parens unnecessary
382
(tex (cadr x) '("{-\\langle ")(cons "\\rangle }" r) 'mparen 'mparen)
383
(tex (cadr x) '("{- ")(cons " }" r) 'mparen 'mparen))
385
(tex x (list "{\\langle ")(cons "\\rangle}" r) 'mparen 'mparen)
386
(tex x (list "{") (cons "}" r) 'mparen 'mparen))))
387
(append l (list "}") r))))))
389
(defprop mncexpt tex-mexpt tex)
391
(defprop mncexpt 135. tex-lbp)
392
(defprop mncexpt 134. tex-rbp)
394
(defprop mnctimes tex-nary tex)
395
(defprop mnctimes "\\cdot " texsym)
396
(defprop mnctimes 110. tex-lbp)
397
(defprop mnctimes 109. tex-rbp)
399
(defprop mtimes tex-nary tex)
400
(defprop mtimes "\\*" texsym)
401
(defprop mtimes 120. tex-lbp)
402
(defprop mtimes 120. tex-rbp)
404
(defprop %sqrt tex-sqrt tex)
406
(defun tex-sqrt(x l r)
407
;; format as \\sqrt { } assuming implicit parens for sqr grouping
408
(tex (cadr x) (append l '("\\sqrt{")) (append '("}") r) 'mparen 'mparen))
410
;; macsyma doesn't know about cube (or nth) roots,
411
;; but if it did, this is what it would look like.
412
(defprop $cubrt tex-cubrt tex)
414
(defun tex-cubrt (x l r)
415
(tex (cadr x) (append l '("\\root 3 \\of{")) (append '("}") r) 'mparen 'mparen))
417
(defprop mquotient tex-mquotient tex)
418
(defprop mquotient ("\\over") texsym)
419
(defprop mquotient 122. tex-lbp) ;;dunno about this
420
(defprop mquotient 123. tex-rbp)
422
(defun tex-mquotient (x l r)
423
(if (or (null (cddr x)) (cdddr x)) (wna-err (caar x)))
424
(cond ((and (atom (cadr x)) (atom (caddr x)))
425
;; both denom and numerator are atoms
426
(setq l (tex (cadr x) (append l '("\\frac{")) nil nil nil) ;;fixme
427
r (tex (caddr x) (list "}{") (append '("}")r) 'mparen 'mparen)))
429
;; numerator is an atom
430
(setq l (tex (cadr x) (append l '("\\frac{")) nil 'mparen 'mparen)
431
r (tex (caddr x) (list "}{") (append '("}")r) 'mparen 'mparen)))
434
(setq l (tex (cadr x) (append l '("\\frac{")) nil 'mparen 'mparen)
435
r (tex (caddr x) (list "}{") (append '("}")r) 'mparen 'mparen)))
438
(setq l (tex (cadr x) (append l '("\\frac{")) nil 'mparen 'mparen)
439
r (tex (caddr x) (list "}{") (append '("}")r) 'mparen 'mparen))))
442
(defprop $matrix tex-matrix tex)
444
(defun tex-matrix(x l r) ;;matrix looks like ((mmatrix)((mlist) a b) ...)
445
(append l `("\\pmatrix{")
447
(tex-list (cdr y) nil (list "\\cr ") "&"))
451
;; macsyma sum or prod is over integer range, not low <= index <= high
452
;; TeX is lots more flexible .. but
454
(defprop %sum tex-sum tex)
455
(defprop %lsum tex-lsum tex)
456
(defprop %product tex-sum tex)
458
;; easily extended to union, intersect, otherops
460
(defun tex-lsum(x l r)
461
(let ((op (cond ((eq (caar x) '%lsum) "\\sum_{")
464
;; gotta be one of those above
465
(s1 (tex (cadr x) nil nil 'mparen rop));; summand
466
(index ;; "index = lowerlimit"
467
(tex `((min simp) , (caddr x), (cadddr x)) nil nil 'mparen 'mparen)))
468
(append l `( ,op ,@index "}}{" ,@s1 "}") r)))
470
(defun tex-sum(x l r)
471
(let ((op (cond ((eq (caar x) '%sum) "\\sum_{")
472
((eq (caar x) '%product) "\\prod_{")
475
;; gotta be one of those above
476
(s1 (tex (cadr x) nil nil 'mparen rop));; summand
477
(index ;; "index = lowerlimit"
478
(tex `((mequal simp) ,(caddr x),(cadddr x)) nil nil 'mparen 'mparen))
479
(toplim (tex (car(cddddr x)) nil nil 'mparen 'mparen)))
480
(append l `( ,op ,@index "}^{" ,@toplim "}{" ,@s1 "}") r)))
482
(defprop %integrate tex-int tex)
483
(defun tex-int (x l r)
484
(let ((s1 (tex (cadr x) nil nil 'mparen 'mparen));;integrand delims / & d
485
(var (tex (caddr x) nil nil 'mparen rop))) ;; variable
486
(cond((= (length x) 3)
487
(append l `("\\int {" ,@s1 "}{\\;d" ,@var "}") r))
488
(t ;; presumably length 5
489
(let ((low (tex (nth 3 x) nil nil 'mparen 'mparen))
491
(hi (tex (nth 4 x) nil nil 'mparen 'mparen)))
492
(append l `("\\int_{" ,@low "}^{" ,@hi "}{" ,@s1 "\\;d" ,@var "}") r))))))
494
(defprop %limit tex-limit tex)
496
(defun tex-limit(x l r) ;; ignoring direction, last optional arg to limit
497
(let ((s1 (tex (cadr x) nil nil 'mparen rop));; limitfunction
498
(subfun ;; the thing underneath "limit"
499
(subst "\\rightarrow " '=
500
(tex `((mequal simp) ,(caddr x),(cadddr x))
501
nil nil 'mparen 'mparen))))
502
(append l `("\\lim_{" ,@subfun "}{" ,@s1 "}") r)))
504
(defprop %at tex-at tex)
506
;; e.g. at(diff(f(x)),x=a)
507
(defun tex-at (x l r)
508
(let ((s1 (tex (cadr x) nil nil lop rop))
509
(sub (tex (caddr x) nil nil 'mparen 'mparen)))
510
(append l '("\\left.") s1 '("\\right|_{") sub '("}") r)))
512
(defprop mbox tex-mbox tex)
514
(defun tex-mbox (x l r)
515
(append l '("\\boxed{") (tex (cadr x) nil nil 'mparen 'mparen) '("}") r))
517
(defprop mlabox tex-mlabox tex)
519
(defun tex-mlabox (x l r)
520
(append l '("\\stackrel{") (tex (caddr x) nil nil 'mparen 'mparen)
521
'("}{\\boxed{") (tex (cadr x) nil nil 'mparen 'mparen) '("}}") r)) ; jh
523
;;binomial coefficients
525
(defprop %binomial tex-choose tex)
26
(let((nc (eq (caar x) 'mncexpt))) ; true if a^^b rather than a^b
27
(setq l (if (and (numberp (cadr x)) (numneedsparen (cadr x)))
28
(tex (cadr x) (cons "\\left(" l) '("\\right)") lop (caar x))
29
(tex (cadr x) l nil lop (caar x)))
30
r (if (mmminusp (setq x (nformat (caddr x))))
31
;; the change in base-line makes parens unnecessary
33
(tex (cadr x) '("^ {-\\langle ")(cons "\\rangle }" r) 'mparen 'mparen)
34
(tex (cadr x) '("^ {- ")(cons " }" r) 'mparen 'mparen))
36
(tex x (list "^{\\langle ")(cons "\\rangle}" r) 'mparen 'mparen)
37
(if (and (integerp x) (< x 10))
38
(tex x (list "^")(cons "" r) 'mparen 'mparen)
39
(tex x (list "^{")(cons "}" r) 'mparen 'mparen)))))
42
;; binomial coefficients
527
44
(defun tex-choose (x l r)
530
47
,@(tex (cadr x) nil nil 'mparen 'mparen)
532
49
,@(tex (caddr x) nil nil 'mparen 'mparen)
537
(defprop rat tex-rat tex)
538
(defprop rat 120. tex-lbp)
539
(defprop rat 121. tex-rbp)
540
(defun tex-rat(x l r) (tex-mquotient x l r))
542
(defprop mplus tex-mplus tex)
543
(defprop mplus 100. tex-lbp)
544
(defprop mplus 100. tex-rbp)
546
(defun tex-mplus (x l r)
547
;(declare (fixnum w))
548
(cond ((memq 'trunc (car x))(setq r (cons "+\\cdots " r))))
549
(cond ((null (cddr x))
551
(tex-function x l r t)
552
(tex (cadr x) (cons "+" l) r 'mplus rop)))
553
(t (setq l (tex (cadr x) l nil lop 'mplus)
555
(do ((nl l) (dissym))
557
(if (mmminusp (car x)) (setq l (cadar x) dissym (list "-"))
558
(setq l (car x) dissym (list "+")))
559
(setq r (tex l dissym r 'mplus rop))
561
(if (mmminusp (car x)) (setq l (cadar x) dissym (list "-"))
562
(setq l (car x) dissym (list "+")))
563
(setq nl (append nl (tex l dissym nil 'mplus 'mplus))
566
(defprop mminus tex-prefix tex)
567
(defprop mminus ("-") texsym)
568
(defprop mminus 100. tex-rbp)
569
(defprop mminus 100. tex-lbp)
571
(defprop min tex-infix tex)
572
(defprop min ("\\in{") texsym)
573
(defprop min 80. tex-lbp)
574
(defprop min 80. tex-rbp)
576
(defprop mequal tex-infix tex)
577
(defprop mequal (=) texsym)
578
(defprop mequal 80. tex-lbp)
579
(defprop mequal 80. tex-rbp)
581
(defprop mnotequal tex-infix tex)
582
(defprop mnotequal 80. tex-lbp)
583
(defprop mnotequal 80. tex-rbp)
585
(defprop mgreaterp tex-infix tex)
586
(defprop mgreaterp (>) texsym)
587
(defprop mgreaterp 80. tex-lbp)
588
(defprop mgreaterp 80. tex-rbp)
590
(defprop mgeqp tex-infix tex)
591
(defprop mgeqp ("\\geq") texsym)
592
(defprop mgeqp 80. tex-lbp)
593
(defprop mgeqp 80. tex-rbp)
595
(defprop mlessp tex-infix tex)
596
(defprop mlessp (<) texsym)
597
(defprop mlessp 80. tex-lbp)
598
(defprop mlessp 80. tex-rbp)
600
(defprop mleqp tex-infix tex)
601
(defprop mleqp ("\\leq") texsym)
602
(defprop mleqp 80. tex-lbp)
603
(defprop mleqp 80. tex-rbp)
605
(defprop mnot tex-prefix tex)
606
(defprop mnot ("\\not ") texsym)
607
(defprop mnot 70. tex-rbp)
609
(defprop mand tex-nary tex)
610
(defprop mand ("\\and") texsym)
611
(defprop mand 60. tex-lbp)
612
(defprop mand 60. tex-rbp)
614
(defprop mor tex-nary tex)
615
(defprop mor ("\\or") texsym)
617
;; make sin(x) display as sin x , but sin(x+y) as sin(x+y)
623
(setf (get a 'tex) 'tex-prefix)
624
(setf (get a 'texword) b) ;This means "sin" will always be roman
625
(setf (get a 'texsym) (list b))
626
(setf (get a 'tex-rbp) 130)))
638
(%acot "\\operatorname{arccot}")
639
(%asec "\\operatorname{arcsec}")
640
(%acsc "\\operatorname{arccsc}")
645
(%sech "\\operatorname{sech}")
646
(%csch "\\operatorname{csch}")
647
(%asinh "\\operatorname{arcsinh}")
648
(%acosh "\\operatorname{arccosh}")
649
(%atanh "\\operatorname{arctanh}")
650
(%acoth "\\operatorname{arccoth}")
651
(%asech "\\operatorname{arcsech}")
652
(%acsch "\\operatorname{arccsch}")
653
(%determinant "\\det ")
656
;; (%erf "{\\rm erf}") this would tend to set erf(x) as erf x. Unusual
657
;(%laplace "{\\cal L}")
660
(defprop mor tex-nary tex)
661
(defprop mor 50. tex-lbp)
662
(defprop mor 50. tex-rbp)
664
(defprop mcond tex-mcond tex)
665
(defprop mcond 25. tex-lbp)
666
(defprop mcond 25. tex-rbp)
667
(defprop %derivative tex-derivative tex)
668
(defun tex-derivative (x l r)
669
(tex (tex-d x '$|d|) l r lop rop ))
671
(defun tex-d(x dsym) ;dsym should be $d or "$d\\partial"
672
;; format the macsyma derivative form so it looks
673
;; sort of like a quotient times the deriva-dand.
675
((arg (cadr x)) ;; the function being differentiated
676
(difflist (cddr x)) ;; list of derivs e.g. (x 1 y 2)
677
(ords (odds difflist 0)) ;; e.g. (1 2)
678
(vars (odds difflist 1)) ;; e.g. (x y)
679
(numer `((mexpt) ,dsym ((mplus) ,@ords))) ; d^n numerator
680
(denom (cons '(mtimes)
681
(mapcan #'(lambda(b e)
682
`(,dsym ,(simplifya `((mexpt) ,b ,e) nil)))
685
((mquotient) ,(simplifya numer nil) ,denom)
689
;; if c=1, get the odd terms (first, third...)
691
((= c 1)(cons (car n)(odds (cdr n) 0)))
692
((= c 0)(odds (cdr n) 1))))
694
(defun tex-mcond (x l r)
696
(tex (cadr x) '("\\mathbf{if}\\;")
697
'("\\;\\mathbf{then}\\;") 'mparen 'mparen)
698
(if (eql (fifth x) '$false)
699
(tex (caddr x) nil r 'mcond rop)
700
(append (tex (caddr x) nil nil 'mparen 'mparen)
701
(tex (fifth x) '("\\;\\mathbf{else}\\;") r 'mcond rop)))))
703
(defprop mdo tex-mdo tex)
704
(defprop mdo 30. tex-lbp)
705
(defprop mdo 30. tex-rbp)
706
(defprop mdoin tex-mdoin tex)
707
(defprop mdoin 30. tex-rbp)
709
(defun tex-lbp(x)(cond((get x 'tex-lbp))(t(lbp x))))
710
(defun tex-rbp(x)(cond((get x 'tex-rbp))(t(lbp x))))
712
;; these aren't quite right
714
(defun tex-mdo (x l r)
715
(tex-list (texmdo x) l r "\\;"))
717
(defun tex-mdoin (x l r)
718
(tex-list (texmdoin x) l r "\\;"))
721
(nconc (cond ((second x) `("\\mathbf{for}" ,(second x))))
722
(cond ((equal 1 (third x)) nil)
723
((third x) `("\\mathbf{from}" ,(third x))))
724
(cond ((equal 1 (fourth x)) nil)
725
((fourth x) `("\\mathbf{step}" ,(fourth x)))
726
((fifth x) `("\\mathbf{next}" ,(fifth x))))
727
(cond ((sixth x) `("\\mathbf{thru}" ,(sixth x))))
728
(cond ((null (seventh x)) nil)
729
((eq 'mnot (caar (seventh x)))
730
`("\\mathbf{while}" ,(cadr (seventh x))))
731
(t `("\\mathbf{unless}" ,(seventh x))))
732
`("\\mathbf{do}" ,(eighth x))))
735
(nconc `("\\mathbf{for}" ,(second x) "\\mathbf{in}" ,(third x))
736
(cond ((sixth x) `("\\mathbf{thru}" ,(sixth x))))
737
(cond ((null (seventh x)) nil)
738
((eq 'mnot (caar (seventh x)))
739
`("\\mathbf{while}" ,(cadr (seventh x))))
740
(t `("\\mathbf{unless}" ,(seventh x))))
741
`("\\mathbf{do}" ,(eighth x))))
744
;; Undone and trickier:
745
;; handle reserved symbols stuff, just in case someone
746
;; has a macsyma variable named (yuck!!) \over or has a name with
748
;; Maybe do some special hacking for standard notations for
749
;; hypergeometric fns, alternative summation notations 0<=n<=inf, etc.
751
;;Undone and really pretty hard: line breaking
753
(defprop mtext tex-mtext tex)
754
(defprop text-string tex-mtext tex)
755
(defprop mlable tex-mlable tex)
756
(defprop spaceout tex-spaceout tex)
758
(defun tex-mtext (x l r) (tex-list (cdr x) l r ""))
53
;; Integrals, sums, products
55
(defun tex-int (x l r)
56
(let ((s1 (tex (cadr x) nil nil 'mparen 'mparen)) ;;integrand delims / & d
57
(var (tex (caddr x) nil nil 'mparen rop))) ;; variable
58
(cond((= (length x) 3)
59
(append l `("\\int {" ,@s1 "}{\\;d" ,@var "}\\big.") r))
60
(t ;; presumably length 5
61
(let ((low (tex (nth 3 x) nil nil 'mparen 'mparen))
63
(hi (tex (nth 4 x) nil nil 'mparen 'mparen)))
64
(append l `("\\int_{" ,@low "}^{" ,@hi "}{" ,@s1 "\\;d" ,@var "}\\big.") r))))))
67
(let ((op (cond ((eq (caar x) '%sum) "\\sum_{")
68
((eq (caar x) '%product) "\\prod_{")
71
;; gotta be one of those above
72
(s1 (tex (cadr x) nil nil 'mparen rop)) ;; summand
73
(index ;; "index = lowerlimit"
74
(tex `((mequal simp) ,(caddr x),(cadddr x)) nil nil 'mparen 'mparen))
75
(toplim (tex (car(cddddr x)) nil nil 'mparen 'mparen)))
76
(append l `( ,op ,@index "}^{" ,@toplim "}{" ,@s1 "}\\big.") r)))
78
(defun tex-lsum(x l r)
79
(let ((op (cond ((eq (caar x) '%lsum) "\\sum_{")
82
;; gotta be one of those above
83
(s1 (tex (cadr x) nil nil 'mparen rop)) ;; summand
84
(index ;; "index = lowerlimit"
85
(tex `((min simp) , (caddr x), (cadddr x)) nil nil 'mparen 'mparen)))
86
(append l `( ,op ,@index "}}{" ,@s1 "}\\big.") r)))
88
;; This is a hack for math input of integrals, sums, products
90
(defmfun $tmint (a b f x) ($integrate f x a b))
92
(defmspec $tmsum (l) (setq l (cdr l))
94
(dosum (caddr l) (cadar l) (meval (caddar l)) (meval (cadr l)) t)
97
(defmspec $tmlsum (l) (setq l (cdr l))
98
(or (= (length l) 2) (wna-err '$tmlsum))
101
(lis (meval (caddar l)))
103
(or (symbolp ind) (merror "Second argument not a variable ~M" ind))
105
(loop for v in (cdr lis)
106
with lind = (cons ind nil)
109
(setq ans (add* ans (mbinding (lind w) (meval form)))))
111
(t `((%lsum) ,form ,ind ,lis)))))
113
(defmspec $tmprod (l) (setq l (cdr l))
115
(dosum (caddr l) (cadar l) (meval (caddar l)) (meval (cadr l)) nil)
760
118
(defun tex-mlable (x l r)
764
(list (format nil "(~A) " (stripdollar (cadr x))))
122
(list (format nil "(~A) "
123
(print-invert-case (stripdollar (cadr x)))))
766
125
r 'mparen 'mparen))
768
(defun tex-spaceout (x l r)
769
(append l (list "\\verb|" (make-string (cadr x) :initial-element #\space) "|") r))
772
127
(defun qndispla (form)
773
128
(let (($display2d nil))
777
;; (princ x) ;; uncomment to debug.
779
133
(if (and (listp x) (cdr x)
780
134
(equal (string-right-trim '(#\Space) (cadr x)) "Is"))
781
(qndispla x) ;(tex x '("") '("") 'mparen 'mparen)
783
137
") 'mparen 'mparen))))
added
removed
interfaces/emacs/emaxima/emaxima.lisp
