theory SubstFlatLemma
  imports SubstDropEnv
begin
  (*
definition refl_use_env where
  "refl_use_env r_s r_x r = (\<lambda> x. if r_s x = OwnPerm \<and> r_x x = NoPerm then r else NoPerm)"

lemma refl_leq_use_env: "leq_use_env (refl_use_env r_s r_x r) r_s"
  apply (simp add: leq_use_env_def)
  apply (simp add: refl_use_env_def)
  done

lemma refl_disj_use_env: "\<lbrakk> leq_use_env r_ex r_x \<rbrakk> \<Longrightarrow> disj_use_env r_ex (refl_use_env r_s r_x r)"
  apply (simp add: leq_use_env_def)
  apply (simp add: disj_use_env_def)
  apply (simp add: refl_use_env_def)
  apply (simp add: mini_disj_use_env_def)
  apply (auto)
   apply (erule_tac x="x" in allE)
   apply (auto)
  apply (erule_tac x="x" in allE)
  apply (case_tac "r_ex x")
    apply (auto)
  done

lemma trans_leq_perm: "\<lbrakk> leq_perm p q; leq_perm q r \<rbrakk> \<Longrightarrow> leq_perm p r"
  apply (case_tac q)
    apply (auto)
    apply (case_tac p)
      apply (auto)
   apply (case_tac r)
     apply (auto)
  apply (case_tac r)
    apply (auto)
  done

lemma rswp_gen_leq_use_env: "\<lbrakk> leq_use_env r_ex r_s1; leq_use_env r_s2 (diff_use_env r_s1 r_ex);
  leq_use_env (diff_use_env r_x r_ex) rx; (\<forall> x. leq_perm (r_x x) r) \<rbrakk> \<Longrightarrow>
  leq_use_env r_x (comp_use_env rx (refl_use_env r_s1 r_s2 r))"
  apply (case_tac "(\<forall> x. leq_perm (r_x x) (comp_use_env rx (refl_use_env r_s1 r_s2 r) x))")
   apply (simp add: leq_use_env_def)
    apply (auto)
    (* in all cases, if EX \<noteq> Own, the case is trivial *)
  apply (case_tac "r_ex x \<noteq> OwnPerm")
   apply (cut_tac r_x="diff_use_env r_x r_ex" and r_s="comp_use_env rx (refl_use_env r_s1 r_s2 r)" and x="x" in spec_leq_perm)
    apply (rule_tac comp_leq_use_env1)
    apply (simp)
   apply (cut_tac r_s="r_x" and r_x="r_ex" and x="x" in diff_use_eq)
    apply (auto)
    (* otherwise, split on r_s1 x1a = Own *)
  apply (case_tac "r_s1 x \<noteq> OwnPerm")
   apply (cut_tac r_x="r_ex" and r_s="r_s1" and x="x" in leq_use_own)
     apply (auto)
    (* - if r_s1 x1a = Own, and EX = Own, r_s2 x1a = None, meaning the reflective case is guaranteed to have a value. *)
  apply (cut_tac r_x="r_s2" and r_s="diff_use_env r_s1 r_ex" and x="x" in leq_use_none)
    apply (simp)
   apply (rule_tac diff_use_none_ex)
   apply (auto)
  apply (cut_tac r_x="r_x" and r_s="comp_use_env rx (refl_use_env r_s1 r_s2 r)" and x="x" in spec_leq_perm)
   apply (cut_tac p="r_x x" and q="refl_use_env r_s1 r_s2 r x" and r="comp_use_env rx (refl_use_env r_s1 r_s2 r) x" in trans_leq_perm)
     apply (simp add: refl_use_env_def)
    apply (rule_tac r_x="refl_use_env r_s1 r_s2 r" in spec_leq_perm)
    apply (rule_tac self_comp_leq_use_env2)
   apply (auto)
  done

lemma rswp_var_leq_use_env: "\<lbrakk> leq_use_env (ereq_use_env x1a tau) r_s1; leq_use_env r_ex r_s1; var_val_type rf tau_r tau;
  leq_use_env r_s2 (diff_use_env r_s1 (comp_use_env (ereq_use_env x1a tau) r_ex)); safe_type tau r; rf \<noteq> NoRef;
  leq_use_env (diff_use_env (ereq_use_env x1a tau) (comp_use_env (ereq_use_env x1a tau) r_ex)) rx \<rbrakk> \<Longrightarrow>
  leq_use_env (ereq_use_env x1a tau) (comp_use_env rx (refl_use_env r_s1 r_s2 r))"
  apply (rule_tac r_x="ereq_use_env x1a tau" and r_ex="comp_use_env (ereq_use_env x1a tau) r_ex" in rswp_gen_leq_use_env)
     apply (rule_tac dist_comp_leq_use_env)
      apply (auto)
  apply (simp add: ereq_use_env_def)
  apply (simp add: one_use_env_def)
  apply (auto)
  apply (simp add: end_req_perm_def)
  apply (case_tac r)
    apply (auto)
  apply (case_tac tau)
        apply (auto)
  done

lemma drop_infl_use_env: "drop_use_env (infl_use_env r_s r_x) = refl_use_env r_s r_x UsePerm"
  apply (case_tac "\<forall> x. drop_use_env (infl_use_env r_s r_x) x = refl_use_env r_s r_x UsePerm x")
   apply (auto)
  apply (simp add: drop_use_env_def)
  apply (simp add: infl_use_env_def)
  apply (simp add: refl_use_env_def)
  apply (case_tac "r_s x = OwnPerm \<and> r_x x = NoPerm")
   apply (auto)
   apply (simp add: infl_use_env_def)
  apply (simp add: infl_use_env_def)
  done

lemma refl_infl_use_env: "infl_use_env r_s r_x = refl_use_env r_s r_x OwnPerm"
  apply (case_tac "\<forall> x. infl_use_env r_s r_x x = refl_use_env r_s r_x OwnPerm x")
   apply (auto)
  apply (simp add: infl_use_env_def)
  apply (simp add: refl_use_env_def)
  done

lemma refl_sexp_wp: "\<lbrakk> well_typed env r_s1 e tau r_s2 rx; is_sexp e; safe_type tau r \<rbrakk> \<Longrightarrow>
  well_typed env (comp_use_env rx (refl_use_env r_s1 r_s2 r)) e tau
  (comp_use_env rx (refl_use_env r_s1 r_s2 r)) (comp_use_env rx (refl_use_env r_s1 r_s2 r))"
  apply (case_tac r)
    apply (auto)
    (* use case *)
   apply (case_tac "\<not> leq_use_env (drop_use_env (comp_use_env rx (infl_use_env r_s1 r_s2))) (comp_use_env rx (refl_use_env r_s1 r_s2 UsePerm))")
    apply (cut_tac r_sa="rx" and r_sb="infl_use_env r_s1 r_s2" in dist_drop_comp_use_env)
    apply (cut_tac r_xa="drop_use_env rx" and r_xb="drop_use_env (infl_use_env r_s1 r_s2)" and r_s="comp_use_env rx (refl_use_env r_s1 r_s2 UsePerm)" in dist_comp_leq_use_env)
      apply (rule_tac comp_leq_use_env1)
      apply (rule_tac self_drop_leq_use_env)
     apply (cut_tac r_s="r_s1" and r_x="r_s2" in drop_infl_use_env)
     apply (auto)
    apply (rule_tac self_comp_leq_use_env2)
   apply (rule_tac rx="drop_use_env (comp_use_env rx (infl_use_env r_s1 r_s2))" in well_typed_incr_req)
     apply (rule_tac r_s="drop_use_env (comp_use_env rx (infl_use_env r_s1 r_s2))" in well_typed_incr_simul_perm)
      apply (auto)
    apply (rule_tac wt_sexp_drop_all)
      apply (rule_tac infl_sexp_wp)
       apply (auto)
    apply (simp add: unlim_def)
   apply (rule_tac id_leq_use_env)
    (* ownership case *)
  apply (rule_tac t="refl_use_env r_s1 r_s2 OwnPerm" and s="infl_use_env r_s1 r_s2" in subst)
   apply (rule_tac refl_infl_use_env)
  apply (rule_tac infl_sexp_wp)
   apply (auto)
  done

    (*
  (* the goal of this is to come up with flat permissions that are still "safe." *)
lemma refl_sexp_wp: "\<lbrakk> well_typed env r_s1 e tau r_s2 rx; is_sexp e; safe_type tau r \<rbrakk> \<Longrightarrow>
  well_typed env (comp_use_env rx (refl_use_env r_s1 r_s2 r)) e tau
  (comp_use_env rx (refl_use_env r_s1 r_s2 r)) (comp_use_env rx (refl_use_env r_s1 r_s2 r))"
  apply (induct e arbitrary: env r_s1 tau r_s2 rx)
       apply (auto)
    (* const + op case *)
       apply (rule_tac id_leq_use_env)
      apply (rule_tac id_leq_use_env)
    (* var case p1. *)
     apply (rule_tac r_ex="r_ex" in rswp_var_leq_use_env)
          apply (auto)
    (* var case p2. *)
    apply (rule_tac x="empty_use_env" in exI)
    apply (auto)
       apply (rule_tac rhs_weak_leq_use_env)
        apply (rule_tac dist_weak_comp_use_env)
         apply (rule_tac weak_ereq_use_env)
         apply (simp add: unlim_def)
         apply (case_tac tau)
               apply (auto)
        apply (simp add: weak_use_env_def)
        apply (simp add: empty_use_env_def)
       apply (rule_tac id_leq_use_env)
      apply (rule_tac id_leq_use_env)
     apply (rule_tac leq_empty_use_env)
    apply (rule_tac diff_leq_use_env)
    apply (rule_tac r_ex="r_ex" in rswp_var_leq_use_env)
          apply (auto)
    (* pair case *)
    (* - prelim: new reqs for e1 \<le> rx1 *)
    apply (cut_tac r_x="comp_use_env r_xa (refl_use_env rx1 r_sa r)" and r_s="rx1" and r="ra" in dist_lift_leq_use_env)
     apply (rule_tac dist_comp_leq_use_env)
      apply (rule_tac r_sb="r_sa" in trans_leq_use_env)
       apply (rule_tac well_typed_perm_leq)
       apply (auto)
      apply (rule_tac well_typed_perm_leqx)
      apply (auto)
     apply (rule_tac refl_leq_use_env)
    (* - prelim: new reqs for e2 \<le> rx2 *)
    apply (cut_tac r_x="comp_use_env r_xb (refl_use_env rx2 r_sb r)" and r_s="rx2" and r="ra" in dist_lift_leq_use_env)
     apply (rule_tac dist_comp_leq_use_env)
      apply (rule_tac r_sb="r_sb" in trans_leq_use_env)
       apply (rule_tac well_typed_perm_leq)
       apply (auto)
      apply (rule_tac well_typed_perm_leqx)
      apply (auto)
     apply (rule_tac refl_leq_use_env)
    (* - prelim: overall inequality proving our new reqs are in rxa *)
    apply (cut_tac r_xa="lift_use_env (comp_use_env r_xa (refl_use_env rx1 r_sa r)) ra " and
      r_xb="lift_use_env (comp_use_env r_xb (refl_use_env rx2 r_sb r)) ra" and r_s="rxa" in dist_comp_leq_use_env)
      apply (rule_tac r_sb="lift_use_env rx1 ra" in trans_leq_use_env)
       apply (simp_all)
     apply (rule_tac r_sb="lift_use_env rx2 ra" in trans_leq_use_env)
      apply (simp_all)
    (* - prelim: the other half of the inequality proving rxa contained in rx + [r_s1 - r_s2] *)
    apply (cut_tac ?r_s1.0="r_s1" and r_x="rxa" and rx="rx" and ?r_s2.0="r_s2" and r_ex="r_ex" and r="r" in rswp_gen_leq_use_env)
        apply (auto)
     apply (case_tac r)
       apply (auto)
     apply (simp add: unlim_def)
     apply (simp add: aff_use_env_def)
     apply (case_tac "max_aff (req_type t1) (req_type t2)")
       apply (auto)
      apply (simp add: weak_use_env_def)
      apply (case_tac "rxa x")
        apply (auto)
     apply (simp add: null_use_env_def)
    (* - well-typedness *)
    apply (rule_tac x="comp_use_env (lift_use_env (comp_use_env r_xa (refl_use_env rx1 r_sa r)) ra)
      (lift_use_env (comp_use_env r_xb (refl_use_env rx2 r_sb r)) ra)" in exI)
    apply (rule_tac x="comp_use_env r_xa (refl_use_env rx1 r_sa r)" in exI)
    apply (auto)
     apply (rule_tac x="comp_use_env r_xa (refl_use_env rx1 r_sa r)" in exI)
     apply (rule_tac x="comp_use_env r_xa (refl_use_env rx1 r_sa r)" in exI)
     apply (cut_tac e="e1" in value_is_sexp)
      apply (auto)
     apply (case_tac "\<not> safe_type t1 r")
      apply (case_tac r)
        apply (auto)
     apply (simp add: unlim_def)
    apply (rule_tac x="comp_use_env r_xb (refl_use_env rx2 r_sb r)" in exI)
    apply (auto)
          apply (rule_tac x="comp_use_env r_xb (refl_use_env rx2 r_sb r)" in exI)
          apply (rule_tac x="comp_use_env r_xb (refl_use_env rx2 r_sb r)" in exI)
          apply (cut_tac e="e2" in value_is_sexp)
           apply (auto)
          apply (case_tac "\<not> safe_type t2 r")
           apply (case_tac r)
             apply (auto)
          apply (simp add: unlim_def)
          apply (case_tac "req_type t1")
            apply (auto)
         apply (rule_tac r_s="rxa" in aff_leq_use_env)
          apply (simp_all)
        apply (rule_tac r_sb="rxa" in trans_leq_use_env)
         apply (simp_all)
       apply (rule_tac self_comp_leq_use_env1)
      apply (rule_tac self_comp_leq_use_env2)
     apply (rule_tac r_s="lift_use_env rx1 ra" in disj_leq_use_env1)
      apply (rule_tac r_s="lift_use_env rx2 ra" in disj_leq_use_env2)
       apply (simp_all)
    apply (rule_tac x="empty_use_env" in exI)
    apply (auto)
       apply (rule_tac rhs_weak_leq_use_env)
        apply (simp add: weak_use_env_def)
        apply (simp add: empty_use_env_def)
       apply (rule_tac id_leq_use_env)
      apply (rule_tac id_leq_use_env)
     apply (rule_tac leq_empty_use_env)
    apply (rule_tac diff_leq_use_env)
    apply (rule_tac r_sb="rxa" in trans_leq_use_env)
     apply (simp_all)
    (* lam case. prelim: this inequality is used twice *)
   apply (cut_tac r_x="rxa" and r_ex="r_ex" and ?r_s1.0="r_s1" and ?r_s2.0="r_s2" and r="r" in rswp_gen_leq_use_env)
       apply (auto)
    apply (case_tac r)
      apply (auto)
    apply (simp add: unlim_def)
    apply (simp add: aff_use_env_def)
    apply (case_tac a)
      apply (auto)
     apply (simp add: weak_use_env_def)
     apply (case_tac "rxa x")
       apply (auto)
    apply (simp add: null_use_env_def)(*
   apply (cut_tac r_x="rxa" and r_s="rx" and r_ex="infl_use_env r_s1 r_s2" in st_diff_comp_leq_use_env)
    apply (rule_tac r_sb="diff_use_env rxa r_ex" in trans_leq_use_env)
     apply (simp)
    apply (rule_tac dist_diff_leq_use_env_cut)
     apply (rule_tac id_leq_use_env)
    apply (rule_tac infl_leq_use_env)
     apply (simp_all)*)
    (* - existentials *)
   apply (rule_tac x="rxa" in exI)
   apply (auto)
   apply (rule_tac x="empty_use_env" in exI)
   apply (auto)
      apply (rule_tac rhs_weak_leq_use_env)
       apply (simp add: weak_use_env_def)
       apply (simp add: empty_use_env_def)
      apply (rule_tac id_leq_use_env)
     apply (rule_tac id_leq_use_env)
    apply (rule_tac leq_empty_use_env)
   apply (rule_tac diff_leq_use_env)
   apply (simp)
    (* app case.*)
  apply (case_tac e1)
       apply (auto)
  apply (case_tac x1)
               apply (auto)
  apply (simp add: pure_fun_def)
  apply (auto)
    (* - proof for e1 *)
  apply (rule_tac x="comp_use_env rx (refl_use_env r_s1 r_s2 r)" in exI)
  apply (auto)
   apply (rule_tac id_leq_use_env)
  apply (rule_tac x="empty_use_env" in exI)
  apply (auto)
   apply (rule_tac leq_empty_use_env)
    (* - proof for e2. we must know that it's a lambda rather than inducting, so we know rx2 is non-affine *)
  apply (case_tac e2)
       apply (auto)
    (* - prelim: r_s3 \<le> r_s1 *)
  apply (cut_tac r_sc="r_s3" and r_sb="diff_use_env r_s2a r_exa" and r_sa="r_s1" in trans_leq_use_env)
    apply (rule_tac diff_leq_use_env)
    apply (auto)
    (* - prelim: this inequality is used several times in the remainder of the proof *)
  apply (case_tac "\<not> leq_use_env rxa (comp_use_env rx (refl_use_env r_s1 r_s2 r))")
    (* - we split it based on whether it's primitive *)
   apply (simp add: app_req_def)
   apply (case_tac "req_type t = Prim")
    apply (auto)
    apply (simp add: leq_use_env_def)
    apply (simp add: aff_use_env_def)
    apply (simp add: null_use_env_def)
    (* - if it's not we use the usual lemma *)
   apply (cut_tac r_x="rxa" and r_ex="comp_use_env r_exa (comp_use_env (comp_use_env rx1 rx2) r_ex)" and rx="rx" and
      ?r_s1.0="r_s1" and ?r_s2.0="r_s2" and r="r" in rswp_gen_leq_use_env)
       apply (auto)
      apply (rule_tac dist_comp_leq_use_env)
       apply (rule_tac r_sb="r_s2a" in trans_leq_use_env)
        apply (auto)
      apply (rule_tac dist_comp_leq_use_env)
       apply (rule_tac r_sb="r_s3" in trans_leq_use_env)
        apply (auto)
     apply (rule_tac r_sb="diff_use_env r_s3 (comp_use_env (comp_use_env rx1 rx2) r_ex)" in trans_leq_use_env)
      apply (rule_tac rhs_unroll_dcl_use_env)
      apply (rule_tac dist_diff_leq_use_env)
      apply (rule_tac r_sb="diff_use_env r_s2a r_exa" in trans_leq_use_env)
       apply (rule_tac dist_diff_leq_use_env)
       apply (auto)
    apply (rule_tac r_sb="diff_use_env (comp_use_env rx1 rx2) (comp_use_env (comp_use_env rx1 rx2) r_ex)" in trans_leq_use_env)
     apply (simp)
    apply (rule_tac lhs_unroll_dcl_use_env)
    apply (rule_tac dist_diff_leq_use_env)
    apply (rule_tac comp_leq_use_env2)
    apply (simp)
   apply (simp add: unlim_def)
   apply (case_tac "req_type t")
     apply (auto)
   apply (case_tac r)
     apply (auto)
   apply (simp add: aff_use_env_def)
   apply (simp add: weak_use_env_def)
   apply (case_tac "rxa x")
     apply (auto)
(*
  apply (cut_tac r_x="rxa" and r_s="rx" and r_ex="infl_use_env r_s1 r_s2" in st_diff_comp_leq_use_env)
    (* - we split it based on whether it's primitive or not *)
   apply (simp add: app_req_def)
   apply (case_tac "req_type t = Prim")
    apply (auto)
    apply (rule_tac diff_leq_use_env)
    apply (rule_tac r_sb="empty_use_env" in trans_leq_use_env)
     apply (rule_tac leq_empty_use_env)
    apply (simp add: leq_use_env_def)
    apply (simp add: aff_use_env_def)
    apply (simp add: null_use_env_def)
    (* - non primitive case actually uses an inequality *)
   apply (rule_tac r_sb="diff_use_env (comp_use_env rx1 rx2) (comp_use_env (comp_use_env rx1 rx2) r_ex)" in trans_leq_use_env)
    apply (simp)
   apply (rule_tac r_sb="diff_use_env (diff_use_env rxa r_exa) (infl_use_env r_s1 r_s2)" in trans_leq_use_env)
    apply (rule_tac dist_diff_leq_use_env_cut)
     apply (rule_tac comp_leq_use_env2)
     apply (simp)
    apply (rule_tac infl_leq_use_env)
     apply (rule_tac r_sb="diff_use_env r_s3 (comp_use_env (comp_use_env rx1 rx2) r_ex)" in trans_leq_use_env)
      apply (rule_tac dist_diff_leq_use_env)
      apply (rule_tac r_sb="diff_use_env r_s2a r_exa" in trans_leq_use_env)
       apply (rule_tac diff_leq_use_env)
       apply (simp_all)
    apply (rule_tac dist_comp_leq_use_env)
     apply (rule_tac r_sb="r_s3" in trans_leq_use_env)
      apply (rule_tac r_sb="diff_use_env r_s2a r_exa" in trans_leq_use_env)
       apply (rule_tac diff_leq_use_env)
       apply (simp_all)
   apply (rule_tac rhs_diff_leq_use_env)
   apply (rule_tac dist_diff_leq_use_env_cut)
    apply (rule_tac id_leq_use_env)
   apply (rule_tac infl_leq_use_env)
    apply (rule_tac r_sb="diff_use_env r_s2a r_exa" in trans_leq_use_env)
     apply (rule_tac dist_diff_leq_use_env)
     apply (simp)
    apply (rule_tac r_sb="diff_use_env r_s3 (comp_use_env (comp_use_env rx1 rx2) r_ex)" in trans_leq_use_env)
     apply (rule_tac diff_leq_use_env)
     apply (simp_all)
   apply (rule_tac r_sb="r_s2a" in trans_leq_use_env)
    apply (simp_all)*)
    (* - completing the proof for e2 *)
  apply (rule_tac x="rxa" in exI)
  apply (rule_tac x="comp_use_env rx (refl_use_env r_s1 r_s2 r)" in exI)
  apply (auto)
   apply (rule_tac x="rxa" in exI)
   apply (auto)
   apply (rule_tac x="empty_use_env" in exI)
   apply (auto)
      apply (rule_tac rhs_weak_leq_use_env)
       apply (simp add: weak_use_env_def)
       apply (simp add: empty_use_env_def)
      apply (rule_tac id_leq_use_env)
    apply (rule_tac leq_empty_use_env)
   apply (rule_tac self_diff_leq_use_env)
    (* - end permissions bound *)
  apply (case_tac "\<not> weak_use_env empty_use_env")
   apply (simp add: weak_use_env_def)
   apply (simp add: empty_use_env_def)
  apply (rule_tac x="empty_use_env" in exI)
  apply (auto)
        apply (rule_tac rhs_weak_leq_use_env)
         apply (rule_tac dist_weak_comp_use_env)
          apply (rule_tac dist_weak_comp_use_env)
           apply (simp_all)
         apply (simp add: aff_use_env_def)
         apply (case_tac "req_type t")
           apply (auto)
          apply (simp add: unlim_def)
         apply (simp add: weak_use_env_def)
         apply (simp add: null_use_env_def)
        apply (rule_tac id_leq_use_env)
    (* - affinity *)
       apply (simp add: aff_use_env_def)
       apply (simp add: weak_use_env_def)
       apply (case_tac "req_type t")
         apply (auto)
         apply (simp add: unlim_def)
        apply (simp add: weak_use_env_def)
       apply (simp add: null_use_env_def)
    (* - requirements containment *)
      apply (rule_tac dist_comp_leq_use_env)
       apply (rule_tac leq_empty_use_env)
      apply (simp)
    (* - disjointness *)
    apply (rule_tac disj_empty_use_env2)
    (* - in-between bound *)
    apply (rule_tac id_leq_use_env)
    (* - subtracter containment *)
   apply (rule_tac leq_empty_use_env)
    (* - requirements bound *)
  apply (simp add: app_req_def)
  apply (case_tac "req_type t = Prim")
   apply (auto)
   apply (rule_tac leq_empty_use_env)
  apply (rule_tac r_sb="rxa" in trans_leq_use_env)
   apply (simp)
  apply (rule_tac diff_leq_use_env)
  apply (rule_tac dist_comp_leq_use_env)
   apply (rule_tac leq_empty_use_env)
  apply (rule_tac id_leq_use_env)
  done    *)

lemma refl_full_sexp_wp: "\<lbrakk> well_typed env r_s1 e tau r_s2 rx; is_sexp e; safe_type tau r \<rbrakk> \<Longrightarrow>
  well_typed env r_s1 e tau r_s1 (comp_use_env rx (refl_use_env r_s1 r_s2 r))"
  apply (rule_tac r_s="comp_use_env rx (refl_use_env r_s1 r_s2 r)" in well_typed_incr_simul_perm)
   apply (rule_tac dist_comp_leq_use_env)
    apply (rule_tac r_sb="r_s2" in trans_leq_use_env)
     apply (rule_tac well_typed_perm_leq)
     apply (auto)
    apply (rule_tac well_typed_perm_leqx)
    apply (auto)
   apply (rule_tac refl_leq_use_env)
  apply (rule_tac refl_sexp_wp)
    apply (auto)
  done
  *)
end


(*
    Author:      Norbert Schirmer
    Maintainer:  Norbert Schirmer, norbert.schirmer at web de
    License:     LGPL
*)

(*  Title:      XVcg.thy
    Author:     Norbert Schirmer, TU Muenchen

Copyright (C) 2006-2008 Norbert Schirmer
Some rights reserved, TU Muenchen

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

This library 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
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
USA
*)

theory XVcg
imports Vcg

begin

text \<open>We introduce a syntactic variant of the let-expression so that we can
safely unfold it during verification condition generation. With the new
theorem attribute \<open>vcg_simp\<close> we can declare equalities to be used
by the verification condition generator, while simplifying assertions.
\<close>

syntax
"_Let'" :: "[letbinds, basicblock] => basicblock"  ("(LET (_)/ IN (_))" 23)

translations
  "_Let' (_binds b bs) e"  == "_Let' b (_Let' bs e)"
  "_Let' (_bind x a) e"    == "CONST Let' a (%x. e)"

lemma Let'_unfold [vcg_simp]: "Let' x f = f x"
  by (simp add: Let'_def Let_def)

lemma Let'_split_conv [vcg_simp]:
  "(Let' x  (\<lambda>p. (case_prod (f p) (g p)))) =
   (Let' x  (\<lambda>p. (f p) (fst (g p)) (snd (g p))))"
  by (simp add: split_def)

end


theory Autoref_Translate
imports Autoref_Fix_Rel
begin

subsection \<open>Definitions\<close>
subsubsection \<open>APP and ABS Rules\<close>
lemma autoref_ABS:
  "\<lbrakk> \<And>x x'. (x,x')\<in>Ra \<Longrightarrow> (c x, a x')\<in>Rr \<rbrakk> \<Longrightarrow> (c, \<lambda>'x. a x)\<in>Ra\<rightarrow>Rr"
  by auto
lemma autoref_APP:
  "\<lbrakk> (c,a)\<in>Ra\<rightarrow>Rr; (x,x')\<in>Ra \<rbrakk> \<Longrightarrow> (c$x, a $ x')\<in>Rr"
  by (auto dest: fun_relD)
(*lemma autoref_ANNOT:
  "\<lbrakk> (x,x')\<in>R \<rbrakk> \<Longrightarrow> (x,x':::R)\<in>R" by (auto simp: ANNOT_def)
*)

lemma autoref_beta:
  assumes "(c,a x)\<in>R"
  shows "(c,(\<lambda>'x. a x)$x)\<in>R"
  using assms by auto

lemmas dflt_trans_rules = autoref_beta autoref_ABS autoref_APP

subsubsection \<open>Side Conditions\<close>
text \<open>
  Rules can have prefer and defer side-conditions. Prefer conditions must
  be solvable in order for the rule to apply, and defer conditions must
  hold after the rule has been applied and the recursive translations have been
  performed. Thus, prefer-conditions typically restrict on the abstract
  expression, while defer conditions restrict the translated expression.

  In order to solve the actual side conditions, we use the
  \<open>Tagged_Solver\<close>-infrastructure. The solvers are applied after
  the \<open>PREFER\<close>/\<open>DEFER\<close> tag has been removed.
\<close>

text \<open>
  Tag to remove internal stuff from term.
  Before a prefer/defer side condition is evaluated, all terms inside these
  tags are purged from autoref-specific annotations, i.e., operator-annotations,
  relator annotations, and tagged applications.
\<close>
definition [simp, autoref_tag_defs]: "REMOVE_INTERNAL x \<equiv> x"

text \<open>Useful abbreviation to require some property that is not related
  to teh refinement framework\<close>
abbreviation "PREFER nt \<Phi> \<equiv> PREFER_tag (nt (REMOVE_INTERNAL \<Phi>))"
abbreviation "DEFER nt \<Phi> \<equiv> DEFER_tag (nt (REMOVE_INTERNAL \<Phi>))"

definition [simp]: "REMOVE_INTERNAL_EQ a b \<equiv> a=b"
lemma REMOVE_INTERNAL_EQI: "REMOVE_INTERNAL_EQ a a" by simp

lemma autoref_REMOVE_INTERNAL_EQ:
  assumes "(c,a)\<in>R"
  assumes "REMOVE_INTERNAL_EQ c c'"
  shows "(c',a)\<in>R"
  using assms by simp

ML \<open>
  signature AUTOREF_TACTICALS = sig
    val is_prefer_cond: int -> thm -> bool
    val is_defer_cond: int -> thm -> bool

    val REPEAT_INTERVAL: tactic' -> itactic
    val COND'': (int -> thm -> bool) -> tactic' -> tactic' -> tactic'
    val REPEAT_ON_SUBGOAL: tactic' -> tactic'
    val IF_SOLVED: tactic' -> tactic' -> tactic' -> tactic'
  end

  structure Autoref_Tacticals :AUTOREF_TACTICALS = struct
    fun is_prefer_cond i st =
      case Logic.concl_of_goal (Thm.prop_of st) i of
        @{mpat "Trueprop (PREFER_tag _)"} => true
      | _ => false

    fun is_defer_cond i st =
      case Logic.concl_of_goal (Thm.prop_of st) i of
        @{mpat "Trueprop (DEFER_tag _)"} => true
      | _ => false

    fun REPEAT_INTERVAL tac i j st = let
      val n = Thm.nprems_of st - (j - i)
      fun r st = (
        COND
          (has_fewer_prems n)
          (all_tac)
          (tac i THEN_ELSE (r,all_tac))
        ) st
    in
      r st
    end

    fun COND'' cond tac1 tac2 = IF_EXGOAL (fn i => fn st =>
      if cond i st then tac1 i st else tac2 i st
    )

    fun REPEAT_ON_SUBGOAL tac i = REPEAT_INTERVAL tac i i

    fun IF_SOLVED tac tac1 tac2 i st = let
      val n = Thm.nprems_of st
    in
      (tac i THEN COND (has_fewer_prems n) (tac1 i) (tac2 i)) st
    end
  end

  signature AUTOREF_TRANSLATE = sig
    type trans_net = (int * thm) Net.net

    val add_post_rule: thm -> Context.generic -> Context.generic
    val delete_post_rule: thm -> Context.generic -> Context.generic
    val get_post_rules: Proof.context -> thm list

    val compute_trans_net: Autoref_Fix_Rel.thm_pairs -> Proof.context
      -> trans_net

    val side_tac: Proof.context -> tactic'
    val side_dbg_tac: Proof.context -> tactic'

    val trans_step_only_tac: Proof.context -> tactic'
    val trans_dbg_step_tac: Proof.context -> tactic'
    val trans_step_tac: Proof.context -> tactic'
    val trans_tac: Proof.context -> itactic

    val trans_analyze: Proof.context -> int -> int -> thm -> bool
    val trans_pretty_failure: Proof.context -> int -> int -> thm -> Pretty.T

    val trans_phase: Autoref_Phases.phase

    val setup: theory -> theory
  end

  structure Autoref_Translate :AUTOREF_TRANSLATE = struct
    type trans_net = (int * thm) Net.net

    (**************************)
    (*       Translation      *)
    (**************************)

    structure autoref_post_simps = Named_Thms (
      val name = @{binding autoref_post_simps}
      val description = "Refinement Framework: " ^
          "Automatic refinement post simplification rules"
    );

    val add_post_rule = autoref_post_simps.add_thm
    val delete_post_rule = autoref_post_simps.del_thm
    val get_post_rules = autoref_post_simps.get

    fun compute_trans_net thm_pairs _ =
      thm_pairs
      |> map #2
      |> (fn thms => thms @ @{thms dflt_trans_rules})
      |> Tactic.build_net

    structure trans_netD = Autoref_Data (
      type T = trans_net
      fun compute ctxt =
        compute_trans_net (Autoref_Fix_Rel.thm_pairsD_get ctxt) ctxt
      val prereq = [Autoref_Fix_Rel.thm_pairsD_init]
    )

    fun REMOVE_INTERNAL_conv ctxt =
      Conv.top_sweep_conv (
        fn _ => fn ct => (case Thm.term_of ct of
          @{mpat "REMOVE_INTERNAL _"} =>
            Conv.rewr_conv @{thm REMOVE_INTERNAL_def}
            then_conv Autoref_Tagging.untag_conv ctxt
          | _ => Conv.no_conv) ct
      ) ctxt

    fun REMOVE_INTERNAL_tac ctxt = CONVERSION (REMOVE_INTERNAL_conv ctxt)

    fun side_tac ctxt =
      resolve_tac ctxt @{thms SIDEI}
      THEN' REMOVE_INTERNAL_tac ctxt
      THEN' Tagged_Solver.solve_tac ctxt

    fun side_dbg_tac ctxt = let
      val ctxt = Config.put Tagged_Solver.cfg_keep true ctxt
    in
      resolve_tac ctxt @{thms SIDEI}
      THEN' REMOVE_INTERNAL_tac ctxt
      THEN' TRY o Tagged_Solver.solve_tac ctxt
    end

    local
      open Autoref_Tacticals
      fun trans_rule_tac ctxt net = resolve_from_net_tac ctxt net
        THEN_ALL_NEW (TRY o match_tac ctxt [@{thm PRIO_TAGI}])

    in
      (* Do not even attempt to solve side conditions *)
      fun trans_step_only_tac ctxt = let
        val net = trans_netD.get ctxt
      in
        (
          COND'' is_defer_cond
            (K no_tac)
            (assume_tac ctxt ORELSE' trans_rule_tac ctxt net)
        )
      end

      (* Leave unsolved side conditions *)
      fun trans_dbg_step_tac ctxt = let
        val net = trans_netD.get ctxt
        val s_tac = side_tac ctxt
      in DETERM o (
        COND'' is_defer_cond
          (SOLVED' s_tac)
          (
            assume_tac ctxt
            ORELSE'
            (trans_rule_tac ctxt net
              THEN_ALL_NEW_FWD
                COND'' is_prefer_cond
                  (TRY o DETERM o SOLVED' s_tac)
                  (K all_tac)
            )
          )
        )
      end

      fun trans_step_tac ctxt = let
        val net = trans_netD.get ctxt
        val s_tac = side_tac ctxt
      in DETERM o (
        COND'' is_defer_cond
          (SOLVED' s_tac)
          (
            assume_tac ctxt
            ORELSE'
            (trans_rule_tac ctxt net
              THEN_ALL_NEW_FWD
                COND'' is_prefer_cond
                  (DETERM o SOLVED' s_tac)
                  (K all_tac)
            )
          )
        )
      end

      fun trans_tac ctxt = let
        val ss = put_simpset HOL_basic_ss ctxt
          addsimps @{thms APP_def PROTECT_def ANNOT_def}
          addsimps get_post_rules ctxt
        val trans_opt_tac =
          resolve_tac ctxt @{thms autoref_REMOVE_INTERNAL_EQ}
          THEN'
          IF_SOLVED (REPEAT_ON_SUBGOAL (trans_step_tac ctxt))
            (simp_tac ss THEN' resolve_tac ctxt @{thms REMOVE_INTERNAL_EQI})
            (K all_tac)
      in
        Seq.INTERVAL trans_opt_tac
      end

    end

    fun trans_analyze _ i j _ = j < i

    fun trans_pretty_failure ctxt i j st =
      if j < i then Pretty.str "No failure"
      else let
        val goal = Logic.get_goal (Thm.prop_of st) i
        val concl = strip_all_body goal |> Logic.strip_imp_concl

        val msg = case concl of
          @{mpat "Trueprop (DEFER_tag _)"}
            => Pretty.str "Could not solve defered side condition"
        | @{mpat "Trueprop ((_,_)\<in>_)"}
            => Pretty.str "Could not refine subterm"
        | _ => Pretty.str "Internal: Unexpected goal"
      in
        Pretty.block [
          msg,
          Pretty.fbrk,
          Syntax.pretty_term ctxt goal
        ]
      end

    val trans_phase = {
      init = trans_netD.init,
      tac = trans_tac,
      analyze = trans_analyze,
      pretty_failure = trans_pretty_failure
    }

    val setup = I
      #> autoref_post_simps.setup

  end
\<close>

setup Autoref_Translate.setup

subsubsection \<open>Standard side-tactics\<close>

text \<open>Preconditions\<close>
definition [simp, autoref_tag_defs]: "PRECOND_tag P == P"
lemma PRECOND_tagI: "P ==> PRECOND_tag P" by simp
abbreviation "SIDE_PRECOND P == PREFER PRECOND_tag P"

declaration \<open>
  Tagged_Solver.declare_solver @{thms PRECOND_tagI} @{binding PRECOND}
    "Refinement: Solve preconditions"
    ( fn ctxt => SOLVED' (
        SELECT_GOAL (auto_tac ctxt)
      )
    )
\<close>

text \<open>Optional preconditions\<close>
definition [simp, autoref_tag_defs]: "PRECOND_OPT_tag P == P"
lemma PRECOND_OPT_tagI: "P ==> PRECOND_OPT_tag P" by simp
abbreviation "SIDE_PRECOND_OPT P == PREFER PRECOND_OPT_tag P"
declaration \<open>
  Tagged_Solver.declare_solver @{thms PRECOND_OPT_tagI} @{binding PRECOND_OPT}
    "Refinement: Solve optional preconditions"
    ( fn ctxt => SOLVED' (asm_full_simp_tac ctxt))
\<close>

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

theory BCorres_UL
imports
  "Monad_WP/NonDetMonadVCG"
  Crunch_Instances_NonDet
begin

definition s_bcorres_underlying where
  "s_bcorres_underlying t f g s \<equiv> (\<lambda>(x,y). (x, t y)) ` (fst (f s)) \<subseteq> (fst (g (t s)))"

definition bcorres_underlying where
  "bcorres_underlying t f g \<equiv> \<forall>s. s_bcorres_underlying t f g s"

lemma wpc_helper_bcorres:
  "bcorres_underlying t f g \<Longrightarrow>  wpc_helper (P, P') (Q, Q') (bcorres_underlying t f g)"
  by (simp add: wpc_helper_def)

lemma wpc_helper_s_bcorres:
  "s_bcorres_underlying t f g s \<Longrightarrow>  wpc_helper (P, P') (Q, Q') (s_bcorres_underlying t f g s)"
  by (simp add: wpc_helper_def)

wpc_setup "\<lambda>f. bcorres_underlying t f g" wpc_helper_bcorres
wpc_setup "\<lambda>f. s_bcorres_underlying t f g s" wpc_helper_bcorres

lemma s_bcorres_underlying_split[wp_split]:
  "(\<And>r s'. (r,s') \<in> fst (f s) \<Longrightarrow>  (s_bcorres_underlying t (g r) (g' r) s')) \<Longrightarrow>
   s_bcorres_underlying t f f' s \<Longrightarrow>
   s_bcorres_underlying t (f >>= g) (f' >>= g') s"
  by (clarsimp simp: s_bcorres_underlying_def bind_def) force

lemma bcorres_underlying_split[wp_split]:
  "(\<And>r. (bcorres_underlying t (g r) (g' r))) \<Longrightarrow>
   bcorres_underlying t f f' \<Longrightarrow>
   bcorres_underlying t (f >>= g) (f' >>= g')"
  by (simp add: bcorres_underlying_def s_bcorres_underlying_split)

lemma get_s_bcorres_underlying[wp]:
  "s_bcorres_underlying t (f s) (f' (t s)) s \<Longrightarrow> s_bcorres_underlying t (get >>= f) (get >>= f') s"
  by (simp add: gets_def s_bcorres_underlying_def get_def bind_def return_def)

lemma get_bcorres[wp]:
  "(\<And>x. bcorres_underlying t (f x) (f' (t x))) \<Longrightarrow> bcorres_underlying t (get >>= f) (get >>= f')"
  by (simp add: bcorres_underlying_def get_s_bcorres_underlying)

lemma gets_s_bcorres_underlying[wp]:
  "x' (t s) = x s \<Longrightarrow>  s_bcorres_underlying t (gets x) (gets x') s"
  by (simp add: s_bcorres_underlying_def gets_def get_def bind_def return_def)

lemma gets_bcorres_underlying[wp]:
  "(\<And>s. x' (t s) = x s) \<Longrightarrow> bcorres_underlying t (gets x) (gets x')"
  by (simp add: bcorres_underlying_def gets_s_bcorres_underlying)

lemma gets_map_bcorres_underlying[wp]:
  "(\<And>s. f' (t s) p = f s p) \<Longrightarrow> bcorres_underlying t (gets_map f p) (gets_map f' p)"
  by (simp add: gets_map_def bcorres_underlying_def s_bcorres_underlying_def simpler_gets_def
                bind_def assert_opt_def fail_def return_def
        split: option.splits)

lemma gets_bcorres_underlying':
  "(\<And>xa. bcorres_underlying t (f (x xa)) (f' (x' (t xa)))) \<Longrightarrow>
  bcorres_underlying t (gets x >>= f) (gets x' >>= f')"
  by (wpsimp simp: gets_def)

lemma assert_bcorres_underlying[wp]:
  "f = f' \<Longrightarrow> bcorres_underlying t (assert f) (assert f')"
  by (simp add: assert_def bcorres_underlying_def return_def s_bcorres_underlying_def fail_def)

lemma return_bcorres[wp]:
  "bcorres_underlying t (return x) (return x)"
  by (simp add:return_def bcorres_underlying_def s_bcorres_underlying_def)

lemma drop_sbcorres_underlying:
  "bcorres_underlying t f g \<Longrightarrow> s_bcorres_underlying t f g s"
  by (simp add: bcorres_underlying_def)

lemma use_sbcorres_underlying:
  "(\<And>s. s_bcorres_underlying t f g s) \<Longrightarrow> bcorres_underlying t f g"
  by (simp add: bcorres_underlying_def)

lemma bcorres_underlying_throwError[wp]:
  "bcorres_underlying t (throwError a) (throwError a)"
  by (wpsimp simp: throwError_def)

lemma s_bcorres_underlying_splitE[wp_split]:
  "(\<And>r s'. (Inr r,s') \<in> fst (f s) \<Longrightarrow> s_bcorres_underlying t (g r) (g' r) s') \<Longrightarrow>
   s_bcorres_underlying t f f' s \<Longrightarrow>
   s_bcorres_underlying t (f >>=E g) (f' >>=E g') s"
  by (wpsimp simp: bindE_def lift_def split: sum.splits | rule conjI drop_sbcorres_underlying)+

lemma get_s_bcorres_underlyingE[wp]:
  "s_bcorres_underlying t (f s) (f' (t s)) s \<Longrightarrow>
   s_bcorres_underlying t (liftE get >>=E f) (liftE get >>=E f') s"
  by (simp add: gets_def s_bcorres_underlying_def get_def bindE_def bind_def return_def liftE_def lift_def)

lemma bcorres_underlying_splitE[wp_split]:
  "(\<And>r. bcorres_underlying t (g r) (g' r)) \<Longrightarrow>
   bcorres_underlying t f f' \<Longrightarrow>
   bcorres_underlying t (f >>=E g) (f' >>=E g')"
  by (simp add: bcorres_underlying_def s_bcorres_underlying_splitE)

lemmas return_s_bcorres_underlying[wp] = drop_sbcorres_underlying[OF return_bcorres]

lemma liftE_s_bcorres_underlying[wp]:
  "s_bcorres_underlying t f f' s \<Longrightarrow> s_bcorres_underlying t (liftE f) (liftE f') s"
  by (wpsimp simp: liftE_def)

lemma liftE_bcorres_underlying[wp]:
  "bcorres_underlying t f f' \<Longrightarrow>  bcorres_underlying t (liftE f) (liftE f')"
  by (simp add: bcorres_underlying_def liftE_s_bcorres_underlying)

lemma returnOk_bcorres_underlying[wp]:
  "bcorres_underlying t (returnOk x) (returnOk x)"
  by (wpsimp simp: returnOk_def)

lemma whenE_s_bcorres_underlying[wp]:
  "\<lbrakk> \<lbrakk>P = P'; P\<rbrakk> \<Longrightarrow> s_bcorres_underlying t f f' s; P = P' \<rbrakk> \<Longrightarrow>
   s_bcorres_underlying t (whenE P f) (whenE P' f') s"
  by (wpsimp simp: whenE_def|rule drop_sbcorres_underlying)+

lemma select_s_bcorres_underlying[wp]:
  "A \<subseteq> B \<Longrightarrow> s_bcorres_underlying t (select A) (select B) s"
  by (simp add: s_bcorres_underlying_def select_def image_def) blast

lemma fail_s_bcorres_underlying[wp]:
  "s_bcorres_underlying t fail fail s"
  by (simp add: s_bcorres_underlying_def fail_def)

lemma fail_bcorres_underlying[wp]:
  "bcorres_underlying t fail fail"
  by (simp add: bcorres_underlying_def fail_s_bcorres_underlying)

lemma assertE_bcorres_underlying[wp]:
  "bcorres_underlying t (assertE P) (assertE P)"
  by (wpsimp simp: assertE_def returnOk_def|rule conjI)+

lemmas assertE_s_bcorres_underlying[wp] = drop_sbcorres_underlying[OF assertE_bcorres_underlying]

lemma when_s_bcorres_underlying[wp]:
  "(P \<Longrightarrow> s_bcorres_underlying t f f' s) \<Longrightarrow> s_bcorres_underlying t (when P f) (when P f') s"
  by (simp add: return_s_bcorres_underlying when_def)

lemma when_bcorres_underlying[wp]:
  "(P \<Longrightarrow> bcorres_underlying t f f') \<Longrightarrow> bcorres_underlying t (when P f) (when P f')"
  by (simp add: bcorres_underlying_def when_s_bcorres_underlying)

lemma put_bcorres_underlying[wp]:
  "t f = f' \<Longrightarrow> bcorres_underlying t (put f) (put f')"
  by (simp add: bcorres_underlying_def s_bcorres_underlying_def put_def)

lemma modify_bcorres_underlying[wp]:
  "(\<And>x. t (f x) = f' (t x)) \<Longrightarrow> bcorres_underlying t (modify f) (modify f')"
  by (wpsimp simp: modify_def)

lemma liftM_bcorres_underlying[wp]:
  "bcorres_underlying t m m' \<Longrightarrow> bcorres_underlying t (liftM f m) (liftM f m')"
  by (wpsimp simp: liftM_def)

lemma sequence_x_bcorres_underlying[wp]:
  "(\<And>x. bcorres_underlying t (f x) (f' x)) \<Longrightarrow>
   bcorres_underlying t (sequence_x (map f xs)) (sequence_x (map f' xs))"
  by (induct xs; wpsimp simp: sequence_x_def)

lemma sequence_bcorres_underlying[wp]:
  "(\<And>x. bcorres_underlying t (f x) (f' x)) \<Longrightarrow>
   bcorres_underlying t (sequence (map f xs)) (sequence (map f' xs))"
  by (induct xs; wpsimp simp: sequence_def)

lemma mapM_x_bcorres_underlying[wp]:
  "(\<And>x. bcorres_underlying t (f x) (f' x)) \<Longrightarrow> bcorres_underlying t (mapM_x f xs) (mapM_x f' xs)"
  by (wpsimp simp: mapM_x_def)

lemma mapM_bcorres_underlying[wp]:
  "(\<And>x. bcorres_underlying t (f x) (f' x)) \<Longrightarrow> bcorres_underlying t (mapM f xs) (mapM f' xs)"
  by (simp add: mapM_def | wp)+

lemma gets_s_bcorres_underlyingE':
  "s_bcorres_underlying t (f (x s)) (f' (x' (t s))) s \<Longrightarrow>
   s_bcorres_underlying t (liftE (gets x) >>=E f) (liftE (gets x') >>=E f') s"
  by (simp add: gets_def liftE_def lift_def bindE_def) wp

lemma bcorres_underlying_filterM[wp]:
  "(\<And>x. bcorres_underlying t (a x) (a' x)) \<Longrightarrow> bcorres_underlying t (filterM a b) (filterM a' b)"
  by (induct b; wpsimp simp: filterM_def)

lemma option_rec_bcorres_underlying[wp_split]:
  "(\<And>x y. bcorres_underlying t (g x y) (g' x y)) \<Longrightarrow>
   (\<And>x. bcorres_underlying t (f x) (f' x)) \<Longrightarrow>
   bcorres_underlying t (rec_option f g a b) (rec_option f' g' a b)"
  by (cases a, simp+)

lemma bcorres_underlying_mapME[wp]:
  "(\<And>x. bcorres_underlying t (f x) (f' x)) \<Longrightarrow> bcorres_underlying t (mapME f r) (mapME f' r)"
  by (induct r; wpsimp simp: mapME_def sequenceE_def)

lemma handle2_bcorres_underlying[wp]:
  "bcorres_underlying t f f' \<Longrightarrow>
   (\<And>x. bcorres_underlying t (g x) (g' x)) \<Longrightarrow>
   bcorres_underlying t (f <handle2> g) (f' <handle2> g')"
  by (wpsimp simp: handleE'_def)

lemma liftME_bcorres_underlying[wp]:
  "bcorres_underlying t f f' \<Longrightarrow> bcorres_underlying t (liftME a f) (liftME a f')"
  by (wpsimp simp: liftME_def)

lemma zipWithM_x_bcorres[wp]:
  "(\<And>x y. bcorres_underlying t (f x y) (f' x y) ) \<Longrightarrow>
   bcorres_underlying t (zipWithM_x f xs ys) (zipWithM_x f' xs ys)"
  by (wpsimp simp: zipWithM_x_def zipWith_def split_def)

lemma mapME_x_bcorres_underlying[wp]:
  "(\<And>x. bcorres_underlying t (f x) (f' x)) \<Longrightarrow> bcorres_underlying t (mapME_x f xs) (mapME_x f' xs)"
  by (induct xs; wpsimp simp: mapME_x_def sequenceE_x_def)

lemma liftE_bind_bcorres[wp]:
  "bcorres_underlying t (f >>= g) (f' >>= g') \<Longrightarrow>
   bcorres_underlying t (liftE f >>=E g) (liftE f' >>=E g')"
  by (simp add: gets_def bcorres_underlying_def s_bcorres_underlying_def get_def bind_def return_def
                split_def liftE_def bindE_def lift_def)

lemma select_f_bcorres[wp]: "bcorres_underlying t (select_f f) (select_f f)"
  by (fastforce simp: select_f_def bcorres_underlying_def s_bcorres_underlying_def)

lemma bcorres_underlying_if[wp]:
  "(b \<Longrightarrow> bcorres_underlying t f f') \<Longrightarrow>
   (\<not>b \<Longrightarrow> bcorres_underlying t g g') \<Longrightarrow>
   bcorres_underlying t (if b then f else g) (if b then f' else g')"
  by (case_tac b; simp)

lemma assert_opt_bcorres_underlying[wp]:
  "bcorres_underlying t (assert_opt f) (assert_opt f)"
  by (wpsimp simp: assert_opt_def)

lemma unlessb_corres_underlying[wp]:
  "bcorres_underlying t f f' \<Longrightarrow> bcorres_underlying t (unless a f) (unless a f')"
  by (wpsimp simp: unless_def)

lemma select_bcorres_underlying[wp]:
  "A \<subseteq> B \<Longrightarrow> bcorres_underlying t (select A) (select B)"
  by (fastforce simp: bcorres_underlying_def select_def s_bcorres_underlying_def)

lemma catch_bcorres[wp]:
  "bcorres_underlying t f f' \<Longrightarrow>
   (\<And>x. bcorres_underlying t (g x) (g' x)) \<Longrightarrow>
   bcorres_underlying t (f <catch> g) (f' <catch> g')"
  unfolding catch_def by wpsimp

lemma whenE_bcorres_underlying[wp]:
  "\<lbrakk> \<lbrakk>P = P'; P\<rbrakk> \<Longrightarrow> bcorres_underlying t f f'; P = P' \<rbrakk> \<Longrightarrow>
  bcorres_underlying t (whenE P f) (whenE P' f')"
  unfolding whenE_def by wpsimp

lemma unlessE_bcorres[wp]:
  "bcorres_underlying t f f' \<Longrightarrow> bcorres_underlying t (unlessE P f) (unlessE P f')"
  by (wpsimp simp: unlessE_def)

lemma alternative_bcorres[wp]:
  "\<lbrakk> bcorres_underlying t f f';  bcorres_underlying t g g' \<rbrakk> \<Longrightarrow>
  bcorres_underlying t (f \<sqinter> g) (f' \<sqinter> g')"
  by (fastforce simp: alternative_def bcorres_underlying_def s_bcorres_underlying_def)

lemma gets_the_bcorres_underlying[wp]:
  "(\<And>s. f' (t s) = f s) \<Longrightarrow> bcorres_underlying t (gets_the f) (gets_the f')"
  by (wpsimp simp: gets_the_def)

ML \<open>
structure CrunchBCorresInstance : CrunchInstance =
struct
  val name = "bcorres";
  type extra = term;
  val eq_extra = ae_conv;
  fun parse_extra ctxt extra
        = case extra of
             "" => error "bcorres needs truncate function"
             | e =>(Syntax.parse_term ctxt "%_. True", Syntax.parse_term ctxt e);
  val has_preconds = false;
  fun mk_term _ body extra =
    (Syntax.parse_term @{context} "bcorres_underlying") $ extra $ body $ body;
  fun dest_term (Const (@{const_name "bcorres_underlying"}, _) $ extra $ body $ _)
        = SOME (Term.dummy, body, extra)
    | dest_term _ = NONE;
  fun put_precond _ ((v as Const (@{const_name "bcorres_underlying"}, _)) $ extra $ body $ body')
        = v $ extra $ body $ body'
    | put_precond _ _ = error "put_precond: not an bcorres term";
  val pre_thms = [];
  val wpc_tactic = WeakestPreCases.wp_cases_tac @{thms wpc_processors};
  val magic = Syntax.parse_term @{context}
    "\<lambda>mapp_lambda_ignore. bcorres_underlying t_free_ignore mapp_lambda_ignore g_free_ignore";
  val get_monad_state_type = get_nondet_monad_state_type;
end;

structure CrunchBCorres : CRUNCH = Crunch(CrunchBCorresInstance);
\<close>

setup \<open>
  add_crunch_instance "bcorres" (CrunchBCorres.crunch_x, CrunchBCorres.crunch_ignore_add_del)
\<close>

end


theory TLS_cert_auto
imports
  "../ESPLogic"
begin

role C
where "C =
  [ Send ''1'' {| sLAV ''C'', sLN ''nc'', sLN ''sid'', sLN ''pc'' |}
  , Recv ''2'' {| sLNV ''ns'', sLN ''sid'', sLNV ''ps'' |}
  , Send ''3'' {| Enc {| sLC ''TT0'', sLN ''pms'' |} ( sPK ''S'' ),
                  Enc {| sLC ''TT1'',
                         Hash {| sLC ''TT2'', sLNV ''ns'', sLAV ''S'', sLN ''pms'' |}
                      |}
                      ( sSK ''C'' ),
                  Enc {| sLC ''TT3'', sLN ''sid'',
                         Hash {| sLC ''TT4'', sLC ''PRF'', sLN ''pms'', sLN ''nc'',
                                 sLNV ''ns''
                              |},
                         sLN ''nc'', sLN ''pc'', sLAV ''C'', sLNV ''ns'', sLNV ''ps'',
                         sLAV ''S''
                      |}
                      ( Hash {| sLC ''clientKey'', sLN ''nc'', sLNV ''ns'',
                                Hash {| sLC ''TT4'', sLC ''PRF'', sLN ''pms'', sLN ''nc'',
                                        sLNV ''ns''
                                     |}
                             |}
                      )
               |}
  , Recv ''4'' ( Enc {| sLC ''TT3'', sLN ''sid'',
                        Hash {| sLC ''TT4'', sLC ''PRF'', sLN ''pms'', sLN ''nc'',
                                sLNV ''ns''
                             |},
                        sLN ''nc'', sLN ''pc'', sLAV ''C'', sLNV ''ns'', sLNV ''ps'',
                        sLAV ''S''
                     |}
                     ( Hash {| sLC ''serverKey'', sLN ''nc'', sLNV ''ns'',
                               Hash {| sLC ''TT4'', sLC ''PRF'', sLN ''pms'', sLN ''nc'',
                                       sLNV ''ns''
                                    |}
                            |}
                     )
               )
  ]"

role S
where "S =
  [ Recv ''1'' {| sLAV ''C'', sLNV ''nc'', sLNV ''sid'', sLNV ''pc''
               |}
  , Send ''2'' {| sLN ''ns'', sLNV ''sid'', sLN ''ps'' |}
  , Recv ''3'' {| Enc {| sLC ''TT0'', sLNV ''pms'' |} ( sPK ''S'' ),
                  Enc {| sLC ''TT1'',
                         Hash {| sLC ''TT2'', sLN ''ns'', sLAV ''S'', sLNV ''pms'' |}
                      |}
                      ( sSK ''C'' ),
                  Enc {| sLC ''TT3'', sLNV ''sid'',
                         Hash {| sLC ''TT4'', sLC ''PRF'', sLNV ''pms'', sLNV ''nc'',
                                 sLN ''ns''
                              |},
                         sLNV ''nc'', sLNV ''pc'', sLAV ''C'', sLN ''ns'', sLN ''ps'',
                         sLAV ''S''
                      |}
                      ( Hash {| sLC ''clientKey'', sLNV ''nc'', sLN ''ns'',
                                Hash {| sLC ''TT4'', sLC ''PRF'', sLNV ''pms'', sLNV ''nc'',
                                        sLN ''ns''
                                     |}
                             |}
                      )
               |}
  , Send ''4'' ( Enc {| sLC ''TT3'', sLNV ''sid'',
                        Hash {| sLC ''TT4'', sLC ''PRF'', sLNV ''pms'', sLNV ''nc'',
                                sLN ''ns''
                             |},
                        sLNV ''nc'', sLNV ''pc'', sLAV ''C'', sLN ''ns'', sLN ''ps'',
                        sLAV ''S''
                     |}
                     ( Hash {| sLC ''serverKey'', sLNV ''nc'', sLN ''ns'',
                               Hash {| sLC ''TT4'', sLC ''PRF'', sLNV ''pms'', sLNV ''nc'',
                                       sLN ''ns''
                                    |}
                            |}
                     )
               )
  ]"

protocol TLS
where "TLS = { C, S }"

locale atomic_TLS_state = atomic_state TLS
locale TLS_state = reachable_state TLS

lemma (in atomic_TLS_state) C_sk_S_sec:
  assumes facts:
    "roleMap r tid0 = Some C"
    "s(|AV ''S'' tid0|) ~: Compromised"
    "SK ( s(|AV ''S'' tid0|) ) : knows t"
  shows "False"
using facts proof(sources! " SK ( s(|AV ''S'' tid0|) ) ")
qed (insert facts, ((clarsimp, order?))+)?

lemma (in atomic_TLS_state) C_pms_sec:
  assumes facts:
    "roleMap r tid0 = Some C"
    "s(|AV ''S'' tid0|) ~: Compromised"
    "LN ''pms'' tid0 : knows t"
  shows "False"
using facts proof(sources! " LN ''pms'' tid0 ")
  case C_3_pms note facts = facts this[simplified]
  thus ?thesis by (fastsimp dest: C_sk_S_sec intro: event_predOrdI)
qed (insert facts, ((clarsimp, order?))+)?

lemma (in atomic_TLS_state) C_PRF_sec:
  assumes facts:
    "roleMap r tid0 = Some C"
    "s(|AV ''S'' tid0|) ~: Compromised"
    "Hash {| LC ''TT4'', LC ''PRF'', LN ''pms'' tid0, LN ''nc'' tid0,
             s(|NV ''ns'' tid0|)
          |} : knows t"
  shows "False"
using facts proof(sources! "
                Hash {| LC ''TT4'', LC ''PRF'', LN ''pms'' tid0, LN ''nc'' tid0,
                        s(|NV ''ns'' tid0|)
                     |} ")
  case fake note facts = facts this[simplified]
  thus ?thesis by (fastsimp dest: C_pms_sec intro: event_predOrdI)
next
  case C_3_hash note facts = facts this[simplified]
  thus ?thesis proof(sources! "
                   Hash {| LC ''clientKey'', LN ''nc'' tid0, s(|NV ''ns'' tid0|),
                           Hash {| LC ''TT4'', LC ''PRF'', LN ''pms'' tid0, LN ''nc'' tid0,
                                   s(|NV ''ns'' tid0|)
                                |}
                        |} ")
  qed (insert facts, ((clarsimp, order?))+)?
next
  case (S_4_hash tid1) note facts = facts this[simplified]
  thus ?thesis proof(sources! "
                   Hash {| LC ''serverKey'', LN ''nc'' tid0, LN ''ns'' tid1,
                           Hash {| LC ''TT4'', LC ''PRF'', LN ''pms'' tid0, LN ''nc'' tid0,
                                   LN ''ns'' tid1
                                |}
                        |} ")
  qed (insert facts, ((clarsimp, order?))+)?
qed (insert facts, ((clarsimp, order?))+)?

lemma (in atomic_TLS_state) C_clientKey_sec:
  assumes facts:
    "roleMap r tid0 = Some C"
    "s(|AV ''S'' tid0|) ~: Compromised"
    "Hash {| LC ''clientKey'', LN ''nc'' tid0, s(|NV ''ns'' tid0|),
             Hash {| LC ''TT4'', LC ''PRF'', LN ''pms'' tid0, LN ''nc'' tid0,
                     s(|NV ''ns'' tid0|)
                  |}
          |} : knows t"
  shows "False"
using facts proof(sources! "
                Hash {| LC ''clientKey'', LN ''nc'' tid0, s(|NV ''ns'' tid0|),
                        Hash {| LC ''TT4'', LC ''PRF'', LN ''pms'' tid0, LN ''nc'' tid0,
                                s(|NV ''ns'' tid0|)
                             |}
                     |} ")
  case fake note facts = facts this[simplified]
  thus ?thesis by (fastsimp dest: C_PRF_sec intro: event_predOrdI)
qed (insert facts, ((clarsimp, order?))+)?

lemma (in atomic_TLS_state) C_serverKey_sec:
  assumes facts:
    "roleMap r tid0 = Some C"
    "s(|AV ''S'' tid0|) ~: Compromised"
    "Hash {| LC ''serverKey'', LN ''nc'' tid0, s(|NV ''ns'' tid0|),
             Hash {| LC ''TT4'', LC ''PRF'', LN ''pms'' tid0, LN ''nc'' tid0,
                     s(|NV ''ns'' tid0|)
                  |}
          |} : knows t"
  shows "False"
using facts proof(sources! "
                Hash {| LC ''serverKey'', LN ''nc'' tid0, s(|NV ''ns'' tid0|),
                        Hash {| LC ''TT4'', LC ''PRF'', LN ''pms'' tid0, LN ''nc'' tid0,
                                s(|NV ''ns'' tid0|)
                             |}
                     |} ")
  case fake note facts = facts this[simplified]
  thus ?thesis by (fastsimp dest: C_PRF_sec intro: event_predOrdI)
qed (insert facts, ((clarsimp, order?))+)?

lemma (in atomic_TLS_state) S_sk_C_sec:
  assumes facts:
    "roleMap r tid0 = Some S"
    "s(|AV ''C'' tid0|) ~: Compromised"
    "SK ( s(|AV ''C'' tid0|) ) : knows t"
  shows "False"
using facts proof(sources! " SK ( s(|AV ''C'' tid0|) ) ")
qed (insert facts, ((clarsimp, order?))+)?

lemma (in atomic_TLS_state) S_pms_sec:
  assumes facts:
    "roleMap r tid0 = Some S"
    "s(|AV ''C'' tid0|) ~: Compromised"
    "s(|AV ''S'' tid0|) ~: Compromised"
    "(tid0, S_4) : steps t"
    "s(|NV ''pms'' tid0|) : knows t"
  shows "False"
proof -
  note_prefix_closed facts = facts note facts = this
  thus ?thesis proof(sources! "
                   Enc {| LC ''TT1'',
                          Hash {| LC ''TT2'', LN ''ns'' tid0, s(|AV ''S'' tid0|),
                                  s(|NV ''pms'' tid0|)
                               |}
                       |}
                       ( SK ( s(|AV ''C'' tid0|) ) ) ")
    case fake note facts = facts this[simplified]
    thus ?thesis by (fastsimp dest: S_sk_C_sec intro: event_predOrdI)
  next
    case (C_3_enc tid1) note facts = facts this[simplified]
    thus ?thesis by (fastsimp dest: C_pms_sec intro: event_predOrdI)
  qed (insert facts, ((clarsimp, order?))+)?
qed

lemma (in atomic_TLS_state) S_PRF_sec:
  assumes facts:
    "roleMap r tid0 = Some S"
    "s(|AV ''C'' tid0|) ~: Compromised"
    "s(|AV ''S'' tid0|) ~: Compromised"
    "(tid0, S_4) : steps t"
    "Hash {| LC ''TT4'', LC ''PRF'', s(|NV ''pms'' tid0|),
             s(|NV ''nc'' tid0|), LN ''ns'' tid0
          |} : knows t"
  shows "False"
proof -
  note_prefix_closed facts = facts note facts = this
  thus ?thesis proof(sources! "
                   Hash {| LC ''TT4'', LC ''PRF'', s(|NV ''pms'' tid0|),
                           s(|NV ''nc'' tid0|), LN ''ns'' tid0
                        |} ")
    case fake note facts = facts this[simplified]
    thus ?thesis by (fastsimp dest: S_pms_sec intro: event_predOrdI)
  next
    case (C_3_hash tid1) note facts = facts this[simplified]
    thus ?thesis proof(sources! "
                     Hash {| LC ''clientKey'', LN ''nc'' tid1, LN ''ns'' tid0,
                             Hash {| LC ''TT4'', LC ''PRF'', LN ''pms'' tid1, LN ''nc'' tid1,
                                     LN ''ns'' tid0
                                  |}
                          |} ")
    qed (insert facts, ((clarsimp, order?))+)?
  next
    case S_4_hash note facts = facts this[simplified]
    thus ?thesis proof(sources! "
                     Hash {| LC ''serverKey'', s(|NV ''nc'' tid0|), LN ''ns'' tid0,
                             Hash {| LC ''TT4'', LC ''PRF'', s(|NV ''pms'' tid0|),
                                     s(|NV ''nc'' tid0|), LN ''ns'' tid0
                                  |}
                          |} ")
    qed (insert facts, ((clarsimp, order?))+)?
  qed (insert facts, ((clarsimp, order?))+)?
qed

lemma (in atomic_TLS_state) S_clientKey_sec:
  assumes facts:
    "roleMap r tid0 = Some S"
    "s(|AV ''C'' tid0|) ~: Compromised"
    "s(|AV ''S'' tid0|) ~: Compromised"
    "(tid0, S_4) : steps t"
    "Hash {| LC ''clientKey'', s(|NV ''nc'' tid0|), LN ''ns'' tid0,
             Hash {| LC ''TT4'', LC ''PRF'', s(|NV ''pms'' tid0|),
                     s(|NV ''nc'' tid0|), LN ''ns'' tid0
                  |}
          |} : knows t"
  shows "False"
proof -
  note_prefix_closed facts = facts note facts = this
  thus ?thesis proof(sources! "
                   Hash {| LC ''clientKey'', s(|NV ''nc'' tid0|), LN ''ns'' tid0,
                           Hash {| LC ''TT4'', LC ''PRF'', s(|NV ''pms'' tid0|),
                                   s(|NV ''nc'' tid0|), LN ''ns'' tid0
                                |}
                        |} ")
    case fake note facts = facts this[simplified]
    thus ?thesis by (fastsimp dest: S_PRF_sec intro: event_predOrdI)
  qed (insert facts, ((clarsimp, order?))+)?
qed

lemma (in atomic_TLS_state) S_serverKey_sec:
  assumes facts:
    "roleMap r tid0 = Some S"
    "s(|AV ''C'' tid0|) ~: Compromised"
    "s(|AV ''S'' tid0|) ~: Compromised"
    "(tid0, S_4) : steps t"
    "Hash {| LC ''serverKey'', s(|NV ''nc'' tid0|), LN ''ns'' tid0,
             Hash {| LC ''TT4'', LC ''PRF'', s(|NV ''pms'' tid0|),
                     s(|NV ''nc'' tid0|), LN ''ns'' tid0
                  |}
          |} : knows t"
  shows "False"
proof -
  note_prefix_closed facts = facts note facts = this
  thus ?thesis proof(sources! "
                   Hash {| LC ''serverKey'', s(|NV ''nc'' tid0|), LN ''ns'' tid0,
                           Hash {| LC ''TT4'', LC ''PRF'', s(|NV ''pms'' tid0|),
                                   s(|NV ''nc'' tid0|), LN ''ns'' tid0
                                |}
                        |} ")
    case fake note facts = facts this[simplified]
    thus ?thesis by (fastsimp dest: S_PRF_sec intro: event_predOrdI)
  qed (insert facts, ((clarsimp, order?))+)?
qed

lemma (in atomic_TLS_state) nc_first_send:
  assumes facts:
    "roleMap r tid1 = Some C"
    "LN ''nc'' tid1 : knows t"
  shows "predOrd t (St(tid1, C_1)) (Ln(LN ''nc'' tid1))"
using facts proof(sources! " LN ''nc'' tid1 ")
  case C_1_nc note facts = facts this[simplified]
  thus ?thesis by force
next
  case C_3_nc note facts = facts this[simplified]
  thus ?thesis by force
qed (insert facts, ((clarsimp, order?))+)?

lemma (in atomic_TLS_state) ns_first_send:
  assumes facts:
    "roleMap r tid1 = Some S"
    "LN ''ns'' tid1 : knows t"
  shows "predOrd t (St(tid1, S_2)) (Ln(LN ''ns'' tid1))"
using facts proof(sources! " LN ''ns'' tid1 ")
  case S_2_ns note facts = facts this[simplified]
  thus ?thesis by force
next
  case S_4_ns note facts = facts this[simplified]
  thus ?thesis by force
qed (insert facts, ((clarsimp, order?))+)?

lemma (in atomic_TLS_state) C_ni_synch:
  assumes facts:
    "roleMap r tid1 = Some C"
    "s(|AV ''C'' tid1|) ~: Compromised"
    "s(|AV ''S'' tid1|) ~: Compromised"
    "(tid1, C_4) : steps t"
  shows
    "? tid2.
       roleMap r tid2 = Some S &
       s(|AV ''C'' tid2|) = s(|AV ''C'' tid1|) &
       s(|AV ''S'' tid2|) = s(|AV ''S'' tid1|) &
       s(|NV ''nc'' tid2|) = LN ''nc'' tid1 &
       s(|NV ''ns'' tid1|) = LN ''ns'' tid2 &
       s(|NV ''pc'' tid2|) = LN ''pc'' tid1 &
       s(|NV ''pms'' tid2|) = LN ''pms'' tid1 &
       s(|NV ''ps'' tid1|) = LN ''ps'' tid2 &
       s(|NV ''sid'' tid2|) = LN ''sid'' tid1 &
       predOrd t (St(tid1, C_1)) (St(tid2, S_1)) &
       predOrd t (St(tid1, C_3)) (St(tid2, S_3)) &
       predOrd t (St(tid1, C_2)) (St(tid1, C_3)) &
       predOrd t (St(tid2, S_2)) (St(tid1, C_2)) &
       predOrd t (St(tid2, S_4)) (St(tid1, C_4)) &
       predOrd t (St(tid2, S_1)) (St(tid2, S_2)) &
       predOrd t (St(tid2, S_3)) (St(tid2, S_4))"
proof -
  note_prefix_closed facts = facts note facts = this
  thus ?thesis proof(sources! "
                   Enc {| LC ''TT3'', LN ''sid'' tid1,
                          Hash {| LC ''TT4'', LC ''PRF'', LN ''pms'' tid1, LN ''nc'' tid1,
                                  s(|NV ''ns'' tid1|)
                               |},
                          LN ''nc'' tid1, LN ''pc'' tid1, s(|AV ''C'' tid1|),
                          s(|NV ''ns'' tid1|), s(|NV ''ps'' tid1|), s(|AV ''S'' tid1|)
                       |}
                       ( Hash {| LC ''serverKey'', LN ''nc'' tid1, s(|NV ''ns'' tid1|),
                                 Hash {| LC ''TT4'', LC ''PRF'', LN ''pms'' tid1, LN ''nc'' tid1,
                                         s(|NV ''ns'' tid1|)
                                      |}
                              |}
                       ) ")
    case fake note facts = facts this[simplified]
    thus ?thesis by (fastsimp dest: C_PRF_sec intro: event_predOrdI)
  next
    case (S_4_enc tid2) note facts = facts this[simplified]
    have f1: "roleMap r tid1 = Some C" using facts by (auto intro: event_predOrdI)
    have f2: "LN ''nc'' tid1 : knows t" using facts by (auto intro: event_predOrdI)
    note facts = facts nc_first_send[OF f1 f2, simplified]
    have f1: "roleMap r tid2 = Some S" using facts by (auto intro: event_predOrdI)
    have f2: "LN ''ns'' tid2 : knows t" using facts by (auto intro: event_predOrdI)
    note facts = facts ns_first_send[OF f1 f2, simplified]
    thus ?thesis proof(sources! "
                     Enc {| LC ''TT0'', LN ''pms'' tid1 |}
                         ( PK ( s(|AV ''S'' tid1|) ) ) ")
      case fake note facts = facts this[simplified]
      thus ?thesis by (fastsimp dest: C_pms_sec intro: event_predOrdI)
    next
      case C_3_enc note facts = facts this[simplified]
      thus ?thesis by force
    qed (insert facts, ((clarsimp, order?))+)?
  qed (insert facts, ((clarsimp, order?))+)?
qed

lemma (in atomic_TLS_state) S_ni_synch:
  assumes facts:
    "roleMap r tid2 = Some S"
    "s(|AV ''C'' tid2|) ~: Compromised"
    "s(|AV ''S'' tid2|) ~: Compromised"
    "(tid2, S_4) : steps t"
  shows
    "? tid1.
       roleMap r tid1 = Some C &
       s(|AV ''C'' tid2|) = s(|AV ''C'' tid1|) &
       s(|AV ''S'' tid2|) = s(|AV ''S'' tid1|) &
       s(|NV ''nc'' tid2|) = LN ''nc'' tid1 &
       s(|NV ''ns'' tid1|) = LN ''ns'' tid2 &
       s(|NV ''pc'' tid2|) = LN ''pc'' tid1 &
       s(|NV ''pms'' tid2|) = LN ''pms'' tid1 &
       s(|NV ''ps'' tid1|) = LN ''ps'' tid2 &
       s(|NV ''sid'' tid2|) = LN ''sid'' tid1 &
       predOrd t (St(tid1, C_1)) (St(tid2, S_1)) &
       predOrd t (St(tid1, C_3)) (St(tid2, S_3)) &
       predOrd t (St(tid1, C_2)) (St(tid1, C_3)) &
       predOrd t (St(tid2, S_2)) (St(tid1, C_2)) &
       predOrd t (St(tid2, S_1)) (St(tid2, S_2)) &
       predOrd t (St(tid2, S_3)) (St(tid2, S_4))"
proof -
  note_prefix_closed facts = facts note facts = this
  thus ?thesis proof(sources! "
                   Enc {| LC ''TT3'', s(|NV ''sid'' tid2|),
                          Hash {| LC ''TT4'', LC ''PRF'', s(|NV ''pms'' tid2|),
                                  s(|NV ''nc'' tid2|), LN ''ns'' tid2
                               |},
                          s(|NV ''nc'' tid2|), s(|NV ''pc'' tid2|), s(|AV ''C'' tid2|),
                          LN ''ns'' tid2, LN ''ps'' tid2, s(|AV ''S'' tid2|)
                       |}
                       ( Hash {| LC ''clientKey'', s(|NV ''nc'' tid2|), LN ''ns'' tid2,
                                 Hash {| LC ''TT4'', LC ''PRF'', s(|NV ''pms'' tid2|),
                                         s(|NV ''nc'' tid2|), LN ''ns'' tid2
                                      |}
                              |}
                       ) ")
    case fake note facts = facts this[simplified]
    thus ?thesis by (fastsimp dest: S_PRF_sec intro: event_predOrdI)
  next
    case (C_3_enc tid3) note facts = facts this[simplified]
    have f1: "roleMap r tid3 = Some C" using facts by (auto intro: event_predOrdI)
    have f2: "LN ''nc'' tid3 : knows t" using facts by (auto intro: event_predOrdI)
    note facts = facts nc_first_send[OF f1 f2, simplified]
    have f1: "roleMap r tid2 = Some S" using facts by (auto intro: event_predOrdI)
    have f2: "LN ''ns'' tid2 : knows t" using facts by (auto intro: event_predOrdI)
    note facts = facts ns_first_send[OF f1 f2, simplified]
    thus ?thesis by force
  qed (insert facts, ((clarsimp, order?))+)?
qed

lemma (in TLS_state) weak_atomicity:
  "complete (t,r,s) atomicAnn"
proof (cases rule: complete_atomicAnnI[completeness_cases_rule])
  case (C_2_ns t r s tid0 \<alpha>) note facts = this
  then interpret state: atomic_state TLS t r s
    by unfold_locales assumption+
  let ?s' = "extendS s \<alpha>"
  show ?case using facts
  by (fastsimp simp: atomicAnn_def dest: state.extract_knows_hyps)
next
  case (C_2_ps t r s tid0 \<alpha>) note facts = this
  then interpret state: atomic_state TLS t r s
    by unfold_locales assumption+
  let ?s' = "extendS s \<alpha>"
  show ?case using facts
  by (fastsimp simp: atomicAnn_def dest: state.extract_knows_hyps)
next
  case (S_1_nc t r s tid0 \<alpha>) note facts = this
  then interpret state: atomic_state TLS t r s
    by unfold_locales assumption+
  let ?s' = "extendS s \<alpha>"
  show ?case using facts
  by (fastsimp simp: atomicAnn_def dest: state.extract_knows_hyps)
next
  case (S_1_pc t r s tid0 \<alpha>) note facts = this
  then interpret state: atomic_state TLS t r s
    by unfold_locales assumption+
  let ?s' = "extendS s \<alpha>"
  show ?case using facts
  by (fastsimp simp: atomicAnn_def dest: state.extract_knows_hyps)
next
  case (S_1_sid t r s tid0 \<alpha>) note facts = this
  then interpret state: atomic_state TLS t r s
    by unfold_locales assumption+
  let ?s' = "extendS s \<alpha>"
  show ?case using facts
  by (fastsimp simp: atomicAnn_def dest: state.extract_knows_hyps)
next
  case (S_3_pms t r s tid0 \<alpha>) note facts = this
  then interpret state: atomic_state TLS t r s
    by unfold_locales assumption+
  let ?s' = "extendS s \<alpha>"
  show ?case using facts
  proof(sources! "
      Enc {| LC ''TT0'', ?s'(|NV ''pms'' tid0|) |}
          ( PK ( ?s'(|AV ''S'' tid0|) ) ) ")
  qed (insert facts, ((clarsimp, order?) | (fastsimp simp: atomicAnn_def dest: state.extract_knows_hyps))+)?
qed

end


(*  Title:      HOL/Auth/n_germanSimp_lemma_on_inv__37.thy
    Author:     Yongjian Li and Kaiqiang Duan, State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
    Copyright    2016 State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
*)

header{*The n_germanSimp Protocol Case Study*}

theory n_germanSimp_lemma_on_inv__37 imports n_germanSimp_base
begin
section{*All lemmas on causal relation between inv__37 and some rule r*}
lemma n_RecvReqSVsinv__37:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_RecvReqS N i)" and
a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__37  p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_RecvReqS N i" apply fastforce done
from a2 obtain p__Inv4 where a2:"p__Inv4\<le>N\<and>f=inv__37  p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_RecvReqE__part__0Vsinv__37:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_RecvReqE__part__0 N i)" and
a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__37  p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_RecvReqE__part__0 N i" apply fastforce done
from a2 obtain p__Inv4 where a2:"p__Inv4\<le>N\<and>f=inv__37  p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_RecvReqE__part__1Vsinv__37:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_RecvReqE__part__1 N i)" and
a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__37  p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_RecvReqE__part__1 N i" apply fastforce done
from a2 obtain p__Inv4 where a2:"p__Inv4\<le>N\<and>f=inv__37  p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_SendInv__part__0Vsinv__37:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_SendInv__part__0  i)" and
a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__37  p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_SendInv__part__0  i" apply fastforce done
from a2 obtain p__Inv4 where a2:"p__Inv4\<le>N\<and>f=inv__37  p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv4)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_SendInv__part__1Vsinv__37:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_SendInv__part__1  i)" and
a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__37  p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_SendInv__part__1  i" apply fastforce done
from a2 obtain p__Inv4 where a2:"p__Inv4\<le>N\<and>f=inv__37  p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv4)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_RecvInvAckVsinv__37:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_RecvInvAck  i)" and
a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__37  p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_RecvInvAck  i" apply fastforce done
from a2 obtain p__Inv4 where a2:"p__Inv4\<le>N\<and>f=inv__37  p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P3 s"
  apply (cut_tac a1 a2 b1, simp, rule_tac x="(neg (andForm (eqn (IVar (Para (Ident ''InvSet'') p__Inv4)) (Const true)) (eqn (IVar (Field (Para (Ident ''Chan3'') p__Inv4) ''Cmd'')) (Const InvAck))))" in exI, auto) done
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv4)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_SendGntSVsinv__37:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_SendGntS  i)" and
a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__37  p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_SendGntS  i" apply fastforce done
from a2 obtain p__Inv4 where a2:"p__Inv4\<le>N\<and>f=inv__37  p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv4)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_SendGntEVsinv__37:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_SendGntE N i)" and
a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__37  p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_SendGntE N i" apply fastforce done
from a2 obtain p__Inv4 where a2:"p__Inv4\<le>N\<and>f=inv__37  p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv4)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_StoreVsinv__37:
  assumes a1: "\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d" and
  a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__37  p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

lemma n_RecvGntSVsinv__37:
  assumes a1: "\<exists> i. i\<le>N\<and>r=n_RecvGntS  i" and
  a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__37  p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

lemma n_RecvGntEVsinv__37:
  assumes a1: "\<exists> i. i\<le>N\<and>r=n_RecvGntE  i" and
  a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__37  p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

lemma n_SendInvAckVsinv__37:
  assumes a1: "\<exists> i. i\<le>N\<and>r=n_SendInvAck  i" and
  a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__37  p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

end


theory Ruleset_Update
imports Matching
begin

lemma free_return_not_match: "\<Gamma>,\<gamma>,p\<turnstile> \<langle>[Rule m Return], Undecided\<rangle> \<Rightarrow> t \<Longrightarrow> \<not> matches \<gamma> m p"
  using no_free_return by fast

subsection\<open>Background Ruleset Updating\<close>
lemma update_Gamma_nomatch:
  assumes "\<not> matches \<gamma> m p"
  shows "\<Gamma>(chain \<mapsto> Rule m a # rs),\<gamma>,p\<turnstile> \<langle>rs', s\<rangle> \<Rightarrow> t \<longleftrightarrow> \<Gamma>(chain \<mapsto> rs),\<gamma>,p\<turnstile> \<langle>rs', s\<rangle> \<Rightarrow> t" (is "?l \<longleftrightarrow> ?r")
  proof
    assume ?l thus ?r
      proof (induction rs' s t rule: iptables_bigstep_induct)
        case (Call_return m a chain' rs\<^sub>1 m' rs\<^sub>2)
        thus ?case
          proof (cases "chain' = chain")
            case True
            with Call_return show ?thesis
              apply simp
              apply(cases "rs\<^sub>1")
              using assms apply fastforce
              apply(rule_tac rs\<^sub>1="list" and m'="m'" and rs\<^sub>2="rs\<^sub>2" in call_return)
                 apply(simp)
                apply(simp)
               apply(simp)
              apply(simp)
              apply(erule seqE_cons[where \<Gamma>="(\<lambda>a. if a = chain then Some rs else \<Gamma> a)"])
              apply(frule iptables_bigstep_to_undecided[where \<Gamma>="(\<lambda>a. if a = chain then Some rs else \<Gamma> a)"])
              apply(simp)
              done
          qed (auto intro: call_return)
      next
        case (Call_result m' a' chain' rs' t')
        have "\<Gamma>(chain \<mapsto> rs),\<gamma>,p\<turnstile> \<langle>[Rule m' (Call chain')], Undecided\<rangle> \<Rightarrow> t'"
          proof (cases "chain' = chain")
            case True
            with Call_result have "Rule m a # rs = rs'" "(\<Gamma>(chain \<mapsto> rs)) chain' = Some rs"
              by simp+
            with assms Call_result show ?thesis
              by (metis call_result nomatchD seqE_cons)
          next
            case False
            with Call_result show ?thesis
              by (metis call_result fun_upd_apply)
          qed
        with Call_result show ?case
          by fast
      qed (auto intro: iptables_bigstep.intros)
  next
    assume ?r thus ?l
      proof (induction rs' s t rule: iptables_bigstep_induct)
        case (Call_return m' a' chain' rs\<^sub>1)
        thus ?case
          proof (cases "chain' = chain")
            case True
            with Call_return show ?thesis
              using assms
              by (auto intro: seq_cons nomatch intro!: call_return[where rs\<^sub>1 = "Rule m a # rs\<^sub>1"])
          qed (auto intro: call_return)
      next
        case (Call_result m' a' chain' rs')
        thus ?case
          proof (cases "chain' = chain")
            case True
            with Call_result show ?thesis
              using assms by (auto intro: seq_cons nomatch intro!: call_result)
          qed (auto intro: call_result)
      qed (auto intro: iptables_bigstep.intros)
  qed

lemma update_Gamma_log_empty:
  assumes "a = Log \<or> a = Empty"
  shows "\<Gamma>(chain \<mapsto> Rule m a # rs),\<gamma>,p\<turnstile> \<langle>rs', s\<rangle> \<Rightarrow> t \<longleftrightarrow>
         \<Gamma>(chain \<mapsto> rs),\<gamma>,p\<turnstile> \<langle>rs', s\<rangle> \<Rightarrow> t" (is "?l \<longleftrightarrow> ?r")
  proof
    assume ?l thus ?r
      proof (induction rs' s t rule: iptables_bigstep_induct)
        case (Call_return m' a' chain' rs\<^sub>1 m'' rs\<^sub>2)
        (*it seems that Isabelle has problems to apply @{thm fun_upd_apply} at the semantics if it appears in the goal without @{text \<lambda>}*)
        note [simp] = fun_upd_apply[abs_def]

        from Call_return have "\<Gamma>(chain \<mapsto> rs),\<gamma>,p\<turnstile> \<langle>[Rule m' (Call chain')], Undecided\<rangle> \<Rightarrow> Undecided" (is ?Call_return_case)
          proof(cases "chain' = chain")
          case True with Call_return show ?Call_return_case
            --\<open>@{term rs\<^sub>1} cannot be empty\<close>
            proof(cases "rs\<^sub>1")
            case Nil with Call_return(3) \<open>chain' = chain\<close> assms have "False" by simp
              thus ?Call_return_case by simp
            next
            case (Cons r\<^sub>1 rs\<^sub>1s)
            from Cons Call_return have "\<Gamma>(chain \<mapsto> rs),\<gamma>,p\<turnstile> \<langle>r\<^sub>1 # rs\<^sub>1s, Undecided\<rangle> \<Rightarrow> Undecided" by blast
            with seqE_cons[where \<Gamma>="\<Gamma>(chain \<mapsto> rs)"] obtain ti where
              "\<Gamma>(chain \<mapsto> rs),\<gamma>,p\<turnstile> \<langle>[r\<^sub>1], Undecided\<rangle> \<Rightarrow> ti" and "\<Gamma>(chain \<mapsto> rs),\<gamma>,p\<turnstile> \<langle>rs\<^sub>1s, ti\<rangle> \<Rightarrow> Undecided" by metis
            with iptables_bigstep_to_undecided[where \<Gamma>="\<Gamma>(chain \<mapsto> rs)"] have "\<Gamma>(chain \<mapsto> rs),\<gamma>,p\<turnstile> \<langle>rs\<^sub>1s, Undecided\<rangle> \<Rightarrow> Undecided" by fast
            with Cons Call_return \<open>chain' = chain\<close> show ?Call_return_case
               apply(rule_tac rs\<^sub>1="rs\<^sub>1s" and m'="m''" and rs\<^sub>2="rs\<^sub>2" in call_return)
                  apply(simp_all)
               done
             qed
          next
          case False with Call_return show ?Call_return_case
           by (auto intro: call_return)
          qed
        thus ?case using Call_return by blast
      next
        case (Call_result m' a' chain' rs' t')
        thus ?case
          proof (cases "chain' = chain")
            case True
            with Call_result have "rs' = [] @ [Rule m a] @ rs"
              by simp
            with Call_result assms have "\<Gamma>(chain \<mapsto> rs),\<gamma>,p\<turnstile> \<langle>[] @ rs, Undecided\<rangle> \<Rightarrow> t'"
              using log_remove empty_empty by fast
            hence "\<Gamma>(chain \<mapsto> rs),\<gamma>,p\<turnstile> \<langle>rs, Undecided\<rangle> \<Rightarrow> t'"
              by simp
            with Call_result True show ?thesis
              by (metis call_result fun_upd_same)
          qed (fastforce intro: call_result)
      qed (auto intro: iptables_bigstep.intros)
  next
    have cases_a: "\<And>P. (a = Log \<Longrightarrow> P a) \<Longrightarrow> (a = Empty \<Longrightarrow> P a) \<Longrightarrow> P a" using assms by blast
    assume ?r thus ?l
      proof (induction rs' s t rule: iptables_bigstep_induct)
        case (Call_return m' a' chain' rs\<^sub>1 m'' rs\<^sub>2)
        from Call_return have xx: "\<Gamma>(chain \<mapsto> Rule m a # rs),\<gamma>,p\<turnstile> \<langle>Rule m a # rs\<^sub>1, Undecided\<rangle> \<Rightarrow> Undecided"
          apply -
          apply(rule cases_a)
          apply (auto intro: nomatch seq_cons intro!: log empty simp del: fun_upd_apply)
          done
        with Call_return show ?case
          proof(cases "chain' = chain")
            case False
            with Call_return have x: "(\<Gamma>(chain \<mapsto> Rule m a # rs)) chain' = Some (rs\<^sub>1 @ Rule m'' Return # rs\<^sub>2)"
              by(simp)
            with Call_return have "\<Gamma>(chain \<mapsto> Rule m a # rs),\<gamma>,p\<turnstile> \<langle>[Rule m' (Call chain')], Undecided\<rangle> \<Rightarrow> Undecided"
             apply -
             apply(rule call_return[where rs\<^sub>1="rs\<^sub>1" and m'="m''" and rs\<^sub>2="rs\<^sub>2"])
                apply(simp_all add: x xx del: fun_upd_apply)
             done
             thus "\<Gamma>(chain \<mapsto> Rule m a # rs),\<gamma>,p\<turnstile> \<langle>[Rule m' a'], Undecided\<rangle> \<Rightarrow> Undecided" using Call_return by simp
            next
            case True
            with Call_return have x: "(\<Gamma>(chain \<mapsto> Rule m a # rs)) chain' = Some (Rule m a # rs\<^sub>1 @ Rule m'' Return # rs\<^sub>2)"
              by(simp)
            with Call_return have "\<Gamma>(chain \<mapsto> Rule m a # rs),\<gamma>,p\<turnstile> \<langle>[Rule m' (Call chain')], Undecided\<rangle> \<Rightarrow> Undecided"
             apply -
             apply(rule call_return[where rs\<^sub>1="Rule m a#rs\<^sub>1" and m'="m''" and rs\<^sub>2="rs\<^sub>2"])
                apply(simp_all add: x xx del: fun_upd_apply)
             done
             thus "\<Gamma>(chain \<mapsto> Rule m a # rs),\<gamma>,p\<turnstile> \<langle>[Rule m' a'], Undecided\<rangle> \<Rightarrow> Undecided" using Call_return by simp
          qed
      next
        case (Call_result ma a chaina rs t)
        thus ?case
          apply (cases "chaina = chain")
           apply(rule cases_a)
            apply (auto intro: nomatch seq_cons intro!: log empty call_result)[2]
          by (auto intro!: call_result)[1]
      qed (auto intro: iptables_bigstep.intros)
  qed

lemma map_update_chain_if: "(\<lambda>b. if b = chain then Some rs else \<Gamma> b) = \<Gamma>(chain \<mapsto> rs)"
  by auto

lemma no_recursive_calls_helper:
  assumes "\<Gamma>,\<gamma>,p\<turnstile> \<langle>[Rule m (Call chain)], Undecided\<rangle> \<Rightarrow> t"
  and     "matches \<gamma> m p"
  and     "\<Gamma> chain = Some [Rule m (Call chain)]"
  shows   False
  using assms
  proof (induction "[Rule m (Call chain)]" Undecided t rule: iptables_bigstep_induct)
    case Seq
    thus ?case
      by (metis Cons_eq_append_conv append_is_Nil_conv skipD)
  next
    case (Call_return chain' rs\<^sub>1 m' rs\<^sub>2)
    hence "rs\<^sub>1 @ Rule m' Return # rs\<^sub>2 = [Rule m (Call chain')]"
      by simp
    thus ?case
      by (cases "rs\<^sub>1") auto
  next
    case Call_result
    thus ?case
      by simp
  qed (auto intro: iptables_bigstep.intros)

lemma no_recursive_calls:
  "\<Gamma>(chain \<mapsto> [Rule m (Call chain)]),\<gamma>,p\<turnstile> \<langle>[Rule m (Call chain)], Undecided\<rangle> \<Rightarrow> t \<Longrightarrow> matches \<gamma> m p \<Longrightarrow> False"
  by (fastforce intro: no_recursive_calls_helper)

lemma no_recursive_calls2:
  assumes "\<Gamma>(chain \<mapsto> (Rule m (Call chain)) # rs''),\<gamma>,p\<turnstile> \<langle>(Rule m (Call chain)) # rs', Undecided\<rangle> \<Rightarrow> Undecided"
  and     "matches \<gamma> m p"
  shows   False
  using assms
  proof (induction "(Rule m (Call chain)) # rs'" Undecided Undecided arbitrary: rs' rule: iptables_bigstep_induct)
    case (Seq rs\<^sub>1 rs\<^sub>2 t)
    thus ?case
      by (cases rs\<^sub>1) (auto elim: seqE_cons simp add: iptables_bigstep_to_undecided)
  qed (auto intro: iptables_bigstep.intros simp: Cons_eq_append_conv)

lemma update_Gamma_nochange1:
  assumes "\<Gamma>(chain \<mapsto> rs),\<gamma>,p\<turnstile> \<langle>[Rule m a], Undecided\<rangle> \<Rightarrow> Undecided"
  and     "\<Gamma>(chain \<mapsto> Rule m a # rs),\<gamma>,p\<turnstile> \<langle>rs', s\<rangle> \<Rightarrow> t"
  shows   "\<Gamma>(chain \<mapsto> rs),\<gamma>,p\<turnstile> \<langle>rs', s\<rangle> \<Rightarrow> t"
  using assms(2) proof (induction rs' s t rule: iptables_bigstep_induct)
    case (Call_return m a chaina rs\<^sub>1 m' rs\<^sub>2)
    thus ?case
      proof (cases "chaina = chain")
        case True
        with Call_return show ?thesis
          apply simp
          apply(cases "rs\<^sub>1")
          apply(simp)
          using assms apply (metis no_free_return) (*gives False*)
          apply(rule_tac rs\<^sub>1="list" and m'="m'" and rs\<^sub>2="rs\<^sub>2" in call_return)
          apply(simp)
          apply(simp)
          apply(simp)
          apply(simp)
          apply(erule seqE_cons[where \<Gamma>="(\<lambda>a. if a = chain then Some rs else \<Gamma> a)"])
          apply(frule iptables_bigstep_to_undecided[where \<Gamma>="(\<lambda>a. if a = chain then Some rs else \<Gamma> a)"])
          apply(simp)
          done
      qed (auto intro: call_return)
  next
    case (Call_result m a chaina rsa t)
    thus ?case
      proof (cases "chaina = chain")
        case True
        with Call_result show ?thesis
          apply(simp)
          apply(cases "rsa")
           apply(simp)
           apply(rule_tac rs=rs in call_result)
            apply(simp_all)
          apply(erule_tac seqE_cons[where \<Gamma>="(\<lambda>b. if b = chain then Some rs else \<Gamma> b)"])
          apply(case_tac t)
           apply(simp)
           apply(frule iptables_bigstep_to_undecided[where \<Gamma>="(\<lambda>b. if b = chain then Some rs else \<Gamma> b)"])
           apply(simp)
          apply(simp)
          apply(subgoal_tac "ti = Undecided")
           apply(simp)
          using assms(1)[simplified map_update_chain_if[symmetric]] iptables_bigstep_deterministic apply fast
          done
      qed (fastforce intro: call_result)
  qed (auto intro: iptables_bigstep.intros)

lemma update_gamme_remove_Undecidedpart:
  assumes "\<Gamma>(chain \<mapsto> rs'),\<gamma>,p\<turnstile> \<langle>rs', Undecided\<rangle> \<Rightarrow> Undecided"
  and     "\<Gamma>(chain \<mapsto> rs1@rs'),\<gamma>,p\<turnstile> \<langle>rs, Undecided\<rangle> \<Rightarrow> Undecided"
  shows   "\<Gamma>(chain \<mapsto>rs'),\<gamma>,p\<turnstile> \<langle>rs, Undecided\<rangle> \<Rightarrow> Undecided"
  using assms(2) proof (induction rs Undecided Undecided rule: iptables_bigstep_induct)
    case Seq
    thus ?case
      by (auto simp: iptables_bigstep_to_undecided intro: seq)
  next
    case (Call_return m a chaina rs\<^sub>1 m' rs\<^sub>2)
    thus ?case
      apply(cases "chaina = chain")
       apply(simp)
       apply(cases "length rs1 \<le> length rs\<^sub>1")
        apply(simp add: List.append_eq_append_conv_if)
        apply(rule_tac rs\<^sub>1="drop (length rs1) rs\<^sub>1" and m'=m' and rs\<^sub>2=rs\<^sub>2 in call_return)
          apply(simp_all)[3]
        apply(subgoal_tac "rs\<^sub>1 = (take (length rs1) rs\<^sub>1) @ drop (length rs1) rs\<^sub>1")
         prefer 2 apply (metis append_take_drop_id)
        apply(clarify)
        apply(subgoal_tac "\<Gamma>(chain \<mapsto> drop (length rs1) rs\<^sub>1 @ Rule m' Return # rs\<^sub>2),\<gamma>,p\<turnstile>
            \<langle>(take (length rs1) rs\<^sub>1) @ drop (length rs1) rs\<^sub>1, Undecided\<rangle> \<Rightarrow> Undecided")
         prefer 2 apply(auto)[1]
        apply(erule_tac rs\<^sub>1="take (length rs1) rs\<^sub>1" and rs\<^sub>2="drop (length rs1) rs\<^sub>1" in seqE)
        apply(simp)
        apply(frule_tac rs="drop (length rs1) rs\<^sub>1" in iptables_bigstep_to_undecided)
        apply(simp; fail) (*oh wow*)
       using assms apply (auto intro: call_result call_return)
      done
  next
    case (Call_result _ _ chain' rsa)
    thus ?case
      apply(cases "chain' = chain")
       apply(simp)
       apply(rule call_result)
         apply(simp_all)[2]
       apply (metis iptables_bigstep_to_undecided seqE)
      apply (auto intro: call_result)
      done
  qed (auto intro: iptables_bigstep.intros)

lemma update_Gamma_nocall:
  assumes "\<not> (\<exists>chain. a = Call chain)"
  shows "\<Gamma>,\<gamma>,p\<turnstile> \<langle>[Rule m a], s\<rangle> \<Rightarrow> t \<longleftrightarrow> \<Gamma>',\<gamma>,p\<turnstile> \<langle>[Rule m a], s\<rangle> \<Rightarrow> t"
  proof -
    {
      fix \<Gamma> \<Gamma>'
      have "\<Gamma>,\<gamma>,p\<turnstile> \<langle>[Rule m a], s\<rangle> \<Rightarrow> t \<Longrightarrow> \<Gamma>',\<gamma>,p\<turnstile> \<langle>[Rule m a], s\<rangle> \<Rightarrow> t"
        proof (induction "[Rule m a]" s t rule: iptables_bigstep_induct)
          case Seq
          thus ?case by (metis (lifting, no_types) list_app_singletonE[where x = "Rule m a"] skipD)
        next
          case Call_return thus ?case using assms by metis
        next
          case Call_result thus ?case using assms by metis
        qed (auto intro: iptables_bigstep.intros)
    }
    thus ?thesis
      by blast
  qed

lemma update_Gamma_call:
  assumes "\<Gamma> chain = Some rs" and "\<Gamma>' chain = Some rs'"
  assumes "\<Gamma>,\<gamma>,p\<turnstile> \<langle>rs, Undecided\<rangle> \<Rightarrow> Undecided" and "\<Gamma>',\<gamma>,p\<turnstile> \<langle>rs', Undecided\<rangle> \<Rightarrow> Undecided"
  shows "\<Gamma>,\<gamma>,p\<turnstile> \<langle>[Rule m (Call chain)], s\<rangle> \<Rightarrow> t \<longleftrightarrow> \<Gamma>',\<gamma>,p\<turnstile> \<langle>[Rule m (Call chain)], s\<rangle> \<Rightarrow> t"
  proof -
    {
      fix \<Gamma> \<Gamma>' rs rs'
      assume assms:
        "\<Gamma> chain = Some rs" "\<Gamma>' chain = Some rs'"
        "\<Gamma>,\<gamma>,p\<turnstile> \<langle>rs, Undecided\<rangle> \<Rightarrow> Undecided" "\<Gamma>',\<gamma>,p\<turnstile> \<langle>rs', Undecided\<rangle> \<Rightarrow> Undecided"
      have "\<Gamma>,\<gamma>,p\<turnstile> \<langle>[Rule m (Call chain)], s\<rangle> \<Rightarrow> t \<Longrightarrow> \<Gamma>',\<gamma>,p\<turnstile> \<langle>[Rule m (Call chain)], s\<rangle> \<Rightarrow> t"
        proof (induction "[Rule m (Call chain)]" s t rule: iptables_bigstep_induct)
          case Seq
          thus ?case by (metis (lifting, no_types) list_app_singletonE[where x = "Rule m (Call chain)"] skipD)
        next
          case Call_result
          thus ?case
            using assms by (metis call_result iptables_bigstep_deterministic)
        qed (auto intro: iptables_bigstep.intros assms)
    }
    note * = this
    show ?thesis
      using *[OF assms(1-4)] *[OF assms(2,1,4,3)] by blast
  qed

lemma update_Gamma_remove_call_undecided:
  assumes "\<Gamma>(chain \<mapsto> Rule m (Call foo) # rs'),\<gamma>,p\<turnstile> \<langle>rs, Undecided\<rangle> \<Rightarrow> Undecided"
  and     "matches \<gamma> m p"
  shows "\<Gamma>(chain \<mapsto> rs'),\<gamma>,p\<turnstile> \<langle>rs, Undecided\<rangle> \<Rightarrow> Undecided"
  using assms
  proof (induction rs Undecided Undecided arbitrary: rule: iptables_bigstep_induct)
    case Seq
    thus ?case
      by (force simp: iptables_bigstep_to_undecided intro: seq')
  next
    case (Call_return m a chaina rs\<^sub>1 m' rs\<^sub>2)
    thus ?case
      apply(cases "chaina = chain")
      apply(cases "rs\<^sub>1")
      apply(force intro: call_return)
      apply(simp)
      apply(erule_tac \<Gamma>="\<Gamma>(chain \<mapsto> list @ Rule m' Return # rs\<^sub>2)" in seqE_cons)
      apply(frule_tac \<Gamma>="\<Gamma>(chain \<mapsto> list @ Rule m' Return # rs\<^sub>2)" in iptables_bigstep_to_undecided)
      apply(auto intro: call_return)
      done
  next
    case (Call_result m a chaina rsa)
    thus ?case
      apply(cases "chaina = chain")
      apply(simp)
      apply (metis call_result fun_upd_same iptables_bigstep_to_undecided seqE_cons)
      apply (auto intro: call_result)
      done
  qed (auto intro: iptables_bigstep.intros)

lemma all_return_subchain:
  assumes a1: "\<Gamma> chain = Some rs"
  and     a2: "matches \<gamma> m p"
  and     a3: "\<forall>r\<in>set rs. get_action r = Return"
  shows "\<Gamma>,\<gamma>,p\<turnstile> \<langle>[Rule m (Call chain)], Undecided\<rangle> \<Rightarrow> Undecided"
  proof (cases "\<exists>r \<in> set rs. matches \<gamma> (get_match r) p")
    case True
    hence "(\<exists>rs1 r rs2. rs = rs1 @ r # rs2 \<and> matches \<gamma> (get_match r) p \<and> (\<forall>r'\<in>set rs1. \<not> matches \<gamma> (get_match r') p))"
      by (subst split_list_first_prop_iff[symmetric])
    then obtain rs1 r rs2
      where *: "rs = rs1 @ r # rs2" "matches \<gamma> (get_match r) p" "\<forall>r'\<in>set rs1. \<not> matches \<gamma> (get_match r') p"
      by auto

    with a3 obtain m' where "r = Rule m' Return"
      by (cases r) simp
    with * assms show ?thesis
      by (fastforce intro: call_return nomatch')
  next
    case False
    hence "\<Gamma>,\<gamma>,p\<turnstile> \<langle>rs, Undecided\<rangle> \<Rightarrow> Undecided"
      by (blast intro: nomatch')
    with a1 a2 show ?thesis
      by (metis call_result)
qed

lemma get_action_case_simp: "get_action (case r of Rule m' x \<Rightarrow> Rule (MatchAnd m m') x) = get_action r"
by (metis rule.case_eq_if rule.sel(2))

lemma updategamma_insert_new: "\<Gamma>,\<gamma>,p\<turnstile> \<langle>rs, s\<rangle> \<Rightarrow> t \<Longrightarrow> chain \<notin> dom \<Gamma> \<Longrightarrow> \<Gamma>(chain \<mapsto> rs'),\<gamma>,p\<turnstile> \<langle>rs, s\<rangle> \<Rightarrow> t"
proof(induction rule: iptables_bigstep_induct)
case (Call_result m a chain' rs t)
  thus ?case by (metis call_result domI fun_upd_def)
next
case Call_return
  thus ?case by (metis call_return domI fun_upd_def)
qed(auto intro: iptables_bigstep.intros)

end