1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
|
{-
Copyright (C) 2009 John MacFarlane <jgm@berkeley.edu>
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
{- | Functions for writing a parsed formula as MathML.
-}
module Text.TeXMath.MathML (toMathML, showExp)
where
import qualified Data.Map as M
import Text.XML.Light
import Text.TeXMath.Types
import Text.TeXMath.ToUnicode
import Data.Generics (everywhere, mkT)
toMathML :: DisplayType -> [Exp] -> Element
toMathML dt exprs =
add_attr dtattr $ math $ map showExp $ everywhere (mkT $ handleDownup dt) exprs
where dtattr = Attr (unqual "display") dt'
dt' = case dt of
DisplayBlock -> "block"
DisplayInline -> "inline"
math :: [Element] -> Element
math = add_attr (Attr (unqual "xmlns") "http://www.w3.org/1998/Math/MathML") . unode "math" . unode "mrow"
mrow :: [Element] -> Element
mrow = unode "mrow"
{- Firefox seems to set spacing based on its own dictionary,
- so I believe this is unnecessary.
setSpacing :: String -> String -> Bool -> Element -> Element
setSpacing left right stretchy elt =
add_attr (Attr (unqual "lspace") left) $
add_attr (Attr (unqual "rspace") right) $
if stretchy
then add_attr (Attr (unqual "stretchy") "true") elt
else elt
showSymbol (ESymbol s x) =
case s of
Ord x -> unode "mo" x
Op x -> setSpacing "0" "0.167em" True $ unode "mo" x
Bin x -> setSpacing "0.222em" "0.222em" False $ unode "mo" x
Rel x -> setSpacing "0.278em" "0.278em" False $ unode "mo" x
Open x -> setSpacing "0" "0" True $ unode "mo" x
Close x -> setSpacing "0" "0" True $ unode "mo" x
Pun x -> setSpacing "0" "0.167em" False $ unode "mo" x
-}
unaryOps :: M.Map String String
unaryOps = M.fromList
[ ("\\sqrt", "msqrt")
, ("\\surd", "msqrt")
]
showUnary :: String -> Exp -> Element
showUnary c x =
case M.lookup c unaryOps of
Just c' -> unode c' (showExp x)
Nothing -> error $ "Unknown unary op: " ++ c
binaryOps :: M.Map String ([Element] -> Element)
binaryOps = M.fromList
[ ("\\frac", unode "mfrac")
, ("\\tfrac", withAttribute "displaystyle" "false" .
unode "mstyle" . unode "mfrac")
, ("\\dfrac", withAttribute "displaystyle" "true" .
unode "mstyle" . unode "mfrac")
, ("\\sqrt", unode "mroot")
, ("\\stackrel", unode "mover" . reverse)
, ("\\overset", unode "mover" . reverse)
, ("\\underset", unode "munder" . reverse)
, ("\\binom", showBinom)
]
showBinom :: [Element] -> Element
showBinom lst = unode "mfenced" $ withAttribute "linethickness" "0" $ unode "mfrac" lst
showBinary :: String -> Exp -> Exp -> Element
showBinary c x y =
case M.lookup c binaryOps of
Just f -> f [showExp x, showExp y]
Nothing -> error $ "Unknown binary op: " ++ c
spaceWidth :: String -> Element
spaceWidth w = withAttribute "width" w $ unode "mspace" ()
makeStretchy :: Element -> Element
makeStretchy = withAttribute "stretchy" "true"
makeScaled :: String -> Element -> Element
makeScaled s = withAttribute "minsize" s . withAttribute "maxsize" s
-- Note: Converts strings to unicode directly, as few renderers support those mathvariants.
makeText :: TextType -> String -> Element
makeText a s = if trailingSp
then mrow [s', sp]
else s'
where sp = spaceWidth "0.333em"
s' = withAttribute "mathvariant" attr $ unode "mtext" $ toUnicode a s
trailingSp = not (null s) && last s `elem` " \t"
attr = case a of
TextNormal -> "normal"
TextBold -> "bold"
TextItalic -> "italic"
TextMonospace -> "monospace"
TextSansSerif -> "sans-serif"
TextDoubleStruck -> "double-struck"
TextScript -> "script"
TextFraktur -> "fraktur"
TextBoldItalic -> "bold-italic"
TextBoldSansSerif -> "bold-sans-serif"
TextBoldSansSerifItalic -> "sans-serif-bold-italic"
TextBoldScript -> "bold-script"
TextBoldFraktur -> "bold-fraktur"
TextSansSerifItalic -> "sans-serif-italic"
makeArray :: [Alignment] -> [ArrayLine] -> Element
makeArray as ls = unode "mtable" $
map (unode "mtr" .
zipWith (\a -> setAlignment a . unode "mtd". map showExp) as') ls
where setAlignment AlignLeft = withAttribute "columnalign" "left"
setAlignment AlignRight = withAttribute "columnalign" "right"
setAlignment AlignCenter = withAttribute "columnalign" "center"
setAlignment AlignDefault = id
as' = as ++ cycle [AlignDefault]
withAttribute :: String -> String -> Element -> Element
withAttribute a = add_attr . Attr (unqual a)
accent :: String -> Element
accent = add_attr (Attr (unqual "accent") "true") .
unode "mo"
handleDownup :: DisplayType -> Exp -> Exp
handleDownup DisplayInline (EDown x y) = ESub x y
handleDownup DisplayBlock (EDown x y) = EUnder x y
handleDownup DisplayInline (EUp x y) = ESuper x y
handleDownup DisplayBlock (EUp x y) = EOver x y
handleDownup DisplayInline (EDownup x y z) = ESubsup x y z
handleDownup DisplayBlock (EDownup x y z) = EUnderover x y z
handleDownup _ x = x
showExp :: Exp -> Element
showExp e =
case e of
ENumber x -> unode "mn" x
EGrouped [x] -> showExp x
EGrouped xs -> mrow $ map showExp xs
EDelimited start end xs -> mrow $
[ makeStretchy (unode "mo" start) | not (null start) ] ++
map showExp xs ++
[ makeStretchy (unode "mo" end) | not (null end) ]
EIdentifier x -> unode "mi" x
EMathOperator x -> unode "mi" x
ESymbol Accent x -> accent x
EStretchy (ESymbol Open x) -> makeStretchy $ unode "mo" x
EStretchy (ESymbol Close x) -> makeStretchy $ unode "mo" x
ESymbol Open x -> withAttribute "stretchy" "false" $ unode "mo" x
ESymbol Close x -> withAttribute "stretchy" "false" $ unode "mo" x
ESymbol _ x -> unode "mo" x
ESpace x -> spaceWidth x
EBinary c x y -> showBinary c x y
ESub x y -> unode "msub" $ map showExp [x, y]
ESuper x y -> unode "msup" $ map showExp [x, y]
ESubsup x y z -> unode "msubsup" $ map showExp [x, y, z]
EUnder x y -> unode "munder" $ map showExp [x, y]
EOver x y -> unode "mover" $ map showExp [x, y]
EUnderover x y z -> unode "munderover" $ map showExp [x, y, z]
EUnary c x -> showUnary c x
EStretchy x -> makeStretchy $ showExp x
EScaled s x -> makeScaled s $ showExp x
EArray as ls -> makeArray as ls
EText a s -> makeText a s
x -> error $ "showExp encountered " ++ show x
-- note: EUp, EDown, EDownup should be removed by handleDownup
|
