/-
Copyright (c) 2019 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl
-/
import data.finsupp.defs
import linear_algebra.pi
import linear_algebra.span

/-!
# Properties of the module `α →₀ M`

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

Given an `R`-module `M`, the `R`-module structure on `α →₀ M` is defined in
`data.finsupp.basic`.

In this file we define `finsupp.supported s` to be the set `{f : α →₀ M | f.support ⊆ s}`
interpreted as a submodule of `α →₀ M`. We also define `linear_map` versions of various maps:

* `finsupp.lsingle a : M →ₗ[R] ι →₀ M`: `finsupp.single a` as a linear map;

* `finsupp.lapply a : (ι →₀ M) →ₗ[R] M`: the map `λ f, f a` as a linear map;

* `finsupp.lsubtype_domain (s : set α) : (α →₀ M) →ₗ[R] (s →₀ M)`: restriction to a subtype as a
  linear map;

* `finsupp.restrict_dom`: `finsupp.filter` as a linear map to `finsupp.supported s`;

* `finsupp.lsum`: `finsupp.sum` or `finsupp.lift_add_hom` as a `linear_map`;

* `finsupp.total α M R (v : ι → M)`: sends `l : ι → R` to the linear combination of `v i` with
  coefficients `l i`;

* `finsupp.total_on`: a restricted version of `finsupp.total` with domain `finsupp.supported R R s`
  and codomain `submodule.span R (v '' s)`;

* `finsupp.supported_equiv_finsupp`: a linear equivalence between the functions `α →₀ M` supported
  on `s` and the functions `s →₀ M`;

* `finsupp.lmap_domain`: a linear map version of `finsupp.map_domain`;

* `finsupp.dom_lcongr`: a `linear_equiv` version of `finsupp.dom_congr`;

* `finsupp.congr`: if the sets `s` and `t` are equivalent, then `supported M R s` is equivalent to
  `supported M R t`;

* `finsupp.lcongr`: a `linear_equiv`alence between `α →₀ M` and `β →₀ N` constructed using `e : α ≃
  β` and `e' : M ≃ₗ[R] N`.

## Tags

function with finite support, module, linear algebra
-/

noncomputable theory

open set linear_map submodule

open_locale classical big_operators

namespace finsupp

variables {α : Type*} {M : Type*} {N : Type*} {P : Type*} {R : Type*} {S : Type*}
variables [semiring R] [semiring S] [add_comm_monoid M] [module R M]
variables [add_comm_monoid N] [module R N]
variables [add_comm_monoid P] [module R P]

/-- Interpret `finsupp.single a` as a linear map. -/
def lsingle (a : α) : M →ₗ[R] (α →₀ M) :=
{ map_smul' := assume a b, (smul_single _ _ _).symm, ..finsupp.single_add_hom a }

/-- Two `R`-linear maps from `finsupp X M` which agree on each `single x y` agree everywhere. -/
lemma lhom_ext ⦃φ ψ : (α →₀ M) →ₗ[R] N⦄ (h : ∀ a b, φ (single a b) = ψ (single a b)) :
  φ = ψ :=
linear_map.to_add_monoid_hom_injective $ add_hom_ext h

/-- Two `R`-linear maps from `finsupp X M` which agree on each `single x y` agree everywhere.

We formulate this fact using equality of linear maps `φ.comp (lsingle a)` and `ψ.comp (lsingle a)`
so that the `ext` tactic can apply a type-specific extensionality lemma to prove equality of these
maps. E.g., if `M = R`, then it suffices to verify `φ (single a 1) = ψ (single a 1)`. -/
@[ext] lemma lhom_ext' ⦃φ ψ : (α →₀ M) →ₗ[R] N⦄ (h : ∀ a, φ.comp (lsingle a) = ψ.comp (lsingle a)) :
  φ = ψ :=
lhom_ext $ λ a, linear_map.congr_fun (h a)

/-- Interpret `λ (f : α →₀ M), f a` as a linear map. -/
def lapply (a : α) : (α →₀ M) →ₗ[R] M :=
{ map_smul' := assume a b, rfl, ..finsupp.apply_add_hom a }

/-- Forget that a function is finitely supported.

This is the linear version of `finsupp.to_fun`. -/
@[simps]
def lcoe_fun : (α →₀ M) →ₗ[R] α → M :=
{ to_fun := coe_fn,
  map_add' := λ x y, by { ext, simp },
  map_smul' := λ x y, by { ext, simp } }

section lsubtype_domain
variables (s : set α)

/-- Interpret `finsupp.subtype_domain s` as a linear map. -/
def lsubtype_domain : (α →₀ M) →ₗ[R] (s →₀ M) :=
{ to_fun := subtype_domain (λx, x ∈ s),
  map_add' := λ a b, subtype_domain_add,
  map_smul' := λ c a, ext $ λ a, rfl }

lemma lsubtype_domain_apply (f : α →₀ M) :
  (lsubtype_domain s : (α →₀ M) →ₗ[R] (s →₀ M)) f = subtype_domain (λx, x ∈ s) f := rfl

end lsubtype_domain

@[simp] lemma lsingle_apply (a : α) (b : M) : (lsingle a : M →ₗ[R] (α →₀ M)) b = single a b  :=
rfl

@[simp] lemma lapply_apply (a : α) (f : α →₀ M) : (lapply a : (α →₀ M) →ₗ[R] M) f = f a  :=
rfl

@[simp] lemma ker_lsingle (a : α) : (lsingle a : M →ₗ[R] (α →₀ M)).ker = ⊥ :=
ker_eq_bot_of_injective (single_injective a)

lemma lsingle_range_le_ker_lapply (s t : set α) (h : disjoint s t) :
  (⨆a∈s, (lsingle a : M →ₗ[R] (α →₀ M)).range) ≤ (⨅a∈t, ker (lapply a : (α →₀ M) →ₗ[R] M)) :=
begin
  refine supr_le (assume a₁, supr_le $ assume h₁, range_le_iff_comap.2 _),
  simp only [(ker_comp _ _).symm, eq_top_iff, set_like.le_def, mem_ker, comap_infi, mem_infi],
  assume b hb a₂ h₂,
  have : a₁ ≠ a₂ := assume eq, h.le_bot ⟨h₁, eq.symm ▸ h₂⟩,
  exact single_eq_of_ne this
end

lemma infi_ker_lapply_le_bot : (⨅a, ker (lapply a : (α →₀ M) →ₗ[R] M)) ≤ ⊥ :=
begin
  simp only [set_like.le_def, mem_infi, mem_ker, mem_bot, lapply_apply],
  exact assume a h, finsupp.ext h
end

lemma supr_lsingle_range : (⨆a, (lsingle a : M →ₗ[R] (α →₀ M)).range) = ⊤ :=
begin
  refine (eq_top_iff.2 $ set_like.le_def.2 $ assume f _, _),
  rw [← sum_single f],
  exact sum_mem (assume a ha, submodule.mem_supr_of_mem a ⟨_, rfl⟩),
end

lemma disjoint_lsingle_lsingle (s t : set α) (hs : disjoint s t) :
  disjoint (⨆a∈s, (lsingle a : M →ₗ[R] (α →₀ M)).range)
    (⨆a∈t, (lsingle a : M →ₗ[R] (α →₀ M)).range) :=
begin
  refine (disjoint.mono
    (lsingle_range_le_ker_lapply _ _ $ disjoint_compl_right)
    (lsingle_range_le_ker_lapply _ _ $ disjoint_compl_right)) _,
  rw disjoint_iff_inf_le,
  refine (le_trans (le_infi $ assume i, _) infi_ker_lapply_le_bot),
  classical,
  by_cases his : i ∈ s,
  { by_cases hit : i ∈ t,
    { exact (hs.le_bot ⟨his, hit⟩).elim },
    exact inf_le_of_right_le (infi_le_of_le i $ infi_le _ hit) },
  exact inf_le_of_left_le (infi_le_of_le i $ infi_le _ his)
end

lemma span_single_image (s : set M) (a : α) :
  submodule.span R (single a '' s) = (submodule.span R s).map (lsingle a : M →ₗ[R] (α →₀ M)) :=
by rw ← span_image; refl

variables (M R)

/-- `finsupp.supported M R s` is the `R`-submodule of all `p : α →₀ M` such that `p.support ⊆ s`. -/
def supported (s : set α) : submodule R (α →₀ M) :=
begin
  refine ⟨ {p | ↑p.support ⊆ s }, _, _, _ ⟩,
  { assume p q hp hq,
    refine subset.trans
      (subset.trans (finset.coe_subset.2 support_add) _) (union_subset hp hq),
    rw [finset.coe_union] },
  { simp only [subset_def, finset.mem_coe, set.mem_set_of_eq, mem_support_iff, zero_apply],
    assume h ha, exact (ha rfl).elim },
  { assume a p hp,
    refine subset.trans (finset.coe_subset.2 support_smul) hp }
end

variables {M}

lemma mem_supported {s : set α} (p : α →₀ M) : p ∈ (supported M R s) ↔ ↑p.support ⊆ s :=
iff.rfl

lemma mem_supported' {s : set α}  (p : α →₀ M) :
  p ∈ supported M R s ↔ ∀ x ∉ s, p x = 0 :=
by haveI := classical.dec_pred (λ (x : α), x ∈ s);
   simp [mem_supported, set.subset_def, not_imp_comm]

lemma mem_supported_support (p : α →₀ M) :
  p ∈ finsupp.supported M R (p.support : set α) :=
by rw finsupp.mem_supported

lemma single_mem_supported {s : set α} {a : α} (b : M) (h : a ∈ s) :
  single a b ∈ supported M R s :=
set.subset.trans support_single_subset (finset.singleton_subset_set_iff.2 h)

lemma supported_eq_span_single (s : set α) :
  supported R R s = span R ((λ i, single i 1) '' s) :=
begin
  refine (span_eq_of_le _ _ (set_like.le_def.2 $ λ l hl, _)).symm,
  { rintro _ ⟨_, hp, rfl ⟩ , exact single_mem_supported R 1 hp },
  { rw ← l.sum_single,
    refine sum_mem (λ i il, _),
    convert @smul_mem R (α →₀ R) _ _ _ _ (single i 1) (l i) _,
    { simp },
    apply subset_span,
    apply set.mem_image_of_mem _ (hl il) }
end

variables (M R)

/-- Interpret `finsupp.filter s` as a linear map from `α →₀ M` to `supported M R s`. -/
def restrict_dom (s : set α) : (α →₀ M) →ₗ[R] supported M R s :=
linear_map.cod_restrict _
  { to_fun := filter (∈ s),
    map_add' := λ l₁ l₂, filter_add,
    map_smul' := λ a l, filter_smul }
  (λ l, (mem_supported' _ _).2 $ λ x, filter_apply_neg (∈ s) l)

variables {M R}

section
@[simp] theorem restrict_dom_apply (s : set α) (l : α →₀ M) :
  ((restrict_dom M R s : (α →₀ M) →ₗ[R] supported M R s) l : α →₀ M) = finsupp.filter (∈ s) l := rfl
end

theorem restrict_dom_comp_subtype (s : set α) :
  (restrict_dom M R s).comp (submodule.subtype _) = linear_map.id :=
begin
  ext l a,
  by_cases a ∈ s; simp [h],
  exact ((mem_supported' R l.1).1 l.2 a h).symm
end

theorem range_restrict_dom (s : set α) :
  (restrict_dom M R s).range = ⊤ :=
range_eq_top.2 $ function.right_inverse.surjective $
  linear_map.congr_fun (restrict_dom_comp_subtype s)

theorem supported_mono {s t : set α} (st : s ⊆ t) :
  supported M R s ≤ supported M R t :=
λ l h, set.subset.trans h st

@[simp] theorem supported_empty : supported M R (∅ : set α) = ⊥ :=
eq_bot_iff.2 $ λ l h, (submodule.mem_bot R).2 $
by ext; simp [*, mem_supported'] at *

@[simp] theorem supported_univ : supported M R (set.univ : set α) = ⊤ :=
eq_top_iff.2 $ λ l _, set.subset_univ _

theorem supported_Union {δ : Type*} (s : δ → set α) :
  supported M R (⋃ i, s i) = ⨆ i, supported M R (s i) :=
begin
  refine le_antisymm _ (supr_le $ λ i, supported_mono $ set.subset_Union _ _),
  haveI := classical.dec_pred (λ x, x ∈ (⋃ i, s i)),
  suffices : ((submodule.subtype _).comp (restrict_dom M R (⋃ i, s i))).range ≤
    ⨆ i, supported M R (s i),
  { rwa [linear_map.range_comp, range_restrict_dom, map_top, range_subtype] at this },
  rw [range_le_iff_comap, eq_top_iff],
  rintro l ⟨⟩,
  apply finsupp.induction l, { exact zero_mem _ },
  refine λ x a l hl a0, add_mem _,
  by_cases (∃ i, x ∈ s i); simp [h],
  { cases h with i hi,
    exact le_supr (λ i, supported M R (s i)) i (single_mem_supported R _ hi) }
end

theorem supported_union (s t : set α) :
  supported M R (s ∪ t) = supported M R s ⊔ supported M R t :=
by erw [set.union_eq_Union, supported_Union, supr_bool_eq]; refl

theorem supported_Inter {ι : Type*} (s : ι → set α) :
  supported M R (⋂ i, s i) = ⨅ i, supported M R (s i) :=
submodule.ext $ λ x, by simp [mem_supported, subset_Inter_iff]

theorem supported_inter (s t : set α) :
  supported M R (s ∩ t) = supported M R s ⊓ supported M R t :=
by rw [set.inter_eq_Inter, supported_Inter, infi_bool_eq]; refl

theorem disjoint_supported_supported {s t : set α} (h : disjoint s t) :
  disjoint (supported M R s) (supported M R t) :=
disjoint_iff.2 $ by rw [← supported_inter, disjoint_iff_inter_eq_empty.1 h, supported_empty]

theorem disjoint_supported_supported_iff [nontrivial M] {s t : set α} :
  disjoint (supported M R s) (supported M R t) ↔ disjoint s t :=
begin
  refine ⟨λ h, set.disjoint_left.mpr $ λ x hx1 hx2, _, disjoint_supported_supported⟩,
  rcases exists_ne (0 : M) with ⟨y, hy⟩,
  have := h.le_bot ⟨single_mem_supported R y hx1, single_mem_supported R y hx2⟩,
  rw [mem_bot, single_eq_zero] at this,
  exact hy this
end

/-- Interpret `finsupp.restrict_support_equiv` as a linear equivalence between
`supported M R s` and `s →₀ M`. -/
def supported_equiv_finsupp (s : set α) : (supported M R s) ≃ₗ[R] (s →₀ M) :=
begin
  let F : (supported M R s) ≃ (s →₀ M) := restrict_support_equiv s M,
  refine F.to_linear_equiv _,
  have : (F : (supported M R s) → (↥s →₀ M)) = ((lsubtype_domain s : (α →₀ M) →ₗ[R] (s →₀ M)).comp
    (submodule.subtype (supported M R s))) := rfl,
  rw this,
  exact linear_map.is_linear _
end

section lsum

variables (S) [module S N] [smul_comm_class R S N]

/-- Lift a family of linear maps `M →ₗ[R] N` indexed by `x : α` to a linear map from `α →₀ M` to
`N` using `finsupp.sum`. This is an upgraded version of `finsupp.lift_add_hom`.

See note [bundled maps over different rings] for why separate `R` and `S` semirings are used.
-/
def lsum : (α → M →ₗ[R] N) ≃ₗ[S] ((α →₀ M) →ₗ[R] N) :=
{ to_fun := λ F,
  { to_fun := λ d, d.sum (λ i, F i),
    map_add' := (lift_add_hom (λ x, (F x).to_add_monoid_hom)).map_add,
    map_smul' := λ c f, by simp [sum_smul_index', smul_sum] },
  inv_fun := λ F x, F.comp (lsingle x),
  left_inv := λ F, by { ext x y, simp },
  right_inv := λ F, by { ext x y, simp },
  map_add' := λ F G, by { ext x y, simp },
  map_smul' := λ F G, by { ext x y, simp } }

@[simp] lemma coe_lsum (f : α → M →ₗ[R] N) : (lsum S f : (α →₀ M) → N) = λ d, d.sum (λ i, f i) :=
rfl

theorem lsum_apply (f : α → M →ₗ[R] N) (l : α →₀ M) :
  finsupp.lsum S f l = l.sum (λ b, f b) := rfl

theorem lsum_single (f : α → M →ₗ[R] N) (i : α) (m : M) :
  finsupp.lsum S f (finsupp.single i m) = f i m :=
finsupp.sum_single_index (f i).map_zero

theorem lsum_symm_apply (f : (α →₀ M) →ₗ[R] N) (x : α) :
  (lsum S).symm f x = f.comp (lsingle x) := rfl

end lsum

section
variables (M) (R) (X : Type*) (S) [module S M] [smul_comm_class R S M]

/--
A slight rearrangement from `lsum` gives us
the bijection underlying the free-forgetful adjunction for R-modules.
-/
noncomputable def lift : (X → M) ≃+ ((X →₀ R) →ₗ[R] M) :=
(add_equiv.arrow_congr (equiv.refl X) (ring_lmap_equiv_self R ℕ M).to_add_equiv.symm).trans
  (lsum _ : _ ≃ₗ[ℕ] _).to_add_equiv

@[simp]
lemma lift_symm_apply (f) (x) : ((lift M R X).symm f) x = f (single x 1) :=
rfl
@[simp]
lemma lift_apply (f) (g) :
  ((lift M R X) f) g = g.sum (λ x r, r • f x) :=
rfl

/-- Given compatible `S` and `R`-module structures on `M` and a type `X`, the set of functions
`X → M` is `S`-linearly equivalent to the `R`-linear maps from the free `R`-module
on `X` to `M`. -/
noncomputable def llift : (X → M) ≃ₗ[S] ((X →₀ R) →ₗ[R] M) :=
{ map_smul' :=
  begin
    intros,
    dsimp,
    ext,
    simp only [coe_comp, function.comp_app, lsingle_apply, lift_apply, pi.smul_apply,
      sum_single_index, zero_smul, one_smul, linear_map.smul_apply],
  end, ..lift M R X }

@[simp] lemma llift_apply (f : X → M) (x : X →₀ R) :
  llift M R S X f x = lift M R X f x := rfl

@[simp] lemma llift_symm_apply (f : (X →₀ R) →ₗ[R] M) (x : X) :
  (llift M R S X).symm f x = f (single x 1) := rfl
end

section lmap_domain
variables {α' : Type*} {α'' : Type*} (M R)

/-- Interpret `finsupp.map_domain` as a linear map. -/
def lmap_domain (f : α → α') : (α →₀ M) →ₗ[R] (α' →₀ M) :=
{ to_fun := map_domain f, map_add' := λ a b, map_domain_add, map_smul' := map_domain_smul }

@[simp] theorem lmap_domain_apply (f : α → α') (l : α →₀ M) :
  (lmap_domain M R f : (α →₀ M) →ₗ[R] (α' →₀ M)) l = map_domain f l := rfl

@[simp] theorem lmap_domain_id : (lmap_domain M R id : (α →₀ M) →ₗ[R] α →₀ M) = linear_map.id :=
linear_map.ext $ λ l, map_domain_id

theorem lmap_domain_comp (f : α → α') (g : α' → α'') :
  lmap_domain M R (g ∘ f) = (lmap_domain M R g).comp (lmap_domain M R f) :=
linear_map.ext $ λ l, map_domain_comp

theorem supported_comap_lmap_domain (f : α → α') (s : set α') :
  supported M R (f ⁻¹' s) ≤ (supported M R s).comap (lmap_domain M R f) :=
λ l (hl : ↑l.support ⊆ f ⁻¹' s),
show ↑(map_domain f l).support ⊆ s, begin
  rw [← set.image_subset_iff, ← finset.coe_image] at hl,
  exact set.subset.trans map_domain_support hl
end

theorem lmap_domain_supported [nonempty α] (f : α → α') (s : set α) :
  (supported M R s).map (lmap_domain M R f) = supported M R (f '' s) :=
begin
  inhabit α,
  refine le_antisymm (map_le_iff_le_comap.2 $
    le_trans (supported_mono $ set.subset_preimage_image _ _)
       (supported_comap_lmap_domain _ _ _ _)) _,
  intros l hl,
  refine ⟨(lmap_domain M R (function.inv_fun_on f s) : (α' →₀ M) →ₗ[R] α →₀ M) l, λ x hx, _, _⟩,
  { rcases finset.mem_image.1 (map_domain_support hx) with ⟨c, hc, rfl⟩,
    exact function.inv_fun_on_mem (by simpa using hl hc) },
  { rw [← linear_map.comp_apply, ← lmap_domain_comp],
    refine (map_domain_congr $ λ c hc, _).trans map_domain_id,
    exact function.inv_fun_on_eq (by simpa using hl hc) }
end

theorem lmap_domain_disjoint_ker (f : α → α') {s : set α}
  (H : ∀ a b ∈ s, f a = f b → a = b) :
  disjoint (supported M R s) (lmap_domain M R f).ker :=
begin
  rw disjoint_iff_inf_le,
  rintro l ⟨h₁, h₂⟩,
  rw [set_like.mem_coe, mem_ker, lmap_domain_apply, map_domain] at h₂,
  simp, ext x,
  haveI := classical.dec_pred (λ x, x ∈ s),
  by_cases xs : x ∈ s,
  { have : finsupp.sum l (λ a, finsupp.single (f a)) (f x) = 0, {rw h₂, refl},
    rw [finsupp.sum_apply, finsupp.sum, finset.sum_eq_single x] at this,
    { simpa [finsupp.single_apply] },
    { intros y hy xy, simp [mt (H _ (h₁ hy) _ xs) xy] },
    { simp {contextual := tt} } },
  { by_contra h, exact xs (h₁ $ finsupp.mem_support_iff.2 h) }
end

end lmap_domain

section lcomap_domain

variables {β : Type*} {R M}

/-- Given `f : α → β` and a proof `hf` that `f` is injective, `lcomap_domain f hf` is the linear map
sending  `l : β →₀ M` to the finitely supported function from `α` to `M` given by composing
`l` with `f`.

This is the linear version of `finsupp.comap_domain`. -/
def lcomap_domain (f : α → β) (hf : function.injective f) :
  (β →₀ M) →ₗ[R] α →₀ M:=
{ to_fun := λ l, finsupp.comap_domain f l (hf.inj_on _),
  map_add' := λ x y, by { ext, simp },
  map_smul' := λ c x, by { ext, simp } }

end lcomap_domain

section total
variables (α) {α' : Type*} (M) {M' : Type*} (R)
          [add_comm_monoid M'] [module R M']
          (v : α → M) {v' : α' → M'}

/-- Interprets (l : α →₀ R) as linear combination of the elements in the family (v : α → M) and
    evaluates this linear combination. -/
protected def total : (α →₀ R) →ₗ[R] M := finsupp.lsum ℕ (λ i, linear_map.id.smul_right (v i))

variables {α M v}

theorem total_apply (l : α →₀ R) :
  finsupp.total α M R v l = l.sum (λ i a, a • v i) := rfl

theorem total_apply_of_mem_supported {l : α →₀ R} {s : finset α}
  (hs : l ∈ supported R R (↑s : set α)) :
  finsupp.total α M R v l = s.sum (λ i, l i • v i) :=
finset.sum_subset hs $ λ x _ hxg, show l x • v x = 0, by rw [not_mem_support_iff.1 hxg, zero_smul]

@[simp] theorem total_single (c : R) (a : α) :
  finsupp.total α M R v (single a c) = c • (v a) :=
by simp [total_apply, sum_single_index]

lemma total_zero_apply (x : α →₀ R) :
  (finsupp.total α M R 0) x = 0 := by simp [finsupp.total_apply]

variables (α M)

@[simp] lemma total_zero :
  finsupp.total α M R 0 = 0 :=
linear_map.ext (total_zero_apply R)

variables {α M}

theorem apply_total (f : M →ₗ[R] M') (v) (l : α →₀ R) :
  f (finsupp.total α M R v l) = finsupp.total α M' R (f ∘ v) l :=
by apply finsupp.induction_linear l; simp { contextual := tt, }

theorem total_unique [unique α] (l : α →₀ R) (v) :
  finsupp.total α M R v l = l default • v default :=
by rw [← total_single, ← unique_single l]

lemma total_surjective (h : function.surjective v) : function.surjective (finsupp.total α M R v) :=
begin
  intro x,
  obtain ⟨y, hy⟩ := h x,
  exact ⟨finsupp.single y 1, by simp [hy]⟩
end

theorem total_range (h : function.surjective v) : (finsupp.total α M R v).range = ⊤ :=
range_eq_top.2 $ total_surjective R h

/-- Any module is a quotient of a free module. This is stated as surjectivity of
`finsupp.total M M R id : (M →₀ R) →ₗ[R] M`. -/
lemma total_id_surjective (M) [add_comm_monoid M] [module R M] :
  function.surjective (finsupp.total M M R id) :=
total_surjective R function.surjective_id

lemma range_total : (finsupp.total α M R v).range = span R (range v) :=
begin
  ext x,
  split,
  { intros hx,
    rw [linear_map.mem_range] at hx,
    rcases hx with ⟨l, hl⟩,
    rw ← hl,
    rw finsupp.total_apply,
    exact sum_mem (λ i hi, submodule.smul_mem _ _ (subset_span (mem_range_self i))) },
  { apply span_le.2,
    intros x hx,
    rcases hx with ⟨i, hi⟩,
    rw [set_like.mem_coe, linear_map.mem_range],
    use finsupp.single i 1,
    simp [hi] }
end

theorem lmap_domain_total (f : α → α') (g : M →ₗ[R] M') (h : ∀ i, g (v i) = v' (f i)) :
  (finsupp.total α' M' R v').comp (lmap_domain R R f) = g.comp (finsupp.total α M R v) :=
by ext l; simp [total_apply, finsupp.sum_map_domain_index, add_smul, h]

theorem total_comp_lmap_domain (f : α → α') :
  (finsupp.total α' M' R v').comp (finsupp.lmap_domain R R f) = (finsupp.total α M' R (v' ∘ f)) :=
by { ext, simp }

@[simp] theorem total_emb_domain (f : α ↪ α') (l : α →₀ R) :
  (finsupp.total α' M' R v') (emb_domain f l) = (finsupp.total α M' R (v' ∘ f)) l :=
by simp [total_apply, finsupp.sum, support_emb_domain, emb_domain_apply]

@[simp]

@[simp] theorem total_equiv_map_domain (f : α ≃ α') (l : α →₀ R) :
  (finsupp.total α' M' R v') (equiv_map_domain f l) = (finsupp.total α M' R (v' ∘ f)) l :=
by rw [equiv_map_domain_eq_map_domain, total_map_domain]

/-- A version of `finsupp.range_total` which is useful for going in the other direction -/
theorem span_eq_range_total (s : set M) :
  span R s = (finsupp.total s M R coe).range :=
by rw [range_total, subtype.range_coe_subtype, set.set_of_mem_eq]

theorem mem_span_iff_total (s : set M) (x : M) :
  x ∈ span R s ↔ ∃ l : s →₀ R, finsupp.total s M R coe l = x :=
(set_like.ext_iff.1 $ span_eq_range_total _ _) x

variables {R}

lemma mem_span_range_iff_exists_finsupp {v : α → M} {x : M} :
  x ∈ span R (range v) ↔ ∃ (c : α →₀ R), c.sum (λ i a, a • v i) = x :=
by simp only [←finsupp.range_total, linear_map.mem_range, finsupp.total_apply]

variables (R)

theorem span_image_eq_map_total (s : set α):
  span R (v '' s) = submodule.map (finsupp.total α M R v) (supported R R s) :=
begin
  apply span_eq_of_le,
  { intros x hx,
    rw set.mem_image at hx,
    apply exists.elim hx,
    intros i hi,
    exact ⟨_, finsupp.single_mem_supported R 1 hi.1, by simp [hi.2]⟩ },
  { refine map_le_iff_le_comap.2 (λ z hz, _),
    have : ∀i, z i • v i ∈ span R (v '' s),
    { intro c,
      haveI := classical.dec_pred (λ x, x ∈ s),
      by_cases c ∈ s,
      { exact smul_mem _ _ (subset_span (set.mem_image_of_mem _ h)) },
      { simp [(finsupp.mem_supported' R _).1 hz _ h] } },
    refine sum_mem _, simp [this] }
end

theorem mem_span_image_iff_total {s : set α} {x : M} :
  x ∈ span R (v '' s) ↔ ∃ l ∈ supported R R s, finsupp.total α M R v l = x :=
by { rw span_image_eq_map_total, simp, }

lemma total_option (v : option α → M) (f : option α →₀ R) :
  finsupp.total (option α) M R v f =
    f none • v none + finsupp.total α M R (v ∘ option.some) f.some :=
by rw [total_apply, sum_option_index_smul, total_apply]

lemma total_total {α β : Type*} (A : α → M) (B : β → (α →₀ R)) (f : β →₀ R) :
  finsupp.total α M R A (finsupp.total β (α →₀ R) R B f) =
    finsupp.total β M R (λ b, finsupp.total α M R A (B b)) f :=
begin
  simp only [total_apply],
  apply induction_linear f,
  { simp only [sum_zero_index], },
  { intros f₁ f₂ h₁ h₂,
    simp [sum_add_index, h₁, h₂, add_smul], },
  { simp [sum_single_index, sum_smul_index, smul_sum, mul_smul], }
end

@[simp] lemma total_fin_zero (f : fin 0 → M) :
  finsupp.total (fin 0) M R f = 0 :=
by { ext i, apply fin_zero_elim i }

variables (α) (M) (v)

/-- `finsupp.total_on M v s` interprets `p : α →₀ R` as a linear combination of a
subset of the vectors in `v`, mapping it to the span of those vectors.

The subset is indicated by a set `s : set α` of indices.
-/
protected def total_on (s : set α) : supported R R s →ₗ[R] span R (v '' s) :=
linear_map.cod_restrict _ ((finsupp.total _ _ _ v).comp (submodule.subtype (supported R R s))) $
  λ ⟨l, hl⟩, (mem_span_image_iff_total _).2 ⟨l, hl, rfl⟩

variables {α} {M} {v}

theorem total_on_range (s : set α) : (finsupp.total_on α M R v s).range = ⊤ :=
begin
  rw [finsupp.total_on, linear_map.range_eq_map, linear_map.map_cod_restrict,
    ← linear_map.range_le_iff_comap, range_subtype, map_top, linear_map.range_comp, range_subtype],
  exact (span_image_eq_map_total _ _).le
end

theorem total_comp (f : α' → α) :
  (finsupp.total α' M R (v ∘ f)) = (finsupp.total α M R v).comp (lmap_domain R R f) :=
by { ext, simp [total_apply] }

lemma total_comap_domain
 (f : α → α') (l : α' →₀ R) (hf : set.inj_on f (f ⁻¹' ↑l.support)) :
 finsupp.total α M R v (finsupp.comap_domain f l hf) =
   (l.support.preimage f hf).sum (λ i, (l (f i)) • (v i)) :=
by rw finsupp.total_apply; refl

lemma total_on_finset
  {s : finset α} {f : α → R} (g : α → M) (hf : ∀ a, f a ≠ 0 → a ∈ s):
  finsupp.total α M R g (finsupp.on_finset s f hf) =
    finset.sum s (λ (x : α), f x • g x) :=
begin
  simp only [finsupp.total_apply, finsupp.sum, finsupp.on_finset_apply, finsupp.support_on_finset],
  rw finset.sum_filter_of_ne,
  intros x hx h,
  contrapose! h,
  simp [h],
end

end total

/-- An equivalence of domains induces a linear equivalence of finitely supported functions.

This is `finsupp.dom_congr` as a `linear_equiv`.
See also `linear_map.fun_congr_left` for the case of arbitrary functions. -/
protected def dom_lcongr {α₁ α₂ : Type*} (e : α₁ ≃ α₂) :
  (α₁ →₀ M) ≃ₗ[R] (α₂ →₀ M) :=
(finsupp.dom_congr e : (α₁ →₀ M) ≃+ (α₂ →₀ M)).to_linear_equiv $
by simpa only [equiv_map_domain_eq_map_domain, dom_congr_apply]
  using (lmap_domain M R e).map_smul

@[simp]
lemma dom_lcongr_apply {α₁ : Type*} {α₂ : Type*} (e : α₁ ≃ α₂) (v : α₁ →₀ M) :
  (finsupp.dom_lcongr e : _ ≃ₗ[R] _) v = finsupp.dom_congr e v :=
rfl

@[simp]
lemma dom_lcongr_refl : finsupp.dom_lcongr (equiv.refl α) = linear_equiv.refl R (α →₀ M) :=
linear_equiv.ext $ λ _, equiv_map_domain_refl _

lemma dom_lcongr_trans {α₁ α₂ α₃ : Type*} (f : α₁ ≃ α₂) (f₂ : α₂ ≃ α₃) :
  (finsupp.dom_lcongr f).trans (finsupp.dom_lcongr f₂) =
    (finsupp.dom_lcongr (f.trans f₂) : (_ →₀ M) ≃ₗ[R] _) :=
linear_equiv.ext $ λ _, (equiv_map_domain_trans _ _ _).symm

@[simp]
lemma dom_lcongr_symm {α₁ α₂ : Type*} (f : α₁ ≃ α₂) :
  ((finsupp.dom_lcongr f).symm : (_ →₀ M) ≃ₗ[R] _) = finsupp.dom_lcongr f.symm :=
linear_equiv.ext $ λ x, rfl

@[simp] theorem dom_lcongr_single {α₁ : Type*} {α₂ : Type*} (e : α₁ ≃ α₂) (i : α₁) (m : M) :
  (finsupp.dom_lcongr e : _ ≃ₗ[R] _) (finsupp.single i m) = finsupp.single (e i) m :=
by simp [finsupp.dom_lcongr, finsupp.dom_congr, equiv_map_domain_single]

/-- An equivalence of sets induces a linear equivalence of `finsupp`s supported on those sets. -/
noncomputable def congr {α' : Type*} (s : set α) (t : set α') (e : s ≃ t) :
  supported M R s ≃ₗ[R] supported M R t :=
begin
  haveI := classical.dec_pred (λ x, x ∈ s),
  haveI := classical.dec_pred (λ x, x ∈ t),
  refine (finsupp.supported_equiv_finsupp s) ≪≫ₗ
      (_ ≪≫ₗ (finsupp.supported_equiv_finsupp t).symm),
  exact finsupp.dom_lcongr e
end

/-- `finsupp.map_range` as a `linear_map`. -/
@[simps]
def map_range.linear_map (f : M →ₗ[R] N) : (α →₀ M) →ₗ[R] (α →₀ N) :=
{ to_fun := (map_range f f.map_zero : (α →₀ M) → (α →₀ N)),
  map_smul' := λ c v, map_range_smul c v (f.map_smul c),
  ..map_range.add_monoid_hom f.to_add_monoid_hom }

@[simp]
lemma map_range.linear_map_id :
  map_range.linear_map linear_map.id = (linear_map.id : (α →₀ M) →ₗ[R] _):=
linear_map.ext map_range_id

lemma map_range.linear_map_comp (f : N →ₗ[R] P) (f₂ : M →ₗ[R] N) :
  (map_range.linear_map (f.comp f₂) : (α →₀ _) →ₗ[R] _) =
    (map_range.linear_map f).comp (map_range.linear_map f₂) :=
linear_map.ext $ map_range_comp _ _ _ _ _

@[simp]
lemma map_range.linear_map_to_add_monoid_hom (f : M →ₗ[R] N) :
  (map_range.linear_map f).to_add_monoid_hom =
    (map_range.add_monoid_hom f.to_add_monoid_hom : (α →₀ M) →+ _):=
add_monoid_hom.ext $ λ _, rfl

/-- `finsupp.map_range` as a `linear_equiv`. -/
@[simps apply]
def map_range.linear_equiv (e : M ≃ₗ[R] N) : (α →₀ M) ≃ₗ[R] (α →₀ N) :=
{ to_fun := map_range e e.map_zero,
  inv_fun := map_range e.symm e.symm.map_zero,
  ..map_range.linear_map e.to_linear_map,
  ..map_range.add_equiv e.to_add_equiv}

@[simp]
lemma map_range.linear_equiv_refl :
  map_range.linear_equiv (linear_equiv.refl R M) = linear_equiv.refl R (α →₀ M) :=
linear_equiv.ext map_range_id

lemma map_range.linear_equiv_trans (f : M ≃ₗ[R] N) (f₂ : N ≃ₗ[R] P) :
  (map_range.linear_equiv (f.trans f₂) : (α →₀ _) ≃ₗ[R] _) =
    (map_range.linear_equiv f).trans (map_range.linear_equiv f₂) :=
linear_equiv.ext $ map_range_comp _ _ _ _ _

@[simp]
lemma map_range.linear_equiv_symm (f : M ≃ₗ[R] N) :
  ((map_range.linear_equiv f).symm : (α →₀ _) ≃ₗ[R] _) = map_range.linear_equiv f.symm :=
linear_equiv.ext $ λ x, rfl

@[simp]
lemma map_range.linear_equiv_to_add_equiv (f : M ≃ₗ[R] N) :
  (map_range.linear_equiv f).to_add_equiv =
    (map_range.add_equiv f.to_add_equiv : (α →₀ M) ≃+ _):=
add_equiv.ext $ λ _, rfl

@[simp]
lemma map_range.linear_equiv_to_linear_map (f : M ≃ₗ[R] N) :
  (map_range.linear_equiv f).to_linear_map =
    (map_range.linear_map f.to_linear_map : (α →₀ M) →ₗ[R] _):=
linear_map.ext $ λ _, rfl

/-- An equivalence of domain and a linear equivalence of codomain induce a linear equivalence of the
corresponding finitely supported functions. -/
def lcongr {ι κ : Sort*} (e₁ : ι ≃ κ) (e₂ : M ≃ₗ[R] N) : (ι →₀ M) ≃ₗ[R] (κ →₀ N) :=
(finsupp.dom_lcongr e₁).trans (map_range.linear_equiv e₂)

@[simp] theorem lcongr_single {ι κ : Sort*} (e₁ : ι ≃ κ) (e₂ : M ≃ₗ[R] N) (i : ι) (m : M) :
  lcongr e₁ e₂ (finsupp.single i m) = finsupp.single (e₁ i) (e₂ m) :=
by simp [lcongr]

@[simp] lemma lcongr_apply_apply {ι κ : Sort*} (e₁ : ι ≃ κ) (e₂ : M ≃ₗ[R] N) (f : ι →₀ M) (k : κ) :
  lcongr e₁ e₂ f k = e₂ (f (e₁.symm k)) :=
rfl

theorem lcongr_symm_single {ι κ : Sort*} (e₁ : ι ≃ κ) (e₂ : M ≃ₗ[R] N) (k : κ) (n : N) :
  (lcongr e₁ e₂).symm (finsupp.single k n) = finsupp.single (e₁.symm k) (e₂.symm n) :=
begin
  apply_fun lcongr e₁ e₂ using (lcongr e₁ e₂).injective,
  simp,
end

@[simp] lemma lcongr_symm {ι κ : Sort*} (e₁ : ι ≃ κ) (e₂ : M ≃ₗ[R] N) :
  (lcongr e₁ e₂).symm = lcongr e₁.symm e₂.symm :=
by { ext, refl }

section sum

variables (R)

/-- The linear equivalence between `(α ⊕ β) →₀ M` and `(α →₀ M) × (β →₀ M)`.

This is the `linear_equiv` version of `finsupp.sum_finsupp_equiv_prod_finsupp`. -/
@[simps apply symm_apply] def sum_finsupp_lequiv_prod_finsupp {α β : Type*} :
  ((α ⊕ β) →₀ M) ≃ₗ[R] (α →₀ M) × (β →₀ M) :=
{ map_smul' :=
    by { intros, ext;
          simp only [add_equiv.to_fun_eq_coe, prod.smul_fst, prod.smul_snd, smul_apply,
              snd_sum_finsupp_add_equiv_prod_finsupp, fst_sum_finsupp_add_equiv_prod_finsupp,
              ring_hom.id_apply] },
  .. sum_finsupp_add_equiv_prod_finsupp }

lemma fst_sum_finsupp_lequiv_prod_finsupp {α β : Type*}
  (f : (α ⊕ β) →₀ M) (x : α) :
  (sum_finsupp_lequiv_prod_finsupp R f).1 x = f (sum.inl x) :=
rfl

lemma snd_sum_finsupp_lequiv_prod_finsupp {α β : Type*}
  (f : (α ⊕ β) →₀ M) (y : β) :
  (sum_finsupp_lequiv_prod_finsupp R f).2 y = f (sum.inr y) :=
rfl

lemma sum_finsupp_lequiv_prod_finsupp_symm_inl {α β : Type*}
  (fg : (α →₀ M) × (β →₀ M)) (x : α) :
  ((sum_finsupp_lequiv_prod_finsupp R).symm fg) (sum.inl x) = fg.1 x :=
rfl

lemma sum_finsupp_lequiv_prod_finsupp_symm_inr {α β : Type*}
  (fg : (α →₀ M) × (β →₀ M)) (y : β) :
  ((sum_finsupp_lequiv_prod_finsupp R).symm fg) (sum.inr y) = fg.2 y :=
rfl

end sum

section sigma

variables {η : Type*} [fintype η] {ιs : η → Type*} [has_zero α]
variables (R)

/-- On a `fintype η`, `finsupp.split` is a linear equivalence between
`(Σ (j : η), ιs j) →₀ M` and `Π j, (ιs j →₀ M)`.

This is the `linear_equiv` version of `finsupp.sigma_finsupp_add_equiv_pi_finsupp`. -/
noncomputable def sigma_finsupp_lequiv_pi_finsupp
  {M : Type*} {ιs : η → Type*} [add_comm_monoid M] [module R M] :
  ((Σ j, ιs j) →₀ M) ≃ₗ[R] Π j, (ιs j →₀ M) :=
{ map_smul' := λ c f, by { ext, simp },
  .. sigma_finsupp_add_equiv_pi_finsupp }

@[simp] lemma sigma_finsupp_lequiv_pi_finsupp_apply
  {M : Type*} {ιs : η → Type*} [add_comm_monoid M] [module R M]
  (f : (Σ j, ιs j) →₀ M) (j i) :
  sigma_finsupp_lequiv_pi_finsupp R f j i = f ⟨j, i⟩ := rfl

@[simp] lemma sigma_finsupp_lequiv_pi_finsupp_symm_apply
  {M : Type*} {ιs : η → Type*} [add_comm_monoid M] [module R M]
  (f : Π j, (ιs j →₀ M)) (ji) :
  (finsupp.sigma_finsupp_lequiv_pi_finsupp R).symm f ji = f ji.1 ji.2 := rfl

end sigma

section prod

/-- The linear equivalence between `α × β →₀ M` and `α →₀ β →₀ M`.

This is the `linear_equiv` version of `finsupp.finsupp_prod_equiv`. -/
noncomputable def finsupp_prod_lequiv {α β : Type*} (R : Type*) {M : Type*}
  [semiring R] [add_comm_monoid M] [module R M] :
  (α × β →₀ M) ≃ₗ[R] (α →₀ β →₀ M) :=
{ map_add' := λ f g, by { ext, simp [finsupp_prod_equiv, curry_apply] },
  map_smul' := λ c f, by { ext, simp [finsupp_prod_equiv, curry_apply] },
  .. finsupp_prod_equiv }

@[simp] lemma finsupp_prod_lequiv_apply {α β R M : Type*}
  [semiring R] [add_comm_monoid M] [module R M] (f : α × β →₀ M) (x y) :
  finsupp_prod_lequiv R f x y = f (x, y) :=
by rw [finsupp_prod_lequiv, linear_equiv.coe_mk, finsupp_prod_equiv, finsupp.curry_apply]

@[simp] lemma finsupp_prod_lequiv_symm_apply {α β R M : Type*}
  [semiring R] [add_comm_monoid M] [module R M] (f : α →₀ β →₀ M) (xy) :
  (finsupp_prod_lequiv R).symm f xy = f xy.1 xy.2 :=
by conv_rhs
  { rw [← (finsupp_prod_lequiv R).apply_symm_apply f, finsupp_prod_lequiv_apply, prod.mk.eta] }

end prod

end finsupp

section fintype

variables {α M : Type*} (R : Type*) [fintype α] [semiring R] [add_comm_monoid M] [module R M]
variables (S : Type*) [semiring S] [module S M] [smul_comm_class R S M]
variable (v : α → M)

/-- `fintype.total R S v f` is the linear combination of vectors in `v` with weights in `f`.
This variant of `finsupp.total` is defined on fintype indexed vectors.

This map is linear in `v` if `R` is commutative, and always linear in `f`.
See note [bundled maps over different rings] for why separate `R` and `S` semirings are used.
-/
protected def fintype.total : (α → M) →ₗ[S] (α → R) →ₗ[R] M :=
{ to_fun := λ v, { to_fun := λ f, ∑ i, f i • v i,
    map_add' := λ f g, by { simp_rw [← finset.sum_add_distrib, ← add_smul], refl },
    map_smul' := λ r f, by { simp_rw [finset.smul_sum, smul_smul], refl } },
  map_add' := λ u v, by { ext, simp [finset.sum_add_distrib, pi.add_apply, smul_add] },
  map_smul' := λ r v, by { ext, simp [finset.smul_sum, smul_comm _ r] } }

variables {S}

lemma fintype.total_apply (f) : fintype.total R S v f = ∑ i, f i • v i := rfl

@[simp]
lemma fintype.total_apply_single (i : α) (r : R) :
  fintype.total R S v (pi.single i r) = r • v i :=
begin
  simp_rw [fintype.total_apply, pi.single_apply, ite_smul, zero_smul],
  rw [finset.sum_ite_eq', if_pos (finset.mem_univ _)]
end

variables (S)

lemma finsupp.total_eq_fintype_total_apply (x : α → R) :
  finsupp.total α M R v ((finsupp.linear_equiv_fun_on_finite R R α).symm x) =
    fintype.total R S v x :=
begin
  apply finset.sum_subset,
  { exact finset.subset_univ _ },
  { intros x _ hx,
    rw finsupp.not_mem_support_iff.mp hx,
    exact zero_smul _ _ }
end

lemma finsupp.total_eq_fintype_total :
  (finsupp.total α M R v).comp (finsupp.linear_equiv_fun_on_finite R R α).symm.to_linear_map =
    fintype.total R S v :=
linear_map.ext $ finsupp.total_eq_fintype_total_apply R S v

variables {S}

@[simp]
lemma fintype.range_total : (fintype.total R S v).range = submodule.span R (set.range v) :=
by rw [← finsupp.total_eq_fintype_total, linear_map.range_comp,
  linear_equiv.to_linear_map_eq_coe, linear_equiv.range, submodule.map_top, finsupp.range_total]

section span_range

variables {v} {x : M}

/--
An element `x` lies in the span of `v` iff it can be written as sum `∑ cᵢ • vᵢ = x`.
-/
lemma mem_span_range_iff_exists_fun :
  x ∈ span R (range v) ↔ ∃ (c : α → R), ∑ i, c i • v i = x :=
begin
  simp only [finsupp.mem_span_range_iff_exists_finsupp,
    finsupp.equiv_fun_on_finite.surjective.exists, finsupp.equiv_fun_on_finite_apply],
  exact exists_congr (λ c, eq.congr_left $ finsupp.sum_fintype _ _ $ λ i, zero_smul _ _)
end

/--
A family `v : α → V` is generating `V` iff every element `(x : V)`
can be written as sum `∑ cᵢ • vᵢ = x`.
-/
theorem top_le_span_range_iff_forall_exists_fun :
  ⊤ ≤ span R (range v) ↔ ∀ x, ∃ (c : α → R), ∑ i, (c i) • (v i) = x :=
begin
  simp_rw ←mem_span_range_iff_exists_fun,
  exact ⟨λ h x, h trivial, λ h x _, h x⟩,
end

end span_range

end fintype

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

section
variables (R)
/--
Pick some representation of `x : span R w` as a linear combination in `w`,
using the axiom of choice.
-/
@[irreducible] def span.repr (w : set M) (x : span R w) : w →₀ R :=
((finsupp.mem_span_iff_total _ _ _).mp x.2).some

@[simp] lemma span.finsupp_total_repr {w : set M} (x : span R w) :
  finsupp.total w M R coe (span.repr R w x) = x :=
begin
  rw span.repr,
  exact ((finsupp.mem_span_iff_total _ _ _).mp x.2).some_spec
end

end

protected lemma submodule.finsupp_sum_mem {ι β : Type*} [has_zero β] (S : submodule R M)
  (f : ι →₀ β) (g : ι → β → M) (h : ∀ c, f c ≠ 0 → g c (f c) ∈ S) : f.sum g ∈ S :=
add_submonoid_class.finsupp_sum_mem S f g h

lemma linear_map.map_finsupp_total
  (f : M →ₗ[R] N) {ι : Type*} {g : ι → M} (l : ι →₀ R) :
  f (finsupp.total ι M R g l) = finsupp.total ι N R (f ∘ g) l :=
by simp only [finsupp.total_apply, finsupp.total_apply, finsupp.sum, f.map_sum, f.map_smul]

lemma submodule.exists_finset_of_mem_supr
  {ι : Sort*} (p : ι → submodule R M) {m : M} (hm : m ∈ ⨆ i, p i) :
  ∃ s : finset ι, m ∈ ⨆ i ∈ s, p i :=
begin
  have := complete_lattice.is_compact_element.exists_finset_of_le_supr (submodule R M)
    (submodule.singleton_span_is_compact_element m) p,
  simp only [submodule.span_singleton_le_iff_mem] at this,
  exact this hm,
end

/-- `submodule.exists_finset_of_mem_supr` as an `iff` -/
lemma submodule.mem_supr_iff_exists_finset
  {ι : Sort*} {p : ι → submodule R M} {m : M} :
  (m ∈ ⨆ i, p i) ↔ ∃ s : finset ι, m ∈ ⨆ i ∈ s, p i :=
⟨submodule.exists_finset_of_mem_supr p,
 λ ⟨_, hs⟩, supr_mono (λ i, (supr_const_le : _ ≤ p i)) hs⟩

lemma mem_span_finset {s : finset M} {x : M} :
  x ∈ span R (↑s : set M) ↔ ∃ f : M → R, ∑ i in s, f i • i = x :=
⟨λ hx, let ⟨v, hvs, hvx⟩ := (finsupp.mem_span_image_iff_total _).1
    (show x ∈ span R (id '' (↑s : set M)), by rwa set.image_id) in
  ⟨v, hvx ▸ (finsupp.total_apply_of_mem_supported _ hvs).symm⟩,
λ ⟨f, hf⟩, hf ▸ sum_mem (λ i hi, smul_mem _ _ $ subset_span hi)⟩

/-- An element `m ∈ M` is contained in the `R`-submodule spanned by a set `s ⊆ M`, if and only if
`m` can be written as a finite `R`-linear combination of elements of `s`.
The implementation uses `finsupp.sum`. -/
lemma mem_span_set {m : M} {s : set M} :
  m ∈ submodule.span R s ↔ ∃ c : M →₀ R, (c.support : set M) ⊆ s ∧ c.sum (λ mi r, r • mi) = m :=
begin
  conv_lhs { rw ←set.image_id s },
  simp_rw ←exists_prop,
  exact finsupp.mem_span_image_iff_total R,
end

/-- If `subsingleton R`, then `M ≃ₗ[R] ι →₀ R` for any type `ι`. -/
@[simps]
def module.subsingleton_equiv (R M ι: Type*) [semiring R] [subsingleton R] [add_comm_monoid M]
  [module R M] : M ≃ₗ[R] ι →₀ R :=
{ to_fun := λ m, 0,
  inv_fun := λ f, 0,
  left_inv := λ m, by { letI := module.subsingleton R M, simp only [eq_iff_true_of_subsingleton] },
  right_inv := λ f, by simp only [eq_iff_true_of_subsingleton],
  map_add' := λ m n, (add_zero 0).symm,
  map_smul' := λ r m, (smul_zero r).symm }

namespace linear_map

variables {R M} {α : Type*}
open finsupp function

/-- A surjective linear map to finitely supported functions has a splitting. -/
-- See also `linear_map.splitting_of_fun_on_fintype_surjective`
def splitting_of_finsupp_surjective (f : M →ₗ[R] (α →₀ R)) (s : surjective f) : (α →₀ R) →ₗ[R] M :=
finsupp.lift _ _ _ (λ x : α, (s (finsupp.single x 1)).some)

lemma splitting_of_finsupp_surjective_splits (f : M →ₗ[R] (α →₀ R)) (s : surjective f) :
  f.comp (splitting_of_finsupp_surjective f s) = linear_map.id :=
begin
  ext x y,
  dsimp [splitting_of_finsupp_surjective],
  congr,
  rw [sum_single_index, one_smul],
  { exact (s (finsupp.single x 1)).some_spec, },
  { rw zero_smul, },
end

lemma left_inverse_splitting_of_finsupp_surjective (f : M →ₗ[R] (α →₀ R)) (s : surjective f) :
  left_inverse f (splitting_of_finsupp_surjective f s) :=
λ g, linear_map.congr_fun (splitting_of_finsupp_surjective_splits f s) g

lemma splitting_of_finsupp_surjective_injective (f : M →ₗ[R] (α →₀ R)) (s : surjective f) :
  injective (splitting_of_finsupp_surjective f s) :=
(left_inverse_splitting_of_finsupp_surjective f s).injective

/-- A surjective linear map to functions on a finite type has a splitting. -/
-- See also `linear_map.splitting_of_finsupp_surjective`
def splitting_of_fun_on_fintype_surjective [fintype α] (f : M →ₗ[R] (α → R)) (s : surjective f) :
  (α → R) →ₗ[R] M :=
(finsupp.lift _ _ _ (λ x : α, (s (finsupp.single x 1)).some)).comp
  (linear_equiv_fun_on_finite R R α).symm.to_linear_map

lemma splitting_of_fun_on_fintype_surjective_splits
  [fintype α] (f : M →ₗ[R] (α → R)) (s : surjective f) :
  f.comp (splitting_of_fun_on_fintype_surjective f s) = linear_map.id :=
begin
  ext x y,
  dsimp [splitting_of_fun_on_fintype_surjective],
  rw [linear_equiv_fun_on_finite_symm_single, finsupp.sum_single_index, one_smul,
    (s (finsupp.single x 1)).some_spec, finsupp.single_eq_pi_single],
  rw [zero_smul],
end

lemma left_inverse_splitting_of_fun_on_fintype_surjective
  [fintype α] (f : M →ₗ[R] (α → R)) (s : surjective f) :
  left_inverse f (splitting_of_fun_on_fintype_surjective f s) :=
λ g, linear_map.congr_fun (splitting_of_fun_on_fintype_surjective_splits f s) g

lemma splitting_of_fun_on_fintype_surjective_injective
  [fintype α] (f : M →ₗ[R] (α → R)) (s : surjective f) :
  injective (splitting_of_fun_on_fintype_surjective f s) :=
(left_inverse_splitting_of_fun_on_fintype_surjective f s).injective

end linear_map


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.nat.basic
import Mathlib.order.rel_iso
import Mathlib.logic.function.iterate
import Mathlib.PostPort

universes u_1

namespace Mathlib

namespace rel_embedding

/-- If `f` is a strictly `r`-increasing sequence, then this returns `f` as an order embedding. -/
def nat_lt {α : Type u_1} {r : α → α → Prop} [is_strict_order α r] (f : ℕ → α)
    (H : ∀ (n : ℕ), r (f n) (f (n + 1))) : Less ↪r r :=
  of_monotone f sorry

/-- If `f` is a strictly `r`-decreasing sequence, then this returns `f` as an order embedding. -/
def nat_gt {α : Type u_1} {r : α → α → Prop} [is_strict_order α r] (f : ℕ → α)
    (H : ∀ (n : ℕ), r (f (n + 1)) (f n)) : gt ↪r r :=
  rel_embedding.swap (nat_lt f H)

theorem well_founded_iff_no_descending_seq {α : Type u_1} {r : α → α → Prop} [is_strict_order α r] :
    well_founded r ↔ ¬Nonempty (gt ↪r r) :=
  sorry

end Mathlib


import .sub_elim ..clause

namespace nat

@[omega] def dnf_core : form → list clause
| (p ∨* q) := (dnf_core p) ++ (dnf_core q)
| (p ∧* q) :=
  (list.product (dnf_core p) (dnf_core q)).map
  (λ pq, clause.append pq.fst pq.snd)
| (t =* s) :=
  [([term.sub (canonize s) (canonize t)],[])]
| (t ≤* s) := [([],[term.sub (canonize s) (canonize t)])]
| (¬* _)   := []

lemma exists_clause_holds_core {v} :
  ∀ {p : form}, p.neg_free → p.sub_free → p.holds v →
  ∃ c ∈ (dnf_core p), clause.holds (λ x, ↑(v x)) c :=
begin
  form.induce `[intros h1 h0 h2],
  { apply list.exists_mem_cons_of,
    constructor, rw list.forall_mem_singleton,
    cases h0 with ht hs, simp_omega [val_canonize ht, val_canonize hs] at *,
     rw [h2, sub_self], apply list.forall_mem_nil },
  { apply list.exists_mem_cons_of,
    constructor, apply list.forall_mem_nil,
    rw list.forall_mem_singleton,
    simp_omega [val_canonize h0.left, val_canonize h0.right] at *,
    rw [le_sub, sub_zero, int.coe_nat_le], assumption },
  { cases h1 },
  { cases h2 with h2 h2;
    [ {cases (ihp h1.left h0.left h2) with c h3},
      {cases (ihq h1.right h0.right h2) with c h3}];
    cases h3 with h3 h4;
    refine ⟨c, list.mem_append.elim_right _, h4⟩;
    [left,right]; assumption },
  { rcases (ihp h1.left h0.left h2.left) with ⟨cp, hp1, hp2⟩,
    rcases (ihq h1.right h0.right h2.right) with ⟨cq, hq1, hq2⟩,
    constructor, constructor,
    simp_omega, rw list.mem_map,
    constructor, constructor,
    rw list.mem_product, constructor; assumption, refl,
    cases cp with ts1 ts2, cases hp2 with hts1 hts2,
    cases cq with ss1 ss2, cases hq2 with hss1 hss2,
    constructor; rw list.forall_mem_append;
    constructor; assumption }
end

def term.vars_core (is : list int) : list bool :=
is.map (λ i, if i = 0 then ff else tt)

def term.vars (t : term) : list bool :=
term.vars_core t.snd

def bools.or : list bool → list bool → list bool
| []        bs2       := bs2
| bs1       []        := bs1
| (b1::bs1) (b2::bs2) := (b1 || b2)::(bools.or bs1 bs2)

def terms.vars : list term → list bool
| []      := []
| (t::ts) := bools.or (term.vars t) (terms.vars ts)

def nonneg_consts_core : nat → list bool → list term
| _ [] := []
| k (ff::bs) := nonneg_consts_core (k+1) bs
| k (tt::bs) := ⟨0, []{k ↦ 1}⟩::nonneg_consts_core (k+1) bs

def nonneg_consts (bs : list bool) : list term :=
nonneg_consts_core 0 bs

def nonnegate : clause → clause | (eqs,les) :=
let xs := terms.vars eqs in
let ys := terms.vars les in
let bs := bools.or xs ys in
(eqs, nonneg_consts bs ++ les)

def dnf (p : form) : list clause :=
(dnf_core p).map nonnegate

lemma holds_nonneg_consts_core {v : nat → int} (h1 : ∀ x, 0 ≤ v x) :
  ∀ m bs, (∀ t ∈ (nonneg_consts_core m bs), 0 ≤ term.val v t)
| _ []       := λ _ h2, by cases h2
| k (ff::bs) := holds_nonneg_consts_core (k+1) bs
| k (tt::bs) :=
  begin
    apply list.forall_mem_cons_of,
    { simp_omega [one_mul], apply h1 },
    { apply holds_nonneg_consts_core (k+1) bs }
  end

lemma holds_nonneg_consts {v : nat → int} {bs} :
  (∀ x, 0 ≤ v x) → (∀ t ∈ (nonneg_consts bs), 0 ≤ term.val v t)
| h1 :=
by apply holds_nonneg_consts_core h1

lemma exists_clause_holds {v} {p : form} :
  p.neg_free → p.sub_free → p.holds v →
  ∃ c ∈ (dnf p), clause.holds (λ x, ↑(v x)) c :=
begin
  intros h1 h2 h3,
  rcases (exists_clause_holds_core h1 h2 h3) with ⟨c,h4,h5⟩,
  existsi (nonnegate c),
  have h6 : nonnegate c ∈ dnf p,
  { simp only [dnf], rw list.mem_map,
    refine ⟨c,h4,rfl⟩ },
    refine ⟨h6,_⟩, cases c with eqs les,
  simp only [nonnegate, clause.holds],
  constructor, apply h5.left,
  rw list.forall_mem_append,
  apply and.intro (holds_nonneg_consts _) h5.right,
  apply int.coe_nat_nonneg
end

lemma exists_clause_sat {p : form} :
  p.neg_free → p.sub_free →
  p.sat → ∃ c ∈ (dnf p), clause.sat c :=
begin
  intros h1 h2 h3, cases h3 with v h3,
  rcases (exists_clause_holds h1 h2 h3) with ⟨c,h4,h5⟩,
  refine ⟨c,h4,_,h5⟩
end

lemma unsat_of_unsat_dnf (p : form) :
  p.neg_free → p.sub_free → clauses.unsat (dnf p) → p.unsat :=
begin
  intros hnf hsf h1 h2, apply h1,
  apply exists_clause_sat hnf hsf h2
end

end nat


import set_theory.ordinal_arithmetic

universe u

namespace list

/-- Splits a list right after the first element satisfying a predicate. -/
def split_at_pred {α : Type u} (l : list α) (P : α → Prop) [decidable_pred P] : list α × list α :=
l.split_at (l.find_index P).succ

/-- `l.split' k` splits `l` right after the first element equal to `k`. -/
def split_eq {α : Type u} (l : list α) (k : α) [decidable_eq α] : list α × list α :=
l.split_at_pred (eq k)

/-- Splits a list into the bad and good parts. -/
def split_prss : list ℕ → list ℕ × list ℕ
| []             := ([], [])
| (0 :: l)       := ([], l)
| ((n + 1) :: l) := l.split_eq n

/-- Bad part of a list. -/
abbreviation bad_part (l : list ℕ) : list ℕ := l.split_prss.fst

/-- Good part of a list. -/
abbreviation good_part (l : list ℕ) : list ℕ := l.split_prss.snd

/-- The empty list splits into two copies of itself. -/
theorem split_prss_nil : list.nil.split_prss = ([], []) := rfl

/-- The bad and good parts together make the tail. -/
theorem bad_append_good_eq_tail : ∀ l : list ℕ, l.bad_part ++ l.good_part = l.tail
| []             := by refl
| (0 :: l)       := by refl
| ((n + 1) :: l) := begin
    change (split_at _ _).fst ++ (split_at _ _).snd = _,
    rw split_at_eq_take_drop _ l,
    exact take_append_drop _ l
  end

/-- Appends a list to itself `n` times. -/
def cycle {α : Type u} : list α → ℕ → list α
| _ 0       := []
| l (n + 1) := l ++ (l.cycle n)

/-- Cycling a list zero times gives the empty list. -/
theorem cycle_zero {α : Type u} (l : list α) : l.cycle 0 = [] := rfl

/-- Cycling a list once gives itself. -/
theorem cycle_one {α : Type u} (l : list α) : l.cycle 1 = l := l.append_nil

/-- Cycling the empty list gives itself. -/
theorem cycle_nil {α : Type u} : ∀ {n : ℕ}, ([] : list α).cycle n = []
| 0       := by refl
| (n + 1) := by { show nil ++ nil.cycle n = nil, by { rw cycle_nil, refl }}

/-- `l.prss n` performs one step of PrSS expansion, and copies the bad part `n` times. -/
def prss (l : list ℕ) (n : ℕ) : list ℕ :=
l.bad_part.cycle n ++ l.good_part

/-- Leading zeros just get removed. -/
theorem prss_lead_zero (l : list ℕ) {n : ℕ} : (0 :: l).prss n = l :=
begin
  change (0 :: l).prss n with list.cycle [] n ++ _,
  rw cycle_nil,
  refl
end

/-- `l.prss 1` just gives the tail. -/
theorem prss_one (l : list ℕ) : l.prss 1 = l.tail :=
begin
  change l.prss 1 with (list.cycle _ 1) ++ _,
  rw cycle_one,
  exact l.bad_append_good_eq_tail
end

/-- Standard PrSS lists. -/
inductive is_standard : list ℕ → Prop
| base (n : ℕ) : is_standard (list.range n).reverse
| prss (l : list ℕ) (n : ℕ) : is_standard (l.prss n)

/-- Tails of standard lists are standard. -/
theorem tail_standard (l : list ℕ) : is_standard l.tail :=
begin
  convert is_standard.prss l 1,
  exact l.prss_one.symm,
end

/-
def split_on' (l : list ℕ) (n : ℕ) : list (list ℕ) :=
(l.split_on n).map (list.cons n)

noncomputable def ordinal' : list ℕ → ordinal
| [] := 0
| (n :: l) := ((l.split_on' (n + 1)).map (λ m, ordinal.omega ^ ordinal' m)).sum
using_well_founded
-/

/-- Returns the function that applies `g 0`, `g 1`, ... `g (n - 1)` to `f`, starting from `a`. -/
def apply {α β : Type u} (f : α → β → α) (a : α) (g : ℕ → β) : ℕ → α :=
λ n, ((list.range n).map g).foldl f a

/-- PrSS terminates. -/
theorem termination {l : list ℕ} (hl : is_standard l) (g : ℕ → ℕ) :
  ∃ n, apply list.prss l g n = [] :=
sorry

end list


import graph_theory.pushforward graph_theory.path
open function classical

variables {V V' V'' : Type*} {x y z : V} {x' y' z' : V'} {f : V → V'} {g : V' → V''}
variables {G H : simple_graph V} {G' H' : simple_graph V'} {G'' : simple_graph V''}

namespace simple_graph

def adapted (f : V → V') (G : simple_graph V) : Prop :=
∀ ⦃x y : V⦄, f x = f y → ∃ p : walk G x y, ∀ z ∈ p.support, f z = f y

lemma merge_edge_adapted [decidable_eq V] {e : G.dart} : adapted (merge_edge e) G :=
begin
  intros x y hxy, rcases e with ⟨⟨u,v⟩,e⟩, have : u ≠ v := G.ne_of_adj e,
  have l₁ : ∀ {z}, z = u ∨ z = v → merge_edge ⟨⟨_,_⟩,e⟩ z = u :=
    by { intros z hz, cases hz; simp [merge_edge,update,hz] },
  have l₂ : ∀ {z}, ¬(z = u ∨ z = v) → merge_edge ⟨⟨_,_⟩,e⟩ z = z :=
    by { simp [merge_edge,update], intros z hz h', simp [h'] at hz, contradiction },
  by_cases hx : x = u ∨ x = v; by_cases hy : y = u ∨ y = v,
  { cases hx; cases hy; substs x y,
    { use walk.nil, intros z hz, simp at hz, rw hz },
    { use walk.nil.cons e, intros z hz, simp at hz, cases hz; subst hz, exact hxy },
    { use walk.nil.cons e.symm, intros z hz, simp at hz, cases hz; subst hz, exact hxy },
    { use walk.nil, intros z hz, simp at hz, rw hz } },
  { rw [l₁ hx, l₂ hy] at hxy, subst hxy, simp at hy, contradiction },
  { rw [l₁ hy, l₂ hx] at hxy, subst hxy, simp at hx, contradiction },
  { rw [l₂ hx, l₂ hy] at hxy, subst y, use walk.nil, intros z hz, simp at hz, rw hz }
end

namespace adapted

lemma of_injective : injective f → adapted f G :=
begin
  rintro hf x y h, have := hf h, subst this, use walk.nil,
  rintro z, simp only [walk.support_nil, list.mem_singleton], exact congr_arg f
end

noncomputable def lift_path_aux (hf : adapted f G) (p : walk (map f G) x' y') :
  Π (x y : V), f x = x' → f y = y' → {q : walk G x y // ∀ z ∈ q.support, f z ∈ p.support} :=
begin
  induction p with a a b c h₁ p ih,
  { rintros x y h₁ rfl, choose p hp using hf h₁,
    refine ⟨p, λ z hz, _⟩, rw hp z hz, apply walk.start_mem_support },
  { rintro x y rfl rfl, cases h₁ with h₁ h₂,
    choose xx hx using h₂, choose yy hy using hx, rcases hy with ⟨h₂,h₃,h₄⟩,
    choose pp hp using hf h₃.symm, use pp.append (walk.cons h₂ $ ih yy y h₄ rfl),
    rintro z hz, rw [walk.support_append, list.mem_append] at hz, cases hz,
    { left, rw hp z hz, exact h₃ },
    { rw [walk.support_cons, list.tail_cons] at hz, right, exact (ih yy y h₄ rfl).prop z hz } }
end

noncomputable def lift_path (hf : adapted f G) (p : walk (map f G) x' y') :
  Π (x y : V), f x = x' → f y = y' → walk G x y :=
λ x y hx hy, (lift_path_aux hf p x y hx hy).val

lemma mem_lift_path {hf : adapted f G} {p : (map f G).walk x' y'} {hx : f x = x'} {hy : f y = y'} :
  z ∈ (lift_path hf p x y hx hy).support → f z ∈ p.support :=
(lift_path_aux hf p x y hx hy).prop z

noncomputable def lift_path' (hf : adapted f G) (p : walk (map f G) (f x) (f y)) : walk G x y :=
lift_path hf p x y rfl rfl

lemma mem_lift_path' {hf : adapted f G} {p : (map f G).walk (f x) (f y)} :
  z ∈ (lift_path' hf p).support → f z ∈ p.support :=
mem_lift_path

lemma connected (hf : adapted f G) (hc : connected (map f G)) : preconnected G :=
begin
  intros x y, obtain ⟨p⟩ := hc (f x) (f y), use lift_path' hf p
end

lemma fmap (hf : adapted f G) {P} : adapted (select.fmap f P) (select (P ∘ f) G) :=
begin
  rintro ⟨x,hx⟩ ⟨y,hy⟩ hxy, simp only [select.fmap, subtype.coe_mk] at hxy,
  obtain ⟨p,hp⟩ := hf hxy, refine ⟨select.push_walk p _, _⟩,
  { rintro z hz, rw ← hp z hz at hy, exact hy },
  rintro ⟨z,hz⟩ h, simp only [select.fmap, subtype.coe_mk],
  exact hp z (select.mem_push_walk.mp h)
end

lemma comp_push : adapted f G → adapted g (map f G) → adapted (g ∘ f) G :=
begin
  rintro hf hg x y hxy, obtain ⟨p, hp⟩ := hg hxy,
  exact ⟨adapted.lift_path' hf p, λ z hz, hp (f z) (adapted.mem_lift_path' hz)⟩,
end
end adapted

def is_contraction (G : simple_graph V) (G' : simple_graph V') : Prop :=
∃ φ : V' → V, surjective φ ∧ adapted φ G' ∧ G = map φ G'

infix ` ≼c `:50 := is_contraction

namespace is_contraction

@[refl] lemma refl : G ≼c G :=
⟨id,surjective_id,adapted.of_injective injective_id,map.id.symm⟩

lemma of_iso : G ≃g G' → G ≼c G' :=
λ φ, let ψ := φ.symm in ⟨ψ, ψ.surjective, adapted.of_injective ψ.injective, map.from_iso ψ⟩

@[trans] lemma trans : G ≼c G' → G' ≼c G'' → G ≼c G'' :=
begin
  rintros ⟨φ,h₁,h₂,rfl⟩ ⟨ψ,h₄,h₅,rfl⟩,
  exact ⟨φ ∘ ψ, h₁.comp h₄, h₅.comp_push h₂, congr_fun map.comp.symm G''⟩,
end

lemma iso_left : G ≃g G' -> G' ≼c G'' -> G ≼c G'' :=
trans ∘ of_iso

lemma le_left_aux {f : V → V'} : H' ≤ map f G → H' = map f (G ⊓ pull' f H') :=
begin
  intro h₁, ext x' y', split,
  { intro h, rcases h₁ h with ⟨h₄,x,y,h₅,rfl,rfl⟩,
    exact ⟨h₄,x,y,⟨h₅,h₄ ∘ congr_arg f,or.inr h⟩,rfl,rfl⟩ },
  { rintros ⟨h₄,x,y,⟨-,-,h₇⟩,rfl,rfl⟩, cases h₇, contradiction, exact h₇ }
end

lemma le_left_aux2 {f : V → V'} (h₁ : H' ≤ map f G) (h₂ : surjective f) (h₃ : adapted f G) :
  H' ≼c G ⊓ pull' f H' :=
begin
  refine ⟨f,h₂,_,le_left_aux h₁⟩,
  intros x' y' h₄, specialize h₃ h₄,
  cases h₃ with p hp, induction p with a a b c h₅ p ih,
  { use walk.nil, exact hp },
  { have h₆ : f b = f c := by { apply hp, right, exact walk.start_mem_support p },
    have h₇ : ∀ (z : V), z ∈ p.support → f z = f c := by { intros z h, apply hp, right, exact h},
    have h₈ : (G ⊓ pull' f H').adj a b :=
      by { split, exact h₅, refine ⟨G.ne_of_adj h₅,_⟩, left, rwa h₆ },
    specialize ih h₆ h₇, cases ih with q h₉, use walk.cons h₈ q,
    intros z h, cases h, rwa h, exact h₉ z h }
end

lemma le_left : H ≤ G → G ≼c G' → ∃ H' : simple_graph V', H ≼c H' ∧ H' ≤ G' :=
by { rintros h₁ ⟨f,h₂,h₃,rfl⟩, exact ⟨G' ⊓ pull' f H, le_left_aux2 h₁ h₂ h₃, λ x y h, h.1⟩ }

lemma select_left {P : V → Prop} : G ≼c G' -> ∃ P' : V' → Prop, select P G ≼c select P' G' :=
begin
  rintros ⟨f,h₁,h₂,h₃⟩, use (λ x, P (f x)), refine ⟨select.fmap f P, _, h₂.fmap, _⟩,
  { rintro ⟨x,py⟩, cases h₁ x with x', refine ⟨⟨x',_⟩,_⟩, rwa h, ext, exact h },
  { ext ⟨x,hx⟩ ⟨y,hy⟩, simp only [select, pull, on_fun, subtype.val_eq_coe], split,
    { intro h₄, rw h₃ at h₄, rcases h₄ with ⟨h₄,x',y',h₅,h₆,h₇⟩,
      simp only [subtype.coe_mk] at h₆ h₇, substs h₆ h₇,
      refine ⟨_,⟨x',hx⟩,⟨y',hy⟩,h₅,rfl,rfl⟩,
      intro h, rw subtype.ext_iff at h, contradiction },
    { rintros ⟨h₄,⟨x',hx⟩,⟨y',hy⟩,h₅,h₆,h₇⟩, rw h₃, refine ⟨_,x',y',h₅,_,_⟩,
      { intro h, rw ←subtype.ext_iff at h, contradiction },
      { simp only [select.fmap, subtype.map] at h₆, exact h₆ },
      { simp only [select.fmap, subtype.map] at h₇, exact h₇ } } }
end

end is_contraction
end simple_graph


import .add_group_action
import .g_space tactic.ext
import algebra.module linear_algebra.basis

universes u v w
variables (X : Type u) (K : Type v) (V : Type w) (ι : Type*)
[field K] [add_comm_group V] [vector_space K V]

abbreviation affine_space
  (X K V : Type*)
  [field K] [add_comm_group V] [vector_space K V] := add_torsor V X

variables (s : finset ι) (g : ι → K) (v : ι → V) [is_basis K v] [affine_space X K V]

open_locale big_operators

def affine_combination (g_add : ∑ i in s, g i = 1) := ∑ i in s, g i • v i

def barycenter (g_add : ∑ i in s, g i = 1) := g -- TODO: want to coerce g to be a list?

structure affine_frame :=
(origin : X)
(vec : ι → V)
(basis : is_basis K vec)

section affine_with_frame

@[ext]
structure vec_with_frame (frame : affine_frame X K V ι) :=
(vec : V)

structure pt_with_frame (frame : affine_frame X K V ι) :=
(pt : X)

variables (basis : affine_frame X K V ι) (pt : X)

def vecf_add : vec_with_frame X K V ι basis → vec_with_frame X K V ι basis → vec_with_frame X K V ι basis :=
λ x y, ⟨x.1 + y.1⟩

def vecf_neg : vec_with_frame X K V ι basis → vec_with_frame X K V ι basis :=
λ x, ⟨-x.1⟩

def vecf_scalar : K → vec_with_frame X K V ι basis → vec_with_frame X K V ι basis :=
λ c x, ⟨c • x.1⟩

instance : has_add (vec_with_frame X K V ι basis) := ⟨vecf_add X K V ι basis⟩

instance : has_neg (vec_with_frame X K V ι basis) := ⟨vecf_neg X K V ι basis⟩

instance vec_has_zero : has_zero V := by refine add_monoid.to_has_zero V

def vecf_zero : vec_with_frame X K V ι basis := ⟨(vec_has_zero V).zero⟩

instance : has_zero (vec_with_frame X K V ι basis) := ⟨vecf_zero X K V ι basis⟩

instance : has_scalar K (vec_with_frame X K V ι basis) := ⟨vecf_scalar X K V ι basis⟩

#print add_comm_group

lemma vadd_assoc : ∀ x y z : vec_with_frame X K V ι basis, x + y + z = x + (y + z) :=
begin
intros,
cases x, cases y, cases z,
ext,
exact add_assoc x y z,
end

lemma vzero_add : ∀ x : vec_with_frame X K V ι basis, 0 + x = x :=
begin
intros,
cases x,
ext,
exact zero_add x,
end

lemma vadd_zero : ∀ x : vec_with_frame X K V ι basis, x + 0 = x :=
begin
intros,
cases x,
ext,
exact add_zero x,
end

lemma vadd_left_neg : ∀ x : vec_with_frame X K V ι basis, -x + x = 0 :=
begin
intros,
cases x,
ext,
exact add_left_neg x,
end

lemma vadd_comm : ∀ x y : vec_with_frame X K V ι basis, x + y = y + x :=
begin
intros,
cases x, cases y,
ext,
exact add_comm x y,
end

instance : add_comm_group (vec_with_frame X K V ι basis) :=
⟨
  vecf_add X K V ι basis,
  vadd_assoc X K V ι basis,
  vecf_zero X K V ι basis,
  vzero_add X K V ι basis,
  vadd_zero X K V ι basis,
  vecf_neg X K V ι basis,
  vadd_left_neg X K V ι basis,
  vadd_comm X K V ι basis
⟩

#print vector_space
#print semimodule

instance : vector_space K (vec_with_frame X K V ι basis) := sorry

instance : affine_space (pt_with_frame X K V ι basis) K (vec_with_frame X K V ι basis) := sorry

end affine_with_frame


-- Copyright © 2019 François G. Dorais. All rights reserved.
-- Released under Apache 2.0 license as described in the file LICENSE.

import util

namespace universal

@[derive decidable_eq]
structure arity (τ : Type) := (cod : τ) (dom : list τ)

namespace arity
variables {τ : Type} (a b : arity τ)

protected theorem eq : ∀ {a b : arity τ}, a.cod = b.cod → a.dom = b.dom → a = b
| ⟨_,_⟩ ⟨_,_⟩ rfl rfl := rfl

theorem eq_iff : a.cod = b.cod ∧ a.dom = b.dom ↔ a = b :=
⟨λ ⟨hc, hd⟩, arity.eq hc hd, λ h, eq.subst h ⟨rfl, rfl⟩⟩

abbreviation index := index a.dom

abbreviation func (sort : τ → Type*) := (Π (i : a.index), sort i.val) → sort a.cod

end arity

definition signature (τ : Type) (σ : Type*) := σ → arity τ

universe u
variables {τ : Type} {σ : Type u} (sig : signature τ σ)

abbreviation signature.cod (f : σ) : τ := arity.cod (sig f)

abbreviation signature.dom (f : σ) : list τ := arity.dom (sig f)

abbreviation signature.index (f : σ) := arity.index (sig f)

inductive term (dom : list τ) : τ → Type u
| proj {} (i : index dom) : term i.val
| func (f : σ) : (Π (i : sig.index f), term i.val) → term (sig.cod f)

namespace term
variables {sig} {dom : list τ} {cod : τ} (t : term sig dom cod)
include t

abbreviation arity : arity τ := ⟨cod, dom⟩

abbreviation dom : list τ := dom

abbreviation cod : τ := cod

abbreviation index : Type := index dom

end term

structure algebra :=
(sort : τ → Type*)
(func (f : σ) : arity.func (sig f) sort)

definition term_algebra (dom : list τ) : algebra sig :=
{ sort := term sig dom
, func := term.func
}

definition const_algebra : algebra sig := term_algebra sig []

namespace algebra
variables {sig} (alg : algebra sig)

abbreviation valuation (dom : list τ) := Π (i : index dom), alg.sort i.val

definition eval {dom : list τ} : Π {cod : τ} (t : term sig dom cod), (Π (i : index dom), alg.sort i.val) → alg.sort cod
| _ (term.proj i) val := val i
| _ (term.func f ts) val := alg.func f (λ i, eval (ts i) val)

theorem eval_proj {dom : list τ} (i) (val : Π i : index dom, alg.sort i.val) : eval alg (term.proj i) val = val i := rfl

theorem eval_func {dom : list τ} (f) (ts) (val : Π i : index dom, alg.sort i.val) : eval alg (term.func f ts) val = alg.func f (λ i, eval alg (ts i) val) := rfl

end algebra

structure equation (dom : list τ) (cod : τ) := (lhs rhs : term sig dom cod)

namespace equation
variables {sig} {dom : list τ} {cod : τ}

abbreviation func (f) (es : Π (i : sig.index f), equation sig dom i.val) : equation sig dom (sig.cod f) :=
⟨term.func f (λ i, (es i).lhs), term.func f (λ i, (es i).rhs)⟩

end equation

definition equation_algebra (dom : list τ) : algebra sig :=
{ sort := equation sig dom
, func := equation.func
}

end universal


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

! This file was ported from Lean 3 source module category_theory.limits.presheaf
! leanprover-community/mathlib commit 70fd9563a21e7b963887c9360bd29b2393e6225a
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Adjunction.Limits
import Mathbin.CategoryTheory.Adjunction.Opposites
import Mathbin.CategoryTheory.Elements
import Mathbin.CategoryTheory.Limits.FunctorCategory
import Mathbin.CategoryTheory.Limits.KanExtension
import Mathbin.CategoryTheory.Limits.Shapes.Terminal
import Mathbin.CategoryTheory.Limits.Types

/-!
# Colimit of representables

This file constructs an adjunction `yoneda_adjunction` between `(Cᵒᵖ ⥤ Type u)` and `ℰ` given a
functor `A : C ⥤ ℰ`, where the right adjoint sends `(E : ℰ)` to `c ↦ (A.obj c ⟶ E)` (provided `ℰ`
has colimits).

This adjunction is used to show that every presheaf is a colimit of representables.

Further, the left adjoint `colimit_adj.extend_along_yoneda : (Cᵒᵖ ⥤ Type u) ⥤ ℰ` satisfies
`yoneda ⋙ L ≅ A`, that is, an extension of `A : C ⥤ ℰ` to `(Cᵒᵖ ⥤ Type u) ⥤ ℰ` through
`yoneda : C ⥤ Cᵒᵖ ⥤ Type u`. It is the left Kan extension of `A` along the yoneda embedding,
sometimes known as the Yoneda extension, as proved in `extend_along_yoneda_iso_Kan`.

`unique_extension_along_yoneda` shows `extend_along_yoneda` is unique amongst cocontinuous functors
with this property, establishing the presheaf category as the free cocompletion of a small category.

## Tags
colimit, representable, presheaf, free cocompletion

## References
* [S. MacLane, I. Moerdijk, *Sheaves in Geometry and Logic*][MM92]
* https://ncatlab.org/nlab/show/Yoneda+extension
-/

namespace CategoryTheory

noncomputable section

open Category Limits

universe u₁ u₂

variable {C : Type u₁} [SmallCategory C]

variable {ℰ : Type u₂} [Category.{u₁} ℰ]

variable (A : C ⥤ ℰ)

namespace ColimitAdj

/--
The functor taking `(E : ℰ) (c : Cᵒᵖ)` to the homset `(A.obj C ⟶ E)`. It is shown in `L_adjunction`
that this functor has a left adjoint (provided `E` has colimits) given by taking colimits over
categories of elements.
In the case where `ℰ = Cᵒᵖ ⥤ Type u` and `A = yoneda`, this functor is isomorphic to the identity.

Defined as in [MM92], Chapter I, Section 5, Theorem 2.
-/
@[simps]
def restrictedYoneda : ℰ ⥤ Cᵒᵖ ⥤ Type u₁ :=
  yoneda ⋙ (whiskeringLeft _ _ (Type u₁)).obj (Functor.op A)
#align category_theory.colimit_adj.restricted_yoneda CategoryTheory.ColimitAdj.restrictedYoneda

/--
The functor `restricted_yoneda` is isomorphic to the identity functor when evaluated at the yoneda
embedding.
-/
def restrictedYonedaYoneda : restrictedYoneda (yoneda : C ⥤ Cᵒᵖ ⥤ Type u₁) ≅ 𝟭 _ :=
  NatIso.ofComponents
    (fun P =>
      NatIso.ofComponents (fun X => yonedaSectionsSmall X.unop _) fun X Y f =>
        funext fun x => by
          dsimp
          rw [← functor_to_types.naturality _ _ x f (𝟙 _)]
          dsimp
          simp)
    fun _ _ _ => rfl
#align category_theory.colimit_adj.restricted_yoneda_yoneda CategoryTheory.ColimitAdj.restrictedYonedaYoneda

/-- (Implementation). The equivalence of homsets which helps construct the left adjoint to
`colimit_adj.restricted_yoneda`.
It is shown in `restrict_yoneda_hom_equiv_natural` that this is a natural bijection.
-/
def restrictYonedaHomEquiv (P : Cᵒᵖ ⥤ Type u₁) (E : ℰ)
    {c : Cocone ((CategoryOfElements.π P).leftOp ⋙ A)} (t : IsColimit c) :
    (c.pt ⟶ E) ≃ (P ⟶ (restrictedYoneda A).obj E) :=
  ((uliftTrivial _).symm ≪≫ t.homIso' E).toEquiv.trans
    { toFun := fun k =>
        { app := fun c p => k.1 (Opposite.op ⟨_, p⟩)
          naturality' := fun c c' f =>
            funext fun p =>
              (k.2
                  (Quiver.Hom.op ⟨f, rfl⟩ :
                    (Opposite.op ⟨c', P.map f p⟩ : P.Elementsᵒᵖ) ⟶ Opposite.op ⟨c, p⟩)).symm }
      invFun := fun τ =>
        { val := fun p => τ.app p.unop.1 p.unop.2
          property := fun p p' f => by
            simp_rw [← f.unop.2]
            apply (congr_fun (τ.naturality f.unop.1) p'.unop.2).symm }
      left_inv := by
        rintro ⟨k₁, k₂⟩
        ext
        dsimp
        congr 1
        simp
      right_inv := by
        rintro ⟨_, _⟩
        rfl }
#align category_theory.colimit_adj.restrict_yoneda_hom_equiv CategoryTheory.ColimitAdj.restrictYonedaHomEquiv

/--
(Implementation). Show that the bijection in `restrict_yoneda_hom_equiv` is natural (on the right).
-/
theorem restrictYonedaHomEquiv_natural (P : Cᵒᵖ ⥤ Type u₁) (E₁ E₂ : ℰ) (g : E₁ ⟶ E₂) {c : Cocone _}
    (t : IsColimit c) (k : c.pt ⟶ E₁) :
    restrictYonedaHomEquiv A P E₂ t (k ≫ g) =
      restrictYonedaHomEquiv A P E₁ t k ≫ (restrictedYoneda A).map g :=
  by
  ext (_ X p)
  apply (assoc _ _ _).symm
#align category_theory.colimit_adj.restrict_yoneda_hom_equiv_natural CategoryTheory.ColimitAdj.restrictYonedaHomEquiv_natural

variable [HasColimits ℰ]

/--
The left adjoint to the functor `restricted_yoneda` (shown in `yoneda_adjunction`). It is also an
extension of `A` along the yoneda embedding (shown in `is_extension_along_yoneda`), in particular
it is the left Kan extension of `A` through the yoneda embedding.
-/
def extendAlongYoneda : (Cᵒᵖ ⥤ Type u₁) ⥤ ℰ :=
  Adjunction.leftAdjointOfEquiv (fun P E => restrictYonedaHomEquiv A P E (colimit.isColimit _))
    fun P E E' g => restrictYonedaHomEquiv_natural A P E E' g _
#align category_theory.colimit_adj.extend_along_yoneda CategoryTheory.ColimitAdj.extendAlongYoneda

@[simp]
theorem extendAlongYoneda_obj (P : Cᵒᵖ ⥤ Type u₁) :
    (extendAlongYoneda A).obj P = colimit ((CategoryOfElements.π P).leftOp ⋙ A) :=
  rfl
#align category_theory.colimit_adj.extend_along_yoneda_obj CategoryTheory.ColimitAdj.extendAlongYoneda_obj

theorem extendAlongYoneda_map {X Y : Cᵒᵖ ⥤ Type u₁} (f : X ⟶ Y) :
    (extendAlongYoneda A).map f =
      colimit.pre ((CategoryOfElements.π Y).leftOp ⋙ A) (CategoryOfElements.map f).op :=
  by
  ext J
  erw [colimit.ι_pre ((category_of_elements.π Y).leftOp ⋙ A) (category_of_elements.map f).op]
  dsimp only [extend_along_yoneda, restrict_yoneda_hom_equiv, is_colimit.hom_iso',
    is_colimit.hom_iso, ulift_trivial]
  simpa
#align category_theory.colimit_adj.extend_along_yoneda_map CategoryTheory.ColimitAdj.extendAlongYoneda_map

/-- Show `extend_along_yoneda` is left adjoint to `restricted_yoneda`.

The construction of [MM92], Chapter I, Section 5, Theorem 2.
-/
def yonedaAdjunction : extendAlongYoneda A ⊣ restrictedYoneda A :=
  Adjunction.adjunctionOfEquivLeft _ _
#align category_theory.colimit_adj.yoneda_adjunction CategoryTheory.ColimitAdj.yonedaAdjunction

/--
The initial object in the category of elements for a representable functor. In `is_initial` it is
shown that this is initial.
-/
def Elements.initial (A : C) : (yoneda.obj A).Elements :=
  ⟨Opposite.op A, 𝟙 _⟩
#align category_theory.colimit_adj.elements.initial CategoryTheory.ColimitAdj.Elements.initial

/-- Show that `elements.initial A` is initial in the category of elements for the `yoneda` functor.
-/
def isInitial (A : C) : IsInitial (Elements.initial A)
    where
  desc s := ⟨s.pt.2.op, comp_id _⟩
  uniq s m w := by
    simp_rw [← m.2]
    dsimp [elements.initial]
    simp
  fac := by rintro s ⟨⟨⟩⟩
#align category_theory.colimit_adj.is_initial CategoryTheory.ColimitAdj.isInitial

/--
`extend_along_yoneda A` is an extension of `A` to the presheaf category along the yoneda embedding.
`unique_extension_along_yoneda` shows it is unique among functors preserving colimits with this
property (up to isomorphism).

The first part of [MM92], Chapter I, Section 5, Corollary 4.
See Property 1 of <https://ncatlab.org/nlab/show/Yoneda+extension#properties>.
-/
def isExtensionAlongYoneda : (yoneda : C ⥤ Cᵒᵖ ⥤ Type u₁) ⋙ extendAlongYoneda A ≅ A :=
  NatIso.ofComponents
    (fun X =>
      (colimit.isColimit _).coconePointUniqueUpToIso
        (colimitOfDiagramTerminal (terminalOpOfInitial (isInitial _)) _))
    (by
      intro X Y f
      change colimit.desc _ ⟨_, _⟩ ≫ colimit.desc _ _ = colimit.desc _ _ ≫ _
      apply colimit.hom_ext
      intro j
      rw [colimit.ι_desc_assoc, colimit.ι_desc_assoc]
      change (colimit.ι _ _ ≫ 𝟙 _) ≫ colimit.desc _ _ = _
      rw [comp_id, colimit.ι_desc]
      dsimp
      rw [← A.map_comp]
      congr 1)
#align category_theory.colimit_adj.is_extension_along_yoneda CategoryTheory.ColimitAdj.isExtensionAlongYoneda

/-- See Property 2 of https://ncatlab.org/nlab/show/Yoneda+extension#properties. -/
instance : PreservesColimits (extendAlongYoneda A) :=
  (yonedaAdjunction A).leftAdjointPreservesColimits

/-- Show that the images of `X` after `extend_along_yoneda` and `Lan yoneda` are indeed isomorphic.
This follows from `category_theory.category_of_elements.costructured_arrow_yoneda_equivalence`.
-/
@[simps]
def extendAlongYonedaIsoKanApp (X) :
    (extendAlongYoneda A).obj X ≅ ((lan yoneda : (_ ⥤ ℰ) ⥤ _).obj A).obj X :=
  let eq := CategoryOfElements.costructuredArrowYonedaEquivalence X
  { Hom := colimit.pre (Lan.diagram (yoneda : C ⥤ _ ⥤ Type u₁) A X) Eq.Functor
    inv := colimit.pre ((CategoryOfElements.π X).leftOp ⋙ A) Eq.inverse
    hom_inv_id' :=
      by
      erw [colimit.pre_pre ((category_of_elements.π X).leftOp ⋙ A) eq.inverse]
      trans colimit.pre ((category_of_elements.π X).leftOp ⋙ A) (𝟭 _)
      congr
      · exact congr_arg functor.op (category_of_elements.from_to_costructured_arrow_eq X)
      · ext
        simp only [colimit.ι_pre]
        erw [category.comp_id]
        congr
    inv_hom_id' :=
      by
      erw [colimit.pre_pre (Lan.diagram (yoneda : C ⥤ _ ⥤ Type u₁) A X) eq.functor]
      trans colimit.pre (Lan.diagram (yoneda : C ⥤ _ ⥤ Type u₁) A X) (𝟭 _)
      congr
      · exact category_of_elements.to_from_costructured_arrow_eq X
      · ext
        simp only [colimit.ι_pre]
        erw [category.comp_id]
        congr }
#align category_theory.colimit_adj.extend_along_yoneda_iso_Kan_app CategoryTheory.ColimitAdj.extendAlongYonedaIsoKanApp

/-- Verify that `extend_along_yoneda` is indeed the left Kan extension along the yoneda embedding.
-/
@[simps]
def extendAlongYonedaIsoKan : extendAlongYoneda A ≅ (lan yoneda : (_ ⥤ ℰ) ⥤ _).obj A :=
  NatIso.ofComponents (extendAlongYonedaIsoKanApp A)
    (by
      intro X Y f; simp
      rw [extend_along_yoneda_map]
      erw [colimit.pre_pre (Lan.diagram (yoneda : C ⥤ _ ⥤ Type u₁) A Y) (costructured_arrow.map f)]
      erw [colimit.pre_pre (Lan.diagram (yoneda : C ⥤ _ ⥤ Type u₁) A Y)
          (category_of_elements.costructured_arrow_yoneda_equivalence Y).Functor]
      congr 1
      apply category_of_elements.costructured_arrow_yoneda_equivalence_naturality)
#align category_theory.colimit_adj.extend_along_yoneda_iso_Kan CategoryTheory.ColimitAdj.extendAlongYonedaIsoKan

/-- extending `F ⋙ yoneda` along the yoneda embedding is isomorphic to `Lan F.op`. -/
@[simps]
def extendOfCompYonedaIsoLan {D : Type u₁} [SmallCategory D] (F : C ⥤ D) :
    extendAlongYoneda (F ⋙ yoneda) ≅ lan F.op :=
  Adjunction.natIsoOfRightAdjointNatIso (yonedaAdjunction (F ⋙ yoneda))
    (Lan.adjunction (Type u₁) F.op)
    (isoWhiskerRight curriedYonedaLemma' ((whiskeringLeft Cᵒᵖ Dᵒᵖ (Type u₁)).obj F.op : _))
#align category_theory.colimit_adj.extend_of_comp_yoneda_iso_Lan CategoryTheory.ColimitAdj.extendOfCompYonedaIsoLan

end ColimitAdj

open ColimitAdj

/-- `F ⋙ yoneda` is naturally isomorphic to `yoneda ⋙ Lan F.op`. -/
@[simps]
def compYonedaIsoYonedaCompLan {D : Type u₁} [SmallCategory D] (F : C ⥤ D) :
    F ⋙ yoneda ≅ yoneda ⋙ lan F.op :=
  (isExtensionAlongYoneda (F ⋙ yoneda)).symm ≪≫ isoWhiskerLeft yoneda (extendOfCompYonedaIsoLan F)
#align category_theory.comp_yoneda_iso_yoneda_comp_Lan CategoryTheory.compYonedaIsoYonedaCompLan

/-- Since `extend_along_yoneda A` is adjoint to `restricted_yoneda A`, if we use `A = yoneda`
then `restricted_yoneda A` is isomorphic to the identity, and so `extend_along_yoneda A` is as well.
-/
def extendAlongYonedaYoneda : extendAlongYoneda (yoneda : C ⥤ _) ≅ 𝟭 _ :=
  Adjunction.natIsoOfRightAdjointNatIso (yonedaAdjunction _) Adjunction.id restrictedYonedaYoneda
#align category_theory.extend_along_yoneda_yoneda CategoryTheory.extendAlongYonedaYoneda

-- Maybe this should be reducible or an abbreviation?
/-- A functor to the presheaf category in which everything in the image is representable (witnessed
by the fact that it factors through the yoneda embedding).
`cocone_of_representable` gives a cocone for this functor which is a colimit and has point `P`.
-/
def functorToRepresentables (P : Cᵒᵖ ⥤ Type u₁) : P.Elementsᵒᵖ ⥤ Cᵒᵖ ⥤ Type u₁ :=
  (CategoryOfElements.π P).leftOp ⋙ yoneda
#align category_theory.functor_to_representables CategoryTheory.functorToRepresentables

/-- This is a cocone with point `P` for the functor `functor_to_representables P`. It is shown in
`colimit_of_representable P` that this cocone is a colimit: that is, we have exhibited an arbitrary
presheaf `P` as a colimit of representables.

The construction of [MM92], Chapter I, Section 5, Corollary 3.
-/
def coconeOfRepresentable (P : Cᵒᵖ ⥤ Type u₁) : Cocone (functorToRepresentables P) :=
  Cocone.extend (colimit.cocone _) (extendAlongYonedaYoneda.Hom.app P)
#align category_theory.cocone_of_representable CategoryTheory.coconeOfRepresentable

@[simp]
theorem coconeOfRepresentable_pt (P : Cᵒᵖ ⥤ Type u₁) : (coconeOfRepresentable P).pt = P :=
  rfl
#align category_theory.cocone_of_representable_X CategoryTheory.coconeOfRepresentable_pt

-- Marking this as a simp lemma seems to make things more awkward.
/-- An explicit formula for the legs of the cocone `cocone_of_representable`. -/
theorem coconeOfRepresentable_ι_app (P : Cᵒᵖ ⥤ Type u₁) (j : P.Elementsᵒᵖ) :
    (coconeOfRepresentable P).ι.app j = (yonedaSectionsSmall _ _).inv j.unop.2 :=
  colimit.ι_desc _ _
#align category_theory.cocone_of_representable_ι_app CategoryTheory.coconeOfRepresentable_ι_app

/-- The legs of the cocone `cocone_of_representable` are natural in the choice of presheaf. -/
theorem coconeOfRepresentable_naturality {P₁ P₂ : Cᵒᵖ ⥤ Type u₁} (α : P₁ ⟶ P₂) (j : P₁.Elementsᵒᵖ) :
    (coconeOfRepresentable P₁).ι.app j ≫ α =
      (coconeOfRepresentable P₂).ι.app ((CategoryOfElements.map α).op.obj j) :=
  by
  ext (T f)
  simpa [cocone_of_representable_ι_app] using functor_to_types.naturality _ _ α f.op _
#align category_theory.cocone_of_representable_naturality CategoryTheory.coconeOfRepresentable_naturality

/-- The cocone with point `P` given by `the_cocone` is a colimit: that is, we have exhibited an
arbitrary presheaf `P` as a colimit of representables.

The result of [MM92], Chapter I, Section 5, Corollary 3.
-/
def colimitOfRepresentable (P : Cᵒᵖ ⥤ Type u₁) : IsColimit (coconeOfRepresentable P) :=
  by
  apply is_colimit.of_point_iso (colimit.is_colimit (functor_to_representables P))
  change is_iso (colimit.desc _ (cocone.extend _ _))
  rw [colimit.desc_extend, colimit.desc_cocone]
  infer_instance
#align category_theory.colimit_of_representable CategoryTheory.colimitOfRepresentable

/-- Given two functors L₁ and L₂ which preserve colimits, if they agree when restricted to the
representable presheaves then they agree everywhere.
-/
def natIsoOfNatIsoOnRepresentables (L₁ L₂ : (Cᵒᵖ ⥤ Type u₁) ⥤ ℰ) [PreservesColimits L₁]
    [PreservesColimits L₂] (h : yoneda ⋙ L₁ ≅ yoneda ⋙ L₂) : L₁ ≅ L₂ :=
  by
  apply nat_iso.of_components _ _
  · intro P
    refine'
      (is_colimit_of_preserves L₁ (colimit_of_representable P)).coconePointsIsoOfNatIso
        (is_colimit_of_preserves L₂ (colimit_of_representable P)) _
    apply functor.associator _ _ _ ≪≫ _
    exact iso_whisker_left (category_of_elements.π P).leftOp h
  · intro P₁ P₂ f
    apply (is_colimit_of_preserves L₁ (colimit_of_representable P₁)).hom_ext
    intro j
    dsimp only [id.def, is_colimit.cocone_points_iso_of_nat_iso_hom, iso_whisker_left_hom]
    have :
      (L₁.map_cocone (cocone_of_representable P₁)).ι.app j ≫ L₁.map f =
        (L₁.map_cocone (cocone_of_representable P₂)).ι.app
          ((category_of_elements.map f).op.obj j) :=
      by
      dsimp
      rw [← L₁.map_comp, cocone_of_representable_naturality]
      rfl
    rw [reassoc_of this, is_colimit.ι_map_assoc, is_colimit.ι_map]
    dsimp
    rw [← L₂.map_comp, cocone_of_representable_naturality]
    rfl
#align category_theory.nat_iso_of_nat_iso_on_representables CategoryTheory.natIsoOfNatIsoOnRepresentables

variable [HasColimits ℰ]

/-- Show that `extend_along_yoneda` is the unique colimit-preserving functor which extends `A` to
the presheaf category.

The second part of [MM92], Chapter I, Section 5, Corollary 4.
See Property 3 of https://ncatlab.org/nlab/show/Yoneda+extension#properties.
-/
def uniqueExtensionAlongYoneda (L : (Cᵒᵖ ⥤ Type u₁) ⥤ ℰ) (hL : yoneda ⋙ L ≅ A)
    [PreservesColimits L] : L ≅ extendAlongYoneda A :=
  natIsoOfNatIsoOnRepresentables _ _ (hL ≪≫ (isExtensionAlongYoneda _).symm)
#align category_theory.unique_extension_along_yoneda CategoryTheory.uniqueExtensionAlongYoneda

/-- If `L` preserves colimits and `ℰ` has them, then it is a left adjoint. This is a special case of
`is_left_adjoint_of_preserves_colimits` used to prove that.
-/
def isLeftAdjointOfPreservesColimitsAux (L : (Cᵒᵖ ⥤ Type u₁) ⥤ ℰ) [PreservesColimits L] :
    IsLeftAdjoint L where
  right := restrictedYoneda (yoneda ⋙ L)
  adj := (yonedaAdjunction _).ofNatIsoLeft (uniqueExtensionAlongYoneda _ L (Iso.refl _)).symm
#align category_theory.is_left_adjoint_of_preserves_colimits_aux CategoryTheory.isLeftAdjointOfPreservesColimitsAux

/-- If `L` preserves colimits and `ℰ` has them, then it is a left adjoint. Note this is a (partial)
converse to `left_adjoint_preserves_colimits`.
-/
def isLeftAdjointOfPreservesColimits (L : (C ⥤ Type u₁) ⥤ ℰ) [PreservesColimits L] :
    IsLeftAdjoint L :=
  let e : _ ⥤ Type u₁ ≌ _ ⥤ Type u₁ := (opOpEquivalence C).congr_left
  let t := isLeftAdjointOfPreservesColimitsAux (e.Functor ⋙ L : _)
  adjunction.left_adjoint_of_nat_iso (e.inv_fun_id_assoc _)
#align category_theory.is_left_adjoint_of_preserves_colimits CategoryTheory.isLeftAdjointOfPreservesColimits

end CategoryTheory


import algebraic_geometry.Spec
import algebraic_geometry.Scheme
import ring_theory.localization

--open classical
open topological_space
open category_theory
open Top
open opposite
open algebraic_geometry
open algebraic_geometry.Scheme

noncomputable theory

variable (R : CommRing)

-- ring_theory/ideal/basic
local attribute [instance] ideal.comap_is_prime

-- ring_theory/localizations
def at_prime_from_comap {R S : CommRing} (f : R →+* S) (P : ideal S) [hP : P.is_prime]:
localization.at_prime (ideal.comap f P) → localization.at_prime P :=
λ x, sorry

noncomputable
def Spec.of {R S : CommRing} (f : R ⟶ S) :
(Top.of ((Spec S).to_LocallyRingedSpace.to_SheafedSpace.to_PresheafedSpace)) ⟶
(Top.of ((Spec R).to_LocallyRingedSpace.to_SheafedSpace.to_PresheafedSpace)) :=
⟨prime_spectrum.comap f, prime_spectrum.comap_continuous f⟩

-- def Spec.of' {R S : CommRing} (f : R ⟶ S) :
-- (Top.of (prime_spectrum S)) ⟶
-- (Top.of (prime_spectrum R)) :=
-- ⟨prime_spectrum.comap f, prime_spectrum.comap_continuous f⟩

lemma opens.map.Spec.of
{R S : CommRing}
(f : R ⟶ S)
(X : (opens (prime_spectrum R))ᵒᵖ) :
(opens.map (Spec.of f)).op.obj X = op ((opens.comap (Spec.of f).2) (unop X)) :=
rfl

def Spec_hom_of_ring_hom
{R S : CommRing}
(f : R ⟶ S) :
((Spec S).to_LocallyRingedSpace.to_SheafedSpace.to_PresheafedSpace) ⟶
((Spec R).to_LocallyRingedSpace.to_SheafedSpace.to_PresheafedSpace) :=
{ base := Spec.of f,
  c := {
    app := λ X, {
      to_fun := λ a, begin
        rw presheaf.pushforward_obj_obj,
        rcases a with ⟨a, ha⟩,
        refine ⟨_, _⟩,
        { intros x,
          have hx : (Spec.of f).1 x.1 ∈ (unop X) := x.2,
          have h := a ⟨(prime_spectrum.comap f) x.1, hx⟩,
          dsimp only [structure_sheaf.localizations, prime_spectrum.comap] at *,
          dunfold prime_spectrum.as_ideal at *,
          simp at h,
          use (at_prime_from_comap f _ h), },
        { intros x,
          sorry, },
      end,
      map_one' := sorry,
      map_mul' := sorry,
      map_zero' := sorry,
      map_add' := sorry,
    },
    naturality' := sorry,
  } }

-- lemma is_locally_fraction_pred'
--   {U : opens (Spec.Top R)} (f : Π x : U, structure_sheaf.localizations R x) :
--   (structure_sheaf.is_locally_fraction R).to_prelocal_predicate.pred f =
--   ∀ x : U, ∃ (V) (m : x.1 ∈ V) (i : V ⟶ U),
--   ∃ (r s : R), ∀ y : V,
--   ¬ (s ∈ y.1.as_ideal) ∧
--     f (i y : U) * (localization.of _).to_map s = (localization.of _).to_map r :=
-- rfl

def Spec_functor : CommRing ⥤ Schemeᵒᵖ :=
{ obj := λ R, (op (Spec R)),
  map := λ R S f, has_hom.hom.op $
    { val := Spec_hom_of_ring_hom f,
      property := λ x, begin
        sorry,
      end,
    },
  map_id' := sorry,
  map_comp' := sorry,
}

-- noncomputable
-- def SpecF : CommRing ⥤ Schemeᵒᵖ :=
-- { obj := λ R, (op (Spec R)),
--   map := λ R S f, has_hom.hom.op $
--     { val :=
--         { base := Spec.of f,
--           c := {
--             app := λ X, {
--               to_fun := begin
--                 intros a,
--                 rw presheaf.pushforward_obj_obj,
--                 dsimp only [Scheme.to_LocallyRingedSpace] at *,
--                 dsimp only [Spec] at *,
--                 dsimp only [Spec.LocallyRingedSpace] at *,
--                 dsimp only [Spec.SheafedSpace] at *,
--                 dsimp only [structure_sheaf] at *,
--                 dsimp only [structure_presheaf_in_CommRing] at *,
--                 dsimp only [structure_sheaf_in_Type] at *,
--                 dsimp only [subsheaf_to_Types] at *,

--                 simp, --simp at a,
--                 rcases a with ⟨a, ha⟩,
--                 --have h : Π (x : ((opens.map (Spec.of f)).obj (unop X))), structure_sheaf.localizations S x,
--                 --{ sorry, },
--                 refine ⟨_,_⟩,
--                 { intros x,
--                   --have y : (prime_spectrum.comap f) ⁻¹' (unop X).1 := x.1,
--                 --   rcases x with ⟨x, hx⟩,
--                 --   have hx' : (prime_spectrum.comap f) x ∈ (unop X) := hx,
--                 --   have ha' := a ⟨prime_spectrum.comap f x, hx'⟩,
--                 --   rw is_locally_fraction_pred' at ha,
--                 --   have hax := (ha ⟨prime_spectrum.comap f x, hx'⟩),
--                   --rcases hax with ⟨V, H⟩,
--                   --choose V h using hax,
--                   sorry, },
--                 { intros x,
--                   rcases x with ⟨x, hx⟩,
--                   have hx' : (prime_spectrum.comap f) x ∈ (unop X) := hx,
--                   have ha' := a ⟨prime_spectrum.comap f x, hx'⟩,
--                   rw is_locally_fraction_pred' at ha,
--                   have hax := (ha ⟨prime_spectrum.comap f x, hx'⟩),
--                   --rcases hax with ⟨V, m, i, r, s, H⟩,
--                   sorry, }
--               end,
--               map_one' := sorry,
--               map_mul' := sorry,
--               map_zero' := sorry,
--               map_add' := sorry,
--             },
--             naturality' := sorry,
--           } },
--         property := λ x,
--           begin
--             sorry,
--           end },
--   map_id' := sorry,
--   map_comp' := sorry,
-- }


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

! This file was ported from Lean 3 source module representation_theory.fdRep
! leanprover-community/mathlib commit 19a70dceb9dff0994b92d2dd049de7d84d28112b
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.RepresentationTheory.Rep
import Mathbin.Algebra.Category.FgModule.Limits
import Mathbin.CategoryTheory.Preadditive.Schur
import Mathbin.RepresentationTheory.Basic

/-!
# `fdRep k G` is the category of finite dimensional `k`-linear representations of `G`.

If `V : fdRep k G`, there is a coercion that allows you to treat `V` as a type,
and this type comes equipped with `module k V` and `finite_dimensional k V` instances.
Also `V.ρ` gives the homomorphism `G →* (V →ₗ[k] V)`.

Conversely, given a homomorphism `ρ : G →* (V →ₗ[k] V)`,
you can construct the bundled representation as `Rep.of ρ`.

We verify that `fdRep k G` is a `k`-linear monoidal category, and rigid when `G` is a group.

`fdRep k G` has all finite limits.

## TODO
* `fdRep k G ≌ full_subcategory (finite_dimensional k)`
* Upgrade the right rigid structure to a rigid structure
  (this just needs to be done for `fgModule`).
* `fdRep k G` has all finite colimits.
* `fdRep k G` is abelian.
* `fdRep k G ≌ fgModule (monoid_algebra k G)`.

-/

universe u

open CategoryTheory

open CategoryTheory.Limits

/- ./././Mathport/Syntax/Translate/Command.lean:323:31: unsupported: @[derive] abbrev -/
/-- The category of finite dimensional `k`-linear representations of a monoid `G`. -/
abbrev FdRep (k G : Type u) [Field k] [Monoid G] :=
  Action (FgModule.{u} k) (MonCat.of G)
#align fdRep FdRep

namespace FdRep

variable {k G : Type u} [Field k] [Monoid G]

instance : Linear k (FdRep k G) := by infer_instance

instance : CoeSort (FdRep k G) (Type u) :=
  ConcreteCategory.hasCoeToSort _

instance (V : FdRep k G) : AddCommGroup V :=
  by
  change AddCommGroup ((forget₂ (FdRep k G) (FgModule k)).obj V).obj
  infer_instance

instance (V : FdRep k G) : Module k V :=
  by
  change Module k ((forget₂ (FdRep k G) (FgModule k)).obj V).obj
  infer_instance

instance (V : FdRep k G) : FiniteDimensional k V :=
  by
  change FiniteDimensional k ((forget₂ (FdRep k G) (FgModule k)).obj V).obj
  infer_instance

/-- All hom spaces are finite dimensional. -/
instance (V W : FdRep k G) : FiniteDimensional k (V ⟶ W) :=
  FiniteDimensional.of_injective ((forget₂ (FdRep k G) (FgModule k)).mapLinearMap k)
    (Functor.map_injective _)

/-- The monoid homomorphism corresponding to the action of `G` onto `V : fdRep k G`. -/
def ρ (V : FdRep k G) : G →* V →ₗ[k] V :=
  V.ρ
#align fdRep.ρ FdRep.ρ

/-- The underlying `linear_equiv` of an isomorphism of representations. -/
def isoToLinearEquiv {V W : FdRep k G} (i : V ≅ W) : V ≃ₗ[k] W :=
  FgModule.isoToLinearEquiv ((Action.forget (FgModule k) (MonCat.of G)).mapIso i)
#align fdRep.iso_to_linear_equiv FdRep.isoToLinearEquiv

theorem Iso.conj_ρ {V W : FdRep k G} (i : V ≅ W) (g : G) :
    W.ρ g = (FdRep.isoToLinearEquiv i).conj (V.ρ g) :=
  by
  rw [FdRep.isoToLinearEquiv, ← FgModule.Iso.conj_eq_conj, iso.conj_apply]
  rw [iso.eq_inv_comp ((Action.forget (FgModule k) (MonCat.of G)).mapIso i)]
  exact (i.hom.comm g).symm
#align fdRep.iso.conj_ρ FdRep.Iso.conj_ρ

/-- Lift an unbundled representation to `fdRep`. -/
@[simps ρ]
def of {V : Type u} [AddCommGroup V] [Module k V] [FiniteDimensional k V]
    (ρ : Representation k G V) : FdRep k G :=
  ⟨FgModule.of k V, ρ⟩
#align fdRep.of FdRep.of

instance : HasForget₂ (FdRep k G) (Rep k G)
    where forget₂ := (forget₂ (FgModule k) (ModuleCat k)).mapAction (MonCat.of G)

theorem forget₂_ρ (V : FdRep k G) : ((forget₂ (FdRep k G) (Rep k G)).obj V).ρ = V.ρ :=
  by
  ext (g v)
  rfl
#align fdRep.forget₂_ρ FdRep.forget₂_ρ

-- Verify that the monoidal structure is available.
example : MonoidalCategory (FdRep k G) := by infer_instance

example : MonoidalPreadditive (FdRep k G) := by infer_instance

example : MonoidalLinear k (FdRep k G) := by infer_instance

open FiniteDimensional

open Classical

-- We need to provide this instance explicitely as otherwise `finrank_hom_simple_simple` gives a
-- deterministic timeout.
instance : HasKernels (FdRep k G) := by infer_instance

-- Verify that Schur's lemma applies out of the box.
theorem finrank_hom_simple_simple [IsAlgClosed k] (V W : FdRep k G) [Simple V] [Simple W] :
    finrank k (V ⟶ W) = if Nonempty (V ≅ W) then 1 else 0 :=
  CategoryTheory.finrank_hom_simple_simple k V W
#align fdRep.finrank_hom_simple_simple FdRep.finrank_hom_simple_simple

/-- The forgetful functor to `Rep k G` preserves hom-sets and their vector space structure -/
def forget₂HomLinearEquiv (X Y : FdRep k G) :
    ((forget₂ (FdRep k G) (Rep k G)).obj X ⟶ (forget₂ (FdRep k G) (Rep k G)).obj Y) ≃ₗ[k] X ⟶ Y
    where
  toFun f := ⟨f.hom, f.comm⟩
  map_add' _ _ := rfl
  map_smul' _ _ := rfl
  invFun f := ⟨(forget₂ (FgModule k) (ModuleCat k)).map f.hom, f.comm⟩
  left_inv _ := by
    ext
    rfl
  right_inv _ := by
    ext
    rfl
#align fdRep.forget₂_hom_linear_equiv FdRep.forget₂HomLinearEquiv

end FdRep

namespace FdRep

variable {k G : Type u} [Field k] [Group G]

-- Verify that the right rigid structure is available when the monoid is a group.
noncomputable instance : RightRigidCategory (FdRep k G) :=
  by
  change right_rigid_category (Action (FgModule k) (GroupCat.of G))
  infer_instance

end FdRep

namespace FdRep

-- The variables in this section are slightly weird, living half in `representation` and half in
-- `fdRep`. When we have a better API for general monoidal closed and rigid categories and these
-- structures on `fdRep`, we should remove the dependancy of statements about `fdRep` on
-- `representation.lin_hom` and `representation.dual`. The isomorphism `dual_tensor_iso_lin_hom`
-- below should then just be obtained from general results about rigid categories.
open Representation

variable {k G V : Type u} [Field k] [Group G]

variable [AddCommGroup V] [Module k V]

variable [FiniteDimensional k V]

variable (ρV : Representation k G V) (W : FdRep k G)

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/-- Auxiliary definition for `fdRep.dual_tensor_iso_lin_hom`. -/
noncomputable def dualTensorIsoLinHomAux :
    (FdRep.of ρV.dual ⊗ W).V ≅ (FdRep.of (linHom ρV W.ρ)).V :=
  (dualTensorHomEquiv k V W).toFgModuleIso
#align fdRep.dual_tensor_iso_lin_hom_aux FdRep.dualTensorIsoLinHomAux

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/-- When `V` and `W` are finite dimensional representations of a group `G`, the isomorphism
`dual_tensor_hom_equiv k V W` of vector spaces induces an isomorphism of representations. -/
noncomputable def dualTensorIsoLinHom : FdRep.of ρV.dual ⊗ W ≅ FdRep.of (linHom ρV W.ρ) :=
  by
  apply Action.mkIso (dual_tensor_iso_lin_hom_aux ρV W)
  convert dual_tensor_hom_comm ρV W.ρ
#align fdRep.dual_tensor_iso_lin_hom FdRep.dualTensorIsoLinHom

@[simp]
theorem dualTensorIsoLinHom_hom_hom : (dualTensorIsoLinHom ρV W).hom.hom = dualTensorHom k V W :=
  rfl
#align fdRep.dual_tensor_iso_lin_hom_hom_hom FdRep.dualTensorIsoLinHom_hom_hom

end FdRep


/-
Copyright (c) 2018 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Callum Sutton, Yury Kudryashov

! This file was ported from Lean 3 source module algebra.ring.aut
! leanprover-community/mathlib commit 207cfac9fcd06138865b5d04f7091e46d9320432
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Algebra.GroupRingAction.Basic
import Mathlib.Algebra.Hom.Aut
import Mathlib.Algebra.Ring.Equiv

/-!
# Ring automorphisms

This file defines the automorphism group structure on `RingAut R := RingEquiv R R`.

## Implementation notes

The definition of multiplication in the automorphism group agrees with function composition,
multiplication in `Equiv.Perm`, and multiplication in `CategoryTheory.End`, but not with
`CategoryTheory.comp`.

This file is kept separate from `Data/Equiv/Ring` so that `GroupTheory.Perm` is free to use
equivalences (and other files that use them) before the group structure is defined.

## Tags

RingAut
-/

/-- The group of ring automorphisms. -/
@[reducible]
def RingAut (R : Type _) [Mul R] [Add R] :=
  RingEquiv R R
#align ring_aut RingAut

namespace RingAut

section mul_add

variable (R : Type _) [Mul R] [Add R]

/-- The group operation on automorphisms of a ring is defined by
`fun g h => RingEquiv.trans h g`.
This means that multiplication agrees with composition, `(g*h)(x) = g (h x)`.
-/
instance : Group (RingAut R) :=
  { mul := fun g h => RingEquiv.trans h g
    one := RingEquiv.refl R
    inv := RingEquiv.symm
    div := _
    npow := @npowRec _ ⟨RingEquiv.refl R⟩ ⟨fun g h => RingEquiv.trans h g⟩
    zpow :=
      @zpowRec _ ⟨RingEquiv.refl R⟩ ⟨fun g h => RingEquiv.trans h g⟩
        ⟨RingEquiv.symm⟩
    mul_assoc := by intros; rfl
    one_mul := by intros; rfl
    mul_one := by intros; rfl
    mul_left_inv := by intros; ext; apply Equiv.left_inv }
/- Porting note: was by
  refine_struct
    { mul := fun g h => RingEquiv.trans h g
      one := RingEquiv.refl R
      inv := RingEquiv.symm
      div := _
      npow := @npowRec _ ⟨RingEquiv.refl R⟩ ⟨fun g h => RingEquiv.trans h g⟩
      zpow :=
        @zpowRec _ ⟨RingEquiv.refl R⟩ ⟨fun g h => RingEquiv.trans h g⟩
          ⟨RingEquiv.symm⟩ } <;>
    intros <;>
    ext <;>
    try rfl <;>
    apply Equiv.left_inv
 -/

instance : Inhabited (RingAut R) :=
  ⟨1⟩

/-- Monoid homomorphism from ring automorphisms to additive automorphisms. -/
def toAddAut : RingAut R →* AddAut R :=
  { toFun := RingEquiv.toAddEquiv
    map_one' := rfl
    map_mul' := fun _ _ => rfl }
  -- Porting note: old proof was
  --`by refine_struct { toFun := RingEquiv.toAddEquiv } <;> intros <;> rfl`
#align ring_aut.to_add_aut RingAut.toAddAut

/-- Monoid homomorphism from ring automorphisms to multiplicative automorphisms. -/
def toMulAut : RingAut R →* MulAut R :=
  { toFun := RingEquiv.toMulEquiv
    map_one' := rfl
    map_mul' := fun _ _ => rfl }
  --Porting note: old proof was
  --=`by refine_struct { toFun := RingEquiv.toMulEquiv } <;> intros <;> rfl`
#align ring_aut.to_mul_aut RingAut.toMulAut

/-- Monoid homomorphism from ring automorphisms to permutations. -/
def toPerm : RingAut R →* Equiv.Perm R :=
  { toFun := RingEquiv.toEquiv
    map_one' := rfl
    map_mul' := fun _ _ => rfl }
  -- Porting note: old proof was
  --`by refine_struct { toFun := RingEquiv.toEquiv } <;> intros <;> rfl`
#align ring_aut.to_perm RingAut.toPerm

end mul_add

section Semiring

variable {G R : Type _} [Group G] [Semiring R]

/-- The tautological action by the group of automorphism of a ring `R` on `R`.-/
instance applyMulSemiringAction :
    MulSemiringAction (RingAut R) R where
  smul := (· <| ·)
  smul_zero := RingEquiv.map_zero
  smul_add := RingEquiv.map_add
  smul_one := RingEquiv.map_one
  smul_mul := RingEquiv.map_mul
  one_smul _ := rfl
  mul_smul _ _ _ := rfl
#align ring_aut.apply_mul_semiring_action RingAut.applyMulSemiringAction

@[simp]
protected theorem smul_def (f : RingAut R) (r : R) : f • r = f r :=
  rfl
#align ring_aut.smul_def RingAut.smul_def

instance apply_faithfulSMul : FaithfulSMul (RingAut R) R :=
  ⟨RingEquiv.ext⟩
#align ring_aut.apply_has_faithful_smul RingAut.apply_faithfulSMul

variable (G R)

/-- Each element of the group defines a ring automorphism.

This is a stronger version of `DistribMulAction.toAddAut` and
`MulDistribMulAction.toMulAut`. -/
@[simps]
def _root_.MulSemiringAction.toRingAut [MulSemiringAction G R] :
    G →* RingAut R where
  toFun := MulSemiringAction.toRingEquiv G R
  map_mul' g h := RingEquiv.ext <| mul_smul g h
  map_one' := RingEquiv.ext <| one_smul _
#align mul_semiring_action.to_ring_aut MulSemiringAction.toRingAut
#align mul_semiring_action.to_ring_aut_apply MulSemiringAction.toRingAut_apply

end Semiring

end RingAut