helm/ocaml/cic_notation/mpresentation.ml

   1 (* Copyright (C) 2000, HELM Team.
   2  *
   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.
   6  *
   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.
  11  *
  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.
  16  *
  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,
  20  * MA  02111-1307, USA.
  21  *
  22  * For details, see the HELM World-Wide-Web page,
  23  * http://cs.unibo.it/helm/.
  24  *)
  25
  26 (**************************************************************************)
  27 (*                                                                        *)
  28 (*                           PROJECT HELM                                 *)
  29 (*                                                                        *)
  30 (*                Andrea Asperti <asperti@cs.unibo.it>                    *)
  31 (*                             16/62003                                   *)
  32 (*                                                                        *)
  33 (**************************************************************************)
  34
  35 type 'a mpres =
  36     Mi of attr * string
  37   | Mn of attr * string
  38   | Mo of attr * string
  39   | Mtext of attr * string
  40   | Mspace of attr
  41   | Ms 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
  66 ;;
  67
  68 let smallskip = Mspace([None,"width","0.5em"]);;
  69 let indentation = Mspace([None,"width","1em"]);;
  70
  71 let indented elem =
  72   Mrow([],[indentation;elem]);;
  73
  74 let standard_tbl_attr =
  75   [None,"align","baseline 1";None,"equalrows","false";None,"columnalign","left"]
  76 ;;
  77
  78 let two_rows_table attr a b =
  79   Mtable(attr@standard_tbl_attr,
  80     [Mtr([],[Mtd([],a)]);
  81      Mtr([],[Mtd([],b)])]);;
  82
  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]))])]);;
  88
  89 let two_rows_table_without_brackets attr a b op =
  90   Mtable(attr@standard_tbl_attr,
  91     [Mtr([],[Mtd([],a)]);
  92      Mtr([],[Mtd([],Mrow([],[indentation;op;b]))])]);;
  93
  94 let row_with_brackets attr a b op =
  95   (* by analogy with two_rows_table_with_brackets we only add the
  96      open brackets *)
  97   Mrow(attr,[Mtext([],"(");a;op;b;Mtext([],")")])
  98
  99 let row_without_brackets attr a b op =
 100   Mrow(attr,[a;op;b])
 101
 102 (* MathML prefix *)
 103 let prefix = "m";;
 104
 105 let print_mpres obj_printer mpres =
 106  let module X = Xml in
 107  let rec aux =
 108     function
 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) ->
 112         let s =
 113           let len = String.length s in
 114           if len > 1 && s.[0] = '\\'
 115           then String.sub s 1 (len - 1)
 116           else s
 117         in
 118         X.xml_nempty ~prefix "mo" attr (X.xml_cdata s)
 119     | Mtext (attr,s) -> X.xml_nempty ~prefix "mtext" attr (X.xml_cdata s)
 120     | Mspace attr -> X.xml_empty ~prefix "mspace" attr
 121     | Ms (attr,s) -> X.xml_nempty ~prefix "ms" attr (X.xml_cdata s)
 122     | Mgliph (attr,s) -> X.xml_nempty ~prefix "mgliph" attr (X.xml_cdata s)
 123     (* General Layout Schemata *)
 124     | Mrow (attr,l) ->
 125         X.xml_nempty ~prefix "mrow" attr
 126            [< (List.fold_right (fun x i -> [< (aux x) ; i >]) l [<>])
 127             >]
 128     | Mfrac (attr,m1,m2) ->
 129          X.xml_nempty ~prefix "mfrac" attr [< aux m1; aux m2 >]
 130     | Msqrt (attr,m) ->
 131          X.xml_nempty ~prefix "msqrt" attr [< aux m >]
 132     | Mroot  (attr,m1,m2) ->
 133          X.xml_nempty ~prefix "mroot" attr [< aux m1; aux m2 >]
 134     | Mstyle (attr,m) -> X.xml_nempty ~prefix "mstyle" attr [< aux m >]
 135     | Merror (attr,m) -> X.xml_nempty ~prefix "merror" attr [< aux m >]
 136     | Mpadded (attr,m) -> X.xml_nempty ~prefix "mpadded" attr [< aux m >]
 137     | Mphantom (attr,m) -> X.xml_nempty ~prefix "mphantom" attr [< aux m >]
 138     | Mfenced (attr,l) ->
 139         X.xml_nempty ~prefix "mfenced" attr
 140            [< (List.fold_right (fun x i -> [< (aux x) ; i >]) l [<>])
 141             >]
 142     | Menclose (attr,m) -> X.xml_nempty ~prefix "menclose" attr [< aux m >]
 143     (* Script and Limit Schemata *)
 144     | Msub (attr,m1,m2) ->
 145         X.xml_nempty ~prefix "msub" attr [< aux m1; aux m2 >]
 146     | Msup (attr,m1,m2) ->
 147         X.xml_nempty ~prefix "msup" attr [< aux m1; aux m2 >]
 148     | Msubsup (attr,m1,m2,m3) ->
 149         X.xml_nempty ~prefix "msubsup" attr [< aux m1; aux m2; aux m3 >]
 150     | Munder (attr,m1,m2) ->
 151         X.xml_nempty ~prefix "munder" attr [< aux m1; aux m2 >]
 152     | Mover (attr,m1,m2) ->
 153         X.xml_nempty ~prefix "mover" attr [< aux m1; aux m2 >]
 154     | Munderover (attr,m1,m2,m3) ->
 155         X.xml_nempty ~prefix "munderover" attr [< aux m1; aux m2; aux m3 >]
 156   (* | Multiscripts of ???  NOT IMPLEMEMENTED *)
 157     (* Tables and Matrices *)
 158     | Mtable (attr, rl) ->
 159         X.xml_nempty ~prefix "mtable" attr
 160            [< (List.fold_right (fun x i -> [< (aux_mrow x) ; i >]) rl [<>]) >]
 161     (* Enlivening Expressions *)
 162     | Maction (attr, l) ->
 163         X.xml_nempty ~prefix "maction" attr
 164           [< (List.fold_right (fun x i -> [< (aux x) ; i >]) l [<>]) >]
 165     | Mobject (attr, obj) ->
 166         let box_stream = obj_printer obj in
 167         X.xml_nempty ~prefix "semantics" attr
 168           [< X.xml_nempty ~prefix "annotation-xml" [None, "encoding", "BoxML"]
 169               box_stream >]
 170
 171   and aux_mrow =
 172    let module X = Xml in
 173    function
 174       Mtr (attr, l) ->
 175         X.xml_nempty ~prefix "mtr" attr
 176            [< (List.fold_right (fun x i -> [< (aux_mtd x) ; i >]) l [<>])
 177             >]
 178   and aux_mtd =
 179     let module X = Xml in
 180     function
 181        Mtd (attr,m) -> X.xml_nempty ~prefix "mtd" attr
 182         [< (aux m) ;
 183             X.xml_nempty ~prefix "mphantom" []
 184               (X.xml_nempty ~prefix "mtext" [] (X.xml_cdata "(")) >]
 185   in
 186   aux mpres
 187 ;;
 188
 189 let document_of_mpres pres =
 190  [< Xml.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
 191     Xml.xml_cdata "\n";
 192     Xml.xml_nempty ~prefix "math"
 193      [Some "xmlns","m","http://www.w3.org/1998/Math/MathML" ;
 194       Some "xmlns","helm","http://www.cs.unibo.it/helm" ;
 195       Some "xmlns","xlink","http://www.w3.org/1999/xlink"
 196      ] (Xml.xml_nempty ~prefix "mstyle" [None, "mathvariant", "normal"; None,
 197      "rowspacing", "0.6ex"] (print_mpres (fun _ -> assert false) pres))
 198  >]
 199
 200 let get_attr = function
 201   | Maction (attr, _)
 202   | Menclose (attr, _)
 203   | Merror (attr, _)
 204   | Mfenced (attr, _)
 205   | Mfrac (attr, _, _)
 206   | Mgliph (attr, _)
 207   | Mi (attr, _)
 208   | Mn (attr, _)
 209   | Mo (attr, _)
 210   | Mobject (attr, _)
 211   | Mover (attr, _, _)
 212   | Mpadded (attr, _)
 213   | Mphantom (attr, _)
 214   | Mroot (attr, _, _)
 215   | Mrow (attr, _)
 216   | Ms (attr, _)
 217   | Mspace attr
 218   | Msqrt (attr, _)
 219   | Mstyle (attr, _)
 220   | Msub (attr, _, _)
 221   | Msubsup (attr, _, _, _)
 222   | Msup (attr, _, _)
 223   | Mtable (attr, _)
 224   | Mtext (attr, _)
 225   | Munder (attr, _, _)
 226   | Munderover (attr, _, _, _) ->
 227       attr
 228
 229 let set_attr attr = function
 230   | Maction (_, x) -> Maction (attr, x)
 231   | Menclose (_, x) -> Menclose (attr, x)
 232   | Merror (_, x) -> Merror (attr, x)
 233   | Mfenced (_, x) -> Mfenced (attr, x)
 234   | Mfrac (_, x, y) -> Mfrac (attr, x, y)
 235   | Mgliph (_, x) -> Mgliph (attr, x)
 236   | Mi (_, x) -> Mi (attr, x)
 237   | Mn (_, x) -> Mn (attr, x)
 238   | Mo (_, x) -> Mo (attr, x)
 239   | Mobject (_, x) -> Mobject (attr, x)
 240   | Mover (_, x, y) -> Mover (attr, x, y)
 241   | Mpadded (_, x) -> Mpadded (attr, x)
 242   | Mphantom (_, x) -> Mphantom (attr, x)
 243   | Mroot (_, x, y) -> Mroot (attr, x, y)
 244   | Mrow (_, x) -> Mrow (attr, x)
 245   | Ms (_, x) -> Ms (attr, x)
 246   | Mspace _ -> Mspace attr
 247   | Msqrt (_, x) -> Msqrt (attr, x)
 248   | Mstyle (_, x) -> Mstyle (attr, x)
 249   | Msub (_, x, y) -> Msub (attr, x, y)
 250   | Msubsup (_, x, y, z) -> Msubsup (attr, x, y, z)
 251   | Msup (_, x, y) -> Msup (attr, x, y)
 252   | Mtable (_, x) -> Mtable (attr, x)
 253   | Mtext (_, x) -> Mtext (attr, x)
 254   | Munder (_, x, y) -> Munder (attr, x, y)
 255   | Munderover (_, x, y, z) -> Munderover (attr, x, y, z)
 256