--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM 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.
+ *
+ * HELM 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 HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(**************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* Andrea Asperti <asperti@cs.unibo.it> *)
+(* 16/62003 *)
+(* *)
+(**************************************************************************)
+
+(* $Id$ *)
+
+type 'a mpres =
+ Mi of attr * string
+ | Mn of attr * string
+ | Mo of attr * string
+ | Mtext of attr * string
+ | Mspace of attr
+ | Ms of attr * string
+ | Mgliph of attr * string
+ | Mrow of attr * 'a mpres list
+ | Mfrac of attr * 'a mpres * 'a mpres
+ | Msqrt of attr * 'a mpres
+ | Mroot of attr * 'a mpres * 'a mpres
+ | Mstyle of attr * 'a mpres
+ | Merror of attr * 'a mpres
+ | Mpadded of attr * 'a mpres
+ | Mphantom of attr * 'a mpres
+ | Mfenced of attr * 'a mpres list
+ | Menclose of attr * 'a mpres
+ | Msub of attr * 'a mpres * 'a mpres
+ | Msup of attr * 'a mpres * 'a mpres
+ | Msubsup of attr * 'a mpres * 'a mpres *'a mpres
+ | Munder of attr * 'a mpres * 'a mpres
+ | Mover of attr * 'a mpres * 'a mpres
+ | Munderover of attr * 'a mpres * 'a mpres *'a mpres
+(* | Multiscripts of ??? NOT IMPLEMEMENTED *)
+ | Mtable of attr * 'a row list
+ | Maction of attr * 'a mpres list
+ | Mobject of attr * 'a
+and 'a row = Mtr of attr * 'a mtd list
+and 'a mtd = Mtd of attr * 'a mpres
+and attr = (string option * string * string) list
+;;
+
+let smallskip = Mspace([None,"width","0.5em"]);;
+let indentation = Mspace([None,"width","1em"]);;
+
+let indented elem =
+ Mrow([],[indentation;elem]);;
+
+let standard_tbl_attr =
+ [None,"align","baseline 1";None,"equalrows","false";None,"columnalign","left"]
+;;
+
+let two_rows_table attr a b =
+ Mtable(attr@standard_tbl_attr,
+ [Mtr([],[Mtd([],a)]);
+ Mtr([],[Mtd([],b)])]);;
+
+let two_rows_table_with_brackets attr a b op =
+ (* only the open bracket is added; the closed bracket must be in b *)
+ Mtable(attr@standard_tbl_attr,
+ [Mtr([],[Mtd([],Mrow([],[Mtext([],"(");a]))]);
+ Mtr([],[Mtd([],Mrow([],[indentation;op;b]))])]);;
+
+let two_rows_table_without_brackets attr a b op =
+ Mtable(attr@standard_tbl_attr,
+ [Mtr([],[Mtd([],a)]);
+ Mtr([],[Mtd([],Mrow([],[indentation;op;b]))])]);;
+
+let row_with_brackets attr a b op =
+ (* by analogy with two_rows_table_with_brackets we only add the
+ open brackets *)
+ Mrow(attr,[Mtext([],"(");a;op;b;Mtext([],")")])
+
+let row_without_brackets attr a b op =
+ Mrow(attr,[a;op;b])
+
+(* MathML prefix *)
+let prefix = "m";;
+
+let print_mpres obj_printer mpres =
+ let module X = Xml in
+ let rec aux =
+ function
+ Mi (attr,s) -> X.xml_nempty ~prefix "mi" attr (X.xml_cdata s)
+ | Mn (attr,s) -> X.xml_nempty ~prefix "mn" attr (X.xml_cdata s)
+ | Mo (attr,s) ->
+ let s =
+ let len = String.length s in
+ if len > 1 && s.[0] = '\\'
+ then String.sub s 1 (len - 1)
+ else s
+ in
+ X.xml_nempty ~prefix "mo" attr (X.xml_cdata s)
+ | Mtext (attr,s) -> X.xml_nempty ~prefix "mtext" attr (X.xml_cdata s)
+ | Mspace attr -> X.xml_empty ~prefix "mspace" attr
+ | Ms (attr,s) -> X.xml_nempty ~prefix "ms" attr (X.xml_cdata s)
+ | Mgliph (attr,s) -> X.xml_nempty ~prefix "mgliph" attr (X.xml_cdata s)
+ (* General Layout Schemata *)
+ | Mrow (attr,l) ->
+ X.xml_nempty ~prefix "mrow" attr
+ [< (List.fold_right (fun x i -> [< (aux x) ; i >]) l [<>])
+ >]
+ | Mfrac (attr,m1,m2) ->
+ X.xml_nempty ~prefix "mfrac" attr [< aux m1; aux m2 >]
+ | Msqrt (attr,m) ->
+ X.xml_nempty ~prefix "msqrt" attr [< aux m >]
+ | Mroot (attr,m1,m2) ->
+ X.xml_nempty ~prefix "mroot" attr [< aux m1; aux m2 >]
+ | Mstyle (attr,m) -> X.xml_nempty ~prefix "mstyle" attr [< aux m >]
+ | Merror (attr,m) -> X.xml_nempty ~prefix "merror" attr [< aux m >]
+ | Mpadded (attr,m) -> X.xml_nempty ~prefix "mpadded" attr [< aux m >]
+ | Mphantom (attr,m) -> X.xml_nempty ~prefix "mphantom" attr [< aux m >]
+ | Mfenced (attr,l) ->
+ X.xml_nempty ~prefix "mfenced" attr
+ [< (List.fold_right (fun x i -> [< (aux x) ; i >]) l [<>])
+ >]
+ | Menclose (attr,m) -> X.xml_nempty ~prefix "menclose" attr [< aux m >]
+ (* Script and Limit Schemata *)
+ | Msub (attr,m1,m2) ->
+ X.xml_nempty ~prefix "msub" attr [< aux m1; aux m2 >]
+ | Msup (attr,m1,m2) ->
+ X.xml_nempty ~prefix "msup" attr [< aux m1; aux m2 >]
+ | Msubsup (attr,m1,m2,m3) ->
+ X.xml_nempty ~prefix "msubsup" attr [< aux m1; aux m2; aux m3 >]
+ | Munder (attr,m1,m2) ->
+ X.xml_nempty ~prefix "munder" attr [< aux m1; aux m2 >]
+ | Mover (attr,m1,m2) ->
+ X.xml_nempty ~prefix "mover" attr [< aux m1; aux m2 >]
+ | Munderover (attr,m1,m2,m3) ->
+ X.xml_nempty ~prefix "munderover" attr [< aux m1; aux m2; aux m3 >]
+ (* | Multiscripts of ??? NOT IMPLEMEMENTED *)
+ (* Tables and Matrices *)
+ | Mtable (attr, rl) ->
+ X.xml_nempty ~prefix "mtable" attr
+ [< (List.fold_right (fun x i -> [< (aux_mrow x) ; i >]) rl [<>]) >]
+ (* Enlivening Expressions *)
+ | Maction (attr, l) ->
+ X.xml_nempty ~prefix "maction" attr
+ [< (List.fold_right (fun x i -> [< (aux x) ; i >]) l [<>]) >]
+ | Mobject (attr, obj) ->
+ let box_stream = obj_printer obj in
+ X.xml_nempty ~prefix "semantics" attr
+ [< X.xml_nempty ~prefix "annotation-xml" [None, "encoding", "BoxML"]
+ box_stream >]
+
+ and aux_mrow =
+ let module X = Xml in
+ function
+ Mtr (attr, l) ->
+ X.xml_nempty ~prefix "mtr" attr
+ [< (List.fold_right (fun x i -> [< (aux_mtd x) ; i >]) l [<>])
+ >]
+ and aux_mtd =
+ let module X = Xml in
+ function
+ Mtd (attr,m) -> X.xml_nempty ~prefix "mtd" attr
+ [< (aux m) ;
+ X.xml_nempty ~prefix "mphantom" []
+ (X.xml_nempty ~prefix "mtext" [] (X.xml_cdata "(")) >]
+ in
+ aux mpres
+;;
+
+let document_of_mpres pres =
+ [< Xml.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
+ Xml.xml_cdata "\n";
+ Xml.xml_nempty ~prefix "math"
+ [Some "xmlns","m","http://www.w3.org/1998/Math/MathML" ;
+ Some "xmlns","helm","http://www.cs.unibo.it/helm" ;
+ Some "xmlns","xlink","http://www.w3.org/1999/xlink"
+ ] (Xml.xml_nempty ~prefix "mstyle" [None, "mathvariant", "normal"; None,
+ "rowspacing", "0.6ex"] (print_mpres (fun _ -> assert false) pres))
+ >]
+
+let get_attr = function
+ | Maction (attr, _)
+ | Menclose (attr, _)
+ | Merror (attr, _)
+ | Mfenced (attr, _)
+ | Mfrac (attr, _, _)
+ | Mgliph (attr, _)
+ | Mi (attr, _)
+ | Mn (attr, _)
+ | Mo (attr, _)
+ | Mobject (attr, _)
+ | Mover (attr, _, _)
+ | Mpadded (attr, _)
+ | Mphantom (attr, _)
+ | Mroot (attr, _, _)
+ | Mrow (attr, _)
+ | Ms (attr, _)
+ | Mspace attr
+ | Msqrt (attr, _)
+ | Mstyle (attr, _)
+ | Msub (attr, _, _)
+ | Msubsup (attr, _, _, _)
+ | Msup (attr, _, _)
+ | Mtable (attr, _)
+ | Mtext (attr, _)
+ | Munder (attr, _, _)
+ | Munderover (attr, _, _, _) ->
+ attr
+
+let set_attr attr = function
+ | Maction (_, x) -> Maction (attr, x)
+ | Menclose (_, x) -> Menclose (attr, x)
+ | Merror (_, x) -> Merror (attr, x)
+ | Mfenced (_, x) -> Mfenced (attr, x)
+ | Mfrac (_, x, y) -> Mfrac (attr, x, y)
+ | Mgliph (_, x) -> Mgliph (attr, x)
+ | Mi (_, x) -> Mi (attr, x)
+ | Mn (_, x) -> Mn (attr, x)
+ | Mo (_, x) -> Mo (attr, x)
+ | Mobject (_, x) -> Mobject (attr, x)
+ | Mover (_, x, y) -> Mover (attr, x, y)
+ | Mpadded (_, x) -> Mpadded (attr, x)
+ | Mphantom (_, x) -> Mphantom (attr, x)
+ | Mroot (_, x, y) -> Mroot (attr, x, y)
+ | Mrow (_, x) -> Mrow (attr, x)
+ | Ms (_, x) -> Ms (attr, x)
+ | Mspace _ -> Mspace attr
+ | Msqrt (_, x) -> Msqrt (attr, x)
+ | Mstyle (_, x) -> Mstyle (attr, x)
+ | Msub (_, x, y) -> Msub (attr, x, y)
+ | Msubsup (_, x, y, z) -> Msubsup (attr, x, y, z)
+ | Msup (_, x, y) -> Msup (attr, x, y)
+ | Mtable (_, x) -> Mtable (attr, x)
+ | Mtext (_, x) -> Mtext (attr, x)
+ | Munder (_, x, y) -> Munder (attr, x, y)
+ | Munderover (_, x, y, z) -> Munderover (attr, x, y, z)
+
projects / helm.git / blobdiff