theory SepAlgebra
  imports Main
begin

type_synonym 'a assertion = "'a \<Rightarrow> bool option"

subsection \<open>Preliminary separation algebra\<close>

locale commutative_monoid =
  fixes orig_plus :: "'a \<Rightarrow> 'a \<Rightarrow> 'a option"
  fixes u :: "'a"
  assumes orig_comm: "orig_plus a b = orig_plus b a"
      and asso1: "Some ab = orig_plus a b \<and> Some bc = orig_plus b c \<Longrightarrow> orig_plus ab c = orig_plus a bc"
      and asso2: "Some ab = orig_plus a b \<and> None = orig_plus b c \<Longrightarrow> None = orig_plus ab c"
      and asso3: "None = orig_plus a b \<and> Some bc = orig_plus b c \<Longrightarrow> None = orig_plus a bc"
      and orig_neutral: "orig_plus a u = Some a"
begin

fun plus :: "'a option \<Rightarrow> 'a option \<Rightarrow> 'a option" (infixl "\<oplus>" 60) where
  "Some a \<oplus> Some b = orig_plus a b"
| "_ \<oplus> _ = None"

definition defined :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infixl "##" 60)
  where "defined a b \<longleftrightarrow> (\<not> Option.is_none (Some a \<oplus> Some b))"

definition smaller :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infixl "<<" 50) where
  "smaller a b \<longleftrightarrow> (\<exists>c. Some b = Some a \<oplus> Some c)"

lemma commutative:
  "a \<oplus> b = b \<oplus> a"
  by (metis option.exhaust_sel orig_comm plus.simps(1) plus.simps(2) plus.simps(3))

lemma associative:
  "(a \<oplus> b) \<oplus> c = a \<oplus> (b \<oplus> c)"
proof (cases "\<exists>aa bb cc. a = Some aa \<and> b = Some bb \<and> c = Some cc")
  case True
  then obtain aa bb cc where "a = Some aa \<and> b = Some bb \<and> c = Some cc" by blast
  then show ?thesis
  proof (cases "Some aa \<oplus> Some bb")
    case None
    then have "(a \<oplus> b) \<oplus> c = None"
      by (simp add: \<open>a = Some aa \<and> b = Some bb \<and> c = Some cc\<close>)
    then show ?thesis
    proof (cases "Some bb \<oplus> Some cc")
      case None
      then show ?thesis
        using \<open>a = Some aa \<and> b = Some bb \<and> c = Some cc\<close> \<open>a \<oplus> b \<oplus> c = None\<close> by auto
    next
      case (Some ab)
      then show ?thesis
        by (metis None \<open>a = Some aa \<and> b = Some bb \<and> c = Some cc\<close> \<open>a \<oplus> b \<oplus> c = None\<close> asso3 plus.simps(1))
    qed
  next
    case (Some ab)
    then have "Some ab = Some aa \<oplus> Some bb" by simp
    then show ?thesis
    proof (cases "Some bb \<oplus> Some cc")
      case None
      then show ?thesis
        by (metis Some \<open>a = Some aa \<and> b = Some bb \<and> c = Some cc\<close> asso2 plus.simps(1) plus.simps(3))
    next
      case (Some bc)
      then show ?thesis
        by (metis \<open>Some ab = Some aa \<oplus> Some bb\<close> \<open>a = Some aa \<and> b = Some bb \<and> c = Some cc\<close> plus.simps(1) commutative_monoid.asso1 commutative_monoid_axioms)
    qed
  qed
next
  case False
  then show ?thesis
    by auto
qed

lemma neutral:
  "a \<oplus> Some u = a" by (metis option.distinct(1) option.sel orig_neutral plus.elims)

lemma smaller_refl:
  "a << a"
  by (metis neutral smaller_def)

lemma smaller_trans:
  assumes "a << b"
      and "b << c"
    shows "a << c"
proof -
  obtain ab bc where "Some b = Some ab \<oplus> Some a" "Some c = Some bc \<oplus> Some b"
    by (metis assms(1) assms(2) commutative smaller_def)
  then have "Some c = Some bc \<oplus> (Some ab \<oplus> Some a)"
    using associative by auto
  then show ?thesis
    by (metis associative commutative option.discI option.exhaust_sel plus.simps(2) smaller_def)
qed

definition pure :: "'a \<Rightarrow> bool" where
  "pure \<phi> \<longleftrightarrow> Some \<phi> \<oplus> Some \<phi> = Some \<phi>"

definition pure_set :: "'a \<Rightarrow> 'a set" where
  "pure_set \<phi> = {\<phi>'. pure \<phi>' \<and> \<phi>' << \<phi>}"

definition core :: "'a \<Rightarrow> 'a" ("|_|")
  where "|\<phi>| = the (Finite_Set.fold (\<oplus>) (Some u) (Some ` (pure_set \<phi>)))"

lemma pure_smaller_ok:
  assumes "p << \<phi>"
      and "pure p"
    shows "Some \<phi> = Some \<phi> \<oplus> Some p"
  by (smt assms(1) assms(2) associative commutative pure_def smaller_def)

lemma pure_add:
  assumes "pure a"
  assumes "pure b"
  assumes "a ## b"
  shows "pure (the (Some a \<oplus> Some b))"
proof -
  have "Some (the (Some a \<oplus> Some b)) = Some a \<oplus> Some b"
    by (metis (no_types) Option.is_none_def assms(3) defined_def option.collapse)
  then show ?thesis
    by (metis (full_types) assms(1) assms(2) associative commutative pure_def)
qed

lemma pure_set_stable_add:
  assumes "a \<in> pure_set \<phi>"
      and "b \<in> pure_set \<phi>"
      and "Some c = Some a \<oplus> Some b"
    shows "c \<in> pure_set \<phi>"
proof -
  have "pure c"
    by (metis assms(1) assms(2) assms(3) defined_def is_none_code(2) mem_Collect_eq option.sel pure_add pure_set_def)
  obtain "Some \<phi> = Some \<phi> \<oplus> Some a" and "Some \<phi> = Some \<phi> \<oplus> Some b"
    using assms(1) assms(2) pure_smaller_ok pure_set_def commutative_monoid_axioms by fastforce
  then have "Some \<phi> = Some \<phi> \<oplus> Some a \<oplus> Some b" by presburger
  then have "c << \<phi>" by (metis assms(3) associative commutative smaller_def)
  then show ?thesis by (simp add: \<open>pure c\<close> pure_set_def)
qed

lemma pure_u [simp]: "pure u" by (simp add: orig_neutral pure_def)

lemma u_smaller [simp]: "u << \<phi>" by (simp add: commutative neutral smaller_def)

lemma empty_in_pure:
  "u \<in> pure_set \<phi>"
  by (simp add: pure_set_def)

definition s_core :: "'a \<Rightarrow> 'a option" where "s_core x = Some |x|"

end

subsection \<open>Separation algebra\<close>

locale sep_algebra = commutative_monoid +
  fixes C :: "'a \<Rightarrow> 'a"
  fixes \<sigma> :: "'a \<Rightarrow> 'b set"

  (* Algebra *)
  assumes finiteness: "finite {\<phi>'. pure \<phi>' \<and> \<phi>' << \<phi>}"
      and positivity: "Some a \<oplus> Some b = Some u \<Longrightarrow> a = u"
      and partially_cancellative: "Some (C \<phi>) \<oplus> Some a = Some (C \<phi>) \<oplus> Some b \<Longrightarrow> a = b"
      and unique_c: "Some \<phi> = Some |\<phi>| \<oplus> Some \<phi>' \<and> |\<phi>'| = u \<longleftrightarrow> \<phi>' = C \<phi>"

  (* STORE *)
      and store_C_empty: "\<sigma> (C \<phi>) = {}"
      and store_pure: "\<sigma> \<phi> = \<sigma> |\<phi>|"
      and store_add: "Some a = Some c \<oplus> Some d \<Longrightarrow> \<sigma> a = \<sigma> c \<union> \<sigma> d"
      and compatible_stores: "a ## b \<Longrightarrow> pure a \<Longrightarrow> \<sigma> a \<subseteq> \<sigma> b \<Longrightarrow> a << b"
      and unique_store_exists: "var \<in> \<sigma> a \<Longrightarrow> (\<exists>c. \<sigma> c = {var} \<and> c << a)"
      and defined_disjoint_store: "\<sigma> a \<inter> \<sigma> b = {} \<Longrightarrow> pure a \<Longrightarrow> a ## b"
begin

lemma decompo: "Some \<phi> = Some |\<phi>| \<oplus> Some (C \<phi>)"
  using unique_c by blast

lemma store_empty: "\<sigma> u = {}"
  by (metis decompo neutral positivity sep_algebra.unique_c sep_algebra_axioms store_C_empty)

lemma pure_u:
  "|u| = u"
  by (metis decompo positivity)

definition some_core :: "'a \<Rightarrow> 'a option" where
  "some_core \<phi> = (Finite_Set.fold (\<oplus>) (Some u) (Some ` (pure_set \<phi>)))"

lemma commut_comp: "\<And>y x. (\<oplus>) y \<circ> (\<oplus>) x = (\<oplus>) x \<circ> (\<oplus>) y"
  apply (rule ext)
proof -
  fix y x xa
  have "((\<oplus>) y \<circ> (\<oplus>) x) xa = (\<oplus>) y (x \<oplus> xa)" by simp
  then have "... = y \<oplus> (x \<oplus> xa)" by simp
  then have "... = x \<oplus> (y \<oplus> xa)" using associative commutative by auto
  then have "... = ((\<oplus>) x \<circ> (\<oplus>) y) xa" by simp
  then show "((\<oplus>) y \<circ> (\<oplus>) x) xa = ((\<oplus>) x \<circ> (\<oplus>) y) xa"
    by (metis \<open>y \<oplus> (x \<oplus> xa) = x \<oplus> (y \<oplus> xa)\<close> comp_apply)
qed

interpretation add_pure: comp_fun_commute "plus"
  by unfold_locales (simp add: commut_comp)

lemma "fold_graph (\<oplus>) (Some u) (Some ` pure_set \<phi>) (some_core \<phi>)"
proof -
  let ?A = "Some ` pure_set \<phi>"
  have "finite ?A" by (simp add: finiteness pure_set_def)
  then have "fold_graph (\<oplus>) (Some u) ?A (Finite_Set.fold (\<oplus>) (Some u) ?A)"
    using add_pure.fold_graph_fold by blast
  then show ?thesis by (simp add: some_core_def)
qed

lemma "|\<phi>| = the (some_core \<phi>)" by (simp add: core_def some_core_def)

lemma pure_set_u: "pure_set u = {u}"
proof -
  have "\<And>x. x << u \<Longrightarrow> x = u" using positivity smaller_def by auto
  moreover have "pure u" by simp
  ultimately show ?thesis using pure_set_def by auto
qed

lemma some_core_u:
  "some_core u = Some u"
by (simp add: neutral pure_set_u some_core_def)

definition some_prop :: "'a \<Rightarrow> 'a option set \<Rightarrow> 'a option \<Rightarrow> bool" where
  "some_prop \<phi> S s \<longleftrightarrow> (S \<subseteq> Some ` pure_set \<phi> \<longrightarrow> (S = {} \<and> s = Some u) \<or> (s \<in> Some ` pure_set \<phi> \<and> (\<forall>s' \<in> S. the s' << the s)))"

lemma some_prop_proof:
  "some_prop \<phi> (Some ` pure_set \<phi>) (some_core \<phi>)"
proof -
  have "fold_graph (\<oplus>) (Some u) (Some ` pure_set \<phi>) (some_core \<phi>)"
    by (simp add: add_pure.comp_fun_commute_axioms comp_fun_commute.fold_graph_fold finiteness pure_set_def some_core_def)
  moreover have "some_prop \<phi> {} (Some u)" using some_prop_def by blast
  moreover have "\<And>x A y. x \<notin> A \<and> fold_graph (\<oplus>) (Some u) A y \<and> some_prop \<phi> A y \<Longrightarrow> some_prop \<phi> (insert x A) (x \<oplus> y)"
  proof -
    fix x A y
    assume "x \<notin> A \<and> fold_graph (\<oplus>) (Some u) A y \<and> some_prop \<phi> A y"
    then show "some_prop \<phi> (insert x A) (x \<oplus> y)"
    proof (cases "(insert x A) \<subseteq> Some ` pure_set \<phi>")
      case True
      then show ?thesis
      proof (cases "A = {}")
        case True
        then show ?thesis
          by (metis \<open>x \<notin> A \<and> fold_graph (\<oplus>) (Some u) A y \<and> some_prop \<phi> A y\<close> empty_fold_graphE insert_subset neutral sep_algebra.some_prop_def sep_algebra_axioms singletonD smaller_refl)
      next
        case False
        then have "y \<in> Some ` pure_set \<phi> \<and> (\<forall>s' \<in> A. the s' << the y)"
          using True \<open>x \<notin> A \<and> fold_graph (\<oplus>) (Some u) A y \<and> some_prop \<phi> A y\<close> some_prop_def by auto
        moreover obtain "A \<subseteq> Some ` pure_set \<phi>" "x \<in> Some ` pure_set \<phi>" using True by blast
        then obtain xx where "x = Some xx" "xx \<in> pure_set \<phi>" by blast
        moreover obtain yy where "y = Some yy" "yy \<in> pure_set \<phi>" using \<open>A \<subseteq> Some ` pure_set \<phi>\<close> calculation(1) by blast
        then obtain zz where "Some zz = Some xx \<oplus> Some yy"
        proof -
          assume a1: "\<And>zz. Some zz = Some xx \<oplus> Some yy \<Longrightarrow> thesis"
          have "\<forall>a aa. a \<notin> pure_set aa \<or> Some aa = orig_plus aa a"
            using commutative_monoid.pure_set_def commutative_monoid_axioms pure_smaller_ok by fastforce
          then show ?thesis
            using a1 by (metis (lifting) \<open>y = Some yy\<close> \<open>yy \<in> pure_set \<phi>\<close> associative calculation(2) calculation(3) option.exhaust orig_comm plus.simps(1) plus.simps(2))
        qed
        then have "Some zz \<in> Some ` pure_set \<phi>" by (meson \<open>yy \<in> pure_set \<phi>\<close> calculation(3) image_eqI pure_set_stable_add)
        moreover have "xx << zz" using \<open>Some zz = Some xx \<oplus> Some yy\<close> smaller_def by blast
        moreover have "\<And>s' . s' \<in> A \<Longrightarrow> the s' << zz"
        proof -
          fix s' assume "s' \<in> A"
          then have "the s' << yy" using \<open>y = Some yy\<close> calculation(1) by auto
          then show "the s' << zz"
            by (metis \<open>Some zz = Some xx \<oplus> Some yy\<close> commutative smaller_def smaller_trans)
        qed
        ultimately have "\<forall>s' \<in> (insert x A). the s' << zz" by simp
        then show ?thesis
          by (metis (mono_tags, lifting) \<open>Some zz = Some xx \<oplus> Some yy\<close> \<open>Some zz \<in> Some ` pure_set \<phi>\<close> \<open>x = Some xx\<close> \<open>y = Some yy\<close> option.sel sep_algebra.some_prop_def sep_algebra_axioms)
      qed
    next
      case False
      then show ?thesis using some_prop_def by auto
    qed
  qed
  ultimately show "some_prop \<phi> (Some ` pure_set \<phi>) (some_core \<phi>)" using fold_graph.induct[of "(\<oplus>)" "Some u" "Some ` (pure_set \<phi>)" "some_core \<phi>" "some_prop \<phi>"]
    by blast
qed

lemma core_is_max_uni:
  "|\<phi>| \<in> pure_set \<phi> \<and> (\<forall>x \<in> pure_set \<phi>. x << |\<phi>| )"
proof -
  have "some_core \<phi> \<in> Some ` pure_set \<phi> \<and> (\<forall>x \<in> pure_set \<phi>. x << the (some_core \<phi>))"
  proof -
    have "some_prop \<phi> (Some ` pure_set \<phi>) (some_core \<phi>)" using some_prop_proof by auto
    then have "(Some ` pure_set \<phi> \<subseteq> Some ` pure_set \<phi> \<longrightarrow> (Some ` pure_set \<phi> = {} \<and> some_core \<phi> = Some u) \<or> (some_core \<phi> \<in> Some ` pure_set \<phi> \<and> (\<forall>s' \<in> Some ` pure_set \<phi>. the s' << the (some_core \<phi>))))"
      by (simp add: some_prop_def)
    then have "(Some ` pure_set \<phi> = {} \<and> some_core \<phi> = Some u) \<or> (some_core \<phi> \<in> Some ` pure_set \<phi> \<and> (\<forall>s' \<in> Some ` pure_set \<phi>. the s' << the (some_core \<phi>)))"
      by blast
    moreover have "pure_set \<phi> \<noteq> {}" using empty_in_pure by blast
    then have "Some ` pure_set \<phi> \<noteq> {}" by simp
    ultimately have "some_core \<phi> \<in> Some ` pure_set \<phi> \<and> (\<forall>s' \<in> Some ` pure_set \<phi>. the s' << the (some_core \<phi>))"
      by linarith
    then show ?thesis by auto
  qed
  moreover have "some_core \<phi> = Some |\<phi>|" using calculation core_def some_core_def by auto
  ultimately show ?thesis by (simp add: image_iff smaller_def)
qed

lemma core_is_max:
  "\<phi>' = |\<phi>| \<longleftrightarrow> (\<phi>' \<in> pure_set \<phi> \<and> (\<forall>\<phi>'' \<in> pure_set \<phi>. \<phi>'' << \<phi>'))" (is "?a \<longleftrightarrow> ?b")
proof -
  have "?a \<Longrightarrow> ?b" using core_is_max_uni by blast
  moreover have "?b \<Longrightarrow> ?a"
    by (metis (no_types, lifting) commutative core_is_max_uni mem_Collect_eq option.inject commutative_monoid.pure_smaller_ok commutative_monoid_axioms pure_set_def)
  ultimately show ?thesis by blast
qed

lemma sum_pure:
  assumes "pure a"
      and "pure b"
      and "Some c = Some a \<oplus> Some b"
    shows "pure c"
  by (metis assms(1) assms(2) assms(3) is_none_code(2) option.sel commutative_monoid.defined_def commutative_monoid_axioms pure_add)

lemma add_trans:
  assumes "a << aa"
      and "b << bb"
      and "Some cc = Some aa \<oplus> Some bb"
      and "Some c = Some a \<oplus> Some b"
    shows "c << cc"
proof -
  obtain aaa where "Some aa = Some a \<oplus> Some aaa" using assms(1) smaller_def by blast
  obtain bbb where "Some bb = Some b \<oplus> Some bbb" using assms(2) smaller_def by blast
  then have "Some cc = Some a \<oplus> Some aaa \<oplus> Some b \<oplus> Some bbb"
    by (simp add: \<open>Some aa = Some a \<oplus> Some aaa\<close> assms(3) associative)
  then have "Some cc = Some c \<oplus> Some aaa \<oplus> Some bbb" by (metis assms(4) associative commutative)
  then show ?thesis by (metis associative plus.elims smaller_def)
qed

lemma pure_set_finite:
  "finite (pure_set \<phi>)"
  by (simp add: finiteness pure_set_def)

definition s_C :: "'a \<Rightarrow> 'a option" where "s_C x = Some (C x)"

lemma core_properties:
  shows "pure |\<phi>|"
    and "|\<phi>| << \<phi>"
    and "pure \<phi> \<longleftrightarrow> \<phi> = |\<phi>|"
proof -
  show "pure |\<phi>|" using core_is_max pure_set_def by auto
  show "|\<phi>| << \<phi>" using core_is_max pure_set_def by auto
  show "pure \<phi> \<longleftrightarrow> \<phi> = |\<phi>|" (is "?a \<longleftrightarrow> ?b")
  proof -
    have "?b \<longrightarrow> ?a" using \<open>pure |\<phi>|\<close> by auto
    moreover have "?a \<Longrightarrow> ?b"
    proof -
      assume "?a"
      then have "\<phi> \<in> pure_set \<phi>" by (simp add: pure_set_def smaller_refl)
      then show "?b" by (simp add: core_is_max pure_set_def)
    qed
    then show ?thesis using calculation by blast
  qed
qed

lemma not_pure_core:
  "\<not> pure \<phi> \<longleftrightarrow> \<phi> \<noteq> |\<phi>|" (is "?a \<longleftrightarrow> ?b")
  using core_properties(3) by auto

definition add_set :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a set" (infixl "\<oplus>\<oplus>" 60) where
  "A \<oplus>\<oplus> B = {the (Some a \<oplus> Some b) | a b. a \<in> A \<and> b \<in> B \<and> a ## b}"

lemma elem_add_set:
  "x \<in> A \<oplus>\<oplus> B \<longleftrightarrow> (\<exists>a b. a \<in> A \<and> b \<in> B \<and> Some x = Some a \<oplus> Some b)"
  by (smt defined_def is_none_code(2) is_none_simps(1) mem_Collect_eq option.expand option.sel sep_algebra.add_set_def sep_algebra_axioms)

lemma simple_set_add_comm:
  "A \<oplus>\<oplus> B = B \<oplus>\<oplus> A"
proof -
  have "\<And>A B. A \<oplus>\<oplus> B \<subseteq> B \<oplus>\<oplus> A"
  proof (rule subsetI)
    fix A B x assume "x \<in> A \<oplus>\<oplus> B"
    obtain a b where "a \<in> A" "b \<in> B" "a ## b" "x = the (Some a \<oplus> Some b)" using \<open>x \<in> A \<oplus>\<oplus> B\<close> add_set_def by auto
    then have "Some x = Some a \<oplus> Some b" by (simp add: Option.is_none_def defined_def)
    then obtain "b ## a" "x = the (Some b \<oplus> Some a)"
      using \<open>a ## b\<close> \<open>x = the (Some a \<oplus> Some b)\<close> commutative defined_def by auto
    then show "x \<in> B \<oplus>\<oplus> A"
      by (metis (mono_tags, lifting) CollectI \<open>a \<in> A\<close> \<open>b \<in> B\<close> add_set_def)
  qed
  then show ?thesis by blast
qed

lemma core_inv:
  "||\<phi>|| = |\<phi>|"
  using core_properties(1) not_pure_core by auto

lemma decompo_new_plus:
  "Some \<phi> = s_core \<phi> \<oplus> s_C \<phi>"
  using decompo s_C_def s_core_def by fastforce

lemma c_empty_core: "|C \<phi>| = u" (is "?x = u")
proof -
  have "\<sigma> ?x = {}"
    using store_C_empty store_pure by blast
  moreover have "pure ?x"
    by (simp add: core_properties(1))
  then have "?x << u"
    by (simp add: calculation compatible_stores defined_disjoint_store)
  then show ?thesis
    using positivity smaller_def by auto
qed

lemma properties_c:
  shows "a = b \<longleftrightarrow> |a| = |b| \<and> C a = C b"
    and "C (C \<phi>) = C \<phi>"
  apply (metis decompo option.inject)
  by (metis c_empty_core commutative commutative_monoid.neutral commutative_monoid_axioms unique_c)

lemma definedness [simp]:
  assumes "a ## b"
  shows "C a ## b"
    and "core a ## b"
    and "b ## a"
  apply (metis (full_types) Option.is_none_def add_pure.comp_fun_commute_axioms assms commutative comp_fun_commute.fun_left_comm decompo defined_def plus.simps(3))
  apply (smt Option.is_none_def add_pure.comp_fun_commute_axioms assms commutative comp_fun_commute.fun_left_comm core_properties(1) core_properties(2) defined_def plus.simps(3) pure_smaller_ok)
  by (metis assms commutative defined_def)

definition bigger_set :: "'a set \<Rightarrow> 'a set \<Rightarrow> bool" (infixl ">>" 50) where
  "A >> B \<longleftrightarrow> (\<forall>a \<in> A. \<exists>b \<in> B. b << a)"

lemma rel_bigger_add_set:
  assumes "A = B \<oplus>\<oplus> D"
  shows "A >> B"
proof -
  have "\<And>a. a \<in> A \<Longrightarrow> (\<exists>b\<in>B. b << a)"
  proof -
    fix a assume "a \<in> A"
    obtain b d where "Some a = Some b \<oplus> Some d" "b \<in> B"
      using \<open>a \<in> A\<close> assms elem_add_set by auto
    then show "\<exists>b\<in>B. b << a" using smaller_def by auto
  qed
  then show ?thesis by (simp add: bigger_set_def)
qed

lemma defined_trans_plus:
  assumes "Some a = Some b \<oplus> Some c \<oplus> Some d"
  shows "c ## d"
  by (metis Option.is_none_def assms associative defined_def option.simps(3) commutative_monoid.plus.simps(3) commutative_monoid_axioms)

lemma neutral_parts:
  shows "|u| = u"
    and "C u = u"
  using core_properties(3) pure_u apply auto[1]
  by (metis c_empty_core properties_c(2) pure_u sep_algebra.properties_c(1) sep_algebra_axioms)

lemma plus_and_bigger_set:
  assumes "A >> B"
  shows "(A \<oplus>\<oplus> D) >> (B \<oplus>\<oplus> D)"
proof -
  have "\<And>ad. (ad \<in> A \<oplus>\<oplus> D) \<Longrightarrow> (\<exists>bd \<in> B \<oplus>\<oplus> D. bd << ad)"
  proof -
    fix ad assume "ad \<in> A \<oplus>\<oplus> D"
    then obtain a d where "a \<in> A" "d \<in> D" "Some ad = Some a \<oplus> Some d" using elem_add_set by auto
    then obtain b where "b \<in> B" "b << a" using assms bigger_set_def by blast
    then obtain c where "Some a = Some b \<oplus> Some c" using smaller_def by blast
    then have "Some ad = Some b \<oplus> Some c \<oplus> Some d" by (simp add: \<open>Some ad = Some a \<oplus> Some d\<close>)
    moreover obtain bd where "Some bd = Some b \<oplus> Some d"
      by (metis \<open>Some ad = Some a \<oplus> Some d\<close> \<open>\<And>thesis. (\<And>c. Some a = Some b \<oplus> Some c \<Longrightarrow> thesis) \<Longrightarrow> thesis\<close> asso2 commutative option.exhaust_sel plus.simps(1))
    ultimately have "bd << ad" by (metis associative commutative smaller_def)
    then show "\<exists>bd \<in> B \<oplus>\<oplus> D. bd << ad"
      using \<open>Some bd = Some b \<oplus> Some d\<close> \<open>b \<in> B\<close> \<open>d \<in> D\<close> elem_add_set by blast
  qed
  then show ?thesis by (simp add: bigger_set_def)
qed

lemma simple_set_add:
  assumes "Some a = Some b \<oplus> Some c"
  shows "{b} \<oplus>\<oplus> {c} = {a}" (is "?s = ?a")
proof -
  have "?a \<subseteq> ?s"
    by (smt CollectI assms is_none_code(2) option.sel add_set_def defined_def sep_algebra_axioms singletonD singletonI subsetI)
  moreover have "?s \<subseteq> ?a"
    by (smt CollectD add_set_def assms insertCI option.sel singletonD subsetI)
  ultimately show ?thesis by blast
qed

lemma set_add_elem:
  assumes "x \<in> A \<oplus>\<oplus> B"
  shows "\<exists>a b. a \<in> A \<and> b \<in> B \<and> Some x = Some a \<oplus> Some b"
proof -
  obtain a b where "a ## b" "x = the (Some a \<oplus> Some b)" "a \<in> A" "b \<in> B"
    using add_set_def assms by auto
  then show ?thesis by (metis defined_def is_none_simps(1) option.collapse)
qed

lemma set_add_elem_reci:
  assumes "a \<in> A \<and> b \<in> B \<and> Some x = Some a \<oplus> Some b"
  shows "x \<in> A \<oplus>\<oplus> B"
  by (metis (mono_tags, lifting) CollectI add_set_def assms is_none_code(2) option.sel defined_def)

lemma set_add_asso:
  "(A \<oplus>\<oplus> B) \<oplus>\<oplus> D = A \<oplus>\<oplus> (B \<oplus>\<oplus> D)" (is "?g = ?d")
proof -
  have "?g \<subseteq> ?d"
  proof (rule subsetI)
    fix x assume "x \<in> ?g"
    obtain ab d where "Some x = Some ab \<oplus> Some d" "ab \<in> A \<oplus>\<oplus> B" "d \<in> D"
      using \<open>x \<in> A \<oplus>\<oplus> B \<oplus>\<oplus> D\<close> set_add_elem by blast
    then obtain a b where "Some ab = Some a \<oplus> Some b" "a \<in> A" "b \<in> B"
      using set_add_elem by blast
    then obtain bd where "Some bd = Some b \<oplus> Some d"
      by (metis \<open>Some x = Some ab \<oplus> Some d\<close> asso2 not_Some_eq option.simps(3) plus.simps(1))
    then obtain "a ## bd" "b ## d" "Some x = Some a \<oplus> (Some b \<oplus> Some d)"
      by (metis \<open>Some ab = Some a \<oplus> Some b\<close> \<open>Some x = Some ab \<oplus> Some d\<close> associative defined_def is_none_code(2))
    then have "bd \<in> B \<oplus>\<oplus> D"
      using \<open>Some bd = Some b \<oplus> Some d\<close> \<open>b \<in> B\<close> \<open>d \<in> D\<close> set_add_elem_reci by blast
    then show "x \<in> ?d"
      using \<open>Some bd = Some b \<oplus> Some d\<close> \<open>Some x = Some a \<oplus> (Some b \<oplus> Some d)\<close> \<open>a \<in> A\<close> set_add_elem_reci by metis
  qed
  moreover have "?d \<subseteq> ?g"
  proof (rule subsetI)
    fix x assume "x \<in> ?d"
    obtain bd a where "Some x = Some a \<oplus> Some bd" "a \<in> A" "bd \<in> B \<oplus>\<oplus> D"
      using \<open>x \<in> A \<oplus>\<oplus> (B \<oplus>\<oplus> D)\<close> set_add_elem by blast
    then obtain b d where "Some bd = Some b \<oplus> Some d" "d \<in> D" "b \<in> B"
      using set_add_elem by blast
    then obtain ab where "Some ab = Some a \<oplus> Some b"
      by (metis \<open>Some x = Some a \<oplus> Some bd\<close> asso3 not_None_eq plus.simps(1))
    then obtain "ab ## d" "a ## b" "Some x = (Some a \<oplus> Some b) \<oplus> Some d"
      by (metis \<open>Some bd = Some b \<oplus> Some d\<close> \<open>Some x = Some a \<oplus> Some bd\<close> associative defined_def is_none_code(2))
    then have "ab \<in> A \<oplus>\<oplus> B"
      using \<open>Some ab = Some a \<oplus> Some b\<close> \<open>b \<in> B\<close> \<open>a \<in> A\<close> set_add_elem_reci by blast
    then show "x \<in> ?g"
      by (metis \<open>Some ab = Some a \<oplus> Some b\<close> \<open>\<And>thesis. (\<lbrakk>ab ## d; a ## b; Some x = Some a \<oplus> Some b \<oplus> Some d\<rbrakk> \<Longrightarrow> thesis) \<Longrightarrow> thesis\<close> \<open>d \<in> D\<close> set_add_elem_reci)
  qed
  ultimately show ?thesis by blast
qed

lemma bigger_set_union:
  assumes "A' >> A"
      and "B' >> B"
    shows "A' \<union> B' >> A \<union> B"
proof -
  have "\<And>x. x \<in> A' \<union> B' \<Longrightarrow> (\<exists>y \<in> A \<union> B. y << x)"
    using assms(1) assms(2) bigger_set_def by auto
  then show ?thesis by (simp add: bigger_set_def)
qed

lemma c_trans_ineq:
  assumes "b << a"
      and "Some a = s_C x \<oplus> Some aa"
      and "Some b = s_C x \<oplus> Some bb"
    shows "bb << aa"
proof -
  obtain c where "Some a = Some b \<oplus> Some c" using assms(1) smaller_def by blast
  then have "s_C x \<oplus> (Some bb \<oplus> Some c) = s_C x \<oplus> Some aa" using assms(2) assms(3) associative by simp
  then have "Some bb \<oplus> Some c = Some aa"
    by (metis assms(2) not_None_eq partially_cancellative plus.simps(3) s_C_def)
  then show ?thesis by (metis smaller_def)
qed

lemma bigger_set_forall:
  "A >> B \<longleftrightarrow> (\<forall>a\<in>A. {a} >> B)"
  by (simp add: bigger_set_def)

lemma subset_smaller:
  assumes "A \<subseteq> B"
  shows "A >> B"
  by (meson assms bigger_set_def in_mono smaller_refl)

lemma bigger_set_trans:
  assumes "A >> B"
      and "B >> D"
    shows "A >> D"
proof -
  have "\<And>a. a \<in> A \<Longrightarrow> (\<exists>d\<in>D. d << a)"
  proof -
    fix a assume "a \<in> A"
    then obtain b where "b \<in> B" "b << a" using assms(1) bigger_set_def by auto
    then obtain d where "d \<in> D" "d << b" using assms(2) bigger_set_def by auto
    then show "\<exists>d\<in>D. d << a" using \<open>b << a\<close> smaller_trans by blast
  qed
  then show ?thesis by (simp add: bigger_set_def)
qed

lemma pure_set_add_smaller:
  assumes "A \<oplus>\<oplus> B = A"
  shows "A >> B"
  by (metis assms rel_bigger_add_set simple_set_add_comm)

lemma decompose_set:
  assumes "x \<in> A \<oplus>\<oplus> B \<oplus>\<oplus> {c} \<oplus>\<oplus> {d}"
  shows "\<exists>a b. a \<in> A \<and> b \<in> B \<and> Some x = Some a \<oplus> Some b \<oplus> Some c \<oplus> Some d"
  by (smt assms elem_add_set singletonD)

lemma add_pure_singleton:
  assumes "A >> B"
      and "A >> {p}"
      and "pure p"
    shows "A >> B \<oplus>\<oplus> {p}"
proof -
  have "\<And>a. a \<in> A \<Longrightarrow> (\<exists>bp \<in> B \<oplus>\<oplus> {p}. bp << a)"
  proof -
    fix a assume "a \<in> A"
    then obtain b where "b \<in> B" "b << a" "p << a" using assms(1) assms(2) bigger_set_def by auto
    then obtain bp where "Some bp = Some b \<oplus> Some p"
      by (metis assms(3) asso3 commutative not_Some_eq plus.simps(1) pure_smaller_ok smaller_def)
    then have "bp << a" using \<open>b << a\<close> \<open>p << a\<close> add_trans assms(3) pure_smaller_ok smaller_refl by blast
    moreover have "bp \<in> B \<oplus>\<oplus> {p}"
      by (meson \<open>Some bp = Some b \<oplus> Some p\<close> \<open>b \<in> B\<close> sep_algebra.set_add_elem_reci sep_algebra_axioms singletonI)
    ultimately show "\<exists>bp \<in> B \<oplus>\<oplus> {p}. bp << a" by blast
  qed
  then show ?thesis by (simp add: bigger_set_def)
qed

lemma add_sets_neutral:
  "A \<oplus>\<oplus> {u} = A" (is "?a = ?b")
proof -
  have "?a \<subseteq> ?b" by (metis option.sel orig_neutral plus.simps(1) set_add_elem singletonD subsetI)
  moreover have "?b \<subseteq> ?a"
    by (metis commutative_monoid.neutral commutative_monoid_axioms set_add_elem_reci singletonI subsetI)
  ultimately show ?thesis by simp
qed

lemma pure_reducibility:
  assumes "pure p"
      and "p << a"
      and "Some a = Some b \<oplus> Some c"
    shows "\<exists>a'. Some a' = s_core b \<oplus> s_core c \<and> p << a'"
proof -
  obtain a' where "Some a' = s_core b \<oplus> s_core c"
    by (metis assms(3) associative commutative decompo_new_plus option.discI option.exhaust_sel plus.simps(2))
  then have "\<sigma> p \<subseteq> \<sigma> a'"
  proof -
    have "\<sigma> a = \<sigma> b \<union> \<sigma> c"
      by (simp add: assms(3) store_add)
    then have "\<sigma> p \<subseteq> \<sigma> b \<union> \<sigma> c"
      by (metis assms(1) assms(2) pure_smaller_ok store_add sep_algebra_axioms sup.orderI)
    then show ?thesis
      by (metis (full_types) \<open>Some a' = s_core b \<oplus> s_core c\<close> s_core_def sep_algebra.store_add sep_algebra_axioms store_pure)
  qed
  then show ?thesis
    using \<open>Some a' = s_core b \<oplus> s_core c\<close> assms(1) assms(2) assms(3) associative commutative compatible_stores core_properties(1) decompo defined_trans_plus definedness(3) pure_def pure_smaller_ok s_core_def
    by metis
qed

lemma core_add:
  assumes "Some a = Some b \<oplus> Some c"
  shows "s_core a = s_core b \<oplus> s_core c"
proof -
  obtain core_bc where "Some core_bc = s_core b \<oplus> s_core c"
    by (meson assms neutral pure_def pure_reducibility sep_algebra_axioms u_smaller)
  have "core_bc \<in> pure_set a"
  proof -
    obtain "pure |b|" "pure |c|" using core_is_max pure_set_def by auto
    then have "pure core_bc"
      by (metis \<open>Some core_bc = s_core b \<oplus> s_core c\<close> s_core_def sum_pure)
    moreover have "core_bc << a"
      by (smt \<open>Some core_bc = s_core b \<oplus> s_core c\<close> \<open>pure |b|\<close> \<open>pure |c|\<close> assms associative commutative decompo pure_def s_core_def smaller_def)
    ultimately show ?thesis by (simp add: pure_set_def)
  qed
  then have "core_bc << |a|" using core_is_max_uni by blast
  moreover have "|a| << core_bc"
  proof -
    obtain a' where "Some a' = s_core b \<oplus> s_core c" "|a| << a'"
      using pure_reducibility[of "|a|" a b c]
      using assms core_is_max_uni commutative_monoid.pure_set_def commutative_monoid_axioms by fastforce
    then show ?thesis
      by (metis \<open>Some core_bc = s_core b \<oplus> s_core c\<close> option.inject)
  qed
  ultimately show ?thesis
    using \<open>Some core_bc = s_core b \<oplus> s_core c\<close> \<open>core_bc \<in> pure_set a\<close> core_is_max_uni orig_comm pure_set_def pure_smaller_ok s_core_def by fastforce
qed

lemma reduce_add:
  assumes "a ## b"
      and "Some a \<oplus> Some b = Some a \<oplus> Some c"
    shows "s_core a \<oplus> Some b = s_core a \<oplus> Some c"
proof -
  have dac: "a ## c" using assms(1) assms(2) defined_def by auto
  have "s_core a \<oplus> Some b = s_C b \<oplus> s_core (the (Some a \<oplus> Some b))"
    by (smt Option.is_none_def assms(2) associative commutative core_add dac decompo_new_plus defined_def option.collapse)
  moreover have "s_core a \<oplus> Some c = s_C c \<oplus> s_core (the (Some a \<oplus> Some c))"
    by (smt Option.is_none_def associative commutative core_add dac decompo_new_plus defined_def option.collapse)
  moreover have "s_C a \<oplus> s_C b \<oplus> s_core (the (Some a \<oplus> Some b)) = s_C a \<oplus> s_C c \<oplus> s_core (the (Some a \<oplus> Some c))"
    by (metis assms(2) associative calculation(1) calculation(2) commutative decompo_new_plus)
  moreover obtain rb where "Some rb = s_C b \<oplus> s_core (the (Some a \<oplus> Some b))"
    by (metis Option.is_none_def assms(1) calculation(1) defined_def definedness(2) option.collapse s_C_def s_core_def)
  moreover obtain rc where "Some rc = s_C c \<oplus> s_core (the (Some a \<oplus> Some c))"
    by (metis Option.is_none_def dac calculation(2) defined_def definedness(2) option.collapse s_C_def s_core_def)
  ultimately show ?thesis by (metis associative partially_cancellative s_C_def)
qed

lemma c_add:
  assumes "Some a = Some b \<oplus> Some c"
  shows "s_C a = s_C b \<oplus> s_C c"
proof -
  have "Some a = s_core b \<oplus> s_core c \<oplus> s_C b \<oplus> s_C c"
    using assms associative commutative decompo_new_plus by auto
  also have "... = s_core a \<oplus> s_C b \<oplus> s_C c" by (simp add: assms core_add)
  obtain bc where "Some bc = s_C b \<oplus> s_C c"
    by (metis associative calculation plus.elims)
  then have "core bc = u"
    by (metis c_empty_core core_add neutral option.inject s_C_def s_core_def)
  then show ?thesis
    by (metis \<open>Some bc = s_C b \<oplus> s_C c\<close> \<open>s_core b \<oplus> s_core c \<oplus> s_C b \<oplus> s_C c = s_core a \<oplus> s_C b \<oplus> s_C c\<close> associative calculation s_C_def s_core_def unique_c)
qed

lemma pure_c:
  "pure \<phi> \<longleftrightarrow> C \<phi> = u"
  by (metis core_inv core_properties(3) neutral neutral_parts(1) properties_c(1) unique_c)

lemma smaller_pure:
  assumes "a << b"
      and "pure b"
    shows "pure a"
proof -
  obtain c where "Some b = Some a \<oplus> Some c" using assms(1) smaller_def by blast
  moreover have "C b = u"
    by (metis assms(2) core_properties(3) neutral pure_u sep_algebra.unique_c sep_algebra_axioms)
  ultimately have "Some (C a) \<oplus> Some (C c) = Some u"
    using c_add s_C_def by auto
  then have "C a = u" by (metis positivity)
  then show ?thesis by (simp add: pure_c)
qed

lemma antisym:
  assumes "a << b"
      and "b << a"
    shows "a = b"
proof -
  obtain d e where "Some a = Some b \<oplus> Some d" and "Some b = Some a \<oplus> Some e"
    using assms(1) assms(2) smaller_def by blast
  then have "Some a = Some a \<oplus> Some d \<oplus> Some e"
    by (metis associative commutative)
  then have "Some a \<oplus> Some u = Some a \<oplus> (Some d \<oplus> Some e)"
    by (metis associative neutral)
  moreover have "a ## u"
    by (simp add: defined_def orig_neutral)
  ultimately have "s_core a = s_core a \<oplus> (Some d \<oplus> Some e)"
    using reduce_add[of a u "the (Some d \<oplus> Some e)"] defined_trans_plus
    \<open>Some a = Some a \<oplus> Some d \<oplus> Some e\<close> defined_def is_none_simps(1) option.collapse
    by (metis associative neutral)
  obtain de where "Some de = Some d \<oplus> Some e"
    by (metis Option.is_none_def \<open>Some a = Some a \<oplus> Some d \<oplus> Some e\<close> defined_def option.discI option.expand option.sel sep_algebra.defined_trans_plus sep_algebra_axioms)
  then have "de << core a"
    by (metis \<open>s_core a = s_core a \<oplus> (Some d \<oplus> Some e)\<close> commutative s_core_def smaller_def)
  then have "pure de" using core_properties(1) smaller_pure by blast
  then have "pure e"
    by (metis \<open>Some de = Some d \<oplus> Some e\<close> commutative smaller_def smaller_pure)
  then show ?thesis
    by (metis \<open>Some a = Some a \<oplus> Some d \<oplus> Some e\<close> \<open>Some b = Some a \<oplus> Some e\<close> option.inject commutative_monoid.associative commutative_monoid_axioms pure_def)
qed

lemma smaller_core_comp:
  "b << a \<longleftrightarrow> |b| << |a| \<and> C b << C a" (is "?a \<longleftrightarrow> ?b")
proof -
  have "?a \<Longrightarrow> ?b"
  proof -
    assume "?a"
    obtain c where "Some a = Some b \<oplus> Some c" using \<open>b << a\<close> smaller_def by blast
    then obtain "s_C a = s_C b \<oplus> s_C c" and "s_core a = s_core b \<oplus> s_core c" using c_add core_add by blast
    then show "?b" using s_C_def s_core_def smaller_def by auto
  qed
  moreover have "?b \<Longrightarrow> ?a"
  proof -
    assume "?b"
    obtain "Some a = s_core a \<oplus> s_C a" and "Some b = s_core b \<oplus> s_C b" using decompo_new_plus by blast
    then show "?a" using \<open>|b| << |a| \<and> C b << C a\<close> add_trans decompo by blast
  qed
  ultimately show ?thesis by blast
qed

lemma frame_trans:
  assumes "b << a"
      and "Some a = Some i \<oplus> Some ra"
      and "Some b = Some i \<oplus> Some rb"
      and "Some c = s_core i \<oplus> Some ra"
    shows "rb << c"
proof -
  have "C rb << C ra"
  proof -
    obtain "s_C a = s_C i \<oplus> s_C ra" "s_C b = s_C i \<oplus> s_C rb" using assms(2) c_add assms(3) by blast
    moreover have "C b << C a" using assms(1) c_add s_C_def smaller_def by auto
    ultimately show ?thesis using c_trans_ineq s_C_def by auto
  qed
  moreover have "|rb| << |c|"
  proof -
    have "s_core b = s_core i \<oplus> s_core rb" using assms(3) core_add by blast
    moreover have "|c| = |a|"
      by (smt assms(2) assms(4) core_add core_properties(1) core_properties(3) option.inject commutative_monoid.s_core_def commutative_monoid_axioms)
    ultimately show ?thesis by (metis assms(1) assms(3) commutative smaller_core_comp smaller_def smaller_trans)
  qed
  moreover have "C ra = C c" by (smt assms(4) c_add option.inject orig_neutral commutative_monoid.commutative
        commutative_monoid.plus.simps(1) commutative_monoid.s_core_def commutative_monoid_axioms pure_c s_C_def sep_algebra.core_properties(1) sep_algebra_axioms)
  ultimately obtain "C rb << C c" and "|rb| << |c|" by simp
  then show ?thesis using smaller_core_comp by blast
qed

end

end


section{*Attic*}
theory attic
imports Main "Lib/FiniteGraph"
begin

text{*old lemma, mainly unused. *}

lemma exists_x1x2_x1notoffending_natLeq:
  fixes
    G::"'v graph" and
    f and
    p::"'v \<Rightarrow> nat"
  assumes
    "wf_graph G"
    "\<exists>(e1, e2)\<in>(edges G). \<not> (p e1 \<le> p e2)" and
    "f \<subseteq> edges G \<and> (\<forall>(e1, e2)\<in>f. \<not> p e1 \<le> p e2)" and
    "\<forall>(e1, e2)\<in>(edges G) - f. p e1 \<le> p e2"
  shows "\<exists> x1 x2. (x1,x2)\<in>(edges G) \<and> (x1,x2)\<in> f \<and> x1 \<in> fst ` f \<and> x1 \<notin> snd ` f \<and> ((p x1) = Max (p`fst` f))"
proof -
   from assms have a2: "\<exists>x\<in>(edges G). \<not> (case x of (e1, e2) \<Rightarrow> p e1 \<le> p e2)" by auto
   from assms have a3: "f \<subseteq>(edges G) \<and> (\<forall>(e1, e2)\<in>f. \<not> p e1 \<le> p e2)" by simp
   from assms have a4: "\<forall>(e1, e2)\<in>(edges G) - f. p e1 \<le> p e2" by simp
   from assms(1) have finiteE: "finite (edges G)" using wf_graph.finiteE by fast
   from finiteE conjunct1[OF a3] have  finiteF: "finite f" by (metis rev_finite_subset)

   -- "Find a suitable x1, it is the Max of the firsts"
   from finiteF have x12: "\<forall> x \<in> f. Max (p`fst` f) \<ge> p (fst x)" by (metis Max_ge finite_imageI image_eqI)
   from a2 a4 have x14: "\<exists> x1. (p x1) \<in> p`fst` f \<and> x1 \<in> fst` f" by fast
   from finiteF have "(p`fst` f) \<noteq> {} \<Longrightarrow> Max (p`fst` f) \<in> (p`fst` f)" by simp
   hence x15: "Max (p`fst` f) \<in> (p`fst` f)" using x14 by fastforce
   hence "\<exists> x1. ((p x1) = Max (p`fst` f)) \<and> x1 \<in> fst` f" by force
   from this x14 obtain x1 where x1Cond: "((p x1) = Max (p`fst` f)) \<and> x1 \<in> fst` f" by blast

   -- "Thus x1 is not in the seconds, not offending"
   from x1Cond x15 have x1ImportantProp3: "(p x1) \<in> p`fst` f" by presburger
   from x1Cond conjunct2[OF a3] x12 have "\<forall>(e1, e2) \<in> f. p x1 > p e2" by fastforce

   from x1Cond this a2 a3 a4 have x1ImportantProp1: "(p x1) \<notin> p`snd` f" by force
   hence x1ImportantProp2: "x1 \<notin> snd` f" by blast

   -- "Obtain x2"
   from x1ImportantProp3 x1Cond have x1ImportantProp4: "x1 \<in> fst` f" by presburger
   from this x1ImportantProp2 have  "\<exists> x1 x2. (x1,x2) \<in> f \<and> x1 \<notin> snd` f" by fastforce
   from this x1Cond x1ImportantProp2 obtain x2 where x2Cond:"(x1,x2) \<in> f \<and> x1 \<notin> snd` f" by force

   from a3 have "\<And> x. x \<in> f \<Longrightarrow> x \<in> (edges G)" by blast
   from this x2Cond have x1x2Cond: "(x1,x2) \<in> (edges G)" by blast

   from x1x2Cond x2Cond x1Cond show ?thesis by auto
qed

lemma exCasePairSimp: "(\<exists>x. x \<in> A \<and> (case x of (e1, e2) \<Rightarrow> P e1 e2)) = (\<exists>(e1, e2) \<in> A. (P e1 e2))"
  by auto

lemma exCasePairNotSimp: "(\<exists>x. x \<in> A \<and> \<not> (case x of (e1, e2) \<Rightarrow> P e1 e2)) = (\<exists>(e1, e2) \<in> A. \<not> (P e1 e2))"
  by auto

(* moved here from FiniteGraph.thy. Currently unused *)
subsection {* Paths *}
  text {* A path is represented by a list of adjacent edges. *}
  type_synonym 'v path = "('v \<times> 'v) list"

  context wf_graph
  begin
    text {* The following predicate describes a valid path:*}
    (* is-path src [src, ...., dst] dst *)
    fun is_path :: "'v \<Rightarrow> 'v path \<Rightarrow> 'v \<Rightarrow> bool" where
      "is_path v [] v' \<longleftrightarrow> v=v' \<and> v'\<in>V" |
      "is_path v ((v1,v2)#p) v' \<longleftrightarrow> v=v1 \<and> (v1,v2)\<in>E \<and> is_path v2 p v'"

    lemma is_path_simps[simp, intro!]:
      "is_path v [] v \<longleftrightarrow> v\<in>V"
      "is_path v [(v,v')] v' \<longleftrightarrow> (v,v')\<in>E"
      by (auto dest: E_wfD)

    lemma is_path_memb[simp]:
      "is_path v p v' \<Longrightarrow> v\<in>V \<and> v'\<in>V"
      apply (induction p arbitrary: v)
       apply (auto dest: E_wfD)
      done

    lemma is_path_split:
      "is_path v (p1@p2) v' \<longleftrightarrow> (\<exists>u. is_path v p1 u \<and> is_path u p2 v')"
      by (induct p1 arbitrary: v) auto

    lemma is_path_split'[simp]:
      "is_path v (p1@(u,u')#p2) v'
        \<longleftrightarrow> is_path v p1 u \<and> (u,u')\<in>E \<and> is_path u' p2 v'"
      by (auto simp add: is_path_split)
  end

  text {* Set of intermediate vertices of a path. These are all vertices but
    the last one. Note that, if the last vertex also occurs earlier on the path,
    it is contained in @{text "int_vertices"}. *}
  definition int_vertices :: "'v path \<Rightarrow> 'v set" where
    "int_vertices p \<equiv> set (map fst p)"

  lemma int_vertices_simps[simp]:
    "int_vertices [] = {}"
    "int_vertices (vv#p) = insert (fst vv) (int_vertices p)"
    "int_vertices (p1@p2) = int_vertices p1 \<union> int_vertices p2"
    by (auto simp add: int_vertices_def)

  lemma (in wf_graph) int_vertices_subset:
    "is_path v p v' \<Longrightarrow> int_vertices p \<subseteq> V"
    apply (induct p arbitrary: v)
     apply (simp)
    apply (force dest: E_wfD)
    done

  lemma int_vertices_empty[simp]: "int_vertices p = {} \<longleftrightarrow> p=[]"
    by (cases p) auto

subsubsection {* Splitting Paths *}
  text {*Split a path at the point where it first leaves the set @{text W}: *}
  lemma (in wf_graph) path_split_set:
    assumes "is_path v p v'" and "v\<in>W" and "v'\<notin>W"
    obtains p1 p2 u w u' where
    "p=p1@(u,u')#p2" and
    "int_vertices p1 \<subseteq> W" and "u\<in>W" and "u'\<notin>W"
    using assms
  proof (induct p arbitrary: v thesis)
    case Nil thus ?case by auto
  next
    case (Cons vv p)
    note [simp, intro!] = `v\<in>W` `v'\<notin>W`
    from Cons.prems obtain u' where
      [simp]: "vv=(v,u')" and
        REST: "is_path u' p v'"
      by (cases vv) auto

    txt {* Distinguish wether the second node @{text u'} of the path is
      in @{text W}. If yes, the proposition follows by the
      induction hypothesis, otherwise it is straightforward, as
      the split takes place at the first edge of the path. *}
    {
      assume A [simp, intro!]: "u'\<in>W"
      from Cons.hyps[OF _ REST] obtain p1 uu uu' p2 where
        "p=p1@(uu,uu')#p2" "int_vertices p1 \<subseteq> W" "uu \<in> W" "uu' \<notin> W"
        by blast
      with Cons.prems(1)[of "vv#p1" uu uu' p2] have thesis by auto
    } moreover {
      assume "u'\<notin>W"
      with Cons.prems(1)[of "[]" v u' p] have thesis by auto
    } ultimately show thesis by blast
  qed

  text {*Split a path at the point where it first enters the set @{text W}:*}

  text {* Split a path at the point where a given vertex is first visited: *}
  lemma (in wf_graph) path_split_vertex:
    assumes "is_path v p v'" and "u\<in>int_vertices p"
    obtains p1 p2 where
    "p=p1@p2" and
    "is_path v p1 u" and
    "u \<notin> int_vertices p1"
    using assms
  proof (induct p arbitrary: v thesis)
    case Nil thus ?case by auto
  next
    case (Cons vv p)
    from Cons.prems obtain u' where
      [simp]: "vv=(v,u')" "v\<in>V" "(v,u')\<in>E" and
        REST: "is_path u' p v'"
      by (cases vv) auto

    {
      assume "u=v"
      with Cons.prems(1)[of "[]" "vv#p"] have thesis by auto
    } moreover {
      assume [simp]: "u\<noteq>v"
      with Cons.hyps(1)[OF _ REST] Cons.prems(3) obtain p1 p2 where
        "p=p1@p2" "is_path u' p1 u" "u\<notin>int_vertices p1"
        by auto
      with Cons.prems(1)[of "vv#p1" p2] have thesis
        by auto
    } ultimately show ?case by blast
  qed

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.*)
  theory TIP_sort_MSortTDPermutes
  imports "../../Test_Base"
begin

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

fun take :: "int => 'a list => 'a list" where
  "take x y =
   (if x <= 0 then nil2 else
      (case y of
         nil2 => nil2
         | cons2 z xs => cons2 z (take (x - 1) xs)))"

fun lmerge :: "int list => int list => int list" where
  "lmerge (nil2) y = y"
| "lmerge (cons2 z x2) (nil2) = cons2 z x2"
| "lmerge (cons2 z x2) (cons2 x3 x4) =
     (if z <= x3 then cons2 z (lmerge x2 (cons2 x3 x4)) else
        cons2 x3 (lmerge (cons2 z x2) x4))"

fun length :: "'a list => int" where
  "length (nil2) = 0"
| "length (cons2 y l) = 1 + (length l)"

fun elem :: "'a => 'a list => bool" where
  "elem x (nil2) = False"
| "elem x (cons2 z xs) = ((z = x) | (elem x xs))"

fun drop :: "int => 'a list => 'a list" where
  "drop x y =
   (if x <= 0 then y else
      (case y of
         nil2 => nil2
         | cons2 z xs1 => drop (x - 1) xs1))"

(*fun did not finish the proof*)
function msorttd :: "int list => int list" where
  "msorttd (nil2) = nil2"
| "msorttd (cons2 y (nil2)) = cons2 y (nil2)"
| "msorttd (cons2 y (cons2 x2 x3)) =
     (let k :: int = (op div) (length (cons2 y (cons2 x2 x3))) 2
     in lmerge
          (msorttd (take k (cons2 y (cons2 x2 x3))))
          (msorttd (drop k (cons2 y (cons2 x2 x3)))))"
  by pat_completeness auto

fun deleteBy :: "('a => ('a => bool)) => 'a => 'a list =>
                 'a list" where
  "deleteBy x y (nil2) = nil2"
| "deleteBy x y (cons2 y2 ys) =
     (if (x y) y2 then ys else cons2 y2 (deleteBy x y ys))"

fun isPermutation :: "'a list => 'a list => bool" where
  "isPermutation (nil2) (nil2) = True"
| "isPermutation (nil2) (cons2 z x2) = False"
| "isPermutation (cons2 x3 xs) y =
     ((elem x3 y) &
        (isPermutation
           xs (deleteBy (% (x4 :: 'a) => % (x5 :: 'a) => (x4 = x5)) x3 y)))"

theorem property0 :
  "isPermutation (msorttd xs) xs"
  oops

end


section \<open>Counting Irreducible Polynomials \label{sec:card_irred}\<close>

subsection \<open>The polynomial $X^n - X$\<close>

theory Card_Irreducible_Polynomials_Aux
imports
  "HOL-Algebra.Multiplicative_Group"
  Formal_Polynomial_Derivatives
  Monic_Polynomial_Factorization
begin

lemma (in domain)
  assumes "subfield K R"
  assumes "f \<in> carrier (K[X])" "degree f > 0"
  shows embed_inj: "inj_on (rupture_surj K f \<circ> poly_of_const) K"
    and rupture_order: "order (Rupt K f) = card K^degree f"
    and rupture_char: "char (Rupt K f) = char R"
proof -
  interpret p: principal_domain "K[X]"
    using univ_poly_is_principal[OF assms(1)] by simp

  interpret I: ideal "PIdl\<^bsub>K[X]\<^esub> f" "K[X]"
    using p.cgenideal_ideal[OF assms(2)] by simp

  interpret d: ring "Rupt K f"
    unfolding rupture_def using I.quotient_is_ring by simp

  have e: "subring K R"
    using assms(1) subfieldE(1) by auto

  interpret h:
    ring_hom_ring "R \<lparr> carrier := K \<rparr>"
      "Rupt K f" "rupture_surj K f \<circ> poly_of_const"
    using rupture_surj_norm_is_hom[OF e assms(2)]
    using ring_hom_ringI2 subring_is_ring d.is_ring e
    by blast

  have "field (R \<lparr>carrier := K\<rparr>)"
    using assms(1) subfield_iff(2) by simp
  hence "subfield K (R\<lparr>carrier := K\<rparr>)"
    using ring.subfield_iff[OF subring_is_ring[OF e]] by simp
  hence b: "subfield (rupture_surj K f ` poly_of_const ` K) (Rupt K f)"
    unfolding image_image comp_def[symmetric]
    by (intro h.img_is_subfield rupture_one_not_zero assms, simp)

  have "inj_on poly_of_const K"
    using poly_of_const_inj inj_on_subset by auto
  moreover have
    "poly_of_const ` K \<subseteq> ((\<lambda>q. q pmod f) ` carrier (K [X]))"
  proof (rule image_subsetI)
    fix x assume "x \<in> K"
    hence f:
      "poly_of_const x \<in> carrier (K[X])"
      "degree (poly_of_const x) = 0"
      using poly_of_const_over_subfield[OF assms(1)] by auto
    moreover
    have "degree (poly_of_const x) < degree f"
      using f(2) assms by simp
    hence "poly_of_const x pmod f = poly_of_const x"
      by (intro pmod_const(2)[OF assms(1)] f assms(2), simp)
    ultimately show
      "poly_of_const x \<in> ((\<lambda>q. q pmod f) ` carrier (K [X]))"
      by force
  qed
  hence "inj_on (rupture_surj K f) (poly_of_const ` K)"
    using rupture_surj_inj_on[OF assms(1,2)] inj_on_subset by blast
  ultimately show d: "inj_on (rupture_surj K f \<circ> poly_of_const) K"
    using comp_inj_on by auto

  have a: "d.dimension (degree f) (rupture_surj K f ` poly_of_const ` K)
    (carrier (Rupt K f))"
    using rupture_dimension[OF assms(1-3)] by auto
  then obtain base where base_def:
    "set base \<subseteq> carrier (Rupt K f)"
    "d.independent (rupture_surj K f ` poly_of_const ` K) base"
    "length base = degree f"
    "d.Span (rupture_surj K f ` poly_of_const ` K) base =
      carrier (Rupt K f)"
    using d.exists_base[OF b a] by auto
  have "order (Rupt K f) =
    card (d.Span (rupture_surj K f ` poly_of_const ` K) base)"
    unfolding order_def base_def(4) by simp
  also have "... =
    card (rupture_surj K f ` poly_of_const ` K) ^ length base"
    using d.card_span[OF b base_def(2,1)] by simp
  also have "...
    = card ((rupture_surj K f \<circ> poly_of_const) ` K) ^ degree f"
    using base_def(3) image_image unfolding comp_def by metis
  also have "... = card K^degree f"
    by (subst card_image[OF d], simp)
  finally show "order (Rupt K f) = card K^degree f" by simp

  have "char (Rupt K f) = char (R \<lparr> carrier := K \<rparr>)"
    using h.char_consistent d by simp
  also have "... = char R"
    using char_consistent[OF subfieldE(1)[OF assms(1)]] by simp
  finally show "char (Rupt K f) = char R" by simp
qed

definition gauss_poly where
  "gauss_poly K n = X\<^bsub>K\<^esub> [^]\<^bsub>poly_ring K\<^esub> (n::nat) \<ominus>\<^bsub>poly_ring K\<^esub> X\<^bsub>K\<^esub>"

context field
begin

interpretation polynomial_ring "R" "carrier R"
  unfolding polynomial_ring_def polynomial_ring_axioms_def
  using field_axioms carrier_is_subfield by simp

text \<open>The following lemma can be found in Ireland and Rosen~\cite[\textsection 7.1, Lemma 2]{ireland1982}.\<close>

lemma gauss_poly_div_gauss_poly_iff_1:
  fixes l m :: nat
  assumes "l > 0"
  shows "(X [^]\<^bsub>P\<^esub> l \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>) pdivides (X [^]\<^bsub>P\<^esub> m \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>) \<longleftrightarrow> l dvd m"
    (is "?lhs \<longleftrightarrow> ?rhs")
proof -
  define q where "q = m div l"
  define r where "r = m mod l"
  have m_def: "m = q * l + r" and r_range: "r < l"
    using assms by (auto simp add:q_def r_def)

  have pow_sum_carr:"(\<Oplus>\<^bsub>P\<^esub>i\<in>{..<q}. (X [^]\<^bsub>P\<^esub> l)[^]\<^bsub>P\<^esub> i) \<in> carrier P"
    using var_pow_closed
    by (intro p.finsum_closed, simp)

  have "(X [^]\<^bsub>P\<^esub> (q*l) \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>) = ((X [^]\<^bsub>P\<^esub> l)[^]\<^bsub>P\<^esub> q) \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>"
    using var_closed
    by (subst p.nat_pow_pow, simp_all add:algebra_simps)
  also have "... =
    (X [^]\<^bsub>P\<^esub> l \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>) \<otimes>\<^bsub>P\<^esub> (\<Oplus>\<^bsub>P\<^esub>i\<in>{..<q}. (X [^]\<^bsub>P\<^esub> l) [^]\<^bsub>P\<^esub> i)"
    using var_pow_closed
    by (subst p.geom[symmetric], simp_all)
  finally have pow_sum_fact: "(X [^]\<^bsub>P\<^esub> (q*l) \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>) =
    (X [^]\<^bsub>P\<^esub> l \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>) \<otimes>\<^bsub>P\<^esub> (\<Oplus>\<^bsub>P\<^esub>i\<in>{..<q}. (X\<^bsub>R\<^esub> [^]\<^bsub>P\<^esub> l) [^]\<^bsub>P\<^esub> i)"
    by simp

  have "(X [^]\<^bsub>P\<^esub> l \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>) divides\<^bsub>P\<^esub> (X [^]\<^bsub>P\<^esub> (q*l) \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>)"
    by (rule dividesI[OF pow_sum_carr pow_sum_fact])

  hence c:"(X [^]\<^bsub>P\<^esub> l \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>) divides\<^bsub>P\<^esub> X [^]\<^bsub>P\<^esub> r \<otimes>\<^bsub>P\<^esub> (X [^]\<^bsub>P\<^esub> (q * l) \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>)"
    using var_pow_closed
    by (intro p.divides_prod_l, auto)

  have "(X [^]\<^bsub>P\<^esub> m \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>) = X [^]\<^bsub>P\<^esub> (r + q * l) \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>"
    unfolding m_def using add.commute by metis
  also have "... = (X [^]\<^bsub>P\<^esub> r) \<otimes>\<^bsub>P\<^esub> (X [^]\<^bsub>P\<^esub> (q*l)) \<oplus>\<^bsub>P\<^esub> (\<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>)"
    using var_closed
    by (subst p.nat_pow_mult, auto simp add:a_minus_def)
  also have "... = ((X [^]\<^bsub>P\<^esub> r) \<otimes>\<^bsub>P\<^esub> (X [^]\<^bsub>P\<^esub> (q*l) \<oplus>\<^bsub>P\<^esub> (\<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>))
    \<oplus>\<^bsub>P\<^esub> (X [^]\<^bsub>P\<^esub> r)) \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>"
    using var_pow_closed
    by algebra
  also have "... = (X [^]\<^bsub>P\<^esub> r) \<otimes>\<^bsub>P\<^esub> (X [^]\<^bsub>P\<^esub> (q*l) \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>)
    \<oplus>\<^bsub>P\<^esub> (X [^]\<^bsub>P\<^esub> r) \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>"
    by algebra
  also have "... = (X [^]\<^bsub>P\<^esub> r) \<otimes>\<^bsub>P\<^esub> (X [^]\<^bsub>P\<^esub> (q*l) \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>)
    \<oplus>\<^bsub>P\<^esub> ((X [^]\<^bsub>P\<^esub> r) \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>)"
    unfolding a_minus_def using var_pow_closed
    by (subst p.a_assoc, auto)
  finally have a:"(X [^]\<^bsub>P\<^esub> m \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>) =
    (X [^]\<^bsub>P\<^esub> r) \<otimes>\<^bsub>P\<^esub> (X [^]\<^bsub>P\<^esub> (q*l) \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>) \<oplus>\<^bsub>P\<^esub> (X [^]\<^bsub>P\<^esub> r \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>)"
    (is "_ = ?x")
    by simp

  have xn_m_1_deg': "degree (X [^]\<^bsub>P\<^esub> n \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>) = n"
    if "n > 0" for n :: nat
  proof -
    have "degree (X [^]\<^bsub>P\<^esub> n \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>) = degree (X [^]\<^bsub>P\<^esub> n \<oplus>\<^bsub>P\<^esub> \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>)"
      by (simp add:a_minus_def)
    also have "... = max (degree (X [^]\<^bsub>P\<^esub> n)) (degree (\<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>))"
      using var_pow_closed var_pow_carr var_pow_degree
      using univ_poly_a_inv_degree degree_one that
      by (subst degree_add_distinct, auto)
    also have "... = n"
      using var_pow_degree degree_one univ_poly_a_inv_degree
      by simp
    finally show ?thesis by simp
  qed

  have xn_m_1_deg: "degree (X [^]\<^bsub>P\<^esub> n \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>) = n" for n :: nat
  proof (cases "n > 0")
    case True
    then show ?thesis using xn_m_1_deg' by auto
  next
    case False
    hence "n = 0" by simp
    hence "degree (X [^]\<^bsub>P\<^esub> n \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>) = degree (\<zero>\<^bsub>P\<^esub>)"
      by (intro arg_cong[where f="degree"], simp)
    then show ?thesis using False by (simp add:univ_poly_zero)
  qed

  have b: "degree (X [^]\<^bsub>P\<^esub> l \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>) > degree (X\<^bsub>R\<^esub> [^]\<^bsub>P\<^esub> r \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>)"
    using r_range unfolding xn_m_1_deg by simp

  have xn_m_1_carr: "X [^]\<^bsub>P\<^esub> n \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub> \<in> carrier P" for n :: nat
    unfolding a_minus_def
    by (intro p.a_closed var_pow_closed, simp)

  have "?lhs \<longleftrightarrow> (X [^]\<^bsub>P\<^esub> l \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>) pdivides ?x"
    by (subst a, simp)
  also have "... \<longleftrightarrow> (X [^]\<^bsub>P\<^esub> l \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>) pdivides (X [^]\<^bsub>P\<^esub> r \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>)"
    unfolding pdivides_def
    by (intro p.div_sum_iff c var_pow_closed
        xn_m_1_carr p.a_closed p.m_closed)
  also have "... \<longleftrightarrow> r = 0"
  proof (cases "r = 0")
    case True
    have "(X [^]\<^bsub>P\<^esub> l \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>) pdivides \<zero>\<^bsub>P\<^esub>"
      unfolding univ_poly_zero
      by (intro pdivides_zero xn_m_1_carr)
    also have "... = (X [^]\<^bsub>P\<^esub> r \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>)"
      by (simp add:a_minus_def True) algebra
    finally show ?thesis using True by simp
  next
    case False
    hence "degree (X [^]\<^bsub>P\<^esub> r \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>) > 0" using xn_m_1_deg by simp
    hence "X [^]\<^bsub>P\<^esub> r \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub> \<noteq> []" by auto
    hence "\<not>(X [^]\<^bsub>P\<^esub> l \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>) pdivides (X [^]\<^bsub>P\<^esub> r \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>)"
      using pdivides_imp_degree_le b xn_m_1_carr
      by (metis le_antisym less_or_eq_imp_le nat_neq_iff)
    thus ?thesis using False by simp
  qed
  also have "... \<longleftrightarrow> l dvd m"
    unfolding m_def using r_range assms by auto
  finally show ?thesis
    by simp
qed

lemma gauss_poly_factor:
  assumes "n > 0"
  shows "gauss_poly R n = (X [^]\<^bsub>P\<^esub> (n-1) \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>) \<otimes>\<^bsub>P\<^esub> X" (is "_ = ?rhs")
proof -
  have a:"1 + (n - 1) = n"
    using assms by simp
  have "gauss_poly R n = X [^]\<^bsub>P\<^esub> (1+(n-1)) \<ominus>\<^bsub>P\<^esub> X"
    unfolding gauss_poly_def by (subst a, simp)
  also have "... = (X [^]\<^bsub>P\<^esub> (n-1)) \<otimes>\<^bsub>P\<^esub> X \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub> \<otimes>\<^bsub>P\<^esub> X"
    using var_closed by simp
  also have "... = ?rhs"
    unfolding a_minus_def using var_closed l_one
    by (subst p.l_distr, auto, algebra)
  finally show ?thesis by simp
qed

lemma var_neq_zero: "X \<noteq> \<zero>\<^bsub>P\<^esub>"
  by (simp add:var_def univ_poly_zero)

lemma var_pow_eq_one_iff: "X [^]\<^bsub>P\<^esub> k = \<one>\<^bsub>P\<^esub> \<longleftrightarrow> k = (0::nat)"
proof (cases "k=0")
  case True
  then show ?thesis using var_closed(1) by simp
next
  case False
  have "degree (X\<^bsub>R\<^esub> [^]\<^bsub>P\<^esub> k) = k "
    using var_pow_degree by simp
  also have "... \<noteq> degree (\<one>\<^bsub>P\<^esub>)" using False degree_one by simp
  finally have "degree (X\<^bsub>R\<^esub> [^]\<^bsub>P\<^esub> k) \<noteq> degree \<one>\<^bsub>P\<^esub>" by simp
  then show ?thesis by auto
qed

lemma gauss_poly_carr: "gauss_poly R n \<in> carrier P"
  using var_closed(1)
  unfolding gauss_poly_def by simp

lemma gauss_poly_degree:
  assumes "n > 1"
  shows "degree (gauss_poly R n) = n"
proof -
  have "degree (gauss_poly R n) = max n 1"
    unfolding gauss_poly_def a_minus_def
    using var_pow_carr var_carr degree_var
    using var_pow_degree univ_poly_a_inv_degree
    using assms by (subst degree_add_distinct, auto)
  also have "... = n" using assms by simp
  finally show ?thesis by simp
qed

lemma gauss_poly_not_zero:
  assumes "n > 1"
  shows "gauss_poly R n \<noteq> \<zero>\<^bsub>P\<^esub>"
proof -
  have "degree (gauss_poly R n) \<noteq> degree ( \<zero>\<^bsub>P\<^esub>)"
    using assms by (subst gauss_poly_degree, simp_all add:univ_poly_zero)
  thus ?thesis by auto
qed

lemma gauss_poly_monic:
  assumes "n > 1"
  shows "monic_poly R (gauss_poly R n)"
proof -
  have "monic_poly R (X [^]\<^bsub>P\<^esub> n)"
    by (intro monic_poly_pow monic_poly_var)
  moreover have "\<ominus>\<^bsub>P\<^esub> X \<in> carrier P"
    using var_closed by simp
  moreover have "degree (\<ominus>\<^bsub>P\<^esub> X) < degree (X [^]\<^bsub>P\<^esub> n)"
    using assms univ_poly_a_inv_degree var_closed
    using degree_var
    unfolding var_pow_degree by (simp)
  ultimately show ?thesis
    unfolding gauss_poly_def a_minus_def
    by (intro monic_poly_add_distinct, auto)
qed

lemma geom_nat:
  fixes q :: nat
  fixes x :: "_ :: {comm_ring,monoid_mult}"
  shows "(x-1) * (\<Sum>i \<in> {..<q}. x^i) = x^q-1"
  by (induction q, auto simp:algebra_simps)

text \<open>The following lemma can be found in Ireland and Rosen~\cite[\textsection 7.1, Lemma 3]{ireland1982}.\<close>

lemma gauss_poly_div_gauss_poly_iff_2:
  fixes a :: int
  fixes l m :: nat
  assumes "l > 0" "a > 1"
  shows "(a ^ l - 1) dvd (a ^ m - 1) \<longleftrightarrow> l dvd m"
    (is "?lhs \<longleftrightarrow> ?rhs")
proof -
  define q where "q = m div l"
  define r where "r = m mod l"
  have m_def: "m = q * l + r" and r_range: "r < l" "r \<ge> 0"
    using assms by (auto simp add:q_def r_def)

  have "a ^ (l * q) - 1 = (a ^ l) ^ q - 1"
    by (simp add: power_mult)
  also have "... = (a^l - 1) * (\<Sum>i \<in> {..<q}. (a^l)^i)"
    by (subst geom_nat[symmetric], simp)
  finally have "a ^ (l * q) - 1 = (a^l - 1) * (\<Sum>i \<in> {..<q}. (a^l)^i)"
    by simp
  hence c:"a ^ l - 1 dvd a^ r * (a ^ (q * l) - 1)" by (simp add:mult.commute)

  have "a ^ m - 1 = a ^ (r + q * l) - 1"
    unfolding m_def using add.commute by metis
  also have "... = (a ^ r) * (a ^ (q*l)) -1"
    by (simp add: power_add)
  also have "... = ((a ^ r) * (a ^ (q*l) -1)) + (a ^ r) - 1"
    by (simp add: right_diff_distrib)
  also have "... = (a ^ r) * (a ^ (q*l) - 1) + ((a ^ r) - 1)"
    by simp
  finally have a:
    "a ^ m - 1 = (a ^ r) * (a ^ (q*l) - 1) + ((a ^ r) - 1)"
    (is "_ = ?x")
    by simp

  have "?lhs \<longleftrightarrow> (a^l -1) dvd ?x"
    by (subst a, simp)
  also have "... \<longleftrightarrow> (a^l -1) dvd (a^r -1)"
    using c dvd_add_right_iff by auto
  also have "... \<longleftrightarrow> r = 0"
  proof
    assume "a ^ l - 1 dvd a ^ r - 1"
    hence "a ^ l - 1  \<le> a ^ r -1 \<or> r = 0 "
      using assms r_range zdvd_not_zless by force
    moreover have "a ^ r < a^l" using assms r_range by simp
    ultimately show "r= 0"by simp
  next
    assume "r = 0"
    thus "a ^ l - 1 dvd a ^ r - 1" by simp
  qed
  also have "... \<longleftrightarrow> l dvd m"
    using r_def by auto
  finally show ?thesis by simp
qed

lemma gauss_poly_div_gauss_poly_iff:
  assumes "m > 0" "n > 0" "a > 1"
  shows "gauss_poly R (a^n) pdivides\<^bsub>R\<^esub> gauss_poly R (a^m)
    \<longleftrightarrow> n dvd m" (is "?lhs=?rhs")
proof -
  have a:"a^m > 1" using assms one_less_power by blast
  hence a1: "a^m > 0" by linarith
  have b:"a^n > 1" using assms one_less_power by blast
  hence b1:"a^n > 0" by linarith

  have "?lhs \<longleftrightarrow>
    (X [^]\<^bsub>P\<^esub> (a^n-1) \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>) \<otimes>\<^bsub>P\<^esub> X pdivides
    (X [^]\<^bsub>P\<^esub> (a^m-1) \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>) \<otimes>\<^bsub>P\<^esub> X"
    using  gauss_poly_factor a1 b1 by simp
  also have "... \<longleftrightarrow>
    (X [^]\<^bsub>P\<^esub> (a^n-1) \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>) pdivides
    (X [^]\<^bsub>P\<^esub> (a^m-1) \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>)"
    using var_closed a b var_neq_zero
    by (subst pdivides_mult_r, simp_all add:var_pow_eq_one_iff)
  also have "... \<longleftrightarrow> a^n-1 dvd a^m-1"
    using b
    by (subst gauss_poly_div_gauss_poly_iff_1) simp_all
  also have "... \<longleftrightarrow> int (a^n-1) dvd int (a^m-1)"
    by (subst of_nat_dvd_iff, simp)
  also have "... \<longleftrightarrow> int a^n-1 dvd int a^m-1"
    using a b by (simp add:of_nat_diff)
  also have "... \<longleftrightarrow> n dvd m"
    using assms
    by (subst gauss_poly_div_gauss_poly_iff_2) simp_all
  finally show ?thesis by simp
qed

end

context finite_field
begin

interpretation polynomial_ring "R" "carrier R"
  unfolding polynomial_ring_def polynomial_ring_axioms_def
  using field_axioms carrier_is_subfield by simp

lemma div_gauss_poly_iff:
  assumes "n > 0"
  assumes "monic_irreducible_poly R f"
  shows "f pdivides\<^bsub>R\<^esub> gauss_poly R (order R^n) \<longleftrightarrow> degree f dvd n"
proof -
  have f_carr: "f \<in> carrier P"
    using assms(2) unfolding monic_irreducible_poly_def
    unfolding monic_poly_def by simp
  have f_deg: "degree f > 0"
    using assms(2) monic_poly_min_degree by fastforce

  define K where "K = Rupt\<^bsub>R\<^esub> (carrier R) f"
  have field_K: "field K"
    using assms(2) unfolding K_def monic_irreducible_poly_def
    unfolding monic_poly_def
    by (subst rupture_is_field_iff_pirreducible)  auto
  have a: "order K = order R^degree f"
    using rupture_order[OF carrier_is_subfield] f_carr f_deg
    unfolding K_def order_def by simp
  have char_K: "char K = char R"
    using rupture_char[OF carrier_is_subfield] f_carr f_deg
    unfolding K_def by simp

  have "card (carrier K) > 0"
    using a f_deg finite_field_min_order unfolding order_def by simp
  hence d: "finite (carrier K)" using card_ge_0_finite by auto
  interpret f: finite_field "K"
    using field_K d by (intro finite_fieldI, simp_all)
  interpret fp: polynomial_ring "K" "(carrier K)"
    unfolding polynomial_ring_def polynomial_ring_axioms_def
    using f.field_axioms f.carrier_is_subfield by simp

  define \<phi> where "\<phi> = rupture_surj (carrier R) f"
  interpret h:ring_hom_ring "P" "K" "\<phi>"
    unfolding K_def \<phi>_def using f_carr rupture_surj_hom by simp

  have embed_inj: "inj_on (\<phi> \<circ> poly_of_const) (carrier R)"
    unfolding \<phi>_def
    using embed_inj[OF carrier_is_subfield f_carr f_deg] by simp

  interpret r:ring_hom_ring "R" "P" "poly_of_const"
    using canonical_embedding_ring_hom by simp

  obtain rn where "order R = char K^rn" "rn > 0"
    unfolding char_K using finite_field_order by auto
  hence ord_rn: "order R ^n = char K^(rn * n)" using assms(1)
    by (simp add: power_mult)

  interpret q:ring_hom_cring "K" "K" "\<lambda>x. x [^]\<^bsub>K\<^esub> order R^n"
    using ord_rn
    by (intro f.frobenius_hom f.finite_carr_imp_char_ge_0 d, simp)

  have o1: "order R^degree f > 1"
    using f_deg finite_field_min_order one_less_power
    by blast
  hence o11: "order R^degree f > 0" by linarith
  have o2: "order R^n > 1"
    using assms(1) finite_field_min_order one_less_power
    by blast
  hence o21: "order R^n > 0" by linarith
  let ?g1 = "gauss_poly K (order R^degree f)"
  let ?g2 = "gauss_poly K (order R^n)"

  have g1_monic: "monic_poly K ?g1"
    using f.gauss_poly_monic[OF o1] by simp

  have c:"x [^]\<^bsub>K\<^esub> (order R^degree f) = x" if b:"x \<in> carrier K" for x
    using b d order_pow_eq_self
    unfolding a[symmetric]
    by (intro f.order_pow_eq_self, auto)

  have k_cycle:
    "\<phi> (poly_of_const x) [^]\<^bsub>K\<^esub> (order R^n) = \<phi>(poly_of_const x)"
    if k_cycle_1: "x \<in> carrier R" for x
  proof -
    have "\<phi> (poly_of_const x) [^]\<^bsub>K\<^esub> (order R^n) =
      \<phi> (poly_of_const (x [^]\<^bsub>R\<^esub> (order R^n)))"
      using k_cycle_1 by (simp add: h.hom_nat_pow r.hom_nat_pow)
    also have "... = \<phi> (poly_of_const x)"
      using order_pow_eq_self' k_cycle_1 by simp
    finally show ?thesis by simp
  qed

  have roots_g1: "pmult\<^bsub>K\<^esub> d ?g1 \<ge> 1"
    if roots_g1_assms: "degree d = 1" "monic_irreducible_poly K d" for d
  proof -
    obtain x where x_def: "x \<in> carrier K" "d = [\<one>\<^bsub>K\<^esub>, \<ominus>\<^bsub>K\<^esub> x]"
      using f.degree_one_monic_poly roots_g1_assms by auto
    interpret x:ring_hom_cring "poly_ring K" "K" "(\<lambda>p. f.eval p x)"
      by (intro fp.eval_cring_hom x_def)
    have "ring.eval K ?g1 x = \<zero>\<^bsub>K\<^esub>"
      unfolding gauss_poly_def a_minus_def
      using fp.var_closed f.eval_var x_def c
      by (simp, algebra)
    hence "f.is_root ?g1 x"
      using x_def f.gauss_poly_not_zero[OF o1]
      unfolding f.is_root_def univ_poly_zero by simp
    hence "[\<one>\<^bsub>K\<^esub>, \<ominus>\<^bsub>K\<^esub> x] pdivides\<^bsub>K\<^esub> ?g1"
      using f.is_root_imp_pdivides f.gauss_poly_carr by simp
    hence "d pdivides\<^bsub>K\<^esub> ?g1" by (simp add:x_def)
    thus "pmult\<^bsub>K\<^esub> d ?g1 \<ge> 1"
      using that f.gauss_poly_not_zero f.gauss_poly_carr o1
      by (subst f.multiplicity_ge_1_iff_pdivides, simp_all)
  qed

  show ?thesis
  proof
    assume f:"f pdivides\<^bsub>R\<^esub> gauss_poly R (order R^n)"
    have "(\<phi> X) [^]\<^bsub>K\<^esub> (order R^n) \<ominus>\<^bsub>K\<^esub> (\<phi> X\<^bsub>R\<^esub>) =
      \<phi> (gauss_poly R (order R^n))"
      unfolding gauss_poly_def a_minus_def using var_closed
      by (simp add: h.hom_nat_pow)
    also have "... = \<zero>\<^bsub>K\<^esub>"
      unfolding K_def \<phi>_def using f_carr gauss_poly_carr f
      by (subst rupture_eq_0_iff, simp_all)
    finally have "(\<phi> X\<^bsub>R\<^esub>) [^]\<^bsub>K\<^esub> (order R^n) \<ominus>\<^bsub>K\<^esub> (\<phi> X\<^bsub>R\<^esub>) = \<zero>\<^bsub>K\<^esub>"
      by simp
    hence g:"(\<phi> X) [^]\<^bsub>K\<^esub> (order R^n) = (\<phi> X)"
      using var_closed by simp

    have roots_g2: "pmult\<^bsub>K\<^esub> d ?g2 \<ge> 1"
      if roots_g2_assms: "degree d = 1" "monic_irreducible_poly K d" for d
    proof -
      obtain y where y_def: "y \<in> carrier K" "d = [\<one>\<^bsub>K\<^esub>, \<ominus>\<^bsub>K\<^esub> y]"
        using f.degree_one_monic_poly roots_g2_assms by auto

      interpret x:ring_hom_cring "poly_ring K" "K" "(\<lambda>p. f.eval p y)"
        by (intro fp.eval_cring_hom y_def)
      obtain x where x_def: "x \<in> carrier P" "y = \<phi> x"
        using y_def unfolding \<phi>_def K_def rupture_def
        unfolding FactRing_def A_RCOSETS_def'
        by auto
      let ?\<tau>  = "\<lambda>i. poly_of_const (coeff x i)"
      have test: "?\<tau> i \<in> carrier P" for i
        by (intro r.hom_closed coeff_range x_def)
      have test_2: "coeff x i \<in> carrier R" for i
        by (intro coeff_range x_def)

      have x_coeff_carr: "i \<in> set x \<Longrightarrow> i \<in> carrier R"  for i
        using x_def(1)
        by (auto simp add:univ_poly_carrier[symmetric] polynomial_def)

      have a:"map (\<phi> \<circ> poly_of_const) x \<in> carrier (poly_ring K)"
        using rupture_surj_norm_is_hom[OF f_carr]
        using domain_axioms f.domain_axioms embed_inj
        by (intro carrier_hom'[OF  x_def(1)])
         (simp_all add:\<phi>_def K_def)

      have "(\<phi> x) [^]\<^bsub>K\<^esub> (order R^n) =
        f.eval (map (\<phi> \<circ> poly_of_const) x) (\<phi> X) [^]\<^bsub>K\<^esub> (order R^n)"
        unfolding \<phi>_def K_def
        by (subst rupture_surj_as_eval[OF f_carr x_def(1)], simp)
      also have "... =
        f.eval (map (\<lambda>x. \<phi> (poly_of_const x) [^]\<^bsub>K\<^esub> order R ^ n) x) (\<phi> X)"
        using a h.hom_closed var_closed(1)
        by (subst q.ring.eval_hom[OF f.carrier_is_subring])
          (simp_all add:comp_def g)
      also have "... = f.eval (map (\<lambda>x. \<phi> (poly_of_const x)) x) (\<phi> X)"
        using k_cycle x_coeff_carr
        by (intro arg_cong2[where f="f.eval"] map_cong, simp_all)
      also have "... = (\<phi> x)"
        unfolding \<phi>_def K_def
        by (subst rupture_surj_as_eval[OF f_carr x_def(1)], simp add:comp_def)
      finally have "\<phi> x [^]\<^bsub>K\<^esub> order R ^ n = \<phi> x" by simp

      hence "y [^]\<^bsub>K\<^esub> (order R^n) = y" using x_def by simp
      hence "ring.eval K ?g2 y = \<zero>\<^bsub>K\<^esub>"
        unfolding gauss_poly_def a_minus_def
        using fp.var_closed f.eval_var y_def
        by (simp, algebra)
      hence "f.is_root ?g2 y"
        using y_def f.gauss_poly_not_zero[OF o2]
        unfolding f.is_root_def univ_poly_zero by simp
      hence "d pdivides\<^bsub>K\<^esub> ?g2"
        unfolding y_def
        by (intro f.is_root_imp_pdivides f.gauss_poly_carr, simp)
      thus "pmult\<^bsub>K\<^esub> d ?g2 \<ge> 1"
        using that f.gauss_poly_carr f.gauss_poly_not_zero o2
        by (subst f.multiplicity_ge_1_iff_pdivides, auto)
    qed

    have inv_k_inj: "inj_on (\<lambda>x. \<ominus>\<^bsub>K\<^esub> x) (carrier K)"
      by (intro inj_onI, metis f.minus_minus)
    let ?mip = "monic_irreducible_poly K"

    have "sum' (\<lambda>d. pmult\<^bsub>K\<^esub> d ?g1 * degree d) {d. ?mip d} = degree ?g1"
      using f.gauss_poly_monic o1
      by (subst f.degree_monic_poly', simp_all)
    also have "... = order K"
      using f.gauss_poly_degree o1 a by simp
    also have "... = card ((\<lambda>k. [\<one>\<^bsub>K\<^esub>, \<ominus>\<^bsub>K\<^esub> k]) ` carrier K)"
      unfolding order_def using inj_onD[OF inv_k_inj]
      by (intro card_image[symmetric] inj_onI) (simp_all)
    also have "... = card {d. ?mip d \<and> degree d = 1}"
      using f.degree_one_monic_poly
      by (intro arg_cong[where f="card"], simp add:set_eq_iff image_iff)
    also have "... = sum (\<lambda>d. 1) {d. ?mip d \<and> degree d = 1}"
      by simp
    also have "... = sum' (\<lambda>d. 1) {d. ?mip d \<and> degree d = 1}"
      by (intro sum.eq_sum[symmetric]
          finite_subset[OF _ fp.finite_poly(1)[OF d]])
       (auto simp:monic_irreducible_poly_def monic_poly_def)
    also have "... = sum' (\<lambda>d. of_bool (degree d = 1)) {d. ?mip d}"
      by (intro sum.mono_neutral_cong_left' subsetI, simp_all)
    also have "... \<le> sum' (\<lambda>d. of_bool (degree d = 1)) {d. ?mip d}"
      by simp
    finally have "sum' (\<lambda>d. pmult\<^bsub>K\<^esub> d ?g1 * degree d) {d. ?mip d}
      \<le> sum' (\<lambda>d. of_bool (degree d = 1)) {d. ?mip d}"
      by simp
    moreover have
      "pmult\<^bsub>K\<^esub> d ?g1 * degree d \<ge> of_bool (degree d = 1)"
      if v:"monic_irreducible_poly K d" for d
    proof (cases "degree d = 1")
      case True
      then obtain x where "x \<in> carrier K" "d = [\<one>\<^bsub>K\<^esub>, \<ominus>\<^bsub>K\<^esub> x]"
        using f.degree_one_monic_poly v by auto
      hence "pmult\<^bsub>K\<^esub> d ?g1 \<ge> 1"
        using roots_g1 v by simp
      then show ?thesis using True by simp
    next
      case False
      then show ?thesis by simp
    qed
    moreover have
      "finite {d. ?mip d \<and> pmult\<^bsub>K\<^esub> d ?g1 * degree d > 0}"
      by (intro finite_subset[OF _ f.factor_monic_poly_fin[OF g1_monic]]
          subsetI) simp
    ultimately have v2:
      "\<forall>d \<in> {d. ?mip d}. pmult\<^bsub>K\<^esub> d ?g1 * degree d =
      of_bool (degree d = 1)"
      by (intro sum'_eq_iff, simp_all add:not_le)
    have "pmult\<^bsub>K\<^esub> d ?g1 \<le> pmult\<^bsub>K\<^esub> d ?g2" if "?mip d" for d
    proof (cases "degree d = 1")
      case True
      hence "pmult\<^bsub>K\<^esub> d ?g1 = 1" using v2 that by simp
      also have "... \<le> pmult\<^bsub>K\<^esub> d ?g2"
        by (intro roots_g2 True that)
      finally show ?thesis by simp
    next
      case False
      hence "degree d > 1"
        using f.monic_poly_min_degree[OF that] by simp
      hence "pmult\<^bsub>K\<^esub> d ?g1 = 0" using v2 that by auto
      then show ?thesis by simp
    qed
    hence "?g1 pdivides\<^bsub>K\<^esub> ?g2"
      using o1 o2 f.divides_monic_poly f.gauss_poly_monic by simp
    thus "degree f dvd n"
      by (subst (asm) f.gauss_poly_div_gauss_poly_iff
          [OF assms(1) f_deg finite_field_min_order], simp)
  next
    have d:"\<phi> X\<^bsub>R\<^esub> \<in> carrier K"
      by (intro h.hom_closed var_closed)

    have "\<phi> (gauss_poly R (order R^degree f)) =
      (\<phi> X\<^bsub>R\<^esub>) [^]\<^bsub>K\<^esub> (order R^degree f) \<ominus>\<^bsub>K\<^esub> (\<phi> X\<^bsub>R\<^esub>)"
      unfolding gauss_poly_def a_minus_def using var_closed
      by (simp add: h.hom_nat_pow)
    also have "... = \<zero>\<^bsub>K\<^esub>"
      using c d by simp
    finally have "\<phi> (gauss_poly R (order R^degree f)) = \<zero>\<^bsub>K\<^esub>" by simp
    hence "f pdivides\<^bsub>R\<^esub> gauss_poly R (order R^degree f)"
      unfolding K_def \<phi>_def using f_carr gauss_poly_carr
      by (subst (asm) rupture_eq_0_iff, simp_all)
    moreover assume "degree f dvd n"

    hence "gauss_poly R (order R^degree f) pdivides
      (gauss_poly R (order R^n))"
      using gauss_poly_div_gauss_poly_iff
        [OF assms(1) f_deg finite_field_min_order]
      by simp
    ultimately show "f pdivides\<^bsub>R\<^esub> gauss_poly R (order R^n)"
      using f_carr a p.divides_trans unfolding pdivides_def by blast
  qed
qed

lemma gauss_poly_splitted:
  "splitted (gauss_poly R (order R))"
proof -
  have "degree q \<le> 1" if
    "q \<in> carrier P"
    "pirreducible (carrier R) q"
    "q pdivides gauss_poly R (order R)" for q
  proof -
    have q_carr: "q \<in> carrier (mult_of P)"
      using that unfolding ring_irreducible_def by simp
    moreover have "irreducible (mult_of P) q"
      using that unfolding ring_irreducible_def
      by (intro p.irreducible_imp_irreducible_mult that, simp_all)
    ultimately obtain p where p_def:
      "monic_irreducible_poly R p" "q \<sim>\<^bsub>mult_of P\<^esub> p"
      using monic_poly_span by auto
    have p_carr: "p \<in> carrier P" "p \<noteq> []"
      using p_def(1)
      unfolding monic_irreducible_poly_def monic_poly_def
      by auto
    moreover have "p divides\<^bsub>mult_of P\<^esub> q"
      using associatedE[OF p_def(2)] by auto
    hence "p pdivides q"
      unfolding pdivides_def using divides_mult_imp_divides by simp
    moreover have "q pdivides gauss_poly R (order R^1)"
      using that by simp
    ultimately have "p pdivides gauss_poly R (order R^1)"
      unfolding pdivides_def using p.divides_trans by blast
    hence "degree p dvd 1"
      using  div_gauss_poly_iff[where n="1"] p_def(1) by simp
    hence "degree p = 1" by simp
    moreover have "q divides\<^bsub>mult_of P\<^esub> p"
      using associatedE[OF p_def(2)] by auto
    hence "q pdivides p"
      unfolding pdivides_def using divides_mult_imp_divides by simp
    hence "degree q \<le> degree p"
      using that p_carr
      by (intro pdivides_imp_degree_le) auto
    ultimately show ?thesis by simp
  qed

  thus ?thesis
    using gauss_poly_carr
    by (intro trivial_factors_imp_splitted, auto)
qed

text \<open>The following lemma, for the case when @{term "R"} is a simple prime field, can be found in
Ireland and Rosen~\cite[\textsection 7.1, Theorem 2]{ireland1982}. Here the result is verified even
for arbitrary finite fields.\<close>

lemma multiplicity_of_factor_of_gauss_poly:
  assumes "n > 0"
  assumes "monic_irreducible_poly R f"
  shows
    "pmult\<^bsub>R\<^esub> f (gauss_poly R (order R^n)) = of_bool (degree f dvd n)"
proof (cases "degree f dvd n")
  case True
  let ?g = "gauss_poly R (order R^n)"
  have f_carr: "f \<in> carrier P" "f \<noteq> []"
    using assms(2)
    unfolding monic_irreducible_poly_def monic_poly_def
    by auto

  have o2: "order R^n > 1"
    using finite_field_min_order assms(1) one_less_power by blast
  hence o21: "order R^n > 0" by linarith

  obtain d :: nat where order_dim: "order R = char R ^ d" "d > 0"
    using finite_field_order by blast
  have "d * n > 0" using order_dim assms by simp
  hence char_dvd_order: "int (char R) dvd int (order R ^ n)"
    unfolding order_dim
    using finite_carr_imp_char_ge_0[OF finite_carrier]
    by (simp add:power_mult[symmetric])

  interpret h: ring_hom_ring  "R" "P" "poly_of_const"
    using canonical_embedding_ring_hom by simp

  have "f pdivides\<^bsub>R\<^esub> ?g"
    using True div_gauss_poly_iff[OF assms] by simp
  hence "pmult\<^bsub>R\<^esub> f ?g \<ge> 1"
    using multiplicity_ge_1_iff_pdivides[OF assms(2)]
    using gauss_poly_carr gauss_poly_not_zero[OF o2]
    by auto
  moreover have "pmult\<^bsub>R\<^esub> f ?g < 2"
  proof (rule ccontr)
    assume "\<not> pmult\<^bsub>R\<^esub> f ?g < 2"
    hence "pmult\<^bsub>R\<^esub> f ?g \<ge> 2" by simp
    hence "(f [^]\<^bsub>P\<^esub> (2::nat)) pdivides\<^bsub>R\<^esub> ?g"
      using gauss_poly_carr gauss_poly_not_zero[OF o2]
      by (subst (asm) multiplicity_ge_iff[OF assms(2)]) simp_all
    hence "(f [^]\<^bsub>P\<^esub> (2::nat)) divides\<^bsub>mult_of P\<^esub> ?g"
      unfolding pdivides_def
      using f_carr gauss_poly_not_zero o2 gauss_poly_carr
      by (intro p.divides_imp_divides_mult) simp_all
    then obtain h where h_def:
      "h \<in> carrier (mult_of P)"
      "?g = f [^]\<^bsub>P\<^esub> (2::nat) \<otimes>\<^bsub>P\<^esub> h"
      using dividesD by auto
    have "\<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub> = int_embed P (order R ^ n)
      \<otimes>\<^bsub>P\<^esub> (X\<^bsub>R\<^esub> [^]\<^bsub>P\<^esub> (order R ^ n-1)) \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>"
      using var_closed
      apply (subst int_embed_consistent_with_poly_of_const)
      apply (subst iffD2[OF embed_char_eq_0_iff char_dvd_order])
      by (simp add:a_minus_def)
    also have "... = pderiv\<^bsub>R\<^esub> (X\<^bsub>R\<^esub> [^]\<^bsub>P\<^esub> order R ^ n) \<ominus>\<^bsub>P\<^esub> pderiv\<^bsub>R\<^esub> X\<^bsub>R\<^esub>"
      using pderiv_var
      by (subst pderiv_var_pow[OF o21], simp)
    also have "... = pderiv\<^bsub>R\<^esub> ?g"
      unfolding gauss_poly_def a_minus_def using var_closed
      by (subst pderiv_add, simp_all add:pderiv_inv)
    also have "... = pderiv\<^bsub>R\<^esub> (f [^]\<^bsub>P\<^esub> (2::nat) \<otimes>\<^bsub>P\<^esub> h)"
      using h_def(2) by simp
    also have "... = pderiv\<^bsub>R\<^esub> (f [^]\<^bsub>P\<^esub> (2::nat)) \<otimes>\<^bsub>P\<^esub> h
      \<oplus>\<^bsub>P\<^esub> (f [^]\<^bsub>P\<^esub> (2::nat)) \<otimes>\<^bsub>P\<^esub> pderiv\<^bsub>R\<^esub> h"
      using f_carr h_def
      by (intro pderiv_mult, simp_all)
    also have "... = int_embed P 2 \<otimes>\<^bsub>P\<^esub> f  \<otimes>\<^bsub>P\<^esub> pderiv\<^bsub>R\<^esub> f \<otimes>\<^bsub>P\<^esub> h
      \<oplus>\<^bsub>P\<^esub> f \<otimes>\<^bsub>P\<^esub> f \<otimes>\<^bsub>P\<^esub> pderiv\<^bsub>R\<^esub> h"
      using f_carr
      by (subst pderiv_pow, simp_all add:numeral_eq_Suc)
    also have "... = f \<otimes>\<^bsub>P\<^esub> (int_embed P 2 \<otimes>\<^bsub>P\<^esub> pderiv\<^bsub>R\<^esub> f \<otimes>\<^bsub>P\<^esub> h)
      \<oplus>\<^bsub>P\<^esub> f \<otimes>\<^bsub>P\<^esub> (f \<otimes>\<^bsub>P\<^esub> pderiv\<^bsub>R\<^esub> h)"
      using f_carr pderiv_carr h_def p.int_embed_closed
      apply (intro arg_cong2[where f="(\<oplus>\<^bsub>P\<^esub>)"])
      by (subst p.m_comm, simp_all add:p.m_assoc)
    also have "... = f \<otimes>\<^bsub>P\<^esub>
      (int_embed P 2 \<otimes>\<^bsub>P\<^esub> pderiv\<^bsub>R\<^esub> f \<otimes>\<^bsub>P\<^esub> h \<oplus>\<^bsub>P\<^esub> f \<otimes>\<^bsub>P\<^esub> pderiv\<^bsub>R\<^esub> h)"
      using f_carr pderiv_carr h_def p.int_embed_closed
      by (subst p.r_distr, simp_all)
    finally have "\<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub> = f \<otimes>\<^bsub>P\<^esub>
      (int_embed P 2 \<otimes>\<^bsub>P\<^esub> pderiv\<^bsub>R\<^esub> f \<otimes>\<^bsub>P\<^esub> h \<oplus>\<^bsub>P\<^esub> f \<otimes>\<^bsub>P\<^esub> pderiv\<^bsub>R\<^esub> h)"
      (is "_ = f \<otimes>\<^bsub>P\<^esub> ?q")
      by simp

    hence "f pdivides\<^bsub>R\<^esub> \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>"
      unfolding factor_def pdivides_def
      using f_carr pderiv_carr h_def p.int_embed_closed
      by auto
    moreover have "\<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub> \<noteq> \<zero>\<^bsub>P\<^esub>" by simp
    ultimately have  "degree f \<le> degree (\<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>)"
      using f_carr
      by (intro pdivides_imp_degree_le, simp_all add:univ_poly_zero)
    also have "... = 0"
      by (subst univ_poly_a_inv_degree, simp)
       (simp add:univ_poly_one)
    finally have "degree f = 0" by simp

    then show "False"
      using pirreducible_degree assms(2)
      unfolding monic_irreducible_poly_def monic_poly_def
      by fastforce
  qed
  ultimately have "pmult\<^bsub>R\<^esub> f ?g = 1" by simp
  then show ?thesis using True by simp
next
  case False
  have o2: "order R^n > 1"
    using finite_field_min_order assms(1) one_less_power by blast

  have "\<not>(f pdivides\<^bsub>R\<^esub> gauss_poly R (order R^n))"
    using div_gauss_poly_iff[OF assms] False by simp
  hence "pmult\<^bsub>R\<^esub> f (gauss_poly R (order R^n)) = 0"
    using multiplicity_ge_1_iff_pdivides[OF assms(2)]
    using gauss_poly_carr gauss_poly_not_zero[OF o2] leI less_one
    by blast
  then show ?thesis using False by simp
qed

text \<open>The following lemma, for the case when @{term "R"} is a simple prime field, can be found in Ireland
and Rosen~\cite[\textsection 7.1, Corollary 1]{ireland1982}. Here the result is verified even for
arbitrary finite fields.\<close>

lemma card_irred_aux:
  assumes "n > 0"
  shows "order R^n = (\<Sum>d | d dvd n. d *
    card {f. monic_irreducible_poly R f \<and> degree f = d})"
  (is "?lhs = ?rhs")
proof -
  let ?G = "{f. monic_irreducible_poly R f \<and> degree f dvd n}"

  let ?D = "{f. monic_irreducible_poly R f}"
  have a: "finite {d. d dvd n}" using finite_divisors_nat assms by simp
  have b: "finite {f. monic_irreducible_poly R f \<and> degree f = k}" for k
  proof -
    have "{f. monic_irreducible_poly R f \<and> degree f = k} \<subseteq>
      {f. f \<in> carrier P \<and> degree f \<le> k}"
      unfolding monic_irreducible_poly_def monic_poly_def by auto
    moreover have "finite {f. f \<in> carrier P \<and> degree f \<le> k}"
      using finite_poly[OF finite_carrier] by simp
    ultimately show ?thesis using finite_subset by simp
  qed

  have G_split: "?G =
    \<Union> {{f.  monic_irreducible_poly R f \<and> degree f = d} | d. d dvd n}"
    by auto
  have c: "finite ?G"
    using a b by (subst G_split, auto)
  have d: "order R^n > 1"
    using assms finite_field_min_order one_less_power by blast

  have "?lhs = degree (gauss_poly R (order R^n))"
    using d
    by (subst gauss_poly_degree, simp_all)
  also have "... =
    sum' (\<lambda>d. pmult\<^bsub>R\<^esub> d (gauss_poly R (order R^n)) * degree d) ?D"
    using d
    by (intro degree_monic_poly'[symmetric] gauss_poly_monic)
  also have "... = sum' (\<lambda>d. of_bool (degree d dvd n) * degree d) ?D"
    using multiplicity_of_factor_of_gauss_poly[OF assms]
    by (intro sum.cong', auto)
  also have "... = sum' (\<lambda>d. degree d) ?G"
    by (intro sum.mono_neutral_cong_right' subsetI, auto)
  also have "... = (\<Sum> d \<in> ?G. degree d)"
    using c by (intro sum.eq_sum, simp)
  also have "... =
    (\<Sum> f \<in> (\<Union> d \<in> {d. d dvd n}.
    {f. monic_irreducible_poly R f \<and> degree f = d}). degree f)"
    by (intro sum.cong, auto simp add:set_eq_iff)
  also have "... = (\<Sum>d | d dvd n. sum degree
    {f. monic_irreducible_poly R f \<and> degree f = d})"
    using a b by (subst sum.UNION_disjoint, auto simp add:set_eq_iff)
  also have "... = (\<Sum>d | d dvd n. sum (\<lambda>_. d)
    {f. monic_irreducible_poly R f \<and> degree f = d})"
    by (intro sum.cong, simp_all)
  also have "... = ?rhs"
    by (simp add:mult.commute)
  finally show ?thesis
    by simp
qed

end

end


(*  Title:      HOL/HOLCF/Fix.thy
    Author:     Franz Regensburger
    Author:     Brian Huffman
*)

section \<open>Fixed point operator and admissibility\<close>

theory Fix
  imports Cfun
begin

default_sort pcpo

subsection \<open>Iteration\<close>

primrec iterate :: "nat \<Rightarrow> ('a::cpo \<rightarrow> 'a) \<rightarrow> ('a \<rightarrow> 'a)"
  where
    "iterate 0 = (\<Lambda> F x. x)"
  | "iterate (Suc n) = (\<Lambda> F x. F\<cdot>(iterate n\<cdot>F\<cdot>x))"

text \<open>Derive inductive properties of iterate from primitive recursion\<close>

lemma iterate_0 [simp]: "iterate 0\<cdot>F\<cdot>x = x"
  by simp

lemma iterate_Suc [simp]: "iterate (Suc n)\<cdot>F\<cdot>x = F\<cdot>(iterate n\<cdot>F\<cdot>x)"
  by simp

declare iterate.simps [simp del]

lemma iterate_Suc2: "iterate (Suc n)\<cdot>F\<cdot>x = iterate n\<cdot>F\<cdot>(F\<cdot>x)"
  by (induct n) simp_all

lemma iterate_iterate: "iterate m\<cdot>F\<cdot>(iterate n\<cdot>F\<cdot>x) = iterate (m + n)\<cdot>F\<cdot>x"
  by (induct m) simp_all

text \<open>The sequence of function iterations is a chain.\<close>

lemma chain_iterate [simp]: "chain (\<lambda>i. iterate i\<cdot>F\<cdot>\<bottom>)"
  by (rule chainI, unfold iterate_Suc2, rule monofun_cfun_arg, rule minimal)

subsection \<open>Least fixed point operator\<close>

definition "fix" :: "('a \<rightarrow> 'a) \<rightarrow> 'a"
  where "fix = (\<Lambda> F. \<Squnion>i. iterate i\<cdot>F\<cdot>\<bottom>)"

text \<open>Binder syntax for \<^term>\<open>fix\<close>\<close>

abbreviation fix_syn :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a"  (binder "\<mu> " 10)
  where "fix_syn (\<lambda>x. f x) \<equiv> fix\<cdot>(\<Lambda> x. f x)"

notation (ASCII)
  fix_syn  (binder "FIX " 10)

text \<open>Properties of \<^term>\<open>fix\<close>\<close>

text \<open>direct connection between \<^term>\<open>fix\<close> and iteration\<close>

lemma fix_def2: "fix\<cdot>F = (\<Squnion>i. iterate i\<cdot>F\<cdot>\<bottom>)"
  by (simp add: fix_def)

lemma iterate_below_fix: "iterate n\<cdot>f\<cdot>\<bottom> \<sqsubseteq> fix\<cdot>f"
  unfolding fix_def2
  using chain_iterate by (rule is_ub_thelub)

text \<open>
  Kleene's fixed point theorems for continuous functions in pointed
  omega cpo's
\<close>

lemma fix_eq: "fix\<cdot>F = F\<cdot>(fix\<cdot>F)"
  apply (simp add: fix_def2)
  apply (subst lub_range_shift [of _ 1, symmetric])
   apply (rule chain_iterate)
  apply (subst contlub_cfun_arg)
   apply (rule chain_iterate)
  apply simp
  done

lemma fix_least_below: "F\<cdot>x \<sqsubseteq> x \<Longrightarrow> fix\<cdot>F \<sqsubseteq> x"
  apply (simp add: fix_def2)
  apply (rule lub_below)
   apply (rule chain_iterate)
  apply (induct_tac i)
   apply simp
  apply simp
  apply (erule rev_below_trans)
  apply (erule monofun_cfun_arg)
  done

lemma fix_least: "F\<cdot>x = x \<Longrightarrow> fix\<cdot>F \<sqsubseteq> x"
  by (rule fix_least_below) simp

lemma fix_eqI:
  assumes fixed: "F\<cdot>x = x"
    and least: "\<And>z. F\<cdot>z = z \<Longrightarrow> x \<sqsubseteq> z"
  shows "fix\<cdot>F = x"
  apply (rule below_antisym)
   apply (rule fix_least [OF fixed])
  apply (rule least [OF fix_eq [symmetric]])
  done

lemma fix_eq2: "f \<equiv> fix\<cdot>F \<Longrightarrow> f = F\<cdot>f"
  by (simp add: fix_eq [symmetric])

lemma fix_eq3: "f \<equiv> fix\<cdot>F \<Longrightarrow> f\<cdot>x = F\<cdot>f\<cdot>x"
  by (erule fix_eq2 [THEN cfun_fun_cong])

lemma fix_eq4: "f = fix\<cdot>F \<Longrightarrow> f = F\<cdot>f"
  by (erule ssubst) (rule fix_eq)

lemma fix_eq5: "f = fix\<cdot>F \<Longrightarrow> f\<cdot>x = F\<cdot>f\<cdot>x"
  by (erule fix_eq4 [THEN cfun_fun_cong])

text \<open>strictness of \<^term>\<open>fix\<close>\<close>

lemma fix_bottom_iff: "fix\<cdot>F = \<bottom> \<longleftrightarrow> F\<cdot>\<bottom> = \<bottom>"
  apply (rule iffI)
   apply (erule subst)
   apply (rule fix_eq [symmetric])
  apply (erule fix_least [THEN bottomI])
  done

lemma fix_strict: "F\<cdot>\<bottom> = \<bottom> \<Longrightarrow> fix\<cdot>F = \<bottom>"
  by (simp add: fix_bottom_iff)

lemma fix_defined: "F\<cdot>\<bottom> \<noteq> \<bottom> \<Longrightarrow> fix\<cdot>F \<noteq> \<bottom>"
  by (simp add: fix_bottom_iff)

text \<open>\<^term>\<open>fix\<close> applied to identity and constant functions\<close>

lemma fix_id: "(\<mu> x. x) = \<bottom>"
  by (simp add: fix_strict)

lemma fix_const: "(\<mu> x. c) = c"
  by (subst fix_eq) simp

subsection \<open>Fixed point induction\<close>

lemma fix_ind: "adm P \<Longrightarrow> P \<bottom> \<Longrightarrow> (\<And>x. P x \<Longrightarrow> P (F\<cdot>x)) \<Longrightarrow> P (fix\<cdot>F)"
  unfolding fix_def2
  apply (erule admD)
   apply (rule chain_iterate)
  apply (rule nat_induct, simp_all)
  done

lemma cont_fix_ind: "cont F \<Longrightarrow> adm P \<Longrightarrow> P \<bottom> \<Longrightarrow> (\<And>x. P x \<Longrightarrow> P (F x)) \<Longrightarrow> P (fix\<cdot>(Abs_cfun F))"
  by (simp add: fix_ind)

lemma def_fix_ind: "\<lbrakk>f \<equiv> fix\<cdot>F; adm P; P \<bottom>; \<And>x. P x \<Longrightarrow> P (F\<cdot>x)\<rbrakk> \<Longrightarrow> P f"
  by (simp add: fix_ind)

lemma fix_ind2:
  assumes adm: "adm P"
  assumes 0: "P \<bottom>" and 1: "P (F\<cdot>\<bottom>)"
  assumes step: "\<And>x. \<lbrakk>P x; P (F\<cdot>x)\<rbrakk> \<Longrightarrow> P (F\<cdot>(F\<cdot>x))"
  shows "P (fix\<cdot>F)"
  unfolding fix_def2
  apply (rule admD [OF adm chain_iterate])
  apply (rule nat_less_induct)
  apply (case_tac n)
   apply (simp add: 0)
  apply (case_tac nat)
   apply (simp add: 1)
  apply (frule_tac x=nat in spec)
  apply (simp add: step)
  done

lemma parallel_fix_ind:
  assumes adm: "adm (\<lambda>x. P (fst x) (snd x))"
  assumes base: "P \<bottom> \<bottom>"
  assumes step: "\<And>x y. P x y \<Longrightarrow> P (F\<cdot>x) (G\<cdot>y)"
  shows "P (fix\<cdot>F) (fix\<cdot>G)"
proof -
  from adm have adm': "adm (case_prod P)"
    unfolding split_def .
  have "P (iterate i\<cdot>F\<cdot>\<bottom>) (iterate i\<cdot>G\<cdot>\<bottom>)" for i
    by (induct i) (simp add: base, simp add: step)
  then have "\<And>i. case_prod P (iterate i\<cdot>F\<cdot>\<bottom>, iterate i\<cdot>G\<cdot>\<bottom>)"
    by simp
  then have "case_prod P (\<Squnion>i. (iterate i\<cdot>F\<cdot>\<bottom>, iterate i\<cdot>G\<cdot>\<bottom>))"
    by - (rule admD [OF adm'], simp, assumption)
  then have "case_prod P (\<Squnion>i. iterate i\<cdot>F\<cdot>\<bottom>, \<Squnion>i. iterate i\<cdot>G\<cdot>\<bottom>)"
    by (simp add: lub_Pair)
  then have "P (\<Squnion>i. iterate i\<cdot>F\<cdot>\<bottom>) (\<Squnion>i. iterate i\<cdot>G\<cdot>\<bottom>)"
    by simp
  then show "P (fix\<cdot>F) (fix\<cdot>G)"
    by (simp add: fix_def2)
qed

lemma cont_parallel_fix_ind:
  assumes "cont F" and "cont G"
  assumes "adm (\<lambda>x. P (fst x) (snd x))"
  assumes "P \<bottom> \<bottom>"
  assumes "\<And>x y. P x y \<Longrightarrow> P (F x) (G y)"
  shows "P (fix\<cdot>(Abs_cfun F)) (fix\<cdot>(Abs_cfun G))"
  by (rule parallel_fix_ind) (simp_all add: assms)

subsection \<open>Fixed-points on product types\<close>

text \<open>
  Bekic's Theorem: Simultaneous fixed points over pairs
  can be written in terms of separate fixed points.
\<close>

lemma fix_cprod:
  "fix\<cdot>(F::'a \<times> 'b \<rightarrow> 'a \<times> 'b) =
   (\<mu> x. fst (F\<cdot>(x, \<mu> y. snd (F\<cdot>(x, y)))),
    \<mu> y. snd (F\<cdot>(\<mu> x. fst (F\<cdot>(x, \<mu> y. snd (F\<cdot>(x, y)))), y)))"
  (is "fix\<cdot>F = (?x, ?y)")
proof (rule fix_eqI)
  have *: "fst (F\<cdot>(?x, ?y)) = ?x"
    by (rule trans [symmetric, OF fix_eq], simp)
  have "snd (F\<cdot>(?x, ?y)) = ?y"
    by (rule trans [symmetric, OF fix_eq], simp)
  with * show "F\<cdot>(?x, ?y) = (?x, ?y)"
    by (simp add: prod_eq_iff)
next
  fix z
  assume F_z: "F\<cdot>z = z"
  obtain x y where z: "z = (x, y)" by (rule prod.exhaust)
  from F_z z have F_x: "fst (F\<cdot>(x, y)) = x" by simp
  from F_z z have F_y: "snd (F\<cdot>(x, y)) = y" by simp
  let ?y1 = "\<mu> y. snd (F\<cdot>(x, y))"
  have "?y1 \<sqsubseteq> y"
    by (rule fix_least) (simp add: F_y)
  then have "fst (F\<cdot>(x, ?y1)) \<sqsubseteq> fst (F\<cdot>(x, y))"
    by (simp add: fst_monofun monofun_cfun)
  with F_x have "fst (F\<cdot>(x, ?y1)) \<sqsubseteq> x"
    by simp
  then have *: "?x \<sqsubseteq> x"
    by (simp add: fix_least_below)
  then have "snd (F\<cdot>(?x, y)) \<sqsubseteq> snd (F\<cdot>(x, y))"
    by (simp add: snd_monofun monofun_cfun)
  with F_y have "snd (F\<cdot>(?x, y)) \<sqsubseteq> y"
    by simp
  then have "?y \<sqsubseteq> y"
    by (simp add: fix_least_below)
  with z * show "(?x, ?y) \<sqsubseteq> z"
    by simp
qed

end