/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Mario Carneiro, Alexander Bentkamp
-/
import algebra.big_operators.finsupp
import algebra.big_operators.finprod
import data.fintype.card
import linear_algebra.finsupp
import linear_algebra.linear_independent
import linear_algebra.linear_pmap
import linear_algebra.projection

/-!

# Bases

This file defines bases in a module or vector space.

It is inspired by Isabelle/HOL's linear algebra, and hence indirectly by HOL Light.

## Main definitions

All definitions are given for families of vectors, i.e. `v : ι → M` where `M` is the module or
vector space and `ι : Type*` is an arbitrary indexing type.

* `basis ι R M` is the type of `ι`-indexed `R`-bases for a module `M`,
  represented by a linear equiv `M ≃ₗ[R] ι →₀ R`.
* the basis vectors of a basis `b : basis ι R M` are available as `b i`, where `i : ι`

* `basis.repr` is the isomorphism sending `x : M` to its coordinates `basis.repr x : ι →₀ R`.
  The converse, turning this isomorphism into a basis, is called `basis.of_repr`.
* If `ι` is finite, there is a variant of `repr` called `basis.equiv_fun b : M ≃ₗ[R] ι → R`
  (saving you from having to work with `finsupp`). The converse, turning this isomorphism into
  a basis, is called `basis.of_equiv_fun`.

* `basis.constr hv f` constructs a linear map `M₁ →ₗ[R] M₂` given the values `f : ι → M₂` at the
  basis elements `⇑b : ι → M₁`.
* `basis.reindex` uses an equiv to map a basis to a different indexing set.
* `basis.map` uses a linear equiv to map a basis to a different module.

## Main statements

* `basis.mk`: a linear independent set of vectors spanning the whole module determines a basis

* `basis.ext` states that two linear maps are equal if they coincide on a basis.
  Similar results are available for linear equivs (if they coincide on the basis vectors),
  elements (if their coordinates coincide) and the functions `b.repr` and `⇑b`.

* `basis.of_vector_space` states that every vector space has a basis.

## Implementation notes

We use families instead of sets because it allows us to say that two identical vectors are linearly
dependent. For bases, this is useful as well because we can easily derive ordered bases by using an
ordered index type `ι`.

## Tags

basis, bases

-/

noncomputable theory

universe u

open function set submodule
open_locale classical big_operators

variables {ι : Type*} {ι' : Type*} {R : Type*} {K : Type*}
variables {M : Type*} {M' M'' : Type*} {V : Type u} {V' : Type*}

section module

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

section
variables (ι) (R) (M)

/-- A `basis ι R M` for a module `M` is the type of `ι`-indexed `R`-bases of `M`.

The basis vectors are available as `coe_fn (b : basis ι R M) : ι → M`.
To turn a linear independent family of vectors spanning `M` into a basis, use `basis.mk`.
They are internally represented as linear equivs `M ≃ₗ[R] (ι →₀ R)`,
available as `basis.repr`.
-/
structure basis := of_repr :: (repr : M ≃ₗ[R] (ι →₀ R))

end

namespace basis

instance : inhabited (basis ι R (ι →₀ R)) := ⟨basis.of_repr (linear_equiv.refl _ _)⟩

variables (b b₁ : basis ι R M) (i : ι) (c : R) (x : M)

section repr

/-- `b i` is the `i`th basis vector. -/
instance : has_coe_to_fun (basis ι R M) (λ _, ι → M) :=
{ coe := λ b i, b.repr.symm (finsupp.single i 1) }

@[simp] lemma coe_of_repr (e : M ≃ₗ[R] (ι →₀ R)) :
  ⇑(of_repr e) = λ i, e.symm (finsupp.single i 1) :=
rfl

protected lemma injective [nontrivial R] : injective b :=
b.repr.symm.injective.comp (λ _ _, (finsupp.single_left_inj (one_ne_zero : (1 : R) ≠ 0)).mp)

lemma repr_symm_single_one : b.repr.symm (finsupp.single i 1) = b i := rfl

lemma repr_symm_single : b.repr.symm (finsupp.single i c) = c • b i :=
calc b.repr.symm (finsupp.single i c)
    = b.repr.symm (c • finsupp.single i 1) : by rw [finsupp.smul_single', mul_one]
... = c • b i : by rw [linear_equiv.map_smul, repr_symm_single_one]

@[simp] lemma repr_self : b.repr (b i) = finsupp.single i 1 :=
linear_equiv.apply_symm_apply _ _

lemma repr_self_apply (j) [decidable (i = j)] :
  b.repr (b i) j = if i = j then 1 else 0 :=
by rw [repr_self, finsupp.single_apply]

@[simp] lemma repr_symm_apply (v) : b.repr.symm v = finsupp.total ι M R b v :=
calc b.repr.symm v = b.repr.symm (v.sum finsupp.single) : by simp
... = ∑ i in v.support, b.repr.symm (finsupp.single i (v i)) :
  by rw [finsupp.sum, linear_equiv.map_sum]
... = finsupp.total ι M R b v :
  by simp [repr_symm_single, finsupp.total_apply, finsupp.sum]

@[simp] lemma coe_repr_symm : ↑b.repr.symm = finsupp.total ι M R b :=
linear_map.ext (λ v, b.repr_symm_apply v)

@[simp] lemma repr_total (v) : b.repr (finsupp.total _ _ _ b v) = v :=
by { rw ← b.coe_repr_symm, exact b.repr.apply_symm_apply v }

@[simp] lemma total_repr : finsupp.total _ _ _ b (b.repr x) = x :=
by { rw ← b.coe_repr_symm, exact b.repr.symm_apply_apply x }

lemma repr_range : (b.repr : M →ₗ[R] (ι →₀ R)).range = finsupp.supported R R univ :=
by rw [linear_equiv.range, finsupp.supported_univ]

lemma mem_span_repr_support {ι : Type*} (b : basis ι R M) (m : M) :
  m ∈ span R (b '' (b.repr m).support) :=
(finsupp.mem_span_image_iff_total _).2 ⟨b.repr m, (by simp [finsupp.mem_supported_support])⟩

end repr

section coord

/-- `b.coord i` is the linear function giving the `i`'th coordinate of a vector
with respect to the basis `b`.

`b.coord i` is an element of the dual space. In particular, for
finite-dimensional spaces it is the `ι`th basis vector of the dual space.
-/
@[simps]
def coord : M →ₗ[R] R := (finsupp.lapply i) ∘ₗ ↑b.repr

lemma forall_coord_eq_zero_iff {x : M} :
  (∀ i, b.coord i x = 0) ↔ x = 0 :=
iff.trans
  (by simp only [b.coord_apply, finsupp.ext_iff, finsupp.zero_apply])
  b.repr.map_eq_zero_iff

/-- The sum of the coordinates of an element `m : M` with respect to a basis. -/
noncomputable def sum_coords : M →ₗ[R] R :=
finsupp.lsum ℕ (λ i, linear_map.id) ∘ₗ (b.repr : M →ₗ[R] ι →₀ R)

@[simp] lemma coe_sum_coords : (b.sum_coords : M → R) = λ m, (b.repr m).sum (λ i, id) :=
rfl

lemma coe_sum_coords_eq_finsum : (b.sum_coords : M → R) = λ m, ∑ᶠ i, b.coord i m :=
begin
  ext m,
  simp only [basis.sum_coords, basis.coord, finsupp.lapply_apply, linear_map.id_coe,
    linear_equiv.coe_coe, function.comp_app, finsupp.coe_lsum, linear_map.coe_comp,
    finsum_eq_sum _ (b.repr m).finite_support, finsupp.sum, finset.finite_to_set_to_finset,
    id.def, finsupp.fun_support_eq],
end

@[simp] lemma coe_sum_coords_of_fintype [fintype ι] : (b.sum_coords : M → R) = ∑ i, b.coord i :=
begin
  ext m,
  simp only [sum_coords, finsupp.sum_fintype, linear_map.id_coe, linear_equiv.coe_coe, coord_apply,
    id.def, fintype.sum_apply, implies_true_iff, eq_self_iff_true, finsupp.coe_lsum,
    linear_map.coe_comp],
end

@[simp] lemma sum_coords_self_apply : b.sum_coords (b i) = 1 :=
by simp only [basis.sum_coords, linear_map.id_coe, linear_equiv.coe_coe, id.def, basis.repr_self,
  function.comp_app, finsupp.coe_lsum, linear_map.coe_comp, finsupp.sum_single_index]

end coord

section ext

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

/-- Two linear maps are equal if they are equal on basis vectors. -/
theorem ext {f₁ f₂ : M →ₗ[R] M₁} (h : ∀ i, f₁ (b i) = f₂ (b i)) : f₁ = f₂ :=
by { ext x,
     rw [← b.total_repr x, finsupp.total_apply, finsupp.sum],
     simp only [linear_map.map_sum, linear_map.map_smul, h] }

/-- Two linear equivs are equal if they are equal on basis vectors. -/
theorem ext' {f₁ f₂ : M ≃ₗ[R] M₁} (h : ∀ i, f₁ (b i) = f₂ (b i)) : f₁ = f₂ :=
by { ext x,
      rw [← b.total_repr x, finsupp.total_apply, finsupp.sum],
      simp only [linear_equiv.map_sum, linear_equiv.map_smul, h] }

/-- Two elements are equal if their coordinates are equal. -/
theorem ext_elem {x y : M}
  (h : ∀ i, b.repr x i = b.repr y i) : x = y :=
by { rw [← b.total_repr x, ← b.total_repr y], congr' 1, ext i, exact h i }

lemma repr_eq_iff {b : basis ι R M} {f : M →ₗ[R] ι →₀ R} :
  ↑b.repr = f ↔ ∀ i, f (b i) = finsupp.single i 1 :=
⟨λ h i, h ▸ b.repr_self i,
 λ h, b.ext (λ i, (b.repr_self i).trans (h i).symm)⟩

lemma repr_eq_iff' {b : basis ι R M} {f : M ≃ₗ[R] ι →₀ R} :
  b.repr = f ↔ ∀ i, f (b i) = finsupp.single i 1 :=
⟨λ h i, h ▸ b.repr_self i,
  λ h, b.ext' (λ i, (b.repr_self i).trans (h i).symm)⟩

lemma apply_eq_iff {b : basis ι R M} {x : M} {i : ι} :
  b i = x ↔ b.repr x = finsupp.single i 1 :=
⟨λ h, h ▸ b.repr_self i,
 λ h, b.repr.injective ((b.repr_self i).trans h.symm)⟩

/-- An unbundled version of `repr_eq_iff` -/
lemma repr_apply_eq (f : M → ι → R)
  (hadd : ∀ x y, f (x + y) = f x + f y) (hsmul : ∀ (c : R) (x : M), f (c • x) = c • f x)
  (f_eq : ∀ i, f (b i) = finsupp.single i 1) (x : M) (i : ι) :
  b.repr x i = f x i :=
begin
  let f_i : M →ₗ[R] R :=
  { to_fun := λ x, f x i,
    map_add' := λ _ _, by rw [hadd, pi.add_apply],
    map_smul' := λ _ _, by { simp [hsmul, pi.smul_apply] } },
  have : (finsupp.lapply i) ∘ₗ ↑b.repr = f_i,
  { refine b.ext (λ j, _),
    show b.repr (b j) i = f (b j) i,
    rw [b.repr_self, f_eq] },
  calc b.repr x i = f_i x : by { rw ← this, refl }
              ... = f x i : rfl
end

/-- Two bases are equal if they assign the same coordinates. -/
lemma eq_of_repr_eq_repr {b₁ b₂ : basis ι R M} (h : ∀ x i, b₁.repr x i = b₂.repr x i) :
  b₁ = b₂ :=
have b₁.repr = b₂.repr, by { ext, apply h },
by { cases b₁, cases b₂, simpa }

/-- Two bases are equal if their basis vectors are the same. -/
@[ext] lemma eq_of_apply_eq {b₁ b₂ : basis ι R M} (h : ∀ i, b₁ i = b₂ i) : b₁ = b₂ :=
suffices b₁.repr = b₂.repr, by { cases b₁, cases b₂, simpa },
repr_eq_iff'.mpr (λ i, by rw [h, b₂.repr_self])

end ext

section map

variables (f : M ≃ₗ[R] M')

/-- Apply the linear equivalence `f` to the basis vectors. -/
@[simps] protected def map : basis ι R M' :=
of_repr (f.symm.trans b.repr)

@[simp] lemma map_apply (i) : b.map f i = f (b i) := rfl

end map

section map_coeffs

variables {R' : Type*} [semiring R'] [module R' M] (f : R ≃+* R') (h : ∀ c (x : M), f c • x = c • x)

include f h b

local attribute [instance] has_scalar.comp.is_scalar_tower

/-- If `R` and `R'` are isomorphic rings that act identically on a module `M`,
then a basis for `M` as `R`-module is also a basis for `M` as `R'`-module.

See also `basis.algebra_map_coeffs` for the case where `f` is equal to `algebra_map`.
-/
@[simps {simp_rhs := tt}]
def map_coeffs : basis ι R' M :=
begin
  letI : module R' R := module.comp_hom R (↑f.symm : R' →+* R),
  haveI : is_scalar_tower R' R M :=
  { smul_assoc := λ x y z, begin dsimp [(•)],  rw [mul_smul, ←h, f.apply_symm_apply], end },
  exact (of_repr $ (b.repr.restrict_scalars R').trans $
    finsupp.map_range.linear_equiv (module.comp_hom.to_linear_equiv f.symm).symm )
end

lemma map_coeffs_apply (i : ι) : b.map_coeffs f h i = b i :=
apply_eq_iff.mpr $ by simp [f.to_add_equiv_eq_coe]

@[simp] lemma coe_map_coeffs : (b.map_coeffs f h : ι → M) = b :=
funext $ b.map_coeffs_apply f h

end map_coeffs

section reindex

variables (b' : basis ι' R M')
variables (e : ι ≃ ι')

/-- `b.reindex (e : ι ≃ ι')` is a basis indexed by `ι'` -/
def reindex : basis ι' R M :=
basis.of_repr (b.repr.trans (finsupp.dom_lcongr e))

lemma reindex_apply (i' : ι') : b.reindex e i' = b (e.symm i') :=
show (b.repr.trans (finsupp.dom_lcongr e)).symm (finsupp.single i' 1) =
  b.repr.symm (finsupp.single (e.symm i') 1),
by rw [linear_equiv.symm_trans_apply, finsupp.dom_lcongr_symm, finsupp.dom_lcongr_single]

@[simp] lemma coe_reindex : (b.reindex e : ι' → M) = b ∘ e.symm :=
funext (b.reindex_apply e)

@[simp] lemma coe_reindex_repr : ((b.reindex e).repr x : ι' → R) = b.repr x ∘ e.symm :=
funext $ λ i',
show (finsupp.dom_lcongr e : _ ≃ₗ[R] _) (b.repr x) i' = _,
by simp

@[simp] lemma reindex_repr (i' : ι') : (b.reindex e).repr x i' = b.repr x (e.symm i') :=
by rw coe_reindex_repr

/-- `simp` normal form version of `range_reindex` -/
@[simp] lemma range_reindex' : set.range (b ∘ e.symm) = set.range b :=
by rw [range_comp, equiv.range_eq_univ, set.image_univ]

lemma range_reindex : set.range (b.reindex e) = set.range b :=
by rw [coe_reindex, range_reindex']

/-- `b.reindex_range` is a basis indexed by `range b`, the basis vectors themselves. -/
def reindex_range : basis (range b) R M :=
if h : nontrivial R then
  by letI := h; exact b.reindex (equiv.of_injective b (basis.injective b))
else
  by letI : subsingleton R := not_nontrivial_iff_subsingleton.mp h; exact
    basis.of_repr (module.subsingleton_equiv R M (range b))

lemma finsupp.single_apply_left {α β γ : Type*} [has_zero γ]
  {f : α → β} (hf : function.injective f)
  (x z : α) (y : γ) :
  finsupp.single (f x) y (f z) = finsupp.single x y z :=
by simp [finsupp.single_apply, hf.eq_iff]

lemma reindex_range_self (i : ι) (h := set.mem_range_self i) :
  b.reindex_range ⟨b i, h⟩ = b i :=
begin
  by_cases htr : nontrivial R,
  { letI := htr,
    simp [htr, reindex_range, reindex_apply, equiv.apply_of_injective_symm b b.injective,
      subtype.coe_mk] },
  { letI : subsingleton R := not_nontrivial_iff_subsingleton.mp htr,
    letI := module.subsingleton R M,
    simp [reindex_range] }
end

lemma reindex_range_repr_self (i : ι) :
  b.reindex_range.repr (b i) = finsupp.single ⟨b i, mem_range_self i⟩ 1 :=
calc b.reindex_range.repr (b i) = b.reindex_range.repr (b.reindex_range ⟨b i, mem_range_self i⟩) :
  congr_arg _ (b.reindex_range_self _ _).symm
... = finsupp.single ⟨b i, mem_range_self i⟩ 1 : b.reindex_range.repr_self _

@[simp] lemma reindex_range_apply (x : range b) : b.reindex_range x = x :=
by { rcases x with ⟨bi, ⟨i, rfl⟩⟩, exact b.reindex_range_self i, }

lemma reindex_range_repr' (x : M) {bi : M} {i : ι} (h : b i = bi) :
  b.reindex_range.repr x ⟨bi, ⟨i, h⟩⟩ = b.repr x i :=
begin
  nontriviality,
  subst h,
  refine (b.repr_apply_eq (λ x i, b.reindex_range.repr x ⟨b i, _⟩) _ _ _ x i).symm,
  { intros x y,
    ext i,
    simp only [pi.add_apply, linear_equiv.map_add, finsupp.coe_add] },
  { intros c x,
    ext i,
    simp only [pi.smul_apply, linear_equiv.map_smul, finsupp.coe_smul] },
  { intros i,
    ext j,
    simp only [reindex_range_repr_self],
    refine @finsupp.single_apply_left _ _ _ _ (λ i, (⟨b i, _⟩ : set.range b)) _ _ _ _,
    exact λ i j h, b.injective (subtype.mk.inj h) }
end

@[simp] lemma reindex_range_repr (x : M) (i : ι) (h := set.mem_range_self i) :
  b.reindex_range.repr x ⟨b i, h⟩ = b.repr x i :=
b.reindex_range_repr' _ rfl

section fintype

variables [fintype ι]

/-- `b.reindex_finset_range` is a basis indexed by `finset.univ.image b`,
the finite set of basis vectors themselves. -/
def reindex_finset_range : basis (finset.univ.image b) R M :=
b.reindex_range.reindex ((equiv.refl M).subtype_equiv (by simp))

lemma reindex_finset_range_self (i : ι) (h := finset.mem_image_of_mem b (finset.mem_univ i)) :
  b.reindex_finset_range ⟨b i, h⟩ = b i :=
by { rw [reindex_finset_range, reindex_apply, reindex_range_apply], refl }

@[simp] lemma reindex_finset_range_apply (x : finset.univ.image b) :
  b.reindex_finset_range x = x :=
by { rcases x with ⟨bi, hbi⟩, rcases finset.mem_image.mp hbi with ⟨i, -, rfl⟩,
     exact b.reindex_finset_range_self i }

lemma reindex_finset_range_repr_self (i : ι) :
  b.reindex_finset_range.repr (b i) =
    finsupp.single ⟨b i, finset.mem_image_of_mem b (finset.mem_univ i)⟩ 1 :=
begin
  ext ⟨bi, hbi⟩,
  rw [reindex_finset_range, reindex_repr, reindex_range_repr_self],
  convert finsupp.single_apply_left ((equiv.refl M).subtype_equiv _).symm.injective _ _ _,
  refl
end

@[simp] lemma reindex_finset_range_repr (x : M) (i : ι)
  (h := finset.mem_image_of_mem b (finset.mem_univ i)) :
  b.reindex_finset_range.repr x ⟨b i, h⟩ = b.repr x i :=
by simp [reindex_finset_range]

end fintype

end reindex

protected lemma linear_independent : linear_independent R b :=
linear_independent_iff.mpr $ λ l hl,
calc l = b.repr (finsupp.total _ _ _ b l) : (b.repr_total l).symm
   ... = 0 : by rw [hl, linear_equiv.map_zero]

protected lemma ne_zero [nontrivial R] (i) : b i ≠ 0 :=
b.linear_independent.ne_zero i

protected lemma mem_span (x : M) : x ∈ span R (range b) :=
by { rw [← b.total_repr x, finsupp.total_apply, finsupp.sum],
     exact submodule.sum_mem _ (λ i hi, submodule.smul_mem _ _ (submodule.subset_span ⟨i, rfl⟩)) }

protected lemma span_eq : span R (range b) = ⊤ :=
eq_top_iff.mpr $ λ x _, b.mem_span x

lemma index_nonempty (b : basis ι R M) [nontrivial M] : nonempty ι :=
begin
  obtain ⟨x, y, ne⟩ : ∃ (x y : M), x ≠ y := nontrivial.exists_pair_ne,
  obtain ⟨i, _⟩ := not_forall.mp (mt b.ext_elem ne),
  exact ⟨i⟩
end

section constr

variables (S : Type*) [semiring S] [module S M']
variables [smul_comm_class R S M']

/-- Construct a linear map given the value at the basis.

This definition is parameterized over an extra `semiring S`,
such that `smul_comm_class R S M'` holds.
If `R` is commutative, you can set `S := R`; if `R` is not commutative,
you can recover an `add_equiv` by setting `S := ℕ`.
See library note [bundled maps over different rings].
-/
def constr : (ι → M') ≃ₗ[S] (M →ₗ[R] M') :=
{ to_fun := λ f, (finsupp.total M' M' R id).comp $ (finsupp.lmap_domain R R f) ∘ₗ ↑b.repr,
  inv_fun := λ f i, f (b i),
  left_inv := λ f, by { ext, simp },
  right_inv := λ f, by { refine b.ext (λ i, _), simp },
  map_add' := λ f g, by { refine b.ext (λ i, _), simp },
  map_smul' := λ c f, by { refine b.ext (λ i, _), simp } }

theorem constr_def (f : ι → M') :
  b.constr S f = (finsupp.total M' M' R id) ∘ₗ ((finsupp.lmap_domain R R f) ∘ₗ ↑b.repr) :=
rfl

theorem constr_apply (f : ι → M') (x : M) :
  b.constr S f x = (b.repr x).sum (λ b a, a • f b) :=
by { simp only [constr_def, linear_map.comp_apply, finsupp.lmap_domain_apply, finsupp.total_apply],
     rw finsupp.sum_map_domain_index; simp [add_smul] }

@[simp] lemma constr_basis (f : ι → M') (i : ι) :
  (b.constr S f : M → M') (b i) = f i :=
by simp [basis.constr_apply, b.repr_self]

lemma constr_eq {g : ι → M'} {f : M →ₗ[R] M'}
  (h : ∀i, g i = f (b i)) : b.constr S g = f :=
b.ext $ λ i, (b.constr_basis S g i).trans (h i)

lemma constr_self (f : M →ₗ[R] M') : b.constr S (λ i, f (b i)) = f :=
b.constr_eq S $ λ x, rfl

lemma constr_range [nonempty ι] {f : ι  → M'} :
  (b.constr S f).range = span R (range f) :=
by rw [b.constr_def S f, linear_map.range_comp, linear_map.range_comp, linear_equiv.range,
       ← finsupp.supported_univ, finsupp.lmap_domain_supported, ←set.image_univ,
       ← finsupp.span_image_eq_map_total, set.image_id]

@[simp]
lemma constr_comp (f : M' →ₗ[R] M') (v : ι → M') :
  b.constr S (f ∘ v) = f.comp (b.constr S v) :=
b.ext (λ i, by simp only [basis.constr_basis, linear_map.comp_apply])

end constr

section equiv

variables (b' : basis ι' R M') (e : ι ≃ ι')
variables [add_comm_monoid M''] [module R M'']

/-- If `b` is a basis for `M` and `b'` a basis for `M'`, and the index types are equivalent,
`b.equiv b' e` is a linear equivalence `M ≃ₗ[R] M'`, mapping `b i` to `b' (e i)`. -/
protected def equiv : M ≃ₗ[R] M' :=
b.repr.trans (b'.reindex e.symm).repr.symm

@[simp] lemma equiv_apply : b.equiv b' e (b i) = b' (e i) :=
by simp [basis.equiv]

@[simp] lemma equiv_refl :
  b.equiv b (equiv.refl ι) = linear_equiv.refl R M :=
b.ext' (λ i, by simp)

@[simp] lemma equiv_symm : (b.equiv b' e).symm = b'.equiv b e.symm :=
b'.ext' $ λ i, (b.equiv b' e).injective (by simp)

@[simp]

@[simp]
lemma map_equiv (b : basis ι R M) (b' : basis ι' R M') (e : ι ≃ ι') :
  b.map (b.equiv b' e) = b'.reindex e.symm :=
by { ext i, simp }

end equiv

section prod

variables (b' : basis ι' R M')

/-- `basis.prod` maps a `ι`-indexed basis for `M` and a `ι'`-indexed basis for `M'`
to a `ι ⊕ ι'`-index basis for `M × M'`. -/
protected def prod : basis (ι ⊕ ι') R (M × M') :=
of_repr ((b.repr.prod b'.repr).trans (finsupp.sum_finsupp_lequiv_prod_finsupp R).symm)

@[simp]
lemma prod_repr_inl (x) (i) : (b.prod b').repr x (sum.inl i) = b.repr x.1 i := rfl

@[simp]
lemma prod_repr_inr (x) (i) : (b.prod b').repr x (sum.inr i) = b'.repr x.2 i := rfl

lemma prod_apply_inl_fst (i) :
  (b.prod b' (sum.inl i)).1 = b i :=
b.repr.injective $ by
{ ext j,
  simp only [basis.prod, basis.coe_of_repr, linear_equiv.symm_trans_apply, linear_equiv.prod_symm,
      linear_equiv.prod_apply, b.repr.apply_symm_apply, linear_equiv.symm_symm, repr_self,
      equiv.to_fun_as_coe, finsupp.fst_sum_finsupp_lequiv_prod_finsupp],
  apply finsupp.single_apply_left sum.inl_injective }

lemma prod_apply_inr_fst (i) :
(b.prod b' (sum.inr i)).1 = 0 :=
b.repr.injective $ by
{ ext i,
  simp only [basis.prod, basis.coe_of_repr, linear_equiv.symm_trans_apply, linear_equiv.prod_symm,
      linear_equiv.prod_apply, b.repr.apply_symm_apply, linear_equiv.symm_symm, repr_self,
      equiv.to_fun_as_coe, finsupp.fst_sum_finsupp_lequiv_prod_finsupp, linear_equiv.map_zero,
      finsupp.zero_apply],
  apply finsupp.single_eq_of_ne sum.inr_ne_inl }

lemma prod_apply_inl_snd (i) :
  (b.prod b' (sum.inl i)).2 = 0 :=
b'.repr.injective $ by
{ ext j,
  simp only [basis.prod, basis.coe_of_repr, linear_equiv.symm_trans_apply, linear_equiv.prod_symm,
      linear_equiv.prod_apply, b'.repr.apply_symm_apply, linear_equiv.symm_symm, repr_self,
      equiv.to_fun_as_coe, finsupp.snd_sum_finsupp_lequiv_prod_finsupp, linear_equiv.map_zero,
      finsupp.zero_apply],
  apply finsupp.single_eq_of_ne sum.inl_ne_inr }

lemma prod_apply_inr_snd (i) :
(b.prod b' (sum.inr i)).2 = b' i :=
b'.repr.injective $ by
{ ext i,
  simp only [basis.prod, basis.coe_of_repr, linear_equiv.symm_trans_apply, linear_equiv.prod_symm,
      linear_equiv.prod_apply, b'.repr.apply_symm_apply, linear_equiv.symm_symm, repr_self,
      equiv.to_fun_as_coe, finsupp.snd_sum_finsupp_lequiv_prod_finsupp],
  apply finsupp.single_apply_left sum.inr_injective }

@[simp]
lemma prod_apply (i) :
  b.prod b' i = sum.elim (linear_map.inl R M M' ∘ b) (linear_map.inr R M M' ∘ b') i :=
by { ext; cases i; simp only [prod_apply_inl_fst, sum.elim_inl, linear_map.inl_apply,
                              prod_apply_inr_fst, sum.elim_inr, linear_map.inr_apply,
                              prod_apply_inl_snd, prod_apply_inr_snd, comp_app] }

end prod

section no_zero_smul_divisors

-- Can't be an instance because the basis can't be inferred.
protected lemma no_zero_smul_divisors [no_zero_divisors R] (b : basis ι R M) :
  no_zero_smul_divisors R M :=
⟨λ c x hcx, or_iff_not_imp_right.mpr (λ hx, begin
  rw [← b.total_repr x, ← linear_map.map_smul] at hcx,
  have := linear_independent_iff.mp b.linear_independent (c • b.repr x) hcx,
  rw smul_eq_zero at this,
  exact this.resolve_right (λ hr, hx (b.repr.map_eq_zero_iff.mp hr))
end)⟩

protected lemma smul_eq_zero [no_zero_divisors R] (b : basis ι R M) {c : R} {x : M} :
  c • x = 0 ↔ c = 0 ∨ x = 0 :=
@smul_eq_zero _ _ _ _ _ b.no_zero_smul_divisors _ _

lemma _root_.eq_bot_of_rank_eq_zero [no_zero_divisors R] (b : basis ι R M) (N : submodule R M)
  (rank_eq : ∀ {m : ℕ} (v : fin m → N),
    linear_independent R (coe ∘ v : fin m → M) → m = 0) :
  N = ⊥ :=
begin
  rw submodule.eq_bot_iff,
  intros x hx,
  contrapose! rank_eq with x_ne,
  refine ⟨1, λ _, ⟨x, hx⟩, _, one_ne_zero⟩,
  rw fintype.linear_independent_iff,
  rintros g sum_eq i,
  cases i,
  simp only [function.const_apply, fin.default_eq_zero, submodule.coe_mk, finset.univ_unique,
             function.comp_const, finset.sum_singleton] at sum_eq,
  convert (b.smul_eq_zero.mp sum_eq).resolve_right x_ne
end

end no_zero_smul_divisors

section singleton

/-- `basis.singleton ι R` is the basis sending the unique element of `ι` to `1 : R`. -/
protected def singleton (ι R : Type*) [unique ι] [semiring R] :
  basis ι R R :=
of_repr
{ to_fun := λ x, finsupp.single (default ι) x,
  inv_fun := λ f, f (default ι),
  left_inv := λ x, by simp,
  right_inv := λ f, finsupp.unique_ext (by simp),
  map_add' := λ x y, by simp,
  map_smul' := λ c x, by simp }

@[simp] lemma singleton_apply (ι R : Type*) [unique ι] [semiring R] (i) :
  basis.singleton ι R i = 1 :=
apply_eq_iff.mpr (by simp [basis.singleton])

@[simp] lemma singleton_repr (ι R : Type*) [unique ι] [semiring R] (x i) :
  (basis.singleton ι R).repr x i = x :=
by simp [basis.singleton, unique.eq_default i]

lemma basis_singleton_iff
  {R M : Type*} [ring R] [nontrivial R] [add_comm_group M] [module R M] [no_zero_smul_divisors R M]
  (ι : Type*) [unique ι] :
  nonempty (basis ι R M) ↔ ∃ x ≠ 0, ∀ y : M, ∃ r : R, r • x = y :=
begin
  fsplit,
  { rintro ⟨b⟩,
    refine ⟨b (default ι), b.linear_independent.ne_zero _, _⟩,
    simpa [span_singleton_eq_top_iff, set.range_unique] using b.span_eq },
  { rintro ⟨x, nz, w⟩,
    refine ⟨of_repr $ linear_equiv.symm
      { to_fun := λ f, f (default ι) • x,
        inv_fun := λ y, finsupp.single (default ι) (w y).some,
        left_inv := λ f, finsupp.unique_ext _,
        right_inv := λ y, _,
        map_add' := λ y z, _,
        map_smul' := λ c y, _ }⟩,
    { rw [finsupp.add_apply, add_smul] },
    { rw [finsupp.smul_apply, smul_assoc], simp },
    { refine smul_left_injective _ nz _,
      simp only [finsupp.single_eq_same],
      exact (w (f (default ι) • x)).some_spec },
    { simp only [finsupp.single_eq_same],
      exact (w y).some_spec } }
end

end singleton

section empty

variables (M)

/-- If `M` is a subsingleton and `ι` is empty, this is the unique `ι`-indexed basis for `M`. -/
protected def empty [subsingleton M] [is_empty ι] : basis ι R M :=
of_repr 0

instance empty_unique [subsingleton M] [is_empty ι] : unique (basis ι R M) :=
{ default := basis.empty M, uniq := λ ⟨x⟩, congr_arg of_repr $ subsingleton.elim _ _ }

end empty

end basis

section fintype

open basis
open fintype

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

/-- A module over `R` with a finite basis is linearly equivalent to functions from its basis to `R`.
-/
def basis.equiv_fun : M ≃ₗ[R] (ι → R) :=
linear_equiv.trans b.repr
  ({ to_fun := coe_fn,
     map_add' := finsupp.coe_add,
     map_smul' := finsupp.coe_smul,
     ..finsupp.equiv_fun_on_fintype } : (ι →₀ R) ≃ₗ[R] (ι → R))

/-- A module over a finite ring that admits a finite basis is finite. -/
def module.fintype_of_fintype [fintype R] : fintype M :=
fintype.of_equiv _ b.equiv_fun.to_equiv.symm

theorem module.card_fintype [fintype R] [fintype M] :
  card M = (card R) ^ (card ι) :=
calc card M = card (ι → R)    : card_congr b.equiv_fun.to_equiv
        ... = card R ^ card ι : card_fun

/-- Given a basis `v` indexed by `ι`, the canonical linear equivalence between `ι → R` and `M` maps
a function `x : ι → R` to the linear combination `∑_i x i • v i`. -/
@[simp] lemma basis.equiv_fun_symm_apply (x : ι → R) :
  b.equiv_fun.symm x = ∑ i, x i • b i :=
by simp [basis.equiv_fun, finsupp.total_apply, finsupp.sum_fintype]

@[simp]
lemma basis.equiv_fun_apply (u : M) : b.equiv_fun u = b.repr u := rfl

lemma basis.sum_equiv_fun (u : M) : ∑ i, b.equiv_fun u i • b i = u :=
begin
  conv_rhs { rw ← b.total_repr u },
  simp [finsupp.total_apply, finsupp.sum_fintype, b.equiv_fun_apply]
end

lemma basis.sum_repr (u : M) : ∑ i, b.repr u i • b i = u :=
b.sum_equiv_fun u

@[simp]
lemma basis.equiv_fun_self (i j : ι) : b.equiv_fun (b i) j = if i = j then 1 else 0 :=
by { rw [b.equiv_fun_apply, b.repr_self_apply] }

/-- Define a basis by mapping each vector `x : M` to its coordinates `e x : ι → R`,
as long as `ι` is finite. -/
def basis.of_equiv_fun (e : M ≃ₗ[R] (ι → R)) : basis ι R M :=
basis.of_repr $ e.trans $ linear_equiv.symm $ finsupp.linear_equiv_fun_on_fintype R R ι

@[simp] lemma basis.of_equiv_fun_repr_apply (e : M ≃ₗ[R] (ι → R)) (x : M) (i : ι) :
  (basis.of_equiv_fun e).repr x i = e x i := rfl

@[simp] lemma basis.coe_of_equiv_fun (e : M ≃ₗ[R] (ι → R)) :
  (basis.of_equiv_fun e : ι → M) = λ i, e.symm (function.update 0 i 1) :=
funext $ λ i, e.injective $ funext $ λ j,
  by simp [basis.of_equiv_fun, ←finsupp.single_eq_pi_single, finsupp.single_eq_update]

variables (S : Type*) [semiring S] [module S M']
variables [smul_comm_class R S M']

@[simp] theorem basis.constr_apply_fintype (f : ι → M') (x : M) :
  (b.constr S f : M → M') x = ∑ i, (b.equiv_fun x i) • f i :=
by simp [b.constr_apply, b.equiv_fun_apply, finsupp.sum_fintype]

end fintype

end module

section comm_semiring

namespace basis

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

/-- If `b` is a basis for `M` and `b'` a basis for `M'`,
and `f`, `g` form a bijection between the basis vectors,
`b.equiv' b' f g hf hg hgf hfg` is a linear equivalence `M ≃ₗ[R] M'`, mapping `b i` to `f (b i)`.
-/
def equiv' (f : M → M') (g : M' → M)
  (hf : ∀ i, f (b i) ∈ range b') (hg : ∀ i, g (b' i) ∈ range b)
  (hgf : ∀i, g (f (b i)) = b i) (hfg : ∀i, f (g (b' i)) = b' i) :
  M ≃ₗ[R] M' :=
{ inv_fun := b'.constr R (g ∘ b'),
  left_inv :=
    have (b'.constr R (g ∘ b')).comp (b.constr R (f ∘ b)) = linear_map.id,
    from (b.ext $ λ i, exists.elim (hf i)
      (λ i' hi', by rw [linear_map.comp_apply, b.constr_basis, function.comp_apply, ← hi',
                        b'.constr_basis, function.comp_apply, hi', hgf, linear_map.id_apply])),
    λ x, congr_arg (λ (h : M →ₗ[R] M), h x) this,
  right_inv :=
    have (b.constr R (f ∘ b)).comp (b'.constr R (g ∘ b')) = linear_map.id,
    from (b'.ext $ λ i, exists.elim (hg i)
      (λ i' hi', by rw [linear_map.comp_apply, b'.constr_basis, function.comp_apply, ← hi',
                        b.constr_basis, function.comp_apply, hi', hfg, linear_map.id_apply])),
    λ x, congr_arg (λ (h : M' →ₗ[R] M'), h x) this,
  .. b.constr R (f ∘ b) }

@[simp] lemma equiv'_apply (f : M → M') (g : M' → M) (hf hg hgf hfg) (i : ι) :
  b.equiv' b' f g hf hg hgf hfg (b i) = f (b i) :=
b.constr_basis R _ _

@[simp] lemma equiv'_symm_apply (f : M → M') (g : M' → M) (hf hg hgf hfg) (i : ι') :
  (b.equiv' b' f g hf hg hgf hfg).symm (b' i) = g (b' i) :=
b'.constr_basis R _ _

lemma sum_repr_mul_repr {ι'} [fintype ι'] (b' : basis ι' R M) (x : M) (i : ι) :
  ∑ (j : ι'), b.repr (b' j) i * b'.repr x j = b.repr x i :=
begin
  conv_rhs { rw [← b'.sum_repr x] },
  simp_rw [linear_equiv.map_sum, linear_equiv.map_smul, finset.sum_apply'],
  refine finset.sum_congr rfl (λ j _, _),
  rw [finsupp.smul_apply, smul_eq_mul, mul_comm]
end

end basis

end comm_semiring

section module

open linear_map

variables {v : ι → M}
variables [ring R] [add_comm_group M] [add_comm_group M'] [add_comm_group M'']
variables [module R M] [module R M'] [module R M'']
variables {c d : R} {x y : M}
variables (b : basis ι R M)

namespace basis

/--
Any basis is a maximal linear independent set.
-/
lemma maximal [nontrivial R] (b : basis ι R M) : b.linear_independent.maximal :=
λ w hi h,
begin
  -- If `range w` is strictly bigger than `range b`,
  apply le_antisymm h,
  -- then choose some `x ∈ range w \ range b`,
  intros x p,
  by_contradiction q,
  -- and write it in terms of the basis.
  have e := b.total_repr x,
  -- This then expresses `x` as a linear combination
  -- of elements of `w` which are in the range of `b`,
  let u : ι ↪ w := ⟨λ i, ⟨b i, h ⟨i, rfl⟩⟩, λ i i' r,
    b.injective (by simpa only [subtype.mk_eq_mk] using r)⟩,
  have r : ∀ i, b i = u i := λ i, rfl,
  simp_rw [finsupp.total_apply, r] at e,
  change (b.repr x).sum (λ (i : ι) (a : R), (λ (x : w) (r : R), r • (x : M)) (u i) a) =
    ((⟨x, p⟩ : w) : M) at e,
  rw [←finsupp.sum_emb_domain, ←finsupp.total_apply] at e,
  -- Now we can contradict the linear independence of `hi`
  refine hi.total_ne_of_not_mem_support _ _ e,
  simp only [finset.mem_map, finsupp.support_emb_domain],
  rintro ⟨j, -, W⟩,
  simp only [embedding.coe_fn_mk, subtype.mk_eq_mk, ←r] at W,
  apply q ⟨j, W⟩,
end

section mk

variables (hli : linear_independent R v) (hsp : span R (range v) = ⊤)

/-- A linear independent family of vectors spanning the whole module is a basis. -/
protected noncomputable def mk : basis ι R M :=
basis.of_repr
{ inv_fun := finsupp.total _ _ _ v,
  left_inv := λ x, hli.total_repr ⟨x, _⟩,
  right_inv := λ x, hli.repr_eq rfl,
  .. hli.repr.comp (linear_map.id.cod_restrict _ (λ h, hsp.symm ▸ submodule.mem_top)) }

@[simp] lemma mk_repr :
  (basis.mk hli hsp).repr x = hli.repr ⟨x, hsp.symm ▸ submodule.mem_top⟩ :=
rfl

lemma mk_apply (i : ι) : basis.mk hli hsp i = v i :=
show finsupp.total _ _ _ v _ = v i, by simp

@[simp] lemma coe_mk : ⇑(basis.mk hli hsp) = v :=
funext (mk_apply _ _)

variables {hli hsp}

/-- Given a basis, the `i`th element of the dual basis evaluates to 1 on the `i`th element of the
basis. -/
lemma mk_coord_apply_eq (i : ι) :
  (basis.mk hli hsp).coord i (v i) = 1 :=
show hli.repr ⟨v i, submodule.subset_span (mem_range_self i)⟩ i = 1,
by simp [hli.repr_eq_single i]

/-- Given a basis, the `i`th element of the dual basis evaluates to 0 on the `j`th element of the
basis if `j ≠ i`. -/
lemma mk_coord_apply_ne {i j : ι} (h : j ≠ i) :
  (basis.mk hli hsp).coord i (v j) = 0 :=
show hli.repr ⟨v j, submodule.subset_span (mem_range_self j)⟩ i = 0,
by simp [hli.repr_eq_single j, h]

/-- Given a basis, the `i`th element of the dual basis evaluates to the Kronecker delta on the
`j`th element of the basis. -/
lemma mk_coord_apply {i j : ι} :
  (basis.mk hli hsp).coord i (v j) = if j = i then 1 else 0 :=
begin
  cases eq_or_ne j i,
  { simp only [h, if_true, eq_self_iff_true, mk_coord_apply_eq i], },
  { simp only [h, if_false, mk_coord_apply_ne h], },
end

end mk

section span

variables (hli : linear_independent R v)

/-- A linear independent family of vectors is a basis for their span. -/
protected noncomputable def span : basis ι R (span R (range v)) :=
basis.mk (linear_independent_span hli) $
begin
  rw eq_top_iff,
  intros x _,
  have h₁ : subtype.val '' set.range (λ i, subtype.mk (v i) _) = range v,
  { rw ← set.range_comp },
  have h₂ : map (submodule.subtype _) (span R (set.range (λ i, subtype.mk (v i) _)))
    = span R (range v),
  { rw [← span_image, submodule.subtype_eq_val, h₁] },
  have h₃ : (x : M) ∈ map (submodule.subtype _) (span R (set.range (λ i, subtype.mk (v i) _))),
  { rw h₂, apply subtype.mem x },
  rcases mem_map.1 h₃ with ⟨y, hy₁, hy₂⟩,
  have h_x_eq_y : x = y,
  { rw [subtype.ext_iff, ← hy₂], simp },
  rwa h_x_eq_y
end

end span

lemma group_smul_span_eq_top
  {G : Type*} [group G] [distrib_mul_action G R] [distrib_mul_action G M]
  [is_scalar_tower G R M] {v : ι → M} (hv : submodule.span R (set.range v) = ⊤) {w : ι → G} :
  submodule.span R (set.range (w • v)) = ⊤ :=
begin
  rw eq_top_iff,
  intros j hj,
  rw ← hv at hj,
  rw submodule.mem_span at hj ⊢,
  refine λ p hp, hj p (λ u hu, _),
  obtain ⟨i, rfl⟩ := hu,
  have : ((w i)⁻¹ • 1 : R) • w i • v i ∈ p := p.smul_mem ((w i)⁻¹ • 1 : R) (hp ⟨i, rfl⟩),
  rwa [smul_one_smul, inv_smul_smul] at this,
end

/-- Given a basis `v` and a map `w` such that for all `i`, `w i` are elements of a group,
`group_smul` provides the basis corresponding to `w • v`. -/
def group_smul {G : Type*} [group G] [distrib_mul_action G R] [distrib_mul_action G M]
  [is_scalar_tower G R M] [smul_comm_class G R M] (v : basis ι R M) (w : ι → G) :
  basis ι R M :=
@basis.mk ι R M (w • v) _ _ _
  (v.linear_independent.group_smul w) (group_smul_span_eq_top v.span_eq)

lemma group_smul_apply {G : Type*} [group G] [distrib_mul_action G R] [distrib_mul_action G M]
  [is_scalar_tower G R M] [smul_comm_class G R M] {v : basis ι R M} {w : ι → G} (i : ι) :
  v.group_smul w i = (w • v : ι → M) i :=
mk_apply
  (v.linear_independent.group_smul w) (group_smul_span_eq_top v.span_eq) i

lemma units_smul_span_eq_top {v : ι → M} (hv : submodule.span R (set.range v) = ⊤)
  {w : ι → units R} : submodule.span R (set.range (w • v)) = ⊤ :=
group_smul_span_eq_top hv

/-- Given a basis `v` and a map `w` such that for all `i`, `w i` is a unit, `smul_of_is_unit`
provides the basis corresponding to `w • v`. -/
def units_smul (v : basis ι R M) (w : ι → units R) :
  basis ι R M :=
@basis.mk ι R M (w • v) _ _ _
  (v.linear_independent.units_smul w) (units_smul_span_eq_top v.span_eq)

lemma units_smul_apply {v : basis ι R M} {w : ι → units R} (i : ι) :
  v.units_smul w i = w i • v i :=
mk_apply
  (v.linear_independent.units_smul w) (units_smul_span_eq_top v.span_eq) i

/-- A version of `smul_of_units` that uses `is_unit`. -/
def is_unit_smul (v : basis ι R M) {w : ι → R} (hw : ∀ i, is_unit (w i)):
  basis ι R M :=
units_smul v (λ i, (hw i).unit)

lemma is_unit_smul_apply {v : basis ι R M} {w : ι → R} (hw : ∀ i, is_unit (w i)) (i : ι) :
  v.is_unit_smul hw i = w i • v i :=
units_smul_apply i

section fin

/-- Let `b` be a basis for a submodule `N` of `M`. If `y : M` is linear independent of `N`
and `y` and `N` together span the whole of `M`, then there is a basis for `M`
whose basis vectors are given by `fin.cons y b`. -/
noncomputable def mk_fin_cons {n : ℕ} {N : submodule R M} (y : M) (b : basis (fin n) R N)
  (hli : ∀ (c : R) (x ∈ N), c • y + x = 0 → c = 0)
  (hsp : ∀ (z : M), ∃ (c : R), z + c • y ∈ N) :
  basis (fin (n + 1)) R M :=
have span_b : submodule.span R (set.range (N.subtype ∘ b)) = N,
{ rw [set.range_comp, submodule.span_image, b.span_eq, submodule.map_subtype_top] },
@basis.mk _ _ _ (fin.cons y (N.subtype ∘ b) : fin (n + 1) → M) _ _ _
  ((b.linear_independent.map' N.subtype (submodule.ker_subtype _)) .fin_cons' _ _ $
    by { rintros c ⟨x, hx⟩ hc, rw span_b at hx, exact hli c x hx hc })
  (eq_top_iff.mpr (λ x _,
    by { rw [fin.range_cons, submodule.mem_span_insert', span_b], exact hsp x }))

@[simp] lemma coe_mk_fin_cons {n : ℕ} {N : submodule R M} (y : M) (b : basis (fin n) R N)
  (hli : ∀ (c : R) (x ∈ N), c • y + x = 0 → c = 0)
  (hsp : ∀ (z : M), ∃ (c : R), z + c • y ∈ N) :
  (mk_fin_cons y b hli hsp : fin (n + 1) → M) = fin.cons y (coe ∘ b) :=
coe_mk _ _

/-- Let `b` be a basis for a submodule `N ≤ O`. If `y ∈ O` is linear independent of `N`
and `y` and `N` together span the whole of `O`, then there is a basis for `O`
whose basis vectors are given by `fin.cons y b`. -/
noncomputable def mk_fin_cons_of_le {n : ℕ} {N O : submodule R M}
  (y : M) (yO : y ∈ O) (b : basis (fin n) R N) (hNO : N ≤ O)
  (hli : ∀ (c : R) (x ∈ N), c • y + x = 0 → c = 0)
  (hsp : ∀ (z ∈ O), ∃ (c : R), z + c • y ∈ N) :
  basis (fin (n + 1)) R O :=
mk_fin_cons ⟨y, yO⟩ (b.map (submodule.comap_subtype_equiv_of_le hNO).symm)
  (λ c x hc hx, hli c x (submodule.mem_comap.mp hc) (congr_arg coe hx))
  (λ z, hsp z z.2)

@[simp] lemma coe_mk_fin_cons_of_le {n : ℕ} {N O : submodule R M}
  (y : M) (yO : y ∈ O) (b : basis (fin n) R N) (hNO : N ≤ O)
  (hli : ∀ (c : R) (x ∈ N), c • y + x = 0 → c = 0)
  (hsp : ∀ (z ∈ O), ∃ (c : R), z + c • y ∈ N) :
  (mk_fin_cons_of_le y yO b hNO hli hsp : fin (n + 1) → O) =
    fin.cons ⟨y, yO⟩ (submodule.of_le hNO ∘ b) :=
coe_mk_fin_cons _ _ _ _

end fin

end basis

end module

section induction

variables [ring R] [is_domain R]
variables [add_comm_group M] [module R M] {b : ι → M}

/-- If `N` is a submodule with finite rank, do induction on adjoining a linear independent
element to a submodule. -/
def submodule.induction_on_rank_aux (b : basis ι R M) (P : submodule R M → Sort*)
  (ih : ∀ (N : submodule R M),
    (∀ (N' ≤ N) (x ∈ N), (∀ (c : R) (y ∈ N'), c • x + y = (0 : M) → c = 0) → P N') → P N)
  (n : ℕ) (N : submodule R M)
  (rank_le : ∀ {m : ℕ} (v : fin m → N),
    linear_independent R (coe ∘ v : fin m → M) → m ≤ n) :
  P N :=
begin
  haveI : decidable_eq M := classical.dec_eq M,
  have Pbot : P ⊥,
  { apply ih,
    intros N N_le x x_mem x_ortho,
    exfalso,
    simpa using x_ortho 1 0 N.zero_mem },

  induction n with n rank_ih generalizing N,
  { suffices : N = ⊥,
    { rwa this },
    apply eq_bot_of_rank_eq_zero b _ (λ m v hv, nat.le_zero_iff.mp (rank_le v hv)) },
  apply ih,
  intros N' N'_le x x_mem x_ortho,
  apply rank_ih,
  intros m v hli,
  refine nat.succ_le_succ_iff.mp (rank_le (fin.cons ⟨x, x_mem⟩ (λ i, ⟨v i, N'_le (v i).2⟩)) _),
  convert hli.fin_cons' x _ _,
  { ext i, refine fin.cases _ _ i; simp },
  { intros c y hcy,
    refine x_ortho c y (submodule.span_le.mpr _ y.2) hcy,
    rintros _ ⟨z, rfl⟩,
    exact (v z).2 }
end

end induction

section division_ring

variables [division_ring K] [add_comm_group V] [add_comm_group V'] [module K V] [module K V']
variables {v : ι → V} {s t : set V} {x y z : V}

include K

open submodule

namespace basis

section exists_basis

/-- If `s` is a linear independent set of vectors, we can extend it to a basis. -/
noncomputable def extend (hs : linear_independent K (coe : s → V)) :
  basis _ K V :=
basis.mk
  (@linear_independent.restrict_of_comp_subtype _ _ _ id _ _ _ _ (hs.linear_independent_extend _))
  (eq_top_iff.mpr $ set_like.coe_subset_coe.mp $
    by simpa using hs.subset_span_extend (subset_univ s))

lemma extend_apply_self (hs : linear_independent K (coe : s → V))
  (x : hs.extend _) :
  basis.extend hs x = x :=
basis.mk_apply _ _ _

@[simp] lemma coe_extend (hs : linear_independent K (coe : s → V)) :
  ⇑(basis.extend hs) = coe :=
funext (extend_apply_self hs)

lemma range_extend (hs : linear_independent K (coe : s → V)) :
  range (basis.extend hs) = hs.extend (subset_univ _) :=
by rw [coe_extend, subtype.range_coe_subtype, set_of_mem_eq]

/-- If `v` is a linear independent family of vectors, extend it to a basis indexed by a sum type. -/
noncomputable def sum_extend (hs : linear_independent K v) :
  basis (ι ⊕ _) K V :=
let s := set.range v,
    e : ι ≃ s := equiv.of_injective v hs.injective,
    b := hs.to_subtype_range.extend (subset_univ (set.range v)) in
(basis.extend hs.to_subtype_range).reindex $ equiv.symm $
  calc ι ⊕ (b \ s : set V) ≃ s ⊕ (b \ s : set V) : equiv.sum_congr e (equiv.refl _)
  ... ≃ b                   : equiv.set.sum_diff_subset (hs.to_subtype_range.subset_extend _)

lemma subset_extend {s : set V} (hs : linear_independent K (coe : s → V)) :
  s ⊆ hs.extend (set.subset_univ _) :=
hs.subset_extend _

section

variables (K V)

/-- A set used to index `basis.of_vector_space`. -/
noncomputable def of_vector_space_index : set V :=
(linear_independent_empty K V).extend (subset_univ _)

/-- Each vector space has a basis. -/
noncomputable def of_vector_space : basis (of_vector_space_index K V) K V :=
basis.extend (linear_independent_empty K V)

lemma of_vector_space_apply_self (x : of_vector_space_index K V) :
  of_vector_space K V x = x :=
basis.mk_apply _ _ _

@[simp] lemma coe_of_vector_space :
  ⇑(of_vector_space K V) = coe :=
funext (λ x, of_vector_space_apply_self K V x)

lemma of_vector_space_index.linear_independent :
  linear_independent K (coe : of_vector_space_index K V → V) :=
by { convert (of_vector_space K V).linear_independent, ext x, rw of_vector_space_apply_self }

lemma range_of_vector_space :
  range (of_vector_space K V) = of_vector_space_index K V :=
range_extend _

lemma exists_basis : ∃ s : set V, nonempty (basis s K V) :=
⟨of_vector_space_index K V, ⟨of_vector_space K V⟩⟩

end

end exists_basis

end basis

open fintype
variables (K V)

theorem vector_space.card_fintype [fintype K] [fintype V] :
  ∃ n : ℕ, card V = (card K) ^ n :=
⟨card (basis.of_vector_space_index K V), module.card_fintype (basis.of_vector_space K V)⟩

end division_ring

section field

variables [field K] [add_comm_group V] [add_comm_group V'] [module K V] [module K V']
variables {v : ι → V} {s t : set V} {x y z : V}

lemma linear_map.exists_left_inverse_of_injective (f : V →ₗ[K] V')
  (hf_inj : f.ker = ⊥) : ∃g:V' →ₗ[K] V, g.comp f = linear_map.id :=
begin
  let B := basis.of_vector_space_index K V,
  let hB := basis.of_vector_space K V,
  have hB₀ : _ := hB.linear_independent.to_subtype_range,
  have : linear_independent K (λ x, x : f '' B → V'),
  { have h₁ : linear_independent K (λ (x : ↥(⇑f '' range (basis.of_vector_space _ _))), ↑x) :=
         @linear_independent.image_subtype _ _ _ _ _ _ _ _ _ f hB₀
      (show disjoint _ _, by simp [hf_inj]),
    rwa [basis.range_of_vector_space K V] at h₁ },
  let C := this.extend (subset_univ _),
  have BC := this.subset_extend (subset_univ _),
  let hC := basis.extend this,
  haveI : inhabited V := ⟨0⟩,
  refine ⟨hC.constr K (C.restrict (inv_fun f)), hB.ext (λ b, _)⟩,
  rw image_subset_iff at BC,
  have fb_eq : f b = hC ⟨f b, BC b.2⟩,
  { change f b = basis.extend this _,
    rw [basis.extend_apply_self, subtype.coe_mk] },
  dsimp [hB],
  rw [basis.of_vector_space_apply_self, fb_eq, hC.constr_basis],
  exact left_inverse_inv_fun (linear_map.ker_eq_bot.1 hf_inj) _
end

lemma submodule.exists_is_compl (p : submodule K V) : ∃ q : submodule K V, is_compl p q :=
let ⟨f, hf⟩ := p.subtype.exists_left_inverse_of_injective p.ker_subtype in
⟨f.ker, linear_map.is_compl_of_proj $ linear_map.ext_iff.1 hf⟩

instance module.submodule.is_complemented : is_complemented (submodule K V) :=
⟨submodule.exists_is_compl⟩

lemma linear_map.exists_right_inverse_of_surjective (f : V →ₗ[K] V')
  (hf_surj : f.range = ⊤) : ∃g:V' →ₗ[K] V, f.comp g = linear_map.id :=
begin
  let C := basis.of_vector_space_index K V',
  let hC := basis.of_vector_space K V',
  haveI : inhabited V := ⟨0⟩,
  use hC.constr K (C.restrict (inv_fun f)),
  refine hC.ext (λ c, _),
  rw [linear_map.comp_apply, hC.constr_basis],
  simp [right_inverse_inv_fun (linear_map.range_eq_top.1 hf_surj) c]
end

/-- Any linear map `f : p →ₗ[K] V'` defined on a subspace `p` can be extended to the whole
space. -/
lemma linear_map.exists_extend {p : submodule K V} (f : p →ₗ[K] V') :
  ∃ g : V →ₗ[K] V', g.comp p.subtype = f :=
let ⟨g, hg⟩ := p.subtype.exists_left_inverse_of_injective p.ker_subtype in
⟨f.comp g, by rw [linear_map.comp_assoc, hg, f.comp_id]⟩

open submodule linear_map

/-- If `p < ⊤` is a subspace of a vector space `V`, then there exists a nonzero linear map
`f : V →ₗ[K] K` such that `p ≤ ker f`. -/
lemma submodule.exists_le_ker_of_lt_top (p : submodule K V) (hp : p < ⊤) :
  ∃ f ≠ (0 : V →ₗ[K] K), p ≤ ker f :=
begin
  rcases set_like.exists_of_lt hp with ⟨v, -, hpv⟩, clear hp,
  rcases (linear_pmap.sup_span_singleton ⟨p, 0⟩ v (1 : K) hpv).to_fun.exists_extend with ⟨f, hf⟩,
  refine ⟨f, _, _⟩,
  { rintro rfl, rw [linear_map.zero_comp] at hf,
    have := linear_pmap.sup_span_singleton_apply_mk ⟨p, 0⟩ v (1 : K) hpv 0 p.zero_mem 1,
    simpa using (linear_map.congr_fun hf _).trans this },
  { refine λ x hx, mem_ker.2 _,
    have := linear_pmap.sup_span_singleton_apply_mk ⟨p, 0⟩ v (1 : K) hpv x hx 0,
    simpa using (linear_map.congr_fun hf _).trans this }
end

theorem quotient_prod_linear_equiv (p : submodule K V) :
  nonempty (((V ⧸ p) × p) ≃ₗ[K] V) :=
let ⟨q, hq⟩ := p.exists_is_compl in nonempty.intro $
((quotient_equiv_of_is_compl p q hq).prod (linear_equiv.refl _ _)).trans
  (prod_equiv_of_is_compl q p hq.symm)

end field


import Mathlib.Data.Fintype.Card
import Mathlib.Data.Int.ModEq
import Mathlib.Data.Nat.Basic
import Mathlib.Data.Nat.ModEq
import Mathlib.Data.Nat.Parity
import Mathlib.Data.Nat.Digits
import Mathlib.Data.Nat.GCD.Basic
import Mathlib.Algebra.BigOperators.Ring

/-!
(From Mathematical Puzzles: A Connoisseur's Collection by Peter Winkler.)

Let n be a natural number. Prove that

  (a) n has a (nonzero) multiple whose representation in base 10 contains
      only zeroes and ones; and
  (b) 2^n has a multiple whose representation contains only ones and twos.
-/

namespace ZerosOnesAndTwos

open BigOperators

def ones (b : ℕ) : ℕ → ℕ
| k => ∑i in Finset.range k, b^i

def map_mod (n : ℕ) (hn: 0 < n) (f : ℕ → ℕ) : ℕ → Fin n
| m => ⟨f m % n, Nat.mod_lt (f m) hn⟩

lemma pigeonhole (n : ℕ) (f : ℕ → Fin n) :
  ∃ a b : ℕ, a < b ∧ f a = f b :=
let ⟨a, b, hne, hfe⟩ := Finite.exists_ne_map_eq_of_infinite f
hne.lt_or_lt.elim (λ h ↦ ⟨a, b, h, hfe⟩) (λ h ↦ ⟨b, a, h, hfe.symm⟩)

def is_zero_or_one : ℕ → Prop
| 0 => True
| 1 => True
| _ => False

def all_zero_or_one (l : List ℕ) : Prop := ∀ e ∈ l, is_zero_or_one e

lemma digits_lemma
    (base : ℕ)
    (h2 : 2 ≤ base)
    (n : ℕ)
    (hn : 0 < n)
    : (Nat.digits base (base * n)) = 0 :: (Nat.digits base n) := by
  have := Nat.digits_add base h2 0 n (Nat.lt_of_succ_lt (Nat.succ_le_iff.mp h2))
                              (Or.inr (ne_of_gt hn))
  rwa [zero_add (base * n)] at this

lemma times_base_still_all_zero_or_one
    (base : ℕ)
    (h2 : 2 ≤ base)
    (n : ℕ)
    (hn : all_zero_or_one (Nat.digits base n))
    : all_zero_or_one (Nat.digits base (base * n)) := by
  cases' (Nat.eq_zero_or_pos n) with hz hp
  · rw [hz]
    simp [mul_zero, Nat.digits_zero, all_zero_or_one]
  · rw [digits_lemma base h2 n hp]
    simpa[is_zero_or_one, all_zero_or_one]

lemma base_pow_still_all_zero_or_one
    (base : ℕ)
    (h2 : 2 ≤ base)
    (k n : ℕ)
    (hn : all_zero_or_one (Nat.digits base n))
    : all_zero_or_one (Nat.digits base ((base ^ k) * n)) := by
  induction' k with pk hpk
  · simpa
  · have := times_base_still_all_zero_or_one base h2 _ hpk
    rwa [←Nat.add_one pk, pow_succ' base pk, mul_comm (base^pk) base, mul_assoc]

lemma times_base_plus_one_still_all_zero_or_one
    (base : ℕ)
    (h2 : 2 ≤ base)
    (n : ℕ)
    (hazoo : all_zero_or_one (Nat.digits base n))
    : all_zero_or_one (Nat.digits base (1 + base * n)) := by
  rw [Nat.digits_add base h2 1 n (Nat.succ_le_iff.mp h2) (Or.inl Nat.one_ne_zero)]
  simpa[all_zero_or_one, is_zero_or_one]

lemma lemma_0 (k b : ℕ) (h2 : 2 ≤ b) :
    all_zero_or_one (b.digits (∑ i in Finset.range k, b^i)) := by
  induction' k with pk hpk
  · simp[all_zero_or_one]
  · have hh := calc
          ∑ i : ℕ in Finset.range pk.succ, b ^ i
        = ∑ i : ℕ in Finset.range pk, b ^ i.succ + b ^ 0 :=
               Finset.sum_range_succ' (λ (i : ℕ) ↦ b ^ i) pk
      _ = b ^ 0 + ∑ i in Finset.range pk, b ^ i.succ := add_comm _ _
      _ = 1 + ∑ i in Finset.range pk, b ^ i.succ := by rw [pow_zero]
      _ = 1 + ∑ i in Finset.range pk, b * b ^ i :=
          by {simp; exact Finset.sum_congr rfl (λx _ ↦ pow_succ _ _)}
      _ =  1 + b * ∑ i in Finset.range pk, b ^ i := by simp [Finset.mul_sum]
    have := times_base_plus_one_still_all_zero_or_one
               b h2
               (∑ i in Finset.range pk, b ^ i) hpk
    rwa [hh]

lemma lemma_1 (k b m: ℕ) (h2 : 2 ≤ b) :
    all_zero_or_one (b.digits (∑i in Finset.range k, b^(i + m))) := by
  have h := calc
          (∑ i in Finset.range k, b ^ (i + m))
        = (∑ i in Finset.range k, b ^ i * b ^ m) :=
             by { refine Finset.sum_congr rfl ?_; intros x _; exact pow_add b x m }
      _ = (∑ i in Finset.range k, b ^ m * b ^ i) :=
             by { refine Finset.sum_congr rfl ?_; intros x _;
                  exact mul_comm (b ^ x) (b ^ m) }
      _ = b^m * (∑ i in Finset.range k, b ^ i) := Finset.mul_sum.symm

  have := base_pow_still_all_zero_or_one b h2 m
                       (∑ i in Finset.range k, b ^ i)
                       (lemma_0 k b h2)
  rwa [h]

lemma lemma_2'''
    (c d : ℕ)
    (f: ℕ → ℕ) :
    (∑ i in Finset.range c, f (i + d)) + (∑ i in Finset.range d, f i)  =
     ∑ i in Finset.range (c+d), f i := by
  induction' c with pc hpc
  · simp
  · have h1 : ∑ i in Finset.range pc.succ, f (i + d) =
              ∑ i in Finset.range pc, f (i + d) + f (pc + d) :=
         Finset.sum_range_succ (λ (x : ℕ) ↦ f (x + d)) pc

    have h2 := calc
          ∑ i in Finset.range (pc.succ + d), f i
        = ∑ i in Finset.range (pc + d).succ, f i        := by rw [Nat.succ_add]
      _ = ∑ i in Finset.range (pc + d), f i + f (pc + d) := Finset.sum_range_succ f _

    linarith

lemma lemma_2''
    (a b : ℕ)
    (hlt : a < b)
    (f: ℕ → ℕ) :
    (∑ i in Finset.range (b - a), f (i + a)) + (∑ i in Finset.range a, f i)  =
       ∑ i in Finset.range b, f i := by
  have := lemma_2''' (b - a) a f
  rwa [Nat.sub_add_cancel (le_of_lt hlt)] at this

lemma lemma_2'
    (a b : ℕ)
    (hlt : a < b) :
    (∑ i in Finset.range (b - a), 10^(i + a)) + (∑ i in Finset.range a, 10^i) =
       ∑ i in Finset.range b, 10^i :=
  lemma_2'' a b hlt (λi ↦ 10^i)

lemma lemma_2_aux (n a b c: ℕ) (hc : a + b = c) (hab: a % n = c % n) : b % n = 0 := by
  rw [show a = a + 0 by rfl, ←hc] at hab
  exact (Nat.ModEq.add_left_cancel' _ hab).symm

lemma lemma_2
    (n : ℕ)
    (a b : ℕ)
    (hlt : a < b)
    (hab : (∑ i in Finset.range a, 10^i) % n = (∑ i in Finset.range b, 10^i) % n) :
    (∑ i in Finset.range (b - a), 10^(i + a)) % n = 0 := by
  have h1 := lemma_2' a b hlt
  refine' lemma_2_aux n _ (∑ i in Finset.range (b - a), 10^(i + a)) _ _ hab
  rwa [add_comm]

lemma lemma_3 {a n : ℕ} (ha : 0 < a) (hm : a % n = 0) : (∃ k : ℕ+, a = n * k) := by
  obtain ⟨k', hk'⟩ := exists_eq_mul_right_of_dvd (Nat.dvd_of_mod_eq_zero hm)
  have hkp : 0 < k' := lt_of_mul_lt_mul_left' (hk' ▸ ha)
  exact ⟨⟨k', hkp⟩, hk'⟩

lemma lemma_4 {k : ℕ} (hk : 0 < k) (f: ℕ → ℕ) (hf0 : 0 < f 0) :
      0 < ∑ i in Finset.range k, f i := by
  cases' k with k
  · exact (Nat.lt_asymm hk hk).elim
  · calc 0 < f 0                                     := hf0
         _ ≤ (∑ i in Finset.range k, f i.succ) + f 0 := Nat.le_add_left _ _
         _ = (∑ i in Finset.range k.succ, f i)       := (Finset.sum_range_succ' _ _).symm

lemma two_le_ten : (2 : ℕ) ≤ 10 := tsub_eq_zero_iff_le.mp rfl

--
-- Prove that n has a positive multiple whose representation contains only zeroes and ones.
--
theorem zeroes_and_ones (n : ℕ) : ∃ k : ℕ+, all_zero_or_one (Nat.digits 10 (n * k)) := by
  obtain (hn0 : n = 0 ) | (hn : n > 0) := Nat.eq_zero_or_pos n
  · use 1; rw [hn0]; simp[all_zero_or_one]
  obtain ⟨a, b, hlt, hab⟩ := pigeonhole n (λm ↦ map_mod n hn (ones 10) m)
  have h' : (∑ i in Finset.range (b - a), 10^(i + a)) % n = 0 :=
    lemma_2 n a b hlt (Fin.mk.inj hab)
  have ha : 0 < ∑ i in Finset.range (b - a), 10^(i + a) := by
    have hm : 0 < b - a := Nat.sub_pos_of_lt hlt
    have hp : 0 < 10 ^ (0 + a) := pow_pos (Nat.succ_pos _) _
    exact lemma_4 hm (λ (i : ℕ) ↦ 10 ^ (i + a)) hp

  obtain ⟨k, hk⟩ := lemma_3 ha h'
  use k
  rw [←hk]
  exact lemma_1 (b - a) 10 a two_le_ten

def is_one_or_two : ℕ → Prop
| 1 => True
| 2 => True
| _ => False

def all_one_or_two (l : List ℕ) : Prop := ∀ e ∈ l, is_one_or_two e

def prepend_one (n : ℕ) := 10 ^ (List.length (Nat.digits 10 n)) + n

lemma prepend_one_pos (n: ℕ) : 0 < prepend_one n := by
  cases' n
  · norm_num
  · rw[prepend_one]; norm_num

lemma digits_len' (n : ℕ) (hn : 0 < n) :
      List.length (Nat.digits 10 n) = 1 + List.length (Nat.digits 10 (n / 10)) := by
  rw[Nat.digits_def' two_le_ten hn, List.length]
  exact add_comm _ _

lemma prepend_one_div (n : ℕ) (hn : 0 < n) : prepend_one n / 10 = prepend_one (n / 10) := by
  rw[prepend_one, prepend_one]
  cases' n with n
  · exact (Nat.lt_asymm hn hn).elim
  · rw[digits_len' n.succ (Nat.succ_pos n)]
    rw[pow_add, pow_one, add_comm]
    rw [Nat.add_mul_div_left _ _ (Nat.succ_pos 9)]
    exact add_comm _ _

lemma prepend_one_mod (n : ℕ) (hn : 0 < n) : prepend_one n % 10 = n % 10 := by
  rw[prepend_one]
  rw[Nat.digits_len _ _ two_le_ten (ne_of_gt hn)]
  rw[pow_add, pow_one]
  exact Nat.mul_add_mod _ 10 n

lemma prepend_one_eq_append (n : ℕ) :
    Nat.digits 10 (prepend_one n) = (Nat.digits 10 n) ++ [1] := by
  induction' n using Nat.strong_induction_on with n' ih
  cases' n' with n'
  · simp[prepend_one]
  · rw[Nat.digits_def' two_le_ten (prepend_one_pos _)]
    rw[prepend_one_div _ (Nat.succ_pos n')]
    have hns : n'.succ / 10 < n'.succ := Nat.div_lt_self' n' 8
    rw[ih _ hns]
    rw[←List.cons_append]
    rw[prepend_one_mod _ (Nat.succ_pos _), Nat.digits_def' two_le_ten (Nat.succ_pos n')]

lemma prepend_one_all_one_or_two (n : ℕ) (hn : all_one_or_two (Nat.digits 10 n)) :
    all_one_or_two (Nat.digits 10 (prepend_one n)) := by
 rw[prepend_one_eq_append, all_one_or_two]
 rw[all_one_or_two] at hn
 intros e he
 rw[List.mem_append] at he
 cases' he with he he
 · exact hn e he
 · rw[List.mem_singleton] at he
   simp only [he, is_one_or_two]

def prepend_two (n : ℕ) := 2 * (10 ^ (List.length (Nat.digits 10 n))) + n

lemma prepend_two_pos (n: ℕ) : 0 < prepend_two n := by
  cases n
  · norm_num
  · rw[prepend_two]; norm_num

lemma prepend_two_div (n : ℕ) (hn : 0 < n) : prepend_two n / 10 = prepend_two (n / 10) := by
  rw[prepend_two, prepend_two]
  cases' n with n
  · cases Nat.lt_asymm hn hn
  · rw[digits_len' n.succ (Nat.succ_pos n)]
    rw[pow_add, pow_one, add_comm]
    rw[←mul_left_comm]
    rw [Nat.add_mul_div_left _ _ (Nat.succ_pos 9)]
    exact add_comm _ _

lemma prepend_two_mod (n : ℕ) (hn : 0 < n) : prepend_two n % 10 = n % 10 := by
  rw[prepend_two]
  rw[Nat.digits_len _ _ two_le_ten (ne_of_gt hn)]
  rw[pow_add, pow_one, ←mul_assoc]
  exact Nat.mul_add_mod _ 10 n

lemma prepend_two_eq_append (n : ℕ) :
    Nat.digits 10 (prepend_two n) = (Nat.digits 10 n) ++ [2] := by
  induction' n using Nat.strong_induction_on with n' ih
  cases' n' with n'
  · simp[prepend_two]
  · rw[Nat.digits_def' two_le_ten (prepend_two_pos _)]
    rw[prepend_two_div _ (Nat.succ_pos n')]
    have hns : n'.succ / 10 < n'.succ := Nat.div_lt_self' n' 8
    rw[ih _ hns]
    rw[←List.cons_append]
    rw[prepend_two_mod _ (Nat.succ_pos _), ←Nat.digits_def' two_le_ten (Nat.succ_pos n')]

lemma prepend_two_all_one_or_two (n : ℕ) (hn : all_one_or_two (Nat.digits 10 n)) :
    all_one_or_two (Nat.digits 10 (prepend_two n)) := by
  rw[prepend_two_eq_append, all_one_or_two]
  rw[all_one_or_two] at hn
  intros e he
  rw[List.mem_append] at he
  cases' he with he he
  · exact hn e he
  · rw[List.mem_singleton] at he
    simp only [he, is_one_or_two]

lemma factor_ten_pow (k : ℕ) : 10 ^ k = (2^k) * (5^k) := by
  induction' k with k' ih
  · simp only [pow_zero, mul_one]
  · rw[pow_succ, pow_succ, pow_succ, ih]; ring

lemma even_5_pow_plus_one (n : ℕ) : 2 ∣ 5 ^ n + 1 := by
  apply Nat.dvd_of_mod_eq_zero
  rw[Nat.add_mod, Nat.pow_mod]
  norm_num

lemma ones_and_twos_aux (n : ℕ) :
  ∃ k : ℕ+, (List.length (Nat.digits 10 (2^n.succ * k)) = n.succ) ∧
             all_one_or_two (Nat.digits 10 (2^n.succ * k)) := by
  induction' n with pn hpn
  · use 1; simp[all_one_or_two]; norm_cast
  obtain ⟨pk, hpk1, hpk2⟩ := hpn

  /-
    Adding a 1 or a 2 to the front of 2^pn.succ * pk increments it by 2^pn.succ * 5^pn.succ or
    by 2^{pn.succ+1} * 5^pn.succ, in each case preserving divisibility by 2^pn.succ. Since the
    two choices differ by 2^pn.succ * 5^pn.succ, one of them must actually achieve
    divisibility by 2^{pn.succ+1}.
  -/

  obtain ⟨t, ht : ↑pk = t + t⟩ | ⟨t, ht : ↑pk = 2 * t + 1⟩ := (pk : ℕ).even_or_odd
  · -- Even case. Prepend 2.
    rw[← two_mul] at ht
    have hd : 2 ^ pn.succ.succ ∣ prepend_two (2 ^ pn.succ * ↑pk) := by
      rw [prepend_two, factor_ten_pow, hpk1, ht]
      have hr : 2 * (2 ^ pn.succ * 5 ^ pn.succ) + 2 ^ pn.succ * (2 * t) =
                   2 ^ pn.succ.succ * (5 ^ pn.succ + t) := by
        repeat rw[pow_succ]; ring_nf
      rw[hr]
      exact Dvd.intro (5 ^ Nat.succ pn + t) rfl
    obtain ⟨k', hk'⟩ := hd
    have hkp': 0 < k' := by
      cases' k'
      · exfalso
        have hzz := prepend_two_pos (2 ^ pn.succ * ↑pk)
        rw[Nat.mul_zero] at hk'
        linarith
      · exact Nat.succ_pos _
    use ⟨k', hkp'⟩
    rw[PNat.mk_coe, ←hk']
    constructor
    · rw[prepend_two_eq_append]
      rw [List.length_append, List.length_singleton, hpk1]
    · exact prepend_two_all_one_or_two _ hpk2
  · -- Odd case. Prepend 1.
    have hd : 2 ^ pn.succ.succ ∣ prepend_one (2 ^ pn.succ * ↑pk) := by
      rw[prepend_one, hpk1, factor_ten_pow, ht]
      have h5 : 2 ^ pn.succ * 5 ^ pn.succ + 2 ^ pn.succ * (2 * t + 1) =
            2^pn.succ * (2 * (2 * 5 ^ pn + t) + (5^pn + 1)) := by
        repeat rw[pow_succ]; ring_nf
      rw[h5]
      obtain ⟨k5,hk5⟩:= even_5_pow_plus_one pn
      rw[hk5]
      have h5' : 2 ^ pn.succ * (2 * (2 * 5 ^ pn + t) + 2 * k5) =
           2^pn.succ.succ * (2 * 5 ^ pn + t + k5) := by
        repeat rw[pow_succ]; ring_nf
      rw[h5']
      exact Dvd.intro (2 * 5 ^ pn + t + k5) rfl
    obtain ⟨k', hk'⟩ := hd
    have hkp': 0 < k' := by
      cases k'
      · exfalso
        have hzz := prepend_one_pos (2 ^ pn.succ * ↑pk)
        rw[Nat.mul_zero] at hk'
        linarith
      · exact Nat.succ_pos _
    use ⟨k', hkp'⟩
    rw[PNat.mk_coe,←hk']
    constructor
    · rw [prepend_one_eq_append]
      rw [List.length_append, List.length_singleton, hpk1]
    · exact prepend_one_all_one_or_two _ hpk2

--
-- Prove that 2^n has a positive multiple whose representation contains only ones and twos.
--
theorem ones_and_twos (n : ℕ) : ∃ k : ℕ+, all_one_or_two (Nat.digits 10 (2^n * k)) := by
  cases' n with n
  · use 1; simp[all_one_or_two]; norm_cast
  · obtain ⟨k, _, hk2⟩ := ones_and_twos_aux n
    exact ⟨k, hk2⟩


/-
Copyright © 2021 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Shing Tak Lam
-/

import topology.algebra.order.proj_Icc
import topology.continuous_function.basic

/-!
# Bundled continuous maps into orders, with order-compatible topology

-/

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

namespace continuous_map

section
variables [linear_ordered_add_comm_group β] [order_topology β]

/-- The pointwise absolute value of a continuous function as a continuous function. -/
def abs (f : C(α, β)) : C(α, β) :=
{ to_fun := λ x, |f x|, }

@[priority 100] -- see Note [lower instance priority]
instance : has_abs C(α, β) := ⟨λf, abs f⟩

@[simp] lemma abs_apply (f : C(α, β)) (x : α) : |f| x = |f x| :=
rfl

end

/-!
We now set up the partial order and lattice structure (given by pointwise min and max)
on continuous functions.
-/
section lattice

instance partial_order [partial_order β] :
  partial_order C(α, β) :=
partial_order.lift (λ f, f.to_fun) (by tidy)

lemma le_def [partial_order β] {f g : C(α, β)} : f ≤ g ↔ ∀ a, f a ≤ g a :=
pi.le_def

lemma lt_def [partial_order β] {f g : C(α, β)} :
  f < g ↔ (∀ a, f a ≤ g a) ∧ (∃ a, f a < g a) :=
pi.lt_def

instance has_sup [linear_order β] [order_closed_topology β] : has_sup C(α, β) :=
{ sup := λ f g, { to_fun := λ a, max (f a) (g a), } }

@[simp, norm_cast] lemma sup_coe [linear_order β] [order_closed_topology β] (f g : C(α, β)) :
  ((f ⊔ g : C(α, β)) : α → β) = (f ⊔ g : α → β) :=
rfl

@[simp] lemma sup_apply [linear_order β] [order_closed_topology β] (f g : C(α, β)) (a : α) :
  (f ⊔ g) a = max (f a) (g a) :=
rfl

instance [linear_order β] [order_closed_topology β] : semilattice_sup C(α, β) :=
{ le_sup_left := λ f g, le_def.mpr (by simp [le_refl]),
  le_sup_right := λ f g, le_def.mpr (by simp [le_refl]),
  sup_le := λ f₁ f₂ g w₁ w₂, le_def.mpr (λ a, by simp [le_def.mp w₁ a, le_def.mp w₂ a]),
  ..continuous_map.partial_order,
  ..continuous_map.has_sup, }

instance has_inf [linear_order β] [order_closed_topology β] : has_inf C(α, β) :=
{ inf := λ f g, { to_fun := λ a, min (f a) (g a), } }

@[simp, norm_cast] lemma inf_coe [linear_order β] [order_closed_topology β] (f g : C(α, β)) :
  ((f ⊓ g : C(α, β)) : α → β) = (f ⊓ g : α → β) :=
rfl

@[simp] lemma inf_apply [linear_order β] [order_closed_topology β] (f g : C(α, β)) (a : α) :
  (f ⊓ g) a = min (f a) (g a) :=
rfl

instance [linear_order β] [order_closed_topology β] : semilattice_inf C(α, β) :=
{ inf_le_left := λ f g, le_def.mpr (by simp [le_refl]),
  inf_le_right := λ f g, le_def.mpr (by simp [le_refl]),
  le_inf := λ f₁ f₂ g w₁ w₂, le_def.mpr (λ a, by simp [le_def.mp w₁ a, le_def.mp w₂ a]),
  ..continuous_map.partial_order,
  ..continuous_map.has_inf, }

instance [linear_order β] [order_closed_topology β] : lattice C(α, β) :=
{ ..continuous_map.semilattice_inf,
  ..continuous_map.semilattice_sup }

-- TODO transfer this lattice structure to `bounded_continuous_function`

section sup'
variables [linear_order γ] [order_closed_topology γ]

lemma sup'_apply {ι : Type*} {s : finset ι} (H : s.nonempty) (f : ι → C(β, γ)) (b : β) :
  s.sup' H f b = s.sup' H (λ a, f a b) :=
finset.comp_sup'_eq_sup'_comp H (λ f : C(β, γ), f b) (λ i j, rfl)

@[simp, norm_cast]
lemma sup'_coe {ι : Type*} {s : finset ι} (H : s.nonempty) (f : ι → C(β, γ)) :
  ((s.sup' H f : C(β, γ)) : ι → β) = s.sup' H (λ a, (f a : β → γ)) :=
by { ext, simp [sup'_apply], }

end sup'

section inf'
variables [linear_order γ] [order_closed_topology γ]

lemma inf'_apply {ι : Type*} {s : finset ι} (H : s.nonempty) (f : ι → C(β, γ)) (b : β) :
  s.inf' H f b = s.inf' H (λ a, f a b) :=
@sup'_apply _ (order_dual γ) _ _ _ _ _ _ H f b

@[simp, norm_cast]
lemma inf'_coe {ι : Type*} {s : finset ι} (H : s.nonempty) (f : ι → C(β, γ)) :
  ((s.inf' H f : C(β, γ)) : ι → β) = s.inf' H (λ a, (f a : β → γ)) :=
@sup'_coe _ (order_dual γ) _ _ _ _ _ _ H f

end inf'

end lattice

section extend

variables [linear_order α] [order_topology α] {a b : α} (h : a ≤ b)

/--
Extend a continuous function `f : C(set.Icc a b, β)` to a function `f : C(α, β)`.
-/
def Icc_extend (f : C(set.Icc a b, β)) : C(α, β) := ⟨set.Icc_extend h f⟩

@[simp] lemma coe_Icc_extend (f : C(set.Icc a b, β)) :
  ((Icc_extend h f : C(α, β)) : α → β) = set.Icc_extend h f := rfl

end extend

end continuous_map


/-
Copyright (c) 2018 Patrick Massot. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Patrick Massot, Johannes Hölzl
-/
import topology.uniform_space.uniform_embedding
import topology.uniform_space.complete_separated
import topology.algebra.group
import tactic.abel

/-!
# Uniform structure on topological groups

* `topological_add_group.to_uniform_space` and `topological_add_group_is_uniform` can be used to
  construct a canonical uniformity for a topological add group.

* extension of ℤ-bilinear maps to complete groups (useful for ring completions)

* `add_group_with_zero_nhd`: construct the topological structure from a group with a neighbourhood
  around zero. Then with `topological_add_group.to_uniform_space` one can derive a `uniform_space`.
-/

noncomputable theory
open_locale classical uniformity topological_space filter

section uniform_add_group
open filter set

variables {α : Type*} {β : Type*}

/-- A uniform (additive) group is a group in which the addition and negation are
  uniformly continuous. -/
class uniform_add_group (α : Type*) [uniform_space α] [add_group α] : Prop :=
(uniform_continuous_sub : uniform_continuous (λp:α×α, p.1 - p.2))

theorem uniform_add_group.mk' {α} [uniform_space α] [add_group α]
  (h₁ : uniform_continuous (λp:α×α, p.1 + p.2))
  (h₂ : uniform_continuous (λp:α, -p)) : uniform_add_group α :=
⟨by simpa only [sub_eq_add_neg] using
  h₁.comp (uniform_continuous_fst.prod_mk (h₂.comp uniform_continuous_snd))⟩

variables [uniform_space α] [add_group α] [uniform_add_group α]

lemma uniform_continuous_sub : uniform_continuous (λp:α×α, p.1 - p.2) :=
uniform_add_group.uniform_continuous_sub

lemma uniform_continuous.sub [uniform_space β] {f : β → α} {g : β → α}
  (hf : uniform_continuous f) (hg : uniform_continuous g) : uniform_continuous (λx, f x - g x) :=
uniform_continuous_sub.comp (hf.prod_mk hg)

lemma uniform_continuous.neg [uniform_space β] {f : β → α}
  (hf : uniform_continuous f) : uniform_continuous (λx, - f x) :=
have uniform_continuous (λx, 0 - f x),
  from uniform_continuous_const.sub hf,
by simp * at *

lemma uniform_continuous_neg : uniform_continuous (λx:α, - x) :=
uniform_continuous_id.neg

lemma uniform_continuous.add [uniform_space β] {f : β → α} {g : β → α}
  (hf : uniform_continuous f) (hg : uniform_continuous g) : uniform_continuous (λx, f x + g x) :=
have uniform_continuous (λx, f x - - g x), from hf.sub hg.neg,
by simp [*, sub_eq_add_neg] at *

lemma uniform_continuous_add : uniform_continuous (λp:α×α, p.1 + p.2) :=
uniform_continuous_fst.add uniform_continuous_snd

@[priority 10]
instance uniform_add_group.to_topological_add_group : topological_add_group α :=
{ continuous_add := uniform_continuous_add.continuous,
  continuous_neg := uniform_continuous_neg.continuous }

instance [uniform_space β] [add_group β] [uniform_add_group β] : uniform_add_group (α × β) :=
⟨((uniform_continuous_fst.comp uniform_continuous_fst).sub
  (uniform_continuous_fst.comp uniform_continuous_snd)).prod_mk
 ((uniform_continuous_snd.comp uniform_continuous_fst).sub
  (uniform_continuous_snd.comp uniform_continuous_snd))⟩

lemma uniformity_translate (a : α) : (𝓤 α).map (λx:α×α, (x.1 + a, x.2 + a)) = 𝓤 α :=
le_antisymm
  (uniform_continuous_id.add uniform_continuous_const)
  (calc 𝓤 α =
    ((𝓤 α).map (λx:α×α, (x.1 + -a, x.2 + -a))).map (λx:α×α, (x.1 + a, x.2 + a)) :
      by simp [filter.map_map, (∘)]; exact filter.map_id.symm
    ... ≤ (𝓤 α).map (λx:α×α, (x.1 + a, x.2 + a)) :
      filter.map_mono (uniform_continuous_id.add uniform_continuous_const))

lemma uniform_embedding_translate (a : α) : uniform_embedding (λx:α, x + a) :=
{ comap_uniformity := begin
    rw [← uniformity_translate a, comap_map] {occs := occurrences.pos [1]},
    rintros ⟨p₁, p₂⟩ ⟨q₁, q₂⟩,
    simp [prod.eq_iff_fst_eq_snd_eq] {contextual := tt}
  end,
  inj := add_left_injective a }

section
variables (α)
lemma uniformity_eq_comap_nhds_zero : 𝓤 α = comap (λx:α×α, x.2 - x.1) (𝓝 (0:α)) :=
begin
  rw [nhds_eq_comap_uniformity, filter.comap_comap],
  refine le_antisymm (filter.map_le_iff_le_comap.1 _) _,
  { assume s hs,
    rcases mem_uniformity_of_uniform_continuous_invariant uniform_continuous_sub hs
      with ⟨t, ht, hts⟩,
    refine mem_map.2 (mem_sets_of_superset ht _),
    rintros ⟨a, b⟩,
    simpa [subset_def] using hts a b a },
  { assume s hs,
    rcases mem_uniformity_of_uniform_continuous_invariant uniform_continuous_add hs
      with ⟨t, ht, hts⟩,
    refine ⟨_, ht, _⟩,
    rintros ⟨a, b⟩, simpa [subset_def] using hts 0 (b - a) a }
end
end

lemma group_separation_rel (x y : α) : (x, y) ∈ separation_rel α ↔ x - y ∈ closure ({0} : set α) :=
have embedding (λa, a + (y - x)), from (uniform_embedding_translate (y - x)).embedding,
show (x, y) ∈ ⋂₀ (𝓤 α).sets ↔ x - y ∈ closure ({0} : set α),
begin
  rw [this.closure_eq_preimage_closure_image, uniformity_eq_comap_nhds_zero α, sInter_comap_sets],
  simp [mem_closure_iff_nhds, inter_singleton_nonempty, sub_eq_add_neg, add_assoc]
end

lemma uniform_continuous_of_tendsto_zero [uniform_space β] [add_group β] [uniform_add_group β]
  {f : α → β} [is_add_group_hom f] (h : tendsto f (𝓝 0) (𝓝 0)) :
  uniform_continuous f :=
begin
  have : ((λx:β×β, x.2 - x.1) ∘ (λx:α×α, (f x.1, f x.2))) = (λx:α×α, f (x.2 - x.1)),
  { simp only [is_add_group_hom.map_sub f] },
  rw [uniform_continuous, uniformity_eq_comap_nhds_zero α, uniformity_eq_comap_nhds_zero β,
    tendsto_comap_iff, this],
  exact tendsto.comp h tendsto_comap
end

lemma add_monoid_hom.uniform_continuous_of_continuous_at_zero
  [uniform_space β] [add_group β] [uniform_add_group β]
  (f : α →+ β) (hf : continuous_at f 0) :
  uniform_continuous f :=
uniform_continuous_of_tendsto_zero (by simpa using hf.tendsto)

lemma uniform_continuous_of_continuous [uniform_space β] [add_group β] [uniform_add_group β]
  {f : α → β} [is_add_group_hom f] (h : continuous f) :
  uniform_continuous f :=
uniform_continuous_of_tendsto_zero $
  suffices tendsto f (𝓝 0) (𝓝 (f 0)), by rwa [is_add_group_hom.map_zero f] at this,
  h.tendsto 0

end uniform_add_group

section topological_add_comm_group
universes u v w x
open filter

variables {G : Type u} [add_comm_group G] [topological_space G] [topological_add_group G]

variable (G)
/-- The right uniformity on a topological group. -/
def topological_add_group.to_uniform_space : uniform_space G :=
{ uniformity          := comap (λp:G×G, p.2 - p.1) (𝓝 0),
  refl                :=
    by refine map_le_iff_le_comap.1 (le_trans _ (pure_le_nhds 0));
      simp [set.subset_def] {contextual := tt},
  symm                :=
  begin
    suffices : tendsto ((λp, -p) ∘ (λp:G×G, p.2 - p.1)) (comap (λp:G×G, p.2 - p.1) (𝓝 0)) (𝓝 (-0)),
    { simpa [(∘), tendsto_comap_iff] },
    exact tendsto.comp (tendsto.neg tendsto_id) tendsto_comap
  end,
  comp                :=
  begin
    intros D H,
    rw mem_lift'_sets,
    { rcases H with ⟨U, U_nhds, U_sub⟩,
      rcases exists_nhds_zero_half U_nhds with ⟨V, ⟨V_nhds, V_sum⟩⟩,
      existsi ((λp:G×G, p.2 - p.1) ⁻¹' V),
      have H : (λp:G×G, p.2 - p.1) ⁻¹' V ∈ comap (λp:G×G, p.2 - p.1) (𝓝 (0 : G)),
        by existsi [V, V_nhds] ; refl,
      existsi H,
      have comp_rel_sub :
        comp_rel ((λp:G×G, p.2 - p.1) ⁻¹' V) ((λp, p.2 - p.1) ⁻¹' V) ⊆ (λp:G×G, p.2 - p.1) ⁻¹' U,
      begin
        intros p p_comp_rel,
        rcases p_comp_rel with ⟨z, ⟨Hz1, Hz2⟩⟩,
        simpa [sub_eq_add_neg, add_comm, add_left_comm] using V_sum _ Hz1 _ Hz2
      end,
      exact set.subset.trans comp_rel_sub U_sub },
    { exact monotone_comp_rel monotone_id monotone_id }
  end,
  is_open_uniformity  :=
  begin
    intro S,
    let S' := λ x, {p : G × G | p.1 = x → p.2 ∈ S},
    show is_open S ↔ ∀ (x : G), x ∈ S → S' x ∈ comap (λp:G×G, p.2 - p.1) (𝓝 (0 : G)),
    rw [is_open_iff_mem_nhds],
    refine forall_congr (assume a, forall_congr (assume ha, _)),
    rw [← nhds_translation a, mem_comap_sets, mem_comap_sets],
    refine exists_congr (assume t, exists_congr (assume ht, _)),
    show (λ (y : G), y - a) ⁻¹' t ⊆ S ↔ (λ (p : G × G), p.snd - p.fst) ⁻¹' t ⊆ S' a,
    split,
    { rintros h ⟨x, y⟩ hx rfl, exact h hx },
    { rintros h x hx, exact @h (a, x) hx rfl }
  end }

section
local attribute [instance] topological_add_group.to_uniform_space

lemma uniformity_eq_comap_nhds_zero' : 𝓤 G = comap (λp:G×G, p.2 - p.1) (𝓝 (0 : G)) := rfl

variable {G}
lemma topological_add_group_is_uniform : uniform_add_group G :=
have tendsto
    ((λp:(G×G), p.1 - p.2) ∘ (λp:(G×G)×(G×G), (p.1.2 - p.1.1, p.2.2 - p.2.1)))
    (comap (λp:(G×G)×(G×G), (p.1.2 - p.1.1, p.2.2 - p.2.1)) ((𝓝 0).prod (𝓝 0)))
    (𝓝 (0 - 0)) :=
  (tendsto_fst.sub tendsto_snd).comp tendsto_comap,
begin
  constructor,
  rw [uniform_continuous, uniformity_prod_eq_prod, tendsto_map'_iff,
    uniformity_eq_comap_nhds_zero' G, tendsto_comap_iff, prod_comap_comap_eq],
  simpa [(∘), sub_eq_add_neg, add_comm, add_left_comm] using this
end
end

end topological_add_comm_group

namespace add_comm_group
section Z_bilin

variables {α : Type*} {β : Type*} {γ : Type*} {δ : Type*}
variables [add_comm_group α] [add_comm_group β] [add_comm_group γ]

/- TODO: when modules are changed to have more explicit base ring, then change replace `is_Z_bilin`
by using `is_bilinear_map ℤ` from `tensor_product`. -/
/-- `ℤ`-bilinearity for maps between additive commutative groups. -/
class is_Z_bilin (f : α × β → γ) : Prop :=
(add_left []  : ∀ a a' b, f (a + a', b) = f (a, b) + f (a', b))
(add_right [] : ∀ a b b', f (a, b + b') = f (a, b) + f (a, b'))

variables (f : α × β → γ) [is_Z_bilin f]

lemma is_Z_bilin.comp_hom {g : γ → δ} [add_comm_group δ] [is_add_group_hom g] :
  is_Z_bilin (g ∘ f) :=
by constructor; simp [(∘), is_Z_bilin.add_left f, is_Z_bilin.add_right f, is_add_hom.map_add g]

instance is_Z_bilin.comp_swap : is_Z_bilin (f ∘ prod.swap) :=
⟨λ a a' b, is_Z_bilin.add_right f b a a',
 λ a b b', is_Z_bilin.add_left f b b' a⟩

lemma is_Z_bilin.zero_left : ∀ b, f (0, b) = 0 :=
begin
  intro b,
  apply add_right_eq_self.1,
  rw [ ←is_Z_bilin.add_left f, zero_add]
end

lemma is_Z_bilin.zero_right : ∀ a, f (a, 0) = 0 :=
is_Z_bilin.zero_left (f ∘ prod.swap)

lemma is_Z_bilin.zero : f (0, 0) = 0 :=
is_Z_bilin.zero_left f 0

lemma is_Z_bilin.neg_left  : ∀ a b, f (-a, b) = -f (a, b) :=
begin
  intros a b,
  apply eq_of_sub_eq_zero,
  rw [sub_eq_add_neg, neg_neg, ←is_Z_bilin.add_left f, neg_add_self, is_Z_bilin.zero_left f]
end

lemma is_Z_bilin.neg_right  : ∀ a b, f (a, -b) = -f (a, b) :=
assume a b, is_Z_bilin.neg_left (f ∘ prod.swap) b a

lemma is_Z_bilin.sub_left : ∀ a a' b, f (a - a', b) = f (a, b) - f (a', b) :=
begin
  intros,
  simp [sub_eq_add_neg],
  rw [is_Z_bilin.add_left f, is_Z_bilin.neg_left f]
end

lemma is_Z_bilin.sub_right : ∀ a b b', f (a, b - b') = f (a, b) - f (a,b') :=
assume a b b', is_Z_bilin.sub_left (f ∘ prod.swap) b b' a
end Z_bilin
end add_comm_group

open add_comm_group filter set function

section
variables {α : Type*} {β : Type*} {γ : Type*} {δ : Type*}

-- α, β and G are abelian topological groups, G is a uniform space
variables [topological_space α] [add_comm_group α]
variables [topological_space β] [add_comm_group β]
variables {G : Type*} [uniform_space G] [add_comm_group G]

variables {ψ : α × β → G} (hψ : continuous ψ) [ψbilin : is_Z_bilin ψ]

include hψ ψbilin

lemma is_Z_bilin.tendsto_zero_left (x₁ : α) : tendsto ψ (𝓝 (x₁, 0)) (𝓝 0) :=
begin
  have := hψ.tendsto (x₁, 0),
  rwa [is_Z_bilin.zero_right ψ] at this
end

lemma is_Z_bilin.tendsto_zero_right (y₁ : β) : tendsto ψ (𝓝 (0, y₁)) (𝓝 0) :=
begin
  have := hψ.tendsto (0, y₁),
  rwa [is_Z_bilin.zero_left ψ] at this
end
end

section
variables {α : Type*} {β : Type*}
variables [topological_space α] [add_comm_group α] [topological_add_group α]

-- β is a dense subgroup of α, inclusion is denoted by e
variables [topological_space β] [add_comm_group β]
variables {e : β → α} [is_add_group_hom e] (de : dense_inducing e)
include de

lemma tendsto_sub_comap_self (x₀ : α) :
  tendsto (λt:β×β, t.2 - t.1) (comap (λp:β×β, (e p.1, e p.2)) $ 𝓝 (x₀, x₀)) (𝓝 0) :=
begin
  have comm : (λx:α×α, x.2-x.1) ∘ (λt:β×β, (e t.1, e t.2)) = e ∘ (λt:β×β, t.2 - t.1),
  { ext t,
    change e t.2 - e t.1 = e (t.2 - t.1),
    rwa ← is_add_group_hom.map_sub e t.2 t.1 },
  have lim : tendsto (λ x : α × α, x.2-x.1) (𝓝 (x₀, x₀)) (𝓝 (e 0)),
    { have := (continuous_sub.comp (@continuous_swap α α _ _)).tendsto (x₀, x₀),
      simpa [-sub_eq_add_neg, sub_self, eq.symm (is_add_group_hom.map_zero e)] using this },
  have := de.tendsto_comap_nhds_nhds lim comm,
  simp [-sub_eq_add_neg, this]
end
end

namespace dense_inducing
variables {α : Type*} {β : Type*} {γ : Type*} {δ : Type*}
variables {G : Type*}

-- β is a dense subgroup of α, inclusion is denoted by e
-- δ is a dense subgroup of γ, inclusion is denoted by f
variables [topological_space α] [add_comm_group α] [topological_add_group α]
variables [topological_space β] [add_comm_group β] [topological_add_group β]
variables [topological_space γ] [add_comm_group γ] [topological_add_group γ]
variables [topological_space δ] [add_comm_group δ] [topological_add_group δ]
variables [uniform_space G] [add_comm_group G] [uniform_add_group G] [separated_space G]
  [complete_space G]
variables {e : β → α} [is_add_group_hom e] (de : dense_inducing e)
variables {f : δ → γ} [is_add_group_hom f] (df : dense_inducing f)
variables {φ : β × δ → G} (hφ : continuous φ) [bilin : is_Z_bilin φ]

include de df hφ bilin

variables {W' : set G} (W'_nhd : W' ∈ 𝓝 (0 : G))
include W'_nhd

private lemma extend_Z_bilin_aux (x₀ : α) (y₁ : δ) :
  ∃ U₂ ∈ comap e (𝓝 x₀), ∀ x x' ∈ U₂, φ (x' - x, y₁) ∈ W' :=
begin
  let Nx := 𝓝 x₀,
  let ee := λ u : β × β, (e u.1, e u.2),

  have lim1 : tendsto (λ a : β × β, (a.2 - a.1, y₁)) (comap e Nx ×ᶠ comap e Nx) (𝓝 (0, y₁)),
  { have := tendsto.prod_mk (tendsto_sub_comap_self de x₀)
      (tendsto_const_nhds : tendsto (λ (p : β × β), y₁) (comap ee $ 𝓝 (x₀, x₀)) (𝓝 y₁)),
    rw [nhds_prod_eq, prod_comap_comap_eq, ←nhds_prod_eq],
    exact (this : _) },

  have lim := tendsto.comp (is_Z_bilin.tendsto_zero_right hφ y₁) lim1,
  rw tendsto_prod_self_iff at lim,
  exact lim W' W'_nhd,
end

private lemma extend_Z_bilin_key (x₀ : α) (y₀ : γ) :
  ∃ U ∈ comap e (𝓝 x₀), ∃ V ∈ comap f (𝓝 y₀),
    ∀ x x' ∈ U, ∀ y y' ∈ V, φ (x', y') - φ (x, y) ∈ W' :=
begin
  let Nx := 𝓝 x₀,
  let Ny := 𝓝 y₀,
  let dp := dense_inducing.prod de df,
  let ee := λ u : β × β, (e u.1, e u.2),
  let ff := λ u : δ × δ, (f u.1, f u.2),

  have lim_φ : filter.tendsto φ (𝓝 (0, 0)) (𝓝 0),
  { have := hφ.tendsto (0, 0),
    rwa [is_Z_bilin.zero φ] at this },

  have lim_φ_sub_sub : tendsto (λ (p : (β × β) × (δ × δ)), φ (p.1.2 - p.1.1, p.2.2 - p.2.1))
    ((comap ee $ 𝓝 (x₀, x₀)) ×ᶠ (comap ff $ 𝓝 (y₀, y₀))) (𝓝 0),
  { have lim_sub_sub :  tendsto (λ (p : (β × β) × δ × δ), (p.1.2 - p.1.1, p.2.2 - p.2.1))
      ((comap ee (𝓝 (x₀, x₀))) ×ᶠ (comap ff (𝓝 (y₀, y₀)))) (𝓝 0 ×ᶠ 𝓝 0),
    { have := filter.prod_mono (tendsto_sub_comap_self de x₀) (tendsto_sub_comap_self df y₀),
      rwa prod_map_map_eq at this },
    rw ← nhds_prod_eq at lim_sub_sub,
    exact tendsto.comp lim_φ lim_sub_sub },

  rcases exists_nhds_zero_quarter W'_nhd with ⟨W, W_nhd, W4⟩,

  have : ∃ U₁ ∈ comap e (𝓝 x₀), ∃ V₁ ∈ comap f (𝓝 y₀),
    ∀ x x' ∈ U₁, ∀ y y' ∈ V₁,  φ (x'-x, y'-y) ∈ W,
  { have := tendsto_prod_iff.1 lim_φ_sub_sub W W_nhd,
    repeat { rw [nhds_prod_eq, ←prod_comap_comap_eq] at this },
    rcases this with ⟨U, U_in, V, V_in, H⟩,
    rw [mem_prod_same_iff] at U_in V_in,
    rcases U_in with ⟨U₁, U₁_in, HU₁⟩,
    rcases V_in with ⟨V₁, V₁_in, HV₁⟩,
    existsi [U₁, U₁_in, V₁, V₁_in],
    intros x x' x_in x'_in y y' y_in y'_in,
    exact H _ _ (HU₁ (mk_mem_prod x_in x'_in)) (HV₁ (mk_mem_prod y_in y'_in)) },
  rcases this with ⟨U₁, U₁_nhd, V₁, V₁_nhd, H⟩,

  obtain ⟨x₁, x₁_in⟩ : U₁.nonempty :=
    ((de.comap_nhds_ne_bot _).nonempty_of_mem U₁_nhd),
  obtain ⟨y₁, y₁_in⟩ : V₁.nonempty :=
    ((df.comap_nhds_ne_bot _).nonempty_of_mem V₁_nhd),

  rcases (extend_Z_bilin_aux de df hφ W_nhd x₀ y₁) with ⟨U₂, U₂_nhd, HU⟩,
  rcases (extend_Z_bilin_aux df de (hφ.comp continuous_swap) W_nhd y₀ x₁) with ⟨V₂, V₂_nhd, HV⟩,

  existsi [U₁ ∩ U₂, inter_mem_sets U₁_nhd U₂_nhd,
            V₁ ∩ V₂, inter_mem_sets V₁_nhd V₂_nhd],

  rintros x x' ⟨xU₁, xU₂⟩ ⟨x'U₁, x'U₂⟩ y y' ⟨yV₁, yV₂⟩ ⟨y'V₁, y'V₂⟩,
  have key_formula : φ(x', y') - φ(x, y) =
    φ(x' - x, y₁) + φ(x' - x, y' - y₁) + φ(x₁, y' - y) + φ(x - x₁, y' - y),
  { repeat { rw is_Z_bilin.sub_left φ },
    repeat { rw is_Z_bilin.sub_right φ },
    apply eq_of_sub_eq_zero,
    simp [sub_eq_add_neg], abel },
  rw key_formula,
  have h₁ := HU x x' xU₂ x'U₂,
  have h₂ := H x x' xU₁ x'U₁ y₁ y' y₁_in y'V₁,
  have h₃ := HV y y' yV₂ y'V₂,
  have h₄ := H x₁ x x₁_in xU₁ y y' yV₁ y'V₁,

  exact W4 h₁ h₂ h₃ h₄
end

omit W'_nhd

open dense_inducing

/-- Bourbaki GT III.6.5 Theorem I:
ℤ-bilinear continuous maps from dense images into a complete Hausdorff group extend by continuity.
Note: Bourbaki assumes that α and β are also complete Hausdorff, but this is not necessary. -/
theorem extend_Z_bilin  : continuous (extend (de.prod df) φ) :=
begin
  refine continuous_extend_of_cauchy _ _,
  rintro ⟨x₀, y₀⟩,
  split,
  { apply ne_bot.map,
    apply comap_ne_bot,

    intros U h,
    rcases mem_closure_iff_nhds.1 ((de.prod df).dense (x₀, y₀)) U h with ⟨x, x_in, ⟨z, z_x⟩⟩,
    existsi z,
    cc },
  { suffices : map (λ (p : (β × δ) × (β × δ)), φ p.2 - φ p.1)
      (comap (λ (p : (β × δ) × β × δ), ((e p.1.1, f p.1.2), (e p.2.1, f p.2.2)))
         (𝓝 (x₀, y₀) ×ᶠ 𝓝 (x₀, y₀))) ≤ 𝓝 0,
    by rwa [uniformity_eq_comap_nhds_zero G, prod_map_map_eq, ←map_le_iff_le_comap, filter.map_map,
        prod_comap_comap_eq],

    intros W' W'_nhd,

    have key := extend_Z_bilin_key de df hφ W'_nhd x₀ y₀,
    rcases key with ⟨U, U_nhd, V, V_nhd, h⟩,
    rw mem_comap_sets at U_nhd,
    rcases U_nhd with ⟨U', U'_nhd, U'_sub⟩,
    rw mem_comap_sets at V_nhd,
    rcases V_nhd with ⟨V', V'_nhd, V'_sub⟩,

    rw [mem_map, mem_comap_sets, nhds_prod_eq],
    existsi set.prod (set.prod U' V') (set.prod U' V'),
    rw mem_prod_same_iff,

    simp only [exists_prop],
    split,
    { change U' ∈ 𝓝 x₀ at U'_nhd,
      change V' ∈ 𝓝 y₀ at V'_nhd,
      have := prod_mem_prod U'_nhd V'_nhd,
      tauto },
    { intros p h',
      simp only [set.mem_preimage, set.prod_mk_mem_set_prod_eq] at h',
      rcases p with ⟨⟨x, y⟩, ⟨x', y'⟩⟩,
      apply h ; tauto } }
end
end dense_inducing