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