let print_if (role_instances : role_instance list) (goals : Types.goals_type list) : unit =
Wm.title_set root ("Protocol Simulation : "^(Filename.basename (!Globals.input_file)));
fileName := (!Globals.input_file);
if not (!Globals.flag_stdout || !Globals.flag_split) then
Globals.tmp_channel := open_out !Globals.tmp_file;
if not (!Globals.flag_split) then
prout_endline ("%% IF specification of "^(!Globals.input_file)^"\n");
print_section_signatureA role_instances;
print_section_types ();
print_section_init role_instances;
automate:=print_section_rulesA role_instances [] [] [];
print_type_in_role_session (!automate);
let symplify_automate () =
let fusion_final_state (s1 : string * string) (s2 : string * string) =
let decomp1 = (cdr(decompose ("x("^(findState s1)^")"))) in
let decomp2 = (cdr(decompose ("x("^(findState s2)^")"))) in
let rec aux l1 l2 res =
match l1 with [] -> let tmp = List.rev res in
if (tmp=[]) then ""
else (List.fold_left (fun a b -> a^","^b) (car tmp) (cdr tmp))
|(x1::xs1) -> match l2 with [] -> let tmp = List.rev res in
if (tmp=[]) then ""
else (List.fold_left (fun a b -> a^","^b) (car tmp) (cdr tmp))
|(x2::xs2) -> if(is_a_refresh_var x1 && not(is_a_refresh_var x2))
then aux xs1 xs2 ((x2^"_new")::res)
else aux xs1 xs2 (x2::res)
in ((aux decomp1 decomp2 []),(findIknows s2))
in
let rec remove_test m =
if(m="") then ""
else(
if(is_a_test_var m) then (get_name_of_test_var m)
else if((is_a_value m) || (is_a_var m)) then m
else let l1= decompose m in
if(l1<>[])
then (
let rec aux ll1 =
match ll1 with [] -> ""
|[x] ->(remove_test x)
|_ ->((remove_test (car ll1))^","^(aux (cdr ll1)))
in
(car l1)^"("^(aux (cdr l1))^")";
)
else ""
)
in
let rec assign_test_var_name m test_var_list=
if(m="") then ""
else(
if((List.mem m test_var_list)) then ("Test_"^m)
else if((is_a_value m) || (is_a_var m)) then m
else let l1= decompose m in
if(l1<>[])
then (
let rec aux ll1 =
match ll1 with [] -> ""
|[x] ->(assign_test_var_name x test_var_list)
|_ ->((assign_test_var_name (car ll1) test_var_list)^","^(aux (cdr ll1)))
in
(car l1)^"("^(aux (cdr l1))^")";
)
else ""
)
in
let treatment state iknows =
let state_d = (cdr (decompose ("x("^state^")"))) in
let test_var_list_ref = ref [] in
let new_state = List.map (fun v -> if (is_a_test_var v)
then (
if(List.mem (get_name_of_test_var v) (!test_var_list_ref)) then "X_X" else (get_name_of_test_var v))
else if ((is_a_var v) )
then (test_var_list_ref:=v::(!test_var_list_ref);v)
else v)
state_d in
let new_state2 = (List.fold_left (fun a b -> a^","^b) "" new_state) in
let new_state3 = String.sub new_state2 1 ((String.length new_state2)-1) in
let new_iknows = assign_test_var_name iknows (!test_var_list_ref) in
(new_state3,new_iknows)
in
let simplify_var name id actionsL =
List.map
(fun (initial, operation, (finalState, finalIknows)) ->
( (treatment (findState initial)(findIknows initial)),
((List.map remove_test (fst (fst operation)), List.map remove_test (snd (fst operation))), (List.map remove_test (fst (snd operation)), List.map remove_test (snd (snd operation)))) ,
(finalState,(remove_test finalIknows)))
)
actionsL
in
let zip_operation l_op1 lop2 =
let zip l1 l2 = remove_double l1@l2 in
(
(
(zip (fst (fst l_op1))(fst (fst lop2))) , (zip (snd (fst l_op1))(snd (fst lop2)))
),
(
(zip (fst (snd l_op1))(fst (snd lop2))) , (zip (snd (snd l_op1))(snd (snd lop2)))
)
)
in
let res = ref [] in
let buff = ref [] in
let add_in_res x = if((List.mem x (!res))
|| (List.mem x (!buff)))
then ()
else (res:= x::(!res)) in
let add_in_buff x = if(List.mem x (!buff)) then () else (buff:= x::(!buff)) in
let symplify_actions_aux name id actionsL =
let find_state state =
let rec aux l res =
match l with [] -> List.rev res
|((initial,operation,final)::ls) ->
if( (replace "Test_" "" (findState initial))=(replace "Test_" "" state) )
then aux ls ((initial,operation,final)::res)
else aux ls res;
in
aux actionsL []
in
let name_in_session = get_name_in_session name id in
res:=[];
buff:=[];
List.iter
(fun (initial,operation,final) ->
if((findIknows final)<> "") then add_in_res (initial,operation,final)
else (List.iter (fun (initial2,operation2,final2) ->
if((findIknows initial2)<> "")
then ( add_in_res (initial,operation,final); add_in_res (initial2,operation2,final2);
List.iter
(fun s ->
if(not(List.mem s (!res))) then res:=s::(!res))
(find_state (findState initial2)))
else (if (match_state name_in_session (findState final) name_in_session (findState initial2))
then (
add_in_buff (initial,operation,final);
add_in_buff (initial2,operation2,final2);
add_in_res (initial,(zip_operation operation operation2),(fusion_final_state final final2)))
else ( add_in_res (initial,operation,final);
add_in_res (initial2,operation2,final2)););
)actionsL))
actionsL;
!res
in
let symplify_actions_aux2 name id actionsL =
let name_in_session = get_name_in_session name id in
res:=[];
buff:=[];
List.iter
(fun (initial,operation,final) ->
if((findIknows final)<> "") then add_in_res (initial,operation,final)
else (List.iter (fun (initial2,operation2,final2) ->
(List.iter (fun (initial3,operation3,final3) ->
if((findIknows initial2)<> "" || (findIknows initial2)<> "")
then (add_in_res (initial,operation,final); add_in_res (initial2,operation2,final2))
else (if (match_state name_in_session (findState final) name_in_session (findState initial3))
then (
add_in_buff (initial,operation,final);
add_in_buff (initial2,operation2,final2);
add_in_buff (initial3,operation3,final3);
add_in_res (initial,(zip_operation (zip_operation operation operation2) operation3),(fusion_final_state (fusion_final_state final final2) final3)))
else ( add_in_res (initial,operation,final);
add_in_res (initial2,operation2,final2);
add_in_res (initial3,operation3,final3)))
)actionsL)
)actionsL))
actionsL;
!res
in
let rec simplify_actions2 name id actionsL length =
let tmp = remove_double (symplify_actions_aux2 name id actionsL) in
let length2 = List.length tmp in
if (length<>length2) then (simplify_actions2 name id tmp length2)
else tmp;
in
let rec simplify_actions name id actionsL length =
let tmp = remove_double (symplify_actions_aux name id actionsL) in
let length2 = List.length tmp in
if (length<>length2) then (simplify_actions name id tmp length2)
else (simplify_actions2 name id tmp length);
in
let simplify_operations actionsL =
let place_delete_test_aux l1_test l2 =
remove ""
(List.map
(fun e ->
let d = decompose e in
if(d<>[] && (car d)="contains")
then(
if( not(List.mem e (fst l2))
&& (List.mem ("delete"^"("^(list2string "," (cdr d))^")") (snd l1_test) ) )
then ""
else e
)
else e
)
(fst l1_test) )
in
let place_delete_test l1 l2 =
(( (place_delete_test_aux (fst l1) (fst l2)), snd(fst l1)),snd l1)
in
let rec aux initial1 operations1 final1 actionsL2 =
match actionsL2 with [] -> (initial1,operations1,final1)
|((initial2,operations2,final2)::ls) -> if( operations1<>operations2 && initial1=initial2 && final1=final2 )
then aux initial1 (zip_operation (place_delete_test operations1 operations2) (place_delete_test operations2 operations1) ) final1 ls
else aux initial1 operations1 final1 ls
in
let rec simplify actionsL res buff =
match actionsL with [] -> List.rev res
|((initial1,operations1,final1)::ls) -> if(List.mem (initial1,final1) buff)
then simplify ls res buff
else simplify ls ((aux initial1 operations1 final1 actionsL)::res) ((initial1,final1)::buff)
in simplify actionsL [] []
in
automate:=
(List.map
(fun (name,id,statesL,actionsL) ->
let actions_with_simplify_operations = simplify_operations actionsL in
(name,id,statesL,(simplify_var name id (simplify_actions name id actions_with_simplify_operations (List.length actions_with_simplify_operations))))
)
(!automate)) in
symplify_automate();
if(!intruder_mode)
then(
pack ~side:`Left ~fill:`Y [intruder_knowledge_v];
pack ~side:`Bottom ~fill:`X [intruder_knowledge_h];
pack ~side:`Left ~fill:`Both ~expand:true [label_intruder];
pack ~side:`Left ~fill:`Both ~expand:true [window_compose_intruder_knowledge];
pack ~side:`Top ~fill:`Both ~expand:false [intruderFrameForButton];
pack ~side:`Top ~fill:`Both ~expand:true [intruder_knowledge_lst];
pack ~side:`Top ~fill:`Both ~expand:true [intruderFrame];
add_type "(Intruder_, 0)" ["agent" ; "set(message)" ; "message"];
add_type "intruder_" ["agent"];
add_type "set_knowledge" ["set(message)"];
add_type "dummy_msg" ["message"];
add_type "0" ["nat"];
add_type "Intruder_" ["agent"];
add_type "Set_knowledge" ["set(message)"];
add_type "Listen_i" ["message"];
add_state "(Intruder_, 0)" "intruder_,0,set_knowledge,dummy_msg";
let intruder_role = ("Intruder_", 0, ref [], [("Intruder_,0,Set_knowledge,Listen_i","Listen_i"), (([],[]), ([],["cons(Listen_i,Set_knowledge)"])), ("Intruder_,0,Set_knowledge,Listen_i","")]) in
automate := intruder_role::(!automate);
);
List.iter
(fun (name,id,statesL,actionsL) ->
if ((!statesL)=[])
then(
let name_in_session = get_name_in_session name id in
let initial_state = get_initial_state name_in_session in
let not_contain_the_start_command = not(List.mem "start" (List.map (fun (initial,_,_) -> findIknows initial) actionsL)) in
List.iter
(fun (initial,_,final) ->
if(match_state name_in_session initial_state name_in_session (findState initial))
then(
List.iter
(fun t ->
if ((is_a_test_var t)
&& not(List.mem (get_name_of_var t) (Hashtbl.find_all role_var_monitoring name_in_session)))
then Hashtbl.add role_var_monitoring name_in_session (get_name_of_var t)
else if ((t<>"X_X") && (is_a_var t)
&& not(List.mem t (Hashtbl.find_all role_var_monitoring name_in_session)))
then Hashtbl.add role_var_monitoring name_in_session t)
(cdr(decompose ("x("^(findState initial)^")")));
if((findIknows initial)="start")
then (ignore(assign_var_of_state name_in_session initial_state name_in_session (findState initial));
statesL:=((findState final), ref true)::(!statesL) ;
operations_affectation_treatment name_in_session (findState final);
)
else (if not_contain_the_start_command then ignore(assign_var_of_state name_in_session initial_state name_in_session (findState initial));
statesL:=((findState initial), ref false)::(!statesL) ;
add_in_rcv_stack name_in_session (findState initial) (findIknows initial);
operations_affectation_treatment name_in_session (findState final);
)
))
actionsL
)
)
(!automate);
if(!intruder_mode)
then(
List.iter
(fun k -> add_in_set "(Intruder_, 0)" k "(Intruder_, 0)" "Set_knowledge")
!intruder_knowledge;
update_intruder_knowledge ();
display_intruder_knowledge();
);
xinit_coord (List.length (!automate));
let x_pos = ref 0. in
List.iter
(fun (name,id,_,_) ->
let name_in_session = (get_name_in_session name id) in
Menu.add_command ~label:name_in_session ~command:(fun () -> var_frame name_in_session) men_var;
draw_plot (!x_pos) name_in_session (if(name_in_session="(Intruder_, 0)" && !intruder_mode) then red else blue);
draw_plot (!x_pos) name_in_session (if(name_in_session="(Intruder_, 0)" && !intruder_mode) then red else blue);
x_pos:= 10. +. (!x_pos))
(!automate);
add_in_automate_story ();
add_in_variable_story ();
next_message_stack ();
next_id_refresh_story ();
insert_lst "" "";
if not (!Globals.flag_stdout || !Globals.flag_split) then
Globals.close_out_noerr !Globals.tmp_channel;
if(Sys.file_exists (!Globals.tmp_file)) then ignore(Sys.remove (!Globals.tmp_file));
mainLoop();
if (!Error_handler.warningsCounter <> 0) then
(flush stdout;
prerr_string "\n%% Number of warnings: ";
prerr_int !Error_handler.warningsCounter;
prerr_newline();
flush stderr)