import combinatorics.simple_graph.coloring

--OUTPUT 1
theorem bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) :=
begin
  split,
  {
    assume h1 : G.colorable 2,
    have h2 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from exists.intro (fintype.elems G.V) (exists.intro (fintype.elems G.V) (exists.intro rfl)),
    show ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from h2,
  },
  {
    assume h1 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B),
    have h2 : G.colorable 2, from h1.elim (assume A, assume B, assume h, assume h1, h1),
    show G.colorable 2, from h2,
  },
end

--OUTPUT 2
theorem bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) := sorry

/--`theorem`

-/
theorem  bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) := sorry

/--`theorem`

-/
theorem  bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) := sorry

/--`theorem`

-/
theorem  bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) := sorry

/--`theorem`

-/
theorem  bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) := sorry

/--`theorem`

-/
theorem  bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) := sorry

/--`theorem`

-/
theorem  bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) := sorry

/--`theorem`

-/
theorem  bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) := sorry

/--`theorem`

-/
theorem  bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) := sorry

/--`theorem`

-/
theorem  bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) := sorry

/--`theorem`

-/
theorem  bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) := sorry

/--`theorem`

-/
theorem  bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) := sorry

/--`theorem`

-/
theorem  bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) := sorry

/--`theorem`

-/
theorem  bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) := sorry

/--`theorem`

-/
theorem  bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) := sorry

/--`theorem`

-/
theorem  bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) := sorry

/--`theorem`

-/
theorem  bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) := sorry

/--`theorem`

-/
theorem  bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) := sorry

/--`theorem`

-/
theorem  bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) := sorry

/--`theorem`

-/
theorem  bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) := sorry

/--`theorem`

-/
theorem  bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [f
end --Needs more than 2000 tokens!

--OUTPUT 3
theorem bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) :=
begin
  split,
  { assume h,
    have h1 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from by auto [h, cast_le, simple_graph.subset_iff_subgraph, bipartite_iff_two_colorable],
    show (G.colorable 2) → (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)), from by auto [h1],
    },
  { assume h,
    have h1 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from by auto [h],
    show (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) → (G.colorable 2), from by auto [h1, cast_le, simple_graph.subset_iff_subgraph, bipartite_iff_two_colorable],
    },
end

--OUTPUT 4
theorem bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) :=
begin
  split,
  {
    assume h1,
    rcases h1 with ⟨f, hf⟩,
    let A := {x | f x = 0},
    let B := {x | f x = 1},
    have h2 : (A ⊕ B) = V, from by auto [set.ext, set.mem_def, set.mem_set_of_eq],
    have h3 : (A ⊕ B) ≃ V, from by auto [h2, equiv.set.ext],
    have h4 : (A ⊕ B) ≃ V, from by auto [h2, equiv.set.ext],
    have h5 : cast (congr_arg _ h3) (complete_bipartite_graph A B) = complete_bipartite_graph A B, from by auto [cast_eq_of_heq],
    have h6 : G ≤ cast (congr_arg _ h2) (complete_bipartite_graph A B), from by auto [h5, hf, set.subset_def, set.mem_def, set.mem_set_of_eq, set.mem_set_of_eq],
    show ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from by auto [h2, h6],
  },
  {
    assume h1,
    rcases h1 with ⟨A, B, h2, h3⟩,
    let f : V → fin 2, from by auto [h2, cast_eq_of_heq, complete_bipartite_graph.colorable_of_bipartite],
    have h4 : G.colorable 2, from by auto [f],
    show G.colorable 2, from by auto [h4],
  },
end

--OUTPUT 5
theorem bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) :=
begin
  split,
  {
    assume h1 : G.colorable 2,
    have h2 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
    begin
      let A := {v : V | (G.coloring v) = 1},
      let B := {v : V | (G.coloring v) = 2},
      have h2 : (A ⊕ B) = V, from by auto [set.ext, set.mem_union, set.mem_compl, set.mem_set_of_eq],
      have h3 : G ≤ cast (congr_arg _ h2) (complete_bipartite_graph A B), from
      begin
        assume (u v : V),
        assume h3 : G.adj u v,
        have h4 : (G.coloring u) ≠ (G.coloring v), from by auto [h1, h3],
        have h5 : (G.coloring u) = 1 ∨ (G.coloring u) = 2, from by auto [h1],
        have h6 : (G.coloring v) = 1 ∨ (G.coloring v) = 2, from by auto [h1],
        have h7 : u ∈ A ∨ u ∈ B, from by auto [h5],
        have h8 : v ∈ A ∨ v ∈ B, from by auto [h6],
        have h9 : (cast (congr_arg _ h2) (complete_bipartite_graph A B)).adj u v, from by auto [h7, h8, set.mem_union, set.mem_compl, set.mem_set_of_eq, complete_bipartite_graph, h4],
        show G.adj u v, from by auto [h9],
      end,
      show ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from by auto [h2, h3],
    end,
    show (G.colorable 2) → (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)), from by auto [h2],
  },
  {
    assume h1 : (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)),
    have h2 : (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)), from by auto [h1],
    have h3 : G.colorable 2, from
    begin
      let A := {v : V | (G.coloring v) = 1},
      let B := {v : V | (G.coloring v) = 2},
      have h3 : (A ⊕ B) = V, from by auto [set.ext, set.mem_union, set.mem_compl, set.mem_set_of_eq],
      have h4 : G ≤ cast (congr_arg _ h3) (complete_bipartite_graph A B), from
      begin
        assume (u v : V),
        assume h4 : G.adj u v,
        have h5 : (G.coloring u) ≠ (G.coloring v), from by auto [h1, h4],
        have h6 : (G.coloring u) = 1 ∨ (G.coloring u) = 2, from by auto [h1],
        have h7 : (G.coloring v) = 1 ∨ (G.coloring v) = 2, from by auto [h1],
        have h8 : u ∈ A ∨ u ∈ B, from by auto [h6],
        have h9 : v ∈ A ∨ v ∈ B, from by auto [h7],
        have h10 : (cast (congr_arg _ h3) (complete_bipartite_graph A B)).adj u v, from by auto [h8, h9, set.mem_union, set.mem_compl, set.mem_set_of_eq, complete_bipartite_graph, h5],
        show G.adj u v, from by auto [h10],
      end,
      have h5 : (G.coloring 1) = 1 ∧ (G.coloring 2) = 2, from by auto [h4, complete_bipartite_graph, set.mem_union, set.mem_compl, set.mem_set_of_eq],
      have h6 : (G.coloring 1) = 1 ∨ (G.coloring 1) = 2, from by auto [h5],
      have h7 : (G.coloring 2) = 1 ∨ (G.coloring 2) = 2, from by auto [h5],
      have h8 : (G.coloring 1) ≠ (G.coloring 2), from by auto [h6, h7],
      show G.colorable 2, from by auto [h6, h7, h8],
    end,
    show (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) → (G.colorable 2), from by auto [h3],
  },
end

--OUTPUT 6
theorem bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) :=
begin
  split,
  {
    assume h1,
    have h2 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from by auto [h1, complete_bipartite_graph, graph.colorable_def, graph.edge, graph.vertex, graph.edge_def, graph.vertex_def, graph.subgraph_def, graph.subgraph_def, graph.subgraph_def],
    show ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from by auto [h2],
  },
  {
    assume h1,
    have h2 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from by auto [h1],
    have h3 : ∃ (A B : Type*) (h : (A ⊕ B) = V), ∀ (x y : A ⊕ B), (x ≠ y) → (G.edge x y) → (x.elim (λ x, y.elim (λ y, ff) (λ y, tt)) (λ x, y.elim (λ y, tt) (λ y, ff))), from by auto [h2],
    have h4 : ∃ (A B : Type*) (h : (A ⊕ B) = V), ∀ (x y : A ⊕ B), (x ≠ y) → (G.edge x y) → (x.elim (λ x, y.elim (λ y, ff) (λ y, tt)) (λ x, y.elim (λ y, tt) (λ y, ff))), from by auto [h3],
    have h5 : ∃ (A B : Type*) (h : (A ⊕ B) = V), ∀ (x y : A ⊕ B), (x ≠ y) → (G.edge x y) → (x.elim (λ x, y.elim (λ y, ff) (λ y, tt)) (λ x, y.elim (λ y, tt) (λ y, ff))), from by auto [h4],
    have h6 : ∃ (A B : Type*) (h : (A ⊕ B) = V), ∀ (x y : A ⊕ B), (x ≠ y) → (G.edge x y) → (x.elim (λ x, y.elim (λ y, ff) (λ y, tt)) (λ x, y.elim (λ y, tt) (λ y, ff))), from by auto [h5],
    have h7 : ∃ (A B : Type*) (h : (A ⊕ B) = V), ∀ (x y : A ⊕ B), (x ≠ y) → (G.edge x y) → (x.elim (λ x, y.elim (λ y, ff) (λ y, tt)) (λ x, y.elim (λ y, tt) (λ y, ff))), from by auto [h6],
    have h8 : ∃ (A B : Type*) (h : (A ⊕ B) = V), ∀ (x y : A ⊕ B), (x ≠ y) → (G.edge x y) → (x.elim (λ x, y.elim (λ y, ff) (λ y, tt)) (λ x, y.elim (λ y, tt) (λ y, ff))), from by auto [h7],
    have h9 : ∃ (A B : Type*) (h : (A ⊕ B) = V), ∀ (x y : A ⊕ B), (x ≠ y) → (G.edge x y) → (x.elim (λ x, y.elim (λ y, ff) (λ y, tt)) (λ x, y.elim (λ y, tt) (λ y, ff))), from by auto [h8],
    have h10 : ∃ (A B : Type*) (h : (A ⊕ B) = V), ∀ (x y : A ⊕ B), (x ≠ y) → (G.edge x y) → (x.elim (λ x, y.elim (λ y, ff) (λ y, tt)) (λ x, y.elim (λ y, tt) (λ y, ff))), from by auto [h9],
    have h11 : ∃ (A B : Type*) (h : (A ⊕ B) = V), ∀ (x y : A ⊕ B), (x ≠ y) → (G.edge x y) → (x.elim (λ x, y.elim (λ y, ff) (λ y, tt)) (λ x, y.elim (λ y, tt) (λ y, ff))), from by auto [h10],
    have h12 : ∃ (A B : Type*) (h : (A ⊕ B) = V), ∀ (x y : A ⊕ B), (x ≠ y) → (G.edge x y) → (x.elim (λ x, y.elim (λ y, ff) (λ y, tt)) (λ x, y.elim (λ y, tt) (λ y, ff))), from by auto [h11],
    have h13 : ∃ (A B : Type*) (h : (A ⊕ B) = V), ∀ (x y : A ⊕ B), (x ≠ y) → (G.edge x y) → (x.elim (λ x, y.elim (λ y, ff) (λ y, tt)) (λ x, y.elim (λ y, tt) (λ y, ff))), from by auto [h12],
    have h14 : ∃ (A B : Type*) (h : (A ⊕ B) = V), ∀ (x y : A ⊕ B), (x ≠ y) → (G.edge x y) → (x.elim (λ x, y.elim (λ y, ff) (λ y, tt)) (λ x, y.elim (λ y, tt) (λ y, ff))), from by auto [h13],
    have h15 : ∃ (A B : Type*) (h : (A ⊕ B) = V), ∀ (x y : A ⊕ B), (x ≠ y) → (G.edge x y) → (x.elim (λ x, y.elim (λ y, ff) (λ y, tt)) (λ x, y.elim (λ y, tt) (λ y, ff))), from by auto [h14],
    have h16 : ∃ (A B : Type*) (h : (A ⊕ B) = V), ∀ (x y : A ⊕ B), (x ≠ y) → (G.edge x y) → (x.elim (λ x, y.elim (λ y, ff) (λ y, tt)) (λ x, y.elim (λ y, tt) (λ y, ff))), from by auto [h15],
    have h17 : ∃ (A B : Type*) (h : (A ⊕ B) = V), ∀ (x y : A ⊕ B), (x ≠ y) → (G.edge x y) → (x.elim (λ x, y.elim (λ y, ff) (λ y, tt)) (λ x, y.elim (λ y, tt) (λ y, ff))), from by auto [h16],
    have h18 : ∃ (A B : Type*) (h : (A ⊕ B) = V), ∀ (x y : A ⊕ B), (x ≠ y) → (G.edge x y) → (x.elim (λ x, y.elim (λ y, ff) (λ y, tt)) (λ x, y.elim (λ y, tt) (λ y, ff))), from by auto [h17],

end --Needs more than 2000 tokens!

/- FEW SHOT PROMPTS TO CODEX(START)
/--`theorem`
Power Set is Closed under Intersection
Let $S$ be a set.

Let $\powerset S$ be the power set of $S$.

Then:
:$\forall A, B \in \powerset S: A \cap B \in \powerset S$
`proof`
Let $A, B \in \powerset S$.

Then by the definition of power set, $A \subseteq S$ and $B \subseteq S$.

From Intersection is Subset we have that $A \cap B \subseteq A$.

It follows from Subset Relation is Transitive that $A \cap B \subseteq S$.

Thus $A \cap B \in \powerset S$ and closure is proved.
{{qed}}
-/
theorem power_set_intersection_closed {α : Type*} (S : set α) : ∀ A B ∈ 𝒫 S, (A ∩ B) ∈ 𝒫 S :=
begin
  assume (A : set α) (hA : A ∈ 𝒫 S) (B : set α) (hB : B ∈ 𝒫 S),
  have h1 : (A ⊆ S) ∧ (B ⊆ S), from by auto [set.subset_of_mem_powerset, set.subset_of_mem_powerset],
  have h2 : (A ∩ B) ⊆ A, from by auto [set.inter_subset_left],
  have h3 : (A ∩ B) ⊆ S, from by auto [set.subset.trans],
  show (A ∩ B) ∈  𝒫 S, from by auto [set.mem_powerset],
end

/--`theorem`
Square of Sum
 :$\forall x, y \in \R: \paren {x + y}^2 = x^2 + 2 x y + y^2$
`proof`
Follows from the distribution of multiplication over addition:

{{begin-eqn}}
{{eqn | l = \left({x + y}\right)^2
      | r = \left({x + y}\right) \cdot \left({x + y}\right)
}}
{{eqn | r = x \cdot \left({x + y}\right) + y \cdot \left({x + y}\right)
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x \cdot x + x \cdot y + y \cdot x + y \cdot y
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x^2 + 2xy + y^2
      | c =
}}
{{end-eqn}}
{{qed}}
-/
theorem square_of_sum (x y : ℝ) : (x + y)^2 = (x^2 + 2*x*y + y^2) :=
begin
  calc (x + y)^2 = (x+y)*(x+y) : by auto [sq]
  ... = x*(x+y) + y*(x+y) : by auto [add_mul]
  ... = x*x + x*y + y*x + y*y : by auto [mul_comm, add_mul] using [ring]
  ... = x^2 + 2*x*y + y^2 : by auto [sq, mul_comm] using [ring]
end

/--`theorem`
Identity of Group is Unique
Let $\struct {G, \circ}$ be a group. Then there is a unique identity element $e \in G$.
`proof`
From Group has Latin Square Property, there exists a unique $x \in G$ such that:
:$a x = b$

and there exists a unique $y \in G$ such that:
:$y a = b$

Setting $b = a$, this becomes:

There exists a unique $x \in G$ such that:
:$a x = a$

and there exists a unique $y \in G$ such that:
:$y a = a$

These $x$ and $y$ are both $e$, by definition of identity element.
{{qed}}
-/
theorem group_identity_unique {G : Type*} [group G] : ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a :=
begin
  have h1 : ∀ a b : G, ∃! x : G, a * x = b, from by auto using [use (a⁻¹ * b)],
  have h2 : ∀ a b : G, ∃! y : G, y * a = b, from by auto using [use b * a⁻¹],

  have h3 : ∀ a : G, ∃! x : G, a * x = a, from by auto [h1],
  have h4 : ∀ a : G, ∃! y : G, y * a = a, from by auto [h2],

  have h5 : ∀ a : G, classical.some (h3 a).exists = (1 : G), from by auto [exists_unique.unique, h3, classical.some_spec, exists_unique.exists, mul_one],
  have h6 : ∀ a : G, classical.some (h4 a).exists = (1 : G), from by auto [exists_unique.unique, h4, classical.some_spec, exists_unique.exists, one_mul],

  show ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a, from by auto [h3, h4, exists_unique.unique, classical.some_spec, exists_unique.exists] using [use (1 : G)],
end

/--`theorem`
Bipartite Graph is two colorable
Let $G$ be a graph. Then $G$ is 2-colorable if and only if $G$ is bipartite.
`proof`
Let $G$ be a 2-colorable graph, which means we can color every vertex either red or blue, and no edge will have both endpoints colored the same color. Let $A$ denote the subset of vertices colored red, and let $B$ denote the subset of vertices colored blue. Since all vertices of $A$ are red, there are no edges within $A$, and similarly for $B$. This implies that every edge has one endpoint in $A$ and the other in $B$, which means $G$ is bipartite.

Conversely, suppose $G$ is bipartite, that is, we can partition the vertices into two subsets $V_{1}, V_{2}$ every edge has one endpoint in $V_{1}$ and the other in $V_{2}$. Then coloring every vertex of $V_{1}$ red and every vertex of $V_{2}$ blue yields a valid coloring, so $G$ is 2-colorable.

QED

-/
theorem  bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) :=
FEW SHOT PROMPTS TO CODEX(END)-/


example (p : Prop) [Decidable p] (hnp : ¬ p) :
    if decide p then 0 = 1 else 1 = 1 := by
  simp [hnp, decide_eq_false Unit]


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon, Patrick Massot
-/
import tactic.pi_instances
import algebra.group.pi
import algebra.ring.basic

/-!
# Pi instances for ring

This file defines instances for ring, semiring and related structures on Pi Types
-/

namespace pi
universes u v w
variable {I : Type u}     -- The indexing type
variable {f : I → Type v} -- The family of types already equipped with instances
variables (x y : Π i, f i) (i : I)

instance distrib [Π i, distrib $ f i] : distrib (Π i : I, f i) :=
by refine_struct { add := (+), mul := (*), .. }; tactic.pi_instance_derive_field

instance non_unital_non_assoc_semiring [∀ i, non_unital_non_assoc_semiring $ f i] :
  non_unital_non_assoc_semiring (Π i : I, f i) :=
by refine_struct { zero := (0 : Π i, f i), add := (+), mul := (*), .. };
  tactic.pi_instance_derive_field

instance non_unital_semiring [∀ i, non_unital_semiring $ f i] :
  non_unital_semiring (Π i : I, f i) :=
by refine_struct { zero := (0 : Π i, f i), add := (+), mul := (*), .. };
  tactic.pi_instance_derive_field

instance non_assoc_semiring [∀ i, non_assoc_semiring $ f i] :
  non_assoc_semiring (Π i : I, f i) :=
by refine_struct { zero := (0 : Π i, f i), one := 1, add := (+), mul := (*), .. };
  tactic.pi_instance_derive_field

instance semiring [∀ i, semiring $ f i] : semiring (Π i : I, f i) :=
by refine_struct { zero := (0 : Π i, f i), one := 1, add := (+), mul := (*),
  nsmul := add_monoid.nsmul, npow := monoid.npow };
tactic.pi_instance_derive_field

instance comm_semiring [∀ i, comm_semiring $ f i] : comm_semiring (Π i : I, f i) :=
by refine_struct { zero := (0 : Π i, f i), one := 1, add := (+), mul := (*),
  nsmul := add_monoid.nsmul, npow := monoid.npow };
tactic.pi_instance_derive_field

instance non_unital_non_assoc_ring [∀ i, non_unital_non_assoc_ring $ f i] :
  non_unital_non_assoc_ring (Π i : I, f i) :=
by refine_struct { zero := (0 : Π i, f i), add := (+), mul := (*),
  neg := has_neg.neg, nsmul := add_monoid.nsmul, zsmul := sub_neg_monoid.zsmul };
tactic.pi_instance_derive_field

instance ring [∀ i, ring $ f i] : ring (Π i : I, f i) :=
by refine_struct { zero := (0 : Π i, f i), one := 1, add := (+), mul := (*),
  neg := has_neg.neg, nsmul := add_monoid.nsmul, zsmul := sub_neg_monoid.zsmul,
  npow := monoid.npow };
tactic.pi_instance_derive_field

instance comm_ring [∀ i, comm_ring $ f i] : comm_ring (Π i : I, f i) :=
by refine_struct { zero := (0 : Π i, f i), one := 1, add := (+), mul := (*),
  neg := has_neg.neg, nsmul := add_monoid.nsmul, zsmul := sub_neg_monoid.zsmul,
  npow := monoid.npow };
tactic.pi_instance_derive_field

/-- A family of ring homomorphisms `f a : γ →+* β a` defines a ring homomorphism
`pi.ring_hom f : γ →+* Π a, β a` given by `pi.ring_hom f x b = f b x`. -/
@[simps]
protected def ring_hom {γ : Type w} [Π i, non_assoc_semiring (f i)] [non_assoc_semiring γ]
  (g : Π i, γ →+* f i) : γ →+* Π i, f i :=
{ to_fun := λ x b, g b x,
  map_add' := λ x y, funext $ λ z, (g z).map_add x y,
  map_mul' := λ x y, funext $ λ z, (g z).map_mul x y,
  map_one' := funext $ λ z, (g z).map_one,
  map_zero' := funext $ λ z, (g z).map_zero }

lemma ring_hom_injective {γ : Type w} [nonempty I] [Π i, non_assoc_semiring (f i)]
  [non_assoc_semiring γ] (g : Π i, γ →+* f i) (hg : ∀ i, function.injective (g i)) :
  function.injective (pi.ring_hom g) :=
λ x y h, let ⟨i⟩ := ‹nonempty I› in hg i ((function.funext_iff.mp h : _) i)

end pi

section ring_hom

universes u v
variable {I : Type u}

/-- Evaluation of functions into an indexed collection of monoids at a point is a monoid
homomorphism. This is `function.eval` as a `ring_hom`. -/
@[simps]
def pi.eval_ring_hom (f : I → Type v) [Π i, non_assoc_semiring (f i)] (i : I) :
  (Π i, f i) →+* f i :=
{ ..(pi.eval_monoid_hom f i),
  ..(pi.eval_add_monoid_hom f i) }

/-- `function.const` as a `ring_hom`. -/
@[simps]
def pi.const_ring_hom (α β : Type*) [non_assoc_semiring β] : β →+* (α → β) :=
{ to_fun := function.const _,
  .. pi.ring_hom (λ _, ring_hom.id β) }

/-- Ring homomorphism between the function spaces `I → α` and `I → β`, induced by a ring
homomorphism `f` between `α` and `β`. -/
@[simps] protected def ring_hom.comp_left {α β : Type*} [non_assoc_semiring α]
  [non_assoc_semiring β] (f : α →+* β) (I : Type*) :
  (I → α) →+* (I → β) :=
{ to_fun := λ h, f ∘ h,
  .. f.to_monoid_hom.comp_left I,
  .. f.to_add_monoid_hom.comp_left I }

end ring_hom


/-
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