(*  Title:       Miscellaneous results
    Author:      Tim Makarios <tjm1983 at gmail.com>, 2012
    Maintainer:  Tim Makarios <tjm1983 at gmail.com>
*)

(*Some of these theorems were moved to the Isabelle repository *)

section "Miscellaneous results"

theory Miscellany
imports Metric
begin

lemma unordered_pair_element_equality:
  assumes "{p, q} = {r, s}" and "p = r"
  shows "q = s"
  using assms by (auto simp: doubleton_eq_iff)

lemma unordered_pair_equality: "{p, q} = {q, p}"
  by auto

lemma cosine_rule:
  fixes a b c :: "real ^ ('n::finite)"
  shows "(norm_dist a c)\<^sup>2 =
  (norm_dist a b)\<^sup>2 + (norm_dist b c)\<^sup>2 + 2 * ((a - b) \<bullet> (b - c))"
proof -
  have "(a - b) + (b - c) = a - c" by simp
  with dot_norm [of "a - b" "b - c"]
    have "(a - b) \<bullet> (b - c) =
        ((norm (a - c))\<^sup>2 - (norm (a - b))\<^sup>2 - (norm (b - c))\<^sup>2) / 2"
      by simp
  thus ?thesis by simp
qed

lemma scalar_equiv: "r *s x = r *\<^sub>R x"
  by vector

lemma norm_dist_dot: "(norm_dist x y)\<^sup>2 = (x - y) \<bullet> (x - y)"
  by (simp add: power2_norm_eq_inner)

definition dep2 :: "'a::real_vector \<Rightarrow> 'a \<Rightarrow> bool" where
  "dep2 u v \<equiv> \<exists>w r s. u = r *\<^sub>R w \<and> v = s *\<^sub>R w"

lemma real2_eq:
  fixes u v :: "real^2"
  assumes "u$1 = v$1" and "u$2 = v$2"
  shows "u = v"
  by (simp add: vec_eq_iff [of u v] forall_2 assms)

definition rotate2 :: "real^2 \<Rightarrow> real^2" where
  "rotate2 x \<equiv> vector [-x$2, x$1]"

declare vector_2 [simp]

lemma rotate2 [simp]:
  "(rotate2 x)$1 = -x$2"
  "(rotate2 x)$2 = x$1"
  by (simp add: rotate2_def)+

lemma rotate2_rotate2 [simp]: "rotate2 (rotate2 x) = -x"
proof -
  have "(rotate2 (rotate2 x))$1 = -x$1" and "(rotate2 (rotate2 x))$2 = -x$2"
    by simp+
  with real2_eq show "rotate2 (rotate2 x) = -x" by simp
qed

lemma rotate2_dot [simp]: "(rotate2 u) \<bullet> (rotate2 v) = u \<bullet> v"
  unfolding inner_vec_def
  by (simp add: sum_2)

lemma rotate2_scaleR [simp]: "rotate2 (k *\<^sub>R x) = k *\<^sub>R (rotate2 x)"
proof -
  have "(rotate2 (k *\<^sub>R x))$1 = (k *\<^sub>R (rotate2 x))$1" and
    "(rotate2 (k *\<^sub>R x))$2 = (k *\<^sub>R (rotate2 x))$2" by simp+
  with real2_eq show ?thesis by simp
qed

lemma rotate2_uminus [simp]: "rotate2 (-x) = -(rotate2 x)"
proof -
  from scaleR_minus_left [of 1] have
    "-1 *\<^sub>R x = -x" and "-1 *\<^sub>R (rotate2 x) = -(rotate2 x)" by auto
  with rotate2_scaleR [of "-1" x] show ?thesis by simp
qed

lemma rotate2_eq [iff]: "rotate2 x = rotate2 y \<longleftrightarrow> x = y"
proof
  assume "x = y"
  thus "rotate2 x = rotate2 y" by simp
next
  assume "rotate2 x = rotate2 y"
  hence "rotate2 (rotate2 x) = rotate2 (rotate2 y)" by simp
  hence "-(-x) = -(-y)" by simp
  thus "x = y" by simp
qed

lemma dot2_rearrange_1:
  fixes u x :: "real^2"
  assumes "u \<bullet> x = 0" and "x$1 \<noteq> 0"
  shows "u = (u$2 / x$1) *\<^sub>R (rotate2 x)" (is "u = ?u'")
proof -
  from \<open>u \<bullet> x = 0\<close> have "u$1 * x$1 = -(u$2) * (x$2)"
    unfolding inner_vec_def
    by (simp add: sum_2)
  hence "u$1 * x$1 / x$1 = -u$2 / x$1 * x$2" by simp
  with \<open>x$1 \<noteq> 0\<close> have "u$1 = ?u'$1" by simp
  from \<open>x$1 \<noteq> 0\<close> have "u$2 = ?u'$2" by simp
  with \<open>u$1 = ?u'$1\<close> and real2_eq show "u = ?u'" by simp
qed

lemma dot2_rearrange_2:
  fixes u x :: "real^2"
  assumes "u \<bullet> x = 0" and "x$2 \<noteq> 0"
  shows "u = -(u$1 / x$2) *\<^sub>R (rotate2 x)" (is "u = ?u'")
proof -
  from assms and dot2_rearrange_1 [of "rotate2 u" "rotate2 x"] have
    "rotate2 u = rotate2 ?u'" by simp
  thus "u = ?u'" by blast
qed

lemma dot2_rearrange:
  fixes u x :: "real^2"
  assumes "u \<bullet> x = 0" and "x \<noteq> 0"
  shows "\<exists>k. u = k *\<^sub>R (rotate2 x)"
proof cases
  assume "x$1 = 0"
  with real2_eq [of x 0] and \<open>x \<noteq> 0\<close> have "x$2 \<noteq> 0" by auto
  with dot2_rearrange_2 and \<open>u \<bullet> x = 0\<close> show ?thesis by blast
next
  assume "x$1 \<noteq> 0"
  with dot2_rearrange_1 and \<open>u \<bullet> x = 0\<close> show ?thesis by blast
qed

lemma dot_left_diff_distrib:
  fixes u v x :: "real^'n"
  shows "(u - v) \<bullet> x = (u \<bullet> x) - (v \<bullet> x)"
proof -
  have "(u \<bullet> x) - (v \<bullet> x) = (\<Sum>i\<in>UNIV. u$i * x$i) - (\<Sum>i\<in>UNIV. v$i * x$i)"
    unfolding inner_vec_def
    by simp
  also from sum_subtractf [of "\<lambda> i. u$i * x$i" "\<lambda> i. v$i * x$i"] have
    "\<dots> = (\<Sum>i\<in>UNIV. u$i * x$i - v$i * x$i)" by simp
  also from left_diff_distrib [where 'a = real] have
    "\<dots> = (\<Sum>i\<in>UNIV. (u$i - v$i) * x$i)" by simp
  also have
    "\<dots> = (u - v) \<bullet> x"
    unfolding inner_vec_def
    by simp
  finally show ?thesis ..
qed

lemma dot_right_diff_distrib:
  fixes u v x :: "real^'n"
  shows "x \<bullet> (u - v) = (x \<bullet> u) - (x \<bullet> v)"
proof -
  from inner_commute have "x \<bullet> (u - v) = (u - v) \<bullet> x" by auto
  also from dot_left_diff_distrib [of u v x] have
    "\<dots> = u \<bullet> x - v \<bullet> x" .
  also from inner_commute [of x] have
    "\<dots> = x \<bullet> u - x \<bullet> v" by simp
  finally show ?thesis .
qed

lemma am_gm2:
  fixes a b :: real
  assumes "a \<ge> 0" and "b \<ge> 0"
  shows "sqrt (a * b) \<le> (a + b) / 2"
  and "sqrt (a * b) = (a + b) / 2 \<longleftrightarrow> a = b"
proof -
  have "0 \<le> (a - b) * (a - b)" and "0 = (a - b) * (a - b) \<longleftrightarrow> a = b" by simp+
  with right_diff_distrib [of "a - b" a b] and left_diff_distrib [of a b] have
    "0 \<le> a * a - 2 * a * b + b * b"
    and "0 = a * a - 2 * a * b + b * b \<longleftrightarrow> a = b" by auto
  hence "4 * a * b \<le> a * a + 2 * a * b + b * b"
    and "4 * a * b = a * a + 2 * a * b + b * b \<longleftrightarrow> a = b" by auto
  with distrib_right [of "a + b" a b] and distrib_left [of a b] have
    "4 * a * b \<le> (a + b) * (a + b)"
    and "4 * a * b = (a + b) * (a + b) \<longleftrightarrow> a = b" by (simp add: field_simps)+
  with real_sqrt_le_mono [of "4 * a * b" "(a + b) * (a + b)"]
    and real_sqrt_eq_iff [of "4 * a * b" "(a + b) * (a + b)"] have
    "sqrt (4 * a * b) \<le> sqrt ((a + b) * (a + b))"
    and "sqrt (4 * a * b) = sqrt ((a + b) * (a + b)) \<longleftrightarrow> a = b" by simp+
  with \<open>a \<ge> 0\<close> and \<open>b \<ge> 0\<close> have "sqrt (4 * a * b) \<le> a + b"
    and "sqrt (4 * a * b) = a + b \<longleftrightarrow> a = b" by simp+
  with real_sqrt_abs2 [of 2] and real_sqrt_mult [of 4 "a * b"] show
    "sqrt (a * b) \<le> (a + b) / 2"
    and "sqrt (a * b) = (a + b) / 2 \<longleftrightarrow> a = b" by (simp add: ac_simps)+
qed

lemma refl_on_allrel: "refl_on A (A \<times> A)"
  unfolding refl_on_def
  by simp

lemma refl_on_restrict:
  assumes "refl_on A r"
  shows "refl_on (A \<inter> B) (r \<inter> B \<times> B)"
proof -
  from \<open>refl_on A r\<close> and refl_on_allrel [of B] and refl_on_Int
  show ?thesis by auto
qed

lemma sym_allrel: "sym (A \<times> A)"
  unfolding sym_def
  by simp

lemma sym_restrict:
  assumes "sym r"
  shows "sym (r \<inter> A \<times> A)"
proof -
  from \<open>sym r\<close> and sym_allrel and sym_Int
  show ?thesis by auto
qed

lemma trans_allrel: "trans (A \<times> A)"
  unfolding trans_def
  by simp

lemma equiv_Int:
  assumes "equiv A r" and "equiv B s"
  shows "equiv (A \<inter> B) (r \<inter> s)"
proof -
  from assms and refl_on_Int [of A r B s] and sym_Int and trans_Int
  show ?thesis
    unfolding equiv_def
    by auto
qed

lemma equiv_allrel: "equiv A (A \<times> A)"
  unfolding equiv_def
  by (simp add: refl_on_allrel sym_allrel trans_allrel)

lemma equiv_restrict:
  assumes "equiv A r"
  shows "equiv (A \<inter> B) (r \<inter> B \<times> B)"
proof -
  from \<open>equiv A r\<close> and equiv_allrel [of B] and equiv_Int
  show ?thesis by auto
qed

lemma invertible_times_eq_zero:
  fixes x :: "real^'n" and A :: "real^'n^'n"
  assumes "invertible A" and "A *v x = 0"
  shows "x = 0"
  using assms invertible_def matrix_left_invertible_ker by blast

lemma times_invertible_eq_zero:
  fixes x :: "real^'n" and A :: "real^'n^'n"
  assumes "invertible A" and "x v* A = 0"
  shows "x = 0"
  using transpose_invertible assms invertible_times_eq_zero by fastforce

lemma matrix_id_invertible:
  "invertible (mat 1 :: ('a::semiring_1)^'n^'n)"
  by (simp add: invertible_def)

lemma Image_refl_on_nonempty:
  assumes "refl_on A r" and "x \<in> A"
  shows "x \<in> r``{x}"
proof
  from \<open>refl_on A r\<close> and \<open>x \<in> A\<close> show "(x, x) \<in> r"
    unfolding refl_on_def
    by simp
qed

lemma quotient_element_nonempty:
  assumes "equiv A r" and "X \<in> A//r"
  shows "\<exists> x. x \<in> X"
  using assms in_quotient_imp_non_empty by fastforce

lemma zero_3: "(3::3) = 0"
  by simp

lemma card_suc_ge_insert:
  fixes A and x
  shows "card A + 1 \<ge> card (insert x A)"
  using card_insert_le_m1 by fastforce

lemma card_le_UNIV:
  fixes A :: "('n::finite) set"
  shows "card A \<le> CARD('n)"
  by (simp add: card_mono)

lemma partition_Image_element:
  assumes "equiv A r" and "X \<in> A//r" and "x \<in> X"
  shows "r``{x} = X"
  by (metis Image_singleton_iff assms equiv_class_eq_iff quotientE)

lemma card_insert_ge: "card (insert x A) \<ge> card A"
  by (metis card_infinite card_insert_le zero_le)

lemma choose_1:
  assumes "card S = 1"
  shows "\<exists> x. S = {x}"
  using \<open>card S = 1\<close> and card_eq_SucD [of S 0]
  by simp

lemma choose_2:
  assumes "card S = 2"
  shows "\<exists> x y. S = {x,y}"
proof -
  from \<open>card S = 2\<close> and card_eq_SucD [of S 1]
  obtain x and T where "S = insert x T" and "card T = 1" by auto
  from \<open>card T = 1\<close> and choose_1 obtain y where "T = {y}" by auto
  with \<open>S = insert x T\<close> have "S = {x,y}" by simp
  thus "\<exists> x y. S = {x,y}" by auto
qed

lemma choose_3:
  assumes "card S = 3"
  shows "\<exists> x y z. S = {x,y,z}"
proof -
  from \<open>card S = 3\<close> and card_eq_SucD [of S 2]
  obtain x and T where "S = insert x T" and "card T = 2" by auto
  from \<open>card T = 2\<close> and choose_2 [of T] obtain y and z where "T = {y,z}" by auto
  with \<open>S = insert x T\<close> have "S = {x,y,z}" by simp
  thus "\<exists> x y z. S = {x,y,z}" by auto
qed

lemma card_gt_0_diff_singleton:
  assumes "card S > 0" and "x \<in> S"
  shows "card (S - {x}) = card S - 1"
proof -
  from \<open>card S > 0\<close> have "finite S" by (rule card_ge_0_finite)
  with \<open>x \<in> S\<close>
  show "card (S - {x}) = card S - 1" by (simp add: card_Diff_singleton)
qed

lemma eq_3_or_of_3:
  fixes j :: 4
  shows "j = 3 \<or> (\<exists> j'::3. j = of_int (Rep_bit1 j'))"
proof (induct j)
  fix j_int :: int
  assume "0 \<le> j_int"
  assume "j_int < int CARD(4)"
  hence "j_int \<le> 3" by simp

  show "of_int j_int = (3::4) \<or> (\<exists> j'::3. of_int j_int = of_int (Rep_bit1 j'))"
  proof cases
    assume "j_int = 3"
    thus
      "of_int j_int = (3::4) \<or> (\<exists> j'::3. of_int j_int = of_int (Rep_bit1 j'))"
      by simp
  next
    assume "j_int \<noteq> 3"
    with \<open>j_int \<le> 3\<close> have "j_int < 3" by simp
    with \<open>0 \<le> j_int\<close> have "j_int \<in> {0..<3}" by simp
    hence "Rep_bit1 (Abs_bit1 j_int :: 3) = j_int"
      by (simp add: bit1.Abs_inverse)
    hence "of_int j_int = of_int (Rep_bit1 (Abs_bit1 j_int :: 3))" by simp
    thus
      "of_int j_int = (3::4) \<or> (\<exists> j'::3. of_int j_int = of_int (Rep_bit1 j'))"
      by auto
  qed
qed

lemma sgn_plus:
  fixes x y :: "'a::linordered_idom"
  assumes "sgn x = sgn y"
  shows "sgn (x + y) = sgn x"
  by (simp add: assms same_sgn_sgn_add)

lemma sgn_div:
  fixes x y :: "'a::linordered_field"
  assumes "y \<noteq> 0" and "sgn x = sgn y"
  shows "x / y > 0"
  using assms sgn_1_pos sgn_eq_0_iff by fastforce

lemma abs_plus:
  fixes x y :: "'a::linordered_idom"
  assumes "sgn x = sgn y"
  shows "\<bar>x + y\<bar> = \<bar>x\<bar> + \<bar>y\<bar>"
  by (simp add: assms same_sgn_abs_add)

lemma sgn_plus_abs:
  fixes x y :: "'a::linordered_idom"
  assumes "\<bar>x\<bar> > \<bar>y\<bar>"
  shows "sgn (x + y) = sgn x"
  by (cases "x > 0") (use assms in auto)

end


theory MyPredicate
    imports Main
begin

text \<open>
We are again talking about proofs in the calculus of Natural Deduction.  In
addition to the rules given in the exercise ``Propositional Logic'', you may
now also use

  @{text "exI:"}~@{thm exI[no_vars]}\\
  @{text "exE:"}~@{thm exE[no_vars]}\\
  @{text "allI:"}~@{thm allI[no_vars]}\\
  @{text "allE:"}~@{thm allE[no_vars]}\\

Give a proof of the following propositions or an argument why the formula is
not valid:
\<close>

lemma "(\<exists>x. \<forall>y. P x y) \<longrightarrow> (\<forall>y. \<exists>x. P x y)"
  apply (rule impI)
  apply (erule exE)
  apply (rule allI)
  apply (rule exI)
  apply (rule allE)
  by assumption

lemma "(\<forall>x. P x \<longrightarrow> Q) = ((\<exists>x. P x) \<longrightarrow> Q)"
  apply (rule iffI)

   apply (rule impI)
   apply (erule exE)
   apply (erule allE)
   apply (erule impE)
    apply assumption+

  apply (rule allI)
  apply (rule impI)
  apply (erule impE)
   apply (rule exI)
  by assumption

lemma "((\<forall> x. P x) \<and> (\<forall> x. Q x)) = (\<forall> x. (P x \<and> Q x))"
  apply (rule iffI)

  apply (erule conjE)
   apply (rule allI)
   apply (erule allE)+
   apply (rule conjI)
    apply assumption+

  apply (rule conjI)
   apply (rule allI)
   apply (erule allE)
   apply (erule conjE)
   apply assumption
  apply (rule allI)
  apply (erule allE)
  apply (erule conjE)
  apply (assumption)

lemma "((\<forall> x. P x ) \<or> (\<forall> x. Q x)) = (\<forall> x. (P x \<or> Q x))"
(*
  The LHS says that either all values of x are true for P or all values of x are true for Q.
  The RHS says that all values of x are true for either P or Q.
  Let's take P as the predicate "is odd" and for Q the predicate "is even", and let x range
  over the natural numbers. Clearly the LHS is true, every number is either odd or even.
  However the LHS is not true, it is not true that every number is even or every number is odd
*)
  oops

lemma "((\<exists> x. P x) \<or> (\<exists> x. Q x)) = (\<exists> x. (P x \<or> Q x))"
  apply (rule iffI)

   apply (erule disjE)
    apply (erule exE)
    apply (rule exI)
    apply (rule disjI1, assumption)
   apply (erule exE)
   apply (rule exI)
   apply (rule disjI2, assumption)

  apply (erule exE)
  apply (erule disjE)
   apply (rule disjI1)
   apply (rule exI, assumption)
  apply (rule disjI2)
  apply (rule exI, assumption)
  done

lemma "(\<forall>x. \<exists>y. P x y) \<longrightarrow> (\<exists>y. \<forall>x. P x y)"
(*
Imagine P is the relation "is greater than"
The left hand side says that for every number there is a number that is bigger than it.
The RHS says the there is a number that is greater than every number. The LHS clearly does
not imply the RHS
*)
  oops

lemma "(\<not> (\<forall> x. P x)) = (\<exists> x. \<not> P x)"
  apply (rule iffI)

  apply (rule classical)
   apply (erule notE)
   apply (rule allI)
   apply (rule classical)
   apply (erule notE)
   apply (rule exI, assumption)

  apply (rule notI)
  apply (erule exE)
  apply (erule allE)
  apply (erule notE)
  by (assumption)

(*<*) end (*>*)


theory Triconnectivity
  imports
    Connectivity
    Idk
    "../../Partitions_Ext"
begin

subsection \<open>Separation classes\<close>

definition (in other) separation_class :: "('a, 'b) multigraph \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> ('a, 'b) edge \<Rightarrow> ('a, 'b) multigraph" where
  "separation_class G a b \<equiv> tbd G {a, b}"

lemma (in other) separation_class_subset:
  shows "separation_class G a b e \<subseteq> G"
  unfolding separation_class_def
  by (intro tbd_subset)

lemma (in other) V_separation_class_subset:
  shows "V (separation_class G a b e) \<subseteq> V G"
  unfolding V_def
  using separation_class_subset
  by fast

(* QUESTION: Should we allow the empty set? *)
definition (in other) separation_classes :: "('a, 'b) multigraph \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> ('a, 'b) multigraph set" where
  "separation_classes G a b \<equiv> {E. \<exists>e\<in>G. E = separation_class G a b e}"

lemma (in other) separation_classes_tbds_cong:
  shows "separation_classes G a b = tbds G {a, b}"
  unfolding separation_classes_def separation_class_def tbds_def
  ..

lemma (in other) separation_classes_image_cong:
  shows "separation_classes G a b = (separation_class G a b) ` G"
  by (auto simp add: separation_classes_def)

lemma (in other) separation_class_subset_2:
  assumes "E1 \<in> separation_classes G a b"
  shows "E1 \<subseteq> G"
  using assms separation_class_subset
  by (fastforce simp add: separation_classes_def)

lemma (in other) V_separation_class_subset_2:
  assumes "E1 \<in> separation_classes G a b"
  shows "V E1 \<subseteq> V G"
  using assms V_separation_class_subset
  by (fastforce simp add: separation_classes_def)

lemma (in finite_multigraph) finite_separation_classes:
  shows "finite (separation_classes G a b)"
  using finite_edges
  by (simp add: separation_classes_image_cong)

lemma (in other) separation_class_68:
  assumes "E1 \<in> separation_classes G a b"
  assumes "E2 \<in> separation_classes G a b"
  assumes "E1 \<noteq> E2"
  shows "E1 \<inter> E2 = {}"
  sorry

lemma (in other) separation_class_69:
  assumes "E1 \<in> separation_classes G a b"
  assumes "E2 \<in> separation_classes G a b"
  assumes "E1 \<noteq> E2"
  shows "V E1 \<inter> V E2 = {a, b}"
  sorry

lemma (in other) separation_class_20:
  assumes "E G X \<in> separation_classes G a b"
  shows "V (E G X) = X \<union> {a, b}"
  sorry

subsection \<open>Separation pairs\<close>

definition (in other) is_case_1 :: "('a, 'b) multigraph \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> bool" where
  "is_case_1 G a b \<equiv>
   \<exists>E1 E2. separation_classes G a b = {E1, E2} \<and> E1 \<noteq> E2 \<and>
           (card E1 = 1 \<or> card E2 = 1)"

lemma (in other) is_case_1E:
  assumes "is_case_1 G a b"
  obtains E1 E2 where
    "separation_classes G a b = {E1, E2}"
    "E1 \<noteq> E2"
    "card E1 = 1 \<or> card E2 = 1"
  using assms
  by (auto simp add: is_case_1_def)

definition (in other) is_case_2 :: "('a, 'b) multigraph \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> bool" where
  "is_case_2 G a b \<equiv>
   \<exists>E1 E2 E3.
      separation_classes G a b = {E1, E2, E3} \<and> E1 \<noteq> E2 \<and> E2 \<noteq> E3 \<and>
      card E1 = 1 \<and> card E2 = 1 \<and> card E3 = 1"

lemma (in other) is_case_2E:
  assumes "is_case_2 G a b"
  obtains E1 E2 E3 where
    "separation_classes G a b = {E1, E2, E3}"
    "E1 \<noteq> E2"
    "E2 \<noteq> E3"
    "card E1 = 1"
    "card E2 = 1"
    "card E3 = 1"
  using assms
  by (auto simp add: is_case_2_def)

definition (in other) is_separation_pair :: "('a, 'b) multigraph \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> bool" where
  "is_separation_pair G a b \<equiv>
   2 \<le> card (separation_classes G a b) \<and>
   \<not> is_case_1 G a b \<and>
   \<not> is_case_2 G a b"

lemma (in other) is_separation_pairD:
  assumes "is_separation_pair G a b"
  shows
    "2 \<le> card (separation_classes G a b)"
    "\<not> is_case_1 G a b"
    "\<not> is_case_2 G a b"
  using assms
  by (simp_all add: is_separation_pair_def)

(* TODO: Rename. *)
lemma (in other) separation_pair_mem_V:
  assumes "is_separation_pair G a b"
  shows
    "a \<in> V G"
    "b \<in> V G"
  using assms
  sorry

lemma (in other) is_separation_pairI:
  assumes "2 \<le> card (separation_classes G a b)"
  assumes "\<not> is_case_1 G a b"
  assumes "\<not> is_case_2 G a b"
  shows "is_separation_pair G a b"
  using assms
  by (simp add: is_separation_pair_def)

(* TODO: Move. *)
lemma card_ge_2_iff:
  assumes "finite S"
  shows "2 \<le> card S = (\<exists>e1 e2. e1 \<in> S \<and> e2 \<in> S \<and> e1 \<noteq> e2)"
  using assms
  by (auto dest: card_le_Suc0_iff_eq)

lemma (in other) is_separation_pairI_2:
  assumes "finite (separation_classes G a b)"
  assumes "E1 \<in> separation_classes G a b"
  assumes "2 \<le> card E1"
  assumes "E2 \<in> separation_classes G a b"
  assumes "2 \<le> card E2"
  assumes "E1 \<noteq> E2"
  shows "is_separation_pair G a b"
proof (rule is_separation_pairI, goal_cases)
  case 1
  show ?case
    using assms(1, 2, 4, 6)
    by (auto simp add: card_ge_2_iff)
next
  case 2
  show ?case
    using assms(2-6)
    by (force simp add: is_case_1_def)
next
  case 3
  show ?case
    using assms(2, 3)
    by (fastforce simp add: is_case_2_def)
qed

lemma (in other) is_separation_pairI_10:
  assumes "C1 \<in> connected_components (idk_4 G {a, b})"
  assumes "C2 \<in> connected_components (idk_4 G {a, b})"
  assumes "C2 \<noteq> C1"
  shows "is_separation_pair G a b"
  sorry

(**)

lemma (in other) separation_class_2:
  assumes "e \<in> G"
  shows "e \<in> separation_class G a b e"
  sorry

lemma (in other) separation_class_non_empty:
  assumes "E1 \<in> separation_classes G a b"
  shows "E1 \<noteq> {}"
  using assms
  by (auto simp add: separation_classes_def intro: separation_class_2)

lemma (in other) separation_class_1:
  assumes "v \<in> V G"
  assumes "v \<noteq> a"
  assumes "v \<noteq> b"
  obtains E where
    "E \<in> separation_classes G a b"
    "v \<in> V E"
  sorry

lemma (in other) separation_class_3:
  assumes "E1 \<in> separation_classes G a b"
  assumes "u \<in> V E1"
  assumes "v \<in> V E1"
  obtains p where
    "walk E1 p u v"
    "set (tl (butlast (walk_vertices p u))) \<inter> {a, b} = {}"
  sorry

lemma (in other) separation_class_4:
  assumes "E1 \<in> separation_classes G a b"
  assumes "u \<noteq> a"
  assumes "u \<noteq> b"
  assumes "u \<in> V E1"
  assumes "v \<noteq> a"
  assumes "v \<noteq> b"
  assumes "v \<in> V E1"
  obtains p where
    "walk E1 p u v"
    "set (walk_vertices p u) \<inter> {a, b} = {}"
  sorry

lemma (in biconnected_multigraph) card_separation_class_geq_2I:
  assumes "E1 \<in> separation_classes G a b"
  assumes "v \<noteq> a"
  assumes "v \<noteq> b"
  assumes "v \<in> V E1"
  shows "2 \<le> card E1"
  sorry

lemma (in other) is_separation_pairI_3:
  assumes "is_multiple_edge G {a, b}"
  assumes "4 \<le> card G"
  shows "is_separation_pair G a b"
proof (rule is_separation_pairI, goal_cases)
  case 1
  then show ?case sorry
next
  case 2
  then show ?case sorry
next
  case 3
  then show ?case sorry
qed

lemma (in other) card_geq_4I:
  assumes "is_separation_pair G a b"
  assumes "is_multiple_edge G {a, b}"
  shows "4 \<le> card G"
  sorry

lemma (in other) separation_class_10:
  assumes "is_separation_pair G a b"
  assumes "\<not> is_multiple_edge G {a, b}"
  assumes "E1 \<in> separation_classes G a b"
  obtains E2 v where
    "E2 \<in> separation_classes G a b"
    "E2 \<noteq> E1"
    "v \<in> V E2"
    "v \<noteq> a"
    "v \<noteq> b"
  sorry

(* TODO: Consider removing this lemma. *)
lemma (in other) separation_class_99:
  assumes "is_separation_pair G a b"
  assumes "\<not> is_multiple_edge G {a, b}"
  assumes "C1 \<in> connected_components (idk_4 G {a, b})"
  obtains C2 where
    "C2 \<in> connected_components (idk_4 G {a, b})"
    "C2 \<noteq> C1"
  sorry

lemma (in other) separation_class_11:
  assumes "is_separation_pair G a b"
  assumes "\<not> is_multiple_edge G {a, b}"
  assumes "E1 \<in> separation_classes G a b"
  obtains v where
    "v \<in> V G"
    "v \<notin> V E1"
  sorry

lemma (in other) separation_class_13:
  assumes "is_separation_pair G a b"
  assumes "\<not> is_multiple_edge G {a, b}"
  obtains C1 C2 where
    "C1 \<in> connected_components (idk_4 G {a, b})"
    "C2 \<in> connected_components (idk_4 G {a, b})"
    "C2 \<noteq> C1"
  sorry

(* TODO: Consider removing this lemma. *)
lemma (in other) separation_class_12:
  assumes "is_separation_pair G a b"
  assumes "\<not> is_multiple_edge G {a, b}"
  assumes "C \<in> connected_components (idk_4 G {a, b})"
  obtains v where
    "v \<in> V G"
    "v \<noteq> a"
    "v \<noteq> b"
    "v \<notin> C"
  sorry

subsection \<open>Split components\<close>

definition (in other) are_split_graphs where
  "are_split_graphs G G' G'' \<equiv>
   \<exists>a b Es' Es'' e.
      Es' \<union> Es'' = separation_classes G a b \<and>
      Es' \<inter> Es'' = {} \<and>
      2 \<le> card (\<Union> Es') \<and>
      2 \<le> card (\<Union> Es'') \<and>
      G' = \<Union> Es' \<union> {e} \<and>
      G'' = \<Union> Es'' \<union> {e} \<and>
      endpoints e = {a, b} \<and>
      e \<notin> G"

lemma (in other) are_split_graphsE:
  assumes "are_split_graphs G G' G''"
  obtains a b Es' Es'' e where
    "Es' \<union> Es'' = separation_classes G a b"
    "Es' \<inter> Es'' = {}"
    "2 \<le> card (\<Union> Es')"
    "2 \<le> card (\<Union> Es'')"
    "G' = \<Union> Es' \<union> {e}"
    "G'' = \<Union> Es'' \<union> {e}"
    "endpoints e = {a, b}"
    "e \<notin> G"
  using assms
  by (auto simp add: are_split_graphs_def)

lemma (in finite_multigraph) split_graphs_imp_separation_pair:
  assumes "are_split_graphs G G' G''"
  obtains a b where
    "is_separation_pair G a b"
proof -
  obtain a b Es' Es'' where
    *: "Es' \<union> Es'' = separation_classes G a b"
    "Es' \<inter> Es'' = {}"
    "2 \<le> card (\<Union> Es')"
    "2 \<le> card (\<Union> Es'')"
    using assms
    by (elim are_split_graphsE)
  have "is_separation_pair G a b"
  proof (intro is_separation_pairI, goal_cases)
    case 1
    obtain E' E'' where
      "E' \<in> Es'"
      "E'' \<in> Es''"
      using *(3, 4)
      by fastforce
    moreover hence "E' \<noteq> E''"
      using *(2)
      by auto
    ultimately show ?case
      using *(1) finite_separation_classes
      by (fastforce simp add: card_ge_2_iff)
  next
    case 2
    { assume "is_case_1 G a b"
      then obtain E1 E2 where
        E1_E2: "separation_classes G a b = {E1, E2}"
        "E1 \<noteq> E2"
        "card E1 = 1 \<or> card E2 = 1"
        by (elim is_case_1E)
      hence "Es' = {E1} \<and> Es'' = {E2} \<or> Es' = {E2} \<and> Es'' = {E1}"
        (* TODO: Beautify. *)
        using *
        by (smt (verit, best) Int_Un_eq(1) Int_insert_left_if0 Int_insert_left_if1 Un_Int_eq(2) Un_Int_eq(3) Union_empty equals0D finite.emptyI card_ge_2_iff other_axioms sup_commute)
      hence False
        using *(3-4) E1_E2(3)
        by fastforce }
    thus ?case
      by fast
  next
    case 3
    { assume "is_case_2 G a b"
      then obtain E1 E2 E3 where
        "separation_classes G a b = {E1, E2, E3}"
        "E1 \<noteq> E2"
        "E2 \<noteq> E3"
        "card E1 = 1"
        "card E2 = 1"
        "card E3 = 1"
        by (elim is_case_2E)
      hence False
        (* TODO: Beautify. *)
        using *
        by (smt (verit, ccfv_threshold) Int_Un_eq(4) Int_insert_right_if0 Int_insert_right_if1 Suc_1 Sup_empty Un_Int_eq(2) Un_Int_eq(3) Un_Int_eq(4) cSup_singleton empty_iff finite.intros(1) insert_iff lessI linorder_not_less card_ge_2_iff other_axioms) }
    thus ?case
      by blast
  qed
  thus ?thesis
    by (intro that)
qed

lemma (in finite_multigraph) split_graphs_if_separation_pair:
  assumes "is_separation_pair G a b"
  obtains G' G'' where
    "are_split_graphs G G' G''"
  sorry

(* QUESTION: Rename? *)
inductive (in other) is_split_image :: "('a, 'b) multigraph list \<Rightarrow> ('a, 'b) multigraph list \<Rightarrow> bool" where
  is_split_image_Nil_Nil: "is_split_image [] []" |
  is_split_image_Cons_Cons:
  "\<lbrakk> \<not> (\<exists>G' G''. are_split_graphs G G' G''); is_split_image Gs Gs' \<rbrakk> \<Longrightarrow>
   is_split_image (G # Gs) (G # Gs')" |
  is_split_image_Cons_Cons_Cons:
  "\<lbrakk> are_split_graphs G G' G''; is_split_image Gs Gs' \<rbrakk> \<Longrightarrow> is_split_image (G # Gs) (G' # G'' # Gs')"

declare (in other) is_split_image_Nil_Nil [simp]
inductive_simps (in other) is_split_image_Cons_Cons_iff [simp]: "is_split_image (G # Gs) (G' # Gs')"
inductive_simps (in other) is_split_image_Cons_Cons_Cons_iff [simp]: "is_split_image (G # Gs) (G' # G'' # Gs')"

lemma (in other) is_split_image_Cons_Cons_iff_2:
  shows
    "is_split_image (G # Gs) (G # Gs') \<longleftrightarrow>
     \<not> (\<exists>G' G''. are_split_graphs G G' G'') \<and> is_split_image Gs Gs'"
  by (auto simp add: are_split_graphs_def)

lemma (in finite_multigraph) is_split_image_Cons_Cons_iff_2:
  shows
    "is_split_image (G # Gs) (G # Gs') \<longleftrightarrow>
     \<not> (\<exists>a b. is_separation_pair G a b) \<and> is_split_image Gs Gs'"
  unfolding is_split_image_Cons_Cons_iff_2
  by (auto elim: split_graphs_imp_separation_pair split_graphs_if_separation_pair)

(* QUESTION: Rename? *)
lemma (in other) is_split_image_fixpoint_iff:
  shows "is_split_image Gs Gs \<longleftrightarrow> (\<forall>G\<in>set Gs. \<not> (\<exists>G' G''. are_split_graphs G G' G''))"
proof (induct Gs)
  case Nil
  show ?case
    by simp
next
  case (Cons G Gs)
  thus ?case
    unfolding is_split_image_Cons_Cons_iff_2
    by simp
qed

(* QUESTION: Rename? *)
lemma (in other) is_split_image_fixpoint_iff_2:
  assumes "Ball (set Gs) (finite_multigraph other)"
  shows "is_split_image Gs Gs \<longleftrightarrow> (\<forall>G\<in>set Gs. \<not> (\<exists>a b. is_separation_pair G a b))"
  using assms
  by
    (fastforce
      simp add: is_split_image_fixpoint_iff
      elim: finite_multigraph.split_graphs_imp_separation_pair finite_multigraph.split_graphs_if_separation_pair)

lemma (in other) length_split_image_geq:
  assumes "is_split_image Gs Gs'"
  shows "length Gs \<le> length Gs'"
  using assms
  by (induct rule: is_split_image.induct) simp+

(* QUESTION: Rename? *)
lemma (in other) is_split_image_fixpointI:
  assumes "is_split_image Gs Gs'"
  assumes "length Gs = length Gs'"
  shows "Gs = Gs'"
  using assms
  by (induct rule: is_split_image.induct) (auto dest: length_split_image_geq)

(* TODO: Rename. *)
definition (in other) is_split_tbd :: "('a, 'b) multigraph list \<Rightarrow> ('a, 'b) multigraph list \<Rightarrow> bool" where
  "is_split_tbd Gs Gs' \<equiv> (Gs, Gs') \<in> {(Gs, Gs'). is_split_image Gs Gs'}\<^sup>+"

(* TODO: Rename. *)
lemma (in other) length_split_tbd_geq:
  assumes "is_split_tbd Gs Gs'"
  shows "length Gs \<le> length Gs'"
  using assms
  unfolding is_split_tbd_def
  by (induct rule: trancl.induct) (auto dest: length_split_image_geq)

(* TODO: Rename. *)
lemma (in other) is_split_tbd_fixpointD:
  assumes "is_split_tbd Gs Gs"
  shows "\<forall>G\<in>set Gs. \<not> (\<exists>G' G''. are_split_graphs G G' G'')"
  using assms
  unfolding is_split_tbd_def
proof (cases rule: trancl.cases)
  case r_into_trancl
  thus ?thesis
    by (simp add: is_split_image_fixpoint_iff)
next
  case (trancl_into_trancl Gs')
  hence "length Gs' = length Gs"
    by (fastforce simp add: is_split_tbd_def[symmetric] dest: length_split_image_geq length_split_tbd_geq)
  hence "Gs' = Gs"
    using trancl_into_trancl(2)
    by (auto dest: is_split_image_fixpointI)
  thus ?thesis
    using trancl_into_trancl(2)
    by (simp add: is_split_image_fixpoint_iff)
qed

(* TODO: Rename. *)
lemma (in other) is_split_tbd_fixpointD_2:
  assumes "Ball (set Gs) (finite_multigraph other)"
  assumes "is_split_tbd Gs Gs"
  shows "\<forall>G\<in>set Gs. \<not> (\<exists>a b. is_separation_pair G a b)"
  using assms
  by (fastforce dest: is_split_tbd_fixpointD elim: finite_multigraph.split_graphs_if_separation_pair)

(* TODO: Rename. *)
lemma (in other) is_split_tbd_fixpoint_iff:
  shows "is_split_tbd Gs Gs \<longleftrightarrow> (\<forall>G\<in>set Gs. \<not> (\<exists>G' G''. are_split_graphs G G' G''))"
proof (standard, goal_cases)
  case 1
  thus ?case
    by (intro is_split_tbd_fixpointD)
next
  case 2
  thus ?case
    by (auto simp add: is_split_tbd_def is_split_image_fixpoint_iff)
qed

(* TODO: Rename. *)
lemma (in other) is_split_tbd_fixpoint_iff_2:
  assumes "Ball (set Gs) (finite_multigraph other)"
  shows "is_split_tbd Gs Gs \<longleftrightarrow> (\<forall>G\<in>set Gs. \<not> (\<exists>a b. is_separation_pair G a b))"
  using assms
  by
    (fastforce
      simp add: is_split_tbd_fixpoint_iff
      elim: finite_multigraph.split_graphs_imp_separation_pair finite_multigraph.split_graphs_if_separation_pair)

definition (in other) are_split_components :: "('a, 'b) multigraph \<Rightarrow> ('a, 'b) multigraph list \<Rightarrow> bool" where
  "are_split_components G Gs \<equiv> is_split_tbd [G] Gs \<and> is_split_tbd Gs Gs"

lemma (in other) are_split_componentsI:
  assumes "is_split_tbd [G] Gs"
  assumes "is_split_tbd Gs Gs"
  shows "are_split_components G Gs"
  using assms
  by (simp add: are_split_components_def)

lemma (in other) are_split_componentsI_2:
  assumes "Ball (set Gs) (finite_multigraph other)"
  assumes "is_split_tbd [G] Gs"
  assumes "\<forall>G\<in>set Gs. \<not> (\<exists>a b. is_separation_pair G a b)"
  shows "are_split_components G Gs"
  using assms
  by (auto simp add: is_split_tbd_fixpoint_iff_2 intro: are_split_componentsI)

definition merge :: "('a, 'b) multigraph \<Rightarrow> ('a, 'b) multigraph \<Rightarrow> ('a, 'b) edge \<Rightarrow> ('a, 'b) multigraph" where
  "merge G1 G2 e \<equiv> G1 \<union> G2 - {e}"

subsection \<open>Triconnected components\<close>

end


(*  Title:       Prefix ordering on coinductive lists as ordering for type class order
    Author:      Andreas Lochbihler
    Maintainer:  Andreas Lochbihler
*)

header {* Instantiation of the order type classes for lazy lists *}
theory Coinductive_List_Prefix imports
  Coinductive_List
  "~~/src/HOL/Library/Prefix_Order"
begin

subsection {* Instantiation of the order type class *}

instantiation llist :: (type) order begin

definition [code_unfold]: "xs \<le> ys = lprefix xs ys"

definition [code_unfold]: "xs < ys = lstrict_prefix xs ys"

instance
proof(intro_classes)
  fix xs ys zs :: "'a llist"
  show "(xs < ys) = (xs \<le> ys \<and> \<not> ys \<le> xs)"
    unfolding less_llist_def less_eq_llist_def lstrict_prefix_def
    by(auto simp: lprefix_antisym)
  show "xs \<le> xs" unfolding less_eq_llist_def by(rule lprefix_refl)
  show "\<lbrakk>xs \<le> ys; ys \<le> zs\<rbrakk> \<Longrightarrow> xs \<le> zs"
    unfolding less_eq_llist_def by(rule lprefix_trans)
  show "\<lbrakk>xs \<le> ys; ys \<le> xs\<rbrakk> \<Longrightarrow> xs = ys"
    unfolding less_eq_llist_def by(rule lprefix_antisym)
qed

end

lemma le_llist_conv_lprefix [iff]: "op \<le> = lprefix"
by(simp add: less_eq_llist_def fun_eq_iff)

lemma less_llist_conv_lstrict_prefix [iff]: "op < = lstrict_prefix"
by(simp add: less_llist_def fun_eq_iff)

instantiation llist :: (type) order_bot begin

definition "bot = LNil"

instance
by(intro_classes)(simp add: bot_llist_def)

end

lemma llist_of_lprefix_llist_of [simp]:
  "lprefix (llist_of xs) (llist_of ys) \<longleftrightarrow> xs \<le> ys"
proof(induct xs arbitrary: ys)
  case (Cons x xs) thus ?case
    by(cases ys)(auto simp add: LCons_lprefix_conv)
qed simp

subsection {* Prefix ordering as a lower semilattice *}

instantiation llist :: (type) semilattice_inf begin

definition [code del]:
  "inf xs ys =
   unfold_llist (\<lambda>(xs, ys). xs \<noteq> LNil \<longrightarrow> ys \<noteq> LNil \<longrightarrow> lhd xs \<noteq> lhd ys)
     (lhd \<circ> snd) (map_prod ltl ltl) (xs, ys)"

lemma llist_inf_simps [simp, code, nitpick_simp]:
  "inf LNil xs = LNil"
  "inf xs LNil = LNil"
  "inf (LCons x xs) (LCons y ys) = (if x = y then LCons x (inf xs ys) else LNil)"
unfolding inf_llist_def by simp_all

lemma llist_inf_eq_LNil [simp]:
  "lnull (inf xs ys) \<longleftrightarrow> (xs \<noteq> LNil \<longrightarrow> ys \<noteq> LNil \<longrightarrow> lhd xs \<noteq> lhd ys)"
by(simp add: inf_llist_def)

instance
proof
  fix xs ys zs :: "'a llist"
  show "inf xs ys \<le> xs" unfolding le_llist_conv_lprefix
    by(coinduction arbitrary: xs ys) auto

  show "inf xs ys \<le> ys" unfolding le_llist_conv_lprefix
    by(coinduction arbitrary: xs ys) auto

  assume "xs \<le> ys" "xs \<le> zs"
  thus "xs \<le> inf ys zs" unfolding le_llist_conv_lprefix
  proof(coinduction arbitrary: xs ys zs)
    case (lprefix xs ys zs)
    thus ?case by(cases xs)(auto 4 4 simp add: LCons_lprefix_conv)
  qed
qed

end

lemma llength_inf [simp]: "llength (inf xs ys) = llcp xs ys"
by(coinduction arbitrary: xs ys rule: enat_coinduct)(auto simp add: llcp_eq_0_iff epred_llength epred_llcp)

instantiation llist :: (type) ccpo
begin

definition "Sup A = lSup A"

instance
  by intro_classes
     (auto simp: Sup_llist_def less_eq_llist_def[abs_def] intro!: llist.lub_upper llist.lub_least)

end

end


(*  Title:      HOL/Algebra/Multiplicative_Group.thy
    Author:     Simon Wimmer
    Author:     Lars Noschinski
*)

theory Multiplicative_Group
imports
  Complex_Main
  Group
  Coset
  UnivPoly
  Generated_Groups
begin

section \<open>Simplification Rules for Polynomials\<close>
text_raw \<open>\label{sec:simp-rules}\<close>

lemma (in ring_hom_cring) hom_sub[simp]:
  assumes "x \<in> carrier R" "y \<in> carrier R"
  shows "h (x \<ominus> y) = h x \<ominus>\<^bsub>S\<^esub> h y"
  using assms by (simp add: R.minus_eq S.minus_eq)

context UP_ring begin

lemma deg_nzero_nzero:
  assumes deg_p_nzero: "deg R p \<noteq> 0"
  shows "p \<noteq> \<zero>\<^bsub>P\<^esub>"
  using deg_zero deg_p_nzero by auto

lemma deg_add_eq:
  assumes c: "p \<in> carrier P" "q \<in> carrier P"
  assumes "deg R q \<noteq> deg R p"
  shows "deg R (p \<oplus>\<^bsub>P\<^esub> q) = max (deg R p) (deg R q)"
proof -
  let ?m = "max (deg R p) (deg R q)"
  from assms have "coeff P p ?m = \<zero> \<longleftrightarrow> coeff P q ?m \<noteq> \<zero>"
    by (metis deg_belowI lcoeff_nonzero[OF deg_nzero_nzero] linear max.absorb_iff2 max.absorb1)
  then have "coeff P (p \<oplus>\<^bsub>P\<^esub> q) ?m \<noteq> \<zero>"
    using assms by auto
  then have "deg R (p \<oplus>\<^bsub>P\<^esub> q) \<ge> ?m"
    using assms by (blast intro: deg_belowI)
  with deg_add[OF c] show ?thesis by arith
qed

lemma deg_minus_eq:
  assumes "p \<in> carrier P" "q \<in> carrier P" "deg R q \<noteq> deg R p"
  shows "deg R (p \<ominus>\<^bsub>P\<^esub> q) = max (deg R p) (deg R q)"
  using assms by (simp add: deg_add_eq a_minus_def)

end

context UP_cring begin

lemma evalRR_add:
  assumes "p \<in> carrier P" "q \<in> carrier P"
  assumes x:"x \<in> carrier R"
  shows "eval R R id x (p \<oplus>\<^bsub>P\<^esub> q) = eval R R id x p \<oplus> eval R R id x q"
proof -
  interpret UP_pre_univ_prop R R id by unfold_locales simp
  interpret ring_hom_cring P R "eval R R id x" by unfold_locales (rule eval_ring_hom[OF x])
  show ?thesis using assms by simp
qed

lemma evalRR_sub:
  assumes "p \<in> carrier P" "q \<in> carrier P"
  assumes x:"x \<in> carrier R"
  shows "eval R R id x (p \<ominus>\<^bsub>P\<^esub> q) = eval R R id x p \<ominus> eval R R id x q"
proof -
  interpret UP_pre_univ_prop R R id by unfold_locales simp
  interpret ring_hom_cring P R "eval R R id x" by unfold_locales (rule eval_ring_hom[OF x])
  show ?thesis using assms by simp
qed

lemma evalRR_mult:
  assumes "p \<in> carrier P" "q \<in> carrier P"
  assumes x:"x \<in> carrier R"
  shows "eval R R id x (p \<otimes>\<^bsub>P\<^esub> q) = eval R R id x p \<otimes> eval R R id x q"
proof -
  interpret UP_pre_univ_prop R R id by unfold_locales simp
  interpret ring_hom_cring P R "eval R R id x" by unfold_locales (rule eval_ring_hom[OF x])
  show ?thesis using assms by simp
qed

lemma evalRR_monom:
  assumes a: "a \<in> carrier R" and x: "x \<in> carrier R"
  shows "eval R R id x (monom P a d) = a \<otimes> x [^] d"
proof -
  interpret UP_pre_univ_prop R R id by unfold_locales simp
  show ?thesis using assms by (simp add: eval_monom)
qed

lemma evalRR_one:
  assumes x: "x \<in> carrier R"
  shows "eval R R id x \<one>\<^bsub>P\<^esub> = \<one>"
proof -
  interpret UP_pre_univ_prop R R id by unfold_locales simp
  interpret ring_hom_cring P R "eval R R id x" by unfold_locales (rule eval_ring_hom[OF x])
  show ?thesis using assms by simp
qed

lemma carrier_evalRR:
  assumes x: "x \<in> carrier R" and "p \<in> carrier P"
  shows "eval R R id x p \<in> carrier R"
proof -
  interpret UP_pre_univ_prop R R id by unfold_locales simp
  interpret ring_hom_cring P R "eval R R id x" by unfold_locales (rule eval_ring_hom[OF x])
  show ?thesis using assms by simp
qed

lemmas evalRR_simps = evalRR_add evalRR_sub evalRR_mult evalRR_monom evalRR_one carrier_evalRR

end

section \<open>Properties of the Euler \<open>\<phi>\<close>-function\<close>
text_raw \<open>\label{sec:euler-phi}\<close>

text\<open>
  In this section we prove that for every positive natural number the equation
  $\sum_{d | n}^n \varphi(d) = n$ holds.
\<close>

lemma dvd_div_ge_1:
  fixes a b :: nat
  assumes "a \<ge> 1" "b dvd a"
  shows "a div b \<ge> 1"
proof -
  from \<open>b dvd a\<close> obtain c where "a = b * c" ..
  with \<open>a \<ge> 1\<close> show ?thesis by simp
qed

lemma dvd_nat_bounds:
 fixes n p :: nat
 assumes "p > 0" "n dvd p"
 shows "n > 0 \<and> n \<le> p"
 using assms by (simp add: dvd_pos_nat dvd_imp_le)

(* Deviates from the definition given in the library in number theory *)
definition phi' :: "nat => nat"
  where "phi' m = card {x. 1 \<le> x \<and> x \<le> m \<and> coprime x m}"

notation (latex output)
  phi' ("\<phi> _")

lemma phi'_nonzero:
  assumes "m > 0"
  shows "phi' m > 0"
proof -
  have "1 \<in> {x. 1 \<le> x \<and> x \<le> m \<and> coprime x m}" using assms by simp
  hence "card {x. 1 \<le> x \<and> x \<le> m \<and> coprime x m} > 0" by (auto simp: card_gt_0_iff)
  thus ?thesis unfolding phi'_def by simp
qed

lemma dvd_div_eq_1:
  fixes a b c :: nat
  assumes "c dvd a" "c dvd b" "a div c = b div c"
  shows "a = b" using assms dvd_mult_div_cancel[OF \<open>c dvd a\<close>] dvd_mult_div_cancel[OF \<open>c dvd b\<close>]
                by presburger

lemma dvd_div_eq_2:
  fixes a b c :: nat
  assumes "c>0" "a dvd c" "b dvd c" "c div a = c div b"
  shows "a = b"
  proof -
  have "a > 0" "a \<le> c" using dvd_nat_bounds[OF assms(1-2)] by auto
  have "a*(c div a) = c" using assms dvd_mult_div_cancel by fastforce
  also have "\<dots> = b*(c div a)" using assms dvd_mult_div_cancel by fastforce
  finally show "a = b" using \<open>c>0\<close> dvd_div_ge_1[OF _ \<open>a dvd c\<close>] by fastforce
qed

lemma div_mult_mono:
  fixes a b c :: nat
  assumes "a > 0" "a\<le>d"
  shows "a * b div d \<le> b"
proof -
  have "a*b div d \<le> b*a div a" using assms div_le_mono2 mult.commute[of a b] by presburger
  thus ?thesis using assms by force
qed

text\<open>
  We arrive at the main result of this section:
  For every positive natural number the equation $\sum_{d | n}^n \varphi(d) = n$ holds.

  The outline of the proof for this lemma is as follows:
  We count the $n$ fractions $1/n$, $\ldots$, $(n-1)/n$, $n/n$.
  We analyze the reduced form $a/d = m/n$ for any of those fractions.
  We want to know how many fractions $m/n$ have the reduced form denominator $d$.
  The condition $1 \leq m \leq n$ is equivalent to the condition $1 \leq a \leq d$.
  Therefore we want to know how many $a$ with $1 \leq a \leq d$ exist, s.t. @{term "gcd a d = 1"}.
  This number is exactly @{term "phi' d"}.

  Finally, by counting the fractions $m/n$ according to their reduced form denominator,
  we get: @{term [display] "(\<Sum>d | d dvd n . phi' d) = n"}.
  To formalize this proof in Isabelle, we analyze for an arbitrary divisor $d$ of $n$
  \begin{itemize}
    \item the set of reduced form numerators @{term "{a. (1::nat) \<le> a \<and> a \<le> d \<and> coprime a d}"}
    \item the set of numerators $m$, for which $m/n$ has the reduced form denominator $d$,
      i.e. the set @{term "{m \<in> {1::nat .. n}. n div gcd m n = d}"}
  \end{itemize}
  We show that @{term "\<lambda>a. a*n div d"} with the inverse @{term "\<lambda>a. a div gcd a n"} is
  a bijection between theses sets, thus yielding the equality
  @{term [display] "phi' d = card {m \<in> {1 .. n}. n div gcd m n = d}"}
  This gives us
  @{term [display] "(\<Sum>d | d dvd n . phi' d)
          = card (\<Union>d \<in> {d. d dvd n}. {m \<in> {1 .. n}. n div gcd m n = d})"}
  and by showing
  @{term "(\<Union>d \<in> {d. d dvd n}. {m \<in> {1::nat .. n}. n div gcd m n = d}) \<supseteq> {1 .. n}"}
  (this is our counting argument) the thesis follows.
\<close>
lemma sum_phi'_factors:
 fixes n :: nat
 assumes "n > 0"
 shows "(\<Sum>d | d dvd n. phi' d) = n"
proof -
  { fix d assume "d dvd n" then obtain q where q: "n = d * q" ..
    have "card {a. 1 \<le> a \<and> a \<le> d \<and> coprime a d} = card {m \<in> {1 .. n}.  n div gcd m n = d}"
         (is "card ?RF = card ?F")
    proof (rule card_bij_eq)
      { fix a b assume "a * n div d = b * n div d"
        hence "a * (n div d) = b * (n div d)"
          using dvd_div_mult[OF \<open>d dvd n\<close>] by (fastforce simp add: mult.commute)
        hence "a = b" using dvd_div_ge_1[OF _ \<open>d dvd n\<close>] \<open>n>0\<close>
          by (simp add: mult.commute nat_mult_eq_cancel1)
      } thus "inj_on (\<lambda>a. a*n div d) ?RF" unfolding inj_on_def by blast
      { fix a assume a:"a\<in>?RF"
        hence "a * (n div d) \<ge> 1" using \<open>n>0\<close> dvd_div_ge_1[OF _ \<open>d dvd n\<close>] by simp
        hence ge_1:"a * n div d \<ge> 1" by (simp add: \<open>d dvd n\<close> div_mult_swap)
        have le_n:"a * n div d \<le> n" using div_mult_mono a by simp
        have "gcd (a * n div d) n = n div d * gcd a d"
          by (simp add: gcd_mult_distrib_nat q ac_simps)
        hence "n div gcd (a * n div d) n = d*n div (d*(n div d))" using a by simp
        hence "a * n div d \<in> ?F"
          using ge_1 le_n by (fastforce simp add: \<open>d dvd n\<close>)
      } thus "(\<lambda>a. a*n div d) ` ?RF \<subseteq> ?F" by blast
      { fix m l assume A: "m \<in> ?F" "l \<in> ?F" "m div gcd m n = l div gcd l n"
        hence "gcd m n = gcd l n" using dvd_div_eq_2[OF assms] by fastforce
        hence "m = l" using dvd_div_eq_1[of "gcd m n" m l] A(3) by fastforce
      } thus "inj_on (\<lambda>a. a div gcd a n) ?F" unfolding inj_on_def by blast
      { fix m assume "m \<in> ?F"
        hence "m div gcd m n \<in> ?RF" using dvd_div_ge_1
          by (fastforce simp add: div_le_mono div_gcd_coprime)
      } thus "(\<lambda>a. a div gcd a n) ` ?F \<subseteq> ?RF" by blast
    qed force+
  } hence phi'_eq:"\<And>d. d dvd n \<Longrightarrow> phi' d = card {m \<in> {1 .. n}. n div gcd m n = d}"
      unfolding phi'_def by presburger
  have fin:"finite {d. d dvd n}" using dvd_nat_bounds[OF \<open>n>0\<close>] by force
  have "(\<Sum>d | d dvd n. phi' d)
                 = card (\<Union>d \<in> {d. d dvd n}. {m \<in> {1 .. n}. n div gcd m n = d})"
    using card_UN_disjoint[OF fin, of "(\<lambda>d. {m \<in> {1 .. n}. n div gcd m n = d})"] phi'_eq
    by fastforce
  also have "(\<Union>d \<in> {d. d dvd n}. {m \<in> {1 .. n}. n div gcd m n = d}) = {1 .. n}" (is "?L = ?R")
  proof
    show "?L \<supseteq> ?R"
    proof
      fix m assume m: "m \<in> ?R"
      thus "m \<in> ?L" using dvd_triv_right[of "n div gcd m n" "gcd m n"]
        by simp
    qed
  qed fastforce
  finally show ?thesis by force
qed

section \<open>Order of an Element of a Group\<close>
text_raw \<open>\label{sec:order-elem}\<close>

context group begin

lemma pow_eq_div2:
  fixes m n :: nat
  assumes x_car: "x \<in> carrier G"
  assumes pow_eq: "x [^] m = x [^] n"
  shows "x [^] (m - n) = \<one>"
proof (cases "m < n")
  case False
  have "\<one> \<otimes> x [^] m = x [^] m" by (simp add: x_car)
  also have "\<dots> = x [^] (m - n) \<otimes> x [^] n"
    using False by (simp add: nat_pow_mult x_car)
  also have "\<dots> = x [^] (m - n) \<otimes> x [^] m"
    by (simp add: pow_eq)
  finally show ?thesis by (simp add: x_car)
qed simp

definition ord where "ord a = Min {d \<in> {1 .. order G} . a [^] d = \<one>}"

lemma
  assumes finite:"finite (carrier G)"
  assumes a:"a \<in> carrier G"
  shows ord_ge_1: "1 \<le> ord a" and ord_le_group_order: "ord a \<le> order G"
    and pow_ord_eq_1: "a [^] ord a = \<one>"
proof -
  have "\<not>inj_on (\<lambda>x. a [^] x) {0 .. order G}"
  proof (rule notI)
    assume A: "inj_on (\<lambda>x. a [^] x) {0 .. order G}"
    have "order G + 1 = card {0 .. order G}" by simp
    also have "\<dots> = card ((\<lambda>x. a [^] x) ` {0 .. order G})" (is "_ = card ?S")
      using A by (simp add: card_image)
    also have "?S = {a [^] x | x. x \<in> {0 .. order G}}" by blast
    also have "\<dots> \<subseteq> carrier G" (is "?S \<subseteq> _") using a by blast
    then have "card ?S \<le> order G" unfolding order_def
      by (rule card_mono[OF finite])
    finally show False by arith
  qed

  then obtain x y where x_y:"x \<noteq> y" "x \<in> {0 .. order G}" "y \<in> {0 .. order G}"
                        "a [^] x = a [^] y" unfolding inj_on_def by blast
  obtain d where "1 \<le> d" "a [^] d = \<one>" "d \<le> order G"
  proof cases
    assume "y < x" with x_y show ?thesis
      by (intro that[where d="x - y"]) (auto simp add: pow_eq_div2[OF a])
  next
    assume "\<not>y < x" with x_y show ?thesis
      by (intro that[where d="y - x"]) (auto simp add: pow_eq_div2[OF a])
  qed
  hence "ord a \<in> {d \<in> {1 .. order G} . a [^] d = \<one>}"
    unfolding ord_def using Min_in[of "{d \<in> {1 .. order G} . a [^] d = \<one>}"]
    by fastforce
  then show "1 \<le> ord a" and "ord a \<le> order G" and "a [^] ord a = \<one>"
    by (auto simp: order_def)
qed

lemma finite_group_elem_finite_ord:
  assumes "finite (carrier G)" "x \<in> carrier G"
  shows "\<exists> d::nat. d \<ge> 1 \<and> x [^] d = \<one>"
  using assms ord_ge_1 pow_ord_eq_1 by auto

lemma ord_min:
  assumes  "finite (carrier G)" "1 \<le> d" "a \<in> carrier G" "a [^] d = \<one>" shows "ord a \<le> d"
proof -
  define Ord where "Ord = {d \<in> {1..order G}. a [^] d = \<one>}"
  have fin: "finite Ord" by (auto simp: Ord_def)
  have in_ord: "ord a \<in> Ord"
    using assms pow_ord_eq_1 ord_ge_1 ord_le_group_order by (auto simp: Ord_def)
  then have "Ord \<noteq> {}" by auto

  show ?thesis
  proof (cases "d \<le> order G")
    case True
    then have "d \<in> Ord" using assms by (auto simp: Ord_def)
    with fin in_ord show ?thesis
      unfolding ord_def Ord_def[symmetric] by simp
  next
    case False
    then show ?thesis using in_ord by (simp add: Ord_def)
  qed
qed

lemma ord_inj:
  assumes finite: "finite (carrier G)"
  assumes a: "a \<in> carrier G"
  shows "inj_on (\<lambda> x . a [^] x) {0 .. ord a - 1}"
proof (rule inj_onI, rule ccontr)
  fix x y assume A: "x \<in> {0 .. ord a - 1}" "y \<in> {0 .. ord a - 1}" "a [^] x= a [^] y" "x \<noteq> y"

  have "finite {d \<in> {1..order G}. a [^] d = \<one>}" by auto

  { fix x y assume A: "x < y" "x \<in> {0 .. ord a - 1}" "y \<in> {0 .. ord a - 1}"
        "a [^] x = a [^] y"
    hence "y - x < ord a" by auto
    also have "\<dots> \<le> order G" using assms by (simp add: ord_le_group_order)
    finally have y_x_range:"y - x \<in> {1 .. order G}" using A by force
    have "a [^] (y-x) = \<one>" using a A by (simp add: pow_eq_div2)

    hence y_x:"y - x \<in> {d \<in> {1.. order G}. a [^] d = \<one>}" using y_x_range by blast
    have "min (y - x) (ord a) = ord a"
      using Min.in_idem[OF \<open>finite {d \<in> {1 .. order G} . a [^] d = \<one>}\<close> y_x] ord_def by auto
    with \<open>y - x < ord a\<close> have False by linarith
  }
  note X = this

  { assume "x < y" with A X have False by blast }
  moreover
  { assume "x > y" with A X  have False by metis }
  moreover
  { assume "x = y" then have False using A by auto}
  ultimately
  show False by fastforce
qed

lemma ord_inj':
  assumes finite: "finite (carrier G)"
  assumes a: "a \<in> carrier G"
  shows "inj_on (\<lambda> x . a [^] x) {1 .. ord a}"
proof (rule inj_onI, rule ccontr)
  fix x y :: nat
  assume A:"x \<in> {1 .. ord a}" "y \<in> {1 .. ord a}" "a [^] x = a [^] y" "x\<noteq>y"
  { assume "x < ord a" "y < ord a"
    hence False using ord_inj[OF assms] A unfolding inj_on_def by fastforce
  }
  moreover
  { assume "x = ord a" "y < ord a"
    hence "a [^] y = a [^] (0::nat)" using pow_ord_eq_1[OF assms] A by auto
    hence "y=0" using ord_inj[OF assms] \<open>y < ord a\<close> unfolding inj_on_def by force
    hence False using A by fastforce
  }
  moreover
  { assume "y = ord a" "x < ord a"
    hence "a [^] x = a [^] (0::nat)" using pow_ord_eq_1[OF assms] A by auto
    hence "x=0" using ord_inj[OF assms] \<open>x < ord a\<close> unfolding inj_on_def by force
    hence False using A by fastforce
  }
  ultimately show False using A  by force
qed

lemma ord_elems:
  assumes "finite (carrier G)" "a \<in> carrier G"
  shows "{a[^]x | x. x \<in> (UNIV :: nat set)} = {a[^]x | x. x \<in> {0 .. ord a - 1}}" (is "?L = ?R")
proof
  show "?R \<subseteq> ?L" by blast
  { fix y assume "y \<in> ?L"
    then obtain x::nat where x:"y = a[^]x" by auto
    define r q where "r = x mod ord a" and "q = x div ord a"
    then have "x = q * ord a + r"
      by (simp add: div_mult_mod_eq)
    hence "y = (a[^]ord a)[^]q \<otimes> a[^]r"
      using x assms by (simp add: mult.commute nat_pow_mult nat_pow_pow)
    hence "y = a[^]r" using assms by (simp add: pow_ord_eq_1)
    have "r < ord a" using ord_ge_1[OF assms] by (simp add: r_def)
    hence "r \<in> {0 .. ord a - 1}" by (force simp: r_def)
    hence "y \<in> {a[^]x | x. x \<in> {0 .. ord a - 1}}" using \<open>y=a[^]r\<close> by blast
  }
  thus "?L \<subseteq> ?R" by auto
qed

(* Next three lemmas contributed by Paulo Emílio de Vilhena*)
lemma generate_pow_on_finite_carrier:
  assumes "finite (carrier G)" and "a \<in> carrier G"
  shows "generate G { a } = { a [^] k | k. k \<in> (UNIV :: nat set) }"
proof
  show "{ a [^] k | k. k \<in> (UNIV :: nat set) } \<subseteq> generate G { a }"
  proof
    fix b assume "b \<in> { a [^] k | k. k \<in> (UNIV :: nat set) }"
    then obtain k :: nat where "b = a [^] k" by blast
    hence "b = a [^] (int k)"
      using int_pow_def2 by auto
    thus "b \<in> generate G { a }"
      unfolding generate_pow[OF assms(2)] by blast
  qed
next
  show "generate G { a } \<subseteq> { a [^] k | k. k \<in> (UNIV :: nat set) }"
  proof
    fix b assume "b \<in> generate G { a }"
    then obtain k :: int where k: "b = a [^] k"
      unfolding generate_pow[OF assms(2)] by blast
    show "b \<in> { a [^] k | k. k \<in> (UNIV :: nat set) }"
    proof (cases "k < 0")
      assume "\<not> k < 0"
      hence "b = a [^] (nat k)"
        using k int_pow_def2 by auto
      thus ?thesis by blast
    next
      assume "k < 0"
      hence b: "b = inv (a [^] (nat (- k)))"
        using k int_pow_def2 by auto

      obtain m where m: "ord a * m \<ge> nat (- k)"
        by (metis assms mult.left_neutral mult_le_mono1 ord_ge_1)
      hence "a [^] (ord a * m) = \<one>"
        by (metis assms nat_pow_one nat_pow_pow pow_ord_eq_1)
      then obtain k' :: nat where "(a [^] (nat (- k))) \<otimes> (a [^] k') = \<one>"
        using m assms(2) nat_le_iff_add nat_pow_mult by auto
      hence "b = a [^] k'"
        using b assms(2) by (metis inv_unique' nat_pow_closed nat_pow_comm)
      thus "b \<in> { a [^] k | k. k \<in> (UNIV :: nat set) }" by blast
    qed
  qed
qed

lemma generate_pow_card:
  assumes "finite (carrier G)" and "a \<in> carrier G"
  shows "ord a = card (generate G { a })"
proof -
  have "generate G { a } = (([^]) a) ` {0..ord a - 1}"
    using generate_pow_on_finite_carrier[OF assms] unfolding ord_elems[OF assms] by auto
  thus ?thesis
    using ord_inj[OF assms] ord_ge_1[OF assms] by (simp add: card_image)
qed

(* This lemma was a suggestion of generalization given by Jeremy Avigad
   at the end of the theory FiniteProduct. *)
corollary power_order_eq_one_group_version:
  assumes "finite (carrier G)" and "a \<in> carrier G"
  shows "a [^] (order G) = \<one>"
proof -
  have "(ord a) dvd (order G)"
    using lagrange[OF generate_is_subgroup[of " { a }"]] assms(2)
    unfolding generate_pow_card[OF assms]
    by (metis dvd_triv_right empty_subsetI insert_subset)
  then obtain k :: nat where "order G = ord a * k" by blast
  thus ?thesis
    using assms(2) pow_ord_eq_1[OF assms] by (metis nat_pow_one nat_pow_pow)
qed

lemma ord_dvd_pow_eq_1 :
  assumes "finite (carrier G)" "a \<in> carrier G" "a [^] k = \<one>"
  shows "ord a dvd k"
proof -
  define r where "r = k mod ord a"

  define r q where "r = k mod ord a" and "q = k div ord a"
  then have q: "k = q * ord a + r"
    by (simp add: div_mult_mod_eq)
  hence "a[^]k = (a[^]ord a)[^]q \<otimes> a[^]r"
      using assms by (simp add: mult.commute nat_pow_mult nat_pow_pow)
  hence "a[^]k = a[^]r" using assms by (simp add: pow_ord_eq_1)
  hence "a[^]r = \<one>" using assms(3) by simp
  have "r < ord a" using ord_ge_1[OF assms(1-2)] by (simp add: r_def)
  hence "r = 0" using \<open>a[^]r = \<one>\<close> ord_def[of a] ord_min[of r a] assms(1-2) by linarith
  thus ?thesis using q by simp
qed

lemma dvd_gcd :
  fixes a b :: nat
  obtains q where "a * (b div gcd a b) = b*q"
proof
  have "a * (b div gcd a b) = (a div gcd a b) * b" by (simp add:  div_mult_swap dvd_div_mult)
  also have "\<dots> = b * (a div gcd a b)" by simp
  finally show "a * (b div gcd a b) = b * (a div gcd a b) " .
qed

lemma ord_pow_dvd_ord_elem :
  assumes finite[simp]: "finite (carrier G)"
  assumes a[simp]:"a \<in> carrier G"
  shows "ord (a[^]n) = ord a div gcd n (ord a)"
proof -
  have "(a[^]n) [^] ord a = (a [^] ord a) [^] n"
    by (simp add: mult.commute nat_pow_pow)
  hence "(a[^]n) [^] ord a = \<one>" by (simp add: pow_ord_eq_1)
  obtain q where "n * (ord a div gcd n (ord a)) = ord a * q" by (rule dvd_gcd)
  hence "(a[^]n) [^] (ord a div gcd n (ord a)) = (a [^] ord a)[^]q"  by (simp add : nat_pow_pow)
  hence pow_eq_1: "(a[^]n) [^] (ord a div gcd n (ord a)) = \<one>"
     by (auto simp add : pow_ord_eq_1[of a])
  have "ord a \<ge> 1" using ord_ge_1 by simp
  have ge_1:"ord a div gcd n (ord a) \<ge> 1"
  proof -
    have "gcd n (ord a) dvd ord a" by blast
    thus ?thesis by (rule dvd_div_ge_1[OF \<open>ord a \<ge> 1\<close>])
  qed
  have "ord a \<le> order G" by (simp add: ord_le_group_order)
  have "ord a div gcd n (ord a) \<le> order G"
  proof -
    have "ord a div gcd n (ord a) \<le> ord a" by simp
    thus ?thesis using \<open>ord a \<le> order G\<close> by linarith
  qed
  hence ord_gcd_elem:"ord a div gcd n (ord a) \<in> {d \<in> {1..order G}. (a[^]n) [^] d = \<one>}"
    using ge_1 pow_eq_1 by force
  { fix d :: nat
    assume d_elem:"d \<in> {d \<in> {1..order G}. (a[^]n) [^] d = \<one>}"
    assume d_lt:"d < ord a div gcd n (ord a)"
    hence pow_nd:"a[^](n*d)  = \<one>" using d_elem
      by (simp add : nat_pow_pow)
    hence "ord a dvd n*d" using assms by (auto simp add : ord_dvd_pow_eq_1)
    then obtain q where "ord a * q = n*d" by (metis dvd_mult_div_cancel)
    hence prod_eq:"(ord a div gcd n (ord a)) * q = (n div gcd n (ord a)) * d"
      by (simp add: dvd_div_mult)
    have cp:"coprime (ord a div gcd n (ord a)) (n div gcd n (ord a))"
    proof -
      have "coprime (n div gcd n (ord a)) (ord a div gcd n (ord a))"
        using div_gcd_coprime[of n "ord a"] ge_1 by fastforce
      thus ?thesis by (simp add: ac_simps)
    qed
    have dvd_d:"(ord a div gcd n (ord a)) dvd d"
    proof -
      have "ord a div gcd n (ord a) dvd (n div gcd n (ord a)) * d" using prod_eq
        by (metis dvd_triv_right mult.commute)
      hence "ord a div gcd n (ord a) dvd d * (n div gcd n (ord a))"
        by (simp add: mult.commute)
      then show ?thesis
        using cp by (simp add: coprime_dvd_mult_left_iff)
    qed
    have "d > 0" using d_elem by simp
    hence "ord a div gcd n (ord a) \<le> d" using dvd_d by (simp add : Nat.dvd_imp_le)
    hence False using d_lt by simp
  } hence ord_gcd_min: "\<And> d . d \<in> {d \<in> {1..order G}. (a[^]n) [^] d = \<one>}
                        \<Longrightarrow> d\<ge>ord a div gcd n (ord a)" by fastforce
  have fin:"finite {d \<in> {1..order G}. (a[^]n) [^] d = \<one>}" by auto
  thus ?thesis using Min_eqI[OF fin ord_gcd_min ord_gcd_elem]
    unfolding ord_def by simp
qed

lemma ord_1_eq_1 :
  assumes "finite (carrier G)"
  shows "ord \<one> = 1"
 using assms ord_ge_1 ord_min[of 1 \<one>] by force

lemma element_generates_subgroup:
  assumes finite[simp]: "finite (carrier G)"
  assumes a[simp]: "a \<in> carrier G"
  shows "subgroup {a [^] i | i. i \<in> {0 .. ord a - 1}} G"
  using generate_is_subgroup[of "{ a }"] assms(2)
        generate_pow_on_finite_carrier[OF assms]
  unfolding ord_elems[OF assms] by auto

lemma ord_dvd_group_order: (* <- DELETE *)
  assumes "finite (carrier G)" and "a \<in> carrier G"
  shows "(ord a) dvd (order G)"
  using lagrange[OF generate_is_subgroup[of " { a }"]] assms(2)
  unfolding generate_pow_card[OF assms]
  by (metis dvd_triv_right empty_subsetI insert_subset)

end

section \<open>Number of Roots of a Polynomial\<close>
text_raw \<open>\label{sec:number-roots}\<close>

definition mult_of :: "('a, 'b) ring_scheme \<Rightarrow> 'a monoid" where
  "mult_of R \<equiv> \<lparr> carrier = carrier R - {\<zero>\<^bsub>R\<^esub>}, mult = mult R, one = \<one>\<^bsub>R\<^esub>\<rparr>"

lemma carrier_mult_of [simp]: "carrier (mult_of R) = carrier R - {\<zero>\<^bsub>R\<^esub>}"
  by (simp add: mult_of_def)

lemma mult_mult_of [simp]: "mult (mult_of R) = mult R"
 by (simp add: mult_of_def)

lemma nat_pow_mult_of: "([^]\<^bsub>mult_of R\<^esub>) = (([^]\<^bsub>R\<^esub>) :: _ \<Rightarrow> nat \<Rightarrow> _)"
  by (simp add: mult_of_def fun_eq_iff nat_pow_def)

lemma one_mult_of [simp]: "\<one>\<^bsub>mult_of R\<^esub> = \<one>\<^bsub>R\<^esub>"
  by (simp add: mult_of_def)

lemmas mult_of_simps = carrier_mult_of mult_mult_of nat_pow_mult_of one_mult_of

context field
begin

lemma mult_of_is_Units: "mult_of R = units_of R"
  unfolding mult_of_def units_of_def using field_Units by auto

lemma m_inv_mult_of :
"\<And>x. x \<in> carrier (mult_of R) \<Longrightarrow> m_inv (mult_of R) x = m_inv R x"
  using mult_of_is_Units units_of_inv unfolding units_of_def
  by simp

lemma field_mult_group :
  shows "group (mult_of R)"
  apply (rule groupI)
  apply (auto simp: mult_of_simps m_assoc dest: integral)
  by (metis Diff_iff Units_inv_Units Units_l_inv field_Units singletonE)

lemma finite_mult_of: "finite (carrier R) \<Longrightarrow> finite (carrier (mult_of R))"
  by (auto simp: mult_of_simps)

lemma order_mult_of: "finite (carrier R) \<Longrightarrow> order (mult_of R) = order R - 1"
  unfolding order_def carrier_mult_of by (simp add: card.remove)

end

lemma (in monoid) Units_pow_closed :
  fixes d :: nat
  assumes "x \<in> Units G"
  shows "x [^] d \<in> Units G"
    by (metis assms group.is_monoid monoid.nat_pow_closed units_group units_of_carrier units_of_pow)

lemma (in comm_monoid) is_monoid:
  shows "monoid G" by unfold_locales

declare comm_monoid.is_monoid[intro?]

lemma (in ring) r_right_minus_eq[simp]:
  assumes "a \<in> carrier R" "b \<in> carrier R"
  shows "a \<ominus> b = \<zero> \<longleftrightarrow> a = b"
  using assms by (metis a_minus_def add.inv_closed minus_equality r_neg)

context UP_cring begin

lemma is_UP_cring:"UP_cring R" by (unfold_locales)
lemma is_UP_ring :
  shows "UP_ring R" by (unfold_locales)

end

context UP_domain begin

lemma roots_bound:
  assumes f [simp]: "f \<in> carrier P"
  assumes f_not_zero: "f \<noteq> \<zero>\<^bsub>P\<^esub>"
  assumes finite: "finite (carrier R)"
  shows "finite {a \<in> carrier R . eval R R id a f = \<zero>} \<and>
         card {a \<in> carrier R . eval R R id a f = \<zero>} \<le> deg R f" using f f_not_zero
proof (induction "deg R f" arbitrary: f)
  case 0
  have "\<And>x. eval R R id x f \<noteq> \<zero>"
  proof -
    fix x
    have "(\<Oplus>i\<in>{..deg R f}. id (coeff P f i) \<otimes> x [^] i) \<noteq> \<zero>"
      using 0 lcoeff_nonzero_nonzero[where p = f] by simp
    thus "eval R R id x f \<noteq> \<zero>" using 0 unfolding eval_def P_def by simp
  qed
  then have *: "{a \<in> carrier R. eval R R (\<lambda>a. a) a f = \<zero>} = {}"
    by (auto simp: id_def)
  show ?case by (simp add: *)
next
  case (Suc x)
  show ?case
  proof (cases "\<exists> a \<in> carrier R . eval R R id a f = \<zero>")
    case True
    then obtain a where a_carrier[simp]: "a \<in> carrier R" and a_root:"eval R R id a f = \<zero>" by blast
    have R_not_triv: "carrier R \<noteq> {\<zero>}"
      by (metis R.one_zeroI R.zero_not_one)
    obtain q  where q:"(q \<in> carrier P)" and
      f:"f = (monom P \<one>\<^bsub>R\<^esub> 1 \<ominus>\<^bsub> P\<^esub> monom P a 0) \<otimes>\<^bsub>P\<^esub> q \<oplus>\<^bsub>P\<^esub> monom P (eval R R id a f) 0"
     using remainder_theorem[OF Suc.prems(1) a_carrier R_not_triv] by auto
    hence lin_fac: "f = (monom P \<one>\<^bsub>R\<^esub> 1 \<ominus>\<^bsub> P\<^esub> monom P a 0) \<otimes>\<^bsub>P\<^esub> q" using q by (simp add: a_root)
    have deg:"deg R (monom P \<one>\<^bsub>R\<^esub> 1 \<ominus>\<^bsub> P\<^esub> monom P a 0) = 1"
      using a_carrier by (simp add: deg_minus_eq)
    hence mon_not_zero:"(monom P \<one>\<^bsub>R\<^esub> 1 \<ominus>\<^bsub> P\<^esub> monom P a 0) \<noteq> \<zero>\<^bsub>P\<^esub>"
      by (fastforce simp del: r_right_minus_eq)
    have q_not_zero:"q \<noteq> \<zero>\<^bsub>P\<^esub>" using Suc by (auto simp add : lin_fac)
    hence "deg R q = x" using Suc deg deg_mult[OF mon_not_zero q_not_zero _ q]
      by (simp add : lin_fac)
    hence q_IH:"finite {a \<in> carrier R . eval R R id a q = \<zero>}
                \<and> card {a \<in> carrier R . eval R R id a q = \<zero>} \<le> x" using Suc q q_not_zero by blast
    have subs:"{a \<in> carrier R . eval R R id a f = \<zero>}
                \<subseteq> {a \<in> carrier R . eval R R id a q = \<zero>} \<union> {a}" (is "?L \<subseteq> ?R \<union> {a}")
      using a_carrier \<open>q \<in> _\<close>
      by (auto simp: evalRR_simps lin_fac R.integral_iff)
    have "{a \<in> carrier R . eval R R id a f = \<zero>} \<subseteq> insert a {a \<in> carrier R . eval R R id a q = \<zero>}"
     using subs by auto
    hence "card {a \<in> carrier R . eval R R id a f = \<zero>} \<le>
           card (insert a {a \<in> carrier R . eval R R id a q = \<zero>})" using q_IH by (blast intro: card_mono)
    also have "\<dots> \<le> deg R f" using q_IH \<open>Suc x = _\<close>
      by (simp add: card_insert_if)
    finally show ?thesis using q_IH \<open>Suc x = _\<close> using finite by force
  next
    case False
    hence "card {a \<in> carrier R. eval R R id a f = \<zero>} = 0" using finite by auto
    also have "\<dots> \<le>  deg R f" by simp
    finally show ?thesis using finite by auto
  qed
qed

end

lemma (in domain) num_roots_le_deg :
  fixes p d :: nat
  assumes finite:"finite (carrier R)"
  assumes d_neq_zero : "d \<noteq> 0"
  shows "card {x \<in> carrier R. x [^] d = \<one>} \<le> d"
proof -
  let ?f = "monom (UP R) \<one>\<^bsub>R\<^esub> d \<ominus>\<^bsub> (UP R)\<^esub> monom (UP R) \<one>\<^bsub>R\<^esub> 0"
  have one_in_carrier:"\<one> \<in> carrier R" by simp
  interpret R: UP_domain R "UP R" by (unfold_locales)
  have "deg R ?f = d"
    using d_neq_zero by (simp add: R.deg_minus_eq)
  hence f_not_zero:"?f \<noteq> \<zero>\<^bsub>UP R\<^esub>" using  d_neq_zero by (auto simp add : R.deg_nzero_nzero)
  have roots_bound:"finite {a \<in> carrier R . eval R R id a ?f = \<zero>} \<and>
                    card {a \<in> carrier R . eval R R id a ?f = \<zero>} \<le> deg R ?f"
                    using finite by (intro R.roots_bound[OF _ f_not_zero]) simp
  have subs:"{x \<in> carrier R. x [^] d = \<one>} \<subseteq> {a \<in> carrier R . eval R R id a ?f = \<zero>}"
    by (auto simp: R.evalRR_simps)
  then have "card {x \<in> carrier R. x [^] d = \<one>} \<le>
        card {a \<in> carrier R. eval R R id a ?f = \<zero>}" using finite by (simp add : card_mono)
  thus ?thesis using \<open>deg R ?f = d\<close> roots_bound by linarith
qed

section \<open>The Multiplicative Group of a Field\<close>
text_raw \<open>\label{sec:mult-group}\<close>

text \<open>
  In this section we show that the multiplicative group of a finite field
  is generated by a single element, i.e. it is cyclic. The proof is inspired
  by the first proof given in the survey~@{cite "conrad-cyclicity"}.
\<close>

lemma (in group) pow_order_eq_1:
  assumes "finite (carrier G)" "x \<in> carrier G" shows "x [^] order G = \<one>"
  using assms by (metis nat_pow_pow ord_dvd_group_order pow_ord_eq_1 dvdE nat_pow_one)

(* XXX remove in AFP devel, replaced by div_eq_dividend_iff *)
lemma nat_div_eq: "a \<noteq> 0 \<Longrightarrow> (a :: nat) div b = a \<longleftrightarrow> b = 1"
  apply rule
  apply (cases "b = 0")
  apply simp_all
  apply (metis (full_types) One_nat_def Suc_lessI div_less_dividend less_not_refl3)
  done

lemma (in group)
  assumes finite': "finite (carrier G)"
  assumes "a \<in> carrier G"
  shows pow_ord_eq_ord_iff: "group.ord G (a [^] k) = ord a \<longleftrightarrow> coprime k (ord a)" (is "?L \<longleftrightarrow> ?R")
proof
  assume A: ?L then show ?R
    using assms ord_ge_1 [OF assms]
    by (auto simp: nat_div_eq ord_pow_dvd_ord_elem coprime_iff_gcd_eq_1)
next
  assume ?R then show ?L
    using ord_pow_dvd_ord_elem[OF assms, of k] by auto
qed

context field begin

lemma num_elems_of_ord_eq_phi':
  assumes finite: "finite (carrier R)" and dvd: "d dvd order (mult_of R)"
      and exists: "\<exists>a\<in>carrier (mult_of R). group.ord (mult_of R) a = d"
  shows "card {a \<in> carrier (mult_of R). group.ord (mult_of R) a = d} = phi' d"
proof -
  note mult_of_simps[simp]
  have finite': "finite (carrier (mult_of R))" using finite by (rule finite_mult_of)

  interpret G:group "mult_of R" rewrites "([^]\<^bsub>mult_of R\<^esub>) = (([^]) :: _ \<Rightarrow> nat \<Rightarrow> _)" and "\<one>\<^bsub>mult_of R\<^esub> = \<one>"
    by (rule field_mult_group) simp_all

  from exists
  obtain a where a:"a \<in> carrier (mult_of R)" and ord_a: "group.ord (mult_of R) a = d"
    by (auto simp add: card_gt_0_iff)

  have set_eq1:"{a[^]n| n. n \<in> {1 .. d}} = {x \<in> carrier (mult_of R). x [^] d = \<one>}"
  proof (rule card_seteq)
    show "finite {x \<in> carrier (mult_of R). x [^] d = \<one>}" using finite by auto

    show "{a[^]n| n. n \<in> {1 ..d}} \<subseteq> {x \<in> carrier (mult_of R). x[^]d = \<one>}"
    proof
      fix x assume "x \<in> {a[^]n | n. n \<in> {1 .. d}}"
      then obtain n where n:"x = a[^]n \<and> n \<in> {1 .. d}" by auto
      have "x[^]d =(a[^]d)[^]n" using n a ord_a by (simp add:nat_pow_pow mult.commute)
      hence "x[^]d = \<one>" using ord_a G.pow_ord_eq_1[OF finite' a] by fastforce
      thus "x \<in> {x \<in> carrier (mult_of R). x[^]d = \<one>}" using G.nat_pow_closed[OF a] n by blast
    qed

    show "card {x \<in> carrier (mult_of R). x [^] d = \<one>} \<le> card {a[^]n | n. n \<in> {1 .. d}}"
    proof -
      have *:"{a[^]n | n. n \<in> {1 .. d }} = ((\<lambda> n. a[^]n) ` {1 .. d})" by auto
      have "0 < order (mult_of R)" unfolding order_mult_of[OF finite]
        using card_mono[OF finite, of "{\<zero>, \<one>}"] by (simp add: order_def)
      have "card {x \<in> carrier (mult_of R). x [^] d = \<one>} \<le> card {x \<in> carrier R. x [^] d = \<one>}"
        using finite by (auto intro: card_mono)
      also have "\<dots> \<le> d" using \<open>0 < order (mult_of R)\<close> num_roots_le_deg[OF finite, of d]
        by (simp add : dvd_pos_nat[OF _ \<open>d dvd order (mult_of R)\<close>])
      finally show ?thesis using G.ord_inj'[OF finite' a] ord_a * by (simp add: card_image)
    qed
  qed

  have set_eq2:"{x \<in> carrier (mult_of R) . group.ord (mult_of R) x = d}
                = (\<lambda> n . a[^]n) ` {n \<in> {1 .. d}. group.ord (mult_of R) (a[^]n) = d}" (is "?L = ?R")
  proof
    { fix x assume x:"x \<in> (carrier (mult_of R)) \<and> group.ord (mult_of R) x = d"
      hence "x \<in> {x \<in> carrier (mult_of R). x [^] d = \<one>}"
        by (simp add: G.pow_ord_eq_1[OF finite', of x, symmetric])
      then obtain n where n:"x = a[^]n \<and> n \<in> {1 .. d}" using set_eq1 by blast
      hence "x \<in> ?R" using x by fast
    } thus "?L \<subseteq> ?R" by blast
    show "?R \<subseteq> ?L" using a by (auto simp add: carrier_mult_of[symmetric] simp del: carrier_mult_of)
  qed
  have "inj_on (\<lambda> n . a[^]n) {n \<in> {1 .. d}. group.ord (mult_of R) (a[^]n) = d}"
    using G.ord_inj'[OF finite' a, unfolded ord_a] unfolding inj_on_def by fast
  hence "card ((\<lambda>n. a[^]n) ` {n \<in> {1 .. d}. group.ord (mult_of R) (a[^]n) = d})
         = card {k \<in> {1 .. d}. group.ord (mult_of R) (a[^]k) = d}"
         using card_image by blast
  thus ?thesis using set_eq2 G.pow_ord_eq_ord_iff[OF finite' \<open>a \<in> _\<close>, unfolded ord_a]
    by (simp add: phi'_def)
qed

end

theorem (in field) finite_field_mult_group_has_gen :
  assumes finite:"finite (carrier R)"
  shows "\<exists> a \<in> carrier (mult_of R) . carrier (mult_of R) = {a[^]i | i::nat . i \<in> UNIV}"
proof -
  note mult_of_simps[simp]
  have finite': "finite (carrier (mult_of R))" using finite by (rule finite_mult_of)

  interpret G: group "mult_of R" rewrites
      "([^]\<^bsub>mult_of R\<^esub>) = (([^]) :: _ \<Rightarrow> nat \<Rightarrow> _)" and "\<one>\<^bsub>mult_of R\<^esub> = \<one>"
    by (rule field_mult_group) (simp_all add: fun_eq_iff nat_pow_def)

  let ?N = "\<lambda> x . card {a \<in> carrier (mult_of R). group.ord (mult_of R) a  = x}"
  have "0 < order R - 1" unfolding order_def using card_mono[OF finite, of "{\<zero>, \<one>}"] by simp
  then have *: "0 < order (mult_of R)" using assms by (simp add: order_mult_of)
  have fin: "finite {d. d dvd order (mult_of R) }" using dvd_nat_bounds[OF *] by force

  have "(\<Sum>d | d dvd order (mult_of R). ?N d)
      = card (UN d:{d . d dvd order (mult_of R) }. {a \<in> carrier (mult_of R). group.ord (mult_of R) a  = d})"
      (is "_ = card ?U")
    using fin finite by (subst card_UN_disjoint) auto
  also have "?U = carrier (mult_of R)"
  proof
    { fix x assume x:"x \<in> carrier (mult_of R)"
      hence x':"x\<in>carrier (mult_of R)" by simp
      then have "group.ord (mult_of R) x dvd order (mult_of R)"
          using finite' G.ord_dvd_group_order[OF _ x'] by (simp add: order_mult_of)
      hence "x \<in> ?U" using dvd_nat_bounds[of "order (mult_of R)" "group.ord (mult_of R) x"] x by blast
    } thus "carrier (mult_of R) \<subseteq> ?U" by blast
  qed auto
  also have "card ... = order (mult_of R)"
    using order_mult_of finite' by (simp add: order_def)
  finally have sum_Ns_eq: "(\<Sum>d | d dvd order (mult_of R). ?N d) = order (mult_of R)" .

  { fix d assume d:"d dvd order (mult_of R)"
    have "card {a \<in> carrier (mult_of R). group.ord (mult_of R) a = d} \<le> phi' d"
    proof cases
      assume "card {a \<in> carrier (mult_of R). group.ord (mult_of R) a = d} = 0" thus ?thesis by presburger
      next
      assume "card {a \<in> carrier (mult_of R). group.ord (mult_of R) a = d} \<noteq> 0"
      hence "\<exists>a \<in> carrier (mult_of R). group.ord (mult_of R) a = d" by (auto simp: card_eq_0_iff)
      thus ?thesis using num_elems_of_ord_eq_phi'[OF finite d] by auto
    qed
  }
  hence all_le:"\<And>i. i \<in> {d. d dvd order (mult_of R) }
        \<Longrightarrow> (\<lambda>i. card {a \<in> carrier (mult_of R). group.ord (mult_of R) a = i}) i \<le> (\<lambda>i. phi' i) i" by fast
  hence le:"(\<Sum>i | i dvd order (mult_of R). ?N i)
            \<le> (\<Sum>i | i dvd order (mult_of R). phi' i)"
            using sum_mono[of "{d .  d dvd order (mult_of R)}"
                  "\<lambda>i. card {a \<in> carrier (mult_of R). group.ord (mult_of R) a = i}"] by presburger
  have "order (mult_of R) = (\<Sum>d | d dvd order (mult_of R). phi' d)" using *
    by (simp add: sum_phi'_factors)
  hence eq:"(\<Sum>i | i dvd order (mult_of R). ?N i)
          = (\<Sum>i | i dvd order (mult_of R). phi' i)" using le sum_Ns_eq by presburger
  have "\<And>i. i \<in> {d. d dvd order (mult_of R) } \<Longrightarrow> ?N i = (\<lambda>i. phi' i) i"
  proof (rule ccontr)
    fix i
    assume i1:"i \<in> {d. d dvd order (mult_of R)}" and "?N i \<noteq> phi' i"
    hence "?N i = 0"
      using num_elems_of_ord_eq_phi'[OF finite, of i] by (auto simp: card_eq_0_iff)
    moreover  have "0 < i" using * i1 by (simp add: dvd_nat_bounds[of "order (mult_of R)" i])
    ultimately have "?N i < phi' i" using phi'_nonzero by presburger
    hence "(\<Sum>i | i dvd order (mult_of R). ?N i)
         < (\<Sum>i | i dvd order (mult_of R). phi' i)"
      using sum_strict_mono_ex1[OF fin, of "?N" "\<lambda> i . phi' i"]
            i1 all_le by auto
    thus False using eq by force
  qed
  hence "?N (order (mult_of R)) > 0" using * by (simp add: phi'_nonzero)
  then obtain a where a:"a \<in> carrier (mult_of R)" and a_ord:"group.ord (mult_of R) a = order (mult_of R)"
    by (auto simp add: card_gt_0_iff)
  hence set_eq:"{a[^]i | i::nat. i \<in> UNIV} = (\<lambda>x. a[^]x) ` {0 .. group.ord (mult_of R) a - 1}"
    using G.ord_elems[OF finite'] by auto
  have card_eq:"card ((\<lambda>x. a[^]x) ` {0 .. group.ord (mult_of R) a - 1}) = card {0 .. group.ord (mult_of R) a - 1}"
    by (intro card_image G.ord_inj finite' a)
  hence "card ((\<lambda> x . a[^]x) ` {0 .. group.ord (mult_of R) a - 1}) = card {0 ..order (mult_of R) - 1}"
    using assms by (simp add: card_eq a_ord)
  hence card_R_minus_1:"card {a[^]i | i::nat. i \<in> UNIV} =  order (mult_of R)"
    using * by (subst set_eq) auto
  have **:"{a[^]i | i::nat. i \<in> UNIV} \<subseteq> carrier (mult_of R)"
    using G.nat_pow_closed[OF a] by auto
  with _ have "carrier (mult_of R) = {a[^]i|i::nat. i \<in> UNIV}"
    by (rule card_seteq[symmetric]) (simp_all add: card_R_minus_1 finite order_def del: UNIV_I)
  thus ?thesis using a by blast
qed

end


theory RecursiveVDMNat
  imports VDMToolkit
begin

(*
primrec
  isafact :: "\<nat> \<Rightarrow> \<nat>"
  where
  "isafact n =
      (if n = 0 then 1 else n * (isafact (n-1)))" *)

primrec
  isafact :: "\<nat> \<Rightarrow> \<nat>"
  where
  "isafact 0 = 1"
| "isafact (Suc n) = Suc n * isafact n"

print_theorems

fun isafact' :: "\<nat> \<Rightarrow> \<nat>"
  where
  "isafact' n =(if n = 0 then 1 else n * (isafact' (n-1)))"

print_theorems

fun isafact'' :: "\<nat> \<Rightarrow> \<nat>"
  where
  "isafact'' 0 = 1"
| "isafact'' (Suc n) = Suc n * (isafact'' n)"

print_theorems

text \<open>VDM expressions with basic-typed (nat, int) variables (e.g. @{term \<open>x-y\<close>})
  have specific type widening rules (e.g. if both variables are nat, the result might be int).
  Therefore, in Isabelle VDM nats become @{typ VDMNat}, which are just a synonym for @{typ \<int>}.

  Isabelle recursive functions requires a proof obligation that parameters represent a
  constructive and compatible pattern, and that recursive calls terminate. Nevertheless,
  @{typ \<int>} in Isabelle is defined in terms of a pair of @{typ \<nat>}, hence recursion over @{typ \<int>}
  are involved. Given VDM needs to represent its nat variables as @{typ VDMNat} this will make
  VDM recursive functions in Isabelle involved as well.

  To give a concrete example, we define a recursive implementation of factorial in VDM
  translated to Isabelle as:

  \begin{vdmsl}
    factorial: nat -> nat
    factorial(n) == if n = 0 then 1 else n * factorial(n)
  	--@IsaMeasure( { (n -1, n) | n : nat & n <> 0 } )
    measure n;
  \end{vdmsl}

  For translation, we firt encode the implicit precondition of factorial that
  insists that the given parameter @{term n} is a @{typ VDMNat}
\<close>
definition
  pre_vdm_factorial :: \<open>VDMNat \<Rightarrow> \<bool>\<close>
  where
  \<open>pre_vdm_factorial n \<equiv> inv_VDMNat n\<close>

lemmas pre_vdm_factorial_defs = pre_vdm_factorial_def inv_VDMNat_def

(*
fun (domintros) vdm_factorial' :: \<open>VDMNat \<Rightarrow> VDMNat\<close>
  where
  \<open>vdm_factorial' n =
    (if pre_vdm_factorial n then
      (if n = 0 then
        1
      else
        n * (vdm_factorial' (n - 1))
      )
    else
      undefined)\<close>
*)

text \<open>Next, we define the factorial function through recursion, where
      when the precondition fails, we return @{term undefined}, which is
      a term that cannot be reasoned with in Isabelle (i.e. it's a dead end).
      Otherwise, we define factorial pretty much as in VDM.\<close>
function (domintros) vdm_factorial :: \<open>VDMNat \<Rightarrow> VDMNat\<close>
  where
  \<open>vdm_factorial n =
    (if pre_vdm_factorial n then
      (if n = 0 then
        1
      else
        n * (vdm_factorial (n - 1))
      )
    else
      undefined)\<close>
  text \<open>Pattern compatibility and completeness is discharged with the usual proof strategy in this case.
        In the general (more complex recursive call cases, e.g., Ackerman's function for instance), the
        user might have goals to discharge.\<close>
  by (pat_completeness, auto)

text \<open>Following the same strategy as before for sets, we define a relation representing
  the recursive and original call, respectively. The relation contains only input values
  that satisfy the precondition of factorial as well as the specific case which recursion occurs (e.g. @{term \<open>0 < n\<close>}).\<close>
abbreviation
  vdm_factorial_wf :: \<open>(VDMNat \<times> VDMNat) set\<close>
  where
  "vdm_factorial_wf \<equiv> { (n - 1, n) | n . n \<noteq> 0 \<and> pre_vdm_factorial n }"

text \<open>To make well foundedness proof easy, we reuse an already proved well founded
  relation for the integers, with the relation
  @{term int_ge_less_than}[display] which we start from @{term 0}, as defined by @{term gen_VDMNat_term}.
  This is quite similar to the strategy used for finite subsets with @{term finite_psubset}[display].

  Because @{term int_ge_less_than} is already well founded (e.g. @{thm wf_int_ge_less_than}[display]),
  the proof for our definition is trivial.\<close>
lemma l_vdm_factorial_term_wf: "wf (gen_VDMNat_term vdm_factorial_wf)"
  by (simp add: wf_int_ge_less_than wf_Int1)

text \<open>To mak sure our choice is valid (e.g. doesn't lead to the empty relation), we ensure
  that indeed the termination relation is in fact the same as the well founded predicate.\<close>
lemma l_vdm_factorial_term_valid: "(gen_VDMNat_term vdm_factorial_wf) = vdm_factorial_wf"
  apply (simp add: pre_vdm_factorial_defs)
  apply (intro equalityI subsetI)
   apply (simp_all add: int_ge_less_than_def case_prod_beta)
  by auto

text \<open>Finally, we prove termination using the previously proved lemmas using the @{method relation}.
  This simplifies the goal into well formedness of termination relation and that the precondition implies it,
  both of which are easily proved with simplification in this case.\<close>
termination
  apply (relation \<open>(gen_VDMNat_term vdm_factorial_wf)\<close>)
  using l_vdm_factorial_term_wf apply presburger
  by (simp add: pre_vdm_factorial_defs int_ge_less_than_def)

end


section \<open> Partial Injections \<close>

theory Partial_Inj
  imports Partial_Fun
begin

typedef ('a, 'b) pinj = "{f :: ('a, 'b) pfun. pfun_inj f}"
  morphisms pfun_of_pinj pinj_of_pfun
  by (auto intro: pfun_inj_empty)

lemma pinj_eq_pfun: "f = g \<longleftrightarrow> pfun_of_pinj f = pfun_of_pinj g"
  by (simp add: pfun_of_pinj_inject)

lemma pfun_inj_pinj [simp]: "pfun_inj (pfun_of_pinj f)"
  using pfun_of_pinj by auto

type_notation pinj (infixr "\<Zpinj>" 1)

setup_lifting type_definition_pinj

lift_definition pinv :: "'a \<Zpinj> 'b \<Rightarrow> 'b \<Zpinj> 'a" is pfun_inv
  by (simp add: pfun_inj_inv)

unbundle lattice_syntax

instantiation pinj :: (type, type) bot
begin
  lift_definition bot_pinj :: "('a, 'b) pinj" is "\<bottom>"
    by simp
instance ..
end

abbreviation pinj_empty :: "('a, 'b) pinj" ("{}\<^sub>\<rho>") where "{}\<^sub>\<rho> \<equiv> \<bottom>"

lift_definition pinj_app :: "('a, 'b) pinj \<Rightarrow> 'a \<Rightarrow> 'b" ("_'(_')\<^sub>\<rho>" [999,0] 999)
is "pfun_app" .

text \<open> Adding a maplet to a partial injection requires that we remove any other maplet that points
  to the value @{term v}, to preserve injectivity. \<close>

lift_definition pinj_upd :: "('a, 'b) pinj \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b) pinj"
is "\<lambda> f k v. pfun_upd (f \<rhd>\<^sub>p (- {v})) k v"
  by (simp add: pfun_inj_rres pfun_inj_upd)

lift_definition pidom :: "'a \<Zpinj> 'b \<Rightarrow> 'a set" is pdom .

lift_definition piran :: "'a \<Zpinj> 'b \<Rightarrow> 'b set" is pran .

lift_definition pinj_dres :: "'a set \<Rightarrow> ('a, 'b) pinj \<Rightarrow> ('a, 'b) pinj" (infixr "\<lhd>\<^sub>\<rho>" 85) is pdom_res
  by (simp add: pfun_inj_dres)

lift_definition pinj_rres :: "('a, 'b) pinj \<Rightarrow> 'b set \<Rightarrow> ('a, 'b) pinj" (infixl "\<rhd>\<^sub>\<rho>" 86) is pran_res
  by (simp add: pfun_inj_rres)

lift_definition pinj_comp :: "'b \<Zpinj> 'c \<Rightarrow> 'a \<Zpinj> 'b \<Rightarrow> 'a \<Zpinj> 'c" (infixl "\<circ>\<^sub>\<rho>" 55) is "(\<circ>\<^sub>p)"
  by (simp add: pfun_inj_comp)

syntax
  "_PinjUpd"  :: "[('a, 'b) pinj, maplets] => ('a, 'b) pinj" ("_'(_')\<^sub>\<rho>" [900,0]900)
  "_Pinj"     :: "maplets => ('a, 'b) pinj"            ("(1{_}\<^sub>\<rho>)")

translations
  "_PinjUpd m (_Maplets xy ms)"  == "_PinjUpd (_PinjUpd m xy) ms"
  "_PinjUpd m (_maplet  x y)"    == "CONST pinj_upd m x y"
  "_Pinj ms"                     => "_PinjUpd (CONST pempty) ms"
  "_Pinj (_Maplets ms1 ms2)"     <= "_PinjUpd (_Pinj ms1) ms2"
  "_Pinj ms"                     <= "_PinjUpd (CONST pempty) ms"

lemma pinj_app_upd [simp]: "(f(k \<mapsto> v)\<^sub>\<rho>)(x)\<^sub>\<rho> = (if (k = x) then v else (f \<rhd>\<^sub>\<rho> (-{v})) (x)\<^sub>\<rho>)"
  by (transfer, simp)

lemma pinj_eq_iff: "f = g \<longleftrightarrow> (pidom(f) = pidom(g) \<and> (\<forall> x\<in>pidom(f). f(x)\<^sub>\<rho> = g(x)\<^sub>\<rho>))"
  by (transfer, simp add: pfun_eq_iff)

lemma pinv_pempty [simp]: "pinv {}\<^sub>\<rho> = {}\<^sub>\<rho>"
  by (transfer, simp)

lemma pinv_pinj_upd [simp]: "pinv (f(x \<mapsto> y)\<^sub>\<rho>) = (pinv ((-{x}) \<lhd>\<^sub>\<rho> f))(y \<mapsto> x)\<^sub>\<rho>"
  by (transfer, subst pfun_inv_upd, simp_all add: pfun_inj_dres pfun_inj_rres  pfun_inv_rres pdres_rres_commute, simp add: pfun_inv_dres)

lemma pinv_pinv: "pinv (pinv f) = f"
  by (transfer, simp add: pfun_inj_inv_inv)

lemma pinv_pcomp: "pinv (f \<circ>\<^sub>\<rho> g) = pinv g \<circ>\<^sub>\<rho> pinv f"
  by (transfer, simp add: pfun_eq_graph pfun_graph_pfun_inv pfun_graph_comp pfun_inj_comp converse_relcomp)

lemmas pidom_empty [simp] = pdom_zero[Transfer.transferred]
lemma piran_zero [simp]: "piran {}\<^sub>\<rho> = {}" by (transfer, simp)

lemmas pinj_dres_empty [simp] = pdom_res_zero[Transfer.transferred]
lemmas pinj_rres_empty [simp] = pran_res_zero[Transfer.transferred]

lemmas pidom_res_empty [simp] = pdom_res_empty[Transfer.transferred]
lemmas piran_res_empty [simp] = pran_res_empty[Transfer.transferred]

lemma pidom_res_upd: "A \<lhd>\<^sub>\<rho> f(k \<mapsto> v)\<^sub>\<rho> = (if k \<in> A then (A \<lhd>\<^sub>\<rho> f)(k \<mapsto> v)\<^sub>\<rho> else A \<lhd>\<^sub>\<rho> (f \<rhd>\<^sub>\<rho> (- {v})))"
  by (transfer, simp, metis pdom_res_swap)

thm pdom_res_upd_out[Transfer.transferred]

lemma piran_res_upd: "f(x \<mapsto> v)\<^sub>\<rho> \<rhd>\<^sub>\<rho> A = (if v \<in> A then (f \<rhd>\<^sub>\<rho> A)(x \<mapsto> v)\<^sub>\<rho> else ((- {x}) \<lhd>\<^sub>\<rho> f) \<rhd>\<^sub>\<rho> A)"
  by (transfer, simp add: inf.commute)
     (metis (no_types, opaque_lifting) ComplI Compl_Un double_compl insert_absorb insert_is_Un pdom_res_swap pran_res_twice)

lemma pinj_upd_with_dres_rres: "((-{x}) \<lhd>\<^sub>\<rho> f \<rhd>\<^sub>\<rho> (-{y}))(x \<mapsto> y)\<^sub>\<rho> = f(x \<mapsto> y)\<^sub>\<rho>"
  by (transfer, simp add: pdom_res_swap)

lemma pidres_twice: "A \<lhd>\<^sub>\<rho> B \<lhd>\<^sub>\<rho> f = (A \<inter> B) \<lhd>\<^sub>\<rho> f"
  by (transfer, metis pdom_res_twice)

lemma pidres_commute: "A \<lhd>\<^sub>\<rho> B \<lhd>\<^sub>\<rho> f = B \<lhd>\<^sub>\<rho> A \<lhd>\<^sub>\<rho> f"
  by (metis (no_types, opaque_lifting) inf_commute pidres_twice)

lemma pidres_rres_commute: "A \<lhd>\<^sub>\<rho> (P \<rhd>\<^sub>\<rho> B) = (A \<lhd>\<^sub>\<rho> P) \<rhd>\<^sub>\<rho> B"
  by (transfer, simp, metis (mono_tags, opaque_lifting) pdres_rres_commute)

lemma pirres_twice: "f \<rhd>\<^sub>\<rho> A \<rhd>\<^sub>\<rho> B = f \<rhd>\<^sub>\<rho> (A \<inter> B)"
  by (transfer, metis (no_types, opaque_lifting) pran_res_twice)

lemma pirres_commute: "f \<rhd>\<^sub>\<rho> A \<rhd>\<^sub>\<rho> B = f \<rhd>\<^sub>\<rho> B \<rhd>\<^sub>\<rho> A"
  by (metis inf_commute pirres_twice)

lemma pidom_upd: "pidom (f(k \<mapsto> v)\<^sub>\<rho>) = insert k (pidom (f \<rhd>\<^sub>\<rho> (- {v})))"
  by (transfer, simp)

(* FIXME: Properly integrate using a proof strategy for coercion to partial injections *)

lemma f_pinv_f_apply: "x \<in> pran (pfun_of_pinj f) \<Longrightarrow> (pfun_of_pinj f)(pfun_of_pinj (pinv f) (x)\<^sub>p)\<^sub>p = x"
  by (transfer, simp add: f_pfun_inv_f_apply)

fun pinj_of_alist :: "('a \<times> 'b) list \<Rightarrow> 'a \<Zpinj> 'b" where
"pinj_of_alist [] = {}\<^sub>\<rho>" |
"pinj_of_alist (p # ps) = (pinj_of_alist ps)(fst p \<mapsto> snd p)\<^sub>\<rho>"

lemma pinj_empty_alist [code]: "{}\<^sub>\<rho> = pinj_of_alist []"
  by simp

lemma pinj_upd_alist [code]: "(pinj_of_alist xs)(k \<mapsto> v)\<^sub>\<rho> = pinj_of_alist ((k, v) # xs)"
  by simp

context begin

text \<open> Injective associative lists \<close>

definition ialist :: "('a \<times> 'b) list \<Rightarrow> bool" where
"ialist xs = (distinct (map fst xs) \<and> distinct (map snd xs))"

text \<open> Remove pairs where either the key or value appeared in a previous pair \<close>

qualified fun clearjunk :: "('a \<times> 'b) list \<Rightarrow> ('a \<times> 'b) list" where
"clearjunk [] = []" |
"clearjunk (p#ps) = p # filter (\<lambda> (k', v'). k' \<noteq> fst p \<and> v' \<noteq> snd p) (clearjunk ps)"

lemma ialist_clearjunk: "ialist (clearjunk xs)"
  by (induct xs rule:clearjunk.induct, auto simp add: ialist_def, (meson distinct_map_filter)+)

lemma ialist_clearjunk_fp: "ialist xs \<Longrightarrow> clearjunk xs = xs"
  by (induct xs, auto simp add: ialist_def filter_id_conv rev_image_eqI)

lemma clearjunk_idem [simp]: "clearjunk (clearjunk xs) = clearjunk xs"
  using ialist_clearjunk ialist_clearjunk_fp by blast

lemma pinj_of_alist_ndres: "k \<notin> fst ` set xs \<Longrightarrow> (-{k}) \<lhd>\<^sub>\<rho> (pinj_of_alist xs) = pinj_of_alist xs"
  by (induct xs, auto simp add: pidom_res_upd)

lemma pinj_of_alist_nrres: "v \<notin> snd ` set xs \<Longrightarrow> (pinj_of_alist xs) \<rhd>\<^sub>\<rho> (- {v}) = pinj_of_alist xs"
  by (induct xs, auto simp add: piran_res_upd)

lemma pidom_ialist: "ialist xs \<Longrightarrow> pidom (pinj_of_alist xs) = set (map fst xs)"
  by (induct xs, auto simp add: ialist_def pidom_upd)
     (metis (no_types, lifting) fst_conv image_eqI pinj_of_alist_nrres)+

lemma pinj_of_alist_filter_as_dres_rres:
  "ialist xs \<Longrightarrow> pinj_of_alist (filter (\<lambda>(k', v'). k' \<noteq> fst p \<and> v' \<noteq> snd p) xs) = (-{fst p}) \<lhd>\<^sub>\<rho> pinj_of_alist xs \<rhd>\<^sub>\<rho> (-{snd p})"
  by (induct xs rule: pinj_of_alist.induct)
     (auto simp add: ialist_def piran_res_upd pinj_of_alist_ndres pidom_res_upd
     ,metis (no_types, lifting) pinj_of_alist_nrres pirres_commute)

lemma pinj_of_alist_clearjunk: "pinj_of_alist (clearjunk xs) = pinj_of_alist xs"
  by (induct xs rule:clearjunk.induct, simp add: pinj_eq_iff)
     (simp add: ialist_clearjunk pinj_of_alist_filter_as_dres_rres pinj_upd_with_dres_rres)

lemma pinv_pinj_of_ialist:
  "ialist xs \<Longrightarrow> pinv (pinj_of_alist xs) = pinj_of_alist (map (\<lambda> (x, y). (y, x)) xs)"
  by (induct xs rule: pinj_of_alist.induct, auto simp add: ialist_def simp add: pinj_of_alist_ndres)

lemma pfun_of_ialist: "ialist xs \<Longrightarrow> pfun_of_pinj (pinj_of_alist xs) = pfun_of_alist xs"
  by (induct xs rule: pinj_of_alist.induct, auto simp add: bot_pinj.rep_eq ialist_def pinj_upd.rep_eq )
     (metis pinj_of_alist_nrres pinj_rres.rep_eq)

declare clearjunk.simps [simp del]

end

lemma pinv_pinj_of_alist [code]: "pinv (pinj_of_alist xs) = pinj_of_alist (map (\<lambda> (x, y). (y, x)) (Partial_Inj.clearjunk xs))"
  by (metis ialist_clearjunk pinj_of_alist_clearjunk pinv_pinj_of_ialist)

lemma pfun_of_pinj_of_alist [code]:
  "pfun_of_pinj (pinj_of_alist xs) = pfun_of_alist (Partial_Inj.clearjunk xs)"
  by (metis ialist_clearjunk pfun_of_ialist pinj_of_alist_clearjunk)

declare pinj_of_alist.simps [simp del]

unbundle no_lattice_syntax

end