(*  Author: John Harrison and Valentina Bruno
    Ported from "hol_light/Multivariate/complexes.ml" by L C Paulson
*)

section \<open>Polynomial Functions: Extremal Behaviour and Root Counts\<close>

theory Poly_Roots
imports Complex_Main
begin

subsection\<open>Basics about polynomial functions: extremal behaviour and root counts\<close>

lemma sub_polyfun:
  fixes x :: "'a::{comm_ring,monoid_mult}"
  shows   "(\<Sum>i\<le>n. a i * x^i) - (\<Sum>i\<le>n. a i * y^i) =
           (x - y) * (\<Sum>j<n. \<Sum>k= Suc j..n. a k * y^(k - Suc j) * x^j)"
proof -
  have "(\<Sum>i\<le>n. a i * x^i) - (\<Sum>i\<le>n. a i * y^i) =
        (\<Sum>i\<le>n. a i * (x^i - y^i))"
    by (simp add: algebra_simps sum_subtractf [symmetric])
  also have "... = (\<Sum>i\<le>n. a i * (x - y) * (\<Sum>j<i. y^(i - Suc j) * x^j))"
    by (simp add: power_diff_sumr2 ac_simps)
  also have "... = (x - y) * (\<Sum>i\<le>n. (\<Sum>j<i. a i * y^(i - Suc j) * x^j))"
    by (simp add: sum_distrib_left ac_simps)
  also have "... = (x - y) * (\<Sum>j<n. (\<Sum>i=Suc j..n. a i * y^(i - Suc j) * x^j))"
    by (simp add: sum.nested_swap')
  finally show ?thesis .
qed

lemma sub_polyfun_alt:
  fixes x :: "'a::{comm_ring,monoid_mult}"
  shows   "(\<Sum>i\<le>n. a i * x^i) - (\<Sum>i\<le>n. a i * y^i) =
           (x - y) * (\<Sum>j<n. \<Sum>k<n-j. a (j+k+1) * y^k * x^j)"
proof -
  { fix j
    have "(\<Sum>k = Suc j..n. a k * y^(k - Suc j) * x^j) =
          (\<Sum>k <n - j. a (Suc (j + k)) * y^k * x^j)"
      by (rule sum.reindex_bij_witness[where i="\<lambda>i. i + Suc j" and j="\<lambda>i. i - Suc j"]) auto }
  then show ?thesis
    by (simp add: sub_polyfun)
qed

lemma polyfun_linear_factor:
  fixes a :: "'a::{comm_ring,monoid_mult}"
  shows  "\<exists>b. \<forall>z. (\<Sum>i\<le>n. c i * z^i) =
                  (z-a) * (\<Sum>i<n. b i * z^i) + (\<Sum>i\<le>n. c i * a^i)"
proof -
  { fix z
    have "(\<Sum>i\<le>n. c i * z^i) - (\<Sum>i\<le>n. c i * a^i) =
          (z - a) * (\<Sum>j<n. (\<Sum>k = Suc j..n. c k * a^(k - Suc j)) * z^j)"
      by (simp add: sub_polyfun sum_distrib_right)
    then have "(\<Sum>i\<le>n. c i * z^i) =
          (z - a) * (\<Sum>j<n. (\<Sum>k = Suc j..n. c k * a^(k - Suc j)) * z^j)
          + (\<Sum>i\<le>n. c i * a^i)"
      by (simp add: algebra_simps) }
  then show ?thesis
    by (intro exI allI)
qed

lemma polyfun_linear_factor_root:
  fixes a :: "'a::{comm_ring,monoid_mult}"
  assumes "(\<Sum>i\<le>n. c i * a^i) = 0"
  shows  "\<exists>b. \<forall>z. (\<Sum>i\<le>n. c i * z^i) = (z-a) * (\<Sum>i<n. b i * z^i)"
  using polyfun_linear_factor [of c n a] assms
  by simp

lemma adhoc_norm_triangle: "a + norm(y) \<le> b ==> norm(x) \<le> a ==> norm(x + y) \<le> b"
  by (metis norm_triangle_mono order.trans order_refl)

proposition polyfun_extremal_lemma:
  fixes c :: "nat \<Rightarrow> 'a::real_normed_div_algebra"
  assumes "e > 0"
    shows "\<exists>M. \<forall>z. M \<le> norm z \<longrightarrow> norm(\<Sum>i\<le>n. c i * z^i) \<le> e * norm(z) ^ Suc n"
proof (induction n)
  case 0
  show ?case
    by (rule exI [where x="norm (c 0) / e"]) (auto simp: mult.commute pos_divide_le_eq assms)
next
  case (Suc n)
  then obtain M where M: "\<forall>z. M \<le> norm z \<longrightarrow> norm (\<Sum>i\<le>n. c i * z^i) \<le> e * norm z ^ Suc n" ..
  show ?case
  proof (rule exI [where x="max 1 (max M ((e + norm(c(Suc n))) / e))"], clarify)
    fix z::'a
    assume "max 1 (max M ((e + norm (c (Suc n))) / e)) \<le> norm z"
    then have norm1: "0 < norm z" "M \<le> norm z" "(e + norm (c (Suc n))) / e \<le> norm z"
      by auto
    then have norm2: "(e + norm (c (Suc n))) \<le> e * norm z"  "(norm z * norm z ^ n) > 0"
      apply (metis assms less_divide_eq mult.commute not_le)
      using norm1 apply (metis mult_pos_pos zero_less_power)
      done
    have "e * (norm z * norm z ^ n) + norm (c (Suc n) * (z * z ^ n)) =
          (e + norm (c (Suc n))) * (norm z * norm z ^ n)"
      by (simp add: norm_mult norm_power algebra_simps)
    also have "... \<le> (e * norm z) * (norm z * norm z ^ n)"
      using norm2
      using assms mult_mono by fastforce
    also have "... = e * (norm z * (norm z * norm z ^ n))"
      by (simp add: algebra_simps)
    finally have "e * (norm z * norm z ^ n) + norm (c (Suc n) * (z * z ^ n))
                  \<le> e * (norm z * (norm z * norm z ^ n))" .
    then show "norm (\<Sum>i\<le>Suc n. c i * z^i) \<le> e * norm z ^ Suc (Suc n)" using M norm1
      by (drule_tac x=z in spec) (auto simp: intro!: adhoc_norm_triangle)
    qed
qed

lemma norm_lemma_xy: assumes "\<bar>b\<bar> + 1 \<le> norm(y) - a" "norm(x) \<le> a" shows "b \<le> norm(x + y)"
proof -
  have "b \<le> norm y - norm x"
    using assms by linarith
  then show ?thesis
    by (metis (no_types) add.commute norm_diff_ineq order_trans)
qed

proposition polyfun_extremal:
  fixes c :: "nat \<Rightarrow> 'a::real_normed_div_algebra"
  assumes "\<exists>k. k \<noteq> 0 \<and> k \<le> n \<and> c k \<noteq> 0"
    shows "eventually (\<lambda>z. norm(\<Sum>i\<le>n. c i * z^i) \<ge> B) at_infinity"
using assms
proof (induction n)
  case 0 then show ?case
    by simp
next
  case (Suc n)
  show ?case
  proof (cases "c (Suc n) = 0")
    case True
    with Suc show ?thesis
      by auto (metis diff_is_0_eq diffs0_imp_equal less_Suc_eq_le not_less_eq)
  next
    case False
    with polyfun_extremal_lemma [of "norm(c (Suc n)) / 2" c n]
    obtain M where M: "\<And>z. M \<le> norm z \<Longrightarrow>
               norm (\<Sum>i\<le>n. c i * z^i) \<le> norm (c (Suc n)) / 2 * norm z ^ Suc n"
      by auto
    show ?thesis
    unfolding eventually_at_infinity
    proof (rule exI [where x="max M (max 1 ((\<bar>B\<bar> + 1) / (norm (c (Suc n)) / 2)))"], clarsimp)
      fix z::'a
      assume les: "M \<le> norm z"  "1 \<le> norm z"  "(\<bar>B\<bar> * 2 + 2) / norm (c (Suc n)) \<le> norm z"
      then have "\<bar>B\<bar> * 2 + 2 \<le> norm z * norm (c (Suc n))"
        by (metis False pos_divide_le_eq zero_less_norm_iff)
      then have "\<bar>B\<bar> * 2 + 2 \<le> norm z ^ (Suc n) * norm (c (Suc n))"
        by (metis \<open>1 \<le> norm z\<close> order.trans mult_right_mono norm_ge_zero self_le_power zero_less_Suc)
      then show "B \<le> norm ((\<Sum>i\<le>n. c i * z^i) + c (Suc n) * (z * z ^ n))" using M les
        apply auto
        apply (rule norm_lemma_xy [where a = "norm (c (Suc n)) * norm z ^ (Suc n) / 2"])
        apply (simp_all add: norm_mult norm_power)
        done
    qed
  qed
qed

proposition polyfun_rootbound:
 fixes c :: "nat \<Rightarrow> 'a::{comm_ring,real_normed_div_algebra}"
 assumes "\<exists>k. k \<le> n \<and> c k \<noteq> 0"
   shows "finite {z. (\<Sum>i\<le>n. c i * z^i) = 0} \<and> card {z. (\<Sum>i\<le>n. c i * z^i) = 0} \<le> n"
using assms
proof (induction n arbitrary: c)
 case (Suc n) show ?case
 proof (cases "{z. (\<Sum>i\<le>Suc n. c i * z^i) = 0} = {}")
   case False
   then obtain a where a: "(\<Sum>i\<le>Suc n. c i * a^i) = 0"
     by auto
   from polyfun_linear_factor_root [OF this]
   obtain b where "\<And>z. (\<Sum>i\<le>Suc n. c i * z^i) = (z - a) * (\<Sum>i< Suc n. b i * z^i)"
     by auto
   then have b: "\<And>z. (\<Sum>i\<le>Suc n. c i * z^i) = (z - a) * (\<Sum>i\<le>n. b i * z^i)"
     by (metis lessThan_Suc_atMost)
   then have ins_ab: "{z. (\<Sum>i\<le>Suc n. c i * z^i) = 0} = insert a {z. (\<Sum>i\<le>n. b i * z^i) = 0}"
     by auto
   have c0: "c 0 = - (a * b 0)" using  b [of 0]
     by simp
   then have extr_prem: "\<not> (\<exists>k\<le>n. b k \<noteq> 0) \<Longrightarrow> \<exists>k. k \<noteq> 0 \<and> k \<le> Suc n \<and> c k \<noteq> 0"
     by (metis Suc.prems le0 minus_zero mult_zero_right)
   have "\<exists>k\<le>n. b k \<noteq> 0"
     apply (rule ccontr)
     using polyfun_extremal [OF extr_prem, of 1]
     apply (auto simp: eventually_at_infinity b simp del: sum.atMost_Suc)
     apply (drule_tac x="of_real ba" in spec, simp)
     done
   then show ?thesis using Suc.IH [of b] ins_ab
     by (auto simp: card_insert_if)
   qed simp
qed simp

corollary
  fixes c :: "nat \<Rightarrow> 'a::{comm_ring,real_normed_div_algebra}"
  assumes "\<exists>k. k \<le> n \<and> c k \<noteq> 0"
    shows polyfun_rootbound_finite: "finite {z. (\<Sum>i\<le>n. c i * z^i) = 0}"
      and polyfun_rootbound_card:   "card {z. (\<Sum>i\<le>n. c i * z^i) = 0} \<le> n"
using polyfun_rootbound [OF assms] by auto

proposition polyfun_finite_roots:
  fixes c :: "nat \<Rightarrow> 'a::{comm_ring,real_normed_div_algebra}"
    shows  "finite {z. (\<Sum>i\<le>n. c i * z^i) = 0} \<longleftrightarrow> (\<exists>k. k \<le> n \<and> c k \<noteq> 0)"
proof (cases " \<exists>k\<le>n. c k \<noteq> 0")
  case True then show ?thesis
    by (blast intro: polyfun_rootbound_finite)
next
  case False then show ?thesis
    by (auto simp: infinite_UNIV_char_0)
qed

lemma polyfun_eq_0:
  fixes c :: "nat \<Rightarrow> 'a::{comm_ring,real_normed_div_algebra}"
    shows  "(\<forall>z. (\<Sum>i\<le>n. c i * z^i) = 0) \<longleftrightarrow> (\<forall>k. k \<le> n \<longrightarrow> c k = 0)"
proof (cases "(\<forall>z. (\<Sum>i\<le>n. c i * z^i) = 0)")
  case True
  then have "\<not> finite {z. (\<Sum>i\<le>n. c i * z^i) = 0}"
    by (simp add: infinite_UNIV_char_0)
  with True show ?thesis
    by (metis (poly_guards_query) polyfun_rootbound_finite)
next
  case False
  then show ?thesis
    by auto
qed

theorem polyfun_eq_const:
  fixes c :: "nat \<Rightarrow> 'a::{comm_ring,real_normed_div_algebra}"
    shows  "(\<forall>z. (\<Sum>i\<le>n. c i * z^i) = k) \<longleftrightarrow> c 0 = k \<and> (\<forall>k. k \<noteq> 0 \<and> k \<le> n \<longrightarrow> c k = 0)"
proof -
  {fix z
    have "(\<Sum>i\<le>n. c i * z^i) = (\<Sum>i\<le>n. (if i = 0 then c 0 - k else c i) * z^i) + k"
      by (induct n) auto
  } then
  have "(\<forall>z. (\<Sum>i\<le>n. c i * z^i) = k) \<longleftrightarrow> (\<forall>z. (\<Sum>i\<le>n. (if i = 0 then c 0 - k else c i) * z^i) = 0)"
    by auto
  also have "... \<longleftrightarrow>  c 0 = k \<and> (\<forall>k. k \<noteq> 0 \<and> k \<le> n \<longrightarrow> c k = 0)"
    by (auto simp: polyfun_eq_0)
  finally show ?thesis .
qed

end


(*
 * This is an autogenerated file. Do not edit.
 * The original is Laws.thy. It was converted using instantiate_laws.py.
 *)

section \<open>Generic laws about registers, instantiated classically\<close>

theory Laws_Classical
  imports Axioms_Classical
begin

text \<open>This notation is only used inside this file\<close>
notation map_comp (infixl "*\<^sub>u" 55)
notation tensor_update (infixr "\<otimes>\<^sub>u" 70)
notation register_pair ("'(_;_')")

subsection \<open>Elementary facts\<close>

declare id_preregister[simp]
declare id_update_left[simp]
declare id_update_right[simp]
declare register_preregister[simp]
declare register_comp[simp]
declare register_of_id[simp]
declare register_tensor_left[simp]
declare register_tensor_right[simp]
declare preregister_mult_right[simp]
declare preregister_mult_left[simp]
declare register_id[simp]

subsection \<open>Preregisters\<close>

lemma preregister_tensor_left[simp]: \<open>preregister (\<lambda>b::'b::type update. tensor_update a b)\<close>
  for a :: \<open>'a::type update\<close>
proof -
  have \<open>preregister ((\<lambda>b1::('a\<times>'b) update. (a \<otimes>\<^sub>u Some) *\<^sub>u b1) o (\<lambda>b. tensor_update Some b))\<close>
    by (rule comp_preregister; simp)
  then show ?thesis
    by (simp add: o_def tensor_update_mult)
qed

lemma preregister_tensor_right[simp]: \<open>preregister (\<lambda>a::'a::type update. tensor_update a b)\<close>
  for b :: \<open>'b::type update\<close>
proof -
  have \<open>preregister ((\<lambda>a1::('a\<times>'b) update. (Some \<otimes>\<^sub>u b) *\<^sub>u a1) o (\<lambda>a. tensor_update a Some))\<close>
    by (rule comp_preregister, simp_all)
  then show ?thesis
    by (simp add: o_def tensor_update_mult)
qed

subsection \<open>Registers\<close>

lemma id_update_tensor_register[simp]:
  assumes \<open>register F\<close>
  shows \<open>register (\<lambda>a::'a::type update. Some \<otimes>\<^sub>u F a)\<close>
  using assms apply (rule register_comp[unfolded o_def])
  by simp

lemma register_tensor_id_update[simp]:
  assumes \<open>register F\<close>
  shows \<open>register (\<lambda>a::'a::type update. F a \<otimes>\<^sub>u Some)\<close>
  using assms apply (rule register_comp[unfolded o_def])
  by simp

subsection \<open>Tensor product of registers\<close>

definition register_tensor  (infixr "\<otimes>\<^sub>r" 70) where
  "register_tensor F G = register_pair (\<lambda>a. tensor_update (F a) Some) (\<lambda>b. tensor_update Some (G b))"

lemma register_tensor_is_register:
  fixes F :: "'a::type update \<Rightarrow> 'b::type update" and G :: "'c::type update \<Rightarrow> 'd::type update"
  shows "register F \<Longrightarrow> register G \<Longrightarrow> register (F \<otimes>\<^sub>r G)"
  unfolding register_tensor_def
  apply (rule register_pair_is_register)
  by (simp_all add: tensor_update_mult)

lemma register_tensor_apply[simp]:
  fixes F :: "'a::type update \<Rightarrow> 'b::type update" and G :: "'c::type update \<Rightarrow> 'd::type update"
  assumes \<open>register F\<close> and \<open>register G\<close>
  shows "(F \<otimes>\<^sub>r G) (a \<otimes>\<^sub>u b) = F a \<otimes>\<^sub>u G b"
  unfolding register_tensor_def
  apply (subst register_pair_apply)
  unfolding register_tensor_def
  by (simp_all add: assms tensor_update_mult)

definition "separating (_::'b::type itself) A \<longleftrightarrow>
  (\<forall>F G :: 'a::type update \<Rightarrow> 'b update. preregister F \<longrightarrow> preregister G \<longrightarrow> (\<forall>x\<in>A. F x = G x) \<longrightarrow> F = G)"

lemma separating_UNIV[simp]: \<open>separating TYPE(_) UNIV\<close>
  unfolding separating_def by auto

lemma separating_mono: \<open>A \<subseteq> B \<Longrightarrow> separating TYPE('a::type) A \<Longrightarrow> separating TYPE('a) B\<close>
  unfolding separating_def by (meson in_mono)

lemma register_eqI: \<open>separating TYPE('b::type) A \<Longrightarrow> preregister F \<Longrightarrow> preregister G \<Longrightarrow> (\<And>x. x\<in>A \<Longrightarrow> F x = G x) \<Longrightarrow> F = (G::_ \<Rightarrow> 'b update)\<close>
  unfolding separating_def by auto

lemma separating_tensor:
  fixes A :: \<open>'a::type update set\<close> and B :: \<open>'b::type update set\<close>
  assumes [simp]: \<open>separating TYPE('c::type) A\<close>
  assumes [simp]: \<open>separating TYPE('c) B\<close>
  shows \<open>separating TYPE('c) {a \<otimes>\<^sub>u b | a b. a\<in>A \<and> b\<in>B}\<close>
proof (unfold separating_def, intro allI impI)
  fix F G :: \<open>('a\<times>'b) update \<Rightarrow> 'c update\<close>
  assume [simp]: \<open>preregister F\<close> \<open>preregister G\<close>
  have [simp]: \<open>preregister (\<lambda>x. F (a \<otimes>\<^sub>u x))\<close> for a
    using _ \<open>preregister F\<close> apply (rule comp_preregister[unfolded o_def])
    by simp
  have [simp]: \<open>preregister (\<lambda>x. G (a \<otimes>\<^sub>u x))\<close> for a
    using _ \<open>preregister G\<close> apply (rule comp_preregister[unfolded o_def])
    by simp
  have [simp]: \<open>preregister (\<lambda>x. F (x \<otimes>\<^sub>u b))\<close> for b
    using _ \<open>preregister F\<close> apply (rule comp_preregister[unfolded o_def])
    by simp
  have [simp]: \<open>preregister (\<lambda>x. G (x \<otimes>\<^sub>u b))\<close> for b
    using _ \<open>preregister G\<close> apply (rule comp_preregister[unfolded o_def])
    by simp

  assume \<open>\<forall>x\<in>{a \<otimes>\<^sub>u b |a b. a\<in>A \<and> b\<in>B}. F x = G x\<close>
  then have EQ: \<open>F (a \<otimes>\<^sub>u b) = G (a \<otimes>\<^sub>u b)\<close> if \<open>a \<in> A\<close> and \<open>b \<in> B\<close> for a b
    using that by auto
  then have \<open>F (a \<otimes>\<^sub>u b) = G (a \<otimes>\<^sub>u b)\<close> if \<open>a \<in> A\<close> for a b
    apply (rule register_eqI[where A=B, THEN fun_cong, where x=b, rotated -1])
    using that by auto
  then have \<open>F (a \<otimes>\<^sub>u b) = G (a \<otimes>\<^sub>u b)\<close> for a b
    apply (rule register_eqI[where A=A, THEN fun_cong, where x=a, rotated -1])
    by auto
  then show "F = G"
    apply (rule tensor_extensionality[rotated -1])
    by auto
qed

lemma register_tensor_distrib:
  assumes [simp]: \<open>register F\<close> \<open>register G\<close> \<open>register H\<close> \<open>register L\<close>
  shows \<open>(F \<otimes>\<^sub>r G) o (H \<otimes>\<^sub>r L) = (F o H) \<otimes>\<^sub>r (G o L)\<close>
  apply (rule tensor_extensionality)
  by (auto intro!: register_comp register_preregister register_tensor_is_register)

text \<open>The following is easier to apply using the @{method rule}-method than @{thm [source] separating_tensor}\<close>
lemma separating_tensor':
  fixes A :: \<open>'a::type update set\<close> and B :: \<open>'b::type update set\<close>
  assumes \<open>separating TYPE('c::type) A\<close>
  assumes \<open>separating TYPE('c) B\<close>
  assumes \<open>C = {a \<otimes>\<^sub>u b | a b. a\<in>A \<and> b\<in>B}\<close>
  shows \<open>separating TYPE('c) C\<close>
  using assms
  by (simp add: separating_tensor)

lemma tensor_extensionality3:
  fixes F G :: \<open>('a::type\<times>'b::type\<times>'c::type) update \<Rightarrow> 'd::type update\<close>
  assumes [simp]: \<open>register F\<close> \<open>register G\<close>
  assumes "\<And>f g h. F (f \<otimes>\<^sub>u g \<otimes>\<^sub>u h) = G (f \<otimes>\<^sub>u g \<otimes>\<^sub>u h)"
  shows "F = G"
proof (rule register_eqI[where A=\<open>{a\<otimes>\<^sub>ub\<otimes>\<^sub>uc| a b c. True}\<close>])
  have \<open>separating TYPE('d) {b \<otimes>\<^sub>u c |b c. True}\<close>
    apply (rule separating_tensor'[where A=UNIV and B=UNIV])
    by auto
  then show \<open>separating TYPE('d) {a \<otimes>\<^sub>u b \<otimes>\<^sub>u c |a b c. True}\<close>
    apply (rule_tac separating_tensor'[where A=UNIV and B=\<open>{b\<otimes>\<^sub>uc| b c. True}\<close>])
    by auto
  show \<open>preregister F\<close> \<open>preregister G\<close> by auto
  show \<open>x \<in> {a \<otimes>\<^sub>u b \<otimes>\<^sub>u c |a b c. True} \<Longrightarrow> F x = G x\<close> for x
    using assms(3) by auto
qed

lemma tensor_extensionality3':
  fixes F G :: \<open>(('a::type\<times>'b::type)\<times>'c::type) update \<Rightarrow> 'd::type update\<close>
  assumes [simp]: \<open>register F\<close> \<open>register G\<close>
  assumes "\<And>f g h. F ((f \<otimes>\<^sub>u g) \<otimes>\<^sub>u h) = G ((f \<otimes>\<^sub>u g) \<otimes>\<^sub>u h)"
  shows "F = G"
proof (rule register_eqI[where A=\<open>{(a\<otimes>\<^sub>ub)\<otimes>\<^sub>uc| a b c. True}\<close>])
  have \<open>separating TYPE('d) {a \<otimes>\<^sub>u b | a b. True}\<close>
    apply (rule separating_tensor'[where A=UNIV and B=UNIV])
    by auto
  then show \<open>separating TYPE('d) {(a \<otimes>\<^sub>u b) \<otimes>\<^sub>u c |a b c. True}\<close>
    apply (rule_tac separating_tensor'[where B=UNIV and A=\<open>{a\<otimes>\<^sub>ub| a b. True}\<close>])
    by auto
  show \<open>preregister F\<close> \<open>preregister G\<close> by auto
  show \<open>x \<in> {(a \<otimes>\<^sub>u b) \<otimes>\<^sub>u c |a b c. True} \<Longrightarrow> F x = G x\<close> for x
    using assms(3) by auto
qed

lemma register_tensor_id[simp]: \<open>id \<otimes>\<^sub>r id = id\<close>
  apply (rule tensor_extensionality)
  by (auto simp add: register_tensor_is_register)

subsection \<open>Pairs and compatibility\<close>

definition compatible :: \<open>('a::type update \<Rightarrow> 'c::type update)
                       \<Rightarrow> ('b::type update \<Rightarrow> 'c update) \<Rightarrow> bool\<close> where
  \<open>compatible F G \<longleftrightarrow> register F \<and> register G \<and> (\<forall>a b. F a *\<^sub>u G b = G b *\<^sub>u F a)\<close>

lemma compatibleI:
  assumes "register F" and "register G"
  assumes \<open>\<And>a b. (F a) *\<^sub>u (G b) = (G b) *\<^sub>u (F a)\<close>
  shows "compatible F G"
  using assms unfolding compatible_def by simp

lemma swap_registers:
  assumes "compatible R S"
  shows "R a *\<^sub>u S b = S b *\<^sub>u R a"
  using assms unfolding compatible_def by metis

lemma compatible_sym: "compatible x y \<Longrightarrow> compatible y x"
  by (simp add: compatible_def)

lemma pair_is_register[simp]:
  assumes "compatible F G"
  shows "register (F; G)"
  by (metis assms compatible_def register_pair_is_register)

lemma register_pair_apply:
  assumes \<open>compatible F G\<close>
  shows \<open>(F; G) (a \<otimes>\<^sub>u b) = (F a) *\<^sub>u (G b)\<close>
  apply (rule register_pair_apply)
  using assms unfolding compatible_def by metis+

lemma register_pair_apply':
  assumes \<open>compatible F G\<close>
  shows \<open>(F; G) (a \<otimes>\<^sub>u b) = (G b) *\<^sub>u (F a)\<close>
  apply (subst register_pair_apply)
  using assms by (auto simp: compatible_def intro: register_preregister)

lemma compatible_comp_left[simp]: "compatible F G \<Longrightarrow> register H \<Longrightarrow> compatible (F \<circ> H) G"
  by (simp add: compatible_def)

lemma compatible_comp_right[simp]: "compatible F G \<Longrightarrow> register H \<Longrightarrow> compatible F (G \<circ> H)"
  by (simp add: compatible_def)

lemma compatible_comp_inner[simp]:
  "compatible F G \<Longrightarrow> register H \<Longrightarrow> compatible (H \<circ> F) (H \<circ> G)"
  by (smt (verit, best) comp_apply compatible_def register_comp register_mult)

lemma compatible_register1: \<open>compatible F G \<Longrightarrow> register F\<close>
  by (simp add: compatible_def)
lemma compatible_register2: \<open>compatible F G \<Longrightarrow> register G\<close>
  by (simp add: compatible_def)

lemma pair_o_tensor:
  assumes "compatible A B" and [simp]: \<open>register C\<close> and [simp]: \<open>register D\<close>
  shows "(A; B) o (C \<otimes>\<^sub>r D) = (A o C; B o D)"
  apply (rule tensor_extensionality)
  using assms by (simp_all add: register_tensor_is_register register_pair_apply comp_preregister)

lemma compatible_tensor_id_update_left[simp]:
  fixes F :: "'a::type update \<Rightarrow> 'c::type update" and G :: "'b::type update \<Rightarrow> 'c::type update"
  assumes "compatible F G"
  shows "compatible (\<lambda>a. Some \<otimes>\<^sub>u F a) (\<lambda>a. Some \<otimes>\<^sub>u G a)"
  using assms apply (rule compatible_comp_inner[unfolded o_def])
  by simp

lemma compatible_tensor_id_update_right[simp]:
  fixes F :: "'a::type update \<Rightarrow> 'c::type update" and G :: "'b::type update \<Rightarrow> 'c::type update"
  assumes "compatible F G"
  shows "compatible (\<lambda>a. F a \<otimes>\<^sub>u Some) (\<lambda>a. G a \<otimes>\<^sub>u Some)"
  using assms apply (rule compatible_comp_inner[unfolded o_def])
  by simp

lemma compatible_tensor_id_update_rl[simp]:
  assumes "register F" and "register G"
  shows "compatible (\<lambda>a. F a \<otimes>\<^sub>u Some) (\<lambda>a. Some \<otimes>\<^sub>u G a)"
  apply (rule compatibleI)
  using assms by (auto simp: tensor_update_mult)

lemma compatible_tensor_id_update_lr[simp]:
  assumes "register F" and "register G"
  shows "compatible (\<lambda>a. Some \<otimes>\<^sub>u F a) (\<lambda>a. G a \<otimes>\<^sub>u Some)"
  apply (rule compatibleI)
  using assms by (auto simp: tensor_update_mult)

lemma register_comp_pair:
  assumes [simp]: \<open>register F\<close> and [simp]: \<open>compatible G H\<close>
  shows "(F o G; F o H) = F o (G; H)"
proof (rule tensor_extensionality)
  show \<open>preregister (F \<circ> G;F \<circ> H)\<close> and \<open>preregister (F \<circ> (G;H))\<close>
    by simp_all

  have [simp]: \<open>compatible (F o G) (F o H)\<close>
    apply (rule compatible_comp_inner, simp)
    by simp
  then have [simp]: \<open>register (F \<circ> G)\<close> \<open>register (F \<circ> H)\<close>
    unfolding compatible_def by auto
  from assms have [simp]: \<open>register G\<close> \<open>register H\<close>
    unfolding compatible_def by auto
  fix a b
  show \<open>(F \<circ> G;F \<circ> H) (a \<otimes>\<^sub>u b) = (F \<circ> (G;H)) (a \<otimes>\<^sub>u b)\<close>
    by (auto simp: register_pair_apply register_mult tensor_update_mult)
qed

lemma swap_registers_left:
  assumes "compatible R S"
  shows "R a *\<^sub>u S b *\<^sub>u c = S b *\<^sub>u R a *\<^sub>u c"
  using assms unfolding compatible_def by metis

lemma swap_registers_right:
  assumes "compatible R S"
  shows "c *\<^sub>u R a *\<^sub>u S b = c *\<^sub>u S b *\<^sub>u R a"
  by (metis assms comp_update_assoc compatible_def)

lemmas compatible_ac_rules = swap_registers comp_update_assoc[symmetric] swap_registers_right

subsection \<open>Fst and Snd\<close>

definition Fst where \<open>Fst a = a \<otimes>\<^sub>u Some\<close>
definition Snd where \<open>Snd a = Some \<otimes>\<^sub>u a\<close>

lemma register_Fst[simp]: \<open>register Fst\<close>
  unfolding Fst_def by (rule register_tensor_left)

lemma register_Snd[simp]: \<open>register Snd\<close>
  unfolding Snd_def by (rule register_tensor_right)

lemma compatible_Fst_Snd[simp]: \<open>compatible Fst Snd\<close>
  apply (rule compatibleI, simp, simp)
  by (simp add: Fst_def Snd_def tensor_update_mult)

lemmas compatible_Snd_Fst[simp] = compatible_Fst_Snd[THEN compatible_sym]

definition \<open>swap = (Snd; Fst)\<close>

lemma swap_apply[simp]: "swap (a \<otimes>\<^sub>u b) = (b \<otimes>\<^sub>u a)"
  unfolding swap_def
  by (simp add: Axioms_Classical.register_pair_apply Fst_def Snd_def tensor_update_mult)

lemma swap_o_Fst: "swap o Fst = Snd"
  by (auto simp add: Fst_def Snd_def)
lemma swap_o_Snd: "swap o Snd = Fst"
  by (auto simp add: Fst_def Snd_def)

lemma register_swap[simp]: \<open>register swap\<close>
  by (simp add: swap_def)

lemma pair_Fst_Snd: \<open>(Fst; Snd) = id\<close>
  apply (rule tensor_extensionality)
  by (simp_all add: register_pair_apply Fst_def Snd_def tensor_update_mult)

lemma swap_o_swap[simp]: \<open>swap o swap = id\<close>
  by (metis swap_def compatible_Snd_Fst pair_Fst_Snd register_comp_pair register_swap swap_o_Fst swap_o_Snd)

lemma swap_swap[simp]: \<open>swap (swap x) = x\<close>
  by (simp add: pointfree_idE)

lemma inv_swap[simp]: \<open>inv swap = swap\<close>
  by (meson inv_unique_comp swap_o_swap)

lemma register_pair_Fst:
  assumes \<open>compatible F G\<close>
  shows \<open>(F;G) o Fst = F\<close>
  using assms by (auto intro!: ext simp: Fst_def register_pair_apply compatible_register2)

lemma register_pair_Snd:
  assumes \<open>compatible F G\<close>
  shows \<open>(F;G) o Snd = G\<close>
  using assms by (auto intro!: ext simp: Snd_def register_pair_apply compatible_register1)

lemma register_Fst_register_Snd[simp]:
  assumes \<open>register F\<close>
  shows \<open>(F o Fst; F o Snd) = F\<close>
  apply (rule tensor_extensionality)
  using assms by (auto simp: register_pair_apply Fst_def Snd_def register_mult tensor_update_mult)

lemma register_Snd_register_Fst[simp]:
  assumes \<open>register F\<close>
  shows \<open>(F o Snd; F o Fst) = F o swap\<close>
  apply (rule tensor_extensionality)
  using assms by (auto simp: register_pair_apply Fst_def Snd_def register_mult tensor_update_mult)

lemma compatible3[simp]:
  assumes [simp]: "compatible F G" and "compatible G H" and "compatible F H"
  shows "compatible (F; G) H"
proof (rule compatibleI)
  have [simp]: \<open>register F\<close> \<open>register G\<close> \<open>register H\<close>
    using assms compatible_def by auto
  then have [simp]: \<open>preregister F\<close> \<open>preregister G\<close> \<open>preregister H\<close>
    using register_preregister by blast+
  have [simp]: \<open>preregister (\<lambda>a. (F;G) a *\<^sub>u z)\<close> for z
    apply (rule comp_preregister[unfolded o_def, of \<open>(F;G)\<close>])
    by simp_all
  have [simp]: \<open>preregister (\<lambda>a. z *\<^sub>u (F;G) a)\<close> for z
    apply (rule comp_preregister[unfolded o_def, of \<open>(F;G)\<close>])
    by simp_all
  have "(F; G) (f \<otimes>\<^sub>u g) *\<^sub>u H h = H h *\<^sub>u (F; G) (f \<otimes>\<^sub>u g)" for f g h
  proof -
    have FH: "F f *\<^sub>u H h = H h *\<^sub>u F f"
      using assms compatible_def by metis
    have GH: "G g *\<^sub>u H h = H h *\<^sub>u G g"
      using assms compatible_def by metis
    have \<open>(F; G) (f \<otimes>\<^sub>u g) *\<^sub>u (H h) = F f *\<^sub>u G g *\<^sub>u H h\<close>
      using \<open>compatible F G\<close> by (subst register_pair_apply, auto)
    also have \<open>\<dots> = H h *\<^sub>u F f *\<^sub>u G g\<close>
      using FH GH by (metis comp_update_assoc)
    also have \<open>\<dots> = H h *\<^sub>u (F; G) (f \<otimes>\<^sub>u g)\<close>
      using \<open>compatible F G\<close> by (subst register_pair_apply, auto simp: comp_update_assoc)
    finally show ?thesis
      by -
  qed
  then show "(F; G) fg *\<^sub>u (H h) = (H h) *\<^sub>u (F; G) fg" for fg h
    apply (rule_tac tensor_extensionality[THEN fun_cong])
    by auto
  show "register H" and  "register (F; G)"
    by simp_all
qed

lemma compatible3'[simp]:
  assumes "compatible F G" and "compatible G H" and "compatible F H"
  shows "compatible F (G; H)"
  apply (rule compatible_sym)
  apply (rule compatible3)
  using assms by (auto simp: compatible_sym)

lemma pair_o_swap[simp]:
  assumes [simp]: "compatible A B"
  shows "(A; B) o swap = (B; A)"
proof (rule tensor_extensionality)
  have [simp]: "preregister A" "preregister B"
     apply (metis (no_types, opaque_lifting) assms compatible_register1 register_preregister)
    by (metis (full_types) assms compatible_register2 register_preregister)
  then show \<open>preregister ((A; B) \<circ> swap)\<close>
    by simp
  show \<open>preregister (B; A)\<close>
    by (metis (no_types, lifting) assms compatible_sym register_preregister pair_is_register)
  show \<open>((A; B) \<circ> swap) (a \<otimes>\<^sub>u b) = (B; A) (a \<otimes>\<^sub>u b)\<close> for a b
    (* Without the "only:", we would not need the "apply subst",
       but that proof fails when instantiated in Classical.thy *)
    apply (simp only: o_def swap_apply)
    apply (subst register_pair_apply, simp)
    apply (subst register_pair_apply, simp add: compatible_sym)
    by (metis (no_types, lifting) assms compatible_def)
qed

subsection \<open>Compatibility of register tensor products\<close>

lemma compatible_register_tensor:
  fixes F :: \<open>'a::type update \<Rightarrow> 'e::type update\<close> and G :: \<open>'b::type update \<Rightarrow> 'f::type update\<close>
    and F' :: \<open>'c::type update \<Rightarrow> 'e update\<close> and G' :: \<open>'d::type update \<Rightarrow> 'f update\<close>
  assumes [simp]: \<open>compatible F F'\<close>
  assumes [simp]: \<open>compatible G G'\<close>
  shows \<open>compatible (F \<otimes>\<^sub>r G) (F' \<otimes>\<^sub>r G')\<close>
proof -
  note [intro!] =
    comp_preregister[OF _ preregister_mult_right, unfolded o_def]
    comp_preregister[OF _ preregister_mult_left, unfolded o_def]
    comp_preregister
    register_tensor_is_register
  have [simp]: \<open>register F\<close> \<open>register G\<close> \<open>register F'\<close> \<open>register G'\<close>
    using assms compatible_def by blast+
  have [simp]: \<open>register (F \<otimes>\<^sub>r G)\<close> \<open>register (F' \<otimes>\<^sub>r G')\<close>
    by (auto simp add: register_tensor_def)
  have [simp]: \<open>register (F;F')\<close> \<open>register (G;G')\<close>
    by auto
  define reorder :: \<open>(('a\<times>'b) \<times> ('c\<times>'d)) update \<Rightarrow> (('a\<times>'c) \<times> ('b\<times>'d)) update\<close>
    where \<open>reorder = ((Fst o Fst; Snd o Fst); (Fst o Snd; Snd o Snd))\<close>
  have [simp]: \<open>preregister reorder\<close>
    by (auto simp: reorder_def)
  have [simp]: \<open>reorder ((a \<otimes>\<^sub>u b) \<otimes>\<^sub>u (c \<otimes>\<^sub>u d)) = ((a \<otimes>\<^sub>u c) \<otimes>\<^sub>u (b \<otimes>\<^sub>u d))\<close> for a b c d
    apply (simp add: reorder_def register_pair_apply)
    by (simp add: Fst_def Snd_def tensor_update_mult)
  define \<Phi> where \<open>\<Phi> c d = ((F;F') \<otimes>\<^sub>r (G;G')) o reorder o (\<lambda>\<sigma>. \<sigma> \<otimes>\<^sub>u (c \<otimes>\<^sub>u d))\<close> for c d
  have [simp]: \<open>preregister (\<Phi> c d)\<close> for c d
    unfolding \<Phi>_def
    by (auto intro: register_preregister)
  have \<open>\<Phi> c d (a \<otimes>\<^sub>u b) = (F \<otimes>\<^sub>r G) (a \<otimes>\<^sub>u b) *\<^sub>u (F' \<otimes>\<^sub>r G') (c \<otimes>\<^sub>u d)\<close> for a b c d
    unfolding \<Phi>_def by (auto simp: register_pair_apply tensor_update_mult)
  then have \<Phi>1: \<open>\<Phi> c d \<sigma> = (F \<otimes>\<^sub>r G) \<sigma> *\<^sub>u (F' \<otimes>\<^sub>r G') (c \<otimes>\<^sub>u d)\<close> for c d \<sigma>
    apply (rule_tac fun_cong[of _ _ \<sigma>])
    apply (rule tensor_extensionality)
    by auto
  have \<open>\<Phi> c d (a \<otimes>\<^sub>u b) = (F' \<otimes>\<^sub>r G') (c \<otimes>\<^sub>u d) *\<^sub>u (F \<otimes>\<^sub>r G) (a \<otimes>\<^sub>u b)\<close> for a b c d
    unfolding \<Phi>_def apply (auto simp: register_pair_apply)
    by (metis assms(1) assms(2) compatible_def tensor_update_mult)
  then have \<Phi>2: \<open>\<Phi> c d \<sigma> = (F' \<otimes>\<^sub>r G') (c \<otimes>\<^sub>u d) *\<^sub>u (F \<otimes>\<^sub>r G) \<sigma>\<close> for c d \<sigma>
    apply (rule_tac fun_cong[of _ _ \<sigma>])
    apply (rule tensor_extensionality)
    by auto
  from \<Phi>1 \<Phi>2 have \<open>(F \<otimes>\<^sub>r G) \<sigma> *\<^sub>u (F' \<otimes>\<^sub>r G') \<tau> = (F' \<otimes>\<^sub>r G') \<tau> *\<^sub>u (F \<otimes>\<^sub>r G) \<sigma>\<close> for \<tau> \<sigma>
    apply (rule_tac fun_cong[of _ _ \<tau>])
    apply (rule tensor_extensionality)
    by auto
  then show ?thesis
    apply (rule compatibleI[rotated -1])
    by auto
qed

subsection \<open>Associativity of the tensor product\<close>

definition assoc :: \<open>(('a::type\<times>'b::type)\<times>'c::type) update \<Rightarrow> ('a\<times>('b\<times>'c)) update\<close> where
  \<open>assoc = ((Fst; Snd o Fst); Snd o Snd)\<close>

lemma assoc_is_hom[simp]: \<open>preregister assoc\<close>
  by (auto simp: assoc_def)

lemma assoc_apply[simp]: \<open>assoc ((a \<otimes>\<^sub>u b) \<otimes>\<^sub>u c) = (a \<otimes>\<^sub>u (b \<otimes>\<^sub>u c))\<close>
  by (auto simp: assoc_def register_pair_apply Fst_def Snd_def tensor_update_mult)

definition assoc' :: \<open>('a\<times>('b\<times>'c)) update \<Rightarrow> (('a::type\<times>'b::type)\<times>'c::type) update\<close> where
  \<open>assoc' = (Fst o Fst; (Fst o Snd; Snd))\<close>

lemma assoc'_is_hom[simp]: \<open>preregister assoc'\<close>
  by (auto simp: assoc'_def)

lemma assoc'_apply[simp]: \<open>assoc' (a \<otimes>\<^sub>u (b \<otimes>\<^sub>u c)) =  ((a \<otimes>\<^sub>u b) \<otimes>\<^sub>u c)\<close>
  by (auto simp: assoc'_def register_pair_apply Fst_def Snd_def tensor_update_mult)

lemma register_assoc[simp]: \<open>register assoc\<close>
  unfolding assoc_def
  by force

lemma register_assoc'[simp]: \<open>register assoc'\<close>
  unfolding assoc'_def
  by force

lemma pair_o_assoc[simp]:
  assumes [simp]: \<open>compatible F G\<close> \<open>compatible G H\<close> \<open>compatible F H\<close>
  shows \<open>(F; (G; H)) \<circ> assoc = ((F; G); H)\<close>
proof (rule tensor_extensionality3')
  show \<open>register ((F; (G; H)) \<circ> assoc)\<close>
    by simp
  show \<open>register ((F; G); H)\<close>
    by simp
  show \<open>((F; (G; H)) \<circ> assoc) ((f \<otimes>\<^sub>u g) \<otimes>\<^sub>u h) = ((F; G); H) ((f \<otimes>\<^sub>u g) \<otimes>\<^sub>u h)\<close> for f g h
    by (simp add: register_pair_apply assoc_apply comp_update_assoc)
qed

lemma pair_o_assoc'[simp]:
  assumes [simp]: \<open>compatible F G\<close> \<open>compatible G H\<close> \<open>compatible F H\<close>
  shows \<open>((F; G); H) \<circ> assoc' = (F; (G; H))\<close>
proof (rule tensor_extensionality3)
  show \<open>register (((F; G); H) \<circ> assoc')\<close>
    by simp
  show \<open>register (F; (G; H))\<close>
    by simp
  show \<open>(((F; G); H) \<circ> assoc') (f \<otimes>\<^sub>u g \<otimes>\<^sub>u h) = (F; (G; H)) (f \<otimes>\<^sub>u g \<otimes>\<^sub>u h)\<close> for f g h
    by (simp add: register_pair_apply assoc'_apply comp_update_assoc)
qed

lemma assoc'_o_assoc[simp]: \<open>assoc' o assoc = id\<close>
  apply (rule tensor_extensionality3')
  by auto

lemma assoc'_assoc[simp]: \<open>assoc' (assoc x) = x\<close>
  by (simp add: pointfree_idE)

lemma assoc_o_assoc'[simp]: \<open>assoc o assoc' = id\<close>
  apply (rule tensor_extensionality3)
  by auto

lemma assoc_assoc'[simp]: \<open>assoc (assoc' x) = x\<close>
  by (simp add: pointfree_idE)

lemma inv_assoc[simp]: \<open>inv assoc = assoc'\<close>
  using assoc'_o_assoc assoc_o_assoc' inv_unique_comp by blast

lemma inv_assoc'[simp]: \<open>inv assoc' = assoc\<close>
  by (simp add: inv_equality)

lemma [simp]: \<open>bij assoc'\<close>
  using assoc'_o_assoc assoc_o_assoc' o_bij by blast

subsection \<open>Iso-registers\<close>

definition \<open>iso_register F \<longleftrightarrow> register F \<and> (\<exists>G. register G \<and> F o G = id \<and> G o F = id)\<close>
  for F :: \<open>_::type update \<Rightarrow> _::type update\<close>

lemma iso_registerI:
  assumes \<open>register F\<close> \<open>register G\<close> \<open>F o G = id\<close> \<open>G o F = id\<close>
  shows \<open>iso_register F\<close>
  using assms(1) assms(2) assms(3) assms(4) iso_register_def by blast

lemma iso_register_inv: \<open>iso_register F \<Longrightarrow> iso_register (inv F)\<close>
  by (metis inv_unique_comp iso_register_def)

lemma iso_register_inv_comp1: \<open>iso_register F \<Longrightarrow> inv F o F = id\<close>
  using inv_unique_comp iso_register_def by blast

lemma iso_register_inv_comp2: \<open>iso_register F \<Longrightarrow> F o inv F = id\<close>
  using inv_unique_comp iso_register_def by blast

lemma iso_register_id[simp]: \<open>iso_register id\<close>
  by (simp add: iso_register_def)

lemma iso_register_is_register: \<open>iso_register F \<Longrightarrow> register F\<close>
  using iso_register_def by blast

lemma iso_register_comp[simp]:
  assumes [simp]: \<open>iso_register F\<close> \<open>iso_register G\<close>
  shows \<open>iso_register (F o G)\<close>
proof -
  from assms obtain F' G' where [simp]: \<open>register F'\<close> \<open>register G'\<close> \<open>F o F' = id\<close> \<open>F' o F = id\<close>
    \<open>G o G' = id\<close> \<open>G' o G = id\<close>
    by (meson iso_register_def)
  show ?thesis
    apply (rule iso_registerI[where G=\<open>G' o F'\<close>])
       apply (auto simp: register_tensor_is_register iso_register_is_register register_tensor_distrib)
     apply (metis \<open>F \<circ> F' = id\<close> \<open>G \<circ> G' = id\<close> fcomp_assoc fcomp_comp id_fcomp)
    by (metis (no_types, lifting) \<open>F \<circ> F' = id\<close> \<open>F' \<circ> F = id\<close> \<open>G' \<circ> G = id\<close> fun.map_comp inj_iff inv_unique_comp o_inv_o_cancel)
qed

lemma iso_register_tensor_is_iso_register[simp]:
  assumes [simp]: \<open>iso_register F\<close> \<open>iso_register G\<close>
  shows \<open>iso_register (F \<otimes>\<^sub>r G)\<close>
proof -
  from assms obtain F' G' where [simp]: \<open>register F'\<close> \<open>register G'\<close> \<open>F o F' = id\<close> \<open>F' o F = id\<close>
    \<open>G o G' = id\<close> \<open>G' o G = id\<close>
    by (meson iso_register_def)
  show ?thesis
    apply (rule iso_registerI[where G=\<open>F' \<otimes>\<^sub>r G'\<close>])
    by (auto simp: register_tensor_is_register iso_register_is_register register_tensor_distrib)
qed

lemma iso_register_bij: \<open>iso_register F \<Longrightarrow> bij F\<close>
  using iso_register_def o_bij by auto

lemma inv_register_tensor[simp]:
  assumes [simp]: \<open>iso_register F\<close> \<open>iso_register G\<close>
  shows \<open>inv (F \<otimes>\<^sub>r G) = inv F \<otimes>\<^sub>r inv G\<close>
  apply (auto intro!: inj_imp_inv_eq bij_is_inj iso_register_bij
              simp: register_tensor_distrib[unfolded o_def, THEN fun_cong] iso_register_is_register
                    iso_register_inv bij_is_surj iso_register_bij surj_f_inv_f)
  by (metis eq_id_iff register_tensor_id)

lemma iso_register_swap[simp]: \<open>iso_register swap\<close>
  apply (rule iso_registerI[of _ swap])
  by auto

lemma iso_register_assoc[simp]: \<open>iso_register assoc\<close>
  apply (rule iso_registerI[of _ assoc'])
  by auto

lemma iso_register_assoc'[simp]: \<open>iso_register assoc'\<close>
  apply (rule iso_registerI[of _ assoc])
  by auto

definition \<open>equivalent_registers F G \<longleftrightarrow> (register F \<and> (\<exists>I. iso_register I \<and> F o I = G))\<close>
  for F G :: \<open>_::type update \<Rightarrow> _::type update\<close>

lemma iso_register_equivalent_id[simp]: \<open>equivalent_registers id F \<longleftrightarrow> iso_register F\<close>
  by (simp add: equivalent_registers_def)

lemma equivalent_registersI:
  assumes \<open>register F\<close>
  assumes \<open>iso_register I\<close>
  assumes \<open>F o I = G\<close>
  shows \<open>equivalent_registers F G\<close>
  using assms unfolding equivalent_registers_def by blast

lemma equivalent_registers_register_left: \<open>equivalent_registers F G \<Longrightarrow> register F\<close>
  using equivalent_registers_def by auto

lemma equivalent_registers_register_right: \<open>register G\<close> if \<open>equivalent_registers F G\<close>
  by (metis equivalent_registers_def iso_register_def register_comp that)

lemma equivalent_registers_sym:
  assumes \<open>equivalent_registers F G\<close>
  shows \<open>equivalent_registers G F\<close>
  by (smt (verit) assms comp_id equivalent_registers_def equivalent_registers_register_right fun.map_comp iso_register_def)

lemma equivalent_registers_trans[trans]:
  assumes \<open>equivalent_registers F G\<close> and \<open>equivalent_registers G H\<close>
  shows \<open>equivalent_registers F H\<close>
proof -
  from assms have [simp]: \<open>register F\<close> \<open>register G\<close>
    by (auto simp: equivalent_registers_def)
  from assms(1) obtain I where [simp]: \<open>iso_register I\<close> and \<open>F o I = G\<close>
    using equivalent_registers_def by blast
  from assms(2) obtain J where [simp]: \<open>iso_register J\<close> and \<open>G o J = H\<close>
    using equivalent_registers_def by blast
  have \<open>register F\<close>
    by (auto simp: equivalent_registers_def)
  moreover have \<open>iso_register (I o J)\<close>
    using \<open>iso_register I\<close> \<open>iso_register J\<close> iso_register_comp by blast
  moreover have \<open>F o (I o J) = H\<close>
    by (simp add: \<open>F \<circ> I = G\<close> \<open>G \<circ> J = H\<close> o_assoc)
  ultimately show ?thesis
    by (rule equivalent_registersI)
qed

lemma equivalent_registers_assoc[simp]:
  assumes [simp]: \<open>compatible F G\<close> \<open>compatible F H\<close> \<open>compatible G H\<close>
  shows \<open>equivalent_registers (F;(G;H)) ((F;G);H)\<close>
  apply (rule equivalent_registersI[where I=assoc])
  by auto

lemma equivalent_registers_pair_right:
  assumes [simp]: \<open>compatible F G\<close>
  assumes eq: \<open>equivalent_registers G H\<close>
  shows \<open>equivalent_registers (F;G) (F;H)\<close>
proof -
  from eq obtain I where [simp]: \<open>iso_register I\<close> and \<open>G o I = H\<close>
    by (metis equivalent_registers_def)
  then have *: \<open>(F;G) \<circ> (id \<otimes>\<^sub>r I) = (F;H)\<close>
    by (auto intro!: tensor_extensionality register_comp register_preregister register_tensor_is_register
        simp:  register_pair_apply iso_register_is_register)
  show ?thesis
    apply (rule equivalent_registersI[where I=\<open>id \<otimes>\<^sub>r I\<close>])
    using * by (auto intro!: iso_register_tensor_is_iso_register)
qed

lemma equivalent_registers_pair_left:
  assumes [simp]: \<open>compatible F G\<close>
  assumes eq: \<open>equivalent_registers F H\<close>
  shows \<open>equivalent_registers (F;G) (H;G)\<close>
proof -
  from eq obtain I where [simp]: \<open>iso_register I\<close> and \<open>F o I = H\<close>
    by (metis equivalent_registers_def)
  then have *: \<open>(F;G) \<circ> (I \<otimes>\<^sub>r id) = (H;G)\<close>
    by (auto intro!: tensor_extensionality register_comp register_preregister register_tensor_is_register
        simp:  register_pair_apply iso_register_is_register)
  show ?thesis
    apply (rule equivalent_registersI[where I=\<open>I \<otimes>\<^sub>r id\<close>])
    using * by (auto intro!: iso_register_tensor_is_iso_register)
qed

lemma equivalent_registers_comp:
  assumes \<open>register H\<close>
  assumes \<open>equivalent_registers F G\<close>
  shows \<open>equivalent_registers (H o F) (H o G)\<close>
  by (metis (no_types, lifting) assms(1) assms(2) comp_assoc equivalent_registers_def register_comp)

subsection \<open>Compatibility simplification\<close>

text \<open>The simproc \<open>compatibility_warn\<close> produces helpful warnings for subgoals of the form
   \<^term>\<open>compatible x y\<close> that are probably unsolvable due to missing declarations of
   variable compatibility facts. Same for subgoals of the form \<^term>\<open>register x\<close>.\<close>
simproc_setup "compatibility_warn" ("compatible x y" | "register x") = \<open>
let val thy_string = Markup.markup (Theory.get_markup \<^theory>) (Context.theory_name \<^theory>)
in
fn m => fn ctxt => fn ct => let
  val (x,y) = case Thm.term_of ct of
                 Const(\<^const_name>\<open>compatible\<close>,_ ) $ x $ y => (x, SOME y)
               | Const(\<^const_name>\<open>register\<close>,_ ) $ x => (x, NONE)
  val str : string lazy = Lazy.lazy (fn () => Syntax.string_of_term ctxt (Thm.term_of ct))
  fun w msg = warning (msg ^ "\n(Disable these warnings with: using [[simproc del: "^thy_string^".compatibility_warn]])")
  val _ = case (x,y) of
        (Free(n,T), SOME (Free(n',T'))) =>
            if String.isPrefix ":" n orelse String.isPrefix ":" n' then
                      w ("Simplification subgoal " ^ Lazy.force str ^ " contains a bound variable.\n" ^
                      "Try to add some assumptions that makes this goal solvable by the simplifier")
            else if n=n' then (if T=T' then ()
                          else w ("In simplification subgoal " ^ Lazy.force str ^
                               ", variables have same name and different types.\n" ^
                               "Probably something is wrong."))
                    else w ("Simplification subgoal " ^ Lazy.force str ^
                            " occurred but cannot be solved.\n" ^
                            "Please add assumption/fact  [simp]: \<open>" ^ Lazy.force str ^
                            "\<close>  somewhere.")
      | (Free(n,T), NONE) =>
            if String.isPrefix ":" n then
                      w ("Simplification subgoal '" ^ Lazy.force str ^ "' contains a bound variable.\n" ^
                      "Try to add some assumptions that makes this goal solvable by the simplifier")
            else w ("Simplification subgoal " ^ Lazy.force str ^ " occurred but cannot be solved.\n" ^
                    "Please add assumption/fact  [simp]: \<open>" ^ Lazy.force str ^ "\<close>  somewhere.")
      | _ => ()
  in NONE end
end\<close>

named_theorems register_attribute_rule_immediate
named_theorems register_attribute_rule

lemmas [register_attribute_rule] = conjunct1 conjunct2 iso_register_is_register iso_register_is_register[OF iso_register_inv]
lemmas [register_attribute_rule_immediate] = compatible_sym compatible_register1 compatible_register2
  asm_rl[of \<open>compatible _ _\<close>] asm_rl[of \<open>iso_register _\<close>] asm_rl[of \<open>register _\<close>] iso_register_inv

text \<open>The following declares an attribute \<open>[register]\<close>. When the attribute is applied to a fact
  of the form \<^term>\<open>register F\<close>, \<^term>\<open>iso_register F\<close>, \<^term>\<open>compatible F G\<close> or a conjunction of these,
  then those facts are added to the simplifier together with some derived theorems
  (e.g., \<^term>\<open>compatible F G\<close> also adds \<^term>\<open>register F\<close>).

  In theory \<open>Laws_Complement\<close>, support for \<^term>\<open>is_unit_register F\<close> and \<^term>\<open>complements F G\<close> is
  added to this attribute.\<close>

setup \<open>
let
fun add thm results =
  Net.insert_term (K true) (Thm.concl_of thm, thm) results
  handle Net.INSERT => results
fun try_rule f thm rule state = case SOME (rule OF [thm]) handle THM _ => NONE  of
  NONE => state | SOME th => f th state
fun collect (rules,rules_immediate) thm results =
  results |> fold (try_rule add thm) rules_immediate |> fold (try_rule (collect (rules,rules_immediate)) thm) rules
fun declare thm context = let
  val ctxt = Context.proof_of context
  val rules = Named_Theorems.get ctxt @{named_theorems register_attribute_rule}
  val rules_immediate = Named_Theorems.get ctxt @{named_theorems register_attribute_rule_immediate}
  val thms = collect (rules,rules_immediate) thm Net.empty |> Net.entries
  (* val _ = \<^print> thms *)
  in Simplifier.map_ss (fn ctxt => ctxt addsimps thms) context end
in
Attrib.setup \<^binding>\<open>register\<close>
 (Scan.succeed (Thm.declaration_attribute declare))
  "Add register-related rules to the simplifier"
end
\<close>

subsection \<open>Notation\<close>

no_notation map_comp (infixl "*\<^sub>u" 55)
no_notation tensor_update (infixr "\<otimes>\<^sub>u" 70)

bundle register_notation begin
notation register_tensor (infixr "\<otimes>\<^sub>r" 70)
notation register_pair ("'(_;_')")
end

bundle no_register_notation begin
no_notation register_tensor (infixr "\<otimes>\<^sub>r" 70)
no_notation register_pair ("'(_;_')")
end

end


text\<open>CNFs alone are nice, but now we want to relate between CNFs and formulas.\<close>
theory CNF_Formulas
imports Formulas CNF
begin

context begin

(* attempts to eliminate \<bottom> from formulas while converting to nnf have been made.
But that just gives you additional cases. So nnfs and cnfs will contain \<bottom> *)

function (sequential) nnf where
"nnf (Atom k) = (Atom k)" |
"nnf \<bottom> = \<bottom>" |
"nnf (Not (And F G)) = Or (nnf (Not F)) (nnf (Not G))" |
"nnf (Not (Or F G)) = And (nnf (Not F)) (nnf (Not G))" |
"nnf (Not (Not F)) = nnf F" |
"nnf (Not (Imp F G)) = And (nnf F) (nnf (Not G))" |
"nnf (Not F) = (Not F)" |
"nnf (And F G) = And (nnf F) (nnf G)" |
"nnf (Or F G) = Or (nnf F) (nnf G)" |
"nnf (Imp F G) = Or (nnf (Not F)) (nnf G)"
  by(pat_completeness) auto

private fun nnf_cost where
"nnf_cost (Atom _) = 42" |
"nnf_cost \<bottom> = 42" |
"nnf_cost (Not F) = Suc (nnf_cost F)" |
"nnf_cost (And F G) = Suc (nnf_cost F + nnf_cost G)" |
"nnf_cost (Or F G) = Suc (nnf_cost F + nnf_cost G)" |
"nnf_cost (Imp F G) = Suc (Suc (nnf_cost F + nnf_cost G))" (* this is why *)

termination nnf by(relation "measure (\<lambda>F. nnf_cost F)"; simp)

lemma "nnf ((Atom (k::nat)) \<^bold>\<rightarrow> (Not ((Atom l) \<^bold>\<or> (Not (Atom m))))) = \<^bold>\<not> (Atom k) \<^bold>\<or> (\<^bold>\<not> (Atom l) \<^bold>\<and> Atom m)"
  by code_simp

fun is_lit_plus where
"is_lit_plus \<bottom> = True" |
"is_lit_plus (Not \<bottom>) = True" |
"is_lit_plus (Atom _) = True" |
"is_lit_plus (Not (Atom _)) = True" |
"is_lit_plus _ = False"
case_of_simps is_lit_plus_cases: is_lit_plus.simps
fun is_disj where
(* It is crucial for this to be a (right) deep tree for the proof of LSC \<Longrightarrow> Res
  At some point, we obtain a subset A where A is in a disjunction from (A \<or> B).
  Now, resolution is at a loss because you can't say anything about the subset.
  If, however, that subset is sandwiched between a literal and the empty clause,
  you can just cover all the cases. *)
"is_disj (Or F G) = (is_lit_plus F \<and> is_disj G)" |
"is_disj F = is_lit_plus F"
fun is_cnf where
(* here, we do want to allow arbitrary trees of \<and>.
  If we do not do that, the proofs in LSC_Resolution won't work,
  since it relies on the \<and> case being just
  a simple split in LSC and union in Resolution.
  It is possible that that is fixable, but at what cost? *)
"is_cnf (And F G) = (is_cnf F \<and> is_cnf G)" |
"is_cnf H = is_disj H"
fun is_nnf where
"is_nnf (Imp F G) = False" |
"is_nnf (And F G) = (is_nnf F \<and> is_nnf G)" |
"is_nnf (Or F G) = (is_nnf F \<and> is_nnf G)" |
"is_nnf F = is_lit_plus F"

lemma is_nnf_nnf: "is_nnf (nnf F)"
  by(induction F rule: nnf.induct; simp)
lemma nnf_no_imp: "A \<^bold>\<rightarrow> B \<notin> set (subformulae (nnf F))"
  by(induction F rule: nnf.induct; simp)
lemma subformulae_nnf: "is_nnf F \<Longrightarrow> G \<in> set (subformulae F) \<Longrightarrow> is_nnf G" (* fun fact *)
  by(induction F rule: is_nnf.induct; simp add: is_lit_plus_cases split: formula.splits; elim disjE conjE; simp)
lemma is_nnf_NotD: "is_nnf (\<^bold>\<not> F) \<Longrightarrow> (\<exists>k. F = Atom k) \<or> F = \<bottom>"
  by(cases F; simp)

fun cnf :: "'a formula \<Rightarrow> 'a clause set" where
"cnf (Atom k) = {{ k\<^sup>+ }}" |
"cnf (Not (Atom k)) = {{ k\<inverse> }}" |
"cnf \<bottom> = {\<box>}" |
"cnf (Not \<bottom>) = {}"  |
"cnf (And F G) = cnf F \<union> cnf G"  |
"cnf (Or F G) = {C \<union> D| C D. C \<in> (cnf F) \<and> D \<in> (cnf G)}"

lemma cnf_fin:
assumes "is_nnf F"
shows "finite (cnf F)" "C \<in> cnf F \<Longrightarrow> finite C"
proof -
  have "finite (cnf F) \<and> (C \<in> cnf F \<longrightarrow> finite C)" using assms
    by(induction F arbitrary: C rule: cnf.induct;  clarsimp simp add: finite_image_set2)
  thus "finite (cnf F)" "C \<in> cnf F \<Longrightarrow> finite C" by simp+
qed

(* Sets, as produced by @{const cnf} can be hard to handle.
   Less because of their infinity, more because of their lack of explicit order. *)
fun cnf_lists :: "'a formula \<Rightarrow> 'a literal list list" where
"cnf_lists (Atom k) = [[ k\<^sup>+ ]]" |
"cnf_lists (Not (Atom k)) = [[ k\<inverse> ]]" |
"cnf_lists \<bottom> = [[]]" |
"cnf_lists (Not \<bottom>) = []"  |
"cnf_lists (And F G) = cnf_lists F @ cnf_lists G"  |
"cnf_lists (Or F G) = [f @ g. f \<leftarrow> (cnf_lists F), g \<leftarrow> (cnf_lists G)]"

primrec form_of_lit where
"form_of_lit (Pos k) = Atom k" |
"form_of_lit (Neg k) = \<^bold>\<not>(Atom k)"
case_of_simps form_of_lit_cases: form_of_lit.simps

definition "disj_of_clause c \<equiv> \<^bold>\<Or>[form_of_lit l. l \<leftarrow> c]"
definition "form_of_cnf F \<equiv> \<^bold>\<And>[disj_of_clause c. c \<leftarrow> F]"
definition "cnf_form_of \<equiv> form_of_cnf \<circ> cnf_lists"
lemmas cnf_form_of_defs = cnf_form_of_def form_of_cnf_def disj_of_clause_def

lemma disj_of_clause_simps[simp]:
  "disj_of_clause [] = \<bottom>"
  "disj_of_clause (F#FF) = form_of_lit F \<^bold>\<or> disj_of_clause FF"
by(simp_all add: disj_of_clause_def)

lemma is_cnf_BigAnd: "is_cnf (\<^bold>\<And>ls) \<longleftrightarrow> (\<forall>l \<in> set ls. is_cnf l)"
  by(induction ls; simp)

private lemma BigOr_is_not_cnf'': "is_cnf (\<^bold>\<Or>ls) \<Longrightarrow> (\<forall>l \<in> set ls. is_lit_plus l)"
proof(induction ls)
  case (Cons l ls)
  from Cons.prems have "is_cnf (\<^bold>\<Or> ls)"
    by (metis BigOr.simps is_cnf.simps(3,5) is_disj.simps(1) list.exhaust)
  thus ?case using Cons by simp
qed simp
private lemma BigOr_is_not_cnf': "(\<forall>l \<in> set ls. is_lit_plus l) \<Longrightarrow> is_cnf (\<^bold>\<Or>ls)"
  by(induction ls; simp) (metis BigOr.simps(1, 2) formula.distinct(25) is_cnf.elims(2) is_cnf.simps(3) list.exhaust)
  (* ugh *)
lemma BigOr_is_not_cnf: "is_cnf (\<^bold>\<Or>ls) \<longleftrightarrow> (\<forall>l \<in> set ls. is_lit_plus l)"
  using BigOr_is_not_cnf' BigOr_is_not_cnf'' by blast

lemma is_nnf_BigAnd[simp]: "is_nnf (\<^bold>\<And>ls) \<longleftrightarrow> (\<forall>l \<in> set ls. is_nnf l)"
  by(induction ls; simp)
lemma is_nnf_BigOr[simp]: "is_nnf (\<^bold>\<Or>ls) \<longleftrightarrow> (\<forall>l \<in> set ls. is_nnf l)"
  by(induction ls; simp)
lemma form_of_lit_is_nnf[simp,intro!]: "is_nnf (form_of_lit x)"
  by(cases x; simp)
lemma form_of_lit_is_lit[simp,intro!]: "is_lit_plus (form_of_lit x)"
  by(cases x; simp)
lemma disj_of_clause_is_nnf[simp,intro!]: "is_nnf (disj_of_clause F)"
  unfolding disj_of_clause_def by simp

lemma cnf_form_of_is: "is_nnf F \<Longrightarrow> is_cnf (cnf_form_of F)"
  by(cases F) (auto simp: cnf_form_of_defs is_cnf_BigAnd BigOr_is_not_cnf)

lemma nnf_cnf_form: "is_nnf F \<Longrightarrow> is_nnf (cnf_form_of F)"
  by(cases F) (auto simp add: cnf_form_of_defs)

lemma cnf_BigAnd: "cnf (\<^bold>\<And>ls) = (\<Union>x \<in> set ls. cnf x)"
  by(induction ls; simp)

lemma cnf_BigOr: "cnf (\<^bold>\<Or> (x @ y)) =  {f \<union> g |f g. f \<in> cnf (\<^bold>\<Or>x) \<and> g \<in> cnf (\<^bold>\<Or>y)}"
  by(induction x arbitrary: y; simp) (metis (no_types, hide_lams) sup.assoc)

lemma cnf_cnf: "is_nnf F \<Longrightarrow> cnf (cnf_form_of F) = cnf F"
  by(induction F rule: cnf.induct;
     fastforce simp add: cnf_form_of_defs cnf_BigAnd cnf_BigOr)
(* this is not an idempotency (is that a word?) lemma, since cnf_form_of is not idempotent. *)

lemma is_nnf_nnf_id: "is_nnf F \<Longrightarrow> nnf F = F"
proof(induction rule: is_nnf.induct)
  fix v assume "is_nnf (\<^bold>\<not> v)"
  thus "nnf (\<^bold>\<not> v) = \<^bold>\<not> v" by(cases v rule: is_lit_plus.cases; simp)
qed simp_all

lemma disj_of_clause_is: "is_disj (disj_of_clause R)"
  by(induction R; simp)

lemma form_of_cnf_is_nnf: "is_nnf (form_of_cnf R)"
  unfolding form_of_cnf_def by simp

lemma cnf_disj: "cnf (disj_of_clause R) = {set R}"
  by(induction R; simp add: form_of_lit_cases split: literal.splits)
lemma cnf_disj_ex: "is_disj F \<Longrightarrow> \<exists>R. cnf F = {R} \<or> cnf F = {}"
  by(induction F rule: is_disj.induct; clarsimp simp: is_lit_plus_cases split: formula.splits)

lemma cnf_form_of_cnf: "cnf (form_of_cnf S) = set (map set S)"
  unfolding form_of_cnf_def by (simp add: cnf_BigAnd cnf_disj) blast

lemma disj_is_nnf: "is_disj F \<Longrightarrow> is_nnf F"
  by(induction F rule: is_disj.induct; simp add: is_lit_plus_cases split: formula.splits)

lemma nnf_BigAnd: "nnf (\<^bold>\<And>F) = \<^bold>\<And>(map nnf F)"
  by(induction F; simp)

end

end


theory Impl_Uv_Set
imports
  "../../Iterator/Iterator"
  "../Intf/Intf_Set"
  "../../../Native_Word/Uint"
begin

  subsection {* Bit-Vectors as Lists of Words *}

  subsubsection {* Lookup *}

  primrec lookup :: "nat \<Rightarrow> ('a::len) word list \<Rightarrow> bool" where
    "lookup _ [] \<longleftrightarrow> False"
  | "lookup n (w#ws)
      \<longleftrightarrow> (if n<len_of TYPE('a) then test_bit w n else lookup (n-len_of TYPE('a)) ws)"

  lemma lookup_append[simp]: "lookup n (w1@w2 :: 'a::len word list)
    \<longleftrightarrow> (
      if n < len_of TYPE('a) * length w1 then
        lookup n w1
      else lookup (n - len_of TYPE('a) * length w1) w2)"
    by (induction w1 arbitrary: n) auto

  lemma lookup_zeroes[simp]: "lookup i (replicate n (0\<Colon>'a::len word)) = False"
    by (induction n arbitrary: i) auto

  subsubsection {* Empty *}

  definition empty :: "'a::len word list" where "empty = []"

  subsubsection {* Set and Reset Bit *}

  function single_bit :: "nat \<Rightarrow> ('a::len) word list"
    where "single_bit n = (
      if (n<len_of TYPE('a)) then
        [set_bit 0 n True]
      else 0#single_bit (n-len_of TYPE('a)))"
    by pat_completeness auto
  termination
    apply (relation "measure id")
    apply simp
    apply simp
    by (metis diff_less le0 lens_not_0(2) sup.semilattice_strict_iff_order)

  declare single_bit.simps[simp del]

  lemma lookup_single_bit[simp]: "lookup i ((single_bit n)::'a::len word list) \<longleftrightarrow> i = n"
    apply (induction n arbitrary: i rule: single_bit.induct)
    apply (subst single_bit.simps)
    apply (auto simp: bin_nth_sc_gen)
    done

find_consts name: set_bit

  primrec set_bit :: "nat \<Rightarrow> 'a::len word list \<Rightarrow> 'a::len word list" where
    "set_bit i [] = single_bit i"
  | "set_bit i (w#ws) = (
      if i<len_of TYPE('a) then
        bits_class.set_bit w i True # ws
      else
        w # set_bit (i - len_of TYPE('a)) ws)"

  lemma set_bit_lookup[simp]: "lookup i (set_bit j ws) \<longleftrightarrow> (lookup i ws \<or> i=j)"
    apply (induction ws arbitrary: i j)
    apply (auto simp: test_bit_set_gen word_size)
    done

  primrec reset_bit :: "nat \<Rightarrow> 'a::len word list \<Rightarrow> 'a::len word list" where
    "reset_bit i [] = []"
  | "reset_bit i (w#ws) = (
      if i<len_of TYPE('a) then
        bits_class.set_bit w i False # ws
      else
        w # reset_bit (i - len_of TYPE('a)) ws)"

  lemma reset_bit_lookup[simp]: "lookup i (reset_bit j ws) \<longleftrightarrow> (lookup i ws \<and> i\<noteq>j)"
    apply (induction ws arbitrary: i j)
    apply (auto simp: test_bit_set_gen word_size)
    done

  subsubsection {* Binary Operations *}

  definition
    is_bin_op_impl
    :: "(bool\<Rightarrow>bool\<Rightarrow>bool) \<Rightarrow> ('a::len word \<Rightarrow> 'a::len word \<Rightarrow> 'a::len word) \<Rightarrow> bool"
    where "is_bin_op_impl f g \<equiv>
    (\<forall>w v.  \<forall>i<len_of TYPE('a). test_bit (g w v) i \<longleftrightarrow> f (test_bit w i) (test_bit v i))"

  definition "is_strict_bin_op_impl f g \<equiv> is_bin_op_impl f g \<and> f False False = False"

  fun binary :: "('a::len word \<Rightarrow> 'a::len word \<Rightarrow> 'a::len word)
    \<Rightarrow> 'a::len word list \<Rightarrow> 'a::len word list \<Rightarrow> 'a::len word list"
    where
    "binary f [] [] = []"
  | "binary f [] (w#ws) = f 0 w # binary f [] ws"
  | "binary f (v#vs) [] = f v 0 # binary f vs []"
  | "binary f (v#vs) (w#ws) = f v w # binary f vs ws"

  lemma binary_lookup:
    assumes "is_strict_bin_op_impl f g"
    shows "lookup i (binary g ws vs) \<longleftrightarrow> f (lookup i ws) (lookup i vs)"
    using assms
    apply (induction g ws vs arbitrary: i rule: binary.induct)
    apply (auto simp: is_strict_bin_op_impl_def is_bin_op_impl_def)
    done

  subsection {* Abstraction to Sets of Naturals *}

  definition "\<alpha> uv \<equiv> {n. lookup n uv}"

  lemma memb_correct: "lookup i ws \<longleftrightarrow> i\<in>\<alpha> ws"
    by (auto simp: \<alpha>_def)

  lemma empty_correct: "\<alpha> empty = {}"
    by (simp add: \<alpha>_def empty_def)

  lemma single_bit_correct: "\<alpha> (single_bit n) = {n}"
    by (simp add: \<alpha>_def)

  lemma insert_correct: "\<alpha> (set_bit i ws) = Set.insert i (\<alpha> ws)"
    by (auto simp add: \<alpha>_def)

  lemma delete_correct: "\<alpha> (reset_bit i ws) = (\<alpha> ws) - {i}"
    by (auto simp add: \<alpha>_def)

  lemma binary_correct:
    assumes "is_strict_bin_op_impl f g"
    shows "\<alpha> (binary g ws vs) = { i . f (i\<in>\<alpha> ws) (i\<in>\<alpha> vs) }"
    unfolding \<alpha>_def
    by (auto simp add: binary_lookup[OF assms])

  fun union :: "'a::len word list \<Rightarrow> 'a::len word list \<Rightarrow> 'a::len word list"
    where
    "union [] ws = ws"
  | "union vs [] = vs"
  | "union (v#vs) (w#ws) = (v OR w) # union vs ws"

  lemma union_lookup[simp]:
    fixes vs :: "'a::len word list"
    shows "lookup i (union vs ws) \<longleftrightarrow> lookup i vs \<or> lookup i ws"
    apply (induction vs ws arbitrary: i rule: union.induct)
    apply (auto simp: word_ao_nth)
    done

  lemma union_correct: "\<alpha> (union ws vs) = \<alpha> ws \<union> \<alpha> vs"
    by (auto simp add: \<alpha>_def)

  fun inter :: "'a::len word list \<Rightarrow> 'a::len word list \<Rightarrow> 'a::len word list"
    where
    "inter [] ws = []"
  | "inter vs [] = []"
  | "inter (v#vs) (w#ws) = (v AND w) # inter vs ws"

  lemma inter_lookup[simp]:
    fixes vs :: "'a::len word list"
    shows "lookup i (inter vs ws) \<longleftrightarrow> lookup i vs \<and> lookup i ws"
    apply (induction vs ws arbitrary: i rule: inter.induct)
    apply (auto simp: word_ao_nth)
    done

  lemma inter_correct: "\<alpha> (inter ws vs) = \<alpha> ws \<inter> \<alpha> vs"
    by (auto simp add: \<alpha>_def)

  fun diff :: "'a::len word list \<Rightarrow> 'a::len word list \<Rightarrow> 'a::len word list"
    where
    "diff [] ws = []"
  | "diff vs [] = vs"
  | "diff (v#vs) (w#ws) = (v AND NOT w) # diff vs ws"

  lemma diff_lookup[simp]:
    fixes vs :: "'a::len word list"
    shows "lookup i (diff vs ws) \<longleftrightarrow> lookup i vs - lookup i ws"
    apply (induction vs ws arbitrary: i rule: diff.induct)
    apply (auto simp: word_ops_nth_size word_size)
    done

  lemma diff_correct: "\<alpha> (diff ws vs) = \<alpha> ws - \<alpha> vs"
    by (auto simp add: \<alpha>_def)

  fun zeroes :: "'a::len word list \<Rightarrow> bool" where
    "zeroes [] \<longleftrightarrow> True"
  | "zeroes (w#ws) \<longleftrightarrow> w=0 \<and> zeroes ws"

  lemma zeroes_lookup: "zeroes ws \<longleftrightarrow> (\<forall>i. \<not>lookup i ws)"
    apply (induction ws)
    apply (auto simp: word_eq_iff)
    by (metis diff_add_inverse2 not_add_less2)

  lemma isEmpty_correct: "zeroes ws \<longleftrightarrow> \<alpha> ws = {}"
    by (auto simp: zeroes_lookup \<alpha>_def)

  fun equal :: "'a::len word list \<Rightarrow> 'a::len word list \<Rightarrow> bool" where
    "equal [] [] \<longleftrightarrow> True"
  | "equal [] ws \<longleftrightarrow> zeroes ws"
  | "equal vs [] \<longleftrightarrow> zeroes vs"
  | "equal (v#vs) (w#ws) \<longleftrightarrow> v=w \<and> equal vs ws"

  lemma equal_lookup:
    fixes vs ws :: "'a::len word list"
    shows "equal vs ws \<longleftrightarrow> (\<forall>i. lookup i vs = lookup i ws)"
  proof (induction vs ws rule: equal.induct)
    fix v w and vs ws :: "'a::len word list"
    assume IH: "equal vs ws = (\<forall>i. lookup i vs = lookup i ws)"
    show "equal (v # vs) (w # ws) = (\<forall>i. lookup i (v # vs) = lookup i (w # ws))"
    proof (rule iffI, rule allI)
      fix i
      assume "equal (v#vs) (w#ws)"
      thus "lookup i (v # vs) = lookup i (w # ws)"
        by (auto simp: IH)
    next
      assume "\<forall>i. lookup i (v # vs) = lookup i (w # ws)"
      thus "equal (v # vs) (w # ws)"
        apply (auto simp: word_eq_iff IH)
        apply metis
        apply metis
        apply (drule_tac x="i + len_of TYPE('a)" in spec)
        apply auto []
        apply (drule_tac x="i + len_of TYPE('a)" in spec)
        apply auto []
        done
    qed
  qed (auto simp: zeroes_lookup)

  lemma equal_correct: "equal vs ws \<longleftrightarrow> \<alpha> vs = \<alpha> ws"
    by (auto simp: \<alpha>_def equal_lookup)

  fun subseteq :: "'a::len word list \<Rightarrow> 'a::len word list \<Rightarrow> bool" where
    "subseteq [] ws \<longleftrightarrow> True"
  | "subseteq vs [] \<longleftrightarrow> zeroes vs"
  | "subseteq (v#vs) (w#ws) \<longleftrightarrow> (v AND NOT w = 0) \<and> subseteq vs ws"

  lemma subseteq_lookup:
    fixes vs ws :: "'a::len word list"
    shows "subseteq vs ws \<longleftrightarrow> (\<forall>i. lookup i vs \<longrightarrow> lookup i ws)"
    apply (induction vs ws rule: subseteq.induct)
    apply simp
    apply (auto simp: zeroes_lookup) []
    apply (auto simp: word_ops_nth_size word_size word_eq_iff)
    by (metis diff_add_inverse2 not_add_less2)

  lemma subseteq_correct: "subseteq vs ws \<longleftrightarrow> \<alpha> vs \<subseteq> \<alpha> ws"
    by (auto simp: \<alpha>_def subseteq_lookup)

  fun subset :: "'a::len word list \<Rightarrow> 'a::len word list \<Rightarrow> bool" where
    "subset [] ws \<longleftrightarrow> \<not>zeroes ws"
  | "subset vs [] \<longleftrightarrow> False"
  | "subset (v#vs) (w#ws) \<longleftrightarrow> (if v=w then subset vs ws else subseteq (v#vs) (w#ws))"

  lemma subset_lookup:
    fixes vs ws :: "'a::len word list"
    shows "subset vs ws \<longleftrightarrow> ((\<forall>i. lookup i vs \<longrightarrow> lookup i ws)
      \<and> (\<exists>i. \<not>lookup i vs \<and> lookup i ws))"
    apply (induction vs ws rule: subset.induct)
    apply (simp add: zeroes_lookup)
    apply (simp add: zeroes_lookup) []
    apply (simp del: subseteq_correct add: subseteq_lookup)
    apply safe
    apply simp_all
    apply (auto simp: word_ops_nth_size word_size word_eq_iff)
    done

  lemma subset_correct: "subset vs ws \<longleftrightarrow> \<alpha> vs \<subset> \<alpha> ws"
    by (auto simp: \<alpha>_def subset_lookup)

  fun disjoint :: "'a::len word list \<Rightarrow> 'a::len word list \<Rightarrow> bool" where
    "disjoint [] ws \<longleftrightarrow> True"
  | "disjoint vs [] \<longleftrightarrow> True"
  | "disjoint (v#vs) (w#ws) \<longleftrightarrow> (v AND w = 0) \<and> disjoint vs ws"

  lemma disjoint_lookup:
    fixes vs ws :: "'a::len word list"
    shows "disjoint vs ws \<longleftrightarrow> (\<forall>i. \<not>(lookup i vs \<and> lookup i ws))"
    apply (induction vs ws rule: disjoint.induct)
    apply simp
    apply simp
    apply (auto simp: word_ops_nth_size word_size word_eq_iff)
    by (metis diff_add_inverse2 not_add_less2)

  lemma disjoint_correct: "disjoint vs ws \<longleftrightarrow> \<alpha> vs \<inter> \<alpha> ws = {}"
    by (auto simp: \<alpha>_def disjoint_lookup)

subsection {* Lifting to Uint *}
  type_synonym uint_vector = "uint list"

  lift_definition uv_\<alpha> :: "uint_vector \<Rightarrow> nat set" is \<alpha> .
  lift_definition uv_lookup :: "nat \<Rightarrow> uint_vector \<Rightarrow> bool" is lookup .
  lift_definition uv_empty :: "uint_vector" is empty .
  lift_definition uv_single_bit :: "nat \<Rightarrow> uint_vector" is single_bit .
  lift_definition uv_set_bit :: "nat \<Rightarrow> uint_vector \<Rightarrow> uint_vector" is set_bit .
  lift_definition uv_reset_bit :: "nat \<Rightarrow> uint_vector \<Rightarrow> uint_vector" is reset_bit .
  lift_definition uv_union :: "uint_vector \<Rightarrow> uint_vector \<Rightarrow> uint_vector" is union .
  lift_definition uv_inter :: "uint_vector \<Rightarrow> uint_vector \<Rightarrow> uint_vector" is inter .
  lift_definition uv_diff :: "uint_vector \<Rightarrow> uint_vector \<Rightarrow> uint_vector" is diff .
  lift_definition uv_zeroes :: "uint_vector \<Rightarrow> bool" is zeroes .
  lift_definition uv_equal :: "uint_vector \<Rightarrow> uint_vector \<Rightarrow> bool" is equal .
  lift_definition uv_subseteq :: "uint_vector \<Rightarrow> uint_vector \<Rightarrow> bool" is subseteq .
  lift_definition uv_subset :: "uint_vector \<Rightarrow> uint_vector \<Rightarrow> bool" is subset .
  lift_definition uv_disjoint :: "uint_vector \<Rightarrow> uint_vector \<Rightarrow> bool" is disjoint .

  lemmas uv_memb_correct = memb_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_empty_correct = empty_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_single_bit_correct = single_bit_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_insert_correct = insert_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_delete_correct = delete_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_union_correct = union_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_inter_correct = inter_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_diff_correct = diff_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_isEmpty_correct = isEmpty_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_equal_correct = equal_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_subseteq_correct = subseteq_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_subset_correct = subset_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_disjoint_correct = disjoint_correct[where 'a=dflt_size, Transfer.transferred]

  lemmas [where 'a=dflt_size, Transfer.transferred, code] =
    lookup.simps
    empty_def
    single_bit.simps
    set_bit.simps
    reset_bit.simps
    union.simps
    inter.simps
    diff.simps
    zeroes.simps
    equal.simps
    subseteq.simps
    subset.simps
    disjoint.simps

  hide_const (open) \<alpha> lookup empty single_bit set_bit reset_bit union inter diff zeroes
    equal subseteq subset disjoint

subsection {* Autoref Setup *}

  definition uv_set_rel_def_internal:
    "uv_set_rel Rk \<equiv>
      if Rk=nat_rel then br uv_\<alpha> (\<lambda>_. True) else {}"
  lemma uv_set_rel_def:
    "\<langle>nat_rel\<rangle>uv_set_rel \<equiv> br uv_\<alpha> (\<lambda>_. True)"
    unfolding uv_set_rel_def_internal relAPP_def by simp

  lemmas [autoref_rel_intf] = REL_INTFI[of "uv_set_rel" i_set]

  lemma uv_set_rel_sv[relator_props]: "single_valued (\<langle>nat_rel\<rangle>uv_set_rel)"
    unfolding uv_set_rel_def by auto

  lemma uv_autoref[autoref_rules,param]:
    "(uv_lookup,op \<in>) \<in> nat_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> bool_rel"
    "(uv_empty,{}) \<in> \<langle>nat_rel\<rangle>uv_set_rel"
    "(uv_set_bit,insert) \<in> nat_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel"
    "(uv_reset_bit,op_set_delete) \<in> nat_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel"
    "(uv_union,op \<union>) \<in> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel"
    "(uv_inter,op \<inter>) \<in> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel"
    "(uv_diff,op -) \<in> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel"
    "(uv_zeroes,op_set_isEmpty) \<in> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> bool_rel"
    "(uv_equal,op =) \<in> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> bool_rel"
    "(uv_subseteq,op \<subseteq>) \<in> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> bool_rel"
    "(uv_subset,op \<subset>) \<in> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> bool_rel"
    "(uv_disjoint,op_set_disjoint) \<in> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> bool_rel"
    by (auto
      simp: uv_set_rel_def br_def
      simp: uv_memb_correct uv_empty_correct uv_insert_correct uv_delete_correct
      simp: uv_union_correct uv_inter_correct uv_diff_correct uv_isEmpty_correct
      simp: uv_equal_correct uv_subseteq_correct uv_subset_correct uv_disjoint_correct)

  export_code
    uv_lookup
    uv_empty
    uv_single_bit
    uv_set_bit
    uv_reset_bit
    uv_union
    uv_inter
    uv_diff
    uv_zeroes
    uv_equal
    uv_subseteq
    uv_subset
    uv_disjoint
  checking SML Scala Haskell? OCaml?

end


(*  Title:  HOL/ex/Arith_Examples.thy
    Author: Tjark Weber
*)

section \<open>Arithmetic\<close>

theory Arith_Examples
imports Main
begin

text \<open>
  The \<open>arith\<close> method is used frequently throughout the Isabelle
  distribution.  This file merely contains some additional tests and special
  corner cases.  Some rather technical remarks:

  \<^ML>\<open>Lin_Arith.simple_tac\<close> is a very basic version of the tactic.  It performs no
  meta-to-object-logic conversion, and only some splitting of operators.
  \<^ML>\<open>Lin_Arith.tac\<close> performs meta-to-object-logic conversion, full
  splitting of operators, and NNF normalization of the goal.  The \<open>arith\<close>
  method combines them both, and tries other methods (e.g.~\<open>presburger\<close>)
  as well.  This is the one that you should use in your proofs!

  An \<open>arith\<close>-based simproc is available as well (see \<^ML>\<open>Lin_Arith.simproc\<close>), which---for performance
  reasons---however does even less splitting than \<^ML>\<open>Lin_Arith.simple_tac\<close>
  at the moment (namely inequalities only).  (On the other hand, it
  does take apart conjunctions, which \<^ML>\<open>Lin_Arith.simple_tac\<close> currently
  does not do.)
\<close>

subsection \<open>Splitting of Operators: \<^term>\<open>max\<close>, \<^term>\<open>min\<close>, \<^term>\<open>abs\<close>,
           \<^term>\<open>minus\<close>, \<^term>\<open>nat\<close>, \<^term>\<open>modulo\<close>,
           \<^term>\<open>divide\<close>\<close>

lemma "(i::nat) <= max i j"
  by linarith

lemma "(i::int) <= max i j"
  by linarith

lemma "min i j <= (i::nat)"
  by linarith

lemma "min i j <= (i::int)"
  by linarith

lemma "min (i::nat) j <= max i j"
  by linarith

lemma "min (i::int) j <= max i j"
  by linarith

lemma "min (i::nat) j + max i j = i + j"
  by linarith

lemma "min (i::int) j + max i j = i + j"
  by linarith

lemma "(i::nat) < j ==> min i j < max i j"
  by linarith

lemma "(i::int) < j ==> min i j < max i j"
  by linarith

lemma "(0::int) <= \<bar>i\<bar>"
  by linarith

lemma "(i::int) <= \<bar>i\<bar>"
  by linarith

lemma "\<bar>\<bar>i::int\<bar>\<bar> = \<bar>i\<bar>"
  by linarith

text \<open>Also testing subgoals with bound variables.\<close>

lemma "!!x. (x::nat) <= y ==> x - y = 0"
  by linarith

lemma "!!x. (x::nat) - y = 0 ==> x <= y"
  by linarith

lemma "!!x. ((x::nat) <= y) = (x - y = 0)"
  by linarith

lemma "[| (x::nat) < y; d < 1 |] ==> x - y = d"
  by linarith

lemma "[| (x::nat) < y; d < 1 |] ==> x - y - x = d - x"
  by linarith

lemma "(x::int) < y ==> x - y < 0"
  by linarith

lemma "nat (i + j) <= nat i + nat j"
  by linarith

lemma "i < j ==> nat (i - j) = 0"
  by linarith

lemma "(i::nat) mod 0 = i"
  using split_mod [of _ _ 0, linarith_split]
    \<comment> \<open>rule \<^text>\<open>split_mod\<close> is only declared by default for numerals\<close>
  by linarith

lemma "(i::nat) mod 1 = 0"
  (* rule split_mod is only declared by default for numerals *)
  using split_mod [of _ _ 1, linarith_split]
    \<comment> \<open>rule \<^text>\<open>split_mod\<close> is only declared by default for numerals\<close>
  by linarith

lemma "(i::nat) mod 42 <= 41"
  by linarith

lemma "(i::int) mod 0 = i"
  using split_zmod [of _ _ 0, linarith_split]
    \<comment> \<open>rule \<^text>\<open>split_zmod\<close> is only declared by default for numerals\<close>
  by linarith

lemma "(i::int) mod 1 = 0"
  using split_zmod [of _ _ "1", linarith_split]
    \<comment> \<open>rule \<^text>\<open>split_zmod\<close> is only declared by default for numerals\<close>
  by linarith

lemma "(i::int) mod 42 <= 41"
  by linarith

lemma "-(i::int) * 1 = 0 ==> i = 0"
  by linarith

lemma "[| (0::int) < \<bar>i\<bar>; \<bar>i\<bar> * 1 < \<bar>i\<bar> * j |] ==> 1 < \<bar>i\<bar> * j"
  by linarith

subsection \<open>Meta-Logic\<close>

lemma "x < Suc y == x <= y"
  by linarith

lemma "((x::nat) == z ==> x ~= y) ==> x ~= y | z ~= y"
  by linarith

subsection \<open>Various Other Examples\<close>

lemma "(x < Suc y) = (x <= y)"
  by linarith

lemma "[| (x::nat) < y; y < z |] ==> x < z"
  by linarith

lemma "(x::nat) < y & y < z ==> x < z"
  by linarith

text \<open>This example involves no arithmetic at all, but is solved by
  preprocessing (i.e. NNF normalization) alone.\<close>

lemma "(P::bool) = Q ==> Q = P"
  by linarith

lemma "[| P = (x = 0); (~P) = (y = 0) |] ==> min (x::nat) y = 0"
  by linarith

lemma "[| P = (x = 0); (~P) = (y = 0) |] ==> max (x::nat) y = x + y"
  by linarith

lemma "[| (x::nat) ~= y; a + 2 = b; a < y; y < b; a < x; x < b |] ==> False"
  by linarith

lemma "[| (x::nat) > y; y > z; z > x |] ==> False"
  by linarith

lemma "(x::nat) - 5 > y ==> y < x"
  by linarith

lemma "(x::nat) ~= 0 ==> 0 < x"
  by linarith

lemma "[| (x::nat) ~= y; x <= y |] ==> x < y"
  by linarith

lemma "[| (x::nat) < y; P (x - y) |] ==> P 0"
  by linarith

lemma "(x - y) - (x::nat) = (x - x) - y"
  by linarith

lemma "[| (a::nat) < b; c < d |] ==> (a - b) = (c - d)"
  by linarith

lemma "((a::nat) - (b - (c - (d - e)))) = (a - (b - (c - (d - e))))"
  by linarith

lemma "(n < m & m < n') | (n < m & m = n') | (n < n' & n' < m) |
  (n = n' & n' < m) | (n = m & m < n') |
  (n' < m & m < n) | (n' < m & m = n) |
  (n' < n & n < m) | (n' = n & n < m) | (n' = m & m < n) |
  (m < n & n < n') | (m < n & n' = n) | (m < n' & n' < n) |
  (m = n & n < n') | (m = n' & n' < n) |
  (n' = m & m = (n::nat))"
(* FIXME: this should work in principle, but is extremely slow because     *)
(*        preprocessing negates the goal and tries to compute its negation *)
(*        normal form, which creates lots of separate cases for this       *)
(*        disjunction of conjunctions                                      *)
(* by (tactic {* Lin_Arith.tac 1 *}) *)
oops

lemma "2 * (x::nat) ~= 1"
(* FIXME: this is beyond the scope of the decision procedure at the moment, *)
(*        because its negation is satisfiable in the rationals?             *)
(* by (tactic {* Lin_Arith.simple_tac 1 *}) *)
oops

text \<open>Constants.\<close>

lemma "(0::nat) < 1"
  by linarith

lemma "(0::int) < 1"
  by linarith

lemma "(47::nat) + 11 < 8 * 15"
  by linarith

lemma "(47::int) + 11 < 8 * 15"
  by linarith

text \<open>Splitting of inequalities of different type.\<close>

lemma "[| (a::nat) ~= b; (i::int) ~= j; a < 2; b < 2 |] ==>
  a + b <= nat (max \<bar>i\<bar> \<bar>j\<bar>)"
  by linarith

text \<open>Again, but different order.\<close>

lemma "[| (i::int) ~= j; (a::nat) ~= b; a < 2; b < 2 |] ==>
  a + b <= nat (max \<bar>i\<bar> \<bar>j\<bar>)"
  by linarith

end


theory Hahn_Jordan_Prelims imports
  "HOL-Analysis.Analysis"
  Extended_Reals_Sums_Compl
begin

section \<open>Preliminary results\<close>

lemma diff_union:
  shows "A - (\<Union> i \<le> n. B i) - B (Suc n) = A - (\<Union> i \<le> (Suc n). B i)"
  using atMost_Suc by auto

lemma disj_subsets:
  assumes "B 0 = A 0"
    and "\<And>(i::nat). B (Suc i) = A (Suc i) - (\<Union> j\<in>{..i}. A j)"
  shows "(\<Union>i. B i) = (\<Union>i. A i)"
proof
  have "B i \<subseteq> A i" for i
  proof (cases "i = 0")
    case True
    thus ?thesis using assms by simp
  next
    case False
    hence "\<exists>j. i = Suc j" by (simp add: not0_implies_Suc)
    from this obtain j where "i = Suc j" by auto
    thus "B i \<subseteq> A i" using assms by auto
  qed
  thus "\<Union> (range B) \<subseteq> \<Union> (range A)" by auto
next
  have ale: "\<And>n. A (Suc n) \<subseteq> B (Suc n) \<union> (\<Union> j\<in>{0..n}. A j)" using assms by auto
  have inc: "\<And>n. (\<Union> i\<in> {0..n}. A i) \<subseteq> (\<Union> i \<in> {0..n}. B i)"
  proof -
    fix n
    show "(\<Union> i\<in> {0..n}. A i) \<subseteq> (\<Union> i \<in> {0..n}. B i)"
    proof (induct n)
      case 0
      then show ?case using assms by auto
    next
      case (Suc n)
      have "\<Union> (A ` {0..Suc n}) = (\<Union> (A ` {0.. n})) \<union> A (Suc n)"
        by (simp add: Un_commute atLeast0_atMost_Suc)
      also have "... \<subseteq> (\<Union> (B ` {0.. n})) \<union> A (Suc n)" using Suc by auto
      also have "... \<subseteq> (\<Union> (B ` {0.. n})) \<union> B (Suc n) \<union> (\<Union> j\<in>{0..n}. A j)" using ale by auto
      also have "... \<subseteq> (\<Union> (B ` {0.. n})) \<union> B (Suc n) \<union> (\<Union> (B ` {0.. n}))" using Suc by auto
      also have "... = (\<Union> (B ` {0.. n})) \<union> B (Suc n)" by auto
      also have "... = (\<Union> (B ` {0.. Suc n}))" by (simp add: Un_commute atLeast0_atMost_Suc)
      finally show ?case .
    qed
  qed
  have "\<And>n. (\<Union> i\<in> {0..<n}. A i) \<subseteq> (\<Union> i \<in> {0..<n}. B i)"
  proof -
    fix n
    show "(\<Union> i\<in> {0..<n}. A i) \<subseteq> (\<Union> i \<in> {0..<n}. B i)"
    proof (cases "n = 0")
      case True
      hence "{0..<n} = {}" by simp
      thus ?thesis by simp
    next
      case False
      hence "\<exists>m. n = Suc m" by (simp add: not0_implies_Suc)
      from this obtain m where "n = Suc m" by auto
      hence "{0..<n} = {0..m}" by auto
      have "(\<Union> i\<in> {0..m}. A i) \<subseteq> (\<Union> i \<in> {0..m}. B i)" using inc by simp
      thus ?thesis using \<open>{0..<n} = {0..m}\<close> by simp
    qed
  qed
  thus "\<Union> (range A) \<subseteq> \<Union> (range B)" using UN_finite2_subset[of A B 0] by simp
qed

lemma disj_Union2:
  assumes "\<And>i. A i \<in> sets M"
  obtains B where "disjoint_family B" and "(\<Union>(i::nat). B i) = (\<Union>(i::nat). A i)"
    and "\<And>i. B i \<in> sets M" and "\<And>i. B i \<subseteq> A i"
proof
  define B where "B = (\<lambda>(i::nat). A i - (\<Union> j\<in>{..<i}. A j))"
  show "\<And>i. B i \<subseteq> A i"
  proof -
    fix i
    show "B i \<subseteq> A i"
    proof (cases "i = 0")
      case True
      thus ?thesis unfolding B_def by simp
    next
      case False
      hence "\<exists>j. i = Suc j" by (simp add: not0_implies_Suc)
      from this obtain j where "i = Suc j" by auto
      thus "B i \<subseteq> A i" unfolding B_def by auto
    qed
  qed
  show "disjoint_family B" unfolding disjoint_family_on_def
  proof -
    {
      fix n m::nat
      assume "n <m"
      hence "B n \<subseteq> (\<Union> j\<in>{..<m}. A j)" using \<open>\<And>i. B i \<subseteq> A i\<close> by auto
      hence "B n \<inter> B m = {}" unfolding B_def by auto
    }
    thus "\<forall>m\<in>UNIV. \<forall>n\<in>UNIV. m \<noteq> n \<longrightarrow> B m \<inter> B n = {}" by (metis Int_commute antisym_conv3)
  qed
  show "(\<Union>(i::nat). B i) = (\<Union>(i::nat). A i)"
  proof (rule disj_subsets)
    show "B 0 = A 0" unfolding B_def by simp
    show "\<And>i. B (Suc i) = A (Suc i) - \<Union> (A ` {..i})" unfolding B_def by auto
  qed
  show "\<And>i. B i \<in> sets M" unfolding B_def using assms by auto
qed

lemma conv_0_half:
  assumes "f \<longlonglongrightarrow> (0::real)"
    and "\<And>n. 0 \<le> f n"
  shows "\<exists>N. \<forall>n \<ge> N. f n < 1/2"
proof -
  have "\<forall>r>0. \<exists>no. \<forall>n\<ge>no. dist (f n) 0 < r" using assms by (simp add: lim_sequentially)
  hence "\<exists>no. \<forall>n\<ge> no. dist (f n) 0 < 1/2" using half_gt_zero_iff zero_less_one by blast
  from this obtain N where "\<forall>n \<ge> N. dist (f n) 0 < 1/2" by auto
  have "\<And>n. dist (f n) 0 = f n" using assms
  proof -
    fix n
    have "dist (f n) 0 = \<bar>f n\<bar>" by simp
    also have "... = f n" using assms by simp
    finally show "dist (f n) 0 = f n" .
  qed
  hence "\<forall>n \<ge> N. f n < 1/2" using \<open>\<forall>n \<ge> N. dist (f n) 0 < 1/2\<close> by simp
  thus ?thesis by auto
qed

lemma e2ennreal_add:
  fixes x::ereal
  assumes "0 \<le> x"
    and "0 \<le> y"
  shows "e2ennreal (x+y) = e2ennreal x + e2ennreal y"
proof (rule ereal_ennreal_cases[of x])
  show "x < 0 \<Longrightarrow> e2ennreal (x + y) = e2ennreal x + e2ennreal y" using assms by simp
  show "\<And>b. 0 \<le> x \<Longrightarrow> x = enn2ereal b \<Longrightarrow> e2ennreal (x + y) = e2ennreal x + e2ennreal y"
  proof -
    fix b
    assume "0 \<le> x" and "x = enn2ereal b"
    hence "e2ennreal x= b" by simp
    show "e2ennreal (x + y) = e2ennreal x + e2ennreal y"
    proof (rule ereal_ennreal_cases[of y])
      show "y < 0 \<Longrightarrow> e2ennreal (x + y) = e2ennreal x + e2ennreal y" using assms by simp
      show "\<And>b. 0 \<le> y \<Longrightarrow> y = enn2ereal b \<Longrightarrow> e2ennreal (x + y) = e2ennreal x + e2ennreal y"
      proof -
        fix c
        assume "0 \<le> y" and "y = enn2ereal c"
        hence "e2ennreal y = c" by simp
        show "e2ennreal (x + y) = e2ennreal x + e2ennreal y"
        proof (rule ereal_ennreal_cases[of "x+y"])
          show "x + y < 0 \<Longrightarrow> e2ennreal (x + y) = e2ennreal x + e2ennreal y" using assms
            by (simp add: leD)
          show "\<And>b. 0 \<le> x + y \<Longrightarrow> x + y = enn2ereal b \<Longrightarrow> e2ennreal (x + y) =
            e2ennreal x + e2ennreal y"
          proof -
            fix d
            assume "0 \<le> x+y" and "x+y = enn2ereal d"
            hence "e2ennreal (x+y) = d" by simp
            show "e2ennreal (x + y) = e2ennreal x + e2ennreal y"
              using \<open>e2ennreal (x+y) = d\<close> \<open>e2ennreal x= b\<close> \<open>e2ennreal y= c\<close>
              by (metis \<open>x = enn2ereal b\<close> \<open>y = enn2ereal c\<close> e2ennreal_enn2ereal plus_ennreal.rep_eq)
          qed
        qed
      qed
    qed
  qed
qed

lemma e2ennreal_finite_sum:
  shows "finite I \<Longrightarrow> (\<And>i. i\<in> I \<Longrightarrow> 0 \<le> ((A i)::ereal)) \<Longrightarrow>
(\<Sum> i\<in> I. e2ennreal (A i)) = e2ennreal (\<Sum>i\<in> I. A i)"
proof (induct rule: finite_induct)
  case empty
  then show ?case by (simp add: zero_ennreal.abs_eq)
next
  case (insert x F)
  hence "(\<Sum> i\<in> (insert x F). e2ennreal (A i)) = e2ennreal (A x) + (\<Sum> i\<in> F. e2ennreal (A i))"
    by simp
  also have "... = e2ennreal (A x) + e2ennreal (\<Sum>i\<in> F. A i)" using insert by simp
  also have "... = e2ennreal (A x + (\<Sum>i\<in> F. A i))"
  proof (rule e2ennreal_add[symmetric])
    show "0 \<le> A x" using insert by simp
    show "0 \<le> sum A F" using insert by (simp add: sum_nonneg)
  qed
  also have "... = e2ennreal (\<Sum>i\<in> insert x F. A i)" using insert by simp
  finally show ?case .
qed

lemma e2ennreal_less_top:
  fixes x::ereal
  assumes "x < \<infinity>"
  shows "e2ennreal x < \<infinity>"
proof (rule ereal_ennreal_cases[of x])
  assume "x < 0"
  hence "e2ennreal x = 0" using e2ennreal_neg by simp
  thus "e2ennreal x < \<infinity>" by simp
next
  fix b
  assume "0 \<le>  x" and "x = enn2ereal b"
  hence "b = e2ennreal x" by simp
  have "b < \<infinity>"
  proof (rule ccontr)
    assume "\<not> b < \<infinity>"
    hence "b = \<infinity>" by (simp add: less_ennreal.rep_eq)
    hence "x = \<infinity>" using enn2ereal_eq_top_iff \<open>x = enn2ereal b\<close> by simp
    thus False using assms by simp
  qed
  thus "e2ennreal x < \<infinity>" using \<open>b = e2ennreal x\<close> by simp
qed

lemma pos_e2ennreal_additive:
  assumes "measure_space (space M) (sets M) (\<lambda>x. e2ennreal (m1 x))"
    and "\<forall>x\<in> sets M. 0 \<le> m1 x"
  shows "additive (sets M) m1"
proof (auto simp add: additive_def)
  fix A B
  assume "A\<in> sets M" and "B\<in> sets M" and "A\<inter> B = {}" note abprops = this
  define M1 where "M1 = (\<lambda>x. e2ennreal (m1 x))"
  have "additive (sets M) M1" using ring_of_sets.countably_additive_additive
      sets.ring_of_sets_axioms assms unfolding measure_space_def M1_def by auto
  have "A\<union>B \<in> sets M" using abprops by simp
  hence "m1 (A\<union> B) = enn2ereal (M1 (A\<union> B))" unfolding M1_def using assms enn2ereal_e2ennreal
      abprops by presburger
  also have "... = enn2ereal (M1 A + M1 B)" using \<open>additive (sets M) M1\<close> abprops
    unfolding additive_def by simp
  also have "... = enn2ereal (M1 A) + enn2ereal (M1 B)" by (simp add: plus_ennreal.rep_eq)
  also have "... = m1 A + m1 B" unfolding M1_def using assms enn2ereal_e2ennreal
      abprops by presburger
  finally show "m1 (A\<union> B) = m1 A + m1 B" .
qed

subsection \<open>Some summability properties\<close>

lemma shift_denum:
  shows "1/(x i - (1::nat)) \<le> 2/x i"
proof (cases "x i \<le> 1")
  case True
  hence "x i - 1 = 0" by simp
  thus ?thesis by simp
next
  case False
  hence "2 \<le> x i" by simp
  hence "0 < x i * (x i - 1)" by simp
  hence "0 \<le> (2 * (x i - 1) - x i)/(x i * (x i - 1))" using \<open>2 \<le> x i\<close> by simp
  also have "... = (real (2 * (x i - 1)) - real (x i))/(x i * (x i - 1))"
    using of_nat_diff by auto
  also have "... = (2 * (x i - 1))/(x i * (x i - 1)) - x i/(x i * (x i - 1))"
    using diff_divide_distrib[of "2 * (x i - 1)" "x i" "x i * (x i - 1)"] by simp
  also have "... = 2/x i - x i/(x i * (x i - 1))"  using \<open>2 \<le> x i\<close> by auto
  also have "... = 2/x i - 1/(x i - 1)" by simp
  finally have "0 \<le> 2/x i - 1/(x i - 1)" .
  thus ?thesis by simp
qed

lemma shift_denum':
  assumes "\<And>i. k \<le> x i \<Longrightarrow> k +e  \<le> ((x i)::nat)"
    and "\<And>i. 0 < x i"
    and "\<And>i. x i < p"
    and "0 < e"
  shows "\<exists>c. \<forall>i. 1/(x i - k) \<le> c/(x i)"
proof
  have "\<And>i. k \<le> x i \<Longrightarrow> e \<le> x i - k"
  proof -
    fix i
    assume "k \<le> x i"
    hence "k + e \<le> x i" using assms by simp
    thus "e \<le> x i - k" using assms by simp
  qed
  have "\<And>i. k \<le> x i \<Longrightarrow> 0 < (x i)*(x i - k)"
  proof -
    fix i
    assume "k \<le> x i"
    thus "0 < (x i)*(x i - k)" using assms by force
  qed
  define cw where "cw = p/e"
  have "0 < p" using assms  using neq0_conv by blast
  hence "0 < cw" unfolding cw_def by (simp add: assms(4))
  show "\<forall>i. 1 / (x i - k) \<le> cw / x i"
  proof
    fix i
    show "1 / (x i - k) \<le> cw / x i"
    proof (cases "k \<le> x i")
      case True
      hence "0 \<le> (p - x i)/((x i) * (x i - k))" using \<open>\<And>i. k \<le> x i \<Longrightarrow>0 < x i * (x i - k)\<close> assms(3)
          divide_nonneg_pos[of "p - x i" "x i * (x i - k)"] by (simp add: less_eq_real_def)
      also have "... = (cw * e - x i)/((x i) * (x i - k))" unfolding cw_def using assms True
        by (metis divide_less_cancel division_ring_divide_zero eq_divide_imp nat_less_le
            of_nat_0_less_iff of_nat_diff times_divide_eq_left)
      also have "... \<le> (cw * (x i - k) - x i)/((x i) * (x i - k))"
      proof -
        have "cw * (x i - k) - x i \<ge> cw * e - x i" using \<open>k \<le> x i \<Longrightarrow> e \<le> x i - k\<close> \<open>0 < cw\<close> True
          by simp
        thus ?thesis using \<open>k \<le> x i \<Longrightarrow> 0 < (x i)*(x i - k)\<close>
            divide_right_mono[of "cw * e - x i" "cw * (x i - k) - x i" "(x i) * (x i - k)"] by simp
      qed
      also have "... = (cw * (x i -k))/((x i)*(x i - k)) - x i/((x i) * (x i - k))"
        using assms diff_divide_distrib by blast
      also have "... = cw / x i - 1/(x i-k)"
      proof -
        have "1/(x i-k) = x i/((x i) * (x i - k))" using assms(2) less_imp_neq by fastforce
        thus ?thesis using \<open>\<And>i. k \<le> x i \<Longrightarrow> 0 < x i * (x i - k)\<close> assms(2) zero_less_mult_pos
        proof -
          have f1: "\<forall>r ra. (1::real) / (ra / r) = r / ra"
            by simp
          have "real (x i * (x i - k)) \<noteq> 0"
            by (metis True  \<open>\<And>i. k \<le> x i \<Longrightarrow> 0 < x i * (x i - k)\<close> neq0_conv of_nat_0 of_nat_le_0_iff)
          thus ?thesis using f1 by (metis \<open>1 / real (x i - k) = real (x i) / real (x i * (x i - k))\<close>
                div_by_1 divide_divide_eq_right nonzero_mult_div_cancel_left)
        qed
      qed
      finally have "0 \<le> cw / x i - 1/(x i-k)" .
      thus "1 / (x i - k) \<le> cw / x i" by simp
    next
      case False
      hence "real (x i - k) = 0" by simp
      hence "1/ real (x i - k) = 0" by simp
      thus "1 / real (x i - k) \<le> cw / real (x i)" by (simp add: cw_def)
    qed
  qed
qed

lemma sum_le:
  assumes "\<And>i. f i \<le> ((g i) :: real)"
  shows "sum f {.. (n::nat)} \<le> sum g {.. n}"
proof (induct n)
  case 0
  then show ?case using assms by simp
next
  case (Suc n)
  have "sum f {..Suc n} = sum f {.. n} + f (Suc n)" by simp
  also have "... \<le> sum g {.. n} + f (Suc n)" using Suc by simp
  also have "... \<le> sum g {.. n} + g (Suc n)" using assms by simp
  also have "... = sum g {.. Suc n}" by simp
  finally show ?case .
qed

lemma summable_bounded:
  assumes "\<And>i. 0 \<le> ((f i)::real)"
    and "\<And>i. f i \<le> g i"
    and "summable g"
  shows "summable f"
proof (rule bounded_imp_summable, (auto simp add: assms))
  fix n
  have "\<And>i. 0 \<le> g i" using assms dual_order.trans by blast
  have "sum f {.. n} \<le> sum g {.. n}" using assms sum_le by simp
  also have "... \<le> suminf g" by (rule sum_le_suminf, (auto simp add: assms \<open>\<And>i. 0 \<le> g i\<close>))
  finally show "sum f {.. n} \<le> suminf g" .
qed

lemma sum_shift_denum:
  assumes "summable (\<lambda>i. 1/((f i)::nat))"
  shows "summable (\<lambda>i. 1/(f i - 1))"
proof -
  have "\<forall>i. 1/(f i - 1) \<le> 2 / f i" using shift_denum[of f] by auto
  have "summable (\<lambda>i. 2/ f i)" using assms summable_mult[of "\<lambda>n. 1/ f n"] by simp
  thus ?thesis using summable_bounded[of "\<lambda>i. 1/(f i - 1)" "\<lambda>i. 2 * 1/f i"]
      \<open>\<forall>i. 1 / real (f i - 1) \<le> 2 / real (f i)\<close> by auto
qed

lemma sum_shift_denum':
  assumes "summable (\<lambda>i. 1/(f i))"
    and "0 < e"
    and "\<And>i. k \<le> f i \<Longrightarrow> k + e \<le> ((f i)::nat)"
    and "\<And>i. 0 < f i"
    and "\<And>i. f i < p"
  shows "summable (\<lambda>i. 1/(f i - k))"
proof -
  have "\<And>i. 0 \<le> 1/(f i - k)"
  proof -
    fix i
    have "0 \<le> f i - k" using assms by simp
    thus "0 \<le> 1/(f i - k)" by simp
  qed
  have "\<exists>c. \<forall>i. 1/(f i - k) \<le> c / f i" using shift_denum'[of k f e p] assms by simp
  from this obtain c where "\<forall>i. 1/(f i - k) \<le> c / f i" by auto
  have "summable (\<lambda>i. c * 1/ f i)" using assms summable_mult[of "\<lambda>n. 1/ f n"] by simp
  thus ?thesis using summable_bounded[of "\<lambda>i. 1/(f i - k)" "\<lambda>i. c * 1/f i"]
      \<open>\<And>i. 0 \<le> 1/(f i - k)\<close> by (simp add: \<open>\<forall>i. 1 / (f i - k) \<le> c / f i\<close>)
qed

end