theory LR3_Compressed
  imports Compressed_Oracles.CO_Invariants General_Luby_Rackoff
begin

(* U_UP,i, using compressed queries *)
definition UPc :: \<open>(whole \<times> whole \<times> db) ell2 \<Rightarrow>\<^sub>C\<^sub>L (whole \<times> whole \<times> db) ell2\<close> where \<open>UPc =
  (reg_1_3 o Fst; reg_2_3 o Snd) cnot o\<^sub>C\<^sub>L
  (reg_1_3 o Snd; reg_2_3 o Fst) cnot o\<^sub>C\<^sub>L
  (reg_1_3 o Fst; (reg_2_3 o Fst; reg_3_3)) query\<close>
(* U_UP,i, using compressed queries, query' variant *)
(* We probably will only use this one because we want to use preserve_query1'_fixY_output which is only available for query *)
definition UPc' :: \<open>(whole \<times> whole \<times> db) ell2 \<Rightarrow>\<^sub>C\<^sub>L (whole \<times> whole \<times> db) ell2\<close> where \<open>UPc' =
  (reg_1_3 o Fst; reg_2_3 o Snd) cnot o\<^sub>C\<^sub>L
  (reg_1_3 o Snd; reg_2_3 o Fst) cnot o\<^sub>C\<^sub>L
  (reg_1_3 o Fst; (reg_2_3 o Fst; reg_3_3)) query'\<close>

(* LR3 using compressed oracles *)
definition LR3c where \<open>LR3c =
  (X;(X1;D1)) UPc o\<^sub>C\<^sub>L (X1;(X2;D2)) UPc o\<^sub>C\<^sub>L (X2;(Y;D3)) UPc o\<^sub>C\<^sub>L (X1;(X2;D2)) UPc o\<^sub>C\<^sub>L (X;(X1;D1)) UPc\<close>
definition LR3c' where \<open>LR3c' =
  (X;(X1;D1)) UPc' o\<^sub>C\<^sub>L (X1;(X2;D2)) UPc' o\<^sub>C\<^sub>L (X2;(Y;D3)) UPc' o\<^sub>C\<^sub>L (X1;(X2;D2)) UPc' o\<^sub>C\<^sub>L (X;(X1;D1)) UPc'\<close>

(* Notion of good from the current eprint of the LR4-paper. Note: uniqueness condition missing. *)
definition old_good where \<open>old_good D1 D2 D3 \<longleftrightarrow> (\<forall>x2L \<in> dom D3. \<exists>xL\<in>dom D1. \<exists>\<beta>\<in>ran D2. x2L = xL + \<beta>)\<close>
  for D1 D2 D3 :: db

(* Notion of good from the current eprint of the LR4-paper, more intuitive formulation *)
lemma old_good_alt_def: \<open>old_good D1 D2 D3 \<longleftrightarrow> (\<forall>x2L \<in> dom D3. \<exists>xL xR. do { (x2L',x2R) \<leftarrow> LR2 D1 D2 (xL,xR); Some (x2L=x2L') } = Some True)\<close>
  for D1 D2 D3
proof (unfold old_good_def; intro iffI ballI)
  fix x2L assume x2L_D3: \<open>x2L \<in> dom D3\<close>
  assume \<open>\<forall>x2L\<in>dom D3. \<exists>xL\<in>dom D1. \<exists>\<beta>\<in>ran D2. x2L = xL + \<beta>\<close>
  from this[rule_format, OF x2L_D3]
  obtain xL \<beta> where \<open>xL \<in> dom D1\<close> \<open>\<beta> \<in> ran D2\<close> \<open>x2L = xL + \<beta>\<close>
    by auto
  from \<open>xL \<in> dom D1\<close> obtain \<alpha> where [simp]: \<open>D1 xL = Some \<alpha>\<close>
    by force
  from \<open>\<beta> \<in> ran D2\<close> obtain D2_in where [simp]: \<open>D2 D2_in = Some \<beta>\<close>
    by (smt (verit, del_insts) mem_Collect_eq ran_def)
  have \<open>LR2 D1 D2 (xL, D2_in + \<alpha>) \<bind> (\<lambda>(x2L', x2R). Some (x2L = x2L')) = Some True\<close>
    using \<open>x2L = xL + \<beta>\<close> by (auto simp: LR2_def)
  then show \<open>\<exists>xL xR. LR2 D1 D2 (xL, xR) \<bind> (\<lambda>(x2L', x2R). Some (x2L = x2L')) = Some True\<close>
    by auto
next
  fix x2L assume x2L_D3: \<open>x2L \<in> dom D3\<close>
  assume \<open>\<forall>x2L\<in>dom D3. \<exists>xL xR. LR2 D1 D2 (xL, xR) \<bind> (\<lambda>(x2L', x2R). Some (x2L = x2L')) = Some True\<close>
  from this[rule_format, OF x2L_D3]
  show \<open>\<exists>xL\<in>dom D1. \<exists>\<beta>\<in>ran D2. x2L = xL + \<beta>\<close>
    by (smt (z3) LR2_def bind_eq_Some_conv domI old.prod.case option.inject ranI)
qed

definition x1_x2_00 :: \<open>state set\<close> where \<open>x1_x2_00 = {(x,0,0,y,D1,D2,D3)| x y D1 D2 D3. True}\<close>
definition x2_0 :: \<open>state set\<close> where \<open>x2_0 = {(x,x1,0,y,D1,D2,D3)| x x1 y D1 D2 D3. True}\<close>

(* definition old_good_state_00 :: \<open>state set\<close> where \<open>old_good_state_00 = {(x,0,0,y,D1,D2,D3)| x y D1 D2 D3. old_good D1 D2 D3}\<close> *)
(* definition old_good_state_0 :: \<open>state set\<close> where \<open>old_good_state_0 = {(x,x1,0,y,D1,D2,D3)| x x1 y D1 D2 D3. old_good D1 D2 D3}\<close> *)
definition old_good_state :: \<open>state set\<close> where \<open>old_good_state = {(x,x1,x2,y,D1,D2,D3). old_good D1 D2 D3}\<close>

abbreviation \<open>old_good_state_00 \<equiv> old_good_state \<inter> x1_x2_00\<close> (* TODO remove *)
abbreviation \<open>old_good_state_0 \<equiv> old_good_state \<inter> x2_0\<close> (* TODO remove *)

definition \<open>co1_old_good = 2 / sqrt N\<close>
lemma preserves_co1_old_good:
  \<open>preserves_ket ((X o Fst; (X1 o Fst; D1)) query) old_good_state_00 old_good_state_0 co1_old_good\<close>
proof -
  define K :: \<open>(half\<times>half\<times>whole\<times>db\<times>db\<times>db) \<Rightarrow> state ell2 ccsubspace\<close>
    where \<open>K = (\<lambda>(xL,xR,y,D1',D2,D3).
          ket_invariant {((xL,xR),(x1L,0),0,y,D1'(xL:=d),D2,D3) | x1L d. True})\<close>
  define M :: \<open>(half\<times>half\<times>whole\<times>db\<times>db\<times>db) set\<close> where
    \<open>M = {(xL,xR,y,D1',D2,D3). D1' xL = None \<and> (\<exists>d. old_good (D1'(xL:=d)) D2 D3)}\<close>

  define I1 J1 :: \<open>(half\<times>half\<times>whole\<times>db\<times>db\<times>db) \<Rightarrow> (half \<times> half option) set\<close>
    where \<open>I1 = (\<lambda>(xL,xR,y,D1',D2,D3).
          {0} \<times> {d. old_good (D1'(xL:=d)) D2 D3})\<close>
      and \<open>J1 = (\<lambda>(xL,xR,y,D1',D2,D3).
          UNIV \<times> {d. old_good (D1'(xL:=d)) D2 D3})\<close>

  show ?thesis
  proof (rule inv_split_reg_query[where X=\<open>X o Fst\<close> and Y=\<open>X1 o Fst\<close> and H=\<open>D1\<close> and K=K
        and ?I1.0=\<open>\<lambda>z. ket_invariant (I1 z)\<close> and ?J1.0=\<open>\<lambda>z. ket_invariant (J1 z)\<close>])
    show \<open>(X \<circ> Fst;(X1 \<circ> Fst;D1)) query = (X \<circ> Fst;(X1 \<circ> Fst;D1)) query\<close>
      by simp
    show [simp]: \<open>compatible (X \<circ> Fst) (X1 \<circ> Fst)\<close> \<open>compatible (X \<circ> Fst) D1\<close> \<open>compatible (X1 \<circ> Fst) D1\<close>
      by simp_all
    show \<open>compatible_register_invariant (X1 \<circ> Fst) (K z)\<close> for z
      apply (cases z, hypsubst_thin)
      by (auto simp add: K_def X1_def comp_assoc
          intro!: compatible_register_invariant_Snd_comp compatible_register_invariant_Fst compatible_register_invariant_Fst_comp)
    show \<open>compatible_register_invariant (D1 \<circ> function_at (fst z)) (K z)\<close> for z
      by (auto simp add: K_def D1_def comp_assoc case_prod_beta
          intro!: compatible_register_invariant_Snd_comp compatible_register_invariant_Fst compatible_register_invariant_Fst_comp
          compatible_register_invariant_function_at)
    show \<open>ket_invariant old_good_state_00 \<le> (SUP z\<in>M. K z \<sqinter> lift_invariant (X1 \<circ> Fst;D1 \<circ> function_at (fst z)) (ket_invariant (I1 z)))\<close>
      apply (auto simp add: K_def D1_def lift_Fst_ket_inv ket_invariant_inter ket_invariant_SUP[symmetric] I1_def
          old_good_state_def x1_x2_00_def case_prod_beta comp_assoc X1_def M_def zero_prod_def
          lift_inv_prod lift_invariant_comp lift_invariant_function_at_ket_inv lift_Snd_ket_inv)
      by (metis fun_upd_same fun_upd_triv fun_upd_upd)
    show \<open>K z \<sqinter> lift_invariant (X1 \<circ> Fst;D1 \<circ> function_at (fst z)) (ket_invariant (J1 z)) \<le> ket_invariant old_good_state_0\<close>
      if \<open>z\<in>M\<close> for z
      using that
      apply (cases z, hypsubst_thin)
      by (auto simp add: K_def lift_Fst_ket_inv ket_invariant_inter ket_invariant_SUP[symmetric] J1_def
          case_prod_beta D1_def comp_assoc X1_def old_good_state_def x2_0_def M_def
          lift_inv_prod lift_invariant_comp lift_invariant_function_at_ket_inv reg_3_3_def lift_Snd_ket_inv)
    show \<open>orthogonal_spaces (K z) (K z')\<close> if \<open>z\<in>M\<close> \<open>z'\<in>M\<close> \<open>z \<noteq> z'\<close> for z z'
      apply (cases z; cases z')
      using that apply (auto simp: K_def M_def)
      by (metis fun_upd_triv fun_upd_upd)
    show \<open>K z \<le> lift_invariant (X \<circ> Fst) (ket_invariant {fst z})\<close> for z
      by (auto simp: K_def X_def lift_Fst_ket_inv lift_invariant_comp case_prod_beta)
    show [simp]: \<open>0 \<le> co1_old_good\<close>
      by (simp add: co1_old_good_def)
    show \<open>preserves_ket query1 (I1 z) (J1 z) co1_old_good\<close> if \<open>z\<in>M\<close> for z
    proof (cases z)
      case (fields xL xR y D1' D2 D3)
      from that have D1'xL: \<open>D1' xL = None\<close>
        by (auto simp: M_def fields)
      show ?thesis
      proof (cases \<open>old_good D1' D2 D3\<close>)
        case True
        show ?thesis
          apply (simp only: case_prod_beta I1_def J1_def fst_conv snd_conv fields)
        proof (rule preserve_query1_fixY[where b\<^sub>i=N and b\<^sub>j\<^sub>0=0])
          show \<open>{d. old_good (D1'(xL := d)) D2 D3} \<subseteq> {d. old_good (D1'(xL := d)) D2 D3}\<close> by simp
          show \<open>card (Some -` {d. old_good (D1'(xL := d)) D2 D3}) \<le> N\<close> by (simp add: card_mono)
          show \<open>card (- Some -` {d. old_good (D1'(xL := d)) D2 D3}) \<le> 0\<close>
            using True D1'xL apply auto
            by (simp add: old_good_def)
          have *: \<open>old_good (D1'(xL := None)) D2 D3\<close>
            by (simp add: D1'xL True domIff)
          show \<open>preserve_query1_fixY_bound
             (None \<in> {d. old_good (D1'(xL := d)) D2 D3}) (None \<notin> {d. old_good (D1'(xL := d)) D2 D3})
             (real N) (real 0) \<le> co1_old_good\<close>
            by (simp add: * preserve_query1_fixY_bound_def)
        qed
      next
        case False
        show ?thesis
          apply (simp only: case_prod_beta I1_def J1_def fst_conv snd_conv fields)
        proof (rule preserve_query1_fixY[where b\<^sub>i=N and b\<^sub>j\<^sub>0=0])
          show \<open>{d. old_good (D1'(xL := d)) D2 D3} \<subseteq> {d. old_good (D1'(xL := d)) D2 D3}\<close> by simp
          show \<open>card (Some -` {d. old_good (D1'(xL := d)) D2 D3}) \<le> N\<close>
            by (simp add: card_mono)
          show \<open>card (- Some -` {d. old_good (D1'(xL := d)) D2 D3}) \<le> 0\<close>
            using False \<open>z\<in>M\<close>
            apply (auto simp: M_def fields old_good_def)
            by (metis DiffE domI insert_iff)
          have *: \<open>\<not> old_good (D1'(xL := None)) D2 D3\<close>
            by (simp add: D1'xL False domIff)
          show \<open>preserve_query1_fixY_bound (None \<in> {d. old_good (D1'(xL := d)) D2 D3}) (None \<notin> {d. old_good (D1'(xL := d)) D2 D3})
                     (real N) (real 0) \<le> co1_old_good\<close>
            apply (auto simp add: * preserve_query1_fixY_bound_def co1_old_good_def)
            by (simp add: inverse_eq_divide sqrt_divide_self_eq)
        qed
      qed
    qed
  qed
qed

definition \<open>co1'_old_good = 2 / sqrt N\<close>
lemma preserves_co1'_old_good:
  \<open>preserves_ket ((X o Fst; (X1 o Fst; D1)) query') old_good_state_00 old_good_state_0 co1'_old_good\<close>
proof -
  define K :: \<open>(half\<times>half\<times>whole\<times>db\<times>db\<times>db) \<Rightarrow> state ell2 ccsubspace\<close>
    where \<open>K = (\<lambda>(xL,xR,y,D1',D2,D3).
          ket_invariant {((xL,xR),(x1L,0),0,y,D1'(xL:=d),D2,D3) | x1L d. True})\<close>
  define M :: \<open>(half\<times>half\<times>whole\<times>db\<times>db\<times>db) set\<close> where
    \<open>M = {(xL,xR,y,D1',D2,D3). D1' xL = None \<and> (\<exists>d. old_good (D1'(xL:=d)) D2 D3)}\<close>

  define I1 J1 :: \<open>(half\<times>half\<times>whole\<times>db\<times>db\<times>db) \<Rightarrow> (half \<times> half option) set\<close>
    where \<open>I1 = (\<lambda>(xL,xR,y,D1',D2,D3).
          {0} \<times> {d. old_good (D1'(xL:=d)) D2 D3})\<close>
      and \<open>J1 = (\<lambda>(xL,xR,y,D1',D2,D3).
          UNIV \<times> {d. old_good (D1'(xL:=d)) D2 D3})\<close>

  show ?thesis
  proof (rule inv_split_reg_query'[where X=\<open>X o Fst\<close> and Y=\<open>X1 o Fst\<close> and H=\<open>D1\<close> and K=K
        and ?I1.0=\<open>\<lambda>z. ket_invariant (I1 z)\<close> and ?J1.0=\<open>\<lambda>z. ket_invariant (J1 z)\<close>])
    show \<open>(X \<circ> Fst;(X1 \<circ> Fst;D1)) query' = (X \<circ> Fst;(X1 \<circ> Fst;D1)) query'\<close>
      by simp
    show [simp]: \<open>compatible (X \<circ> Fst) (X1 \<circ> Fst)\<close> \<open>compatible (X \<circ> Fst) D1\<close> \<open>compatible (X1 \<circ> Fst) D1\<close>
      by simp_all
    show \<open>compatible_register_invariant (X1 \<circ> Fst) (K z)\<close> for z
      apply (cases z, hypsubst_thin)
      by (auto simp add: K_def X1_def comp_assoc
          intro!: compatible_register_invariant_Snd_comp compatible_register_invariant_Fst compatible_register_invariant_Fst_comp)
    show \<open>compatible_register_invariant (D1 \<circ> function_at (fst z)) (K z)\<close> for z
      by (auto simp add: K_def D1_def comp_assoc case_prod_beta
          intro!: compatible_register_invariant_Snd_comp compatible_register_invariant_Fst compatible_register_invariant_Fst_comp
          compatible_register_invariant_function_at)
    show \<open>ket_invariant old_good_state_00 \<le> (SUP z\<in>M. K z \<sqinter> lift_invariant (X1 \<circ> Fst;D1 \<circ> function_at (fst z)) (ket_invariant (I1 z)))\<close>
      apply (auto simp add: K_def D1_def lift_Fst_ket_inv ket_invariant_inter ket_invariant_SUP[symmetric] I1_def
          old_good_state_def x1_x2_00_def case_prod_beta comp_assoc X1_def M_def zero_prod_def
          lift_inv_prod lift_invariant_comp lift_invariant_function_at_ket_inv lift_Snd_ket_inv)
      by (metis fun_upd_same fun_upd_triv fun_upd_upd)
    show \<open>K z \<sqinter> lift_invariant (X1 \<circ> Fst;D1 \<circ> function_at (fst z)) (ket_invariant (J1 z)) \<le> ket_invariant old_good_state_0\<close>
      if \<open>z\<in>M\<close> for z
      using that
      apply (cases z, hypsubst_thin)
      by (auto simp add: K_def lift_Fst_ket_inv ket_invariant_inter ket_invariant_SUP[symmetric] J1_def
          case_prod_beta D1_def comp_assoc X1_def old_good_state_def x2_0_def M_def
          lift_inv_prod lift_invariant_comp lift_invariant_function_at_ket_inv reg_3_3_def lift_Snd_ket_inv)
    show \<open>orthogonal_spaces (K z) (K z')\<close> if \<open>z\<in>M\<close> \<open>z'\<in>M\<close> \<open>z \<noteq> z'\<close> for z z'
      apply (cases z; cases z')
      using that apply (auto simp: K_def M_def)
      by (metis fun_upd_triv fun_upd_upd)
    show \<open>K z \<le> lift_invariant (X \<circ> Fst) (ket_invariant {fst z})\<close> for z
      by (auto simp: K_def X_def lift_Fst_ket_inv lift_invariant_comp case_prod_beta)
    show [simp]: \<open>0 \<le> co1'_old_good\<close>
      by (simp add: co1'_old_good_def)
    show \<open>preserves_ket query1' (I1 z) (J1 z) co1'_old_good\<close> if \<open>z\<in>M\<close> for z
    proof (cases z)
      case (fields xL xR y D1' D2 D3)
      from that have D1'xL: \<open>D1' xL = None\<close>
        by (auto simp: M_def fields)
      show ?thesis
      proof (cases \<open>old_good D1' D2 D3\<close>)
        case True
        show ?thesis
          apply (simp only: case_prod_beta I1_def J1_def fst_conv snd_conv fields)
        proof (rule preserve_query1'_fixY[where b\<^sub>i=N and b\<^sub>j\<^sub>0=0])
          show \<open>{d. old_good (D1'(xL := d)) D2 D3} \<subseteq> {d. old_good (D1'(xL := d)) D2 D3}\<close> by simp
          show \<open>card (Some -` {d. old_good (D1'(xL := d)) D2 D3}) \<le> N\<close> by (simp add: card_mono)
          show \<open>card (- Some -` {d. old_good (D1'(xL := d)) D2 D3}) \<le> 0\<close>
            using True D1'xL apply auto
            by (simp add: old_good_def)
          have *: \<open>old_good (D1'(xL := None)) D2 D3\<close>
            by (simp add: D1'xL True domIff)
          show \<open>preserve_query1'_fixY_bound
             (None \<in> {d. old_good (D1'(xL := d)) D2 D3}) (None \<notin> {d. old_good (D1'(xL := d)) D2 D3})
             (real N) (real 0) \<le> co1'_old_good\<close>
            by (simp add: * preserve_query1'_fixY_bound_def)
        qed
      next
        case False
        show ?thesis
          apply (simp only: case_prod_beta I1_def J1_def fst_conv snd_conv fields)
        proof (rule preserve_query1'_fixY[where b\<^sub>i=N and b\<^sub>j\<^sub>0=0])
          show \<open>{d. old_good (D1'(xL := d)) D2 D3} \<subseteq> {d. old_good (D1'(xL := d)) D2 D3}\<close> by simp
          show \<open>card (Some -` {d. old_good (D1'(xL := d)) D2 D3}) \<le> N\<close>
            by (simp add: card_mono)
          show \<open>card (- Some -` {d. old_good (D1'(xL := d)) D2 D3}) \<le> 0\<close>
            using False \<open>z\<in>M\<close>
            apply (auto simp: M_def fields old_good_def)
            by (metis DiffE domI insert_iff)
          have *: \<open>\<not> old_good (D1'(xL := None)) D2 D3\<close>
            by (simp add: D1'xL False domIff)
          show \<open>preserve_query1'_fixY_bound (None \<in> {d. old_good (D1'(xL := d)) D2 D3}) (None \<notin> {d. old_good (D1'(xL := d)) D2 D3})
                     (real N) (real 0) \<le> co1'_old_good\<close>
            apply (auto simp add: * preserve_query1'_fixY_bound_def co1'_old_good_def)
            by (simp add: inverse_eq_divide sqrt_divide_self_eq)
        qed
      qed
    qed
  qed
qed

definition \<open>UPc1_old_good = co1_old_good\<close>
lemma preserves_UPc1_old_good:
  \<open>preserves_ket ((X;(X1;D1)) UPc) old_good_state_00 old_good_state_0 UPc1_old_good\<close>
proof -
  note comp_apply[simp del]

  have UPc: \<open>((X;(X1;D1)) UPc) =
      (X o Fst; X1 o Snd) cnot o\<^sub>C\<^sub>L (X \<circ> Snd; X1 \<circ> Fst) cnot o\<^sub>C\<^sub>L (X \<circ> Fst; (X1 \<circ> Fst; D1)) query\<close>
    by (simp add: UPc_def reg_1_3_def reg_2_3_def reg_3_3_def register_pair_Fst register_pair_Snd
        flip: register_mult comp_assoc register_comp_pair
        o_apply[where x=cnot and f=\<open>(X;(X1;D1))\<close>] o_apply[where x=query and f=\<open>(X;(X1;D1))\<close>])

  have \<open>preserves_ket ((X \<circ> Fst; (X1 \<circ> Fst; D1)) query) old_good_state_00 old_good_state_0 co1_old_good\<close>
    by (rule preserves_co1_old_good)
  also have \<open>preserves_ket ((X \<circ> Snd; X1 \<circ> Fst) cnot) old_good_state_0 old_good_state_0 0\<close>
    apply (rule preserves_compatible[where U=cnot])
    by (auto simp add: old_good_state_def x2_0_def X_def X1_def comp_assoc
        intro!: compatible_register_invariant_pair compatible_register_invariant_Fst_comp
        compatible_register_invariant_Snd_comp)
  also have \<open>preserves_ket ((X \<circ> Fst; X1 \<circ> Snd) cnot) old_good_state_0 old_good_state_0 0\<close>
    apply (rule preserves_compatible[where U=cnot])
    by (auto simp add: old_good_state_def x2_0_def X_def X1_def comp_assoc
        intro!: compatible_register_invariant_pair compatible_register_invariant_Fst_comp
        compatible_register_invariant_Snd_comp)
  finally show ?thesis
    by (auto simp add: UPc1_old_good_def UPc cblinfun_compose_assoc register_norm)
qed

definition \<open>UPc1'_old_good = co1'_old_good\<close>
lemma preserves_UPc1'_old_good:
  \<open>preserves_ket ((X;(X1;D1)) UPc') old_good_state_00 old_good_state_0 UPc1'_old_good\<close>
proof -
  note comp_apply[simp del]

  have UPc: \<open>((X;(X1;D1)) UPc') =
      (X o Fst; X1 o Snd) cnot o\<^sub>C\<^sub>L (X \<circ> Snd; X1 \<circ> Fst) cnot o\<^sub>C\<^sub>L (X \<circ> Fst; (X1 \<circ> Fst; D1)) query'\<close>
    by (simp add: UPc'_def reg_1_3_def reg_2_3_def reg_3_3_def register_pair_Fst register_pair_Snd
        flip: register_mult comp_assoc register_comp_pair
        o_apply[where x=cnot and f=\<open>(X;(X1;D1))\<close>] o_apply[where x=query' and f=\<open>(X;(X1;D1))\<close>])

  have \<open>preserves_ket ((X \<circ> Fst; (X1 \<circ> Fst; D1)) query') old_good_state_00 old_good_state_0 co1'_old_good\<close>
    by (rule preserves_co1'_old_good)
  also have \<open>preserves_ket ((X \<circ> Snd; X1 \<circ> Fst) cnot) old_good_state_0 old_good_state_0 0\<close>
    apply (rule preserves_compatible[where U=cnot])
    by (auto simp add: old_good_state_def x2_0_def X_def X1_def comp_assoc
        intro!: compatible_register_invariant_pair compatible_register_invariant_Fst_comp
        compatible_register_invariant_Snd_comp)
  also have \<open>preserves_ket ((X \<circ> Fst; X1 \<circ> Snd) cnot) old_good_state_0 old_good_state_0 0\<close>
    apply (rule preserves_compatible[where U=cnot])
    by (auto simp add: old_good_state_def x2_0_def X_def X1_def comp_assoc
        intro!: compatible_register_invariant_pair compatible_register_invariant_Fst_comp
        compatible_register_invariant_Snd_comp)
  finally show ?thesis
    by (auto simp add: UPc1'_old_good_def UPc cblinfun_compose_assoc register_norm)
qed

definition num_queries_D1 :: \<open>nat \<Rightarrow> state set\<close> where \<open>num_queries_D1 q = {(x,x1,x2,y,D1,D2,D3). card (dom D1) \<le> q}\<close>

(* TODO: preservation lemma for num_queries_1 *)

definition \<open>co2'_old_good q = 2 * sqrt q / N  +  2 * sqrt q / sqrt N  +  1 / sqrt N\<close>
lemma preserves_co2'_old_good:
  \<open>preserves_ket ((X1 o Fst; (X2 o Fst; D2)) query') (old_good_state_0 \<inter> num_queries_D1 q) old_good_state (co2'_old_good q)\<close>
proof -
  define K :: \<open>(half\<times>half\<times>whole\<times>whole\<times>db\<times>db\<times>db) \<Rightarrow> state ell2 ccsubspace\<close>
    where \<open>K = (\<lambda>(x1L,x1R,x,y,D1,D2',D3).
          ket_invariant {(x,(x1L,x1R),(x2L,0),y,D1,D2'(x1L:=d),D3) | x2L d. True})\<close>
  define M :: \<open>(half\<times>half\<times>whole\<times>whole\<times>db\<times>db\<times>db) set\<close> where
    \<open>M = {(x1L,x1R,x,y,D1,D2',D3). D2' x1L = None \<and> (\<exists>d. old_good D1 (D2'(x1L:=d)) D3) \<and> card (dom D1) \<le> q}\<close>

  define I1 J1 :: \<open>(half\<times>half\<times>whole\<times>whole\<times>db\<times>db\<times>db) \<Rightarrow> (half \<times> half option) set\<close>
    where \<open>I1 = (\<lambda>(x1L,x1R,x,y,D1,D2',D3).
          {0} \<times> {d. old_good D1 (D2'(x1L:=d)) D3})\<close>
      and \<open>J1 = (\<lambda>(x1L,x1R,x,y,D1,D2',D3).
          UNIV \<times> {d. old_good D1 (D2'(x1L:=d)) D3})\<close>

  show ?thesis
  proof (rule inv_split_reg_query'[where X=\<open>X1 o Fst\<close> and Y=\<open>X2 o Fst\<close> and H=\<open>D2\<close> and K=K
        and ?I1.0=\<open>\<lambda>z. ket_invariant (I1 z)\<close> and ?J1.0=\<open>\<lambda>z. ket_invariant (J1 z)\<close>])
    show \<open>(X1 \<circ> Fst;(X2 \<circ> Fst;D2)) query' = (X1 \<circ> Fst;(X2 \<circ> Fst;D2)) query'\<close>
      by simp
    show [simp]: \<open>compatible (X1 \<circ> Fst) (X2 \<circ> Fst)\<close> \<open>compatible (X1 \<circ> Fst) D2\<close> \<open>compatible (X2 \<circ> Fst) D2\<close>
      by simp_all
    show \<open>compatible_register_invariant (X2 \<circ> Fst) (K z)\<close> for z
      apply (cases z, hypsubst_thin)
      by (auto simp add: K_def X2_def comp_assoc
          intro!: compatible_register_invariant_Snd_comp compatible_register_invariant_Fst compatible_register_invariant_Fst_comp)
    show \<open>compatible_register_invariant (D2 \<circ> function_at (fst z)) (K z)\<close> for z
      by (auto simp add: K_def D2_def comp_assoc case_prod_beta
          intro!: compatible_register_invariant_Snd_comp compatible_register_invariant_Fst compatible_register_invariant_Fst_comp
          compatible_register_invariant_function_at)
    show \<open>ket_invariant (old_good_state_0 \<inter> num_queries_D1 q) \<le> (SUP z\<in>M. K z \<sqinter> lift_invariant (X2 \<circ> Fst;D2 \<circ> function_at (fst z)) (ket_invariant (I1 z)))\<close>
      apply (auto simp add: K_def D2_def lift_Fst_ket_inv ket_invariant_inter ket_invariant_SUP[symmetric] I1_def
          old_good_state_def x2_0_def case_prod_beta comp_assoc X2_def M_def zero_prod_def num_queries_D1_def
          lift_inv_prod lift_invariant_comp lift_invariant_function_at_ket_inv lift_Snd_ket_inv)
      by (metis fun_upd_same fun_upd_triv fun_upd_upd)
    show \<open>K z \<sqinter> lift_invariant (X2 \<circ> Fst;D2 \<circ> function_at (fst z)) (ket_invariant (J1 z)) \<le> ket_invariant old_good_state\<close>
      if \<open>z\<in>M\<close> for z
      using that
      apply (cases z, hypsubst_thin)
      by (auto simp add: K_def lift_Fst_ket_inv ket_invariant_inter ket_invariant_SUP[symmetric] J1_def
          case_prod_beta D2_def comp_assoc X2_def old_good_state_def M_def
          lift_inv_prod lift_invariant_comp lift_invariant_function_at_ket_inv reg_3_3_def lift_Snd_ket_inv)
    show \<open>orthogonal_spaces (K z) (K z')\<close> if \<open>z\<in>M\<close> \<open>z'\<in>M\<close> \<open>z \<noteq> z'\<close> for z z'
      apply (cases z; cases z')
      using that apply (auto simp: K_def M_def)
      by (metis fun_upd_triv fun_upd_upd)
    show \<open>K z \<le> lift_invariant (X1 \<circ> Fst) (ket_invariant {fst z})\<close> for z
      by (auto simp: K_def X1_def lift_Fst_ket_inv lift_Snd_ket_inv lift_invariant_comp case_prod_beta)
    show [simp]: \<open>0 \<le> co2'_old_good q\<close>
      by (simp add: co2'_old_good_def)
    show \<open>preserves_ket query1' (I1 z) (J1 z) (co2'_old_good q)\<close> if \<open>z\<in>M\<close> for z
    proof (cases z)
      case (fields x1L x1R x y D1 D2' D3)
      from that have D2'xL: \<open>D2' x1L = None\<close>
        by (auto simp: M_def fields)
      show ?thesis
      proof (cases \<open>old_good D1 D2' D3\<close>)
        case True
        show ?thesis
          apply (simp only: case_prod_beta I1_def J1_def fst_conv snd_conv fields)
        proof (rule preserve_query1'_fixY[where b\<^sub>i=N and b\<^sub>j\<^sub>0=0])
          show \<open>{d. old_good D1 (D2'(x1L := d)) D3} \<subseteq> {d. old_good D1 (D2'(x1L := d)) D3}\<close> by simp
          show \<open>card (Some -` {d. old_good D1 (D2'(x1L := d)) D3}) \<le> N\<close> by (simp add: card_mono)
          show \<open>card (- Some -` {d. old_good D1 (D2'(x1L := d)) D3}) \<le> 0\<close>
            using True D2'xL apply auto
            apply (simp add: old_good_def)
            by meson
          have *: \<open>old_good D1 (D2'(x1L := None)) D3\<close>
            by (simp add: D2'xL True domIff)
          show \<open>preserve_query1'_fixY_bound
             (None \<in> {d. old_good D1 (D2'(x1L := d)) D3}) (None \<notin> {d. old_good D1 (D2'(x1L := d)) D3})
             (real N) (real 0) \<le> (co2'_old_good q)\<close>
            by (simp add: * preserve_query1'_fixY_bound_def)
        qed
      next
        case False
        show ?thesis
          apply (simp only: case_prod_beta I1_def J1_def fst_conv snd_conv fields)
        proof (rule preserve_query1'_fixY[where b\<^sub>i=q and b\<^sub>j\<^sub>0=N])
          show \<open>{d. old_good D1 (D2'(x1L := d)) D3} \<subseteq> {d. old_good D1 (D2'(x1L := d)) D3}\<close> by simp
          have card_D1: \<open>card (dom D1) \<le> q\<close>
            using \<open>z\<in>M\<close> by (simp add: fields M_def)
          from False obtain x2L where \<open>x2L \<in> dom D3\<close> and x2L_not_good: \<open>\<forall>xL\<in>dom D1. \<forall>\<beta>\<in>ran D2'. x2L \<noteq> xL + \<beta>\<close>
            by (auto simp: old_good_def)
          have d_poss: \<open>Some -` {d. old_good D1 (D2'(x1L := d)) D3} \<subseteq> (+) x2L ` dom D1\<close>
          proof (rule subsetI, rename_tac d)
            fix d assume \<open>d \<in> Some -` {d. old_good D1 (D2'(x1L := d)) D3}\<close>
            then have \<open>old_good D1 (D2'(x1L \<mapsto> d)) D3\<close>
              by simp
            with \<open>x2L \<in> dom D3\<close> have \<open>\<exists>xL\<in>dom D1. \<exists>\<beta>\<in>ran (D2'(x1L \<mapsto> d)). x2L = xL + \<beta>\<close>
              by (simp add: old_good_def)
            with x2L_not_good have \<open>\<exists>xL\<in>dom D1. x2L = xL + d\<close>
              using D2'xL by auto
            then show \<open>d \<in> (+) x2L ` dom D1\<close>
              by force
          qed
          show \<open>card (Some -` {d. old_good D1 (D2'(x1L := d)) D3}) \<le> q\<close>
            using _ card_D1 apply (rule order.trans)
            using d_poss by (simp add: surj_card_le)
          show \<open>card (- Some -` {d. old_good D1 (D2'(x1L := d)) D3}) \<le> N\<close>
            by (simp add: card_mono)
          have *: \<open>\<not> old_good D1 (D2'(x1L := None)) D3\<close>
            by (simp add: D2'xL False domIff)
          show \<open>preserve_query1'_fixY_bound (None \<in> {d. old_good D1 (D2'(x1L := d)) D3}) (None \<notin> {d. old_good D1 (D2'(x1L := d)) D3})
                     (real q) (real N) \<le> co2'_old_good q\<close>
            apply (auto simp add: * preserve_query1'_fixY_bound_def co2'_old_good_def)
            by (metis ab_semigroup_mult_class.mult_ac(1) dual_order.refl of_nat_0_le_iff real_divide_square_eq sqrt_sqrt times_divide_eq_right)
        qed
      qed
    qed
  qed
qed

definition \<open>UPc2'_old_good q = co2'_old_good q\<close>
lemma preserves_UPc2'_old_good:
  \<open>preserves_ket ((X1;(X2;D2)) UPc') (old_good_state_0 \<inter> num_queries_D1 q) old_good_state (UPc2'_old_good q)\<close>
proof -
  note comp_apply[simp del]

  have UPc: \<open>((X1;(X2;D2)) UPc') =
      (X1 o Fst; X2 o Snd) cnot o\<^sub>C\<^sub>L (X1 \<circ> Snd; X2 \<circ> Fst) cnot o\<^sub>C\<^sub>L (X1 \<circ> Fst; (X2 \<circ> Fst; D2)) query'\<close>
    by (simp add: UPc'_def reg_1_3_def reg_2_3_def reg_3_3_def register_pair_Fst register_pair_Snd
        flip: register_mult comp_assoc register_comp_pair
        o_apply[where x=cnot and f=\<open>(X1;(X2;D2))\<close>] o_apply[where x=query' and f=\<open>(X1;(X2;D2))\<close>])

  have \<open>preserves_ket ((X1 \<circ> Fst; (X2 \<circ> Fst; D2)) query') (old_good_state_0 \<inter> num_queries_D1 q) old_good_state (co2'_old_good q)\<close>
    by (rule preserves_co2'_old_good)
  also have \<open>preserves_ket ((X1 \<circ> Snd; X2 \<circ> Fst) cnot) old_good_state old_good_state 0\<close>
    apply (rule preserves_compatible[where U=cnot])
    by (auto simp add: old_good_state_def X1_def X2_def comp_assoc
        intro!: compatible_register_invariant_pair compatible_register_invariant_Fst_comp
        compatible_register_invariant_Snd_comp)
  also have \<open>preserves_ket ((X1 \<circ> Fst; X2 \<circ> Snd) cnot) old_good_state old_good_state 0\<close>
    apply (rule preserves_compatible[where U=cnot])
    by (auto simp add: old_good_state_def X1_def X2_def comp_assoc
        intro!: compatible_register_invariant_pair compatible_register_invariant_Fst_comp
        compatible_register_invariant_Snd_comp)
  finally show ?thesis
    by (auto simp add: UPc2'_old_good_def UPc cblinfun_compose_assoc register_norm)
qed

definition xx2_LR2 :: \<open>state set\<close> where \<open>xx2_LR2 = {(x,x1,x2,y,D1,D2,D3). LR2 D1 D2 x = Some x2}\<close>

definition \<open>co3'_old_good = 3 / sqrt N\<close>
lemma preserves_co3'_old_good:
  \<open>preserves_ket ((X2 o Fst; (Y o Fst; D3)) query') (old_good_state \<inter> xx2_LR2) old_good_state co3'_old_good\<close>
proof -
  define K :: \<open>(half\<times>half\<times>half\<times>whole\<times>whole\<times>db\<times>db\<times>db) \<Rightarrow> state ell2 ccsubspace\<close>
    where \<open>K = (\<lambda>(x2L,x2R,yR,x1,x,D1,D2,D3').
          ket_invariant {(x,x1,(x2L,x2R),(yL,yR),D1,D2,D3'(x2L:=d)) | yL d. True})\<close>
  define M :: \<open>(half\<times>half\<times>half\<times>whole\<times>whole\<times>db\<times>db\<times>db) set\<close> where
    \<open>M = {(x2L,x2R,yR,x1,x,D1,D2,D3'). D3' x2L = None \<and> (\<exists>d. old_good D1 D2 (D3'(x2L:=d))) \<and> LR2 D1 D2 x = Some (x2L,x2R)}\<close>

  define I1 J1 :: \<open>(half\<times>half\<times>half\<times>whole\<times>whole\<times>db\<times>db\<times>db) \<Rightarrow> (half \<times> half option) set\<close>
    where \<open>I1 = (\<lambda>(x2L,x2R,yR,x1,x,D1,D2,D3').
          UNIV \<times> {d. old_good D1 D2 (D3'(x2L:=d))})\<close>
      and \<open>J1 = (\<lambda>(x2L,x2R,yR,x1,x,D1,D2,D3').
          UNIV \<times> {d. old_good D1 D2 (D3'(x2L:=d))})\<close>

  show ?thesis
  proof (rule inv_split_reg_query'[where X=\<open>X2 o Fst\<close> and Y=\<open>Y o Fst\<close> and H=\<open>D3\<close> and K=K
        and ?I1.0=\<open>\<lambda>z. ket_invariant (I1 z)\<close> and ?J1.0=\<open>\<lambda>z. ket_invariant (J1 z)\<close>])
    show \<open>(X2 \<circ> Fst;(Y \<circ> Fst;D3)) query' = (X2 \<circ> Fst;(Y \<circ> Fst;D3)) query'\<close>
      by simp
    show [simp]: \<open>compatible (X2 \<circ> Fst) (Y \<circ> Fst)\<close> \<open>compatible (X2 \<circ> Fst) D3\<close> \<open>compatible (Y \<circ> Fst) D3\<close>
      by simp_all
    show \<open>compatible_register_invariant (Y \<circ> Fst) (K z)\<close> for z
      apply (cases z, hypsubst_thin)
      by (auto simp add: K_def Y_def comp_assoc
          intro!: compatible_register_invariant_Snd_comp compatible_register_invariant_Fst compatible_register_invariant_Fst_comp)
    show \<open>compatible_register_invariant (D3 \<circ> function_at (fst z)) (K z)\<close> for z
      by (auto simp add: K_def D3_def comp_assoc case_prod_beta
          intro!: compatible_register_invariant_Snd_comp compatible_register_invariant_Fst compatible_register_invariant_Fst_comp
          compatible_register_invariant_function_at)
    show \<open>ket_invariant (old_good_state \<inter> xx2_LR2) \<le> (SUP z\<in>M. K z \<sqinter> lift_invariant (Y \<circ> Fst; D3 \<circ> function_at (fst z)) (ket_invariant (I1 z)))\<close>
      apply (auto simp add: K_def D3_def lift_Fst_ket_inv ket_invariant_inter
          ket_invariant_SUP[symmetric] I1_def xx2_LR2_def
          old_good_state_def case_prod_beta comp_assoc Y_def M_def zero_prod_def num_queries_D1_def
          lift_inv_prod lift_invariant_comp lift_invariant_function_at_ket_inv lift_Snd_ket_inv)
      by (metis fun_upd_same fun_upd_triv fun_upd_upd)
    show \<open>K z \<sqinter> lift_invariant (Y \<circ> Fst; D3 \<circ> function_at (fst z)) (ket_invariant (J1 z)) \<le> ket_invariant old_good_state\<close>
      if \<open>z\<in>M\<close> for z
      using that
      apply (cases z, hypsubst_thin)
      by (auto simp add: K_def lift_Fst_ket_inv ket_invariant_inter ket_invariant_SUP[symmetric] J1_def
          case_prod_beta D3_def comp_assoc Y_def old_good_state_def M_def
          lift_inv_prod lift_invariant_comp lift_invariant_function_at_ket_inv reg_3_3_def lift_Snd_ket_inv)
    show \<open>orthogonal_spaces (K z) (K z')\<close> if \<open>z\<in>M\<close> \<open>z'\<in>M\<close> \<open>z \<noteq> z'\<close> for z z'
      apply (cases z; cases z')
      using that apply (auto simp: K_def M_def)
      by (metis fun_upd_triv fun_upd_upd)
    show \<open>K z \<le> lift_invariant (X2 \<circ> Fst) (ket_invariant {fst z})\<close> for z
      by (auto simp: K_def X2_def lift_Fst_ket_inv lift_Snd_ket_inv lift_invariant_comp case_prod_beta)
    show [simp]: \<open>0 \<le> co3'_old_good\<close>
      by (simp add: co3'_old_good_def)
    show \<open>preserves_ket query1' (I1 z) (J1 z) co3'_old_good\<close> if \<open>z\<in>M\<close> for z
    proof (cases z)
      case (fields x2L x2R yR x1 x D1 D2D3')
      obtain D2 D3' where D2D3'[simp]: \<open>D2D3' = (D2,D3')\<close>
        apply atomize_elim by auto
      from that have D3'xL: \<open>D3' x2L = None\<close>
        by (auto simp: M_def fields)
      from that have \<open>\<exists>d. old_good D1 D2 (D3'(x2L:=d))\<close>
        by (auto simp: M_def fields)
      then have D3'_good: \<open>old_good D1 D2 D3'\<close>
        by (smt (verit) D3'xL domIff fun_upd_apply old_good_def)
      then have None_I1: \<open>None \<in> snd ` I1 z\<close> (* TODO used? *)
        apply (auto simp: M_def fields I1_def D3'xL)
        by (simp add: D3'xL fun_upd_idem)
      from that have \<open>LR2 D1 D2 x = Some (x2L,x2R)\<close>
        by (auto simp: M_def fields)
      then have good_x2L: \<open>\<exists>xL xR. LR2 D1 D2 (xL, xR) \<bind> (\<lambda>(x2L', x2R). Some (x2L = x2L')) = Some True\<close>
        apply (rule_tac x=\<open>fst x\<close> in exI, rule_tac x=\<open>snd x\<close> in exI) by simp
      with D3'_good have D3'x2L_good: \<open>old_good D1 D2 (D3'(x2L:=d))\<close> for d
        unfolding old_good_alt_def by auto

      show ?thesis
        apply (simp only: case_prod_beta I1_def J1_def fst_conv snd_conv fields D2D3')
      proof (rule preserve_query1'[where b\<^sub>i=N and b\<^sub>j\<^sub>0=0])
        show \<open>{d. old_good D1 D2 (D3'(x2L := d))} \<subseteq> {d. old_good D1 D2 (D3'(x2L := d))}\<close> by simp
        show \<open>card (Some -` {d. old_good D1 D2 (D3'(x2L := d))}) \<le> N\<close> by (simp add: card_mono)
        show \<open>card (- Some -` {d. old_good D1 D2 (D3'(x2L := d))}) \<le> 0\<close>
          using D3'x2L_good by auto
        show \<open>preserve_query1'_bound
             (None \<in> {d. old_good D1 D2 (D3'(x2L := d))})
             (real N) (real 0) \<le> co3'_old_good\<close>
          by (simp add: preserve_query1'_bound_def)
        show \<open>None \<in> {d. old_good D1 D2 (D3'(x2L := d))}\<close>
          using D3'_good by (auto simp: M_def fields I1_def D3'xL fun_upd_idem)
      qed
    qed
  qed
qed

definition \<open>UPc3'_old_good = co3'_old_good\<close>
lemma preserves_UPc3'_old_good:
  \<open>preserves_ket ((X2;(Y;D3)) UPc') (old_good_state \<inter> xx2_LR2) old_good_state UPc3'_old_good\<close>
proof -
  note comp_apply[simp del]

  have UPc: \<open>((X2;(Y;D3)) UPc') =
      (X2 o Fst; Y o Snd) cnot o\<^sub>C\<^sub>L (X2 \<circ> Snd; Y \<circ> Fst) cnot o\<^sub>C\<^sub>L (X2 \<circ> Fst; (Y \<circ> Fst; D3)) query'\<close>
    by (simp add: UPc'_def reg_1_3_def reg_2_3_def reg_3_3_def register_pair_Fst register_pair_Snd
        flip: register_mult comp_assoc register_comp_pair
        o_apply[where x=cnot and f=\<open>(X2;(Y;D3))\<close>] o_apply[where x=query' and f=\<open>(X2;(Y;D3))\<close>])

  have \<open>preserves_ket ((X2 \<circ> Fst; (Y \<circ> Fst; D3)) query') (old_good_state \<inter> xx2_LR2) old_good_state co3'_old_good\<close>
    by (rule preserves_co3'_old_good)
  also have \<open>preserves_ket ((X2 \<circ> Snd; Y \<circ> Fst) cnot) old_good_state old_good_state 0\<close>
    apply (rule preserves_compatible[where U=cnot])
    by (auto simp add: old_good_state_def X2_def Y_def comp_assoc
        intro!: compatible_register_invariant_pair compatible_register_invariant_Fst_comp
        compatible_register_invariant_Snd_comp)
  also have \<open>preserves_ket ((X2 \<circ> Fst; Y \<circ> Snd) cnot) old_good_state old_good_state 0\<close>
    apply (rule preserves_compatible[where U=cnot])
    by (auto simp add: old_good_state_def X2_def Y_def comp_assoc
        intro!: compatible_register_invariant_pair compatible_register_invariant_Fst_comp
        compatible_register_invariant_Snd_comp)
  finally show ?thesis
    by (auto simp add: UPc3'_old_good_def UPc cblinfun_compose_assoc register_norm)
qed

definition x1_out_x2_0 :: \<open>state set\<close> where \<open>x1_out_x2_0 = {((xL,xR), (the (D1 xL) + xR, xL), 0,y,D1,D2,D3)| xL xR y D1 D2 D3. D1 xL \<noteq> None}\<close>

lemma cnotXSnd_apply: \<open>((X \<circ> Snd; X1 \<circ> Fst) cnot) *\<^sub>V ket ((xL,xR), (x1L,x1R), x,y,D1,D2,D3) = ket ((xL,xR), (x1L + xR,x1R), x,y,D1,D2,D3)\<close>
  for D1 D2 D3
    apply (auto intro!: cblinfun_image_ket_invariant_leqI
        simp: preserves0I explicit_pair cnot_apply)
  apply (simp add: register_pair_apply Fst_def Snd_def X_def X1_def
      tensor_op_ell2 ket_cinner' tensor_ell2_scaleC2 tensor_ell2_scaleC1
      flip: tensor_butterfly of_bool_conj tensor_ell2_ket)
  apply (subst sum_single[where i=\<open>(xR,x1L)\<close>])
  by auto

lemma cnotXFst_apply: \<open>((X \<circ> Fst; X1 \<circ> Snd) cnot) *\<^sub>V ket ((xL,xR), (x1L,x1R), x,y,D1,D2,D3)
           = ket ((xL,xR), (x1L,x1R+xL), x,y,D1,D2,D3)\<close>
  for D1 D2 D3
    apply (auto intro!: cblinfun_image_ket_invariant_leqI
        simp: preserves0I explicit_pair cnot_apply)
  apply (simp add: register_pair_apply Fst_def Snd_def X_def X1_def
      tensor_op_ell2 ket_cinner' tensor_ell2_scaleC2 tensor_ell2_scaleC1
      flip: tensor_butterfly of_bool_conj tensor_ell2_ket)
  apply (subst sum_single[where i=\<open>(xL,x1R)\<close>])
  by auto

lemma cnotX1Snd_apply: \<open>((X1 \<circ> Snd; X2 \<circ> Fst) cnot) *\<^sub>V ket (x, (x1L,x1R), (x2L,x2R), y,D1,D2,D3)
       = ket (x, (x1L,x1R), (x2L+x1R,x2R) ,y,D1,D2,D3)\<close>
  for D1 D2 D3
    apply (auto intro!: cblinfun_image_ket_invariant_leqI
        simp: preserves0I explicit_pair cnot_apply)
  apply (simp add: register_pair_apply Fst_def Snd_def X_def X1_def X2_def
      tensor_op_ell2 ket_cinner' tensor_ell2_scaleC2 tensor_ell2_scaleC1
      flip: tensor_butterfly of_bool_conj tensor_ell2_ket)
  apply (subst sum_single[where i=\<open>(x1R,x2L)\<close>])
  by auto

lemma cnotX1Fst_apply: \<open>((X1 \<circ> Fst; X2 \<circ> Snd) cnot) *\<^sub>V ket (x, (x1L,x1R), (x2L,x2R), y,D1,D2,D3)
           = ket (x, (x1L,x1R), (x2L,x2R+x1L) ,y,D1,D2,D3)\<close>
  for D1 D2 D3
    apply (auto intro!: cblinfun_image_ket_invariant_leqI
        simp: preserves0I explicit_pair cnot_apply)
  apply (simp add: register_pair_apply Fst_def Snd_def X_def X1_def X2_def
      tensor_op_ell2 ket_cinner' tensor_ell2_scaleC2 tensor_ell2_scaleC1
      flip: tensor_butterfly of_bool_conj tensor_ell2_ket)
  apply (subst sum_single[where i=\<open>(x1L,x2R)\<close>])
  by auto

definition UPc1'_output where \<open>UPc1'_output = 6 / sqrt N\<close>
lemma preserves_UPc1'_output: \<open>preserves_ket ((X;(X1;D1)) UPc') x1_x2_00 x1_out_x2_0 UPc1'_output\<close>
proof -
  have UPc: \<open>((X;(X1;D1)) UPc') =
      (X o Fst; X1 o Snd) cnot o\<^sub>C\<^sub>L (X \<circ> Snd; X1 \<circ> Fst) cnot o\<^sub>C\<^sub>L (X \<circ> Fst; (X1 \<circ> Fst; D1)) query'\<close>
    by (simp add: UPc'_def reg_1_3_def reg_2_3_def reg_3_3_def register_pair_Fst register_pair_Snd
        flip: register_mult comp_assoc register_comp_pair
        o_apply[where x=cnot and f=\<open>(X;(X1;D1))\<close>] o_apply[where x=query' and f=\<open>(X;(X1;D1))\<close>])

  have \<open>preserves_ket ((X o Fst; (X1 o Fst; D1)) query') x1_x2_00 {((xL,xR), (the (D1 xL), 0), 0,y,D1,D2,D3)| xL xR y D1 D2 D3. D1 xL \<noteq> None} UPc1'_output\<close>
  proof -
    define K :: \<open>(half\<times>half\<times>whole\<times>db\<times>db\<times>db) \<Rightarrow> state ell2 ccsubspace\<close>
      where \<open>K = (\<lambda>(xL,xR,y,D1',D2,D3).
          ket_invariant {((xL,xR),(x1L,0),0,y,D1'(xL:=d),D2,D3) | x1L d. True})\<close>
    define M :: \<open>(half\<times>half\<times>whole\<times>db\<times>db\<times>db) set\<close> where
      \<open>M = {(xL,xR,y,D1',D2,D3). D1' xL = None}\<close>

    show ?thesis
    proof (rule inv_split_reg_query'[where X=\<open>X o Fst\<close> and Y=\<open>X1 o Fst\<close> and H=\<open>D1\<close> and K=K
          and ?I1.0=\<open>\<lambda>z. ket_invariant ({0} \<times> UNIV)\<close> and ?J1.0=\<open>\<lambda>z. ket_invariant {(d, Some d)| d. True}\<close>])
      show \<open>(X \<circ> Fst;(X1 \<circ> Fst;D1)) query' = (X \<circ> Fst;(X1 \<circ> Fst;D1)) query'\<close>
        by simp
      show [simp]: \<open>compatible (X \<circ> Fst) (X1 \<circ> Fst)\<close> \<open>compatible (X \<circ> Fst) D1\<close> \<open>compatible (X1 \<circ> Fst) D1\<close>
        by simp_all
      show \<open>compatible_register_invariant (X1 \<circ> Fst) (K z)\<close> for z
        apply (cases z, hypsubst_thin)
        by (auto simp add: K_def X1_def comp_assoc
            intro!: compatible_register_invariant_Snd_comp compatible_register_invariant_Fst compatible_register_invariant_Fst_comp)
      show \<open>compatible_register_invariant (D1 \<circ> function_at (fst z)) (K z)\<close> for z
        by (auto simp add: K_def D1_def comp_assoc case_prod_beta
            intro!: compatible_register_invariant_Snd_comp compatible_register_invariant_Fst compatible_register_invariant_Fst_comp
            compatible_register_invariant_function_at)
      show \<open>ket_invariant x1_x2_00 \<le> (SUP z\<in>M. K z \<sqinter> lift_invariant (X1 \<circ> Fst; D1 \<circ> function_at (fst z)) (ket_invariant ({0} \<times> UNIV)))\<close>
        apply (auto simp add: K_def D1_def lift_Fst_ket_inv ket_invariant_inter
            ket_invariant_SUP[symmetric] x1_x2_00_def X1_def
            old_good_state_def case_prod_beta comp_assoc Y_def M_def zero_prod_def num_queries_D1_def
            lift_inv_prod lift_invariant_comp lift_invariant_function_at_ket_inv lift_Snd_ket_inv)
        by (metis fun_upd_same fun_upd_triv fun_upd_upd)
      show \<open>K z \<sqinter> lift_invariant (X1 \<circ> Fst; D1 \<circ> function_at (fst z)) (ket_invariant {(d, Some d) |d. True})
         \<le> ket_invariant {((xL, xR), (the (D1 xL), 0), 0, y, D1, D2, D3) |xL xR y D1 D2 D3. D1 xL \<noteq> None}\<close>
        if \<open>z\<in>M\<close> for z
        using that
        apply (cases z, hypsubst_thin)
        by (auto simp add: K_def lift_Fst_ket_inv ket_invariant_inter ket_invariant_SUP[symmetric]
            case_prod_beta D3_def comp_assoc Y_def old_good_state_def M_def X1_def D1_def
            lift_inv_prod' lift_invariant_comp lift_invariant_function_at_ket_inv reg_3_3_def lift_Snd_ket_inv)
      show \<open>orthogonal_spaces (K z) (K z')\<close> if \<open>z\<in>M\<close> \<open>z'\<in>M\<close> \<open>z \<noteq> z'\<close> for z z'
        apply (cases z; cases z')
        using that apply (auto simp: K_def M_def)
        by (metis fun_upd_triv fun_upd_upd)
      show \<open>K z \<le> lift_invariant (X \<circ> Fst) (ket_invariant {fst z})\<close> for z
        by (auto simp: K_def X_def lift_Fst_ket_inv lift_Snd_ket_inv lift_invariant_comp case_prod_beta)
      show \<open>0 \<le> UPc1'_output\<close>
        by (simp add: UPc1'_output_def)
      show \<open>preserves_ket query1'({0} \<times> UNIV) {(d, Some d) |d. True} UPc1'_output\<close> if \<open>z\<in>M\<close> for z
        apply (subst asm_rl[of \<open>{(d, Some d) |d. True} = {(0+d, Some d) |d. True}\<close>], simp)
        apply (rule preserve_query1'_fixY_output[where b\<^sub>i=N])
         apply (auto simp: preserve_query1'_fixY_bound_output_def UPc1'_output_def)
        by (metis (no_types, opaque_lifting) add_One_commute add_divide_distrib divide_inverse dual_order.refl numeral_plus_numeral of_nat_0_le_iff semiring_norm(3) semiring_norm(6) sqrt_divide_self_eq times_divide_eq_right)
    qed
  qed
  also have \<open>preserves_ket ((X \<circ> Snd; X1 \<circ> Fst) cnot)
       {((xL,xR), (the (D1 xL), 0), 0,y,D1,D2,D3)| xL xR y D1 D2 D3. D1 xL \<noteq> None}
       {((xL,xR), (the (D1 xL) + xR, 0), 0,y,D1,D2,D3)| xL xR y D1 D2 D3. D1 xL \<noteq> None}
       0\<close>
    by (auto intro!: cblinfun_image_ket_invariant_leqI ket_in_ket_invariantI
        simp: preserves0I cnotXSnd_apply ket_in_ket_invariantI)
  also have \<open>preserves_ket ((X \<circ> Fst; X1 \<circ> Snd) cnot)
       {((xL,xR), (the (D1 xL) + xR, 0), 0,y,D1,D2,D3)| xL xR y D1 D2 D3. D1 xL \<noteq> None}
       x1_out_x2_0
       0\<close>
    by (auto intro!: cblinfun_image_ket_invariant_leqI ket_in_ket_invariantI
        simp: preserves0I cnotXFst_apply ket_in_ket_invariantI x1_out_x2_0_def)
  finally show ?thesis
    by (auto simp add: UPc1_old_good_def UPc cblinfun_compose_assoc register_norm)
qed

definition UPc2'_output where \<open>UPc2'_output = 6 / sqrt N\<close>
lemma preserves_UPc2'_output: \<open>preserves_ket ((X1;(X2;D2)) UPc') x1_out_x2_0 xx2_LR2 UPc2'_output\<close>
proof -
  have UPc: \<open>((X1;(X2;D2)) UPc') =
      (X1 o Fst; X2 o Snd) cnot o\<^sub>C\<^sub>L (X1 \<circ> Snd; X2 \<circ> Fst) cnot o\<^sub>C\<^sub>L (X1 \<circ> Fst; (X2 \<circ> Fst; D2)) query'\<close>
    by (simp add: UPc'_def reg_1_3_def reg_2_3_def reg_3_3_def register_pair_Fst register_pair_Snd
        flip: register_mult comp_assoc register_comp_pair
        o_apply[where x=cnot and f=\<open>(X1;(X2;D2))\<close>] o_apply[where x=query' and f=\<open>(X1;(X2;D2))\<close>])

  have \<open>preserves_ket ((X1 o Fst; (X2 o Fst; D2)) query') x1_out_x2_0
        {((xL,xR), (the (D1 xL) + xR, xL), (the (D2 (the (D1 xL) + xR)), 0), y,D1,D2,D3)| xL xR y D1 D2 D3. D1 xL \<noteq> None \<and> D2 (the (D1 xL) + xR) \<noteq> None}
        UPc2'_output\<close>
  proof -
    define K :: \<open>(half\<times>half\<times>half\<times>whole\<times>db\<times>db\<times>db) \<Rightarrow> state ell2 ccsubspace\<close>
      where \<open>K = (\<lambda>(x1L,xL,xR,y,D1,D2',D3).
          ket_invariant {((xL,xR), (x1L, xL), (x2L,0), y,D1,D2'(x1L:=d),D3) | x2L d. D1 xL \<noteq> None})\<close>
    define M :: \<open>(half\<times>half\<times>half\<times>whole\<times>db\<times>db\<times>db) set\<close> where
      \<open>M = {(x1L,xL,xR,y,D1,D2',D3). D1 xL \<noteq> None \<and> D2' x1L = None \<and> x1L = the (D1 xL) + xR}\<close>

    show ?thesis
    proof (rule inv_split_reg_query'[where X=\<open>X1 o Fst\<close> and Y=\<open>X2 o Fst\<close> and H=\<open>D2\<close> and K=K
          and ?I1.0=\<open>\<lambda>z. ket_invariant ({0} \<times> UNIV)\<close> and ?J1.0=\<open>\<lambda>z. ket_invariant {(d, Some d)| d. True}\<close>])
      show \<open>(X1 \<circ> Fst;(X2 \<circ> Fst;D2)) query' = (X1 \<circ> Fst;(X2 \<circ> Fst;D2)) query'\<close>
        by simp
      show [simp]: \<open>compatible (X1 \<circ> Fst) (X2 \<circ> Fst)\<close> \<open>compatible (X1 \<circ> Fst) D2\<close> \<open>compatible (X2 \<circ> Fst) D2\<close>
        by simp_all
      show \<open>compatible_register_invariant (X2 \<circ> Fst) (K z)\<close> for z
        apply (cases z, hypsubst_thin)
        by (auto simp add: K_def X2_def comp_assoc
            intro!: compatible_register_invariant_Snd_comp compatible_register_invariant_Fst compatible_register_invariant_Fst_comp)
      show \<open>compatible_register_invariant (D2 \<circ> function_at (fst z)) (K z)\<close> for z
        by (auto simp add: K_def D2_def comp_assoc case_prod_beta
            intro!: compatible_register_invariant_Snd_comp compatible_register_invariant_Fst compatible_register_invariant_Fst_comp
            compatible_register_invariant_function_at)
      show \<open>ket_invariant x1_out_x2_0 \<le> (SUP z\<in>M. K z \<sqinter> lift_invariant (X2 \<circ> Fst; D2 \<circ> function_at (fst z)) (ket_invariant ({0} \<times> UNIV)))\<close>
        apply (auto simp add: K_def D1_def lift_Fst_ket_inv ket_invariant_inter
            ket_invariant_SUP[symmetric] x1_out_x2_0_def X1_def X2_def D2_def
            old_good_state_def case_prod_beta comp_assoc Y_def M_def zero_prod_def num_queries_D1_def
            lift_inv_prod lift_invariant_comp lift_invariant_function_at_ket_inv lift_Snd_ket_inv)
        by (metis fun_upd_same fun_upd_triv fun_upd_upd option.sel)
      show \<open>K z \<sqinter> lift_invariant (X2 \<circ> Fst; D2 \<circ> function_at (fst z)) (ket_invariant {(d, Some d) |d. True})
         \<le> ket_invariant {((xL,xR), (the (D1 xL) + xR, xL), (the (D2 (the (D1 xL) + xR)), 0), y,D1,D2,D3)| xL xR y D1 D2 D3. D1 xL \<noteq> None \<and> D2 (the (D1 xL) + xR) \<noteq> None}\<close>
        if \<open>z\<in>M\<close> for z
        using that
        apply (cases z, hypsubst_thin)
        by (auto simp add: K_def lift_Fst_ket_inv ket_invariant_inter ket_invariant_SUP[symmetric]
            case_prod_beta D3_def comp_assoc Y_def old_good_state_def M_def X1_def D1_def X2_def D2_def
            lift_inv_prod' lift_invariant_comp lift_invariant_function_at_ket_inv reg_3_3_def lift_Snd_ket_inv)
      show \<open>orthogonal_spaces (K z) (K z')\<close> if \<open>z\<in>M\<close> \<open>z'\<in>M\<close> \<open>z \<noteq> z'\<close> for z z'
        apply (cases z; cases z')
        using that apply (auto simp: K_def M_def)
        by (metis fun_upd_triv fun_upd_upd)
      show \<open>K z \<le> lift_invariant (X1 \<circ> Fst) (ket_invariant {fst z})\<close> for z
        by (auto simp: K_def X_def X1_def lift_Fst_ket_inv lift_Snd_ket_inv lift_invariant_comp case_prod_beta)
      show \<open>0 \<le> UPc2'_output\<close>
        by (simp add: UPc2'_output_def)
      show \<open>preserves_ket query1' ({0} \<times> UNIV) {(d, Some d) |d. True} UPc2'_output\<close> if \<open>z\<in>M\<close> for z
        apply (subst asm_rl[of \<open>{(d, Some d) |d. True} = {(0+d, Some d) |d. True}\<close>], simp)
        apply (rule preserve_query1'_fixY_output[where b\<^sub>i=N])
         apply (auto simp: preserve_query1'_fixY_bound_output_def UPc2'_output_def)
        by (metis (no_types, opaque_lifting) add_One_commute add_divide_distrib divide_inverse dual_order.refl numeral_plus_numeral of_nat_0_le_iff semiring_norm(3) semiring_norm(6) sqrt_divide_self_eq times_divide_eq_right)
    qed
  qed
  also have \<open>preserves_ket ((X1 \<circ> Snd; X2 \<circ> Fst) cnot)
       {((xL,xR), (the (D1 xL) + xR, xL), (the (D2 (the (D1 xL) + xR)), 0), y,D1,D2,D3)| xL xR y D1 D2 D3. D1 xL \<noteq> None \<and> D2 (the (D1 xL) + xR) \<noteq> None}
       {((xL,xR), (the (D1 xL) + xR, xL), (the (D2 (the (D1 xL) + xR)) + xL, 0), y,D1,D2,D3)| xL xR y D1 D2 D3. D1 xL \<noteq> None \<and> D2 (the (D1 xL) + xR) \<noteq> None}
       0\<close>
    by (auto intro!: cblinfun_image_ket_invariant_leqI ket_in_ket_invariantI
        simp: preserves0I cnotX1Snd_apply ket_in_ket_invariantI)
  also have \<open>preserves_ket ((X1 \<circ> Fst; X2 \<circ> Snd) cnot)
       {((xL,xR), (the (D1 xL) + xR, xL), (the (D2 (the (D1 xL) + xR)) + xL, 0), y,D1,D2,D3)| xL xR y D1 D2 D3. D1 xL \<noteq> None \<and> D2 (the (D1 xL) + xR) \<noteq> None}
       xx2_LR2
       0\<close>
    by (auto intro!: cblinfun_image_ket_invariant_leqI ket_in_ket_invariantI
        simp: preserves0I cnotX1Fst_apply ket_in_ket_invariantI xx2_LR2_def LR2_def add.commute)
  finally show ?thesis
    by (auto simp add: UPc1_old_good_def UPc cblinfun_compose_assoc register_norm)
qed

lemma x1_out_x2_0_subset_x2_0: \<open>x1_out_x2_0 \<subseteq> x2_0\<close>
  by (smt (z3) Collect_mono_iff x1_out_x2_0_def x2_0_def)

end

(* What we have so far:

UPc1': old_good_state \<inter> x1_x2_00 \<longrightarrow> old_good_state \<inter> x2_0 (* Do we need the x2_0 part here? *)
       x1_x2_00 \<longrightarrow> x1_out_x2_0
       x1_out_x2_0 \<subseteq> x2_0
UPc2': old_good_state \<inter> x2_0 \<inter> num_queries_1 q \<longrightarrow> old_good_state
       x1_out_x2_0 \<longrightarrow> xx2_LR2
UPc3': old_good_state \<inter> xx1_LR3 \<longrightarrow> old_good_state

Plugging this together with other stuff:
UPc1';UPc2': old_good_state_00 \<inter> num_queries_1 q \<inter> num_queries_2 q
        \<longrightarrow>  old_good_state_00 \<inter> num_queries_1 (q+1) \<inter> num_queries_2 (q+1)
             \<inter> x1,x2 have the right stuff given x,D1,D2

*)


(*<*)
theory Uv_Proofs
imports Heard_Of.Reduction
  Two_Step_Observing "../HO_Transition_System" Uv_Defs
begin
(*>*)

subsection \<open>Proofs\<close>
type_synonym uv_TS_state = "(nat \<times> (process \<Rightarrow> (val pstate)))"

axiomatization where val_linorder:
  "OFCLASS(val, linorder_class)"

instance val :: linorder by (rule val_linorder)

lemma two_step_step:
   "step = two_step"
   "phase = two_phase"
   by(auto simp add: step_def two_step_def phase_def two_phase_def)

context mono_quorum
begin

definition UV_Alg :: "(process, val pstate, val msg)CHOAlgorithm" where
  "UV_Alg = CHOAlgorithm.truncate UV_M"

definition UV_TS ::
  "(round \<Rightarrow> process HO) \<Rightarrow> (round \<Rightarrow> process HO) \<Rightarrow> (round \<Rightarrow> process) \<Rightarrow> uv_TS_state TS"
where
  "UV_TS HOs SHOs crds = CHO_to_TS UV_Alg HOs SHOs (K o crds)"

lemmas UV_TS_defs = UV_TS_def CHO_to_TS_def UV_Alg_def CHOinitConfig_def
  UV_initState_def

type_synonym rHO = "nat \<Rightarrow> process HO"

definition UV_trans_step
  where
  "UV_trans_step HOs SHOs nxt_f snd_f stp \<equiv> \<Union>r \<mu>.
    {((r, cfg), (Suc r, cfg'))|cfg cfg'. step r = stp  \<and> (\<forall>p.
      \<mu> p \<in> get_msgs (snd_f r) cfg (HOs r) (SHOs r) p
      \<and> nxt_f r p (cfg p) (\<mu> p) (cfg' p)
    )}"

lemma step_less_D:
  "0 < step r \<Longrightarrow> step r = Suc 0"
  by(auto simp add: step_def)

lemma UV_trans:
  "CSHO_trans_alt UV_sendMsg (\<lambda>r p st msgs crd st'. UV_nextState r p st msgs st') HOs SHOs crds =
  UV_trans_step HOs SHOs next0 send0 0
  \<union> UV_trans_step HOs SHOs  next1 send1 1
  "
proof
  show "CSHO_trans_alt UV_sendMsg (\<lambda>r p st msgs crd. UV_nextState r p st msgs) HOs SHOs crds
    \<subseteq> UV_trans_step HOs SHOs next0 send0 0 \<union> UV_trans_step HOs SHOs next1 send1 1"
  by(force simp add: CSHO_trans_alt_def UV_sendMsg_def UV_nextState_def UV_trans_step_def
    K_def dest!: step_less_D)
next
  show " UV_trans_step HOs SHOs next0 send0 0 \<union>
    UV_trans_step HOs SHOs next1 send1 1
    \<subseteq> CSHO_trans_alt UV_sendMsg
        (\<lambda>r p st msgs crd. UV_nextState r p st msgs) HOs SHOs crds"
  by(force simp add: CSHO_trans_alt_def UV_sendMsg_def UV_nextState_def UV_trans_step_def)
qed

subsubsection \<open>Invariants\<close>
(******************************************************************************)

definition UV_inv1
  :: "uv_TS_state set"
where
  "UV_inv1  = {(r, s).
    two_step r = 0 \<longrightarrow> (\<forall>p. agreed_vote (s p) = None)
  }"

lemmas UV_inv1I = UV_inv1_def [THEN setc_def_to_intro, rule_format]
lemmas UV_inv1E [elim] = UV_inv1_def [THEN setc_def_to_elim, rule_format]
lemmas UV_inv1D = UV_inv1_def [THEN setc_def_to_dest, rule_format]

lemma UV_inv1_inductive:
  "init (UV_TS HOs SHOs crds) \<subseteq> UV_inv1"
  "{UV_inv1} TS.trans (UV_TS HOs SHOs crds) {> UV_inv1}"
  by(auto simp add: UV_inv1_def UV_TS_defs CHO_trans_alt UV_trans PO_hoare_def
    UV_HOMachine_def CHOAlgorithm.truncate_def UV_trans_step_def
    all_conj_distrib two_step_phase_Suc two_step_step next1_def)

lemma UV_inv1_invariant:
  "reach (UV_TS HOs SHOs crds) \<subseteq> UV_inv1"
  by(intro inv_rule_basic UV_inv1_inductive)

subsubsection \<open>Refinement\<close>
(******************************************************************************)

definition ref_rel :: "(tso_state \<times> uv_TS_state)set" where
  "ref_rel \<equiv> {(sa, (r, sc)).
    r = next_round sa
    \<and> (step r = 1 \<longrightarrow> r_votes sa = agreed_vote o sc)
    \<and> (\<forall>p v. last_obs (sc p) = v \<longrightarrow> (\<exists>q. opt_obsv_state.last_obs sa q \<in> {None, Some v}))
    \<and> decisions sa = decide o sc
  }"

(******************************************************************************)
text \<open>Agreement for UV only holds if the communication predicates hold\<close>
context
  fixes
    HOs :: "nat \<Rightarrow> process \<Rightarrow> process set"
    and rho :: "nat \<Rightarrow> process \<Rightarrow> 'val pstate"
  assumes global: "UV_commGlobal HOs"
  and per_rd: "\<forall>r. UV_commPerRd (HOs r)"
  and run: "HORun fA rho HOs"
begin
(******************************************************************************)

lemma HOs_intersect:
  "HOs r p \<inter> HOs r' q \<noteq> {}" using per_rd
  apply(simp add: UV_commPerRd_def)
  apply(blast dest: qintersect)
  done

lemma HOs_nonempty:
  "HOs r p \<noteq> {}"
  using HOs_intersect
  by blast

lemma vote_origin:
  assumes
  send: "\<forall>p. \<mu> p \<in> get_msgs (send0 r) cfg (HOs r) (HOs r) p"
  and step: "\<forall>p. next0 r p (cfg p) (\<mu> p) (cfg' p)"
  and inv: "(r, cfg) \<in> UV_inv1"
  and step_r: "two_step r = 0"
  shows
    "agreed_vote (cfg' p) = Some v \<longleftrightarrow> (\<forall>q \<in> HOs r p. last_obs (cfg q) = v)"
  using send[THEN spec, where x=p] step[THEN spec, where x=p] inv step_r HOs_nonempty
  by(auto simp add: next0_def get_msgs_benign send0_def msgRcvd_def o_def restrict_map_def)

lemma same_new_vote:
  assumes
  send: "\<forall>p. \<mu> p \<in> get_msgs (send0 r) cfg (HOs r) (HOs r) p"
  and step: "\<forall>p. next0 r p (cfg p) (\<mu> p) (cfg' p)"
  and inv: "(r, cfg) \<in> UV_inv1"
  and step_r: "two_step r = 0"
  obtains v where "\<forall>p w. agreed_vote (cfg' p) = Some w \<longrightarrow> w = v"
proof(cases "\<exists>p v. agreed_vote (cfg' p) = Some v")
  case True
  assume asm: "\<And>v. \<forall>p w. agreed_vote (cfg' p) = Some w \<longrightarrow> w = v \<Longrightarrow> thesis"
  from True obtain p v where "agreed_vote (cfg' p) = Some v" by auto

  hence "\<forall>p w. agreed_vote (cfg' p) = Some w \<longrightarrow> w = v" (is "?LV(v)")
    using vote_origin[OF send step inv step_r] HOs_intersect
    by(force)

  from asm[OF this] show ?thesis .
qed(auto)

lemma x_origin1:
  assumes
  send: "\<forall>p. \<mu> p \<in> get_msgs (send0 r) cfg (HOs r) (HOs r) p"
  and step: "\<forall>p. next0 r p (cfg p) (\<mu> p) (cfg' p)"
  and step_r: "two_step r = 0"
  and last_obs: "last_obs (cfg' p) = v"
  shows
    "\<exists>q. last_obs (cfg q) = v"
proof-
  have "smallestValRcvd (\<mu> p) \<in> {v. \<exists>q. \<mu> p q = Some (Val v)}" (is "smallestValRcvd ?msgs \<in> ?vals")
  unfolding smallestValRcvd_def
  proof(rule Min_in)
    have "?vals \<subseteq> getval ` ((the \<circ> ?msgs) ` (HOs r p))"
      using send[THEN spec, where x=p]
      by (auto simp: image_def get_msgs_benign restrict_map_def send0_def)
    thus "finite ?vals" by (auto simp: finite_subset)
  next
    from send[THEN spec, where x=p]
    show "?vals \<noteq> {}" using HOs_nonempty[of r p]
      by (auto simp: image_def get_msgs_benign restrict_map_def send0_def)
  qed
  hence "v \<in> ?vals" using last_obs step[THEN spec, of p]
    by(auto simp add: next0_def all_conj_distrib)
  thus ?thesis using send[THEN spec, of p]
    by(auto simp add: get_msgs_benign send0_def restrict_map_def)
qed

lemma step0_ref:
  "{ref_rel \<inter> UNIV \<times> UV_inv1} \<Union>r S v. tso_round0 r S v,
    UV_trans_step HOs HOs next0 send0 0 {> ref_rel}"
proof(clarsimp simp add: PO_rhoare_defs UV_trans_step_def two_step_step all_conj_distrib)
  fix sa r cfg \<mu> cfg'
  assume
    R: "(sa, (r, cfg)) \<in> ref_rel"
    and step_r: "two_step r = 0"
    and send: "\<forall>p. \<mu> p \<in> get_msgs (send0 r) cfg (HOs r) (HOs r) p"
    and step: "\<forall>p. next0 r p (cfg p) (\<mu> p) (cfg' p)"
    and inv: "(r, cfg) \<in> UV_inv1"

  from R have next_r: "next_round sa = r"
    by(simp add: ref_rel_def)

  from HOs_nonempty send have "\<forall>p. \<exists>q. q \<in> msgRcvd (\<mu> p)"
    by(fastforce simp add: get_msgs_benign send0_def msgRcvd_def restrict_map_def)
  with step have same_dec: "decide o cfg' = decide o cfg"
    apply(simp add: next0_def o_def)
    by (metis pstate.select_convs(3) pstate.surjective pstate.update_convs(1) pstate.update_convs(2))

  define S where "S = {p. \<exists>v. agreed_vote (cfg' p) = Some v}"
  from same_new_vote[OF send step inv step_r]
  obtain v where v: "\<forall>p \<in> S. agreed_vote (cfg' p) = Some v"
    by(simp add: S_def) (metis)
  hence vote_const_map: "agreed_vote o cfg' = const_map v S"
    by(auto simp add: S_def const_map_def restrict_map_def intro!: ext)

  note x_origin = x_origin1[OF send step step_r]

  define sa' where "sa' = sa\<lparr> next_round := Suc r, r_votes := const_map v S \<rparr>"

  have "\<forall>p. p \<in> S \<longrightarrow> opt_obs_safe (opt_obsv_state.last_obs sa) v"
    using vote_origin[OF send step inv step_r] R per_rd[THEN spec, of r] v
    apply(clarsimp simp add: UV_commPerRd_def opt_obs_safe_def ref_rel_def)
    by metis

  hence "(sa, sa') \<in> tso_round0 r S v" using next_r step_r v R
    vote_origin[OF send step inv step_r]
    by(auto simp add: tso_round0_def sa'_def all_conj_distrib)

  moreover have "(sa', Suc r, cfg') \<in> ref_rel" using step send v R same_dec step_r next_r
    apply(clarsimp simp add: ref_rel_def sa'_def two_step_step two_step_phase_Suc vote_const_map)
    by (metis x_origin)
  ultimately show
    "\<exists>sa'. (\<exists>r S v. (sa, sa') \<in> tso_round0 r S v) \<and> (sa', Suc r, cfg') \<in> ref_rel"
    by blast
qed

lemma x_origin2:
  assumes
  send: "\<forall>p. \<mu> p \<in> get_msgs (send1 r) cfg (HOs r) (HOs r) p"
  and step: "\<forall>p. next1 r p (cfg p) (\<mu> p) (cfg' p)"
  and step_r: "two_step r = Suc 0"
  and last_obs: "last_obs (cfg' p) = v"
  shows
    "(\<exists>q. last_obs (cfg q) = v) \<or> (\<exists>q. agreed_vote (cfg q) = Some v)"
proof(cases "\<forall>q \<in> HOs r p. \<exists>w. \<mu> p q = Some (ValVote w None)")
  case True
  hence empty: "someVoteRcvd (\<mu> p) = {}" using send[THEN spec, of p] HOs_nonempty[of r p]
    by(auto simp add: someVoteRcvd_def msgRcvd_def isValVote_def
      get_msgs_benign send1_def restrict_map_def)
  have "smallestValNoVoteRcvd (\<mu> p) \<in> {v. \<exists>q. \<mu> p q = Some (ValVote v None)}"
    (is "smallestValNoVoteRcvd ?msgs \<in> ?vals")
  unfolding smallestValNoVoteRcvd_def
  proof(rule Min_in)
    have "?vals \<subseteq> getval ` ((the \<circ> ?msgs) ` (HOs r p))"
      using send[THEN spec, where x=p]
      by (auto simp: image_def get_msgs_benign restrict_map_def send0_def)
    thus "finite ?vals" by (auto simp: finite_subset)
  next
    from send[THEN spec, where x=p] True HOs_nonempty[of r p]
    show "?vals \<noteq> {}"
      by (auto simp: image_def get_msgs_benign restrict_map_def send1_def)
  qed
  hence "v \<in> ?vals" using empty step[THEN spec, of p] last_obs
    by(auto simp add: next1_def x_update_def)
  thus ?thesis using send[THEN spec, of p]
    by(auto simp add: get_msgs_benign restrict_map_def send1_def)
next
  case False
  hence "someVoteRcvd (\<mu> p) \<noteq> {}" using send[THEN spec, of p] HOs_nonempty[of r p]
    by(auto simp add: someVoteRcvd_def msgRcvd_def isValVote_def
      get_msgs_benign send1_def restrict_map_def)
  hence "\<exists>q \<in> someVoteRcvd (\<mu> p). v = the (getvote (the (\<mu> p q)))" using step[THEN spec, of p] last_obs
    by(auto simp add: next1_def x_update_def)
  thus ?thesis using send[THEN spec, of p]
    by(auto simp add: next1_def x_update_def someVoteRcvd_def isValVote_def
      send1_def get_msgs_benign msgRcvd_def restrict_map_def)
qed

definition D where
  "D cfg cfg' \<equiv> {p. decide (cfg' p) \<noteq> decide (cfg p) }"

lemma decide_origin:
  assumes
  send: "\<forall>p. \<mu> p \<in> get_msgs (send1 r) cfg (HOs r) (HOs r) p"
  and step: "\<forall>p. next1 r p (cfg p) (\<mu> p) (cfg' p)"
  and step_r: "two_step r = Suc 0"
  shows
    "D cfg cfg' \<subseteq> {p. \<exists>v. decide (cfg' p) = Some v \<and> (\<forall>q \<in> HOs r p. agreed_vote (cfg q) = Some v)}"
  using assms
  by(fastforce simp add: D_def next1_def get_msgs_benign send1_def msgRcvd_def o_def restrict_map_def
    x_update_def dec_update_def identicalVoteRcvd_def all_conj_distrib someVoteRcvd_def isValVote_def
    smallestValNoVoteRcvd_def)

lemma step1_ref:
  "{ref_rel \<inter> (TSO_inv1 \<inter> TSO_inv2) \<times> UNIV} \<Union>r d_f o_f. tso_round1 r d_f o_f,
    UV_trans_step HOs HOs next1 send1 (Suc 0) {> ref_rel}"
proof(clarsimp simp add: PO_rhoare_defs UV_trans_step_def two_step_step all_conj_distrib)
  fix sa r cfg \<mu> and cfg' :: "process \<Rightarrow> val pstate"
  assume
    R: "(sa, (r, cfg)) \<in> ref_rel"
    and step_r: "two_step r = Suc 0"
    and send: "\<forall>p. \<mu> p \<in> get_msgs (send1 r) cfg (HOs r) (HOs r) p"
    and step: "\<forall>p. next1 r p (cfg p) (\<mu> p) (cfg' p)"
    and ainv: "sa \<in> TSO_inv1"
    and ainv2: "sa \<in> TSO_inv2"

  from R have next_r: "next_round sa = r"
    by(simp add: ref_rel_def)

  define S where "S = {p. \<exists>v. agreed_vote (cfg p) = Some v}"
  from R obtain v where v: "\<forall>p \<in> S. agreed_vote (cfg p) = Some v" using ainv step_r
    by(auto simp add: ref_rel_def TSO_inv1_def S_def two_step_step)

  define Ob where "Ob = {p. last_obs (cfg' p) = v}"
  define o_f where "o_f p = (if S \<in> Quorum then Some v else None)" for p :: process

  define dec_f where "dec_f p = (if p \<in> D cfg cfg' then decide (cfg' p) else None)" for p

  {
    fix p w
    assume "agreed_vote (cfg p) = Some w"
    hence "w = v" using v
      by(unfold S_def, auto)
  } note v'=this

  have d_guard: "d_guard dec_f (agreed_vote \<circ> cfg)" using per_rd[THEN spec, of r]
    by(fastforce simp add: d_guard_def locked_in_vf_def quorum_for_def dec_f_def
      UV_commPerRd_def dest!: decide_origin[OF send step step_r, THEN subsetD])

  have "dom (agreed_vote \<circ> cfg) \<in> Quorum \<longrightarrow> Ob = UNIV"
  proof(auto simp add: Ob_def)
    fix p
    assume Q: "dom (agreed_vote \<circ> cfg) \<in> Quorum" (is "?Q \<in> Quorum")
    hence "?Q \<inter> HOs r p \<noteq> {}"  using per_rd[THEN spec, of r]
      by(auto simp add: UV_commPerRd_def dest: qintersect)
    hence "someVoteRcvd (\<mu> p) \<noteq> {}" using send[THEN spec, of p]
      by(force simp add: someVoteRcvd_def get_msgs_benign msgRcvd_def restrict_map_def
        isValVote_def send1_def)
    moreover have "\<forall>q \<in> someVoteRcvd (\<mu> p). \<exists>x'. \<mu> p q = Some (ValVote x' (Some v))"
      using send[THEN spec, of p]
      by(auto simp add: someVoteRcvd_def get_msgs_benign msgRcvd_def restrict_map_def
        isValVote_def send1_def dest: v')
    ultimately show "last_obs (cfg' p) = v" using step[THEN spec, of p]
      by(auto simp add: next1_def x_update_def)
  qed
  note Ob_UNIV=this[rule_format]

  have obs_guard: "obs_guard o_f (agreed_vote \<circ> cfg)"
    apply(auto simp add: obs_guard_def o_f_def S_def dom_def
      dest: v' Ob_UNIV quorum_non_empty)
    apply (metis S_def all_not_in_conv  empty_not_quorum v)
    done

  define sa' where "sa' = sa\<lparr>
    next_round := Suc (next_round sa)
    , decisions := decisions sa ++ dec_f
    , opt_obsv_state.last_obs := opt_obsv_state.last_obs sa ++ o_f
    \<rparr>"

  \<comment> \<open>Abstract step\<close>
  have abs_step: "(sa, sa') \<in> tso_round1 r dec_f o_f"  using next_r step_r R d_guard obs_guard
    by(auto simp add: tso_round1_def sa'_def ref_rel_def two_step_step)

  \<comment> \<open>Relation preserved\<close>
  have "\<forall>p. ((decide \<circ> cfg) ++ dec_f) p = decide (cfg' p)"
  proof
    fix p
    show "((decide \<circ> cfg) ++ dec_f) p = decide (cfg' p)" using step[THEN spec, of p]
      by(auto simp add: dec_f_def D_def next1_def dec_update_def map_add_def)
  qed
  note dec_rel=this[rule_format]

  have "\<forall>p. (\<exists>q. o_f q = None \<and> opt_obsv_state.last_obs sa q = None
        \<or> (opt_obsv_state.last_obs sa ++ o_f) q = Some (last_obs (cfg' p)))"
  proof(intro allI impI, cases "S \<in> Quorum")
    fix p
    case True
    hence "last_obs (cfg' p) = v" using Ob_UNIV
      by(auto simp add: S_def Ob_def dom_def)
    thus "(\<exists>q. o_f q = None \<and> opt_obsv_state.last_obs sa q = None
        \<or> (opt_obsv_state.last_obs sa ++ o_f) q = Some (last_obs (cfg' p)))"
      using True
      by(auto simp add: o_f_def)
  next
    fix p
    case False
    hence empty: "o_f = Map.empty"
      by(auto simp add: o_f_def)
    note last_obs = x_origin2[OF send step step_r refl, of p]
    thus "(\<exists>q. o_f q = None \<and> opt_obsv_state.last_obs sa q = None
        \<or> (opt_obsv_state.last_obs sa ++ o_f) q = Some (last_obs (cfg' p)))"
    proof(elim disjE exE)
      fix q
      assume "last_obs (cfg q) = last_obs (cfg' p)"
      from this[symmetric] show ?thesis using R step_r empty
        by(simp add: ref_rel_def two_step_step)
    next
      fix q
      assume "agreed_vote (cfg q) = Some (last_obs (cfg' p))"
      from this[symmetric] show ?thesis using R ainv2 step_r empty
        apply(auto simp add: ref_rel_def two_step_step TSO_inv2_def)
        by metis
    qed
  qed
  note obs_rel=this[rule_format]

  have post_rel:
    "(sa', Suc r, cfg') \<in> ref_rel" using step send next_r R step_r
    by(auto simp add: sa'_def ref_rel_def two_step_step
      two_step_phase_Suc dec_rel obs_rel)

  from abs_step post_rel show
    "\<exists>sa'. (\<exists>r d_f o_f. (sa, sa') \<in> tso_round1 r d_f o_f) \<and> (sa', Suc r, cfg') \<in> ref_rel"
    by blast
qed

lemma UV_Refines_votes:
  "PO_refines (ref_rel \<inter> (TSO_inv1 \<inter> TSO_inv2) \<times> UV_inv1)
    tso_TS (UV_TS HOs HOs crds)"
proof(rule refine_using_invariants)
  show "init (UV_TS HOs HOs crds) \<subseteq> ref_rel `` init tso_TS"
    by(auto simp add: UV_TS_defs UV_HOMachine_def CHOAlgorithm.truncate_def
      tso_TS_defs ref_rel_def tso_init_def Let_def o_def)
next
  show
    "{ref_rel \<inter> (TSO_inv1 \<inter> TSO_inv2) \<times> UV_inv1} TS.trans tso_TS,
      TS.trans (UV_TS HOs HOs crds) {> ref_rel}"
    apply(simp add: tso_TS_defs UV_TS_defs UV_HOMachine_def CHOAlgorithm.truncate_def)
    apply(auto simp add: CHO_trans_alt UV_trans intro!: step0_ref step1_ref)
    done
qed(auto intro!: TSO_inv1_inductive TSO_inv2_inductive UV_inv1_inductive)

end (* HO predicate context *)

end (* mono_quorum context *)

subsubsection \<open>Termination\<close>
(******************************************************************************)

text \<open>As the model of the algorithm is taken verbatim from the HO Model AFP, we
  do not repeat the termination proof here and refer to that AFP entry.\<close>

end (* theory *)