end of line
[scilab.git] / 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