theory Concrete_Security
imports
  Observe_Failure
  Construction_Utility
begin

section \<open>Concrete security definition\<close>

locale constructive_security_aux_obsf =
  fixes real_resource :: "('a + 'e, 'b + 'f) resource"
    and ideal_resource :: "('c + 'e, 'd + 'f) resource"
    and sim :: "('a, 'b, 'c, 'd) converter"
    and \<I>_real :: "('a, 'b) \<I>"
    and \<I>_ideal :: "('c, 'd) \<I>"
    and \<I>_common :: "('e, 'f) \<I>"
    and adv :: real
  assumes WT_real [WT_intro]: "\<I>_real \<oplus>\<^sub>\<I> \<I>_common \<turnstile>res real_resource \<surd>"
    and WT_ideal [WT_intro]: "\<I>_ideal \<oplus>\<^sub>\<I> \<I>_common \<turnstile>res ideal_resource \<surd>"
    and WT_sim [WT_intro]: "\<I>_real, \<I>_ideal \<turnstile>\<^sub>C sim \<surd>"
    and pfinite_sim [pfinite_intro]: "pfinite_converter \<I>_real \<I>_ideal sim"
    and adv_nonneg: "0 \<le> adv"

locale constructive_security_sim_obsf =
  fixes real_resource :: "('a + 'e, 'b + 'f) resource"
    and ideal_resource :: "('c + 'e, 'd + 'f) resource"
    and sim :: "('a, 'b, 'c, 'd) converter"
    and \<I>_real :: "('a, 'b) \<I>"
    and \<I>_common :: "('e, 'f) \<I>"
    and \<A> :: "('a + 'e, 'b + 'f) distinguisher_obsf"
    and adv :: real
  assumes adv: "\<lbrakk> exception_\<I> (\<I>_real \<oplus>\<^sub>\<I> \<I>_common) \<turnstile>g \<A> \<surd> \<rbrakk>
      \<Longrightarrow> advantage \<A> (obsf_resource (sim |\<^sub>= 1\<^sub>C \<rhd> ideal_resource)) (obsf_resource (real_resource)) \<le> adv"

locale constructive_security_obsf = constructive_security_aux_obsf real_resource ideal_resource sim \<I>_real \<I>_ideal \<I>_common adv
  + constructive_security_sim_obsf real_resource ideal_resource sim \<I>_real \<I>_common \<A> adv
  for real_resource :: "('a + 'e, 'b + 'f) resource"
    and ideal_resource :: "('c + 'e, 'd + 'f) resource"
    and sim :: "('a, 'b, 'c, 'd) converter"
    and \<I>_real :: "('a, 'b) \<I>"
    and \<I>_ideal :: "('c, 'd) \<I>"
    and \<I>_common :: "('e, 'f) \<I>"
    and \<A> :: "('a + 'e, 'b + 'f) distinguisher_obsf"
    and adv :: real
begin

lemma constructive_security_aux_obsf: "constructive_security_aux_obsf real_resource ideal_resource sim \<I>_real \<I>_ideal \<I>_common adv" ..
lemma constructive_security_sim_obsf: "constructive_security_sim_obsf real_resource ideal_resource sim \<I>_real \<I>_common \<A> adv" ..

end

context constructive_security_aux_obsf begin

lemma constructive_security_obsf_refl:
  "constructive_security_obsf real_resource ideal_resource sim \<I>_real \<I>_ideal \<I>_common \<A>
    (advantage \<A> (obsf_resource (sim |\<^sub>= 1\<^sub>C \<rhd> ideal_resource)) (obsf_resource (real_resource)))"
  by unfold_locales(simp_all add: advantage_def WT_intro pfinite_intro)

end

lemma constructive_security_obsf_absorb_cong:
  assumes sec: "constructive_security_obsf real_resource ideal_resource sim \<I>_real \<I>_ideal \<I>_common (absorb \<A> cnv) adv"
    and [WT_intro]: "exception_\<I> \<I>, exception_\<I> (\<I>_real \<oplus>\<^sub>\<I> \<I>_common) \<turnstile>\<^sub>C cnv \<surd>" "exception_\<I> \<I>, exception_\<I> (\<I>_real \<oplus>\<^sub>\<I> \<I>_common) \<turnstile>\<^sub>C cnv' \<surd>" "exception_\<I> \<I> \<turnstile>g \<A> \<surd>"
    and cong: "exception_\<I> \<I>, exception_\<I> (\<I>_real \<oplus>\<^sub>\<I> \<I>_common) \<turnstile>\<^sub>C cnv \<sim> cnv'"
  shows "constructive_security_obsf real_resource ideal_resource sim \<I>_real \<I>_ideal \<I>_common (absorb \<A> cnv') adv"
proof -
  interpret constructive_security_obsf real_resource ideal_resource sim \<I>_real \<I>_ideal \<I>_common "absorb \<A> cnv" adv by fact
  show ?thesis
  proof
    have "connect_obsf \<A> (cnv' \<rhd> obsf_resource (sim |\<^sub>= 1\<^sub>C \<rhd> ideal_resource)) = connect_obsf \<A> (cnv \<rhd> obsf_resource (sim |\<^sub>= 1\<^sub>C \<rhd> ideal_resource))"
      "connect_obsf \<A> (cnv' \<rhd> obsf_resource real_resource) = connect_obsf \<A> (cnv \<rhd> obsf_resource real_resource)"
      by(rule connect_eq_resource_cong eq_\<I>_attach_on' WT_intro cong[symmetric] order_refl)+
    then have "advantage (absorb \<A> cnv') (obsf_resource (sim |\<^sub>= 1\<^sub>C \<rhd> ideal_resource)) (obsf_resource real_resource) =
          advantage (absorb \<A> cnv) (obsf_resource (sim |\<^sub>= 1\<^sub>C \<rhd> ideal_resource)) (obsf_resource real_resource)"
      unfolding advantage_def distinguish_attach[symmetric] by simp
    also have "\<dots> \<le> adv" by(rule adv)(rule WT_intro)+
    finally show "advantage (absorb \<A> cnv') (obsf_resource (sim |\<^sub>= 1\<^sub>C \<rhd> ideal_resource)) (obsf_resource real_resource) \<le> adv" .
  qed
qed

lemma constructive_security_obsf_sim_cong:
  assumes sec: "constructive_security_obsf real_resource ideal_resource sim \<I>_real \<I>_ideal \<I>_common \<A> adv"
    and cong: "\<I>_real, \<I>_ideal \<turnstile>\<^sub>C sim \<sim> sim'"
    and pfinite [pfinite_intro]: "pfinite_converter \<I>_real \<I>_ideal sim'" (* This could probably be derived from cong and sec.pfinite_sim *)
  shows "constructive_security_obsf real_resource ideal_resource sim' \<I>_real \<I>_ideal \<I>_common \<A> adv"
proof
  interpret constructive_security_obsf real_resource ideal_resource sim \<I>_real \<I>_ideal \<I>_common \<A> adv by fact
  show "\<I>_real \<oplus>\<^sub>\<I> \<I>_common \<turnstile>res real_resource \<surd>" "\<I>_ideal \<oplus>\<^sub>\<I> \<I>_common \<turnstile>res ideal_resource \<surd>" by(rule WT_intro)+
  from cong show [WT_intro]: "\<I>_real, \<I>_ideal \<turnstile>\<^sub>C sim' \<surd>" by(rule eq_\<I>_converterD_WT1)(rule WT_intro)
  show "pfinite_converter \<I>_real \<I>_ideal sim'" by fact
  show "0 \<le> adv" by(rule adv_nonneg)

  assume WT [WT_intro]: "exception_\<I> (\<I>_real \<oplus>\<^sub>\<I> \<I>_common) \<turnstile>g \<A> \<surd>"
  have "connect_obsf \<A> (obsf_resource (sim' |\<^sub>= 1\<^sub>C \<rhd> ideal_resource)) = connect_obsf \<A> (obsf_resource (sim |\<^sub>= 1\<^sub>C \<rhd> ideal_resource))"
    by(rule connect_eq_resource_cong WT_intro obsf_resource_eq_\<I>_cong eq_\<I>_attach_on' parallel_converter2_eq_\<I>_cong cong[symmetric] eq_\<I>_converter_reflI | simp)+
  with adv[OF WT]
  show "advantage \<A> (obsf_resource (sim' |\<^sub>= 1\<^sub>C \<rhd> ideal_resource)) (obsf_resource real_resource) \<le> adv"
    unfolding advantage_def by simp
qed

lemma constructive_security_obsfI_core_rest [locale_witness]:
  assumes "constructive_security_aux_obsf real_resource ideal_resource sim \<I>_real \<I>_ideal (\<I>_common_core \<oplus>\<^sub>\<I> \<I>_common_rest) adv"
    and adv: "\<lbrakk> exception_\<I> (\<I>_real \<oplus>\<^sub>\<I> (\<I>_common_core \<oplus>\<^sub>\<I> \<I>_common_rest)) \<turnstile>g \<A> \<surd> \<rbrakk>
      \<Longrightarrow> advantage \<A> (obsf_resource (sim |\<^sub>= (1\<^sub>C |\<^sub>= 1\<^sub>C) \<rhd> ideal_resource)) (obsf_resource (real_resource)) \<le> adv"
  shows "constructive_security_obsf real_resource ideal_resource sim \<I>_real \<I>_ideal (\<I>_common_core \<oplus>\<^sub>\<I> \<I>_common_rest) \<A> adv"
proof -
  interpret constructive_security_aux_obsf real_resource ideal_resource sim \<I>_real \<I>_ideal "\<I>_common_core \<oplus>\<^sub>\<I> \<I>_common_rest" by fact
  show ?thesis
  proof
    assume A [WT_intro]: "exception_\<I> (\<I>_real \<oplus>\<^sub>\<I> (\<I>_common_core \<oplus>\<^sub>\<I> \<I>_common_rest)) \<turnstile>g \<A> \<surd>"
    hence outs: "outs_gpv (exception_\<I> (\<I>_real \<oplus>\<^sub>\<I> (\<I>_common_core \<oplus>\<^sub>\<I> \<I>_common_rest))) \<A> \<subseteq> outs_\<I> (\<I>_real \<oplus>\<^sub>\<I> (\<I>_common_core \<oplus>\<^sub>\<I> \<I>_common_rest))"
      unfolding WT_gpv_iff_outs_gpv by simp
    have "connect_obsf \<A> (obsf_resource (sim |\<^sub>= 1\<^sub>C \<rhd> ideal_resource)) = connect_obsf \<A> (obsf_resource (sim |\<^sub>= 1\<^sub>C |\<^sub>= 1\<^sub>C \<rhd> ideal_resource))"
      by(rule connect_cong_trace trace_eq_obsf_resourceI eq_resource_on_imp_trace_eq eq_\<I>_attach_on')+
        (rule WT_intro parallel_converter2_eq_\<I>_cong eq_\<I>_converter_reflI parallel_converter2_id_id[symmetric] order_refl outs)+
    then show "advantage \<A> (obsf_resource (sim |\<^sub>= 1\<^sub>C \<rhd> ideal_resource)) (obsf_resource real_resource) \<le> adv"
      using adv[OF A] by(simp add: advantage_def)
  qed
qed

subsection \<open>Composition theorems\<close>

theorem constructive_security_obsf_composability:
  fixes real
  assumes "constructive_security_obsf middle ideal sim_inner \<I>_middle \<I>_inner \<I>_common (absorb \<A> (obsf_converter (sim_outer |\<^sub>= 1\<^sub>C))) adv1"
  assumes "constructive_security_obsf real middle sim_outer \<I>_real \<I>_middle \<I>_common \<A> adv2"
  shows "constructive_security_obsf real ideal (sim_outer \<odot> sim_inner) \<I>_real \<I>_inner \<I>_common \<A> (adv1 + adv2)"
proof
  let ?\<A> = "absorb \<A> (obsf_converter (sim_outer |\<^sub>= 1\<^sub>C))"
  interpret inner: constructive_security_obsf middle ideal sim_inner \<I>_middle \<I>_inner \<I>_common ?\<A> adv1 by fact
  interpret outer: constructive_security_obsf real middle sim_outer \<I>_real \<I>_middle \<I>_common \<A> adv2 by fact

  show "\<I>_real \<oplus>\<^sub>\<I> \<I>_common \<turnstile>res real \<surd>"
    and "\<I>_inner \<oplus>\<^sub>\<I> \<I>_common \<turnstile>res ideal \<surd>"
    and "\<I>_real, \<I>_inner \<turnstile>\<^sub>C sim_outer \<odot> sim_inner \<surd>"  by(rule WT_intro)+
  show "pfinite_converter \<I>_real \<I>_inner (sim_outer \<odot> sim_inner)" by(rule pfinite_intro WT_intro)+
  show "0 \<le> adv1 + adv2" using inner.adv_nonneg outer.adv_nonneg by simp

  assume WT_adv[WT_intro]: "exception_\<I> (\<I>_real \<oplus>\<^sub>\<I> \<I>_common) \<turnstile>g \<A> \<surd>"
  have eq1: "connect_obsf (absorb \<A> (obsf_converter (sim_outer |\<^sub>= 1\<^sub>C))) (obsf_resource (sim_inner |\<^sub>= 1\<^sub>C \<rhd> ideal)) =
      connect_obsf \<A> (obsf_resource (sim_outer \<odot> sim_inner |\<^sub>= 1\<^sub>C \<rhd> ideal))"
    unfolding distinguish_attach[symmetric]
    apply(rule connect_eq_resource_cong)
      apply(rule WT_intro)
     apply(simp del: outs_plus_\<I> add: parallel_converter2_comp1_out attach_compose)
     apply(rule obsf_attach)
       apply(rule pfinite_intro WT_intro)+
    done
  have eq2: "connect_obsf (absorb \<A> (obsf_converter (sim_outer |\<^sub>= 1\<^sub>C))) (obsf_resource middle) =
      connect_obsf \<A> (obsf_resource (sim_outer |\<^sub>= 1\<^sub>C \<rhd> middle))"
    unfolding distinguish_attach[symmetric]
    apply(rule connect_eq_resource_cong)
      apply(rule WT_intro)
     apply(simp del: outs_plus_\<I> add: parallel_converter2_comp1_out attach_compose)
     apply(rule obsf_attach)
       apply(rule pfinite_intro WT_intro)+
    done

  have "advantage ?\<A> (obsf_resource (sim_inner |\<^sub>= 1\<^sub>C \<rhd> ideal)) (obsf_resource middle) \<le> adv1"
    by(rule inner.adv)(rule WT_intro)+
  moreover have "advantage \<A> (obsf_resource (sim_outer |\<^sub>= 1\<^sub>C \<rhd> middle)) (obsf_resource real) \<le> adv2"
    by(rule outer.adv)(rule WT_intro)+
  ultimately
  show "advantage \<A> (obsf_resource (sim_outer \<odot> sim_inner |\<^sub>= 1\<^sub>C \<rhd> ideal)) (obsf_resource real) \<le> adv1 + adv2"
    by(auto simp add: advantage_def eq1 eq2 abs_diff_triangle_ineq2)
qed

theorem constructive_security_obsf_lifting:
  assumes sec: "constructive_security_aux_obsf real_resource ideal_resource sim \<I>_real \<I>_ideal \<I>_common adv"
    and sec2: "exception_\<I> (\<I>_real' \<oplus>\<^sub>\<I> \<I>_common') \<turnstile>g \<A> \<surd>
    \<Longrightarrow> constructive_security_sim_obsf real_resource ideal_resource sim \<I>_real \<I>_common (absorb \<A> (obsf_converter (w_adv_real |\<^sub>= w_usr))) adv"
    (is "_ \<Longrightarrow> constructive_security_sim_obsf _ _ _ _ _ ?\<A> _")
  assumes WT_usr [WT_intro]: "\<I>_common', \<I>_common \<turnstile>\<^sub>C w_usr \<surd>"
    and pfinite [pfinite_intro]: "pfinite_converter \<I>_common' \<I>_common w_usr"
    and WT_adv_real [WT_intro]: "\<I>_real', \<I>_real \<turnstile>\<^sub>C w_adv_real \<surd>"
    and WT_w_adv_ideal [WT_intro]: "\<I>_ideal', \<I>_ideal \<turnstile>\<^sub>C w_adv_ideal \<surd>"
    and WT_adv_ideal_inv [WT_intro]: "\<I>_ideal, \<I>_ideal' \<turnstile>\<^sub>C w_adv_ideal_inv \<surd>"
    and ideal_inverse: "\<I>_ideal, \<I>_ideal \<turnstile>\<^sub>C w_adv_ideal_inv \<odot> w_adv_ideal \<sim> 1\<^sub>C"
    and pfinite_real [pfinite_intro]: "pfinite_converter \<I>_real' \<I>_real w_adv_real"
    and pfinite_ideal [pfinite_intro]: "pfinite_converter \<I>_ideal \<I>_ideal' w_adv_ideal_inv"
  shows "constructive_security_obsf (w_adv_real |\<^sub>= w_usr \<rhd> real_resource) (w_adv_ideal |\<^sub>= w_usr \<rhd> ideal_resource) (w_adv_real \<odot> sim \<odot> w_adv_ideal_inv) \<I>_real' \<I>_ideal' \<I>_common' \<A> adv"
    (is "constructive_security_obsf ?real ?ideal ?sim ?\<I>_real ?\<I>_ideal _ _ _")
proof
  interpret constructive_security_aux_obsf real_resource ideal_resource sim \<I>_real \<I>_ideal \<I>_common by fact
  show "\<I>_real' \<oplus>\<^sub>\<I> \<I>_common' \<turnstile>res ?real \<surd>"
    and "\<I>_ideal' \<oplus>\<^sub>\<I> \<I>_common' \<turnstile>res ?ideal \<surd>"
    and "\<I>_real', \<I>_ideal' \<turnstile>\<^sub>C ?sim \<surd>" by(rule WT_intro)+
  show "pfinite_converter \<I>_real' \<I>_ideal' ?sim" by(rule pfinite_intro WT_intro)+
  show "0 \<le> adv" by(rule adv_nonneg)

  assume WT_adv [WT_intro]: "exception_\<I> (\<I>_real' \<oplus>\<^sub>\<I> \<I>_common') \<turnstile>g \<A> \<surd>"
  then interpret constructive_security_sim_obsf real_resource ideal_resource sim \<I>_real \<I>_common ?\<A> adv by(rule sec2)

  have *: "advantage ?\<A> (obsf_resource (sim |\<^sub>= 1\<^sub>C \<rhd> ideal_resource)) (obsf_resource real_resource) \<le> adv"
    by(rule adv)(rule WT_intro)+

  have ideal: "connect_obsf ?\<A> (obsf_resource (sim |\<^sub>= 1\<^sub>C \<rhd> ideal_resource)) =
    connect_obsf \<A> (obsf_resource (?sim |\<^sub>= 1\<^sub>C \<rhd> ?ideal))"
    unfolding distinguish_attach[symmetric]
    apply(rule connect_eq_resource_cong)
      apply(rule WT_intro)
     apply(simp del: outs_plus_\<I>)
     apply(rule eq_resource_on_trans[OF obsf_attach])
        apply(rule pfinite_intro WT_intro)+
     apply(rule obsf_resource_eq_\<I>_cong)
     apply(fold attach_compose)
     apply(unfold comp_converter_parallel2)
     apply(rule eq_\<I>_attach_on')
       apply(rule WT_intro)
      apply(rule parallel_converter2_eq_\<I>_cong)
       apply(unfold comp_converter_assoc)
       apply(rule eq_\<I>_comp_cong)
        apply(rule eq_\<I>_converter_reflI; rule WT_intro)
       apply(rule eq_\<I>_converter_trans[rotated])
        apply(rule eq_\<I>_comp_cong)
         apply(rule eq_\<I>_converter_reflI; rule WT_intro)
        apply(rule ideal_inverse[symmetric])
       apply(unfold comp_converter_id_right comp_converter_id_left)
       apply(rule eq_\<I>_converter_reflI; rule WT_intro)+
     apply simp
    apply(rule WT_intro)+
    done
  have real: "connect_obsf ?\<A> (obsf_resource real_resource) = connect_obsf \<A> (obsf_resource ?real)"
    unfolding distinguish_attach[symmetric]
    apply(rule connect_eq_resource_cong)
      apply(rule WT_intro)
     apply(simp del: outs_plus_\<I>)
     apply(rule obsf_attach)
       apply(rule pfinite_intro WT_intro)+
    done
  show "advantage \<A> (obsf_resource ((?sim |\<^sub>= 1\<^sub>C) \<rhd> ?ideal)) (obsf_resource ?real) \<le> adv" using *
    unfolding advantage_def ideal[symmetric] real[symmetric] .
qed

corollary constructive_security_obsf_lifting_:
  assumes sec: "constructive_security_obsf real_resource ideal_resource sim \<I>_real \<I>_ideal \<I>_common (absorb \<A> (obsf_converter (w_adv_real |\<^sub>= w_usr))) adv"
  assumes WT_usr [WT_intro]: "\<I>_common', \<I>_common \<turnstile>\<^sub>C w_usr \<surd>"
    and pfinite [pfinite_intro]: "pfinite_converter \<I>_common' \<I>_common w_usr"
    and WT_adv_real [WT_intro]: "\<I>_real', \<I>_real \<turnstile>\<^sub>C w_adv_real \<surd>"
    and WT_w_adv_ideal [WT_intro]: "\<I>_ideal', \<I>_ideal \<turnstile>\<^sub>C w_adv_ideal \<surd>"
    and WT_adv_ideal_inv [WT_intro]: "\<I>_ideal, \<I>_ideal' \<turnstile>\<^sub>C w_adv_ideal_inv \<surd>"
    and ideal_inverse: "\<I>_ideal, \<I>_ideal \<turnstile>\<^sub>C w_adv_ideal_inv \<odot> w_adv_ideal \<sim> 1\<^sub>C"
    and pfinite_real [pfinite_intro]: "pfinite_converter \<I>_real' \<I>_real w_adv_real"
    and pfinite_ideal [pfinite_intro]: "pfinite_converter \<I>_ideal \<I>_ideal' w_adv_ideal_inv"
  shows "constructive_security_obsf (w_adv_real |\<^sub>= w_usr \<rhd> real_resource) (w_adv_ideal |\<^sub>= w_usr \<rhd> ideal_resource) (w_adv_real \<odot> sim \<odot> w_adv_ideal_inv) \<I>_real' \<I>_ideal' \<I>_common' \<A> adv"
proof -
  interpret constructive_security_obsf real_resource ideal_resource sim \<I>_real \<I>_ideal \<I>_common "absorb \<A> (obsf_converter (w_adv_real |\<^sub>= w_usr))" adv by fact
  from constructive_security_aux_obsf constructive_security_sim_obsf assms(2-)
  show ?thesis by(rule constructive_security_obsf_lifting)
qed

theorem constructive_security_obsf_lifting_usr:
  assumes sec: "constructive_security_aux_obsf real_resource ideal_resource sim \<I>_real \<I>_ideal \<I>_common adv"
    and sec2: "exception_\<I> (\<I>_real \<oplus>\<^sub>\<I> \<I>_common') \<turnstile>g \<A> \<surd>
    \<Longrightarrow> constructive_security_sim_obsf real_resource ideal_resource sim \<I>_real \<I>_common (absorb \<A> (obsf_converter (1\<^sub>C |\<^sub>= conv))) adv"
    and WT_conv [WT_intro]: "\<I>_common', \<I>_common \<turnstile>\<^sub>C conv \<surd>"
    and pfinite [pfinite_intro]: "pfinite_converter \<I>_common' \<I>_common conv"
  shows "constructive_security_obsf (1\<^sub>C |\<^sub>= conv \<rhd> real_resource) (1\<^sub>C |\<^sub>= conv \<rhd> ideal_resource) sim \<I>_real \<I>_ideal \<I>_common' \<A> adv"
  by(rule constructive_security_obsf_lifting[OF sec sec2, where ?w_adv_ideal="1\<^sub>C" and ?w_adv_ideal_inv="1\<^sub>C", simplified comp_converter_id_left comp_converter_id_right])
    (rule WT_intro pfinite_intro id_converter_eq_self order_refl | assumption)+

theorem constructive_security_obsf_lifting2:
  assumes sec: "constructive_security_aux_obsf real_resource ideal_resource sim (\<I>_real1 \<oplus>\<^sub>\<I> \<I>_real2) (\<I>_ideal1 \<oplus>\<^sub>\<I> \<I>_ideal2) \<I>_common adv"
    and sec2: "exception_\<I> ((\<I>_real1 \<oplus>\<^sub>\<I> \<I>_real2) \<oplus>\<^sub>\<I> \<I>_common') \<turnstile>g \<A> \<surd>
    \<Longrightarrow> constructive_security_sim_obsf real_resource ideal_resource sim (\<I>_real1 \<oplus>\<^sub>\<I> \<I>_real2) \<I>_common (absorb \<A> (obsf_converter ((1\<^sub>C |\<^sub>= 1\<^sub>C) |\<^sub>= conv))) adv"
  assumes WT_conv [WT_intro]: "\<I>_common', \<I>_common \<turnstile>\<^sub>C conv \<surd>"
    and pfinite [pfinite_intro]: "pfinite_converter \<I>_common' \<I>_common conv"
  shows "constructive_security_obsf ((1\<^sub>C |\<^sub>= 1\<^sub>C) |\<^sub>= conv \<rhd> real_resource) ((1\<^sub>C |\<^sub>= 1\<^sub>C) |\<^sub>= conv \<rhd> ideal_resource) sim (\<I>_real1 \<oplus>\<^sub>\<I> \<I>_real2) (\<I>_ideal1 \<oplus>\<^sub>\<I> \<I>_ideal2) \<I>_common' \<A> adv"
    (is "constructive_security_obsf ?real ?ideal _ ?\<I>_real ?\<I>_ideal _ _ _")
proof -
  interpret constructive_security_aux_obsf real_resource ideal_resource sim "\<I>_real1 \<oplus>\<^sub>\<I> \<I>_real2" "\<I>_ideal1 \<oplus>\<^sub>\<I> \<I>_ideal2" \<I>_common adv by fact
  have sim [unfolded comp_converter_id_left]: "\<I>_real1 \<oplus>\<^sub>\<I> \<I>_real2,\<I>_ideal1 \<oplus>\<^sub>\<I> \<I>_ideal2 \<turnstile>\<^sub>C (1\<^sub>C |\<^sub>= 1\<^sub>C) \<odot> sim \<sim> 1\<^sub>C \<odot> sim"
    by(rule eq_\<I>_comp_cong)(rule parallel_converter2_id_id eq_\<I>_converter_reflI WT_intro)+
  show ?thesis
    apply(rule constructive_security_obsf_sim_cong)
      apply(rule constructive_security_obsf_lifting[OF sec sec2, where ?w_adv_ideal="1\<^sub>C |\<^sub>= 1\<^sub>C" and ?w_adv_ideal_inv="1\<^sub>C", unfolded comp_converter_id_left comp_converter_id_right])
              apply(assumption|rule WT_intro sim pfinite_intro parallel_converter2_id_id)+
    done
qed

theorem constructive_security_obsf_trivial:
  fixes res
  assumes [WT_intro]: "\<I> \<oplus>\<^sub>\<I> \<I>_common \<turnstile>res res \<surd>"
  shows "constructive_security_obsf res res 1\<^sub>C \<I> \<I> \<I>_common \<A> 0"
proof
  show "\<I> \<oplus>\<^sub>\<I> \<I>_common \<turnstile>res res \<surd>" and "\<I>, \<I> \<turnstile>\<^sub>C 1\<^sub>C \<surd>" by(rule WT_intro)+
  show "pfinite_converter \<I> \<I> 1\<^sub>C" by(rule pfinite_intro)

  assume WT [WT_intro]: "exception_\<I> (\<I> \<oplus>\<^sub>\<I> \<I>_common) \<turnstile>g \<A> \<surd>"
  have "connect_obsf \<A> (obsf_resource (1\<^sub>C |\<^sub>= 1\<^sub>C \<rhd> res)) = connect_obsf \<A> (obsf_resource (1\<^sub>C \<rhd> res))"
    by(rule connect_eq_resource_cong[OF WT])(fastforce intro: WT_intro eq_\<I>_attach_on' obsf_resource_eq_\<I>_cong parallel_converter2_id_id)+
  then show "advantage \<A> (obsf_resource (1\<^sub>C |\<^sub>= 1\<^sub>C \<rhd> res)) (obsf_resource res) \<le> 0"
    unfolding advantage_def by simp
qed simp

lemma parallel_constructive_security_aux_obsf [locale_witness]:
  assumes "constructive_security_aux_obsf real1 ideal1 sim1 \<I>_real1 \<I>_inner1 \<I>_common1 adv1"
  assumes "constructive_security_aux_obsf real2 ideal2 sim2 \<I>_real2 \<I>_inner2 \<I>_common2 adv2"
  shows "constructive_security_aux_obsf (parallel_wiring \<rhd> real1 \<parallel> real2) (parallel_wiring \<rhd> ideal1 \<parallel> ideal2) (sim1 |\<^sub>= sim2)
    (\<I>_real1 \<oplus>\<^sub>\<I> \<I>_real2) (\<I>_inner1 \<oplus>\<^sub>\<I> \<I>_inner2) (\<I>_common1 \<oplus>\<^sub>\<I> \<I>_common2)
    (adv1 + adv2)"
proof
  interpret sec1: constructive_security_aux_obsf real1 ideal1 sim1 \<I>_real1 \<I>_inner1 \<I>_common1 adv1 by fact
  interpret sec2: constructive_security_aux_obsf real2 ideal2 sim2 \<I>_real2 \<I>_inner2 \<I>_common2 adv2 by fact

  show "(\<I>_real1 \<oplus>\<^sub>\<I> \<I>_real2) \<oplus>\<^sub>\<I> (\<I>_common1 \<oplus>\<^sub>\<I> \<I>_common2) \<turnstile>res parallel_wiring \<rhd> real1 \<parallel> real2 \<surd>"
    and "(\<I>_inner1 \<oplus>\<^sub>\<I> \<I>_inner2) \<oplus>\<^sub>\<I> (\<I>_common1 \<oplus>\<^sub>\<I> \<I>_common2) \<turnstile>res parallel_wiring \<rhd> ideal1 \<parallel> ideal2 \<surd>"
    and "\<I>_real1 \<oplus>\<^sub>\<I> \<I>_real2, \<I>_inner1 \<oplus>\<^sub>\<I> \<I>_inner2 \<turnstile>\<^sub>C sim1 |\<^sub>= sim2 \<surd>" by(rule WT_intro)+
  show "pfinite_converter (\<I>_real1 \<oplus>\<^sub>\<I> \<I>_real2) (\<I>_inner1 \<oplus>\<^sub>\<I> \<I>_inner2) (sim1 |\<^sub>= sim2)" by(rule pfinite_intro)+
  show "0 \<le> adv1 + adv2" using sec1.adv_nonneg sec2.adv_nonneg by simp
qed

theorem parallel_constructive_security_obsf:
  assumes "constructive_security_obsf real1 ideal1 sim1 \<I>_real1 \<I>_inner1 \<I>_common1 (absorb \<A> (obsf_converter (parallel_wiring \<odot> parallel_converter 1\<^sub>C (converter_of_resource (sim2 |\<^sub>= 1\<^sub>C \<rhd> ideal2))))) adv1"
    (is "constructive_security_obsf _ _ _ _ _ _ ?\<A>1 _")
  assumes "constructive_security_obsf real2 ideal2 sim2 \<I>_real2 \<I>_inner2 \<I>_common2 (absorb \<A> (obsf_converter (parallel_wiring \<odot> parallel_converter (converter_of_resource real1) 1\<^sub>C))) adv2"
    (is "constructive_security_obsf _ _ _ _ _ _ ?\<A>2 _")
  shows "constructive_security_obsf (parallel_wiring \<rhd> real1 \<parallel> real2) (parallel_wiring \<rhd> ideal1 \<parallel> ideal2) (sim1 |\<^sub>= sim2)
    (\<I>_real1 \<oplus>\<^sub>\<I> \<I>_real2) (\<I>_inner1 \<oplus>\<^sub>\<I> \<I>_inner2) (\<I>_common1 \<oplus>\<^sub>\<I> \<I>_common2)
    \<A> (adv1 + adv2)"
proof -
  interpret sec1: constructive_security_obsf real1 ideal1 sim1 \<I>_real1 \<I>_inner1 \<I>_common1 ?\<A>1 adv1 by fact
  interpret sec2: constructive_security_obsf real2 ideal2 sim2 \<I>_real2 \<I>_inner2 \<I>_common2 ?\<A>2 adv2 by fact

  show ?thesis
  proof
    assume WT [WT_intro]: "exception_\<I> ((\<I>_real1 \<oplus>\<^sub>\<I> \<I>_real2) \<oplus>\<^sub>\<I> (\<I>_common1 \<oplus>\<^sub>\<I> \<I>_common2)) \<turnstile>g \<A> \<surd>"

    have **: "outs_\<I> ((\<I>_real1 \<oplus>\<^sub>\<I> \<I>_real2) \<oplus>\<^sub>\<I> (\<I>_common1 \<oplus>\<^sub>\<I> \<I>_common2)) \<turnstile>\<^sub>R
    ((1\<^sub>C |\<^sub>= sim2) |\<^sub>= 1\<^sub>C |\<^sub>= 1\<^sub>C) \<odot> parallel_wiring \<rhd> real1 \<parallel> ideal2 \<sim>
    parallel_wiring \<odot> (converter_of_resource real1 |\<^sub>\<propto> 1\<^sub>C) \<rhd> sim2 |\<^sub>= 1\<^sub>C \<rhd> ideal2"
      unfolding comp_parallel_wiring
      by(rule eq_resource_on_trans, rule eq_\<I>_attach_on[where conv'="parallel_wiring \<odot> (1\<^sub>C |\<^sub>= sim2 |\<^sub>= 1\<^sub>C)"]
          , (rule WT_intro)+, rule eq_\<I>_comp_cong, rule eq_\<I>_converter_mono)
        (auto simp add: le_\<I>_def attach_compose attach_parallel2 attach_converter_of_resource_conv_parallel_resource
          intro: WT_intro parallel_converter2_eq_\<I>_cong parallel_converter2_id_id eq_\<I>_converter_reflI)

    have ideal2:
      "connect_obsf ?\<A>2 (obsf_resource (sim2 |\<^sub>= 1\<^sub>C \<rhd> ideal2)) =
     connect_obsf \<A> (obsf_resource ((1\<^sub>C |\<^sub>= sim2) |\<^sub>= (1\<^sub>C |\<^sub>= 1\<^sub>C) \<rhd> parallel_wiring \<rhd> real1 \<parallel> ideal2))"
      unfolding distinguish_attach[symmetric]
      apply(rule connect_eq_resource_cong)
        apply(rule WT_intro)
       apply(simp del: outs_plus_\<I>)
       apply(rule eq_resource_on_trans[OF obsf_attach])
          apply(rule pfinite_intro WT_intro)+
       apply(rule obsf_resource_eq_\<I>_cong)
       apply(rule eq_resource_on_sym)
       apply(subst attach_compose[symmetric])
       apply(rule **)
      apply(rule WT_intro)+
      done

    have real2: "connect_obsf ?\<A>2 (obsf_resource real2) = connect_obsf \<A> (obsf_resource (parallel_wiring \<rhd> real1 \<parallel> real2))"
      unfolding distinguish_attach[symmetric]
      apply(rule connect_eq_resource_cong)
        apply(rule WT_intro)
       apply(simp del: outs_plus_\<I>)
       apply(rule eq_resource_on_trans[OF obsf_attach])
          apply(rule pfinite_intro WT_intro)+
       apply(rule obsf_resource_eq_\<I>_cong)
       apply(rule eq_resource_on_sym)
      by(simp add: attach_compose attach_converter_of_resource_conv_parallel_resource)(rule WT_intro)+

    have adv2: "advantage \<A>
     (obsf_resource ((1\<^sub>C |\<^sub>= sim2) |\<^sub>= (1\<^sub>C |\<^sub>= 1\<^sub>C) \<rhd> parallel_wiring \<rhd> real1 \<parallel> ideal2))
     (obsf_resource (parallel_wiring \<rhd> real1 \<parallel> real2)) \<le> adv2"
      unfolding advantage_def ideal2[symmetric] real2[symmetric] by(rule sec2.adv[unfolded advantage_def])(rule WT_intro)+

    have ideal1:
      "connect_obsf ?\<A>1 (obsf_resource (sim1 |\<^sub>= 1\<^sub>C \<rhd> ideal1)) =
     connect_obsf \<A> (obsf_resource ((sim1 |\<^sub>= sim2) |\<^sub>= (1\<^sub>C |\<^sub>= 1\<^sub>C) \<rhd> parallel_wiring \<rhd> ideal1 \<parallel> ideal2))"
    proof -
      have *:"((outs_\<I> \<I>_real1 <+> outs_\<I> \<I>_real2) <+> outs_\<I> \<I>_common1 <+> outs_\<I> \<I>_common2) \<turnstile>\<^sub>R
    (sim1 |\<^sub>= sim2) |\<^sub>= (1\<^sub>C |\<^sub>= 1\<^sub>C) \<rhd> parallel_wiring \<rhd> ideal1 \<parallel> ideal2 \<sim>
    parallel_wiring \<odot> (1\<^sub>C |\<^sub>\<propto> converter_of_resource (sim2 |\<^sub>= 1\<^sub>C \<rhd> ideal2)) \<rhd> sim1 |\<^sub>= 1\<^sub>C \<rhd> ideal1"
        by(auto simp add: le_\<I>_def comp_parallel_wiring' attach_compose attach_parallel2 attach_converter_of_resource_conv_parallel_resource2 intro: WT_intro)
      show ?thesis
        unfolding distinguish_attach[symmetric]
        apply(rule connect_eq_resource_cong)
          apply(rule WT_intro)
         apply(simp del: outs_plus_\<I>)
         apply(rule eq_resource_on_trans[OF obsf_attach])
            apply(rule pfinite_intro WT_intro)+
         apply(rule obsf_resource_eq_\<I>_cong)
         apply(rule eq_resource_on_sym)
        by(simp add: *, (rule WT_intro)+)
    qed

    have real1: "connect_obsf ?\<A>1 (obsf_resource real1) = connect_obsf \<A> (obsf_resource ((1\<^sub>C |\<^sub>= sim2) |\<^sub>= (1\<^sub>C |\<^sub>= 1\<^sub>C) \<rhd> parallel_wiring \<rhd> real1 \<parallel> ideal2))"
    proof -
      have *: "outs_\<I> ((\<I>_real1 \<oplus>\<^sub>\<I> \<I>_real2) \<oplus>\<^sub>\<I> (\<I>_common1 \<oplus>\<^sub>\<I> \<I>_common2)) \<turnstile>\<^sub>R
    parallel_wiring \<odot> ((1\<^sub>C |\<^sub>= 1\<^sub>C) |\<^sub>= sim2 |\<^sub>= 1\<^sub>C) \<rhd> real1 \<parallel> ideal2 \<sim>
    parallel_wiring \<odot> (1\<^sub>C |\<^sub>\<propto> converter_of_resource (sim2 |\<^sub>= 1\<^sub>C \<rhd> ideal2 )) \<rhd> real1"
        by(rule eq_resource_on_trans, rule eq_\<I>_attach_on[where conv'="parallel_wiring \<odot> (1\<^sub>C |\<^sub>= sim2 |\<^sub>= 1\<^sub>C)"]
            , (rule WT_intro)+, rule eq_\<I>_comp_cong, rule eq_\<I>_converter_mono)
          (auto simp add: le_\<I>_def attach_compose attach_converter_of_resource_conv_parallel_resource2 attach_parallel2
            intro: WT_intro parallel_converter2_eq_\<I>_cong parallel_converter2_id_id eq_\<I>_converter_reflI)

      show ?thesis
        unfolding distinguish_attach[symmetric]
        apply(rule connect_eq_resource_cong)
          apply(rule WT_intro)
         apply(simp del: outs_plus_\<I>)
         apply(rule eq_resource_on_trans[OF obsf_attach])
            apply(rule pfinite_intro WT_intro)+
         apply(rule obsf_resource_eq_\<I>_cong)
         apply(rule eq_resource_on_sym)
         apply(fold attach_compose)
         apply(subst comp_parallel_wiring)
         apply(rule *)
        apply(rule WT_intro)+
        done
    qed

    have adv1: "advantage \<A>
     (obsf_resource ((sim1 |\<^sub>= sim2) |\<^sub>= (1\<^sub>C |\<^sub>= 1\<^sub>C) \<rhd> parallel_wiring \<rhd> ideal1 \<parallel> ideal2))
     (obsf_resource ((1\<^sub>C |\<^sub>= sim2) |\<^sub>= (1\<^sub>C |\<^sub>= 1\<^sub>C) \<rhd> parallel_wiring \<rhd> real1 \<parallel> ideal2)) \<le> adv1"
      unfolding advantage_def ideal1[symmetric] real1[symmetric] by(rule sec1.adv[unfolded advantage_def])(rule WT_intro)+

    from adv1 adv2 show "advantage \<A> (obsf_resource ((sim1 |\<^sub>= sim2) |\<^sub>= (1\<^sub>C |\<^sub>= 1\<^sub>C) \<rhd> parallel_wiring \<rhd> ideal1 \<parallel> ideal2))
         (obsf_resource (parallel_wiring \<rhd> real1 \<parallel> real2)) \<le> adv1 + adv2"
      by(auto simp add: advantage_def)
  qed
qed

theorem parallel_constructive_security_obsf_fuse:
  assumes 1: "constructive_security_obsf real1 ideal1 sim1 (\<I>_real1_core \<oplus>\<^sub>\<I> \<I>_real1_rest) (\<I>_ideal1_core \<oplus>\<^sub>\<I> \<I>_ideal1_rest) (\<I>_common1_core \<oplus>\<^sub>\<I> \<I>_common1_rest) (absorb \<A> (obsf_converter (fused_wiring \<odot> parallel_converter 1\<^sub>C (converter_of_resource (sim2 |\<^sub>= 1\<^sub>C \<rhd> ideal2))))) adv1"
    (is "constructive_security_obsf _ _ _ ?\<I>_real1 ?\<I>_ideal1 ?\<I>_common1 ?\<A>1 _")
  assumes 2: "constructive_security_obsf real2 ideal2 sim2 (\<I>_real2_core \<oplus>\<^sub>\<I> \<I>_real2_rest) (\<I>_ideal2_core \<oplus>\<^sub>\<I> \<I>_ideal2_rest) (\<I>_common2_core \<oplus>\<^sub>\<I> \<I>_common2_rest) (absorb \<A> (obsf_converter (fused_wiring \<odot> parallel_converter (converter_of_resource real1) 1\<^sub>C))) adv2"
    (is "constructive_security_obsf _ _ _ ?\<I>_real2 ?\<I>_ideal2 ?\<I>_common2 ?\<A>2 _")
  shows "constructive_security_obsf (fused_wiring \<rhd> real1 \<parallel> real2) (fused_wiring \<rhd> ideal1 \<parallel> ideal2)
    (parallel_wiring \<odot> (sim1 |\<^sub>= sim2) \<odot> parallel_wiring)
    ((\<I>_real1_core \<oplus>\<^sub>\<I> \<I>_real2_core) \<oplus>\<^sub>\<I> (\<I>_real1_rest \<oplus>\<^sub>\<I> \<I>_real2_rest))
    ((\<I>_ideal1_core \<oplus>\<^sub>\<I> \<I>_ideal2_core) \<oplus>\<^sub>\<I> (\<I>_ideal1_rest \<oplus>\<^sub>\<I> \<I>_ideal2_rest))
    ((\<I>_common1_core \<oplus>\<^sub>\<I> \<I>_common2_core) \<oplus>\<^sub>\<I> (\<I>_common1_rest \<oplus>\<^sub>\<I> \<I>_common2_rest))
    \<A> (adv1 + adv2)"
proof -
  interpret sec1: constructive_security_obsf real1 ideal1 sim1 ?\<I>_real1 ?\<I>_ideal1 ?\<I>_common1 ?\<A>1 adv1 by fact
  interpret sec2: constructive_security_obsf real2 ideal2 sim2 ?\<I>_real2 ?\<I>_ideal2 ?\<I>_common2 ?\<A>2 adv2 by fact

  have aux1: "constructive_security_aux_obsf real1 ideal1 sim1 ?\<I>_real1 ?\<I>_ideal1 ?\<I>_common1 adv1" ..
  have aux2: "constructive_security_aux_obsf real2 ideal2 sim2 ?\<I>_real2 ?\<I>_ideal2 ?\<I>_common2 adv2" ..

  have sim: "constructive_security_sim_obsf (parallel_wiring \<rhd> real1 \<parallel> real2) (parallel_wiring \<rhd> ideal1 \<parallel> ideal2) (sim1 |\<^sub>= sim2)
      (?\<I>_real1 \<oplus>\<^sub>\<I> ?\<I>_real2) (?\<I>_common1 \<oplus>\<^sub>\<I> ?\<I>_common2)
      (absorb \<A> (obsf_converter (parallel_wiring |\<^sub>= parallel_wiring)))
      (adv1 + adv2)"
    if [WT_intro]: "exception_\<I> (((\<I>_real1_core \<oplus>\<^sub>\<I> \<I>_real2_core) \<oplus>\<^sub>\<I> (\<I>_real1_rest \<oplus>\<^sub>\<I> \<I>_real2_rest)) \<oplus>\<^sub>\<I> ((\<I>_common1_core \<oplus>\<^sub>\<I> \<I>_common2_core) \<oplus>\<^sub>\<I> (\<I>_common1_rest \<oplus>\<^sub>\<I> \<I>_common2_rest))) \<turnstile>g \<A> \<surd>"
  proof -
    interpret constructive_security_obsf
      "parallel_wiring \<rhd> real1 \<parallel> real2"
      "parallel_wiring \<rhd> ideal1 \<parallel> ideal2"
      "sim1 |\<^sub>= sim2"
      "?\<I>_real1 \<oplus>\<^sub>\<I> ?\<I>_real2" "?\<I>_ideal1 \<oplus>\<^sub>\<I> ?\<I>_ideal2" "?\<I>_common1 \<oplus>\<^sub>\<I> ?\<I>_common2"
      "absorb \<A> (obsf_converter (parallel_wiring |\<^sub>= parallel_wiring))"
      "adv1 + adv2"
      apply(rule parallel_constructive_security_obsf)
       apply(fold absorb_comp_converter)
       apply(rule constructive_security_obsf_absorb_cong[OF 1])
          apply(rule WT_intro)+
       apply(unfold fused_wiring_def comp_converter_assoc)
       apply(rule obsf_comp_converter)
         apply(rule WT_intro pfinite_intro)+
      apply(rule constructive_security_obsf_absorb_cong[OF 2])
         apply(rule WT_intro)+
      apply(subst fused_wiring_def)
      apply(unfold comp_converter_assoc)
      apply(rule obsf_comp_converter)
        apply(rule WT_intro pfinite_intro wiring_intro parallel_wiring_inverse)+
      done
    show ?thesis ..
  qed
  show ?thesis
    unfolding fused_wiring_def attach_compose
    apply(rule constructive_security_obsf_lifting[where w_adv_ideal_inv=parallel_wiring])
             apply(rule parallel_constructive_security_aux_obsf[OF aux1 aux2])
            apply(erule sim)
           apply(rule WT_intro pfinite_intro parallel_wiring_inverse)+
    done
qed

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 ExecConcrete
imports CorresXF
begin

definition "exec_transformed (sr :: ('s \<times> 't) set) (M :: ('t, 'r) nondet_monad) \<equiv>
    \<lambda>s. (\<Union> ((\<lambda>(r', t'). {(r, t). r = r' \<and> (t, t') \<in> sr}) ` (\<Union> (fst ` M ` {s'. (s, s') \<in> sr}))),
            True \<in> snd ` M ` {s'. (s, s') \<in> sr})"

lemma in_exec_transformed:
  "((r, s') \<in> fst (exec_transformed sr A s)) = (\<exists>t t'. (s, t) \<in> sr \<and>  (s', t') \<in> sr \<and> (r, t') \<in> fst (A t))"
  apply (clarsimp simp: exec_transformed_def)
  apply force
  done

lemma snd_exec_transformed:
  "snd (exec_transformed sr M s) = (\<exists>x. (s, x) \<in> sr \<and> snd (M x))"
  by (clarsimp simp: exec_transformed_def)

lemma exec_transformed_Id [simp]:
    "exec_transformed Id M = M"
  apply (auto simp: exec_transformed_def)
  done

lemma exec_transformed_valid_def:
    "\<lbrace> P \<rbrace> exec_transformed sr M \<lbrace> Q \<rbrace> = \<lbrace> \<lambda>s. \<exists>s'. (s', s) \<in> sr \<and> P s' \<rbrace> M \<lbrace> \<lambda>r s. \<forall>s'. (s', s) \<in> sr \<longrightarrow> Q r s' \<rbrace>"
  apply (rule iffI [rotated])
   apply (clarsimp simp: image_def split_def valid_def in_exec_transformed)
   apply force
  apply (clarsimp simp: image_def split_def valid_def exec_transformed_def)
  apply (erule allE, erule (1) impE)
  apply (case_tac "M s")
  apply (erule_tac allE, erule impE)
   by (auto intro!: exI) fastforce

lemma exec_transformed_wp [wp]:
    "\<lbrace> \<lambda>s. \<exists>s'. (s', s) \<in> sr \<and> P s' \<rbrace> M \<lbrace> \<lambda>r s. \<forall>s'. (s', s) \<in> sr \<longrightarrow> Q r s' \<rbrace> \<Longrightarrow> \<lbrace> P \<rbrace> exec_transformed sr M \<lbrace> Q \<rbrace>"
  apply (subst exec_transformed_valid_def)
  apply simp
  done

lemma exec_transformedE_wp [wp]:
  "\<lbrace> \<lambda>s. \<exists>s'. (s', s) \<in> sr \<and> P s' \<rbrace> M \<lbrace> \<lambda>r s. \<forall>s'. (s', s) \<in> sr \<longrightarrow> Q r s' \<rbrace>,\<lbrace> \<lambda>r s. \<forall>s'. (s', s) \<in> sr \<longrightarrow> E r s' \<rbrace>
      \<Longrightarrow> \<lbrace> P \<rbrace> exec_transformed sr M \<lbrace> Q \<rbrace>,\<lbrace> E \<rbrace>"
  apply (clarsimp simp: validE_def)
  apply (rule exec_transformed_wp)
  apply (clarsimp simp: valid_def split: sum.splits)
  apply force
  done

lemma exec_transformed_no_fail [wp]:
  "no_fail (\<lambda>s. \<exists>s'. (s', s) \<in> sr \<and> P s') M \<Longrightarrow> no_fail P (exec_transformed sr M)"
  apply (clarsimp simp: no_fail_def snd_exec_transformed)
  apply force
  done

lemmas exec_transformed_wp_nf [wp] =
  validNF [OF exec_transformed_wp exec_transformed_no_fail]

lemma exec_transformed_return_wp [wp]:
    "\<lbrace> \<lambda>s. \<forall>s''. (\<exists>s'. (s, s') \<in> sr \<and> (s'', s') \<in> sr) \<longrightarrow> P a s'' \<rbrace> exec_transformed sr (return a) \<lbrace> P \<rbrace>"
  including no_pre
  apply wp
  apply clarsimp
  apply force
  done

lemma exec_transformed_returnOk_wp [wp]:
    "\<lbrace> \<lambda>s. \<forall>s''. (\<exists>s'. (s, s') \<in> sr \<and> (s'', s') \<in> sr) \<longrightarrow> P a s'' \<rbrace> exec_transformed sr (returnOk a) \<lbrace> P \<rbrace>,\<lbrace> E \<rbrace>"
  including no_pre
  apply wp
  apply clarsimp
  apply force
  done

lemma exec_transformed_fail_wp_nf [wp]:
    "\<lbrace> \<lambda>s. \<not> (\<exists>s'. (s, s') \<in> sr) \<rbrace> exec_transformed sr fail \<lbrace> P \<rbrace>!"
  apply wp
  apply (clarsimp simp: fail_def no_fail_def)
  apply force
  done

lemma exec_transformed_fail_wp [wp]:
    "\<lbrace> \<lambda>_. True \<rbrace> exec_transformed st fail \<lbrace> P \<rbrace>"
  including no_pre by wp

(*
 * Execute the given monad with a concrete state.
 *
 * In particular, we non-determinstically select a concrete state that maps
 * to the current abstract state, execute @{term M}, and then map the resulting
 * states back into the abstract universe.
 *)
definition "exec_concrete (st :: 't \<Rightarrow> 's)  (M :: ('t, 'r) nondet_monad) \<equiv>
       \<lambda>s. ({(r, t). \<exists>s' t'. s = st s' \<and> t = st t' \<and> (r, t') \<in> fst (M s')},
            \<exists>s'. s = st s' \<and> snd (M s'))"

lemma "exec_concrete st M = exec_transformed {(s, t). st t = s} M"
  apply (rule ext)
  apply (clarsimp simp: exec_concrete_def exec_transformed_def)
  apply force
  done

lemma in_exec_concrete [monad_eq]:
  "((r, s') \<in> fst (exec_concrete st A s)) = (\<exists>t t'. st t = s \<and> st t' = s' \<and> (r, t') \<in> fst (A t))"
  apply (clarsimp simp: exec_concrete_def split_def image_def)
  apply force
  done

lemma snd_exec_concrete [monad_eq]:
  "snd (exec_concrete st M s) = (\<exists>x. st x = s \<and> snd (M x))"
  by (fastforce simp: exec_concrete_def)

lemma exec_concrete_id [simp]:
    "exec_concrete id M = M"
    "exec_concrete (\<lambda>a. a) M = M"
  apply (auto simp: exec_concrete_def)
  done

lemma exec_concrete_wp [wp]:
    "\<lbrace> \<lambda>s. P (st s) \<rbrace> M \<lbrace> \<lambda>r s. Q r (st s) \<rbrace> \<Longrightarrow> \<lbrace> P \<rbrace> exec_concrete st M \<lbrace> Q \<rbrace>"
  apply (clarsimp simp: image_def split_def valid_def in_exec_concrete)
  apply force
  done

lemma exec_concreteE_wp [wp]:
  "\<lbrace> \<lambda>s. P (st s) \<rbrace> M \<lbrace> \<lambda>r s. Q r (st s) \<rbrace>,\<lbrace> \<lambda>r s. E r (st s) \<rbrace>
      \<Longrightarrow> \<lbrace> P \<rbrace> exec_concrete st M \<lbrace> Q \<rbrace>,\<lbrace> E \<rbrace>"
  apply (clarsimp simp: validE_def)
  apply (rule exec_concrete_wp)
  apply simp
  done

lemma exec_concrete_no_fail [wp]:
  "no_fail (\<lambda>s. P (st s)) M \<Longrightarrow> no_fail P (exec_concrete st M)"
  apply (clarsimp simp: no_fail_def snd_exec_concrete)
  done

lemma exec_concrete_wp_nf [wp]:
    "\<lbrace> \<lambda>s. P (st s) \<rbrace> M \<lbrace> \<lambda>r s. Q r (st s) \<rbrace>! \<Longrightarrow> \<lbrace> P \<rbrace> exec_concrete st M \<lbrace> Q \<rbrace>!"
  apply rule
   apply (rule exec_concrete_wp)
   apply (erule validNF_valid)
  including no_pre
  apply wp
  apply (erule validNF_no_fail)
  done

lemma exec_concrete_return_wp [wp]:
    "\<lbrace> P a \<rbrace> exec_concrete st (return a) \<lbrace> P \<rbrace>"
  by wp

lemma exec_concrete_returnOk_wp [wp]:
    "\<lbrace> P a \<rbrace> exec_concrete st (returnOk a) \<lbrace> P \<rbrace>,\<lbrace> E \<rbrace>"
  by wp

lemma exec_concrete_return_wp_nf [wp]:
    "\<lbrace> P a \<rbrace> exec_concrete st (return a) \<lbrace> P \<rbrace>!"
  by wp

lemma exec_concrete_fail_wp_nf [wp]:
    "\<lbrace> \<lambda>s. False \<rbrace> exec_concrete st fail \<lbrace> P \<rbrace>!"
  by wp

lemma exec_concrete_fail_wp [wp]:
    "\<lbrace> \<lambda>_. True \<rbrace> exec_concrete st fail \<lbrace> P \<rbrace>"
  by wp

lemma corresXF_simple_exec_concrete:
    "corresXF_simple st (\<lambda>r s. r) P (exec_concrete st M) M"
  apply (clarsimp simp: corresXF_simple_def  image_def split_def
      snd_exec_concrete in_exec_concrete)
  apply force
  done

lemma corresXF_exec_concrete_self:
    "corresXF st (\<lambda>r s. r) (\<lambda>r s. r) P (exec_concrete st M) M"
  apply (subst corresXF_simple_corresXF [symmetric])
  apply clarsimp
  apply (rule corresXF_simple_exec_concrete)
  done

lemma corresXF_exec_concrete [intro?]:
  "corresXF id ret_xf ex_xf P A C \<Longrightarrow> corresXF st ret_xf ex_xf P (exec_concrete st A) C"
  apply (clarsimp simp: corresXF_def exec_concrete_def split: sum.splits)
  apply safe
    apply (clarsimp simp: image_def split_def)
    apply force
   apply (clarsimp simp: image_def split_def)
   apply force
  done

lemma exec_concrete_empty_fail [wp]:
  "\<lbrakk> empty_fail M; \<forall>s. \<exists>x. st x = s \<rbrakk> \<Longrightarrow> empty_fail (exec_concrete st M)"
  apply (subst empty_fail_def)
  apply (clarsimp simp: exec_concrete_def)
  apply (metis empty_failD2  surjective_pairing)
  done

(*
 * Execute the given monad in a modified state.
 *)
definition "exec_abstract st M \<equiv>
       \<lambda>s'. ({(r', t'). \<exists>t. t = st t' \<and> (r', t) \<in> fst (M (st s'))},
            \<exists>s. s = st s' \<and> snd (M (st s')))"

lemma exec_abstract_transformed:
    "exec_abstract st M = exec_transformed {(s, t). t = st s} M"
  apply (rule ext)
  apply (clarsimp simp: exec_transformed_def exec_abstract_def)
  apply blast
  done

lemma in_exec_abstract [monad_eq]:
  "((r, t) \<in> fst (exec_abstract st A s)) = (\<exists>t'. st t = t' \<and> (r, t') \<in> fst (A (st s)))"
  by (clarsimp simp: exec_abstract_def split_def image_def)

lemma snd_exec_abstract [monad_eq]:
  "snd (exec_abstract st M s) = (snd (M (st s)))"
  by (clarsimp simp: exec_abstract_def)

lemma exec_abstract_id [simp]:
    "exec_abstract id M = M"
    "exec_abstract (\<lambda>a. a) M = M"
  apply (auto simp: exec_abstract_def)
  done

lemma exec_abstract_valid_def:
    "\<lbrace> P \<rbrace> exec_abstract st M \<lbrace> Q \<rbrace> = \<lbrace> \<lambda>s. \<exists>s'. st s' = s \<and> P s' \<rbrace> M \<lbrace> \<lambda>r s. \<forall>t. st t = s \<longrightarrow> Q r t \<rbrace>"
  apply (subst exec_abstract_transformed)
  apply (subst exec_transformed_valid_def)
  apply (fastforce simp: valid_def)
  done

lemma exec_abstract_wp [wp]:
    "\<lbrakk> \<lbrace> P \<rbrace> M \<lbrace> \<lambda>r s. \<forall>t. st t = s \<longrightarrow> Q r t \<rbrace>  \<rbrakk>
              \<Longrightarrow> \<lbrace> \<lambda>s. P (st s) \<rbrace> exec_abstract st M \<lbrace> Q \<rbrace>"
  apply (subst exec_abstract_valid_def)
  apply (clarsimp simp: valid_def)
  apply force
  done

lemma exec_abstractE_wp [wp]:
    "\<lbrakk> \<lbrace> P \<rbrace> M \<lbrace> \<lambda>r s. \<forall>t. st t = s \<longrightarrow> Q r t \<rbrace>,\<lbrace> \<lambda>r s. \<forall>t. st t = s \<longrightarrow> E r t \<rbrace>  \<rbrakk>
              \<Longrightarrow> \<lbrace> \<lambda>s. P (st s) \<rbrace> exec_abstract st M \<lbrace> Q \<rbrace>,\<lbrace> E \<rbrace>"
  apply (clarsimp simp: validE_def)
  apply (rule exec_abstract_wp)
  apply (clarsimp simp: valid_def split: sum.splits)
  apply force
  done

lemma exec_abstract_no_fail [wp]:
  "no_fail (\<lambda>s. \<exists>t. st t = s \<and> P t) M \<Longrightarrow> no_fail P (exec_abstract st M)"
  apply (clarsimp simp: no_fail_def snd_exec_abstract)
  apply force
  done

lemma exec_abstract_wp_nf [wp]:
    "\<lbrakk> \<lbrace> P \<rbrace> M \<lbrace> \<lambda>r s. \<forall>t. st t = s \<longrightarrow> Q r t \<rbrace>!  \<rbrakk>
              \<Longrightarrow> \<lbrace> \<lambda>s. P (st s) \<rbrace> exec_abstract st M \<lbrace> Q \<rbrace>!"
  apply rule
   apply (rule exec_abstract_wp)
   apply (erule validNF_valid)
  apply (rule exec_abstract_no_fail)
  apply (rule validNF_no_fail)
  apply (erule validNF_weaken_pre)
  apply force
  done

lemma exec_abstract_return_wp [wp]:
    "\<lbrace> \<lambda>s. \<forall>t. st s = st t \<longrightarrow> P a t \<rbrace> exec_abstract st (return a) \<lbrace> P \<rbrace>"
  apply wp
  apply clarsimp
  done

lemma exec_abstract_returnOk_wp [wp]:
    "\<lbrace> \<lambda>s. \<forall>t. st s = st t \<longrightarrow> P a t \<rbrace> exec_abstract st (returnOk a) \<lbrace> P \<rbrace>,\<lbrace> E \<rbrace>"
  apply wp
  apply clarsimp
  done

lemma exec_abstract_return_wp_nf [wp]:
    "\<lbrace> \<lambda>s. \<forall>t. st s = st t \<longrightarrow> P a t \<rbrace> exec_abstract st (return a) \<lbrace> P \<rbrace>!"
  apply wp
  apply clarsimp
  done

lemma exec_abstract_fail_wp_nf [wp]:
    "\<lbrace> \<lambda>s. False \<rbrace> exec_abstract st fail \<lbrace> P \<rbrace>!"
  apply wp
  apply clarsimp
  done

lemma exec_abstract_fail_wp [wp]:
    "\<lbrace> \<lambda>_. True \<rbrace> exec_abstract st fail \<lbrace> P \<rbrace>"
  by wp

lemma corresXF_simple_exec_abstract:
    "corresXF_simple st (\<lambda>r s. r) P M (exec_abstract st M)"
  apply (clarsimp simp: corresXF_simple_def  image_def split_def
      snd_exec_abstract in_exec_abstract)
  done

lemma corresXF_exec_abstract_self:
    "corresXF st (\<lambda>r s. r) (\<lambda>r s. r) P M (exec_abstract st M)"
  apply (subst corresXF_simple_corresXF [symmetric])
  apply clarsimp
  apply (rule corresXF_simple_exec_abstract)
  done

lemma corresXF_exec_abstract [intro?]:
  "corresXF st ret_xf ex_xf P A C \<Longrightarrow> corresXF id ret_xf ex_xf P (exec_abstract st A) C"
  apply (clarsimp simp: corresXF_def exec_abstract_def split: sum.splits)
  done

lemma exec_abstract_empty_fail [wp]:
  "\<lbrakk> empty_fail M; \<forall>s. \<exists>x. st x = s \<rbrakk> \<Longrightarrow> empty_fail (exec_abstract st M)"
  apply (clarsimp simp: empty_fail_def exec_abstract_def)
  apply (metis nonemptyE surjective_pairing)
  done

end


theory TopoS_Interface_impl
imports "Lib/FiniteGraph" "Lib/FiniteListGraph" TopoS_Interface TopoS_Helper
begin

section{*Executable Implementation with Lists*}
  text {*Correspondence List Implementation and set Specification*}

  subsection{*Abstraction from list implementation to set specification*}
  text{*Nomenclature: @{text "_spec"} is the specification, @{text "_impl"} the corresponding implementation.*}

  text{*@{text "_spec"} and @{text "_impl"} only need to comply for @{const valid_graph}s.
   We will always require the stricter @{const valid_list_graph}, which implies @{const valid_graph}.
  *}
  lemma "valid_list_graph G \<Longrightarrow> valid_graph (list_graph_to_graph G)"
    by %invisible (metis valid_list_graph_def valid_list_graph_iff_valid_graph)

  locale TopoS_List_Impl =
    fixes default_node_properties :: "'a" ("\<bottom>")
    and sinvar_spec::"('v::vertex) graph \<Rightarrow> ('v::vertex \<Rightarrow> 'a) \<Rightarrow> bool"
    and sinvar_impl::"('v::vertex) list_graph \<Rightarrow> ('v::vertex \<Rightarrow> 'a) \<Rightarrow> bool"
    and verify_globals_spec::"('v::vertex) graph \<Rightarrow> ('v::vertex \<Rightarrow> 'a) \<Rightarrow> 'b \<Rightarrow> bool"
    and verify_globals_impl::"('v::vertex) list_graph \<Rightarrow> ('v::vertex \<Rightarrow> 'a) \<Rightarrow> 'b \<Rightarrow> bool"
    and receiver_violation :: "bool"
    and offending_flows_impl::"('v::vertex) list_graph \<Rightarrow> ('v \<Rightarrow> 'a) \<Rightarrow> ('v \<times> 'v) list list"
    and node_props_impl::"('v::vertex, 'a, 'b) TopoS_Params \<Rightarrow> ('v \<Rightarrow> 'a)"
    and eval_impl::"('v::vertex) list_graph \<Rightarrow> ('v, 'a, 'b)TopoS_Params \<Rightarrow> bool"
    assumes
      spec: "SecurityInvariant sinvar_spec default_node_properties receiver_violation" --"specification is valid"
    and
      sinvar_spec_impl: "valid_list_graph G \<Longrightarrow>
        (sinvar_spec (list_graph_to_graph G) nP) = (sinvar_impl G nP)"
    and
      verify_globals_spec_impl: "valid_list_graph G \<Longrightarrow>
        (verify_globals_spec (list_graph_to_graph G) nP gP) = (verify_globals_impl G nP gP)"
    and
      offending_flows_spec_impl: "valid_list_graph G \<Longrightarrow>
      (SecurityInvariant_withOffendingFlows.set_offending_flows sinvar_spec (list_graph_to_graph G) nP) =
      set`set (offending_flows_impl G nP)"
    and
      node_props_spec_impl:
     "SecurityInvariant.node_props_formaldef default_node_properties P = node_props_impl P"
    and
      eval_spec_impl:
     "(distinct (nodesL G) \<and> distinct (edgesL G) \<and>
     SecurityInvariant.eval sinvar_spec verify_globals_spec default_node_properties (list_graph_to_graph G) P ) =
     (eval_impl G P)"

  subsection {* Security Invariants Packed*}

  text {* We pack all necessary functions and properties of a security invariant in a struct-like data structure.*}
  record ('v::vertex, 'a, 'b) TopoS_packed =
    nm_name :: "string"
    nm_receiver_violation :: "bool"
    nm_default :: "'a"
    nm_sinvar::"('v::vertex) list_graph \<Rightarrow> ('v \<Rightarrow> 'a) \<Rightarrow> bool"
    nm_verify_globals::"('v::vertex) list_graph \<Rightarrow> ('v \<Rightarrow> 'a) \<Rightarrow> 'b \<Rightarrow> bool"
    nm_offending_flows::"('v::vertex) list_graph \<Rightarrow> ('v \<Rightarrow> 'a) \<Rightarrow> ('v \<times> 'v) list list"
    nm_node_props::"('v::vertex, 'a, 'b) TopoS_Params \<Rightarrow> ('v \<Rightarrow> 'a)"
    nm_eval::"('v::vertex) list_graph \<Rightarrow> ('v, 'a, 'b)TopoS_Params \<Rightarrow> bool"

   text{*The packed list implementation must comply with the formal definition. *}
   locale TopoS_modelLibrary =
    fixes m :: "('v::vertex, 'a, 'b) TopoS_packed" -- "concrete model implementation"
    and sinvar_spec::"('v::vertex) graph \<Rightarrow> ('v::vertex \<Rightarrow> 'a) \<Rightarrow> bool" --"specification"
    and verify_globals_spec::"('v::vertex) graph \<Rightarrow> ('v::vertex \<Rightarrow> 'a) \<Rightarrow> 'b \<Rightarrow> bool" --"specification"
    assumes
       name_not_empty: "length (nm_name m) > 0"
     and
       impl_spec: "TopoS_List_Impl
        (nm_default m)
        sinvar_spec
        (nm_sinvar m)
        verify_globals_spec
        (nm_verify_globals m)
        (nm_receiver_violation m)
        (nm_offending_flows m)
        (nm_node_props m)
        (nm_eval m)"

  subsection{*Helpful Lemmata*}

  text{*show that @{term "sinvar"} complies*}
  lemma TopoS_eval_impl_proofrule:
    assumes inst: "SecurityInvariant sinvar_spec default_node_properties receiver_violation"
    assumes ev: "\<And>nP. valid_list_graph G \<Longrightarrow> sinvar_spec (list_graph_to_graph G) nP = sinvar_impl G nP"
    assumes ver: "\<And> nP gP. valid_list_graph G \<Longrightarrow> verify_globals_spec (list_graph_to_graph G) nP gP = verify_globals_impl G nP gP"
    shows "
      (distinct (nodesL G) \<and> distinct (edgesL G) \<and> SecurityInvariant.eval sinvar_spec verify_globals_spec default_node_properties (list_graph_to_graph G) P) =
      (valid_list_graph G \<and> verify_globals_impl G (SecurityInvariant.node_props default_node_properties P) (model_global_properties P) \<and>
       sinvar_impl G (SecurityInvariant.node_props default_node_properties P))"
  proof (cases "valid_list_graph G")
    case True
    hence "(verify_globals_spec (list_graph_to_graph G) (SecurityInvariant.node_props default_node_properties P) (model_global_properties P) \<and>
       sinvar_spec (list_graph_to_graph G) (SecurityInvariant.node_props default_node_properties P)) =
      (verify_globals_impl G (SecurityInvariant.node_props default_node_properties P) (model_global_properties P) \<and>
       sinvar_impl G (SecurityInvariant.node_props default_node_properties P))"
      using ev ver by blast

    with inst show ?thesis
      unfolding valid_list_graph_def
      by (simp add: valid_list_graph_iff_valid_graph SecurityInvariant.eval_def)
  next
    case False
    hence "(distinct (nodesL G) \<and> distinct (edgesL G) \<and> valid_list_graph_axioms G) = False"
      unfolding valid_list_graph_def by blast
    with False show ?thesis
      unfolding SecurityInvariant.eval_def[OF inst]
      by (fastforce simp: valid_list_graph_iff_valid_graph)
  qed

subsection {*Helper lemmata*}

  text{* Provide @{term sinvar} function and get back a function that computes the list of offending flows

  Exponential time!
  *}
  definition Generic_offending_list:: "('v list_graph \<Rightarrow> ('v \<Rightarrow> 'a) \<Rightarrow> bool )\<Rightarrow> 'v list_graph \<Rightarrow> ('v \<Rightarrow> 'a) \<Rightarrow> ('v \<times> 'v) list list" where
    "Generic_offending_list sinvar G nP = [f \<leftarrow> (sublists (edgesL G)).
    (\<not> sinvar G nP \<and> sinvar (FiniteListGraph.delete_edges G f) nP) \<and>
      (\<forall>(e1, e2)\<in>set f. \<not> sinvar (add_edge e1 e2 (FiniteListGraph.delete_edges G f)) nP)]"

  text{*proof rule: if @{term sinvar} complies, @{const Generic_offending_list} complies *}
  lemma Generic_offending_list_correct:
    assumes valid: "valid_list_graph G"
    assumes spec_impl: "\<And>G nP. valid_list_graph G \<Longrightarrow> sinvar_spec (list_graph_to_graph G) nP = sinvar_impl G nP"
    shows "SecurityInvariant_withOffendingFlows.set_offending_flows sinvar_spec (list_graph_to_graph G) nP =
      set`set( Generic_offending_list sinvar_impl G nP )"
  proof -
    have "\<And> P G. set ` {x \<in> set (sublists (edgesL G)). P G (set x)} = {x \<in> set ` set (sublists (edgesL G)). P G (x)}"
      by fastforce
    hence subset_sublists_filter: "\<And> G P. {f. f \<subseteq> edges (list_graph_to_graph G) \<and> P G f}
    = set ` set [f\<leftarrow>sublists (edgesL G) . P G (set f)]"
      unfolding list_graph_to_graph_def
      by (auto simp: sublists_powset)

    from valid delete_edges_valid have "\<forall>f. valid_list_graph(FiniteListGraph.delete_edges G f)" by fast
    with spec_impl[symmetric] FiniteListGraph.delete_edges_correct[of "G"] have impl_spec_delete:
      "\<forall>f. sinvar_impl (FiniteListGraph.delete_edges G f) nP =
          sinvar_spec (FiniteGraph.delete_edges (list_graph_to_graph G) (set f)) nP" by simp

    from spec_impl[OF valid, symmetric] have impl_spec_not:
      "(\<not> sinvar_impl G nP) = (\<not> sinvar_spec (list_graph_to_graph G) nP)" by auto

    from spec_impl[symmetric, OF FiniteListGraph.add_edge_valid[OF FiniteListGraph.delete_edges_valid[OF valid]]] have impl_spec_allE:
    "\<forall> e1 e2 E. sinvar_impl (FiniteListGraph.add_edge e1 e2 (FiniteListGraph.delete_edges G E)) nP =
    sinvar_spec (list_graph_to_graph (FiniteListGraph.add_edge e1 e2 (FiniteListGraph.delete_edges G E))) nP" by simp

    have list_graph: "\<And> e1 e2 G f. (list_graph_to_graph (FiniteListGraph.add_edge e1 e2 (FiniteListGraph.delete_edges G f))) =
      (FiniteGraph.add_edge e1 e2 (FiniteGraph.delete_edges (list_graph_to_graph G) (set f)))"
    by(simp add: FiniteListGraph.add_edge_correct FiniteListGraph.delete_edges_correct)

    show ?thesis
      unfolding SecurityInvariant_withOffendingFlows.set_offending_flows_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_min_set_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_def
      Generic_offending_list_def
        apply(subst impl_spec_delete)
        apply(subst impl_spec_not)
        apply(subst impl_spec_allE)
        apply(subst list_graph)
        apply(rule subset_sublists_filter)
        done
  qed

  lemma all_edges_list_I: "P (list_graph_to_graph G) = Pl G \<Longrightarrow>
    (\<forall>(e1, e2)\<in> (edges (list_graph_to_graph G)). P (list_graph_to_graph G) e1 e2) = (\<forall>(e1, e2)\<in>set (edgesL G). Pl G e1 e2)"
  unfolding list_graph_to_graph_def
  by simp

  lemma all_nodes_list_I: "P (list_graph_to_graph G) = Pl G \<Longrightarrow>
    (\<forall>n \<in> (nodes (list_graph_to_graph G)). P (list_graph_to_graph G) n) = (\<forall> n \<in>set (nodesL G). Pl G n)"
  unfolding list_graph_to_graph_def
  by simp

(*TODO: this should be a header of TopoS_Libary. The header should be printed BEFORE the imports are processed. *)
section{*Security Invariant Library*}
(*The SINVAR_* theory files all use the "subsection" command. Here is the top-section.*)

end


(*  Title:      HOL/Auth/n_german_lemma_on_inv__49.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_german Protocol Case Study*}*)

theory n_german_lemma_on_inv__49 imports n_german_base
begin
section{*All lemmas on causal relation between inv__49 and some rule r*}
lemma n_SendInvAckVsinv__49:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_SendInvAck  i)" and
a2: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__49  p__Inv0 p__Inv2)"
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_SendInvAck  i" apply fastforce done
from a2 obtain p__Inv0 p__Inv2 where a2:"p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__49  p__Inv0 p__Inv2" apply fastforce done
have "(i=p__Inv2)\<or>(i=p__Inv0)\<or>(i~=p__Inv0\<and>i~=p__Inv2)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv2)"
  have "?P3 s"
  apply (cut_tac a1 a2 b1, simp, rule_tac x="(neg (andForm (andForm (eqn (IVar (Field (Para (Ident ''Chan3'') p__Inv0) ''Cmd'')) (Const InvAck)) (eqn (IVar (Ident ''ExGntd'')) (Const true))) (eqn (IVar (Field (Para (Ident ''Chan2'') p__Inv2) ''Cmd'')) (Const Inv))))" in exI, auto) done
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i=p__Inv0)"
  have "?P3 s"
  apply (cut_tac a1 a2 b1, simp, rule_tac x="(neg (andForm (andForm (eqn (IVar (Field (Para (Ident ''Chan3'') p__Inv2) ''Cmd'')) (Const InvAck)) (eqn (IVar (Ident ''ExGntd'')) (Const true))) (eqn (IVar (Field (Para (Ident ''Chan2'') p__Inv0) ''Cmd'')) (Const Inv))))" in exI, auto) done
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv0\<and>i~=p__Inv2)"
  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__49:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_RecvInvAck  i)" and
a2: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__49  p__Inv0 p__Inv2)"
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__Inv0 p__Inv2 where a2:"p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__49  p__Inv0 p__Inv2" apply fastforce done
have "(i=p__Inv2)\<or>(i=p__Inv0)\<or>(i~=p__Inv0\<and>i~=p__Inv2)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv2)"
  have "((formEval (eqn (IVar (Ident ''ExGntd'')) (Const true)) s))\<or>((formEval (neg (eqn (IVar (Ident ''ExGntd'')) (Const true))) s))" by auto
  moreover {
    assume c1: "((formEval (eqn (IVar (Ident ''ExGntd'')) (Const true)) s))"
    have "?P1 s"
    proof(cut_tac a1 a2 b1 c1, auto) qed
    then have "invHoldForRule s f r (invariants N)" by auto
  }
  moreover {
    assume c1: "((formEval (neg (eqn (IVar (Ident ''ExGntd'')) (Const true))) s))"
    have "?P1 s"
    proof(cut_tac a1 a2 b1 c1, auto) qed
    then have "invHoldForRule s f r (invariants N)" by auto
  }
  ultimately have "invHoldForRule s f r (invariants N)" by satx
}
moreover {
  assume b1: "(i=p__Inv0)"
  have "((formEval (eqn (IVar (Ident ''ExGntd'')) (Const true)) s))\<or>((formEval (neg (eqn (IVar (Ident ''ExGntd'')) (Const true))) s))" by auto
  moreover {
    assume c1: "((formEval (eqn (IVar (Ident ''ExGntd'')) (Const true)) s))"
    have "?P1 s"
    proof(cut_tac a1 a2 b1 c1, auto) qed
    then have "invHoldForRule s f r (invariants N)" by auto
  }
  moreover {
    assume c1: "((formEval (neg (eqn (IVar (Ident ''ExGntd'')) (Const true))) s))"
    have "?P1 s"
    proof(cut_tac a1 a2 b1 c1, auto) qed
    then have "invHoldForRule s f r (invariants N)" by auto
  }
  ultimately have "invHoldForRule s f r (invariants N)" by satx
}
moreover {
  assume b1: "(i~=p__Inv0\<and>i~=p__Inv2)"
  have "((formEval (eqn (IVar (Ident ''ExGntd'')) (Const true)) s))\<or>((formEval (neg (eqn (IVar (Ident ''ExGntd'')) (Const true))) s))" by auto
  moreover {
    assume c1: "((formEval (eqn (IVar (Ident ''ExGntd'')) (Const true)) s))"
    have "?P1 s"
    proof(cut_tac a1 a2 b1 c1, auto) qed
    then have "invHoldForRule s f r (invariants N)" by auto
  }
  moreover {
    assume c1: "((formEval (neg (eqn (IVar (Ident ''ExGntd'')) (Const true))) s))"
    have "?P2 s"
    proof(cut_tac a1 a2 b1 c1, auto) qed
    then have "invHoldForRule s f r (invariants N)" by auto
  }
  ultimately have "invHoldForRule s f r (invariants N)" by satx
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_SendGntEVsinv__49:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_SendGntE N i)" and
a2: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__49  p__Inv0 p__Inv2)"
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__Inv0 p__Inv2 where a2:"p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__49  p__Inv0 p__Inv2" apply fastforce done
have "(i=p__Inv2)\<or>(i=p__Inv0)\<or>(i~=p__Inv0\<and>i~=p__Inv2)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv2)"
  have "?P3 s"
  apply (cut_tac a1 a2 b1, simp, rule_tac x="(neg (andForm (eqn (IVar (Para (Ident ''ShrSet'') p__Inv0)) (Const false)) (eqn (IVar (Field (Para (Ident ''Chan3'') p__Inv0) ''Cmd'')) (Const InvAck))))" in exI, auto) done
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i=p__Inv0)"
  have "?P3 s"
  apply (cut_tac a1 a2 b1, simp, rule_tac x="(neg (andForm (eqn (IVar (Para (Ident ''ShrSet'') p__Inv0)) (Const false)) (eqn (IVar (Field (Para (Ident ''Chan3'') p__Inv0) ''Cmd'')) (Const InvAck))))" in exI, auto) done
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv0\<and>i~=p__Inv2)"
  have "?P3 s"
  apply (cut_tac a1 a2 b1, simp, rule_tac x="(neg (andForm (eqn (IVar (Para (Ident ''ShrSet'') p__Inv0)) (Const false)) (eqn (IVar (Field (Para (Ident ''Chan3'') p__Inv0) ''Cmd'')) (Const InvAck))))" in exI, auto) done
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_SendReqE__part__1Vsinv__49:
  assumes a1: "\<exists> i. i\<le>N\<and>r=n_SendReqE__part__1  i" and
  a2: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__49  p__Inv0 p__Inv2)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

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

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

lemma n_SendGntSVsinv__49:
  assumes a1: "\<exists> i. i\<le>N\<and>r=n_SendGntS  i" and
  a2: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__49  p__Inv0 p__Inv2)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

lemma n_RecvReqEVsinv__49:
  assumes a1: "\<exists> i. i\<le>N\<and>r=n_RecvReqE N i" and
  a2: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__49  p__Inv0 p__Inv2)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

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

lemma n_SendInv__part__0Vsinv__49:
  assumes a1: "\<exists> i. i\<le>N\<and>r=n_SendInv__part__0  i" and
  a2: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__49  p__Inv0 p__Inv2)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

lemma n_SendReqE__part__0Vsinv__49:
  assumes a1: "\<exists> i. i\<le>N\<and>r=n_SendReqE__part__0  i" and
  a2: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__49  p__Inv0 p__Inv2)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

lemma n_SendInv__part__1Vsinv__49:
  assumes a1: "\<exists> i. i\<le>N\<and>r=n_SendInv__part__1  i" and
  a2: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__49  p__Inv0 p__Inv2)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

lemma n_SendReqSVsinv__49:
  assumes a1: "\<exists> i. i\<le>N\<and>r=n_SendReqS  i" and
  a2: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__49  p__Inv0 p__Inv2)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

lemma n_RecvReqSVsinv__49:
  assumes a1: "\<exists> i. i\<le>N\<and>r=n_RecvReqS N i" and
  a2: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__49  p__Inv0 p__Inv2)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

end


(*  Title:      HOL/Auth/n_german_lemma_inv__46_on_rules.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_german Protocol Case Study*}

theory n_german_lemma_inv__46_on_rules imports n_german_lemma_on_inv__46
begin
section{*All lemmas on causal relation between inv__46*}
lemma lemma_inv__46_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv3 p__Inv4. p__Inv3\<le>N\<and>p__Inv4\<le>N\<and>p__Inv3~=p__Inv4\<and>f=inv__46  p__Inv3 p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> j. j\<le>N\<and>r=n_SendReqS  j)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqEI  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqES  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvReq N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInvE  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInvS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInvAck  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvInvAck  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendGntS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendGntE N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvGntS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvGntE  i)\<or>
    (\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d)"
  apply (cut_tac b1, auto) done
    moreover {
      assume d1: "(\<exists> j. j\<le>N\<and>r=n_SendReqS  j)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendReqSVsinv__46) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendReqEI  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendReqEIVsinv__46) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendReqES  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendReqESVsinv__46) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvReq N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvReqVsinv__46) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendInvE  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendInvEVsinv__46) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendInvS  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendInvSVsinv__46) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendInvAck  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendInvAckVsinv__46) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvInvAck  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvInvAckVsinv__46) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendGntS  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendGntSVsinv__46) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendGntE N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendGntEVsinv__46) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvGntS  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvGntSVsinv__46) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvGntE  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvGntEVsinv__46) done
    }

    moreover {
      assume d1: "(\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_StoreVsinv__46) done
    }

  ultimately show "invHoldForRule s f r (invariants N)"
  by satx
qed

end


(*  Title:      JinjaThreads/BV/EffectMono.thy
    Author:     Gerwin Klein, Andreas Lochbihler
*)

section \<open>Monotonicity of eff and app\<close>

theory EffectMono
imports
  Effect
begin

declare not_Err_eq [iff]

declare widens_trans[trans]

lemma app\<^sub>i_mono:
  assumes wf: "wf_prog p P"
  assumes less: "P \<turnstile> \<tau> \<le>\<^sub>i \<tau>'"
  shows "app\<^sub>i (i,P,mxs,mpc,rT,\<tau>') \<Longrightarrow> app\<^sub>i (i,P,mxs,mpc,rT,\<tau>)"
proof -
  assume app: "app\<^sub>i (i,P,mxs,mpc,rT,\<tau>')"

  obtain ST LT ST' LT' where
    [simp]: "\<tau> = (ST,LT)" and
    [simp]: "\<tau>' = (ST',LT')"
    by (cases \<tau>, cases \<tau>')

  from less have [simp]: "size ST = size ST'" and [simp]: "size LT = size LT'"
    by (auto dest: list_all2_lengthD)

  note [iff] = list_all2_Cons2 widen_Class
  note [simp] = fun_of_def

  from app less show "app\<^sub>i (i,P,mxs,mpc,rT,\<tau>)"
  proof (cases i)
    case Load
    with app less show ?thesis by (auto dest!: list_all2_nthD)
  next
    case (Invoke M n)
    with app have n: "n < size ST'" by simp

    { assume "ST!n = NT" hence ?thesis using n app Invoke by simp }
    moreover {
      assume "ST'!n = NT"
      moreover with n less have "ST!n = NT"
        by (auto dest: list_all2_nthD)
      ultimately have ?thesis using n app Invoke by simp }
    moreover {
      assume ST: "ST!n \<noteq> NT" and ST': "ST'!n \<noteq> NT"

      from ST' app Invoke
      obtain D Ts T m C'
        where D: "class_type_of' (ST' ! n) = \<lfloor>D\<rfloor>"
        and Ts: "P \<turnstile> rev (take n ST') [\<le>] Ts"
        and D_M: "P \<turnstile> D sees M: Ts\<rightarrow>T = m in C'"
        by fastforce

      from less have "P \<turnstile> ST!n \<le> ST'!n"
        by(auto dest: list_all2_nthD2[OF _ n])
      with D obtain D' where D': "class_type_of' (ST ! n) = \<lfloor>D'\<rfloor>"
        and DsubC: "P \<turnstile> D' \<preceq>\<^sup>* D"
        using ST by(rule widen_is_class_type_of)
      from wf D_M DsubC obtain Ts' T' m' C'' where
        D'_M: "P \<turnstile> D' sees M: Ts'\<rightarrow>T' = m' in C''" and
        Ts': "P \<turnstile> Ts [\<le>] Ts'"
        by (blast dest: sees_method_mono)
      from less have "P \<turnstile> rev (take n ST) [\<le>] rev (take n ST')" by simp
      also note Ts also note Ts'
      finally have "P \<turnstile> rev (take n ST) [\<le>] Ts'" .
      with D'_M D' app less Invoke D have ?thesis by(auto)
    }
    ultimately show ?thesis by blast
  next
    case Getfield
    with app less show ?thesis
      by(fastforce simp add: sees_field_def widen_Array dest: has_fields_fun)
  next
    case Putfield
    with app less show ?thesis
      by (fastforce intro: widen_trans rtrancl_trans simp add: sees_field_def widen_Array dest: has_fields_fun)
  next
    case CAS
    with app less show ?thesis
      by (fastforce intro: widen_trans rtrancl_trans simp add: sees_field_def widen_Array dest: has_fields_fun)
  next
    case Return
    with app less show ?thesis by (fastforce intro: widen_trans)
  next
    case ALoad
    with app less show ?thesis by(auto simp add: widen_Array)
  next
    case AStore
    with app less show ?thesis by(auto simp add: widen_Array)
  next
    case ALength
    with app less show ?thesis by(auto simp add: widen_Array)
  next
    case (Checkcast T)
    with app less show ?thesis
      by(auto elim!: refTE simp: widen_Array)
  next
    case (Instanceof T)
    with app less show ?thesis
      by(auto elim!: refTE simp: widen_Array)
  next
    case ThrowExc
    with app less show ?thesis
      by(auto elim!: refTE simp: widen_Array)
  next
    case MEnter
    with app less show ?thesis
      by(auto elim!: refTE simp: widen_Array)
  next
    case MExit
    with app less show ?thesis
      by(auto elim!: refTE simp: widen_Array)
  next
    case (BinOpInstr bop)
    with app less show ?thesis by(force dest: WTrt_binop_widen_mono)
  next
    case Dup
    with app less show ?thesis
      by(auto dest: list_all2_lengthD)
  next
    case Swap
    with app less show ?thesis
      by(auto dest: list_all2_lengthD)
  qed (auto elim!: refTE not_refTE)
qed

lemma succs_mono:
  assumes wf: "wf_prog p P" and app\<^sub>i: "app\<^sub>i (i,P,mxs,mpc,rT,\<tau>')"
  shows "P \<turnstile> \<tau> \<le>\<^sub>i \<tau>' \<Longrightarrow> set (succs i \<tau> pc) \<subseteq> set (succs i \<tau>' pc)"
proof (cases i)
  case (Invoke M n)
  obtain ST LT ST' LT' where
    [simp]: "\<tau> = (ST,LT)" and [simp]: "\<tau>' = (ST',LT')" by (cases \<tau>, cases \<tau>')
  assume "P \<turnstile> \<tau> \<le>\<^sub>i \<tau>'"
  moreover
  with app\<^sub>i Invoke have "n < size ST" by (auto dest: list_all2_lengthD)
  ultimately
  have "P \<turnstile> ST!n \<le> ST'!n" by (auto simp add: fun_of_def dest: list_all2_nthD)
  with Invoke show ?thesis by auto
next
  case ALoad
  obtain ST LT ST' LT' where
    [simp]: "\<tau> = (ST,LT)" and [simp]: "\<tau>' = (ST',LT')" by (cases \<tau>, cases \<tau>')
  assume "P \<turnstile> \<tau> \<le>\<^sub>i \<tau>'"
  moreover
  with app\<^sub>i ALoad have "1 < size ST" by (auto dest: list_all2_lengthD)
  ultimately
  have "P \<turnstile> ST!1 \<le> ST'!1" by (auto simp add: fun_of_def dest: list_all2_nthD)
  with ALoad show ?thesis by auto
next
  case AStore
  obtain ST LT ST' LT' where
    [simp]: "\<tau> = (ST,LT)" and [simp]: "\<tau>' = (ST',LT')" by (cases \<tau>, cases \<tau>')
  assume "P \<turnstile> \<tau> \<le>\<^sub>i \<tau>'"
  moreover
  with app\<^sub>i AStore have "2 < size ST" by (auto dest: list_all2_lengthD)
  ultimately
  have "P \<turnstile> ST!2 \<le> ST'!2" by (auto simp add: fun_of_def dest: list_all2_nthD)
  with AStore show ?thesis by auto
next
  case ALength
  obtain ST LT ST' LT' where
    [simp]: "\<tau> = (ST,LT)" and [simp]: "\<tau>' = (ST',LT')" by (cases \<tau>, cases \<tau>')
  assume "P \<turnstile> \<tau> \<le>\<^sub>i \<tau>'"
  moreover
  with app\<^sub>i ALength have "0 < size ST" by (auto dest: list_all2_lengthD)
  ultimately
  have "P \<turnstile> ST!0 \<le> ST'!0" by (auto simp add: fun_of_def dest: list_all2_nthD)
  with ALength show ?thesis by auto
next
  case MEnter
  obtain ST LT ST' LT' where
    [simp]: "\<tau> = (ST,LT)" and [simp]: "\<tau>' = (ST',LT')" by (cases \<tau>, cases \<tau>')
  assume "P \<turnstile> \<tau> \<le>\<^sub>i \<tau>'"
  moreover
  with app\<^sub>i MEnter have "0 < size ST" by (auto dest: list_all2_lengthD)
  ultimately
  have "P \<turnstile> ST!0 \<le> ST'!0" by (auto simp add: fun_of_def dest: list_all2_nthD)
  with MEnter show ?thesis by auto
next
  case MExit
  obtain ST LT ST' LT' where
    [simp]: "\<tau> = (ST,LT)" and [simp]: "\<tau>' = (ST',LT')" by (cases \<tau>, cases \<tau>')
  assume "P \<turnstile> \<tau> \<le>\<^sub>i \<tau>'"
  moreover
  with app\<^sub>i MExit have "0 < size ST" by (auto dest: list_all2_lengthD)
  ultimately
  have "P \<turnstile> ST!0 \<le> ST'!0" by (auto simp add: fun_of_def dest: list_all2_nthD)
  with MExit show ?thesis by auto
qed auto

lemma app_mono:
  assumes wf: "wf_prog p P"
  assumes less': "P \<turnstile> \<tau> \<le>' \<tau>'"
  shows "app i P m rT pc mpc xt \<tau>' \<Longrightarrow> app i P m rT pc mpc xt \<tau>"
proof (cases \<tau>)
  case None thus ?thesis by simp
next
  case (Some \<tau>\<^sub>1)
  moreover
  with less' obtain \<tau>\<^sub>2 where \<tau>\<^sub>2: "\<tau>' = Some \<tau>\<^sub>2" by (cases \<tau>') auto
  ultimately have less: "P \<turnstile> \<tau>\<^sub>1 \<le>\<^sub>i \<tau>\<^sub>2" using less' by simp

  assume "app i P m rT pc mpc xt \<tau>'"
  with Some \<tau>\<^sub>2 obtain
    app\<^sub>i: "app\<^sub>i (i, P, pc, m, rT, \<tau>\<^sub>2)" and
    xcpt: "xcpt_app i P pc m xt \<tau>\<^sub>2" and
    succs: "\<forall>(pc',s')\<in>set (eff i P pc xt (Some \<tau>\<^sub>2)). pc' < mpc"
    by (auto simp add: app_def)

  from wf less app\<^sub>i have "app\<^sub>i (i, P, pc, m, rT, \<tau>\<^sub>1)" by (rule app\<^sub>i_mono)
  moreover
  from less have "size (fst \<tau>\<^sub>1) = size (fst \<tau>\<^sub>2)"
    by (cases \<tau>\<^sub>1, cases \<tau>\<^sub>2) (auto dest: list_all2_lengthD)
  with xcpt have "xcpt_app i P pc m xt \<tau>\<^sub>1" by (simp add: xcpt_app_def)
  moreover
  from wf app\<^sub>i less have "\<forall>pc. set (succs i \<tau>\<^sub>1 pc) \<subseteq> set (succs i \<tau>\<^sub>2 pc)"
    by (blast dest: succs_mono)
  with succs
  have "\<forall>(pc',s')\<in>set (eff i P pc xt (Some \<tau>\<^sub>1)). pc' < mpc"
    by (cases \<tau>\<^sub>1, cases \<tau>\<^sub>2)
       (auto simp add: eff_def norm_eff_def xcpt_eff_def dest: bspec)
  ultimately
  show ?thesis using Some by (simp add: app_def)
qed

lemma eff\<^sub>i_mono:
  assumes wf: "wf_prog p P"
  assumes less: "P \<turnstile> \<tau> \<le>\<^sub>i \<tau>'"
  assumes app\<^sub>i: "app i P m rT pc mpc xt (Some \<tau>')"
  assumes succs: "succs i \<tau> pc \<noteq> []"  "succs i \<tau>' pc \<noteq> []"
  shows "P \<turnstile> eff\<^sub>i (i,P,\<tau>) \<le>\<^sub>i eff\<^sub>i (i,P,\<tau>')"
proof -
  obtain ST LT ST' LT' where
    [simp]: "\<tau> = (ST,LT)" and
    [simp]: "\<tau>' = (ST',LT')"
    by (cases \<tau>, cases \<tau>')

  note [simp] = eff_def app_def fun_of_def

  from less have "P \<turnstile> (Some \<tau>) \<le>' (Some \<tau>')" by simp
  from wf this app\<^sub>i
  have app: "app i P m rT pc mpc xt (Some \<tau>)" by (rule app_mono)

  from less app app\<^sub>i show ?thesis
  proof (cases i)
    case ThrowExc with succs have False by simp
    thus ?thesis ..
  next
    case Return with succs have False by simp
    thus ?thesis ..
  next
    case (Load i)
    from Load app obtain y where
       y:  "i < size LT" "LT!i = OK y" by clarsimp
    from Load app\<^sub>i obtain y' where
       y': "i < size LT'" "LT'!i = OK y'" by clarsimp

    from less have "P \<turnstile> LT [\<le>\<^sub>\<top>] LT'" by simp
    with y y' have "P \<turnstile> y \<le> y'" by (auto dest: list_all2_nthD)
    with Load less y y' app app\<^sub>i
    show ?thesis by auto
  next
    case Store with less app app\<^sub>i
    show ?thesis by (auto simp add: list_all2_update_cong)
  next
    case (Invoke M n)
    with app\<^sub>i have n: "n < size ST'" by simp
    from less have [simp]: "size ST = size ST'"
      by (auto dest: list_all2_lengthD)

    from Invoke succs have ST: "ST!n \<noteq> NT" and ST': "ST'!n \<noteq> NT" by (auto)

    from ST' app\<^sub>i Invoke obtain D Ts T m C'
      where D: "class_type_of' (ST' ! n) = \<lfloor>D\<rfloor>"
      and Ts: "P \<turnstile> rev (take n ST') [\<le>] Ts"
      and D_M: "P \<turnstile> D sees M: Ts\<rightarrow>T = m in C'"
      by fastforce

    from less have "P \<turnstile> ST!n \<le> ST'!n" by(auto dest: list_all2_nthD2[OF _ n])
    with D obtain D' where D': "class_type_of' (ST ! n) = \<lfloor>D'\<rfloor>"
      and DsubC: "P \<turnstile> D' \<preceq>\<^sup>* D"
      using ST by(rule widen_is_class_type_of)

    from wf D_M DsubC obtain Ts' T' m' C'' where
      D'_M: "P \<turnstile> D' sees M: Ts'\<rightarrow>T' = m' in C''" and
      Ts': "P \<turnstile> Ts [\<le>] Ts'" and "P \<turnstile> T' \<le> T" by (blast dest: sees_method_mono)

    show ?thesis using Invoke n D D' D_M less D'_M Ts' \<open>P \<turnstile> T' \<le> T\<close>
      by(auto intro: list_all2_dropI)
  next
    case ALoad with less app app\<^sub>i succs
    show ?thesis by(auto split: if_split_asm dest: Array_Array_widen)
  next
    case AStore with less app app\<^sub>i succs
    show ?thesis by(auto split: if_split_asm dest: Array_Array_widen)
  next
    case (BinOpInstr bop)
    with less app app\<^sub>i succs show ?thesis
      by auto(force dest: WTrt_binop_widen_mono WTrt_binop_fun)
  qed auto
qed

end