(*************************************************************
 *                                                           *
 *  Cryptographic protocol verifier                          *
 *                                                           *
 *  Bruno Blanchet, Vincent Cheval, and Marc Sylvestre       *
 *                                                           *
 *  Copyright (C) INRIA, CNRS 2000-2023                      *
 *                                                           *
 *************************************************************)

(*

    This program is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation; either version 2 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details (in file LICENSE).

    You should have received a copy of the GNU General Public License along
    with this program; if not, write to the Free Software Foundation, Inc.,
    51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.

*)

(* Trace reconstruction
   This version of the trace reconstruction does not exploit the
   order of nodes in the derivation tree.
 *)
(* TO DO Test phases
   Should I use evaluated terms in the "comment" field?
 *)

open Types
open Pitypes
open Terms
open Reduction_helper

let made_forward_step = ref false
let failed_traces = ref 0

let debug_find_io_rule = ref false
let debug_backtracking = ref false
let debug_print s = ()
    (* print_string s;
     Display.Text.newline()*)

(* This exception is raise when the derivation prevents executing
   a step *)
exception DerivBlocks

(* This exception is used in reduction_nobacktrack
   It is raised after a bunch of reductions to
   to get the final state after these reductions,
   while preventing backtracking on these reductions.*)
exception Reduced of (term * term) reduc_state

(* [Terms.auto_cleanup f] runs [f()], removing all links
   created by [f()], whether [f] terminates normally or
   with an exception

   [auto_cleanup_red] is a variant of this function that
   treats the exception [Reduced] specially. Indeed, in most
   cases, when an exception is raised, it is because we
   backtrack, so the links we have set must be removed,
   since we undo the reductions.
   However, the exception [Reduced] is different: for this
   exception, we want to get the final state, so the links
   must be kept.
*)

let auto_cleanup_red f =
  let tmp_bound_vars = !current_bound_vars in
  current_bound_vars := [];
  try
    let r = f () in
    List.iter (fun v -> v.link <- NoLink) (!current_bound_vars);
    current_bound_vars := tmp_bound_vars;
    r
  with
    Reduced s ->
      (* Do not delete the links when the exception [Reduced] is raised.
	 Keep them in [current_bound_vars] so that they are deleted later if needed *)
      current_bound_vars := List.rev_append tmp_bound_vars (!current_bound_vars);
      raise (Reduced s)
  | x ->
      List.iter (fun v -> v.link <- NoLink) (!current_bound_vars);
      current_bound_vars := tmp_bound_vars;
      raise x


(* Set when we should take the else branch of Get but we cannot
   because an element has already been inserted so that the in branch
   is taken. In this case, we try delaying the inserts. *)
let has_backtrack_get = ref false

exception No_result
(* We use the exception Unify for local failure *)

exception FailOnlyOnSide of int

let make_bi_choice (t1, t2) = make_choice t1 t2

let make_bi_choice_fact = function
  | Pred(p1,args1), Pred(p2,args2) when p1 == p2 ->
      Pred(p1,List.map2 make_choice args1 args2)
  | _ -> Parsing_helper.internal_error "[reduction_bipro.ml >> make_bi_choice_fact] Should be the same predicate."

let get_choice = function
    FunApp({ f_cat = Choice }, [t1;t2]) -> (t1,t2)
  | _ -> Parsing_helper.internal_error "Choice term expected"

let equal_bi_terms_modulo (t1,t2) (t1',t2') =
  (equal_terms_modulo t1 t1') && (equal_terms_modulo t2 t2')

let is_true_test (t1,t2) =
  let r1 = equal_terms_modulo t1 Terms.true_term in
  let r2 = equal_terms_modulo t2 Terms.true_term in
  if r1 && r2 then true else
  if (not r1) && (not r2) then false else
  raise (FailOnlyOnSide (if (not r1) then 1 else 2))

(* [bi_action action] executes action for both sides.
   Raises Unify when it fails.
   Raises FailOnlyOnSide 1 when left side only of the action fails.
   Raises FailOnlyOnSide 2 when right side only of the action fails.
   Raises Unify when the action fails on both sides. *)
let bi_action action =
  try
    let t1 = action 1 in
    try
      let t2 = action 2 in
      (t1,t2)
    with Unify ->
      (* Left side succeeded, right side failed *)
      raise (FailOnlyOnSide 2)
  with Unify ->
    (* Left side failed *)
    let _ = action 2 in
    (* Left side failed, right side succeeded *)
    raise (FailOnlyOnSide 1)

let rev_name_subst_bi = function
    [t] -> let r = rev_name_subst t in (r,r)
  | [t1;t2] -> (rev_name_subst t1, rev_name_subst t2)
  | _ -> Parsing_helper.internal_error "Unexpected number of arguments for this predicate"

let get_term_type_bi = function
    [t] -> Terms.get_term_type t
  | [t1;t2] -> Terms.get_term_type t1
  | _ -> Parsing_helper.internal_error "Unexpected number of arguments for this predicate"

let get_min_choice_phase() =
  match (!Param.current_state).pi_min_choice_phase with
  | Set min_phase -> min_phase
  | Unset -> Parsing_helper.internal_error "pi_min_choice_phase not set"

let build_mess_fact phase (tc1,tc2) (t1,t2) =
  if phase < get_min_choice_phase() then
    Pred(Param.get_pred(Mess(phase, Terms.get_term_type t1)), [tc1;t1])
  else
    Pred(Param.get_pred(MessBin(phase, Terms.get_term_type t1)), [tc1;t1;tc2;t2])

let build_table_fact phase (t1,t2) =
  if phase < get_min_choice_phase() then
    Pred(Param.get_pred(Table(phase)), [t1])
  else
    Pred(Param.get_pred(TableBin(phase)), [t1;t2])

let build_precise_fact occ_name (t1,t2) =
  let ev = Param.get_precise_event (Action (get_term_type t1)) in
  Pred(Param.event2_pred_block,[FunApp(ev,[occ_name;t1]);FunApp(ev,[occ_name;t2])])

(* Detect various goals *)

let is_table_goal cur_phase t = function
  | Pred({p_info = TableBin(i); _},[tbl_elem1;tbl_elem2]) ->
      (* If the term tbl_elem is in the table
         in phase cur_state.current_phase, it will still be in the table in any
         later phase. *)
      cur_phase <= i &&
      equal_bi_terms_modulo (tbl_elem1,tbl_elem2) t
  | Pred({p_info = Table(i)},[tbl_elem]) ->
      (* When the phase is less than [min_choice_phase],
	 we use a unary [Table] predicate. *)
      cur_phase <= i &&
      equal_bi_terms_modulo (tbl_elem,tbl_elem) t
  | _ -> false

let is_mess_goal cur_phase tc t = function
  | Pred({p_info = MessBin(n,_)},[tcg1;tg1;tcg2;tg2]) ->
      (n == cur_phase) &&
      equal_bi_terms_modulo (tg1,tg2) t &&
      equal_bi_terms_modulo (tcg1,tcg2) tc
  | Pred({p_info = Mess(n,_)},[tcg;tg]) ->
      (n == cur_phase) &&
      equal_bi_terms_modulo (tg,tg) t &&
      equal_bi_terms_modulo (tcg,tcg) tc
  | _ -> false

(* Display clauses *)

let display_rule (n, sons, hsl, nl, concl) =
  print_string ("Rule " ^ (string_of_int n) ^ ": ");
  display_tag hsl nl;
  print_string "  ";
  Display.Text.display_rule (List.map (fun t -> copy_fact2 t) sons, copy_fact2 concl, Empty concl, Terms.true_constraints);
  Display.Text.newline()

(* Display the trace *)

let noninterftest_to_string = function
    ProcessTest _ -> " process performs a test that may succeed on one side and not on the other"
  | InputProcessTest _ -> "The pattern-matching in the input succeeds on one side and not on the other."
  | NIFailTest _ -> "This holds on one side and not on the other."
  | ApplyTest _ -> Parsing_helper.internal_error "There should be no ApplyTest in reduction_bipro.ml"
  | CommTest _ -> "The communication succeeds on one side and not on the other."
  | NIEqTest _ -> "The result in the left-hand side is different from the result in the right-hand side."

let display_trace final_state =
  match !Param.trace_display with
    Param.NoDisplay -> ()
  | Param.ShortDisplay ->
      if !Param.html_output then
	Display.Html.display_labeled_trace final_state
      else
	begin
	  if !Param.display_init_state then
	    begin
	      print_string "A more detailed output of the traces is available with\n";
	      if !Param.typed_frontend then
		print_string "  set traceDisplay = long.\n"
              else
		print_string "  param traceDisplay = long.\n";
	      Display.Text.newline()
	    end;
	  Display.Text.display_labeled_trace final_state
	end
  | Param.LongDisplay ->
      if !Param.html_output then
	ignore (Display.Html.display_reduc_state Display.bi_term_to_term true final_state)
      else
	ignore (Display.Text.display_reduc_state Display.bi_term_to_term true final_state)

(* Updating the goals *)

let is_equivalence_goal = function
  | NonInterfGoal _ -> true
  | _ -> false

(* Find a clause *)

let find_io_rule next_f hypspeclist hyplist name_params var_list io_rules =
  let name_params1 = extract_name_params_noneed name_params in
  let l = List.length hypspeclist in
  let lnp = List.length name_params1 in
  let lh = List.length hyplist in
  (* Useful for debugging *)
  if !debug_find_io_rule then
    begin
      auto_cleanup (fun () ->
	print_string "Looking for ";
	display_tag hypspeclist name_params1;
	print_string "  ";
	Display.Text.display_list Display.Text.WithLinks.fact " & " hyplist;
	Display.Text.newline())
    end;
  let found_terms = ref [] in
  let rec find_io_rule_aux = function
    [] -> raise Unify
  | (((n, sons, hypspeclist2, name_params',_) as io_rule)::io_rules) ->
      let l2 = List.length hypspeclist2 in
      let lnp2 = List.length name_params' in
      let lh2 = List.length sons in
      if (l2 < l) || (lnp2 < lnp) || (lh2 < lh) || (not (hypspeclist = skip (l2-l) hypspeclist2))
      then
	begin
	  if l > 0 && List.mem (List.hd hypspeclist) hypspeclist2 then
	    begin
	      (* When the first element (last added) of hypspeclist matches,
		 we have reached the same program point (thanks to the occurrence),
		 so the rest of hypspeclist should match as well and the lengths
		 of lists should be compatible. *)
	      print_string "Looking for ";
	      display_tag hypspeclist name_params1;
	      print_string "  ";
	      Display.Text.display_list Display.Text.WithLinks.fact " & " hyplist;
	      Display.Text.newline();
	      print_string "Partly matching clause: ";
	      display_rule io_rule;
	      Parsing_helper.internal_error "Desynchronization between the tags of generated clauses and the tags built during attack reconstruction"
	    end;
	  find_io_rule_aux io_rules
	end
      else
        begin
	  let sons3 = skip (lh2-lh) sons in
	  try
	    let name_params2 = skip (lnp2-lnp) name_params' in
	    if not (Param.get_ignore_types()) &&
	      (List.exists2 (fun t1 t2 -> Terms.get_term_type t1 != Terms.get_term_type t2) name_params1 name_params2) then
	      raise Unify;
	    auto_cleanup_red (fun () ->
	      match_modulo_list (fun () ->
	        match_equiv_list (fun () ->
                  let new_found = List.map copy_closed_remove_syntactic var_list in
	          if List.exists (fun old_found ->
	            List.for_all2 equal_terms_modulo old_found new_found) (!found_terms) then
	            raise Unify;
	          found_terms := new_found :: (!found_terms);
		  if !debug_find_io_rule then
		    begin
		      auto_cleanup (fun () ->
			print_string "Found ";
			Display.Text.display_list Display.Text.WithLinks.term ", " new_found;
			Display.Text.newline())
		    end;
	          next_f new_found) sons3 hyplist
                  ) name_params1 name_params2
		)
          with Unify -> find_io_rule_aux io_rules
        end
  in
  find_io_rule_aux io_rules

(* Evaluate a term possibly containing destructors.
   It always succeeds, perhaps returning Fail.  *)

let rec term_evaluation side = function
    Var v ->
      begin
        match v.link with
          TLink t ->
            (* I think this is useful only to split a Choice inside t *)
            term_evaluation side t
        | _ -> Parsing_helper.internal_error "Error: term should be closed in attack reconstruction";
      end
  | FunApp(f,[c;tthen;telse]) when
    f == Terms.gtest_fun (snd f.f_type) ->
      (* optimize evaluation of if-then-else terms, to evaluate only the useful branch.
	 useful in particular to avoid evaluating catch-fail(caught-fail). *)
      let c_eval = term_evaluation side c in
      begin
        try
          auto_cleanup (fun () ->
            Reduction_helper.match_modulo (fun () ->
              term_evaluation side tthen
            ) Terms.true_term c_eval
          )
        with Unify ->
          try
            auto_cleanup (fun () ->
              Reduction_helper.match_modulo (fun () ->
                Terms.get_fail_term (snd f.f_type)
              ) (Terms.get_fail_term Param.bool_type) c_eval
            )
          with Unify -> term_evaluation side telse
      end
  | FunApp(f,l) ->
      (* for speed, use the initial definition of destructors, not the one enriched with the equational theory *)
      match f.f_initial_cat with
        Eq _ | Tuple ->
          let l' = List.map (term_evaluation side) l in
          if List.exists is_fail l' then
            Terms.get_fail_term (snd f.f_type)
          else
            FunApp(f, l')
      | Name _ | Failure -> FunApp(f,[])
      | Choice ->
          begin
            match l with
              [t1;t2] ->
                if side = 1 then
                  term_evaluation side t1
                else
                  term_evaluation side t2
            | _ -> Parsing_helper.internal_error "Choice should have two arguments"
          end
      | ChoiceFst ->
          begin
            match l with
              [t] -> term_evaluation 1 t
            | _ -> Parsing_helper.internal_error "Choice-fst should have one argument"
          end
      | ChoiceSnd ->
          begin
            match l with
              [t] -> term_evaluation 2 t
            | _ -> Parsing_helper.internal_error "Choice-snd should have one argument"
          end
      | Red redl ->
          let l' = List.map (term_evaluation side) l in
          let rec try_red_list = function
              [] ->
                Parsing_helper.internal_error "Term evaluation should always succeeds (perhaps returning Fail)"
            | (red1::redl) ->
                let (left, right, side_c) = auto_cleanup (fun () -> Terms.copy_red red1) in
                try
                  auto_cleanup (fun () ->
                    match_modulo_list (fun () ->
                      close_destr_constraints side_c;
                      if TermsEq.check_closed_constraints side_c then
                        begin
                        (* TO DO (for speed) should I remove_syntactic, or keep it,
                           but take it into account elsewhere (when doing
                           function symbol comparisons, accept functions that
                           differ by their syntactic status) *)
                          close_term right;
                          TermsEq.remove_syntactic_term right
                        end
                      else
                        raise Unify
                     ) left l')
                with Unify -> try_red_list redl
          in
          try_red_list redl
      | _ ->
        Printf.printf "\nName of the function:";
        Display.Text.display_function_name f;
        Parsing_helper.internal_error "unexpected function symbol in term_evaluation (reduction_bipro.ml)"

(* Evaluates t1 and tests if it is equal to t2. *)

let equal_terms_modulo_eval t1 t2 =
  let t1_l = term_evaluation 1 t1 in
  let t1_r = term_evaluation 2 t1 in
  if (is_fail t1_l) || (is_fail t1_r) then false else
  equal_bi_terms_modulo (t1_l, t1_r) t2


(* Evaluates a term. Raises Unify when the result is fail. *)

let term_evaluation_fail t side =
  let r = term_evaluation side t in
  if is_fail r then
    raise Unify
  else
    r

let fact_evaluation_fail fact side = match fact with
  | Pred(p,args) ->
      let args' =
        List.map (fun t ->
          let r = term_evaluation side t in
          if is_fail r
          then raise Unify
          else r
        ) args
      in
      Pred(p,args')

let term_evaluation_fail2 t1 t2 side =
  (term_evaluation_fail t1 side, term_evaluation_fail t2 side)

let make_name_param_entry cur_state t' =
  let t =
    if cur_state.current_phase < get_min_choice_phase() then
      fst t'
    else
      make_bi_choice t'
  in
  (MUnknown, t, Always)

let term_evaluation_name_params cur_state occ t name_params =
  let may_have_several_patterns = reduction_check_several_patterns occ in
  let t' = bi_action (term_evaluation_fail t) in
  if may_have_several_patterns then
    t', ((make_name_param_entry cur_state t') :: name_params)
  else
    t', name_params

let term_evaluation_to_true t side =
  let r = term_evaluation side t in
  if (is_fail r) || (not (equal_terms_modulo r Terms.true_term)) then
    raise Unify
  else
    r

let term_evaluation_name_params_true cur_state occ t name_params =
  let may_have_several_patterns = reduction_check_several_patterns occ in
  let t' = bi_action (term_evaluation_to_true t) in
  if may_have_several_patterns then
    (make_name_param_entry cur_state t') :: name_params
  else
    name_params

(* Update the value of name_params after pattern-matching *)

let rec update_name_params cur_state put_var name_params = function
    PatVar b ->
      let bi_t = copy_closed_remove_syntactic (Var b) in
      let t =
	if cur_state.current_phase < get_min_choice_phase() then
	  match bi_t with
	  | FunApp({ f_cat = Choice }, [t1;t2]) -> t1
	  | _ -> Parsing_helper.internal_error "reduction_bipro: variable should be linked to choice"
	else
	  bi_t
      in
      (MVar(b, None), t, put_var)::name_params
  | PatTuple(f,l) -> update_name_params_list cur_state put_var name_params l
  | PatEqual _ -> name_params

and update_name_params_list cur_state put_var name_params = function
    [] -> name_params
  | (a::l) -> update_name_params_list cur_state put_var (update_name_params cur_state put_var name_params a) l

(* Match a pattern
   Raises Unify when the matching fails *)

let rec match_pattern p side t =
  if not (Terms.equal_types (Terms.get_pat_type p) (Terms.get_term_type t)) then
    raise Unify;
  match p with
    PatVar b ->
      begin
	if side = 1 then
	  Terms.link b (TLink (make_choice t t))
	else
	  match b.link with
	    TLink (FunApp({ f_cat = Choice }, [t1;t2])) ->
	      Terms.link b (TLink (make_choice t1 t))
	  | _ ->
	      (* When the evaluation or pattern matching failed on the left side,
	         some variables may be unbounded when we try the pattern matching
	         on the right side *)
	      Terms.link b (TLink (make_choice t t))
      end
  | PatTuple(f,[pat1;pat2]) when f.f_cat = Choice ->
      if side = 1 then
	begin
	  match_pattern pat1 1 t;
	  match_pattern pat1 2 t;
	end
      else
	begin
	  match_pattern pat2 1 t;
	  match_pattern pat2 2 t;
	end
  | PatTuple(f,l) ->
      let vl = Terms.var_gen (fst f.f_type) in
      let tl =
	match_modulo (fun () ->
	  List.map copy_closed_remove_syntactic vl) (FunApp(f, vl)) t
      in
      List.iter2 (fun p t -> match_pattern p side t) l tl
  | PatEqual t' ->
      let t'' = term_evaluation_fail t' side in
      match_modulo (fun () -> ()) t'' t

let bi_match_pattern p (t1,t2) side =
  if side = 1 then
    match_pattern p side t1
  else
    match_pattern p side t2

let bi_match_pattern_and_test p (t1,t2) t side =
  bi_match_pattern p (t1,t2) side;
  let t' = term_evaluation_fail t side in
  if not (equal_terms_modulo t' Terms.true_term) then
    raise Unify

let term_evaluation_name_params_and_match cur_state pat occ t name_params =
  let may_have_several_patterns = reduction_check_several_patterns occ in
  let t'' = bi_action (fun side ->
    let t' = term_evaluation_fail t side in
    match_pattern pat side t';
    t')
  in
  if may_have_several_patterns then
    t'', ((make_name_param_entry cur_state t'') :: name_params)
  else
    t'', name_params

(*
   Terms come with a recipe that explains how to compute them.
   Recipes may contain variables (especially in prepared_attacker_rules)
   which are later instantiated by putting links in these variables.
   Copies of the recipes are not made immediately after creating the links,
   so these links remain when the trace progresses; they are removed
   in case of backtrack (by auto_cleanup_red).
   Not making too many copies is important for speed in complex
   examples such as ffgg.
   Copies of recipes are made before adding a term to public,
   so that recipes in public do not contain links.
   They are also made before using a term in an input.
*)

(* Decompose tuples *)

let rec decompose_term ((recipe, t) as pair:Types.term * (Types.term * Types.term)) =
  match t with
    (FunApp({f_cat = Tuple } as f,l), FunApp({f_cat = Tuple} as f',l')) when f == f' ->
      let projs = Terms.get_all_projection_fun f in
      decompose_list (List.map2 (fun fi ti -> (FunApp(fi,[recipe]),ti))
                      projs (List.combine l l'))
   | _ -> [pair]

and decompose_list = function
    [] -> []
  | (a::l) -> (decompose_term a) @ (decompose_list l)


let rec decompose_term_rev (binder, t) =
  match t with
    (FunApp({f_cat = Tuple } as f,l), FunApp({f_cat = Tuple} as f',l')) when f == f' ->
      let new_list = List.map (fun (x, x') -> ((Terms.new_var ~orig:false "~M" (Terms.get_term_type x)), (x, x')))
	  (List.combine l l')
      in
      Terms.link binder (TLink (FunApp(f, (List.map (fun (x, y) -> Var x) new_list))));
      decompose_list_rev new_list
  | t -> [(binder, t)]

and decompose_list_rev = function
    [] -> []
  | (a::l) -> (decompose_term_rev a) @ (decompose_list_rev l)



(* Test if a term is public *)

let rec is_in_public public = function
  | (FunApp({f_cat = Tuple} as f, l), FunApp(f',l')) when f == f' ->
      (match (is_in_public_list public) (List.combine l l') with
        | None -> None
        | Some lst -> Some(FunApp(f, lst)))
  | t ->
      try
        let (ca, _) = List.find (fun (_, t') -> equal_bi_terms_modulo t t') public in
        Some ca
      with Not_found ->
        None

and is_in_public_list public = function
    [] -> Some []
  | hd::tail ->
      match is_in_public public hd with
	None -> None
      | Some ca ->
        match is_in_public_list public tail with
	  None -> None
	| Some catail -> Some (ca::catail)


let rec decompose_tuple = function
  | (FunApp({f_cat = Tuple } as f1,l1), FunApp(f2,l2)) when f1 = f2 ->
      List.concat (List.map2 (fun t1 t2 -> decompose_tuple (t1, t2)) l1 l2)
  | x -> [x]


let rec can_be_built public t =
  try
    let (ca, _) = List.find (fun (_, t') -> equal_bi_terms_modulo t t') public in
    Some ca
  with Not_found ->
    match t with
    | FunApp({f_private = false; _} as f1,l1), FunApp(f2, l2) when f1 == f2 ->
	begin match can_be_built_list public l1 l2 with
	| None -> None
	| Some lst -> Some(FunApp(f1,lst))
	end
    | _ ->
        None

and can_be_built_list public l1 l2 =
  match l1, l2 with
  | [],[] -> Some []
  | hd1::tail1, hd2::tail2 ->
      begin
      match can_be_built public (hd1, hd2) with
        | None -> None
        | Some ca ->
            match can_be_built_list public tail1 tail2 with
              | None -> None
              | Some catail -> Some (ca::catail)
      end
  | _ -> Parsing_helper.internal_error "lists of different lengths in can_be_built_list"

let rec remove_first_in_public public = function
    [] -> []
  | (((c, a)::l) as l') ->
    if Terms.is_ground_public (fst a) && Terms.equal_terms (fst a) (snd a)
    then
      begin
        link c (TLink (fst a));
        remove_first_in_public public l
      end
    else
      try
        let (ca, _) = List.find (fun (_, t) -> equal_bi_terms_modulo a t) public in
        Terms.link c (TLink ca);
        remove_first_in_public public l
      with Not_found ->
        l'


let update_term_list oldpub public tc_list =
  match tc_list with
    [] -> []
  | ((c0, t0)::l0) ->
    let rec is_in_until = function
	[] -> false
      | (((ca, a)::l) as public) ->
	if public == oldpub then false else
          if equal_bi_terms_modulo a t0
          then
            begin
              Terms.link c0 (TLink ca);
              true
            end
          else
	    is_in_until l
    in
    if Terms.is_ground_public (fst t0) && Terms.equal_terms (fst t0) (snd t0)
    then
      begin
        Terms.link c0 (TLink (fst t0));
        remove_first_in_public public l0
      end
    else
    if is_in_until public then
      remove_first_in_public public l0
    else
      tc_list


(* We maintain the following invariants in public and prepared_attacker_rule:
   1/ All rules in prepared_attacker_rule are for a phase later or equal to the current one.
      Rules for a previous phase are removed.
   2/ All rules in prepared_attacker_rule for the current phase have non-empty assumptions.
      Rules with empty assumptions are removed after adding their conclusion to public.
   3/ All assumptions of rules in prepared_attacker_rule are not in public.
      When an assumption is in public, we remove it, and possibly apply 2/.

[add_public_and_close state l] guarantees that these invariants are preserved after
addition of the terms in [l] to public.
It removes assumptions of rules in prepared_attacker_rule that are in [l].
When a rule then has no assumptions and is for the current phase, it adds the
conclusion to public and continues closing recursively.

*)

let add_public_and_close state l =
  let queue = ref l in
  let rec remove_from_att_rules public ((recipe, t) as pair) = function
      [] -> []
    | (p, hyp_terms, (recipe_concl, concl_bi_term))::attacker_rules ->
	let attacker_rules' = remove_from_att_rules public pair attacker_rules in
	let phase_p = getphase p in
	assert (phase_p >= state.current_phase);
	let hyp_terms' = match hyp_terms with
	  [] -> []
	| ((c0, t0)::l0) ->
	    if equal_bi_terms_modulo t0 t then
	      begin
		link c0 (TLink recipe);
		remove_first_in_public public l0
	      end
	    else
	      hyp_terms
	in
	if (hyp_terms' = []) && (phase_p = state.current_phase) then
	  begin
	    queue := (decompose_term (Terms.copy_term4 recipe_concl, concl_bi_term)) @ (!queue);
	    attacker_rules'
	  end
	else
	  (* Keep the rule, removing hypotheses that are already in public *)
	  (p, hyp_terms', (recipe_concl, concl_bi_term)) :: attacker_rules'
  in
  let rec do_close state =
    match !queue with
      [] -> state
    | ((c, t)::l) ->
	queue := l;
	if List.exists (fun (_, t') -> equal_bi_terms_modulo t t') state.public then
	  do_close state
	else
	  let public' = (c, t) :: state.public in
	  do_close { state with
                     public = public';
                     prepared_attacker_rule = remove_from_att_rules public' (c, t) state.prepared_attacker_rule }
  in
  do_close state

let rec add_public_with_recipe state (recipe, t) =
  match t with
    (FunApp({ f_cat = Tuple } as f, l), FunApp({f_cat = Tuple} as f',l')) when f == f' ->
       let projs = Terms.get_all_projection_fun f in
       add_public_list state (List.map2 (fun fi ti -> (FunApp(fi, [recipe]), ti)) projs (List.combine l l'))
  | t -> add_public_and_close state [(recipe, t)]

and add_public_list state = function
    [] -> state
  | (a::l) -> add_public_list (add_public_with_recipe state a) l

(* [close_public_after_phase_increment state] guarantees that the invariants on
   public and prepared_attacker_rule mentioned above are preserved after a phase increment.
   It removes rules for previous phases, adds to public the conclusions
   of rules with no assumptions in the new phase, and closes using
   [add_public_and_close]. *)

let close_public_after_phase_increment state =
  let queue = ref [] in
  let rec remove_from_att_rules public = function
      [] -> []
    | ((p, hyp_terms, (recipe_concl, concl_bi_term)) as rule)::attacker_rules ->
	let attacker_rules' = remove_from_att_rules public attacker_rules in
	let phase_p = getphase p in
	if phase_p < state.current_phase then attacker_rules' else
	if (hyp_terms = []) && (phase_p = state.current_phase) then
	  begin
	    queue := (decompose_term (Terms.copy_term4 recipe_concl, concl_bi_term)) @ (!queue);
	    attacker_rules'
	  end
	else
	  (* Keep the rule *)
	  rule :: attacker_rules'
  in
  let state' =
    { state with
      prepared_attacker_rule = remove_from_att_rules state.public state.prepared_attacker_rule }
  in
  add_public_and_close state' (!queue)

(* [close_public_phase_change state n] changes the current phase to [n]
   after closes public, by incrementing the phase from [state.current_phase] to [n]
   and closing by [close_public_after_phase_increment] at each increment. *)

let rec close_public_phase_change state n =
  if n < state.current_phase then
    Parsing_helper.internal_error "Phases should be in increasing order.";
  if n = state.current_phase then state else
  let state1 = { state with current_phase = state.current_phase + 1 } in
  let state2 = close_public_after_phase_increment state1 in
  close_public_phase_change state2 n

(* [close_public_initial state] guarantees that the invariants on
   public and prepared_attacker_rule mentioned above are true initially.
   It applies rules with empty assumptions in phase 0 by
   [close_public_after_phase_increment] and
   closes with terms initially known to be public by
   [add_public_list]. *)

let close_public_initial state =
  let state0 = { state with public = [] } in
  let state1 = close_public_after_phase_increment state0 in
  add_public_list state1 state.public


let add_public state t =
  let new_recipe = new_var ~orig:false "~M" (get_term_type (fst t)) in
  let l = decompose_term_rev (new_recipe, t) in
  let l' = List.map (fun (b,t) -> (Var b, t)) l in
  let state' = add_public_and_close state l' in
  (Terms.copy_term4 (Var new_recipe), state')


let optional_eavesdrop state public_channel mess_term =
  if public_channel then
     (* The adversary is passive and the channel is public;
        the adversary eavesdrops the message sent by RIO / RIO_PatRemove *)
     let (new_recipe, state') = add_public state mess_term in
    (Some new_recipe, state')
  else
    (None, state)

let get_occurrence_name_for_precise occ name_params =
  let (np,npm) =
    List.fold_right (fun (m,t,_) (acc_np,acc_npm) -> match m with
      | MSid _ -> (t::acc_np,m::acc_npm)
      | _ -> (acc_np,acc_npm)
    ) name_params ([],[])
  in
  let n = Reduction_helper.get_occ_name occ in
  match n.f_cat with
    | Name r ->
        let n' = FunApp(n,np) in
        FunApp(add_name_for_pat n',[])
    | _ -> Parsing_helper.internal_error "[reduction_bipro.ml >> get_occurrence_name_for_precise] Unexpected case."

(* Do reductions that do not involve interactions
   f takes as input
      - a boolean indicating whether the attacker knowledge has changed
      - the new state

   When the goal is reached, do_red_nointeract returns the final state.
   Otherwise, raises an exception No_result.
*)

let rec do_red_nointeract f prev_state n =
  let (proc, name_params, occs, facts, cache_info) =
         List.nth prev_state.subprocess n in
  match proc with
    Nil -> debug_print "Doing Nil";
      made_forward_step := true;
      f false (do_rnil prev_state n)
  | Par(p,q) ->
      debug_print "Doing Par";
      made_forward_step := true;
      do_red_nointeract (fun new_att_know cur_state2 ->
        do_red_nointeract (fun new_att_know2 cur_state3 ->
             f (new_att_know || new_att_know2) cur_state3)
          cur_state2 n
        ) { prev_state with
            subprocess = add_at n (p, name_params, occs, facts, Nothing)
                        (replace_at n (q, name_params, occs, facts, Nothing)
                         prev_state.subprocess);
            comment = RPar(n);
            previous_state = Some prev_state } (n+1)
  | Restr(na,(args,env),p,occ) ->
      debug_print "Doing Restr";
      made_forward_step := true;
      let need_list = get_need_vars (!Param.current_state) na in
      let include_info = prepare_include_info env args need_list in
      let l = extract_name_params na include_info name_params in
      let n' = FunApp(add_name_for_pat (FunApp(na, l)),[]) in
      let p' = process_subst p na n' in
      begin
        do_red_nointeract f { prev_state with
            subprocess = replace_at n (p', name_params, occs, facts, Nothing) prev_state.subprocess;
            comment = RRestr(n, na, n');
            previous_state = Some prev_state } n
      end
  | Let(pat,t,p,q,occ) ->
      debug_print "Doing Let";
      made_forward_step := true;
      let new_occs = (LetTag occ) :: occs in
      begin
      try
        auto_cleanup_red (fun () ->
          let t', name_params' = term_evaluation_name_params_and_match prev_state pat (OLet(occ)) t name_params in
          let p' = copy_process p in
          let name_params'' = update_name_params prev_state IfQueryNeedsIt name_params' pat in
          do_red_nointeract f { prev_state with
            subprocess = replace_at n (p', name_params'', new_occs, facts, Nothing) prev_state.subprocess;
            comment = RLet_In(n, pat, make_bi_choice t');
            previous_state = Some prev_state } n
        )
      with Unify ->
        do_red_nointeract f { prev_state with
          subprocess = replace_at n (q, name_params, new_occs, facts, Nothing) prev_state.subprocess;
          comment = RLet_Else(n, pat, t);
          previous_state = Some prev_state } n
      | FailOnlyOnSide _ ->
          if is_equivalence_goal prev_state.goal
          then
            (* SUCCESS *)
            { prev_state with
              goal = NonInterfGoal(ProcessTest([],[],(Some(n, List.nth prev_state.subprocess n)))) }
          else
            f false { prev_state with
                      subprocess = remove_at n prev_state.subprocess;
                      comment = RLet_Remove(n,pat, t);
                      previous_state = Some prev_state }
      end
  | Test(t,p,q,occ) ->
      debug_print "Doing Test";
      made_forward_step := true;
      if q == Nil then
        (* Optimize the case q == Nil: in this case, the adversary
           cannot distinguish whether a destructor fails in t or
           t is false. *)
        begin
        try
          auto_cleanup_red (fun () ->
            let new_occs = (TestTag occ) :: occs in
            let name_params' = term_evaluation_name_params_true prev_state (OTest(occ)) t name_params in
            do_red_nointeract f
                    { prev_state with
                      subprocess = replace_at n (p, name_params', new_occs, facts, Nothing) prev_state.subprocess;
                      comment = RTest_Then(n, t);
                      previous_state = Some prev_state } n
              )
        with Unify ->
          f false { prev_state with
              subprocess = remove_at n prev_state.subprocess;
              comment = RTest_Remove(n, t, TestFails);
              previous_state = Some prev_state }
        | FailOnlyOnSide _ ->
            if is_equivalence_goal prev_state.goal
            then
              (* SUCCESS *)
              { prev_state with
                goal = NonInterfGoal(ProcessTest([],[],(Some(n, List.nth prev_state.subprocess n)))) }
            else
              f false { prev_state with
                  subprocess = remove_at n prev_state.subprocess;
                  comment = RTest_Remove(n, t, Blocks);
                  previous_state = Some prev_state }
        end
      else
        begin
        try
          auto_cleanup_red (fun () ->
            let new_occs = (TestTag occ) :: occs in
            let (t', name_params') = term_evaluation_name_params prev_state (OTest(occ)) t name_params in
            if is_true_test t' then
              do_red_nointeract f
                    { prev_state with
                      subprocess = replace_at n (p, name_params', new_occs, facts, Nothing) prev_state.subprocess;
                      comment = RTest_Then(n, t);
                      previous_state = Some prev_state } n
            else
              do_red_nointeract f
                    { prev_state with
                      subprocess = replace_at n (q, name_params', new_occs, facts, Nothing) prev_state.subprocess;
                      comment = RTest_Else(n, t);
                      previous_state = Some prev_state } n
                )
        with Unify ->
          f false { prev_state with
              subprocess = remove_at n prev_state.subprocess;
              comment = RTest_Remove(n, t, DestrFails);
              previous_state = Some prev_state }
        | FailOnlyOnSide _ ->
            if is_equivalence_goal prev_state.goal
            then
              (* SUCCESS *)
              { prev_state with
                goal = NonInterfGoal(ProcessTest([],[],(Some(n, List.nth prev_state.subprocess n)))) }
            else
              f false { prev_state with
                  subprocess = remove_at n prev_state.subprocess;
                  comment = RTest_Remove(n, t, Blocks);
                  previous_state = Some prev_state }
        end
  | Output(tc,t,p,occ) ->
      let new_goal_opt =
        if cache_info != Nothing then
          None (* Was already tested and failed before; will still fail if tested again *)
        else
          match prev_state.goal with
            NonInterfGoal(CommTest(tin,tout,loc)) ->
            if equal_terms_modulo_eval tc tout then
              begin
                  (match is_in_public prev_state.public tin with
                   Some (recipe) ->
                      begin
                        let new_loc = Some (LocAttacker (recipe), LocProcess(n, List.nth prev_state.subprocess n)) in
                        Some (NonInterfGoal(CommTest(tin,tout,new_loc)))
                      end
                   | None ->  (* find a process that does some input on tin *)
                       try
                          let (n',p') =
                            findi (function
                              (Input(tc,_,_,_),_,_,_,_) -> equal_terms_modulo_eval tc tin
                            | _ -> false
                           ) prev_state.subprocess
                          in
                          let new_loc = Some (LocProcess(n',p'), LocProcess(n, List.nth prev_state.subprocess n)) in
                          Some (NonInterfGoal(CommTest(tin,tout,new_loc)))
                        with Not_found ->
                    None)
                end
              else None
          | _ -> None
      in
      begin
        match new_goal_opt with
          Some new_goal -> { prev_state with goal = new_goal }
        | None ->
        debug_print "Doing Output";
        (* For passive attackers, do red I/O only,
           but still evaluate the arguments of the output *)
        if not (!Param.active_attacker) then
          match cache_info with
            InputInfo _ | GetInfo _ -> Parsing_helper.internal_error "Should not have input/get info for an output!"
          | OutputInfo _ -> f false prev_state (* Arguments already evaluated *)
          | Nothing ->
              try
                auto_cleanup_red (fun () ->
                  let ((tc1,t1),(tc2,t2)) = bi_action (term_evaluation_fail2 tc t) in
                  let tc' = (tc1, tc2) in
                  let t' = (t1, t2) in
                  let tclist = decompose_term_rev (Terms.new_var ~orig:false "Useless" (Terms.get_term_type tc1), tc') in
                  f false { prev_state with
                            subprocess = replace_at n (Output(make_bi_choice tc', make_bi_choice t',p,occ),
                                                       name_params, occs, facts,
                                                       (OutputInfo(tclist, prev_state.public)))
                                     prev_state.subprocess }
                    )
              with Unify ->
                f false { prev_state with
                      subprocess = remove_at n prev_state.subprocess;
                      comment = ROutput_Remove(n, tc, t, DestrFails);
                      previous_state = Some prev_state }
              | FailOnlyOnSide _ ->
                  if is_equivalence_goal prev_state.goal
                  then
                    (* SUCCESS *)
                    { prev_state with
                      goal = NonInterfGoal(ProcessTest([],[],(Some(n, List.nth prev_state.subprocess n)))) }
                  else
                    f false { prev_state with
                          subprocess = remove_at n prev_state.subprocess;
                          comment = ROutput_Remove(n, tc, t, Blocks);
                          previous_state = Some prev_state }
        else
        (* For active attackers, one can output on public channels *)
        begin
          let new_occs = (OutputTag occ) :: occs in
          match cache_info with
            InputInfo _ | GetInfo _ -> Parsing_helper.internal_error "Should not have input/get info for an output!"
          | OutputInfo(tclist, oldpub) ->
              let tclist' = update_term_list oldpub prev_state.public tclist in
              if tclist' = [] then
                 begin
                   made_forward_step := true;
                          let (new_recipe, prev_state') = add_public prev_state (get_choice t) in
                   do_red_nointeract (if prev_state.public == prev_state'.public then f else
                  (fun mod_public cur_state -> f true cur_state))
                    { prev_state' with
                      subprocess = replace_at n (p, name_params, new_occs, facts, Nothing) prev_state.subprocess;
                      comment = ROutput_Success(n, tc, new_recipe, t);
                      previous_state = Some prev_state } n
                end
              else
                f false { prev_state with
                          subprocess = replace_at n (proc, name_params, occs, facts,
                                                     (OutputInfo(tclist', prev_state.public)))
                                         prev_state.subprocess }
          | Nothing ->
              try
                auto_cleanup_red (fun () ->
                  let ((tc1,t1),(tc2,t2)) = bi_action (term_evaluation_fail2 tc t) in
                  let tc' = (tc1, tc2) in
                  let t' = (t1, t2) in
                  let tclist = decompose_term_rev (Terms.new_var ~orig:false "Useless" (Terms.get_term_type tc1), tc') in
                  let tclist' = remove_first_in_public prev_state.public tclist in
                  if tclist' = [] then
                    begin
                      made_forward_step := true;
                      let (new_recipe, prev_state') = add_public prev_state t' in
                      do_red_nointeract (if prev_state.public == prev_state'.public then f else
                      (fun mod_public cur_state -> f true cur_state))
                              { prev_state' with
                                  subprocess = replace_at n (p, name_params, new_occs, facts, Nothing) prev_state.subprocess;
                                  comment = ROutput_Success(n, make_bi_choice tc', new_recipe, make_bi_choice t');
                                  previous_state = Some prev_state } n
                    end
                  else
                    (* When one side is a channel and the other side is not,
                       we keep the Output process; the failure of the equivalence
                       will be detected (or has already been detected) by CommTest *)
                    f false { prev_state with
                              subprocess = replace_at n (Output(make_bi_choice tc', make_bi_choice t',p,occ), name_params, occs, facts,
                                                         (OutputInfo(tclist', prev_state.public)))
                                               prev_state.subprocess }
                          )
              with Unify ->
                f false { prev_state with
                      subprocess = remove_at n prev_state.subprocess;
                      comment = ROutput_Remove(n, tc, t, DestrFails);
                      previous_state = Some prev_state }
              | FailOnlyOnSide _ ->
                  if is_equivalence_goal prev_state.goal
                  then
                    (* SUCCESS *)
                    { prev_state with
                      goal = NonInterfGoal(ProcessTest([],[],(Some(n, List.nth prev_state.subprocess n)))) }
                  else
                    f false { prev_state with
                          subprocess = remove_at n prev_state.subprocess;
                          comment = ROutput_Remove(n, tc, t, Blocks);
                          previous_state = Some prev_state }
        end
      end
  | Event(FunApp(fs,l) as t,_,p,occ) ->
      debug_print "Doing Event";
      made_forward_step := true;
      let fstatus = Pievent.get_event_status (!Param.current_state) fs in
      let do_end prev_state new_occs new_facts t' =
        let n_subprocess = replace_at n (p,name_params,new_occs,new_facts,Nothing) prev_state.subprocess in

        let (new_goal, event_in_goal, success) =
          (* We do not store the sid list here since they were only used for injective queries.
             This cannot happen when proving lemmas on biprocesses. *)
          update_corresp_goal prev_state.goal (Some (occ,[]))
            (function
              | Pred(pr,[t1';t2']) -> pr == Param.event2_pred && equal_bi_terms_modulo t' (t1',t2')
              | _ -> false
            )
        in
        let bi_t = make_bi_choice t' in
        let new_state =
          { prev_state with
            subprocess = n_subprocess;
            comment = REvent_Success(n,bi_t,event_in_goal);
            events = bi_t::prev_state.events;
            goal = new_goal;
            previous_state = Some prev_state
          }
        in
        if success
        then new_state
        else do_red_nointeract f new_state n
      in
      begin
         (* Check that the argument of the event can be evaluated but otherwise ignore it *)
        try
          begin match fstatus.begin_status with
            | No ->
                auto_cleanup_red (fun () ->
                  let t' = bi_action (term_evaluation_fail t) in
                  let new_occs = (EventTag(occ)) :: occs in
                  do_end prev_state new_occs facts t'
                )
            | NoOcc ->
                auto_cleanup_red (fun () ->
                  let (t1,t2) = bi_action (term_evaluation_fail t) in
                  let new_occs' = (EventTag (occ)) :: occs in
                  let new_occs = BeginFact :: new_occs' in
                  let new_facts = Pred(Param.event2_pred_block,[t1;t2]) :: facts in
		  try
                    find_io_rule (fun _ ->
                      do_end prev_state new_occs new_facts (t1,t2)
			) new_occs' facts name_params [] prev_state.io_rule
		  with Unify -> raise DerivBlocks
                )
            | WithOcc -> Parsing_helper.internal_error "[Reduction_bipro.ml] Unexpected injective event."
          end
        with Unify ->
          f false { prev_state with
                    subprocess = remove_at n prev_state.subprocess;
                    comment = REvent_Remove(n, t, DestrFails);
                    previous_state = Some prev_state }
	| DerivBlocks ->
            f false { prev_state with
                    subprocess = remove_at n prev_state.subprocess;
                    comment = REvent_Remove(n, t, Blocks);
                    previous_state = Some prev_state }
        | FailOnlyOnSide _ ->
            if is_equivalence_goal prev_state.goal
            then
              (* SUCCESS *)
              { prev_state with
                goal = NonInterfGoal(ProcessTest([],[],(Some(n, List.nth prev_state.subprocess n)))) }
            else
              f false { prev_state with
                        subprocess = remove_at n prev_state.subprocess;
                        comment = REvent_Remove(n, t, Blocks);
                        previous_state = Some prev_state }
      end
  | LetFilter _ -> Parsing_helper.user_error "Predicates in 'let suchthat in else' processes are currently incompatible with non-interference.";
  | Repl(p,occ) ->
      debug_print "Doing Repl";
      made_forward_step := true;
      let sid = Terms.new_var ~orig:false "sid" Param.sid_type in
      let new_occs = (ReplTag (occ,count_name_params name_params))::occs in
      let copy_number = ref 0 in
      let new_state = ref { prev_state with
                            subprocess = remove_at n prev_state.subprocess;
                            comment = RRepl(n,0);
                            previous_state = Some prev_state }
      in
      begin
      try
        auto_cleanup (fun () ->
          find_io_rule (function
             [sid_pat] ->
                let p' = auto_cleanup (fun () -> copy_process p) in
                    incr copy_number;
                    new_state := { !new_state with
                            subprocess = add_at n (p', (MSid 0,sid_pat,Always)::name_params, new_occs, facts, Nothing) !new_state.subprocess
                          };
                    raise Unify
           | _ -> Parsing_helper.internal_error "Repl case, reduction.ml"
             ) new_occs facts ((MSid 0,Var sid,Always)::name_params) [Var sid] prev_state.io_rule
           )
      with Unify ->
        debug_print ("Repl: " ^ (string_of_int (!copy_number)) ^ " copies");
        let rec do_red_copies b ncopies state =
          if ncopies < 0 then
            f b state
          else
            do_red_nointeract (fun b' s -> do_red_copies (b||b') (ncopies-1) s) state (n+ncopies)
        in
        do_red_copies false ((!copy_number)-1)
          { !new_state with
            comment = RRepl(n,!copy_number)
          }
     end
  | Input(tc,_,_,_) ->
      begin
        match prev_state.goal with
          NonInterfGoal(CommTest(tin,tout,loc)) ->
            if equal_terms_modulo_eval tc tin then
              begin
                (match  is_in_public prev_state.public tout with
              | Some recipe ->
                  begin
                    let new_loc = Some (LocProcess(n, List.nth prev_state.subprocess n), LocAttacker recipe) in
                    let new_goal = NonInterfGoal(CommTest(tin,tout,new_loc)) in
                    { prev_state with goal = new_goal }
                  end
              | None ->  (* find a process that does some output on tout *)
                  try
                    let (n',p') =
                      findi (function
                          (Output(tc,_,_,_),_,_,_,_) -> equal_terms_modulo_eval tc tout
                        | _ -> false
                              ) prev_state.subprocess
                    in
                    let new_loc = Some (LocProcess(n, List.nth prev_state.subprocess n), LocProcess(n',p')) in
                    let new_goal = NonInterfGoal(CommTest(tin,tout,new_loc)) in
                    { prev_state with goal = new_goal }
                  with Not_found ->
                    f false prev_state)
              end
            else f false prev_state
        | _ -> f false prev_state

      end
  | Insert(t,p,occ) ->
      debug_print "Doing Insert";
      begin
        let new_occs = (InsertTag occ) :: occs in
        let new_element_inserted = ref false in
        try
          auto_cleanup_red (fun () ->
            let t' = bi_action (term_evaluation_fail t) in
            let already_in = List.exists (equal_bi_terms_modulo t') prev_state.tables in
            new_element_inserted := not already_in;
            made_forward_step := true;
            let (new_goal,insert_in_goal,success) =
              update_corresp_goal prev_state.goal None
		(is_table_goal prev_state.current_phase t')
            in
            let bi_t = make_bi_choice t' in
            let new_state =
              { prev_state with
                subprocess = replace_at n (p, name_params, new_occs, facts, Nothing) prev_state.subprocess;
                tables = if already_in then prev_state.tables else t'::prev_state.tables;
                comment = RInsert_Success(n, bi_t, insert_in_goal);
                goal = new_goal;
                previous_state = Some prev_state
              }
            in
            if success
            then new_state
            else do_red_nointeract f new_state n
          )
        with Unify ->
          f false { prev_state with
                    subprocess = remove_at n prev_state.subprocess;
                    comment = RInsert_Remove(n, t, DestrFails);
                    previous_state = Some prev_state }
        | FailOnlyOnSide _ ->
            if is_equivalence_goal prev_state.goal
            then
              (* SUCCESS *)
              { prev_state with
                goal = NonInterfGoal(ProcessTest([],[],(Some(n, List.nth prev_state.subprocess n)))) }
            else
              f false { prev_state with
                        subprocess = remove_at n prev_state.subprocess;
                        comment = RInsert_Remove(n, t, Blocks);
                        previous_state = Some prev_state }
        | No_result ->
            (* The attack reconstruction failed after doing the insert.
               Try not doing it, in case that allows executing the else branch of a Get. *)
            if (!has_backtrack_get) && (!new_element_inserted) then
              f false prev_state
            else
              raise No_result
      end
  | NamedProcess(name, tl, p) ->
    debug_print "Doing NamedProcess";
    do_red_nointeract  f { prev_state with
      subprocess = replace_at n (p, name_params, occs, facts, Nothing) prev_state.subprocess;
      comment = RNamedProcess(n, name, tl);
      previous_state = Some prev_state } n
  | _ -> f false prev_state

(* Test success when the knowledge of the attacker has changed *)

let test_success cur_state' =
  try
    match cur_state'.goal with
    | CorrespGoal(l,id_goals) ->
        let new_goal =
          CorrespGoal (List.map (fun goal -> match goal with
            | Fact(Pred({p_info = AttackerBin(i,_)},[t1;t2]) as fact, _, false) when cur_state'.current_phase <= i ->
                (* compute the new recipe_lst
                   if t is known by the attacker in phase cur_state'.current_phase,
                   it will still be known in phase i *)
                begin match is_in_public cur_state'.public (t1,t2) with
                  | Some recipe -> Fact(fact,Some [recipe],true)
                  | _ -> goal
                end
            | Fact(Pred({p_info = Attacker(i,_)},[t]) as fact, _, false) when cur_state'.current_phase <= i ->
                (* compute the new recipe_lst
                   if t is known by the attacker in phase cur_state'.current_phase,
                   it will still be known in phase i *)
                begin match is_in_public cur_state'.public (t,t) with
                  | Some recipe -> Fact(fact,Some [recipe],true)
                  | _ -> goal
                end
            | Fact(Pred({p_info = MessBin(i,_)},[tc1;t1;tc2;t2]) as fact, _, false) when cur_state'.current_phase <= i ->
                (* compute the new recipe_lst
           	   if tc and t are known by the attacker in phase cur_state'.current_phase,
           	   they will still be known in phase i,
           	   so the attacker will be able to send t on tc in phase i *)
                begin match is_in_public cur_state'.public (t1,t2), is_in_public cur_state'.public (tc1,tc2) with
                  | Some recipe1, Some recipe2 -> Fact(fact, Some [recipe1; recipe2], true)
                  | _ -> goal
                end
            | Fact(Pred({p_info = Mess(i,_)},[tc;t]) as fact, _, false) when cur_state'.current_phase <= i ->
                (* compute the new recipe_lst
           	   if tc and t are known by the attacker in phase cur_state'.current_phase,
           	   they will still be known in phase i,
           	   so the attacker will be able to send t on tc in phase i *)
                begin match is_in_public cur_state'.public (t,t), is_in_public cur_state'.public (tc,tc) with
                  | Some recipe1, Some recipe2 -> Fact(fact, Some [recipe1; recipe2], true)
                  | _ -> goal
                end
            | _ -> goal
          ) l, id_goals)
        in
        (is_success_corresp_goal new_goal, {cur_state' with goal = new_goal})
    | NonInterfGoal(NIEqTest((t1, _),(t2, _))) ->
        (match is_in_public cur_state'.public t1, is_in_public cur_state'.public t2 with
        | Some recipe1, Some recipe2 ->
            let new_goal = NonInterfGoal(NIEqTest((t1, Some recipe1),(t2, Some recipe2))) in
            (true, { cur_state' with goal = new_goal })
          | _ -> (false, cur_state'))
    | NonInterfGoal(NIFailTest (t, _)) ->
        (match is_in_public cur_state'.public t with
        | Some recipe ->
            let new_goal = NonInterfGoal(NIFailTest (t, Some recipe)) in
            (true, { cur_state' with goal = new_goal })
        | None -> (false, cur_state'))
    | NonInterfGoal(CommTest(tin,tout,loc)) ->
        let rin =
           (match is_in_public cur_state'.public tin with
           | Some recipe -> Some (LocAttacker recipe)
           | None ->
               try
                 let (n,p) =
                   findi (function
                      (Input(tc,_,_,_),_,_,_,_) -> equal_terms_modulo_eval tc tin
                    | _ -> false
                    ) cur_state'.subprocess
              in
              Some (LocProcess(n,p))
            with Not_found ->
              None)
        in
        let rout =
           (match is_in_public cur_state'.public tout with
           |  Some recipe -> Some (LocAttacker recipe)
           | None ->
              try
                let (n,p) =
                  findi (function
                    (Output(tc,_,_,_),_,_,_,_) -> equal_terms_modulo_eval tc tout
                  | _ -> false
                  ) cur_state'.subprocess
              in
              Some (LocProcess(n,p))
            with Not_found ->
              None)
        in
        begin
          match rin,rout with
            Some lin, Some lout ->
              let new_goal = NonInterfGoal(CommTest(tin,tout,Some(lin,lout))) in
              (true, { cur_state' with goal = new_goal })
          | _ -> (false, cur_state')
        end
    | _ -> (false, cur_state')
  with Unify ->
    (false, cur_state')

(* let test_success = Profile.f1 "test_success" test_success *)

let end_if_success next_f cur_state =
  let (success, cur_state') = test_success cur_state in
  if success then cur_state' else next_f cur_state'

(* Normalize the state after a reduction *)

let rec find_possible_outputs f cur_state n seen_list = function
    [] -> f cur_state
  | (Output(tc,t,p,out_occ) as proc, name_params, occs, facts, cache_info)::rest_subprocess when (!Param.active_attacker) ->
      let tclist' =
	match cache_info with
	  InputInfo _ | GetInfo _ -> Parsing_helper.internal_error "Should not have input/get info for an output!"
	| OutputInfo(tclist, oldpub) ->
	    update_term_list oldpub cur_state.public tclist
	| Nothing ->
	    let tclist = decompose_term_rev  ((Terms.new_var ~orig:false "Useless" (Terms.get_term_type tc)), (tc, tc)) in
	    remove_first_in_public cur_state.public tclist
      in
      let seen_list' = (proc, name_params, occs, facts, OutputInfo(tclist', cur_state.public)) :: seen_list in
      if tclist' = [] then
        do_red_nointeract (fun change_pub cur_state2 ->
          if change_pub then
            end_if_success (find_possible_outputs_rec f) cur_state2
          else
            find_possible_outputs f cur_state2 0 [] cur_state2.subprocess
	      ) { cur_state with subprocess = List.rev_append seen_list' rest_subprocess } n
      else
	find_possible_outputs f cur_state (n+1) seen_list' rest_subprocess
  | sub_proc::rest_subprocess -> find_possible_outputs f cur_state (n+1) (sub_proc::seen_list) rest_subprocess

and find_possible_outputs_rec f cur_state3 =
	 find_possible_outputs f cur_state3 0 [] cur_state3.subprocess

(*      When the process number n has been changed *)

let normal_state f change_pub cur_state n =
  do_red_nointeract (fun change_pub2 cur_state2 ->
    if change_pub || change_pub2 then
      end_if_success (find_possible_outputs_rec f) cur_state2
    else f cur_state2
	            ) cur_state n

(*      When two processes have been changed, numbers n1 and n2 *)

let normal_state2 f change_pub cur_state n1 n2 =
  let n1',n2' = if n1 < n2 then n1,n2 else n2,n1 in
  do_red_nointeract (fun change_pub2 cur_state2 ->
    do_red_nointeract (fun change_pub3 cur_state3 ->
      if change_pub || change_pub2 || change_pub3 then
        end_if_success (find_possible_outputs_rec f) cur_state3
      else f cur_state3
	              ) cur_state2 n1'
	            ) cur_state n2'

(*      When all processes have been changed *)

let normal_state_all f change_pub cur_state =
  let rec do_red_all change_pub2 cur_state2 n =
    if n < 0 then
      if change_pub2 then
	end_if_success (find_possible_outputs_rec f) cur_state2
      else
	f cur_state2
    else
      do_red_nointeract (fun change_pub3 cur_state3 ->
	do_red_all (change_pub2 || change_pub3) cur_state3 (n-1)
			) cur_state2 n
  in
  do_red_all change_pub cur_state (List.length cur_state.subprocess - 1)

(* Initial attacker knowledge *)

let rec public_build l =
  match l with
  | [] -> []
  | h::t ->
      if not h.f_private then
	(FunApp(h,[]))::(public_build t)
      else
	public_build t

(* Initialize the rule lists *)

let rec init_rule state tree =
  match tree.desc with
    FHAny | FEmpty | FRemovedWithMaxHyp ->
      begin
	match tree.thefact with
	| Pred(p,_) when p == Param.event2_pred_block -> state
	| Pred({ p_info = Attacker _ | AttackerBin _ | Table _ | TableBin _ }, _) ->
            (* We treat
	       - attacker (will add the term to public)
	       - table (will add the term to tables) *)
	    let fact = rev_name_subst_fact tree.thefact in
	    if List.exists (fun (_, fact') -> Terms.equal_facts fact fact') state.hyp_not_matched then
	      (* Do not add [fact] in [state.hyp_not_matched] if it is already present *)
	      state
	    else
	      { state with
                hyp_not_matched = (None, fact)::state.hyp_not_matched }
        | _ ->
	    (* The other hypotheses are ignored, they cannot help us build the trace *)
	    state
      end
  | FRemovedWithProof _ -> state
  | FRule (n, tags, constra, sons,_,_) ->
      let rec init_sons_rule state1 = function
	| [] ->
	    begin
	      match tags with
	        ProcessRule (hsl,nl) ->
                  {state1 with io_rule = (n, List.map (fun t -> rev_name_subst_fact t.thefact) sons,
					  hsl, rev_name_subst_list nl,
					  rev_name_subst_fact tree.thefact)::state1.io_rule}
	      | Apply (f,_) when f.f_cat != Tuple ->
		  begin
		    let (p,c) =
		      match tree.thefact with
			Pred(p,l) -> (p,rev_name_subst_bi l)
		    in
		    let h = List.map (function
			{ thefact = Pred(_,l) } -> (Terms.new_var ~orig:false "~X" (get_term_type_bi l), rev_name_subst_bi l)) sons
                    in
                    let h' = decompose_list_rev h in
		      (* concl_copy is the recipe used to compute the conclusion from the hypotheses *)
                    let recipe_concl = FunApp(f, (List.map (fun (x, y) -> Var x) h)) in
	            {state1 with prepared_attacker_rule = (p, h',(recipe_concl, c))::state1.prepared_attacker_rule}
		  end
              | Rn _ ->
                  begin
	            match tree.thefact with
		      Pred(p, l) ->
			let t1',t2' = rev_name_subst_bi l in
			if not (equal_terms_modulo t1' t2') then
			  Parsing_helper.internal_error "Rule Rn should conclude p(name,name) with the same name";
                        { state1 with prepared_attacker_rule = (p, [], (t1',(t1',t2')))::state1.prepared_attacker_rule }
	          end
	      | _ -> state1
	    end
	| h::t ->
	    let state1' = init_rule state1 h in
	    init_sons_rule state1' t
      in
      init_sons_rule state sons
  | FEquation son -> init_rule state son


(* Handle reductions i/o and in *)

(* Perform an input on a public channel (Res In) *)

let do_res_in cur_state seen_list rest_subprocess n current_cache_list name_params' new_occs facts tc pat p tc' mess_term public_status next_f    =
  (* The real list of processes is (List.rev_append seen_list (InputProcess :: rest_subprocess)) *)
  let (recipe, mess_list, oldpub) =
    match public_status with
      Some (recipe, m,o) -> (recipe, m,o)
    | None ->
        let new_recipe = Terms.new_var ~orig:false "~M" (Terms.get_term_type (fst mess_term)) in
        (Var new_recipe, decompose_term_rev (new_recipe, mess_term), [])
  in
  (* Remove the elements of mess_list' that are already in cur_state.public *)
  let mess_list' = update_term_list oldpub cur_state.public mess_list in
  let recipe' = Terms.copy_term4 recipe in
  (* When mess_list' is not empty, its first element is not in cur_state.public
     Remember that point to avoid testing again that part of public *)
  current_cache_list := (mess_term, Some (recipe', mess_list', cur_state.public)) :: (!current_cache_list);
  if mess_list' != [] then raise Unify; (* The message is not public *)
  try
    made_forward_step := true;
    auto_cleanup_red (fun () ->
      let _ = bi_action (bi_match_pattern pat mess_term) in
      let name_params'' = update_name_params cur_state Always name_params' pat in
      let p' = auto_cleanup (fun () -> copy_process p) in
      let fact' = build_mess_fact cur_state.current_phase tc' mess_term in
      let fact_list = match new_occs with
        | (InputTag _)::(PreciseTag(occ))::_ ->
            let occ_n = get_occurrence_name_for_precise occ name_params' in
            fact' :: (build_precise_fact occ_n mess_term) :: facts
        | (InputTag _) :: _ -> fact' :: facts
        | _ -> Parsing_helper.internal_error "[reduction_bipro.ml >> do_res_in] First element of new_occs should be an input tag."
      in
      normal_state next_f false
        { cur_state with
            subprocess = List.rev_append seen_list ((p', name_params'', new_occs, fact_list, Nothing) :: rest_subprocess);
            comment = RInput_Success(n, make_bi_choice tc', pat, recipe', make_bi_choice mess_term);
            previous_state = Some cur_state } n
    )
  with No_result ->
    (* Inputting the message mess_term on this input will always fail,
       even in the following of the trace *)
    current_cache_list := List.tl (!current_cache_list);
    raise Unify
  | FailOnlyOnSide _ ->
      if is_equivalence_goal cur_state.goal
      then
        (* SUCCESS the pattern matching fails on one side only *)
          { cur_state with
            goal = NonInterfGoal(InputProcessTest([],[],make_bi_choice mess_term, (Some(n, List.nth cur_state.subprocess n, LocAttacker recipe')))) }
      else
	begin
	  (* I can remove this message from the cache, since retrying this input
	     with the same message will always fail on one side, and I do not want
             to consider that. *)
	  current_cache_list := List.tl (!current_cache_list);
          raise Unify
	end

(* Perform a (Red I/O) reduction between an input and an asynchronous output *)

let do_async_res_io cur_state seen_list rest_subprocess n current_cache_list name_params' new_occs facts tc pat p tc' mess_term public_channel next_f  =
  (* The real list of processes is (List.rev_append seen_list (InputProcess :: rest_subprocess))
     It differs from cur_state.subprocess only by the cache of input processes, so when
     looking for an output process, we can use cur_state.subprocess instead. *)
  current_cache_list := (mess_term, None) :: (!current_cache_list);
  (* Find the corresponding asynchronous output *)
  let rec find_asynchronous_output noutput = function
      [] -> raise Unify (* not found *)
    | ((Output(tc2, t2, Nil,out_occ), name_params2,occs2, facts2, cache_info2)::_) when
      (equal_bi_terms_modulo (get_choice tc2) tc') && (equal_bi_terms_modulo (get_choice t2) mess_term) -> noutput
    | _::rest_subprocess2 -> find_asynchronous_output (noutput+1) rest_subprocess2
  in
  let noutput = find_asynchronous_output 0 cur_state.subprocess in
  begin
    try
      made_forward_step := true;
      let fail_case input_fails =
        (* The pattern does not match *)
        let noutput' = if n>noutput then noutput else noutput-1 in

        let (_, name_params2,occs2, facts2, _) = List.nth cur_state.subprocess noutput in
        let (new_goal,comm_in_goal,attack_found) =
          update_corresp_goal cur_state.goal None
	    (is_mess_goal cur_state.current_phase tc' mess_term)
        in

        let tc'' = make_bi_choice tc' in
        (* When the adversary is passive and the channel is public,
           the adversary eavesdrops the message sent by RIO_PatRemove *)
	let (opt_recipe, cur_state1) = optional_eavesdrop cur_state public_channel mess_term in
        let cur_state2 =
            { cur_state1  with
              subprocess = replace_at noutput' (Nil, name_params2,occs2, facts2, Nothing) (List.rev_append seen_list rest_subprocess);
              comment = RIO_PatRemove(n, tc'', pat, noutput, tc'', opt_recipe, make_bi_choice mess_term, comm_in_goal, input_fails);
              goal = new_goal;
              previous_state = Some cur_state
            }
        in
	let cur_state3 = do_rnil cur_state2 noutput' in
        if attack_found
        then cur_state3
        else next_f cur_state3
      in
      try
        auto_cleanup_red (fun () ->
          let _ = bi_action (bi_match_pattern pat mess_term) in
          let name_params'' = update_name_params cur_state Always name_params' pat in
          let p' = auto_cleanup (fun () -> copy_process p) in
          let fact' = build_mess_fact cur_state.current_phase tc' mess_term in
          let facts' = match new_occs with
            | (InputTag _)::(PreciseTag(occ))::_ ->
                let occ_n = get_occurrence_name_for_precise occ name_params' in
                fact' :: (build_precise_fact occ_n mess_term) :: facts
            | (InputTag _) :: _ -> fact' :: facts
            | _ -> Parsing_helper.internal_error "[reduction.ml >> do_async_res_io] First element of new_occs should be an input tag."
          in

          let tc'' = make_bi_choice tc' in

          let (_, name_params2,occs2, facts2, _) = List.nth cur_state.subprocess noutput in
          let (new_goal,comm_in_goal,attack_found) =
            update_corresp_goal cur_state.goal None
	      (is_mess_goal cur_state.current_phase tc' mess_term)
          in

          (* When the adversary is passive and the channel is public,
             the adversary eavesdrops the message sent by RIO *)
	  let (opt_recipe, cur_state1) = optional_eavesdrop cur_state public_channel mess_term in
          let cur_state' =
              { cur_state1 with
                subprocess = replace_at noutput (Nil, name_params2,occs2, facts2, Nothing)
                  (List.rev_append seen_list ((p', name_params'', new_occs, facts', Nothing) :: rest_subprocess));
                comment = RIO(n, tc'', pat, noutput, tc'', opt_recipe, make_bi_choice mess_term, comm_in_goal);
                goal = new_goal;
                previous_state = Some cur_state
              }
          in
          (* Then do RNil on the Nil process that follows the output *)
          let cur_state3 = do_rnil cur_state' noutput in
          let ninput = if n > noutput then n-1 else n in
          if attack_found
          then cur_state3
          else normal_state next_f (cur_state3.public != cur_state.public) cur_state3 ninput
        )
      with
        | Unify -> fail_case true
        | FailOnlyOnSide _ ->
            if is_equivalence_goal cur_state.goal
            then
              (* SUCCESS the pattern matching fails on one side only *)
              { cur_state with
                      goal = NonInterfGoal(InputProcessTest([],[],make_bi_choice mess_term, Some(n, List.nth cur_state.subprocess n, LocProcess(noutput, List.nth cur_state.subprocess noutput)))) }
            else fail_case false
    with No_result ->
      current_cache_list := List.tl (!current_cache_list);
      raise Unify
  end


(* Perform a (Res I/O) reduction with a synchronous output *)

let do_sync_res_io cur_state seen_list rest_subprocess n name_params' new_occs facts tc pat p tc' public_channel next_f   =
  (* The real list of processes is (List.rev_append seen_list (InputProcess :: rest_subprocess))
     It differs from cur_state.subprocess only by the cache of input processes, so when
     looking for an output process, we can use cur_state.subprocess instead. *)
  let rec find_synchronous_output noutput = function
      [] -> raise No_result (* Not found *)
    | ((Output(tc2,t2,p2,out_occ),name_params2,occs2, facts2, cache_info2)::rest_subprocess2) ->
      begin
        (* when (p2 != Nil) || public_channel || not (is_equivalence_goal cur_state.goal) *)
        try
          let tc2' = get_choice tc2 in
          let t2' = get_choice t2 in
          if equal_bi_terms_modulo tc2' tc' then
            begin
              let (new_goal,comm_in_goal,attack_found) =
                update_corresp_goal cur_state.goal None
		  (is_mess_goal cur_state.current_phase tc2' t2')
              in

              (* When p2 is Nil and the Horn clause derivation does not justify the
		 input, the output is useless (because it does not allow to execute
		 more instructions), except in two situations:
		 - when the attacker is passive and the channel is public;
                   in this case, it allows the attacker to obtain the message
                   (public_channel is true in this case)
		 - when the communication itself is what makes the attack succeed,
                   that is, the goal is that communication.
                   (comm_in_goal is true in this case) *)
              if not ((p2 != Nil) || public_channel || comm_in_goal)
              then raise Unify;

              made_forward_step := true;
              (* The i/o reduction is possible, compute the reduced state *)
              let fact = build_mess_fact cur_state.current_phase tc' t2' in
              let facts' = match new_occs with
                | (InputTag _)::(PreciseTag(occ))::_ ->
                    let occ_n = get_occurrence_name_for_precise occ name_params' in
                    fact :: (build_precise_fact occ_n t2') :: facts
                | (InputTag _) :: _ -> fact :: facts
                | _ -> Parsing_helper.internal_error "[reduction.ml >> do_sync_res_io] First element of new_occs should be an input tag."
              in
              let fail_case input_fails =
                (* The pattern does not match *)
                let noutput' = if n > noutput then noutput else noutput-1 in
                (* When the adversary is passive and the channel is public,
		   the adversary eavesdrops the message sent by RIO_PatRemove *)
		let (opt_recipe, cur_state1) = optional_eavesdrop cur_state public_channel t2' in
                let cur_state' =
                    { cur_state1 with
                      subprocess = replace_at noutput' (p2, name_params2, (OutputTag out_occ)::occs2, facts2, Nothing)
                        (List.rev_append seen_list rest_subprocess);
                      comment = RIO_PatRemove(n, make_bi_choice tc', pat, noutput, tc2, opt_recipe, t2, comm_in_goal, input_fails);
                      goal = new_goal;
                      previous_state = Some cur_state }
                in

                if attack_found
                then cur_state'
                else normal_state next_f (cur_state'.public != cur_state.public) cur_state' noutput'
              in

              try
                auto_cleanup_red (fun () ->
                  let _ = bi_action (bi_match_pattern pat t2') in
                  let name_params'' = update_name_params cur_state Always name_params' pat in
                  let p' = auto_cleanup (fun () -> copy_process p) in
                  (* When the adversary is passive and the channel is public,
                     the adversary eavesdrops the message sent by RIO *)
		  let (opt_recipe, cur_state1) = optional_eavesdrop cur_state public_channel t2' in
                  let cur_state' =
                      { cur_state1 with
                          subprocess = replace_at noutput (p2, name_params2, (OutputTag out_occ)::occs2, facts2, Nothing)
                            (List.rev_append seen_list ((p', name_params'', new_occs, facts', Nothing) :: rest_subprocess));
                          comment = RIO(n, make_bi_choice tc', pat, noutput, tc2, opt_recipe, t2, comm_in_goal);
                          goal = new_goal;
                          previous_state = Some cur_state }
                  in
                  if attack_found
                  then cur_state'
                  else normal_state2 next_f (cur_state'.public != cur_state.public) cur_state' noutput n
                )
              with
                | Unify -> fail_case true
                | FailOnlyOnSide _ ->
                    if is_equivalence_goal cur_state.goal
                    then
                      (* SUCCESS the pattern matching fails on one side only *)
                      { cur_state with
                        goal = NonInterfGoal(InputProcessTest([],[],t2,Some(n, List.nth cur_state.subprocess n, LocProcess(noutput, List.nth cur_state.subprocess noutput)))) }
                    else fail_case false
            end
          else raise Unify
        with Unify | No_result ->
          find_synchronous_output (noutput+1) rest_subprocess2
      end
    | _::rest_subprocess2 -> find_synchronous_output (noutput+1) rest_subprocess2
  in
  find_synchronous_output 0 cur_state.subprocess
(* Perform a get (Res Get) *)

let rec find_term stop_l t l =
  if l == stop_l then false else
  match l with
    [] -> false
  | (a::r) ->
      if equal_bi_terms_modulo t a then true else find_term stop_l t r

let do_res_get cur_state seen_list rest_subprocess n current_cache_list name_params' new_occs facts pat t p mess_term old_tables next_f    =
  (* The real list of processes is (List.rev_append seen_list (InputProcess :: rest_subprocess)) *)
  current_cache_list := mess_term :: (!current_cache_list);
  debug_print "Get";
  if not (find_term old_tables mess_term cur_state.tables) then raise Unify; (* The entry is not found *)
  debug_print "Ok, the entry is present";
  try
    made_forward_step := true;
    auto_cleanup_red (fun () ->
      (* we check that the pattern pat matches and t evaluates to true *)
      let _ = bi_action (bi_match_pattern_and_test pat mess_term t) in
      let name_params'' = update_name_params cur_state Always name_params' pat in
      let p' = auto_cleanup (fun () -> copy_process p) in
      let fact' = build_table_fact cur_state.current_phase mess_term in
      let facts' = match new_occs with
        | (GetTag _)::(PreciseTag(occ))::_ ->
            let occ_n = get_occurrence_name_for_precise occ name_params' in
            fact' :: (build_precise_fact occ_n mess_term) :: facts
        | (GetTag _) :: _ -> fact' :: facts
        | _ -> Parsing_helper.internal_error "[reduction.ml >> do_res_get] First element of new_occs should be a Get tag."
      in
      normal_state next_f false
		{ cur_state with
                  subprocess = List.rev_append seen_list ((p', name_params'', new_occs, facts', Nothing) :: rest_subprocess);
                  comment = RGet_In(n, pat, t, make_bi_choice mess_term);
                  previous_state = Some cur_state } n
	)
  with No_result ->
    (* Using the entry mess_term on this input will always fail,
       even in the following of the trace *)
    current_cache_list := List.tl (!current_cache_list);
    raise Unify
  | FailOnlyOnSide _ ->
    if is_equivalence_goal cur_state.goal then
      (* SUCCESS the pattern matching fails on one side only *)
      { cur_state with
        goal = NonInterfGoal(ProcessTest([],[],Some(n, List.nth cur_state.subprocess n))) }
    else
      next_f
	{ cur_state with
          subprocess = remove_at n cur_state.subprocess;
          comment = RGet_Remove(n, pat, t);
          previous_state = Some cur_state }

(* Dispatch between (Res In), asynchronous (Res I/O), and synchronous (Res I/O), and (Res Get).
   May also execute (Insert) in case an insert has been delayed because it prevented executing the
   else branch of Get. *)

exception Backtrack_get
(* This exception is used only when I should take the
   else of Get and I cannot because an element that
   makes Get succeed already occurs. *)

let rec find_in_out next_f cur_state n seen_list = function
    [] -> raise No_result
  | ((Input(tc,pat,p,occ) as proc ,name_params,occs, facts, cache_info)::rest_subprocess) ->
      debug_print ("Trying Input on process " ^ (string_of_int n));
      begin
	match cache_info with
	  OutputInfo _ | GetInfo _ -> Parsing_helper.internal_error "Should not have output/get info for an input!"
	| InputInfo(tc_list, oldpub, tc', name_params', new_occs, l) ->
	    let tc_list' = update_term_list oldpub cur_state.public tc_list in
	    if (!Param.active_attacker) && (tc_list' = []) then
	      begin
	        (* The channel is public and the attacker is active, try (Res In) *)
		let current_cache_list = ref [] in
		let rec do_l = function
		    [] ->
		      let seen_list' = (proc ,name_params,occs, facts,
					InputInfo(tc_list', cur_state.public, tc', name_params', new_occs, !current_cache_list)) :: seen_list in
		      find_in_out next_f cur_state (n+1) seen_list' rest_subprocess
		  | (mess_term, public_status)::l ->
		      try
	                 do_res_in cur_state seen_list rest_subprocess n current_cache_list name_params' new_occs facts tc pat p tc' mess_term public_status next_f
		      with Unify ->
		      do_l l
		in
		do_l l
	      end
	    else
	      begin
	        (* The channel is private or the attacker is passive, try (Res I/O) *)
		let current_cache_list = ref [] in
		let public_channel = (not (!Param.active_attacker)) && (tc_list' = []) in
		let rec do_l = function
		    [] ->
		      let seen_list' = (proc ,name_params,occs, facts,
					InputInfo(tc_list', cur_state.public, tc', name_params', new_occs, !current_cache_list)) :: seen_list in
		      begin
			try
			  do_sync_res_io cur_state seen_list rest_subprocess n name_params' new_occs facts tc pat p tc' public_channel next_f
			with Unify | No_result ->
			  find_in_out next_f cur_state (n+1) seen_list' rest_subprocess
		      end
		  | (mess_term,_)::l ->
		      try
			do_async_res_io cur_state seen_list rest_subprocess n current_cache_list name_params' new_occs facts tc pat p tc' mess_term public_channel next_f
		      with Unify ->
			do_l l
		in
		do_l l
	      end
	| Nothing ->
	    let seen_list' = ref ((proc, name_params, occs, facts, cache_info) :: seen_list) in
	    try
              auto_cleanup_red (fun () ->
		let (tc', name_params') = term_evaluation_name_params cur_state (OInChannel(occ)) tc name_params in
		let m =
		  if cur_state.current_phase < get_min_choice_phase() then
		    let v = Reduction_helper.new_var_pat pat in
		    (v,v)
		  else
		    (Reduction_helper.new_var_pat pat, Reduction_helper.new_var_pat pat)
		in
		let fact = build_mess_fact cur_state.current_phase tc' m in
                let (new_occs,new_facts) =
                  let ty = get_term_type (fst m) in
                  if Reduction_helper.exists_specific_precise_events_of_occ occ (Action ty)
                  then
                    let occ_n = get_occurrence_name_for_precise occ name_params' in
                    ((InputTag occ) :: (PreciseTag(occ)) :: occs, (fact :: (build_precise_fact occ_n m) :: facts))
                  else ((InputTag occ) :: occs, (fact :: facts))
                in

                let new_recipe = Terms.new_var ~orig:false "Useless" (Terms.get_term_type (fst tc')) in
		let tc_list = decompose_term_rev (new_recipe, tc') in
		let tc_list' = remove_first_in_public cur_state.public tc_list in
		if (!Param.active_attacker) && (tc_list' = []) then
		  begin
		    (* Input on a public channel, and the attacker is active: apply (Res In)  *)
		    let current_cache_list = ref [] in
		    try
		      find_io_rule (function
			  [mess_term1;mess_term2] ->
			    do_res_in cur_state seen_list rest_subprocess n current_cache_list name_params' new_occs facts tc pat p tc' (mess_term1,mess_term2) None next_f
			| _ -> Parsing_helper.internal_error "input case; reduction_bipro.ml"
			      ) new_occs new_facts name_params' [fst m; snd m] cur_state.io_rule
		    with Unify ->
		      seen_list' := (proc, name_params, occs, facts,
				     InputInfo([], [], tc', name_params', new_occs, !current_cache_list)) :: seen_list;
		      raise No_result
		  end
		else
		  begin
		    (* Input on a private channel or the attacker is passive: apply (Res I/O)
		       First try an asynchronous output, with a corresponding clause in the tree *)
		    let current_cache_list = ref [] in
		    let public_channel = (not (!Param.active_attacker)) && (tc_list' = []) in
		    try
		      find_io_rule (function
			  [mess_term1;mess_term2] ->
			    do_async_res_io cur_state seen_list rest_subprocess n current_cache_list name_params' new_occs facts tc pat p tc' (mess_term1,mess_term2) public_channel next_f
			| _ -> Parsing_helper.internal_error "input case; reduction_bipro.ml"
			      ) new_occs new_facts name_params' [fst m; snd m] cur_state.io_rule
                    with Unify ->
		      seen_list' := (proc, name_params,occs, facts,
				     InputInfo(tc_list', cur_state.public, tc', name_params', new_occs, !current_cache_list)) :: seen_list;
		      (* Try a synchronous output *)
		      do_sync_res_io cur_state seen_list rest_subprocess n name_params' new_occs facts tc pat p tc' public_channel next_f
		    end
		    )
	    with Unify | No_result ->
	      find_in_out next_f cur_state (n+1) (!seen_list') rest_subprocess
	  | FailOnlyOnSide _ ->
	      if is_equivalence_goal cur_state.goal then
	        (* SUCCESS the evaluation of the channel name fails on one side only *)
		{ cur_state with
                  goal = NonInterfGoal(ProcessTest([],[],Some(n, List.nth cur_state.subprocess n))) }
	      else
		find_in_out next_f
		  { cur_state with
                    subprocess = remove_at n cur_state.subprocess;
                    comment = RInput_Remove(n, tc, pat, Blocks);
                    previous_state = Some cur_state } n seen_list rest_subprocess
      end
  | ((Get(pat,t,p,p_else,occ) as proc ,name_params,occs, facts, cache_info)::rest_subprocess) ->
      debug_print ("Trying Get on process " ^ (string_of_int n));
      begin
	match cache_info with
	  OutputInfo _ | InputInfo _ -> Parsing_helper.internal_error "Should not have input/output info for a get!"
	| GetInfo(old_tables, l) ->
	    let new_occs =
              if Reduction_helper.exists_specific_precise_events_of_occ occ (Action Param.table_type) then
		(GetTag occ) :: (PreciseTag occ) :: occs
	      else
		(GetTag occ) :: occs
	    in
	    let current_cache_list = ref [] in
	    let rec do_l = function
		[] ->
		  let seen_list' = (proc ,name_params,occs, facts,
				    GetInfo(cur_state.tables, !current_cache_list)) :: seen_list in
		  find_in_out next_f cur_state (n+1) seen_list' rest_subprocess
	      | mess_term::l ->
		  try
		    do_res_get cur_state seen_list rest_subprocess n current_cache_list name_params new_occs facts pat t p mess_term old_tables next_f
		  with Unify ->
		    do_l l
	    in
	    do_l l
	| Nothing ->
	    let seen_list' = ref ((proc, name_params, occs, facts, cache_info) :: seen_list) in
	    try
              auto_cleanup_red (fun () ->
		let m =
		  if cur_state.current_phase < get_min_choice_phase() then
		    let v = Reduction_helper.new_var_pat pat in
		    (v,v)
		  else
		    (Reduction_helper.new_var_pat pat, Reduction_helper.new_var_pat pat)
		in
		let fact = build_table_fact cur_state.current_phase m in
                let (new_occs,new_facts) =
                  if Reduction_helper.exists_specific_precise_events_of_occ occ (Action Param.table_type)
                  then
                    let occ_n = get_occurrence_name_for_precise occ name_params in
                    ((GetTag occ) :: (PreciseTag occ) :: occs, fact :: (build_precise_fact occ_n m) :: facts)
                  else ((GetTag occ) :: occs, fact :: facts)
                in

		begin
		  let current_cache_list = ref [] in
		  try
		    find_io_rule (function
			[mess_term1;mess_term2] ->
			  do_res_get cur_state seen_list rest_subprocess n current_cache_list name_params new_occs facts pat t p (mess_term1,mess_term2) [] next_f
		      | _ -> Parsing_helper.internal_error "get case; reduction_bipro.ml"
                            ) new_occs new_facts name_params [fst m; snd m] cur_state.io_rule
		  with Unify ->
		    if p_else != Nil then
		      (* See if we should take the else branch if present *)
		      begin
			try
			  let new_occs = (GetTagElse occ) :: occs in
			  find_io_rule (function
			      [] ->
				(* We should take the else branch, since a clause uses that branch *)
				debug_print "Get: else branch should be taken";
				if List.exists (fun mess_term ->
				  try
				    auto_cleanup (fun () ->
                                      (* we check that the pattern pat matches and t evaluates to true *)
				      let _ = bi_action (bi_match_pattern_and_test pat mess_term t) in
				      true)
				  with Unify -> false
				      (* When FailOnlyOnSide _ is raised, it will be catched above and
					 the trace reconstruction succeeds. *)) cur_state.tables
				then
				  begin
				    debug_print "Get: an element of the table matches, cannot take the else branch, backtracking";
				    (* The Get process is blocked forever: the else branch should be taken,
				       but the table contains an element that prevents it. Since elements
				       are only added to tables, this situation will not change.
				       So I backtrack. *)
				    has_backtrack_get := true;
				    raise Backtrack_get
				  end
				else
				  begin
				    debug_print "Get: taking the else branch";
				    normal_state next_f false
				      { cur_state with
			                subprocess = List.rev_append seen_list ((p_else, name_params, new_occs, facts, Nothing) :: rest_subprocess);
                                        comment = RGet_Else(n, pat, t);
                                        previous_state = Some cur_state } n
				  end
			    | _ -> Parsing_helper.internal_error "get else case; reduction_bipro.ml"
				  ) new_occs facts name_params [] cur_state.io_rule
			with Unify ->
			  seen_list' := (proc, name_params, occs, facts,
					 GetInfo(cur_state.tables, !current_cache_list)) :: seen_list;
			  raise No_result
		      end
		    else
		      begin
			seen_list' := (proc, name_params, occs, facts,
				       GetInfo(cur_state.tables, !current_cache_list)) :: seen_list;
			raise No_result
		      end
		end
		  )
	    with Unify | No_result ->
	      find_in_out next_f cur_state (n+1) (!seen_list') rest_subprocess
	  | FailOnlyOnSide _ ->
	      if is_equivalence_goal cur_state.goal then
	        (* SUCCESS an element of the table matches on one side and not on the other *)
	        { cur_state with
                  goal = NonInterfGoal(ProcessTest([],[],Some(n, List.nth cur_state.subprocess n))) }
	      else
		find_in_out next_f
		  { cur_state with
                    subprocess = remove_at n cur_state.subprocess;
                    comment = RGet_Remove(n, pat, t);
                    previous_state = Some cur_state } n seen_list rest_subprocess
	  | Backtrack_get -> raise No_result
      end
  | ((Insert(t,p,occ), name_params, occs, facts, cache_info) as sub_proc)::rest_subprocess ->
      debug_print "Doing Insert";
      begin
        let new_occs = (InsertTag occ) :: occs in
        let new_element_inserted = ref false in
        try
          auto_cleanup_red (fun () ->
            let t' = bi_action (term_evaluation_fail t) in
            let already_in = List.exists (equal_bi_terms_modulo t') cur_state.tables in
            new_element_inserted := not already_in;

            (* This test will probably never succeed, because in
               case it would succeed, it would have been detected earlier
               in the [Insert] case of [do_red_nointeract] *)
            let (new_goal,insert_in_goal,success) =
              update_corresp_goal cur_state.goal None
		(is_table_goal cur_state.current_phase t')
            in
            let new_state =
              { cur_state with
                subprocess = List.rev_append seen_list ((p, name_params, new_occs, facts, Nothing) :: rest_subprocess);
                tables = if already_in then cur_state.tables else t'::cur_state.tables;
                comment = RInsert_Success(n, make_bi_choice t', insert_in_goal);
                previous_state = Some cur_state;
                goal = new_goal
              }
            in

            if success
            then new_state
            else normal_state next_f false new_state n
          )
        with Unify | FailOnlyOnSide _ ->
          Parsing_helper.internal_error "Insert: Unify/FailOnlyOnSide _ should have been detected on the first try of that insert"
        | No_result ->
            (* The attack reconstruction failed after doing the insert.
               Try not doing it, in case that allows executing the else branch of a Get. *)
            if (!has_backtrack_get) && (!new_element_inserted) then
              find_in_out next_f cur_state (n+1) (sub_proc :: seen_list) rest_subprocess
            else
              raise No_result
      end
  | sub_proc::rest_subprocess ->
      find_in_out next_f cur_state (n+1) (sub_proc :: seen_list) rest_subprocess

(* Handle phases *)

(* [extract_phase n processes] modifies the processes for a [phase n] transition:
   removes processes with no phase prefix or a phase prefix less than [n];
   removes the phase prefix [phase n], leaving the rest of the process;
   leaves processes with phase prefix greater than [n] unchanged. *)

let rec extract_phase n = function
    [] -> []
  | (Phase(n',p,occ),name_params,occs, facts, cache_info)::r ->
      let r' = extract_phase n r in
      if n = n' then (p,name_params,occs, facts, Nothing)::r' else
      if n<n' then (Phase(n',p,occ),name_params,occs, facts, Nothing)::r' else r'
  | _::r -> extract_phase n r

(* [find_phase current_phase None processes] returns either
   [None] when no process in [processes] starts with a phase, or
   [Some n] when a process in [processes] starts with phase [n] and this is the lowest such phase.
   It is an error if a process in [processes] starts with a phase less or equal to [current_phase]. *)

let rec find_phase current_phase found_phase = function
    [] -> found_phase
  | (Phase(n,p,_),name_params,occs, facts, cache_info)::rest_subprocess ->
      if n <= current_phase then
	Parsing_helper.user_error "Phases should be in increasing order.";
      let found_phase' =
	match found_phase with
	  None -> Some n
	| Some n_found -> if n_found <= n then found_phase else Some n
      in
      find_phase current_phase found_phase' rest_subprocess
  | _::rest_subprocess ->
      find_phase current_phase found_phase rest_subprocess

let find_phase2 cur_state =
  let found_phase_proc = find_phase cur_state.current_phase None cur_state.subprocess in
  match found_phase_proc with
  | Some _ -> found_phase_proc
  | None ->
      let max_phase = (!Param.current_state).pi_max_used_phase in
      if cur_state.current_phase < max_phase then
	Some max_phase
      else
	None

let update_hyp_not_matched old_phase new_phase cur_state =
  let hyp_list = cur_state.hyp_not_matched in
  let cur_state' = { cur_state with hyp_not_matched = [] } in
  List.fold_left (fun state hyp ->
    match hyp with
    | (_, Pred({ p_info = Attacker(phase,_) } as p, [t])) when phase > old_phase && phase <= new_phase ->
	begin
	  let tl' = Evaluation_helper.decompose_tuple t in
	  List.fold_left (fun state t' ->
	    let bi_t' = (t',t') in
	    match t' with
	      FunApp({ f_cat = Name _; f_private = false },[]) ->
		{ state with public = (t',bi_t') :: state.public }
	    | _ ->
		if (not (is_in_public  state.public bi_t' = None)) then
		  state
		else
		  match can_be_built state.public bi_t' with
		  | None ->
                        (* I introduce a variable for the recipe here,
           		   and use it when displaying hyp_not_matched.
			   Note: it is important that the term t' is never a tuple.
			   Otherwise, it would be decomposed later, and the link
			   between the recipe in public and the one in hyp_not_matched
			   would be lost. *)
		      let recipe = Var (new_var ~orig:false "~M" (Terms.get_term_type t')) in
		      { state with
                        public = (recipe,bi_t') :: state.public;
                        hyp_not_matched = (Some recipe, Pred(p,[t']))::state.hyp_not_matched }
		  | Some recipe ->
		      { state with public = (recipe,bi_t') :: state.public }
			) state tl'
        end
    | (_, Pred({ p_info = AttackerBin(phase,_) } as p, [t1;t2])) when phase > old_phase && phase <= new_phase ->
	begin
          (* In general, tuples should already be decomposed. I decompose
	     them for safety, in case for instance unify_derivation would
	     make them reappear as hypothesis. *)
	  let bi_tl' = decompose_tuple (t1, t2) in
	  List.fold_left (fun state ((t1', t2') as bi_t') ->
	    match bi_t' with
	      (FunApp({ f_cat = Name _; f_private = false },[]),
	       FunApp({ f_cat = Name _; f_private = false },[])) when
	      equal_terms_modulo t1' t2' ->
		{ state with public = (t1', bi_t') :: state.public }
	    | _ ->
		if (not (is_in_public state.public bi_t' = None)) then
		  state
		else
		  match can_be_built state.public bi_t' with
		  | None ->
                    (* I introduce a variable for the recipe here,
           	       and use it when displaying hyp_not_matched.
		       Note: it is important that the term t' is never a tuple.
		       Otherwise, it would be decomposed later, and the link
		       between the recipe in public and the one in hyp_not_matched
		       would be lost. *)
		      let recipe = Var (new_var ~orig:false "~M" (Terms.get_term_type t1')) in
		      { state with
                        public = (recipe, bi_t') :: state.public;
                        hyp_not_matched = (Some recipe, Pred(p,[t1';t2']))::state.hyp_not_matched }
		  | Some recipe ->
		      { state with public = (recipe, bi_t') :: state.public }
			) state bi_tl'
        end
    | (_, (Pred({ p_info = Table(phase) }, [t]) as fact)) when phase > old_phase && phase <= new_phase ->
	if List.exists (equal_bi_terms_modulo (t,t)) state.tables then
	  state
	else
	  { state with
            tables = (t,t) :: state.tables;
            hyp_not_matched = (None, fact)::state.hyp_not_matched }
    | (_, (Pred({ p_info = TableBin(phase) }, [t1;t2]) as fact)) when phase > old_phase && phase <= new_phase ->
	if List.exists (equal_bi_terms_modulo (t1,t2)) state.tables then
	  state
	else
	  { state with
            tables = (t1,t2) :: state.tables;
            hyp_not_matched = (None, fact)::state.hyp_not_matched }
    | _ ->
	{ state with
          hyp_not_matched = hyp::state.hyp_not_matched }
	  ) cur_state' hyp_list

let do_phase next_f cur_state =
  match find_phase2 cur_state with
    None ->
      if !made_forward_step then
	begin
          incr failed_traces;
          made_forward_step := false
	end;
      (* Useful for debugging *)
      if !debug_backtracking then
	begin
	  ignore (Display.Text.display_reduc_state Display.bi_term_to_term true cur_state);
	  print_string "Blocked. Backtracking...\n"
	end
      else
	debug_print "Backtracking";
      raise No_result
  | Some n ->
      debug_print "Doing Phase";
      made_forward_step := true;
      let cur_state1 = update_hyp_not_matched cur_state.current_phase n cur_state in
      (* Reclose public, since new function symbols may become applicable *)
      let cur_state2 = close_public_phase_change cur_state1 n in
      (* Do transition to phase n *)
      let cur_state3 =
	{ cur_state2 with
	  subprocess = extract_phase n cur_state2.subprocess;
	  previous_state = Some cur_state;
	  current_phase = n;
	  comment = RPhase(n) }
      in
      normal_state_all next_f (cur_state3.public != cur_state.public) cur_state3

(* Put all reductions together *)

let reduction_step next_f state =
  try
    find_in_out next_f state 0 [] state.subprocess
  with No_result ->
    do_phase next_f state

let rec reduction_backtrack state =
  reduction_step reduction_backtrack state

let rec reduction_nobacktrack state =
  try
    reduction_step (fun state -> raise (Reduced state)) state
  with Reduced one_red_state ->
    display_trace one_red_state;
    Param.display_init_state := false;
    reduction_nobacktrack (Display.forget_trace_info one_red_state)

let reduction state =
  if !Param.trace_backtracking then
    reduction_backtrack state
  else
    reduction_nobacktrack state

(* Build the goal *)

let analyze_tree tree =
  match tree.desc with
    FRule(_, lbl, _, hyp,_,_) ->
      begin
        match lbl, hyp with
          ProcessRule(hyp_tags, name_params), hyp ->
            ProcessTest([], [], None)
        | Rfail(p), hyp ->
            NIFailTest((match hyp with
              [{ thefact = Pred(_, l) }] -> rev_name_subst_bi l
            | _ -> Parsing_helper.internal_error "Unexpected derivation for choice"), None)
        | TestComm(pi,po), [{thefact = Pred(_,lin)}; {thefact = Pred(_,lout)}] ->
            CommTest(rev_name_subst_bi lin, rev_name_subst_bi lout, None)
        | TestEq(p), [{thefact = Pred(_,l1)};{thefact = Pred(_,l2)}] ->
            NIEqTest((rev_name_subst_bi l1, None), (rev_name_subst_bi l2, None))
        | _ -> Parsing_helper.internal_error "Unexpected clause concluding the derivation for choice"
      end
  | _ -> Parsing_helper.internal_error "Unexpected derivation for choice"

let build_goal tree = function
  | CorrespQEnc _ ->
      let (fact_list,id_goals) = get_corresp_goals tree in
      let goal_list =
        List.map (function Pred(p,_) as pred_goal ->
          if p == Param.event2_pred
          then EventGoal(rev_name_subst_fact pred_goal,None)
          else Fact(rev_name_subst_fact pred_goal,None,false)
        ) fact_list
      in
      CorrespGoal (goal_list, id_goals)
  | _ -> NonInterfGoal (analyze_tree tree)

(* Verify correspondence query *)

exception FalseQuery

let rec extract_conclusion_query restwork = function
  | QTrue -> restwork ([],[],Terms.true_constraints,[],[])
  | QFalse -> raise Unify
  | QEvent (QSEvent _) -> Parsing_helper.internal_error "[reduction_bipro.ml >> extract_conclusion_query] QSEvent should only occur in query for processes."
  | QEvent(QFact(p,_,l,_)) -> restwork ([],[Pred(p,l)],Terms.true_constraints,[],[])
  | QEvent (QNeq ((t1,_),(t2,_))) -> restwork ([], [], Terms.constraints_of_neq t1 t2, [], [])
  | QEvent (QGeq ((t1,_),(t2,_))) -> restwork ([], [], Terms.constraints_of_geq t1 t2, [], [])
  | QEvent (QIsNat t) -> restwork ([],[],Terms.constraints_of_is_nat t,[],[])
  | QEvent (QEq ((t1,_),(t2,_))) -> restwork ([], [], Terms.true_constraints, [t1], [t2])
  | QEvent((QSEvent2(t1,t2))) -> restwork ([t1,t2],[],Terms.true_constraints,[],[])
  | QEvent (QGr _) -> Parsing_helper.internal_error "[reduction_bipro.ml >> extract_conclusion_query] There should not be any strict disequalities in correspondance queries for biprocess."
  | NestedQuery _ -> Parsing_helper.internal_error "[reduction_bipro.ml >> extract_conclusion_query] There should not be any nested query in correspondance queries for biprocess."
  | QAnd(concl1,concl2) ->
      extract_conclusion_query (fun (ev1, facts1, constra1, eq_left1, eq_right1) ->
        extract_conclusion_query (fun (ev2, facts2, constra2, eq_left2, eq_right2) ->
          restwork (ev1@ev2, facts1@facts2, Terms.wedge_constraints constra1 constra2, eq_left1@eq_left2, eq_right1@eq_right2)
        ) concl2
      ) concl1
  | QOr(concl1,concl2) ->
      try
        extract_conclusion_query restwork concl1
      with Unify ->
        extract_conclusion_query restwork concl2


let rec find_in_event_table restwork ((t1,t2) as ev0) = function
    [] -> raise Unify
  | ev::rest ->
      try
        let ev1 = choice_in_term 1 ev
        and ev2 = choice_in_term 2 ev in

        TermsEq.unify_modulo_list (fun () ->
          restwork ()
            ) [t1;t2] [ev1;ev2]
      with Unify -> find_in_event_table restwork ev0 rest

let rec find_event_list restwork event_table = function
    [] -> restwork ()
  | ev::evlist ->
      find_in_event_table (fun () ->
        find_event_list restwork event_table evlist
      ) ev event_table

let bad_fact = Pred(Param.bad_pred, [])

let check_conclusion_query restwork event_table concl_q =
  extract_conclusion_query (fun (evlist, facts, constra, eq_left, eq_right) ->
    find_event_list (fun () ->
      TermsEq.unify_modulo_list (fun () ->
        (* We first look at the natural number predicates *)

        TermsEq.close_constraints_eq_synt (fun constra' ->
          (* [facts] should always be empty: lemmas and axioms never
	     use attacker, mess, table in conclusion, and user-defined
	     predicates are not used with biprocesses.

             If facts were not empty, not checking them means that
	     I approximate: a query may be considered true when
             it is in fact false. This approximation is fine:
             ProVerif will consider that the found trace does not falsify
             the query and will answer "cannot be proved". *)
          let constra'' = TermsEq.remove_syntactic_constra constra' in
          begin
            try
              TermsEq.check_constraints constra''
            with TermsEq.FalseConstraint -> raise Unify
          end;
          (* The current hypothesis has been satisfied *)
          restwork ()
        ) constra
      ) eq_left eq_right
    ) event_table evlist
  ) concl_q

let rec check_query_falsified_rec restwork event_table constra_prem concl_q evl goall =
  match (evl, goall) with
    [], [] ->
      (* The query does not contain any injective event. *)
      if not (TermsEq.check_closed_constraints constra_prem)
      then restwork ()
      else
        let concl_q' =
          Terms.auto_cleanup (fun () ->
            Terms.copy_conclusion_query2 concl_q
          )
        in
        check_conclusion_query restwork event_table concl_q'
  | QNeq ((t1,_),(t2,_))::rest_evl, _ -> 
      let constra_prem' = Terms.wedge_constraints (Terms.constraints_of_neq t1 t2) constra_prem in
      check_query_falsified_rec restwork event_table constra_prem' concl_q rest_evl goall
  | QGeq ((t1,_),(t2,_))::rest_evl, _ -> 
      let constra_prem' = Terms.wedge_constraints (Terms.constraints_of_geq t1 t2) constra_prem in
      check_query_falsified_rec restwork event_table constra_prem' concl_q rest_evl goall
  | QIsNat t ::rest_evl, _ -> 
      let constra_prem' = Terms.wedge_constraints (Terms.constraints_of_is_nat t) constra_prem in
      check_query_falsified_rec restwork event_table constra_prem' concl_q rest_evl goall
  | ev::rest_evl, (Fact(goal,_,_) | EventGoal(goal,_))::rest_goall ->
      let (l,l') =
        match ev, goal with
          QFact(p,_,l,_), Pred(p',l') when p == p' -> l,l'
        | QSEvent2(t1,t2), Pred(pr,[t1';t2']) when pr == Param.event2_pred -> [t1;t2],[t1';t2']
        | _ ->
            print_string "Query: "; Display.Text.display_event ev; print_newline();
            print_string "Goal: "; Display.Text.display_fact goal; print_newline();
            Parsing_helper.internal_error "The goal of the trace does not match the query (1)"
      in
      begin
        try
          TermsEq.unify_modulo_list (fun () ->
            try
              check_query_falsified_rec restwork event_table constra_prem concl_q rest_evl rest_goall
            with Unify -> raise FalseQuery
          ) l l'
        with
          | Unify ->
              print_string "Query: "; Display.Text.WithLinks.term_list l; print_newline();
              print_string "Goal: "; Display.Text.WithLinks.term_list l'; print_newline();
              Parsing_helper.internal_error "The goal of the trace does not match the query (2)"
          | FalseQuery -> raise Unify
      end
  | _ ->
      Parsing_helper.internal_error "The goal of the trace does not match the query (3)"


let check_query_falsified q final_state =
  (* Include in [event_table] the executed events *)
  let event_table = List.rev final_state.events in

  (*
  List.iter (fun (t,_) ->
    print_string "Event found "; Display.Text.display_term t; print_newline()) event_table;
  *)
  let Before(evl, hyp) = q in
  match final_state.goal with
    CorrespGoal(goall,_) ->
      begin
        (* The trace corresponds to a standard clause *)
        try
          check_query_falsified_rec (fun () ->
            (* The trace may not falsify the query *)
            Display.Def.print_line "I could not confirm that the previous trace falsifies the query.";
            false
          ) event_table Terms.true_constraints hyp (List.rev evl) (List.rev goall)
        with Unify -> true
      end
  | _ -> Parsing_helper.internal_error "The goal of the trace does not match the query (4)"

(* Main trace reconstruction function *)

let do_reduction opt_query axioms tree =
(*  Profile.start();  *)
  debug_print "Initializing";
  has_backtrack_get := false;
  made_forward_step := true;
  failed_traces := 0;
  let freenames = (!Param.current_state).pi_freenames in
  let public_init = public_build freenames in
  Param.display_init_state := true;
  init_name_mapping freenames;
  try
    Reduction_helper.instantiate_natural_predicates (fun () ->
      close_tree tree;
      let ({ proc = main_process }, query) = Param.get_process_query (!Param.current_state) in
      let init_state =
        { goal = (build_goal tree query);
          subprocess = [(main_process, [],[],[],Nothing)];
          public = List.map (fun t -> (t,(t, t))) public_init;
          pub_vars = public_init;
          tables = [];
          io_rule = [];
          prepared_attacker_rule = [];
          previous_state = None;
          hyp_not_matched = [];
          assumed_false = [];
          current_phase = 0;
          comment = RInit;
          events = [];
          barriers = []
        }
      in
      let res =
        begin
          try
            let state = init_rule init_state tree in
	    let state = update_hyp_not_matched (-1) 0 state in
            (* Close initially the set public *)
            let state = close_public_initial state in
            if !debug_find_io_rule then
              begin
                auto_cleanup (fun () ->
                  print_string "Available rules:";
                  Display.Text.newline();
                  List.iter display_rule state.io_rule)
              end;
            debug_print "Initialization done";
            if !Param.html_output then
              begin
                let qs = string_of_int (!Param.derivation_number) in
                Display.LangHtml.openfile ((!Param.html_dir) ^ "/trace" ^ qs ^ ".html") ("ProVerif: trace for query " ^ qs);
                Display.Html.print_string "<H1>Trace</H1>\n"
              end;
            let final_state = normal_state reduction true state 0 in
            display_trace final_state;
            let dot_err = Reduction_helper.create_pdf_trace Display.bi_term_to_term noninterftest_to_string "" final_state in
            if !Param.html_output then
              begin
                Display.Html.display_goal Display.bi_term_to_term noninterftest_to_string final_state true;
                Display.LangHtml.close();
                let qs = string_of_int (!Param.derivation_number) in
                Display.Html.print_string ("<A HREF=\"trace" ^ qs ^ ".html\">Trace</A><br>\n");
                if (not !Param.command_line_graph_set) && (!Param.trace_backtracking && (dot_err = 0))  then
                Display.Html.print_string ("<A HREF=\"trace" ^ qs ^ ".pdf\">Trace graph</A><br>\n")
              end
            else
              Display.Text.display_goal Display.bi_term_to_term noninterftest_to_string final_state true;

            (* Check the validity of the trace w.r.t. axioms *)
            let verif_axioms = Lemma.check_axioms final_state axioms in

            if verif_axioms
            then
              if final_state.hyp_not_matched = []
              then
                match opt_query with
                  | Some q -> check_query_falsified q final_state
                  | _ -> true
              else false
            else false
          with No_result ->
            if not (!Param.trace_backtracking) then
              Display.Def.print_line "Blocked!";
            if !Param.html_output then
              begin
                Display.LangHtml.close();
                if not (!Param.trace_backtracking) then
                  begin
                    let qs = string_of_int (!Param.derivation_number) in
                    Display.Html.print_string ("<A HREF=\"trace" ^ qs ^ ".html\">Unfinished trace</A><br>\n")
                  end;
                Display.Html.print_line "Could not find a trace corresponding to this derivation."
              end;
            Display.Text.print_line "Could not find a trace corresponding to this derivation.";
            false
        end
      in
      (*  print_endline ("Failed " ^ (string_of_int (!failed_traces)) ^ " traces."); *)
      (*  Profile.stop(); *)
      res
    ) tree
  with TermsEq.FalseConstraint -> false

let do_reduction opt_query axioms tree =
  debug_print "Starting reduction";
  let res =
    Display.auto_cleanup_display (fun () ->
      do_reduction opt_query axioms tree
        )
  in
  Terms.cleanup ();
  res
