(*  Author:     Steven Obua, TU Muenchen *)

section \<open>Various algebraic structures combined with a lattice\<close>

theory Lattice_Algebras
  imports Complex_MainRLT
begin

class semilattice_inf_ab_group_add = ordered_ab_group_add + semilattice_inf
begin

lemma add_inf_distrib_left: "a + inf b c = inf (a + b) (a + c)"
  apply (rule order.antisym)
   apply (simp_all add: le_infI)
  apply (rule add_le_imp_le_left [of "uminus a"])
  apply (simp only: add.assoc [symmetric], simp add: diff_le_eq add.commute)
  done

lemma add_inf_distrib_right: "inf a b + c = inf (a + c) (b + c)"
proof -
  have "c + inf a b = inf (c + a) (c + b)"
    by (simp add: add_inf_distrib_left)
  then show ?thesis
    by (simp add: add.commute)
qed

end

class semilattice_sup_ab_group_add = ordered_ab_group_add + semilattice_sup
begin

lemma add_sup_distrib_left: "a + sup b c = sup (a + b) (a + c)"
  apply (rule order.antisym)
   apply (rule add_le_imp_le_left [of "uminus a"])
   apply (simp only: add.assoc [symmetric], simp)
   apply (simp add: le_diff_eq add.commute)
  apply (rule le_supI)
   apply (rule add_le_imp_le_left [of "a"], simp only: add.assoc[symmetric], simp)+
  done

lemma add_sup_distrib_right: "sup a b + c = sup (a + c) (b + c)"
proof -
  have "c + sup a b = sup (c+a) (c+b)"
    by (simp add: add_sup_distrib_left)
  then show ?thesis
    by (simp add: add.commute)
qed

end

class lattice_ab_group_add = ordered_ab_group_add + lattice
begin

subclass semilattice_inf_ab_group_add ..
subclass semilattice_sup_ab_group_add ..

lemmas add_sup_inf_distribs =
  add_inf_distrib_right add_inf_distrib_left add_sup_distrib_right add_sup_distrib_left

lemma inf_eq_neg_sup: "inf a b = - sup (- a) (- b)"
proof (rule inf_unique)
  fix a b c :: 'a
  show "- sup (- a) (- b) \<le> a"
    by (rule add_le_imp_le_right [of _ "sup (uminus a) (uminus b)"])
      (simp, simp add: add_sup_distrib_left)
  show "- sup (-a) (-b) \<le> b"
    by (rule add_le_imp_le_right [of _ "sup (uminus a) (uminus b)"])
      (simp, simp add: add_sup_distrib_left)
  assume "a \<le> b" "a \<le> c"
  then show "a \<le> - sup (-b) (-c)"
    by (subst neg_le_iff_le [symmetric]) (simp add: le_supI)
qed

lemma sup_eq_neg_inf: "sup a b = - inf (- a) (- b)"
proof (rule sup_unique)
  fix a b c :: 'a
  show "a \<le> - inf (- a) (- b)"
    by (rule add_le_imp_le_right [of _ "inf (uminus a) (uminus b)"])
      (simp, simp add: add_inf_distrib_left)
  show "b \<le> - inf (- a) (- b)"
    by (rule add_le_imp_le_right [of _ "inf (uminus a) (uminus b)"])
      (simp, simp add: add_inf_distrib_left)
  show "- inf (- a) (- b) \<le> c" if "a \<le> c" "b \<le> c"
    using that by (subst neg_le_iff_le [symmetric]) (simp add: le_infI)
qed

lemma neg_inf_eq_sup: "- inf a b = sup (- a) (- b)"
  by (simp add: inf_eq_neg_sup)

lemma diff_inf_eq_sup: "a - inf b c = a + sup (- b) (- c)"
  using neg_inf_eq_sup [of b c, symmetric] by simp

lemma neg_sup_eq_inf: "- sup a b = inf (- a) (- b)"
  by (simp add: sup_eq_neg_inf)

lemma diff_sup_eq_inf: "a - sup b c = a + inf (- b) (- c)"
  using neg_sup_eq_inf [of b c, symmetric] by simp

lemma add_eq_inf_sup: "a + b = sup a b + inf a b"
proof -
  have "0 = - inf 0 (a - b) + inf (a - b) 0"
    by (simp add: inf_commute)
  then have "0 = sup 0 (b - a) + inf (a - b) 0"
    by (simp add: inf_eq_neg_sup)
  then have "0 = (- a + sup a b) + (inf a b + (- b))"
    by (simp only: add_sup_distrib_left add_inf_distrib_right) simp
  then show ?thesis
    by (simp add: algebra_simps)
qed

subsection \<open>Positive Part, Negative Part, Absolute Value\<close>

definition nprt :: "'a \<Rightarrow> 'a"
  where "nprt x = inf x 0"

definition pprt :: "'a \<Rightarrow> 'a"
  where "pprt x = sup x 0"

lemma pprt_neg: "pprt (- x) = - nprt x"
proof -
  have "sup (- x) 0 = sup (- x) (- 0)"
    by (simp only: minus_zero)
  also have "\<dots> = - inf x 0"
    by (simp only: neg_inf_eq_sup)
  finally have "sup (- x) 0 = - inf x 0" .
  then show ?thesis
    by (simp only: pprt_def nprt_def)
qed

lemma nprt_neg: "nprt (- x) = - pprt x"
proof -
  from pprt_neg have "pprt (- (- x)) = - nprt (- x)" .
  then have "pprt x = - nprt (- x)" by simp
  then show ?thesis by simp
qed

lemma prts: "a = pprt a + nprt a"
  by (simp add: pprt_def nprt_def flip: add_eq_inf_sup)

lemma zero_le_pprt[simp]: "0 \<le> pprt a"
  by (simp add: pprt_def)

lemma nprt_le_zero[simp]: "nprt a \<le> 0"
  by (simp add: nprt_def)

lemma le_eq_neg: "a \<le> - b \<longleftrightarrow> a + b \<le> 0"
  (is "?lhs = ?rhs")
proof
  assume ?lhs
  show ?rhs
    by (rule add_le_imp_le_right[of _ "uminus b" _]) (simp add: add.assoc \<open>?lhs\<close>)
next
  assume ?rhs
  show ?lhs
    by (rule add_le_imp_le_right[of _ "b" _]) (simp add: \<open>?rhs\<close>)
qed

lemma pprt_0[simp]: "pprt 0 = 0" by (simp add: pprt_def)
lemma nprt_0[simp]: "nprt 0 = 0" by (simp add: nprt_def)

lemma pprt_eq_id [simp, no_atp]: "0 \<le> x \<Longrightarrow> pprt x = x"
  by (simp add: pprt_def sup_absorb1)

lemma nprt_eq_id [simp, no_atp]: "x \<le> 0 \<Longrightarrow> nprt x = x"
  by (simp add: nprt_def inf_absorb1)

lemma pprt_eq_0 [simp, no_atp]: "x \<le> 0 \<Longrightarrow> pprt x = 0"
  by (simp add: pprt_def sup_absorb2)

lemma nprt_eq_0 [simp, no_atp]: "0 \<le> x \<Longrightarrow> nprt x = 0"
  by (simp add: nprt_def inf_absorb2)

lemma sup_0_imp_0:
  assumes "sup a (- a) = 0"
  shows "a = 0"
proof -
  have pos: "0 \<le> a" if "sup a (- a) = 0" for a :: 'a
  proof -
    from that have "sup a (- a) + a = a"
      by simp
    then have "sup (a + a) 0 = a"
      by (simp add: add_sup_distrib_right)
    then have "sup (a + a) 0 \<le> a"
      by simp
    then show ?thesis
      by (blast intro: order_trans inf_sup_ord)
  qed
  from assms have **: "sup (-a) (-(-a)) = 0"
    by (simp add: sup_commute)
  from pos[OF assms] pos[OF **] show "a = 0"
    by simp
qed

lemma inf_0_imp_0: "inf a (- a) = 0 \<Longrightarrow> a = 0"
  apply (simp add: inf_eq_neg_sup)
  apply (simp add: sup_commute)
  apply (erule sup_0_imp_0)
  done

lemma inf_0_eq_0 [simp, no_atp]: "inf a (- a) = 0 \<longleftrightarrow> a = 0"
  apply (rule iffI)
   apply (erule inf_0_imp_0)
  apply simp
  done

lemma sup_0_eq_0 [simp, no_atp]: "sup a (- a) = 0 \<longleftrightarrow> a = 0"
  apply (rule iffI)
   apply (erule sup_0_imp_0)
  apply simp
  done

lemma zero_le_double_add_iff_zero_le_single_add [simp]: "0 \<le> a + a \<longleftrightarrow> 0 \<le> a"
  (is "?lhs \<longleftrightarrow> ?rhs")
proof
  show ?rhs if ?lhs
  proof -
    from that have a: "inf (a + a) 0 = 0"
      by (simp add: inf_commute inf_absorb1)
    have "inf a 0 + inf a 0 = inf (inf (a + a) 0) a"  (is "?l = _")
      by (simp add: add_sup_inf_distribs inf_aci)
    then have "?l = 0 + inf a 0"
      by (simp add: a, simp add: inf_commute)
    then have "inf a 0 = 0"
      by (simp only: add_right_cancel)
    then show ?thesis
      unfolding le_iff_inf by (simp add: inf_commute)
  qed
  show ?lhs if ?rhs
    by (simp add: add_mono[OF that that, simplified])
qed

lemma double_zero [simp]: "a + a = 0 \<longleftrightarrow> a = 0"
  using add_nonneg_eq_0_iff order.eq_iff by auto

lemma zero_less_double_add_iff_zero_less_single_add [simp]: "0 < a + a \<longleftrightarrow> 0 < a"
  by (meson le_less_trans less_add_same_cancel2 less_le_not_le
      zero_le_double_add_iff_zero_le_single_add)

lemma double_add_le_zero_iff_single_add_le_zero [simp]: "a + a \<le> 0 \<longleftrightarrow> a \<le> 0"
proof -
  have "a + a \<le> 0 \<longleftrightarrow> 0 \<le> - (a + a)"
    by (subst le_minus_iff) simp
  moreover have "\<dots> \<longleftrightarrow> a \<le> 0"
    by (simp only: minus_add_distrib zero_le_double_add_iff_zero_le_single_add) simp
  ultimately show ?thesis
    by blast
qed

lemma double_add_less_zero_iff_single_less_zero [simp]: "a + a < 0 \<longleftrightarrow> a < 0"
proof -
  have "a + a < 0 \<longleftrightarrow> 0 < - (a + a)"
    by (subst less_minus_iff) simp
  moreover have "\<dots> \<longleftrightarrow> a < 0"
    by (simp only: minus_add_distrib zero_less_double_add_iff_zero_less_single_add) simp
  ultimately show ?thesis
    by blast
qed

declare neg_inf_eq_sup [simp]
  and neg_sup_eq_inf [simp]
  and diff_inf_eq_sup [simp]
  and diff_sup_eq_inf [simp]

lemma le_minus_self_iff: "a \<le> - a \<longleftrightarrow> a \<le> 0"
proof -
  from add_le_cancel_left [of "uminus a" "plus a a" zero]
  have "a \<le> - a \<longleftrightarrow> a + a \<le> 0"
    by (simp flip: add.assoc)
  then show ?thesis
    by simp
qed

lemma minus_le_self_iff: "- a \<le> a \<longleftrightarrow> 0 \<le> a"
proof -
  have "- a \<le> a \<longleftrightarrow> 0 \<le> a + a"
    using add_le_cancel_left [of "uminus a" zero "plus a a"]
    by (simp flip: add.assoc)
  then show ?thesis
    by simp
qed

lemma zero_le_iff_zero_nprt: "0 \<le> a \<longleftrightarrow> nprt a = 0"
  unfolding le_iff_inf by (simp add: nprt_def inf_commute)

lemma le_zero_iff_zero_pprt: "a \<le> 0 \<longleftrightarrow> pprt a = 0"
  unfolding le_iff_sup by (simp add: pprt_def sup_commute)

lemma le_zero_iff_pprt_id: "0 \<le> a \<longleftrightarrow> pprt a = a"
  unfolding le_iff_sup by (simp add: pprt_def sup_commute)

lemma zero_le_iff_nprt_id: "a \<le> 0 \<longleftrightarrow> nprt a = a"
  unfolding le_iff_inf by (simp add: nprt_def inf_commute)

lemma pprt_mono [simp, no_atp]: "a \<le> b \<Longrightarrow> pprt a \<le> pprt b"
  unfolding le_iff_sup by (simp add: pprt_def sup_aci sup_assoc [symmetric, of a])

lemma nprt_mono [simp, no_atp]: "a \<le> b \<Longrightarrow> nprt a \<le> nprt b"
  unfolding le_iff_inf by (simp add: nprt_def inf_aci inf_assoc [symmetric, of a])

end

lemmas add_sup_inf_distribs =
  add_inf_distrib_right add_inf_distrib_left add_sup_distrib_right add_sup_distrib_left

class lattice_ab_group_add_abs = lattice_ab_group_add + abs +
  assumes abs_lattice: "\<bar>a\<bar> = sup a (- a)"
begin

lemma abs_prts: "\<bar>a\<bar> = pprt a - nprt a"
proof -
  have "0 \<le> \<bar>a\<bar>"
  proof -
    have a: "a \<le> \<bar>a\<bar>" and b: "- a \<le> \<bar>a\<bar>"
      by (auto simp add: abs_lattice)
    show ?thesis
      by (rule add_mono [OF a b, simplified])
  qed
  then have "0 \<le> sup a (- a)"
    unfolding abs_lattice .
  then have "sup (sup a (- a)) 0 = sup a (- a)"
    by (rule sup_absorb1)
  then show ?thesis
    by (simp add: add_sup_inf_distribs ac_simps pprt_def nprt_def abs_lattice)
qed

subclass ordered_ab_group_add_abs
proof
  have abs_ge_zero [simp]: "0 \<le> \<bar>a\<bar>" for a
  proof -
    have a: "a \<le> \<bar>a\<bar>" and b: "- a \<le> \<bar>a\<bar>"
      by (auto simp add: abs_lattice)
    show "0 \<le> \<bar>a\<bar>"
      by (rule add_mono [OF a b, simplified])
  qed
  have abs_leI: "a \<le> b \<Longrightarrow> - a \<le> b \<Longrightarrow> \<bar>a\<bar> \<le> b" for a b
    by (simp add: abs_lattice le_supI)
  fix a b
  show "0 \<le> \<bar>a\<bar>"
    by simp
  show "a \<le> \<bar>a\<bar>"
    by (auto simp add: abs_lattice)
  show "\<bar>-a\<bar> = \<bar>a\<bar>"
    by (simp add: abs_lattice sup_commute)
  show "- a \<le> b \<Longrightarrow> \<bar>a\<bar> \<le> b" if "a \<le> b"
    using that by (rule abs_leI)
  show "\<bar>a + b\<bar> \<le> \<bar>a\<bar> + \<bar>b\<bar>"
  proof -
    have g: "\<bar>a\<bar> + \<bar>b\<bar> = sup (a + b) (sup (- a - b) (sup (- a + b) (a + (- b))))"
      (is "_ = sup ?m ?n")
      by (simp add: abs_lattice add_sup_inf_distribs ac_simps)
    have a: "a + b \<le> sup ?m ?n"
      by simp
    have b: "- a - b \<le> ?n"
      by simp
    have c: "?n \<le> sup ?m ?n"
      by simp
    from b c have d: "- a - b \<le> sup ?m ?n"
      by (rule order_trans)
    have e: "- a - b = - (a + b)"
      by simp
    from a d e have "\<bar>a + b\<bar> \<le> sup ?m ?n"
      apply -
      apply (drule abs_leI)
       apply (simp_all only: algebra_simps minus_add)
      apply (metis add_uminus_conv_diff d sup_commute uminus_add_conv_diff)
      done
    with g[symmetric] show ?thesis by simp
  qed
qed

end

lemma sup_eq_if:
  fixes a :: "'a::{lattice_ab_group_add,linorder}"
  shows "sup a (- a) = (if a < 0 then - a else a)"
  using add_le_cancel_right [of a a "- a", symmetric, simplified]
    and add_le_cancel_right [of "-a" a a, symmetric, simplified]
  by (auto simp: sup_max max.absorb1 max.absorb2)

lemma abs_if_lattice:
  fixes a :: "'a::{lattice_ab_group_add_abs,linorder}"
  shows "\<bar>a\<bar> = (if a < 0 then - a else a)"
  by auto

lemma estimate_by_abs:
  fixes a b c :: "'a::lattice_ab_group_add_abs"
  assumes "a + b \<le> c"
  shows "a \<le> c + \<bar>b\<bar>"
proof -
  from assms have "a \<le> c + (- b)"
    by (simp add: algebra_simps)
  have "- b \<le> \<bar>b\<bar>"
    by (rule abs_ge_minus_self)
  then have "c + (- b) \<le> c + \<bar>b\<bar>"
    by (rule add_left_mono)
  with \<open>a \<le> c + (- b)\<close> show ?thesis
    by (rule order_trans)
qed

class lattice_ring = ordered_ring + lattice_ab_group_add_abs
begin

subclass semilattice_inf_ab_group_add ..
subclass semilattice_sup_ab_group_add ..

end

lemma abs_le_mult:
  fixes a b :: "'a::lattice_ring"
  shows "\<bar>a * b\<bar> \<le> \<bar>a\<bar> * \<bar>b\<bar>"
proof -
  let ?x = "pprt a * pprt b - pprt a * nprt b - nprt a * pprt b + nprt a * nprt b"
  let ?y = "pprt a * pprt b + pprt a * nprt b + nprt a * pprt b + nprt a * nprt b"
  have a: "\<bar>a\<bar> * \<bar>b\<bar> = ?x"
    by (simp only: abs_prts[of a] abs_prts[of b] algebra_simps)
  have bh: "u = a \<Longrightarrow> v = b \<Longrightarrow>
            u * v = pprt a * pprt b + pprt a * nprt b +
                    nprt a * pprt b + nprt a * nprt b" for u v :: 'a
    apply (subst prts[of u], subst prts[of v])
    apply (simp add: algebra_simps)
    done
  note b = this[OF refl[of a] refl[of b]]
  have xy: "- ?x \<le> ?y"
    apply simp
    apply (metis (full_types) add_increasing add_uminus_conv_diff
      lattice_ab_group_add_class.minus_le_self_iff minus_add_distrib mult_nonneg_nonneg
      mult_nonpos_nonpos nprt_le_zero zero_le_pprt)
    done
  have yx: "?y \<le> ?x"
    apply simp
    apply (metis (full_types) add_nonpos_nonpos add_uminus_conv_diff
      lattice_ab_group_add_class.le_minus_self_iff minus_add_distrib mult_nonneg_nonpos
      mult_nonpos_nonneg nprt_le_zero zero_le_pprt)
    done
  have i1: "a * b \<le> \<bar>a\<bar> * \<bar>b\<bar>"
    by (simp only: a b yx)
  have i2: "- (\<bar>a\<bar> * \<bar>b\<bar>) \<le> a * b"
    by (simp only: a b xy)
  show ?thesis
    apply (rule abs_leI)
    apply (simp add: i1)
    apply (simp add: i2[simplified minus_le_iff])
    done
qed

instance lattice_ring \<subseteq> ordered_ring_abs
proof
  fix a b :: "'a::lattice_ring"
  assume a: "(0 \<le> a \<or> a \<le> 0) \<and> (0 \<le> b \<or> b \<le> 0)"
  show "\<bar>a * b\<bar> = \<bar>a\<bar> * \<bar>b\<bar>"
  proof -
    have s: "(0 \<le> a * b) \<or> (a * b \<le> 0)"
      apply auto
      apply (rule_tac split_mult_pos_le)
      apply (rule_tac contrapos_np[of "a * b \<le> 0"])
      apply simp
      apply (rule_tac split_mult_neg_le)
      using a
      apply blast
      done
    have mulprts: "a * b = (pprt a + nprt a) * (pprt b + nprt b)"
      by (simp flip: prts)
    show ?thesis
    proof (cases "0 \<le> a * b")
      case True
      then show ?thesis
        apply (simp_all add: mulprts abs_prts)
        using a
        apply (auto simp add:
          algebra_simps
          iffD1[OF zero_le_iff_zero_nprt] iffD1[OF le_zero_iff_zero_pprt]
          iffD1[OF le_zero_iff_pprt_id] iffD1[OF zero_le_iff_nprt_id])
        apply(drule (1) mult_nonneg_nonpos[of a b], simp)
        apply(drule (1) mult_nonneg_nonpos2[of b a], simp)
        done
    next
      case False
      with s have "a * b \<le> 0"
        by simp
      then show ?thesis
        apply (simp_all add: mulprts abs_prts)
        apply (insert a)
        apply (auto simp add: algebra_simps)
        apply(drule (1) mult_nonneg_nonneg[of a b],simp)
        apply(drule (1) mult_nonpos_nonpos[of a b],simp)
        done
    qed
  qed
qed

lemma mult_le_prts:
  fixes a b :: "'a::lattice_ring"
  assumes "a1 \<le> a"
    and "a \<le> a2"
    and "b1 \<le> b"
    and "b \<le> b2"
  shows "a * b \<le>
    pprt a2 * pprt b2 + pprt a1 * nprt b2 + nprt a2 * pprt b1 + nprt a1 * nprt b1"
proof -
  have "a * b = (pprt a + nprt a) * (pprt b + nprt b)"
    by (subst prts[symmetric])+ simp
  then have "a * b = pprt a * pprt b + pprt a * nprt b + nprt a * pprt b + nprt a * nprt b"
    by (simp add: algebra_simps)
  moreover have "pprt a * pprt b \<le> pprt a2 * pprt b2"
    by (simp_all add: assms mult_mono)
  moreover have "pprt a * nprt b \<le> pprt a1 * nprt b2"
  proof -
    have "pprt a * nprt b \<le> pprt a * nprt b2"
      by (simp add: mult_left_mono assms)
    moreover have "pprt a * nprt b2 \<le> pprt a1 * nprt b2"
      by (simp add: mult_right_mono_neg assms)
    ultimately show ?thesis
      by simp
  qed
  moreover have "nprt a * pprt b \<le> nprt a2 * pprt b1"
  proof -
    have "nprt a * pprt b \<le> nprt a2 * pprt b"
      by (simp add: mult_right_mono assms)
    moreover have "nprt a2 * pprt b \<le> nprt a2 * pprt b1"
      by (simp add: mult_left_mono_neg assms)
    ultimately show ?thesis
      by simp
  qed
  moreover have "nprt a * nprt b \<le> nprt a1 * nprt b1"
  proof -
    have "nprt a * nprt b \<le> nprt a * nprt b1"
      by (simp add: mult_left_mono_neg assms)
    moreover have "nprt a * nprt b1 \<le> nprt a1 * nprt b1"
      by (simp add: mult_right_mono_neg assms)
    ultimately show ?thesis
      by simp
  qed
  ultimately show ?thesis
    by - (rule add_mono | simp)+
qed

lemma mult_ge_prts:
  fixes a b :: "'a::lattice_ring"
  assumes "a1 \<le> a"
    and "a \<le> a2"
    and "b1 \<le> b"
    and "b \<le> b2"
  shows "a * b \<ge>
    nprt a1 * pprt b2 + nprt a2 * nprt b2 + pprt a1 * pprt b1 + pprt a2 * nprt b1"
proof -
  from assms have a1: "- a2 \<le> -a"
    by auto
  from assms have a2: "- a \<le> -a1"
    by auto
  from mult_le_prts[of "- a2" "- a" "- a1" "b1" b "b2",
    OF a1 a2 assms(3) assms(4), simplified nprt_neg pprt_neg]
  have le: "- (a * b) \<le>
    - nprt a1 * pprt b2 + - nprt a2 * nprt b2 +
    - pprt a1 * pprt b1 + - pprt a2 * nprt b1"
    by simp
  then have "- (- nprt a1 * pprt b2 + - nprt a2 * nprt b2 +
      - pprt a1 * pprt b1 + - pprt a2 * nprt b1) \<le> a * b"
    by (simp only: minus_le_iff)
  then show ?thesis
    by (simp add: algebra_simps)
qed

instance int :: lattice_ring
proof
  show "\<bar>k\<bar> = sup k (- k)" for k :: int
    by (auto simp add: sup_int_def)
qed

instance real :: lattice_ring
proof
  show "\<bar>a\<bar> = sup a (- a)" for a :: real
    by (auto simp add: sup_real_def)
qed

end


(*
    $Id: sol.thy,v 1.3 2011/06/28 18:11:38 webertj Exp $
    Author: Tjark Weber
*)

header {* Quantifying Lists *}

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

text {* Define a universal and an existential quantifier on lists
using primitive recursion.  Expression @{term "alls P xs"} should
be true iff @{term "P x"} holds for every element @{term x} of
@{term xs}, and @{term "exs P xs"} should be true iff @{term "P x"}
holds for some element @{term x} of @{term xs}.
*}

primrec alls :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool" where
  "alls P []     = True"
| "alls P (x#xs) = (P x \<and> alls P xs)"

primrec exs  :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool" where
  "exs P []     = False"
| "exs P (x#xs) = (P x \<or> exs P xs)"

text {*
Prove or disprove (by counterexample) the following theorems.
You may have to prove some lemmas first.

Use the @{text "[simp]"}-attribute only if the equation is truly a
simplification and is necessary for some later proof.
*}

lemma "alls (\<lambda>x. P x \<and> Q x) xs = (alls P xs \<and> alls Q xs)"
  apply (induct "xs")
  apply auto
done

lemma alls_append: "alls P (xs @ ys) = (alls P xs \<and> alls P ys)"
  apply (induct "xs")
  apply auto
done

lemma "alls P (rev xs) = alls P xs"
  apply (induct "xs")
  apply (auto simp add: alls_append)
done

lemma "exs (\<lambda>x. P x \<and> Q x) xs = (exs P xs \<and> exs Q xs)"
  quickcheck
oops

text {*
  A possible counterexample is:
  P = even, Q = odd, xs = [0, 1]
*}

lemma "exs P (map f xs) = exs (P o f) xs"
  apply (induct "xs")
  apply auto
done

lemma exs_append: "exs P (xs @ ys) = (exs P xs \<or> exs P ys)"
  apply (induct "xs")
  apply auto
done

lemma "exs P (rev xs) = exs P xs"
  apply (induct "xs")
  apply (auto simp add: exs_append)
done

text {* Find a (non-trivial) term @{text Z} such that the following equation holds: *}

lemma "exs (\<lambda>x. P x \<or> Q x) xs = Z"
(*<*)oops(*>*)

lemma "exs (\<lambda>x. P x \<or> Q x) xs = (exs P xs \<or> exs Q xs)"
  apply (induct "xs")
  apply auto
done

text {* Express the existential via the universal quantifier --
@{text exs} should not occur on the right-hand side: *}

lemma "exs P xs = Z"
(*<*)oops(*>*)

lemma "exs P xs = (\<not> alls (\<lambda>x. \<not> P x) xs)"
  apply (induct "xs")
  apply auto
done

text {*
Define a primitive-recursive function @{term "is_in x xs"} that
checks if @{term x} occurs in @{term xs}. Now express
@{text is_in} via @{term exs}:
*}

primrec is_in :: "'a \<Rightarrow> 'a list \<Rightarrow> bool" where
  "is_in x []     = False"
| "is_in x (z#zs) = (x=z \<or> is_in x zs)"

lemma "is_in a xs = exs (\<lambda>x. x=a) xs"
  apply (induct "xs")
  apply auto
done

text {* Define a primitive-recursive function @{term "nodups xs"}
that is true iff @{term xs} does not contain duplicates, and a
function @{term "deldups xs"} that removes all duplicates.  Note
that @{term "deldups[x,y,x]"} (where @{term x} and @{term y} are
distinct) can be either @{term "[x,y]"} or @{term "[y,x]"}.
*}

primrec nodups :: "'a list \<Rightarrow> bool" where
  "nodups []     = True"
| "nodups (x#xs) = (\<not> is_in x xs \<and> nodups xs)"

primrec deldups :: "'a list \<Rightarrow> 'a list" where
  "deldups []     = []"
| "deldups (x#xs) = (if is_in x xs then deldups xs else x # deldups xs)"

text {*
Prove or disprove (by counterexample) the following theorems.
*}

lemma "length (deldups xs) <= length xs"
  apply (induct "xs")
  apply auto
done

lemma is_in_deldups: "is_in a (deldups xs) = is_in a xs"
  apply (induct "xs")
  apply auto
done

lemma "nodups (deldups xs)"
  apply (induct "xs")
  apply (auto simp add: is_in_deldups)
done

lemma "deldups (rev xs) = rev (deldups xs)"
  quickcheck
oops

text {*
  A possible counterexample is:
  xs = [0, 1, 0]
*}

(*<*) end (*>*)


(*
    Author:      René Thiemann
                 Akihisa Yamada
    License:     BSD
*)
section \<open>Gram-Schmidt Orthogonalization\<close>

text \<open>
  This theory provides the Gram-Schmidt orthogonalization algorithm,
  that takes the conjugate operation into account. It works over fields
  like the rational, real, or complex numbers.
\<close>

theory Gram_Schmidt
imports
  VS_Connect
  Missing_VectorSpace
  Conjugate
begin

subsection \<open>Orthogonality with Conjugates\<close>

definition "corthogonal vs \<equiv>
    \<forall>i < length vs. \<forall>j < length vs. vs ! i \<bullet>c vs ! j = 0 \<longleftrightarrow> i \<noteq> j"

lemma corthogonalD[elim]:
  "corthogonal vs \<Longrightarrow> i < length vs \<Longrightarrow> j < length vs \<Longrightarrow>
   vs ! i \<bullet>c vs ! j = 0 \<longleftrightarrow> i \<noteq> j"
  unfolding corthogonal_def by auto

lemma corthogonalI[intro]:
  "(\<And>i j. i < length vs \<Longrightarrow> j < length vs \<Longrightarrow> vs ! i \<bullet>c vs ! j = 0 \<longleftrightarrow> i \<noteq> j) \<Longrightarrow>
   corthogonal vs"
  unfolding corthogonal_def by auto

lemma corthogonal_distinct: "corthogonal us \<Longrightarrow> distinct us"
proof (induct us)
  case (Cons u us)
    have "u \<notin> set us"
    proof
      assume "u : set us"
      then obtain j where uj: "u = us!j" and j: "j < length us"
        using in_set_conv_nth by metis
      hence j': "j+1 < length (u#us)" by auto
      have "u \<bullet>c us!j = 0"
        using corthogonalD[OF Cons(2) _ j',of 0] by auto
      hence "u \<bullet>c u = 0" using uj by simp
      thus False using corthogonalD[OF Cons(2),of 0 0] by auto
    qed
    moreover have "distinct us"
    proof (rule Cons(1),intro corthogonalI)
      fix i j assume "i < length (us)" "j < length (us)"
      hence len: "i+1 < length (u#us)" "j+1 < length (u#us)" by auto
      show "(us!i \<bullet>c us!j = 0) = (i\<noteq>j)"
        using corthogonalD[OF Cons(2) len] by simp
    qed
    ultimately show ?case by simp
qed simp

lemma corthogonal_sort:
  assumes dist': "distinct us'"
      and mem: "set us = set us'"
  shows "corthogonal us \<Longrightarrow> corthogonal us'"
proof
  assume orth: "corthogonal us"
  hence dist: "distinct us" using corthogonal_distinct by auto
  fix i' j' assume i': "i' < length us'" and j': "j' < length us'"
  obtain i where ii': "us!i = us'!i'" and i: "i < length us"
    using mem i' in_set_conv_nth by metis
  obtain j where jj': "us!j = us'!j'" and j: "j < length us"
    using mem j' in_set_conv_nth by metis
  from corthogonalD[OF orth i j]
  have "(us!i \<bullet>c us!j = 0) = (i \<noteq> j)".
  hence "(us'!i' \<bullet>c us'!j' = 0) = (i \<noteq> j)" using ii' jj' by auto
  also have "... = (us!i \<noteq> us!j)" using nth_eq_iff_index_eq dist i j by auto
  also have "... = (us'!i' \<noteq> us'!j')" using ii' jj' by auto
  also have "... = (i' \<noteq> j')" using nth_eq_iff_index_eq dist' i' j' by auto
  finally show "(us'!i' \<bullet>c us'!j' = 0) = (i' \<noteq> j')".
qed

subsection\<open>The Algorithm\<close>

fun adjuster :: "nat \<Rightarrow> 'a :: conjugatable_field vec \<Rightarrow> 'a vec list \<Rightarrow> 'a vec"
  where "adjuster n w [] = 0\<^sub>v n"
    |  "adjuster n w (u#us) = -(w \<bullet>c u)/(u \<bullet>c u) \<cdot>\<^sub>v u + adjuster n w us"

text \<open>
  The following formulation is easier to analyze,
  but outputs of the subroutine should be properly reversed.
\<close>

fun gram_schmidt_sub
  where "gram_schmidt_sub n us [] = us"
  | "gram_schmidt_sub n us (w # ws) =
     gram_schmidt_sub n ((adjuster n w us + w) # us) ws"

definition gram_schmidt :: "nat \<Rightarrow> 'a :: conjugatable_field vec list \<Rightarrow> 'a vec list"
  where "gram_schmidt n ws = rev (gram_schmidt_sub n [] ws)"

text \<open>
  The following formulation requires no reversal.
\<close>

fun gram_schmidt_sub2
  where "gram_schmidt_sub2 n us [] = []"
  | "gram_schmidt_sub2 n us (w # ws) =
     (let u = adjuster n w us + w in
      u # gram_schmidt_sub2 n (u # us) ws)"

lemma gram_schmidt_sub_eq:
  "rev (gram_schmidt_sub n us ws) = rev us @ gram_schmidt_sub2 n us ws"
  by (induct ws arbitrary:us, auto simp:Let_def)

lemma gram_schmidt_code[code]:
  "gram_schmidt n ws = gram_schmidt_sub2 n [] ws"
  unfolding gram_schmidt_def
  apply(subst gram_schmidt_sub_eq) by simp

subsection \<open>Properties of the Algorithms\<close>

locale cof_vec_space = vec_space f_ty for
  f_ty :: "'a :: conjugatable_ordered_field itself"
begin

lemma adjuster_finsum:
  assumes U: "set us \<subseteq> carrier_vec n"
    and dist: "distinct (us :: 'a vec list)"
  shows "adjuster n w us = finsum V (\<lambda>u. -(w \<bullet>c u)/(u \<bullet>c u) \<cdot>\<^sub>v u) (set us)"
  using assms
proof (induct us)
  case Cons show ?case unfolding set_simps
  by (subst finsum_insert[OF finite_set], insert Cons, auto)
qed simp

lemma adjuster_lincomb:
  assumes w: "(w :: 'a vec) : carrier_vec n"
    and us: "set (us :: 'a vec list) \<subseteq> carrier_vec n"
    and dist: "distinct us"
  shows "adjuster n w us = lincomb (\<lambda>u. -(w \<bullet>c u)/(u \<bullet>c u)) (set us)"
    (is "_ = lincomb ?a _")
  using us dist unfolding lincomb_def
proof (induct us)
  case (Cons u us)
    let ?f = "\<lambda>u. ?a u \<cdot>\<^sub>v u"
    have "?f : (set us) \<rightarrow> carrier_vec n" and "?f u : carrier_vec n" using w Cons by auto
    moreover have "u \<notin> set us" using Cons by auto
    ultimately show ?case
      unfolding adjuster.simps
      unfolding set_simps
      using finsum_insert[OF finite_set] Cons by auto
qed simp

lemma adjuster_in_span:
  assumes w: "(w :: 'a vec) : carrier_vec n"
    and us: "set (us :: 'a vec list) \<subseteq> carrier_vec n"
    and dist: "distinct us"
  shows "adjuster n w us : span (set us)"
  using adjuster_lincomb[OF assms]
  unfolding finite_span[OF finite_set us] by auto

lemma adjuster_carrier[simp]:
  assumes w: "(w :: 'a vec) : carrier_vec n"
    and us: "set (us :: 'a vec list) \<subseteq> carrier_vec n"
    and dist: "distinct us"
  shows "adjuster n w us : carrier_vec n"
  using adjuster_in_span span_closed assms by auto

lemma adjust_not_in_span:
  assumes w[simp]: "(w :: 'a vec) : carrier_vec n"
    and us: "set (us :: 'a vec list) \<subseteq> carrier_vec n"
    and dist: "distinct us"
    and ind: "w \<notin> span (set us)"
  shows "adjuster n w us + w \<notin> span (set us)"
  using span_add[OF us adjuster_in_span[OF w us dist] w]
  using comm_add_vec ind by auto

lemma adjust_not_mem:
  assumes w[simp]: "(w :: 'a vec) : carrier_vec n"
    and us: "set (us :: 'a vec list) \<subseteq> carrier_vec n"
    and dist: "distinct us"
    and ind: "w \<notin> span (set us)"
  shows "adjuster n w us + w \<notin> set us"
  using adjust_not_in_span[OF assms] span_mem[OF us] by auto

lemma adjust_in_span:
  assumes w[simp]: "(w :: 'a vec) : carrier_vec n"
    and us: "set (us :: 'a vec list) \<subseteq> carrier_vec n"
    and dist: "distinct us"
  shows "adjuster n w us + w : span (insert w (set us))" (is "?v + _ : span ?U")
proof -
  let ?a = "\<lambda>u. -(w \<bullet>c u)/(u \<bullet>c u)"
  have "?v = lincomb ?a (set us)" using adjuster_lincomb[OF assms].
  hence vU: "?v : span (set us)" unfolding finite_span[OF finite_set us] by auto
  hence v[simp]: "?v : carrier_vec n" using span_closed[OF us] by auto
  have vU': "?v : span ?U" using vU span_is_monotone[OF subset_insertI] by auto

  have "{w} \<subseteq> ?U" by simp
  from span_is_monotone[OF this]
  have wU': "w : span ?U" using span_self[OF w] by auto

  have "?U \<subseteq> carrier_vec n" using us w by simp
  from span_add[OF this wU' v] vU' comm_add_vec[OF w]
  show ?thesis by simp
qed

lemma adjust_not_lindep:
  assumes w[simp]: "(w :: 'a vec) : carrier_vec n"
    and us: "set (us :: 'a vec list) \<subseteq> carrier_vec n"
    and dist: "distinct us"
    and wus: "w \<notin> span (set us)"
    and ind: "~ lin_dep (set us)"
  shows "~ lin_dep (insert (adjuster n w us + w) (set us))"
    (is "~ _ (insert ?v _)")
proof -
  have v: "?v : carrier_vec n" using assms by auto
  have "?v \<notin> span (set us)"
    using adjust_not_in_span[OF w us dist wus]
    using comm_add_vec[OF adjuster_carrier[OF w us dist] w] by auto
  thus ?thesis
    using lin_dep_iff_in_span[OF us ind v] adjust_not_mem[OF w us dist wus] by auto
qed

lemma adjust_preserves_span:
  assumes w[simp]: "(w :: 'a vec) : carrier_vec n"
    and us: "set (us :: 'a vec list) \<subseteq> carrier_vec n"
    and dist: "distinct us"
  shows "w : span (set us) \<longleftrightarrow> adjuster n w us + w : span (set us)"
    (is "_ \<longleftrightarrow> ?v + _ : _")
proof -
  have "?v : span (set us)"
    using adjuster_lincomb[OF assms]
    unfolding finite_span[OF finite_set us] by auto
  hence [simp]: "?v : carrier_vec n" using span_closed[OF us] by auto
  show ?thesis
    using span_add[OF us adjuster_in_span[OF w us] w] comm_add_vec[OF w] dist
    by auto
qed

lemma in_span_adjust:
  assumes w[simp]: "(w :: 'a vec) : carrier_vec n"
    and us: "set (us :: 'a vec list) \<subseteq> carrier_vec n"
    and dist: "distinct us"
  shows "w : span (insert (adjuster n w us + w) (set us))"
    (is "_ : span (insert ?v _)")
proof -
  have v: "?v : carrier_vec n" using assms by auto
  have a[simp]: "adjuster n w us : carrier_vec n"
   and neg: "- adjuster n w us : carrier_vec n" using assms by auto
  hence vU: "insert ?v (set us) \<subseteq> carrier_vec n" using us by auto
  have aS: "adjuster n w us : span (insert ?v (set us))"
    using adjuster_in_span[OF w us] span_is_monotone[OF subset_insertI] dist
    by auto
  have negS: "- adjuster n w us : span (insert ?v (set us))"
    using span_neg[OF vU aS] us by simp
  have [simp]:"- adjuster n w us + (adjuster n w us + w) = w"
    unfolding a_assoc[OF neg a w,symmetric] by simp
  have "{?v} \<subseteq> insert ?v (set us)" by simp
  from span_is_monotone[OF this]
  have vS: "?v : span (insert ?v (set us))" using span_self[OF v] by auto
  thus ?thesis using span_add[OF vU negS v] by auto
qed

lemma adjust_zero:
  assumes U: "set (us :: 'a vec list) \<subseteq> carrier_vec n"
    and orth: "corthogonal us"
    and w[simp]: "w : carrier_vec n"
    and i: "i < length us"
  shows "(adjuster n w us + w) \<bullet>c us!i = 0"
proof -
  define u where "u = us!i"
  have u[simp]: "u : carrier_vec n" using i U u_def by auto
  hence cu[simp]: "conjugate u : carrier_vec n" by auto
  have uU: "u : set us" using i u_def by auto
  let ?g = "\<lambda>u'::'a vec. (-(w \<bullet>c u')/(u' \<bullet>c u') \<cdot>\<^sub>v u')"
  have g: "?g : set us \<rightarrow> carrier_vec n" using w U by auto
  hence carrier: "finsum V ?g (set us) : carrier_vec n" by simp
  let ?f = "\<lambda>u'. ?g u' \<bullet>c u"
  let ?U = "set us - {u}"
  { fix u' assume u': "(u'::'a vec) : carrier_vec n"
    have [simp]: "dim_vec u = n" by auto
    have "?f u' = (- (w \<bullet>c u') / (u' \<bullet>c u')) * (u' \<bullet>c u)"
      using scalar_prod_smult_left[of "u'" "conjugate u"]
      unfolding carrier_vecD[OF u] carrier_vecD[OF u'] by auto
  } note conv = this
  have "?f : ?U \<rightarrow> {0}"
  proof (intro Pi_I)
    fix u' assume u'Uu: "u' : set us - {u}"
    hence u'U: "u' : set us" by auto
    hence u'[simp]: "u' : carrier_vec n" using U by auto
    obtain j where j: "j < length us" and u'j: "u' = us ! j"
      using u'U in_set_conv_nth by metis
    have "i \<noteq> j" using u'Uu u'j u_def by auto
    hence "u' \<bullet>c u = 0"
      unfolding u'j using corthogonalD[OF orth j i] u_def by auto
    hence "?f u' = 0" using mult_zero_right conv[OF u'] by auto
    thus "?f u' : {0}" by auto
  qed
  hence "restrict ?f ?U = restrict (\<lambda>u. 0) ?U" by force
  hence "sum ?f ?U = sum (\<lambda>u. 0) ?U"
    by (intro R.finsum_restrict, auto)
  hence fU'0: "sum ?f ?U = 0" by auto
  have uU': "u \<notin> ?U" by auto
  have "set us = insert u ?U"
    using insert_Diff_single uU by auto
  hence "sum ?f (set us) = ?f u + sum ?f ?U"
    using R.finsum_insert[OF _ uU'] by auto
  also have "... = ?f u" using fU'0 by auto
  also have "... = - (w \<bullet>c u) / (u \<bullet>c u) * (u \<bullet>c u)"
    using conv[OF u] by auto
  finally have main: "sum ?f (set us) = - (w \<bullet>c u)"
    unfolding u_def
    by (simp add: i orth corthogonalD)
  show ?thesis
    unfolding u_def[symmetric]
    unfolding adjuster_finsum[OF U corthogonal_distinct[OF orth]]
    unfolding add_scalar_prod_distrib[OF carrier w cu]
    unfolding finsum_scalar_prod_sum[OF g cu]
    unfolding main
    unfolding comm_scalar_prod[OF cu w]
    using left_minus by auto
qed

lemma adjust_nonzero:
  assumes U: "set (us :: 'a vec list) \<subseteq> carrier_vec n"
    and dist: "distinct us"
    and w[simp]: "w : carrier_vec n"
    and wsU: "w \<notin> span (set us)"
  shows "adjuster n w us + w \<noteq> 0\<^sub>v n" (is "?a + _ \<noteq> _")
proof
  have [simp]: "?a : carrier_vec n" using U dist by auto
  have [simp]: "- ?a : carrier_vec n" by auto
  have [simp]: "?a + w : carrier_vec n" by auto
  assume "?a + w = 0\<^sub>v n"
  hence "- ?a = - ?a + (?a + w)" by auto
  also have "... = (- ?a + ?a) + w" apply(subst a_assoc) by auto
  also have "- ?a + ?a = 0\<^sub>v n" using r_neg[OF w] unfolding vec_neg[OF w] by auto
  finally have "- ?a = w" by auto
  moreover have "- ?a : span (set us)"
    using span_neg[OF U adjuster_in_span[OF w U dist]] by auto
  ultimately show "False" using wsU by auto
qed

lemma adjust_orthogonal:
  assumes U: "set (us :: 'a vec list) \<subseteq> carrier_vec n"
    and orth: "corthogonal us"
    and w[simp]: "w : carrier_vec n"
    and wsU: "w \<notin> span (set us)"
  shows "corthogonal ((adjuster n w us + w) # us)"
    (is "corthogonal (?aw # _)")
proof
  have dist: "distinct us" using corthogonal_distinct orth by auto
  have aw[simp]: "?aw : carrier_vec n" using U dist by auto
  note adjust_nonzero[OF U dist w] wsU
  hence aw0: "?aw \<bullet>c ?aw \<noteq> 0" using conjugate_square_eq_0_vec[OF aw] by auto
  fix i j assume i: "i < length (?aw # us)" and j: "j < length (?aw # us)"
  show "((?aw # us) ! i \<bullet>c (?aw # us) ! j = 0) = (i \<noteq> j)"
  proof (cases "i = 0")
    case True note i0 = this
      show ?thesis
      proof (cases "j = 0")
        case True show ?thesis unfolding True i0 using aw0 by auto
        next case False
          define j' where "j' = j-1"
          hence jfold: "j = j'+1" using False by auto
          hence j': "j' < length us" using j by auto
          show ?thesis unfolding i0 jfold
            using adjust_zero[OF U orth w j'] by auto
      qed
    next case False
      define i' where "i' = i-1"
      hence ifold: "i = i'+1" using False by auto
      hence i': "i' < length us" using i by auto
      have [simp]: "us ! i' : carrier_vec n" using U i' by auto
      hence cu': "conjugate (us ! i') : carrier_vec n" by auto
      show ?thesis
      proof (cases "j = 0")
        case True
          { assume "?aw \<bullet>c us ! i' = 0"
            hence "conjugate (?aw \<bullet>c us ! i') = 0" using conjugate_zero by auto
            hence "conjugate ?aw \<bullet> us ! i' = 0"
              using conjugate_sprod_vec[OF aw cu'] by auto
          }
          thus ?thesis unfolding True ifold
          using adjust_zero[OF U orth w i']
          by (subst comm_scalar_prod[of _ n], auto)
        next case False
          define j' where "j' = j-1"
          hence jfold: "j = j'+1" using False by auto
          hence j': "j' < length us" using j by auto
          show ?thesis
            unfolding ifold jfold
            using orth i' j' by (auto simp: corthogonalD)
     qed
  qed
qed

lemma gram_schmidt_sub_span:
  assumes w[simp]: "w : carrier_vec n"
    and us: "set us \<subseteq> carrier_vec n"
    and dist: "distinct us"
  shows "span (set ((adjuster n w us + w) # us)) = span (set (w # us))"
  (is "span (set (?v # _)) = span ?wU")
proof (cases "w : span (set us)")
  case True
    hence "?v : span (set us)"
      using adjust_preserves_span[OF assms] by auto
    thus ?thesis using already_in_span[OF us] True by auto next
  case False show ?thesis
    proof
      have wU: "?wU \<subseteq> carrier_vec n" using us by simp
      have vswU: "?v : span ?wU" using adjust_in_span[OF assms] by auto
      hence v: "?v : carrier_vec n" using span_closed[OF wU] by auto
      have wsvU: "w : span (insert ?v (set us))" using in_span_adjust[OF assms].
      show "span ?wU \<subseteq> span (set (?v # us))"
        using span_swap[OF finite_set us w False v wsvU] by auto
      have "?v \<notin> span (set us)"
        using False adjust_preserves_span[OF assms] by auto
      thus "span (set (?v # us)) \<subseteq> span ?wU"
        using span_swap[OF finite_set us v _ w] vswU by auto
    qed
qed

lemma gram_schmidt_sub_result:
  assumes "gram_schmidt_sub n us ws = us'"
    and "set ws \<subseteq> carrier_vec n"
    and "set us \<subseteq> carrier_vec n"
    and "distinct (us @ ws)"
    and "~ lin_dep (set (us @ ws))"
    and "corthogonal us"
  shows "set us' \<subseteq> carrier_vec n \<and>
         distinct us' \<and>
         corthogonal us' \<and>
         span (set (us @ ws)) = span (set us') \<and> length us' = length us + length ws"
  using assms
proof (induct ws arbitrary: us us')
case (Cons w ws)
  let ?v = "adjuster n w us"
  have wW[simp]: "set (w#ws) \<subseteq> carrier_vec n" using Cons by simp
  hence W[simp]: "set ws \<subseteq> carrier_vec n"
   and w[simp]: "w : carrier_vec n" by auto
  have U[simp]: "set us \<subseteq> carrier_vec n" using Cons by simp
  have UW: "set (us@ws) \<subseteq> carrier_vec n" by simp
  have wU: "set (w#us) \<subseteq> carrier_vec n" by simp
  have dist: "distinct (us @ w # ws)" using Cons by simp
  hence dist_U: "distinct us"
    and dist_W: "distinct ws"
    and dist_UW: "distinct (us @ ws)"
    and w_U: "w \<notin> set us"
    and w_W: "w \<notin> set ws"
    and w_UW: "w \<notin> set (us @ ws)" by auto
  have ind: "~ lin_dep (set (us @ w # ws))" using Cons by simp
  have ind_U: "~ lin_dep (set us)"
    and ind_W: "~ lin_dep (set ws)"
    and ind_wU: "~ lin_dep (insert w (set us))"
    and ind_UW: "~ lin_dep (set (us @ ws))"
    by (subst subset_li_is_li[OF ind];auto)+
  have corth: "corthogonal us" using Cons by simp
  have U'def: "gram_schmidt_sub n ((?v + w)#us) ws = us'" using Cons by simp

  have v: "?v : carrier_vec n" using dist_U by auto
  hence vw: "?v + w : carrier_vec n" by auto
  hence vwU: "set ((?v + w) # us) \<subseteq> carrier_vec n" by auto
  have vsU: "?v : span (set us)" using adjuster_in_span[OF w] dist by auto
  hence vsUW: "?v : span (set (us @ ws))"
    using span_is_monotone[of "set us" "set (us@ws)"] by auto
  have wsU: "w \<notin> span (set us)"
    using lin_dep_iff_in_span[OF U ind_U w w_U] ind_wU by auto
  hence vwU: "?v + w \<notin> span (set us)" using adjust_not_in_span[OF w U dist_U] by auto

  have "w \<notin> span (set (us@ws))" using lin_dep_iff_in_span[OF _ ind_UW] dist ind by auto
  hence span: "?v + w \<notin> span (set (us@ws))" using span_add[OF UW vsUW w] by auto
  hence vwUS: "?v + w \<notin> set (us @ ws)" using span_mem by auto
  hence ind2: "~ lin_dep (set (((?v + w) # us) @ ws))"
    using lin_dep_iff_in_span[OF UW ind_UW vw] span by auto

  have vwU: "set ((?v + w) # us) \<subseteq> carrier_vec n" using U w dist by auto
  have dist2: "distinct (((?v + w) # us) @ ws)" using dist vwUS by simp

  have orth2: "corthogonal ((adjuster n w us + w) # us)"
    using adjust_orthogonal[OF U corth w wsU].

  show ?case
    using Cons(1)[OF U'def W vwU dist2 ind2] orth2
    using span_Un[OF vwU wU gram_schmidt_sub_span[OF w U dist_U] W W] by auto

qed simp

lemma gram_schmidt_hd [simp]:
  assumes [simp]: "w : carrier_vec n" shows "hd (gram_schmidt n (w#ws)) = w"
  unfolding gram_schmidt_code by simp

theorem gram_schmidt_result:
  assumes ws: "set ws \<subseteq> carrier_vec n"
    and dist: "distinct ws"
    and ind: "~ lin_dep (set ws)"
    and us: "us = gram_schmidt n ws"
  shows "span (set ws) = span (set us)"
    and "corthogonal us"
    and "set us \<subseteq> carrier_vec n"
    and "length us = length ws"
    and "distinct us"
proof -
  have main: "gram_schmidt_sub n [] ws = rev us"
    using us unfolding gram_schmidt_def
    using gram_schmidt_sub_eq by auto
  have orth: "corthogonal []" by auto
  have "span (set ws) = span (set (rev us))"
   and orth2: "corthogonal (rev us)"
   and "set us \<subseteq> carrier_vec n"
   and "length us = length ws"
   and dist: "distinct us"
    using gram_schmidt_sub_result[OF main ws]
    by (auto simp: assms orth)
  thus "span (set ws) = span (set us)" by simp
  show "set us \<subseteq> carrier_vec n" by fact
  show "length us = length ws" by fact
  show "distinct us" by fact
  show "corthogonal us"
    using corthogonal_distinct[OF orth2] unfolding distinct_rev
    using corthogonal_sort[OF _ set_rev orth2] by auto
qed
end

end


section\<open>Lindelöf spaces\<close>

theory Lindelof_Spaces
imports T1_Spaces
begin

definition Lindelof_space where
  "Lindelof_space X \<equiv>
        \<forall>\<U>. (\<forall>U \<in> \<U>. openin X U) \<and> \<Union>\<U> = topspace X
            \<longrightarrow> (\<exists>\<V>. countable \<V> \<and> \<V> \<subseteq> \<U> \<and> \<Union>\<V> = topspace X)"

lemma Lindelof_spaceD:
  "\<lbrakk>Lindelof_space X; \<And>U. U \<in> \<U> \<Longrightarrow> openin X U; \<Union>\<U> = topspace X\<rbrakk>
  \<Longrightarrow> \<exists>\<V>. countable \<V> \<and> \<V> \<subseteq> \<U> \<and> \<Union>\<V> = topspace X"
  by (auto simp: Lindelof_space_def)

lemma Lindelof_space_alt:
   "Lindelof_space X \<longleftrightarrow>
        (\<forall>\<U>. (\<forall>U \<in> \<U>. openin X U) \<and> topspace X \<subseteq> \<Union>\<U>
             \<longrightarrow> (\<exists>\<V>. countable \<V> \<and> \<V> \<subseteq> \<U> \<and> topspace X \<subseteq> \<Union>\<V>))"
  unfolding Lindelof_space_def
  using openin_subset by fastforce

lemma compact_imp_Lindelof_space:
   "compact_space X \<Longrightarrow> Lindelof_space X"
  unfolding Lindelof_space_def compact_space
  by (meson uncountable_infinite)

lemma Lindelof_space_topspace_empty:
   "topspace X = {} \<Longrightarrow> Lindelof_space X"
  using compact_imp_Lindelof_space compact_space_topspace_empty by blast

lemma Lindelof_space_Union:
  assumes \<U>: "countable \<U>" and lin: "\<And>U. U \<in> \<U> \<Longrightarrow> Lindelof_space (subtopology X U)"
  shows "Lindelof_space (subtopology X (\<Union>\<U>))"
proof -
  have "\<exists>\<V>. countable \<V> \<and> \<V> \<subseteq> \<F> \<and> \<Union>\<U> \<inter> \<Union>\<V> = topspace X \<inter> \<Union>\<U>"
    if \<F>: "\<F> \<subseteq> Collect (openin X)" and UF: "\<Union>\<U> \<inter> \<Union>\<F> = topspace X \<inter> \<Union>\<U>"
    for \<F>
  proof -
    have "\<And>U. \<lbrakk>U \<in> \<U>; U \<inter> \<Union>\<F> = topspace X \<inter> U\<rbrakk>
               \<Longrightarrow> \<exists>\<V>. countable \<V> \<and> \<V> \<subseteq> \<F> \<and> U \<inter> \<Union>\<V> = topspace X \<inter> U"
      using lin \<F>
      unfolding Lindelof_space_def openin_subtopology_alt Ball_def subset_iff [symmetric]
      by (simp add: all_subset_image imp_conjL ex_countable_subset_image)
    then obtain g where g: "\<And>U. \<lbrakk>U \<in> \<U>; U \<inter> \<Union>\<F> = topspace X \<inter> U\<rbrakk>
                               \<Longrightarrow> countable (g U) \<and> (g U) \<subseteq> \<F> \<and> U \<inter> \<Union>(g U) = topspace X \<inter> U"
      by metis
    show ?thesis
    proof (intro exI conjI)
      show "countable (\<Union>(g ` \<U>))"
        using Int_commute UF g  by (fastforce intro: countable_UN [OF \<U>])
      show "\<Union>(g ` \<U>) \<subseteq> \<F>"
        using g UF by blast
      show "\<Union>\<U> \<inter> \<Union>(\<Union>(g ` \<U>)) = topspace X \<inter> \<Union>\<U>"
      proof
        show "\<Union>\<U> \<inter> \<Union>(\<Union>(g ` \<U>)) \<subseteq> topspace X \<inter> \<Union>\<U>"
          using g UF by blast
        show "topspace X \<inter> \<Union>\<U> \<subseteq> \<Union>\<U> \<inter> \<Union>(\<Union>(g ` \<U>))"
        proof clarsimp
          show "\<exists>y\<in>\<U>. \<exists>W\<in>g y. x \<in> W"
            if "x \<in> topspace X" "x \<in> V" "V \<in> \<U>" for x V
          proof -
            have "V \<inter> \<Union>\<F> = topspace X \<inter> V"
              using UF \<open>V \<in> \<U>\<close> by blast
            with that g [OF \<open>V \<in> \<U>\<close>]  show ?thesis by blast
          qed
        qed
      qed
    qed
  qed
  then show ?thesis
      unfolding Lindelof_space_def openin_subtopology_alt Ball_def subset_iff [symmetric]
      by (simp add: all_subset_image imp_conjL ex_countable_subset_image)
qed

lemma countable_imp_Lindelof_space:
  assumes "countable(topspace X)"
  shows "Lindelof_space X"
proof -
  have "Lindelof_space (subtopology X (\<Union>x \<in> topspace X. {x}))"
  proof (rule Lindelof_space_Union)
    show "countable ((\<lambda>x. {x}) ` topspace X)"
      using assms by blast
    show "Lindelof_space (subtopology X U)"
      if "U \<in> (\<lambda>x. {x}) ` topspace X" for U
    proof -
      have "compactin X U"
        using that by force
      then show ?thesis
        by (meson compact_imp_Lindelof_space compact_space_subtopology)
    qed
  qed
  then show ?thesis
    by simp
qed
lemma Lindelof_space_subtopology:
   "Lindelof_space(subtopology X S) \<longleftrightarrow>
        (\<forall>\<U>. (\<forall>U \<in> \<U>. openin X U) \<and> topspace X \<inter> S \<subseteq> \<Union>\<U>
            \<longrightarrow> (\<exists>V. countable V \<and> V \<subseteq> \<U> \<and> topspace X \<inter> S \<subseteq> \<Union>V))"
proof -
  have *: "(S \<inter> \<Union>\<U> = topspace X \<inter> S) = (topspace X \<inter> S \<subseteq> \<Union>\<U>)"
    if "\<And>x. x \<in> \<U> \<Longrightarrow> openin X x" for \<U>
    by (blast dest: openin_subset [OF that])
  moreover have "(\<V> \<subseteq> \<U> \<and> S \<inter> \<Union>\<V> = topspace X \<inter> S) = (\<V> \<subseteq> \<U> \<and> topspace X \<inter> S \<subseteq> \<Union>\<V>)"
    if "\<forall>x. x \<in> \<U> \<longrightarrow> openin X x" "topspace X \<inter> S \<subseteq> \<Union>\<U>" "countable \<V>" for \<U> \<V>
    using that * by blast
  ultimately show ?thesis
    unfolding Lindelof_space_def openin_subtopology_alt Ball_def
    apply (simp add: all_subset_image imp_conjL ex_countable_subset_image flip: subset_iff)
    apply (intro all_cong1 imp_cong ex_cong, auto)
    done
qed

lemma Lindelof_space_subtopology_subset:
   "S \<subseteq> topspace X
        \<Longrightarrow> (Lindelof_space(subtopology X S) \<longleftrightarrow>
             (\<forall>\<U>. (\<forall>U \<in> \<U>. openin X U) \<and> S \<subseteq> \<Union>\<U>
                 \<longrightarrow> (\<exists>V. countable V \<and> V \<subseteq> \<U> \<and> S \<subseteq> \<Union>V)))"
  by (metis Lindelof_space_subtopology topspace_subtopology topspace_subtopology_subset)

lemma Lindelof_space_closedin_subtopology:
  assumes X: "Lindelof_space X" and clo: "closedin X S"
  shows "Lindelof_space (subtopology X S)"
proof -
  have "S \<subseteq> topspace X"
    by (simp add: clo closedin_subset)
  then show ?thesis
  proof (clarsimp simp add: Lindelof_space_subtopology_subset)
    show "\<exists>V. countable V \<and> V \<subseteq> \<F> \<and> S \<subseteq> \<Union>V"
      if "\<forall>U\<in>\<F>. openin X U" and "S \<subseteq> \<Union>\<F>" for \<F>
    proof -
      have "\<exists>\<V>. countable \<V> \<and> \<V> \<subseteq> insert (topspace X - S) \<F> \<and> \<Union>\<V> = topspace X"
      proof (rule Lindelof_spaceD [OF X, of "insert (topspace X - S) \<F>"])
        show "openin X U"
          if "U \<in> insert (topspace X - S) \<F>" for U
          using that \<open>\<forall>U\<in>\<F>. openin X U\<close> clo by blast
        show "\<Union>(insert (topspace X - S) \<F>) = topspace X"
          apply auto
          apply (meson in_mono openin_closedin_eq that(1))
          using UnionE \<open>S \<subseteq> \<Union>\<F>\<close> by auto
      qed
      then obtain \<V> where "countable \<V>" "\<V> \<subseteq> insert (topspace X - S) \<F>" "\<Union>\<V> = topspace X"
        by metis
      with \<open>S \<subseteq> topspace X\<close>
      show ?thesis
        by (rule_tac x="(\<V> - {topspace X - S})" in exI) auto
    qed
  qed
qed

lemma Lindelof_space_continuous_map_image:
  assumes X: "Lindelof_space X" and f: "continuous_map X Y f" and fim: "f ` (topspace X) = topspace Y"
  shows "Lindelof_space Y"
proof -
  have "\<exists>\<V>. countable \<V> \<and> \<V> \<subseteq> \<U> \<and> \<Union>\<V> = topspace Y"
    if \<U>: "\<And>U. U \<in> \<U> \<Longrightarrow> openin Y U" and UU: "\<Union>\<U> = topspace Y" for \<U>
  proof -
    define \<V> where "\<V> \<equiv> (\<lambda>U. {x \<in> topspace X. f x \<in> U}) ` \<U>"
    have "\<And>V. V \<in> \<V> \<Longrightarrow> openin X V"
      unfolding \<V>_def using \<U> continuous_map f by fastforce
    moreover have "\<Union>\<V> = topspace X"
      unfolding \<V>_def using UU fim by fastforce
    ultimately have "\<exists>\<W>. countable \<W> \<and> \<W> \<subseteq> \<V> \<and> \<Union>\<W> = topspace X"
      using X by (simp add: Lindelof_space_def)
    then obtain \<C> where "countable \<C>" "\<C> \<subseteq> \<U>" and \<C>: "(\<Union>U\<in>\<C>. {x \<in> topspace X. f x \<in> U}) = topspace X"
      by (metis (no_types, lifting) \<V>_def countable_subset_image)
    moreover have "\<Union>\<C> = topspace Y"
    proof
      show "\<Union>\<C> \<subseteq> topspace Y"
        using UU \<C> \<open>\<C> \<subseteq> \<U>\<close> by fastforce
      have "y \<in> \<Union>\<C>" if "y \<in> topspace Y" for y
      proof -
        obtain x where "x \<in> topspace X" "y = f x"
          using that fim by (metis \<open>y \<in> topspace Y\<close> imageE)
        with \<C> show ?thesis by auto
      qed
      then show "topspace Y \<subseteq> \<Union>\<C>" by blast
    qed
    ultimately show ?thesis
      by blast
  qed
  then show ?thesis
    unfolding Lindelof_space_def
    by auto
qed

lemma Lindelof_space_quotient_map_image:
   "\<lbrakk>quotient_map X Y q; Lindelof_space X\<rbrakk> \<Longrightarrow> Lindelof_space Y"
  by (meson Lindelof_space_continuous_map_image quotient_imp_continuous_map quotient_imp_surjective_map)

lemma Lindelof_space_retraction_map_image:
   "\<lbrakk>retraction_map X Y r; Lindelof_space X\<rbrakk> \<Longrightarrow> Lindelof_space Y"
  using Abstract_Topology.retraction_imp_quotient_map Lindelof_space_quotient_map_image by blast

lemma locally_finite_cover_of_Lindelof_space:
  assumes X: "Lindelof_space X" and UU: "topspace X \<subseteq> \<Union>\<U>" and fin: "locally_finite_in X \<U>"
  shows "countable \<U>"
proof -
  have UU_eq: "\<Union>\<U> = topspace X"
    by (meson UU fin locally_finite_in_def subset_antisym)
  obtain T where T: "\<And>x. x \<in> topspace X \<Longrightarrow> openin X (T x) \<and> x \<in> T x \<and> finite {U \<in> \<U>. U \<inter> T x \<noteq> {}}"
    using fin unfolding locally_finite_in_def by metis
  then obtain I where "countable I" "I \<subseteq> topspace X" and I: "topspace X \<subseteq> \<Union>(T ` I)"
    using X unfolding Lindelof_space_alt
    by (drule_tac x="image T (topspace X)" in spec) (auto simp: ex_countable_subset_image)
  show ?thesis
  proof (rule countable_subset)
    have "\<And>i. i \<in> I \<Longrightarrow> countable {U \<in> \<U>. U \<inter> T i \<noteq> {}}"
      using T
      by (meson \<open>I \<subseteq> topspace X\<close> in_mono uncountable_infinite)
    then show "countable (insert {} (\<Union>i\<in>I. {U \<in> \<U>. U \<inter> T i \<noteq> {}}))"
      by (simp add: \<open>countable I\<close>)
  qed (use UU_eq I in auto)
qed

lemma Lindelof_space_proper_map_preimage:
  assumes f: "proper_map X Y f" and Y: "Lindelof_space Y"
  shows "Lindelof_space X"
proof (clarsimp simp: Lindelof_space_alt)
  show "\<exists>\<V>. countable \<V> \<and> \<V> \<subseteq> \<U> \<and> topspace X \<subseteq> \<Union>\<V>"
    if \<U>: "\<forall>U\<in>\<U>. openin X U" and sub_UU: "topspace X \<subseteq> \<Union>\<U>" for \<U>
  proof -
    have "\<exists>\<V>. finite \<V> \<and> \<V> \<subseteq> \<U> \<and> {x \<in> topspace X. f x = y} \<subseteq> \<Union>\<V>" if "y \<in> topspace Y" for y
    proof (rule compactinD)
      show "compactin X {x \<in> topspace X. f x = y}"
        using f proper_map_def that by fastforce
    qed (use sub_UU \<U> in auto)
    then obtain \<V> where \<V>: "\<And>y. y \<in> topspace Y \<Longrightarrow> finite (\<V> y) \<and> \<V> y \<subseteq> \<U> \<and> {x \<in> topspace X. f x = y} \<subseteq> \<Union>(\<V> y)"
      by meson
    define \<W> where "\<W> \<equiv> (\<lambda>y. topspace Y - image f (topspace X - \<Union>(\<V> y))) ` topspace Y"
    have "\<forall>U \<in> \<W>. openin Y U"
      using f \<U> \<V> unfolding \<W>_def proper_map_def closed_map_def
      by (simp add: closedin_diff openin_Union openin_diff subset_iff)
    moreover have "topspace Y \<subseteq> \<Union>\<W>"
      using \<V> unfolding \<W>_def by clarsimp fastforce
    ultimately have "\<exists>\<V>. countable \<V> \<and> \<V> \<subseteq> \<W> \<and> topspace Y \<subseteq> \<Union>\<V>"
      using Y by (simp add: Lindelof_space_alt)
    then obtain I where "countable I" "I \<subseteq> topspace Y"
      and I: "topspace Y \<subseteq> (\<Union>i\<in>I. topspace Y - f ` (topspace X - \<Union>(\<V> i)))"
      unfolding \<W>_def ex_countable_subset_image by metis
    show ?thesis
    proof (intro exI conjI)
      have "\<And>i. i \<in> I \<Longrightarrow> countable (\<V> i)"
        by (meson \<V> \<open>I \<subseteq> topspace Y\<close> in_mono uncountable_infinite)
      with \<open>countable I\<close> show "countable (\<Union>(\<V> ` I))"
        by auto
      show "\<Union>(\<V> ` I) \<subseteq> \<U>"
        using \<V> \<open>I \<subseteq> topspace Y\<close> by fastforce
      show "topspace X \<subseteq> \<Union>(\<Union>(\<V> ` I))"
      proof
        show "x \<in> \<Union> (\<Union> (\<V> ` I))" if "x \<in> topspace X" for x
        proof -
          have "f x \<in> topspace Y"
            by (meson f image_subset_iff proper_map_imp_subset_topspace that)
          then show ?thesis
            using that I by auto
        qed
      qed
    qed
  qed
qed

lemma Lindelof_space_perfect_map_image:
   "\<lbrakk>Lindelof_space X; perfect_map X Y f\<rbrakk> \<Longrightarrow> Lindelof_space Y"
  using Lindelof_space_quotient_map_image perfect_imp_quotient_map by blast

lemma Lindelof_space_perfect_map_image_eq:
   "perfect_map X Y f \<Longrightarrow> Lindelof_space X \<longleftrightarrow> Lindelof_space Y"
  using Lindelof_space_perfect_map_image Lindelof_space_proper_map_preimage perfect_map_def by blast

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_sort_nat_TSortSorts
imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

datatype Tree = TNode "Tree" "Nat" "Tree" | TNil

fun le :: "Nat => Nat => bool" where
"le (Z) y = True"
| "le (S z) (Z) = False"
| "le (S z) (S x2) = le z x2"

fun ordered :: "Nat list => bool" where
"ordered (nil2) = True"
| "ordered (cons2 y (nil2)) = True"
| "ordered (cons2 y (cons2 y2 xs)) =
     ((le y y2) & (ordered (cons2 y2 xs)))"

fun flatten :: "Tree => Nat list => Nat list" where
"flatten (TNode q z r) y = flatten q (cons2 z (flatten r y))"
| "flatten (TNil) y = y"

fun add :: "Nat => Tree => Tree" where
"add x (TNode q z r) =
   (if le x z then TNode (add x q) z r else TNode q z (add x r))"
| "add x (TNil) = TNode TNil x TNil"

fun toTree :: "Nat list => Tree" where
"toTree (nil2) = TNil"
| "toTree (cons2 y xs) = add y (toTree xs)"

fun tsort :: "Nat list => Nat list" where
"tsort x = flatten (toTree x) (nil2)"

theorem property0 :
  "ordered (tsort xs)"
  oops

end


theory Exercises2 imports Main begin

subsection "primitive recursion and induction"

datatype 'a tree = Tip | Node "'a tree" 'a "'a tree"

text {*
  define a function that converts a tree into
  a list in post order by primitive recursion
*}

consts
  postorder :: "'a tree \<Rightarrow> 'a list"

text {*
  define another function that does the same,
  but with tail recursion (recursive call at
  top level only)
*}

consts
  postorder_it :: "['a tree, 'a list] \<Rightarrow> 'a list"

lemma "postorder_it t [] = postorder t"
  oops

subsection "inductively defined sets"

consts Ev :: "nat set"
inductive Ev
intros
ZeroI: "0 \<in> Ev"
Add2I: "n \<in> Ev \<Longrightarrow> Suc(Suc n) \<in> Ev"

lemma "\<lbrakk> n \<in> Ev; m \<in> Ev \<rbrakk> \<Longrightarrow> m+n \<in> Ev"
oops

text {* use method arith to solve linear arithmetic problems *}

lemma "n \<in> Ev \<Longrightarrow> \<exists>k. n = 2*k"
oops

lemma "n = 2*k \<longrightarrow> n \<in> Ev"
oops

text {* Solve in Isar: *}

lemma "A \<and> B \<longrightarrow> B \<and> A"
oops

lemma "A \<and> (B \<or> C) \<longrightarrow> (A \<and> B) \<or> (A \<and> C)"
oops

end


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

theory Ideal_Product
  imports Ideal
begin

section \<open>Product of Ideals\<close>

text \<open>In this section, we study the structure of the set of ideals of a given ring.\<close>

inductive_set
  ideal_prod :: "[ ('a, 'b) ring_scheme, 'a set, 'a set ] \<Rightarrow> 'a set" (infixl "\<cdot>\<index>" 80)
  for R and I and J (* both I and J are supposed ideals *) where
    prod: "\<lbrakk> i \<in> I; j \<in> J \<rbrakk> \<Longrightarrow> i \<otimes>\<^bsub>R\<^esub> j \<in> ideal_prod R I J"
  |  sum: "\<lbrakk> s1 \<in> ideal_prod R I J; s2 \<in> ideal_prod R I J \<rbrakk> \<Longrightarrow> s1 \<oplus>\<^bsub>R\<^esub> s2 \<in> ideal_prod R I J"

definition ideals_set :: "('a, 'b) ring_scheme \<Rightarrow> ('a set) ring"
  where "ideals_set R = \<lparr> carrier = { I. ideal I R },
                             mult = ideal_prod R,
                              one = carrier R,
                             zero = { \<zero>\<^bsub>R\<^esub> },
                              add = set_add R \<rparr>"

subsection \<open>Basic Properties\<close>

lemma (in ring) ideal_prod_in_carrier:
  assumes "ideal I R" "ideal J R"
  shows "I \<cdot> J \<subseteq> carrier R"
proof
  fix s assume "s \<in> I \<cdot> J" thus "s \<in> carrier R"
    by (induct s rule: ideal_prod.induct) (auto, meson assms ideal.I_l_closed ideal.Icarr)
qed

lemma (in ring) ideal_prod_inter:
  assumes "ideal I R" "ideal J R"
  shows "I \<cdot> J \<subseteq> I \<inter> J"
proof
  fix s assume "s \<in> I \<cdot> J" thus "s \<in> I \<inter> J"
    apply (induct s rule: ideal_prod.induct)
    apply (auto, (meson assms ideal.I_r_closed ideal.I_l_closed ideal.Icarr)+)
    apply (simp_all add: additive_subgroup.a_closed assms ideal.axioms(1))
    done
qed

lemma (in ring) ideal_prod_is_ideal:
  assumes "ideal I R" "ideal J R"
  shows "ideal (I \<cdot> J) R"
proof (rule idealI)
  show "ring R" using is_ring .
next
  show "subgroup (I \<cdot> J) (add_monoid R)"
    unfolding subgroup_def
  proof (auto)
    show "\<zero> \<in> I \<cdot> J" using ideal_prod.prod[of \<zero> I \<zero> J R]
      by (simp add: additive_subgroup.zero_closed assms ideal.axioms(1))
  next
    fix s1 s2 assume s1: "s1 \<in> I \<cdot> J" and s2: "s2 \<in> I \<cdot> J"
    have IJcarr: "\<And>a. a \<in> I \<cdot> J \<Longrightarrow> a \<in> carrier R"
      by (meson assms subsetD ideal_prod_in_carrier)
    show "s1 \<in> carrier R" using ideal_prod_in_carrier[OF assms] s1 by blast
    show "s1 \<oplus> s2 \<in> I \<cdot> J" by (simp add: ideal_prod.sum[OF s1 s2])
    show "inv\<^bsub>add_monoid R\<^esub> s1 \<in> I \<cdot> J" using s1
    proof (induct s1 rule: ideal_prod.induct)
      case (prod i j)
      hence "inv\<^bsub>add_monoid R\<^esub> (i \<otimes> j) = (inv\<^bsub>add_monoid R\<^esub> i) \<otimes> j"
        by (metis a_inv_def assms(1) assms(2) ideal.Icarr l_minus)
      thus ?case using ideal_prod.prod[of "inv\<^bsub>add_monoid R\<^esub> i" I j J R] assms
        by (simp add: additive_subgroup.a_subgroup ideal.axioms(1) prod.hyps subgroup.m_inv_closed)
    next
      case (sum s1 s2) thus ?case
        by (metis (no_types) IJcarr a_inv_def add.inv_mult_group ideal_prod.sum sum.hyps)
    qed
  qed
next
  fix s x assume s: "s \<in> I \<cdot> J" and x: "x \<in> carrier R"
  show "x \<otimes> s \<in> I \<cdot> J" using s
  proof (induct s rule: ideal_prod.induct)
    case (prod i j) thus ?case using ideal_prod.prod[of "x \<otimes> i" I j J R] assms
      by (simp add: x ideal.I_l_closed ideal.Icarr m_assoc)
  next
    case (sum s1 s2) thus ?case
    proof -
      have IJ: "I \<cdot> J \<subseteq> carrier R"
        by (metis (no_types) assms(1) assms(2) ideal.axioms(2) ring.ideal_prod_in_carrier)
      then have "s2 \<in> carrier R"
        using sum.hyps(3) by blast
      moreover have "s1 \<in> carrier R"
        using IJ sum.hyps(1) by blast
      ultimately show ?thesis
        by (simp add: ideal_prod.sum r_distr sum.hyps x)
    qed
  qed
  show "s \<otimes> x \<in> I \<cdot> J" using s
  proof (induct s rule: ideal_prod.induct)
    case (prod i j) thus ?case using ideal_prod.prod[of i I "j \<otimes> x" J R] assms x
      by (simp add: x ideal.I_r_closed ideal.Icarr m_assoc)
  next
    case (sum s1 s2) thus ?case
    proof -
      have "s1 \<in> carrier R" "s2 \<in> carrier R"
        by (meson assms subsetD ideal_prod_in_carrier sum.hyps)+
      then show ?thesis
        by (metis ideal_prod.sum l_distr sum.hyps(2) sum.hyps(4) x)
    qed
  qed
qed

lemma (in ring) ideal_prod_eq_genideal:
  assumes "ideal I R" "ideal J R"
  shows "I \<cdot> J = Idl (I <#> J)"
proof
  have "I <#> J \<subseteq> I \<cdot> J"
  proof
    fix s assume "s \<in> I <#> J"
    then obtain i j where "i \<in> I" "j \<in> J" "s = i \<otimes> j"
      unfolding set_mult_def by blast
    thus "s \<in> I \<cdot> J" using ideal_prod.prod by simp
  qed
  thus "Idl (I <#> J) \<subseteq> I \<cdot> J"
    unfolding genideal_def using ideal_prod_is_ideal[OF assms] by blast
next
  show "I \<cdot> J \<subseteq> Idl (I <#> J)"
  proof
    fix s assume "s \<in> I \<cdot> J" thus "s \<in> Idl (I <#> J)"
    proof (induct s rule: ideal_prod.induct)
      case (prod i j) hence "i \<otimes> j \<in> I <#> J" unfolding set_mult_def by blast
      thus ?case unfolding genideal_def by blast
    next
      case (sum s1 s2) thus ?case
        by (simp add: additive_subgroup.a_closed additive_subgroup.a_subset
            assms genideal_ideal ideal.axioms(1) set_mult_closed)
    qed
  qed
qed

lemma (in ring) ideal_prod_simp:
  assumes "ideal I R" "ideal J R" (* the second assumption could be suppressed *)
  shows "I = I <+> (I \<cdot> J)"
proof
  show "I \<subseteq> I <+> I \<cdot> J"
  proof
    fix i assume "i \<in> I" hence "i \<oplus> \<zero> \<in> I <+> I \<cdot> J"
      using set_add_def'[of R I "I \<cdot> J"] ideal_prod_is_ideal[OF assms]
            additive_subgroup.zero_closed[OF ideal.axioms(1), of "I \<cdot> J" R] by auto
    thus "i \<in> I <+> I \<cdot> J"
      using \<open>i \<in> I\<close> assms(1) ideal.Icarr by fastforce
  qed
next
  show "I <+> I \<cdot> J \<subseteq> I"
  proof
    fix s assume "s \<in> I <+> I \<cdot> J"
    then obtain i ij where "i \<in> I" "ij \<in> I \<cdot> J" "s = i \<oplus> ij"
      using set_add_def'[of R I "I \<cdot> J"] by auto
    thus "s \<in> I"
      using ideal_prod_inter[OF assms]
      by (meson additive_subgroup.a_closed assms(1) ideal.axioms(1) inf_sup_ord(1) subsetCE)
  qed
qed

lemma (in ring) ideal_prod_one:
  assumes "ideal I R"
  shows "I \<cdot> (carrier R) = I"
proof
  show "I \<cdot> (carrier R) \<subseteq> I"
  proof
    fix s assume "s \<in> I \<cdot> (carrier R)" thus "s \<in> I"
      by (induct s rule: ideal_prod.induct)
         (simp_all add: assms ideal.I_r_closed additive_subgroup.a_closed ideal.axioms(1))
  qed
next
  show "I \<subseteq> I \<cdot> (carrier R)"
  proof
    fix i assume "i \<in> I" thus "i \<in>  I \<cdot> (carrier R)"
      by (metis assms ideal.Icarr ideal_prod.simps one_closed r_one)
  qed
qed

lemma (in ring) ideal_prod_zero:
  assumes "ideal I R"
  shows "I \<cdot> { \<zero> } = { \<zero> }"
proof
  show "I \<cdot> { \<zero> } \<subseteq> { \<zero> }"
  proof
    fix s assume "s \<in> I \<cdot> {\<zero>}" thus "s \<in> { \<zero> }"
      using assms ideal.Icarr by (induct s rule: ideal_prod.induct) (fastforce, simp)
  qed
next
  show "{ \<zero> } \<subseteq> I \<cdot> { \<zero> }"
    by (simp add: additive_subgroup.zero_closed assms
                  ideal.axioms(1) ideal_prod_is_ideal zeroideal)
qed

lemma (in ring) ideal_prod_assoc:
  assumes "ideal I R" "ideal J R" "ideal K R"
  shows "(I \<cdot> J) \<cdot> K = I \<cdot> (J \<cdot> K)"
proof
  show "(I \<cdot> J) \<cdot> K \<subseteq> I \<cdot> (J \<cdot> K)"
  proof
    fix s assume "s \<in> (I \<cdot> J) \<cdot> K" thus "s \<in> I \<cdot> (J \<cdot> K)"
    proof (induct s rule: ideal_prod.induct)
      case (sum s1 s2) thus ?case
        by (simp add: ideal_prod.sum)
    next
      case (prod i k) thus ?case
      proof (induct i rule: ideal_prod.induct)
        case (prod i j) thus ?case
          using ideal_prod.prod[OF prod(1) ideal_prod.prod[OF prod(2-3),of R], of R]
          by (metis assms ideal.Icarr m_assoc)
      next
        case (sum s1 s2) thus ?case
        proof -
          have "s1 \<in> carrier R" "s2 \<in> carrier R"
            by (meson assms subsetD ideal.axioms(2) ring.ideal_prod_in_carrier sum.hyps)+
          moreover have "k \<in> carrier R"
            by (meson additive_subgroup.a_Hcarr assms(3) ideal.axioms(1) sum.prems)
          ultimately show ?thesis
            by (metis ideal_prod.sum l_distr sum.hyps(2) sum.hyps(4) sum.prems)
        qed
      qed
    qed
  qed
next
  show "I \<cdot> (J \<cdot> K) \<subseteq> (I \<cdot> J) \<cdot> K"
  proof
    fix s assume "s \<in> I \<cdot> (J \<cdot> K)" thus "s \<in> (I \<cdot> J) \<cdot> K"
    proof (induct s rule: ideal_prod.induct)
      case (sum s1 s2) thus ?case by (simp add: ideal_prod.sum)
    next
      case (prod i j) show ?case using prod(2) prod(1)
      proof (induct j rule: ideal_prod.induct)
        case (prod j k) thus ?case
          using ideal_prod.prod[OF ideal_prod.prod[OF prod(3) prod(1), of R] prod (2), of R]
          by (metis assms ideal.Icarr m_assoc)
      next
        case (sum s1 s2) thus ?case
        proof -
          have "\<And>a A B. \<lbrakk>a \<in> B \<cdot> A; ideal A R; ideal B R\<rbrakk> \<Longrightarrow> a \<in> carrier R"
            by (meson subsetD ideal_prod_in_carrier)
          moreover have "i \<in> carrier R"
            by (meson additive_subgroup.a_Hcarr assms(1) ideal.axioms(1) sum.prems)
          ultimately show ?thesis
            by (metis (no_types) assms(2) assms(3) ideal_prod.sum r_distr sum)
        qed
      qed
    qed
  qed
qed

lemma (in ring) ideal_prod_r_distr:
  assumes "ideal I R" "ideal J R" "ideal K R"
  shows "I \<cdot> (J <+> K) = (I \<cdot> J) <+>  (I \<cdot> K)"
proof
  show "I \<cdot> (J <+> K) \<subseteq> I \<cdot> J <+> I \<cdot> K"
  proof
    fix s assume "s \<in> I \<cdot> (J <+> K)" thus "s \<in> I \<cdot> J <+> I \<cdot> K"
    proof(induct s rule: ideal_prod.induct)
      case (prod i jk)
      then obtain j k where j: "j \<in> J" and k: "k \<in> K" and jk: "jk = j \<oplus> k"
        using set_add_def'[of R J K] by auto
      hence "i \<otimes> j \<oplus> i \<otimes> k \<in> I \<cdot> J <+> I \<cdot> K"
        using ideal_prod.prod[OF prod(1) j,of R]
              ideal_prod.prod[OF prod(1) k,of R]
              set_add_def'[of R "I \<cdot> J" "I \<cdot> K"] by auto
      thus ?case
        using assms ideal.Icarr r_distr jk j k prod(1) by metis
    next
      case (sum s1 s2) thus ?case
        by (simp add: add_ideals additive_subgroup.a_closed assms ideal.axioms(1)
                      local.ring_axioms ring.ideal_prod_is_ideal)
    qed
  qed
next
  { fix s J K assume A: "ideal J R" "ideal K R" "s \<in> I \<cdot> J"
    have "s \<in> I \<cdot> (J <+> K) \<and> s \<in> I \<cdot> (K <+> J)"
    proof -
      from \<open>s \<in> I \<cdot> J\<close> have "s \<in> I \<cdot> (J <+> K)"
      proof (induct s rule: ideal_prod.induct)
        case (prod i j)
        hence "(j \<oplus> \<zero>) \<in> J <+> K"
          using set_add_def'[of R J K]
                additive_subgroup.zero_closed[OF ideal.axioms(1), of K R] A(2) by auto
        thus ?case
          by (metis A(1) additive_subgroup.a_Hcarr ideal.axioms(1) ideal_prod.prod prod r_zero)
      next
        case (sum s1 s2) thus ?case
          by (simp add: ideal_prod.sum)
      qed
      thus ?thesis
        by (metis A(1) A(2) ideal_def ring.union_genideal sup_commute)
    qed } note aux_lemma = this

  show "I \<cdot> J <+> I \<cdot> K \<subseteq> I \<cdot> (J <+> K)"
  proof
    fix s assume "s \<in> I \<cdot> J <+> I \<cdot> K"
    then obtain s1 s2 where s1: "s1 \<in> I \<cdot> J" and s2: "s2 \<in> I \<cdot> K" and  s: "s = s1 \<oplus> s2"
      using set_add_def'[of R "I \<cdot> J" "I \<cdot> K"] by auto
    thus "s \<in> I \<cdot> (J <+> K)"
      using aux_lemma[OF assms(2) assms(3) s1]
            aux_lemma[OF assms(3) assms(2) s2] by (simp add: ideal_prod.sum)
  qed
qed

lemma (in cring) ideal_prod_commute:
  assumes "ideal I R" "ideal J R"
  shows "I \<cdot> J = J \<cdot> I"
proof -
  { fix I J assume A: "ideal I R" "ideal J R"
    have "I \<cdot> J \<subseteq> J \<cdot> I"
    proof
      fix s assume "s \<in> I \<cdot> J" thus "s \<in> J \<cdot> I"
      proof (induct s rule: ideal_prod.induct)
        case (prod i j) thus ?case
          using m_comm[OF ideal.Icarr[OF A(1) prod(1)] ideal.Icarr[OF A(2) prod(2)]]
          by (simp add: ideal_prod.prod)
      next
        case (sum s1 s2) thus ?case by (simp add: ideal_prod.sum)
      qed
    qed }
  thus ?thesis using assms by blast
qed

text \<open>The following result would also be true for locale ring\<close>
lemma (in cring) ideal_prod_distr:
  assumes "ideal I R" "ideal J R" "ideal K R"
  shows "I \<cdot> (J <+> K) = (I \<cdot> J) <+>  (I \<cdot> K)"
    and "(J <+> K) \<cdot> I = (J \<cdot> I) <+>  (K \<cdot> I)"
  by (simp_all add: assms ideal_prod_commute local.ring_axioms
                    ring.add_ideals ring.ideal_prod_r_distr)

lemma (in cring) ideal_prod_eq_inter:
  assumes "ideal I R" "ideal J R"
    and "I <+> J = carrier R"
  shows "I \<cdot> J = I \<inter> J"
proof
  show "I \<cdot> J \<subseteq> I \<inter> J"
    using assms ideal_prod_inter by auto
next
  show "I \<inter> J \<subseteq> I \<cdot> J"
  proof
    have "\<one> \<in> I <+> J" using assms(3) one_closed by simp
    then obtain i j where ij: "i \<in> I" "j \<in> J" "\<one> = i \<oplus> j"
      using set_add_def'[of R I J] by auto

    fix s assume s: "s \<in> I \<inter> J"
    hence "(i \<otimes> s \<in> I \<cdot> J) \<and> (s \<otimes> j \<in> I \<cdot> J)"
      using ij(1-2) by (simp add: ideal_prod.prod)
    moreover have "s = (i \<otimes> s) \<oplus> (s \<otimes> j)"
      using ideal.Icarr[OF assms(1) ij(1)]
            ideal.Icarr[OF assms(2) ij(2)]
            ideal.Icarr[OF assms(1), of s]
      by (metis ij(3) s m_comm[of s i] Int_iff r_distr r_one)
    ultimately show "s \<in>  I \<cdot> J"
      using ideal_prod.sum by fastforce
  qed
qed

subsection \<open>Structure of the Set of Ideals\<close>

text \<open>We focus on commutative rings for convenience.\<close>

lemma (in cring) ideals_set_is_semiring: "semiring (ideals_set R)"
proof -
  have "abelian_monoid (ideals_set R)"
    apply (rule abelian_monoidI) unfolding ideals_set_def
    apply (simp_all add: add_ideals zeroideal)
    apply (simp add: add.set_mult_assoc additive_subgroup.a_subset ideal.axioms(1) set_add_defs(1))
    apply (metis Un_absorb1 additive_subgroup.a_subset additive_subgroup.zero_closed
        cgenideal_minimal cgenideal_self empty_iff genideal_minimal ideal.axioms(1)
        local.ring_axioms order_refl ring.genideal_self subset_antisym subset_singletonD
        union_genideal zero_closed zeroideal)
    by (metis sup_commute union_genideal)

  moreover have "monoid (ideals_set R)"
    apply (rule monoidI) unfolding ideals_set_def
    apply (simp_all add: ideal_prod_is_ideal oneideal
                         ideal_prod_commute ideal_prod_one)
    by (metis ideal_prod_assoc ideal_prod_commute)

  ultimately show ?thesis
    unfolding semiring_def semiring_axioms_def ideals_set_def
    by (simp_all add: ideal_prod_distr ideal_prod_commute ideal_prod_zero zeroideal)
qed

lemma (in cring) ideals_set_is_comm_monoid: "comm_monoid (ideals_set R)"
proof -
  have "monoid (ideals_set R)"
    apply (rule monoidI) unfolding ideals_set_def
    apply (simp_all add: ideal_prod_is_ideal oneideal
                         ideal_prod_commute ideal_prod_one)
    by (metis ideal_prod_assoc ideal_prod_commute)
  thus ?thesis
    unfolding comm_monoid_def comm_monoid_axioms_def
    by (simp add: ideal_prod_commute ideals_set_def)
qed

lemma (in cring) ideal_prod_eq_Inter_aux:
  assumes "I: {..(Suc n)} \<rightarrow> { J. ideal J R }"
    and "\<And>i j. \<lbrakk> i \<le> Suc n; j \<le> Suc n \<rbrakk> \<Longrightarrow>
                 i \<noteq> j \<Longrightarrow> (I i) <+> (I j) = carrier R"
  shows "(\<Otimes>\<^bsub>(ideals_set R)\<^esub> k \<in> {..n}. I k) <+> (I (Suc n)) = carrier R" using assms
proof (induct n arbitrary: I)
  case 0
  hence "(\<Otimes>\<^bsub>(ideals_set R)\<^esub> k \<in> {..0}. I k) <+> I (Suc 0) = (I 0) <+> (I (Suc 0))"
    using comm_monoid.finprod_0[OF ideals_set_is_comm_monoid, of I]
    by (simp add: atMost_Suc ideals_set_def)
  also have " ... = carrier R"
    using 0(2)[of 0 "Suc 0"] by simp
  finally show ?case .
next
  interpret ISet: comm_monoid "ideals_set R"
    by (simp add: ideals_set_is_comm_monoid)

  case (Suc n)
  let ?I' = "\<lambda>i. I (Suc i)"
  have "?I': {..(Suc n)} \<rightarrow> { J. ideal J R }"
    using Suc.prems(1) by auto
  moreover have "\<And>i j. \<lbrakk> i \<le> Suc n; j \<le> Suc n \<rbrakk> \<Longrightarrow>
                         i \<noteq> j \<Longrightarrow> (?I' i) <+> (?I' j) = carrier R"
    by (simp add: Suc.prems(2))
  ultimately have "(\<Otimes>\<^bsub>(ideals_set R)\<^esub> k \<in> {..n}. ?I' k) <+> (?I' (Suc n)) = carrier R"
    using Suc.hyps by metis

  moreover have I_carr: "I: {..Suc (Suc n)} \<rightarrow> carrier (ideals_set R)"
    unfolding ideals_set_def using Suc by simp
  hence I'_carr: "I \<in> Suc ` {..n} \<rightarrow> carrier (ideals_set R)" by auto
  ultimately have "(\<Otimes>\<^bsub>(ideals_set R)\<^esub> k \<in> {(Suc 0)..Suc n}. I k) <+> (I (Suc (Suc n))) = carrier R"
    using ISet.finprod_reindex[of I "\<lambda>i. Suc i" "{..n}"] by (simp add: atMost_atLeast0)

  hence "(carrier R) \<cdot> (I 0) = ((\<Otimes>\<^bsub>(ideals_set R)\<^esub> k \<in> {Suc 0..Suc n}. I k) <+> I (Suc (Suc n))) \<cdot> (I 0)"
    by auto
  moreover have fprod_cl1: "ideal (\<Otimes>\<^bsub>(ideals_set R)\<^esub> k \<in> {Suc 0..Suc n}. I k) R"
    by (metis I'_carr ISet.finprod_closed One_nat_def ideals_set_def image_Suc_atMost
        mem_Collect_eq partial_object.select_convs(1))
  ultimately
  have "I 0 = (\<Otimes>\<^bsub>(ideals_set R)\<^esub> k \<in> {Suc 0..Suc n}. I k) \<cdot> (I 0) <+> I (Suc (Suc n)) \<cdot> (I 0)"
    by (metis PiE Suc.prems(1) atLeast0_atMost_Suc atLeast0_atMost_Suc_eq_insert_0
        atMost_atLeast0 ideal_prod_commute ideal_prod_distr(2) ideal_prod_one insertI1
        mem_Collect_eq oneideal)
  also have " ... = (I 0) \<cdot> (\<Otimes>\<^bsub>(ideals_set R)\<^esub> k \<in> {Suc 0..Suc n}. I k) <+> I (Suc (Suc n)) \<cdot> (I 0)"
    using fprod_cl1 ideal_prod_commute Suc.prems(1)
    by (simp add: atLeast0_atMost_Suc_eq_insert_0 atMost_atLeast0)
  also have " ... = (I 0) \<otimes>\<^bsub>(ideals_set R)\<^esub> (\<Otimes>\<^bsub>(ideals_set R)\<^esub> k \<in> {Suc 0..Suc n}. I k) <+>
                     I (Suc (Suc n)) \<cdot> (I 0)"
    by (simp add: ideals_set_def)
  finally have I0: "I 0 = (\<Otimes>\<^bsub>(ideals_set R)\<^esub> k \<in> {..Suc n}. I k) <+> I (Suc (Suc n)) \<cdot> (I 0)"
    using ISet.finprod_insert[of "{Suc 0..Suc n}" 0 I]
          I_carr I'_carr atMost_atLeast0 ISet.finprod_0' atMost_Suc by auto

  have I_SucSuc_I0: "ideal (I (Suc (Suc n))) R \<and> ideal (I 0) R"
    using Suc.prems(1) by auto
  have fprod_cl2: "ideal (\<Otimes>\<^bsub>(ideals_set R)\<^esub> k \<in> {..Suc n}. I k) R"
    by (metis (no_types) ISet.finprod_closed I_carr Pi_split_insert_domain atMost_Suc ideals_set_def mem_Collect_eq partial_object.select_convs(1))
  have "carrier R = I (Suc (Suc n)) <+> I 0"
    by (simp add: Suc.prems(2))
  also have " ... = I (Suc (Suc n)) <+>
                    ((\<Otimes>\<^bsub>(ideals_set R)\<^esub> k \<in> {..Suc n}. I k) <+> I (Suc (Suc n)) \<cdot> (I 0))"
    using I0 by auto
  also have " ... = I (Suc (Suc n)) <+>
                    (I (Suc (Suc n)) \<cdot> (I 0) <+> (\<Otimes>\<^bsub>(ideals_set R)\<^esub> k \<in> {..Suc n}. I k))"
    using fprod_cl2 I_SucSuc_I0 by (metis Un_commute ideal_prod_is_ideal union_genideal)
  also have " ... = (I (Suc (Suc n)) <+> I (Suc (Suc n)) \<cdot> (I 0)) <+>
                    (\<Otimes>\<^bsub>(ideals_set R)\<^esub> k \<in> {..Suc n}. I k)"
    using fprod_cl2 I_SucSuc_I0 by (metis add.set_mult_assoc ideal_def ideal_prod_in_carrier
                                          oneideal ring.ideal_prod_one set_add_defs(1))
  also have " ... = I (Suc (Suc n)) <+> (\<Otimes>\<^bsub>(ideals_set R)\<^esub> k \<in> {..Suc n}. I k)"
    using ideal_prod_simp[of "I (Suc (Suc n))" "I 0"] I_SucSuc_I0 by simp
  also have " ... = (\<Otimes>\<^bsub>(ideals_set R)\<^esub> k \<in> {..Suc n}. I k) <+> I (Suc (Suc n))"
    using fprod_cl2 I_SucSuc_I0 by (metis Un_commute union_genideal)
  finally show ?case by simp
qed

theorem (in cring) ideal_prod_eq_Inter:
  assumes "I: {..n :: nat} \<rightarrow> { J. ideal J R }"
    and "\<And>i j. \<lbrakk> i \<in> {..n}; j \<in> {..n} \<rbrakk> \<Longrightarrow> i \<noteq> j \<Longrightarrow> (I i) <+> (I j) = carrier R"
  shows "(\<Otimes>\<^bsub>(ideals_set R)\<^esub> k \<in> {..n}. I k) = (\<Inter> k \<in> {..n}. I k)" using assms
proof (induct n)
  case 0 thus ?case
    using comm_monoid.finprod_0[OF ideals_set_is_comm_monoid] by (simp add: ideals_set_def)
next
  interpret ISet: comm_monoid "ideals_set R"
    by (simp add: ideals_set_is_comm_monoid)

  case (Suc n)
  hence IH: "(\<Otimes>\<^bsub>(ideals_set R)\<^esub> k \<in> {..n}. I k) = (\<Inter> k \<in> {..n}. I k)"
    by (simp add: atMost_Suc)
  hence "(\<Otimes>\<^bsub>(ideals_set R)\<^esub> k \<in> {..Suc n}. I k) = I (Suc n) \<otimes>\<^bsub>(ideals_set R)\<^esub> (\<Inter> k \<in> {..n}. I k)"
    using ISet.finprod_insert[of "{Suc 0..Suc n}" 0 I] atMost_Suc_eq_insert_0[of n]
    by (metis ISet.finprod_Suc Suc.prems(1) ideals_set_def partial_object.select_convs(1))
  hence "(\<Otimes>\<^bsub>(ideals_set R)\<^esub> k \<in> {..Suc n}. I k) = I (Suc n) \<cdot> (\<Inter> k \<in> {..n}. I k)"
    by (simp add: ideals_set_def)
  moreover have "(\<Inter> k \<in> {..n}. I k) <+> I (Suc n) = carrier R"
    using ideal_prod_eq_Inter_aux[of I n] by (simp add: Suc.prems IH)
  moreover have "ideal (\<Inter> k \<in> {..n}. I k) R"
    using ring.i_Intersect[of R "I ` {..n}"]
    by (metis IH ISet.finprod_closed Pi_split_insert_domain Suc.prems(1) atMost_Suc
              ideals_set_def mem_Collect_eq partial_object.select_convs(1))
  ultimately
  have "(\<Otimes>\<^bsub>(ideals_set R)\<^esub> k \<in> {..Suc n}. I k) = (\<Inter> k \<in> {..n}. I k) \<inter> I (Suc n)"
    using ideal_prod_eq_inter[of "\<Inter> k \<in> {..n}. I k" "I (Suc n)"]
          ideal_prod_commute[of "\<Inter> k \<in> {..n}. I k" "I (Suc n)"]
    by (metis PiE Suc.prems(1) atMost_iff mem_Collect_eq order_refl)
  thus ?case by (simp add: Int_commute atMost_Suc)
qed

corollary (in cring) inter_plus_ideal_eq_carrier:
  assumes "\<And>i. i \<le> Suc n \<Longrightarrow> ideal (I i) R"
      and "\<And>i j. \<lbrakk> i \<le> Suc n; j \<le> Suc n; i \<noteq> j \<rbrakk> \<Longrightarrow> I i <+> I j = carrier R"
  shows "(\<Inter> i \<le> n. I i) <+> (I (Suc n)) = carrier R"
  using ideal_prod_eq_Inter[of I n] ideal_prod_eq_Inter_aux[of I n] by (auto simp add: assms)

corollary (in cring) inter_plus_ideal_eq_carrier_arbitrary:
  assumes "\<And>i. i \<le> Suc n \<Longrightarrow> ideal (I i) R"
      and "\<And>i j. \<lbrakk> i \<le> Suc n; j \<le> Suc n; i \<noteq> j \<rbrakk> \<Longrightarrow> I i <+> I j = carrier R"
      and "j \<le> Suc n"
  shows "(\<Inter> i \<in> ({..(Suc n)} - { j }). I i) <+> (I j) = carrier R"
proof -
  define I' where "I' = (\<lambda>i. if i = Suc n then (I j) else
                             if i = j     then (I (Suc n))
                                          else (I i))"
  have "\<And>i. i \<le> Suc n \<Longrightarrow> ideal (I' i) R"
    using I'_def assms(1) assms(3) by auto
  moreover have "\<And>i j. \<lbrakk> i \<le> Suc n; j \<le> Suc n; i \<noteq> j \<rbrakk> \<Longrightarrow> I' i <+> I' j = carrier R"
    using I'_def assms(2-3) by force
  ultimately have "(\<Inter> i \<le> n. I' i) <+> (I' (Suc n)) = carrier R"
    using inter_plus_ideal_eq_carrier by simp

  moreover have "I' ` {..n} = I ` ({..(Suc n)} - { j })"
  proof
    show "I' ` {..n} \<subseteq> I ` ({..Suc n} - {j})"
    proof
      fix x assume "x \<in> I' ` {..n}"
      then obtain i where i: "i \<in> {..n}" "I' i = x" by blast
      thus "x \<in> I ` ({..Suc n} - {j})"
      proof (cases)
        assume "i = j" thus ?thesis using i I'_def by auto
      next
        assume "i \<noteq> j" thus ?thesis using I'_def i insert_iff by auto
      qed
    qed
  next
    show "I ` ({..Suc n} - {j}) \<subseteq> I' ` {..n}"
    proof
      fix x assume "x \<in> I ` ({..Suc n} - {j})"
      then obtain i where i: "i \<in> {..Suc n}" "i \<noteq> j" "I i = x" by blast
      thus "x \<in> I' ` {..n}"
      proof (cases)
        assume "i = Suc n" thus ?thesis using I'_def assms(3) i(2-3) by auto
      next
        assume "i \<noteq> Suc n" thus ?thesis using I'_def i by auto
      qed
    qed
  qed
  ultimately show ?thesis using I'_def by metis
qed

subsection \<open>Another Characterization of Prime Ideals\<close>

text \<open>With product of ideals being defined, we can give another definition of a prime ideal\<close>

lemma (in ring) primeideal_divides_ideal_prod:
  assumes "primeideal P R" "ideal I R" "ideal J R"
      and "I \<cdot> J \<subseteq> P"
    shows "I \<subseteq> P \<or> J \<subseteq> P"
proof (cases)
  assume "\<exists> i \<in> I. i \<notin> P"
  then obtain i where i: "i \<in> I" "i \<notin> P" by blast
  have "J \<subseteq> P"
  proof
    fix j assume j: "j \<in> J"
    hence "i \<otimes> j \<in> P"
      using ideal_prod.prod[OF i(1) j, of R] assms(4) by auto
    thus "j \<in> P"
      using primeideal.I_prime[OF assms(1), of i j] i j
      by (meson assms(2-3) ideal.Icarr)
  qed
  thus ?thesis by blast
next
  assume "\<not> (\<exists> i \<in> I. i \<notin> P)" thus ?thesis by blast
qed

lemma (in cring) divides_ideal_prod_imp_primeideal:
  assumes "ideal P R"
    and "P \<noteq> carrier R"
    and "\<And>I J. \<lbrakk> ideal I R; ideal J R; I \<cdot> J \<subseteq> P \<rbrakk> \<Longrightarrow> I \<subseteq> P \<or> J \<subseteq> P"
  shows "primeideal P R"
proof -
  have "\<And>a b. \<lbrakk> a \<in> carrier R; b \<in> carrier R; a \<otimes> b \<in> P \<rbrakk> \<Longrightarrow> a \<in> P \<or> b \<in> P"
  proof -
    fix a b assume A: "a \<in> carrier R" "b \<in> carrier R" "a \<otimes> b \<in> P"
    have "(PIdl a) \<cdot> (PIdl b) = Idl (PIdl (a \<otimes> b))"
      using ideal_prod_eq_genideal[of "Idl { a }" "Idl { b }"]
            A(1-2) cgenideal_eq_genideal cgenideal_ideal cgenideal_prod by auto
    hence "(PIdl a) \<cdot> (PIdl b) = PIdl (a \<otimes> b)"
      by (simp add: A Idl_subset_ideal cgenideal_ideal cgenideal_minimal
                    genideal_self oneideal subset_antisym)
    hence "(PIdl a) \<cdot> (PIdl b) \<subseteq> P"
      by (simp add: A(3) assms(1) cgenideal_minimal)
    hence "(PIdl a) \<subseteq> P \<or> (PIdl b) \<subseteq> P"
      by (simp add: A assms(3) cgenideal_ideal)
    thus "a \<in> P \<or> b \<in> P"
      using A cgenideal_self by blast
  qed
  thus ?thesis
    using assms is_cring by (simp add: primeidealI)
qed

end


section {* \isaheader{Operations on sorted Lists} *}
theory Sorted_List_Operations
imports Main "../../Automatic_Refinement/Lib/Misc"
begin

fun inter_sorted :: "'a::{linorder} list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
   "inter_sorted [] l2 = []"
 | "inter_sorted l1 [] = []"
 | "inter_sorted (x1 # l1) (x2 # l2) =
    (if (x1 < x2) then (inter_sorted l1 (x2 # l2)) else
     (if (x1 = x2) then x1 # (inter_sorted l1 l2) else inter_sorted (x1 # l1) l2))"

lemma inter_sorted_correct :
assumes l1_OK: "distinct l1 \<and> sorted l1"
assumes l2_OK: "distinct l2 \<and> sorted l2"
shows "distinct (inter_sorted l1 l2) \<and> sorted (inter_sorted l1 l2) \<and>
       set (inter_sorted l1 l2) = set l1 \<inter> set l2"
using assms
proof (induct l1 arbitrary: l2)
  case Nil thus ?case by simp
next
  case (Cons x1 l1 l2)
  note x1_l1_props = Cons(2)
  note l2_props = Cons(3)

  from x1_l1_props have l1_props: "distinct l1 \<and> sorted l1"
                    and x1_nin_l1: "x1 \<notin> set l1"
                    and x1_le: "\<And>x. x \<in> set l1 \<Longrightarrow> x1 \<le> x"
    by (simp_all add: sorted_Cons Ball_def)

  note ind_hyp_l1 = Cons(1)[OF l1_props]

  show ?case
  using l2_props
  proof (induct l2)
    case Nil with x1_l1_props show ?case by simp
  next
    case (Cons x2 l2)
    note x2_l2_props = Cons(2)
    from x2_l2_props have l2_props: "distinct l2 \<and> sorted l2"
                    and x2_nin_l2: "x2 \<notin> set l2"
                    and x2_le: "\<And>x. x \<in> set l2 \<Longrightarrow> x2 \<le> x"
    by (simp_all add: sorted_Cons Ball_def)

    note ind_hyp_l2 = Cons(1)[OF l2_props]
    show ?case
    proof (cases "x1 < x2")
      case True note x1_less_x2 = this

      from ind_hyp_l1[OF x2_l2_props] x1_less_x2 x1_nin_l1 x1_le x2_le
      show ?thesis
        apply (auto simp add: sorted_Cons Ball_def)
        apply (metis linorder_not_le)
      done
    next
      case False note x2_le_x1 = this

      show ?thesis
      proof (cases "x1 = x2")
        case True note x1_eq_x2 = this

        from ind_hyp_l1[OF l2_props] x1_le x2_le x2_nin_l2 x1_eq_x2 x1_nin_l1
        show ?thesis by (simp add: x1_eq_x2 sorted_Cons Ball_def)
      next
        case False note x1_neq_x2 = this
        with x2_le_x1 have x2_less_x1 : "x2 < x1" by auto

        from ind_hyp_l2 x2_le_x1 x1_neq_x2 x2_le x2_nin_l2 x1_le
        show ?thesis
          apply (auto simp add: x2_less_x1 sorted_Cons Ball_def)
          apply (metis linorder_not_le x2_less_x1)
        done
      qed
    qed
  qed
qed

fun diff_sorted :: "'a::{linorder} list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
   "diff_sorted [] l2 = []"
 | "diff_sorted l1 [] = l1"
 | "diff_sorted (x1 # l1) (x2 # l2) =
    (if (x1 < x2) then x1 # (diff_sorted l1 (x2 # l2)) else
     (if (x1 = x2) then (diff_sorted l1 l2) else diff_sorted (x1 # l1) l2))"

lemma diff_sorted_correct :
assumes l1_OK: "distinct l1 \<and> sorted l1"
assumes l2_OK: "distinct l2 \<and> sorted l2"
shows "distinct (diff_sorted l1 l2) \<and> sorted (diff_sorted l1 l2) \<and>
       set (diff_sorted l1 l2) = set l1 - set l2"
using assms
proof (induct l1 arbitrary: l2)
  case Nil thus ?case by simp
next
  case (Cons x1 l1 l2)
  note x1_l1_props = Cons(2)
  note l2_props = Cons(3)

  from x1_l1_props have l1_props: "distinct l1 \<and> sorted l1"
                    and x1_nin_l1: "x1 \<notin> set l1"
                    and x1_le: "\<And>x. x \<in> set l1 \<Longrightarrow> x1 \<le> x"
    by (simp_all add: sorted_Cons Ball_def)

  note ind_hyp_l1 = Cons(1)[OF l1_props]

  show ?case
  using l2_props
  proof (induct l2)
    case Nil with x1_l1_props show ?case by simp
  next
    case (Cons x2 l2)
    note x2_l2_props = Cons(2)
    from x2_l2_props have l2_props: "distinct l2 \<and> sorted l2"
                    and x2_nin_l2: "x2 \<notin> set l2"
                    and x2_le: "\<And>x. x \<in> set l2 \<Longrightarrow> x2 \<le> x"
    by (simp_all add: sorted_Cons Ball_def)

    note ind_hyp_l2 = Cons(1)[OF l2_props]
    show ?case
    proof (cases "x1 < x2")
      case True note x1_less_x2 = this

      from ind_hyp_l1[OF x2_l2_props] x1_less_x2 x1_nin_l1 x1_le x2_le
      show ?thesis
        apply simp
        apply (simp add: sorted_Cons Ball_def set_eq_iff)
        apply (metis linorder_not_le order_less_imp_not_eq2)
      done
    next
      case False note x2_le_x1 = this

      show ?thesis
      proof (cases "x1 = x2")
        case True note x1_eq_x2 = this

        from ind_hyp_l1[OF l2_props] x1_le x2_le x2_nin_l2 x1_eq_x2 x1_nin_l1
        show ?thesis by (simp add: x1_eq_x2 sorted_Cons Ball_def)
      next
        case False note x1_neq_x2 = this
        with x2_le_x1 have x2_less_x1 : "x2 < x1" by auto

        from x2_less_x1 x1_le have x2_nin_l1: "x2 \<notin> set l1"
           by (metis linorder_not_less)

        from ind_hyp_l2 x1_le x2_nin_l1
        show ?thesis
          apply (simp add: x2_less_x1 x1_neq_x2 x2_le_x1 x1_nin_l1 sorted_Cons Ball_def set_eq_iff)
          apply (metis x1_neq_x2)
        done
      qed
    qed
  qed
qed

fun subset_sorted :: "'a::{linorder} list \<Rightarrow> 'a list \<Rightarrow> bool" where
   "subset_sorted [] l2 = True"
 | "subset_sorted (x1 # l1) [] = False"
 | "subset_sorted (x1 # l1) (x2 # l2) =
    (if (x1 < x2) then False else
     (if (x1 = x2) then (subset_sorted l1 l2) else subset_sorted (x1 # l1) l2))"

lemma subset_sorted_correct :
assumes l1_OK: "distinct l1 \<and> sorted l1"
assumes l2_OK: "distinct l2 \<and> sorted l2"
shows "subset_sorted l1 l2 \<longleftrightarrow> set l1 \<subseteq> set l2"
using assms
proof (induct l1 arbitrary: l2)
  case Nil thus ?case by simp
next
  case (Cons x1 l1 l2)
  note x1_l1_props = Cons(2)
  note l2_props = Cons(3)

  from x1_l1_props have l1_props: "distinct l1 \<and> sorted l1"
                    and x1_nin_l1: "x1 \<notin> set l1"
                    and x1_le: "\<And>x. x \<in> set l1 \<Longrightarrow> x1 \<le> x"
    by (simp_all add: sorted_Cons Ball_def)

  note ind_hyp_l1 = Cons(1)[OF l1_props]

  show ?case
  using l2_props
  proof (induct l2)
    case Nil with x1_l1_props show ?case by simp
  next
    case (Cons x2 l2)
    note x2_l2_props = Cons(2)
    from x2_l2_props have l2_props: "distinct l2 \<and> sorted l2"
                    and x2_nin_l2: "x2 \<notin> set l2"
                    and x2_le: "\<And>x. x \<in> set l2 \<Longrightarrow> x2 \<le> x"
    by (simp_all add: sorted_Cons Ball_def)

    note ind_hyp_l2 = Cons(1)[OF l2_props]
    show ?case
    proof (cases "x1 < x2")
      case True note x1_less_x2 = this

      from ind_hyp_l1[OF x2_l2_props] x1_less_x2 x1_nin_l1 x1_le x2_le
      show ?thesis
        apply (auto simp add: sorted_Cons Ball_def)
        apply (metis linorder_not_le)
      done
    next
      case False note x2_le_x1 = this

      show ?thesis
      proof (cases "x1 = x2")
        case True note x1_eq_x2 = this

        from ind_hyp_l1[OF l2_props] x1_le x2_le x2_nin_l2 x1_eq_x2 x1_nin_l1
        show ?thesis
          apply (simp add: subset_iff x1_eq_x2 sorted_Cons Ball_def)
          apply metis
        done
      next
        case False note x1_neq_x2 = this
        with x2_le_x1 have x2_less_x1 : "x2 < x1" by auto

        from ind_hyp_l2 x2_le_x1 x1_neq_x2 x2_le x2_nin_l2 x1_le
        show ?thesis
          apply (simp add: subset_iff x2_less_x1 sorted_Cons Ball_def)
          apply (metis linorder_not_le x2_less_x1)
        done
      qed
    qed
  qed
qed

lemma set_eq_sorted_correct :
  assumes l1_OK: "distinct l1 \<and> sorted l1"
  assumes l2_OK: "distinct l2 \<and> sorted l2"
  shows "l1 = l2 \<longleftrightarrow> set l1 = set l2"
  using assms
proof -
  have l12_eq: "l1 = l2 \<longleftrightarrow> subset_sorted l1 l2 \<and> subset_sorted l2 l1"
  proof (induct l1 arbitrary: l2)
    case Nil thus ?case by (cases l2) auto
  next
    case (Cons x1 l1')
    note ind_hyp = Cons(1)

    show ?case
    proof (cases l2)
      case Nil thus ?thesis by simp
    next
      case (Cons x2 l2')
      thus ?thesis by (simp add: ind_hyp)
    qed
  qed
  also have "\<dots> \<longleftrightarrow> ((set l1 \<subseteq> set l2) \<and> (set l2 \<subseteq> set l1))"
    using subset_sorted_correct[OF l1_OK l2_OK] subset_sorted_correct[OF l2_OK l1_OK]
    by simp
  also have "\<dots> \<longleftrightarrow> set l1 = set l2" by auto
  finally show ?thesis .
qed

fun memb_sorted where
   "memb_sorted [] x = False"
 | "memb_sorted (y # xs) x =
    (if (y < x) then memb_sorted xs x else (x = y))"

lemma memb_sorted_correct :
  "sorted xs \<Longrightarrow> memb_sorted xs x \<longleftrightarrow> x \<in> set xs"
by (induct xs) (auto simp add: sorted_Cons Ball_def)

fun insertion_sort where
   "insertion_sort x [] = [x]"
 | "insertion_sort x (y # xs) =
    (if (y < x) then y # insertion_sort x xs else
     (if (x = y) then y # xs else x # y # xs))"

lemma insertion_sort_correct :
  "sorted xs \<Longrightarrow> distinct xs \<Longrightarrow>
   distinct (insertion_sort x xs) \<and>
   sorted (insertion_sort x xs) \<and>
   set (insertion_sort x xs) = set (x # xs)"
by (induct xs) (auto simp add: sorted_Cons Ball_def)

fun delete_sorted where
   "delete_sorted x [] = []"
 | "delete_sorted x (y # xs) =
    (if (y < x) then y # delete_sorted x xs else
     (if (x = y) then xs else y # xs))"

lemma delete_sorted_correct :
  "sorted xs \<Longrightarrow> distinct xs \<Longrightarrow>
   distinct (delete_sorted x xs) \<and>
   sorted (delete_sorted x xs) \<and>
   set (delete_sorted x xs) = set xs - {x}"
apply (induct xs)
apply simp
apply (simp add: sorted_Cons Ball_def set_eq_iff)
apply (metis order_less_le)
done

end