namespace xena
inductive xnat
| zero : xnat
| succ : xnat → xnat

open xnat
open classical
--#check @succ.inj

definition one := succ zero
definition two := succ one

definition add : xnat → xnat → xnat
| n zero := n
| n (succ p) := succ (add n p)

notation a + b := add a b

theorem one_add_one_equals_two : one + one = two :=
begin
unfold two,
unfold one,
unfold add,
end

theorem add_zero (n : xnat) : n + zero = n :=
begin
unfold add
end

 theorem zero_add (n : xnat) : zero + n = n :=
begin
induction n with t Ht,
  refl,
unfold add,
rewrite [Ht],
end

theorem add_assoc (a b c : xnat) : (a + b) + c = a + (b + c) :=
begin
induction c with t Ht,
refl,
unfold add,
rewrite [Ht]
end

theorem zero_add_eq_add_zero (n : xnat) : zero + n = n + zero :=
begin
rewrite [zero_add],
unfold add
end

theorem one_add_eq_succ (n : xnat) : one + n = succ n :=
begin
unfold one,
induction n with t Ht,
refl,
unfold add,
rewrite [Ht]
end

theorem add_comm (a b : xnat) : a + b = b + a :=
begin
induction b with t Ht,
rw [←zero_add_eq_add_zero],
unfold add,
rewrite [Ht],
rewrite [←one_add_eq_succ],
rewrite [← add_assoc],
rw [one_add_eq_succ]
end

theorem eq_iff_succ_eq_succ (a b : xnat) : succ a = succ b ↔ a = b :=
begin
split,
  exact succ.inj,
assume H : a = b,
rw [H]
end

theorem add_cancel_right (a b t : xnat) :  a = b ↔ a+t = b+t :=
begin
split,
assume H : a = b,
rw [H],
assume P : a+t = b+t,
induction t with s Qs,
have h3: a = a + zero, by exact add_zero a,
have h4: b = b+ zero, by exact add_zero b,
rw [h3, h4], assumption,
rw [Qs],
unfold add at P,
rw [eq_iff_succ_eq_succ] at P,assumption
end

definition mul : xnat → xnat → xnat
| n zero := zero
| n (succ p) := n + (mul n p)

notation a * b := mul a b

example : one * one = one :=
begin
refl
end

theorem mul_zero (a : xnat) : a * zero = zero :=
begin
unfold mul
end

theorem zero_mul (a : xnat) : zero * a = zero :=
begin
induction a with t Ht,
refl,
unfold mul,
rewrite [Ht],
refl
end

theorem mul_one (a : xnat) : a * one = a :=
begin
unfold one,
unfold mul,
rewrite [add_zero]
end

theorem one_mul (a : xnat) : one * a = a :=
begin
induction a with t Ht,
  refl,
unfold mul,
rewrite [Ht],
rewrite [one_add_eq_succ]
end

theorem zero_sum : zero + zero = zero :=
begin
unfold add,
end

theorem right_distrib (a b c : xnat) : a * (b + c) = a* b + a * c :=
begin
induction c with t Ht,
rw [add_zero],
rw [mul_zero],
rw [add_zero],
unfold add,
unfold mul,
rewrite [Ht],
rw [← add_assoc],
rw [← add_assoc],
rw [← add_cancel_right],
rw [add_comm]
end

theorem add_one_eq_succ (n : xnat) : n + one = succ n :=
begin
unfold one,
unfold add,
end

theorem left_distrib (a b c : xnat) : (a + b) * c = a * c + b * c :=
begin
induction c with n Hn,
  unfold mul,
  refl,
rw [←add_one_eq_succ,right_distrib,Hn,right_distrib,right_distrib],
rw [mul_one,mul_one,mul_one],
rw [add_assoc,←add_assoc (b*n),add_comm (b*n),←add_assoc,←add_assoc,←add_assoc],
end

theorem mul_assoc (a b c : xnat) : (a * b) * c = a * (b * c) :=
begin
induction c with n Hn,
refl,
unfold mul,
rw [Hn,right_distrib],
end

theorem mul_comm (a b : xnat) : a * b = b * a :=
begin
induction b with n Hn,
rw [mul_zero,zero_mul],
rw[← one_add_eq_succ,right_distrib,left_distrib,Hn,one_mul,mul_one]
end

definition lt : xnat → xnat → Prop
| zero zero := false
| (succ m) zero := false
| zero (succ p) := true
| (succ m) (succ p) := lt m p

definition gt : xnat → xnat → Prop
| zero zero := false
| (succ m) zero := true
| zero (succ p) := false
| (succ m) (succ p) := gt m p

notation a < b := lt a b
notation b > a := gt a b

theorem inequality_A1 (a b t : xnat) : a < b → a + t < b + t :=
begin
intro H,
induction t with n Hn,
rw [add_zero,add_zero],assumption,
rw [← add_one_eq_succ,← add_assoc,← add_assoc],
rw [add_one_eq_succ,add_one_eq_succ],
unfold lt, assumption
end

end xena


theorem succ_eq_succ_iff (a b : mynat) : succ a = succ b ↔ a = b :=
begin
split,
exact succ_inj,
exact succ_eq_succ_of_eq,
end


/-
Copyright (c) 2020 Bhavik Mehta, Aaron Anderson. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta, Aaron Anderson
-/
import ring_theory.power_series.basic
import combinatorics.partition
import data.nat.parity
import data.finset.nat_antidiagonal
import tactic.interval_cases
import tactic.apply_fun

/-!
# Euler's Partition Theorem

This file proves Theorem 45 from the [100 Theorems List](https://www.cs.ru.nl/~freek/100/).

The theorem concerns the counting of integer partitions -- ways of
writing a positive integer `n` as a sum of positive integer parts.

Specifically, Euler proved that the number of integer partitions of `n`
into *distinct* parts equals the number of partitions of `n` into *odd*
parts.

## Proof outline

The proof is based on the generating functions for odd and distinct partitions, which turn out to be
equal:

$$\prod_{i=0}^\infty \frac {1}{1-X^{2i+1}} = \prod_{i=0}^\infty (1+X^{i+1})$$

In fact, we do not take a limit: it turns out that comparing the `n`'th coefficients of the partial
products up to `m := n + 1` is sufficient.

In particular, we

1. define the partial product for the generating function for odd partitions `partial_odd_gf m` :=
  $$\prod_{i=0}^m \frac {1}{1-X^{2i+1}}$$;
2. prove `odd_gf_prop`: if `m` is big enough (`m * 2 > n`), the partial product's coefficient counts
  the number of odd partitions;
3. define the partial product for the generating function for distinct partitions
  `partial_distinct_gf m` := $$\prod_{i=0}^m (1+X^{i+1})$$;
4. prove `distinct_gf_prop`: if `m` is big enough (`m + 1 > n`), the `n`th coefficient of the
  partial product counts the number of distinct partitions of `n`;
5. prove `same_coeffs`: if m is big enough (`m ≥ n`), the `n`th coefficient of the partial products
  are equal;
6. combine the above in `partition_theorem`.

## References
https://en.wikipedia.org/wiki/Partition_(number_theory)#Odd_parts_and_distinct_parts
-/

open power_series
noncomputable theory

variables {α : Type*}

open finset
open_locale big_operators
open_locale classical

/--
The partial product for the generating function for odd partitions.
TODO: As `m` tends to infinity, this converges (in the `X`-adic topology).

If `m` is sufficiently large, the `i`th coefficient gives the number of odd partitions of the
natural number `i`: proved in `odd_gf_prop`.
It is stated for an arbitrary field `α`, though it usually suffices to use `ℚ` or `ℝ`.
-/
def partial_odd_gf (m : ℕ) [field α] := ∏ i in range m, (1 - (X : power_series α)^(2*i+1))⁻¹

/--
The partial product for the generating function for distinct partitions.
TODO: As `m` tends to infinity, this converges (in the `X`-adic topology).

If `m` is sufficiently large, the `i`th coefficient gives the number of distinct partitions of the
natural number `i`: proved in `distinct_gf_prop`.
It is stated for an arbitrary commutative semiring `α`, though it usually suffices to use `ℕ`, `ℚ`
or `ℝ`.
-/
def partial_distinct_gf (m : ℕ) [comm_semiring α] :=
∏ i in range m, (1 + (X : power_series α)^(i+1))

/--
Functions defined only on `s`, which sum to `n`. In other words, a partition of `n` indexed by `s`.
Every function in here is finitely supported, and the support is a subset of `s`.
This should be thought of as a generalisation of `finset.nat.antidiagonal`, where
`antidiagonal n` is the same thing as `cut s n` if `s` has two elements.
-/
def cut {ι : Type*} (s : finset ι) (n : ℕ) : finset (ι → ℕ) :=
finset.filter (λ f, s.sum f = n) ((s.pi (λ _, range (n+1))).map
  ⟨λ f i, if h : i ∈ s then f i h else 0,
   λ f g h, by { ext i hi, simpa [dif_pos hi] using congr_fun h i }⟩)

lemma mem_cut {ι : Type*} (s : finset ι) (n : ℕ) (f : ι → ℕ) :
  f ∈ cut s n ↔ s.sum f = n ∧ ∀ i ∉ s, f i = 0 :=
begin
  rw [cut, mem_filter, and_comm, and_congr_right],
  intro h,
  simp only [mem_map, exists_prop, function.embedding.coe_fn_mk, mem_pi],
  split,
  { rintro ⟨_, _, rfl⟩ _ _,
    simp [dif_neg H] },
  { intro hf,
    refine ⟨λ i hi, f i, λ i hi, _, _⟩,
    { rw [mem_range, nat.lt_succ_iff, ← h],
      apply single_le_sum _ hi,
      simp },
    { ext,
      rw [dite_eq_ite, ite_eq_left_iff, eq_comm],
      exact hf x } }
end

lemma cut_equiv_antidiag (n : ℕ) :
  equiv.finset_congr (equiv.bool_arrow_equiv_prod _) (cut univ n) = nat.antidiagonal n :=
begin
  ext ⟨x₁, x₂⟩,
  simp_rw [equiv.finset_congr_apply, mem_map, equiv.to_embedding, function.embedding.coe_fn_mk,
           ←equiv.eq_symm_apply],
  simp [mem_cut, add_comm],
end

/-- There is only one `cut` of 0. -/
@[simp]
lemma cut_zero {ι : Type*} (s : finset ι) :
  cut s 0 = {0} :=
begin
  -- In general it's nice to prove things using `mem_cut` but in this case it's easier to just
  -- use the definition.
  rw [cut, range_one, pi_const_singleton, map_singleton, function.embedding.coe_fn_mk,
      filter_singleton, if_pos, singleton_inj],
  { ext, split_ifs; refl },
  rw sum_eq_zero_iff,
  intros x hx,
  apply dif_pos hx,
end

@[simp]
lemma cut_empty_succ {ι : Type*} (n : ℕ) :
  cut (∅ : finset ι) (n+1) = ∅ :=
begin
  apply eq_empty_of_forall_not_mem,
  intros x hx,
  rw [mem_cut, sum_empty] at hx,
  cases hx.1,
end

lemma cut_insert {ι : Type*} (n : ℕ) (a : ι) (s : finset ι) (h : a ∉ s) :
  cut (insert a s) n =
  (nat.antidiagonal n).bUnion
    (λ (p : ℕ × ℕ), (cut s p.snd).map
      ⟨λ f, f + λ t, if t = a then p.fst else 0, add_left_injective _⟩) :=
begin
  ext f,
  rw [mem_cut, mem_bUnion, sum_insert h],
  split,
  { rintro ⟨rfl, h₁⟩,
    simp only [exists_prop, function.embedding.coe_fn_mk, mem_map,
               nat.mem_antidiagonal, prod.exists],
    refine ⟨f a, s.sum f, rfl, λ i, if i = a then 0 else f i, _, _⟩,
    { rw [mem_cut],
      refine ⟨_, _⟩,
      { rw [sum_ite],
        have : (filter (λ x, x ≠ a) s) = s,
        { apply filter_true_of_mem,
          rintro i hi rfl,
          apply h hi },
        simp [this] },
      { intros i hi,
        rw ite_eq_left_iff,
        intro hne,
        apply h₁,
        simp [not_or_distrib, hne, hi] } },
    { ext,
      obtain rfl|h := eq_or_ne x a,
      { simp },
      { simp [if_neg h] } } },
  { simp only [mem_insert, function.embedding.coe_fn_mk, mem_map, nat.mem_antidiagonal, prod.exists,
               exists_prop, mem_cut, not_or_distrib],
    rintro ⟨p, q, rfl, g, ⟨rfl, hg₂⟩, rfl⟩,
    refine ⟨_, _⟩,
    { simp [sum_add_distrib, if_neg h, hg₂ _ h, add_comm] },
    { rintro i ⟨h₁, h₂⟩,
      simp [if_neg h₁, hg₂ _ h₂] } }
end

lemma coeff_prod_range
  [comm_semiring α] {ι : Type*} (s : finset ι) (f : ι → power_series α) (n : ℕ) :
  coeff α n (∏ j in s, f j) = ∑ l in cut s n, ∏ i in s, coeff α (l i) (f i) :=
begin
  revert n,
  apply finset.induction_on s,
  { rintro ⟨_ | n⟩,
    { simp },
    simp [cut_empty_succ, if_neg (nat.succ_ne_zero _)] },
  intros a s hi ih n,
  rw [cut_insert _ _ _ hi, prod_insert hi, coeff_mul, sum_bUnion],
  { apply sum_congr rfl _,
    simp only [prod.forall, sum_map, pi.add_apply,
               function.embedding.coe_fn_mk, nat.mem_antidiagonal],
    rintro i j rfl,
    simp only [prod_insert hi, if_pos rfl, ih, mul_sum],
    apply sum_congr rfl _,
    intros x hx,
    rw mem_cut at hx,
    rw [hx.2 a hi, zero_add],
    congr' 1,
    apply prod_congr rfl,
    intros k hk,
    rw [if_neg, add_zero],
    exact ne_of_mem_of_not_mem hk hi },
  { simp only [set.pairwise_disjoint, set.pairwise, prod.forall, not_and, ne.def,
      nat.mem_antidiagonal, disjoint_left, mem_map, exists_prop, function.embedding.coe_fn_mk,
      exists_imp_distrib, not_exists, finset.mem_coe],
    rintro p₁ q₁ rfl p₂ q₂ h t x hx,
    simp only [finset.inf_eq_inter, finset.mem_map, finset.mem_inter, mem_cut, exists_prop,
      function.embedding.coe_fn_mk] at hx,
    rcases hx with ⟨⟨p, ⟨hp, hp2⟩, hp3⟩, ⟨q, ⟨hq, hq2⟩, hq3⟩⟩,
    have z := hp3.trans hq3.symm,
    have := sum_congr (eq.refl s) (λ x _, function.funext_iff.1 z x),
    obtain rfl : q₁ = q₂,
    { simpa [sum_add_distrib, hp, hq, if_neg hi] using this },
    obtain rfl : p₂ = p₁,
    { simpa using h },
    exact (t rfl).elim }
end

/-- A convenience constructor for the power series whose coefficients indicate a subset. -/
def indicator_series (α : Type*) [semiring α] (s : set ℕ) : power_series α :=
power_series.mk (λ n, if n ∈ s then 1 else 0)

lemma coeff_indicator (s : set ℕ) [semiring α] (n : ℕ) :
  coeff α n (indicator_series _ s) = if n ∈ s then 1 else 0 :=
coeff_mk _ _
lemma coeff_indicator_pos (s : set ℕ) [semiring α] (n : ℕ) (h : n ∈ s):
  coeff α n (indicator_series _ s) = 1 :=
by rw [coeff_indicator, if_pos h]
lemma coeff_indicator_neg (s : set ℕ) [semiring α] (n : ℕ) (h : n ∉ s):
  coeff α n (indicator_series _ s) = 0 :=
by rw [coeff_indicator, if_neg h]
lemma constant_coeff_indicator (s : set ℕ) [semiring α] :
  constant_coeff α (indicator_series _ s) = if 0 ∈ s then 1 else 0 :=
rfl

lemma two_series (i : ℕ) [semiring α] :
  (1 + (X : power_series α)^i.succ) = indicator_series α {0, i.succ} :=
begin
  ext,
  simp only [coeff_indicator, coeff_one, coeff_X_pow, set.mem_insert_iff, set.mem_singleton_iff,
    map_add],
  cases n with d,
  { simp [(nat.succ_ne_zero i).symm] },
  { simp [nat.succ_ne_zero d], },
end

lemma num_series' [field α] (i : ℕ) :
  (1 - (X : power_series α)^(i+1))⁻¹ = indicator_series α { k | i + 1 ∣ k } :=
begin
  rw power_series.inv_eq_iff_mul_eq_one,
  { ext,
    cases n,
    { simp [mul_sub, zero_pow, constant_coeff_indicator] },
    { simp only [coeff_one, if_neg n.succ_ne_zero, mul_sub, mul_one,
                 coeff_indicator, linear_map.map_sub],
      simp_rw [coeff_mul, coeff_X_pow, coeff_indicator, boole_mul, sum_ite, filter_filter,
               sum_const_zero, add_zero, sum_const, nsmul_eq_mul, mul_one, sub_eq_iff_eq_add,
               zero_add, filter_congr_decidable],
      symmetry,
      split_ifs,
      { suffices :
        ((nat.antidiagonal n.succ).filter (λ (a : ℕ × ℕ), i + 1 ∣ a.fst ∧ a.snd = i + 1)).card = 1,
        { simp only [set.mem_set_of_eq], rw this, norm_cast },
        rw card_eq_one,
        cases h with p hp,
        refine ⟨((i+1) * (p-1), i+1), _⟩,
        ext ⟨a₁, a₂⟩,
        simp only [mem_filter, prod.mk.inj_iff, nat.mem_antidiagonal, mem_singleton],
        split,
        { rintro ⟨a_left, ⟨a, rfl⟩, rfl⟩,
          refine ⟨_, rfl⟩,
          rw [nat.mul_sub_left_distrib, ← hp, ← a_left, mul_one, nat.add_sub_cancel] },
        { rintro ⟨rfl, rfl⟩,
          cases p,
          { rw mul_zero at hp, cases hp },
          rw hp,
          simp [nat.succ_eq_add_one, mul_add] } },
      { suffices :
        (filter (λ (a : ℕ × ℕ), i + 1 ∣ a.fst ∧ a.snd = i + 1) (nat.antidiagonal n.succ)).card = 0,
        { simp only [set.mem_set_of_eq], rw this, norm_cast },
        rw card_eq_zero,
        apply eq_empty_of_forall_not_mem,
        simp only [prod.forall, mem_filter, not_and, nat.mem_antidiagonal],
        rintro _ h₁ h₂ ⟨a, rfl⟩ rfl,
        apply h,
        simp [← h₂] } } },
  { simp [zero_pow] },
end

def mk_odd : ℕ ↪ ℕ := ⟨λ i, 2 * i + 1, λ x y h, by linarith⟩

-- The main workhorse of the partition theorem proof.
lemma partial_gf_prop
  (α : Type*) [comm_semiring α] (n : ℕ) (s : finset ℕ)
  (hs : ∀ i ∈ s, 0 < i) (c : ℕ → set ℕ) (hc : ∀ i ∉ s, 0 ∈ c i) :
  (finset.card
    ((univ : finset (nat.partition n)).filter
      (λ p, (∀ j, p.parts.count j ∈ c j) ∧ ∀ j ∈ p.parts, j ∈ s)) : α) =
        (coeff α n) (∏ (i : ℕ) in s, indicator_series α ((* i) '' c i)) :=
begin
  simp_rw [coeff_prod_range, coeff_indicator, prod_boole, sum_boole],
  congr' 1,
  refine finset.card_congr (λ p _ i, multiset.count i p.parts • i) _ _ _,
  { simp only [mem_filter, mem_cut, mem_univ, true_and, exists_prop, and_assoc, and_imp,
               smul_eq_zero, function.embedding.coe_fn_mk, exists_imp_distrib],
    rintro ⟨p, hp₁, hp₂⟩ hp₃ hp₄,
    dsimp only at *,
    refine ⟨_, _, _⟩,
    { rw [←hp₂, ←sum_multiset_count_of_subset p s (λ x hx, hp₄ _ (multiset.mem_to_finset.mp hx))] },
    { intros i hi,
      left,
      exact multiset.count_eq_zero_of_not_mem (mt (hp₄ i) hi) },
    { exact λ i hi, ⟨_, hp₃ i, rfl⟩ } },
  { intros p₁ p₂ hp₁ hp₂ h,
    apply nat.partition.ext,
    simp only [true_and, mem_univ, mem_filter] at hp₁ hp₂,
    ext i,
    rw function.funext_iff at h,
    specialize h i,
    cases i,
    { rw multiset.count_eq_zero_of_not_mem,
      rw multiset.count_eq_zero_of_not_mem,
      intro a, exact nat.lt_irrefl 0 (hs 0 (hp₂.2 0 a)),
      intro a, exact nat.lt_irrefl 0 (hs 0 (hp₁.2 0 a)) },
    { rwa [nat.nsmul_eq_mul, nat.nsmul_eq_mul, nat.mul_left_inj i.succ_pos] at h } },
  { simp only [mem_filter, mem_cut, mem_univ, exists_prop, true_and, and_assoc],
    rintros f ⟨hf₁, hf₂, hf₃⟩,
    refine ⟨⟨∑ i in s, multiset.repeat i (f i / i), _, _⟩, _, _, _⟩,
    { intros i hi,
      simp only [exists_prop, mem_sum, mem_map, function.embedding.coe_fn_mk] at hi,
      rcases hi with ⟨t, ht, z⟩,
      apply hs,
      rwa multiset.eq_of_mem_repeat z },
    { simp_rw [multiset.sum_sum, multiset.sum_repeat, nat.nsmul_eq_mul, ←hf₁],
      refine sum_congr rfl (λ i hi, nat.div_mul_cancel _),
      rcases hf₃ i hi with ⟨w, hw, hw₂⟩,
      rw ← hw₂,
      exact dvd_mul_left _ _ },
    { intro i,
      simp_rw [multiset.count_sum', multiset.count_repeat, sum_ite_eq],
      split_ifs with h h,
      { rcases hf₃ i h with ⟨w, hw₁, hw₂⟩,
        rwa [← hw₂, nat.mul_div_cancel _ (hs i h)] },
      { exact hc _ h } },
    { intros i hi,
      rw mem_sum at hi,
      rcases hi with ⟨j, hj₁, hj₂⟩,
      rwa multiset.eq_of_mem_repeat hj₂ },
    { ext i,
      simp_rw [multiset.count_sum', multiset.count_repeat, sum_ite_eq],
      split_ifs,
      { apply nat.div_mul_cancel,
        rcases hf₃ i h with ⟨w, hw, hw₂⟩,
        apply dvd.intro_left _ hw₂ },
      { rw [zero_smul, hf₂ i h] } } },
end

lemma partial_odd_gf_prop [field α] (n m : ℕ) :
  (finset.card ((univ : finset (nat.partition n)).filter
    (λ p, ∀ j ∈ p.parts, j ∈ (range m).map mk_odd)) : α) = coeff α n (partial_odd_gf m) :=
begin
  rw partial_odd_gf,
  convert partial_gf_prop α n ((range m).map mk_odd) _ (λ _, set.univ) (λ _ _, trivial) using 2,
  { congr' 2,
    simp only [true_and, forall_const, set.mem_univ] },
  { rw finset.prod_map,
    simp_rw num_series',
    apply prod_congr rfl,
    intros,
    congr' 1,
    ext k,
    split,
    { rintro ⟨p, rfl⟩,
      refine ⟨p, ⟨⟩, _⟩,
      apply mul_comm },
    rintro ⟨a_w, -, rfl⟩,
    apply dvd.intro_left a_w rfl },
  { intro i,
    rw mem_map,
    rintro ⟨a, -, rfl⟩,
    exact nat.succ_pos _ },
end

/--  If m is big enough, the partial product's coefficient counts the number of odd partitions -/
theorem odd_gf_prop [field α] (n m : ℕ) (h : n < m * 2) :
  (finset.card (nat.partition.odds n) : α) = coeff α n (partial_odd_gf m) :=
begin
  rw [← partial_odd_gf_prop],
  congr' 2,
  apply filter_congr,
  intros p hp,
  apply ball_congr,
  intros i hi,
  have hin : i ≤ n,
  { simpa [p.parts_sum] using multiset.single_le_sum (λ _ _, nat.zero_le _) _ hi },
  simp only [mk_odd, exists_prop, mem_range, function.embedding.coe_fn_mk, mem_map],
  split,
  { intro hi₂,
    have := nat.mod_add_div i 2,
    rw nat.not_even_iff at hi₂,
    rw [hi₂, add_comm] at this,
    refine ⟨i / 2, _, this⟩,
    rw nat.div_lt_iff_lt_mul _ _ zero_lt_two,
    exact lt_of_le_of_lt hin h },
  { rintro ⟨a, -, rfl⟩,
    rw even_iff_two_dvd,
    apply nat.two_not_dvd_two_mul_add_one },
end

lemma partial_distinct_gf_prop [comm_semiring α] (n m : ℕ) :
  (finset.card
    ((univ : finset (nat.partition n)).filter
      (λ p, p.parts.nodup ∧ ∀ j ∈ p.parts, j ∈ (range m).map ⟨nat.succ, nat.succ_injective⟩)) : α) =
  coeff α n (partial_distinct_gf m) :=
begin
  rw partial_distinct_gf,
  convert partial_gf_prop α n
    ((range m).map ⟨nat.succ, nat.succ_injective⟩) _ (λ _, {0, 1}) (λ _ _, or.inl rfl) using 2,
  { congr' 2,
    ext p,
    congr' 2,
    apply propext,
    rw multiset.nodup_iff_count_le_one,
    apply forall_congr,
    intro i,
    rw [set.mem_insert_iff, set.mem_singleton_iff],
    split,
    { intro hi,
      interval_cases (multiset.count i p.parts),
      { left, assumption },
      { right, assumption } },
    { rintro (h | h),
      { rw h, norm_num },
      { rw h } } },
  { rw finset.prod_map,
    apply prod_congr rfl,
    intros,
    rw two_series,
    congr' 1,
    simp [set.image_pair] },
  { simp only [mem_map, function.embedding.coe_fn_mk],
    rintro i ⟨_, _, rfl⟩,
    apply nat.succ_pos }
end

/--
If m is big enough, the partial product's coefficient counts the number of distinct partitions
-/
theorem distinct_gf_prop [comm_semiring α] (n m : ℕ) (h : n < m + 1) :
  ((nat.partition.distincts n).card : α) = coeff α n (partial_distinct_gf m) :=
begin
  erw [← partial_distinct_gf_prop],
  congr' 2,
  apply filter_congr,
  intros p hp,
  apply (and_iff_left _).symm,
  intros i hi,
  have : i ≤ n,
  { simpa [p.parts_sum] using multiset.single_le_sum (λ _ _, nat.zero_le _) _ hi },
  simp only [mk_odd, exists_prop, mem_range, function.embedding.coe_fn_mk, mem_map],
  refine ⟨i-1, _, nat.succ_pred_eq_of_pos (p.parts_pos hi)⟩,
  rw tsub_lt_iff_right (nat.one_le_iff_ne_zero.mpr (p.parts_pos hi).ne'),
  exact lt_of_le_of_lt this h,
end

/--
The key proof idea for the partition theorem, showing that the generating functions for both
sequences are ultimately the same (since the factor converges to 0 as m tends to infinity).
It's enough to not take the limit though, and just consider large enough `m`.
-/
lemma same_gf [field α] (m : ℕ) :
  partial_odd_gf m * (range m).prod (λ i, (1 - (X : power_series α)^(m+i+1))) =
  partial_distinct_gf m :=
begin
  rw [partial_odd_gf, partial_distinct_gf],
  induction m with m ih,
  { simp },

  rw nat.succ_eq_add_one,

  set π₀ : power_series α := ∏ i in range m, (1 - X ^ (m + 1 + i + 1)) with hπ₀,
  set π₁ : power_series α := ∏ i in range m, (1 - X ^ (2 * i + 1))⁻¹ with hπ₁,
  set π₂ : power_series α := ∏ i in range m, (1 - X ^ (m + i + 1)) with hπ₂,
  set π₃ : power_series α := ∏ i in range m, (1 + X ^ (i + 1)) with hπ₃,
  rw ←hπ₃ at ih,

  have h : constant_coeff α (1 - X ^ (2 * m + 1)) ≠ 0,
  { rw [ring_hom.map_sub, ring_hom.map_pow, constant_coeff_one, constant_coeff_X,
      zero_pow (2 * m).succ_pos, sub_zero],
    exact one_ne_zero },

  calc (∏ i in range (m + 1), (1 - X ^ (2 * i + 1))⁻¹) *
          ∏ i in range (m + 1), (1 - X ^ (m + 1 + i + 1))
      = π₁ * (1 - X ^ (2 * m + 1))⁻¹ * (π₀ * (1 - X ^ (m + 1 + m + 1))) :
          by rw [prod_range_succ _ m, ←hπ₁, prod_range_succ _ m, ←hπ₀]
  ... = π₁ * (1 - X ^ (2 * m + 1))⁻¹ * (π₀ * ((1 + X ^ (m + 1)) * (1 - X ^ (m + 1)))) :
          by rw [←sq_sub_sq, one_pow, add_assoc _ m 1, ←two_mul (m + 1), pow_mul']
  ... = π₀ * (1 - X ^ (m + 1)) * (1 - X ^ (2 * m + 1))⁻¹ * (π₁ * (1 + X ^ (m + 1))) :
          by ring
  ... = (∏ i in range (m + 1), (1 - X ^ (m + 1 + i))) * (1 - X ^ (2 * m + 1))⁻¹ *
          (π₁ * (1 + X ^ (m + 1))) :
          by { rw [prod_range_succ', add_zero, hπ₀], simp_rw ←add_assoc }
  ... = π₂ * (1 - X ^ (m + 1 + m)) * (1 - X ^ (2 * m + 1))⁻¹ * (π₁ * (1 + X ^ (m + 1))) :
          by { rw [add_right_comm, hπ₂, ←prod_range_succ], simp_rw [add_right_comm] }
  ... = π₂ * (1 - X ^ (2 * m + 1)) * (1 - X ^ (2 * m + 1))⁻¹ * (π₁ * (1 + X ^ (m + 1))) :
          by rw [two_mul, add_right_comm _ m 1]
  ... = (1 - X ^ (2 * m + 1)) * (1 - X ^ (2 * m + 1))⁻¹ * π₂ * (π₁ * (1 + X ^ (m + 1))) :
          by ring
  ... = π₂ * (π₁ * (1 + X ^ (m + 1))) : by rw [power_series.mul_inv_cancel _ h, one_mul]
  ... = π₁ * π₂ * (1 + X ^ (m + 1)) : by ring
  ... = π₃ * (1 + X ^ (m + 1)) : by rw ih
  ... = _ : by rw prod_range_succ,
end

lemma same_coeffs [field α] (m n : ℕ) (h : n ≤ m) :
  coeff α n (partial_odd_gf m) = coeff α n (partial_distinct_gf m) :=
begin
  rw [← same_gf, coeff_mul_prod_one_sub_of_lt_order],
  rintros i -,
  rw order_X_pow,
  exact_mod_cast nat.lt_succ_of_le (le_add_right h),
end

theorem partition_theorem (n : ℕ) :
  (nat.partition.odds n).card = (nat.partition.distincts n).card :=
begin
  -- We need the counts to live in some field (which contains ℕ), so let's just use ℚ
  suffices : ((nat.partition.odds n).card : ℚ) = (nat.partition.distincts n).card,
  { exact_mod_cast this },
  rw distinct_gf_prop n (n+1) (by linarith),
  rw odd_gf_prop n (n+1) (by linarith),
  apply same_coeffs (n+1) n n.le_succ,
end


import data.set.basic
import data.set.lattice

/-
Первые несколько строк файла на Lean импортируют нужные файлы. Если вы скачали репозиторий с помощью `leanproject`, то у вас автоматически в _target/deps/mathlib установлена библиотека mathlib:
GitHub: https://github.com/leanprover-community/mathlib
Документация: https://leanprover-community.github.io/mathlib_docs/

В VSCode с помощью Ctrl + Click по названию можно удобно перейти к импортированному файлу или определению леммы/функции.

Lean поддерживает Unicode и много команд из LaTeX! Наведите курсор на символ, чтобы увидеть команду, с помощью которой его можно набрать.

Часто используемые символы:
→ = \r, \to         ← = \l              ↔ = \iff, \lr
∀ = \all, \forall   ∃ = \ex, \exists    ∈ = \in, \mem
¬ = \not, \neg      ⟨ = \<,             ⟩ = \>
≠ = \neq,           ≤ = \le             ≥ = \ge
⊆ = \ss, \sub       ⊂ = \ssub           Sᶜ = \compl, \^c
∧ = \and, \wedge    ∨ = \or, \vee       ⊢ = \goal, \|-
∩ = \cap, \inter    ∪ = \cup, \union
 -/

--

-- `variables (X : Type) (x : X)` позволяет в текущем контексте объявить переменные, чтобы не писать их каждый раз в сигнатурах: если вы используете `x` в определении леммы/теоремы, он автоматически добавится аргументом
-- В фигурных скобках (`{X : Type}`) записываются неявные аргументы, про них чуть позже
variables {X : Type} (A B C : set X) (p q : X)

-- По определению, `set X` это функции из `X` в `Prop` (`X → Prop`). Если сделать Ctrl + Click по `set`, то вы перейдете к определению `set`, а там написано a ∈ X ↔ X a
-- `a ∈ X` (\in или \mem) это по определению `X a`
example : p ∈ A = A p :=
begin
  refl,
end

-- Вне tactic mode для обозначения равенства по определению используется `rfl`
example : p ∈ A = A p := rfl

-- Есть два специальных множества: `∅` (\empty) - пустое и `univ` - универсальное
-- По определению, `p ∈ ∅ = false`, `p ∈ univ = true`
lemma mem_empty : p ∈ (∅ : set X) ↔ false :=
begin
  refl,
end

lemma mem_univ : p ∈ (set.univ : set X) ↔ true :=
begin
  refl,
end

-- `lemma` и `theorem` обычно используют для утверждений (Prop), `def` для новых определений (типов или функций)
-- Ко всему, что определено внутри namespace test, нужно обращаться с префиксом test
-- Команда #check дает проверить тип выражения (использовать внутри begin-end блока нельзя)
-- Обратите внимание на вставленные `∀ (X : Type) (A : set X) (p : X)`, которые пришли из `variables`
-- `(B C : set X)` здесь нет, потому что `B` и `C` не используются
namespace test
lemma obviously_false : p ∈ A ↔ ¬ p ∈ A := sorry
end test

#check test.obviously_false

-- `A ⊆ B` по определению то же самое, что `∀ ⦃x⦄, x ∈ A → x ∈ B`
-- На выражение `∀ ⦃x⦄, x ∈ A → x ∈ B` следует смотреть, как на функцию, которая принимает `x` и доказательство того, что `x ∈ A`, а возвращает доказательство, что `x ∈ B` (`x` - необязательный аргумент, и можно сразу подавать `x ∈ A`)
lemma subset_def : A ⊆ B = ∀ x : X, x ∈ A → x ∈ B := rfl

lemma subset_refl : A ⊆ A :=
begin
  -- попробуйте начать сразу с `intro x`, `rw subset_def` делать не обязательно (но пока вы не знакомы с определениями, можно их раскрывать явно)
  sorry,
end

lemma subset_trans : A ⊆ B → B ⊆ C → A ⊆ C :=
begin
  sorry,
end

-- Два множества равны, если в них содержатся одинаковые элементы
-- "ext" означает extensionality, "объекты равны, если они внешне ведут себя одинаково"
-- Чтобы доказать равенство каких-то объектов (множеств, функций, ...), используйте тактику `ext`
lemma set_eq_def : A = B ↔ ∀ x, x ∈ A ↔ x ∈ B := set.ext_iff
-- A ↔ B это просто пара ⟨A → B, B → A⟩ (обратите внимание, здесь угловые скобки \< \>)

lemma subset_antisymm : A ⊆ B → B ⊆ A → A = B :=
begin
  sorry,
end

-- term mode, конструируем доказательство не тактиками, а напрямую
example : A ⊆ B → B ⊆ A → A = B := λ hAB hBA, set.ext_iff.2 (λ x, ⟨λ xA, hAB xA, λ xB, hBA xB⟩)

-- Аргументы бывают явные и неявные
-- В сигнатуре функции до `:` можно написать именованные аргументы
-- `lemma f (h : α) : β` по сути то же самое, что `lemma f : α → β`
-- Некоторые аргументы можно делать неявными, если их можно вывести из последующих аргументов
-- Иногда можно опустить тип аргументов (и явных, и неявных)

lemma implicit_args {X} {A B : set X} {x : X} : x ∈ A → x ∈ B := sorry
#check implicit_args
#check @implicit_args

lemma subset_trans' (X : Type) (A B C : set X) : A ⊆ B → B ⊆ C → A ⊆ C := sorry
lemma subset_trans'' {X : Type} {A B C : set X} : A ⊆ B → B ⊆ C → A ⊆ C := sorry

#check subset_trans
#check subset_trans'
#check subset_trans''
-- "@" перед названием функции делает все неявные аргументы явными
#check @subset_trans''

-- Пересечение и объединение

lemma union_def : (p ∈ A ∪ B) = (p ∈ A ∨ p ∈ B) := rfl
lemma inter_def : (p ∈ A ∩ B) = (p ∈ A ∧ p ∈ B) := rfl

-- Тактика `rcases` позволяет разбирать структуры на части за одно применение
-- Если `h : α ∧ β ∧ γ`, то `rcases h with ⟨ha, hb, hc⟩` даст три нужные гипотезы
-- Если `h : α ∨ β`, то `rcases h with (ha | hb)` даст две цели с `ha : α` в первой и `hb : β` во второй
-- Если `h :
example : (p ∈ A ∨ p ∈ B) ∧ (p ∈ C) → p ∈ (A ∪ B) ∩ C :=
begin
  intro h,
  rcases h with ⟨(hA | hB), hC⟩,
  -- Цель: `⊢ p ∈ (A ∪ B) ∩ C`, можно с помощью `exact` и `or.inl hA` сразу сконструировать ответ
  exact ⟨or.inl hA, hC⟩,
  -- Аналогично с `or.inr hB`
  exact ⟨or.inr hB, hC⟩,
end

-- На самом деле это верно по определению
example : (p ∈ A ∨ p ∈ B) ∧ (p ∈ C) → p ∈ (A ∪ B) ∩ C := id

-- Тактика `rintro` = `intros` + `rcases`: применяет `intros` и сразу `rcases` ко всем новым переменным
-- Когда цель выглядит как `α ∧ β → γ`, вместо того, чтобы делать `intro h`, `cases h with ha hb`, можно использовать `rintro ⟨hA, hB⟩` и сразу получить `hA : α`, `hB : β` в контексте
example : p ∈ A ∨ (p ∈ B ∧ p ∈ C) → p ∈ A ∪ (B ∩ C) :=
begin
  rintro (pA | ⟨pB, pC⟩),
  -- две цели, соответствующие двум конструкторам `or`
  left, exact pA,
  right, exact ⟨pB, pC⟩,
end

lemma inter_assoc (A B C : set X) : (A ∩ B) ∩ C = A ∩ (B ∩ C) :=
begin
  sorry,
end

lemma union_assoc (A B C : set X) : (A ∪ B) ∪ C = A ∪ (B ∪ C) :=
begin
  sorry,
end

-- Тактика `all_goals {...}` применяет блок ко всем целям
example (A B C : set X) : (A ∪ B) ∪ C = A ∪ (B ∪ C) :=
begin
  ext x, split,
  all_goals {repeat {rw set.mem_union}, tauto},
end

lemma union_eq_of_subset (hAB : A ⊆ B) : A ∪ B = B :=
begin
  sorry,
end

lemma inter_eq_iff_subset : A ⊆ B ↔ A ∩ B = A :=
begin
  sorry,
end

-- `Aᶜ` (A\^c) это дополнение `A`, то есть, `p ∈ Aᶜ = p ∉ A = ¬p ∈ A`
#check @set.mem_compl
example : p ∉ A  = ¬p ∈ A := rfl
example : p ∈ Aᶜ = (p ∉ A) := rfl

lemma compl_subset_compl_of_subset (hAB : A ⊆ B) : Bᶜ ⊆ Aᶜ :=
begin
  sorry,
end

-- Закон де Моргана
-- Полезные тактики: `simp at h ⊢` упростит локальную гипотезу и цель (можно также написать `simp at *`, что будет упрощать все локальные гипотезы и цель)
-- `tauto` решает цели в логике высказываний, `tauto!` работает в классической логике и может использовать закон исключенного третьего
lemma compl_inter_eq_compl_union_compl : (A ∩ B)ᶜ = Aᶜ ∪ Bᶜ :=
begin
  sorry,
end

-- Для объединения/пересечений нескольких множеств есть следующие операторы:
-- Леммы про них лежат в `data.set.lattice`
-- 1. Если `f : ι → set S`, то `⋃ (i : ι), f i` равно объединению `f i`, где `i` пробегает все элементы типа `ι`
-- `x` принадлежит `⋃ (i : ι), f i` ↔ `∃ i, x ∈ f i`
-- Леммы про такое объединение содержат `Union` в названии

lemma Union_def {S ι} {F : ι → set S} : set.Union F = ⋃ i, F i :=
begin
  refl,
end

lemma mem_Union {S ι} {x : S} {F : ι → set S} : (x ∈ ⋃ i, F i) ↔ (∃ i, x ∈ F i) :=
begin
  exact set.mem_Union,
end

-- 2. `bUnion` (от bounded union) берет объединение только по `i`, лежащим в множестве `I : set ι`
-- Обратите внимание на нотацию `∃ i ∈ I`, это сокращение от `∃ i (H : i ∈ I)`, то есть, "существует `i` и доказательство `i ∈ I`"
lemma mem_bUnion {S ι} {x : S} {F : ι → set S} {I : set ι} : (x ∈ ⋃ i ∈ I, F i) ↔ (∃ i ∈ I, x ∈ F i) :=
begin
  exact set.mem_bUnion_iff,
end

-- 3. Если у нас есть (s : set (set S)), то `⋃₀ s : set S` объединяет все множества, лежащие в `s`
-- Леммы про такое объединение содержат `sUnion` в названии
lemma mem_sUnion {S} {x : S} {s : set (set S)} : (x ∈ ⋃₀ s) ↔ (∃ t ∈ s, x ∈ t) :=
begin
  exact set.mem_sUnion,
end

-- Пересечение всех множеств, содержащих `S` как подмножество, равно `S`
def supersets {X : Type} (S : set X) : set (set X) := {T | S ⊆ T}

lemma supersets_sInter {S : set X} : ⋂₀ (supersets S) = S :=
begin
  sorry,
end


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

Type class for encodable Types.
Note that every encodable Type is countable.
-/
import data.equiv.nat
open option list nat function

/-- An encodable type is a "constructively countable" type. This is where
  we have an explicit injection `encode : α → nat` and a partial inverse
  `decode : nat → option α`. This makes the range of `encode` decidable,
  although it is not decidable if `α` is finite or not. -/
class encodable (α : Type*) :=
(encode : α → nat) (decode : nat → option α) (encodek : ∀ a, decode (encode a) = some a)

namespace encodable
variables {α : Type*} {β : Type*}
universe u
open encodable

theorem encode_injective [encodable α] : function.injective (@encode α _)
| x y e := option.some.inj $ by rw [← encodek, e, encodek]

/- This is not set as an instance because this is usually not the best way
  to infer decidability. -/
def decidable_eq_of_encodable (α) [encodable α] : decidable_eq α
| a b := decidable_of_iff _ encode_injective.eq_iff

def of_left_injection [encodable α]
  (f : β → α) (finv : α → option β) (linv : ∀ b, finv (f b) = some b) : encodable β :=
⟨λ b, encode (f b),
 λ n, (decode α n).bind finv,
 λ b, by simp [encodable.encodek, linv]⟩

def of_left_inverse [encodable α]
  (f : β → α) (finv : α → β) (linv : ∀ b, finv (f b) = b) : encodable β :=
of_left_injection f (some ∘ finv) (λ b, congr_arg some (linv b))

def of_equiv (α) [encodable α] (e : β ≃ α) : encodable β :=
of_left_inverse e e.symm e.left_inv

@[simp] theorem encode_of_equiv {α β} [encodable α] (e : β ≃ α) (b : β) :
  @encode _ (of_equiv _ e) b = encode (e b) := rfl

@[simp] theorem decode_of_equiv {α β} [encodable α] (e : β ≃ α) (n : ℕ) :
  @decode _ (of_equiv _ e) n = (decode α n).map e.symm := rfl

instance nat : encodable nat :=
⟨id, some, λ a, rfl⟩

@[simp] theorem encode_nat (n : ℕ) : encode n = n := rfl
@[simp] theorem decode_nat (n : ℕ) : decode ℕ n = some n := rfl

instance empty : encodable empty :=
⟨λ a, a.rec _, λ n, none, λ a, a.rec _⟩

instance unit : encodable punit :=
⟨λ_, zero, λn, nat.cases_on n (some punit.star) (λ _, none), λ⟨⟩, by simp⟩

@[simp] theorem encode_star : encode punit.star = 0 := rfl

@[simp] theorem decode_unit_zero : decode punit 0 = some punit.star := rfl
@[simp] theorem decode_unit_succ (n) : decode punit (succ n) = none := rfl

instance option {α : Type*} [h : encodable α] : encodable (option α) :=
⟨λ o, option.cases_on o nat.zero (λ a, succ (encode a)),
 λ n, nat.cases_on n (some none) (λ m, (decode α m).map some),
 λ o, by cases o; dsimp; simp [encodek, nat.succ_ne_zero]⟩

@[simp] theorem encode_none [encodable α] : encode (@none α) = 0 := rfl
@[simp] theorem encode_some [encodable α] (a : α) :
  encode (some a) = succ (encode a) := rfl

@[simp] theorem decode_option_zero [encodable α] : decode (option α) 0 = some none := rfl
@[simp] theorem decode_option_succ [encodable α] (n) :
  decode (option α) (succ n) = (decode α n).map some := rfl

def decode2 (α) [encodable α] (n : ℕ) : option α :=
(decode α n).bind (option.guard (λ a, encode a = n))

theorem mem_decode2' [encodable α] {n : ℕ} {a : α} :
  a ∈ decode2 α n ↔ a ∈ decode α n ∧ encode a = n :=
by simp [decode2]; exact
⟨λ ⟨_, h₁, rfl, h₂⟩, ⟨h₁, h₂⟩, λ ⟨h₁, h₂⟩, ⟨_, h₁, rfl, h₂⟩⟩

theorem mem_decode2 [encodable α] {n : ℕ} {a : α} :
  a ∈ decode2 α n ↔ encode a = n :=
mem_decode2'.trans (and_iff_right_of_imp $ λ e, e ▸ encodek _)

theorem decode2_is_partial_inv [encodable α] : is_partial_inv encode (decode2 α) :=
λ a n, mem_decode2

theorem decode2_inj [encodable α] {n : ℕ} {a₁ a₂ : α}
  (h₁ : a₁ ∈ decode2 α n) (h₂ : a₂ ∈ decode2 α n) : a₁ = a₂ :=
encode_injective $ (mem_decode2.1 h₁).trans (mem_decode2.1 h₂).symm

theorem encodek2 [encodable α] (a : α) : decode2 α (encode a) = some a :=
mem_decode2.2 rfl

section sum
variables [encodable α] [encodable β]

def encode_sum : α ⊕ β → nat
| (sum.inl a) := bit0 $ encode a
| (sum.inr b) := bit1 $ encode b

def decode_sum (n : nat) : option (α ⊕ β) :=
match bodd_div2 n with
| (ff, m) := (decode α m).map sum.inl
| (tt, m) := (decode β m).map sum.inr
end

instance sum : encodable (α ⊕ β) :=
⟨encode_sum, decode_sum, λ s,
  by cases s; simp [encode_sum, decode_sum, encodek]; refl⟩

@[simp] theorem encode_inl (a : α) :
  @encode (α ⊕ β) _ (sum.inl a) = bit0 (encode a) := rfl
@[simp] theorem encode_inr (b : β) :
  @encode (α ⊕ β) _ (sum.inr b) = bit1 (encode b) := rfl
@[simp] theorem decode_sum_val (n : ℕ) :
  decode (α ⊕ β) n = decode_sum n := rfl

end sum

instance bool : encodable bool :=
of_equiv (unit ⊕ unit) equiv.bool_equiv_punit_sum_punit

@[simp] theorem encode_tt : encode tt = 1 := rfl
@[simp] theorem encode_ff : encode ff = 0 := rfl

@[simp] theorem decode_zero : decode bool 0 = some ff := rfl
@[simp] theorem decode_one : decode bool 1 = some tt := rfl

theorem decode_ge_two (n) (h : 2 ≤ n) : decode bool n = none :=
begin
  suffices : decode_sum n = none,
  { change (decode_sum n).map _ = none, rw this, refl },
  have : 1 ≤ div2 n,
  { rw [div2_val, nat.le_div_iff_mul_le],
    exacts [h, dec_trivial] },
  cases exists_eq_succ_of_ne_zero (ne_of_gt this) with m e,
  simp [decode_sum]; cases bodd n; simp [decode_sum]; rw e; refl
end

section sigma
variables {γ : α → Type*} [encodable α] [∀ a, encodable (γ a)]

def encode_sigma : sigma γ → ℕ
| ⟨a, b⟩ := mkpair (encode a) (encode b)

def decode_sigma (n : ℕ) : option (sigma γ) :=
let (n₁, n₂) := unpair n in
(decode α n₁).bind $ λ a, (decode (γ a) n₂).map $ sigma.mk a

instance sigma : encodable (sigma γ) :=
⟨encode_sigma, decode_sigma, λ ⟨a, b⟩,
  by simp [encode_sigma, decode_sigma, unpair_mkpair, encodek]⟩

@[simp] theorem decode_sigma_val (n : ℕ) : decode (sigma γ) n =
  (decode α n.unpair.1).bind (λ a, (decode (γ a) n.unpair.2).map $ sigma.mk a) :=
show decode_sigma._match_1 _ = _, by cases n.unpair; refl

@[simp] theorem encode_sigma_val (a b) : @encode (sigma γ) _ ⟨a, b⟩ =
  mkpair (encode a) (encode b) := rfl

end sigma

section prod
variables [encodable α] [encodable β]

instance prod : encodable (α × β) :=
of_equiv _ (equiv.sigma_equiv_prod α β).symm

@[simp] theorem decode_prod_val (n : ℕ) : decode (α × β) n =
  (decode α n.unpair.1).bind (λ a, (decode β n.unpair.2).map $ prod.mk a) :=
show (decode (sigma (λ _, β)) n).map (equiv.sigma_equiv_prod α β) = _,
by simp; cases decode α n.unpair.1; simp;
   cases decode β n.unpair.2; refl

@[simp] theorem encode_prod_val (a b) : @encode (α × β) _ (a, b) =
  mkpair (encode a) (encode b) := rfl

end prod

section subtype
open subtype decidable
variable {P : α → Prop}
variable [encA : encodable α]
variable [decP : decidable_pred P]

include encA
def encode_subtype : {a : α // P a} → nat
| ⟨v, h⟩ := encode v

include decP
def decode_subtype (v : nat) : option {a : α // P a} :=
(decode α v).bind $ λ a,
if h : P a then some ⟨a, h⟩ else none

instance subtype : encodable {a : α // P a} :=
⟨encode_subtype, decode_subtype,
 λ ⟨v, h⟩, by simp [encode_subtype, decode_subtype, encodek, h]⟩
end subtype

instance fin (n) : encodable (fin n) :=
of_equiv _ (equiv.fin_equiv_subtype _)

instance int : encodable ℤ :=
of_equiv _ equiv.int_equiv_nat

instance ulift [encodable α] : encodable (ulift α) :=
of_equiv _ equiv.ulift

instance plift [encodable α] : encodable (plift α) :=
of_equiv _ equiv.plift

noncomputable def of_inj [encodable β] (f : α → β) (hf : injective f) : encodable α :=
of_left_injection f (partial_inv f) (λ x, (partial_inv_of_injective hf _ _).2 rfl)

end encodable

/-
Choice function for encodable types and decidable predicates.
We provide the following API

choose      {α : Type*} {p : α → Prop} [c : encodable α] [d : decidable_pred p] : (∃ x, p x) → α :=
choose_spec {α : Type*} {p : α → Prop} [c : encodable α] [d : decidable_pred p] (ex : ∃ x, p x) : p (choose ex) :=
-/

namespace encodable
section find_a
variables {α : Type*} (p : α → Prop) [encodable α] [decidable_pred p]

private def good : option α → Prop
| (some a) := p a
| none     := false

private def decidable_good : decidable_pred (good p)
| n := by cases n; unfold good; apply_instance
local attribute [instance] decidable_good

open encodable
variable {p}

def choose_x (h : ∃ x, p x) : {a:α // p a} :=
have ∃ n, good p (decode α n), from
let ⟨w, pw⟩ := h in ⟨encode w, by simp [good, encodek, pw]⟩,
match _, nat.find_spec this : ∀ o, good p o → {a // p a} with
| some a, h := ⟨a, h⟩
end

def choose (h : ∃ x, p x) : α := (choose_x h).1

lemma choose_spec (h : ∃ x, p x) : p (choose h) := (choose_x h).2

end find_a

theorem axiom_of_choice {α : Type*} {β : α → Type*} {R : Π x, β x → Prop}
  [Π a, encodable (β a)] [∀ x y, decidable (R x y)]
  (H : ∀x, ∃y, R x y) : ∃f:Πa, β a, ∀x, R x (f x) :=
⟨λ x, choose (H x), λ x, choose_spec (H x)⟩

theorem skolem {α : Type*} {β : α → Type*} {P : Π x, β x → Prop}
  [c : Π a, encodable (β a)] [d : ∀ x y, decidable (P x y)] :
  (∀x, ∃y, P x y) ↔ ∃f : Π a, β a, (∀x, P x (f x)) :=
⟨axiom_of_choice, λ ⟨f, H⟩ x, ⟨_, H x⟩⟩

end encodable

namespace quot
open encodable
variables {α : Type*} {s : setoid α} [@decidable_rel α (≈)] [encodable α]

-- Choose equivalence class representative
def rep (q : quotient s) : α :=
choose (exists_rep q)

theorem rep_spec (q : quotient s) : ⟦rep q⟧ = q :=
choose_spec (exists_rep q)

def encodable_quotient : encodable (quotient s) :=
⟨λ q, encode (rep q),
 λ n, quotient.mk <$> decode α n,
 by rintros ⟨l⟩; rw encodek; exact congr_arg some (rep_spec _)⟩

end quot


/-
Copyright (c) 2020 Kyle Miller. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kyle Miller
-/
import data.zmod.basic
import data.equiv.mul_add
import tactic.group

/-!
# Racks and Quandles

This file defines racks and quandles, algebraic structures for sets
that bijectively act on themselves with a self-distributivity
property.  If `R` is a rack and `act : R → (R ≃ R)` is the self-action,
then the self-distributivity is, equivalently, that
```
act (act x y) = act x * act y * (act x)⁻¹
```
where multiplication is composition in `R ≃ R` as a group.
Quandles are racks such that `act x x = x` for all `x`.

One example of a quandle (not yet in mathlib) is the action of a Lie
algebra on itself, defined by `act x y = Ad (exp x) y`.

Quandles and racks were independently developed by multiple
mathematicians.  David Joyce introduced quandles in his thesis
[Joyce1982] to define an algebraic invariant of knot and link
complements that is analogous to the fundamental group of the
exterior, and he showed that the quandle associated to an oriented
knot is invariant up to orientation-reversed mirror image.  Racks were
used by Fenn and Rourke for framed codimension-2 knots and
links.[FennRourke1992]

The name "rack" came from wordplay by Conway and Wraith for the "wrack
and ruin" of forgetting everything but the conjugation operation for a
group.

## Main definitions

* `shelf` is a type with a self-distributive action
* `rack` is a shelf whose action for each element is invertible
* `quandle` is a rack whose action for an element fixes that element
* `quandle.conj` defines a quandle of a group acting on itself by conjugation.
* `shelf_hom` is homomorphisms of shelves, racks, and quandles.
* `rack.envel_group` gives the universal group the rack maps to as a conjugation quandle.
* `rack.opp` gives the rack with the action replaced by its inverse.

## Main statements
* `rack.envel_group` is left adjoint to `quandle.conj` (`to_envel_group.map`).
  The universality statements are `to_envel_group.univ` and `to_envel_group.univ_uniq`.

## Notation

The following notation is localized in `quandles`:

* `x ◃ y` is `shelf.act x y`
* `x ◃⁻¹ y` is `rack.inv_act x y`
* `S →◃ S'` is `shelf_hom S S'`

Use `open_locale quandles` to use these.

## Todo

* If `g` is the Lie algebra of a Lie group `G`, then `(x ◃ y) = Ad (exp x) x` forms a quandle.
* If `X` is a symmetric space, then each point has a corresponding involution that acts on `X`,
  forming a quandle.
* Alexander quandle with `a ◃ b = t * b + (1 - t) * b`, with `a` and `b` elements
  of a module over `Z[t,t⁻¹]`.
* If `G` is a group, `H` a subgroup, and `z` in `H`, then there is a quandle `(G/H;z)` defined by
  `yH ◃ xH = yzy⁻¹xH`.  Every homogeneous quandle (i.e., a quandle `Q` whose automorphism group acts
  transitively on `Q` as a set) is isomorphic to such a quandle.
  There is a generalization to this arbitrary quandles in [Joyce's paper (Theorem 7.2)][Joyce1982].

## Tags

rack, quandle
-/
open opposite

universes u v

/--
A *shelf* is a structure with a self-distributive binary operation.
The binary operation is regarded as a left action of the type on itself.
-/
class shelf (α : Type u) :=
(act : α → α → α)
(self_distrib : ∀ {x y z : α}, act x (act y z) = act (act x y) (act x z))

/--
The type of homomorphisms between shelves.
This is also the notion of rack and quandle homomorphisms.
-/
@[ext]
structure shelf_hom (S₁ : Type*) (S₂ : Type*) [shelf S₁] [shelf S₂] :=
(to_fun : S₁ → S₂)
(map_act' : ∀ {x y : S₁}, to_fun (shelf.act x y) = shelf.act (to_fun x) (to_fun y))

/--
A *rack* is an automorphic set (a set with an action on itself by
bijections) that is self-distributive.  It is a shelf such that each
element's action is invertible.

The notations `x ◃ y` and `x ◃⁻¹ y` denote the action and the
inverse action, respectively, and they are right associative.
-/
class rack (α : Type u) extends shelf α :=
(inv_act : α → α → α)
(left_inv : ∀ x, function.left_inverse (inv_act x) (act x))
(right_inv : ∀ x, function.right_inverse (inv_act x) (act x))

localized "infixr ` ◃ `:65 := shelf.act" in quandles
localized "infixr ` ◃⁻¹ `:65 := rack.inv_act" in quandles
localized "infixr ` →◃ `:25 := shelf_hom" in quandles

open_locale quandles

namespace rack
variables {R : Type*} [rack R]

lemma self_distrib {x y z : R} : x ◃ (y ◃ z) = (x ◃ y) ◃ (x ◃ z) :=
shelf.self_distrib

/--
A rack acts on itself by equivalences.
-/
def act (x : R) : R ≃ R :=
{ to_fun := shelf.act x,
  inv_fun := inv_act x,
  left_inv := left_inv x,
  right_inv := right_inv x }

@[simp] lemma act_apply (x y : R) : act x y = x ◃ y := rfl
@[simp] lemma act_symm_apply (x y : R) : (act x).symm y = x ◃⁻¹ y := rfl
@[simp] lemma inv_act_apply (x y : R) : (act x)⁻¹ y = x ◃⁻¹ y := rfl

@[simp] lemma inv_act_act_eq (x y : R) : x ◃⁻¹ x ◃ y = y := left_inv x y
@[simp] lemma act_inv_act_eq (x y : R) : x ◃ x ◃⁻¹ y = y := right_inv x y

lemma left_cancel (x : R) {y y' : R} : x ◃ y = x ◃ y' ↔ y = y' :=
by { split, apply (act x).injective, rintro rfl, refl }

lemma left_cancel_inv (x : R) {y y' : R} : x ◃⁻¹ y = x ◃⁻¹ y' ↔ y = y' :=
by { split, apply (act x).symm.injective, rintro rfl, refl }

lemma self_distrib_inv {x y z : R} : x ◃⁻¹ y ◃⁻¹ z = (x ◃⁻¹ y) ◃⁻¹ (x ◃⁻¹ z) :=
begin
  rw [←left_cancel (x ◃⁻¹ y), right_inv, ←left_cancel x, right_inv, self_distrib],
  repeat {rw right_inv },
end

/--
The *adjoint action* of a rack on itself is `op'`, and the adjoint
action of `x ◃ y` is the conjugate of the action of `y` by the action
of `x`. It is another way to understand the self-distributivity axiom.

This is used in the natural rack homomorphism `to_conj` from `R` to
`conj (R ≃ R)` defined by `op'`.
-/
lemma ad_conj {R : Type*} [rack R] (x y : R) :
  act (x ◃ y) = act x * act y * (act x)⁻¹ :=
begin
  apply @mul_right_cancel _ _ _ (act x), ext z,
  simp only [inv_mul_cancel_right],
  apply self_distrib.symm,
end

/--
The opposite rack, swapping the roles of `◃` and `◃⁻¹`.
-/
instance opposite_rack : rack Rᵒᵖ :=
{ act := λ x y, op (inv_act (unop x) (unop y)),
  self_distrib := λ (x y z : Rᵒᵖ), begin
    op_induction x, op_induction y, op_induction z,
    simp only [unop_op, op_inj_iff],
    exact self_distrib_inv,
  end,
  inv_act := λ x y, op (shelf.act (unop x) (unop y)),
  left_inv := λ x y, begin
    op_induction x, op_induction y, simp,
  end,
  right_inv := λ x y, begin
    op_induction x, op_induction y, simp,
  end }

@[simp] lemma op_act_op_eq {x y : R} : (op x) ◃ (op y) = op (x ◃⁻¹ y) := rfl
@[simp] lemma op_inv_act_op_eq {x y : R} : (op x) ◃⁻¹ (op y) = op (x ◃ y) := rfl

@[simp]
lemma self_act_act_eq {x y : R} : (x ◃ x) ◃ y = x ◃ y :=
by { rw [←right_inv x y, ←self_distrib] }

@[simp]
lemma self_inv_act_inv_act_eq {x y : R} : (x ◃⁻¹ x) ◃⁻¹ y = x ◃⁻¹ y :=
by { have h := @self_act_act_eq _ _ (op x) (op y), simpa using h }

@[simp]
lemma self_act_inv_act_eq {x y : R} : (x ◃ x) ◃⁻¹ y = x ◃⁻¹ y :=
by { rw ←left_cancel (x ◃ x), rw right_inv, rw self_act_act_eq, rw right_inv }

@[simp]
lemma self_inv_act_act_eq {x y : R} : (x ◃⁻¹ x) ◃ y = x ◃ y :=
by { have h := @self_act_inv_act_eq _ _ (op x) (op y), simpa using h }

lemma self_act_eq_iff_eq {x y : R} : x ◃ x = y ◃ y ↔ x = y :=
begin
  split, swap, rintro rfl, refl,
  intro h,
  transitivity (x ◃ x) ◃⁻¹ (x ◃ x),
  rw [←left_cancel (x ◃ x), right_inv, self_act_act_eq],
  rw [h, ←left_cancel (y ◃ y), right_inv, self_act_act_eq],
end

lemma self_inv_act_eq_iff_eq {x y : R} : x ◃⁻¹ x = y ◃⁻¹ y ↔ x = y :=
by { have h := @self_act_eq_iff_eq _ _ (op x) (op y), simpa using h }

/--
The map `x ↦ x ◃ x` is a bijection.  (This has applications for the
regular isotopy version of the Reidemeister I move for knot diagrams.)
-/
def self_apply_equiv (R : Type*) [rack R] : R ≃ R :=
{ to_fun := λ x, x ◃ x,
  inv_fun := λ x, x ◃⁻¹ x,
  left_inv := λ x, by simp,
  right_inv := λ x, by simp }

/--
An involutory rack is one for which `rack.op R x` is an involution for every x.
-/
def is_involutory (R : Type*) [rack R] : Prop := ∀ x : R, function.involutive (shelf.act x)

lemma involutory_inv_act_eq_act {R : Type*} [rack R] (h : is_involutory R) (x y : R) :
  x ◃⁻¹ y = x ◃ y :=
begin
  rw [←left_cancel x, right_inv],
  exact ((h x).left_inverse y).symm,
end

/--
An abelian rack is one for which the mediality axiom holds.
-/
def is_abelian (R : Type*) [rack R] : Prop :=
∀ (x y z w : R), (x ◃ y) ◃ (z ◃ w) = (x ◃ z) ◃ (y ◃ w)

/--
Associative racks are uninteresting.
-/
lemma assoc_iff_id {R : Type*} [rack R] {x y z : R} :
  x ◃ y ◃ z = (x ◃ y) ◃ z ↔ x ◃ z = z :=
by { rw self_distrib, rw left_cancel }

end rack

namespace shelf_hom
variables {S₁ : Type*} {S₂ : Type*} {S₃ : Type*} [shelf S₁] [shelf S₂] [shelf S₃]

instance : has_coe_to_fun (S₁ →◃ S₂) :=
⟨_, shelf_hom.to_fun⟩

@[simp] lemma to_fun_eq_coe (f : S₁ →◃ S₂) : f.to_fun = f := rfl

@[simp] lemma map_act (f : S₁ →◃ S₂) {x y : S₁} : f (x ◃ y) = f x ◃ f y := map_act' f

/-- The identity homomorphism -/
def id (S : Type*) [shelf S] : S →◃ S :=
{ to_fun := id,
  map_act' := by simp }

instance inhabited (S : Type*) [shelf S] : inhabited (S →◃ S) :=
⟨id S⟩

/-- The composition of shelf homomorphisms -/
def comp (g : S₂ →◃ S₃) (f : S₁ →◃ S₂) : S₁ →◃ S₃ :=
{ to_fun := g.to_fun ∘ f.to_fun,
  map_act' := by simp }

@[simp]
lemma comp_apply (g : S₂ →◃ S₃) (f : S₁ →◃ S₂) (x : S₁) :
  (g.comp f) x = g (f x) := rfl

end shelf_hom

/--
A quandle is a rack such that each automorphism fixes its corresponding element.
-/
class quandle (α : Type*) extends rack α :=
(fix : ∀ {x : α}, act x x = x)

namespace quandle
open rack
variables {Q : Type*} [quandle Q]

attribute [simp] fix

@[simp]
lemma fix_inv {x : Q} : x ◃⁻¹ x = x :=
by { rw ←left_cancel x, simp }

instance opposite_quandle : quandle Qᵒᵖ :=
{ fix := λ x, by { op_induction x, simp } }

/--
The conjugation quandle of a group.  Each element of the group acts by
the corresponding inner automorphism.
-/
@[nolint has_inhabited_instance]
def conj (G : Type*) := G

instance conj.quandle (G : Type*) [group G] : quandle (conj G) :=
{ act := (λ x, @mul_aut.conj G _ x),
  self_distrib := λ x y z, begin
    dsimp only [mul_equiv.coe_to_equiv, mul_aut.conj_apply, conj],
    group,
  end,
  inv_act := (λ x, (@mul_aut.conj G _ x).symm),
  left_inv := λ x y, by { dsimp [act, conj], group },
  right_inv := λ x y, by { dsimp [act, conj], group },
  fix := λ x, by simp }

@[simp]
lemma conj_act_eq_conj {G : Type*} [group G] (x y : conj G) :
  x ◃ y = ((x : G) * (y : G) * (x : G)⁻¹ : G) := rfl

lemma conj_swap {G : Type*} [group G] (x y : conj G) :
  x ◃ y = y ↔ y ◃ x = x :=
begin
  dsimp, split,
  repeat { intro h, conv_rhs { rw eq_mul_inv_of_mul_eq (eq_mul_inv_of_mul_eq h) }, simp, },
end

/--
`conj` is functorial
-/
def conj.map {G : Type*} {H : Type*} [group G] [group H] (f : G →* H) : conj G →◃ conj H :=
{ to_fun := f,
  map_act' := by simp }

instance {G : Type*} {H : Type*} [group G] [group H] : has_lift (G →* H) (conj G →◃ conj H) :=
{ lift := conj.map }

/--
The dihedral quandle. This is the conjugation quandle of the dihedral group restrict to flips.

Used for Fox n-colorings of knots.
-/
@[nolint has_inhabited_instance]
def dihedral (n : ℕ) := zmod n

/--
The operation for the dihedral quandle.  It does not need to be an equivalence
because it is an involution (see `dihedral_act.inv`).
-/
def dihedral_act (n : ℕ) (a : zmod n) : zmod n → zmod n :=
λ b, 2 * a - b

lemma dihedral_act.inv (n : ℕ) (a : zmod n) : function.involutive (dihedral_act n a) :=
by { intro b, dsimp [dihedral_act], ring }

instance (n : ℕ) : quandle (dihedral n) :=
{ act := dihedral_act n,
  self_distrib := λ x y z, begin
    dsimp [function.involutive.to_equiv, dihedral_act], ring,
  end,
  inv_act := dihedral_act n,
  left_inv := λ x, (dihedral_act.inv n x).left_inverse,
  right_inv := λ x, (dihedral_act.inv n x).right_inverse,
  fix := λ x, begin
    dsimp [function.involutive.to_equiv, dihedral_act], ring,
  end }

end quandle

namespace rack

/--
This is the natural rack homomorphism to the conjugation quandle of the group `R ≃ R`
that acts on the rack.
-/
def to_conj (R : Type*) [rack R] : R →◃ quandle.conj (R ≃ R) :=
{ to_fun := act,
  map_act' := ad_conj }

section envel_group

/-!
### Universal enveloping group of a rack

The universal enveloping group `envel_group R` of a rack `R` is the
universal group such that every rack homomorphism `R →◃ conj G` is
induced by a unique group homomorphism `envel_group R →* G`.
For quandles, Joyce called this group `AdConj R`.

The `envel_group` functor is left adjoint to the `conj` forgetful
functor, and the way we construct the enveloping group is via a
technique that should work for left adjoints of forgetful functors in
general.  It involves thinking a little about 2-categories, but the
payoff is that the map `envel_group R →* G` has a nice description.

Let's think of a group as being a one-object category.  The first step
is to define `pre_envel_group`, which gives formal expressions for all
the 1-morphisms and includes the unit element, elements of `R`,
multiplication, and inverses.  To introduce relations, the second step
is to define `pre_envel_group_rel'`, which gives formal expressions
for all 2-morphisms between the 1-morphisms.  The 2-morphisms include
associativity, multiplication by the unit, multiplication by inverses,
compatibility with multiplication and inverses (`congr_mul` and
`congr_inv`), the axioms for an equivalence relation, and,
importantly, the relationship between conjugation and the rack action
(see `rack.ad_conj`).

None of this forms a 2-category yet, for example due to lack of
associativity of `trans`.  The `pre_envel_group_rel` relation is a
`Prop`-valued version of `pre_envel_group_rel'`, and making it
`Prop`-valued essentially introduces enough 3-isomorphisms so that
every pair of compatible 2-morphisms is isomorphic.  Now, while
composition in `pre_envel_group` does not strictly satisfy the category
axioms, `pre_envel_group` and `pre_envel_group_rel'` do form a weak
2-category.

Since we just want a 1-category, the last step is to quotient
`pre_envel_group` by `pre_envel_group_rel'`, and the result is the
group `envel_group`.

For a homomorphism `f : R →◃ conj G`, how does
`envel_group.map f : envel_group R →* G` work?  Let's think of `G` as
being a 2-category with one object, a 1-morphism per element of `G`,
and a single 2-morphism called `eq.refl` for each 1-morphism.  We
define the map using a "higher `quotient.lift`" -- not only do we
evaluate elements of `pre_envel_group` as expressions in `G` (this is
`to_envel_group.map_aux`), but we evaluate elements of
`pre_envel_group'` as expressions of 2-morphisms of `G` (this is
`to_envel_group.map_aux.well_def`).  That is to say,
`to_envel_group.map_aux.well_def` recursively evaluates formal
expressions of 2-morphisms as equality proofs in `G`.  Now that all
morphisms are accounted for, the map descends to a homomorphism
`envel_group R →* G`.

Note: `Type`-valued relations are not common.  The fact it is
`Type`-valued is what makes `to_envel_group.map_aux.well_def` have
well-founded recursion.
-/

/--
Free generators of the enveloping group.
-/
inductive pre_envel_group (R : Type u) : Type u
| unit : pre_envel_group
| incl (x : R) : pre_envel_group
| mul (a b : pre_envel_group) : pre_envel_group
| inv (a : pre_envel_group) : pre_envel_group

instance pre_envel_group.inhabited (R : Type u) : inhabited (pre_envel_group R) :=
⟨pre_envel_group.unit⟩

open pre_envel_group

/--
Relations for the enveloping group. This is a type-valued relation because
`to_envel_group.map_aux.well_def` inducts on it to show `to_envel_group.map`
is well-defined.  The relation `pre_envel_group_rel` is the `Prop`-valued version,
which is used to define `envel_group` itself.
-/
inductive pre_envel_group_rel' (R : Type u) [rack R] :
  pre_envel_group R → pre_envel_group R → Type u
| refl {a : pre_envel_group R} : pre_envel_group_rel' a a
| symm {a b : pre_envel_group R} (hab : pre_envel_group_rel' a b) : pre_envel_group_rel' b a
| trans {a b c : pre_envel_group R}
  (hab : pre_envel_group_rel' a b) (hbc : pre_envel_group_rel' b c) : pre_envel_group_rel' a c
| congr_mul {a b a' b' : pre_envel_group R}
  (ha : pre_envel_group_rel' a a') (hb : pre_envel_group_rel' b b') :
  pre_envel_group_rel' (mul a b) (mul a' b')
| congr_inv {a a' : pre_envel_group R} (ha : pre_envel_group_rel' a a') :
  pre_envel_group_rel' (inv a) (inv a')
| assoc (a b c : pre_envel_group R) : pre_envel_group_rel' (mul (mul a b) c) (mul a (mul b c))
| one_mul (a : pre_envel_group R) : pre_envel_group_rel' (mul unit a) a
| mul_one (a : pre_envel_group R) : pre_envel_group_rel' (mul a unit) a
| mul_left_inv (a : pre_envel_group R) : pre_envel_group_rel' (mul (inv a) a) unit
| act_incl (x y : R) :
  pre_envel_group_rel' (mul (mul (incl x) (incl y)) (inv (incl x))) (incl (x ◃ y))

instance pre_envel_group_rel'.inhabited (R : Type u) [rack R] :
  inhabited (pre_envel_group_rel' R unit unit) :=
⟨pre_envel_group_rel'.refl⟩

/--
The `pre_envel_group_rel` relation as a `Prop`.  Used as the relation for `pre_envel_group.setoid`.
-/
inductive pre_envel_group_rel (R : Type u) [rack R] : pre_envel_group R → pre_envel_group R → Prop
| rel {a b : pre_envel_group R} (r : pre_envel_group_rel' R a b) : pre_envel_group_rel a b

/--
A quick way to convert a `pre_envel_group_rel'` to a `pre_envel_group_rel`.
-/
lemma pre_envel_group_rel'.rel {R : Type u} [rack R] {a b : pre_envel_group R} :
  pre_envel_group_rel' R a b → pre_envel_group_rel R a b :=
pre_envel_group_rel.rel

@[refl]
lemma pre_envel_group_rel.refl {R : Type u} [rack R] {a : pre_envel_group R} :
  pre_envel_group_rel R a a :=
pre_envel_group_rel.rel pre_envel_group_rel'.refl

@[symm]
lemma pre_envel_group_rel.symm {R : Type u} [rack R] {a b : pre_envel_group R} :
  pre_envel_group_rel R a b → pre_envel_group_rel R b a
| ⟨r⟩ := r.symm.rel

@[trans]
lemma pre_envel_group_rel.trans {R : Type u} [rack R] {a b c : pre_envel_group R} :
  pre_envel_group_rel R a b → pre_envel_group_rel R b c → pre_envel_group_rel R a c
| ⟨rab⟩ ⟨rbc⟩ := (rab.trans rbc).rel

instance pre_envel_group.setoid (R : Type*) [rack R] : setoid (pre_envel_group R) :=
{ r := pre_envel_group_rel R,
  iseqv := begin
    split, apply pre_envel_group_rel.refl,
    split, apply pre_envel_group_rel.symm,
    apply pre_envel_group_rel.trans
  end }

/--
The universal enveloping group for the rack R.
-/
def envel_group (R : Type*) [rack R] := quotient (pre_envel_group.setoid R)

-- Define the `group` instances in two steps so `inv` can be inferred correctly.
-- TODO: is there a non-invasive way of defining the instance directly?
instance (R : Type*) [rack R] : div_inv_monoid (envel_group R) :=
{ mul := λ a b, quotient.lift_on₂ a b
                  (λ a b, ⟦pre_envel_group.mul a b⟧)
                  (λ a b a' b' ⟨ha⟩ ⟨hb⟩,
                    quotient.sound (pre_envel_group_rel'.congr_mul ha hb).rel),
  one := ⟦unit⟧,
  inv := λ a, quotient.lift_on a
                (λ a, ⟦pre_envel_group.inv a⟧)
                (λ a a' ⟨ha⟩,
                  quotient.sound (pre_envel_group_rel'.congr_inv ha).rel),
  mul_assoc := λ a b c,
    quotient.induction_on₃ a b c (λ a b c, quotient.sound (pre_envel_group_rel'.assoc a b c).rel),
  one_mul := λ a,
    quotient.induction_on a (λ a, quotient.sound (pre_envel_group_rel'.one_mul a).rel),
  mul_one := λ a,
    quotient.induction_on a (λ a, quotient.sound (pre_envel_group_rel'.mul_one a).rel),}

instance (R : Type*) [rack R] : group (envel_group R) :=
{ mul_left_inv := λ a,
    quotient.induction_on a (λ a, quotient.sound (pre_envel_group_rel'.mul_left_inv a).rel),
  .. envel_group.div_inv_monoid _ }

instance envel_group.inhabited (R : Type*) [rack R] : inhabited (envel_group R) := ⟨1⟩

/--
The canonical homomorphism from a rack to its enveloping group.
Satisfies universal properties given by `to_envel_group.map` and `to_envel_group.univ`.
-/
def to_envel_group (R : Type*) [rack R] : R →◃ quandle.conj (envel_group R) :=
{ to_fun := λ x, ⟦incl x⟧,
  map_act' := λ x y, quotient.sound (pre_envel_group_rel'.act_incl x y).symm.rel }

/--
The preliminary definition of the induced map from the enveloping group.
See `to_envel_group.map`.
-/
def to_envel_group.map_aux {R : Type*} [rack R] {G : Type*} [group G]
  (f : R →◃ quandle.conj G) : pre_envel_group R → G
| unit := 1
| (incl x) := f x
| (mul a b) := to_envel_group.map_aux a * to_envel_group.map_aux b
| (inv a) := (to_envel_group.map_aux a)⁻¹

namespace to_envel_group.map_aux
open pre_envel_group_rel'

/--
Show that `to_envel_group.map_aux` sends equivalent expressions to equal terms.
-/
lemma well_def {R : Type*} [rack R] {G : Type*} [group G] (f : R →◃ quandle.conj G) :
  Π {a b : pre_envel_group R}, pre_envel_group_rel' R a b →
  to_envel_group.map_aux f a = to_envel_group.map_aux f b
| a b refl := rfl
| a b (symm h) := (well_def h).symm
| a b (trans hac hcb) := eq.trans (well_def hac) (well_def hcb)
| _ _ (congr_mul ha hb) := by { simp [to_envel_group.map_aux, well_def ha, well_def hb] }
| _ _ (congr_inv ha) := by { simp [to_envel_group.map_aux, well_def ha] }
| _ _ (assoc a b c) := by { apply mul_assoc }
| _ _ (one_mul a) := by { simp [to_envel_group.map_aux] }
| _ _ (mul_one a) := by { simp [to_envel_group.map_aux] }
| _ _ (mul_left_inv a) := by { simp [to_envel_group.map_aux] }
| _ _ (act_incl x y) := by { simp [to_envel_group.map_aux] }

end to_envel_group.map_aux

/--
Given a map from a rack to a group, lift it to being a map from the enveloping group.
More precisely, the `envel_group` functor is left adjoint to `quandle.conj`.
-/
def to_envel_group.map {R : Type*} [rack R] {G : Type*} [group G] :
  (R →◃ quandle.conj G) ≃ (envel_group R →* G) :=
{ to_fun := λ f,
  { to_fun := λ x, quotient.lift_on x (to_envel_group.map_aux f)
                    (λ a b ⟨hab⟩, to_envel_group.map_aux.well_def f hab),
    map_one' := begin
      change quotient.lift_on ⟦unit⟧ (to_envel_group.map_aux f) _ = 1,
      simp [to_envel_group.map_aux],
    end,
    map_mul' := λ x y, quotient.induction_on₂ x y (λ x y, begin
      change quotient.lift_on ⟦mul x y⟧ (to_envel_group.map_aux f) _ = _,
      simp [to_envel_group.map_aux],
    end) },
  inv_fun := λ F, (quandle.conj.map F).comp (to_envel_group R),
  left_inv := λ f, by { ext, refl },
  right_inv := λ F, monoid_hom.ext $ λ x, quotient.induction_on x $ λ x, begin
    induction x,
    { exact F.map_one.symm, },
    { refl, },
    { have hm : ⟦x_a.mul x_b⟧ = @has_mul.mul (envel_group R) _ ⟦x_a⟧ ⟦x_b⟧ := rfl,
      rw [hm, F.map_mul, monoid_hom.map_mul, ←x_ih_a, ←x_ih_b] },
    { have hm : ⟦x_a.inv⟧ = @has_inv.inv (envel_group R) _ ⟦x_a⟧ := rfl,
      rw [hm, F.map_inv, monoid_hom.map_inv, x_ih], }
  end, }

/--
Given a homomorphism from a rack to a group, it factors through the enveloping group.
-/
lemma to_envel_group.univ (R : Type*) [rack R] (G : Type*) [group G]
  (f : R →◃ quandle.conj G) :
  (quandle.conj.map (to_envel_group.map f)).comp (to_envel_group R) = f :=
to_envel_group.map.symm_apply_apply f

/--
The homomorphism `to_envel_group.map f` is the unique map that fits into the commutative
triangle in `to_envel_group.univ`.
-/
lemma to_envel_group.univ_uniq (R : Type*) [rack R] (G : Type*) [group G]
  (f : R →◃ quandle.conj G)
  (g : envel_group R →* G) (h : f = (quandle.conj.map g).comp (to_envel_group R)) :
  g = to_envel_group.map f :=
h.symm ▸ (to_envel_group.map.apply_symm_apply g).symm

/--
The induced group homomorphism from the enveloping group into bijections of the rack,
using `rack.to_conj`. Satisfies the property `envel_action_prop`.

This gives the rack `R` the structure of an augmented rack over `envel_group R`.
-/
def envel_action {R : Type*} [rack R] : envel_group R →* (R ≃ R) :=
to_envel_group.map (to_conj R)

@[simp]

end envel_group

end rack


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

import order.complete_boolean_algebra
import order.modular_lattice
import data.fintype.basic

/-!
# Atoms, Coatoms, and Simple Lattices

This module defines atoms, which are minimal non-`⊥` elements in bounded lattices, simple lattices,
which are lattices with only two elements, and related ideas.

## Main definitions

### Atoms and Coatoms
  * `is_atom a` indicates that the only element below `a` is `⊥`.
  * `is_coatom a` indicates that the only element above `a` is `⊤`.

### Atomic and Atomistic Lattices
  * `is_atomic` indicates that every element other than `⊥` is above an atom.
  * `is_coatomic` indicates that every element other than `⊤` is below a coatom.
  * `is_atomistic` indicates that every element is the `Sup` of a set of atoms.
  * `is_coatomistic` indicates that every element is the `Inf` of a set of coatoms.

### Simple Lattices
  * `is_simple_order` indicates that an order has only two unique elements, `⊥` and `⊤`.
  * `is_simple_order.bounded_order`
  * `is_simple_order.distrib_lattice`
  * Given an instance of `is_simple_order`, we provide the following definitions. These are not
    made global instances as they contain data :
    * `is_simple_order.boolean_algebra`
    * `is_simple_order.complete_lattice`
    * `is_simple_order.complete_boolean_algebra`

## Main results
  * `is_atom_dual_iff_is_coatom` and `is_coatom_dual_iff_is_atom` express the (definitional) duality
   of `is_atom` and `is_coatom`.
  * `is_simple_order_iff_is_atom_top` and `is_simple_order_iff_is_coatom_bot` express the
  connection between atoms, coatoms, and simple lattices
  * `is_compl.is_atom_iff_is_coatom` and `is_compl.is_coatom_if_is_atom`: In a modular
  bounded lattice, a complement of an atom is a coatom and vice versa.
  * ``is_atomic_iff_is_coatomic`: A modular complemented lattice is atomic iff it is coatomic.

-/

variable {α : Type*}

section atoms

section is_atom

variables [partial_order α] [order_bot α]

/-- An atom of an `order_bot` is an element with no other element between it and `⊥`,
  which is not `⊥`. -/
def is_atom (a : α) : Prop := a ≠ ⊥ ∧ (∀ b, b < a → b = ⊥)

lemma eq_bot_or_eq_of_le_atom {a b : α} (ha : is_atom a) (hab : b ≤ a) : b = ⊥ ∨ b = a :=
hab.lt_or_eq.imp_left (ha.2 b)

lemma is_atom.Iic {x a : α} (ha : is_atom a) (hax : a ≤ x) : is_atom (⟨a, hax⟩ : set.Iic x) :=
⟨λ con, ha.1 (subtype.mk_eq_mk.1 con), λ ⟨b, hb⟩ hba, subtype.mk_eq_mk.2 (ha.2 b hba)⟩

lemma is_atom.of_is_atom_coe_Iic {x : α} {a : set.Iic x} (ha : is_atom a) : is_atom (a : α) :=
⟨λ con, ha.1 (subtype.ext con), λ b hba, subtype.mk_eq_mk.1 (ha.2 ⟨b, hba.le.trans a.prop⟩ hba)⟩

end is_atom

section is_coatom

variables [partial_order α] [order_top α]

/-- A coatom of an `order_top` is an element with no other element between it and `⊤`,
  which is not `⊤`. -/
def is_coatom (a : α) : Prop := a ≠ ⊤ ∧ (∀ b, a < b → b = ⊤)

lemma eq_top_or_eq_of_coatom_le {a b : α} (ha : is_coatom a) (hab : a ≤ b) : b = ⊤ ∨ b = a :=
hab.lt_or_eq.imp (ha.2 b) eq_comm.2

lemma is_coatom.Ici {x a : α} (ha : is_coatom a) (hax : x ≤ a) : is_coatom (⟨a, hax⟩ : set.Ici x) :=
⟨λ con, ha.1 (subtype.mk_eq_mk.1 con), λ ⟨b, hb⟩ hba, subtype.mk_eq_mk.2 (ha.2 b hba)⟩

lemma is_coatom.of_is_coatom_coe_Ici {x : α} {a : set.Ici x} (ha : is_coatom a) :
  is_coatom (a : α) :=
⟨λ con, ha.1 (subtype.ext con), λ b hba, subtype.mk_eq_mk.1 (ha.2 ⟨b, le_trans a.prop hba.le⟩ hba)⟩

end is_coatom

section pairwise

lemma is_atom.inf_eq_bot_of_ne [semilattice_inf α] [order_bot α] {a b : α}
  (ha : is_atom a) (hb : is_atom b) (hab : a ≠ b) : a ⊓ b = ⊥ :=
or.elim (eq_bot_or_eq_of_le_atom ha inf_le_left) id
  (λ h1, or.elim (eq_bot_or_eq_of_le_atom hb inf_le_right) id
  (λ h2, false.rec _ (hab (le_antisymm (inf_eq_left.mp h1) (inf_eq_right.mp h2)))))

lemma is_atom.disjoint_of_ne [semilattice_inf α] [order_bot α] {a b : α}
  (ha : is_atom a) (hb : is_atom b) (hab : a ≠ b) : disjoint a b :=
disjoint_iff.mpr (is_atom.inf_eq_bot_of_ne ha hb hab)

lemma is_coatom.sup_eq_top_of_ne [semilattice_sup α] [order_top α] {a b : α}
  (ha : is_coatom a) (hb : is_coatom b) (hab : a ≠ b) : a ⊔ b = ⊤ :=
or.elim (eq_top_or_eq_of_coatom_le ha le_sup_left) id
  (λ h1, or.elim (eq_top_or_eq_of_coatom_le hb le_sup_right) id
  (λ h2, false.rec _ (hab (le_antisymm (sup_eq_right.mp h2) (sup_eq_left.mp h1)))))

end pairwise

variables [partial_order α] {a : α}

@[simp]
lemma is_coatom_dual_iff_is_atom [order_bot α] :
  is_coatom (order_dual.to_dual a) ↔ is_atom a :=
iff.rfl

@[simp]
lemma is_atom_dual_iff_is_coatom [order_top α] :
  is_atom (order_dual.to_dual a) ↔ is_coatom a :=
iff.rfl

end atoms

section atomic

variables [partial_order α] (α)

/-- A lattice is atomic iff every element other than `⊥` has an atom below it. -/
class is_atomic [order_bot α] : Prop :=
(eq_bot_or_exists_atom_le : ∀ (b : α), b = ⊥ ∨ ∃ (a : α), is_atom a ∧ a ≤ b)

/-- A lattice is coatomic iff every element other than `⊤` has a coatom above it. -/
class is_coatomic [order_top α] : Prop :=
(eq_top_or_exists_le_coatom : ∀ (b : α), b = ⊤ ∨ ∃ (a : α), is_coatom a ∧ b ≤ a)

export is_atomic (eq_bot_or_exists_atom_le) is_coatomic (eq_top_or_exists_le_coatom)

variable {α}

@[simp] theorem is_coatomic_dual_iff_is_atomic [order_bot α] :
  is_coatomic (order_dual α) ↔ is_atomic α :=
⟨λ h, ⟨λ b, by apply h.eq_top_or_exists_le_coatom⟩, λ h, ⟨λ b, by apply h.eq_bot_or_exists_atom_le⟩⟩

@[simp] theorem is_atomic_dual_iff_is_coatomic [order_top α] :
  is_atomic (order_dual α) ↔ is_coatomic α :=
⟨λ h, ⟨λ b, by apply h.eq_bot_or_exists_atom_le⟩, λ h, ⟨λ b, by apply h.eq_top_or_exists_le_coatom⟩⟩

namespace is_atomic

variables [order_bot α] [is_atomic α]

instance is_coatomic_dual : is_coatomic (order_dual α) :=
is_coatomic_dual_iff_is_atomic.2 ‹is_atomic α›

instance {x : α} : is_atomic (set.Iic x) :=
⟨λ ⟨y, hy⟩, (eq_bot_or_exists_atom_le y).imp subtype.mk_eq_mk.2
  (λ ⟨a, ha, hay⟩, ⟨⟨a, hay.trans hy⟩, ha.Iic (hay.trans hy), hay⟩)⟩

end is_atomic

namespace is_coatomic

variables [order_top α] [is_coatomic α]

instance is_coatomic : is_atomic (order_dual α) :=
is_atomic_dual_iff_is_coatomic.2 ‹is_coatomic α›

instance {x : α} : is_coatomic (set.Ici x) :=
⟨λ ⟨y, hy⟩, (eq_top_or_exists_le_coatom y).imp subtype.mk_eq_mk.2
  (λ ⟨a, ha, hay⟩, ⟨⟨a, le_trans hy hay⟩, ha.Ici (le_trans hy hay), hay⟩)⟩

end is_coatomic

theorem is_atomic_iff_forall_is_atomic_Iic [order_bot α] :
  is_atomic α ↔ ∀ (x : α), is_atomic (set.Iic x) :=
⟨@is_atomic.set.Iic.is_atomic _ _ _, λ h, ⟨λ x, ((@eq_bot_or_exists_atom_le _ _ _ (h x))
  (⊤ : set.Iic x)).imp subtype.mk_eq_mk.1 (exists_imp_exists' coe
  (λ ⟨a, ha⟩, and.imp_left (is_atom.of_is_atom_coe_Iic)))⟩⟩

theorem is_coatomic_iff_forall_is_coatomic_Ici [order_top α] :
  is_coatomic α ↔ ∀ (x : α), is_coatomic (set.Ici x) :=
is_atomic_dual_iff_is_coatomic.symm.trans $ is_atomic_iff_forall_is_atomic_Iic.trans $ forall_congr
  (λ x, is_coatomic_dual_iff_is_atomic.symm.trans iff.rfl)

end atomic

section atomistic

variables (α) [complete_lattice α]

/-- A lattice is atomistic iff every element is a `Sup` of a set of atoms. -/
class is_atomistic : Prop :=
(eq_Sup_atoms : ∀ (b : α), ∃ (s : set α), b = Sup s ∧ ∀ a, a ∈ s → is_atom a)

/-- A lattice is coatomistic iff every element is an `Inf` of a set of coatoms. -/
class is_coatomistic : Prop :=
(eq_Inf_coatoms : ∀ (b : α), ∃ (s : set α), b = Inf s ∧ ∀ a, a ∈ s → is_coatom a)

export is_atomistic (eq_Sup_atoms) is_coatomistic (eq_Inf_coatoms)

variable {α}

@[simp]
theorem is_coatomistic_dual_iff_is_atomistic : is_coatomistic (order_dual α) ↔ is_atomistic α :=
⟨λ h, ⟨λ b, by apply h.eq_Inf_coatoms⟩, λ h, ⟨λ b, by apply h.eq_Sup_atoms⟩⟩

@[simp]
theorem is_atomistic_dual_iff_is_coatomistic : is_atomistic (order_dual α) ↔ is_coatomistic α :=
⟨λ h, ⟨λ b, by apply h.eq_Sup_atoms⟩, λ h, ⟨λ b, by apply h.eq_Inf_coatoms⟩⟩

namespace is_atomistic

instance is_coatomistic_dual [h : is_atomistic α] : is_coatomistic (order_dual α) :=
is_coatomistic_dual_iff_is_atomistic.2 h

variable [is_atomistic α]

@[priority 100]
instance : is_atomic α :=
⟨λ b, by { rcases eq_Sup_atoms b with ⟨s, rfl, hs⟩,
  cases s.eq_empty_or_nonempty with h h,
  { simp [h] },
  { exact or.intro_right _ ⟨h.some, hs _ h.some_spec, le_Sup h.some_spec⟩ } } ⟩

end is_atomistic

section is_atomistic
variables [is_atomistic α]

@[simp]
theorem Sup_atoms_le_eq (b : α) : Sup {a : α | is_atom a ∧ a ≤ b} = b :=
begin
  rcases eq_Sup_atoms b with ⟨s, rfl, hs⟩,
  exact le_antisymm (Sup_le (λ _, and.right)) (Sup_le_Sup (λ a ha, ⟨hs a ha, le_Sup ha⟩)),
end

@[simp]
theorem Sup_atoms_eq_top : Sup {a : α | is_atom a} = ⊤ :=
begin
  refine eq.trans (congr rfl (set.ext (λ x, _))) (Sup_atoms_le_eq ⊤),
  exact (and_iff_left le_top).symm,
end

theorem le_iff_atom_le_imp {a b : α} :
  a ≤ b ↔ ∀ c : α, is_atom c → c ≤ a → c ≤ b :=
⟨λ ab c hc ca, le_trans ca ab, λ h, begin
  rw [← Sup_atoms_le_eq a, ← Sup_atoms_le_eq b],
  exact Sup_le_Sup (λ c hc, ⟨hc.1, h c hc.1 hc.2⟩),
end⟩

end is_atomistic

namespace is_coatomistic

instance is_atomistic_dual [h : is_coatomistic α] : is_atomistic (order_dual α) :=
is_atomistic_dual_iff_is_coatomistic.2 h

variable [is_coatomistic α]

@[priority 100]
instance : is_coatomic α :=
⟨λ b, by { rcases eq_Inf_coatoms b with ⟨s, rfl, hs⟩,
  cases s.eq_empty_or_nonempty with h h,
  { simp [h] },
  { exact or.intro_right _ ⟨h.some, hs _ h.some_spec, Inf_le h.some_spec⟩ } } ⟩

end is_coatomistic
end atomistic

/-- An order is simple iff it has exactly two elements, `⊥` and `⊤`. -/
class is_simple_order (α : Type*) [has_le α] [bounded_order α] extends nontrivial α : Prop :=
(eq_bot_or_eq_top : ∀ (a : α), a = ⊥ ∨ a = ⊤)

export is_simple_order (eq_bot_or_eq_top)

theorem is_simple_order_iff_is_simple_order_order_dual [has_le α] [bounded_order α] :
  is_simple_order α ↔ is_simple_order (order_dual α) :=
begin
  split; intro i; haveI := i,
  { exact { exists_pair_ne := @exists_pair_ne α _,
      eq_bot_or_eq_top := λ a, or.symm (eq_bot_or_eq_top ((order_dual.of_dual a)) : _ ∨ _) } },
  { exact { exists_pair_ne := @exists_pair_ne (order_dual α) _,
      eq_bot_or_eq_top := λ a, or.symm (eq_bot_or_eq_top (order_dual.to_dual a)) } }
end

lemma is_simple_order.bot_ne_top [has_le α] [bounded_order α] [is_simple_order α] :
  (⊥ : α) ≠ (⊤ : α) :=
begin
  obtain ⟨a, b, h⟩ := exists_pair_ne α,
  rcases eq_bot_or_eq_top a with rfl|rfl;
  rcases eq_bot_or_eq_top b with rfl|rfl;
  simpa <|> simpa using h.symm
end

section is_simple_order

variables [partial_order α] [bounded_order α] [is_simple_order α]

instance {α} [has_le α] [bounded_order α] [is_simple_order α] : is_simple_order (order_dual α) :=
is_simple_order_iff_is_simple_order_order_dual.1 (by apply_instance)

/-- A simple `bounded_order` induces a preorder. This is not an instance to prevent loops. -/
protected def is_simple_order.preorder {α} [has_le α] [bounded_order α] [is_simple_order α] :
  preorder α :=
{ le := (≤),
  le_refl := λ a, by rcases eq_bot_or_eq_top a with rfl|rfl; simp,
  le_trans := λ a b c, begin
    rcases eq_bot_or_eq_top a with rfl|rfl,
    { simp },
    { rcases eq_bot_or_eq_top b with rfl|rfl,
      { rcases eq_bot_or_eq_top c with rfl|rfl; simp },
      { simp } }
  end }

/-- A simple partial ordered `bounded_order` induces a linear order.
This is not an instance to prevent loops. -/
protected def is_simple_order.linear_order [decidable_eq α] : linear_order α :=
{ le_total := λ a b, by rcases eq_bot_or_eq_top a with rfl|rfl; simp,
  decidable_le := λ a b, if ha : a = ⊥ then is_true (ha.le.trans bot_le) else
    if hb : b = ⊤ then is_true (le_top.trans hb.ge) else
      is_false (λ H, hb (top_unique
        (le_trans (top_le_iff.mpr (or.resolve_left (eq_bot_or_eq_top a) ha)) H))),
  decidable_eq := by assumption,
  ..(infer_instance : partial_order α) }

@[simp] lemma is_atom_top : is_atom (⊤ : α) :=
⟨top_ne_bot, λ a ha, or.resolve_right (eq_bot_or_eq_top a) (ne_of_lt ha)⟩

@[simp] lemma is_coatom_bot : is_coatom (⊥ : α) := is_atom_dual_iff_is_coatom.1 is_atom_top

end is_simple_order

namespace is_simple_order

section bounded_order

variables [lattice α] [bounded_order α] [is_simple_order α]

/-- A simple partial ordered `bounded_order` induces a lattice.
This is not an instance to prevent loops -/
protected def lattice {α} [decidable_eq α] [partial_order α] [bounded_order α]
  [is_simple_order α] : lattice α :=
@lattice_of_linear_order α (is_simple_order.linear_order)

/-- A lattice that is a `bounded_order` is a distributive lattice.
This is not an instance to prevent loops -/
protected def distrib_lattice : distrib_lattice α :=
{ le_sup_inf := λ x y z, by { rcases eq_bot_or_eq_top x with rfl | rfl; simp },
  .. (infer_instance : lattice α) }

@[priority 100] -- see Note [lower instance priority]
instance : is_atomic α :=
⟨λ b, (eq_bot_or_eq_top b).imp_right (λ h, ⟨⊤, ⟨is_atom_top, ge_of_eq h⟩⟩)⟩

@[priority 100] -- see Note [lower instance priority]
instance : is_coatomic α := is_atomic_dual_iff_is_coatomic.1 is_simple_order.is_atomic

end bounded_order

/- It is important that in this section `is_simple_order` is the last type-class argument. -/
section decidable_eq

variables [decidable_eq α] [partial_order α] [bounded_order α] [is_simple_order α]

/-- Every simple lattice is isomorphic to `bool`, regardless of order. -/
@[simps] def equiv_bool {α} [decidable_eq α] [has_le α] [bounded_order α] [is_simple_order α] :
  α ≃ bool :=
{ to_fun := λ x, x = ⊤,
  inv_fun := λ x, cond x ⊤ ⊥,
  left_inv := λ x, by { rcases (eq_bot_or_eq_top x) with rfl | rfl; simp [bot_ne_top] },
  right_inv := λ x, by { cases x; simp [bot_ne_top] } }

/-- Every simple lattice over a partial order is order-isomorphic to `bool`. -/
def order_iso_bool : α ≃o bool :=
{ map_rel_iff' := λ a b, begin
    rcases (eq_bot_or_eq_top a) with rfl | rfl,
    { simp [bot_ne_top] },
    { rcases (eq_bot_or_eq_top b) with rfl | rfl,
      { simp [bot_ne_top.symm, bot_ne_top, bool.ff_lt_tt] },
      { simp [bot_ne_top] } }
  end,
  ..equiv_bool }

/- It is important that `is_simple_order` is the last type-class argument of this instance,
so that type-class inference fails quickly if it doesn't apply. -/
@[priority 200]
instance {α} [decidable_eq α] [has_le α] [bounded_order α] [is_simple_order α] : fintype α :=
fintype.of_equiv bool equiv_bool.symm

/-- A simple `bounded_order` is also a `boolean_algebra`. -/
protected def boolean_algebra {α} [decidable_eq α] [lattice α] [bounded_order α]
  [is_simple_order α] : boolean_algebra α :=
{ compl := λ x, if x = ⊥ then ⊤ else ⊥,
  sdiff := λ x y, if x = ⊤ ∧ y = ⊥ then ⊤ else ⊥,
  sdiff_eq := λ x y, by rcases eq_bot_or_eq_top x with rfl | rfl;
      simp [bot_ne_top, has_sdiff.sdiff, compl],
  inf_compl_le_bot := λ x, begin
      rcases eq_bot_or_eq_top x with rfl | rfl,
      { simp },
      { simp only [top_inf_eq],
        split_ifs with h h;
        simp [h] }
    end,
  top_le_sup_compl := λ x, by rcases eq_bot_or_eq_top x with rfl | rfl; simp,
  sup_inf_sdiff := λ x y, by rcases eq_bot_or_eq_top x with rfl | rfl;
      rcases eq_bot_or_eq_top y with rfl | rfl; simp [bot_ne_top],
  inf_inf_sdiff := λ x y, begin
      rcases eq_bot_or_eq_top x with rfl | rfl,
      { simpa },
      rcases eq_bot_or_eq_top y with rfl | rfl,
      { simpa },
      { simp only [true_and, top_inf_eq, eq_self_iff_true],
        split_ifs with h h;
        simpa [h] }
    end,
  .. (show bounded_order α, by apply_instance),
  .. is_simple_order.distrib_lattice }

end decidable_eq

variables [lattice α] [bounded_order α] [is_simple_order α]
open_locale classical

/-- A simple `bounded_order` is also complete. -/
protected noncomputable def complete_lattice : complete_lattice α :=
{ Sup := λ s, if ⊤ ∈ s then ⊤ else ⊥,
  Inf := λ s, if ⊥ ∈ s then ⊥ else ⊤,
  le_Sup := λ s x h, by { rcases eq_bot_or_eq_top x with rfl | rfl,
    { exact bot_le },
    { rw if_pos h } },
  Sup_le := λ s x h, by { rcases eq_bot_or_eq_top x with rfl | rfl,
    { rw if_neg,
      intro con,
      exact bot_ne_top (eq_top_iff.2 (h ⊤ con)) },
    { exact le_top } },
  Inf_le := λ s x h, by { rcases eq_bot_or_eq_top x with rfl | rfl,
    { rw if_pos h },
    { exact le_top } },
  le_Inf := λ s x h, by { rcases eq_bot_or_eq_top x with rfl | rfl,
    { exact bot_le },
    { rw if_neg,
      intro con,
      exact top_ne_bot (eq_bot_iff.2 (h ⊥ con)) } },
  .. (infer_instance : lattice α),
  .. (infer_instance : bounded_order α) }

/-- A simple `bounded_order` is also a `complete_boolean_algebra`. -/
protected noncomputable def complete_boolean_algebra : complete_boolean_algebra α :=
{ infi_sup_le_sup_Inf := λ x s, by { rcases eq_bot_or_eq_top x with rfl | rfl,
    { simp only [bot_sup_eq, ← Inf_eq_infi], apply le_refl },
    { simp only [top_sup_eq, le_top] }, },
  inf_Sup_le_supr_inf := λ x s, by { rcases eq_bot_or_eq_top x with rfl | rfl,
    { simp only [bot_inf_eq, bot_le] },
    { simp only [top_inf_eq, ← Sup_eq_supr], apply le_refl } },
  .. is_simple_order.complete_lattice,
  .. is_simple_order.boolean_algebra }

end is_simple_order

namespace is_simple_order
variables [complete_lattice α] [is_simple_order α]
set_option default_priority 100

instance : is_atomistic α :=
⟨λ b, (eq_bot_or_eq_top b).elim
  (λ h, ⟨∅, ⟨h.trans Sup_empty.symm, λ a ha, false.elim (set.not_mem_empty _ ha)⟩⟩)
  (λ h, ⟨{⊤}, h.trans Sup_singleton.symm, λ a ha, (set.mem_singleton_iff.1 ha).symm ▸ is_atom_top⟩)⟩

instance : is_coatomistic α := is_atomistic_dual_iff_is_coatomistic.1 is_simple_order.is_atomistic

end is_simple_order
namespace fintype
namespace is_simple_order
variables [partial_order α] [bounded_order α] [is_simple_order α] [decidable_eq α]

lemma univ : (finset.univ : finset α) = {⊤, ⊥} :=
begin
  change finset.map _ (finset.univ : finset bool) = _,
  rw fintype.univ_bool,
  simp only [finset.map_insert, function.embedding.coe_fn_mk, finset.map_singleton],
  refl,
end

lemma card : fintype.card α = 2 :=
(fintype.of_equiv_card _).trans fintype.card_bool

end is_simple_order
end fintype

namespace bool

instance : is_simple_order bool :=
⟨λ a, begin
  rw [← finset.mem_singleton, or.comm, ← finset.mem_insert,
      top_eq_tt, bot_eq_ff, ← fintype.univ_bool],
  apply finset.mem_univ,
end⟩

end bool

theorem is_simple_order_iff_is_atom_top [partial_order α] [bounded_order α] :
  is_simple_order α ↔ is_atom (⊤ : α) :=
⟨λ h, @is_atom_top _ _ _ h, λ h,
  { exists_pair_ne := ⟨⊤, ⊥, h.1⟩,
    eq_bot_or_eq_top := λ a, ((eq_or_lt_of_le le_top).imp_right (h.2 a)).symm }⟩

theorem is_simple_order_iff_is_coatom_bot [partial_order α] [bounded_order α] :
  is_simple_order α ↔ is_coatom (⊥ : α) :=
is_simple_order_iff_is_simple_order_order_dual.trans is_simple_order_iff_is_atom_top

namespace set

theorem is_simple_order_Iic_iff_is_atom [partial_order α] [bounded_order α] {a : α} :
  is_simple_order (Iic a) ↔ is_atom a :=
is_simple_order_iff_is_atom_top.trans $ and_congr (not_congr subtype.mk_eq_mk)
  ⟨λ h b ab, subtype.mk_eq_mk.1 (h ⟨b, le_of_lt ab⟩ ab),
    λ h ⟨b, hab⟩ hbotb, subtype.mk_eq_mk.2 (h b (subtype.mk_lt_mk.1 hbotb))⟩

theorem is_simple_order_Ici_iff_is_coatom [partial_order α] [bounded_order α] {a : α} :
  is_simple_order (Ici a) ↔ is_coatom a :=
is_simple_order_iff_is_coatom_bot.trans $ and_congr (not_congr subtype.mk_eq_mk)
  ⟨λ h b ab, subtype.mk_eq_mk.1 (h ⟨b, le_of_lt ab⟩ ab),
    λ h ⟨b, hab⟩ hbotb, subtype.mk_eq_mk.2 (h b (subtype.mk_lt_mk.1 hbotb))⟩

end set

namespace order_iso

variables {β : Type*}

@[simp] lemma is_atom_iff [partial_order α] [order_bot α] [partial_order β] [order_bot β]
  (f : α ≃o β) (a : α) :
  is_atom (f a) ↔ is_atom a :=
and_congr (not_congr ⟨λ h, f.injective (f.map_bot.symm ▸ h), λ h, f.map_bot ▸ (congr rfl h)⟩)
  ⟨λ h b hb, f.injective ((h (f b) ((f : α ↪o β).lt_iff_lt.2 hb)).trans f.map_bot.symm),
  λ h b hb, f.symm.injective begin
    rw f.symm.map_bot,
    apply h,
    rw [← f.symm_apply_apply a],
    exact (f.symm : β ↪o α).lt_iff_lt.2 hb,
  end⟩

@[simp] lemma is_coatom_iff [partial_order α] [order_top α] [partial_order β] [order_top β]
  (f : α ≃o β) (a : α) :
  is_coatom (f a) ↔ is_coatom a :=
f.dual.is_atom_iff a

lemma is_simple_order_iff [partial_order α] [bounded_order α] [partial_order β] [bounded_order β]
  (f : α ≃o β) :
  is_simple_order α ↔ is_simple_order β :=
by rw [is_simple_order_iff_is_atom_top, is_simple_order_iff_is_atom_top,
  ← f.is_atom_iff ⊤, f.map_top]

lemma is_simple_order [partial_order α] [bounded_order α] [partial_order β] [bounded_order β]
  [h : is_simple_order β] (f : α ≃o β) :
  is_simple_order α :=
f.is_simple_order_iff.mpr h

lemma is_atomic_iff [partial_order α] [order_bot α] [partial_order β] [order_bot β] (f : α ≃o β) :
  is_atomic α ↔ is_atomic β :=
begin
  suffices : (∀ b : α, b = ⊥ ∨ ∃ (a : α), is_atom a ∧ a ≤ b) ↔
    (∀ b : β, b = ⊥ ∨ ∃ (a : β), is_atom a ∧ a ≤ b),
  from ⟨λ ⟨p⟩, ⟨this.mp p⟩, λ ⟨p⟩, ⟨this.mpr p⟩⟩,
  apply f.to_equiv.forall_congr,
  simp_rw [rel_iso.coe_fn_to_equiv],
  intro b, apply or_congr,
  { rw [f.apply_eq_iff_eq_symm_apply, map_bot], },
  { split,
    { exact λ ⟨a, ha⟩, ⟨f a, ⟨(f.is_atom_iff a).mpr ha.1, f.le_iff_le.mpr ha.2⟩⟩, },
    { rintros ⟨b, ⟨hb1, hb2⟩⟩,
      refine ⟨f.symm b, ⟨(f.symm.is_atom_iff b).mpr hb1, _⟩⟩,
      rwa [←f.le_iff_le, f.apply_symm_apply], }, },
end

lemma is_coatomic_iff [partial_order α] [order_top α] [partial_order β] [order_top β] (f : α ≃o β) :
  is_coatomic α ↔ is_coatomic β :=
by { rw [←is_atomic_dual_iff_is_coatomic, ←is_atomic_dual_iff_is_coatomic],
  exact f.dual.is_atomic_iff }

end order_iso

section is_modular_lattice
variables [lattice α] [bounded_order α] [is_modular_lattice α]

namespace is_compl
variables {a b : α} (hc : is_compl a b)
include hc

lemma is_atom_iff_is_coatom : is_atom a ↔ is_coatom b :=
set.is_simple_order_Iic_iff_is_atom.symm.trans $ hc.Iic_order_iso_Ici.is_simple_order_iff.trans
  set.is_simple_order_Ici_iff_is_coatom

lemma is_coatom_iff_is_atom : is_coatom a ↔ is_atom b := hc.symm.is_atom_iff_is_coatom.symm

end is_compl

variables [is_complemented α]

lemma is_coatomic_of_is_atomic_of_is_complemented_of_is_modular [is_atomic α] : is_coatomic α :=
⟨λ x, begin
  rcases exists_is_compl x with ⟨y, xy⟩,
  apply (eq_bot_or_exists_atom_le y).imp _ _,
  { rintro rfl,
    exact eq_top_of_is_compl_bot xy },
  { rintro ⟨a, ha, ay⟩,
    rcases exists_is_compl (xy.symm.Iic_order_iso_Ici ⟨a, ay⟩) with ⟨⟨b, xb⟩, hb⟩,
    refine ⟨↑(⟨b, xb⟩ : set.Ici x), is_coatom.of_is_coatom_coe_Ici _, xb⟩,
    rw [← hb.is_atom_iff_is_coatom, order_iso.is_atom_iff],
    apply ha.Iic }
end⟩

lemma is_atomic_of_is_coatomic_of_is_complemented_of_is_modular [is_coatomic α] : is_atomic α :=
is_coatomic_dual_iff_is_atomic.1 is_coatomic_of_is_atomic_of_is_complemented_of_is_modular

theorem is_atomic_iff_is_coatomic : is_atomic α ↔ is_coatomic α :=
⟨λ h, @is_coatomic_of_is_atomic_of_is_complemented_of_is_modular _ _ _ _ _ h,
  λ h, @is_atomic_of_is_coatomic_of_is_complemented_of_is_modular _ _ _ _ _ h⟩

end is_modular_lattice


/- Integers mod 37

  A demonstration of how to use equivalence relations and equivalence classes in Lean.

  We define the "congruent mod 37" relation on integers, prove it is an equivalence
  relation, define Zmod37 to be the equivalence classes, and put a ring structure on
  the quotient.

-/
-- this import is helpful for some intermediate calculations
import tactic.ring

-- Definition of the equivalence relation
definition cong_mod37 (a b : ℤ) : Prop := ∃ (k : ℤ), k * 37 = b - a

-- Now check it's an equivalence reln!

theorem cong_mod_refl : reflexive (cong_mod37) :=
begin
  intro x,
  -- to prove cong_mod37 x x we just observe that k = 0 will do.
  use (0 : ℤ), -- this is k
  simp,
end

theorem cong_mod_symm : symmetric (cong_mod37) :=
begin
  intros a b H,
  -- H : cond_mod37 a b
  cases H with l Hl,
  -- Hl : l * 37 = (b - a)
  -- Goal is to find an integer k with k * 37 = a - b
  use -l,
  simp [Hl],
end

theorem cong_mod_trans : transitive (cong_mod37) :=
begin
  intros a b c Hab Hbc,
  cases Hab with l Hl,
  cases Hbc with m Hm,
  -- Hl : l * 37 = b - a, and Hm : m * 37 = c - b
  -- Goal : ∃ k, k * 37 = c - a
  use (l + m),
  rw [add_mul, Hl, Hm], ring
end

-- so we've now seen a general technique for proving a ≈ b -- use (the k that works)

theorem cong_mod_equiv : equivalence (cong_mod37) :=
⟨cong_mod_refl, cong_mod_symm, cong_mod_trans⟩

-- Now let's put an equivalence relation on ℤ
definition Zmod37.setoid : setoid ℤ := { r := cong_mod37, iseqv := cong_mod_equiv }

-- Tell the type class inference system about this equivalence relation.
local attribute [instance] Zmod37.setoid

-- Now we can make the quotient.
definition Zmod37 := quotient (Zmod37.setoid)

-- now a little bit of basic interface

namespace Zmod37

-- Let's give a name to the reduction mod 37 map.
definition reduce_mod37 : ℤ → Zmod37 := quot.mk (cong_mod37)

-- Let's now set up a coercion.
definition coe_int_Zmod37 : has_coe ℤ (Zmod37) := ⟨reduce_mod37⟩

-- Let's tell Lean that given an integer, it can consider it as
-- an integer mod 37 automatically.
local attribute [instance] coe_int_Zmod37

-- Notation for 0 and 1
instance : has_zero (Zmod37) := ⟨reduce_mod37 0⟩
instance : has_one (Zmod37) := ⟨reduce_mod37 1⟩

-- Add basic facts about 0 and 1 to the set of simp facts
@[simp] theorem of_int_zero : (0 : (Zmod37))  = reduce_mod37 0 := rfl
@[simp] theorem of_int_one : (1 : (Zmod37))  = reduce_mod37 1 := rfl

-- now back to the maths

-- here's a useful lemma -- it's needed to prove addition is well-defined on the quotient.
-- Note the use of quotient.sound to get from Zmod37 back to Z

lemma congr_add (a₁ a₂ b₁ b₂ : ℤ) : a₁ ≈ b₁ → a₂ ≈ b₂ → ⟦a₁ + a₂⟧ = ⟦b₁ + b₂⟧ :=
begin
  intros H1 H2,
  cases H1 with m Hm, -- Hm : m * 37 = b₁ - a₁
  cases H2 with n Hn, -- Hn : n * 37 = b₂ - a₂
  -- goal is ⟦a₁ + a₂⟧ = ⟦b₁ + b₂⟧
  apply quotient.sound,
  -- goal now a₁ + a₂ ≈ b₁ + b₂, and we know how to do these.
  use (m + n),
  rw [add_mul, Hm, Hn], ring
end

-- That lemma above is *exactly* what we need to make sure addition is
-- well-defined on Zmod37, so let's do this now, using quotient.lift

-- note: stuff like "add" is used everywhere so it's best to protect.
protected definition add : Zmod37 → Zmod37 → Zmod37 :=
quotient.lift₂ (λ a b : ℤ, ⟦a + b⟧) (begin
  show ∀ (a₁ a₂ b₁ b₂ : ℤ), a₁ ≈ b₁ → a₂ ≈ b₂ → ⟦a₁ + a₂⟧ = ⟦b₁ + b₂⟧,
  -- that's what quotient.lift₂ reduces us to doing. But we did it already!
  exact congr_add,
end)

-- Now here's the lemma we need for the definition of neg

-- I spelt out the proof for add, here's a quick term proof for neg.

lemma congr_neg (a b : ℤ) : a ≈ b → ⟦-a⟧ = ⟦-b⟧ :=
λ ⟨m, Hm⟩, quotient.sound ⟨-m, by simp [Hm]⟩

protected def neg : Zmod37 → Zmod37 := quotient.lift (λ a : ℤ, ⟦-a⟧) congr_neg

-- For multiplication I won't even bother proving the lemma, I'll just let ring do it

protected def mul : Zmod37 → Zmod37 → Zmod37 :=
quotient.lift₂ (λ a b : ℤ, ⟦a * b⟧) (λ a₁ a₂ b₁ b₂ ⟨m₁, H₁⟩ ⟨m₂, H₂⟩,
  quotient.sound ⟨b₁ * m₂ + a₂ * m₁, by rw [add_mul, mul_assoc, mul_assoc, H₁, H₂]; ring⟩)

-- this adds notation to the quotient

instance : has_add (Zmod37) := ⟨Zmod37.add⟩
instance : has_neg (Zmod37) := ⟨Zmod37.neg⟩
instance : has_mul (Zmod37) := ⟨Zmod37.mul⟩

-- these are now very cool proofs:
@[simp] lemma coe_add {a b : ℤ} : (↑(a + b) : Zmod37) = ↑a + ↑b := rfl
@[simp] lemma coe_neg {a : ℤ} : (↑(-a) : Zmod37) = -↑a := rfl
@[simp] lemma coe_mul {a b : ℤ} : (↑(a * b) : Zmod37) = ↑a * ↑b := rfl

-- Note that the proof of these results is `rfl`. If we had defined addition
-- on the quotient in the standard way that mathematicians do,
-- by choosing representatives and then adding them,
-- then the proof would not be rfl. This is the power of quotient.lift.

-- Now here's how to use quotient.induction_on and quotient.sound

instance : add_comm_group (Zmod37)  :=
{ add_comm_group .
  zero         := 0, -- because we already defined has_zero
  add          := (+), -- could also have written has_add.add or Zmod37.add
  neg          := has_neg.neg,
  zero_add     :=
    λ abar, quotient.induction_on abar (begin
      -- goal is ∀ (a : ℤ), 0 + ⟦a⟧ = ⟦a⟧ -- that's what quotient.induction_on does for us
      intro a,
      apply quotient.sound, -- works because 0 + ⟦a⟧ is by definition ⟦0⟧ + ⟦a⟧ which
                            -- is by definition ⟦0 + a⟧
      -- goal is now 0 + a ≈ a
      -- here's the way we used to do it.
      use (0 : ℤ),
      simp,
      -- but there are tricks now, which I'll show you with add_zero and add_assoc.
    end),
  add_assoc    := λ abar bbar cbar,quotient.induction_on₃ abar bbar cbar (λ a b c,
    begin
      -- goal now ⟦a⟧ + ⟦b⟧ + ⟦c⟧ = ⟦a⟧ + (⟦b⟧ + ⟦c⟧)
      apply quotient.sound,
      -- goal now a + b + c ≈ a + (b + c)
      rw add_assoc, -- done :-) because after a rw a goal is closed if it's of the form x ≈ x,
                    -- as ≈ is known by Lean to be reflexive.
    end),
  add_zero     := -- I will introduce some more sneaky stuff now
                  -- add_zero for Zmod37 follows from add_zero on Z.
                  -- Note use of $ instead of the brackets
    λ abar, quotient.induction_on abar $ λ a, quotient.sound $ by rw add_zero,
                  -- that's it! Term mode proof.
  add_left_neg := -- super-slow method not even using quotient.induction_on
    begin
      intro abar,
      cases (quot.exists_rep abar) with a Ha,
      rw [←Ha],
      apply quot.sound,
      use (0 : ℤ),
      simp,
    end,
  -- but really all proofs should just look something like this
  add_comm     := λ abar bbar, quotient.induction_on₂ abar bbar $
    λ _ _,quotient.sound $ by rw add_comm,
  -- the noise at the beginning is just the machine; all the work is done by the rewrite
}

-- Now let's just nail this using all the tricks in the book. All ring axioms on the quotient
-- follow from the corresponding axioms for Z.
instance : comm_ring (Zmod37) :=
{
  mul := Zmod37.mul, -- could have written (*)
  -- Now look how the proof of mul_assoc is just the same structure as add_comm above
  -- but with three variables not two
  mul_assoc := λ a b c, quotient.induction_on₃ a b c $ λ _ _ _, quotient.sound $
    by rw mul_assoc,
  one := 1,
  one_mul := λ a, quotient.induction_on a $ λ _, quotient.sound $ by rw one_mul,
  mul_one := λ a, quotient.induction_on a $ λ _, quotient.sound $ by rw mul_one,
  left_distrib := λ a b c, quotient.induction_on₃ a b c $ λ _ _ _, quotient.sound $
    by rw left_distrib,
  right_distrib := λ a b c, quotient.induction_on₃ a b c $ λ _ _ _, quotient.sound $
    by rw right_distrib,
  mul_comm := λ a b, quotient.induction_on₂ a b $ λ _ _, quotient.sound $ by rw mul_comm,
  ..Zmod37.add_comm_group
}

end Zmod37