(*  Title:     HOL/Probability/Levy.thy
    Authors:   Jeremy Avigad (CMU)
*)

section \<open>The Levy inversion theorem, and the Levy continuity theorem.\<close>

theory Levy
  imports Characteristic_Functions Helly_Selection Sinc_Integral
begin

subsection \<open>The Levy inversion theorem\<close>

(* Actually, this is not needed for us -- but it is useful for other purposes. (See Billingsley.) *)
lemma Levy_Inversion_aux1:
  fixes a b :: real
  assumes "a \<le> b"
  shows "((\<lambda>t. (iexp (-(t * a)) - iexp (-(t * b))) / (\<i> * t)) \<longlongrightarrow> b - a) (at 0)"
    (is "(?F \<longlongrightarrow> _) (at _)")
proof -
  have 1: "cmod (?F t - (b - a)) \<le> a^2 / 2 * abs t + b^2 / 2 * abs t" if "t \<noteq> 0" for t
  proof -
    have "cmod (?F t - (b - a)) = cmod (
        (iexp (-(t * a)) - (1 + \<i> * -(t * a))) / (\<i> * t) -
        (iexp (-(t * b)) - (1 + \<i> * -(t * b))) / (\<i> * t))"
           (is "_ = cmod (?one / (\<i> * t) - ?two / (\<i> * t))")
      using \<open>t \<noteq> 0\<close> by (intro arg_cong[where f=norm]) (simp add: field_simps)
    also have "\<dots> \<le> cmod (?one / (\<i> * t)) + cmod (?two / (\<i> * t))"
      by (rule norm_triangle_ineq4)
    also have "cmod (?one / (\<i> * t)) = cmod ?one / abs t"
      by (simp add: norm_divide norm_mult)
    also have "cmod (?two / (\<i> * t)) = cmod ?two / abs t"
      by (simp add: norm_divide norm_mult)
    also have "cmod ?one / abs t + cmod ?two / abs t \<le>
        ((- (a * t))^2 / 2) / abs t + ((- (b * t))^2 / 2) / abs t"
      apply (rule add_mono)
      apply (rule divide_right_mono)
      using iexp_approx1 [of "-(t * a)" 1] apply (simp add: field_simps eval_nat_numeral)
      apply force
      apply (rule divide_right_mono)
      using iexp_approx1 [of "-(t * b)" 1] apply (simp add: field_simps eval_nat_numeral)
      by force
    also have "\<dots> = a^2 / 2 * abs t + b^2 / 2 * abs t"
      using \<open>t \<noteq> 0\<close> apply (case_tac "t \<ge> 0", simp add: field_simps power2_eq_square)
      using \<open>t \<noteq> 0\<close> by (subst (1 2) abs_of_neg, auto simp add: field_simps power2_eq_square)
    finally show "cmod (?F t - (b - a)) \<le> a^2 / 2 * abs t + b^2 / 2 * abs t" .
  qed
  show ?thesis
    apply (rule LIM_zero_cancel)
    apply (rule tendsto_norm_zero_cancel)
    apply (rule real_LIM_sandwich_zero [OF _ _ 1])
    apply (auto intro!: tendsto_eq_intros)
    done
qed

lemma Levy_Inversion_aux2:
  fixes a b t :: real
  assumes "a \<le> b" and "t \<noteq> 0"
  shows "cmod ((iexp (t * b) - iexp (t * a)) / (\<i> * t)) \<le> b - a" (is "?F \<le> _")
proof -
  have "?F = cmod (iexp (t * a) * (iexp (t * (b - a)) - 1) / (\<i> * t))"
    using \<open>t \<noteq> 0\<close> by (intro arg_cong[where f=norm]) (simp add: field_simps exp_diff exp_minus)
  also have "\<dots> = cmod (iexp (t * (b - a)) - 1) / abs t"
    unfolding norm_divide norm_mult norm_exp_i_times using \<open>t \<noteq> 0\<close>
    by (simp add: complex_eq_iff norm_mult)
  also have "\<dots> \<le> abs (t * (b - a)) / abs t"
    using iexp_approx1 [of "t * (b - a)" 0]
    by (intro divide_right_mono) (auto simp add: field_simps eval_nat_numeral)
  also have "\<dots> = b - a"
    using assms by (auto simp add: abs_mult)
  finally show ?thesis .
qed

(* TODO: refactor! *)
theorem (in real_distribution) Levy_Inversion:
  fixes a b :: real
  assumes "a \<le> b"
  defines "\<mu> \<equiv> measure M" and "\<phi> \<equiv> char M"
  assumes "\<mu> {a} = 0" and "\<mu> {b} = 0"
  shows "(\<lambda>T. 1 / (2 * pi) * (CLBINT t=-T..T. (iexp (-(t * a)) - iexp (-(t * b))) / (\<i> * t) * \<phi> t))
    \<longlonglongrightarrow> \<mu> {a<..b}"
    (is "(\<lambda>T. 1 / (2 * pi) * (CLBINT t=-T..T. ?F t * \<phi> t)) \<longlonglongrightarrow> of_real (\<mu> {a<..b})")
proof -
  interpret P: pair_sigma_finite lborel M ..
  from bounded_Si obtain B where Bprop: "\<And>T. abs (Si T) \<le> B" by auto
  from Bprop [of 0] have [simp]: "B \<ge> 0" by auto
  let ?f = "\<lambda>t x :: real. (iexp (t * (x - a)) - iexp(t * (x - b))) / (\<i> * t)"
  { fix T :: real
    assume "T \<ge> 0"
    let ?f' = "\<lambda>(t, x). indicator {-T<..<T} t *\<^sub>R ?f t x"
    { fix x
      have 1: "complex_interval_lebesgue_integrable lborel u v (\<lambda>t. ?f t x)" for u v :: real
        using Levy_Inversion_aux2[of "x - b" "x - a"]
        apply (simp add: interval_lebesgue_integrable_def set_integrable_def del: times_divide_eq_left)
        apply (intro integrableI_bounded_set_indicator[where B="b - a"] conjI impI)
        apply (auto intro!: AE_I [of _ _ "{0}"] simp: assms)
        done
      have "(CLBINT t. ?f' (t, x)) = (CLBINT t=-T..T. ?f t x)"
        using \<open>T \<ge> 0\<close> by (simp add: interval_lebesgue_integral_def set_lebesgue_integral_def)
      also have "\<dots> = (CLBINT t=-T..(0 :: real). ?f t x) + (CLBINT t=(0 :: real)..T. ?f t x)"
          (is "_ = _ + ?t")
        using 1 by (intro interval_integral_sum[symmetric]) (simp add: min_absorb1 max_absorb2 \<open>T \<ge> 0\<close>)
      also have "(CLBINT t=-T..(0 :: real). ?f t x) = (CLBINT t=(0::real)..T. ?f (-t) x)"
        by (subst interval_integral_reflect) auto
      also have "\<dots> + ?t = (CLBINT t=(0::real)..T. ?f (-t) x + ?f t x)"
        using 1
        by (intro interval_lebesgue_integral_add(2) [symmetric] interval_integrable_mirror[THEN iffD2]) simp_all
      also have "\<dots> = (CLBINT t=(0::real)..T. ((iexp(t * (x - a)) - iexp (-(t * (x - a)))) -
          (iexp(t * (x - b)) - iexp (-(t * (x - b))))) / (\<i> * t))"
        using \<open>T \<ge> 0\<close> by (intro interval_integral_cong) (auto simp add: field_split_simps)
      also have "\<dots> = (CLBINT t=(0::real)..T. complex_of_real(
          2 * (sin (t * (x - a)) / t) - 2 * (sin (t * (x - b)) / t)))"
        using \<open>T \<ge> 0\<close>
        apply (intro interval_integral_cong)
        apply (simp add: field_simps cis.ctr Im_divide Re_divide Im_exp Re_exp complex_eq_iff)
        unfolding minus_diff_eq[symmetric, of "y * x" "y * a" for y a] sin_minus cos_minus
        apply (simp add: field_simps power2_eq_square)
        done
      also have "\<dots> = complex_of_real (LBINT t=(0::real)..T.
          2 * (sin (t * (x - a)) / t) - 2 * (sin (t * (x - b)) / t))"
        by (rule interval_lebesgue_integral_of_real)
      also have "\<dots> = complex_of_real (2 * (sgn (x - a) * Si (T * abs (x - a)) -
          sgn (x - b) * Si (T * abs (x - b))))"
        apply (subst interval_lebesgue_integral_diff)
        apply (rule interval_lebesgue_integrable_mult_right, rule integrable_sinc')+
        apply (subst interval_lebesgue_integral_mult_right)+
        apply (simp add: zero_ereal_def[symmetric] LBINT_I0c_sin_scale_divide[OF \<open>T \<ge> 0\<close>])
        done
      finally have "(CLBINT t. ?f' (t, x)) =
          2 * (sgn (x - a) * Si (T * abs (x - a)) - sgn (x - b) * Si (T * abs (x - b)))" .
    } note main_eq = this
    have "(CLBINT t=-T..T. ?F t * \<phi> t) =
      (CLBINT t. (CLINT x | M. ?F t * iexp (t * x) * indicator {-T<..<T} t))"
      using \<open>T \<ge> 0\<close> unfolding \<phi>_def char_def interval_lebesgue_integral_def set_lebesgue_integral_def
      by (auto split: split_indicator intro!: Bochner_Integration.integral_cong)
    also have "\<dots> = (CLBINT t. (CLINT x | M. ?f' (t, x)))"
      by (auto intro!: Bochner_Integration.integral_cong simp: field_simps exp_diff exp_minus split: split_indicator)
    also have "\<dots> = (CLINT x | M. (CLBINT t. ?f' (t, x)))"
    proof (intro P.Fubini_integral [symmetric] integrableI_bounded_set [where B="b - a"])
      show "emeasure (lborel \<Otimes>\<^sub>M M) ({- T<..<T} \<times> space M) < \<infinity>"
        using \<open>T \<ge> 0\<close>
        by (subst emeasure_pair_measure_Times)
           (auto simp: ennreal_mult_less_top not_less top_unique)
      show "AE x\<in>{- T<..<T} \<times> space M in lborel \<Otimes>\<^sub>M M. cmod (case x of (t, x) \<Rightarrow> ?f' (t, x)) \<le> b - a"
        using Levy_Inversion_aux2[of "x - b" "x - a" for x] \<open>a \<le> b\<close>
        by (intro AE_I [of _ _ "{0} \<times> UNIV"]) (force simp: emeasure_pair_measure_Times)+
    qed (auto split: split_indicator split_indicator_asm)
    also have "\<dots> = (CLINT x | M. (complex_of_real (2 * (sgn (x - a) *
         Si (T * abs (x - a)) - sgn (x - b) * Si (T * abs (x - b))))))"
       using main_eq by (intro Bochner_Integration.integral_cong, auto)
    also have "\<dots> = complex_of_real (LINT x | M. (2 * (sgn (x - a) *
         Si (T * abs (x - a)) - sgn (x - b) * Si (T * abs (x - b)))))"
       by (rule integral_complex_of_real)
    finally have "(CLBINT t=-T..T. ?F t * \<phi> t) =
        complex_of_real (LINT x | M. (2 * (sgn (x - a) *
         Si (T * abs (x - a)) - sgn (x - b) * Si (T * abs (x - b)))))" .
  } note main_eq2 = this

  have "(\<lambda>T :: nat. LINT x | M. (2 * (sgn (x - a) *
         Si (T * abs (x - a)) - sgn (x - b) * Si (T * abs (x - b))))) \<longlonglongrightarrow>
       (LINT x | M. 2 * pi * indicator {a<..b} x)"
  proof (rule integral_dominated_convergence [where w="\<lambda>x. 4 * B"])
    show "integrable M (\<lambda>x. 4 * B)"
      by (rule integrable_const_bound [of _ "4 * B"]) auto
  next
    let ?S = "\<lambda>n::nat. \<lambda>x. sgn (x - a) * Si (n * \<bar>x - a\<bar>) - sgn (x - b) * Si (n * \<bar>x - b\<bar>)"
    { fix n x
      have "norm (?S n x) \<le> norm (sgn (x - a) * Si (n * \<bar>x - a\<bar>)) + norm (sgn (x - b) * Si (n * \<bar>x - b\<bar>))"
        by (rule norm_triangle_ineq4)
      also have "\<dots> \<le> B + B"
        using Bprop by (intro add_mono) (auto simp: abs_mult abs_sgn_eq)
      finally have "norm (2 * ?S n x) \<le> 4 * B"
        by simp }
    then show "\<And>n. AE x in M. norm (2 * ?S n x) \<le> 4 * B"
      by auto
    have "AE x in M. x \<noteq> a" "AE x in M. x \<noteq> b"
      using prob_eq_0[of "{a}"] prob_eq_0[of "{b}"] \<open>\<mu> {a} = 0\<close> \<open>\<mu> {b} = 0\<close> by (auto simp: \<mu>_def)
    then show "AE x in M. (\<lambda>n. 2 * ?S n x) \<longlonglongrightarrow> 2 * pi * indicator {a<..b} x"
    proof eventually_elim
      fix x assume x: "x \<noteq> a" "x \<noteq> b"
      then have "(\<lambda>n. 2 * (sgn (x - a) * Si (\<bar>x - a\<bar> * n) - sgn (x - b) * Si (\<bar>x - b\<bar> * n)))
          \<longlonglongrightarrow> 2 * (sgn (x - a) * (pi / 2) - sgn (x - b) * (pi / 2))"
        by (intro tendsto_intros filterlim_compose[OF Si_at_top]
            filterlim_tendsto_pos_mult_at_top[OF tendsto_const] filterlim_real_sequentially)
           auto
      also have "(\<lambda>n. 2 * (sgn (x - a) * Si (\<bar>x - a\<bar> * n) - sgn (x - b) * Si (\<bar>x - b\<bar> * n))) = (\<lambda>n. 2 * ?S n x)"
        by (auto simp: ac_simps)
      also have "2 * (sgn (x - a) * (pi / 2) - sgn (x - b) * (pi / 2)) = 2 * pi * indicator {a<..b} x"
        using x \<open>a \<le> b\<close> by (auto split: split_indicator)
      finally show "(\<lambda>n. 2 * ?S n x) \<longlonglongrightarrow> 2 * pi * indicator {a<..b} x" .
    qed
  qed simp_all
  also have "(LINT x | M. 2 * pi * indicator {a<..b} x) = 2 * pi * \<mu> {a<..b}"
    by (simp add: \<mu>_def)
  finally have "(\<lambda>T. LINT x | M. (2 * (sgn (x - a) *
         Si (T * abs (x - a)) - sgn (x - b) * Si (T * abs (x - b))))) \<longlonglongrightarrow>
       2 * pi * \<mu> {a<..b}" .
  with main_eq2 show ?thesis
    by (auto intro!: tendsto_eq_intros)
qed

theorem Levy_uniqueness:
  fixes M1 M2 :: "real measure"
  assumes "real_distribution M1" "real_distribution M2" and
    "char M1 = char M2"
  shows "M1 = M2"
proof -
  interpret M1: real_distribution M1 by (rule assms)
  interpret M2: real_distribution M2 by (rule assms)
  have "countable ({x. measure M1 {x} \<noteq> 0} \<union> {x. measure M2 {x} \<noteq> 0})"
    by (intro countable_Un M2.countable_support M1.countable_support)
  then have count: "countable {x. measure M1 {x} \<noteq> 0 \<or> measure M2 {x} \<noteq> 0}"
    by (simp add: Un_def)

  have "cdf M1 = cdf M2"
  proof (rule ext)
    fix x
    let ?D = "\<lambda>x. \<bar>cdf M1 x - cdf M2 x\<bar>"

    { fix \<epsilon> :: real
      assume "\<epsilon> > 0"
      have "(?D \<longlongrightarrow> 0) at_bot"
        using M1.cdf_lim_at_bot M2.cdf_lim_at_bot by (intro tendsto_eq_intros) auto
      then have "eventually (\<lambda>y. ?D y < \<epsilon> / 2 \<and> y \<le> x) at_bot"
        using \<open>\<epsilon> > 0\<close> by (simp only: tendsto_iff dist_real_def diff_0_right eventually_conj eventually_le_at_bot abs_idempotent)
      then obtain M where "\<And>y. y \<le> M \<Longrightarrow> ?D y < \<epsilon> / 2" "M \<le> x"
        unfolding eventually_at_bot_linorder by auto
      with open_minus_countable[OF count, of "{..< M}"] obtain a where
        "measure M1 {a} = 0" "measure M2 {a} = 0" "a < M" "a \<le> x" and 1: "?D a < \<epsilon> / 2"
        by auto

      have "(?D \<longlongrightarrow> ?D x) (at_right x)"
        using M1.cdf_is_right_cont [of x] M2.cdf_is_right_cont [of x]
        by (intro tendsto_intros) (auto simp add: continuous_within)
      then have "eventually (\<lambda>y. \<bar>?D y - ?D x\<bar> < \<epsilon> / 2) (at_right x)"
        using \<open>\<epsilon> > 0\<close> by (simp only: tendsto_iff dist_real_def eventually_conj eventually_at_right_less)
      then obtain N where "N > x" "\<And>y. x < y \<Longrightarrow> y < N \<Longrightarrow> \<bar>?D y - ?D x\<bar> < \<epsilon> / 2"
        by (auto simp add: eventually_at_right[OF less_add_one])
      with open_minus_countable[OF count, of "{x <..< N}"] obtain b where "x < b" "b < N"
          "measure M1 {b} = 0" "measure M2 {b} = 0" and 2: "\<bar>?D b - ?D x\<bar> < \<epsilon> / 2"
        by (auto simp: abs_minus_commute)
      from \<open>a \<le> x\<close> \<open>x < b\<close> have "a < b" "a \<le> b" by auto

      from \<open>char M1 = char M2\<close>
        M1.Levy_Inversion [OF \<open>a \<le> b\<close> \<open>measure M1 {a} = 0\<close> \<open>measure M1 {b} = 0\<close>]
        M2.Levy_Inversion [OF \<open>a \<le> b\<close> \<open>measure M2 {a} = 0\<close> \<open>measure M2 {b} = 0\<close>]
      have "complex_of_real (measure M1 {a<..b}) = complex_of_real (measure M2 {a<..b})"
        by (intro LIMSEQ_unique) auto
      then have "?D a = ?D b"
        unfolding of_real_eq_iff M1.cdf_diff_eq [OF \<open>a < b\<close>, symmetric] M2.cdf_diff_eq [OF \<open>a < b\<close>, symmetric] by simp
      then have "?D x = \<bar>(?D b - ?D x) - ?D a\<bar>"
        by simp
      also have "\<dots> \<le> \<bar>?D b - ?D x\<bar> + \<bar>?D a\<bar>"
        by (rule abs_triangle_ineq4)
      also have "\<dots> \<le> \<epsilon> / 2 + \<epsilon> / 2"
        using 1 2 by (intro add_mono) auto
      finally have "?D x \<le> \<epsilon>" by simp }
    then show "cdf M1 x = cdf M2 x"
      by (metis abs_le_zero_iff dense_ge eq_iff_diff_eq_0)
  qed
  thus ?thesis
    by (rule cdf_unique [OF \<open>real_distribution M1\<close> \<open>real_distribution M2\<close>])
qed

subsection \<open>The Levy continuity theorem\<close>

theorem levy_continuity1:
  fixes M :: "nat \<Rightarrow> real measure" and M' :: "real measure"
  assumes "\<And>n. real_distribution (M n)" "real_distribution M'" "weak_conv_m M M'"
  shows "(\<lambda>n. char (M n) t) \<longlonglongrightarrow> char M' t"
  unfolding char_def using assms by (rule weak_conv_imp_integral_bdd_continuous_conv) auto

theorem levy_continuity:
  fixes M :: "nat \<Rightarrow> real measure" and M' :: "real measure"
  assumes real_distr_M : "\<And>n. real_distribution (M n)"
    and real_distr_M': "real_distribution M'"
    and char_conv: "\<And>t. (\<lambda>n. char (M n) t) \<longlonglongrightarrow> char M' t"
  shows "weak_conv_m M M'"
proof -
  interpret Mn: real_distribution "M n" for n by fact
  interpret M': real_distribution M' by fact

  have *: "\<And>u x. u > 0 \<Longrightarrow> x \<noteq> 0 \<Longrightarrow> (CLBINT t:{-u..u}. 1 - iexp (t * x)) =
      2 * (u  - sin (u * x) / x)"
  proof -
    fix u :: real and x :: real
    assume "u > 0" and "x \<noteq> 0"
    hence "(CLBINT t:{-u..u}. 1 - iexp (t * x)) = (CLBINT t=-u..u. 1 - iexp (t * x))"
      by (subst interval_integral_Icc, auto)
    also have "\<dots> = (CLBINT t=-u..0. 1 - iexp (t * x)) + (CLBINT t=0..u. 1 - iexp (t * x))"
      using \<open>u > 0\<close>
      apply (subst interval_integral_sum)
      apply (simp add: min_absorb1 min_absorb2 max_absorb1 max_absorb2)
      apply (rule interval_integrable_isCont)
      apply auto
      done
    also have "\<dots> = (CLBINT t=ereal 0..u. 1 - iexp (t * -x)) + (CLBINT t=ereal 0..u. 1 - iexp (t * x))"
      apply (subgoal_tac "0 = ereal 0", erule ssubst)
      by (subst interval_integral_reflect, auto)
    also have "\<dots> = (LBINT t=ereal 0..u. 2 - 2 * cos (t * x))"
      apply (subst interval_lebesgue_integral_add (2) [symmetric])
      apply ((rule interval_integrable_isCont, auto)+) [2]
      unfolding exp_Euler cos_of_real
      apply (simp add: of_real_mult interval_lebesgue_integral_of_real[symmetric])
      done
    also have "\<dots> = 2 * u - 2 * sin (u * x) / x"
      by (subst interval_lebesgue_integral_diff)
         (auto intro!: interval_integrable_isCont
               simp: interval_lebesgue_integral_of_real integral_cos [OF \<open>x \<noteq> 0\<close>] mult.commute[of _ x])
    finally show "(CLBINT t:{-u..u}. 1 - iexp (t * x)) = 2 * (u  - sin (u * x) / x)"
      by (simp add: field_simps)
  qed
  have main_bound: "\<And>u n. u > 0 \<Longrightarrow> Re (CLBINT t:{-u..u}. 1 - char (M n) t) \<ge>
    u * measure (M n) {x. abs x \<ge> 2 / u}"
  proof -
    fix u :: real and n
    assume "u > 0"
    interpret P: pair_sigma_finite "M n" lborel ..
    (* TODO: put this in the real_distribution locale as a simp rule? *)
    have Mn1 [simp]: "measure (M n) UNIV = 1" by (metis Mn.prob_space Mn.space_eq_univ)
    (* TODO: make this automatic somehow? *)
    have Mn2 [simp]: "\<And>x. complex_integrable (M n) (\<lambda>t. exp (\<i> * complex_of_real (x * t)))"
      by (rule Mn.integrable_const_bound [where B = 1], auto)
    have Mn3: "set_integrable (M n \<Otimes>\<^sub>M lborel) (UNIV \<times> {- u..u}) (\<lambda>a. 1 - exp (\<i> * complex_of_real (snd a * fst a)))"
      using \<open>0 < u\<close>
      unfolding set_integrable_def
      by (intro integrableI_bounded_set_indicator [where B="2"])
         (auto simp: lborel.emeasure_pair_measure_Times ennreal_mult_less_top not_less top_unique
               split: split_indicator
               intro!: order_trans [OF norm_triangle_ineq4])
    have "(CLBINT t:{-u..u}. 1 - char (M n) t) =
        (CLBINT t:{-u..u}. (CLINT x | M n. 1 - iexp (t * x)))"
      unfolding char_def by (rule set_lebesgue_integral_cong, auto simp del: of_real_mult)
    also have "\<dots> = (CLBINT t. (CLINT x | M n. indicator {-u..u} t *\<^sub>R (1 - iexp (t * x))))"
      unfolding set_lebesgue_integral_def
      by (rule Bochner_Integration.integral_cong) (auto split: split_indicator)
    also have "\<dots> = (CLINT x | M n. (CLBINT t:{-u..u}. 1 - iexp (t * x)))"
      using Mn3 by (subst P.Fubini_integral) (auto simp: indicator_times split_beta' set_integrable_def set_lebesgue_integral_def)
    also have "\<dots> = (CLINT x | M n. (if x = 0 then 0 else 2 * (u  - sin (u * x) / x)))"
      using \<open>u > 0\<close> by (intro Bochner_Integration.integral_cong, auto simp add: * simp del: of_real_mult)
    also have "\<dots> = (LINT x | M n. (if x = 0 then 0 else 2 * (u  - sin (u * x) / x)))"
      by (rule integral_complex_of_real)
    finally have "Re (CLBINT t:{-u..u}. 1 - char (M n) t) =
       (LINT x | M n. (if x = 0 then 0 else 2 * (u  - sin (u * x) / x)))" by simp
    also have "\<dots> \<ge> (LINT x : {x. abs x \<ge> 2 / u} | M n. u)"
    proof -
      have "complex_integrable (M n) (\<lambda>x. CLBINT t:{-u..u}. 1 - iexp (snd (x, t) * fst (x, t)))"
        using Mn3 unfolding set_integrable_def set_lebesgue_integral_def
        by (intro P.integrable_fst) (simp add: indicator_times split_beta')
      hence "complex_integrable (M n) (\<lambda>x. if x = 0 then 0 else 2 * (u  - sin (u * x) / x))"
        using \<open>u > 0\<close>
        unfolding set_integrable_def
        by (subst Bochner_Integration.integrable_cong) (auto simp add: * simp del: of_real_mult)
      hence **: "integrable (M n) (\<lambda>x. if x = 0 then 0 else 2 * (u  - sin (u * x) / x))"
        unfolding complex_of_real_integrable_eq .
      have "2 * sin x \<le> x" if "2 \<le> x" for x :: real
        by (rule order_trans[OF _ \<open>2 \<le> x\<close>]) auto
      moreover have "x \<le> 2 * sin x" if "x \<le> - 2" for x :: real
        by (rule order_trans[OF \<open>x \<le> - 2\<close>]) auto
      moreover have "x < 0 \<Longrightarrow> x \<le> sin x" for x :: real
        using sin_x_le_x[of "-x"] by simp
      ultimately show ?thesis
        using \<open>u > 0\<close> unfolding set_lebesgue_integral_def
        by (intro integral_mono [OF _ **])
           (auto simp: divide_simps sin_x_le_x mult.commute[of u] mult_neg_pos top_unique less_top[symmetric]
                 split: split_indicator)
    qed
    also (xtrans) have "(LINT x : {x. abs x \<ge> 2 / u} | M n. u) = u * measure (M n) {x. abs x \<ge> 2 / u}"
      unfolding set_lebesgue_integral_def
      by (simp add: Mn.emeasure_eq_measure)
    finally show "Re (CLBINT t:{-u..u}. 1 - char (M n) t) \<ge> u * measure (M n) {x. abs x \<ge> 2 / u}" .
  qed

  have tight_aux: "\<And>\<epsilon>. \<epsilon> > 0 \<Longrightarrow> \<exists>a b. a < b \<and> (\<forall>n. 1 - \<epsilon> < measure (M n) {a<..b})"
  proof -
    fix \<epsilon> :: real
    assume "\<epsilon> > 0"
    note M'.isCont_char [of 0]
    hence "\<exists>d>0. \<forall>t. abs t < d \<longrightarrow> cmod (char M' t - 1) < \<epsilon> / 4"
      apply (subst (asm) continuous_at_eps_delta)
      apply (drule_tac x = "\<epsilon> / 4" in spec)
      using \<open>\<epsilon> > 0\<close> by (auto simp add: dist_real_def dist_complex_def M'.char_zero)
    then obtain d where "d > 0 \<and> (\<forall>t. (abs t < d \<longrightarrow> cmod (char M' t - 1) < \<epsilon> / 4))" ..
    hence d0: "d > 0" and d1: "\<And>t. abs t < d \<Longrightarrow> cmod (char M' t - 1) < \<epsilon> / 4" by auto
    have 1: "\<And>x. cmod (1 - char M' x) \<le> 2"
      by (rule order_trans [OF norm_triangle_ineq4], auto simp add: M'.cmod_char_le_1)
    then have 2: "\<And>u v. complex_set_integrable lborel {u..v} (\<lambda>x. 1 - char M' x)"
      unfolding set_integrable_def
      by (intro integrableI_bounded_set_indicator[where B=2]) (auto simp: emeasure_lborel_Icc_eq)
    have 3: "\<And>u v. integrable lborel (\<lambda>x. indicat_real {u..v} x *\<^sub>R cmod (1 - char M' x))"
      by (intro borel_integrable_compact[OF compact_Icc] continuous_at_imp_continuous_on
                continuous_intros ballI M'.isCont_char continuous_intros)
    have "cmod (CLBINT t:{-d/2..d/2}. 1 - char M' t) \<le> LBINT t:{-d/2..d/2}. cmod (1 - char M' t)"
      unfolding set_lebesgue_integral_def
      using integral_norm_bound[of _ "\<lambda>x. indicator {u..v} x *\<^sub>R (1 - char M' x)" for u v] by simp
    also have 4: "\<dots> \<le> LBINT t:{-d/2..d/2}. \<epsilon> / 4"
      unfolding set_lebesgue_integral_def
      apply (rule integral_mono [OF 3])
       apply (simp add: emeasure_lborel_Icc_eq)
      apply (case_tac "x \<in> {-d/2..d/2}")
       apply auto
      apply (subst norm_minus_commute)
      apply (rule less_imp_le)
      apply (rule d1 [simplified])
      using d0 apply auto
      done
    also from d0 4 have "\<dots> = d * \<epsilon> / 4"
      unfolding set_lebesgue_integral_def by simp
    finally have bound: "cmod (CLBINT t:{-d/2..d/2}. 1 - char M' t) \<le> d * \<epsilon> / 4" .
    have "cmod (1 - char (M n) x) \<le> 2" for n x
      by (rule order_trans [OF norm_triangle_ineq4], auto simp add: Mn.cmod_char_le_1)
    then have "(\<lambda>n. CLBINT t:{-d/2..d/2}. 1 - char (M n) t) \<longlonglongrightarrow> (CLBINT t:{-d/2..d/2}. 1 - char M' t)"
      unfolding set_lebesgue_integral_def
      apply (intro integral_dominated_convergence[where w="\<lambda>x. indicator {-d/2..d/2} x *\<^sub>R 2"])
      apply (auto intro!: char_conv tendsto_intros
                  simp: emeasure_lborel_Icc_eq
                  split: split_indicator)
      done
    hence "eventually (\<lambda>n. cmod ((CLBINT t:{-d/2..d/2}. 1 - char (M n) t) -
        (CLBINT t:{-d/2..d/2}. 1 - char M' t)) < d * \<epsilon> / 4) sequentially"
      using d0 \<open>\<epsilon> > 0\<close> apply (subst (asm) tendsto_iff)
      by (subst (asm) dist_complex_def, drule spec, erule mp, auto)
    hence "\<exists>N. \<forall>n \<ge> N. cmod ((CLBINT t:{-d/2..d/2}. 1 - char (M n) t) -
        (CLBINT t:{-d/2..d/2}. 1 - char M' t)) < d * \<epsilon> / 4" by (simp add: eventually_sequentially)
    then obtain N
      where "\<forall>n\<ge>N. cmod ((CLBINT t:{- d / 2..d / 2}. 1 - char (M n) t) -
        (CLBINT t:{- d / 2..d / 2}. 1 - char M' t)) < d * \<epsilon> / 4" ..
    hence N: "\<And>n. n \<ge> N \<Longrightarrow> cmod ((CLBINT t:{-d/2..d/2}. 1 - char (M n) t) -
        (CLBINT t:{-d/2..d/2}. 1 - char M' t)) < d * \<epsilon> / 4" by auto
    { fix n
      assume "n \<ge> N"
      have "cmod (CLBINT t:{-d/2..d/2}. 1 - char (M n) t) =
        cmod ((CLBINT t:{-d/2..d/2}. 1 - char (M n) t) - (CLBINT t:{-d/2..d/2}. 1 - char M' t)
          + (CLBINT t:{-d/2..d/2}. 1 - char M' t))" by simp
      also have "\<dots> \<le> cmod ((CLBINT t:{-d/2..d/2}. 1 - char (M n) t) -
          (CLBINT t:{-d/2..d/2}. 1 - char M' t)) + cmod(CLBINT t:{-d/2..d/2}. 1 - char M' t)"
        by (rule norm_triangle_ineq)
      also have "\<dots> < d * \<epsilon> / 4 + d * \<epsilon> / 4"
        by (rule add_less_le_mono [OF N [OF \<open>n \<ge> N\<close>] bound])
      also have "\<dots> = d * \<epsilon> / 2" by auto
      finally have "cmod (CLBINT t:{-d/2..d/2}. 1 - char (M n) t) < d * \<epsilon> / 2" .
      hence "d * \<epsilon> / 2 > Re (CLBINT t:{-d/2..d/2}. 1 - char (M n) t)"
        by (rule order_le_less_trans [OF complex_Re_le_cmod])
      hence "d * \<epsilon> / 2 > Re (CLBINT t:{-(d/2)..d/2}. 1 - char (M n) t)" (is "_ > ?lhs") by simp
      also have "?lhs \<ge> (d / 2) * measure (M n) {x. abs x \<ge> 2 / (d / 2)}"
        using d0 by (intro main_bound, simp)
      finally (xtrans) have "d * \<epsilon> / 2 > (d / 2) * measure (M n) {x. abs x \<ge> 2 / (d / 2)}" .
      with d0 \<open>\<epsilon> > 0\<close> have "\<epsilon> > measure (M n) {x. abs x \<ge> 2 / (d / 2)}" by (simp add: field_simps)
      hence "\<epsilon> > 1 - measure (M n) (UNIV - {x. abs x \<ge> 2 / (d / 2)})"
        apply (subst Mn.borel_UNIV [symmetric])
        by (subst Mn.prob_compl, auto)
      also have "UNIV - {x. abs x \<ge> 2 / (d / 2)} = {x. -(4 / d) < x \<and> x < (4 / d)}"
        using d0 apply (auto simp add: field_simps)
        (* very annoying -- this should be automatic *)
        apply (case_tac "x \<ge> 0", auto simp add: field_simps)
        apply (subgoal_tac "0 \<le> x * d", arith, rule mult_nonneg_nonneg, auto)
        apply (case_tac "x \<ge> 0", auto simp add: field_simps)
        apply (subgoal_tac "x * d \<le> 0", arith)
        apply (rule mult_nonpos_nonneg, auto)
        by (case_tac "x \<ge> 0", auto simp add: field_simps)
      finally have "measure (M n) {x. -(4 / d) < x \<and> x < (4 / d)} > 1 - \<epsilon>"
        by auto
    } note 6 = this
    { fix n :: nat
      have *: "(UN (k :: nat). {- real k<..real k}) = UNIV"
        by (auto, metis leI le_less_trans less_imp_le minus_less_iff reals_Archimedean2)
      have "(\<lambda>k. measure (M n) {- real k<..real k}) \<longlonglongrightarrow>
          measure (M n) (UN (k :: nat). {- real k<..real k})"
        by (rule Mn.finite_Lim_measure_incseq, auto simp add: incseq_def)
      hence "(\<lambda>k. measure (M n) {- real k<..real k}) \<longlonglongrightarrow> 1"
        using Mn.prob_space unfolding * Mn.borel_UNIV by simp
      hence "eventually (\<lambda>k. measure (M n) {- real k<..real k} > 1 - \<epsilon>) sequentially"
        apply (elim order_tendstoD (1))
        using \<open>\<epsilon> > 0\<close> by auto
    } note 7 = this
    { fix n :: nat
      have "eventually (\<lambda>k. \<forall>m < n. measure (M m) {- real k<..real k} > 1 - \<epsilon>) sequentially"
        (is "?P n")
      proof (induct n)
        case (Suc n) with 7[of n] show ?case
          by eventually_elim (auto simp add: less_Suc_eq)
      qed simp
    } note 8 = this
    from 8 [of N] have "\<exists>K :: nat. \<forall>k \<ge> K. \<forall>m<N. 1 - \<epsilon> <
        Sigma_Algebra.measure (M m) {- real k<..real k}"
      by (auto simp add: eventually_sequentially)
    hence "\<exists>K :: nat. \<forall>m<N. 1 - \<epsilon> < Sigma_Algebra.measure (M m) {- real K<..real K}" by auto
    then obtain K :: nat where
      "\<forall>m<N. 1 - \<epsilon> < Sigma_Algebra.measure (M m) {- real K<..real K}" ..
    hence K: "\<And>m. m < N \<Longrightarrow> 1 - \<epsilon> < Sigma_Algebra.measure (M m) {- real K<..real K}"
      by auto
    let ?K' = "max K (4 / d)"
    have "-?K' < ?K' \<and> (\<forall>n. 1 - \<epsilon> < measure (M n) {-?K'<..?K'})"
      using d0 apply auto
      apply (rule max.strict_coboundedI2, auto)
    proof -
      fix n
      show " 1 - \<epsilon> < measure (M n) {- max (real K) (4 / d)<..max (real K) (4 / d)}"
        apply (case_tac "n < N")
        apply (rule order_less_le_trans)
        apply (erule K)
        apply (rule Mn.finite_measure_mono, auto)
        apply (rule order_less_le_trans)
        apply (rule 6, erule leI)
        by (rule Mn.finite_measure_mono, auto)
    qed
    thus "\<exists>a b. a < b \<and> (\<forall>n. 1 - \<epsilon> < measure (M n) {a<..b})" by (intro exI)
  qed
  have tight: "tight M"
    by (auto simp: tight_def intro: assms tight_aux)
  show ?thesis
  proof (rule tight_subseq_weak_converge [OF real_distr_M real_distr_M' tight])
    fix s \<nu>
    assume s: "strict_mono (s :: nat \<Rightarrow> nat)"
    assume nu: "weak_conv_m (M \<circ> s) \<nu>"
    assume *: "real_distribution \<nu>"
    have 2: "\<And>n. real_distribution ((M \<circ> s) n)" unfolding comp_def by (rule assms)
    have 3: "\<And>t. (\<lambda>n. char ((M \<circ> s) n) t) \<longlonglongrightarrow> char \<nu> t" by (intro levy_continuity1 [OF 2 * nu])
    have 4: "\<And>t. (\<lambda>n. char ((M \<circ> s) n) t) = ((\<lambda>n. char (M n) t) \<circ> s)" by (rule ext, simp)
    have 5: "\<And>t. (\<lambda>n. char ((M \<circ> s) n) t) \<longlonglongrightarrow> char M' t"
      by (subst 4, rule LIMSEQ_subseq_LIMSEQ [OF _ s], rule assms)
    hence "char \<nu> = char M'" by (intro ext, intro LIMSEQ_unique [OF 3 5])
    hence "\<nu> = M'" by (rule Levy_uniqueness [OF * \<open>real_distribution M'\<close>])
    thus "weak_conv_m (M \<circ> s) M'"
      by (elim subst) (rule nu)
  qed
qed

end


(*  Title:      HOL/Proofs/Extraction/Warshall.thy
    Author:     Stefan Berghofer, TU Muenchen
*)

section {* Warshall's algorithm *}

theory Warshall
imports Old_Datatype
begin

text {*
  Derivation of Warshall's algorithm using program extraction,
  based on Berger, Schwichtenberg and Seisenberger @{cite "Berger-JAR-2001"}.
*}

datatype b = T | F

primrec
  is_path' :: "('a \<Rightarrow> 'a \<Rightarrow> b) \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a \<Rightarrow> bool"
where
    "is_path' r x [] z = (r x z = T)"
  | "is_path' r x (y # ys) z = (r x y = T \<and> is_path' r y ys z)"

definition
  is_path :: "(nat \<Rightarrow> nat \<Rightarrow> b) \<Rightarrow> (nat * nat list * nat) \<Rightarrow>
    nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool"
where
  "is_path r p i j k \<longleftrightarrow> fst p = j \<and> snd (snd p) = k \<and>
     list_all (\<lambda>x. x < i) (fst (snd p)) \<and>
     is_path' r (fst p) (fst (snd p)) (snd (snd p))"

definition
  conc :: "('a * 'a list * 'a) \<Rightarrow> ('a * 'a list * 'a) \<Rightarrow> ('a * 'a list * 'a)"
where
  "conc p q = (fst p, fst (snd p) @ fst q # fst (snd q), snd (snd q))"

theorem is_path'_snoc [simp]:
  "\<And>x. is_path' r x (ys @ [y]) z = (is_path' r x ys y \<and> r y z = T)"
  by (induct ys) simp+

theorem list_all_scoc [simp]: "list_all P (xs @ [x]) \<longleftrightarrow> P x \<and> list_all P xs"
  by (induct xs, simp+, iprover)

theorem list_all_lemma:
  "list_all P xs \<Longrightarrow> (\<And>x. P x \<Longrightarrow> Q x) \<Longrightarrow> list_all Q xs"
proof -
  assume PQ: "\<And>x. P x \<Longrightarrow> Q x"
  show "list_all P xs \<Longrightarrow> list_all Q xs"
  proof (induct xs)
    case Nil
    show ?case by simp
  next
    case (Cons y ys)
    hence Py: "P y" by simp
    from Cons have Pys: "list_all P ys" by simp
    show ?case
      by simp (rule conjI PQ Py Cons Pys)+
  qed
qed

theorem lemma1: "\<And>p. is_path r p i j k \<Longrightarrow> is_path r p (Suc i) j k"
  apply (unfold is_path_def)
  apply (simp cong add: conj_cong add: split_paired_all)
  apply (erule conjE)+
  apply (erule list_all_lemma)
  apply simp
  done

theorem lemma2: "\<And>p. is_path r p 0 j k \<Longrightarrow> r j k = T"
  apply (unfold is_path_def)
  apply (simp cong add: conj_cong add: split_paired_all)
  apply (case_tac "aa")
  apply simp+
  done

theorem is_path'_conc: "is_path' r j xs i \<Longrightarrow> is_path' r i ys k \<Longrightarrow>
  is_path' r j (xs @ i # ys) k"
proof -
  assume pys: "is_path' r i ys k"
  show "\<And>j. is_path' r j xs i \<Longrightarrow> is_path' r j (xs @ i # ys) k"
  proof (induct xs)
    case (Nil j)
    hence "r j i = T" by simp
    with pys show ?case by simp
  next
    case (Cons z zs j)
    hence jzr: "r j z = T" by simp
    from Cons have pzs: "is_path' r z zs i" by simp
    show ?case
      by simp (rule conjI jzr Cons pzs)+
  qed
qed

theorem lemma3:
  "\<And>p q. is_path r p i j i \<Longrightarrow> is_path r q i i k \<Longrightarrow>
   is_path r (conc p q) (Suc i) j k"
  apply (unfold is_path_def conc_def)
  apply (simp cong add: conj_cong add: split_paired_all)
  apply (erule conjE)+
  apply (rule conjI)
  apply (erule list_all_lemma)
  apply simp
  apply (rule conjI)
  apply (erule list_all_lemma)
  apply simp
  apply (rule is_path'_conc)
  apply assumption+
  done

theorem lemma5:
  "\<And>p. is_path r p (Suc i) j k \<Longrightarrow> ~ is_path r p i j k \<Longrightarrow>
   (\<exists>q. is_path r q i j i) \<and> (\<exists>q'. is_path r q' i i k)"
proof (simp cong add: conj_cong add: split_paired_all is_path_def, (erule conjE)+)
  fix xs
  assume asms:
    "list_all (\<lambda>x. x < Suc i) xs"
    "is_path' r j xs k"
    "\<not> list_all (\<lambda>x. x < i) xs"
  show "(\<exists>ys. list_all (\<lambda>x. x < i) ys \<and> is_path' r j ys i) \<and>
    (\<exists>ys. list_all (\<lambda>x. x < i) ys \<and> is_path' r i ys k)"
  proof
    show "\<And>j. list_all (\<lambda>x. x < Suc i) xs \<Longrightarrow> is_path' r j xs k \<Longrightarrow>
      \<not> list_all (\<lambda>x. x < i) xs \<Longrightarrow>
    \<exists>ys. list_all (\<lambda>x. x < i) ys \<and> is_path' r j ys i" (is "PROP ?ih xs")
    proof (induct xs)
      case Nil
      thus ?case by simp
    next
      case (Cons a as j)
      show ?case
      proof (cases "a=i")
        case True
        show ?thesis
        proof
          from True and Cons have "r j i = T" by simp
          thus "list_all (\<lambda>x. x < i) [] \<and> is_path' r j [] i" by simp
        qed
      next
        case False
        have "PROP ?ih as" by (rule Cons)
        then obtain ys where ys: "list_all (\<lambda>x. x < i) ys \<and> is_path' r a ys i"
        proof
          from Cons show "list_all (\<lambda>x. x < Suc i) as" by simp
          from Cons show "is_path' r a as k" by simp
          from Cons and False show "\<not> list_all (\<lambda>x. x < i) as" by (simp)
        qed
        show ?thesis
        proof
          from Cons False ys
          show "list_all (\<lambda>x. x<i) (a#ys) \<and> is_path' r j (a#ys) i" by simp
        qed
      qed
    qed
    show "\<And>k. list_all (\<lambda>x. x < Suc i) xs \<Longrightarrow> is_path' r j xs k \<Longrightarrow>
      \<not> list_all (\<lambda>x. x < i) xs \<Longrightarrow>
      \<exists>ys. list_all (\<lambda>x. x < i) ys \<and> is_path' r i ys k" (is "PROP ?ih xs")
    proof (induct xs rule: rev_induct)
      case Nil
      thus ?case by simp
    next
      case (snoc a as k)
      show ?case
      proof (cases "a=i")
        case True
        show ?thesis
        proof
          from True and snoc have "r i k = T" by simp
          thus "list_all (\<lambda>x. x < i) [] \<and> is_path' r i [] k" by simp
        qed
      next
        case False
        have "PROP ?ih as" by (rule snoc)
        then obtain ys where ys: "list_all (\<lambda>x. x < i) ys \<and> is_path' r i ys a"
        proof
          from snoc show "list_all (\<lambda>x. x < Suc i) as" by simp
          from snoc show "is_path' r j as a" by simp
          from snoc and False show "\<not> list_all (\<lambda>x. x < i) as" by simp
        qed
        show ?thesis
        proof
          from snoc False ys
          show "list_all (\<lambda>x. x < i) (ys @ [a]) \<and> is_path' r i (ys @ [a]) k"
            by simp
        qed
      qed
    qed
  qed (rule asms)+
qed

theorem lemma5':
  "\<And>p. is_path r p (Suc i) j k \<Longrightarrow> \<not> is_path r p i j k \<Longrightarrow>
   \<not> (\<forall>q. \<not> is_path r q i j i) \<and> \<not> (\<forall>q'. \<not> is_path r q' i i k)"
  by (iprover dest: lemma5)

theorem warshall:
  "\<And>j k. \<not> (\<exists>p. is_path r p i j k) \<or> (\<exists>p. is_path r p i j k)"
proof (induct i)
  case (0 j k)
  show ?case
  proof (cases "r j k")
    assume "r j k = T"
    hence "is_path r (j, [], k) 0 j k"
      by (simp add: is_path_def)
    hence "\<exists>p. is_path r p 0 j k" ..
    thus ?thesis ..
  next
    assume "r j k = F"
    hence "r j k ~= T" by simp
    hence "\<not> (\<exists>p. is_path r p 0 j k)"
      by (iprover dest: lemma2)
    thus ?thesis ..
  qed
next
  case (Suc i j k)
  thus ?case
  proof
    assume h1: "\<not> (\<exists>p. is_path r p i j k)"
    from Suc show ?case
    proof
      assume "\<not> (\<exists>p. is_path r p i j i)"
      with h1 have "\<not> (\<exists>p. is_path r p (Suc i) j k)"
        by (iprover dest: lemma5')
      thus ?case ..
    next
      assume "\<exists>p. is_path r p i j i"
      then obtain p where h2: "is_path r p i j i" ..
      from Suc show ?case
      proof
        assume "\<not> (\<exists>p. is_path r p i i k)"
        with h1 have "\<not> (\<exists>p. is_path r p (Suc i) j k)"
          by (iprover dest: lemma5')
        thus ?case ..
      next
        assume "\<exists>q. is_path r q i i k"
        then obtain q where "is_path r q i i k" ..
        with h2 have "is_path r (conc p q) (Suc i) j k"
          by (rule lemma3)
        hence "\<exists>pq. is_path r pq (Suc i) j k" ..
        thus ?case ..
      qed
    qed
  next
    assume "\<exists>p. is_path r p i j k"
    hence "\<exists>p. is_path r p (Suc i) j k"
      by (iprover intro: lemma1)
    thus ?case ..
  qed
qed

extract warshall

text {*
  The program extracted from the above proof looks as follows
  @{thm [display, eta_contract=false] warshall_def [no_vars]}
  The corresponding correctness theorem is
  @{thm [display] warshall_correctness [no_vars]}
*}

ML_val "@{code warshall}"

end


(*  Title:      Secondary Sylow Theorems
    Author:     Jakob von Raumer, Karlsruhe Institute of Technology
    Maintainer: Jakob von Raumer <jakob.raumer at student.kit.edu>
*)

theory SndSylow
imports SubgroupConjugation
begin

no_notation Multiset.subset_mset  (infix "<#" 50) (*prevent a clash with the same syntax for l_coset*)

section \<open>The Secondary Sylow Theorems\<close>

subsection \<open>Preliminaries\<close>

lemma singletonI:
  assumes "\<And>x. x \<in> A \<Longrightarrow> x = y"
  assumes "y \<in> A"
  shows "A = {y}"
using assms by fastforce

context group
begin

lemma set_mult_inclusion:
  assumes H:"subgroup H G"
  assumes Q:"P \<subseteq> carrier G"
  assumes PQ:"H <#> P \<subseteq> H"
  shows "P \<subseteq> H"
proof
  fix x
  from H have "\<one> \<in> H" by (rule subgroup.one_closed)
  moreover assume x:"x \<in> P"
  ultimately have "\<one> \<otimes> x \<in> H <#> P" unfolding set_mult_def by auto
  with PQ have "\<one> \<otimes> x \<in> H" by auto
  with H Q x show  "x \<in> H" by (metis in_mono l_one)
qed

lemma card_subgrp_dvd:
  assumes "subgroup H G"
  shows "card H dvd order G"
proof(cases "finite (carrier G)")
  case True
  with assms have "card (rcosets H) * card H = order G" by (metis lagrange)
  thus ?thesis by (metis dvd_triv_left mult.commute)
next
  case False
  hence "order G = 0" unfolding order_def by (metis card_infinite)
  thus ?thesis by (metis dvd_0_right)
qed

lemma subgroup_finite:
  assumes subgroup:"subgroup H G"
  assumes finite:"finite (carrier G)"
  shows "finite H"
by (metis finite finite_subset subgroup subgroup.subset)

end

subsection \<open>Extending the Sylow Locale\<close>

text \<open>This locale extends the originale @{term sylow} locale by adding
the constraint that the @{term p} must not divide the remainder @{term m},
i.e. @{term "p ^ a"} is the maximal size of a @{term p}-subgroup of
@{term G}.\<close>

locale snd_sylow = sylow +
  assumes pNotDvdm:"\<not> (p dvd m)"

context snd_sylow
begin

lemma pa_not_zero: "p ^ a \<noteq> 0"
  by (simp add: prime_gt_0_nat prime_p)

lemma sylow_greater_zero:
  shows "card (subgroups_of_size (p ^ a)) > 0"
proof -
  obtain P where PG:"subgroup P G" and cardP:"card P = p ^ a" by (metis sylow_thm)
  hence "P \<in> subgroups_of_size (p ^ a)" unfolding subgroups_of_size_def by auto
  hence "subgroups_of_size (p ^ a) \<noteq> {}" by auto
  moreover from finite_G have "finite (subgroups_of_size (p ^ a))" unfolding subgroups_of_size_def subgroup_def by auto
  ultimately show ?thesis by auto
qed

lemma is_snd_sylow: "snd_sylow G p a m" by (rule snd_sylow_axioms)

subsection \<open>Every $p$-group is Contained in a conjugate of a $p$-Sylow-Group\<close>

lemma ex_conj_sylow_group:
  assumes H:"H \<in> subgroups_of_size (p ^ b)"
  assumes Psize:"P \<in> subgroups_of_size (p ^ a)"
  obtains g where "g \<in> carrier G" "H \<subseteq> g <# (P #> inv g)"
proof -
  from H have HsubG:"subgroup H G" unfolding subgroups_of_size_def by auto
  hence HG:"H \<subseteq> carrier G" unfolding subgroups_of_size_def by (simp add:subgroup.subset)
  from Psize have PG:"subgroup P G" and cardP:"card P = p ^ a" unfolding subgroups_of_size_def by auto
  define H' where "H' = G\<lparr>carrier := H\<rparr>"
  from HsubG interpret Hgroup: group H' unfolding H'_def by (metis subgroup_imp_group)
  from H have orderH':"order H' =  p ^ b" unfolding H'_def subgroups_of_size_def order_def by simp
  define \<phi> where "\<phi> = (\<lambda>g. \<lambda>U\<in>rcosets P. U #> inv g)"
  with PG interpret Gact: group_action G \<phi> "rcosets P" unfolding \<phi>_def by (metis inv_mult_on_rcosets_action)
  from H interpret H'act: group_action H' \<phi> "rcosets P" unfolding H'_def subgroups_of_size_def by (metis (mono_tags) Gact.subgroup_action mem_Collect_eq)
  from finite_G PG have "finite (rcosets P)" unfolding RCOSETS_def r_coset_def by (metis (lifting) finite.emptyI finite_UN_I finite_insert)
  with orderH' sylow_axioms cardP have "card H'act.fixed_points mod p = card (rcosets P) mod p" unfolding sylow_def sylow_axioms_def by (metis H'act.fixed_point_congruence)
  moreover from finite_G PG order_G cardP  have "card (rcosets P) * p ^ a  = p ^ a * m" by (metis lagrange)
  with prime_p have "card (rcosets P) = m" by (metis less_nat_zero_code mult_cancel2 mult_is_0 mult.commute order_G zero_less_o_G)
  hence "card (rcosets P) mod p = m mod p" by simp
  moreover from pNotDvdm prime_p have "... \<noteq> 0" by (metis dvd_eq_mod_eq_0)
  ultimately have "card H'act.fixed_points \<noteq> 0" by (metis mod_0)
  then obtain N where N:"N \<in> H'act.fixed_points" by fastforce
  hence Ncoset:"N \<in> rcosets P" unfolding H'act.fixed_points_def by simp
  then obtain g where g:"g \<in> carrier G" "N = P #> g" unfolding RCOSETS_def by auto
  hence invg:"inv g \<in> carrier G" by (metis inv_closed)
  hence invinvg:"inv (inv g) \<in> carrier G" by (metis inv_closed)
  from N have "carrier H' \<subseteq> H'act.stabilizer N" unfolding H'act.fixed_points_def by simp
  hence "\<forall>h\<in>H. \<phi> h N = N" unfolding H'act.stabilizer_def using H'_def by auto
  with HG Ncoset have a1:"\<forall>h\<in>H. N #> inv h \<subseteq> N" unfolding \<phi>_def by simp
  have "N <#> H \<subseteq> N" unfolding set_mult_def r_coset_def
  proof(auto)
    fix n h
    assume n:"n \<in> N" and h:"h \<in> H"
    with H have "inv h \<in> H" by (metis (mono_tags) mem_Collect_eq subgroup.m_inv_closed subgroups_of_size_def)
    with n HG PG a1 have "n \<otimes> inv (inv h) \<in> N" unfolding r_coset_def by auto
    with HG h show  "n \<otimes> h \<in> N" by (metis in_mono inv_inv)
  qed
  with g have "((P #> g) <#> H) #> inv g \<subseteq> (P #> g) #> inv g" unfolding r_coset_def by auto
  with PG g invg have "((P #> g) <#> H) #> inv g \<subseteq> P" by (metis coset_mult_assoc coset_mult_one r_inv subgroup.subset)
  with g HG PG invg have "P <#> (g <# H #> inv g) \<subseteq> P" by (metis lr_coset_assoc r_coset_subset_G rcos_assoc_lcos setmult_rcos_assoc subgroup.subset)
  with PG HG g invg have "g <# H #> inv g \<subseteq> P" by (metis l_coset_subset_G r_coset_subset_G set_mult_inclusion)
  with g have "(g <# H #> inv g) #> inv (inv g) \<subseteq> P #> inv (inv g)" unfolding r_coset_def by auto
  with HG g invg invinvg have "g <# H \<subseteq> P #> inv (inv g)" by (metis coset_mult_assoc coset_mult_inv2 l_coset_subset_G)
  with g have "(inv g) <# (g <# H) \<subseteq> inv g <# (P #> inv (inv g))" unfolding l_coset_def by auto
  with HG g invg invinvg have "H \<subseteq> inv g <# (P #> inv (inv g))" by (metis inv_inv lcos_m_assoc lcos_mult_one r_inv)
  with invg show thesis by (auto dest:that)
qed

subsection\<open>Every $p$-Group is Contained in a $p$-Sylow-Group\<close>

theorem sylow_contained_in_sylow_group:
  assumes H:"H \<in> subgroups_of_size (p ^ b)"
  obtains S where "H \<subseteq> S" and "S \<in> subgroups_of_size (p ^ a)"
proof -
  from H have HG:"H \<subseteq> carrier G" unfolding subgroups_of_size_def by (simp add:subgroup.subset)
  obtain P where PG:"subgroup P G" and cardP:"card P = p ^ a" by (metis sylow_thm)
  hence Psize:"P \<in> subgroups_of_size (p ^ a)" unfolding subgroups_of_size_def by simp
  with H obtain g where g:"g \<in> carrier G" "H \<subseteq> g <# (P #> inv g)" by (metis ex_conj_sylow_group)
  moreover note Psize g
  moreover with finite_G have "conjugation_action (p ^ a) g P \<in> subgroups_of_size (p ^ a)" by (metis conjugation_is_size_invariant)
  ultimately show thesis unfolding conjugation_action_def by (auto dest:that)
qed

subsection\<open>$p$-Sylow-Groups are conjugates of each other\<close>

theorem sylow_conjugate:
  assumes P:"P \<in> subgroups_of_size (p ^ a)"
  assumes Q:"Q \<in> subgroups_of_size (p ^ a)"
  obtains g where "g \<in> carrier G" "Q = g <# (P #> inv g)"
proof -
  from P have "card P = p ^ a" unfolding subgroups_of_size_def by simp
  from Q have Qcard:"card Q = p ^ a" unfolding subgroups_of_size_def by simp
  from Q P obtain g where g:"g \<in> carrier G" "Q \<subseteq> g <# (P #> inv g)" by (rule ex_conj_sylow_group)
  moreover with P finite_G have "conjugation_action (p ^ a) g P \<in> subgroups_of_size (p ^ a)" by (metis conjugation_is_size_invariant)
  moreover from g P have "conjugation_action (p ^ a) g P = g <# (P #> inv g)" unfolding conjugation_action_def by simp
  ultimately have conjSize:"g <# (P #> inv g) \<in> subgroups_of_size (p ^ a)" unfolding conjugation_action_def by simp
  with Qcard have  card:"card (g <# (P #> inv g)) = card Q"  unfolding subgroups_of_size_def by simp
  from conjSize finite_G have "finite (g <# (P #> inv g))" by (metis (mono_tags) finite_subset mem_Collect_eq subgroup.subset subgroups_of_size_def)
  with g card have "Q = g <# (P #> inv g)" by (metis card_subset_eq)
  with g show thesis by (metis that)
qed

corollary sylow_conj_orbit_rel:
  assumes P:"P \<in> subgroups_of_size (p ^ a)"
  assumes Q:"Q \<in> subgroups_of_size (p ^ a)"
  shows "(P,Q) \<in> group_action.same_orbit_rel G (conjugation_action (p ^ a)) (subgroups_of_size (p ^ a))"
unfolding group_action.same_orbit_rel_def
proof -
  from Q P obtain g where g:"g \<in> carrier G" "P = g <# (Q #> inv g)" by (rule sylow_conjugate)
  with Q P have g':"conjugation_action (p ^ a) g Q = P" unfolding conjugation_action_def by simp
  from finite_G interpret conj: group_action G "(conjugation_action (p ^ a))" "(subgroups_of_size (p ^ a))" by (rule acts_on_subsets)
  have "conj.same_orbit_rel = {X \<in> (subgroups_of_size (p ^ a) \<times> subgroups_of_size (p ^ a)). \<exists>g \<in> carrier G. ((conjugation_action (p ^ a)) g) (snd X) = (fst X)}" by (rule conj.same_orbit_rel_def)
  with g g' P Q show ?thesis by auto
qed

subsection\<open>Counting Sylow-Groups\<close>

text \<open>The number of sylow groups is the orbit size of one of them:\<close>

theorem num_eq_card_orbit:
  assumes P:"P \<in> subgroups_of_size (p ^ a)"
  shows "subgroups_of_size (p ^ a) = group_action.orbit G (conjugation_action (p ^ a)) (subgroups_of_size (p ^ a)) P"
proof(auto)
  from finite_G interpret conj: group_action G "(conjugation_action (p ^ a))" "(subgroups_of_size (p ^ a))" by (rule acts_on_subsets)
  have "group_action.orbit G (conjugation_action (p ^ a)) (subgroups_of_size (p ^ a)) P = group_action.same_orbit_rel G (conjugation_action (p ^ a)) (subgroups_of_size (p ^ a)) `` {P}" by (rule conj.orbit_def)
  fix Q
  {
    assume Q:"Q \<in> subgroups_of_size (p ^ a)"
    from P Q obtain g where g:"g \<in> carrier G" "Q = g <# (P #> inv g) " by (rule sylow_conjugate)
    with P conj.orbit_char show "Q \<in> group_action.orbit G (conjugation_action (p ^ a)) (subgroups_of_size (p ^ a)) P"
      unfolding conjugation_action_def by auto
  } {
    assume "Q \<in> group_action.orbit G (conjugation_action (p ^ a)) (subgroups_of_size (p ^ a)) P"
    with P conj.orbit_char obtain g where g:"g \<in> carrier G" "Q = conjugation_action (p ^ a) g P" by auto
    with finite_G P show "Q \<in> subgroups_of_size (p ^ a)"  by (metis conjugation_is_size_invariant)
  }
qed

theorem num_sylow_normalizer:
  assumes Psize:"P \<in> subgroups_of_size (p ^ a)"
  shows "card (rcosets\<^bsub>G\<lparr>carrier := group_action.stabilizer G (conjugation_action (p ^ a)) P\<rparr>\<^esub> P) * p ^ a = card (group_action.stabilizer G (conjugation_action (p ^ a)) P)"
proof -
  from finite_G interpret conj: group_action G "(conjugation_action (p ^ a))" "(subgroups_of_size (p ^ a))" by (rule acts_on_subsets)
  from Psize have PG:"subgroup P G" and cardP:"card P = p ^ a" unfolding subgroups_of_size_def by auto
  with finite_G have "order G = card (conj.orbit P) * card (conj.stabilizer P)" by (metis Psize acts_on_subsets group_action.orbit_size)
  with order_G Psize have "p ^ a * m = card (subgroups_of_size (p ^ a)) * card (conj.stabilizer P)" by (metis num_eq_card_orbit)
  moreover from Psize interpret stabGroup: group "G\<lparr>carrier := conj.stabilizer P\<rparr>" by (metis conj.stabilizer_is_subgroup subgroup_imp_group)
  from finite_G Psize have PStab:"subgroup P (G\<lparr>carrier := conj.stabilizer P\<rparr>)" by (rule stabilizer_supergrp_P)
  from finite_G Psize have "finite (conj.stabilizer P)" by (metis card_infinite conj.stabilizer_is_subgroup less_nat_zero_code subgroup.finite_imp_card_positive)
  with finite_G PStab stabGroup.lagrange have "card (rcosets\<^bsub>G\<lparr>carrier := conj.stabilizer P\<rparr>\<^esub> P) * card P = order (G\<lparr>carrier := conj.stabilizer P\<rparr>)" by force
  with cardP show ?thesis unfolding order_def by auto
qed

theorem (in snd_sylow) num_sylow_dvd_remainder:
  shows "card (subgroups_of_size (p ^ a)) dvd m"
proof -
  from finite_G interpret conj: group_action G "(conjugation_action (p ^ a))" "(subgroups_of_size (p ^ a))" by (rule acts_on_subsets)
  obtain P where PG:"subgroup P G" and cardP:"card P = p ^ a" by (metis sylow_thm)
  hence Psize:"P \<in> subgroups_of_size (p ^ a)" unfolding subgroups_of_size_def by simp
  with finite_G have "order G = card (conj.orbit P) * card (conj.stabilizer P)" by (metis Psize acts_on_subsets group_action.orbit_size)
  with order_G Psize have orderEq:"p ^ a * m = card (subgroups_of_size (p ^ a)) * card (conj.stabilizer P)" by (metis num_eq_card_orbit)
  define k where "k = card (rcosets\<^bsub>G\<lparr>carrier := conj.stabilizer P\<rparr>\<^esub> P)"
  with Psize have "k * p ^ a = card (conj.stabilizer P)" by (metis num_sylow_normalizer)
  with orderEq have "p ^ a * m = card (subgroups_of_size (p ^ a)) * p ^ a * k" by (auto simp:mult.assoc mult.commute)
  hence "p ^ a * m = p ^ a * card (subgroups_of_size (p ^ a)) * k" by auto
  then have "m = card (subgroups_of_size (p ^ a)) * k"
    using pa_not_zero by auto
  then show ?thesis ..
qed

text \<open>We can restrict this locale to refer to a subgroup of order at
least @{term "(p ^ a)"}:\<close>

lemma (in snd_sylow) restrict_locale:
  assumes subgrp:"subgroup P G"
  assumes card:"p ^ a dvd card P"
  shows "snd_sylow (G\<lparr>carrier := P\<rparr>) p a ((card P) div (p ^ a))"
proof -
  from subgrp interpret groupP: group "G\<lparr>carrier := P\<rparr>" by (metis subgroup_imp_group)
  define k where "k = (card P) div (p ^ a)"
  with card have cardP:"card P = p ^ a * k" by auto
  hence orderP:"order (G\<lparr>carrier := P\<rparr>) = p ^ a * k" unfolding order_def by simp
  from cardP subgrp order_G have "p ^ a * k dvd p ^ a * m" by (metis card_subgrp_dvd)
  hence "k dvd m"
    by (metis nat_mult_dvd_cancel_disj pa_not_zero)
  with pNotDvdm have ndvd:"\<not> p dvd k"
    by (blast intro: dvd_trans)
  define PcalM where "PcalM = {s. s \<subseteq> carrier (G\<lparr>carrier := P\<rparr>) \<and> card s = p ^ a}"
  define PRelM where "PRelM = {(N1, N2). N1 \<in> PcalM \<and> N2 \<in> PcalM \<and> (\<exists>g\<in>carrier (G\<lparr>carrier := P\<rparr>). N1 = N2 #>\<^bsub>G\<lparr>carrier := P\<rparr>\<^esub> g)}"
  from subgrp finite_G have finite_groupP:"finite (carrier (G\<lparr>carrier := P\<rparr>))" by (auto simp:subgroup_finite)
  interpret Nsylow: snd_sylow "G\<lparr>carrier := P\<rparr>" p a k PcalM PRelM
     unfolding snd_sylow_def snd_sylow_axioms_def sylow_def sylow_axioms_def k_def
     using groupP.is_group prime_p orderP finite_groupP ndvd PcalM_def PRelM_def k_def by fastforce+
  show ?thesis using k_def by (metis Nsylow.is_snd_sylow)
qed

theorem (in snd_sylow) p_sylow_mod_p:
  shows "card (subgroups_of_size (p ^ a)) mod p = 1"
proof -
  obtain P where PG:"subgroup P G" and cardP:"card P = p ^ a" by (metis sylow_thm)
  hence orderP:"order (G\<lparr>carrier := P\<rparr>) = p ^ a" unfolding order_def by auto
  from PG have PsubG:"P \<subseteq> carrier G" by (metis subgroup.subset)
  from PG cardP have PSize:"P \<in> subgroups_of_size (p ^ a)" unfolding subgroups_of_size_def by auto
  from PG interpret groupP:group "(G\<lparr>carrier := P\<rparr>)" by (rule subgroup_imp_group)
  from cardP have PSize2:"P \<in> groupP.subgroups_of_size (p ^ a)" using groupP.subgroups_of_size_def groupP.subgroup_self by auto
  from finite_G interpret conjG: group_action G "conjugation_action (p ^ a)" "subgroups_of_size (p ^ a)" by (rule acts_on_subsets)
  from PG interpret conjP: group_action "G\<lparr>carrier := P\<rparr>" "conjugation_action (p ^ a)" "subgroups_of_size (p ^ a)" by (rule conjG.subgroup_action)
  from finite_G have "finite (subgroups_of_size (p ^ a))" unfolding subgroups_of_size_def subgroup_def by auto
  with orderP prime_p have "card (subgroups_of_size (p ^ a)) mod p = card conjP.fixed_points mod p" by (rule conjP.fixed_point_congruence)
  also have "... = 1"
  proof -
    have "\<And>Q. Q \<in> conjP.fixed_points \<Longrightarrow> Q = P"
    proof -
      fix Q
      assume Qfixed:"Q \<in> conjP.fixed_points"
      hence Qsize:"Q \<in> subgroups_of_size (p ^ a)" unfolding conjP.fixed_points_def by simp
      hence cardQ:"card Q = p ^ a" unfolding subgroups_of_size_def by simp
      \<comment> \<open>The normalizer of @{term Q} in @{term G}\<close>
      \<comment> \<open>Let's first show some basic propertiers of @{text N}\<close>
      define N where "N = conjG.stabilizer Q"
      define k where "k = (card N) div (p ^ a)"
      from N_def Qsize have NG:"subgroup N G" by (metis conjG.stabilizer_is_subgroup)
      then interpret groupN: group "G\<lparr>carrier := N\<rparr>" by (metis subgroup_imp_group)
      from Qsize N_def have QN:"subgroup Q (G\<lparr>carrier := N\<rparr>)" using stabilizer_supergrp_P by auto
      \<comment> \<open>The following proposition is used to show that $P = Q$ later\<close>
      from Qsize have NfixesQ:"\<forall>g\<in>N. conjugation_action (p ^ a) g Q = Q" unfolding N_def conjG.stabilizer_def by auto
      from Qfixed have PfixesQ:"\<forall>g\<in>P. conjugation_action (p ^ a) g Q = Q" unfolding conjP.fixed_points_def conjP.stabilizer_def by auto
      with PsubG have  "P \<subseteq> N" unfolding N_def conjG.stabilizer_def by auto
      with PG N_def Qsize have PN:"subgroup P (G\<lparr>carrier := N\<rparr>)" by (metis conjG.stabilizer_is_subgroup is_group subgroup.subgroup_of_subset)
      with cardP have "p ^ a dvd order (G\<lparr>carrier := N\<rparr>)" using groupN.card_subgrp_dvd by force
      hence "p ^ a dvd card N" unfolding order_def by simp
      with NG have smaller_sylow:"snd_sylow (G\<lparr>carrier := N\<rparr>) p a k" unfolding k_def by (rule restrict_locale)
      \<comment> \<open>Instantiate the @{term snd_sylow} Locale a second time for the normalizer of @{term Q}\<close>
      define NcalM where "NcalM = {s. s \<subseteq> carrier (G\<lparr>carrier := N\<rparr>) \<and> card s = p ^ a}"
      define NRelM where "NRelM = {(N1, N2). N1 \<in> NcalM \<and> N2 \<in> NcalM \<and> (\<exists>g\<in>carrier (G\<lparr>carrier := N\<rparr>). N1 = N2 #>\<^bsub>G\<lparr>carrier := N\<rparr>\<^esub> g)}"
      interpret Nsylow: snd_sylow "G\<lparr>carrier := N\<rparr>" p a k NcalM NRelM
        unfolding NcalM_def NRelM_def using smaller_sylow .
      \<comment> \<open>@{term P} and @{term Q} are conjugate in @{term N}:\<close>
      from cardP PN have PsizeN:"P \<in> groupN.subgroups_of_size (p ^ a)" unfolding groupN.subgroups_of_size_def by auto
      from cardQ QN have QsizeN:"Q \<in> groupN.subgroups_of_size (p ^ a)" unfolding groupN.subgroups_of_size_def by auto
      from QsizeN PsizeN obtain g where g:"g \<in> carrier (G\<lparr>carrier := N\<rparr>)" "P = g <#\<^bsub>G\<lparr>carrier := N\<rparr>\<^esub> (Q #>\<^bsub>G\<lparr>carrier := N\<rparr>\<^esub> inv\<^bsub>G\<lparr>carrier := N\<rparr>\<^esub> g)" by (rule Nsylow.sylow_conjugate)
      with NG have "P = g <# (Q #> inv g)" unfolding r_coset_def l_coset_def by (auto simp:m_inv_consistent)
      with NG g Qsize have "conjugation_action (p ^ a) g Q = P" unfolding conjugation_action_def using subgroup.subset by force
      with g NfixesQ show "Q = P" by auto
    qed
    moreover from finite_G PSize have "P \<in> conjP.fixed_points" using P_fixed_point_of_P_conj by auto
    ultimately have "conjP.fixed_points = {P}" by fastforce
    hence one:"card conjP.fixed_points = 1" by (auto simp: card_Suc_eq)
    with prime_p have "card conjP.fixed_points < p" unfolding prime_nat_iff by auto
    with one show ?thesis using mod_pos_pos_trivial by auto
  qed
  finally show ?thesis.
qed

end

end


section \<open>The Ping Pong lemma\<close>

theory "PingPongLemma"
imports
   "HOL-Algebra.Bij"
   FreeGroups
begin

text \<open>
The Ping Pong Lemma is a way to recognice a Free Group by its action on
a set (often a topological space or a graph). The name stems from the way that
elements of the set are passed forth and back between the subsets given there.
\<close>

text \<open>
We start with two auxiliary lemmas, one about the identity of the group of
bijections, and one about sets of cardinality larger than one.
\<close>

lemma Bij_one[simp]:
  assumes "x \<in> X"
  shows "\<one>\<^bsub>BijGroup X\<^esub> x = x"
using assms by (auto simp add: BijGroup_def)

lemma other_member:
   assumes "I \<noteq> {}" and "i \<in> I" and "card I \<noteq> 1"
   obtains j where "j\<in>I" and "j\<noteq>i"
proof(cases "finite I")
  case True
  hence "I - {i} \<noteq> {}" using \<open>card I \<noteq> 1\<close> and \<open>i\<in>I\<close> by (metis Suc_eq_plus1_left card_Diff_subset_Int card_Suc_Diff1 diff_add_inverse2 diff_self_eq_0 empty_Diff finite.emptyI inf_bot_left minus_nat.diff_0)
  thus ?thesis using that by auto
next
  case False
  hence "I - {i} \<noteq> {}" by (metis Diff_empty finite.emptyI finite_Diff_insert)
  thus ?thesis using that by auto
qed

text \<open>
And now we can attempt the lemma. The gencount condition is a weaker variant
of ``x has to lie outside all subsets'' that is only required if the set of
generators is one. Otherwise, we will be able to find a suitable x to start
with in the proof.
\<close>

lemma ping_pong_lemma:
  assumes "group G"
  and "act \<in> hom G (BijGroup X)"
  and "g \<in> (I \<rightarrow> carrier G)"
  and "\<langle>g ` I\<rangle>\<^bsub>G\<^esub> = carrier G"
  and sub1: "\<forall>i\<in>I. Xout i \<subseteq> X"
  and sub2: "\<forall>i\<in>I. Xin i \<subseteq> X"
  and disj1: "\<forall>i\<in>I. \<forall>j\<in>I. i \<noteq> j \<longrightarrow> Xout i \<inter> Xout j = {}"
  and disj2: "\<forall>i\<in>I. \<forall>j\<in>I. i \<noteq> j \<longrightarrow> Xin i \<inter> Xin j = {}"
  and disj3: "\<forall>i\<in>I. \<forall>j\<in>I. Xin i \<inter> Xout j = {}"
  and "x \<in> X"
  and gencount: "\<forall> i . I = {i} \<longrightarrow> (x \<notin> Xout i \<and> x \<notin> Xin i)"
  and ping: "\<forall>i\<in>I. act (g i) ` (X - Xout i) \<subseteq> Xin i"
  and pong: "\<forall>i\<in>I. act (inv\<^bsub>G\<^esub> (g i)) ` (X - Xin i) \<subseteq> Xout i"
  shows "group.lift G g \<in> iso (\<F>\<^bsub>I\<^esub>) G"
proof-
  interpret F: group "\<F>\<^bsub>I\<^esub>"
    using assms by (auto simp add: free_group_is_group)
  interpret G: group G by fact
  interpret B: group "BijGroup X" using group_BijGroup by auto
  interpret act: group_hom G "BijGroup X" act by (unfold_locales) fact
  interpret h: group_hom "\<F>\<^bsub>I\<^esub>" G "G.lift g"
    using F.is_group G.is_group G.lift_is_hom assms
    by (auto intro!: group_hom.intro group_hom_axioms.intro)

  show ?thesis
  proof(rule h.group_hom_isoI)
    txt \<open>Injectivity is the hard part of the proof.\<close>
    show "\<forall>x\<in>carrier \<F>\<^bsub>I\<^esub>. G.lift g x = \<one>\<^bsub>G\<^esub> \<longrightarrow> x = \<one>\<^bsub>\<F>\<^bsub>I\<^esub>\<^esub>"
       proof(rule+)

         txt \<open>We lift the Xout and Xin sets to generators and their inveres, and
         create variants of the disj-conditions:\<close>
         define Xout' where "Xout' = (\<lambda>(b,i::'d). if b then Xin i else Xout i)"
         define Xin' where "Xin' = (\<lambda>(b,i::'d). if b then Xout i else Xin i)"

         have disj1': "\<forall>i\<in>(UNIV \<times> I). \<forall>j\<in>(UNIV \<times> I). i \<noteq> j \<longrightarrow> Xout' i \<inter> Xout' j = {}"
           using disj1[rule_format] disj2[rule_format] disj3[rule_format]
           by (auto simp add:Xout'_def Xin'_def split:if_splits, blast+)
         have disj2': "\<forall>i\<in>(UNIV \<times> I). \<forall>j\<in>(UNIV \<times> I). i \<noteq> j \<longrightarrow> Xin' i \<inter> Xin' j = {}"
           using disj1[rule_format] disj2[rule_format] disj3[rule_format]
           by (auto simp add:Xout'_def Xin'_def split:if_splits, blast+)
         have disj3': "\<forall>i\<in>(UNIV \<times> I). \<forall>j\<in>(UNIV \<times> I). \<not> canceling i j \<longrightarrow> Xin' i \<inter> Xout' j = {}"
           using disj1[rule_format] disj2[rule_format] disj3[rule_format]
           by (auto simp add:canceling_def Xout'_def Xin'_def split:if_splits, blast)

         txt \<open>We need to pick a suitable element of the set to play ping pong
         with. In particular, it needs to be outside of the Xout-set of the last
         generator in the list, and outside the in-set of the first element. This
         part of the proof is surprisingly tedious, because there are several
         cases, some similar but not the same.
\<close>

         fix w
         assume w: "w \<in> carrier \<F>\<^bsub>I\<^esub>"

         obtain x where "x \<in> X"
           and x1: "w = [] \<or> x \<notin> Xout' (last w)"
           and x2: "w = [] \<or> x \<notin> Xin' (hd w)"
         proof-
           { assume "I = {}"
             hence "w = []" using w by (auto simp add:free_group_def)
             hence ?thesis using that \<open>x\<in>X\<close> by auto
           }
           moreover
           { assume "card I = 1"
             then obtain i where "I={i}" by (auto dest: card_eq_SucD)
             assume "w\<noteq>[]"
             hence "snd (hd w) = i" and "snd (last w) = i"
               using w \<open>I={i}\<close>
               apply (cases w, auto simp add:free_group_def)
               apply (cases w rule:rev_exhaust, auto simp add:free_group_def)
               done
             hence ?thesis using gencount[rule_format, OF \<open>I={i}\<close>] that[OF \<open>x\<in>X\<close>] \<open>w\<noteq>[]\<close>
             by (cases "last w", cases "hd w", auto simp add:Xout'_def Xin'_def split:if_splits)
           }
           moreover
           { assume "I \<noteq> {}" and "card I \<noteq> 1" and "w \<noteq> []"

             from \<open>w \<noteq> []\<close> and w
             obtain b i where hd: "hd w = (b,i)" and "i\<in>I"
               by (cases w, auto simp add:free_group_def)
             from \<open>w \<noteq> []\<close> and w
             obtain b' i' where last: "last w = (b',i')" and "i'\<in>I"
               by (cases w rule: rev_exhaust, auto simp add:free_group_def)

             txt \<open>What follows are two very similar cases, but the correct
             choice of variables depends on where we find x.\<close>
             {
             obtain b'' i'' where
               "(b'',i'') \<noteq> (b,i)" and
               "(b'',i'') \<noteq> (b',i')" and
               "\<not> canceling (b'', i'') (b',i')" and
               "i''\<in>I"
             proof(cases "i=i'")
               case True
               obtain j where "j\<in>I" and "j\<noteq>i" using  \<open>card I \<noteq> 1\<close> and \<open>i\<in>I\<close>
                 by -(rule other_member, auto)
               with True show ?thesis using that by (auto simp add:canceling_def)
             next
               case False thus ?thesis using that \<open>i\<in>I\<close> \<open>i' \<in> I\<close>
               by (simp add:canceling_def, metis)
             qed
             let ?g = "(b'',i'')"

             assume "x \<in> Xout' (last w)"
             hence "x \<notin> Xout' ?g"
               using disj1'[rule_format, OF _ _ \<open>?g \<noteq> (b',i')\<close>]
                   \<open>i \<in> I\<close> \<open>i'\<in>I\<close> \<open>i''\<in>I\<close> hd last
               by auto
             hence "act (G.lift_gi g ?g) x \<in> Xin' ?g" (is "?x \<in> _") using \<open>i'' \<in> I\<close> \<open>x \<in> X\<close>
               ping[rule_format, OF \<open>i'' \<in> I\<close>, THEN subsetD]
               pong[rule_format, OF \<open>i'' \<in> I\<close>, THEN subsetD]
               by (auto simp add:G.lift_def G.lift_gi_def Xout'_def Xin'_def)
             hence "?x \<notin> Xout' (last w) \<and> ?x \<notin> Xin' (hd w)"
               using
                 disj3'[rule_format, OF _ _ \<open>\<not> canceling (b'', i'') (b',i')\<close>]
                 disj2'[rule_format, OF _ _  \<open>?g \<noteq> (b,i)\<close>]
                 \<open>i \<in> I\<close> \<open>i'\<in>I\<close> \<open>i''\<in>I\<close> hd last
               by (auto simp add: canceling_def)
             moreover
             note \<open>i'' \<in> I\<close>
             hence "g i'' \<in> carrier G" using \<open>g \<in> (I \<rightarrow> carrier G)\<close> by auto
             hence "G.lift_gi g ?g \<in> carrier G"
               by (auto simp add:G.lift_gi_def inv1_def)
             hence "act (G.lift_gi g ?g) \<in> carrier (BijGroup X)"
               using \<open>act \<in> hom G (BijGroup X)\<close> by auto
             hence "?x \<in> X" using \<open>x\<in>X\<close>
               by (auto simp add:BijGroup_def Bij_def bij_betw_def)
             ultimately have ?thesis using that[of ?x] by auto
             }
             moreover
             {
             obtain b'' i'' where
               "\<not> canceling (b'',i'') (b,i)" and
               "\<not> canceling (b'',i'') (b',i')" and
               "(b,i) \<noteq> (b'',i'')" and
               "i''\<in>I"
             proof(cases "i=i'")
               case True
               obtain j where "j\<in>I" and "j\<noteq>i" using  \<open>card I \<noteq> 1\<close> and \<open>i\<in>I\<close>
                 by -(rule other_member, auto)
               with True show ?thesis using that by (auto simp add:canceling_def)
             next
               case False thus ?thesis using that \<open>i\<in>I\<close> \<open>i' \<in> I\<close>
               by (simp add:canceling_def, metis)
             qed
             let ?g = "(b'',i'')"
             note cancel_sym_neg[OF \<open>\<not> canceling (b'',i'') (b,i)\<close>]
             note cancel_sym_neg[OF \<open>\<not> canceling (b'',i'') (b',i')\<close>]

             assume "x \<in> Xin' (hd w)"
             hence "x \<notin> Xout' ?g"
               using disj3'[rule_format, OF _ _ \<open>\<not> canceling (b,i) ?g\<close>]
                   \<open>i \<in> I\<close> \<open>i'\<in>I\<close> \<open>i''\<in>I\<close> hd last
               by auto
             hence "act (G.lift_gi g ?g) x \<in> Xin' ?g" (is "?x \<in> _") using \<open>i'' \<in> I\<close> \<open>x \<in> X\<close>
               ping[rule_format, OF \<open>i'' \<in> I\<close>, THEN subsetD]
               pong[rule_format, OF \<open>i'' \<in> I\<close>, THEN subsetD]
               by (auto simp add:G.lift_def G.lift_gi_def Xout'_def Xin'_def)
             hence "?x \<notin> Xout' (last w) \<and> ?x \<notin> Xin' (hd w)"
               using
                 disj3'[rule_format, OF _ _ \<open>\<not> canceling ?g (b',i')\<close>]
                 disj2'[rule_format, OF _ _  \<open>(b,i) \<noteq> ?g\<close>]
                 \<open>i \<in> I\<close> \<open>i'\<in>I\<close> \<open>i''\<in>I\<close> hd last
               by (auto simp add: canceling_def)
             moreover
             note \<open>i'' \<in> I\<close>
             hence "g i'' \<in> carrier G" using \<open>g \<in> (I \<rightarrow> carrier G)\<close> by auto
             hence "G.lift_gi g ?g \<in> carrier G"
               by (auto simp add:G.lift_gi_def)
             hence "act (G.lift_gi g ?g) \<in> carrier (BijGroup X)"
               using \<open>act \<in> hom G (BijGroup X)\<close> by auto
             hence "?x \<in> X" using \<open>x\<in>X\<close>
               by (auto simp add:BijGroup_def Bij_def bij_betw_def)
             ultimately have ?thesis using that[of ?x] by auto
             }
             moreover note calculation
           }
           ultimately show ?thesis using \<open>x\<in> X\<close> that by auto
         qed

         txt \<open>The proof works by induction over the length of the word. Each
         inductive step is one ping as in ping pong. At the end, we land in one
         of the subsets of X, so the word cannot be the identity.\<close>
         from x1 and w
         have "w = [] \<or> act (G.lift g w) x \<in> Xin' (hd w)"
         proof(induct w)
           case Nil show ?case by simp
         next case (Cons w ws)
           note C = Cons

           txt \<open>The following lemmas establish all ``obvious'' element relations that will be required during the proof.\<close>
           note calculation = Cons(3)
           moreover have "x\<in>X" by fact
           moreover have "snd w \<in> I" using calculation by (auto simp add:free_group_def)
           moreover have "g \<in> (I \<rightarrow> carrier G)" by fact
           moreover have "g (snd w) \<in> carrier G" using calculation by auto
           moreover have "ws \<in> carrier \<F>\<^bsub>I\<^esub>"
              using calculation by (auto intro:cons_canceled simp add:free_group_def)
           moreover have "G.lift g ws \<in> carrier G" and "G.lift g [w] \<in> carrier G"
              using calculation by (auto simp add: free_group_def)
           moreover have "act (G.lift g ws) \<in> carrier (BijGroup X)"
                     and "act (G.lift g [w]) \<in> carrier (BijGroup X)"
                     and "act (G.lift g (w#ws)) \<in> carrier (BijGroup X)"
                     and "act (g (snd w)) \<in> carrier (BijGroup X)"
              using calculation by auto
           moreover have "act (g (snd w)) \<in> Bij X"
              using calculation by (auto simp add:BijGroup_def)
           moreover have "act (G.lift g ws) x \<in> X" (is "?x2 \<in> X")
              using calculation by (auto simp add:BijGroup_def Bij_def bij_betw_def)
           moreover have "act (G.lift g [w]) ?x2 \<in> X"
              using calculation by (auto simp add:BijGroup_def Bij_def bij_betw_def)
           moreover have "act (G.lift g (w#ws)) x \<in> X"
              using calculation by (auto simp add:BijGroup_def Bij_def bij_betw_def)
           moreover note mems = calculation

           have "act (G.lift g ws) x \<notin> Xout' w"
           proof(cases ws)
             case Nil
               moreover have "x \<notin> Xout' w" using Cons(2) Nil
                 unfolding Xout'_def using mems
                 by (auto split:if_splits)
               ultimately show "act (G.lift g ws) x \<notin> Xout' w"
                 using mems by auto
           next case (Cons ww wws)
             hence "act (G.lift g ws) x \<in> Xin' (hd ws)"
               using C mems by simp
             moreover have "Xin' (hd ws) \<inter> Xout' w = {}"
             proof-
               have "\<not> canceling (hd ws) w"
               proof
                 assume "canceling (hd ws) w"
                 hence "cancels_to_1 (w#ws) wws" using Cons
                    by(auto simp add:cancel_sym cancels_to_1_def cancels_to_1_at_def cancel_at_def)
                 thus False using \<open>w#ws \<in> carrier \<F>\<^bsub>I\<^esub>\<close>
                    by(auto simp add:free_group_def canceled_def)
               qed

               have "w \<in> UNIV \<times> I" "hd ws \<in> UNIV \<times> I"
                 using \<open>snd w \<in> I\<close> mems Cons
                 by (cases w, auto, cases "hd ws", auto simp add:free_group_def)
               thus ?thesis
                 by- (rule disj3'[rule_format, OF _ _ \<open>\<not> canceling (hd ws) w\<close>], auto)
             qed
             ultimately show "act (G.lift g ws) x \<notin> Xout' w" using Cons by auto
           qed
           show ?case
           proof-
             have "act (G.lift g (w # ws)) x = act (G.lift g ([w] @ ws)) x" by simp
             also have "\<dots> = act (G.lift g [w] \<otimes>\<^bsub>G\<^esub> G.lift g ws) x"
               using mems by (subst G.lift_append, auto simp add:free_group_def)
             also have "\<dots> = (act (G.lift g [w]) \<otimes>\<^bsub>BijGroup X\<^esub> act (G.lift g ws)) x"
               using mems by (auto simp add:act.hom_mult free_group_def intro!:G.lift_closed)
             also have "\<dots> = act (G.lift g [w]) (act (G.lift g ws) x)"
               using mems by (auto simp add:BijGroup_def compose_def)
             also have "\<dots> \<notin> act (G.lift g [w]) ` Xout' w"
               apply(rule ccontr)
               apply simp
               apply (erule imageE)
               apply (subst (asm) inj_on_eq_iff[of "act (G.lift g [w])" "X"])
               using mems \<open>act (G.lift g ws) x \<notin> Xout' w\<close> \<open>\<forall>i\<in>I. Xout i \<subseteq> X\<close> \<open>\<forall>i\<in>I. Xin i \<subseteq> X\<close>
               apply (auto simp add:BijGroup_def Bij_def bij_betw_def free_group_def Xout'_def split:if_splits)
               apply blast+
               done
             finally
             have "act (G.lift g (w # ws)) x \<in> Xin' w"
             proof-
               assume "act (G.lift g (w # ws)) x \<notin> act (G.lift g [w]) ` Xout' w"
               hence "act (G.lift g (w # ws)) x \<in> (X - act (G.lift g [w]) ` Xout' w)"
                 using mems by auto
               also have "\<dots> \<subseteq> act (G.lift g [w]) ` X - act (G.lift g [w]) ` Xout' w"
                     using \<open>act (G.lift g [w]) \<in> carrier (BijGroup X)\<close>
                     by (auto simp add:BijGroup_def Bij_def bij_betw_def)
               also have "\<dots> \<subseteq> act (G.lift g [w]) ` (X - Xout' w)"
                      by (rule image_diff_subset)
               also have "... \<subseteq> Xin' w"
               proof(cases "fst w")
                 assume "\<not> fst w"
                 thus ?thesis
                   using mems
                   by (auto intro!: ping[rule_format, THEN subsetD] simp add: Xout'_def Xin'_def G.lift_def G.lift_gi_def free_group_def)
               next assume "fst w"
                 thus ?thesis
                   using mems
                   by (auto intro!: pong[rule_format, THEN subsetD] simp add: restrict_def inv_BijGroup Xout'_def Xin'_def G.lift_def G.lift_gi_def free_group_def)
               qed
               finally show ?thesis .
             qed
             thus ?thesis by simp
           qed
         qed
           moreover assume "G.lift g w = \<one>\<^bsub>G\<^esub>"
         ultimately show "w = \<one>\<^bsub>\<F>\<^bsub>I\<^esub>\<^esub>"
           using \<open>x\<in>X\<close> Cons(1) x2 \<open>w \<in> carrier \<F>\<^bsub>I\<^esub>\<close>
         by (cases w, auto simp add:free_group_def Xin'_def split:if_splits)
       qed
    next
    txt \<open>Surjectivity is relatively simple, and often not even mentioned in
    human proofs.\<close>
    have "G.lift g ` carrier \<F>\<^bsub>I\<^esub> =
          G.lift g ` \<langle>\<iota> ` I\<rangle>\<^bsub>\<F>\<^bsub>I\<^esub>\<^esub>"
      by (metis gens_span_free_group)
    also have "... = \<langle>G.lift g ` (\<iota> ` I) \<rangle>\<^bsub>G\<^esub>"
       by (auto intro!:h.hom_span simp add: insert_closed)
    also have "\<dots> = \<langle>g ` I \<rangle>\<^bsub>G\<^esub>"
       proof-
         have "\<forall> i \<in> I. G.lift g (\<iota> i) = g i"
           using \<open>g \<in> (I \<rightarrow> carrier G)\<close>
           by (auto simp add:insert_def G.lift_def G.lift_gi_def intro:G.r_one)
         then have "G.lift g ` (\<iota> ` I) = g ` I "
           by (auto intro!: image_cong simp add: image_comp [symmetric, THEN sym])
         thus ?thesis by simp
       qed
     also have "\<dots> = carrier G" using assms by simp
     finally show "G.lift g ` carrier \<F>\<^bsub>I\<^esub> = carrier G".
  qed
qed

end


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

section\<open>Functions, Function Spaces, Lambda-Abstraction\<close>

theory Function imports Equalities Sum begin

subsection\<open>The Pi Operator: Dependent Function Space\<close>

lemma subset_Sigma_imp_relation: "r \<subseteq> Sigma A B ==> relation(r)"
by (simp add: relation_def, blast)

lemma relation_converse_converse [simp]:
     "relation(r) ==> converse(converse(r)) = r"
by (simp add: relation_def, blast)

lemma relation_restrict [simp]:  "relation (restrict r A)"
by (simp add: restrict_def relation_def, blast)

lemma Pi_iff:
    "f \<in> Pi A B \<longleftrightarrow> function f & f<=Sigma A B & A<=domain(f)"
by (unfold Pi_def, blast)

(*For upward compatibility with the former definition*)
lemma Pi_iff_old:
    "f \<in> Pi A B \<longleftrightarrow> f<=Sigma A B & (\<forall>x\<in>A. \<exists>!y. <x,y>: f)"
by (unfold Pi_def function_def, blast)

lemma fun_is_function: "f \<in> Pi A B ==> function(f)"
by (simp only: Pi_iff)

lemma function_imp_Pi:
     "[|function(f); relation(f)|] ==> f \<in> domain(f) -> range(f)"
by (simp add: Pi_iff relation_def, blast)

lemma functionI:
     "[| !!x y y'. [| <x,y>:r; <x,y'>:r |] ==> y=y' |] ==> function(r)"
by (simp add: function_def, blast)

(*Functions are relations*)
lemma fun_is_rel: "f \<in> Pi A B ==> f \<subseteq> Sigma A B"
by (unfold Pi_def, blast)

lemma Pi_cong:
    "[| A=A';  !!x. x \<in> A' ==> B(x)=B'(x) |] ==> Pi A B = Pi A' B'"
by (simp add: Pi_def cong add: Sigma_cong)

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

(*Weakening one function type to another; see also Pi_type*)
lemma fun_weaken_type: "[| f \<in> A->B;  B<=D |] ==> f \<in> A->D"
by (unfold Pi_def, best)

subsection\<open>Function Application\<close>

lemma apply_equality2: "[| <a,b>: f;  <a,c>: f;  f \<in> Pi A B |] ==> b=c"
by (unfold Pi_def function_def, blast)

lemma function_apply_equality: "[| <a,b>: f;  function(f) |] ==> f`a = b"
by (unfold apply_def function_def, blast)

lemma apply_equality: "[| <a,b>: f;  f \<in> Pi A B |] ==> f`a = b"
apply (unfold Pi_def)
apply (blast intro: function_apply_equality)
done

(*Applying a function outside its domain yields 0*)
lemma apply_0: "a \<notin> domain(f) ==> f`a = 0"
by (unfold apply_def, blast)

lemma Pi_memberD: "[| f \<in> Pi A B;  c \<in> f |] ==> \<exists>x\<in>A.  c = <x,f`x>"
apply (frule fun_is_rel)
apply (blast dest: apply_equality)
done

lemma function_apply_Pair: "[| function(f);  a \<in> domain(f)|] ==> <a,f`a>: f"
apply (simp add: function_def, clarify)
apply (subgoal_tac "f`a = y", blast)
apply (simp add: apply_def, blast)
done

lemma apply_Pair: "[| f \<in> Pi A B;  a \<in> A |] ==> <a,f`a>: f"
apply (simp add: Pi_iff)
apply (blast intro: function_apply_Pair)
done

(*Conclusion is flexible -- use rule_tac or else apply_funtype below!*)
lemma apply_type [TC]: "[| f \<in> Pi A B;  a \<in> A |] ==> f`a \<in> B(a)"
by (blast intro: apply_Pair dest: fun_is_rel)

(*This version is acceptable to the simplifier*)
lemma apply_funtype: "[| f \<in> A->B;  a \<in> A |] ==> f`a \<in> B"
by (blast dest: apply_type)

lemma apply_iff: "f \<in> Pi A B ==> <a,b>: f \<longleftrightarrow> a \<in> A & f`a = b"
apply (frule fun_is_rel)
apply (blast intro!: apply_Pair apply_equality)
done

(*Refining one Pi type to another*)
lemma Pi_type: "[| f \<in> Pi A C;  !!x. x \<in> A ==> f`x \<in> B(x) |] ==> f \<in> Pi A B"
apply (simp only: Pi_iff)
apply (blast dest: function_apply_equality)
done

(*Such functions arise in non-standard datatypes, ZF/ex/Ntree for instance*)
lemma Pi_Collect_iff:
     "(f \<in> Pi A (%x. {y \<in> B(x). P x y}))
      \<longleftrightarrow>  f \<in> Pi A B & (\<forall>x\<in>A. P x (f`x))"
by (blast intro: Pi_type dest: apply_type)

lemma Pi_weaken_type:
        "[| f \<in> Pi A B;  !!x. x \<in> A ==> B(x)<=C(x) |] ==> f \<in> Pi A C"
by (blast intro: Pi_type dest: apply_type)

(** Elimination of membership in a function **)

lemma domain_type: "[| <a,b> \<in> f;  f \<in> Pi A B |] ==> a \<in> A"
by (blast dest: fun_is_rel)

lemma range_type: "[| <a,b> \<in> f;  f \<in> Pi A B |] ==> b \<in> B(a)"
by (blast dest: fun_is_rel)

lemma Pair_mem_PiD: "[| <a,b>: f;  f \<in> Pi A B |] ==> a \<in> A & b \<in> B(a) & f`a = b"
by (blast intro: domain_type range_type apply_equality)

subsection\<open>Lambda Abstraction\<close>

lemma lamI: "a \<in> A ==> <a,b(a)> \<in> (\<lambda>x\<in>A. b(x))"
apply (unfold lam_def)
apply (erule RepFunI)
done

lemma lamE:
    "[| p: (\<lambda>x\<in>A. b(x));  !!x.[| x \<in> A; p=<x,b(x)> |] ==> P
     |] ==>  P"
by (simp add: lam_def, blast)

lemma lamD: "[| <a,c>: (\<lambda>x\<in>A. b(x)) |] ==> c = b(a)"
by (simp add: lam_def)

lemma lam_type [TC]:
    "[| !!x. x \<in> A ==> b(x): B(x) |] ==> (\<lambda>x\<in>A. b(x)) \<in> Pi A B"
by (simp add: lam_def Pi_def function_def, blast)

lemma lam_funtype: "(\<lambda>x\<in>A. b(x)) \<in> A -> {b(x). x \<in> A}"
by (blast intro: lam_type)

lemma function_lam: "function (\<lambda>x\<in>A. b(x))"
by (simp add: function_def lam_def)

lemma relation_lam: "relation (\<lambda>x\<in>A. b(x))"
by (simp add: relation_def lam_def)

lemma beta_if [simp]: "(\<lambda>x\<in>A. b(x)) ` a = (if a \<in> A then b(a) else 0)"
by (simp add: apply_def lam_def, blast)

lemma beta: "a \<in> A ==> (\<lambda>x\<in>A. b(x)) ` a = b(a)"
by (simp add: apply_def lam_def, blast)

lemma lam_empty [simp]: "(\<lambda>x\<in>0. b(x)) = 0"
by (simp add: lam_def)

lemma domain_lam [simp]: "domain(Lambda A b) = A"
by (simp add: lam_def, blast)

(*congruence rule for lambda abstraction*)
lemma lam_cong [cong]:
    "[| A=A';  !!x. x \<in> A' ==> b(x)=b'(x) |] ==> Lambda A b = Lambda A' b'"
by (simp only: lam_def cong add: RepFun_cong)

lemma lam_theI:
    "(!!x. x \<in> A ==> \<exists>!y. Q x y) ==> \<exists>f. \<forall>x\<in>A. Q x (f`x)"
apply (rule_tac x = "\<lambda>x\<in>A. THE y. Q x y" in exI)
apply simp
apply (blast intro: theI)
done

lemma lam_eqE: "[| (\<lambda>x\<in>A. f(x)) = (\<lambda>x\<in>A. g(x));  a \<in> A |] ==> f(a)=g(a)"
by (fast intro!: lamI elim: equalityE lamE)

(*Empty function spaces*)
lemma Pi_empty1 [simp]: "Pi 0 A = {0}"
by (unfold Pi_def function_def, blast)

(*The singleton function*)
lemma singleton_fun [simp]: "{<a,b>} \<in> {a} -> {b}"
by (unfold Pi_def function_def, blast)

lemma Pi_empty2 [simp]: "(A->0) = (if A=0 then {0} else 0)"
by (unfold Pi_def function_def, force)

lemma  fun_space_empty_iff [iff]: "(A->X)=0 \<longleftrightarrow> X=0 & (A \<noteq> 0)"
apply auto
apply (fast intro!: equals0I intro: lam_type)
done

subsection\<open>Extensionality\<close>

(*Semi-extensionality!*)

lemma fun_subset:
    "[| f \<in> Pi A B;  g \<in> Pi C D;  A<=C;
        !!x. x \<in> A ==> f`x = g`x       |] ==> f<=g"
by (force dest: Pi_memberD intro: apply_Pair)

lemma fun_extension:
    "[| f \<in> Pi A B;  g \<in> Pi A D;
        !!x. x \<in> A ==> f`x = g`x       |] ==> f=g"
by (blast del: subsetI intro: subset_refl sym fun_subset)

lemma eta [simp]: "f \<in> Pi A B ==> (\<lambda>x\<in>A. f`x) = f"
apply (rule fun_extension)
apply (auto simp add: lam_type apply_type beta)
done

lemma fun_extension_iff:
     "[| f \<in> Pi A B; g \<in> Pi A C |] ==> (\<forall>a\<in>A. f`a = g`a) \<longleftrightarrow> f=g"
by (blast intro: fun_extension)

(*thm by Mark Staples, proof by lcp*)
lemma fun_subset_eq: "[| f \<in> Pi A B; g \<in> Pi A C |] ==> f \<subseteq> g \<longleftrightarrow> (f = g)"
by (blast dest: apply_Pair
          intro: fun_extension apply_equality [symmetric])

(*Every element of Pi(A,B) may be expressed as a lambda abstraction!*)
lemma Pi_lamE:
  assumes major: "f \<in> Pi A B"
      and minor: "!!b. [| \<forall>x\<in>A. b(x):B(x);  f = (\<lambda>x\<in>A. b(x)) |] ==> P"
  shows "P"
apply (rule minor)
apply (rule_tac [2] eta [symmetric])
apply (blast intro: major apply_type)+
done

subsection\<open>Images of Functions\<close>

lemma image_lam: "C \<subseteq> A ==> (\<lambda>x\<in>A. b(x)) `` C = {b(x). x \<in> C}"
by (unfold lam_def, blast)

lemma Repfun_function_if:
     "function(f)
      ==> {f`x. x \<in> C} = (if C \<subseteq> domain(f) then f``C else cons 0 (f``C))"
apply simp
apply (intro conjI impI)
 apply (blast dest: function_apply_equality intro: function_apply_Pair)
apply (rule equalityI)
 apply (blast intro!: function_apply_Pair apply_0)
apply (blast dest: function_apply_equality intro: apply_0 [symmetric])
done

(*For this lemma and the next, the right-hand side could equivalently
  be written \<Union>x\<in>C. {f`x} *)
lemma image_function:
     "[| function(f);  C \<subseteq> domain(f) |] ==> f``C = {f`x. x \<in> C}"
by (simp add: Repfun_function_if)

lemma image_fun: "[| f \<in> Pi A B;  C \<subseteq> A |] ==> f``C = {f`x. x \<in> C}"
apply (simp add: Pi_iff)
apply (blast intro: image_function)
done

lemma image_eq_UN:
  assumes f: "f \<in> Pi A B" "C \<subseteq> A" shows "f``C = (\<Union>x\<in>C. {f ` x})"
by (auto simp add: image_fun [OF f])

lemma Pi_image_cons:
     "[| f \<in> Pi A B;  x \<in> A |] ==> f `` cons x y = cons (f`x) (f``y)"
by (blast dest: apply_equality apply_Pair)

subsection\<open>Properties of @{term "restrict f A"}\<close>

lemma restrict_subset: "restrict f A \<subseteq> f"
by (unfold restrict_def, blast)

lemma function_restrictI:
    "function f ==> function (restrict f A)"
by (unfold restrict_def function_def, blast)

lemma restrict_type2: "[| f \<in> Pi C B;  A<=C |] ==> restrict f A \<in> Pi A B"
by (simp add: Pi_iff function_def restrict_def, blast)

lemma restrict: "restrict f A ` a = (if a \<in> A then f`a else 0)"
by (simp add: apply_def restrict_def, blast)

lemma restrict_empty [simp]: "restrict f 0 = 0"
by (unfold restrict_def, simp)

lemma restrict_iff: "z \<in> restrict r A \<longleftrightarrow> z \<in> r & (\<exists>x\<in>A. \<exists>y. z = \<langle>x, y\<rangle>)"
by (simp add: restrict_def)

lemma restrict_restrict [simp]:
     "restrict (restrict r A) B = restrict r (A \<inter> B)"
by (unfold restrict_def, blast)

lemma domain_restrict [simp]: "domain (restrict f C) = domain f \<inter> C"
apply (unfold restrict_def)
apply (auto simp add: domain_def)
done

lemma restrict_idem: "f \<subseteq> Sigma A B ==> restrict f A = f"
by (simp add: restrict_def, blast)

(*converse probably holds too*)
lemma domain_restrict_idem:
     "[| domain(r) \<subseteq> A; relation(r) |] ==> restrict r A = r"
by (simp add: restrict_def relation_def, blast)

lemma domain_restrict_lam [simp]: "domain(restrict (Lambda A f) C) = A \<inter> C"
apply (unfold restrict_def lam_def)
apply (rule equalityI)
apply (auto simp add: domain_iff)
done

lemma restrict_if [simp]: "restrict f A ` a = (if a \<in> A then f`a else 0)"
by (simp add: restrict apply_0)

lemma restrict_lam_eq:
    "A<=C ==> restrict (\<lambda>x\<in>C. b(x)) A = (\<lambda>x\<in>A. b(x))"
by (unfold restrict_def lam_def, auto)

lemma fun_cons_restrict_eq:
     "f \<in> cons a b -> B ==> f = cons <a, f ` a> (restrict f b)"
apply (rule equalityI)
 prefer 2 apply (blast intro: apply_Pair restrict_subset [THEN subsetD])
apply (auto dest!: Pi_memberD simp add: restrict_def lam_def)
done

subsection\<open>Unions of Functions\<close>

(** The Union of a set of COMPATIBLE functions is a function **)

lemma function_Union:
    "[| \<forall>x\<in>S. function(x);
        \<forall>x\<in>S. \<forall>y\<in>S. x<=y | y<=x  |]
     ==> function(\<Union>(S))"
by (unfold function_def, blast)

lemma fun_Union:
    "[| \<forall>f\<in>S. \<exists>C D. f \<in> C->D;
             \<forall>f\<in>S. \<forall>y\<in>S. f<=y | y<=f  |] ==>
          \<Union>(S) \<in> domain(\<Union>(S)) -> range(\<Union>(S))"
apply (unfold Pi_def)
apply (blast intro!: rel_Union function_Union)
done

lemma gen_relation_Union [rule_format]:
     "\<forall>f\<in>F. relation(f) \<Longrightarrow> relation(\<Union>(F))"
by (simp add: relation_def)

(** The Union of 2 disjoint functions is a function **)

lemmas Un_rls = Un_subset_iff SUM_Un_distrib1 prod_Un_distrib2
                subset_trans [OF _ Un_upper1]
                subset_trans [OF _ Un_upper2]

lemma fun_disjoint_Un:
     "[| f \<in> A->B;  g \<in> C->D;  A \<inter> C = 0  |]
      ==> (f \<union> g) \<in> (A \<union> C) -> (B \<union> D)"
(*Prove the product and domain subgoals using distributive laws*)
apply (simp add: Pi_iff extension Un_rls)
apply (unfold function_def, blast)
done

lemma fun_disjoint_apply1: "a \<notin> domain(g) ==> (f \<union> g)`a = f`a"
by (simp add: apply_def, blast)

lemma fun_disjoint_apply2: "c \<notin> domain(f) ==> (f \<union> g)`c = g`c"
by (simp add: apply_def, blast)

subsection\<open>Domain and Range of a Function or Relation\<close>

lemma domain_of_fun: "f \<in> Pi A B ==> domain f = A"
by (unfold Pi_def, blast)

lemma apply_rangeI: "[| f \<in> Pi A B;  a \<in> A |] ==> f`a \<in> range f"
by (erule apply_Pair [THEN rangeI], assumption)

lemma range_of_fun: "f \<in> Pi A B ==> f \<in> A->range(f)"
by (blast intro: Pi_type apply_rangeI)

subsection\<open>Extensions of Functions\<close>

lemma fun_extend:
     "[| f \<in> A->B;  c\<notin>A |] ==> cons <c,b> f \<in> cons c A -> cons b B"
apply (frule singleton_fun [THEN fun_disjoint_Un], blast)
apply (simp add: cons_eq)
done

lemma fun_extend3:
     "[| f \<in> A->B;  c\<notin>A;  b \<in> B |] ==> cons <c,b> f \<in> cons c A -> B"
by (blast intro: fun_extend [THEN fun_weaken_type])

lemma extend_apply:
     "c \<notin> domain(f) ==> cons <c,b> f ` a = (if a=c then b else f`a)"
by (auto simp add: apply_def)

lemma fun_extend_apply [simp]:
     "[| f \<in> A->B;  c\<notin>A |] ==> cons <c,b> f ` a = (if a=c then b else f`a)"
apply (rule extend_apply)
apply (simp add: Pi_def, blast)
done

lemmas singleton_apply = apply_equality [OF singletonI singleton_fun, simp]

(*For Finite.ML.  Inclusion of right into left is easy*)
lemma cons_fun_eq:
     "c \<notin> A ==> cons c A -> B = (\<Union>f \<in> A->B. \<Union>b\<in>B. {cons <c,b> f})"
apply (rule equalityI)
apply (safe elim!: fun_extend3)
(*Inclusion of left into right*)
apply (subgoal_tac "restrict x A \<in> A -> B")
 prefer 2 apply (blast intro: restrict_type2)
apply (rule UN_I, assumption)
apply (rule apply_funtype [THEN UN_I])
  apply assumption
 apply (rule consI1)
apply (simp (no_asm))
apply (rule fun_extension)
  apply assumption
 apply (blast intro: fun_extend)
apply (erule consE, simp_all)
done

lemma succ_fun_eq: "succ(n) -> B = (\<Union>f \<in> n->B. \<Union>b\<in>B. {cons <n,b> f})"
by (simp add: succ_def mem_not_refl cons_fun_eq)

subsection\<open>Function Updates\<close>

definition
  update  :: "[i,i,i] => i"  where
   "update f a b == \<lambda>x\<in>cons a (domain f). if x=a then b else f`x"

nonterminal updbinds and updbind

syntax

  (* Let expressions *)

  "_updbind"    :: "[i, i] => updbind"               ("(2_ :=/ _)")
  ""            :: "updbind => updbinds"             ("_")
  "_updbinds"   :: "[updbind, updbinds] => updbinds" ("_,/ _")
  "_Update"     :: "[i, updbinds] => i"              ("_/'((_)')" [900,0] 900)

translations
  "_Update f (_updbinds b bs)"  == "_Update (_Update f b) bs"
  "f(x:=y)"                       == "CONST update f x y"

lemma update_apply [simp]: "f(x:=y) ` z = (if z=x then y else f`z)"
apply (simp add: update_def)
apply (case_tac "z \<in> domain(f)")
apply (simp_all add: apply_0)
done

lemma update_idem: "[| f`x = y;  f \<in> Pi A B;  x \<in> A |] ==> f(x:=y) = f"
apply (unfold update_def)
apply (simp add: domain_of_fun cons_absorb)
apply (rule fun_extension)
apply (best intro: apply_type if_type lam_type, assumption, simp)
done

(* [| f \<in> Pi(A, B); x \<in> A |] ==> f(x := f`x) = f *)
declare refl [THEN update_idem, simp]

lemma domain_update [simp]: "domain(f(x:=y)) = cons x (domain f)"
by (unfold update_def, simp)

lemma update_type: "[| f \<in> Pi A B;  x \<in> A;  y \<in> B(x) |] ==> f(x:=y) \<in> Pi A B"
apply (unfold update_def)
apply (simp add: domain_of_fun cons_absorb apply_funtype lam_type)
done

subsection\<open>Monotonicity Theorems\<close>

subsubsection\<open>Replacement in its Various Forms\<close>

(*Not easy to express monotonicity in P, since any "bigger" predicate
  would have to be single-valued*)
lemma Replace_mono: "A<=B ==> Replace A P \<subseteq> Replace B P"
by (blast elim!: ReplaceE)

lemma RepFun_mono: "A<=B ==> {f(x). x \<in> A} \<subseteq> {f(x). x \<in> B}"
by blast

lemma Pow_mono: "A<=B ==> Pow(A) \<subseteq> Pow(B)"
by blast

lemma Union_mono: "A<=B ==> \<Union>(A) \<subseteq> \<Union>(B)"
by blast

lemma UN_mono:
    "[| A<=C;  !!x. x \<in> A ==> B(x)<=D(x) |] ==> (\<Union>x\<in>A. B(x)) \<subseteq> (\<Union>x\<in>C. D(x))"
by blast

(*Intersection is ANTI-monotonic.  There are TWO premises! *)
lemma Inter_anti_mono: "[| A<=B;  A\<noteq>0 |] ==> \<Inter>(B) \<subseteq> \<Inter>(A)"
by blast

lemma cons_mono: "C<=D ==> cons a C \<subseteq> cons a D"
by blast

lemma Un_mono: "[| A<=C;  B<=D |] ==> A \<union> B \<subseteq> C \<union> D"
by blast

lemma Int_mono: "[| A<=C;  B<=D |] ==> A \<inter> B \<subseteq> C \<inter> D"
by blast

lemma Diff_mono: "[| A<=C;  D<=B |] ==> A-B \<subseteq> C-D"
by blast

subsubsection\<open>Standard Products, Sums and Function Spaces\<close>

lemma Sigma_mono [rule_format]:
     "[| A<=C;  !!x. x \<in> A \<longrightarrow> B(x) \<subseteq> D(x) |] ==> Sigma A B \<subseteq> Sigma C D"
by blast

lemma sum_mono: "[| A<=C;  B<=D |] ==> A+B \<subseteq> C+D"
by (unfold sum_def, blast)

(*Note that B->A and C->A are typically disjoint!*)
lemma Pi_mono: "B<=C ==> A->B \<subseteq> A->C"
by (blast intro: lam_type elim: Pi_lamE)

lemma lam_mono: "A<=B ==> Lambda A c \<subseteq> Lambda B c"
apply (unfold lam_def)
apply (erule RepFun_mono)
done

subsubsection\<open>Converse, Domain, Range, Field\<close>

lemma converse_mono: "r<=s ==> converse(r) \<subseteq> converse(s)"
by blast

lemma domain_mono: "r<=s ==> domain(r)<=domain(s)"
by blast

lemmas domain_rel_subset = subset_trans [OF domain_mono domain_subset]

lemma range_mono: "r<=s ==> range(r)<=range(s)"
by blast

lemmas range_rel_subset = subset_trans [OF range_mono range_subset]

lemma field_mono: "r<=s ==> field(r)<=field(s)"
by blast

lemma field_rel_subset: "r \<subseteq> A*A ==> field(r) \<subseteq> A"
by (erule field_mono [THEN subset_trans], blast)

subsubsection\<open>Images\<close>

lemma image_pair_mono:
    "[| !! x y. <x,y>:r ==> <x,y>:s;  A<=B |] ==> r``A \<subseteq> s``B"
by blast

lemma vimage_pair_mono:
    "[| !! x y. <x,y>:r ==> <x,y>:s;  A<=B |] ==> r-``A \<subseteq> s-``B"
by blast

lemma image_mono: "[| r<=s;  A<=B |] ==> r``A \<subseteq> s``B"
by blast

lemma vimage_mono: "[| r<=s;  A<=B |] ==> r-``A \<subseteq> s-``B"
by blast

lemma Collect_mono:
    "[| A<=B;  !!x. x \<in> A ==> P(x) \<longrightarrow> Q(x) |] ==> Collect A P \<subseteq> Collect B Q"
by blast

(*Used in intr_elim.ML and in individual datatype definitions*)
lemmas basic_monos = subset_refl imp_refl disj_mono conj_mono ex_mono
                     Collect_mono Part_mono in_mono

(* Useful with simp; contributed by Clemens Ballarin. *)

lemma bex_image_simp:
  "[| f \<in> Pi X Y; A \<subseteq> X |]  ==> (\<exists>x\<in>f``A. P(x)) \<longleftrightarrow> (\<exists>x\<in>A. P(f`x))"
  apply safe
   apply rule
    prefer 2 apply assumption
   apply (simp add: apply_equality)
  apply (blast intro: apply_Pair)
  done

lemma ball_image_simp:
  "[| f \<in> Pi X Y; A \<subseteq> X |]  ==> (\<forall>x\<in>f``A. P(x)) \<longleftrightarrow> (\<forall>x\<in>A. P(f`x))"
  apply safe
   apply (blast intro: apply_Pair)
  apply (drule bspec) apply assumption
  apply (simp add: apply_equality)
  done

end