(*
  File:     Carmichael_Numbers.thy
  Authors:  Daniel Stüwe

  Definition and basic properties of Carmichael numbers
*)
section \<open>Carmichael Numbers\<close>
theory Carmichael_Numbers
imports
  Residues_Nat
begin

text \<open>
  A Carmichael number is a composite number \<open>n\<close> that Fermat's test incorrectly labels
  as primes no matter which witness \<open>a\<close> is chosen (except in the case that \<open>a\<close> shares a
  factor with \<open>n\<close>). \<^cite>\<open>"Carmichael_numbers" and "wiki:Carmichael_number"\<close>
\<close>
definition Carmichael_number :: "nat \<Rightarrow> bool" where
  "Carmichael_number n \<longleftrightarrow> n > 1 \<and> \<not>prime n \<and> (\<forall>a. coprime a n \<longrightarrow> [a ^ (n - 1) = 1] (mod n))"

lemma Carmichael_number_0[simp, intro]: "\<not>Carmichael_number 0"
  unfolding Carmichael_number_def by simp

lemma Carmichael_number_1[simp, intro]: "\<not>Carmichael_number 1"
  by (auto simp: Carmichael_number_def)

lemma Carmichael_number_Suc_0[simp, intro]: "\<not>Carmichael_number (Suc 0)"
  by (auto simp: Carmichael_number_def)

lemma Carmichael_number_not_prime: "Carmichael_number n \<Longrightarrow> \<not>prime n"
  by (auto simp: Carmichael_number_def)

lemma Carmichael_number_gt_3: "Carmichael_number n \<Longrightarrow> n > 3"
proof -
  assume *: "Carmichael_number n"
  hence "n > 1" by (auto simp: Carmichael_number_def)
  {
    assume "\<not>(n > 3)"
    with \<open>n > 1\<close> have "n = 2 \<or> n = 3" by auto
    with * and Carmichael_number_not_prime[of n] have False by auto
  }
  thus "n > 3" by auto
qed

text \<open>
  The proofs are inspired by \<^cite>\<open>"Carmichael_numbers" and "Carmichael_number_square_free"\<close>.
\<close>
lemma Carmichael_number_imp_squarefree_aux:
  assumes "Carmichael_number n"
  assumes n: "n = p^r * l" and "prime p" "\<not>p dvd l"
  assumes "r > 1"
  shows False
proof -
  have "\<not> prime n" using \<open>Carmichael_number n\<close> unfolding Carmichael_number_def by blast

  have * : "[a^(n-1) = 1] (mod n)" if "coprime a n" for a
    using \<open>Carmichael_number n\<close> that
    unfolding Carmichael_number_def
    by blast

  have "1 \<le> n"
    unfolding n using \<open>prime p\<close> \<open>\<not> p dvd l\<close>
    by (auto intro: gre1I_nat)

  have "2 \<le> n"
  proof(cases "n = 1")
    case True
    then show ?thesis
      unfolding n using \<open>1 < r\<close> prime_gt_1_nat[OF \<open>prime p\<close>]
      by simp
  next
    case False
    then show ?thesis using \<open>1 \<le> n\<close> by linarith
  qed

  have "p < p^r"
    using prime_gt_1_nat[OF \<open>prime p\<close>] \<open>1 < r\<close>
    by (metis power_one_right power_strict_increasing_iff)

  hence "p < n" using \<open>1 \<le> n\<close> less_le_trans n by fastforce

  then have [simp]: "{..n} - {0..Suc 0} = {2..n}" by auto

  obtain a where a: "[a = p + 1] (mod p^r)" "[a = 1] (mod l)"
    using binary_chinese_remainder_nat[of "p^r" l "p + 1" 1]
    and \<open>prime p\<close> prime_imp_coprime_nat coprime_power_left_iff \<open>\<not>p dvd l\<close>
    by blast

  hence "coprime a n"
    using lucas_coprime_lemma[of 1 a l] cong_imp_coprime[of "p+1" a "p^r"]
      and coprime_add_one_left cong_sym
    unfolding \<open>n = p ^ r * l\<close> coprime_mult_right_iff coprime_power_right_iff power_one_right
    by blast

  hence "[a ^ (n - 1) = 1] (mod n)"
    using * by blast

  hence "[a ^ (n - 1) = 1] (mod p^r)"
    using n cong_modulus_mult_nat by blast

  hence A: "[a ^ n = a] (mod p^r)"
    using cong_scalar_right[of "a^(n-1)" 1 "p^r" a] \<open>1 \<le> n\<close>
    unfolding power_Suc2[symmetric]
    by simp

  have "r = Suc (Suc (r - 2))"
    using \<open>1 < r\<close> by linarith

  then have "p^r = p^2 * p^(r-2)"
    by (simp add: algebra_simps flip: power_add power_Suc)

  hence "[a ^ n = a] (mod p^2)" "[a = p + 1] (mod p^2)"
    using \<open>1 < r\<close> A cong_modulus_mult_nat \<open>[a = p + 1] (mod p^r)\<close>
    by algebra+

  hence 1: "[(p + 1) ^ n = (p + 1)] (mod p^2)"
    by (metis (mono_tags) cong_def power_mod)

  have "[(p + 1) ^ n = (\<Sum>k\<le>n. of_nat (n choose k) * p ^ k * 1 ^ (n - k))] (mod p^2)"
    using binomial[of p 1 n] by simp

  also have "(\<Sum>k\<le>n. of_nat (n choose k) * p ^ k * 1 ^ (n - k)) =
             (\<Sum>k = 0..1. (n choose k) * p ^ k) + (\<Sum>k\<in> {2..n}. of_nat (n choose k) * p ^ k * 1 ^ (n - k))"
    using \<open>2 \<le> n\<close> finite_atMost[of n]
    by (subst sum.subset_diff[where B = "{0..1}"]) auto

  also have "[(\<Sum>k = 0..1. (n choose k) * p ^ k) = 1] (mod p^2)"
    by (simp add: cong_altdef_nat \<open>p ^ r = p\<^sup>2 * p ^ (r - 2)\<close> n)

  also have "[(\<Sum>k\<in> {2..n}. of_nat (n choose k) * p ^ k * 1 ^ (n - k)) = 0] (mod p^2)"
    by (rule cong_eq_0_I) (clarsimp simp: cong_0_iff le_imp_power_dvd)

  finally have 2: "[(p + 1) ^ n = 1] (mod p^2)" by simp

  from cong_trans[OF cong_sym[OF 1] 2]
  show ?thesis
    using prime_gt_1_nat[OF \<open>prime p\<close>]
    by (auto dest: residue_one_dvd[unfolded One_nat_def] simp add: cong_def numeral_2_eq_2)
qed

theorem Carmichael_number_imp_squarefree:
  assumes "Carmichael_number n"
  shows "squarefree n"
proof(rule squarefreeI, rule ccontr)
  fix x :: nat
  assume "x\<^sup>2 dvd n"
  from assms have "n > 0" using Carmichael_number_gt_3[of n] by auto
  from \<open>x\<^sup>2 dvd n\<close> and \<open>0 < n\<close> have "0 < x" by auto

  assume "\<not> is_unit x"
  then obtain p where "prime p" "p dvd x"
    using prime_divisor_exists[of x] \<open>0 < x\<close>
    by blast

  with \<open>x\<^sup>2 dvd n\<close> have "p^2 dvd n"
    by auto

  obtain l where n: "n = p ^ multiplicity p n * l"
    using multiplicity_dvd[of p n] by blast

  then have "\<not> p dvd l"
    using multiplicity_decompose'[where x = n and p = p]
    using \<open>prime p\<close> \<open>0 < n\<close>
    by (metis nat_dvd_1_iff_1 nat_mult_eq_cancel1 neq0_conv prime_prime_factor_sqrt zero_less_power)

  have "2 \<le> multiplicity p n"
    using \<open>p\<^sup>2 dvd n\<close> \<open>0 < n\<close> prime_gt_1_nat[OF \<open>prime p\<close>]
    by (auto intro!: multiplicity_geI simp: power2_eq_square)

  then show False
    using Carmichael_number_imp_squarefree_aux[OF \<open>Carmichael_number n\<close> n] \<open>prime p\<close> \<open>\<not> p dvd l\<close>
    by auto
qed

corollary Carmichael_not_primepow:
  assumes "Carmichael_number n"
  shows   "\<not>primepow n"
  using Carmichael_number_imp_squarefree[of n] Carmichael_number_not_prime[of n] assms
        primepow_gt_0_nat[of n] by (auto simp: not_squarefree_primepow)

lemma Carmichael_number_imp_squarefree_alt_weak:
  assumes "Carmichael_number n"
  shows "\<exists>p l. (n = p * l) \<and> prime p \<and> \<not>p dvd l"
proof -
  from assms have "n > 1"
    using Carmichael_number_gt_3[of n] by simp
  have "squarefree n"
    using Carmichael_number_imp_squarefree assms
    by blast

  obtain p l where "p * l = n" "prime p" "1 < p"
    using assms prime_divisor_exists_strong_nat prime_gt_1_nat
    unfolding Carmichael_number_def by blast

  then have "multiplicity p n = 1"
    using \<open>1 < n\<close> \<open>squarefree n\<close> and multiplicity_eq_zero_iff[of n p] squarefree_factorial_semiring''[of n]
    by auto

  then have "\<not>p dvd l"
    using \<open>1 < n\<close> \<open>prime p\<close> \<open>p * l = n\<close> multiplicity_decompose'[of n p]
    by force

  show ?thesis
    using \<open>p * l = n\<close> \<open>prime p\<close> \<open>\<not>p dvd l\<close>
    by blast
qed

theorem Carmichael_number_odd:
  assumes "Carmichael_number n"
  shows   "odd n"
proof (rule ccontr)
  assume "\<not> odd n"
  hence "even n" by simp
  from assms have "n \<ge> 4" using Carmichael_number_gt_3[of n] by simp
  have "[(n - 1) ^ (n - 1) = n - 1] (mod n)"
    using \<open>even n\<close> and \<open>n \<ge> 4\<close> by (intro odd_pow_cong) auto

  then have "[(n - 1) ^ (n - 1) \<noteq> 1] (mod n)"
    using cong_trans[of 1 "(n - 1) ^ (n - 1)" n "n-1", OF cong_sym] \<open>4 \<le> n\<close>
    by (auto simp: cong_def)

  moreover have "coprime (n - 1) n"
    using \<open>n \<ge> 4\<close> coprime_diff_one_left_nat[of n] by auto

  ultimately show False
    using assms unfolding Carmichael_number_def by blast
qed

lemma Carmichael_number_imp_squarefree_alt:
  assumes "Carmichael_number n"
  shows "\<exists>p l. (n = p * l) \<and> prime p \<and> \<not>p dvd l \<and> 2 < l"
proof -
  obtain p l where [simp]: "(n = p * l)" and "prime p" "\<not>p dvd l"
    using Carmichael_number_imp_squarefree_alt_weak and assms by blast

  moreover have "odd n" using Carmichael_number_odd and assms by blast

  consider "l = 0 \<or> l = 2" | "l = 1" | "2 < l"
    by fastforce

  then have "2 < l"
  proof cases
    case 1
    then show ?thesis
      using \<open>odd n\<close> by auto
  next
    case 2
    then show ?thesis
      using \<open>n = p * l\<close> \<open>prime p\<close> \<open>Carmichael_number n\<close>
      unfolding Carmichael_number_def by simp
  qed simp

  ultimately show ?thesis by blast
qed

lemma Carmichael_number_imp_dvd:
  fixes n :: nat
  assumes Carmichael_number: "Carmichael_number n" and "prime p" "p dvd n"
  shows "p - 1 dvd n - 1"
proof -
  have "\<not>prime n" using Carmichael_number unfolding Carmichael_number_def by blast
  obtain u where "n = p * u" using \<open>p dvd n\<close> by blast
  have "squarefree n" using Carmichael_number_imp_squarefree assms by blast
  then have "\<not>p dvd u"
    using \<open>prime p\<close> not_prime_unit[of p]
    unfolding power2_eq_square squarefree_def \<open>n = p * u\<close>
    by fastforce

  define R where "R = Residues_nat p"
  interpret residues_nat_prime p R
    by unfold_locales (simp_all only: \<open>prime p\<close> R_def)

  obtain a where a: "a \<in> {0<..<p}" "units.ord a = p - 1"
    using residues_prime_cyclic' \<open>prime p\<close> by metis
  from a have "a \<in> totatives p" by (auto simp: totatives_prime \<open>prime p\<close>)

  have "coprime p u"
    using \<open>prime p\<close> \<open>\<not> p dvd u\<close>
    by (simp add: prime_imp_coprime_nat)

  then obtain x where "[x = a] (mod p)" "[x = 1] (mod u)"
    using binary_chinese_remainder_nat[of p u a 1] by blast

  have "coprime x p"
    using \<open>a \<in> totatives p\<close> and cong_imp_coprime[OF cong_sym[OF \<open>[x = a] (mod p)\<close>]]
    by (simp add: coprime_commute totatives_def)
  moreover have "coprime x u"
    using coprime_1_left and cong_imp_coprime[OF cong_sym[OF \<open>[x = 1] (mod u)\<close>]] by blast
  ultimately have "coprime x n"
    by (simp add: \<open>n = p * u\<close>)

  have "[a ^ (n - 1) = x ^ (n - 1)] (mod p)"
    using \<open>[x = a] (mod p)\<close> by (intro cong_pow) (auto simp: cong_sym_eq)
  also have "[x ^ (n - 1) = 1] (mod n)"
    using Carmichael_number \<open>coprime x n\<close> unfolding Carmichael_number_def by blast
  then have "[x ^ (n - 1) = 1] (mod p)"
    using \<open>n = p * u\<close> cong_modulus_mult_nat by blast
  finally have "ord p a dvd n - 1"
    by (simp add: ord_divides [symmetric])
  also have "ord p a = p - 1"
    using a \<open>a \<in> totatives p\<close> by (simp add: units.ord_residue_mult_group)
  finally show ?thesis .
qed

text \<open>
  The following lemma is also called Korselt's criterion.
\<close>
lemma Carmichael_numberI:
  fixes n :: nat
  assumes "\<not> prime n" "squarefree n" "1 < n" and
          DIV: "\<And>p. p \<in> prime_factors n \<Longrightarrow> p - 1 dvd n - 1"
  shows   "Carmichael_number n"
  unfolding Carmichael_number_def
proof (intro assms conjI allI impI)
  fix a :: nat assume "coprime a n"

  have n: "n = \<Prod>(prime_factors n)"
    using prime_factorization_nat and squarefree_factorial_semiring'[of n] \<open>1 < n\<close> \<open>squarefree n\<close>
    by fastforce

  have "x \<in># prime_factorization n \<Longrightarrow> y \<in># prime_factorization n \<Longrightarrow> x \<noteq> y \<Longrightarrow> coprime x y" for x y
    using in_prime_factors_imp_prime primes_coprime
    by blast

  moreover {
    fix p
    assume p: "p \<in># prime_factorization n"

    have "\<not>p dvd a"
      using \<open>coprime a n\<close> p coprime_common_divisor_nat[of a n p]
      by (auto simp: in_prime_factors_iff)
    with p have "[a ^ (p - 1) = 1] (mod p)"
      by (intro fermat_theorem) auto
    hence "ord p a dvd p - 1"
      by (subst (asm) ord_divides)
    also from p have "p - 1 dvd n - 1"
      by (rule DIV)
    finally have "[a ^ (n - 1) = 1] (mod p)"
      by (subst ord_divides)
  }

  ultimately show "[a ^ (n - 1) = 1] (mod n)"
    using n coprime_cong_prod_nat by metis
qed

theorem Carmichael_number_iff:
  "Carmichael_number n \<longleftrightarrow>
     n \<noteq> 1 \<and> \<not>prime n \<and> squarefree n \<and> (\<forall>p\<in>prime_factors n. p - 1 dvd n - 1)"
proof -
  consider "n = 0" | "n = 1" | "n > 1" by force
  thus ?thesis using Carmichael_numberI[of n] Carmichael_number_imp_dvd[of n]
    by cases (auto simp: Carmichael_number_not_prime Carmichael_number_imp_squarefree)
qed

text \<open>
  Every Carmichael number has at least three distinct prime factors.
\<close>
theorem Carmichael_number_card_prime_factors:
  assumes "Carmichael_number n"
  shows   "card (prime_factors n) \<ge> 3"
proof (rule ccontr)
  from assms have "n > 3"
    using Carmichael_number_gt_3[of n] by simp
  assume "\<not>(card (prime_factors n) \<ge> 3)"
  moreover have "card (prime_factors n) \<noteq> 0"
    using assms Carmichael_number_gt_3[of n] by (auto simp: prime_factorization_empty_iff)
  moreover have "card (prime_factors n) \<noteq> 1"
    using assms by (auto simp: one_prime_factor_iff_primepow Carmichael_not_primepow)
  ultimately have "card (prime_factors n) = 2"
    by linarith
  then obtain p q where pq: "prime_factors n = {p, q}" "p \<noteq> q"
    by (auto simp: card_Suc_eq numeral_2_eq_2)
  hence "prime p" "prime q" by (auto simp: in_prime_factors_iff)

  have "n = \<Prod>(prime_factors n)"
    using assms by (subst squarefree_imp_prod_prime_factors_eq)
                   (auto simp: Carmichael_number_imp_squarefree)
  with pq have n_eq: "n = p * q" by simp

  have "p - 1 dvd n - 1" and "q - 1 dvd n - 1" using assms pq
    unfolding Carmichael_number_iff by blast+
  with \<open>prime p\<close> \<open>prime q\<close> \<open>n = p * q\<close> \<open>p \<noteq> q\<close> show False
  proof (induction p q rule: linorder_wlog)
    case (le p q)
    hence "p < q" by auto
    have "[q = 1] (mod q - 1)"
      using prime_gt_1_nat[of q] \<open>prime q\<close> by (simp add: cong_def le_mod_geq)
    hence "[p * q - 1 = p * 1 - 1] (mod q - 1)"
      using le prime_gt_1_nat[of p] by (intro cong_diff_nat cong_mult) auto
    hence "[p - 1 = n - 1] (mod q - 1)"
      by (simp add: \<open>n = p * q\<close> cong_sym_eq)
    also have "[n - 1 = 0] (mod q - 1)"
      using le by (simp add: cong_def)
    finally have "(p - 1) mod (q - 1) = 0"
      by (simp add: cong_def)
    also have "(p - 1) mod (q - 1) = p - 1"
      using prime_gt_1_nat[of p] \<open>prime p\<close> \<open>p < q\<close> by (intro mod_less) auto
    finally show False
      using prime_gt_1_nat[of p] \<open>prime p\<close> by simp
  qed (simp_all add: mult.commute)
qed

lemma Carmichael_number_iff':
  fixes n :: nat
  defines "P \<equiv> prime_factorization n"
  shows "Carmichael_number n \<longleftrightarrow>
           n > 1 \<and> size P \<noteq> 1 \<and> (\<forall>p\<in>#P. count P p = 1 \<and> p - 1 dvd n - 1)"
  unfolding Carmichael_number_iff
  by (cases "n = 0") (auto simp: P_def squarefree_factorial_semiring' count_prime_factorization)

text \<open>
  The smallest Carmichael number is 561, and it was found and proven so by
  Carmichael in 1910~\<^cite>\<open>"carmichael1910note"\<close>.
\<close>
lemma Carmichael_number_561: "Carmichael_number 561" (is "Carmichael_number ?n")
proof -
  have [simp]: "prime_factorization (561 :: nat) = {#3, 11, 17#}"
    by (rule prime_factorization_eqI) auto
  show ?thesis by (subst Carmichael_number_iff') auto
qed

end


(*
    $Id: ex.thy,v 1.2 2004/11/23 15:14:34 webertj Exp $
    Author: Gerwin Klein
*)

header {* Sorting with Lists and Trees *}

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

text {*
  For simplicity we sort natural numbers.
*}

subsubsection {* Sorting with lists *}

text {*
  The task is to define insertion sort and prove its correctness.  The
  following functions are required:
*}

consts
  insort :: "nat \<Rightarrow> nat list \<Rightarrow> nat list"
  sort   :: "nat list \<Rightarrow> nat list"
  le     :: "nat \<Rightarrow> nat list \<Rightarrow> bool"
  sorted :: "nat list \<Rightarrow> bool"

text {*
  In your definition, @{term "insort x xs"} should insert a number @{term x}
  into an already sorted list @{text xs}, and @{term "sort ys"} should build on
  @{text insort} to produce the sorted version of @{text ys}.

  To show that the resulting list is indeed sorted we need a predicate @{term
  sorted} that checks if each element in the list is less or equal to the
  following ones; @{term "le n xs"} should be true iff @{term n} is less or
  equal to all elements of @{text xs}.
*}

text {*
  Start out by showing a monotonicity property of @{term le}.  For technical
  reasons the lemma should be phrased as follows:
*}

text {*
  Now show the following correctness theorem:
*}

theorem "sorted (sort xs)"
(*<*) oops (*>*)

text {*
  This theorem alone is too weak.  It does not guarantee that the sorted list
  contains the same elements as the input.  In the worst case, @{term sort}
  might always return @{term"[]"}~-- surely an undesirable implementation of
  sorting.

  Define a function @{term "count xs x"} that counts how often @{term x} occurs
  in @{term xs}.
*}

text {*
  Show that
*}

theorem "count (sort xs) x = count xs x"
(*<*) oops (*>*)

subsubsection {* Sorting with trees *}

text {*
  Our second sorting algorithm uses trees.  Thus you should first define a data
  type @{text bintree} of binary trees that are either empty or consist of a
  node carrying a natural number and two subtrees.
*}

text {*
  Define a function @{text tsorted} that checks if a binary tree is sorted.  It
  is convenient to employ two auxiliary functions @{text tge}/@{text tle} that
  test whether a number is greater-or-equal/less-or-equal to all elements of a
  tree.

  Finally define a function @{text tree_of} that turns a list into a sorted
  tree.  It is helpful to base @{text tree_of} on a function @{term "ins n b"}
  that inserts a number @{term n} into a sorted tree @{term b}.
*}

text {*
  Show
*}

theorem [simp]: "tsorted (tree_of xs)"
(*<*) oops (*>*)

text {*
  Again we have to show that no elements are lost (or added).  As for lists,
  define a function @{term "tcount x b"} that counts the number of occurrences
  of the number @{term x} in the tree @{term b}.
*}

text {*
  Show
*}

theorem "tcount (tree_of xs) x = count xs x"
(*<*) oops (*>*)

text {*
  Now we are ready to sort lists.  We know how to produce an ordered tree from
  a list.  Thus we merely need a function @{text list_of} that turns an
  (ordered) tree into an (ordered) list.  Define this function and prove
*}

theorem "sorted (list_of (tree_of xs))"
(*<*) oops (*>*)

theorem "count (list_of (tree_of xs)) n = count xs n"
(*<*) oops (*>*)

text {*
  Hints:
  \begin{itemize}
  \item
  Try to formulate all your lemmas as equations rather than implications
  because that often simplifies their proof.  Make sure that the right-hand
  side is (in some sense) simpler than the left-hand side.
  \item
  Eventually you need to relate @{text sorted} and @{text tsorted}.  This is
  facilitated by a function @{text ge} on lists (analogously to @{text tge} on
  trees) and the following lemma (that you will need to prove):\\
  @{term[display] "sorted (a@x#b) = (sorted a \<and> sorted b \<and> ge x a
  \<and> le x b)"}
  \end{itemize}
*}

(*<*) end (*>*)


(*  Title:      HOL/Algebra/Sylow.thy
    Author:     Florian Kammueller, with new proofs by L C Paulson
*)

theory Sylow
imports Coset Exponent
begin

text \<open>
  See also @{cite "Kammueller-Paulson:1999"}.
\<close>

text\<open>The combinatorial argument is in theory Exponent\<close>

lemma le_extend_mult:
  fixes c::nat shows "\<lbrakk>0 < c; a \<le> b\<rbrakk> \<Longrightarrow> a \<le> b * c"
by (metis divisors_zero dvd_triv_left leI less_le_trans nat_dvd_not_less zero_less_iff_neq_zero)

locale sylow = group +
  fixes p and a and m and calM and RelM
  assumes prime_p:   "prime p"
      and order_G:   "order(G) = (p^a) * m"
      and finite_G [iff]:  "finite (carrier G)"
  defines "calM == {s. s \<subseteq> carrier(G) & card(s) = p^a}"
      and "RelM == {(N1,N2). N1 \<in> calM & N2 \<in> calM &
                             (\<exists>g \<in> carrier(G). N1 = (N2 #> g) )}"
begin

lemma RelM_refl_on: "refl_on calM RelM"
apply (auto simp add: refl_on_def RelM_def calM_def)
apply (blast intro!: coset_mult_one [symmetric])
done

lemma RelM_sym: "sym RelM"
proof (unfold sym_def RelM_def, clarify)
  fix y g
  assume   "y \<in> calM"
    and g: "g \<in> carrier G"
  hence "y = y #> g #> (inv g)" by (simp add: coset_mult_assoc calM_def)
  thus "\<exists>g'\<in>carrier G. y = y #> g #> g'" by (blast intro: g)
qed

lemma RelM_trans: "trans RelM"
by (auto simp add: trans_def RelM_def calM_def coset_mult_assoc)

lemma RelM_equiv: "equiv calM RelM"
apply (unfold equiv_def)
apply (blast intro: RelM_refl_on RelM_sym RelM_trans)
done

lemma M_subset_calM_prep: "M' \<in> calM // RelM  ==> M' \<subseteq> calM"
apply (unfold RelM_def)
apply (blast elim!: quotientE)
done

end

subsection\<open>Main Part of the Proof\<close>

locale sylow_central = sylow +
  fixes H and M1 and M
  assumes M_in_quot:  "M \<in> calM // RelM"
      and not_dvd_M:  "~(p ^ Suc(multiplicity p m) dvd card(M))"
      and M1_in_M:    "M1 \<in> M"
  defines "H == {g. g\<in>carrier G & M1 #> g = M1}"

begin

lemma M_subset_calM: "M \<subseteq> calM"
  by (rule M_in_quot [THEN M_subset_calM_prep])

lemma card_M1: "card(M1) = p^a"
  using M1_in_M M_subset_calM calM_def by blast

lemma exists_x_in_M1: "\<exists>x. x \<in> M1"
using prime_p [THEN prime_gt_Suc_0_nat] card_M1
by (metis Suc_lessD card_eq_0_iff empty_subsetI equalityI gr_implies_not0 nat_zero_less_power_iff subsetI)

lemma M1_subset_G [simp]: "M1 \<subseteq> carrier G"
  using M1_in_M  M_subset_calM calM_def mem_Collect_eq subsetCE by blast

lemma M1_inj_H: "\<exists>f \<in> H\<rightarrow>M1. inj_on f H"
proof -
  from exists_x_in_M1 obtain m1 where m1M: "m1 \<in> M1"..
  have m1G: "m1 \<in> carrier G" by (simp add: m1M M1_subset_G [THEN subsetD])
  show ?thesis
  proof
    show "inj_on (\<lambda>z\<in>H. m1 \<otimes> z) H"
      by (simp add: inj_on_def l_cancel [of m1 x y, THEN iffD1] H_def m1G)
    show "restrict (op \<otimes> m1) H \<in> H \<rightarrow> M1"
    proof (rule restrictI)
      fix z assume zH: "z \<in> H"
      show "m1 \<otimes> z \<in> M1"
      proof -
        from zH
        have zG: "z \<in> carrier G" and M1zeq: "M1 #> z = M1"
          by (auto simp add: H_def)
        show ?thesis
          by (rule subst [OF M1zeq], simp add: m1M zG rcosI)
      qed
    qed
  qed
qed

end

subsection\<open>Discharging the Assumptions of \<open>sylow_central\<close>\<close>

context sylow
begin

lemma EmptyNotInEquivSet: "{} \<notin> calM // RelM"
by (blast elim!: quotientE dest: RelM_equiv [THEN equiv_class_self])

lemma existsM1inM: "M \<in> calM // RelM ==> \<exists>M1. M1 \<in> M"
  using RelM_equiv equiv_Eps_in by blast

lemma zero_less_o_G: "0 < order(G)"
  by (simp add: order_def card_gt_0_iff carrier_not_empty)

lemma zero_less_m: "m > 0"
  using zero_less_o_G by (simp add: order_G)

lemma card_calM: "card(calM) = (p^a) * m choose p^a"
by (simp add: calM_def n_subsets order_G [symmetric] order_def)

lemma zero_less_card_calM: "card calM > 0"
by (simp add: card_calM zero_less_binomial le_extend_mult zero_less_m)

lemma max_p_div_calM:
     "~ (p ^ Suc(multiplicity p m) dvd card(calM))"
proof
  assume "p ^ Suc (multiplicity p m) dvd card calM"
  with zero_less_card_calM prime_p
  have "Suc (multiplicity p m) \<le> multiplicity p (card calM)"
    by (intro multiplicity_geI) auto
  hence "multiplicity p m < multiplicity p (card calM)" by simp
  also have "multiplicity p m = multiplicity p (card calM)"
    by (simp add: const_p_fac prime_p zero_less_m card_calM)
  finally show False by simp
qed

lemma finite_calM: "finite calM"
  unfolding calM_def
  by (rule_tac B = "Pow (carrier G) " in finite_subset) auto

lemma lemma_A1:
     "\<exists>M \<in> calM // RelM. ~ (p ^ Suc(multiplicity p m) dvd card(M))"
  using RelM_equiv equiv_imp_dvd_card finite_calM max_p_div_calM by blast

end

subsubsection\<open>Introduction and Destruct Rules for @{term H}\<close>

lemma (in sylow_central) H_I: "[|g \<in> carrier G; M1 #> g = M1|] ==> g \<in> H"
by (simp add: H_def)

lemma (in sylow_central) H_into_carrier_G: "x \<in> H ==> x \<in> carrier G"
by (simp add: H_def)

lemma (in sylow_central) in_H_imp_eq: "g : H ==> M1 #> g = M1"
by (simp add: H_def)

lemma (in sylow_central) H_m_closed: "[| x\<in>H; y\<in>H|] ==> x \<otimes> y \<in> H"
apply (unfold H_def)
apply (simp add: coset_mult_assoc [symmetric])
done

lemma (in sylow_central) H_not_empty: "H \<noteq> {}"
apply (simp add: H_def)
apply (rule exI [of _ \<one>], simp)
done

lemma (in sylow_central) H_is_subgroup: "subgroup H G"
apply (rule subgroupI)
apply (rule subsetI)
apply (erule H_into_carrier_G)
apply (rule H_not_empty)
apply (simp add: H_def, clarify)
apply (erule_tac P = "%z. lhs(z) = M1" for lhs in subst)
apply (simp add: coset_mult_assoc )
apply (blast intro: H_m_closed)
done

lemma (in sylow_central) rcosetGM1g_subset_G:
     "[| g \<in> carrier G; x \<in> M1 #>  g |] ==> x \<in> carrier G"
by (blast intro: M1_subset_G [THEN r_coset_subset_G, THEN subsetD])

lemma (in sylow_central) finite_M1: "finite M1"
by (rule finite_subset [OF M1_subset_G finite_G])

lemma (in sylow_central) finite_rcosetGM1g: "g\<in>carrier G ==> finite (M1 #> g)"
  using rcosetGM1g_subset_G finite_G M1_subset_G cosets_finite rcosetsI by blast

lemma (in sylow_central) M1_cardeq_rcosetGM1g:
     "g \<in> carrier G ==> card(M1 #> g) = card(M1)"
by (simp (no_asm_simp) add: card_cosets_equal rcosetsI)

lemma (in sylow_central) M1_RelM_rcosetGM1g:
     "g \<in> carrier G ==> (M1, M1 #> g) \<in> RelM"
apply (simp add: RelM_def calM_def card_M1)
apply (rule conjI)
 apply (blast intro: rcosetGM1g_subset_G)
apply (simp add: card_M1 M1_cardeq_rcosetGM1g)
apply (metis M1_subset_G coset_mult_assoc coset_mult_one r_inv_ex)
done

subsection\<open>Equal Cardinalities of @{term M} and the Set of Cosets\<close>

text\<open>Injections between @{term M} and @{term "rcosets\<^bsub>G\<^esub> H"} show that
 their cardinalities are equal.\<close>

lemma ElemClassEquiv:
     "[| equiv A r; C \<in> A // r |] ==> \<forall>x \<in> C. \<forall>y \<in> C. (x,y)\<in>r"
by (unfold equiv_def quotient_def sym_def trans_def, blast)

lemma (in sylow_central) M_elem_map:
     "M2 \<in> M ==> \<exists>g. g \<in> carrier G & M1 #> g = M2"
apply (cut_tac M1_in_M M_in_quot [THEN RelM_equiv [THEN ElemClassEquiv]])
apply (simp add: RelM_def)
apply (blast dest!: bspec)
done

lemmas (in sylow_central) M_elem_map_carrier =
        M_elem_map [THEN someI_ex, THEN conjunct1]

lemmas (in sylow_central) M_elem_map_eq =
        M_elem_map [THEN someI_ex, THEN conjunct2]

lemma (in sylow_central) M_funcset_rcosets_H:
     "(%x:M. H #> (SOME g. g \<in> carrier G & M1 #> g = x)) \<in> M \<rightarrow> rcosets H"
  by (metis (lifting) H_is_subgroup M_elem_map_carrier rcosetsI restrictI subgroup_imp_subset)

lemma (in sylow_central) inj_M_GmodH: "\<exists>f \<in> M \<rightarrow> rcosets H. inj_on f M"
apply (rule bexI)
apply (rule_tac [2] M_funcset_rcosets_H)
apply (rule inj_onI, simp)
apply (rule trans [OF _ M_elem_map_eq])
prefer 2 apply assumption
apply (rule M_elem_map_eq [symmetric, THEN trans], assumption)
apply (rule coset_mult_inv1)
apply (erule_tac [2] M_elem_map_carrier)+
apply (rule_tac [2] M1_subset_G)
apply (rule coset_join1 [THEN in_H_imp_eq])
apply (rule_tac [3] H_is_subgroup)
prefer 2 apply (blast intro: M_elem_map_carrier)
apply (simp add: coset_mult_inv2 H_def M_elem_map_carrier subset_eq)
done

subsubsection\<open>The Opposite Injection\<close>

lemma (in sylow_central) H_elem_map:
     "H1 \<in> rcosets H ==> \<exists>g. g \<in> carrier G & H #> g = H1"
by (auto simp add: RCOSETS_def)

lemmas (in sylow_central) H_elem_map_carrier =
        H_elem_map [THEN someI_ex, THEN conjunct1]

lemmas (in sylow_central) H_elem_map_eq =
        H_elem_map [THEN someI_ex, THEN conjunct2]

lemma (in sylow_central) rcosets_H_funcset_M:
  "(\<lambda>C \<in> rcosets H. M1 #> (@g. g \<in> carrier G \<and> H #> g = C)) \<in> rcosets H \<rightarrow> M"
apply (simp add: RCOSETS_def)
apply (fast intro: someI2
            intro!: M1_in_M in_quotient_imp_closed [OF RelM_equiv M_in_quot _  M1_RelM_rcosetGM1g])
done

text\<open>close to a duplicate of \<open>inj_M_GmodH\<close>\<close>
lemma (in sylow_central) inj_GmodH_M:
     "\<exists>g \<in> rcosets H\<rightarrow>M. inj_on g (rcosets H)"
apply (rule bexI)
apply (rule_tac [2] rcosets_H_funcset_M)
apply (rule inj_onI)
apply (simp)
apply (rule trans [OF _ H_elem_map_eq])
prefer 2 apply assumption
apply (rule H_elem_map_eq [symmetric, THEN trans], assumption)
apply (rule coset_mult_inv1)
apply (erule_tac [2] H_elem_map_carrier)+
apply (rule_tac [2] H_is_subgroup [THEN subgroup.subset])
apply (rule coset_join2)
apply (blast intro: H_elem_map_carrier)
apply (rule H_is_subgroup)
apply (simp add: H_I coset_mult_inv2 H_elem_map_carrier)
done

lemma (in sylow_central) calM_subset_PowG: "calM \<subseteq> Pow(carrier G)"
by (auto simp add: calM_def)

lemma (in sylow_central) finite_M: "finite M"
by (metis M_subset_calM finite_calM rev_finite_subset)

lemma (in sylow_central) cardMeqIndexH: "card(M) = card(rcosets H)"
apply (insert inj_M_GmodH inj_GmodH_M)
apply (blast intro: card_bij finite_M H_is_subgroup
             rcosets_subset_PowG [THEN finite_subset]
             finite_Pow_iff [THEN iffD2])
done

lemma (in sylow_central) index_lem: "card(M) * card(H) = order(G)"
by (simp add: cardMeqIndexH lagrange H_is_subgroup)

lemma (in sylow_central) lemma_leq1: "p^a \<le> card(H)"
apply (rule dvd_imp_le)
 apply (rule div_combine [OF prime_imp_prime_elem[OF prime_p] not_dvd_M])
 prefer 2 apply (blast intro: subgroup.finite_imp_card_positive H_is_subgroup)
apply (simp add: index_lem order_G power_add mult_dvd_mono multiplicity_dvd
                 zero_less_m)
done

lemma (in sylow_central) lemma_leq2: "card(H) \<le> p^a"
apply (subst card_M1 [symmetric])
apply (cut_tac M1_inj_H)
apply (blast intro!: M1_subset_G intro:
             card_inj H_into_carrier_G finite_subset [OF _ finite_G])
done

lemma (in sylow_central) card_H_eq: "card(H) = p^a"
by (blast intro: le_antisym lemma_leq1 lemma_leq2)

lemma (in sylow) sylow_thm: "\<exists>H. subgroup H G & card(H) = p^a"
apply (cut_tac lemma_A1, clarify)
apply (frule existsM1inM, clarify)
apply (subgoal_tac "sylow_central G p a m M1 M")
 apply (blast dest:  sylow_central.H_is_subgroup sylow_central.card_H_eq)
apply (simp add: sylow_central_def sylow_central_axioms_def sylow_axioms calM_def RelM_def)
done

text\<open>Needed because the locale's automatic definition refers to
   @{term "semigroup G"} and @{term "group_axioms G"} rather than
  simply to @{term "group G"}.\<close>
lemma sylow_eq: "sylow G p a m = (group G & sylow_axioms G p a m)"
by (simp add: sylow_def group_def)

subsection \<open>Sylow's Theorem\<close>

theorem sylow_thm:
     "[| prime p;  group(G);  order(G) = (p^a) * m; finite (carrier G)|]
      ==> \<exists>H. subgroup H G & card(H) = p^a"
apply (rule sylow.sylow_thm [of G p a m])
apply (simp add: sylow_eq sylow_axioms_def)
done

end


(* Author: Tobias Nipkow *)
(* Todo:
 (min_)height of balanced trees via floorlog
 minimal path_len of balanced trees
*)

section \<open>Binary Tree\<close>

theory Tree
imports Main
begin

datatype 'a tree =
  is_Leaf: Leaf ("\<langle>\<rangle>") |
  Node (left: "'a tree") (val: 'a) (right: "'a tree") ("(1\<langle>_,/ _,/ _\<rangle>)")
  where
    "left Leaf = Leaf"
  | "right Leaf = Leaf"
datatype_compat tree

text\<open>Can be seen as counting the number of leaves rather than nodes:\<close>

definition size1 :: "'a tree \<Rightarrow> nat" where
"size1 t = size t + 1"

fun subtrees :: "'a tree \<Rightarrow> 'a tree set" where
"subtrees \<langle>\<rangle> = {\<langle>\<rangle>}" |
"subtrees (\<langle>l, a, r\<rangle>) = insert \<langle>l, a, r\<rangle> (subtrees l \<union> subtrees r)"

fun mirror :: "'a tree \<Rightarrow> 'a tree" where
"mirror \<langle>\<rangle> = Leaf" |
"mirror \<langle>l,x,r\<rangle> = \<langle>mirror r, x, mirror l\<rangle>"

class height = fixes height :: "'a \<Rightarrow> nat"

instantiation tree :: (type)height
begin

fun height_tree :: "'a tree => nat" where
"height Leaf = 0" |
"height (Node t1 a t2) = max (height t1) (height t2) + 1"

instance ..

end

fun min_height :: "'a tree \<Rightarrow> nat" where
"min_height Leaf = 0" |
"min_height (Node l _ r) = min (min_height l) (min_height r) + 1"

fun complete :: "'a tree \<Rightarrow> bool" where
"complete Leaf = True" |
"complete (Node l x r) = (complete l \<and> complete r \<and> height l = height r)"

definition balanced :: "'a tree \<Rightarrow> bool" where
"balanced t = (height t - min_height t \<le> 1)"

text \<open>Weight balanced:\<close>
fun wbalanced :: "'a tree \<Rightarrow> bool" where
"wbalanced Leaf = True" |
"wbalanced (Node l x r) = (abs(int(size l) - int(size r)) \<le> 1 \<and> wbalanced l \<and> wbalanced r)"

text \<open>Internal path length:\<close>
fun path_len :: "'a tree \<Rightarrow> nat" where
"path_len Leaf = 0 " |
"path_len (Node l _ r) = path_len l + size l + path_len r + size r"

fun preorder :: "'a tree \<Rightarrow> 'a list" where
"preorder \<langle>\<rangle> = []" |
"preorder \<langle>l, x, r\<rangle> = x # preorder l @ preorder r"

fun inorder :: "'a tree \<Rightarrow> 'a list" where
"inorder \<langle>\<rangle> = []" |
"inorder \<langle>l, x, r\<rangle> = inorder l @ [x] @ inorder r"

text\<open>A linear version avoiding append:\<close>
fun inorder2 :: "'a tree \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"inorder2 \<langle>\<rangle> xs = xs" |
"inorder2 \<langle>l, x, r\<rangle> xs = inorder2 l (x # inorder2 r xs)"

text\<open>Binary Search Tree:\<close>
fun (in linorder) bst :: "'a tree \<Rightarrow> bool" where
"bst \<langle>\<rangle> \<longleftrightarrow> True" |
"bst \<langle>l, a, r\<rangle> \<longleftrightarrow> bst l \<and> bst r \<and> (\<forall>x\<in>set_tree l. x < a) \<and> (\<forall>x\<in>set_tree r. a < x)"

text\<open>Binary Search Tree with duplicates:\<close>
fun (in linorder) bst_eq :: "'a tree \<Rightarrow> bool" where
"bst_eq \<langle>\<rangle> \<longleftrightarrow> True" |
"bst_eq \<langle>l,a,r\<rangle> \<longleftrightarrow>
 bst_eq l \<and> bst_eq r \<and> (\<forall>x\<in>set_tree l. x \<le> a) \<and> (\<forall>x\<in>set_tree r. a \<le> x)"

fun (in linorder) heap :: "'a tree \<Rightarrow> bool" where
"heap Leaf = True" |
"heap (Node l m r) =
  (heap l \<and> heap r \<and> (\<forall>x \<in> set_tree l \<union> set_tree r. m \<le> x))"

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

lemma size1_simps[simp]:
  "size1 \<langle>\<rangle> = 1"
  "size1 \<langle>l, x, r\<rangle> = size1 l + size1 r"
by (simp_all add: size1_def)

lemma size1_ge0[simp]: "0 < size1 t"
by (simp add: size1_def)

lemma size_0_iff_Leaf: "size t = 0 \<longleftrightarrow> t = Leaf"
by(cases t) auto

lemma neq_Leaf_iff: "(t \<noteq> \<langle>\<rangle>) = (\<exists>l a r. t = \<langle>l, a, r\<rangle>)"
by (cases t) auto

lemma finite_set_tree[simp]: "finite(set_tree t)"
by(induction t) auto

lemma size_map_tree[simp]: "size (map_tree f t) = size t"
by (induction t) auto

lemma size1_map_tree[simp]: "size1 (map_tree f t) = size1 t"
by (simp add: size1_def)

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

lemma set_treeE: "a \<in> set_tree t \<Longrightarrow> \<exists>l r. \<langle>l, a, r\<rangle> \<in> subtrees t"
by (induction t)(auto)

lemma Node_notin_subtrees_if[simp]: "a \<notin> set_tree t \<Longrightarrow> Node l a r \<notin> subtrees t"
by (induction t) auto

lemma in_set_tree_if: "\<langle>l, a, r\<rangle> \<in> subtrees t \<Longrightarrow> a \<in> set_tree t"
by (metis Node_notin_subtrees_if)

subsection \<open>@{const height} and @{const min_height}\<close>

lemma height_0_iff_Leaf: "height t = 0 \<longleftrightarrow> t = Leaf"
by(cases t) auto

lemma height_map_tree[simp]: "height (map_tree f t) = height t"
by (induction t) auto

lemma height_le_size_tree: "height t \<le> size (t::'a tree)"
by (induction t) auto

lemma size1_height: "size t + 1 \<le> 2 ^ height (t::'a tree)"
proof(induction t)
  case (Node l a r)
  show ?case
  proof (cases "height l \<le> height r")
    case True
    have "size(Node l a r) + 1 = (size l + 1) + (size r + 1)" by simp
    also have "size l + 1 \<le> 2 ^ height l" by(rule Node.IH(1))
    also have "size r + 1 \<le> 2 ^ height r" by(rule Node.IH(2))
    also have "(2::nat) ^ height l \<le> 2 ^ height r" using True by simp
    finally show ?thesis using True by (auto simp: max_def mult_2)
  next
    case False
    have "size(Node l a r) + 1 = (size l + 1) + (size r + 1)" by simp
    also have "size l + 1 \<le> 2 ^ height l" by(rule Node.IH(1))
    also have "size r + 1 \<le> 2 ^ height r" by(rule Node.IH(2))
    also have "(2::nat) ^ height r \<le> 2 ^ height l" using False by simp
    finally show ?thesis using False by (auto simp: max_def mult_2)
  qed
qed simp

corollary size_height: "size t \<le> 2 ^ height (t::'a tree) - 1"
using size1_height[of t] by(arith)

lemma height_subtrees: "s \<in> subtrees t \<Longrightarrow> height s \<le> height t"
by (induction t) auto

lemma min_hight_le_height: "min_height t \<le> height t"
by(induction t) auto

lemma min_height_map_tree[simp]: "min_height (map_tree f t) = min_height t"
by (induction t) auto

lemma min_height_le_size1: "2 ^ min_height t \<le> size t + 1"
proof(induction t)
  case (Node l a r)
  have "(2::nat) ^ min_height (Node l a r) \<le> 2 ^ min_height l + 2 ^ min_height r"
    by (simp add: min_def)
  also have "\<dots> \<le> size(Node l a r) + 1" using Node.IH by simp
  finally show ?case .
qed simp

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

lemma complete_iff_height: "complete t \<longleftrightarrow> (min_height t = height t)"
apply(induction t)
 apply simp
apply (simp add: min_def max_def)
by (metis le_antisym le_trans min_hight_le_height)

lemma size1_if_complete: "complete t \<Longrightarrow> size1 t = 2 ^ height t"
by (induction t) auto

lemma size_if_complete: "complete t \<Longrightarrow> size t = 2 ^ height t - 1"
using size1_if_complete[simplified size1_def] by fastforce

lemma complete_if_size: "size t = 2 ^ height t - 1 \<Longrightarrow> complete t"
proof (induct "height t" arbitrary: t)
  case 0 thus ?case by (simp add: size_0_iff_Leaf)
next
  case (Suc h)
  hence "t \<noteq> Leaf" by auto
  then obtain l a r where [simp]: "t = Node l a r"
    by (auto simp: neq_Leaf_iff)
  have 1: "height l \<le> h" and 2: "height r \<le> h" using Suc(2) by(auto)
  have 3: "~ height l < h"
  proof
    assume 0: "height l < h"
    have "size t = size l + (size r + 1)" by simp
    also note size_height[of l]
    also note size1_height[of r]
    also have "(2::nat) ^ height l - 1 < 2 ^ h - 1"
        using 0 by (simp add: diff_less_mono)
    also have "(2::nat) ^ height r \<le> 2 ^ h" using 2 by simp
    also have "(2::nat) ^ h - 1 + 2 ^ h = 2 ^ (Suc h) - 1" by (simp)
    also have "\<dots> = size t" using Suc(2,3) by simp
    finally show False by (simp add: diff_le_mono)
  qed
  have 4: "~ height r < h"
  proof
    assume 0: "height r < h"
    have "size t = (size l + 1) + size r" by simp
    also note size_height[of r]
    also note size1_height[of l]
    also have "(2::nat) ^ height r - 1 < 2 ^ h - 1"
        using 0 by (simp add: diff_less_mono)
    also have "(2::nat) ^ height l \<le> 2 ^ h" using 1 by simp
    also have "(2::nat) ^ h + (2 ^ h - 1) = 2 ^ (Suc h) - 1" by (simp)
    also have "\<dots> = size t" using Suc(2,3) by simp
    finally show False by (simp add: diff_le_mono)
  qed
  from 1 2 3 4 have *: "height l = h" "height r = h" by linarith+
  hence "size l = 2 ^ height l - 1" "size r = 2 ^ height r - 1"
    using Suc(3) size_height[of l] size_height[of r] by (auto)
  with * Suc(1) show ?case by simp
qed

lemma complete_iff_size: "complete t \<longleftrightarrow> size t = 2 ^ height t - 1"
using complete_if_size size_if_complete by blast

text\<open>A better lower bound for incomplete trees:\<close>

lemma min_height_le_size_if_incomplete:
  "\<not> complete t \<Longrightarrow> 2 ^ min_height t \<le> size t"
proof(induction t)
  case Leaf thus ?case by simp
next
  case (Node l a r)
  show ?case (is "?l \<le> ?r")
  proof (cases "complete l")
    case l: True thus ?thesis
    proof (cases "complete r")
      case r: True
      have "height l \<noteq> height r" using Node.prems l r by simp
      hence "?l < 2 ^ min_height l + 2 ^ min_height r"
        using l r by (simp add: min_def complete_iff_height)
      also have "\<dots> = (size l + 1) + (size r + 1)"
        using l r size_if_complete[where ?'a = 'a]
        by (simp add: complete_iff_height)
      also have "\<dots> \<le> ?r + 1" by simp
      finally show ?thesis by arith
    next
      case r: False
      have "?l \<le> 2 ^ min_height l + 2 ^ min_height r" by (simp add: min_def)
      also have "\<dots> \<le> size l + 1 + size r"
        using Node.IH(2)[OF r] l size_if_complete[where ?'a = 'a]
        by (simp add: complete_iff_height)
      also have "\<dots> = ?r" by simp
      finally show ?thesis .
    qed
  next
    case l: False thus ?thesis
    proof (cases "complete r")
      case r: True
      have "?l \<le> 2 ^ min_height l + 2 ^ min_height r" by (simp add: min_def)
      also have "\<dots> \<le> size l + (size r + 1)"
        using Node.IH(1)[OF l] r size_if_complete[where ?'a = 'a]
        by (simp add: complete_iff_height)
      also have "\<dots> = ?r" by simp
      finally show ?thesis .
    next
      case r: False
      have "?l \<le> 2 ^ min_height l + 2 ^ min_height r"
        by (simp add: min_def)
      also have "\<dots> \<le> size l + size r"
        using Node.IH(1)[OF l] Node.IH(2)[OF r] by (simp)
      also have "\<dots> \<le> ?r" by simp
      finally show ?thesis .
    qed
  qed
qed

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

lemma balanced_subtreeL: "balanced (Node l x r) \<Longrightarrow> balanced l"
by(simp add: balanced_def)

lemma balanced_subtreeR: "balanced (Node l x r) \<Longrightarrow> balanced r"
by(simp add: balanced_def)

lemma balanced_subtrees: "\<lbrakk> balanced t; s \<in> subtrees t \<rbrakk> \<Longrightarrow> balanced s"
using [[simp_depth_limit=1]]
by(induction t arbitrary: s)
  (auto simp add: balanced_subtreeL balanced_subtreeR)

text\<open>Balanced trees have optimal height:\<close>

lemma balanced_optimal:
fixes t :: "'a tree" and t' :: "'b tree"
assumes "balanced t" "size t \<le> size t'" shows "height t \<le> height t'"
proof (cases "complete t")
  case True
  have "(2::nat) ^ height t - 1 \<le> 2 ^ height t' - 1"
  proof -
    have "(2::nat) ^ height t - 1 = size t"
      using True by (simp add: complete_iff_height size_if_complete)
    also note assms(2)
    also have "size t' \<le> 2 ^ height t' - 1" by (rule size_height)
    finally show ?thesis .
  qed
  thus ?thesis by (simp add: le_diff_iff)
next
  case False
  have "(2::nat) ^ min_height t < 2 ^ height t'"
  proof -
    have "(2::nat) ^ min_height t \<le> size t"
      by(rule min_height_le_size_if_incomplete[OF False])
    also note assms(2)
    also have "size t' \<le> 2 ^ height t' - 1"  by(rule size_height)
    finally show ?thesis
      using power_eq_0_iff[of "2::nat" "height t'"] by linarith
  qed
  hence *: "min_height t < height t'" by simp
  have "min_height t + 1 = height t"
    using min_hight_le_height[of t] assms(1) False
    by (simp add: complete_iff_height balanced_def)
  with * show ?thesis by arith
qed

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

lemma wbalanced_subtrees: "\<lbrakk> wbalanced t; s \<in> subtrees t \<rbrakk> \<Longrightarrow> wbalanced s"
using [[simp_depth_limit=1]] by(induction t arbitrary: s) auto

(* show wbalanced \<Longrightarrow> balanced and use that in Balanced.thy *)

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

text \<open>The internal path length of a tree:\<close>

lemma path_len_if_bal: "complete t
  \<Longrightarrow> path_len t = (let n = height t in 2 + n*2^n - 2^(n+1))"
proof(induction t)
  case (Node l x r)
  have *: "2^(n+1) \<le> 2 + n*2^n" for n :: nat
    by(induction n) auto
  have **: "(0::nat) < 2^n" for n :: nat by simp
  let ?h = "height r"
  show ?case using Node *[of ?h] **[of ?h] by (simp add: size_if_complete Let_def)
qed simp

subsection "List of entries"

lemma set_inorder[simp]: "set (inorder t) = set_tree t"
by (induction t) auto

lemma set_preorder[simp]: "set (preorder t) = set_tree t"
by (induction t) auto

lemma length_preorder[simp]: "length (preorder t) = size t"
by (induction t) auto

lemma length_inorder[simp]: "length (inorder t) = size t"
by (induction t) auto

lemma preorder_map: "preorder (map_tree f t) = map f (preorder t)"
by (induction t) auto

lemma inorder_map: "inorder (map_tree f t) = map f (inorder t)"
by (induction t) auto

lemma inorder2_inorder: "inorder2 t xs = inorder t @ xs"
by (induction t arbitrary: xs) auto

subsection \<open>Binary Search Tree\<close>

lemma (in linorder) bst_eq_if_bst: "bst t \<Longrightarrow> bst_eq t"
by (induction t) (auto)

lemma (in linorder) bst_eq_imp_sorted: "bst_eq t \<Longrightarrow> sorted (inorder t)"
apply (induction t)
 apply(simp)
by (fastforce simp: sorted_append sorted_Cons intro: less_imp_le less_trans)

lemma (in linorder) distinct_preorder_if_bst: "bst t \<Longrightarrow> distinct (preorder t)"
apply (induction t)
 apply simp
apply(fastforce elim: order.asym)
done

lemma (in linorder) distinct_inorder_if_bst: "bst t \<Longrightarrow> distinct (inorder t)"
apply (induction t)
 apply simp
apply(fastforce elim: order.asym)
done

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

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

lemma mirror_Leaf[simp]: "mirror t = \<langle>\<rangle> \<longleftrightarrow> t = \<langle>\<rangle>"
by (induction t) simp_all

lemma size_mirror[simp]: "size(mirror t) = size t"
by (induction t) simp_all

lemma size1_mirror[simp]: "size1(mirror t) = size1 t"
by (simp add: size1_def)

lemma height_mirror[simp]: "height(mirror t) = height t"
by (induction t) simp_all

lemma inorder_mirror: "inorder(mirror t) = rev(inorder t)"
by (induction t) simp_all

lemma map_mirror: "map_tree f (mirror t) = mirror (map_tree f t)"
by (induction t) simp_all

lemma mirror_mirror[simp]: "mirror(mirror t) = t"
by (induction t) simp_all

end


(* Title:      Kleene Algebra
   Author:     Alasdair Armstrong, Georg Struth, Tjark Weber
   Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
               Tjark Weber <tjark.weber at it.uu.se>
*)

header {* Dioids *}

theory Dioid
imports Signatures
begin

subsection {* Join Semilattices *}

text {* Join semilattices can be axiomatised order-theoretically or
algebraically. A join semilattice (or upper semilattice) is either a
poset in which every pair of elements has a join (or least upper
bound), or a set endowed with an associative, commutative, idempotent
binary operation. It is well known that the order-theoretic definition
induces the algebraic one and vice versa. We start from the algebraic
axiomatisation because it is easily expandable to dioids, using
Isabelle's type class mechanism.

In Isabelle/HOL, a type class @{class semilattice_sup} is available.
Alas, we cannot use this type class because we need the symbol~@{text
"+"} for the join operation in the dioid expansion and subclass
proofs in Isabelle/HOL require the two type classes involved to have
the same fixed signature.

Using {\em add\_assoc} as a name for the first assumption in class
{\em join\_semilattice} would lead to name clashes: we will later
define classes that inherit from @{class semigroup_add}, which
provides its own assumption {\em add\_assoc}, and prove that these are
subclasses of {\em join\_semilattice}. Hence the primed name.
*}

class join_semilattice = plus_ord +
  assumes add_assoc' [simp]: "(x + y) + z = x + (y + z)"
  and add_comm [simp]: "x + y = y + x"
  and add_idem [simp]: "x + x = x"
begin

lemma add_left_comm [simp]:
  "b + (a + c) = a + (b + c)"
  unfolding add_assoc' [symmetric] by simp

lemma add_left_idem [simp]:
  "a + (a + b) = a + b"
  unfolding add_assoc' [symmetric] by simp

text {* The definition @{term "x \<le> y \<longleftrightarrow> x + y = y"} of the order is
hidden in class @{class plus_ord}.

We show some simple order-based properties of semilattices. The
first one states that every semilattice is a partial order. *}

subclass order
proof
  fix x y z :: 'a
  show "x < y \<longleftrightarrow> x \<le> y \<and> \<not> y \<le> x"
    by (metis add_comm less_def less_eq_def)
  show "x \<le> x"
    by (metis add_idem less_eq_def)
  show "x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
    by (metis add_assoc' less_eq_def)
  show "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
    by (metis add_comm less_eq_def)
qed

text {* Next we show that joins are least upper bounds. *}

lemma add_ub1 [simp]: "x \<le> x + y"
  by (metis add_assoc' add_idem less_eq_def)

lemma add_ub2 [simp]: "y \<le> x + y"
  by (metis add_assoc' add_comm add_idem less_eq_def)

lemma add_lub_var: "x \<le> z \<longrightarrow> y \<le> z \<longrightarrow> x + y \<le> z"
  by (metis add_assoc' less_eq_def)

lemma add_lub: "x + y \<le> z \<longleftrightarrow> x \<le> z \<and> y \<le> z"
  by (metis add_lub_var add_ub1 add_ub2 order_trans)

text {* Next we prove that joins are isotone (order preserving). *}

lemma add_iso: "x \<le> y \<longrightarrow> x + z \<le> y + z"
  by (metis add_lub add_ub2 less_eq_def)

lemma add_iso_var: "x \<le> y \<longrightarrow> u \<le> v \<longrightarrow> x + u \<le> y + v"
  by (metis add_comm add_iso add_lub)

text {* The next lemma links the definition of order as @{term "x \<le> y
\<longleftrightarrow> x + y = y"}
with a perhaps more conventional one known, e.g., from
arithmetics. *}

lemma order_prop: "x \<le> y \<longleftrightarrow> (\<exists>z. x + z = y)"
proof
  assume "x \<le> y"
  hence "x + y = y"
    by (metis less_eq_def)
  thus "\<exists>z. x + z = y"
    by auto
next
  assume "\<exists>z. x + z = y"
  then obtain c where "x + c = y"
    by auto
  also have "x + c \<le> y"
    by (metis calculation eq_refl)
  thus "x \<le> y"
    by (metis add_ub1 calculation)
qed

end (* join_semilattice *)

subsection {* Join Semilattices with an Additive Unit *}

text {* We now expand join semilattices by an additive unit~$0$. Is
the least element with respect to the order, and therefore often
denoted by~@{text \<bottom>}. Semilattices with a least element are often
called \emph{bounded}. *}

class join_semilattice_zero = join_semilattice + zero +
  assumes add_zero_l [simp]: "0 + x = x"
begin

subclass comm_monoid_add
  apply unfold_locales
  apply auto
  apply (metis add_comm add_zero_l)
  done

lemma zero_least [simp]: "0 \<le> x"
  by (metis add_zero_l less_eq_def)

lemma add_zero_r [simp]: "x + 0 = x"
  by (metis add_comm add_zero_l)

lemma zero_unique [simp]: "x \<le> 0 \<longleftrightarrow> x = 0"
  by (metis zero_least eq_iff)

lemma no_trivial_inverse: "x \<noteq> 0 \<longrightarrow> \<not>(\<exists>y. x + y = 0)"
  by (metis zero_unique order_prop)

end (* join_semilattice_zero *)

subsection {* Near Semirings *}

text {* \emph{Near semirings} (also called seminearrings) are
generalisations of near rings to the semiring case. They have been
studied, for instance, in G.~Pilz's book~\cite{pilz83nearrings} on
near rings. According to his definition, a near semiring consists of
an additive and a multiplicative semigroup that interact via a single
distributivity law (left or right). The additive semigroup is not
required to be commutative. The definition is influenced by partial
transformation semigroups.

We only consider near semirings in which addition is commutative, and
in which the right distributivity law holds. We call such near
semirings \emph{abelian}. *}

class ab_near_semiring = ab_semigroup_add + semigroup_mult +
  assumes distrib_right': "(x + y) \<cdot> z = x \<cdot> z + y \<cdot> z"

subclass (in semiring) ab_near_semiring
  by (unfold_locales, metis distrib_right)

subsection {* Variants of Dioids *}

text {* A \emph{near dioid} is an abelian near semiring in which
addition is idempotent. This generalises the notion of (additively)
idempotent semirings by dropping one distributivity law. Near dioids
are a starting point for process algebras.

By modelling variants of dioids as variants of semirings in which
addition is idempotent we follow the tradition of
Birkhoff~\cite{birkhoff67lattices}, but deviate from the definitions
in Gondran and Minoux's book~\cite{gondran10graphs}. *}

class near_dioid = ab_near_semiring + plus_ord +
  assumes add_idem' [simp]: "x + x = x"
begin

text {* Since addition is idempotent, the additive (commutative)
semigroup reduct of a near dioid is a semilattice. Near dioids are
therefore ordered by the semilattice order. *}

subclass join_semilattice
by unfold_locales (auto simp add: add.commute add.left_commute)

text {* It follows that multiplication is right-isotone (but not
necessarily left-isotone). *}

lemma mult_isor: "x \<le> y \<longrightarrow> x \<cdot> z \<le> y \<cdot> z"
proof
  assume "x \<le> y"
  hence "x + y = y"
    by (metis less_eq_def)
  also have "x \<cdot> z + y \<cdot> z = (x + y) \<cdot> z"
    by (metis distrib_right')
  moreover have "... = y \<cdot> z"
    by (metis calculation)
  thus "x \<cdot> z \<le> y \<cdot> z"
    by (metis calculation less_eq_def)
qed

lemma "x \<le> y \<longrightarrow> z \<cdot> x \<le> z \<cdot> y"
  nitpick [expect=genuine] -- "3-element counterexample"
oops

text {* The next lemma states that, in every near dioid, left
isotonicity and left subdistributivity are equivalent. *}

lemma mult_isol_equiv_subdistl:
  "(\<forall>x y z. x \<le> y \<longrightarrow> z \<cdot> x \<le> z \<cdot> y) \<longleftrightarrow> (\<forall>x y z. z \<cdot> x \<le> z \<cdot> (x + y))"
  by (metis add_ub1 less_eq_def)

end (* near_dioid *)

text {* We now make multiplication in near dioids left isotone, which
is equivalent to left subdistributivity, as we have seen. The
corresponding structures form the basis of probabilistic Kleene
algebras~\cite{mciverweber05pka} and game
algebras~\cite{venema03gamealgebra}. We are not aware that these
structures have a special name, so we baptise them \emph{pre-dioids}.

We do not explicitly define pre-semirings since we have no application
for them. *}

class pre_dioid = near_dioid +
  assumes subdistl: "z \<cdot> x \<le> z \<cdot> (x + y)"
begin

text {* Now, obviously, left isotonicity follows from left
subdistributivity. *}

lemma subdistl_var: "z \<cdot> x + z \<cdot> y \<le> z \<cdot> (x + y)"
  by (metis add.commute add_lub subdistl)

lemma mult_isol: "x \<le> y \<longrightarrow> z \<cdot> x \<le> z \<cdot> y"
proof
  assume "x \<le> y"
  hence "x + y = y"
    by (metis less_eq_def)
  also have "z \<cdot> x + z \<cdot> y \<le> z \<cdot> (x + y)"
    by (metis subdistl_var)
  moreover have "... = z \<cdot> y"
    by (metis calculation)
  thus "z \<cdot> x \<le> z \<cdot> y"
    by (metis add_ub1 calculation order_trans)
qed

lemma mult_isol_var: "u \<le> x \<and> v \<le> y \<longrightarrow> u \<cdot> v \<le> x \<cdot> y"
  by (metis mult_isol mult_isor order_trans)

lemma mult_double_iso: "x \<le> y \<longrightarrow> w \<cdot> x \<cdot> z \<le> w \<cdot> y \<cdot> z"
  by (metis mult_isol mult_isor)

end (* pre_dioid *)

text {* By adding a full left distributivity law we obtain semirings
(which are already available in Isabelle/HOL as @{class semiring})
from near semirings, and dioids from near dioids. Dioids are therefore
idempotent semirings. *}

class dioid = near_dioid + semiring

subclass (in dioid) pre_dioid
  by (unfold_locales, metis order_prop distrib_left)

subsection {* Families of Nearsemirings with a Multiplicative Unit *}

text {* Multiplicative units are important, for instance, for defining
an operation of finite iteration or Kleene star on dioids. We do not
introduce left and right units separately since we have no application
for this. *}

class ab_near_semiring_one = ab_near_semiring + one +
  assumes mult_onel [simp]: "1 \<cdot> x = x"
  and mult_oner [simp]: "x \<cdot> 1 = x"
begin

subclass monoid_mult
by (unfold_locales, simp_all)

end (* ab_near_semiring_one *)

class near_dioid_one = near_dioid + ab_near_semiring_one

text {* For near dioids with one, it would be sufficient to require
$1+1=1$. This implies @{term "x+x=x"} for arbitray~@{term x} (but that
would lead to annoying redundant proof obligations in mutual
subclasses of @{class near_dioid_one} and @{class near_dioid} later).
*}

class pre_dioid_one = pre_dioid + near_dioid_one

class dioid_one = dioid + near_dioid_one

subclass (in dioid_one) pre_dioid_one ..

subsection {* Families of Nearsemirings with Additive Units *}

text {*
We now axiomatise an additive unit~$0$ for nearsemirings. The zero is
usually required to satisfy annihilation properties with respect to
multiplication. Due to applications we distinguish a zero which is
only a left annihilator from one that is also a right annihilator.
More briefly, we call zero either a left unit or a unit.

Semirings and dioids with a right zero only can be obtained from those
with a left unit by duality.
*}

class ab_near_semiring_one_zerol = ab_near_semiring_one + zero +
  assumes add_zerol [simp]: "0 + x = x"
  and annil [simp]: "0 \<cdot> x = 0"

begin (* ab_near_semiring_one_zerol *)

text {* Note that we do not require~$0 \neq 1$.  *}

lemma add_zeror [simp]: "x + 0 = x"
  by (metis add.commute add_zerol)

end (* ab_near_semiring_one_zerol *)

class near_dioid_one_zerol = near_dioid_one + ab_near_semiring_one_zerol

subclass (in near_dioid_one_zerol) join_semilattice_zero
  by (unfold_locales, metis add_zerol)

class pre_dioid_one_zerol = pre_dioid_one + ab_near_semiring_one_zerol

subclass (in pre_dioid_one_zerol) near_dioid_one_zerol ..

class semiring_one_zerol = semiring + ab_near_semiring_one_zerol

class dioid_one_zerol = dioid_one + ab_near_semiring_one_zerol

subclass (in dioid_one_zerol) pre_dioid_one_zerol ..

text {* We now make zero also a right annihilator. *}

class ab_near_semiring_one_zero = ab_near_semiring_one_zerol +
  assumes annir [simp]: "x \<cdot> 0 = 0"

class semiring_one_zero = semiring + ab_near_semiring_one_zero

class near_dioid_one_zero = near_dioid_one_zerol + ab_near_semiring_one_zero

class pre_dioid_one_zero = pre_dioid_one_zerol + ab_near_semiring_one_zero

subclass (in pre_dioid_one_zero) near_dioid_one_zero ..

class dioid_one_zero = dioid_one_zerol + ab_near_semiring_one_zero

subclass (in dioid_one_zero) pre_dioid_one_zero ..

subclass (in dioid_one_zero) semiring_one_zero ..

subsection {* Duality by Opposition *}

text {*
Swapping the order of multiplication in a semiring (or dioid) gives
another semiring (or dioid), called its \emph{dual} or
\emph{opposite}.
*}

definition (in times) opp_mult (infixl "\<odot>" 70)
  where "x \<odot> y \<equiv> y \<cdot> x"

lemma (in semiring_1) dual_semiring_1:
  "class.semiring_1 1 (op \<odot>) (op +) 0"
by unfold_locales (auto simp add: opp_mult_def mult.assoc distrib_right distrib_left)

lemma (in dioid_one_zero) dual_dioid_one_zero:
  "class.dioid_one_zero (op +) (op \<odot>) 1 0 (op \<le>) (op <)"
by unfold_locales (auto simp add: opp_mult_def mult.assoc distrib_right distrib_left)

subsection {* Selective Near Semirings *}

text {* In this section we briefly sketch a generalisation of the
notion of \emph{dioid}. Some important models, e.g. max-plus and
min-plus semirings, have that property. *}

class selective_near_semiring = ab_near_semiring + plus_ord +
  assumes select: "x + y = x \<or> x + y = y"
begin

lemma select_alt: "x + y \<in> {x,y}"
  by (metis insert_iff select)

text {* It follows immediately that every selective near semiring is a
near dioid. *}

subclass near_dioid
  by (unfold_locales, metis select)

text {* Moreover, the order in a selective near semiring is obviously
linear. *}

subclass linorder
  by (unfold_locales, metis add.commute add_ub1 select)

end (*selective_near_semiring*)

class selective_semiring = selective_near_semiring + semiring_one_zero
begin

subclass dioid_one_zero ..

end (* selective_semiring *)

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
   Some proofs were added by Yutaka Nagashima.*)
theory TIP_prop_20
  imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

fun len :: "'a list => Nat" where
  "len (nil2) = Z"
| "len (cons2 y xs) = S (len xs)"

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

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

fun sort :: "Nat list => Nat list" where
  "sort (nil2) = nil2"
| "sort (cons2 y xs) = insort y (sort xs)"

theorem property0 :
  "((len (sort xs)) = (len xs))"
  oops

end


section\<open>Cardinal Arithmetic under Choice\label{sec:cardinal-lib}\<close>

theory Cardinal_Library
  imports
    ZF_Library
    ZF.Cardinal_AC

begin

text\<open>This theory includes results on cardinalities that depend on $\AC$\<close>

subsection\<open>Results on cardinal exponentiation\<close>

text\<open>Non trivial instances of cardinal exponentiation require that
     the relevant function spaces are well-ordered, hence this
     implies a strong use of choice.\<close>

lemma cexp_eqpoll_cong:
  assumes
    "A \<approx> A'" "B \<approx> B'"
  shows
    "A\<^bsup>\<up>B\<^esup> = A'\<^bsup>\<up>B'\<^esup>"
  unfolding cexp_def using cardinal_eqpoll_iff
    function_space_eqpoll_cong assms
  by simp

lemma cexp_cexp_cmult: "(\<kappa>\<^bsup>\<up>\<nu>1\<^esup>)\<^bsup>\<up>\<nu>2\<^esup> = \<kappa>\<^bsup>\<up>\<nu>2 \<otimes> \<nu>1\<^esup>"
proof -
  have "(\<kappa>\<^bsup>\<up>\<nu>1\<^esup>)\<^bsup>\<up>\<nu>2\<^esup> = (\<nu>1 \<rightarrow> \<kappa>)\<^bsup>\<up>\<nu>2\<^esup>"
    using cardinal_eqpoll
    by (intro cexp_eqpoll_cong) (simp_all add:cexp_def)
  also
  have " \<dots> = \<kappa>\<^bsup>\<up>\<nu>2 \<times> \<nu>1\<^esup>"
    unfolding cexp_def using curry_eqpoll cardinal_cong by blast
  also
  have " \<dots> = \<kappa>\<^bsup>\<up>\<nu>2 \<otimes> \<nu>1\<^esup>"
    using cardinal_eqpoll[THEN eqpoll_sym]
    unfolding cmult_def by (intro cexp_eqpoll_cong) (simp)
  finally
  show ?thesis  .
qed

lemma cardinal_Pow: "|Pow(X)| = 2\<^bsup>\<up>X\<^esup>" \<comment> \<open>Perhaps it's better with |X|\<close>
  using cardinal_eqpoll_iff[THEN iffD2, OF Pow_eqpoll_function_space]
  unfolding cexp_def by simp

lemma cantor_cexp:
  assumes "Card(\<nu>)"
  shows "\<nu> < 2\<^bsup>\<up>\<nu>\<^esup>"
  using assms Card_is_Ord Card_cexp
proof (intro not_le_iff_lt[THEN iffD1] notI)
  assume "2\<^bsup>\<up>\<nu>\<^esup> \<le> \<nu>"
  then
  have "|Pow(\<nu>)| \<le> \<nu>"
    using cardinal_Pow by simp
  with assms
  have "Pow(\<nu>) \<lesssim> \<nu>"
    using cardinal_eqpoll_iff Card_le_imp_lepoll Card_cardinal_eq
    by auto
  then
  obtain g where "g \<in> inj(Pow(\<nu>), \<nu>)"
    by blast
  then
  show "False"
    using cantor_inj by simp
qed simp

lemma cexp_left_mono:
  assumes "\<kappa>1 \<le> \<kappa>2"
  shows "\<kappa>1\<^bsup>\<up>\<nu>\<^esup> \<le> \<kappa>2\<^bsup>\<up>\<nu>\<^esup>"
    (* \<comment> \<open>short, unreadable proof: \<close>
  unfolding cexp_def
  using subset_imp_lepoll[THEN lepoll_imp_cardinal_le]
    assms le_subset_iff[THEN iffD1, OF assms]
    Pi_weaken_type[of _ _ "\<lambda>_. \<kappa>1" "\<lambda>_. \<kappa>2"] by auto *)
proof -
  from assms
  have "\<kappa>1 \<subseteq> \<kappa>2"
    using le_subset_iff by simp
  then
  have "\<nu> \<rightarrow> \<kappa>1  \<subseteq> \<nu> \<rightarrow> \<kappa>2"
    using Pi_weaken_type by auto
  then
  show ?thesis unfolding cexp_def
    using lepoll_imp_cardinal_le subset_imp_lepoll by simp
qed

lemma cantor_cexp':
  assumes "2 \<le> \<kappa>" "Card(\<nu>)"
  shows "\<nu> < \<kappa>\<^bsup>\<up>\<nu>\<^esup>"
  using cexp_left_mono assms cantor_cexp lt_trans2 by blast

lemma InfCard_cexp:
  assumes "2 \<le> \<kappa>" "InfCard(\<nu>)"
  shows "InfCard(\<kappa>\<^bsup>\<up>\<nu>\<^esup>)"
  using assms cantor_cexp'[THEN leI] le_trans Card_cexp
  unfolding InfCard_def by auto

lemmas InfCard_cexp' = InfCard_cexp[OF nats_le_InfCard, simplified]
  \<comment> \<open>\<^term>\<open>InfCard(\<kappa>) \<Longrightarrow> InfCard(\<nu>) \<Longrightarrow> InfCard(\<kappa>\<^bsup>\<up>\<nu>\<^esup>)\<close>\<close>

subsection\<open>Miscellaneous\<close>

lemma cardinal_RepFun_le: "|{f(a) . a\<in>A}| \<le> |A|"
proof -
  have "(\<lambda>x\<in>A. f(x)) \<in> surj(A, {f(a) . a\<in>A})"
    unfolding surj_def using lam_funtype by auto
  then
  show ?thesis
    using  surj_implies_cardinal_le by blast
qed

lemma subset_imp_le_cardinal: "A \<subseteq> B \<Longrightarrow> |A| \<le> |B|"
  using subset_imp_lepoll[THEN lepoll_imp_cardinal_le] .

lemma lt_cardinal_imp_not_subset: "|A| < |B| \<Longrightarrow> \<not> B \<subseteq> A"
  using subset_imp_le_cardinal le_imp_not_lt by blast

lemma cardinal_lt_csucc_iff: "Card(K) \<Longrightarrow> |K'| < K\<^sup>+ \<longleftrightarrow> |K'| \<le> K"
  by (simp add: Card_lt_csucc_iff)

lemma cardinal_UN_le_nat:
  "(\<And>i. i\<in>\<omega> \<Longrightarrow> |X(i)| \<le> \<omega>) \<Longrightarrow> |\<Union>i\<in>\<omega>. X(i)| \<le> \<omega>"
  by (simp add: cardinal_UN_le InfCard_nat)

lemma lepoll_imp_cardinal_UN_le:
  notes [dest] = InfCard_is_Card Card_is_Ord
  assumes "InfCard(K)" "J \<lesssim> K" "\<And>i. i\<in>J \<Longrightarrow> |X(i)| \<le> K"
  shows "|\<Union>i\<in>J. X(i)| \<le> K"
proof -
  from \<open>J \<lesssim> K\<close>
  obtain f where "f \<in> inj(J,K)" by blast
  define Y where "Y(k) \<equiv> if k\<in>range(f) then X(converse(f)`k) else 0" for k
  have "i\<in>J \<Longrightarrow> f`i \<in> K" for i
    using inj_is_fun[OF \<open>f \<in> inj(J,K)\<close>] by auto
  have "(\<Union>i\<in>J. X(i)) \<subseteq> (\<Union>i\<in>K. Y(i))"
  proof (standard, elim UN_E)
    fix x i
    assume "i\<in>J" "x\<in>X(i)"
    with \<open>f \<in> inj(J,K)\<close> \<open>i\<in>J \<Longrightarrow> f`i \<in> K\<close>
    have "x \<in> Y(f`i)" "f`i \<in> K"
      unfolding Y_def
      using inj_is_fun[OF \<open>f \<in> inj(J,K)\<close>]
        right_inverse apply_rangeI by auto
    then
    show "x \<in> (\<Union>i\<in>K. Y(i))" by auto
  qed
  then
  have "|\<Union>i\<in>J. X(i)| \<le> |\<Union>i\<in>K. Y(i)|"
    unfolding Y_def using subset_imp_le_cardinal by simp
  with assms \<open>\<And>i. i\<in>J \<Longrightarrow> f`i \<in> K\<close>
  show "|\<Union>i\<in>J. X(i)| \<le> K"
    using inj_converse_fun[OF \<open>f \<in> inj(J,K)\<close>] unfolding Y_def
    by (rule_tac le_trans[OF _ cardinal_UN_le]) (auto intro:Ord_0_le)+
qed

\<comment> \<open>For backwards compatibility\<close>
lemmas leqpoll_imp_cardinal_UN_le = lepoll_imp_cardinal_UN_le

lemma cardinal_lt_csucc_iff':
  includes Ord_dests
  assumes "Card(\<kappa>)"
  shows "\<kappa> < |X| \<longleftrightarrow> \<kappa>\<^sup>+ \<le> |X|"
  using assms cardinal_lt_csucc_iff[of \<kappa> X] Card_csucc[of \<kappa>]
    not_le_iff_lt[of "\<kappa>\<^sup>+" "|X|"] not_le_iff_lt[of "|X|" \<kappa>]
  by blast

lemma lepoll_imp_subset_bij: "X \<lesssim> Y \<longleftrightarrow> (\<exists>Z. Z \<subseteq> Y \<and> Z \<approx> X)"
proof
  assume "X \<lesssim> Y"
  then
  obtain j where  "j \<in> inj(X,Y)"
    by blast
  then
  have "range(j) \<subseteq> Y" "j \<in> bij(X,range(j))"
    using inj_bij_range inj_is_fun range_fun_subset_codomain
    by blast+
  then
  show "\<exists>Z. Z \<subseteq> Y \<and> Z \<approx> X"
    using eqpoll_sym unfolding eqpoll_def
    by force
next
  assume "\<exists>Z. Z \<subseteq> Y \<and> Z \<approx> X"
  then
  obtain Z f where "f \<in> bij(Z,X)" "Z \<subseteq> Y"
    unfolding eqpoll_def by force
  then
  have "converse(f) \<in> inj(X,Y)"
    using bij_is_inj inj_weaken_type bij_converse_bij by blast
  then
  show "X \<lesssim> Y" by blast
qed

text\<open>The following result proves to be very useful when combining
     \<^term>\<open>cardinal\<close> and \<^term>\<open>eqpoll\<close> in a calculation.\<close>

lemma cardinal_Card_eqpoll_iff: "Card(\<kappa>) \<Longrightarrow> |X| = \<kappa> \<longleftrightarrow> X \<approx> \<kappa>"
  using Card_cardinal_eq[of \<kappa>] cardinal_eqpoll_iff[of X \<kappa>] by auto
    \<comment> \<open>Compare @{thm [source] "le_Card_iff"}\<close>

lemma lepoll_imp_lepoll_cardinal: assumes "X \<lesssim> Y" shows "X \<lesssim> |Y|"
  using assms cardinal_Card_eqpoll_iff[of "|Y|" Y]
    lepoll_eq_trans[of _ _ "|Y|"] by simp

lemma lepoll_Un:
  assumes "InfCard(\<kappa>)" "A \<lesssim> \<kappa>" "B \<lesssim> \<kappa>"
  shows "A \<union> B \<lesssim> \<kappa>"
proof -
  have "A \<union> B \<lesssim> sum(A,B)"
    using Un_lepoll_sum .
  moreover
  note assms
  moreover from this
  have "|sum(A,B)| \<le> \<kappa> \<oplus> \<kappa>"
    using sum_lepoll_mono[of A \<kappa> B \<kappa>] lepoll_imp_cardinal_le
    unfolding cadd_def by auto
  ultimately
  show ?thesis
    using InfCard_cdouble_eq Card_cardinal_eq
      InfCard_is_Card Card_le_imp_lepoll[of "sum(A,B)" \<kappa>]
      lepoll_trans[of "A\<union>B"]
    by auto
qed

lemma cardinal_Un_le:
  assumes "InfCard(\<kappa>)" "|A| \<le> \<kappa>" "|B| \<le> \<kappa>"
  shows "|A \<union> B| \<le> \<kappa>"
  using assms lepoll_Un le_Card_iff InfCard_is_Card by auto

text\<open>This is the unconditional version under choice of
     @{thm [source] Cardinal.Finite_cardinal_iff}.\<close>
lemma Finite_cardinal_iff': "Finite(|i|) \<longleftrightarrow> Finite(i)"
  using cardinal_eqpoll_iff eqpoll_imp_Finite_iff by fastforce

lemma cardinal_subset_of_Card:
  assumes "Card(\<gamma>)" "a \<subseteq> \<gamma>"
  shows "|a| < \<gamma> \<or> |a| = \<gamma>"
proof -
  from assms
  have "|a| < |\<gamma>| \<or> |a| = |\<gamma>|"
    using subset_imp_le_cardinal le_iff by simp
  with assms
  show ?thesis
    using Card_cardinal_eq by simp
qed

lemma cardinal_cases:
  includes Ord_dests
  shows "Card(\<gamma>) \<Longrightarrow> |X| < \<gamma> \<longleftrightarrow> \<not> |X| \<ge> \<gamma>"
  using not_le_iff_lt
  by auto

subsection\<open>Countable and uncountable sets\<close>

lemma countable_iff_cardinal_le_nat: "countable(X) \<longleftrightarrow> |X| \<le> \<omega>"
  using le_Card_iff[of \<omega> X] Card_nat
  unfolding countable_def by simp

lemma lepoll_countable: "X \<lesssim> Y \<Longrightarrow> countable(Y) \<Longrightarrow> countable(X)"
  using lepoll_trans[of X Y] by blast

\<comment> \<open>Next lemma can be proved without using AC\<close>
lemma surj_countable: "countable(X) \<Longrightarrow> f \<in> surj(X,Y) \<Longrightarrow> countable(Y)"
  using surj_implies_cardinal_le[of f X Y, THEN le_trans]
    countable_iff_cardinal_le_nat by simp

lemma Finite_imp_countable: "Finite(X) \<Longrightarrow> countable(X)"
  unfolding Finite_def
  by (auto intro:InfCard_nat nats_le_InfCard[of _ \<omega>,
        THEN le_imp_lepoll] dest!:eq_lepoll_trans[of X _ \<omega>])

lemma countable_imp_countable_UN:
  assumes "countable(J)" "\<And>i. i\<in>J \<Longrightarrow> countable(X(i))"
  shows "countable(\<Union>i\<in>J. X(i))"
  using assms lepoll_imp_cardinal_UN_le[of \<omega> J X] InfCard_nat
    countable_iff_cardinal_le_nat
  by auto

lemma countable_union_countable:
  assumes "\<And>x. x \<in> C \<Longrightarrow> countable(x)" "countable(C)"
  shows "countable(\<Union>C)"
  using assms countable_imp_countable_UN[of C "\<lambda>x. x"] by simp

abbreviation
  uncountable :: "i\<Rightarrow>o" where
  "uncountable(X) \<equiv> \<not> countable(X)"

lemma uncountable_iff_nat_lt_cardinal:
  "uncountable(X) \<longleftrightarrow> \<omega> < |X|"
  using countable_iff_cardinal_le_nat not_le_iff_lt by simp

lemma uncountable_not_empty: "uncountable(X) \<Longrightarrow> X \<noteq> 0"
  using empty_lepollI by auto

lemma uncountable_imp_Infinite: "uncountable(X) \<Longrightarrow> Infinite(X)"
  using uncountable_iff_nat_lt_cardinal[of X] lepoll_nat_imp_Infinite[of X]
    cardinal_le_imp_lepoll[of \<omega> X] leI
  by simp

lemma uncountable_not_subset_countable:
  assumes "countable(X)" "uncountable(Y)"
  shows "\<not> (Y \<subseteq> X)"
  using assms lepoll_trans subset_imp_lepoll[of Y X]
  by blast

subsection\<open>Results on Alephs\<close>

lemma nat_lt_Aleph1: "\<omega> < \<aleph>\<^bsub>1\<^esub>"
  by (simp add: Aleph_def lt_csucc)

lemma zero_lt_Aleph1: "0 < \<aleph>\<^bsub>1\<^esub>"
  by (rule lt_trans[of _ "\<omega>"], auto simp add: ltI nat_lt_Aleph1)

lemma le_aleph1_nat: "Card(k) \<Longrightarrow> k<\<aleph>\<^bsub>1\<^esub> \<Longrightarrow> k \<le> \<omega>"
  by (simp add: Aleph_def Card_lt_csucc_iff Card_nat)

lemma Aleph_succ: "\<aleph>\<^bsub>succ(\<alpha>)\<^esub> = \<aleph>\<^bsub>\<alpha>\<^esub>\<^sup>+"
  unfolding Aleph_def by simp

lemma lesspoll_aleph_plus_one:
  assumes "Ord(\<alpha>)"
  shows "d \<prec> \<aleph>\<^bsub>succ(\<alpha>)\<^esub> \<longleftrightarrow> d \<lesssim> \<aleph>\<^bsub>\<alpha>\<^esub>"
  using assms lesspoll_csucc Aleph_succ Card_is_Ord by simp

lemma cardinal_Aleph [simp]: "Ord(\<alpha>) \<Longrightarrow> |\<aleph>\<^bsub>\<alpha>\<^esub>| = \<aleph>\<^bsub>\<alpha>\<^esub>"
  using Card_cardinal_eq by simp

\<comment> \<open>Could be proved without using AC\<close>
lemma Aleph_lesspoll_increasing:
  includes Aleph_intros
  shows "a < b \<Longrightarrow> \<aleph>\<^bsub>a\<^esub> \<prec> \<aleph>\<^bsub>b\<^esub>"
  using cardinal_lt_iff_lesspoll[of "\<aleph>\<^bsub>a\<^esub>" "\<aleph>\<^bsub>b\<^esub>"] Card_cardinal_eq[of "\<aleph>\<^bsub>b\<^esub>"]
    lt_Ord lt_Ord2 Card_Aleph[THEN Card_is_Ord] by auto

lemma uncountable_iff_subset_eqpoll_Aleph1:
  includes Ord_dests
  notes Aleph_zero_eq_nat[simp] Card_nat[simp] Aleph_succ[simp]
  shows "uncountable(X) \<longleftrightarrow> (\<exists>S. S \<subseteq> X \<and> S \<approx> \<aleph>\<^bsub>1\<^esub>)"
proof
  assume "uncountable(X)"
  then
  have "\<aleph>\<^bsub>1\<^esub> \<lesssim> X"
    using uncountable_iff_nat_lt_cardinal cardinal_lt_csucc_iff'
      cardinal_le_imp_lepoll by force
  then
  obtain S where "S \<subseteq> X" "S \<approx> \<aleph>\<^bsub>1\<^esub>"
    using lepoll_imp_subset_bij by auto
  then
  show "\<exists>S. S \<subseteq> X \<and> S \<approx> \<aleph>\<^bsub>1\<^esub>"
    using cardinal_cong Card_csucc[of \<omega>] Card_cardinal_eq by auto
next
  assume "\<exists>S. S \<subseteq> X \<and> S \<approx> \<aleph>\<^bsub>1\<^esub>"
  then
  have "\<aleph>\<^bsub>1\<^esub> \<lesssim> X"
    using subset_imp_lepoll[THEN [2] eq_lepoll_trans, of "\<aleph>\<^bsub>1\<^esub>" _ X,
        OF eqpoll_sym] by auto
  then
  show "uncountable(X)"
    using Aleph_lesspoll_increasing[of 0 1, THEN [2] lesspoll_trans1,
        of "\<aleph>\<^bsub>1\<^esub>"] lepoll_trans[of "\<aleph>\<^bsub>1\<^esub>" X \<omega>]
    by auto
qed

lemma lt_Aleph_imp_cardinal_UN_le_nat: "function(G) \<Longrightarrow> domain(G) \<lesssim> \<omega> \<Longrightarrow>
   \<forall>n\<in>domain(G). |G`n|<\<aleph>\<^bsub>1\<^esub> \<Longrightarrow> |\<Union>n\<in>domain(G). G`n|\<le>\<omega>"
proof -
  assume "function(G)"
  let ?N="domain(G)" and ?R="\<Union>n\<in>domain(G). G`n"
  assume "?N \<lesssim> \<omega>"
  assume Eq1: "\<forall>n\<in>?N. |G`n|<\<aleph>\<^bsub>1\<^esub>"
  {
    fix n
    assume "n\<in>?N"
    with Eq1 have "|G`n| \<le> \<omega>"
      using le_aleph1_nat by simp
  }
  then
  have "n\<in>?N \<Longrightarrow> |G`n| \<le> \<omega>" for n .
  with \<open>?N \<lesssim> \<omega>\<close>
  show ?thesis
    using InfCard_nat lepoll_imp_cardinal_UN_le by simp
qed

lemma Aleph1_eq_cardinal_vimage: "f:\<aleph>\<^bsub>1\<^esub>\<rightarrow>\<omega> \<Longrightarrow> \<exists>n\<in>\<omega>. |f-``{n}| = \<aleph>\<^bsub>1\<^esub>"
proof -
  assume "f:\<aleph>\<^bsub>1\<^esub>\<rightarrow>\<omega>"
  then
  have "function(f)" "domain(f) = \<aleph>\<^bsub>1\<^esub>" "range(f)\<subseteq>\<omega>"
    by (simp_all add: domain_of_fun fun_is_function range_fun_subset_codomain)
  let ?G="\<lambda>n\<in>range(f). f-``{n}"
  from \<open>f:\<aleph>\<^bsub>1\<^esub>\<rightarrow>\<omega>\<close>
  have "range(f) \<subseteq> \<omega>" by (simp add: range_fun_subset_codomain)
  then
  have "domain(?G) \<lesssim> \<omega>"
    using subset_imp_lepoll by simp
  have "function(?G)" by (simp add:function_lam)
  from \<open>f:\<aleph>\<^bsub>1\<^esub>\<rightarrow>\<omega>\<close>
  have "n\<in>\<omega> \<Longrightarrow> f-``{n} \<subseteq> \<aleph>\<^bsub>1\<^esub>" for n
    using Pi_vimage_subset by simp
  with \<open>range(f) \<subseteq> \<omega>\<close>
  have "\<aleph>\<^bsub>1\<^esub> = (\<Union>n\<in>range(f). f-``{n})"
  proof (intro equalityI, intro subsetI)
    fix x
    assume "x \<in> \<aleph>\<^bsub>1\<^esub>"
    with \<open>f:\<aleph>\<^bsub>1\<^esub>\<rightarrow>\<omega>\<close> \<open>function(f)\<close> \<open>domain(f) = \<aleph>\<^bsub>1\<^esub>\<close>
    have "x \<in> f-``{f`x}" "f`x \<in> range(f)"
      using function_apply_Pair vimage_iff apply_rangeI by simp_all
    then
    show "x \<in> (\<Union>n\<in>range(f). f-``{n})" by auto
  qed auto
  {
    assume "\<forall>n\<in>range(f). |f-``{n}| < \<aleph>\<^bsub>1\<^esub>"
    then
    have "\<forall>n\<in>domain(?G). |?G`n| < \<aleph>\<^bsub>1\<^esub>"
      using zero_lt_Aleph1 by (auto)
    with \<open>function(?G)\<close> \<open>domain(?G) \<lesssim> \<omega>\<close>
    have "|\<Union>n\<in>domain(?G). ?G`n|\<le>\<omega>"
      using lt_Aleph_imp_cardinal_UN_le_nat by blast
    then
    have "|\<Union>n\<in>range(f). f-``{n}|\<le>\<omega>" by simp
    with \<open>\<aleph>\<^bsub>1\<^esub> = _\<close>
    have "|\<aleph>\<^bsub>1\<^esub>| \<le> \<omega>" by simp
    then
    have "\<aleph>\<^bsub>1\<^esub> \<le> \<omega>"
      using Card_Aleph Card_cardinal_eq
      by simp
    then
    have "False"
      using nat_lt_Aleph1 by (blast dest:lt_trans2)
  }
  with \<open>range(f)\<subseteq>\<omega>\<close>
  obtain n where "n\<in>\<omega>" "\<not>(|f -`` {n}| < \<aleph>\<^bsub>1\<^esub>)"
    by blast
  moreover from this
  have "\<aleph>\<^bsub>1\<^esub> \<le> |f-``{n}|"
    using not_lt_iff_le Card_is_Ord by auto
  moreover
  note \<open>n\<in>\<omega> \<Longrightarrow> f-``{n} \<subseteq> \<aleph>\<^bsub>1\<^esub>\<close>
  ultimately
  show ?thesis
    using subset_imp_le_cardinal[THEN le_anti_sym, of _ "\<aleph>\<^bsub>1\<^esub>"]
      Card_Aleph Card_cardinal_eq by auto
qed

\<comment> \<open>There is some asymmetry between assumptions and conclusion
    (\<^term>\<open>(\<approx>)\<close> versus \<^term>\<open>cardinal\<close>)\<close>
lemma eqpoll_Aleph1_cardinal_vimage:
  assumes "X \<approx> \<aleph>\<^bsub>1\<^esub>" "f : X \<rightarrow> \<omega>"
  shows "\<exists>n\<in>\<omega>. |f-``{n}| = \<aleph>\<^bsub>1\<^esub>"
proof -
  from assms
  obtain g where "g\<in>bij(\<aleph>\<^bsub>1\<^esub>,X)"
    using eqpoll_sym by blast
  with \<open>f : X \<rightarrow> \<omega>\<close>
  have "f O g : \<aleph>\<^bsub>1\<^esub> \<rightarrow> \<omega>" "converse(g) \<in> bij(X, \<aleph>\<^bsub>1\<^esub>)"
    using bij_is_fun comp_fun bij_converse_bij by blast+
  then
  obtain n where "n\<in>\<omega>" "|(f O g)-``{n}| = \<aleph>\<^bsub>1\<^esub>"
    using Aleph1_eq_cardinal_vimage by auto
  then
  have "\<aleph>\<^bsub>1\<^esub> = |converse(g) `` (f -``{n})|"
    using image_comp converse_comp
    unfolding vimage_def by simp
  also from \<open>converse(g) \<in> bij(X, \<aleph>\<^bsub>1\<^esub>)\<close> \<open>f: X\<rightarrow> \<omega>\<close>
  have "\<dots> = |f -``{n}|"
    using range_of_subset_eqpoll[of "converse(g)" X  _ "f -``{n}"]
      bij_is_inj cardinal_cong bij_is_fun eqpoll_sym Pi_vimage_subset
    by fastforce
  finally
  show ?thesis using \<open>n\<in>\<omega>\<close> by auto
qed

subsection\<open>Applications of transfinite recursive constructions\<close>

text\<open>The next lemma is an application of recursive constructions.
     It works under the assumption that whenever the already constructed
     subsequence is small enough, another element can be added.\<close>

lemma bounded_cardinal_selection:
  includes Ord_dests
  assumes
    "\<And>X. |X| < \<gamma> \<Longrightarrow> X \<subseteq> G \<Longrightarrow> \<exists>a\<in>G. \<forall>s\<in>X. Q(s,a)" "b\<in>G" "Card(\<gamma>)"
  shows
    "\<exists>S. S : \<gamma> \<rightarrow> G \<and> (\<forall>\<alpha> \<in> \<gamma>. \<forall>\<beta> \<in> \<gamma>.  \<alpha><\<beta> \<longrightarrow> Q(S`\<alpha>,S`\<beta>))"
proof -
  let ?cdlt\<gamma>="{X\<in>Pow(G) . |X|<\<gamma>}" \<comment> \<open>``cardinal less than \<^term>\<open>\<gamma>\<close>''\<close>
    and ?inQ="\<lambda>Y.{a\<in>G. \<forall>s\<in>Y. Q(s,a)}"
  from assms
  have "\<forall>Y \<in> ?cdlt\<gamma>. \<exists>a. a \<in> ?inQ(Y)"
    by blast
  then
  have "\<exists>f. f \<in> Pi(?cdlt\<gamma>,?inQ)"
    using AC_ball_Pi[of ?cdlt\<gamma> ?inQ] by simp
  then
  obtain f where f_type:"f \<in> Pi(?cdlt\<gamma>,?inQ)"
    by auto
  moreover
  define Cb where "Cb \<equiv> \<lambda>_\<in>Pow(G)-?cdlt\<gamma>. b"
  moreover from \<open>b\<in>G\<close>
  have "Cb \<in> Pow(G)-?cdlt\<gamma> \<rightarrow> G"
    unfolding Cb_def by simp
  moreover
  note \<open>Card(\<gamma>)\<close>
  ultimately
  have "f \<union> Cb : (\<Prod>x\<in>Pow(G). ?inQ(x) \<union> G)" using
      fun_Pi_disjoint_Un[ of f ?cdlt\<gamma>  ?inQ Cb "Pow(G)-?cdlt\<gamma>" "\<lambda>_.G"]
      Diff_partition[of "{X\<in>Pow(G). |X|<\<gamma>}" "Pow(G)", OF Collect_subset]
    by auto
  moreover
  have "?inQ(x) \<union> G = G" for x by auto
  ultimately
  have "f \<union> Cb : Pow(G) \<rightarrow> G" by simp
  define S where "S\<equiv>\<lambda>\<alpha>\<in>\<gamma>. rec_constr(f \<union> Cb, \<alpha>)"
  from \<open>f \<union> Cb: Pow(G) \<rightarrow> G\<close> \<open>Card(\<gamma>)\<close>
  have "S : \<gamma> \<rightarrow> G"
    using Ord_in_Ord unfolding S_def
    by (intro lam_type rec_constr_type) auto
  moreover
  have "\<forall>\<alpha>\<in>\<gamma>. \<forall>\<beta>\<in>\<gamma>. \<alpha> < \<beta> \<longrightarrow> Q(S ` \<alpha>, S ` \<beta>)"
  proof (intro ballI impI)
    fix \<alpha> \<beta>
    assume "\<beta>\<in>\<gamma>"
    with \<open>Card(\<gamma>)\<close>
    have "{rec_constr(f \<union> Cb, x) . x\<in>\<beta>} = {S`x . x \<in> \<beta>}"
      using Ord_trans[OF _ _ Card_is_Ord, of _ \<beta> \<gamma>]
      unfolding S_def
      by auto
    moreover from \<open>\<beta>\<in>\<gamma>\<close> \<open>S : \<gamma> \<rightarrow> G\<close> \<open>Card(\<gamma>)\<close>
    have "{S`x . x \<in> \<beta>} \<subseteq> G"
      using Ord_trans[OF _ _ Card_is_Ord, of _ \<beta> \<gamma>]
        apply_type[of S \<gamma> "\<lambda>_. G"] by auto
    moreover from \<open>Card(\<gamma>)\<close> \<open>\<beta>\<in>\<gamma>\<close>
    have "|{S`x . x \<in> \<beta>}| < \<gamma>"
      using cardinal_RepFun_le[of \<beta>]  Ord_in_Ord
        lt_trans1[of "|{S`x . x \<in> \<beta>}|" "|\<beta>|" \<gamma>]
        Card_lt_iff[THEN iffD2, of \<beta> \<gamma>, OF _ _ ltI]
      by force
    moreover
    have "\<forall>x\<in>\<beta>. Q(S`x, f ` {S`x . x \<in> \<beta>})"
    proof -
      from calculation and f_type
      have "f ` {S`x . x \<in> \<beta>} \<in> {a\<in>G. \<forall>x\<in>\<beta>. Q(S`x,a)}"
        using apply_type[of f ?cdlt\<gamma> ?inQ "{S`x . x \<in> \<beta>}"]
        by blast
      then
      show ?thesis by simp
    qed
    moreover
    assume "\<alpha>\<in>\<gamma>" "\<alpha> < \<beta>"
    moreover
    note \<open>\<beta>\<in>\<gamma>\<close> \<open>Cb \<in> Pow(G)-?cdlt\<gamma> \<rightarrow> G\<close>
    ultimately
    show "Q(S ` \<alpha>, S ` \<beta>)"
      using fun_disjoint_apply1[of "{S`x . x \<in> \<beta>}" Cb f]
        domain_of_fun[of Cb] ltD[of \<alpha> \<beta>]
      by (subst (2) S_def, auto) (subst rec_constr_unfold, auto)
  qed
  ultimately
  show ?thesis by blast
qed

text\<open>The following basic result can, in turn, be proved by a
     bounded-cardinal selection.\<close>
lemma Infinite_iff_lepoll_nat: "Infinite(X) \<longleftrightarrow> \<omega> \<lesssim> X"
proof
  assume "Infinite(X)"
  then
  obtain b where "b\<in>X"
    using Infinite_not_empty by auto
  {
    fix Y
    assume "|Y| < \<omega>"
    then
    have "Finite(Y)"
      using Finite_cardinal_iff' ltD nat_into_Finite by blast
    with \<open>Infinite(X)\<close>
    have "X \<noteq> Y" by auto
  }
  with \<open>b\<in>X\<close>
  obtain S where "S : \<omega> \<rightarrow> X"  "\<forall>\<alpha>\<in>\<omega>. \<forall>\<beta>\<in>\<omega>. \<alpha> < \<beta> \<longrightarrow> S`\<alpha> \<noteq> S`\<beta>"
    using bounded_cardinal_selection[of \<omega> X "\<lambda>x y. x\<noteq>y"]
      Card_nat by blast
  moreover from this
  have "\<alpha> \<in> \<omega> \<Longrightarrow> \<beta> \<in> \<omega> \<Longrightarrow> \<alpha>\<noteq>\<beta> \<Longrightarrow> S`\<alpha> \<noteq> S`\<beta>" for \<alpha> \<beta>
    by (rule_tac lt_neq_symmetry[of "\<omega>" "\<lambda>\<alpha> \<beta>. S`\<alpha> \<noteq> S`\<beta>"])
      auto
  ultimately
  show "\<omega> \<lesssim> X"
    unfolding lepoll_def inj_def by blast
qed (intro lepoll_nat_imp_Infinite)

lemma Infinite_InfCard_cardinal: "Infinite(X) \<Longrightarrow> InfCard(|X|)"
  using lepoll_eq_trans eqpoll_sym lepoll_nat_imp_Infinite
    Infinite_iff_lepoll_nat Inf_Card_is_InfCard cardinal_eqpoll
  by simp

lemma Finite_to_one_surj_imp_cardinal_eq:
  assumes "F \<in> Finite_to_one(X,Y) \<inter> surj(X,Y)" "Infinite(X)"
  shows "|Y| = |X|"
proof -
  from \<open>F \<in> Finite_to_one(X,Y) \<inter> surj(X,Y)\<close>
  have "X = (\<Union>y\<in>Y. {x\<in>X . F`x = y})"
    using apply_type by fastforce
  show ?thesis
  proof (cases "Finite(Y)")
    case True
    with \<open>X = (\<Union>y\<in>Y. {x\<in>X . F`x = y})\<close> and assms
    show ?thesis
      using Finite_RepFun[THEN [2] Finite_Union, of Y "\<lambda>y. {x\<in>X . F`x = y}"]
      by auto
  next
    case False
    moreover from this
    have "Y \<lesssim> |Y|"
      using cardinal_eqpoll eqpoll_sym eqpoll_imp_lepoll by simp
    moreover
    note assms
    moreover from calculation
    have "y \<in> Y \<Longrightarrow> |{x\<in>X . F`x = y}| \<le> |Y|" for y
      using Infinite_imp_nats_lepoll[THEN lepoll_imp_cardinal_le, of Y
          "|{x\<in>X . F`x = y}|"] cardinal_idem by auto
    ultimately
    have "|\<Union>y\<in>Y. {x\<in>X . F`x = y}| \<le> |Y|"
      using lepoll_imp_cardinal_UN_le[of "|Y|" Y]
        Infinite_InfCard_cardinal[of Y] by simp
    moreover from \<open>F \<in> Finite_to_one(X,Y) \<inter> surj(X,Y)\<close>
    have "|Y| \<le> |X|"
      using surj_implies_cardinal_le by auto
    moreover
    note \<open>X = (\<Union>y\<in>Y. {x\<in>X . F`x = y})\<close>
    ultimately
    show ?thesis
      using le_anti_sym by auto
  qed
qed

lemma cardinal_map_Un:
  assumes "Infinite(X)" "Finite(b)"
  shows "|{a \<union> b . a \<in> X}| = |X|"
proof -
  have "(\<lambda>a\<in>X. a \<union> b) \<in> Finite_to_one(X,{a \<union> b . a \<in> X})"
    "(\<lambda>a\<in>X. a \<union> b) \<in>  surj(X,{a \<union> b . a \<in> X})"
    unfolding surj_def
  proof
    fix d
    have "Finite({a \<in> X . a \<union> b = d})" (is "Finite(?Y(b,d))")
      using \<open>Finite(b)\<close>
    proof (induct arbitrary:d)
      case 0
      have "{a \<in> X . a \<union> 0 = d} = (if d\<in>X then {d} else 0)"
        by auto
      then
      show ?case by simp
    next
      case (cons c b)
      from \<open>c \<notin> b\<close>
      have "?Y(cons(c,b),d) \<subseteq> (if c\<in>d then ?Y(b,d) \<union> ?Y(b,d-{c}) else 0)"
        by auto
      with cons
      show ?case
        using subset_Finite
        by simp
    qed
    moreover
    assume "d \<in> {x \<union> b . x \<in> X}"
    ultimately
    show "Finite({a \<in> X . (\<lambda>x\<in>X. x \<union> b) ` a = d})"
      by simp
  qed (auto intro:lam_funtype)
  with assms
  show ?thesis
    using Finite_to_one_surj_imp_cardinal_eq by fast
qed

end


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

section {* Theory of the natural numbers: Peano's axioms, primitive recursion *}

theory Nat
imports FOLP
begin

typedecl nat
instance nat :: "term" ..

axiomatization
  Zero :: nat    ("0") and
  Suc :: "nat => nat" and
  rec :: "[nat, 'a, [nat, 'a] => 'a] => 'a" and

  (*Proof terms*)
  nrec :: "[nat, p, [nat, p] => p] => p" and
  ninj :: "p => p" and
  nneq :: "p => p" and
  rec0 :: "p" and
  recSuc :: "p"
where
  induct:     "[| b:P(0); !!x u. u:P(x) ==> c(x,u):P(Suc(x))
              |] ==> nrec(n,b,c):P(n)" and

  Suc_inject: "p:Suc(m)=Suc(n) ==> ninj(p) : m=n" and
  Suc_neq_0:  "p:Suc(m)=0      ==> nneq(p) : R" and
  rec_0:      "rec0 : rec(0,a,f) = a" and
  rec_Suc:    "recSuc : rec(Suc(m), a, f) = f(m, rec(m,a,f))" and
  nrecB0:     "b: A ==> nrec(0,b,c) = b : A" and
  nrecBSuc:   "c(n,nrec(n,b,c)) : A ==> nrec(Suc(n),b,c) = c(n,nrec(n,b,c)) : A"

definition add :: "[nat, nat] => nat"    (infixl "+" 60)
  where "m + n == rec(m, n, %x y. Suc(y))"

subsection {* Proofs about the natural numbers *}

schematic_lemma Suc_n_not_n: "?p : ~ (Suc(k) = k)"
apply (rule_tac n = k in induct)
apply (rule notI)
apply (erule Suc_neq_0)
apply (rule notI)
apply (erule notE)
apply (erule Suc_inject)
done

schematic_lemma "?p : (k+m)+n = k+(m+n)"
apply (rule induct)
back
back
back
back
back
back
oops

schematic_lemma add_0 [simp]: "?p : 0+n = n"
apply (unfold add_def)
apply (rule rec_0)
done

schematic_lemma add_Suc [simp]: "?p : Suc(m)+n = Suc(m+n)"
apply (unfold add_def)
apply (rule rec_Suc)
done

schematic_lemma Suc_cong: "p : x = y \<Longrightarrow> ?p : Suc(x) = Suc(y)"
  apply (erule subst)
  apply (rule refl)
  done

schematic_lemma Plus_cong: "[| p : a = x;  q: b = y |] ==> ?p : a + b = x + y"
  apply (erule subst, erule subst, rule refl)
  done

lemmas nat_congs = Suc_cong Plus_cong

ML {*
  val add_ss = FOLP_ss addcongs @{thms nat_congs} addrews [@{thm add_0}, @{thm add_Suc}]
*}

schematic_

schematic_lemma add_0_right: "?p : m+0 = m"
apply (rule_tac n = m in induct)
apply (tactic {* SIMP_TAC add_ss 1 *})
apply (tactic {* ASM_SIMP_TAC add_ss 1 *})
done

schematic_lemma add_Suc_right: "?p : m+Suc(n) = Suc(m+n)"
apply (rule_tac n = m in induct)
apply (tactic {* ALLGOALS (ASM_SIMP_TAC add_ss) *})
done

(*mk_typed_congs appears not to work with FOLP's version of subst*)

end


section "Arithmetic and Boolean Expressions"

theory LExp
imports "~~/src/HOL/IMP/BExp"
        "~~/src/HOL/IMP/ASM"
begin

datatype lexp = Nl int | Vl vname | Plusl lexp lexp | LET vname lexp lexp

fun lval :: "lexp \<Rightarrow> state \<Rightarrow> int" where
"lval (Nl n) s = n" |
"lval (Vl x) s = s x" |
"lval (Plusl a\<^sub>1 a\<^sub>2) s = (lval a\<^sub>1 s) + (lval a\<^sub>2 s)" |
"lval (LET x a\<^sub>1 a\<^sub>2) s = (let e = lval a\<^sub>1 s in lval a\<^sub>2 (s(x := e)))"

value "lval (Plusl (Vl ''x'') (Nl 5)) (\<lambda>x. if x = ''x'' then 7 else 0)"
value "lval (Plusl (Vl ''x'') (Nl 5)) ((\<lambda>x. 0) (''x'':= 7))"
value "lval (Plusl (Vl ''x'') (Nl 5)) <''x'':= 7>"
value "lval (Plusl (Vl ''x'') (Nl 5)) <''y'':= 7>"
value "lval (Plusl (Vl ''x'') (Nl 5)) <''x'':= 7, ''x'' := 5>"
value "lval (LET ''y'' (Nl 3) (Plusl (Vl ''y'') (Vl ''x''))) ((\<lambda>x. 0) (''x'':= 7))"

fun asubst :: "vname \<Rightarrow> aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"asubst x a (N n) = N n" |
"asubst x a (V y) = (if x = y then a else V y)" |
"asubst x a (Plus e1 e2) = Plus (asubst x a e1) (asubst x a e2)"

value "asubst ''x'' (N 3) (Plus (V ''x'' ) (V ''y''))"

fun lsubst :: "vname \<Rightarrow> lexp \<Rightarrow> lexp \<Rightarrow> lexp" where
"lsubst x a (Nl n) = Nl n" |
"lsubst x a (Vl y) = (if x = y then a else Vl y)" |
"lsubst x a (Plusl e1 e2) = Plusl (lsubst x a e1) (lsubst x a e2)" |
"lsubst x a (LET y e1 e2) = LET y (lsubst x a e1) (lsubst x a e2)"

fun inline :: "lexp \<Rightarrow> aexp" where
"inline (Nl n) = N n" |
"inline (Vl x) = V x" |
"inline (Plusl e1 e2) = Plus (inline e1) (inline e2)" |
"inline (LET x e1 e2) =
    (let a1 = inline e1 in
     let a2 = inline e2 in
     asubst x a1 a2)"

value "inline (Nl 2)"
value "inline (Vl ''x'')"
value "inline (LET ''x'' (Nl 1) (Vl ''x''))"
value "inline (LET ''x'' (Nl 1) (Plusl (Vl ''y'') (Vl ''x'')))"
value "inline (LET ''x'' (Nl 1) (Plusl (Vl ''x'') (Vl ''x'')))"

lemma aval_subst [simp]:"aval (asubst x a1 a2) s = aval a2 (s(x := aval a1 s))"
apply(induction a2)
apply(auto)
done

lemma "lval a s = aval (inline a) s"
apply(induction a arbitrary: s)
apply(auto)
done

end