theory Binomial_Coeffs
imports Complex_Main "HOL-Number_Theory.Fib"
begin

lemma choose_row_sum: "(\<Sum>k\<le>n. n choose k) = 2^n"
  using binomial [of 1 1 n] by (simp add: numeral_2_eq_2)

text\<open>sums of binomial coefficients.\<close>
lemma sum_choose_lower:
    "(\<Sum>k\<le>n. (r+k) choose k) = Suc (r+n) choose n"
  by (induction n) auto

lemma sum_choose_upper:
    "(\<Sum>k\<le>n. k choose m) = Suc n choose Suc m"
  by (induction n) auto

lemma sum_choose_diagonal:
  assumes "m\<le>n"
    shows "(\<Sum>k\<le>m. (n-k) choose (m-k)) = Suc n choose m"
proof -
  have "(\<Sum>k\<le>m. (n-k) choose (m-k)) = (\<Sum>k\<le>m. (n-m+k) choose k)"
    using sum.atLeastAtMost_rev [of "\<lambda>k. (n - k) choose (m - k)" 0 m]
    by (simp add: atMost_atLeast0 \<open>m\<le>n\<close>)
  also have "\<dots> = Suc (n-m+m) choose m"
    by (rule sum_choose_lower)
  also have "\<dots> = Suc n choose m" using assms
    by simp
  finally show ?thesis .
qed

lemma choose_mult_lemma:
  "((m+r+k) choose (m+k)) * ((m+k) choose k) = ((m+r+k) choose k) * ((m+r) choose m)"
  (is "?lhs = _")
proof -
  have "?lhs =
      fact(m+r+k) div (fact(m+k) * fact(m+r-m)) * (fact(m+k) div (fact k * fact m))"
    by (simp add: binomial_altdef_nat)
  also have "\<dots> = fact(m+r+k) * fact(m+k) div
                 (fact(m+k) * fact(m+r-m) * (fact k * fact m))"
    by (metis add_implies_diff add_le_mono1 choose_dvd diff_cancel2 div_mult_div_if_dvd
        le_add1 le_add2)
  also have "\<dots> = fact(m+r+k) div (fact r * (fact k * fact m))"
    by (auto simp: algebra_simps fact_fact_dvd_fact)
  also have "\<dots> = (fact(m+r+k) * fact(m+r)) div (fact r * (fact k * fact m) * fact(m+r))"
    by simp
  also have "\<dots> =
      (fact(m+r+k) div (fact k * fact(m+r)) * (fact(m+r) div (fact r * fact m)))"
    by (smt (verit) fact_fact_dvd_fact div_mult_div_if_dvd mult.assoc mult.commute)
  finally show ?thesis
    by (simp add: binomial_altdef_nat mult.commute)
qed

text \<open>The "Subset of a Subset" identity.\<close>
lemma choose_mult:
  "k \<le> m \<Longrightarrow> m \<le> n \<Longrightarrow> (n choose m) * (m choose k) = (n choose k) * ((n - k) choose (m - k))"
  using choose_mult_lemma [of "m-k" "n-m" k] by simp

text \<open>Concrete Mathematics, 5.18: "this formula is easily verified by induction on m"\<close>
lemma choose_row_sum_weighted:
  "(\<Sum>k\<le>m. (r choose k) * (r/2 - k)) = (Suc m)/2 * (r choose (Suc m))"
proof (induction m)
  case 0 show ?case by simp
next
  case (Suc m)
  have "(\<Sum>k\<le>Suc m. real (r choose k) * (r/2 - k))
      = ((r choose Suc m) * (r/2 - (Suc m))) + (Suc m) / 2 * (r choose Suc m)"
    by (simp add: Suc)
  also have "\<dots> = (r choose Suc m) * (real r - (Suc m)) / 2"
    by (simp add: field_simps)
  also have "\<dots> = Suc (Suc m) / 2 * (r choose Suc (Suc m))"
  proof (cases "r \<ge> Suc m")
    case True with binomial_absorb_comp[of r "Suc m"] show ?thesis
      by (metis binomial_absorption mult.commute of_nat_diff of_nat_mult times_divide_eq_left)
  qed (simp add: binomial_eq_0)
  finally show ?case .
qed

lemma sum_drop_zero: "(\<Sum>k\<le>Suc n. if 0<k then (f (k - 1)) else 0) = (\<Sum>j\<le>n. f j)"
  by (induction n) auto

lemma sum_choose_drop_zero:
  "(\<Sum>k\<le>Suc n. if k = 0 then 0 else (Suc n - k) choose (k - 1)) =
    (\<Sum>j\<le>n. (n-j) choose j)"
  by (rule trans [OF sum.cong sum_drop_zero]) auto

lemma ne_diagonal_fib:
   "(\<Sum>k\<le>n. (n-k) choose k) = fib (Suc n)"
proof (induction n rule: fib.induct)
  case 1 show ?case by simp
next
  case 2 show ?case by simp
next
  case (3 n)
  have "(\<Sum>k\<le>Suc n. Suc (Suc n) - k choose k) =
        (\<Sum>k\<le>Suc n. (Suc n - k choose k) + (if k=0 then 0 else (Suc n - k choose (k - 1))))"
    by (rule sum.cong) (simp_all add: choose_reduce_nat)
  also have "\<dots> = (\<Sum>k\<le>Suc n. Suc n - k choose k) +
                  (\<Sum>k\<le>Suc n. if k=0 then 0 else (Suc n - k choose (k - 1)))"
    by (simp add: sum.distrib)
  also have "\<dots> = (\<Sum>k\<le>Suc n. Suc n - k choose k) + (\<Sum>j\<le>n. n - j choose j)"
    by (metis sum_choose_drop_zero)
  finally show ?case using 3
    by simp
qed

end


(*  Title:      HOL/Fields.thy
    Author:     Gertrud Bauer
    Author:     Steven Obua
    Author:     Tobias Nipkow
    Author:     Lawrence C Paulson
    Author:     Markus Wenzel
    Author:     Jeremy Avigad
*)

section \<open>Fields\<close>

theory Fields
imports Nat
begin

subsection \<open>Division rings\<close>

text \<open>
  A division ring is like a field, but without the commutativity requirement.
\<close>

class inverse = divide +
  fixes inverse :: "'a \<Rightarrow> 'a"
begin

abbreviation inverse_divide :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"  (infixl "'/" 70)
where
  "inverse_divide \<equiv> divide"

end

text \<open>Setup for linear arithmetic prover\<close>

ML_file "~~/src/Provers/Arith/fast_lin_arith.ML"
ML_file "Tools/lin_arith.ML"
setup \<open>Lin_Arith.global_setup\<close>
declaration \<open>K Lin_Arith.setup\<close>

simproc_setup fast_arith_nat ("(m::nat) < n" | "(m::nat) \<le> n" | "(m::nat) = n") =
  \<open>K Lin_Arith.simproc\<close>
(* Because of this simproc, the arithmetic solver is really only
useful to detect inconsistencies among the premises for subgoals which are
*not* themselves (in)equalities, because the latter activate
fast_nat_arith_simproc anyway. However, it seems cheaper to activate the
solver all the time rather than add the additional check. *)

lemmas [arith_split] = nat_diff_split split_min split_max

text\<open>Lemmas \<open>divide_simps\<close> move division to the outside and eliminates them on (in)equalities.\<close>

named_theorems divide_simps "rewrite rules to eliminate divisions"

class division_ring = ring_1 + inverse +
  assumes left_inverse [simp]:  "a \<noteq> 0 \<Longrightarrow> inverse a * a = 1"
  assumes right_inverse [simp]: "a \<noteq> 0 \<Longrightarrow> a * inverse a = 1"
  assumes divide_inverse: "a / b = a * inverse b"
  assumes inverse_zero [simp]: "inverse 0 = 0"
begin

subclass ring_1_no_zero_divisors
proof
  fix a b :: 'a
  assume a: "a \<noteq> 0" and b: "b \<noteq> 0"
  show "a * b \<noteq> 0"
  proof
    assume ab: "a * b = 0"
    hence "0 = inverse a * (a * b) * inverse b" by simp
    also have "\<dots> = (inverse a * a) * (b * inverse b)"
      by (simp only: mult.assoc)
    also have "\<dots> = 1" using a b by simp
    finally show False by simp
  qed
qed

lemma nonzero_imp_inverse_nonzero:
  "a \<noteq> 0 \<Longrightarrow> inverse a \<noteq> 0"
proof
  assume ianz: "inverse a = 0"
  assume "a \<noteq> 0"
  hence "1 = a * inverse a" by simp
  also have "... = 0" by (simp add: ianz)
  finally have "1 = 0" .
  thus False by (simp add: eq_commute)
qed

lemma inverse_zero_imp_zero:
  "inverse a = 0 \<Longrightarrow> a = 0"
apply (rule classical)
apply (drule nonzero_imp_inverse_nonzero)
apply auto
done

lemma inverse_unique:
  assumes ab: "a * b = 1"
  shows "inverse a = b"
proof -
  have "a \<noteq> 0" using ab by (cases "a = 0") simp_all
  moreover have "inverse a * (a * b) = inverse a" by (simp add: ab)
  ultimately show ?thesis by (simp add: mult.assoc [symmetric])
qed

lemma nonzero_inverse_minus_eq:
  "a \<noteq> 0 \<Longrightarrow> inverse (- a) = - inverse a"
by (rule inverse_unique) simp

lemma nonzero_inverse_inverse_eq:
  "a \<noteq> 0 \<Longrightarrow> inverse (inverse a) = a"
by (rule inverse_unique) simp

lemma nonzero_inverse_eq_imp_eq:
  assumes "inverse a = inverse b" and "a \<noteq> 0" and "b \<noteq> 0"
  shows "a = b"
proof -
  from \<open>inverse a = inverse b\<close>
  have "inverse (inverse a) = inverse (inverse b)" by (rule arg_cong)
  with \<open>a \<noteq> 0\<close> and \<open>b \<noteq> 0\<close> show "a = b"
    by (simp add: nonzero_inverse_inverse_eq)
qed

lemma inverse_1 [simp]: "inverse 1 = 1"
by (rule inverse_unique) simp

lemma nonzero_inverse_mult_distrib:
  assumes "a \<noteq> 0" and "b \<noteq> 0"
  shows "inverse (a * b) = inverse b * inverse a"
proof -
  have "a * (b * inverse b) * inverse a = 1" using assms by simp
  hence "a * b * (inverse b * inverse a) = 1" by (simp only: mult.assoc)
  thus ?thesis by (rule inverse_unique)
qed

lemma division_ring_inverse_add:
  "a \<noteq> 0 \<Longrightarrow> b \<noteq> 0 \<Longrightarrow> inverse a + inverse b = inverse a * (a + b) * inverse b"
by (simp add: algebra_simps)

lemma division_ring_inverse_diff:
  "a \<noteq> 0 \<Longrightarrow> b \<noteq> 0 \<Longrightarrow> inverse a - inverse b = inverse a * (b - a) * inverse b"
by (simp add: algebra_simps)

lemma right_inverse_eq: "b \<noteq> 0 \<Longrightarrow> a / b = 1 \<longleftrightarrow> a = b"
proof
  assume neq: "b \<noteq> 0"
  {
    hence "a = (a / b) * b" by (simp add: divide_inverse mult.assoc)
    also assume "a / b = 1"
    finally show "a = b" by simp
  next
    assume "a = b"
    with neq show "a / b = 1" by (simp add: divide_inverse)
  }
qed

lemma nonzero_inverse_eq_divide: "a \<noteq> 0 \<Longrightarrow> inverse a = 1 / a"
by (simp add: divide_inverse)

lemma divide_self [simp]: "a \<noteq> 0 \<Longrightarrow> a / a = 1"
by (simp add: divide_inverse)

lemma inverse_eq_divide [field_simps, divide_simps]: "inverse a = 1 / a"
by (simp add: divide_inverse)

lemma add_divide_distrib: "(a+b) / c = a/c + b/c"
by (simp add: divide_inverse algebra_simps)

lemma times_divide_eq_right [simp]: "a * (b / c) = (a * b) / c"
  by (simp add: divide_inverse mult.assoc)

lemma minus_divide_left: "- (a / b) = (-a) / b"
  by (simp add: divide_inverse)

lemma nonzero_minus_divide_right: "b \<noteq> 0 ==> - (a / b) = a / (- b)"
  by (simp add: divide_inverse nonzero_inverse_minus_eq)

lemma nonzero_minus_divide_divide: "b \<noteq> 0 ==> (-a) / (-b) = a / b"
  by (simp add: divide_inverse nonzero_inverse_minus_eq)

lemma divide_minus_left [simp]: "(-a) / b = - (a / b)"
  by (simp add: divide_inverse)

lemma diff_divide_distrib: "(a - b) / c = a / c - b / c"
  using add_divide_distrib [of a "- b" c] by simp

lemma nonzero_eq_divide_eq [field_simps]: "c \<noteq> 0 \<Longrightarrow> a = b / c \<longleftrightarrow> a * c = b"
proof -
  assume [simp]: "c \<noteq> 0"
  have "a = b / c \<longleftrightarrow> a * c = (b / c) * c" by simp
  also have "... \<longleftrightarrow> a * c = b" by (simp add: divide_inverse mult.assoc)
  finally show ?thesis .
qed

lemma nonzero_divide_eq_eq [field_simps]: "c \<noteq> 0 \<Longrightarrow> b / c = a \<longleftrightarrow> b = a * c"
proof -
  assume [simp]: "c \<noteq> 0"
  have "b / c = a \<longleftrightarrow> (b / c) * c = a * c" by simp
  also have "... \<longleftrightarrow> b = a * c" by (simp add: divide_inverse mult.assoc)
  finally show ?thesis .
qed

lemma nonzero_neg_divide_eq_eq [field_simps]: "b \<noteq> 0 \<Longrightarrow> - (a / b) = c \<longleftrightarrow> - a = c * b"
  using nonzero_divide_eq_eq[of b "-a" c] by simp

lemma nonzero_neg_divide_eq_eq2 [field_simps]: "b \<noteq> 0 \<Longrightarrow> c = - (a / b) \<longleftrightarrow> c * b = - a"
  using nonzero_neg_divide_eq_eq[of b a c] by auto

lemma divide_eq_imp: "c \<noteq> 0 \<Longrightarrow> b = a * c \<Longrightarrow> b / c = a"
  by (simp add: divide_inverse mult.assoc)

lemma eq_divide_imp: "c \<noteq> 0 \<Longrightarrow> a * c = b \<Longrightarrow> a = b / c"
  by (drule sym) (simp add: divide_inverse mult.assoc)

lemma add_divide_eq_iff [field_simps]:
  "z \<noteq> 0 \<Longrightarrow> x + y / z = (x * z + y) / z"
  by (simp add: add_divide_distrib nonzero_eq_divide_eq)

lemma divide_add_eq_iff [field_simps]:
  "z \<noteq> 0 \<Longrightarrow> x / z + y = (x + y * z) / z"
  by (simp add: add_divide_distrib nonzero_eq_divide_eq)

lemma diff_divide_eq_iff [field_simps]:
  "z \<noteq> 0 \<Longrightarrow> x - y / z = (x * z - y) / z"
  by (simp add: diff_divide_distrib nonzero_eq_divide_eq eq_diff_eq)

lemma minus_divide_add_eq_iff [field_simps]:
  "z \<noteq> 0 \<Longrightarrow> - (x / z) + y = (- x + y * z) / z"
  by (simp add: add_divide_distrib diff_divide_eq_iff)

lemma divide_diff_eq_iff [field_simps]:
  "z \<noteq> 0 \<Longrightarrow> x / z - y = (x - y * z) / z"
  by (simp add: field_simps)

lemma minus_divide_diff_eq_iff [field_simps]:
  "z \<noteq> 0 \<Longrightarrow> - (x / z) - y = (- x - y * z) / z"
  by (simp add: divide_diff_eq_iff[symmetric])

lemma division_ring_divide_zero [simp]:
  "a / 0 = 0"
  by (simp add: divide_inverse)

lemma divide_self_if [simp]:
  "a / a = (if a = 0 then 0 else 1)"
  by simp

lemma inverse_nonzero_iff_nonzero [simp]:
  "inverse a = 0 \<longleftrightarrow> a = 0"
  by rule (fact inverse_zero_imp_zero, simp)

lemma inverse_minus_eq [simp]:
  "inverse (- a) = - inverse a"
proof cases
  assume "a=0" thus ?thesis by simp
next
  assume "a\<noteq>0"
  thus ?thesis by (simp add: nonzero_inverse_minus_eq)
qed

lemma inverse_inverse_eq [simp]:
  "inverse (inverse a) = a"
proof cases
  assume "a=0" thus ?thesis by simp
next
  assume "a\<noteq>0"
  thus ?thesis by (simp add: nonzero_inverse_inverse_eq)
qed

lemma inverse_eq_imp_eq:
  "inverse a = inverse b \<Longrightarrow> a = b"
  by (drule arg_cong [where f="inverse"], simp)

lemma inverse_eq_iff_eq [simp]:
  "inverse a = inverse b \<longleftrightarrow> a = b"
  by (force dest!: inverse_eq_imp_eq)

lemma add_divide_eq_if_simps [divide_simps]:
    "a + b / z = (if z = 0 then a else (a * z + b) / z)"
    "a / z + b = (if z = 0 then b else (a + b * z) / z)"
    "- (a / z) + b = (if z = 0 then b else (-a + b * z) / z)"
    "a - b / z = (if z = 0 then a else (a * z - b) / z)"
    "a / z - b = (if z = 0 then -b else (a - b * z) / z)"
    "- (a / z) - b = (if z = 0 then -b else (- a - b * z) / z)"
  by (simp_all add: add_divide_eq_iff divide_add_eq_iff diff_divide_eq_iff divide_diff_eq_iff
      minus_divide_diff_eq_iff)

lemma [divide_simps]:
  shows divide_eq_eq: "b / c = a \<longleftrightarrow> (if c \<noteq> 0 then b = a * c else a = 0)"
    and eq_divide_eq: "a = b / c \<longleftrightarrow> (if c \<noteq> 0 then a * c = b else a = 0)"
    and minus_divide_eq_eq: "- (b / c) = a \<longleftrightarrow> (if c \<noteq> 0 then - b = a * c else a = 0)"
    and eq_minus_divide_eq: "a = - (b / c) \<longleftrightarrow> (if c \<noteq> 0 then a * c = - b else a = 0)"
  by (auto simp add:  field_simps)

end

subsection \<open>Fields\<close>

class field = comm_ring_1 + inverse +
  assumes field_inverse: "a \<noteq> 0 \<Longrightarrow> inverse a * a = 1"
  assumes field_divide_inverse: "a / b = a * inverse b"
  assumes field_inverse_zero: "inverse 0 = 0"
begin

subclass division_ring
proof
  fix a :: 'a
  assume "a \<noteq> 0"
  thus "inverse a * a = 1" by (rule field_inverse)
  thus "a * inverse a = 1" by (simp only: mult.commute)
next
  fix a b :: 'a
  show "a / b = a * inverse b" by (rule field_divide_inverse)
next
  show "inverse 0 = 0"
    by (fact field_inverse_zero)
qed

subclass idom_divide
proof
  fix b a
  assume "b \<noteq> 0"
  then show "a * b / b = a"
    by (simp add: divide_inverse ac_simps)
next
  fix a
  show "a / 0 = 0"
    by (simp add: divide_inverse)
qed

text\<open>There is no slick version using division by zero.\<close>
lemma inverse_add:
  "a \<noteq> 0 \<Longrightarrow> b \<noteq> 0 \<Longrightarrow> inverse a + inverse b = (a + b) * inverse a * inverse b"
  by (simp add: division_ring_inverse_add ac_simps)

lemma nonzero_mult_divide_mult_cancel_left [simp]:
  assumes [simp]: "c \<noteq> 0"
  shows "(c * a) / (c * b) = a / b"
proof (cases "b = 0")
  case True then show ?thesis by simp
next
  case False
  then have "(c*a)/(c*b) = c * a * (inverse b * inverse c)"
    by (simp add: divide_inverse nonzero_inverse_mult_distrib)
  also have "... =  a * inverse b * (inverse c * c)"
    by (simp only: ac_simps)
  also have "... =  a * inverse b" by simp
    finally show ?thesis by (simp add: divide_inverse)
qed

lemma nonzero_mult_divide_mult_cancel_right [simp]:
  "c \<noteq> 0 \<Longrightarrow> (a * c) / (b * c) = a / b"
  using nonzero_mult_divide_mult_cancel_left [of c a b] by (simp add: ac_simps)

lemma times_divide_eq_left [simp]: "(b / c) * a = (b * a) / c"
  by (simp add: divide_inverse ac_simps)

lemma divide_inverse_commute: "a / b = inverse b * a"
  by (simp add: divide_inverse mult.commute)

lemma add_frac_eq:
  assumes "y \<noteq> 0" and "z \<noteq> 0"
  shows "x / y + w / z = (x * z + w * y) / (y * z)"
proof -
  have "x / y + w / z = (x * z) / (y * z) + (y * w) / (y * z)"
    using assms by simp
  also have "\<dots> = (x * z + y * w) / (y * z)"
    by (simp only: add_divide_distrib)
  finally show ?thesis
    by (simp only: mult.commute)
qed

text\<open>Special Cancellation Simprules for Division\<close>

lemma nonzero_divide_mult_cancel_right [simp]:
  "b \<noteq> 0 \<Longrightarrow> b / (a * b) = 1 / a"
  using nonzero_mult_divide_mult_cancel_right [of b 1 a] by simp

lemma nonzero_divide_mult_cancel_left [simp]:
  "a \<noteq> 0 \<Longrightarrow> a / (a * b) = 1 / b"
  using nonzero_mult_divide_mult_cancel_left [of a 1 b] by simp

lemma nonzero_mult_divide_mult_cancel_left2 [simp]:
  "c \<noteq> 0 \<Longrightarrow> (c * a) / (b * c) = a / b"
  using nonzero_mult_divide_mult_cancel_left [of c a b] by (simp add: ac_simps)

lemma nonzero_mult_divide_mult_cancel_right2 [simp]:
  "c \<noteq> 0 \<Longrightarrow> (a * c) / (c * b) = a / b"
  using nonzero_mult_divide_mult_cancel_right [of b c a] by (simp add: ac_simps)

lemma diff_frac_eq:
  "y \<noteq> 0 \<Longrightarrow> z \<noteq> 0 \<Longrightarrow> x / y - w / z = (x * z - w * y) / (y * z)"
  by (simp add: field_simps)

lemma frac_eq_eq:
  "y \<noteq> 0 \<Longrightarrow> z \<noteq> 0 \<Longrightarrow> (x / y = w / z) = (x * z = w * y)"
  by (simp add: field_simps)

lemma divide_minus1 [simp]: "x / - 1 = - x"
  using nonzero_minus_divide_right [of "1" x] by simp

text\<open>This version builds in division by zero while also re-orienting
      the right-hand side.\<close>
lemma inverse_mult_distrib [simp]:
  "inverse (a * b) = inverse a * inverse b"
proof cases
  assume "a \<noteq> 0 & b \<noteq> 0"
  thus ?thesis by (simp add: nonzero_inverse_mult_distrib ac_simps)
next
  assume "~ (a \<noteq> 0 & b \<noteq> 0)"
  thus ?thesis by force
qed

lemma inverse_divide [simp]:
  "inverse (a / b) = b / a"
  by (simp add: divide_inverse mult.commute)

text \<open>Calculations with fractions\<close>

text\<open>There is a whole bunch of simp-rules just for class \<open>field\<close> but none for class \<open>field\<close> and \<open>nonzero_divides\<close>
because the latter are covered by a simproc.\<close>

lemma mult_divide_mult_cancel_left:
  "c \<noteq> 0 \<Longrightarrow> (c * a) / (c * b) = a / b"
apply (cases "b = 0")
apply simp_all
done

lemma mult_divide_mult_cancel_right:
  "c \<noteq> 0 \<Longrightarrow> (a * c) / (b * c) = a / b"
apply (cases "b = 0")
apply simp_all
done

lemma divide_divide_eq_right [simp]:
  "a / (b / c) = (a * c) / b"
  by (simp add: divide_inverse ac_simps)

lemma divide_divide_eq_left [simp]:
  "(a / b) / c = a / (b * c)"
  by (simp add: divide_inverse mult.assoc)

lemma divide_divide_times_eq:
  "(x / y) / (z / w) = (x * w) / (y * z)"
  by simp

text \<open>Special Cancellation Simprules for Division\<close>

lemma mult_divide_mult_cancel_left_if [simp]:
  shows "(c * a) / (c * b) = (if c = 0 then 0 else a / b)"
  by simp

text \<open>Division and Unary Minus\<close>

lemma minus_divide_right:
  "- (a / b) = a / - b"
  by (simp add: divide_inverse)

lemma divide_minus_right [simp]:
  "a / - b = - (a / b)"
  by (simp add: divide_inverse)

lemma minus_divide_divide:
  "(- a) / (- b) = a / b"
apply (cases "b=0", simp)
apply (simp add: nonzero_minus_divide_divide)
done

lemma inverse_eq_1_iff [simp]:
  "inverse x = 1 \<longleftrightarrow> x = 1"
  by (insert inverse_eq_iff_eq [of x 1], simp)

lemma divide_eq_0_iff [simp]:
  "a / b = 0 \<longleftrightarrow> a = 0 \<or> b = 0"
  by (simp add: divide_inverse)

lemma divide_cancel_right [simp]:
  "a / c = b / c \<longleftrightarrow> c = 0 \<or> a = b"
  apply (cases "c=0", simp)
  apply (simp add: divide_inverse)
  done

lemma divide_cancel_left [simp]:
  "c / a = c / b \<longleftrightarrow> c = 0 \<or> a = b"
  apply (cases "c=0", simp)
  apply (simp add: divide_inverse)
  done

lemma divide_eq_1_iff [simp]:
  "a / b = 1 \<longleftrightarrow> b \<noteq> 0 \<and> a = b"
  apply (cases "b=0", simp)
  apply (simp add: right_inverse_eq)
  done

lemma one_eq_divide_iff [simp]:
  "1 = a / b \<longleftrightarrow> b \<noteq> 0 \<and> a = b"
  by (simp add: eq_commute [of 1])

lemma times_divide_times_eq:
  "(x / y) * (z / w) = (x * z) / (y * w)"
  by simp

lemma add_frac_num:
  "y \<noteq> 0 \<Longrightarrow> x / y + z = (x + z * y) / y"
  by (simp add: add_divide_distrib)

lemma add_num_frac:
  "y \<noteq> 0 \<Longrightarrow> z + x / y = (x + z * y) / y"
  by (simp add: add_divide_distrib add.commute)

end

class field_char_0 = field + ring_char_0

subsection \<open>Ordered fields\<close>

class field_abs_sgn = field + idom_abs_sgn
begin

lemma sgn_inverse [simp]:
  "sgn (inverse a) = inverse (sgn a)"
proof (cases "a = 0")
  case True then show ?thesis by simp
next
  case False
  then have "a * inverse a = 1"
    by simp
  then have "sgn (a * inverse a) = sgn 1"
    by simp
  then have "sgn a * sgn (inverse a) = 1"
    by (simp add: sgn_mult)
  then have "inverse (sgn a) * (sgn a * sgn (inverse a)) = inverse (sgn a) * 1"
    by simp
  then have "(inverse (sgn a) * sgn a) * sgn (inverse a) = inverse (sgn a)"
    by (simp add: ac_simps)
  with False show ?thesis
    by (simp add: sgn_eq_0_iff)
qed

lemma abs_inverse [simp]:
  "\<bar>inverse a\<bar> = inverse \<bar>a\<bar>"
proof -
  from sgn_mult_abs [of "inverse a"] sgn_mult_abs [of a]
  have "inverse (sgn a) * \<bar>inverse a\<bar> = inverse (sgn a * \<bar>a\<bar>)"
    by simp
  then show ?thesis by (auto simp add: sgn_eq_0_iff)
qed

lemma sgn_divide [simp]:
  "sgn (a / b) = sgn a / sgn b"
  unfolding divide_inverse sgn_mult by simp

lemma abs_divide [simp]:
  "\<bar>a / b\<bar> = \<bar>a\<bar> / \<bar>b\<bar>"
  unfolding divide_inverse abs_mult by simp

end

class linordered_field = field + linordered_idom
begin

lemma positive_imp_inverse_positive:
  assumes a_gt_0: "0 < a"
  shows "0 < inverse a"
proof -
  have "0 < a * inverse a"
    by (simp add: a_gt_0 [THEN less_imp_not_eq2])
  thus "0 < inverse a"
    by (simp add: a_gt_0 [THEN less_not_sym] zero_less_mult_iff)
qed

lemma negative_imp_inverse_negative:
  "a < 0 \<Longrightarrow> inverse a < 0"
  by (insert positive_imp_inverse_positive [of "-a"],
    simp add: nonzero_inverse_minus_eq less_imp_not_eq)

lemma inverse_le_imp_le:
  assumes invle: "inverse a \<le> inverse b" and apos: "0 < a"
  shows "b \<le> a"
proof (rule classical)
  assume "~ b \<le> a"
  hence "a < b"  by (simp add: linorder_not_le)
  hence bpos: "0 < b"  by (blast intro: apos less_trans)
  hence "a * inverse a \<le> a * inverse b"
    by (simp add: apos invle less_imp_le mult_left_mono)
  hence "(a * inverse a) * b \<le> (a * inverse b) * b"
    by (simp add: bpos less_imp_le mult_right_mono)
  thus "b \<le> a"  by (simp add: mult.assoc apos bpos less_imp_not_eq2)
qed

lemma inverse_positive_imp_positive:
  assumes inv_gt_0: "0 < inverse a" and nz: "a \<noteq> 0"
  shows "0 < a"
proof -
  have "0 < inverse (inverse a)"
    using inv_gt_0 by (rule positive_imp_inverse_positive)
  thus "0 < a"
    using nz by (simp add: nonzero_inverse_inverse_eq)
qed

lemma inverse_negative_imp_negative:
  assumes inv_less_0: "inverse a < 0" and nz: "a \<noteq> 0"
  shows "a < 0"
proof -
  have "inverse (inverse a) < 0"
    using inv_less_0 by (rule negative_imp_inverse_negative)
  thus "a < 0" using nz by (simp add: nonzero_inverse_inverse_eq)
qed

lemma linordered_field_no_lb:
  "\<forall>x. \<exists>y. y < x"
proof
  fix x::'a
  have m1: "- (1::'a) < 0" by simp
  from add_strict_right_mono[OF m1, where c=x]
  have "(- 1) + x < x" by simp
  thus "\<exists>y. y < x" by blast
qed

lemma linordered_field_no_ub:
  "\<forall> x. \<exists>y. y > x"
proof
  fix x::'a
  have m1: " (1::'a) > 0" by simp
  from add_strict_right_mono[OF m1, where c=x]
  have "1 + x > x" by simp
  thus "\<exists>y. y > x" by blast
qed

lemma less_imp_inverse_less:
  assumes less: "a < b" and apos:  "0 < a"
  shows "inverse b < inverse a"
proof (rule ccontr)
  assume "~ inverse b < inverse a"
  hence "inverse a \<le> inverse b" by simp
  hence "~ (a < b)"
    by (simp add: not_less inverse_le_imp_le [OF _ apos])
  thus False by (rule notE [OF _ less])
qed

lemma inverse_less_imp_less:
  "inverse a < inverse b \<Longrightarrow> 0 < a \<Longrightarrow> b < a"
apply (simp add: less_le [of "inverse a"] less_le [of "b"])
apply (force dest!: inverse_le_imp_le nonzero_inverse_eq_imp_eq)
done

text\<open>Both premises are essential. Consider -1 and 1.\<close>
lemma inverse_less_iff_less [simp]:
  "0 < a \<Longrightarrow> 0 < b \<Longrightarrow> inverse a < inverse b \<longleftrightarrow> b < a"
  by (blast intro: less_imp_inverse_less dest: inverse_less_imp_less)

lemma le_imp_inverse_le:
  "a \<le> b \<Longrightarrow> 0 < a \<Longrightarrow> inverse b \<le> inverse a"
  by (force simp add: le_less less_imp_inverse_less)

lemma inverse_le_iff_le [simp]:
  "0 < a \<Longrightarrow> 0 < b \<Longrightarrow> inverse a \<le> inverse b \<longleftrightarrow> b \<le> a"
  by (blast intro: le_imp_inverse_le dest: inverse_le_imp_le)

text\<open>These results refer to both operands being negative.  The opposite-sign
case is trivial, since inverse preserves signs.\<close>
lemma inverse_le_imp_le_neg:
  "inverse a \<le> inverse b \<Longrightarrow> b < 0 \<Longrightarrow> b \<le> a"
apply (rule classical)
apply (subgoal_tac "a < 0")
 prefer 2 apply force
apply (insert inverse_le_imp_le [of "-b" "-a"])
apply (simp add: nonzero_inverse_minus_eq)
done

lemma less_imp_inverse_less_neg:
   "a < b \<Longrightarrow> b < 0 \<Longrightarrow> inverse b < inverse a"
apply (subgoal_tac "a < 0")
 prefer 2 apply (blast intro: less_trans)
apply (insert less_imp_inverse_less [of "-b" "-a"])
apply (simp add: nonzero_inverse_minus_eq)
done

lemma inverse_less_imp_less_neg:
   "inverse a < inverse b \<Longrightarrow> b < 0 \<Longrightarrow> b < a"
apply (rule classical)
apply (subgoal_tac "a < 0")
 prefer 2
 apply force
apply (insert inverse_less_imp_less [of "-b" "-a"])
apply (simp add: nonzero_inverse_minus_eq)
done

lemma inverse_less_iff_less_neg [simp]:
  "a < 0 \<Longrightarrow> b < 0 \<Longrightarrow> inverse a < inverse b \<longleftrightarrow> b < a"
apply (insert inverse_less_iff_less [of "-b" "-a"])
apply (simp del: inverse_less_iff_less
            add: nonzero_inverse_minus_eq)
done

lemma le_imp_inverse_le_neg:
  "a \<le> b \<Longrightarrow> b < 0 ==> inverse b \<le> inverse a"
  by (force simp add: le_less less_imp_inverse_less_neg)

lemma inverse_le_iff_le_neg [simp]:
  "a < 0 \<Longrightarrow> b < 0 \<Longrightarrow> inverse a \<le> inverse b \<longleftrightarrow> b \<le> a"
  by (blast intro: le_imp_inverse_le_neg dest: inverse_le_imp_le_neg)

lemma one_less_inverse:
  "0 < a \<Longrightarrow> a < 1 \<Longrightarrow> 1 < inverse a"
  using less_imp_inverse_less [of a 1, unfolded inverse_1] .

lemma one_le_inverse:
  "0 < a \<Longrightarrow> a \<le> 1 \<Longrightarrow> 1 \<le> inverse a"
  using le_imp_inverse_le [of a 1, unfolded inverse_1] .

lemma pos_le_divide_eq [field_simps]:
  assumes "0 < c"
  shows "a \<le> b / c \<longleftrightarrow> a * c \<le> b"
proof -
  from assms have "a \<le> b / c \<longleftrightarrow> a * c \<le> (b / c) * c"
    using mult_le_cancel_right [of a c "b * inverse c"] by (auto simp add: field_simps)
  also have "... \<longleftrightarrow> a * c \<le> b"
    by (simp add: less_imp_not_eq2 [OF assms] divide_inverse mult.assoc)
  finally show ?thesis .
qed

lemma pos_less_divide_eq [field_simps]:
  assumes "0 < c"
  shows "a < b / c \<longleftrightarrow> a * c < b"
proof -
  from assms have "a < b / c \<longleftrightarrow> a * c < (b / c) * c"
    using mult_less_cancel_right [of a c "b / c"] by auto
  also have "... = (a*c < b)"
    by (simp add: less_imp_not_eq2 [OF assms] divide_inverse mult.assoc)
  finally show ?thesis .
qed

lemma neg_less_divide_eq [field_simps]:
  assumes "c < 0"
  shows "a < b / c \<longleftrightarrow> b < a * c"
proof -
  from assms have "a < b / c \<longleftrightarrow> (b / c) * c < a * c"
    using mult_less_cancel_right [of "b / c" c a] by auto
  also have "... \<longleftrightarrow> b < a * c"
    by (simp add: less_imp_not_eq [OF assms] divide_inverse mult.assoc)
  finally show ?thesis .
qed

lemma neg_le_divide_eq [field_simps]:
  assumes "c < 0"
  shows "a \<le> b / c \<longleftrightarrow> b \<le> a * c"
proof -
  from assms have "a \<le> b / c \<longleftrightarrow> (b / c) * c \<le> a * c"
    using mult_le_cancel_right [of "b * inverse c" c a] by (auto simp add: field_simps)
  also have "... \<longleftrightarrow> b \<le> a * c"
    by (simp add: less_imp_not_eq [OF assms] divide_inverse mult.assoc)
  finally show ?thesis .
qed

lemma pos_divide_le_eq [field_simps]:
  assumes "0 < c"
  shows "b / c \<le> a \<longleftrightarrow> b \<le> a * c"
proof -
  from assms have "b / c \<le> a \<longleftrightarrow> (b / c) * c \<le> a * c"
    using mult_le_cancel_right [of "b / c" c a] by auto
  also have "... \<longleftrightarrow> b \<le> a * c"
    by (simp add: less_imp_not_eq2 [OF assms] divide_inverse mult.assoc)
  finally show ?thesis .
qed

lemma pos_divide_less_eq [field_simps]:
  assumes "0 < c"
  shows "b / c < a \<longleftrightarrow> b < a * c"
proof -
  from assms have "b / c < a \<longleftrightarrow> (b / c) * c < a * c"
    using mult_less_cancel_right [of "b / c" c a] by auto
  also have "... \<longleftrightarrow> b < a * c"
    by (simp add: less_imp_not_eq2 [OF assms] divide_inverse mult.assoc)
  finally show ?thesis .
qed

lemma neg_divide_le_eq [field_simps]:
  assumes "c < 0"
  shows "b / c \<le> a \<longleftrightarrow> a * c \<le> b"
proof -
  from assms have "b / c \<le> a \<longleftrightarrow> a * c \<le> (b / c) * c"
    using mult_le_cancel_right [of a c "b / c"] by auto
  also have "... \<longleftrightarrow> a * c \<le> b"
    by (simp add: less_imp_not_eq [OF assms] divide_inverse mult.assoc)
  finally show ?thesis .
qed

lemma neg_divide_less_eq [field_simps]:
  assumes "c < 0"
  shows "b / c < a \<longleftrightarrow> a * c < b"
proof -
  from assms have "b / c < a \<longleftrightarrow> a * c < b / c * c"
    using mult_less_cancel_right [of a c "b / c"] by auto
  also have "... \<longleftrightarrow> a * c < b"
    by (simp add: less_imp_not_eq [OF assms] divide_inverse mult.assoc)
  finally show ?thesis .
qed

text\<open>The following \<open>field_simps\<close> rules are necessary, as minus is always moved atop of
division but we want to get rid of division.\<close>

lemma pos_le_minus_divide_eq [field_simps]: "0 < c \<Longrightarrow> a \<le> - (b / c) \<longleftrightarrow> a * c \<le> - b"
  unfolding minus_divide_left by (rule pos_le_divide_eq)

lemma neg_le_minus_divide_eq [field_simps]: "c < 0 \<Longrightarrow> a \<le> - (b / c) \<longleftrightarrow> - b \<le> a * c"
  unfolding minus_divide_left by (rule neg_le_divide_eq)

lemma pos_less_minus_divide_eq [field_simps]: "0 < c \<Longrightarrow> a < - (b / c) \<longleftrightarrow> a * c < - b"
  unfolding minus_divide_left by (rule pos_less_divide_eq)

lemma neg_less_minus_divide_eq [field_simps]: "c < 0 \<Longrightarrow> a < - (b / c) \<longleftrightarrow> - b < a * c"
  unfolding minus_divide_left by (rule neg_less_divide_eq)

lemma pos_minus_divide_less_eq [field_simps]: "0 < c \<Longrightarrow> - (b / c) < a \<longleftrightarrow> - b < a * c"
  unfolding minus_divide_left by (rule pos_divide_less_eq)

lemma neg_minus_divide_less_eq [field_simps]: "c < 0 \<Longrightarrow> - (b / c) < a \<longleftrightarrow> a * c < - b"
  unfolding minus_divide_left by (rule neg_divide_less_eq)

lemma pos_minus_divide_le_eq [field_simps]: "0 < c \<Longrightarrow> - (b / c) \<le> a \<longleftrightarrow> - b \<le> a * c"
  unfolding minus_divide_left by (rule pos_divide_le_eq)

lemma neg_minus_divide_le_eq [field_simps]: "c < 0 \<Longrightarrow> - (b / c) \<le> a \<longleftrightarrow> a * c \<le> - b"
  unfolding minus_divide_left by (rule neg_divide_le_eq)

lemma frac_less_eq:
  "y \<noteq> 0 \<Longrightarrow> z \<noteq> 0 \<Longrightarrow> x / y < w / z \<longleftrightarrow> (x * z - w * y) / (y * z) < 0"
  by (subst less_iff_diff_less_0) (simp add: diff_frac_eq )

lemma frac_le_eq:
  "y \<noteq> 0 \<Longrightarrow> z \<noteq> 0 \<Longrightarrow> x / y \<le> w / z \<longleftrightarrow> (x * z - w * y) / (y * z) \<le> 0"
  by (subst le_iff_diff_le_0) (simp add: diff_frac_eq )

text\<open>Lemmas \<open>sign_simps\<close> is a first attempt to automate proofs
of positivity/negativity needed for \<open>field_simps\<close>. Have not added \<open>sign_simps\<close> to \<open>field_simps\<close> because the former can lead to case
explosions.\<close>

lemmas sign_simps = algebra_simps zero_less_mult_iff mult_less_0_iff

lemmas (in -) sign_simps = algebra_simps zero_less_mult_iff mult_less_0_iff

(* Only works once linear arithmetic is installed:
text{*An example:*}
lemma fixes a b c d e f :: "'a::linordered_field"
shows "\<lbrakk>a>b; c<d; e<f; 0 < u \<rbrakk> \<Longrightarrow>
 ((a-b)*(c-d)*(e-f))/((c-d)*(e-f)*(a-b)) <
 ((e-f)*(a-b)*(c-d))/((e-f)*(a-b)*(c-d)) + u"
apply(subgoal_tac "(c-d)*(e-f)*(a-b) > 0")
 prefer 2 apply(simp add:sign_simps)
apply(subgoal_tac "(c-d)*(e-f)*(a-b)*u > 0")
 prefer 2 apply(simp add:sign_simps)
apply(simp add:field_simps)
done
*)

lemma divide_pos_pos[simp]:
  "0 < x ==> 0 < y ==> 0 < x / y"
by(simp add:field_simps)

lemma divide_nonneg_pos:
  "0 <= x ==> 0 < y ==> 0 <= x / y"
by(simp add:field_simps)

lemma divide_neg_pos:
  "x < 0 ==> 0 < y ==> x / y < 0"
by(simp add:field_simps)

lemma divide_nonpos_pos:
  "x <= 0 ==> 0 < y ==> x / y <= 0"
by(simp add:field_simps)

lemma divide_pos_neg:
  "0 < x ==> y < 0 ==> x / y < 0"
by(simp add:field_simps)

lemma divide_nonneg_neg:
  "0 <= x ==> y < 0 ==> x / y <= 0"
by(simp add:field_simps)

lemma divide_neg_neg:
  "x < 0 ==> y < 0 ==> 0 < x / y"
by(simp add:field_simps)

lemma divide_nonpos_neg:
  "x <= 0 ==> y < 0 ==> 0 <= x / y"
by(simp add:field_simps)

lemma divide_strict_right_mono:
     "[|a < b; 0 < c|] ==> a / c < b / c"
by (simp add: less_imp_not_eq2 divide_inverse mult_strict_right_mono
              positive_imp_inverse_positive)

lemma divide_strict_right_mono_neg:
     "[|b < a; c < 0|] ==> a / c < b / c"
apply (drule divide_strict_right_mono [of _ _ "-c"], simp)
apply (simp add: less_imp_not_eq nonzero_minus_divide_right [symmetric])
done

text\<open>The last premise ensures that @{term a} and @{term b}
      have the same sign\<close>
lemma divide_strict_left_mono:
  "[|b < a; 0 < c; 0 < a*b|] ==> c / a < c / b"
  by (auto simp: field_simps zero_less_mult_iff mult_strict_right_mono)

lemma divide_left_mono:
  "[|b \<le> a; 0 \<le> c; 0 < a*b|] ==> c / a \<le> c / b"
  by (auto simp: field_simps zero_less_mult_iff mult_right_mono)

lemma divide_strict_left_mono_neg:
  "[|a < b; c < 0; 0 < a*b|] ==> c / a < c / b"
  by (auto simp: field_simps zero_less_mult_iff mult_strict_right_mono_neg)

lemma mult_imp_div_pos_le: "0 < y ==> x <= z * y ==>
    x / y <= z"
by (subst pos_divide_le_eq, assumption+)

lemma mult_imp_le_div_pos: "0 < y ==> z * y <= x ==>
    z <= x / y"
by(simp add:field_simps)

lemma mult_imp_div_pos_less: "0 < y ==> x < z * y ==>
    x / y < z"
by(simp add:field_simps)

lemma mult_imp_less_div_pos: "0 < y ==> z * y < x ==>
    z < x / y"
by(simp add:field_simps)

lemma frac_le: "0 <= x ==>
    x <= y ==> 0 < w ==> w <= z  ==> x / z <= y / w"
  apply (rule mult_imp_div_pos_le)
  apply simp
  apply (subst times_divide_eq_left)
  apply (rule mult_imp_le_div_pos, assumption)
  apply (rule mult_mono)
  apply simp_all
done

lemma frac_less: "0 <= x ==>
    x < y ==> 0 < w ==> w <= z  ==> x / z < y / w"
  apply (rule mult_imp_div_pos_less)
  apply simp
  apply (subst times_divide_eq_left)
  apply (rule mult_imp_less_div_pos, assumption)
  apply (erule mult_less_le_imp_less)
  apply simp_all
done

lemma frac_less2: "0 < x ==>
    x <= y ==> 0 < w ==> w < z  ==> x / z < y / w"
  apply (rule mult_imp_div_pos_less)
  apply simp_all
  apply (rule mult_imp_less_div_pos, assumption)
  apply (erule mult_le_less_imp_less)
  apply simp_all
done

lemma less_half_sum: "a < b ==> a < (a+b) / (1+1)"
by (simp add: field_simps zero_less_two)

lemma gt_half_sum: "a < b ==> (a+b)/(1+1) < b"
by (simp add: field_simps zero_less_two)

subclass unbounded_dense_linorder
proof
  fix x y :: 'a
  from less_add_one show "\<exists>y. x < y" ..
  from less_add_one have "x + (- 1) < (x + 1) + (- 1)" by (rule add_strict_right_mono)
  then have "x - 1 < x + 1 - 1" by simp
  then have "x - 1 < x" by (simp add: algebra_simps)
  then show "\<exists>y. y < x" ..
  show "x < y \<Longrightarrow> \<exists>z>x. z < y" by (blast intro!: less_half_sum gt_half_sum)
qed

subclass field_abs_sgn ..

lemma inverse_sgn [simp]:
  "inverse (sgn a) = sgn a"
  by (cases a 0 rule: linorder_cases) simp_all

lemma divide_sgn [simp]:
  "a / sgn b = a * sgn b"
  by (cases b 0 rule: linorder_cases) simp_all

lemma nonzero_abs_inverse:
  "a \<noteq> 0 ==> \<bar>inverse a\<bar> = inverse \<bar>a\<bar>"
  by (rule abs_inverse)

lemma nonzero_abs_divide:
  "b \<noteq> 0 ==> \<bar>a / b\<bar> = \<bar>a\<bar> / \<bar>b\<bar>"
  by (rule abs_divide)

lemma field_le_epsilon:
  assumes e: "\<And>e. 0 < e \<Longrightarrow> x \<le> y + e"
  shows "x \<le> y"
proof (rule dense_le)
  fix t assume "t < x"
  hence "0 < x - t" by (simp add: less_diff_eq)
  from e [OF this] have "x + 0 \<le> x + (y - t)" by (simp add: algebra_simps)
  then have "0 \<le> y - t" by (simp only: add_le_cancel_left)
  then show "t \<le> y" by (simp add: algebra_simps)
qed

lemma inverse_positive_iff_positive [simp]:
  "(0 < inverse a) = (0 < a)"
apply (cases "a = 0", simp)
apply (blast intro: inverse_positive_imp_positive positive_imp_inverse_positive)
done

lemma inverse_negative_iff_negative [simp]:
  "(inverse a < 0) = (a < 0)"
apply (cases "a = 0", simp)
apply (blast intro: inverse_negative_imp_negative negative_imp_inverse_negative)
done

lemma inverse_nonnegative_iff_nonnegative [simp]:
  "0 \<le> inverse a \<longleftrightarrow> 0 \<le> a"
  by (simp add: not_less [symmetric])

lemma inverse_nonpositive_iff_nonpositive [simp]:
  "inverse a \<le> 0 \<longleftrightarrow> a \<le> 0"
  by (simp add: not_less [symmetric])

lemma one_less_inverse_iff: "1 < inverse x \<longleftrightarrow> 0 < x \<and> x < 1"
  using less_trans[of 1 x 0 for x]
  by (cases x 0 rule: linorder_cases) (auto simp add: field_simps)

lemma one_le_inverse_iff: "1 \<le> inverse x \<longleftrightarrow> 0 < x \<and> x \<le> 1"
proof (cases "x = 1")
  case True then show ?thesis by simp
next
  case False then have "inverse x \<noteq> 1" by simp
  then have "1 \<noteq> inverse x" by blast
  then have "1 \<le> inverse x \<longleftrightarrow> 1 < inverse x" by (simp add: le_less)
  with False show ?thesis by (auto simp add: one_less_inverse_iff)
qed

lemma inverse_less_1_iff: "inverse x < 1 \<longleftrightarrow> x \<le> 0 \<or> 1 < x"
  by (simp add: not_le [symmetric] one_le_inverse_iff)

lemma inverse_le_1_iff: "inverse x \<le> 1 \<longleftrightarrow> x \<le> 0 \<or> 1 \<le> x"
  by (simp add: not_less [symmetric] one_less_inverse_iff)

lemma [divide_simps]:
  shows le_divide_eq: "a \<le> b / c \<longleftrightarrow> (if 0 < c then a * c \<le> b else if c < 0 then b \<le> a * c else a \<le> 0)"
    and divide_le_eq: "b / c \<le> a \<longleftrightarrow> (if 0 < c then b \<le> a * c else if c < 0 then a * c \<le> b else 0 \<le> a)"
    and less_divide_eq: "a < b / c \<longleftrightarrow> (if 0 < c then a * c < b else if c < 0 then b < a * c else a < 0)"
    and divide_less_eq: "b / c < a \<longleftrightarrow> (if 0 < c then b < a * c else if c < 0 then a * c < b else 0 < a)"
    and le_minus_divide_eq: "a \<le> - (b / c) \<longleftrightarrow> (if 0 < c then a * c \<le> - b else if c < 0 then - b \<le> a * c else a \<le> 0)"
    and minus_divide_le_eq: "- (b / c) \<le> a \<longleftrightarrow> (if 0 < c then - b \<le> a * c else if c < 0 then a * c \<le> - b else 0 \<le> a)"
    and less_minus_divide_eq: "a < - (b / c) \<longleftrightarrow> (if 0 < c then a * c < - b else if c < 0 then - b < a * c else  a < 0)"
    and minus_divide_less_eq: "- (b / c) < a \<longleftrightarrow> (if 0 < c then - b < a * c else if c < 0 then a * c < - b else 0 < a)"
  by (auto simp: field_simps not_less dest: antisym)

text \<open>Division and Signs\<close>

lemma
  shows zero_less_divide_iff: "0 < a / b \<longleftrightarrow> 0 < a \<and> 0 < b \<or> a < 0 \<and> b < 0"
    and divide_less_0_iff: "a / b < 0 \<longleftrightarrow> 0 < a \<and> b < 0 \<or> a < 0 \<and> 0 < b"
    and zero_le_divide_iff: "0 \<le> a / b \<longleftrightarrow> 0 \<le> a \<and> 0 \<le> b \<or> a \<le> 0 \<and> b \<le> 0"
    and divide_le_0_iff: "a / b \<le> 0 \<longleftrightarrow> 0 \<le> a \<and> b \<le> 0 \<or> a \<le> 0 \<and> 0 \<le> b"
  by (auto simp add: divide_simps)

text \<open>Division and the Number One\<close>

text\<open>Simplify expressions equated with 1\<close>

lemma zero_eq_1_divide_iff [simp]: "0 = 1 / a \<longleftrightarrow> a = 0"
  by (cases "a = 0") (auto simp: field_simps)

lemma one_divide_eq_0_iff [simp]: "1 / a = 0 \<longleftrightarrow> a = 0"
  using zero_eq_1_divide_iff[of a] by simp

text\<open>Simplify expressions such as \<open>0 < 1/x\<close> to \<open>0 < x\<close>\<close>

lemma zero_le_divide_1_iff [simp]:
  "0 \<le> 1 / a \<longleftrightarrow> 0 \<le> a"
  by (simp add: zero_le_divide_iff)

lemma zero_less_divide_1_iff [simp]:
  "0 < 1 / a \<longleftrightarrow> 0 < a"
  by (simp add: zero_less_divide_iff)

lemma divide_le_0_1_iff [simp]:
  "1 / a \<le> 0 \<longleftrightarrow> a \<le> 0"
  by (simp add: divide_le_0_iff)

lemma divide_less_0_1_iff [simp]:
  "1 / a < 0 \<longleftrightarrow> a < 0"
  by (simp add: divide_less_0_iff)

lemma divide_right_mono:
     "[|a \<le> b; 0 \<le> c|] ==> a/c \<le> b/c"
by (force simp add: divide_strict_right_mono le_less)

lemma divide_right_mono_neg: "a <= b
    ==> c <= 0 ==> b / c <= a / c"
apply (drule divide_right_mono [of _ _ "- c"])
apply auto
done

lemma divide_left_mono_neg: "a <= b
    ==> c <= 0 ==> 0 < a * b ==> c / a <= c / b"
  apply (drule divide_left_mono [of _ _ "- c"])
  apply (auto simp add: mult.commute)
done

lemma inverse_le_iff: "inverse a \<le> inverse b \<longleftrightarrow> (0 < a * b \<longrightarrow> b \<le> a) \<and> (a * b \<le> 0 \<longrightarrow> a \<le> b)"
  by (cases a 0 b 0 rule: linorder_cases[case_product linorder_cases])
     (auto simp add: field_simps zero_less_mult_iff mult_le_0_iff)

lemma inverse_less_iff: "inverse a < inverse b \<longleftrightarrow> (0 < a * b \<longrightarrow> b < a) \<and> (a * b \<le> 0 \<longrightarrow> a < b)"
  by (subst less_le) (auto simp: inverse_le_iff)

lemma divide_le_cancel: "a / c \<le> b / c \<longleftrightarrow> (0 < c \<longrightarrow> a \<le> b) \<and> (c < 0 \<longrightarrow> b \<le> a)"
  by (simp add: divide_inverse mult_le_cancel_right)

lemma divide_less_cancel: "a / c < b / c \<longleftrightarrow> (0 < c \<longrightarrow> a < b) \<and> (c < 0 \<longrightarrow> b < a) \<and> c \<noteq> 0"
  by (auto simp add: divide_inverse mult_less_cancel_right)

text\<open>Simplify quotients that are compared with the value 1.\<close>

lemma le_divide_eq_1:
  "(1 \<le> b / a) = ((0 < a & a \<le> b) | (a < 0 & b \<le> a))"
by (auto simp add: le_divide_eq)

lemma divide_le_eq_1:
  "(b / a \<le> 1) = ((0 < a & b \<le> a) | (a < 0 & a \<le> b) | a=0)"
by (auto simp add: divide_le_eq)

lemma less_divide_eq_1:
  "(1 < b / a) = ((0 < a & a < b) | (a < 0 & b < a))"
by (auto simp add: less_divide_eq)

lemma divide_less_eq_1:
  "(b / a < 1) = ((0 < a & b < a) | (a < 0 & a < b) | a=0)"
by (auto simp add: divide_less_eq)

lemma divide_nonneg_nonneg [simp]:
  "0 \<le> x \<Longrightarrow> 0 \<le> y \<Longrightarrow> 0 \<le> x / y"
  by (auto simp add: divide_simps)

lemma divide_nonpos_nonpos:
  "x \<le> 0 \<Longrightarrow> y \<le> 0 \<Longrightarrow> 0 \<le> x / y"
  by (auto simp add: divide_simps)

lemma divide_nonneg_nonpos:
  "0 \<le> x \<Longrightarrow> y \<le> 0 \<Longrightarrow> x / y \<le> 0"
  by (auto simp add: divide_simps)

lemma divide_nonpos_nonneg:
  "x \<le> 0 \<Longrightarrow> 0 \<le> y \<Longrightarrow> x / y \<le> 0"
  by (auto simp add: divide_simps)

text \<open>Conditional Simplification Rules: No Case Splits\<close>

lemma le_divide_eq_1_pos [simp]:
  "0 < a \<Longrightarrow> (1 \<le> b/a) = (a \<le> b)"
by (auto simp add: le_divide_eq)

lemma le_divide_eq_1_neg [simp]:
  "a < 0 \<Longrightarrow> (1 \<le> b/a) = (b \<le> a)"
by (auto simp add: le_divide_eq)

lemma divide_le_eq_1_pos [simp]:
  "0 < a \<Longrightarrow> (b/a \<le> 1) = (b \<le> a)"
by (auto simp add: divide_le_eq)

lemma divide_le_eq_1_neg [simp]:
  "a < 0 \<Longrightarrow> (b/a \<le> 1) = (a \<le> b)"
by (auto simp add: divide_le_eq)

lemma less_divide_eq_1_pos [simp]:
  "0 < a \<Longrightarrow> (1 < b/a) = (a < b)"
by (auto simp add: less_divide_eq)

lemma less_divide_eq_1_neg [simp]:
  "a < 0 \<Longrightarrow> (1 < b/a) = (b < a)"
by (auto simp add: less_divide_eq)

lemma divide_less_eq_1_pos [simp]:
  "0 < a \<Longrightarrow> (b/a < 1) = (b < a)"
by (auto simp add: divide_less_eq)

lemma divide_less_eq_1_neg [simp]:
  "a < 0 \<Longrightarrow> b/a < 1 \<longleftrightarrow> a < b"
by (auto simp add: divide_less_eq)

lemma eq_divide_eq_1 [simp]:
  "(1 = b/a) = ((a \<noteq> 0 & a = b))"
by (auto simp add: eq_divide_eq)

lemma divide_eq_eq_1 [simp]:
  "(b/a = 1) = ((a \<noteq> 0 & a = b))"
by (auto simp add: divide_eq_eq)

lemma abs_div_pos: "0 < y ==>
    \<bar>x\<bar> / y = \<bar>x / y\<bar>"
  apply (subst abs_divide)
  apply (simp add: order_less_imp_le)
done

lemma zero_le_divide_abs_iff [simp]: "(0 \<le> a / \<bar>b\<bar>) = (0 \<le> a | b = 0)"
by (auto simp: zero_le_divide_iff)

lemma divide_le_0_abs_iff [simp]: "(a / \<bar>b\<bar> \<le> 0) = (a \<le> 0 | b = 0)"
by (auto simp: divide_le_0_iff)

lemma field_le_mult_one_interval:
  assumes *: "\<And>z. \<lbrakk> 0 < z ; z < 1 \<rbrakk> \<Longrightarrow> z * x \<le> y"
  shows "x \<le> y"
proof (cases "0 < x")
  assume "0 < x"
  thus ?thesis
    using dense_le_bounded[of 0 1 "y/x"] *
    unfolding le_divide_eq if_P[OF \<open>0 < x\<close>] by simp
next
  assume "\<not>0 < x" hence "x \<le> 0" by simp
  obtain s::'a where s: "0 < s" "s < 1" using dense[of 0 "1::'a"] by auto
  hence "x \<le> s * x" using mult_le_cancel_right[of 1 x s] \<open>x \<le> 0\<close> by auto
  also note *[OF s]
  finally show ?thesis .
qed

text\<open>For creating values between @{term u} and @{term v}.\<close>
lemma scaling_mono:
  assumes "u \<le> v" "0 \<le> r" "r \<le> s"
    shows "u + r * (v - u) / s \<le> v"
proof -
  have "r/s \<le> 1" using assms
    using divide_le_eq_1 by fastforce
  then have "(r/s) * (v - u) \<le> 1 * (v - u)"
    apply (rule mult_right_mono)
    using assms by simp
  then show ?thesis
    by (simp add: field_simps)
qed

end

text \<open>Min/max Simplification Rules\<close>

lemma min_mult_distrib_left:
  fixes x::"'a::linordered_idom"
  shows "p * min x y = (if 0 \<le> p then min (p*x) (p*y) else max (p*x) (p*y))"
by (auto simp add: min_def max_def mult_le_cancel_left)

lemma min_mult_distrib_right:
  fixes x::"'a::linordered_idom"
  shows "min x y * p = (if 0 \<le> p then min (x*p) (y*p) else max (x*p) (y*p))"
by (auto simp add: min_def max_def mult_le_cancel_right)

lemma min_divide_distrib_right:
  fixes x::"'a::linordered_field"
  shows "min x y / p = (if 0 \<le> p then min (x/p) (y/p) else max (x/p) (y/p))"
by (simp add: min_mult_distrib_right divide_inverse)

lemma max_mult_distrib_left:
  fixes x::"'a::linordered_idom"
  shows "p * max x y = (if 0 \<le> p then max (p*x) (p*y) else min (p*x) (p*y))"
by (auto simp add: min_def max_def mult_le_cancel_left)

lemma max_mult_distrib_right:
  fixes x::"'a::linordered_idom"
  shows "max x y * p = (if 0 \<le> p then max (x*p) (y*p) else min (x*p) (y*p))"
by (auto simp add: min_def max_def mult_le_cancel_right)

lemma max_divide_distrib_right:
  fixes x::"'a::linordered_field"
  shows "max x y / p = (if 0 \<le> p then max (x/p) (y/p) else min (x/p) (y/p))"
by (simp add: max_mult_distrib_right divide_inverse)

hide_fact (open) field_inverse field_divide_inverse field_inverse_zero

code_identifier
  code_module Fields \<rightharpoonup> (SML) Arith and (OCaml) Arith and (Haskell) Arith

end


section \<open> Finite bijections \<close>

theory Finite_Bijection
  imports "HOL-Library.Countable_Set"
begin

text \<open> This theory shows that there exists a bijection between any finite type and the set
        of natural numbers bounded by the cardinality of the finite type. \<close>

definition is_to_nat_ind :: "'a \<Rightarrow> nat \<Rightarrow> bool" where
"is_to_nat_ind x i \<longleftrightarrow> (finite (UNIV :: 'a set) \<and>
                        i < card (UNIV :: 'a set) \<and>
                        sorted_list_of_set (to_nat_on (UNIV :: 'a set) ` (UNIV :: 'a set)) ! i = to_nat_on (UNIV :: 'a set) x)"

text \<open> The function @{const to_nat} from the countable class makes no guarantees about
        which natural numbers will be picked for each element. Nevertheless it guaranatees
        a unique natural for each element. We use this to map each of these elements to
        a number in the range 0..|A| by creating a sorted list of the corresponding naturals
        from @{const to_nat} and then assigning each element its index in this list. Thus
        we end up with a more predictable set of numbers. \<close>

definition to_nat_fin :: "'a \<Rightarrow> nat" where
"to_nat_fin x = (THE i. is_to_nat_ind x i)"

lemma sorted_list_of_set_index_ex:
  assumes "finite A"
  shows "(\<exists> i<card A. sorted_list_of_set A ! i = x) \<longleftrightarrow> x \<in> A"
  by (metis assms distinct_card in_set_conv_nth sorted_list_of_set)

lemma nat_ind_exists:
  assumes "finite (UNIV :: 'a set)"
  shows "\<exists> i. is_to_nat_ind (x :: 'a) i"
proof -
  have "to_nat_on (UNIV :: 'a set) x \<in> range (to_nat_on (UNIV :: 'a set)) \<longleftrightarrow>
          (\<exists> i<card (UNIV :: 'a set). sorted_list_of_set (range (to_nat_on (UNIV :: 'a set))) ! i = to_nat_on (UNIV :: 'a set) x)"
    by (meson assms card_image_le dual_order.strict_trans1 finite_imageI range_eqI sorted_list_of_set_index_ex)

  then obtain a
    where a_card: "a < card (UNIV :: 'a set)"
    and a_ind: "sorted_list_of_set (range (to_nat_on (UNIV :: 'a set))) ! a = to_nat_on (UNIV :: 'a set) x"
    by auto

  thus ?thesis
    by (auto simp add: is_to_nat_ind_def assms)
qed

lemma length_sorted_list_of_set [simp]: "finite A \<Longrightarrow> length (sorted_list_of_set A) = card A"
  by (metis distinct_card distinct_sorted_list_of_set set_sorted_list_of_set)

lemma to_nat_on_inj_on: "countable A \<Longrightarrow> inj_on (to_nat_on A) A"
  by (auto simp add: inj_on_def)

lemma finite_card_to_nat_on [simp]:
  "finite (UNIV :: 'a set) \<Longrightarrow> card (range (to_nat_on (UNIV :: 'a set))) = card (UNIV :: 'a set)"
  by (simp add: card_image countable_finite to_nat_on_inj_on)

lemma nat_ind_unique:
  assumes "is_to_nat_ind (x :: 'a) i"
  shows "to_nat_fin x = i"
proof -
  let ?A = "range (to_nat_on (UNIV :: 'a set))"
  from assms have finA: "finite ?A"
    by (simp add: is_to_nat_ind_def)
  hence "distinct (sorted_list_of_set ?A)"
    using sorted_list_of_set by blast
  with assms have "\<And> i j. \<lbrakk> i < card(UNIV :: 'a set); j < card (UNIV :: 'a set)
                 ; sorted_list_of_set ?A ! i = sorted_list_of_set ?A ! j \<rbrakk> \<Longrightarrow> i = j"
    using finite_card_to_nat_on is_to_nat_ind_def by (fastforce simp add: distinct_conv_nth finA)
  with assms show ?thesis
    apply (simp add: the_equality to_nat_fin_def)
    apply (rule the_equality)
    apply (auto simp add: is_to_nat_ind_def)
  done
qed

lemma nat_ind_val_exists:
  assumes "finite (UNIV :: 'a set)" "i < card (UNIV :: 'a set)"
  shows "\<exists>x :: 'a. is_to_nat_ind x i"
  using assms
  apply (auto simp add: is_to_nat_ind_def)
  apply (metis finite_card_to_nat_on finite_imageI imageE sorted_list_of_set_index_ex)
done

lemma to_nat_fin_ex:
  fixes x :: "'a"
  assumes "finite (UNIV :: 'a set)" "i < card (UNIV :: 'a set)"
  shows "\<exists>x :: 'a. i = to_nat_fin x"
proof -
  obtain y :: 'a where "is_to_nat_ind y i"
    using assms nat_ind_val_exists by blast
  thus ?thesis
    using nat_ind_unique by fastforce
qed

lemma to_nat_fin_bounded:
  fixes x :: "'a"
  assumes "finite (UNIV :: 'a set)"
  shows "to_nat_fin x < card (UNIV :: 'a set)"
proof -
  obtain i where "is_to_nat_ind x i"
    by (meson assms nat_ind_exists)
  thus ?thesis
    using is_to_nat_ind_def nat_ind_unique by fastforce
qed

lemma range_to_nat_fin:
  "finite (UNIV :: 'a set) \<Longrightarrow> range (to_nat_fin :: 'a \<Rightarrow> nat) = {n. n < card(UNIV :: 'a set)}"
  using to_nat_fin_ex by (auto simp add: to_nat_fin_bounded)

lemma is_to_nat_ind:
  "\<lbrakk> finite (UNIV :: 'a set); is_to_nat_ind (x :: 'a) i; is_to_nat_ind x j \<rbrakk> \<Longrightarrow> i = j"
  apply (auto simp add: is_to_nat_ind_def)
  apply (metis distinct_card finite_card_to_nat_on finite_imageI nth_eq_iff_index_eq sorted_list_of_set)
done

lemma is_to_nat_ind_elem:
  "\<lbrakk> is_to_nat_ind x i; is_to_nat_ind y i \<rbrakk> \<Longrightarrow> x = y"
  by (auto simp add: is_to_nat_ind_def countable_finite)

lemma to_nat_fin_inj:
  assumes "finite (UNIV :: 'a set)"
  shows "inj (to_nat_fin :: 'a \<Rightarrow> nat)"
proof (rule injI)
  fix x y :: 'a
  assume "to_nat_fin x = to_nat_fin y"
  moreover obtain i where "is_to_nat_ind x i"
    by (meson assms nat_ind_exists)
  moreover obtain j where "is_to_nat_ind y j"
    by (meson assms nat_ind_exists)
 ultimately show "x = y"
    by (metis is_to_nat_ind_elem nat_ind_unique)
qed

lemma to_nat_fin_bij:
  "finite (UNIV :: 'a set) \<Longrightarrow> bij_betw to_nat_fin (UNIV :: 'a set) {n. n < card (UNIV :: 'a set)}"
  by (auto simp add: bij_betw_def to_nat_fin_inj to_nat_fin_bounded range_to_nat_fin)
end


(*
    Author:      René Thiemann
                 Akihisa Yamada
    License:     BSD
*)
section \<open>Improved Code Equations\<close>

text \<open>This theory contains improved code equations for certain algorithms.\<close>

theory Improved_Code_Equations
imports
  "HOL-Computational_Algebra.Polynomial"
  "HOL-Library.Code_Target_Nat"
begin

subsection \<open>@{const divmod_integer}.\<close>

text \<open>We improve @{thm divmod_integer_code} by deleting @{const sgn}-expressions.\<close>

text \<open>We guard the application of divmod-abs' with the condition @{term "x \<ge> 0 \<and> y \<ge> 0"},
  so that application can be ensured on non-negative values. Hence, one can drop "abs" in
   target language setup.\<close>

definition divmod_abs' where
  "x \<ge> 0 \<Longrightarrow> y \<ge> 0 \<Longrightarrow> divmod_abs' x y = Code_Numeral.divmod_abs x y"

(* led to an another 10 % improvement on factorization example *)

lemma divmod_integer_code''[code]: "divmod_integer k l =
  (if k = 0 then (0, 0)
    else if l > 0 then
            (if k > 0 then divmod_abs' k l
             else case divmod_abs' (- k) l of (r, s) \<Rightarrow>
                  if s = 0 then (- r, 0) else (- r - 1, l - s))
    else if l = 0 then (0, k)
    else apsnd uminus
            (if k < 0 then divmod_abs' (-k) (-l)
             else case divmod_abs' k (-l) of (r, s) \<Rightarrow>
                  if s = 0 then (- r, 0) else (- r - 1, - l - s)))"
   unfolding divmod_integer_code
   by (cases "l = 0"; cases "l < 0"; cases "l > 0"; auto split: prod.splits simp: divmod_abs'_def divmod_abs_def)

code_printing \<comment> \<open>FIXME illusion of partiality\<close>
  constant divmod_abs' \<rightharpoonup>
    (SML) "IntInf.divMod/ ( _,/ _ )"
    and (Eval) "Integer.div'_mod/ ( _ )/ ( _ )"
    and (OCaml) "Z.div'_rem"
    and (Haskell) "divMod/ ( _ )/ ( _ )"
    and (Scala) "!((k: BigInt) => (l: BigInt) =>/ if (l == 0)/ (BigInt(0), k) else/ (k '/% l))"

subsection \<open>@{const Divides.divmod_nat}.\<close>
text \<open>We implement @{const Divides.divmod_nat} via @{const divmod_integer}
  instead of invoking both division and modulo separately,
  and we further simplify the case-analysis which is
  performed in @{thm divmod_integer_code''}.\<close>

lemma divmod_nat_code'[code]: "Divides.divmod_nat m n = (
  let k = integer_of_nat m; l = integer_of_nat n
  in map_prod nat_of_integer nat_of_integer
  (if k = 0 then (0, 0)
    else if l = 0 then (0,k) else
            divmod_abs' k l))"
  using divmod_nat_code [of m n]
  by (simp add: divmod_abs'_def integer_of_nat_eq_of_nat Let_def)

subsection \<open>@{const binomial}\<close>

lemma binomial_code[code]:
  "n choose k = (if k \<le> n then fact n div (fact k * fact (n - k)) else 0)"
  using binomial_eq_0[of n k] binomial_altdef_nat[of k n] by simp

end


section "Bitvector based Sets of Naturals"
theory Impl_Bit_Set
imports
  "../../Iterator/Iterator"
  "../Intf/Intf_Set"
  "../../../Native_Word/Code_Target_Integer_Bit"
begin
  text \<open>
    Based on the Native-Word library, using bit-operations on arbitrary
    precision integers. Fast for sets of small numbers,
    direct and fast implementations of equal, union, inter, diff.

    Note: On Poly/ML 5.5.1, bit-operations on arbitrary precision integers are
      rather inefficient. Use MLton instead, here they are efficiently implemented.
\<close>

  type_synonym bitset = integer

  definition bs_\<alpha> :: "bitset \<Rightarrow> nat set" where "bs_\<alpha> s \<equiv> { n . bit s n}"

  context
    includes integer.lifting bit_operations_syntax
  begin

  definition bs_empty :: "unit \<Rightarrow> bitset" where "bs_empty \<equiv> \<lambda>_. 0"

  lemma bs_empty_correct: "bs_\<alpha> (bs_empty ()) = {}"
    unfolding bs_\<alpha>_def bs_empty_def
    apply transfer
    by auto

  definition bs_isEmpty :: "bitset \<Rightarrow> bool" where "bs_isEmpty s \<equiv> s=0"

  lemma bs_isEmpty_correct: "bs_isEmpty s \<longleftrightarrow> bs_\<alpha> s = {}"
    unfolding bs_isEmpty_def bs_\<alpha>_def
    by transfer (auto simp: bit_eq_iff)

  term set_bit
  definition bs_insert :: "nat \<Rightarrow> bitset \<Rightarrow> bitset" where
    "bs_insert i s \<equiv> set_bit s i True"

  lemma bs_insert_correct: "bs_\<alpha> (bs_insert i s) = insert i (bs_\<alpha> s)"
    unfolding bs_\<alpha>_def bs_insert_def
    by transfer (auto simp add: bit_simps)

  definition bs_delete :: "nat \<Rightarrow> bitset \<Rightarrow> bitset" where
    "bs_delete i s \<equiv> set_bit s i False"

  lemma bs_delete_correct: "bs_\<alpha> (bs_delete i s) = (bs_\<alpha> s) - {i}"
    unfolding bs_\<alpha>_def bs_delete_def
    by transfer (auto simp add: bit_simps split: if_splits)

  definition bs_mem :: "nat \<Rightarrow> bitset \<Rightarrow> bool" where
    "bs_mem i s \<equiv> bit s i"

  lemma bs_mem_correct: "bs_mem i s \<longleftrightarrow> i\<in>bs_\<alpha> s"
    unfolding bs_mem_def bs_\<alpha>_def by transfer auto

  definition bs_eq :: "bitset \<Rightarrow> bitset \<Rightarrow> bool" where
    "bs_eq s1 s2 \<equiv> (s1=s2)"

  lemma bs_eq_correct: "bs_eq s1 s2 \<longleftrightarrow> bs_\<alpha> s1 = bs_\<alpha> s2"
    unfolding bs_eq_def bs_\<alpha>_def
    including integer.lifting
    by transfer (simp add: bit_eq_iff set_eq_iff)

  definition bs_subset_eq :: "bitset \<Rightarrow> bitset \<Rightarrow> bool" where
    "bs_subset_eq s1 s2 \<equiv> s1 AND NOT s2 = 0"

  lemma bs_subset_eq_correct: "bs_subset_eq s1 s2 \<longleftrightarrow> bs_\<alpha> s1 \<subseteq> bs_\<alpha> s2"
    unfolding bs_\<alpha>_def bs_subset_eq_def
    by transfer (simp add: bit_eq_iff, auto simp add: bit_simps)

  definition bs_disjoint :: "bitset \<Rightarrow> bitset \<Rightarrow> bool" where
    "bs_disjoint s1 s2 \<equiv> s1 AND s2 = 0"

  lemma bs_disjoint_correct: "bs_disjoint s1 s2 \<longleftrightarrow> bs_\<alpha> s1 \<inter> bs_\<alpha> s2 = {}"
    unfolding bs_\<alpha>_def bs_disjoint_def
    by transfer (simp add: bit_eq_iff, auto simp add: bit_simps)

  definition bs_union :: "bitset \<Rightarrow> bitset \<Rightarrow> bitset" where
    "bs_union s1 s2 = s1 OR s2"

  lemma bs_union_correct: "bs_\<alpha> (bs_union s1 s2) = bs_\<alpha> s1 \<union> bs_\<alpha> s2"
    unfolding bs_\<alpha>_def bs_union_def
    by transfer (simp add: bit_eq_iff, auto simp add: bit_simps)

  definition bs_inter :: "bitset \<Rightarrow> bitset \<Rightarrow> bitset" where
    "bs_inter s1 s2 = s1 AND s2"

  lemma bs_inter_correct: "bs_\<alpha> (bs_inter s1 s2) = bs_\<alpha> s1 \<inter> bs_\<alpha> s2"
    unfolding bs_\<alpha>_def bs_inter_def
    by transfer (simp add: bit_eq_iff, auto simp add: bit_simps)

  definition bs_diff :: "bitset \<Rightarrow> bitset \<Rightarrow> bitset" where
    "bs_diff s1 s2 = s1 AND NOT s2"

  lemma bs_diff_correct: "bs_\<alpha> (bs_diff s1 s2) = bs_\<alpha> s1 - bs_\<alpha> s2"
    unfolding bs_\<alpha>_def bs_diff_def
    by transfer (simp add: bit_eq_iff, auto simp add: bit_simps)

  definition bs_UNIV :: "unit \<Rightarrow> bitset" where "bs_UNIV \<equiv> \<lambda>_. -1"

  lemma bs_UNIV_correct: "bs_\<alpha> (bs_UNIV ()) = UNIV"
    unfolding bs_\<alpha>_def bs_UNIV_def
    by transfer (auto)

  definition bs_complement :: "bitset \<Rightarrow> bitset" where
    "bs_complement s = NOT s"

  lemma bs_complement_correct: "bs_\<alpha> (bs_complement s) = - bs_\<alpha> s"
    unfolding bs_\<alpha>_def bs_complement_def
    by transfer (simp add: bit_eq_iff, auto simp add: bit_simps)

end

  lemmas bs_correct[simp] =
    bs_empty_correct
    bs_isEmpty_correct
    bs_insert_correct
    bs_delete_correct
    bs_mem_correct
    bs_eq_correct
    bs_subset_eq_correct
    bs_disjoint_correct
    bs_union_correct
    bs_inter_correct
    bs_diff_correct
    bs_UNIV_correct
    bs_complement_correct

subsection \<open>Autoref Setup\<close>

definition bs_set_rel_def_internal:
  "bs_set_rel Rk \<equiv>
    if Rk=nat_rel then br bs_\<alpha> (\<lambda>_. True) else {}"
lemma bs_set_rel_def:
  "\<langle>nat_rel\<rangle>bs_set_rel \<equiv> br bs_\<alpha> (\<lambda>_. True)"
  unfolding bs_set_rel_def_internal relAPP_def by simp

lemmas [autoref_rel_intf] = REL_INTFI[of "bs_set_rel" i_set]

lemma bs_set_rel_sv[relator_props]: "single_valued (\<langle>nat_rel\<rangle>bs_set_rel)"
  unfolding bs_set_rel_def by auto

term bs_empty

lemma [autoref_rules]: "(bs_empty (),{})\<in>\<langle>nat_rel\<rangle>bs_set_rel"
  by (auto simp: bs_set_rel_def br_def)

lemma [autoref_rules]: "(bs_UNIV (),UNIV)\<in>\<langle>nat_rel\<rangle>bs_set_rel"
  by (auto simp: bs_set_rel_def br_def)

lemma [autoref_rules]: "(bs_isEmpty,op_set_isEmpty)\<in>\<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> bool_rel"
  by (auto simp: bs_set_rel_def br_def)

term insert
lemma [autoref_rules]: "(bs_insert,insert)\<in>nat_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel"
  by (auto simp: bs_set_rel_def br_def)

term op_set_delete
lemma [autoref_rules]: "(bs_delete,op_set_delete)\<in>nat_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel"
  by (auto simp: bs_set_rel_def br_def)

lemma [autoref_rules]: "(bs_mem,(\<in>))\<in>nat_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> bool_rel"
  by (auto simp: bs_set_rel_def br_def)

lemma [autoref_rules]: "(bs_eq,(=))\<in>\<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> bool_rel"
  by (auto simp: bs_set_rel_def br_def)

lemma [autoref_rules]: "(bs_subset_eq,(\<subseteq>))\<in>\<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> bool_rel"
  by (auto simp: bs_set_rel_def br_def)

lemma [autoref_rules]: "(bs_union,(\<union>))\<in>\<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel"
  by (auto simp: bs_set_rel_def br_def)

lemma [autoref_rules]: "(bs_inter,(\<inter>))\<in>\<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel"
  by (auto simp: bs_set_rel_def br_def)

lemma [autoref_rules]: "(bs_diff,(-))\<in>\<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel"
  by (auto simp: bs_set_rel_def br_def)

lemma [autoref_rules]: "(bs_complement,uminus)\<in>\<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel"
  by (auto simp: bs_set_rel_def br_def)

lemma [autoref_rules]: "(bs_disjoint,op_set_disjoint)\<in>\<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> bool_rel"
  by (auto simp: bs_set_rel_def br_def)

export_code
    bs_empty
    bs_isEmpty
    bs_insert
    bs_delete
    bs_mem
    bs_eq
    bs_subset_eq
    bs_disjoint
    bs_union
    bs_inter
    bs_diff
    bs_UNIV
    bs_complement
 in SML

(*

    TODO: Iterator

  definition "maxbi s \<equiv> GREATEST i. s!!i"

  lemma cmp_BIT_append_conv[simp]: "i < i BIT b \<longleftrightarrow> ((i\<ge>0 \<and> b=1) \<or> i>0)"
    by (cases b) (auto simp: Bit_B0 Bit_B1)

  lemma BIT_append_cmp_conv[simp]: "i BIT b < i \<longleftrightarrow> ((i<0 \<and> (i=-1 \<longrightarrow> b=0)))"
    by (cases b) (auto simp: Bit_B0 Bit_B1)

  lemma BIT_append_eq[simp]: fixes i :: int shows "i BIT b = i \<longleftrightarrow> (i=0 \<and> b=0) \<or> (i=-1 \<and> b=1)"
    by (cases b) (auto simp: Bit_B0 Bit_B1)

  lemma int_no_bits_eq_zero[simp]:
    fixes s::int shows "(\<forall>i. \<not>s!!i) \<longleftrightarrow> s=0"
    apply clarsimp
    by (metis bin_eqI bin_nth_code(1))

  lemma int_obtain_bit:
    fixes s::int
    assumes "s\<noteq>0"
    obtains i where "s!!i"
    by (metis assms int_no_bits_eq_zero)

  lemma int_bit_bound:
    fixes s::int
    assumes "s\<ge>0" and "s!!i"
    shows "i \<le> Bits_Integer.log2 s"
  proof (rule ccontr)
    assume "\<not>i\<le>Bits_Integer.log2 s"
    hence "i>Bits_Integer.log2 s" by simp
    hence "i - 1 \<ge> Bits_Integer.log2 s" by simp
    hence "s AND bin_mask (i - 1) = s" by (simp add: int_and_mask `s\<ge>0`)
    hence "\<not> (s!!i)"
      by clarsimp (metis Nat.diff_le_self bin_nth_mask bin_nth_ops(1) leD)
    thus False using `s!!i` ..
  qed

  lemma int_bit_bound':
    fixes s::int
    assumes "s\<ge>0" and "s!!i"
    shows "i < Bits_Integer.log2 s + 1"
    using assms int_bit_bound by smt

  lemma int_obtain_bit_pos:
    fixes s::int
    assumes "s>0"
    obtains i where "s!!i" "i < Bits_Integer.log2 s + 1"
    by (metis assms int_bit_bound' int_no_bits_eq_zero less_imp_le less_irrefl)

  lemma maxbi_set: fixes s::int shows "s>0 \<Longrightarrow> s!!maxbi s"
    unfolding maxbi_def
    apply (rule int_obtain_bit_pos, assumption)
    apply (rule GreatestI_nat, assumption)
    apply (intro allI impI)
    apply (rule int_bit_bound'[rotated], assumption)
    by auto

  lemma maxbi_max: fixes s::int shows "i>maxbi s \<Longrightarrow> \<not> s!!i"
    oops

  function get_maxbi :: "nat \<Rightarrow> int \<Rightarrow> nat" where
    "get_maxbi n s = (let
        b = 1<<n
      in
        if b\<le>s then get_maxbi (n+1) s
        else n
    )"
    by pat_completeness auto

  termination
    apply (rule "termination"[of "measure (\<lambda>(n,s). nat (s + 1 - (1<<n)))"])
    apply simp
    apply auto
    by (smt bin_mask_ge0 bin_mask_p1_conv_shift)

  partial_function (tailrec)
    bs_iterate_aux :: "nat \<Rightarrow> bitset \<Rightarrow> ('\<sigma> \<Rightarrow> bool) \<Rightarrow> (nat \<Rightarrow> '\<sigma> \<Rightarrow> '\<sigma>) \<Rightarrow> '\<sigma> \<Rightarrow> '\<sigma>"
    where "bs_iterate_aux i s c f \<sigma> = (
    if s < 1 << i then \<sigma>
    else if \<not>c \<sigma> then \<sigma>
    else if test_bit s i then bs_iterate_aux (i+1) s c f (f i \<sigma>)
    else bs_iterate_aux (i+1) s c f \<sigma>
  )"

  definition bs_iteratei :: "bitset \<Rightarrow> (nat,'\<sigma>) set_iterator" where
    "bs_iteratei s = bs_iterate_aux 0 s"

  definition bs_set_rel_def_internal:
    "bs_set_rel Rk \<equiv>
      if Rk=nat_rel then br bs_\<alpha> (\<lambda>_. True) else {}"
  lemma bs_set_rel_def:
    "\<langle>nat_rel\<rangle>bs_set_rel \<equiv> br bs_\<alpha> (\<lambda>_. True)"
    unfolding bs_set_rel_def_internal relAPP_def by simp

  definition "bs_to_list \<equiv> it_to_list bs_iteratei"

  lemma "(1::int)<<i = 2^i"
    by (simp add: shiftl_int_def)

  lemma
    fixes s :: int
    assumes "s\<ge>0"
    shows "s < 1<<i \<longleftrightarrow> Bits_Integer.log2 s \<le> i"
    using assms
  proof (induct i arbitrary: s)
    case 0 thus ?case by auto
  next
    case (Suc i)
    note GE=`0\<le>s`
    show ?case proof
      assume "s < 1 << Suc i"

      have "s \<le> (s >> 1) BIT 1"

      hence "(s >> 1) < (1<<i)" using GE apply auto
      with Suc.hyps[of "s div 2"]

    apply auto

  lemma "distinct (bs_to_list s)"
    unfolding bs_to_list_def it_to_list_def bs_iteratei_def[abs_def]
  proof -
    {
      fix l i
      assume "distinct l"
      show "distinct (bs_iterate_aux 0 s (\<lambda>_. True) (\<lambda>x l. l @ [x]) [])"

    }

    apply auto

    lemma "set (bs_to_list s) = bs_\<alpha> s"

  lemma autoref_iam_is_iterator[autoref_ga_rules]:
    shows "is_set_to_list nat_rel bs_set_rel bs_to_list"
    unfolding is_set_to_list_def is_set_to_sorted_list_def
    apply clarsimp
    unfolding it_to_sorted_list_def
    apply (refine_rcg refine_vcg)
    apply (simp_all add: bs_set_rel_def br_def)

  proof (clarsimp)

  definition

"iterate s c f \<sigma> \<equiv> let
    i=0;
    b=0;
    (_,_,s) = while
  in

  end"

*)

end


theory Exercise9
  imports Main
begin

fun add :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "add 0 n = n"
  | "add (Suc x) y = Suc (add x y)"

fun itadd :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "itadd 0 x = x"
  | "itadd (Suc x) y = itadd x (Suc y)"

lemma add_n_zero [simp]: "add n 0 = n"
  apply (induction n)
  apply auto
done

lemma add_m_suc_n [simp]: "add m (Suc n) = Suc (add m n)"
  apply (induction m)
  apply auto
done

lemma add_commutativity [simp]: "add m n = add n m"
  apply (induction n)
  apply auto
done

theorem itadd_is_add [simp]: "itadd m n = add m n"
  apply (induction m arbitrary: n)
  apply auto
done

end


theory NewAlgebra
  imports Fixpoint "$AFP/Kleene_Algebra/Kleene_Algebra" Omega_Algebra
begin

notation inf (infixl "\<sqinter>" 70)
notation sup (infixl "\<squnion>" 65)

class par_dioid = join_semilattice_zero + one +
  fixes par :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<parallel>" 69)
  assumes par_assoc [simp]: "x \<parallel> (y \<parallel> z) = (x \<parallel> y) \<parallel> z"
  and par_comm: "x \<parallel> y = y \<parallel> x"
  and par_distl [simp]: "x \<parallel> (y + z) = x \<parallel> y + x \<parallel> z"
  and par_unitl [simp]: "1 \<parallel> x = x"
  and par_annil [simp]: "0 \<parallel> x = 0"

begin

  lemma par_distr [simp]: "(x+y) \<parallel> z = x \<parallel> z + y \<parallel> z"
    by (metis par_comm par_distl)

  lemma par_isol [intro]: "x \<le> y \<Longrightarrow> x \<parallel> z \<le> y \<parallel> z"
    by (metis order_prop par_distr)

  lemma par_isor [intro]: "x \<le> y \<Longrightarrow> z \<parallel> x \<le> z \<parallel> y"
    by (metis par_comm par_isol)

  lemma par_unitr [simp]: "x \<parallel> 1 = x"
    by (metis par_comm par_unitl)

  lemma par_annir [simp]: "x \<parallel> 0 = 0"
    by (metis par_annil par_comm)

  lemma par_subdistl: "x \<parallel> z \<le> (x + y) \<parallel> z"
    by (metis order_prop par_distr)

  lemma par_subdistr: "z \<parallel> x \<le> z \<parallel> (x + y)"
    by (metis par_comm par_subdistl)

  lemma par_double_iso [intro]: "w \<le> x \<Longrightarrow> y \<le> z \<Longrightarrow> w \<parallel> y \<le> x \<parallel> z"
    by (metis order_trans par_isol par_isor)

end

class weak_trioid = par_dioid + dioid_one_zerol

class trioid = par_dioid + dioid_one_zero + complete_lattice

locale rg_algebra =
  fixes restrict :: "'b::complete_lattice \<Rightarrow> 'a::trioid \<Rightarrow> 'a::trioid" (infixr "\<Colon>" 55)
  and rg :: "'b::complete_lattice \<Rightarrow> 'a::trioid \<Rightarrow> 'a::trioid" (infixr "\<leadsto>" 55)
  and guar :: "'b::complete_lattice \<Rightarrow> 'a::trioid"
  assumes mod_coext: "r \<Colon> x \<le> x"
  and guar_iso: "r \<le> s \<Longrightarrow> guar r \<le> guar s"
  and mod_top: "top \<Colon> x = x"
  and rg_top: "top \<leadsto> x = x"
  and mod_inter: "r \<sqinter> s \<Colon> x = r \<Colon> s \<Colon> x"
  and mod_isotone: "r \<le> s \<Longrightarrow> r \<Colon> x \<le> s \<Colon> x"
  and galois: "(r \<Colon> x \<le> y) \<longleftrightarrow> (x \<le> r \<leadsto> y)"
  and rg_antitone: "r \<le> s  \<Longrightarrow> s \<leadsto> x \<le> r \<leadsto> x"
  and guar_par: "guar g1 \<parallel> guar g2 = guar (g1 \<squnion> g2)"

  and ax2: "(r \<squnion> g2 \<leadsto> guar g1 \<sqinter> x) \<parallel> (r \<squnion> g1 \<leadsto> guar g2 \<sqinter> y) \<le> r \<leadsto> (guar g1 \<sqinter> x) \<parallel> (guar g2 \<sqinter> y)"

begin

  lemma rg_ext: "x \<le> r \<leadsto> x"
    by (metis galois mod_coext)

  lemma mod_prog_iso: "x \<le> y \<Longrightarrow> r \<Colon> x \<le> r \<Colon> y"
    by (metis ab_semigroup_add_class.add_ac(1) dual_order.order_iff_strict galois order_prop)

  lemma rg_prog_iso: "x \<le> y \<Longrightarrow> r \<leadsto> x \<le> r \<leadsto> y"
    by (metis dual_order.trans galois order_refl)

  lemma rg_mono: "r \<le> s \<Longrightarrow> x \<le> y \<Longrightarrow> s \<leadsto> x \<le> r \<leadsto> y"
    by (metis galois rg_antitone sup.coboundedI1 sup.orderE sup_commute)

  lemma "r \<squnion> s \<leadsto> x \<le> r \<leadsto> s \<leadsto> x"
    apply (rule rg_mono)
    apply (metis sup.cobounded1)
    by (metis rg_ext)

  lemma "r \<Colon> r \<leadsto> x \<le> r \<Colon> x"
    by (metis galois inf_idem mod_inter mod_prog_iso order_refl)

  definition quintuple :: "'b \<Rightarrow> 'b \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" ("_, _ \<turnstile> \<lbrace>_\<rbrace> _ \<lbrace>_\<rbrace>" [20,20,20,20,20] 1000) where
    "r, g \<turnstile> \<lbrace>p\<rbrace> x \<lbrace>q\<rbrace> \<equiv> (p \<cdot> x \<le> r \<leadsto> guar g \<sqinter> q) \<and> (guar r \<parallel> q \<le> q)"

  lemma "r \<Colon> r \<leadsto> x \<le> r \<Colon> x"
    by (metis galois inf_idem mod_inter mod_prog_iso order_refl)

  lemma "r \<leadsto> x \<le> r \<leadsto> r \<Colon> x"
    by (metis galois inf_idem mod_inter mod_prog_iso order_refl)

  lemma rely_swap: "r \<Colon> r \<leadsto> x \<le> r \<leadsto> r \<Colon> x"
    by (metis galois order_refl rg_prog_iso)

  theorem parallel_rule:
    assumes "r \<squnion> g1 \<le> r2"
    and "r \<squnion> g2 \<le> r1"
    and "g1 \<squnion> g2 \<le> g"
    and "r1, g1 \<turnstile> \<lbrace>p\<rbrace> x \<lbrace>q1\<rbrace>"
    and "r2, g2 \<turnstile> \<lbrace>p\<rbrace> y \<lbrace>q2\<rbrace>"
    and "p \<cdot> (x \<parallel> y) \<le> p \<cdot> x \<parallel> p \<cdot> y"
    shows "r, g \<turnstile> \<lbrace>p\<rbrace> x \<parallel> y \<lbrace>q1 \<sqinter> q2\<rbrace>"
  proof -
    from assms(5) have g1_preserves_q2: "guar g1 \<parallel> q2 \<le> q2"
      by (simp add: quintuple_def) (metis assms(1) dual_order.trans guar_iso par_isol sup.boundedE)

    from assms(5) have r2_preserves_q2: "guar r2 \<parallel> q2 \<le> q2"
      by (simp add: quintuple_def)

    from assms(4) have g2_preserves_q1: "q1 \<parallel> guar g2 \<le> q1"
      by (simp add: quintuple_def) (metis assms(2) guar_iso par_comm par_isor sup.boundedE sup_absorb2)

    from assms(4) have r1_preserves_q1: "guar r1 \<parallel> q1 \<le> q1"
      by (simp add: quintuple_def)

    have "p \<cdot> (x \<parallel> y) \<le> p \<cdot> x \<parallel> p \<cdot> y"
      by (metis assms(6))
    also have "... \<le> (r1 \<leadsto> guar g1 \<sqinter> q1) \<parallel> (r2 \<leadsto> guar g2 \<sqinter> q2)"
      by (metis assms(4) assms(5) par_double_iso quintuple_def)
    also have "... \<le> (r \<squnion> g2 \<leadsto> guar g1 \<sqinter> q1) \<parallel> (r \<squnion> g1 \<leadsto> guar g2 \<sqinter> q2)"
      by (metis assms(1) assms(2) par_double_iso rg_antitone)
    also have "... \<le> r \<leadsto> (guar g1 \<sqinter> q1) \<parallel> (guar g2 \<sqinter> q2)"
      by (metis ax2)
    also have "... \<le> r \<leadsto> guar (g1 \<squnion> g2) \<sqinter> (q1 \<sqinter> q2)"
      apply (auto intro!: rg_prog_iso)
      apply (metis guar_par inf.cobounded2 inf_commute par_double_iso)
      apply (metis g2_preserves_q1 inf_commute inf_sup_ord(2) order.trans par_double_iso)
      by (metis g1_preserves_q2 inf.bounded_iff inf.cobounded2 inf_absorb2 par_double_iso)
    finally have "p \<cdot> (x \<parallel> y) \<le> r \<leadsto> guar (g1 \<squnion> g2) \<sqinter> (q1 \<sqinter> q2)" .
    moreover have "guar r \<parallel> q1 \<sqinter> q2 \<le> q1 \<sqinter> q2"
      apply auto
      apply (metis assms(2) guar_iso inf_sup_ord(1) order_trans par_double_iso r1_preserves_q1 sup.boundedE)
      by (metis assms(1) guar_iso inf_sup_ord(2) order_trans par_double_iso r2_preserves_q2 sup.boundedE)
    ultimately show ?thesis
      apply (simp add: quintuple_def)
      apply (erule order_trans)
      by (metis assms(3) guar_iso inf_mono order_refl rg_prog_iso)
  qed

end


theory General_Groups
  imports Set_Mult
begin

(* Manuel *)
lemma (in subgroup) nat_pow_closed [simp,intro]: "a \<in> H \<Longrightarrow> pow G a (n::nat) \<in> H"
  by (induction n) (auto simp: nat_pow_def)

(* Manuel *)
lemma nat_pow_modify_carrier: "a [^]\<^bsub>G\<lparr>carrier := H\<rparr>\<^esub> b = a [^]\<^bsub>G\<^esub> (b::nat)"
  by (simp add: nat_pow_def)

definition (in group) complementary :: "'a set \<Rightarrow> 'a set \<Rightarrow> bool" where
  "complementary H1 H2 \<longleftrightarrow> H1 \<inter> H2 = {\<one>}"

lemma (in group) complementary_symm[simp]: "complementary A B \<longleftrightarrow> complementary B A"
  unfolding complementary_def by blast

lemma (in group) subgroup_carrier_complementary:
  assumes "complementary H J" "subgroup I (G\<lparr>carrier := H\<rparr>)" "subgroup K (G\<lparr>carrier := J\<rparr>)"
  shows "complementary I K"
proof -
  have "\<one> \<in> I" using subgroup.one_closed[OF assms(2)] by simp
  moreover have "\<one> \<in> K" using subgroup.one_closed[OF assms(3)] by simp
  moreover have "I \<inter> K \<subseteq> H \<inter> J" using subgroup.subset assms(2, 3) by force
  ultimately show ?thesis using assms(1) unfolding complementary_def by blast
qed

lemma (in group) subgroup_subset_complementary:
  assumes "subgroup H G" "subgroup J G" "subgroup I G"
  and "I \<subseteq> J" "complementary H J"
shows "complementary H I"
  by(intro subgroup_carrier_complementary[OF assms(5), of H I] subgroup_incl, use assms in auto)

lemma (in group) complementary_subgroup_iff:
  assumes "subgroup H G"
  shows "complementary A B \<longleftrightarrow> group.complementary (G\<lparr>carrier := H\<rparr>) A B"
proof -
  interpret H: group "G\<lparr>carrier := H\<rparr>" using subgroup.subgroup_is_group assms by blast
  have "\<one>\<^bsub>G\<^esub> = \<one>\<^bsub>G\<lparr>carrier := H\<rparr>\<^esub>" by simp
  then show ?thesis unfolding complementary_def H.complementary_def by simp
qed

lemma (in group) subgroup_card_dvd_group_ord:
  assumes "subgroup H G"
  shows "card H dvd order G"
  using Coset.group.lagrange[of G H] assms group_axioms by (metis dvd_triv_right)

lemma (in group) subgroup_card_eq_order:
  assumes "subgroup H G"
  shows "card H = order (G\<lparr>carrier := H\<rparr>)"
  unfolding order_def by simp

lemma (in group) finite_subgroup_card_neq_0:
  assumes "subgroup H G" "finite H"
  shows "card H \<noteq> 0"
  using subgroup_nonempty assms by auto

lemma (in group) subgroup_ord_dvd_group_ord:
  assumes "subgroup H G"
  shows "order (G\<lparr>carrier := H\<rparr>) dvd order G"
  by (metis subgroup_card_dvd_group_ord[of H] assms subgroup_card_eq_order)

lemma (in group) sub_subgroup_dvd_card:
  assumes "subgroup H G" "subgroup J G" "J \<subseteq> H"
  shows "card J dvd card H"
  by (metis subgroup_incl[of J H] subgroup_card_eq_order[of H] group.subgroup_card_dvd_group_ord[of "(G\<lparr>carrier := H\<rparr>)" J] assms subgroup.subgroup_is_group[of H G] group_axioms)

lemma (in group) inter_subgroup_dvd_card:
  assumes "subgroup H G" "subgroup J G"
  shows "card (H \<inter> J) dvd card H"
  using subgroups_Inter_pair[of H J] assms sub_subgroup_dvd_card[of H "H \<inter> J"] by blast

lemma (in group) set_subgroup_generate_dvd_order:
  assumes "A \<subseteq> carrier G" and "subgroup H G"
  shows "(card H) dvd card (generate G (H \<union> A))" (is "?cH dvd card ?F")
proof -
  from generate_is_subgroup[of "H \<union> A"] have "subgroup ?F G" using assms subgroup.subset by blast
  moreover have "H \<subseteq> ?F" using generate.incl[of _ H G] mono_generate[of H "H \<union> A"] by blast
  ultimately show ?thesis using assms(2) sub_subgroup_dvd_card[of "?F" H] by blast
qed

lemma (in group) sub_sub_generate_dvd_order:
  assumes "subgroup H G" "subgroup J G"
  shows "(card H) dvd card (generate G (H \<union> J))"
  using set_subgroup_generate_dvd_order[of J H] subgroup.subset[of J G] assms by blast

lemma (in group) subgroups_order_coprime_inter_card_one:
  assumes "subgroup H G" and "subgroup J G" and "coprime (card H) (card J)"
  shows "card (H \<inter> J) = 1"
proof -
  from assms coprime_def[of "card H" "card J"] inter_subgroup_dvd_card[of H J] inter_subgroup_dvd_card[of J H] have "is_unit (card (H \<inter> J))" by (simp add: inf_commute)
  then show ?thesis by simp
qed

lemma (in group) subgroups_order_coprime_imp_compl:
  assumes "subgroup H G" and "subgroup J G" and "coprime (card H) (card J)"
  shows "complementary H J" unfolding complementary_def
  using subgroups_order_coprime_inter_card_one[of H J] assms
  by (metis card_1_singletonE insert_absorb singleton_insert_inj_eq subgroup.one_closed subgroups_Inter_pair)

lemma (in comm_group) compl_imp_diff_cosets:
  assumes "subgroup H G" "subgroup J G" "finite H" "finite J"
  and "complementary H J"
shows "\<And>a b. \<lbrakk>a \<in> J; b \<in> J; a \<noteq> b\<rbrakk> \<Longrightarrow> (H #> a) \<noteq> (H #> b)"
proof (rule ccontr; safe)
  fix a b
  assume ab: "a \<in> J" "b \<in> J" "a \<noteq> b"
  then have [simp]: "a \<in> carrier G" "b \<in> carrier G" using assms subgroup.subset by auto
  assume "H #> a = H #> b"
  then have "a \<otimes> inv b \<in> H" using assms(1, 2) ab
    by (metis comm_group_axioms comm_group_def rcos_self subgroup.mem_carrier subgroup.rcos_module_imp)
  moreover have "a \<otimes> inv b \<in> J" by (rule subgroup.m_closed[OF assms(2) ab(1) subgroup.m_inv_closed[OF assms(2) ab(2)]])
  moreover have "a \<otimes> inv b \<noteq> \<one>" using ab inv_equality by fastforce
  ultimately have "H \<inter> J \<noteq> {\<one>}" by blast
  thus False using assms(5) unfolding complementary_def by blast
qed

lemma (in group) coset_neq_imp_empty_inter:
  assumes "subgroup H G" "a \<in> carrier G" "b \<in> carrier G"
  shows "H #> a \<noteq> H #> b \<Longrightarrow> (H #> a) \<inter> (H #> b) = {}"
  by (metis Int_emptyI assms repr_independence)

lemma (in comm_group) subgroup_is_comm_group:
  assumes "subgroup H G"
  shows "comm_group (G\<lparr>carrier := H\<rparr>)" unfolding comm_group_def
proof
  interpret HG: Group.group "(G\<lparr>carrier := H\<rparr>)" using subgroup.subgroup_is_group assms by blast
  show "Group.group (G\<lparr>carrier := H\<rparr>)" by unfold_locales
  show "comm_monoid (G\<lparr>carrier := H\<rparr>)" unfolding comm_monoid_def comm_monoid_axioms_def
  proof(safe)
    fix x y
    assume "x \<in> carrier (G\<lparr>carrier := H\<rparr>)" "y \<in> carrier (G\<lparr>carrier := H\<rparr>)"
    then have xy: "x \<in> H" "y \<in> H" by auto
    moreover have "H \<subseteq> carrier G" by (rule subgroup.subset[OF assms])
    thus "x \<otimes>\<^bsub>G\<lparr>carrier := H\<rparr>\<^esub> y = y \<otimes>\<^bsub>G\<lparr>carrier := H\<rparr>\<^esub> x"
      using comm_monoid.m_comm[of G, OF comm_monoid_axioms] xy by auto
  qed
qed

lemma (in group) prime_power_complementary_groups:
  assumes "Factorial_Ring.prime p" "Factorial_Ring.prime q" "p \<noteq> q"
  and "subgroup P G" "card P = p ^ x"
  and "subgroup Q G" "card Q = q ^ y"
  shows "complementary P Q"
proof -
  from assms(1-3) assms(5) assms(7) have "coprime (card P) (card Q)" using coprime_def[unfolded] by (metis coprime_power_right_iff primes_coprime)
  then show ?thesis using group.subgroups_order_coprime_imp_compl[of G P Q] assms(4, 6) complementary_def[unfolded] by blast
qed

lemma (in group) pow_int_mod_ord:
  assumes [simp]:"a \<in> carrier G" "ord a \<noteq> 0"
  shows "a [^] (n::int) = a [^] (n mod ord a)"
proof -
  obtain q r where d: "q = n div ord a" "r = n mod ord a" "n = q * ord a + r"
    using mod_div_decomp by blast
  hence "a [^] n = (a [^] int (ord a)) [^] q \<otimes> a [^] r"
    using assms(1) int_pow_mult int_pow_pow
    by (metis mult_of_nat_commute)
  also have "\<dots> = \<one> [^] q \<otimes> a [^] r"
    by (simp add: int_pow_int)
  also have "\<dots> = a [^] r" by simp
  finally show ?thesis using d(2) by blast
qed

lemma (in group) pow_nat_mod_ord:
  assumes [simp]:"a \<in> carrier G" "ord a \<noteq> 0"
  shows "a [^] (n::nat) = a [^] (n mod ord a)"
proof -
  obtain q r where d: "q = n div ord a" "r = n mod ord a" "n = q * ord a + r"
    using mod_div_decomp by blast
  hence "a [^] n = (a [^] ord a) [^] q \<otimes> a [^] r"
    using assms(1) nat_pow_mult nat_pow_pow by presburger
  also have "\<dots> = \<one> [^] q \<otimes> a [^] r" by auto
  also have "\<dots> = a [^] r" by simp
  finally show ?thesis using d(2) by blast
qed

lemma (in group) ord_min:
  assumes "m \<ge> 1" "x \<in> carrier G" "x [^] m = \<one>"
  shows   "ord x \<le> m"
  using assms pow_eq_id by auto

(* Manuel *)
lemma (in group) bij_betw_mult_left[intro]:
  assumes [simp]: "x \<in> carrier G"
  shows "bij_betw (\<lambda>y. x \<otimes> y) (carrier G) (carrier G)"
  by (intro bij_betwI[where ?g = "\<lambda>y. inv x \<otimes> y"])
     (auto simp: m_assoc [symmetric])

(* Manuel *)
lemma (in subgroup) inv_in_iff:
  assumes "x \<in> carrier G" "group G"
  shows   "inv x \<in> H \<longleftrightarrow> x \<in> H"
proof safe
  assume "inv x \<in> H"
  hence "inv (inv x) \<in> H" by blast
  also have "inv (inv x) = x"
    by (intro group.inv_inv) (use assms in auto)
  finally show "x \<in> H" .
qed auto

(* Manuel *)
lemma (in subgroup) mult_in_cancel_left:
  assumes "y \<in> carrier G" "x \<in> H" "group G"
  shows   "x \<otimes> y \<in> H \<longleftrightarrow> y \<in> H"
proof safe
  assume "x \<otimes> y \<in> H"
  hence "inv x \<otimes> (x \<otimes> y) \<in> H"
    using assms by blast
  also have "inv x \<otimes> (x \<otimes> y) = y"
    using assms by (simp add: \<open>x \<otimes> y \<in> H\<close> group.inv_solve_left')
  finally show "y \<in> H" .
qed (use assms in auto)

(* Manuel *)
lemma (in subgroup) mult_in_cancel_right:
  assumes "x \<in> carrier G" "y \<in> H" "group G"
  shows   "x \<otimes> y \<in> H \<longleftrightarrow> x \<in> H"
proof safe
  assume "x \<otimes> y \<in> H"
  hence "(x \<otimes> y) \<otimes> inv y \<in> H"
    using assms by blast
  also have "(x \<otimes> y) \<otimes> inv y = x"
    using assms by (simp add: \<open>x \<otimes> y \<in> H\<close> group.inv_solve_right')
  finally show "x \<in> H" .
qed (use assms in auto)

lemma (in group) (* Manuel *)
  assumes "x \<in> carrier G" and "x [^] n = \<one>" and "n > 0"
  shows   ord_le: "ord x \<le> n" and ord_pos: "ord x > 0"
proof -
  have "ord x dvd n"
    using pow_eq_id[of x n] assms by auto
  thus "ord x \<le> n" "ord x > 0"
    using assms by (auto intro: dvd_imp_le)
qed

lemma (in group) ord_conv_Least: (* Manuel *)
  assumes "x \<in> carrier G" "\<exists>n::nat > 0. x [^] n = \<one>"
  shows   "ord x = (LEAST n::nat. 0 < n \<and> x [^] n = \<one>)"
proof (rule antisym)
  show "ord x \<le> (LEAST n::nat. 0 < n \<and> x [^] n = \<one>)"
    using assms LeastI_ex[OF assms(2)] by (intro ord_le) auto
  show "ord x \<ge> (LEAST n::nat. 0 < n \<and> x [^] n = \<one>)"
    using assms by (intro Least_le) (auto intro: pow_ord_eq_1 ord_pos)
qed

lemma (in group) ord_conv_Gcd: (* Manuel *)
  assumes "x \<in> carrier G"
  shows   "ord x = Gcd {n. x [^] n = \<one>}"
  by (rule sym, rule Gcd_eqI) (use assms in \<open>auto simp: pow_eq_id\<close>)

lemma (in group) subgroup_ord_eq:
  assumes "subgroup H G" "x \<in> H"
  shows "group.ord (G\<lparr>carrier := H\<rparr>) x = ord x"
  using nat_pow_consistent[of x] ord_def[of x] group.ord_def[of "(G\<lparr>carrier := H\<rparr>)" x] subgroup.subgroup_is_group[of H G] assms group_axioms by simp

lemma (in group) ord_FactGroup:
  assumes "subgroup P G" "group (G Mod P)"
  shows "order (G Mod P) * card P = order G"
  using lagrange[of P] FactGroup_def[of G P] assms order_def[of "(G Mod P)"] by fastforce

lemma (in group) one_is_same:
  assumes "subgroup H G"
  shows "\<one>\<^bsub>G\<lparr>carrier := H\<rparr>\<^esub> = \<one>"
  by simp

lemma (in group) kernel_FactGroup:
  assumes "P \<lhd> G"
  shows "kernel G (G Mod P) (\<lambda>x. P #> x) = P"
proof(rule equalityI; rule subsetI)
  fix x
  assume "x \<in> kernel G (G Mod P) ((#>) P)"
  then have "P #> x = \<one>\<^bsub>G Mod P\<^esub>" "x \<in> carrier G" unfolding kernel_def by simp+
  with coset_join1[of P x] show "x \<in> P" using assms unfolding normal_def by simp
next
  fix x
  assume x:"x \<in> P"
  then have xc: "x \<in> carrier G" using assms subgroup.subset unfolding normal_def by fast
  from x have "P #> x = P" using assms
    by (simp add: normal_imp_subgroup subgroup.rcos_const)
  thus "x \<in> kernel G (G Mod P) ((#>) P)" unfolding kernel_def using xc by simp
qed

lemma (in group) sub_subgroup_coprime:
  assumes "subgroup H G" "subgroup J G" "coprime (card H) (card J)"
  and "subgroup sH G" "subgroup sJ G" "sH \<subseteq> H" "sJ \<subseteq> J"
shows "coprime (card sH) (card sJ)"
  using assms by (meson coprime_divisors sub_subgroup_dvd_card)

lemma (in group) pow_eq_nat_mod:
  assumes "a \<in> carrier G" "a [^] n = a [^] m"
  shows "n mod (ord a) = m mod (ord a)"
proof -
  from assms have "a [^] (n - m) = \<one>" using pow_eq_div2 by blast
  hence "ord a dvd n - m" using assms(1) pow_eq_id by blast
  thus ?thesis
    by (metis assms mod_eq_dvd_iff_nat nat_le_linear pow_eq_div2 pow_eq_id)
qed

lemma (in group) pow_eq_int_mod:
  fixes n m::int
  assumes "a \<in> carrier G" "a [^] n = a [^] m"
  shows "n mod (ord a) = m mod (ord a)"
proof -
  from assms have "a [^] (n - m) = \<one>" using int_pow_closed int_pow_diff r_inv by presburger
  hence "ord a dvd n - m" using assms(1) int_pow_eq_id by blast
  thus ?thesis by (meson mod_eq_dvd_iff)
qed

end