theory MathOlympiadProblems
imports Complex_Main Dirichlet_Series.Arithmetic_Summatory Dirichlet_Series.Divisor_Count
begin

section \<open>India 2014 Question 2\<close>

(*
https://www.youtube.com/watch?v=SEHhzkH3ZqM
https://en.wikipedia.org/wiki/Floor_and_ceiling_functions#Equivalences
https://www.youtube.com/watch?v=KMyQIPc4pgA&feature=youtu.be
https://math.stackexchange.com/questions/338432/how-to-prove-the-relation-between-the-floor-function-and-the-number-of-divisors
*)

sledgehammer_params[debug=true,timeout=600]

abbreviation divisors :: "nat \<Rightarrow> int" where
  "divisors n \<equiv> card { d. d dvd n }"

abbreviation psq where
  "psq n \<equiv> (\<exists>a. n = a\<^sup>2)"

lemma not_psq:
  fixes n::nat
  assumes "\<not> (psq n)"
  shows "\<forall>a::nat. n \<noteq> a\<^sup>2"  using assms by simp

(* Proof borrowed from sum_upto_sum_divisors; seems easier than trying to fit proof to use sum_upto_sum_divisors *)
lemma sum_div_sum_divisors:
  fixes n::nat
  shows  "(\<Sum>k \<in> {1..n}.  \<lfloor>n / k \<rfloor>) = (\<Sum>i \<in> {1..n}. divisors(i))"
proof -
  let ?A = "SIGMA  i: {1..n}. {d. d dvd i}"
  let ?B = "SIGMA  k: {1..n}. {1.. nat \<lfloor>n / k \<rfloor> }"

  have bij: "bij_betw (\<lambda>(k,d). (d * k, k)) ?B ?A"
    apply(rule bij_betwI[where g = "\<lambda>(k,d). (d, k div d)"],auto+ )
    apply(metis floor_divide_of_nat_eq le_trans mult.commute mult_le_mono2 nat_int times_div_less_eq_dividend)
     apply(meson Suc_le_lessD dvd_imp_le le_trans)
  by (simp add: div_le_mono floor_divide_of_nat_eq)

  have "(\<Sum>i \<in> {1..n}. divisors(i)) = (\<Sum>(k,d)\<in>?A. 1)"
    using sum.Sigma[of "{1..n}" "\<lambda>i. {d. d dvd i}"  "\<lambda>_ _. 1"] by simp
  also have "... = (\<Sum>(k,d)\<in>?B. 1)"   by (subst sum.reindex_bij_betw[OF bij, symmetric]) (auto simp: case_prod_unfold)
  also have "... = (\<Sum>k \<in> {1..n}.  \<lfloor>real n / real k \<rfloor>)" using
   sum.Sigma[of "{1..n}" "\<lambda>k. {1.. nat \<lfloor>real n / real k \<rfloor> }" "\<lambda>_ _.1" ] by simp
  finally show ?thesis by auto
qed

(* From ME *)
lemma bij_betw_submultisets:
  "card {B. B \<subseteq># A} = (\<Prod>x\<in>set_mset A. count A x + 1)"
proof -
  define f :: "'a multiset \<Rightarrow> 'a \<Rightarrow> nat"
    where "f = (\<lambda>B x. if x \<in># A then count B x else undefined)"
  define g :: "('a \<Rightarrow> nat) \<Rightarrow> 'a multiset"
    where "g = (\<lambda>h. Abs_multiset (\<lambda>x. if x \<in># A then h x else 0))"

  have count_g: "count (g h) x = (if x \<in># A then h x else 0)"
    if "h \<in> (\<Pi>\<^sub>E x\<in>set_mset A. {0..count A x})" for h x
  proof -
    have "finite {x. (if x \<in># A then h x else 0) > 0}"
      by (rule finite_subset[of _ "set_mset A"]) (use that in auto)
    thus ?thesis by (simp add: multiset_def g_def)
  qed

  have f: "f B \<in> (\<Pi>\<^sub>E x\<in>set_mset A. {0..count A x})" if "B \<subseteq># A" for B
      using that by (auto simp: f_def subseteq_mset_def)

  have "bij_betw f {B. B \<subseteq># A} (\<Pi>\<^sub>E x\<in>set_mset A. {0..count A x})"
  proof (rule bij_betwI[where g = g], goal_cases)
    case 1
    thus ?case using f by auto
  next
    case 2
    show ?case
      by (auto simp: Pi_def PiE_def count_g subseteq_mset_def)
  next
    case (3 B)
    have "count (g (f B)) x  = count B x" for x
    proof -
      have "count (g (f B)) x = (if x \<in># A then f B x else 0)"
        using f 3 by (simp add: count_g)
      also have "\<dots> = count B x"
        using 3 by (auto simp: f_def dest: mset_subset_eqD)
      finally show ?thesis .
    qed
    thus ?case
      by (auto simp: multiset_eq_iff)
  next
    case 4
    thus ?case
      by (auto simp: fun_eq_iff f_def count_g)
  qed
  hence "card {B. B \<subseteq># A} = card (\<Pi>\<^sub>E x\<in>set_mset A. {0..count A x})"
    using bij_betw_same_card by blast
  thm card_PiE
  thus ?thesis
    by (simp add: card_PiE)
qed

lemma count_multiplicity:
  fixes n::nat
  assumes  "p \<in> prime_factors n"
  shows "count (prime_factorization n) p = multiplicity p n"
  using assms  count_prime_factorization_prime by blast

lemma num_divisors:
  fixes n :: nat
  assumes "n \<noteq> 0"
  shows  "card { d. d dvd n } = (\<Prod>p\<in> prime_factors n.  multiplicity p n + 1)"
proof -
  define f :: "nat multiset \<Rightarrow> nat" where "f = prod_mset"
  define g :: "nat \<Rightarrow> nat multiset" where "g = prime_factorization"

  have "bij_betw f  { B . B \<subseteq># prime_factorization n} { d. d dvd n }"
  proof (rule bij_betwI[where g = g], goal_cases)
    case 1
    {
      fix x
      assume "x \<in> {B. B \<subseteq># prime_factorization n}"
      hence "f x \<in> { d . d dvd n}" using prime_factorization_subset_iff_dvd
        using assms f_def prod_mset_subset_imp_dvd by fastforce
    }
    then show ?case by simp
  next
    case 2
    {
      fix x
      assume "x \<in> { d . d dvd n}"
      hence "g x \<in>  {B. B \<subseteq># prime_factorization n}" using prime_factorization_subset_iff_dvd
        using assms f_def prod_mset_subset_imp_dvd
        by (metis g_def mem_Collect_eq prime_factorization_0 subset_mset.bot.extremum)
    }
    then show ?case by simp
  next
    case (3 x)
    hence "(\<And>p. p \<in># x \<Longrightarrow> prime p)"  using mset_subset_eqD by fastforce
    then show ?case using f_def g_def assms prime_factorization_prod_mset_primes[of x] normalize_nat_def by auto
  next
    case (4 y)
    then show ?case using f_def g_def assms prod_mset_prime_factorization normalize_nat_def by auto
  qed

  hence  "card { d. d dvd n } = card {B. B \<subseteq># prime_factorization n}"
    using prime_factorization_subset_iff_dvd bij_betw_same_card by force
  moreover have "(\<Prod>x\<in>prime_factors n. count (prime_factorization n) x + 1) = (\<Prod>p\<in>prime_factors n. multiplicity p n + 1)"
    using count_multiplicity
    by (metis (no_types, lifting) prod.cong)
  ultimately show ?thesis using bij_betw_submultisets[of "prime_factorization n"] by simp
qed

lemma even_psq:
  fixes n::nat
  assumes "B =  prime_factorization n" and
         "\<forall>p \<in>#  B.  even( count B p )" and "n \<noteq> 0"
  shows "psq n"
proof -

  define f where "f = (\<lambda>p. if p \<in># B then (count B p)  div 2 else 0)"
  define A where "A = Abs_multiset f"

  have fm: "f  \<in> multiset" proof -
    have "finite {x. 0 < f x}" using f_def
      by (metis finite_nat_set_iff_bounded finite_set_mset mem_Collect_eq nat_neq_iff)
    thus ?thesis using multiset_def by auto
  qed

  have "A + A = B" proof  -
    have "(\<forall>p. count (A + A) p = count B p)"  using A_def assms fm f_def Abs_multiset_inverse  dvd_div_eq_iff by fastforce
    thus ?thesis  using  multiset_eq_iff[of "A + A" B] by simp
  qed

  obtain a::nat where a:"a = prod_mset A"  by simp

  have "(\<And>p. p \<in># A \<Longrightarrow> prime p)"
  proof -
    fix p
    assume "p \<in> set_mset A"
    hence "count A p > 0" by auto
    hence "count B p > 0" using assms
      by (metis \<open>A + A = B\<close> count_eq_zero_iff neq0_conv union_iff)
    thus  "prime p" using assms prime_factorization_def by auto
  qed

  hence a2:"A = prime_factorization a"
    using  prime_factorization_exists[of a] normalize_nat_def prime_factorization_unique prime_factorization_prod_mset_primes
    by (simp add: prime_factorization_prod_mset_primes a)
  hence "a \<noteq> 0" using a
    by (metis prime_factorization_0 prod_mset_empty zero_neq_one)
  hence "prime_factorization (a * a) = A + A"
     using prime_factorization_mult \<open>a \<noteq> 0\<close> a2 by auto
  hence "prime_factorization (a * a) = prime_factorization n" using  \<open>A + A = B\<close> assms by auto
  hence "n = a\<^sup>2" using prime_factorization_unique[of "a*a" n] normalize_nat_def a2 a
    a2 a assms power2_eq_square \<open>a \<noteq> 0\<close>
    by (metis id_apply mult_is_0)
  thus ?thesis by simp
qed

lemma psq_even:
  fixes n::nat
  assumes  "psq n" and "B =  prime_factorization n"
  shows "\<forall>p \<in># B.  even ( count B p)"
using assms proof(cases "n=0")
  case True
  then show ?thesis  by (simp add: assms(2))
next
  case False

  obtain a::nat where a: "n = a\<^sup>2" using assms by auto

  define A where "A = prime_factorization a"
  have "a \<noteq> 0"  using a False by simp
  hence "A + A = B" using prime_factorization_mult[of a a] a assms
    by (simp add: A_def power2_eq_square)

  hence "\<forall>p \<in># B. count B p = count A p + count A p" using count_union by auto
  thus ?thesis by simp
qed

lemma num_divisors2:
  fixes n::nat
  assumes "n \<noteq> 0" and "A = prime_factorization n"
  shows "card {d. d dvd n} = (\<Prod>p \<in> set_mset A. count A p  + 1)"
proof -
  have "\<forall>p \<in> set_mset A. count A p + 1 = multiplicity p n + 1" using count_prime_factorization_prime
    by (simp add: assms(2) count_multiplicity)
  hence *:"(\<Prod>p \<in> set_mset A. multiplicity p n + 1) =  (\<Prod>p \<in> set_mset A. count A p  + 1)"
    using assms prime_factorsI by auto
  hence "(\<Prod>p \<in> prime_factors n . multiplicity p n + 1) =  (\<Prod>p \<in> set_mset A. multiplicity p n + 1)"
    unfolding  prod_mset_def
    using assms(2) by auto
  thus ?thesis using num_divisors[of n] assms * by auto
qed

lemma odd_even:
  fixes A::"'a set"
  assumes "finite A"
  shows "odd (\<Prod>p \<in> A. (f p  + 1)) = (\<forall>p \<in> A. even (f p ))"
using assms proof(induct A rule:finite_induct)
  case empty
  then show ?case by auto
next
  case (insert x F)
  hence "(\<Prod>p\<in>insert x F. (f p + 1)) = (\<Prod>p\<in>F. f p + 1) * (f x + 1)"
    by (simp add: mult.commute)
  then show ?case using insert
    by auto
qed

lemma psq_odd_card_divisors:
  fixes n::nat
  assumes "n \<noteq> 0"
  shows "psq n \<longleftrightarrow> odd (divisors n)"
proof -
  obtain A where A:"A =  prime_factorization n" by auto
  hence *:"finite (set_mset A)"
    by simp
  hence "odd (divisors n) = (\<forall>p \<in># A.  even ( count A p))" using num_divisors2[OF assms A]
         odd_even[OF *, where f="count A"]
    by presburger
  thus ?thesis using psq_even even_psq assms A by metis
qed

lemma sum_divisors_eq_sum_psq:
  fixes n::nat
  shows  "(\<Sum>k \<in> {1..n}. divisors(k)) mod 2 = ((\<Sum>k \<in> {1..n}. if psq k then 1 else 0)) mod 2"
proof(induct n)
  case 0
  then show ?case by auto
next
  case (Suc m)
  have "Suc m \<noteq> 0" by auto
  hence *: "(if psq (Suc m) then 1 else 0) =  divisors (Suc m) mod 2" using psq_odd_card_divisors[of "Suc m"]
    by (metis parity_cases)

  have "sum divisors {1..Suc m} mod 2  = (sum divisors {1..m} + divisors (Suc m) ) mod 2"
    by auto
  also have "... = (sum divisors {1..m} mod 2 + divisors (Suc m) mod 2 ) mod 2" by presburger
  also have "... = (((\<Sum>k = 1..m. if psq k then 1 else 0) mod 2) +  divisors (Suc m) mod 2 ) mod 2"
    using Suc by argo
  also have "... = (((\<Sum>k = 1..m. if psq k then 1 else 0) mod 2) + (if psq (Suc m) then 1 else 0) mod 2) mod 2"
    using * by presburger
   also have "... = (((\<Sum>k = 1..m. if psq k then 1 else 0) + (if psq (Suc m) then 1 else 0)) mod 2) mod 2"
     by (simp add: mod_add_left_eq)
   also have "... =  (\<Sum>k = 1..Suc m. if psq k then 1 else 0) mod 2"
     by auto
  finally show ?case by auto
qed

lemma divsuc:
  fixes n::nat
  assumes "n \<noteq> 0" and "k dvd (n+1)" and "k \<noteq> 1"
  shows "\<not> (k dvd n)"
using assms proof(induct n)
  case 0
  then show ?case by simp
next
  case (Suc m)
  then show ?case using dvd_def
    by (metis One_nat_def dvd_1_iff_1 dvd_add_right_iff)
qed

lemma suc_n_product:
  fixes k::nat and n::nat
  assumes "n+1 = k * x"
  shows "n = k*(x-1) + (k-1)"
proof -
  have "k*(x-1) + (k-1) = k*x - k + (k - 1)" using assms
    by (simp add: right_diff_distrib')
  also have "... = k*x - 1"
    using Nat.add_diff_assoc Suc_diff_1 assms diff_is_0_eq' le_add2 le_numeral_extra
      less_numeral_extra(1) one_le_mult_iff ordered_cancel_comm_monoid_diff_class.diff_add

    by (metis add_right_imp_eq calculation mult.right_neutral nat_less_le no_zero_divisors zero_less_diff)
  finally have "k*(x-1) + (k-1) = n" using assms by simp
  thus ?thesis by simp
qed

lemma div_suc_n_mod_n:
  fixes k::nat and n::nat
  assumes "(n+1) mod k = 0" and "k > 0" and "n > 0"
  shows "n mod k = k-1" using assms
  by (smt Suc_lessI add.right_neutral add_eq_0_iff_both_eq_0 diff_Suc_1
         group_cancel.add2 mod_add_left_eq mod_less plus_1_eq_Suc unique_euclidean_semiring_numeral_class.pos_mod_bound zero_neq_one)

lemma div_suc_n_div_n:
  fixes k::nat and n::nat
  assumes "(n+1) div k = x" and "(n+1) mod k = 0"
  shows "n div k = x - 1"
proof -
  have "n+1 = k * x" using assms
    by auto
  hence "n = k*(x-1) + (k-1)" using assms suc_n_product[of n k x] by auto
  moreover have "n mod k = k-1" using assms div_suc_n_mod_n
    by (metis \<open>n + 1 = k * x\<close> add_gr_0 calculation mod_mod_trivial nat_0_less_mult_iff not_gr_zero)
  ultimately show ?thesis using div_mult_mod_eq[of n k]
    by (metis Nat.add_0_right \<open>n + 1 = k * x\<close> assms(1) diff_0_eq_0 div_mult_self4 mod_div_trivial mult_eq_0_iff)
qed

lemma divstep:
  fixes k::nat and n::nat
  assumes "n \<noteq> 0" and "k dvd (n+1)" and "k > 1"
  shows "\<lfloor>(n+1)/k\<rfloor> = \<lfloor>n/k\<rfloor> + 1"
proof -
  have "\<lfloor>(n+1)/k\<rfloor> = (n+1) div k" using assms by fastforce
  hence "n div k = \<lfloor>(n+1)/k\<rfloor> - 1" using assms div_suc_n_div_n[of n k]
    using dvd_div_gt0 int_ops(6) by auto
  moreover have "\<lfloor>n/k\<rfloor> = n div k" using assms
    by (simp add: floor_divide_of_nat_eq)
  ultimately show ?thesis using assms by simp
qed

lemma sqrt_suc_le_suc_sqrt:
 fixes n::nat
 shows  "sqrt(n+1) \<le> sqrt(n) + 1"
proof -
  have "n + 1 \<le> n + 2*sqrt(n) + 1" by simp
  moreover have "n + 2*sqrt(n) + 1 = (sqrt(n) + 1)\<^sup>2" proof -
    have "(sqrt(n) + 1)\<^sup>2 = (sqrt(n) + 1) * (sqrt(n) + 1)"
      by (simp add: power2_eq_square)
    also have "... = sqrt(n)*sqrt(n) + 2*sqrt(n) + 1" by argo
    finally show ?thesis by auto
  qed

  ultimately have "n + 1 \<le> (sqrt(n) + 1)\<^sup>2" by simp
  thus ?thesis
    by (smt \<open>real n + 2 * sqrt (real n) + 1 = (sqrt (real n) + 1)\<^sup>2\<close> of_nat_0 of_nat_le_0_iff real_le_lsqrt sqrt_le_D)
qed

lemma sqrt_suc_le_suc_sqrt2:
  fixes n::nat
  shows "\<lfloor>sqrt (n+1)\<rfloor> - \<lfloor>sqrt n\<rfloor> \<le> 1"
  using sqrt_suc_le_suc_sqrt[of n]
  by linarith

lemma psq_imp_sqrt_suc_suc:
  fixes n::nat
  assumes "psq (n+1)"
  shows "\<lfloor>sqrt (n+1)\<rfloor> = \<lfloor>sqrt n\<rfloor>+1"
proof -
  obtain a::nat where a:"n+1=a\<^sup>2" using assms by auto
  hence "\<lfloor>sqrt (n+1)\<rfloor> = a" by auto
  have "a - \<lfloor>sqrt n\<rfloor> = 1" proof(rule ccontr)
    assume "a - \<lfloor>sqrt n\<rfloor> \<noteq> 1"
    hence "\<lfloor>sqrt n\<rfloor> = a" using sqrt_suc_le_suc_sqrt2
      by (smt \<open>\<lfloor>sqrt (real (n + 1))\<rfloor> = int a\<close> floor_mono of_nat_1 of_nat_add real_sqrt_le_iff)
    hence "sqrt n \<ge> a" by linarith
    hence "n \<ge> a\<^sup>2"
      using  a le_add2 of_nat_1 of_nat_add of_nat_le_of_nat_power_cancel_iff one_power2 power2_nat_le_eq_le real_le_lsqrt real_sqrt_eq_iff real_sqrt_unique
      by (metis of_nat_0_le_iff power_mono real_sqrt_pow2_iff)
    thus False using a by simp
  qed
  thus ?thesis using a by simp
qed

lemma not_psq_imp_sqrt_suc_eq:
  fixes n::nat
  assumes "\<not> psq (n+1)"
  shows "\<lfloor>sqrt (n+1)\<rfloor> = \<lfloor>sqrt n\<rfloor>"
proof -
  have psq: "\<forall>a::nat. n+1 \<noteq> a\<^sup>2" using assms not_psq[of "n+1"] by auto
  obtain a::nat where a_def:" a = \<lfloor>sqrt (n+1)\<rfloor>"
    using nat_0_le of_nat_0_le_iff real_sqrt_ge_0_iff zero_le_floor by blast
  have 2:"n+1 < (a+1)\<^sup>2" proof(rule ccontr)
    assume "\<not> n + 1 < (a + 1)\<^sup>2"
    hence "n+1 \<ge> (a + 1)\<^sup>2" by auto
    hence "sqrt (n+1) \<ge> a + 1"
      using of_nat_le_of_nat_power_cancel_iff real_le_rsqrt by blast
    thus False using a_def by linarith
  qed
  moreover have 1:"a\<^sup>2 \<le> n" proof(rule ccontr)
    assume "\<not> (a\<^sup>2 \<le> n)"
    hence **:"a\<^sup>2 \<ge> n+1" by auto
    show False proof(cases "a\<^sup>2 = n+1")
      case True
      then show ?thesis using psq by metis
    next
      case False
      hence "a > sqrt(n+1)" using **
        by (smt add_leD2 le_antisym of_nat_1 of_nat_le_of_nat_power_cancel_iff one_power2 power2_nat_le_eq_le real_less_lsqrt real_sqrt_lt_0_iff)
      then show ?thesis using a_def by linarith
    qed
  qed
  moreover have 3:"n < n+1" by auto
  ultimately have  "a \<le> sqrt n \<and> sqrt n < (a+1)" proof -
    have "a \<le> sqrt n" using 1 a_def
      by (simp add: real_le_rsqrt)
    moreover have "sqrt n < (a+1)" using 2 3 real_le_rsqrt
      by (smt le_add2 of_nat_1 of_nat_add of_nat_mono of_nat_power_less_of_nat_cancel_iff real_less_lsqrt)
    ultimately show ?thesis by auto
  qed
  hence "\<lfloor>sqrt n\<rfloor> = a" by linarith
  thus ?thesis using a_def by simp
qed

lemma sum_psq_eq_sqrt:
  fixes n::nat
  shows  "((\<Sum>k \<in> {1..n}.  if psq k then 1 else 0) =  \<lfloor>sqrt n\<rfloor>)"
proof(induct n)
  case 0
  then show ?case by auto
next
  case (Suc m)
  then show ?case proof(cases "psq (Suc m)")
    case True
    hence "\<lfloor>sqrt (m+1)\<rfloor> = \<lfloor>sqrt m\<rfloor>+1"  using psq_imp_sqrt_suc_suc  by auto
    moreover have "(if psq (Suc m) then 1 else 0) = 1" using True by simp
    ultimately show ?thesis using Suc by auto
  next
    case False
    hence "\<lfloor>sqrt (m+1)\<rfloor> = \<lfloor>sqrt m\<rfloor>" using not_psq_imp_sqrt_suc_eq by simp
    moreover have "(if psq (Suc m) then 1 else 0) = 0" using False by simp
    ultimately show ?thesis using Suc by auto
  qed
qed

lemma sum_div_sum_psq:
  fixes n::nat
  shows  "((\<Sum>k \<in> {1..n}.   \<lfloor>n/k\<rfloor>)) mod 2 = ((\<Sum>k \<in> {1..n}.  if psq k then 1 else 0)) mod 2"
proof -
  have "(\<Sum>k \<in> {1..n}.  (\<lfloor>n / k \<rfloor>)) mod 2 = (\<Sum>i \<in> {1..n}. divisors(i)) mod 2" using sum_div_sum_divisors by presburger
  also have "... = ((\<Sum>k \<in> {1..n}.  if psq k then 1 else 0)) mod 2" using sum_divisors_eq_sum_psq[of n] by argo
  finally show ?thesis by auto
qed

lemma sum_div_suc_sum_psq:
  fixes n::nat
  shows "((\<Sum>k \<in> {1..Suc n}.  \<lfloor>real (Suc n)/real k\<rfloor>) mod 2) = (((\<Sum>k \<in> {1..n}.  \<lfloor>real n/ real k\<rfloor>)) + (if psq (n+1) then 1 else 0)) mod 2" (is "?A = ?B ")
proof -
  have "?A = ((\<Sum>k \<in> {1..n+1}.  if psq k then 1 else 0)) mod 2" using sum_div_sum_psq[of "Suc n"] by auto
  also have "... = (((\<Sum>k \<in> {1..n}.  if psq k then 1 else 0))  + ((if psq (n+1) then 1 else 0))) mod 2" by auto
  also have "... = (((\<Sum>k \<in> {1..n}.  if psq k then 1 else 0) mod 2)  + ((if psq (n+1) then 1 else 0) mod 2)) mod 2"
    by (metis (no_types, lifting) mod_add_eq)
  also have "... = (((\<Sum>k \<in> {1..n}.  \<lfloor>real n/ real k\<rfloor>) mod 2 ) + ((if psq (n+1) then 1 else 0) mod 2)) mod 2" using sum_div_sum_psq by metis
  finally show ?thesis using mod_add_eq by metis
qed

lemma soln1:
  fixes n::nat
  shows "even ((\<Sum>k \<in> {1..n}.  \<lfloor>n/k\<rfloor>) +  \<lfloor>sqrt n\<rfloor>) "
proof(induct n)
  case 0
  then show ?case by auto
next
  case (Suc n)
  then show ?case proof(cases "\<exists>a. n+1 = a\<^sup>2")
    case True
    hence " \<lfloor>sqrt (real n)\<rfloor> + 1 = \<lfloor>sqrt (real (Suc n))\<rfloor>" using psq_imp_sqrt_suc_suc by simp
    moreover have "((\<Sum>k \<in> {1..Suc n}.  \<lfloor>real (Suc n)/real k\<rfloor>) mod 2) = (((\<Sum>k \<in> {1..n}.  \<lfloor>real n/ real k\<rfloor>) ) + 1) mod 2"
      using sum_div_suc_sum_psq True by simp
    ultimately have  "((\<Sum>k \<in> {1..n}.  \<lfloor>real n/real k\<rfloor>) + \<lfloor>sqrt (real n)\<rfloor>) mod 2 = ((\<Sum>k \<in> {1..Suc n}.  \<lfloor>real (Suc n)/ real k\<rfloor>) + \<lfloor>sqrt (real (Suc n))\<rfloor>) mod 2"
      by presburger
    thus ?thesis using Suc by (metis odd_iff_mod_2_eq_one)
  next
    case False
    hence " \<lfloor>sqrt (real n)\<rfloor>  = \<lfloor>sqrt (real (Suc n))\<rfloor>" using not_psq_imp_sqrt_suc_eq by simp
    moreover have "((\<Sum>k \<in> {1..n}.  \<lfloor>real n/ real k\<rfloor>) mod 2) = ((\<Sum>k \<in> {1..Suc n}.  \<lfloor>real (Suc n)/real k\<rfloor>) mod 2)" using sum_div_suc_sum_psq False by auto
    ultimately have  "((\<Sum>k \<in> {1..n}.  \<lfloor>real n/real k\<rfloor>) + \<lfloor>sqrt (real n)\<rfloor>) mod 2 = ((\<Sum>k \<in> {1..Suc n}.  \<lfloor>real (Suc n)/ real k\<rfloor>) + \<lfloor>sqrt (real (Suc n))\<rfloor>) mod 2"
      by presburger
    thus ?thesis using Suc by (metis odd_iff_mod_2_eq_one)
  qed
qed

lemma soln2:
  fixes n::nat
  shows  "even ((\<Sum>k \<in> {1..n}.   \<lfloor>n/k\<rfloor>) +   \<lfloor>sqrt n\<rfloor>)"
proof  -
  have "(\<Sum>k \<in> {1..n}.  (\<lfloor>n / k \<rfloor>)) mod 2 = (\<Sum>i \<in> {1..n}. divisors(i)) mod 2" using sum_div_sum_divisors by presburger
  also have "... = ((\<Sum>k \<in> {1..n}.  if psq k then 1 else 0)) mod 2" using sum_divisors_eq_sum_psq[of n] by argo
  finally have "((\<Sum>k \<in> {1..n}.   \<lfloor>n/k\<rfloor>)) mod 2 = ((\<Sum>k \<in> {1..n}.  if psq k then 1 else 0)) mod 2"
    by auto
  hence  "((\<Sum>k \<in> {1..n}.   \<lfloor> n/ k\<rfloor>) +   \<lfloor>sqrt n\<rfloor>) mod 2 = (((\<Sum>k \<in> {1..n}.  if psq k then 1 else 0) +  \<lfloor>sqrt n\<rfloor>) mod 2)"
    using mod_add_cong by blast
  thus ?thesis using sum_psq_eq_sqrt[of n]
    by (metis odd_add odd_iff_mod_2_eq_one)
qed

lemma card_eq_sum: "card A = sum (\<lambda>x. 1) A"
proof -
  have "plus \<circ> (\<lambda>_. Suc 0) = (\<lambda>_. Suc)"
    by (simp add: fun_eq_iff)
  then have "Finite_Set.fold (plus \<circ> (\<lambda>_. Suc 0)) = Finite_Set.fold (\<lambda>_. Suc)"
    by (rule arg_cong)
  then have "Finite_Set.fold (plus \<circ> (\<lambda>_. Suc 0)) 0 A = Finite_Set.fold (\<lambda>_. Suc) 0 A"
    by (blast intro: fun_cong)
  then show ?thesis
    by (simp add: card.eq_fold sum.eq_fold)
qed

lemma
  shows "(\<Sum>k\<in> S. (\<Sum>d\<in> P k. 1)) = (\<Sum>k\<in> S. card (P k))"
  using card_eq_sum by auto

lemma
  fixes S::"'a set" and P::"'a \<Rightarrow> 'b set"
  assumes  "finite S" and "\<forall>k. finite (P k)"
  shows "card {(k,d) . k \<in> S  \<and> d \<in> P k  } = (\<Sum>k\<in> S. card (P k))"
proof -
  obtain A::"'a \<Rightarrow> ('a*'b) set" where A:"A = (\<lambda>k. {k} \<times> P k )" by auto
  have "card (\<Union> (A ` S)) = (\<Sum>i\<in>S. card (A i))" proof(rule card_UN_disjoint)
    show "finite S" using assms by auto
    show "\<forall>i\<in>S. finite (A i)" using assms A by auto
    show "\<forall>i\<in>S. \<forall>j\<in>S. i \<noteq> j \<longrightarrow> A i \<inter> A j = {}" using A by auto
  qed

  moreover have "\<forall>i \<in> S. card (A i) = card (P i)" proof
    fix i
    assume *:"i \<in> S"
    have "A i = {i} \<times> P i" using A by auto
    then show "card (A i) = card (P i)" using *
      by (simp add: card_cartesian_product_singleton)
  qed
  moreover have "\<Union> (A ` S) =  {(k,d) . k \<in> S  \<and> d \<in> P k  }" unfolding image_def
    apply(auto)
    using A by blast+
  ultimately show ?thesis by auto
qed

end


(*  Title:      HOL/Analysis/Determinants.thy
    Author:     Amine Chaieb, University of Cambridge
*)

section \<open>Traces, Determinant of square matrices and some properties\<close>

theory Determinants
imports
  Cartesian_Euclidean_Space
  "~~/src/HOL/Library/Permutations"
begin

subsection \<open>Trace\<close>

definition trace :: "'a::semiring_1^'n^'n \<Rightarrow> 'a"
  where "trace A = sum (\<lambda>i. ((A$i)$i)) (UNIV::'n set)"

lemma trace_0: "trace (mat 0) = 0"
  by (simp add: trace_def mat_def)

lemma trace_I: "trace (mat 1 :: 'a::semiring_1^'n^'n) = of_nat(CARD('n))"
  by (simp add: trace_def mat_def)

lemma trace_add: "trace ((A::'a::comm_semiring_1^'n^'n) + B) = trace A + trace B"
  by (simp add: trace_def sum.distrib)

lemma trace_sub: "trace ((A::'a::comm_ring_1^'n^'n) - B) = trace A - trace B"
  by (simp add: trace_def sum_subtractf)

lemma trace_mul_sym: "trace ((A::'a::comm_semiring_1^'n^'m) ** B) = trace (B**A)"
  apply (simp add: trace_def matrix_matrix_mult_def)
  apply (subst sum.commute)
  apply (simp add: mult.commute)
  done

text \<open>Definition of determinant.\<close>

definition det:: "'a::comm_ring_1^'n^'n \<Rightarrow> 'a" where
  "det A =
    sum (\<lambda>p. of_int (sign p) * prod (\<lambda>i. A$i$p i) (UNIV :: 'n set))
      {p. p permutes (UNIV :: 'n set)}"

text \<open>A few general lemmas we need below.\<close>

lemma prod_permute:
  assumes p: "p permutes S"
  shows "prod f S = prod (f \<circ> p) S"
  using assms by (fact prod.permute)

lemma product_permute_nat_interval:
  fixes m n :: nat
  shows "p permutes {m..n} \<Longrightarrow> prod f {m..n} = prod (f \<circ> p) {m..n}"
  by (blast intro!: prod_permute)

text \<open>Basic determinant properties.\<close>

lemma det_transpose: "det (transpose A) = det (A::'a::comm_ring_1 ^'n^'n)"
proof -
  let ?di = "\<lambda>A i j. A$i$j"
  let ?U = "(UNIV :: 'n set)"
  have fU: "finite ?U" by simp
  {
    fix p
    assume p: "p \<in> {p. p permutes ?U}"
    from p have pU: "p permutes ?U"
      by blast
    have sth: "sign (inv p) = sign p"
      by (metis sign_inverse fU p mem_Collect_eq permutation_permutes)
    from permutes_inj[OF pU]
    have pi: "inj_on p ?U"
      by (blast intro: subset_inj_on)
    from permutes_image[OF pU]
    have "prod (\<lambda>i. ?di (transpose A) i (inv p i)) ?U =
      prod (\<lambda>i. ?di (transpose A) i (inv p i)) (p ` ?U)"
      by simp
    also have "\<dots> = prod ((\<lambda>i. ?di (transpose A) i (inv p i)) \<circ> p) ?U"
      unfolding prod.reindex[OF pi] ..
    also have "\<dots> = prod (\<lambda>i. ?di A i (p i)) ?U"
    proof -
      {
        fix i
        assume i: "i \<in> ?U"
        from i permutes_inv_o[OF pU] permutes_in_image[OF pU]
        have "((\<lambda>i. ?di (transpose A) i (inv p i)) \<circ> p) i = ?di A i (p i)"
          unfolding transpose_def by (simp add: fun_eq_iff)
      }
      then show "prod ((\<lambda>i. ?di (transpose A) i (inv p i)) \<circ> p) ?U =
        prod (\<lambda>i. ?di A i (p i)) ?U"
        by (auto intro: prod.cong)
    qed
    finally have "of_int (sign (inv p)) * (prod (\<lambda>i. ?di (transpose A) i (inv p i)) ?U) =
      of_int (sign p) * (prod (\<lambda>i. ?di A i (p i)) ?U)"
      using sth by simp
  }
  then show ?thesis
    unfolding det_def
    apply (subst sum_permutations_inverse)
    apply (rule sum.cong)
    apply (rule refl)
    apply blast
    done
qed

lemma det_lowerdiagonal:
  fixes A :: "'a::comm_ring_1^('n::{finite,wellorder})^('n::{finite,wellorder})"
  assumes ld: "\<And>i j. i < j \<Longrightarrow> A$i$j = 0"
  shows "det A = prod (\<lambda>i. A$i$i) (UNIV:: 'n set)"
proof -
  let ?U = "UNIV:: 'n set"
  let ?PU = "{p. p permutes ?U}"
  let ?pp = "\<lambda>p. of_int (sign p) * prod (\<lambda>i. A$i$p i) (UNIV :: 'n set)"
  have fU: "finite ?U"
    by simp
  from finite_permutations[OF fU] have fPU: "finite ?PU" .
  have id0: "{id} \<subseteq> ?PU"
    by (auto simp add: permutes_id)
  {
    fix p
    assume p: "p \<in> ?PU - {id}"
    from p have pU: "p permutes ?U" and pid: "p \<noteq> id"
      by blast+
    from permutes_natset_le[OF pU] pid obtain i where i: "p i > i"
      by (metis not_le)
    from ld[OF i] have ex:"\<exists>i \<in> ?U. A$i$p i = 0"
      by blast
    from prod_zero[OF fU ex] have "?pp p = 0"
      by simp
  }
  then have p0: "\<forall>p \<in> ?PU - {id}. ?pp p = 0"
    by blast
  from sum.mono_neutral_cong_left[OF fPU id0 p0] show ?thesis
    unfolding det_def by (simp add: sign_id)
qed

lemma det_upperdiagonal:
  fixes A :: "'a::comm_ring_1^'n::{finite,wellorder}^'n::{finite,wellorder}"
  assumes ld: "\<And>i j. i > j \<Longrightarrow> A$i$j = 0"
  shows "det A = prod (\<lambda>i. A$i$i) (UNIV:: 'n set)"
proof -
  let ?U = "UNIV:: 'n set"
  let ?PU = "{p. p permutes ?U}"
  let ?pp = "(\<lambda>p. of_int (sign p) * prod (\<lambda>i. A$i$p i) (UNIV :: 'n set))"
  have fU: "finite ?U"
    by simp
  from finite_permutations[OF fU] have fPU: "finite ?PU" .
  have id0: "{id} \<subseteq> ?PU"
    by (auto simp add: permutes_id)
  {
    fix p
    assume p: "p \<in> ?PU - {id}"
    from p have pU: "p permutes ?U" and pid: "p \<noteq> id"
      by blast+
    from permutes_natset_ge[OF pU] pid obtain i where i: "p i < i"
      by (metis not_le)
    from ld[OF i] have ex:"\<exists>i \<in> ?U. A$i$p i = 0"
      by blast
    from prod_zero[OF fU ex] have "?pp p = 0"
      by simp
  }
  then have p0: "\<forall>p \<in> ?PU -{id}. ?pp p = 0"
    by blast
  from sum.mono_neutral_cong_left[OF fPU id0 p0] show ?thesis
    unfolding det_def by (simp add: sign_id)
qed

lemma det_diagonal:
  fixes A :: "'a::comm_ring_1^'n^'n"
  assumes ld: "\<And>i j. i \<noteq> j \<Longrightarrow> A$i$j = 0"
  shows "det A = prod (\<lambda>i. A$i$i) (UNIV::'n set)"
proof -
  let ?U = "UNIV:: 'n set"
  let ?PU = "{p. p permutes ?U}"
  let ?pp = "\<lambda>p. of_int (sign p) * prod (\<lambda>i. A$i$p i) (UNIV :: 'n set)"
  have fU: "finite ?U" by simp
  from finite_permutations[OF fU] have fPU: "finite ?PU" .
  have id0: "{id} \<subseteq> ?PU"
    by (auto simp add: permutes_id)
  {
    fix p
    assume p: "p \<in> ?PU - {id}"
    then have "p \<noteq> id"
      by simp
    then obtain i where i: "p i \<noteq> i"
      unfolding fun_eq_iff by auto
    from ld [OF i [symmetric]] have ex:"\<exists>i \<in> ?U. A$i$p i = 0"
      by blast
    from prod_zero [OF fU ex] have "?pp p = 0"
      by simp
  }
  then have p0: "\<forall>p \<in> ?PU - {id}. ?pp p = 0"
    by blast
  from sum.mono_neutral_cong_left[OF fPU id0 p0] show ?thesis
    unfolding det_def by (simp add: sign_id)
qed

lemma det_I: "det (mat 1 :: 'a::comm_ring_1^'n^'n) = 1"
proof -
  let ?A = "mat 1 :: 'a::comm_ring_1^'n^'n"
  let ?U = "UNIV :: 'n set"
  let ?f = "\<lambda>i j. ?A$i$j"
  {
    fix i
    assume i: "i \<in> ?U"
    have "?f i i = 1"
      using i by (vector mat_def)
  }
  then have th: "prod (\<lambda>i. ?f i i) ?U = prod (\<lambda>x. 1) ?U"
    by (auto intro: prod.cong)
  {
    fix i j
    assume i: "i \<in> ?U" and j: "j \<in> ?U" and ij: "i \<noteq> j"
    have "?f i j = 0" using i j ij
      by (vector mat_def)
  }
  then have "det ?A = prod (\<lambda>i. ?f i i) ?U"
    using det_diagonal by blast
  also have "\<dots> = 1"
    unfolding th prod.neutral_const ..
  finally show ?thesis .
qed

lemma det_0: "det (mat 0 :: 'a::comm_ring_1^'n^'n) = 0"
  by (simp add: det_def prod_zero)

lemma det_permute_rows:
  fixes A :: "'a::comm_ring_1^'n^'n"
  assumes p: "p permutes (UNIV :: 'n::finite set)"
  shows "det (\<chi> i. A$p i :: 'a^'n^'n) = of_int (sign p) * det A"
  apply (simp add: det_def sum_distrib_left mult.assoc[symmetric])
  apply (subst sum_permutations_compose_right[OF p])
proof (rule sum.cong)
  let ?U = "UNIV :: 'n set"
  let ?PU = "{p. p permutes ?U}"
  fix q
  assume qPU: "q \<in> ?PU"
  have fU: "finite ?U"
    by simp
  from qPU have q: "q permutes ?U"
    by blast
  from p q have pp: "permutation p" and qp: "permutation q"
    by (metis fU permutation_permutes)+
  from permutes_inv[OF p] have ip: "inv p permutes ?U" .
  have "prod (\<lambda>i. A$p i$ (q \<circ> p) i) ?U = prod ((\<lambda>i. A$p i$(q \<circ> p) i) \<circ> inv p) ?U"
    by (simp only: prod_permute[OF ip, symmetric])
  also have "\<dots> = prod (\<lambda>i. A $ (p \<circ> inv p) i $ (q \<circ> (p \<circ> inv p)) i) ?U"
    by (simp only: o_def)
  also have "\<dots> = prod (\<lambda>i. A$i$q i) ?U"
    by (simp only: o_def permutes_inverses[OF p])
  finally have thp: "prod (\<lambda>i. A$p i$ (q \<circ> p) i) ?U = prod (\<lambda>i. A$i$q i) ?U"
    by blast
  show "of_int (sign (q \<circ> p)) * prod (\<lambda>i. A$ p i$ (q \<circ> p) i) ?U =
    of_int (sign p) * of_int (sign q) * prod (\<lambda>i. A$i$q i) ?U"
    by (simp only: thp sign_compose[OF qp pp] mult.commute of_int_mult)
qed rule

lemma det_permute_columns:
  fixes A :: "'a::comm_ring_1^'n^'n"
  assumes p: "p permutes (UNIV :: 'n set)"
  shows "det(\<chi> i j. A$i$ p j :: 'a^'n^'n) = of_int (sign p) * det A"
proof -
  let ?Ap = "\<chi> i j. A$i$ p j :: 'a^'n^'n"
  let ?At = "transpose A"
  have "of_int (sign p) * det A = det (transpose (\<chi> i. transpose A $ p i))"
    unfolding det_permute_rows[OF p, of ?At] det_transpose ..
  moreover
  have "?Ap = transpose (\<chi> i. transpose A $ p i)"
    by (simp add: transpose_def vec_eq_iff)
  ultimately show ?thesis
    by simp
qed

lemma det_identical_rows:
  fixes A :: "'a::linordered_idom^'n^'n"
  assumes ij: "i \<noteq> j"
    and r: "row i A = row j A"
  shows "det A = 0"
proof-
  have tha: "\<And>(a::'a) b. a = b \<Longrightarrow> b = - a \<Longrightarrow> a = 0"
    by simp
  have th1: "of_int (-1) = - 1" by simp
  let ?p = "Fun.swap i j id"
  let ?A = "\<chi> i. A $ ?p i"
  from r have "A = ?A" by (simp add: vec_eq_iff row_def Fun.swap_def)
  then have "det A = det ?A" by simp
  moreover have "det A = - det ?A"
    by (simp add: det_permute_rows[OF permutes_swap_id] sign_swap_id ij th1)
  ultimately show "det A = 0" by (metis tha)
qed

lemma det_identical_columns:
  fixes A :: "'a::linordered_idom^'n^'n"
  assumes ij: "i \<noteq> j"
    and r: "column i A = column j A"
  shows "det A = 0"
  apply (subst det_transpose[symmetric])
  apply (rule det_identical_rows[OF ij])
  apply (metis row_transpose r)
  done

lemma det_zero_row:
  fixes A :: "'a::{idom, ring_char_0}^'n^'n"
  assumes r: "row i A = 0"
  shows "det A = 0"
  using r
  apply (simp add: row_def det_def vec_eq_iff)
  apply (rule sum.neutral)
  apply (auto simp: sign_nz)
  done

lemma det_zero_column:
  fixes A :: "'a::{idom,ring_char_0}^'n^'n"
  assumes r: "column i A = 0"
  shows "det A = 0"
  apply (subst det_transpose[symmetric])
  apply (rule det_zero_row [of i])
  apply (metis row_transpose r)
  done

lemma det_row_add:
  fixes a b c :: "'n::finite \<Rightarrow> _ ^ 'n"
  shows "det((\<chi> i. if i = k then a i + b i else c i)::'a::comm_ring_1^'n^'n) =
    det((\<chi> i. if i = k then a i else c i)::'a::comm_ring_1^'n^'n) +
    det((\<chi> i. if i = k then b i else c i)::'a::comm_ring_1^'n^'n)"
  unfolding det_def vec_lambda_beta sum.distrib[symmetric]
proof (rule sum.cong)
  let ?U = "UNIV :: 'n set"
  let ?pU = "{p. p permutes ?U}"
  let ?f = "(\<lambda>i. if i = k then a i + b i else c i)::'n \<Rightarrow> 'a::comm_ring_1^'n"
  let ?g = "(\<lambda> i. if i = k then a i else c i)::'n \<Rightarrow> 'a::comm_ring_1^'n"
  let ?h = "(\<lambda> i. if i = k then b i else c i)::'n \<Rightarrow> 'a::comm_ring_1^'n"
  fix p
  assume p: "p \<in> ?pU"
  let ?Uk = "?U - {k}"
  from p have pU: "p permutes ?U"
    by blast
  have kU: "?U = insert k ?Uk"
    by blast
  {
    fix j
    assume j: "j \<in> ?Uk"
    from j have "?f j $ p j = ?g j $ p j" and "?f j $ p j= ?h j $ p j"
      by simp_all
  }
  then have th1: "prod (\<lambda>i. ?f i $ p i) ?Uk = prod (\<lambda>i. ?g i $ p i) ?Uk"
    and th2: "prod (\<lambda>i. ?f i $ p i) ?Uk = prod (\<lambda>i. ?h i $ p i) ?Uk"
    apply -
    apply (rule prod.cong, simp_all)+
    done
  have th3: "finite ?Uk" "k \<notin> ?Uk"
    by auto
  have "prod (\<lambda>i. ?f i $ p i) ?U = prod (\<lambda>i. ?f i $ p i) (insert k ?Uk)"
    unfolding kU[symmetric] ..
  also have "\<dots> = ?f k $ p k * prod (\<lambda>i. ?f i $ p i) ?Uk"
    apply (rule prod.insert)
    apply simp
    apply blast
    done
  also have "\<dots> = (a k $ p k * prod (\<lambda>i. ?f i $ p i) ?Uk) + (b k$ p k * prod (\<lambda>i. ?f i $ p i) ?Uk)"
    by (simp add: field_simps)
  also have "\<dots> = (a k $ p k * prod (\<lambda>i. ?g i $ p i) ?Uk) + (b k$ p k * prod (\<lambda>i. ?h i $ p i) ?Uk)"
    by (metis th1 th2)
  also have "\<dots> = prod (\<lambda>i. ?g i $ p i) (insert k ?Uk) + prod (\<lambda>i. ?h i $ p i) (insert k ?Uk)"
    unfolding  prod.insert[OF th3] by simp
  finally have "prod (\<lambda>i. ?f i $ p i) ?U = prod (\<lambda>i. ?g i $ p i) ?U + prod (\<lambda>i. ?h i $ p i) ?U"
    unfolding kU[symmetric] .
  then show "of_int (sign p) * prod (\<lambda>i. ?f i $ p i) ?U =
    of_int (sign p) * prod (\<lambda>i. ?g i $ p i) ?U + of_int (sign p) * prod (\<lambda>i. ?h i $ p i) ?U"
    by (simp add: field_simps)
qed rule

lemma det_row_mul:
  fixes a b :: "'n::finite \<Rightarrow> _ ^ 'n"
  shows "det((\<chi> i. if i = k then c *s a i else b i)::'a::comm_ring_1^'n^'n) =
    c * det((\<chi> i. if i = k then a i else b i)::'a::comm_ring_1^'n^'n)"
  unfolding det_def vec_lambda_beta sum_distrib_left
proof (rule sum.cong)
  let ?U = "UNIV :: 'n set"
  let ?pU = "{p. p permutes ?U}"
  let ?f = "(\<lambda>i. if i = k then c*s a i else b i)::'n \<Rightarrow> 'a::comm_ring_1^'n"
  let ?g = "(\<lambda> i. if i = k then a i else b i)::'n \<Rightarrow> 'a::comm_ring_1^'n"
  fix p
  assume p: "p \<in> ?pU"
  let ?Uk = "?U - {k}"
  from p have pU: "p permutes ?U"
    by blast
  have kU: "?U = insert k ?Uk"
    by blast
  {
    fix j
    assume j: "j \<in> ?Uk"
    from j have "?f j $ p j = ?g j $ p j"
      by simp
  }
  then have th1: "prod (\<lambda>i. ?f i $ p i) ?Uk = prod (\<lambda>i. ?g i $ p i) ?Uk"
    apply -
    apply (rule prod.cong)
    apply simp_all
    done
  have th3: "finite ?Uk" "k \<notin> ?Uk"
    by auto
  have "prod (\<lambda>i. ?f i $ p i) ?U = prod (\<lambda>i. ?f i $ p i) (insert k ?Uk)"
    unfolding kU[symmetric] ..
  also have "\<dots> = ?f k $ p k  * prod (\<lambda>i. ?f i $ p i) ?Uk"
    apply (rule prod.insert)
    apply simp
    apply blast
    done
  also have "\<dots> = (c*s a k) $ p k * prod (\<lambda>i. ?f i $ p i) ?Uk"
    by (simp add: field_simps)
  also have "\<dots> = c* (a k $ p k * prod (\<lambda>i. ?g i $ p i) ?Uk)"
    unfolding th1 by (simp add: ac_simps)
  also have "\<dots> = c* (prod (\<lambda>i. ?g i $ p i) (insert k ?Uk))"
    unfolding prod.insert[OF th3] by simp
  finally have "prod (\<lambda>i. ?f i $ p i) ?U = c* (prod (\<lambda>i. ?g i $ p i) ?U)"
    unfolding kU[symmetric] .
  then show "of_int (sign p) * prod (\<lambda>i. ?f i $ p i) ?U =
    c * (of_int (sign p) * prod (\<lambda>i. ?g i $ p i) ?U)"
    by (simp add: field_simps)
qed rule

lemma det_row_0:
  fixes b :: "'n::finite \<Rightarrow> _ ^ 'n"
  shows "det((\<chi> i. if i = k then 0 else b i)::'a::comm_ring_1^'n^'n) = 0"
  using det_row_mul[of k 0 "\<lambda>i. 1" b]
  apply simp
  apply (simp only: vector_smult_lzero)
  done

lemma det_row_operation:
  fixes A :: "'a::linordered_idom^'n^'n"
  assumes ij: "i \<noteq> j"
  shows "det (\<chi> k. if k = i then row i A + c *s row j A else row k A) = det A"
proof -
  let ?Z = "(\<chi> k. if k = i then row j A else row k A) :: 'a ^'n^'n"
  have th: "row i ?Z = row j ?Z" by (vector row_def)
  have th2: "((\<chi> k. if k = i then row i A else row k A) :: 'a^'n^'n) = A"
    by (vector row_def)
  show ?thesis
    unfolding det_row_add [of i] det_row_mul[of i] det_identical_rows[OF ij th] th2
    by simp
qed

lemma det_row_span:
  fixes A :: "real^'n^'n"
  assumes x: "x \<in> span {row j A |j. j \<noteq> i}"
  shows "det (\<chi> k. if k = i then row i A + x else row k A) = det A"
proof -
  let ?U = "UNIV :: 'n set"
  let ?S = "{row j A |j. j \<noteq> i}"
  let ?d = "\<lambda>x. det (\<chi> k. if k = i then x else row k A)"
  let ?P = "\<lambda>x. ?d (row i A + x) = det A"
  {
    fix k
    have "(if k = i then row i A + 0 else row k A) = row k A"
      by simp
  }
  then have P0: "?P 0"
    apply -
    apply (rule cong[of det, OF refl])
    apply (vector row_def)
    done
  moreover
  {
    fix c z y
    assume zS: "z \<in> ?S" and Py: "?P y"
    from zS obtain j where j: "z = row j A" "i \<noteq> j"
      by blast
    let ?w = "row i A + y"
    have th0: "row i A + (c*s z + y) = ?w + c*s z"
      by vector
    have thz: "?d z = 0"
      apply (rule det_identical_rows[OF j(2)])
      using j
      apply (vector row_def)
      done
    have "?d (row i A + (c*s z + y)) = ?d (?w + c*s z)"
      unfolding th0 ..
    then have "?P (c*s z + y)"
      unfolding thz Py det_row_mul[of i] det_row_add[of i]
      by simp
  }
  ultimately show ?thesis
    apply -
    apply (rule span_induct_alt[of ?P ?S, OF P0, folded scalar_mult_eq_scaleR])
    apply blast
    apply (rule x)
    done
qed

text \<open>
  May as well do this, though it's a bit unsatisfactory since it ignores
  exact duplicates by considering the rows/columns as a set.
\<close>

lemma det_dependent_rows:
  fixes A:: "real^'n^'n"
  assumes d: "dependent (rows A)"
  shows "det A = 0"
proof -
  let ?U = "UNIV :: 'n set"
  from d obtain i where i: "row i A \<in> span (rows A - {row i A})"
    unfolding dependent_def rows_def by blast
  {
    fix j k
    assume jk: "j \<noteq> k" and c: "row j A = row k A"
    from det_identical_rows[OF jk c] have ?thesis .
  }
  moreover
  {
    assume H: "\<And> i j. i \<noteq> j \<Longrightarrow> row i A \<noteq> row j A"
    have th0: "- row i A \<in> span {row j A|j. j \<noteq> i}"
      apply (rule span_neg)
      apply (rule set_rev_mp)
      apply (rule i)
      apply (rule span_mono)
      using H i
      apply (auto simp add: rows_def)
      done
    from det_row_span[OF th0]
    have "det A = det (\<chi> k. if k = i then 0 *s 1 else row k A)"
      unfolding right_minus vector_smult_lzero ..
    with det_row_mul[of i "0::real" "\<lambda>i. 1"]
    have "det A = 0" by simp
  }
  ultimately show ?thesis by blast
qed

lemma det_dependent_columns:
  assumes d: "dependent (columns (A::real^'n^'n))"
  shows "det A = 0"
  by (metis d det_dependent_rows rows_transpose det_transpose)

text \<open>Multilinearity and the multiplication formula.\<close>

lemma Cart_lambda_cong: "(\<And>x. f x = g x) \<Longrightarrow> (vec_lambda f::'a^'n) = (vec_lambda g :: 'a^'n)"
  by (rule iffD1[OF vec_lambda_unique]) vector

lemma det_linear_row_sum:
  assumes fS: "finite S"
  shows "det ((\<chi> i. if i = k then sum (a i) S else c i)::'a::comm_ring_1^'n^'n) =
    sum (\<lambda>j. det ((\<chi> i. if i = k then a  i j else c i)::'a^'n^'n)) S"
proof (induct rule: finite_induct[OF fS])
  case 1
  then show ?case
    apply simp
    unfolding sum.empty det_row_0[of k]
    apply rule
    done
next
  case (2 x F)
  then show ?case
    by (simp add: det_row_add cong del: if_weak_cong)
qed

lemma finite_bounded_functions:
  assumes fS: "finite S"
  shows "finite {f. (\<forall>i \<in> {1.. (k::nat)}. f i \<in> S) \<and> (\<forall>i. i \<notin> {1 .. k} \<longrightarrow> f i = i)}"
proof (induct k)
  case 0
  have th: "{f. \<forall>i. f i = i} = {id}"
    by auto
  show ?case
    by (auto simp add: th)
next
  case (Suc k)
  let ?f = "\<lambda>(y::nat,g) i. if i = Suc k then y else g i"
  let ?S = "?f ` (S \<times> {f. (\<forall>i\<in>{1..k}. f i \<in> S) \<and> (\<forall>i. i \<notin> {1..k} \<longrightarrow> f i = i)})"
  have "?S = {f. (\<forall>i\<in>{1.. Suc k}. f i \<in> S) \<and> (\<forall>i. i \<notin> {1.. Suc k} \<longrightarrow> f i = i)}"
    apply (auto simp add: image_iff)
    apply (rule_tac x="x (Suc k)" in bexI)
    apply (rule_tac x = "\<lambda>i. if i = Suc k then i else x i" in exI)
    apply auto
    done
  with finite_imageI[OF finite_cartesian_product[OF fS Suc.hyps(1)], of ?f]
  show ?case
    by metis
qed

lemma det_linear_rows_sum_lemma:
  assumes fS: "finite S"
    and fT: "finite T"
  shows "det ((\<chi> i. if i \<in> T then sum (a i) S else c i):: 'a::comm_ring_1^'n^'n) =
    sum (\<lambda>f. det((\<chi> i. if i \<in> T then a i (f i) else c i)::'a^'n^'n))
      {f. (\<forall>i \<in> T. f i \<in> S) \<and> (\<forall>i. i \<notin> T \<longrightarrow> f i = i)}"
  using fT
proof (induct T arbitrary: a c set: finite)
  case empty
  have th0: "\<And>x y. (\<chi> i. if i \<in> {} then x i else y i) = (\<chi> i. y i)"
    by vector
  from empty.prems show ?case
    unfolding th0 by (simp add: eq_id_iff)
next
  case (insert z T a c)
  let ?F = "\<lambda>T. {f. (\<forall>i \<in> T. f i \<in> S) \<and> (\<forall>i. i \<notin> T \<longrightarrow> f i = i)}"
  let ?h = "\<lambda>(y,g) i. if i = z then y else g i"
  let ?k = "\<lambda>h. (h(z),(\<lambda>i. if i = z then i else h i))"
  let ?s = "\<lambda> k a c f. det((\<chi> i. if i \<in> T then a i (f i) else c i)::'a^'n^'n)"
  let ?c = "\<lambda>j i. if i = z then a i j else c i"
  have thif: "\<And>a b c d. (if a \<or> b then c else d) = (if a then c else if b then c else d)"
    by simp
  have thif2: "\<And>a b c d e. (if a then b else if c then d else e) =
     (if c then (if a then b else d) else (if a then b else e))"
    by simp
  from \<open>z \<notin> T\<close> have nz: "\<And>i. i \<in> T \<Longrightarrow> i = z \<longleftrightarrow> False"
    by auto
  have "det (\<chi> i. if i \<in> insert z T then sum (a i) S else c i) =
    det (\<chi> i. if i = z then sum (a i) S else if i \<in> T then sum (a i) S else c i)"
    unfolding insert_iff thif ..
  also have "\<dots> = (\<Sum>j\<in>S. det (\<chi> i. if i \<in> T then sum (a i) S else if i = z then a i j else c i))"
    unfolding det_linear_row_sum[OF fS]
    apply (subst thif2)
    using nz
    apply (simp cong del: if_weak_cong cong add: if_cong)
    done
  finally have tha:
    "det (\<chi> i. if i \<in> insert z T then sum (a i) S else c i) =
     (\<Sum>(j, f)\<in>S \<times> ?F T. det (\<chi> i. if i \<in> T then a i (f i)
                                else if i = z then a i j
                                else c i))"
    unfolding insert.hyps unfolding sum.cartesian_product by blast
  show ?case unfolding tha
    using \<open>z \<notin> T\<close>
    by (intro sum.reindex_bij_witness[where i="?k" and j="?h"])
       (auto intro!: cong[OF refl[of det]] simp: vec_eq_iff)
qed

lemma det_linear_rows_sum:
  fixes S :: "'n::finite set"
  assumes fS: "finite S"
  shows "det (\<chi> i. sum (a i) S) =
    sum (\<lambda>f. det (\<chi> i. a i (f i) :: 'a::comm_ring_1 ^ 'n^'n)) {f. \<forall>i. f i \<in> S}"
proof -
  have th0: "\<And>x y. ((\<chi> i. if i \<in> (UNIV:: 'n set) then x i else y i) :: 'a^'n^'n) = (\<chi> i. x i)"
    by vector
  from det_linear_rows_sum_lemma[OF fS, of "UNIV :: 'n set" a, unfolded th0, OF finite]
  show ?thesis by simp
qed

lemma matrix_mul_sum_alt:
  fixes A B :: "'a::comm_ring_1^'n^'n"
  shows "A ** B = (\<chi> i. sum (\<lambda>k. A$i$k *s B $ k) (UNIV :: 'n set))"
  by (vector matrix_matrix_mult_def sum_component)

lemma det_mul:
  fixes A B :: "'a::linordered_idom^'n^'n"
  shows "det (A ** B) = det A * det B"
proof -
  let ?U = "UNIV :: 'n set"
  let ?F = "{f. (\<forall>i\<in> ?U. f i \<in> ?U) \<and> (\<forall>i. i \<notin> ?U \<longrightarrow> f i = i)}"
  let ?PU = "{p. p permutes ?U}"
  have fU: "finite ?U"
    by simp
  have fF: "finite ?F"
    by (rule finite)
  {
    fix p
    assume p: "p permutes ?U"
    have "p \<in> ?F" unfolding mem_Collect_eq permutes_in_image[OF p]
      using p[unfolded permutes_def] by simp
  }
  then have PUF: "?PU \<subseteq> ?F" by blast
  {
    fix f
    assume fPU: "f \<in> ?F - ?PU"
    have fUU: "f ` ?U \<subseteq> ?U"
      using fPU by auto
    from fPU have f: "\<forall>i \<in> ?U. f i \<in> ?U" "\<forall>i. i \<notin> ?U \<longrightarrow> f i = i" "\<not>(\<forall>y. \<exists>!x. f x = y)"
      unfolding permutes_def by auto

    let ?A = "(\<chi> i. A$i$f i *s B$f i) :: 'a^'n^'n"
    let ?B = "(\<chi> i. B$f i) :: 'a^'n^'n"
    {
      assume fni: "\<not> inj_on f ?U"
      then obtain i j where ij: "f i = f j" "i \<noteq> j"
        unfolding inj_on_def by blast
      from ij
      have rth: "row i ?B = row j ?B"
        by (vector row_def)
      from det_identical_rows[OF ij(2) rth]
      have "det (\<chi> i. A$i$f i *s B$f i) = 0"
        unfolding det_rows_mul by simp
    }
    moreover
    {
      assume fi: "inj_on f ?U"
      from f fi have fith: "\<And>i j. f i = f j \<Longrightarrow> i = j"
        unfolding inj_on_def by metis
      note fs = fi[unfolded surjective_iff_injective_gen[OF fU fU refl fUU, symmetric]]
      {
        fix y
        from fs f have "\<exists>x. f x = y"
          by blast
        then obtain x where x: "f x = y"
          by blast
        {
          fix z
          assume z: "f z = y"
          from fith x z have "z = x"
            by metis
        }
        with x have "\<exists>!x. f x = y"
          by blast
      }
      with f(3) have "det (\<chi> i. A$i$f i *s B$f i) = 0"
        by blast
    }
    ultimately have "det (\<chi> i. A$i$f i *s B$f i) = 0"
      by blast
  }
  then have zth: "\<forall> f\<in> ?F - ?PU. det (\<chi> i. A$i$f i *s B$f i) = 0"
    by simp
  {
    fix p
    assume pU: "p \<in> ?PU"
    from pU have p: "p permutes ?U"
      by blast
    let ?s = "\<lambda>p. of_int (sign p)"
    let ?f = "\<lambda>q. ?s p * (\<Prod>i\<in> ?U. A $ i $ p i) * (?s q * (\<Prod>i\<in> ?U. B $ i $ q i))"
    have "(sum (\<lambda>q. ?s q *
        (\<Prod>i\<in> ?U. (\<chi> i. A $ i $ p i *s B $ p i :: 'a^'n^'n) $ i $ q i)) ?PU) =
      (sum (\<lambda>q. ?s p * (\<Prod>i\<in> ?U. A $ i $ p i) * (?s q * (\<Prod>i\<in> ?U. B $ i $ q i))) ?PU)"
      unfolding sum_permutations_compose_right[OF permutes_inv[OF p], of ?f]
    proof (rule sum.cong)
      fix q
      assume qU: "q \<in> ?PU"
      then have q: "q permutes ?U"
        by blast
      from p q have pp: "permutation p" and pq: "permutation q"
        unfolding permutation_permutes by auto
      have th00: "of_int (sign p) * of_int (sign p) = (1::'a)"
        "\<And>a. of_int (sign p) * (of_int (sign p) * a) = a"
        unfolding mult.assoc[symmetric]
        unfolding of_int_mult[symmetric]
        by (simp_all add: sign_idempotent)
      have ths: "?s q = ?s p * ?s (q \<circ> inv p)"
        using pp pq permutation_inverse[OF pp] sign_inverse[OF pp]
        by (simp add:  th00 ac_simps sign_idempotent sign_compose)
      have th001: "prod (\<lambda>i. B$i$ q (inv p i)) ?U = prod ((\<lambda>i. B$i$ q (inv p i)) \<circ> p) ?U"
        by (rule prod_permute[OF p])
      have thp: "prod (\<lambda>i. (\<chi> i. A$i$p i *s B$p i :: 'a^'n^'n) $i $ q i) ?U =
        prod (\<lambda>i. A$i$p i) ?U * prod (\<lambda>i. B$i$ q (inv p i)) ?U"
        unfolding th001 prod.distrib[symmetric] o_def permutes_inverses[OF p]
        apply (rule prod.cong[OF refl])
        using permutes_in_image[OF q]
        apply vector
        done
      show "?s q * prod (\<lambda>i. (((\<chi> i. A$i$p i *s B$p i) :: 'a^'n^'n)$i$q i)) ?U =
        ?s p * (prod (\<lambda>i. A$i$p i) ?U) * (?s (q \<circ> inv p) * prod (\<lambda>i. B$i$(q \<circ> inv p) i) ?U)"
        using ths thp pp pq permutation_inverse[OF pp] sign_inverse[OF pp]
        by (simp add: sign_nz th00 field_simps sign_idempotent sign_compose)
    qed rule
  }
  then have th2: "sum (\<lambda>f. det (\<chi> i. A$i$f i *s B$f i)) ?PU = det A * det B"
    unfolding det_def sum_product
    by (rule sum.cong [OF refl])
  have "det (A**B) = sum (\<lambda>f.  det (\<chi> i. A $ i $ f i *s B $ f i)) ?F"
    unfolding matrix_mul_sum_alt det_linear_rows_sum[OF fU]
    by simp
  also have "\<dots> = sum (\<lambda>f. det (\<chi> i. A$i$f i *s B$f i)) ?PU"
    using sum.mono_neutral_cong_left[OF fF PUF zth, symmetric]
    unfolding det_rows_mul by auto
  finally show ?thesis unfolding th2 .
qed

text \<open>Relation to invertibility.\<close>

lemma invertible_left_inverse:
  fixes A :: "real^'n^'n"
  shows "invertible A \<longleftrightarrow> (\<exists>(B::real^'n^'n). B** A = mat 1)"
  by (metis invertible_def matrix_left_right_inverse)

lemma invertible_righ_inverse:
  fixes A :: "real^'n^'n"
  shows "invertible A \<longleftrightarrow> (\<exists>(B::real^'n^'n). A** B = mat 1)"
  by (metis invertible_def matrix_left_right_inverse)

lemma invertible_det_nz:
  fixes A::"real ^'n^'n"
  shows "invertible A \<longleftrightarrow> det A \<noteq> 0"
proof -
  {
    assume "invertible A"
    then obtain B :: "real ^'n^'n" where B: "A ** B = mat 1"
      unfolding invertible_righ_inverse by blast
    then have "det (A ** B) = det (mat 1 :: real ^'n^'n)"
      by simp
    then have "det A \<noteq> 0"
      by (simp add: det_mul det_I) algebra
  }
  moreover
  {
    assume H: "\<not> invertible A"
    let ?U = "UNIV :: 'n set"
    have fU: "finite ?U"
      by simp
    from H obtain c i where c: "sum (\<lambda>i. c i *s row i A) ?U = 0"
      and iU: "i \<in> ?U"
      and ci: "c i \<noteq> 0"
      unfolding invertible_righ_inverse
      unfolding matrix_right_invertible_independent_rows
      by blast
    have *: "\<And>(a::real^'n) b. a + b = 0 \<Longrightarrow> -a = b"
      apply (drule_tac f="op + (- a)" in cong[OF refl])
      apply (simp only: ab_left_minus add.assoc[symmetric])
      apply simp
      done
    from c ci
    have thr0: "- row i A = sum (\<lambda>j. (1/ c i) *s (c j *s row j A)) (?U - {i})"
      unfolding sum.remove[OF fU iU] sum_cmul
      apply -
      apply (rule vector_mul_lcancel_imp[OF ci])
      apply (auto simp add: field_simps)
      unfolding *
      apply rule
      done
    have thr: "- row i A \<in> span {row j A| j. j \<noteq> i}"
      unfolding thr0
      apply (rule span_sum)
      apply simp
      apply (rule span_mul [where 'a="real^'n", folded scalar_mult_eq_scaleR])+
      apply (rule span_superset)
      apply auto
      done
    let ?B = "(\<chi> k. if k = i then 0 else row k A) :: real ^'n^'n"
    have thrb: "row i ?B = 0" using iU by (vector row_def)
    have "det A = 0"
      unfolding det_row_span[OF thr, symmetric] right_minus
      unfolding det_zero_row[OF thrb] ..
  }
  ultimately show ?thesis
    by blast
qed

text \<open>Cramer's rule.\<close>

lemma cramer_lemma_transpose:
  fixes A:: "real^'n^'n"
    and x :: "real^'n"
  shows "det ((\<chi> i. if i = k then sum (\<lambda>i. x$i *s row i A) (UNIV::'n set)
                             else row i A)::real^'n^'n) = x$k * det A"
  (is "?lhs = ?rhs")
proof -
  let ?U = "UNIV :: 'n set"
  let ?Uk = "?U - {k}"
  have U: "?U = insert k ?Uk"
    by blast
  have fUk: "finite ?Uk"
    by simp
  have kUk: "k \<notin> ?Uk"
    by simp
  have th00: "\<And>k s. x$k *s row k A + s = (x$k - 1) *s row k A + row k A + s"
    by (vector field_simps)
  have th001: "\<And>f k . (\<lambda>x. if x = k then f k else f x) = f"
    by auto
  have "(\<chi> i. row i A) = A" by (vector row_def)
  then have thd1: "det (\<chi> i. row i A) = det A"
    by simp
  have thd0: "det (\<chi> i. if i = k then row k A + (\<Sum>i \<in> ?Uk. x $ i *s row i A) else row i A) = det A"
    apply (rule det_row_span)
    apply (rule span_sum)
    apply (rule span_mul [where 'a="real^'n", folded scalar_mult_eq_scaleR])+
    apply (rule span_superset)
    apply auto
    done
  show "?lhs = x$k * det A"
    apply (subst U)
    unfolding sum.insert[OF fUk kUk]
    apply (subst th00)
    unfolding add.assoc
    apply (subst det_row_add)
    unfolding thd0
    unfolding det_row_mul
    unfolding th001[of k "\<lambda>i. row i A"]
    unfolding thd1
    apply (simp add: field_simps)
    done
qed

lemma cramer_lemma:
  fixes A :: "real^'n^'n"
  shows "det((\<chi> i j. if j = k then (A *v x)$i else A$i$j):: real^'n^'n) = x$k * det A"
proof -
  let ?U = "UNIV :: 'n set"
  have *: "\<And>c. sum (\<lambda>i. c i *s row i (transpose A)) ?U = sum (\<lambda>i. c i *s column i A) ?U"
    by (auto simp add: row_transpose intro: sum.cong)
  show ?thesis
    unfolding matrix_mult_vsum
    unfolding cramer_lemma_transpose[of k x "transpose A", unfolded det_transpose, symmetric]
    unfolding *[of "\<lambda>i. x$i"]
    apply (subst det_transpose[symmetric])
    apply (rule cong[OF refl[of det]])
    apply (vector transpose_def column_def row_def)
    done
qed

lemma cramer:
  fixes A ::"real^'n^'n"
  assumes d0: "det A \<noteq> 0"
  shows "A *v x = b \<longleftrightarrow> x = (\<chi> k. det(\<chi> i j. if j=k then b$i else A$i$j) / det A)"
proof -
  from d0 obtain B where B: "A ** B = mat 1" "B ** A = mat 1"
    unfolding invertible_det_nz[symmetric] invertible_def
    by blast
  have "(A ** B) *v b = b"
    by (simp add: B matrix_vector_mul_lid)
  then have "A *v (B *v b) = b"
    by (simp add: matrix_vector_mul_assoc)
  then have xe: "\<exists>x. A *v x = b"
    by blast
  {
    fix x
    assume x: "A *v x = b"
    have "x = (\<chi> k. det(\<chi> i j. if j=k then b$i else A$i$j) / det A)"
      unfolding x[symmetric]
      using d0 by (simp add: vec_eq_iff cramer_lemma field_simps)
  }
  with xe show ?thesis
    by auto
qed

text \<open>Orthogonality of a transformation and matrix.\<close>

definition "orthogonal_transformation f \<longleftrightarrow> linear f \<and> (\<forall>v w. f v \<bullet> f w = v \<bullet> w)"

lemma orthogonal_transformation:
  "orthogonal_transformation f \<longleftrightarrow> linear f \<and> (\<forall>(v::real ^_). norm (f v) = norm v)"
  unfolding orthogonal_transformation_def
  apply auto
  apply (erule_tac x=v in allE)+
  apply (simp add: norm_eq_sqrt_inner)
  apply (simp add: dot_norm  linear_add[symmetric])
  done

definition "orthogonal_matrix (Q::'a::semiring_1^'n^'n) \<longleftrightarrow>
  transpose Q ** Q = mat 1 \<and> Q ** transpose Q = mat 1"

lemma orthogonal_matrix: "orthogonal_matrix (Q:: real ^'n^'n) \<longleftrightarrow> transpose Q ** Q = mat 1"
  by (metis matrix_left_right_inverse orthogonal_matrix_def)

lemma orthogonal_matrix_id: "orthogonal_matrix (mat 1 :: _^'n^'n)"
  by (simp add: orthogonal_matrix_def transpose_mat matrix_mul_lid)

lemma orthogonal_matrix_mul:
  fixes A :: "real ^'n^'n"
  assumes oA : "orthogonal_matrix A"
    and oB: "orthogonal_matrix B"
  shows "orthogonal_matrix(A ** B)"
  using oA oB
  unfolding orthogonal_matrix matrix_transpose_mul
  apply (subst matrix_mul_assoc)
  apply (subst matrix_mul_assoc[symmetric])
  apply (simp add: matrix_mul_rid)
  done

lemma orthogonal_transformation_matrix:
  fixes f:: "real^'n \<Rightarrow> real^'n"
  shows "orthogonal_transformation f \<longleftrightarrow> linear f \<and> orthogonal_matrix(matrix f)"
  (is "?lhs \<longleftrightarrow> ?rhs")
proof -
  let ?mf = "matrix f"
  let ?ot = "orthogonal_transformation f"
  let ?U = "UNIV :: 'n set"
  have fU: "finite ?U" by simp
  let ?m1 = "mat 1 :: real ^'n^'n"
  {
    assume ot: ?ot
    from ot have lf: "linear f" and fd: "\<forall>v w. f v \<bullet> f w = v \<bullet> w"
      unfolding  orthogonal_transformation_def orthogonal_matrix by blast+
    {
      fix i j
      let ?A = "transpose ?mf ** ?mf"
      have th0: "\<And>b (x::'a::comm_ring_1). (if b then 1 else 0)*x = (if b then x else 0)"
        "\<And>b (x::'a::comm_ring_1). x*(if b then 1 else 0) = (if b then x else 0)"
        by simp_all
      from fd[rule_format, of "axis i 1" "axis j 1",
        simplified matrix_works[OF lf, symmetric] dot_matrix_vector_mul]
      have "?A$i$j = ?m1 $ i $ j"
        by (simp add: inner_vec_def matrix_matrix_mult_def columnvector_def rowvector_def
            th0 sum.delta[OF fU] mat_def axis_def)
    }
    then have "orthogonal_matrix ?mf"
      unfolding orthogonal_matrix
      by vector
    with lf have ?rhs
      by blast
  }
  moreover
  {
    assume lf: "linear f" and om: "orthogonal_matrix ?mf"
    from lf om have ?lhs
      apply (simp only: orthogonal_matrix_def norm_eq orthogonal_transformation)
      apply (simp only: matrix_works[OF lf, symmetric])
      apply (subst dot_matrix_vector_mul)
      apply (simp add: dot_matrix_product matrix_mul_lid)
      done
  }
  ultimately show ?thesis
    by blast
qed

lemma det_orthogonal_matrix:
  fixes Q:: "'a::linordered_idom^'n^'n"
  assumes oQ: "orthogonal_matrix Q"
  shows "det Q = 1 \<or> det Q = - 1"
proof -
  have th: "\<And>x::'a. x = 1 \<or> x = - 1 \<longleftrightarrow> x*x = 1" (is "\<And>x::'a. ?ths x")
  proof -
    fix x:: 'a
    have th0: "x * x - 1 = (x - 1) * (x + 1)"
      by (simp add: field_simps)
    have th1: "\<And>(x::'a) y. x = - y \<longleftrightarrow> x + y = 0"
      apply (subst eq_iff_diff_eq_0)
      apply simp
      done
    have "x * x = 1 \<longleftrightarrow> x * x - 1 = 0"
      by simp
    also have "\<dots> \<longleftrightarrow> x = 1 \<or> x = - 1"
      unfolding th0 th1 by simp
    finally show "?ths x" ..
  qed
  from oQ have "Q ** transpose Q = mat 1"
    by (metis orthogonal_matrix_def)
  then have "det (Q ** transpose Q) = det (mat 1:: 'a^'n^'n)"
    by simp
  then have "det Q * det Q = 1"
    by (simp add: det_mul det_I det_transpose)
  then show ?thesis unfolding th .
qed

text \<open>Linearity of scaling, and hence isometry, that preserves origin.\<close>

lemma scaling_linear:
  fixes f :: "real ^'n \<Rightarrow> real ^'n"
  assumes f0: "f 0 = 0"
    and fd: "\<forall>x y. dist (f x) (f y) = c * dist x y"
  shows "linear f"
proof -
  {
    fix v w
    {
      fix x
      note fd[rule_format, of x 0, unfolded dist_norm f0 diff_0_right]
    }
    note th0 = this
    have "f v \<bullet> f w = c\<^sup>2 * (v \<bullet> w)"
      unfolding dot_norm_neg dist_norm[symmetric]
      unfolding th0 fd[rule_format] by (simp add: power2_eq_square field_simps)}
  note fc = this
  show ?thesis
    unfolding linear_iff vector_eq[where 'a="real^'n"] scalar_mult_eq_scaleR
    by (simp add: inner_add fc field_simps)
qed

lemma isometry_linear:
  "f (0:: real^'n) = (0:: real^'n) \<Longrightarrow> \<forall>x y. dist(f x) (f y) = dist x y \<Longrightarrow> linear f"
  by (rule scaling_linear[where c=1]) simp_all

text \<open>Hence another formulation of orthogonal transformation.\<close>

lemma orthogonal_transformation_isometry:
  "orthogonal_transformation f \<longleftrightarrow> f(0::real^'n) = (0::real^'n) \<and> (\<forall>x y. dist(f x) (f y) = dist x y)"
  unfolding orthogonal_transformation
  apply (rule iffI)
  apply clarify
  apply (clarsimp simp add: linear_0 linear_diff[symmetric] dist_norm)
  apply (rule conjI)
  apply (rule isometry_linear)
  apply simp
  apply simp
  apply clarify
  apply (erule_tac x=v in allE)
  apply (erule_tac x=0 in allE)
  apply (simp add: dist_norm)
  done

text \<open>Can extend an isometry from unit sphere.\<close>

lemma isometry_sphere_extend:
  fixes f:: "real ^'n \<Rightarrow> real ^'n"
  assumes f1: "\<forall>x. norm x = 1 \<longrightarrow> norm (f x) = 1"
    and fd1: "\<forall> x y. norm x = 1 \<longrightarrow> norm y = 1 \<longrightarrow> dist (f x) (f y) = dist x y"
  shows "\<exists>g. orthogonal_transformation g \<and> (\<forall>x. norm x = 1 \<longrightarrow> g x = f x)"
proof -
  {
    fix x y x' y' x0 y0 x0' y0' :: "real ^'n"
    assume H:
      "x = norm x *\<^sub>R x0"
      "y = norm y *\<^sub>R y0"
      "x' = norm x *\<^sub>R x0'" "y' = norm y *\<^sub>R y0'"
      "norm x0 = 1" "norm x0' = 1" "norm y0 = 1" "norm y0' = 1"
      "norm(x0' - y0') = norm(x0 - y0)"
    then have *: "x0 \<bullet> y0 = x0' \<bullet> y0' + y0' \<bullet> x0' - y0 \<bullet> x0 "
      by (simp add: norm_eq norm_eq_1 inner_add inner_diff)
    have "norm(x' - y') = norm(x - y)"
      apply (subst H(1))
      apply (subst H(2))
      apply (subst H(3))
      apply (subst H(4))
      using H(5-9)
      apply (simp add: norm_eq norm_eq_1)
      apply (simp add: inner_diff scalar_mult_eq_scaleR)
      unfolding *
      apply (simp add: field_simps)
      done
  }
  note th0 = this
  let ?g = "\<lambda>x. if x = 0 then 0 else norm x *\<^sub>R f (inverse (norm x) *\<^sub>R x)"
  {
    fix x:: "real ^'n"
    assume nx: "norm x = 1"
    have "?g x = f x"
      using nx by auto
  }
  then have thfg: "\<forall>x. norm x = 1 \<longrightarrow> ?g x = f x"
    by blast
  have g0: "?g 0 = 0"
    by simp
  {
    fix x y :: "real ^'n"
    {
      assume "x = 0" "y = 0"
      then have "dist (?g x) (?g y) = dist x y"
        by simp
    }
    moreover
    {
      assume "x = 0" "y \<noteq> 0"
      then have "dist (?g x) (?g y) = dist x y"
        apply (simp add: dist_norm)
        apply (rule f1[rule_format])
        apply (simp add: field_simps)
        done
    }
    moreover
    {
      assume "x \<noteq> 0" "y = 0"
      then have "dist (?g x) (?g y) = dist x y"
        apply (simp add: dist_norm)
        apply (rule f1[rule_format])
        apply (simp add: field_simps)
        done
    }
    moreover
    {
      assume z: "x \<noteq> 0" "y \<noteq> 0"
      have th00:
        "x = norm x *\<^sub>R (inverse (norm x) *\<^sub>R x)"
        "y = norm y *\<^sub>R (inverse (norm y) *\<^sub>R y)"
        "norm x *\<^sub>R f ((inverse (norm x) *\<^sub>R x)) = norm x *\<^sub>R f (inverse (norm x) *\<^sub>R x)"
        "norm y *\<^sub>R f (inverse (norm y) *\<^sub>R y) = norm y *\<^sub>R f (inverse (norm y) *\<^sub>R y)"
        "norm (inverse (norm x) *\<^sub>R x) = 1"
        "norm (f (inverse (norm x) *\<^sub>R x)) = 1"
        "norm (inverse (norm y) *\<^sub>R y) = 1"
        "norm (f (inverse (norm y) *\<^sub>R y)) = 1"
        "norm (f (inverse (norm x) *\<^sub>R x) - f (inverse (norm y) *\<^sub>R y)) =
          norm (inverse (norm x) *\<^sub>R x - inverse (norm y) *\<^sub>R y)"
        using z
        by (auto simp add: field_simps intro: f1[rule_format] fd1[rule_format, unfolded dist_norm])
      from z th0[OF th00] have "dist (?g x) (?g y) = dist x y"
        by (simp add: dist_norm)
    }
    ultimately have "dist (?g x) (?g y) = dist x y"
      by blast
  }
  note thd = this
    show ?thesis
    apply (rule exI[where x= ?g])
    unfolding orthogonal_transformation_isometry
    using g0 thfg thd
    apply metis
    done
qed

text \<open>Rotation, reflection, rotoinversion.\<close>

definition "rotation_matrix Q \<longleftrightarrow> orthogonal_matrix Q \<and> det Q = 1"
definition "rotoinversion_matrix Q \<longleftrightarrow> orthogonal_matrix Q \<and> det Q = - 1"

lemma orthogonal_rotation_or_rotoinversion:
  fixes Q :: "'a::linordered_idom^'n^'n"
  shows " orthogonal_matrix Q \<longleftrightarrow> rotation_matrix Q \<or> rotoinversion_matrix Q"
  by (metis rotoinversion_matrix_def rotation_matrix_def det_orthogonal_matrix)

text \<open>Explicit formulas for low dimensions.\<close>

lemma prod_neutral_const: "prod f {(1::nat)..1} = f 1"
  by simp

lemma prod_2: "prod f {(1::nat)..2} = f 1 * f 2"
  by (simp add: eval_nat_numeral atLeastAtMostSuc_conv mult.commute)

lemma prod_3: "prod f {(1::nat)..3} = f 1 * f 2 * f 3"
  by (simp add: eval_nat_numeral atLeastAtMostSuc_conv mult.commute)

lemma det_1: "det (A::'a::comm_ring_1^1^1) = A$1$1"
  by (simp add: det_def of_nat_Suc sign_id)

lemma det_2: "det (A::'a::comm_ring_1^2^2) = A$1$1 * A$2$2 - A$1$2 * A$2$1"
proof -
  have f12: "finite {2::2}" "1 \<notin> {2::2}" by auto
  show ?thesis
    unfolding det_def UNIV_2
    unfolding sum_over_permutations_insert[OF f12]
    unfolding permutes_sing
    by (simp add: sign_swap_id sign_id swap_id_eq)
qed

lemma det_3:
  "det (A::'a::comm_ring_1^3^3) =
    A$1$1 * A$2$2 * A$3$3 +
    A$1$2 * A$2$3 * A$3$1 +
    A$1$3 * A$2$1 * A$3$2 -
    A$1$1 * A$2$3 * A$3$2 -
    A$1$2 * A$2$1 * A$3$3 -
    A$1$3 * A$2$2 * A$3$1"
proof -
  have f123: "finite {2::3, 3}" "1 \<notin> {2::3, 3}"
    by auto
  have f23: "finite {3::3}" "2 \<notin> {3::3}"
    by auto

  show ?thesis
    unfolding det_def UNIV_3
    unfolding sum_over_permutations_insert[OF f123]
    unfolding sum_over_permutations_insert[OF f23]
    unfolding permutes_sing
    by (simp add: sign_swap_id permutation_swap_id sign_compose sign_id swap_id_eq)
qed

end


(*  Title:      HOL/Fun.thy
    Author:     Tobias Nipkow, Cambridge University Computer Laboratory
    Author:     Andrei Popescu, TU Muenchen
    Copyright   1994, 2012
*)

section {* Notions about functions *}

theory Fun
imports Set
keywords "functor" :: thy_goal
begin

lemma apply_inverse:
  "f x = u \<Longrightarrow> (\<And>x. P x \<Longrightarrow> g (f x) = x) \<Longrightarrow> P x \<Longrightarrow> x = g u"
  by auto

subsection {* The Identity Function @{text id} *}

definition id :: "'a \<Rightarrow> 'a" where
  "id = (\<lambda>x. x)"

lemma id_apply [simp]: "id x = x"
  by (simp add: id_def)

lemma image_id [simp]: "image id = id"
  by (simp add: id_def fun_eq_iff)

lemma vimage_id [simp]: "vimage id = id"
  by (simp add: id_def fun_eq_iff)

code_printing
  constant id \<rightharpoonup> (Haskell) "id"

subsection {* The Composition Operator @{text "f \<circ> g"} *}

definition comp :: "('b \<Rightarrow> 'c) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'c" (infixl "o" 55) where
  "f o g = (\<lambda>x. f (g x))"

notation (xsymbols)
  comp  (infixl "\<circ>" 55)

notation (HTML output)
  comp  (infixl "\<circ>" 55)

lemma comp_apply [simp]: "(f o g) x = f (g x)"
  by (simp add: comp_def)

lemma comp_assoc: "(f o g) o h = f o (g o h)"
  by (simp add: fun_eq_iff)

lemma id_comp [simp]: "id o g = g"
  by (simp add: fun_eq_iff)

lemma comp_id [simp]: "f o id = f"
  by (simp add: fun_eq_iff)

lemma comp_eq_dest:
  "a o b = c o d \<Longrightarrow> a (b v) = c (d v)"
  by (simp add: fun_eq_iff)

lemma comp_eq_elim:
  "a o b = c o d \<Longrightarrow> ((\<And>v. a (b v) = c (d v)) \<Longrightarrow> R) \<Longrightarrow> R"
  by (simp add: fun_eq_iff)

lemma comp_eq_dest_lhs: "a o b = c \<Longrightarrow> a (b v) = c v"
  by clarsimp

lemma comp_eq_id_dest: "a o b = id o c \<Longrightarrow> a (b v) = c v"
  by clarsimp

lemma image_comp:
  "f ` (g ` r) = (f o g) ` r"
  by auto

lemma vimage_comp:
  "f -` (g -` x) = (g \<circ> f) -` x"
  by auto

code_printing
  constant comp \<rightharpoonup> (SML) infixl 5 "o" and (Haskell) infixr 9 "."

subsection {* The Forward Composition Operator @{text fcomp} *}

definition fcomp :: "('a \<Rightarrow> 'b) \<Rightarrow> ('b \<Rightarrow> 'c) \<Rightarrow> 'a \<Rightarrow> 'c" (infixl "\<circ>>" 60) where
  "f \<circ>> g = (\<lambda>x. g (f x))"

lemma fcomp_apply [simp]:  "(f \<circ>> g) x = g (f x)"
  by (simp add: fcomp_def)

lemma fcomp_assoc: "(f \<circ>> g) \<circ>> h = f \<circ>> (g \<circ>> h)"
  by (simp add: fcomp_def)

lemma id_fcomp [simp]: "id \<circ>> g = g"
  by (simp add: fcomp_def)

lemma fcomp_id [simp]: "f \<circ>> id = f"
  by (simp add: fcomp_def)

code_printing
  constant fcomp \<rightharpoonup> (Eval) infixl 1 "#>"

no_notation fcomp (infixl "\<circ>>" 60)

subsection {* Mapping functions *}

definition map_fun :: "('c \<Rightarrow> 'a) \<Rightarrow> ('b \<Rightarrow> 'd) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'c \<Rightarrow> 'd" where
  "map_fun f g h = g \<circ> h \<circ> f"

lemma map_fun_apply [simp]:
  "map_fun f g h x = g (h (f x))"
  by (simp add: map_fun_def)

subsection {* Injectivity and Bijectivity *}

definition inj_on :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a set \<Rightarrow> bool" where -- "injective"
  "inj_on f A \<longleftrightarrow> (\<forall>x\<in>A. \<forall>y\<in>A. f x = f y \<longrightarrow> x = y)"

definition bij_betw :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a set \<Rightarrow> 'b set \<Rightarrow> bool" where -- "bijective"
  "bij_betw f A B \<longleftrightarrow> inj_on f A \<and> f ` A = B"

text{*A common special case: functions injective, surjective or bijective over
the entire domain type.*}

abbreviation
  "inj f \<equiv> inj_on f UNIV"

abbreviation surj :: "('a \<Rightarrow> 'b) \<Rightarrow> bool" where -- "surjective"
  "surj f \<equiv> (range f = UNIV)"

abbreviation
  "bij f \<equiv> bij_betw f UNIV UNIV"

text{* The negated case: *}
translations
"\<not> CONST surj f" <= "CONST range f \<noteq> CONST UNIV"

lemma injI:
  assumes "\<And>x y. f x = f y \<Longrightarrow> x = y"
  shows "inj f"
  using assms unfolding inj_on_def by auto

theorem range_ex1_eq: "inj f \<Longrightarrow> b : range f = (EX! x. b = f x)"
  by (unfold inj_on_def, blast)

lemma injD: "[| inj(f); f(x) = f(y) |] ==> x=y"
by (simp add: inj_on_def)

lemma inj_on_eq_iff: "inj_on f A ==> x:A ==> y:A ==> (f(x) = f(y)) = (x=y)"
by (force simp add: inj_on_def)

lemma inj_on_cong:
  "(\<And> a. a : A \<Longrightarrow> f a = g a) \<Longrightarrow> inj_on f A = inj_on g A"
unfolding inj_on_def by auto

lemma inj_on_strict_subset:
  "inj_on f B \<Longrightarrow> A \<subset> B \<Longrightarrow> f ` A \<subset> f ` B"
  unfolding inj_on_def by blast

lemma inj_comp:
  "inj f \<Longrightarrow> inj g \<Longrightarrow> inj (f \<circ> g)"
  by (simp add: inj_on_def)

lemma inj_fun: "inj f \<Longrightarrow> inj (\<lambda>x y. f x)"
  by (simp add: inj_on_def fun_eq_iff)

lemma inj_eq: "inj f ==> (f(x) = f(y)) = (x=y)"
by (simp add: inj_on_eq_iff)

lemma inj_on_id[simp]: "inj_on id A"
  by (simp add: inj_on_def)

lemma inj_on_id2[simp]: "inj_on (%x. x) A"
by (simp add: inj_on_def)

lemma inj_on_Int: "inj_on f A \<or> inj_on f B \<Longrightarrow> inj_on f (A \<inter> B)"
unfolding inj_on_def by blast

lemma surj_id: "surj id"
by simp

lemma bij_id[simp]: "bij id"
by (simp add: bij_betw_def)

lemma inj_onI:
    "(!! x y. [|  x:A;  y:A;  f(x) = f(y) |] ==> x=y) ==> inj_on f A"
by (simp add: inj_on_def)

lemma inj_on_inverseI: "(!!x. x:A ==> g(f(x)) = x) ==> inj_on f A"
by (auto dest:  arg_cong [of concl: g] simp add: inj_on_def)

lemma inj_onD: "[| inj_on f A;  f(x)=f(y);  x:A;  y:A |] ==> x=y"
by (unfold inj_on_def, blast)

lemma inj_on_iff: "[| inj_on f A;  x:A;  y:A |] ==> (f(x)=f(y)) = (x=y)"
  by (fact inj_on_eq_iff)

lemma comp_inj_on:
     "[| inj_on f A;  inj_on g (f`A) |] ==> inj_on (g o f) A"
by (simp add: comp_def inj_on_def)

lemma inj_on_imageI: "inj_on (g o f) A \<Longrightarrow> inj_on g (f ` A)"
  by (simp add: inj_on_def) blast

lemma inj_on_image_iff: "\<lbrakk> ALL x:A. ALL y:A. (g(f x) = g(f y)) = (g x = g y);
  inj_on f A \<rbrakk> \<Longrightarrow> inj_on g (f ` A) = inj_on g A"
apply(unfold inj_on_def)
apply blast
done

lemma inj_on_contraD: "[| inj_on f A;  ~x=y;  x:A;  y:A |] ==> ~ f(x)=f(y)"
by (unfold inj_on_def, blast)

lemma inj_singleton: "inj (%s. {s})"
by (simp add: inj_on_def)

lemma inj_on_empty[iff]: "inj_on f {}"
by(simp add: inj_on_def)

lemma subset_inj_on: "[| inj_on f B; A <= B |] ==> inj_on f A"
by (unfold inj_on_def, blast)

lemma inj_on_Un:
 "inj_on f (A Un B) =
  (inj_on f A & inj_on f B & f`(A-B) Int f`(B-A) = {})"
apply(unfold inj_on_def)
apply (blast intro:sym)
done

lemma inj_on_insert[iff]:
  "inj_on f (insert a A) = (inj_on f A & f a ~: f`(A-{a}))"
apply(unfold inj_on_def)
apply (blast intro:sym)
done

lemma inj_on_diff: "inj_on f A ==> inj_on f (A-B)"
apply(unfold inj_on_def)
apply (blast)
done

lemma comp_inj_on_iff:
  "inj_on f A \<Longrightarrow> inj_on f' (f ` A) \<longleftrightarrow> inj_on (f' o f) A"
by(auto simp add: comp_inj_on inj_on_def)

lemma inj_on_imageI2:
  "inj_on (f' o f) A \<Longrightarrow> inj_on f A"
by(auto simp add: comp_inj_on inj_on_def)

lemma inj_img_insertE:
  assumes "inj_on f A"
  assumes "x \<notin> B" and "insert x B = f ` A"
  obtains x' A' where "x' \<notin> A'" and "A = insert x' A'"
    and "x = f x'" and "B = f ` A'"
proof -
  from assms have "x \<in> f ` A" by auto
  then obtain x' where *: "x' \<in> A" "x = f x'" by auto
  then have "A = insert x' (A - {x'})" by auto
  with assms * have "B = f ` (A - {x'})"
    by (auto dest: inj_on_contraD)
  have "x' \<notin> A - {x'}" by simp
  from `x' \<notin> A - {x'}` `A = insert x' (A - {x'})` `x = f x'` `B = image f (A - {x'})`
  show ?thesis ..
qed

lemma linorder_injI:
  assumes hyp: "\<And>x y. x < (y::'a::linorder) \<Longrightarrow> f x \<noteq> f y"
  shows "inj f"
  -- {* Courtesy of Stephan Merz *}
proof (rule inj_onI)
  fix x y
  assume f_eq: "f x = f y"
  show "x = y" by (rule linorder_cases) (auto dest: hyp simp: f_eq)
qed

lemma surj_def: "surj f \<longleftrightarrow> (\<forall>y. \<exists>x. y = f x)"
  by auto

lemma surjI: assumes *: "\<And> x. g (f x) = x" shows "surj g"
  using *[symmetric] by auto

lemma surjD: "surj f \<Longrightarrow> \<exists>x. y = f x"
  by (simp add: surj_def)

lemma surjE: "surj f \<Longrightarrow> (\<And>x. y = f x \<Longrightarrow> C) \<Longrightarrow> C"
  by (simp add: surj_def, blast)

lemma comp_surj: "[| surj f;  surj g |] ==> surj (g o f)"
apply (simp add: comp_def surj_def, clarify)
apply (drule_tac x = y in spec, clarify)
apply (drule_tac x = x in spec, blast)
done

lemma bij_betw_imageI:
  "\<lbrakk> inj_on f A; f ` A = B \<rbrakk> \<Longrightarrow> bij_betw f A B"
unfolding bij_betw_def by clarify

lemma bij_betw_imp_surj_on: "bij_betw f A B \<Longrightarrow> f ` A = B"
  unfolding bij_betw_def by clarify

lemma bij_betw_imp_surj: "bij_betw f A UNIV \<Longrightarrow> surj f"
  unfolding bij_betw_def by auto

lemma bij_betw_empty1:
  assumes "bij_betw f {} A"
  shows "A = {}"
using assms unfolding bij_betw_def by blast

lemma bij_betw_empty2:
  assumes "bij_betw f A {}"
  shows "A = {}"
using assms unfolding bij_betw_def by blast

lemma inj_on_imp_bij_betw:
  "inj_on f A \<Longrightarrow> bij_betw f A (f ` A)"
unfolding bij_betw_def by simp

lemma bij_def: "bij f \<longleftrightarrow> inj f \<and> surj f"
  unfolding bij_betw_def ..

lemma bijI: "[| inj f; surj f |] ==> bij f"
by (simp add: bij_def)

lemma bij_is_inj: "bij f ==> inj f"
by (simp add: bij_def)

lemma bij_is_surj: "bij f ==> surj f"
by (simp add: bij_def)

lemma bij_betw_imp_inj_on: "bij_betw f A B \<Longrightarrow> inj_on f A"
by (simp add: bij_betw_def)

lemma bij_betw_trans:
  "bij_betw f A B \<Longrightarrow> bij_betw g B C \<Longrightarrow> bij_betw (g o f) A C"
by(auto simp add:bij_betw_def comp_inj_on)

lemma bij_comp: "bij f \<Longrightarrow> bij g \<Longrightarrow> bij (g o f)"
  by (rule bij_betw_trans)

lemma bij_betw_comp_iff:
  "bij_betw f A A' \<Longrightarrow> bij_betw f' A' A'' \<longleftrightarrow> bij_betw (f' o f) A A''"
by(auto simp add: bij_betw_def inj_on_def)

lemma bij_betw_comp_iff2:
  assumes BIJ: "bij_betw f' A' A''" and IM: "f ` A \<le> A'"
  shows "bij_betw f A A' \<longleftrightarrow> bij_betw (f' o f) A A''"
using assms
proof(auto simp add: bij_betw_comp_iff)
  assume *: "bij_betw (f' \<circ> f) A A''"
  thus "bij_betw f A A'"
  using IM
  proof(auto simp add: bij_betw_def)
    assume "inj_on (f' \<circ> f) A"
    thus "inj_on f A" using inj_on_imageI2 by blast
  next
    fix a' assume **: "a' \<in> A'"
    hence "f' a' \<in> A''" using BIJ unfolding bij_betw_def by auto
    then obtain a where 1: "a \<in> A \<and> f'(f a) = f' a'" using *
    unfolding bij_betw_def by force
    hence "f a \<in> A'" using IM by auto
    hence "f a = a'" using BIJ ** 1 unfolding bij_betw_def inj_on_def by auto
    thus "a' \<in> f ` A" using 1 by auto
  qed
qed

lemma bij_betw_inv: assumes "bij_betw f A B" shows "EX g. bij_betw g B A"
proof -
  have i: "inj_on f A" and s: "f ` A = B"
    using assms by(auto simp:bij_betw_def)
  let ?P = "%b a. a:A \<and> f a = b" let ?g = "%b. The (?P b)"
  { fix a b assume P: "?P b a"
    hence ex1: "\<exists>a. ?P b a" using s by blast
    hence uex1: "\<exists>!a. ?P b a" by(blast dest:inj_onD[OF i])
    hence " ?g b = a" using the1_equality[OF uex1, OF P] P by simp
  } note g = this
  have "inj_on ?g B"
  proof(rule inj_onI)
    fix x y assume "x:B" "y:B" "?g x = ?g y"
    from s `x:B` obtain a1 where a1: "?P x a1" by blast
    from s `y:B` obtain a2 where a2: "?P y a2" by blast
    from g[OF a1] a1 g[OF a2] a2 `?g x = ?g y` show "x=y" by simp
  qed
  moreover have "?g ` B = A"
  proof(auto simp: image_def)
    fix b assume "b:B"
    with s obtain a where P: "?P b a" by blast
    thus "?g b \<in> A" using g[OF P] by auto
  next
    fix a assume "a:A"
    then obtain b where P: "?P b a" using s by blast
    then have "b:B" using s by blast
    with g[OF P] show "\<exists>b\<in>B. a = ?g b" by blast
  qed
  ultimately show ?thesis by(auto simp:bij_betw_def)
qed

lemma bij_betw_cong:
  "(\<And> a. a \<in> A \<Longrightarrow> f a = g a) \<Longrightarrow> bij_betw f A A' = bij_betw g A A'"
unfolding bij_betw_def inj_on_def by force

lemma bij_betw_id[intro, simp]:
  "bij_betw id A A"
unfolding bij_betw_def id_def by auto

lemma bij_betw_id_iff:
  "bij_betw id A B \<longleftrightarrow> A = B"
by(auto simp add: bij_betw_def)

lemma bij_betw_combine:
  assumes "bij_betw f A B" "bij_betw f C D" "B \<inter> D = {}"
  shows "bij_betw f (A \<union> C) (B \<union> D)"
  using assms unfolding bij_betw_def inj_on_Un image_Un by auto

lemma bij_betw_subset:
  assumes BIJ: "bij_betw f A A'" and
          SUB: "B \<le> A" and IM: "f ` B = B'"
  shows "bij_betw f B B'"
using assms
by(unfold bij_betw_def inj_on_def, auto simp add: inj_on_def)

lemma bij_pointE:
  assumes "bij f"
  obtains x where "y = f x" and "\<And>x'. y = f x' \<Longrightarrow> x' = x"
proof -
  from assms have "inj f" by (rule bij_is_inj)
  moreover from assms have "surj f" by (rule bij_is_surj)
  then have "y \<in> range f" by simp
  ultimately have "\<exists>!x. y = f x" by (simp add: range_ex1_eq)
  with that show thesis by blast
qed

lemma surj_image_vimage_eq: "surj f ==> f ` (f -` A) = A"
by simp

lemma surj_vimage_empty:
  assumes "surj f" shows "f -` A = {} \<longleftrightarrow> A = {}"
  using surj_image_vimage_eq[OF `surj f`, of A]
  by (intro iffI) fastforce+

lemma inj_vimage_image_eq: "inj f ==> f -` (f ` A) = A"
by (simp add: inj_on_def, blast)

lemma vimage_subsetD: "surj f ==> f -` B <= A ==> B <= f ` A"
by (blast intro: sym)

lemma vimage_subsetI: "inj f ==> B <= f ` A ==> f -` B <= A"
by (unfold inj_on_def, blast)

lemma vimage_subset_eq: "bij f ==> (f -` B <= A) = (B <= f ` A)"
apply (unfold bij_def)
apply (blast del: subsetI intro: vimage_subsetI vimage_subsetD)
done

lemma inj_on_image_eq_iff: "\<lbrakk> inj_on f C; A \<subseteq> C; B \<subseteq> C \<rbrakk> \<Longrightarrow> f ` A = f ` B \<longleftrightarrow> A = B"
by(fastforce simp add: inj_on_def)

lemma inj_on_Un_image_eq_iff: "inj_on f (A \<union> B) \<Longrightarrow> f ` A = f ` B \<longleftrightarrow> A = B"
by(erule inj_on_image_eq_iff) simp_all

lemma inj_on_image_Int:
   "[| inj_on f C;  A<=C;  B<=C |] ==> f`(A Int B) = f`A Int f`B"
apply (simp add: inj_on_def, blast)
done

lemma inj_on_image_set_diff:
   "[| inj_on f C;  A<=C;  B<=C |] ==> f`(A-B) = f`A - f`B"
apply (simp add: inj_on_def, blast)
done

lemma image_Int: "inj f ==> f`(A Int B) = f`A Int f`B"
by (simp add: inj_on_def, blast)

lemma image_set_diff: "inj f ==> f`(A-B) = f`A - f`B"
by (simp add: inj_on_def, blast)

lemma inj_image_mem_iff: "inj f ==> (f a : f`A) = (a : A)"
by (blast dest: injD)

lemma inj_image_subset_iff: "inj f ==> (f`A <= f`B) = (A<=B)"
by (simp add: inj_on_def, blast)

lemma inj_image_eq_iff: "inj f ==> (f`A = f`B) = (A = B)"
by (blast dest: injD)

lemma surj_Compl_image_subset: "surj f ==> -(f`A) <= f`(-A)"
by auto

lemma inj_image_Compl_subset: "inj f ==> f`(-A) <= -(f`A)"
by (auto simp add: inj_on_def)

lemma bij_image_Compl_eq: "bij f ==> f`(-A) = -(f`A)"
apply (simp add: bij_def)
apply (rule equalityI)
apply (simp_all (no_asm_simp) add: inj_image_Compl_subset surj_Compl_image_subset)
done

lemma inj_vimage_singleton: "inj f \<Longrightarrow> f -` {a} \<subseteq> {THE x. f x = a}"
  -- {* The inverse image of a singleton under an injective function
         is included in a singleton. *}
  apply (auto simp add: inj_on_def)
  apply (blast intro: the_equality [symmetric])
  done

lemma inj_on_vimage_singleton:
  "inj_on f A \<Longrightarrow> f -` {a} \<inter> A \<subseteq> {THE x. x \<in> A \<and> f x = a}"
  by (auto simp add: inj_on_def intro: the_equality [symmetric])

lemma (in ordered_ab_group_add) inj_uminus[simp, intro]: "inj_on uminus A"
  by (auto intro!: inj_onI)

lemma (in linorder) strict_mono_imp_inj_on: "strict_mono f \<Longrightarrow> inj_on f A"
  by (auto intro!: inj_onI dest: strict_mono_eq)

lemma bij_betw_byWitness:
assumes LEFT: "\<forall>a \<in> A. f'(f a) = a" and
        RIGHT: "\<forall>a' \<in> A'. f(f' a') = a'" and
        IM1: "f ` A \<le> A'" and IM2: "f' ` A' \<le> A"
shows "bij_betw f A A'"
using assms
proof(unfold bij_betw_def inj_on_def, safe)
  fix a b assume *: "a \<in> A" "b \<in> A" and **: "f a = f b"
  have "a = f'(f a) \<and> b = f'(f b)" using * LEFT by simp
  with ** show "a = b" by simp
next
  fix a' assume *: "a' \<in> A'"
  hence "f' a' \<in> A" using IM2 by blast
  moreover
  have "a' = f(f' a')" using * RIGHT by simp
  ultimately show "a' \<in> f ` A" by blast
qed

corollary notIn_Un_bij_betw:
assumes NIN: "b \<notin> A" and NIN': "f b \<notin> A'" and
       BIJ: "bij_betw f A A'"
shows "bij_betw f (A \<union> {b}) (A' \<union> {f b})"
proof-
  have "bij_betw f {b} {f b}"
  unfolding bij_betw_def inj_on_def by simp
  with assms show ?thesis
  using bij_betw_combine[of f A A' "{b}" "{f b}"] by blast
qed

lemma notIn_Un_bij_betw3:
assumes NIN: "b \<notin> A" and NIN': "f b \<notin> A'"
shows "bij_betw f A A' = bij_betw f (A \<union> {b}) (A' \<union> {f b})"
proof
  assume "bij_betw f A A'"
  thus "bij_betw f (A \<union> {b}) (A' \<union> {f b})"
  using assms notIn_Un_bij_betw[of b A f A'] by blast
next
  assume *: "bij_betw f (A \<union> {b}) (A' \<union> {f b})"
  have "f ` A = A'"
  proof(auto)
    fix a assume **: "a \<in> A"
    hence "f a \<in> A' \<union> {f b}" using * unfolding bij_betw_def by blast
    moreover
    {assume "f a = f b"
     hence "a = b" using * ** unfolding bij_betw_def inj_on_def by blast
     with NIN ** have False by blast
    }
    ultimately show "f a \<in> A'" by blast
  next
    fix a' assume **: "a' \<in> A'"
    hence "a' \<in> f`(A \<union> {b})"
    using * by (auto simp add: bij_betw_def)
    then obtain a where 1: "a \<in> A \<union> {b} \<and> f a = a'" by blast
    moreover
    {assume "a = b" with 1 ** NIN' have False by blast
    }
    ultimately have "a \<in> A" by blast
    with 1 show "a' \<in> f ` A" by blast
  qed
  thus "bij_betw f A A'" using * bij_betw_subset[of f "A \<union> {b}" _ A] by blast
qed

subsection{*Function Updating*}

definition fun_upd :: "('a => 'b) => 'a => 'b => ('a => 'b)" where
  "fun_upd f a b == % x. if x=a then b else f x"

nonterminal updbinds and updbind

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

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

(* Hint: to define the sum of two functions (or maps), use case_sum.
         A nice infix syntax could be defined by
notation
  case_sum  (infixr "'(+')"80)
*)

lemma fun_upd_idem_iff: "(f(x:=y) = f) = (f x = y)"
apply (simp add: fun_upd_def, safe)
apply (erule subst)
apply (rule_tac [2] ext, auto)
done

lemma fun_upd_idem: "f x = y ==> f(x:=y) = f"
  by (simp only: fun_upd_idem_iff)

lemma fun_upd_triv [iff]: "f(x := f x) = f"
  by (simp only: fun_upd_idem)

lemma fun_upd_apply [simp]: "(f(x:=y))z = (if z=x then y else f z)"
by (simp add: fun_upd_def)

(* fun_upd_apply supersedes these two,   but they are useful
   if fun_upd_apply is intentionally removed from the simpset *)
lemma fun_upd_same: "(f(x:=y)) x = y"
by simp

lemma fun_upd_other: "z~=x ==> (f(x:=y)) z = f z"
by simp

lemma fun_upd_upd [simp]: "f(x:=y,x:=z) = f(x:=z)"
by (simp add: fun_eq_iff)

lemma fun_upd_twist: "a ~= c ==> (m(a:=b))(c:=d) = (m(c:=d))(a:=b)"
by (rule ext, auto)

lemma inj_on_fun_updI:
  "inj_on f A \<Longrightarrow> y \<notin> f ` A \<Longrightarrow> inj_on (f(x := y)) A"
  by (fastforce simp: inj_on_def)

lemma fun_upd_image:
     "f(x:=y) ` A = (if x \<in> A then insert y (f ` (A-{x})) else f ` A)"
by auto

lemma fun_upd_comp: "f \<circ> (g(x := y)) = (f \<circ> g)(x := f y)"
  by auto

subsection {* @{text override_on} *}

definition override_on :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a set \<Rightarrow> 'a \<Rightarrow> 'b" where
  "override_on f g A = (\<lambda>a. if a \<in> A then g a else f a)"

lemma override_on_emptyset[simp]: "override_on f g {} = f"
by(simp add:override_on_def)

lemma override_on_apply_notin[simp]: "a ~: A ==> (override_on f g A) a = f a"
by(simp add:override_on_def)

lemma override_on_apply_in[simp]: "a : A ==> (override_on f g A) a = g a"
by(simp add:override_on_def)

subsection {* @{text swap} *}

definition swap :: "'a \<Rightarrow> 'a \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b)"
where
  "swap a b f = f (a := f b, b:= f a)"

lemma swap_apply [simp]:
  "swap a b f a = f b"
  "swap a b f b = f a"
  "c \<noteq> a \<Longrightarrow> c \<noteq> b \<Longrightarrow> swap a b f c = f c"
  by (simp_all add: swap_def)

lemma swap_self [simp]:
  "swap a a f = f"
  by (simp add: swap_def)

lemma swap_commute:
  "swap a b f = swap b a f"
  by (simp add: fun_upd_def swap_def fun_eq_iff)

lemma swap_nilpotent [simp]:
  "swap a b (swap a b f) = f"
  by (rule ext, simp add: fun_upd_def swap_def)

lemma swap_comp_involutory [simp]:
  "swap a b \<circ> swap a b = id"
  by (rule ext) simp

lemma swap_triple:
  assumes "a \<noteq> c" and "b \<noteq> c"
  shows "swap a b (swap b c (swap a b f)) = swap a c f"
  using assms by (simp add: fun_eq_iff swap_def)

lemma comp_swap: "f \<circ> swap a b g = swap a b (f \<circ> g)"
  by (rule ext, simp add: fun_upd_def swap_def)

lemma swap_image_eq [simp]:
  assumes "a \<in> A" "b \<in> A" shows "swap a b f ` A = f ` A"
proof -
  have subset: "\<And>f. swap a b f ` A \<subseteq> f ` A"
    using assms by (auto simp: image_iff swap_def)
  then have "swap a b (swap a b f) ` A \<subseteq> (swap a b f) ` A" .
  with subset[of f] show ?thesis by auto
qed

lemma inj_on_imp_inj_on_swap:
  "\<lbrakk>inj_on f A; a \<in> A; b \<in> A\<rbrakk> \<Longrightarrow> inj_on (swap a b f) A"
  by (simp add: inj_on_def swap_def, blast)

lemma inj_on_swap_iff [simp]:
  assumes A: "a \<in> A" "b \<in> A" shows "inj_on (swap a b f) A \<longleftrightarrow> inj_on f A"
proof
  assume "inj_on (swap a b f) A"
  with A have "inj_on (swap a b (swap a b f)) A"
    by (iprover intro: inj_on_imp_inj_on_swap)
  thus "inj_on f A" by simp
next
  assume "inj_on f A"
  with A show "inj_on (swap a b f) A" by (iprover intro: inj_on_imp_inj_on_swap)
qed

lemma surj_imp_surj_swap: "surj f \<Longrightarrow> surj (swap a b f)"
  by simp

lemma surj_swap_iff [simp]: "surj (swap a b f) \<longleftrightarrow> surj f"
  by simp

lemma bij_betw_swap_iff [simp]:
  "\<lbrakk> x \<in> A; y \<in> A \<rbrakk> \<Longrightarrow> bij_betw (swap x y f) A B \<longleftrightarrow> bij_betw f A B"
  by (auto simp: bij_betw_def)

lemma bij_swap_iff [simp]: "bij (swap a b f) \<longleftrightarrow> bij f"
  by simp

hide_const (open) swap

subsection {* Inversion of injective functions *}

definition the_inv_into :: "'a set => ('a => 'b) => ('b => 'a)" where
  "the_inv_into A f == %x. THE y. y : A & f y = x"

lemma the_inv_into_f_f:
  "[| inj_on f A;  x : A |] ==> the_inv_into A f (f x) = x"
apply (simp add: the_inv_into_def inj_on_def)
apply blast
done

lemma f_the_inv_into_f:
  "inj_on f A ==> y : f`A  ==> f (the_inv_into A f y) = y"
apply (simp add: the_inv_into_def)
apply (rule the1I2)
 apply(blast dest: inj_onD)
apply blast
done

lemma the_inv_into_into:
  "[| inj_on f A; x : f ` A; A <= B |] ==> the_inv_into A f x : B"
apply (simp add: the_inv_into_def)
apply (rule the1I2)
 apply(blast dest: inj_onD)
apply blast
done

lemma the_inv_into_onto[simp]:
  "inj_on f A ==> the_inv_into A f ` (f ` A) = A"
by (fast intro:the_inv_into_into the_inv_into_f_f[symmetric])

lemma the_inv_into_f_eq:
  "[| inj_on f A; f x = y; x : A |] ==> the_inv_into A f y = x"
  apply (erule subst)
  apply (erule the_inv_into_f_f, assumption)
  done

lemma the_inv_into_comp:
  "[| inj_on f (g ` A); inj_on g A; x : f ` g ` A |] ==>
  the_inv_into A (f o g) x = (the_inv_into A g o the_inv_into (g ` A) f) x"
apply (rule the_inv_into_f_eq)
  apply (fast intro: comp_inj_on)
 apply (simp add: f_the_inv_into_f the_inv_into_into)
apply (simp add: the_inv_into_into)
done

lemma inj_on_the_inv_into:
  "inj_on f A \<Longrightarrow> inj_on (the_inv_into A f) (f ` A)"
by (auto intro: inj_onI simp: the_inv_into_f_f)

lemma bij_betw_the_inv_into:
  "bij_betw f A B \<Longrightarrow> bij_betw (the_inv_into A f) B A"
by (auto simp add: bij_betw_def inj_on_the_inv_into the_inv_into_into)

abbreviation the_inv :: "('a \<Rightarrow> 'b) \<Rightarrow> ('b \<Rightarrow> 'a)" where
  "the_inv f \<equiv> the_inv_into UNIV f"

lemma the_inv_f_f:
  assumes "inj f"
  shows "the_inv f (f x) = x" using assms UNIV_I
  by (rule the_inv_into_f_f)

subsection {* Cantor's Paradox *}

lemma Cantors_paradox:
  "\<not>(\<exists>f. f ` A = Pow A)"
proof clarify
  fix f assume "f ` A = Pow A" hence *: "Pow A \<le> f ` A" by blast
  let ?X = "{a \<in> A. a \<notin> f a}"
  have "?X \<in> Pow A" unfolding Pow_def by auto
  with * obtain x where "x \<in> A \<and> f x = ?X" by blast
  thus False by best
qed

subsection {* Setup *}

subsubsection {* Proof tools *}

text {* simplifies terms of the form
  f(...,x:=y,...,x:=z,...) to f(...,x:=z,...) *}

simproc_setup fun_upd2 ("f(v := w, x := y)") = {* fn _ =>
let
  fun gen_fun_upd NONE T _ _ = NONE
    | gen_fun_upd (SOME f) T x y = SOME (Const (@{const_name fun_upd}, T) $ f $ x $ y)
  fun dest_fun_T1 (Type (_, T :: Ts)) = T
  fun find_double (t as Const (@{const_name fun_upd},T) $ f $ x $ y) =
    let
      fun find (Const (@{const_name fun_upd},T) $ g $ v $ w) =
            if v aconv x then SOME g else gen_fun_upd (find g) T v w
        | find t = NONE
    in (dest_fun_T1 T, gen_fun_upd (find f) T x y) end

  val ss = simpset_of @{context}

  fun proc ctxt ct =
    let
      val t = Thm.term_of ct
    in
      case find_double t of
        (T, NONE) => NONE
      | (T, SOME rhs) =>
          SOME (Goal.prove ctxt [] [] (Logic.mk_equals (t, rhs))
            (fn _ =>
              resolve_tac [eq_reflection] 1 THEN
              resolve_tac @{thms ext} 1 THEN
              simp_tac (put_simpset ss ctxt) 1))
    end
in proc end
*}

subsubsection {* Functorial structure of types *}

ML_file "Tools/functor.ML"

functor map_fun: map_fun
  by (simp_all add: fun_eq_iff)

functor vimage
  by (simp_all add: fun_eq_iff vimage_comp)

text {* Legacy theorem names *}

lemmas o_def = comp_def
lemmas o_apply = comp_apply
lemmas o_assoc = comp_assoc [symmetric]
lemmas id_o = id_comp
lemmas o_id = comp_id
lemmas o_eq_dest = comp_eq_dest
lemmas o_eq_elim = comp_eq_elim
lemmas o_eq_dest_lhs = comp_eq_dest_lhs
lemmas o_eq_id_dest = comp_eq_id_dest

end


(*  Title:      Simple Groups
    Author:     Jakob von Raumer, Karlsruhe Institute of Technology
    Maintainer: Jakob von Raumer <jakob.raumer@student.kit.edu>
*)

theory SimpleGroups
imports Coset "HOL-Computational_Algebra.Primes"
begin

section \<open>Simple Groups\<close>

locale simple_group = group +
  assumes order_gt_one: "order G > 1"
  assumes no_real_normal_subgroup: "\<And>H. H \<lhd> G \<Longrightarrow> (H = carrier G \<or> H = {\<one>})"

lemma (in simple_group) is_simple_group: "simple_group G"
  by (rule simple_group_axioms)

text \<open>Simple groups are non-trivial.\<close>

lemma (in simple_group) simple_not_triv: "carrier G \<noteq> {\<one>}"
  using order_gt_one unfolding order_def by auto

text \<open>Every group of prime order is simple\<close>

lemma (in group) prime_order_simple:
  assumes prime: "prime (order G)"
  shows "simple_group G"
proof
  from prime show "1 < order G"
    unfolding prime_nat_iff by auto
next
  fix H
  assume "H \<lhd> G"
  hence HG: "subgroup H G" unfolding normal_def by simp
  hence "card H dvd order G"
    by (metis dvd_triv_right lagrange)
  with prime have "card H = 1 \<or> card H = order G"
    unfolding prime_nat_iff by simp
  thus "H = carrier G \<or> H = {\<one>}"
  proof
    assume "card H = 1"
    moreover from HG have "\<one> \<in> H" by (metis subgroup.one_closed)
    ultimately show ?thesis by (auto simp: card_Suc_eq)
  next
    assume "card H = order G"
    moreover from HG have "H \<subseteq> carrier G" unfolding subgroup_def by simp
    moreover from prime have "finite (carrier G)"
      using order_gt_0_iff_finite by force
    ultimately show ?thesis
      unfolding order_def by (metis card_subset_eq)
  qed
qed

text \<open>Being simple is a property that is preserved by isomorphisms.\<close>

lemma (in simple_group) iso_simple:
  assumes H: "group H"
  assumes iso: "\<phi> \<in> iso G H"
  shows "simple_group H"
unfolding simple_group_def simple_group_axioms_def
proof (intro conjI strip H)
  from iso have "order G = order H" unfolding iso_def order_def using bij_betw_same_card by auto
  with order_gt_one show "1 < order H" by simp
next
  have inv_iso: "(inv_into (carrier G) \<phi>) \<in> iso H G" using iso
    by (simp add: iso_set_sym)
  fix N
  assume NH: "N \<lhd> H"
  then interpret Nnormal: normal N H by simp
  define M where "M = (inv_into (carrier G) \<phi>) ` N"
  hence MG: "M \<lhd> G"
    using inv_iso NH H by (metis is_group iso_normal_subgroup)
  have surj: "\<phi> ` carrier G = carrier H"
    using iso unfolding iso_def bij_betw_def by simp
  hence MN: "\<phi> ` M = N"
    unfolding M_def using Nnormal.subset image_inv_into_cancel by metis
  then have "N = {\<one>\<^bsub>H\<^esub>}" if "M = {\<one>}"
    using Nnormal.subgroup_axioms subgroup.one_closed that by force
  then show "N = carrier H \<or> N = {\<one>\<^bsub>H\<^esub>}"
    by (metis MG MN no_real_normal_subgroup surj)
qed

text \<open>As a corollary of this: Factorizing a group by itself does not result in a simple group!\<close>

lemma (in group) self_factor_not_simple: "\<not> simple_group (G Mod (carrier G))"
proof
  assume assm: "simple_group (G Mod (carrier G))"
  with self_factor_iso simple_group.iso_simple have "simple_group (G\<lparr>carrier := {\<one>}\<rparr>)"
    using subgroup_imp_group triv_subgroup by blast
  thus False
    using simple_group.simple_not_triv by force
qed

end