/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Johannes Hölzl, Sander Dahmen
-/
import linear_algebra.basis
import linear_algebra.std_basis
import set_theory.cardinal_ordinal

/-!
# Dimension of modules and vector spaces

## Main definitions

* The rank of a module is defined as `module.rank : cardinal`.
  This is currently only defined for vector spaces, i.e., when the base semiring is a field.

## Main statements

* `mk_eq_mk_of_basis`: the dimension theorem, any two bases of the same vector space have the same
  cardinality.
* `dim_quotient_add_dim`: if V₁ is a submodule of V, then
  `module.rank (V/V₁) + module.rank V₁ = module.rank V`.
* `dim_range_add_dim_ker`: the rank-nullity theorem.

## Implementation notes

Many theorems in this file are not universe-generic when they relate dimensions
in different universes. They should be as general as they can be without
inserting `lift`s. The types `V`, `V'`, ... all live in different universes,
and `V₁`, `V₂`, ... all live in the same universe.
-/

noncomputable theory

universes u v v' v'' u₁' w w'

variables {K : Type u} {V V₁ V₂ V₃ : Type v} {V' V'₁ : Type v'} {V'' : Type v''}
variables {ι : Type w} {ι' : Type w'} {η : Type u₁'} {φ : η → Type*}

open_locale classical big_operators

section module
variables [field K] [add_comm_group V] [module K V] [add_comm_group V₁] [module K V₁]
include K
open submodule function set

variables (K V)

/-- The rank of a module, defined as a term of type `cardinal`.

In a vector space, this is the same as the dimension of the space.

TODO: this is currently only defined for vector spaces, as the cardinality of
the basis set. It should be generalized to modules in general.

The definition is marked as protected to avoid conflicts with `_root_.rank`,
the rank of a linear map.
-/
protected def module.rank : cardinal :=
cardinal.min
  (nonempty_subtype.2 (@exists_is_basis K V _ _ _))
  (λ b, cardinal.mk b.1)

variables {K V}

section
theorem is_basis.le_span {v : ι → V} {J : set V} (hv : is_basis K v)
   (hJ : span K J = ⊤) : cardinal.mk (range v) ≤ cardinal.mk J :=
begin
  cases le_or_lt cardinal.omega (cardinal.mk J) with oJ oJ,
  { have := cardinal.mk_range_eq_of_injective (linear_independent.injective hv.1),
    let S : J → set ι := λ j, ↑(is_basis.repr hv j).support,
    let S' : J → set V := λ j, v '' S j,
    have hs : range v ⊆ ⋃ j, S' j,
    { intros b hb,
      rcases mem_range.1 hb with ⟨i, hi⟩,
      have : span K J ≤ comap hv.repr (finsupp.supported K K (⋃ j, S j)) :=
        span_le.2 (λ j hj x hx, ⟨_, ⟨⟨j, hj⟩, rfl⟩, hx⟩),
      rw hJ at this,
      replace : hv.repr (v i) ∈ (finsupp.supported K K (⋃ j, S j)) := this trivial,
      rw [hv.repr_eq_single, finsupp.mem_supported,
        finsupp.support_single_ne_zero one_ne_zero] at this,
      { subst b,
        rcases mem_Union.1 (this (finset.mem_singleton_self _)) with ⟨j, hj⟩,
        exact mem_Union.2 ⟨j, (mem_image _ _ _).2 ⟨i, hj, rfl⟩⟩ },
      { apply_instance } },
    refine le_of_not_lt (λ IJ, _),
    suffices : cardinal.mk (⋃ j, S' j) < cardinal.mk (range v),
    { exact not_le_of_lt this ⟨set.embedding_of_subset _ _ hs⟩ },
    refine lt_of_le_of_lt (le_trans cardinal.mk_Union_le_sum_mk
      (cardinal.sum_le_sum _ (λ _, cardinal.omega) _)) _,
    { exact λ j, le_of_lt (cardinal.lt_omega_iff_finite.2 $ (finset.finite_to_set _).image _) },
    { rwa [cardinal.sum_const, cardinal.mul_eq_max oJ (le_refl _), max_eq_left oJ] } },
  { rcases exists_finite_card_le_of_finite_of_linear_independent_of_span
      (cardinal.lt_omega_iff_finite.1 oJ) hv.1.to_subtype_range _ with ⟨fI, hi⟩,
    { rwa [← cardinal.nat_cast_le, cardinal.finset_card, set.finite.coe_to_finset,
        cardinal.finset_card, set.finite.coe_to_finset] at hi, },
    { rw hJ, apply set.subset_univ } },
end
end

/-- dimension theorem -/
theorem mk_eq_mk_of_basis {v : ι → V} {v' : ι' → V}
  (hv : is_basis K v) (hv' : is_basis K v') :
  cardinal.lift.{w w'} (cardinal.mk ι) = cardinal.lift.{w' w} (cardinal.mk ι') :=
begin
  rw ←cardinal.lift_inj.{(max w w') v},
  rw [cardinal.lift_lift, cardinal.lift_lift],
  apply le_antisymm,
  { convert cardinal.lift_le.{v (max w w')}.2 (hv.le_span hv'.2),
    { rw cardinal.lift_max.{w v w'},
      apply (cardinal.mk_range_eq_of_injective hv.injective).symm, },
    { rw cardinal.lift_max.{w' v w},
      apply (cardinal.mk_range_eq_of_injective hv'.injective).symm, }, },
  { convert cardinal.lift_le.{v (max w w')}.2 (hv'.le_span hv.2),
    { rw cardinal.lift_max.{w' v w},
      apply (cardinal.mk_range_eq_of_injective hv'.injective).symm, },
    { rw cardinal.lift_max.{w v w'},
      apply (cardinal.mk_range_eq_of_injective hv.injective).symm, }, }
end

theorem mk_eq_mk_of_basis' {ι' : Type w} {v : ι → V} {v' : ι' → V} (hv : is_basis K v)
  (hv' : is_basis K v') :
  cardinal.mk ι = cardinal.mk ι' :=
cardinal.lift_inj.1 $ mk_eq_mk_of_basis hv hv'

theorem is_basis.mk_eq_dim'' {ι : Type v} {v : ι → V} (h : is_basis K v) :
  cardinal.mk ι = module.rank K V :=
begin
  obtain ⟨v', e : module.rank K V = _⟩ := cardinal.min_eq _ _,
  rw e,
  rw ← cardinal.mk_range_eq _ h.injective,
  exact mk_eq_mk_of_basis' h.range v'.2
end

theorem is_basis.mk_range_eq_dim {v : ι → V} (h : is_basis K v) :
  cardinal.mk (range v) = module.rank K V :=
h.range.mk_eq_dim''

theorem is_basis.mk_eq_dim {v : ι → V} (h : is_basis K v) :
  cardinal.lift.{w v} (cardinal.mk ι) = cardinal.lift.{v w} (module.rank K V) :=
by rw [←h.mk_range_eq_dim, cardinal.mk_range_eq_of_injective h.injective]

theorem {m} is_basis.mk_eq_dim' {v : ι → V} (h : is_basis K v) :
  cardinal.lift.{w (max v m)} (cardinal.mk ι) = cardinal.lift.{v (max w m)} (module.rank K V) :=
by simpa using h.mk_eq_dim

theorem dim_le {n : ℕ}
  (H : ∀ s : finset V, linear_independent K (λ i : (↑s : set V), (i : V)) → s.card ≤ n) :
  module.rank K V ≤ n :=
let ⟨b, hb⟩ := exists_is_basis K V in
hb.mk_eq_dim'' ▸ cardinal.card_le_of (λ s, @finset.card_map _ _ ⟨_, subtype.val_injective⟩ s ▸ H _
(by { refine hb.1.mono (λ y h, _),
  rw [finset.mem_coe, finset.mem_map] at h, rcases h with ⟨x, hx, rfl⟩, exact x.2 } ))

variables [add_comm_group V'] [module K V']

/-- Two linearly equivalent vector spaces have the same dimension, a version with different
universes. -/
theorem linear_equiv.lift_dim_eq (f : V ≃ₗ[K] V') :
  cardinal.lift.{v v'} (module.rank K V) = cardinal.lift.{v' v} (module.rank K V') :=
let ⟨b, hb⟩ := exists_is_basis K V in
calc cardinal.lift.{v v'} (module.rank K V) = cardinal.lift.{v v'} (cardinal.mk b) :
  congr_arg _ hb.mk_eq_dim''.symm
... = cardinal.lift.{v' v} (module.rank K V') : (f.is_basis hb).mk_eq_dim

/-- Two linearly equivalent vector spaces have the same dimension. -/
theorem linear_equiv.dim_eq (f : V ≃ₗ[K] V₁) :
  module.rank K V = module.rank K V₁ :=
cardinal.lift_inj.1 f.lift_dim_eq

/-- Two vector spaces are isomorphic if they have the same dimension. -/
theorem nonempty_linear_equiv_of_lift_dim_eq
  (cond : cardinal.lift.{v v'} (module.rank K V) = cardinal.lift.{v' v} (module.rank K V')) :
  nonempty (V ≃ₗ[K] V') :=
begin
  obtain ⟨B, h⟩ := exists_is_basis K V,
  obtain ⟨B', h'⟩ := exists_is_basis K V',
  have : cardinal.lift.{v v'} (cardinal.mk B) = cardinal.lift.{v' v} (cardinal.mk B'),
    by rw [h.mk_eq_dim'', cond, h'.mk_eq_dim''],
  exact (cardinal.lift_mk_eq.{v v' 0}.1 this).map (linear_equiv_of_is_basis h h')
end

/-- Two vector spaces are isomorphic if they have the same dimension. -/
theorem nonempty_linear_equiv_of_dim_eq (cond : module.rank K V = module.rank K V₁) :
  nonempty (V ≃ₗ[K] V₁) :=
nonempty_linear_equiv_of_lift_dim_eq $ congr_arg _ cond

section

variables (V V' V₁)

/-- Two vector spaces are isomorphic if they have the same dimension. -/
def linear_equiv.of_lift_dim_eq
  (cond : cardinal.lift.{v v'} (module.rank K V) = cardinal.lift.{v' v} (module.rank K V')) :
  V ≃ₗ[K] V' :=
classical.choice (nonempty_linear_equiv_of_lift_dim_eq cond)

/-- Two vector spaces are isomorphic if they have the same dimension. -/
def linear_equiv.of_dim_eq (cond : module.rank K V = module.rank K V₁) : V ≃ₗ[K] V₁ :=
classical.choice (nonempty_linear_equiv_of_dim_eq cond)

end

/-- Two vector spaces are isomorphic if and only if they have the same dimension. -/
theorem linear_equiv.nonempty_equiv_iff_lift_dim_eq :
  nonempty (V ≃ₗ[K] V') ↔
    cardinal.lift.{v v'} (module.rank K V) = cardinal.lift.{v' v} (module.rank K V') :=
⟨λ ⟨h⟩, linear_equiv.lift_dim_eq h, λ h, nonempty_linear_equiv_of_lift_dim_eq h⟩

/-- Two vector spaces are isomorphic if and only if they have the same dimension. -/
theorem linear_equiv.nonempty_equiv_iff_dim_eq :
  nonempty (V ≃ₗ[K] V₁) ↔ module.rank K V = module.rank K V₁ :=
⟨λ ⟨h⟩, linear_equiv.dim_eq h, λ h, nonempty_linear_equiv_of_dim_eq h⟩

@[simp] lemma dim_bot : module.rank K (⊥ : submodule K V) = 0 :=
by letI := classical.dec_eq V;
  rw [← cardinal.lift_inj, ← (is_basis_empty (⊥ : submodule K V) not_nonempty_pempty).mk_eq_dim,
    cardinal.mk_pempty]

@[simp] lemma dim_top : module.rank K (⊤ : submodule K V) = module.rank K V :=
linear_equiv.dim_eq (linear_equiv.of_top _ rfl)

lemma dim_of_field (K : Type*) [field K] : module.rank K K = 1 :=
by rw [←cardinal.lift_inj, ← (@is_basis_singleton_one punit K _ _).mk_eq_dim, cardinal.mk_punit]

lemma dim_span {v : ι → V} (hv : linear_independent K v) :
  module.rank K ↥(span K (range v)) = cardinal.mk (range v) :=
by rw [←cardinal.lift_inj, ← (is_basis_span hv).mk_eq_dim,
    cardinal.mk_range_eq_of_injective (@linear_independent.injective ι K V v _ _ _ _ hv)]

lemma dim_span_set {s : set V} (hs : linear_independent K (λ x, x : s → V)) :
  module.rank K ↥(span K s) = cardinal.mk s :=
by { rw [← @set_of_mem_eq _ s, ← subtype.range_coe_subtype], exact dim_span hs }

lemma {m} cardinal_lift_le_dim_of_linear_independent
  {ι : Type w} {v : ι → V} (hv : linear_independent K v) :
  cardinal.lift.{w (max v m)} (cardinal.mk ι) ≤ cardinal.lift.{v (max w m)} (module.rank K V) :=
begin
  obtain ⟨ι', v', is⟩ := exists_sum_is_basis hv,
  rw [← cardinal.lift_umax, ← cardinal.lift_umax.{v}],
  simpa using le_trans
    (cardinal.lift_mk_le.{w _ (max v m)}.2 ⟨@function.embedding.inl ι ι'⟩)
    (le_of_eq $ is_basis.mk_eq_dim'.{_ _ _ (max w m)} is),
end

lemma cardinal_le_dim_of_linear_independent
  {ι : Type v} {v : ι → V} (hv : linear_independent K v) :
  cardinal.mk ι ≤ module.rank K V :=
by simpa using cardinal_lift_le_dim_of_linear_independent hv

lemma cardinal_le_dim_of_linear_independent'
  {s : set V} (hs : linear_independent K (λ x, x : s → V)) :
  cardinal.mk s ≤ module.rank K V :=
cardinal_le_dim_of_linear_independent hs

lemma dim_span_le (s : set V) : module.rank K (span K s) ≤ cardinal.mk s :=
begin
  classical,
  rcases
    exists_linear_independent (linear_independent_empty K V) (set.empty_subset s)
    with ⟨b, hb, _, hsb, hlib⟩,
  have hsab : span K s = span K b,
    from span_eq_of_le _ hsb (span_le.2 (λ x hx, subset_span (hb hx))),
  convert cardinal.mk_le_mk_of_subset hb,
  rw [hsab, dim_span_set hlib]
end

lemma dim_span_of_finset (s : finset V) :
  module.rank K (span K (↑s : set V)) < cardinal.omega :=
calc module.rank K (span K (↑s : set V)) ≤ cardinal.mk (↑s : set V) : dim_span_le ↑s
                             ... = s.card : by rw ←cardinal.finset_card
                             ... < cardinal.omega : cardinal.nat_lt_omega _

theorem dim_prod : module.rank K (V × V₁) = module.rank K V + module.rank K V₁ :=
begin
  rcases exists_is_basis K V with ⟨b, hb⟩,
  rcases exists_is_basis K V₁ with ⟨c, hc⟩,
  rw [← cardinal.lift_inj,
      ← @is_basis.mk_eq_dim K (V × V₁) _ _ _ _ _ (is_basis_inl_union_inr hb hc),
      cardinal.lift_add, cardinal.lift_mk,
      ← hb.mk_eq_dim, ← hc.mk_eq_dim,
      cardinal.lift_mk, cardinal.lift_mk,
      cardinal.add_def (ulift b) (ulift c)],
  exact cardinal.lift_inj.1 (cardinal.lift_mk_eq.2
      ⟨equiv.ulift.trans (equiv.sum_congr (@equiv.ulift b) (@equiv.ulift c)).symm ⟩),
end

theorem dim_quotient_add_dim (p : submodule K V) :
  module.rank K p.quotient + module.rank K p = module.rank K V :=
by classical; exact let ⟨f⟩ := quotient_prod_linear_equiv p in dim_prod.symm.trans f.dim_eq

theorem dim_quotient_le (p : submodule K V) :
  module.rank K p.quotient ≤ module.rank K V :=
by { rw ← dim_quotient_add_dim p, exact self_le_add_right _ _ }

/-- rank-nullity theorem -/
theorem dim_range_add_dim_ker (f : V →ₗ[K] V₁) :
  module.rank K f.range + module.rank K f.ker = module.rank K V :=
begin
  haveI := λ (p : submodule K V), classical.dec_eq p.quotient,
  rw [← f.quot_ker_equiv_range.dim_eq, dim_quotient_add_dim]
end

lemma dim_range_le (f : V →ₗ[K] V₁) : module.rank K f.range ≤ module.rank K V :=
by { rw ← dim_range_add_dim_ker f, exact self_le_add_right _ _ }

lemma dim_map_le (f : V →ₗ V₁) (p : submodule K V) : module.rank K (p.map f) ≤ module.rank K p :=
begin
  have h := dim_range_le (f.comp (submodule.subtype p)),
  rwa [linear_map.range_comp, range_subtype] at h,
end

lemma dim_range_of_surjective (f : V →ₗ[K] V') (h : surjective f) :
  module.rank K f.range = module.rank K V' :=
by rw [linear_map.range_eq_top.2 h, dim_top]

lemma dim_eq_of_surjective (f : V →ₗ[K] V₁) (h : surjective f) :
  module.rank K V = module.rank K V₁ + module.rank K f.ker :=
by rw [← dim_range_add_dim_ker f, ← dim_range_of_surjective f h]

lemma dim_le_of_surjective (f : V →ₗ[K] V₁) (h : surjective f) :
  module.rank K V₁ ≤ module.rank K V :=
by { rw [dim_eq_of_surjective f h], refine self_le_add_right _ _ }

lemma dim_eq_of_injective (f : V →ₗ[K] V₁) (h : injective f) :
  module.rank K V = module.rank K f.range :=
by rw [← dim_range_add_dim_ker f, linear_map.ker_eq_bot.2 h]; simp [dim_bot]

lemma dim_submodule_le (s : submodule K V) : module.rank K s ≤ module.rank K V :=
by { rw ← dim_quotient_add_dim s, exact self_le_add_left _ _ }

lemma dim_le_of_injective (f : V →ₗ[K] V₁) (h : injective f) :
  module.rank K V ≤ module.rank K V₁ :=
by { rw [dim_eq_of_injective f h], exact dim_submodule_le _ }

lemma dim_le_of_submodule (s t : submodule K V) (h : s ≤ t) :
  module.rank K s ≤ module.rank K t :=
dim_le_of_injective (of_le h) $ assume ⟨x, hx⟩ ⟨y, hy⟩ eq,
  subtype.eq $ show x = y, from subtype.ext_iff_val.1 eq

lemma linear_independent_le_dim
  {v : ι → V} (hv : linear_independent K v) :
  cardinal.lift.{w v} (cardinal.mk ι) ≤ cardinal.lift.{v w} (module.rank K V) :=
calc
  cardinal.lift.{w v} (cardinal.mk ι) = cardinal.lift.{v w} (cardinal.mk (set.range v)) :
     (cardinal.mk_range_eq_of_injective (linear_independent.injective hv)).symm
  ... = cardinal.lift.{v w} (module.rank K (submodule.span K (set.range v))) :
    by rw (dim_span hv).symm
  ... ≤ cardinal.lift.{v w} (module.rank K V) :
    cardinal.lift_le.2 (dim_submodule_le (submodule.span K _))

theorem {u₁} linear_independent_le_dim' {v : ι → V} (hs : linear_independent K v) :
  ((cardinal.mk ι).lift : cardinal.{(max w v u₁)}) ≤
    ((module.rank K V).lift : cardinal.{(max v w u₁)}) :=
cardinal.mk_range_eq_lift hs.injective ▸ dim_span hs ▸ cardinal.lift_le.2 (dim_submodule_le _)

section
variables [add_comm_group V₂] [module K V₂]
variables [add_comm_group V₃] [module K V₃]
open linear_map

/-- This is mostly an auxiliary lemma for `dim_sup_add_dim_inf_eq`. -/
lemma dim_add_dim_split
  (db : V₂ →ₗ[K] V) (eb : V₃ →ₗ[K] V) (cd : V₁ →ₗ[K] V₂) (ce : V₁ →ₗ[K] V₃)
  (hde : ⊤ ≤ db.range ⊔ eb.range)
  (hgd : ker cd = ⊥)
  (eq : db.comp cd = eb.comp ce)
  (eq₂ : ∀d e, db d = eb e → (∃c, cd c = d ∧ ce c = e)) :
  module.rank K V + module.rank K V₁ = module.rank K V₂ + module.rank K V₃ :=
have hf : surjective (coprod db eb),
begin
  refine (range_eq_top.1 $ top_unique $ _),
  rwa [← map_top, ← prod_top, map_coprod_prod, ←range_eq_map, ←range_eq_map]
end,
begin
  conv {to_rhs, rw [← dim_prod, dim_eq_of_surjective _ hf] },
  congr' 1,
  apply linear_equiv.dim_eq,
  refine linear_equiv.of_bijective _ _ _,
  { refine cod_restrict _ (prod cd (- ce)) _,
    { assume c,
      simp only [add_eq_zero_iff_eq_neg, prod_apply, mem_ker,
        coprod_apply, neg_neg, map_neg, neg_apply],
      exact linear_map.ext_iff.1 eq c } },
  { rw [ker_cod_restrict, ker_prod, hgd, bot_inf_eq] },
  { rw [eq_top_iff, range_cod_restrict, ← map_le_iff_le_comap, map_top, range_subtype],
    rintros ⟨d, e⟩,
    have h := eq₂ d (-e),
    simp only [add_eq_zero_iff_eq_neg, prod_apply, mem_ker, set_like.mem_coe, prod.mk.inj_iff,
      coprod_apply, map_neg, neg_apply, linear_map.mem_range] at ⊢ h,
    assume hde,
    rcases h hde with ⟨c, h₁, h₂⟩,
    refine ⟨c, h₁, _⟩,
    rw [h₂, _root_.neg_neg] }
end

lemma dim_sup_add_dim_inf_eq (s t : submodule K V) :
  module.rank K (s ⊔ t : submodule K V) + module.rank K (s ⊓ t : submodule K V) =
    module.rank K s + module.rank K t :=
dim_add_dim_split (of_le le_sup_left) (of_le le_sup_right) (of_le inf_le_left) (of_le inf_le_right)
  begin
    rw [← map_le_map_iff' (ker_subtype $ s ⊔ t), map_sup, map_top,
      ← linear_map.range_comp, ← linear_map.range_comp, subtype_comp_of_le, subtype_comp_of_le,
      range_subtype, range_subtype, range_subtype],
    exact le_refl _
  end
  (ker_of_le _ _ _)
  begin ext ⟨x, hx⟩, refl end
  begin
    rintros ⟨b₁, hb₁⟩ ⟨b₂, hb₂⟩ eq,
    have : b₁ = b₂ := congr_arg subtype.val eq,
    subst this,
    exact ⟨⟨b₁, hb₁, hb₂⟩, rfl, rfl⟩
  end

lemma dim_add_le_dim_add_dim (s t : submodule K V) :
  module.rank K (s ⊔ t : submodule K V) ≤ module.rank K s + module.rank K t :=
by { rw [← dim_sup_add_dim_inf_eq], exact self_le_add_right _ _ }

end

section fintype
variable [fintype η]
variables [∀i, add_comm_group (φ i)] [∀i, module K (φ i)]

open linear_map

lemma dim_pi : module.rank K (Πi, φ i) = cardinal.sum (λi, module.rank K (φ i)) :=
begin
  choose b hb using assume i, exists_is_basis K (φ i),
  have : is_basis K (λ (ji : Σ j, b j), std_basis K (λ j, φ j) ji.fst ji.snd.val),
    by apply pi.is_basis_std_basis _ hb,
  rw [←cardinal.lift_inj, ← this.mk_eq_dim],
  simp [λ i, (hb i).mk_range_eq_dim.symm, cardinal.sum_mk]
end

lemma dim_fun {V η : Type u} [fintype η] [add_comm_group V] [module K V] :
  module.rank K (η → V) = fintype.card η * module.rank K V :=
by rw [dim_pi, cardinal.sum_const, cardinal.fintype_card]

lemma dim_fun_eq_lift_mul :
  module.rank K (η → V) = (fintype.card η : cardinal.{max u₁' v}) *
    cardinal.lift.{v u₁'} (module.rank K V) :=
by rw [dim_pi, cardinal.sum_const_eq_lift_mul, cardinal.fintype_card, cardinal.lift_nat_cast]

lemma dim_fun' : module.rank K (η → K) = fintype.card η :=
by rw [dim_fun_eq_lift_mul, dim_of_field K, cardinal.lift_one, mul_one, cardinal.nat_cast_inj]

lemma dim_fin_fun (n : ℕ) : module.rank K (fin n → K) = n :=
by simp [dim_fun']

end fintype

lemma exists_mem_ne_zero_of_ne_bot {s : submodule K V} (h : s ≠ ⊥) : ∃ b : V, b ∈ s ∧ b ≠ 0 :=
begin
  classical,
  by_contradiction hex,
  have : ∀x∈s, (x:V) = 0, { simpa only [not_exists, not_and, not_not, ne.def] using hex },
  exact (h $ bot_unique $ assume s hs, (submodule.mem_bot K).2 $ this s hs)
end

lemma exists_mem_ne_zero_of_dim_pos {s : submodule K V} (h : 0 < module.rank K s) :
  ∃ b : V, b ∈ s ∧ b ≠ 0 :=
exists_mem_ne_zero_of_ne_bot $ assume eq, by rw [eq, dim_bot] at h; exact lt_irrefl _ h

lemma exists_is_basis_fintype (h : module.rank K V < cardinal.omega) :
  ∃ s : (set V), (is_basis K (subtype.val : s → V)) ∧ nonempty (fintype s) :=
begin
  cases exists_is_basis K V with s hs,
  rw [←cardinal.lift_lt, ← is_basis.mk_eq_dim hs, cardinal.lift_lt,
      cardinal.lt_omega_iff_fintype] at h,
  exact ⟨s, hs, h⟩
end

section rank

/-- `rank f` is the rank of a `linear_map f`, defined as the dimension of `f.range`. -/
def rank (f : V →ₗ[K] V') : cardinal := module.rank K f.range

lemma rank_le_domain (f : V →ₗ[K] V₁) : rank f ≤ module.rank K V :=
by { rw [← dim_range_add_dim_ker f], exact self_le_add_right _ _ }

lemma rank_le_range (f : V →ₗ[K] V₁) : rank f ≤ module.rank K V₁ :=
dim_submodule_le _

lemma rank_add_le (f g : V →ₗ[K] V') : rank (f + g) ≤ rank f + rank g :=
calc rank (f + g) ≤ module.rank K (f.range ⊔ g.range : submodule K V') :
  begin
    refine dim_le_of_submodule _ _ _,
    exact (linear_map.range_le_iff_comap.2 $ eq_top_iff'.2 $
      assume x, show f x + g x ∈ (f.range ⊔ g.range : submodule K V'), from
        mem_sup.2 ⟨_, ⟨x, rfl⟩, _, ⟨x, rfl⟩, rfl⟩)
  end
  ... ≤ rank f + rank g : dim_add_le_dim_add_dim _ _

@[simp] lemma rank_zero : rank (0 : V →ₗ[K] V') = 0 :=
by rw [rank, linear_map.range_zero, dim_bot]

lemma rank_finset_sum_le {η} (s : finset η) (f : η → V →ₗ[K] V') :
  rank (∑ d in s, f d) ≤ ∑ d in s, rank (f d) :=
@finset.sum_hom_rel _ _ _ _ _ (λa b, rank a ≤ b) f (λ d, rank (f d)) s (le_of_eq rank_zero)
      (λ i g c h, le_trans (rank_add_le _ _) (add_le_add_left h _))

variables [add_comm_group V''] [module K V'']

lemma rank_comp_le1 (g : V →ₗ[K] V') (f : V' →ₗ[K] V'') : rank (f.comp g) ≤ rank f :=
begin
  refine dim_le_of_submodule _ _ _,
  rw [linear_map.range_comp],
  exact linear_map.map_le_range,
end

variables [add_comm_group V'₁] [module K V'₁]

lemma rank_comp_le2 (g : V →ₗ[K] V') (f : V' →ₗ V'₁) : rank (f.comp g) ≤ rank g :=
by rw [rank, rank, linear_map.range_comp]; exact dim_map_le _ _

end rank

lemma dim_zero_iff_forall_zero : module.rank K V = 0 ↔ ∀ x : V, x = 0 :=
begin
  split,
  { intros h x,
    cases exists_is_basis K V with w hw,
    have card_mk_range := hw.mk_range_eq_dim,
    rw [h, cardinal.mk_emptyc_iff, subtype.range_coe] at card_mk_range,
    simpa [card_mk_range] using hw.mem_span x },
  { intro h,
    have : (⊤ : submodule K V) = ⊥,
    { ext x, simp [h x] },
    rw [←dim_top, this, dim_bot] }
end

lemma dim_zero_iff : module.rank K V = 0 ↔ subsingleton V :=
dim_zero_iff_forall_zero.trans (subsingleton_iff_forall_eq 0).symm

lemma is_basis_of_dim_eq_zero {ι : Type*} (h : ¬ nonempty ι)
  (hV : module.rank K V = 0) : is_basis K (λ x : ι, (0 : V)) :=
begin
  haveI : subsingleton V := dim_zero_iff.1 hV,
  exact is_basis_empty _ h
end

lemma is_basis_of_dim_eq_zero'
  (hV : module.rank K V = 0) : is_basis K (λ x : fin 0, (0 : V)) :=
is_basis_of_dim_eq_zero (finset.univ_eq_empty.mp rfl) hV

lemma dim_pos_iff_exists_ne_zero : 0 < module.rank K V ↔ ∃ x : V, x ≠ 0 :=
begin
  rw ←not_iff_not,
  simpa using dim_zero_iff_forall_zero
end

lemma dim_pos_iff_nontrivial : 0 < module.rank K V ↔ nontrivial V :=
dim_pos_iff_exists_ne_zero.trans (nontrivial_iff_exists_ne 0).symm

lemma dim_pos [h : nontrivial V] : 0 < module.rank K V :=
dim_pos_iff_nontrivial.2 h

lemma le_dim_iff_exists_linear_independent {c : cardinal} :
  c ≤ module.rank K V ↔ ∃ s : set V, cardinal.mk s = c ∧ linear_independent K (coe : s → V) :=
begin
  split,
  { intro h,
    rcases exists_is_basis K V with ⟨t, ht⟩,
    rw [← ht.mk_eq_dim'', cardinal.le_mk_iff_exists_subset] at h,
    rcases h with ⟨s, hst, hsc⟩,
    exact ⟨s, hsc, ht.1.mono hst⟩ },
  { rintro ⟨s, rfl, si⟩,
    exact cardinal_le_dim_of_linear_independent si }
end

lemma le_dim_iff_exists_linear_independent_finset {n : ℕ} :
  ↑n ≤ module.rank K V ↔
    ∃ s : finset V, s.card = n ∧ linear_independent K (coe : (s : set V) → V) :=
begin
  simp only [le_dim_iff_exists_linear_independent, cardinal.mk_eq_nat_iff_finset],
  split,
  { rintro ⟨s, ⟨t, rfl, rfl⟩, si⟩,
    exact ⟨t, rfl, si⟩ },
  { rintro ⟨s, rfl, si⟩,
    exact ⟨s, ⟨s, rfl, rfl⟩, si⟩ }
end

lemma le_rank_iff_exists_linear_independent {c : cardinal} {f : V →ₗ[K] V'} :
  c ≤ rank f ↔
  ∃ s : set V, cardinal.lift.{v v'} (cardinal.mk s) = cardinal.lift.{v' v} c ∧
    linear_independent K (λ x : s, f x) :=
begin
  rcases f.range_restrict.exists_right_inverse_of_surjective f.range_range_restrict with ⟨g, hg⟩,
  have fg : left_inverse f.range_restrict g, from linear_map.congr_fun hg,
  refine ⟨λ h, _, _⟩,
  { rcases le_dim_iff_exists_linear_independent.1 h with ⟨s, rfl, si⟩,
    refine ⟨g '' s, cardinal.mk_image_eq_lift _ _ fg.injective, _⟩,
    replace fg : ∀ x, f (g x) = x, by { intro x, convert congr_arg subtype.val (fg x) },
    replace si : linear_independent K (λ x : s, f (g x)),
      by simpa only [fg] using si.map' _ (ker_subtype _),
    exact si.image_of_comp s g f },
  { rintro ⟨s, hsc, si⟩,
    have : linear_independent K (λ x : s, f.range_restrict x),
      from linear_independent.of_comp (f.range.subtype) (by convert si),
    convert cardinal_le_dim_of_linear_independent this.image,
    rw [← cardinal.lift_inj, ← hsc, cardinal.mk_image_eq_of_inj_on_lift],
    exact inj_on_iff_injective.2 this.injective }
end

lemma le_rank_iff_exists_linear_independent_finset {n : ℕ} {f : V →ₗ[K] V'} :
  ↑n ≤ rank f ↔ ∃ s : finset V, s.card = n ∧ linear_independent K (λ x : (s : set V), f x) :=
begin
  simp only [le_rank_iff_exists_linear_independent, cardinal.lift_nat_cast,
    cardinal.lift_eq_nat_iff, cardinal.mk_eq_nat_iff_finset],
  split,
  { rintro ⟨s, ⟨t, rfl, rfl⟩, si⟩,
    exact ⟨t, rfl, si⟩ },
  { rintro ⟨s, rfl, si⟩,
    exact ⟨s, ⟨s, rfl, rfl⟩, si⟩ }
end

/-- A vector space has dimension at most `1` if and only if there is a
single vector of which all vectors are multiples. -/
lemma dim_le_one_iff : module.rank K V ≤ 1 ↔ ∃ v₀ : V, ∀ v, ∃ r : K, r • v₀ = v :=
begin
  obtain ⟨b, h⟩ := exists_is_basis K V,
  split,
  { intro hd,
    rw [←is_basis.mk_eq_dim'' h, cardinal.le_one_iff_subsingleton, subsingleton_coe] at hd,
    rcases eq_empty_or_nonempty b with rfl | ⟨⟨v₀, hv₀⟩⟩,
    { use 0,
      have h' : ∀ v : V, v = 0, { simpa [submodule.eq_bot_iff] using h.2.symm },
      intro v,
      simp [h' v] },
    { use v₀,
      have h' : (K ∙ v₀) = ⊤, { simpa [hd.eq_singleton_of_mem hv₀] using h.2 },
      intro v,
      have hv : v ∈ (⊤ : submodule K V) := mem_top,
      rwa [←h', mem_span_singleton] at hv } },
  { rintros ⟨v₀, hv₀⟩,
    have h : (K ∙ v₀) = ⊤,
    { ext, simp [mem_span_singleton, hv₀] },
    rw [←dim_top, ←h],
    convert dim_span_le _,
    simp }
end

/-- A submodule has dimension at most `1` if and only if there is a
single vector in the submodule such that the submodule is contained in
its span. -/
lemma dim_submodule_le_one_iff (s : submodule K V) : module.rank K s ≤ 1 ↔ ∃ v₀ ∈ s, s ≤ K ∙ v₀ :=
begin
  simp_rw [dim_le_one_iff, le_span_singleton_iff],
  split,
  { rintro ⟨⟨v₀, hv₀⟩, h⟩,
    use [v₀, hv₀],
    intros v hv,
    obtain ⟨r, hr⟩ := h ⟨v, hv⟩,
    use r,
    simp_rw [subtype.ext_iff, coe_smul, coe_mk] at hr,
    exact hr },
  { rintro ⟨v₀, hv₀, h⟩,
    use ⟨v₀, hv₀⟩,
    rintro ⟨v, hv⟩,
    obtain ⟨r, hr⟩ := h v hv,
    use r,
    simp_rw [subtype.ext_iff, coe_smul, coe_mk],
    exact hr }
end

/-- A submodule has dimension at most `1` if and only if there is a
single vector, not necessarily in the submodule, such that the
submodule is contained in its span. -/
lemma dim_submodule_le_one_iff' (s : submodule K V) : module.rank K s ≤ 1 ↔ ∃ v₀, s ≤ K ∙ v₀ :=
begin
  rw dim_submodule_le_one_iff,
  split,
  { rintros ⟨v₀, hv₀, h⟩,
    exact ⟨v₀, h⟩ },
  { rintros ⟨v₀, h⟩,
    by_cases hw : ∃ w : V, w ∈ s ∧ w ≠ 0,
    { rcases hw with ⟨w, hw, hw0⟩,
      use [w, hw],
      rcases mem_span_singleton.1 (h hw) with ⟨r', rfl⟩,
      have h0 : r' ≠ 0,
      { rintro rfl,
        simpa using hw0 },
      rwa span_singleton_smul_eq _ h0 },
    { push_neg at hw,
      rw ←submodule.eq_bot_iff at hw,
      simp [hw] } }
end

end module

section unconstrained_universes

variables {E : Type v'}
variables [field K] [add_comm_group V] [module K V]
          [add_comm_group E] [module K E]
open module

/-- Version of linear_equiv.dim_eq without universe constraints. -/
theorem linear_equiv.dim_eq_lift (f : V ≃ₗ[K] E) :
  cardinal.lift.{v v'} (module.rank K V) = cardinal.lift.{v' v} (module.rank K E) :=
begin
  cases exists_is_basis K V with b hb,
  rw [← cardinal.lift_inj.1 hb.mk_eq_dim, ← (f.is_basis hb).mk_eq_dim, cardinal.lift_mk],
end

end unconstrained_universes


/-
Copyright (c) 2018 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau, Yury Kudryashov
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.char_p.basic
import Mathlib.data.equiv.ring
import Mathlib.algebra.group_with_zero.power
import Mathlib.algebra.iterate_hom
import Mathlib.PostPort

universes u l v u_1

namespace Mathlib

/-!
# The perfect closure of a field
-/

/-- A perfect ring is a ring of characteristic p that has p-th root. -/
class perfect_ring (R : Type u) [comm_semiring R] (p : ℕ) [fact (nat.prime p)] [char_p R p] where
  pth_root' : R → R
  frobenius_pth_root' : ∀ (x : R), coe_fn (frobenius R p) (pth_root' x) = x
  pth_root_frobenius' : ∀ (x : R), pth_root' (coe_fn (frobenius R p) x) = x

/-- Frobenius automorphism of a perfect ring. -/
def frobenius_equiv (R : Type u) [comm_semiring R] (p : ℕ) [fact (nat.prime p)] [char_p R p]
    [perfect_ring R p] : R ≃+* R :=
  ring_equiv.mk (ring_hom.to_fun (frobenius R p)) (perfect_ring.pth_root' p)
    perfect_ring.pth_root_frobenius' perfect_ring.frobenius_pth_root' sorry sorry

/-- `p`-th root of an element in a `perfect_ring` as a `ring_hom`. -/
def pth_root (R : Type u) [comm_semiring R] (p : ℕ) [fact (nat.prime p)] [char_p R p]
    [perfect_ring R p] : R →+* R :=
  ↑(ring_equiv.symm (frobenius_equiv R p))

@[simp] theorem coe_frobenius_equiv {R : Type u} [comm_semiring R] {p : ℕ} [fact (nat.prime p)]
    [char_p R p] [perfect_ring R p] : ⇑(frobenius_equiv R p) = ⇑(frobenius R p) :=
  rfl

@[simp] theorem coe_frobenius_equiv_symm {R : Type u} [comm_semiring R] {p : ℕ} [fact (nat.prime p)]
    [char_p R p] [perfect_ring R p] : ⇑(ring_equiv.symm (frobenius_equiv R p)) = ⇑(pth_root R p) :=
  rfl

@[simp] theorem frobenius_pth_root {R : Type u} [comm_semiring R] {p : ℕ} [fact (nat.prime p)]
    [char_p R p] [perfect_ring R p] (x : R) :
    coe_fn (frobenius R p) (coe_fn (pth_root R p) x) = x :=
  ring_equiv.apply_symm_apply (frobenius_equiv R p) x

@[simp] theorem pth_root_pow_p {R : Type u} [comm_semiring R] {p : ℕ} [fact (nat.prime p)]
    [char_p R p] [perfect_ring R p] (x : R) : coe_fn (pth_root R p) x ^ p = x :=
  frobenius_pth_root x

@[simp] theorem pth_root_frobenius {R : Type u} [comm_semiring R] {p : ℕ} [fact (nat.prime p)]
    [char_p R p] [perfect_ring R p] (x : R) :
    coe_fn (pth_root R p) (coe_fn (frobenius R p) x) = x :=
  ring_equiv.symm_apply_apply (frobenius_equiv R p) x

@[simp] theorem pth_root_pow_p' {R : Type u} [comm_semiring R] {p : ℕ} [fact (nat.prime p)]
    [char_p R p] [perfect_ring R p] (x : R) : coe_fn (pth_root R p) (x ^ p) = x :=
  pth_root_frobenius x

theorem left_inverse_pth_root_frobenius {R : Type u} [comm_semiring R] {p : ℕ} [fact (nat.prime p)]
    [char_p R p] [perfect_ring R p] : function.left_inverse ⇑(pth_root R p) ⇑(frobenius R p) :=
  pth_root_frobenius

theorem right_inverse_pth_root_frobenius {R : Type u} [comm_semiring R] {p : ℕ} [fact (nat.prime p)]
    [char_p R p] [perfect_ring R p] : function.right_inverse ⇑(pth_root R p) ⇑(frobenius R p) :=
  frobenius_pth_root

theorem commute_frobenius_pth_root {R : Type u} [comm_semiring R] {p : ℕ} [fact (nat.prime p)]
    [char_p R p] [perfect_ring R p] : function.commute ⇑(frobenius R p) ⇑(pth_root R p) :=
  fun (x : R) => Eq.trans (frobenius_pth_root x) (Eq.symm (pth_root_frobenius x))

theorem eq_pth_root_iff {R : Type u} [comm_semiring R] {p : ℕ} [fact (nat.prime p)] [char_p R p]
    [perfect_ring R p] {x : R} {y : R} :
    x = coe_fn (pth_root R p) y ↔ coe_fn (frobenius R p) x = y :=
  equiv.eq_symm_apply (ring_equiv.to_equiv (frobenius_equiv R p))

theorem pth_root_eq_iff {R : Type u} [comm_semiring R] {p : ℕ} [fact (nat.prime p)] [char_p R p]
    [perfect_ring R p] {x : R} {y : R} :
    coe_fn (pth_root R p) x = y ↔ x = coe_fn (frobenius R p) y :=
  equiv.symm_apply_eq (ring_equiv.to_equiv (frobenius_equiv R p))

theorem monoid_hom.map_pth_root {R : Type u} [comm_semiring R] {S : Type v} [comm_semiring S]
    (f : R →* S) {p : ℕ} [fact (nat.prime p)] [char_p R p] [perfect_ring R p] [char_p S p]
    [perfect_ring S p] (x : R) :
    coe_fn f (coe_fn (pth_root R p) x) = coe_fn (pth_root S p) (coe_fn f x) :=
  sorry

theorem monoid_hom.map_iterate_pth_root {R : Type u} [comm_semiring R] {S : Type v}
    [comm_semiring S] (f : R →* S) {p : ℕ} [fact (nat.prime p)] [char_p R p] [perfect_ring R p]
    [char_p S p] [perfect_ring S p] (x : R) (n : ℕ) :
    coe_fn f (nat.iterate (⇑(pth_root R p)) n x) = nat.iterate (⇑(pth_root S p)) n (coe_fn f x) :=
  function.semiconj.iterate_right (monoid_hom.map_pth_root f) n x

theorem ring_hom.map_pth_root {R : Type u} [comm_semiring R] {S : Type v} [comm_semiring S]
    (g : R →+* S) {p : ℕ} [fact (nat.prime p)] [char_p R p] [perfect_ring R p] [char_p S p]
    [perfect_ring S p] (x : R) :
    coe_fn g (coe_fn (pth_root R p) x) = coe_fn (pth_root S p) (coe_fn g x) :=
  monoid_hom.map_pth_root (ring_hom.to_monoid_hom g) x

theorem ring_hom.map_iterate_pth_root {R : Type u} [comm_semiring R] {S : Type v} [comm_semiring S]
    (g : R →+* S) {p : ℕ} [fact (nat.prime p)] [char_p R p] [perfect_ring R p] [char_p S p]
    [perfect_ring S p] (x : R) (n : ℕ) :
    coe_fn g (nat.iterate (⇑(pth_root R p)) n x) = nat.iterate (⇑(pth_root S p)) n (coe_fn g x) :=
  monoid_hom.map_iterate_pth_root (ring_hom.to_monoid_hom g) x n

theorem injective_pow_p {R : Type u} [comm_semiring R] (p : ℕ) [fact (nat.prime p)] [char_p R p]
    [perfect_ring R p] {x : R} {y : R} (hxy : x ^ p = y ^ p) : x = y :=
  function.left_inverse.injective left_inverse_pth_root_frobenius hxy

/-- `perfect_closure K p` is the quotient by this relation. -/
inductive perfect_closure.r (K : Type u) [comm_ring K] (p : ℕ) [fact (nat.prime p)] [char_p K p] :
    ℕ × K → ℕ × K → Prop
    where
| intro : ∀ (n : ℕ) (x : K), perfect_closure.r K p (n, x) (n + 1, coe_fn (frobenius K p) x)

/-- The perfect closure is the smallest extension that makes frobenius surjective. -/
def perfect_closure (K : Type u) [comm_ring K] (p : ℕ) [fact (nat.prime p)] [char_p K p] :=
  Quot sorry

namespace perfect_closure

/-- Constructor for `perfect_closure`. -/
def mk (K : Type u) [comm_ring K] (p : ℕ) [fact (nat.prime p)] [char_p K p] (x : ℕ × K) :
    perfect_closure K p :=
  Quot.mk (r K p) x

@[simp] theorem quot_mk_eq_mk (K : Type u) [comm_ring K] (p : ℕ) [fact (nat.prime p)] [char_p K p]
    (x : ℕ × K) : Quot.mk (r K p) x = mk K p x :=
  rfl

/-- Lift a function `ℕ × K → L` to a function on `perfect_closure K p`. -/
def lift_on {K : Type u} [comm_ring K] {p : ℕ} [fact (nat.prime p)] [char_p K p] {L : Type u_1}
    (x : perfect_closure K p) (f : ℕ × K → L) (hf : ∀ (x y : ℕ × K), r K p x y → f x = f y) : L :=
  quot.lift_on x f hf

@[simp] theorem lift_on_mk {K : Type u} [comm_ring K] {p : ℕ} [fact (nat.prime p)] [char_p K p]
    {L : Type u_1} (f : ℕ × K → L) (hf : ∀ (x y : ℕ × K), r K p x y → f x = f y) (x : ℕ × K) :
    lift_on (mk K p x) f hf = f x :=
  rfl

theorem induction_on {K : Type u} [comm_ring K] {p : ℕ} [fact (nat.prime p)] [char_p K p]
    (x : perfect_closure K p) {q : perfect_closure K p → Prop} (h : ∀ (x : ℕ × K), q (mk K p x)) :
    q x :=
  quot.induction_on x h

protected instance has_mul (K : Type u) [comm_ring K] (p : ℕ) [fact (nat.prime p)] [char_p K p] :
    Mul (perfect_closure K p) :=
  { mul :=
      Quot.lift
        (fun (x : ℕ × K) =>
          Quot.lift
            (fun (y : ℕ × K) =>
              mk K p
                (prod.fst x + prod.fst y,
                nat.iterate (⇑(frobenius K p)) (prod.fst y) (prod.snd x) *
                  nat.iterate (⇑(frobenius K p)) (prod.fst x) (prod.snd y)))
            (mul_aux_right K p x))
        sorry }

@[simp] theorem mk_mul_mk (K : Type u) [comm_ring K] (p : ℕ) [fact (nat.prime p)] [char_p K p]
    (x : ℕ × K) (y : ℕ × K) :
    mk K p x * mk K p y =
        mk K p
          (prod.fst x + prod.fst y,
          nat.iterate (⇑(frobenius K p)) (prod.fst y) (prod.snd x) *
            nat.iterate (⇑(frobenius K p)) (prod.fst x) (prod.snd y)) :=
  rfl

protected instance comm_monoid (K : Type u) [comm_ring K] (p : ℕ) [fact (nat.prime p)]
    [char_p K p] : comm_monoid (perfect_closure K p) :=
  comm_monoid.mk Mul.mul sorry (mk K p (0, 1)) sorry sorry sorry

theorem one_def (K : Type u) [comm_ring K] (p : ℕ) [fact (nat.prime p)] [char_p K p] :
    1 = mk K p (0, 1) :=
  rfl

protected instance inhabited (K : Type u) [comm_ring K] (p : ℕ) [fact (nat.prime p)] [char_p K p] :
    Inhabited (perfect_closure K p) :=
  { default := 1 }

protected instance has_add (K : Type u) [comm_ring K] (p : ℕ) [fact (nat.prime p)] [char_p K p] :
    Add (perfect_closure K p) :=
  { add :=
      Quot.lift
        (fun (x : ℕ × K) =>
          Quot.lift
            (fun (y : ℕ × K) =>
              mk K p
                (prod.fst x + prod.fst y,
                nat.iterate (⇑(frobenius K p)) (prod.fst y) (prod.snd x) +
                  nat.iterate (⇑(frobenius K p)) (prod.fst x) (prod.snd y)))
            (add_aux_right K p x))
        sorry }

@[simp] theorem mk_add_mk (K : Type u) [comm_ring K] (p : ℕ) [fact (nat.prime p)] [char_p K p]
    (x : ℕ × K) (y : ℕ × K) :
    mk K p x + mk K p y =
        mk K p
          (prod.fst x + prod.fst y,
          nat.iterate (⇑(frobenius K p)) (prod.fst y) (prod.snd x) +
            nat.iterate (⇑(frobenius K p)) (prod.fst x) (prod.snd y)) :=
  rfl

protected instance has_neg (K : Type u) [comm_ring K] (p : ℕ) [fact (nat.prime p)] [char_p K p] :
    Neg (perfect_closure K p) :=
  { neg := Quot.lift (fun (x : ℕ × K) => mk K p (prod.fst x, -prod.snd x)) sorry }

@[simp] theorem neg_mk (K : Type u) [comm_ring K] (p : ℕ) [fact (nat.prime p)] [char_p K p]
    (x : ℕ × K) : -mk K p x = mk K p (prod.fst x, -prod.snd x) :=
  rfl

protected instance has_zero (K : Type u) [comm_ring K] (p : ℕ) [fact (nat.prime p)] [char_p K p] :
    HasZero (perfect_closure K p) :=
  { zero := mk K p (0, 0) }

theorem zero_def (K : Type u) [comm_ring K] (p : ℕ) [fact (nat.prime p)] [char_p K p] :
    0 = mk K p (0, 0) :=
  rfl

theorem mk_zero (K : Type u) [comm_ring K] (p : ℕ) [fact (nat.prime p)] [char_p K p] (n : ℕ) :
    mk K p (n, 0) = 0 :=
  sorry

theorem r.sound (K : Type u) [comm_ring K] (p : ℕ) [fact (nat.prime p)] [char_p K p] (m : ℕ) (n : ℕ)
    (x : K) (y : K) (H : nat.iterate (⇑(frobenius K p)) m x = y) :
    mk K p (n, x) = mk K p (m + n, y) :=
  sorry

protected instance comm_ring (K : Type u) [comm_ring K] (p : ℕ) [fact (nat.prime p)] [char_p K p] :
    comm_ring (perfect_closure K p) :=
  comm_ring.mk Add.add sorry 0 sorry sorry Neg.neg
    (ring.sub._default Add.add sorry 0 sorry sorry Neg.neg) sorry sorry comm_monoid.mul sorry
    comm_monoid.one sorry sorry sorry sorry sorry

theorem eq_iff' (K : Type u) [comm_ring K] (p : ℕ) [fact (nat.prime p)] [char_p K p] (x : ℕ × K)
    (y : ℕ × K) :
    mk K p x = mk K p y ↔
        ∃ (z : ℕ),
          nat.iterate (⇑(frobenius K p)) (prod.fst y + z) (prod.snd x) =
            nat.iterate (⇑(frobenius K p)) (prod.fst x + z) (prod.snd y) :=
  sorry

theorem nat_cast (K : Type u) [comm_ring K] (p : ℕ) [fact (nat.prime p)] [char_p K p] (n : ℕ)
    (x : ℕ) : ↑x = mk K p (n, ↑x) :=
  sorry

theorem int_cast (K : Type u) [comm_ring K] (p : ℕ) [fact (nat.prime p)] [char_p K p] (x : ℤ) :
    ↑x = mk K p (0, ↑x) :=
  sorry

theorem nat_cast_eq_iff (K : Type u) [comm_ring K] (p : ℕ) [fact (nat.prime p)] [char_p K p] (x : ℕ)
    (y : ℕ) : ↑x = ↑y ↔ ↑x = ↑y :=
  sorry

protected instance char_p (K : Type u) [comm_ring K] (p : ℕ) [fact (nat.prime p)] [char_p K p] :
    char_p (perfect_closure K p) p :=
  char_p.mk
    fun (x : ℕ) =>
      eq.mpr
        (id
          (Eq._oldrec (Eq.refl (↑x = 0 ↔ p ∣ x))
            (Eq.symm (propext (char_p.cast_eq_zero_iff K p x)))))
        (eq.mpr (id (Eq._oldrec (Eq.refl (↑x = 0 ↔ ↑x = 0)) (Eq.symm nat.cast_zero)))
          (eq.mpr (id (Eq._oldrec (Eq.refl (↑x = ↑0 ↔ ↑x = 0)) (propext (nat_cast_eq_iff K p x 0))))
            (eq.mpr (id (Eq._oldrec (Eq.refl (↑x = ↑0 ↔ ↑x = 0)) nat.cast_zero))
              (iff.refl (↑x = 0)))))

theorem frobenius_mk (K : Type u) [comm_ring K] (p : ℕ) [fact (nat.prime p)] [char_p K p]
    (x : ℕ × K) :
    coe_fn (frobenius (perfect_closure K p) p) (mk K p x) = mk K p (prod.fst x, prod.snd x ^ p) :=
  sorry

/-- Embedding of `K` into `perfect_closure K p` -/
def of (K : Type u) [comm_ring K] (p : ℕ) [fact (nat.prime p)] [char_p K p] :
    K →+* perfect_closure K p :=
  ring_hom.mk (fun (x : K) => mk K p (0, x)) sorry sorry sorry sorry

theorem of_apply (K : Type u) [comm_ring K] (p : ℕ) [fact (nat.prime p)] [char_p K p] (x : K) :
    coe_fn (of K p) x = mk K p (0, x) :=
  rfl

theorem eq_iff (K : Type u) [integral_domain K] (p : ℕ) [fact (nat.prime p)] [char_p K p]
    (x : ℕ × K) (y : ℕ × K) :
    Quot.mk (r K p) x = Quot.mk (r K p) y ↔
        nat.iterate (⇑(frobenius K p)) (prod.fst y) (prod.snd x) =
          nat.iterate (⇑(frobenius K p)) (prod.fst x) (prod.snd y) :=
  sorry

protected instance has_inv (K : Type u) [field K] (p : ℕ) [fact (nat.prime p)] [char_p K p] :
    has_inv (perfect_closure K p) :=
  has_inv.mk (Quot.lift (fun (x : ℕ × K) => Quot.mk (r K p) (prod.fst x, prod.snd x⁻¹)) sorry)

protected instance field (K : Type u) [field K] (p : ℕ) [fact (nat.prime p)] [char_p K p] :
    field (perfect_closure K p) :=
  field.mk comm_ring.add sorry comm_ring.zero sorry sorry comm_ring.neg comm_ring.sub sorry sorry
    comm_ring.mul sorry comm_ring.one sorry sorry sorry sorry sorry has_inv.inv sorry sorry sorry

protected instance perfect_ring (K : Type u) [field K] (p : ℕ) [fact (nat.prime p)] [char_p K p] :
    perfect_ring (perfect_closure K p) p :=
  perfect_ring.mk
    (fun (e : perfect_closure K p) =>
      lift_on e (fun (x : ℕ × K) => mk K p (prod.fst x + 1, prod.snd x)) sorry)
    sorry sorry

theorem eq_pth_root (K : Type u) [field K] (p : ℕ) [fact (nat.prime p)] [char_p K p] (x : ℕ × K) :
    mk K p x =
        nat.iterate (⇑(pth_root (perfect_closure K p) p)) (prod.fst x)
          (coe_fn (of K p) (prod.snd x)) :=
  sorry

/-- Given a field `K` of characteristic `p` and a perfect ring `L` of the same characteristic,
any homomorphism `K →+* L` can be lifted to `perfect_closure K p`. -/
def lift (K : Type u) [field K] (p : ℕ) [fact (nat.prime p)] [char_p K p] (L : Type v)
    [comm_semiring L] [char_p L p] [perfect_ring L p] : (K →+* L) ≃ (perfect_closure K p →+* L) :=
  equiv.mk
    (fun (f : K →+* L) =>
      ring_hom.mk
        (fun (e : perfect_closure K p) =>
          lift_on e
            (fun (x : ℕ × K) => nat.iterate (⇑(pth_root L p)) (prod.fst x) (coe_fn f (prod.snd x)))
            sorry)
        sorry sorry sorry sorry)
    (fun (f : perfect_closure K p →+* L) => ring_hom.comp f (of K p)) sorry sorry

end Mathlib


/-
Copyright (c) 2018 Reid Barton. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Reid Barton
-/
import topology.bases
import topology.dense_embedding

/-! # Stone-Čech compactification

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

Construction of the Stone-Čech compactification using ultrafilters.

Parts of the formalization are based on "Ultrafilters and Topology"
by Marius Stekelenburg, particularly section 5.
-/

noncomputable theory

open filter set
open_locale topology

universes u v

section ultrafilter
/- The set of ultrafilters on α carries a natural topology which makes
  it the Stone-Čech compactification of α (viewed as a discrete space). -/

/-- Basis for the topology on `ultrafilter α`. -/
def ultrafilter_basis (α : Type u) : set (set (ultrafilter α)) :=
range $ λ s : set α, {u | s ∈ u}

variables {α : Type u}

instance : topological_space (ultrafilter α) :=
topological_space.generate_from (ultrafilter_basis α)

lemma ultrafilter_basis_is_basis :
  topological_space.is_topological_basis (ultrafilter_basis α) :=
⟨begin
   rintros _ ⟨a, rfl⟩ _ ⟨b, rfl⟩ u ⟨ua, ub⟩,
   refine ⟨_, ⟨a ∩ b, rfl⟩, inter_mem ua ub, assume v hv, ⟨_, _⟩⟩;
     apply mem_of_superset hv; simp [inter_subset_right a b]
 end,
 eq_univ_of_univ_subset $ subset_sUnion_of_mem $
   ⟨univ, eq_univ_of_forall (λ u, univ_mem)⟩,
 rfl⟩

/-- The basic open sets for the topology on ultrafilters are open. -/
lemma ultrafilter_is_open_basic (s : set α) :
  is_open {u : ultrafilter α | s ∈ u} :=
ultrafilter_basis_is_basis.is_open ⟨s, rfl⟩

/-- The basic open sets for the topology on ultrafilters are also closed. -/
lemma ultrafilter_is_closed_basic (s : set α) :
  is_closed {u : ultrafilter α | s ∈ u} :=
begin
  rw ← is_open_compl_iff,
  convert ultrafilter_is_open_basic sᶜ,
  ext u,
  exact ultrafilter.compl_mem_iff_not_mem.symm
end

/-- Every ultrafilter `u` on `ultrafilter α` converges to a unique
  point of `ultrafilter α`, namely `mjoin u`. -/
lemma ultrafilter_converges_iff {u : ultrafilter (ultrafilter α)} {x : ultrafilter α} :
  ↑u ≤ 𝓝 x ↔ x = mjoin u :=
begin
  rw [eq_comm, ← ultrafilter.coe_le_coe],
  change ↑u ≤ 𝓝 x ↔ ∀ s ∈ x, {v : ultrafilter α | s ∈ v} ∈ u,
  simp only [topological_space.nhds_generate_from, le_infi_iff, ultrafilter_basis,
    le_principal_iff, mem_set_of_eq],
  split,
  { intros h a ha, exact h _ ⟨ha, a, rfl⟩ },
  { rintros h a ⟨xi, a, rfl⟩, exact h _ xi }
end

instance ultrafilter_compact : compact_space (ultrafilter α) :=
⟨is_compact_iff_ultrafilter_le_nhds.mpr $ assume f _,
   ⟨mjoin f, trivial, ultrafilter_converges_iff.mpr rfl⟩⟩

instance ultrafilter.t2_space : t2_space (ultrafilter α) :=
t2_iff_ultrafilter.mpr $ assume x y f fx fy,
  have hx : x = mjoin f, from ultrafilter_converges_iff.mp fx,
  have hy : y = mjoin f, from ultrafilter_converges_iff.mp fy,
  hx.trans hy.symm

instance : totally_disconnected_space (ultrafilter α) :=
begin
  rw totally_disconnected_space_iff_connected_component_singleton,
  intro A,
  simp only [set.eq_singleton_iff_unique_mem, mem_connected_component, true_and],
  intros B hB,
  rw ← ultrafilter.coe_le_coe,
  intros s hs,
  rw [connected_component_eq_Inter_clopen, set.mem_Inter] at hB,
  let Z := { F : ultrafilter α | s ∈ F },
  have hZ : is_clopen Z := ⟨ultrafilter_is_open_basic s, ultrafilter_is_closed_basic s⟩,
  exact hB ⟨Z, hZ, hs⟩,
end

lemma ultrafilter_comap_pure_nhds (b : ultrafilter α) : comap pure (𝓝 b) ≤ b :=
begin
  rw topological_space.nhds_generate_from,
  simp only [comap_infi, comap_principal],
  intros s hs,
  rw ←le_principal_iff,
  refine infi_le_of_le {u | s ∈ u} _,
  refine infi_le_of_le ⟨hs, ⟨s, rfl⟩⟩ _,
  exact principal_mono.2 (λ a, id)
end

section embedding

lemma ultrafilter_pure_injective : function.injective (pure : α → ultrafilter α) :=
begin
  intros x y h,
  have : {x} ∈ (pure x : ultrafilter α) := singleton_mem_pure,
  rw h at this,
  exact (mem_singleton_iff.mp (mem_pure.mp this)).symm
end

open topological_space

/-- The range of `pure : α → ultrafilter α` is dense in `ultrafilter α`. -/
lemma dense_range_pure : dense_range (pure : α → ultrafilter α) :=
λ x, mem_closure_iff_ultrafilter.mpr
       ⟨x.map pure, range_mem_map, ultrafilter_converges_iff.mpr (bind_pure x).symm⟩

/-- The map `pure : α → ultra_filter α` induces on `α` the discrete topology. -/
lemma induced_topology_pure :
  topological_space.induced (pure : α → ultrafilter α) ultrafilter.topological_space = ⊥ :=
begin
  apply eq_bot_of_singletons_open,
  intros x,
  use [{u : ultrafilter α | {x} ∈ u}, ultrafilter_is_open_basic _],
  simp,
end

/-- `pure : α → ultrafilter α` defines a dense inducing of `α` in `ultrafilter α`. -/
lemma dense_inducing_pure : @dense_inducing _ _ ⊥ _ (pure : α → ultrafilter α) :=
by letI : topological_space α := ⊥; exact ⟨⟨induced_topology_pure.symm⟩, dense_range_pure⟩

-- The following refined version will never be used

/-- `pure : α → ultrafilter α` defines a dense embedding of `α` in `ultrafilter α`. -/
lemma dense_embedding_pure : @dense_embedding _ _ ⊥ _ (pure : α → ultrafilter α) :=
by letI : topological_space α := ⊥ ;
exact { inj := ultrafilter_pure_injective, ..dense_inducing_pure }
end embedding

section extension
/- Goal: Any function `α → γ` to a compact Hausdorff space `γ` has a
  unique extension to a continuous function `ultrafilter α → γ`. We
  already know it must be unique because `α → ultrafilter α` is a
  dense embedding and `γ` is Hausdorff. For existence, we will invoke
  `dense_embedding.continuous_extend`. -/

variables {γ : Type*} [topological_space γ]

/-- The extension of a function `α → γ` to a function `ultrafilter α → γ`.
  When `γ` is a compact Hausdorff space it will be continuous. -/
def ultrafilter.extend (f : α → γ) : ultrafilter α → γ :=
by letI : topological_space α := ⊥; exact dense_inducing_pure.extend f

variables [t2_space γ]

lemma ultrafilter_extend_extends (f : α → γ) : ultrafilter.extend f ∘ pure = f :=
begin
  letI : topological_space α := ⊥,
  haveI : discrete_topology α := ⟨rfl⟩,
  exact funext (dense_inducing_pure.extend_eq continuous_of_discrete_topology)
end

variables  [compact_space γ]

lemma continuous_ultrafilter_extend (f : α → γ) : continuous (ultrafilter.extend f) :=
have ∀ (b : ultrafilter α), ∃ c, tendsto f (comap pure (𝓝 b)) (𝓝 c) := assume b,
  -- b.map f is an ultrafilter on γ, which is compact, so it converges to some c in γ.
  let ⟨c, _, h⟩ := is_compact_univ.ultrafilter_le_nhds (b.map f)
    (by rw [le_principal_iff]; exact univ_mem) in
  ⟨c, le_trans (map_mono (ultrafilter_comap_pure_nhds _)) h⟩,
begin
  letI : topological_space α := ⊥,
  haveI : normal_space γ := normal_of_compact_t2,
  exact dense_inducing_pure.continuous_extend this
end

/-- The value of `ultrafilter.extend f` on an ultrafilter `b` is the
  unique limit of the ultrafilter `b.map f` in `γ`. -/
lemma ultrafilter_extend_eq_iff {f : α → γ} {b : ultrafilter α} {c : γ} :
  ultrafilter.extend f b = c ↔ ↑(b.map f) ≤ 𝓝 c :=
⟨assume h, begin
   -- Write b as an ultrafilter limit of pure ultrafilters, and use
   -- the facts that ultrafilter.extend is a continuous extension of f.
   let b' : ultrafilter (ultrafilter α) := b.map pure,
   have t : ↑b' ≤ 𝓝 b,
     from ultrafilter_converges_iff.mpr (bind_pure _).symm,
   rw ←h,
   have := (continuous_ultrafilter_extend f).tendsto b,
   refine le_trans _ (le_trans (map_mono t) this),
   change _ ≤ map (ultrafilter.extend f ∘ pure) ↑b,
   rw ultrafilter_extend_extends,
   exact le_rfl
 end,
 assume h, by letI : topological_space α := ⊥; exact
   dense_inducing_pure.extend_eq_of_tendsto (le_trans (map_mono (ultrafilter_comap_pure_nhds _)) h)⟩

end extension

end ultrafilter

section stone_cech
/- Now, we start with a (not necessarily discrete) topological space α
  and we want to construct its Stone-Čech compactification. We can
  build it as a quotient of `ultrafilter α` by the relation which
  identifies two points if the extension of every continuous function
  α → γ to a compact Hausdorff space sends the two points to the same
  point of γ. -/

variables (α : Type u) [topological_space α]

instance stone_cech_setoid : setoid (ultrafilter α) :=
{ r := λ x y, ∀ (γ : Type u) [topological_space γ], by exactI
    ∀ [t2_space γ] [compact_space γ] (f : α → γ) (hf : continuous f),
    ultrafilter.extend f x = ultrafilter.extend f y,
  iseqv :=
    ⟨assume x γ tγ h₁ h₂ f hf, rfl,
     assume x y xy γ tγ h₁ h₂ f hf, by exactI (xy γ f hf).symm,
     assume x y z xy yz γ tγ h₁ h₂ f hf, by exactI (xy γ f hf).trans (yz γ f hf)⟩ }

/-- The Stone-Čech compactification of a topological space. -/
def stone_cech : Type u := quotient (stone_cech_setoid α)

variables {α}
instance : topological_space (stone_cech α) := by unfold stone_cech; apply_instance
instance [inhabited α] : inhabited (stone_cech α) := by unfold stone_cech; apply_instance

/-- The natural map from α to its Stone-Čech compactification. -/
def stone_cech_unit (x : α) : stone_cech α := ⟦pure x⟧

/-- The image of stone_cech_unit is dense. (But stone_cech_unit need
  not be an embedding, for example if α is not Hausdorff.) -/
lemma dense_range_stone_cech_unit : dense_range (stone_cech_unit : α → stone_cech α) :=
dense_range_pure.quotient

section extension

variables {γ : Type u} [topological_space γ] [t2_space γ] [compact_space γ]
variables {γ' : Type u} [topological_space γ'] [t2_space γ']
variables {f : α → γ} (hf : continuous f)

local attribute [elab_with_expected_type] quotient.lift

/-- The extension of a continuous function from α to a compact
  Hausdorff space γ to the Stone-Čech compactification of α. -/
def stone_cech_extend : stone_cech α → γ :=
quotient.lift (ultrafilter.extend f) (λ x y xy, xy γ f hf)

lemma stone_cech_extend_extends : stone_cech_extend hf ∘ stone_cech_unit = f :=
ultrafilter_extend_extends f

lemma continuous_stone_cech_extend : continuous (stone_cech_extend hf) :=
continuous_quot_lift _ (continuous_ultrafilter_extend f)

lemma stone_cech_hom_ext {g₁ g₂ : stone_cech α → γ'}
  (h₁ : continuous g₁) (h₂ : continuous g₂)
  (h : g₁ ∘ stone_cech_unit = g₂ ∘ stone_cech_unit) : g₁ = g₂ :=
begin
  apply continuous.ext_on dense_range_stone_cech_unit h₁ h₂,
  rintros x ⟨x, rfl⟩,
  apply (congr_fun h x)
end

end extension

lemma convergent_eqv_pure {u : ultrafilter α} {x : α} (ux : ↑u ≤ 𝓝 x) : u ≈ pure x :=
assume γ tγ h₁ h₂ f hf, begin
  resetI,
  transitivity f x, swap, symmetry,
  all_goals { refine ultrafilter_extend_eq_iff.mpr (le_trans (map_mono _) (hf.tendsto _)) },
  { apply pure_le_nhds }, { exact ux }
end

lemma continuous_stone_cech_unit : continuous (stone_cech_unit : α → stone_cech α) :=
continuous_iff_ultrafilter.mpr $ λ x g gx,
  have ↑(g.map pure) ≤ 𝓝 g,
    by rw ultrafilter_converges_iff; exact (bind_pure _).symm,
  have (g.map stone_cech_unit : filter (stone_cech α)) ≤ 𝓝 ⟦g⟧, from
    continuous_at_iff_ultrafilter.mp (continuous_quotient_mk.tendsto g) _ this,
  by rwa (show ⟦g⟧ = ⟦pure x⟧, from quotient.sound $ convergent_eqv_pure gx) at this

instance stone_cech.t2_space : t2_space (stone_cech α) :=
begin
  rw t2_iff_ultrafilter,
  rintros ⟨x⟩ ⟨y⟩ g gx gy,
  apply quotient.sound,
  intros γ tγ h₁ h₂ f hf,
  resetI,
  let ff := stone_cech_extend hf,
  change ff ⟦x⟧ = ff ⟦y⟧,
  have lim := λ (z : ultrafilter α) (gz : (g : filter (stone_cech α)) ≤ 𝓝 ⟦z⟧),
    ((continuous_stone_cech_extend hf).tendsto _).mono_left gz,
  exact tendsto_nhds_unique (lim x gx) (lim y gy)
end

instance stone_cech.compact_space : compact_space (stone_cech α) :=
quotient.compact_space

end stone_cech


/-
Copyright © 2020 Nicolò Cavalleri. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Nicolò Cavalleri

! This file was ported from Lean 3 source module geometry.manifold.algebra.left_invariant_derivation
! leanprover-community/mathlib commit d1bd9c5df2867c1cb463bc6364446d57bdd9f7f1
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Geometry.Manifold.DerivationBundle

/-!

# Left invariant derivations

In this file we define the concept of left invariant derivation for a Lie group. The concept is
analogous to the more classical concept of left invariant vector fields, and it holds that the
derivation associated to a vector field is left invariant iff the field is.

Moreover we prove that `left_invariant_derivation I G` has the structure of a Lie algebra, hence
implementing one of the possible definitions of the Lie algebra attached to a Lie group.

-/

noncomputable section

open LieGroup Manifold Derivation

variable {𝕜 : Type _} [NontriviallyNormedField 𝕜] {E : Type _} [NormedAddCommGroup E]
  [NormedSpace 𝕜 E] {H : Type _} [TopologicalSpace H] (I : ModelWithCorners 𝕜 E H) (G : Type _)
  [TopologicalSpace G] [ChartedSpace H G] [Monoid G] [HasSmoothMul I G] (g h : G)

-- Generate trivial has_sizeof instance. It prevents weird type class inference timeout problems
@[local nolint instance_priority, local instance]
private def disable_has_sizeof {α} : SizeOf α :=
  ⟨fun _ => 0⟩
#align disable_has_sizeof disable_has_sizeof

/-- Left-invariant global derivations.

A global derivation is left-invariant if it is equal to its pullback along left multiplication by
an arbitrary element of `G`.
-/
structure LeftInvariantDerivation extends Derivation 𝕜 C^∞⟮I, G; 𝕜⟯ C^∞⟮I, G; 𝕜⟯ where
  left_invariant'' :
    ∀ g,
      𝒅ₕ (smoothLeftMul_one I g) (Derivation.evalAt 1 to_derivation) =
        Derivation.evalAt g to_derivation
#align left_invariant_derivation LeftInvariantDerivation

variable {I G}

namespace LeftInvariantDerivation

instance : Coe (LeftInvariantDerivation I G) (Derivation 𝕜 C^∞⟮I, G; 𝕜⟯ C^∞⟮I, G; 𝕜⟯) :=
  ⟨fun X => X.toDerivation⟩

instance : CoeFun (LeftInvariantDerivation I G) fun _ => C^∞⟮I, G; 𝕜⟯ → C^∞⟮I, G; 𝕜⟯ :=
  ⟨fun X => X.toDerivation.toFun⟩

variable {M : Type _} [TopologicalSpace M] [ChartedSpace H M] {x : M} {r : 𝕜}
  {X Y : LeftInvariantDerivation I G} {f f' : C^∞⟮I, G; 𝕜⟯}

theorem toFun_eq_coe : X.toFun = ⇑X :=
  rfl
#align left_invariant_derivation.to_fun_eq_coe LeftInvariantDerivation.toFun_eq_coe

theorem coe_to_linearMap : ⇑(X : C^∞⟮I, G; 𝕜⟯ →ₗ[𝕜] C^∞⟮I, G; 𝕜⟯) = X :=
  rfl
#align left_invariant_derivation.coe_to_linear_map LeftInvariantDerivation.coe_to_linearMap

@[simp]
theorem toDerivation_eq_coe : X.toDerivation = X :=
  rfl
#align left_invariant_derivation.to_derivation_eq_coe LeftInvariantDerivation.toDerivation_eq_coe

theorem coe_injective :
    @Function.Injective (LeftInvariantDerivation I G) (_ → C^⊤⟮I, G; 𝕜⟯) coeFn := fun X Y h =>
  by
  cases X
  cases Y
  congr
  exact Derivation.coe_injective h
#align left_invariant_derivation.coe_injective LeftInvariantDerivation.coe_injective

@[ext]
theorem ext (h : ∀ f, X f = Y f) : X = Y :=
  coe_injective <| funext h
#align left_invariant_derivation.ext LeftInvariantDerivation.ext

variable (X Y f)

theorem coe_derivation :
    ⇑(X : Derivation 𝕜 C^∞⟮I, G; 𝕜⟯ C^∞⟮I, G; 𝕜⟯) = (X : C^∞⟮I, G; 𝕜⟯ → C^∞⟮I, G; 𝕜⟯) :=
  rfl
#align left_invariant_derivation.coe_derivation LeftInvariantDerivation.coe_derivation

theorem coe_derivation_injective :
    Function.Injective
      (coe : LeftInvariantDerivation I G → Derivation 𝕜 C^∞⟮I, G; 𝕜⟯ C^∞⟮I, G; 𝕜⟯) :=
  fun X Y h => by
  cases X
  cases Y
  congr
  exact h
#align left_invariant_derivation.coe_derivation_injective LeftInvariantDerivation.coe_derivation_injective

/-- Premature version of the lemma. Prefer using `left_invariant` instead. -/
theorem left_invariant' :
    𝒅ₕ (smoothLeftMul_one I g) (Derivation.evalAt (1 : G) ↑X) = Derivation.evalAt g ↑X :=
  left_invariant'' X g
#align left_invariant_derivation.left_invariant' LeftInvariantDerivation.left_invariant'

@[simp]
theorem map_add : X (f + f') = X f + X f' :=
  Derivation.map_add X f f'
#align left_invariant_derivation.map_add LeftInvariantDerivation.map_add

@[simp]
theorem map_zero : X 0 = 0 :=
  Derivation.map_zero X
#align left_invariant_derivation.map_zero LeftInvariantDerivation.map_zero

@[simp]
theorem map_neg : X (-f) = -X f :=
  Derivation.map_neg X f
#align left_invariant_derivation.map_neg LeftInvariantDerivation.map_neg

@[simp]
theorem map_sub : X (f - f') = X f - X f' :=
  Derivation.map_sub X f f'
#align left_invariant_derivation.map_sub LeftInvariantDerivation.map_sub

@[simp]
theorem map_smul : X (r • f) = r • X f :=
  Derivation.map_smul X r f
#align left_invariant_derivation.map_smul LeftInvariantDerivation.map_smul

@[simp]
theorem leibniz : X (f * f') = f • X f' + f' • X f :=
  X.leibniz' _ _
#align left_invariant_derivation.leibniz LeftInvariantDerivation.leibniz

instance : Zero (LeftInvariantDerivation I G) :=
  ⟨⟨0, fun g => by simp only [LinearMap.map_zero, Derivation.coe_zero]⟩⟩

instance : Inhabited (LeftInvariantDerivation I G) :=
  ⟨0⟩

instance : Add (LeftInvariantDerivation I G)
    where add X Y :=
    ⟨X + Y, fun g => by
      simp only [LinearMap.map_add, Derivation.coe_add, left_invariant', Pi.add_apply]⟩

instance : Neg (LeftInvariantDerivation I G) where neg X := ⟨-X, fun g => by simp [left_invariant']⟩

instance : Sub (LeftInvariantDerivation I G)
    where sub X Y := ⟨X - Y, fun g => by simp [left_invariant']⟩

@[simp]
theorem coe_add : ⇑(X + Y) = X + Y :=
  rfl
#align left_invariant_derivation.coe_add LeftInvariantDerivation.coe_add

@[simp]
theorem coe_zero : ⇑(0 : LeftInvariantDerivation I G) = 0 :=
  rfl
#align left_invariant_derivation.coe_zero LeftInvariantDerivation.coe_zero

@[simp]
theorem coe_neg : ⇑(-X) = -X :=
  rfl
#align left_invariant_derivation.coe_neg LeftInvariantDerivation.coe_neg

@[simp]
theorem coe_sub : ⇑(X - Y) = X - Y :=
  rfl
#align left_invariant_derivation.coe_sub LeftInvariantDerivation.coe_sub

@[simp, norm_cast]
theorem lift_add : (↑(X + Y) : Derivation 𝕜 C^∞⟮I, G; 𝕜⟯ C^∞⟮I, G; 𝕜⟯) = X + Y :=
  rfl
#align left_invariant_derivation.lift_add LeftInvariantDerivation.lift_add

@[simp, norm_cast]
theorem lift_zero :
    (↑(0 : LeftInvariantDerivation I G) : Derivation 𝕜 C^∞⟮I, G; 𝕜⟯ C^∞⟮I, G; 𝕜⟯) = 0 :=
  rfl
#align left_invariant_derivation.lift_zero LeftInvariantDerivation.lift_zero

instance hasNatScalar : SMul ℕ (LeftInvariantDerivation I G)
    where smul r X := ⟨r • X, fun g => by simp_rw [LinearMap.map_smul_of_tower, left_invariant']⟩
#align left_invariant_derivation.has_nat_scalar LeftInvariantDerivation.hasNatScalar

instance hasIntScalar : SMul ℤ (LeftInvariantDerivation I G)
    where smul r X := ⟨r • X, fun g => by simp_rw [LinearMap.map_smul_of_tower, left_invariant']⟩
#align left_invariant_derivation.has_int_scalar LeftInvariantDerivation.hasIntScalar

instance : AddCommGroup (LeftInvariantDerivation I G) :=
  coe_injective.AddCommGroup _ coe_zero coe_add coe_neg coe_sub (fun _ _ => rfl) fun _ _ => rfl

instance : SMul 𝕜 (LeftInvariantDerivation I G)
    where smul r X := ⟨r • X, fun g => by simp_rw [LinearMap.map_smul, left_invariant']⟩

variable (r X)

@[simp]
theorem coe_smul : ⇑(r • X) = r • X :=
  rfl
#align left_invariant_derivation.coe_smul LeftInvariantDerivation.coe_smul

@[simp]
theorem lift_smul (k : 𝕜) : (↑(k • X) : Derivation 𝕜 C^∞⟮I, G; 𝕜⟯ C^∞⟮I, G; 𝕜⟯) = k • X :=
  rfl
#align left_invariant_derivation.lift_smul LeftInvariantDerivation.lift_smul

variable (I G)

/-- The coercion to function is a monoid homomorphism. -/
@[simps]
def coeFnAddMonoidHom : LeftInvariantDerivation I G →+ C^∞⟮I, G; 𝕜⟯ → C^∞⟮I, G; 𝕜⟯ :=
  ⟨fun X => X.toDerivation.toFun, coe_zero, coe_add⟩
#align left_invariant_derivation.coe_fn_add_monoid_hom LeftInvariantDerivation.coeFnAddMonoidHom

variable {I G}

instance : Module 𝕜 (LeftInvariantDerivation I G) :=
  coe_injective.Module _ (coeFnAddMonoidHom I G) coe_smul

/-- Evaluation at a point for left invariant derivation. Same thing as for generic global
derivations (`derivation.eval_at`). -/
def evalAt : LeftInvariantDerivation I G →ₗ[𝕜] PointDerivation I g
    where
  toFun X := Derivation.evalAt g ↑X
  map_add' X Y := rfl
  map_smul' k X := rfl
#align left_invariant_derivation.eval_at LeftInvariantDerivation.evalAt

theorem evalAt_apply : evalAt g X f = (X f) g :=
  rfl
#align left_invariant_derivation.eval_at_apply LeftInvariantDerivation.evalAt_apply

@[simp]
theorem evalAt_coe : Derivation.evalAt g ↑X = evalAt g X :=
  rfl
#align left_invariant_derivation.eval_at_coe LeftInvariantDerivation.evalAt_coe

theorem left_invariant : 𝒅ₕ (smoothLeftMul_one I g) (evalAt (1 : G) X) = evalAt g X :=
  X.left_invariant'' g
#align left_invariant_derivation.left_invariant LeftInvariantDerivation.left_invariant

theorem evalAt_mul : evalAt (g * h) X = 𝒅ₕ (L_apply I g h) (evalAt h X) :=
  by
  ext f
  rw [← left_invariant, apply_hfdifferential, apply_hfdifferential, L_mul, fdifferential_comp,
    apply_fdifferential, LinearMap.comp_apply, apply_fdifferential, ← apply_hfdifferential,
    left_invariant]
#align left_invariant_derivation.eval_at_mul LeftInvariantDerivation.evalAt_mul

theorem comp_L : (X f).comp (𝑳 I g) = X (f.comp (𝑳 I g)) := by
  ext h <;>
    rw [ContMdiffMap.comp_apply, L_apply, ← eval_at_apply, eval_at_mul, apply_hfdifferential,
      apply_fdifferential, eval_at_apply]
#align left_invariant_derivation.comp_L LeftInvariantDerivation.comp_L

instance : Bracket (LeftInvariantDerivation I G) (LeftInvariantDerivation I G)
    where bracket X Y :=
    ⟨⁅(X : Derivation 𝕜 C^∞⟮I, G; 𝕜⟯ C^∞⟮I, G; 𝕜⟯), Y⁆, fun g =>
      by
      ext f
      have hX := Derivation.congr_fun (left_invariant' g X) (Y f)
      have hY := Derivation.congr_fun (left_invariant' g Y) (X f)
      rw [apply_hfdifferential, apply_fdifferential, Derivation.evalAt_apply] at hX hY⊢
      rw [comp_L] at hX hY
      rw [Derivation.commutator_apply, SmoothMap.coe_sub, Pi.sub_apply, coe_derivation]
      rw [coe_derivation] at hX hY⊢
      rw [hX, hY]
      rfl⟩

@[simp]
theorem commutator_coe_derivation :
    ⇑⁅X, Y⁆ =
      (⁅(X : Derivation 𝕜 C^∞⟮I, G; 𝕜⟯ C^∞⟮I, G; 𝕜⟯), Y⁆ :
        Derivation 𝕜 C^∞⟮I, G; 𝕜⟯ C^∞⟮I, G; 𝕜⟯) :=
  rfl
#align left_invariant_derivation.commutator_coe_derivation LeftInvariantDerivation.commutator_coe_derivation

theorem commutator_apply : ⁅X, Y⁆ f = X (Y f) - Y (X f) :=
  rfl
#align left_invariant_derivation.commutator_apply LeftInvariantDerivation.commutator_apply

instance : LieRing (LeftInvariantDerivation I G)
    where
  add_lie X Y Z := by
    ext1
    simp only [commutator_apply, coe_add, Pi.add_apply, LinearMap.map_add,
      LeftInvariantDerivation.map_add]
    ring
  lie_add X Y Z := by
    ext1
    simp only [commutator_apply, coe_add, Pi.add_apply, LinearMap.map_add,
      LeftInvariantDerivation.map_add]
    ring
  lie_self X := by
    ext1
    simp only [commutator_apply, sub_self]
    rfl
  leibniz_lie X Y Z := by
    ext1
    simp only [commutator_apply, coe_add, coe_sub, map_sub, Pi.add_apply]
    ring

instance : LieAlgebra 𝕜 (LeftInvariantDerivation I G)
    where lie_smul r Y Z := by
    ext1
    simp only [commutator_apply, map_smul, smul_sub, coe_smul, Pi.smul_apply]

end LeftInvariantDerivation


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

! This file was ported from Lean 3 source module group_theory.schur_zassenhaus
! leanprover-community/mathlib commit d57133e49cf06508700ef69030cd099917e0f0de
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.GroupTheory.Sylow
import Mathbin.GroupTheory.Transfer

/-!
# The Schur-Zassenhaus Theorem

In this file we prove the Schur-Zassenhaus theorem.

## Main results

- `exists_right_complement'_of_coprime` : The **Schur-Zassenhaus** theorem:
  If `H : subgroup G` is normal and has order coprime to its index,
  then there exists a subgroup `K` which is a (right) complement of `H`.
- `exists_left_complement'_of_coprime`  The **Schur-Zassenhaus** theorem:
  If `H : subgroup G` is normal and has order coprime to its index,
  then there exists a subgroup `K` which is a (left) complement of `H`.
-/

open BigOperators

namespace Subgroup

section SchurZassenhausAbelian

open MulOpposite MulAction Subgroup.leftTransversals MemLeftTransversals

variable {G : Type _} [Group G] (H : Subgroup G) [IsCommutative H] [FiniteIndex H]
  (α β : leftTransversals (H : Set G))

/-- The quotient of the transversals of an abelian normal `N` by the `diff` relation. -/
def QuotientDiff :=
  Quotient
    (Setoid.mk (fun α β => diff (MonoidHom.id H) α β = 1)
      ⟨fun α => diff_self (MonoidHom.id H) α, fun α β h => by rw [← diff_inv, h, inv_one],
        fun α β γ h h' => by rw [← diff_mul_diff, h, h', one_mul]⟩)
#align subgroup.quotient_diff Subgroup.QuotientDiff

instance : Inhabited H.QuotientDiff :=
  Quotient.inhabited _

theorem smul_diff_smul' [hH : Normal H] (g : Gᵐᵒᵖ) :
    diff (MonoidHom.id H) (g • α) (g • β) =
      ⟨g.unop⁻¹ * (diff (MonoidHom.id H) α β : H) * g.unop,
        hH.mem_comm ((congr_arg (· ∈ H) (mul_inv_cancel_left _ _)).mpr (SetLike.coe_mem _))⟩ :=
  by
  letI := H.fintype_quotient_of_finite_index
  let ϕ : H →* H :=
    { toFun := fun h =>
        ⟨g.unop⁻¹ * h * g.unop,
          hH.mem_comm ((congr_arg (· ∈ H) (mul_inv_cancel_left _ _)).mpr (SetLike.coe_mem _))⟩
      map_one' := by rw [Subtype.ext_iff, coe_mk, coe_one, mul_one, inv_mul_self]
      map_mul' := fun h₁ h₂ => by
        rw [Subtype.ext_iff, coe_mk, coe_mul, coe_mul, coe_mk, coe_mk, mul_assoc, mul_assoc,
          mul_assoc, mul_assoc, mul_assoc, mul_inv_cancel_left] }
  refine'
    Eq.trans
      (Finset.prod_bij' (fun q _ => g⁻¹ • q) (fun q _ => Finset.mem_univ _)
        (fun q _ => Subtype.ext _) (fun q _ => g • q) (fun q _ => Finset.mem_univ _)
        (fun q _ => smul_inv_smul g q) fun q _ => inv_smul_smul g q)
      (map_prod ϕ _ _).symm
  simp_rw [MonoidHom.id_apply, MonoidHom.coe_mk, coe_mk, smul_apply_eq_smul_apply_inv_smul,
    smul_eq_mul_unop, mul_inv_rev, mul_assoc]
#align subgroup.smul_diff_smul' Subgroup.smul_diff_smul'

variable {H} [Normal H]

instance : MulAction G H.QuotientDiff
    where
  smul g :=
    Quotient.map' (fun α => op g⁻¹ • α) fun α β h =>
      Subtype.ext
        (by
          rwa [smul_diff_smul', coe_mk, coe_one, mul_eq_one_iff_eq_inv, mul_right_eq_self, ←
            coe_one, ← Subtype.ext_iff])
  mul_smul g₁ g₂ q :=
    Quotient.inductionOn' q fun T =>
      congr_arg Quotient.mk'' (by rw [mul_inv_rev] <;> exact mul_smul (op g₁⁻¹) (op g₂⁻¹) T)
  one_smul q :=
    Quotient.inductionOn' q fun T =>
      congr_arg Quotient.mk'' (by rw [inv_one] <;> apply one_smul Gᵐᵒᵖ T)

theorem smul_diff' (h : H) :
    diff (MonoidHom.id H) α (op (h : G) • β) = diff (MonoidHom.id H) α β * h ^ H.index :=
  by
  letI := H.fintype_quotient_of_finite_index
  rw [diff, diff, index_eq_card, ← Finset.card_univ, ← Finset.prod_const, ← Finset.prod_mul_distrib]
  refine' Finset.prod_congr rfl fun q _ => _
  simp_rw [Subtype.ext_iff, MonoidHom.id_apply, coe_mul, coe_mk, mul_assoc, mul_right_inj]
  rw [smul_apply_eq_smul_apply_inv_smul, smul_eq_mul_unop, unop_op, mul_left_inj, ← Subtype.ext_iff,
    Equiv.apply_eq_iff_eq, inv_smul_eq_iff]
  exact self_eq_mul_right.mpr ((QuotientGroup.eq_one_iff _).mpr h.2)
#align subgroup.smul_diff' Subgroup.smul_diff'

theorem eq_one_of_smul_eq_one (hH : Nat.coprime (Nat.card H) H.index) (α : H.QuotientDiff) (h : H) :
    h • α = α → h = 1 :=
  Quotient.inductionOn' α fun α hα =>
    (powCoprime hH).Injective <|
      calc
        h ^ H.index = diff (MonoidHom.id H) (op ((h⁻¹ : H) : G) • α) α := by
          rw [← diff_inv, smul_diff', diff_self, one_mul, inv_pow, inv_inv]
        _ = 1 ^ H.index := (Quotient.exact' hα).trans (one_pow H.index).symm

#align subgroup.eq_one_of_smul_eq_one Subgroup.eq_one_of_smul_eq_one

theorem exists_smul_eq (hH : Nat.coprime (Nat.card H) H.index) (α β : H.QuotientDiff) :
    ∃ h : H, h • α = β :=
  Quotient.inductionOn' α
    (Quotient.inductionOn' β fun β α =>
      Exists.imp (fun n => Quotient.sound')
        ⟨(powCoprime hH).symm (diff (MonoidHom.id H) β α),
          (diff_inv _ _ _).symm.trans
            (inv_eq_one.mpr
              ((smul_diff' β α ((powCoprime hH).symm (diff (MonoidHom.id H) β α))⁻¹).trans
                (by rw [inv_pow, ← powCoprime_apply hH, Equiv.apply_symm_apply, mul_inv_self])))⟩)
#align subgroup.exists_smul_eq Subgroup.exists_smul_eq

theorem isComplement'_stabilizer_of_coprime {α : H.QuotientDiff}
    (hH : Nat.coprime (Nat.card H) H.index) : IsComplement' H (stabilizer G α) :=
  isComplement'_stabilizer α (eq_one_of_smul_eq_one hH α) fun g => exists_smul_eq hH (g • α) α
#align subgroup.is_complement'_stabilizer_of_coprime Subgroup.isComplement'_stabilizer_of_coprime

/-- Do not use this lemma: It is made obsolete by `exists_right_complement'_of_coprime` -/
private theorem exists_right_complement'_of_coprime_aux (hH : Nat.coprime (Nat.card H) H.index) :
    ∃ K : Subgroup G, IsComplement' H K :=
  instNonempty.elim fun α => ⟨stabilizer G α, isComplement'_stabilizer_of_coprime hH⟩
#align subgroup.exists_right_complement'_of_coprime_aux subgroup.exists_right_complement'_of_coprime_aux

end SchurZassenhausAbelian

open Classical

universe u

namespace SchurZassenhausInduction

/-! ## Proof of the Schur-Zassenhaus theorem

In this section, we prove the Schur-Zassenhaus theorem.
The proof is by contradiction. We assume that `G` is a minimal counterexample to the theorem.
-/

variable {G : Type u} [Group G] [Fintype G] {N : Subgroup G} [Normal N]
  (h1 : Nat.coprime (Fintype.card N) N.index)
  (h2 :
    ∀ (G' : Type u) [Group G'] [Fintype G'],
      ∀ (hG'3 : Fintype.card G' < Fintype.card G) {N' : Subgroup G'} [N'.Normal]
        (hN : Nat.coprime (Fintype.card N') N'.index), ∃ H' : Subgroup G', is_complement' N' H')
  (h3 : ∀ H : Subgroup G, ¬IsComplement' N H)

include h1 h2 h3

/-! We will arrive at a contradiction via the following steps:
 * step 0: `N` (the normal Hall subgroup) is nontrivial.
 * step 1: If `K` is a subgroup of `G` with `K ⊔ N = ⊤`, then `K = ⊤`.
 * step 2: `N` is a minimal normal subgroup, phrased in terms of subgroups of `G`.
 * step 3: `N` is a minimal normal subgroup, phrased in terms of subgroups of `N`.
 * step 4: `p` (`min_fact (fintype.card N)`) is prime (follows from step0).
 * step 5: `P` (a Sylow `p`-subgroup of `N`) is nontrivial.
 * step 6: `N` is a `p`-group (applies step 1 to the normalizer of `P` in `G`).
 * step 7: `N` is abelian (applies step 3 to the center of `N`).
-/

/-- Do not use this lemma: It is made obsolete by `exists_right_complement'_of_coprime` -/
@[nolint unused_arguments]
private theorem step0 : N ≠ ⊥ := by
  rintro rfl
  exact h3 ⊤ is_complement'_bot_top
#align subgroup.schur_zassenhaus_induction.step0 subgroup.schur_zassenhaus_induction.step0

/-- Do not use this lemma: It is made obsolete by `exists_right_complement'_of_coprime` -/
private theorem step1 (K : Subgroup G) (hK : K ⊔ N = ⊤) : K = ⊤ :=
  by
  contrapose! h3
  have h4 : (N.comap K.subtype).index = N.index :=
    by
    rw [← N.relindex_top_right, ← hK]
    exact (relindex_sup_right K N).symm
  have h5 : Fintype.card K < Fintype.card G :=
    by
    rw [← K.index_mul_card]
    exact lt_mul_of_one_lt_left Fintype.card_pos (one_lt_index_of_ne_top h3)
  have h6 : Nat.coprime (Fintype.card (N.comap K.subtype)) (N.comap K.subtype).index :=
    by
    rw [h4]
    exact h1.coprime_dvd_left (card_comap_dvd_of_injective N K.subtype Subtype.coe_injective)
  obtain ⟨H, hH⟩ := h2 K h5 h6
  replace hH : Fintype.card (H.map K.subtype) = N.index :=
    ((Set.card_image_of_injective _ Subtype.coe_injective).trans
          (mul_left_injective₀ Fintype.card_ne_zero
            (hH.symm.card_mul.trans (N.comap K.subtype).index_mul_card.symm))).trans
      h4
  have h7 : Fintype.card N * Fintype.card (H.map K.subtype) = Fintype.card G := by
    rw [hH, ← N.index_mul_card, mul_comm]
  have h8 : (Fintype.card N).coprime (Fintype.card (H.map K.subtype)) := by rwa [hH]
  exact ⟨H.map K.subtype, is_complement'_of_coprime h7 h8⟩
#align subgroup.schur_zassenhaus_induction.step1 subgroup.schur_zassenhaus_induction.step1

/-- Do not use this lemma: It is made obsolete by `exists_right_complement'_of_coprime` -/
private theorem step2 (K : Subgroup G) [K.Normal] (hK : K ≤ N) : K = ⊥ ∨ K = N :=
  by
  have : Function.Surjective (QuotientGroup.mk' K) := Quotient.surjective_Quotient_mk''
  have h4 := step1 h1 h2 h3
  contrapose! h4
  have h5 : Fintype.card (G ⧸ K) < Fintype.card G :=
    by
    rw [← index_eq_card, ← K.index_mul_card]
    refine'
      lt_mul_of_one_lt_right (Nat.pos_of_ne_zero index_ne_zero_of_finite)
        (K.one_lt_card_iff_ne_bot.mpr h4.1)
  have h6 :
    Nat.coprime (Fintype.card (N.map (QuotientGroup.mk' K))) (N.map (QuotientGroup.mk' K)).index :=
    by
    have index_map := N.index_map_eq this (by rwa [QuotientGroup.ker_mk'])
    have index_pos : 0 < N.index := Nat.pos_of_ne_zero index_ne_zero_of_finite
    rw [index_map]
    refine' h1.coprime_dvd_left _
    rw [← Nat.mul_dvd_mul_iff_left index_pos, index_mul_card, ← index_map, index_mul_card]
    exact K.card_quotient_dvd_card
  obtain ⟨H, hH⟩ := h2 (G ⧸ K) h5 h6
  refine' ⟨H.comap (QuotientGroup.mk' K), _, _⟩
  · have key : (N.map (QuotientGroup.mk' K)).comap (QuotientGroup.mk' K) = N :=
      by
      refine' comap_map_eq_self _
      rwa [QuotientGroup.ker_mk']
    rwa [← key, comap_sup_eq, hH.symm.sup_eq_top, comap_top]
  · rw [← comap_top (QuotientGroup.mk' K)]
    intro hH'
    rw [comap_injective this hH', is_complement'_top_right, map_eq_bot_iff,
      QuotientGroup.ker_mk'] at hH
    · exact h4.2 (le_antisymm hK hH)
#align subgroup.schur_zassenhaus_induction.step2 subgroup.schur_zassenhaus_induction.step2

/-- Do not use this lemma: It is made obsolete by `exists_right_complement'_of_coprime` -/
private theorem step3 (K : Subgroup N) [(K.map N.Subtype).Normal] : K = ⊥ ∨ K = ⊤ :=
  by
  have key := step2 h1 h2 h3 (K.map N.subtype) K.map_subtype_le
  rw [← map_bot N.subtype] at key
  conv at key =>
    congr
    skip
    rhs
    rw [← N.subtype_range, N.subtype.range_eq_map]
  have inj := map_injective N.subtype_injective
  rwa [inj.eq_iff, inj.eq_iff] at key
#align subgroup.schur_zassenhaus_induction.step3 subgroup.schur_zassenhaus_induction.step3

/-- Do not use this lemma: It is made obsolete by `exists_right_complement'_of_coprime` -/
private theorem step4 : (Fintype.card N).minFac.Prime :=
  Nat.minFac_prime (N.one_lt_card_iff_ne_bot.mpr (step0 h1 h2 h3)).ne'
#align subgroup.schur_zassenhaus_induction.step4 subgroup.schur_zassenhaus_induction.step4

/-- Do not use this lemma: It is made obsolete by `exists_right_complement'_of_coprime` -/
private theorem step5 {P : Sylow (Fintype.card N).minFac N} : P.1 ≠ ⊥ :=
  haveI : Fact (Fintype.card N).minFac.Prime := ⟨step4 h1 h2 h3⟩
  P.ne_bot_of_dvd_card (Fintype.card N).minFac_dvd
#align subgroup.schur_zassenhaus_induction.step5 subgroup.schur_zassenhaus_induction.step5

/-- Do not use this lemma: It is made obsolete by `exists_right_complement'_of_coprime` -/
private theorem step6 : IsPGroup (Fintype.card N).minFac N :=
  by
  haveI : Fact (Fintype.card N).minFac.Prime := ⟨step4 h1 h2 h3⟩
  refine' sylow.nonempty.elim fun P => P.2.ofSurjective P.1.Subtype _
  rw [← MonoidHom.range_top_iff_surjective, subtype_range]
  haveI : (P.1.map N.subtype).Normal :=
    normalizer_eq_top.mp (step1 h1 h2 h3 (P.1.map N.subtype).normalizer P.normalizer_sup_eq_top)
  exact (step3 h1 h2 h3 P.1).resolve_left (step5 h1 h2 h3)
#align subgroup.schur_zassenhaus_induction.step6 subgroup.schur_zassenhaus_induction.step6

/-- Do not use this lemma: It is made obsolete by `exists_right_complement'_of_coprime` -/
theorem step7 : IsCommutative N :=
  by
  haveI := N.bot_or_nontrivial.resolve_left (step0 h1 h2 h3)
  haveI : Fact (Fintype.card N).minFac.Prime := ⟨step4 h1 h2 h3⟩
  exact
    ⟨⟨fun g h =>
        eq_top_iff.mp ((step3 h1 h2 h3 N.center).resolve_left (step6 h1 h2 h3).bot_lt_center.ne')
          (mem_top h) g⟩⟩
#align subgroup.schur_zassenhaus_induction.step7 Subgroup.SchurZassenhausInduction.step7

end SchurZassenhausInduction

variable {n : ℕ} {G : Type u} [Group G]

/-- Do not use this lemma: It is made obsolete by `exists_right_complement'_of_coprime` -/
private theorem exists_right_complement'_of_coprime_aux' [Fintype G] (hG : Fintype.card G = n)
    {N : Subgroup G} [N.Normal] (hN : Nat.coprime (Fintype.card N) N.index) :
    ∃ H : Subgroup G, IsComplement' N H := by
  revert G
  apply Nat.strong_induction_on n
  rintro n ih G _ _ rfl N _ hN
  refine' not_forall_not.mp fun h3 => _
  haveI :=
    schur_zassenhaus_induction.step7 hN
      (fun G' _ _ hG' => by
        apply ih _ hG'
        rfl)
      h3
  rw [← Nat.card_eq_fintype_card] at hN
  exact not_exists_of_forall_not h3 (exists_right_complement'_of_coprime_aux hN)
#align subgroup.exists_right_complement'_of_coprime_aux' subgroup.exists_right_complement'_of_coprime_aux'

/-- **Schur-Zassenhaus** for normal subgroups:
  If `H : subgroup G` is normal, and has order coprime to its index, then there exists a
  subgroup `K` which is a (right) complement of `H`. -/
theorem exists_right_complement'_of_coprime_of_fintype [Fintype G] {N : Subgroup G} [N.Normal]
    (hN : Nat.coprime (Fintype.card N) N.index) : ∃ H : Subgroup G, IsComplement' N H :=
  exists_right_complement'_of_coprime_aux' rfl hN
#align subgroup.exists_right_complement'_of_coprime_of_fintype Subgroup.exists_right_complement'_of_coprime_of_fintype

/-- **Schur-Zassenhaus** for normal subgroups:
  If `H : subgroup G` is normal, and has order coprime to its index, then there exists a
  subgroup `K` which is a (right) complement of `H`. -/
theorem exists_right_complement'_of_coprime {N : Subgroup G} [N.Normal]
    (hN : Nat.coprime (Nat.card N) N.index) : ∃ H : Subgroup G, IsComplement' N H :=
  by
  by_cases hN1 : Nat.card N = 0
  · rw [hN1, Nat.coprime_zero_left, index_eq_one] at hN
    rw [hN]
    exact ⟨⊥, is_complement'_top_bot⟩
  by_cases hN2 : N.index = 0
  · rw [hN2, Nat.coprime_zero_right] at hN
    haveI := (cardinal.to_nat_eq_one_iff_unique.mp hN).1
    rw [N.eq_bot_of_subsingleton]
    exact ⟨⊤, is_complement'_bot_top⟩
  have hN3 : Nat.card G ≠ 0 := by
    rw [← N.card_mul_index]
    exact mul_ne_zero hN1 hN2
  haveI :=
    (cardinal.lt_aleph_0_iff_fintype.mp
        (lt_of_not_ge (mt Cardinal.toNat_apply_of_aleph0_le hN3))).some
  rw [Nat.card_eq_fintype_card] at hN
  exact exists_right_complement'_of_coprime_of_fintype hN
#align subgroup.exists_right_complement'_of_coprime Subgroup.exists_right_complement'_of_coprime

/-- **Schur-Zassenhaus** for normal subgroups:
  If `H : subgroup G` is normal, and has order coprime to its index, then there exists a
  subgroup `K` which is a (left) complement of `H`. -/
theorem exists_left_complement'_of_coprime_of_fintype [Fintype G] {N : Subgroup G} [N.Normal]
    (hN : Nat.coprime (Fintype.card N) N.index) : ∃ H : Subgroup G, IsComplement' H N :=
  Exists.imp (fun _ => IsComplement'.symm) (exists_right_complement'_of_coprime_of_fintype hN)
#align subgroup.exists_left_complement'_of_coprime_of_fintype Subgroup.exists_left_complement'_of_coprime_of_fintype

/-- **Schur-Zassenhaus** for normal subgroups:
  If `H : subgroup G` is normal, and has order coprime to its index, then there exists a
  subgroup `K` which is a (left) complement of `H`. -/
theorem exists_left_complement'_of_coprime {N : Subgroup G} [N.Normal]
    (hN : Nat.coprime (Nat.card N) N.index) : ∃ H : Subgroup G, IsComplement' H N :=
  Exists.imp (fun _ => IsComplement'.symm) (exists_right_complement'_of_coprime hN)
#align subgroup.exists_left_complement'_of_coprime Subgroup.exists_left_complement'_of_coprime

end Subgroup


import tactic order.bounded_lattice order.zorn
import .aut

/-- One element covers another when there's no other element strictly in between. -/
def covers {α : Type*} [preorder α] (y x : α) : Prop :=
x < y ∧ ∀ z, ¬ (z ∈ set.Ioo x y)

notation x ` ⋗ `:50 y:50 := covers x y
notation x ` ⋖ `:50 y:50 := covers y x

/-- Covering is irreflexive. -/
instance covers.is_irrefl {α : Type*} [preorder α] : is_irrefl α covers :=
⟨ λ _ ha, ne_of_lt ha.left (refl _) ⟩

/-- A natural covers another iff it's a successor. -/
lemma nat.cover_iff_succ (m n : ℕ) : m ⋖ n ↔ n = m + 1 :=
begin
  split, {
    rintro ⟨hmnl, hmnr⟩,
    cases le_or_gt n (m + 1) with hnm hnm,
    exact antisymm hnm (nat.succ_le_of_lt hmnl),
    exact (hmnr _ ⟨lt_add_one m, hnm⟩).elim,
  },
  intro hnm,
  split, {
    rw hnm,
    exact lt_add_one m,
  },
  rintros r ⟨hrl, hrr⟩,
  have : m + 1 < n := lt_of_le_of_lt (nat.succ_le_of_lt hrl) hrr,
  rw hnm at this,
  exact nat.lt_asymm this this,
end

/-- A bounded order has both a bottom and top element. -/
class bounded_order (α : Type*) [has_le α] extends order_top α, order_bot α

namespace bounded_order

variables {α : Type*} [preorder α] [bounded_order α]

/-- A closed interval of a bounded order is a bounded order. -/
instance Icc (x y : α) (h : x ≤ y) : bounded_order (set.Icc x y) :=
{ to_order_top :=
  { top := ⟨y, by obviously⟩,
    le_top := by obviously },
  to_order_bot := by obviously, }

end bounded_order

/-- A bounded graded order has an order homomorphism into the naturals, such
    that `⊥` has grade 0, and the homomorphism respects covering. -/
@[protect_proj, field_simps]
class {u} has_grade (α : Type u) [preorder α] [order_bot α] : Type u :=
(grade : α → ℕ)
(grade_bot : grade ⊥ = 0)
(strict_mono : strict_mono grade)
(hcovers : ∀ {x y}, x ⋖ y → grade y = grade x + 1)

/-- A bounded graded partial order. -/
class bounded_graded (α : Type*) extends partial_order α, bounded_order α, has_grade α

/-- The grade of an element in a polytope. -/
@[reducible]
def grade {α : Type*} [preorder α] [bounded_order α] [hg : has_grade α] : α → ℕ :=
hg.grade

/-- The grade of a polytope is the grade of `⊤`. -/
@[reducible]
def top_grade (α : Type*) [preorder α] [bounded_order α] [hg : has_grade α] : ℕ :=
grade (⊤ : α)

namespace bounded_graded

/-- A `bounded_graded`'s grade is monotone. -/
protected lemma monotone {α : Type*} [bg : bounded_graded α] : monotone bg.grade :=
has_grade.strict_mono.monotone

end bounded_graded

/-- Proper elements are those that are neither `⊥` nor `⊤`. -/
@[reducible]
def proper {α : Type*} [bounded_graded α] (x : α) : Prop :=
x ≠ ⊥ ∧ x ≠ ⊤

namespace bounded_graded

/-- Every closed non-empty interval of a `bounded_graded` is itself a `bounded_graded`. -/
instance Icc {α : Type*} [bounded_graded α] (x y : α) (h : x ≤ y) : bounded_graded (set.Icc x y) :=
{ grade := λ a, grade a.val - grade x,
  strict_mono := λ a b h,
    nat.sub_mono_left_strict (bounded_graded.monotone a.prop.left) (has_grade.strict_mono h),
  grade_bot := tsub_eq_zero_iff_le.mpr (refl _),
  hcovers := begin
    rintros ⟨a, ha⟩ ⟨b, hb⟩ ⟨hab, hcov⟩,
    suffices this : ∀ z, z ∉ set.Ioo a b,
    have : grade b = grade a + 1 := has_grade.hcovers ⟨hab, this⟩,
    change grade b - grade x = grade a - grade x + 1,
    rw [this, nat.sub_add_comm],
    exact bounded_graded.monotone ha.left,
    intros z h,
    simp at hcov,
    apply hcov z (ha.left.trans (le_of_lt h.left)) ((le_of_lt h.right).trans hb.right),
    exact h.left,
    exact h.right
  end,
  ..bounded_order.Icc x y h }

end bounded_graded

/-- One element covers another iff they do so in the flag. -/
theorem flag.cover_iff_flag_cover {α : Type*} [bounded_graded α] {Φ : flag α} (x y : Φ) :
  x ⋖ y ↔ x.val ⋖ y.val :=
begin
  split, {
    refine λ h, ⟨h.left, λ z hzi, _⟩,
    cases h with hxy h,
    replace h : ∀ z ∈ Φ, z ∉ set.Ioo x.val y := λ z hz, h ⟨z, hz⟩,
    refine h z _ hzi,
    cases hzi with hxz hzy,
    refine (flag.mem_flag_iff_comp _).mpr (λ w hw, _),
    have hwi := h w hw,
    simp only [set.mem_Ioo, not_and] at hwi,
    by_cases hxw : x.val < w,
      { refine or.inl (le_of_lt _),
        cases Φ.comparable' y.prop hw with hyw hwy, { exact lt_trans hzy hyw },
        cases eq_or_lt_of_le hwy with hwy hwy, { rwa hwy },
        exact (hwi hxw hwy).elim },
      { cases Φ.comparable' x.prop hw with hxw' hwx, { exact (hxw hxw').elim },
        exact or.inr (le_trans hwx (le_of_lt hxz)), },
  },
  exact λ ⟨hxy, hz⟩, ⟨hxy, λ _, hz _⟩,
end

/-- Flags are bounded graded posets. -/
instance flag.bounded_graded {α : Type*} [bg : bounded_graded α] (Φ : flag α) : bounded_graded Φ :=
{ grade := λ x, grade x.val,
  grade_bot := bg.grade_bot,
  strict_mono := λ _ _ hab, has_grade.strict_mono hab,
  hcovers := λ _ _ hcov, has_grade.hcovers ((flag.cover_iff_flag_cover _ _).mp hcov), }

/-- Grades in flags coincide with the grades in the poset. -/
@[simp]
lemma flag.grade_eq_grade {α : Type*} [bg : bounded_graded α] {Φ : flag α} (a : Φ) : grade a = grade a.val :=
by refl

/-- Grade is injective over flags. -/
theorem flag.grade.injective {α : Type*} [bounded_graded α] (Φ : flag α) : function.injective (grade : Φ → ℕ) :=
has_grade.strict_mono.injective

/-- Grade is an order homomorphism in flags. -/
lemma flag.le_iff_grade_le {α : Type*} [bounded_graded α] {Φ : flag α} (x y : Φ) : x ≤ y ↔ grade x ≤ grade y :=
begin
  split, {
    intro hxy,
    exact bounded_graded.monotone hxy,
  },
  contrapose,
  refine λ hnxy, not_le_of_gt (has_grade.strict_mono _),
  exact lt_of_not_ge hnxy,
end

/-- Grade is an order isomorphism in flags. -/
lemma flag.lt_iff_grade_lt {α : Type*} [bg : bounded_graded α] {Φ : flag α} (x y : Φ) : x < y ↔ grade x < grade y :=
begin
  split, {
    intro hxy,
    apply bg.strict_mono,
    exact hxy,
  },
  intro hxy,
  rw lt_iff_le_and_ne,
  split, {
    rw flag.le_iff_grade_le,
    exact le_of_lt hxy,
  },
  intro heq,
  rw heq at hxy,
  exact nat.lt_asymm hxy hxy,
end

/-- In flags, `hcovers` is an equivalence. -/
theorem flag.hcovers {α : Type*} [bg : bounded_graded α] {Φ : flag α} (a b : Φ) : a ⋖ b ↔ grade b = grade a + 1 :=
begin
  split, {
    intro _,
    apply bg.hcovers,
    rwa ←flag.cover_iff_flag_cover,
  },
  intro hba,
  split, {
    rw [flag.lt_iff_grade_lt, hba],
    exact lt_add_one _,
  },
  rintros z ⟨hzl, hzr⟩,
  rw ←nat.cover_iff_succ at hba,
  rw flag.lt_iff_grade_lt at hzl,
  rw flag.lt_iff_grade_lt at hzr,
  exact hba.right _ ⟨hzl, hzr⟩,
end

/-- Two elements in a flag cover each other iff their grades do. -/
theorem flag.cover_iff_nat_cover {α : Type*} [bg : bounded_graded α] {Φ : flag α} (a b : Φ) :
a ⋖ b ↔ grade a ⋖ grade b :=
begin
  split, {
    intro _,
    rw nat.cover_iff_succ,
    apply bg.hcovers,
    rwa ←flag.cover_iff_flag_cover,
  },
  intro hab,
  rwa [flag.hcovers, ←nat.cover_iff_succ],
end

namespace bounded_graded

variables {α : Type*} [bounded_graded α]

/-- A point subdivides an interval into three. -/
lemma ioo_tricho {a b : ℕ} (c ∈ set.Ioo a b) (d: ℕ) : c = d ∨ c ∈ set.Ioo a d ∨ c ∈ set.Ioo d b :=
begin
  cases eq_or_ne c d with hcd hcd,
    { exact or.inl hcd },
  cases ne.lt_or_lt hcd with ha hb,
    { exact or.inr (or.inl ⟨and.left ‹_›, ha⟩) },
    { exact or.inr (or.inr ⟨hb, and.right ‹_›⟩) }
end

/-- A bounded set of nats without gaps is an interval. -/
private lemma all_ioo_of_ex_ioo' {P : ℕ → Prop} (n : ℕ) (hP : ∀ a b, b ≤ a + n → P a → P b → nonempty (set.Ioo a b) → ∃ c ∈ set.Ioo a b, P c) :
  ∀ a b, b ≤ a + n → P a → P b → ∀ c ∈ set.Ioo a b, P c :=
begin
  induction n with n hP',
    { exact λ _ _ hba _ _ _ hci, ((not_lt_of_ge hba) (lt_trans hci.left hci.right)).elim },
  intros a b hba ha hb _ hci,
  rcases hP a b hba ha hb (nonempty.intro ⟨_, hci⟩) with ⟨d, ⟨hdil, hdir⟩, hd⟩,
  cases ioo_tricho _ hci d with hcd hdb, { rwa ←hcd at hd },
  have hxy : ∃ x y, P x ∧ P y ∧ c ∈ set.Ioo x y ∧ y ≤ x + n := begin
    cases hdb with hcad hcdb,
      { refine ⟨a, d, ha, hd, hcad, _⟩,
        have := lt_of_lt_of_le hdir hba,
        rw nat.add_succ at this,
        exact nat.le_of_lt_succ this },
      { refine ⟨d, b, hd, hb, hcdb, _⟩,
        have := nat.add_le_add hdil rfl.le,
        rw nat.succ_add a n at this,
        exact le_trans hba this }
  end,
  rcases hxy with ⟨x, y, hx, hy, hxy, hyx⟩,
  refine hP' (λ _ _ hba, _) x y hyx hx hy c hxy,
  exact hP _ _ (hba.trans (nat.le_succ _)),
end

/-- A set of nats without gaps is an interval. -/
private lemma all_ioo_of_ex_ioo {P : ℕ → Prop} (hP : ∀ a b, P a → P b → (nonempty (set.Ioo a b)) → ∃ c ∈ set.Ioo a b, P c) :
  ∀ a b, P a → P b → ∀ c ∈ set.Ioo a b, P c :=
λ _ b, all_ioo_of_ex_ioo' b (λ c d _, hP c d) _ _ le_add_self

/-- A bounded set of nats without gaps is an interval. -/
lemma all_icc_of_ex_ioo {P : ℕ → Prop} (hP : ∀ a b, P a → P b → (nonempty (set.Ioo a b)) → ∃ c ∈ set.Ioo a b, P c) :
  ∀ a b, P a → P b → ∀ c ∈ set.Icc a b, P c :=
begin
  rintros a b ha hb c ⟨hac, hcb⟩,
  cases eq_or_lt_of_le hac with hac hac,
    { rwa ←hac },
  cases eq_or_lt_of_le hcb with hcb hcb,
    { rwa  hcb },
  exact all_ioo_of_ex_ioo hP a b ha hb c ⟨hac, hcb⟩,
end

/-- A number is a grade of some element in a flag. -/
def is_grade {α : Type*} [bounded_graded α] (Φ : flag α) (n : ℕ) :=
∃ a : Φ, grade a = n

/-- If `x < y` but `y` does not cover `x`, then there's an element in between. -/
lemma between_of_ncover {x y : α} (hnxy : ¬x ⋖ y) (hxy : x < y) :
  ∃ z, x < z ∧ z < y :=
by by_contra hne; push_neg at hne; exact hnxy ⟨hxy, λ z ⟨hl, hr⟩, hne z hl hr⟩

/-- The set of grades in a flag has no gaps. -/
lemma grade_ioo (Φ : flag α) (m n : ℕ) :
  is_grade Φ m → is_grade Φ n → nonempty (set.Ioo m n) → ∃ r ∈ set.Ioo m n, is_grade Φ r :=
begin
  rintros ⟨a, ham⟩ ⟨b, hbn⟩ ⟨r, hr⟩,

  have hnab : ¬a ⋖ b := begin
    have : ¬m ⋖ n := λ hmn, (hmn.right r) hr,
    rwa [←ham, ←hbn, ←flag.cover_iff_nat_cover] at this,
  end,

  have hab : a < b := begin
    rw [flag.lt_iff_grade_lt, ham, hbn],
    exact lt_trans hr.left hr.right,
  end,

  rcases between_of_ncover hnab hab with ⟨c, hac, hcb⟩,
  use grade c,
  split,
    { split,
      { rw ←ham,
        exact has_grade.strict_mono hac, },
      rw ←hbn,
      exact has_grade.strict_mono hcb, },
  exact ⟨c, rfl⟩,
end

/-- If a flag contains two elements, it contains elements with all grades in between. -/
lemma flag_grade' {Φ : flag α} (x y : Φ) :
  ∀ r ∈ set.Icc (grade x) (grade y), ∃ z : Φ, grade z = r :=
λ r hri, (all_icc_of_ex_ioo (grade_ioo Φ)) (grade x) (grade y) ⟨x, rfl⟩ ⟨y, rfl⟩ r hri

/-- A flag has a unique element of grade `r` iff `r ≤ grade ⊤`. -/
theorem flag_grade (Φ : flag α) :
  ∀ n : ℕ, (∃! r : Φ, grade r = n) ↔ n ∈ set.Iic (top_grade Φ) :=
begin
  intro n,
  split, {
    rintro ⟨_, hal, _⟩,
    rw ←hal,
    exact bounded_graded.monotone le_top,
  },
  intro hn,

  have he : ∃ (r : Φ), grade r = n := begin
    apply flag_grade' ⊥ ⊤ n,
    split, {
      have : grade (⊥ : Φ) = 0 := (flag.bounded_graded Φ).grade_bot,
      rw this,
      exact zero_le n,
    },
    exact hn,
  end,

  cases he with r hr,
  use [r, hr],
  intros s hs,
  apply flag.grade.injective,
  rw [hr, hs],
end

end bounded_graded

/-- The diamond property between two elements. -/
def diamond {α : Type*} [bounded_graded α] (x y : α) : Prop :=
x ≤ y → grade y = grade x + 2 → ∃ a b, a ≠ b ∧ set.Ioo x y = {a, b}

/-- A pre-polytope is a bounded graded partial order that satisfies the
    diamond property. -/
class pre_polytope (α : Type*) extends bounded_graded α :=
(diamond (x y : α) : diamond x y)

/-- Asserts that a set is a singleton. -/
@[reducible]
def set.is_singleton {β : Type*} (s : set β) := ∃ a, s = {a}

lemma singleton_nonempty {β : Type*} {s : set β} : set.is_singleton s → s.nonempty :=
begin
  rintro ⟨b, hb⟩,
  use b,
  rw hb,
  exact rfl,
end

namespace flag
variables {α : Type*} [pre_polytope α]

/-- Two flags are `j`-adjacent when they share all elements save for the one of grade `j`. -/
def flag_adj (j : ℕ) (Φ Ψ : flag α) : Prop :=
Φ ≠ Ψ ∧ ∀ a ∈ Φ.val \ Ψ.val, grade a = j

noncomputable def flag_idx (j : ℕ) (Φ : flag α) : Φ :=
  if hj : j ≤ (top_grade Φ)
  then classical.some ((bounded_graded.flag_grade Φ j).mpr hj)
  else ⊤

lemma grade_flag_idx (j : ℕ) (Φ : flag α) (hj : j ≤ (top_grade Φ)): grade (flag_idx j Φ) = j :=
begin
  split_ifs,
end

/-- Two flags are subsets of one another iff they're equal. -/
lemma subset_iff_eq_flag (Φ Ψ : flag α) : Φ.val ⊆ Ψ.val ↔ Φ = Ψ := begin
  split, {
    intro hΦΨ,
    rcases Φ with ⟨_, _, hΦ⟩,
    rcases Ψ with ⟨Ψ, hcΨ, _⟩,
    cases set.eq_or_ssubset_of_subset hΦΨ,
    exact subtype.ext_val h,
    exact (hΦ ⟨Ψ, hcΨ, h⟩).elim,
  },
  intro h,
  rw h,
end

/-- Flag adjacency is irreflexive. -/
instance flag_adj.is_irrefl (j : ℕ) : is_irrefl (flag α) (flag_adj j) :=
⟨λ _ ⟨hΦ, _⟩, hΦ rfl⟩

/-- Two flags are adjacent iff their difference is a singleton. -/
lemma flag_adj' (Φ Ψ : flag α) : (∃ j, flag_adj j Φ Ψ) ↔ set.is_singleton (Φ.val \ Ψ.val) :=
begin
  split, {
    rintro ⟨j, ⟨hjl, hjr⟩⟩,
    have h : set.nonempty (Φ.val \ Ψ.val) := begin
      rw set.nonempty_diff,
      intro hΦΨ,
      rw subset_iff_eq_flag at hΦΨ,
      exact hjl hΦΨ,
    end,
    cases h with a ha,
    use a,
    apply set.ext,
    intro b,
    split, {
      intro hb,
      let a' : Φ := ⟨a, set.mem_of_mem_diff ha⟩,
      let b' : Φ := ⟨b, set.mem_of_mem_diff hb⟩,
      have : b' = a' := begin
        refine (flag.grade.injective _ _).symm,
        repeat {rw flag.grade_eq_grade},
        rw [hjr a ha, hjr b hb]
      end,
      rwa subtype.ext_iff_val at this,
    },
    intro hba,
    have : b = a := hba,
    rwa this,
  },
  intro h,
  cases h with a ha,
  use grade a,
  split, {
    intro hΦΨ,
    rw hΦΨ at ha,
    have : Ψ.val \ Ψ.val = ∅ := sdiff_self,
    rw ha at this,
    exact exists_false (singleton_nonempty ⟨a, this.symm⟩),
  },
  intros b hb,
  have : b = a := by rw ha at hb; exact hb,
  rw this,
end

lemma flag_adj.symm (Φ Ψ : flag α) (j : ℕ) : flag_adj j Φ Ψ → flag_adj j Ψ Φ :=
begin
  intro hf,
  sorry,
end

lemma ex_flag_adj' (Φ : flag α) (j : ℕ) :
  ∃ Ψ, flag_adj j Φ Ψ := sorry

theorem ex_flag_adj (Φ : flag α) (j : ℕ) :
  ∃! Ψ, flag_adj j Φ Ψ := sorry

end flag

/-- The type `connected_ind a b` is the type of all paths from `a` to `b`
    passing only through proper elements. Giving an instance of this type is
    equivalent to proving `a` and `b` are connected. -/
inductive connected {α : Type*} [bounded_graded α] : α → α → Prop
| start (x : α) : proper x → connected x x
| next (x y z : α) : connected x y → proper z → comparable y z → connected x z

namespace bounded_graded

/-- A `bounded_graded` is connected when it's of grade 2, or any two proper
     elements are connected. -/
def connected (α : Type*) [bounded_graded α] : Prop :=
top_grade α = 2 ∨ ∀ a b : α, proper a → proper b → connected a b

end bounded_graded

/-- A section of a pre-polytope is connected. -/
@[reducible]
def section_connected {α : Type*} [bounded_graded α] (x y : α) : Prop :=
x ≤ y → @bounded_graded.connected _ (bounded_graded.Icc x y ‹_›)

/-- A polytope is a strongly connected pre-polytope. -/
class polytope (α : Type*) extends pre_polytope α :=
(scon : ∀ x y : α, section_connected x y)


axiom appendNil {α} (as : List α) : as ++ [] = as
axiom appendAssoc {α} (as bs cs : List α) : (as ++ bs) ++ cs = as ++ (bs ++ cs)
axiom reverseEq {α} (as : List α) : as.reverse.reverse = as

theorem ex1 {α} (as bs : List α) : as.reverse.reverse ++ [] ++ [] ++ bs ++ bs = as ++ (bs ++ bs) := by
  rw [appendNil, appendNil, reverseEq];
  trace_state;
  rw [←appendAssoc];

theorem ex2 {α} (as bs : List α) : as.reverse.reverse ++ [] ++ [] ++ bs ++ bs = as ++ (bs ++ bs) := by
rewrite [reverseEq, reverseEq]; -- Error on second reverseEq
done

axiom zeroAdd (x : Nat) : 0 + x = x

theorem ex2 (x y z) (h₁ : 0 + x = y) (h₂ : 0 + y = z) : x = z := by
rewrite [zeroAdd] at h₁ h₂;
trace_state;
subst x;
subst y;
exact rfl

theorem ex3 (x y z) (h₁ : 0 + x = y) (h₂ : 0 + y = z) : x = z := by
rewrite [zeroAdd] at *;
subst x;
subst y;
exact rfl

theorem ex4 (x y z) (h₁ : 0 + x = y) (h₂ : 0 + y = z) : x = z := by
rewrite [appendAssoc] at *; -- Error
done

theorem ex5 (m n k : Nat) (h : 0 + n = m) (h : k = m) : k = n := by
rw [zeroAdd] at *;
trace_state; -- `h` is still a name for `h : k = m`
refine Eq.trans h ?hole;
apply Eq.symm;
assumption

theorem ex6 (p q r : Prop) (h₁ : q → r) (h₂ : p ↔ q) (h₃ : p) : r := by
rw [←h₂] at h₁;
exact h₁ h₃

theorem ex7 (p q r : Prop) (h₁ : q → r) (h₂ : p ↔ q) (h₃ : p) : r := by
rw [h₂] at h₃;
exact h₁ h₃

example (α : Type) (p : Prop) (a b c : α) (h : p → a = b) : a = c := by
  rw [h _]  -- should manifest goal `⊢ p`, like `rw [h]` would