(* 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                                   *)
(*                                                                        *)
(**************************************************************************)

type 
  mpres = 
  (* token elements *)
    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
  (* General Layout Schemata *)
  | Mrow of attr * mpres list
  | Mfrac of attr * mpres * mpres
  | Msqrt of attr * mpres
  | Mroot of attr * mpres * mpres
  | Mstyle of attr * mpres
  | Merror of attr * mpres
  | Mpadded of attr * mpres
  | Mphantom of attr * mpres
  | Mfenced of attr * mpres list
  | Menclose of attr * mpres
  (* Script and Limit Schemata *)
  | Msub of attr * mpres * mpres
  | Msup of attr * mpres * mpres
  | Msubsup of attr * mpres * mpres *mpres 
  | Munder of attr * mpres * mpres
  | Mover of attr * mpres * mpres
  | Munderover of attr * mpres * mpres *mpres 
(* | Multiscripts of ???  NOT IMPLEMEMENTED *)
  (* Tables and Matrices *)
  | Mtable of attr * row list
  (* Enlivening Expressions *)
  | Maction of attr * mpres list

and row = Mtr of attr * mtd list

and mtd = Mtd of attr * mpres

and attr = (string option * string * string) list
;;

let smallskip = Mspace([None,"width","0.1cm"]);;
let indentation = Mspace([None,"width","0.3cm"]);;

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])

let row_without_brackets attr a b op =
  Mrow(attr,[a;op;b])

(* MathML prefix *)
let prefix = "m";;
 
let rec print_mpres =
 let module X = Xml in
  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) -> 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 -> [< (print_mpres x) ; i >]) l [<>])
          >]
  | Mfrac (attr,m1,m2) ->
       X.xml_nempty ~prefix "mfrac" attr 
         [< print_mpres m1;
            print_mpres m2
         >]
  | Msqrt (attr,m) ->
       X.xml_nempty ~prefix "msqrt" attr [< print_mpres m >]
  | Mroot  (attr,m1,m2) ->
       X.xml_nempty ~prefix "mroot" attr 
         [< print_mpres m1;
            print_mpres m2
         >]
  | Mstyle (attr,m) ->
       X.xml_nempty ~prefix "mstyle" attr [< print_mpres m >]
  | Merror (attr,m) ->
       X.xml_nempty ~prefix "merror" attr [< print_mpres m >]
  | Mpadded (attr,m) ->
       X.xml_nempty ~prefix "mpadded" attr [< print_mpres m >]
  | Mphantom (attr,m) ->
       X.xml_nempty ~prefix "mphantom" attr [< print_mpres m >]
  | Mfenced (attr,l) ->
      X.xml_nempty ~prefix "mfenced" attr 
         [< (List.fold_right (fun x i -> [< (print_mpres x) ; i >]) l [<>])
          >]
  | Menclose (attr,m) ->
      X.xml_nempty ~prefix "menclose" attr [< print_mpres m >]
  (* Script and Limit Schemata *)
  | Msub (attr,m1,m2) ->
      X.xml_nempty ~prefix "msub" attr 
         [< print_mpres m1;
            print_mpres m2
         >]
  | Msup (attr,m1,m2) ->
      X.xml_nempty ~prefix "msup" attr 
         [< print_mpres m1;
            print_mpres m2
         >]
  | Msubsup (attr,m1,m2,m3) ->
      X.xml_nempty ~prefix "msubsup" attr 
         [< print_mpres m1;
            print_mpres m2;
            print_mpres m3
         >]
  | Munder (attr,m1,m2) ->
      X.xml_nempty ~prefix "munder" attr 
         [< print_mpres m1;
            print_mpres m2
         >]
  | Mover (attr,m1,m2) ->
      X.xml_nempty ~prefix "mover" attr 
         [< print_mpres m1;
            print_mpres m2
         >]
  | Munderover (attr,m1,m2,m3) ->
      X.xml_nempty ~prefix "munderover" attr 
         [< print_mpres m1;
            print_mpres m2;
            print_mpres m3
         >]
(* | Multiscripts of ???  NOT IMPLEMEMENTED *)
  (* Tables and Matrices *)
  | Mtable (attr, rl) ->
      X.xml_nempty ~prefix "mtable" attr 
         [< (List.fold_right (fun x i -> [< (print_mrow x) ; i >]) rl [<>])
          >]
  (* Enlivening Expressions *)
  | Maction (attr, l) ->
      X.xml_nempty ~prefix "maction" attr 
         [< (List.fold_right (fun x i -> [< (print_mpres x) ; i >]) l [<>])
          >]

and print_mrow =
 let module X = Xml in
 function 
    Mtr (attr, l) -> 
      X.xml_nempty ~prefix "mtr" attr 
         [< (List.fold_right (fun x i -> [< (print_mtd x) ; i >]) l [<>])
          >]

and print_mtd =
  let module X = Xml in
  function 
     Mtd (attr,m) -> X.xml_nempty ~prefix "mtd" attr (print_mpres m)
;;

let print_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"
     ] (print_mpres pres)
 >]