3
;; Created by David Drysdale (DMD), December 2002/January 2003
5
;; closely based on the original TeX conversion code in mactex.lisp,
6
;; for which the following credits apply:
7
;; (c) copyright 1987, Richard J. Fateman
8
;; small corrections and additions: Andrey Grozin, 2001
9
;; additional additions: Judah Milgram (JM), September 2001
10
;; additional corrections: Barton Willis (BLW), October 2001
12
;; Usage: mathml(d8,"/tmp/foo.xml"); mathml(d10,"/tmp/foo.xml"); ..
13
;; to append lines d8 and d10 to the mathml file. If given only
14
;; one argument the result goes to standard output.
18
;; Producing MathML from a macsyma internal expression is done by
19
;; a reversal of the parsing process. Fundamentally, a
20
;; traversal of the expression tree is produced by the program,
21
;; with appropriate substitutions and recognition of the
22
;; infix / prefix / postfix / matchfix relations on symbols. Various
23
;; changes are made to this so that MathML will like the results.
26
;; in macsyma, type mathml(<expression>); or mathml(<label>); or
27
;; mathml(<expr-or-label>, <file-name>); In the case of a label,
28
;; an equation-number will also be produced.
29
;; in case a file-name is supplied, the output will be sent
30
;; (perhaps appended) to that file.
32
(macsyma-module mathml)
35
(special lop rop ccol $gcprint texport $labels $inchar
38
(*expr mathml-lbp mathml-rbp))
40
;; top level command the result of converting the expression x.
42
(defmspec $mathml(l) ;; mexplabel, and optional filename
43
;;if filename supplied but 'nil' then return a string
45
(cond ((and (cdr args) (null (cadr args)))
46
(let ((*standard-output* (make-string-output-stream)))
48
(get-output-stream-string *standard-output*)
51
(t (apply 'mathml1 args)))))
53
(defun mathml1 (mexplabel &optional filename ) ;; mexplabel, and optional filename
54
(prog (mexp texport $gcprint ccol x y itsalabel tmpport)
55
;; $gcprint = nil turns gc messages off
57
(cond ((null mexplabel)
58
(displa " No eqn given to MathML")
60
;; collect the file-name, if any, and open a port if needed
61
(setq texport (cond((null filename) *standard-output* ); t= output to terminal
63
(open (string (stripdollar filename))
66
:if-does-not-exist :create))))
67
;; go back and analyze the first arg more thoroughly now.
68
;; do a normal evaluation of the expression in macsyma
69
(setq mexp (meval mexplabel))
70
(cond ((memq mexplabel $labels); leave it if it is a label
71
(setq mexplabel (concat "(" (stripdollar mexplabel) ")"))
73
(t (setq mexplabel nil)));flush it otherwise
75
;; maybe it is a function?
76
(cond((symbolp (setq x mexp)) ;;exclude strings, numbers
78
(cond ((setq y (mget x 'mexpr))
79
(setq mexp (list '(mdefine) (cons (list x) (cdadr y)) (caddr y))))
80
((setq y (mget x 'mmacro))
81
(setq mexp (list '(mdefmacro) (cons (list x) (cdadr y)) (caddr y))))
82
((setq y (mget x 'aexpr))
83
(setq mexp (list '(mdefine) (cons (list x 'array) (cdadr y)) (caddr y)))))))
84
(cond ((and (null (atom mexp))
85
(memq (caar mexp) '(mdefine mdefmacro)))
86
(format texport "<pre>~%" )
87
(cond (mexplabel (format texport "~a " mexplabel)))
88
;; need to get rid of "<" signs
89
(setq tmpport (make-string-output-stream))
93
(string-substitute "<" #\< (get-output-stream-string tmpport)))
94
(format texport ";~%</pre>"))
97
itsalabel ;; but is it a user-command-label?
98
(eq (getchar $inchar 2) (getchar mexplabel 2)))
99
;; aha, this is a C-line: do the grinding:
100
(format texport "<pre>~%~a " mexplabel)
101
;; need to get rid of "<" signs
102
(setq tmpport (make-string-output-stream))
103
(mgrind mexp tmpport)
106
(string-substitute "<" #\< (get-output-stream-string tmpport)))
107
(format texport ";~%</pre>"))
109
(t ; display the expression for MathML now:
110
(myprinc "<math xmlns=\"http://www.w3.org/1998/Math/MathML\"> ")
112
;;initially the left and right contexts are
113
;; empty lists, and there are implicit parens
114
;; around the whole expression
115
(mathml mexp nil nil 'mparen 'mparen))
117
(format texport "<mspace width=\"verythickmathspace\"/> <mtext>~a</mtext> " mexplabel)))
118
(format texport "</math>")))
119
(cond(filename(terpri texport); and drain port if not terminal
123
(defun mathml (x l r lop rop)
124
;; x is the expression of interest; l is the list of strings to its
125
;; left, r to its right. lop and rop are the operators on the left
126
;; and right of x in the tree, and will determine if parens must
129
(cond ((atom x) (mathml-atom x l r))
130
((or (<= (mathml-lbp (caar x)) (mathml-rbp lop))
131
(> (mathml-lbp rop) (mathml-rbp (caar x))))
132
(mathml-paren x l r))
133
;; special check needed because macsyma notates arrays peculiarly
134
((memq 'array (cdar x)) (mathml-array x l r))
135
;; dispatch for object-oriented mathml-ifiying
136
((get (caar x) 'mathml) (funcall (get (caar x) 'mathml) x l r))
137
(t (mathml-function x l r nil))))
139
(defun string-substitute (newstring oldchar x &aux matchpos)
140
(setq matchpos (position oldchar x))
141
(if (null matchpos) x
143
(subseq x 0 matchpos)
145
(string-substitute newstring oldchar (subseq x (1+ matchpos))))))
147
;;; NOTE that we try to include spaces after closing tags (e.g. "</mwhatever> ")
148
;;; so that the line breaking algorithm in myprinc has some spaces where it
149
;;; can choose to line break.
151
;;; First we have the functions which are called directly by mathml and its
154
(defun mathml-atom (x l r)
156
(list (cond ((numberp x) (mathmlnumformat x))
157
((mstringp x) (string-left-trim '(#\&) x))
158
((and (symbolp x) (get x 'mathmlword)))
159
(t (mathml-stripdollar x))))
162
(defun mathmlnumformat(atom)
163
(let (r firstpart exponent)
164
(cond ((integerp atom)
165
(strcat "<mn>" (format nil "~d" atom) "</mn> "))
167
(setq r (explode atom))
168
(setq exponent (member 'e r :test #'string-equal));; is it ddd.ddde+EE
169
(cond ((null exponent)
170
;; it is not. go with it as given
171
(strcat "<mn>" (format nil "~s" atom) "</mn> "))
174
(nreverse (cdr (member 'e (reverse r) :test #'string-equal))))
177
(apply #'strcat firstpart)
178
"</mn><mo>×</mo> <msup><mn>10</mn><mn>"
179
(apply #'strcat (cdr exponent))
180
"</mn></msup> </mrow> ")
183
(defun mathml-stripdollar(sym)
185
(return-from mathml-stripdollar sym))
186
(let* ((pname (string-left-trim '(#\$) (symbol-name sym)))
189
(sloop for i downfrom (1- l)
190
when (not (digit-char-p (aref pname i)))
191
do (return (1+ i)))))
192
(cond ((< begin-sub l) ;; need to do subscripting
194
(subseq pname 0 begin-sub)
196
(subseq pname begin-sub l)
198
(t ;; no subscripting needed
199
(strcat "<mi>" pname "</mi> ")))))
201
(defun mathml-paren (x l r)
202
(mathml x (append l '("<mfenced separators=\"\">")) (cons "</mfenced> " r) 'mparen 'mparen))
204
(defun mathml-array (x l r)
206
(if (eq 'mqapply (caar x))
209
l (mathml f (append l (list "<mfenced separators=\",\">"))
210
(list "</mfenced> ") 'mparen 'mparen))
212
l (mathml (mathmlword f) (append l '("<msub><mrow>")) nil lop 'mfunction)))
214
r (nconc (mathml-list (cdr x) nil (list "</mrow></msub> ") "<mo>,</mo>") r))
215
(nconc l (list "</mrow><mrow>") r )))
217
;; set up a list , separated by symbols (, * ...) and then tack on the
218
;; ending item (e.g. "]" or perhaps ")"
219
(defun mathml-list (x l r sym)
223
(setq nl (nconc nl (mathml (car x) l r 'mparen 'mparen)))
225
(setq nl (nconc nl (mathml (car x) l (list sym) 'mparen 'mparen))
229
;; we could patch this so sin x rather than sin(x), but instead we made sin a prefix
231
(defun mathml-function (x l r op) op
232
(setq l (mathml (mathmlword (caar x)) l nil 'mparen 'mparen)
233
r (mathml (cons '(mprogn) (cdr x)) nil r 'mparen 'mparen))
236
;;; Now we have functions which are called via property lists
238
(defun mathml-prefix (x l r)
239
(mathml (cadr x) (append l (mathmlsym (caar x))) r (caar x) rop))
241
(defun mathml-infix (x l r)
243
(if (or (null (cddr x)) (cdddr x)) (wna-err (caar x)))
244
(setq l (mathml (cadr x) l nil lop (caar x)))
245
(mathml (caddr x) (append l (mathmlsym (caar x))) r (caar x) rop))
247
(defun mathml-postfix (x l r)
248
(mathml (cadr x) l (append (mathmlsym (caar x)) r) lop (caar x)))
250
(defun mathml-nary (x l r)
251
(let* ((op (caar x)) (sym (mathmlsym op)) (y (cdr x)) (ext-lop lop) (ext-rop rop))
252
(cond ((null y) (mathml-function x l r t)) ; this should not happen
253
((null (cdr y)) (mathml-function x l r t)) ; this should not happen, too
254
(t (do ((nl) (lop ext-lop op) (rop op (if (null (cdr y)) ext-rop op)))
255
((null (cdr y)) (setq nl (nconc nl (mathml (car y) l r lop rop))) nl)
256
(setq nl (nconc nl (mathml (car y) l (list sym) lop rop))
260
(defun mathml-nofix (x l r) (mathml (caar x) l r (caar x) rop))
262
(defun mathml-matchfix (x l r)
263
(setq l (append l (car (mathmlsym (caar x))))
264
;; car of mathmlsym of a matchfix operator is the lead op
265
r (append (cdr (mathmlsym (caar x))) r)
266
;; cdr is the trailing op
267
x (mathml-list (cdr x) nil r "<mo>,</mo>"))
270
(defun mathmlsym (x) (or (get x 'mathmlsym) (get x 'strsym)(get x 'dissym)
273
(defun mathmlword (x)(or (get x 'mathmlword) (stripdollar x)))
275
(defprop bigfloat mathml-bigfloat mathml)
277
(defun mathml-bigfloat (x l r) (declare (ignore l r)) (fpformat x))
279
(defprop mprog "<mi>block</mi><mspace width=\"mediummathspace\"/> " mathmlword)
280
(defprop %erf "<mi>erf</mi> " mathmlword)
281
(defprop $erf "<mi>erf</mi> " mathmlword) ;; etc for multicharacter names
282
(defprop $true "<mi>true</mi> " mathmlword)
283
(defprop $false "<mi>false</mi> " mathmlword)
285
(defprop mprogn mathml-matchfix mathml) ;; mprogn is (<progstmnt>, ...)
286
(defprop mprogn (("<mfenced separators=\"\">") "</mfenced> ") mathmlsym)
288
(defprop mlist mathml-matchfix mathml)
289
(defprop mlist (("<mfenced separators=\"\" open=\"[\" close=\"]\">")"</mfenced> ") mathmlsym)
292
(defprop mabs mathml-matchfix mathml)
293
(defprop mabs (("<mfenced separators=\"\" open=\"|\" close=\"|\">")"</mfenced> ") mathmlsym)
295
(defprop mqapply mathml-mqapply mathml)
297
(defun mathml-mqapply (x l r)
298
(setq l (mathml (cadr x) l (list "(" ) lop 'mfunction)
299
r (mathml-list (cddr x) nil (cons ")" r) "<mo>,</mo>"))
300
(append l r));; fixed 9/24/87 RJF
302
(defprop $%i "<mi>ⅈ</mi> " mathmlword)
303
(defprop $%pi "<mi>π</mi> " mathmlword)
304
(defprop $%e "<mi>ⅇ</mi> " mathmlword)
305
(defprop $inf "<mi>∞</mi> " mathmlword)
306
(defprop $minf "<mi>-∞</mi> " mathmlword)
307
(defprop %laplace "<mo>ℒ</mo>" mathmlword)
308
(defprop $alpha "<mi>α</mi> " mathmlword)
309
(defprop $beta "<mi>β</mi> " mathmlword)
310
(defprop $gamma "<mi>γ</mi> " mathmlword)
311
(defprop %gamma "<mi>Γ</mi> " mathmlword)
312
(defprop $delta "<mi>δ</mi> " mathmlword)
313
(defprop $epsilon "<mi>ε</mi> " mathmlword)
314
(defprop $zeta "<mi>ζ</mi> " mathmlword)
315
(defprop $eta "<mi>η</mi> " mathmlword)
316
(defprop $theta "<mi>θ</mi> " mathmlword)
317
(defprop $iota "<mi>ι</mi> " mathmlword)
318
(defprop $kappa "<mi>κ</mi> " mathmlword)
319
;(defprop $lambda "<mi>λ</mi> " mathmlword)
320
(defprop $mu "<mi>μ</mi> " mathmlword)
321
(defprop $nu "<mi>ν</mi> " mathmlword)
322
(defprop $xi "<mi>ξ</mi> " mathmlword)
323
(defprop $pi "<mi>π</mi> " mathmlword)
324
(defprop $rho "<mi>ρ</mi> " mathmlword)
325
(defprop $sigma "<mi>σ</mi> " mathmlword)
326
(defprop $tau "<mi>τ</mi> " mathmlword)
327
(defprop $upsilon "<mi>υ</mi> " mathmlword)
328
(defprop $phi "<mi>φ</mi> " mathmlword)
329
(defprop $chi "<mi>χ</mi> " mathmlword)
330
(defprop $psi "<mi>ψ</mi> " mathmlword)
331
(defprop $omega "<mi>ω</mi> " mathmlword)
333
(defprop mquote mathml-prefix mathml)
334
(defprop mquote ("<mo>'</mo>") mathmlsym)
335
(defprop mquote 201. mathml-rbp)
337
(defprop msetq mathml-infix mathml)
338
(defprop msetq ("<mo>:</mo>") mathmlsym)
339
(defprop msetq 180. mathml-rbp)
340
(defprop msetq 20. mathml-rbp)
342
(defprop mset mathml-infix mathml)
343
(defprop mset ("<mo>::</mo>") mathmlsym)
344
(defprop mset 180. mathml-lbp)
345
(defprop mset 20. mathml-rbp)
347
(defprop mdefine mathml-infix mathml)
348
(defprop mdefine ("<mo>:=</mo>") mathmlsym)
349
(defprop mdefine 180. mathml-lbp)
350
(defprop mdefine 20. mathml-rbp)
352
(defprop mdefmacro mathml-infix mathml)
353
(defprop mdefmacro ("<mo>::=</mo>") mathmlsym)
354
(defprop mdefmacro 180. mathml-lbp)
355
(defprop mdefmacro 20. mathml-rbp)
357
(defprop marrow mathml-infix mathml)
358
(defprop marrow ("<mo>→</mo>") mathmlsym)
359
(defprop marrow 25 mathml-lbp)
360
(defprop marrow 25 mathml-rbp)
362
(defprop mfactorial mathml-postfix mathml)
363
(defprop mfactorial ("<mo>!</mo>") mathmlsym)
364
(defprop mfactorial 160. mathml-lbp)
366
(defprop mexpt mathml-mexpt mathml)
367
(defprop mexpt 140. mathml-lbp)
368
(defprop mexpt 139. mathml-rbp)
370
(defprop %sum 110. mathml-rbp) ;; added by BLW, 1 Oct 2001
371
(defprop %product 115. mathml-rbp) ;; added by BLW, 1 Oct 2001
373
;; insert left-angle-brackets for mncexpt. a^<n> is how a^^n looks.
374
(defun mathml-mexpt (x l r)
375
(let((nc (eq (caar x) 'mncexpt))); true if a^^b rather than a^b
376
;; here is where we have to check for f(x)^b to be displayed
377
;; as f^b(x), as is the case for sin(x)^2 .
378
;; which should be sin^2 x rather than (sin x)^2 or (sin(x))^2.
379
;; yet we must not display (a+b)^2 as +^2(a,b)...
380
;; or (sin(x))^(-1) as sin^(-1)x, which would be arcsine x
381
(cond ;; this whole clause
382
;; should be deleted if this hack is unwanted and/or the
383
;; time it takes is of concern.
384
;; it shouldn't be too expensive.
385
((and (eq (caar x) 'mexpt) ; don't do this hack for mncexpt
387
((fx (cadr x)); this is f(x)
388
(f (and (not (atom fx)) (atom (caar fx)) (caar fx))) ; this is f [or nil]
389
(bascdr (and f (cdr fx))) ; this is (x) [maybe (x,y..), or nil]
390
(expon (caddr x)) ;; this is the exponent
392
f ; there is such a function
393
(memq (getchar f 1) '(% $)) ;; insist it is a % or $ function
394
(not (memq f '(%sum %product %derivative %integrate %at
395
%lsum %limit))) ;; what else? what a hack...
396
(or (and (atom expon) (not (numberp expon))) ; f(x)^y is ok
397
(and (atom expon) (numberp expon) (> expon 0))))))
398
; f(x)^3 is ok, but not f(x)^-1, which could
399
; inverse of f, if written f^-1 x
400
; what else? f(x)^(1/2) is sqrt(f(x)), ??
402
(setq l (mathml `((mexpt) ,f ,expon) l nil 'mparen 'mparen))
403
(if (and (null (cdr bascdr))
404
(eq (get f 'mathml) 'mathml-prefix))
405
(setq r (mathml (car bascdr) nil r f 'mparen))
406
(setq r (mathml (cons '(mprogn) bascdr) nil r 'mparen 'mparen))))
407
(t nil))))) ; won't doit. fall through
408
(t (setq l (mathml (cadr x) (append l '("<msup><mrow>")) nil lop (caar x))
409
r (if (mmminusp (setq x (nformat (caddr x))))
410
;; the change in base-line makes parens unnecessary
412
(mathml (cadr x) '("</mrow> <mfenced separators=\"\" open=\"<\" close=\">\"> -")(cons "</mfenced></msup> " r) 'mparen 'mparen)
413
(mathml (cadr x) '("</mrow> <mfenced separators=\"\"> -")(cons "</mfenced></msup> " r) 'mparen 'mparen))
415
(mathml x (list "</mrow> <mfenced separators=\"\" open=\"<\" close=\">\">")(cons "</mfenced></msup>" r) 'mparen 'mparen)
416
(if (and (numberp x) (< x 10))
417
(mathml x (list "</mrow> ")(cons "</msup> " r) 'mparen 'mparen)
418
(mathml x (list "</mrow> <mrow>")(cons "</mrow></msup> " r) 'mparen 'mparen))
422
(defprop mncexpt mathml-mexpt mathml)
424
(defprop mncexpt 135. mathml-lbp)
425
(defprop mncexpt 134. mathml-rbp)
427
(defprop mnctimes mathml-nary mathml)
428
(defprop mnctimes "<mi>⋯</mi> " mathmlsym)
429
(defprop mnctimes 110. mathml-lbp)
430
(defprop mnctimes 109. mathml-rbp)
432
(defprop mtimes mathml-nary mathml)
433
(defprop mtimes "<mspace width=\"thinmathspace\"/>" mathmlsym)
434
(defprop mtimes 120. mathml-lbp)
435
(defprop mtimes 120. mathml-rbp)
437
(defprop %sqrt mathml-sqrt mathml)
439
(defun mathml-sqrt(x l r)
440
;; format as \\sqrt { } assuming implicit parens for sqr grouping
441
(mathml (cadr x) (append l '("<msqrt>")) (append '("</msqrt>") r) 'mparen 'mparen))
443
;; macsyma doesn't know about cube (or nth) roots,
444
;; but if it did, this is what it would look like.
445
(defprop $cubrt mathml-cubrt mathml)
447
(defun mathml-cubrt (x l r)
448
(mathml (cadr x) (append l '("<mroot><mrow>")) (append '("</mrow>3</mroot>") r) 'mparen 'mparen))
450
(defprop mquotient mathml-mquotient mathml)
451
(defprop mquotient ("<mo>/</mo>") mathmlsym)
452
(defprop mquotient 122. mathml-lbp) ;;dunno about this
453
(defprop mquotient 123. mathml-rbp)
455
(defun mathml-mquotient (x l r)
456
(if (or (null (cddr x)) (cdddr x)) (wna-err (caar x)))
457
(setq l (mathml (cadr x) (append l '("<mfrac><mrow>")) nil 'mparen 'mparen)
458
r (mathml (caddr x) (list "</mrow> <mrow>") (append '("</mrow></mfrac> ")r) 'mparen 'mparen))
461
(defprop $matrix mathml-matrix mathml)
463
(defun mathml-matrix(x l r) ;;matrix looks like ((mmatrix)((mlist) a b) ...)
464
(append l `("<mfenced separators=\"\" open=\"(\" close=\")\"><mtable>")
466
(mathml-list (cdr y) (list "<mtr><mtd>") (list "</mtd></mtr> ") "</mtd><mtd>"))
468
'("</mtable></mfenced> ") r))
470
;; macsyma sum or prod is over integer range, not low <= index <= high
471
;; Mathml is lots more flexible .. but
473
(defprop %sum mathml-sum mathml)
474
(defprop %lsum mathml-lsum mathml)
475
(defprop %product mathml-sum mathml)
477
;; easily extended to union, intersect, otherops
479
(defun mathml-lsum(x l r)
480
(let ((op (cond ((eq (caar x) '%lsum) "<mrow><munder><mo>∑</mo> <mrow>")
483
;; gotta be one of those above
484
(s1 (mathml (cadr x) nil nil 'mparen rop));; summand
485
(index ;; "index = lowerlimit"
486
(mathml `((min simp) , (caddr x), (cadddr x)) nil nil 'mparen 'mparen)))
487
(append l `( ,op ,@index "</mrow></munder> <mrow>" ,@s1 "</mrow></mrow> ") r)))
489
(defun mathml-sum(x l r)
490
(let ((op (cond ((eq (caar x) '%sum) "<mrow><munderover><mo>∑</mo><mrow>")
491
((eq (caar x) '%product) "<mrow><munderover><mo>∏</mo><mrow>")
494
;; gotta be one of those above
495
(s1 (mathml (cadr x) nil nil 'mparen rop));; summand
496
(index ;; "index = lowerlimit"
497
(mathml `((mequal simp) ,(caddr x),(cadddr x)) nil nil 'mparen 'mparen))
498
(toplim (mathml (car(cddddr x)) nil nil 'mparen 'mparen)))
499
(append l `( ,op ,@index "</mrow> <mrow>" ,@toplim "</mrow></munderover> <mrow>" ,@s1 "</mrow></mrow> ") r)))
501
(defprop %integrate mathml-int mathml)
503
(defun mathml-int (x l r)
504
(let ((s1 (mathml (cadr x) nil nil 'mparen 'mparen));;integrand delims / & d
505
(var (mathml (caddr x) nil nil 'mparen rop))) ;; variable
506
(cond((= (length x) 3)
507
(append l `("<mrow><mo>∫</mo><mrow>" ,@s1 "</mrow> <mspace width=\"mediummathspace\"/> <mrow><mo>ⅆ</mo><mi>" ,@var "</mi></mrow></mrow> ") r))
508
(t ;; presumably length 5
509
(let ((low (mathml (nth 3 x) nil nil 'mparen 'mparen))
511
(hi (mathml (nth 4 x) nil nil 'mparen 'mparen)))
512
(append l `("<mrow><munderover><mo>∫</mo> <mrow>" ,@low "</mrow> <mrow>" ,@hi "</mrow> </munderover> <mrow>" ,@s1 "</mrow> <mspace width=\"mediummathspace\"/> <mrow><mo>ⅆ</mo><mi>" ,@var "</mi> </mrow></mrow> ") r))))))
514
(defprop %limit mathml-limit mathml)
516
(defprop mrarr mathml-infix mathml)
517
(defprop mrarr ("<mo>→</mo> ") mathmlsym)
518
(defprop mrarr 80. mathml-lbp)
519
(defprop mrarr 80. mathml-rbp)
521
(defun mathml-limit(x l r) ;; ignoring direction, last optional arg to limit
522
(let ((s1 (mathml (second x) nil nil 'mparen rop));; limitfunction
523
(subfun ;; the thing underneath "limit"
524
(mathml `((mrarr simp) ,(third x) ,(fourth x)) nil nil 'mparen 'mparen)))
525
(append l `("<munder><mo>lim</mo><mrow>" ,@subfun "</mrow> </munder> <mrow>" ,@s1 "</mrow>") r)))
527
(defprop %at mathml-at mathml)
529
;; e.g. at(diff(f(x)),x=a)
530
(defun mathml-at (x l r)
531
(let ((s1 (mathml (cadr x) nil nil lop rop))
532
(sub (mathml (caddr x) nil nil 'mparen 'mparen)))
533
(append l '("<msub><mfenced separators=\"\" open=\"\" close=\"|\">") s1 '("</mfenced> <mrow>") sub '("</mrow> </msub> ") r)))
535
;;binomial coefficients
537
(defprop %binomial mathml-choose mathml)
539
(defun mathml-choose (x l r)
541
"<mfenced separators=\"\" open=\"(\" close=\")\"><mtable><mtr><mtd>"
542
,@(mathml (cadr x) nil nil 'mparen 'mparen)
543
"</mtd></mtr> <mtr><mtd>"
544
,@(mathml (caddr x) nil nil 'mparen 'mparen)
545
"</mtd></mtr> </mtable></mfenced> "
549
(defprop rat mathml-rat mathml)
550
(defprop rat 120. mathml-lbp)
551
(defprop rat 121. mathml-rbp)
552
(defun mathml-rat(x l r) (mathml-mquotient x l r))
554
(defprop mplus mathml-mplus mathml)
555
(defprop mplus 100. mathml-lbp)
556
(defprop mplus 100. mathml-rbp)
558
(defun mathml-mplus (x l r)
559
;(declare (fixnum w))
560
(cond ((memq 'trunc (car x))(setq r (cons "<mo>+</mo><mtext>⋯</mtext> " r))))
561
(cond ((null (cddr x))
563
(mathml-function x l r t)
564
(mathml (cadr x) (cons "<mo>+</mo>" l) r 'mplus rop)))
565
(t (setq l (mathml (cadr x) l nil lop 'mplus)
567
(do ((nl l) (dissym))
569
(if (mmminusp (car x)) (setq l (cadar x) dissym (list "<mo>-</mo> "))
570
(setq l (car x) dissym (list "<mo>+</mo> ")))
571
(setq r (mathml l dissym r 'mplus rop))
573
(if (mmminusp (car x)) (setq l (cadar x) dissym (list "<mo>-</mo> "))
574
(setq l (car x) dissym (list "<mo>+</mo> ")))
575
(setq nl (append nl (mathml l dissym nil 'mplus 'mplus))
578
(defprop mminus mathml-prefix mathml)
579
(defprop mminus ("-") mathmlsym)
580
(defprop mminus 100. mathml-rbp)
581
(defprop mminus 100. mathml-lbp)
583
(defprop min mathml-infix mathml)
584
(defprop min ("<mo>∈</mo> ") mathmlsym)
585
(defprop min 80. mathml-lbp)
586
(defprop min 80. mathml-rbp)
588
(defprop mequal mathml-infix mathml)
589
(defprop mequal ("<mo>=</mo> ") mathmlsym)
590
(defprop mequal 80. mathml-lbp)
591
(defprop mequal 80. mathml-rbp)
593
(defprop mnotequal mathml-infix mathml)
594
(defprop mnotequal 80. mathml-lbp)
595
(defprop mnotequal 80. mathml-rbp)
597
(defprop mgreaterp mathml-infix mathml)
598
(defprop mgreaterp ("<mo>></mo> ") mathmlsym)
599
(defprop mgreaterp 80. mathml-lbp)
600
(defprop mgreaterp 80. mathml-rbp)
602
(defprop mgeqp mathml-infix mathml)
603
(defprop mgeqp ("<mo>≥</mo> ") mathmlsym)
604
(defprop mgeqp 80. mathml-lbp)
605
(defprop mgeqp 80. mathml-rbp)
607
(defprop mlessp mathml-infix mathml)
608
(defprop mlessp ("<mo><</mo> ") mathmlsym)
609
(defprop mlessp 80. mathml-lbp)
610
(defprop mlessp 80. mathml-rbp)
612
(defprop mleqp mathml-infix mathml)
613
(defprop mleqp ("<mo>≤</mo> ") mathmlsym)
614
(defprop mleqp 80. mathml-lbp)
615
(defprop mleqp 80. mathml-rbp)
617
(defprop mnot mathml-prefix mathml)
618
(defprop mnot ("<mo>¬</mo> ") mathmlsym)
619
(defprop mnot 70. mathml-rbp)
621
(defprop mand mathml-nary mathml)
622
(defprop mand ("<mo>∧</mo> ") mathmlsym)
623
(defprop mand 60. mathml-lbp)
624
(defprop mand 60. mathml-rbp)
626
(defprop mor mathml-nary mathml)
627
(defprop mor ("<mo>∨</mo> ") mathmlsym)
629
;; make sin(x) display as sin x , but sin(x+y) as sin(x+y)
632
(defun mathml-setup (x)
635
(setf (get a 'mathml) 'mathml-prefix)
636
(setf (get a 'mathmlword) b) ;This means "sin" will always be roman
637
(setf (get a 'mathmlsym) (list b))
638
(setf (get a 'mathml-rbp) 130)))
642
(%acos "<mi>arccos</mi> ")
643
(%asin "<mi>arcsin</mi> ")
644
(%atan "<mi>arctan</mi> ")
645
(%arg "<mi>arg</mi> ")
646
(%cos "<mi>cos</mi> ")
647
(%cosh "<mi>cosh</mi> ")
648
(%cot "<mi>cot</mi> ")
649
(%coth "<mi>coth</mi> ")
650
(%csc "<mi>cosec</mi> ")
651
(%deg "<mi>deg</mi> ")
652
(%determinant "<mi>det</mi> ")
653
(%dim "<mi>dim</mi> ")
654
(%exp "<mi>exp</mi> ")
655
(%gcd "<mi>gcd</mi> ")
656
(%hom "<mi>hom</mi> ")
657
(%inf "<mi>∞</mi> ")
658
(%ker "<mi>ker</mi> ")
660
;;(%limit "<mi>lim</mi> ")
661
(%liminf "<mi>lim inf</mi> ")
662
(%limsup "<mi>lim sup</mi> ")
664
(%log "<mi>log</mi> ")
665
(%max "<mi>max</mi> ")
666
(%min "<mi>min</mi> ")
668
(%sec "<mi>sec</mi> ")
669
(%sech "<mi>sech</mi> ")
670
(%sin "<mi>sin</mi> ")
671
(%sinh "<mi>sinh</mi> ")
672
(%sup "<mi>sup</mi> ")
673
(%tan "<mi>tan</mi> ")
674
(%tanh "<mi>tanh</mi> ")
675
;; (%erf "{\\rm erf}") this would tend to set erf(x) as erf x. Unusual
676
;(%laplace "{\\cal L}")
679
(defprop mor mathml-nary mathml)
680
(defprop mor 50. mathml-lbp)
681
(defprop mor 50. mathml-rbp)
683
(defprop mcond mathml-mcond mathml)
684
(defprop mcond 25. mathml-lbp)
685
(defprop mcond 25. mathml-rbp)
687
(defprop %derivative mathml-derivative mathml)
689
(defun mathml-derivative (x l r)
690
(mathml (mathml-d x "ⅆ") l r lop rop ))
692
(defun mathml-d(x dsym) ;dsym should be "ⅆ" or "∂"
693
;; format the macsyma derivative form so it looks
694
;; sort of like a quotient times the deriva-dand.
696
((arg (cadr x)) ;; the function being differentiated
697
(difflist (cddr x)) ;; list of derivs e.g. (x 1 y 2)
698
(ords (odds difflist 0)) ;; e.g. (1 2)
699
(vars (odds difflist 1)) ;; e.g. (x y)
700
(numer `((mexpt) ,dsym ((mplus) ,@ords))) ; d^n numerator
701
(denom (cons '(mtimes)
702
(mapcan #'(lambda(b e)
703
`(,dsym ,(simplifya `((mexpt) ,b ,e) nil)))
706
((mquotient) ,(simplifya numer nil) ,denom)
709
(defun mathml-mcond (x l r)
711
(mathml (cadr x) '("<mi>if</mi> <mspace width=\"mediummathspace\"/>")
712
'("<mspace width=\"mediummathspace\"/> <mi>then</mi><mspace width=\"mediummathspace\"/> ") 'mparen 'mparen)
713
(if (eql (fifth x) '$false)
714
(mathml (caddr x) nil r 'mcond rop)
715
(append (mathml (caddr x) nil nil 'mparen 'mparen)
716
(mathml (fifth x) '("<mspace width=\"mediummathspace\"/> <mi>else</mi><mspace width=\"mediummathspace\"/> ") r 'mcond rop)))))
718
(defprop mdo mathml-mdo mathml)
719
(defprop mdo 30. mathml-lbp)
720
(defprop mdo 30. mathml-rbp)
721
(defprop mdoin mathml-mdoin mathml)
722
(defprop mdoin 30. mathml-rbp)
724
(defun mathml-lbp(x)(cond((get x 'mathml-lbp))(t(lbp x))))
725
(defun mathml-rbp(x)(cond((get x 'mathml-rbp))(t(lbp x))))
727
;; these aren't quite right
729
(defun mathml-mdo (x l r)
730
(mathml-list (mathmlmdo x) l r "<mspace width=\"mediummathspace\"/> "))
732
(defun mathml-mdoin (x l r)
733
(mathml-list (mathmlmdoin x) l r "<mspace width=\"mediummathspace\"/> "))
736
(nconc (cond ((second x) `("<mi>for</mi> " ,(second x))))
737
(cond ((equal 1 (third x)) nil)
738
((third x) `("<mi>from</mi> " ,(third x))))
739
(cond ((equal 1 (fourth x)) nil)
740
((fourth x) `("<mi>step</mi> " ,(fourth x)))
741
((fifth x) `("<mi>next</mi> " ,(fifth x))))
742
(cond ((sixth x) `("<mi>thru</mi> " ,(sixth x))))
743
(cond ((null (seventh x)) nil)
744
((eq 'mnot (caar (seventh x)))
745
`("<mi>while</mi> " ,(cadr (seventh x))))
746
(t `("<mi>unless</mi> " ,(seventh x))))
747
`("<mi>do</mi> " ,(eighth x))))
749
(defun mathmlmdoin (x)
750
(nconc `("<mi>for</mi>" ,(second x) "<mi>in</mi> " ,(third x))
751
(cond ((sixth x) `("<mi>thru</mi> " ,(sixth x))))
752
(cond ((null (seventh x)) nil)
753
((eq 'mnot (caar (seventh x)))
754
`("<mi>while</mi> " ,(cadr (seventh x))))
755
(t `("<mi>unless</mi> " ,(seventh x))))
756
`("<mi>do</mi> " ,(eighth x))))
758
;; Undone and trickier:
759
;; Maybe do some special hacking for standard notations for
760
;; hypergeometric fns, alternative summation notations 0<=n<=inf, etc.
added
removed
share/contrib/lurkmathml/mathml.lisp
