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) -> 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 *)
 117     | Mrow (attr,l) ->
 118         X.xml_nempty ~prefix "mrow" attr
 119            [< (List.fold_right (fun x i -> [< (aux x) ; i >]) l [<>])
 120             >]
 121     | Mfrac (attr,m1,m2) ->
 122          X.xml_nempty ~prefix "mfrac" attr [< aux m1; aux m2 >]
 123     | Msqrt (attr,m) ->
 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 [<>])
 134             >]
 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"]
 162               box_stream >]
 163
 164   and aux_mrow =
 165    let module X = Xml in
 166    function
 167       Mtr (attr, l) ->
 168         X.xml_nempty ~prefix "mtr" attr
 169            [< (List.fold_right (fun x i -> [< (aux_mtd x) ; i >]) l [<>])
 170             >]
 171   and aux_mtd =
 172     let module X = Xml in
 173     function
 174        Mtd (attr,m) -> X.xml_nempty ~prefix "mtd" attr
 175         [< (aux m) ;
 176             X.xml_nempty ~prefix "mphantom" []
 177               (X.xml_nempty ~prefix "mtext" [] (X.xml_cdata "(")) >]
 178   in
 179   aux mpres
 180 ;;
 181
 182 let document_of_mpres pres =
 183  [< Xml.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
 184     Xml.xml_cdata "\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))
 191  >]
 192