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

! This file was ported from Lean 3 source module category_theory.sites.left_exact
! leanprover-community/mathlib commit 59382264386afdbaf1727e617f5fdda511992eb9
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Sites.Sheafification
import Mathbin.CategoryTheory.Sites.Limits
import Mathbin.CategoryTheory.Limits.FunctorCategory
import Mathbin.CategoryTheory.Limits.FilteredColimitCommutesFiniteLimit

/-!
# Left exactness of sheafification
In this file we show that sheafification commutes with finite limits.
-/

open CategoryTheory

open CategoryTheory.Limits

open Opposite

universe w v u

variable {C : Type max v u} [Category.{v} C] {J : GrothendieckTopology C}

variable {D : Type w} [Category.{max v u} D]

variable [∀ (P : Cᵒᵖ ⥤ D) (X : C) (S : J.cover X), HasMultiequalizer (S.index P)]

noncomputable section

namespace CategoryTheory.GrothendieckTopology

/-- An auxiliary definition to be used in the proof of the fact that
`J.diagram_functor D X` preserves limits. -/
@[simps]
def coneCompEvaluationOfConeCompDiagramFunctorCompEvaluation {X : C} {K : Type max v u}
    [SmallCategory K] {F : K ⥤ Cᵒᵖ ⥤ D} {W : J.cover X} (i : W.arrow)
    (E : Cone (F ⋙ J.diagramFunctor D X ⋙ (evaluation (J.cover X)ᵒᵖ D).obj (op W))) :
    Cone (F ⋙ (evaluation _ _).obj (op i.y))
    where
  pt := E.pt
  π :=
    { app := fun k => E.π.app k ≫ Multiequalizer.ι (W.index (F.obj k)) i
      naturality' := by
        intro a b f
        dsimp
        rw [category.id_comp, category.assoc, ← E.w f]
        dsimp [diagram_nat_trans]
        simp only [multiequalizer.lift_ι, category.assoc] }
#align category_theory.grothendieck_topology.cone_comp_evaluation_of_cone_comp_diagram_functor_comp_evaluation CategoryTheory.GrothendieckTopology.coneCompEvaluationOfConeCompDiagramFunctorCompEvaluation

/-- An auxiliary definition to be used in the proof of the fact that
`J.diagram_functor D X` preserves limits. -/
abbrev liftToDiagramLimitObj {X : C} {K : Type max v u} [SmallCategory K] [HasLimitsOfShape K D]
    {W : (J.cover X)ᵒᵖ} (F : K ⥤ Cᵒᵖ ⥤ D)
    (E : Cone (F ⋙ J.diagramFunctor D X ⋙ (evaluation (J.cover X)ᵒᵖ D).obj W)) :
    E.pt ⟶ (J.diagram (limit F) X).obj W :=
  Multiequalizer.lift _ _
    (fun i =>
      (isLimitOfPreserves ((evaluation _ _).obj (op i.y)) (limit.isLimit _)).lift
        (coneCompEvaluationOfConeCompDiagramFunctorCompEvaluation i E))
    (by
      intro i
      change (_ ≫ _) ≫ _ = (_ ≫ _) ≫ _
      dsimp [evaluate_combined_cones]
      erw [category.comp_id, category.comp_id, category.assoc, category.assoc, ←
        (limit.lift F _).naturality, ← (limit.lift F _).naturality, ← category.assoc, ←
        category.assoc]
      congr 1; ext1
      erw [category.assoc, category.assoc, limit.lift_π, limit.lift_π, limit.lift_π_assoc,
        limit.lift_π_assoc, category.assoc, category.assoc, multiequalizer.condition]
      rfl)
#align category_theory.grothendieck_topology.lift_to_diagram_limit_obj CategoryTheory.GrothendieckTopology.liftToDiagramLimitObj

instance (X : C) (K : Type max v u) [SmallCategory K] [HasLimitsOfShape K D] (F : K ⥤ Cᵒᵖ ⥤ D) :
    PreservesLimit F (J.diagramFunctor D X) :=
  preservesLimitOfEvaluation _ _ fun W =>
    preservesLimitOfPreservesLimitCone (limit.isLimit _)
      { lift := fun E => liftToDiagramLimitObj F E
        fac := by
          intro E k
          dsimp [diagram_nat_trans]
          ext1
          simp only [multiequalizer.lift_ι, multiequalizer.lift_ι_assoc, category.assoc]
          change (_ ≫ _) ≫ _ = _
          dsimp [evaluate_combined_cones]
          erw [category.comp_id, category.assoc, ← nat_trans.comp_app, limit.lift_π, limit.lift_π]
          rfl
        uniq := by
          intro E m hm
          ext
          delta lift_to_diagram_limit_obj
          erw [multiequalizer.lift_ι, category.assoc]
          change _ = (_ ≫ _) ≫ _
          dsimp [evaluate_combined_cones]
          erw [category.comp_id, category.assoc, ← nat_trans.comp_app, limit.lift_π, limit.lift_π]
          dsimp
          rw [← hm]
          dsimp [diagram_nat_trans]
          simp }

instance (X : C) (K : Type max v u) [SmallCategory K] [HasLimitsOfShape K D] :
    PreservesLimitsOfShape K (J.diagramFunctor D X) :=
  ⟨⟩

instance (X : C) [HasLimits D] : PreservesLimits (J.diagramFunctor D X) :=
  ⟨⟩

variable [∀ X : C, HasColimitsOfShape (J.cover X)ᵒᵖ D]

variable [ConcreteCategory.{max v u} D]

variable [∀ X : C, PreservesColimitsOfShape (J.cover X)ᵒᵖ (forget D)]

/-- An auxiliary definition to be used in the proof that `J.plus_functor D` commutes
with finite limits. -/
def liftToPlusObjLimitObj {K : Type max v u} [SmallCategory K] [FinCategory K]
    [HasLimitsOfShape K D] [PreservesLimitsOfShape K (forget D)]
    [ReflectsLimitsOfShape K (forget D)] (F : K ⥤ Cᵒᵖ ⥤ D) (X : C)
    (S : Cone (F ⋙ J.plusFunctor D ⋙ (evaluation Cᵒᵖ D).obj (op X))) :
    S.pt ⟶ (J.plusObj (limit F)).obj (op X) :=
  let e := colimitLimitIso (F ⋙ J.diagramFunctor D X)
  let t : J.diagram (limit F) X ≅ limit (F ⋙ J.diagramFunctor D X) :=
    (isLimitOfPreserves (J.diagramFunctor D X) (limit.isLimit _)).conePointUniqueUpToIso
      (limit.isLimit _)
  let p : (J.plusObj (limit F)).obj (op X) ≅ colimit (limit (F ⋙ J.diagramFunctor D X)) :=
    HasColimit.isoOfNatIso t
  let s :
    colimit (F ⋙ J.diagramFunctor D X).flip ≅ F ⋙ J.plusFunctor D ⋙ (evaluation Cᵒᵖ D).obj (op X) :=
    NatIso.ofComponents (fun k => colimitObjIsoColimitCompEvaluation _ k)
      (by
        intro i j f
        rw [← iso.eq_comp_inv, category.assoc, ← iso.inv_comp_eq]
        ext w
        dsimp [plus_map]
        erw [colimit.ι_map_assoc,
          colimit_obj_iso_colimit_comp_evaluation_ι_inv (F ⋙ J.diagram_functor D X).flip w j,
          colimit_obj_iso_colimit_comp_evaluation_ι_inv_assoc (F ⋙ J.diagram_functor D X).flip w i]
        rw [← (colimit.ι (F ⋙ J.diagram_functor D X).flip w).naturality]
        rfl)
  limit.lift _ S ≫ (HasLimit.isoOfNatIso s.symm).Hom ≫ e.inv ≫ p.inv
#align category_theory.grothendieck_topology.lift_to_plus_obj_limit_obj CategoryTheory.GrothendieckTopology.liftToPlusObjLimitObj

-- This lemma should not be used directly. Instead, one should use the fact that
-- `J.plus_functor D` preserves finite limits, along with the fact that
-- evaluation preserves limits.
theorem liftToPlusObjLimitObj_fac {K : Type max v u} [SmallCategory K] [FinCategory K]
    [HasLimitsOfShape K D] [PreservesLimitsOfShape K (forget D)]
    [ReflectsLimitsOfShape K (forget D)] (F : K ⥤ Cᵒᵖ ⥤ D) (X : C)
    (S : Cone (F ⋙ J.plusFunctor D ⋙ (evaluation Cᵒᵖ D).obj (op X))) (k) :
    liftToPlusObjLimitObj F X S ≫ (J.plusMap (limit.π F k)).app (op X) = S.π.app k :=
  by
  dsimp only [lift_to_plus_obj_limit_obj]
  rw [← (limit.is_limit (F ⋙ J.plus_functor D ⋙ (evaluation Cᵒᵖ D).obj (op X))).fac S k,
    category.assoc]
  congr 1
  dsimp
  simp only [category.assoc]
  rw [← iso.eq_inv_comp, iso.inv_comp_eq, iso.inv_comp_eq]
  ext
  dsimp [plus_map]
  simp only [has_colimit.iso_of_nat_iso_ι_hom_assoc, ι_colim_map]
  dsimp [is_limit.cone_point_unique_up_to_iso, has_limit.iso_of_nat_iso, is_limit.map]
  rw [limit.lift_π]
  dsimp
  rw [ι_colimit_limit_iso_limit_π_assoc]
  simp_rw [← nat_trans.comp_app, ← category.assoc, ← nat_trans.comp_app]
  rw [limit.lift_π, category.assoc]
  congr 1
  rw [← iso.comp_inv_eq]
  erw [colimit.ι_desc]
  rfl
#align category_theory.grothendieck_topology.lift_to_plus_obj_limit_obj_fac CategoryTheory.GrothendieckTopology.liftToPlusObjLimitObj_fac

instance (K : Type max v u) [SmallCategory K] [FinCategory K] [HasLimitsOfShape K D]
    [PreservesLimitsOfShape K (forget D)] [ReflectsLimitsOfShape K (forget D)] :
    PreservesLimitsOfShape K (J.plusFunctor D) :=
  by
  constructor; intro F; apply preserves_limit_of_evaluation; intro X
  apply preserves_limit_of_preserves_limit_cone (limit.is_limit F)
  refine' ⟨fun S => lift_to_plus_obj_limit_obj F X.unop S, _, _⟩
  · intro S k
    apply lift_to_plus_obj_limit_obj_fac
  · intro S m hm
    dsimp [lift_to_plus_obj_limit_obj]
    simp_rw [← category.assoc, iso.eq_comp_inv, ← iso.comp_inv_eq]
    ext
    simp only [limit.lift_π, category.assoc, ← hm]
    congr 1
    ext
    dsimp [plus_map, plus_obj]
    erw [colimit.ι_map, colimit.ι_desc_assoc, limit.lift_π]
    dsimp
    simp only [category.assoc]
    rw [ι_colimit_limit_iso_limit_π_assoc]
    simp only [nat_iso.of_components_inv_app, colimit_obj_iso_colimit_comp_evaluation_ι_app_hom,
      iso.symm_inv]
    dsimp [is_limit.cone_point_unique_up_to_iso]
    rw [← category.assoc, ← nat_trans.comp_app, limit.lift_π]
    rfl

instance [HasFiniteLimits D] [PreservesFiniteLimits (forget D)] [ReflectsIsomorphisms (forget D)] :
    PreservesFiniteLimits (J.plusFunctor D) :=
  by
  apply preservesFiniteLimitsOfPreservesFiniteLimitsOfSize.{max v u}
  intro K _ _
  haveI : reflects_limits_of_shape K (forget D) := reflects_limits_of_shape_of_reflects_isomorphisms
  infer_instance

instance (K : Type max v u) [SmallCategory K] [FinCategory K] [HasLimitsOfShape K D]
    [PreservesLimitsOfShape K (forget D)] [ReflectsLimitsOfShape K (forget D)] :
    PreservesLimitsOfShape K (J.sheafification D) :=
  Limits.compPreservesLimitsOfShape _ _

instance [HasFiniteLimits D] [PreservesFiniteLimits (forget D)] [ReflectsIsomorphisms (forget D)] :
    PreservesFiniteLimits (J.sheafification D) :=
  Limits.compPreservesFiniteLimits _ _

end CategoryTheory.GrothendieckTopology

namespace CategoryTheory

variable [∀ X : C, HasColimitsOfShape (J.cover X)ᵒᵖ D]

variable [ConcreteCategory.{max v u} D]

variable [∀ X : C, PreservesColimitsOfShape (J.cover X)ᵒᵖ (forget D)]

variable [PreservesLimits (forget D)]

variable [ReflectsIsomorphisms (forget D)]

variable (K : Type max v u)

variable [SmallCategory K] [FinCategory K] [HasLimitsOfShape K D]

instance : PreservesLimitsOfShape K (presheafToSheaf J D) :=
  by
  constructor; intro F; constructor; intro S hS
  apply is_limit_of_reflects (Sheaf_to_presheaf J D)
  haveI : reflects_limits_of_shape K (forget D) := reflects_limits_of_shape_of_reflects_isomorphisms
  apply is_limit_of_preserves (J.sheafification D) hS

instance [HasFiniteLimits D] : PreservesFiniteLimits (presheafToSheaf J D) :=
  by
  apply preservesFiniteLimitsOfPreservesFiniteLimitsOfSize.{max v u}
  intros ; skip; infer_instance

end CategoryTheory


/-
Copyright (c) 2021 Anne Baanen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Anne Baanen
-/
import logic.function.iterate
import order.galois_connection
import order.hom.basic

/-!
# Lattice structure on order homomorphisms

This file defines the lattice structure on order homomorphisms, which are bundled
monotone functions.

## Main definitions

 * `order_hom.complete_lattice`: if `β` is a complete lattice, so is `α →o β`

## Tags

monotone map, bundled morphism
-/

namespace order_hom

variables {α β : Type*}

section preorder

variables [preorder α]

@[simps]
instance [semilattice_sup β] : has_sup (α →o β) :=
{ sup := λ f g, ⟨λ a, f a ⊔ g a, f.mono.sup g.mono⟩ }

instance [semilattice_sup β] : semilattice_sup (α →o β) :=
{ sup := has_sup.sup,
  le_sup_left := λ a b x, le_sup_left,
  le_sup_right := λ a b x, le_sup_right,
  sup_le := λ a b c h₀ h₁ x, sup_le (h₀ x) (h₁ x),
  .. (_ : partial_order (α →o β)) }

@[simps]
instance [semilattice_inf β] : has_inf (α →o β) :=
{ inf := λ f g, ⟨λ a, f a ⊓ g a, f.mono.inf g.mono⟩ }

instance [semilattice_inf β] : semilattice_inf (α →o β) :=
{ inf := (⊓),
  .. (_ : partial_order (α →o β)),
  .. (dual_iso α β).symm.to_galois_insertion.lift_semilattice_inf }

instance [lattice β] : lattice (α →o β) :=
{ .. (_ : semilattice_sup (α →o β)),
  .. (_ : semilattice_inf (α →o β)) }

@[simps]
instance [preorder β] [order_bot β] : has_bot (α →o β) :=
{ bot := const α ⊥ }

instance [preorder β] [order_bot β] : order_bot (α →o β) :=
{ bot := ⊥,
  bot_le := λ a x, bot_le }

@[simps]
instance [preorder β] [order_top β] : has_top (α →o β) :=
{ top := const α ⊤ }

instance [preorder β] [order_top β] : order_top (α →o β) :=
{ top := ⊤,
  le_top := λ a x, le_top }

instance [complete_lattice β] : has_Inf (α →o β) :=
{ Inf := λ s, ⟨λ x, ⨅ f ∈ s, (f : _) x, λ x y h, binfi_le_binfi (λ f _, f.mono h)⟩ }

@[simp] lemma Inf_apply [complete_lattice β] (s : set (α →o β)) (x : α) :
  Inf s x = ⨅ f ∈ s, (f : _) x := rfl

lemma infi_apply {ι : Sort*} [complete_lattice β] (f : ι → α →o β) (x : α) :
  (⨅ i, f i) x = ⨅ i, f i x :=
(Inf_apply _ _).trans infi_range

@[simp, norm_cast] lemma coe_infi {ι : Sort*} [complete_lattice β] (f : ι → α →o β) :
  ((⨅ i, f i : α →o β) : α → β) = ⨅ i, f i :=
funext $ λ x, (infi_apply f x).trans (@_root_.infi_apply _ _ _ _ (λ i, f i) _).symm

instance [complete_lattice β] : has_Sup (α →o β) :=
{ Sup := λ s, ⟨λ x, ⨆ f ∈ s, (f : _) x, λ x y h, bsupr_le_bsupr (λ f _, f.mono h)⟩ }

@[simp] lemma Sup_apply [complete_lattice β] (s : set (α →o β)) (x : α) :
  Sup s x = ⨆ f ∈ s, (f : _) x := rfl

lemma supr_apply {ι : Sort*} [complete_lattice β] (f : ι → α →o β) (x : α) :
  (⨆ i, f i) x = ⨆ i, f i x :=
(Sup_apply _ _).trans supr_range

@[simp, norm_cast] lemma coe_supr {ι : Sort*} [complete_lattice β] (f : ι → α →o β) :
  ((⨆ i, f i : α →o β) : α → β) = ⨆ i, f i :=
funext $ λ x, (supr_apply f x).trans (@_root_.supr_apply _ _ _ _ (λ i, f i) _).symm

instance [complete_lattice β] : complete_lattice (α →o β) :=
{ Sup := Sup,
  le_Sup := λ s f hf x, le_supr_of_le f (le_supr _ hf),
  Sup_le := λ s f hf x, bsupr_le (λ g hg, hf g hg x),
  Inf := Inf,
  le_Inf := λ s f hf x, le_binfi (λ g hg, hf g hg x),
  Inf_le := λ s f hf x, infi_le_of_le f (infi_le _ hf),
  .. (_ : lattice (α →o β)),
  .. order_hom.order_top,
  .. order_hom.order_bot }

lemma iterate_sup_le_sup_iff {α : Type*} [semilattice_sup α] (f : α →o α) :
  (∀ n₁ n₂ a₁ a₂, f^[n₁ + n₂] (a₁ ⊔ a₂) ≤ (f^[n₁] a₁) ⊔ (f^[n₂] a₂)) ↔
  (∀ a₁ a₂, f (a₁ ⊔ a₂) ≤ (f a₁) ⊔ a₂) :=
begin
  split; intros h,
  { exact h 1 0, },
  { intros n₁ n₂ a₁ a₂, have h' : ∀ n a₁ a₂, f^[n] (a₁ ⊔ a₂) ≤ (f^[n] a₁) ⊔ a₂,
    { intros n, induction n with n ih; intros a₁ a₂,
      { refl, },
      { calc f^[n + 1] (a₁ ⊔ a₂) = (f^[n] (f (a₁ ⊔ a₂))) : function.iterate_succ_apply f n _
                             ... ≤ (f^[n] ((f a₁) ⊔ a₂)) : f.mono.iterate n (h a₁ a₂)
                             ... ≤ (f^[n] (f a₁)) ⊔ a₂ : ih _ _
                             ... = (f^[n + 1] a₁) ⊔ a₂ : by rw ← function.iterate_succ_apply, }, },
    calc f^[n₁ + n₂] (a₁ ⊔ a₂) = (f^[n₁] (f^[n₂] (a₁ ⊔ a₂))) : function.iterate_add_apply f n₁ n₂ _
                           ... = (f^[n₁] (f^[n₂] (a₂ ⊔ a₁))) : by rw sup_comm
                           ... ≤ (f^[n₁] ((f^[n₂] a₂) ⊔ a₁)) : f.mono.iterate n₁ (h' n₂ _ _)
                           ... = (f^[n₁] (a₁ ⊔ (f^[n₂] a₂))) : by rw sup_comm
                           ... ≤ (f^[n₁] a₁) ⊔ (f^[n₂] a₂) : h' n₁ a₁ _, },
end

end preorder

end order_hom


/-
Copyright (c) 2018 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau, Mario Carneiro
-/

import group_theory.congruence
import algebra.module.submodule.bilinear

/-!
# Tensor product of modules over commutative semirings.

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

This file constructs the tensor product of modules over commutative semirings. Given a semiring
`R` and modules over it `M` and `N`, the standard construction of the tensor product is
`tensor_product R M N`. It is also a module over `R`.

It comes with a canonical bilinear map `M → N → tensor_product R M N`.

Given any bilinear map `M → N → P`, there is a unique linear map `tensor_product R M N → P` whose
composition with the canonical bilinear map `M → N → tensor_product R M N` is the given bilinear
map `M → N → P`.

We start by proving basic lemmas about bilinear maps.

## Notations

This file uses the localized notation `M ⊗ N` and `M ⊗[R] N` for `tensor_product R M N`, as well
as `m ⊗ₜ n` and `m ⊗ₜ[R] n` for `tensor_product.tmul R m n`.

## Tags

bilinear, tensor, tensor product
-/

section semiring
variables {R : Type*} [comm_semiring R]
variables {R' : Type*} [monoid R']
variables {R'' : Type*} [semiring R'']
variables {M : Type*} {N : Type*} {P : Type*} {Q : Type*} {S : Type*}

variables [add_comm_monoid M] [add_comm_monoid N] [add_comm_monoid P] [add_comm_monoid Q]
  [add_comm_monoid S]
variables [module R M] [module R N] [module R P] [module R Q] [module R S]
variables [distrib_mul_action R' M]
variables [module R'' M]
include R

variables (M N)

namespace tensor_product

section
-- open free_add_monoid
variables (R)

/-- The relation on `free_add_monoid (M × N)` that generates a congruence whose quotient is
the tensor product. -/
inductive eqv : free_add_monoid (M × N) → free_add_monoid (M × N) → Prop
| of_zero_left : ∀ n : N, eqv (free_add_monoid.of (0, n)) 0
| of_zero_right : ∀ m : M, eqv (free_add_monoid.of (m, 0)) 0
| of_add_left : ∀ (m₁ m₂ : M) (n : N), eqv
    (free_add_monoid.of (m₁, n) + free_add_monoid.of (m₂, n)) (free_add_monoid.of (m₁ + m₂, n))
| of_add_right : ∀ (m : M) (n₁ n₂ : N), eqv
    (free_add_monoid.of (m, n₁) + free_add_monoid.of (m, n₂)) (free_add_monoid.of (m, n₁ + n₂))
| of_smul : ∀ (r : R) (m : M) (n : N), eqv
    (free_add_monoid.of (r • m, n)) (free_add_monoid.of (m, r • n))
| add_comm : ∀ x y, eqv (x + y) (y + x)
end

end tensor_product

variables (R)

/-- The tensor product of two modules `M` and `N` over the same commutative semiring `R`.
The localized notations are `M ⊗ N` and `M ⊗[R] N`, accessed by `open_locale tensor_product`. -/
def tensor_product : Type* :=
(add_con_gen (tensor_product.eqv R M N)).quotient

variables {R}

localized "infix (name := tensor_product.infer)
  ` ⊗ `:100 := tensor_product hole!" in tensor_product
localized "notation (name := tensor_product)
  M ` ⊗[`:100 R `] `:0 N:100 := tensor_product R M N" in tensor_product

namespace tensor_product

section module

instance : add_zero_class (M ⊗[R] N) :=
{ .. (add_con_gen (tensor_product.eqv R M N)).add_monoid }

instance : add_comm_semigroup (M ⊗[R] N) :=
{ add_comm := λ x y, add_con.induction_on₂ x y $ λ x y, quotient.sound' $
    add_con_gen.rel.of _ _ $ eqv.add_comm _ _,
  .. (add_con_gen (tensor_product.eqv R M N)).add_monoid }

instance : inhabited (M ⊗[R] N) := ⟨0⟩

variables (R) {M N}
/-- The canonical function `M → N → M ⊗ N`. The localized notations are `m ⊗ₜ n` and `m ⊗ₜ[R] n`,
accessed by `open_locale tensor_product`. -/
def tmul (m : M) (n : N) : M ⊗[R] N := add_con.mk' _ $ free_add_monoid.of (m, n)
variables {R}

infix ` ⊗ₜ `:100 := tmul _
notation x ` ⊗ₜ[`:100 R `] `:0 y:100 := tmul R x y

@[elab_as_eliminator]
protected theorem induction_on
  {C : (M ⊗[R] N) → Prop}
  (z : M ⊗[R] N)
  (C0 : C 0)
  (C1 : ∀ {x y}, C $ x ⊗ₜ[R] y)
  (Cp : ∀ {x y}, C x → C y → C (x + y)) : C z :=
add_con.induction_on z $ λ x, free_add_monoid.rec_on x C0 $ λ ⟨m, n⟩ y ih,
by { rw add_con.coe_add, exact Cp C1 ih }

variables (M)
@[simp] lemma zero_tmul (n : N) : (0 : M) ⊗ₜ[R] n = 0 :=
quotient.sound' $ add_con_gen.rel.of _ _ $ eqv.of_zero_left _
variables {M}

lemma add_tmul (m₁ m₂ : M) (n : N) : (m₁ + m₂) ⊗ₜ n = m₁ ⊗ₜ n + m₂ ⊗ₜ[R] n :=
eq.symm $ quotient.sound' $ add_con_gen.rel.of _ _ $ eqv.of_add_left _ _ _

variables (N)
@[simp] lemma tmul_zero (m : M) : m ⊗ₜ[R] (0 : N) = 0 :=
quotient.sound' $ add_con_gen.rel.of _ _ $ eqv.of_zero_right _
variables {N}

lemma tmul_add (m : M) (n₁ n₂ : N) : m ⊗ₜ (n₁ + n₂) = m ⊗ₜ n₁ + m ⊗ₜ[R] n₂ :=
eq.symm $ quotient.sound' $ add_con_gen.rel.of _ _ $ eqv.of_add_right _ _ _

section

variables (R R' M N)

/--
A typeclass for `has_smul` structures which can be moved across a tensor product.

This typeclass is generated automatically from a `is_scalar_tower` instance, but exists so that
we can also add an instance for `add_comm_group.int_module`, allowing `z •` to be moved even if
`R` does not support negation.

Note that `module R' (M ⊗[R] N)` is available even without this typeclass on `R'`; it's only
needed if `tensor_product.smul_tmul`, `tensor_product.smul_tmul'`, or `tensor_product.tmul_smul` is
used.
-/
class compatible_smul [distrib_mul_action R' N] :=
(smul_tmul : ∀ (r : R') (m : M) (n : N), (r • m) ⊗ₜ n = m ⊗ₜ[R] (r • n))

end

/-- Note that this provides the default `compatible_smul R R M N` instance through
`mul_action.is_scalar_tower.left`. -/
@[priority 100]
instance compatible_smul.is_scalar_tower
  [has_smul R' R] [is_scalar_tower R' R M] [distrib_mul_action R' N] [is_scalar_tower R' R N] :
  compatible_smul R R' M N :=
⟨λ r m n, begin
  conv_lhs {rw ← one_smul R m},
  conv_rhs {rw ← one_smul R n},
  rw [←smul_assoc, ←smul_assoc],
  exact (quotient.sound' $ add_con_gen.rel.of _ _ $ eqv.of_smul _ _ _),
end⟩

/-- `smul` can be moved from one side of the product to the other .-/
lemma smul_tmul [distrib_mul_action R' N] [compatible_smul R R' M N] (r : R') (m : M) (n : N) :
  (r • m) ⊗ₜ n = m ⊗ₜ[R] (r • n) :=
compatible_smul.smul_tmul _ _ _

/-- Auxiliary function to defining scalar multiplication on tensor product. -/
def smul.aux {R' : Type*} [has_smul R' M] (r : R') : free_add_monoid (M × N) →+ M ⊗[R] N :=
free_add_monoid.lift $ λ p : M × N, (r • p.1) ⊗ₜ p.2

theorem smul.aux_of {R' : Type*} [has_smul R' M] (r : R') (m : M) (n : N) :
  smul.aux r (free_add_monoid.of (m, n)) = (r • m) ⊗ₜ[R] n :=
rfl

variables [smul_comm_class R R' M]
variables [smul_comm_class R R'' M]

/-- Given two modules over a commutative semiring `R`, if one of the factors carries a
(distributive) action of a second type of scalars `R'`, which commutes with the action of `R`, then
the tensor product (over `R`) carries an action of `R'`.

This instance defines this `R'` action in the case that it is the left module which has the `R'`
action. Two natural ways in which this situation arises are:
 * Extension of scalars
 * A tensor product of a group representation with a module not carrying an action

Note that in the special case that `R = R'`, since `R` is commutative, we just get the usual scalar
action on a tensor product of two modules. This special case is important enough that, for
performance reasons, we define it explicitly below. -/
instance left_has_smul : has_smul R' (M ⊗[R] N) :=
⟨λ r, (add_con_gen (tensor_product.eqv R M N)).lift (smul.aux r : _ →+ M ⊗[R] N) $
add_con.add_con_gen_le $ λ x y hxy, match x, y, hxy with
| _, _, (eqv.of_zero_left n)       := (add_con.ker_rel _).2 $
    by simp_rw [add_monoid_hom.map_zero, smul.aux_of, smul_zero, zero_tmul]
| _, _, (eqv.of_zero_right m)      := (add_con.ker_rel _).2 $
    by simp_rw [add_monoid_hom.map_zero, smul.aux_of, tmul_zero]
| _, _, (eqv.of_add_left m₁ m₂ n)  := (add_con.ker_rel _).2 $
    by simp_rw [add_monoid_hom.map_add, smul.aux_of, smul_add, add_tmul]
| _, _, (eqv.of_add_right m n₁ n₂) := (add_con.ker_rel _).2 $
    by simp_rw [add_monoid_hom.map_add, smul.aux_of, tmul_add]
| _, _, (eqv.of_smul s m n)        := (add_con.ker_rel _).2 $
    by rw [smul.aux_of, smul.aux_of, ←smul_comm, smul_tmul]
| _, _, (eqv.add_comm x y)         := (add_con.ker_rel _).2 $
    by simp_rw [add_monoid_hom.map_add, add_comm]
end⟩

instance : has_smul R (M ⊗[R] N) := tensor_product.left_has_smul

protected theorem smul_zero (r : R') : (r • 0 : M ⊗[R] N) = 0 :=
add_monoid_hom.map_zero _

protected theorem smul_add (r : R') (x y : M ⊗[R] N) :
  r • (x + y) = r • x + r • y :=
add_monoid_hom.map_add _ _ _

protected theorem zero_smul (x : M ⊗[R] N) : (0 : R'') • x = 0 :=
have ∀ (r : R'') (m : M) (n : N), r • (m ⊗ₜ[R] n) = (r • m) ⊗ₜ n := λ _ _ _, rfl,
tensor_product.induction_on x
  (by rw tensor_product.smul_zero)
  (λ m n, by rw [this, zero_smul, zero_tmul])
  (λ x y ihx ihy, by rw [tensor_product.smul_add, ihx, ihy, add_zero])

protected theorem one_smul (x : M ⊗[R] N) : (1 : R') • x = x :=
have ∀ (r : R') (m : M) (n : N), r • (m ⊗ₜ[R] n) = (r • m) ⊗ₜ n := λ _ _ _, rfl,
tensor_product.induction_on x
  (by rw tensor_product.smul_zero)
  (λ m n, by rw [this, one_smul])
  (λ x y ihx ihy, by rw [tensor_product.smul_add, ihx, ihy])

protected theorem add_smul (r s : R'') (x : M ⊗[R] N) : (r + s) • x = r • x + s • x :=
have ∀ (r : R'') (m : M) (n : N), r • (m ⊗ₜ[R] n) = (r • m) ⊗ₜ n := λ _ _ _, rfl,
tensor_product.induction_on x
  (by simp_rw [tensor_product.smul_zero, add_zero])
  (λ m n, by simp_rw [this, add_smul, add_tmul])
  (λ x y ihx ihy, by { simp_rw tensor_product.smul_add, rw [ihx, ihy, add_add_add_comm] })

instance : add_comm_monoid (M ⊗[R] N) :=
{ nsmul := λ n v, n • v,
  nsmul_zero' := by simp [tensor_product.zero_smul],
  nsmul_succ' := by simp [nat.succ_eq_one_add, tensor_product.one_smul, tensor_product.add_smul],
  .. tensor_product.add_comm_semigroup _ _, .. tensor_product.add_zero_class _ _}

instance left_distrib_mul_action : distrib_mul_action R' (M ⊗[R] N) :=
have ∀ (r : R') (m : M) (n : N), r • (m ⊗ₜ[R] n) = (r • m) ⊗ₜ n := λ _ _ _, rfl,
{ smul := (•),
  smul_add := λ r x y, tensor_product.smul_add r x y,
  mul_smul := λ r s x, tensor_product.induction_on x
    (by simp_rw tensor_product.smul_zero)
    (λ m n, by simp_rw [this, mul_smul])
    (λ x y ihx ihy, by { simp_rw tensor_product.smul_add, rw [ihx, ihy] }),
  one_smul := tensor_product.one_smul,
  smul_zero := tensor_product.smul_zero }

instance : distrib_mul_action R (M ⊗[R] N) := tensor_product.left_distrib_mul_action

theorem smul_tmul' (r : R') (m : M) (n : N) :
  r • (m ⊗ₜ[R] n) = (r • m) ⊗ₜ n :=
rfl

@[simp] lemma tmul_smul
  [distrib_mul_action R' N] [compatible_smul R R' M N] (r : R') (x : M) (y : N) :
  x ⊗ₜ (r • y) = r • (x ⊗ₜ[R] y) :=
(smul_tmul _ _ _).symm

lemma smul_tmul_smul (r s : R) (m : M) (n : N) : (r • m) ⊗ₜ[R] (s • n) = (r * s) • (m ⊗ₜ[R] n) :=
by simp only [tmul_smul, smul_tmul, mul_smul]

instance left_module : module R'' (M ⊗[R] N) :=
{ smul := (•),
  add_smul := tensor_product.add_smul,
  zero_smul := tensor_product.zero_smul,
  ..tensor_product.left_distrib_mul_action }

instance : module R (M ⊗[R] N) := tensor_product.left_module

instance [module R''ᵐᵒᵖ M] [is_central_scalar R'' M] : is_central_scalar R'' (M ⊗[R] N) :=
{ op_smul_eq_smul := λ r x,
  tensor_product.induction_on x
    (by rw [smul_zero, smul_zero])
    (λ x y, by rw [smul_tmul', smul_tmul', op_smul_eq_smul])
    (λ x y hx hy, by rw [smul_add, smul_add, hx, hy]) }

section

-- Like `R'`, `R'₂` provides a `distrib_mul_action R'₂ (M ⊗[R] N)`
variables {R'₂ : Type*} [monoid R'₂] [distrib_mul_action R'₂ M]
variables [smul_comm_class R R'₂ M] [has_smul R'₂ R']

/-- `is_scalar_tower R'₂ R' M` implies `is_scalar_tower R'₂ R' (M ⊗[R] N)` -/
instance is_scalar_tower_left [is_scalar_tower R'₂ R' M] :
  is_scalar_tower R'₂ R' (M ⊗[R] N) :=
⟨λ s r x, tensor_product.induction_on x
  (by simp)
  (λ m n, by rw [smul_tmul', smul_tmul', smul_tmul', smul_assoc])
  (λ x y ihx ihy, by rw [smul_add, smul_add, smul_add, ihx, ihy])⟩

variables [distrib_mul_action R'₂ N] [distrib_mul_action R' N]
variables [compatible_smul R R'₂ M N] [compatible_smul R R' M N]

/-- `is_scalar_tower R'₂ R' N` implies `is_scalar_tower R'₂ R' (M ⊗[R] N)` -/
instance is_scalar_tower_right [is_scalar_tower R'₂ R' N] :
    is_scalar_tower R'₂ R' (M ⊗[R] N) :=
⟨λ s r x, tensor_product.induction_on x
  (by simp)
  (λ m n, by rw [←tmul_smul, ←tmul_smul, ←tmul_smul, smul_assoc])
  (λ x y ihx ihy, by rw [smul_add, smul_add, smul_add, ihx, ihy])⟩

end

/-- A short-cut instance for the common case, where the requirements for the `compatible_smul`
instances are sufficient. -/
instance is_scalar_tower [has_smul R' R] [is_scalar_tower R' R M] :
  is_scalar_tower R' R (M ⊗[R] N) :=
tensor_product.is_scalar_tower_left  -- or right

variables (R M N)
/-- The canonical bilinear map `M → N → M ⊗[R] N`. -/
def mk : M →ₗ[R] N →ₗ[R] M ⊗[R] N :=
linear_map.mk₂ R (⊗ₜ) add_tmul (λ c m n, by rw [smul_tmul, tmul_smul]) tmul_add tmul_smul
variables {R M N}

@[simp] lemma mk_apply (m : M) (n : N) : mk R M N m n = m ⊗ₜ n := rfl

lemma ite_tmul (x₁ : M) (x₂ : N) (P : Prop) [decidable P] :
  (if P then x₁ else 0) ⊗ₜ[R] x₂ = if P then x₁ ⊗ₜ x₂ else 0 :=
by { split_ifs; simp }

lemma tmul_ite (x₁ : M) (x₂ : N) (P : Prop) [decidable P] :
  x₁ ⊗ₜ[R] (if P then x₂ else 0) = if P then x₁ ⊗ₜ x₂ else 0 :=
by { split_ifs; simp }

section
open_locale big_operators

lemma sum_tmul {α : Type*} (s : finset α) (m : α → M) (n : N) :
  (∑ a in s, m a) ⊗ₜ[R] n = ∑ a in s, m a ⊗ₜ[R] n :=
begin
  classical,
  induction s using finset.induction with a s has ih h,
  { simp, },
  { simp [finset.sum_insert has, add_tmul, ih], },
end

lemma tmul_sum (m : M) {α : Type*} (s : finset α) (n : α → N) :
  m ⊗ₜ[R] (∑ a in s, n a) = ∑ a in s, m ⊗ₜ[R] n a :=
begin
  classical,
  induction s using finset.induction with a s has ih h,
  { simp, },
  { simp [finset.sum_insert has, tmul_add, ih], },
end
end

variables (R M N)

/-- The simple (aka pure) elements span the tensor product. -/
lemma span_tmul_eq_top :
  submodule.span R { t : M ⊗[R] N | ∃ m n, m ⊗ₜ n = t } = ⊤ :=
begin
  ext t, simp only [submodule.mem_top, iff_true],
  apply t.induction_on,
  { exact submodule.zero_mem _, },
  { intros m n, apply submodule.subset_span, use [m, n], },
  { intros t₁ t₂ ht₁ ht₂, exact submodule.add_mem _ ht₁ ht₂, },
end

@[simp] lemma map₂_mk_top_top_eq_top : submodule.map₂ (mk R M N) ⊤ ⊤ = ⊤ :=
begin
  rw [← top_le_iff, ← span_tmul_eq_top, submodule.map₂_eq_span_image2],
  exact submodule.span_mono (λ _ ⟨m, n, h⟩, ⟨m, n, trivial, trivial, h⟩),
end

end module

section UMP

variables {M N P Q}
variables (f : M →ₗ[R] N →ₗ[R] P)

/-- Auxiliary function to constructing a linear map `M ⊗ N → P` given a bilinear map `M → N → P`
with the property that its composition with the canonical bilinear map `M → N → M ⊗ N` is
the given bilinear map `M → N → P`. -/
def lift_aux : (M ⊗[R] N) →+ P :=
(add_con_gen (tensor_product.eqv R M N)).lift (free_add_monoid.lift $ λ p : M × N, f p.1 p.2) $
add_con.add_con_gen_le $ λ x y hxy, match x, y, hxy with
| _, _, (eqv.of_zero_left n)       := (add_con.ker_rel _).2 $
    by simp_rw [add_monoid_hom.map_zero, free_add_monoid.lift_eval_of, f.map_zero₂]
| _, _, (eqv.of_zero_right m)      := (add_con.ker_rel _).2 $
    by simp_rw [add_monoid_hom.map_zero, free_add_monoid.lift_eval_of, (f m).map_zero]
| _, _, (eqv.of_add_left m₁ m₂ n)  := (add_con.ker_rel _).2 $
    by simp_rw [add_monoid_hom.map_add, free_add_monoid.lift_eval_of, f.map_add₂]
| _, _, (eqv.of_add_right m n₁ n₂) := (add_con.ker_rel _).2 $
    by simp_rw [add_monoid_hom.map_add, free_add_monoid.lift_eval_of, (f m).map_add]
| _, _, (eqv.of_smul r m n)        := (add_con.ker_rel _).2 $
    by simp_rw [free_add_monoid.lift_eval_of, f.map_smul₂, (f m).map_smul]
| _, _, (eqv.add_comm x y)         := (add_con.ker_rel _).2 $
    by simp_rw [add_monoid_hom.map_add, add_comm]
end

lemma lift_aux_tmul (m n) : lift_aux f (m ⊗ₜ n) = f m n := rfl

variable {f}

@[simp] lemma lift_aux.smul (r : R) (x) : lift_aux f (r • x) = r • lift_aux f x :=
tensor_product.induction_on x (smul_zero _).symm
  (λ p q, by rw [← tmul_smul, lift_aux_tmul, lift_aux_tmul, (f p).map_smul])
  (λ p q ih1 ih2, by rw [smul_add, (lift_aux f).map_add, ih1, ih2, (lift_aux f).map_add, smul_add])

variable (f)
/-- Constructing a linear map `M ⊗ N → P` given a bilinear map `M → N → P` with the property that
its composition with the canonical bilinear map `M → N → M ⊗ N` is
the given bilinear map `M → N → P`. -/
def lift : M ⊗ N →ₗ[R] P :=
{ map_smul' := lift_aux.smul,
  .. lift_aux f }
variable {f}

@[simp] lemma lift.tmul (x y) : lift f (x ⊗ₜ y) = f x y := rfl
@[simp] lemma lift.tmul' (x y) : (lift f).1 (x ⊗ₜ y) = f x y := rfl

theorem ext' {g h : (M ⊗[R] N) →ₗ[R] P}
  (H : ∀ x y, g (x ⊗ₜ y) = h (x ⊗ₜ y)) : g = h :=
linear_map.ext $ λ z, tensor_product.induction_on z (by simp_rw linear_map.map_zero) H $
λ x y ihx ihy, by rw [g.map_add, h.map_add, ihx, ihy]

theorem lift.unique {g : (M ⊗[R] N) →ₗ[R] P} (H : ∀ x y, g (x ⊗ₜ y) = f x y) :
  g = lift f :=
ext' $ λ m n, by rw [H, lift.tmul]

theorem lift_mk : lift (mk R M N) = linear_map.id :=
eq.symm $ lift.unique $ λ x y, rfl

theorem lift_compr₂ (g : P →ₗ[R] Q) : lift (f.compr₂ g) = g.comp (lift f) :=
eq.symm $ lift.unique $ λ x y, by simp

theorem lift_mk_compr₂ (f : M ⊗ N →ₗ[R] P) : lift ((mk R M N).compr₂ f) = f :=
by rw [lift_compr₂ f, lift_mk, linear_map.comp_id]

/--
This used to be an `@[ext]` lemma, but it fails very slowly when the `ext` tactic tries to apply
it in some cases, notably when one wants to show equality of two linear maps. The `@[ext]`
attribute is now added locally where it is needed. Using this as the `@[ext]` lemma instead of
`tensor_product.ext'` allows `ext` to apply lemmas specific to `M →ₗ _` and `N →ₗ _`.

See note [partially-applied ext lemmas]. -/
theorem ext {g h : M ⊗ N →ₗ[R] P}
  (H : (mk R M N).compr₂ g = (mk R M N).compr₂ h) : g = h :=
by rw [← lift_mk_compr₂ g, H, lift_mk_compr₂]

local attribute [ext] ext

example : M → N → (M → N → P) → P :=
λ m, flip $ λ f, f m

variables (R M N P)
/-- Linearly constructing a linear map `M ⊗ N → P` given a bilinear map `M → N → P`
with the property that its composition with the canonical bilinear map `M → N → M ⊗ N` is
the given bilinear map `M → N → P`. -/
def uncurry : (M →ₗ[R] N →ₗ[R] P) →ₗ[R] M ⊗[R] N →ₗ[R] P :=
linear_map.flip $ lift $ (linear_map.lflip _ _ _ _).comp (linear_map.flip linear_map.id)
variables {R M N P}

@[simp] theorem uncurry_apply (f : M →ₗ[R] N →ₗ[R] P) (m : M) (n : N) :
  uncurry R M N P f (m ⊗ₜ n) = f m n :=
by rw [uncurry, linear_map.flip_apply, lift.tmul]; refl

variables (R M N P)
/-- A linear equivalence constructing a linear map `M ⊗ N → P` given a bilinear map `M → N → P`
with the property that its composition with the canonical bilinear map `M → N → M ⊗ N` is
the given bilinear map `M → N → P`. -/
def lift.equiv : (M →ₗ[R] N →ₗ[R] P) ≃ₗ[R] (M ⊗ N →ₗ[R] P) :=
{ inv_fun := λ f, (mk R M N).compr₂ f,
  left_inv := λ f, linear_map.ext₂ $ λ m n, lift.tmul _ _,
  right_inv := λ f, ext' $ λ m n, lift.tmul _ _,
  .. uncurry R M N P }

@[simp] lemma lift.equiv_apply (f : M →ₗ[R] N →ₗ[R] P) (m : M) (n : N) :
  lift.equiv R M N P f (m ⊗ₜ n) = f m n :=
uncurry_apply f m n

@[simp] lemma lift.equiv_symm_apply (f : M ⊗[R] N →ₗ[R] P) (m : M) (n : N) :
  (lift.equiv R M N P).symm f m n = f (m ⊗ₜ n) :=
rfl

/-- Given a linear map `M ⊗ N → P`, compose it with the canonical bilinear map `M → N → M ⊗ N` to
form a bilinear map `M → N → P`. -/
def lcurry : (M ⊗[R] N →ₗ[R] P) →ₗ[R] M →ₗ[R] N →ₗ[R] P :=
(lift.equiv R M N P).symm
variables {R M N P}

@[simp] theorem lcurry_apply (f : M ⊗[R] N →ₗ[R] P) (m : M) (n : N) :
  lcurry R M N P f m n = f (m ⊗ₜ n) := rfl

/-- Given a linear map `M ⊗ N → P`, compose it with the canonical bilinear map `M → N → M ⊗ N` to
form a bilinear map `M → N → P`. -/
def curry (f : M ⊗ N →ₗ[R] P) : M →ₗ[R] N →ₗ[R] P := lcurry R M N P f

@[simp] theorem curry_apply (f : M ⊗ N →ₗ[R] P) (m : M) (n : N) :
  curry f m n = f (m ⊗ₜ n) := rfl

lemma curry_injective : function.injective (curry : (M ⊗[R] N →ₗ[R] P) → (M →ₗ[R] N →ₗ[R] P)) :=
λ g h H, ext H

theorem ext_threefold {g h : (M ⊗[R] N) ⊗[R] P →ₗ[R] Q}
  (H : ∀ x y z, g ((x ⊗ₜ y) ⊗ₜ z) = h ((x ⊗ₜ y) ⊗ₜ z)) : g = h :=
begin
  ext x y z,
  exact H x y z
end

-- We'll need this one for checking the pentagon identity!
theorem ext_fourfold {g h : ((M ⊗[R] N) ⊗[R] P) ⊗[R] Q →ₗ[R] S}
  (H : ∀ w x y z, g (((w ⊗ₜ x) ⊗ₜ y) ⊗ₜ z) = h (((w ⊗ₜ x) ⊗ₜ y) ⊗ₜ z)) : g = h :=
begin
  ext w x y z,
  exact H w x y z,
end

/-- Two linear maps (M ⊗ N) ⊗ (P ⊗ Q) → S which agree on all elements of the
form (m ⊗ₜ n) ⊗ₜ (p ⊗ₜ q) are equal. -/
theorem ext_fourfold' {φ ψ : (M ⊗[R] N) ⊗[R] (P ⊗[R] Q) →ₗ[R] S}
  (H : ∀ w x y z, φ ((w ⊗ₜ x) ⊗ₜ (y ⊗ₜ z)) = ψ ((w ⊗ₜ x) ⊗ₜ (y ⊗ₜ z))) : φ = ψ :=
begin
  ext m n p q,
  exact H m n p q,
end

end UMP

variables {M N}
section
variables (R M)

/--
The base ring is a left identity for the tensor product of modules, up to linear equivalence.
-/
protected def lid : R ⊗ M ≃ₗ[R] M :=
linear_equiv.of_linear (lift $ linear_map.lsmul R M) (mk R R M 1)
  (linear_map.ext $ λ _, by simp)
  (ext' $ λ r m, by simp; rw [← tmul_smul, ← smul_tmul, smul_eq_mul, mul_one])
end

@[simp] theorem lid_tmul (m : M) (r : R) :
  ((tensor_product.lid R M) : (R ⊗ M → M)) (r ⊗ₜ m) = r • m :=
begin
  dsimp [tensor_product.lid],
  simp,
end

@[simp] lemma lid_symm_apply (m : M) :
  (tensor_product.lid R M).symm m = 1 ⊗ₜ m := rfl

section
variables (R M N)

/--
The tensor product of modules is commutative, up to linear equivalence.
-/
protected def comm : M ⊗ N ≃ₗ[R] N ⊗ M :=
linear_equiv.of_linear (lift (mk R N M).flip) (lift (mk R M N).flip)
  (ext' $ λ m n, rfl)
  (ext' $ λ m n, rfl)

@[simp] theorem comm_tmul (m : M) (n : N) :
  (tensor_product.comm R M N) (m ⊗ₜ n) = n ⊗ₜ m := rfl

@[simp] theorem comm_symm_tmul (m : M) (n : N) :
  (tensor_product.comm R M N).symm (n ⊗ₜ m) = m ⊗ₜ n := rfl

end

section
variables (R M)

/--
The base ring is a right identity for the tensor product of modules, up to linear equivalence.
-/
protected def rid : M ⊗[R] R ≃ₗ[R] M :=
linear_equiv.trans (tensor_product.comm R M R) (tensor_product.lid R M)
end

@[simp] theorem rid_tmul (m : M) (r : R) :
  (tensor_product.rid R M) (m ⊗ₜ r) = r • m :=
begin
  dsimp [tensor_product.rid, tensor_product.comm, tensor_product.lid],
  simp,
end

@[simp] lemma rid_symm_apply (m : M) :
  (tensor_product.rid R M).symm m = m ⊗ₜ 1 := rfl

open linear_map
section
variables (R M N P)

/-- The associator for tensor product of R-modules, as a linear equivalence. -/
protected def assoc : (M ⊗[R] N) ⊗[R] P ≃ₗ[R] M ⊗[R] (N ⊗[R] P) :=
begin
  refine linear_equiv.of_linear
    (lift $ lift $ comp (lcurry R _ _ _) $ mk _ _ _)
    (lift $ comp (uncurry R _ _ _) $ curry $ mk _ _ _)
    (ext $ linear_map.ext $ λ m, ext' $ λ n p, _)
    (ext $ flip_inj $ linear_map.ext $ λ p, ext' $ λ m n, _);
  repeat { rw lift.tmul <|> rw compr₂_apply <|> rw comp_apply <|>
    rw mk_apply <|> rw flip_apply <|> rw lcurry_apply <|>
    rw uncurry_apply <|> rw curry_apply <|> rw id_apply }
end
end

@[simp] theorem assoc_tmul (m : M) (n : N) (p : P) :
  (tensor_product.assoc R M N P) ((m ⊗ₜ n) ⊗ₜ p) = m ⊗ₜ (n ⊗ₜ p) := rfl

@[simp] theorem assoc_symm_tmul (m : M) (n : N) (p : P) :
  (tensor_product.assoc R M N P).symm (m ⊗ₜ (n ⊗ₜ p)) = (m ⊗ₜ n) ⊗ₜ p := rfl

/-- The tensor product of a pair of linear maps between modules. -/
def map (f : M →ₗ[R] P) (g : N →ₗ[R] Q) : M ⊗ N →ₗ[R] P ⊗ Q :=
lift $ comp (compl₂ (mk _ _ _) g) f

@[simp] theorem map_tmul (f : M →ₗ[R] P) (g : N →ₗ[R] Q) (m : M) (n : N) :
  map f g (m ⊗ₜ n) = f m ⊗ₜ g n :=
rfl

lemma map_range_eq_span_tmul (f : M →ₗ[R] P) (g : N →ₗ[R] Q) :
  (map f g).range = submodule.span R { t | ∃ m n, (f m) ⊗ₜ (g n) = t } :=
begin
  simp only [← submodule.map_top, ← span_tmul_eq_top, submodule.map_span, set.mem_image,
    set.mem_set_of_eq],
  congr, ext t,
  split,
  { rintros ⟨_, ⟨⟨m, n, rfl⟩, rfl⟩⟩, use [m, n], simp only [map_tmul], },
  { rintros ⟨m, n, rfl⟩, use [m ⊗ₜ n, m, n], simp only [map_tmul], },
end

/-- Given submodules `p ⊆ P` and `q ⊆ Q`, this is the natural map: `p ⊗ q → P ⊗ Q`. -/
@[simp] def map_incl (p : submodule R P) (q : submodule R Q) : p ⊗[R] q →ₗ[R] P ⊗[R] Q :=
map p.subtype q.subtype

section
variables {P' Q' : Type*}
variables [add_comm_monoid P'] [module R P']
variables [add_comm_monoid Q'] [module R Q']

lemma lift_comp_map (i : P →ₗ[R] Q →ₗ[R] Q') (f : M →ₗ[R] P) (g : N →ₗ[R] Q) :
  (lift i).comp (map f g) = lift ((i.comp f).compl₂ g) :=
ext' $ λ _ _, rfl

local attribute [ext] ext

@[simp] lemma map_id : map (id : M →ₗ[R] M) (id : N →ₗ[R] N) = id :=
by { ext, simp only [mk_apply, id_coe, compr₂_apply, id.def, map_tmul], }

@[simp] lemma map_one : map (1 : M →ₗ[R] M) (1 : N →ₗ[R] N) = 1 := map_id

lemma map_mul (f₁ f₂ : M →ₗ[R] M) (g₁ g₂ : N →ₗ[R] N) :
  map (f₁ * f₂) (g₁ * g₂) = (map f₁ g₁) * (map f₂ g₂) :=
map_comp f₁ f₂ g₁ g₂

@[simp] protected lemma map_pow (f : M →ₗ[R] M) (g : N →ₗ[R] N) (n : ℕ) :
  (map f g)^n = map (f^n) (g^n) :=
begin
  induction n with n ih,
  { simp only [pow_zero, map_one], },
  { simp only [pow_succ', ih, map_mul], },
end

lemma map_add_left (f₁ f₂ : M →ₗ[R] P) (g : N →ₗ[R] Q) : map (f₁ + f₂) g = map f₁ g + map f₂ g :=
by {ext, simp only [add_tmul, compr₂_apply, mk_apply, map_tmul, add_apply]}

lemma map_add_right (f : M →ₗ[R] P) (g₁ g₂ : N →ₗ[R] Q) : map f (g₁ + g₂) = map f g₁ + map f g₂ :=
by {ext, simp only [tmul_add, compr₂_apply, mk_apply, map_tmul, add_apply]}

lemma map_smul_left (r : R) (f : M →ₗ[R] P) (g : N →ₗ[R] Q) : map (r • f) g = r • map f g :=
by {ext, simp only [smul_tmul, compr₂_apply, mk_apply, map_tmul, smul_apply, tmul_smul]}

lemma map_smul_right (r : R) (f : M →ₗ[R] P) (g : N →ₗ[R] Q) : map f (r • g) = r • map f g :=
by {ext, simp only [smul_tmul, compr₂_apply, mk_apply, map_tmul, smul_apply, tmul_smul]}

variables (R M N P Q)

/-- The tensor product of a pair of linear maps between modules, bilinear in both maps. -/
def map_bilinear : (M →ₗ[R] P) →ₗ[R] (N →ₗ[R] Q) →ₗ[R] (M ⊗[R] N →ₗ[R] P ⊗[R] Q) :=
linear_map.mk₂ R map map_add_left map_smul_left map_add_right map_smul_right

/-- The canonical linear map from `P ⊗[R] (M →ₗ[R] Q)` to `(M →ₗ[R] P ⊗[R] Q)` -/
def ltensor_hom_to_hom_ltensor : P ⊗[R] (M →ₗ[R] Q) →ₗ[R] (M →ₗ[R] P ⊗[R] Q) :=
tensor_product.lift (llcomp R M Q _ ∘ₗ mk R P Q)

/-- The canonical linear map from `(M →ₗ[R] P) ⊗[R] Q` to `(M →ₗ[R] P ⊗[R] Q)` -/
def rtensor_hom_to_hom_rtensor : (M →ₗ[R] P) ⊗[R] Q →ₗ[R] (M →ₗ[R] P ⊗[R] Q) :=
tensor_product.lift (llcomp R M P _ ∘ₗ (mk R P Q).flip).flip

/-- The linear map from `(M →ₗ P) ⊗ (N →ₗ Q)` to `(M ⊗ N →ₗ P ⊗ Q)` sending `f ⊗ₜ g` to
the `tensor_product.map f g`, the tensor product of the two maps. -/
def hom_tensor_hom_map : (M →ₗ[R] P) ⊗[R] (N →ₗ[R] Q) →ₗ[R] (M ⊗[R] N →ₗ[R] P ⊗[R] Q) :=
lift (map_bilinear R M N P Q)

variables {R M N P Q}

@[simp]
lemma map_bilinear_apply (f : M →ₗ[R] P) (g : N →ₗ[R] Q) :
  map_bilinear R M N P Q f g = map f g := rfl

@[simp]
lemma ltensor_hom_to_hom_ltensor_apply (p : P) (f : M →ₗ[R] Q) (m : M) :
  ltensor_hom_to_hom_ltensor R M P Q (p ⊗ₜ f) m = p ⊗ₜ f m := rfl

@[simp]
lemma rtensor_hom_to_hom_rtensor_apply (f : M →ₗ[R] P) (q : Q) (m : M) :
  rtensor_hom_to_hom_rtensor R M P Q (f ⊗ₜ q) m = f m ⊗ₜ q := rfl

@[simp]
lemma hom_tensor_hom_map_apply (f : M →ₗ[R] P) (g : N →ₗ[R] Q) :
  hom_tensor_hom_map R M N P Q (f ⊗ₜ g) = map f g := rfl

end

/-- If `M` and `P` are linearly equivalent and `N` and `Q` are linearly equivalent
then `M ⊗ N` and `P ⊗ Q` are linearly equivalent. -/
def congr (f : M ≃ₗ[R] P) (g : N ≃ₗ[R] Q) : M ⊗ N ≃ₗ[R] P ⊗ Q :=
linear_equiv.of_linear (map f g) (map f.symm g.symm)
  (ext' $ λ m n, by simp; simp only [linear_equiv.apply_symm_apply])
  (ext' $ λ m n, by simp; simp only [linear_equiv.symm_apply_apply])

@[simp] theorem congr_tmul (f : M ≃ₗ[R] P) (g : N ≃ₗ[R] Q) (m : M) (n : N) :
  congr f g (m ⊗ₜ n) = f m ⊗ₜ g n :=
rfl

@[simp] theorem congr_symm_tmul (f : M ≃ₗ[R] P) (g : N ≃ₗ[R] Q) (p : P) (q : Q) :
  (congr f g).symm (p ⊗ₜ q) = f.symm p ⊗ₜ g.symm q :=
rfl

variables (R M N P Q)

/-- A tensor product analogue of `mul_left_comm`. -/
def left_comm : M ⊗[R] (N ⊗[R] P) ≃ₗ[R] N ⊗[R] (M ⊗[R] P) :=
let e₁ := (tensor_product.assoc R M N P).symm,
    e₂ := congr (tensor_product.comm R M N) (1 : P ≃ₗ[R] P),
    e₃ := (tensor_product.assoc R N M P) in
e₁ ≪≫ₗ (e₂ ≪≫ₗ e₃)

variables {M N P Q}

@[simp] lemma left_comm_tmul (m : M) (n : N) (p : P) :
  left_comm R M N P (m ⊗ₜ (n ⊗ₜ p)) = n ⊗ₜ (m ⊗ₜ p) :=
rfl

@[simp] lemma left_comm_symm_tmul (m : M) (n : N) (p : P) :
  (left_comm R M N P).symm (n ⊗ₜ (m ⊗ₜ p)) = m ⊗ₜ (n ⊗ₜ p) :=
rfl

variables (M N P Q)

/-- This special case is worth defining explicitly since it is useful for defining multiplication
on tensor products of modules carrying multiplications (e.g., associative rings, Lie rings, ...).

E.g., suppose `M = P` and `N = Q` and that `M` and `N` carry bilinear multiplications:
`M ⊗ M → M` and `N ⊗ N → N`. Using `map`, we can define `(M ⊗ M) ⊗ (N ⊗ N) → M ⊗ N` which, when
combined with this definition, yields a bilinear multiplication on `M ⊗ N`:
`(M ⊗ N) ⊗ (M ⊗ N) → M ⊗ N`. In particular we could use this to define the multiplication in
the `tensor_product.semiring` instance (currently defined "by hand" using `tensor_product.mul`).

See also `mul_mul_mul_comm`. -/
def tensor_tensor_tensor_comm : (M ⊗[R] N) ⊗[R] (P ⊗[R] Q) ≃ₗ[R] (M ⊗[R] P) ⊗[R] (N ⊗[R] Q) :=
let e₁ := tensor_product.assoc R M N (P ⊗[R] Q),
    e₂ := congr (1 : M ≃ₗ[R] M) (left_comm R N P Q),
    e₃ := (tensor_product.assoc R M P (N ⊗[R] Q)).symm in
e₁ ≪≫ₗ (e₂ ≪≫ₗ e₃)

variables {M N P Q}

@[simp] lemma tensor_tensor_tensor_comm_tmul (m : M) (n : N) (p : P) (q : Q) :
  tensor_tensor_tensor_comm R M N P Q ((m ⊗ₜ n) ⊗ₜ (p ⊗ₜ q)) = (m ⊗ₜ p) ⊗ₜ (n ⊗ₜ q) :=
rfl

@[simp] lemma tensor_tensor_tensor_comm_symm :
  (tensor_tensor_tensor_comm R M N P Q).symm = tensor_tensor_tensor_comm R M P N Q :=
rfl

variables (M N P Q)

/-- This special case is useful for describing the interplay between `dual_tensor_hom_equiv` and
composition of linear maps.

E.g., composition of linear maps gives a map `(M → N) ⊗ (N → P) → (M → P)`, and applying
`dual_tensor_hom_equiv.symm` to the three hom-modules gives a map
`(M.dual ⊗ N) ⊗ (N.dual ⊗ P) → (M.dual ⊗ P)`, which agrees with the application of `contract_right`
on `N ⊗ N.dual` after the suitable rebracketting.
-/
def tensor_tensor_tensor_assoc : (M ⊗[R] N) ⊗[R] (P ⊗[R] Q) ≃ₗ[R] M ⊗[R] (N ⊗[R] P) ⊗[R] Q :=
(tensor_product.assoc R (M ⊗[R] N) P Q).symm ≪≫ₗ
congr (tensor_product.assoc R M N P) (1 : Q ≃ₗ[R] Q)

variables {M N P Q}

@[simp] lemma tensor_tensor_tensor_assoc_tmul (m : M) (n : N) (p : P) (q : Q) :
  tensor_tensor_tensor_assoc R M N P Q ((m ⊗ₜ n) ⊗ₜ (p ⊗ₜ q)) = m ⊗ₜ (n ⊗ₜ p) ⊗ₜ q := rfl

@[simp] lemma tensor_tensor_tensor_assoc_symm_tmul (m : M) (n : N) (p : P) (q : Q) :
  (tensor_tensor_tensor_assoc R M N P Q).symm (m ⊗ₜ (n ⊗ₜ p) ⊗ₜ q) = (m ⊗ₜ n) ⊗ₜ (p ⊗ₜ q) :=
rfl

end tensor_product

namespace linear_map

variables {R} (M) {N P Q}

/-- `ltensor M f : M ⊗ N →ₗ M ⊗ P` is the natural linear map induced by `f : N →ₗ P`. -/
def ltensor (f : N →ₗ[R] P) : M ⊗ N →ₗ[R] M ⊗ P :=
tensor_product.map id f

/-- `rtensor f M : N₁ ⊗ M →ₗ N₂ ⊗ M` is the natural linear map induced by `f : N₁ →ₗ N₂`. -/
def rtensor (f : N →ₗ[R] P) : N ⊗ M →ₗ[R] P ⊗ M :=
tensor_product.map f id

variables (g : P →ₗ[R] Q) (f : N →ₗ[R] P)

@[simp] lemma ltensor_tmul (m : M) (n : N) : f.ltensor M (m ⊗ₜ n) = m ⊗ₜ (f n) := rfl

@[simp] lemma rtensor_tmul (m : M) (n : N) : f.rtensor M (n ⊗ₜ m) = (f n) ⊗ₜ m := rfl

open tensor_product

local attribute [ext] tensor_product.ext

/-- `ltensor_hom M` is the natural linear map that sends a linear map `f : N →ₗ P` to `M ⊗ f`. -/
def ltensor_hom : (N →ₗ[R] P) →ₗ[R] (M ⊗[R] N →ₗ[R] M ⊗[R] P) :=
{ to_fun := ltensor M,
  map_add' := λ f g, by
  { ext x y, simp only [compr₂_apply, mk_apply, add_apply, ltensor_tmul, tmul_add] },
  map_smul' := λ r f, by
  { dsimp, ext x y, simp only [compr₂_apply, mk_apply, tmul_smul, smul_apply, ltensor_tmul] } }

/-- `rtensor_hom M` is the natural linear map that sends a linear map `f : N →ₗ P` to `M ⊗ f`. -/
def rtensor_hom : (N →ₗ[R] P) →ₗ[R] (N ⊗[R] M →ₗ[R] P ⊗[R] M) :=
{ to_fun := λ f, f.rtensor M,
  map_add' := λ f g, by
  { ext x y, simp only [compr₂_apply, mk_apply, add_apply, rtensor_tmul, add_tmul] },
  map_smul' := λ r f, by
  { dsimp, ext x y, simp only [compr₂_apply, mk_apply, smul_tmul, tmul_smul, smul_apply,
    rtensor_tmul] } }

@[simp] lemma coe_ltensor_hom :
  (ltensor_hom M : (N →ₗ[R] P) → (M ⊗[R] N →ₗ[R] M ⊗[R] P)) = ltensor M := rfl

@[simp] lemma coe_rtensor_hom :
  (rtensor_hom M : (N →ₗ[R] P) → (N ⊗[R] M →ₗ[R] P ⊗[R] M)) = rtensor M := rfl

@[simp] lemma ltensor_add (f g : N →ₗ[R] P) : (f + g).ltensor M = f.ltensor M + g.ltensor M :=
(ltensor_hom M).map_add f g

@[simp] lemma rtensor_add (f g : N →ₗ[R] P) : (f + g).rtensor M = f.rtensor M + g.rtensor M :=
(rtensor_hom M).map_add f g

@[simp] lemma ltensor_zero : ltensor M (0 : N →ₗ[R] P) = 0 :=
(ltensor_hom M).map_zero

@[simp] lemma rtensor_zero : rtensor M (0 : N →ₗ[R] P) = 0 :=
(rtensor_hom M).map_zero

@[simp] lemma ltensor_smul (r : R) (f : N →ₗ[R] P) : (r • f).ltensor M = r • (f.ltensor M) :=
(ltensor_hom M).map_smul r f

@[simp] lemma rtensor_smul (r : R) (f : N →ₗ[R] P) : (r • f).rtensor M = r • (f.rtensor M) :=
(rtensor_hom M).map_smul r f

lemma ltensor_comp : (g.comp f).ltensor M = (g.ltensor M).comp (f.ltensor M) :=
by { ext m n, simp only [compr₂_apply, mk_apply, comp_apply, ltensor_tmul] }

lemma ltensor_comp_apply (x : M ⊗[R] N) :
  (g.comp f).ltensor M x = (g.ltensor M) ((f.ltensor M) x) :=
by { rw [ltensor_comp, coe_comp], }

lemma rtensor_comp : (g.comp f).rtensor M = (g.rtensor M).comp (f.rtensor M) :=
by { ext m n, simp only [compr₂_apply, mk_apply, comp_apply, rtensor_tmul] }

lemma rtensor_comp_apply (x : N ⊗[R] M) :
  (g.comp f).rtensor M x = (g.rtensor M) ((f.rtensor M) x) :=
by { rw [rtensor_comp, coe_comp], }

lemma ltensor_mul (f g : module.End R N) : (f * g).ltensor M = (f.ltensor M) * (g.ltensor M) :=
ltensor_comp M f g

lemma rtensor_mul (f g : module.End R N) : (f * g).rtensor M = (f.rtensor M) * (g.rtensor M) :=
rtensor_comp M f g

variables (N)

@[simp] lemma ltensor_id : (id : N →ₗ[R] N).ltensor M = id := map_id

-- `simp` can prove this.
lemma ltensor_id_apply (x : M ⊗[R] N) : (linear_map.id : N →ₗ[R] N).ltensor M x = x :=
by {rw [ltensor_id, id_coe, id.def], }

@[simp] lemma rtensor_id : (id : N →ₗ[R] N).rtensor M = id := map_id

-- `simp` can prove this.
lemma rtensor_id_apply (x : N ⊗[R] M) : (linear_map.id : N →ₗ[R] N).rtensor M x = x :=
by { rw [rtensor_id, id_coe, id.def], }

variables {N}

@[simp] lemma ltensor_comp_rtensor (f : M →ₗ[R] P) (g : N →ₗ[R] Q) :
  (g.ltensor P).comp (f.rtensor N) = map f g :=
by simp only [ltensor, rtensor, ← map_comp, id_comp, comp_id]

@[simp] lemma rtensor_comp_ltensor (f : M →ₗ[R] P) (g : N →ₗ[R] Q) :
  (f.rtensor Q).comp (g.ltensor M) = map f g :=
by simp only [ltensor, rtensor, ← map_comp, id_comp, comp_id]

@[simp] lemma map_comp_rtensor (f : M →ₗ[R] P) (g : N →ₗ[R] Q) (f' : S →ₗ[R] M) :
  (map f g).comp (f'.rtensor _) = map (f.comp f') g :=
by simp only [ltensor, rtensor, ← map_comp, id_comp, comp_id]

@[simp] lemma map_comp_ltensor (f : M →ₗ[R] P) (g : N →ₗ[R] Q) (g' : S →ₗ[R] N) :
  (map f g).comp (g'.ltensor _) = map f (g.comp g') :=
by simp only [ltensor, rtensor, ← map_comp, id_comp, comp_id]

@[simp] lemma rtensor_comp_map (f' : P →ₗ[R] S) (f : M →ₗ[R] P) (g : N →ₗ[R] Q) :
  (f'.rtensor _).comp (map f g) = map (f'.comp f) g :=
by simp only [ltensor, rtensor, ← map_comp, id_comp, comp_id]

@[simp] lemma ltensor_comp_map (g' : Q →ₗ[R] S) (f : M →ₗ[R] P) (g : N →ₗ[R] Q) :
  (g'.ltensor _).comp (map f g) = map f (g'.comp g) :=
by simp only [ltensor, rtensor, ← map_comp, id_comp, comp_id]

variables {M}

@[simp] lemma rtensor_pow (f : M →ₗ[R] M) (n : ℕ) : (f.rtensor N)^n = (f^n).rtensor N :=
by { have h := tensor_product.map_pow f (id : N →ₗ[R] N) n, rwa id_pow at h, }

@[simp] lemma ltensor_pow (f : N →ₗ[R] N) (n : ℕ) : (f.ltensor M)^n = (f^n).ltensor M :=
by { have h := tensor_product.map_pow (id : M →ₗ[R] M) f n, rwa id_pow at h, }

end linear_map

end semiring

section ring

variables {R : Type*} [comm_semiring R]
variables {M : Type*} {N : Type*} {P : Type*} {Q : Type*} {S : Type*}

variables [add_comm_group M] [add_comm_group N] [add_comm_group P] [add_comm_group Q]
  [add_comm_group S]
variables [module R M] [module R N] [module R P] [module R Q] [module R S]

namespace tensor_product

open_locale tensor_product
open linear_map

variables (R)

/-- Auxiliary function to defining negation multiplication on tensor product. -/
def neg.aux : free_add_monoid (M × N) →+ M ⊗[R] N :=
free_add_monoid.lift $ λ p : M × N, (-p.1) ⊗ₜ p.2

variables {R}

theorem neg.aux_of (m : M) (n : N) :
  neg.aux R (free_add_monoid.of (m, n)) = (-m) ⊗ₜ[R] n :=
rfl

instance : has_neg (M ⊗[R] N) :=
{ neg := (add_con_gen (tensor_product.eqv R M N)).lift (neg.aux R) $ add_con.add_con_gen_le $
    λ x y hxy, match x, y, hxy with
    | _, _, (eqv.of_zero_left n)       := (add_con.ker_rel _).2 $
        by simp_rw [add_monoid_hom.map_zero, neg.aux_of, neg_zero, zero_tmul]
    | _, _, (eqv.of_zero_right m)      := (add_con.ker_rel _).2 $
        by simp_rw [add_monoid_hom.map_zero, neg.aux_of, tmul_zero]
    | _, _, (eqv.of_add_left m₁ m₂ n)  := (add_con.ker_rel _).2 $
        by simp_rw [add_monoid_hom.map_add, neg.aux_of, neg_add, add_tmul]
    | _, _, (eqv.of_add_right m n₁ n₂) := (add_con.ker_rel _).2 $
        by simp_rw [add_monoid_hom.map_add, neg.aux_of, tmul_add]
    | _, _, (eqv.of_smul s m n)        := (add_con.ker_rel _).2 $
        by simp_rw [neg.aux_of, tmul_smul s, smul_tmul', smul_neg]
    | _, _, (eqv.add_comm x y)         := (add_con.ker_rel _).2 $
        by simp_rw [add_monoid_hom.map_add, add_comm]
    end }

protected theorem add_left_neg (x : M ⊗[R] N) : -x + x = 0 :=
tensor_product.induction_on x
  (by { rw [add_zero], apply (neg.aux R).map_zero, })
  (λ x y, by { convert (add_tmul (-x) x y).symm, rw [add_left_neg, zero_tmul], })
  (λ x y hx hy, by
  { unfold has_neg.neg sub_neg_monoid.neg,
    rw add_monoid_hom.map_add,
    ac_change (-x + x) + (-y + y) = 0,
    rw [hx, hy, add_zero], })

instance : add_comm_group (M ⊗[R] N) :=
{ neg := has_neg.neg,
  sub := _,
  sub_eq_add_neg := λ _ _, rfl,
  add_left_neg := λ x, by exact tensor_product.add_left_neg x,
  zsmul := λ n v, n • v,
  zsmul_zero' := by simp [tensor_product.zero_smul],
  zsmul_succ' := by simp [nat.succ_eq_one_add, tensor_product.one_smul, tensor_product.add_smul],
  zsmul_neg' := λ n x, begin
    change (- n.succ : ℤ) • x = - (((n : ℤ) + 1) • x),
    rw [← zero_add (-↑(n.succ) • x), ← tensor_product.add_left_neg (↑(n.succ) • x), add_assoc,
      ← add_smul, ← sub_eq_add_neg, sub_self, zero_smul, add_zero],
    refl,
  end,
  .. tensor_product.add_comm_monoid }

lemma neg_tmul (m : M) (n : N) : (-m) ⊗ₜ n = -(m ⊗ₜ[R] n) := rfl

lemma tmul_neg (m : M) (n : N) : m ⊗ₜ (-n) = -(m ⊗ₜ[R] n) := (mk R M N _).map_neg _

lemma tmul_sub (m : M) (n₁ n₂ : N) : m ⊗ₜ (n₁ - n₂) = (m ⊗ₜ[R] n₁) - (m ⊗ₜ[R] n₂) :=
(mk R M N _).map_sub _ _

lemma sub_tmul (m₁ m₂ : M) (n : N) : (m₁ - m₂) ⊗ₜ n = (m₁ ⊗ₜ[R] n) - (m₂ ⊗ₜ[R] n) :=
(mk R M N).map_sub₂ _ _ _

/--
While the tensor product will automatically inherit a ℤ-module structure from
`add_comm_group.int_module`, that structure won't be compatible with lemmas like `tmul_smul` unless
we use a `ℤ-module` instance provided by `tensor_product.left_module`.

When `R` is a `ring` we get the required `tensor_product.compatible_smul` instance through
`is_scalar_tower`, but when it is only a `semiring` we need to build it from scratch.
The instance diamond in `compatible_smul` doesn't matter because it's in `Prop`.
-/
instance compatible_smul.int : compatible_smul R ℤ M N :=
⟨λ r m n, int.induction_on r
  (by simp)
  (λ r ih, by simpa [add_smul, tmul_add, add_tmul] using ih)
  (λ r ih, by simpa [sub_smul, tmul_sub, sub_tmul] using ih)⟩

instance compatible_smul.unit {S} [monoid S] [distrib_mul_action S M] [distrib_mul_action S N]
  [compatible_smul R S M N] :
  compatible_smul R Sˣ M N :=
⟨λ s m n, (compatible_smul.smul_tmul (s : S) m n : _)⟩

end tensor_product

namespace linear_map

@[simp] lemma ltensor_sub (f g : N →ₗ[R] P) : (f - g).ltensor M = f.ltensor M - g.ltensor M :=
by simp only [← coe_ltensor_hom, map_sub]

@[simp] lemma rtensor_sub (f g : N →ₗ[R] P) : (f - g).rtensor M = f.rtensor M - g.rtensor M :=
by simp only [← coe_rtensor_hom, map_sub]

@[simp] lemma ltensor_neg (f : N →ₗ[R] P) : (-f).ltensor M = -(f.ltensor M) :=
by simp only [← coe_ltensor_hom, map_neg]

@[simp] lemma rtensor_neg (f : N →ₗ[R] P) : (-f).rtensor M = -(f.rtensor M) :=
by simp only [← coe_rtensor_hom, map_neg]

end linear_map

end ring


-- First part
variables p q r : Prop
example : p ∧ q ↔ q ∧ p :=
  iff.intro
    (λ hpq, ⟨hpq.right, hpq.left⟩)
    (λ hqp, ⟨hqp.right, hqp.left⟩)

example : p ∨ q ↔ q ∨ p :=
  iff.intro
    (λ hpq, or.elim hpq (λ hp, or.inr hp) (λ hq, or.inl hq))
    (λ hqp, or.elim hqp (λ hq, or.inr hq) (λ hp, or.inl hp))

example : (p ∧ q) ∧ r ↔ p ∧ (q ∧ r) :=
  iff.intro
    (λ hpq_r, ⟨hpq_r.left.left, hpq_r.left.right, hpq_r.right⟩)
    (λ hp_qr, ⟨⟨hp_qr.left, hp_qr.right.left⟩, hp_qr.right.right⟩)

example : (p ∨ q) ∨ r ↔ p ∨ (q ∨ r) :=
  iff.intro
    (λ hpq_r,
      or.elim hpq_r
        (λ hpq, or.elim hpq
          (λ hp, or.inl hp)
          (λ hq, or.inr (or.inl hq)))
        (λ hr, or.inr (or.inr hr)))
    (λ hp_qr,
      or.elim hp_qr
        (λ hp, or.inl (or.inl hp))
        (λ hqr, or.elim hqr
          (λ hq, or.inl (or.inr hq))
          (λ hr, or.inr hr)))

example : p ∧ (q ∨ r) ↔ (p ∧ q) ∨ (p ∧ r) :=
  iff.intro
    (λ hp_qr, or.elim hp_qr.right
      (λ hq, or.inl ⟨hp_qr.left, hq⟩)
      (λ hr, or.inr ⟨hp_qr.left, hr⟩))
    (λ hpq_pr, ⟨
      or.elim hpq_pr (λ hpq, hpq.left) (λ hpr, hpr.left),
      or.elim hpq_pr (λ hpq, or.inl hpq.right) (λ hpr, or.inr hpr.right)
    ⟩)

example : p ∨ (q ∧ r) ↔ (p ∨ q) ∧ (p ∨ r) :=
  iff.intro
    (λ hp_qr, ⟨
      or.elim hp_qr (λ hp, or.inl hp) (λ hqr : q ∧ r, or.inr hqr.left),
      or.elim hp_qr (λ hp, or.inl hp) (λ hqr : q ∧ r, or.inr hqr.right)
    ⟩)
    (λ hpq_pr, or.elim hpq_pr.left
      (λ hp, or.inl hp)
      (λ hq, or.elim hpq_pr.right
        (λ hp, or.inl hp)
        (λ hr, or.inr ⟨hq, hr⟩)))

example : p → (q → r) ↔ (p ∧ q → r) :=
  iff.intro
    (λ hpqr,
      λ hpq, hpqr hpq.left hpq.right)
    (λ hpq_r,
      λ hp, λ hq, hpq_r ⟨hp, hq⟩)

example : ((p ∨ q) → r) ↔ (p → r) ∧ (q → r) :=
  iff.intro
    (λ hpq_r,
      ⟨λ hp, hpq_r (or.inl hp),
       λ hq, hpq_r (or.inr hq)⟩)
    (λ hpr_qr,
      (λ hpq, or.elim hpq
        (λ hp, hpr_qr.left hp)
        (λ hq, hpr_qr.right hq)))

example : ¬(p ∨ q) ↔ ¬p ∧ ¬q :=
  iff.intro
    (λ hnpq, ⟨λ hp, hnpq (or.inl hp),
              λ hq, hnpq (or.inr hq)⟩)
    (λ hnp_nq,
      λ hpq, or.elim hpq
        (λ hp, hnp_nq.left hp)
        (λ hq, hnp_nq.right hq))

example : ¬p ∨ ¬q → ¬(p ∧ q) :=
  (λ hnp_nq,
    λ hpq, or.elim hnp_nq
      (λ hnp, hnp hpq.left)
      (λ hnq, hnq hpq.right))

example : ¬(p ∧ ¬p) := λ hp_np, hp_np.right hp_np.left

example : p ∧ ¬q → ¬(p → q) :=
  λ hp_nq, λ hpq, hp_nq.right (hpq hp_nq.left)

example : ¬p → (p → q) := λ hnp, λ hp, false.elim (hnp hp)

example : (¬p ∨ q) → (p → q) :=
  λ hnp_q,
    λ hp, or.elim hnp_q
      (λ hnp, false.elim (hnp hp))
      (λ hq, hq)

example : p ∨ false ↔ p :=
  iff.intro
    (λ hpf, or.elim hpf (λ hp, hp) (λ hf, false.elim hf))
    (λ hp, or.inl hp)

example : p ∧ false ↔ false :=
  iff.intro
    (λ hpf, hpf.right)
    (λ hf, ⟨false.elim hf, hf⟩)

example : (p → q) → (¬q → ¬p) :=
  λ hpq, λ hnq, λ hp, hnq (hpq hp)

-- Second part
open classical
variable s : Prop

example : (p → r ∨ s) → ((p → r) ∨ (p → s)) :=
  λ hp_rs, by_cases
    (λ hp, or.elim (hp_rs hp)
      (λ hr, or.inl (λ hp', hr))
      (λ hs, or.inr (λ hp', hs)))
    (λ hnp, or.inl (λ hp', false.elim (hnp hp')))

example : ¬(p ∧ q) → ¬p ∨ ¬q :=
  λ hnpq, by_cases
    (λ hp, or.inr (λ hq, hnpq ⟨hp, hq⟩))
    (λ hnp, or.inl hnp)

-- Brute force
example : ¬(p → q) → p ∧ ¬q :=
  λ hnpq, by_cases
    (λ hp, by_cases
      (λ hq, ⟨hp, false.elim (hnpq (λ hp', hq))⟩)
      (λ hnq, ⟨hp, hnq⟩))
    (λ hnp, by_cases
      (λ hq, ⟨false.elim (hnpq (λ hp', false.elim (hnp hp'))),
              false.elim (hnpq (λ hp', hq))⟩)
      (λ hnq, ⟨false.elim (hnpq (λ hp', false.elim (hnp hp'))), hnq⟩))

example : (p → q) → (¬p ∨ q) :=
  λ hpq, by_cases
    (λ hp, or.inr (hpq hp))
    (λ hnp, or.inl hnp)

example : (¬q → ¬p) → (p → q) :=
  λ hnq_np,
    λ hp, by_cases
      (λ hq, hq)
      (λ hnq, false.elim (hnq_np hnq hp))

example : p ∨ ¬p := em p

example : (((p → q) → p) → p) :=
  λ hpqp, by_contradiction
    (λ hnp, hnp (hpqp (λ hp, false.elim (hnp hp))))

-- No classical logic
example : ¬(p ↔ ¬p) :=
  λ hp_np,
    have hp : p, from hp_np.mpr (λ hp, hp_np.mp hp hp),
    show false, from hp_np.mp hp hp


/-
Copyright (c) 2020 Ruben Van de Velde. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
-/

import data.int.order.units
import number_theory.zsqrtd.basic
import ring_theory.prime
import .primes

lemma zsqrtd.exists {d : ℤ} (a : ℤ√d) (him : a.im ≠ 0) :
  ∃ (c : ℤ√d), a.norm = c.norm ∧ 0 ≤ c.re ∧ c.im ≠ 0 :=
begin
  cases le_or_lt a.re 0 with hre hre,
  { use -a,
    simp only [hre, him, zsqrtd.norm_neg, eq_self_iff_true, zsqrtd.neg_im, zsqrtd.neg_re, and_self,
      neg_nonneg, ne.def, not_false_iff, neg_eq_zero] },
  { use a, simp only [hre.le, him, eq_self_iff_true, and_self, ne.def, not_false_iff] },
end

-- Edwards p49 step (2')
lemma factors2
  {a : ℤ√-3}
  (heven : even a.norm) :
  ∃ b : ℤ√-3, a.norm = 4 * b.norm :=
begin
  have hparity : even a.re ↔ even a.im,
  { simpa [two_ne_zero, zsqrtd.norm_def] with parity_simps using heven },
  simp only [iff_iff_and_or_not_and_not, ←int.odd_iff_not_even] at hparity,

  obtain ⟨⟨c, hc⟩, ⟨d, hd⟩⟩|⟨hre, him⟩ := hparity,
  { use ⟨c, d⟩,
    simp only [zsqrtd.norm_def, hc, hd],
    ring },
  { cases int.four_dvd_add_or_sub_of_odd hre him with h4 h4,
    { obtain ⟨v, hv⟩ := h4,
      use ⟨v - a.im, v⟩,
      rw [eq_comm, ←sub_eq_iff_eq_add] at hv,
      simp only [zsqrtd.norm_def, ←hv],
      ring },
    { obtain ⟨v, hv⟩ := h4,
      use ⟨v + a.im, v⟩,
      rw [sub_eq_iff_eq_add] at hv,
      simp only [zsqrtd.norm_def, hv],
      ring } }
end

lemma spts.mul_of_dvd'
  {a p : ℤ√-3}
  (hdvd : p.norm ∣ a.norm)
  (hpprime : prime p.norm) :
  ∃ u : ℤ√-3, a = p * u ∨ a = star p * u :=
begin
  obtain ⟨f, hf⟩ := hdvd,
  have h0 : p.norm ∣ p.re * a.im - a.re * p.im ∨
         p.norm ∣ p.re * a.im + a.re * p.im,
  { apply hpprime.dvd_or_dvd,
    convert dvd_mul_right p.norm (a.im ^ 2 - p.im ^ 2 * f) using 1,
    transitivity a.im ^ 2 * p.norm - p.im ^ 2 * (p.norm * f),
    { rw [←hf, zsqrtd.norm_def, zsqrtd.norm_def], ring },
    { rw [zsqrtd.norm_def], ring } },

  obtain ⟨A, HA⟩ : ∃ A : units ℤ, p.norm ∣ p.re * a.im + A * a.re * p.im,
  { cases h0 with h0 h0;
    [use -1, use 1];
    convert h0;
    simp, },

  have HAsq : (A : ℤ) ^ 2 = 1,
  { calc (A : ℤ) ^ 2
        = ((A ^ 2 : units ℤ) : ℤ) : (units.coe_pow _ _).symm
    ... = ((1 : units ℤ) : ℤ) : congr_arg _ (int.units_sq A)
    ... = 1 : units.coe_one },

  { set X : ℤ√-3 := ⟨p.re * a.re - A * 3 * p.im * a.im, p.re * a.im + A * a.re * p.im⟩ with HX,
    obtain ⟨U, HU⟩ : (p.norm : ℤ√-3) ∣ X,
    { rw zsqrtd.coe_int_dvd_iff,
      refine ⟨_, HA⟩,
      apply @prime.dvd_of_dvd_pow _ _ _ hpprime _ 2,
      have : X.re ^ 2 = X.norm - 3 * X.im ^ 2,
      { rw [zsqrtd.norm_def], ring },
      rw this,
      apply dvd_sub,
      { use a.norm,
        transitivity (p.re * a.re) ^ 2 + (A : ℤ) ^ 2 * (3 * p.im * a.im) ^ 2 +
          3 * ((p.re * a.im) ^ 2 + (A : ℤ) ^ 2 * (a.re * p.im) ^ 2),
        { simp only [zsqrtd.norm_def],
          ring },
        { simp only [zsqrtd.norm_def, HAsq],
          ring } },
      { apply dvd_mul_of_dvd_right,
        exact dvd_pow HA two_ne_zero } },
    use U,
    suffices : a = ⟨p.re, -A * p.im⟩ * U,
    { apply or.imp _ _ (int.units_eq_one_or A).symm; rintro rfl; simpa [zsqrtd.ext] using this },
    apply zsqrtd.eq_of_smul_eq_smul_left hpprime.ne_zero,
    have : p.norm = p.re ^ 2 + 3 * ↑A ^ 2 * p.im ^ 2,
    { rw [zsqrtd.norm_def, HAsq], ring },
    rw [mul_comm _ U, ←mul_assoc, ←HU, HX],
    simp only [zsqrtd.ext, neg_mul, add_zero, zsqrtd.coe_int_re, zero_mul,
      mul_neg, zsqrtd.mul_im, zsqrtd.mul_re, neg_neg, mul_zero, neg_zero,
      zsqrtd.coe_int_im, this],
    split; ring },
end

-- Edwards p49 step (3')
lemma spts.mul_of_dvd''
  {a p : ℤ√-3}
  (hdvd : p.norm ∣ a.norm)
  (hpprime : prime p.norm) :
  ∃ u : ℤ√-3,
    (a = p * u ∨ a = star p * u) ∧
    a.norm = p.norm * u.norm :=
begin
  obtain ⟨u, hu⟩ := spts.mul_of_dvd' hdvd hpprime,
  refine ⟨u, hu, _⟩,
  obtain (rfl|rfl) := hu,
  { rw [zsqrtd.norm_mul] },
  { rw [zsqrtd.norm_mul, zsqrtd.norm_conj] },
end

-- Edwards p49 step (4'), contraposed
lemma factors'
  (a : ℤ√-3)
  (f : ℤ)
  (g : ℤ)
  (hodd : odd f)
  (hgpos : g ≠ 0)
  (hfactor : f * g = a.norm)
  (hnotform : ∀ (f' : ℤ), f' ∣ g → odd f' → (∃ (p : ℤ√-3), abs f' = p.norm)) :
  ∃ (p : ℤ√-3), abs f = p.norm :=
begin
  induction hg : g.nat_abs using nat.strong_induction_on with g'' IH generalizing a g,
  subst g'',
  dsimp at IH,
  have ha : a.norm ≠ 0,
  { rw [←hfactor, mul_ne_zero_iff, and_iff_left hgpos],
    rintro rfl,
    exact int.odd_iff_not_even.mp hodd even_zero },
  by_cases H : even (zsqrtd.norm a),
  { obtain ⟨c, hc⟩ := factors2 H,
    obtain ⟨g', rfl⟩ : 4 ∣ g,
    { apply is_coprime.dvd_of_dvd_mul_left,
      { show is_coprime _ f,
        rw [int.odd_iff_not_even, even_iff_two_dvd, ←int.prime_two.coprime_iff_not_dvd] at hodd,
        convert hodd.pow_left,
        rw sq,
        norm_num },
      { rw [hfactor, hc],
        exact dvd_mul_right _ _ } },
    have hg'pos : g' ≠ 0 := right_ne_zero_of_mul hgpos,
    have hgcdcd : 0 < int.gcd c.re c.im,
    { rw [zsqrtd.gcd_pos_iff, ne.def, ←c.norm_eq_zero_iff (by norm_num)],
      apply right_ne_zero_of_mul,
      rwa ←hc },
    refine IH g'.nat_abs _ c g' hg'pos _ _ rfl,
    { rw [int.nat_abs_mul],
      apply lt_mul_of_one_lt_left (int.nat_abs_pos_of_ne_zero hg'pos),
      norm_num },
    { rw [←mul_right_inj' (four_ne_zero' ℤ), ←hc, ←hfactor, mul_left_comm] },
    { intros f' hf'dvd hf'odd,
      refine hnotform f' _ hf'odd,
      exact hf'dvd.mul_left _ } },
  { by_cases h : |g| = 1,
    { apply_fun abs at hfactor,
      rw [abs_mul, h, mul_one, abs_of_nonneg (zsqrtd.norm_nonneg (by norm_num) a)] at hfactor,
      exact ⟨_, hfactor⟩ },
    { rw [int.abs_eq_nat_abs, ←int.coe_nat_one, int.coe_nat_inj'] at h,
      obtain ⟨p, pprime, pdvd⟩ := int.exists_prime_and_dvd h,
      have : p ∣ a.norm,
      { rw [←hfactor],
        exact pdvd.mul_left _ },
      have podd : odd p := int.odd_iff_not_even.mpr (by {
        intro X,
        apply H,
        apply even_iff_two_dvd.mpr,
        apply dvd_trans _ this,
        apply even_iff_two_dvd.mp X
      }),
      obtain ⟨A, HA⟩ := hnotform p pdvd podd,
      have pprime' := pprime.abs,
      rw [HA] at pprime',
      have pdvd' : A.norm ∣ a.norm,
      { rw [←hfactor, ←HA, abs_dvd],
        exact dvd_mul_of_dvd_right pdvd _ },
      obtain ⟨c, -, hcd⟩ := spts.mul_of_dvd'' pdvd' pprime',
      obtain ⟨q, rfl⟩ := pdvd,
      have hqpos : q ≠ 0 := right_ne_zero_of_mul hgpos,
      have : (p.sign * q).nat_abs = q.nat_abs,
      { rw [int.nat_abs_mul, int.nat_abs_sign_of_nonzero pprime.ne_zero, one_mul] },
      refine IH q.nat_abs _ c (p.sign * q) _ _ _ this,
      { rw [int.nat_abs_mul],
        apply lt_mul_of_one_lt_left (int.nat_abs_pos_of_ne_zero hqpos),
        rw int.prime_iff_nat_abs_prime at pprime,
        exact pprime.one_lt },
      { rwa [←int.nat_abs_eq_zero, this, int.nat_abs_eq_zero] },
      { rw [←mul_right_inj' pprime'.ne_zero, ←hcd, mul_left_comm, ←hfactor, ←HA, ←mul_assoc (|p|),
          mul_comm (|p|), int.sign_mul_abs] },
      { intros f' hf'dvd hf'odd,
        refine hnotform f' _ hf'odd,
        rw [←int.dvd_nat_abs, this, int.dvd_nat_abs] at hf'dvd,
        exact hf'dvd.mul_left _ } } }
end

lemma zqrtd.factor_div (a : ℤ√-3) {x : ℤ} (hodd : odd x) :
  ∃ c m : ℤ√-3, a = c + m * x ∧ c.norm < x ^ 2 :=
begin
  obtain ⟨m, c, ha, hc⟩ := int.factor_div a.re x hodd,
  obtain ⟨n, d, hb, hd⟩ := int.factor_div a.im x hodd,
  set c' : ℤ√-3 := ⟨c, d⟩,
  refine ⟨c', ⟨m, n⟩, _, _⟩,
  { simp only [zsqrtd.ext, ha, hb, add_zero, zsqrtd.coe_int_re, eq_self_iff_true, zsqrtd.mul_im,
      zero_add, zsqrtd.add_im, and_self, zsqrtd.mul_re, mul_zero, zsqrtd.add_re, zsqrtd.coe_int_im] },
  { rw ←mul_lt_mul_left (by norm_num : (0 : ℤ) < 4),
    calc 4 * c'.norm
        = (2 * c) ^ 2 + 3 * (2 * d) ^ 2 : by { rw zsqrtd.norm_def, ring }
    ... < x ^ 2 + 3 * x ^ 2 : add_lt_add _ _
    ... = 4 * x ^ 2 : by ring,
    { rw [mul_pow, ←int.nat_abs_pow_two c, ←int.nat_abs_pow_two x, ←mul_pow],
      norm_cast,
      exact nat.pow_lt_pow_of_lt_left hc zero_lt_two },
    { rw [mul_pow, ←int.nat_abs_pow_two d, ←int.nat_abs_pow_two x, ←mul_pow,
        mul_lt_mul_left (by norm_num : (0 : ℤ) < 3)],
      norm_cast,
      exact nat.pow_lt_pow_of_lt_left hd zero_lt_two } },
end

lemma zqrtd.factor_div' (a : ℤ√-3) {x : ℤ} (hodd : odd x) (h : 1 < |x|)
  (hcoprime : is_coprime a.re a.im) (hfactor : x ∣ a.norm) :
  ∃ c m : ℤ√-3, a = c + m * x ∧ c.norm < x ^ 2 ∧ c ≠ 0 ∧
    ∃ y, c.norm = x * y ∧ y.nat_abs < x.nat_abs :=
begin
  obtain ⟨c, m, rfl, h2⟩ := zqrtd.factor_div a hodd,
  refine ⟨c, m, rfl, h2, _, _⟩,
  { rintro rfl,
    apply h.ne',
    rw ←int.is_unit_iff_abs_eq,
    apply hcoprime.is_unit_of_dvd';
    simp only [zero_add, mul_comm m, zsqrtd.smul_re, zsqrtd.smul_im, dvd_mul_right] },
  { obtain ⟨y, hy⟩ : x ∣ c.norm,
    { set e : ℤ := m.re ^ 2 * x + 2 * m.re * c.re + 3 * m.im ^ 2 * x + 6 * m.im * c.im with he,
      convert dvd_sub hfactor (dvd_mul_right x e),
      rw [he, zsqrtd.norm_def, zsqrtd.norm_def],
      simp only [zsqrtd.coe_int_re, zsqrtd.mul_im, zsqrtd.add_im, zsqrtd.mul_re, zsqrtd.add_re,
        zsqrtd.coe_int_im],
      ring },
    refine ⟨y, hy, _⟩,
    have h0'' : 0 < x.nat_abs,
    { zify,
      exact zero_lt_one.trans h },
    rw [←mul_lt_mul_left h0'', ←pow_two, ←int.nat_abs_mul, ←hy],
    zify,
    rwa [← int.coe_nat_abs x, int.nat_abs_pow_two x, ← int.coe_nat_abs,
      int.nat_abs_of_nonneg (zsqrtd.norm_nonneg (by norm_num) c)] },
end

-- Edwards p50 step (5')
lemma factors
  (a : ℤ√-3)
  (x : ℤ)
  (hcoprime : is_coprime a.re a.im)
  (hodd : odd x)
  (hfactor : x ∣ a.norm) :
  ∃ c : ℤ√-3, abs x = c.norm :=
begin
  induction hx' : x.nat_abs using nat.strong_induction_on with x' IH generalizing a x,
  subst hx',
  have hneg1 : 1 ≤ a.norm,
  { rw [←int.sub_one_lt_iff, sub_self],
    apply lt_of_le_of_ne (zsqrtd.norm_nonneg (by norm_num) a),
    rw [ne.def, eq_comm, zsqrtd.norm_eq_zero_iff (by norm_num : (-3 : ℤ) < 0)],
    rintro rfl,
    rw [zsqrtd.zero_im, zsqrtd.zero_re] at hcoprime,
    exact not_coprime_zero_zero hcoprime },

  have h0 : x ≠ 0,
  { rintro rfl,
    simpa only [even_zero, not_true, int.odd_iff_not_even] using hodd },
  have h0' : 1 ≤ abs x,
  { rwa [←int.sub_one_lt_iff, sub_self, abs_pos] },
  cases h0'.eq_or_lt with h h,
  { rw ←h,
    refine ⟨⟨1, 0⟩, _⟩,
    norm_num [zsqrtd.norm_def] },

  obtain ⟨c', m, rfl, h2', h1, ⟨y, hy, h3⟩⟩ := zqrtd.factor_div' a hodd h hcoprime hfactor,

  have h4 : c'.norm ≠ 0,
  { rwa [ne.def, zsqrtd.norm_eq_zero_iff (by norm_num) c'] },

  set g := int.gcd c'.re c'.im with hg,
  have hgpos : 0 < g,
  { rwa [hg, zsqrtd.gcd_pos_iff] },
  obtain ⟨C', HC', HCDcoprime⟩ := zsqrtd.exists_coprime_of_gcd_pos hgpos,
  have h5 : x * y = g ^ 2 * C'.norm,
  { rw [←hy, HC', zsqrtd.norm_mul, zsqrtd.norm_int_cast, ←pow_two] },
  obtain ⟨z, hz⟩ : (g ^ 2 : ℤ) ∣ y,
  { have : (g ^ 2 : ℤ) ∣ x * y,
    { rw h5, exact dvd_mul_right _ _ },
    apply is_coprime.dvd_of_dvd_mul_left _ this,
    apply is_coprime_of_prime_dvd,
    { contrapose! h0, exact h0.2 },
    intros p hpprime hpdvdleft hpdvdright,
    have : ↑p ∣ c' + m * x,
    { rw [HC'],
      exact dvd_add
        (dvd_mul_of_dvd_left
          ((zsqrtd.coe_int_dvd_coe_int _ _).mpr (hpprime.dvd_of_dvd_pow hpdvdleft)) _)
        (dvd_mul_of_dvd_right ((zsqrtd.coe_int_dvd_coe_int _ _).mpr hpdvdright) _) },
    have := zsqrtd.coprime_of_dvd_coprime hcoprime this,
    simpa only [zsqrtd.coe_int_re, is_coprime_zero_right, zsqrtd.coe_int_im, hpprime.not_unit] using this },

  have h6 : x * z = C'.norm,
  { have hgnezero := int.coe_nat_ne_zero_iff_pos.mpr hgpos,
    apply int.eq_of_mul_eq_mul_left (pow_ne_zero 2 hgnezero),
    rw [←h5, hz, mul_left_comm] },

  have h8 : z ≠ 0,
  { apply right_ne_zero_of_mul,
    apply right_ne_zero_of_mul,
    rwa [h6, ←h5, ←hy] },
  refine factors' _ x z hodd h8 h6 _,
  intros w hwdvd hwodd,
  refine IH w.nat_abs _ C' w HCDcoprime hwodd _ rfl,
  { calc w.nat_abs
        ≤ z.nat_abs : nat.le_of_dvd (int.nat_abs_pos_of_ne_zero h8) (int.nat_abs_dvd_iff_dvd.mpr hwdvd)
    ... ≤ y.nat_abs : by { rw [hz, int.nat_abs_mul], exact nat.le_mul_of_pos_left (pow_pos hgpos 2) }
    ... < x.nat_abs : h3 },
  { rw ←h6,
    exact dvd_mul_of_dvd_right hwdvd x },
end

theorem spts.eq_one
  {a : ℤ√-3}
  (h : a.norm = 1) :
  abs a.re = 1 ∧ a.im = 0 :=
begin
  suffices H : abs a.re = 1,
  { refine ⟨H, _⟩,
    rw [zsqrtd.norm_def, mul_assoc, ←int.nat_abs_mul_self' a.re, ←int.abs_eq_nat_abs, H, one_mul,
      neg_mul, sub_neg_eq_add, add_right_eq_self, mul_eq_zero,
      mul_self_eq_zero] at h,
    exact h.resolve_left three_ne_zero },
  contrapose! h,
  cases lt_or_gt_of_ne h with H H,
  { have : a.re = 0,
    { rwa [←int.abs_lt_one_iff] },
    simp only [zsqrtd.norm_def, this, zero_mul, zero_sub, neg_mul, neg_neg],
    by_cases hb : a.im = 0,
    { simp only [hb, not_false_iff, zero_ne_one, mul_zero] },
    { have : 1 ≤ abs a.im,
      { rwa [←int.abs_lt_one_iff, not_lt] at hb },
      have : 1 ≤ a.im ^ 2,
      { rw ←sq_abs,
        exact pow_le_pow_of_le_left zero_le_one this 2 },
      linarith } },
  { apply ne_of_gt,
    rw [zsqrtd.norm_def, neg_mul, neg_mul, sub_neg_eq_add],
    apply lt_add_of_lt_of_nonneg,
    { rw [←sq, ←sq_abs],
      exact pow_lt_pow_of_lt_left H zero_le_one zero_lt_two },
    { rw mul_assoc,
      exact mul_nonneg zero_lt_three.le (mul_self_nonneg _) } }
end

theorem spts.eq_one'
  {a : ℤ√-3}
  (h : a.norm = 1) :
  a = 1 ∨ a = -1 :=
begin
  simp only [zsqrtd.ext, zsqrtd.one_re, zsqrtd.one_im, zsqrtd.neg_im, zsqrtd.neg_re, neg_zero,
    ←or_and_distrib_right, ←abs_eq (zero_le_one' ℤ), spts.eq_one h, eq_self_iff_true, and_self],
end

lemma spts.ne_zero_of_coprime'
  (a : ℤ√-3)
  (hcoprime : is_coprime a.re a.im) :
  a.norm ≠ 0 :=
begin
  contrapose! hcoprime with H,
  obtain ⟨rfl, rfl⟩ := (zsqrtd.norm_eq_zero_iff (by norm_num) _).mp H,
  exact not_coprime_zero_zero,
end

lemma spts.pos_of_coprime'
  {a : ℤ√-3}
  (hcoprime : is_coprime a.re a.im) :
  0 < a.norm :=
begin
  apply lt_of_le_of_ne,
  { apply zsqrtd.norm_nonneg, norm_num },
  { symmetry, exact spts.ne_zero_of_coprime' _ hcoprime }
end

lemma spts.one_lt_of_im_ne_zero
  (a : ℤ√-3)
  (hb : a.im ≠ 0) :
  1 < a.norm :=
begin
  apply lt_of_le_of_ne,
  { rw [←int.sub_one_lt_iff, sub_self],
    apply lt_of_le_of_ne (zsqrtd.norm_nonneg (by norm_num) a),
    contrapose! hb,
    rw [eq_comm, zsqrtd.norm_eq_zero_iff (by norm_num) a] at hb,
    rw [hb, zsqrtd.zero_im] },
  { intro H,
    exact hb (spts.eq_one H.symm).2 }
end

lemma spts.not_two
  (a : ℤ√-3) :
  a.norm ≠ 2 :=
begin
  rw zsqrtd.norm_def,
  obtain him|him := eq_or_ne a.im 0,
  { rw [him, mul_zero, sub_zero, ←int.nat_abs_mul_self, ←sq],
    norm_cast,
    apply (nat.pow_left_strict_mono one_le_two).monotone.ne_of_lt_of_lt_nat 1; norm_num },
  { apply ne_of_gt,
    apply lt_add_of_nonneg_of_lt (mul_self_nonneg a.re),
    rw ←int.add_one_le_iff,
    rw [mul_assoc, neg_mul_eq_neg_mul, neg_neg],
    refine le_mul_of_one_le_right zero_lt_three.le _,
    rwa [←int.sub_one_lt_iff, sub_self, mul_self_pos] }
end

lemma spts.four
  {p : ℤ√-3}
  (hfour : p.norm = 4)
  (hq : p.im ≠ 0) :
  abs p.re = 1 ∧ abs p.im = 1 :=
begin
  suffices : p.re ^ 2 = 1 ∧ p.im ^ 2 = 1,
  { apply and.imp _ _ this;
    { intro h,
      rwa [←sq_eq_sq (abs_nonneg (_ : ℤ)) zero_le_one, one_pow, sq_abs] } },
  have hq : p.im ^ 2 = 1,
  { apply le_antisymm,
    { contrapose! hfour with hq',
      apply ne_of_gt,
      rw ←int.add_one_le_iff at hq',
      calc 4 < 3 * 2 : by norm_num
      ... ≤ 3 * p.im ^ 2 : int.mul_le_mul_of_nonneg_left hq' (by norm_num)
      ... ≤ p.re ^ 2 + 3 * p.im ^ 2 : le_add_of_nonneg_left (pow_two_nonneg p.re)
      ... = p.norm : by { rw [zsqrtd.norm_def], ring } },
    { rw [←int.sub_one_lt_iff, sub_self],
      exact sq_pos_of_ne_zero _ hq, } },
  refine ⟨_, hq⟩,
  calc p.re ^ 2
      = p.re ^ 2 + 3 * p.im ^ 2 - 3 : by rw [hq, mul_one, add_sub_cancel]
  ... = p.norm - 3 : by { rw [zsqrtd.norm_def], ring }
  ... = 1 : by { rw hfour, norm_num },
end

lemma spts.four_of_coprime
  {p : ℤ√-3}
  (hcoprime : is_coprime p.re p.im)
  (hfour : p.norm = 4) :
  abs p.re = 1 ∧ abs p.im = 1 :=
begin
  apply spts.four hfour,
  rintro him,
  rw [him, is_coprime_zero_right, int.is_unit_iff_abs_eq] at hcoprime,
  rw [zsqrtd.norm_def, him, mul_zero, sub_zero, ←sq, ←sq_abs, hcoprime] at hfour,
  norm_num at hfour
end


/-
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 linear_algebra.dimension
import linear_algebra.finite_dimensional
import linear_algebra.std_basis

/-!
# Linear structures on function with finite support `ι →₀ M`

This file contains results on the `R`-module structure on functions of finite support from a type
`ι` to an `R`-module `M`, in particular in the case that `R` is a field.

Furthermore, it contains some facts about isomorphisms of vector spaces from equality of dimension
as well as the cardinality of finite dimensional vector spaces.

## TODO

Move the second half of this file to more appropriate other files.
-/

noncomputable theory
local attribute [instance, priority 100] classical.prop_decidable

open set linear_map submodule
open_locale cardinal

universes u v w

namespace finsupp

section ring
variables {R : Type*} {M : Type*} {ι : Type*}
variables [ring R] [add_comm_group M] [module R M]

lemma linear_independent_single {φ : ι → Type*}
  {f : Π ι, φ ι → M} (hf : ∀i, linear_independent R (f i)) :
  linear_independent R (λ ix : Σ i, φ i, single ix.1 (f ix.1 ix.2)) :=
begin
  apply @linear_independent_Union_finite R _ _ _ _ ι φ (λ i x, single i (f i x)),
  { assume i,
    have h_disjoint : disjoint (span R (range (f i))) (ker (lsingle i)),
    { rw ker_lsingle,
      exact disjoint_bot_right },
    apply (hf i).map h_disjoint },
  { intros i t ht hit,
    refine (disjoint_lsingle_lsingle {i} t (disjoint_singleton_left.2 hit)).mono _ _,
    { rw span_le,
      simp only [supr_singleton],
      rw range_coe,
      apply range_comp_subset_range },
    { refine supr₂_mono (λ i hi, _),
      rw [span_le, range_coe],
      apply range_comp_subset_range } }
end

open linear_map submodule

/-- The basis on `ι →₀ M` with basis vectors `λ ⟨i, x⟩, single i (b i x)`. -/
protected def basis {φ : ι → Type*} (b : ∀ i, basis (φ i) R M) :
  basis (Σ i, φ i) R (ι →₀ M) :=
basis.of_repr
  { to_fun := λ g,
      { to_fun := λ ix, (b ix.1).repr (g ix.1) ix.2,
        support := g.support.sigma (λ i, ((b i).repr (g i)).support),
        mem_support_to_fun := λ ix,
          by { simp only [finset.mem_sigma, mem_support_iff, and_iff_right_iff_imp, ne.def],
               intros b hg,
               simpa [hg] using b } },
    inv_fun := λ g,
      { to_fun := λ i, (b i).repr.symm (g.comap_domain _
                          (set.inj_on_of_injective sigma_mk_injective _)),
        support := g.support.image sigma.fst,
        mem_support_to_fun := λ i,
          by { rw [ne.def, ← (b i).repr.injective.eq_iff, (b i).repr.apply_symm_apply, ext_iff],
               simp only [exists_prop, linear_equiv.map_zero, comap_domain_apply, zero_apply,
                  exists_and_distrib_right, mem_support_iff, exists_eq_right, sigma.exists,
                  finset.mem_image, not_forall] } },
    left_inv := λ g,
      by { ext i, rw ← (b i).repr.injective.eq_iff, ext x,
           simp only [coe_mk, linear_equiv.apply_symm_apply, comap_domain_apply] },
    right_inv := λ g,
      by { ext ⟨i, x⟩,
           simp only [coe_mk, linear_equiv.apply_symm_apply, comap_domain_apply] },
    map_add' := λ g h, by { ext ⟨i, x⟩, simp only [coe_mk, add_apply, linear_equiv.map_add] },
    map_smul' := λ c h, by { ext ⟨i, x⟩, simp only [coe_mk, smul_apply, linear_equiv.map_smul,
                                                    ring_hom.id_apply] } }

@[simp] lemma basis_repr {φ : ι → Type*} (b : ∀ i, basis (φ i) R M)
  (g : ι →₀ M) (ix) :
  (finsupp.basis b).repr g ix = (b ix.1).repr (g ix.1) ix.2 :=
rfl

@[simp] lemma coe_basis {φ : ι → Type*} (b : ∀ i, basis (φ i) R M) :
  ⇑(finsupp.basis b) = λ (ix : Σ i, φ i), single ix.1 (b ix.1 ix.2) :=
funext $ λ ⟨i, x⟩, basis.apply_eq_iff.mpr $
begin
  ext ⟨j, y⟩,
  by_cases h : i = j,
  { cases h,
    simp only [basis_repr, single_eq_same, basis.repr_self,
               basis.finsupp.single_apply_left sigma_mk_injective] },
  simp only [basis_repr, single_apply, h, false_and, if_false, linear_equiv.map_zero, zero_apply]
end

/-- The basis on `ι →₀ M` with basis vectors `λ i, single i 1`. -/
@[simps]
protected def basis_single_one :
  basis ι R (ι →₀ R) :=
basis.of_repr (linear_equiv.refl _ _)

@[simp] lemma coe_basis_single_one :
  (finsupp.basis_single_one : ι → (ι →₀ R)) = λ i, finsupp.single i 1 :=
funext $ λ i, basis.apply_eq_iff.mpr rfl

end ring

section dim
variables {K : Type u} {V : Type v} {ι : Type v}
variables [field K] [add_comm_group V] [module K V]

lemma dim_eq : module.rank K (ι →₀ V) = #ι * module.rank K V :=
begin
  let bs := basis.of_vector_space K V,
  rw [← bs.mk_eq_dim'', ← (finsupp.basis (λa:ι, bs)).mk_eq_dim'',
    cardinal.mk_sigma, cardinal.sum_const']
end

end dim

end finsupp

section module
variables {K : Type u} {V V₁ V₂ : Type v} {V' : Type w}
variables [field K]
variables [add_comm_group V] [module K V]
variables [add_comm_group V₁] [module K V₁]
variables [add_comm_group V₂] [module K V₂]
variables [add_comm_group V'] [module K V']

open module

lemma equiv_of_dim_eq_lift_dim
  (h : cardinal.lift.{w} (module.rank K V) = cardinal.lift.{v} (module.rank K V')) :
  nonempty (V ≃ₗ[K] V') :=
begin
  haveI := classical.dec_eq V,
  haveI := classical.dec_eq V',
  let m := basis.of_vector_space K V,
  let m' := basis.of_vector_space K V',
  rw [←cardinal.lift_inj.1 m.mk_eq_dim, ←cardinal.lift_inj.1 m'.mk_eq_dim] at h,
  rcases quotient.exact h with ⟨e⟩,
  let e := (equiv.ulift.symm.trans e).trans equiv.ulift,
  exact ⟨(m.repr ≪≫ₗ (finsupp.dom_lcongr e)) ≪≫ₗ m'.repr.symm⟩
end

/-- Two `K`-vector spaces are equivalent if their dimension is the same. -/
def equiv_of_dim_eq_dim (h : module.rank K V₁ = module.rank K V₂) : V₁ ≃ₗ[K] V₂ :=
begin
  classical,
  exact classical.choice (equiv_of_dim_eq_lift_dim (cardinal.lift_inj.2 h))
end

/-- An `n`-dimensional `K`-vector space is equivalent to `fin n → K`. -/
def fin_dim_vectorspace_equiv (n : ℕ)
  (hn : (module.rank K V) = n) : V ≃ₗ[K] (fin n → K) :=
begin
  have : cardinal.lift.{u} (n : cardinal.{v}) = cardinal.lift.{v} (n : cardinal.{u}),
    by simp,
  have hn := cardinal.lift_inj.{v u}.2 hn,
  rw this at hn,
  rw ←@dim_fin_fun K _ n at hn,
  exact classical.choice (equiv_of_dim_eq_lift_dim hn),
end

end module

section module

open module

variables (K V : Type u) [field K] [add_comm_group V] [module K V]

lemma cardinal_mk_eq_cardinal_mk_field_pow_dim [finite_dimensional K V] :
  #V = #K ^ module.rank K V :=
begin
  let s := basis.of_vector_space_index K V,
  let hs := basis.of_vector_space K V,
  calc #V = #(s →₀ K) : quotient.sound ⟨hs.repr.to_equiv⟩
    ... = #(s → K) : quotient.sound ⟨finsupp.equiv_fun_on_fintype⟩
    ... = _ : by rw [← cardinal.lift_inj.1 hs.mk_eq_dim, cardinal.power_def]
end

lemma cardinal_lt_omega_of_finite_dimensional [fintype K] [finite_dimensional K V] :
  #V < ω :=
begin
  letI : is_noetherian K V := is_noetherian.iff_fg.2 infer_instance,
  rw cardinal_mk_eq_cardinal_mk_field_pow_dim K V,
  exact cardinal.power_lt_omega (cardinal.lt_omega_iff_fintype.2 ⟨infer_instance⟩)
    (is_noetherian.dim_lt_omega K V),
end

end module


/-
Copyright (c) 2021 Anne Baanen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Anne Baanen
-/
import data.fin.interval

/-!
# The structure of `fintype (fin n)`

This file contains some basic results about the `fintype` instance for `fin`,
especially properties of `finset.univ : finset (fin n)`.
-/

open finset
open fintype

namespace fin

@[simp] lemma Ioi_zero_eq_map {n : ℕ} :
  Ioi (0 : fin n.succ) = univ.map (fin.succ_embedding _).to_embedding :=
begin
  ext i,
  simp only [mem_Ioi, mem_map, mem_univ, function.embedding.coe_fn_mk, exists_true_left],
  split,
  { refine cases _ _ i,
    { rintro ⟨⟨⟩⟩ },
    { intros j _, exact ⟨j, rfl⟩ } },
  { rintro ⟨i, _, rfl⟩,
    exact succ_pos _ },
end

@[simp] lemma Ioi_succ {n : ℕ} (i : fin n) :
  Ioi i.succ = (Ioi i).map (fin.succ_embedding _).to_embedding :=
begin
  ext i,
  simp only [mem_filter, mem_Ioi, mem_map, mem_univ, true_and,
  function.embedding.coe_fn_mk, exists_true_left],
  split,
  { refine cases _ _ i,
    { rintro ⟨⟨⟩⟩ },
    { intros i hi,
      refine ⟨i, succ_lt_succ_iff.mp hi, rfl⟩ } },
  { rintro ⟨i, hi, rfl⟩, simpa },
end

end fin


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

! This file was ported from Lean 3 source module category_theory.full_subcategory
! leanprover-community/mathlib commit 550b58538991c8977703fdeb7c9d51a5aa27df11
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.CategoryTheory.Functor.FullyFaithful
import Std.Tactic.Lint.Basic

/-!
# Induced categories and full subcategories

Given a category `D` and a function `F : C → D `from a type `C` to the
objects of `D`, there is an essentially unique way to give `C` a
category structure such that `F` becomes a fully faithful functor,
namely by taking $$ Hom_C(X, Y) = Hom_D(FX, FY) $$. We call this the
category induced from `D` along `F`.

As a special case, if `C` is a subtype of `D`,
this produces the full subcategory of `D` on the objects belonging to `C`.
In general the induced category is equivalent to the full subcategory of `D` on the
image of `F`.

## Implementation notes

It looks odd to make `D` an explicit argument of `InducedCategory`,
when it is determined by the argument `F` anyways. The reason to make `D`
explicit is in order to control its syntactic form, so that instances
like `InducedCategory.has_forget₂` (elsewhere) refer to the correct
form of `D`. This is used to set up several algebraic categories like

  def CommMon : Type (u+1) := InducedCategory Mon (Bundled.map @CommMonoid.toMonoid)
  -- not `InducedCategory (Bundled Monoid) (Bundled.map @CommMonoid.toMonoid)`,
  -- even though `Mon = Bundled Monoid`!
-/

namespace CategoryTheory

universe v v₂ u₁ u₂
-- morphism levels before object levels. See note [CategoryTheory universes].

section Induced

variable {C : Type u₁} (D : Type u₂) [Category.{v} D]
variable (F : C → D)

/-- `InducedCategory D F`, where `F : C → D`, is a typeclass synonym for `C`,
which provides a category structure so that the morphisms `X ⟶ Y` are the morphisms
in `D` from `F X` to `F Y`.
-/
-- Porting note: @[nolint has_nonempty_instance unused_arguments]
@[nolint unusedArguments]
def InducedCategory (_F: C → D): Type u₁ :=
  C
#align category_theory.induced_category CategoryTheory.InducedCategory

variable {D}

instance InducedCategory.hasCoeToSort {α : Sort _} [CoeSort D α] :
    CoeSort (InducedCategory D F) α :=
  ⟨fun c => F c⟩
#align category_theory.induced_category.has_coe_to_sort CategoryTheory.InducedCategory.hasCoeToSort

instance InducedCategory.category : Category.{v} (InducedCategory D F) where
  Hom X Y := F X ⟶ F Y
  id X := 𝟙 (F X)
  comp f g := f ≫ g
#align category_theory.induced_category.category CategoryTheory.InducedCategory.category

/-- The forgetful functor from an induced category to the original category,
forgetting the extra data.
-/
@[simps]
def inducedFunctor : InducedCategory D F ⥤ D where
  obj := F
  map f := f
#align category_theory.induced_functor CategoryTheory.inducedFunctor
#align category_theory.induced_functor_map CategoryTheory.inducedFunctor_map
#align category_theory.induced_functor_obj CategoryTheory.inducedFunctor_obj

instance InducedCategory.full : Full (inducedFunctor F) where preimage f := f
#align category_theory.induced_category.full CategoryTheory.InducedCategory.full

instance InducedCategory.faithful : Faithful (inducedFunctor F) where
#align category_theory.induced_category.faithful CategoryTheory.InducedCategory.faithful

end Induced

section FullSubcategory

variable {C : Type u₁} [Category.{v} C]
variable (Z : C → Prop)

/--
A subtype-like structure for full subcategories. Morphisms just ignore the property. We don't use
actual subtypes since the simp-normal form `↑X` of `X.val` does not work well for full
subcategories.

See <https://stacks.math.columbia.edu/tag/001D>. We do not define 'strictly full' subcategories.
-/
@[ext]
structure FullSubcategory where
  /--The category of which this is a full subcategory-/
  obj : C
  /--The predicate satisfied by all objects in this subcategory-/
  property : Z obj
#align category_theory.full_subcategory CategoryTheory.FullSubcategory
#align category_theory.full_subcategory.ext CategoryTheory.FullSubcategory.ext
#align category_theory.full_subcategory.ext_iff CategoryTheory.FullSubcategory.ext_iff

instance FullSubcategory.category : Category.{v} (FullSubcategory Z) :=
  InducedCategory.category FullSubcategory.obj
#align category_theory.full_subcategory.category CategoryTheory.FullSubcategory.category

/-- The forgetful functor from a full subcategory into the original category
("forgetting" the condition).
-/
def fullSubcategoryInclusion : FullSubcategory Z ⥤ C :=
  inducedFunctor FullSubcategory.obj
#align category_theory.full_subcategory_inclusion CategoryTheory.fullSubcategoryInclusion

@[simp]
theorem fullSubcategoryInclusion.obj {X} : (fullSubcategoryInclusion Z).obj X = X.obj :=
  rfl
#align category_theory.full_subcategory_inclusion.obj CategoryTheory.fullSubcategoryInclusion.obj

@[simp]
theorem fullSubcategoryInclusion.map {X Y} {f : X ⟶ Y} : (fullSubcategoryInclusion Z).map f = f :=
  rfl
#align category_theory.full_subcategory_inclusion.map CategoryTheory.fullSubcategoryInclusion.map

instance FullSubcategory.full : Full (fullSubcategoryInclusion Z) :=
  InducedCategory.full _
#align category_theory.full_subcategory.full CategoryTheory.FullSubcategory.full

instance FullSubcategory.faithful : Faithful (fullSubcategoryInclusion Z) :=
  InducedCategory.faithful _
#align category_theory.full_subcategory.faithful CategoryTheory.FullSubcategory.faithful

variable {Z} {Z' : C → Prop}

/-- An implication of predicates `Z → Z'` induces a functor between full subcategories. -/
@[simps]
def FullSubcategory.map (h : ∀ ⦃X⦄, Z X → Z' X) : FullSubcategory Z ⥤ FullSubcategory Z' where
  obj X := ⟨X.1, h X.2⟩
  map f := f
#align category_theory.full_subcategory.map CategoryTheory.FullSubcategory.map
#align category_theory.full_subcategory.map_obj_obj CategoryTheory.FullSubcategory.map_obj_obj
#align category_theory.full_subcategory.map_map CategoryTheory.FullSubcategory.map_map

instance FullSubcategory.full_map (h : ∀ ⦃X⦄, Z X → Z' X) :
  Full (FullSubcategory.map h) where preimage f := f

instance FullSubcategory.faithful_map (h : ∀ ⦃X⦄, Z X → Z' X) :
  Faithful (FullSubcategory.map h) where

@[simp]
theorem FullSubcategory.map_inclusion (h : ∀ ⦃X⦄, Z X → Z' X) :
    FullSubcategory.map h ⋙ fullSubcategoryInclusion Z' = fullSubcategoryInclusion Z :=
  rfl
#align category_theory.full_subcategory.map_inclusion CategoryTheory.FullSubcategory.map_inclusion

section lift

variable {D : Type u₂} [Category.{v₂} D] (P Q : D → Prop)

/-- A functor which maps objects to objects satisfying a certain property induces a lift through
    the full subcategory of objects satisfying that property. -/
@[simps]
def FullSubcategory.lift (F : C ⥤ D) (hF : ∀ X, P (F.obj X)) : C ⥤ FullSubcategory P where
  obj X := ⟨F.obj X, hF X⟩
  map f := F.map f
#align category_theory.full_subcategory.lift CategoryTheory.FullSubcategory.lift
#align category_theory.full_subcategory.lift_obj_obj CategoryTheory.FullSubcategory.lift_obj_obj
#align category_theory.full_subcategory.lift_map CategoryTheory.FullSubcategory.lift_map

/-- Composing the lift of a functor through a full subcategory with the inclusion yields the
    original functor. Unfortunately, this is not true by definition, so we only get a natural
    isomorphism, but it is pointwise definitionally true, see
    `fullSubcategoryInclusion_obj_lift_obj` and `fullSubcategoryInclusion_map_lift_map`. -/
def FullSubcategory.lift_comp_inclusion (F : C ⥤ D) (hF : ∀ X, P (F.obj X)) :
    FullSubcategory.lift P F hF ⋙ fullSubcategoryInclusion P ≅ F :=
  NatIso.ofComponents (fun X => Iso.refl _) (by simp)
#align category_theory.full_subcategory.lift_comp_inclusion CategoryTheory.FullSubcategory.lift_comp_inclusion

@[simp]
theorem fullSubcategoryInclusion_obj_lift_obj (F : C ⥤ D) (hF : ∀ X, P (F.obj X)) {X : C} :
    (fullSubcategoryInclusion P).obj ((FullSubcategory.lift P F hF).obj X) = F.obj X :=
  rfl
#align category_theory.full_subcategory.inclusion_obj_lift_obj CategoryTheory.fullSubcategoryInclusion_obj_lift_obj

theorem fullSubcategoryInclusion_map_lift_map (F : C ⥤ D) (hF : ∀ X, P (F.obj X)) {X Y : C}
    (f : X ⟶ Y) :
    (fullSubcategoryInclusion P).map ((FullSubcategory.lift P F hF).map f) = F.map f :=
  rfl
#align category_theory.full_subcategory.inclusion_map_lift_map CategoryTheory.fullSubcategoryInclusion_map_lift_map

instance (F : C ⥤ D) (hF : ∀ X, P (F.obj X)) [Faithful F] :
    Faithful (FullSubcategory.lift P F hF) :=
  Faithful.of_comp_iso (FullSubcategory.lift_comp_inclusion P F hF)

instance (F : C ⥤ D) (hF : ∀ X, P (F.obj X)) [Full F] : Full (FullSubcategory.lift P F hF) :=
  Full.ofCompFaithfulIso (FullSubcategory.lift_comp_inclusion P F hF)

@[simp]
theorem FullSubcategory.lift_comp_map (F : C ⥤ D) (hF : ∀ X, P (F.obj X)) (h : ∀ ⦃X⦄, P X → Q X) :
    FullSubcategory.lift P F hF ⋙ FullSubcategory.map h =
      FullSubcategory.lift Q F fun X => h (hF X) :=
  rfl
#align category_theory.full_subcategory.lift_comp_map CategoryTheory.FullSubcategory.lift_comp_map

end lift

end FullSubcategory

end CategoryTheory


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

! This file was ported from Lean 3 source module topology.instances.rat_lemmas
! leanprover-community/mathlib commit 92ca63f0fb391a9ca5f22d2409a6080e786d99f7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Topology.Instances.Irrational
import Mathbin.Topology.Instances.Rat
import Mathbin.Topology.Alexandroff

/-!
# Additional lemmas about the topology on rational numbers

The structure of a metric space on `ℚ` (`rat.metric_space`) is introduced elsewhere, induced from
`ℝ`. In this file we prove some properties of this topological space and its one-point
compactification.

## Main statements

- `rat.totally_disconnected_space`: `ℚ` is a totally disconnected space;

- `rat.not_countably_generated_nhds_infty_alexandroff`: the filter of neighbourhoods of infinity in
  `alexandroff ℚ` is not countably generated.

## Notation

- `ℚ∞` is used as a local notation for `alexandroff ℚ`
-/

open Set Metric Filter TopologicalSpace

open Topology Alexandroff

-- mathport name: «exprℚ∞»
local notation "ℚ∞" => Alexandroff ℚ

namespace Rat

variable {p q : ℚ} {s t : Set ℚ}

theorem interior_compact_eq_empty (hs : IsCompact s) : interior s = ∅ :=
  denseEmbedding_coe_real.to_denseInducing.interior_compact_eq_empty dense_irrational hs
#align rat.interior_compact_eq_empty Rat.interior_compact_eq_empty

theorem dense_compl_compact (hs : IsCompact s) : Dense (sᶜ) :=
  interior_eq_empty_iff_dense_compl.1 (interior_compact_eq_empty hs)
#align rat.dense_compl_compact Rat.dense_compl_compact

instance cocompact_inf_nhds_neBot : NeBot (cocompact ℚ ⊓ 𝓝 p) :=
  by
  refine' (has_basis_cocompact.inf (nhds_basis_opens _)).neBot_iff.2 _
  rintro ⟨s, o⟩ ⟨hs, hpo, ho⟩; rw [inter_comm]
  exact (dense_compl_compact hs).inter_open_nonempty _ ho ⟨p, hpo⟩
#align rat.cocompact_inf_nhds_ne_bot Rat.cocompact_inf_nhds_neBot

theorem not_countably_generated_cocompact : ¬IsCountablyGenerated (cocompact ℚ) :=
  by
  intro H
  rcases exists_seq_tendsto (cocompact ℚ ⊓ 𝓝 0) with ⟨x, hx⟩
  rw [tendsto_inf] at hx; rcases hx with ⟨hxc, hx0⟩
  obtain ⟨n, hn⟩ : ∃ n : ℕ, x n ∉ insert (0 : ℚ) (range x)
  exact (hxc.eventually hx0.is_compact_insert_range.compl_mem_cocompact).exists
  exact hn (Or.inr ⟨n, rfl⟩)
#align rat.not_countably_generated_cocompact Rat.not_countably_generated_cocompact

theorem not_countably_generated_nhds_infty_alexandroff : ¬IsCountablyGenerated (𝓝 (∞ : ℚ∞)) :=
  by
  intro
  have : is_countably_generated (comap (coe : ℚ → ℚ∞) (𝓝 ∞)) := by infer_instance
  rw [Alexandroff.comap_coe_nhds_infty, coclosed_compact_eq_cocompact] at this
  exact not_countably_generated_cocompact this
#align rat.not_countably_generated_nhds_infty_alexandroff Rat.not_countably_generated_nhds_infty_alexandroff

theorem not_firstCountableTopology_alexandroff : ¬FirstCountableTopology ℚ∞ :=
  by
  intro
  exact not_countably_generated_nhds_infty_alexandroff inferInstance
#align rat.not_first_countable_topology_alexandroff Rat.not_firstCountableTopology_alexandroff

theorem not_secondCountableTopology_alexandroff : ¬SecondCountableTopology ℚ∞ :=
  by
  intro
  exact not_first_countable_topology_alexandroff inferInstance
#align rat.not_second_countable_topology_alexandroff Rat.not_secondCountableTopology_alexandroff

instance : TotallyDisconnectedSpace ℚ :=
  by
  refine' ⟨fun s hsu hs x hx y hy => _⟩; clear hsu
  by_contra' H : x ≠ y
  wlog hlt : x < y
  · exact this s hs y hy x hx H.symm (H.lt_or_lt.resolve_left hlt)
  rcases exists_irrational_btwn (Rat.cast_lt.2 hlt) with ⟨z, hz, hxz, hzy⟩
  have := hs.image coe continuous_coe_real.continuous_on
  rw [isPreconnected_iff_ordConnected] at this
  have : z ∈ coe '' s := this.out (mem_image_of_mem _ hx) (mem_image_of_mem _ hy) ⟨hxz.le, hzy.le⟩
  exact hz (image_subset_range _ _ this)

end Rat


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.finsupp.basic
import Mathlib.PostPort

universes u₂ u₁

namespace Mathlib

/-!
# The pointwise product on `finsupp`.

TODO per issue #1864:
We intend to remove the convolution product on finsupp, and define
it only on a type synonym `add_monoid_algebra`. After we've done this,
it would be good to make this the default product on `finsupp`.
-/

namespace finsupp

/-! ### Declarations about the pointwise product on `finsupp`s -/

/-- The product of `f g : α →₀ β` is the finitely supported function
  whose value at `a` is `f a * g a`. -/
protected instance has_mul {α : Type u₁} {β : Type u₂} [mul_zero_class β] : Mul (α →₀ β) :=
  { mul := zip_with Mul.mul sorry }

@[simp] theorem mul_apply {α : Type u₁} {β : Type u₂} [mul_zero_class β] {g₁ : α →₀ β} {g₂ : α →₀ β}
    {a : α} : coe_fn (g₁ * g₂) a = coe_fn g₁ a * coe_fn g₂ a :=
  rfl

theorem support_mul {α : Type u₁} {β : Type u₂} [mul_zero_class β] {g₁ : α →₀ β} {g₂ : α →₀ β} :
    support (g₁ * g₂) ⊆ support g₁ ∩ support g₂ :=
  sorry

protected instance semigroup {α : Type u₁} {β : Type u₂} [semiring β] : semigroup (α →₀ β) :=
  semigroup.mk Mul.mul sorry

protected instance distrib {α : Type u₁} {β : Type u₂} [semiring β] : distrib (α →₀ β) :=
  distrib.mk semigroup.mul add_comm_monoid.add sorry sorry

end Mathlib