4 * Copyright (C) 2005 - 2007 Imagine S.A.
5 * For more information or commercial use please contact us at www.amesim.com
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.
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.
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.
23 type 'a tree = Leaf of (string * 'a) | Node of string * 'a tree list
25 (* function used to hide XML special characters *)
27 let encoded_s = ref "" in
28 let hide_special_character c = match c with
29 | '<' -> encoded_s := !encoded_s ^ "<"
30 | '>' -> encoded_s := !encoded_s ^ ">"
31 | '&' -> encoded_s := !encoded_s ^ "&"
32 | '\'' -> encoded_s := !encoded_s ^ "'"
33 | '\"' -> encoded_s := !encoded_s ^ """
34 | _ -> encoded_s := !encoded_s ^ (String.make 1 c) in
35 String.iter hide_special_character s;
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'
44 | [s] -> Leaf (s, x) :: ts
45 | s :: path' -> insert' s path' ts
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)
56 let s, name_opt = cut_on_dot name in
59 | Some name' -> s :: split name'
66 initial_value: SymbolicExpression.t option;
76 let build_tree model =
77 let bool_of_option = function
91 initial_value = Some SymbolicExpression.zero;
96 model.Optimization.inputs in
102 (split par.Optimization.p_name)
105 id = par.Optimization.p_name;
106 comment = par.Optimization.p_comment;
107 initial_value = Some par.Optimization.value;
112 model.Optimization.parameters in
118 (split var.Optimization.v_name)
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
128 model.Optimization.variables in
134 (split dvar.Optimization.d_v_name)
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
144 model.Optimization.discrete_variables in
147 let print_expression oc model expr =
148 let add_parenthesis expr_option sub_expr =
149 match expr_option with
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') ->
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') ->
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') ->
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'') ->
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'] ->
262 let nat = SymbolicExpression.nature expr
263 and nat' = SymbolicExpression.nature expr' in
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' &&
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
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
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) =
315 else if n = 1 then sprintf i s
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
323 (fun i s -> i + 1, s ^ string_of_expression expr_option exprs.(i))
330 let i, s = string_of_array_argument' dim' dims (i, s) in
336 let _, s = string_of_array_argument' dim dims (0, "{") in
339 | SymbolicExpression.ScalarArgument expr ->
340 string_of_expression expr_option expr
341 | SymbolicExpression.ArrayArgument (dims, exprs) ->
342 string_of_array_argument dims exprs
344 Printf.fprintf oc "%s" (hide_spc (string_of_expression None expr))
346 let print_expression_option oc model expr_option =
347 match expr_option with
349 | Some expr -> print_expression oc model expr
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);
357 let string_of_kind = function
359 | Parameter -> "fixed_parameter"
360 | Variable -> "variable"
361 | DiscreteVariable -> "discrete_variable" in
362 let rec print_tree_element tabs = function
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";
374 Printf.fprintf oc "</struct>\n"
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
393 print_tabs (tabs + 1);
394 Printf.fprintf oc "<select/>\n"
396 print_tabs tabs; Printf.fprintf oc "</terminal>\n"
398 Printf.fprintf oc " <elements>\n";
399 List.iter (print_tree_element 2) ts;
400 Printf.fprintf oc " </elements>\n"
402 let print_equations oc model =
403 Printf.fprintf oc " <equations>\n";
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"
417 let print_when_clauses oc model =
418 Printf.fprintf oc " <when_clauses>\n";
421 Printf.fprintf oc " <when_clause value=\"";
422 Printf.fprintf oc "when ";
423 print_expression oc model cond;
424 Printf.fprintf oc " then ";
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 "); ")
439 Printf.fprintf oc "end when;\"/>\n")
440 model.Optimization.when_clauses;
441 Printf.fprintf oc " </when_clauses>\n"
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";