1 (* Copyright (C) 2000, HELM Team.
3 * This file is part of HELM, an Hypertextual, Electronic
4 * Library of Mathematics, developed at the Computer Science
5 * Department, University of Bologna, Italy.
7 * HELM is free software; you can redistribute it and/or
8 * modify it under the terms of the GNU General Public License
9 * as published by the Free Software Foundation; either version 2
10 * of the License, or (at your option) any later version.
12 * HELM is distributed in the hope that it will be useful,
13 * but WITHOUT ANY WARRANTY; without even the implied warranty of
14 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 * GNU General Public License for more details.
17 * You should have received a copy of the GNU General Public License
18 * along with HELM; if not, write to the Free Software
19 * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
22 * For details, see the HELM World-Wide-Web page,
23 * http://cs.unibo.it/helm/.
26 (**************************************************************************)
30 (* Andrea Asperti <asperti@cs.unibo.it> *)
33 (**************************************************************************)
39 | Mtext of attr * string
42 | Mgliph of attr * string
43 | Mrow of attr * 'a mpres list
44 | Mfrac of attr * 'a mpres * 'a mpres
45 | Msqrt of attr * 'a mpres
46 | Mroot of attr * 'a mpres * 'a mpres
47 | Mstyle of attr * 'a mpres
48 | Merror of attr * 'a mpres
49 | Mpadded of attr * 'a mpres
50 | Mphantom of attr * 'a mpres
51 | Mfenced of attr * 'a mpres list
52 | Menclose of attr * 'a mpres
53 | Msub of attr * 'a mpres * 'a mpres
54 | Msup of attr * 'a mpres * 'a mpres
55 | Msubsup of attr * 'a mpres * 'a mpres *'a mpres
56 | Munder of attr * 'a mpres * 'a mpres
57 | Mover of attr * 'a mpres * 'a mpres
58 | Munderover of attr * 'a mpres * 'a mpres *'a mpres
59 (* | Multiscripts of ??? NOT IMPLEMEMENTED *)
60 | Mtable of attr * 'a row list
61 | Maction of attr * 'a mpres list
62 | Mobject of attr * 'a
63 and 'a row = Mtr of attr * 'a mtd list
64 and 'a mtd = Mtd of attr * 'a mpres
65 and attr = (string option * string * string) list
68 let smallskip = Mspace([None,"width","0.5em"]);;
69 let indentation = Mspace([None,"width","1em"]);;
72 Mrow([],[indentation;elem]);;
74 let standard_tbl_attr =
75 [None,"align","baseline 1";None,"equalrows","false";None,"columnalign","left"]
78 let two_rows_table attr a b =
79 Mtable(attr@standard_tbl_attr,
81 Mtr([],[Mtd([],b)])]);;
83 let two_rows_table_with_brackets attr a b op =
84 (* only the open bracket is added; the closed bracket must be in b *)
85 Mtable(attr@standard_tbl_attr,
86 [Mtr([],[Mtd([],Mrow([],[Mtext([],"(");a]))]);
87 Mtr([],[Mtd([],Mrow([],[indentation;op;b]))])]);;
89 let two_rows_table_without_brackets attr a b op =
90 Mtable(attr@standard_tbl_attr,
92 Mtr([],[Mtd([],Mrow([],[indentation;op;b]))])]);;
94 let row_with_brackets attr a b op =
95 (* by analogy with two_rows_table_with_brackets we only add the
97 Mrow(attr,[Mtext([],"(");a;op;b;Mtext([],")")])
99 let row_without_brackets attr a b op =
105 let print_mpres obj_printer mpres =
106 let module X = Xml in
109 Mi (attr,s) -> X.xml_nempty ~prefix "mi" attr (X.xml_cdata s)
110 | Mn (attr,s) -> X.xml_nempty ~prefix "mn" attr (X.xml_cdata s)
111 | Mo (attr,s) -> X.xml_nempty ~prefix "mo" attr (X.xml_cdata s)
112 | Mtext (attr,s) -> X.xml_nempty ~prefix "mtext" attr (X.xml_cdata s)
113 | Mspace attr -> X.xml_empty ~prefix "mspace" attr
114 | Ms (attr,s) -> X.xml_nempty ~prefix "ms" attr (X.xml_cdata s)
115 | Mgliph (attr,s) -> X.xml_nempty ~prefix "mgliph" attr (X.xml_cdata s)
116 (* General Layout Schemata *)
118 X.xml_nempty ~prefix "mrow" attr
119 [< (List.fold_right (fun x i -> [< (aux x) ; i >]) l [<>])
121 | Mfrac (attr,m1,m2) ->
122 X.xml_nempty ~prefix "mfrac" attr [< aux m1; aux m2 >]
124 X.xml_nempty ~prefix "msqrt" attr [< aux m >]
125 | Mroot (attr,m1,m2) ->
126 X.xml_nempty ~prefix "mroot" attr [< aux m1; aux m2 >]
127 | Mstyle (attr,m) -> X.xml_nempty ~prefix "mstyle" attr [< aux m >]
128 | Merror (attr,m) -> X.xml_nempty ~prefix "merror" attr [< aux m >]
129 | Mpadded (attr,m) -> X.xml_nempty ~prefix "mpadded" attr [< aux m >]
130 | Mphantom (attr,m) -> X.xml_nempty ~prefix "mphantom" attr [< aux m >]
131 | Mfenced (attr,l) ->
132 X.xml_nempty ~prefix "mfenced" attr
133 [< (List.fold_right (fun x i -> [< (aux x) ; i >]) l [<>])
135 | Menclose (attr,m) -> X.xml_nempty ~prefix "menclose" attr [< aux m >]
136 (* Script and Limit Schemata *)
137 | Msub (attr,m1,m2) ->
138 X.xml_nempty ~prefix "msub" attr [< aux m1; aux m2 >]
139 | Msup (attr,m1,m2) ->
140 X.xml_nempty ~prefix "msup" attr [< aux m1; aux m2 >]
141 | Msubsup (attr,m1,m2,m3) ->
142 X.xml_nempty ~prefix "msubsup" attr [< aux m1; aux m2; aux m3 >]
143 | Munder (attr,m1,m2) ->
144 X.xml_nempty ~prefix "munder" attr [< aux m1; aux m2 >]
145 | Mover (attr,m1,m2) ->
146 X.xml_nempty ~prefix "mover" attr [< aux m1; aux m2 >]
147 | Munderover (attr,m1,m2,m3) ->
148 X.xml_nempty ~prefix "munderover" attr [< aux m1; aux m2; aux m3 >]
149 (* | Multiscripts of ??? NOT IMPLEMEMENTED *)
150 (* Tables and Matrices *)
151 | Mtable (attr, rl) ->
152 X.xml_nempty ~prefix "mtable" attr
153 [< (List.fold_right (fun x i -> [< (aux_mrow x) ; i >]) rl [<>]) >]
154 (* Enlivening Expressions *)
155 | Maction (attr, l) ->
156 X.xml_nempty ~prefix "maction" attr
157 [< (List.fold_right (fun x i -> [< (aux x) ; i >]) l [<>]) >]
158 | Mobject (attr, obj) ->
159 let box_stream = obj_printer obj in
160 X.xml_nempty ~prefix "semantics" attr
161 [< X.xml_nempty ~prefix "annotation-xml" [None, "encoding", "BoxML"]
165 let module X = Xml in
168 X.xml_nempty ~prefix "mtr" attr
169 [< (List.fold_right (fun x i -> [< (aux_mtd x) ; i >]) l [<>])
172 let module X = Xml in
174 Mtd (attr,m) -> X.xml_nempty ~prefix "mtd" attr
176 X.xml_nempty ~prefix "mphantom" []
177 (X.xml_nempty ~prefix "mtext" [] (X.xml_cdata "(")) >]
182 let document_of_mpres pres =
183 [< Xml.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
185 Xml.xml_nempty ~prefix "math"
186 [Some "xmlns","m","http://www.w3.org/1998/Math/MathML" ;
187 Some "xmlns","helm","http://www.cs.unibo.it/helm" ;
188 Some "xmlns","xlink","http://www.w3.org/1999/xlink"
189 ] (Xml.xml_nempty ~prefix "mstyle" [None, "mathvariant", "normal"; None,
190 "rowspacing", "0.6ex"] (print_mpres (fun _ -> assert false) pres))
193 let get_attr = function
214 | Msubsup (attr, _, _, _)
218 | Munder (attr, _, _)
219 | Munderover (attr, _, _, _) ->
222 let set_attr attr = function
223 | Maction (_, x) -> Maction (attr, x)
224 | Menclose (_, x) -> Menclose (attr, x)
225 | Merror (_, x) -> Merror (attr, x)
226 | Mfenced (_, x) -> Mfenced (attr, x)
227 | Mfrac (_, x, y) -> Mfrac (attr, x, y)
228 | Mgliph (_, x) -> Mgliph (attr, x)
229 | Mi (_, x) -> Mi (attr, x)
230 | Mn (_, x) -> Mn (attr, x)
231 | Mo (_, x) -> Mo (attr, x)
232 | Mobject (_, x) -> Mobject (attr, x)
233 | Mover (_, x, y) -> Mover (attr, x, y)
234 | Mpadded (_, x) -> Mpadded (attr, x)
235 | Mphantom (_, x) -> Mphantom (attr, x)
236 | Mroot (_, x, y) -> Mroot (attr, x, y)
237 | Mrow (_, x) -> Mrow (attr, x)
238 | Ms (_, x) -> Ms (attr, x)
239 | Mspace _ -> Mspace attr
240 | Msqrt (_, x) -> Msqrt (attr, x)
241 | Mstyle (_, x) -> Mstyle (attr, x)
242 | Msub (_, x, y) -> Msub (attr, x, y)
243 | Msubsup (_, x, y, z) -> Msubsup (attr, x, y, z)
244 | Msup (_, x, y) -> Msup (attr, x, y)
245 | Mtable (_, x) -> Mtable (attr, x)
246 | Mtext (_, x) -> Mtext (attr, x)
247 | Munder (_, x, y) -> Munder (attr, x, y)
248 | Munderover (_, x, y, z) -> Munderover (attr, x, y, z)