/-
Copyright (c) 2021 Anne Baanen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Anne Baanen
-/
import data.zmod.basic
import group_theory.group_action.quotient
import ring_theory.int.basic

/-!
# `zmod n` and quotient groups / rings

This file relates `zmod n` to the quotient group
`quotient_add_group.quotient (add_subgroup.zmultiples n)` and to the quotient ring
`(ideal.span {n}).quotient`.

## Main definitions

 - `zmod.quotient_zmultiples_nat_equiv_zmod` and `zmod.quotient_zmultiples_equiv_zmod`:
   `zmod n` is the group quotient of `ℤ` by `n ℤ := add_subgroup.zmultiples (n)`,
   (where `n : ℕ` and `n : ℤ` respectively)
 - `zmod.quotient_span_nat_equiv_zmod` and `zmod.quotient_span_equiv_zmod`:
   `zmod n` is the ring quotient of `ℤ` by `n ℤ : ideal.span {n}`
   (where `n : ℕ` and `n : ℤ` respectively)
 - `zmod.lift n f` is the map from `zmod n` induced by `f : ℤ →+ A` that maps `n` to `0`.

## Tags

zmod, quotient group, quotient ring, ideal quotient
-/

open quotient_add_group
open zmod

variables (n : ℕ) {A R : Type*} [add_group A] [ring R]

namespace int

/-- `ℤ` modulo multiples of `n : ℕ` is `zmod n`. -/
def quotient_zmultiples_nat_equiv_zmod :
  ℤ ⧸ add_subgroup.zmultiples (n : ℤ) ≃+ zmod n :=
(equiv_quotient_of_eq (zmod.ker_int_cast_add_hom _)).symm.trans $
quotient_ker_equiv_of_right_inverse (int.cast_add_hom (zmod n)) coe int_cast_zmod_cast

/-- `ℤ` modulo multiples of `a : ℤ` is `zmod a.nat_abs`. -/
def quotient_zmultiples_equiv_zmod (a : ℤ) :
  ℤ ⧸ add_subgroup.zmultiples a ≃+ zmod a.nat_abs :=
(equiv_quotient_of_eq (zmultiples_nat_abs a)).symm.trans
  (quotient_zmultiples_nat_equiv_zmod a.nat_abs)

/-- `ℤ` modulo the ideal generated by `n : ℕ` is `zmod n`. -/
def quotient_span_nat_equiv_zmod :
  ℤ ⧸ ideal.span {↑n} ≃+* zmod n :=
(ideal.quot_equiv_of_eq (zmod.ker_int_cast_ring_hom _)).symm.trans $
  ring_hom.quotient_ker_equiv_of_right_inverse $
  show function.right_inverse coe (int.cast_ring_hom (zmod n)),
  from int_cast_zmod_cast

/-- `ℤ` modulo the ideal generated by `a : ℤ` is `zmod a.nat_abs`. -/
def quotient_span_equiv_zmod (a : ℤ) :
  ℤ ⧸ ideal.span ({a} : set ℤ) ≃+* zmod a.nat_abs :=
(ideal.quot_equiv_of_eq (span_nat_abs a)).symm.trans
  (quotient_span_nat_equiv_zmod a.nat_abs)

end int

namespace add_action

open add_subgroup add_monoid_hom add_equiv function

variables {α β : Type*} [add_group α] (a : α) [add_action α β] (b : β)

/-- The quotient `(ℤ ∙ a) ⧸ (stabilizer b)` is cyclic of order `minimal_period ((+ᵥ) a) b`. -/
noncomputable def zmultiples_quotient_stabilizer_equiv :
  zmultiples a ⧸ stabilizer (zmultiples a) b ≃+ zmod (minimal_period ((+ᵥ) a) b) :=
(of_bijective (map _ (stabilizer (zmultiples a) b)
  (zmultiples_hom (zmultiples a) ⟨a, mem_zmultiples a⟩) (by
  { rw [zmultiples_le, mem_comap, mem_stabilizer_iff,
        zmultiples_hom_apply, coe_nat_zsmul, ←vadd_iterate],
    exact is_periodic_pt_minimal_period ((+ᵥ) a) b })) ⟨by
  { rw [←ker_eq_bot_iff, eq_bot_iff],
    refine λ q, induction_on' q (λ n hn, _),
    rw [mem_bot, eq_zero_iff, int.mem_zmultiples_iff, ←zsmul_vadd_eq_iff_minimal_period_dvd],
    exact (eq_zero_iff _).mp hn },
  λ q, induction_on' q (λ ⟨_, n, rfl⟩, ⟨n, rfl⟩)⟩).symm.trans
  (int.quotient_zmultiples_nat_equiv_zmod (minimal_period ((+ᵥ) a) b))

lemma zmultiples_quotient_stabilizer_equiv_symm_apply (n : zmod (minimal_period ((+ᵥ) a) b)) :
  (zmultiples_quotient_stabilizer_equiv a b).symm n =
    (n : ℤ) • (⟨a, mem_zmultiples a⟩ : zmultiples a) :=
rfl

end add_action

namespace mul_action

open add_action subgroup add_subgroup function

variables {α β : Type*} [group α] (a : α) [mul_action α β] (b : β)

local attribute [semireducible] mul_opposite

/-- The quotient `(a ^ ℤ) ⧸ (stabilizer b)` is cyclic of order `minimal_period ((•) a) b`. -/
noncomputable def zpowers_quotient_stabilizer_equiv :
  zpowers a ⧸ stabilizer (zpowers a) b ≃* multiplicative (zmod (minimal_period ((•) a) b)) :=
let f := zmultiples_quotient_stabilizer_equiv (additive.of_mul a) b in
⟨f.to_fun, f.inv_fun, f.left_inv, f.right_inv, f.map_add'⟩

lemma zpowers_quotient_stabilizer_equiv_symm_apply (n : zmod (minimal_period ((•) a) b)) :
  (zpowers_quotient_stabilizer_equiv a b).symm n = (⟨a, mem_zpowers a⟩ : zpowers a) ^ (n : ℤ) :=
rfl

/-- The orbit `(a ^ ℤ) • b` is a cycle of order `minimal_period ((•) a) b`. -/
noncomputable def orbit_zpowers_equiv : orbit (zpowers a) b ≃ zmod (minimal_period ((•) a) b) :=
(orbit_equiv_quotient_stabilizer _ b).trans (zpowers_quotient_stabilizer_equiv a b).to_equiv

/-- The orbit `(ℤ • a) +ᵥ b` is a cycle of order `minimal_period ((+ᵥ) a) b`. -/
noncomputable def _root_.add_action.orbit_zmultiples_equiv
  {α β : Type*} [add_group α] (a : α) [add_action α β] (b : β) :
  add_action.orbit (zmultiples a) b ≃ zmod (minimal_period ((+ᵥ) a) b) :=
(add_action.orbit_equiv_quotient_stabilizer (zmultiples a) b).trans
  (zmultiples_quotient_stabilizer_equiv a b).to_equiv

attribute [to_additive orbit_zmultiples_equiv] orbit_zpowers_equiv

@[to_additive orbit_zmultiples_equiv_symm_apply]
lemma orbit_zpowers_equiv_symm_apply (k : zmod (minimal_period ((•) a) b)) :
  (orbit_zpowers_equiv a b).symm k =
    (⟨a, mem_zpowers a⟩ : zpowers a) ^ (k : ℤ) • ⟨b, mem_orbit_self b⟩ :=
rfl

lemma orbit_zpowers_equiv_symm_apply' (k : ℤ) :
  (orbit_zpowers_equiv a b).symm k =
    (⟨a, mem_zpowers a⟩ : zpowers a) ^ k • ⟨b, mem_orbit_self b⟩ :=
begin
  rw [orbit_zpowers_equiv_symm_apply, zmod.coe_int_cast],
  exact subtype.ext (zpow_smul_mod_minimal_period _ _ k),
end

lemma _root_.add_action.orbit_zmultiples_equiv_symm_apply'
  {α β : Type*} [add_group α] (a : α) [add_action α β] (b : β) (k : ℤ) :
  (add_action.orbit_zmultiples_equiv a b).symm k =
    (k • (⟨a, mem_zmultiples a⟩ : zmultiples a)) +ᵥ ⟨b, add_action.mem_orbit_self b⟩ :=
begin
  rw [add_action.orbit_zmultiples_equiv_symm_apply, zmod.coe_int_cast],
  exact subtype.ext (zsmul_vadd_mod_minimal_period _ _ k),
end

attribute [to_additive orbit_zmultiples_equiv_symm_apply'] orbit_zpowers_equiv_symm_apply'

@[to_additive] lemma minimal_period_eq_card [fintype (orbit (zpowers a) b)] :
  minimal_period ((•) a) b = fintype.card (orbit (zpowers a) b) :=
by rw [←fintype.of_equiv_card (orbit_zpowers_equiv a b), zmod.card]

@[to_additive] instance minimal_period_pos [fintype $ orbit (zpowers a) b] :
  ne_zero $ minimal_period ((•) a) b :=
⟨begin
  haveI : nonempty (orbit (zpowers a) b) := (orbit_nonempty b).to_subtype,
  rw minimal_period_eq_card,
  exact fintype.card_ne_zero,
end⟩

end mul_action


/-
Copyright (c) 2019 Anne Baanen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Anne Baanen
-/
import algebra.associated
import algebra.regular.basic
import linear_algebra.matrix.mv_polynomial
import linear_algebra.matrix.polynomial
import ring_theory.polynomial.basic
import tactic.linarith
import tactic.ring_exp

/-!
# Cramer's rule and adjugate matrices

The adjugate matrix is the transpose of the cofactor matrix.
It is calculated with Cramer's rule, which we introduce first.
The vectors returned by Cramer's rule are given by the linear map `cramer`,
which sends a matrix `A` and vector `b` to the vector consisting of the
determinant of replacing the `i`th column of `A` with `b` at index `i`
(written as `(A.update_column i b).det`).
Using Cramer's rule, we can compute for each matrix `A` the matrix `adjugate A`.
The entries of the adjugate are the determinants of each minor of `A`.
Instead of defining a minor to be `A` with row `i` and column `j` deleted, we
replace the `i`th row of `A` with the `j`th basis vector; this has the same
determinant as the minor but more importantly equals Cramer's rule applied
to `A` and the `j`th basis vector, simplifying the subsequent proofs.
We prove the adjugate behaves like `det A • A⁻¹`.

## Main definitions

 * `matrix.cramer A b`: the vector output by Cramer's rule on `A` and `b`.
 * `matrix.adjugate A`: the adjugate (or classical adjoint) of the matrix `A`.

## References

  * https://en.wikipedia.org/wiki/Cramer's_rule#Finding_inverse_matrix

## Tags

cramer, cramer's rule, adjugate
-/

namespace matrix
universes u v
variables {n : Type u} [decidable_eq n] [fintype n] {α : Type v} [comm_ring α]
open_locale matrix big_operators
open equiv equiv.perm finset

section cramer
/-!
  ### `cramer` section

  Introduce the linear map `cramer` with values defined by `cramer_map`.
  After defining `cramer_map` and showing it is linear,
  we will restrict our proofs to using `cramer`.
-/
variables (A : matrix n n α) (b : n → α)

/--
  `cramer_map A b i` is the determinant of the matrix `A` with column `i` replaced with `b`,
  and thus `cramer_map A b` is the vector output by Cramer's rule on `A` and `b`.

  If `A ⬝ x = b` has a unique solution in `x`, `cramer_map A` sends the vector `b` to `A.det • x`.
  Otherwise, the outcome of `cramer_map` is well-defined but not necessarily useful.
-/
def cramer_map (i : n) : α := (A.update_column i b).det

lemma cramer_map_is_linear (i : n) : is_linear_map α (λ b, cramer_map A b i) :=
{ map_add := det_update_column_add _ _,
  map_smul := det_update_column_smul _ _ }

lemma cramer_is_linear : is_linear_map α (cramer_map A) :=
begin
  split; intros; ext i,
  { apply (cramer_map_is_linear A i).1 },
  { apply (cramer_map_is_linear A i).2 }
end

/--
  `cramer A b i` is the determinant of the matrix `A` with column `i` replaced with `b`,
  and thus `cramer A b` is the vector output by Cramer's rule on `A` and `b`.

  If `A ⬝ x = b` has a unique solution in `x`, `cramer A` sends the vector `b` to `A.det • x`.
  Otherwise, the outcome of `cramer` is well-defined but not necessarily useful.
 -/
def cramer (A : matrix n n α) : (n → α) →ₗ[α] (n → α) :=
is_linear_map.mk' (cramer_map A) (cramer_is_linear A)

lemma cramer_apply (i : n) : cramer A b i = (A.update_column i b).det := rfl

lemma cramer_transpose_apply (i : n) : cramer Aᵀ b i = (A.update_row i b).det :=
by rw [cramer_apply, update_column_transpose, det_transpose]

lemma cramer_transpose_row_self (i : n) :
  Aᵀ.cramer (A i) = pi.single i A.det :=
begin
  ext j,
  rw [cramer_apply, pi.single_apply],
  split_ifs with h,
  { -- i = j: this entry should be `A.det`
    subst h,
    simp only [update_column_transpose, det_transpose, update_row, function.update_eq_self] },
  { -- i ≠ j: this entry should be 0
    rw [update_column_transpose, det_transpose],
    apply det_zero_of_row_eq h,
    rw [update_row_self, update_row_ne (ne.symm h)] }
end

lemma cramer_row_self (i : n) (h : ∀ j, b j = A j i) :
  A.cramer b = pi.single i A.det :=
begin
  rw [← transpose_transpose A, det_transpose],
  convert cramer_transpose_row_self Aᵀ i,
  exact funext h
end

@[simp] lemma cramer_one : cramer (1 : matrix n n α) = 1 :=
begin
  ext i j,
  convert congr_fun (cramer_row_self (1 : matrix n n α) (pi.single i 1) i _) j,
  { simp },
  { intros j, rw [matrix.one_eq_pi_single, pi.single_comm] }
end

lemma cramer_smul (r : α) (A : matrix n n α) :
  cramer (r • A) = r ^ (fintype.card n - 1) • cramer A :=
linear_map.ext $ λ b, funext $ λ _, det_update_column_smul' _ _ _ _

@[simp] lemma cramer_subsingleton_apply [subsingleton n] (A : matrix n n α) (b : n → α) (i : n) :
  cramer A b i = b i :=
by rw [cramer_apply, det_eq_elem_of_subsingleton _ i, update_column_self]

lemma cramer_zero [nontrivial n] : cramer (0 : matrix n n α) = 0 :=
begin
  ext i j,
  obtain ⟨j', hj'⟩ : ∃ j', j' ≠ j := exists_ne j,
  apply det_eq_zero_of_column_eq_zero j',
  intro j'',
  simp [update_column_ne hj'],
end

/-- Use linearity of `cramer` to take it out of a summation. -/
lemma sum_cramer {β} (s : finset β) (f : β → n → α) :
  ∑ x in s, cramer A (f x) = cramer A (∑ x in s, f x) :=
(linear_map.map_sum (cramer A)).symm

/-- Use linearity of `cramer` and vector evaluation to take `cramer A _ i` out of a summation. -/
lemma sum_cramer_apply {β} (s : finset β) (f : n → β → α) (i : n) :
∑ x in s, cramer A (λ j, f j x) i = cramer A (λ (j : n), ∑ x in s, f j x) i :=
calc ∑ x in s, cramer A (λ j, f j x) i
    = (∑ x in s, cramer A (λ j, f j x)) i : (finset.sum_apply i s _).symm
... = cramer A (λ (j : n), ∑ x in s, f j x) i :
  by { rw [sum_cramer, cramer_apply], congr' with j, apply finset.sum_apply }

end cramer

section adjugate
/-!
### `adjugate` section

Define the `adjugate` matrix and a few equations.
These will hold for any matrix over a commutative ring.
-/

/-- The adjugate matrix is the transpose of the cofactor matrix.

  Typically, the cofactor matrix is defined by taking the determinant of minors,
  i.e. the matrix with a row and column removed.
  However, the proof of `mul_adjugate` becomes a lot easier if we define the
  minor as replacing a column with a basis vector, since it allows us to use
  facts about the `cramer` map.
-/
def adjugate (A : matrix n n α) : matrix n n α := λ i, cramer Aᵀ (pi.single i 1)

lemma adjugate_def (A : matrix n n α) :
  adjugate A = λ i, cramer Aᵀ (pi.single i 1) := rfl

lemma adjugate_apply (A : matrix n n α) (i j : n) :
  adjugate A i j = (A.update_row j (pi.single i 1)).det :=
by { rw adjugate_def, simp only, rw [cramer_apply, update_column_transpose, det_transpose], }

lemma adjugate_transpose (A : matrix n n α) : (adjugate A)ᵀ = adjugate (Aᵀ) :=
begin
  ext i j,
  rw [transpose_apply, adjugate_apply, adjugate_apply, update_row_transpose, det_transpose],
  rw [det_apply', det_apply'],
  apply finset.sum_congr rfl,
  intros σ _,
  congr' 1,

  by_cases i = σ j,
  { -- Everything except `(i , j)` (= `(σ j , j)`) is given by A, and the rest is a single `1`.
    congr; ext j',
    subst h,
    have : σ j' = σ j ↔ j' = j := σ.injective.eq_iff,
    rw [update_row_apply, update_column_apply],
    simp_rw this,
    rw [←dite_eq_ite, ←dite_eq_ite],
    congr' 1 with rfl,
    rw [pi.single_eq_same, pi.single_eq_same], },
  { -- Otherwise, we need to show that there is a `0` somewhere in the product.
    have : (∏ j' : n, update_column A j (pi.single i 1) (σ j') j') = 0,
    { apply prod_eq_zero (mem_univ j),
      rw [update_column_self, pi.single_eq_of_ne' h], },
    rw this,
    apply prod_eq_zero (mem_univ (σ⁻¹ i)),
    erw [apply_symm_apply σ i, update_row_self],
    apply pi.single_eq_of_ne,
    intro h',
    exact h ((symm_apply_eq σ).mp h') }
end

/-- Since the map `b ↦ cramer A b` is linear in `b`, it must be multiplication by some matrix. This
matrix is `A.adjugate`. -/
lemma cramer_eq_adjugate_mul_vec (A : matrix n n α) (b : n → α) :
  cramer A b = A.adjugate.mul_vec b :=
begin
  nth_rewrite 1 ← A.transpose_transpose,
  rw [← adjugate_transpose, adjugate_def],
  have : b = ∑ i, (b i) • (pi.single i 1),
  { refine (pi_eq_sum_univ b).trans _, congr' with j, simp [pi.single_apply, eq_comm], congr, },
  nth_rewrite 0 this, ext k,
  simp [mul_vec, dot_product, mul_comm],
end

lemma mul_adjugate_apply (A : matrix n n α) (i j k) :
  A i k * adjugate A k j = cramer Aᵀ (pi.single k (A i k)) j :=
begin
  erw [←smul_eq_mul, ←pi.smul_apply, ←linear_map.map_smul, ←pi.single_smul', smul_eq_mul, mul_one],
end

lemma mul_adjugate (A : matrix n n α) : A ⬝ adjugate A = A.det • 1 :=
begin
  ext i j,
  rw [mul_apply, pi.smul_apply, pi.smul_apply, one_apply, smul_eq_mul, mul_boole],
  simp [mul_adjugate_apply, sum_cramer_apply, cramer_transpose_row_self, pi.single_apply, eq_comm]
end

lemma adjugate_mul (A : matrix n n α) : adjugate A ⬝ A = A.det • 1 :=
calc adjugate A ⬝ A = (Aᵀ ⬝ (adjugate Aᵀ))ᵀ :
  by rw [←adjugate_transpose, ←transpose_mul, transpose_transpose]
... = A.det • 1 : by rw [mul_adjugate (Aᵀ), det_transpose, transpose_smul, transpose_one]

lemma adjugate_smul (r : α) (A : matrix n n α) :
  adjugate (r • A) = r ^ (fintype.card n - 1) • adjugate A :=
begin
  rw [adjugate, adjugate, transpose_smul, cramer_smul],
  refl,
end

/-- A stronger form of **Cramer's rule** that allows us to solve some instances of `A ⬝ x = b` even
if the determinant is not a unit. A sufficient (but still not necessary) condition is that `A.det`
divides `b`. -/
@[simp] lemma mul_vec_cramer (A : matrix n n α) (b : n → α) :
  A.mul_vec (cramer A b) = A.det • b :=
by rw [cramer_eq_adjugate_mul_vec, mul_vec_mul_vec, mul_adjugate, smul_mul_vec_assoc, one_mul_vec]

lemma adjugate_subsingleton [subsingleton n] (A : matrix n n α) : adjugate A = 1 :=
begin
  ext i j,
  simp [subsingleton.elim i j, adjugate_apply, det_eq_elem_of_subsingleton _ i]
end

lemma adjugate_eq_one_of_card_eq_one {A : matrix n n α} (h : fintype.card n = 1) : adjugate A = 1 :=
begin
  haveI : subsingleton n := fintype.card_le_one_iff_subsingleton.mp h.le,
  exact adjugate_subsingleton _
end

@[simp] lemma adjugate_zero [nontrivial n] : adjugate (0 : matrix n n α) = 0 :=
begin
  ext i j,
  obtain ⟨j', hj'⟩ : ∃ j', j' ≠ j := exists_ne j,
  apply det_eq_zero_of_column_eq_zero j',
  intro j'',
  simp [update_column_ne hj'],
end

@[simp] lemma adjugate_one : adjugate (1 : matrix n n α) = 1 :=
by { ext, simp [adjugate_def, matrix.one_apply, pi.single_apply, eq_comm] }

lemma _root_.ring_hom.map_adjugate {R S : Type*} [comm_ring R] [comm_ring S] (f : R →+* S)
  (M : matrix n n R) : f.map_matrix M.adjugate = matrix.adjugate (f.map_matrix M) :=
begin
  ext i k,
  have : pi.single i (1 : S) = f ∘ pi.single i 1,
  { rw ←f.map_one,
    exact pi.single_op (λ i, f) (λ i, f.map_zero) i (1 : R) },
  rw [adjugate_apply, ring_hom.map_matrix_apply, map_apply, ring_hom.map_matrix_apply,
      this, ←map_update_row, ←ring_hom.map_matrix_apply, ←ring_hom.map_det, ←adjugate_apply]
end

lemma _root_.alg_hom.map_adjugate {R A B : Type*} [comm_semiring R] [comm_ring A] [comm_ring B]
  [algebra R A] [algebra R B] (f : A →ₐ[R] B)
  (M : matrix n n A) : f.map_matrix M.adjugate = matrix.adjugate (f.map_matrix M) :=
f.to_ring_hom.map_adjugate _

lemma det_adjugate (A : matrix n n α) : (adjugate A).det = A.det ^ (fintype.card n - 1) :=
begin
  -- get rid of the `- 1`
  cases (fintype.card n).eq_zero_or_pos with h_card h_card,
  { haveI : is_empty n := fintype.card_eq_zero_iff.mp h_card,
    rw [h_card, nat.zero_sub, pow_zero, adjugate_subsingleton, det_one] },
  replace h_card := tsub_add_cancel_of_le h_card.nat_succ_le,

  -- express `A` as an evaluation of a polynomial in n^2 variables, and solve in the polynomial ring
  -- where `A'.det` is non-zero.
  let A' := mv_polynomial_X n n ℤ,
  suffices : A'.adjugate.det = A'.det ^ (fintype.card n - 1),
  { rw [←mv_polynomial_X_map_matrix_aeval ℤ A, ←alg_hom.map_adjugate, ←alg_hom.map_det,
      ←alg_hom.map_det, ←alg_hom.map_pow, this] },

  apply mul_left_cancel₀ (show A'.det ≠ 0, from det_mv_polynomial_X_ne_zero n ℤ),
  calc  A'.det * A'.adjugate.det
      = (A' ⬝ adjugate A').det                 : (det_mul _ _).symm
  ... = A'.det ^ fintype.card n                : by rw [mul_adjugate, det_smul, det_one, mul_one]
  ... = A'.det * A'.det ^ (fintype.card n - 1) : by rw [←pow_succ, h_card],
end

@[simp] lemma adjugate_fin_zero (A : matrix (fin 0) (fin 0) α) : adjugate A = 0 :=
@subsingleton.elim _ matrix.subsingleton_of_empty_left _ _

@[simp] lemma adjugate_fin_one (A : matrix (fin 1) (fin 1) α) : adjugate A = 1 :=
adjugate_subsingleton A

lemma adjugate_fin_two (A : matrix (fin 2) (fin 2) α) :
  adjugate A = ![![A 1 1, -A 0 1], ![-A 1 0, A 0 0]] :=
begin
  ext i j,
  rw [adjugate_apply, det_fin_two],
  fin_cases i with [0, 1]; fin_cases j with [0, 1];
  simp only [nat.one_ne_zero, one_mul, fin.one_eq_zero_iff, pi.single_eq_same, zero_mul,
    fin.zero_eq_one_iff, sub_zero, pi.single_eq_of_ne, ne.def, not_false_iff, update_row_self,
    update_row_ne, cons_val_zero, mul_zero, mul_one, zero_sub, cons_val_one, head_cons],
end

@[simp] lemma adjugate_fin_two' (a b c d : α) :
  adjugate ![![a, b], ![c, d]] = ![![d, -b], ![-c, a]] :=
adjugate_fin_two _

lemma adjugate_conj_transpose [star_ring α] (A : matrix n n α) : A.adjugateᴴ = adjugate (Aᴴ) :=
begin
  dsimp only [conj_transpose],
  have : Aᵀ.adjugate.map star = adjugate (Aᵀ.map star) :=
    ((star_ring_aut : α ≃+* α).to_ring_hom.map_adjugate Aᵀ),
  rw [A.adjugate_transpose, this],
end

lemma is_regular_of_is_left_regular_det {A : matrix n n α} (hA : is_left_regular A.det) :
  is_regular A :=
begin
  split,
  { intros B C h,
    refine hA.matrix _,
    rw [←matrix.one_mul B, ←matrix.one_mul C, ←matrix.smul_mul, ←matrix.smul_mul, ←adjugate_mul,
        matrix.mul_assoc, matrix.mul_assoc, ←mul_eq_mul A, h, mul_eq_mul] },
  { intros B C h,
    simp only [mul_eq_mul] at h,
    refine hA.matrix _,
    rw [←matrix.mul_one B, ←matrix.mul_one C, ←matrix.mul_smul, ←matrix.mul_smul, ←mul_adjugate,
        ←matrix.mul_assoc, ←matrix.mul_assoc, h] }
end

lemma adjugate_mul_distrib_aux (A B : matrix n n α)
  (hA : is_left_regular A.det)
  (hB : is_left_regular B.det) :
  adjugate (A ⬝ B) = adjugate B ⬝ adjugate A :=
begin
  have hAB : is_left_regular (A ⬝ B).det,
  { rw [det_mul],
    exact hA.mul hB },
  refine (is_regular_of_is_left_regular_det hAB).left _,
  rw [mul_eq_mul, mul_adjugate, mul_eq_mul, matrix.mul_assoc, ←matrix.mul_assoc B, mul_adjugate,
      smul_mul, matrix.one_mul, mul_smul, mul_adjugate, smul_smul, mul_comm, ←det_mul]
end

/--
Proof follows from "The trace Cayley-Hamilton theorem" by Darij Grinberg, Section 5.3
-/
lemma adjugate_mul_distrib (A B : matrix n n α) : adjugate (A ⬝ B) = adjugate B ⬝ adjugate A :=
begin
  let g : matrix n n α → matrix n n (polynomial α) :=
    λ M, M.map polynomial.C + (polynomial.X : polynomial α) • 1,
  let f' : matrix n n (polynomial α) →+* matrix n n α := (polynomial.eval_ring_hom 0).map_matrix,
  have f'_inv : ∀ M, f' (g M) = M,
  { intro,
    ext,
    simp [f', g], },
  have f'_adj : ∀ (M : matrix n n α), f' (adjugate (g M)) = adjugate M,
  { intro,
    rw [ring_hom.map_adjugate, f'_inv] },
  have f'_g_mul : ∀ (M N : matrix n n α), f' (g M ⬝ g N) = M ⬝ N,
  { intros,
    rw [←mul_eq_mul, ring_hom.map_mul, f'_inv, f'_inv, mul_eq_mul] },
  have hu : ∀ (M : matrix n n α), is_regular (g M).det,
  { intros M,
    refine polynomial.monic.is_regular _,
    simp only [g, polynomial.monic.def, ←polynomial.leading_coeff_det_X_one_add_C M, add_comm] },
  rw [←f'_adj, ←f'_adj, ←f'_adj, ←mul_eq_mul (f' (adjugate (g B))), ←f'.map_mul, mul_eq_mul,
      ←adjugate_mul_distrib_aux _ _ (hu A).left (hu B).left, ring_hom.map_adjugate,
      ring_hom.map_adjugate, f'_inv, f'_g_mul]
end

@[simp] lemma adjugate_pow (A : matrix n n α) (k : ℕ) :
  adjugate (A ^ k) = (adjugate A) ^ k :=
begin
  induction k with k IH,
  { simp },
  { rw [pow_succ', mul_eq_mul, adjugate_mul_distrib, IH, ←mul_eq_mul, pow_succ] }
end

lemma det_smul_adjugate_adjugate (A : matrix n n α) :
  det A • adjugate (adjugate A) = det A ^ (fintype.card n - 1) • A :=
begin
  have : A ⬝ (A.adjugate ⬝ A.adjugate.adjugate) = A ⬝ (A.det ^ (fintype.card n - 1) • 1),
  { rw [←adjugate_mul_distrib, adjugate_mul, adjugate_smul, adjugate_one], },
  rwa [←matrix.mul_assoc, mul_adjugate, matrix.mul_smul, matrix.mul_one, matrix.smul_mul,
    matrix.one_mul] at this,
end

/-- Note that this is not true for `fintype.card n = 1` since `1 - 2 = 0` and not `-1`. -/

  -- express `A` as an evaluation of a polynomial in n^2 variables, and solve in the polynomial ring
  -- where `A'.det` is non-zero.
  let A' := mv_polynomial_X n n ℤ,
  suffices : adjugate (adjugate A') = det A' ^ (fintype.card n - 2) • A',
  { rw [←mv_polynomial_X_map_matrix_aeval ℤ A, ←alg_hom.map_adjugate, ←alg_hom.map_adjugate, this,
      ←alg_hom.map_det, ← alg_hom.map_pow],
    -- TODO: missing an `alg_hom.map_smul_of_tower` here.
    ext i j,
    dsimp [-mv_polynomial_X],
    rw [←alg_hom.map_mul] },
  have h_card' : fintype.card n - 2 + 1 = fintype.card n - 1,
  { simp [h_card] },

  have is_reg : is_smul_regular (mv_polynomial (n × n) ℤ) (det A') :=
    λ x y, mul_left_cancel₀ (det_mv_polynomial_X_ne_zero n ℤ),
  apply is_reg.matrix,
  rw [smul_smul, ←pow_succ, h_card', det_smul_adjugate_adjugate],
end

/-- A weaker version of `matrix.adjugate_adjugate` that uses `nontrivial`. -/
lemma adjugate_adjugate' (A : matrix n n α) [nontrivial n] :
  adjugate (adjugate A) = det A ^ (fintype.card n - 2) • A :=
adjugate_adjugate _ $ fintype.one_lt_card.ne'

end adjugate

end matrix


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import tactic.basic
import data.nat.basic
import algebra.order.ring

/- Turn off trace messages so they don't pollute the test build: -/
set_option trace.silence_library_search true

example {a b : ℕ} (h : b > 0) (w : a ≥ 1) : b ≤ a * b :=
by library_search -- exact (le_mul_iff_one_le_left h).mpr w


/-
Copyright (c) 2019 Neil Strickland. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Neil Strickland

This file defines a typeclass for types α with an ordered
enumeration of the elements (as opposed to a `fintype`
instance, which is an unordered enumeration).  This is
intended to allow for explicit calculation in a wider range
of cases.
-/

-- TODO:
-- instances for (co) products etc

import data.finset data.fintype.basic data.list.basic logic.encodable.basic

namespace combinatorics

universes u v

variables {α : Type*} {β : Type*} {γ : Type*}

class enumeration (α : Type*) :=
(elems : list α)
(nodup : list.nodup elems)
(complete : ∀ x : α, x ∈ elems)

instance enumeration_fintype [e : enumeration α] : fintype α :=
  ⟨⟨e.elems,e.nodup⟩,e.complete⟩

namespace enumeration

variable (α)
variable [enumeration α]

def univ_list : list α := (@enumeration.elems α _)
def univ_nodup : list.nodup (univ_list α) := (@enumeration.nodup α _)
def univ_complete := (@enumeration.complete α _)

lemma enum_card : fintype.card α = (@enumeration.elems α _).length :=
begin
  dsimp[fintype.card,finset.univ,fintype.elems,finset.card],refl,
end

#check function.left_inverse.injective

def of_equiv (f : α ≃ β) : enumeration β :=
{ elems := (univ_list α).map f.to_fun,
  nodup := list.nodup.map f.left_inv.injective (univ_nodup α),
  complete :=
  begin
    intro b,
    rw[← f.right_inv b],
    exact list.mem_map_of_mem f.to_fun (univ_complete α (f.inv_fun b)),
   end }

variable [decidable_eq α]

def fin_equiv {n : ℕ} (h : (univ_list α).length = n) : α ≃ (fin n) :=
begin
  let els := univ_list α,
  let inv_fun : (fin n) → α :=
    λ i, els.nth_le i.val (@eq.subst ℕ (nat.lt i.val) _ _ h.symm i.is_lt),
  let to_fun_aux : ∀ (a : α), {i : fin n // inv_fun i = a} :=
  begin
    intro a,
    let i_val := els.index_of a,
    let i_lt_l := list.index_of_lt_length.mpr (enumeration.complete a),
    let i_lt_n : i_val < n := @eq.subst ℕ (nat.lt i_val) _ _ h i_lt_l,
    let i : fin n := ⟨i_val,i_lt_n⟩,
    have : inv_fun i = a :=
      by { cases h,exact list.index_of_nth_le i_lt_l },
    exact ⟨i,this⟩
  end,
  let to_fun : α → (fin n) := λ a, (to_fun_aux a).val,
  let left_inv : ∀ a : α, inv_fun (to_fun a) = a :=
    λ a, (to_fun_aux a).property,
  let right_inv : ∀ i : (fin n), to_fun (inv_fun i) = i :=
  begin
   intro i,cases i with i_val i_is_lt,
   apply fin.eq_of_veq,
   let i_lt_l : i_val < els.length :=
    @eq.subst ℕ (nat.lt i_val) _ _ h.symm i_is_lt,
   exact list.nth_le_index_of (univ_nodup α) i_val i_lt_l,
  end,
  exact ⟨to_fun,inv_fun,left_inv,right_inv⟩
end

instance : encodable α :=
begin
 let els := univ_list α,
 let f := fin_equiv α rfl,
 let encode : α → ℕ := λ a,(f.to_fun a).val,
 let decode : ℕ → option α :=
 begin
  intro i,
  by_cases h : i < els.length,
  {exact some (f.inv_fun ⟨i,h⟩),},
  {exact none,}
 end,
 let encodek : ∀ a, decode (encode a) = some a :=
 begin
  intro a,
  dsimp[decode,encode],
  rw[dif_pos (f a).is_lt],simp[f.left_inv a],
 end,
 exact ⟨encode,decode,encodek⟩
end

def subtype_enumeration {p : α → Prop} (l : list α)
 (l_nodup : list.nodup l)
 (l_mem : ∀ x : α, x ∈ l ↔ p x) : enumeration {x // p x} :=
begin
 let α1 := {x // p x},
 let elems1 : list α1 := @list.pmap α α1 p subtype.mk l (λ x, (l_mem x).mp),
 let nodup : elems1.nodup :=
  @list.nodup.pmap α α1 p subtype.mk l (λ x, (l_mem x).mp)
   (λ a _ b _,congr_arg subtype.val) l_nodup,
 let complete : ∀ a1 : α1, a1 ∈ elems1 :=
 begin
  intro a1, cases a1,
  let h0 := ((@list.mem_pmap α α1 p subtype.mk l
               (λ x, (l_mem x).mp)) ⟨a1_val,a1_property⟩).mpr,
  have h1 : a1_val ∈ l := (l_mem a1_val).mpr a1_property,
  exact h0 ⟨a1_val,h1,rfl⟩,
 end,
 exact ⟨elems1,nodup,complete⟩
end

instance (p : α → Prop) [decidable_pred p] : enumeration {a // p a} :=
begin
 let l := (univ_list α).filter p,
 let l_nodup : l.nodup := list.nodup.filter p (univ_nodup α),
 let l_mem : ∀ x : α, x ∈ l ↔ p x :=
 begin
  intro x,
  let h0 : x ∈ univ_list α := (univ_complete α) x,
  simp[list.mem_filter,h0],
 end,
 exact subtype_enumeration α l l_nodup l_mem,
end

end enumeration

end combinatorics

namespace fin

instance enum : ∀ (n : ℕ), combinatorics.enumeration (fin n)
| 0 := { elems := [], nodup := list.nodup_nil, complete := λ x, fin.elim0 x }
| (n + 1) := {
    elems := (0 : fin n.succ) :: ((enum n).elems.map fin.succ),
    nodup :=
    begin
      rw [list.nodup_cons], split,
      { intro h, rcases list.mem_map.mp h with ⟨i,⟨hm,he⟩⟩,
        exact fin.succ_ne_zero i he },
      { exact list.nodup.map (λ i j e, fin.succ_inj.mp e) (enum n).nodup }
    end,
    complete :=
    λ i, begin
      by_cases h : i = 0,
      { rw [h], exact list.mem_cons_self _ _ },
      { let j := fin.pred i h,
        have : i = j.succ := (fin.succ_pred i h).symm,
        rw [this],
        let hc := (enum n).complete,
        exact list.mem_cons_of_mem _
         (list.mem_map_of_mem fin.succ (hc j)),
      }
    end
  }

lemma enum_length : ∀ (n : ℕ), (fin.enum n).elems.length = n
| 0 := rfl
| (n + 1) :=
begin
  change (list.cons (0 : fin (n + 1)) ((fin.enum n).elems.map fin.succ)).length = n + 1,
  rw [list.length, list.length_map, enum_length n]
end

end fin


import tuto_lib
/-
This file continues the elementary study of limits of sequences.
It can be skipped if the previous file was too easy, it won't introduce
any new tactic or trick.

Remember useful lemmas:

abs_le (x y : ℝ) : |x| ≤ y ↔ -y ≤ x ∧ x ≤ y

abs_add (x y : ℝ) : |x + y| ≤ |x| + |y|

abs_sub_comm (x y : ℝ) : |x - y| = |y - x|

ge_max_iff (p q r) : r ≥ max p q  ↔ r ≥ p ∧ r ≥ q

le_max_left p q : p ≤ max p q

le_max_right p q : q ≤ max p q

and the definition:

def seq_limit (u : ℕ → ℝ) (l : ℝ) : Prop :=
∀ ε > 0, ∃ N, ∀ n ≥ N, |u n - l| ≤ ε

You can also use a property proved in the previous file:

unique_limit : seq_limit u l → seq_limit u l' → l = l'

def extraction (φ : ℕ → ℕ) := ∀ n m, n < m → φ n < φ m
-/

variable { φ : ℕ → ℕ}

/-
The next lemma is proved by an easy induction, but we haven't seen induction
in this tutorial. If you did the natural number game then you can delete
the proof below and try to reconstruct it.
-/
/-- An extraction is greater than id -/
lemma id_le_extraction' : extraction φ → ∀ n, n ≤ φ n :=
begin
  intros hyp n,
  induction n with n hn,
  { exact nat.zero_le _ },
  { exact nat.succ_le_of_lt (by linarith [hyp n (n+1) (by linarith)]) },
end

/-- Extractions take arbitrarily large values for arbitrarily large
inputs. -/
-- 0039
lemma extraction_ge : extraction φ → ∀ N N', ∃ n ≥ N', φ n ≥ N :=
begin
  sorry
end

/-- A real number `a` is a cluster point of a sequence `u`
if `u` has a subsequence converging to `a`.

def cluster_point (u : ℕ → ℝ) (a : ℝ) :=
∃ φ, extraction φ ∧ seq_limit (u ∘ φ) a
-/

variables {u : ℕ → ℝ} {a l : ℝ}

/-
In the exercise, we use `∃ n ≥ N, ...` which is the abbreviation of
`∃ n, n ≥ N ∧ ...`.
Lean can read this abbreviation, but displays it as the confusing:
`∃ (n : ℕ) (H : n ≥ N)`
One gets used to it. Alternatively, one can get rid of it using the lemma
  exists_prop {p q : Prop} : (∃ (h : p), q) ↔ p ∧ q
-/

/-- If `a` is a cluster point of `u` then there are values of
`u` arbitrarily close to `a` for arbitrarily large input. -/
-- 0040
lemma near_cluster :
  cluster_point u a → ∀ ε > 0, ∀ N, ∃ n ≥ N, |u n - a| ≤ ε :=
begin
  sorry
end

/-
The above exercice can be done in five lines.
Hint: you can use the anonymous constructor syntax when proving
existential statements.
-/

/-- If `u` tends to `l` then its subsequences tend to `l`. -/
-- 0041
lemma subseq_tendsto_of_tendsto' (h : seq_limit u l) (hφ : extraction φ) :
seq_limit (u ∘ φ) l :=
begin
  sorry
end

/-- If `u` tends to `l` all its cluster points are equal to `l`. -/
-- 0042
lemma cluster_limit (hl : seq_limit u l) (ha : cluster_point u a) : a = l :=
begin
  sorry
end

/-- Cauchy_sequence sequence -/
def cauchy_sequence (u : ℕ → ℝ) := ∀ ε > 0, ∃ N, ∀ p q, p ≥ N → q ≥ N → |u p - u q| ≤ ε

-- 0043
example : (∃ l, seq_limit u l) → cauchy_sequence u :=
begin
  sorry
end

/-
In the next exercise, you can reuse
 near_cluster : cluster_point u a → ∀ ε > 0, ∀ N, ∃ n ≥ N, |u n - a| ≤ ε
-/
-- 0044
example (hu : cauchy_sequence u) (hl : cluster_point u l) : seq_limit u l :=
begin
  sorry
end


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import tactic.basic
import data.fintype.basic

/-!
# Erdős–Szekeres theorem

This file proves Theorem 73 from the [100 Theorems List](https://www.cs.ru.nl/~freek/100/), also
known as the Erdős–Szekeres theorem: given a sequence of more than `r * s` distinct
values, there is an increasing sequence of length longer than `r` or a decreasing sequence of length
longer than `s`.

We use the proof outlined at
https://en.wikipedia.org/wiki/Erdos-Szekeres_theorem#Pigeonhole_principle.

## Tags

sequences, increasing, decreasing, Ramsey, Erdos-Szekeres, Erdős–Szekeres, Erdős-Szekeres
-/

variables {α : Type*} [linear_order α] {β : Type*}

open function finset
open_locale classical

/--
Given a sequence of more than `r * s` distinct values, there is an increasing sequence of length
longer than `r` or a decreasing sequence of length longer than `s`.

Proof idea:
We label each value in the sequence with two numbers specifying the longest increasing
subsequence ending there, and the longest decreasing subsequence ending there.
We then show the pair of labels must be unique. Now if there is no increasing sequence longer than
`r` and no decreasing sequence longer than `s`, then there are at most `r * s` possible labels,
which is a contradiction if there are more than `r * s` elements.
-/
theorem erdos_szekeres {r s n : ℕ} {f : fin n → α} (hn : r * s < n) (hf : injective f) :
  (∃ (t : finset (fin n)), r < t.card ∧ strict_mono_incr_on f ↑t) ∨
  (∃ (t : finset (fin n)), s < t.card ∧ strict_mono_decr_on f ↑t) :=
begin
  -- Given an index `i`, produce the set of increasing (resp., decreasing) subsequences which ends
  -- at `i`.
  let inc_sequences_ending_in : fin n → finset (finset (fin n)) :=
    λ i, univ.powerset.filter (λ t, finset.max t = some i ∧ strict_mono_incr_on f ↑t),
  let dec_sequences_ending_in : fin n → finset (finset (fin n)) :=
    λ i, univ.powerset.filter (λ t, finset.max t = some i ∧ strict_mono_decr_on f ↑t),
  -- The singleton sequence is in both of the above collections.
  -- (This is useful to show that the maximum length subsequence is at least 1, and that the set
  -- of subsequences is nonempty.)
  have inc_i : ∀ i, {i} ∈ inc_sequences_ending_in i := λ i, by simp [strict_mono_incr_on],
  have dec_i : ∀ i, {i} ∈ dec_sequences_ending_in i := λ i, by simp [strict_mono_decr_on],
  -- Define the pair of labels: at index `i`, the pair is the maximum length of an increasing
  -- subsequence ending at `i`, paired with the maximum length of a decreasing subsequence ending
  -- at `i`.
  -- We call these labels `(a_i, b_i)`.
  let ab : fin n → ℕ × ℕ,
  { intro i,
    apply (max' ((inc_sequences_ending_in i).image card) (nonempty.image ⟨{i}, inc_i i⟩ _),
           max' ((dec_sequences_ending_in i).image card) (nonempty.image ⟨{i}, dec_i i⟩ _)) },
  -- It now suffices to show that one of the labels is 'big' somewhere. In particular, if the
  -- first in the pair is more than `r` somewhere, then we have an increasing subsequence in our
  -- set, and if the second is more than `s` somewhere, then we have a decreasing subsequence.
  suffices : ∃ i, r < (ab i).1 ∨ s < (ab i).2,
  { obtain ⟨i, hi⟩ := this,
    apply or.imp _ _ hi,
    work_on_goal 0 { have : (ab i).1 ∈ _ := max'_mem _ _ },
    work_on_goal 1 { have : (ab i).2 ∈ _ := max'_mem _ _ },
    all_goals
    { intro hi,
      rw mem_image at this,
      obtain ⟨t, ht₁, ht₂⟩ := this,
      refine ⟨t, by rwa ht₂, _⟩,
      rw mem_filter at ht₁,
      apply ht₁.2.2 } },
  -- Show first that the pair of labels is unique.
  have : injective ab,
  { apply injective_of_lt_imp_ne,
    intros i j k q,
    injection q with q₁ q₂,
    -- We have two cases: `f i < f j` or `f j < f i`.
    -- In the former we'll show `a_i < a_j`, and in the latter we'll show `b_i < b_j`.
    cases lt_or_gt_of_ne (λ _, ne_of_lt ‹i < j› (hf ‹f i = f j›)),
    work_on_goal 0 { apply ne_of_lt _ q₁, have : (ab i).1 ∈ _ := max'_mem _ _ },
    work_on_goal 1 { apply ne_of_lt _ q₂, have : (ab i).2 ∈ _ := max'_mem _ _ },
    all_goals
    { -- Reduce to showing there is a subsequence of length `a_i + 1` which ends at `j`.
      rw nat.lt_iff_add_one_le,
      apply le_max',
      rw mem_image at this ⊢,
      -- In particular we take the subsequence `t` of length `a_i` which ends at `i`, by definition
      -- of `a_i`
      rcases this with ⟨t, ht₁, ht₂⟩,
      rw mem_filter at ht₁,
      -- Ensure `t` ends at `i`.
      have : i ∈ t.max,
        simp [ht₁.2.1],
      -- Now our new subsequence is given by adding `j` at the end of `t`.
      refine ⟨insert j t, _, _⟩,
      -- First make sure it's valid, i.e., that this subsequence ends at `j` and is increasing
      { rw mem_filter,
        refine ⟨_, _, _⟩,
        { rw mem_powerset, apply subset_univ },
        -- It ends at `j` since `i < j`.
        { convert max_insert,
          rw [ht₁.2.1, option.lift_or_get_some_some, max_eq_left, with_top.some_eq_coe],
          apply le_of_lt ‹i < j› },
        -- To show it's increasing (i.e., `f` is monotone increasing on `t.insert j`), we do cases
        -- on what the possibilities could be - either in `t` or equals `j`.
        simp only [strict_mono_incr_on, strict_mono_decr_on, coe_insert, set.mem_insert_iff,
          mem_coe],
        -- Most of the cases are just bashes.
        rintros x ⟨rfl | _⟩ y ⟨rfl | _⟩ _,
        { apply (irrefl _ ‹j < j›).elim },
        { exfalso,
          apply not_le_of_lt (trans ‹i < j› ‹j < y›) (le_max_of_mem ‹y ∈ t› ‹i ∈ t.max›) },
        { apply lt_of_le_of_lt _ ‹f i < f j› <|> apply lt_of_lt_of_le ‹f j < f i› _,
          rcases lt_or_eq_of_le (le_max_of_mem ‹x ∈ t› ‹i ∈ t.max›) with _ | rfl,
          { apply le_of_lt (ht₁.2.2 ‹x ∈ t› (mem_of_max ‹i ∈ t.max›) ‹x < i›) },
          { refl } },
        { apply ht₁.2.2 ‹x ∈ t› ‹y ∈ t› ‹x < y› } },
      -- Finally show that this new subsequence is one longer than the old one.
      { rw [card_insert_of_not_mem, ht₂],
        intro _,
        apply not_le_of_lt ‹i < j› (le_max_of_mem ‹j ∈ t› ‹i ∈ t.max›) } } },
      -- Finished both goals!
  -- Now that we have uniqueness of each label, it remains to do some counting to finish off.
  -- Suppose all the labels are small.
  by_contra q,
  push_neg at q,
  -- Then the labels `(a_i, b_i)` all fit in the following set: `{ (x,y) | 1 ≤ x ≤ r, 1 ≤ y ≤ s }`
  let ran : finset (ℕ × ℕ) := ((range r).image nat.succ).product ((range s).image nat.succ),
  -- which we prove here.
  have : image ab univ ⊆ ran,
  -- First some logical shuffling
  { rintro ⟨x₁, x₂⟩,
    simp only [mem_image, exists_prop, mem_range, mem_univ, mem_product, true_and, prod.mk.inj_iff],
    rintros ⟨i, rfl, rfl⟩,
    specialize q i,
    -- Show `1 ≤ a_i` and `1 ≤ b_i`, which is easy from the fact that `{i}` is a increasing and
    -- decreasing subsequence which we did right near the top.
    have z : 1 ≤ (ab i).1 ∧ 1 ≤ (ab i).2,
    { split;
      { apply le_max',
        rw mem_image,
        refine ⟨{i}, by solve_by_elim, card_singleton i⟩ } },
    refine ⟨_, _⟩,
    -- Need to get `a_i ≤ r`, here phrased as: there is some `a < r` with `a+1 = a_i`.
    { refine ⟨(ab i).1 - 1, _, nat.succ_pred_eq_of_pos z.1⟩,
      rw nat.sub_lt_right_iff_lt_add z.1,
      apply nat.lt_succ_of_le q.1 },
    { refine ⟨(ab i).2 - 1, _, nat.succ_pred_eq_of_pos z.2⟩,
      rw nat.sub_lt_right_iff_lt_add z.2,
      apply nat.lt_succ_of_le q.2 } },
  -- To get our contradiction, it suffices to prove `n ≤ r * s`
  apply not_le_of_lt hn,
  -- Which follows from considering the cardinalities of the subset above, since `ab` is injective.
  simpa [nat.succ_injective, card_image_of_injective, ‹injective ab›] using card_le_of_subset this,
end


import data.finset

namespace finset
variable {α : Type*}

def disjoint (s t : finset α) : Prop := ∀ ⦃a⦄, a ∈ s → a ∈ t → false

theorem disjoint.symm {s t : finset α} (d : disjoint s t) : disjoint t s
| a i₂ i₁ := d i₁ i₂

@[simp] theorem disjoint_comm {s t : finset α} : disjoint s t ↔ disjoint t s :=
⟨disjoint.symm, disjoint.symm⟩

theorem disjoint_left {s t : finset α} : disjoint s t ↔ ∀ {a}, a ∈ s → a ∉ t := iff.rfl

theorem disjoint_right {s t : finset α} : disjoint s t ↔ ∀ {a}, a ∈ t → a ∉ s :=
disjoint_comm

theorem disjoint_iff_ne {s t : finset α} : disjoint s t ↔ ∀ a ∈ s, ∀ b ∈ t, a ≠ b :=
by simp [disjoint_left, imp_not_comm]

theorem disjoint_of_subset_left {s t u : finset α} (h : s ⊆ u) (d : disjoint u t) : disjoint s t
| x m₁ := d (h m₁)

theorem disjoint_of_subset_right {s t u : finset α} (h : t ⊆ u) (d : disjoint s u) : disjoint s t
| x m m₁ := d m (h m₁)

@[simp] theorem empty_disjoint (l : finset α) : disjoint ∅ l
| a := (not_mem_empty a).elim

@[simp] theorem singleton_disjoint [decidable_eq α] {l : finset α} {a : α} : disjoint (singleton a) l ↔ a ∉ l :=
by simp [disjoint]; refl

@[simp] theorem disjoint_singleton [decidable_eq α] {l : finset α} {a : α} : disjoint l (singleton a) ↔ a ∉ l :=
by rw disjoint_comm; simp

@[simp] theorem disjoint_insert_left [decidable_eq α] {a : α} {s t : finset α} :
  disjoint (insert a s) t ↔ a ∉ t ∧ disjoint s t :=
by simp [disjoint, or_imp_distrib, forall_and_distrib]; refl

@[simp] theorem disjoint_insert_right [decidable_eq α] {a : α} {s t : finset α} :
  disjoint s (insert a t) ↔ a ∉ s ∧ disjoint s t :=
disjoint_comm.trans $ by simp [disjoint_insert_left]

theorem inter_eq_zero_iff_disjoint [decidable_eq α] {s t : finset α} : s ∩ t = ∅ ↔ disjoint s t :=
by rw ← subset_empty; simp [subset_iff, disjoint]

@[simp] theorem disjoint_union_left [decidable_eq α] {s t u : finset α} :
  disjoint (s ∪ t) u ↔ disjoint s u ∧ disjoint t u :=
by simp [disjoint, or_imp_distrib, forall_and_distrib]

@[simp] theorem disjoint_union_right [decidable_eq α] {s t u : finset α} :
  disjoint s (t ∪ u) ↔ disjoint s t ∧ disjoint s u :=
by simp [disjoint, or_imp_distrib, forall_and_distrib]

@[simp] theorem disjoint_val {s t : finset α} : multiset.disjoint s.1 t.1 ↔ disjoint s t :=
by simp [disjoint, multiset.disjoint, mem_def]

@[simp] theorem card_disjoint_union [decidable_eq α] {s t : finset α} :
    disjoint s t → card (s ∪ t) = card s + card t :=
finset.induction_on s (by simp) $ begin simp {contextual := tt} end

end finset


namespace hidden
  variables {α : Type} (r : α → α → Prop)

  definition reflexive : Prop := ∀ (a : α), r a a
  definition symmetric : Prop := ∀ ⦃a b : α⦄, r a b → r b a
  definition transitive : Prop := ∀ ⦃a b c : α⦄, r a b → r b c → r a c
  definition euclidean : Prop := ∀ ⦃a b c : α⦄, r a b → r a c → r b c

  variable {r}

  theorem th1 (reflr : reflexive r) (euclr : euclidean r) : symmetric r :=
    assume (a b : α), assume : (r a b),
    show r b a, from euclr this (reflr _)

  theorem th2 (symmr : symmetric r) (euclr : euclidean r) : transitive r :=
    assume (a b c : α), assume (rab : r a b) (rbc : r b c),
    euclr (symmr rab) rbc

  theorem th3 (reflr : reflexive r) (euclr : euclidean r) : transitive r :=
    th2 (th1 reflr euclr) euclr
end hidden


import algebra.order_functions

universe variables u

section

parameters {α : Type u}
parameters [partial_order α]
parameters x y : α

lemma indirect_eq_left_iff
: x = y ↔ (∀ z, z ≤ x ↔ z ≤ y) :=
begin
  split ; intro h,
  { subst y, intro, refl },
  apply @le_antisymm α,
  { rw ← h },
  { rw h },
end

lemma indirect_eq_right_iff
: x = y ↔ (∀ z, x ≤ z ↔ y ≤ z) :=
begin
  split ; intro h,
  { subst y, intro, refl },
  apply @le_antisymm α,
  { rw h },
  { rw ← h },
end

lemma indirect_le_left_iff
: x ≤ y ↔ (∀ z, z ≤ x → z ≤ y) :=
begin
  split ; intro h,
  { intro z, apply flip le_trans h, },
  { apply h, refl },
end

lemma indirect_le_right_iff
: x ≤ y ↔ (∀ z, y ≤ z → x ≤ z) :=
begin
  split ; intro h,
  { intro z, apply le_trans h, },
  { apply h, refl },
end

parameters {x y}

lemma eq_of_indirect_left_iff
  (h : ∀ z, z ≤ x ↔ z ≤ y)
: x = y :=
indirect_eq_left_iff.mpr h

lemma eq_of_indirect_eq_right
  (h : ∀ z, x ≤ z ↔ y ≤ z)
: x = y :=
indirect_eq_right_iff.mpr h

lemma le_of_indirect_le_left
  (h : ∀ z, z ≤ x → z ≤ y)
: x ≤ y :=
indirect_le_left_iff.mpr h

lemma le_of_indirect_le_right
  (h : ∀ z, y ≤ z → x ≤ z)
: x ≤ y :=
indirect_le_right_iff.mpr h

parameter z : α

lemma indirect_left_left_of_eq
  (h : x = y)
: z ≤ x ↔ z ≤ y :=
indirect_eq_left_iff.mp h z

lemma indirect_eq_right_of_eq
  (h : x = y)
: x ≤ z ↔ y ≤ z :=
indirect_eq_right_iff.mp h z

lemma indirect_le_left_of_le
  (h : x ≤ y)
: z ≤ x → z ≤ y :=
indirect_le_left_iff.mp h z

lemma indirect_le_right_of_le
  (h : x ≤ y)
: y ≤ z → x ≤ z :=
indirect_le_right_iff.mp h z

end

section

parameters {α : Type u}
parameters x y z : α
variable [decidable_linear_order α]

lemma le_max_iff_le_or_le
: x ≤ max y z ↔ x ≤ y ∨ x ≤ z :=
begin
  split
  ; intros H
  ; cases decidable.em (y ≤ z) with H' H'
  ; try { unfold max at H }
  ; try { unfold max },
  { rw if_pos H' at H,
    right, apply H },
  { rw if_neg H' at H,
    left, apply H },
  { rw if_pos H',
    cases H with H H,
    transitivity y ; assumption,
    assumption },
  { rw if_neg H',
    have H₂ := le_of_not_ge H',
    cases H with H H,
    assumption,
    transitivity z ; assumption }
end

parameters {x y}

lemma le_max_of_le_left
  (h : x ≤ y)
: x ≤ max y z :=
by simp [le_max_iff_le_or_le,h]

lemma lt_max_of_lt_left
  (h : x < y)
: x < max y z :=
begin
  simp only [lt_iff_not_ge,(≥),max_le_iff,decidable.not_and_iff_or_not] at ⊢ h,
  left, assumption,
end

lemma le_max_of_le_right
  (h : x ≤ z)
: x ≤ max y z :=
by simp [le_max_iff_le_or_le,h]

lemma lt_max_of_lt_right
  (h : x < z)
: x < max y z :=
begin
  simp only [lt_iff_not_ge,(≥),max_le_iff,decidable.not_and_iff_or_not] at ⊢ h,
  right, assumption,
end

end


/-
Graphs
Sina Hazratpour
Introduction to Proof
MATH 301, Johns Hopkins University, Fall 2022
-/

import ..prooflab
import .lec11_type_classes

set_option pp.beta true
set_option pp.generalized_field_notation false
-- set_option pp.all true

open PROOFS

open PROOFS.STR

/-!
### Graphs

A simple graph is specified by the following data:
1. A type `V` of vertices
2. An irreflexive symmetric binary predicate (i.e. relation) `adj` on `V` describing which pairs of vertices are adjacent. In other words, for vertices `v₁` and `v₂`, the proposition `adj v₁ v₂` expresses the condition for adjecency.

- We want `adj` to be symmetric which is to say if vertex `v₁` is adjacent to vertex `v₂` then `v₂` is also adjacent to `v₁`.
- We want `adj` to be irreflexive which is to say we do not want to have loops.

The relation
There is exactly one edge for every pair of adjacent vertices;
see `simple_graph.edge_set` for the corresponding edge set.

Given a type `V`, then `G : simple_graph V` is a simple graph defined over `V` with an adjacency relation `G.adj` between vertices of type V that is symmetric (G.sym) and irreflexive (G.noloop).
-/

@[ext]
structure simple_graph_str (V : Type) :=
(adj : V → V → Prop)
(symm : symmetric adj)
(noloop : irreflexive adj)

#check simple_graph_str

variable {X : Type}
variables {V : Type} (G : simple_graph_str V)

/-! ## Challenge
Define the __empty graph__ on a vertex type `V`, i.e. the graph with no edges on a given vertex type `V`.
 -/
def empty_graph_str (V : Type) : simple_graph_str V :=
{
  adj := λ v1 v2, false,
  symm := by
    {
      unfold symmetric,
      intros v1 v2,
      intro h,
      exact h,
    },
  noloop := by
    {
      unfold irreflexive,
      intro v1,
      intro h,
      exact h,
    },
}

/-
### Challenge :
Define a graph structure on the type `bool` where the only edge is between `ff` and `tt`.
-/

def bool_graph_str : simple_graph_str bool :=
{
  adj := λ v1, λ v2, v1 ≠ v2,
  symm := by {rw symmetric,
              intros x y h₁,
              apply neq.symm,
              exact h₁},
  noloop := by {rw irreflexive,
                intros x h₁,
                have h₂ : x = x, by refl,
                exact neq.elim h₁ h₂,
                },
}

structure preorder_str (X : Type) :=
(rel : X → X → Prop)
(rflx : reflexive rel)
(trns : transitive rel)

def preorder_bool : preorder_str bool :=
{
  rel := λ b, λ b', b && b' = b,
  rflx := by { unfold reflexive, --
               intro x, --
               cases x,
               repeat {refl},
               },
  trns := by { unfold transitive,
               intros x y z,
               intros h₁ h₂, rw ← h₁, rw bool_and_assoc, rw h₂},
}

/-
### Challenge :
Construct for any preorder a graph where there is an edge between any two points of the preorder if they are related to each other.
-/
def graph_of_preorder_str (X : Type) (ρ : preorder_str X) : simple_graph_str (X) :=
{
  adj := λ x₁, λ x₂, (¬ ρ.rel x₁ x₂ ∧ ρ.rel x₂ x₁) ∨ (ρ.rel x₁ x₂ ∧ ¬ ρ.rel x₂ x₁),
  symm := by {
    unfold symmetric,
    intros x₁ x₂,
    intro h₁,
    cases h₁,
    {
      right,
      split,
      {
        exact h₁.2,
      },
      {
        exact h₁.1,
      },
    },
    {
      left,
      split,
      {
        exact h₁.2,
      },
      {
        exact h₁.1,
      }
    },
   },
  noloop := by {
    unfold irreflexive,
    intro x,
    intro h₁,
    cases h₁,
    {
      cases h₁ with hnr hr,
      exact hnr hr,
    },
    {
      cases h₁ with hr hnr,
      exact hnr hr,
    },
  }
}

/-
### Challenge  :
Construct the prodcut of two preorders.
-/

def preorder_str.prod {X Y : Type} (P : preorder_str X) (Q : preorder_str Y) :
preorder_str (X × Y) :=
{
  rel := λ a, λ b, (P.rel a.1 b.1) ∧ (Q.rel a.2 b.2),
  rflx := by {unfold reflexive,
              intro q,
              split,
              {
                exact P.rflx q.fst,
              },
              {
                exact Q.rflx q.snd,
              },
              },
  trns := by {  unfold transitive,
                intros x y z,
                intro hpqx,
                intro hpqy,
                split,
                {
                  cases hpqx,
                  cases hpqy,
                  exact P.trns hpqx_left hpqy_left,
                },
                {
                  cases hpqx,
                  cases hpqy,
                  exact Q.trns hpqx_right hpqy_right,
                },},
}

/-
### Challenge  :
Construct the graph associated to the pointwise preorder on `bool × bool`. How many edges does this graph have?
-/

def graph_of_boolxbool_ptwise : simple_graph_str (bool × bool) :=
graph_of_preorder_str (bool × bool) (preorder_str.prod preorder_bool preorder_bool)

/-
### Challenge :
Develope an API for simple graphs.
-/

lemma adj_comm (u v : V) :
  G.adj u v ↔ G.adj v u :=
begin
  split,
  {
    intro h₁,
    exact G.symm h₁,
  },
  {
    intro h₁,
    exact G.symm h₁,
  },
end

/-
### Challenge :
The __complete graph__ on a type `V` is the simple graph with all pairs of distinct vertices adjacent.
-/

def complete_graph_str (V : Type) : simple_graph_str V :=
{
  adj := λ x₁, λ x₂, ¬ (x₁ = x₂),
  symm := by {
    unfold symmetric,
    intros x₁ x₂,
    intro h₁,
    intro h₂,
    apply h₁,
    rw h₂,
  },
  noloop := by {
    unfold irreflexive,
    intro x,
    intro h₁,
    apply h₁,
    refl,
  },
}

/-
### Challenge :
Define subgraphs. Suppose we have two graphs `G` and `H` on the same vertex type `V`. We say `G` is a subgraph of `H` if
whenever any two vertex are connected by an edge in `G` they are connected by an edge in `H`.
-/

def is_subgraph (G H : simple_graph_str V) : Prop := ∀ {x₁ x₂ : V}, (G.adj x₁ x₂ → H.adj x₁ x₂)

/-
### Challenge :
Show that the empty graph is a subgraph of any other graph.
-/

example (H : simple_graph_str V) : is_subgraph (empty_graph_str V) H :=
begin
unfold is_subgraph,
intros x₁ x₂ h₁,
exfalso,
exact h₁,
end

/- ### Challenge :
Show that every graph is a subgraph of the complete graph on the same vertex type.
-/

lemma all_sub_of_comp (V : Type) (C G : simple_graph_str V) (h₁ : C = complete_graph_str V):
  is_subgraph G C :=
begin
  unfold is_subgraph,
  intros x₁ x₂,
  intro hg,
  rw h₁,
  intro hn,
  have hi : irreflexive G.adj, from G.noloop,
  rw hn at hg,
  unfold irreflexive at hi,
  exact (hi x₂) hg,
end

/-
### Challenge :
Construct the sum of two graphs on the same type. The sum of two graphs `G` and `H` has an edge between two vertices if and only if either there is an edge between the same vertices in `G` or there is an edge between the same vertices in `H`.
-/

@[simp]
def sum_of_graphs (G H : simple_graph_str V) : simple_graph_str V :=
{ adj := λ i j, G.adj i j ∨ H.adj i j,
  symm := by {unfold symmetric, intros x y, intro hGH, cases hGH,
              {
                left,
                apply G.symm hGH,
              },
              {
                right,
                apply H.symm hGH,
              },
            },
  noloop := by {unfold irreflexive, intros x h₁, cases h₁,
                {
                  have h₂: ¬G.adj x x, from G.noloop x,
                  apply h₂,
                  exact h₁,
                },
                {
                  have h₂: ¬H.adj x x, from H.noloop x,
                  apply h₂,
                  exact h₁,
                },
              },
}

/-
### Challenge :
Define the __complement__ of a graph. The complement of a graph `G` is a graph `Gᶜ` on the same set of vertices as of G such that there will be an edge between two vertices `v₁` and `v₂` in G’, if and only if there is no edge in between `v₁` and `v₂` in `Gᶜ`.
-/
@[simp]
def complement (G : simple_graph_str V) : simple_graph_str V :=
{
  adj := λ v1, λ v2, (¬ G.adj v1 v2) ∧ v1 ≠ v2,

  symm := by
  {
    unfold symmetric,
    intros x y,
    intro h,
    split,
    {
      intro h1,
      have h2 := G.symm,
      have h3 := h2 h1,
      cases h,
      exact h_left h3,
    },
    {
      intro h1,
      cases h,
      have h2 : x = y := by rw h1,
      exact h_right h2,
      },
  },

  noloop := by
  {
    unfold irreflexive,
    intro v1,
    intro h,
    simp at *,
    exact h,
  },
}

/- ### Challenge :
Define the embedding of graphs. A __graph embedding__ is a injective function `f`  between the vertex types of two such that for vertices `v₁ v₂ : V`,
`G.adj f(v₁) f(v₂) ↔ G.adj v₁ v₂ `.
-/

structure graph_embedding {V W : Type} (G : simple_graph_str V) (H : simple_graph_str W) :=
(to_fun : V → W)
(to_fun_inj : is_injective to_fun)
(embed : ∀ {a b : V}, H.adj (to_fun a) (to_fun b) ↔ G.adj a b)

/- ### Challenge :
Show that an embedding with the identity function induces a subgraph.
-/

/-
### Challenge :
What is the sum of a graph of its complement. Prove it in Lean.
-/

#check graph_embedding.to_fun

structure graph_isomorphism {V W : Type} (G : simple_graph_str V) (H : simple_graph_str W) extends graph_embedding G H :=
(surj : is_surjective to_fun)

#check graph_embedding
#check is_surjective

#check sum_of_graphs
#check complement

infix ` ≅ `:35 := graph_isomorphism
def self_of_sum_complement_self {V : Type} {G : simple_graph_str V} : (sum_of_graphs G (complement G)) ≅ complete_graph_str V :=
{ to_fun := id,
  to_fun_inj := by {intros x y, simp,},
  embed := by {intros x y, simp, split, intro h, sorry, },
  surj := sorry, }

/- ### Challenge :
A (proper) coloring of a graph `G` with color set `C` is a function `f : V → C` assigning colors to each vertex such that adjacent vertices have different colors. -/

structure colored_graph :=
(G : simple_graph_str V)
(C : Type)
(color : V → C)
(adj_diff_color : ∀ {v1 v2 : V}, G.adj v1 v2 → color v1 ≠ color v2)

/- ### Challenge :
A bipartition of a graph `G` is a coloring of `G` with color set `{1,2}`. Let `V₁` and `V₂` respectively denote the color classes for colors 1 and 2. If a bipartition exists, the graph is called bipartite.
-/

structure bipartite_graph :=
(cgraph : colored_graph)
(color_1 : cgraph.C)
(color_2 : cgraph.C)
(two_colors : ∀ x : V, cgraph.color x = color_1 ∨ cgraph.color x = color_2)


import .basic
import ..list.take_drop_lemmas

universe variables u

namespace vector

variables {α : Type u}
variable {m : ℕ}
variable {n : ℕ}

def join_list : list (vector α m) → list α
| list.nil := list.nil
| (list.cons a v) := list.append (to_list a) (join_list v)

theorem length_join_list : ∀ (l : list (vector α m)), list.length (join_list l) = m * list.length l
| list.nil := rfl
| (list.cons a v) := calc
  list.length (list.append (to_list a) (join_list v))
        = list.length (to_list a) + list.length (join_list v) : list.length_append (to_list a) (join_list v)
    ... = m + list.length (join_list v) : congr_arg (λ i, i + list.length (join_list v)) (length_to_list a)
    ... = m + m * list.length v         : congr_arg (λ i, m + i) (length_join_list v)
    ... = m * list.length v + m         : nat.add_comm _ _

definition join : vector (vector α m) n → vector α (m * n)
| ⟨ l, h ⟩ :=
  let p := calc
     list.length (join_list l)
           = m * list.length l : length_join_list l
       ... = m * n : congr_arg (λ i, m * i) h
  in ⟨ join_list l, p ⟩

lemma to_list_join : ∀(x : vector (vector α m) n), to_list (join x) = join_list (to_list x)
| ⟨ l, h ⟩ := rfl

def take_le (n : ℕ) (l : list α) (p : n ≤ list.length l) : vector α n :=
  ⟨list.take n l, eq.trans (list.length_take n l) (min_eq_left p)⟩

lemma to_list_take_le (n : ℕ) (l : list α) (p : n ≤ list.length l) : to_list (take_le n l p) = list.take n l := rfl

-- 'bounded_chunk_list n m l' splits 'l' into at most 'n' 'm'-element chunks.
definition bounded_chunk_list : Π(n m : ℕ), list α → list (vector α m)
| nat.zero m l := list.nil
| (nat.succ n) m l :=
  if p : list.length l ≥ m then
    list.cons (take_le m l p) (bounded_chunk_list n m (list.drop m l))
  else
    list.nil

lemma bounded_chunk_list_zero (m : ℕ) (l : list α) : bounded_chunk_list 0 m l = [] := rfl

lemma bounded_chunk_list_succ_next (n m : ℕ) (l : list α) (p : list.length l ≥ m)
: bounded_chunk_list (nat.succ n) m l = list.cons (take_le m l p) (bounded_chunk_list n m (list.drop m l)) :=
begin
  unfold bounded_chunk_list,
  rw [dif_pos p]
end

lemma length_bounded_chunk_list : ∀(n m : ℕ) (l : list α), (list.length l = m * n) → list.length (bounded_chunk_list n m l) = n
| nat.zero m t  :=
  begin
    intros,
    simp [bounded_chunk_list_zero],
  end
| (nat.succ n) m t :=
  if p : list.length t ≥ m then
    begin
      rw [nat.mul_succ],
      intro h,
      have q : list.length (list.drop m t) = m * n,
         { rw [list.length_drop, h, nat.add_sub_cancel] },
      unfold bounded_chunk_list,
      rw [dif_pos p],
      simp [length_bounded_chunk_list n m _ q, nat.add_succ]
    end
  else
    begin
      simp [nat.mul_succ],
      intro h,
      have t_ge : list.length t ≥ m,
        { rw [h], apply nat.le_add_right },
      contradiction
    end

definition split_vector {m:ℕ} : Π(n : ℕ), vector α (m * n) → list (vector α m)
| n ⟨ l, p ⟩ := bounded_chunk_list n m l

theorem length_split_vector {m : ℕ} : ∀ (n : ℕ) (t : vector α (m * n)), (split_vector n t)^.length = n
| n ⟨ l, p ⟩ :=
begin
  unfold split_vector,
  simp [length_bounded_chunk_list n m l p]
end

definition split : Π {n : ℕ}, vector α (m * n) → vector (vector α m) n
| n v := ⟨ split_vector n v, length_split_vector n v ⟩

--------------------------------------------------------------------------------
-- Relate join_list and split_list

theorem join_list_of_bounded_chunk_list {α : Type u}
: ∀ (n m) (l : list α) (p : list.length l = m * n), vector.join_list (vector.bounded_chunk_list n m l) = l
| 0 m l :=
begin
  unfold bounded_chunk_list,
  simp [nat.mul_zero],
  intros,
  cases l, refl, contradiction,
end
| (nat.succ n) m l :=
if q : list.length l ≥ m then
begin
  unfold bounded_chunk_list,
  rw [dif_pos q],
  unfold join_list,
  intros,
  have h : list.length (list.drop m l) = m * n,
    { rw [list.length_drop, a, nat.mul_succ,nat.add_sub_cancel]
    },
  simp [join_list_of_bounded_chunk_list _ _ _ h, to_list_take_le],
  exact (list.take_append_drop_self m l)
end
else
begin
  rw [nat.mul_succ],
  intro p,
  -- Assert contradiction
  have t_ge : list.length l ≥ m, { rw p, apply nat.le_add_left },
  contradiction
end

theorem join_list_of_split_list {α : Type u} {m n}
: ∀ (t : vector α (m * n)), join_list (split_vector n t) = t^.to_list
| ⟨l, p⟩ :=
  begin
    unfold split_vector,
    apply join_list_of_bounded_chunk_list,
    exact p
  end

end vector


/-
Copyright (c) 2020 Thomas Browning, Patrick Lutz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Thomas Browning, Patrick Lutz
-/

import analysis.complex.polynomial
import field_theory.galois
import group_theory.perm.cycle_type
import ring_theory.eisenstein_criterion

/-!
# Galois Groups of Polynomials

In this file we introduce the Galois group of a polynomial, defined as
the automorphism group of the splitting field.

## Main definitions

- `gal p`: the Galois group of a polynomial p.
- `restrict p E`: the restriction homomorphism `(E ≃ₐ[F] E) → gal p`.
- `gal_action p E`: the action of `gal p` on the roots of `p` in `E`.

## Main results

- `restrict_smul`: `restrict p E` is compatible with `gal_action p E`.
- `gal_action_hom_injective`: the action of `gal p` on the roots of `p` in `E` is faithful.
- `restrict_prod_inj`: `gal (p * q)` embeds as a subgroup of `gal p × gal q`.
- `gal_action_hom_bijective_of_prime_degree`: An irreducible polynomial of prime degree
  with two non-real roots has full Galois group
-/

noncomputable theory
open_locale classical

open finite_dimensional

namespace polynomial

variables {F : Type*} [field F] (p q : polynomial F) (E : Type*) [field E] [algebra F E]

/-- The Galois group of a polynomial -/
@[derive [has_coe_to_fun, group, fintype]]
def gal := p.splitting_field ≃ₐ[F] p.splitting_field

namespace gal

@[ext] lemma ext {σ τ : p.gal} (h : ∀ x ∈ p.root_set p.splitting_field, σ x = τ x) : σ = τ :=
begin
  refine alg_equiv.ext (λ x, (alg_hom.mem_equalizer σ.to_alg_hom τ.to_alg_hom x).mp
      ((set_like.ext_iff.mp _ x).mpr algebra.mem_top)),
  rwa [eq_top_iff, ←splitting_field.adjoin_roots, algebra.adjoin_le_iff],
end

instance [h : fact (p.splits (ring_hom.id F))] : unique p.gal :=
{ default := 1,
  uniq := λ f, alg_equiv.ext (λ x, by { obtain ⟨y, rfl⟩ := algebra.mem_bot.mp
    ((set_like.ext_iff.mp ((is_splitting_field.splits_iff _ p).mp h.1) x).mp algebra.mem_top),
    rw [alg_equiv.commutes, alg_equiv.commutes] }) }

/-- If `p` splits in `F` then the `p.gal` is trivial. -/
def unique_gal_of_splits (h : p.splits (ring_hom.id F)) : unique p.gal :=
{ default := 1,
  uniq := λ f, alg_equiv.ext (λ x, by { obtain ⟨y, rfl⟩ := algebra.mem_bot.mp
    ((set_like.ext_iff.mp ((is_splitting_field.splits_iff _ p).mp h) x).mp algebra.mem_top),
    rw [alg_equiv.commutes, alg_equiv.commutes] }) }

instance unique_gal_zero : unique (0 : polynomial F).gal :=
unique_gal_of_splits _ (splits_zero _)

instance unique_gal_one : unique (1 : polynomial F).gal :=
unique_gal_of_splits _ (splits_one _)

instance unique_gal_C (x : F) : unique (C x).gal :=
unique_gal_of_splits _ (splits_C _ _)

instance unique_gal_X : unique (X : polynomial F).gal :=
unique_gal_of_splits _ (splits_X _)

instance unique_gal_X_sub_C (x : F) : unique (X - C x).gal :=
unique_gal_of_splits _ (splits_X_sub_C _)

instance unique_gal_X_pow (n : ℕ) : unique (X ^ n : polynomial F).gal :=
unique_gal_of_splits _ (splits_X_pow _ _)

instance [h : fact (p.splits (algebra_map F E))] : algebra p.splitting_field E :=
(is_splitting_field.lift p.splitting_field p h.1).to_ring_hom.to_algebra

instance [h : fact (p.splits (algebra_map F E))] : is_scalar_tower F p.splitting_field E :=
is_scalar_tower.of_algebra_map_eq
  (λ x, ((is_splitting_field.lift p.splitting_field p h.1).commutes x).symm)

/-- The restriction homomorphism -/
def restrict [fact (p.splits (algebra_map F E))] : (E ≃ₐ[F] E) →* p.gal :=
alg_equiv.restrict_normal_hom p.splitting_field

lemma restrict_surjective [fact (p.splits (algebra_map F E))] [normal F E] :
  function.surjective (restrict p E) :=
alg_equiv.restrict_normal_hom_surjective E

section roots_action

/-- The function from `roots p p.splitting_field` to `roots p E` -/
def map_roots [fact (p.splits (algebra_map F E))] :
  root_set p p.splitting_field → root_set p E :=
λ x, ⟨is_scalar_tower.to_alg_hom F p.splitting_field E x, begin
  have key := subtype.mem x,
  by_cases p = 0,
  { simp only [h, root_set_zero] at key,
    exact false.rec _ key },
  { rw [mem_root_set h, aeval_alg_hom_apply, (mem_root_set h).mp key, alg_hom.map_zero] } end⟩

lemma map_roots_bijective [h : fact (p.splits (algebra_map F E))] :
  function.bijective (map_roots p E) :=
begin
  split,
  { exact λ _ _ h, subtype.ext (ring_hom.injective _ (subtype.ext_iff.mp h)) },
  { intro y,
    have key := roots_map
      (is_scalar_tower.to_alg_hom F p.splitting_field E : p.splitting_field →+* E)
      ((splits_id_iff_splits _).mpr (is_splitting_field.splits p.splitting_field p)),
    rw [map_map, alg_hom.comp_algebra_map] at key,
    have hy := subtype.mem y,
    simp only [root_set, finset.mem_coe, multiset.mem_to_finset, key, multiset.mem_map] at hy,
    rcases hy with ⟨x, hx1, hx2⟩,
    exact ⟨⟨x, multiset.mem_to_finset.mpr hx1⟩, subtype.ext hx2⟩ }
end

/-- The bijection between `root_set p p.splitting_field` and `root_set p E` -/
def roots_equiv_roots [fact (p.splits (algebra_map F E))] :
  (root_set p p.splitting_field) ≃ (root_set p E) :=
equiv.of_bijective (map_roots p E) (map_roots_bijective p E)

instance gal_action_aux : mul_action p.gal (root_set p p.splitting_field) :=
{ smul := λ ϕ x, ⟨ϕ x, begin
    have key := subtype.mem x,
    --simp only [root_set, finset.mem_coe, multiset.mem_to_finset] at *,
    by_cases p = 0,
    { simp only [h, root_set_zero] at key,
      exact false.rec _ key },
    { rw mem_root_set h,
      change aeval (ϕ.to_alg_hom x) p = 0,
      rw [aeval_alg_hom_apply, (mem_root_set h).mp key, alg_hom.map_zero] } end⟩,
  one_smul := λ _, by { ext, refl },
  mul_smul := λ _ _ _, by { ext, refl } }

instance gal_action [fact (p.splits (algebra_map F E))] : mul_action p.gal (root_set p E) :=
{ smul := λ ϕ x, roots_equiv_roots p E (ϕ • ((roots_equiv_roots p E).symm x)),
  one_smul := λ _, by simp only [equiv.apply_symm_apply, one_smul],
  mul_smul := λ _ _ _, by simp only [equiv.apply_symm_apply, equiv.symm_apply_apply, mul_smul] }

variables {p E}

@[simp] lemma restrict_smul [fact (p.splits (algebra_map F E))]
  (ϕ : E ≃ₐ[F] E) (x : root_set p E) : ↑((restrict p E ϕ) • x) = ϕ x :=
begin
  let ψ := alg_equiv.of_injective_field (is_scalar_tower.to_alg_hom F p.splitting_field E),
  change ↑(ψ (ψ.symm _)) = ϕ x,
  rw alg_equiv.apply_symm_apply ψ,
  change ϕ (roots_equiv_roots p E ((roots_equiv_roots p E).symm x)) = ϕ x,
  rw equiv.apply_symm_apply (roots_equiv_roots p E),
end

variables (p E)

/-- `gal_action` as a permutation representation -/
def gal_action_hom [fact (p.splits (algebra_map F E))] : p.gal →* equiv.perm (root_set p E) :=
{ to_fun := λ ϕ, equiv.mk (λ x, ϕ • x) (λ x, ϕ⁻¹ • x)
  (λ x, inv_smul_smul ϕ x) (λ x, smul_inv_smul ϕ x),
  map_one' := by { ext1 x, exact mul_action.one_smul x },
  map_mul' := λ x y, by { ext1 z, exact mul_action.mul_smul x y z } }

lemma gal_action_hom_restrict [fact (p.splits (algebra_map F E))]
  (ϕ : E ≃ₐ[F] E) (x : root_set p E) : ↑(gal_action_hom p E (restrict p E ϕ) x) = ϕ x :=
restrict_smul ϕ x

lemma gal_action_hom_injective [fact (p.splits (algebra_map F E))] :
  function.injective (gal_action_hom p E) :=
begin
  rw monoid_hom.injective_iff,
  intros ϕ hϕ,
  let equalizer := alg_hom.equalizer ϕ.to_alg_hom (alg_hom.id F p.splitting_field),
  suffices : equalizer = ⊤,
  { exact alg_equiv.ext (λ x, (set_like.ext_iff.mp this x).mpr algebra.mem_top) },
  rw [eq_top_iff, ←splitting_field.adjoin_roots, algebra.adjoin_le_iff],
  intros x hx,
  have key := equiv.perm.ext_iff.mp hϕ (roots_equiv_roots p E ⟨x, hx⟩),
  change roots_equiv_roots p E (ϕ • (roots_equiv_roots p E).symm
    (roots_equiv_roots p E ⟨x, hx⟩)) = roots_equiv_roots p E ⟨x, hx⟩ at key,
  rw equiv.symm_apply_apply at key,
  exact subtype.ext_iff.mp (equiv.injective (roots_equiv_roots p E) key),
end

end roots_action

variables {p q}

/-- The restriction homomorphism between Galois groups -/
def restrict_dvd (hpq : p ∣ q) : q.gal →* p.gal :=
if hq : q = 0 then 1 else @restrict F _ p _ _ _
  ⟨splits_of_splits_of_dvd (algebra_map F q.splitting_field) hq (splitting_field.splits q) hpq⟩

lemma restrict_dvd_surjective (hpq : p ∣ q) (hq : q ≠ 0) :
  function.surjective (restrict_dvd hpq) :=
by simp only [restrict_dvd, dif_neg hq, restrict_surjective]

variables (p q)

/-- The Galois group of a product embeds into the product of the Galois groups  -/
def restrict_prod : (p * q).gal →* p.gal × q.gal :=
monoid_hom.prod (restrict_dvd (dvd_mul_right p q)) (restrict_dvd (dvd_mul_left q p))

lemma restrict_prod_injective : function.injective (restrict_prod p q) :=
begin
  by_cases hpq : (p * q) = 0,
  { haveI : unique (p * q).gal := by { rw hpq, apply_instance },
    exact λ f g h, eq.trans (unique.eq_default f) (unique.eq_default g).symm },
  intros f g hfg,
  dsimp only [restrict_prod, restrict_dvd] at hfg,
  simp only [dif_neg hpq, monoid_hom.prod_apply, prod.mk.inj_iff] at hfg,
  suffices : alg_hom.equalizer f.to_alg_hom g.to_alg_hom = ⊤,
  { exact alg_equiv.ext (λ x, (set_like.ext_iff.mp this x).mpr algebra.mem_top) },
  rw [eq_top_iff, ←splitting_field.adjoin_roots, algebra.adjoin_le_iff],
  intros x hx,
  rw [map_mul, polynomial.roots_mul] at hx,
  cases multiset.mem_add.mp (multiset.mem_to_finset.mp hx) with h h,
  { change f x = g x,
    haveI : fact (p.splits (algebra_map F (p * q).splitting_field)) :=
      ⟨splits_of_splits_of_dvd _ hpq (splitting_field.splits (p * q)) (dvd_mul_right p q)⟩,
    have key : x = algebra_map (p.splitting_field) (p * q).splitting_field
      ((roots_equiv_roots p _).inv_fun ⟨x, multiset.mem_to_finset.mpr h⟩) :=
      subtype.ext_iff.mp (equiv.apply_symm_apply (roots_equiv_roots p _) ⟨x, _⟩).symm,
    rw [key, ←alg_equiv.restrict_normal_commutes, ←alg_equiv.restrict_normal_commutes],
    exact congr_arg _ (alg_equiv.ext_iff.mp hfg.1 _) },
  { change f x = g x,
    haveI : fact (q.splits (algebra_map F (p * q).splitting_field)) :=
      ⟨splits_of_splits_of_dvd _ hpq (splitting_field.splits (p * q)) (dvd_mul_left q p)⟩,
    have key : x = algebra_map (q.splitting_field) (p * q).splitting_field
      ((roots_equiv_roots q _).inv_fun ⟨x, multiset.mem_to_finset.mpr h⟩) :=
      subtype.ext_iff.mp (equiv.apply_symm_apply (roots_equiv_roots q _) ⟨x, _⟩).symm,
    rw [key, ←alg_equiv.restrict_normal_commutes, ←alg_equiv.restrict_normal_commutes],
    exact congr_arg _ (alg_equiv.ext_iff.mp hfg.2 _) },
  { rwa [ne.def, mul_eq_zero, map_eq_zero, map_eq_zero, ←mul_eq_zero] }
end

lemma splits_in_splitting_field_of_comp (hq : q.nat_degree ≠ 0) :
  p.splits (algebra_map F (p.comp q).splitting_field) :=
begin
  let P : polynomial F → Prop := λ r, r.splits (algebra_map F (r.comp q).splitting_field),
  have key1 : ∀ {r : polynomial F}, irreducible r → P r,
  { intros r hr,
    by_cases hr' : nat_degree r = 0,
    { exact splits_of_nat_degree_le_one _ (le_trans (le_of_eq hr') zero_le_one) },
    obtain ⟨x, hx⟩ := exists_root_of_splits _ (splitting_field.splits (r.comp q))
      (λ h, hr' ((mul_eq_zero.mp (nat_degree_comp.symm.trans
        (nat_degree_eq_of_degree_eq_some h))).resolve_right hq)),
    rw [←aeval_def, aeval_comp] at hx,
    have h_normal : normal F (r.comp q).splitting_field := splitting_field.normal (r.comp q),
    have qx_int := normal.is_integral h_normal (aeval x q),
    exact splits_of_splits_of_dvd _
      (minpoly.ne_zero qx_int)
      (normal.splits h_normal _)
      (dvd_symm_of_irreducible (minpoly.irreducible qx_int) hr (minpoly.dvd F _ hx)) },
  have key2 : ∀ {p₁ p₂ : polynomial F}, P p₁ → P p₂ → P (p₁ * p₂),
  { intros p₁ p₂ hp₁ hp₂,
    by_cases h₁ : p₁.comp q = 0,
    { cases comp_eq_zero_iff.mp h₁ with h h,
      { rw [h, zero_mul],
        exact splits_zero _ },
      { exact false.rec _ (hq (by rw [h.2, nat_degree_C])) } },
    by_cases h₂ : p₂.comp q = 0,
    { cases comp_eq_zero_iff.mp h₂ with h h,
      { rw [h, mul_zero],
        exact splits_zero _ },
      { exact false.rec _ (hq (by rw [h.2, nat_degree_C])) } },
    have key := mul_splits_in_splitting_field_of_mul h₁ h₂ hp₁ hp₂,
    rwa ← mul_comp at key },
  exact wf_dvd_monoid.induction_on_irreducible p (splits_zero _)
    (λ _, splits_of_is_unit _) (λ _ _ _ h, key2 (key1 h)),
end

/-- The restriction homomorphism from the Galois group of a homomorphism -/
def restrict_comp (hq : q.nat_degree ≠ 0) : (p.comp q).gal →* p.gal :=
@restrict F _ p _ _ _ ⟨splits_in_splitting_field_of_comp p q hq⟩

lemma restrict_comp_surjective (hq : q.nat_degree ≠ 0) :
  function.surjective (restrict_comp p q hq) :=
by simp only [restrict_comp, restrict_surjective]

variables {p q}

lemma card_of_separable (hp : p.separable) :
  fintype.card p.gal = finrank F p.splitting_field :=
begin
  haveI : is_galois F p.splitting_field := is_galois.of_separable_splitting_field hp,
  exact is_galois.card_aut_eq_finrank F p.splitting_field,
end

lemma prime_degree_dvd_card [char_zero F] (p_irr : irreducible p) (p_deg : p.nat_degree.prime) :
  p.nat_degree ∣ fintype.card p.gal :=
begin
  rw gal.card_of_separable p_irr.separable,
  have hp : p.degree ≠ 0 :=
    λ h, nat.prime.ne_zero p_deg (nat_degree_eq_zero_iff_degree_le_zero.mpr (le_of_eq h)),
  let α : p.splitting_field := root_of_splits (algebra_map F p.splitting_field)
    (splitting_field.splits p) hp,
  have hα : is_integral F α :=
    (is_algebraic_iff_is_integral F).mp (algebra.is_algebraic_of_finite α),
  use finite_dimensional.finrank F⟮α⟯ p.splitting_field,
  suffices : (minpoly F α).nat_degree = p.nat_degree,
  { rw [←finite_dimensional.finrank_mul_finrank F F⟮α⟯ p.splitting_field,
        intermediate_field.adjoin.finrank hα, this] },
  suffices : minpoly F α ∣ p,
  { have key := dvd_symm_of_irreducible (minpoly.irreducible hα) p_irr this,
    apply le_antisymm,
    { exact nat_degree_le_of_dvd this p_irr.ne_zero },
    { exact nat_degree_le_of_dvd key (minpoly.ne_zero hα) } },
  apply minpoly.dvd F α,
  rw [aeval_def, map_root_of_splits _ (splitting_field.splits p) hp],
end

lemma splits_ℚ_ℂ {p : polynomial ℚ} : fact (p.splits (algebra_map ℚ ℂ)) :=
⟨is_alg_closed.splits_codomain p⟩

local attribute [instance] splits_ℚ_ℂ

/-- The number of complex roots equals the number of real roots plus
  the number of roots not fixed by complex conjugation -/
lemma gal_action_hom_bijective_of_prime_degree_aux {p : polynomial ℚ} :
  (p.root_set ℂ).to_finset.card = (p.root_set ℝ).to_finset.card +
  (gal_action_hom p ℂ (restrict p ℂ (complex.conj_alg_equiv.restrict_scalars ℚ))).support.card :=
begin
  by_cases hp : p = 0,
  { simp_rw [hp, root_set_zero, set.to_finset_eq_empty_iff.mpr rfl, finset.card_empty, zero_add],
    refine eq.symm (nat.le_zero_iff.mp ((finset.card_le_univ _).trans (le_of_eq _))),
    simp_rw [hp, root_set_zero, fintype.card_eq_zero_iff],
    exact λ h, (set.mem_empty_eq h.val).mp h.mem },
  have inj : function.injective (is_scalar_tower.to_alg_hom ℚ ℝ ℂ) := (algebra_map ℝ ℂ).injective,
  rw [←finset.card_image_of_injective _ subtype.coe_injective,
      ←finset.card_image_of_injective _ inj],
  let a : finset ℂ := _,
  let b : finset ℂ := _,
  let c : finset ℂ := _,
  change a.card = b.card + c.card,
  have ha : ∀ z : ℂ, z ∈ a ↔ aeval z p = 0 :=
  λ z, by rw [set.mem_to_finset, mem_root_set hp],
  have hb : ∀ z : ℂ, z ∈ b ↔ aeval z p = 0 ∧ z.im = 0,
  { intro z,
    simp_rw [finset.mem_image, exists_prop, set.mem_to_finset, mem_root_set hp],
    split,
    { rintros ⟨w, hw, rfl⟩,
      exact ⟨by rw [aeval_alg_hom_apply, hw, alg_hom.map_zero], rfl⟩ },
    { rintros ⟨hz1, hz2⟩,
      have key : is_scalar_tower.to_alg_hom ℚ ℝ ℂ z.re = z := by { ext, refl, rw hz2, refl },
      exact ⟨z.re, inj (by rwa [←aeval_alg_hom_apply, key, alg_hom.map_zero]), key⟩ } },
  have hc0 : ∀ w : p.root_set ℂ, gal_action_hom p ℂ
    (restrict p ℂ (complex.conj_alg_equiv.restrict_scalars ℚ)) w = w ↔ w.val.im = 0,
  { intro w,
    rw [subtype.ext_iff, gal_action_hom_restrict],
    exact complex.eq_conj_iff_im },
  have hc : ∀ z : ℂ, z ∈ c ↔ aeval z p = 0 ∧ z.im ≠ 0,
  { intro z,
    simp_rw [finset.mem_image, exists_prop],
    split,
    { rintros ⟨w, hw, rfl⟩,
      exact ⟨(mem_root_set hp).mp w.2, mt (hc0 w).mpr (equiv.perm.mem_support.mp hw)⟩ },
    { rintros ⟨hz1, hz2⟩,
      exact ⟨⟨z, (mem_root_set hp).mpr hz1⟩,
        equiv.perm.mem_support.mpr (mt (hc0 _).mp hz2), rfl⟩ } },
  rw ← finset.card_disjoint_union,
  { apply congr_arg finset.card,
    simp_rw [finset.ext_iff, finset.mem_union, ha, hb, hc],
    tauto },
  { intro z,
    rw [finset.inf_eq_inter, finset.mem_inter, hb, hc],
    tauto },
  { apply_instance },
end

/-- An irreducible polynomial of prime degree with two non-real roots has full Galois group -/
lemma gal_action_hom_bijective_of_prime_degree
  {p : polynomial ℚ} (p_irr : irreducible p) (p_deg : p.nat_degree.prime)
  (p_roots : fintype.card (p.root_set ℂ) = fintype.card (p.root_set ℝ) + 2) :
  function.bijective (gal_action_hom p ℂ) :=
begin
  have h1 : fintype.card (p.root_set ℂ) = p.nat_degree,
  { simp_rw [root_set_def, fintype.card_coe],
    rw [multiset.to_finset_card_of_nodup, ←nat_degree_eq_card_roots],
    { exact is_alg_closed.splits_codomain p },
    { exact nodup_roots ((separable_map (algebra_map ℚ ℂ)).mpr p_irr.separable) } },
  have h2 : fintype.card p.gal = fintype.card (gal_action_hom p ℂ).range :=
  fintype.card_congr (monoid_hom.of_injective (gal_action_hom_injective p ℂ)).to_equiv,
  let conj := restrict p ℂ (complex.conj_alg_equiv.restrict_scalars ℚ),
  refine ⟨gal_action_hom_injective p ℂ, λ x, (congr_arg (has_mem.mem x)
    (show (gal_action_hom p ℂ).range = ⊤, from _)).mpr (subgroup.mem_top x)⟩,
  apply equiv.perm.subgroup_eq_top_of_swap_mem,
  { rwa h1 },
  { rw [h1, ←h2],
    exact prime_degree_dvd_card p_irr p_deg },
  { exact ⟨conj, rfl⟩ },
  { rw ← equiv.perm.card_support_eq_two,
    apply nat.add_left_cancel,
    rw [←p_roots, ←set.to_finset_card (root_set p ℝ), ←set.to_finset_card (root_set p ℂ)],
    exact gal_action_hom_bijective_of_prime_degree_aux.symm },
end

end gal

end polynomial


/-
Copyright (c) 2020 Chrisil Ouseph. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chrisil Ouseph
-/

import analysis.complex.basic tactic

/-!
# Polygonally-Connected & Step-Connected Sets in Complex Numbers and Regions

This file defines polygonal-connectedness and step-connectedness (polygonal-connectedness using
only horizontal and vertical line segments) for pairs of points as well as subsets of ℂ along with
regions (domains) in topological spaces. We prove basic related theorems, like step-connectedness
implies polygonal-connectedness and all regions in ℂ are step-connected.

## Important definitions

* `are_poly_connected` : polygonal-connectedness for pairs of complex numbers
* `is_poly_connected` : polygonal-connectedness for subsets of complex numbers
* `are_step_connected` : step-connectedness for pairs of complex numbers
* `is_step_connected` : step-connectedness for subsets of complex numbers
* `is_region` : regions (also called domains, i.e. open and connected sets) of a topological space

## Implementation notes

All the above properties are implemented as `Prop`. The pairwise properties are implemented as
inductive types, producing a `Prop`.

## References

J. Bak, D. J. Newman : *Complex Analysis* : https://www.springer.com/gp/book/9781441972873
-/

open complex set
variables z1 z2 z3: ℂ
variable A : set ℂ
variables l : list ℂ
variable rp : {r : ℝ // 0 < r}

/-- The closed line segment between two complex numbers -/
def cIcc := {z : ℂ | ∃ t ∈ set.Icc (0 : ℝ) 1, z = z1 + ↑t * (z2 - z1)}

lemma cIcc_endpoints : z1 ∈ cIcc z1 z2 ∧ z2 ∈ cIcc z1 z2 :=
⟨⟨0, left_mem_Icc.mpr zero_le_one, by norm_cast; ring⟩,
⟨1, right_mem_Icc.mpr zero_le_one, by norm_cast; ring⟩⟩

lemma cIcc_self : cIcc z1 z1 = {z1} :=
begin
  refine antisymm _ (singleton_subset_iff.mpr (cIcc_endpoints z1 z1).left),
  rintros z ⟨t, ht, rfl⟩,
  rw mem_singleton_iff,
  ring
end

lemma cIcc_symm : cIcc z1 z2 = cIcc z2 z1 :=
begin
  apply subset.antisymm;
  { rintros z ⟨t, ⟨ht0, ht1⟩, rfl⟩,
    refine ⟨1-t, ⟨_, _⟩, _⟩;
      try { linarith  },
    push_cast,
    ring  }
end

/-- Two complex numbers are polygonally-connected in a set `A` iff
the line segment joining them is in `A` or by transitivity. -/
inductive are_poly_connected (A : set ℂ) : ℂ → ℂ → Prop
| line {z1 z2 : ℂ} : cIcc z1 z2 ⊆ A → are_poly_connected z1 z2
| poly_trans {z1 z2 z3 : ℂ} :
  are_poly_connected z1 z3 → are_poly_connected z3 z2 → are_poly_connected z1 z2

open are_poly_connected

lemma are_poly_connected_refl {A z1} (h : z1 ∈ A) : are_poly_connected A z1 z1 :=
by apply line; rwa [cIcc_self, singleton_subset_iff]

lemma are_poly_connected_symm {A z1 z2} (h12 : are_poly_connected A z1 z2) :
  are_poly_connected A z2 z1 :=
begin
  induction h12,
  case line : z3 z4 hl
  { apply line,
    rwa cIcc_symm },
  case poly_trans : _ _ _ _ _ h53 h45
  { exact poly_trans h45 h53  }
end

lemma are_poly_connected_trans {z1 z2 z3 A}
  (h12 : are_poly_connected A z1 z2) (h23 : are_poly_connected A z2 z3) :
  are_poly_connected A z1 z3 := poly_trans h12 h23

lemma are_poly_connected_mono {z1 z2 A B} (hs : A ⊆ B) (h : are_poly_connected A z1 z2) :
  are_poly_connected B z1 z2 :=
begin
  induction h,
  case line : z3 z4 hl
  { exact line (set.subset.trans hl hs) },
  case poly_trans : z3 z4 z5 h35 h54 h53 h45
  { exact poly_trans h53 h45  }
end
/-- A set is polygonally-connected if each pair of points in it is. -/
def is_poly_connected := ∀ {z1 z2}, z1 ∈ A → z2 ∈ A → are_poly_connected A z1 z2

/-- Two complex numbers are step-connected in a set `A` if they are connected by a
horizontal or vertical line in `A` or by transitivity. -/
inductive are_step_connected (A : set ℂ) : ℂ → ℂ → Prop
| hor {z1 z2 : ℂ} : z1.im = z2.im → cIcc z1 z2 ⊆ A → are_step_connected z1 z2
| ver {z1 z2 : ℂ} : z1.re = z2.re → cIcc z1 z2 ⊆ A → are_step_connected z1 z2
| step_trans {z1 z2 z3 : ℂ} :
  are_step_connected z1 z3 → are_step_connected z3 z2 → are_step_connected z1 z2

open are_step_connected

lemma are_step_connected_refl {A z1} (h : z1 ∈ A) : are_step_connected A z1 z1 :=
by apply hor rfl; rwa [cIcc_self, singleton_subset_iff]

lemma are_step_connected_trans {z1 z2 z3 A} (h12 : are_step_connected A z1 z2)
(h23 : are_step_connected A z2 z3) : are_step_connected A z1 z3 := step_trans h12 h23

lemma are_step_connected_symm {A z1 z2} (h12 : are_step_connected A z1 z2) :
  are_step_connected A z2 z1 :=
begin
  induction h12,
  case hor : z3 z4 hi hl
  { apply hor hi.symm,
    rwa cIcc_symm },
  case ver : z3 z4 hr hl
  { apply ver hr.symm,
    rwa cIcc_symm },
  case step_trans : z3 z4 z5 h35 h54 h53 h45
  { exact step_trans h45 h53  }
end

lemma are_step_connected_mem {z1 z2 A} (h : are_step_connected A z1 z2) : z1 ∈ A ∧ z2 ∈ A:=
begin
  induction h,
  case hor : z3 z4 hi hl
  { use [hl (cIcc_endpoints _ _).left, hl (cIcc_endpoints _ _).right] },
  case ver : z3 z4 hr hl
  { use [hl (cIcc_endpoints _ _).left, hl (cIcc_endpoints _ _).right] },
  case step_trans : z3 z4 z5 h35 h54 h53 h45
  { use [h53.left, h45.right] }
end

lemma are_poly_connected_of_are_step_connected {A z1 z2}
  (h12 : are_step_connected A z1 z2) : are_poly_connected A z1 z2 :=
begin
  induction h12,
  case hor : z3 z4 hi hl
  { exact line hl },
  case ver : z3 z4 hr hl
  { exact line hl },
  case step_trans : _ _ _ _ _ h1 h2
  { exact are_poly_connected_trans h1 h2  }
end

lemma are_step_connected_mono {z1 z2 A B} (hs : A ⊆ B) (h : are_step_connected A z1 z2):
  are_step_connected B z1 z2 :=
begin
  induction h,
  case hor : z3 z4 hi hl
  { exact hor hi (set.subset.trans hl hs) },
  case ver : z3 z4 hr hl
  { exact ver hr (set.subset.trans hl hs) },
  case step_trans : _ _ _ _ _ h1 h2
  { exact step_trans h1 h2  }
end

/-- A set is step-connected if each pair of points in it is. -/
def is_step_connected := ∀ {z1 z2}, z1 ∈ A → z2 ∈ A → are_step_connected A z1 z2

lemma is_poly_connected_of_is_step_connected {A} (h : is_step_connected A) :
  is_poly_connected A := λ x y hx hy, are_poly_connected_of_are_step_connected (h hx hy)

open metric

lemma is_step_connected_ball : is_step_connected (ball z1 ↑rp) :=
begin
  suffices heq : ∀ z ∈ ball z1 ↑rp, are_step_connected (ball z1 ↑rp) z z1,
  { intros x y hx hy,
    exact are_step_connected_trans (heq x hx) (are_step_connected_symm (heq y hy))},
  intros z hz,
  apply @step_trans _ _ _ ⟨z.re, z1.im⟩,
  { refine ver rfl _,
    rintro w ⟨t, ⟨ht0, ht1⟩, rfl⟩,
    rw [mem_ball, dist_eq] at hz ⊢,
    change abs (z + _ * ⟨z.re - z.re, (z1 - z).im⟩ - z1) < _,
    rw [sub_self, ←sub_add_eq_add_sub, ←re_add_im ⟨0, _⟩],
    show abs (z - _ + _ * (0 + ↑(z1 - z).im * I)) < _,
    rw [zero_add, mul_mul_div (_ * I) (two_ne_zero'), mul_right_comm _ I],
    norm_cast,
    rw [mul_comm (im _), ←sub_conj, ←mul_one (z-z1), mul_left_comm,
      ←div_eq_mul_one_div, sub_mul (z1-z), ←add_sub_assoc, ←neg_sub z,
      ←neg_mul_eq_neg_mul, ←sub_eq_add_neg, ←mul_sub, neg_sub z, sub_eq_add_neg],
    apply lt_of_le_of_lt (complex.abs_add _ _),
    norm_cast,
    rw [complex.abs_neg, complex.abs_mul, complex.abs_mul,
      abs_conj, complex.abs_sub z1, ←mul_add, ←mul_one ↑rp],
    refine mul_lt_mul hz _ _ (le_of_lt rp.2);
    { rw [complex.abs_of_nonneg, complex.abs_of_nonneg];
      { linarith  }}},
  refine hor rfl _,
  rintro w ⟨t, ⟨ht0, ht1⟩, rfl⟩,
  rw [mem_ball, dist_eq] at *,
  rw [←sub_add_eq_add_sub],
  change abs ((⟨(z - z1).re, z1.im - z1.im⟩ : ℂ) + _ * ⟨(z1 - z).re, z1.im - z1.im⟩) < _,
  rw [sub_self],
  change complex.abs (↑(z - z1).re + _ * ↑(z1 - z).re) < _,
  norm_cast,
  rw [←one_mul (z - z1).re, ←neg_sub z, neg_re, ←neg_mul_eq_mul_neg, neg_mul_eq_neg_mul],
  rw [←add_mul, ←one_mul ↑rp, of_real_mul, complex.abs_mul, abs_of_real (re _)],
  apply mul_lt_mul' _ (lt_of_le_of_lt (abs_re_le_abs _) hz) (abs_nonneg _) (zero_lt_one),
  rw [complex.abs_of_nonneg];
  { linarith  }
end

/-- An open and preconnected set is called a region. -/
def is_region := is_open A ∧ is_preconnected A

theorem region_step_connected {A} : is_region A → is_step_connected A :=
begin
  classical,
  rintro ⟨hao, hap⟩ z1 z2 h1 h2,
  let C := {z | are_step_connected A z1 z},
  let D := A ∩ {z | ¬ are_step_connected A z1 z},
  by_contra hw,
  obtain ⟨_, _, _, _, _⟩ := hap C D _ _ _ ⟨_, ⟨h1, are_step_connected_refl h1⟩⟩ ⟨_, h2, ⟨h2, hw⟩⟩,
      { contradiction },
    { rw is_open_iff,
      rintro x hxz1,
      rcases (is_open_iff.mp hao) x (are_step_connected_mem hxz1).right with ⟨d, hdp, hb⟩,
      use [d, hdp],
      intros y hy,
      exact are_step_connected_trans hxz1 (are_step_connected_mono hb $
        is_step_connected_ball x ⟨d, hdp⟩ (mem_ball_self hdp) hy) },
  { rw is_open_iff,
    rintro x ⟨hx, hxz1⟩,
    rcases (is_open_iff.mp hao) x hx with ⟨d, hdp, hb⟩,
    use [d, hdp],
    intros y hy,
    use [hb hy],
    intro hw,
    replace hw := step_trans hw (are_step_connected_symm (are_step_connected_mono hb $
      is_step_connected_ball x ⟨d, hdp⟩ (mem_ball_self hdp) hy)),
    contradiction },
  intros z hz,
  by_cases hc : are_step_connected A z1 z,
  { exact or.inl hc  },
  exact or.inr ⟨hz, hc⟩,
end

lemma is_poly_connected_ball : is_poly_connected (ball z1 ↑rp) :=
  @is_poly_connected_of_is_step_connected (ball z1 ↑rp) (@is_step_connected_ball z1 rp)

lemma is_poly_connected_region (hA : is_region A) : is_poly_connected A :=
  @is_poly_connected_of_is_step_connected A (@region_step_connected A hA)


/-
Copyright (c) 2022 Kevin H. Wilson. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kevin H. Wilson

! This file was ported from Lean 3 source module order.filter.curry
! leanprover-community/mathlib commit d6fad0e5bf2d6f48da9175d25c3dc5706b3834ce
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Order.Filter.Prod

/-!
# Curried Filters

This file provides an operation (`filter.curry`) on filters which provides the equivalence
`∀ᶠ a in l, ∀ᶠ b in l', p (a, b) ↔ ∀ᶠ c in (l.curry l'), p c` (see `filter.eventually_curry_iff`).

To understand when this operation might arise, it is helpful to think of `∀ᶠ` as a combination of
the quantifiers `∃ ∀`. For instance, `∀ᶠ n in at_top, p n ↔ ∃ N, ∀ n ≥ N, p n`. A curried filter
yields the quantifier order `∃ ∀ ∃ ∀`. For instance,
`∀ᶠ n in at_top.curry at_top, p n ↔ ∃ M, ∀ m ≥ M, ∃ N, ∀ n ≥ N, p (m, n)`.

This is different from a product filter, which instead yields a quantifier order `∃ ∃ ∀ ∀`. For
instance, `∀ᶠ n in at_top ×ᶠ at_top, p n ↔ ∃ M, ∃ N, ∀ m ≥ M, ∀ n ≥ N, p (m, n)`. This makes it
clear that if something eventually occurs on the product filter, it eventually occurs on the curried
filter (see `filter.curry_le_prod` and `filter.eventually.curry`), but the converse is not true.

Another way to think about the curried versus the product filter is that tending to some limit on
the product filter is a version of uniform convergence (see `tendsto_prod_filter_iff`) whereas
tending to some limit on a curried filter is just iterated limits (see `tendsto.curry`).

## Main definitions

* `Filter.curry`: A binary operation on filters which represents iterated limits

## Main statements

* `Filter.eventually_curry_iff`: An alternative definition of a curried filter
* `Filter.curry_le_prod`: Something that is eventually true on the a product filter is eventually
   true on the curried filter

## Tags

uniform convergence, curried filters, product filters
-/

namespace Filter

variable {α β γ : Type _}

/-- This filter is characterized by `Filter.eventually_curry_iff`:
`(∀ᶠ (x : α × β) in f.curry g, p x) ↔ ∀ᶠ (x : α) in f, ∀ᶠ (y : β) in g, p (x, y)`. Useful
in adding quantifiers to the middle of `tendsto`s. See
`has_fderiv_at_of_tendsto_uniformly_on_filter`. -/
def curry (f : Filter α) (g : Filter β) : Filter (α × β) where
  sets := { s | ∀ᶠ a : α in f, ∀ᶠ b : β in g, (a, b) ∈ s }
  univ_sets := by simp only [Set.mem_setOf_eq, Set.mem_univ, eventually_true]
  sets_of_superset := fun hx hxy =>
    hx.mono fun a ha => ha.mono fun b hb => Set.mem_of_subset_of_mem hxy hb
  inter_sets := fun hx hy =>
    (hx.and hy).mono fun a ha => (ha.1.and ha.2).mono fun b hb => hb
#align filter.curry Filter.curry

theorem eventually_curry_iff {f : Filter α} {g : Filter β} {p : α × β → Prop} :
    (∀ᶠ x : α × β in f.curry g, p x) ↔ ∀ᶠ x : α in f, ∀ᶠ y : β in g, p (x, y) :=
  Iff.rfl
#align filter.eventually_curry_iff Filter.eventually_curry_iff

theorem curry_le_prod {f : Filter α} {g : Filter β} : f.curry g ≤ f.prod g :=
  fun _ => Eventually.curry
#align filter.curry_le_prod Filter.curry_le_prod

theorem Tendsto.curry {f : α → β → γ} {la : Filter α} {lb : Filter β} {lc : Filter γ}
    (h : ∀ᶠ a in la, Tendsto (fun b : β => f a b) lb lc) : Tendsto (↿f) (la.curry lb) lc :=
  fun _s hs => h.mono fun _a ha =>  ha hs
#align filter.tendsto.curry Filter.Tendsto.curry

end Filter


/-
Chapter 5: Models & Counter Examples
Author: Billy Price
-/
import definitions chapter4
import data.finset

namespace nat_deduction

/-- A model is uniquely determined by its valuation of atoms-/
@[reducible]
def Model := finset ℕ

/-- The evaluation of a Model on a formula -/
@[simp]
def Form.eval_model (M : Model) : Form → bool
| ⊥         := ff
| (n : ℕ)   := n ∈ M
| (A ⋀ B)   := Form.eval_model A && Form.eval_model B
| (A ⋁ B)   := Form.eval_model A || Form.eval_model B
| (A ⟹ B) := (bnot $ Form.eval_model A) || Form.eval_model B

notation M`[`A`]` := Form.eval_model M A

/--sat M X means M evaluates to true on every formula in X-/
def sat (M : Model) (X : set Form) : Prop := ∀ A ∈ X, M[A] = tt

-- Some simplification theorems, so that something like
-- sat M {A,B,C} simplifies to M[A] = tt ∧ M[B] = tt ∧ M[C] = tt

@[simp]
theorem sat_insert {M : Model} {X : set Form} {A : Form} :
  sat M (insert A X) ↔ M[A] = tt ∧ sat M X := set.ball_insert_iff

@[simp]
theorem sat_singleton {M : Model} {A : Form} :
  sat M {A} ↔ M[A] = tt :=
by split; tidy

@[simp]
theorem sat_empty {M : Model} : sat M ∅ :=
begin
  intros A mem, simp at *, contradiction
end

@[simp]
theorem sat_union {M : Model} {X Y : set Form} : sat M (X ∪ Y) ↔ (sat M X ∧ sat M Y) :=
begin
  split,
    intro satXY,
    split;
    intros A Amem;
    apply satXY,
    exact set.mem_union_left _ Amem,
    exact set.mem_union_right _ Amem,
  rintro ⟨satX, satY⟩, tidy
end

/-- The type of counterexamples of an argument X ≻ A-/
def counterexample (X : set Form) (A : Form) := {M // sat M X ∧ M[A] = ff}

/-- Validity according to boolean models-/
def boolean.valid (X : set Form) (A : Form) : Prop := ∀ M : Model, (sat M X → M[A] = tt)
@[reducible]
def boolean.invalid (X : set Form) (A : Form) : Prop := ¬ (boolean.valid X A)

infix ` ⊨ `:60 := boolean.valid
infix ` ⊭ `:60 := boolean.invalid

/-- Boolean unsatisfiability of a set X of formulas -/
def unsat (X : set Form) : Prop := X ⊨ ⊥

/--The textbooks definition of validity (the right side of this equivalence)
is inconvenient to work with, this theorem proves the equivalence-/
theorem boolean.valid_iff_no_counterexample (X : set Form) (A : Form) : X ⊨ A ↔ ¬ ∃ M, sat M X ∧ M[A] = ff :=
begin
  split,
    rintros h ⟨M,hX,hnA⟩,
    apply absurd hnA, simp,
    exact h M hX,
  intros hA N NsatX,
  by_contradiction nA,
  apply hA,
  use N, tidy,
end

/-- Any counterexample gives a proof of invalidity -/
def invalid_of_counterexample {X : set Form} {A : Form} : counterexample X A → X ⊭ A :=
begin
  rintro ⟨M, MX, MA⟩,
  intro valid,
  apply absurd MA, simp,
  exact valid M MX
end

end nat_deduction

meta def tactic.interactive.by_counterexample : tactic unit :=
  do `[apply nat_deduction.invalid_of_counterexample]

namespace nat_deduction

section

variables {X Y : set Form}
variables {A B C : Form}

theorem boolean.valid_refl : {A} ⊨ A :=
begin
  intros _ _, simp * at *,
end

theorem boolean.valid_weakening : X ⊨ A → X ∪ Y ⊨ A :=
begin
  intros XbA M MsatA,
  apply XbA,
  simp * at *,
end

theorem boolean.valid_cut (A : Form) : X ⊨ A → Y ∪ {A} ⊨ B → X ∪ Y ⊨ B :=
begin
  intros XbA YAbB M MsatXY,
  apply YAbB, simp * at *,
  apply XbA, tidy,
end

theorem boolean.compactness : X ⊨ A → ∃ X' : finset Form, ↑X' ⊆ X ∧ ↑X' ⊨ A := sorry

theorem boolean.and_iff : X ⊨ A ⋀ B ↔ X ⊨A ∧ X ⊨ B :=
begin
  split,
    intro hAB,
    split;
    intros M MsatX;
    specialize hAB M MsatX; simp * at *,
  rintro ⟨hA,hB⟩,
  intros M MsatX,
  specialize hA M MsatX,
  specialize hB M MsatX,
  simp * at *
end

theorem boolean.imp_iff : X ⊨ A ⟹ B ↔ X ∪ {A} ⊨ B :=
begin
  split,
    intros XbAB M Msat, simp at *,
    specialize XbAB M Msat.2,
    simp * at *,
  intros XAbB M Msat, simp at *,
  specialize XAbB M,
  by_cases (M[A] = tt),
    apply or.inr,
    apply XAbB,
    simp, split; assumption,
  simp at *, exact or.inl (by assumption)
end

theorem boolean.from_or_iff : X ∪ {A ⋁ B} ⊨ C ↔ (X ∪ {A} ⊨ C ∧ X ∪ {B} ⊨ C) :=
begin
  split,
    intro XABbC, split; intros M Msat; apply XABbC; simp * at *,
  rintros ⟨XAbC,XBbC⟩ M Msat,
  specialize XAbC M,
  specialize XBbC M,
  simp * at *, tidy,
end

end

section chapter_5_basic_questions

variables {p q r : ℕ}
variables {X : set Form}
variables {A B : Form}

example {q ≠ p}: {¬(p ⋀ q)} ⊭ (¬p) ⋀ (¬q) :=
begin
  by_counterexample,
  use {p}, simp * at *
end

example : {p ⟹ q, q ⟹ r} ⊨ p ⟹ r :=
begin
  intros M Msat, simp * at *,
  cases Msat.1 with hnp hq,
  exact or.inl hnp,
  cases Msat.2 with hnq hr,
  contradiction,
  exact or.inr hr
end

example {h : p ≠ q ∧ p ≠ r} : {p ⟹ q, q ⟹ r} ⊭ ¬p ⟹ ¬r :=
begin
  by_counterexample,
  use {q,r}, simp * at *
end

example : {¬ (p ⟹ q)} ⊨ p :=
  by intros _ _; simp * at *

example : {¬ (p ⋀ q)} ⊨ (¬ p) ⋁ (¬ q) :=
  by intros M Msat; simp * at *

example : ∅ ⊨ ((p ⟹ q) ⟹ p) ⟹ p :=
begin
  intros M Msat, simp * at *,
  by_cases p ∈ M; simp *
end

-- Question 3

-- If A ⊨ B then ¬ B ⊨ ¬ A
theorem boolean.contrapositive : {A} ⊨ B → {¬B} ⊨ ¬A :=
begin
  intros AbB M Msat,
  by_contradiction h,
  specialize AbB M,
  simp at *,
  specialize AbB h,
  apply absurd Msat, simp * at *
end

-- If A ⊨ B then its not true that B ⊨ A
-- False, take A = B
example : ⊥ ⊨ ⊥ → ⊥ ⊨ ⊥ := id

-- Either A ⊨ B or B ⊨ A
-- False (with disinct atoms)
example {h : p ≠ q} : ¬ ({p} ⊨ q ∨ {q} ⊨ p) :=
begin
  suffices : ∀ {a b : ℕ}, a ≠ b → {a} ⊭ b,
    rintro (hpq | hqp),
    apply this (by assumption) hpq,
    apply this (by symmetry;assumption) hqp,
  intros a b anb,
  by_counterexample, use {a}, tidy
end

theorem boolean.contract_pos_to_neg : X ∪ {A} ⊨ ¬A ↔ X ⊨ ¬A :=
begin
  split,
    intros XAbnA M Msat,
    specialize XAbnA M,
    simp * at *, { cases M[A], tidy, },
  intros XbnA M Msat, simp * at *,
  apply absurd XbnA,
  by_counterexample, use M, tidy
end

-- X ⊨ A ⋁ B iff X ⊨ A or X ⊨ B
-- False
example {h : p ≠ q}: ¬ ({p ⋁ q} ⊨ p ⋁ q ↔ (({p ⋁ q} ⊨ p) ∨ ({p ⋁ q} ⊨ q))) :=
begin
  intro h,
  cases h.1 (boolean.valid_refl) with k₁ k₂,
  apply absurd k₁,
  by_counterexample, use {q}, simp * at *,
  apply absurd k₂,
  by_counterexample, use {p}, simp * at *, tidy
end

/-TODO: Question 4-/

/-TODO: Challenge Questions-/

end chapter_5_basic_questions

end nat_deduction