/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Nicolò Cavalleri
-/
import algebra.algebra.pi
import algebra.periodic
import algebra.algebra.subalgebra.basic
import algebra.star.star_alg_hom
import tactic.field_simp
import topology.algebra.module.basic
import topology.algebra.infinite_sum.basic
import topology.algebra.star
import topology.algebra.uniform_group
import topology.continuous_function.ordered
import topology.uniform_space.compact_convergence

/-!
# Algebraic structures over continuous functions

In this file we define instances of algebraic structures over the type `continuous_map α β`
(denoted `C(α, β)`) of **bundled** continuous maps from `α` to `β`. For example, `C(α, β)`
is a group when `β` is a group, a ring when `β` is a ring, etc.

For each type of algebraic structure, we also define an appropriate subobject of `α → β`
with carrier `{ f : α → β | continuous f }`. For example, when `β` is a group, a subgroup
`continuous_subgroup α β` of `α → β` is constructed with carrier `{ f : α → β | continuous f }`.

Note that, rather than using the derived algebraic structures on these subobjects
(for example, when `β` is a group, the derived group structure on `continuous_subgroup α β`),
one should use `C(α, β)` with the appropriate instance of the structure.
-/

local attribute [elab_simple] continuous.comp

namespace continuous_functions

variables {α : Type*} {β : Type*} [topological_space α] [topological_space β]
variables {f g : {f : α → β | continuous f }}

instance : has_coe_to_fun {f : α → β | continuous f} (λ _, α → β) :=  ⟨subtype.val⟩

end continuous_functions

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

/- ### "mul" and "add" -/

@[to_additive]
instance has_mul [has_mul β] [has_continuous_mul β] : has_mul C(α, β) :=
⟨λ f g, ⟨f * g, continuous_mul.comp (f.continuous.prod_mk g.continuous : _)⟩⟩

@[simp, norm_cast, to_additive]
lemma coe_mul [has_mul β] [has_continuous_mul β] (f g : C(α, β)) : ⇑(f * g) = f * g := rfl

@[simp, to_additive]
lemma mul_apply [has_mul β] [has_continuous_mul β] (f g : C(α, β)) (x : α) :
  (f * g) x = f x * g x := rfl

@[simp, to_additive] lemma mul_comp [has_mul γ] [has_continuous_mul γ]
  (f₁ f₂ : C(β, γ)) (g : C(α, β)) :
  (f₁ * f₂).comp g = f₁.comp g * f₂.comp g :=
rfl

/- ### "one" -/

@[to_additive] instance [has_one β] : has_one C(α, β) := ⟨const α 1⟩

@[simp, norm_cast, to_additive] lemma coe_one [has_one β]  : ⇑(1 : C(α, β)) = 1 := rfl

@[simp, to_additive] lemma one_apply [has_one β] (x : α) : (1 : C(α, β)) x = 1 := rfl

@[simp, to_additive] lemma one_comp [has_one γ] (g : C(α, β)) : (1 : C(β, γ)).comp g = 1 := rfl

/- ### "nat_cast" -/

instance [has_nat_cast β] : has_nat_cast C(α, β) := ⟨λ n, continuous_map.const _ n⟩

@[simp, norm_cast] lemma coe_nat_cast [has_nat_cast β] (n : ℕ) : ((n : C(α, β)) : α → β) = n := rfl

@[simp] lemma nat_cast_apply [has_nat_cast β] (n : ℕ) (x : α) : (n : C(α, β)) x = n := rfl

/- ### "int_cast" -/

instance [has_int_cast β] : has_int_cast C(α, β) :=
⟨λ n, continuous_map.const _ n⟩

@[simp, norm_cast]
lemma coe_int_cast [has_int_cast β] (n : ℤ) : ((n : C(α, β)) : α → β) = n := rfl

@[simp] lemma int_cast_apply [has_int_cast β] (n : ℤ) (x : α) : (n : C(α, β)) x = n := rfl

/- ### "nsmul" and "pow" -/

instance has_nsmul [add_monoid β] [has_continuous_add β] : has_smul ℕ C(α, β) :=
⟨λ n f, ⟨n • f, f.continuous.nsmul n⟩⟩

@[to_additive]
instance has_pow [monoid β] [has_continuous_mul β] : has_pow C(α, β) ℕ :=
⟨λ f n, ⟨f ^ n, f.continuous.pow n⟩⟩

@[norm_cast, to_additive]
lemma coe_pow [monoid β] [has_continuous_mul β] (f : C(α, β)) (n : ℕ) :
  ⇑(f ^ n) = f ^ n := rfl

@[to_additive] lemma pow_apply [monoid β] [has_continuous_mul β]
  (f : C(α, β)) (n : ℕ) (x : α) :
  (f ^ n) x = f x ^ n :=
rfl

-- don't make auto-generated `coe_nsmul` and `nsmul_apply` simp, as the linter complains they're
-- redundant WRT `coe_smul`
attribute [simp] coe_pow pow_apply

@[to_additive] lemma pow_comp [monoid γ] [has_continuous_mul γ]
  (f : C(β, γ)) (n : ℕ) (g : C(α, β)) :
  (f^n).comp g = (f.comp g)^n :=
rfl

-- don't make `nsmul_comp` simp as the linter complains it's redundant WRT `smul_comp`
attribute [simp] pow_comp

/- ### "inv" and "neg" -/

@[to_additive]
instance [group β] [topological_group β] : has_inv C(α, β) :=
{ inv := λ f, ⟨f⁻¹, f.continuous.inv⟩ }

@[simp, norm_cast, to_additive]
lemma coe_inv [group β] [topological_group β] (f : C(α, β)) :
  ⇑(f⁻¹) = f⁻¹ :=
rfl

@[simp, to_additive]

@[simp, to_additive] lemma inv_comp [group γ] [topological_group γ] (f : C(β, γ)) (g : C(α, β)) :
  (f⁻¹).comp g = (f.comp g)⁻¹ :=
rfl

/- ### "div" and "sub" -/

@[to_additive]
instance [has_div β] [has_continuous_div β] : has_div C(α, β) :=
{ div := λ f g, ⟨f / g, f.continuous.div' g.continuous⟩ }

@[simp, norm_cast, to_additive]
lemma coe_div [has_div β] [has_continuous_div β] (f g : C(α, β)) : ⇑(f / g) = f / g :=
rfl

@[simp, to_additive] lemma div_apply [has_div β] [has_continuous_div β] (f g : C(α, β)) (x : α) :
  (f / g) x = f x / g x :=
rfl

@[simp, to_additive] lemma div_comp [has_div γ] [has_continuous_div γ]
  (f g : C(β, γ)) (h : C(α, β)) :
  (f / g).comp h = (f.comp h) / (g.comp h) :=
rfl

/- ### "zpow" and "zsmul" -/

instance has_zsmul [add_group β] [topological_add_group β] : has_smul ℤ C(α, β) :=
{ smul := λ z f, ⟨z • f, f.continuous.zsmul z⟩ }

@[to_additive]
instance has_zpow [group β] [topological_group β] :
  has_pow C(α, β) ℤ :=
{ pow := λ f z, ⟨f ^ z, f.continuous.zpow z⟩ }

@[norm_cast, to_additive]
lemma coe_zpow [group β] [topological_group β] (f : C(α, β)) (z : ℤ) :
  ⇑(f ^ z) = f ^ z :=
rfl

@[to_additive] lemma zpow_apply [group β] [topological_group β]
  (f : C(α, β)) (z : ℤ) (x : α) :
  (f ^ z) x = f x ^ z :=
rfl

-- don't make auto-generated `coe_zsmul` and `zsmul_apply` simp as the linter complains they're
-- redundant WRT `coe_smul`
attribute [simp] coe_zpow zpow_apply

@[to_additive]
lemma zpow_comp [group γ] [topological_group γ] (f : C(β, γ)) (z : ℤ) (g : C(α, β)) :
  (f^z).comp g = (f.comp g)^z :=
rfl

-- don't make `zsmul_comp` simp as the linter complains it's redundant WRT `smul_comp`
attribute [simp] zpow_comp

end continuous_map

section group_structure

/-!
### Group stucture

In this section we show that continuous functions valued in a topological group inherit
the structure of a group.
-/

section subtype

/-- The `submonoid` of continuous maps `α → β`. -/
@[to_additive "The `add_submonoid` of continuous maps `α → β`. "]
def continuous_submonoid (α : Type*) (β : Type*) [topological_space α] [topological_space β]
  [monoid β] [has_continuous_mul β] : submonoid (α → β) :=
{ carrier := { f : α → β | continuous f },
  one_mem' := @continuous_const _ _ _ _ 1,
  mul_mem' := λ f g fc gc, fc.mul gc }

/-- The subgroup of continuous maps `α → β`. -/
@[to_additive "The `add_subgroup` of continuous maps `α → β`. "]
def continuous_subgroup (α : Type*) (β : Type*) [topological_space α] [topological_space β]
  [group β] [topological_group β] : subgroup (α → β) :=
{ inv_mem' := λ f fc, continuous.inv fc,
  ..continuous_submonoid α β, }.

end subtype

namespace continuous_map

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

@[to_additive]
instance [semigroup β] [has_continuous_mul β] : semigroup C(α, β) :=
coe_injective.semigroup _ coe_mul

@[to_additive]
instance [comm_semigroup β] [has_continuous_mul β] : comm_semigroup C(α, β) :=
coe_injective.comm_semigroup _ coe_mul

@[to_additive]
instance [mul_one_class β] [has_continuous_mul β] : mul_one_class C(α, β) :=
coe_injective.mul_one_class _ coe_one coe_mul

instance [mul_zero_class β] [has_continuous_mul β] : mul_zero_class C(α, β) :=
coe_injective.mul_zero_class _ coe_zero coe_mul

instance [semigroup_with_zero β] [has_continuous_mul β] : semigroup_with_zero C(α, β) :=
coe_injective.semigroup_with_zero _ coe_zero coe_mul

@[to_additive]
instance [monoid β] [has_continuous_mul β] : monoid C(α, β) :=
coe_injective.monoid _ coe_one coe_mul coe_pow

instance [monoid_with_zero β] [has_continuous_mul β] : monoid_with_zero C(α, β) :=
coe_injective.monoid_with_zero _ coe_zero coe_one coe_mul coe_pow

@[to_additive]
instance [comm_monoid β] [has_continuous_mul β] : comm_monoid C(α, β) :=
coe_injective.comm_monoid _ coe_one coe_mul coe_pow

instance [comm_monoid_with_zero β] [has_continuous_mul β] : comm_monoid_with_zero C(α, β) :=
coe_injective.comm_monoid_with_zero _ coe_zero coe_one coe_mul coe_pow

@[to_additive]
instance [locally_compact_space α] [has_mul β] [has_continuous_mul β] :
  has_continuous_mul C(α, β) :=
⟨begin
  refine continuous_of_continuous_uncurry _ _,
  have h1 : continuous (λ x : (C(α, β) × C(α, β)) × α, x.fst.fst x.snd) :=
    continuous_eval'.comp (continuous_fst.prod_map continuous_id),
  have h2 : continuous (λ x : (C(α, β) × C(α, β)) × α, x.fst.snd x.snd) :=
    continuous_eval'.comp (continuous_snd.prod_map continuous_id),
  exact h1.mul h2,
end⟩

/-- Coercion to a function as an `monoid_hom`. Similar to `monoid_hom.coe_fn`. -/
@[to_additive "Coercion to a function as an `add_monoid_hom`. Similar to `add_monoid_hom.coe_fn`.",
  simps]
def coe_fn_monoid_hom [monoid β] [has_continuous_mul β] : C(α, β) →* (α → β) :=
{ to_fun := coe_fn, map_one' := coe_one, map_mul' := coe_mul }

variables (α)

/-- Composition on the left by a (continuous) homomorphism of topological monoids, as a
`monoid_hom`. Similar to `monoid_hom.comp_left`. -/
@[to_additive "Composition on the left by a (continuous) homomorphism of topological `add_monoid`s,
as an `add_monoid_hom`. Similar to `add_monoid_hom.comp_left`.", simps]
protected def _root_.monoid_hom.comp_left_continuous
  {γ : Type*} [monoid β] [has_continuous_mul β]
  [topological_space γ] [monoid γ] [has_continuous_mul γ] (g : β →* γ) (hg : continuous g)  :
  C(α, β) →* C(α, γ) :=
{ to_fun := λ f, (⟨g, hg⟩ : C(β, γ)).comp f,
  map_one' := ext $ λ x, g.map_one,
  map_mul' := λ f₁ f₂, ext $ λ x, g.map_mul _ _ }

variables {α}

/-- Composition on the right as a `monoid_hom`. Similar to `monoid_hom.comp_hom'`. -/
@[to_additive "Composition on the right as an `add_monoid_hom`. Similar to
`add_monoid_hom.comp_hom'`.", simps]
def comp_monoid_hom' {γ : Type*} [topological_space γ]
  [mul_one_class γ] [has_continuous_mul γ] (g : C(α, β)) : C(β, γ) →* C(α, γ) :=
{ to_fun := λ f, f.comp g, map_one' := one_comp g, map_mul' := λ f₁ f₂, mul_comp f₁ f₂ g }

open_locale big_operators
@[simp, to_additive] lemma coe_prod [comm_monoid β] [has_continuous_mul β]
  {ι : Type*} (s : finset ι) (f : ι → C(α, β)) :
  ⇑(∏ i in s, f i) = (∏ i in s, (f i : α → β)) :=
(coe_fn_monoid_hom : C(α, β) →* _).map_prod f s

@[to_additive]
lemma prod_apply [comm_monoid β] [has_continuous_mul β]
  {ι : Type*} (s : finset ι) (f : ι → C(α, β)) (a : α) :
  (∏ i in s, f i) a = (∏ i in s, f i a) :=
by simp

@[to_additive]
instance [group β] [topological_group β] : group C(α, β) :=
coe_injective.group _ coe_one coe_mul coe_inv coe_div coe_pow coe_zpow

@[to_additive]
instance [comm_group β] [topological_group β] : comm_group C(α, β) :=
coe_injective.comm_group _ coe_one coe_mul coe_inv coe_div coe_pow coe_zpow

@[to_additive] instance [comm_group β] [topological_group β] : topological_group C(α, β) :=
{ continuous_mul := by
  { letI : uniform_space β := topological_group.to_uniform_space β,
    have : uniform_group β := topological_comm_group_is_uniform,
    rw continuous_iff_continuous_at,
    rintros ⟨f, g⟩,
    rw [continuous_at, tendsto_iff_forall_compact_tendsto_uniformly_on, nhds_prod_eq],
    exactI λ K hK, uniform_continuous_mul.comp_tendsto_uniformly_on
      ((tendsto_iff_forall_compact_tendsto_uniformly_on.mp filter.tendsto_id K hK).prod
      (tendsto_iff_forall_compact_tendsto_uniformly_on.mp filter.tendsto_id K hK)), },
  continuous_inv := by
  { letI : uniform_space β := topological_group.to_uniform_space β,
    have : uniform_group β := topological_comm_group_is_uniform,
    rw continuous_iff_continuous_at,
    intro f,
    rw [continuous_at, tendsto_iff_forall_compact_tendsto_uniformly_on],
    exactI λ K hK, uniform_continuous_inv.comp_tendsto_uniformly_on
      (tendsto_iff_forall_compact_tendsto_uniformly_on.mp filter.tendsto_id K hK), } }

-- TODO: rewrite the next three lemmas for products and deduce sum case via `to_additive`, once
-- definition of `tprod` is in place

/-- If `α` is locally compact, and an infinite sum of functions in `C(α, β)`
converges to `g` (for the compact-open topology), then the pointwise sum converges to `g x` for
all `x ∈ α`. -/
lemma has_sum_apply {γ : Type*} [locally_compact_space α] [add_comm_monoid β] [has_continuous_add β]
  {f : γ → C(α, β)} {g : C(α, β)} (hf : has_sum f g) (x : α) :
  has_sum (λ i : γ, f i x) (g x) :=
begin
  let evₓ : add_monoid_hom C(α, β) β := (pi.eval_add_monoid_hom _ x).comp coe_fn_add_monoid_hom,
  exact hf.map evₓ (continuous_map.continuous_eval_const' x),
end

lemma summable_apply [locally_compact_space α] [add_comm_monoid β] [has_continuous_add β]
  {γ : Type*} {f : γ → C(α, β)} (hf : summable f) (x : α) :
  summable (λ i : γ, f i x) :=
(has_sum_apply hf.has_sum x).summable

lemma tsum_apply [locally_compact_space α] [t2_space β] [add_comm_monoid β] [has_continuous_add β]
  {γ : Type*} {f : γ → C(α, β)} (hf : summable f) (x : α) :
  (∑' (i:γ), f i x) = (∑' (i:γ), f i) x :=
(has_sum_apply hf.has_sum x).tsum_eq

end continuous_map

end group_structure

section ring_structure

/-!
### Ring stucture

In this section we show that continuous functions valued in a topological semiring `R` inherit
the structure of a ring.
-/

section subtype

/-- The subsemiring of continuous maps `α → β`. -/
def continuous_subsemiring (α : Type*) (R : Type*) [topological_space α] [topological_space R]
  [semiring R] [topological_semiring R] : subsemiring (α → R) :=
{ ..continuous_add_submonoid α R,
  ..continuous_submonoid α R }

/-- The subring of continuous maps `α → β`. -/
def continuous_subring (α : Type*) (R : Type*) [topological_space α] [topological_space R]
  [ring R] [topological_ring R] : subring (α → R) :=
{ ..continuous_subsemiring α R,
  ..continuous_add_subgroup α R }

end subtype

namespace continuous_map

instance {α : Type*} {β : Type*} [topological_space α] [topological_space β]
  [non_unital_non_assoc_semiring β] [topological_semiring β] :
  non_unital_non_assoc_semiring C(α, β) :=
coe_injective.non_unital_non_assoc_semiring _ coe_zero coe_add coe_mul coe_nsmul

instance {α : Type*} {β : Type*} [topological_space α] [topological_space β]
  [non_unital_semiring β] [topological_semiring β] :
  non_unital_semiring C(α, β) :=
coe_injective.non_unital_semiring _ coe_zero coe_add coe_mul coe_nsmul

instance {α : Type*} {β : Type*} [topological_space α] [topological_space β]
  [add_monoid_with_one β] [has_continuous_add β] :
  add_monoid_with_one C(α, β) :=
coe_injective.add_monoid_with_one _ coe_zero coe_one coe_add coe_nsmul coe_nat_cast

instance {α : Type*} {β : Type*} [topological_space α] [topological_space β]
  [non_assoc_semiring β] [topological_semiring β] :
  non_assoc_semiring C(α, β) :=
coe_injective.non_assoc_semiring _ coe_zero coe_one coe_add coe_mul coe_nsmul coe_nat_cast

instance {α : Type*} {β : Type*} [topological_space α] [topological_space β]
  [semiring β] [topological_semiring β] : semiring C(α, β) :=
coe_injective.semiring _ coe_zero coe_one coe_add coe_mul coe_nsmul coe_pow coe_nat_cast

instance {α : Type*} {β : Type*} [topological_space α] [topological_space β]
  [non_unital_non_assoc_ring β] [topological_ring β] : non_unital_non_assoc_ring C(α, β) :=
coe_injective.non_unital_non_assoc_ring _ coe_zero coe_add coe_mul coe_neg coe_sub
  coe_nsmul coe_zsmul

instance {α : Type*} {β : Type*} [topological_space α] [topological_space β]
  [non_unital_ring β] [topological_ring β] : non_unital_ring C(α, β) :=
coe_injective.non_unital_ring _ coe_zero coe_add coe_mul coe_neg coe_sub coe_nsmul coe_zsmul

instance {α : Type*} {β : Type*} [topological_space α] [topological_space β]
  [non_assoc_ring β] [topological_ring β] : non_assoc_ring C(α, β) :=
coe_injective.non_assoc_ring _ coe_zero coe_one coe_add coe_mul coe_neg coe_sub coe_nsmul coe_zsmul
  coe_nat_cast coe_int_cast

instance {α : Type*} {β : Type*} [topological_space α] [topological_space β]
  [ring β] [topological_ring β] : ring C(α, β) :=
coe_injective.ring _ coe_zero coe_one coe_add coe_mul coe_neg coe_sub coe_nsmul coe_zsmul coe_pow
  coe_nat_cast coe_int_cast

instance {α : Type*} {β : Type*} [topological_space α] [topological_space β]
  [non_unital_comm_semiring β] [topological_semiring β] : non_unital_comm_semiring C(α, β) :=
coe_injective.non_unital_comm_semiring _ coe_zero coe_add coe_mul coe_nsmul

instance {α : Type*} {β : Type*} [topological_space α]
  [topological_space β] [comm_semiring β] [topological_semiring β] : comm_semiring C(α, β) :=
coe_injective.comm_semiring _ coe_zero coe_one coe_add coe_mul coe_nsmul coe_pow coe_nat_cast

instance {α : Type*} {β : Type*} [topological_space α] [topological_space β]
  [non_unital_comm_ring β] [topological_ring β] : non_unital_comm_ring C(α, β) :=
coe_injective.non_unital_comm_ring _ coe_zero coe_add coe_mul coe_neg coe_sub coe_nsmul coe_zsmul

instance {α : Type*} {β : Type*} [topological_space α]
  [topological_space β] [comm_ring β] [topological_ring β] : comm_ring C(α, β) :=
coe_injective.comm_ring _ coe_zero coe_one coe_add coe_mul coe_neg coe_sub coe_nsmul coe_zsmul
  coe_pow coe_nat_cast coe_int_cast

/-- Composition on the left by a (continuous) homomorphism of topological semirings, as a
`ring_hom`.  Similar to `ring_hom.comp_left`. -/
@[simps] protected def _root_.ring_hom.comp_left_continuous (α : Type*) {β : Type*} {γ : Type*}
  [topological_space α] [topological_space β] [semiring β] [topological_semiring β]
  [topological_space γ] [semiring γ] [topological_semiring γ] (g : β →+* γ) (hg : continuous g) :
  C(α, β) →+* C(α, γ) :=
{ .. g.to_monoid_hom.comp_left_continuous α hg,
  .. g.to_add_monoid_hom.comp_left_continuous α hg }

/-- Coercion to a function as a `ring_hom`. -/
@[simps]
def coe_fn_ring_hom {α : Type*} {β : Type*} [topological_space α] [topological_space β]
  [semiring β] [topological_semiring β] : C(α, β) →+* (α → β) :=
{ to_fun := coe_fn,
  ..(coe_fn_monoid_hom : C(α, β) →* _),
  ..(coe_fn_add_monoid_hom : C(α, β) →+ _) }

end continuous_map

end ring_structure

local attribute [ext] subtype.eq

section module_structure

/-!
### Semiodule stucture

In this section we show that continuous functions valued in a topological module `M` over a
topological semiring `R` inherit the structure of a module.
-/

section subtype

variables (α : Type*) [topological_space α]
variables (R : Type*) [semiring R]
variables (M : Type*) [topological_space M] [add_comm_group M]
variables [module R M] [has_continuous_const_smul R M] [topological_add_group M]

/-- The `R`-submodule of continuous maps `α → M`. -/
def continuous_submodule : submodule R (α → M) :=
{ carrier := { f : α → M | continuous f },
  smul_mem' := λ c f hf, hf.const_smul c,
  ..continuous_add_subgroup α M }

end subtype

namespace continuous_map
variables {α β : Type*} [topological_space α] [topological_space β]
  {R R₁ : Type*}
  {M : Type*} [topological_space M]
  {M₂ : Type*} [topological_space M₂]

@[to_additive continuous_map.has_vadd]
instance [has_smul R M] [has_continuous_const_smul R M] : has_smul R C(α, M) :=
⟨λ r f, ⟨r • f, f.continuous.const_smul r⟩⟩

@[to_additive]
instance [locally_compact_space α] [has_smul R M] [has_continuous_const_smul R M] :
  has_continuous_const_smul R C(α, M) :=
⟨λ γ, continuous_of_continuous_uncurry _ (continuous_eval'.const_smul γ)⟩

@[to_additive]
instance [locally_compact_space α] [topological_space R] [has_smul R M]
  [has_continuous_smul R M] : has_continuous_smul R C(α, M) :=
⟨begin
  refine continuous_of_continuous_uncurry _ _,
  have h : continuous (λ x : (R × C(α, M)) × α, x.fst.snd x.snd) :=
    continuous_eval'.comp (continuous_snd.prod_map continuous_id),
  exact (continuous_fst.comp continuous_fst).smul h,
end⟩

@[simp, norm_cast, to_additive]
lemma coe_smul [has_smul R M] [has_continuous_const_smul R M]
  (c : R) (f : C(α, M)) : ⇑(c • f) = c • f := rfl

@[to_additive]
lemma smul_apply [has_smul R M] [has_continuous_const_smul R M]
  (c : R) (f : C(α, M)) (a : α) : (c • f) a = c • (f a) :=
rfl

@[simp, to_additive] lemma smul_comp [has_smul R M] [has_continuous_const_smul R M]
  (r : R) (f : C(β, M)) (g : C(α, β)) :
  (r • f).comp g = r • (f.comp g) :=
rfl

@[to_additive]
instance [has_smul R M] [has_continuous_const_smul R M]
  [has_smul R₁ M] [has_continuous_const_smul R₁ M]
  [smul_comm_class R R₁ M] : smul_comm_class R R₁ C(α, M) :=
{ smul_comm := λ _ _ _, ext $ λ _, smul_comm _ _ _ }

instance [has_smul R M] [has_continuous_const_smul R M]
  [has_smul R₁ M] [has_continuous_const_smul R₁ M]
  [has_smul R R₁] [is_scalar_tower R R₁ M] : is_scalar_tower R R₁ C(α, M) :=
{ smul_assoc := λ _ _ _, ext $ λ _, smul_assoc _ _ _ }

instance [has_smul R M] [has_smul Rᵐᵒᵖ M] [has_continuous_const_smul R M]
  [is_central_scalar R M] : is_central_scalar R C(α, M) :=
{ op_smul_eq_smul := λ _ _, ext $ λ _, op_smul_eq_smul _ _ }

instance [monoid R] [mul_action R M] [has_continuous_const_smul R M] : mul_action R C(α, M) :=
function.injective.mul_action _ coe_injective coe_smul

instance [monoid R] [add_monoid M] [distrib_mul_action R M]
  [has_continuous_add M] [has_continuous_const_smul R M] :
  distrib_mul_action R C(α, M) :=
function.injective.distrib_mul_action coe_fn_add_monoid_hom coe_injective coe_smul

variables [semiring R] [add_comm_monoid M] [add_comm_monoid M₂]
variables [has_continuous_add M] [module R M] [has_continuous_const_smul R M]
variables [has_continuous_add M₂] [module R M₂] [has_continuous_const_smul R M₂]

instance module : module R C(α, M) :=
function.injective.module R coe_fn_add_monoid_hom coe_injective coe_smul

variables (R)

/-- Composition on the left by a continuous linear map, as a `linear_map`.
Similar to `linear_map.comp_left`. -/
@[simps] protected def _root_.continuous_linear_map.comp_left_continuous (α : Type*)
  [topological_space α] (g : M →L[R] M₂) :
  C(α, M) →ₗ[R] C(α, M₂) :=
{ map_smul' := λ c f, ext $ λ x, g.map_smul' c _,
  .. g.to_linear_map.to_add_monoid_hom.comp_left_continuous α g.continuous }

/-- Coercion to a function as a `linear_map`. -/
@[simps]
def coe_fn_linear_map : C(α, M) →ₗ[R] (α → M) :=
{ to_fun := coe_fn,
  map_smul' := coe_smul,
  ..(coe_fn_add_monoid_hom : C(α, M) →+ _) }

end continuous_map

end module_structure

section algebra_structure

/-!
### Algebra structure

In this section we show that continuous functions valued in a topological algebra `A` over a ring
`R` inherit the structure of an algebra. Note that the hypothesis that `A` is a topological algebra
is obtained by requiring that `A` be both a `has_continuous_smul` and a `topological_semiring`.-/

section subtype

variables {α : Type*} [topological_space α]
{R : Type*} [comm_semiring R]
{A : Type*} [topological_space A] [semiring A]
[algebra R A] [topological_semiring A]

/-- The `R`-subalgebra of continuous maps `α → A`. -/
def continuous_subalgebra : subalgebra R (α → A) :=
{ carrier := { f : α → A | continuous f },
  algebra_map_mem' := λ r, (continuous_const : continuous $ λ (x : α), algebra_map R A r),
  ..continuous_subsemiring α A }

end subtype

section continuous_map

variables {α : Type*} [topological_space α]
{R : Type*} [comm_semiring R]
{A : Type*} [topological_space A] [semiring A]
[algebra R A] [topological_semiring A]
{A₂ : Type*} [topological_space A₂] [semiring A₂]
[algebra R A₂] [topological_semiring A₂]

/-- Continuous constant functions as a `ring_hom`. -/
def continuous_map.C : R →+* C(α, A) :=
{ to_fun    := λ c : R, ⟨λ x: α, ((algebra_map R A) c), continuous_const⟩,
  map_one'  := by ext x; exact (algebra_map R A).map_one,
  map_mul'  := λ c₁ c₂, by ext x; exact (algebra_map R A).map_mul _ _,
  map_zero' := by ext x; exact (algebra_map R A).map_zero,
  map_add'  := λ c₁ c₂, by ext x; exact (algebra_map R A).map_add _ _ }

@[simp] lemma continuous_map.C_apply (r : R) (a : α) : continuous_map.C r a = algebra_map R A r :=
rfl

instance continuous_map.algebra : algebra R C(α, A) :=
{ to_ring_hom := continuous_map.C,
  commutes' := λ c f, by ext x; exact algebra.commutes' _ _,
  smul_def' := λ c f, by ext x; exact algebra.smul_def' _ _, }

variables (R)

/-- Composition on the left by a (continuous) homomorphism of topological `R`-algebras, as an
`alg_hom`. Similar to `alg_hom.comp_left`. -/
@[simps] protected def alg_hom.comp_left_continuous {α : Type*} [topological_space α]
  (g : A →ₐ[R] A₂) (hg : continuous g) :
  C(α, A) →ₐ[R] C(α, A₂) :=
{ commutes' := λ c, continuous_map.ext $ λ _, g.commutes' _,
  .. g.to_ring_hom.comp_left_continuous α hg }

variables (A)

/--
Precomposition of functions into a normed ring by a continuous map is an algebra homomorphism.
-/
@[simps] def continuous_map.comp_right_alg_hom {α β : Type*} [topological_space α]
  [topological_space β] (f : C(α, β)) : C(β, A) →ₐ[R] C(α, A) :=
{ to_fun := λ g, g.comp f,
  map_zero' := by { ext, refl, },
  map_add' := λ g₁ g₂, by { ext, refl, },
  map_one' := by { ext, refl, },
  map_mul' := λ g₁ g₂, by { ext, refl, },
  commutes' := λ r, by { ext, refl, }, }

variables {A}

/-- Coercion to a function as an `alg_hom`. -/
@[simps]
def continuous_map.coe_fn_alg_hom : C(α, A) →ₐ[R] (α → A) :=
{ to_fun := coe_fn,
  commutes' := λ r, rfl,
  ..(continuous_map.coe_fn_ring_hom : C(α, A) →+* _) }

variables {R}

/--
A version of `separates_points` for subalgebras of the continuous functions,
used for stating the Stone-Weierstrass theorem.
-/
abbreviation subalgebra.separates_points (s : subalgebra R C(α, A)) : Prop :=
set.separates_points ((λ f : C(α, A), (f : α → A)) '' (s : set C(α, A)))

lemma subalgebra.separates_points_monotone :
  monotone (λ s : subalgebra R C(α, A), s.separates_points) :=
λ s s' r h x y n,
begin
  obtain ⟨f, m, w⟩ := h n,
  rcases m with ⟨f, ⟨m, rfl⟩⟩,
  exact ⟨_, ⟨f, ⟨r m, rfl⟩⟩, w⟩,
end

@[simp] lemma algebra_map_apply (k : R) (a : α) :
  algebra_map R C(α, A) k a = k • 1 :=
by { rw algebra.algebra_map_eq_smul_one, refl, }

variables {𝕜 : Type*} [topological_space 𝕜]

/--
A set of continuous maps "separates points strongly"
if for each pair of distinct points there is a function with specified values on them.

We give a slightly unusual formulation, where the specified values are given by some
function `v`, and we ask `f x = v x ∧ f y = v y`. This avoids needing a hypothesis `x ≠ y`.

In fact, this definition would work perfectly well for a set of non-continuous functions,
but as the only current use case is in the Stone-Weierstrass theorem,
writing it this way avoids having to deal with casts inside the set.
(This may need to change if we do Stone-Weierstrass on non-compact spaces,
where the functions would be continuous functions vanishing at infinity.)
-/
def set.separates_points_strongly (s : set C(α, 𝕜)) : Prop :=
∀ (v : α → 𝕜) (x y : α), ∃ f : s, (f x : 𝕜) = v x ∧ f y = v y

variables [field 𝕜] [topological_ring 𝕜]

/--
Working in continuous functions into a topological field,
a subalgebra of functions that separates points also separates points strongly.

By the hypothesis, we can find a function `f` so `f x ≠ f y`.
By an affine transformation in the field we can arrange so that `f x = a` and `f x = b`.
-/
lemma subalgebra.separates_points.strongly {s : subalgebra 𝕜 C(α, 𝕜)} (h : s.separates_points) :
  (s : set C(α, 𝕜)).separates_points_strongly :=
λ v x y,
begin
  by_cases n : x = y,
  { subst n,
    use ((v x) • 1 : C(α, 𝕜)),
    { apply s.smul_mem,
      apply s.one_mem, },
    { simp [coe_fn_coe_base'] }, },
  obtain ⟨f, ⟨f, ⟨m, rfl⟩⟩, w⟩ := h n,
  replace w : f x - f y ≠ 0 := sub_ne_zero_of_ne w,
  let a := v x,
  let b := v y,
  let f' := ((b - a) * (f x - f y)⁻¹) • (continuous_map.C (f x) - f) + continuous_map.C a,
  refine ⟨⟨f', _⟩, _, _⟩,
  { simp only [f', set_like.mem_coe, subalgebra.mem_to_submodule],
    -- TODO should there be a tactic for this?
    -- We could add an attribute `@[subobject_mem]`, and a tactic
    -- ``def subobject_mem := `[solve_by_elim with subobject_mem { max_depth := 10 }]``
    solve_by_elim
      [subalgebra.add_mem, subalgebra.smul_mem, subalgebra.sub_mem, subalgebra.algebra_map_mem]
      { max_depth := 6 }, },
  { simp [f', coe_fn_coe_base'], },
  { simp [f', coe_fn_coe_base', inv_mul_cancel_right₀ w], },
end

end continuous_map

instance continuous_map.subsingleton_subalgebra (α : Type*) [topological_space α]
  (R : Type*) [comm_semiring R] [topological_space R] [topological_semiring R]
  [subsingleton α] : subsingleton (subalgebra R C(α, R)) :=
begin
  fsplit,
  intros s₁ s₂,
  by_cases n : nonempty α,
  { obtain ⟨x⟩ := n,
    ext f,
    have h : f = algebra_map R C(α, R) (f x),
    { ext x', simp only [mul_one, algebra.id.smul_eq_mul, algebra_map_apply], congr, },
    rw h,
    simp only [subalgebra.algebra_map_mem], },
  { ext f,
    have h : f = 0,
    { ext x', exact false.elim (n ⟨x'⟩), },
    subst h,
    simp only [subalgebra.zero_mem], },
end

end algebra_structure

section module_over_continuous_functions

/-!
### Structure as module over scalar functions

If `M` is a module over `R`, then we show that the space of continuous functions from `α` to `M`
is naturally a module over the ring of continuous functions from `α` to `R`. -/

namespace continuous_map

instance has_smul' {α : Type*} [topological_space α]
  {R : Type*} [semiring R] [topological_space R]
  {M : Type*} [topological_space M] [add_comm_monoid M]
  [module R M] [has_continuous_smul R M] :
  has_smul C(α, R) C(α, M) :=
⟨λ f g, ⟨λ x, (f x) • (g x), (continuous.smul f.2 g.2)⟩⟩

instance module' {α : Type*} [topological_space α]
  (R : Type*) [ring R] [topological_space R] [topological_ring R]
  (M : Type*) [topological_space M] [add_comm_monoid M] [has_continuous_add M]
  [module R M] [has_continuous_smul R M] :
  module C(α, R) C(α, M) :=
{ smul     := (•),
  smul_add := λ c f g, by ext x; exact smul_add (c x) (f x) (g x),
  add_smul := λ c₁ c₂ f, by ext x; exact add_smul (c₁ x) (c₂ x) (f x),
  mul_smul := λ c₁ c₂ f, by ext x; exact mul_smul (c₁ x) (c₂ x) (f x),
  one_smul := λ f, by ext x; exact one_smul R (f x),
  zero_smul := λ f, by ext x; exact zero_smul _ _,
  smul_zero := λ r, by ext x; exact smul_zero _, }

end continuous_map

end module_over_continuous_functions

/-!
We now provide formulas for `f ⊓ g` and `f ⊔ g`, where `f g : C(α, β)`,
in terms of `continuous_map.abs`.
-/

section
variables {R : Type*} [linear_ordered_field R]

-- TODO:
-- This lemma (and the next) could go all the way back in `algebra.order.field`,
-- except that it is tedious to prove without tactics.
-- Rather than stranding it at some intermediate location,
-- it's here, immediately prior to the point of use.
lemma min_eq_half_add_sub_abs_sub {x y : R} : min x y = 2⁻¹ * (x + y - |x - y|) :=
by cases le_total x y with h h; field_simp [h, abs_of_nonneg, abs_of_nonpos, mul_two]; abel

lemma max_eq_half_add_add_abs_sub {x y : R} : max x y = 2⁻¹ * (x + y + |x - y|) :=
by cases le_total x y with h h; field_simp [h, abs_of_nonneg, abs_of_nonpos, mul_two]; abel

end

namespace continuous_map

section lattice
variables {α : Type*} [topological_space α]
variables {β : Type*} [linear_ordered_field β] [topological_space β]
  [order_topology β] [topological_ring β]

lemma inf_eq (f g : C(α, β)) : f ⊓ g = (2⁻¹ : β) • (f + g - |f - g|) :=
ext (λ x, by simpa using min_eq_half_add_sub_abs_sub)

-- Not sure why this is grosser than `inf_eq`:
lemma sup_eq (f g : C(α, β)) : f ⊔ g = (2⁻¹ : β) • (f + g + |f - g|) :=
ext (λ x, by simpa [mul_add] using @max_eq_half_add_add_abs_sub _ _ (f x) (g x))

end lattice

/-!
### Star structure

If `β` has a continuous star operation, we put a star structure on `C(α, β)` by using the
star operation pointwise.

If `β` is a ⋆-ring, then `C(α, β)` inherits a ⋆-ring structure.

If `β` is a ⋆-ring and a ⋆-module over `R`, then the space of continuous functions from `α` to `β`
is a ⋆-module over `R`.

-/

section star_structure
variables {R α β : Type*}
variables [topological_space α] [topological_space β]

section has_star
variables [has_star β] [has_continuous_star β]

instance : has_star C(α, β) :=
{ star := λ f, star_continuous_map.comp f }

@[simp] lemma coe_star (f : C(α, β)) : ⇑(star f) = star f := rfl

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

end has_star

instance [has_involutive_star β] [has_continuous_star β] : has_involutive_star C(α, β) :=
{ star_involutive := λ f, ext $ λ x, star_star _ }

instance [add_monoid β] [has_continuous_add β] [star_add_monoid β] [has_continuous_star β] :
  star_add_monoid C(α, β) :=
{ star_add := λ f g, ext $ λ x, star_add _ _ }

instance [semigroup β] [has_continuous_mul β] [star_semigroup β] [has_continuous_star β] :
  star_semigroup C(α, β) :=
{ star_mul := λ f g, ext $ λ x, star_mul _ _ }

instance [non_unital_semiring β] [topological_semiring β] [star_ring β] [has_continuous_star β] :
  star_ring C(α, β) :=
{ ..continuous_map.star_add_monoid }

instance [has_star R] [has_star β] [has_smul R β] [star_module R β]
  [has_continuous_star β] [has_continuous_const_smul R β] :
  star_module R C(α, β) :=
{ star_smul := λ k f, ext $ λ x, star_smul _ _ }

end star_structure

variables {X Y Z : Type*} [topological_space X] [topological_space Y] [topological_space Z]
variables (𝕜 : Type*) [comm_semiring 𝕜]
variables (A : Type*) [topological_space A] [semiring A] [topological_semiring A] [star_ring A]
variables [has_continuous_star A] [algebra 𝕜 A]

/-- The functorial map taking `f : C(X, Y)` to `C(Y, A) →⋆ₐ[𝕜] C(X, A)` given by pre-composition
with the continuous function `f`. See `continuous_map.comp_monoid_hom'` and
`continuous_map.comp_add_monoid_hom'`, `continuous_map.comp_right_alg_hom` for bundlings of
pre-composition into a `monoid_hom`, an `add_monoid_hom` and an `alg_hom`, respectively, under
suitable assumptions on `A`. -/
@[simps] def comp_star_alg_hom' (f : C(X, Y)) : C(Y, A) →⋆ₐ[𝕜] C(X, A) :=
{ to_fun := λ g, g.comp f,
  map_one' := one_comp _,
  map_mul' := λ _ _, rfl,
  map_zero' := zero_comp _,
  map_add' := λ _ _, rfl,
  commutes' := λ _, rfl,
  map_star' := λ _, rfl }

/-- `continuous_map.comp_star_alg_hom'` sends the identity continuous map to the identity
`star_alg_hom` -/
lemma comp_star_alg_hom'_id :
  comp_star_alg_hom' 𝕜 A (continuous_map.id X) = star_alg_hom.id 𝕜 C(X, A) :=
star_alg_hom.ext $ λ _, continuous_map.ext $ λ _, rfl

/-- `continuous_map.comp_star_alg_hom` is functorial. -/
lemma comp_star_alg_hom'_comp (g : C(Y, Z)) (f : C(X, Y)) :
  comp_star_alg_hom' 𝕜 A (g.comp f) = (comp_star_alg_hom' 𝕜 A f).comp (comp_star_alg_hom' 𝕜 A g) :=
star_alg_hom.ext $ λ _, continuous_map.ext $ λ _, rfl

section periodicity

/-! ### Summing translates of a function -/

/-- Summing the translates of `f` by `ℤ • p` gives a map which is periodic with period `p`.
(This is true without any convergence conditions, since if the sum doesn't converge it is taken to
be the zero map, which is periodic.) -/
lemma periodic_tsum_comp_add_zsmul [locally_compact_space X] [add_comm_group X]
  [topological_add_group X] [add_comm_monoid Y] [has_continuous_add Y] [t2_space Y]
  (f : C(X, Y)) (p : X) :
  function.periodic ⇑(∑' (n : ℤ), f.comp (continuous_map.add_right (n • p))) p :=
begin
  intro x,
  by_cases h : summable (λ n : ℤ, f.comp (continuous_map.add_right (n • p))),
  { convert congr_arg (λ f : C(X, Y), f x) ((equiv.add_right (1 : ℤ)).tsum_eq _) using 1,
    simp_rw [←tsum_apply h, ←tsum_apply ((equiv.add_right (1 : ℤ)).summable_iff.mpr h),
      equiv.coe_add_right, comp_apply, coe_add_right, add_one_zsmul, add_comm (_ • p) p,
      ←add_assoc] },
  { rw tsum_eq_zero_of_not_summable h,
    simp only [coe_zero, pi.zero_apply] }
end

end periodicity

end continuous_map

namespace homeomorph

variables {X Y : Type*} [topological_space X] [topological_space Y]
variables (𝕜 : Type*) [comm_semiring 𝕜]
variables (A : Type*) [topological_space A] [semiring A] [topological_semiring A] [star_ring A]
variables [has_continuous_star A] [algebra 𝕜 A]

/-- `continuous_map.comp_star_alg_hom'` as a `star_alg_equiv` when the continuous map `f` is
actually a homeomorphism. -/
@[simps] def comp_star_alg_equiv' (f : X ≃ₜ Y) : C(Y, A) ≃⋆ₐ[𝕜] C(X, A) :=
{ to_fun := (f : C(X, Y)).comp_star_alg_hom' 𝕜 A,
  inv_fun := (f.symm : C(Y, X)).comp_star_alg_hom' 𝕜 A,
  left_inv := λ g, by simp only [continuous_map.comp_star_alg_hom'_apply, continuous_map.comp_assoc,
    to_continuous_map_comp_symm, continuous_map.comp_id],
  right_inv := λ g, by simp only [continuous_map.comp_star_alg_hom'_apply,
    continuous_map.comp_assoc, symm_comp_to_continuous_map, continuous_map.comp_id],
  map_smul' := λ k a, map_smul (f.to_continuous_map.comp_star_alg_hom' 𝕜 A) k a,
  .. (f.to_continuous_map.comp_star_alg_hom' 𝕜 A) }

end homeomorph


/-
Copyright (c) 2021 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang
-/
import category_theory.limits.shapes.pullbacks
import ring_theory.tensor_product
import algebra.category.Ring.limits
import algebra.category.Ring.instances
import category_theory.limits.shapes.strict_initial
import ring_theory.subring.basic

/-!
# Constructions of (co)limits in CommRing

In this file we provide the explicit (co)cones for various (co)limits in `CommRing`, including
* tensor product is the pushout
* `Z` is the initial object
* `0` is the strict terminal object
* cartesian product is the product
* `ring_hom.eq_locus` is the equalizer

-/

universes u u'

open category_theory category_theory.limits
open_locale tensor_product

namespace CommRing

section pushout

variables {R A B : CommRing.{u}} (f : R ⟶ A) (g : R ⟶ B)

/-- The explicit cocone with tensor products as the fibered product in `CommRing`. -/
def pushout_cocone : limits.pushout_cocone f g :=
begin
  letI := ring_hom.to_algebra f,
  letI := ring_hom.to_algebra g,
  apply limits.pushout_cocone.mk,
  show CommRing, from CommRing.of (A ⊗[R] B),
  show A ⟶ _,  from algebra.tensor_product.include_left.to_ring_hom,
  show B ⟶ _,  from algebra.tensor_product.include_right.to_ring_hom,
  ext r,
  transitivity algebra_map R (A ⊗[R] B) r,
  { exact algebra.tensor_product.include_left.commutes r },
  { exact (algebra.tensor_product.include_right.commutes r).symm }
end

@[simp]
lemma pushout_cocone_inl : (pushout_cocone f g).inl = (by
{ letI := f.to_algebra, letI := g.to_algebra,
  exactI algebra.tensor_product.include_left.to_ring_hom }) := rfl

@[simp]
lemma pushout_cocone_inr : (pushout_cocone f g).inr = (by
{ letI := f.to_algebra, letI := g.to_algebra,
  exactI algebra.tensor_product.include_right.to_ring_hom }) := rfl

@[simp]
lemma pushout_cocone_X : (pushout_cocone f g).X = (by
{ letI := f.to_algebra, letI := g.to_algebra,
  exactI CommRing.of (A ⊗[R] B) }) := rfl

/-- Verify that the `pushout_cocone` is indeed the colimit. -/
def pushout_cocone_is_colimit : limits.is_colimit (pushout_cocone f g) :=
limits.pushout_cocone.is_colimit_aux' _ (λ s,
begin
  letI := ring_hom.to_algebra f,
  letI := ring_hom.to_algebra g,
  letI := ring_hom.to_algebra (f ≫ s.inl),
  let f' : A →ₐ[R] s.X := { commutes' := λ r, by
      { change s.inl.to_fun (f r) = (f ≫ s.inl) r, refl }, ..s.inl },
  let g' : B →ₐ[R] s.X := { commutes' := λ r, by
      { change (g ≫ s.inr) r = (f ≫ s.inl) r,
        congr' 1,
        exact (s.ι.naturality limits.walking_span.hom.snd).trans
          (s.ι.naturality limits.walking_span.hom.fst).symm }, ..s.inr },
  /- The factor map is a ⊗ b ↦ f(a) * g(b). -/
  use alg_hom.to_ring_hom (algebra.tensor_product.product_map f' g'),
  simp only [pushout_cocone_inl, pushout_cocone_inr],
  split, { ext x, exact algebra.tensor_product.product_map_left_apply  _ _ x, },
  split, { ext x, exact algebra.tensor_product.product_map_right_apply _ _ x, },
  intros h eq1 eq2,
  let h' : (A ⊗[R] B) →ₐ[R] s.X :=
    { commutes' := λ r, by
    { change h ((f r) ⊗ₜ[R] 1) = s.inl (f r),
      rw ← eq1, simp }, ..h },
  suffices : h' = algebra.tensor_product.product_map f' g',
  { ext x,
    change h' x = algebra.tensor_product.product_map f' g' x,
    rw this },
  apply algebra.tensor_product.ext,
  intros a b,
  simp [← eq1, ← eq2, ← h.map_mul],
end)

end pushout

section terminal

/-- The trivial ring is the (strict) terminal object of `CommRing`. -/
def punit_is_terminal : is_terminal (CommRing.of.{u} punit) :=
begin
  apply_with is_terminal.of_unique { instances := ff },
  tidy
end

instance CommRing_has_strict_terminal_objects : has_strict_terminal_objects CommRing.{u} :=
begin
  apply has_strict_terminal_objects_of_terminal_is_strict (CommRing.of punit),
  intros X f,
  refine ⟨⟨by tidy, by ext, _⟩⟩,
  ext,
  have e : (0 : X) = 1 := by { rw [← f.map_one, ← f.map_zero], congr },
  replace e : 0 * x = 1 * x := congr_arg (λ a, a * x) e,
  rw [one_mul, zero_mul, ← f.map_zero] at e,
  exact e,
end

lemma subsingleton_of_is_terminal {X : CommRing} (hX : is_terminal X) : subsingleton X :=
(hX.unique_up_to_iso punit_is_terminal).CommRing_iso_to_ring_equiv.to_equiv
  .subsingleton_congr.mpr (show subsingleton punit, by apply_instance)

/-- `ℤ` is the initial object of `CommRing`. -/
def Z_is_initial : is_initial (CommRing.of ℤ) :=
begin
  apply_with is_initial.of_unique { instances := ff },
  exact λ R, ⟨⟨int.cast_ring_hom R⟩, λ a, a.ext_int _⟩,
end

end terminal

section product

variables (A B : CommRing.{u})

/-- The product in `CommRing` is the cartesian product. This is the binary fan. -/
@[simps X]
def prod_fan : binary_fan A B :=
binary_fan.mk (CommRing.of_hom $ ring_hom.fst A B) (CommRing.of_hom $ ring_hom.snd A B)

/-- The product in `CommRing` is the cartesian product. -/
def prod_fan_is_limit : is_limit (prod_fan A B) :=
{ lift := λ c, ring_hom.prod (c.π.app ⟨walking_pair.left⟩) (c.π.app ⟨walking_pair.right⟩),
  fac' := λ c j, by { ext, rcases j with ⟨⟨⟩⟩;
    simpa only [binary_fan.π_app_left, binary_fan.π_app_right, comp_apply, ring_hom.prod_apply] },
  uniq' := λ s m h, by { ext, { simpa using congr_hom (h ⟨walking_pair.left⟩) x },
    { simpa using congr_hom (h ⟨walking_pair.right⟩) x } } }

end product

section equalizer

variables {A B : CommRing.{u}} (f g : A ⟶ B)

/-- The equalizer in `CommRing` is the equalizer as sets. This is the equalizer fork. -/
def equalizer_fork : fork f g :=
fork.of_ι (CommRing.of_hom (ring_hom.eq_locus f g).subtype) (by { ext ⟨x, e⟩, simpa using e })

/-- The equalizer in `CommRing` is the equalizer as sets. -/
def equalizer_fork_is_limit : is_limit (equalizer_fork f g) :=
begin
  fapply fork.is_limit.mk',
  intro s,
  use s.ι.cod_restrict _ (λ x, (concrete_category.congr_hom s.condition x : _)),
  split,
  { ext, refl },
  { intros m hm, ext x, exact concrete_category.congr_hom hm x }
end

instance : is_local_ring_hom (equalizer_fork f g).ι :=
begin
  constructor,
  rintros ⟨a, (h₁ : _ = _)⟩ (⟨⟨x,y,h₃,h₄⟩,(rfl : x = _)⟩ : is_unit a),
  have : y ∈ ring_hom.eq_locus f g,
  { apply (f.is_unit_map ⟨⟨x,y,h₃,h₄⟩,rfl⟩ : is_unit (f x)).mul_left_inj.mp,
    conv_rhs { rw h₁ },
    rw [← f.map_mul, ← g.map_mul, h₄, f.map_one, g.map_one] },
  rw is_unit_iff_exists_inv,
  exact ⟨⟨y, this⟩, subtype.eq h₃⟩,
end

instance equalizer_ι_is_local_ring_hom (F : walking_parallel_pair ⥤ CommRing.{u}) :
  is_local_ring_hom (limit.π F walking_parallel_pair.zero) :=
begin
  have := lim_map_π (diagram_iso_parallel_pair F).hom walking_parallel_pair.zero,
  rw ← is_iso.comp_inv_eq at this,
  rw ← this,
  rw ← limit.iso_limit_cone_hom_π ⟨_, equalizer_fork_is_limit
    (F.map walking_parallel_pair_hom.left) (F.map walking_parallel_pair_hom.right)⟩
    walking_parallel_pair.zero,
  change is_local_ring_hom ((lim.map _ ≫ _ ≫ (equalizer_fork _ _).ι) ≫ _),
  apply_instance
end

open category_theory.limits.walking_parallel_pair opposite
open category_theory.limits.walking_parallel_pair_hom

instance equalizer_ι_is_local_ring_hom' (F : walking_parallel_pairᵒᵖ ⥤ CommRing.{u}) :
  is_local_ring_hom (limit.π F (opposite.op walking_parallel_pair.one)) :=
begin
  have : _ = limit.π F (walking_parallel_pair_op_equiv.functor.obj _) :=
    (limit.iso_limit_cone_inv_π ⟨_, is_limit.whisker_equivalence (limit.is_limit F)
      walking_parallel_pair_op_equiv⟩ walking_parallel_pair.zero : _),
  erw ← this,
  apply_instance
end

end equalizer

section pullback

/--
In the category of `CommRing`, the pullback of `f : A ⟶ C` and `g : B ⟶ C` is the `eq_locus` of
the two maps `A × B ⟶ C`. This is the constructed pullback cone.
-/
def pullback_cone {A B C : CommRing.{u}} (f : A ⟶ C) (g : B ⟶ C) : pullback_cone f g :=
pullback_cone.mk
  (CommRing.of_hom $ (ring_hom.fst A B).comp
    (ring_hom.eq_locus (f.comp (ring_hom.fst A B)) (g.comp (ring_hom.snd A B))).subtype)
  (CommRing.of_hom $ (ring_hom.snd A B).comp
    (ring_hom.eq_locus (f.comp (ring_hom.fst A B)) (g.comp (ring_hom.snd A B))).subtype)
  (by { ext ⟨x, e⟩, simpa [CommRing.of_hom] using e })

/-- The constructed pullback cone is indeed the limit. -/
def pullback_cone_is_limit {A B C : CommRing.{u}} (f : A ⟶ C) (g : B ⟶ C) :
  is_limit (pullback_cone f g) :=
begin
  fapply pullback_cone.is_limit.mk,
  { intro s,
    apply (s.fst.prod s.snd).cod_restrict,
    intro x, exact congr_arg (λ f : s.X →+* C, f x) s.condition },
  { intro s, ext x, refl },
  { intro s, ext x, refl },
  { intros s m e₁ e₂, ext,
    { exact (congr_arg (λ f : s.X →+* A, f x) e₁ : _) },
    { exact (congr_arg (λ f : s.X →+* B, f x) e₂ : _) } }
end

end pullback

end CommRing


import category_theory.monoidal.rigid.basic
import kassel.lemma.to_matrix

namespace kassel
open category_theory
open category_theory.monoidal_category

universes v u

section

variables
  {C: Type u}
  [category.{v} C]
  [monoidal_category.{v} C]
  [right_rigid_category.{v} C]

lemma congr_comp_left {X Y Z: C} (h: X ⟶ Y) (f g: Y ⟶ Z):
  f = g → h ≫ f = h ≫ g :=
by intro h; rw h

lemma congr_comp_right {X Y Z: C} (h: Y ⟶ Z) (f g: X ⟶ Y):
  f = g → f ≫ h = g ≫ h :=
by intro h; rw h

lemma congr_tensor_left {X₁ Y₁ X₂ Y₂: C} (h: X₁ ⟶ Y₁) (f g: X₂ ⟶ Y₂):
  f = g → h ⊗ f = h ⊗ g :=
by intro h; rw h

lemma congr_tensor_right {X₁ Y₁ X₂ Y₂: C} (h: X₂ ⟶ Y₂) (f g: X₁ ⟶ Y₁):
  f = g → f ⊗ h = g ⊗ h :=
by intro h; rw h

namespace iso

@[reassoc] lemma hom_dual_inv_dual_id {X Y: C} (f: X ≅ Y):
  (f.hom)ᘁ ≫ (f.inv)ᘁ = 𝟙 _ :=
by rw [←comp_right_adjoint_mate, iso.inv_hom_id, right_adjoint_mate_id]

@[reassoc] lemma inv_dual_hom_dual_id {X Y: C} (f: X ≅ Y):
  (f.inv)ᘁ ≫ (f.hom)ᘁ = 𝟙 _ :=
by rw [←comp_right_adjoint_mate, iso.hom_inv_id, right_adjoint_mate_id]

end iso

-- * Show that `X ⊗ Y` and `Yᘁ ⊗ Xᘁ` form an exact pairing.

@[instance] def tensor_exact_pairing (X Y: C): exact_pairing (X ⊗ Y) (Yᘁ ⊗ Xᘁ) := {
  coevaluation := η_ X Xᘁ ≫ ((ρ_ _).inv ⊗  𝟙 _) ≫ ((𝟙 _ ⊗ η_ Y Yᘁ) ⊗ 𝟙 _) ≫ ((α_ _ _ _).inv ⊗ 𝟙 _) ≫ (α_ _ _ _).hom,
  evaluation := (α_ _ _ _).inv ≫ ((α_ _ _ _).hom ⊗ 𝟙 _) ≫ ((𝟙 _ ⊗ ε_ X Xᘁ) ⊗ 𝟙 _) ≫ ((ρ_ _).hom ⊗ 𝟙 _) ≫ ε_ Y Yᘁ,
  coevaluation_evaluation' :=
  begin
    simp_rw [id_tensor_comp, comp_tensor_id, ←tensor_id, category.assoc],
    slice_lhs 2 3 {
      rw ←triangle_assoc_comp_left_inv,
      simp only [←tensor_comp],
      rw [category.assoc, ←associator_inv_naturality, ←id_tensor_comp_assoc],
      simp only [tensor_comp],
      rw [associator_inv_conjugation, associator_conjugation (𝟙 Yᘁ) _ _],
      rw [←category.id_comp ((λ_ Xᘁ).inv ≫ (η_ Y Yᘁ ⊗ 𝟙 Xᘁ)), ←category.comp_id ((λ_ Xᘁ).inv ≫ (η_ Y Yᘁ ⊗ 𝟙 Xᘁ))],
      simp only [tensor_comp, ←tensor_id],
    },
    slice_lhs 13 14 {
      simp only [←tensor_comp, category.comp_id],
      rw [associator_conjugation, associator_inv_conjugation _ _ (𝟙 Xᘁ)],
      rw [←category.id_comp ((𝟙 Yᘁ ⊗ ε_ X Xᘁ) ≫ (ρ_ Yᘁ).hom), ←category.comp_id ((𝟙 Yᘁ ⊗ ε_ X Xᘁ) ≫ (ρ_ Yᘁ).hom)],
      simp only [tensor_comp, ←tensor_id],
    },
    have h: ((α_ Yᘁ Xᘁ X).inv ⊗ (𝟙 Y ⊗ 𝟙 Yᘁ) ⊗ 𝟙 Xᘁ) ≫ (α_ (Yᘁ ⊗ Xᘁ) X ((Y ⊗ Yᘁ) ⊗ Xᘁ)).hom ≫ ((𝟙 Yᘁ ⊗ 𝟙 Xᘁ) ⊗ (α_ X (Y ⊗ Yᘁ) Xᘁ).inv) ≫ ((𝟙 Yᘁ ⊗ 𝟙 Xᘁ) ⊗ (α_ X Y Yᘁ).inv ⊗ 𝟙 Xᘁ) ≫ ((𝟙 Yᘁ ⊗ 𝟙 Xᘁ) ⊗ (α_ (X ⊗ Y) Yᘁ Xᘁ).hom) ≫ (α_ (Yᘁ ⊗ Xᘁ) (X ⊗ Y) (Yᘁ ⊗ Xᘁ)).inv ≫ ((α_ (Yᘁ ⊗ Xᘁ) X Y).inv ⊗ 𝟙 Yᘁ ⊗ 𝟙 Xᘁ) ≫ (((α_ Yᘁ Xᘁ X).hom ⊗ 𝟙 Y) ⊗ 𝟙 Yᘁ ⊗ 𝟙 Xᘁ) ≫ (α_ (Yᘁ ⊗ Xᘁ ⊗ X) Y (Yᘁ ⊗ Xᘁ)).hom ≫ ((𝟙 Yᘁ ⊗ 𝟙 Xᘁ ⊗ 𝟙 X) ⊗ (α_ Y Yᘁ Xᘁ).inv) = 𝟙 _ := by coherence,
    slice_lhs 4 14 { rw [h, category.comp_id], }, clear h,
    slice_lhs 4 5 {
      simp only [tensor_id],
      rw eq.trans (id_tensor_comp_tensor_id _ _) (tensor_id_comp_id_tensor _ _).symm,
      simp only [id_tensor_comp, comp_tensor_id],
    },
    iterate 2 { rw associator_conjugation, },
    slice_lhs 3 6 { rw [←pentagon_hom_inv, iso.inv_hom_id_assoc], },
    slice_lhs 2 4 { simp only [←id_tensor_comp], rw exact_pairing.coevaluation_evaluation, },
    iterate 2 { rw associator_inv_conjugation, },
    slice_lhs 8 11 { rw [←pentagon_inv_inv_hom_assoc, iso.hom_inv_id_assoc, iso.hom_inv_id, category.comp_id], },
    slice_lhs 7 9 { simp only [←comp_tensor_id], rw exact_pairing.coevaluation_evaluation, },
    coherence,
  end,
  evaluation_coevaluation' :=
  begin
    simp_rw [id_tensor_comp, comp_tensor_id, ←tensor_id],
    slice_lhs 2 3 {
      simp only [←tensor_comp, category.comp_id],
      rw [associator_conjugation, associator_inv_conjugation (𝟙 Xᘁ) _ _],
      rw [←category.id_comp ((ρ_ X).inv ≫ (𝟙 X ⊗ η_ Y Yᘁ)), ←category.comp_id ((ρ_ X).inv ≫ (𝟙 X ⊗ η_ Y Yᘁ))],
      simp only [tensor_comp, ←tensor_id],
    },
    slice_lhs 12 13 {
      rw ←triangle,
      simp only [←tensor_comp],
      rw [associator_naturality_assoc, ←id_tensor_comp],
      simp only [tensor_comp],
      rw [associator_inv_conjugation, associator_conjugation _ _ (𝟙 Yᘁ)],
      rw [←category.id_comp ((ε_ X Xᘁ ⊗ 𝟙 Y) ≫ (λ_ Y).hom), ←category.comp_id ((ε_ X Xᘁ ⊗ 𝟙 Y) ≫ (λ_ Y).hom)],
      simp only [tensor_comp, ←tensor_id],
    },
    have h: ((𝟙 X ⊗ 𝟙 Y ⊗ 𝟙 Yᘁ) ⊗ (α_ Xᘁ X Y).hom) ≫ (α_ (X ⊗ Y ⊗ Yᘁ) Xᘁ (X ⊗ Y)).inv ≫ (((α_ X Y Yᘁ).inv ⊗ 𝟙 Xᘁ) ⊗ 𝟙 X ⊗ 𝟙 Y) ≫ ((α_ (X ⊗ Y) Yᘁ Xᘁ).hom ⊗ 𝟙 X ⊗ 𝟙 Y) ≫ (α_ (X ⊗ Y) (Yᘁ ⊗ Xᘁ) (X ⊗ Y)).hom ≫ ((𝟙 X ⊗ 𝟙 Y) ⊗ (α_ (Yᘁ ⊗ Xᘁ) X Y).inv) ≫ ((𝟙 X ⊗ 𝟙 Y) ⊗ (α_ Yᘁ Xᘁ X).hom ⊗ 𝟙 Y) ≫ ((𝟙 X ⊗ 𝟙 Y) ⊗ (α_ Yᘁ (Xᘁ ⊗ X) Y).hom) ≫ (α_ (X ⊗ Y) Yᘁ ((Xᘁ ⊗ X) ⊗ Y)).inv ≫ ((α_ X Y Yᘁ).hom ⊗ (𝟙 Xᘁ ⊗ 𝟙 X) ⊗ 𝟙 Y) = 𝟙 _ := by coherence,
    slice_lhs 4 14 { rw [h, category.comp_id], }, clear h,
    slice_lhs 4 5 {
      simp only [tensor_id],
      rw eq.trans (tensor_id_comp_id_tensor _ _) (id_tensor_comp_tensor_id _ _).symm,
      simp only [id_tensor_comp, comp_tensor_id],
    },
    iterate 2 { rw associator_inv_conjugation, },
    slice_lhs 3 6 { rw [←pentagon_inv_hom, iso.hom_inv_id_assoc], },
    slice_lhs 2 4 { simp only [←comp_tensor_id], rw exact_pairing.evaluation_coevaluation, },
    iterate 2 { rw associator_conjugation, },
    slice_lhs 8 11 { rw [pentagon_inv_inv_hom_assoc, iso.inv_hom_id, category.comp_id], },
    slice_lhs 7 9 { simp only [←id_tensor_comp], rw exact_pairing.evaluation_coevaluation, },
    coherence,
  end
}

def tensor_iso_dual_tensor_dual (X Y: C): (X ⊗ Y)ᘁ ≅ Yᘁ ⊗ Xᘁ := {
  hom := (ρ_ _).inv ≫ (𝟙 _ ⊗ η_ (X ⊗ Y) (Yᘁ ⊗ Xᘁ)) ≫ (α_ _ _ _).inv ≫ ((ε_ (X ⊗ Y) (X ⊗ Y)ᘁ) ⊗ 𝟙 Yᘁ ⊗ 𝟙 Xᘁ) ≫ (λ_ _).hom,
  inv := (ρ_ _).inv ≫ ((𝟙 Yᘁ ⊗ 𝟙 Xᘁ) ⊗ (η_ (X ⊗ Y) (X ⊗ Y)ᘁ)) ≫ (α_ _ _ _).inv ≫ (ε_ (X ⊗ Y) (Yᘁ ⊗ Xᘁ) ⊗ 𝟙 _) ≫ (λ_ _).hom,
  hom_inv_id' := begin
    rw right_unitor_inv_naturality_assoc,
    simp_rw comp_tensor_id,
    slice_lhs 6 7 { rw [tensor_id, eq.trans (tensor_id_comp_id_tensor _ _) (id_tensor_comp_tensor_id _ _).symm], },
    slice_lhs 7 8 { rw [←tensor_id, associator_inv_naturality], },
    slice_lhs 8 9 { rw [←comp_tensor_id, ←left_unitor_tensor', category.assoc, ←left_unitor_naturality], simp only [comp_tensor_id], },
    slice_lhs 9 11 { rw [unitors_equal, ←triangle], simp only [category.assoc], rw associator_naturality_assoc, },
    slice_lhs 2 6 { simp only [←tensor_comp, category.id_comp], rw [←category.comp_id (η_ _ (X ⊗ Y)ᘁ), tensor_comp], simp only [comp_tensor_id], },
    slice_lhs 6 9 { rw [tensor_id, category.id_comp, ←pentagon_hom_inv], },
    slice_lhs 5 6 { rw associator_naturality, },
    slice_lhs 6 9 { simp only [←tensor_comp, category.comp_id, ←category.assoc], rw [←category.id_comp (ε_ _ (X ⊗ Y)ᘁ), tensor_comp], simp only [id_tensor_comp], },

    slice_lhs 3 3 { rw [←tensor_id, associator_conjugation, associator_inv_conjugation (η_ _ _) _ _], },
    slice_lhs 10 10 { rw [←tensor_id, associator_conjugation, associator_inv_conjugation _ (ε_ _ _) _], },
    simp_rw id_tensor_comp,
    have h: (𝟙 (X ⊗ Y)ᘁ ⊗ (α_ ((X ⊗ Y) ⊗ Yᘁ ⊗ Xᘁ) (X ⊗ Y) (X ⊗ Y)ᘁ).hom) ≫ (α_ (X ⊗ Y)ᘁ ((X ⊗ Y) ⊗ Yᘁ ⊗ Xᘁ) ((X ⊗ Y) ⊗ (X ⊗ Y)ᘁ)).inv ≫ ((α_ (X ⊗ Y)ᘁ (X ⊗ Y) (Yᘁ ⊗ Xᘁ)).inv ⊗ 𝟙 ((X ⊗ Y) ⊗ (X ⊗ Y)ᘁ)) ≫ (α_ ((X ⊗ Y)ᘁ ⊗ X ⊗ Y) (Yᘁ ⊗ Xᘁ) ((X ⊗ Y) ⊗ (X ⊗ Y)ᘁ)).hom ≫ (𝟙 ((X ⊗ Y)ᘁ ⊗ X ⊗ Y) ⊗ (𝟙 Yᘁ ⊗ 𝟙 Xᘁ) ⊗ 𝟙 ((X ⊗ Y) ⊗ (X ⊗ Y)ᘁ)) ≫ (𝟙 ((X ⊗ Y)ᘁ ⊗ X ⊗ Y) ⊗ (α_ (Yᘁ ⊗ Xᘁ) (X ⊗ Y) (X ⊗ Y)ᘁ).inv) ≫ (α_ (X ⊗ Y)ᘁ (X ⊗ Y) (((Yᘁ ⊗ Xᘁ) ⊗ X ⊗ Y) ⊗ (X ⊗ Y)ᘁ)).hom ≫ (𝟙 (X ⊗ Y)ᘁ ⊗ (α_ (X ⊗ Y) ((Yᘁ ⊗ Xᘁ) ⊗ X ⊗ Y) (X ⊗ Y)ᘁ).inv) = 𝟙 _ ⊗ (α_ _ _ _).hom ⊗ 𝟙 _ := by coherence,
    slice_lhs 6 13 { rw h, }, clear h,
    slice_lhs 5 7 {
      simp only [←id_tensor_comp, ←comp_tensor_id],
      rw exact_pairing.evaluation_coevaluation,
      simp only [id_tensor_comp, comp_tensor_id],
      rw [associator_inv_conjugation, ←triangle_assoc_comp_right, ←triangle_assoc_comp_left_inv],
      simp only [id_tensor_comp, comp_tensor_id],
    },
    slice_lhs 3 7 { rw ←pentagon_inv_hom_assoc, simp only [←comp_tensor_id], rw [iso.hom_inv_id_assoc, ←associator_inv_naturality], },
    slice_lhs 4 9 { rw iso.inv_hom_id_assoc, simp only [←id_tensor_comp_assoc], rw [iso.inv_hom_id, category.comp_id, associator_inv_naturality], },
    slice_lhs 2 3 { rw [←tensor_comp, iso.inv_hom_id, tensor_id, category.comp_id], },
    slice_lhs 4 5 { rw [←tensor_comp, iso.inv_hom_id, tensor_id, category.id_comp], },
    slice_lhs 2 4 { rw exact_pairing.coevaluation_evaluation, },
    coherence,
  end,
  inv_hom_id' := begin
    rw right_unitor_inv_naturality_assoc,
    simp_rw comp_tensor_id,
    slice_lhs 6 7 { rw [eq.trans (tensor_id_comp_id_tensor _ _) (id_tensor_comp_tensor_id _ _).symm], },
    slice_lhs 7 8 { rw [←tensor_id, associator_inv_naturality], },
    slice_lhs 8 9 { rw [tensor_id, ←comp_tensor_id, ←left_unitor_tensor', category.assoc, ←left_unitor_naturality], simp only [comp_tensor_id], },
    slice_lhs 9 11 { rw [unitors_equal, ←triangle], simp only [category.assoc], rw associator_naturality_assoc, },
    slice_lhs 2 6 { simp only [←tensor_comp, category.id_comp], rw [←category.comp_id (η_ _ (Yᘁ ⊗ Xᘁ)), tensor_comp], simp only [comp_tensor_id], },
    slice_lhs 6 9 { rw [tensor_id, category.id_comp, ←pentagon_hom_inv], },
    slice_lhs 5 6 { rw associator_naturality, },
    slice_lhs 6 9 { simp only [←tensor_comp, category.comp_id, ←category.assoc], rw [←category.id_comp (ε_ _ (Yᘁ ⊗ Xᘁ)), tensor_comp], simp only [id_tensor_comp], },

    slice_lhs 3 3 { rw [←tensor_id, associator_conjugation, associator_inv_conjugation (η_ _ _) _ _, tensor_id], },
    slice_lhs 10 10 { rw [←tensor_id, associator_conjugation, associator_inv_conjugation _ (ε_ _ _) _], },
    simp_rw id_tensor_comp,
    have h: (𝟙 (Yᘁ ⊗ Xᘁ) ⊗ (α_ ((X ⊗ Y) ⊗ (X ⊗ Y)ᘁ) (X ⊗ Y) (Yᘁ ⊗ Xᘁ)).hom) ≫ (α_ (Yᘁ ⊗ Xᘁ) ((X ⊗ Y) ⊗ (X ⊗ Y)ᘁ) ((X ⊗ Y) ⊗ Yᘁ ⊗ Xᘁ)).inv ≫ ((α_ (Yᘁ ⊗ Xᘁ) (X ⊗ Y) (X ⊗ Y)ᘁ).inv ⊗ 𝟙 ((X ⊗ Y) ⊗ Yᘁ ⊗ Xᘁ)) ≫ (α_ ((Yᘁ ⊗ Xᘁ) ⊗ X ⊗ Y) (X ⊗ Y)ᘁ ((X ⊗ Y) ⊗ Yᘁ ⊗ Xᘁ)).hom ≫ (𝟙 ((Yᘁ ⊗ Xᘁ) ⊗ X ⊗ Y) ⊗ 𝟙 (X ⊗ Y)ᘁ ⊗ 𝟙 ((X ⊗ Y) ⊗ Yᘁ ⊗ Xᘁ)) ≫ (𝟙 ((Yᘁ ⊗ Xᘁ) ⊗ X ⊗ Y) ⊗ (α_ (X ⊗ Y)ᘁ (X ⊗ Y) (Yᘁ ⊗ Xᘁ)).inv) ≫ (α_ (Yᘁ ⊗ Xᘁ) (X ⊗ Y) (((X ⊗ Y)ᘁ ⊗ X ⊗ Y) ⊗ Yᘁ ⊗ Xᘁ)).hom ≫ (𝟙 (Yᘁ ⊗ Xᘁ) ⊗ (α_ (X ⊗ Y) ((X ⊗ Y)ᘁ ⊗ X ⊗ Y) (Yᘁ ⊗ Xᘁ)).inv) = 𝟙 _ ⊗ (α_ _ _ _).hom ⊗ 𝟙 _ := by coherence,
    slice_lhs 6 13 { rw h, }, clear h,
    slice_lhs 5 7 {
      simp only [←id_tensor_comp, ←comp_tensor_id],
      rw exact_pairing.evaluation_coevaluation,
      simp only [id_tensor_comp, comp_tensor_id],
      rw [associator_inv_conjugation, ←triangle_assoc_comp_right, ←triangle_assoc_comp_left_inv],
      simp only [id_tensor_comp, comp_tensor_id],
    },
    slice_lhs 3 7 { rw ←pentagon_inv_hom_assoc, simp only [←comp_tensor_id], rw [iso.hom_inv_id_assoc, ←associator_inv_naturality], },
    slice_lhs 4 9 { rw iso.inv_hom_id_assoc, simp only [←id_tensor_comp_assoc], rw [iso.inv_hom_id, category.comp_id, associator_inv_naturality], },
    slice_lhs 2 3 { rw [←tensor_comp, iso.inv_hom_id, tensor_id, category.comp_id], },
    slice_lhs 4 5 { rw [←tensor_comp, iso.inv_hom_id, tensor_id, category.id_comp], },
    slice_lhs 2 4 { rw exact_pairing.coevaluation_evaluation, },
    coherence,
  end
}

notation `δ_` := tensor_iso_dual_tensor_dual

end

section right_pivotal_category

variables
  (C: Type u)
  [category.{v} C]
  [monoidal_category.{v} C]
  [right_rigid_category.{v} C]

-- * Define pivotal categories (rigid categories equipped with a natural isomorphism `ᘁᘁ ≅ 𝟙 C`).
-- 参考: https://tqft.net/web/research/students/SamQuinn/thesis.pdf

class right_pivotal_category :=
  (right_pivotor: Π X: C, X ≅ Xᘁᘁ)
  (notation `φ_` := right_pivotor)
  (right_pivotor_naturality': ∀ {X Y: C} (f: X ⟶ Y), f ≫ (φ_ Y).hom = (φ_ X).hom ≫ fᘁᘁ)
  (right_pivotor_tensor_naturality': ∀ {X Y: C}, (φ_ (X ⊗ Y)).hom = ((φ_ X).hom ⊗ (φ_ Y).hom) ≫ (δ_ _ _).inv ≫ ((δ_ _ _).hom)ᘁ)

restate_axiom right_pivotal_category.right_pivotor_naturality'
attribute [reassoc] right_pivotal_category.right_pivotor_naturality
restate_axiom right_pivotal_category.right_pivotor_tensor_naturality'
attribute [reassoc] right_pivotal_category.right_pivotor_tensor_naturality

open right_pivotal_category
notation `φ_` := right_pivotor

variable [right_pivotal_category.{v} C]

lemma right_pivotor_inv_naturality {X Y: C} (f: X ⟶ Y):
  (φ_ X).inv ≫ f = fᘁᘁ ≫ (φ_ Y).inv :=
begin
  rw ←(φ_ X).cancel_iso_hom_left,
  rw ←iso.cancel_iso_hom_right _ _ (φ_ Y),
  simp_rw [iso.hom_inv_id_assoc, category.assoc, iso.inv_hom_id, category.comp_id, right_pivotor_naturality],
end

lemma right_pivotor_inv_tensor_naturality (X Y: C):
  (φ_ (X ⊗ Y)).inv = ((δ_ _ _).inv)ᘁ ≫ (δ_ _ _).hom ≫ ((φ_ X).inv ⊗ (φ_ Y).inv) :=
begin
  rw [←(φ_ (X ⊗ Y)).cancel_iso_hom_left, iso.hom_inv_id, right_pivotor_tensor_naturality],
  simp_rw category.assoc,
  rw [iso.hom_dual_inv_dual_id_assoc, iso.inv_hom_id_assoc],
  simp_rw [←tensor_comp, iso.hom_inv_id, tensor_id],
end

end right_pivotal_category

section

variables
  {C: Type u}
  [category.{v} C]
  [monoidal_category.{v} C]
  [right_rigid_category.{v} C]
  (V: C)

lemma coevaluation_tensor (X Y: C):
  η_ (X ⊗ Y) (X ⊗ Y)ᘁ = η_ (X ⊗ Y) (Yᘁ ⊗ Xᘁ) ≫ (𝟙 _ ⊗ (δ_ _ _).inv) :=
begin
  simp only [tensor_iso_dual_tensor_dual, id_tensor_comp],
  rw id_tensor_right_unitor_inv,
  slice_rhs 1 2 { rw right_unitor_inv_naturality, },
  slice_rhs 3 4 { rw ←associator_naturality, },
  slice_rhs 2 3 { simp only [tensor_id], rw [eq.trans (tensor_id_comp_id_tensor _ _) (id_tensor_comp_tensor_id _ _).symm], },
  slice_rhs 1 2 { rw [←unitors_inv_equal, ←left_unitor_inv_naturality], },
  slice_rhs 3 3 { rw [←tensor_id, associator_inv_conjugation], },
  slice_rhs 5 8 { rw [pentagon_hom_inv_assoc, iso.hom_inv_id_assoc, ←associator_naturality], },
  slice_rhs 4 6 { simp only [←comp_tensor_id], rw exact_pairing.evaluation_coevaluation, },
  conv_lhs { rw ←category.comp_id (η_ _ _) }, rw congr_comp_left,
  coherence,
end

lemma evaluation_tensor (X Y: C):
  ε_ (X ⊗ Y) (X ⊗ Y)ᘁ = ((δ_ _ _).hom ⊗ 𝟙 _) ≫ ε_ _ _ :=
begin
  simp only [tensor_iso_dual_tensor_dual, comp_tensor_id],
  rw ←left_unitor_tensor',
  slice_rhs 6 7 { rw ←left_unitor_naturality, },
  slice_rhs 4 5 { rw associator_naturality, },
  slice_rhs 5 6 { simp only [tensor_id], rw [eq.trans (tensor_id_comp_id_tensor _ _) (id_tensor_comp_tensor_id _ _).symm], },
  slice_rhs 6 7 { rw [unitors_equal, right_unitor_naturality], },
  slice_rhs 5 5 { rw [←tensor_id, associator_conjugation], },
  slice_rhs 3 5 { rw [←pentagon, ←comp_tensor_id_assoc (α_ (X ⊗ Y)ᘁ (X ⊗ Y) (Yᘁ ⊗ Xᘁ)).inv, iso.inv_hom_id], },
  slice_rhs 2 5 { simp only [←tensor_id, associator_naturality_assoc], simp only [tensor_id], rw category.id_comp, },
  slice_rhs 3 5 { simp only [←id_tensor_comp], rw exact_pairing.evaluation_coevaluation, },
  conv_lhs { rw ←category.id_comp (ε_ _ _) }, simp_rw ←category.assoc, rw congr_comp_right,
  coherence,
end

lemma coevaluation_dual_tensor (X Y: C):
  η_ (X ⊗ Y)ᘁ (X ⊗ Y)ᘁᘁ = η_ (Yᘁ ⊗ Xᘁ) (Yᘁ ⊗ Xᘁ)ᘁ ≫ ((δ_ X Y).inv ⊗ ((δ_ X Y).hom)ᘁ) :=
begin
  rw ←tensor_id_comp_id_tensor,
  slice_rhs 1 2 { rw ←coevaluation_comp_right_adjoint_mate, },
  slice_rhs 1 3 { rw [←id_tensor_comp, iso.inv_dual_hom_dual_id, tensor_id, category.comp_id], },
end

lemma evaluation_dual_tensor (X Y: C):
  ε_ (X ⊗ Y)ᘁ (X ⊗ Y)ᘁᘁ = (((δ_ X Y).inv)ᘁ ⊗ (δ_ X Y).hom) ≫ ε_ (Yᘁ ⊗ Xᘁ) (Yᘁ ⊗ Xᘁ)ᘁ :=
begin
  rw ←tensor_id_comp_id_tensor,
  slice_rhs 2 3 { rw ←right_adjoint_mate_comp_evaluation, },
  slice_rhs 1 3 { rw [←comp_tensor_id_assoc, iso.inv_dual_hom_dual_id, tensor_id, category.id_comp], },
end

def coevaluation' := η_ V Vᘁ
def evaluation' := ε_ V Vᘁ

notation η_⁺ := coevaluation'
notation ε_⁺ := evaluation'

variable [right_pivotal_category.{v} C]
open right_pivotal_category

def coevaluation_rev := η_⁺ Vᘁ ≫ (𝟙 Vᘁ ⊗ (φ_ _).inv)
def evaluation_rev := ((φ_ _).hom ⊗ 𝟙 Vᘁ) ≫ ε_⁺ Vᘁ

notation η_⁻ := coevaluation_rev
notation ε_⁻ := evaluation_rev

lemma id_comp_comp_id {V₁ V₂: C} (f: V₁ ⟶ V₂): 𝟙 _ ≫ f = f ≫ 𝟙 _ := by simp

@[reassoc] lemma coevaluation_evaluation:
  (𝟙 Vᘁ ⊗ η_⁺ _) ≫ (α_ _ _ _).inv ≫ (ε_⁺ _ ⊗ 𝟙 Vᘁ) = (ρ_ _).hom ≫ (λ_ _).inv := by simp [coevaluation', evaluation', coevaluation_rev, evaluation_rev]

@[reassoc] lemma coevaluation_evaluation_rev:
  (𝟙 V ⊗ η_⁻ _) ≫ (α_ _ _ _).inv ≫ (ε_⁻ _ ⊗ 𝟙 V) = (ρ_ _).hom ≫ (λ_ _).inv := begin
  simp [coevaluation', evaluation', coevaluation_rev, evaluation_rev],
  slice_lhs 1 2 { rw [←tensor_comp, id_comp_comp_id, tensor_comp], },
  slice_lhs 1 1 { rw [←category.comp_id (φ_ V).hom, ←category.id_comp (η_ _ _), tensor_comp], },
  slice_lhs 3 4 { rw associator_inv_naturality, },
  slice_lhs 4 5 { rw [←tensor_comp, ←id_comp_comp_id, tensor_comp], },
  slice_lhs 5 6 { rw [←category.comp_id (ε_ _ _), ←category.id_comp (φ_ V).inv, tensor_comp], },
  simp,
end

@[reassoc] lemma evaluation_coevaluation:
  (η_⁺ _ ⊗ 𝟙 V) ≫ (α_ _ _ _).hom ≫ (𝟙 V ⊗ ε_⁺ _) = (λ_ _).hom ≫ (ρ_ _).inv := by simp [coevaluation', evaluation', coevaluation_rev, evaluation_rev]

@[reassoc] lemma evaluation_coevaluation_rev:
  (η_⁻ _ ⊗ 𝟙 Vᘁ) ≫ (α_ _ _ _).hom ≫ (𝟙 Vᘁ ⊗ ε_⁻ _) = (λ_ _).hom ≫ (ρ_ _).inv := begin
  simp [coevaluation', evaluation', coevaluation_rev, evaluation_rev],
  slice_lhs 3 4 { rw [←tensor_comp, ←tensor_comp, (φ_ _).inv_hom_id, category.comp_id, tensor_id, tensor_id], },
  simp,
end

@[reassoc] lemma coevaluation_hom_tensor (X Y: C):
  η_⁺ (X ⊗ Y) = η_⁺ X ≫ (𝟙 _ ⊗ (λ_ _).inv) ≫ (𝟙 _ ⊗ η_⁺ Y ⊗ 𝟙 _)  ≫ (𝟙 _ ⊗ (α_ _ _ _).hom) ≫ (α_ _ _ _).inv ≫ (𝟙 _ ⊗ (δ_ _ _).inv) :=
begin
  simp only [coevaluation', coevaluation_tensor], unfold_projs,
  slice_lhs 2 2 { rw ←triangle_assoc_comp_left_inv, },
  slice_lhs 3 4 { rw [associator_conjugation, iso.inv_hom_id_assoc], },
  slice_lhs 4 6 { rw pentagon_inv_inv_hom, },
  simp_rw category.assoc,
end

@[reassoc] lemma evaluation_hom_tensor (X Y: C):
  ε_⁺ (X ⊗ Y) = ((δ_ _ _).hom ⊗ 𝟙 _) ≫ (α_ _ _ _).hom ≫ (𝟙 _ ⊗ (α_ _ _ _).inv) ≫ (𝟙 _ ⊗ ε_⁺ X ⊗ 𝟙 _) ≫ (𝟙 _ ⊗ (λ_ _).hom) ≫ ε_⁺ Y :=
begin
  simp only [evaluation', evaluation_tensor], unfold_projs,
  slice_lhs 4 4 { rw associator_conjugation, },
  slice_lhs 6 7 { rw triangle_assoc_comp_right, },
  slice_lhs 2 4 { rw ←pentagon_hom_inv, },
  simp_rw category.assoc,
end

@[reassoc] lemma coevaluation_rev_tensor (X Y: C):
  η_⁻ (X ⊗ Y) = η_⁻ Y ≫ (𝟙 _ ⊗ (λ_ _).inv) ≫ (𝟙 _ ⊗ η_⁻ X ⊗ 𝟙 _)  ≫ (𝟙 _ ⊗ (α_ _ _ _).hom) ≫ (α_ _ _ _).inv ≫ ((δ_ _ _).inv ⊗ 𝟙 _) :=
begin
  simp only [coevaluation_rev, id_tensor_comp, comp_tensor_id],
  conv_lhs {
    rw [coevaluation', coevaluation_dual_tensor, ←coevaluation'],
    rw [category.assoc, ←tensor_comp, category.comp_id, coevaluation_hom_tensor],
  },
  slice_rhs 2 3 { rw [←tensor_comp, left_unitor_inv_naturality, tensor_comp], },
  slice_rhs 3 4 { rw [←tensor_comp, eq.trans (id_tensor_comp_tensor_id _ _) (tensor_id_comp_id_tensor _ _).symm, tensor_comp], },
  slice_rhs 4 5 { simp only [←tensor_comp, category.id_comp, category.comp_id], },
  slice_rhs 4 5 { rw [←tensor_comp, associator_naturality, tensor_comp], },
  slice_rhs 5 6 { rw associator_inv_naturality, },
  simp_rw category.assoc, iterate 5 { rw congr_comp_left, },
  simp_rw [←tensor_comp, tensor_id, category.comp_id], rw congr_tensor_left,
  rw [right_pivotor_inv_tensor_naturality, iso.hom_dual_inv_dual_id_assoc, iso.inv_hom_id_assoc],
end

@[reassoc] lemma evaluation_rev_tensor (X Y: C):
  ε_⁻ (X ⊗ Y) = (𝟙 _ ⊗ (δ_ _ _).hom) ≫ (α_ _ _ _).hom ≫ (𝟙 _ ⊗ (α_ _ _ _).inv) ≫ (𝟙 _ ⊗ ε_⁻ Y ⊗ 𝟙 _) ≫ (𝟙 _ ⊗ (λ_ _).hom) ≫ ε_⁻ X :=
begin
  simp only [evaluation_rev, id_tensor_comp, comp_tensor_id],
  conv_lhs {
    rw [evaluation', evaluation_dual_tensor, ←evaluation'],
    rw [←tensor_comp_assoc, category.id_comp, evaluation_hom_tensor],
  },
  slice_rhs 3 7 {
    simp only [←tensor_comp, category.id_comp],
    rw [category.comp_id, ←category.comp_id ((φ_ X).hom), tensor_comp],
    simp only [id_tensor_comp],
  },
  slice_rhs 3 4 { rw [←tensor_comp, ←associator_inv_naturality, tensor_comp], },
  slice_rhs 2 3 { rw ←associator_naturality, },
  simp_rw ←category.assoc, iterate 5 { rw congr_comp_right, },
  simp_rw [←tensor_comp, tensor_id, category.id_comp], rw congr_tensor_right,
  rw [right_pivotor_tensor_naturality],
  slice_lhs 3 5 { rw iso.hom_dual_inv_dual_id_assoc, },
  rw [iso.inv_hom_id, category.comp_id],
end

end

section

open right_pivotal_category

variables
  {C: Type u}
  [category.{v} C]
  [monoidal_category.{v} C]
  [right_rigid_category.{v} C]
  [right_pivotal_category C]

lemma right_adjoint_mate_inv {X Y: C} (f: X ⟶ Y):
  (λ_ _).inv ≫ (η_⁺ _ ⊗ 𝟙 _) ≫ ((𝟙 _ ⊗ fᘁ) ⊗ 𝟙 _) ≫ (α_ _ _ _).hom ≫ (𝟙 _ ⊗ ε_⁺ _) ≫ (ρ_ _).hom = f :=
begin
  simp [coevaluation', evaluation'],
  simp [right_adjoint_mate],
  slice_lhs 8 10 { rw [←id_tensor_comp, ←id_tensor_comp, pentagon_inv, id_tensor_comp], }, simp,
  slice_lhs 11 12 { rw [associator_inv_conjugation, ←triangle_assoc_comp_right, comp_tensor_id], simp, },
  slice_lhs 10 12 { rw pentagon_inv, }, simp,
  slice_lhs 9 10 { rw associator_inv_naturality, },
  slice_lhs 10 11 { rw [←tensor_comp, id_comp_comp_id, tensor_comp], },
  slice_lhs 9 10 { rw [←associator_inv_naturality, ←id_tensor_comp_tensor_id (ε_ _ _) (ε_ _ _), id_tensor_comp], },
  slice_lhs 8 9 { rw [←id_tensor_comp, ←tensor_id, ←associator_inv_naturality, id_tensor_comp], },
  slice_lhs 7 8 { rw [←tensor_comp, ←tensor_comp, tensor_id_comp_id_tensor, ←id_tensor_comp_tensor_id _ f, tensor_comp, tensor_comp], },
  slice_lhs 6 7 { rw [←id_tensor_comp, ←id_tensor_comp], },
  slice_lhs 5 6 { rw [←id_tensor_comp, ←id_tensor_comp, exact_pairing.evaluation_coevaluation], }, simp,
  slice_lhs 4 5 { rw [←id_tensor_comp, ←id_tensor_comp, (λ_ _).inv_hom_id], },
  slice_lhs 5 6 { rw [←id_tensor_comp, ←id_tensor_comp, (ρ_ _).inv_hom_id], },
  slice_lhs 7 8 { rw [←id_tensor_comp, ←id_tensor_comp, (ρ_ _).inv_hom_id], }, simp,
  slice_lhs 3 4 { rw ←associator_naturality, },
  slice_lhs 2 3 { rw [tensor_id, tensor_id_comp_id_tensor, ←id_tensor_comp_tensor_id], },
  slice_lhs 3 5 { rw exact_pairing.evaluation_coevaluation, }, simp,
end

@[reassoc] lemma right_adjoint_mate_hom {X Y: C} (f: X ⟶ Y):
  (ρ_ _).inv ≫ (𝟙 _ ⊗ η_⁺ _) ≫ (𝟙 _ ⊗ (f ⊗ 𝟙 _)) ≫ (α_ _ _ _).inv ≫ ((ε_⁺ _) ⊗ 𝟙 _) ≫ (λ_ _).hom = fᘁ :=
by rw [coevaluation', evaluation', right_adjoint_mate]

@[reassoc] lemma right_adjoint_mate_rev {X Y: C} (f: X ⟶ Y):
  (λ_ _).inv ≫ (η_⁻ _ ⊗ 𝟙 _) ≫ ((𝟙 _ ⊗ f) ⊗ 𝟙 _) ≫ (α_ _ _ _).hom ≫ (𝟙 _ ⊗ ε_⁻ _) ≫ (ρ_ _).hom = fᘁ :=
begin
  simp only [coevaluation_rev, evaluation_rev, comp_tensor_id, id_tensor_comp, category.assoc],
  rw ←associator_naturality_assoc,
  slice_lhs 3 5 {
    simp only [←tensor_comp, category.comp_id],
    rw [right_pivotor_naturality, iso.inv_hom_id_assoc],
  },
  simp only [category.assoc],
  rw right_adjoint_mate_inv,
end

end

end kassel


/-
Copyright (c) 2019 Patrick Massot. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Patrick Massot
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.topology.uniform_space.uniform_embedding
import Mathlib.PostPort

universes u l u_1 u_2 u_3 u_4

namespace Mathlib

/-!
# Abstract theory of Hausdorff completions of uniform spaces

This file characterizes Hausdorff completions of a uniform space α as complete Hausdorff spaces
equipped with a map from α which has dense image and induce the original uniform structure on α.
Assuming these properties we "extend" uniformly continuous maps from α to complete Hausdorff spaces
to the completions of α. This is the universal property expected from a completion.
It is then used to extend uniformly continuous maps from α to α' to maps between
completions of α and α'.

This file does not construct any such completion, it only study consequences of their existence.
The first advantage is that formal properties are clearly highlighted without interference from
construction details. The second advantage is that this framework can then be used to compare
different completion constructions. See `topology/uniform_space/compare_reals` for an example.
Of course the comparison comes from the universal property as usual.

A general explicit construction of completions is done in `uniform_space/completion`, leading
to a functor from uniform spaces to complete Hausdorff uniform spaces that is left adjoint to the
inclusion, see `uniform_space/UniformSpace` for the category packaging.

## Implementation notes

A tiny technical advantage of using a characteristic predicate such as the properties listed in
`abstract_completion` instead of stating the universal property is that the universal property
derived from the predicate is more universe polymorphic.

## References

We don't know any traditional text discussing this. Real world mathematics simply silently
identify the results of any two constructions that lead to something one could reasonnably
call a completion.

## Tags

uniform spaces, completion, universal property
-/

/-- A completion of `α` is the data of a complete separated uniform space (from the same universe)
and a map from `α` with dense range and inducing the original uniform structure on `α`. -/
structure abstract_completion (α : Type u) [uniform_space α]
where
  space : Type u
  coe : α → space
  uniform_struct : uniform_space space
  complete : complete_space space
  separation : separated_space space
  uniform_inducing : uniform_inducing coe
  dense : dense_range coe

namespace abstract_completion

theorem closure_range {α : Type u_1} [uniform_space α] (pkg : abstract_completion α) : closure (set.range (coe pkg)) = set.univ :=
  dense_range.closure_range (dense pkg)

theorem dense_inducing {α : Type u_1} [uniform_space α] (pkg : abstract_completion α) : dense_inducing (coe pkg) :=
  dense_inducing.mk (uniform_inducing.inducing (uniform_inducing pkg)) (dense pkg)

theorem uniform_continuous_coe {α : Type u_1} [uniform_space α] (pkg : abstract_completion α) : uniform_continuous (coe pkg) :=
  uniform_inducing.uniform_continuous (uniform_inducing pkg)

theorem continuous_coe {α : Type u_1} [uniform_space α] (pkg : abstract_completion α) : continuous (coe pkg) :=
  uniform_continuous.continuous (uniform_continuous_coe pkg)

theorem induction_on {α : Type u_1} [uniform_space α] (pkg : abstract_completion α) {p : space pkg → Prop} (a : space pkg) (hp : is_closed (set_of fun (a : space pkg) => p a)) (ih : ∀ (a : α), p (coe pkg a)) : p a :=
  is_closed_property (dense pkg) hp ih a

protected theorem funext {α : Type u_1} [uniform_space α] (pkg : abstract_completion α) {β : Type u_2} [uniform_space β] [t2_space β] {f : space pkg → β} {g : space pkg → β} (hf : continuous f) (hg : continuous g) (h : ∀ (a : α), f (coe pkg a) = g (coe pkg a)) : f = g :=
  funext fun (a : space pkg) => induction_on pkg a (is_closed_eq hf hg) h

/-- Extension of maps to completions -/
protected def extend {α : Type u_1} [uniform_space α] (pkg : abstract_completion α) {β : Type u_2} [uniform_space β] (f : α → β) : space pkg → β :=
  ite (uniform_continuous f) (dense_inducing.extend (dense_inducing pkg) f)
    fun (x : space pkg) => f (dense_range.some (dense pkg) x)

theorem extend_def {α : Type u_1} [uniform_space α] (pkg : abstract_completion α) {β : Type u_2} [uniform_space β] {f : α → β} (hf : uniform_continuous f) : abstract_completion.extend pkg f = dense_inducing.extend (dense_inducing pkg) f :=
  if_pos hf

theorem extend_coe {α : Type u_1} [uniform_space α] (pkg : abstract_completion α) {β : Type u_2} [uniform_space β] {f : α → β} [t2_space β] (hf : uniform_continuous f) (a : α) : abstract_completion.extend pkg f (coe pkg a) = f a :=
  eq.mpr (id (Eq._oldrec (Eq.refl (abstract_completion.extend pkg f (coe pkg a) = f a)) (extend_def pkg hf)))
    (dense_inducing.extend_eq (dense_inducing pkg) (uniform_continuous.continuous hf) a)

theorem uniform_continuous_extend {α : Type u_1} [uniform_space α] (pkg : abstract_completion α) {β : Type u_2} [uniform_space β] {f : α → β} [complete_space β] [separated_space β] : uniform_continuous (abstract_completion.extend pkg f) := sorry

theorem continuous_extend {α : Type u_1} [uniform_space α] (pkg : abstract_completion α) {β : Type u_2} [uniform_space β] {f : α → β} [complete_space β] [separated_space β] : continuous (abstract_completion.extend pkg f) :=
  uniform_continuous.continuous (uniform_continuous_extend pkg)

theorem extend_unique {α : Type u_1} [uniform_space α] (pkg : abstract_completion α) {β : Type u_2} [uniform_space β] {f : α → β} [complete_space β] [separated_space β] (hf : uniform_continuous f) {g : space pkg → β} (hg : uniform_continuous g) (h : ∀ (a : α), f a = g (coe pkg a)) : abstract_completion.extend pkg f = g := sorry

@[simp] theorem extend_comp_coe {α : Type u_1} [uniform_space α] (pkg : abstract_completion α) {β : Type u_2} [uniform_space β] [complete_space β] [separated_space β] {f : space pkg → β} (hf : uniform_continuous f) : abstract_completion.extend pkg (f ∘ coe pkg) = f := sorry

/-- Lifting maps to completions -/
protected def map {α : Type u_1} [uniform_space α] (pkg : abstract_completion α) {β : Type u_2} [uniform_space β] (pkg' : abstract_completion β) (f : α → β) : space pkg → space pkg' :=
  abstract_completion.extend pkg (coe pkg' ∘ f)

theorem uniform_continuous_map {α : Type u_1} [uniform_space α] (pkg : abstract_completion α) {β : Type u_2} [uniform_space β] (pkg' : abstract_completion β) (f : α → β) : uniform_continuous (abstract_completion.map pkg pkg' f) :=
  uniform_continuous_extend pkg

theorem continuous_map {α : Type u_1} [uniform_space α] (pkg : abstract_completion α) {β : Type u_2} [uniform_space β] (pkg' : abstract_completion β) (f : α → β) : continuous (abstract_completion.map pkg pkg' f) :=
  continuous_extend pkg

@[simp] theorem map_coe {α : Type u_1} [uniform_space α] (pkg : abstract_completion α) {β : Type u_2} [uniform_space β] (pkg' : abstract_completion β) {f : α → β} (hf : uniform_continuous f) (a : α) : abstract_completion.map pkg pkg' f (coe pkg a) = coe pkg' (f a) :=
  extend_coe pkg (uniform_continuous.comp (uniform_continuous_coe pkg') hf) a

theorem map_unique {α : Type u_1} [uniform_space α] (pkg : abstract_completion α) {β : Type u_2} [uniform_space β] (pkg' : abstract_completion β) {f : α → β} {g : space pkg → space pkg'} (hg : uniform_continuous g) (h : ∀ (a : α), coe pkg' (f a) = g (coe pkg a)) : abstract_completion.map pkg pkg' f = g := sorry

@[simp] theorem map_id {α : Type u_1} [uniform_space α] (pkg : abstract_completion α) : abstract_completion.map pkg pkg id = id :=
  map_unique pkg pkg uniform_continuous_id fun (a : α) => rfl

theorem extend_map {α : Type u_1} [uniform_space α] (pkg : abstract_completion α) {β : Type u_2} [uniform_space β] (pkg' : abstract_completion β) {γ : Type u_3} [uniform_space γ] [complete_space γ] [separated_space γ] {f : β → γ} {g : α → β} (hf : uniform_continuous f) (hg : uniform_continuous g) : abstract_completion.extend pkg' f ∘ abstract_completion.map pkg pkg' g = abstract_completion.extend pkg (f ∘ g) := sorry

theorem map_comp {α : Type u_1} [uniform_space α] (pkg : abstract_completion α) {β : Type u_2} [uniform_space β] (pkg' : abstract_completion β) {γ : Type u_3} [uniform_space γ] (pkg'' : abstract_completion γ) {g : β → γ} {f : α → β} (hg : uniform_continuous g) (hf : uniform_continuous f) : abstract_completion.map pkg' pkg'' g ∘ abstract_completion.map pkg pkg' f = abstract_completion.map pkg pkg'' (g ∘ f) :=
  extend_map pkg pkg' (uniform_continuous.comp (uniform_continuous_coe pkg'') hg) hf

-- We can now compare two completion packages for the same uniform space

/-- The comparison map between two completions of the same uniform space. -/
def compare {α : Type u_1} [uniform_space α] (pkg : abstract_completion α) (pkg' : abstract_completion α) : space pkg → space pkg' :=
  abstract_completion.extend pkg (coe pkg')

theorem uniform_continuous_compare {α : Type u_1} [uniform_space α] (pkg : abstract_completion α) (pkg' : abstract_completion α) : uniform_continuous (compare pkg pkg') :=
  uniform_continuous_extend pkg

theorem compare_coe {α : Type u_1} [uniform_space α] (pkg : abstract_completion α) (pkg' : abstract_completion α) (a : α) : compare pkg pkg' (coe pkg a) = coe pkg' a :=
  extend_coe pkg (uniform_continuous_coe pkg') a

theorem inverse_compare {α : Type u_1} [uniform_space α] (pkg : abstract_completion α) (pkg' : abstract_completion α) : compare pkg pkg' ∘ compare pkg' pkg = id := sorry

/-- The bijection between two completions of the same uniform space. -/
def compare_equiv {α : Type u_1} [uniform_space α] (pkg : abstract_completion α) (pkg' : abstract_completion α) : space pkg ≃ space pkg' :=
  equiv.mk (compare pkg pkg') (compare pkg' pkg) sorry sorry

theorem uniform_continuous_compare_equiv {α : Type u_1} [uniform_space α] (pkg : abstract_completion α) (pkg' : abstract_completion α) : uniform_continuous ⇑(compare_equiv pkg pkg') :=
  uniform_continuous_compare pkg pkg'

theorem uniform_continuous_compare_equiv_symm {α : Type u_1} [uniform_space α] (pkg : abstract_completion α) (pkg' : abstract_completion α) : uniform_continuous ⇑(equiv.symm (compare_equiv pkg pkg')) :=
  uniform_continuous_compare pkg' pkg

/-- Products of completions -/
protected def prod {α : Type u_1} [uniform_space α] (pkg : abstract_completion α) {β : Type u_2} [uniform_space β] (pkg' : abstract_completion β) : abstract_completion (α × β) :=
  mk (space pkg × space pkg') (fun (p : α × β) => (coe pkg (prod.fst p), coe pkg' (prod.snd p))) prod.uniform_space sorry
    sorry sorry sorry

/-- Extend two variable map to completions. -/
protected def extend₂ {α : Type u_1} [uniform_space α] (pkg : abstract_completion α) {β : Type u_2} [uniform_space β] (pkg' : abstract_completion β) {γ : Type u_3} [uniform_space γ] (f : α → β → γ) : space pkg → space pkg' → γ :=
  function.curry (abstract_completion.extend (abstract_completion.prod pkg pkg') (function.uncurry f))

theorem extension₂_coe_coe {α : Type u_1} [uniform_space α] (pkg : abstract_completion α) {β : Type u_2} [uniform_space β] (pkg' : abstract_completion β) {γ : Type u_3} [uniform_space γ] [separated_space γ] {f : α → β → γ} (hf : uniform_continuous (function.uncurry f)) (a : α) (b : β) : abstract_completion.extend₂ pkg pkg' f (coe pkg a) (coe pkg' b) = f a b := sorry

theorem uniform_continuous_extension₂ {α : Type u_1} [uniform_space α] (pkg : abstract_completion α) {β : Type u_2} [uniform_space β] (pkg' : abstract_completion β) {γ : Type u_3} [uniform_space γ] [separated_space γ] (f : α → β → γ) [complete_space γ] : uniform_continuous₂ (abstract_completion.extend₂ pkg pkg' f) := sorry

/-- Lift two variable maps to completions. -/
protected def map₂ {α : Type u_1} [uniform_space α] (pkg : abstract_completion α) {β : Type u_2} [uniform_space β] (pkg' : abstract_completion β) {γ : Type u_3} [uniform_space γ] (pkg'' : abstract_completion γ) (f : α → β → γ) : space pkg → space pkg' → space pkg'' :=
  abstract_completion.extend₂ pkg pkg' (function.bicompr (coe pkg'') f)

theorem uniform_continuous_map₂ {α : Type u_1} [uniform_space α] (pkg : abstract_completion α) {β : Type u_2} [uniform_space β] (pkg' : abstract_completion β) {γ : Type u_3} [uniform_space γ] (pkg'' : abstract_completion γ) (f : α → β → γ) : uniform_continuous₂ (abstract_completion.map₂ pkg pkg' pkg'' f) :=
  uniform_continuous_extension₂ pkg pkg' (function.bicompr (coe pkg'') f)

theorem continuous_map₂ {α : Type u_1} [uniform_space α] (pkg : abstract_completion α) {β : Type u_2} [uniform_space β] (pkg' : abstract_completion β) {γ : Type u_3} [uniform_space γ] (pkg'' : abstract_completion γ) {δ : Type u_4} [topological_space δ] {f : α → β → γ} {a : δ → space pkg} {b : δ → space pkg'} (ha : continuous a) (hb : continuous b) : continuous fun (d : δ) => abstract_completion.map₂ pkg pkg' pkg'' f (a d) (b d) :=
  continuous.comp (uniform_continuous.continuous (uniform_continuous_map₂ pkg pkg' pkg'' f)) (continuous.prod_mk ha hb)

theorem map₂_coe_coe {α : Type u_1} [uniform_space α] (pkg : abstract_completion α) {β : Type u_2} [uniform_space β] (pkg' : abstract_completion β) {γ : Type u_3} [uniform_space γ] (pkg'' : abstract_completion γ) (a : α) (b : β) (f : α → β → γ) (hf : uniform_continuous₂ f) : abstract_completion.map₂ pkg pkg' pkg'' f (coe pkg a) (coe pkg' b) = coe pkg'' (f a b) :=
  extension₂_coe_coe pkg pkg' (uniform_continuous.comp (uniform_continuous_coe pkg'') hf) a b