/-
Copyright (c) 2021 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Aaron Anderson, Alex J. Best, Johan Commelin, Eric Rodriguez, Ruben Van de Velde
-/

import algebra.char_p.algebra
import field_theory.finite.basic
import field_theory.galois

/-!
# Galois fields

If `p` is a prime number, and `n` a natural number,
then `galois_field p n` is defined as the splitting field of `X^(p^n) - X` over `zmod p`.
It is a finite field with `p ^ n` elements.

## Main definition

* `galois_field p n` is a field with `p ^ n` elements

## Main Results

- `galois_field.alg_equiv_galois_field`: Any finite field is isomorphic to some Galois field
- `finite_field.alg_equiv_of_card_eq`: Uniqueness of finite fields : algebra isomorphism
- `finite_field.ring_equiv_of_card_eq`: Uniqueness of finite fields : ring isomorphism

-/

noncomputable theory

open polynomial
open_locale polynomial

lemma galois_poly_separable {K : Type*} [field K] (p q : ℕ) [char_p K p] (h : p ∣ q) :
  separable (X ^ q - X : K[X]) :=
begin
  use [1, (X ^ q - X - 1)],
  rw [← char_p.cast_eq_zero_iff K[X] p] at h,
  rw [derivative_sub, derivative_pow, derivative_X, h],
  ring,
end

/-- A finite field with `p ^ n` elements.
Every field with the same cardinality is (non-canonically)
isomorphic to this field. -/
@[derive field]
def galois_field (p : ℕ) [fact p.prime] (n : ℕ) :=
splitting_field (X^(p^n) - X : (zmod p)[X])

instance : inhabited (@galois_field 2 (fact.mk nat.prime_two) 1) :=
⟨37⟩

namespace galois_field
variables (p : ℕ) [fact p.prime] (n : ℕ)

instance : algebra (zmod p) (galois_field p n) :=
splitting_field.algebra _

instance : is_splitting_field (zmod p) (galois_field p n) (X^(p^n) - X) :=
polynomial.is_splitting_field.splitting_field _

instance : char_p (galois_field p n) p :=
(algebra.char_p_iff (zmod p) (galois_field p n) p).mp (by apply_instance)

instance : fintype (galois_field p n) := by {dsimp only [galois_field],
  exact finite_dimensional.fintype_of_fintype (zmod p) (galois_field p n) }

lemma finrank {n} (h : n ≠ 0) : finite_dimensional.finrank (zmod p) (galois_field p n) = n :=
begin
  set g_poly := (X^(p^n) - X : (zmod p)[X]),
  have hp : 1 < p := (fact.out (nat.prime p)).one_lt,
  have aux : g_poly ≠ 0 := finite_field.X_pow_card_pow_sub_X_ne_zero _ h hp,
  have key : fintype.card ((g_poly).root_set (galois_field p n)) = (g_poly).nat_degree :=
    card_root_set_eq_nat_degree (galois_poly_separable p _ (dvd_pow (dvd_refl p) h))
    (splitting_field.splits g_poly),
  have nat_degree_eq : (g_poly).nat_degree = p ^ n :=
    finite_field.X_pow_card_pow_sub_X_nat_degree_eq _ h hp,
  rw nat_degree_eq at key,
  suffices : (g_poly).root_set (galois_field p n) = set.univ,
  { simp_rw [this, ←fintype.of_equiv_card (equiv.set.univ _)] at key,
    rw [@card_eq_pow_finrank (zmod p), zmod.card] at key,
    exact nat.pow_right_injective ((nat.prime.one_lt' p).out) key },
  rw set.eq_univ_iff_forall,
  suffices : ∀ x (hx : x ∈ (⊤ : subalgebra (zmod p) (galois_field p n))),
    x ∈ (X ^ p ^ n - X : (zmod p)[X]).root_set (galois_field p n),
  { simpa, },
  rw ← splitting_field.adjoin_root_set,
  simp_rw algebra.mem_adjoin_iff,
  intros x hx,
  -- We discharge the `p = 0` separately, to avoid typeclass issues on `zmod p`.
  unfreezingI { cases p, cases hp, },
  apply subring.closure_induction hx; clear_dependent x; simp_rw mem_root_set aux,
  { rintros x (⟨r, rfl⟩ | hx),
    { simp only [aeval_X_pow, aeval_X, alg_hom.map_sub],
      rw [← map_pow, zmod.pow_card_pow, sub_self], },
    { dsimp only [galois_field] at hx,
      rwa mem_root_set aux at hx, }, },
  { dsimp only [g_poly],
    rw [← coeff_zero_eq_aeval_zero'],
    simp only [coeff_X_pow, coeff_X_zero, sub_zero, ring_hom.map_eq_zero, ite_eq_right_iff,
      one_ne_zero, coeff_sub],
    intro hn,
    exact nat.not_lt_zero 1 (pow_eq_zero hn.symm ▸ hp), },
  { simp, },
  { simp only [aeval_X_pow, aeval_X, alg_hom.map_sub, add_pow_char_pow, sub_eq_zero],
    intros x y hx hy,
    rw [hx, hy], },
  { intros x hx,
    simp only [sub_eq_zero, aeval_X_pow, aeval_X, alg_hom.map_sub, sub_neg_eq_add] at *,
    rw [neg_pow, hx, char_p.neg_one_pow_char_pow],
    simp, },
  { simp only [aeval_X_pow, aeval_X, alg_hom.map_sub, mul_pow, sub_eq_zero],
    intros x y hx hy,
    rw [hx, hy], },
end

lemma card (h : n ≠ 0) : fintype.card (galois_field p n) = p ^ n :=
begin
  let b := is_noetherian.finset_basis (zmod p) (galois_field p n),
  rw [module.card_fintype b, ← finite_dimensional.finrank_eq_card_basis b, zmod.card, finrank p h],
end

theorem splits_zmod_X_pow_sub_X : splits (ring_hom.id (zmod p)) (X ^ p - X) :=
begin
  have hp : 1 < p := (fact.out (nat.prime p)).one_lt,
  have h1 : roots (X ^ p - X : (zmod p)[X]) = finset.univ.val,
  { convert finite_field.roots_X_pow_card_sub_X _,
    exact (zmod.card p).symm },
  have h2 := finite_field.X_pow_card_sub_X_nat_degree_eq (zmod p) hp,
  -- We discharge the `p = 0` separately, to avoid typeclass issues on `zmod p`.
  unfreezingI { cases p, cases hp, },
  rw [splits_iff_card_roots, h1, ←finset.card_def, finset.card_univ, h2, zmod.card],
end

/-- A Galois field with exponent 1 is equivalent to `zmod` -/
def equiv_zmod_p : galois_field p 1 ≃ₐ[zmod p] (zmod p) :=
have h : (X ^ p ^ 1 : (zmod p)[X]) = X ^ (fintype.card (zmod p)),
  by rw [pow_one, zmod.card p],
have inst : is_splitting_field (zmod p) (zmod p) (X ^ p ^ 1 - X),
  by { rw h, apply_instance },
by exactI (is_splitting_field.alg_equiv (zmod p) (X ^ (p ^ 1) - X : (zmod p)[X])).symm

variables {K : Type*} [field K] [fintype K] [algebra (zmod p) K]

theorem splits_X_pow_card_sub_X : splits (algebra_map (zmod p) K) (X ^ fintype.card K - X) :=
(finite_field.has_sub.sub.polynomial.is_splitting_field K (zmod p)).splits

lemma is_splitting_field_of_card_eq (h : fintype.card K = p ^ n) :
  is_splitting_field (zmod p) K (X ^ (p ^ n) - X) :=
h ▸ finite_field.has_sub.sub.polynomial.is_splitting_field K (zmod p)

@[priority 100]
instance {K K' : Type*} [field K] [field K'] [fintype K'] [algebra K K'] : is_galois K K' :=
begin
  obtain ⟨p, hp⟩ := char_p.exists K,
  haveI : char_p K p := hp,
  haveI : char_p K' p := char_p_of_injective_algebra_map' K K' p,
  exact is_galois.of_separable_splitting_field (galois_poly_separable p (fintype.card K')
    (let ⟨n, hp, hn⟩ := finite_field.card K' p in hn.symm ▸ dvd_pow_self p n.ne_zero)),
end

/-- Any finite field is (possibly non canonically) isomorphic to some Galois field. -/
def alg_equiv_galois_field (h : fintype.card K = p ^ n) :
  K ≃ₐ[zmod p] galois_field p n :=
by haveI := is_splitting_field_of_card_eq _ _ h; exact is_splitting_field.alg_equiv _ _

end galois_field

namespace finite_field

variables {K : Type*} [field K] [fintype K] {K' : Type*} [field K'] [fintype K']

/-- Uniqueness of finite fields:
  Any two finite fields of the same cardinality are (possibly non canonically) isomorphic-/
def alg_equiv_of_card_eq (p : ℕ) [fact p.prime] [algebra (zmod p) K] [algebra (zmod p) K']
  (hKK' : fintype.card K = fintype.card K') :
  K ≃ₐ[zmod p] K' :=
begin
  haveI : char_p K p,
  { rw ← algebra.char_p_iff (zmod p) K p, exact zmod.char_p p, },
  haveI : char_p K' p,
  { rw ← algebra.char_p_iff (zmod p) K' p, exact zmod.char_p p, },
  choose n a hK using finite_field.card K p,
  choose n' a' hK' using finite_field.card K' p,
  rw [hK,hK'] at hKK',
  have hGalK := galois_field.alg_equiv_galois_field p n hK,
  have hK'Gal := (galois_field.alg_equiv_galois_field p n' hK').symm,
  rw (nat.pow_right_injective (fact.out (nat.prime p)).one_lt hKK') at *,
  use alg_equiv.trans hGalK hK'Gal,
end

/-- Uniqueness of finite fields:
  Any two finite fields of the same cardinality are (possibly non canonically) isomorphic-/
def ring_equiv_of_card_eq (hKK' : fintype.card K = fintype.card K') : K ≃+* K' :=
begin
  choose p _char_p_K using char_p.exists K,
  choose p' _char_p'_K' using char_p.exists K',
  resetI,
  choose n hp hK using finite_field.card K p,
  choose n' hp' hK' using finite_field.card K' p',
  have hpp' : p = p', -- := eq_prime_of_eq_prime_pow
  { by_contra hne,
    have h2 := nat.coprime_pow_primes n n' hp hp' hne,
    rw [(eq.congr hK hK').mp hKK', nat.coprime_self, pow_eq_one_iff (pnat.ne_zero n')] at h2,
    exact nat.prime.ne_one hp' h2,
    all_goals {apply_instance}, },
  rw ← hpp' at *,
  haveI := fact_iff.2 hp,
  exact alg_equiv_of_card_eq p hKK',
end

end finite_field


/-
Copyright (c) 2014 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Jeremy Avigad

The rational numbers as a field generated by the integers, defined as the usual quotient.
-/
import data.int algebra.field
open int quot eq.ops

record prerat : Type :=
(num : ℤ) (denom : ℤ) (denom_pos : denom > 0)

/-
  prerat: the representations of the rationals as integers num, denom, with denom > 0.
  note: names are not protected, because it is not expected that users will open prerat.
-/

namespace prerat

/- the equivalence relation -/

definition equiv (a b : prerat) : Prop := num a * denom b = num b * denom a

infix ≡ := equiv

theorem equiv.refl [refl] (a : prerat) : a ≡ a := rfl

theorem equiv.symm [symm] {a b : prerat} (H : a ≡ b) : b ≡ a := !eq.symm H

theorem num_eq_zero_of_equiv {a b : prerat} (H : a ≡ b) (na_zero : num a = 0) : num b = 0 :=
have num a * denom b = 0, from !zero_mul ▸ na_zero ▸ rfl,
have num b * denom a = 0, from H ▸ this,
show num b = 0, from or_resolve_left (eq_zero_or_eq_zero_of_mul_eq_zero this) (ne_of_gt (denom_pos a))

theorem num_pos_of_equiv {a b : prerat} (H : a ≡ b) (na_pos : num a > 0) : num b > 0 :=
have num a * denom b > 0, from mul_pos na_pos (denom_pos b),
have num b * denom a > 0, from H ▸ this,
show num b > 0, from pos_of_mul_pos_right this (le_of_lt (denom_pos a))

theorem num_neg_of_equiv {a b : prerat} (H : a ≡ b) (na_neg : num a < 0) : num b < 0 :=
have H₁ : num a * denom b = num b * denom a, from H,
have num a * denom b < 0,     from mul_neg_of_neg_of_pos na_neg (denom_pos b),
have -(-num b * denom a) < 0,   begin rewrite [neg_mul_eq_neg_mul, neg_neg, -H₁], exact this end,
have -num b > 0, from pos_of_mul_pos_right (pos_of_neg_neg this) (le_of_lt (denom_pos a)),
neg_of_neg_pos this

theorem equiv_of_num_eq_zero {a b : prerat} (H1 : num a = 0) (H2 : num b = 0) : a ≡ b :=
by rewrite [↑equiv, H1, H2, *zero_mul]

theorem equiv.trans [trans] {a b c : prerat} (H1 : a ≡ b) (H2 : b ≡ c) : a ≡ c :=
decidable.by_cases
  (suppose num b = 0,
    have num a = 0, from num_eq_zero_of_equiv (equiv.symm H1) `num b = 0`,
    have num c = 0, from num_eq_zero_of_equiv H2 `num b = 0`,
    equiv_of_num_eq_zero `num a = 0` `num c = 0`)
  (suppose num b ≠ 0,
    have H3 : num b * denom b ≠ 0, from mul_ne_zero this (ne_of_gt (denom_pos b)),
    have H4 : (num b * denom b) * (num a * denom c) = (num b * denom b) * (num c * denom a),
      from calc
        (num b * denom b) * (num a * denom c) = (num a * denom b) * (num b * denom c) :
                    by rewrite [*mul.assoc, *mul.left_comm (num a), *mul.left_comm (num b)]
          ... = (num b * denom a) * (num b * denom c)                                 : {H1}
          ... = (num b * denom a) * (num c * denom b)                                 : {H2}
          ... = (num b * denom b) * (num c * denom a)                                 :
                    by rewrite [*mul.assoc, *mul.left_comm (denom a),
                                   *mul.left_comm (denom b), mul.comm (denom a)],
    eq_of_mul_eq_mul_left H3 H4)

theorem equiv.is_equivalence : equivalence equiv :=
  mk_equivalence equiv equiv.refl @equiv.symm @equiv.trans

definition setoid : setoid prerat :=
setoid.mk equiv equiv.is_equivalence

/- field operations -/

definition of_int (i : int) : prerat := prerat.mk i 1 !of_nat_succ_pos

definition zero : prerat := of_int 0

definition one : prerat := of_int 1

private theorem mul_denom_pos (a b : prerat) : denom a * denom b > 0 :=
mul_pos (denom_pos a) (denom_pos b)

definition add (a b : prerat) : prerat :=
prerat.mk (num a * denom b + num b * denom a) (denom a * denom b) (mul_denom_pos a b)

definition mul (a b : prerat) : prerat :=
prerat.mk (num a * num b) (denom a * denom b) (mul_denom_pos a b)

definition neg (a : prerat) : prerat :=
prerat.mk (- num a) (denom a) (denom_pos a)

definition smul (a : ℤ) (b : prerat) (H : a > 0) : prerat :=
prerat.mk (a * num b) (a * denom b) (mul_pos H (denom_pos b))

theorem of_int_add (a b : ℤ) : of_int (a + b) ≡ add (of_int a) (of_int b) :=
by esimp [equiv, one, add, of_int]; rewrite [*int.mul_one]

theorem of_int_mul (a b : ℤ) : of_int (a * b) ≡ mul (of_int a) (of_int b) :=
!equiv.refl

theorem of_int_neg (a : ℤ) : of_int (-a) ≡ neg (of_int a) :=
!equiv.refl

theorem of_int.inj {a b : ℤ} : of_int a ≡ of_int b → a = b :=
by rewrite [↑of_int, ↑equiv, *mul_one]; intros; assumption

definition inv : prerat → prerat
| inv (prerat.mk nat.zero d dp)     := zero
| inv (prerat.mk (nat.succ n) d dp) := prerat.mk d (nat.succ n) !of_nat_succ_pos
| inv (prerat.mk -[1+n] d dp)       := prerat.mk (-d) (nat.succ n) !of_nat_succ_pos

theorem equiv_zero_of_num_eq_zero {a : prerat} (H : num a = 0) : a ≡ zero :=
by rewrite [↑equiv, H, ↑zero, ↑of_int, *zero_mul]

theorem num_eq_zero_of_equiv_zero {a : prerat} : a ≡ zero → num a = 0 :=
by rewrite [↑equiv, ↑zero, ↑of_int, mul_one, zero_mul]; intro H; exact H

theorem inv_zero {d : int} (dp : d > 0) : inv (mk nat.zero d dp) = zero :=
begin rewrite [↑inv, ▸*] end

theorem inv_zero' : inv zero = zero := inv_zero (of_nat_succ_pos nat.zero)

open nat

theorem inv_of_pos {n d : int} (np : n > 0) (dp : d > 0) : inv (mk n d dp) ≡ mk d n np :=
obtain (n' : nat) (Hn' : n = of_nat n'), from exists_eq_of_nat (le_of_lt np),
have (n' > nat.zero), from lt_of_of_nat_lt_of_nat (Hn' ▸ np),
obtain (k : nat) (Hk : n' = nat.succ k), from nat.exists_eq_succ_of_lt this,
have d * n = d * nat.succ k, by rewrite [Hn', Hk],
Hn'⁻¹ ▸ (Hk⁻¹ ▸ this)

theorem inv_neg {n d : int} (np : n > 0) (dp : d > 0) : inv (mk (-n) d dp) ≡ mk (-d) n np :=
obtain (n' : nat) (Hn' : n = of_nat n'), from exists_eq_of_nat (le_of_lt np),
have (n' > nat.zero), from lt_of_of_nat_lt_of_nat (Hn' ▸ np),
obtain (k : nat) (Hk : n' = nat.succ k), from nat.exists_eq_succ_of_lt this,
have -d * n = -d * nat.succ k, by rewrite [Hn', Hk],
have H3 : inv (mk -[1+k] d dp) ≡ mk (-d) n np, from this,
have H4 : -[1+k] = -n, from calc
  -[1+k] = -(nat.succ k) : rfl
      ... = -n            : by rewrite [Hk⁻¹, Hn'],
H4 ▸ H3

theorem inv_of_neg {n d : int} (nn : n < 0) (dp : d > 0) :
  inv (mk n d dp) ≡ mk (-d) (-n) (neg_pos_of_neg nn) :=
have inv (mk (-(-n)) d dp) ≡ mk (-d) (-n) (neg_pos_of_neg nn),
  from inv_neg (neg_pos_of_neg nn) dp,
!neg_neg ▸ this

/- operations respect equiv -/

theorem add_equiv_add {a1 b1 a2 b2 : prerat} (eqv1 : a1 ≡ a2) (eqv2 : b1 ≡ b2) :
  add a1 b1 ≡ add a2 b2 :=
calc
  (num a1 * denom b1 + num b1 * denom a1) * (denom a2 * denom b2)
      = num a1 * denom a2 * denom b1 * denom b2 + num b1 * denom b2 * denom a1 * denom a2 :
          by rewrite [right_distrib, *mul.assoc, mul.left_comm (denom b1),
                      mul.comm (denom b2), *mul.assoc]
  ... = num a2 * denom a1 * denom b1 * denom b2 + num b2 * denom b1 * denom a1 * denom a2 :
          by rewrite [↑equiv at *, eqv1, eqv2]
  ... = (num a2 * denom b2 + num b2 * denom a2) * (denom a1 * denom b1) :
          by rewrite [right_distrib, *mul.assoc, *mul.left_comm (denom b2),
                      *mul.comm (denom b1), *mul.assoc, mul.left_comm (denom a2)]

theorem mul_equiv_mul {a1 b1 a2 b2 : prerat} (eqv1 : a1 ≡ a2) (eqv2 : b1 ≡ b2) :
  mul a1 b1 ≡ mul a2 b2 :=
calc
  (num a1 * num b1) * (denom a2 * denom b2)
      = (num a1 * denom a2) * (num b1 * denom b2) : by rewrite [*mul.assoc, mul.left_comm (num b1)]
  ... = (num a2 * denom a1) * (num b2 * denom b1) : by rewrite [↑equiv at *, eqv1, eqv2]
  ... = (num a2 * num b2) * (denom a1 * denom b1) : by rewrite [*mul.assoc, mul.left_comm (num b2)]

theorem neg_equiv_neg {a b : prerat} (eqv : a ≡ b) : neg a ≡ neg b :=
calc
  -num a * denom b = -(num a * denom b) : neg_mul_eq_neg_mul
               ... = -(num b * denom a) : {eqv}
               ... = -num b * denom a   : neg_mul_eq_neg_mul

theorem inv_equiv_inv : ∀{a b : prerat}, a ≡ b → inv a ≡ inv b
| (mk an ad adp) (mk bn bd bdp) :=
  assume H,
  lt.by_cases
    (assume an_neg : an < 0,
      have bn_neg : bn < 0, from num_neg_of_equiv H an_neg,
      calc
        inv (mk an ad adp) ≡ mk (-ad) (-an) (neg_pos_of_neg an_neg) : inv_of_neg an_neg adp
                       ... ≡ mk (-bd) (-bn) (neg_pos_of_neg bn_neg) :
                             by rewrite [↑equiv at *, ▸*, *neg_mul_neg, mul.comm ad, mul.comm bd, H]
                       ... ≡ inv (mk bn bd bdp)                     : (inv_of_neg bn_neg bdp)⁻¹)
    (assume an_zero : an = 0,
      have bn_zero : bn = 0, from num_eq_zero_of_equiv H an_zero,
      eq.subst (calc
        inv (mk an ad adp) = inv (mk 0 ad adp)  : {an_zero}
                       ... = zero               : inv_zero adp
                       ... = inv (mk 0 bd bdp)  : inv_zero bdp
                       ... = inv (mk bn bd bdp) : bn_zero) !equiv.refl)
    (assume an_pos : an > 0,
      have bn_pos : bn > 0, from num_pos_of_equiv H an_pos,
      calc
        inv (mk an ad adp) ≡ mk ad an an_pos    : inv_of_pos an_pos adp
                       ... ≡ mk bd bn bn_pos    :
                                by rewrite [↑equiv at *, ▸*, mul.comm ad, mul.comm bd, H]
                       ... ≡ inv (mk bn bd bdp) : (inv_of_pos bn_pos bdp)⁻¹)

theorem smul_equiv {a : ℤ} {b : prerat} (H : a > 0) : smul a b H ≡ b :=
by esimp[equiv, smul]; rewrite[mul.assoc, mul.left_comm]

/- properties -/

protected theorem add.comm (a b : prerat) : add a b ≡ add b a :=
by rewrite [↑add, ↑equiv, ▸*, add.comm, mul.comm (denom a)]

protected theorem add.assoc (a b c : prerat) : add (add a b) c ≡ add a (add b c) :=
by rewrite [↑add, ↑equiv, ▸*, *(mul.comm (num c)), *(λy, mul.comm y (denom a)), *left_distrib,
            *right_distrib, *mul.assoc, *add.assoc]

protected theorem add_zero (a : prerat) : add a zero ≡ a :=
by rewrite [↑add, ↑equiv, ↑zero, ↑of_int, ▸*, *mul_one, zero_mul, add_zero]

protected theorem add_left_inv (a : prerat) : add (neg a) a ≡ zero :=
by rewrite [↑add, ↑equiv, ↑neg, ↑zero, ↑of_int, ▸*, -neg_mul_eq_neg_mul, add.left_inv, *zero_mul]

protected theorem mul_comm (a b : prerat) : mul a b ≡ mul b a :=
by rewrite [↑mul, ↑equiv, mul.comm (num a), mul.comm (denom a)]

protected theorem mul_assoc (a b c : prerat) : mul (mul a b) c ≡ mul a (mul b c) :=
by rewrite [↑mul, ↑equiv, *mul.assoc]

protected theorem mul_one (a : prerat) : mul a one ≡ a :=
by rewrite [↑mul, ↑one, ↑of_int, ↑equiv, ▸*, *mul_one]

protected theorem mul_left_distrib (a b c : prerat) : mul a (add b c) ≡ add (mul a b) (mul a c) :=
have H : smul (denom a) (mul a (add b c)) (denom_pos a) =
   add (mul a b) (mul a c), from begin
  rewrite[↑smul, ↑mul, ↑add],
  congruence,
  rewrite[*left_distrib, *right_distrib, -+(int.mul_assoc)],
  have T : ∀ {x y z w : ℤ}, x*y*z*w=y*z*x*w, from
    λx y z w, (!int.mul_assoc ⬝ !int.mul_comm) ▸ rfl,
  exact !congr_arg2 T T,
  rewrite [mul.left_comm (denom a) (denom b) (denom c)],
  rewrite int.mul_assoc
end,
equiv.symm (H ▸ smul_equiv (denom_pos a))

theorem mul_inv_cancel : ∀{a : prerat}, ¬ a ≡ zero → mul a (inv a) ≡ one
| (mk an ad adp) :=
  assume H,
  let a := mk an ad adp in
  lt.by_cases
    (assume an_neg : an < 0,
      let ia := mk (-ad) (-an) (neg_pos_of_neg an_neg) in
      calc
        mul a (inv a) ≡ mul a ia : mul_equiv_mul !equiv.refl (inv_of_neg an_neg adp)
                  ... ≡ one      : begin
                                     esimp [equiv, one, mul, of_int],
                                     rewrite [*int.mul_one, *int.one_mul, mul.comm,
                                              neg_mul_comm]
                                   end)
    (assume an_zero : an = 0, absurd (equiv_zero_of_num_eq_zero an_zero) H)
    (assume an_pos : an > 0,
      let ia := mk ad an an_pos in
      calc
        mul a (inv a) ≡ mul a ia : mul_equiv_mul !equiv.refl (inv_of_pos an_pos adp)
                  ... ≡ one      : begin
                                     esimp [equiv, one, mul, of_int],
                                     rewrite [*int.mul_one, *int.one_mul, mul.comm]
                                   end)

theorem zero_not_equiv_one : ¬ zero ≡ one :=
begin
  esimp [equiv, zero, one, of_int],
  rewrite [zero_mul, int.mul_one],
  exact zero_ne_one
end

theorem mul_denom_equiv (a : prerat) : mul a (of_int (denom a)) ≡ of_int (num a) :=
by esimp [mul, of_int, equiv]; rewrite [*int.mul_one]

/- Reducing a fraction to lowest terms. Needed to choose a canonical representative of rat, and
   define numerator and denominator. -/

definition reduce : prerat → prerat
| (mk an ad adpos) :=
    have pos : ad / gcd an ad > 0, from div_pos_of_pos_of_dvd adpos !gcd_nonneg !gcd_dvd_right,
    if an = 0 then prerat.zero
              else mk (an / gcd an ad) (ad / gcd an ad) pos

protected theorem eq {a b : prerat} (Hn : num a = num b) (Hd : denom a = denom b) : a = b :=
begin
  cases a with [an, ad, adpos],
  cases b with [bn, bd, bdpos],
  generalize adpos, generalize bdpos,
  esimp at *,
  rewrite [Hn, Hd],
  intros, apply rfl
end

theorem reduce_equiv : ∀ a : prerat, reduce a ≡ a
| (mk an ad adpos) :=
    decidable.by_cases
      (assume anz : an = 0,
        begin rewrite [↑reduce, if_pos anz, ↑equiv, anz], krewrite zero_mul end)
      (assume annz : an ≠ 0,
        by rewrite [↑reduce, if_neg annz, ↑equiv, mul.comm, -!int.mul_div_assoc
                    !gcd_dvd_left, -!int.mul_div_assoc !gcd_dvd_right, mul.comm])

theorem reduce_eq_reduce : ∀ {a b : prerat}, a ≡ b → reduce a = reduce b
| (mk an ad adpos) (mk bn bd bdpos) :=
  assume H : an * bd = bn * ad,
  decidable.by_cases
    (assume anz : an = 0,
      have H' : bn * ad = 0, by rewrite [-H, anz, zero_mul],
      have bnz : bn = 0,
        from or_resolve_left (eq_zero_or_eq_zero_of_mul_eq_zero H') (ne_of_gt adpos),
      by rewrite [↑reduce, if_pos anz, if_pos bnz])
    (assume annz : an ≠ 0,
      have bnnz : bn ≠ 0, from
        assume bnz,
        have H' : an * bd = 0, by rewrite [H, bnz, zero_mul],
        have anz : an = 0,
          from or_resolve_left (eq_zero_or_eq_zero_of_mul_eq_zero H') (ne_of_gt bdpos),
        show false, from annz anz,
      begin
        rewrite [↑reduce, if_neg annz, if_neg bnnz],
        apply prerat.eq,
          {apply div_gcd_eq_div_gcd H adpos bdpos},
          {esimp, rewrite [gcd.comm, gcd.comm bn],
            apply div_gcd_eq_div_gcd_of_nonneg,
              rewrite [mul.comm, -H, mul.comm],
              apply annz,
              apply bnnz,
              apply le_of_lt adpos,
              apply le_of_lt bdpos},
      end)

end prerat

/-
  the rationals
-/

definition rat : Type.{1} := quot prerat.setoid
notation `ℚ` := rat

local attribute prerat.setoid [instance]

namespace rat

/- operations -/

definition of_int [coercion] (i : ℤ) : ℚ := ⟦prerat.of_int i⟧
definition of_nat [coercion] (n : ℕ) : ℚ := n
definition of_num [coercion] [reducible] (n : num) : ℚ := n

protected definition prio := num.pred int.prio

definition rat_has_zero [instance] [priority rat.prio] : has_zero rat :=
has_zero.mk (of_int 0)

definition rat_has_one [instance] [priority rat.prio] : has_one rat :=
has_one.mk (of_int 1)

theorem of_int_zero : of_int (0:int) = (0:rat) :=
rfl

theorem of_int_one : of_int (1:int) = (1:rat) :=
rfl

protected definition add : ℚ → ℚ → ℚ :=
quot.lift₂
  (λ a b : prerat, ⟦prerat.add a b⟧)
  (take a1 a2 b1 b2, assume H1 H2, quot.sound (prerat.add_equiv_add H1 H2))

protected definition mul : ℚ → ℚ → ℚ :=
quot.lift₂
  (λ a b : prerat, ⟦prerat.mul a b⟧)
  (take a1 a2 b1 b2, assume H1 H2, quot.sound (prerat.mul_equiv_mul H1 H2))

protected definition neg : ℚ → ℚ :=
quot.lift
  (λ a : prerat, ⟦prerat.neg a⟧)
  (take a1 a2, assume H, quot.sound (prerat.neg_equiv_neg H))

protected definition inv : ℚ → ℚ :=
quot.lift
  (λ a : prerat, ⟦prerat.inv a⟧)
  (take a1 a2, assume H, quot.sound (prerat.inv_equiv_inv H))

definition reduce : ℚ → prerat :=
quot.lift
  (λ a : prerat, prerat.reduce a)
  @prerat.reduce_eq_reduce

definition num (a : ℚ) : ℤ := prerat.num (reduce a)
definition denom (a : ℚ) : ℤ := prerat.denom (reduce a)

theorem denom_pos (a : ℚ): denom a > 0 :=
prerat.denom_pos (reduce a)

definition rat_has_add [instance] [priority rat.prio] : has_add rat :=
has_add.mk rat.add

definition rat_has_mul [instance] [priority rat.prio] : has_mul rat :=
has_mul.mk rat.mul

definition rat_has_neg [instance] [priority rat.prio] : has_neg rat :=
has_neg.mk rat.neg

definition rat_has_inv [instance] [priority rat.prio] : has_inv rat :=
has_inv.mk rat.inv

protected definition sub [reducible] (a b : ℚ) : rat := a + (-b)

definition rat_has_sub [instance] [priority rat.prio] : has_sub rat :=
has_sub.mk rat.sub

lemma sub.def (a b : ℚ) : a - b = a + (-b) :=
rfl

/- properties -/

theorem of_int_add (a b : ℤ) : of_int (a + b) = of_int a + of_int b :=
quot.sound (prerat.of_int_add a b)

theorem of_int_mul (a b : ℤ) : of_int (a * b) = of_int a * of_int b :=
quot.sound (prerat.of_int_mul a b)

theorem of_int_neg (a : ℤ) : of_int (-a) = -(of_int a) :=
quot.sound (prerat.of_int_neg a)

theorem of_int_sub (a b : ℤ) : of_int (a - b) = of_int a - of_int b :=
calc
  of_int (a - b) = of_int a + of_int (-b) : of_int_add
             ... = of_int a - of_int b    : {of_int_neg b}

theorem of_int.inj {a b : ℤ} (H : of_int a = of_int b) : a = b :=
prerat.of_int.inj (quot.exact H)

theorem eq_of_of_int_eq_of_int {a b : ℤ} (H : of_int a = of_int b) : a = b :=
of_int.inj H

theorem of_int_eq_of_int_iff (a b : ℤ) : of_int a = of_int b ↔ a = b :=
iff.intro eq_of_of_int_eq_of_int !congr_arg

theorem of_nat_eq (a : ℕ) : of_nat a = of_int (int.of_nat a) :=
rfl

open nat

theorem of_nat_add (a b : ℕ) : of_nat (a + b) = of_nat a + of_nat b :=
by rewrite [of_nat_eq, int.of_nat_add, rat.of_int_add]

theorem of_nat_mul (a b : ℕ) : of_nat (a * b) = of_nat a * of_nat b :=
by rewrite [of_nat_eq, int.of_nat_mul, rat.of_int_mul]

theorem of_nat_sub {a b : ℕ} (H : a ≥ b) : of_nat (a - b) = of_nat a - of_nat b :=
begin
  rewrite of_nat_eq,
  rewrite [int.of_nat_sub H],
  rewrite [rat.of_int_sub]
end

theorem of_nat.inj {a b : ℕ} (H : of_nat a = of_nat b) : a = b :=
int.of_nat.inj (of_int.inj H)

theorem eq_of_of_nat_eq_of_nat {a b : ℕ} (H : of_nat a = of_nat b) : a = b :=
of_nat.inj H

theorem of_nat_eq_of_nat_iff (a b : ℕ) : of_nat a = of_nat b ↔ a = b :=
iff.intro of_nat.inj !congr_arg

protected theorem add_comm (a b : ℚ) : a + b = b + a :=
quot.induction_on₂ a b (take u v, quot.sound !prerat.add.comm)

protected theorem add_assoc (a b c : ℚ) : a + b + c = a + (b + c) :=
quot.induction_on₃ a b c (take u v w, quot.sound !prerat.add.assoc)

protected theorem add_zero (a : ℚ) : a + 0 = a :=
quot.induction_on a (take u, quot.sound !prerat.add_zero)

protected theorem zero_add (a : ℚ) : 0 + a = a := !rat.add_comm ▸ !rat.add_zero

protected theorem add_left_inv (a : ℚ) : -a + a = 0 :=
quot.induction_on a (take u, quot.sound !prerat.add_left_inv)

protected theorem mul_comm (a b : ℚ) : a * b = b * a :=
quot.induction_on₂ a b (take u v, quot.sound !prerat.mul_comm)

protected theorem mul_assoc (a b c : ℚ) : a * b * c = a * (b * c) :=
quot.induction_on₃ a b c (take u v w, quot.sound !prerat.mul_assoc)

protected theorem mul_one (a : ℚ) : a * 1 = a :=
quot.induction_on a (take u, quot.sound !prerat.mul_one)

protected theorem one_mul (a : ℚ) : 1 * a = a := !rat.mul_comm ▸ !rat.mul_one

protected theorem left_distrib (a b c : ℚ) : a * (b + c) = a * b + a * c :=
quot.induction_on₃ a b c (take u v w, quot.sound !prerat.mul_left_distrib)

protected theorem right_distrib (a b c : ℚ) : (a + b) * c = a * c + b * c :=
by rewrite [rat.mul_comm, rat.left_distrib, *rat.mul_comm c]

protected theorem mul_inv_cancel {a : ℚ} : a ≠ 0 → a * a⁻¹ = 1 :=
quot.induction_on a
  (take u,
    assume H,
    quot.sound (!prerat.mul_inv_cancel (assume H1, H (quot.sound H1))))

protected theorem inv_mul_cancel {a : ℚ} (H : a ≠ 0) : a⁻¹ * a = 1 :=
!rat.mul_comm ▸ rat.mul_inv_cancel H

protected theorem zero_ne_one : (0 : ℚ) ≠ 1 :=
assume H, prerat.zero_not_equiv_one (quot.exact H)

definition has_decidable_eq [instance] : decidable_eq ℚ :=
take a b, quot.rec_on_subsingleton₂ a b
  (take u v,
     if H : prerat.num u * prerat.denom v = prerat.num v * prerat.denom u
       then decidable.inl (quot.sound H)
       else decidable.inr (assume H1, H (quot.exact H1)))

protected theorem inv_zero : inv 0 = (0 : ℚ) :=
quot.sound (prerat.inv_zero' ▸ !prerat.equiv.refl)

theorem quot_reduce (a : ℚ) : ⟦reduce a⟧ = a :=
quot.induction_on a (take u, quot.sound !prerat.reduce_equiv)

section
local attribute rat [reducible]
theorem mul_denom (a : ℚ) : a * denom a = num a :=
have H : ⟦reduce a⟧ * of_int (denom a) = of_int (num a), from quot.sound (!prerat.mul_denom_equiv),
quot_reduce a ▸ H
end

theorem coprime_num_denom (a : ℚ) : coprime (num a) (denom a) :=
decidable.by_cases
  (suppose a = 0, by substvars)
  (quot.induction_on a
    (take u H,
      have H' : prerat.num u ≠ 0, from take H'', H (quot.sound (prerat.equiv_zero_of_num_eq_zero H'')),
      begin
        cases u with un ud udpos,
        rewrite [▸*, ↑num, ↑denom, ↑reduce, ↑prerat.reduce, if_neg H', ▸*],
        have gcd un ud ≠ 0, from ne_of_gt (!gcd_pos_of_ne_zero_left H'),
        apply coprime_div_gcd_div_gcd this
      end))

protected definition discrete_field [trans_instance] : discrete_field rat :=
⦃discrete_field,
 add              := rat.add,
 add_assoc        := rat.add_assoc,
 zero             := 0,
 zero_add         := rat.zero_add,
 add_zero         := rat.add_zero,
 neg              := rat.neg,
 add_left_inv     := rat.add_left_inv,
 add_comm         := rat.add_comm,
 mul              := rat.mul,
 mul_assoc        := rat.mul_assoc,
 one              := 1,
 one_mul          := rat.one_mul,
 mul_one          := rat.mul_one,
 left_distrib     := rat.left_distrib,
 right_distrib    := rat.right_distrib,
 mul_comm         := rat.mul_comm,
 mul_inv_cancel   := @rat.mul_inv_cancel,
 inv_mul_cancel   := @rat.inv_mul_cancel,
 zero_ne_one      := rat.zero_ne_one,
 inv_zero         := rat.inv_zero,
 has_decidable_eq := has_decidable_eq⦄

definition rat_has_div [instance] [priority rat.prio] : has_div rat :=
has_div.mk has_div.div

definition rat_has_pow_nat [instance] [priority rat.prio] : has_pow_nat rat :=
has_pow_nat.mk has_pow_nat.pow_nat

theorem eq_num_div_denom (a : ℚ) : a = num a / denom a :=
have H : of_int (denom a) ≠ 0, from assume H', ne_of_gt (denom_pos a) (of_int.inj H'),
iff.mpr (!eq_div_iff_mul_eq H) (mul_denom a)

theorem of_int_div {a b : ℤ} (H : b ∣ a) : of_int (a / b) = of_int a / of_int b :=
decidable.by_cases
  (assume bz : b = 0,
    by rewrite [bz, int.div_zero, of_int_zero, div_zero])
  (assume bnz : b ≠ 0,
    have bnz' : of_int b ≠ 0, from assume oibz, bnz (of_int.inj oibz),
    have H' : of_int (a / b) * of_int b = of_int a, from
      dvd.elim H
        (take c, assume Hc : a = b * c,
          by rewrite [Hc, !int.mul_div_cancel_left bnz, mul.comm]),
    iff.mpr (!eq_div_iff_mul_eq bnz') H')

theorem of_nat_div {a b : ℕ} (H : b ∣ a) : of_nat (a / b) = of_nat a / of_nat b :=
have H' : (int.of_nat b ∣ int.of_nat a), by rewrite [int.of_nat_dvd_of_nat_iff]; exact H,
by rewrite [of_nat_eq, int.of_nat_div, of_int_div H']

theorem of_int_pow (a : ℤ) (n : ℕ) : of_int (a^n) = (of_int a)^n :=
begin
  induction n with n ih,
    apply eq.refl,
  rewrite [pow_succ, pow_succ, of_int_mul, ih]
end

theorem of_nat_pow (a : ℕ) (n : ℕ) : of_nat (a^n) = (of_nat a)^n :=
by rewrite [of_nat_eq, int.of_nat_pow, of_int_pow]

end rat


/-
M1F 2017-18 Sheet 1 Question 1, solution
Author : Kevin Buzzard

Note: this version of the solution uses integers instead of real numbers.
This is because the real numbers are not currently in Lean's standard library
and I want to make things as easy as possible at this point. This file should
work with any version of lean -- whether you installed it yourself or are
running the version on https://leanprover.github.io/live/latest/

Lean does have real numbers -- it's just that you need to install
another library to get them (the mathlib library).

Notes for KMB : If I switch to real numbers, I should also switch to x^2
-/

-- Here are some solutions to M1F sheet 1 question 1.
-- Let me stress that they are basically completely
-- unreadable unless you use Lean to read them.
-- If you use Lean, then by moving the cursor around
-- the proofs, or clicking on them, you will be able
-- to see, at each stage, what Xena
-- knows and what she is trying to prove.
-- This will give you a much better feeling for what
-- is going on.

-- Before we start, just let me define the power notation,
-- which is not in the core lean library (it is in another
-- library called mathlib which may not be installed on your machine).
-- Don't worry about this bit. I'm defining x^n by recursion on n, which
-- is sort of like induction but with definitions instead of proofs.

@[reducible] definition pow : int -> nat -> int
| _ 0 := (1:int)
| x (nat.succ n) := x * (pow x n)

notation x `^` n := pow x n

-- Now onto the question.

-- M1F Sheet 1 Q1 part (a): this is false.

theorem m1f_sheet01_q01a_is_F : ¬ (∀ x : ℤ, x^2 - 3*x + 2 = 0 → x=1) :=
begin
--
-- We're going to prove this by contradiction.
-- Let's let H1 be our false hypothesis,
-- so H1 is "for all x, x^2-3x+2=0 implies x=1".
-- By the way, if you're using lean to read this file, you
-- can hover over or click on various lines to see much more
-- clearly what is going on.
--
intro H1,
--
-- Now the problems will occur if we let x be 2,
-- because x^2-3*2+2=0 but 2 isn't 1. So let's
-- see what we can deduce from H1 if we set x=2.
--
have H2 : (2:ℤ)^2-3*2+2=0 → (2:ℤ)=1, -- new hypothesis
{ exact (H1 2) }, -- and there's its proof.
-- We used { ... } here to 'focus' on the
-- first of several goals.
--
-- Hypothesis H2 now says that smething which is true,
-- implies something which is false. So that's going to
-- be our contradiction. But Xena really
-- needs to be talked through this. Let's first
-- check that 2^2-3*2+2=0! Let's call this very
-- easy hypothesis H3.
--
have H3 : (2:ℤ)^2-3*2+2=0,
{ trivial }, -- Xena can work this proof out herself.
--
-- From hypotheses H2 and H3 we can deduce that 2=1!
have H4 : (2:ℤ) = 1,
{ exact (H2 H3) },
-- H2 applied to H3 tells us that 2=1. But Xena is smart
-- enough to know that 2 isn't 1.
have H5 : (2:ℤ) ≠ 1,
{ cc }, -- "cc" is a proof tactic that Xena knows.
-- Amongst other things, it solves basic inequalities like this.
-- Xena currently knows a few of these tactics,
-- and she learns more all the time, as new ones are
-- implemented into her brain. It stands for
-- "congruence closure", not that this is much help.
--
-- Anyway, the point is that H4 and H5 now contradict
-- each other. So we can finish the proof!
contradiction
end
-- End M1F Sheet 1 Q1 part (a)

-- M1F Sheet 1 Q1 part (b) is true.

theorem m1f_sheet01_q01b_is_T : ∀ x : ℤ, x=1 → x^2-3*x+2=0 :=
-- This one is much easier.
-- First we assume the hypothesis that x=1.
begin
intros x H1, -- now H1 says that x=1.
-- Our goal is to prove that x^2-3*x+2=0.
--
-- First let's simplify our goal using the
-- hypothesis H1.
simp [H1],
-- our goal is now to prove 1^2-3+2=0, but Xena can do this.
trivial
end
-- End M1F Sheet 1 Q1 part (b)

-- M1F Sheet 1 Q1 part (c) is false and this follows from part (a)

theorem m1f_sheet01_q01c_is_F : ¬ (∀ x : ℤ, x^2 - 3*x + 2 = 0 ↔ x=1) :=

begin
-- We prove it by contradiction.
intro H, -- H is now the hypothesis that for all x, x^2-3x+2=0 iff x=1
-- We could just now copy out the proof of part a now
-- but we could also just use part a.
-- We first deduce from H that for all x, x^2-3x+2=0 implies x=1.
have H2: ∀ x : ℤ, (x^2-3*x+2=0 → x=1),
{ exact λ x, iff.elim_left (H x) },
-- and now we note that this and part a give us our contradiction
apply m1f_sheet01_q01a_is_F,
assumption
end
-- End M1F Sheet 1 Q1 part (c)

-- M1F Sheet 1 Q1 part (d) is true but the proof is really long.

theorem m1f_sheet01_q01d_is_T : ∀ x : ℤ, x^2 - 3*x + 2 = 0 ↔ (x=1 ∨ x=2) :=
begin
-- Now this one is going to be some work,
-- because we need to prove that the *only* roots of
-- the quadratic are x=1 and x=2, but Xena doesn't know
-- anything about solving quadratic equations.
--
-- First let's get x.
intro x,
-- Now we have to prove an iff statement, so let's
-- break it up into an if and an only if.
apply iff.intro,
-- now we have two things to prove so I'll indent.
 -- Let's do the easy one first. (that weird v sign means "or")
show x=1 ∨ x=2 → x^2-3*x+2=0, {
 intro H12, -- hypothesis H12 says "x=1 or x=2"
 apply or.elim H12, -- eliminate the or,
 intro H1, -- H1 is the hypothesis that x=1.
 simp [H1], -- now sub in to x^2-3x+2=0,
 trivial, -- and it's trivial.
 -- that was x=1, and x=2 is just as easy.
 intro H2,
 simp [H2],
 trivial
},
-- now we have to do the trickier case.
--
-- We have to prove x^2-3x+2=0 implies x=1 or x=2.
intro H, -- this is the hypothesis x^2-3x+2=0.
-- We will now show that this hypothesis H implies x=1 or x=2
-- by slowly introducing new hypotheses H2,H3,H4 of H, with the "have" command,
-- and then proving each one,
-- until finally we have proved x=1 or x=2.

-- First Let's factor.

have H2:x^2-3*x+2=(x-1)*(x-2), {
 -- Aargh! Lean stuggles to do this! Excuse us for a second.
 unfold pow,
 change (3:ℤ) with 2+1;simp [mul_add,mul_one,add_left_cancel_iff,mul_add,add_mul,mul_comm],
 -- Done.
},

have H3: (x-1)*(x-2)=0, { -- This follows from H1 and H2 via a calculation.
 exact
 calc
 (x-1)*(x-2) = x^2-3*x+2 : eq.symm H2
 ... = 0 : H
},

 -- From H3 we can deduce x-1=0 or x-2=0. This is an inbuilt
 -- fact in Lean -- if a*b=0 then either a=0 or b=0. So we apply this fact.
have H4: (x-1)=0 ∨ (x-2)=0, {
 apply iff.elim_left mul_eq_zero_iff_eq_zero_or_eq_zero,
 assumption
},

 -- Now all we have to do is to prove that if x-1=0 then x=1, and if x-2=0 then x=2

cases H4 with HX1 HX2,
-- x-1=0
left, -- prove the left part of "x=1 or x=2"
apply iff.elim_left sub_eq_zero_iff_eq HX1,

-- x-2=0
right,
apply iff.elim_left sub_eq_zero_iff_eq HX2,

-- QED!
end

-- End M1F Sheet 1 Q1 part (d)

-- M1F Sheet 1 Q1 part (e) is true, and follows easily from (d)

theorem m1f_sheet01_q01e_is_T : ∀ x : ℤ, x^2 - 3*x + 2 = 0 → (x=1 ∨ x=2 ∨ x=3) :=
begin
intro x,
intro Hx,
have H12 : x=1 ∨ x=2,
{ apply (iff.elim_left (m1f_sheet01_q01d_is_T x) Hx) },
-- H12 is "x=1 or x=2", and goal is now "x=1 or x=2 or x=3", so looking good :-)
-- To understand the next lines better it might be good to think of
-- it as x=1 or (x=2 or x=3)
cases H12, -- next line is x=1, one after is x=2
{ left, assumption },
{ right, left, assumption },
end

-- End M1F Sheet 1 Q1 part (e)

-- M1F Sheet 1 Q1 part (f) is false

theorem m1f_sheet01_q01f_is_F : ¬ (∀ x : ℤ, (x=1 ∨ x=2 ∨ x=3) → x^2 - 3*x + 2 = 0) :=
begin
intro H,
specialize H 3,
have H2 : (3:int)=1 ∨ (3:int)=2 ∨ (3:int)=3,
{ right,right,trivial },

let s:=(3:int)^2-3*3+2,

have H3: s=0,
{ exact H H2 },

-- But it's easy to check s isn't 0:
have H4: s ≠ 0,
{ exact dec_trivial },

-- H3 and H4 are a contradiction.
contradiction,
end

-- End M1F Sheet 1 Q1 part (f)


/-
Copyright (c) 2015 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Leonardo de Moura, Jeremy Avigad

Combinators for finite sets.
-/
import data.finset.basic logic.identities
open list quot subtype decidable perm function

namespace finset

/- image (corresponds to map on list) -/
section image
variables {A B : Type}
variable [h : decidable_eq B]
include h

definition image (f : A → B) (s : finset A) : finset B :=
quot.lift_on s
  (λ l, to_finset (list.map f (elt_of l)))
  (λ l₁ l₂ p, quot.sound (perm_erase_dup_of_perm (perm_map _ p)))

infix [priority finset.prio] `'` := image

theorem image_empty (f : A → B) : image f ∅ = ∅ :=
rfl

theorem mem_image_of_mem (f : A → B) {s : finset A} {a : A} : a ∈ s → f a ∈ image f s :=
quot.induction_on s (take l, assume H : a ∈ elt_of l, mem_to_finset (mem_map f H))

theorem mem_image {f : A → B} {s : finset A} {a : A} {b : B}
    (H1 : a ∈ s) (H2 : f a = b) :
  b ∈ image f s :=
eq.subst H2 (mem_image_of_mem f H1)

theorem exists_of_mem_image {f : A → B} {s : finset A} {b : B} :
  b ∈ image f s → ∃a, a ∈ s ∧ f a = b :=
quot.induction_on s
  (take l, assume H : b ∈ erase_dup (list.map f (elt_of l)),
    exists_of_mem_map (mem_of_mem_erase_dup H))

theorem mem_image_iff (f : A → B) {s : finset A} {y : B} : y ∈ image f s ↔ ∃x, x ∈ s ∧ f x = y :=
iff.intro exists_of_mem_image
  (assume H,
    obtain x (H₁ : x ∈ s) (H₂ : f x = y), from H,
    mem_image H₁ H₂)

theorem mem_image_eq (f : A → B) {s : finset A} {y : B} : y ∈ image f s = ∃x, x ∈ s ∧ f x = y :=
propext (mem_image_iff f)

theorem mem_image_of_mem_image_of_subset {f : A → B} {s t : finset A} {y : B}
    (H1 : y ∈ image f s) (H2 : s ⊆ t) : y ∈ image f t :=
obtain x (H3: x ∈ s) (H4 : f x = y), from exists_of_mem_image H1,
have H5 : x ∈ t, from mem_of_subset_of_mem H2 H3,
show y ∈ image f t, from mem_image H5 H4

theorem image_insert [h' : decidable_eq A] (f : A → B) (s : finset A) (a : A) :
  image f (insert a s) = insert (f a) (image f s) :=
ext (take y, iff.intro
  (assume H : y ∈ image f (insert a s),
    obtain x (H1l : x ∈ insert a s) (H1r :f x = y), from exists_of_mem_image H,
    have x = a ∨ x ∈ s, from eq_or_mem_of_mem_insert H1l,
    or.elim this
      (suppose x = a,
        have f a = y, from eq.subst this H1r,
        show y ∈ insert (f a) (image f s), from eq.subst this !mem_insert)
      (suppose x ∈ s,
        have f x ∈ image f s, from mem_image_of_mem f this,
        show y ∈ insert (f a) (image f s), from eq.subst H1r (mem_insert_of_mem _ this)))
  (suppose y ∈ insert (f a) (image f s),
    have y = f a ∨ y ∈ image f s, from eq_or_mem_of_mem_insert this,
    or.elim this
      (suppose y = f a,
        have f a ∈ image f (insert a s), from mem_image_of_mem f !mem_insert,
        show y ∈ image f (insert a s), from eq.subst (eq.symm `y = f a`) this)
      (suppose y ∈ image f s,
        show y ∈ image f (insert a s), from mem_image_of_mem_image_of_subset this !subset_insert)))

lemma image_comp {C : Type} [deceqC : decidable_eq C] {f : B → C} {g : A → B} {s : finset A} :
  image (f∘g) s = image f (image g s) :=
ext (take z, iff.intro
  (suppose z ∈ image (f∘g) s,
    obtain x (Hx : x ∈ s) (Hgfx : f (g x) = z), from exists_of_mem_image this,
    by rewrite -Hgfx; apply mem_image_of_mem _ (mem_image_of_mem _ Hx))
  (suppose z ∈ image f (image g s),
    obtain y (Hy : y ∈ image g s) (Hfy : f y = z), from exists_of_mem_image this,
    obtain x (Hx : x ∈ s) (Hgx : g x = y), from exists_of_mem_image Hy,
    mem_image Hx (by esimp; rewrite [Hgx, Hfy])))

lemma image_subset {a b : finset A} (f : A → B) (H : a ⊆ b) : f ' a ⊆ f ' b :=
subset_of_forall
  (take y, assume Hy : y ∈ f ' a,
    obtain x (Hx₁ : x ∈ a) (Hx₂ : f x = y), from exists_of_mem_image Hy,
    mem_image (mem_of_subset_of_mem H Hx₁) Hx₂)

theorem image_union [h' : decidable_eq A] (f : A → B) (s t : finset A) :
  image f (s ∪ t) = image f s ∪ image f t :=
ext (take y, iff.intro
  (assume H : y ∈ image f (s ∪ t),
    obtain x [(xst : x ∈ s ∪ t) (fxy : f x = y)], from exists_of_mem_image H,
    or.elim (mem_or_mem_of_mem_union xst)
      (assume xs, mem_union_l (mem_image xs fxy))
      (assume xt, mem_union_r (mem_image xt fxy)))
  (assume H : y ∈ image f s ∪ image f t,
    or.elim (mem_or_mem_of_mem_union H)
      (assume yifs : y ∈ image f s,
        obtain x [(xs : x ∈ s) (fxy : f x = y)], from exists_of_mem_image yifs,
        mem_image (mem_union_l xs) fxy)
      (assume yift : y ∈ image f t,
        obtain x [(xt : x ∈ t) (fxy : f x = y)], from exists_of_mem_image yift,
        mem_image (mem_union_r xt) fxy)))
end image

/- separation and set-builder notation -/
section sep
variables {A : Type} [deceq : decidable_eq A]
include deceq
variables (p : A → Prop) [decp : decidable_pred p] (s : finset A) {x : A}
include decp

definition sep : finset A :=
quot.lift_on s
  (λl, to_finset_of_nodup
    (list.filter p (subtype.elt_of l))
    (list.nodup_filter p (subtype.has_property l)))
  (λ l₁ l₂ u, quot.sound (perm.perm_filter u))

notation [priority finset.prio] `{` binder ` ∈ ` s ` | ` r:(scoped:1 p, sep p s) `}` := r

theorem sep_empty : sep p ∅ = ∅ := rfl

variables {p s}

theorem of_mem_sep : x ∈ sep p s → p x :=
quot.induction_on s (take l, list.of_mem_filter)

theorem mem_of_mem_sep : x ∈ sep p s → x ∈ s :=
quot.induction_on s (take l, list.mem_of_mem_filter)

theorem mem_sep_of_mem {x : A} : x ∈ s → p x → x ∈ sep p s :=
quot.induction_on s (take l, list.mem_filter_of_mem)

variables (p s)

theorem mem_sep_iff : x ∈ sep p s ↔ x ∈ s ∧ p x :=
iff.intro
  (assume H, and.intro (mem_of_mem_sep H) (of_mem_sep H))
  (assume H, mem_sep_of_mem (and.left H) (and.right H))

theorem mem_sep_eq : x ∈ sep p s = (x ∈ s ∧ p x) :=
propext !mem_sep_iff

variable t : finset A

theorem mem_sep_union_iff : x ∈ sep p (s ∪ t) ↔ x ∈ sep p s ∨ x ∈ sep p t :=
by rewrite [*mem_sep_iff, mem_union_iff, and.right_distrib]

end sep

section

variables {A : Type} [deceqA : decidable_eq A]
include deceqA

theorem eq_sep_of_subset {s t : finset A} (ssubt : s ⊆ t) : s = {x ∈ t | x ∈ s} :=
ext (take x, iff.intro
  (suppose x ∈ s, mem_sep_of_mem (mem_of_subset_of_mem ssubt this) this)
  (suppose x ∈ {x ∈ t | x ∈ s}, of_mem_sep this))

end

/- set difference -/
section diff
variables {A : Type} [deceq : decidable_eq A]
include deceq

definition diff (s t : finset A) : finset A := {x ∈ s | x ∉ t}
infix [priority finset.prio] ` \ `:70 := diff

theorem mem_of_mem_diff {s t : finset A} {x : A} (H : x ∈ s \ t) : x ∈ s :=
mem_of_mem_sep H

theorem not_mem_of_mem_diff {s t : finset A} {x : A} (H : x ∈ s \ t) : x ∉ t :=
of_mem_sep H

theorem mem_diff {s t : finset A} {x : A} (H1 : x ∈ s) (H2 : x ∉ t) : x ∈ s \ t :=
mem_sep_of_mem H1 H2

theorem mem_diff_iff (s t : finset A) (x : A) : x ∈ s \ t ↔ x ∈ s ∧ x ∉ t :=
iff.intro
  (assume H, and.intro (mem_of_mem_diff H) (not_mem_of_mem_diff H))
  (assume H, mem_diff (and.left H) (and.right H))

theorem mem_diff_eq (s t : finset A) (x : A) : x ∈ s \ t = (x ∈ s ∧ x ∉ t) :=
propext !mem_diff_iff

theorem union_diff_cancel {s t : finset A} (H : s ⊆ t) : s ∪ (t \ s) = t :=
ext (take x, iff.intro
  (suppose x ∈ s ∪ (t \ s),
    or.elim (mem_or_mem_of_mem_union this)
      (suppose x ∈ s, mem_of_subset_of_mem H this)
      (suppose x ∈ t \ s, mem_of_mem_diff this))
  (suppose x ∈ t,
    decidable.by_cases
      (suppose x ∈ s, mem_union_left _ this)
      (suppose x ∉ s, mem_union_right _ (mem_diff `x ∈ t` this))))

theorem diff_union_cancel {s t : finset A} (H : s ⊆ t) : (t \ s) ∪ s = t :=
eq.subst !union_comm (!union_diff_cancel H)
end diff

/- set complement -/
section complement

variables {A : Type} [deceqA : decidable_eq A] [h : fintype A]
include deceqA h

definition compl (s : finset A) : finset A := univ \ s
prefix [priority finset.prio] - := compl

theorem mem_compl {s : finset A} {x : A} (H : x ∉ s) : x ∈ -s :=
mem_diff !mem_univ H

theorem not_mem_of_mem_compl {s : finset A} {x : A} (H : x ∈ -s) : x ∉ s :=
not_mem_of_mem_diff H

theorem mem_compl_iff (s : finset A) (x : A) : x ∈ -s ↔ x ∉ s :=
iff.intro not_mem_of_mem_compl mem_compl

section
  open classical

  theorem union_eq_compl_compl_inter_compl (s t : finset A) : s ∪ t = -(-s ∩ -t) :=
  ext (take x, by rewrite [mem_union_iff, mem_compl_iff, mem_inter_iff, *mem_compl_iff,
                           or_iff_not_and_not])

  theorem inter_eq_compl_compl_union_compl (s t : finset A) : s ∩ t = -(-s ∪ -t) :=
  ext (take x, by rewrite [mem_inter_iff, mem_compl_iff, mem_union_iff, *mem_compl_iff,
                           and_iff_not_or_not])
end

end complement

/- all -/
section all
variables {A : Type}
definition all (s : finset A) (p : A → Prop) : Prop :=
quot.lift_on s
  (λ l, all (elt_of l) p)
  (λ l₁ l₂ p, foldr_eq_of_perm (λ a₁ a₂ q, propext !and.left_comm) p true)

theorem all_empty (p : A → Prop) : all ∅ p = true :=
rfl

theorem of_mem_of_all {p : A → Prop} {a : A} {s : finset A} : a ∈ s → all s p → p a :=
quot.induction_on s (λ l i h, list.of_mem_of_all i h)

theorem forall_of_all {p : A → Prop} {s : finset A} (H : all s p) : ∀{a}, a ∈ s → p a :=
λ a H', of_mem_of_all H' H

theorem all_of_forall {p : A → Prop} {s : finset A} : (∀a, a ∈ s → p a) → all s p :=
quot.induction_on s (λ l H, list.all_of_forall H)

theorem all_iff_forall (p : A → Prop) (s : finset A) : all s p ↔ (∀a, a ∈ s → p a) :=
iff.intro forall_of_all all_of_forall

definition decidable_all [instance] (p : A → Prop) [h : decidable_pred p] (s : finset A) :
  decidable (all s p) :=
quot.rec_on_subsingleton s (λ l, list.decidable_all p (elt_of l))

theorem all_implies {p q : A → Prop} {s : finset A} : all s p → (∀ x, p x → q x) → all s q :=
quot.induction_on s (λ l h₁ h₂, list.all_implies h₁ h₂)

variable [h : decidable_eq A]
include h

theorem all_union {p : A → Prop} {s₁ s₂ : finset A} :  all s₁ p → all s₂ p → all (s₁ ∪ s₂) p :=
quot.induction_on₂ s₁ s₂ (λ l₁ l₂ a₁ a₂, all_union a₁ a₂)

theorem all_of_all_union_left {p : A → Prop} {s₁ s₂ : finset A} : all (s₁ ∪ s₂) p → all s₁ p :=
quot.induction_on₂ s₁ s₂ (λ l₁ l₂ a, list.all_of_all_union_left a)

theorem all_of_all_union_right {p : A → Prop} {s₁ s₂ : finset A} : all (s₁ ∪ s₂) p → all s₂ p :=
quot.induction_on₂ s₁ s₂ (λ l₁ l₂ a, list.all_of_all_union_right a)

theorem all_insert_of_all {p : A → Prop} {a : A} {s : finset A} : p a → all s p → all (insert a s) p :=
quot.induction_on s (λ l h₁ h₂, list.all_insert_of_all h₁ h₂)

theorem all_erase_of_all {p : A → Prop} (a : A) {s : finset A}: all s p → all (erase a s) p :=
quot.induction_on s (λ l h, list.all_erase_of_all a h)

theorem all_inter_of_all_left {p : A → Prop} {s₁ : finset A} (s₂ : finset A) : all s₁ p → all (s₁ ∩ s₂) p :=
quot.induction_on₂ s₁ s₂ (λ l₁ l₂ h, list.all_inter_of_all_left _ h)

theorem all_inter_of_all_right {p : A → Prop} {s₁ : finset A} (s₂ : finset A) : all s₂ p → all (s₁ ∩ s₂) p :=
quot.induction_on₂ s₁ s₂ (λ l₁ l₂ h, list.all_inter_of_all_right _ h)

theorem subset_iff_all (s t : finset A) : s ⊆ t ↔ all s (λ x, x ∈ t) :=
iff.intro
  (suppose s ⊆ t, all_of_forall (take x, suppose x ∈ s, mem_of_subset_of_mem `s ⊆ t` `x ∈ s`))
  (suppose all s (λ x, x ∈ t), subset_of_forall (take x, suppose x ∈ s, of_mem_of_all `x ∈ s` `all s (λ x, x ∈ t)`))

definition decidable_subset [instance] (s t : finset A) : decidable (s ⊆ t) :=
decidable_of_decidable_of_iff _ (iff.symm !subset_iff_all)
end all

/- any -/
section any
variables {A : Type}
definition any (s : finset A) (p : A → Prop) : Prop :=
quot.lift_on s
  (λ l, any (elt_of l) p)
  (λ l₁ l₂ p, foldr_eq_of_perm (λ a₁ a₂ q, propext !or.left_comm) p false)

theorem any_empty (p : A → Prop) : any ∅ p = false := rfl

theorem exists_of_any {p : A → Prop} {s : finset A} : any s p → ∃a, a ∈ s ∧ p a :=
quot.induction_on s (λ l H, list.exists_of_any H)

theorem any_of_mem {p : A → Prop} {s : finset A} {a : A} : a ∈ s → p a → any s p :=
quot.induction_on s (λ l H1 H2, list.any_of_mem H1 H2)

theorem any_of_exists {p : A → Prop} {s : finset A} (H : ∃a, a ∈ s ∧ p a) : any s p :=
obtain a H₁ H₂, from H,
any_of_mem H₁ H₂

theorem any_iff_exists (p : A → Prop) (s : finset A) : any s p ↔ (∃a, a ∈ s ∧ p a) :=
iff.intro exists_of_any any_of_exists

theorem any_of_insert [h : decidable_eq A] {p : A → Prop} (s : finset A) {a : A} (H : p a) :
  any (insert a s) p :=
any_of_mem (mem_insert a s) H

theorem any_of_insert_right [h : decidable_eq A] {p : A → Prop} {s : finset A} (a : A) (H : any s p) :
  any (insert a s) p :=
obtain b (H₁ : b ∈ s) (H₂ : p b), from exists_of_any H,
any_of_mem (mem_insert_of_mem a H₁) H₂

definition decidable_any [instance] (p : A → Prop) [h : decidable_pred p] (s : finset A) :
  decidable (any s p) :=
quot.rec_on_subsingleton s (λ l, list.decidable_any p (elt_of l))
end any

section product
variables {A B : Type}
definition product (s₁ : finset A) (s₂ : finset B) : finset (A × B) :=
quot.lift_on₂ s₁ s₂
  (λ l₁ l₂,
    to_finset_of_nodup (product (elt_of l₁) (elt_of l₂))
                       (nodup_product (has_property l₁) (has_property l₂)))
  (λ v₁ v₂ w₁ w₂ p₁ p₂, begin apply @quot.sound, apply perm_product p₁ p₂ end)

infix [priority finset.prio] * := product

theorem empty_product (s : finset B) : @empty A * s = ∅ :=
quot.induction_on s (λ l, rfl)

theorem mem_product {a : A} {b : B} {s₁ : finset A} {s₂ : finset B}
        : a ∈ s₁ → b ∈ s₂ → (a, b) ∈ s₁ * s₂ :=
quot.induction_on₂ s₁ s₂ (λ l₁ l₂ i₁ i₂, list.mem_product i₁ i₂)

theorem mem_of_mem_product_left {a : A} {b : B} {s₁ : finset A} {s₂ : finset B}
        : (a, b) ∈ s₁ * s₂ → a ∈ s₁ :=
quot.induction_on₂ s₁ s₂ (λ l₁ l₂ i, list.mem_of_mem_product_left i)

theorem mem_of_mem_product_right {a : A} {b : B} {s₁ : finset A} {s₂ : finset B}
        : (a, b) ∈ s₁ * s₂ → b ∈ s₂ :=
quot.induction_on₂ s₁ s₂ (λ l₁ l₂ i, list.mem_of_mem_product_right i)

theorem product_empty (s : finset A) : s * @empty B = ∅ :=
ext (λ p,
  match p with
  | (a, b) := iff.intro
     (λ i, absurd (mem_of_mem_product_right i) !not_mem_empty)
     (λ i, absurd i !not_mem_empty)
  end)
end product

/- powerset -/
section powerset
variables {A : Type} [deceqA : decidable_eq A]
include deceqA

  section list_powerset
  open list

  definition list_powerset : list A → finset (finset A)
  | []       := '{∅}
  | (a :: l) := list_powerset l ∪ image (insert a) (list_powerset l)

  end list_powerset

private theorem image_insert_comm (a b : A) (s : finset (finset A)) :
  image (insert a) (image (insert b) s) = image (insert b) (image (insert a) s) :=
have aux' : ∀ a b : A, ∀ x : finset A,
  x ∈ image (insert a) (image (insert b) s) →
    x ∈ image (insert b) (image (insert a) s), from
  begin
    intros [a, b, x, H],
    cases (exists_of_mem_image H) with [y, Hy],
    cases Hy with [Hy1, Hy2],
    cases (exists_of_mem_image Hy1) with [z, Hz],
    cases Hz with [Hz1, Hz2],
    substvars,
    rewrite insert.comm,
    repeat (apply mem_image_of_mem),
    assumption
  end,
ext (take x, iff.intro (aux' a b x) (aux' b a x))

theorem list_powerset_eq_list_powerset_of_perm {l₁ l₂ : list A} (p : l₁ ~ l₂) :
    list_powerset l₁ = list_powerset l₂ :=
perm.induction_on p
  rfl
  (λ x l₁ l₂ p ih, by rewrite [↑list_powerset, ih])
  (λ x y l, by rewrite [↑list_powerset, ↑list_powerset, *image_union, image_insert_comm,
                        *union_assoc, union_left_comm (finset.image (finset.insert x) _)])
  (λ l₁ l₂ l₃ p₁ p₂ r₁ r₂, eq.trans r₁ r₂)

definition powerset (s : finset A) : finset (finset A) :=
quot.lift_on s
  (λ l, list_powerset (elt_of l))
  (λ l₁ l₂ p, list_powerset_eq_list_powerset_of_perm p)

prefix [priority finset.prio] `𝒫`:100 := powerset

theorem powerset_empty : 𝒫 (∅ : finset A) = '{∅} := rfl

theorem powerset_insert {a : A} {s : finset A} : a ∉ s → 𝒫 (insert a s) = 𝒫 s ∪ image (insert a) (𝒫 s) :=
quot.induction_on s
  (λ l,
    assume H : a ∉ quot.mk l,
    calc
      𝒫 (insert a (quot.mk l))
            = list_powerset (list.insert a (elt_of l)) : rfl
        ... = list_powerset (#list a :: elt_of l)       : by rewrite [list.insert_eq_of_not_mem H]
        ... = 𝒫 (quot.mk l) ∪ image (insert a) (𝒫 (quot.mk l)) : rfl)

theorem mem_powerset_iff_subset (s : finset A) : ∀ x, x ∈ 𝒫 s ↔ x ⊆ s :=
begin
  induction s with a s nains ih,
    intro x,
    rewrite powerset_empty,
    show x ∈ '{∅} ↔ x ⊆ ∅, by rewrite [mem_singleton_iff, subset_empty_iff],
  intro x,
    rewrite [powerset_insert nains, mem_union_iff, ih, mem_image_iff],
    exact
      (iff.intro
        (assume H,
          or.elim H
            (suppose x ⊆ s, subset.trans this !subset_insert)
            (suppose ∃ y, y ∈ 𝒫 s ∧ insert a y = x,
              obtain y [yps iay], from this,
              show x ⊆ insert a s,
                begin
                  rewrite [-iay],
                  apply insert_subset_insert,
                  rewrite -ih,
                  apply yps
                end))
        (assume H : x ⊆ insert a s,
          have H' : erase a x ⊆ s, from erase_subset_of_subset_insert H,
          decidable.by_cases
            (suppose a ∈ x,
              or.inr (exists.intro (erase a x)
                (and.intro
                  (show erase a x ∈ 𝒫 s, by rewrite ih; apply H')
                  (show insert a (erase a x) = x, from insert_erase this))))
            (suppose a ∉ x, or.inl
              (show x ⊆ s, by rewrite [(erase_eq_of_not_mem this) at H']; apply H'))))
end

theorem subset_of_mem_powerset {s t : finset A} (H : s ∈ 𝒫 t) : s ⊆ t :=
iff.mp (mem_powerset_iff_subset t s) H

theorem mem_powerset_of_subset {s t : finset A} (H : s ⊆ t) : s ∈ 𝒫 t :=
iff.mpr (mem_powerset_iff_subset t s) H

theorem empty_mem_powerset (s : finset A) : ∅ ∈ 𝒫 s :=
mem_powerset_of_subset (empty_subset s)

end powerset
end finset


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

! This file was ported from Lean 3 source module set_theory.game.impartial
! leanprover-community/mathlib commit 2e0975f6a25dd3fbfb9e41556a77f075f6269748
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.SetTheory.Game.Basic
import Mathbin.Tactic.NthRewrite.Default

/-!
# Basic definitions about impartial (pre-)games

We will define an impartial game, one in which left and right can make exactly the same moves.
Our definition differs slightly by saying that the game is always equivalent to its negative,
no matter what moves are played. This allows for games such as poker-nim to be classifed as
impartial.
-/

universe u

open Pgame

namespace Pgame

/-- The definition for a impartial game, defined using Conway induction. -/
def ImpartialAux : Pgame → Prop
  | G =>
    (G ≈ -G) ∧ (∀ i, impartial_aux (G.moveLeft i)) ∧ ∀ j, impartial_aux (G.moveRight j)decreasing_by
  pgame_wf_tac
#align pgame.impartial_aux Pgame.ImpartialAux

theorem impartialAux_def {G : Pgame} :
    G.ImpartialAux ↔
      (G ≈ -G) ∧ (∀ i, ImpartialAux (G.moveLeft i)) ∧ ∀ j, ImpartialAux (G.moveRight j) :=
  by rw [impartial_aux]
#align pgame.impartial_aux_def Pgame.impartialAux_def

/-- A typeclass on impartial games. -/
class Impartial (G : Pgame) : Prop where
  out : ImpartialAux G
#align pgame.impartial Pgame.Impartial

theorem impartial_iff_aux {G : Pgame} : G.Impartial ↔ G.ImpartialAux :=
  ⟨fun h => h.1, fun h => ⟨h⟩⟩
#align pgame.impartial_iff_aux Pgame.impartial_iff_aux

theorem impartial_def {G : Pgame} :
    G.Impartial ↔ (G ≈ -G) ∧ (∀ i, Impartial (G.moveLeft i)) ∧ ∀ j, Impartial (G.moveRight j) := by
  simpa only [impartial_iff_aux] using impartial_aux_def
#align pgame.impartial_def Pgame.impartial_def

namespace Impartial

instance impartial_zero : Impartial 0 :=
  by
  rw [impartial_def]
  dsimp
  simp
#align pgame.impartial.impartial_zero Pgame.Impartial.impartial_zero

instance impartial_star : Impartial star :=
  by
  rw [impartial_def]
  simpa using impartial.impartial_zero
#align pgame.impartial.impartial_star Pgame.Impartial.impartial_star

theorem neg_equiv_self (G : Pgame) [h : G.Impartial] : G ≈ -G :=
  (impartial_def.1 h).1
#align pgame.impartial.neg_equiv_self Pgame.Impartial.neg_equiv_self

@[simp]
theorem mk'_neg_equiv_self (G : Pgame) [h : G.Impartial] : -⟦G⟧ = ⟦G⟧ :=
  Quot.sound (neg_equiv_self G).symm
#align pgame.impartial.mk_neg_equiv_self Pgame.Impartial.mk'_neg_equiv_self

instance moveLeft_impartial {G : Pgame} [h : G.Impartial] (i : G.LeftMoves) :
    (G.moveLeft i).Impartial :=
  (impartial_def.1 h).2.1 i
#align pgame.impartial.move_left_impartial Pgame.Impartial.moveLeft_impartial

instance moveRight_impartial {G : Pgame} [h : G.Impartial] (j : G.RightMoves) :
    (G.moveRight j).Impartial :=
  (impartial_def.1 h).2.2 j
#align pgame.impartial.move_right_impartial Pgame.Impartial.moveRight_impartial

theorem impartial_congr : ∀ {G H : Pgame} (e : G ≡r H) [G.Impartial], H.Impartial
  | G, H => fun e => by
    intro h
    exact
      impartial_def.2
        ⟨e.symm.equiv.trans ((neg_equiv_self G).trans (neg_equiv_neg_iff.2 e.equiv)), fun i =>
          impartial_congr (e.move_left_symm i), fun j =>
          impartial_congr (e.move_right_symm j)⟩decreasing_by
  pgame_wf_tac
#align pgame.impartial.impartial_congr Pgame.Impartial.impartial_congr

instance impartial_add : ∀ (G H : Pgame) [G.Impartial] [H.Impartial], (G + H).Impartial
  | G, H => by
    intro hG hH
    rw [impartial_def]
    refine'
      ⟨(add_congr (neg_equiv_self _) (neg_equiv_self _)).trans (neg_add_relabelling _ _).Equiv.symm,
        fun k => _, fun k => _⟩
    · apply left_moves_add_cases k
      all_goals
        intro i; simp only [add_move_left_inl, add_move_left_inr]
        apply impartial_add
    · apply right_moves_add_cases k
      all_goals
        intro i; simp only [add_move_right_inl, add_move_right_inr]
        apply impartial_add decreasing_by
  pgame_wf_tac
#align pgame.impartial.impartial_add Pgame.Impartial.impartial_add

instance impartial_neg : ∀ (G : Pgame) [G.Impartial], (-G).Impartial
  | G => by
    intro hG
    rw [impartial_def]
    refine' ⟨_, fun i => _, fun i => _⟩
    · rw [neg_neg]
      exact (neg_equiv_self G).symm
    · rw [move_left_neg']
      apply impartial_neg
    · rw [move_right_neg']
      apply impartial_neg decreasing_by pgame_wf_tac
#align pgame.impartial.impartial_neg Pgame.Impartial.impartial_neg

variable (G : Pgame) [Impartial G]

theorem nonpos : ¬0 < G := fun h =>
  by
  have h' := neg_lt_neg_iff.2 h
  rw [neg_zero, lt_congr_left (neg_equiv_self G).symm] at h'
  exact (h.trans h').False
#align pgame.impartial.nonpos Pgame.Impartial.nonpos

theorem nonneg : ¬G < 0 := fun h =>
  by
  have h' := neg_lt_neg_iff.2 h
  rw [neg_zero, lt_congr_right (neg_equiv_self G).symm] at h'
  exact (h.trans h').False
#align pgame.impartial.nonneg Pgame.Impartial.nonneg

/-- In an impartial game, either the first player always wins, or the second player always wins. -/
theorem equiv_or_fuzzy_zero : (G ≈ 0) ∨ G ‖ 0 :=
  by
  rcases lt_or_equiv_or_gt_or_fuzzy G 0 with (h | h | h | h)
  · exact ((nonneg G) h).elim
  · exact Or.inl h
  · exact ((nonpos G) h).elim
  · exact Or.inr h
#align pgame.impartial.equiv_or_fuzzy_zero Pgame.Impartial.equiv_or_fuzzy_zero

@[simp]
theorem not_equiv_zero_iff : ¬(G ≈ 0) ↔ G ‖ 0 :=
  ⟨(equiv_or_fuzzy_zero G).resolve_left, Fuzzy.not_equiv⟩
#align pgame.impartial.not_equiv_zero_iff Pgame.Impartial.not_equiv_zero_iff

@[simp]
theorem not_fuzzy_zero_iff : ¬G ‖ 0 ↔ (G ≈ 0) :=
  ⟨(equiv_or_fuzzy_zero G).resolve_right, Equiv.not_fuzzy⟩
#align pgame.impartial.not_fuzzy_zero_iff Pgame.Impartial.not_fuzzy_zero_iff

theorem add_self : G + G ≈ 0 :=
  (add_congr_left (neg_equiv_self G)).trans (add_left_neg_equiv G)
#align pgame.impartial.add_self Pgame.Impartial.add_self

@[simp]
theorem mk'_add_self : ⟦G⟧ + ⟦G⟧ = 0 :=
  Quot.sound (add_self G)
#align pgame.impartial.mk_add_self Pgame.Impartial.mk'_add_self

/-- This lemma doesn't require `H` to be impartial. -/
theorem equiv_iff_add_equiv_zero (H : Pgame) : (H ≈ G) ↔ (H + G ≈ 0) :=
  by
  rw [equiv_iff_game_eq, equiv_iff_game_eq, ← @add_right_cancel_iff _ _ _ (-⟦G⟧)]
  simpa
#align pgame.impartial.equiv_iff_add_equiv_zero Pgame.Impartial.equiv_iff_add_equiv_zero

/-- This lemma doesn't require `H` to be impartial. -/
theorem equiv_iff_add_equiv_zero' (H : Pgame) : (G ≈ H) ↔ (G + H ≈ 0) :=
  by
  rw [equiv_iff_game_eq, equiv_iff_game_eq, ← @add_left_cancel_iff _ _ _ (-⟦G⟧), eq_comm]
  simpa
#align pgame.impartial.equiv_iff_add_equiv_zero' Pgame.Impartial.equiv_iff_add_equiv_zero'

theorem le_zero_iff {G : Pgame} [G.Impartial] : G ≤ 0 ↔ 0 ≤ G := by
  rw [← zero_le_neg_iff, le_congr_right (neg_equiv_self G)]
#align pgame.impartial.le_zero_iff Pgame.Impartial.le_zero_iff

theorem lf_zero_iff {G : Pgame} [G.Impartial] : G ⧏ 0 ↔ 0 ⧏ G := by
  rw [← zero_lf_neg_iff, lf_congr_right (neg_equiv_self G)]
#align pgame.impartial.lf_zero_iff Pgame.Impartial.lf_zero_iff

theorem equiv_zero_iff_le : (G ≈ 0) ↔ G ≤ 0 :=
  ⟨And.left, fun h => ⟨h, le_zero_iff.1 h⟩⟩
#align pgame.impartial.equiv_zero_iff_le Pgame.Impartial.equiv_zero_iff_le

theorem fuzzy_zero_iff_lf : G ‖ 0 ↔ G ⧏ 0 :=
  ⟨And.left, fun h => ⟨h, lf_zero_iff.1 h⟩⟩
#align pgame.impartial.fuzzy_zero_iff_lf Pgame.Impartial.fuzzy_zero_iff_lf

theorem equiv_zero_iff_ge : (G ≈ 0) ↔ 0 ≤ G :=
  ⟨And.right, fun h => ⟨le_zero_iff.2 h, h⟩⟩
#align pgame.impartial.equiv_zero_iff_ge Pgame.Impartial.equiv_zero_iff_ge

theorem fuzzy_zero_iff_gf : G ‖ 0 ↔ 0 ⧏ G :=
  ⟨And.right, fun h => ⟨lf_zero_iff.2 h, h⟩⟩
#align pgame.impartial.fuzzy_zero_iff_gf Pgame.Impartial.fuzzy_zero_iff_gf

theorem forall_leftMoves_fuzzy_iff_equiv_zero : (∀ i, G.moveLeft i ‖ 0) ↔ (G ≈ 0) :=
  by
  refine' ⟨fun hb => _, fun hp i => _⟩
  · rw [equiv_zero_iff_le G, le_zero_lf]
    exact fun i => (hb i).1
  · rw [fuzzy_zero_iff_lf]
    exact hp.1.moveLeft_lf i
#align pgame.impartial.forall_left_moves_fuzzy_iff_equiv_zero Pgame.Impartial.forall_leftMoves_fuzzy_iff_equiv_zero

theorem forall_rightMoves_fuzzy_iff_equiv_zero : (∀ j, G.moveRight j ‖ 0) ↔ (G ≈ 0) :=
  by
  refine' ⟨fun hb => _, fun hp i => _⟩
  · rw [equiv_zero_iff_ge G, zero_le_lf]
    exact fun i => (hb i).2
  · rw [fuzzy_zero_iff_gf]
    exact hp.2.lf_moveRight i
#align pgame.impartial.forall_right_moves_fuzzy_iff_equiv_zero Pgame.Impartial.forall_rightMoves_fuzzy_iff_equiv_zero

theorem exists_left_move_equiv_iff_fuzzy_zero : (∃ i, G.moveLeft i ≈ 0) ↔ G ‖ 0 :=
  by
  refine' ⟨fun ⟨i, hi⟩ => (fuzzy_zero_iff_gf G).2 (lf_of_le_move_left hi.2), fun hn => _⟩
  rw [fuzzy_zero_iff_gf G, zero_lf_le] at hn
  cases' hn with i hi
  exact ⟨i, (equiv_zero_iff_ge _).2 hi⟩
#align pgame.impartial.exists_left_move_equiv_iff_fuzzy_zero Pgame.Impartial.exists_left_move_equiv_iff_fuzzy_zero

theorem exists_right_move_equiv_iff_fuzzy_zero : (∃ j, G.moveRight j ≈ 0) ↔ G ‖ 0 :=
  by
  refine' ⟨fun ⟨i, hi⟩ => (fuzzy_zero_iff_lf G).2 (lf_of_move_right_le hi.1), fun hn => _⟩
  rw [fuzzy_zero_iff_lf G, lf_zero_le] at hn
  cases' hn with i hi
  exact ⟨i, (equiv_zero_iff_le _).2 hi⟩
#align pgame.impartial.exists_right_move_equiv_iff_fuzzy_zero Pgame.Impartial.exists_right_move_equiv_iff_fuzzy_zero

end Impartial

end Pgame


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Johannes Hölzl

(Least / Greatest) upper / lower bounds
-/
import order.complete_lattice
open set lattice

universes u v w x
variables {α : Type u} {β : Type v} {γ : Type w} {ι : Sort x} {a a₁ a₂ : α} {b b₁ b₂ : β} {s t : set α}

section preorder

variables [preorder α] [preorder β] {f : α → β}

def upper_bounds (s : set α) : set α := { x | ∀a ∈ s, a ≤ x }
def lower_bounds (s : set α) : set α := { x | ∀a ∈ s, x ≤ a }
def is_least (s : set α) (a : α) : Prop := a ∈ s ∧ a ∈ lower_bounds s
def is_greatest (s : set α) (a : α) : Prop := a ∈ s ∧ a ∈ upper_bounds s
def is_lub (s : set α) : α → Prop := is_least (upper_bounds s)
def is_glb (s : set α) : α → Prop := is_greatest (lower_bounds s)

lemma mem_upper_bounds_image (Hf : monotone f) (Ha : a ∈ upper_bounds s) :
  f a ∈ upper_bounds (f '' s) :=
ball_image_of_ball (assume x H, Hf (Ha _ ‹x ∈ s›))

lemma mem_lower_bounds_image (Hf : monotone f) (Ha : a ∈ lower_bounds s) :
  f a ∈ lower_bounds (f '' s) :=
ball_image_of_ball (assume x H, Hf (Ha _ ‹x ∈ s›))

lemma is_lub_singleton {a : α} : is_lub {a} a :=
by simp [is_lub, is_least, upper_bounds, lower_bounds] {contextual := tt}

lemma is_glb_singleton {a : α} : is_glb {a} a :=
by simp [is_glb, is_greatest, upper_bounds, lower_bounds] {contextual := tt}

end preorder

section partial_order
variables [partial_order α]

lemma eq_of_is_least_of_is_least (Ha : is_least s a₁) (Hb : is_least s a₂) : a₁ = a₂ :=
le_antisymm (Ha.right _ Hb.left) (Hb.right _ Ha.left)

lemma is_least_iff_eq_of_is_least (Ha : is_least s a₁) : is_least s a₂ ↔ a₁ = a₂ :=
iff.intro (eq_of_is_least_of_is_least Ha) (assume h, h ▸ Ha)

lemma eq_of_is_greatest_of_is_greatest (Ha : is_greatest s a₁) (Hb : is_greatest s a₂) : a₁ = a₂ :=
le_antisymm (Hb.right _ Ha.left) (Ha.right _ Hb.left)

lemma is_greatest_iff_eq_of_is_greatest (Ha : is_greatest s a₁) : is_greatest s a₂ ↔ a₁ = a₂ :=
iff.intro (eq_of_is_greatest_of_is_greatest Ha) (assume h, h ▸ Ha)

lemma eq_of_is_lub_of_is_lub : is_lub s a₁ → is_lub s a₂ → a₁ = a₂ :=
eq_of_is_least_of_is_least

lemma is_lub_iff_eq_of_is_lub : is_lub s a₁ → (is_lub s a₂ ↔ a₁ = a₂) :=
is_least_iff_eq_of_is_least

lemma eq_of_is_glb_of_is_glb : is_glb s a₁ → is_glb s a₂ → a₁ = a₂ :=
eq_of_is_greatest_of_is_greatest

lemma is_glb_iff_eq_of_is_glb : is_glb s a₁ → (is_glb s a₂ ↔ a₁ = a₂) :=
is_greatest_iff_eq_of_is_greatest

lemma ne_empty_of_is_lub [no_bot_order α] (hs : is_lub s a) : s ≠ ∅ :=
let ⟨a', ha'⟩ := no_bot a in
assume h,
have a ≤ a', from hs.right _ (by simp [upper_bounds, h]),
lt_irrefl a $ lt_of_le_of_lt this ha'

lemma ne_empty_of_is_glb [no_top_order α] (hs : is_glb s a) : s ≠ ∅ :=
let ⟨a', ha'⟩ := no_top a in
assume h,
have a' ≤ a, from hs.right _ (by simp [lower_bounds, h]),
lt_irrefl a $ lt_of_lt_of_le ha' this

end partial_order

section lattice

lemma is_glb_empty [order_top α] : is_glb ∅ (⊤:α) :=
by simp [is_glb, is_greatest, lower_bounds, upper_bounds]

lemma is_lub_empty [order_bot α] : is_lub ∅ (⊥:α) :=
by simp [is_lub, is_least, lower_bounds, upper_bounds]

lemma is_lub_union_sup [semilattice_sup α] (hs : is_lub s a₁) (ht : is_lub t a₂) :
  is_lub (s ∪ t) (a₁ ⊔ a₂) :=
⟨assume c h, h.cases_on (le_sup_left_of_le ∘ hs.left c) (le_sup_right_of_le ∘ ht.left c),
  assume c hc, sup_le
    (hs.right _ $ assume d hd, hc _ $ or.inl hd) (ht.right _ $ assume d hd, hc _ $ or.inr hd)⟩

lemma is_glb_union_inf [semilattice_inf α] (hs : is_glb s a₁) (ht : is_glb t a₂) :
  is_glb (s ∪ t) (a₁ ⊓ a₂) :=
⟨assume c h, h.cases_on (inf_le_left_of_le ∘ hs.left c) (inf_le_right_of_le ∘ ht.left c),
  assume c hc, le_inf
    (hs.right _ $ assume d hd, hc _ $ or.inl hd) (ht.right _ $ assume d hd, hc _ $ or.inr hd)⟩

lemma is_lub_insert_sup [semilattice_sup α] (h : is_lub s a₁) : is_lub (insert a₂ s) (a₂ ⊔ a₁) :=
by rw [insert_eq]; exact is_lub_union_sup is_lub_singleton h

lemma is_lub_iff_sup_eq [semilattice_sup α] : is_lub {a₁, a₂} a ↔ a₂ ⊔ a₁ = a :=
is_lub_iff_eq_of_is_lub $ is_lub_insert_sup $ is_lub_singleton

lemma is_glb_insert_inf [semilattice_inf α] (h : is_glb s a₁) : is_glb (insert a₂ s) (a₂ ⊓ a₁) :=
by rw [insert_eq]; exact is_glb_union_inf is_glb_singleton h

lemma is_glb_iff_inf_eq [semilattice_inf α] : is_glb {a₁, a₂} a ↔ a₂ ⊓ a₁ = a :=
is_glb_iff_eq_of_is_glb $ is_glb_insert_inf $ is_glb_singleton

end lattice

section complete_lattice
variables [complete_lattice α] {f : ι → α}

lemma is_lub_Sup : is_lub s (Sup s) := and.intro (assume x, le_Sup) (assume x, Sup_le)

lemma is_lub_supr : is_lub (range f) (⨆j, f j) :=
have is_lub (range f) (Sup (range f)), from is_lub_Sup,
by rwa [Sup_range] at this

lemma is_lub_iff_supr_eq : is_lub (range f) a ↔ (⨆j, f j) = a := is_lub_iff_eq_of_is_lub is_lub_supr
lemma is_lub_iff_Sup_eq : is_lub s a ↔ Sup s = a := is_lub_iff_eq_of_is_lub is_lub_Sup

lemma is_glb_Inf : is_glb s (Inf s) := and.intro (assume a, Inf_le) (assume a, le_Inf)

lemma is_glb_infi : is_glb (range f) (⨅j, f j) :=
have is_glb (range f) (Inf (range f)), from is_glb_Inf,
by rwa [Inf_range] at this

lemma is_glb_iff_infi_eq : is_glb (range f) a ↔ (⨅j, f j) = a := is_glb_iff_eq_of_is_glb is_glb_infi
lemma is_glb_iff_Inf_eq : is_glb s a ↔ Inf s = a := is_glb_iff_eq_of_is_glb is_glb_Inf

end complete_lattice


/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Stephen Morgan, Scott Morrison, Johannes Hölzl, Reid Barton

! This file was ported from Lean 3 source module category_theory.category.preorder
! leanprover-community/mathlib commit dc6c365e751e34d100e80fe6e314c3c3e0fd2988
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.CategoryTheory.Equivalence
import Mathlib.Order.Hom.Basic

/-!

# Preorders as categories

We install a category instance on any preorder. This is not to be confused with the category _of_
preorders, defined in `Order.Category.Preorder`.

We show that monotone functions between preorders correspond to functors of the associated
categories.

## Main definitions

* `homOfLE` and `leOfHom` provide translations between inequalities in the preorder, and
  morphisms in the associated category.
* `Monotone.functor` is the functor associated to a monotone function.

-/

universe u v

namespace Preorder

open CategoryTheory

-- see Note [lower instance priority]
/--
The category structure coming from a preorder. There is a morphism `X ⟶ Y` if and only if `X ≤ Y`.

Because we don't allow morphisms to live in `Prop`,
we have to define `X ⟶ Y` as `ULift (PLift (X ≤ Y))`.
See `CategoryTheory.homOfLE` and `CategoryTheory.leOfHom`.

See <https://stacks.math.columbia.edu/tag/00D3>.
-/
instance (priority := 100) smallCategory (α : Type u) [Preorder α] : SmallCategory α where
  Hom U V := ULift (PLift (U ≤ V))
  id X := ⟨⟨le_refl X⟩⟩
  comp f g := ⟨⟨le_trans _ _ _ f.down.down g.down.down⟩⟩
#align preorder.small_category Preorder.smallCategory

end Preorder

namespace CategoryTheory

open Opposite

variable {X : Type u} [Preorder X]

/-- Express an inequality as a morphism in the corresponding preorder category.
-/
def homOfLE {x y : X} (h : x ≤ y) : x ⟶ y :=
  ULift.up (PLift.up h)
#align category_theory.hom_of_le CategoryTheory.homOfLE

alias homOfLE ← _root_.LE.le.hom
#align has_le.le.hom LE.le.hom

@[simp]
theorem homOfLE_refl {x : X} : (le_refl x).hom = 𝟙 x :=
  rfl
#align category_theory.hom_of_le_refl CategoryTheory.homOfLE_refl

@[simp]
theorem homOfLE_comp {x y z : X} (h : x ≤ y) (k : y ≤ z) :
    homOfLE h ≫ homOfLE k = homOfLE (h.trans k) :=
  rfl
#align category_theory.hom_of_le_comp CategoryTheory.homOfLE_comp

/-- Extract the underlying inequality from a morphism in a preorder category.
-/
theorem leOfHom {x y : X} (h : x ⟶ y) : x ≤ y :=
  h.down.down
#align category_theory.le_of_hom CategoryTheory.leOfHom

alias leOfHom ← _root_.Quiver.Hom.le
#align quiver.hom.le Quiver.Hom.le

-- porting note: why does this lemma exist? With proof irrelevance, we don't need to simplify proofs
-- @[simp]
theorem leOfHom_homOfLE {x y : X} (h : x ≤ y) : h.hom.le = h :=
  rfl
#align category_theory.le_of_hom_hom_of_le CategoryTheory.leOfHom_homOfLE

-- porting note: linter gives: "Left-hand side does not simplify, when using the simp lemma on
-- itself. This usually means that it will never apply." removing simp? It doesn't fire
-- @[simp]
theorem homOfLE_leOfHom {x y : X} (h : x ⟶ y) : h.le.hom = h :=
  rfl
#align category_theory.hom_of_le_le_of_hom CategoryTheory.homOfLE_leOfHom

/-- Construct a morphism in the opposite of a preorder category from an inequality. -/
def opHomOfLe {x y : Xᵒᵖ} (h : unop x ≤ unop y) : y ⟶ x :=
  (homOfLE h).op
#align category_theory.op_hom_of_le CategoryTheory.opHomOfLe

theorem le_of_op_hom {x y : Xᵒᵖ} (h : x ⟶ y) : unop y ≤ unop x :=
  h.unop.le
#align category_theory.le_of_op_hom CategoryTheory.le_of_op_hom

instance uniqueToTop [OrderTop X] {x : X} : Unique (x ⟶ ⊤) where
  default := homOfLE le_top
  uniq := fun a => by rfl
#align category_theory.unique_to_top CategoryTheory.uniqueToTop

instance uniqueFromBot [OrderBot X] {x : X} : Unique (⊥ ⟶ x) where
  default := homOfLE bot_le
  uniq := fun a => by rfl
#align category_theory.unique_from_bot CategoryTheory.uniqueFromBot

end CategoryTheory

section

variable {X : Type u} {Y : Type v} [Preorder X] [Preorder Y]

/-- A monotone function between preorders induces a functor between the associated categories.
-/
def Monotone.functor {f : X → Y} (h : Monotone f) : X ⥤ Y where
  obj := f
  map g := CategoryTheory.homOfLE (h g.le)
#align monotone.functor Monotone.functor

@[simp]
theorem Monotone.functor_obj {f : X → Y} (h : Monotone f) : h.functor.obj = f :=
  rfl
#align monotone.functor_obj Monotone.functor_obj

end

namespace CategoryTheory

section Preorder

variable {X : Type u} {Y : Type v} [Preorder X] [Preorder Y]

/-- A functor between preorder categories is monotone.
-/
@[mono]
theorem Functor.monotone (f : X ⥤ Y) : Monotone f.obj := fun _ _ hxy => (f.map hxy.hom).le
#align category_theory.functor.monotone CategoryTheory.Functor.monotone

end Preorder

section PartialOrder

variable {X : Type u} {Y : Type v} [PartialOrder X] [PartialOrder Y]

theorem Iso.to_eq {x y : X} (f : x ≅ y) : x = y :=
  le_antisymm f.hom.le f.inv.le
#align category_theory.iso.to_eq CategoryTheory.Iso.to_eq

/-- A categorical equivalence between partial orders is just an order isomorphism.
-/
def Equivalence.toOrderIso (e : X ≌ Y) : X ≃o Y where
  toFun := e.functor.obj
  invFun := e.inverse.obj
  left_inv a := (e.unitIso.app a).to_eq.symm
  right_inv b := (e.counitIso.app b).to_eq
  map_rel_iff' {a a'} :=
    ⟨fun h =>
      ((Equivalence.unit e).app a ≫ e.inverse.map h.hom ≫ (Equivalence.unitInv e).app a').le,
      fun h : a ≤ a' => (e.functor.map h.hom).le⟩
#align category_theory.equivalence.to_order_iso CategoryTheory.Equivalence.toOrderIso

-- `@[simps]` on `Equivalence.toOrderIso` produces lemmas that fail the `simpNF` linter,
-- so we provide them by hand:
@[simp]
theorem Equivalence.toOrderIso_apply (e : X ≌ Y) (x : X) : e.toOrderIso x = e.functor.obj x :=
  rfl
#align category_theory.equivalence.to_order_iso_apply CategoryTheory.Equivalence.toOrderIso_apply

@[simp]
theorem Equivalence.toOrderIso_symm_apply (e : X ≌ Y) (y : Y) :
    e.toOrderIso.symm y = e.inverse.obj y :=
  rfl
#align category_theory.equivalence.to_order_iso_symm_apply CategoryTheory.Equivalence.toOrderIso_symm_apply

end PartialOrder

end CategoryTheory


/-
Copyright (c) 2021 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser
-/
import group_theory.subgroup.pointwise
import linear_algebra.span

/-! # Pointwise instances on `submodule`s

This file provides:

* `submodule.has_pointwise_neg`

and the actions

* `submodule.pointwise_distrib_mul_action`
* `submodule.pointwise_mul_action_with_zero`

which matches the action of `mul_action_set`.

These actions are available in the `pointwise` locale.

## Implementation notes

Most of the lemmas in this file are direct copies of lemmas from
`group_theory/submonoid/pointwise.lean`.
-/

variables {α : Type*} {R : Type*} {M : Type*}

open_locale pointwise

namespace submodule

section neg

section semiring
variables [semiring R] [add_comm_group M] [module R M]

/-- The submodule with every element negated. Note if `R` is a ring and not just a semiring, this
is a no-op, as shown by `submodule.neg_eq_self`.

Recall that When `R` is the semiring corresponding to the nonnegative elements of `R'`,
`submodule R' M` is the type of cones of `M`. This instance reflects such cones about `0`.

This is available as an instance in the `pointwise` locale. -/
protected def has_pointwise_neg : has_neg (submodule R M) :=
{ neg := λ p,
  { carrier := -(p : set M),
    smul_mem' := λ r m hm, set.mem_neg.2 $ smul_neg r m ▸ p.smul_mem r $ set.mem_neg.1 hm,
    ..(- p.to_add_submonoid) } }

localized "attribute [instance] submodule.has_pointwise_neg" in pointwise
open_locale pointwise

@[simp] lemma coe_set_neg (S : submodule R M) : ↑(-S) = -(S : set M) := rfl

@[simp] lemma neg_to_add_submonoid (S : submodule R M) :
  (-S).to_add_submonoid = -S.to_add_submonoid := rfl

@[simp] lemma mem_neg {g : M} {S : submodule R M} : g ∈ -S ↔ -g ∈ S := iff.rfl

/-- `submodule.has_pointwise_neg` is involutive.

This is available as an instance in the `pointwise` locale. -/
protected def has_involutive_pointwise_neg : has_involutive_neg (submodule R M) :=
{ neg := has_neg.neg,
  neg_neg := λ S, set_like.coe_injective $ neg_neg _ }

localized "attribute [instance] submodule.has_involutive_pointwise_neg" in pointwise

@[simp] lemma neg_le_neg (S T : submodule R M) : -S ≤ -T ↔ S ≤ T :=
set_like.coe_subset_coe.symm.trans set.neg_subset_neg

lemma neg_le (S T : submodule R M) : -S ≤ T ↔ S ≤ -T :=
set_like.coe_subset_coe.symm.trans set.neg_subset

/-- `submodule.has_pointwise_neg` as an order isomorphism. -/
def neg_order_iso : submodule R M ≃o submodule R M :=
{ to_equiv := equiv.neg _,
  map_rel_iff' := neg_le_neg }

lemma closure_neg (s : set M) : span R (-s) = -(span R s) :=
begin
  apply le_antisymm,
  { rw [span_le, coe_set_neg, ←set.neg_subset, neg_neg],
    exact subset_span },
  { rw [neg_le, span_le, coe_set_neg, ←set.neg_subset],
    exact subset_span }
end

@[simp]
lemma neg_inf (S T : submodule R M) : -(S ⊓ T) = (-S) ⊓ (-T) :=
set_like.coe_injective set.inter_neg

@[simp]
lemma neg_sup (S T : submodule R M) : -(S ⊔ T) = (-S) ⊔ (-T) :=
(neg_order_iso : submodule R M ≃o submodule R M).map_sup S T

@[simp]
lemma neg_bot : -(⊥ : submodule R M) = ⊥ :=
set_like.coe_injective $ (set.neg_singleton 0).trans $ congr_arg _ neg_zero

@[simp]
lemma neg_top : -(⊤ : submodule R M) = ⊤ :=
set_like.coe_injective $ set.neg_univ

@[simp]
lemma neg_infi {ι : Sort*} (S : ι → submodule R M) : -(⨅ i, S i) = ⨅ i, -S i :=
(neg_order_iso : submodule R M ≃o submodule R M).map_infi _

@[simp]
lemma neg_supr {ι : Sort*} (S : ι → submodule R M) : -(⨆ i, S i) = ⨆ i, -(S i) :=
(neg_order_iso : submodule R M ≃o submodule R M).map_supr _

end semiring

open_locale pointwise

@[simp] lemma neg_eq_self [ring R] [add_comm_group M] [module R M] (p : submodule R M) : -p = p :=
ext $ λ _, p.neg_mem_iff

end neg

variables [semiring R] [add_comm_monoid M] [module R M]

instance pointwise_add_comm_monoid : add_comm_monoid (submodule R M) :=
{ add := (⊔),
  add_assoc := λ _ _ _, sup_assoc,
  zero := ⊥,
  zero_add := λ _, bot_sup_eq,
  add_zero := λ _, sup_bot_eq,
  add_comm := λ _ _, sup_comm }

@[simp] lemma add_eq_sup (p q : submodule R M) : p + q = p ⊔ q := rfl
@[simp] lemma zero_eq_bot : (0 : submodule R M) = ⊥ := rfl

section
variables [monoid α] [distrib_mul_action α M] [smul_comm_class α R M]

/-- The action on a submodule corresponding to applying the action to every element.

This is available as an instance in the `pointwise` locale. -/
protected def pointwise_distrib_mul_action : distrib_mul_action α (submodule R M) :=
{ smul := λ a S, S.map (distrib_mul_action.to_linear_map _ _ a),
  one_smul := λ S,
    (congr_arg (λ f, S.map f) (linear_map.ext $ by exact one_smul α)).trans S.map_id,
  mul_smul := λ a₁ a₂ S,
    (congr_arg (λ f : M →ₗ[R] M, S.map f) (linear_map.ext $ by exact mul_smul _ _)).trans
      (S.map_comp _ _),
  smul_zero := λ a, map_bot _,
  smul_add := λ a S₁ S₂, map_sup _ _ _ }

localized "attribute [instance] submodule.pointwise_distrib_mul_action" in pointwise
open_locale pointwise

@[simp] lemma coe_pointwise_smul (a : α) (S : submodule R M) : ↑(a • S) = a • (S : set M) := rfl

@[simp] lemma pointwise_smul_to_add_submonoid (a : α) (S : submodule R M) :
  (a • S).to_add_submonoid = a • S.to_add_submonoid := rfl

@[simp] lemma pointwise_smul_to_add_subgroup {R M : Type*}
  [ring R] [add_comm_group M] [distrib_mul_action α M] [module R M] [smul_comm_class α R M]
  (a : α) (S : submodule R M) :
  (a • S).to_add_subgroup = a • S.to_add_subgroup := rfl

lemma smul_mem_pointwise_smul (m : M) (a : α) (S : submodule R M) : m ∈ S → a • m ∈ a • S :=
(set.smul_mem_smul_set : _ → _ ∈ a • (S : set M))

instance pointwise_central_scalar [distrib_mul_action αᵐᵒᵖ M] [smul_comm_class αᵐᵒᵖ R M]
  [is_central_scalar α M] :
  is_central_scalar α (submodule R M) :=
⟨λ a S, congr_arg (λ f, S.map f) $ linear_map.ext $ by exact op_smul_eq_smul _⟩

@[simp] lemma smul_le_self_of_tower {α : Type*}
  [semiring α] [module α R] [module α M] [smul_comm_class α R M] [is_scalar_tower α R M]
  (a : α) (S : submodule R M) : a • S ≤ S :=
begin
  rintro y ⟨x, hx, rfl⟩,
  exact smul_of_tower_mem _ a hx,
end

end

section
variables [semiring α] [module α M] [smul_comm_class α R M]
/-- The action on a submodule corresponding to applying the action to every element.

This is available as an instance in the `pointwise` locale.

This is a stronger version of `submodule.pointwise_distrib_mul_action`. Note that `add_smul` does
not hold so this cannot be stated as a `module`. -/
protected def pointwise_mul_action_with_zero : mul_action_with_zero α (submodule R M) :=
{ zero_smul := λ S,
    (congr_arg (λ f : M →ₗ[R] M, S.map f) (linear_map.ext $ by exact zero_smul α)).trans S.map_zero,
  .. submodule.pointwise_distrib_mul_action }

localized "attribute [instance] submodule.pointwise_mul_action_with_zero" in pointwise

end

end submodule


import Chap5
namespace HTPI
set_option pp.funBinderTypes true

-- Version of finite sets using relations rather than sets of ordered pairs

theorem RelExt {A B : Type} (R S : Rel A B)
    (h : ∀ (a : A) (b : B), R a b ↔ S a b) : R = S := by
  apply funext
  fix a
  apply funext
  fix b
  rewrite [h]
  rfl

def invRel {A B : Type} (R : Rel A B) (b : B) (a : A) : Prop := R a b

theorem invRel_invRel {A B : Type} (R : Rel A B) : invRel (invRel R) = R := by
  apply RelExt
  fix a; fix b
  rfl
  done

theorem invRel_def {A B : Type} (R : Rel A B) (a : A) (b : B) :
    invRel R b a ↔ R a b := by rfl

/- Basic properties of finite sets -/

def I (n : Nat) : Set Nat := { k : Nat | 1 ≤ k ∧ k ≤ n }

theorem I_1 {n : Nat} (h : n > 0) : 1 ∈ I n := by
  define
  apply And.intro _ h
  norm_num
  done

theorem I_top {n : Nat} (h : n > 0) : n ∈ I n := by
  define
  apply And.intro h
  linarith
  done

theorem I_0_empty : empty (I 0) := by
  define
  by_contra h1
  obtain x h2 from h1
  define at h2
  linarith
  done

theorem I_1_singleton : I 1 = {1} := by
  apply Set.ext
  fix x
  apply Iff.intro
  · -- (→)
    assume h1
    define at h1
    define
    exact Nat.le_antisymm h1.right h1.left
    done
  · -- (←)
    assume h1
    define at h1
    rewrite [h1]
    exact I_1 zero_lt_one
    done
  done

theorem I_diff (n : Nat) : I (n + 1) \ { n + 1 } = I n := by
  apply Set.ext
  fix x
  apply Iff.intro
  · -- (→)
    assume h1
    define
    define at h1
    have h2 := h1.left
    have h3 := h1.right
    define at h2
    define at h3
    apply And.intro h2.left
    have h4 : x < n + 1 := Nat.lt_of_le_of_ne h2.right h3
    exact Nat.le_of_lt_succ h4
    done
  · -- (←)
    assume h1
    define; define at h1
    apply And.intro
    · -- Proof that x ∈ I (n + 1)
      define
      apply And.intro h1.left
      linarith
      done
    · -- Proof that x ∉ {n + 1}
      by_contra h2
      define at h2
      rewrite [h2] at h1
      linarith
      done
    done
  done

def pairing {A B : Type} (R : Rel A B) (X : Set A) (Y : Set B) : Prop :=
    ∀ (x : A) (y : B), R x y → x ∈ X ∧ y ∈ Y

def match_from {A B : Type} (R : Rel A B) (X : Set A) : Prop :=
    ∀ x ∈ X, ∃! (y : B), R x y

def matching {A B : Type} (R : Rel A B) (X : Set A) (Y : Set B) : Prop :=
    pairing R X Y ∧ match_from R X ∧ match_from (invRel R) Y

def equinum {A B : Type} (X : Set A) (Y : Set B) : Prop :=
    ∃ (R : Rel A B), matching R X Y

def numElts {A : Type} (X : Set A) (n : Nat) : Prop :=
    equinum (I n) X

def finite {A : Type} (X : Set A) : Prop :=
    ∃ (n : Nat), numElts X n

theorem match_pair {A B : Type} {R : Rel A B} {X : Set A} {Y : Set B} {a : A} {b : B}
    (h1 : matching R X Y) (h2 : R a b) : a ∈ X ∧ b ∈ Y := by
  define at h1
  have h3 := h1.left
  define at h3
  exact h3 a b h2
  done

theorem match_inv {A B : Type} {R : Rel A B} {X : Set A} {Y : Set B}
    (h : matching R X Y) : matching (invRel R) Y X := by
  define
  apply And.intro
  · -- Proof that pairing R Y X
    define
    fix y; fix x
    assume h1
    define at h1
    have h2 := match_pair h h1
    exact And.intro h2.right h2.left
    done
  · -- proof that match_from (inv R) Y ∧ match_from (inv (inv R)) X
    rewrite [invRel_invRel]
    define at h
    exact And.intro h.right.right h.right.left
    done
  done

theorem match_unique {A B : Type} {R : Rel A B} {X : Set A} {j : A} {u v : B}
    (h1 : match_from R X) (h2 : j ∈ X) (h3 : R j u) (h4 : R j v) : u = v := by
  define at h1
  have h5 := h1 j h2
  obtain z _h6 h7 from h5
  exact h7 u v h3 h4
  done

def remove_one {A B : Type} (R : Rel A B) (u : A) (v : B) (x : A) (y : B) : Prop :=
    x ≠ u ∧ y ≠ v ∧ (R x y ∨ (R x v ∧ R u y))

theorem remove_one_pair {A B : Type} {R : Rel A B} {X : Set A} {Y : Set B} {x u : A} {y v : B}
    (h1 : matching R X Y) (h2 : remove_one R u v x y) : x ∈ X \ {u} ∧ y ∈ Y \ {v} := by
  define at h2
  have h3 : x ∈ X ∧ y ∈ Y := by
    by_cases on h2.right.right with h3
    · -- Case 1. h3: R x y
      exact match_pair h1 h3
      done
    · -- Case 2. h3: R x v ∧ R y u
      have h4 := match_pair h1 h3.left
      have h5 := match_pair h1 h3.right
      exact And.intro h4.left h5.right
      done
    done
  exact And.intro (And.intro h3.left h2.left) (And.intro h3.right h2.right.left)
  done

theorem remove_inv_comm {A B : Type} (R : Rel A B) (u : A) (v : B) :
    invRel (remove_one R u v) = remove_one (invRel R) v u := by
  apply RelExt
  fix b; fix a
  define : invRel (remove_one R u v) b a
  define : remove_one (invRel R) v u b a
  rewrite [invRel_def, invRel_def, invRel_def]
  rewrite [←and_assoc, @and_comm (¬a = u), and_assoc, @and_comm (R a v)]
  rfl
  done

theorem remove_iff_1 {A B : Type} {R : Rel A B} {X : Set A} {Y : Set B} {x u : A} {v : B}
    (h1 : matching R X Y) (h2 : x ≠ u) (h3 : R x v) :
    ∀ (y : B), remove_one R u v x y ↔ R u y := by
  fix y
  have h4 := match_pair h1 h3
  apply Iff.intro
  · -- (→)
    assume h5
    define at h5
    by_cases on h5.right.right with h6
    · -- Case 1. h6: (x, y) ∈ R
      have h7 := match_unique h1.right.left h4.left h6 h3
      exact absurd h7 h5.right.left
      done
    · -- Case 2. h6: (x, v) ∈ R ∧ (u, y) ∈ R
      exact h6.right
      done
    done
  · -- (←)
    assume h5
    define
    apply And.intro h2
    apply And.intro _ (Or.inr (And.intro h3 h5))
    contradict h2 with h6
    rewrite [h6] at h5
    exact match_unique h1.right.right h4.right h3 h5
    done
  done

theorem remove_iff_2 {A B : Type} {R : Rel A B} {x u : A} {v : B}
    (h2 : x ≠ u) (h3 : ¬R x v) :
    ∀ (y : B), remove_one R u v x y ↔ R x y := by
  fix y
  apply Iff.intro
  · -- (→)
    assume h4
    define at h4
    by_cases on h4.right.right with h5
    · -- Case 1. h5: (x, y) ∈ R
      exact h5
      done
    · -- Case 2. h5: (x, v) ∈ R ∧ (u, y) ∈ R
      exact absurd h5.left h3
      done
    done
  · -- (←)
    assume h4
    define
    apply And.intro h2
    apply And.intro _ (Or.inl h4)
    contradict h3 with h5
    rewrite [h5] at h4
    exact h4
    done
  done

theorem unique_in_remove_one {A B : Type} {R : Rel A B} {X : Set A} {Y : Set B} {w x u : A} {v : B}
    (h1 : matching R X Y) (h2 : w ∈ X) (h3 : ∀ (y : B), remove_one R u v x y ↔ R w y) :
    ∃! (y : B), remove_one R u v x y := by
  have h4 := h1.right.left w h2
  define at h4; define
  obtain z h5 from h4
  apply Exists.intro z
  rewrite [h3 z]
  apply And.intro h5.left
  fix y1
  rewrite [h3 y1]
  exact h5.right y1
  done

theorem remove_one_match_from {A B : Type} {R : Rel A B} {X : Set A} {Y : Set B} {u : A}
    (h1 : matching R X Y) (h2 : u ∈ X) (v : B): match_from (remove_one R u v) (X \ {u}) := by
  define
  fix x
  assume h4
  define at h4
  by_cases h5 : R x v
  · -- Case 1. h5: R x v
    exact unique_in_remove_one h1 h2 (remove_iff_1 h1 h4.right h5)
    done
  · -- Case 2. h5: ¬R x v
    exact unique_in_remove_one h1 h4.left (remove_iff_2 h4.right h5)
    done
  done

theorem remove_one_matching {A B : Type} {R : Rel A B} {X : Set A} {Y : Set B} {u : A} {v : B}
    (h1 : matching R X Y) (h2 : u ∈ X) (h3 : v ∈ Y) :
    matching (remove_one R u v) (X \ {u}) (Y \ {v}) := by
  define
  apply And.intro
  · -- Proof of pairing
    define
    fix x; fix y
    assume h4
    exact remove_one_pair h1 h4
    done
  · -- Proof of match_froms
    apply And.intro (remove_one_match_from h1 h2 v)
    rewrite [remove_inv_comm]
    exact remove_one_match_from (match_inv h1) h3 u
  done

theorem empty_match_from {A B : Type} {R : Rel A B} {X : Set A} (h : empty X) : match_from R X := by
  define
  fix x
  assume h1
  define at h
  contradict h
  exact Exists.intro x h1
  done

def one_match {A B : Type} (a : A) (b : B) (x : A) (y : B) : Prop :=
    x = a ∧ y = b

theorem one_elt_match_from {A B : Type} (a : A) (b : B) :
    match_from (one_match a b) {a} := by
  define
  fix x
  assume h1
  define at h1
  rewrite [h1]
  exists_unique
  · -- Existence
    apply Exists.intro b
    define
    apply And.intro
    rfl
    rfl
    done
  · -- Uniqueness
    fix b1; fix b2
    assume h2; assume h3
    define at h2; define at h3
    rewrite [h3.right]
    exact h2.right
    done
  done

/- Basic theorems about finite sets and number of elements -/

theorem remove_one_equinum {A B : Type} {X : Set A} {Y : Set B} {x : A} {y : B}
    (h1 : equinum X Y) (h2 : x ∈ X) (h3 : y ∈ Y) : equinum (X \ { x }) (Y \ { y }) := by
  define
  obtain R h4 from h1
  apply Exists.intro (remove_one R x y)
  exact remove_one_matching h4 h2 h3
  done

theorem remove_one_numElts {A : Type} {X : Set A} {n : Nat} {x : A}
    (h1 : numElts X (n + 1)) (h2 : x ∈ X) : numElts (X \ {x}) n := by
  have h3 : n + 1 ∈ I (n + 1) := I_top (Nat.zero_lt_succ n)
  unfold numElts at h1
  have h4 := remove_one_equinum h1 h3 h2
  rewrite [I_diff] at h4
  exact h4
  done

def empty_match {A B : Type} (a : A) (b : B) : Prop := False

theorem zero_elts_iff_empty {A : Type} (X : Set A) : numElts X 0 ↔ empty X := by
  apply Iff.intro
  · -- (→)
    assume h1
    define
    by_contra h2
    obtain x h3 from h2
    define at h1
    obtain R h4 from h1
    obtain j h5 _h6 from h4.right.right x h3
    define at h5
    have h7 := match_pair h4 h5
    contradict I_0_empty
    exact Exists.intro j h7.left
    done
  · -- (←)
    assume h1
    define
    apply Exists.intro empty_match
    define
    apply And.intro
    · -- Proof of pairing
      define
      fix n; fix a
      assume h2
      exact False.elim h2
      done
    · -- Proofs of match_from
      apply And.intro
      · -- Proof of match_from empty_match (I 0)
        exact empty_match_from I_0_empty
        done
      · -- Proof of match_from (invRel empty_match) X
        exact empty_match_from h1
        done
      done
    done
  done

theorem one_elt_iff_singleton {A : Type} (X : Set A) : numElts X 1 ↔ ∃ (x : A), X = {x} := by
  define : numElts X 1
  rewrite [I_1_singleton]
  apply Iff.intro
  · -- (→)
    assume h1
    obtain R h2 from h1
    have h3 : 1 ∈ {1} := by define; rfl
    obtain x h4 _h5 from h2.right.left 1 h3
    have h6 := match_pair h2 h4
    apply Exists.intro x
    apply Set.ext
    fix a
    apply Iff.intro
    · -- (→)
      assume h7
      define
      have h8 := h2.right.right a h7
      obtain j h9 _h10 from h8
      define at h9
      have h11 := match_pair h2 h9
      have h12 := h11.left
      define at h12
      rewrite [h12] at h9
      exact match_unique h2.right.left h3 h9 h4
      done
    · -- (←)
      assume h7
      define at h7
      rewrite [h7]
      exact h6.right
      done
    done
  · -- (←)
    assume h1
    obtain x h2 from h1
    let R : Rel Nat A := one_match 1 x
    apply Exists.intro R
    define
    apply And.intro
    · -- Proof of pairing R {1} X
      define
      fix n; fix a
      assume h3
      define at h3
      rewrite [h3.left, h3.right, h2]
      apply And.intro
      · -- Proof that 1 ∈ {1}
        define
        rfl
        done
      · -- Proof that x ∈ {x}
        define
        rfl
        done
      done
    · -- Proof of matchings
      apply And.intro
      · -- Proof that match_from R {1}
        exact one_elt_match_from 1 x
        done
      · -- Proof that match_from (inv R) X
        have h3 : invRel R = one_match x 1 := by
          apply RelExt
          fix y; fix n
          define : invRel R y n
          define : one_match x 1 y n
          rewrite [and_comm]
          rfl
          done
        rewrite [h2, h3]
        exact one_elt_match_from x 1
        done
      done
    done
  done

theorem nonempty_of_pos_numElts {A : Type} {X : Set A} {n : Nat}
    (h1 : numElts X n) (h2 : n > 0) : ∃ (x : A), x ∈ X := by
  obtain R h3 from h1
  have h4 : 1 ∈ I n := I_1 h2
  have h5 := h3.right.left 1 h4
  obtain x h6 _h7 from h5
  have h8 := match_pair h3 h6
  exact Exists.intro x h8.right