(* Author: Christian Urban, Xingyuan Zhang, Chunhan Wu *)
theory Closures
imports Myhill "~~/src/HOL/Library/Infinite_Set"
begin

section {* Closure properties of regular languages *}

abbreviation
  regular :: "'a lang \<Rightarrow> bool"
where
  "regular A \<equiv> \<exists>r. A = lang r"

subsection {* Closure under @{text "\<union>"}, @{text "\<cdot>"} and @{text "\<star>"} *}

lemma closure_union [intro]:
  assumes "regular A" "regular B"
  shows "regular (A \<union> B)"
proof -
  from assms obtain r1 r2::"'a rexp" where "lang r1 = A" "lang r2 = B" by auto
  then have "A \<union> B = lang (Plus r1 r2)" by simp
  then show "regular (A \<union> B)" by blast
qed

lemma closure_seq [intro]:
  assumes "regular A" "regular B"
  shows "regular (A \<cdot> B)"
proof -
  from assms obtain r1 r2::"'a rexp" where "lang r1 = A" "lang r2 = B" by auto
  then have "A \<cdot> B = lang (Times r1 r2)" by simp
  then show "regular (A \<cdot> B)" by blast
qed

lemma closure_star [intro]:
  assumes "regular A"
  shows "regular (A\<star>)"
proof -
  from assms obtain r::"'a rexp" where "lang r = A" by auto
  then have "A\<star> = lang (Star r)" by simp
  then show "regular (A\<star>)" by blast
qed

subsection {* Closure under complementation *}

text {* Closure under complementation is proved via the
  Myhill-Nerode theorem *}

lemma closure_complement [intro]:
  fixes A::"('a::finite) lang"
  assumes "regular A"
  shows "regular (- A)"
proof -
  from assms have "finite (UNIV // \<approx>A)" by (simp add: Myhill_Nerode)
  then have "finite (UNIV // \<approx>(-A))" by (simp add: str_eq_def)
  then show "regular (- A)" by (simp add: Myhill_Nerode)
qed

subsection {* Closure under @{text "-"} and @{text "\<inter>"} *}

lemma closure_difference [intro]:
  fixes A::"('a::finite) lang"
  assumes "regular A" "regular B"
  shows "regular (A - B)"
proof -
  have "A - B = - (- A \<union> B)" by blast
  moreover
  have "regular (- (- A \<union> B))"
    using assms by blast
  ultimately show "regular (A - B)" by simp
qed

lemma closure_intersection [intro]:
  fixes A::"('a::finite) lang"
  assumes "regular A" "regular B"
  shows "regular (A \<inter> B)"
proof -
  have "A \<inter> B = - (- A \<union> - B)" by blast
  moreover
  have "regular (- (- A \<union> - B))"
    using assms by blast
  ultimately show "regular (A \<inter> B)" by simp
qed

subsection {* Closure under string reversal *}

fun
  Rev :: "'a rexp \<Rightarrow> 'a rexp"
where
  "Rev Zero = Zero"
| "Rev One = One"
| "Rev (Atom c) = Atom c"
| "Rev (Plus r1 r2) = Plus (Rev r1) (Rev r2)"
| "Rev (Times r1 r2) = Times (Rev r2) (Rev r1)"
| "Rev (Star r) = Star (Rev r)"

lemma rev_seq[simp]:
  shows "rev ` (B \<cdot> A) = (rev ` A) \<cdot> (rev ` B)"
unfolding conc_def image_def
by (auto) (metis rev_append)+

lemma rev_star1:
  assumes a: "s \<in> (rev ` A)\<star>"
  shows "s \<in> rev ` (A\<star>)"
using a
proof(induct rule: star_induct)
  case (append s1 s2)
  have inj: "inj (rev::'a list \<Rightarrow> 'a list)" unfolding inj_on_def by auto
  have "s1 \<in> rev ` A" "s2 \<in> rev ` (A\<star>)" by fact+
  then obtain x1 x2 where "x1 \<in> A" "x2 \<in> A\<star>" and eqs: "s1 = rev x1" "s2 = rev x2" by auto
  then have "x1 \<in> A\<star>" "x2 \<in> A\<star>" by (auto)
  then have "x2 @ x1 \<in> A\<star>" by (auto)
  then have "rev (x2 @ x1) \<in> rev ` A\<star>" using inj by (simp only: inj_image_mem_iff)
  then show "s1 @ s2 \<in>  rev ` A\<star>" using eqs by simp
qed (auto)

lemma rev_star2:
  assumes a: "s \<in> A\<star>"
  shows "rev s \<in> (rev ` A)\<star>"
using a
proof(induct rule: star_induct)
  case (append s1 s2)
  have inj: "inj (rev::'a list \<Rightarrow> 'a list)" unfolding inj_on_def by auto
  have "s1 \<in> A"by fact
  then have "rev s1 \<in> rev ` A" using inj by (simp only: inj_image_mem_iff)
  then have "rev s1 \<in> (rev ` A)\<star>" by (auto)
  moreover
  have "rev s2 \<in> (rev ` A)\<star>" by fact
  ultimately show "rev (s1 @ s2) \<in>  (rev ` A)\<star>" by (auto)
qed (auto)

lemma rev_star [simp]:
  shows " rev ` (A\<star>) = (rev ` A)\<star>"
using rev_star1 rev_star2 by auto

lemma rev_lang:
  shows "rev ` (lang r) = lang (Rev r)"
by (induct r) (simp_all add: image_Un)

lemma closure_reversal [intro]:
  assumes "regular A"
  shows "regular (rev ` A)"
proof -
  from assms obtain r::"'a rexp" where "A = lang r" by auto
  then have "lang (Rev r) = rev ` A" by (simp add: rev_lang)
  then show "regular (rev` A)" by blast
qed

subsection {* Closure under left-quotients *}

abbreviation
  "Deriv_lang A B \<equiv> \<Union>x \<in> A. Derivs x B"

lemma closure_left_quotient:
  assumes "regular A"
  shows "regular (Deriv_lang B A)"
proof -
  from assms obtain r::"'a rexp" where eq: "lang r = A" by auto
  have fin: "finite (pderivs_lang B r)" by (rule finite_pderivs_lang)

  have "Deriv_lang B (lang r) = (\<Union> (lang ` pderivs_lang B r))"
    by (simp add: Derivs_pderivs pderivs_lang_def)
  also have "\<dots> = lang (\<Uplus>(pderivs_lang B r))" using fin by simp
  finally have "Deriv_lang B A = lang (\<Uplus>(pderivs_lang B r))" using eq
    by simp
  then show "regular (Deriv_lang B A)" by auto
qed

subsection {* Finite and co-finite sets are regular *}

lemma singleton_regular:
  shows "regular {s}"
proof (induct s)
  case Nil
  have "{[]} = lang (One)" by simp
  then show "regular {[]}" by blast
next
  case (Cons c s)
  have "regular {s}" by fact
  then obtain r where "{s} = lang r" by blast
  then have "{c # s} = lang (Times (Atom c) r)"
    by (auto simp add: conc_def)
  then show "regular {c # s}" by blast
qed

lemma finite_regular:
  assumes "finite A"
  shows "regular A"
using assms
proof (induct)
  case empty
  have "{} = lang (Zero)" by simp
  then show "regular {}" by blast
next
  case (insert s A)
  have "regular {s}" by (simp add: singleton_regular)
  moreover
  have "regular A" by fact
  ultimately have "regular ({s} \<union> A)" by (rule closure_union)
  then show "regular (insert s A)" by simp
qed

lemma cofinite_regular:
  fixes A::"'a::finite lang"
  assumes "finite (- A)"
  shows "regular A"
proof -
  from assms have "regular (- A)" by (simp add: finite_regular)
  then have "regular (-(- A))" by (rule closure_complement)
  then show "regular A" by simp
qed

subsection {* Continuation lemma for showing non-regularity of languages *}

lemma continuation_lemma:
  fixes A B::"'a::finite lang"
  assumes reg: "regular A"
  and     inf: "infinite B"
  shows "\<exists>x \<in> B. \<exists>y \<in> B. x \<noteq> y \<and> x \<approx>A y"
proof -
  def eqfun \<equiv> "\<lambda>A x::('a::finite list). (\<approx>A) `` {x}"
  have "finite (UNIV // \<approx>A)" using reg by (simp add: Myhill_Nerode)
  moreover
  have "(eqfun A) ` B \<subseteq> UNIV // (\<approx>A)"
    unfolding eqfun_def quotient_def by auto
  ultimately have "finite ((eqfun A) ` B)" by (rule rev_finite_subset)
  with inf have "\<exists>a \<in> B. infinite {b \<in> B. eqfun A b = eqfun A a}"
    by (rule pigeonhole_infinite)
  then obtain a where in_a: "a \<in> B" and "infinite {b \<in> B. eqfun A b = eqfun A a}"
    by blast
  moreover
  have "{b \<in> B. eqfun A b = eqfun A a} = {b \<in> B. b \<approx>A a}"
    unfolding eqfun_def Image_def str_eq_def by auto
  ultimately have "infinite {b \<in> B. b \<approx>A a}" by simp
  then have "infinite ({b \<in> B. b \<approx>A a} - {a})" by simp
  moreover
  have "{b \<in> B. b \<approx>A a} - {a} = {b \<in> B. b \<approx>A a \<and> b \<noteq> a}" by auto
  ultimately have "infinite {b \<in> B. b \<approx>A a \<and> b \<noteq> a}" by simp
  then have "{b \<in> B. b \<approx>A a \<and> b \<noteq> a} \<noteq> {}"
    by (metis finite.emptyI)
  then obtain b where "b \<in> B" "b \<noteq> a" "b \<approx>A a" by blast
  with in_a show "\<exists>x \<in> B. \<exists>y \<in> B. x \<noteq> y \<and> x \<approx>A y"
    by blast
qed

subsection {* The language @{text "a\<^sup>n b\<^sup>n"} is not regular *}

abbreviation
  replicate_rev ("_ ^^^ _" [100, 100] 100)
where
  "a ^^^ n \<equiv> replicate n a"

lemma an_bn_not_regular:
  shows "\<not> regular (\<Union>n. {CHR ''a'' ^^^ n @ CHR ''b'' ^^^ n})"
proof
  def A\<equiv>"\<Union>n. {CHR ''a'' ^^^ n @ CHR ''b'' ^^^ n}"
  def B\<equiv>"\<Union>n. {CHR ''a'' ^^^ n}"
  assume as: "regular A"
  def B\<equiv>"\<Union>n. {CHR ''a'' ^^^ n}"

  have sameness: "\<And>i j. CHR ''a'' ^^^ i @ CHR ''b'' ^^^ j \<in> A \<longleftrightarrow> i = j"
    unfolding A_def
    apply auto
    apply(drule_tac f="\<lambda>s. length (filter (op= (CHR ''a'')) s) = length (filter (op= (CHR ''b'')) s)"
      in arg_cong)
    apply(simp)
    done

  have b: "infinite B"
    unfolding infinite_iff_countable_subset
    unfolding inj_on_def B_def
    by (rule_tac x="\<lambda>n. CHR ''a'' ^^^ n" in exI) (auto)
  moreover
  have "\<forall>x \<in> B. \<forall>y \<in> B. x \<noteq> y \<longrightarrow> \<not> (x \<approx>A y)"
    apply(auto)
    unfolding B_def
    apply(auto)
    apply(simp add: str_eq_def)
    apply(drule_tac x="CHR ''b'' ^^^ n" in spec)
    apply(simp add: sameness)
    done
  ultimately
  show "False" using continuation_lemma[OF as] by blast
qed

end


(*  Title:      HOL/Library/Boolean_Algebra.thy
    Author:     Brian Huffman
*)

section \<open>Boolean Algebras\<close>

theory Boolean_Algebra
  imports Main
begin

locale boolean_algebra = conj: abel_semigroup "(\<^bold>\<sqinter>)" + disj: abel_semigroup "(\<^bold>\<squnion>)"
  for conj :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"  (infixr "\<^bold>\<sqinter>" 70)
    and disj :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"  (infixr "\<^bold>\<squnion>" 65) +
  fixes compl :: "'a \<Rightarrow> 'a"  ("\<sim> _" [81] 80)
    and zero :: "'a"  ("\<zero>")
    and one  :: "'a"  ("\<one>")
  assumes conj_disj_distrib: "x \<^bold>\<sqinter> (y \<^bold>\<squnion> z) = (x \<^bold>\<sqinter> y) \<^bold>\<squnion> (x \<^bold>\<sqinter> z)"
    and disj_conj_distrib: "x \<^bold>\<squnion> (y \<^bold>\<sqinter> z) = (x \<^bold>\<squnion> y) \<^bold>\<sqinter> (x \<^bold>\<squnion> z)"
    and conj_one_right: "x \<^bold>\<sqinter> \<one> = x"
    and disj_zero_right: "x \<^bold>\<squnion> \<zero> = x"
    and conj_cancel_right [simp]: "x \<^bold>\<sqinter> \<sim> x = \<zero>"
    and disj_cancel_right [simp]: "x \<^bold>\<squnion> \<sim> x = \<one>"
begin

sublocale conj: semilattice_neutr "(\<^bold>\<sqinter>)" "\<one>"
proof
  show "x \<^bold>\<sqinter> \<one> = x" for x
    by (fact conj_one_right)
  show "x \<^bold>\<sqinter> x = x" for x
  proof -
    have "x \<^bold>\<sqinter> x = (x \<^bold>\<sqinter> x) \<^bold>\<squnion> \<zero>"
      by (simp add: disj_zero_right)
    also have "\<dots> = (x \<^bold>\<sqinter> x) \<^bold>\<squnion> (x \<^bold>\<sqinter> \<sim> x)"
      by simp
    also have "\<dots> = x \<^bold>\<sqinter> (x \<^bold>\<squnion> \<sim> x)"
      by (simp only: conj_disj_distrib)
    also have "\<dots> = x \<^bold>\<sqinter> \<one>"
      by simp
    also have "\<dots> = x"
      by (simp add: conj_one_right)
    finally show ?thesis .
  qed
qed

sublocale disj: semilattice_neutr "(\<^bold>\<squnion>)" "\<zero>"
proof
  show "x \<^bold>\<squnion> \<zero> = x" for x
    by (fact disj_zero_right)
  show "x \<^bold>\<squnion> x = x" for x
  proof -
    have "x \<^bold>\<squnion> x = (x \<^bold>\<squnion> x) \<^bold>\<sqinter> \<one>"
      by simp
    also have "\<dots> = (x \<^bold>\<squnion> x) \<^bold>\<sqinter> (x \<^bold>\<squnion> \<sim> x)"
      by simp
    also have "\<dots> = x \<^bold>\<squnion> (x \<^bold>\<sqinter> \<sim> x)"
      by (simp only: disj_conj_distrib)
    also have "\<dots> = x \<^bold>\<squnion> \<zero>"
      by simp
    also have "\<dots> = x"
      by (simp add: disj_zero_right)
    finally show ?thesis .
  qed
qed

subsection \<open>Complement\<close>

lemma complement_unique:
  assumes 1: "a \<^bold>\<sqinter> x = \<zero>"
  assumes 2: "a \<^bold>\<squnion> x = \<one>"
  assumes 3: "a \<^bold>\<sqinter> y = \<zero>"
  assumes 4: "a \<^bold>\<squnion> y = \<one>"
  shows "x = y"
proof -
  from 1 3 have "(a \<^bold>\<sqinter> x) \<^bold>\<squnion> (x \<^bold>\<sqinter> y) = (a \<^bold>\<sqinter> y) \<^bold>\<squnion> (x \<^bold>\<sqinter> y)"
    by simp
  then have "(x \<^bold>\<sqinter> a) \<^bold>\<squnion> (x \<^bold>\<sqinter> y) = (y \<^bold>\<sqinter> a) \<^bold>\<squnion> (y \<^bold>\<sqinter> x)"
    by (simp add: ac_simps)
  then have "x \<^bold>\<sqinter> (a \<^bold>\<squnion> y) = y \<^bold>\<sqinter> (a \<^bold>\<squnion> x)"
    by (simp add: conj_disj_distrib)
  with 2 4 have "x \<^bold>\<sqinter> \<one> = y \<^bold>\<sqinter> \<one>"
    by simp
  then show "x = y"
    by simp
qed

lemma compl_unique: "x \<^bold>\<sqinter> y = \<zero> \<Longrightarrow> x \<^bold>\<squnion> y = \<one> \<Longrightarrow> \<sim> x = y"
  by (rule complement_unique [OF conj_cancel_right disj_cancel_right])

lemma double_compl [simp]: "\<sim> (\<sim> x) = x"
proof (rule compl_unique)
  show "\<sim> x \<^bold>\<sqinter> x = \<zero>"
    by (simp only: conj_cancel_right conj.commute)
  show "\<sim> x \<^bold>\<squnion> x = \<one>"
    by (simp only: disj_cancel_right disj.commute)
qed

lemma compl_eq_compl_iff [simp]: "\<sim> x = \<sim> y \<longleftrightarrow> x = y"
  by (rule inj_eq [OF inj_on_inverseI]) (rule double_compl)

subsection \<open>Conjunction\<close>

lemma conj_zero_right [simp]: "x \<^bold>\<sqinter> \<zero> = \<zero>"
  using conj.left_idem conj_cancel_right by fastforce

lemma compl_one [simp]: "\<sim> \<one> = \<zero>"
  by (rule compl_unique [OF conj_zero_right disj_zero_right])

lemma conj_zero_left [simp]: "\<zero> \<^bold>\<sqinter> x = \<zero>"
  by (subst conj.commute) (rule conj_zero_right)

lemma conj_cancel_left [simp]: "\<sim> x \<^bold>\<sqinter> x = \<zero>"
  by (subst conj.commute) (rule conj_cancel_right)

lemma conj_disj_distrib2: "(y \<^bold>\<squnion> z) \<^bold>\<sqinter> x = (y \<^bold>\<sqinter> x) \<^bold>\<squnion> (z \<^bold>\<sqinter> x)"
  by (simp only: conj.commute conj_disj_distrib)

lemmas conj_disj_distribs = conj_disj_distrib conj_disj_distrib2

lemma conj_assoc: "(x \<^bold>\<sqinter> y) \<^bold>\<sqinter> z = x \<^bold>\<sqinter> (y \<^bold>\<sqinter> z)"
  by (fact ac_simps)

lemma conj_commute: "x \<^bold>\<sqinter> y = y \<^bold>\<sqinter> x"
  by (fact ac_simps)

lemmas conj_left_commute = conj.left_commute
lemmas conj_ac = conj.assoc conj.commute conj.left_commute

lemma conj_one_left: "\<one> \<^bold>\<sqinter> x = x"
  by (fact conj.left_neutral)

lemma conj_left_absorb: "x \<^bold>\<sqinter> (x \<^bold>\<sqinter> y) = x \<^bold>\<sqinter> y"
  by (fact conj.left_idem)

lemma conj_absorb: "x \<^bold>\<sqinter> x = x"
  by (fact conj.idem)

subsection \<open>Disjunction\<close>

interpretation dual: boolean_algebra "(\<^bold>\<squnion>)" "(\<^bold>\<sqinter>)" compl \<one> \<zero>
  apply standard
       apply (rule disj_conj_distrib)
      apply (rule conj_disj_distrib)
     apply simp_all
  done

lemma compl_zero [simp]: "\<sim> \<zero> = \<one>"
  by (fact dual.compl_one)

lemma disj_one_right [simp]: "x \<^bold>\<squnion> \<one> = \<one>"
  by (fact dual.conj_zero_right)

lemma disj_one_left [simp]: "\<one> \<^bold>\<squnion> x = \<one>"
  by (fact dual.conj_zero_left)

lemma disj_cancel_left [simp]: "\<sim> x \<^bold>\<squnion> x = \<one>"
  by (rule dual.conj_cancel_left)

lemma disj_conj_distrib2: "(y \<^bold>\<sqinter> z) \<^bold>\<squnion> x = (y \<^bold>\<squnion> x) \<^bold>\<sqinter> (z \<^bold>\<squnion> x)"
  by (rule dual.conj_disj_distrib2)

lemmas disj_conj_distribs = disj_conj_distrib disj_conj_distrib2

lemma disj_assoc: "(x \<^bold>\<squnion> y) \<^bold>\<squnion> z = x \<^bold>\<squnion> (y \<^bold>\<squnion> z)"
  by (fact ac_simps)

lemma disj_commute: "x \<^bold>\<squnion> y = y \<^bold>\<squnion> x"
  by (fact ac_simps)

lemmas disj_left_commute = disj.left_commute

lemmas disj_ac = disj.assoc disj.commute disj.left_commute

lemma disj_zero_left: "\<zero> \<^bold>\<squnion> x = x"
  by (fact disj.left_neutral)

lemma disj_left_absorb: "x \<^bold>\<squnion> (x \<^bold>\<squnion> y) = x \<^bold>\<squnion> y"
  by (fact disj.left_idem)

lemma disj_absorb: "x \<^bold>\<squnion> x = x"
  by (fact disj.idem)

subsection \<open>De Morgan's Laws\<close>

lemma de_Morgan_conj [simp]: "\<sim> (x \<^bold>\<sqinter> y) = \<sim> x \<^bold>\<squnion> \<sim> y"
proof (rule compl_unique)
  have "(x \<^bold>\<sqinter> y) \<^bold>\<sqinter> (\<sim> x \<^bold>\<squnion> \<sim> y) = ((x \<^bold>\<sqinter> y) \<^bold>\<sqinter> \<sim> x) \<^bold>\<squnion> ((x \<^bold>\<sqinter> y) \<^bold>\<sqinter> \<sim> y)"
    by (rule conj_disj_distrib)
  also have "\<dots> = (y \<^bold>\<sqinter> (x \<^bold>\<sqinter> \<sim> x)) \<^bold>\<squnion> (x \<^bold>\<sqinter> (y \<^bold>\<sqinter> \<sim> y))"
    by (simp only: conj_ac)
  finally show "(x \<^bold>\<sqinter> y) \<^bold>\<sqinter> (\<sim> x \<^bold>\<squnion> \<sim> y) = \<zero>"
    by (simp only: conj_cancel_right conj_zero_right disj_zero_right)
next
  have "(x \<^bold>\<sqinter> y) \<^bold>\<squnion> (\<sim> x \<^bold>\<squnion> \<sim> y) = (x \<^bold>\<squnion> (\<sim> x \<^bold>\<squnion> \<sim> y)) \<^bold>\<sqinter> (y \<^bold>\<squnion> (\<sim> x \<^bold>\<squnion> \<sim> y))"
    by (rule disj_conj_distrib2)
  also have "\<dots> = (\<sim> y \<^bold>\<squnion> (x \<^bold>\<squnion> \<sim> x)) \<^bold>\<sqinter> (\<sim> x \<^bold>\<squnion> (y \<^bold>\<squnion> \<sim> y))"
    by (simp only: disj_ac)
  finally show "(x \<^bold>\<sqinter> y) \<^bold>\<squnion> (\<sim> x \<^bold>\<squnion> \<sim> y) = \<one>"
    by (simp only: disj_cancel_right disj_one_right conj_one_right)
qed

lemma de_Morgan_disj [simp]: "\<sim> (x \<^bold>\<squnion> y) = \<sim> x \<^bold>\<sqinter> \<sim> y"
  using dual.boolean_algebra_axioms by (rule boolean_algebra.de_Morgan_conj)

subsection \<open>Symmetric Difference\<close>

definition xor :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"  (infixr "\<oplus>" 65)
  where "x \<oplus> y = (x \<^bold>\<sqinter> \<sim> y) \<^bold>\<squnion> (\<sim> x \<^bold>\<sqinter> y)"

sublocale xor: comm_monoid xor \<zero>
proof
  fix x y z :: 'a
  let ?t = "(x \<^bold>\<sqinter> y \<^bold>\<sqinter> z) \<^bold>\<squnion> (x \<^bold>\<sqinter> \<sim> y \<^bold>\<sqinter> \<sim> z) \<^bold>\<squnion> (\<sim> x \<^bold>\<sqinter> y \<^bold>\<sqinter> \<sim> z) \<^bold>\<squnion> (\<sim> x \<^bold>\<sqinter> \<sim> y \<^bold>\<sqinter> z)"
  have "?t \<^bold>\<squnion> (z \<^bold>\<sqinter> x \<^bold>\<sqinter> \<sim> x) \<^bold>\<squnion> (z \<^bold>\<sqinter> y \<^bold>\<sqinter> \<sim> y) = ?t \<^bold>\<squnion> (x \<^bold>\<sqinter> y \<^bold>\<sqinter> \<sim> y) \<^bold>\<squnion> (x \<^bold>\<sqinter> z \<^bold>\<sqinter> \<sim> z)"
    by (simp only: conj_cancel_right conj_zero_right)
  then show "(x \<oplus> y) \<oplus> z = x \<oplus> (y \<oplus> z)"
    by (simp only: xor_def de_Morgan_disj de_Morgan_conj double_compl)
      (simp only: conj_disj_distribs conj_ac disj_ac)
  show "x \<oplus> y = y \<oplus> x"
    by (simp only: xor_def conj_commute disj_commute)
  show "x \<oplus> \<zero> = x"
    by (simp add: xor_def)
qed

lemmas xor_assoc = xor.assoc
lemmas xor_commute = xor.commute
lemmas xor_left_commute = xor.left_commute

lemmas xor_ac = xor.assoc xor.commute xor.left_commute

lemma xor_def2: "x \<oplus> y = (x \<^bold>\<squnion> y) \<^bold>\<sqinter> (\<sim> x \<^bold>\<squnion> \<sim> y)"
  using conj.commute conj_disj_distrib2 disj.commute xor_def by auto

lemma xor_zero_right [simp]: "x \<oplus> \<zero> = x"
  by (simp only: xor_def compl_zero conj_one_right conj_zero_right disj_zero_right)

lemma xor_zero_left [simp]: "\<zero> \<oplus> x = x"
  by (subst xor_commute) (rule xor_zero_right)

lemma xor_one_right [simp]: "x \<oplus> \<one> = \<sim> x"
  by (simp only: xor_def compl_one conj_zero_right conj_one_right disj_zero_left)

lemma xor_one_left [simp]: "\<one> \<oplus> x = \<sim> x"
  by (subst xor_commute) (rule xor_one_right)

lemma xor_self [simp]: "x \<oplus> x = \<zero>"
  by (simp only: xor_def conj_cancel_right conj_cancel_left disj_zero_right)

lemma xor_left_self [simp]: "x \<oplus> (x \<oplus> y) = y"
  by (simp only: xor_assoc [symmetric] xor_self xor_zero_left)

lemma xor_compl_left [simp]: "\<sim> x \<oplus> y = \<sim> (x \<oplus> y)"
  by (metis xor_assoc xor_one_left)

lemma xor_compl_right [simp]: "x \<oplus> \<sim> y = \<sim> (x \<oplus> y)"
  using xor_commute xor_compl_left by auto

lemma xor_cancel_right: "x \<oplus> \<sim> x = \<one>"
  by (simp only: xor_compl_right xor_self compl_zero)

lemma xor_cancel_left: "\<sim> x \<oplus> x = \<one>"
  by (simp only: xor_compl_left xor_self compl_zero)

lemma conj_xor_distrib: "x \<^bold>\<sqinter> (y \<oplus> z) = (x \<^bold>\<sqinter> y) \<oplus> (x \<^bold>\<sqinter> z)"
proof -
  have *: "(x \<^bold>\<sqinter> y \<^bold>\<sqinter> \<sim> z) \<^bold>\<squnion> (x \<^bold>\<sqinter> \<sim> y \<^bold>\<sqinter> z) =
        (y \<^bold>\<sqinter> x \<^bold>\<sqinter> \<sim> x) \<^bold>\<squnion> (z \<^bold>\<sqinter> x \<^bold>\<sqinter> \<sim> x) \<^bold>\<squnion> (x \<^bold>\<sqinter> y \<^bold>\<sqinter> \<sim> z) \<^bold>\<squnion> (x \<^bold>\<sqinter> \<sim> y \<^bold>\<sqinter> z)"
    by (simp only: conj_cancel_right conj_zero_right disj_zero_left)
  then show "x \<^bold>\<sqinter> (y \<oplus> z) = (x \<^bold>\<sqinter> y) \<oplus> (x \<^bold>\<sqinter> z)"
    by (simp (no_asm_use) only:
        xor_def de_Morgan_disj de_Morgan_conj double_compl
        conj_disj_distribs conj_ac disj_ac)
qed

lemma conj_xor_distrib2: "(y \<oplus> z) \<^bold>\<sqinter> x = (y \<^bold>\<sqinter> x) \<oplus> (z \<^bold>\<sqinter> x)"
  by (simp add: conj.commute conj_xor_distrib)

lemmas conj_xor_distribs = conj_xor_distrib conj_xor_distrib2

end

end


theory Week3
  imports Main
begin

(*McGee against MP*)
lemma
  assumes A
  assumes "\<not>B"
  assumes "\<not>C"
  shows "A \<longrightarrow> B \<longrightarrow> C"
proof (rule impI)
  show "B \<longrightarrow> C"
  proof (rule impI)
    assume B
   (* with `\<not>B` show C by (rule notE) *)
    then have False using `\<not>B` by blast
    from `\<not>C` show C using `False` by blast
  qed
qed

lemma
assumes A
assumes "\<not>B"
assumes "\<not>C"
shows "B \<longrightarrow> C"
proof(rule impI)
  assume B
  with `\<not>B` show C by (rule notE)
qed

(*Conjunction Elimination*)
  thm conjE
lemma "A \<and> B \<longrightarrow> A"
proof(rule impI)
  assume "A \<and> B"
  then show A by (rule conjE)
qed

lemma "A \<and> B \<longrightarrow> B"
proof(rule impI)
  assume "A \<and> B"
  then show B by (rule conjE)
qed

(* Exercise 2.1 *)
lemma import:"(A \<longrightarrow> B\<longrightarrow> C) \<longrightarrow>((A \<and> B)\<longrightarrow>C)"
proof(rule impI)
  assume "(A \<longrightarrow> B\<longrightarrow> C)"
  show "(A \<and> B)\<longrightarrow>C"
  proof (rule impI)
    assume "A \<and> B"
    then have A by (rule conjE)
    from `A \<longrightarrow> B\<longrightarrow> C` have "B\<longrightarrow> C" using `A` by (rule mp)
    from `A \<and> B` have B by (rule conjE)
    from `B\<longrightarrow> C` have C using `B` by (rule mp)
    thus C.
  qed
qed

(*Conjunction Introduction*)
lemma "A \<and> B \<longrightarrow> B \<and> A"
proof
  assume "A \<and> B"
  then have A by (rule conjE)
  from `A \<and> B` have B by (rule conjE)
  from `B` show "B \<and> A" using `A` by (rule conjI)
qed

(* Exercise 3.1 *)
lemma export: "((A \<and> B)\<longrightarrow>C)\<longrightarrow> (A \<longrightarrow> B\<longrightarrow> C)"
proof (rule impI)
  assume "(A \<and> B)\<longrightarrow>C"
  show "A \<longrightarrow> B\<longrightarrow> C"
  proof (rule impI)
    assume A
    show "B\<longrightarrow> C"
    proof (rule impI)
      assume B
      then have "A \<and> B" using `A` by auto (*rule conjI not working*)
      from `(A \<and> B)\<longrightarrow>C` show C using `A \<and> B` by (rule mp)
      qed
    qed
  qed

(* Biconditional Introduction *)
print_statement iffI
lemma
  assumes "A \<longrightarrow> B"
  assumes "B \<longrightarrow> A"
  shows "B \<longleftrightarrow> A"
proof (rule iffI)
  assume A
  with `A \<longrightarrow> B` show B by (rule mp)
next
  assume B
  with `B \<longrightarrow> A` show A by (rule mp)
qed

(* Exercise 4.1 *)
lemma "A \<longleftrightarrow> A"
proof
qed (* How is this valid ?*)

(* Biconditional Elimination *)

print_statement iffD1
lemma "(A \<longleftrightarrow> B) \<longrightarrow> A \<longrightarrow> B"
proof(rule impI)
  assume "A \<longleftrightarrow> B"
  show "A \<longrightarrow>B"
  proof(rule impI)
    assume A
    then show B using `A \<longleftrightarrow> B` by blast
  qed
qed

lemma "(A \<longleftrightarrow> B) \<longrightarrow> B \<longrightarrow> A"
proof(rule impI)
  assume "A \<longleftrightarrow> B"
  show "B \<longrightarrow> A"
  proof(rule impI)
    assume B
    with `A \<longleftrightarrow> B` show A by (rule iffD2)
  qed
qed

(* Exercise 5.1 *)

lemma "\<not>(A \<longleftrightarrow> \<not>A)"
proof(rule notI) (* alternative *)
  assume "A \<longleftrightarrow> \<not>A"
  then have A by blast
  from `A \<longleftrightarrow> \<not>A` have "\<not>A" by blast
  then show False using `A` by blast
qed

(* Exercises *)

lemma import_export: "((A \<and> B) \<longrightarrow> C) \<longleftrightarrow> (A \<longrightarrow> B\<longrightarrow> C)"
proof (rule iffI)
  assume "(A \<and> B) \<longrightarrow> C"
  then show "A \<longrightarrow> B \<longrightarrow> C" by blast (* rule Week3.export not working *)
next
  assume "A \<longrightarrow> B \<longrightarrow> C"
  then show "(A \<and> B) \<longrightarrow> C" by blast (* rule Week3.import not working *)
qed

lemma
  assumes "(A \<and> B) \<longrightarrow> C"
  assumes A
  shows "B \<longrightarrow> C"
proof (rule impI)
  assume B
  then have "A \<and> B" using `A` by blast (* conjI not working *)
  (*then show C using `(A \<and> B) \<longrightarrow> C` by blast (* mp not working*)*)
  with `(A \<and> B) \<longrightarrow> C` show C by (rule mp)

qed

lemma
  assumes  A
  assumes "\<not>B"
  assumes "\<not>C"
  shows "(A \<and> B) \<longrightarrow> C"
proof(rule impI)
  assume "A \<and> B"
  then have B by (rule conjE)
  then have False using `\<not>B` by blast
  then show C using `\<not>C` by blast
qed

lemma equivalence_left_to_right: "(A \<longrightarrow> B) \<longrightarrow> (\<not> (A \<and> \<not> B))"
proof(rule impI)
  assume "A \<longrightarrow> B"
  show "\<not>(A \<and> \<not>B)"
  proof (rule notI)
    assume "A \<and> \<not> B"
    then have "\<not>B" by (rule conjE)
    from `A \<and> \<not>B` have A by (rule conjE)
    then have B using `A \<longrightarrow> B` by blast
    then show False using `\<not>B` by blast
  qed
qed

lemma equivalence_right_to_left: "\<not>(A \<and> \<not>B) \<longrightarrow> (A \<longrightarrow> B)"
proof (rule impI)
  assume "\<not>(A \<and> \<not>B)"
  show "A \<longrightarrow> B"
  proof (rule impI)
    assume A
    then show B using `\<not>(A \<and> \<not>B)` by blast
  qed
qed

lemma the_equivalence_thesis: "(A \<longrightarrow> B) \<longleftrightarrow> (\<not>(A \<and> \<not> B))"
proof(rule iffI)
  assume "A \<longrightarrow> B"
  then show "\<not>(A \<and> \<not> B)" by blast
      next
        assume "\<not>(A \<and> \<not> B)"
        then show "A \<longrightarrow> B" by blast
      qed

lemma the_equivalence_thesis2: "(A \<longrightarrow> B) \<longleftrightarrow> (\<not>(A \<and> \<not> B))"
proof(rule iffI)
  assume "A \<longrightarrow> B"
  with Week3.equivalence_left_to_right show "\<not>(A \<and> \<not> B)" by (rule mp)
next
  assume "\<not>(A \<and> \<not> B)"
  with Week3.equivalence_right_to_left show "A \<longrightarrow> B" by (rule mp)
qed

end


(*
    $Id: ex.thy,v 1.3 2005/06/29 07:38:01 kleing Exp $
    Author: Tobias Nipkow
*)

header {* Power, Sum *}

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

subsubsection {* Power *}

text {* Define a primitive recursive function $pow~x~n$ that
computes $x^n$ on natural numbers. *}

consts
  pow :: "nat => nat => nat"

text {* Prove the well known equation $x^{m \cdot n} = (x^m)^n$: *}

theorem pow_mult: "pow x (m * n) = pow (pow x m) n"
(*<*) oops (*>*)

text {* Hint: prove a suitable lemma first.  If you need to appeal to
associativity and commutativity of multiplication: the corresponding
simplification rules are named @{text mult_ac}. *}

subsubsection {* Summation *}

text {* Define a (primitive recursive) function $sum~ns$ that sums a list
of natural numbers: $sum [n_1, \dots, n_k] = n_1 + \cdots + n_k$. *}

consts
  sum :: "nat list => nat"

text {* Show that $sum$ is compatible with $rev$. You may need a lemma. *}

theorem sum_rev: "sum (rev ns) = sum ns"
(*<*) oops (*>*)

text {* Define a function $Sum~f~k$ that sums $f$ from $0$ up to $k-1$:
$Sum~f~k = f~0 + \cdots + f(k - 1)$. *}

consts
  Sum :: "(nat => nat) => nat => nat"

text {* Show the following equations for the pointwise summation of functions.
Determine first what the expression @{text whatever} should be. *};

theorem "Sum (%i. f i + g i) k = Sum f k + Sum g k"
(*<*) oops (*>*)

theorem "Sum f (k + l) = Sum f k + Sum whatever l"
(*<*) oops (*>*)

text {* What is the relationship between @{term sum} and @{text Sum}?
Prove the following equation, suitably instantiated. *}

theorem "Sum f k = sum whatever"
(*<*) oops (*>*)

text {* Hint: familiarize yourself with the predefined functions @{term map}
and @{text"[i..<j]"} on lists in theory List. *}

(*<*) end (*>*)


(*  Author: Lukas Bulwahn <lukas.bulwahn-at-gmail.com> *)

section \<open>Combinatorial Basics\<close>

theory Injectivity_Solver
imports
  "HOL-Library.Disjoint_Sets"
  "HOL-Library.Monad_Syntax"
  "HOL-Eisbach.Eisbach"
begin

subsection \<open>Preliminaries\<close>

text \<open>
These lemmas shall be added to the Disjoint Set theory.
\<close>

subsubsection \<open>Injectivity and Disjoint Families\<close>

lemma inj_on_impl_disjoint_family_on_singleton:
  assumes "inj_on f A"
  shows "disjoint_family_on (\<lambda>x. {f x}) A"
using assms disjoint_family_on_def inj_on_contraD by fastforce

subsubsection \<open>Cardinality Theorems for Set.bind\<close>

lemma card_bind:
  assumes "finite S"
  assumes "\<forall>X \<in> S. finite (f X)"
  assumes "disjoint_family_on f S"
  shows "card (S \<bind> f) = (\<Sum>x\<in>S. card (f x))"
proof -
  have "card (S \<bind> f) = card (\<Union>(f ` S))"
    by (simp add: bind_UNION)
  also have "card (\<Union>(f ` S)) = (\<Sum>x\<in>S. card (f x))"
    using assms unfolding disjoint_family_on_def by (simp add: card_UN_disjoint)
  finally show ?thesis .
qed

lemma card_bind_constant:
  assumes "finite S"
  assumes "\<forall>X \<in> S. finite (f X)"
  assumes "disjoint_family_on f S"
  assumes "\<And>x. x \<in> S \<Longrightarrow> card (f x) = k"
  shows "card (S \<bind> f) = card S * k"
using assms by (simp add: card_bind)

lemma card_bind_singleton:
  assumes "finite S"
  assumes "inj_on f S"
  shows "card (S \<bind> (\<lambda>x. {f x})) = card S"
using assms by (auto simp add: card_bind_constant inj_on_impl_disjoint_family_on_singleton)

subsection \<open>Third Version of Injectivity Solver\<close>

text \<open>
Here, we provide a third version of the injectivity solver. The original first version was provided
in the AFP entry `Spivey's Generalized Recurrence for Bell Numbers`. From that method, I derived a
second version in the AFP entry `Cardinality of Equivalence Relations`. At roughly the same time,
Makarius improved the injectivity solver in the development version of the first AFP entry. This
third version now includes the improvements of the second version and Makarius improvements
to the first, and it further extends the method to handle the new cases in the cardinality proof
of this AFP entry.

As the implementation of the injectivity solver only evolves in the development branch of the AFP,
the submissions of the three AFP entries that employ the injectivity solver, have to create clones
of the injectivity solver for the identified and needed method adjustments. Ultimately, these three
clones should only remain in the stable branches of the AFP from Isabelle2016 to Isabelle2017
to work with their corresponding release versions.
In the development version, I have now consolidated the three versions here.
In the next step, I will move this version of the injectivity solver in
the @{theory "HOL-Library.Disjoint_Sets"} and it will hopefully only evolve further there.
\<close>

lemma disjoint_family_onI:
  assumes "\<And>i j. i \<in> I \<and> j \<in> I \<Longrightarrow> i \<noteq> j \<Longrightarrow> (A i) \<inter> (A j) = {}"
  shows "disjoint_family_on A I"
using assms unfolding disjoint_family_on_def by auto

lemma disjoint_bind: "\<And>S T f g. (\<And>s t. S s \<and> T t \<Longrightarrow> f s \<inter> g t = {}) \<Longrightarrow> ({s. S s} \<bind> f) \<inter> ({t. T t} \<bind> g) = {}"
by fastforce

lemma injectivity_solver_CollectE:
  assumes "a \<in> {x. P x} \<and> a' \<in> {x. P' x}"
  assumes "(P a \<and> P' a') \<Longrightarrow> W"
  shows "W"
using assms by auto

lemma injectivity_solver_prep_assms_Collect:
  assumes "x \<in> {x. P x}"
  shows "P x \<and> P x"
using assms by simp

lemma injectivity_solver_prep_assms: "x \<in> A \<Longrightarrow> x \<in> A \<and> x \<in> A"
  by simp

lemma disjoint_terminal_singleton: "\<And>s t X Y. s \<noteq> t \<Longrightarrow> (X = Y \<Longrightarrow> s = t) \<Longrightarrow> {X} \<inter> {Y} = {}"
by auto

lemma disjoint_terminal_Collect:
  assumes "s \<noteq> t"
  assumes "\<And>x x'. S x \<and> T x' \<Longrightarrow> x = x' \<Longrightarrow> s = t"
  shows "{x. S x} \<inter> {x. T x} = {}"
using assms by auto

lemma disjoint_terminal:
  "s \<noteq> t \<Longrightarrow> (\<And>x x'. x \<in> S \<and> x' \<in> T \<Longrightarrow> x = x' \<Longrightarrow> s = t) \<Longrightarrow> S \<inter> T = {}"
by blast

lemma elim_singleton:
  assumes "x \<in> {s} \<and> x' \<in> {t}"
  obtains "x = s \<and> x' = t"
using assms by blast

method injectivity_solver uses rule =
  insert method_facts,
  use nothing in \<open>
    ((drule injectivity_solver_prep_assms_Collect | drule injectivity_solver_prep_assms)+)?;
    rule disjoint_family_onI;
    ((rule disjoint_bind | rule disjoint_bind')+)?;
    (erule elim_singleton)?;
    (erule disjoint_terminal_singleton | erule disjoint_terminal_Collect | erule disjoint_terminal);
    (elim injectivity_solver_CollectE)?;
    rule rule;
    assumption+
  \<close>

end


chapter "Orbit-Stabiliser Theorem"
text \<open>
In this Theory we will prove the orbit-stabiliser theorem, a basic result in the algebra of groups.

\<close>

theory Orbit_Stabiliser
  imports
    Left_Coset

begin

section "Imports"
text \<open>
  /HOL/Algebra/Group.thy is used for the definitions of groups and subgroups
\<close>

text \<open>
  Left\_Coset.thy is a copy of /HOL/Algebra/Coset.thy that includes additional theorems about left cosets.

  The version of Coset.thy in the Isabelle library is missing some theorems about left cosets
  that are available for right cosets, so these had to be added by simply replacing the definitions
  of right cosets with those of left cosets.

  Coset.thy is used for definitions of group order, quotient groups (operator LMod), and Lagranges theorem.
\<close>

text \<open>
  /HOL/Fun.thy is used for function composition and the identity function.
\<close>

section "Group Actions"

text \<open>
  We begin by augmenting the existing definition of a group with a group action.

  The group action was defined according to @{cite groupaction}.
\<close>

locale orbit_stabiliser = group +
  fixes action :: "'a \<Rightarrow> 'b \<Rightarrow> 'b" (infixl "\<odot>" 51)
  assumes id_act [simp]: "\<one> \<odot> x = x"
    and compat_act:
    "g \<in> carrier G \<and> h \<in> carrier G \<longrightarrow> g \<odot> (h \<odot> x) = (g \<otimes> h) \<odot> x"

section "Orbit and stabiliser"

text \<open>
Next, we define orbit and stabiliser, according to the same Wikipedia article.
\<close>

context orbit_stabiliser
begin

definition orbit :: "'b \<Rightarrow> 'b set" where
  "orbit x = {y. (\<exists> g \<in> carrier G. y = g \<odot> x)}"

definition stabiliser :: "'b \<Rightarrow> 'a set"
  where "stabiliser x = {g \<in> carrier G. g \<odot> x = x}"

section "Stabiliser Theorems"

text \<open>
We begin our proofs by showing that the stabiliser forms a subgroup.

This proof follows the template from  @{cite stabsub}.
\<close>

theorem stabiliser_subgroup: "subgroup (stabiliser x) G"
proof(rule subgroupI)
  show "stabiliser x \<subseteq> carrier G" using stabiliser_def by auto
next
  fix x
  from id_act have "\<one> \<odot> x = x" by simp
  then have "\<one> \<in> stabiliser x" using stabiliser_def by auto
  then show "stabiliser x \<noteq> {}" by auto
next
  fix g x
  assume gStab:"g \<in> stabiliser x"
  then have g_car:"g \<in> carrier G" using stabiliser_def by simp
  then have invg_car:"inv g \<in> carrier G" using inv_closed by simp
  have "g \<odot> x = x" using stabiliser_def gStab by simp
  then have "inv g \<odot> (g \<odot> x) = inv g \<odot> x" by simp
  then have "(inv g \<otimes> g) \<odot> x = inv g \<odot> x" using compat_act g_car invg_car by simp
  then have "x = (inv g) \<odot> x" using g_car l_inv by simp
  then show "inv g \<in> stabiliser x" using invg_car stabiliser_def by simp
next
  fix g h x
  assume g_stab: "g \<in> stabiliser x" and h_stab: "h \<in> stabiliser x"
  then have g_car: "g \<in> carrier G" and h_car: "h \<in> carrier G" using stabiliser_def by auto
  then have "g \<odot> x = x" "h \<odot> x = x"
    using stabiliser_def g_stab h_stab by auto
  then have "g \<odot> (h \<odot> x) = x" by simp
  then have "(g \<otimes> h) \<odot> x = x" using compat_act g_car h_car by simp
  then show "(g \<otimes> h) \<in> stabiliser x"
    using g_stab h_stab stabiliser_def by auto
qed

text \<open>
As an intermediate step we formulate a lemma about the relationship between the group action
and the stabiliser.

This proof follows the template from @{cite stabsubcor}.
\<close>

corollary stabiliser_subgroup_corollary:
  assumes g_car: "g \<in> carrier G" and
    h_car: "h \<in> carrier G"
  shows "(g \<odot> x) = (h \<odot> x) \<longleftrightarrow> ((inv g) \<otimes> h) \<in> stabiliser x"
proof
  from g_car have invg_car: "(inv g) \<in> carrier G" by auto
  show "(g \<odot> x) = (h \<odot> x) \<Longrightarrow> inv g \<otimes> h \<in> stabiliser x"
  proof -
    assume gh: "(g \<odot> x) = (h \<odot> x)"
    have "((inv g) \<otimes> h) \<odot> x = (inv g) \<odot> (h \<odot> x)" using assms compat_act by simp
    moreover have "(inv g) \<odot> (h \<odot> x) = (inv g) \<odot> (g \<odot> x)" using gh by simp
    moreover have "(inv g) \<odot> (g \<odot> x) = ((inv g) \<otimes> g) \<odot> x" using invg_car g_car compat_act by simp
    moreover have "((inv g) \<otimes> g) \<odot> x = x" using g_car by simp
    ultimately have "((inv g) \<otimes> h) \<odot> x = x" by simp
    then show ?thesis using stabiliser_def assms by simp
  qed

  show "inv g \<otimes> h \<in> stabiliser x \<Longrightarrow> g \<odot> x = h \<odot> x"
  proof -
    assume gh_stab: "inv g \<otimes> h \<in> stabiliser x"
    with stabiliser_def have "x = ((inv g) \<otimes> h) \<odot> x" by simp
    then have "\<one> \<odot> x = ((inv g) \<otimes> h) \<odot> x"  by simp
    then have "((inv g) \<otimes> g) \<odot> x = ((inv g) \<otimes> h) \<odot> x" using invg_car g_car by simp
    then have "x = (inv g) \<odot> (h \<odot> x)" using compat_act g_car h_car by simp
    then have "g \<odot> x = (g \<otimes> (inv g)) \<odot> (h \<odot> x)" using compat_act g_car invg_car by metis
    then have "g \<odot> x = h \<odot> x" using compat_act g_car id_act invg_car r_inv by simp
    then show ?thesis by simp
  qed
qed

text \<open>
Using the previous lemma and our proof that the stabiliser forms a subgroup, we can now
show that the elements of the orbit map to left cosets of the stabiliser.

This will later form the basis of showing a bijection between the orbit and those cosets.
\<close>

lemma stabiliser_cosets_equivalent:
  assumes g_car: "g \<in> carrier G" and
    h_car: "h \<in> carrier G"
  shows "(g \<odot> x) = (h \<odot> x) \<longleftrightarrow> (g <# stabiliser x) = (h <# stabiliser x)"
proof
  show "g \<odot> x = h \<odot> x \<Longrightarrow> g <# stabiliser x = h <# stabiliser x"
  proof -
    assume "g \<odot> x = h \<odot> x"
    then have stab_elem: "((inv g) \<otimes> h) \<in> stabiliser x"
      using assms stabiliser_subgroup_corollary by simp
    with subgroup.lcos_module_rev[OF stabiliser_subgroup] have "h \<in> g <# (stabiliser x)"
      using assms is_group by simp
    with l_repr_independence have  "g <# (stabiliser x) = h <# (stabiliser x)"
      using assms  stab_elem stabiliser_subgroup by auto
    then show ?thesis by simp
  qed
  show "g <# stabiliser x = h <# stabiliser x \<Longrightarrow> g \<odot> x = h \<odot> x"
  proof -
    assume "g <# stabiliser x = h <# stabiliser x"
    with subgroup.lcos_module_rev[OF stabiliser_subgroup] have "h \<in> g <# (stabiliser x)"
      using assms is_group l_inv stabiliser_subgroup subgroup_def by metis
    with subgroup.lcos_module_imp[OF stabiliser_subgroup] have "((inv g) \<otimes> h) \<in> stabiliser x"
      using assms is_group by blast
    with stabiliser_subgroup_corollary have "g \<odot> x = h \<odot> x" using assms by simp
    then show ?thesis by simp
  qed
qed

section "Picking representatives from cosets"

text \<open>
Before we can prove the bijection, we need a few lemmas about representatives from sets.

First we define rep to be an arbitrary element from a left coset of the stabiliser.
\<close>
definition rep :: "'a set \<Rightarrow> 'a" where
  "(H \<in> carrier (G LMod (stabiliser x))) \<Longrightarrow> rep H = (SOME y. y \<in> H)"

text \<open>
  The next lemma shows that the representative is always an element of its coset.
\<close>
lemma quotient_rep_ex  : "H \<in> (carrier (G LMod (stabiliser x))) \<Longrightarrow> rep H \<in> H"
proof -
  fix H
  assume H:"H \<in> carrier (G LMod stabiliser x)"
  then obtain g where "g \<in> carrier G" "H = g <# (stabiliser x)"
    unfolding LFactGroup_def LCOSETS_def by auto
  then have "(SOME x. x \<in> H) \<in> H" using lcos_self stabiliser_subgroup someI_ex by fast
  then show "rep H \<in> H" using H rep_def by auto
qed

text \<open>
The final lemma about representatives shows that it does not matter which element of the coset
is picked, i.e. all representatives are equivalent.
\<close>
lemma rep_equivalent:
  assumes H:"H \<in> carrier (G LMod stabiliser x)" and
    gH:"g \<in> H"
  shows "H = g <# (stabiliser x)"
proof -
  fix h
  from H obtain h where hG:"h \<in> carrier G" and H2:"H = h <# (stabiliser x)"
    unfolding LFactGroup_def LCOSETS_def by auto
  with H gH have gh:"g \<in> h <# (stabiliser x)" by simp
  from l_repr_independence have "h <# stabiliser x = g <# stabiliser x"
    using hG gh stabiliser_subgroup by simp
  with H2 have "H = g <# (stabiliser x)" by simp
  then show ?thesis by simp
qed

section "Orbit-Stabiliser Theorem"

text \<open>
  We can now establish the bijection between orbit(x) and the quotient group G/(stabiliser(x))

  The idea for this bijection is from @{cite orbitstab}
\<close>
theorem orbit_stabiliser_bij:
  "bij_betw (\<lambda>H. rep H \<odot> x) (carrier (G LMod (stabiliser x))) (orbit x) "
proof (rule bij_betw_imageI)
  (* show the function is injective *)
  show "inj_on (\<lambda>H. rep H \<odot> x) (carrier (G LMod stabiliser x))"
  proof(rule inj_onI)
    fix H H'
    assume H:"H \<in> carrier (G LMod (stabiliser x))"
    assume H':"H' \<in> carrier (G LMod (stabiliser x))"
    obtain h h' where  h:"h = rep H" and h': "h' = rep H'" by simp
    assume act_equal: "(rep H) \<odot> x = (rep H') \<odot> x"
    from H h quotient_rep_ex have hH: "h \<in> H" by simp
    from H' h' quotient_rep_ex have hH': "h' \<in> H'" by simp
    from subgroup.lcosets_carrier[OF stabiliser_subgroup is_group] H have "H \<subseteq> carrier G"
      unfolding LFactGroup_def by simp
    then have hG: "h \<in> carrier G" using hH by auto
    from subgroup.lcosets_carrier[OF stabiliser_subgroup is_group] H' have "H' \<subseteq> carrier G"
      unfolding LFactGroup_def by simp
    then have h'G: "h' \<in> carrier G" using hH' by auto

        (* Apply lemma about equivalent cosets *)
    have hh'_equiv:"h <# (stabiliser x) = h' <# (stabiliser x)"
      using hG h'G h h' act_equal stabiliser_cosets_equivalent by simp

    from hh'_equiv have H2:"H = h <# (stabiliser x)"
      using H hH rep_equivalent by blast
    moreover from hh'_equiv have H3:"H' = h <# (stabiliser x)"
      using H' hH' rep_equivalent by blast
    then show "H = H'" using H2 H3 by simp
  qed
next
  show "(\<lambda>H. rep H \<odot> x) ` carrier (G LMod stabiliser x) = orbit x"
  proof(auto)
    show "\<And>H. H \<in> carrier (G LMod stabiliser x) \<Longrightarrow> rep H \<odot> x \<in> orbit x"
    proof -
      fix H
      assume H:"H \<in> carrier (G LMod (stabiliser x))"
      obtain h where h:"h = rep H" by simp
      from H h quotient_rep_ex have hH: "h \<in> H" by simp
      have stab_sub: "(stabiliser x) \<subseteq> carrier G" using stabiliser_def by auto
      from subgroup.lcosets_carrier[OF stabiliser_subgroup is_group] H have "H \<subseteq> carrier G"
        unfolding LFactGroup_def by simp
      with hH have "h \<in> carrier G" by auto
      then show "(rep H) \<odot> x \<in> orbit x" using h orbit_def mem_Collect_eq by blast
    qed
    show "\<And>y. y \<in> orbit x \<Longrightarrow> y \<in> (\<lambda>H. rep H \<odot> x) ` carrier (G LMod stabiliser x)"
    proof -
      fix y
      assume y:"y \<in> orbit x"
      obtain g  where gG:"g \<in> carrier G" and "y = g \<odot> x" using y orbit_def by auto
      obtain H where H:"H = g <# (stabiliser x)" by auto
      with gG have H_carr:"H \<in> carrier (G LMod stabiliser x)"
        unfolding LFactGroup_def LCOSETS_def by auto
      then have "rep H \<in> H" using quotient_rep_ex by auto
      then obtain h where h_stab:"h \<in> stabiliser x" and gh:"rep H = g \<otimes> h"
        unfolding H l_coset_def by auto
      have hG:"h \<in> carrier G" using h_stab stabiliser_def by auto
      from stabiliser_def h_stab have "h \<odot> x = x" by auto
      with \<open>y = g \<odot> x\<close> have "y = g \<odot> (h \<odot> x)" by simp
      then have "y = (g \<otimes> h) \<odot> x" using gG hG compat_act by auto
      then have "y = (rep H) \<odot> x" using gh by simp
      then show "y \<in> (\<lambda>H. rep H \<odot> x) ` carrier (G LMod stabiliser x)"
        using H_carr by simp
    qed
  qed
qed

text\<open>
  The actual orbit-stabiliser theorem is a consequence of the bijection
   we established in the previous theorem and of Lagrange's theorem
\<close>
theorem orbit_stabiliser:
  assumes finite: "finite (carrier G)"
  shows "order G = card (orbit x) * card (stabiliser x)"
proof -
  have "card (carrier (G LMod (stabiliser x))) = card (orbit x)"
    using bij_betw_same_card orbit_stabiliser_bij by auto
  moreover have "card (carrier (G LMod (stabiliser x))) * card (stabiliser x)  = order G"
    using finite stabiliser_subgroup l_lagrange unfolding LFactGroup_def by simp
  ultimately show ?thesis by simp
qed
end

end


(* Author: Fabian Hellauer, 2018-2019 *)
(*<*) theory Doc
  imports
    Field_Extensions.Examples
    Field_Extensions.Old_Field_Extension
    "HOL-Algebra.Algebra"
begin (*>*)

section \<open>Project Scope\<close>

text \<open>Higher-order logic (HOL) is a widely used instance of the theorem prover Isabelle. The
 goal of the project at hand was to extend \<^emph>\<open>Isabelle/HOL\<close>'s library of abstract algebra by
 formalising field extension theory from chapter~16 of Gregor Kemper's lecture notes in
 algebra~@{cite Algebra1}. As requirement, some theory about vector spaces was added to the
 formalisation goal.

Apart from Isabelle's own \<^session>\<open>HOL-Algebra\<close> library, the entry \isatt{VectorSpace} from the
 \<^emph>\<open>Archive of Formal Proofs\<close>~(AFP)~\<^footnote>\<open>\<^url>\<open>https://www.isa-afp.org\<close>\<close> was used as a basis.

The work was carried out separately from the development repositories of Isabelle and AFP to
 avoid obstructing the integrity of their pull/push areas with formalisation experiments.
\<close>

section \<open>Modelling of Algebraic Structures\<close>

subsection \<open>Background\<close>

text \<open>\<^emph>\<open>Isabelle/HOL\<close> provides the \<^theory_text>\<open>record\<close> package for defining structure types with named data
 fields. \<^session>\<open>HOL-Algebra\<close> uses that to define the type \<^type>\<open>ring\<close> with data fields
 \<^const>\<open>carrier\<close>, \<open>\<otimes>\<close>, \<open>\<oplus>\<close>, \<open>\<one>\<close> and \<open>\<zero>\<close>.

In algebra, superstructures generally are defined to be just the inverse of substructures, as
  is the cases for fields. Thus, modelling the notion of subfield also defines field extensions
  (which is just another term for superfield).

During my work, Isabelle developers added definitions for \<^locale>\<open>subring\<close> and
 \<^locale>\<open>subfield\<close> to \<^session>\<open>HOL-Algebra\<close>; these are described below. For compatibility, I
 ported my material to use these library definitions.\<close>

subsection \<open>Subrings\label{sec:sr}\<close>

text \<open>A first try at formalising the notion of a subring is \<^const>\<open>ring.old_sr\<close>: A predicate
 which operates on two full \<^type>\<open>ring\<close> records \<open>R\<close> and \<open>S\<close>. It enforces the well-known
 properties for the subring \<open>S\<close>, and that, if restricted to \<open>S\<close>'s carrier set, both
 structure's \<open>\<otimes>\<close> resp.\ \<open>\<oplus>\<close> have to equal.

A problem  with this approach is that there are two entities for \<open>\<otimes>\<close> and \<open>\<oplus>\<close> each: Many facts can be
 shown not for any subring \<open>S\<close>, but only for \<^term>\<open>(R\<lparr>carrier := carrier S\<rparr>)\<close> (the structure with
 \<open>\<otimes>\<close>, \<open>\<oplus>\<close>, \<open>\<zero>\<close> and \<open>\<one>\<close> from \<open>R\<close>, but carrier set from the subring \<open>S\<close>). This may differ from \<open>S\<close>
  in where the operations map objects from outside the carrier set.

Similarly, \<open>\<zero>\<close> and \<open>\<one>\<close> are fixed twice each. Since they are equal in sub- and superstructure,
 there is some degree of freedom in stating lemmas (using one or the other),
 hindering fact uniformity.

To conclude, it seems advisable to fix all needed objects only once within a locale. For
 algebra, this means: A group or ring needs a full record, but for \<^emph>\<open>sub\<close>structures we should only
 add a \<^emph>\<open>set\<close> to the fixed items.

The locale \<^locale>\<open>subring\<close> in \<^session>\<open>HOL-Algebra\<close> uses this approach, via
 \<^locale>\<open>subgroup\<close> and \<^locale>\<open>submonoid\<close>. Note however, that \<^locale>\<open>subgroup\<close>'s axioms
 only describe the relation to the superstructure, assumed to be a group:
 \begin{center} @{prop[names_short] \<open>subgroup H G \<Longrightarrow> group (G\<lparr>carrier := H\<rparr>)\<close>} \end{center} does not
 hold without the additional assumption @{prop[names_short] \<open>group G\<close>}, equivalently for ring and
 monoid. It is only under these additional assumptions that these locales coincide with the typical
 textbook definitions.\<close>

subsection \<open>Subfields\label{sec:sf}\<close>

text \<open>The locale \<^locale>\<open>subfield\<close> extends \<^locale>\<open>subring\<close> with the appropriate additional
 assumptions for the substructure.

My locale \<^locale>\<open>field_extension\<close> combines \<^locale>\<open>subfield\<close> and \<open>field\<close>. It also renames the
 variables to \<open>L\<close> for the field and \<open>K\<close> for the subfield set.

The locale \<^locale>\<open>UP_field_extension\<close> additionally sets \<open>P\<close> to denote the ring of univariate
  polynomials over \<open>K\<close>, fixes an \<open>\<alpha>\<close> in \<open>L\<close>, and defines \<open>Eval\<close> to be the map \<open>P \<rightarrow> L\<close> which
  evaluates polynomials at \<open>\<alpha>\<close>. The homomorphism property of this map is proven in
  \<^theory>\<open>HOL-Algebra.UnivPoly\<close>.\<close>

subsection \<open>Infinite Dimension\<close>

text \<open>In \<open>VectorSpace.VectorSpace\<close>, the case of an infinite dimension is modelled by \<^const>\<open>vector_space.dim\<close>
 being an unspecified \<^typ>\<open>nat\<close>. My impression from reading that theory is that distinct
 representations would improve the formalisation: For instance, in \<open>VectorSpace\<close>, the finite
 dimension cannot be expressed as equality of the dimension to a number; these statements
 additionally need the predicate \<^const>\<open>vectorspace.fin_dim\<close> to be meaningful, counterintuitively.

As the zero vector space is no field, the degree of a field extension is never zero. With the above
 consideration in mind, I therefore decided to define the infinite degree to be @{term_type
 "0::nat"}. Incidentally, for the purpose of the tower rule (\<open>\<section>\<close>\ref{sec:tr}), zero and infinity
 happen to have the same absorbing properties in a multiplication.

A more robust implementation would use an extended type of natural numbers, or even the full range
 of cardinal numbers. For field extensions, only one additional number is needed: My template~@{cite
 Algebra1} views the degree as number in \<open>\<nat> \<union> {\<infinity>}\<close>.

Whatever the best formalisation is, the change should be made in \<open>VectorSpace\<close>:
 \<^theory>\<open>Field_Extensions.Field_Extension\<close> only uses what is there. Due to there being no
 collision with the actual zero, my material should be easily adaptable to such a change.\<close>

section \<open>Field Extensions\<close>

subsection \<open>Degree Multiplicativity (Tower Rule)\label{sec:tr}\<close>

text\<open>Remember that infinite field extensions are encoded to have \<open>degree = 0\<close>. This case may occur
  in the following "tower rule":\<close>

proposition degree_multiplicative:
  "\<lbrakk>subfield K (M\<lparr>carrier:=L\<rparr>); subfield L M; field M\<rbrakk> \<Longrightarrow>
  field_extension.degree M K =
    field_extension.degree M L * field_extension.degree (M\<lparr>carrier:=L\<rparr>) K"(*<*)by(fact degree_multiplicative)(*>*)

text \<open>The proof is covered by considering three (partially overlapping) cases:
  \<^enum> The lower field extension is infinite.
  \<^enum> The upper field extension is infinite.
  \<^enum> Both extension parts are finite.

Recently, case~3 has also been proven in
 another \<^session>\<open>HOL-Algebra\<close> development~\<^footnote>\<open>\<^url>\<open>https://github.com/DeVilhena-Paulo/GaloisCVC4\<close>\<close>.
 It uses the inner product instead of the outer for the proof, thus avoiding the vector space
  terminology as described in \autoref{sec:mvs}.\<close>

subsection \<open>The Minimal Polynomial\<close>
(*<*)context UP_field_extension begin(*>*)
text \<open>Recall the context \<^locale>\<open>UP_field_extension\<close> from \autoref{sec:sf}. For an \<^emph>\<open>algebraic\<close> \<^term>\<open>\<alpha>\<close>,
  I define the minimal polynomial:\<close>
text_raw\<open>\isacommand{definition}\isamarkupfalse%
\ irr\ %
\isamarkupcmt{named after its \emph{irr}educibility (shown later)%
}\ \isanewline
\ \ \isakeyword{where}\ {\isachardoublequoteopen}irr\ {\isacharequal}\isanewline
\ \ \ \ {\isacharparenleft}ARG{\isacharunderscore}MIN\ degree\ p{\isachardot}\ p\ {\isasymin}\ carrier\ P\ {\isasymand}\ monic\ p\ {\isasymand}\ Eval\ p\ {\isacharequal}\ {\isasymzero}\isactrlbsub L\isactrlesub {\isacharparenright}{\isachardoublequoteclose}%\<close>
text \<open>This uses an indefinite description (via @{const arg_min}) because a priori, there could be
 multiple such polynomials. This formulation is also common in textbooks.\<close>

subsection \<open>Classification of Simple Algebraic Extensions\<close>

text \<open>In \<^locale>\<open>UP_field_extension\<close>, within the above-mentioned context of an algebraic
 \<^term>\<open>\<alpha>\<close>, Kemper/theorem~16.9b~@{cite Algebra1} applies. Its results are:
  \<^item> @{thm[source] irr_exists}, the existence of \<^term>\<open>\<alpha>\<close>'s minimal polynomial "\<^const>\<open>irr\<close>"
  \<^item> @{thm[source] irr_unique}, the uniqueness of \<^const>\<open>irr\<close>
  \<^item> @{thm[source] irr_irreducible_polynomial}, the irreducibility of \<^const>\<open>irr\<close> in \<^term>\<open>P\<close>
  \<^item> @{thm[source] the_elem_ring_iso_Quot_generate_field}, an isomorphism $P/(irr)~\to~K(\alpha)$
\<close>
(*<*)end(*>*)

subsection \<open>Example Instantiations\label{sec:ethy}\<close>

text \<open>\isatt{Examples.thy} provides instantiations for some of the locales, using commonly known
 rings and fields.
 The theory cannot use the @{theory_text \<open>interpretation\<close>} command due to some library
  errors:
\begin{figure}[H]
  \includegraphics[width=\linewidth]{"interpretation_error"}
  \caption{@{thm[source] subfield_Reals_complex_field}, if stated as an interpretation: The
 proof works just as in the case of a lemma, but the fact generation fails.}
\end{figure}
The problem traces back to \<^locale>\<open>subring\<close> importing both \<^locale>\<open>submonoid\<close> and
 \<^locale>\<open>subgroup\<close>, which both have an axiom named \<open>subset\<close>. A workaround is known, but complicates
  matters quite a bit~\<^footnote>\<open>cf.\
  \<^url>\<open>https://lists.cam.ac.uk/pipermail/cl-isabelle-users/2018-June/msg00033.html\<close>\<close>.\<close>

section \<open>Modules and Vector Spaces\label{sec:mvs}\<close>

subsection \<open>Motivation\<close>

text \<open>The motivation for working in this area was Kemper's proof of the field extension tower rule
 (\<open>\<section>\<close>\ref{sec:tr}), which uses vector space results unavailable in \<^session>\<open>HOL-Algebra\<close>. Note
 that the tower rule could be proven more directly using indexed sums~\<^footnote>\<open>cf.\ e.g.\
 \<^url>\<open>https://wikipedia.org/wiki/Degree_of_a_field_extension\#The_multiplicativity_formula_for_degrees\<close>\<close>,
  but the material which Kemper uses seemed to be of general usefulness for a vector space library.\<close>

subsection \<open>Indexed Products\<close>

text \<open>For a ring \<open>R\<close>, the following defines the coordinate space $R^n$:

\<^theory_text>\<open>definition (in ring) nspace where "nspace n = func_space {..<n::nat}"\<close>

Here, \<^term>\<open>ring.func_space\<close> is the well-known module of functions from any set to the ring
 carrier set with pointwise addition and scalar multiplication.

A limitation of this approach is that only sums of the same module can be described, compared to
 \<^const>\<open>direct_sum\<close> (see \<open>\<section>\<close>\ref{sec:ds}), which can even combine modules of different type (over the same
 ring). An obvious advantage is however the variability of \<open>n\<close>.

A well-known theorem about \<open>K\<close>-vector-spaces \<open>V\<close> of finite dimension \<open>dim\<close> is that they are
  isomorphic to $K^{dim}$:\<close>

theorem (in vectorspace) nspace_iso:
  assumes fin_dim
  shows "\<exists>\<phi>. linear_map K (nspace dim) V \<phi> \<and>
    bij_betw \<phi> (carrier (nspace dim)) (carrier V)"(*<*)using assms by(fact nspace_iso)(*>*)

text \<open>In the proof, some lemmas from \isatt{VectorSpace} turned out to be useful, e.g.\ about the
  kernel of injective linear maps.\<close>

subsection \<open>Direct Sums\label{sec:ds}\<close>

text \<open>In \<open>SumSpaces\<close>, one finds the definition \<^const>\<open>direct_sum\<close>. It is misleading in that it
 also defines contents for the unused \<open>mult\<close> and \<open>one\<close> field of the module. I replaced these with
 \<open>undefined\<close>.

The notion gives rise to another view on the previous result:\<close>

lemma decompose_step:
  "\<lbrakk>vectorspace K V; vectorspace.fin_dim K V; 0 < vectorspace.dim K V\<rbrakk>
\<Longrightarrow> \<exists>\<phi> V'.
  linear_map K V (direct_sum (module_of K) (V\<lparr>carrier:=V'\<rparr>)) \<phi> \<and>
  bij_betw \<phi> (carrier V) (carrier K \<times> V') \<and>
  subspace K V' V \<and>
  vectorspace.dim K (V\<lparr>carrier:=V'\<rparr>) = vectorspace.dim K V - 1"(*<*)by(fact vectorspace.decompose_step)(*>*)

text \<open>This variant is used in the proof of the tower rule's finite case, together with induction. In
 retrospect, @{thm[source] vectorspace.nspace_iso} probably could have achieved the same with
 less work. The reason I used \<open>decompose_step\<close> is that I expected some
 material about the direct sum to be available, as \<^const>\<open>direct_sum\<close> was already defined.
 Ultimately, no useful results turned out to exist for this function.

Some ugliness of @{thm[source] vectorspace.decompose_step} comes from the use of a second
  existential quantifier, namely for \<open>V'\<close>. This cannot be avoided elegantly, as the witness
\<^item> is somewhat unhandy (see the proof) and,
\<^item> more importantly, depends on a choice of basis, and a choice of ordering on that basis.\<close>

subsection \<open>Subspaces\<close>

text \<open>These are two other useful results:
  \<^item> Subspaces of finite-dimensional vector spaces are again finite-dimensional: The dimension of the
 subspace is less than or equal to the dimension of the finite-dimensional superspace.
  \<^item> If a subspace of a finite-dimensional vector space has the "full" dimension, then it is the same as
 its superspace, i.e.\ the inclusion is improper.

For the proof, I needed the basis extension
 theorem~\<^footnote>\<open>\<^url>\<open>http://www-m11.ma.tum.de/fileadmin/w00bnb/www/people/kemper/lectureNotes/LADS.pdf\#section.0.10\<close>\<close>,
at least for finite-dimensional vector spaces and \<^prop>\<open>S = carrier V\<close>. This special case is
 @{thm[source] vectorspace.lin_indpt_extends_to_basis}.

As a side note, the notion \<^const>\<open>maximal\<close>, where @{thm[show_question_marks = false]
 maximal_def}, is introduced in \<open>VectorSpace.VectorSpace\<close> and not in \<^theory>\<open>HOL.Zorn\<close>. This may
 be relevant when porting the basis extension theorem to allow for infinite dimensions.
\<close>

section \<open>Problems\<close>

subsection \<open>Missing Substructure Theory\<close>

text \<open>The most important problem can be identified easily: the lack of material about substructures.
 A simple \<^theory_text>\<open>find_theorems\<close> invocation for instance reveals that not a single lemma had been
  proven within e.g.\ the \<^locale>\<open>subspace\<close> or \<^locale>\<open>submodule\<close> locales. The theories at
 hand should mitigate this a bit.

The \<^locale>\<open>subspace\<close> locale has a definition quirk which should be re-evaluated before putting
  more work in proving lemmas in it: It states its dependencies as assumptions, not as imports.
  This leads to blown-up proofs because many facts need to be re-constructed before usage, i.e.\ the
 assumptions are not discharged by the locale system.

Another nuisance is the different argument order for \<^const>\<open>VectorSpace.subspace\<close> and @{const[names_long] submodule}.\<close>

subsection \<open>Non-Canonical Maps\<close>

text \<open>Some results about vector spaces and linear maps depend on a choice of basis. While bases are
 defined a sets, we sometimes need a "first" element, or even a full ordering.

This means that we cannot translate the informal "We fix a basis \<open>B\<close>." to the \<^emph>\<open>Isar formal proof language\<close> like this:\<close>
(*<*)notepad (in vectorspace) begin(*>*)
  fix B
  assume "basis B"
(*<*)end(*>*)

text \<open>Instead, one has to work with a distinct list as basis, and use a conversion function with
 every \<open>\<in>\<close>, \<open>\<subseteq>\<close>, etc. If more such situations arise in the theory of vector spaces, one might consider
  adding something like\<close>

definition (in vectorspace) B where
  "B = (SOME B. distinct B \<and> basis (set B))"
lemma (in vectorspace)
  assumes fin_dim shows "distinct B" and "basis (set B)" (*<*) unfolding B_def
  using assms by (metis (lifting) finite_basis_exists finite_distinct_list someI)+ (*>*)

text \<open>to the library. This is just another way of stating the existence of a finite basis, but might
 be more useful in proofs and lemma statements.

As is known, infinite-dimensional vector spaces have bases, too, but proving this requires more work
 and a different indexing scheme.\<close>

subsection \<open>Old-School Context Elements\<close>

text \<open>The \<^doc>\<open>locales\<close> manual~@{cite "isabelle-locale"} states that \<^theory_text>\<open>defines\<close> clauses in locale
 definitions are provided only for backward compatibility, but gives no reason for the deprecation.
 My problem with \<^theory_text>\<open>defines\<close> is that it causes code duplication, e.g.\ @{thm[source]
 UP_field_extension.Eval_def} cannot be derived from @{thm[source] UP_univ_prop.Eval_def}.

In my development, I tried to avoid \<^theory_text>\<open>defines\<close> for this reason, and used regular definitions
 instead. The only usage is in the definition of @{locale UP_field_extension}, where this seems to
 be the only way to make a \<^theory_text>\<open>(structure)\<close> declaration. An alternative with no \<^theory_text>\<open>defines\<close> at all is
 in the \isatt{no\_defines} branch~\<^footnote>\<open>\<^url>\<open>https://github.com/helli/field-extensions/tree/no\_defines\<close>\<close>;
 it needs a lot more subscripts in subsequent statements and proofs, but removes the need to
  redefine \<open>P\<close> for interpretations of the locale, see the proof of @{thm[source]
  generate_field_\<i>_UNIV}.\<close>

section \<open>Analysis of the Used Libraries\<close>

subsection \<open>Principal Ideal Definitions\<close>

text \<open>There are two definitions of generated ideals in \<^theory>\<open>HOL-Algebra.Ideal\<close>:
 \<^const>\<open>Ideal.genideal\<close> and \<^const>\<open>Ideal.cgenideal\<close>. They differ not in \<^emph>\<open>c\<close>ommutativity, as
 their names suggest, but in whether they take a set or single element as argument. Confusingly
 enough, the locales \<^const>\<open>principalideal\<close> and \<^const>\<open>principal_domain\<close> are not defined via
 the same notion of ideal. (They also do not use each other in their definitions.)

 @{const[names_long] Ideal.cgenideal} should probably be renamed to
  match its function symbol "\<open>PIdl\<close>" (principal ideal). It could also just abbreviate
  \<^const>\<open>genideal\<close> with \<^prop>\<open>S = {a}\<close>. In this scenario, the
 current @{thm[source] cgenideal_def} would become a lemma, perhaps stated like @{thm[source]
  cring.cgenideal_eq_rcos} to benefit from the huge theory \<^theory>\<open>HOL-Algebra.Coset\<close>.

Moreover note that both functions are hull operations,
  thus using the material from \<^theory>\<open>HOL.Hull\<close> might shorten some proofs.\<close>

subsection \<open>Generated Fields\<close>

text \<open>The function \<^const>\<open>generate_field\<close> was added during my work. This meant that I had to do
 some porting (see \<^theory>\<open>Field_Extensions.Old_Field_Extension\<close> for the state before that).
 However, it turned out to simplify matters overall because it leaves out the "lower bound" field
 found in Kemper/definition~16.4~@{cite Algebra1}.

A note about the style: Just like in their locale
 definitions (see \<open>\<section>\<close>\ref{sec:sr}), the authors use a technical description with the
  \<^theory_text>\<open>inductive_set\<close> command, instead of using \<^theory_text>\<open>definition\<close> and \<^const>\<open>hull\<close>.\<close>

subsection \<open>Integer Ring Definitions\<close>

text \<open>
Both \<^theory>\<open>HOL-Algebra.UnivPoly\<close> and \<^theory>\<open>HOL-Algebra.IntRing\<close> define an integer ring,
 i.e.\ a ring with the \<^term>\<open>UNIV\<close> of type \<^typ>\<open>int set\<close> as carrier set and the obvious
 operations.

Apart from the usual problems of duplicate definitions (\<^const>\<open>INTEG\<close> vs.\ \<open>\<Z>\<close>), they also
 pollute the name space: For instance, \<^theory_text>\<open>find_theorems eval\<close> yields 35 facts, 15 of which
 are about \<^const>\<open>INTEG\<close>. These are too special and therefore useless when doing abstract
 algebra. Note that \<^theory_text>\<open>hide_const INTEG\<close> does not hide the facts, hindering e.g.\ auto-completion.
When going up in the locale hierarchy (e.g.\ \<^locale>\<open>monoid\<close>), lemmas about \<open>\<Z>\<close> come on board, too, if
 \<^theory>\<open>HOL-Algebra.IntRing\<close> is imported.
To me, this is a reason why \<^theory>\<open>HOL-Algebra.Algebra\<close> is not attractive as an import. In future
 revisions of the library, the import of both \<^const>\<open>INTEG\<close> and \<open>\<Z>\<close> should be optional.

\<^const>\<open>INTEG\<close> and \<open>\<Z>\<close> are unused outside of their theories, also in the AFP.
 A reason may be that they are too special: Since
 \<^const>\<open>UNIV\<close> is already the largest set, they cannot be substructures. The ability to reason
 about substructures is however a common reason to use \<^session>\<open>HOL-Algebra\<close> in the first place.
 \hyperref[sec:ethy]{Section~\ref*{sec:ethy}} follows a different approach using mostly abstract types.
\<close>

subsection \<open>Modelling of Polynomials\<close>

text \<open>There are both old-school @{type[names_long] up_ring}, and @{const[names_long] polynomial}.
 This coexistence had not much effect on my development, but it means that
 \<^theory>\<open>HOL-Algebra.Polynomials\<close> cannot be added to the imports without also switching to long
  identifiers for some entities.

The original motivation to avoid \<^theory>\<open>HOL-Algebra.Polynomials\<close> was the requirement of
  \<^const>\<open>ring.normalize\<close> in definitions, lemmas and proofs. This deficiency stems from
  representing the polynomials as coefficient lists, thereby losing uniqueness. A unification of the
 two approaches is subject of ongoing development. I refer the reader to the Isabelle developers for
  more information.\<close>

subsection \<open>Side Notes\<close>

text \<open>The file \<^file>\<open>~~/src/HOL/Algebra/README.html\<close> is quite outdated.\<close>

text \<open>In \<^file>\<open>~~/src/HOL/Algebra/document/root.tex\<close>, I suggest to use
\\\<^verbatim>\<open>\includegraphics[height=\textheight]{session_graph}\<close>\\
for the session graph, so that it is
  displayed wholly in the document.\<close>

section \<open>Conclusion\<close>

text \<open>Contrary to Isabelle/HOL itself, the libraries \<^session>\<open>HOL-Algebra\<close> and
 \isatt{VectorSpace} leave much to be desired in terms of usability and uniformity. Formalising
 based upon them proved hard in the areas of both field extensions and vector spaces:
 The result of a few months' work barely amounts to a handful of formalised textbook pages.

Hopefully, my development can be part of the effort to provide the basics of abstract algebra within
 this fine prove assistant.
\<close>

section \<open>Additional Resources\<close>

text \<open>In \isatt{README.md}, the changes to the AFP entry \isatt{VectorSpace} are documented.
 Overall, the diff to AFP\,2019 is designed to be small, so that the
 modifications can be easily reconstructed with a normal diff-viewer.

Another reference is the generated document of the repository's main session
 \<^session>\<open>Field_Extensions\<close>. In particular its detailed contents section may make lemmas that
  were not mentioned here easier to find.\<close>

(*<*)
end
(*>*)


(*  Title:      ZF/pair.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1992  University of Cambridge
*)

section\<open>Ordered Pairs\<close>

theory pair imports upair
begin

ML_file \<open>simpdata.ML\<close>

setup \<open>
  map_theory_simpset
    (Simplifier.set_mksimps (fn ctxt => map mk_eq o ZF_atomize o Variable.gen_all ctxt)
      #> Simplifier.add_cong @{thm if_weak_cong})
\<close>

ML \<open>val ZF_ss = simpset_of \<^context>\<close>

simproc_setup defined_Bex ("\<exists>x\<in>A. P(x) & Q(x)") = \<open>
  fn _ => Quantifier1.rearrange_Bex
    (fn ctxt => unfold_tac ctxt @{thms Bex_def})
\<close>

simproc_setup defined_Ball ("\<forall>x\<in>A. P(x) \<longrightarrow> Q(x)") = \<open>
  fn _ => Quantifier1.rearrange_Ball
    (fn ctxt => unfold_tac ctxt @{thms Ball_def})
\<close>

(** Lemmas for showing that <a,b> uniquely determines a and b **)

lemma singleton_eq_iff [iff]: "{a} = {b} \<longleftrightarrow> a=b"
by (rule extension [THEN iff_trans], blast)

lemma doubleton_eq_iff: "{a,b} = {c,d} \<longleftrightarrow> (a=c & b=d) | (a=d & b=c)"
by (rule extension [THEN iff_trans], blast)

lemma Pair_iff [simp]: "<a,b> = <c,d> \<longleftrightarrow> a=c & b=d"
by (simp add: Pair_def doubleton_eq_iff, blast)

lemmas Pair_inject = Pair_iff [THEN iffD1, THEN conjE, elim!]

lemmas Pair_inject1 = Pair_iff [THEN iffD1, THEN conjunct1]
lemmas Pair_inject2 = Pair_iff [THEN iffD1, THEN conjunct2]

lemma Pair_not_0: "<a,b> \<noteq> 0"
apply (unfold Pair_def)
apply (blast elim: equalityE)
done

lemmas Pair_neq_0 = Pair_not_0 [THEN notE, elim!]

declare sym [THEN Pair_neq_0, elim!]

lemma Pair_neq_fst: "<a,b>=a ==> P"
proof (unfold Pair_def)
  assume eq: "{{a, a}, {a, b}} = a"
  have  "{a, a} \<in> {{a, a}, {a, b}}" by (rule consI1)
  hence "{a, a} \<in> a" by (simp add: eq)
  moreover have "a \<in> {a, a}" by (rule consI1)
  ultimately show "P" by (rule mem_asym)
qed

lemma Pair_neq_snd: "<a,b>=b ==> P"
proof (unfold Pair_def)
  assume eq: "{{a, a}, {a, b}} = b"
  have  "{a, b} \<in> {{a, a}, {a, b}}" by blast
  hence "{a, b} \<in> b" by (simp add: eq)
  moreover have "b \<in> {a, b}" by blast
  ultimately show "P" by (rule mem_asym)
qed

subsection\<open>Sigma: Disjoint Union of a Family of Sets\<close>

text\<open>Generalizes Cartesian product\<close>

lemma Sigma_iff [simp]: "<a,b>: Sigma(A,B) \<longleftrightarrow> a \<in> A & b \<in> B(a)"
by (simp add: Sigma_def)

lemma SigmaI [TC,intro!]: "[| a \<in> A;  b \<in> B(a) |] ==> <a,b> \<in> Sigma(A,B)"
by simp

lemmas SigmaD1 = Sigma_iff [THEN iffD1, THEN conjunct1]
lemmas SigmaD2 = Sigma_iff [THEN iffD1, THEN conjunct2]

(*The general elimination rule*)
lemma SigmaE [elim!]:
    "[| c \<in> Sigma(A,B);
        !!x y.[| x \<in> A;  y \<in> B(x);  c=<x,y> |] ==> P
     |] ==> P"
by (unfold Sigma_def, blast)

lemma SigmaE2 [elim!]:
    "[| <a,b> \<in> Sigma(A,B);
        [| a \<in> A;  b \<in> B(a) |] ==> P
     |] ==> P"
by (unfold Sigma_def, blast)

lemma Sigma_cong:
    "[| A=A';  !!x. x \<in> A' ==> B(x)=B'(x) |] ==>
     Sigma(A,B) = Sigma(A',B')"
by (simp add: Sigma_def)

(*Sigma_cong, Pi_cong NOT given to Addcongs: they cause
  flex-flex pairs and the "Check your prover" error.  Most
  Sigmas and Pis are abbreviated as * or -> *)

lemma Sigma_empty1 [simp]: "Sigma(0,B) = 0"
by blast

lemma Sigma_empty2 [simp]: "A*0 = 0"
by blast

lemma Sigma_empty_iff: "A*B=0 \<longleftrightarrow> A=0 | B=0"
by blast

subsection\<open>Projections \<^term>\<open>fst\<close> and \<^term>\<open>snd\<close>\<close>

lemma fst_conv [simp]: "fst(<a,b>) = a"
by (simp add: fst_def)

lemma snd_conv [simp]: "snd(<a,b>) = b"
by (simp add: snd_def)

lemma fst_type [TC]: "p \<in> Sigma(A,B) ==> fst(p) \<in> A"
by auto

lemma snd_type [TC]: "p \<in> Sigma(A,B) ==> snd(p) \<in> B(fst(p))"
by auto

lemma Pair_fst_snd_eq: "a \<in> Sigma(A,B) ==> <fst(a),snd(a)> = a"
by auto

subsection\<open>The Eliminator, \<^term>\<open>split\<close>\<close>

(*A META-equality, so that it applies to higher types as well...*)
lemma split [simp]: "split(%x y. c(x,y), <a,b>) == c(a,b)"
by (simp add: split_def)

lemma split_type [TC]:
    "[|  p \<in> Sigma(A,B);
         !!x y.[| x \<in> A; y \<in> B(x) |] ==> c(x,y):C(<x,y>)
     |] ==> split(%x y. c(x,y), p) \<in> C(p)"
by (erule SigmaE, auto)

lemma expand_split:
  "u \<in> A*B ==>
        R(split(c,u)) \<longleftrightarrow> (\<forall>x\<in>A. \<forall>y\<in>B. u = <x,y> \<longrightarrow> R(c(x,y)))"
by (auto simp add: split_def)

subsection\<open>A version of \<^term>\<open>split\<close> for Formulae: Result Type \<^typ>\<open>o\<close>\<close>

lemma splitI: "R(a,b) ==> split(R, <a,b>)"
by (simp add: split_def)

lemma splitE:
    "[| split(R,z);  z \<in> Sigma(A,B);
        !!x y. [| z = <x,y>;  R(x,y) |] ==> P
     |] ==> P"
by (auto simp add: split_def)

lemma splitD: "split(R,<a,b>) ==> R(a,b)"
by (simp add: split_def)

text \<open>
  \bigskip Complex rules for Sigma.
\<close>

lemma split_paired_Bex_Sigma [simp]:
     "(\<exists>z \<in> Sigma(A,B). P(z)) \<longleftrightarrow> (\<exists>x \<in> A. \<exists>y \<in> B(x). P(<x,y>))"
by blast

lemma split_paired_Ball_Sigma [simp]:
     "(\<forall>z \<in> Sigma(A,B). P(z)) \<longleftrightarrow> (\<forall>x \<in> A. \<forall>y \<in> B(x). P(<x,y>))"
by blast

end


(*  Title:      HOL/Quotient_Examples/Lift_Fun.thy
    Author:     Ondrej Kuncar
*)

section \<open>Example of lifting definitions with contravariant or co/contravariant type variables\<close>

theory Lift_Fun
imports Main "HOL-Library.Quotient_Syntax"
begin

text \<open>This file is meant as a test case.
  It contains examples of lifting definitions with quotients that have contravariant
  type variables or type variables which are covariant and contravariant in the same time.\<close>

subsection \<open>Contravariant type variables\<close>

text \<open>'a is a contravariant type variable and we are able to map over this variable
  in the following four definitions. This example is based on HOL/Fun.thy.\<close>

quotient_type
('a, 'b) fun' (infixr "\<rightarrow>" 55) = "'a \<Rightarrow> 'b" / "(=)"
  by (simp add: identity_equivp)

quotient_definition "comp' :: ('b \<rightarrow> 'c) \<rightarrow> ('a \<rightarrow> 'b) \<rightarrow> 'a \<rightarrow> 'c"  is
  "comp :: ('b \<Rightarrow> 'c) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'c" done

quotient_definition "fcomp' :: ('a \<Rightarrow> 'b) \<Rightarrow> ('b \<Rightarrow> 'c) \<Rightarrow> 'a \<Rightarrow> 'c" is
  fcomp done

quotient_definition "map_fun' :: ('c \<rightarrow> 'a) \<rightarrow> ('b \<rightarrow> 'd) \<rightarrow> ('a \<rightarrow> 'b) \<rightarrow> 'c \<rightarrow> 'd"
  is "map_fun::('c \<Rightarrow> 'a) \<Rightarrow> ('b \<Rightarrow> 'd) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'c \<Rightarrow> 'd" done

quotient_definition "inj_on' :: ('a \<rightarrow> 'b) \<rightarrow> 'a set \<rightarrow> bool" is inj_on done

quotient_definition "bij_betw' :: ('a \<rightarrow> 'b) \<rightarrow> 'a set \<rightarrow> 'b set \<rightarrow> bool" is bij_betw done

subsection \<open>Co/Contravariant type variables\<close>

text \<open>'a is a covariant and contravariant type variable in the same time.
  The following example is a bit artificial. We haven't had a natural one yet.\<close>

quotient_type 'a endofun = "'a \<Rightarrow> 'a" / "(=)" by (simp add: identity_equivp)

definition map_endofun' :: "('a \<Rightarrow> 'b) \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> ('a => 'a) \<Rightarrow> ('b => 'b)"
  where "map_endofun' f g e = map_fun g f e"

quotient_definition "map_endofun :: ('a \<Rightarrow> 'b) \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> 'a endofun \<Rightarrow> 'b endofun" is
  map_endofun' done

text \<open>Registration of the map function for 'a endofun.\<close>

functor map_endofun : map_endofun
proof -
  have "\<forall> x. abs_endofun (rep_endofun x) = x" using Quotient3_endofun by (auto simp: Quotient3_def)
  then show "map_endofun id id = id"
    by (auto simp: map_endofun_def map_endofun'_def map_fun_def fun_eq_iff)

  have a:"\<forall> x. rep_endofun (abs_endofun x) = x" using Quotient3_endofun
    Quotient3_rep_abs[of "(=)" abs_endofun rep_endofun] by blast
  show "\<And>f g h i. map_endofun f g \<circ> map_endofun h i = map_endofun (f \<circ> h) (i \<circ> g)"
    by (auto simp: map_endofun_def map_endofun'_def map_fun_def fun_eq_iff) (simp add: a o_assoc)
qed

text \<open>Relator for 'a endofun.\<close>

definition
  rel_endofun' :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> ('b \<Rightarrow> 'b) \<Rightarrow> bool"
where
  "rel_endofun' R = (\<lambda>f g. (R ===> R) f g)"

quotient_definition "rel_endofun :: ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a endofun \<Rightarrow> 'b endofun \<Rightarrow> bool" is
  rel_endofun' done

lemma endofun_quotient:
assumes a: "Quotient3 R Abs Rep"
shows "Quotient3 (rel_endofun R) (map_endofun Abs Rep) (map_endofun Rep Abs)"
proof (intro Quotient3I)
  show "\<And>a. map_endofun Abs Rep (map_endofun Rep Abs a) = a"
    by (metis (opaque_lifting, no_types) a abs_o_rep id_apply map_endofun.comp map_endofun.id o_eq_dest_lhs)
next
  show "\<And>a. rel_endofun R (map_endofun Rep Abs a) (map_endofun Rep Abs a)"
  using fun_quotient3[OF a a, THEN Quotient3_rep_reflp]
  unfolding rel_endofun_def map_endofun_def map_fun_def o_def map_endofun'_def rel_endofun'_def id_def
    by (metis (mono_tags) Quotient3_endofun rep_abs_rsp)
next
  have abs_to_eq: "\<And> x y. abs_endofun x = abs_endofun y \<Longrightarrow> x = y"
  by (drule arg_cong[where f=rep_endofun]) (simp add: Quotient3_rep_abs[OF Quotient3_endofun])
  fix r s
  show "rel_endofun R r s =
          (rel_endofun R r r \<and>
           rel_endofun R s s \<and> map_endofun Abs Rep r = map_endofun Abs Rep s)"
    apply(auto simp add: rel_endofun_def rel_endofun'_def map_endofun_def map_endofun'_def)
    using fun_quotient3[OF a a,THEN Quotient3_refl1]
    apply metis
    using fun_quotient3[OF a a,THEN Quotient3_refl2]
    apply metis
    using fun_quotient3[OF a a, THEN Quotient3_rel]
    apply metis
    by (auto intro: fun_quotient3[OF a a, THEN Quotient3_rel, THEN iffD1] simp add: abs_to_eq)
qed

declare [[mapQ3 endofun = (rel_endofun, endofun_quotient)]]

quotient_definition "endofun_id_id :: ('a endofun) endofun" is "id :: ('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a)" done

term  endofun_id_id
thm  endofun_id_id_def

quotient_type 'a endofun' = "'a endofun" / "(=)" by (simp add: identity_equivp)

text \<open>We have to map "'a endofun" to "('a endofun') endofun", i.e., mapping (lifting)
  over a type variable which is a covariant and contravariant type variable.\<close>

quotient_definition "endofun'_id_id :: ('a endofun') endofun'" is endofun_id_id done

term  endofun'_id_id
thm  endofun'_id_id_def

end


(*
    Authors:      Jose Divasón
                  Sebastiaan Joosten
                  René Thiemann
                  Akihisa Yamada
*)
subsection \<open>Maximal Degree during Reconstruction\<close>

text \<open>We define a function which computes an upper bound on the degree of
  a factor for which we have to reconstruct the integer values of the coefficients.
  This degree will determine how large the second parameter of the factor-bound will
  be.

  In essence, if the Berlekamp-factorization will produce $n$ factors with degrees
  $d_1,\ldots,d_n$, then our bound will be the sum of the $\frac{n}2$ largest degrees.
  The reason is that we will combine at most $\frac{n}2$ factors before reconstruction.

  Soundness of the bound is proven, as well as a monotonicity property.\<close>

theory Degree_Bound
  imports Containers.Set_Impl (* for sort_append_Cons_swap *)
  "HOL-Library.Multiset"
  Polynomial_Interpolation.Missing_Polynomial
  "Efficient-Mergesort.Efficient_Sort"
begin

definition max_factor_degree :: "nat list \<Rightarrow> nat" where
  "max_factor_degree degs = (let
     ds = sort degs
     in sum_list (drop (length ds div 2) ds))"

definition degree_bound where "degree_bound vs = max_factor_degree (map degree vs)"

lemma insort_middle: "sort (xs @ x # ys) = insort x (sort (xs @ ys))"
  by (metis append.assoc sort_append_Cons_swap sort_snoc)

lemma sum_list_insort[simp]:
  "sum_list (insort (d :: 'a :: {comm_monoid_add,linorder}) xs) = d + sum_list xs"
proof (induct xs)
  case (Cons x xs)
  thus ?case by (cases "d \<le> x", auto simp: ac_simps)
qed simp

lemma half_largest_elements_mono: "sum_list (drop (length ds div 2) (sort ds))
    \<le> sum_list (drop (Suc (length ds) div 2) (insort (d :: nat) (sort ds)))"
proof -
  define n  where "n  = length ds div 2"
  define m  where "m  = Suc (length ds) div 2"
  define xs where "xs = sort ds"
  have xs: "sorted xs" unfolding xs_def by auto
  have nm: "m \<in> {n, Suc n}" unfolding n_def m_def by auto
  show ?thesis unfolding n_def[symmetric] m_def[symmetric] xs_def[symmetric]
    using nm xs
  proof (induct xs arbitrary: n m d)
    case (Cons x xs n m d)
    show ?case
    proof (cases n)
      case 0
      with Cons(2) have m: "m = 0 \<or> m = 1" by auto
      show ?thesis
      proof (cases "d \<le> x")
        case True
        hence ins: "insort d (x # xs) = d # x # xs" by auto
        show ?thesis unfolding ins 0 using True m by auto
      next
        case False
        hence ins: "insort d (x # xs) = x # insort d xs" by auto
        show ?thesis unfolding ins 0 using False m by auto
      qed
    next
      case (Suc nn)
      with Cons(2) obtain mm where m: "m = Suc mm" and mm: "mm \<in> {nn, Suc nn}" by auto
      from Cons(3) have sort: "sorted xs" by (simp)
      note IH = Cons(1)[OF mm]
      show ?thesis
      proof (cases "d \<le> x")
        case True
        with Cons(3) have ins: "insort d (x # xs) = d # insort x xs"
          by (cases xs, auto)
        show ?thesis unfolding ins Suc m using IH[OF sort] by auto
      next
        case False
        hence ins: "insort d (x # xs) = x # insort d xs" by auto
        show ?thesis unfolding ins Suc m using IH[OF sort] Cons(3) by auto
      qed
    qed
  qed auto
qed

lemma max_factor_degree_mono:
  "max_factor_degree (map degree (fold remove1 ws vs)) \<le> max_factor_degree (map degree vs)"
  unfolding max_factor_degree_def Let_def length_sort length_map
proof (induct ws arbitrary: vs)
  case (Cons w ws vs)
  show ?case
  proof (cases "w \<in> set vs")
    case False
    hence "remove1 w vs = vs" by (rule remove1_idem)
    thus ?thesis using Cons[of vs] by auto
  next
    case True
    then obtain bef aft where vs: "vs = bef @ w # aft" and rem1: "remove1 w vs = bef @ aft"
      by (metis remove1.simps(2) remove1_append split_list_first)
    let ?exp = "\<lambda> ws vs. sum_list (drop (length (fold remove1 ws vs) div 2)
      (sort (map degree (fold remove1 ws vs))))"
    let ?bnd = "\<lambda> vs. sum_list (drop (length vs div 2) (sort (map degree vs)))"
    let ?bd = "\<lambda> vs. sum_list (drop (length vs div 2) (sort vs))"
    define ba where "ba = bef @ aft"
    define ds where "ds = map degree ba"
    define d  where "d  = degree w"
    have "?exp (w # ws) vs = ?exp ws (bef @ aft)" by (auto simp: rem1)
    also have "\<dots> \<le> ?bnd ba" unfolding ba_def by (rule Cons)
    also have "\<dots> = ?bd ds" unfolding ds_def by simp
    also have "\<dots> \<le> sum_list (drop (Suc (length ds) div 2) (insort d (sort ds)))"
      by (rule half_largest_elements_mono)
    also have "\<dots> = ?bnd vs" unfolding vs ds_def d_def by (simp add: ba_def insort_middle)
    finally show "?exp (w # ws) vs \<le> ?bnd vs" by simp
  qed
qed auto

lemma mset_sub_decompose: "mset ds \<subseteq># mset bs + as \<Longrightarrow> length ds < length bs \<Longrightarrow> \<exists> b1 b b2.
   bs = b1 @ b # b2 \<and> mset ds \<subseteq># mset (b1 @ b2) + as"
proof (induct ds arbitrary: bs as)
  case Nil
  hence "bs = [] @ hd bs # tl bs" by auto
  thus ?case by fastforce
next
  case (Cons d ds bs as)
  have "d \<in># mset (d # ds)" by auto
  with Cons(2) have d: "d \<in># mset bs + as" by (rule mset_subset_eqD)
  hence "d \<in> set bs \<or> d \<in># as" by auto
  thus ?case
  proof
    assume "d \<in> set bs"
    from this[unfolded in_set_conv_decomp] obtain b1 b2 where bs: "bs = b1 @ d # b2" by auto
    from Cons(2) Cons(3)
    have "mset ds \<subseteq># mset (b1 @ b2) + as" "length ds < length (b1 @ b2)" by (auto simp: ac_simps bs)
    from Cons(1)[OF this] obtain b1' b b2' where split: "b1 @ b2 = b1' @ b # b2'"
      and sub: "mset ds \<subseteq># mset (b1' @ b2') + as" by auto
    from split[unfolded append_eq_append_conv2]
    obtain us where "b1 = b1' @ us \<and> us @ b2 = b # b2' \<or> b1 @ us = b1' \<and> b2 = us @ b # b2'" ..
    thus ?thesis
    proof
      assume "b1 @ us = b1' \<and> b2 = us @ b # b2'"
      hence *: "b1 @ us = b1'" "b2 = us @ b # b2'" by auto
      hence bs: "bs = (b1 @ d # us) @ b # b2'" unfolding bs by auto
      show ?thesis
        by (intro exI conjI, rule bs, insert * sub, auto simp: ac_simps)
    next
      assume "b1 = b1' @ us \<and> us @ b2 = b # b2'"
      hence *: "b1 = b1' @ us" "us @ b2 = b # b2'" by auto
      show ?thesis
      proof (cases us)
        case Nil
        with * have *: "b1 = b1'" "b2 = b # b2'" by auto
        hence bs: "bs = (b1' @ [d]) @ b # b2'" unfolding bs by simp
        show ?thesis
          by (intro exI conjI, rule bs, insert * sub, auto simp: ac_simps)
      next
        case (Cons u vs)
        with * have *: "b1 = b1' @ b # vs" "vs @ b2 = b2'" by auto
        hence bs: "bs = b1' @ b # (vs @ d # b2)" unfolding bs by auto
        show ?thesis
          by (intro exI conjI, rule bs, insert * sub, auto simp: ac_simps)
      qed
    qed
  next
    define as' where "as' = as - {#d#}"
    assume "d \<in># as"
    hence as': "as = {#d#} + as'" unfolding as'_def by auto
    from Cons(2)[unfolded as'] Cons(3) have "mset ds \<subseteq># mset bs + as'" "length ds < length bs"
      by (auto simp: ac_simps)
    from Cons(1)[OF this] obtain b1 b b2 where bs: "bs = b1 @ b # b2" and
      sub: "mset ds \<subseteq># mset (b1 @ b2) + as'" by auto
    show ?thesis
      by (intro exI conjI, rule bs, insert sub, auto simp: as' ac_simps)
  qed
qed

lemma max_factor_degree_aux: fixes es :: "nat list"
  assumes sub: "mset ds \<subseteq># mset es"
    and len: "length ds + length ds \<le> length es" and sort: "sorted es"
  shows "sum_list ds \<le> sum_list (drop (length es div 2) es)"
proof -
  define bef where "bef = take (length es div 2) es"
  define aft where "aft = drop (length es div 2) es"
  have es: "es = bef @ aft" unfolding bef_def aft_def by auto
  from len have len: "length ds \<le> length bef" "length ds \<le> length aft" unfolding bef_def aft_def
    by auto
  from sub have sub: "mset ds \<subseteq># mset bef + mset aft" unfolding es by auto
  from sort have sort: "sorted (bef @ aft)" unfolding es .
  show ?thesis unfolding aft_def[symmetric] using sub len sort
  proof (induct ds arbitrary: bef aft)
    case (Cons d ds bef aft)
    have "d \<in># mset (d # ds)" by auto
    with Cons(2) have "d \<in># mset bef + mset aft" by (rule mset_subset_eqD)
    hence "d \<in> set bef \<or> d \<in> set aft" by auto
    thus ?case
    proof
      assume "d \<in> set aft"
      from this[unfolded in_set_conv_decomp] obtain a1 a2 where aft: "aft = a1 @ d # a2" by auto
      from Cons(4) have len_a: "length ds \<le> length (a1 @ a2)" unfolding aft by auto
      from Cons(2)[unfolded aft] Cons(3)
      have "mset ds \<subseteq># mset bef + (mset (a1 @ a2))" "length ds < length bef" by auto
      from mset_sub_decompose[OF this]
      obtain b b1 b2
        where bef: "bef = b1 @ b # b2" and sub: "mset ds \<subseteq># (mset (b1 @ b2) + mset (a1 @ a2))" by auto
      from Cons(3) have len_b: "length ds \<le> length (b1 @ b2)" unfolding bef by auto
      from Cons(5)[unfolded bef aft] have sort: "sorted ( (b1 @ b2) @ (a1 @ a2))"
        unfolding sorted_append by auto
      note IH = Cons(1)[OF sub len_b len_a sort]
      show ?thesis using IH unfolding aft by simp
    next
      assume "d \<in> set bef"
      from this[unfolded in_set_conv_decomp] obtain b1 b2 where bef: "bef = b1 @ d # b2" by auto
      from Cons(3) have len_b: "length ds \<le> length (b1 @ b2)" unfolding bef by auto
      from Cons(2)[unfolded bef] Cons(4)
      have "mset ds \<subseteq># mset aft + (mset (b1 @ b2))" "length ds < length aft" by (auto simp: ac_simps)
      from mset_sub_decompose[OF this]
      obtain a a1 a2
        where aft: "aft = a1 @ a # a2" and sub: "mset ds \<subseteq># (mset (b1 @ b2) + mset (a1 @ a2))"
        by (auto simp: ac_simps)
      from Cons(4) have len_a: "length ds \<le> length (a1 @ a2)" unfolding aft by auto
      from Cons(5)[unfolded bef aft] have sort: "sorted ( (b1 @ b2) @ (a1 @ a2))" and ad: "d \<le> a"
        unfolding sorted_append by auto
      note IH = Cons(1)[OF sub len_b len_a sort]
      show ?thesis using IH ad unfolding aft by simp
    qed
  qed auto
qed

lemma max_factor_degree: assumes sub: "mset ws \<subseteq># mset vs"
  and len: "length ws + length ws \<le> length vs"
  shows "degree (prod_list ws) \<le> max_factor_degree (map degree vs)"
proof -
  define ds where "ds \<equiv> map degree ws"
  define es where "es \<equiv> sort (map degree vs)"
  from sub len have sub: "mset ds \<subseteq># mset es" and len: "length ds + length ds \<le> length es"
    and es: "sorted es"
    unfolding ds_def es_def
    by (auto simp: image_mset_subseteq_mono)
  have "degree (prod_list ws) \<le> sum_list (map degree ws)" by (rule degree_prod_list_le)
  also have "\<dots> \<le> max_factor_degree (map degree vs)"
    unfolding max_factor_degree_def Let_def ds_def[symmetric] es_def[symmetric]
    using sub len es by (rule max_factor_degree_aux)
  finally show ?thesis .
qed

lemma degree_bound: assumes sub: "mset ws \<subseteq># mset vs"
  and len: "length ws + length ws \<le> length vs"
shows "degree (prod_list ws) \<le> degree_bound vs"
  using max_factor_degree[OF sub len] unfolding degree_bound_def by auto

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_BubSortIsSort
  imports "../../Test_Base"
begin

datatype ('a, 'b) pair = pair2 "'a" "'b"

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

datatype Nat = Z | S "Nat"

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

fun insert :: "Nat => Nat list => Nat list" where
  "insert x (nil2) = cons2 x (nil2)"
| "insert x (cons2 z xs) =
     (if le x z then cons2 x (cons2 z xs) else cons2 z (insert x xs))"

fun isort :: "Nat list => Nat list" where
  "isort (nil2) = nil2"
| "isort (cons2 y xs) = insert y (isort xs)"

fun bubble :: "Nat list => (bool, (Nat list)) pair" where
  "bubble (nil2) = pair2 False (nil2)"
| "bubble (cons2 y (nil2)) = pair2 False (cons2 y (nil2))"
| "bubble (cons2 y (cons2 y2 xs)) =
     (if le y y2 then
        (case bubble (cons2 y2 xs) of
           pair2 b22 ys22 => pair2 b22 (cons2 y ys22))
        else
        (case bubble (cons2 y xs) of
           pair2 b2 ys2 => pair2 True (cons2 y2 ys2)))"

(*fun did not finish the proof*)
function bubsort :: "Nat list => Nat list" where
  "bubsort x =
   (case bubble x of pair2 b1 ys => (if b1 then bubsort ys else x))"
  by pat_completeness auto

theorem property0 :
  "((bubsort xs) = (isort xs))"
  oops

end