/-
Copyright (c) 2019 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Fabian Glöckle, Kyle Miller
-/
import linear_algebra.finite_dimensional
import linear_algebra.projection
import linear_algebra.sesquilinear_form
import ring_theory.finiteness
import linear_algebra.free_module.finite.basic

/-!
# Dual vector spaces

The dual space of an $R$-module $M$ is the $R$-module of $R$-linear maps $M \to R$.

## Main definitions

* Duals and transposes:
  * `module.dual R M` defines the dual space of the `R`-module `M`, as `M →ₗ[R] R`.
  * `module.dual_pairing R M` is the canonical pairing between `dual R M` and `M`.
  * `module.dual.eval R M : M →ₗ[R] dual R (dual R)` is the canonical map to the double dual.
  * `module.dual.transpose` is the linear map from `M →ₗ[R] M'` to `dual R M' →ₗ[R] dual R M`.
  * `linear_map.dual_map` is `module.dual.transpose` of a given linear map, for dot notation.
  * `linear_equiv.dual_map` is for the dual of an equivalence.
* Bases:
  * `basis.to_dual` produces the map `M →ₗ[R] dual R M` associated to a basis for an `R`-module `M`.
  * `basis.to_dual_equiv` is the equivalence `M ≃ₗ[R] dual R M` associated to a finite basis.
  * `basis.dual_basis` is a basis for `dual R M` given a finite basis for `M`.
  * `module.dual_bases e ε` is the proposition that the families `e` of vectors and `ε` of dual
    vectors have the characteristic properties of a basis and a dual.
* Submodules:
  * `submodule.dual_restrict W` is the transpose `dual R M →ₗ[R] dual R W` of the inclusion map.
  * `submodule.dual_annihilator W` is the kernel of `W.dual_restrict`. That is, it is the submodule
    of `dual R M` whose elements all annihilate `W`.
  * `submodule.dual_restrict_comap W'` is the dual annihilator of `W' : submodule R (dual R M)`,
    pulled back along `module.dual.eval R M`.
  * `submodule.dual_copairing W` is the canonical pairing between `W.dual_annihilator` and `M ⧸ W`.
    It is nondegenerate for vector spaces (`subspace.dual_copairing_nondegenerate`).
  * `submodule.dual_pairing W` is the canonical pairing between `dual R M ⧸ W.dual_annihilator`
    and `W`. It is nondegenerate for vector spaces (`subspace.dual_pairing_nondegenerate`).
* Vector spaces:
  * `subspace.dual_lift W` is an arbitrary section (using choice) of `submodule.dual_restrict W`.

## Main results

* Bases:
  * `module.dual_basis.basis` and `module.dual_basis.coe_basis`: if `e` and `ε` form a dual pair,
    then `e` is a basis.
  * `module.dual_basis.coe_dual_basis`: if `e` and `ε` form a dual pair,
    then `ε` is a basis.
* Annihilators:
  * `module.dual_annihilator_gc R M` is the antitone Galois correspondence between
    `submodule.dual_annihilator` and `submodule.dual_coannihilator`.
  * `linear_map.ker_dual_map_eq_dual_annihilator_range` says that
    `f.dual_map.ker = f.range.dual_annihilator`
  * `linear_map.range_dual_map_eq_dual_annihilator_ker_of_subtype_range_surjective` says that
    `f.dual_map.range = f.ker.dual_annihilator`; this is specialized to vector spaces in
    `linear_map.range_dual_map_eq_dual_annihilator_ker`.
  * `submodule.dual_quot_equiv_dual_annihilator` is the equivalence
    `dual R (M ⧸ W) ≃ₗ[R] W.dual_annihilator`
* Vector spaces:
  * `subspace.dual_annihilator_dual_coannihilator_eq` says that the double dual annihilator,
    pulled back ground `module.dual.eval`, is the original submodule.
  * `subspace.dual_annihilator_gci` says that `module.dual_annihilator_gc R M` is an
    antitone Galois coinsertion.
  * `subspace.quot_annihilator_equiv` is the equivalence
    `dual K V ⧸ W.dual_annihilator ≃ₗ[K] dual K W`.
  * `linear_map.dual_pairing_nondegenerate` says that `module.dual_pairing` is nondegenerate.
  * `subspace.is_compl_dual_annihilator` says that the dual annihilator carries complementary
    subspaces to complementary subspaces.
* Finite-dimensional vector spaces:
  * `module.eval_equiv` is the equivalence `V ≃ₗ[K] dual K (dual K V)`
  * `module.map_eval_equiv` is the order isomorphism between subspaces of `V` and
    subspaces of `dual K (dual K V)`.
  * `subspace.quot_dual_equiv_annihilator W` is the equivalence
    `(dual K V ⧸ W.dual_lift.range) ≃ₗ[K] W.dual_annihilator`, where `W.dual_lift.range` is a copy
    of `dual K W` inside `dual K V`.
  * `subspace.quot_equiv_annihilator W` is the equivalence `(V ⧸ W) ≃ₗ[K] W.dual_annihilator`
  * `subspace.dual_quot_distrib W` is an equivalence
    `dual K (V₁ ⧸ W) ≃ₗ[K] dual K V₁ ⧸ W.dual_lift.range` from an arbitrary choice of
    splitting of `V₁`.

## TODO

Erdös-Kaplansky theorem about the dimension of a dual vector space in case of infinite dimension.
-/

noncomputable theory

namespace module

variables (R : Type*) (M : Type*)
variables [comm_semiring R] [add_comm_monoid M] [module R M]

/-- The dual space of an R-module M is the R-module of linear maps `M → R`. -/
@[derive [add_comm_monoid, module R]] def dual := M →ₗ[R] R

instance {S : Type*} [comm_ring S] {N : Type*} [add_comm_group N] [module S N] :
  add_comm_group (dual S N) := linear_map.add_comm_group

instance : linear_map_class (dual R M) R M R :=
linear_map.semilinear_map_class

/-- The canonical pairing of a vector space and its algebraic dual. -/
def dual_pairing (R M) [comm_semiring R] [add_comm_monoid M] [module R M] :
  module.dual R M →ₗ[R] M →ₗ[R] R := linear_map.id

@[simp] lemma dual_pairing_apply (v x) : dual_pairing R M v x = v x := rfl

namespace dual

instance : inhabited (dual R M) := linear_map.inhabited

instance : has_coe_to_fun (dual R M) (λ _, M → R) := ⟨linear_map.to_fun⟩

/-- Maps a module M to the dual of the dual of M. See `module.erange_coe` and
`module.eval_equiv`. -/
def eval : M →ₗ[R] (dual R (dual R M)) := linear_map.flip linear_map.id

@[simp] lemma eval_apply (v : M) (a : dual R M) : eval R M v a = a v := rfl

variables {R M} {M' : Type*} [add_comm_monoid M'] [module R M']

/-- The transposition of linear maps, as a linear map from `M →ₗ[R] M'` to
`dual R M' →ₗ[R] dual R M`. -/
def transpose : (M →ₗ[R] M') →ₗ[R] (dual R M' →ₗ[R] dual R M) :=
(linear_map.llcomp R M M' R).flip

lemma transpose_apply (u : M →ₗ[R] M') (l : dual R M') : transpose u l = l.comp u := rfl

variables {M'' : Type*} [add_comm_monoid M''] [module R M'']

lemma transpose_comp (u : M' →ₗ[R] M'') (v : M →ₗ[R] M') :
  transpose (u.comp v) = (transpose v).comp (transpose u) := rfl

end dual

section prod
variables (M' : Type*) [add_comm_monoid M'] [module R M']

/-- Taking duals distributes over products. -/
@[simps] def dual_prod_dual_equiv_dual :
  (module.dual R M × module.dual R M') ≃ₗ[R] module.dual R (M × M') :=
linear_map.coprod_equiv R

@[simp] lemma dual_prod_dual_equiv_dual_apply (φ : module.dual R M) (ψ : module.dual R M') :
  dual_prod_dual_equiv_dual R M M' (φ, ψ) = φ.coprod ψ := rfl

end prod

end module

section dual_map
open module

variables {R : Type*} [comm_semiring R] {M₁ : Type*} {M₂ : Type*}
variables [add_comm_monoid M₁] [module R M₁] [add_comm_monoid M₂] [module R M₂]

/-- Given a linear map `f : M₁ →ₗ[R] M₂`, `f.dual_map` is the linear map between the dual of
`M₂` and `M₁` such that it maps the functional `φ` to `φ ∘ f`. -/
def linear_map.dual_map (f : M₁ →ₗ[R] M₂) : dual R M₂ →ₗ[R] dual R M₁ :=
module.dual.transpose f

lemma linear_map.dual_map_def (f : M₁ →ₗ[R] M₂) : f.dual_map = module.dual.transpose f := rfl

lemma linear_map.dual_map_apply' (f : M₁ →ₗ[R] M₂) (g : dual R M₂) :
  f.dual_map g = g.comp f := rfl

@[simp] lemma linear_map.dual_map_apply (f : M₁ →ₗ[R] M₂) (g : dual R M₂) (x : M₁) :
  f.dual_map g x = g (f x) := rfl

@[simp] lemma linear_map.dual_map_id :
  (linear_map.id : M₁ →ₗ[R] M₁).dual_map = linear_map.id :=
by { ext, refl }

lemma linear_map.dual_map_comp_dual_map {M₃ : Type*} [add_comm_group M₃] [module R M₃]
  (f : M₁ →ₗ[R] M₂) (g : M₂ →ₗ[R] M₃) :
  f.dual_map.comp g.dual_map = (g.comp f).dual_map :=
rfl

/-- If a linear map is surjective, then its dual is injective. -/
lemma linear_map.dual_map_injective_of_surjective {f : M₁ →ₗ[R] M₂} (hf : function.surjective f) :
  function.injective f.dual_map :=
begin
  intros φ ψ h,
  ext x,
  obtain ⟨y, rfl⟩ := hf x,
  exact congr_arg (λ (g : module.dual R M₁), g y) h,
end

/-- The `linear_equiv` version of `linear_map.dual_map`. -/
def linear_equiv.dual_map (f : M₁ ≃ₗ[R] M₂) : dual R M₂ ≃ₗ[R] dual R M₁ :=
{ inv_fun := f.symm.to_linear_map.dual_map,
  left_inv :=
    begin
      intro φ, ext x,
      simp only [linear_map.dual_map_apply, linear_equiv.coe_to_linear_map,
                 linear_map.to_fun_eq_coe, linear_equiv.apply_symm_apply]
    end,
  right_inv :=
    begin
      intro φ, ext x,
      simp only [linear_map.dual_map_apply, linear_equiv.coe_to_linear_map,
                 linear_map.to_fun_eq_coe, linear_equiv.symm_apply_apply]
    end,
  .. f.to_linear_map.dual_map }

@[simp] lemma linear_equiv.dual_map_apply (f : M₁ ≃ₗ[R] M₂) (g : dual R M₂) (x : M₁) :
  f.dual_map g x = g (f x) := rfl

@[simp] lemma linear_equiv.dual_map_refl :
  (linear_equiv.refl R M₁).dual_map = linear_equiv.refl R (dual R M₁) :=
by { ext, refl }

@[simp] lemma linear_equiv.dual_map_symm {f : M₁ ≃ₗ[R] M₂} :
  (linear_equiv.dual_map f).symm = linear_equiv.dual_map f.symm := rfl

lemma linear_equiv.dual_map_trans {M₃ : Type*} [add_comm_group M₃] [module R M₃]
  (f : M₁ ≃ₗ[R] M₂) (g : M₂ ≃ₗ[R] M₃) :
  g.dual_map.trans f.dual_map = (f.trans g).dual_map :=
rfl

end dual_map

namespace basis

universes u v w

open module module.dual submodule linear_map cardinal function
open_locale big_operators

variables {R M K V ι : Type*}

section comm_semiring

variables [comm_semiring R] [add_comm_monoid M] [module R M] [decidable_eq ι]
variables (b : basis ι R M)

/-- The linear map from a vector space equipped with basis to its dual vector space,
taking basis elements to corresponding dual basis elements. -/
def to_dual : M →ₗ[R] module.dual R M :=
b.constr ℕ $ λ v, b.constr ℕ $ λ w, if w = v then (1 : R) else 0

lemma to_dual_apply (i j : ι) :
  b.to_dual (b i) (b j) = if i = j then 1 else 0 :=
by { erw [constr_basis b, constr_basis b], ac_refl }

@[simp] lemma to_dual_total_left (f : ι →₀ R) (i : ι) :
  b.to_dual (finsupp.total ι M R b f) (b i) = f i :=
begin
  rw [finsupp.total_apply, finsupp.sum, linear_map.map_sum, linear_map.sum_apply],
  simp_rw [linear_map.map_smul, linear_map.smul_apply, to_dual_apply, smul_eq_mul,
           mul_boole, finset.sum_ite_eq'],
  split_ifs with h,
  { refl },
  { rw finsupp.not_mem_support_iff.mp h }
end

@[simp] lemma to_dual_total_right (f : ι →₀ R) (i : ι) :
  b.to_dual (b i) (finsupp.total ι M R b f) = f i :=
begin
  rw [finsupp.total_apply, finsupp.sum, linear_map.map_sum],
  simp_rw [linear_map.map_smul, to_dual_apply, smul_eq_mul, mul_boole, finset.sum_ite_eq],
  split_ifs with h,
  { refl },
  { rw finsupp.not_mem_support_iff.mp h }
end

lemma to_dual_apply_left (m : M) (i : ι) : b.to_dual m (b i) = b.repr m i :=
by rw [← b.to_dual_total_left, b.total_repr]

lemma to_dual_apply_right (i : ι) (m : M) : b.to_dual (b i) m = b.repr m i :=
by rw [← b.to_dual_total_right, b.total_repr]

lemma coe_to_dual_self (i : ι) : b.to_dual (b i) = b.coord i :=
by { ext, apply to_dual_apply_right }

/-- `h.to_dual_flip v` is the linear map sending `w` to `h.to_dual w v`. -/
def to_dual_flip (m : M) : (M →ₗ[R] R) := b.to_dual.flip m

lemma to_dual_flip_apply (m₁ m₂ : M) : b.to_dual_flip m₁ m₂ = b.to_dual m₂ m₁ := rfl

lemma to_dual_eq_repr (m : M) (i : ι) : b.to_dual m (b i) = b.repr m i :=
b.to_dual_apply_left m i

lemma to_dual_eq_equiv_fun [fintype ι] (m : M) (i : ι) : b.to_dual m (b i) = b.equiv_fun m i :=
by rw [b.equiv_fun_apply, to_dual_eq_repr]

lemma to_dual_inj (m : M) (a : b.to_dual m = 0) : m = 0 :=
begin
  rw [← mem_bot R, ← b.repr.ker, mem_ker, linear_equiv.coe_coe],
  apply finsupp.ext,
  intro b,
  rw [← to_dual_eq_repr, a],
  refl
end

theorem to_dual_ker : b.to_dual.ker = ⊥ :=
ker_eq_bot'.mpr b.to_dual_inj

theorem to_dual_range [_root_.finite ι] : b.to_dual.range = ⊤ :=
begin
  casesI nonempty_fintype ι,
  refine eq_top_iff'.2 (λ f, _),
  rw linear_map.mem_range,
  let lin_comb : ι →₀ R := finsupp.equiv_fun_on_finite.symm (λ i, f.to_fun (b i)),
  refine ⟨finsupp.total ι M R b lin_comb, b.ext $ λ i, _⟩,
  rw [b.to_dual_eq_repr _ i, repr_total b],
  refl,
end

end comm_semiring

section

variables [comm_semiring R] [add_comm_monoid M] [module R M] [fintype ι]
variables (b : basis ι R M)

@[simp] lemma sum_dual_apply_smul_coord (f : module.dual R M) : ∑ x, f (b x) • b.coord x = f :=
begin
  ext m,
  simp_rw [linear_map.sum_apply, linear_map.smul_apply, smul_eq_mul, mul_comm (f _), ←smul_eq_mul,
    ←f.map_smul, ←f.map_sum, basis.coord_apply, basis.sum_repr],
end

end

section comm_ring

variables [comm_ring R] [add_comm_group M] [module R M] [decidable_eq ι]
variables (b : basis ι R M)

section finite
variables [_root_.finite ι]

/-- A vector space is linearly equivalent to its dual space. -/
@[simps]
def to_dual_equiv : M ≃ₗ[R] dual R M :=
linear_equiv.of_bijective b.to_dual
  ⟨ker_eq_bot.mp b.to_dual_ker, range_eq_top.mp b.to_dual_range⟩

/-- Maps a basis for `V` to a basis for the dual space. -/
def dual_basis : basis ι R (dual R M) := b.map b.to_dual_equiv

-- We use `j = i` to match `basis.repr_self`
lemma dual_basis_apply_self (i j : ι) : b.dual_basis i (b j) = if j = i then 1 else 0 :=
by { convert b.to_dual_apply i j using 2, rw @eq_comm _ j i }

lemma total_dual_basis (f : ι →₀ R) (i : ι) :
  finsupp.total ι (dual R M) R b.dual_basis f (b i) = f i :=
begin
  casesI nonempty_fintype ι,
  rw [finsupp.total_apply, finsupp.sum_fintype, linear_map.sum_apply],
  { simp_rw [linear_map.smul_apply, smul_eq_mul, dual_basis_apply_self, mul_boole,
      finset.sum_ite_eq, if_pos (finset.mem_univ i)] },
  { intro, rw zero_smul },
end

lemma dual_basis_repr (l : dual R M) (i : ι) : b.dual_basis.repr l i = l (b i) :=
by rw [← total_dual_basis b, basis.total_repr b.dual_basis l]

lemma dual_basis_apply (i : ι) (m : M) : b.dual_basis i m = b.repr m i := b.to_dual_apply_right i m

@[simp] lemma coe_dual_basis : ⇑b.dual_basis = b.coord := by { ext i x, apply dual_basis_apply }

@[simp] lemma to_dual_to_dual : b.dual_basis.to_dual.comp b.to_dual = dual.eval R M :=
begin
  refine b.ext (λ i, b.dual_basis.ext (λ j, _)),
  rw [linear_map.comp_apply, to_dual_apply_left, coe_to_dual_self, ← coe_dual_basis,
      dual.eval_apply, basis.repr_self, finsupp.single_apply, dual_basis_apply_self]
end

end finite

lemma dual_basis_equiv_fun [fintype ι] (l : dual R M) (i : ι) :
  b.dual_basis.equiv_fun l i = l (b i) :=
by rw [basis.equiv_fun_apply, dual_basis_repr]

theorem eval_ker {ι : Type*} (b : basis ι R M) :
  (dual.eval R M).ker = ⊥ :=
begin
  rw ker_eq_bot',
  intros m hm,
  simp_rw [linear_map.ext_iff, dual.eval_apply, zero_apply] at hm,
  exact (basis.forall_coord_eq_zero_iff _).mp (λ i, hm (b.coord i))
end

lemma eval_range {ι : Type*} [_root_.finite ι] (b : basis ι R M) : (eval R M).range = ⊤ :=
begin
  classical,
  casesI nonempty_fintype ι,
  rw [← b.to_dual_to_dual, range_comp, b.to_dual_range, submodule.map_top, to_dual_range _],
  apply_instance
end

/-- A module with a basis is linearly equivalent to the dual of its dual space. -/
def eval_equiv  {ι : Type*} [_root_.finite ι] (b : basis ι R M) : M ≃ₗ[R] dual R (dual R M) :=
linear_equiv.of_bijective (eval R M)
  ⟨ker_eq_bot.mp b.eval_ker, range_eq_top.mp b.eval_range⟩

@[simp] lemma eval_equiv_to_linear_map {ι : Type*} [_root_.finite ι] (b : basis ι R M) :
  (b.eval_equiv).to_linear_map = dual.eval R M := rfl

section

open_locale classical

variables [finite R M] [free R M] [nontrivial R]

instance dual_free : free R (dual R M) := free.of_basis (free.choose_basis R M).dual_basis

instance dual_finite : finite R (dual R M) := finite.of_basis (free.choose_basis R M).dual_basis

end

end comm_ring

/-- `simp` normal form version of `total_dual_basis` -/
@[simp] lemma total_coord [comm_ring R] [add_comm_group M] [module R M] [_root_.finite ι]
  (b : basis ι R M) (f : ι →₀ R) (i : ι) :
  finsupp.total ι (dual R M) R b.coord f (b i) = f i :=
by { haveI := classical.dec_eq ι, rw [← coe_dual_basis, total_dual_basis] }

lemma dual_dim_eq [comm_ring K] [add_comm_group V] [module K V] [_root_.finite ι]
  (b : basis ι K V) :
  cardinal.lift (module.rank K V) = module.rank K (dual K V) :=
begin
  classical,
  casesI nonempty_fintype ι,
  have := linear_equiv.lift_dim_eq b.to_dual_equiv,
  simp only [cardinal.lift_umax] at this,
  rw [this, ← cardinal.lift_umax],
  apply cardinal.lift_id,
end

end basis

namespace module

variables {K V : Type*}
variables [field K] [add_comm_group V] [module K V]
open module module.dual submodule linear_map cardinal basis finite_dimensional

section
variables (K) (V)

theorem eval_ker : (eval K V).ker = ⊥ :=
by { classical, exact (basis.of_vector_space K V).eval_ker }

theorem map_eval_injective : (submodule.map (eval K V)).injective :=
begin
  apply submodule.map_injective_of_injective,
  rw ← linear_map.ker_eq_bot,
  apply eval_ker K V, -- elaborates faster than `exact`
end

theorem comap_eval_surjective : (submodule.comap (eval K V)).surjective :=
begin
  apply submodule.comap_surjective_of_injective,
  rw ← linear_map.ker_eq_bot,
  apply eval_ker K V, -- elaborates faster than `exact`
end

end

section
variable (K)

theorem eval_apply_eq_zero_iff (v : V) : (eval K V) v = 0 ↔ v = 0 :=
by simpa only using set_like.ext_iff.mp (eval_ker K V) v

theorem eval_apply_injective : function.injective (eval K V) :=
(injective_iff_map_eq_zero' (eval K V)).mpr (eval_apply_eq_zero_iff K)

theorem forall_dual_apply_eq_zero_iff (v : V) : (∀ (φ : module.dual K V), φ v = 0) ↔ v = 0 :=
by { rw [← eval_apply_eq_zero_iff K v, linear_map.ext_iff], refl }

end

-- TODO(jmc): generalize to rings, once `module.rank` is generalized
theorem dual_dim_eq [finite_dimensional K V] :
  cardinal.lift (module.rank K V) = module.rank K (dual K V) :=
(basis.of_vector_space K V).dual_dim_eq

lemma erange_coe [finite_dimensional K V] : (eval K V).range = ⊤ :=
begin
  letI : is_noetherian K V := is_noetherian.iff_fg.2 infer_instance,
  exact (basis.of_vector_space K V).eval_range
end

variables (K V)

/-- A vector space is linearly equivalent to the dual of its dual space. -/
def eval_equiv [finite_dimensional K V] : V ≃ₗ[K] dual K (dual K V) :=
linear_equiv.of_bijective (eval K V)
  -- 60x faster elaboration than using `ker_eq_bot.mp eval_ker` directly:
  ⟨by { rw ← ker_eq_bot, apply eval_ker K V }, range_eq_top.mp erange_coe⟩

/-- The isomorphism `module.eval_equiv` induces an order isomorphism on subspaces. -/
def map_eval_equiv [finite_dimensional K V] : subspace K V ≃o subspace K (dual K (dual K V)) :=
submodule.order_iso_map_comap (eval_equiv K V)

variables {K V}

@[simp] lemma eval_equiv_to_linear_map [finite_dimensional K V] :
  (eval_equiv K V).to_linear_map = dual.eval K V := rfl

@[simp] lemma map_eval_equiv_apply [finite_dimensional K V] (W : subspace K V) :
  map_eval_equiv K V W = W.map (eval K V) := rfl

@[simp] lemma map_eval_equiv_symm_apply [finite_dimensional K V]
  (W'' : subspace K (dual K (dual K V))) :
  (map_eval_equiv K V).symm W'' = W''.comap (eval K V) := rfl

end module

section dual_bases

open module

variables {R M ι : Type*}
variables [comm_semiring R] [add_comm_monoid M] [module R M] [decidable_eq ι]

/-- Try using `set.to_finite` to dispatch a `set.finite` goal. -/
-- TODO: In Lean 4 we can remove this and use `by { intros; exact Set.toFinite _ }` as a default
-- argument.
meta def use_finite_instance : tactic unit := `[intros, exact set.to_finite _]

/-- `e` and `ε` have characteristic properties of a basis and its dual -/
@[nolint has_nonempty_instance]
structure module.dual_bases (e : ι → M) (ε : ι → (dual R M)) : Prop :=
(eval : ∀ i j : ι, ε i (e j) = if i = j then 1 else 0)
(total : ∀ {m : M}, (∀ i, ε i m = 0) → m = 0)
(finite : ∀ m : M, {i | ε i m ≠ 0}.finite . use_finite_instance)

end dual_bases

namespace module.dual_bases

open module module.dual linear_map function

variables {R M ι : Type*}
variables [comm_ring R] [add_comm_group M] [module R M]
variables {e : ι → M} {ε : ι → dual R M}

/-- The coefficients of `v` on the basis `e` -/
def coeffs [decidable_eq ι] (h : dual_bases e ε) (m : M) : ι →₀ R :=
{ to_fun := λ i, ε i m,
  support := (h.finite m).to_finset,
  mem_support_to_fun := by { intro i, rw [set.finite.mem_to_finset, set.mem_set_of_eq] } }

@[simp]

/-- linear combinations of elements of `e`.
This is a convenient abbreviation for `finsupp.total _ M R e l` -/
def lc {ι} (e : ι → M) (l : ι →₀ R) : M := l.sum (λ (i : ι) (a : R), a • (e i))

lemma lc_def (e : ι → M) (l : ι →₀ R) : lc e l = finsupp.total _ _ _ e l := rfl

open module

variables [decidable_eq ι] (h : dual_bases e ε)
include h

lemma dual_lc (l : ι →₀ R) (i : ι) : ε i (dual_bases.lc e l) = l i :=
begin
  erw linear_map.map_sum,
  simp only [h.eval, map_smul, smul_eq_mul],
  rw finset.sum_eq_single i,
  { simp },
  { intros q q_in q_ne,
    simp [q_ne.symm] },
  { intro p_not_in,
    simp [finsupp.not_mem_support_iff.1 p_not_in] },
end

@[simp]
lemma coeffs_lc (l : ι →₀ R) : h.coeffs (dual_bases.lc e l) = l :=
by { ext i, rw [h.coeffs_apply, h.dual_lc] }

/-- For any m : M n, \sum_{p ∈ Q n} (ε p m) • e p = m -/
@[simp]
lemma lc_coeffs (m : M) : dual_bases.lc e (h.coeffs m) = m :=
begin
  refine eq_of_sub_eq_zero (h.total _),
  intros i,
  simp [-sub_eq_add_neg, linear_map.map_sub, h.dual_lc, sub_eq_zero]
end

/-- `(h : dual_bases e ε).basis` shows the family of vectors `e` forms a basis. -/
@[simps]
def basis : basis ι R M :=
basis.of_repr
{ to_fun := coeffs h,
  inv_fun := lc e,
  left_inv := lc_coeffs h,
  right_inv := coeffs_lc h,
  map_add' := λ v w, by { ext i, exact (ε i).map_add v w },
  map_smul' := λ c v, by { ext i, exact (ε i).map_smul c v } }

@[simp] lemma coe_basis : ⇑h.basis = e :=
by { ext i, rw basis.apply_eq_iff, ext j,
     rw [h.basis_repr_apply, coeffs_apply, h.eval, finsupp.single_apply],
     convert if_congr eq_comm rfl rfl } -- `convert` to get rid of a `decidable_eq` mismatch

lemma mem_of_mem_span {H : set ι} {x : M} (hmem : x ∈ submodule.span R (e '' H)) :
  ∀ i : ι, ε i x ≠ 0 → i ∈ H :=
begin
  intros i hi,
  rcases (finsupp.mem_span_image_iff_total _).mp hmem with ⟨l, supp_l, rfl⟩,
  apply not_imp_comm.mp ((finsupp.mem_supported' _ _).mp supp_l i),
  rwa [← lc_def, h.dual_lc] at hi
end

lemma coe_dual_basis [fintype ι] : ⇑h.basis.dual_basis = ε :=
funext (λ i, h.basis.ext (λ j, by rw [h.basis.dual_basis_apply_self, h.coe_basis, h.eval,
                                      if_congr eq_comm rfl rfl]))

end module.dual_bases

namespace submodule

universes u v w

variables {R : Type u} {M : Type v} [comm_semiring R] [add_comm_monoid M] [module R M]
variable {W : submodule R M}

/-- The `dual_restrict` of a submodule `W` of `M` is the linear map from the
  dual of `M` to the dual of `W` such that the domain of each linear map is
  restricted to `W`. -/
def dual_restrict (W : submodule R M) :
  module.dual R M →ₗ[R] module.dual R W :=
linear_map.dom_restrict' W

lemma dual_restrict_def (W : submodule R M) : W.dual_restrict = W.subtype.dual_map := rfl

@[simp] lemma dual_restrict_apply
  (W : submodule R M) (φ : module.dual R M) (x : W) :
  W.dual_restrict φ x = φ (x : M) := rfl

/-- The `dual_annihilator` of a submodule `W` is the set of linear maps `φ` such
  that `φ w = 0` for all `w ∈ W`. -/
def dual_annihilator {R : Type u} {M : Type v} [comm_semiring R] [add_comm_monoid M]
  [module R M] (W : submodule R M) : submodule R $ module.dual R M :=
W.dual_restrict.ker

@[simp] lemma mem_dual_annihilator (φ : module.dual R M) :
  φ ∈ W.dual_annihilator ↔ ∀ w ∈ W, φ w = 0 :=
begin
  refine linear_map.mem_ker.trans _,
  simp_rw [linear_map.ext_iff, dual_restrict_apply],
  exact ⟨λ h w hw, h ⟨w, hw⟩, λ h w, h w.1 w.2⟩
end

/-- That $\operatorname{ker}(\iota^* : V^* \to W^*) = \operatorname{ann}(W)$.
This is the definition of the dual annihilator of the submodule $W$. -/
lemma dual_restrict_ker_eq_dual_annihilator (W : submodule R M) :
  W.dual_restrict.ker = W.dual_annihilator :=
rfl

/-- The `dual_annihilator` of a submodule of the dual space pulled back along the evaluation map
`module.dual.eval`. -/
def dual_coannihilator (Φ : submodule R (module.dual R M)) : submodule R M :=
Φ.dual_annihilator.comap (module.dual.eval R M)

lemma mem_dual_coannihilator {Φ : submodule R (module.dual R M)} (x : M) :
  x ∈ Φ.dual_coannihilator ↔ ∀ φ ∈ Φ, (φ x : R) = 0 :=
by simp_rw [dual_coannihilator, mem_comap, mem_dual_annihilator, module.dual.eval_apply]

lemma dual_annihilator_gc (R M : Type*) [comm_semiring R] [add_comm_monoid M] [module R M] :
  galois_connection
    (order_dual.to_dual ∘ (dual_annihilator : submodule R M → submodule R (module.dual R M)))
    (dual_coannihilator ∘ order_dual.of_dual) :=
begin
  intros a b,
  induction b using order_dual.rec,
  simp only [function.comp_app, order_dual.to_dual_le_to_dual, order_dual.of_dual_to_dual],
  split;
  { intros h x hx,
    simp only [mem_dual_annihilator, mem_dual_coannihilator],
    intros y hy,
    have := h hy,
    simp only [mem_dual_annihilator, mem_dual_coannihilator] at this,
    exact this x hx },
end

lemma le_dual_annihilator_iff_le_dual_coannihilator
  {U : submodule R (module.dual R M)} {V : submodule R M} :
  U ≤ V.dual_annihilator ↔ V ≤ U.dual_coannihilator :=
(dual_annihilator_gc R M).le_iff_le

@[simp] lemma dual_annihilator_bot : (⊥ : submodule R M).dual_annihilator = ⊤ :=
(dual_annihilator_gc R M).l_bot

@[simp] lemma dual_annihilator_top : (⊤ : submodule R M).dual_annihilator = ⊥ :=
begin
  rw eq_bot_iff,
  intro v,
  simp_rw [mem_dual_annihilator, mem_bot, mem_top, forall_true_left],
  exact λ h, linear_map.ext h,
end

@[simp] lemma dual_coannihilator_bot :
  (⊥ : submodule R (module.dual R M)).dual_coannihilator = ⊤ :=
(dual_annihilator_gc R M).u_top

@[mono] lemma dual_annihilator_anti {U V : submodule R M} (hUV : U ≤ V) :
  V.dual_annihilator ≤ U.dual_annihilator :=
(dual_annihilator_gc R M).monotone_l hUV

@[mono] lemma dual_coannihilator_anti {U V : submodule R (module.dual R M)} (hUV : U ≤ V) :
  V.dual_coannihilator ≤ U.dual_coannihilator :=
(dual_annihilator_gc R M).monotone_u hUV

lemma le_dual_annihilator_dual_coannihilator (U : submodule R M) :
  U ≤ U.dual_annihilator.dual_coannihilator :=
(dual_annihilator_gc R M).le_u_l U

lemma le_dual_coannihilator_dual_annihilator (U : submodule R (module.dual R M)) :
  U ≤ U.dual_coannihilator.dual_annihilator :=
(dual_annihilator_gc R M).l_u_le U

lemma dual_annihilator_dual_coannihilator_dual_annihilator
  (U : submodule R M) :
  U.dual_annihilator.dual_coannihilator.dual_annihilator = U.dual_annihilator :=
(dual_annihilator_gc R M).l_u_l_eq_l U

lemma dual_coannihilator_dual_annihilator_dual_coannihilator
  (U : submodule R (module.dual R M)) :
  U.dual_coannihilator.dual_annihilator.dual_coannihilator = U.dual_coannihilator :=
(dual_annihilator_gc R M).u_l_u_eq_u U

lemma dual_annihilator_sup_eq (U V : submodule R M) :
  (U ⊔ V).dual_annihilator = U.dual_annihilator ⊓ V.dual_annihilator :=
(dual_annihilator_gc R M).l_sup

lemma dual_coannihilator_sup_eq (U V : submodule R (module.dual R M)) :
  (U ⊔ V).dual_coannihilator = U.dual_coannihilator ⊓ V.dual_coannihilator :=
(dual_annihilator_gc R M).u_inf

lemma dual_annihilator_supr_eq {ι : Type*} (U : ι → submodule R M) :
  (⨆ (i : ι), U i).dual_annihilator = ⨅ (i : ι), (U i).dual_annihilator :=
(dual_annihilator_gc R M).l_supr

lemma dual_coannihilator_supr_eq {ι : Type*} (U : ι → submodule R (module.dual R M)) :
  (⨆ (i : ι), U i).dual_coannihilator = ⨅ (i : ι), (U i).dual_coannihilator :=
(dual_annihilator_gc R M).u_infi

/-- See also `subspace.dual_annihilator_inf_eq` for vector subspaces. -/
lemma sup_dual_annihilator_le_inf (U V : submodule R M) :
  U.dual_annihilator ⊔ V.dual_annihilator ≤ (U ⊓ V).dual_annihilator :=
begin
  rw [le_dual_annihilator_iff_le_dual_coannihilator, dual_coannihilator_sup_eq],
  apply' inf_le_inf; exact le_dual_annihilator_dual_coannihilator _,
end

/-- See also `subspace.dual_annihilator_infi_eq` for vector subspaces when `ι` is finite. -/
lemma supr_dual_annihilator_le_infi {ι : Type*} (U : ι → submodule R M) :
  (⨆ (i : ι), (U i).dual_annihilator) ≤ (⨅ (i : ι), U i).dual_annihilator :=
begin
  rw [le_dual_annihilator_iff_le_dual_coannihilator, dual_coannihilator_supr_eq],
  apply' infi_mono,
  exact λ (i : ι), le_dual_annihilator_dual_coannihilator (U i),
end

end submodule

namespace subspace

open submodule linear_map

universes u v w

-- We work in vector spaces because `exists_is_compl` only hold for vector spaces
variables {K : Type u} {V : Type v} [field K] [add_comm_group V] [module K V]

@[simp] lemma dual_coannihilator_top (W : subspace K V) :
  (⊤ : subspace K (module.dual K W)).dual_coannihilator = ⊥ :=
by rw [dual_coannihilator, dual_annihilator_top, comap_bot, module.eval_ker]

lemma dual_annihilator_dual_coannihilator_eq {W : subspace K V} :
  W.dual_annihilator.dual_coannihilator = W :=
begin
  refine le_antisymm _ (le_dual_annihilator_dual_coannihilator _),
  intro v,
  simp only [mem_dual_annihilator, mem_dual_coannihilator],
  contrapose!,
  intro hv,
  obtain ⟨W', hW⟩ := submodule.exists_is_compl W,
  obtain ⟨⟨w, w'⟩, rfl, -⟩ := exists_unique_add_of_is_compl_prod hW v,
  have hw'n : (w' : V) ∉ W := by { contrapose! hv, exact submodule.add_mem W w.2 hv },
  have hw'nz : w' ≠ 0 := by { rintro rfl, exact hw'n (submodule.zero_mem W) },
  rw [ne.def, ← module.forall_dual_apply_eq_zero_iff K w'] at hw'nz,
  push_neg at hw'nz,
  obtain ⟨φ, hφ⟩ := hw'nz,
  existsi ((linear_map.of_is_compl_prod hW).comp (linear_map.inr _ _ _)) φ,
  simp only [coe_comp, coe_inr, function.comp_app, of_is_compl_prod_apply, map_add,
    of_is_compl_left_apply, zero_apply, of_is_compl_right_apply, zero_add, ne.def],
  refine ⟨_, hφ⟩,
  intros v hv,
  apply linear_map.of_is_compl_left_apply hW ⟨v, hv⟩, -- exact elaborates slowly
end

theorem forall_mem_dual_annihilator_apply_eq_zero_iff (W : subspace K V) (v : V) :
  (∀ (φ : module.dual K V), φ ∈ W.dual_annihilator → φ v = 0) ↔ v ∈ W :=
by rw [← set_like.ext_iff.mp dual_annihilator_dual_coannihilator_eq v,
       mem_dual_coannihilator]

/-- `submodule.dual_annihilator` and `submodule.dual_coannihilator` form a Galois coinsertion. -/
def dual_annihilator_gci (K V : Type*) [field K] [add_comm_group V] [module K V] :
  galois_coinsertion
    (order_dual.to_dual ∘ (dual_annihilator : subspace K V → subspace K (module.dual K V)))
    (dual_coannihilator ∘ order_dual.of_dual) :=
{ choice := λ W h, dual_coannihilator W,
  gc := dual_annihilator_gc K V,
  u_l_le := λ W, dual_annihilator_dual_coannihilator_eq.le,
  choice_eq := λ W h, rfl }

lemma dual_annihilator_le_dual_annihilator_iff {W W' : subspace K V} :
  W.dual_annihilator ≤ W'.dual_annihilator ↔ W' ≤ W :=
(dual_annihilator_gci K V).l_le_l_iff

lemma dual_annihilator_inj {W W' : subspace K V} :
  W.dual_annihilator = W'.dual_annihilator ↔ W = W' :=
begin
  split,
  { apply (dual_annihilator_gci K V).l_injective },
  { rintro rfl, refl },
end

/-- Given a subspace `W` of `V` and an element of its dual `φ`, `dual_lift W φ` is
an arbitrary extension of `φ` to an element of the dual of `V`.
That is, `dual_lift W φ` sends `w ∈ W` to `φ x` and `x` in a chosen complement of `W` to `0`. -/
noncomputable def dual_lift (W : subspace K V) :
  module.dual K W →ₗ[K] module.dual K V :=
let h := classical.indefinite_description _ W.exists_is_compl in
  (linear_map.of_is_compl_prod h.2).comp (linear_map.inl _ _ _)

variable {W : subspace K V}

@[simp] lemma dual_lift_of_subtype {φ : module.dual K W} (w : W) :
  W.dual_lift φ (w : V) = φ w :=
by { erw of_is_compl_left_apply _ w, refl }

lemma dual_lift_of_mem {φ : module.dual K W} {w : V} (hw : w ∈ W) :
  W.dual_lift φ w = φ ⟨w, hw⟩ :=
by convert dual_lift_of_subtype ⟨w, hw⟩

@[simp] lemma dual_restrict_comp_dual_lift (W : subspace K V) :
  W.dual_restrict.comp W.dual_lift = 1 :=
by { ext φ x, simp }

lemma dual_restrict_left_inverse (W : subspace K V) :
  function.left_inverse W.dual_restrict W.dual_lift :=
λ x, show W.dual_restrict.comp W.dual_lift x = x,
  by { rw [dual_restrict_comp_dual_lift], refl }

lemma dual_lift_right_inverse (W : subspace K V) :
  function.right_inverse W.dual_lift W.dual_restrict :=
W.dual_restrict_left_inverse

lemma dual_restrict_surjective :
  function.surjective W.dual_restrict :=
W.dual_lift_right_inverse.surjective

lemma dual_lift_injective : function.injective W.dual_lift :=
W.dual_restrict_left_inverse.injective

/-- The quotient by the `dual_annihilator` of a subspace is isomorphic to the
  dual of that subspace. -/
noncomputable def quot_annihilator_equiv (W : subspace K V) :
  (module.dual K V ⧸ W.dual_annihilator) ≃ₗ[K] module.dual K W :=
(quot_equiv_of_eq _ _ W.dual_restrict_ker_eq_dual_annihilator).symm.trans $
  W.dual_restrict.quot_ker_equiv_of_surjective dual_restrict_surjective

@[simp] lemma quot_annihilator_equiv_apply (W : subspace K V) (φ : module.dual K V) :
  W.quot_annihilator_equiv (submodule.quotient.mk φ) = W.dual_restrict φ :=
by { ext, refl }

/-- The natural isomorphism from the dual of a subspace `W` to `W.dual_lift.range`. -/
noncomputable def dual_equiv_dual (W : subspace K V) :
  module.dual K W ≃ₗ[K] W.dual_lift.range :=
linear_equiv.of_injective _ dual_lift_injective

lemma dual_equiv_dual_def (W : subspace K V) :
  W.dual_equiv_dual.to_linear_map = W.dual_lift.range_restrict := rfl

@[simp] lemma dual_equiv_dual_apply (φ : module.dual K W) :
  W.dual_equiv_dual φ = ⟨W.dual_lift φ, mem_range.2 ⟨φ, rfl⟩⟩ := rfl

section

open_locale classical

open finite_dimensional

variables {V₁ : Type*} [add_comm_group V₁] [module K V₁]

instance [H : finite_dimensional K V] : finite_dimensional K (module.dual K V) :=
by apply_instance

variables [finite_dimensional K V] [finite_dimensional K V₁]

lemma dual_annihilator_dual_annihilator_eq (W : subspace K V) :
  W.dual_annihilator.dual_annihilator = module.map_eval_equiv K V W :=
begin
  have : _ = W := subspace.dual_annihilator_dual_coannihilator_eq,
  rw [dual_coannihilator, ← module.map_eval_equiv_symm_apply] at this,
  rwa ← order_iso.symm_apply_eq,
end

-- TODO(kmill): https://github.com/leanprover-community/mathlib/pull/17521#discussion_r1083241963
@[simp] lemma dual_finrank_eq :
  finrank K (module.dual K V) = finrank K V :=
linear_equiv.finrank_eq (basis.of_vector_space K V).to_dual_equiv.symm

/-- The quotient by the dual is isomorphic to its dual annihilator.  -/
noncomputable def quot_dual_equiv_annihilator (W : subspace K V) :
  (module.dual K V ⧸ W.dual_lift.range) ≃ₗ[K] W.dual_annihilator :=
linear_equiv.quot_equiv_of_quot_equiv $
  linear_equiv.trans W.quot_annihilator_equiv W.dual_equiv_dual

/-- The quotient by a subspace is isomorphic to its dual annihilator. -/
noncomputable def quot_equiv_annihilator (W : subspace K V) :
  (V ⧸ W) ≃ₗ[K] W.dual_annihilator :=
begin
  refine _ ≪≫ₗ W.quot_dual_equiv_annihilator,
  refine linear_equiv.quot_equiv_of_equiv _ (basis.of_vector_space K V).to_dual_equiv,
  exact (basis.of_vector_space K W).to_dual_equiv.trans W.dual_equiv_dual
end

open finite_dimensional

@[simp]
lemma finrank_dual_coannihilator_eq {Φ : subspace K (module.dual K V)} :
  finrank K Φ.dual_coannihilator = finrank K Φ.dual_annihilator :=
begin
  rw [submodule.dual_coannihilator, ← module.eval_equiv_to_linear_map],
  exact linear_equiv.finrank_eq (linear_equiv.of_submodule' _ _),
end

lemma finrank_add_finrank_dual_coannihilator_eq
  (W : subspace K (module.dual K V)) :
  finrank K W + finrank K W.dual_coannihilator = finrank K V :=
begin
  rw [finrank_dual_coannihilator_eq, W.quot_equiv_annihilator.finrank_eq.symm, add_comm,
      submodule.finrank_quotient_add_finrank, subspace.dual_finrank_eq],
end

end

end subspace

open module

namespace linear_map
variables {R : Type*} [comm_semiring R] {M₁ : Type*} {M₂ : Type*}
variables [add_comm_monoid M₁] [module R M₁] [add_comm_monoid M₂] [module R M₂]

variable (f : M₁ →ₗ[R] M₂)

lemma ker_dual_map_eq_dual_annihilator_range :
  f.dual_map.ker = f.range.dual_annihilator :=
begin
  ext φ, split; intro hφ,
  { rw mem_ker at hφ,
    rw submodule.mem_dual_annihilator,
    rintro y ⟨x, rfl⟩,
    rw [← dual_map_apply, hφ, zero_apply] },
  { ext x,
    rw dual_map_apply,
    rw submodule.mem_dual_annihilator at hφ,
    exact hφ (f x) ⟨x, rfl⟩ }
end

lemma range_dual_map_le_dual_annihilator_ker :
  f.dual_map.range ≤ f.ker.dual_annihilator :=
begin
  rintro _ ⟨ψ, rfl⟩,
  simp_rw [submodule.mem_dual_annihilator, mem_ker],
  rintro x hx,
  rw [dual_map_apply, hx, map_zero]
end

end linear_map

section comm_ring

variables {R M M' : Type*}
variables [comm_ring R] [add_comm_group M] [module R M] [add_comm_group M'] [module R M']

namespace submodule

/-- Given a submodule, corestrict to the pairing on `M ⧸ W` by
simultaneously restricting to `W.dual_annihilator`.

See `subspace.dual_copairing_nondegenerate`. -/
def dual_copairing (W : submodule R M) :
  W.dual_annihilator →ₗ[R] M ⧸ W →ₗ[R] R :=
linear_map.flip $ W.liftq ((module.dual_pairing R M).dom_restrict W.dual_annihilator).flip
  (by { intros w hw, ext ⟨φ, hφ⟩, exact (mem_dual_annihilator φ).mp hφ w hw })

@[simp] lemma dual_copairing_apply {W : submodule R M} (φ : W.dual_annihilator) (x : M) :
  W.dual_copairing φ (quotient.mk x) = φ x := rfl

/-- Given a submodule, restrict to the pairing on `W` by
simultaneously corestricting to `module.dual R M ⧸ W.dual_annihilator`.
This is `submodule.dual_restrict` factored through the quotient by its kernel (which
is `W.dual_annihilator` by definition).

See `subspace.dual_pairing_nondegenerate`. -/
def dual_pairing (W : submodule R M) :
  module.dual R M ⧸ W.dual_annihilator →ₗ[R] W →ₗ[R] R :=
W.dual_annihilator.liftq W.dual_restrict le_rfl

@[simp] lemma dual_pairing_apply {W : submodule R M} (φ : module.dual R M) (x : W) :
  W.dual_pairing (quotient.mk φ) x = φ x := rfl

/-- That $\operatorname{im}(q^* : (V/W)^* \to V^*) = \operatorname{ann}(W)$. -/
lemma range_dual_map_mkq_eq (W : submodule R M) :
  W.mkq.dual_map.range = W.dual_annihilator :=
begin
  ext φ,
  rw linear_map.mem_range,
  split,
  { rintro ⟨ψ, rfl⟩,
    have := linear_map.mem_range_self W.mkq.dual_map ψ,
    simpa only [ker_mkq] using linear_map.range_dual_map_le_dual_annihilator_ker W.mkq this, },
  { intro hφ,
    existsi W.dual_copairing ⟨φ, hφ⟩,
    ext,
    refl, }
end

/-- Equivalence $(M/W)^* \approx \operatorname{ann}(W)$. That is, there is a one-to-one
correspondence between the dual of `M ⧸ W` and those elements of the dual of `M` that
vanish on `W`.

The inverse of this is `submodule.dual_copairing`. -/
def dual_quot_equiv_dual_annihilator (W : submodule R M) :
  module.dual R (M ⧸ W) ≃ₗ[R] W.dual_annihilator :=
linear_equiv.of_linear
  (W.mkq.dual_map.cod_restrict W.dual_annihilator $
    λ φ, W.range_dual_map_mkq_eq ▸ W.mkq.dual_map.mem_range_self φ)
  W.dual_copairing
  (by { ext, refl}) (by { ext, refl })

@[simp] lemma dual_quot_equiv_dual_annihilator_apply (W : submodule R M)
  (φ : module.dual R (M ⧸ W)) (x : M) :
  dual_quot_equiv_dual_annihilator W φ x = φ (quotient.mk x) := rfl

lemma dual_copairing_eq (W : submodule R M) :
  W.dual_copairing = (dual_quot_equiv_dual_annihilator W).symm.to_linear_map := rfl

@[simp] lemma dual_quot_equiv_dual_annihilator_symm_apply_mk (W : submodule R M)
  (φ : W.dual_annihilator) (x : M) :
  (dual_quot_equiv_dual_annihilator W).symm φ (quotient.mk x) = φ x := rfl

end submodule

namespace linear_map
open submodule

lemma range_dual_map_eq_dual_annihilator_ker_of_surjective
  (f : M →ₗ[R] M') (hf : function.surjective f) :
  f.dual_map.range = f.ker.dual_annihilator :=
begin
  rw ← f.ker.range_dual_map_mkq_eq,
  let f' := linear_map.quot_ker_equiv_of_surjective f hf,
  transitivity linear_map.range (f.dual_map.comp f'.symm.dual_map.to_linear_map),
  { rw linear_map.range_comp_of_range_eq_top,
    apply linear_equiv.range },
  { apply congr_arg,
    ext φ x,
    simp only [linear_map.coe_comp, linear_equiv.coe_to_linear_map, linear_map.dual_map_apply,
      linear_equiv.dual_map_apply, mkq_apply, f', linear_map.quot_ker_equiv_of_surjective,
      linear_equiv.trans_symm, linear_equiv.trans_apply, linear_equiv.of_top_symm_apply,
      linear_map.quot_ker_equiv_range_symm_apply_image, mkq_apply], }
end

-- Note, this can be specialized to the case where `R` is an injective `R`-module, or when
-- `f.coker` is a projective `R`-module.
lemma range_dual_map_eq_dual_annihilator_ker_of_subtype_range_surjective
  (f : M →ₗ[R] M') (hf : function.surjective f.range.subtype.dual_map) :
  f.dual_map.range = f.ker.dual_annihilator :=
begin
  have rr_surj : function.surjective f.range_restrict,
  { rw [← linear_map.range_eq_top, linear_map.range_range_restrict] },
  have := range_dual_map_eq_dual_annihilator_ker_of_surjective f.range_restrict rr_surj,
  convert this using 1,
  { change ((submodule.subtype f.range).comp f.range_restrict).dual_map.range = _,
    rw [← linear_map.dual_map_comp_dual_map, linear_map.range_comp_of_range_eq_top],
    rwa linear_map.range_eq_top, },
  { apply congr_arg,
    exact (linear_map.ker_range_restrict f).symm, },
end

end linear_map

end comm_ring

section vector_space

variables {K : Type*} [field K] {V₁ : Type*} {V₂ : Type*}
variables [add_comm_group V₁] [module K V₁] [add_comm_group V₂] [module K V₂]

namespace linear_map

lemma dual_pairing_nondegenerate : (dual_pairing K V₁).nondegenerate :=
⟨separating_left_iff_ker_eq_bot.mpr ker_id, λ x, (forall_dual_apply_eq_zero_iff K x).mp⟩

lemma dual_map_surjective_of_injective {f : V₁ →ₗ[K] V₂} (hf : function.injective f) :
  function.surjective f.dual_map :=
begin
  intro φ,
  let f' := linear_equiv.of_injective f hf,
  use subspace.dual_lift (range f) (f'.symm.dual_map φ),
  ext x,
  rw [linear_map.dual_map_apply, subspace.dual_lift_of_mem (mem_range_self f x),
    linear_equiv.dual_map_apply],
  congr' 1,
  exact linear_equiv.symm_apply_apply f' x,
end

lemma range_dual_map_eq_dual_annihilator_ker (f : V₁ →ₗ[K] V₂) :
  f.dual_map.range = f.ker.dual_annihilator :=
range_dual_map_eq_dual_annihilator_ker_of_subtype_range_surjective f $
  dual_map_surjective_of_injective (range f).injective_subtype

/-- For vector spaces, `f.dual_map` is surjective if and only if `f` is injective -/
@[simp] lemma dual_map_surjective_iff {f : V₁ →ₗ[K] V₂} :
  function.surjective f.dual_map ↔ function.injective f :=
by rw [← linear_map.range_eq_top, range_dual_map_eq_dual_annihilator_ker,
       ← submodule.dual_annihilator_bot, subspace.dual_annihilator_inj, linear_map.ker_eq_bot]

end linear_map

namespace subspace
open submodule

lemma dual_pairing_eq (W : subspace K V₁) :
  W.dual_pairing = W.quot_annihilator_equiv.to_linear_map :=
by { ext, refl }

lemma dual_pairing_nondegenerate (W : subspace K V₁) : W.dual_pairing.nondegenerate :=
begin
  split,
  { rw [linear_map.separating_left_iff_ker_eq_bot, dual_pairing_eq],
    apply linear_equiv.ker, },
  { intros x h,
    rw ← forall_dual_apply_eq_zero_iff K x,
    intro φ,
    simpa only [submodule.dual_pairing_apply, dual_lift_of_subtype]
      using h (submodule.quotient.mk (W.dual_lift φ)), }
end

lemma dual_copairing_nondegenerate (W : subspace K V₁) : W.dual_copairing.nondegenerate :=
begin
  split,
  { rw [linear_map.separating_left_iff_ker_eq_bot, dual_copairing_eq],
    apply linear_equiv.ker, },
  { rintro ⟨x⟩,
    simp only [quotient.quot_mk_eq_mk, dual_copairing_apply, quotient.mk_eq_zero],
    rw [← forall_mem_dual_annihilator_apply_eq_zero_iff, set_like.forall],
    exact id, }
end

-- Argument from https://math.stackexchange.com/a/2423263/172988
lemma dual_annihilator_inf_eq (W W' : subspace K V₁) :
  (W ⊓ W').dual_annihilator = W.dual_annihilator ⊔ W'.dual_annihilator :=
begin
  refine le_antisymm _ (sup_dual_annihilator_le_inf W W'),
  let F : V₁ →ₗ[K] (V₁ ⧸ W) × (V₁ ⧸ W') := (submodule.mkq W).prod (submodule.mkq W'),
  have : F.ker = W ⊓ W' := by simp only [linear_map.ker_prod, ker_mkq],
  rw [← this, ← linear_map.range_dual_map_eq_dual_annihilator_ker],
  intro φ,
  rw [linear_map.mem_range],
  rintro ⟨x, rfl⟩,
  rw [submodule.mem_sup],
  obtain ⟨⟨a, b⟩, rfl⟩ := (dual_prod_dual_equiv_dual K (V₁ ⧸ W) (V₁ ⧸ W')).surjective x,
  obtain ⟨a', rfl⟩ := (dual_quot_equiv_dual_annihilator W).symm.surjective a,
  obtain ⟨b', rfl⟩ := (dual_quot_equiv_dual_annihilator W').symm.surjective b,
  use [a', a'.property, b', b'.property],
  refl,
end

-- This is also true if `V₁` is finite dimensional since one can restrict `ι` to some subtype
-- for which the infi and supr are the same.
--
-- The obstruction to the `dual_annihilator_inf_eq` argument carrying through is that we need
-- for `module.dual R (Π (i : ι), V ⧸ W i) ≃ₗ[K] Π (i : ι), module.dual R (V ⧸ W i)`, which is not
-- true for infinite `ι`. One would need to add additional hypothesis on `W` (for example, it might
-- be true when the family is inf-closed).
lemma dual_annihilator_infi_eq {ι : Type*} [_root_.finite ι] (W : ι → subspace K V₁) :
  (⨅ (i : ι), W i).dual_annihilator = (⨆ (i : ι), (W i).dual_annihilator) :=
begin
  unfreezingI { revert ι },
  refine finite.induction_empty_option _ _ _,
  { intros α β h hyp W,
    rw [← h.infi_comp, hyp (W ∘ h), ← h.supr_comp], },
  { intro W,
    rw [supr_of_empty', infi_of_empty', Inf_empty, Sup_empty, dual_annihilator_top], },
  { introsI α _ h W,
    rw [infi_option, supr_option, dual_annihilator_inf_eq, h], }
end

/-- For vector spaces, dual annihilators carry direct sum decompositions
to direct sum decompositions. -/
lemma is_compl_dual_annihilator {W W' : subspace K V₁} (h : is_compl W W') :
  is_compl W.dual_annihilator W'.dual_annihilator :=
begin
  rw [is_compl_iff, disjoint_iff, codisjoint_iff] at h ⊢,
  rw [← dual_annihilator_inf_eq, ← dual_annihilator_sup_eq, h.1, h.2,
    dual_annihilator_top, dual_annihilator_bot],
  exact ⟨rfl, rfl⟩
end

/-- For finite-dimensional vector spaces, one can distribute duals over quotients by identifying
`W.dual_lift.range` with `W`. Note that this depends on a choice of splitting of `V₁`. -/
def dual_quot_distrib [finite_dimensional K V₁] (W : subspace K V₁) :
  module.dual K (V₁ ⧸ W) ≃ₗ[K] (module.dual K V₁ ⧸ W.dual_lift.range) :=
W.dual_quot_equiv_dual_annihilator.trans W.quot_dual_equiv_annihilator.symm

end subspace

section finite_dimensional

open finite_dimensional linear_map

variable [finite_dimensional K V₂]

namespace linear_map

-- TODO(kmill) remove finite_dimensional if possible
-- see https://github.com/leanprover-community/mathlib/pull/17521#discussion_r1083242551
@[simp] lemma finrank_range_dual_map_eq_finrank_range (f : V₁ →ₗ[K] V₂) :
  finrank K f.dual_map.range = finrank K f.range :=
begin
  have := submodule.finrank_quotient_add_finrank f.range,
  rw [(subspace.quot_equiv_annihilator f.range).finrank_eq,
      ← ker_dual_map_eq_dual_annihilator_range] at this,
  conv_rhs at this { rw ← subspace.dual_finrank_eq },
  refine add_left_injective (finrank K f.dual_map.ker) _,
  change _ + _ = _ + _,
  rw [finrank_range_add_finrank_ker f.dual_map, add_comm, this],
end

/-- `f.dual_map` is injective if and only if `f` is surjective -/
@[simp] lemma dual_map_injective_iff {f : V₁ →ₗ[K] V₂} :
  function.injective f.dual_map ↔ function.surjective f :=
begin
  refine ⟨_, λ h, dual_map_injective_of_surjective h⟩,
  rw [← range_eq_top, ← ker_eq_bot],
  intro h,
  apply finite_dimensional.eq_top_of_finrank_eq,
  rw ← finrank_eq_zero at h,
  rw [← add_zero (finite_dimensional.finrank K f.range), ← h,
      ← linear_map.finrank_range_dual_map_eq_finrank_range,
      linear_map.finrank_range_add_finrank_ker, subspace.dual_finrank_eq],
end

/-- `f.dual_map` is bijective if and only if `f` is -/
@[simp] lemma dual_map_bijective_iff {f : V₁ →ₗ[K] V₂} :
  function.bijective f.dual_map ↔ function.bijective f :=
by simp_rw [function.bijective, dual_map_surjective_iff, dual_map_injective_iff, and.comm]

end linear_map

end finite_dimensional

end vector_space

namespace tensor_product

variables (R : Type*) (M : Type*) (N : Type*)

variables {ι κ : Type*}
variables [decidable_eq ι] [decidable_eq κ]
variables [fintype ι] [fintype κ]

open_locale big_operators
open_locale tensor_product

local attribute [ext] tensor_product.ext

open tensor_product
open linear_map

section
variables [comm_semiring R] [add_comm_monoid M] [add_comm_monoid N]
variables [module R M] [module R N]

/--
The canonical linear map from `dual M ⊗ dual N` to `dual (M ⊗ N)`,
sending `f ⊗ g` to the composition of `tensor_product.map f g` with
the natural isomorphism `R ⊗ R ≃ R`.
-/
def dual_distrib : (dual R M) ⊗[R] (dual R N) →ₗ[R] dual R (M ⊗[R] N) :=
(comp_right ↑(tensor_product.lid R R)) ∘ₗ hom_tensor_hom_map R M N R R

variables {R M N}

@[simp]
lemma dual_distrib_apply (f : dual R M) (g : dual R N) (m : M) (n : N) :
  dual_distrib R M N (f ⊗ₜ g) (m ⊗ₜ n) = f m * g n :=
rfl

end

variables {R M N}
variables [comm_ring R] [add_comm_group M] [add_comm_group N]
variables [module R M] [module R N]

/--
An inverse to `dual_tensor_dual_map` given bases.
-/
noncomputable
def dual_distrib_inv_of_basis (b : basis ι R M) (c : basis κ R N) :
  dual R (M ⊗[R] N) →ₗ[R] (dual R M) ⊗[R] (dual R N) :=
∑ i j, (ring_lmap_equiv_self R ℕ _).symm (b.dual_basis i ⊗ₜ c.dual_basis j)
    ∘ₗ applyₗ (c j) ∘ₗ applyₗ (b i) ∘ₗ (lcurry R M N R)

@[simp]
lemma dual_distrib_inv_of_basis_apply (b : basis ι R M) (c : basis κ R N)
  (f : dual R (M ⊗[R] N)) : dual_distrib_inv_of_basis b c f =
  ∑ i j, (f (b i ⊗ₜ c j)) • (b.dual_basis i ⊗ₜ c.dual_basis j) :=
by simp [dual_distrib_inv_of_basis]

/--
A linear equivalence between `dual M ⊗ dual N` and `dual (M ⊗ N)` given bases for `M` and `N`.
It sends `f ⊗ g` to the composition of `tensor_product.map f g` with the natural
isomorphism `R ⊗ R ≃ R`.
-/
@[simps]
noncomputable def dual_distrib_equiv_of_basis (b : basis ι R M) (c : basis κ R N) :
  (dual R M) ⊗[R] (dual R N) ≃ₗ[R] dual R (M ⊗[R] N) :=
begin
  refine linear_equiv.of_linear
    (dual_distrib R M N) (dual_distrib_inv_of_basis b c) _ _,
  { ext f m n,
    have h : ∀ (r s : R), r • s = s • r := is_commutative.comm,
    simp only [compr₂_apply, mk_apply, comp_apply, id_apply, dual_distrib_inv_of_basis_apply,
      linear_map.map_sum, map_smul, sum_apply, smul_apply, dual_distrib_apply, h (f _) _,
      ← f.map_smul, ←f.map_sum, ←smul_tmul_smul, ←tmul_sum, ←sum_tmul, basis.coe_dual_basis,
      basis.coord_apply, basis.sum_repr] },
  { ext f g,
    simp only [compr₂_apply, mk_apply, comp_apply, id_apply, dual_distrib_inv_of_basis_apply,
      dual_distrib_apply, ←smul_tmul_smul, ←tmul_sum, ←sum_tmul, basis.coe_dual_basis,
      basis.sum_dual_apply_smul_coord] }
end

variables (R M N)
variables [module.finite R M] [module.finite R N] [module.free R M] [module.free R N]
variables [nontrivial R]

open_locale classical

/--
A linear equivalence between `dual M ⊗ dual N` and `dual (M ⊗ N)` when `M` and `N` are finite free
modules. It sends `f ⊗ g` to the composition of `tensor_product.map f g` with the natural
isomorphism `R ⊗ R ≃ R`.
-/
@[simp]
noncomputable
def dual_distrib_equiv : (dual R M) ⊗[R] (dual R N) ≃ₗ[R] dual R (M ⊗[R] N) :=
dual_distrib_equiv_of_basis (module.free.choose_basis R M) (module.free.choose_basis R N)

end tensor_product


/-
Copyright (c) 2023 Kevin Buzzard. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author : Kevin Buzzard
-/

import field_theory.abel_ruffini

/-

## Insolvability of the quintic

There exist polynomials whose solutions cannot be expressed by radicals.

Let `E` be a field and assume `p : E[X]` is a polynomial
-/

open_locale polynomial

variables (E : Type) [field E] (p : E[X])

-- The Galois group of `p` is the Galois group of `F/E` where `F` is the splitting field of `p`.

open polynomial

example : p.gal = ((splitting_field p) ≃ₐ[E] (splitting_field p)) := rfl

/-
If F/E is any field extension at all, then `solvable_by_rad E F` is the intermediate field consisting
of elements which can be built using n'th roots and the field operations, starting from `E`. Here
is the rather beautiful definition of the underlying set of this intermediate field:

```
/-- Inductive definition of solvable by radicals -/
inductive is_solvable_by_rad : E → Prop
| base (a : F) : is_solvable_by_rad (algebra_map F E a)
| add (a b : E) : is_solvable_by_rad a → is_solvable_by_rad b → is_solvable_by_rad (a + b)
| neg (α : E) : is_solvable_by_rad α → is_solvable_by_rad (-α)
| mul (α β : E) : is_solvable_by_rad α → is_solvable_by_rad β → is_solvable_by_rad (α * β)
| inv (α : E) : is_solvable_by_rad α → is_solvable_by_rad α⁻¹
| rad (α : E) (n : ℕ) (hn : n ≠ 0) : is_solvable_by_rad (α^n) → is_solvable_by_rad α
```

-/

variables  (F : Type) [field F] [algebra E F]
example : intermediate_field E F := solvable_by_rad E F

-- The Abel-Ruffini theorem is that the min poly of an element in `solvable_by_rad E F` has solvable Galois group

example (a : solvable_by_rad E F) : is_solvable ((minpoly E a).gal) := solvable_by_rad.is_solvable a

-- This was hard won! It was only finished a year or so ago.

-- A symmetric group of size 5 or more is known not to be solvable:

example (X : Type) (hX : 5 ≤ cardinal.mk X) : ¬is_solvable (equiv.perm X) := equiv.perm.not_solvable X hX

-- Using a root of x^5-4x+2 and the machinery in this section, Browning proves

example : ∃ x : ℂ, is_algebraic ℚ x ∧ ¬ is_solvable_by_rad ℚ x := sorry

-- See the file `archive.100-theorems-list.16_abel_ruffini`.


/-
Copyright (c) 2018 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad
-/
import topology.continuous_on
import order.filter.partial

/-!
# Partial functions and topological spaces

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

In this file we prove properties of `filter.ptendsto` etc in topological spaces. We also introduce
`pcontinuous`, a version of `continuous` for partially defined functions.
-/

open filter
open_locale topology

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

theorem rtendsto_nhds {r : rel β α} {l : filter β} {a : α} :
  rtendsto r l (𝓝 a) ↔ (∀ s, is_open s → a ∈ s → r.core s ∈ l) :=
all_mem_nhds_filter _ _ (λ s t, id) _

theorem rtendsto'_nhds {r : rel β α} {l : filter β} {a : α} :
  rtendsto' r l (𝓝 a) ↔ (∀ s, is_open s → a ∈ s → r.preimage s ∈ l) :=
by { rw [rtendsto'_def], apply all_mem_nhds_filter, apply rel.preimage_mono }

theorem ptendsto_nhds {f : β →. α} {l : filter β} {a : α} :
  ptendsto f l (𝓝 a) ↔ (∀ s, is_open s → a ∈ s → f.core s ∈ l) :=
rtendsto_nhds

theorem ptendsto'_nhds {f : β →. α} {l : filter β} {a : α} :
  ptendsto' f l (𝓝 a) ↔ (∀ s, is_open s → a ∈ s → f.preimage s ∈ l) :=
rtendsto'_nhds

/-! ### Continuity and partial functions -/

variable [topological_space β]

/-- Continuity of a partial function -/
def pcontinuous (f : α →. β) := ∀ s, is_open s → is_open (f.preimage s)

lemma open_dom_of_pcontinuous {f : α →. β} (h : pcontinuous f) : is_open f.dom :=
by rw [←pfun.preimage_univ]; exact h _ is_open_univ

lemma pcontinuous_iff' {f : α →. β} :
  pcontinuous f ↔ ∀ {x y} (h : y ∈ f x), ptendsto' f (𝓝 x) (𝓝 y) :=
begin
  split,
  { intros h x y h',
    simp only [ptendsto'_def, mem_nhds_iff],
    rintros s ⟨t, tsubs, opent, yt⟩,
    exact ⟨f.preimage t, pfun.preimage_mono _ tsubs, h _ opent, ⟨y, yt, h'⟩⟩ },
  intros hf s os,
  rw is_open_iff_nhds,
  rintros x ⟨y, ys, fxy⟩ t,
  rw [mem_principal],
  assume h : f.preimage s ⊆ t,
  change t ∈ 𝓝 x,
  apply mem_of_superset _ h,
  have h' : ∀ s ∈ 𝓝 y, f.preimage s ∈ 𝓝 x,
  { intros s hs,
     have : ptendsto' f (𝓝 x) (𝓝 y) := hf fxy,
     rw ptendsto'_def at this,
     exact this s hs },
  show f.preimage s ∈ 𝓝 x,
  apply h', rw mem_nhds_iff, exact ⟨s, set.subset.refl _, os, ys⟩
end

theorem continuous_within_at_iff_ptendsto_res (f : α → β) {x : α} {s : set α} :
  continuous_within_at f s x ↔ ptendsto (pfun.res f s) (𝓝 x) (𝓝 (f x)) :=
tendsto_iff_ptendsto _ _ _ _


/-
Copyright (c) 2022 Jujian Zhang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jujian Zhang
-/
import algebra.category.Group.epi_mono
import algebra.category.Module.epi_mono
import algebra.module.injective
import category_theory.preadditive.injective
import group_theory.divisible
import ring_theory.principal_ideal_domain

/-!
# Injective objects in the category of abelian groups

In this file we prove that divisible groups are injective object in category of (additive) abelian
groups.

-/

open category_theory
open_locale pointwise

universe u

variables (A : Type u) [add_comm_group A]

namespace AddCommGroup

lemma injective_of_injective_as_module [injective (⟨A⟩ : Module ℤ)] :
  category_theory.injective (⟨A⟩ : AddCommGroup) :=
{ factors := λ X Y g f m,
  begin
    resetI,
    let G : (⟨X⟩ : Module ℤ) ⟶ ⟨A⟩ :=
      { map_smul' := by { intros, rw [ring_hom.id_apply, g.to_fun_eq_coe, map_zsmul], }, ..g },
    let F : (⟨X⟩ : Module ℤ) ⟶ ⟨Y⟩ :=
      { map_smul' := by { intros, rw [ring_hom.id_apply, f.to_fun_eq_coe, map_zsmul], }, ..f },
    haveI : mono F,
    { refine ⟨λ Z α β eq1, _⟩,
      let α' : AddCommGroup.of Z ⟶ X := α.to_add_monoid_hom,
      let β' : AddCommGroup.of Z ⟶ X := β.to_add_monoid_hom,
      have eq2 : α' ≫ f = β' ≫ f,
      { ext,
        simp only [category_theory.comp_apply, linear_map.to_add_monoid_hom_coe],
        simpa only [Module.coe_comp, linear_map.coe_mk,
          function.comp_app] using fun_like.congr_fun eq1 x },
      rw cancel_mono at eq2,
      ext, simpa only using fun_like.congr_fun eq2 x, },
    refine ⟨(injective.factor_thru G F).to_add_monoid_hom, _⟩,
    ext, convert fun_like.congr_fun (injective.comp_factor_thru G F) x,
  end }

lemma injective_as_module_of_injective_as_Ab [injective (⟨A⟩ : AddCommGroup)] :
  injective (⟨A⟩ : Module ℤ) :=
{ factors := λ X Y g f m,
  begin
    resetI,
    let G : (⟨X⟩ : AddCommGroup) ⟶ ⟨A⟩ := g.to_add_monoid_hom,
    let F : (⟨X⟩ : AddCommGroup) ⟶ ⟨Y⟩ := f.to_add_monoid_hom,
    haveI : mono F,
    { rw mono_iff_injective, intros _ _ h, exact ((Module.mono_iff_injective f).mp m) h, },
    refine ⟨{map_smul' := _, ..injective.factor_thru G F}, _⟩,
    { intros m x, rw [add_monoid_hom.to_fun_eq_coe, ring_hom.id_apply],
      induction m using int.induction_on with n hn n hn,
      { rw [zero_smul],
        convert map_zero _,
        convert zero_smul _ x, },
      { simp only [add_smul, map_add, hn, one_smul], },
      { simp only [sub_smul, map_sub, hn, one_smul] }, },
    ext, convert fun_like.congr_fun (injective.comp_factor_thru G F) x,
  end }

instance injective_of_divisible [divisible_by A ℤ] :
  category_theory.injective (⟨A⟩ : AddCommGroup) :=
@@injective_of_injective_as_module A _ $
@@module.injective_object_of_injective_module ℤ _ A _ _ $
module.Baer.injective $
λ I g, begin
  rcases is_principal_ideal_ring.principal I with ⟨m, rfl⟩,
  by_cases m_eq_zero : m = 0,
  { subst m_eq_zero,
    refine ⟨{ to_fun := _, map_add' := _, map_smul' := _ }, λ n hn, _⟩,
    { intros n, exact g 0, },
    { intros n1 n2,
      simp only [map_zero, add_zero] },
    { intros n1 n2,
      simp only [map_zero, smul_zero], },
    { rw [submodule.span_singleton_eq_bot.mpr rfl, submodule.mem_bot] at hn,
      simp only [hn, map_zero],
      symmetry,
      convert map_zero _, }, },
  { set gₘ := g ⟨m, submodule.subset_span (set.mem_singleton _)⟩ with gm_eq,
    refine ⟨{ to_fun := _, map_add' := _, map_smul' := _ }, λ n hn, _⟩,
    { intros n,
      exact n • divisible_by.div gₘ m, },
    { intros n1 n2, simp only [add_smul], },
    { intros n1 n2,
      rw [ring_hom.id_apply, smul_eq_mul, mul_smul], },
    { rw submodule.mem_span_singleton at hn,
      rcases hn with ⟨n, rfl⟩,
      simp only [gm_eq, algebra.id.smul_eq_mul, linear_map.coe_mk],
      rw [mul_smul, divisible_by.div_cancel (g ⟨m, _⟩) m_eq_zero, ←linear_map.map_smul],
      congr, }, },
end

end AddCommGroup


/-
Copyright (c) 2018 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau
-/
import data.fintype.basic
import group_theory.subgroup.basic

/-!
# Free groups

This file defines free groups over a type. Furthermore, it is shown that the free group construction
is an instance of a monad. For the result that `free_group` is the left adjoint to the forgetful
functor from groups to types, see `algebra/category/Group/adjunctions`.

## Main definitions

* `free_group`: the free group associated to a type `α` defined as the words over `a : α × bool`
  modulo the relation `a * x * x⁻¹ * b = a * b`.
* `free_group.mk`: the canonical quotient map `list (α × bool) → free_group α`.
* `free_group.of`: the canoical injection `α → free_group α`.
* `free_group.lift f`: the canonical group homomorphism `free_group α →* G`
  given a group `G` and a function `f : α → G`.

## Main statements

* `free_group.church_rosser`: The Church-Rosser theorem for word reduction
  (also known as Newman's diamond lemma).
* `free_group.free_group_unit_equiv_int`: The free group over the one-point type
  is isomorphic to the integers.
* The free group construction is an instance of a monad.

## Implementation details

First we introduce the one step reduction relation `free_group.red.step`:
`w * x * x⁻¹ * v   ~>   w * v`, its reflexive transitive closure `free_group.red.trans`
and prove that its join is an equivalence relation. Then we introduce `free_group α` as a quotient
over `free_group.red.step`.

## Tags

free group, Newman's diamond lemma, Church-Rosser theorem
-/

open relation

universes u v w

variables {α : Type u}

local attribute [simp] list.append_eq_has_append

namespace free_group
variables {L L₁ L₂ L₃ L₄ : list (α × bool)}

/-- Reduction step: `w * x * x⁻¹ * v ~> w * v` -/
inductive red.step : list (α × bool) → list (α × bool) → Prop
| bnot {L₁ L₂ x b} : red.step (L₁ ++ (x, b) :: (x, bnot b) :: L₂) (L₁ ++ L₂)
attribute [simp] red.step.bnot

/-- Reflexive-transitive closure of red.step -/
def red : list (α × bool) → list (α × bool) → Prop := refl_trans_gen red.step

@[refl] lemma red.refl : red L L := refl_trans_gen.refl
@[trans] lemma red.trans : red L₁ L₂ → red L₂ L₃ → red L₁ L₃ := refl_trans_gen.trans

namespace red

/-- Predicate asserting that word `w₁` can be reduced to `w₂` in one step, i.e. there are words
`w₃ w₄` and letter `x` such that `w₁ = w₃xx⁻¹w₄` and `w₂ = w₃w₄`  -/
theorem step.length : ∀ {L₁ L₂ : list (α × bool)}, step L₁ L₂ → L₂.length + 2 = L₁.length
| _ _ (@red.step.bnot _ L1 L2 x b) := by rw [list.length_append, list.length_append]; refl

@[simp] lemma step.bnot_rev {x b} : step (L₁ ++ (x, bnot b) :: (x, b) :: L₂) (L₁ ++ L₂) :=
by cases b; from step.bnot

@[simp] lemma step.cons_bnot {x b} : red.step ((x, b) :: (x, bnot b) :: L) L :=
@step.bnot _ [] _ _ _

@[simp] lemma step.cons_bnot_rev {x b} : red.step ((x, bnot b) :: (x, b) :: L) L :=
@red.step.bnot_rev _ [] _ _ _

theorem step.append_left : ∀ {L₁ L₂ L₃ : list (α × bool)}, step L₂ L₃ → step (L₁ ++ L₂) (L₁ ++ L₃)
| _ _ _ red.step.bnot := by rw [← list.append_assoc, ← list.append_assoc]; constructor

theorem step.cons {x} (H : red.step L₁ L₂) : red.step (x :: L₁) (x :: L₂) :=
@step.append_left _ [x] _ _ H

theorem step.append_right : ∀ {L₁ L₂ L₃ : list (α × bool)}, step L₁ L₂ → step (L₁ ++ L₃) (L₂ ++ L₃)
| _ _ _ red.step.bnot := by simp

lemma not_step_nil : ¬ step [] L :=
begin
  generalize h' : [] = L',
  assume h,
  cases h with L₁ L₂,
  simp [list.nil_eq_append_iff] at h',
  contradiction
end

lemma step.cons_left_iff {a : α} {b : bool} :
  step ((a, b) :: L₁) L₂ ↔ (∃L, step L₁ L ∧ L₂ = (a, b) :: L) ∨ (L₁ = (a, bnot b)::L₂) :=
begin
  split,
  { generalize hL : ((a, b) :: L₁ : list _) = L,
    assume h,
    rcases h with ⟨_ | ⟨p, s'⟩, e, a', b'⟩,
    { simp at hL, simp [*] },
    { simp at hL,
      rcases hL with ⟨rfl, rfl⟩,
      refine or.inl ⟨s' ++ e, step.bnot, _⟩,
      simp } },
  { assume h,
    rcases h with ⟨L, h, rfl⟩ | rfl,
    { exact step.cons h },
    { exact step.cons_bnot } }
end

lemma not_step_singleton : ∀ {p : α × bool}, ¬ step [p] L
| (a, b) := by simp [step.cons_left_iff, not_step_nil]

lemma step.cons_cons_iff : ∀{p : α × bool}, step (p :: L₁) (p :: L₂) ↔ step L₁ L₂ :=
by simp [step.cons_left_iff, iff_def, or_imp_distrib] {contextual := tt}

lemma step.append_left_iff : ∀L, step (L ++ L₁) (L ++ L₂) ↔ step L₁ L₂
| [] := by simp
| (p :: l) := by simp [step.append_left_iff l, step.cons_cons_iff]

private theorem step.diamond_aux : ∀ {L₁ L₂ L₃ L₄ : list (α × bool)} {x1 b1 x2 b2},
  L₁ ++ (x1, b1) :: (x1, bnot b1) :: L₂ = L₃ ++ (x2, b2) :: (x2, bnot b2) :: L₄ →
  L₁ ++ L₂ = L₃ ++ L₄ ∨ ∃ L₅, red.step (L₁ ++ L₂) L₅ ∧ red.step (L₃ ++ L₄) L₅
| []        _ []        _ _ _ _ _ H := by injections; subst_vars; simp
| []        _ [(x3,b3)] _ _ _ _ _ H := by injections; subst_vars; simp
| [(x3,b3)] _ []        _ _ _ _ _ H := by injections; subst_vars; simp
| []                     _ ((x3,b3)::(x4,b4)::tl) _ _ _ _ _ H :=
  by injections; subst_vars; simp; right; exact ⟨_, red.step.bnot, red.step.cons_bnot⟩
| ((x3,b3)::(x4,b4)::tl) _ []                     _ _ _ _ _ H :=
  by injections; subst_vars; simp; right; exact ⟨_, red.step.cons_bnot, red.step.bnot⟩
| ((x3,b3)::tl) _ ((x4,b4)::tl2) _ _ _ _ _ H :=
  let ⟨H1, H2⟩ := list.cons.inj H in
  match step.diamond_aux H2 with
    | or.inl H3 := or.inl $ by simp [H1, H3]
    | or.inr ⟨L₅, H3, H4⟩ := or.inr
      ⟨_, step.cons H3, by simpa [H1] using step.cons H4⟩
  end

theorem step.diamond : ∀ {L₁ L₂ L₃ L₄ : list (α × bool)},
  red.step L₁ L₃ → red.step L₂ L₄ → L₁ = L₂ →
  L₃ = L₄ ∨ ∃ L₅, red.step L₃ L₅ ∧ red.step L₄ L₅
| _ _ _ _ red.step.bnot red.step.bnot H := step.diamond_aux H

lemma step.to_red : step L₁ L₂ → red L₁ L₂ :=
refl_trans_gen.single

/-- **Church-Rosser theorem** for word reduction: If `w1 w2 w3` are words such that `w1` reduces
to `w2` and `w3` respectively, then there is a word `w4` such that `w2` and `w3` reduce to `w4`
respectively. This is also known as Newman's diamond lemma. -/
theorem church_rosser : red L₁ L₂ → red L₁ L₃ → join red L₂ L₃ :=
relation.church_rosser (assume a b c hab hac,
match b, c, red.step.diamond hab hac rfl with
| b, _, or.inl rfl           := ⟨b, by refl, by refl⟩
| b, c, or.inr ⟨d, hbd, hcd⟩ := ⟨d, refl_gen.single hbd, hcd.to_red⟩
end)

lemma cons_cons {p} : red L₁ L₂ → red (p :: L₁) (p :: L₂) :=
refl_trans_gen.lift (list.cons p) (assume a b, step.cons)

lemma cons_cons_iff (p) : red (p :: L₁) (p :: L₂) ↔ red L₁ L₂ :=
iff.intro
  begin
    generalize eq₁ : (p :: L₁ : list _) = LL₁,
    generalize eq₂ : (p :: L₂ : list _) = LL₂,
    assume h,
    induction h using relation.refl_trans_gen.head_induction_on
      with L₁ L₂ h₁₂ h ih
      generalizing L₁ L₂,
    { subst_vars, cases eq₂, constructor },
    { subst_vars,
      cases p with a b,
      rw [step.cons_left_iff] at h₁₂,
      rcases h₁₂ with ⟨L, h₁₂, rfl⟩ | rfl,
      { exact (ih rfl rfl).head h₁₂ },
      { exact (cons_cons h).tail step.cons_bnot_rev } }
  end
  cons_cons

lemma append_append_left_iff : ∀L, red (L ++ L₁) (L ++ L₂) ↔ red L₁ L₂
| []       := iff.rfl
| (p :: L) := by simp [append_append_left_iff L, cons_cons_iff]

lemma append_append (h₁ : red L₁ L₃) (h₂ : red L₂ L₄) : red (L₁ ++ L₂) (L₃ ++ L₄) :=
(h₁.lift (λL, L ++ L₂) (assume a b, step.append_right)).trans ((append_append_left_iff _).2 h₂)

lemma to_append_iff : red L (L₁ ++ L₂) ↔ (∃L₃ L₄, L = L₃ ++ L₄ ∧ red L₃ L₁ ∧ red L₄ L₂) :=
iff.intro
  begin
    generalize eq : L₁ ++ L₂ = L₁₂,
    assume h,
    induction h with L' L₁₂ hLL' h ih generalizing L₁ L₂,
    { exact ⟨_, _, eq.symm, by refl, by refl⟩ },
    { cases h with s e a b,
      rcases list.append_eq_append_iff.1 eq with ⟨s', rfl, rfl⟩ | ⟨e', rfl, rfl⟩,
      { have : L₁ ++ (s' ++ ((a, b) :: (a, bnot b) :: e)) =
                 (L₁ ++ s') ++ ((a, b) :: (a, bnot b) :: e),
        { simp },
        rcases ih this with ⟨w₁, w₂, rfl, h₁, h₂⟩,
        exact ⟨w₁, w₂, rfl, h₁, h₂.tail step.bnot⟩ },
      { have : (s ++ ((a, b) :: (a, bnot b) :: e')) ++ L₂ =
                 s ++ ((a, b) :: (a, bnot b) :: (e' ++ L₂)),
        { simp },
        rcases ih this with ⟨w₁, w₂, rfl, h₁, h₂⟩,
        exact ⟨w₁, w₂, rfl, h₁.tail step.bnot, h₂⟩ }, }
  end
  (assume ⟨L₃, L₄, eq, h₃, h₄⟩, eq.symm ▸ append_append h₃ h₄)

/-- The empty word `[]` only reduces to itself. -/
theorem nil_iff : red [] L ↔ L = [] :=
refl_trans_gen_iff_eq (assume l, red.not_step_nil)

/-- A letter only reduces to itself. -/
theorem singleton_iff {x} : red [x] L₁ ↔ L₁ = [x] :=
refl_trans_gen_iff_eq (assume l, not_step_singleton)

/-- If `x` is a letter and `w` is a word such that `xw` reduces to the empty word, then `w` reduces
to `x⁻¹` -/
theorem cons_nil_iff_singleton {x b} : red ((x, b) :: L) [] ↔ red L [(x, bnot b)] :=
iff.intro
  (assume h,
    have h₁ : red ((x, bnot b) :: (x, b) :: L) [(x, bnot b)], from cons_cons h,
    have h₂ : red ((x, bnot b) :: (x, b) :: L) L, from refl_trans_gen.single step.cons_bnot_rev,
    let ⟨L', h₁, h₂⟩ := church_rosser h₁ h₂ in
    by rw [singleton_iff] at h₁; subst L'; assumption)
  (assume h, (cons_cons h).tail step.cons_bnot)

theorem red_iff_irreducible {x1 b1 x2 b2} (h : (x1, b1) ≠ (x2, b2)) :
  red [(x1, bnot b1), (x2, b2)] L ↔ L = [(x1, bnot b1), (x2, b2)] :=
begin
  apply refl_trans_gen_iff_eq,
  generalize eq : [(x1, bnot b1), (x2, b2)] = L',
  assume L h',
  cases h',
  simp [list.cons_eq_append_iff, list.nil_eq_append_iff] at eq,
  rcases eq with ⟨rfl, ⟨rfl, rfl⟩, ⟨rfl, rfl⟩, rfl⟩, subst_vars,
  simp at h,
  contradiction
end

/-- If `x` and `y` are distinct letters and `w₁ w₂` are words such that `xw₁` reduces to `yw₂`, then
`w₁` reduces to `x⁻¹yw₂`. -/
theorem inv_of_red_of_ne {x1 b1 x2 b2}
  (H1 : (x1, b1) ≠ (x2, b2))
  (H2 : red ((x1, b1) :: L₁) ((x2, b2) :: L₂)) :
  red L₁ ((x1, bnot b1) :: (x2, b2) :: L₂) :=
begin
  have : red ((x1, b1) :: L₁) ([(x2, b2)] ++ L₂), from H2,
  rcases to_append_iff.1 this with ⟨_ | ⟨p, L₃⟩, L₄, eq, h₁, h₂⟩,
  { simp [nil_iff] at h₁, contradiction },
  { cases eq,
    show red (L₃ ++ L₄) ([(x1, bnot b1), (x2, b2)] ++ L₂),
    apply append_append _ h₂,
    have h₁ : red ((x1, bnot b1) :: (x1, b1) :: L₃) [(x1, bnot b1), (x2, b2)],
    { exact cons_cons h₁ },
    have h₂ : red ((x1, bnot b1) :: (x1, b1) :: L₃) L₃,
    { exact step.cons_bnot_rev.to_red },
    rcases church_rosser h₁ h₂ with ⟨L', h₁, h₂⟩,
    rw [red_iff_irreducible H1] at h₁,
    rwa [h₁] at h₂ }
end

theorem step.sublist (H : red.step L₁ L₂) : L₂ <+ L₁ :=
by cases H; simp; constructor; constructor; refl

/-- If `w₁ w₂` are words such that `w₁` reduces to `w₂`, then `w₂` is a sublist of `w₁`. -/
theorem sublist : red L₁ L₂ → L₂ <+ L₁ :=
refl_trans_gen_of_transitive_reflexive
  (λl, list.sublist.refl l) (λa b c hab hbc, list.sublist.trans hbc hab) (λa b, red.step.sublist)

theorem sizeof_of_step : ∀ {L₁ L₂ : list (α × bool)}, step L₁ L₂ → L₂.sizeof < L₁.sizeof
| _ _ (@step.bnot _ L1 L2 x b) :=
  begin
    induction L1 with hd tl ih,
    case list.nil
    { dsimp [list.sizeof],
      have H : 1 + sizeof (x, b) + (1 + sizeof (x, bnot b) + list.sizeof L2)
        = (list.sizeof L2 + 1) + (sizeof (x, b) + sizeof (x, bnot b) + 1),
      { ac_refl },
      rw H,
      exact nat.le_add_right _ _ },
    case list.cons
    { dsimp [list.sizeof],
      exact nat.add_lt_add_left ih _ }
  end

theorem length (h : red L₁ L₂) : ∃ n, L₁.length = L₂.length + 2 * n :=
begin
  induction h with L₂ L₃ h₁₂ h₂₃ ih,
  { exact ⟨0, rfl⟩ },
  { rcases ih with ⟨n, eq⟩,
    existsi (1 + n),
    simp [mul_add, eq, (step.length h₂₃).symm, add_assoc] }
end

theorem antisymm (h₁₂ : red L₁ L₂) : red L₂ L₁ → L₁ = L₂ :=
match L₁, h₁₂.cases_head with
| _,  or.inl rfl            := assume h, rfl
| L₁, or.inr ⟨L₃, h₁₃, h₃₂⟩ := assume h₂₁,
  let ⟨n, eq⟩ := length (h₃₂.trans h₂₁) in
  have list.length L₃ + 0 = list.length L₃ + (2 * n + 2),
    by simpa [(step.length h₁₃).symm, add_comm, add_assoc] using eq,
  (nat.no_confusion $ nat.add_left_cancel this)
end

end red

theorem equivalence_join_red : equivalence (join (@red α)) :=
equivalence_join_refl_trans_gen $ assume a b c hab hac,
(match b, c, red.step.diamond hab hac rfl with
| b, _, or.inl rfl           := ⟨b, by refl, by refl⟩
| b, c, or.inr ⟨d, hbd, hcd⟩ := ⟨d, refl_gen.single hbd, refl_trans_gen.single hcd⟩
end)

theorem join_red_of_step (h : red.step L₁ L₂) : join red L₁ L₂ :=
join_of_single reflexive_refl_trans_gen h.to_red

theorem eqv_gen_step_iff_join_red : eqv_gen red.step L₁ L₂ ↔ join red L₁ L₂ :=
iff.intro
  (assume h,
    have eqv_gen (join red) L₁ L₂ := h.mono (assume a b, join_red_of_step),
    equivalence_join_red.eqv_gen_iff.1 this)
  (join_of_equivalence (eqv_gen.is_equivalence _) $ assume a b,
    refl_trans_gen_of_equivalence (eqv_gen.is_equivalence _) eqv_gen.rel)

end free_group

/-- The free group over a type, i.e. the words formed by the elements of the type and their formal
inverses, quotient by one step reduction. -/
def free_group (α : Type u) : Type u :=
quot $ @free_group.red.step α

namespace free_group

variables {α} {L L₁ L₂ L₃ L₄ : list (α × bool)}

/-- The canonical map from `list (α × bool)` to the free group on `α`. -/
def mk (L) : free_group α := quot.mk red.step L

@[simp] lemma quot_mk_eq_mk : quot.mk red.step L = mk L := rfl

@[simp] lemma quot_lift_mk (β : Type v) (f : list (α × bool) → β)
  (H : ∀ L₁ L₂, red.step L₁ L₂ → f L₁ = f L₂) :
quot.lift f H (mk L) = f L := rfl

@[simp] lemma quot_lift_on_mk (β : Type v) (f : list (α × bool) → β)
  (H : ∀ L₁ L₂, red.step L₁ L₂ → f L₁ = f L₂) :
quot.lift_on (mk L) f H = f L := rfl

@[simp] lemma quot_map_mk (β : Type v) (f : list (α × bool) → list (β × bool))
  (H : (red.step ⇒ red.step) f f) :
quot.map f H (mk L) = mk (f L) := rfl

instance : has_one (free_group α) := ⟨mk []⟩
lemma one_eq_mk : (1 : free_group α) = mk [] := rfl

instance : inhabited (free_group α) := ⟨1⟩

instance : has_mul (free_group α) :=
⟨λ x y, quot.lift_on x
    (λ L₁, quot.lift_on y (λ L₂, mk $ L₁ ++ L₂) (λ L₂ L₃ H, quot.sound $ red.step.append_left H))
    (λ L₁ L₂ H, quot.induction_on y $ λ L₃, quot.sound $ red.step.append_right H)⟩
@[simp] lemma mul_mk : mk L₁ * mk L₂ = mk (L₁ ++ L₂) := rfl

instance : has_inv (free_group α) :=
⟨λx, quot.lift_on x (λ L, mk (L.map $ λ x : α × bool, (x.1, bnot x.2)).reverse)
  (assume a b h, quot.sound $ by cases h; simp)⟩
@[simp] lemma inv_mk : (mk L)⁻¹ = mk (L.map $ λ x : α × bool, (x.1, bnot x.2)).reverse := rfl

instance : group (free_group α) :=
{ mul := (*),
  one := 1,
  inv := has_inv.inv,
  mul_assoc := by rintros ⟨L₁⟩ ⟨L₂⟩ ⟨L₃⟩; simp,
  one_mul := by rintros ⟨L⟩; refl,
  mul_one := by rintros ⟨L⟩; simp [one_eq_mk],
  mul_left_inv := by rintros ⟨L⟩; exact (list.rec_on L rfl $
    λ ⟨x, b⟩ tl ih, eq.trans (quot.sound $ by simp [one_eq_mk]) ih) }

/-- `of` is the canonical injection from the type to the free group over that type by sending each
element to the equivalence class of the letter that is the element. -/
def of (x : α) : free_group α :=
mk [(x, tt)]

theorem red.exact : mk L₁ = mk L₂ ↔ join red L₁ L₂ :=
calc (mk L₁ = mk L₂) ↔ eqv_gen red.step L₁ L₂ : iff.intro (quot.exact _) quot.eqv_gen_sound
  ... ↔ join red L₁ L₂ : eqv_gen_step_iff_join_red

/-- The canonical injection from the type to the free group is an injection. -/
theorem of_injective : function.injective (@of α) :=
λ _ _ H, let ⟨L₁, hx, hy⟩ := red.exact.1 H in
  by simp [red.singleton_iff] at hx hy; cc

section lift

variables {β : Type v} [group β] (f : α → β) {x y : free_group α}

/-- Given `f : α → β` with `β` a group, the canonical map `list (α × bool) → β` -/
def lift.aux : list (α × bool) → β :=
λ L, list.prod $ L.map $ λ x, cond x.2 (f x.1) (f x.1)⁻¹

theorem red.step.lift {f : α → β} (H : red.step L₁ L₂) :
  lift.aux f L₁ = lift.aux f L₂ :=
by cases H with _ _ _ b; cases b; simp [lift.aux]

/-- If `β` is a group, then any function from `α` to `β`
extends uniquely to a group homomorphism from
the free group over `α` to `β` -/
@[simps symm_apply]
def lift : (α → β) ≃ (free_group α →* β) :=
{ to_fun := λ f,
    monoid_hom.mk' (quot.lift (lift.aux f) $ λ L₁ L₂, red.step.lift) $ begin
      rintros ⟨L₁⟩ ⟨L₂⟩, simp [lift.aux],
    end,
  inv_fun := λ g, g ∘ of,
  left_inv := λ f, one_mul _,
  right_inv := λ g, monoid_hom.ext $ begin
    rintros ⟨L⟩,
    apply list.rec_on L,
    { exact g.map_one.symm, },
    { rintros ⟨x, _ | _⟩ t (ih : _ = g (mk t)),
      { show _ = g ((of x)⁻¹ * mk t),
        simpa [lift.aux] using ih },
      { show _ = g (of x * mk t),
        simpa [lift.aux] using ih }, },
  end }
variable {f}

@[simp] lemma lift.mk : lift f (mk L) =
  list.prod (L.map $ λ x, cond x.2 (f x.1) (f x.1)⁻¹) :=
rfl

@[simp] lemma lift.of {x} : lift f (of x) = f x :=
one_mul _

theorem lift.unique (g : free_group α →* β)
  (hg : ∀ x, g (of x) = f x) : ∀{x}, g x = lift f x :=
monoid_hom.congr_fun $ (lift.symm_apply_eq).mp (funext hg : g ∘ of = f)

/-- Two homomorphisms out of a free group are equal if they are equal on generators.

See note [partially-applied ext lemmas]. -/
@[ext]
lemma ext_hom {G : Type*} [group G] (f g : free_group α →* G) (h : ∀ a, f (of a) = g (of a)) :
  f = g :=
lift.symm.injective $ funext h

theorem lift.of_eq (x : free_group α) : lift of x = x :=
monoid_hom.congr_fun (lift.apply_symm_apply (monoid_hom.id _)) x

theorem lift.range_subset {s : subgroup β} (H : set.range f ⊆ s) :
  set.range (lift f) ⊆ s :=
by rintros _ ⟨⟨L⟩, rfl⟩; exact list.rec_on L s.one_mem
(λ ⟨x, b⟩ tl ih, bool.rec_on b
    (by simp at ih ⊢; from s.mul_mem
      (s.inv_mem $ H ⟨x, rfl⟩) ih)
    (by simp at ih ⊢; from s.mul_mem (H ⟨x, rfl⟩) ih))

theorem closure_subset {G : Type*} [group G] {s : set G} {t : subgroup G}
  (h : s ⊆ t) : subgroup.closure s ≤ t :=
begin
  simp only [h, subgroup.closure_le],
end

theorem lift.range_eq_closure :
  set.range (lift f) = subgroup.closure (set.range f) :=
set.subset.antisymm
  (lift.range_subset subgroup.subset_closure)
  begin
    suffices : (subgroup.closure (set.range f)) ≤ monoid_hom.range (lift f),
      simpa,
    rw subgroup.closure_le,
    rintros y ⟨x, hx⟩,
    exact ⟨of x, by simpa⟩
  end

end lift

section map

variables {β : Type v} (f : α → β) {x y : free_group α}

/-- Any function from `α` to `β` extends uniquely
to a group homomorphism from the free group
ver `α` to the free group over `β`. -/
def map : free_group α →* free_group β :=
monoid_hom.mk'
  (quot.map (list.map $ λ x, (f x.1, x.2)) $ λ L₁ L₂ H, by cases H; simp)
  (by { rintros ⟨L₁⟩ ⟨L₂⟩, simp })

variable {f}

@[simp] lemma map.mk : map f (mk L) = mk (L.map (λ x, (f x.1, x.2))) :=
rfl

@[simp] lemma map.id (x : free_group α) : map id x = x :=
by rcases x with ⟨L⟩; simp [list.map_id']

@[simp] lemma map.id' (x : free_group α) : map (λ z, z) x = x := map.id x

theorem map.comp {γ : Type w} (f : α → β) (g : β → γ) (x) :
  map g (map f x) = map (g ∘ f) x :=
by rcases x with ⟨L⟩; simp

@[simp] lemma map.of {x} : map f (of x) = of (f x) := rfl

theorem map.unique (g : free_group α →* free_group β)
  (hg : ∀ x, g (of x) = of (f x)) : ∀{x}, g x = map f x :=
by rintros ⟨L⟩; exact list.rec_on L g.map_one
(λ ⟨x, b⟩ t (ih : g (mk t) = map f (mk t)), bool.rec_on b
  (show g ((of x)⁻¹ * mk t) = map f ((of x)⁻¹ * mk t),
     by simp [g.map_mul, g.map_inv, hg, ih])
  (show g (of x * mk t) = map f (of x * mk t),
     by simp [g.map_mul, hg, ih]))

theorem map_eq_lift : map f x = lift (of ∘ f) x :=
eq.symm $ map.unique _ $ λ x, by simp

/-- Equivalent types give rise to multiplicatively equivalent free groups.

The converse can be found in `group_theory.free_abelian_group_finsupp`,
as `equiv.of_free_group_equiv`
 -/
@[simps apply]
def free_group_congr {α β} (e : α ≃ β) : free_group α ≃* free_group β :=
{ to_fun := map e, inv_fun := map e.symm,
  left_inv := λ x, by simp [function.comp, map.comp],
  right_inv := λ x, by simp [function.comp, map.comp],
  map_mul' := monoid_hom.map_mul _ }

@[simp] lemma free_group_congr_refl : free_group_congr (equiv.refl α) = mul_equiv.refl _ :=
mul_equiv.ext map.id

@[simp] lemma free_group_congr_symm {α β} (e : α ≃ β) :
  (free_group_congr e).symm = free_group_congr e.symm :=
rfl

lemma free_group_congr_trans {α β γ} (e : α ≃ β) (f : β ≃ γ) :
  (free_group_congr e).trans (free_group_congr f) = free_group_congr (e.trans f) :=
mul_equiv.ext $ map.comp _ _

end map

section prod

variables [group α] (x y : free_group α)

/-- If `α` is a group, then any function from `α` to `α`
extends uniquely to a homomorphism from the
free group over `α` to `α`. This is the multiplicative
version of `sum`. -/
def prod : free_group α →* α := lift id

variables {x y}

@[simp] lemma prod_mk :
  prod (mk L) = list.prod (L.map $ λ x, cond x.2 x.1 x.1⁻¹) :=
rfl

@[simp] lemma prod.of {x : α} : prod (of x) = x :=
lift.of

lemma prod.unique (g : free_group α →* α)
  (hg : ∀ x, g (of x) = x) {x} :
  g x = prod x :=
lift.unique g hg

end prod

theorem lift_eq_prod_map {β : Type v} [group β] {f : α → β} {x} :
  lift f x = prod (map f x) :=
begin
  rw ←lift.unique (prod.comp (map f)),
  { refl },
  { simp }
end

section sum

variables [add_group α] (x y : free_group α)

/-- If `α` is a group, then any function from `α` to `α`
extends uniquely to a homomorphism from the
free group over `α` to `α`. This is the additive
version of `prod`. -/
def sum : α :=
@prod (multiplicative _) _ x

variables {x y}

@[simp] lemma sum_mk :
  sum (mk L) = list.sum (L.map $ λ x, cond x.2 x.1 (-x.1)) :=
rfl

@[simp] lemma sum.of {x : α} : sum (of x) = x :=
prod.of

-- note: there are no bundled homs with different notation in the domain and codomain, so we copy
-- these manually
@[simp] lemma sum.map_mul : sum (x * y) = sum x + sum y :=
(@prod (multiplicative _) _).map_mul _ _

@[simp] lemma sum.map_one : sum (1:free_group α) = 0 :=
(@prod (multiplicative _) _).map_one

@[simp] lemma sum.map_inv : sum x⁻¹ = -sum x :=
(@prod (multiplicative _) _).map_inv _

end sum

/-- The bijection between the free group on the empty type, and a type with one element. -/
def free_group_empty_equiv_unit : free_group empty ≃ unit :=
{ to_fun    := λ _, (),
  inv_fun   := λ _, 1,
  left_inv  := by rintros ⟨_ | ⟨⟨⟨⟩, _⟩, _⟩⟩; refl,
  right_inv := λ ⟨⟩, rfl }

/-- The bijection between the free group on a singleton, and the integers. -/
def free_group_unit_equiv_int : free_group unit ≃ ℤ :=
{ to_fun    := λ x,
   sum begin revert x, apply monoid_hom.to_fun,
    apply map (λ _, (1 : ℤ)),
  end,
  inv_fun   := λ x, of () ^ x,
  left_inv  :=
  begin
    rintros ⟨L⟩,
    refine list.rec_on L rfl _,
    exact (λ ⟨⟨⟩, b⟩ tl ih, by cases b; simp [zpow_add] at ih ⊢; rw ih; refl),
  end,
  right_inv :=
    λ x, int.induction_on x (by simp)
    (λ i ih, by simp at ih; simp [zpow_add, ih])
    (λ i ih, by simp at ih; simp [zpow_add, ih, sub_eq_add_neg, -int.add_neg_one]) }

section category

variables {β : Type u}

instance : monad free_group.{u} :=
{ pure := λ α, of,
  map := λ α β f, (map f),
  bind := λ α β x f, lift f x }

@[elab_as_eliminator]
protected theorem induction_on
  {C : free_group α → Prop}
  (z : free_group α)
  (C1 : C 1)
  (Cp : ∀ x, C $ pure x)
  (Ci : ∀ x, C (pure x) → C (pure x)⁻¹)
  (Cm : ∀ x y, C x → C y → C (x * y)) : C z :=
quot.induction_on z $ λ L, list.rec_on L C1 $ λ ⟨x, b⟩ tl ih,
bool.rec_on b (Cm _ _ (Ci _ $ Cp x) ih) (Cm _ _ (Cp x) ih)

@[simp] lemma map_pure (f : α → β) (x : α) : f <$> (pure x : free_group α) = pure (f x) :=
map.of

@[simp] lemma map_one (f : α → β) : f <$> (1 : free_group α) = 1 :=
(map f).map_one

@[simp] lemma map_mul (f : α → β) (x y : free_group α) : f <$> (x * y) = f <$> x * f <$> y :=
(map f).map_mul x y

@[simp] lemma map_inv (f : α → β) (x : free_group α) : f <$> (x⁻¹) = (f <$> x)⁻¹ :=
(map f).map_inv x

@[simp] lemma pure_bind (f : α → free_group β) (x) : pure x >>= f = f x :=
lift.of

@[simp] lemma one_bind (f : α → free_group β) : 1 >>= f = 1 :=
(lift f).map_one

@[simp] lemma mul_bind (f : α → free_group β) (x y : free_group α) :
  x * y >>= f = (x >>= f) * (y >>= f) :=
(lift f).map_mul _ _

@[simp] lemma inv_bind (f : α → free_group β) (x : free_group α) : x⁻¹ >>= f = (x >>= f)⁻¹ :=
(lift f).map_inv _

instance : is_lawful_monad free_group.{u} :=
{ id_map := λ α x, free_group.induction_on x (map_one id) (λ x, map_pure id x)
    (λ x ih, by rw [map_inv, ih]) (λ x y ihx ihy, by rw [map_mul, ihx, ihy]),
  pure_bind := λ α β x f, pure_bind f x,
  bind_assoc := λ α β γ x f g, free_group.induction_on x
    (by iterate 3 { rw one_bind }) (λ x, by iterate 2 { rw pure_bind })
    (λ x ih, by iterate 3 { rw inv_bind }; rw ih)
    (λ x y ihx ihy, by iterate 3 { rw mul_bind }; rw [ihx, ihy]),
  bind_pure_comp_eq_map := λ α β f x, free_group.induction_on x
    (by rw [one_bind, map_one]) (λ x, by rw [pure_bind, map_pure])
    (λ x ih, by rw [inv_bind, map_inv, ih]) (λ x y ihx ihy, by rw [mul_bind, map_mul, ihx, ihy]) }

end category

section reduce

variable [decidable_eq α]

/-- The maximal reduction of a word. It is computable
iff `α` has decidable equality. -/
def reduce (L : list (α × bool)) : list (α × bool) :=
list.rec_on L [] $ λ hd1 tl1 ih,
list.cases_on ih [hd1] $ λ hd2 tl2,
if hd1.1 = hd2.1 ∧ hd1.2 = bnot hd2.2 then tl2
else hd1 :: hd2 :: tl2

@[simp] lemma reduce.cons (x) : reduce (x :: L) =
  list.cases_on (reduce L) [x] (λ hd tl,
  if x.1 = hd.1 ∧ x.2 = bnot hd.2 then tl
  else x :: hd :: tl) := rfl

/-- The first theorem that characterises the function
`reduce`: a word reduces to its maximal reduction. -/
theorem reduce.red : red L (reduce L) :=
begin
  induction L with hd1 tl1 ih,
  case list.nil
  { constructor },
  case list.cons
  { dsimp,
    revert ih,
    generalize htl : reduce tl1 = TL,
    intro ih,
    cases TL with hd2 tl2,
    case list.nil
    { exact red.cons_cons ih },
    case list.cons
    { dsimp,
      by_cases h : hd1.fst = hd2.fst ∧ hd1.snd = bnot (hd2.snd),
      { rw [if_pos h],
        transitivity,
        { exact red.cons_cons ih },
        { cases hd1, cases hd2, cases h,
          dsimp at *, subst_vars,
          exact red.step.cons_bnot_rev.to_red } },
      { rw [if_neg h],
        exact red.cons_cons ih } } }
end

theorem reduce.not {p : Prop} :
  ∀ {L₁ L₂ L₃ : list (α × bool)} {x b}, reduce L₁ = L₂ ++ (x, b) :: (x, bnot b) :: L₃ → p
| [] L2 L3 _ _ := λ h, by cases L2; injections
| ((x,b)::L1) L2 L3 x' b' := begin
  dsimp,
  cases r : reduce L1,
  { dsimp, intro h,
    have := congr_arg list.length h,
    simp [-add_comm] at this,
    exact absurd this dec_trivial },
  cases hd with y c,
  by_cases x = y ∧ b = bnot c; simp [h]; intro H,
  { rw H at r,
    exact @reduce.not L1 ((y,c)::L2) L3 x' b' r },
  rcases L2 with _|⟨a, L2⟩,
  { injections, subst_vars,
    simp at h, cc },
  { refine @reduce.not L1 L2 L3 x' b' _,
    injection H with _ H,
    rw [r, H], refl }
end

/-- The second theorem that characterises the
function `reduce`: the maximal reduction of a word
only reduces to itself. -/
theorem reduce.min (H : red (reduce L₁) L₂) : reduce L₁ = L₂ :=
begin
  induction H with L1 L' L2 H1 H2 ih,
  { refl },
  { cases H1 with L4 L5 x b,
    exact reduce.not H2 }
end

/-- `reduce` is idempotent, i.e. the maximal reduction
of the maximal reduction of a word is the maximal
reduction of the word. -/
theorem reduce.idem : reduce (reduce L) = reduce L :=
eq.symm $ reduce.min reduce.red

theorem reduce.step.eq (H : red.step L₁ L₂) : reduce L₁ = reduce L₂ :=
let ⟨L₃, HR13, HR23⟩ := red.church_rosser reduce.red (reduce.red.head H) in
(reduce.min HR13).trans (reduce.min HR23).symm

/-- If a word reduces to another word, then they have
a common maximal reduction. -/
theorem reduce.eq_of_red (H : red L₁ L₂) : reduce L₁ = reduce L₂ :=
let ⟨L₃, HR13, HR23⟩ := red.church_rosser reduce.red (red.trans H reduce.red) in
(reduce.min HR13).trans (reduce.min HR23).symm

/-- If two words correspond to the same element in
the free group, then they have a common maximal
reduction. This is the proof that the function that
sends an element of the free group to its maximal
reduction is well-defined. -/
theorem reduce.sound (H : mk L₁ = mk L₂) : reduce L₁ = reduce L₂ :=
let ⟨L₃, H13, H23⟩ := red.exact.1 H in
(reduce.eq_of_red H13).trans (reduce.eq_of_red H23).symm

/-- If two words have a common maximal reduction,
then they correspond to the same element in the free group. -/
theorem reduce.exact (H : reduce L₁ = reduce L₂) : mk L₁ = mk L₂ :=
red.exact.2 ⟨reduce L₂, H ▸ reduce.red, reduce.red⟩

/-- A word and its maximal reduction correspond to
the same element of the free group. -/
theorem reduce.self : mk (reduce L) = mk L :=
reduce.exact reduce.idem

/-- If words `w₁ w₂` are such that `w₁` reduces to `w₂`,
then `w₂` reduces to the maximal reduction of `w₁`. -/
theorem reduce.rev (H : red L₁ L₂) : red L₂ (reduce L₁) :=
(reduce.eq_of_red H).symm ▸ reduce.red

/-- The function that sends an element of the free
group to its maximal reduction. -/
def to_word : free_group α → list (α × bool) :=
quot.lift reduce $ λ L₁ L₂ H, reduce.step.eq H

lemma to_word.mk : ∀{x : free_group α}, mk (to_word x) = x :=
by rintros ⟨L⟩; exact reduce.self

lemma to_word.inj : ∀(x y : free_group α), to_word x = to_word y → x = y :=
by rintros ⟨L₁⟩ ⟨L₂⟩; exact reduce.exact

/-- Constructive Church-Rosser theorem (compare `church_rosser`). -/
def reduce.church_rosser (H12 : red L₁ L₂) (H13 : red L₁ L₃) :
  { L₄ // red L₂ L₄ ∧ red L₃ L₄ } :=
⟨reduce L₁, reduce.rev H12, reduce.rev H13⟩

instance : decidable_eq (free_group α) :=
function.injective.decidable_eq to_word.inj

instance red.decidable_rel : decidable_rel (@red α)
| [] []          := is_true red.refl
| [] (hd2::tl2)  := is_false $ λ H, list.no_confusion (red.nil_iff.1 H)
| ((x,b)::tl) [] := match red.decidable_rel tl [(x, bnot b)] with
  | is_true H  := is_true $ red.trans (red.cons_cons H) $
    (@red.step.bnot _ [] [] _ _).to_red
  | is_false H := is_false $ λ H2, H $ red.cons_nil_iff_singleton.1 H2
  end
| ((x1,b1)::tl1) ((x2,b2)::tl2) := if h : (x1, b1) = (x2, b2)
  then match red.decidable_rel tl1 tl2 with
    | is_true H  := is_true $ h ▸ red.cons_cons H
    | is_false H := is_false $ λ H2, H $ h ▸ (red.cons_cons_iff _).1 $ H2
    end
  else match red.decidable_rel tl1 ((x1,bnot b1)::(x2,b2)::tl2) with
    | is_true H  := is_true $ (red.cons_cons H).tail red.step.cons_bnot
    | is_false H := is_false $ λ H2, H $ red.inv_of_red_of_ne h H2
    end

/-- A list containing every word that `w₁` reduces to. -/
def red.enum (L₁ : list (α × bool)) : list (list (α × bool)) :=
list.filter (λ L₂, red L₁ L₂) (list.sublists L₁)

theorem red.enum.sound (H : L₂ ∈ red.enum L₁) : red L₁ L₂ :=
list.of_mem_filter H

theorem red.enum.complete (H : red L₁ L₂) : L₂ ∈ red.enum L₁ :=
list.mem_filter_of_mem (list.mem_sublists.2 $ red.sublist H) H

instance : fintype { L₂ // red L₁ L₂ } :=
fintype.subtype (list.to_finset $ red.enum L₁) $
λ L₂, ⟨λ H, red.enum.sound $ list.mem_to_finset.1 H,
  λ H, list.mem_to_finset.2 $ red.enum.complete H⟩

end reduce

end free_group


/-
Copyright (c) 2022 Peter Nelson. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Peter Nelson
-/
import order.antichain

/-!
# Orders with involution

This file concerns orders that admit an order-reversing involution. In the case of a lattice,
these are sometimes referred to as 'i-lattices' or 'lattices with involution'. Such an involution
is more general than a `boolean_algebra` complement, but retains many of its properties. Other than
a boolean algebra, an example is the subspace lattice of the vector space `𝕂ⁿ` for `𝕂` of nonzero
characteristic, where for each subspace `W` we have `invo W = {x ∈ V | ∀ w ∈ W, wᵀx = 0}`; this is
not a complement in the stronger sense because `invo W` can intersect `W`.

## Main declarations

* `has_involution`: typeclass applying to types with a `preorder` that admit an antitone involution.

* `ⁱ` : postfix notation for the function `invo : α → α` given a type `α` with `[has_involution α]`

## TODO

Provide instances other than the one from `boolean_algebra`.
-/

universe u

class has_involution (α : Type u) [preorder α]  :=
(invo : α → α)
(invo_antitone' : ∀ (x y : α), x ≤ y → invo y ≤ invo x)
(invo_involutive' : function.involutive invo)

open has_involution

variables {α : Type u}

postfix `ⁱ`:(max+1) := invo

section preorder

variables [preorder α] [has_involution α] {x y : α}

@[simp] lemma invo_invo (x : α) : xⁱⁱ = x :=  invo_involutive' x

lemma invo_eq_iff_invo_eq : xⁱ = y ↔ yⁱ = x :=
by {rw [eq_comm], exact invo_involutive'.eq_iff.symm}

lemma eq_invo_iff_eq_invo : x = yⁱ ↔ y = xⁱ :=
by rw [← invo_invo x, invo_eq_iff_invo_eq, invo_invo, invo_invo]

lemma invo_le_invo (hxy : x ≤ y) : yⁱ ≤ xⁱ := invo_antitone' _ _ hxy

lemma le_of_invo_le (hx : xⁱ ≤ yⁱ) : y ≤ x :=
by {rw [←invo_invo x, ←invo_invo y], exact invo_le_invo hx,}

lemma invo_le_invo_iff_le : xⁱ ≤ yⁱ ↔ y ≤ x := ⟨le_of_invo_le, invo_le_invo⟩

lemma le_invo_iff_le_invo : x ≤ yⁱ ↔ y ≤ xⁱ := by rw [←invo_le_invo_iff_le, invo_invo]

lemma invo_le_iff_invo_le : xⁱ ≤ y ↔ yⁱ ≤ x := by rw [←invo_le_invo_iff_le, invo_invo]

lemma invo_inj (h : xⁱ = yⁱ) : x = y := invo_involutive'.injective h

lemma invo_lt_invo_iff_lt : xⁱ < yⁱ ↔ y < x := by simp [lt_iff_le_not_le, invo_le_invo_iff_le]

lemma lt_invo_iff_lt_invo : x < yⁱ ↔ y < xⁱ := by rw [←invo_lt_invo_iff_lt, invo_invo]

lemma invo_lt_iff_invo_lt : xⁱ < y ↔ yⁱ < x := by rw [←invo_lt_invo_iff_lt, invo_invo]

lemma le_invo_of_le_invo (h : y ≤ xⁱ) : x ≤ yⁱ := le_invo_iff_le_invo.mp h

lemma invo_le_of_invo_le (h : yⁱ ≤ x) : xⁱ ≤ y := invo_le_iff_invo_le.mp h

lemma invo_involutive : function.involutive (has_involution.invo : α → α) := invo_invo

lemma invo_bijective : function.bijective (invo : α → α) := invo_involutive.bijective

lemma invo_surjective : function.surjective (invo : α → α) := invo_involutive.surjective

lemma invo_injective : function.injective (invo : α → α) := invo_involutive.injective

lemma invo_antitone : antitone (invo: α → α) := λ a b, invo_le_invo

@[simp] lemma invo_inj_iff : xⁱ = yⁱ ↔ x = y := invo_injective.eq_iff

lemma invo_comp_invo : invo ∘ invo = @id α := funext invo_invo

end preorder

section lattice

variables [lattice α] [has_involution α]

@[simp] lemma invo_inf (x y : α) : (x ⊓ y)ⁱ = xⁱ ⊔ yⁱ :=
le_antisymm (invo_le_iff_invo_le.mpr (le_inf (invo_le_iff_invo_le.mp le_sup_left)
    ((invo_le_iff_invo_le.mp le_sup_right))))
      (sup_le (invo_le_invo inf_le_left) (invo_le_invo inf_le_right))

@[simp] lemma invo_sup (x y : α) : (x ⊔ y)ⁱ = xⁱ ⊓ yⁱ :=
by rw [invo_eq_iff_invo_eq, invo_inf, invo_invo, invo_invo]

end lattice

section boolean_algebra

@[priority 100]
instance boolean_algebra.to_has_involution [boolean_algebra α] : has_involution α :=
{ invo := compl,
  invo_antitone' := λ _ _, compl_le_compl,
  invo_involutive' := compl_involutive }

end boolean_algebra

section hom

variables (α) [preorder α] [has_involution α]

instance order_dual.has_involution : has_involution αᵒᵈ :=
{ invo := λ x, order_dual.to_dual (order_dual.of_dual x)ⁱ,
  invo_antitone' := λ a b h, @invo_antitone' α _ _ b a h,
  invo_involutive' := invo_involutive' }

/-- Taking the involution as an order isomorphism to the order dual. -/
@[simps]
def order_iso.invo : α ≃o αᵒᵈ :=
{ to_fun := order_dual.to_dual ∘ invo,
  inv_fun := invo ∘ order_dual.of_dual,
  left_inv := invo_invo,
  right_inv := invo_invo,
  map_rel_iff' := λ _ _, invo_le_invo_iff_le }

lemma invo_strict_anti : strict_anti (invo : α → α) := (order_iso.invo α).strict_mono

end hom

section antichain

variables [preorder α] [has_involution α] {s : set α}

lemma is_antichain.image_invo (hs : is_antichain (≤) s) :
  is_antichain (≤) (invo '' s) :=
(hs.image_embedding (order_iso.invo α).to_order_embedding).flip

lemma is_antichain.preimage_invo (hs : is_antichain (≤) s) :
  is_antichain (≤) (invo ⁻¹' s) :=
λ a ha a' ha' hne hle, hs ha' ha (λ h, hne (invo_inj_iff.mp h.symm)) (invo_le_invo hle)

end antichain


/-
Copyright (c) 2021 OpenAI. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kunhao Zheng, Stanislas Polu, David Renshaw, OpenAI GPT-f
-/
import mathzoo.imports.miniF2F

open_locale nat rat real big_operators topological_space

theorem mathd_algebra_69
  (r s : ℕ+)
  (h₀ : ↑r * ↑s = (450:ℤ))
  (h₁ : (↑r + 5) * (↑s - 3) = (450:ℤ)) :
  r = 25 :=
begin
  apply subtype.ext,
  norm_num [add_mul] at *,
  nlinarith,
end