/-
Copyright (c) 2021 Riccardo Brasca. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Riccardo Brasca
-/

import data.set.finite
import data.finset
import group_theory.submonoid.operations
import group_theory.subgroup.basic

/-!
# Finitely generated monoids and groups

We define finitely generated monoids and groups. See also `submodule.fg` and `module.finite` for
finitely-generated modules.

## Main definition

* `submonoid.fg S`, `add_submonoid.fg S` : A submonoid `S` is finitely generated.
* `monoid.fg M`, `add_monoid.fg M` : A typeclass indicating a type `M` is finitely generated as a
monoid.
* `subgroup.fg S`, `add_subgroup.fg S` : A subgroup `S` is finitely generated.
* `group.fg M`, `add_group.fg M` : A typeclass indicating a type `M` is finitely generated as a
group.

-/

/-! ### Monoids and submonoids -/

open_locale pointwise
variables {M N : Type*} [monoid M] [add_monoid N]

section submonoid

/-- A submonoid of `M` is finitely generated if it is the closure of a finite subset of `M`. -/
@[to_additive]
def submonoid.fg (P : submonoid M) : Prop := ∃ S : finset M, submonoid.closure ↑S = P

/-- An additive submonoid of `N` is finitely generated if it is the closure of a finite subset of
`M`. -/
add_decl_doc add_submonoid.fg

/-- An equivalent expression of `submonoid.fg` in terms of `set.finite` instead of `finset`. -/
@[to_additive "An equivalent expression of `add_submonoid.fg` in terms of `set.finite` instead of
`finset`."]
lemma submonoid.fg_iff (P : submonoid M) : submonoid.fg P ↔
  ∃ S : set M, submonoid.closure S = P ∧ S.finite :=
⟨λ ⟨S, hS⟩, ⟨S, hS, finset.finite_to_set S⟩, λ ⟨S, hS, hf⟩, ⟨set.finite.to_finset hf, by simp [hS]⟩⟩

lemma submonoid.fg_iff_add_fg (P : submonoid M) : P.fg ↔ P.to_add_submonoid.fg :=
⟨λ h, let ⟨S, hS, hf⟩ := (submonoid.fg_iff _).1 h in (add_submonoid.fg_iff _).mpr
  ⟨additive.to_mul ⁻¹' S, by simp [← submonoid.to_add_submonoid_closure, hS], hf⟩,
 λ h, let ⟨T, hT, hf⟩ := (add_submonoid.fg_iff _).1 h in (submonoid.fg_iff _).mpr
  ⟨multiplicative.of_add ⁻¹' T, by simp [← add_submonoid.to_submonoid'_closure, hT], hf⟩⟩

lemma add_submonoid.fg_iff_mul_fg (P : add_submonoid N) : P.fg ↔ P.to_submonoid.fg :=
begin
  convert (submonoid.fg_iff_add_fg P.to_submonoid).symm,
  exact set_like.ext' rfl
end

end submonoid

section monoid

variables (M N)

/-- A monoid is finitely generated if it is finitely generated as a submonoid of itself. -/
class monoid.fg : Prop := (out : (⊤ : submonoid M).fg)

/-- An additive monoid is finitely generated if it is finitely generated as an additive submonoid of
itself. -/
class add_monoid.fg : Prop := (out : (⊤ : add_submonoid N).fg)

attribute [to_additive] monoid.fg

variables {M N}

lemma monoid.fg_def : monoid.fg M ↔ (⊤ : submonoid M).fg := ⟨λ h, h.1, λ h, ⟨h⟩⟩

lemma add_monoid.fg_def : add_monoid.fg N ↔ (⊤ : add_submonoid N).fg := ⟨λ h, h.1, λ h, ⟨h⟩⟩

/-- An equivalent expression of `monoid.fg` in terms of `set.finite` instead of `finset`. -/
@[to_additive "An equivalent expression of `add_monoid.fg` in terms of `set.finite` instead of
`finset`."]
lemma monoid.fg_iff : monoid.fg M ↔
  ∃ S : set M, submonoid.closure S = (⊤ : submonoid M) ∧ S.finite :=
⟨λ h, (submonoid.fg_iff ⊤).1 h.out, λ h, ⟨(submonoid.fg_iff ⊤).2 h⟩⟩

lemma monoid.fg_iff_add_fg : monoid.fg M ↔ add_monoid.fg (additive M) :=
⟨λ h, ⟨(submonoid.fg_iff_add_fg ⊤).1 h.out⟩, λ h, ⟨(submonoid.fg_iff_add_fg ⊤).2 h.out⟩⟩

lemma add_monoid.fg_iff_mul_fg : add_monoid.fg N ↔ monoid.fg (multiplicative N) :=
⟨λ h, ⟨(add_submonoid.fg_iff_mul_fg ⊤).1 h.out⟩, λ h, ⟨(add_submonoid.fg_iff_mul_fg ⊤).2 h.out⟩⟩

instance add_monoid.fg_of_monoid_fg [monoid.fg M] : add_monoid.fg (additive M) :=
monoid.fg_iff_add_fg.1 ‹_›

instance monoid.fg_of_add_monoid_fg [add_monoid.fg N] : monoid.fg (multiplicative N) :=
add_monoid.fg_iff_mul_fg.1 ‹_›

end monoid

@[to_additive]
lemma submonoid.fg.map {M' : Type*} [monoid M'] {P : submonoid M} (h : P.fg) (e : M →* M') :
  (P.map e).fg :=
begin
  classical,
  obtain ⟨s, rfl⟩ := h,
  exact ⟨s.image e, by rw [finset.coe_image, monoid_hom.map_mclosure]⟩
end

@[to_additive]
lemma submonoid.fg.map_injective {M' : Type*} [monoid M'] {P : submonoid M}
  (e : M →* M') (he : function.injective e) (h : (P.map e).fg) : P.fg :=
begin
  obtain ⟨s, hs⟩ := h,
  use s.preimage e (he.inj_on _),
  apply submonoid.map_injective_of_injective he,
  rw [← hs, e.map_mclosure, finset.coe_preimage],
  congr,
  rw [set.image_preimage_eq_iff, ← e.coe_mrange, ← submonoid.closure_le, hs, e.mrange_eq_map],
  exact submonoid.monotone_map le_top
end

@[simp, to_additive]
lemma monoid.fg_iff_submonoid_fg (N : submonoid M) : monoid.fg N ↔ N.fg :=
begin
  conv_rhs { rw [← N.range_subtype, monoid_hom.mrange_eq_map] },
  exact ⟨λ h, h.out.map N.subtype, λ h, ⟨h.map_injective N.subtype subtype.coe_injective⟩⟩
end

@[to_additive]
lemma monoid.fg_of_surjective {M' : Type*} [monoid M'] [monoid.fg M]
  (f : M →* M') (hf : function.surjective f) : monoid.fg M' :=
begin
  classical,
  obtain ⟨s, hs⟩ := monoid.fg_def.mp ‹_›,
  use s.image f,
  rwa [finset.coe_image, ← monoid_hom.map_mclosure, hs, ← monoid_hom.mrange_eq_map,
    monoid_hom.mrange_top_iff_surjective],
end

@[to_additive]
lemma submonoid.powers_fg (r : M) : (submonoid.powers r).fg :=
⟨{r}, (finset.coe_singleton r).symm ▸ (submonoid.powers_eq_closure r).symm⟩

@[to_additive]
instance (r : M) : monoid.fg (submonoid.powers r) :=
(monoid.fg_iff_submonoid_fg _).mpr (submonoid.powers_fg r)

/-! ### Groups and subgroups -/

variables {G H : Type*} [group G] [add_group H]

section subgroup

/-- A subgroup of `G` is finitely generated if it is the closure of a finite subset of `G`. -/
@[to_additive]
def subgroup.fg (P : subgroup G) : Prop := ∃ S : finset G, subgroup.closure ↑S = P

/-- An additive subgroup of `H` is finitely generated if it is the closure of a finite subset of
`H`. -/
add_decl_doc add_subgroup.fg

/-- An equivalent expression of `subgroup.fg` in terms of `set.finite` instead of `finset`. -/
@[to_additive "An equivalent expression of `add_subgroup.fg` in terms of `set.finite` instead of
`finset`."]
lemma subgroup.fg_iff (P : subgroup G) : subgroup.fg P ↔
  ∃ S : set G, subgroup.closure S = P ∧ S.finite :=
⟨λ⟨S, hS⟩, ⟨S, hS, finset.finite_to_set S⟩, λ⟨S, hS, hf⟩, ⟨set.finite.to_finset hf, by simp [hS]⟩⟩

/-- A subgroup is finitely generated if and only if it is finitely generated as a submonoid. -/
@[to_additive add_subgroup.fg_iff_add_submonoid.fg "An additive subgroup is finitely generated if
and only if it is finitely generated as an additive submonoid."]
lemma subgroup.fg_iff_submonoid_fg (P : subgroup G) : P.fg ↔ P.to_submonoid.fg :=
begin
  split,
  { rintro ⟨S, rfl⟩,
    rw submonoid.fg_iff,
    refine ⟨S ∪ S⁻¹, _, S.finite_to_set.union S.finite_to_set.inv⟩,
    exact (subgroup.closure_to_submonoid _).symm },
  { rintro ⟨S, hS⟩,
    refine ⟨S, le_antisymm _ _⟩,
    { rw [subgroup.closure_le, ←subgroup.coe_to_submonoid, ←hS],
      exact submonoid.subset_closure },
    { rw [← subgroup.to_submonoid_le, ← hS, submonoid.closure_le],
      exact subgroup.subset_closure } }
end

lemma subgroup.fg_iff_add_fg (P : subgroup G) : P.fg ↔ P.to_add_subgroup.fg :=
begin
  rw [subgroup.fg_iff_submonoid_fg, add_subgroup.fg_iff_add_submonoid.fg],
  exact (subgroup.to_submonoid P).fg_iff_add_fg
end

lemma add_subgroup.fg_iff_mul_fg (P : add_subgroup H) :
  P.fg ↔ P.to_subgroup.fg :=
begin
  rw [add_subgroup.fg_iff_add_submonoid.fg, subgroup.fg_iff_submonoid_fg],
  exact add_submonoid.fg_iff_mul_fg (add_subgroup.to_add_submonoid P)
end

end subgroup

section group

variables (G H)

/-- A group is finitely generated if it is finitely generated as a submonoid of itself. -/
class group.fg : Prop := (out : (⊤ : subgroup G).fg)

/-- An additive group is finitely generated if it is finitely generated as an additive submonoid of
itself. -/
class add_group.fg : Prop := (out : (⊤ : add_subgroup H).fg)

attribute [to_additive] group.fg

variables {G H}

lemma group.fg_def : group.fg G ↔ (⊤ : subgroup G).fg := ⟨λ h, h.1, λ h, ⟨h⟩⟩

lemma add_group.fg_def : add_group.fg H ↔ (⊤ : add_subgroup H).fg := ⟨λ h, h.1, λ h, ⟨h⟩⟩

/-- An equivalent expression of `group.fg` in terms of `set.finite` instead of `finset`. -/
@[to_additive "An equivalent expression of `add_group.fg` in terms of `set.finite` instead of
`finset`."]
lemma group.fg_iff : group.fg G ↔
  ∃ S : set G, subgroup.closure S = (⊤ : subgroup G) ∧ S.finite :=
⟨λ h, (subgroup.fg_iff ⊤).1 h.out, λ h, ⟨(subgroup.fg_iff ⊤).2 h⟩⟩

/-- A group is finitely generated if and only if it is finitely generated as a monoid. -/
@[to_additive add_group.fg_iff_add_monoid.fg "An additive group is finitely generated if and only
if it is finitely generated as an additive monoid."]
lemma group.fg_iff_monoid.fg : group.fg G ↔ monoid.fg G :=
⟨λ h, monoid.fg_def.2 $ (subgroup.fg_iff_submonoid_fg ⊤).1 (group.fg_def.1 h),
    λ h, group.fg_def.2 $ (subgroup.fg_iff_submonoid_fg ⊤).2 (monoid.fg_def.1 h)⟩

lemma group_fg.iff_add_fg : group.fg G ↔ add_group.fg (additive G) :=
⟨λ h, ⟨(subgroup.fg_iff_add_fg ⊤).1 h.out⟩, λ h, ⟨(subgroup.fg_iff_add_fg ⊤).2 h.out⟩⟩

lemma add_group.fg_iff_mul_fg : add_group.fg H ↔ group.fg (multiplicative H) :=
⟨λ h, ⟨(add_subgroup.fg_iff_mul_fg ⊤).1 h.out⟩, λ h, ⟨(add_subgroup.fg_iff_mul_fg ⊤).2 h.out⟩⟩

instance add_group.fg_of_group_fg [group.fg G] : add_group.fg (additive G) :=
group_fg.iff_add_fg.1 ‹_›

instance group.fg_of_mul_group_fg [add_group.fg H] : group.fg (multiplicative H) :=
add_group.fg_iff_mul_fg.1 ‹_›

end group


import useful_lemmas
import algebra.ring.basic
import algebra.big_operators.basic
import algebra.group.units
import data.nat.basic
import data.polynomial.basic
import data.polynomial.coeff
import data.polynomial.degree.definitions
import order.basic
import order.locally_finite
import ring_theory.nilpotent
import ring_theory.polynomial.content
import tactic
open finset tactic polynomial nat set
open_locale big_operators

variables {R : Type*} [comm_ring R] [nontrivial R]

/-
1.1: sum of unit and nilpotent is a unit
-/
lemma mul_neg_one_square (r : R) : r * (-1) ^ 2 = r := by ring

theorem unit_of_one_plus_nilpotent (r : R) (h : is_nilpotent r) :
  is_unit (1 + r) :=
begin
  rw is_unit_iff_exists_inv',
  by_cases rzero : r = 0,
  rw [rzero, add_zero],
  use ⟨1, by ring⟩,

  obtain ⟨n, hn⟩ := h,
  have npos : n > 0,
  { by_contra h,
    replace h := nat.eq_zero_of_le_zero (le_of_not_gt h),
    subst h,
    have contra : (0 : R) ≠ (1 : R) := zero_ne_one,
    rw ←hn at contra,
    exact contra (pow_zero _) },

  set S : ℕ → R := λ k, (-1) ^ k * r ^ k with Sdef,
  set inv := ∑ (k : ℕ) in Ico 0 n, S k with invdef,

  have : ∀ (k : ℕ), S (k+1) = (-1) ^ (k+1) * r ^ (k+1) :=
    by { intro k, refl },

  use inv,
  { rw [invdef, mul_add, mul_one, sum_mul],
      -- I wish there was an easier way to manipulate sums...
      conv_lhs {
        conv {
          congr, skip, congr, skip, funext,
          rw mul_assoc, rw ←pow_succ',

          rw ←mul_neg_one_square ((-1 : R) ^ x),
          rw [←pow_add, pow_succ, mul_assoc, ←this x, add_comm],
        },
        conv {
          congr,
          rw [sum_eq_sum_Ico_succ_bot npos, zero_add],
          skip,
          rw sum_Ico_add (λ k, (-1) * S k),
          rw sum_Ico_succ_top (succ_le_iff.mpr npos),
        }
      },
      repeat { dsimp only },
      conv_lhs {
        rw add_assoc, congr, skip, rw ←add_assoc, congr,
        rw ←sum_add_distrib, congr, skip, funext,
        dsimp [S], simp,
      },
      rw sum_const_zero, dsimp [S], rw hn, ring }
end

lemma nilpotent_of_mul_nilpotent (a r : R) (hr : is_nilpotent r) :
  is_nilpotent (a * r) :=
begin
  obtain ⟨n, hn⟩ := hr,
  use n,
  rw [mul_pow, hn, mul_zero]
end

theorem unit_of_unit_plus_nilpotent {u r : R} (hu : is_unit u) (hr : is_nilpotent r) :
  is_unit (u + r) :=
begin
  have hu' := hu,  -- For the last line
  rw is_unit_iff_exists_inv at hu,
  obtain ⟨v, huv⟩ := hu,

  have : u + r = u * (1 + v * r) :=
    by { rw [mul_add, ←mul_assoc], rw huv, simp },
  rw this,

  exact is_unit.mul hu'
    (unit_of_one_plus_nilpotent _ (nilpotent_of_mul_nilpotent _ _ hr)),
end

/-
1.2: characterisation of units, nilpotents, zero divisors in R[x],
and primitive elements
-/
lemma is_unit_const_of_unit {p : polynomial R} (h : is_unit p) :
  is_unit (p.coeff 0) :=
begin
  rw is_unit_iff_exists_inv at ⊢ h,
  obtain ⟨q, hpq⟩ := h,
  use q.coeff 0,
  rw polynomial.ext_iff at hpq,
  specialize hpq 0,
  rwa [mul_coeff_zero, coeff_one_zero] at hpq
end

lemma sum_antidiagonal_split {a b : ℕ} {f : ℕ × ℕ → R} :
  ∑ (x : ℕ × ℕ) in nat.antidiagonal (a + b), f x =
  ∑ x in nat.antidiagonal (a + b) \ {(a, b)}, f x + f (a, b) :=
begin
  have h : {(a, b)} ⊆ nat.antidiagonal (a + b),
  { intro x,
    rw [finset.mem_singleton, nat.mem_antidiagonal],
    intro hx, rw hx },
  rw [←sum_sdiff h, sum_singleton],
end

lemma antidiagonal_gt_of {a b : ℕ} {x : ℕ × ℕ}
  (h : x ∈ nat.antidiagonal (a + b) \ {(a, b)}):
  x.fst > a ∨ x.snd > b :=
begin
  rw [mem_sdiff, nat.mem_antidiagonal, finset.mem_singleton,
      prod.ext_iff, not_and_distrib] at h,
  rcases h with ⟨hx1, hx2⟩,
  dsimp at hx2,

  by_contra h,
  rw not_or_distrib at h,
  cases hx2,
  { have contra := add_lt_of_lt_and_le
      ((ne.le_iff_lt hx2).mp (le_of_not_gt h.left))
      (le_of_not_gt h.right),
    exact (ne_of_lt contra) hx1 },
  { have contra := add_lt_of_lt_and_le
      ((ne.le_iff_lt hx2).mp (le_of_not_gt h.right))
      (le_of_not_gt h.left),
    conv_lhs at contra { rw add_comm },
    conv_rhs at contra { rw add_comm },
    exact (ne_of_lt contra) hx1 }
end

lemma leading_term_nilpotent_of_unit {p : polynomial R}
(dpos : p.nat_degree > 0) (h : is_unit p) :
  is_nilpotent p.leading_coeff :=
begin
  rw is_unit_iff_exists_inv at h,
  obtain ⟨q, hpq⟩ := h,

  let n := p.nat_degree,
  let m := q.nat_degree,
  have nmpos : n + m > 0 := add_pos_left dpos m,

  have h1 : ∀ r, r ≤ m → p.coeff n ^ (r + 1) * q.coeff (m - r) = 0,
  { intros r,
    rw polynomial.ext_iff at hpq,
    apply nat.case_strong_induction_on r, clear r,

    { intro _, simp,
      rw ←coeff_mul_degree_add_degree,
      specialize hpq (n + m),
      rwa [coeff_one, if_neg] at hpq,
      exact ne_of_lt nmpos },

    { intros i hi him,
      set d' := n + (m - i.succ) with d'_def,
      have d'pos : d' > 0 :=
        calc 0 < n : dpos
        ... = n + 0 : by rw add_zero
        ... ≤ n + (m - i.succ) : add_le_add_left (zero_le _) n,

      -- Spaghetti code warning
      specialize hpq d',
      rw [coeff_mul, coeff_one, if_neg] at hpq,
      swap, exact ne_of_lt d'pos,
      { have h : ∑ x in nat.antidiagonal d' \ {(n, m - i.succ)},
          p.coeff n ^ i.succ * (p.coeff x.fst * q.coeff x.snd) = 0,
        { apply sum_eq_zero,
          intros x hx,

          by_cases hx' : x.fst > n ∨ x.snd > m,
          { cases hx',
              rw [coeff_eq_zero_of_nat_degree_lt hx', zero_mul, mul_zero],
              rw [coeff_eq_zero_of_nat_degree_lt hx', mul_zero, mul_zero] },

          rw not_or_distrib at hx',
          replace hx := antidiagonal_gt_of hx,
          cases hx,
            rw [coeff_eq_zero_of_nat_degree_lt hx, zero_mul, mul_zero],

          replace hx := add_lt_add_right hx i.succ,
          rw [nat.sub_add_cancel him, add_succ, lt_succ_iff] at hx,
          replace hx := nat.sub_le_sub_right hx x.snd,
          rw nat.add_sub_cancel_left x.snd i at hx,
          -- hx is now `m - x.snd ≤ i`

          have ha := hi (m - x.snd) hx (nat.sub_le _ _),
          rw sub_sub' (not_lt.mp hx'.right) at ha,

          have hb : i.succ = (i.succ - (m - x.snd + 1)) + (m - x.snd + 1),
          { rw nat.sub_add_cancel _,
            rwa succ_le_succ_iff },
          rw [hb, pow_add, mul_assoc],
          conv_lhs { congr, skip, congr, skip, rw mul_comm },
          conv_lhs { congr, skip, rw ←mul_assoc },
          rw [ha, zero_mul, mul_zero] },

        replace hpq := mul_left_of_eq (p.coeff n ^ i.succ) hpq,
        rw [mul_sum, mul_zero, sum_antidiagonal_split] at hpq,
        dsimp only at hpq,
        rw [h, zero_add] at hpq,
        convert hpq using 1,
        rw [←mul_assoc, pow_add, pow_one] } } },

  have h2 : ∀ r, r ≤ m → p.coeff n ^ m.succ * q.coeff (m - r) = 0,
  { intros r hr,
    have h := h1 r hr,
    replace h := mul_left_of_eq (p.coeff n ^ (m + 1 - r.succ)) h,
    have ha : m.succ - r.succ + r.succ = m.succ :=
      nat.sub_add_cancel (succ_le_succ_iff.mpr hr),
    rwa [←mul_assoc, mul_zero, ←pow_add, ha] at h },

  have h3 : p.coeff n ^ m.succ * eval 1 q = 0,
  { rw [eval_eq_finset_sum, mul_sum],
    convert finset.sum_const_zero,
    ext i, rw [one_pow, mul_one],
    by_cases hi : i ≤ m,
    { have := h2 (m - i) (nat.sub_le _ _),
      rwa sub_sub' hi at this },
    { rw [coeff_eq_zero_of_nat_degree_lt (not_le.mp hi), mul_zero] } },

  have h4 : p.coeff n ^ m.succ = 0,
  { have ha : eval 1 q * eval 1 p = 1 :=
      by rw [←eval_mul, mul_comm, hpq, eval_one],
    have hb := mul_right_of_eq (eval 1 p) h3,
    rwa [mul_assoc, ha, mul_one, zero_mul] at hb },

  use m.succ, convert h4
end

lemma monomial_nilpotent_of_nilpotent {r : R} (h : is_nilpotent r) (n : ℕ) :
  is_nilpotent ((monomial n) r) :=
by { obtain ⟨n, hn⟩ := h, use n, rwa [monomial_pow, monomial_eq_zero_iff] }

theorem polynomial_unit_iff (p : polynomial R) :
  is_unit p ↔ is_unit (p.coeff 0) ∧ ∀ (n : ℕ), n > 0 → is_nilpotent (p.coeff n) :=
begin
  split,
  { intro hp, split,
    { exact is_unit_const_of_unit hp },

    revert hp,
    induction hd : p.nat_degree using nat.case_strong_induction_on with i hi generalizing p,
    { intros hp n npos,
      rw coeff_eq_zero_of_nat_degree_lt _,
      exact is_nilpotent.zero, rwa hd },

    { intros hp n npos,
      set p' := p.erase p.nat_degree with p'_def,

      have dpos := nat.pos_of_ne_zero (succ_ne_zero i),
      rw ←hd at dpos,

      have h1 := unit_of_unit_plus_nilpotent hp
        (is_nilpotent.neg
          (monomial_nilpotent_of_nilpotent
            (leading_term_nilpotent_of_unit dpos hp) p.nat_degree)),
      rw ←orig_sub_monomial p at h1,

      have h2 : p'.nat_degree < p.nat_degree := erase_nat_degree_lt dpos,

      have h3 : ∀ n, n > 0 → is_nilpotent (p'.coeff n),
      { intros n npos,
        rw [hd, lt_succ_iff] at h2,
        exact hi p'.nat_degree h2 p' rfl h1 n npos },

      by_cases hn : n = p.nat_degree,
      { convert (leading_term_nilpotent_of_unit dpos hp) },
      { specialize h3 n npos,
        convert h3 using 1,
        rwa [coeff_erase, if_neg] } } },

  { induction hd : p.nat_degree using nat.case_strong_induction_on with i hi generalizing p,
    { rintro ⟨hconst, -⟩,
      rw is_unit_iff_exists_inv at ⊢ hconst,
      obtain ⟨inv, mul_inv⟩ := hconst,
      rw eq_C_of_nat_degree_eq_zero hd,
      use C inv, rw [←C_mul, mul_inv], exact C_1 },

    { rintro ⟨hconst, hrest⟩,
      have dpos := nat.pos_of_ne_zero (succ_ne_zero i),
      rw ←hd at dpos,

      set p' := p.erase p.nat_degree with p'_def,

      have h1 : p'.nat_degree < p.nat_degree := erase_nat_degree_lt dpos,

      have hconst' : is_unit (p'.coeff 0) :=
        by { rw (erase_const_eq dpos), exact hconst },
      have hrest' : ∀ n, n > 0 → is_nilpotent (p'.coeff n),
      { intro n, cases erase_coeff_eq_orig_or_zero p n with ha hb,
          rw ha, intro _, exact is_nilpotent.zero,
          rw hb, exact hrest n },

      have h2 : is_unit p',
      { rw [hd, lt_succ_iff] at h1,
        exact hi p'.nat_degree h1 p' rfl ⟨hconst', hrest'⟩ },

      let leading_term := (monomial p.nat_degree) p.leading_coeff,
      have h3 : is_nilpotent leading_term,
      { obtain ⟨n, hn⟩ := hrest p.nat_degree dpos,
        use n, rw [monomial_pow, monomial_eq_zero_iff], convert hn },

      rw [←monomial_add_erase p p.nat_degree, ←p'_def, add_comm],
      exact unit_of_unit_plus_nilpotent h2 h3 } }
end

lemma leading_term_nilpotent_of_nilpotent {p : polynomial R} (h : is_nilpotent p) :
  is_nilpotent p.leading_coeff :=
begin
  obtain ⟨n, hn⟩ := h,
  use n,
  rw ←coeff_pow_degree_mul_degree p n,
  rw polynomial.ext_iff at hn,
  exact hn _,
end

theorem polynomial_nilpotent_iff (p : polynomial R) :
  is_nilpotent p ↔ ∀ (n : ℕ), is_nilpotent (p.coeff n) :=
begin
  split,
  { induction hd : p.nat_degree using nat.strong_induction_on with i hi generalizing p,
    intros hp n,
    dsimp at hi, subst hd,
    cases erase_nat_degree_lt_or_zero p with h,

    { by_cases hn : n = 0,
      { rw [hn, ←h], exact leading_term_nilpotent_of_nilpotent hp },
      { change n ≠ 0 at hn, rw [←pos_iff_ne_zero, ←h] at hn,
        rw coeff_eq_zero_of_nat_degree_lt hn,
        exact is_nilpotent.zero }},

    { set p' := p.erase p.nat_degree with p'_def, rw ←p'_def at *,
      have hp' := hi p'.nat_degree h p' rfl,
      have h1 := leading_term_nilpotent_of_nilpotent hp,
      have h2 := commute.is_nilpotent_add (by exact comm_ring.mul_comm _ _) hp
        (is_nilpotent.neg
          (monomial_nilpotent_of_nilpotent h1 p.nat_degree)),
      rw ←orig_sub_monomial p at h2,

      apply reduce_to_erase n,
      { exact h1 },
      { exact hp' h2 },
      -- very hacky, figure out how to remove this
      exact _inst_2 } },

  { induction hd : p.nat_degree using nat.strong_induction_on with i hi generalizing p,
    intros hp,
    dsimp at hi, subst hd,
    cases erase_nat_degree_lt_or_zero p with h,

    { replace h := eq_C_of_nat_degree_eq_zero h, rw h,
      obtain ⟨n, hn⟩ := hp 0,
      use n, rw [←C_pow, hn, C_eq_zero] },

    { set p' := p.erase p.nat_degree with p'_def, rw ←p'_def at *,
      have h1 : ∀ n, is_nilpotent (p'.coeff n),
      { intro n,
        cases erase_coeff_eq_orig_or_zero p n with h' h'; rw h',
        { exact is_nilpotent.zero },
        { exact hp n } },
      have h2 := hi p'.nat_degree h p' rfl h1,
      have h3 : is_nilpotent (monomial p.nat_degree p.leading_coeff) :=
        monomial_nilpotent_of_nilpotent (hp p.nat_degree) _,

      rw ←monomial_add_erase p p.nat_degree,
      exact commute.is_nilpotent_add (by exact comm_ring.mul_comm _ _) h3 h2 } }
end

def is_zero_divisor (a : R) : Prop := a ≠ 0 ∧ ∃ b, b ≠ 0 ∧ a * b = 0

theorem polynomial_zero_divisor_iff (p : polynomial R) :
  is_zero_divisor p ↔ ∃ (a : R), a ≠ 0 ∧ a • p = 0 :=
sorry

theorem polynomial_primitive_mul_iff (p q : polynomial R) :
  (p * q).is_primitive ↔ p.is_primitive ∧ q.is_primitive :=
sorry


/-
Copyright (c) 2020 Oliver Nash. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Oliver Nash
-/
import algebra.lie.of_associative
import algebra.ring_quot
import linear_algebra.tensor_algebra

/-!
# Universal enveloping algebra

Given a commutative ring `R` and a Lie algebra `L` over `R`, we construct the universal
enveloping algebra of `L`, together with its universal property.

## Main definitions

  * `universal_enveloping_algebra`: the universal enveloping algebra, endowed with an
    `R`-algebra structure.
  * `universal_enveloping_algebra.ι`: the Lie algebra morphism from `L` to its universal
    enveloping algebra.
  * `universal_enveloping_algebra.lift`: given an associative algebra `A`, together with a Lie
    algebra morphism `f : L →ₗ⁅R⁆ A`, `lift R L f : universal_enveloping_algebra R L →ₐ[R] A` is the
    unique morphism of algebras through which `f` factors.
  * `universal_enveloping_algebra.ι_comp_lift`: states that the lift of a morphism is indeed part
    of a factorisation.
  * `universal_enveloping_algebra.lift_unique`: states that lifts of morphisms are indeed unique.
  * `universal_enveloping_algebra.hom_ext`: a restatement of `lift_unique` as an extensionality
    lemma.

## Tags

lie algebra, universal enveloping algebra, tensor algebra
-/

universes u₁ u₂ u₃

variables (R : Type u₁) (L : Type u₂)
variables [comm_ring R] [lie_ring L] [lie_algebra R L]

local notation `ιₜ` := tensor_algebra.ι R

namespace universal_enveloping_algebra

/-- The quotient by the ideal generated by this relation is the universal enveloping algebra.

Note that we have avoided using the more natural expression:
| lie_compat (x y : L) : rel (ιₜ ⁅x, y⁆) ⁅ιₜ x, ιₜ y⁆
so that our construction needs only the semiring structure of the tensor algebra. -/
inductive rel : tensor_algebra R L → tensor_algebra R L → Prop
| lie_compat (x y : L) : rel (ιₜ ⁅x, y⁆ + (ιₜ y) * (ιₜ x)) ((ιₜ x) * (ιₜ y))

end universal_enveloping_algebra

/-- The universal enveloping algebra of a Lie algebra. -/
@[derive [inhabited, ring, algebra R]]
def universal_enveloping_algebra := ring_quot (universal_enveloping_algebra.rel R L)

namespace universal_enveloping_algebra

/-- The quotient map from the tensor algebra to the universal enveloping algebra as a morphism of
associative algebras. -/
def mk_alg_hom : tensor_algebra R L →ₐ[R] universal_enveloping_algebra R L :=
ring_quot.mk_alg_hom R (rel R L)

variables {L}

/-- The natural Lie algebra morphism from a Lie algebra to its universal enveloping algebra. -/
def ι : L →ₗ⁅R⁆ universal_enveloping_algebra R L :=
{ map_lie'   := λ x y, by
  { suffices : mk_alg_hom R L (ιₜ ⁅x, y⁆ + (ιₜ y) * (ιₜ x)) = mk_alg_hom R L ((ιₜ x) * (ιₜ y)),
    { rw alg_hom.map_mul at this, simp [lie_ring.of_associative_ring_bracket, ← this], },
    exact ring_quot.mk_alg_hom_rel _ (rel.lie_compat x y), },
  ..(mk_alg_hom R L).to_linear_map.comp ιₜ }

variables {A : Type u₃} [ring A] [algebra R A] (f : L →ₗ⁅R⁆ A)

/-- The universal property of the universal enveloping algebra: Lie algebra morphisms into
associative algebras lift to associative algebra morphisms from the universal enveloping algebra. -/
def lift : (L →ₗ⁅R⁆ A) ≃ (universal_enveloping_algebra R L →ₐ[R] A) :=
{ to_fun := λ f,
    ring_quot.lift_alg_hom R ⟨tensor_algebra.lift R (f : L →ₗ[R] A),
    begin
      intros a b h, induction h with x y,
      simp [lie_ring.of_associative_ring_bracket],
    end⟩,
  inv_fun := λ F, (lie_algebra.of_associative_algebra_hom F).comp (ι R),
  left_inv := λ f, by { ext, simp [ι, mk_alg_hom], },
  right_inv := λ F, by { ext, simp [ι, mk_alg_hom], } }

@[simp] lemma lift_symm_apply (F : universal_enveloping_algebra R L →ₐ[R] A) :
  (lift R).symm F = (lie_algebra.of_associative_algebra_hom F).comp (ι R) :=
rfl

@[simp] lemma ι_comp_lift : (lift R f) ∘ (ι R) = f :=
funext $ lie_hom.ext_iff.mp $ (lift R).symm_apply_apply f

@[simp] lemma lift_ι_apply (x : L) : lift R f (ι R x) = f x :=
by rw [←function.comp_apply (lift R f) (ι R) x, ι_comp_lift]

lemma lift_unique (g : universal_enveloping_algebra R L →ₐ[R] A) :
  g ∘ (ι R) = f ↔ g = lift R f :=
begin
  refine iff.trans _ (lift R).symm_apply_eq,
  split; {intro h, ext, simp [←h] },
end

/-- See note [partially-applied ext lemmas]. -/
@[ext] lemma hom_ext {g₁ g₂ : universal_enveloping_algebra R L →ₐ[R] A}
  (h : g₁ ∘ (ι R) = g₂ ∘ (ι R)) : g₁ = g₂ :=
begin
  apply (lift R).symm.injective,
  rw [lift_symm_apply, lift_symm_apply],
  ext x,
  have := congr h (rfl : x = x),
  rw function.comp_apply at this,
  simp [this],
end

end universal_enveloping_algebra


import tactic.apply_fun
import data.matrix.basic

open function

example (X Y Z : Type) (f : X → Y) (g : Y → Z) (H : injective $ g ∘ f) :
  injective f :=
begin
  intros x x' h,
  apply_fun g at h,
  exact H h
end

example (f : ℕ → ℕ) (a b : ℕ) (monof : monotone f) (h : a ≤ b) : f a ≤ f b :=
begin
  apply_fun f at h,
  assumption,
  assumption
end

example (a b : ℤ) (h : a = b) : a + 1 = b + 1 :=
begin
  apply_fun (λ n, n+1) at h,
  -- check that `h` was β-reduced
  guard_hyp' h : a + 1 = b + 1,
  exact h
end

example (f : ℕ → ℕ) (a b : ℕ) (monof : monotone f) (h : a ≤ b) : f a ≤ f b :=
begin
  apply_fun f at h using monof,
  assumption
end

-- monotonicity will be proved by `mono` in the next example
example (a b : ℕ) (h : a ≤ b) : a + 1 ≤ b + 1 :=
begin
  apply_fun (λ n, n+1) at h,
  exact h
end

example {n : Type} [fintype n] {X : Type} [semiring X]
  (f : matrix n n X → matrix n n X) (A B : matrix n n X) (h : A * B = 0) : f (A * B) = f 0 :=
begin
  apply_fun f at h,
  -- check that our β-reduction didn't mess things up:
  -- (previously `apply_fun` was producing `f (A.mul B) = f 0`)
  guard_hyp' h : f (A * B) = f 0,
  exact h,
end

-- Verify that `apply_fun` works with `fin.cast_succ`, even though it has an implicit argument.
example (n : ℕ) (a b : fin n) (H : a ≤ b) : a.cast_succ ≤ b.cast_succ :=
begin
  apply_fun fin.cast_succ at H,
  exact H,
end

example (n m : ℕ) (f : ℕ → ℕ) (h : f n ≠ f m) : n ≠ m :=
begin
  apply_fun f,
  exact h,
end

example (n m : ℕ) (f : ℕ → ℕ) (w : function.injective f) (h : f n = f m) : n = m :=
begin
  apply_fun f,
  assumption,
end

example (n m : ℕ) (f : ℕ → ℕ) (w : function.injective f ∧ true) (h : f n = f m) : n = m :=
begin
  apply_fun f using w.1,
  assumption,
end

example (n m : ℕ) (f : ℕ → ℕ) (w : function.injective f ∧ true) (h : f n = f m) : n = m :=
begin
  apply_fun f,
  assumption,
  exact w.1,
end

example (n m : ℕ) (f : ℕ ≃ ℕ) (h : f n = f m) : n = m :=
begin
  apply_fun f,
  assumption,
end

example (n m : ℕ) (f : ℕ ≃o ℕ) (h : f n ≤ f m) : n ≤ m :=
begin
  apply_fun f,
  assumption,
end

example (n m : ℕ) (f : ℕ ≃o ℕ) (h : f n < f m) : n < m :=
begin
  apply_fun f,
  assumption,
end


/-
Copyright (c) 2018 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Mitchell Rowett, Scott Morrison, Johan Commelin, Mario Carneiro,
  Michael Howes
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.group_theory.subgroup
import Mathlib.deprecated.submonoid
import Mathlib.PostPort

universes u_3 l u_1 u_2 u_4

namespace Mathlib

/-- `s` is an additive subgroup: a set containing 0 and closed under addition and negation. -/
class is_add_subgroup {A : Type u_3} [add_group A] (s : set A) extends is_add_submonoid s where
  neg_mem : ∀ {a : A}, a ∈ s → -a ∈ s

/-- `s` is a subgroup: a set containing 1 and closed under multiplication and inverse. -/
class is_subgroup {G : Type u_1} [group G] (s : set G) extends is_submonoid s where
  inv_mem : ∀ {a : G}, a ∈ s → a⁻¹ ∈ s

theorem is_subgroup.div_mem {G : Type u_1} [group G] {s : set G} [is_subgroup s] {x : G} {y : G}
    (hx : x ∈ s) (hy : y ∈ s) : x / y ∈ s :=
  sorry

theorem additive.is_add_subgroup {G : Type u_1} [group G] (s : set G) [is_subgroup s] :
    is_add_subgroup s :=
  is_add_subgroup.mk is_subgroup.inv_mem

theorem additive.is_add_subgroup_iff {G : Type u_1} [group G] {s : set G} :
    is_add_subgroup s ↔ is_subgroup s :=
  sorry

theorem multiplicative.is_subgroup {A : Type u_3} [add_group A] (s : set A) [is_add_subgroup s] :
    is_subgroup s :=
  is_subgroup.mk is_add_subgroup.neg_mem

theorem multiplicative.is_subgroup_iff {A : Type u_3} [add_group A] {s : set A} :
    is_subgroup s ↔ is_add_subgroup s :=
  sorry

/-- The group structure on a subgroup coerced to a type. -/
def subtype.group {G : Type u_1} [group G] {s : set G} [is_subgroup s] : group ↥s :=
  group.mk monoid.mul sorry monoid.one sorry sorry
    (fun (x : ↥s) => { val := ↑x⁻¹, property := sorry })
    (fun (x y : ↥s) => { val := ↑x / ↑y, property := sorry }) sorry

/-- The commutative group structure on a commutative subgroup coerced to a type. -/
def subtype.comm_group {G : Type u_1} [comm_group G] {s : set G} [is_subgroup s] : comm_group ↥s :=
  comm_group.mk group.mul sorry group.one sorry sorry group.inv group.div sorry sorry

@[simp] theorem is_subgroup.coe_inv {G : Type u_1} [group G] {s : set G} [is_subgroup s] (a : ↥s) :
    ↑(a⁻¹) = (↑a⁻¹) :=
  rfl

@[simp] theorem is_subgroup.coe_gpow {G : Type u_1} [group G] {s : set G} [is_subgroup s] (a : ↥s)
    (n : ℤ) : ↑(a ^ n) = ↑a ^ n :=
  sorry

@[simp] theorem is_add_subgroup.gsmul_coe {A : Type u_3} [add_group A] {s : set A}
    [is_add_subgroup s] (a : ↥s) (n : ℤ) : ↑(n •ℤ a) = n •ℤ ↑a :=
  sorry

theorem is_add_subgroup.of_add_neg {G : Type u_1} [add_group G] (s : set G) (one_mem : 0 ∈ s)
    (div_mem : ∀ {a b : G}, a ∈ s → b ∈ s → a + -b ∈ s) : is_add_subgroup s :=
  sorry

theorem is_add_subgroup.of_sub {A : Type u_3} [add_group A] (s : set A) (zero_mem : 0 ∈ s)
    (sub_mem : ∀ {a b : A}, a ∈ s → b ∈ s → a - b ∈ s) : is_add_subgroup s :=
  sorry

protected instance is_add_subgroup.inter {G : Type u_1} [add_group G] (s₁ : set G) (s₂ : set G)
    [is_add_subgroup s₁] [is_add_subgroup s₂] : is_add_subgroup (s₁ ∩ s₂) :=
  is_add_subgroup.mk
    fun (x : G) (hx : x ∈ s₁ ∩ s₂) =>
      { left := is_add_subgroup.neg_mem (and.left hx),
        right := is_add_subgroup.neg_mem (and.right hx) }

protected instance is_add_subgroup.Inter {G : Type u_1} [add_group G] {ι : Sort u_2} (s : ι → set G)
    [h : ∀ (y : ι), is_add_subgroup (s y)] : is_add_subgroup (set.Inter s) :=
  is_add_subgroup.mk
    fun (x : G) (h_1 : x ∈ set.Inter s) =>
      iff.mpr set.mem_Inter fun (y : ι) => is_add_subgroup.neg_mem (iff.mp set.mem_Inter h_1 y)

theorem is_add_subgroup_Union_of_directed {G : Type u_1} [add_group G] {ι : Type u_2}
    [hι : Nonempty ι] (s : ι → set G) [∀ (i : ι), is_add_subgroup (s i)]
    (directed : ∀ (i j : ι), ∃ (k : ι), s i ⊆ s k ∧ s j ⊆ s k) :
    is_add_subgroup (set.Union fun (i : ι) => s i) :=
  sorry

def gpowers {G : Type u_1} [group G] (x : G) : set G := set.range (pow x)

def gmultiples {A : Type u_3} [add_group A] (x : A) : set A := set.range fun (i : ℤ) => i •ℤ x

protected instance gpowers.is_subgroup {G : Type u_1} [group G] (x : G) : is_subgroup (gpowers x) :=
  is_subgroup.mk fun (x₀ : G) (_x : x₀ ∈ gpowers x) => sorry

protected instance gmultiples.is_add_subgroup {A : Type u_3} [add_group A] (x : A) :
    is_add_subgroup (gmultiples x) :=
  iff.mp multiplicative.is_subgroup_iff (gpowers.is_subgroup x)

theorem is_subgroup.gpow_mem {G : Type u_1} [group G] {a : G} {s : set G} [is_subgroup s]
    (h : a ∈ s) {i : ℤ} : a ^ i ∈ s :=
  int.cases_on i (fun (i : ℕ) => idRhs (a ^ i ∈ s) (is_submonoid.pow_mem h))
    fun (i : ℕ) => idRhs (a ^ Nat.succ i⁻¹ ∈ s) (is_subgroup.inv_mem (is_submonoid.pow_mem h))

theorem is_add_subgroup.gsmul_mem {A : Type u_3} [add_group A] {a : A} {s : set A}
    [is_add_subgroup s] : a ∈ s → ∀ {i : ℤ}, i •ℤ a ∈ s :=
  is_subgroup.gpow_mem

theorem gpowers_subset {G : Type u_1} [group G] {a : G} {s : set G} [is_subgroup s] (h : a ∈ s) :
    gpowers a ⊆ s :=
  sorry

theorem gmultiples_subset {A : Type u_3} [add_group A] {a : A} {s : set A} [is_add_subgroup s]
    (h : a ∈ s) : gmultiples a ⊆ s :=
  gpowers_subset h

theorem mem_gpowers {G : Type u_1} [group G] {a : G} : a ∈ gpowers a := sorry

theorem mem_gmultiples {A : Type u_3} [add_group A] {a : A} : a ∈ gmultiples a := sorry

namespace is_subgroup

theorem inv_mem_iff {G : Type u_1} {a : G} [group G] (s : set G) [is_subgroup s] :
    a⁻¹ ∈ s ↔ a ∈ s :=
  sorry

theorem Mathlib.is_add_subgroup.add_mem_cancel_right {G : Type u_1} {a : G} {b : G} [add_group G]
    (s : set G) [is_add_subgroup s] (h : a ∈ s) : b + a ∈ s ↔ b ∈ s :=
  sorry

theorem Mathlib.is_add_subgroup.add_mem_cancel_left {G : Type u_1} {a : G} {b : G} [add_group G]
    (s : set G) [is_add_subgroup s] (h : a ∈ s) : a + b ∈ s ↔ b ∈ s :=
  sorry

end is_subgroup

class normal_add_subgroup {A : Type u_3} [add_group A] (s : set A) extends is_add_subgroup s where
  normal : ∀ (n : A), n ∈ s → ∀ (g : A), g + n + -g ∈ s

class normal_subgroup {G : Type u_1} [group G] (s : set G) extends is_subgroup s where
  normal : ∀ (n : G), n ∈ s → ∀ (g : G), g * n * (g⁻¹) ∈ s

theorem normal_add_subgroup_of_add_comm_group {G : Type u_1} [add_comm_group G] (s : set G)
    [hs : is_add_subgroup s] : normal_add_subgroup s :=
  sorry

theorem additive.normal_add_subgroup {G : Type u_1} [group G] (s : set G) [normal_subgroup s] :
    normal_add_subgroup s :=
  normal_add_subgroup.mk normal_subgroup.normal

theorem additive.normal_add_subgroup_iff {G : Type u_1} [group G] {s : set G} :
    normal_add_subgroup s ↔ normal_subgroup s :=
  sorry

theorem multiplicative.normal_subgroup {A : Type u_3} [add_group A] (s : set A)
    [normal_add_subgroup s] : normal_subgroup s :=
  normal_subgroup.mk normal_add_subgroup.normal

theorem multiplicative.normal_subgroup_iff {A : Type u_3} [add_group A] {s : set A} :
    normal_subgroup s ↔ normal_add_subgroup s :=
  sorry

namespace is_subgroup

-- Normal subgroup properties

theorem mem_norm_comm {G : Type u_1} [group G] {s : set G} [normal_subgroup s] {a : G} {b : G}
    (hab : a * b ∈ s) : b * a ∈ s :=
  sorry

theorem Mathlib.is_add_subgroup.mem_norm_comm_iff {G : Type u_1} [add_group G] {s : set G}
    [normal_add_subgroup s] {a : G} {b : G} : a + b ∈ s ↔ b + a ∈ s :=
  { mp := is_add_subgroup.mem_norm_comm, mpr := is_add_subgroup.mem_norm_comm }

/-- The trivial subgroup -/
def trivial (G : Type u_1) [group G] : set G := singleton 1

@[simp] theorem Mathlib.is_add_subgroup.mem_trivial {G : Type u_1} [add_group G] {g : G} :
    g ∈ is_add_subgroup.trivial G ↔ g = 0 :=
  set.mem_singleton_iff

protected instance Mathlib.is_add_subgroup.trivial_normal {G : Type u_1} [add_group G] :
    normal_add_subgroup (is_add_subgroup.trivial G) :=
  sorry

theorem Mathlib.is_add_subgroup.eq_trivial_iff {G : Type u_1} [add_group G] {s : set G}
    [is_add_subgroup s] : s = is_add_subgroup.trivial G ↔ ∀ (x : G), x ∈ s → x = 0 :=
  sorry

protected instance univ_subgroup {G : Type u_1} [group G] : normal_subgroup set.univ :=
  normal_subgroup.mk
    (eq.mpr
      (id
        (Eq.trans
          (forall_congr_eq
            fun (n : G) =>
              Eq.trans
                (imp_congr_eq
                  (propext ((fun {α : Type u_1} (x : α) => iff_true_intro (set.mem_univ x)) n))
                  (Eq.trans
                    (forall_congr_eq
                      fun (g : G) =>
                        propext
                          ((fun {α : Type u_1} (x : α) => iff_true_intro (set.mem_univ x))
                            (g * n * (g⁻¹))))
                    (propext (forall_const G))))
                (propext (forall_prop_of_true True.intro)))
          (propext (forall_const G))))
      trivial)

def Mathlib.is_add_subgroup.add_center (G : Type u_1) [add_group G] : set G :=
  set_of fun (z : G) => ∀ (g : G), g + z = z + g

theorem mem_center {G : Type u_1} [group G] {a : G} : a ∈ center G ↔ ∀ (g : G), g * a = a * g :=
  iff.rfl

protected instance center_normal {G : Type u_1} [group G] : normal_subgroup (center G) := sorry

def Mathlib.is_add_subgroup.add_normalizer {G : Type u_1} [add_group G] (s : set G) : set G :=
  set_of fun (g : G) => ∀ (n : G), n ∈ s ↔ g + n + -g ∈ s

protected instance Mathlib.is_add_subgroup.normalizer_is_add_subgroup {G : Type u_1} [add_group G]
    (s : set G) : is_add_subgroup (is_add_subgroup.add_normalizer s) :=
  sorry

theorem Mathlib.is_add_subgroup.subset_add_normalizer {G : Type u_1} [add_group G] (s : set G)
    [is_add_subgroup s] : s ⊆ is_add_subgroup.add_normalizer s :=
  sorry

/-- Every subgroup is a normal subgroup of its normalizer -/
protected instance Mathlib.is_add_subgroup.add_normal_in_add_normalizer {G : Type u_1} [add_group G]
    (s : set G) [is_add_subgroup s] : normal_add_subgroup (subtype.val ⁻¹' s) :=
  normal_add_subgroup.mk
    fun (a : ↥(is_add_subgroup.add_normalizer s)) (ha : a ∈ subtype.val ⁻¹' s)
      (_x : ↥(is_add_subgroup.add_normalizer s)) => sorry

end is_subgroup

-- Homomorphism subgroups

namespace is_group_hom

def ker {G : Type u_1} {H : Type u_2} [group H] (f : G → H) : set G := f ⁻¹' is_subgroup.trivial H

theorem Mathlib.is_add_group_hom.mem_ker {G : Type u_1} {H : Type u_2} [add_group H] (f : G → H)
    {x : G} : x ∈ is_add_group_hom.ker f ↔ f x = 0 :=
  is_add_subgroup.mem_trivial

theorem Mathlib.is_add_group_hom.zero_ker_neg {G : Type u_1} {H : Type u_2} [add_group G]
    [add_group H] (f : G → H) [is_add_group_hom f] {a : G} {b : G} (h : f (a + -b) = 0) :
    f a = f b :=
  sorry

theorem one_ker_inv' {G : Type u_1} {H : Type u_2} [group G] [group H] (f : G → H) [is_group_hom f]
    {a : G} {b : G} (h : f (a⁻¹ * b) = 1) : f a = f b :=
  sorry

theorem Mathlib.is_add_group_hom.neg_ker_zero {G : Type u_1} {H : Type u_2} [add_group G]
    [add_group H] (f : G → H) [is_add_group_hom f] {a : G} {b : G} (h : f a = f b) :
    f (a + -b) = 0 :=
  sorry

theorem inv_ker_one' {G : Type u_1} {H : Type u_2} [group G] [group H] (f : G → H) [is_group_hom f]
    {a : G} {b : G} (h : f a = f b) : f (a⁻¹ * b) = 1 :=
  sorry

theorem Mathlib.is_add_group_hom.zero_iff_ker_neg {G : Type u_1} {H : Type u_2} [add_group G]
    [add_group H] (f : G → H) [is_add_group_hom f] (a : G) (b : G) : f a = f b ↔ f (a + -b) = 0 :=
  { mp := is_add_group_hom.neg_ker_zero f, mpr := is_add_group_hom.zero_ker_neg f }

theorem one_iff_ker_inv' {G : Type u_1} {H : Type u_2} [group G] [group H] (f : G → H)
    [is_group_hom f] (a : G) (b : G) : f a = f b ↔ f (a⁻¹ * b) = 1 :=
  { mp := inv_ker_one' f, mpr := one_ker_inv' f }

theorem inv_iff_ker {G : Type u_1} {H : Type u_2} [group G] [group H] (f : G → H)
    [w : is_group_hom f] (a : G) (b : G) : f a = f b ↔ a * (b⁻¹) ∈ ker f :=
  eq.mpr (id (Eq._oldrec (Eq.refl (f a = f b ↔ a * (b⁻¹) ∈ ker f)) (propext (mem_ker f))))
    (one_iff_ker_inv f a b)

theorem inv_iff_ker' {G : Type u_1} {H : Type u_2} [group G] [group H] (f : G → H)
    [w : is_group_hom f] (a : G) (b : G) : f a = f b ↔ a⁻¹ * b ∈ ker f :=
  eq.mpr (id (Eq._oldrec (Eq.refl (f a = f b ↔ a⁻¹ * b ∈ ker f)) (propext (mem_ker f))))
    (one_iff_ker_inv' f a b)

protected instance Mathlib.is_add_group_hom.image_add_subgroup {G : Type u_1} {H : Type u_2}
    [add_group G] [add_group H] (f : G → H) [is_add_group_hom f] (s : set G) [is_add_subgroup s] :
    is_add_subgroup (f '' s) :=
  is_add_subgroup.mk fun (a : H) (_x : a ∈ f '' s) => sorry

protected instance range_subgroup {G : Type u_1} {H : Type u_2} [group G] [group H] (f : G → H)
    [is_group_hom f] : is_subgroup (set.range f) :=
  set.image_univ ▸ is_group_hom.image_subgroup f set.univ

protected instance preimage {G : Type u_1} {H : Type u_2} [group G] [group H] (f : G → H)
    [is_group_hom f] (s : set H) [is_subgroup s] : is_subgroup (f ⁻¹' s) :=
  is_subgroup.mk
    (eq.mpr
      (id
        (Eq.trans
          (forall_congr_eq
            fun (a : G) =>
              Eq.trans
                (imp_congr_ctx_eq (propext set.mem_preimage)
                  fun (_h : f a ∈ s) =>
                    Eq.trans
                      (Eq.trans (propext set.mem_preimage)
                        ((fun (ᾰ ᾰ_1 : H) (e_2 : ᾰ = ᾰ_1) (ᾰ_2 ᾰ_3 : set H) (e_3 : ᾰ_2 = ᾰ_3) =>
                            congr (congr_arg has_mem.mem e_2) e_3)
                          (f (a⁻¹)) (f a⁻¹) (map_inv f a) s s (Eq.refl s)))
                      (propext
                        ((fun [c : is_subgroup s] {a : H} (ᾰ : a ∈ s) =>
                            iff_true_intro (is_subgroup.inv_mem ᾰ))
                          (iff.mpr (iff_true_intro _h) True.intro))))
                (propext forall_true_iff))
          (propext (forall_const G))))
      trivial)

protected instance preimage_normal {G : Type u_1} {H : Type u_2} [group G] [group H] (f : G → H)
    [is_group_hom f] (s : set H) [normal_subgroup s] : normal_subgroup (f ⁻¹' s) :=
  sorry

protected instance normal_subgroup_ker {G : Type u_1} {H : Type u_2} [group G] [group H] (f : G → H)
    [is_group_hom f] : normal_subgroup (ker f) :=
  is_group_hom.preimage_normal f (is_subgroup.trivial H)

theorem Mathlib.is_add_group_hom.injective_of_trivial_ker {G : Type u_1} {H : Type u_2}
    [add_group G] [add_group H] (f : G → H) [is_add_group_hom f]
    (h : is_add_group_hom.ker f = is_add_subgroup.trivial G) : function.injective f :=
  sorry

theorem trivial_ker_of_injective {G : Type u_1} {H : Type u_2} [group G] [group H] (f : G → H)
    [is_group_hom f] (h : function.injective f) : ker f = is_subgroup.trivial G :=
  sorry

theorem Mathlib.is_add_group_hom.injective_iff_trivial_ker {G : Type u_1} {H : Type u_2}
    [add_group G] [add_group H] (f : G → H) [is_add_group_hom f] :
    function.injective f ↔ is_add_group_hom.ker f = is_add_subgroup.trivial G :=
  { mp := is_add_group_hom.trivial_ker_of_injective f,
    mpr := is_add_group_hom.injective_of_trivial_ker f }

theorem Mathlib.is_add_group_hom.trivial_ker_iff_eq_zero {G : Type u_1} {H : Type u_2} [add_group G]
    [add_group H] (f : G → H) [is_add_group_hom f] :
    is_add_group_hom.ker f = is_add_subgroup.trivial G ↔ ∀ (x : G), f x = 0 → x = 0 :=
  sorry

end is_group_hom

protected instance subtype_val.is_add_group_hom {G : Type u_1} [add_group G] {s : set G}
    [is_add_subgroup s] : is_add_group_hom subtype.val :=
  is_add_group_hom.mk

protected instance coe.is_add_group_hom {G : Type u_1} [add_group G] {s : set G}
    [is_add_subgroup s] : is_add_group_hom coe :=
  is_add_group_hom.mk

protected instance subtype_mk.is_group_hom {G : Type u_1} {H : Type u_2} [group G] [group H]
    {s : set G} [is_subgroup s] (f : H → G) [is_group_hom f] (h : ∀ (x : H), f x ∈ s) :
    is_group_hom fun (x : H) => { val := f x, property := h x } :=
  is_group_hom.mk

protected instance set_inclusion.is_group_hom {G : Type u_1} [group G] {s : set G} {t : set G}
    [is_subgroup s] [is_subgroup t] (h : s ⊆ t) : is_group_hom (set.inclusion h) :=
  subtype_mk.is_group_hom (fun (x : ↥s) => ↑x) fun (x : ↥s) => set.inclusion._proof_1 h x

/-- `subtype.val : set.range f → H` as a monoid homomorphism, when `f` is a monoid homomorphism. -/
def monoid_hom.range_subtype_val {G : Type u_1} {H : Type u_2} [monoid G] [monoid H] (f : G →* H) :
    ↥(set.range ⇑f) →* H :=
  monoid_hom.of subtype.val

/-- `set.range_factorization f : G → set.range f` as a monoid homomorphism, when `f` is a monoid
homomorphism. -/
def add_monoid_hom.range_factorization {G : Type u_1} {H : Type u_2} [add_monoid G] [add_monoid H]
    (f : G →+ H) : G →+ ↥(set.range ⇑f) :=
  add_monoid_hom.mk (set.range_factorization ⇑f) sorry sorry

namespace add_group

inductive in_closure {A : Type u_3} [add_group A] (s : set A) : A → Prop where
| basic : ∀ {a : A}, a ∈ s → in_closure s a
| zero : in_closure s 0
| neg : ∀ {a : A}, in_closure s a → in_closure s (-a)
| add : ∀ {a b : A}, in_closure s a → in_closure s b → in_closure s (a + b)

end add_group

namespace group

inductive in_closure {G : Type u_1} [group G] (s : set G) : G → Prop where
| basic : ∀ {a : G}, a ∈ s → in_closure s a
| one : in_closure s 1
| inv : ∀ {a : G}, in_closure s a → in_closure s (a⁻¹)
| mul : ∀ {a b : G}, in_closure s a → in_closure s b → in_closure s (a * b)

/-- `group.closure s` is the subgroup closed over `s`, i.e. the smallest subgroup containg s. -/
def Mathlib.add_group.closure {G : Type u_1} [add_group G] (s : set G) : set G :=
  set_of fun (a : G) => add_group.in_closure s a

theorem Mathlib.add_group.mem_closure {G : Type u_1} [add_group G] {s : set G} {a : G} :
    a ∈ s → a ∈ add_group.closure s :=
  add_group.in_closure.basic

protected instance closure.is_subgroup {G : Type u_1} [group G] (s : set G) :
    is_subgroup (closure s) :=
  is_subgroup.mk fun (a : G) => in_closure.inv

theorem Mathlib.add_group.subset_closure {G : Type u_1} [add_group G] {s : set G} :
    s ⊆ add_group.closure s :=
  fun (a : G) => add_group.mem_closure

theorem Mathlib.add_group.closure_subset {G : Type u_1} [add_group G] {s : set G} {t : set G}
    [is_add_subgroup t] (h : s ⊆ t) : add_group.closure s ⊆ t :=
  sorry

theorem Mathlib.add_group.closure_subset_iff {G : Type u_1} [add_group G] (s : set G) (t : set G)
    [is_add_subgroup t] : add_group.closure s ⊆ t ↔ s ⊆ t :=
  { mp := fun (h : add_group.closure s ⊆ t) (b : G) (ha : b ∈ s) => h (add_group.mem_closure ha),
    mpr := fun (h : s ⊆ t) (b : G) (ha : b ∈ add_group.closure s) => add_group.closure_subset h ha }

theorem Mathlib.add_group.closure_mono {G : Type u_1} [add_group G] {s : set G} {t : set G}
    (h : s ⊆ t) : add_group.closure s ⊆ add_group.closure t :=
  add_group.closure_subset (set.subset.trans h add_group.subset_closure)

@[simp] theorem closure_subgroup {G : Type u_1} [group G] (s : set G) [is_subgroup s] :
    closure s = s :=
  set.subset.antisymm (closure_subset (set.subset.refl s)) subset_closure

theorem Mathlib.add_group.exists_list_of_mem_closure {G : Type u_1} [add_group G] {s : set G}
    {a : G} (h : a ∈ add_group.closure s) :
    ∃ (l : List G), (∀ (x : G), x ∈ l → x ∈ s ∨ -x ∈ s) ∧ list.sum l = a :=
  sorry

theorem Mathlib.add_group.image_closure {G : Type u_1} {H : Type u_2} [add_group G] [add_group H]
    (f : G → H) [is_add_group_hom f] (s : set G) :
    f '' add_group.closure s = add_group.closure (f '' s) :=
  sorry

theorem Mathlib.add_group.mclosure_subset {G : Type u_1} [add_group G] {s : set G} :
    add_monoid.closure s ⊆ add_group.closure s :=
  add_monoid.closure_subset add_group.subset_closure

theorem Mathlib.add_group.mclosure_neg_subset {G : Type u_1} [add_group G] {s : set G} :
    add_monoid.closure (Neg.neg ⁻¹' s) ⊆ add_group.closure s :=
  add_monoid.closure_subset
    fun (x : G) (hx : x ∈ Neg.neg ⁻¹' s) =>
      neg_neg x ▸ is_add_subgroup.neg_mem (add_group.subset_closure hx)

theorem Mathlib.add_group.closure_eq_mclosure {G : Type u_1} [add_group G] {s : set G} :
    add_group.closure s = add_monoid.closure (s ∪ Neg.neg ⁻¹' s) :=
  sorry

theorem Mathlib.add_group.mem_closure_union_iff {G : Type u_1} [add_comm_group G] {s : set G}
    {t : set G} {x : G} :
    x ∈ add_group.closure (s ∪ t) ↔
        ∃ (y : G),
          ∃ (H : y ∈ add_group.closure s), ∃ (z : G), ∃ (H : z ∈ add_group.closure t), y + z = x :=
  sorry

theorem gpowers_eq_closure {G : Type u_1} [group G] {a : G} : gpowers a = closure (singleton a) :=
  sorry

end group

namespace is_subgroup

theorem Mathlib.is_add_subgroup.trivial_eq_closure {G : Type u_1} [add_group G] :
    is_add_subgroup.trivial G = add_group.closure ∅ :=
  sorry

end is_subgroup

/-The normal closure of a set s is the subgroup closure of all the conjugates of
elements of s. It is the smallest normal subgroup containing s. -/

namespace group

theorem conjugates_subset {G : Type u_1} [group G] {t : set G} [normal_subgroup t] {a : G}
    (h : a ∈ t) : conjugates a ⊆ t :=
  sorry

theorem conjugates_of_set_subset' {G : Type u_1} [group G] {s : set G} {t : set G}
    [normal_subgroup t] (h : s ⊆ t) : conjugates_of_set s ⊆ t :=
  set.bUnion_subset fun (x : G) (H : x ∈ s) => conjugates_subset (h H)

/-- The normal closure of a set s is the subgroup closure of all the conjugates of
elements of s. It is the smallest normal subgroup containing s. -/
def normal_closure {G : Type u_1} [group G] (s : set G) : set G := closure (conjugates_of_set s)

theorem conjugates_of_set_subset_normal_closure {G : Type u_1} {s : set G} [group G] :
    conjugates_of_set s ⊆ normal_closure s :=
  subset_closure

theorem subset_normal_closure {G : Type u_1} {s : set G} [group G] : s ⊆ normal_closure s :=
  set.subset.trans subset_conjugates_of_set conjugates_of_set_subset_normal_closure

/-- The normal closure of a set is a subgroup. -/
protected instance normal_closure.is_subgroup {G : Type u_1} [group G] (s : set G) :
    is_subgroup (normal_closure s) :=
  closure.is_subgroup (conjugates_of_set s)

/-- The normal closure of s is a normal subgroup. -/
protected instance normal_closure.is_normal {G : Type u_1} {s : set G} [group G] :
    normal_subgroup (normal_closure s) :=
  sorry

/-- The normal closure of s is the smallest normal subgroup containing s. -/
theorem normal_closure_subset {G : Type u_1} [group G] {s : set G} {t : set G} [normal_subgroup t]
    (h : s ⊆ t) : normal_closure s ⊆ t :=
  sorry

theorem normal_closure_subset_iff {G : Type u_1} [group G] {s : set G} {t : set G}
    [normal_subgroup t] : s ⊆ t ↔ normal_closure s ⊆ t :=
  { mp := normal_closure_subset, mpr := set.subset.trans subset_normal_closure }

theorem normal_closure_mono {G : Type u_1} [group G] {s : set G} {t : set G} :
    s ⊆ t → normal_closure s ⊆ normal_closure t :=
  fun (h : s ⊆ t) => normal_closure_subset (set.subset.trans h subset_normal_closure)

end group

class simple_group (G : Type u_4) [group G] where
  simple : ∀ (N : set G) [_inst_1_1 : normal_subgroup N], N = is_subgroup.trivial G ∨ N = set.univ

class simple_add_group (A : Type u_4) [add_group A] where
  simple :
    ∀ (N : set A) [_inst_1_1 : normal_add_subgroup N], N = is_add_subgroup.trivial A ∨ N = set.univ

theorem additive.simple_add_group_iff {G : Type u_1} [group G] :
    simple_add_group (additive G) ↔ simple_group G :=
  sorry

protected instance additive.simple_add_group {G : Type u_1} [group G] [simple_group G] :
    simple_add_group (additive G) :=
  iff.mpr additive.simple_add_group_iff _inst_2

theorem multiplicative.simple_group_iff {A : Type u_3} [add_group A] :
    simple_group (multiplicative A) ↔ simple_add_group A :=
  sorry

protected instance multiplicative.simple_group {A : Type u_3} [add_group A] [simple_add_group A] :
    simple_group (multiplicative A) :=
  iff.mpr multiplicative.simple_group_iff _inst_2

theorem simple_add_group_of_surjective {G : Type u_1} {H : Type u_2} [add_group G] [add_group H]
    [simple_add_group G] (f : G → H) [is_add_group_hom f] (hf : function.surjective f) :
    simple_add_group H :=
  sorry

/-- Create a bundled subgroup from a set `s` and `[is_subroup s]`. -/
def subgroup.of {G : Type u_1} [group G] (s : set G) [h : is_subgroup s] : subgroup G :=
  subgroup.mk s sorry sorry is_subgroup.inv_mem

protected instance subgroup.is_subgroup {G : Type u_1} [group G] (K : subgroup G) :
    is_subgroup ↑K :=
  is_subgroup.mk (subgroup.inv_mem' K)

protected instance subgroup.of_normal {G : Type u_1} [group G] (s : set G) [h : is_subgroup s]
    [n : normal_subgroup s] : subgroup.normal (subgroup.of s) :=
  subgroup.normal.mk normal_subgroup.normal

end Mathlib


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

import data.list.chain
import data.nat.lattice
import data.enat.basic
import order.grade
import tactic.tfae

/-!

# Maximal length of chains

This file contains lemmas to work with the maximal length of strictly descending finite
sequences (chains) in a partially ordered set.

## Main definition

- `set.subchain`: The set of strictly ascending lists of `α` contained in a `set α`.
- `set.chain_height`: The maximal length of a strictly ascending sequence in a poset.
This is defined as the maximum of the lengths of `set.subchain`s, valued in `ℕ∞`.

## Main results

- `set.exists_chain_of_le_chain_height`: For each `n : ℕ` such that `n ≤ s.chain_height`, there
  exists `s.subchain` of length `n`.
- `set.chain_height_le_of_subset`: If `s ⊆ t` then `s.chain_height ≤ t.chain_height`.
- `set.chain_height_image`: If `f` is an order embedding, then
  `(f '' s).chain_height = s.chain_height`.
- `set.chain_height_insert_of_forall_lt`: If `∀ y ∈ s, y < x`, then
  `(insert x s).chain_height = s.chain_height + 1`.
- `set.chain_height_insert_of_lt_forall`: If `∀ y ∈ s, x < y`, then
  `(insert x s).chain_height = s.chain_height + 1`.
- `set.chain_height_union_eq`: If `∀ x ∈ s, ∀ y ∈ t, s ≤ t`, then
  `(s ∪ t).chain_height = s.chain_height + t.chain_height`.
- `set.well_founded_gt_of_chain_height_ne_top`:
  If `s` has finite height, then `>` is well-founded on `s`.
- `set.well_founded_lt_of_chain_height_ne_top`:
  If `s` has finite height, then `<` is well-founded on `s`.

-/

universes u v

open list

namespace set

section

variables {α : Type u} (s : set α) [has_lt α]

/-- The set of strictly ascending lists of `α` contained in a `set α`. -/
def subchain : set (list α) :=
{ l | list.chain' (<) l ∧ ∀ i ∈ l, i ∈ s }

lemma nil_mem_subchain : [] ∈ s.subchain :=
⟨trivial, λ x hx, hx.elim⟩

lemma cons_mem_subchain_iff {s : set α} {x : α} {xs : list α} :
  x :: xs ∈ s.subchain ↔ x ∈ s ∧ xs ∈ s.subchain ∧ (∀ y ∈ xs.head', x < y) :=
begin
  split,
  { intro h,
    exact ⟨h.2 _ (or.inl rfl), ⟨(chain'_cons'.mp h.1).2, λ i hi, h.2 _ (or.inr hi)⟩,
      (chain'_cons'.mp h.1).1⟩ },
  { rintro ⟨h₁, h₂, h₃⟩,
    split,
    { rw chain'_cons', exact ⟨h₃, h₂.1⟩ },
    { rintros i (rfl|hi), exacts [h₁, h₂.2 _ hi] } }
end

instance : nonempty s.subchain :=
⟨⟨[], s.nil_mem_subchain⟩⟩

/-- The maximal length of a strictly ascending sequence in a poset. -/
noncomputable
def chain_height : ℕ∞ :=
⨆ l ∈ s.subchain, list.length l

lemma chain_height_eq_supr_subtype : s.chain_height = ⨆ l : s.subchain, l.1.length :=
begin
  rw supr_subtype,
  refl,
end

lemma exists_chain_of_le_length {l : list α} (hl : chain' (<) l) {n : ℕ}
  (hn : n ≤ l.length) : ∃ l' : list α, chain' (<) l' ∧ l' ⊆ l ∧ l'.length = n  :=
begin
  cases n,
  { exact ⟨[], trivial, λ _ h, h.elim, rfl⟩ },
  cases e : l.drop n,
  { exact (nat.lt_le_antisymm (nat.lt_iff_add_one_le.mpr hn) (drop_eq_nil_iff_le.mp e)).elim },
  rw [← l.take_append_drop n, e] at hl,
  refine ⟨_, (chain'_split.mp hl).1, _, _⟩,
  { simp only [list.nil_subset, and_true, list.append_subset_iff, list.cons_subset],
    exact ⟨list.take_subset _ _, list.drop_subset n _ $ by { rw e, exact or.inl rfl }⟩ },
  { simpa [nat.succ_eq_add_one] using n.le_succ.trans hn }
end

lemma exists_chain_of_le_chain_height {n : ℕ} (hn : ↑n ≤ s.chain_height) :
  ∃ l ∈ s.subchain, list.length l = n :=
begin
  cases (le_top : s.chain_height ≤ ⊤).eq_or_lt with ha ha; rw chain_height_eq_supr_subtype at ha,
  { obtain ⟨_, ⟨⟨l, h₁, h₂⟩, rfl⟩, h₃⟩ :=
      not_bdd_above_iff'.mp ((with_top.supr_coe_eq_top _).mp ha) n,
    obtain ⟨l', h₁', h₂', h₃'⟩ := exists_chain_of_le_length h₁ (le_of_not_ge h₃),
    exact ⟨l', ⟨h₁', λ x h, h₂ _ (h₂' h)⟩, h₃'⟩ },
  { rw with_top.supr_coe_lt_top at ha,
    obtain ⟨⟨l, h₁, h₂⟩, e : l.length = _⟩ := nat.Sup_mem (set.range_nonempty _) ha,
    obtain ⟨l', h₁', h₂', h₃'⟩ := exists_chain_of_le_length h₁ _,
    exact ⟨l', ⟨h₁', λ x h, h₂ _ (h₂' h)⟩, h₃'⟩,
    rwa [e, ← with_top.coe_le_coe, Sup_range, with_top.coe_supr, ← chain_height_eq_supr_subtype],
    exact ha }
end

variables {s}

lemma le_chain_height_iff {n : ℕ} :
  ↑n ≤ s.chain_height ↔ ∃ l ∈ s.subchain, list.length l = n :=
begin
  refine ⟨s.exists_chain_of_le_chain_height, _⟩,
  rintros ⟨l, h, rfl⟩,
  refine eq.trans_le _ (le_supr₂ l h),
  refl
end

lemma length_le_chain_height_of_mem_subchain (l ∈ s.subchain) :
  ↑l.length ≤ s.chain_height :=
le_chain_height_iff.mpr ⟨l, H, rfl⟩

@[simp]
lemma one_le_chain_height_iff : 1 ≤ s.chain_height ↔ s.nonempty :=
begin
  change ((1 : ℕ) : enat) ≤ _ ↔ _,
  rw set.le_chain_height_iff,
  split,
  { rintro ⟨_|⟨x, xs⟩, ⟨h₁, h₂⟩, h₃⟩,
    { cases h₃ },
    { exact ⟨x, h₂ _ (or.inl rfl)⟩ } },
  { rintro ⟨x, hx⟩,
    exact ⟨[x], ⟨chain.nil, λ y h, (list.mem_singleton.mp h).symm ▸ hx⟩, rfl⟩ }
end

@[simp]
lemma chain_height_eq_zero_iff : s.chain_height = 0 ↔ s = ∅ :=
begin
  rw [← not_iff_not, ← ne.def, ← bot_eq_zero, ← bot_lt_iff_ne_bot, bot_eq_zero,
    ← enat.one_le_iff_pos, one_le_chain_height_iff, ← ne_empty_iff_nonempty],
end

@[simp]
lemma chain_length_empty : (∅ : set α).chain_height = 0 :=
chain_height_eq_zero_iff.mpr rfl

@[simp]
lemma chain_height_eq_zero_of_empty [is_empty α] : s.chain_height = 0 :=
chain_height_eq_zero_iff.mpr (subsingleton.elim _ _)

variables {β : Type*} [has_lt β]

lemma chain_height_le_chain_height_tfae (s : set α) (t : set β) :
  tfae [s.chain_height ≤ t.chain_height,
    ∀ l ∈ s.subchain, ∃ l' ∈ t.subchain, list.length l = list.length l',
    ∀ l ∈ s.subchain, ∃ l' ∈ t.subchain, list.length l ≤ list.length l'] :=
begin
  tfae_have : 1 → 2,
  { intros e l hl,
    simp_rw @eq_comm _ l.length,
    have := length_le_chain_height_of_mem_subchain l hl,
    exact le_chain_height_iff.mp (this.trans e) },
  tfae_have : 2 → 3,
  { exact forall₂_imp (λ l hl ⟨l', h₁, h₂⟩, ⟨l', h₁, h₂.le⟩) },
  tfae_have : 3 → 1,
  { intros H,
    refine supr₂_le _,
    intros l hl,
    obtain ⟨l', h₁, h₂⟩ := H l hl,
    exact (with_top.coe_le_coe.mpr h₂).trans (length_le_chain_height_of_mem_subchain l' h₁) },
  tfae_finish
end

lemma chain_height_le_chain_height_iff {t : set β} :
  s.chain_height ≤ t.chain_height ↔
    ∀ l ∈ s.subchain, ∃ l' ∈ t.subchain, list.length l = list.length l' :=
(chain_height_le_chain_height_tfae s t).out 0 1

lemma chain_height_le_chain_height_iff_le {t : set β} :
  s.chain_height ≤ t.chain_height ↔
    ∀ l ∈ s.subchain, ∃ l' ∈ t.subchain, list.length l ≤ list.length l' :=
(chain_height_le_chain_height_tfae s t).out 0 2

lemma chain_height_add_le_chain_height_add (s : set α) (t : set β) (n m : ℕ) :
  s.chain_height + n ≤ t.chain_height + m ↔
    ∀ l ∈ s.subchain, ∃ l' ∈ t.subchain, list.length l + n ≤ list.length l' + m :=
begin
  split,
  { intros e l hl,
    cases le_or_gt m (l.length + n),
    swap, { refine ⟨[], set.nil_mem_subchain _, h.lt.le.trans_eq (zero_add _).symm⟩ },
    have : ↑(l.length + n - m) ≤ t.chain_height,
    { apply with_top.le_of_add_le_add_right (with_top.some_lt_none m).ne,
      rw [with_top.some_eq_coe, ← with_top.coe_add, tsub_add_cancel_of_le h, with_top.coe_add],
      exact (add_le_add (length_le_chain_height_of_mem_subchain l hl) rfl.le).trans e },
    obtain ⟨l', H, e⟩ := le_chain_height_iff.mp this,
    exact ⟨l', H, by rw [e, tsub_add_cancel_of_le h]⟩ },
  { intro H,
    have : ↑n ≤ t.chain_height + ↑m,
    { obtain ⟨l₀, H₀, e₀⟩ := H [] s.nil_mem_subchain,
      have := length_le_chain_height_of_mem_subchain l₀ H₀,
      calc (n : enat) = (nil : list α).length + n      : (zero_add _).symm
                        ... ≤ l₀.length + m       : with_top.coe_le_coe.mpr e₀
                        ... ≤ t.chain_height + ↑m : add_le_add this rfl.le },
    rw ← tsub_add_cancel_of_le this,
    refine add_le_add _ rfl.le,
    apply supr₂_le _,
    intros l hl,
    obtain ⟨l', H', e⟩ := H l hl,
    apply with_top.le_of_add_le_add_right (with_top.some_lt_none n).ne,
    rw [with_top.some_eq_coe, tsub_add_cancel_of_le this],
    refine (with_top.coe_le_coe.mpr e).trans _,
    rw with_top.coe_add,
    exact add_le_add (length_le_chain_height_of_mem_subchain l' H') rfl.le },
end

lemma chain_height_le_of_subset {t : set α} (e : s ⊆ t) : s.chain_height ≤ t.chain_height :=
begin
  rw chain_height_le_chain_height_iff,
  intros l hl,
  exact ⟨l, ⟨hl.1, λ i hi, e (hl.2 i hi)⟩, rfl⟩
end

lemma chain_height_image
  (f : α → β) (hf : ∀ {x y}, x < y ↔ f x < f y) (s : set α) :
  (f '' s).chain_height = s.chain_height :=
begin
  apply le_antisymm; rw chain_height_le_chain_height_iff,
  { suffices : ∀ l ∈ (f '' s).subchain, ∃ l' ∈ s.subchain, list.map f l' = l,
    { intros l hl, obtain ⟨l', h₁, rfl⟩ := this l hl, exact ⟨l', h₁, list.length_map _ _⟩ },
    intro l,
    induction l with x xs hx,
    { exact λ _, ⟨nil, ⟨trivial, λ _ h, h.elim⟩, rfl⟩ },
    { intros h,
      rw cons_mem_subchain_iff at h,
      obtain ⟨⟨x, hx', rfl⟩, h₁, h₂⟩ := h,
      obtain ⟨l', h₃, rfl⟩ := hx h₁,
      refine ⟨x :: l', set.cons_mem_subchain_iff.mpr ⟨hx', h₃, _⟩, rfl⟩,
      cases l', { simp }, { simpa [← hf] using h₂ } } },
  { intros l hl,
    refine ⟨l.map f, ⟨_, _⟩, _⟩,
    { simp_rw [chain'_map, ← hf], exact hl.1 },
    { intros _ e, obtain ⟨a, ha, rfl⟩ := mem_map.mp e, exact set.mem_image_of_mem _ (hl.2 _ ha) },
    { rw length_map } },
end

end

section

variables {α : Type u} (s : set α) [preorder α]

lemma chain_height_order_dual (t : set αᵒᵈ) (e : s = t) : s.chain_height = t.chain_height :=
begin
  subst e,
  apply le_antisymm,
  all_goals
  { rw chain_height_le_chain_height_iff,
    rintros l ⟨h₁, h₂⟩,
    exact ⟨l.reverse, ⟨chain'_reverse.mpr h₁,
      λ i h, h₂ i (list.mem_reverse.mp h)⟩, (list.length_reverse _).symm⟩ },
end

lemma chain_height_eq_supr_Ici :
  s.chain_height = ⨆ i ∈ s, set.chain_height (s ∩ set.Ici i) :=
begin
  apply le_antisymm,
  { refine supr₂_le _,
    rintros (_|⟨x, xs⟩) h,
    { exact zero_le _ },
    { apply le_trans _ (le_supr₂ x (cons_mem_subchain_iff.mp h).1),
      apply length_le_chain_height_of_mem_subchain,
      refine ⟨h.1, λ i hi, ⟨h.2 i hi, _⟩⟩,
      cases hi, { exact hi.symm.le },
      cases chain'_iff_pairwise.mp h.1 with _ _ h',
      exact (h' _ hi).le } },
  { exact supr₂_le (λ i hi, chain_height_le_of_subset (set.inter_subset_left _ _)) }
end

lemma chain_height_eq_supr_Iic :
  s.chain_height = ⨆ i ∈ s, set.chain_height (s ∩ set.Iic i) :=
begin
  rw [chain_height_order_dual s s rfl, chain_height_eq_supr_Ici],
  congr, ext1, congr, ext1,
  apply chain_height_order_dual,
  refl,
end

lemma chain_height_insert_of_lt_forall (x : α) (hx : ∀ a ∈ s, x < a) :
  (insert x s).chain_height = s.chain_height + 1 :=
begin
  rw ← add_zero (insert x s).chain_height,
  change (insert x s).chain_height + (0 : ℕ) = s.chain_height + (1 : ℕ),
  apply le_antisymm; rw chain_height_add_le_chain_height_add,
  { rintro (_|⟨y, ys⟩) h,
    { exact ⟨[], nil_mem_subchain _, zero_le _⟩ },
    { have h' := cons_mem_subchain_iff.mp h,
      refine ⟨ys, ⟨h'.2.1.1, λ i hi, _⟩, by simp⟩,
      apply (h'.2.1.2 i hi).resolve_left,
      rintro rfl,
      cases chain'_iff_pairwise.mp h.1 with _ _ hy,
      cases h'.1 with h' h',
      exacts [(hy _ hi).ne h', not_le_of_gt (hy _ hi) (hx _ h').le] } },
  { intros l hl,
    refine ⟨x :: l, ⟨_, _⟩, by simp⟩,
    { rw chain'_cons', exact ⟨λ y hy, hx _ (hl.2 _ (list.mem_of_mem_head' hy)), hl.1⟩ },
    { rintro x (rfl|hx), exacts [or.inl (set.mem_singleton x), or.inr (hl.2 x hx)] } }
end

lemma chain_height_insert_of_forall_lt (x : α) (hx : ∀ a ∈ s, a < x) :
  (insert x s).chain_height = s.chain_height + 1 :=
begin
  rw [chain_height_order_dual s s rfl, ← chain_height_insert_of_lt_forall],
  { apply chain_height_order_dual, refl },
  { exact hx },
end

lemma chain_height_union_le (s t : set α) :
  (s ∪ t).chain_height ≤ s.chain_height + t.chain_height :=
begin
  classical,
  refine supr₂_le _,
  intros l hl,
  let l₁ := l.filter (∈ s), let l₂ := l.filter (∈ t),
  have hl₁ : ↑l₁.length ≤ s.chain_height,
  { apply set.length_le_chain_height_of_mem_subchain,
    exact ⟨hl.1.sublist (list.filter_sublist _), λ i h, (list.of_mem_filter h : _)⟩ },
  have hl₂ : ↑l₂.length ≤ t.chain_height,
  { apply set.length_le_chain_height_of_mem_subchain,
    exact ⟨hl.1.sublist (list.filter_sublist _), λ i h, (list.of_mem_filter h : _)⟩ },
  refine le_trans _ (add_le_add hl₁ hl₂),
  simp_rw [← with_top.coe_add, with_top.coe_le_coe, ← multiset.coe_card,
    ← multiset.card_add, ← multiset.coe_filter],
  rw [multiset.filter_add_filter, multiset.filter_eq_self.mpr, multiset.card_add],
  exacts [le_add_right rfl.le, hl.2]
end

lemma chain_height_union_eq (s t : set α) (H : ∀ (a ∈ s) (b ∈ t), a < b) :
  (s ∪ t).chain_height = s.chain_height + t.chain_height :=
begin
  cases h : t.chain_height,
  { rw [with_top.none_eq_top, add_top, eq_top_iff, ← with_top.none_eq_top, ← h],
    exact set.chain_height_le_of_subset (set.subset_union_right _ _) },
  apply le_antisymm,
  { rw ← h, exact chain_height_union_le s t },
  rw [with_top.some_eq_coe, ← add_zero (s ∪ t).chain_height, ← with_top.coe_zero,
    chain_height_add_le_chain_height_add],
  intros l hl,
  obtain ⟨l', hl', rfl⟩ := exists_chain_of_le_chain_height t h.symm.le,
  refine ⟨l ++ l', ⟨chain'.append hl.1 hl'.1 _, _⟩, by simp⟩,
  { intros x hx y hy, exact H x (hl.2 _ $ mem_of_mem_last' hx) y (hl'.2 _ $ mem_of_mem_head' hy) },
  { intros i hi, rw mem_append at hi, cases hi, exacts [or.inl (hl.2 _ hi), or.inr (hl'.2 _ hi)] }
end

lemma well_founded_gt_of_chain_height_ne_top {α : Type*} [partial_order α]
  (s : set α) (hs : s.chain_height ≠ ⊤) :
  well_founded_gt s :=
begin
  rw [well_founded_gt, is_well_founded_iff, well_founded.well_founded_iff_has_max'],
  intros t ht,
    have : ∀ x : α, (set.Iio x ∩ s).chain_height ≠ ⊤,
    { intro p, rw [← lt_top_iff_ne_top] at hs ⊢,
      exact (set.chain_height_le_of_subset $ set.inter_subset_right _ _).trans_lt hs },
    have bdd : bdd_above ((λ x : s, (set.Iio ↑x ∩ s).chain_height.untop $ this x) '' t),
    { use s.chain_height.untop hs,
      rintros _ ⟨p, hp, rfl⟩,
      rw [← with_top.coe_le_coe, with_top.coe_untop, with_top.coe_untop],
      exact (set.chain_height_le_of_subset $ set.inter_subset_right _ _) },
    obtain ⟨q, hq, hq' : with_top.untop _ _ = _⟩ := nat.Sup_mem (ht.image _) bdd,
    refine ⟨q, hq, λ p hp e, _⟩,
    symmetry,
    by_contra,
    apply @not_lt_of_le _ _ (with_top.untop _ (this p)) (with_top.untop _ (this q)),
    { rw [hq', ← with_top.coe_le_coe, with_top.coe_Sup bdd, with_top.coe_untop],
      refine le_trans _ (le_supr₂ _ ⟨p, hp, rfl⟩),
      exact (with_top.coe_untop _ _).symm.le },
    { rw [← nat.add_one_le_iff, ← with_top.coe_le_coe, with_top.coe_add, with_top.coe_untop,
        with_top.coe_untop, with_top.coe_one, ← set.chain_height_insert_of_forall_lt _ q.1],
      { apply set.chain_height_le_of_subset, rintros _ (rfl|⟨e' : _ < _, hx⟩),
        exacts [⟨(lt_of_le_of_ne e h : _), q.2⟩, ⟨e'.trans_le e, hx⟩] },
      { exact λ _ h, h.1 } }
end

lemma well_founded_lt_of_chain_height_ne_top {α : Type*} [partial_order α]
  (s : set α) (hs : s.chain_height ≠ ⊤) :
  well_founded_lt s :=
begin
  let t : set αᵒᵈ := s,
  change well_founded_gt t,
  apply well_founded_gt_of_chain_height_ne_top,
  convert hs using 1,
  exact chain_height_order_dual s t rfl,
end

end

end set