(*  Title:      HOL/Algebra/Chinese_Remainder.thy
    Author:     Paulo Emílio de Vilhena
*)

theory Chinese_Remainder
  imports Weak_Morphisms Ideal_Product

begin

section \<open>Direct Product of Rings\<close>

subsection \<open>Definitions\<close>

definition RDirProd :: "('a, 'n) ring_scheme \<Rightarrow> ('b, 'm) ring_scheme \<Rightarrow> ('a \<times> 'b) ring"
  where "RDirProd R S = monoid.extend (R \<times>\<times> S)
           \<lparr> zero = one ((add_monoid R) \<times>\<times> (add_monoid S)),
              add = mult ((add_monoid R) \<times>\<times> (add_monoid S)) \<rparr> "

abbreviation nil_ring :: "('a list) ring"
  where "nil_ring \<equiv> monoid.extend nil_monoid \<lparr> zero = [], add = (\<lambda>a b. []) \<rparr>"

definition RDirProd_list :: "(('a, 'n) ring_scheme) list \<Rightarrow> ('a list) ring"
  where "RDirProd_list Rs = foldr (\<lambda>R S. image_ring (\<lambda>(a, as). a # as) (RDirProd R S)) Rs nil_ring"

subsection \<open>Basic Properties\<close>

lemma RDirProd_carrier: "carrier (RDirProd R S) = carrier R \<times> carrier S"
  unfolding RDirProd_def DirProd_def by (simp add: monoid.defs)

lemma RDirProd_add_monoid [simp]: "add_monoid (RDirProd R S) = (add_monoid R) \<times>\<times> (add_monoid S)"
  by (simp add: RDirProd_def monoid.defs)

lemma RDirProd_ring:
  assumes "ring R" and "ring S" shows "ring (RDirProd R S)"
proof -
  have "monoid (RDirProd R S)"
    using DirProd_monoid[OF assms[THEN ring.axioms(2)]] unfolding monoid_def
    by (auto simp add: DirProd_def RDirProd_def monoid.defs)
  then interpret Prod: group "add_monoid (RDirProd R S)" + monoid "RDirProd R S"
    using DirProd_group[OF assms[THEN abelian_group.a_group[OF ring.is_abelian_group]]]
    unfolding RDirProd_add_monoid by auto
  show ?thesis
    by (unfold_locales, auto simp add: RDirProd_def DirProd_def monoid.defs assms ring.ring_simprules)
qed

lemma RDirProd_iso1:
  "(\<lambda>(x, y). (y, x)) \<in> ring_iso (RDirProd R S) (RDirProd S R)"
  unfolding ring_iso_def ring_hom_def bij_betw_def inj_on_def
  by (auto simp add: RDirProd_def DirProd_def monoid.defs)

lemma RDirProd_iso2:
  "(\<lambda>(x, (y, z)). ((x, y), z)) \<in> ring_iso (RDirProd R (RDirProd S T)) (RDirProd (RDirProd R S) T)"
  unfolding ring_iso_def ring_hom_def bij_betw_def inj_on_def
  by (auto simp add: image_iff RDirProd_def DirProd_def monoid.defs)

lemma RDirProd_iso3:
  "(\<lambda>((x, y), z). (x, (y, z))) \<in> ring_iso (RDirProd (RDirProd R S) T) (RDirProd R (RDirProd S T))"
  unfolding ring_iso_def ring_hom_def bij_betw_def inj_on_def
  by (auto simp add: image_iff RDirProd_def DirProd_def monoid.defs)

lemma RDirProd_iso4:
  assumes "f \<in> ring_iso R S" shows "(\<lambda>(r, t). (f r, t)) \<in> ring_iso (RDirProd R T) (RDirProd S T)"
  using assms unfolding ring_iso_def ring_hom_def bij_betw_def inj_on_def
  by (auto simp add: image_iff RDirProd_def DirProd_def monoid.defs)+

lemma RDirProd_iso5:
  assumes "f \<in> ring_iso S T" shows "(\<lambda>(r, s). (r, f s)) \<in> ring_iso (RDirProd R S) (RDirProd R T)"
  using ring_iso_set_trans[OF ring_iso_set_trans[OF RDirProd_iso1 RDirProd_iso4[OF assms]] RDirProd_iso1]
  by (simp add: case_prod_unfold comp_def)

lemma RDirProd_iso6:
  assumes "f \<in> ring_iso R R'" and "g \<in> ring_iso S S'"
  shows "(\<lambda>(r, s). (f r, g s)) \<in> ring_iso (RDirProd R S) (RDirProd R' S')"
  using ring_iso_set_trans[OF RDirProd_iso4[OF assms(1)] RDirProd_iso5[OF assms(2)]]
  by (simp add: case_prod_beta' comp_def)

lemma RDirProd_iso7:
  shows "(\<lambda>a. (a, [])) \<in> ring_iso R (RDirProd R nil_ring)"
  unfolding ring_iso_def ring_hom_def bij_betw_def inj_on_def
  by (auto simp add: RDirProd_def DirProd_def monoid.defs)

lemma RDirProd_hom1:
  shows "(\<lambda>a. (a, a)) \<in> ring_hom R (RDirProd R R)"
  by (auto simp add: ring_hom_def RDirProd_def DirProd_def monoid.defs)

lemma RDirProd_hom2:
  assumes "f \<in> ring_hom S T"
  shows "(\<lambda>(x, y). (x, f y)) \<in> ring_hom (RDirProd R S) (RDirProd R T)"
    and "(\<lambda>(x, y). (f x, y)) \<in> ring_hom (RDirProd S R) (RDirProd T R)"
  using assms by (auto simp add: ring_hom_def RDirProd_def DirProd_def monoid.defs)

lemma RDirProd_hom3:
  assumes "f \<in> ring_hom R R'" and "g \<in> ring_hom S S'"
  shows "(\<lambda>(r, s). (f r, g s)) \<in> ring_hom (RDirProd R S) (RDirProd R' S')"
  using ring_hom_trans[OF RDirProd_hom2(2)[OF assms(1)] RDirProd_hom2(1)[OF assms(2)]]
  by (simp add: case_prod_beta' comp_def)

subsection \<open>Direct Product of a List of Rings\<close>

lemma RDirProd_list_nil [simp]: "RDirProd_list [] = nil_ring"
  unfolding RDirProd_list_def by simp

lemma nil_ring_simprules [simp]:
  "carrier nil_ring = { [] }" and "one nil_ring = []" and "zero nil_ring = []"
  by (auto simp add: monoid.defs)

lemma RDirProd_list_truncate:
  shows "monoid.truncate (RDirProd_list Rs) = DirProd_list Rs"
proof (induct Rs, simp add: RDirProd_list_def DirProd_list_def monoid.defs)
  case (Cons R Rs)
  have "monoid.truncate (RDirProd_list (R # Rs)) =
        monoid.truncate (image_ring (\<lambda>(a, as). a # as) (RDirProd R (RDirProd_list Rs)))"
    unfolding RDirProd_list_def by simp
  also have " ... = image_group (\<lambda>(a, as). a # as) (monoid.truncate (RDirProd R (RDirProd_list Rs)))"
  by (simp add: image_ring_def image_group_def monoid.defs)
  also have " ... = image_group (\<lambda>(a, as). a # as) (R \<times>\<times> (monoid.truncate (RDirProd_list Rs)))"
    by (simp add: RDirProd_def DirProd_def monoid.defs)
  also have " ... = DirProd_list (R # Rs)"
    unfolding Cons DirProd_list_def by simp
  finally show ?case .
qed

lemma RDirProd_list_carrier_def':
  shows "carrier (RDirProd_list Rs) = carrier (DirProd_list Rs)"
proof -
  have "carrier (RDirProd_list Rs) = carrier (monoid.truncate (RDirProd_list Rs))"
    by (simp add: monoid.defs)
  thus ?thesis
    unfolding RDirProd_list_truncate .
qed

lemma RDirProd_list_carrier:
  shows "carrier (RDirProd_list (G # Gs)) = (\<lambda>(x, xs). x # xs) ` (carrier G \<times> carrier (RDirProd_list Gs))"
  unfolding RDirProd_list_carrier_def' using DirProd_list_carrier .

lemma RDirProd_list_one:
  shows "one (RDirProd_list Rs) = foldr (\<lambda>R tl. (one R) # tl) Rs []"
  unfolding RDirProd_list_def RDirProd_def image_ring_def image_group_def
  by (induct Rs) (auto simp add: monoid.defs)

lemma RDirProd_list_zero:
  shows "zero (RDirProd_list Rs) = foldr (\<lambda>R tl. (zero R) # tl) Rs []"
  unfolding RDirProd_list_def RDirProd_def image_ring_def
  by (induct Rs) (auto simp add: monoid.defs)

lemma RDirProd_list_zero':
  shows "zero (RDirProd_list (R # Rs)) = (zero R) # (zero (RDirProd_list Rs))"
  unfolding RDirProd_list_zero by simp

lemma RDirProd_list_carrier_mem:
  assumes "as \<in> carrier (RDirProd_list Rs)"
  shows "length as = length Rs" and "\<And>i. i < length Rs \<Longrightarrow> (as ! i) \<in> carrier (Rs ! i)"
  using assms DirProd_list_carrier_mem unfolding RDirProd_list_carrier_def' by auto

lemma RDirProd_list_carrier_memI:
  assumes "length as = length Rs" and "\<And>i. i < length Rs \<Longrightarrow> (as ! i) \<in> carrier (Rs ! i)"
  shows "as \<in> carrier (RDirProd_list Rs)"
  using assms DirProd_list_carrier_memI unfolding RDirProd_list_carrier_def' by auto

lemma inj_on_RDirProd_carrier:
  shows "inj_on (\<lambda>(a, as). a # as) (carrier (RDirProd R (RDirProd_list Rs)))"
  unfolding RDirProd_def DirProd_def inj_on_def by auto

lemma RDirProd_list_is_ring:
  assumes "\<And>i. i < length Rs \<Longrightarrow> ring (Rs ! i)" shows "ring (RDirProd_list Rs)"
  using assms
proof (induct Rs)
  case Nil thus ?case
    unfolding RDirProd_list_def by (unfold_locales, auto simp add: monoid.defs Units_def)
next
  case (Cons R Rs)
  hence is_ring: "ring (RDirProd R (RDirProd_list Rs))"
    using RDirProd_ring[of R "RDirProd_list Rs"] by force
  show ?case
    using ring.inj_imp_image_ring_is_ring[OF is_ring inj_on_RDirProd_carrier]
    unfolding RDirProd_list_def by auto
qed

lemma RDirProd_list_iso1:
  "(\<lambda>(a, as). a # as) \<in> ring_iso (RDirProd R (RDirProd_list Rs)) (RDirProd_list (R # Rs))"
  using inj_imp_image_ring_iso[OF inj_on_RDirProd_carrier] unfolding RDirProd_list_def by auto

lemma RDirProd_list_iso2:
  "Hilbert_Choice.inv (\<lambda>(a, as). a # as) \<in> ring_iso (RDirProd_list (R # Rs)) (RDirProd R (RDirProd_list Rs))"
  unfolding RDirProd_list_def by (auto intro: inj_imp_image_ring_inv_iso simp add: inj_def)

lemma RDirProd_list_iso3:
  "(\<lambda>a. [ a ]) \<in> ring_iso R (RDirProd_list [ R ])"
proof -
  have [simp]: "(\<lambda>a. [ a ]) = (\<lambda>(a, as). a # as) \<circ> (\<lambda>a. (a, []))" by auto
  show ?thesis
    using ring_iso_set_trans[OF RDirProd_iso7] RDirProd_list_iso1[of R "[]"]
    unfolding RDirProd_list_def by simp
qed

lemma RDirProd_list_hom1:
  "(\<lambda>(a, as). a # as) \<in> ring_hom (RDirProd R (RDirProd_list Rs)) (RDirProd_list (R # Rs))"
  using RDirProd_list_iso1 unfolding ring_iso_def by auto

lemma RDirProd_list_hom2:
  assumes "f \<in> ring_hom R S" shows "(\<lambda>a. [ f a ]) \<in> ring_hom R (RDirProd_list [ S ])"
proof -
  have hom1: "(\<lambda>a. (a, [])) \<in> ring_hom R (RDirProd R nil_ring)"
    using RDirProd_iso7 unfolding ring_iso_def by auto
  have hom2: "(\<lambda>(a, as). a # as) \<in> ring_hom (RDirProd S nil_ring) (RDirProd_list [ S ])"
    using RDirProd_list_hom1[of _ "[]"] unfolding RDirProd_list_def by auto
  have [simp]: "(\<lambda>(a, as). a # as) \<circ> ((\<lambda>(x, y). (f x, y)) \<circ> (\<lambda>a. (a, []))) = (\<lambda>a. [ f a ])" by auto
  show ?thesis
    using ring_hom_trans[OF ring_hom_trans[OF hom1 RDirProd_hom2(2)[OF assms]] hom2] by simp
qed

section \<open>Chinese Remainder Theorem\<close>

subsection \<open>Definitions\<close>

abbreviation (in ring) canonical_proj :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a \<Rightarrow> 'a set \<times> 'a set"
  where "canonical_proj I J \<equiv> (\<lambda>a. (I +> a, J +> a))"

definition (in ring) canonical_proj_ext :: "(nat \<Rightarrow> 'a set) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> ('a set) list"
  where "canonical_proj_ext I n = (\<lambda>a. map (\<lambda>i. (I i) +> a) [0..< Suc n])"

subsection \<open>Chinese Remainder Simple\<close>

lemma (in ring) canonical_proj_is_surj:
  assumes "ideal I R" "ideal J R" and "I <+> J = carrier R"
  shows "(canonical_proj I J) ` carrier R = carrier (RDirProd (R Quot I) (R Quot J))"
  unfolding RDirProd_def DirProd_def FactRing_def A_RCOSETS_def'
proof (auto simp add: monoid.defs)
  { fix I i assume "ideal I R" "i \<in> I" hence "I +> i = \<zero>\<^bsub>R Quot I\<^esub>"
      using a_rcos_zero by (simp add: FactRing_def)
  } note aux_lemma1 = this

  { fix I i j assume A: "ideal I R" "i \<in> I" "j \<in> carrier R" "i \<oplus> j = \<one>"
    have "(I +> i) \<oplus>\<^bsub>R Quot I\<^esub> (I +> j) = I +> \<one>"
      using ring_hom_memE(3)[OF ideal.rcos_ring_hom ideal.Icarr[OF _ A(2)] A(3)] A(1,4) by simp
    moreover have "I +> i = I"
      using abelian_subgroupI3[OF ideal.axioms(1) is_abelian_group]
      by (simp add: A(1-2) abelian_subgroup.a_rcos_const)
    moreover have "I +> j \<in> carrier (R Quot I)" and "I = \<zero>\<^bsub>R Quot I\<^esub>" and "I +> \<one> = \<one>\<^bsub>R Quot I\<^esub>"
      by (auto simp add: FactRing_def A_RCOSETS_def' A(3))
    ultimately have "I +> j = \<one>\<^bsub>R Quot I\<^esub>"
      using ring.ring_simprules(8)[OF ideal.quotient_is_ring[OF A(1)]] by simp
  } note aux_lemma2 = this

  interpret I: ring "R Quot I" + J: ring "R Quot J"
    using assms(1-2)[THEN ideal.quotient_is_ring] by auto

  fix a b assume a: "a \<in> carrier R" and b: "b \<in> carrier R"
  have "\<one> \<in> I <+> J"
    using assms(3) by blast
  then obtain i j where i: "i \<in> carrier R" "i \<in> I" and j: "j \<in> carrier R" "j \<in> J" and ij: "i \<oplus> j = \<one>"
    using assms(1-2)[THEN ideal.Icarr] unfolding set_add_def' by auto
  hence rcos_j: "I +> j = \<one>\<^bsub>R Quot I\<^esub>" and rcos_i: "J +> i = \<one>\<^bsub>R Quot J\<^esub>"
    using assms(1-2)[THEN aux_lemma2] a_comm by simp+

  define s where "s = (a \<otimes> j) \<oplus> (b \<otimes> i)"
  hence "s \<in> carrier R"
    using a b i j by simp

  have "I +> s = ((I +> a) \<otimes>\<^bsub>R Quot I\<^esub> (I +> j)) \<oplus>\<^bsub>R Quot I\<^esub> (I +> (b \<otimes> i))"
    using ring_hom_memE(2-3)[OF ideal.rcos_ring_hom[OF assms(1)]]
    by (simp add: a b i(1) j(1) s_def)
  moreover have "I +> a \<in> carrier (R Quot I)"
    by (auto simp add: FactRing_def A_RCOSETS_def' a)
  ultimately have "I +> s = I +> a"
    unfolding rcos_j aux_lemma1[OF assms(1) ideal.I_l_closed[OF assms(1) i(2) b]] by simp

  have "J +> s = (J +> (a \<otimes> j)) \<oplus>\<^bsub>R Quot J\<^esub> ((J +> b) \<otimes>\<^bsub>R Quot J\<^esub> (J +> i))"
    using ring_hom_memE(2-3)[OF ideal.rcos_ring_hom[OF assms(2)]]
    by (simp add: a b i(1) j(1) s_def)
  moreover have "J +> b \<in> carrier (R Quot J)"
    by (auto simp add: FactRing_def A_RCOSETS_def' b)
  ultimately have "J +> s = J +> b"
    unfolding rcos_i aux_lemma1[OF assms(2) ideal.I_l_closed[OF assms(2) j(2) a]] by simp

  from \<open>I +> s = I +> a\<close> and \<open>J +> s = J +> b\<close> and \<open>s \<in> carrier R\<close>
  show "(I +> a, J +> b) \<in> (canonical_proj I J) ` carrier R" by blast
qed

lemma (in ring) canonical_proj_ker:
  assumes "ideal I R" and "ideal J R"
  shows "a_kernel R (RDirProd (R Quot I) (R Quot J)) (canonical_proj I J) = I \<inter> J"
proof
  show "a_kernel R (RDirProd (R Quot I) (R Quot J)) (canonical_proj I J) \<subseteq> I \<inter> J"
    unfolding FactRing_def RDirProd_def DirProd_def a_kernel_def'
    by (auto simp add: assms[THEN ideal.rcos_const_imp_mem] monoid.defs)
next
  show "I \<inter> J \<subseteq> a_kernel R (RDirProd (R Quot I) (R Quot J)) (canonical_proj I J)"
  proof
    fix s assume s: "s \<in> I \<inter> J" then have "I +> s = I" and "J +> s = J"
      using abelian_subgroupI3[OF ideal.axioms(1) is_abelian_group]
      by (simp add: abelian_subgroup.a_rcos_const assms)+
    thus "s \<in> a_kernel R (RDirProd (R Quot I) (R Quot J)) (canonical_proj I J)"
      unfolding FactRing_def RDirProd_def DirProd_def a_kernel_def'
      using ideal.Icarr[OF assms(1)] s by (simp add: monoid.defs)
  qed
qed

lemma (in ring) canonical_proj_is_hom:
  assumes "ideal I R" and "ideal J R"
  shows "(canonical_proj I J) \<in> ring_hom R (RDirProd (R Quot I) (R Quot J))"
  unfolding RDirProd_def DirProd_def FactRing_def A_RCOSETS_def'
  by (auto intro!: ring_hom_memI
         simp add: assms[THEN ideal.rcoset_mult_add]
                   assms[THEN ideal.a_rcos_sum] monoid.defs)

lemma (in ring) canonical_proj_ring_hom:
  assumes "ideal I R" and "ideal J R"
  shows "ring_hom_ring R (RDirProd (R Quot I) (R Quot J)) (canonical_proj I J)"
  using ring_hom_ring.intro[OF ring_axioms RDirProd_ring[OF assms[THEN ideal.quotient_is_ring]]]
  by (simp add: ring_hom_ring_axioms_def canonical_proj_is_hom[OF assms])

theorem (in ring) chinese_remainder_simple:
  assumes "ideal I R" "ideal J R" and "I <+> J = carrier R"
  shows "R Quot (I \<inter> J) \<simeq> RDirProd (R Quot I) (R Quot J)"
  using ring_hom_ring.FactRing_iso[OF canonical_proj_ring_hom canonical_proj_is_surj]
  by (simp add: canonical_proj_ker assms)

subsection \<open>Chinese Remainder Generalized\<close>

lemma (in ring) canonical_proj_ext_zero [simp]: "(canonical_proj_ext I 0) = (\<lambda>a. [ (I 0) +> a ])"
  unfolding canonical_proj_ext_def by simp

lemma (in ring) canonical_proj_ext_tl:
  "(\<lambda>a. canonical_proj_ext I (Suc n) a) = (\<lambda>a. ((I 0) +> a) # (canonical_proj_ext (\<lambda>i. I (Suc i)) n a))"
  unfolding canonical_proj_ext_def by (induct n) (auto, metis (lifting) append.assoc append_Cons append_Nil)

lemma (in ring) canonical_proj_ext_is_hom:
  assumes "\<And>i. i \<le> n \<Longrightarrow> ideal (I i) R"
  shows "(canonical_proj_ext I n) \<in> ring_hom R (RDirProd_list (map (\<lambda>i. R Quot (I i)) [0..< Suc n]))"
  using assms
proof (induct n arbitrary: I)
  case 0 thus ?case
    using RDirProd_list_hom2[OF ideal.rcos_ring_hom[of _ R]] by (simp add: canonical_proj_ext_def)
next
  let ?DirProd = "\<lambda>I n. RDirProd_list (map (\<lambda>i. R Quot (I i)) [0..<Suc n])"
  let ?proj = "\<lambda>I n. canonical_proj_ext I n"

  case (Suc n)
  hence I: "ideal (I 0) R" by simp
  have hom: "(?proj (\<lambda>i. I (Suc i)) n) \<in> ring_hom R (?DirProd (\<lambda>i. I (Suc i)) n)"
    using Suc(1)[of "\<lambda>i. I (Suc i)"] Suc(2) by simp
  have [simp]:
    "(\<lambda>(a, as). a # as) \<circ> ((\<lambda>(r, s). (I 0 +> r, ?proj (\<lambda>i. I (Suc i)) n s)) \<circ> (\<lambda>a. (a, a))) = ?proj I (Suc n)"
    unfolding canonical_proj_ext_tl by auto
  moreover have
    "(R Quot I 0) # (map (\<lambda>i. R Quot I (Suc i)) [0..< Suc n]) = map (\<lambda>i. R Quot (I i)) [0..< Suc (Suc n)]"
    by (induct n) (auto)
  moreover show ?case
    using ring_hom_trans[OF ring_hom_trans[OF RDirProd_hom1
          RDirProd_hom3[OF ideal.rcos_ring_hom[OF I] hom]] RDirProd_list_hom1]
    unfolding calculation(2) by simp
qed

lemma (in ring) RDirProd_Quot_list_is_ring:
  assumes "\<And>i. i \<le> n \<Longrightarrow> ideal (I i) R" shows "ring (RDirProd_list (map (\<lambda>i. R Quot (I i)) [0..< Suc n]))"
proof -
  have ring_list: "\<And>i. i < Suc n \<Longrightarrow> ring ((map (\<lambda>i. R Quot I i) [0..< Suc n]) ! i)"
    using ideal.quotient_is_ring[OF assms]
    by (metis add.left_neutral diff_zero le_simps(2) nth_map_upt)
  show ?thesis
    using RDirProd_list_is_ring[OF ring_list] by simp
qed

lemma (in ring) canonical_proj_ext_ring_hom:
  assumes "\<And>i. i \<le> n \<Longrightarrow> ideal (I i) R"
  shows "ring_hom_ring R (RDirProd_list (map (\<lambda>i. R Quot (I i)) [0..< Suc n])) (canonical_proj_ext I n)"
proof -
  have ring: "ring (RDirProd_list (map (\<lambda>i. R Quot (I i)) [0..< Suc n]))"
    using RDirProd_Quot_list_is_ring[OF assms] by simp
  show ?thesis
    using canonical_proj_ext_is_hom assms ring_hom_ring.intro[OF ring_axioms ring]
    unfolding ring_hom_ring_axioms_def by blast
qed

lemma (in ring) canonical_proj_ext_ker:
  assumes "\<And>i. i \<le> (n :: nat) \<Longrightarrow> ideal (I i) R"
  shows "a_kernel R (RDirProd_list (map (\<lambda>i. R Quot (I i)) [0..< Suc n])) (canonical_proj_ext I n) = (\<Inter>i \<le> n. I i)"
proof -
  let ?map_Quot = "\<lambda>I n. map (\<lambda>i. R Quot (I i)) [0..< Suc n]"
  let ?ker = "\<lambda>I n. a_kernel R (RDirProd_list (?map_Quot I n)) (canonical_proj_ext I n)"

  from assms show ?thesis
  proof (induct n arbitrary: I)
    case 0 then have I: "ideal (I 0) R" by simp
    show ?case
      unfolding a_kernel_def' RDirProd_list_zero canonical_proj_ext_def FactRing_def
      using ideal.rcos_const_imp_mem a_rcos_zero ideal.Icarr I by auto
  next
    case (Suc n)
    hence I: "ideal (I 0) R" by simp
    have map_simp: "?map_Quot I (Suc n) = (R Quot I 0) # (?map_Quot (\<lambda>i. I (Suc i)) n)"
      by (induct n) (auto)
    have ker_I0: "I 0 = a_kernel R (R Quot (I 0)) (\<lambda>a. (I 0) +> a)"
      using ideal.rcos_const_imp_mem[OF I] a_rcos_zero[OF I] ideal.Icarr[OF I]
      unfolding a_kernel_def' FactRing_def by auto
    hence "?ker I (Suc n) = (?ker (\<lambda>i. I (Suc i)) n) \<inter> (I 0)"
      unfolding a_kernel_def' map_simp RDirProd_list_zero' canonical_proj_ext_tl by auto
    moreover have "?ker (\<lambda>i. I (Suc i)) n = (\<Inter>i \<le> n. I (Suc i))"
      using Suc(1)[of "\<lambda>i. I (Suc i)"] Suc(2) by auto
    ultimately show ?case
      by (auto simp add: INT_extend_simps(10) atMost_atLeast0)
         (metis atLeastAtMost_iff le_zero_eq not_less_eq_eq)
  qed
qed

lemma (in cring) canonical_proj_ext_is_surj:
  assumes "\<And>i. i \<le> n \<Longrightarrow> ideal (I i) R" and "\<And>i j. \<lbrakk> i \<le> n; j \<le> n \<rbrakk> \<Longrightarrow> i \<noteq> j \<Longrightarrow> I i <+> I j = carrier R"
  shows "(canonical_proj_ext I n) ` carrier R = carrier (RDirProd_list (map (\<lambda>i. R Quot (I i)) [0..< Suc n]))"
  using assms
proof (induct n arbitrary: I)
  case 0 show ?case
    by (auto simp add: RDirProd_list_carrier FactRing_def A_RCOSETS_def')
next
  { fix S :: "'c ring" and T :: "'d ring" and f g
    assume A: "ring T" "f \<in> ring_hom R S" "g \<in> ring_hom R T" "f ` carrier R \<subseteq> f ` (a_kernel R T g)"
    have "(\<lambda>a. (f a, g a)) ` carrier R = (f ` carrier R) \<times> (g ` carrier R)"
    proof
      show "(\<lambda>a. (f a, g a)) ` carrier R \<subseteq> (f ` carrier R) \<times> (g ` carrier R)"
        by blast
    next
      show "(f ` carrier R) \<times> (g ` carrier R) \<subseteq> (\<lambda>a. (f a, g a)) ` carrier R"
      proof
        fix t assume "t \<in> (f ` carrier R) \<times> (g ` carrier R)"
        then obtain a b where a: "a \<in> carrier R" "f a = fst t" and b: "b \<in> carrier R" "g b = snd t"
          by auto
        obtain c where c: "c \<in> a_kernel R T g" "f c = f (a \<ominus> b)"
          using A(4) minus_closed[OF a(1) b (1)] by auto
        have "f (c \<oplus> b) = f (a \<ominus> b) \<oplus>\<^bsub>S\<^esub>  f b"
          using ring_hom_memE(3)[OF A(2)] b c unfolding a_kernel_def' by auto
        hence "f (c \<oplus> b) = f a"
          using ring_hom_memE(3)[OF A(2) minus_closed[of a b], of b] a b by algebra
        moreover have "g (c \<oplus> b) = g b"
          using ring_hom_memE(1,3)[OF A(3)] b(1) c ring.ring_simprules(8)[OF A(1)]
          unfolding a_kernel_def' by auto
        ultimately have "(\<lambda>a. (f a, g a)) (c \<oplus> b) = t" and "c \<oplus> b \<in> carrier R"
          using a b c unfolding a_kernel_def' by auto
        thus "t \<in> (\<lambda>a. (f a, g a)) ` carrier R"
          by blast
      qed
    qed } note aux_lemma = this

  let ?map_Quot = "\<lambda>I n. map (\<lambda>i. R Quot (I i)) [0..< Suc n]"
  let ?DirProd = "\<lambda>I n. RDirProd_list (?map_Quot I n)"
  let ?proj = "\<lambda>I n. canonical_proj_ext I n"

  case (Suc n)
  interpret I: ideal "I 0" R + Inter: ideal "\<Inter>i \<le> n. I (Suc i)" R
    using i_Intersect[of "(\<lambda>i. I (Suc i)) ` {..n}"] Suc(2) by auto

  have map_simp: "?map_Quot I (Suc n) = (R Quot I 0) # (?map_Quot (\<lambda>i. I (Suc i)) n)"
    by (induct n) (auto)

  have IH: "(?proj (\<lambda>i. I (Suc i)) n) ` carrier R = carrier (?DirProd (\<lambda>i. I (Suc i)) n)"
   and ring: "ring (?DirProd (\<lambda>i. I (Suc i)) n)"
   and hom: "?proj (\<lambda>i. I (Suc i)) n \<in> ring_hom R (?DirProd (\<lambda>i. I (Suc i)) n)"
    using RDirProd_Quot_list_is_ring[of n "\<lambda>i. I (Suc i)"] Suc(1)[of "\<lambda>i. I (Suc i)"]
           canonical_proj_ext_is_hom[of n "\<lambda>i. I (Suc i)"] Suc(2-3) by auto

  have ker: "a_kernel R (?DirProd (\<lambda>i. I (Suc i)) n) (?proj (\<lambda>i. I (Suc i)) n) = (\<Inter>i \<le> n. I (Suc i))"
    using canonical_proj_ext_ker[of n "\<lambda>i. I (Suc i)"] Suc(2) by auto
  have carrier_Quot: "carrier (R Quot (I 0)) = (\<lambda>a. (I 0) +> a) ` carrier R"
    by (auto simp add: RDirProd_list_carrier FactRing_def A_RCOSETS_def')
  have ring: "ring (?DirProd (\<lambda>i. I (Suc i)) n)"
   and hom: "?proj (\<lambda>i. I (Suc i)) n \<in> ring_hom R (?DirProd (\<lambda>i. I (Suc i)) n)"
    using RDirProd_Quot_list_is_ring[of n "\<lambda>i. I (Suc i)"]
          canonical_proj_ext_is_hom[of n "\<lambda>i. I (Suc i)"] Suc(2) by auto
  have "carrier (R Quot (I 0)) \<subseteq> (\<lambda>a. (I 0) +> a) ` (\<Inter>i \<le> n. I (Suc i))"
  proof
    have "(\<Inter>i \<in> {Suc 0.. Suc n}. I i) <+> (I 0) = carrier R"
      using inter_plus_ideal_eq_carrier_arbitrary[of n I 0]
      by (simp add: Suc(2-3) atLeast1_atMost_eq_remove0)
    hence eq_carrier: "(I 0) <+> (\<Inter>i \<le> n. I (Suc i)) = carrier R"
      using set_add_comm[OF I.a_subset Inter.a_subset]
      by (metis INT_extend_simps(10) atMost_atLeast0 image_Suc_atLeastAtMost)

    fix b assume "b \<in> carrier (R Quot (I 0))"
    hence "(b, (\<Inter>i \<le> n. I (Suc i))) \<in> carrier (R Quot I 0) \<times> carrier (R Quot (\<Inter>i\<le>n. I (Suc i)))"
      using ring.ring_simprules(2)[OF Inter.quotient_is_ring] by (simp add: FactRing_def)
    then obtain s
      where "s \<in> carrier R" "(canonical_proj (I 0) (\<Inter>i \<le> n. I (Suc i))) s = (b, (\<Inter>i \<le> n. I (Suc i)))"
      using canonical_proj_is_surj[OF I.is_ideal Inter.is_ideal eq_carrier]
      unfolding RDirProd_carrier by (metis (no_types, lifting) imageE)
    hence "s \<in> (\<Inter>i \<le> n. I (Suc i))" and "(\<lambda>a. (I 0) +> a) s = b"
      using Inter.rcos_const_imp_mem by auto
    thus "b \<in> (\<lambda>a. (I 0) +> a) ` (\<Inter>i \<le> n. I (Suc i))"
      by auto
  qed
  hence "(\<lambda>a. ((I 0) +> a, ?proj (\<lambda>i. I (Suc i)) n a)) ` carrier R =
         carrier (R Quot (I 0)) \<times> carrier (?DirProd (\<lambda>i. I (Suc i)) n)"
    using aux_lemma[OF ring I.rcos_ring_hom hom] unfolding carrier_Quot ker IH by simp
  moreover show ?case
    unfolding map_simp RDirProd_list_carrier sym[OF calculation(1)] canonical_proj_ext_tl by auto
qed

theorem (in cring) chinese_remainder:
  assumes "\<And>i. i \<le> n \<Longrightarrow> ideal (I i) R" and "\<And>i j. \<lbrakk> i \<le> n; j \<le> n \<rbrakk> \<Longrightarrow> i \<noteq> j \<Longrightarrow> I i <+> I j = carrier R"
  shows "R Quot (\<Inter>i \<le> n. I i) \<simeq> RDirProd_list (map (\<lambda>i. R Quot (I i)) [0..< Suc n])"
  using ring_hom_ring.FactRing_iso[OF canonical_proj_ext_ring_hom, of n I]
        canonical_proj_ext_is_surj[of n I] canonical_proj_ext_ker[of n I] assms
  by auto

end


section \<open>\isaheader{List Based Sets}\<close>
theory Impl_List_Set
imports
  "../../Iterator/Iterator"
  "../Intf/Intf_Set"
begin
  (* TODO: Move *)
  lemma list_all2_refl_conv:
    "list_all2 P xs xs \<longleftrightarrow> (\<forall>x\<in>set xs. P x x)"
    by (induct xs) auto

  primrec glist_member :: "('a\<Rightarrow>'a\<Rightarrow>bool) \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> bool" where
    "glist_member eq x [] \<longleftrightarrow> False"
  | "glist_member eq x (y#ys) \<longleftrightarrow> eq x y \<or> glist_member eq x ys"

  lemma param_glist_member[param]:
    "(glist_member,glist_member)\<in>(Ra\<rightarrow>Ra\<rightarrow>Id) \<rightarrow> Ra \<rightarrow> \<langle>Ra\<rangle>list_rel \<rightarrow> Id"
    unfolding glist_member_def
    by (parametricity)

  lemma list_member_alt: "List.member = (\<lambda>l x. glist_member (=) x l)"
  proof (intro ext)
    fix x l
    show "List.member l x = glist_member (=) x l"
      by (induct l) (auto simp: List.member_rec)
  qed

  thm List.insert_def
  definition
    "glist_insert eq x xs = (if glist_member eq x xs then xs else x#xs)"

  lemma param_glist_insert[param]:
    "(glist_insert, glist_insert) \<in> (R\<rightarrow>R\<rightarrow>Id) \<rightarrow> R \<rightarrow> \<langle>R\<rangle>list_rel \<rightarrow> \<langle>R\<rangle>list_rel"
    unfolding glist_insert_def[abs_def]
    by (parametricity)

  primrec rev_append where
    "rev_append [] ac = ac"
  | "rev_append (x#xs) ac = rev_append xs (x#ac)"

  lemma rev_append_eq: "rev_append l ac = rev l @ ac"
    by (induct l arbitrary: ac) auto

  (*
  primrec glist_delete_aux1 :: "('a\<Rightarrow>'a\<Rightarrow>bool) \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
    "glist_delete_aux1 eq x [] = []"
  | "glist_delete_aux1 eq x (y#ys) = (
      if eq x y then
        ys
      else y#glist_delete_aux1 eq x ys)"

  primrec glist_delete_aux2 :: "('a\<Rightarrow>'a\<Rightarrow>_) \<Rightarrow> _" where
    "glist_delete_aux2 eq ac x [] = ac"
  | "glist_delete_aux2 eq ac x (y#ys) = (if eq x y then rev_append ys ac else
      glist_delete_aux2 eq (y#ac) x ys
    )"

  lemma glist_delete_aux2_eq1:
    "glist_delete_aux2 eq ac x l = rev (glist_delete_aux1 eq x l) @ ac"
    by (induct l arbitrary: ac) (auto simp: rev_append_eq)

  definition "glist_delete eq x l = glist_delete_aux2 eq [] x l"
  *)

  primrec glist_delete_aux :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> _" where
    "glist_delete_aux eq x [] as = as"
  | "glist_delete_aux eq x (y#ys) as = (
      if eq x y then rev_append as ys
      else glist_delete_aux eq x ys (y#as)
    )"

  definition glist_delete where
    "glist_delete eq x l \<equiv> glist_delete_aux eq x l []"

  lemma param_glist_delete[param]:
    "(glist_delete, glist_delete) \<in> (R\<rightarrow>R\<rightarrow>Id) \<rightarrow> R \<rightarrow> \<langle>R\<rangle>list_rel \<rightarrow> \<langle>R\<rangle>list_rel"
    unfolding glist_delete_def[abs_def]
      glist_delete_aux_def
      rev_append_def
    by (parametricity)

lemma list_rel_Range:
    "\<forall>x'\<in>set l'. x' \<in> Range R \<Longrightarrow> l' \<in> Range (\<langle>R\<rangle>list_rel)"
proof (induction l')
  case Nil thus ?case by force
next
  case (Cons x' xs')
    then obtain xs where "(xs,xs') \<in> \<langle>R\<rangle> list_rel" by force
    moreover from Cons.prems obtain x where "(x,x') \<in> R" by force
    ultimately have "(x#xs, x'#xs') \<in> \<langle>R\<rangle> list_rel" by simp
    thus ?case ..
qed

  text \<open>All finite sets can be represented\<close>
  lemma list_set_rel_range:
    "Range (\<langle>R\<rangle>list_set_rel) = { S. finite S \<and> S\<subseteq>Range R }"
      (is "?A = ?B")
  proof (intro equalityI subsetI)
    fix s' assume "s' \<in> ?A"
    then obtain l l' where A: "(l,l') \<in> \<langle>R\<rangle>list_rel" and
       B: "s' = set l'" and C: "distinct l'"
        unfolding list_set_rel_def br_def by blast
    moreover have "set l' \<subseteq> Range R"
        by (induction rule: list_rel_induct[OF A], auto)
    ultimately show "s' \<in> ?B" by simp
  next
    fix s' assume A: "s' \<in> ?B"
    then obtain l' where B: "set l' = s'" and C: "distinct l'"
        using finite_distinct_list by blast
    hence "(l',s') \<in> br set distinct" by (simp add: br_def)

    moreover from A and B have "\<forall>x\<in>set l'. x \<in> Range R" by blast
    from list_rel_Range[OF this] obtain l
        where "(l,l') \<in> \<langle>R\<rangle>list_rel" by blast

    ultimately show "s' \<in> ?A" unfolding list_set_rel_def by fast
  qed

  lemmas [autoref_rel_intf] = REL_INTFI[of list_set_rel i_set]

  lemma list_set_rel_finite[autoref_ga_rules]:
    "finite_set_rel (\<langle>R\<rangle>list_set_rel)"
    unfolding finite_set_rel_def list_set_rel_def
    by (auto simp: br_def)

  lemma list_set_rel_sv[relator_props]:
    "single_valued R \<Longrightarrow> single_valued (\<langle>R\<rangle>list_set_rel)"
    unfolding list_set_rel_def
    by tagged_solver

  (* TODO: Move to Misc *)
  lemma Id_comp_Id: "Id O Id = Id" by simp

  lemma glist_member_id_impl:
    "(glist_member (=), (\<in>)) \<in> Id \<rightarrow> br set distinct \<rightarrow> Id"
  proof (intro fun_relI, goal_cases)
    case (1 x x' l s') thus ?case
      by (induct l arbitrary: s') (auto simp: br_def)
  qed

  lemma glist_insert_id_impl:
    "(glist_insert (=), Set.insert) \<in> Id \<rightarrow> br set distinct \<rightarrow> br set distinct"
  proof -
    have IC: "\<And>x s. insert x s = (if x\<in>s then s else insert x s)" by auto

    show ?thesis
      apply (intro fun_relI)
      apply (subst IC)
      unfolding glist_insert_def
      apply (parametricity add: glist_member_id_impl)
      apply (auto simp: br_def)
      done
  qed

  lemma glist_delete_id_impl:
    "(glist_delete (=), \<lambda>x s. s-{x})
    \<in> Id\<rightarrow>br set distinct \<rightarrow> br set distinct"
  proof (intro fun_relI)
    fix x x':: 'a and s and s' :: "'a set"
    assume XREL: "(x, x') \<in> Id" and SREL: "(s, s') \<in> br set distinct"
    from XREL have [simp]: "x'=x" by simp

    {
      fix a and a' :: "'a set"
      assume "(a,a')\<in>br set distinct" and "s' \<inter> a' = {}"
      hence "(glist_delete_aux (=) x s a, s'-{x'} \<union> a')\<in>br set distinct"
        using SREL
      proof (induction s arbitrary: a s' a')
        case Nil thus ?case by (simp add: br_def)
      next
        case (Cons y s)
        show ?case proof (cases "x=y")
          case True with Cons show ?thesis
            by (auto simp add: br_def rev_append_eq)
        next
          case False
          have "glist_delete_aux (=) x (y # s) a
            = glist_delete_aux (=) x s (y#a)" by (simp add: False)
          also have "(\<dots>,set s - {x'} \<union> insert y a')\<in>br set distinct"
            apply (rule Cons.IH[of "y#a" "insert y a'" "set s"])
            using Cons.prems by (auto simp: br_def)
          also have "set s - {x'} \<union> insert y a' = (s' - {x'}) \<union> a'"
          proof -
            from Cons.prems have [simp]: "s' = insert y (set s)"
              by (auto simp: br_def)
            show ?thesis using False by auto
          qed
          finally show ?thesis .
        qed
      qed
    }
    from this[of "[]" "{}"]
    show "(glist_delete (=) x s, s' - {x'}) \<in> br set distinct"
      unfolding glist_delete_def
      by (simp add: br_def)
  qed

  lemma list_set_autoref_empty[autoref_rules]:
    "([],{})\<in>\<langle>R\<rangle>list_set_rel"
    by (auto simp: list_set_rel_def br_def)

  lemma list_set_autoref_member[autoref_rules]:
    assumes "GEN_OP eq (=) (R\<rightarrow>R\<rightarrow>Id)"
    shows "(glist_member eq,(\<in>)) \<in> R \<rightarrow> \<langle>R\<rangle>list_set_rel \<rightarrow> Id"
    using assms
    apply (intro fun_relI)
    unfolding list_set_rel_def
    apply (erule relcompE)
    apply (simp del: pair_in_Id_conv)
    apply (subst Id_comp_Id[symmetric])
    apply (rule relcompI[rotated])
    apply (rule glist_member_id_impl[param_fo])
    apply (rule IdI)
    apply assumption
    apply parametricity
    done

  lemma list_set_autoref_insert[autoref_rules]:
    assumes "GEN_OP eq (=) (R\<rightarrow>R\<rightarrow>Id)"
    shows "(glist_insert eq,Set.insert)
      \<in> R \<rightarrow> \<langle>R\<rangle>list_set_rel \<rightarrow> \<langle>R\<rangle>list_set_rel"
    using assms
    apply (intro fun_relI)
    unfolding list_set_rel_def
    apply (erule relcompE)
    apply (simp del: pair_in_Id_conv)
    apply (rule relcompI[rotated])
    apply (rule glist_insert_id_impl[param_fo])
    apply (rule IdI)
    apply assumption
    apply parametricity
    done

  lemma list_set_autoref_delete[autoref_rules]:
    assumes "GEN_OP eq (=) (R\<rightarrow>R\<rightarrow>Id)"
    shows "(glist_delete eq,op_set_delete)
      \<in> R \<rightarrow> \<langle>R\<rangle>list_set_rel \<rightarrow> \<langle>R\<rangle>list_set_rel"
    using assms
    apply (intro fun_relI)
    unfolding list_set_rel_def
    apply (erule relcompE)
    apply (simp del: pair_in_Id_conv)
    apply (rule relcompI[rotated])
    apply (rule glist_delete_id_impl[param_fo])
    apply (rule IdI)
    apply assumption
    apply parametricity
    done

  lemma list_set_autoref_to_list[autoref_ga_rules]:
    shows "is_set_to_sorted_list (\<lambda>_ _. True) R list_set_rel id"
    unfolding is_set_to_list_def is_set_to_sorted_list_def
      it_to_sorted_list_def list_set_rel_def br_def
    by auto

  lemma list_set_it_simp[refine_transfer_post_simp]:
    "foldli (id l) = foldli l" by simp

  lemma glist_insert_dj_id_impl:
    "\<lbrakk> x\<notin>s; (l,s)\<in>br set distinct \<rbrakk> \<Longrightarrow> (x#l,insert x s)\<in>br set distinct"
    by (auto simp: br_def)

context begin interpretation autoref_syn .
  lemma list_set_autoref_insert_dj[autoref_rules]:
    assumes "PRIO_TAG_OPTIMIZATION"
    assumes "SIDE_PRECOND_OPT (x'\<notin>s')"
    assumes "(x,x')\<in>R"
    assumes "(s,s')\<in>\<langle>R\<rangle>list_set_rel"
    shows "(x#s,
      (OP Set.insert ::: R \<rightarrow> \<langle>R\<rangle>list_set_rel \<rightarrow> \<langle>R\<rangle>list_set_rel) $ x' $ s')
      \<in> \<langle>R\<rangle>list_set_rel"
    using assms
    unfolding autoref_tag_defs
    unfolding list_set_rel_def
    apply -
    apply (erule relcompE)
    apply (simp del: pair_in_Id_conv)
    apply (rule relcompI[rotated])
    apply (rule glist_insert_dj_id_impl)
    apply assumption
    apply assumption
    apply parametricity
    done
end

  subsection \<open>More Operations\<close>
  lemma list_set_autoref_isEmpty[autoref_rules]:
    "(is_Nil,op_set_isEmpty) \<in> \<langle>R\<rangle>list_set_rel \<rightarrow> bool_rel"
    by (auto simp: list_set_rel_def br_def split: list.split_asm)

  lemma list_set_autoref_filter[autoref_rules]:
    "(filter,op_set_filter)
      \<in> (R \<rightarrow> bool_rel) \<rightarrow> \<langle>R\<rangle>list_set_rel \<rightarrow> \<langle>R\<rangle>list_set_rel"
  proof -
    have "(filter, op_set_filter)
      \<in> (Id \<rightarrow> bool_rel) \<rightarrow> \<langle>Id\<rangle>list_set_rel \<rightarrow> \<langle>Id\<rangle>list_set_rel"
      by (auto simp: list_set_rel_def br_def)
    note this[param_fo]
    moreover have "(filter,filter)\<in>(R \<rightarrow> bool_rel) \<rightarrow> \<langle>R\<rangle>list_rel \<rightarrow> \<langle>R\<rangle>list_rel"
      unfolding List.filter_def
      by parametricity
    note this[param_fo]
    ultimately show ?thesis
      unfolding list_set_rel_def
      apply (intro fun_relI)
      apply (erule relcompE, simp)
      apply (rule relcompI)
      apply (rprems, assumption+)
      apply (rprems, simp+)
      done
  qed

  context begin interpretation autoref_syn .
  lemma list_set_autoref_inj_image[autoref_rules]:
    assumes "PRIO_TAG_OPTIMIZATION"
    assumes INJ: "SIDE_PRECOND_OPT (inj_on f s)"
    assumes [param]: "(fi,f)\<in>Ra\<rightarrow>Rb"
    assumes LP: "(l,s)\<in>\<langle>Ra\<rangle>list_set_rel"
    shows "(map fi l,
      (OP (`) ::: (Ra\<rightarrow>Rb) \<rightarrow> \<langle>Ra\<rangle>list_set_rel \<rightarrow> \<langle>Rb\<rangle>list_set_rel)$f$s)
      \<in> \<langle>Rb\<rangle>list_set_rel"
  proof -
    from LP obtain l' where
      [param]: "(l,l')\<in>\<langle>Ra\<rangle>list_rel" and L'S: "(l',s)\<in>br set distinct"
      unfolding list_set_rel_def by auto

    have "(map fi l, map f l')\<in>\<langle>Rb\<rangle>list_rel" by parametricity
    also from INJ L'S have "(map f l',f`s)\<in>br set distinct"
      apply (induction l' arbitrary: s)
      apply (auto simp: br_def dest: injD)
      done
    finally (relcompI) show ?thesis
      unfolding autoref_tag_defs list_set_rel_def .
  qed

  end

  lemma list_set_cart_autoref[autoref_rules]:
    fixes Rx :: "('xi \<times> 'x) set"
    fixes Ry :: "('yi \<times> 'y) set"
    shows "(\<lambda>xl yl. [ (x,y). x\<leftarrow>xl, y\<leftarrow>yl], op_set_cart)
    \<in> \<langle>Rx\<rangle>list_set_rel \<rightarrow> \<langle>Ry\<rangle>list_set_rel \<rightarrow> \<langle>Rx \<times>\<^sub>r Ry\<rangle>list_set_rel"
  proof (intro fun_relI)
    fix xl xs yl ys
    assume "(xl, xs) \<in> \<langle>Rx\<rangle>list_set_rel" "(yl, ys) \<in> \<langle>Ry\<rangle>list_set_rel"
    then obtain xl' :: "'x list" and yl' :: "'y list" where
      [param]: "(xl,xl')\<in>\<langle>Rx\<rangle>list_rel" "(yl,yl')\<in>\<langle>Ry\<rangle>list_rel"
      and XLS: "(xl',xs)\<in>br set distinct" and YLS: "(yl',ys)\<in>br set distinct"
      unfolding list_set_rel_def
      by auto

    have "([ (x,y). x\<leftarrow>xl, y\<leftarrow>yl ], [ (x,y). x\<leftarrow>xl', y\<leftarrow>yl' ])
      \<in> \<langle>Rx \<times>\<^sub>r Ry\<rangle>list_rel"
      by parametricity
    also have "([ (x,y). x\<leftarrow>xl', y\<leftarrow>yl' ], xs \<times> ys) \<in> br set distinct"
      using XLS YLS
      apply (auto simp: br_def)
      apply hypsubst_thin
      apply (induction xl')
      apply simp
      apply (induction yl')
      apply simp
      apply auto []
      apply (metis (lifting) concat_map_maps distinct.simps(2)
        distinct_singleton maps_simps(2))
      done
    finally (relcompI)
    show "([ (x,y). x\<leftarrow>xl, y\<leftarrow>yl ], op_set_cart xs ys) \<in> \<langle>Rx \<times>\<^sub>r Ry\<rangle>list_set_rel"
      unfolding list_set_rel_def by simp
  qed

  subsection \<open>Optimizations\<close>
  lemma glist_delete_hd: "eq x y \<Longrightarrow> glist_delete eq x (y#s) = s"
    by (simp add: glist_delete_def)

  text \<open>Hack to ensure specific ordering. Note that ordering has no meaning
    abstractly\<close>
  definition [simp]: "LIST_SET_REV_TAG \<equiv> \<lambda>x. x"

  lemma LIST_SET_REV_TAG_autoref[autoref_rules]:
    "(rev,LIST_SET_REV_TAG) \<in> \<langle>R\<rangle>list_set_rel \<rightarrow> \<langle>R\<rangle>list_set_rel"
    unfolding list_set_rel_def
    apply (intro fun_relI)
    apply (elim relcompE)
    apply (clarsimp simp: br_def)
    apply (rule relcompI)
    apply (rule param_rev[param_fo], assumption)
    apply auto
    done

end


(* Author: Johannes Hölzl <hoelzl@in.tum.de> *)

section \<open>The Category of Measurable Spaces is not Cartesian Closed\<close>

theory Measure_Not_CCC
  imports "~~/src/HOL/Probability/Probability" "~~/src/HOL/Library/ContNotDenum"
begin

text \<open>
  We show that the category of measurable spaces with measurable functions as morphisms is not a
  Cartesian closed category. While the category has products and terminal objects, the exponential
  does not exist for each pair of measurable spaces.

  We show that the exponential $\mathbb{B}^\mathbb{C}$ does not exist, where $\mathbb{B}$ is the
  discrete measurable space on boolean values, and $\mathbb{C}$ is the $\sigma$-algebra consisting
  of all countable and co-countable real sets. We also define $\mathbb{R}$ to be the discrete
  measurable space on the reals.

  Now, the diagonal predicate @{term "\<lambda>x y. x = y"} is $\mathbb{R}$-$\mathbb{B}^\mathbb{C}$-measurable,
  but @{term "\<lambda>(x, y). x = y"} is not $(\mathbb{R} \times \mathbb{C})$-$\mathbb{B}$-measurable.
\<close>

definition COCOUNT :: "real measure" where
  "COCOUNT = sigma UNIV {{x} | x. True}"

abbreviation POW :: "real measure" where
  "POW \<equiv> count_space UNIV"

abbreviation BOOL :: "bool measure" where
  "BOOL \<equiv> count_space UNIV"

lemma measurable_const_iff: "(\<lambda>x. c) \<in> measurable A B \<longleftrightarrow> (space A = {} \<or> c \<in> space B)"
  by (auto simp: measurable_def)

lemma measurable_eq[measurable]: "(op = x) \<in> measurable COCOUNT BOOL"
  unfolding pred_def by (auto simp: COCOUNT_def)

lemma COCOUNT_eq: "A \<in> COCOUNT \<longleftrightarrow> countable A \<or> countable (UNIV - A)"
proof
  fix A assume "A \<in> COCOUNT"
  then have "A \<in> sigma_sets UNIV {{x} | x. True}"
    by (auto simp: COCOUNT_def)
  then show "countable A \<or> countable (UNIV - A)"
  proof induction
    case (Union F)
    moreover
    { fix i assume "countable (UNIV - F i)"
      then have "countable (UNIV - (\<Union>i. F i))"
        by (rule countable_subset[rotated]) auto }
    ultimately show "countable (\<Union>i. F i) \<or> countable (UNIV - (\<Union>i. F i))"
      by blast
  qed (auto simp: Diff_Diff_Int)
next
  assume "countable A \<or> countable (UNIV - A)"
  moreover
  { fix A :: "real set" assume A: "countable A"
    have "A = (\<Union>a\<in>A. {a})"
      by auto
    also have "\<dots> \<in> COCOUNT"
      by (intro sets.countable_UN' A) (auto simp: COCOUNT_def)
    finally have "A \<in> COCOUNT" . }
  note A = this
  note A[of A]
  moreover
  { assume "countable (UNIV - A)"
    with A have "space COCOUNT - (UNIV - A) \<in> COCOUNT" by simp
    then have "A \<in> COCOUNT"
      by (auto simp: COCOUNT_def Diff_Diff_Int) }
  ultimately show "A \<in> COCOUNT"
    by blast
qed

lemma pair_COCOUNT:
  assumes A: "A \<in> sets (COCOUNT \<Otimes>\<^sub>M M)"
  shows "\<exists>J F X. X \<in> sets M \<and> F \<in> J \<rightarrow> sets M \<and> countable J \<and> A = (UNIV - J) \<times> X \<union> (SIGMA j:J. F j)"
  using A unfolding sets_pair_measure
proof induction
  case (Basic X)
  then obtain a b where X: "X = a \<times> b" and b: "b \<in> sets M" and a: "countable a \<or> countable (UNIV - a)"
    by (auto simp: COCOUNT_eq)
  from a show ?case
  proof
    assume "countable a" with X b show ?thesis
      by (intro exI[of _ a] exI[of _ "\<lambda>_. b"] exI[of _ "{}"]) auto
  next
    assume "countable (UNIV - a)" with X b show ?thesis
      by (intro exI[of _ "UNIV - a"] exI[of _ "\<lambda>_. {}"] exI[of _ "b"]) auto
  qed
next
  case Empty then show ?case
    by (intro exI[of _ "{}"] exI[of _ "\<lambda>_. {}"] exI[of _ "{}"]) auto
next
  case (Compl A)
  then obtain J F X where XFJ: "X \<in> sets M" "F \<in> J \<rightarrow> sets M" "countable J"
    and A: "A = (UNIV - J) \<times> X \<union> Sigma J F"
    by auto
  have *: "space COCOUNT \<times> space M - A = (UNIV - J) \<times> (space M - X) \<union> (SIGMA j:J. space M - F j)"
    unfolding A by (auto simp: COCOUNT_def)
  show ?case
    using XFJ unfolding *
    by (intro exI[of _ J] exI[of _ "space M - X"] exI[of _ "\<lambda>j. space M - F j"]) auto
next
  case (Union A)
  obtain J F X where XFJ: "\<And>i. X i \<in> sets M" "\<And>i. F i \<in> J i \<rightarrow> sets M" "\<And>i. countable (J i)"
    and A_eq: "A = (\<lambda>i. (UNIV - J i) \<times> X i \<union> Sigma (J i) (F i))"
    unfolding fun_eq_iff using Union.IH by metis
  show ?case
  proof (intro exI conjI)
    def G \<equiv> "\<lambda>j. (\<Union>i. if j \<in> J i then F i j else X i)"
    show "(\<Union>i. X i) \<in> sets M" "countable (\<Union>i. J i)" "G \<in> (\<Union>i. J i) \<rightarrow> sets M"
      using XFJ by (auto simp: G_def Pi_iff)
    show "UNION UNIV A = (UNIV - (\<Union>i. J i)) \<times> (\<Union>i. X i) \<union> (SIGMA j:\<Union>i. J i. \<Union>i. if j \<in> J i then F i j else X i)"
      unfolding A_eq by (auto split: split_if_asm)
  qed
qed

context
  fixes EXP :: "(real \<Rightarrow> bool) measure"
  assumes eq: "\<And>P. split P \<in> measurable (POW \<Otimes>\<^sub>M COCOUNT) BOOL \<longleftrightarrow> P \<in> measurable POW EXP"
begin

lemma space_EXP: "space EXP = measurable COCOUNT BOOL"
proof -
  { fix f
    have "f \<in> space EXP \<longleftrightarrow> (\<lambda>(a, b). f b) \<in> measurable (POW \<Otimes>\<^sub>M COCOUNT) BOOL"
      using eq[of "\<lambda>x. f"] by (simp add: measurable_const_iff)
    also have "\<dots> \<longleftrightarrow> f \<in> measurable COCOUNT BOOL"
      by auto
    finally have "f \<in> space EXP \<longleftrightarrow> f \<in> measurable COCOUNT BOOL" . }
  then show ?thesis by auto
qed

lemma measurable_eq_EXP: "(\<lambda>x y. x = y) \<in> measurable POW EXP"
  unfolding measurable_def by (auto simp: space_EXP)

lemma measurable_eq_pair: "(\<lambda>(y, x). x = y) \<in> measurable (COCOUNT \<Otimes>\<^sub>M POW) BOOL"
  using measurable_eq_EXP unfolding eq[symmetric]
  by (subst measurable_pair_swap_iff) simp

lemma ce: False
proof -
  have "{(y, x) \<in> space (COCOUNT \<Otimes>\<^sub>M POW). x = y} \<in> sets (COCOUNT \<Otimes>\<^sub>M POW)"
    using measurable_eq_pair unfolding pred_def by (simp add: split_beta')
  also have "{(y, x) \<in> space (COCOUNT \<Otimes>\<^sub>M POW). x = y} = (SIGMA j:UNIV. {j})"
    by (auto simp: space_pair_measure COCOUNT_def)
  finally obtain X F J where "countable (J::real set)"
    and eq: "(SIGMA j:UNIV. {j}) = (UNIV - J) \<times> X \<union> (SIGMA j:J. F j)"
    using pair_COCOUNT[of "SIGMA j:UNIV. {j}" POW] by auto
  have X_single: "\<And>x. x \<notin> J \<Longrightarrow> X = {x}"
    using eq[unfolded set_eq_iff] by force

  have "uncountable (UNIV - J)"
    using `countable J` uncountable_UNIV_real uncountable_minus_countable by blast
  then have "infinite (UNIV - J)"
    by (auto intro: countable_finite)
  then have "\<exists>A. finite A \<and> card A = 2 \<and> A \<subseteq> UNIV - J"
    by (rule infinite_arbitrarily_large)
  then obtain i j where ij: "i \<in> UNIV - J" "j \<in> UNIV - J" "i \<noteq> j"
    by (auto simp add: card_Suc_eq numeral_2_eq_2)
  have "{(i, i), (j, j)} \<subseteq> (SIGMA j:UNIV. {j})" by auto
  with ij X_single[of i] X_single[of j] show False
    by auto
qed

end

corollary "\<not> (\<exists>EXP. \<forall>P. split P \<in> measurable (POW \<Otimes>\<^sub>M COCOUNT) BOOL \<longleftrightarrow> P \<in> measurable POW EXP)"
  using ce by blast

end


(*
    $Id: ex.thy,v 1.3 2012/08/13 15:59:05 webertj Exp $
    Author: Tobias Nipkow
*)

header {* The Towers of Hanoi *}

(*<*) theory ex imports Main begin (*>*)

text {*
We are given 3 pegs $A$, $B$ and $C$, and $n$ disks with a hole, such that no
two disks have the same diameter.  Initially all $n$ disks rest on peg $A$,
ordered according to their size, with the largest one at the bottom.  The aim
is to transfer all $n$ disks from $A$ to $C$ by a sequence of single-disk moves
such that we never place a larger disk on top of a smaller one.  Peg $B$ may be
used for intermediate storage.

\begin{center}
\includegraphics[width=0.8\textwidth]{Hanoi}
\end{center}

\medskip The pegs and moves can be modelled as follows:
*}

datatype peg = A | B | C

type_synonym move = "peg * peg"

text {*
Define a primitive recursive function
*}

consts
  move :: "nat => peg => peg => move list"

text {*
such that @{term move}$~n~a~b$ returns a list of (legal) moves that transfer
$n$ disks from peg $a$ to peg $c$.
*}

text {*
Show that this requires $2^n - 1$ moves:
*}

theorem "length (move n a b) = 2^n - 1"
(*<*) oops (*>*)

text {*
Hint: You need to strengthen the theorem for the induction to go through.
Beware: subtraction on natural numbers behaves oddly: $n - m = 0$ if $n \le m$.
*}

subsection {* Correctness *}

text {*
In the last section we introduced the towers of Hanoi and defined a function
@{term move} to generate the moves to solve the puzzle.  Now it is time to show
that @{term move} is correct.  This means that
\begin{itemize}
\item when executing the list of moves, the result is indeed the intended one,
      i.e.\ all disks are moved from one peg to another, and
\item all of the moves are legal, i.e.\ never is a larger disk placed on top of
      a smaller one.
\end{itemize}

Hint: This is a non-trivial undertaking.  The complexity of your proofs will
depend crucially on your choice of model, and you may have to revise your model
as you proceed with the proof.
*}

(*<*) end (*>*)


(*  Author:     Makarius

Example theory involving Unicode characters (UTF-8 encoding) -- both
formal and informal ones.
*)

section \<open>A Hebrew theory\<close>

theory Hebrew
imports MainRLT
begin

text \<open>
  \<^bold>\<open>Warning:\<close> Bidirectional Unicode text may confuse display in browsers, editors, etc.!
\<close>

subsection \<open>The Hebrew Alef-Bet (א-ב).\<close>

datatype alef_bet =
    Alef    ("א")
  | Bet     ("ב")
  | Gimel   ("ג")
  | Dalet   ("ד")
  | He      ("ה")
  | Vav     ("ו")
  | Zayin   ("ז")
  | Het     ("ח")
  | Tet     ("ט")
  | Yod     ("י")
  | Kaf     ("כ")
  | Lamed   ("ל")
  | Mem     ("מ")
  | Nun     ("נ")
  | Samekh  ("ס")
  | Ayin    ("ע")
  | Pe      ("פ")
  | Tsadi   ("צ")
  | Qof     ("ק")
  | Resh    ("ר")
  | Shin    ("ש")
  | Tav     ("ת")

thm alef_bet.induct

subsection \<open>Interpreting Hebrew letters as numbers.\<close>

primrec mispar :: "alef_bet \<Rightarrow> nat"
where
  "mispar א = 1"
| "mispar ב = 2"
| "mispar ג = 3"
| "mispar ד = 4"
| "mispar ה = 5"
| "mispar ו = 6"
| "mispar ז = 7"
| "mispar ח = 8"
| "mispar ט = 9"
| "mispar י = 10"
| "mispar כ = 20"
| "mispar ל = 30"
| "mispar מ = 40"
| "mispar נ = 50"
| "mispar ס = 60"
| "mispar ע = 70"
| "mispar פ = 80"
| "mispar צ = 90"
| "mispar ק = 100"
| "mispar ר = 200"
| "mispar ש = 300"
| "mispar ת = 400"

thm mispar.simps

lemma "mispar ק + mispar ל + mispar ה = 135"
  by simp

end


(* Title:      Action Algebra
   Author:     Alasdair Armstrong, Georg Struth, Tjark Weber
   Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
               Tjark Weber <tjark.weber at it.uu.se>
*)

section \<open>Action Algebras\<close>

theory Action_Algebra
imports "../Residuated_Lattices/Residuated_Lattices" Kleene_Algebra.Kleene_Algebra
begin

text \<open>Action algebras have been defined and discussed in œ
Pratt's paper on \emph{Action Logic and Pure
Induction}~\cite{pratt90action}. They are expansions of Kleene
algebras by operations of left and right residuation. They are
interesting, first because most models of Kleene algebras, e.g.
relations, traces, paths and languages, possess the residuated
structure, and second because, in this setting, the Kleene star can be
defined equationally.

Action algebras can be based on residuated
semilattices. Many important properties of action
algebras already arise at this level.\<close>

text \<open>We can define an action algebra as a residuated join
semilattice that is also a dioid. Following Pratt, we also add a star
operation that is axiomatised as a reflexive transitive closure
operation.
\<close>

class action_algebra = residuated_sup_lgroupoid + dioid_one_zero + star_op +
  assumes star_rtc1: "1 + x\<^sup>\<star> \<cdot> x\<^sup>\<star> + x \<le> x\<^sup>\<star>"
  and star_rtc2: "1 + y \<cdot> y + x \<le> y \<Longrightarrow> x\<^sup>\<star> \<le> y"
begin

lemma plus_sup: "(+) = (\<squnion>)"
  by (rule ext)+ (simp add: local.join.sup_unique)

text \<open>We first prove a reflexivity property for residuals.\<close>

lemma residual_r_refl: "1 \<le> x \<rightarrow> x"
  by (simp add: local.resrI)

lemma residual_l_refl: "1 \<le> x \<leftarrow> x"
  by (simp add: local.reslI)

text \<open>We now derive pure induction laws for residuals.\<close>

lemma residual_l_pure_induction: "(x \<leftarrow> x)\<^sup>\<star> \<le> x \<leftarrow> x"
proof -
  have "1 + (x \<leftarrow> x) \<cdot> (x \<leftarrow> x) + (x \<leftarrow> x) \<le> (x \<leftarrow> x)"
    using local.resl_antitoner local.resl_galois mult_assoc by auto
  thus ?thesis
    by (fact star_rtc2)
qed

lemma residual_r_pure_induction: "(x \<rightarrow> x)\<^sup>\<star> \<le> x \<rightarrow> x"
proof -
  have "1 + (x \<rightarrow> x) \<cdot> (x \<rightarrow> x) + (x \<rightarrow> x) \<le> (x \<rightarrow> x)"
    using local.resr_antitonel local.resr_galois mult_assoc apply clarsimp
    by (metis local.mult_oner residual_r_refl)
  thus ?thesis
    by (fact star_rtc2)
qed

text \<open>Next we show that every action algebra is a Kleene
algebra. First, we derive the star unfold law and the star induction
laws in action algebra. Then we prove a subclass statement.\<close>

lemma star_unfoldl: "1 + x \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star>"
proof -
  have "x \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star>"
    by (meson local.dual_order.trans local.join.le_sup_iff local.mult_isor local.star_rtc1)
  thus ?thesis
    using local.star_rtc1 by auto
qed

lemma star_mon [intro]: "x \<le> y \<Longrightarrow> x\<^sup>\<star> \<le> y\<^sup>\<star>"
proof -
  assume "x \<le> y"
  hence "x \<le> y\<^sup>\<star>"
    by (meson local.dual_order.trans local.join.le_supE local.star_rtc1)
  hence "1 + x + y\<^sup>\<star> \<cdot> y\<^sup>\<star> \<le> y\<^sup>\<star>"
    using local.star_rtc1 by auto
  thus "x\<^sup>\<star> \<le> y\<^sup>\<star>"
    by (simp add: local.star_rtc2)
qed

lemma star_subdist': "x\<^sup>\<star> \<le> (x + y)\<^sup>\<star>"
  by force

lemma star_inductl: "z + x \<cdot> y \<le> y \<Longrightarrow> x\<^sup>\<star> \<cdot> z \<le> y"
proof -
  assume hyp: "z + x \<cdot> y \<le> y"
  hence "x \<le> y \<leftarrow> y"
    by (simp add: local.resl_galois)
  hence "x\<^sup>\<star> \<le> (y \<leftarrow> y)\<^sup>\<star>"
    by (fact star_mon)
  hence "x\<^sup>\<star> \<le> y \<leftarrow> y"
    using local.order_trans residual_l_pure_induction by blast
  hence "x\<^sup>\<star> \<cdot> y \<le> y"
    by (simp add: local.resl_galois)
  thus "x\<^sup>\<star> \<cdot> z \<le> y"
    by (meson hyp local.dual_order.trans local.join.le_supE local.mult_isol)
qed

lemma star_inductr: "z + y \<cdot> x \<le> y \<Longrightarrow> z \<cdot> x\<^sup>\<star> \<le> y"
proof -
  assume hyp: "z + y \<cdot> x \<le> y"
  hence "x \<le> y \<rightarrow> y"
    by (simp add: resr_galois)
  hence "x\<^sup>\<star> \<le> (y \<rightarrow> y)\<^sup>\<star>"
    by (fact star_mon)
  hence "x\<^sup>\<star> \<le> y \<rightarrow> y"
    by (metis order_trans residual_r_pure_induction)
  hence "y \<cdot> x\<^sup>\<star> \<le> y"
    by (simp add: local.resr_galois)
  thus "z \<cdot> x\<^sup>\<star> \<le> y"
    by (meson hyp local.join.le_supE local.order_trans local.resl_galois)
qed

subclass kleene_algebra
proof
  fix x y z
  show "1 + x \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star>"
    using local.star_unfoldl by blast
  show "z + x \<cdot> y \<le> y \<Longrightarrow> x\<^sup>\<star> \<cdot> z \<le> y"
    by (simp add: local.star_inductl)
  show "z + y \<cdot> x \<le> y \<Longrightarrow> z \<cdot> x\<^sup>\<star> \<le> y"
    by (simp add: star_inductr)
qed

end (* action_algebra *)

subsection \<open>Equational Action Algebras\<close>

text \<open>The induction axioms of Kleene algebras are universal Horn
formulas. This is unavoidable, because due to a well known result of
Redko, there is no finite equational axiomatisation for the equational
theory of regular expressions.

Action algebras, in contrast, admit a finite equational
axiomatization, as Pratt has shown. We now formalise this
result. Consequently, the equational action algebra axioms, which
imply those based on Galois connections, which in turn imply those of
Kleene algebras, are complete with respect to the equational theory of
regular expressions. However, this completeness result does not
account for residuation.\<close>

class equational_action_algebra = residuated_sup_lgroupoid + dioid_one_zero + star_op +
  assumes star_ax: "1 + x\<^sup>\<star> \<cdot> x\<^sup>\<star> + x \<le> x\<^sup>\<star>"
  and star_subdist: "x\<^sup>\<star> \<le> (x + y)\<^sup>\<star>"
  and right_pure_induction: "(x \<rightarrow> x)\<^sup>\<star> \<le> x \<rightarrow> x"
begin

text \<open>We now show that the equational axioms of action algebra
satisfy those based on the Galois connections. Since we can use our
correspondence between the two variants of residuated semilattice, it
remains to derive the second reflexive transitive closure axiom for
the star, essentially copying Pratt's proof step by step. We then
prove a subclass statement.\<close>

lemma star_rtc_2: "1 + y \<cdot> y + x \<le> y \<Longrightarrow> x\<^sup>\<star> \<le> y"
proof -
  assume "1 + y \<cdot> y + x \<le> y"
  hence "1 \<le> y" and "x \<le> y" and "y \<cdot> y \<le> y"
    by auto
  hence "y \<le> y \<rightarrow> y" and "x \<le> y \<rightarrow> y"
    using local.order_trans by blast+
  hence "x\<^sup>\<star> \<le> (y \<rightarrow> y)\<^sup>\<star>"
    by (metis local.join.sup.absorb2 local.star_subdist)
  hence "x\<^sup>\<star> \<le> y \<rightarrow> y"
    by (metis order_trans right_pure_induction)
  hence "y \<cdot> x\<^sup>\<star> \<le> y"
    by (simp add: local.resr_galois)
  thus "x\<^sup>\<star> \<le> y"
    by (metis \<open>1 \<le> y\<close> local.dual_order.trans local.mult_onel local.resl_galois)
qed

subclass action_algebra
  by (unfold_locales, metis star_ax, metis star_rtc_2)

end (* equational_action_algebra *)

text \<open>
Conversely, every action algebra satisfies the equational axioms of
equational action algebras.

Because the subclass relation must be acyclic in Isabelle, we can only
establish this for the corresponding locales. Again this proof is
based on the residuated semilattice result.
\<close>

sublocale action_algebra \<subseteq> equational_action_algebra
  by (unfold_locales, metis star_rtc1, metis star_subdist, metis residual_r_pure_induction)

subsection \<open>Another Variant\<close>

text \<open>Finally we show that Pratt and Kozen's star axioms generate
precisely the same theory.\<close>

class action_algebra_var = residuated_sup_lgroupoid + dioid_one_zero + star_op +
  assumes star_unfold': "1 + x \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star>"
  and star_inductl': "z + x \<cdot> y \<le> y \<Longrightarrow> x\<^sup>\<star> \<cdot> z \<le> y"
  and star_inductr': "z + y \<cdot> x \<le> y \<Longrightarrow> z \<cdot> x\<^sup>\<star>  \<le> y"
begin

subclass kleene_algebra
  by (unfold_locales, metis star_unfold', metis star_inductl', metis star_inductr')

subclass action_algebra
  by (unfold_locales, metis add.commute less_eq_def order_refl star_ext star_plus_one star_trans_eq, metis add.assoc add.commute star_rtc_least)

end

sublocale action_algebra \<subseteq> action_algebra_var
  by (unfold_locales, metis star_unfoldl, metis star_inductl, metis star_inductr)

end


text \<open> Version 0.4, last changed 2019-01-28
  (C) fovefi ltd, www.fovefi.co
  (author: Lukas Bulwahn [lubu@fovefi.co], comments by Manfred Kerber [make@fovefi.co])

  Dually licenced under
  Creative Commons Attribution (CC-BY) 4.0 [https://creativecommons.org/licenses/by/4.0/]
  ISC License (1-clause BSD License)       [https://www.isc.org/downloads/software-support-policy/isc-license/]
  See LICENSE files for details.
  (Rationale for this dual licence: http://arxiv.org/abs/1107.3212)

  In this file, a linear approximation (i.e., linear interpolation) is defined. The linear approximation
  of two given points (x1,y1) and (x2,y2) is a function f(x) = a*(x-b) + c with f(x1) = y1 and
  f(x2) = y2. This is the function with slope a = (y2 - y1)/(x2 - x1), b = x1,
  and c = y1. There is a priori a problem if the two given points are the same. We implicitly assume
  in the following that they are not. Note that Isabelle's logic is total and 1/0 has been defined
  as 0.

  In addition to the definition, properties of the linear approximation are presented
  such as about the maximum and minimum of the linear approximation. \<close>

theory Linear_Interpolation
  imports Complex_Main
begin

section \<open>Linear function defined by two points\<close>

text \<open> A linear function through two points (x1, y1) and (x2, y2) is defined as the unique
      straight line through the points (assumed the points are different and x1 \<noteq> x2). \<close>
definition linear :: "real \<times> real \<Rightarrow> real \<times> real \<Rightarrow> real \<Rightarrow> real"
where
  "linear xy1 xy2 = (case (xy1, xy2) of
    ((x1, y1), (x2, y2)) \<Rightarrow> (\<lambda>x. (y2 - y1) / (x2 - x1) * (x - x1) + y1))"

text \<open> Alternative description with explicit pair representation. \<close>
lemma linear_def':
  "linear (x1, y1) (x2, y2) = (\<lambda>x. (y2 - y1) / (x2 - x1) * (x - x1) + y1)"
unfolding linear_def by simp

text \<open> Alternative description of linear function. \<close>
lemma linear_eq:
  "linear (x1, y1) (x2, y2) x = y1 + (x - x1) * (y2 - y1) / (x2 - x1)"
unfolding linear_def by simp

text \<open> The linear function evaluates correctly at the first point. \<close>
lemma linear_first:
  "linear (x1, y1) (x2, y2) x1 = y1"
unfolding linear_def' by simp

text \<open> The linear function evaluates correctly at the second point, assumed the x-values are different \<close>
lemma linear_second:
  assumes "x1 \<noteq> x2"
  shows "linear (x1, y1) (x2, y2) x2 = y2"
using assms unfolding linear_def' by simp

text \<open> A linear function is bounded from above by the bigger of two values (for all values in between). \<close>
lemma linear_upper_bound:
  assumes "x1 \<le> x" "x \<le> x2"
  shows "linear (x1, y1) (x2, y2) x \<le> max y1 y2"
proof -
  have "linear (x1, y1) (x2, y2) x = (y2 - y1) / (x2 - x1) * (x - x1) + y1"
    unfolding linear_def' by simp
  also have "\<dots> \<le> max y1 y2"
  proof cases
    assume "y1 \<le> y2"
    have "(x - x1) / (x2 - x1) \<le> 1"
      using assms divide_le_eq_1 by force
    have "(y2 - y1) / (x2 - x1) * (x - x1) + y1 = y2 - ((1 - (x - x1) / (x2 - x1)) * (y2 - y1))"
      by algebra
    also have "\<dots> \<le> y2" by (simp add: \<open>(x - x1) / (x2 - x1) \<le> 1\<close> \<open>y1 \<le> y2\<close>)
    also have "\<dots> \<le> max y1 y2" by simp
    finally show ?thesis .
  next
    assume "\<not> y1 \<le> y2"
    from this have "(y2 - y1) / (x2 - x1) \<le> 0"
      using assms divide_le_0_iff by force
    from this have "(y2 - y1) / (x2 - x1) * (x - x1) + y1 \<le> y1"
      using assms(1) by (meson add_le_same_cancel2 diff_ge_0_iff_ge mult_le_0_iff)
    also have "\<dots> \<le> max y1 y2" by simp
    finally show ?thesis .
  qed
  finally show ?thesis .
qed

text \<open> A linear function is bounded from below by the smaller of two values (for all values in between).\<close>
lemma linear_lower_bound:
  assumes "x1 \<le> x" "x \<le> x2"
  shows "min y1 y2 \<le> linear (x1, y1) (x2, y2) x"
proof -
  have "min y1 y2 \<le> (y2 - y1) / (x2 - x1) * (x - x1) + y1"
  proof cases
    assume "y1 \<le> y2"
    have "(y2 - y1) / (x2 - x1) \<ge> 0"
      using \<open>y1 \<le> y2\<close> assms(1) assms(2) by auto
    have "min y1 y2 \<le> y1" by simp
    also have "\<dots> \<le> (y2 - y1) / (x2 - x1) * (x - x1) + y1"
      using \<open>0 \<le> (y2 - y1) / (x2 - x1)\<close> assms(1) mult_nonneg_nonneg by fastforce
    finally show ?thesis .
  next
    assume "\<not> y1 \<le> y2"
    have "(x - x1) / (x2 - x1) \<le> 1"
      using assms divide_le_eq_1 by fastforce
    have "min y1 y2 \<le> y2" by simp
    also have "\<dots> \<le> y2 - ((1 - (x - x1) / (x2 - x1)) * (y2 - y1))"
      using \<open>(x - x1) / (x2 - x1) \<le> 1\<close> \<open>\<not> y1 \<le> y2\<close> mult_le_0_iff by fastforce
    also have "\<dots> = (y2 - y1) / (x2 - x1) * (x - x1) + y1" by algebra
    finally show ?thesis .
  qed
  also have "(y2 - y1) / (x2 - x1) * (x - x1) + y1 = linear (x1, y1) (x2, y2) x"
    unfolding linear_def' by simp
  finally show ?thesis .
qed

text \<open> Linear functions with the value at the 2nd point greater or equal the value at the 1st point
   are (weakly) monotonically increasing. \<close>
lemma linear_monotonic:
  assumes "x1 < x2" "y1 \<le> y2"
  assumes "x \<le> x'"
  shows "linear (x1, y1) (x2, y2) x \<le> linear (x1, y1) (x2, y2) x'"
proof -
  from \<open>x1 < x2\<close> \<open>y1 \<le> y2\<close> have "(y2 - y1) / (x2 - x1) \<ge> 0" by auto
  from this show ?thesis
    using assms unfolding linear_def'
    by (metis add.commute add_le_cancel_left diff_right_mono mult.commute mult_le_cancel_right not_le)
qed

text \<open> Linear functions scale by constant factors.\<close>
lemma linear_scale:
  "c * linear (x1, y1) (x2, y2) x = linear (x1, c * y1) (x2, c * y2) x"
unfolding linear_def'
by (simp add: distrib_left linordered_field_class.sign_simps(38) mult.commute mult.left_commute)

text \<open> Linear functions are Lipschitz continuous with the Lipschitz constant being the slope. \<close>
lemma linear_Lipschitz:
  "\<bar>linear (x1, y1) (x2, y2) x' - linear (x1, y1) (x2, y2) x\<bar> = \<bar>(y2 - y1) / (x2 - x1)\<bar> * \<bar>x' - x\<bar>"
proof -
  have "\<bar>linear (x1, y1) (x2, y2) x' - linear (x1, y1) (x2, y2) x\<bar> =
     \<bar>(y2 - y1) / (x2 - x1) * (x' - x1) + y1 - ((y2 - y1) / (x2 - x1) * (x - x1) + y1)\<bar>"
    unfolding linear_def by simp
  also have "\<dots> = \<bar>(y2 - y1) / (x2 - x1) * (x' - x)\<bar>"
    by (simp add: linordered_field_class.sign_simps(38))
  also have "\<dots> = \<bar>(y2 - y1) / (x2 - x1)\<bar> * \<bar>x' - x\<bar>" by (simp add: abs_mult)
  finally show ?thesis .
qed

section \<open>Nearest rank method\<close>
text \<open> The nearest rank method assumes a partial function (concretely, a function with domain type
  "real option"), which is defined only for some values. This is perhaps best been explained with
  the help of an example.

  Let us assume that you have a list of 5 real numbers xs = [8, 10, 1, 4, 5] in order to compute a
  particular rank, e.g., that of 0.75, first you order the list and get sxs = [1, 4, 5, 8, 10].
  Then you put 5 values (length of the list) on the unit interval [0;1] at equal distances of 1/5,
  staying half the distance (i.e., 1/10) away from the left and right borders, that is, you get
  [0.1, 0.3, 0.5, 0.7, 0.9]. For all other values it is undefined. The nearest rank is the biggest
  defined position smaller than the position, e.g. for 0.75 it is 0.7.
 \<close>

definition nearest_rank :: "(real \<Rightarrow> real option) \<Rightarrow> real \<Rightarrow> real"
where
  "nearest_rank p x = the (p (Max {x'. p x' = Some x' \<and> x' \<le> x}))"

section \<open>Linear approximation of partial function\<close>

text \<open> Let p be a partial function and x be a real value, then the neighbors of x wrt p are two values,
  1) the biggest value - where p is defined - of the values smaller than or equal to x (as the
  next smaller neighbor) and
  2) the smallest value - where p is defined - of the values bigger than or equal to x (as the
  next bigger neighbor of x). \<close>
definition neighbors :: "(real \<Rightarrow> real option) \<Rightarrow> real \<Rightarrow> real \<times> real"
where
  "neighbors p x = (Max {x' \<in> dom p. x' \<le> x}, Min {x' \<in> dom p. x \<le> x'})"

text \<open> For a partial function p (i.e., a function of type real option), the defined interval of p is
  defined as the interval between the minimal element in the domain and the maximal element
  in the domain, (assumed p is not completely undefined, in which case it is the empty set). \<close>
definition defined_interval_of :: "(real \<Rightarrow> real option) \<Rightarrow> real set"
where
  "defined_interval_of p = (if (p = Map.empty) then {} else {Min (dom p)..Max (dom p)})"

text \<open> The linear approximation of a partial (real) function p is defined as the linear function
  going through the left and right neighbors where p is defined. \<close>
definition linear_interpolation :: "(real \<Rightarrow> real option) \<Rightarrow> real \<Rightarrow> real"
where
  "linear_interpolation p x = (let (x1, x2) = neighbors p x;
     (y1, y2) = (the (p x1), the (p x2)) in linear (x1, y1) (x2, y2) x)"

subsection \<open>Basic Properties\<close>

text \<open> The domain of a partial function p is a subset of the defined interval of p. \<close>
lemma subseteq_defined_interval_of:
  assumes "finite (dom p)"
  shows "dom p \<subseteq> defined_interval_of p"
using assms by (simp add: defined_interval_of_def subset_iff)

text \<open> If the domain of a partial function p is finite and an element is in the defined interval of p then
  the minimum of the elements in the domain greater than or equal to the element is in the domain
  of p as well and greater than or equal to the element. \<close>
lemma defined_interval_of_Min_in:
  assumes "finite (dom p)"
  assumes "x \<in> defined_interval_of p"
  shows "Min {x' \<in> dom p. x \<le> x'} \<in> {x' \<in> dom p. x \<le> x'}"
proof -
  from assms have "p \<noteq> Map.empty"
    unfolding defined_interval_of_def by auto
  from assms have "x \<in> {Min (dom p)..Max (dom p)}"
    by (simp add: \<open>p \<noteq> Map.empty\<close> defined_interval_of_def)
  from this have "Max (dom p) \<in> {x' \<in> dom p. x \<le> x'}"
    using \<open>p \<noteq> Map.empty\<close> \<open>finite (dom p)\<close> by auto
  have "finite {x' \<in> dom p. x \<le> x'}"
    using \<open>finite (dom p)\<close> by auto
  have "\<exists>y. p (Min {x' \<in> dom p. x \<le> x'}) = Some y"
    using \<open>finite {x' \<in> dom p. _}\<close> \<open>_ \<in> {x' \<in> dom p. _}\<close> Min_in by blast
  moreover have "x \<le> Min {x' \<in> dom p. x \<le> x'}"
    using \<open>finite {x' \<in> dom p. _}\<close> \<open>_ \<in> {x' \<in> dom p. _}\<close> Min_in by blast
  ultimately show ?thesis by auto
qed

text \<open> If the domain of a partial function p is finite and an element is in the defined interval of p then
  the maximum of the elements in the domain smaller than or equal to the element is in the domain
  of p as well and smaller than or equal to the element. \<close>
lemma defined_interval_of_Max_in:
  assumes "finite (dom p)"
  assumes "x \<in> defined_interval_of p"
  shows "Max {x' \<in> dom p. x' \<le> x} \<in> {x' \<in> dom p. x' \<le> x}"
proof -
  from assms have "p \<noteq> Map.empty"
    unfolding defined_interval_of_def by auto
  from assms have "x \<in> {Min (dom p)..Max (dom p)}"
    by (simp add: \<open>p \<noteq> Map.empty\<close> defined_interval_of_def)
  from this have "Min (dom p) \<in> {x' \<in> dom p. x' \<le> x}"
    using \<open>p \<noteq> Map.empty\<close> \<open>finite (dom p)\<close> by auto
  have "finite {x' \<in> dom p. x' \<le> x}"
    using \<open>finite (dom p)\<close> by auto
  have "\<exists>y. p (Max {x' \<in> dom p. x' \<le> x}) = Some y"
    using \<open>finite {x' \<in> dom p. _}\<close> \<open>_ \<in> {x' \<in> dom p. _}\<close> Max_in by blast
  moreover have "Max {x' \<in> dom p. x' \<le> x} \<le> x"
    using \<open>finite {x' \<in> dom p. _}\<close> \<open>_ \<in> {x' \<in> dom p. _}\<close> Max_in by blast
  ultimately show ?thesis by auto
qed

text \<open> For a partial function p, the neighbors of two defined values are equal or the right neighbor
  of the smaller is less than or equal to the left neighbor of the bigger. \<close>
lemma neighbors_cases:
  assumes "finite (dom p)"
  assumes "x \<in> defined_interval_of p" "x' \<in> defined_interval_of p"
  assumes "x \<le> x'"
  shows "(neighbors p x = neighbors p x') \<or> (snd (neighbors p x) \<le> fst (neighbors p x'))"
proof cases
  have "finite {x'' \<in> dom p. x \<le> x''}"
    by (simp add: \<open>finite (dom p)\<close>)
  assume "x' < Min {x'' \<in> dom p. x \<le> x''}"
  have "Min {x'' \<in> dom p. x' \<le> x''} = Min {x'' \<in> dom p. x \<le> x''}"
    using \<open>x \<le> x'\<close> \<open>x' < _\<close> \<open>finite {x'' \<in> dom p. _}\<close>
    by (metis (mono_tags, lifting) Min.bounded_iff eq_iff ex_in_conv less_eq_real_def mem_Collect_eq order_trans)
  moreover have "Max {x'' \<in> dom p. x'' \<le> x} = Max {x'' \<in> dom p. x'' \<le> x'}"
    using \<open>x \<le> x'\<close> \<open>x' < _\<close> \<open>finite {x'' \<in> dom p. _}\<close>
    by (smt Collect_cong Min_le mem_Collect_eq)
  ultimately show ?thesis
    unfolding neighbors_def by auto
next
  assume "\<not> x' < Min {x'' \<in> dom p. x \<le> x''}"
  have "Min {x'' \<in> dom p. x \<le> x''} \<in> {x'' \<in> dom p. x'' \<le> x'}"
    using assms(1, 2, 4) \<open>\<not> x' < _\<close> defined_interval_of_Min_in by auto
  have "Min {x'' \<in> dom p. x \<le> x''} \<le> Max {x'' \<in> dom p. x'' \<le> x'}"
    using \<open>finite _\<close> \<open>Min _ \<in> _\<close> by auto
  from this show ?thesis
    unfolding neighbors_def by auto
qed

text \<open> If the domain of a partial function is finite and x an element of the defined interval then
  there are neighbors of x such that x is between the neighbors (included). \<close>
lemma neighbors_dest:
  assumes "finite (dom p)"
  assumes "x \<in> defined_interval_of p"
  obtains x1 y1 x2 y2 where "neighbors p x = (x1, x2)"
    and "p x1 = Some y1" and "p x2 = Some y2" and "x1 \<le> x" and "x \<le> x2"
proof -
  obtain x1 x2 where "neighbors p x = (x1, x2)" by fastforce
  from assms(1) have "finite {x' \<in> dom p. x' \<le> x}" by auto
  from this have "Max {x' \<in> dom p. x' \<le> x} \<in> {x' \<in> dom p. x' \<le> x}"
    using defined_interval_of_Max_in assms(1, 2) by auto
  from this obtain y1 where "p x1 = Some y1"
    using \<open>neighbors p x = (x1, x2)\<close> unfolding neighbors_def by auto
  from assms(1) have "finite {x' \<in> dom p. x \<le> x'}" by auto
  from this have "Min {x' \<in> dom p. x \<le> x'} \<in> {x' \<in> dom p. x \<le> x'}"
    using defined_interval_of_Min_in assms(1, 2) by auto
  from this obtain y2 where "p x2 = Some y2"
    using \<open>neighbors p x = (x1, x2)\<close> unfolding neighbors_def by auto
  have "x1 \<le> x" and "x \<le> x2"
    using \<open>Max {x' \<in> dom p. x' \<le> x} \<in> {x' \<in> dom p. x' \<le> x}\<close>
    using \<open>Min {x' \<in> dom p. x \<le> x'} \<in> {x' \<in> dom p. x \<le> x'}\<close>
    using \<open>neighbors p x = (x1, x2)\<close> unfolding neighbors_def by auto
  from that show thesis
    using \<open>neighbors p x = (x1, x2)\<close> \<open>p x1 = Some y1\<close> \<open>p x2 = Some y2\<close> \<open>x1 \<le> x\<close> \<open>x \<le> x2\<close> by blast
qed

subsection \<open>Boundedness\<close>

text \<open> The linear approximation of a partial function with finite domain is limited by the maximum of
  the values of the partial function from above. \<close>
lemma upper_bound:
  assumes "finite (dom p)"
  assumes "x \<in> defined_interval_of p"
  shows "linear_interpolation p x \<le> Max (ran p)"
proof -
  have "finite (ran p)"
    using assms(1) by (simp add: finite_ran)
  from assms obtain x1 y1 x2 y2 where
    "neighbors p x = (x1, x2)" and "p x1 = Some y1" and "p x2 = Some y2"
    and "x1 \<le> x" and "x \<le> x2"
    using neighbors_dest[of p x] by metis
  from this have "linear_interpolation p x = linear (x1, y1) (x2, y2) x"
    unfolding linear_interpolation_def by simp
  also have "\<dots> \<le> max y1 y2"
    using \<open>x1 \<le> x\<close> \<open>x \<le> x2\<close> by (simp add: linear_upper_bound)
  also have "\<dots> \<le> Max (ran p)"
    using Max_ge \<open>finite (ran p)\<close> \<open>p x1 = Some y1\<close> \<open>p x2 = Some y2\<close> ranI by fastforce
  finally show ?thesis .
qed

text \<open> The linear approximation of a partial function with finite domain is limited by the minimum of
  the values of the partial function from below. \<close>
lemma lower_bound:
  assumes "finite (dom p)"
  assumes "x \<in> defined_interval_of p"
  shows "Min (ran p) \<le> linear_interpolation p x"
proof -
  have "finite (ran p)"
    using assms(1) by (simp add: finite_ran)
  from assms obtain x1 y1 x2 y2 where
    "neighbors p x = (x1, x2)" and "p x1 = Some y1" and "p x2 = Some y2"
    and "x1 \<le> x" and "x \<le> x2"
    using neighbors_dest[of p x] by metis
  have "Min (ran p) \<le> min y1 y2"
    using Min_le \<open>finite (ran p)\<close> \<open>p x1 = Some y1\<close> \<open>p x2 = Some y2\<close> ranI by fastforce
  also have "\<dots> \<le> linear (x1, y1) (x2, y2) x"
    using \<open>x1 \<le> x\<close> \<open>x \<le> x2\<close> by (simp add: linear_lower_bound)
  also have "\<dots> = linear_interpolation p x"
    unfolding linear_interpolation_def
    using \<open>neighbors p x = (x1, x2)\<close> \<open>p x1 = Some y1\<close> \<open>p x2 = Some y2\<close> by simp
  finally show ?thesis .
qed

subsection \<open>Monotonicity\<close>

text \<open> If a partial function has finite domain and is (weakly) monotonically increasing for the values
  where it is defined, then its linear approximation is (weakly) monotonically increasing.\<close>
lemma linear_interpolation_monotonic:
  assumes "finite (dom p)"
  assumes "x \<in> defined_interval_of p" "x' \<in> defined_interval_of p"
  assumes "\<forall>x x' y y'. x \<le> x' \<and> p x = Some y \<and> p x' = Some y' \<longrightarrow> y \<le> y'"
  assumes "x \<le> x'"
  shows "linear_interpolation p x \<le> linear_interpolation p x'"
proof -
  from assms(1,2,5) obtain x1 y1 x2 y2
    where neighbors_x: "neighbors p x = (x1, x2)" "p x1 = Some y1" "p x2 = Some y2"
    and "x1 \<le> x" and "x \<le> x2"
    using neighbors_dest[of p x] by metis
  from assms(1,3,5) obtain x1' y1' x2' y2'
    where neighbors_x': "neighbors p x' = (x1', x2')" "p x1' = Some y1'" "p x2' = Some y2'"
    and "x1' \<le> x'" and "x' \<le> x2'"
    using neighbors_dest[of p x'] by metis
  have "max y1 y2 = y2"
    using \<open>x \<le> x2\<close> \<open>x1 \<le> x\<close> assms(4) neighbors_x(2) neighbors_x(3)
    by (meson dual_order.trans max_absorb2)
  have "min y1' y2' = y1'"
    using \<open>x' \<le> x2'\<close> \<open>x1' \<le> x'\<close> assms(4) neighbors_x'(2) neighbors_x'(3)
    by (metis dual_order.trans min.order_iff)
  from \<open>x \<le> x'\<close> have "(x1 = x1' \<and> x2 = x2') \<or> x2 \<le> x1'"
    using neighbors_cases[OF assms(1, 2, 3)]
    by (simp add: neighbors_x'(1) neighbors_x(1))
  from neighbors_x have "linear_interpolation p x = linear (x1, y1) (x2, y2) x"
    unfolding linear_interpolation_def by simp
  also from \<open>_ \<or> _\<close> have "linear (x1, y1) (x2, y2) x \<le> linear (x1', y1') (x2', y2') x'"
  proof
    assume a: "x1 = x1' \<and> x2 = x2'"
    from this have b: "y1 = y1' \<and> y2 = y2'"
      using neighbors_x'(2) neighbors_x'(3) neighbors_x(2) neighbors_x(3) by auto
    from \<open>max y1 y2 = y2\<close> have "y1 \<le> y2" by simp
    from a b this \<open>x \<le> x2\<close> \<open>x1 \<le> x\<close> \<open>x' \<le> x2'\<close> show ?thesis
      using linear_monotonic assms(5) by (metis (no_types, lifting) dual_order.trans eq_iff not_le)
  next
    assume "x2 \<le> x1'"
    have "linear (x1, y1) (x2, y2) x \<le> y2"
      using \<open>max y1 y2 = y2\<close> by (metis \<open>x \<le> x2\<close> \<open>x1 \<le> x\<close> linear_upper_bound)
    also from \<open>x2 \<le> x1'\<close> have "y2 \<le> y1'"
      using \<open>p x1' = Some y1'\<close> \<open>p x2 = Some y2\<close> assms(4) by blast
    also have "y1' \<le> linear (x1', y1') (x2', y2') x'"
      using \<open>x' \<le> x2'\<close> \<open>x1' \<le> x'\<close> \<open>min y1' y2' = y1'\<close> by (metis linear_lower_bound)
    finally show ?thesis .
  qed
  also have "linear (x1', y1') (x2', y2') x' = linear_interpolation p x'"
    unfolding linear_interpolation_def
    using neighbors_x' by simp
  finally show ?thesis .
qed

subsection \<open>Scalar multiplication\<close>

text \<open> Multiplying a partial function by a scalar does not change the neighbors. \<close>
lemma neighbors_scale_invariant:
   "neighbors (\<lambda>x. map_option (\<lambda>y. (c * y)) (p x)) x = neighbors p x"
  unfolding neighbors_def by (simp add: domIff)

text \<open> Linear approximation of a partial function is linear with respect to multiplication. \<close>
lemma linear_interpolation_scale:
  assumes "finite (dom p)"
  assumes "x \<in> defined_interval_of p"
  shows "linear_interpolation (\<lambda>x. map_option (\<lambda>y. c * y) (p x)) x = c * linear_interpolation p x"
proof -
  obtain x1 y1 x2 y2 where "neighbors p x = (x1, x2)" and "p x1 = Some y1" and "p x2 = Some y2"
    using assms neighbors_dest[of p x] by (metis (no_types, lifting))
  have "linear_interpolation (\<lambda>x. map_option (\<lambda>y. c * y) (p x)) x = linear (x1, c * the (p x1)) (x2, c * the (p x2)) x"
    using \<open>neighbors p x = (x1, x2)\<close> \<open>p x1 = Some y1\<close> \<open>p x2 = Some y2\<close>
    unfolding linear_interpolation_def by (simp add: neighbors_scale_invariant)
  also have "\<dots> = c * linear_interpolation p x"
    unfolding linear_interpolation_def
    using \<open>neighbors p x = (x1, x2)\<close> by (simp add: linear_scale)
  finally show ?thesis .
qed

subsection \<open>Lipschitz\<close>

text \<open> If for a partial function p there is no defined value between x and x' then
  the neighbors of x and x' are the same. \<close>
lemma neighbors_eq:
  assumes "x \<le> x'"
  assumes "\<forall>x''. x \<le> x'' \<and> x'' \<le> x' \<longrightarrow> p x'' = None"
  shows "neighbors p x = neighbors p x'"
proof -
  have "{x'' \<in> dom p. x'' \<le> x} = {x'' \<in> dom p. x'' \<le> x'}"
    using \<open>x \<le> x'\<close> \<open>\<forall>x''. x \<le> x'' \<and> x'' \<le> x' \<longrightarrow> p x'' = None\<close> linear by force
  moreover have "{x'' \<in> dom p. x \<le> x''} = {x'' \<in> dom p. x' \<le> x''}"
    using \<open>x \<le> x'\<close> \<open>\<forall>x''. x \<le> x'' \<and> x'' \<le> x' \<longrightarrow> p x'' = None\<close> by auto
  ultimately show ?thesis
    unfolding neighbors_def by simp
qed

text \<open> For a partial function with finite domain, the neighbors of a defined value are the point itself. \<close>
lemma defined_point_neighbors_eq:
  assumes "finite (dom p)"
  assumes "x \<in> dom p"
  shows "neighbors p x = (x, x)"
proof -
  from assms have "Max {x' \<in> dom p. x' \<le> x} = x"
    by (metis (mono_tags, lifting) Max_eqI infinite_super mem_Collect_eq order_refl subsetI)
  moreover from assms have "Min {x' \<in> dom p. x \<le> x'} = x"
    by (metis (mono_tags, lifting) Min_eqI infinite_super mem_Collect_eq order_refl subsetI)
  ultimately show ?thesis
    unfolding neighbors_def by auto
qed

text \<open> finite' defines in an inductive way on ordered sets, starting from the empty set inserting
  elements smaller than all elements to a set. \<close>
inductive finite'
where
  "finite' {}"
| "finite' A \<Longrightarrow> a \<notin> A \<Longrightarrow> a < Min A \<or> A = {} \<Longrightarrow> finite' (insert a A)"

text \<open> On sets with a linear order the concept finite' is equivalent to the standard finite concept.\<close>
thm finite'.induct
lemma finite_eq_finite':
  fixes X :: "('a :: linorder) set"
  shows "finite X \<longleftrightarrow> finite' X"
proof
  show "finite X" if "finite' X"
    using that by (induct rule: finite'.induct) auto
  find_theorems "finite" name: induct
  thm finite_remove_induct
  show "finite' X" if "finite X" using that
  proof (induct rule: finite_remove_induct)
    show "finite' {}" by (rule finite'.intros)
  next
    case (remove A)
    let ?a' = "Min A"
    let ?A' = "A - {?a'}"
    from \<open>finite A\<close> \<open>A \<noteq> {}\<close> have "?a' \<in> A" by simp
    from \<open>?a' \<in> A\<close> have "insert ?a' ?A' = A" by auto
    from \<open>?a' \<in> A\<close> remove(4) have "finite' ?A'" by simp
    moreover have "?a' \<notin> ?A'" by blast
    moreover have "?a' < Min ?A' \<or> ?A' = {}"
      by (metis Min.remove Min_in \<open>Min A \<in> A\<close> calculation(2) finite_Diff min.strict_order_iff remove.hyps(1))
    ultimately have "finite' (insert ?a' ?A')" by (rule finite'.intros)
    from this \<open>insert ?a' ?A' = A\<close> show ?case by simp
  qed
qed

text \<open> On finite sets with minima, there is an induction principle based on adding elements smaller
   than the minimum. \<close>
lemma finite_Min_induct [consumes 1, case_names empty insert]:
  "finite X \<Longrightarrow> P {} \<Longrightarrow> (\<And>A a. finite A \<Longrightarrow> P A \<Longrightarrow> a \<notin> A \<Longrightarrow> a < Min A \<or> A = {} \<Longrightarrow> P (insert a A)) \<Longrightarrow> P X"
unfolding finite_eq_finite' by (rule finite'.induct)

text \<open> If a property holds for a two place partial function in all four cases depending on whether
  the arguments are in the domain or not, the property holds in general. \<close>
lemma four_cases:
  assumes "x \<in> dom p \<and> x' \<in> dom p \<Longrightarrow> P p x x'"
  assumes "x \<in> dom p \<and> x' \<notin> dom p \<Longrightarrow> P p x x'"
  assumes "x \<notin> dom p \<and> x' \<in> dom p \<Longrightarrow> P p x x'"
  assumes "x \<notin> dom p \<and> x' \<notin> dom p \<Longrightarrow> P p x x'"
  shows "P p x x'"
using assms(1) assms(2) assms(3) assms(4) by blast

text \<open> The linear approximation of a partial function p is Lipschitz continuous in case that there is
  no defined element between x and x'. \<close>
lemma empty_case:
  assumes "finite (dom p)"
  assumes "x \<in> defined_interval_of p"
  assumes "x' \<in> defined_interval_of p"
  assumes "x \<le> x'"
  assumes "\<forall>x''. x < x'' \<and> x'' < x' \<longrightarrow> p x'' = None"
  shows "\<exists>K. \<bar>linear_interpolation p x' - linear_interpolation p x\<bar> \<le> K * \<bar>x' - x\<bar>"
proof cases
  assume "x = x'"
  from this show ?thesis by simp
next
  assume "x \<noteq> x'"
  text \<open> cases: TODO: check if we can reduce it to at most two cases, when we look at the larger proof!
     and hence refine the assumption! \<close>
  show ?thesis
  proof (rule four_cases[of x p x'])
    assume a: "x \<in> dom p \<and> x' \<in> dom p"
    from this \<open>finite _\<close> have 1: "neighbors p x = (x, x)"
      by (simp add: defined_point_neighbors_eq)
    from a \<open>finite _\<close> have "neighbors p x' = (x', x')"
      by (simp add: defined_point_neighbors_eq)
    from 1 this show ?thesis
      unfolding linear_interpolation_def apply simp
      apply (simp add: linear_first)
      by (metis abs_ge_self abs_minus_commute abs_of_nonneg assms(4) diff_ge_0_iff_ge mult.commute nonzero_mult_div_cancel_left right_minus_eq times_divide_eq_right)
  next
    assume "x \<in> dom p \<and> x' \<notin> dom p"
    from assms obtain x1 y1 x2 y2 where
      n: "neighbors p x' = (x1, x2)" and 1: "p x1 = Some y1" and 2: "p x2 = Some y2"
      and "x1 \<le> x'" and "x' \<le> x2"
      using neighbors_dest[of p x'] by metis
    have "x = x1"
      using \<open>x \<in> dom p \<and> x' \<notin> dom p\<close> assms
      by (smt "1" \<open>x1 \<le> x'\<close> defined_point_neighbors_eq domI domIff n neighbors_cases prod.sel(1) prod.sel(2))
    from this n 1 2 \<open>x \<in> dom p \<and> _\<close> \<open>finite _\<close> show ?thesis
      unfolding linear_interpolation_def
      apply (simp add: defined_point_neighbors_eq linear_first)
      by (metis (no_types, hide_lams) abs_eq_0 add_diff_cancel_left' cancel_comm_monoid_add_class.diff_cancel diff_diff_eq2 mult.commute nonzero_mult_div_cancel_left order_refl times_divide_eq_right)
  next
    assume "x \<notin> dom p \<and> x' \<in> dom p"
    from assms obtain x1 y1 x2 y2 where
      n: "neighbors p x = (x1, x2)" and 1: "p x1 = Some y1" and 2: "p x2 = Some y2"
      and "x1 \<le> x" and "x \<le> x2"
      using neighbors_dest[of p x] by metis
    have "x' = x2"
      by (smt \<open>x \<notin> dom p \<and> x' \<in> dom p\<close> assms defined_point_neighbors_eq domI domIff fst_conv n neighbors_cases neighbors_dest snd_conv)
    from this n 1 2 \<open>_ \<and> _\<close> \<open>finite _\<close> show ?thesis
      unfolding linear_interpolation_def
      apply (simp add: defined_point_neighbors_eq linear_first)
      by (metis (no_types, hide_lams) abs_eq_0 add_diff_cancel_left' cancel_comm_monoid_add_class.diff_cancel diff_diff_eq2 mult.commute nonzero_mult_div_cancel_left order_refl times_divide_eq_right)
  next
    assume a: "x \<notin> dom p \<and> x' \<notin> dom p"
    from assms obtain x1 y1 x2 y2 where
      "neighbors p x = (x1, x2)" and "p x1 = Some y1" and "p x2 = Some y2"
      and "x1 \<le> x" and "x \<le> x2"
      using neighbors_dest[of p x] by metis
    have n: "neighbors p x' = (x1, x2)"
      using neighbors_eq assms(5) a
      by (metis \<open>neighbors p x = (x1, x2)\<close> assms(4) domIff less_eq_real_def)
    from this have "x' \<le> x2"
      using assms(1) assms(3) n neighbors_dest by force
    from \<open>x \<noteq> x'\<close> \<open>x1 \<le> x\<close> \<open>x \<le> x'\<close> \<open>x' \<le> x2\<close> have "x1 < x2" by linarith
    have "linear_interpolation p x = linear (x1, y1) (x2, y2) x"
      using \<open>neighbors p x = (x1, x2)\<close> \<open>p x1 = _\<close> \<open>p x2 = _\<close>
      unfolding linear_interpolation_def by simp
    moreover have "linear_interpolation p x' = linear (x1, y1) (x2, y2) x'"
    proof -
      from n \<open>p x1 = _\<close> \<open>p x2 = _\<close> show ?thesis
        unfolding linear_interpolation_def apply auto done
    qed
    ultimately show "\<exists>K. \<bar>linear_interpolation p x' - linear_interpolation p x\<bar> \<le> K * \<bar>x' - x\<bar>"
      by (metis linear_Lipschitz order_refl)
  qed
qed

text \<open> The linear approximation of a partial function with finite domain is Lipschitz continuous on
  the defined interval. \<close>
lemma linear_interpolation_Lipschitz:
  assumes "finite (dom p)"
  assumes "x \<in> defined_interval_of p" "x' \<in> defined_interval_of p"
  shows "\<exists>K. abs (linear_interpolation p x' - linear_interpolation p x) \<le> K * abs (x' - x)"
proof -
  { fix x x' :: real
  (*assume with loss of generality *)
    assume "x \<le> x'"
  assume "x \<in> defined_interval_of p"
  assume "x' \<in> defined_interval_of p"
  have "finite {x''. \<exists>y. p x'' = Some y \<and> x < x'' \<and> x'' \<le> x'}"
    using \<open>finite (dom p)\<close>
    by (simp add: dom_def)
  { fix A
    have "finite A \<Longrightarrow> x \<le> x' \<Longrightarrow> x \<in> defined_interval_of p \<Longrightarrow> {x''. \<exists>y. p x'' = Some y \<and> x < x'' \<and> x'' \<le> x'} = A \<longrightarrow>
      (\<exists>K. abs (linear_interpolation p x' - linear_interpolation p x) \<le> K * abs (x' - x))"
    proof (induct A arbitrary: x rule: finite_Min_induct)
      case empty
      {
        assume "{x''. \<exists>y. p x'' = Some y \<and> x < x'' \<and> x'' \<le> x'} = {}"
        from this have "\<forall>x''. x < x'' \<and> x'' \<le> x' \<longrightarrow> p x'' = None" by auto
        from this have "\<exists>K. \<bar>linear_interpolation p x' - linear_interpolation p x\<bar> \<le> K * \<bar>x' - x\<bar>"
          using \<open>x \<le> x'\<close> empty_case \<open>finite (dom p)\<close> \<open>x \<in> defined_interval_of p\<close> \<open>x' \<in> defined_interval_of p\<close>
          by simp
      }
      then show ?case by auto
    next
      case (insert A a)
      {
        assume a: "{x''. \<exists>y. p x'' = Some y \<and> x < x'' \<and> x'' \<le> x'} = insert a A"
        from this have "x < a" and "a \<le> x'" by blast+
        have "a \<in> defined_interval_of p"
          using \<open>a \<le> x'\<close> \<open>x < a\<close> \<open>x' \<in> defined_interval_of p\<close> defined_interval_of_def insert.prems(2) by auto
        have "{x''. \<exists>y. p x'' = Some y \<and> a < x'' \<and> x'' \<le> x'} = A"
          using insert.hyps(1,3,4) a \<open>x < a\<close> Min.coboundedI by fastforce
        (* possible improvement: replace linear_interpolation p by an local abbreviation for shorter proofs *)
        from insert.hyps(2) \<open>a \<le> x'\<close> \<open>a \<in> _\<close> this obtain K where
          1: "\<bar>linear_interpolation p x' - linear_interpolation p a\<bar> \<le> K * \<bar>x' - a\<bar>" by auto
        have "{x''. \<exists>y. p x'' = Some y \<and> x < x'' \<and> x'' < a} = {}"
        proof -
          have "p x'' = None" if "x < x'' \<and> x'' < a" for x''
          proof (rule ccontr)
            assume "p x'' \<noteq> None"
            from this have "x'' \<in> insert a A"
              using \<open>a \<le> x'\<close> a that by fastforce
            from this that show False
              using insert.hyps(1,3,4) Min_gr_iff by fastforce
          qed
          from this show ?thesis by auto
        qed
        from this have "\<forall>x''. x < x'' \<and> x'' < a \<longrightarrow> p x'' = None" by auto
        from this obtain K' where 2: "\<bar>linear_interpolation p a - linear_interpolation p x\<bar> \<le> K' * \<bar>a - x\<bar>"
          using empty_case \<open>x < a\<close> \<open>finite (dom p)\<close> \<open>x \<in> _\<close> \<open>a \<in> _\<close> by fastforce
        have "\<bar>linear_interpolation p x' - linear_interpolation p x\<bar> \<le>
          \<bar>linear_interpolation p x' - linear_interpolation p a\<bar> + \<bar>linear_interpolation p a - linear_interpolation p x\<bar>"
          by auto
        also have "\<dots> \<le> K * \<bar>x' - a\<bar> + K' * \<bar>a - x\<bar>" using 1 2 by simp
        also have "\<dots> \<le> max K K' * \<bar>x' - a\<bar> + max K K' * \<bar>a - x\<bar>"
          by (simp add: add_mono_thms_linordered_semiring(1) mult_le_cancel_right)
        also have "\<dots> \<le> max K K' * \<bar>x' - x\<bar>" (* todo: simpler proof or lemma *)
        proof -
          have f1: "\<bar>a - x'\<bar> = x' - a"
            by (simp add: \<open>a \<le> x'\<close>)
          have "\<bar>x' - x\<bar> = x' - x"
            by (simp add: insert.prems)
          then show ?thesis
            using f1
            by (metis (no_types) \<open>x < a\<close> abs_minus_commute abs_of_nonneg add.right_neutral add_diff_eq cancel_comm_monoid_add_class.diff_cancel diff_add_eq diff_ge_0_iff_ge distrib_left dual_order.strict_implies_order order_refl)
        qed
        finally have "\<exists>K. \<bar>linear_interpolation p x' - linear_interpolation p x\<bar> \<le> K * \<bar>x' - x\<bar>" by auto
      }
      then show ?case by auto
    qed
  }
  from this have "\<exists>K. \<bar>linear_interpolation p x' - linear_interpolation p x\<bar> \<le> K * \<bar>x' - x\<bar>"
    using \<open>finite {x''. \<exists>y. p x'' = Some y \<and> x < x'' \<and> x'' \<le> x'}\<close> \<open>x \<le> x'\<close> \<open>x \<in> _\<close> by blast
  } note derived_case = this
  show ?thesis
  proof cases
    assume "x \<le> x'"
    from this derived_case \<open>x \<in> _\<close> \<open>x' \<in> _\<close> show ?thesis by simp
  next
    assume "\<not> x \<le> x'"
    from this have "x' \<le> x" by simp
    from this derived_case[of x' x] \<open>x \<in> _\<close> \<open>x' \<in> _\<close> show ?thesis by (simp add: abs_minus_commute)
  qed
qed

lemma one_point_interpolation:
  assumes "finite (dom p)"
  assumes "x \<in> dom p"
  shows "linear_interpolation p x = the (p x)"
proof -
  have "neighbors p x = (x, x)"
    using defined_point_neighbors_eq assms by simp
  then show ?thesis
    by (simp add: linear_interpolation_def linear_first)
qed

end