5
(STRIPDOLLAR $INCHAR) $LINENUM))
7
;(DEFUN BREAK-PROMPT ()
8
; (declare (special $prompt))
9
; (format nil "~A" (STRIPDOLLAR $PROMPT)))
11
(DEFMFUN DISPLA (FORM &aux #+kcl(form form))
12
(IF (OR (NOT #.TTYOFF) #.WRITEFILEP)
13
(cond #+Franz ($typeset (apply #'$photot (list form)))
14
((eq $display2d '$texmacs) (latex form))
17
(LINEARRAY (IF DISPLAYP (MAKE-array 80.) LINEARRAY))
18
(MRATP (CHECKRAT FORM))
19
(#.WRITEFILEP #.WRITEFILEP)
20
(MAXHT 1) (MAXDP 0) (WIDTH 0)
21
(HEIGHT 0) (DEPTH 0) (LEVEL 0) (SIZE 2)
22
(BREAK 0) (RIGHT 0) (LINES 1) BKPT
23
(BKPTWD 0) (BKPTHT 1) (BKPTDP 0) (BKPTOUT 0)
25
(MOREFLUSH D-MOREFLUSH)
29
(PROGN (SETQ FORM (DIMENSION FORM
30
NIL 'MPAREN 'MPAREN 0 0))
31
(CHECKBREAK FORM WIDTH)
32
(OUTPUT FORM (IF (AND (NOT $LEFTJUST) (= 2 LINES))
33
(f- LINEL (f- WIDTH BKPTOUT))
35
(IF (AND SMART-TTY (NOT (AND SCROLLP (NOT $CURSORDISP)))
36
(> (CAR (CURSORPOS)) (f- TTYHEIGHT 3)))
37
(LET (#.writefilep) (MTERPRI))))
38
;; make sure the linearray gets cleared out.
40
(T (LINEAR-DISPLA FORM)))))
42
(defun break-dbm-loop (at)
44
(*quit-tags* (cons (cons *break-level* *quit-tag*) *quit-tags*))
45
(*break-level* (if (not at) *break-level* (cons t *break-level*)))
46
(*quit-tag* (cons nil nil))
47
(*break-env* *break-env*)
50
(*diff-mspeclist* nil)
53
(declare (special *mread-prompt* ))
54
(and (consp at) (set-env at))
62
"~@[(~a:~a) ~]" (unless (stringp at) "dbm")
66
(let ((res (dbm-read *debug-io* nil *top-eof* t)))
67
(declare (special *mread-prompt*))
68
(cond ((and (consp res) (keywordp (car res)))
69
(let ((value (break-call (car res)
70
(cdr res) 'break-command)))
71
(cond ((eq value :resume) (return)))
74
(setq $__ (nth 2 res))
75
(setq $% (meval* $__))
87
(DEFMFUN $ENTERMATRIX (ROWS COLUMNS)
88
(PROG (ROW COLUMN VECTOR MATRIX SYM SYMVECTOR)
89
(COND ((OR (NOT (FIXNUMP ROWS))
90
(NOT (FIXNUMP COLUMNS)))
91
(MERROR "ENTERMATRIX called with non-integer arguments")))
93
(COND ((NOT (= ROWS COLUMNS)) (SETQ SYM NIL) (GO OLOOP)))
94
QUEST(PRINC "Is the matrix 1. Diagonal 2. Symmetric 3. Antisymmetric 4. General
95
Answer 1, 2, 3 or 4 : ") (SETQ SYM (RETRIEVE NIL NIL))
96
(COND ((NOT (zl-MEMBER SYM '(1 2 3 4))) (GO QUEST)))
97
OLOOP(COND ((> (SETQ ROW (f1+ ROW)) ROWS)
98
(format t "~%Matrix entered.~%")
99
(RETURN (CONS '($MATRIX) (MXC MATRIX)))))
102
(PRINC "Row ") (PRINC ROW) (PRINC " Column ")
103
(PRINC COLUMN) (PRINC ": ")
106
(NCONS (ONEN ROW COLUMNS (MEVAL (RETRIEVE NIL NIL)) 0))))
109
(SETQ COLUMN (f1- ROW))
110
(COND ((EQUAL ROW 1) (GO ILOOP)))
112
(CONS (NTHCDR COLUMN VECTOR) SYMVECTOR)
113
VECTOR (NREVERSE (MAPCAR 'CAR SYMVECTOR))
114
SYMVECTOR (MAPCAR 'CDR SYMVECTOR))
118
(COND ((EQUAL ROW 1) (SETQ VECTOR (NCONS 0)) (GO ILOOP)))
121
(NTHCDR (f1- COLUMN) VECTOR))
123
VECTOR (NRECONC (MAPCAR 'CAR SYMVECTOR) (NCONS 0))
124
SYMVECTOR (MAPCAR 'CDR SYMVECTOR))
126
(SETQ COLUMN 0 VECTOR NIL)
127
ILOOP(COND ((> (SETQ COLUMN (f1+ COLUMN)) COLUMNS)
128
(SETQ MATRIX (NCONC MATRIX (NCONS VECTOR)))
130
(PRINC "Row ") (PRINC ROW) (PRINC " Column ")
131
(PRINC COLUMN) (PRINC ": ")
132
(SETQ VECTOR (NCONC VECTOR (NCONS (MEVAL (RETRIEVE NIL NIL)))))
135
(setq $display2d '$texmacs)
138
;; (c) copyright 1987, Richard J. Fateman
139
;; Small changes for interfacing with TeXmacs: Andrey Grozin, 2001
142
(special lop rop ccol $gcprint $inchar)
143
(*expr tex-lbp tex-rbp))
144
(defconstant texport t)
146
;;; myprinc is an intelligent low level printing routine. it keeps track of
147
;;; the size of the output for purposes of allowing the TeX file to
148
;;; have a reasonable line-line. myprinc will break it at a space
149
;;; once it crosses a threshold.
150
;;; this has nothign to do with breaking the resulting equations.
152
;- arg: chstr - string or number to princ
153
;- scheme: This function keeps track of the current location
154
;- on the line of the cursor and makes sure
155
;- that a value is all printed on one line (and not divided
156
;- by the crazy top level os routines)
158
(defun myprinc (chstr)
160
(cond ((greaterp (plus (length (setq chlst (exploden chstr)))
163
(terpri texport) ;would have exceeded the line length
165
(myprinc " ") ; lead off with a space for safety
166
)) ;so we split it up.
167
(do ((ch chlst (cdr ch))
168
(colc ccol (add1 colc)))
169
((null ch) (setq ccol colc))
170
(tyo (car ch) texport))))
173
(cond (texport (terpri texport))
177
(defun tex (x l r lop rop)
178
;; x is the expression of interest; l is the list of strings to its
179
;; left, r to its right. lop and rop are the operators on the left
180
;; and right of x in the tree, and will determine if parens must
183
(cond ((atom x) (tex-atom x l r))
184
((or (<= (tex-lbp (caar x)) (tex-rbp lop)) (> (tex-lbp rop) (tex-rbp (caar x))))
186
;; special check needed because macsyma notates arrays peculiarly
187
((memq 'array (cdar x)) (tex-array x l r))
188
;; dispatch for object-oriented tex-ifiying
189
((get (caar x) 'tex) (funcall (get (caar x) 'tex) x l r))
190
(t (tex-function x l r nil))))
192
(defun tex-atom (x l r) ;; atoms: note: can we lose by leaving out {}s ?
194
(list (cond ((numberp x) (texnumformat x))
195
((and (symbolp x) (get x 'texword)))
196
((stringp x) (texstring x))
197
((characterp x) (texchar x))
198
(t (tex-stripdollar x))))
203
(cond ((equal x "") "")
204
((eql (elt x 0) #\\) x)
205
(t (concatenate 'string "\\mbox{{}" x "{}}"))))
208
(if (eql x #\|) "\\mbox{\\verb/|/}"
209
(concatenate 'string "\\mbox{\\verb|" (string x) "|}")))
211
(defun tex-stripdollar (sym)
212
(or (symbolp sym) (return-from tex-stripdollar sym))
213
(let* ((name (symbol-name sym))
214
(pname (if (memq (elt name 0) '(#\$ #\&)) (subseq name 1) name))
218
(t (concatenate 'string "\\mathrm{" pname "}")))))
220
(defun texnumformat(atom) ;; 10/14/87 RJF convert 1.2e20 to 1.2 \cdot 10^{20}
221
(let(r firstpart exponent)
222
(cond ((integerp atom)atom)
223
(t (setq r (explode atom))
224
(setq exponent (memq 'e r)) ;; is it ddd.ddde+EE
225
(cond ((null exponent) atom); it is not. go with it as given
226
(t (setq firstpart (nreverse (cdr (memq 'e (reverse r)))))
227
(strcat (apply #'strcat firstpart )
229
(apply #'strcat (cdr exponent))
232
(defun tex-paren (x l r)
233
(tex x (append l '("\\left(")) (cons "\\right)" r) 'mparen 'mparen))
235
(defun tex-array (x l r)
237
(if (eq 'mqapply (caar x))
241
(setq l (tex (texword f) l nil lop 'mfunction)
243
r (nconc (tex-list (cdr x) nil (list "}") ",") r))
244
(nconc l (list "_{") r )))
246
;; we could patch this so sin x rather than sin(x), but instead we made sin a prefix
249
(defun tex-function (x l r op) op
250
(setq l (tex (texword (caar x)) l nil 'mparen 'mparen)
251
r (tex (cons '(mprogn) (cdr x)) nil r 'mparen 'mparen))
254
;; set up a list , separated by symbols (, * ...) and then tack on the
255
;; ending item (e.g. "]" or perhaps ")"
257
(defun tex-list (x l r sym)
261
(setq nl (nconc nl (tex (car x) l r 'mparen 'mparen)))
263
(setq nl (nconc nl (tex (car x) l (list sym) 'mparen 'mparen))
267
(defun tex-prefix (x l r)
268
(tex (cadr x) (append l (texsym (caar x))) r (caar x) rop))
270
(defun tex-infix (x l r)
272
(if (or (null (cddr x)) (cdddr x)) (wna-err (caar x)))
273
(setq l (tex (cadr x) l nil lop (caar x)))
274
(tex (caddr x) (append l (texsym (caar x))) r (caar x) rop))
276
(defun tex-postfix (x l r)
277
(tex (cadr x) l (append (texsym (caar x)) r) lop (caar x)))
279
(defun tex-nary (x l r)
280
(let* ((op (caar x)) (sym (texsym op)) (y (cdr x)) (ext-lop lop) (ext-rop rop))
281
(cond ((null y) (tex-function x l r t)) ; this should not happen
282
((null (cdr y)) (tex-function x l r t)) ; this should not happen, too
283
(t (do ((nl) (lop ext-lop op) (rop op (if (null (cdr y)) ext-rop op)))
284
((null (cdr y)) (setq nl (nconc nl (tex (car y) l r lop rop))) nl)
285
(setq nl (nconc nl (tex (car y) l (list sym) lop rop))
289
(defun tex-nofix (x l r) (tex (caar x) l r (caar x) rop))
291
(defun tex-matchfix (x l r)
292
(setq l (append l (car (texsym (caar x))))
293
;; car of texsym of a matchfix operator is the lead op
294
r (append (cdr (texsym (caar x))) r)
295
;; cdr is the trailing op
296
x (tex-list (cdr x) nil r ","))
299
(defun texsym (x) (or (get x 'texsym) (get x 'strsym)(get x 'dissym)
302
(defun texword (x)(or (get x 'texword) (stripdollar x)))
304
(defprop bigfloat tex-bigfloat tex)
306
(defun tex-bigfloat (x l r) (fpformat x))
308
(defprop mprog "\\mathbf{block}\\;" texword)
309
(defprop %erf "\\mathrm{erf}" texword)
310
(defprop $erf "\\mathrm{erf}" texword) ;; etc for multicharacter names
311
(defprop $true "\\mathbf{true}" texword)
312
(defprop $false "\\mathbf{false}" texword)
314
(defprop mprogn tex-matchfix tex) ;; mprogn is (<progstmnt>, ...)
315
(defprop mprogn (("\\left(") "\\right)") texsym)
317
(defprop mlist tex-matchfix tex)
318
(defprop mlist (("\\left[ ")" \\right] ") texsym)
321
(defprop mabs tex-matchfix tex)
322
(defprop mabs (("\\left| ")"\\right| ") texsym)
324
(defprop mqapply tex-mqapply tex)
326
(defun tex-mqapply (x l r)
327
(setq l (tex (cadr x) l (list "(" ) lop 'mfunction)
328
r (tex-list (cddr x) nil (cons ")" r) ","))
329
(append l r));; fixed 9/24/87 RJF
331
(defprop $%i "i" texword)
332
(defprop $%pi "\\pi" texword)
333
(defprop $%e "e" texword)
334
(defprop $inf "\\infty " texword)
335
(defprop $minf " -\\infty " texword)
336
(defprop %laplace "{\\cal L}" texword)
337
(defprop $alpha "\\alpha" texword)
338
(defprop $beta "\\beta" texword)
339
(defprop $gamma "\\gamma" texword)
340
(defprop %gamma "\\Gamma" texword)
341
(defprop $%gamma "\\gamma" texword)
342
(defprop $delta "\\delta" texword)
343
(defprop $epsilon "\\varepsilon" texword)
344
(defprop $zeta "\\zeta" texword)
345
(defprop $eta "\\eta" texword)
346
(defprop $theta "\\vartheta" texword)
347
(defprop $iota "\\iota" texword)
348
(defprop $kappa "\\varkappa" texword)
349
;(defprop $lambda "\\lambda" texword)
350
(defprop $mu "\\mu" texword)
351
(defprop $nu "\\nu" texword)
352
(defprop $xi "\\xi" texword)
353
(defprop $pi "\\pi" texword)
354
(defprop $rho "\\rho" texword)
355
(defprop $sigma "\\sigma" texword)
356
(defprop $tau "\\tau" texword)
357
(defprop $upsilon "\\upsilon" texword)
358
(defprop $phi "\\varphi" texword)
359
(defprop $chi "\\chi" texword)
360
(defprop $psi "\\psi" texword)
361
(defprop $omega "\\omega" texword)
363
(defprop mquote tex-prefix tex)
364
(defprop mquote ("'") texsym)
365
(defprop mquote 201. tex-rbp)
367
(defprop msetq tex-infix tex)
368
(defprop msetq (":") texsym)
369
(defprop msetq 180. tex-rbp)
370
(defprop msetq 20. tex-rbp)
372
(defprop mset tex-infix tex)
373
(defprop mset ("::") texsym)
374
(defprop mset 180. tex-lbp)
375
(defprop mset 20. tex-rbp)
377
(defprop mdefine tex-infix tex)
378
(defprop mdefine (":=") texsym)
379
(defprop mdefine 180. tex-lbp)
380
(defprop mdefine 20. tex-rbp)
382
(defprop mdefmacro tex-infix tex)
383
(defprop mdefmacro ("::=") texsym)
384
(defprop mdefmacro 180. tex-lbp)
385
(defprop mdefmacro 20. tex-rbp)
387
(defprop marrow tex-infix tex)
388
(defprop marrow ("\\rightarrow ") texsym)
389
(defprop marrow 25 tex-lbp)
390
(defprop marrow 25 tex-rbp)
392
(defprop mfactorial tex-postfix tex)
393
(defprop mfactorial ("!") texsym)
394
(defprop mfactorial 160. tex-lbp)
396
(defprop mexpt tex-mexpt tex)
397
(defprop mexpt 140. tex-lbp)
398
(defprop mexpt 139. tex-rbp)
400
;; insert left-angle-brackets for mncexpt. a^<n> is how a^^n looks.
401
(defun tex-mexpt (x l r)
402
(let((nc (eq (caar x) 'mncexpt))); true if a^^b rather than a^b
403
;; here is where we have to check for f(x)^b to be displayed
404
;; as f^b(x), as is the case for sin(x)^2 .
405
;; which should be sin^2 x rather than (sin x)^2 or (sin(x))^2.
406
;; yet we must not display (a+b)^2 as +^2(a,b)...
407
;; or (sin(x))^(-1) as sin^(-1)x, which would be arcsine x
408
(cond ;; this whole clause
409
;; should be deleted if this hack is unwanted and/or the
410
;; time it takes is of concern.
411
;; it shouldn't be too expensive.
412
((and (eq (caar x) 'mexpt) ; don't do this hack for mncexpt
414
((fx (cadr x)); this is f(x)
415
(f (and (not (atom fx)) (atom (caar fx)) (caar fx))) ; this is f [or nil]
416
(bascdr (and f (cdr fx))) ; this is (x) [maybe (x,y..), or nil]
417
(expon (caddr x)) ;; this is the exponent
419
f ; there is such a function
420
(memq (getchar f 1) '(% $)) ;; insist it is a % or $ function
421
(not (memq f '(%sum %product))) ;; what else? what a hack...
422
(or (and (atom expon) (not (numberp expon))) ; f(x)^y is ok
423
(and (atom expon) (numberp expon) (> expon 0))))))
424
; f(x)^3 is ok, but not f(x)^-1, which could
425
; inverse of f, if written f^-1 x
426
; what else? f(x)^(1/2) is sqrt(f(x)), ??
428
(setq l (tex `((mexpt) ,f ,expon) l nil 'mparen 'mparen))
430
(if (and (null (cdr bascdr)) (eq (get f 'tex) 'tex-prefix))
431
(car bascdr) (cons '(mprogn) bascdr))
433
(t nil))))) ; won't doit. fall through
434
(t (setq l (tex (cadr x) l nil lop (caar x))
435
r (if (mmminusp (setq x (nformat (caddr x))))
436
;; the change in base-line makes parens unnecessary
438
(tex (cadr x) '("^ {-\\langle ")(cons "\\rangle }" r) 'mparen 'mparen)
439
(tex (cadr x) '("^ {- ")(cons " }" r) 'mparen 'mparen))
441
(tex x (list "^{\\langle ")(cons "\\rangle}" r) 'mparen 'mparen)
442
(tex x (list "^{")(cons "}" r) 'mparen 'mparen))))))
445
(defprop mncexpt tex-mexpt tex)
447
(defprop mncexpt 135. tex-lbp)
448
(defprop mncexpt 134. tex-rbp)
450
(defprop mnctimes tex-nary tex)
451
(defprop mnctimes "\\cdot " texsym)
452
(defprop mnctimes 110. tex-lbp)
453
(defprop mnctimes 109. tex-rbp)
455
(defprop mtimes tex-nary tex)
456
(defprop mtimes "\\*" texsym)
457
(defprop mtimes 120. tex-lbp)
458
(defprop mtimes 120. tex-rbp)
460
(defprop %sqrt tex-sqrt tex)
462
(defun tex-sqrt(x l r)
463
;; format as \\sqrt { } assuming implicit parens for sqr grouping
464
(tex (cadr x) (append l '("\\sqrt{")) (append '("}") r) 'mparen 'mparen))
466
;; macsyma doesn't know about cube (or nth) roots,
467
;; but if it did, this is what it would look like.
468
(defprop $cubrt tex-cubrt tex)
470
(defun tex-cubrt (x l r)
471
(tex (cadr x) (append l '("\\root 3 \\of{")) (append '("}") r) 'mparen 'mparen))
473
(defprop mquotient tex-mquotient tex)
474
(defprop mquotient ("\\over") texsym)
475
(defprop mquotient 122. tex-lbp) ;;dunno about this
476
(defprop mquotient 123. tex-rbp)
478
(defun tex-mquotient (x l r)
479
(if (or (null (cddr x)) (cdddr x)) (wna-err (caar x)))
480
(setq l (tex (cadr x) (append l '("{{")) nil 'mparen 'mparen)
481
;the divide bar groups things
482
r (tex (caddr x) (list "}\\over{") (append '("}}")r) 'mparen 'mparen))
485
(defprop $matrix tex-matrix tex)
487
(defun tex-matrix(x l r) ;;matrix looks like ((mmatrix)((mlist) a b) ...)
488
(append l `("\\pmatrix{")
490
(tex-list (cdr y) nil (list "\\cr ") "&"))
494
;; macsyma sum or prod is over integer range, not low <= index <= high
495
;; TeX is lots more flexible .. but
497
(defprop %sum tex-sum tex)
498
(defprop %lsum tex-lsum tex)
499
(defprop %product tex-sum tex)
501
;; easily extended to union, intersect, otherops
503
(defun tex-lsum(x l r)
504
(let ((op (cond ((eq (caar x) '%lsum) "\\sum_{")
507
;; gotta be one of those above
508
(s1 (tex (cadr x) nil nil 'mparen rop));; summand
509
(index ;; "index = lowerlimit"
510
(tex `((min simp) , (caddr x), (cadddr x)) nil nil 'mparen 'mparen)))
511
(append l `( ,op ,@index "}}{" ,@s1 "}") r)))
513
(defun tex-sum(x l r)
514
(let ((op (cond ((eq (caar x) '%sum) "\\sum_{")
515
((eq (caar x) '%product) "\\prod_{")
518
;; gotta be one of those above
519
(s1 (tex (cadr x) nil nil 'mparen rop));; summand
520
(index ;; "index = lowerlimit"
521
(tex `((mequal simp) ,(caddr x),(cadddr x)) nil nil 'mparen 'mparen))
522
(toplim (tex (car(cddddr x)) nil nil 'mparen 'mparen)))
523
(append l `( ,op ,@index "}^{" ,@toplim "}{" ,@s1 "}") r)))
525
(defprop %integrate tex-int tex)
526
(defun tex-int (x l r)
527
(let ((s1 (tex (cadr x) nil nil 'mparen 'mparen));;integrand delims / & d
528
(var (tex (caddr x) nil nil 'mparen rop))) ;; variable
529
(cond((= (length x) 3)
530
(append l `("\\int {" ,@s1 "}{\\;d" ,@var "}") r))
531
(t ;; presumably length 5
532
(let ((low (tex (nth 3 x) nil nil 'mparen 'mparen))
534
(hi (tex (nth 4 x) nil nil 'mparen 'mparen)))
535
(append l `("\\int_{" ,@low "}^{" ,@hi "}{" ,@s1 "\\;d" ,@var "}") r))))))
537
(defprop %limit tex-limit tex)
539
(defun tex-limit(x l r) ;; ignoring direction, last optional arg to limit
540
(let ((s1 (tex (cadr x) nil nil 'mparen rop));; limitfunction
541
(subfun ;; the thing underneath "limit"
542
(subst "\\rightarrow " '=
543
(tex `((mequal simp) ,(caddr x),(cadddr x))
544
nil nil 'mparen 'mparen))))
545
(append l `("\\lim_{" ,@subfun "}{" ,@s1 "}") r)))
547
(defprop %at tex-at tex)
549
;; e.g. at(diff(f(x)),x=a)
550
(defun tex-at (x l r)
551
(let ((s1 (tex (cadr x) nil nil lop rop))
552
(sub (tex (caddr x) nil nil 'mparen 'mparen)))
553
(append l '("\\left.") s1 '("\\right|_{") sub '("}") r)))
555
;(defprop mbox tex-mbox tex)
557
;(defun tex-mbox (x l r)
558
; (append l '("\\framebox{") (tex (cadr x) nil nil 'mparen 'mparen) '("}")))
560
;;binomial coefficients
562
(defprop %binomial tex-choose tex)
564
(defun tex-choose (x l r)
567
,@(tex (cadr x) nil nil 'mparen 'mparen)
569
,@(tex (caddr x) nil nil 'mparen 'mparen)
574
(defprop rat tex-rat tex)
575
(defprop rat 120. tex-lbp)
576
(defprop rat 121. tex-rbp)
577
(defun tex-rat(x l r) (tex-mquotient x l r))
579
(defprop mplus tex-mplus tex)
580
(defprop mplus 100. tex-lbp)
581
(defprop mplus 100. tex-rbp)
583
(defun tex-mplus (x l r)
584
;(declare (fixnum w))
585
(cond ((memq 'trunc (car x))(setq r (cons "+\\cdots " r))))
586
(cond ((null (cddr x))
588
(tex-function x l r t)
589
(tex (cadr x) (cons "+" l) r 'mplus rop)))
590
(t (setq l (tex (cadr x) l nil lop 'mplus)
592
(do ((nl l) (dissym))
594
(if (mmminusp (car x)) (setq l (cadar x) dissym (list "-"))
595
(setq l (car x) dissym (list "+")))
596
(setq r (tex l dissym r 'mplus rop))
598
(if (mmminusp (car x)) (setq l (cadar x) dissym (list "-"))
599
(setq l (car x) dissym (list "+")))
600
(setq nl (append nl (tex l dissym nil 'mplus 'mplus))
603
(defprop mminus tex-prefix tex)
604
(defprop mminus ("-") texsym)
605
(defprop mminus 100. tex-rbp)
606
(defprop mminus 100. tex-lbp)
608
(defprop min tex-infix tex)
609
(defprop min ("\\in{") texsym)
610
(defprop min 80. tex-lbp)
611
(defprop min 80. tex-rbp)
613
(defprop mequal tex-infix tex)
614
(defprop mequal (=) texsym)
615
(defprop mequal 80. tex-lbp)
616
(defprop mequal 80. tex-rbp)
618
(defprop mnotequal tex-infix tex)
619
(defprop mnotequal 80. tex-lbp)
620
(defprop mnotequal 80. tex-rbp)
622
(defprop mgreaterp tex-infix tex)
623
(defprop mgreaterp (>) texsym)
624
(defprop mgreaterp 80. tex-lbp)
625
(defprop mgreaterp 80. tex-rbp)
627
(defprop mgeqp tex-infix tex)
628
(defprop mgeqp ("\\geq") texsym)
629
(defprop mgeqp 80. tex-lbp)
630
(defprop mgeqp 80. tex-rbp)
632
(defprop mlessp tex-infix tex)
633
(defprop mlessp (<) texsym)
634
(defprop mlessp 80. tex-lbp)
635
(defprop mlessp 80. tex-rbp)
637
(defprop mleqp tex-infix tex)
638
(defprop mleqp ("\\leq") texsym)
639
(defprop mleqp 80. tex-lbp)
640
(defprop mleqp 80. tex-rbp)
642
(defprop mnot tex-prefix tex)
643
(defprop mnot ("\\not ") texsym)
644
(defprop mnot 70. tex-rbp)
646
(defprop mand tex-nary tex)
647
(defprop mand ("\\and") texsym)
648
(defprop mand 60. tex-lbp)
649
(defprop mand 60. tex-rbp)
651
(defprop mor tex-nary tex)
652
(defprop mor ("\\or") texsym)
654
;; make sin(x) display as sin x , but sin(x+y) as sin(x+y)
660
(setf (get a 'tex) 'tex-prefix)
661
(setf (get a 'texword) b) ;This means "sin" will always be roman
662
(setf (get a 'texsym) (list b))
663
(setf (get a 'tex-rbp) 130)))
681
;; (%erf "{\\rm erf}") this would tend to set erf(x) as erf x. Unusual
682
;(%laplace "{\\cal L}")
685
(defprop mor tex-nary tex)
686
(defprop mor 50. tex-lbp)
687
(defprop mor 50. tex-rbp)
689
(defprop mcond tex-mcond tex)
690
(defprop mcond 25. tex-lbp)
691
(defprop mcond 25. tex-rbp)
692
(defprop %derivative tex-derivative tex)
693
(defun tex-derivative (x l r)
694
(tex (tex-d x '$|d|) l r lop rop ))
696
(defun tex-d(x dsym) ;dsym should be $d or "$d\\partial"
697
;; format the macsyma derivative form so it looks
698
;; sort of like a quotient times the deriva-dand.
700
((arg (cadr x)) ;; the function being differentiated
701
(difflist (cddr x)) ;; list of derivs e.g. (x 1 y 2)
702
(ords (odds difflist 0)) ;; e.g. (1 2)
703
(vars (odds difflist 1)) ;; e.g. (x y)
704
(numer `((mexpt) $|d| ((mplus) ,@ords))) ; d^n numerator
705
(denom (cons '(mtimes)
706
(mapcan #'(lambda(b e)
707
`(,dsym ,(simplifya `((mexpt) ,b ,e) nil)))
710
((mquotient) ,(simplifya numer nil) ,denom)
714
;; if c=1, get the odd terms (first, third...)
716
((= c 1)(cons (car n)(odds (cdr n) 0)))
717
((= c 0)(odds (cdr n) 1))))
719
(defun tex-mcond (x l r)
721
(tex (cadr x) '("\\mathbf{if}\\;")
722
'("\\;\\mathbf{then}\\;") 'mparen 'mparen)
723
(if (eql (fifth x) '$false)
724
(tex (caddr x) nil r 'mcond rop)
725
(append (tex (caddr x) nil nil 'mparen 'mparen)
726
(tex (fifth x) '("\\;\\mathbf{else}\\;") r 'mcond rop)))))
728
(defprop mdo tex-mdo tex)
729
(defprop mdo 30. tex-lbp)
730
(defprop mdo 30. tex-rbp)
731
(defprop mdoin tex-mdoin tex)
732
(defprop mdoin 30. tex-rbp)
734
(defun tex-lbp(x)(cond((get x 'tex-lbp))(t(lbp x))))
735
(defun tex-rbp(x)(cond((get x 'tex-rbp))(t(lbp x))))
737
;; these aren't quite right
739
(defun tex-mdo (x l r)
740
(tex-list (texmdo x) l r "\\;"))
742
(defun tex-mdoin (x l r)
743
(tex-list (texmdoin x) l r "\\;"))
746
(nconc (cond ((second x) `("\\mathbf{for}" ,(second x))))
747
(cond ((equal 1 (third x)) nil)
748
((third x) `("\\mathbf{from}" ,(third x))))
749
(cond ((equal 1 (fourth x)) nil)
750
((fourth x) `("\\mathbf{step}" ,(fourth x)))
751
((fifth x) `("\\mathbf{next}" ,(fifth x))))
752
(cond ((sixth x) `("\\mathbf{thru}" ,(sixth x))))
753
(cond ((null (seventh x)) nil)
754
((eq 'mnot (caar (seventh x)))
755
`("\\mathbf{while}" ,(cadr (seventh x))))
756
(t `("\\mathbf{unless}" ,(seventh x))))
757
`("\\mathbf{do}" ,(eighth x))))
760
(nconc `("\\mathbf{for}" ,(second x) $|in| ,(third x))
761
(cond ((sixth x) `("\\mathbf{thru}" ,(sixth x))))
762
(cond ((null (seventh x)) nil)
763
((eq 'mnot (caar (seventh x)))
764
`("\\mathbf{while}" ,(cadr (seventh x))))
765
(t `("\\mathbf{unless}" ,(seventh x))))
766
`("\\mathbf{do}" ,(eighth x))))
769
;; Undone and trickier:
770
;; handle reserved symbols stuff, just in case someone
771
;; has a macsyma variable named (yuck!!) \over or has a name with
773
;; Maybe do some special hacking for standard notations for
774
;; hypergeometric fns, alternative summation notations 0<=n<=inf, etc.
776
;;Undone and really pretty hard: line breaking
778
(defprop mtext tex-mtext tex)
779
(defprop text-string tex-mtext tex)
780
(defprop mlable tex-mlable tex)
781
(defprop spaceout tex-spaceout tex)
783
(defun tex-mtext (x l r) (tex-list (cdr x) l r ""))
785
(defun tex-mlable (x l r)
789
(list (format nil "\\mbox{\\tt\\red(~A) \\black}" (stripdollar (cadr x))))
793
(defun tex-spaceout (x l r)
794
(append l (list "\\mbox{\\verb|" (make-string (cadr x) :initial-element #\space) "|}") r))
799
(if (and (listp x) (cdr x) (equal (cadr x) "Is "))
800
(tex x '("$\\displaystyle ") '("$ ") 'mparen 'mparen)
801
(tex x '("latex:$\\displaystyle ") '("$
802
") 'mparen 'mparen)))))
added
removed
plugins/maxima/lisp/texmacs-maxima-5.6.lisp
