;;;; Convert Scheme expressions to MathML
;;;; This uses content MathML, except in fractions, where we use presentation
;;;; to force fractions that are done with a build, rather than a slash.
;;;; The two exported procedures are
;;;; scheme->mathml -- Takes a Scheme expression and returns the corresponding
;;;; MathML string. For example, if the expression is (+ x 2)
;;;; the string returned is
;;;;
;;;; scheme-mathml-write-file -- Takes a Scheme expression and writes the
;;;; corresponding MathML as a file whose name is given by the string
;;;; standard-output-file
(load-option 'xml)
(define standard-output-file
"/home/hal/hal-web/misc/mathml/testmathml.xml")
(define scheme->mathml)
(define scheme->mathml-write-file)
(let ()
(set! scheme->mathml
(lambda (exp)
(string-append mathml-open-tag
(convert-expression exp)
mathml-close-tag)))
(set! scheme->mathml-write-file
(lambda (exp)
(scheme->mathml-write-file-name exp standard-output-file)))
#| ; old version without indentation of the XML file
(define (scheme->mathml-write-file-name exp file)
(let ((x (scheme->mathml exp)))
(with-output-to-file file
(lambda ()
(display-standard-file-header)
(display x)
(display-standard-file-close)))))
|#
(define (scheme->mathml-write-file-name exp file)
(let ((x (string->xml (scheme->mathml exp)))
(p (open-output-file file)))
(xml-indent! x)
(with-output-to-port p
(lambda () (display-standard-file-header)))
(write-xml x p)
(with-output-to-port p
(lambda () (display-standard-file-close)))
(close-output-port p)))
;;;CPH intent procedure, using the XML parser
(define (xml-indent! document)
(set-xml-document-misc-2! document '("\n"))
(set-xml-document-misc-3! document '("\n"))
(let element-loop
((element (xml-document-root document))
(indent 2)
(prev-indent-string "\n"))
(let ((items (xml-element-contents element)))
(if (there-exists? items xml-element?)
(set-xml-element-contents!
element
(let ((indent-string
(string-append "\n" (make-string indent #\space))))
(let item-loop ((items items))
(if (xml-element? (car items))
(element-loop (car items) (+ indent 2) indent-string))
(cons* indent-string (car items)
(if (pair? (cdr items))
(item-loop (cdr items))
(list prev-indent-string))))))))))
;;;main prcedure, it's bascially an eval
(define (convert-expression exp)
(if (null? exp)
""
(if (not (pair? exp))
(convert-atomic exp)
(let ((special-process
(assq (car exp) *mathml-special-operators*)))
(if special-process
((cadr special-process) (cdr exp))
(make-application
(convert-expression (car exp))
(convert-operands (cdr exp))))))))
;;;atoms are either numbers, special symbols that are replaced by their MathML
;;;analogues, or ordinary variables
(define (convert-atomic x)
(if (number? x)
(tag-enclose "cn" (number->string x))
(let ((special
(assq x *mathml-special-symbols*)))
(if (not (null? special))
(cadr special)
(tag-enclose "ci" (symbol->string x))))))
;;;applications
;;;here operator and operatnds are xml strings
(define (make-application operator operands)
(tag-enclose "apply"
(string-append operator operands)))
(define (convert-operands exps)
(apply string-append (map convert-expression exps)))
(define (tag-enclose tag contents)
(string-append "<" tag ">" contents ""))
(define mathml-open-tag
"")
(define (display-standard-file-header)
(display-line "")
(display-line "")
(display-line "")
(newline)
(display-line "")
(newline))
(define (display-standard-file-close)
(newline)
(display-line "")
(display-line "")
)
(define (display-line s)
(display s)
(newline))
;;; Here are the procedures for handling special operators, i.e., operators that require
;;; some special processing to generate the MathML, not jsut substituting a MathML symbol for a
;;; Scheme symbol
;;For division, force the output to be a built fraction by using presentation MathML
;;We permit 2-arg division only, since otherwise we'll get a
;;MathML "invalid markup" error
;;exps is the list (numer denom)
(define (convert-division exps)
(define (make-fraction args)
(apply string-append
`(""
""
,@args
""
"")))
(let ((n (length exps)))
(cond ((= n 0) (error "Division with no arguments" exps))
((= n 1) (convert-expression `(/ 1 ,exp)))
((= n 2) (make-fraction (map convert-expression exps)))
((> n 2)
(error "Division with more than two arguments -- CONVERT-DIVISION" exps))
(else "Bad division expression -- CONVERT-DIVISION" exps))))
;;exps is the list (var subscript) -- one subscript only
(define (convert-subscripted exps)
(tag-enclose
"ci"
(tag-enclose "msub"
(convert-operands exps))))
;;exps is the list (degree radicand)
(define (convert-radical exps)
(make-application
""
(string-append
(tag-enclose "degree"
(convert-expression (car exps)))
(convert-expression (cadr exps)))))
(define *mathml-special-operators*
`((/ ,convert-division)
(subscript ,convert-subscripted)
(radical ,convert-radical)
))
;;; MathML special symbols are ones where we cna just substiutte a MathML symbol for the
;;; Scheme symbol
(define *mathml-special-symbols*
(append
;;this group of symbols is just substituted, with no special processing
(map (lambda (pair)
(let ((scheme-operator (car pair))
(mathml-operator (cadr pair)))
(list scheme-operator
(string-append "<" (symbol->string mathml-operator) "/>"))))
'((+ plus)
(- minus)
(* times)
(/ divide) ;unused since we build fractions
(= eq)
(expt power)
(approx approx)
(acos arccos)
(asin arcsin)
(atan arctan)
(sin sin)
(cos cos)
(tan tan)
(cot cot)
(csc cosec)
(sec sec)
(:pi pi)
(sqrt root) ; with no make degree 2
(exp exp)
(log ln)
(infinity infinity) ;called infty in mechanics code
(infty infinity)
))
;;this group of symbols turns into "numbers" from the font codes
(map (lambda (pair)
(let ((scheme-symbol (car pair))
(code (number->string (cadr pair) 16)))
(list scheme-symbol
(tag-enclose "cn"
(string-append "&" "#x" code ";")))))
'((alpha #x3B1)
(beta #x3B2)
(gamma #x3B3)
(delta #x3B4)
;;hmm .. I don't see epsilon in the font table. This
;;is really varepsilon
(epsilon #x3B45)
(zeta #x3B6)
(eta #x3B7)
(theta #x3B8)
(iota #x3B9)
(kappa #x3BA)
(lambda #x3BB)
(mu #x3BC)
(nu #x3BD)
(xi #x3BE)
;;there is no omicron in the chracater set
(pi #x3C0)
(rho #x3C1)
(sigma #x3C3)
(tau #x3C4)
(upsilon #x3C5)
(phi #x3C6)
(chi #xC7)
(psi #x3C8)
(omega #x3C9)
(varsigma #x3C2)
(vartheta #x3D1)
(varphi #x3D5)
(varpi #x3D6)
(varrho #x3F1)
(varepsilon #x3B45)
;; upper case Greek letters. The Cap names are duplicates
;; so we can play with this in Scheme bands that do not
;; distinguish upper and lower case symbols
(Gamma #x393)
(CapGamma #x393)
(Delta #x394)
(CapDelta #x394)
(Theta #x398)
(CapTheta #x398)
(Lambda #x39B)
(CapLambda #x39B)
(Xi #x39E)
(CapXi #x39E)
(Pi #x3A0)
(CapPi #x3A0)
(Sigma #x3A3)
(CapSigma #x3A3)
(Upsilon #x3A5)
(CapUpsilon #x3A5)
(Phi #x3A6)
(CapPhi #x3A6)
(Psi #x3A8)
(CapPsi #x3A8)
(Omega #x3A9)
(CapOmega #x3A9)
(aleph #x2135)
(mho #x2127)
))
))
) ;close the pakaging let
#|
Things below here still need to be implemented.
(define tex:unparse-table
`((parenthesize ,tex:parenthesize)
(,derivative-symbol ,unparse-derivative)
(derivative ,unparse-derivative)
(second-derivative ,tex:unparse-second-derivative)
(nth-derivative ,tex:unparse-nth-derivative)
(partial-derivative ,tex:unparse-partial-derivative)
(vector ,tex:unparse-vector)
(column ,tex:unparse-up)
(row ,tex:unparse-down)
(up ,tex:unparse-up)
(down ,tex:unparse-down)
(matrix ,tex:unparse-matrix)
(dotted ,tex:unparse-dotted)
(dotdotted ,tex:unparse-dotdotted)
))
(define tex:symbol-substs
(append `((derivative "D")
)
(map (lambda (string)
(list (string->symbol string)
(string-append "\\" string)))
'(
;;"Alpha" "Beta"
;;"Epsilon" "Zeta" "Eta"
;;"Iota" "Kappa"
;;"Mu" "Nu"
;;"Omicron"
;;"Rho" "Tau"
;;"Chi"
"hbar" "nabla" "top" "bot" "Re" "Im"
"Box" "diamond" "Diamond" "triangle"
))))
|#