section \<open>Adversary Rule\<close>

theory Adversary_Rule
  imports Helping_Lemmas
begin

locale adversary_rule =
  fixes s :: "nat \<Rightarrow> context"
  fixes s' :: "nat \<Rightarrow> context"
  fixes R :: predicate
  fixes aux :: var
  fixes Rv defines "Rv \<equiv> deidx12 (fvp R)"
begin

definition "subst C = substitute C s"
definition "subst' C = substitute C s'"

lemma finite_Rv: "finite Rv"
  unfolding Rv_def deidx12_def apply simp
  unfolding vimage_def[symmetric]
  by (meson finite_fvp finite_vimageI idx_inj injI)+

abbreviation "qrhlC V C \<equiv> qRHL (R \<sqinter> Eq V) (subst C) (subst' C) (R \<sqinter> Eq V)"

lemma context_induct[
    params     i and p and           e C1 C2 and   e C and   x C and                      q C and                     C1 C2,
    case_names Hole program[program] IfTE[IH1 IH2] While[IH] LocalC[IH program classical] LocalQ[IH program quantum] Seq[IH1 IH2]]:
  fixes P :: "context \<Rightarrow> bool"
    and "context" :: "context"
  assumes "\<And>i. P (Hole i)"
    and "\<And>p. program p \<Longrightarrow> P p"
    and "\<And>e C1 C2. P C1 \<Longrightarrow> P C2 \<Longrightarrow> P (IfTE e C1 C2)"
    and "\<And>e C. P C \<Longrightarrow> P (While e C)"
    and "\<And>x C. P C \<Longrightarrow> \<not> program C \<Longrightarrow> is_classical x \<Longrightarrow> P (Local x C)"
    and "\<And>q C. P C \<Longrightarrow> \<not> program C \<Longrightarrow> is_quantum q \<Longrightarrow> P (Local q C)"
    and "\<And>C1 C2. P C1 \<Longrightarrow> P C2 \<Longrightarrow> P (Seq C1 C2)"
  shows "P context"
  apply (rule context.induct)
  using assms apply (auto intro!: program.intros)
  by (meson program.intros(9))

lemma adversary_rule0:
  fixes V :: "var set"
  fixes Vmid :: "var set"
  assumes inf_aux: "infinite_var aux"
  assumes quant_aux: "is_quantum aux"
  assumes aux_R: "aux \<notin> Rv"
  assumes aux_si: "\<And>i. i \<in> holes C \<Longrightarrow> aux \<notin> fv (s i)"
  assumes aux_s'i: "\<And>i. i \<in> holes C \<Longrightarrow> aux \<notin> fv (s' i)"
  assumes finite_Vmid: "finite Vmid"
  assumes qrhl_s: "\<And>i. i\<in>holes C \<Longrightarrow> qRHL (R \<sqinter> Eq Vmid) (s i) (s' i) (R \<sqinter> Eq Vmid)"
  assumes aux_Vmid: "aux \<in> Vmid"
  assumes Vmid_V: "Vmid \<supseteq> V \<union> inner C"
  assumes Vmid_R: "Vmid \<inter> Rv \<subseteq> V \<union> covered C"
  assumes Vmid_s: "\<And>i. i\<in>holes C \<Longrightarrow> Vmid \<inter> (fv (s i) \<union> fv (s' i)) \<subseteq> classical' (overwr (s i) \<inter> overwr (s' i)) \<union> covered C \<union> V"
  assumes fv_V: "fv C \<subseteq> V"
  assumes R_inner: "Rv \<inter> inner C = {}"
  assumes R_written: "Rv \<inter> written C = {}"
  shows "qrhlC V C"
  using aux_si aux_s'i finite_Vmid qrhl_s aux_Vmid Vmid_V Vmid_R Vmid_s fv_V R_inner R_written apply atomize
proof (induction C arbitrary: V Vmid rule:context_induct)
  case (program p)

  from program.prems
  have R_written: "Rv \<inter> written p = {}"
    by simp

  from \<open>fv p \<subseteq> V\<close>
  have "qRHL (Eq V) p p (Eq V)"
    by (rule equal_rule)
  then have "qRHL (R \<sqinter> Eq V) p p (R \<sqinter> Eq V)"
    unfolding inf.commute[of R]
    apply (rule frame_rule[rotated -1])
    using R_written \<open>program p\<close>
    by (auto simp add: Rv_def deidx12_def idx12_def is_classical'_def)
  then show ?case
    by (simp add: program.program subst_def subst'_def substitute_program)
next
  case (Seq C1 C2)
  have subst: "subst (Seq C1 C2) = Seq (subst C1) (subst C2)"
    unfolding subst_def by simp
  have subst': "subst' (Seq C1 C2) = Seq (subst' C1) (subst' C2)"
    unfolding subst'_def by simp

  have "qrhlC V C1"
    apply (rule Seq.IH1)
    using Seq.prems by (auto simp: idx12_def)
  moreover have "qrhlC V C2"
    apply (rule Seq.IH2)
    using Seq.prems by (auto simp: idx12_def)
  ultimately show ?case
    unfolding subst subst'
    by (rule seq)
next
  case (IfTE e C1 C2)
  have subst: "subst (IfTE e C1 C2) = IfTE e (subst C1) (subst C2)"
    unfolding subst_def by simp
  have subst': "subst' (IfTE e C1 C2) = IfTE e (subst' C1) (subst' C2)"
    unfolding subst'_def by simp

  from IfTE.prems
  have "CVar ` fve e \<subseteq> V"
    by auto
  then have Eq_e: "Eq V \<le> Eq (CVar ` fve e)"
    apply (subst asm_rl[of "V = (CVar ` fve e) \<union> (V - CVar ` fve e)"], blast)
    apply (subst Eq_split)
    by (auto simp: is_classical'_def)

  have "qrhlC V C1"
    apply (rule IfTE.IH1)
    using IfTE.prems by (auto simp: idx12_def)
  moreover have "qrhlC V C2"
    apply (rule IfTE.IH2)
    using IfTE.prems by (auto simp: idx12_def)
  ultimately show ?case
    unfolding subst subst'
    apply (rule joint_if_rule[rotated -2])
    using Eq_e by (simp_all add: inf.coboundedI2)
next
  case (While e C)
  have subst: "subst (While e C) = While e (subst C)"
    unfolding subst_def by simp
  have subst': "subst' (While e C) = While e (subst' C)"
    unfolding subst'_def by simp

  from While.prems
  have "CVar ` fve e \<subseteq> V"
    by simp
  then have Eq_e: "Eq V \<le> Eq (CVar ` fve e)"
    apply (subst asm_rl[of "V = (CVar ` fve e) \<union> (V - CVar ` fve e)"], blast)
    apply (subst Eq_split)
    by (auto simp: is_classical'_def)

  have "qrhlC V C"
    apply (rule While.IH)
    using While.prems apply simp
    using While.prems apply (auto simp: idx12_def)[1]
    using While.prems by auto
  then show ?case
    unfolding subst subst'
    apply (rule joint_while_rule[rotated 1])
    using Eq_e by (simp_all add: inf.coboundedI2)
next
  case (LocalC x C)
  have subst: "subst (Local x C) = Local x (subst C)"
    unfolding subst_def by simp
  have subst': "subst' (Local x C) = Local x (subst' C)"
    unfolding subst'_def by simp

  from LocalC.classical
  obtain x' where x': "x = CVar x'"
    using is_classical.cases by blast

  from LocalC.program
  have inner: "inner (Local x C) = {x} \<union> inner C"
    by simp
  moreover
  from LocalC.prems
  have R_inner: "Rv \<inter> inner (Local x C) = {}"
    by simp
  ultimately have xR: " x \<notin> Rv"
    by auto

  have [simp]: "CVar (idxc b x') = idx b x" for b
    unfolding x' by simp

  have "qrhlC (insert x V) C"
    apply (rule LocalC.IH[where V="insert x V"])
    using LocalC.prems inner by (auto simp: idx12_def)
  then have "qrhlC (V-{x}) (Local x C)"
    unfolding subst subst'
    apply (rule_tac joint_local0_rule[rotated -1])
    using xR by (auto simp: Rv_def deidx12_def)
  then have "qRHL (R \<sqinter> Eq (V-{x}) \<sqinter> Eq (V\<inter>{x}))
             (subst (Local x C)) (subst' (Local x C))
             (R \<sqinter> Eq (V-{x}) \<sqinter> Eq (V\<inter>{x}))"
    apply (rule frame_rule[rotated -1])
    by (auto simp: is_classical'_def subst subst' idx12_def intro!: program.intros)
  then show ?case
    unfolding inf.assoc
    unfolding inf.commute[of "Eq (V-{x})"]
    apply (subst (asm) Eq_split[symmetric], simp add: is_classical'_def LocalC.classical)
    apply (subst (asm) Eq_split[symmetric], simp add: is_classical'_def LocalC.classical)
    by (simp add: Un_Diff_Int Un_commute)
next
  case (LocalQ q C)

  from LocalQ.program
  have [simp]: "inner (Local q C) = insert q (inner C)"
    by simp

  from LocalQ.prems
  have [simp]: "finite V"
    using rev_finite_subset by blast

  have cofin: "\<exists>x. compatible q x \<and> P x" if "finite {x. \<not> P x}" for P :: "var \<Rightarrow> bool" and q
  proof -
    have "{x. compatible q x \<and> P x} = Collect (compatible q) - {x. \<not> P x}"
      by auto
    also have "infinite (Collect (compatible q) - {x. \<not> P x})"
      using that apply (rule Diff_infinite_finite)
      by (simp add: compatible_inexhaust)
    finally have "{x. compatible q x \<and> P x} \<noteq> {}"
      by force
    then show ?thesis
      by auto
  qed

  have [simp]: "finite {r. \<exists>i\<in>holes C. r \<in> fv (s i)}"
    apply (subst Collect_bex_eq)
    apply (rule finite_Union)
    by auto

  obtain r :: var where [simp]: \<open>compatible q r\<close>
    and "r \<notin> fv (subst C)"
    and "r \<notin> fv (subst' C)"
    and "r \<notin> Rv"
    and "r \<noteq> q"
    and "r \<notin> V"
    and [simp]: "\<And>i. i\<in>holes C \<Longrightarrow> r \<notin> fv (s i)"
    and [simp]: "\<And>i. i\<in>holes C \<Longrightarrow> r \<notin> fv (s' i)"
    apply atomize_elim
    apply (rule cofin)
    by (auto intro!: finite_Rv finite_vimageI[unfolded vimage_def, unfolded inj_on_def, rule_format])
  from \<open>compatible q r\<close> have [simp]: \<open>is_quantum r\<close>
    using LocalQ.quantum compatible_is_classical by blast

  from LocalQ.quantum \<open>is_quantum r\<close>
  obtain q' r' :: qvar where q': "q = QVar q'" and r': "r = QVar r'"
    by (metis (full_types) is_classical_CVar var.exhaust)
  with \<open>compatible q r\<close> have [simp]: \<open>compatible (QVar q') (QVar r')\<close>
    by simp

  define V' where
    "V' = (if q\<in>V then insert r V - {q} else V)"

  have "q \<notin> V'"
    unfolding V'_def by auto

  from LocalQ.prems
  have qR: "q \<notin> Rv"
    by simp

  have subst: "subst (Local q C) = Local q (subst C)"
    unfolding subst_def by simp
  have subst': "subst' (Local q C) = Local q (subst' C)"
    unfolding subst'_def by simp

  from LocalQ.prems
  have qrhl_s: "qRHL (R \<sqinter> Eq Vmid) (s i) (s' i) (R \<sqinter> Eq Vmid)" if "i\<in>holes C" for i
    using that by simp

  from LocalQ.prems
  have aux_si: "\<And>i. i \<in> holes C \<Longrightarrow> aux \<notin> fv (s i)"
    and aux_s'i: "\<And>i. i \<in> holes C \<Longrightarrow> aux \<notin> fv (s' i)"
    by auto

  have qrhl_sr: "qRHL (R \<sqinter> Eq (insert r Vmid)) (s i) (s' i) (R \<sqinter> Eq (insert r Vmid))"
    if "i\<in>holes C" for i
    apply (subst asm_rl[of "insert r Vmid = (Vmid-{aux}) \<union> {aux,r}"],
               (auto simp add: \<open>aux \<in> Vmid\<close>)[1])+
    apply (rule varchange[where Q="{aux}" and q=aux, rotated -1])
          apply (subst asm_rl[of "Vmid - {aux} \<union> {aux} = Vmid"], (auto simp add: \<open>aux \<in> Vmid\<close>)[1])+
          using that apply (rule qrhl_s)
    using quant_aux \<open>is_quantum r\<close> inf_aux aux_R aux_si aux_s'i that
    by (auto simp add: is_quantum'_def Rv_def deidx12_def)

  have "qrhlC (insert q V') C"
  proof (rule LocalQ.IH[where Vmid = "insert r Vmid"])
    show "finite (insert r Vmid)"
      using LocalQ.prems by simp
    show "aux \<in> insert r Vmid"
      using LocalQ.prems by simp
    show "insert q V' \<union> inner C \<subseteq> insert r Vmid"
      using LocalQ.prems V'_def by auto
    show "insert r Vmid \<inter> Rv \<subseteq> insert q V' \<union> covered C"
      using LocalQ.prems \<open>r \<notin> Rv\<close>
      by (auto simp: idx12_diff V'_def)
    show "\<forall>i. i\<in>holes C \<longrightarrow> insert r Vmid \<inter> (fv (s i) \<union> fv (s' i))
        \<subseteq> classical' (overwr (s i) \<inter> overwr (s' i)) \<union> covered C \<union> insert q V'"
      using LocalQ.prems unfolding V'_def by auto
    show "fv C \<subseteq> insert q V'"
      using LocalQ.prems V'_def by auto
    show "Rv \<inter> inner C = {}"
      using LocalQ.prems by auto
    from LocalQ.prems
    have R_written: "Rv \<inter> written (Local q C) = {}"
      by simp
    then show "Rv \<inter> written C = {}"
      using qR by auto
  qed (auto simp add: qrhl_sr aux_si aux_s'i)

  then have qrhl_V': "qrhlC V' (Local q C)"
    unfolding subst subst'
    apply (rule joint_local0_rule[rotated -1])
    using qR \<open>q \<notin> V'\<close> \<open>q \<notin> V'\<close> by (auto simp: Rv_def deidx12_def)

  have [simp]: "QVar q' \<notin> fv (subst' (Local (QVar q') C))"
    using subst' by (simp add: q')
  have [simp]: "QVar r' \<notin> fv (subst' (Local (QVar q') C))"
    using \<open>r \<notin> fv (subst' C)\<close> subst' by (simp add: r' q')
  have [simp]: "QVar q' \<notin> fv (subst (Local (QVar q') C))"
    using subst by (simp add: q')
  have [simp]: "QVar r' \<notin> fv (subst (Local (QVar q') C))"
    using \<open>r \<notin> fv (subst C)\<close> subst by (simp add: r' q')
  have idx_r_R[simp]: "idx b r \<notin> fvp R" for b
    apply (cases b)
    using \<open>r \<notin> Rv\<close> by (simp_all add: r' deidx12_def Rv_def)
  have idx_q_R[simp]: "idx b q \<notin> fvp R" for b
    apply (cases b)
    using qR by (simp_all add: Rv_def deidx12_def)

  have swap_V': "transpose (QVar q') (QVar r') ` V' = V"
    unfolding V'_def
    using \<open>r \<noteq> q\<close> \<open>r \<notin> V\<close>
    by (auto simp: transpose_def q'[symmetric] r'[symmetric])

  have "R \<sqinter> Eq V
        = substp_bij (transpose (idx True q) (idx True r) o
                   (transpose (idx False q) (idx False r))) (R \<sqinter> Eq V')"
    apply (subst substp_bij_inter)
      apply (auto intro!: valid_var_subst_comp compatible_idx simp: bij_swap_iff)[2]
    apply (subst substp_bij_id)
       apply (auto intro!: valid_var_subst_comp compatible_idx simp: bij_swap_iff)[3]
     apply (metis idx_q_R idx_r_R transpose_apply_other)
    using substp_bij_Eq  q' r' apply auto
    by (metis \<open>compatible q r\<close> \<open>r \<noteq> q\<close> swap_V')
  also have \<open>\<dots> = substp (transpose (idx True q) (idx True r)) (substp (transpose (idx False q) (idx False r)) (R \<sqinter> Eq V'))\<close>
    apply (subst substp_bij_comp[symmetric])
        apply auto[4]
    apply (subst substp_substp_bij[where \<tau>=\<open>transpose (idx True q) (idx True r)\<close>])
       apply auto[3]
    apply (subst substp_substp_bij[where \<tau>=\<open>transpose (idx False q) (idx False r)\<close>])
    by auto

  also have "qRHL \<dots> (subst (Local q C)) (subst' (Local q C)) \<dots>"
    unfolding q' r'
    apply (rule rename_qrhl1)
      apply auto[3]
    apply (rule rename_qrhl2)
      apply auto[3]
    using q' qrhl_V' by blast

  finally show "qrhlC V (Local q C)"
    by simp
next
  case (Hole i)

  define X Y Q C where "X = {x\<in>Vmid-V. is_classical x \<and> x \<in> overwr (s i) \<and> x \<in> overwr (s' i)}"
    and "Y = {x\<in>Vmid-V. is_classical x \<and> \<not> (x \<in> overwr (s i) \<and> x \<in> overwr (s' i))}"
    and "Q = {x\<in>Vmid-V. is_quantum x}" and [simp]: "C = Hole i"

  have quant_Q[simp]: "is_quantum' Q"
    unfolding is_quantum'_def Q_def by simp
  have class_Y[simp]: "is_classical' Y"
    using Y_def is_classical'_def by blast

  from \<open>aux \<in> Vmid\<close> quant_aux
  have [simp]: "aux \<in> V \<union> Q"
    by (simp add: Q_def)

  from Hole.prems
  have Vmid_s: "Vmid \<inter> (fv (s i) \<union> fv (s' i)) \<subseteq> classical' (overwr (s i) \<inter> overwr (s' i)) \<union> covered C \<union> V"
    and Vmid_R: "Vmid \<inter> Rv \<subseteq> V \<union> covered C"
    and Vmid_V: "V \<union> inner C \<subseteq> Vmid"
    and qrhl_s: "qRHL (R \<sqinter> Eq Vmid) (s i) (s' i) (R \<sqinter> Eq Vmid)"
    by simp_all

  from Vmid_s
  have sQ: "fv (s i) \<inter> Q = {}" and s'Q: "fv (s' i) \<inter> Q = {}"
    by (auto simp add: Q_def classical'_def)

  from \<open>finite Vmid\<close>
  have "finite X"
    unfolding X_def by simp

  have class_X: "is_classical' X"
    unfolding X_def is_classical'_def by simp

  from Vmid_s
  have X_overwr_si: "X \<subseteq> overwr (s i)" and X_overwr_si': "X \<subseteq> overwr (s' i)"
    using overwr_fv[of "s i"] overwr_fv[of "s' i"] unfolding X_def classical'_def by auto

  then obtain Xlist where Xlist: "X = CVar ` set Xlist"
    using class_X \<open>finite X\<close>
    by (metis finite_list is_classical'_def finite_subset_image imageI is_classical.simps subsetI)
  have Vmid_XYQ: "Vmid = V \<union> X \<union> Y \<union> Q"
    unfolding X_def Y_def Q_def using Vmid_V by blast
  have "X \<inter> V = {}" and "X \<inter> Y = {}" and "X \<inter> Q = {}"
    unfolding X_def Y_def Q_def
    by auto
  moreover
  from \<open>X \<inter> V = {}\<close>
  have "idx12 X \<inter> idx12 V = {}"
    unfolding idx12_def by auto
  then have "idx12 X \<inter> fvp R = {}"
    using Vmid_R unfolding Rv_def deidx12_def idx12_def Vmid_XYQ idx12_union by auto
  ultimately have 1: "idx12 X \<inter> fvp (R \<sqinter> Eq (V \<union> Y \<union> Q)) = {}"
    apply (rule_tac fvp_inter_empty)
    by (auto simp add: idx12_def)

  have "Y \<inter> V = {}" and "Y \<inter> Q = {}"
    unfolding Y_def Q_def by auto
  moreover
  from \<open>Y \<inter> V = {}\<close>
  have "idx12 Y \<inter> idx12 V = {}"
    unfolding idx12_def by auto
  then have "idx12 Y \<inter> fvp R = {}"
    using Vmid_R unfolding Rv_def idx12_def deidx12_def Vmid_XYQ idx12_union by auto
  ultimately have 2: "idx12 Y \<inter> fvp (R \<sqinter> Eq (V \<union> Q)) = {}"
    apply (rule_tac fvp_inter_empty)
    by (auto simp add: idx12_def)
  have siY: "fv (s i) \<inter> Y = {}" and s'iY: "fv (s' i) \<inter> Y = {}"
    using Vmid_s unfolding Y_def classical'_def by auto

  have "R \<sqinter> Eq (V \<union> Q) \<sqinter> Eq Y = R \<sqinter> Eq (V \<union> Y \<union> Q)"
    apply (subst asm_rl[of "V \<union> Y \<union> Q = Y \<union> (V \<union> Q)"], blast)
    apply (subst Eq_split[where X=Y], simp)
    by (simp add: inf_commute inf_left_commute)
  also have "qRHL (R \<sqinter> Eq (V \<union> Y \<union> Q)) (Assign Xlist some_constant) (Assign Xlist some_constant) (R \<sqinter> Eq Vmid)"
    apply (subst asm_rl[of "R \<sqinter> Eq Vmid = Eq (CVar ` set Xlist) \<sqinter> (R \<sqinter> Eq (V \<union> Y \<union> Q))"])
     apply (metis Eq_split Vmid_XYQ Xlist class_X inf_left_commute sup_commute sup_left_commute)
    apply (subst asm_rl[of "(R \<sqinter> Eq (V \<union> Y \<union> Q)) = top \<sqinter> (R \<sqinter> Eq (V \<union> Y \<union> Q))"], simp)
    apply (rule frame_rule)
    using 1 apply (auto simp: idx12_def Xlist[symmetric] intro!: program.intros) [2]
    by (rule assign_Eq)
  also from qrhl_s have "qrhlC Vmid C"
    unfolding subst_def subst'_def by auto
  also have "Assign Xlist some_constant; subst C =d= subst C"
    apply (rule denot_eq_init)
    unfolding subst_def apply auto using X_overwr_si Xlist by blast
  also have "Assign Xlist some_constant; subst' C =d= subst' C"
    apply (rule denot_eq_init)
    unfolding subst'_def apply auto using X_overwr_si' Xlist by blast
  also have "R \<sqinter> Eq Vmid \<le> R \<sqinter> Eq (V \<union> Q)"
    apply (rule inf_mono, simp)
    apply (rule weaken_Eq)
    using class_X Vmid_XYQ is_classical'_def Q_def
    by blast+
  finally have "qRHL (R \<sqinter> Eq (V \<union> Q) \<sqinter> Eq Y) (subst C) (subst' C) (R \<sqinter> Eq (V \<union> Q))"
    by auto

  then have qrhl_VQ: "qrhlC (V \<union> Q) C"
    apply (rule drop_Eq[rotated -1])
    using 2 siY s'iY by (auto simp: subst_def subst'_def)

  from Hole.prems
  have aux_si: "aux \<notin> fv (s i)"
    and aux_s'i: "aux \<notin> fv (s' i)"
    by auto

  have "qrhlC ((V - {aux}) \<union> (V \<inter> {aux})) (Hole i)"
    apply (rule varchange[where Q="insert aux Q" and q=aux])
    using inf_aux quant_aux quant_Q aux_R
      aux_si aux_s'i sQ s'Q
          apply (auto simp: is_quantum'_def idx12_def subst_def subst'_def Rv_def deidx12_def)[6]
    using qrhl_VQ \<open>aux \<in> V \<union> Q\<close>
    by (metis C_def Un_insert_right insert_Diff_single insert_absorb sup_commute)

  then show ?case
    by (simp add: Un_Diff_Int)
qed

lemma adversary_rule:
  fixes Vin :: "var set"
  fixes Vout :: "var set"
  fixes Vmid :: "var set"
  assumes inf_aux: "infinite_var aux"
  assumes quant_aux: "is_quantum aux"
  assumes aux_R: "aux \<notin> Rv"
  assumes finite_Vmid: "finite Vmid"
  assumes finite_Vin: "finite Vin"
  assumes aux_si: "\<And>i. i \<in> holes C \<Longrightarrow> aux \<notin> fv (s i)"
  assumes aux_s'i: "\<And>i. i \<in> holes C \<Longrightarrow> aux \<notin> fv (s' i)"
  assumes qrhl_s: "\<And>i. i \<in> holes C \<Longrightarrow> qRHL (R \<sqinter> Eq Vmid) (s i) (s' i) (R \<sqinter> Eq Vmid)"
  assumes aux_Vmid: "aux \<in> Vmid"
  assumes inner_Vmid: "inner C \<subseteq> Vmid"
  assumes Vout_Vmid: "Vout \<subseteq> Vmid"
  assumes Vout_overwr_Vin: "Vout - overwr C \<subseteq> Vin"
  assumes Vout_Vin_R: "(Vout - Vin) \<inter> Rv = {}"
  assumes Vin_Vout_overwr: "quantum' Vin \<subseteq> Vout \<union> overwr C"
  assumes Vin_Vout_R: "quantum' (Vin - Vout) \<inter> Rv = {}"
  assumes Vmid_R_Vin_covered: "Vmid \<inter> Rv \<subseteq> Vin \<union> covered C"
  assumes Vmid_R_Vout_covered: "quantum' (Vmid \<inter> Rv) \<subseteq> Vout \<union> covered C"
  assumes Vmid_s_Vin_covered: "\<And>i. i \<in> holes C \<Longrightarrow> Vmid \<inter> (fv (s i) \<union> fv (s' i)) \<subseteq> Vin \<union> covered C \<union> classical' (overwr (s i) \<inter> overwr (s' i))"
  assumes Vmid_s_Vout_covered: "\<And>i. i \<in> holes C \<Longrightarrow> quantum' Vmid \<inter> (fv (s i) \<union> fv (s' i)) \<subseteq> Vout \<union> covered C"
  assumes C_Vmid: "fv C \<subseteq> Vmid"
  assumes C_Vin_overwr: "fv C \<subseteq> Vin \<union> overwr C"
  assumes C_Vin_R: "fv C \<inter> Rv \<subseteq> Vin"
  assumes C_Vout: "quantum' (fv C) \<subseteq> Vout"
  assumes R_inner: "Rv \<inter> inner C = {}"
  assumes R_written: "Rv \<inter> written C = {}"

  shows "qRHL (R \<sqinter> Eq Vin) (subst C) (subst' C) (R \<sqinter> Eq Vout)"
proof -
  define V where
    "V = Vmid \<inter> (overwr C \<union> Vin) \<inter> (Vin \<union> - Rv) \<inter> (Vout \<union> range CVar)"

  have [simp]: "finite V"
    unfolding V_def
    using finite_Vmid by blast

  have Vmid_V: "V \<union> inner C \<subseteq> Vmid"
    unfolding V_def using inner_Vmid by auto
  have Vmid_R: "Vmid \<inter> Rv \<subseteq> V \<union> covered C"
    unfolding V_def
    using Vmid_R_Vin_covered Vmid_R_Vout_covered
    unfolding quantum'_def is_classical.simps
    by auto
  have Vmid_s: "Vmid \<inter> (fv (s i) \<union> fv (s' i))
         \<subseteq> classical' (overwr (s i) \<inter> overwr (s' i)) \<union> covered C \<union> V" if "i\<in>holes C" for i
    unfolding V_def Un_Int_distrib
    apply (rule Int_greatest)+
       apply blast
      using Vmid_s_Vin_covered that apply blast
     using Vmid_s_Vin_covered that apply fastforce
    using Vmid_s_Vout_covered that by (auto simp: quantum'_def is_classical.simps)
  have fv_V: "fv C \<subseteq> V"
    using C_Vmid C_Vin_overwr C_Vin_R C_Vout
    unfolding V_def Rv_def quantum'_def is_classical.simps by auto
  have V_Vin_overwr: "V - Vin \<subseteq> overwr C"
    unfolding V_def by auto
  have Vin_V_overwr: "quantum' (Vin - V) \<subseteq> overwr C"
    using Vout_Vmid Vin_Vout_overwr
    unfolding V_def quantum'_def
    by auto
  have V_Vin_R: "idx12 (V - Vin) \<inter> fvp R = {}"
    unfolding V_def idx12_def deidx12_def Rv_def by auto
  have "quantum' (Vin - V) \<inter> deidx12 (fvp R) = {}"
    using Vin_Vout_R Diff_disjoint Vout_Vmid
    unfolding V_def quantum'_def Rv_def
    by auto
  then have Vin_V_R: "idx12 (quantum' (Vin - V)) \<inter> fvp R = {}"
    unfolding deidx12_def idx12_def by auto
  have Vout_V: "Vout \<subseteq> V"
    using Vout_Vmid Vout_overwr_Vin Vout_Vin_R
    unfolding deidx12_def V_def Rv_def
    by auto
  have Vout_V_class: "is_classical' (V - Vout)"
    unfolding V_def is_classical'_def by auto

  from inf_aux quant_aux aux_R aux_si aux_s'i  finite_Vmid qrhl_s aux_Vmid Vmid_V Vmid_R Vmid_s fv_V R_inner R_written
  have \<open>qrhlC V C\<close>
    by (rule adversary_rule0[where Vmid=Vmid])

  then have \<open>qRHL (R \<sqinter> Eq Vin) (subst C) (subst' C) (R \<sqinter> Eq V)\<close>
    apply (rule change_Eq_precondition[rotated -1])
    using V_Vin_overwr overwr_subst subst'_def subst_def apply auto[1]
    using Vin_V_overwr overwr_subst subst'_def subst_def apply auto[1]
    using \<open>finite V\<close> \<open>finite Vin\<close> V_Vin_R Vin_V_R by simp_all
  also have "R \<sqinter> Eq V \<le> R \<sqinter> Eq Vout"
    apply (rule inf_mono, simp)
    apply (subst asm_rl[of "V = (V-Vout) \<union> Vout"])
    using Vout_V apply auto[1]
    apply (subst Eq_split)
    using Vout_V_class by auto
  finally show ?thesis
    by auto

qed

end

end


(* Author: Florian Haftmann, TU Muenchen *)

section \<open>Reflecting Pure types into HOL\<close>

theory Typerep
imports String
begin

datatype typerep = Typerep String.literal "typerep list"

class typerep =
  fixes typerep :: "'a itself \<Rightarrow> typerep"
begin

definition typerep_of :: "'a \<Rightarrow> typerep" where
  [simp]: "typerep_of x = typerep TYPE('a)"

end

syntax
  "_TYPEREP" :: "type => logic"  ("(1TYPEREP/(1'(_')))")

parse_translation \<open>
  let
    fun typerep_tr (*"_TYPEREP"*) [ty] =
          Syntax.const \<^const_syntax>\<open>typerep\<close> $
            (Syntax.const \<^syntax_const>\<open>_constrain\<close> $ Syntax.const \<^const_syntax>\<open>Pure.type\<close> $
              (Syntax.const \<^type_syntax>\<open>itself\<close> $ ty))
      | typerep_tr (*"_TYPEREP"*) ts = raise TERM ("typerep_tr", ts);
  in [(\<^syntax_const>\<open>_TYPEREP\<close>, K typerep_tr)] end
\<close>

typed_print_translation \<open>
  let
    fun typerep_tr' ctxt (*"typerep"*)
            (Type (\<^type_name>\<open>fun\<close>, [Type (\<^type_name>\<open>itself\<close>, [T]), _]))
            (Const (\<^const_syntax>\<open>Pure.type\<close>, _) :: ts) =
          Term.list_comb
            (Syntax.const \<^syntax_const>\<open>_TYPEREP\<close> $ Syntax_Phases.term_of_typ ctxt T, ts)
      | typerep_tr' _ T ts = raise Match;
  in [(\<^const_syntax>\<open>typerep\<close>, typerep_tr')] end
\<close>

setup \<open>
let

fun add_typerep tyco thy =
  let
    val sorts = replicate (Sign.arity_number thy tyco) \<^sort>\<open>typerep\<close>;
    val vs = Name.invent_names Name.context "'a" sorts;
    val ty = Type (tyco, map TFree vs);
    val lhs = Const (\<^const_name>\<open>typerep\<close>, Term.itselfT ty --> \<^typ>\<open>typerep\<close>)
      $ Free ("T", Term.itselfT ty);
    val rhs = \<^term>\<open>Typerep\<close> $ HOLogic.mk_literal tyco
      $ HOLogic.mk_list \<^typ>\<open>typerep\<close> (map (HOLogic.mk_typerep o TFree) vs);
    val eq = HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, rhs));
  in
    thy
    |> Class.instantiation ([tyco], vs, \<^sort>\<open>typerep\<close>)
    |> `(fn lthy => Syntax.check_term lthy eq)
    |-> (fn eq => Specification.definition NONE [] [] (Binding.empty_atts, eq))
    |> snd
    |> Class.prove_instantiation_exit (fn ctxt => Class.intro_classes_tac ctxt [])
  end;

fun ensure_typerep tyco thy =
  if not (Sorts.has_instance (Sign.classes_of thy) tyco \<^sort>\<open>typerep\<close>)
    andalso Sorts.has_instance (Sign.classes_of thy) tyco \<^sort>\<open>type\<close>
  then add_typerep tyco thy else thy;

in

add_typerep \<^type_name>\<open>fun\<close>
#> Typedef.interpretation (Local_Theory.background_theory o ensure_typerep)
#> Code.type_interpretation ensure_typerep

end
\<close>

lemma [code nbe]:
  "HOL.equal (x :: typerep) x \<longleftrightarrow> True"
  by (fact equal_refl)

code_printing
  type_constructor typerep \<rightharpoonup> (Eval) "Term.typ"
| constant Typerep \<rightharpoonup> (Eval) "Term.Type/ (_, _)"

code_reserved Eval Term

hide_const (open) typerep Typerep

end


theory User_Execution

imports Context_Switch

begin

definition
  ptable_lift_user :: "vaddr  \<Rightarrow> p_state  \<Rightarrow> paddr \<Rightarrow> bool"    ("(_/ \<hookrightarrow>\<^sub>_/ \<^sub>u\<^sub>s\<^sub>e\<^sub>r / _)")
where
  "ptable_lift_user va s p \<equiv> (ptable_lift_m (heap s) (root s) User va  = Some p)"

definition
  user_safe :: "p_state \<Rightarrow> vaddr set"
where
  "user_safe s = {va. \<exists>p. va \<hookrightarrow>\<^sub>s  \<^sub>u\<^sub>s\<^sub>e\<^sub>r  p } "

lemma mmu_layout_no_phy:
  "\<lbrakk> mmu_layout s; mode s = User;  ptable_lift_m (heap s) (root s) (mode s) (Addr vp) = Some p \<rbrakk>
           \<Longrightarrow> p \<notin> kernel_phy_mem"
  by (clarsimp simp: mmu_layout_def user_mappings_def dest!: root_map_rootsD)

lemma phy_mem_data_area:
  "\<lbrakk> mmu_layout s; p \<notin> kernel_phy_mem \<rbrakk>
           \<Longrightarrow> p \<notin> kernel_data_area s"
  apply (clarsimp simp: mmu_layout_def )
  by blast

lemma user_safe_assignment:
  "\<Turnstile> \<lbrace> \<lambda>s. mmu_layout s \<and> mode s = User \<and> \<I>\<C> s = {} \<and>
           aval lval s = Some vp \<and> aval rval s = Some v \<and>
         ptable_lift_m (heap s) (root s) (mode s) (Addr vp) = Some p \<rbrace>
                  lval ::= rval
           \<lbrace>\<lambda>s. mmu_layout s \<and> mode s = User \<and> \<I>\<C> s = {} \<and> heap s p = Some v\<rbrace>"
  apply vcgm
  apply (rule conjI)
   apply (clarsimp simp: \<I>\<C>_def)
  apply (frule_tac vp = vp and p = p in  mmu_layout_no_phy , clarsimp , clarsimp)
  apply (frule_tac  p = p in phy_mem_data_area, simp)
  apply (clarsimp simp: mmu_layout_global_heap_upd)
  apply (frule_tac mmu_layout_global_set_subset, simp)
  apply (simp add: mmu_layout_ptable_comp mmu_layout_upd)
  apply (simp add: \<I>\<C>_def)
  done

end


section \<open>Secure composition: Encrypt then MAC\<close>

theory Secure_Channel imports
  One_Time_Pad
  Message_Authentication_Code
begin

context begin
interpretation INSEC: insec_channel .

interpretation MAC: macode "rnd \<eta>" "mac \<eta>" for \<eta> .
interpretation AUTH: auth_channel .

interpretation CIPHER: cipher "key \<eta>" "enc \<eta>" "dec \<eta>" for \<eta> .
interpretation SEC: sec_channel .

lemma plossless_enc [plossless_intro]:
  "plossless_converter (\<I>_uniform (nlists UNIV \<eta>) UNIV) (\<I>_uniform UNIV (nlists UNIV \<eta>) \<oplus>\<^sub>\<I> \<I>_uniform (nlists UNIV \<eta>) UNIV) (CIPHER.enc \<eta>)"
  unfolding CIPHER.enc_def
  by(rule plossless_converter_of_callee) (auto simp add: stateless_callee_def enc_def in_nlists_UNIV)

lemma plossless_dec [plossless_intro]:
  "plossless_converter (\<I>_uniform UNIV (insert None (Some ` nlists UNIV \<eta>))) (\<I>_uniform UNIV (nlists UNIV \<eta>) \<oplus>\<^sub>\<I> \<I>_uniform UNIV (insert None (Some ` nlists UNIV \<eta>))) (CIPHER.dec \<eta>)"
  unfolding CIPHER.dec_def
  by(rule plossless_converter_of_callee) (auto simp add: stateless_callee_def dec_def in_nlists_UNIV split: option.split)

lemma callee_invariant_on_key_oracle:
  "callee_invariant_on
     (CIPHER.KEY.key_oracle \<eta> \<oplus>\<^sub>O CIPHER.KEY.key_oracle \<eta>)
     (\<lambda>x. case x of None \<Rightarrow> True | Some x' \<Rightarrow> length x' = \<eta>)
     (\<I>_uniform UNIV (nlists UNIV \<eta>) \<oplus>\<^sub>\<I> \<I>_full)"
proof(unfold_locales, goal_cases)
  case (1 s x y s')
  then show ?case by(cases x; clarsimp split: option.splits; simp add: key_def in_nlists_UNIV)
next
  case (2 s)
  then show ?case by(clarsimp intro!: WT_calleeI split: option.split_asm)(simp_all add: in_nlists_UNIV key_def)
qed

interpretation key: callee_invariant_on
  "CIPHER.KEY.key_oracle \<eta> \<oplus>\<^sub>O CIPHER.KEY.key_oracle \<eta>"
  "\<lambda>x. case x of None \<Rightarrow> True | Some x' \<Rightarrow> length x' = \<eta>"
  "\<I>_uniform UNIV (nlists UNIV \<eta>) \<oplus>\<^sub>\<I> \<I>_full" for \<eta>
  by(rule callee_invariant_on_key_oracle)

lemma WT_enc [WT_intro]: "\<I>_uniform (nlists UNIV \<eta>) UNIV,
  \<I>_uniform UNIV (nlists UNIV \<eta>) \<oplus>\<^sub>\<I> \<I>_uniform (vld \<eta>) UNIV \<turnstile>\<^sub>C CIPHER.enc \<eta> \<surd>"
  unfolding CIPHER.enc_def
  by (rule WT_converter_of_callee) (simp_all add: stateless_callee_def vld_def enc_def in_nlists_UNIV)

lemma WT_dec [WT_intro]: "\<I>_uniform UNIV (insert None (Some ` nlists UNIV \<eta>)),
    \<I>_uniform UNIV (nlists UNIV \<eta>) \<oplus>\<^sub>\<I> \<I>_uniform UNIV (insert None (Some ` vld \<eta>)) \<turnstile>\<^sub>C
    CIPHER.dec \<eta> \<surd>"
  unfolding CIPHER.dec_def
  by(rule WT_converter_of_callee)(auto simp add: stateless_callee_def dec_def vld_def in_nlists_UNIV)

lemma bound_enc [interaction_bound]: "interaction_any_bounded_converter (CIPHER.enc \<eta>) (enat 2)"
  unfolding CIPHER.enc_def
  by (rule interaction_any_bounded_converter_of_callee)
    (auto simp add: stateless_callee_def map_gpv_id_bind_gpv zero_enat_def one_enat_def)

lemma bound_dec [interaction_bound]: "interaction_any_bounded_converter (CIPHER.dec \<eta>) (enat 2)"
  unfolding CIPHER.dec_def
  by (rule interaction_any_bounded_converter_of_callee)
    (auto simp add: stateless_callee_def map_gpv_id_bind_gpv zero_enat_def one_enat_def split: sum.split option.split)

theorem mac_otp:
  defines "\<I>_real \<equiv> \<lambda>\<eta>. \<I>_uniform {x. valid_mac_query \<eta> x} UNIV"
    and "\<I>_ideal \<equiv> \<lambda>_. \<I>_full"
    and "\<I>_common \<equiv> \<lambda>\<eta>. \<I>_uniform (vld \<eta>) UNIV \<oplus>\<^sub>\<I> \<I>_full"
  shows
    "constructive_security
      (\<lambda>\<eta>. 1\<^sub>C |\<^sub>= (CIPHER.enc \<eta> |\<^sub>= CIPHER.dec \<eta>) \<odot> parallel_wiring \<rhd>
            parallel_resource1_wiring \<rhd>
            CIPHER.KEY.res \<eta> \<parallel>
            (1\<^sub>C |\<^sub>= MAC.enm \<eta> |\<^sub>= MAC.dem \<eta> \<rhd>
             1\<^sub>C |\<^sub>= parallel_wiring \<rhd>
             parallel_resource1_wiring \<rhd> MAC.RO.res \<eta> \<parallel> INSEC.res))
      (\<lambda>_. SEC.res)
      (\<lambda>\<eta>. CNV Message_Authentication_Code.sim (Inl None) \<odot> CNV One_Time_Pad.sim None)
      (\<lambda>\<eta>. \<I>_uniform (Set.Collect (valid_mac_query \<eta>)) (insert None (Some ` (nlists UNIV \<eta> \<times> nlists UNIV \<eta>))))
      (\<lambda>\<eta>. \<I>_uniform UNIV {None, Some \<eta>})
      (\<lambda>\<eta>. \<I>_uniform (nlists UNIV \<eta>) UNIV \<oplus>\<^sub>\<I> \<I>_uniform UNIV (insert None (Some ` nlists UNIV \<eta>)))
      (\<lambda>_. enat q) True (\<lambda>\<eta>. (id, map_option length) \<circ>\<^sub>w (insec_query_of, map_option snd))"
proof(rule composability[OF one_time_pad[THEN constructive_security2.constructive_security, unfolded CIPHER.res_alt_def comp_converter_parallel2 comp_converter_id_left]
  secure_mac[unfolded MAC.res_def,
        THEN constructive_security.parallel_resource1,
        THEN constructive_security.lifting],
      where ?\<I>_res2="\<lambda>\<eta>. \<I>_uniform UNIV (nlists UNIV \<eta>) \<oplus>\<^sub>\<I> \<I>_uniform UNIV (nlists UNIV \<eta>)" and ?bound_conv1="\<lambda>_. 2" and ?q3 = "2 * q" and bound_sim = "\<lambda>_. \<infinity>",
simplified]
    , goal_cases)
  case (1 \<eta>)
  have [simp]: "\<I>_uniform UNIV (nlists UNIV \<eta>) \<turnstile>c CIPHER.KEY.key_oracle \<eta> s \<surd>"
    if "pred_option (\<lambda>x. length x = \<eta>) s" for s \<eta>
    apply(rule WT_calleeI)
    subgoal for call using that by(cases s; cases call; clarsimp; auto simp add: key_def in_nlists_UNIV)
    done
  have *: "callee_invariant_on (CIPHER.KEY.key_oracle \<eta> \<oplus>\<^sub>O CIPHER.KEY.key_oracle \<eta>) (pred_option (\<lambda>x. length x = \<eta>))
     (\<I>_uniform UNIV (nlists UNIV \<eta>) \<oplus>\<^sub>\<I> \<I>_uniform UNIV (nlists UNIV \<eta>))" for \<eta>
    apply(unfold_locales)
    subgoal for s x y s' by(cases s; cases x; clarsimp; auto simp add: key_def in_nlists_UNIV)
    subgoal for s by auto
    done
  then show ?case unfolding CIPHER.KEY.res_def
    by(rule callee_invariant_on.WT_resource_of_oracle) simp

  case (2 \<eta>)
  show ?case
    unfolding CIPHER.KEY.res_def
    apply(rule callee_invariant_on.lossless_resource_of_oracle[OF *])
    subgoal for s x by(cases s; cases x)(auto split: plus_oracle_split; simp add: key_def)+
    subgoal by simp
    done

  case (3 \<eta>)
  show ?case by(rule WT_intro)+

  case (4 \<eta>)
  show ?case by interaction_bound_converter code_simp

  case (5 \<eta>)
  show ?case by (simp add: mult_2_right)

  case (6 \<eta>)
  show ?case unfolding vld_def by(rule plossless_intro WT_intro[unfolded vld_def])+
qed

end

end


theory Benchmark_Default imports
  Benchmark_Comparison
  "~~/src/HOL/Library/Code_Target_Nat"
begin

notepad begin
  have "complete 200 (12345, 67889) = (48, 50)" by eval
end

end


(*<*)
theory Everything
imports DenotationalEquivalences Correctness CorrectnessUpd "Correctness-Counterexample" "~~/src/HOL/Library/LaTeXsugar"
begin

notation (latex output) DenotationalUpd.ESem ("\<lbrakk>_\<rbrakk>\<^bsup>u\<^esup>\<^bsub>_\<^esub>"  [60,60] 60)
notation (latex output) "Denotational-PropsUpd.HSem_syn" ("\<lbrace>_\<rbrace>\<^bsup>u\<^esup>_"  [60,60] 60)

translations
  "xs" <= "CONST set xs"
translations
  "xs" <= "CONST asToHeap xs"
translations
  "a" <= "CONST atom a"

lemma Terms:
  "\<exists> x assn e'. (e = (Lam [x]. e') \<or> (e = Var x) \<or> (e = App e' x) \<or> (e = Let assn e'))"
  by (metis Terms.exp_assn.exhaust(1))
lemma expressions_grammar:
"(\<forall> var. y = Var var \<longrightarrow> P) \<longrightarrow>
(\<forall> exp var. y = App exp var \<longrightarrow> P) \<longrightarrow>
(\<forall> assn exp. y = Terms.Let assn exp \<longrightarrow> P) \<longrightarrow> (\<forall> var exp. y = Lam [var]. exp \<longrightarrow> P) \<longrightarrow> P"
  by (metis exp_assn.exhaust(1))

abbreviation (Grammar output)
  "grammar_imp"
where
  "grammar_imp \<equiv> op \<longrightarrow>"

syntax (Grammar output)
  "_grapats" :: "term \<Rightarrow> term \<Rightarrow> term" ("_ | _")
  "_grafirst" :: "term \<Rightarrow> term \<Rightarrow> term" ("_ ::= _")
  "_grarest" :: "term \<Rightarrow> term \<Rightarrow> term"
  "_firsteq" :: "term \<Rightarrow> term \<Rightarrow> term"
  "_resteq" :: "term \<Rightarrow> term \<Rightarrow> term"

translations
  "_grapats (_firsteq all) (_grarest (CONST grammar_imp rest1 rest2))" <= "CONST grammar_imp all (CONST grammar_imp rest1 rest2)"
  "_grapats (_resteq all) (_grarest (CONST grammar_imp rest1 rest2))" <= "_grarest (CONST grammar_imp all (CONST grammar_imp rest1 rest2))"
  "_resteq all" <= "_grarest (CONST grammar_imp all rest)"
  "_resteq all" <= "_resteq (CONST grammar_imp all rest)"
  "_firsteq all" <= "_firsteq (CONST grammar_imp all rest)"
  "_firsteq imp" <= "_firsteq (ALL x. imp)"
  "_resteq imp" <= "_resteq (ALL x. imp)"
  "_grafirst x t" <= "_firsteq (x = t)"
  "t" <= "_resteq (x = t)"

(*
thm expressions_grammar[no_vars]
thm (Grammar) expressions_grammar[no_vars]
thm (latex) expressions_grammar[no_vars]
thm (latex Grammar) expressions_grammar[no_vars]
*)

declare [[names_short]]

(*>*)
subsection {* Main definitions and theorems *}

text {*
For your convenience, the main definitions and theorems of the present work are assembled in this section. The following
formulas are mechanically pretty-printed versions of the statements as defined resp.\ proven in Isabelle.
Free variables are all-quantified. Some type conversion functions (like @{term_type set}) are omitted.
The relations @{text \<sharp>} and @{text "\<sharp>*"} come from the Nominal package and express freshness of the
variables on the left with regard to the expressions on the right.

\input{map.tex}
*}

subsubsection {* Expressions *}

text {*
The type @{typ var} of variables is abstract and provided by the Nominal package. All we know about
it is that it is countably infinite.
Expressions of type @{typ exp} are given by the following grammar:
\begin{alignatstar}{2}
@{term e} \Coloneqq {}& @{term "Lam [x]. e"} &\quad& \text{lambda abstraction}\\
\mid {} & @{term "App e x"} && \text{application}\\
\mid {} & @{term "Var x"} && \text{variable} \\
\mid {} & @{term "Let as e"} && \text{recursive let}
\end{alignatstar}
In the introduction we pretty-print expressions to match the notation in \cite{launchbury} and omit
the constructor names @{term Var}, @{term App}, @{text Lam} and @{term Let}. In the actual theories, these are visible.
These expressions are, due to the machinery of the Nominal package, actually alpha-equivalency classes, so @{thm alpha_test[no_vars]} holds provably. This differs from Launchbury's original definition, which expects distinctly-named expressions and performs explicit alpha-renaming in the semantics.

The type @{type heap} is an abbreviation for @{typ "(var \<times> exp) list"}. These are \emph{not} alpha-equivalency classes, i.e.\ we manage the bindings in heaps explicitly.
*}

subsubsection {* The natural semantics *}

text_raw {*
\newlength{\rulelen}
\setlength{\rulelen}{\linewidth}
\newlength{\rulenamelen}
\settowidth{\rulenamelen}{~{\sc Application}}
\addtolength{\rulelen}{-\rulenamelen}
*}

text {*
Launchbury's original semantics, extended with some technical overhead related to name binding,
is defined as follows:\\
%\begin{center}
\parbox[t]{\rulelen}{\centering@{thm[mode=Axiom] Launchbury.reds.Lambda[no_vars]}}~{\sc Lambda}\\[2ex]
\parbox[t]{\rulelen}{\centering@{thm[mode=Rule] Launchbury.reds.Application[no_vars]}}~{\sc Application}\\[2ex]
\parbox[t]{\rulelen}{\centering@{thm[mode=Rule] Launchbury.reds.Variable[no_vars]}}~{\sc Variable}\\[2ex]
\parbox[t]{\rulelen}{\centering@{thm[mode=Rule] Launchbury.reds.Let[no_vars]}}~{\sc Let}
%\end{center}
*}

subsubsection {* The stacked semantics *}

text {*
This is our modified semantics that allows the correctness theorem to go through without generalisation:\\
\parbox[t]{\rulelen}{\centering@{thm[mode=Axiom] LaunchburyStacked.reds.Lambda[no_vars]}}~{\sc Lambda}\\[2ex]
\parbox[t]{\rulelen}{\centering@{thm[mode=Rule] LaunchburyStacked.reds.Application[no_vars]}}~{\sc Application}\\[2ex]
\parbox[t]{\rulelen}{\centering@{thm[mode=Rule] LaunchburyStacked.reds.Variable[no_vars]}}~{\sc Variable}\\[2ex]
\parbox[t]{\rulelen}{\centering@{thm[mode=Rule] LaunchburyStacked.reds.Let[no_vars]}}~{\sc Let}
*}
subsubsection {* The denotational semantics *}

text {*
The value domain of the denotational semantics is the initial solution to
\[
D = [D \to D]_\bot
\]
as introduced in \cite{abramsky}. The type @{typ Value}, together with the bottom value @{term_type "\<bottom>::Value"}, the
injection @{term_type "Fn"} and the projection @{term "DUMMY \<down>Fn DUMMY"}@{text "::"}@{typeof "Fn_project"},
is constructed as a pointed chain-complete partial order from this equation by the HOLCF package.
The type of semantic environments, @{typ Env}, is an abbreviation for @{typ "var f\<rightharpoonup> Value"}.

The semantics of an expression @{term_type "e :: exp"} in an environment @{term "\<rho>"}@{text "::"}@{typ Env} is
written \mbox{@{term_type "Denotational.ESem e \<rho>"}} and defined by the following equations:
\begin{alignstar}
@{thm (lhs) Denotational.ESem.simps(1)[no_vars]} & = @{thm (rhs) Denotational.ESem.simps(1)[no_vars]} && \text{if } @{thm (prem 1) Denotational.ESem.simps(1)[no_vars]} \\
@{thm (lhs) Denotational.ESem.simps(2)[no_vars]} & = @{thm (rhs) Denotational.ESem.simps(2)[no_vars]} \\
@{thm (lhs) Denotational.ESem.simps(3)[no_vars]} & = @{thm (rhs) Denotational.ESem.simps(3)[no_vars]} \\
@{thm (lhs) Denotational.ESem.simps(4)[no_vars]} & = @{thm (rhs) Denotational.ESem.simps(4)[no_vars]} && \text{if } @{thm (prem 1) Denotational.ESem.simps(4)[no_vars]}.
\end{alignstar}
*}

text {*
We study two alternatives for the semantics @{term "Denotational.HSem \<Gamma> \<rho>"}@{text "::"}@{typ Env} of a
heap @{term "\<Gamma> :: heap"}@{text "::"}@{typ heap}
in an environment @{term "\<rho>"}@{text "::"}@{typ Env}. As this is used in denotations of a Let expression,
we have also two expression semantics. Their defining equations are, besides the choice of heap semantics, identical.

The first involves a least upper bound ($\sqcup$) and is defined by the recursive equation
\[ @{thm (concl) Denotational.HSem_eq[no_vars]}, \]
where the set in the index position indicates the expansion of the map to the given domain and
@{term "heapToEnv:: heap \<Rightarrow> (exp \<Rightarrow> Value) \<Rightarrow> Env"}@{text "::"}@{typ "heap \<Rightarrow> (exp \<Rightarrow> Value) \<Rightarrow> Env"}
maps the given expression semantics over the heap, producing a semantic environment.

The other, here shown with a superscript @{text "u"}, uses the right-sided update operator @{text "f++"}
and is defined by the recursive equation
\[ @{thm "Denotational-PropsUpd.HSem_eq"[no_vars]}. \]

The semantics of the heap in the empty environment @{term "fempty"} is abbreviated as @{abbrev "HSem_fempty \<Gamma>"}.

It is worth noting that the two semantics agree on expressions, i.e. @{thm HSem_join_update(1)[no_vars] },
but obviously not on heaps that bind variables that also occur in the environment.
*}

subsubsection {* Equivalences *}
text {*
The stacked semantics is equivalent to the original semantics in the following sense:
\begin{itemize}
\item If @{thm[mode=IfThen] (prem 1) forget_stack_nice[no_vars] } is derivable in the stacked semantics,
and @{term L} is chosen such that @{thm[mode=IfThen] (prem 2) forget_stack_nice[no_vars]} holds, then
 @{thm[mode=IfThen] (concl) forget_stack_nice[no_vars]} is derivable in the original semantics.
\item If @{thm[mode=IfThen] (prem 1) add_stack[no_vars]} is derivable in the original semantics and
@{term "x"} and @{term "\<Gamma>'"} are chosen such that @{thm[mode=IfThen] (prem 2) add_stack[no_vars]} and
@{thm[mode=IfThen] (prem 3) add_stack[no_vars]} holds, then  @{thm[mode=IfThen] (concl) add_stack[no_vars]}
is derivable in the stacked semantics.
\end{itemize}
*}

subsubsection {* Correctness *}
text {* The statement of correctness for the stacked semantics reads:
If @{thm [mode=IfThen] (prem 1) CorrectnessStacked.correctness[no_vars]} and, as a side condition,
@{thm [mode=IfThen] (prem 2) CorrectnessStacked.correctness[no_vars]} holds, then @{thm [mode=IfThen] (concl) CorrectnessStacked.correctness(1)[no_vars]}. *}

text {* By the stated equivalency, we obtain the correctness of the original semantics:
If \mbox{@{thm [mode=IfThen] (prem 1) Correctness.correctness(1)[no_vars]}} and, as a side condition,
@{thm [mode=IfThen] (prem 2) Correctness.correctness(1)[no_vars]} holds, then @{thm [mode=IfThen] (concl) Correctness.correctness(1)[no_vars]} and
 @{thm [mode=IfThen] (concl) Correctness.correctness(2)[no_vars]} *}

text {* The generalization introduced by Launchbury is true if the update-based semantics is chosen:
If @{thm [mode=IfThen] (prem 1) CorrectnessUpd.correctness(1)[no_vars]} and, as a side condition,
@{thm [mode=IfThen] (prem 2) CorrectnessUpd.correctness(1)[no_vars]} and
\mbox{@{thm [mode=IfThen] (prem 3) CorrectnessUpd.correctness(1)[no_vars]}} hold,
then @{thm [mode=IfThen] (concl) CorrectnessUpd.correctness(1)[no_vars]} and  @{thm [mode=IfThen] (concl) CorrectnessUpd.correctness(2)[no_vars]}. *}

(*<*)

end
(*>*)


(*  Title:      Native_Cast.thy
    Author:     Andreas Lochbihler, ETH Zurich
*)

chapter \<open>Conversions between unsigned words and between char\<close>

theory Native_Cast
  imports
  Uint8
  Uint16
  Uint32
  Uint64
begin

text \<open>Auxiliary stuff\<close>

lemma integer_of_char_char_of_integer [simp]:
  "integer_of_char (char_of_integer x) = x mod 256"
  by (simp add: integer_of_char_def char_of_integer_def)

lemma char_of_integer_integer_of_char [simp]:
  "char_of_integer (integer_of_char x) = x"
  by (simp add: integer_of_char_def char_of_integer_def)

lemma int_lt_numeral [simp]: "int x < numeral n \<longleftrightarrow> x < numeral n"
by (metis nat_numeral zless_nat_eq_int_zless)

lemma int_of_integer_ge_0: "0 \<le> int_of_integer x \<longleftrightarrow> 0 \<le> x"
including integer.lifting by transfer simp

lemma integer_of_char_ge_0 [simp]: "0 \<le> integer_of_char x"
  including integer.lifting unfolding integer_of_char_def
  by transfer (simp add: of_char_def)

section \<open>Conversion between native words\<close>

lift_definition uint8_of_uint16 :: "uint16 \<Rightarrow> uint8" is ucast .
lift_definition uint8_of_uint32 :: "uint32 \<Rightarrow> uint8" is ucast .
lift_definition uint8_of_uint64 :: "uint64 \<Rightarrow> uint8" is ucast .

lift_definition uint16_of_uint8 :: "uint8 \<Rightarrow> uint16" is ucast .
lift_definition uint16_of_uint32 :: "uint32 \<Rightarrow> uint16" is ucast .
lift_definition uint16_of_uint64 :: "uint64 \<Rightarrow> uint16" is ucast .

lift_definition uint32_of_uint8 :: "uint8 \<Rightarrow> uint32" is ucast .
lift_definition uint32_of_uint16 :: "uint16 \<Rightarrow> uint32" is ucast .
lift_definition uint32_of_uint64 :: "uint64 \<Rightarrow> uint32" is ucast .

lift_definition uint64_of_uint8 :: "uint8 \<Rightarrow> uint64" is ucast .
lift_definition uint64_of_uint16 :: "uint16 \<Rightarrow> uint64" is ucast .
lift_definition uint64_of_uint32 :: "uint32 \<Rightarrow> uint64" is ucast .

definition mask where "mask = (0xFFFFFFFF :: integer)"

code_printing
  constant uint8_of_uint16 \<rightharpoonup>
  (SML_word) "Word8.fromLarge (Word16.toLarge _)" and
  (Haskell) "(Prelude.fromIntegral _ :: Uint8.Word8)" and
  (Scala) "_.toByte"
| constant uint8_of_uint32 \<rightharpoonup>
  (SML) "Word8.fromLarge (Word32.toLarge _)" and
  (Haskell) "(Prelude.fromIntegral _ :: Uint8.Word8)" and
  (Scala) "_.toByte"
| constant uint8_of_uint64 \<rightharpoonup>
  (SML) "Word8.fromLarge (Uint64.toLarge _)" and
  (Haskell) "(Prelude.fromIntegral _ :: Uint8.Word8)" and
  (Scala) "_.toByte"
| constant uint16_of_uint8 \<rightharpoonup>
  (SML_word) "Word16.fromLarge (Word8.toLarge _)" and
  (Haskell) "(Prelude.fromIntegral _ :: Uint16.Word16)" and
  (Scala) "((_).toInt & 0xFF).toChar"
| constant uint16_of_uint32 \<rightharpoonup>
  (SML_word) "Word16.fromLarge (Word32.toLarge _)" and
  (Haskell) "(Prelude.fromIntegral _ :: Uint16.Word16)" and
  (Scala) "_.toChar"
| constant uint16_of_uint64 \<rightharpoonup>
  (SML_word) "Word16.fromLarge (Uint64.toLarge _)" and
  (Haskell) "(Prelude.fromIntegral _ :: Uint16.Word16)" and
  (Scala) "_.toChar"
| constant uint32_of_uint8 \<rightharpoonup>
  (SML) "Word32.fromLarge (Word8.toLarge _)" and
  (Haskell) "(Prelude.fromIntegral _ :: Uint32.Word32)" and
  (Scala) "((_).toInt & 0xFF)"
| constant uint32_of_uint16 \<rightharpoonup>
  (SML_word) "Word32.fromLarge (Word16.toLarge _)" and
  (Haskell) "(Prelude.fromIntegral _ :: Uint32.Word32)" and
  (Scala) "(_).toInt"
| constant uint32_of_uint64 \<rightharpoonup>
  (SML_word) "Word32.fromLarge (Uint64.toLarge _)" and
  (Haskell) "(Prelude.fromIntegral _ :: Uint32.Word32)" and
  (Scala) "(_).toInt" and
  (OCaml) "Int64.to'_int32"
| constant uint64_of_uint8 \<rightharpoonup>
  (SML_word) "Word64.fromLarge (Word8.toLarge _)" and
  (Haskell) "(Prelude.fromIntegral _ :: Uint64.Word64)" and
  (Scala) "((_).toLong & 0xFF)"
| constant uint64_of_uint16 \<rightharpoonup>
  (SML_word) "Word64.fromLarge (Word16.toLarge _)" and
  (Haskell) "(Prelude.fromIntegral _ :: Uint64.Word64)" and
  (Scala) "_.toLong"
| constant uint64_of_uint32 \<rightharpoonup>
  (SML_word) "Word64.fromLarge (Word32.toLarge _)" and
  (Haskell) "(Prelude.fromIntegral _ :: Uint64.Word64)" and
  (Scala) "((_).toLong & 0xFFFFFFFFL)" and
  (OCaml) "Int64.logand (Int64.of'_int32 _) (Int64.of'_string \"4294967295\")"

text \<open>
  Use @{const Abs_uint8'} etc. instead of @{const Rep_uint8} in code equations
  for conversion functions to avoid exceptions during code generation when the
  target language provides only some of the uint types.
\<close>

lemma uint8_of_uint16_code [code]:
  "uint8_of_uint16 x = Abs_uint8' (ucast (Rep_uint16' x))"
by transfer simp

lemma uint8_of_uint32_code [code]:
  "uint8_of_uint32 x = Abs_uint8' (ucast (Rep_uint32' x))"
by transfer simp

lemma uint8_of_uint64_code [code]:
  "uint8_of_uint64 x = Abs_uint8' (ucast (Rep_uint64' x))"
by transfer simp

lemma uint16_of_uint8_code [code]:
  "uint16_of_uint8 x = Abs_uint16' (ucast (Rep_uint8' x))"
by transfer simp

lemma uint16_of_uint32_code [code]:
  "uint16_of_uint32 x = Abs_uint16' (ucast (Rep_uint32' x))"
by transfer simp

lemma uint16_of_uint64_code [code]:
  "uint16_of_uint64 x = Abs_uint16' (ucast (Rep_uint64' x))"
by transfer simp

lemma uint32_of_uint8_code [code]:
  "uint32_of_uint8 x = Abs_uint32' (ucast (Rep_uint8' x))"
by transfer simp

lemma uint32_of_uint16_code [code]:
  "uint32_of_uint16 x = Abs_uint32' (ucast (Rep_uint16' x))"
by transfer simp

lemma uint32_of_uint64_code [code]:
  "uint32_of_uint64 x = Abs_uint32' (ucast (Rep_uint64' x))"
by transfer simp

lemma uint64_of_uint8_code [code]:
  "uint64_of_uint8 x = Abs_uint64' (ucast (Rep_uint8' x))"
by transfer simp

lemma uint64_of_uint16_code [code]:
  "uint64_of_uint16 x = Abs_uint64' (ucast (Rep_uint16' x))"
by transfer simp

lemma uint64_of_uint32_code [code]:
  "uint64_of_uint32 x = Abs_uint64' (ucast (Rep_uint32' x))"
by transfer simp

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 Memset
imports "AutoCorres.AutoCorres"
begin

external_file "memset.c"
install_C_file "memset.c"

autocorres [
  heap_abs_syntax,
  no_heap_abs=memset,
  no_signed_word_abs=memset,
  unsigned_word_abs=memset] "memset.c"

lemma c_guard_word8_ptr [simp]:
     "c_guard (x :: word8 ptr) = (x \<noteq> NULL)"
  apply (clarsimp simp: c_guard_def ptr_aligned_def c_null_guard_def)
  apply (metis Ptr_ptr_val first_in_intvl intvl_Suc not_less_eq ptr_val.ptr_val_def)
  done

lemma to_bytes_word8 [simp]: "to_bytes (a :: word8) x = [a]"
  by (clarsimp simp: to_bytes_def typ_info_word word_rsplit_same)

lemma heap_update_list_id [simp]:
    "heap_update_list x [] = (\<lambda>x. x)"
  apply (rule ext)
  apply simp
  done

lemma heap_update_heap_update_list:
   "\<lbrakk> ptr_val p = q + (of_nat (length l)); Suc (length l) < addr_card \<rbrakk> \<Longrightarrow>
      heap_update (p :: word8 ptr) v (heap_update_list q l s) = (heap_update_list q (l @ [v]) s)"
  apply (rule ext)
  apply (clarsimp simp: heap_update_def unat_of_nat
    addr_card word_bits_def fun_upd_def)
  apply (subst heap_update_list_value, clarsimp simp: addr_card)
  apply safe
   apply (subst if_P)
    apply (fastforce intro: intvlI)
   apply (clarsimp simp: unat_of_nat word_bits_def)
  apply (subst (1 2)  heap_update_list_value,
    simp add: addr_card,
    simp add: addr_card)
  apply (case_tac "x \<in> {q..+length l}")
   apply (subst if_P, simp)
   apply (subst if_P)
    apply clarsimp
    apply (metis (full_types) intvlD intvlI less_SucI)
   apply (subst nth_append, clarsimp)
   apply (metis (hide_lams, no_types) add_diff_cancel2 intvlD le_unat_uoi less_or_eq_imp_le not_le)
  apply clarsimp
  apply (metis intvlD intvlI less_antisym)
  done

lemma (in memset) memset:
  "\<forall>s\<^sub>0. \<lbrace> \<lambda>s. s = s\<^sub>0 \<and> n < addr_card \<and> 0 \<notin> {ptr_val p ..+ n} \<rbrace>
      memset' p c n
      \<lbrace> \<lambda>rv s. s = t_hrs_'_update (hrs_mem_update (
          heap_update_list (ptr_val p) (replicate n (scast c)))) s\<^sub>0 \<rbrace>!"
proof -
  {
     fix s0
     have "\<lbrace> \<lambda>s. s = s0 \<and> n < addr_card \<and> 0 \<notin> {ptr_val p ..+ n} \<rbrace>
                memset' p c n
          \<lbrace> \<lambda>rv s. s = t_hrs_'_update (hrs_mem_update
              (heap_update_list (ptr_val p) (replicate n (scast c)))) s0 \<rbrace>!"
      apply (rule validNF_assume_pre)
      apply (unfold memset'_def)
      apply (subst whileLoop_add_inv [where M="\<lambda>((d', n'), _). n'"
                and I="\<lambda>(d', n') s.
                   n' \<le> n \<and>
                   (n' \<le> n \<longrightarrow> d' = ptr_coerce p +\<^sub>p int (n - n')) \<and>
                   (n' \<le> n \<longrightarrow> s = t_hrs_'_update
                  (hrs_mem_update (heap_update_list (ptr_val p) (replicate (n - n') (scast c)))) s0)"])
      apply wp
        apply (clarsimp simp:)
        apply (intro conjI impI)
           apply arith
          apply (clarsimp simp: ptr_add_def)
         apply (rule globals.fold_congs, simp, simp)
         apply (clarsimp simp: hrs_mem_update_def)
         apply (subst heap_update_heap_update_list)
           apply (clarsimp simp: ptr_add_def)
          apply (clarsimp)
          apply arith
         apply (metis diff_Suc_diff_eq2 diff_diff_left minus_nat.diff_0 replicate_Suc_append)
        apply (clarsimp simp: ptr_add_def)
        apply (metis (hide_lams, no_types) add_less_cancel_right add.left_neutral intvl_inter_le le0 le_add_diff_inverse of_nat_diff semiring_1_class.of_nat_0)
       apply clarsimp
      apply (clarsimp simp: hrs_mem_update_def)
      done
  }

  thus ?thesis
    by simp
qed

lemma word_rsplit_sword_0 [simplified, simp]:
  "word_rsplit (0 :: addr_bitsize signed word) = replicate (size_of TYPE(addr)) (0 :: word8)"
  apply (simp add: word_rsplit_def bin_rsplit_def Let_def)
  done

lemma word_rsplit_word_0 [simplified, simp]:
  "word_rsplit (0 :: addr_bitsize word) = replicate (size_of TYPE(addr)) (0 :: word8)"
  apply (simp add: word_rsplit_def bin_rsplit_def Let_def)
  done

lemma heap_update_zero_node [simplified]:
  "heap_update_list p (replicate (size_of TYPE(node_C)) 0) = heap_update (Ptr p) (node_C NULL 0)"
  apply (rule ext)
  apply (clarsimp simp: heap_update_def to_bytes_def)
  apply (subst packed_type_access_ti, simp)
  apply (clarsimp simp: access_ti\<^sub>0_def)
  apply (clarsimp simp: to_bytes_def to_bytes_p_def node_C_tag_def node_C_typ_tag)
  apply (subst final_pad_def)
  apply (clarsimp simp: typ_info_word size_td_lt_ti_typ_pad_combine Let_def padup_def)
  apply (clarsimp simp: ti_typ_pad_combine_def)
  apply (clarsimp simp: ti_typ_combine_def empty_typ_info_def typ_info_ptr typ_info_word)
  done

lemma (in memset) is_valid_node_C_non_NULL [simp]:
  "is_valid_node_C (lift_global_heap s) p \<Longrightarrow> 0 \<notin> {ptr_val p ..+ size_of TYPE(node_C)}"
  by (auto simp: lift_global_heap_def c_guard_def c_null_guard_def dest: simple_lift_c_guard)

lemma (in memset) zero_node:
  "\<forall>s\<^sub>0. \<lbrace> \<lambda>s. is_valid_node_C s p \<and> s = s\<^sub>0\<rbrace> zero_node' p \<lbrace> \<lambda>rv s. s = s\<^sub>0[p := (node_C NULL 0) ] \<rbrace>! "
  including nf_no_pre
  apply (clarsimp simp: zero_node'_def)
  apply (wp add: memset [THEN validNF_make_schematic_post, simplified])
  apply (fastforce dest: simple_lift_c_guard is_valid_node_C_non_NULL
                   simp: addr_card lift_global_heap_def heap_update_zero_node
                         memset.update_node_def typ_simple_heap_simps fun_upd_def)
  done

end