scilab/modules/scicos/src/modelica_compiler/xMLCodeGeneration.ml

   1 (*
   2  *  Modelicac
   3  *
   4  *  Copyright (C) 2005 - 2007 Imagine S.A.
   5  *  For more information or commercial use please contact us at www.amesim.com
   6  *
   7  *  This program 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  *  This program 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 this program; if not, write to the Free Software
  19  *  Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
  20  *
  21  *)
  22
  23 type 'a tree = Leaf of (string * 'a) | Node of string * 'a tree list
  24
  25 (* function used to hide XML special characters *)
  26 let hide_spc s =
  27   let encoded_s = ref "" in
  28   let hide_special_character c = match c with
  29     | '<' -> encoded_s := !encoded_s ^ "&lt;"
  30     | '>' -> encoded_s := !encoded_s ^ "&gt;"
  31     | '&' -> encoded_s := !encoded_s ^ "&amp;"
  32     | '\'' -> encoded_s := !encoded_s ^ "&apos;"
  33     | '\"' -> encoded_s := !encoded_s ^ "&quot;"
  34     | _ -> encoded_s := !encoded_s ^ (String.make 1 c) in
  35   String.iter hide_special_character s;
  36   !encoded_s
  37
  38 let rec insert path x ts =
  39   let rec insert' s path' = function
  40     | [] -> [Node (s, insert path' x [])]
  41     | Node (s', ts'') :: ts' when s = s' -> Node (s', insert path' x ts'') :: ts'
  42     | t' :: ts' -> t' :: insert' s path' ts'
  43   in match path with
  44     | [s] -> Leaf (s, x) :: ts
  45     | s :: path' -> insert' s path' ts
  46     | [] -> assert false
  47
  48 let cut_on_dot s =
  49   let rec cut_on_dot' i =
  50     if i = String.length s then s, None
  51       else if s.[i] = '.' then String.sub s 0 i, Some (String.sub s (i + 1) (String.length s - i - 1))
  52       else cut_on_dot' (i + 1)
  53   in cut_on_dot' 0
  54
  55 let rec split name =
  56   let s, name_opt = cut_on_dot name in
  57   match name_opt with
  58     | None -> [s]
  59     | Some name' -> s :: split name'
  60
  61 type element =
  62   {
  63     kind: element_kind;
  64     id: string;
  65     comment: string;
  66     initial_value: SymbolicExpression.t option;
  67     output: bool
  68   }
  69
  70 and element_kind =
  71   | Input
  72   | Parameter
  73   | Variable
  74   | DiscreteVariable
  75
  76 let build_tree model =
  77   let bool_of_option = function
  78     | None -> false
  79     | Some _ -> true
  80   in
  81   let (_, ts) =
  82     Array.fold_left
  83       (fun (i, ts) s ->
  84         i + 1,
  85         insert
  86           (split s)
  87           {
  88             kind = Input;
  89             id = s;
  90             comment = "";
  91             initial_value = Some SymbolicExpression.zero;
  92             output = false
  93           }
  94           ts)
  95       (0, [])
  96       model.Optimization.inputs in
  97   let (_, ts) =
  98     Array.fold_left
  99       (fun (i, ts) par ->
 100         i + 1,
 101         insert
 102           (split par.Optimization.p_name)
 103           {
 104             kind = Parameter;
 105             id = par.Optimization.p_name;
 106             comment = par.Optimization.p_comment;
 107             initial_value = Some par.Optimization.value;
 108             output = false
 109           }
 110           ts)
 111       (0, ts)
 112       model.Optimization.parameters in
 113   let (_, ts) =
 114     Array.fold_left
 115       (fun (i, ts) var ->
 116         i + 1,
 117         insert
 118           (split var.Optimization.v_name)
 119           {
 120             kind = Variable;
 121             id = var.Optimization.v_name;
 122             comment = var.Optimization.v_comment;
 123             initial_value = var.Optimization.start_value;
 124             output = bool_of_option var.Optimization.output
 125           }
 126           ts)
 127       (0, ts)
 128       model.Optimization.variables in
 129   let (_, ts) =
 130     Array.fold_left
 131       (fun (i, ts) dvar ->
 132         i + 1,
 133         insert
 134           (split dvar.Optimization.d_v_name)
 135           {
 136             kind = DiscreteVariable;
 137             id = dvar.Optimization.d_v_name;
 138             comment = dvar.Optimization.d_v_comment;
 139             initial_value = dvar.Optimization.d_start_value;
 140             output = bool_of_option dvar.Optimization.d_output
 141           }
 142           ts)
 143       (0, ts)
 144       model.Optimization.discrete_variables in
 145   ts
 146
 147 let print_expression oc model expr =
 148   let add_parenthesis expr_option sub_expr =
 149     match expr_option with
 150     | None -> sub_expr
 151     | Some _ -> Printf.sprintf "(%s)" sub_expr in
 152   let rec string_of_expression expr_option sub_expr =
 153     let expr_option' = Some sub_expr in
 154     match SymbolicExpression.nature sub_expr with
 155     | SymbolicExpression.Addition [] -> "0"
 156     | SymbolicExpression.Addition exprs ->
 157         let exprs' = List.map (string_of_expression expr_option') exprs in
 158         add_parenthesis expr_option (String.concat " + " exprs')
 159     | SymbolicExpression.And [] -> "false"
 160     | SymbolicExpression.And (exprs) ->
 161         let s = List.map (string_of_expression expr_option') exprs in
 162         add_parenthesis expr_option (String.concat " and " s)
 163     | SymbolicExpression.ArcCosine expr ->
 164         let s = string_of_expression expr_option' expr in
 165         Printf.sprintf "acos(%s)" s
 166     | SymbolicExpression.ArcHyperbolicCosine expr ->
 167         let s = string_of_expression expr_option' expr in
 168         Printf.sprintf "acosh(%s)" s
 169     | SymbolicExpression.ArcHyperbolicSine expr ->
 170         let s = string_of_expression expr_option' expr in
 171         Printf.sprintf "asinh(%s)" s
 172     | SymbolicExpression.ArcHyperbolicTangent expr ->
 173         let s = string_of_expression expr_option' expr in
 174         Printf.sprintf "atanh(%s)" s
 175     | SymbolicExpression.ArcSine expr ->
 176         let s = string_of_expression expr_option' expr in
 177         Printf.sprintf "asin(%s)" s
 178     | SymbolicExpression.ArcTangent expr ->
 179         let s = string_of_expression expr_option' expr in
 180         Printf.sprintf "atan(%s)" s
 181     | SymbolicExpression.BlackBox (s, args) ->
 182         let args' = List.map (string_of_argument expr_option') args in
 183         let s' = String.concat ", " args' in
 184         Printf.sprintf "%s(%s)" s s'
 185     | SymbolicExpression.BooleanValue false -> Printf.sprintf "false"
 186     | SymbolicExpression.BooleanValue true -> Printf.sprintf "true"
 187     | SymbolicExpression.Constant s -> s
 188     | SymbolicExpression.Cosine expr ->
 189         let s = string_of_expression expr_option' expr in
 190         Printf.sprintf "cos(%s)" s
 191     | SymbolicExpression.Derivative (expr, Num.Int 1) ->
 192         let s = string_of_expression expr_option' expr in
 193         Printf.sprintf "der(%s)" s
 194     | SymbolicExpression.Derivative _ -> assert false
 195     | SymbolicExpression.DiscreteVariable i when i >= 0 ->
 196         Printf.sprintf "`%s`"
 197           model.Optimization.discrete_variables.(i).Optimization.d_v_name
 198     | SymbolicExpression.DiscreteVariable i ->
 199         Printf.sprintf "`%s`" model.Optimization.inputs.(-1 - i)
 200     | SymbolicExpression.Equality (expr, expr') ->
 201         let s =
 202           Printf.sprintf "%s == %s"
 203             (string_of_expression expr_option' expr)
 204             (string_of_expression expr_option' expr') in
 205         add_parenthesis expr_option s
 206     | SymbolicExpression.Exponential expr ->
 207         let s = string_of_expression expr_option' expr in
 208         Printf.sprintf "exp(%s)" s
 209     | SymbolicExpression.Floor expr ->
 210         let s = string_of_expression expr_option' expr in
 211         Printf.sprintf "floor(%s)" s
 212     | SymbolicExpression.Greater (expr, expr') ->
 213         let s =
 214           Printf.sprintf "%s > %s"
 215             (string_of_expression expr_option' expr)
 216             (string_of_expression expr_option' expr') in
 217         add_parenthesis expr_option s
 218     | SymbolicExpression.GreaterEqual (expr, expr') ->
 219         let s =
 220           Printf.sprintf "%s >= %s"
 221             (string_of_expression expr_option' expr)
 222             (string_of_expression expr_option' expr') in
 223         add_parenthesis expr_option s
 224     | SymbolicExpression.HyperbolicCosine expr ->
 225         let s = string_of_expression expr_option' expr in
 226         Printf.sprintf "cosh(%s)" s
 227     | SymbolicExpression.HyperbolicSine expr ->
 228         let s = string_of_expression expr_option' expr in
 229         Printf.sprintf "sinh(%s)" s
 230     | SymbolicExpression.HyperbolicTangent expr ->
 231         let s = string_of_expression expr_option' expr in
 232         Printf.sprintf "tanh(%s)" s
 233     | SymbolicExpression.If (expr, expr', expr'') ->
 234         let s =
 235           Printf.sprintf "if %s then %s else %s"
 236             (string_of_expression expr_option' expr)
 237             (string_of_expression expr_option' expr')
 238             (string_of_expression expr_option' expr'') in
 239         add_parenthesis expr_option s
 240     | SymbolicExpression.Integer i ->
 241         let s = Printf.sprintf "%ld" i in
 242         add_parenthesis expr_option s
 243     | SymbolicExpression.Logarithm expr ->
 244         let s = string_of_expression expr_option' expr in
 245         Printf.sprintf "log(%s)" s
 246     | SymbolicExpression.Multiplication [] -> "1"
 247     | SymbolicExpression.Multiplication exprs ->
 248         let exprs' = List.map (string_of_expression expr_option') exprs in
 249         let s = String.concat " * " exprs' in
 250         add_parenthesis expr_option (Printf.sprintf "%s" s)
 251     | SymbolicExpression.Not expr ->
 252         let s = string_of_expression expr_option' expr in
 253         add_parenthesis expr_option (Printf.sprintf "not %s" s)
 254     | SymbolicExpression.Number num ->
 255         let s = Printf.sprintf "%.16g" (Num.float_of_num num) in
 256         add_parenthesis expr_option s
 257     | SymbolicExpression.Or [] -> "true"
 258     | SymbolicExpression.Or [expr] ->
 259         string_of_expression expr_option' expr
 260     | SymbolicExpression.Or [expr; expr'] ->
 261         begin
 262           let nat = SymbolicExpression.nature expr
 263           and nat' = SymbolicExpression.nature expr' in
 264           match nat, nat' with
 265           | SymbolicExpression.Equality (expr1, expr2),
 266             SymbolicExpression.Greater (expr1', expr2') |
 267             SymbolicExpression.Greater (expr1', expr2'),
 268             SymbolicExpression.Equality (expr1, expr2)
 269             when expr1 == expr1' && expr2 == expr2' || expr1 == expr2' &&
 270               expr2 == expr1' ->
 271               (* Special case to recognize '>=' *)
 272               let s = Printf.sprintf "%s >= %s"
 273                 (string_of_expression expr_option' expr1')
 274                 (string_of_expression expr_option' expr2') in
 275               add_parenthesis expr_option s
 276           | _ ->
 277               let s = Printf.sprintf "%s or %s"
 278                 (string_of_expression expr_option' expr)
 279                 (string_of_expression expr_option' expr') in
 280               add_parenthesis expr_option s
 281         end
 282     | SymbolicExpression.Or exprs ->
 283         let exprs' = List.map (string_of_expression expr_option') exprs in
 284         add_parenthesis expr_option (String.concat " or " exprs')
 285     | SymbolicExpression.Parameter i ->
 286         Printf.sprintf "`%s`"
 287           model.Optimization.parameters.(i).Optimization.p_name
 288     | SymbolicExpression.PartialDerivative _ -> assert false
 289     | SymbolicExpression.Pre expr ->
 290         let s = string_of_expression expr_option' expr in
 291         Printf.sprintf "pre(%s)" s
 292     | SymbolicExpression.RationalPower (expr, num) ->
 293         let s = Printf.sprintf "%s ^ (%s)"
 294           (string_of_expression expr_option' expr)
 295           (Num.string_of_num num) in
 296         add_parenthesis expr_option s
 297     | SymbolicExpression.Sign expr ->
 298         let s = string_of_expression expr_option' expr in
 299         Printf.sprintf "sgn(%s)" s
 300     | SymbolicExpression.Sine expr ->
 301         let s = string_of_expression expr_option' expr in
 302         Printf.sprintf "sin(%s)" s
 303     | SymbolicExpression.String s -> Printf.sprintf "\"%s\"" s
 304     | SymbolicExpression.Tangent expr ->
 305         let s = string_of_expression expr_option' expr in
 306         Printf.sprintf "tan(%s)" s
 307     | SymbolicExpression.TimeVariable -> "time"
 308     | SymbolicExpression.Variable i ->
 309         Printf.sprintf "`%s`"
 310           model.Optimization.variables.(i).Optimization.v_name
 311   and string_of_argument expr_option arg =
 312     let string_of_array_argument dims exprs =
 313       let rec repeat n sprintf (i, s) =
 314         if n = 0 then i, ""
 315         else if n = 1 then sprintf i s
 316         else
 317           let i, s = sprintf i s in
 318           repeat (n - 1) sprintf (i, s ^ ", ") in
 319       let rec string_of_array_argument' dim dims (i, s) = match dims with
 320       | [] ->
 321           repeat
 322             dim
 323             (fun i s -> i + 1, s ^ string_of_expression expr_option exprs.(i))
 324             (i, s)
 325       | dim' :: dims ->
 326           repeat
 327             dim
 328             (fun i s ->
 329                let s = s ^ "{" in
 330                let i, s = string_of_array_argument' dim' dims (i, s) in
 331                i, s ^ "}")
 332             (i, s) in
 333     match dims with
 334     | [] -> assert false
 335     | dim :: dims ->
 336         let _, s = string_of_array_argument' dim dims (0, "{") in
 337         s ^ "}" in
 338     match arg with
 339     | SymbolicExpression.ScalarArgument expr ->
 340         string_of_expression expr_option expr
 341     | SymbolicExpression.ArrayArgument (dims, exprs) ->
 342         string_of_array_argument dims exprs
 343   in
 344   Printf.fprintf oc "%s" (hide_spc (string_of_expression None expr))
 345
 346 let print_expression_option oc model expr_option =
 347   match expr_option with
 348   | None -> ()
 349   | Some expr -> print_expression oc model expr
 350
 351 let print_tree oc model ts =
 352   let rec print_tabs tabs =
 353     if tabs > 0 then begin
 354       Printf.fprintf oc "  ";
 355       print_tabs (tabs - 1);
 356     end in
 357   let string_of_kind = function
 358     | Input -> "input"
 359     | Parameter -> "fixed_parameter"
 360     | Variable -> "variable"
 361     | DiscreteVariable -> "discrete_variable" in
 362   let rec print_tree_element tabs = function
 363     | Node (s, ts) ->
 364         print_tabs tabs;
 365         Printf.fprintf oc "<struct>\n";
 366         print_tabs (tabs + 1);
 367         Printf.fprintf oc "<name>%s</name>\n" (hide_spc s);
 368         print_tabs (tabs + 1);
 369         Printf.fprintf oc "<subnodes>\n";
 370         List.iter (print_tree_element (tabs + 2)) ts;
 371         print_tabs (tabs + 1);
 372         Printf.fprintf oc "</subnodes>\n";
 373         print_tabs tabs;
 374         Printf.fprintf oc "</struct>\n"
 375     | Leaf (s, elt) ->
 376         print_tabs tabs; Printf.fprintf oc "<terminal>\n";
 377         print_tabs (tabs + 1);
 378         Printf.fprintf oc "<name>%s</name>\n" (hide_spc s);
 379         print_tabs (tabs + 1);
 380         Printf.fprintf oc "<kind>%s</kind>\n" (string_of_kind elt.kind);
 381         print_tabs (tabs + 1);
 382         Printf.fprintf oc "<id>%s</id>\n" (hide_spc elt.id);
 383         print_tabs (tabs + 1);
 384         Printf.fprintf oc "<comment value=\"%s\"/>\n" (hide_spc elt.comment);
 385         print_tabs (tabs + 1);
 386         Printf.fprintf oc "<initial_value value=\"";
 387         print_expression_option oc model elt.initial_value;
 388         Printf.fprintf oc "\"/>\n";
 389         if elt.output then begin print_tabs (tabs + 1);
 390         Printf.fprintf oc "<output/>\n" end;
 391         if elt.kind <> Parameter && elt.initial_value <> None then
 392         begin
 393           print_tabs (tabs + 1);
 394           Printf.fprintf oc "<select/>\n"
 395         end;
 396         print_tabs tabs; Printf.fprintf oc "</terminal>\n"
 397   in
 398   Printf.fprintf oc "  <elements>\n";
 399   List.iter (print_tree_element 2) ts;
 400   Printf.fprintf oc "  </elements>\n"
 401
 402 let print_equations oc model =
 403   Printf.fprintf oc "  <equations>\n";
 404   Array.iteri
 405     (fun i equ ->
 406       Printf.fprintf oc "    <equation value=\"";
 407       if equ.Optimization.solved then
 408         let s = Printf.sprintf "`%s` = "
 409           model.Optimization.variables.(i).Optimization.v_name in
 410         Printf.fprintf oc "%s" (hide_spc s)
 411       else Printf.fprintf oc "0 = ";
 412       print_expression oc model equ.Optimization.expression;
 413       Printf.fprintf oc ";\"/>\n")
 414     model.Optimization.equations;
 415   Printf.fprintf oc "  </equations>\n"
 416
 417 let print_when_clauses oc model =
 418   Printf.fprintf oc "  <when_clauses>\n";
 419   List.iter
 420     (fun (cond, equs) ->
 421       Printf.fprintf oc "    <when_clause value=\"";
 422         Printf.fprintf oc "when ";
 423         print_expression oc model cond;
 424         Printf.fprintf oc " then ";
 425         List.iter
 426           (function
 427             | Optimization.Assign (expr, expr') ->
 428                 print_expression oc model expr;
 429                 Printf.fprintf oc " := ";
 430                 print_expression oc model expr';
 431                 Printf.fprintf oc "; "
 432             | Optimization.Reinit (expr, expr') ->
 433                 Printf.fprintf oc "reinit(";
 434                 print_expression oc model expr;
 435                 Printf.fprintf oc ", ";
 436                 print_expression oc model expr';
 437                 Printf.fprintf oc "); ")
 438           equs;
 439         Printf.fprintf oc "end when;\"/>\n")
 440     model.Optimization.when_clauses;
 441   Printf.fprintf oc "  </when_clauses>\n"
 442
 443 let generate_XML filename fun_name model =
 444   let oc = open_out filename in
 445   Printf.fprintf oc "<model>\n";
 446   Printf.fprintf oc "  <name>%s</name>\n" (hide_spc fun_name);
 447   print_tree oc model (build_tree model);
 448   print_equations oc model;
 449   print_when_clauses oc model;
 450   Printf.fprintf oc "</model>\n";
 451   close_out oc