/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Tim Baumann, Stephen Morgan, Scott Morrison, Floris van Doorn
-/
import category_theory.natural_transformation
import category_theory.isomorphism

/-!
# The category of functors and natural transformations between two fixed categories.

We provide the category instance on `C ⥤ D`, with morphisms the natural transformations.

## Universes

If `C` and `D` are both small categories at the same universe level,
this is another small category at that level.
However if `C` and `D` are both large categories at the same universe level,
this is a small category at the next higher level.
-/

namespace category_theory

-- declare the `v`'s first; see `category_theory.category` for an explanation
universes v₁ v₂ v₃ u₁ u₂ u₃

open nat_trans category category_theory.functor

variables (C : Type u₁) [category.{v₁} C] (D : Type u₂) [category.{v₂} D]

local attribute [simp] vcomp_app
/--
`functor.category C D` gives the category structure on functors and natural transformations
between categories `C` and `D`.

Notice that if `C` and `D` are both small categories at the same universe level,
this is another small category at that level.
However if `C` and `D` are both large categories at the same universe level,
this is a small category at the next higher level.
-/
instance functor.category : category.{(max u₁ v₂)} (C ⥤ D) :=
{ hom     := λ F G, nat_trans F G,
  id      := λ F, nat_trans.id F,
  comp    := λ _ _ _ α β, vcomp α β }

variables {C D} {E : Type u₃} [category.{v₃} E]
variables {F G H I : C ⥤ D}

namespace nat_trans

@[simp] lemma vcomp_eq_comp (α : F ⟶ G) (β : G ⟶ H) : vcomp α β = α ≫ β := rfl

lemma vcomp_app' (α : F ⟶ G) (β : G ⟶ H) (X : C) :
  (α ≫ β).app X = (α.app X) ≫ (β.app X) := rfl

lemma congr_app {α β : F ⟶ G} (h : α = β) (X : C) : α.app X = β.app X := by rw h
@[simp] lemma id_app (F : C ⥤ D) (X : C) : (𝟙 F : F ⟶ F).app X = 𝟙 (F.obj X) := rfl
@[simp] lemma comp_app {F G H : C ⥤ D} (α : F ⟶ G) (β : G ⟶ H) (X : C) :
  (α ≫ β).app X = α.app X ≫ β.app X := rfl

lemma app_naturality {F G : C ⥤ (D ⥤ E)} (T : F ⟶ G) (X : C) {Y Z : D} (f : Y ⟶ Z) :
  ((F.obj X).map f) ≫ ((T.app X).app Z) = ((T.app X).app Y) ≫ ((G.obj X).map f) :=
(T.app X).naturality f

lemma naturality_app {F G : C ⥤ (D ⥤ E)} (T : F ⟶ G) (Z : D) {X Y : C} (f : X ⟶ Y) :
  ((F.map f).app Z) ≫ ((T.app Y).app Z) = ((T.app X).app Z) ≫ ((G.map f).app Z) :=
congr_fun (congr_arg app (T.naturality f)) Z

/-- A natural transformation is a monomorphism if each component is. -/
lemma mono_app_of_mono (α : F ⟶ G) [∀ (X : C), mono (α.app X)] : mono α :=
⟨λ H g h eq, by { ext X, rw [←cancel_mono (α.app X), ←comp_app, eq, comp_app] }⟩

/-- A natural transformation is an epimorphism if each component is. -/
lemma epi_app_of_epi (α : F ⟶ G) [∀ (X : C), epi (α.app X)] : epi α :=
⟨λ H g h eq, by { ext X, rw [←cancel_epi (α.app X), ←comp_app, eq, comp_app] }⟩

/-- `hcomp α β` is the horizontal composition of natural transformations. -/
def hcomp {H I : D ⥤ E} (α : F ⟶ G) (β : H ⟶ I) : (F ⋙ H) ⟶ (G ⋙ I) :=
{ app         := λ X : C, (β.app (F.obj X)) ≫ (I.map (α.app X)),
  naturality' := λ X Y f,
  begin
    rw [functor.comp_map, functor.comp_map, ←assoc, naturality, assoc,
        ←map_comp I, naturality, map_comp, assoc]
  end }

infix ` ◫ `:80 := hcomp

@[simp] lemma hcomp_app {H I : D ⥤ E} (α : F ⟶ G) (β : H ⟶ I) (X : C) :
  (α ◫ β).app X = (β.app (F.obj X)) ≫ (I.map (α.app X)) := rfl

@[simp] lemma hcomp_id_app {H : D ⥤ E} (α : F ⟶ G) (X : C) : (α ◫ 𝟙 H).app X = H.map (α.app X) :=
  by {dsimp, simp} -- See note [dsimp, simp].

lemma id_hcomp_app {H : E ⥤ C} (α : F ⟶ G) (X : E) : (𝟙 H ◫ α).app X = α.app _ := by simp

-- Note that we don't yet prove a `hcomp_assoc` lemma here: even stating it is painful, because we
-- need to use associativity of functor composition. (It's true without the explicit associator,
-- because functor composition is definitionally associative,
-- but relying on the definitional equality causes bad problems with elaboration later.)

lemma exchange {I J K : D ⥤ E} (α : F ⟶ G) (β : G ⟶ H)
  (γ : I ⟶ J) (δ : J ⟶ K) : (α ≫ β) ◫ (γ ≫ δ) = (α ◫ γ) ≫ (β ◫ δ) :=
by ext; simp

end nat_trans
open nat_trans
namespace functor

/-- Flip the arguments of a bifunctor. See also `currying.lean`. -/
protected def flip (F : C ⥤ (D ⥤ E)) : D ⥤ (C ⥤ E) :=
{ obj := λ k,
  { obj := λ j, (F.obj j).obj k,
    map := λ j j' f, (F.map f).app k,
    map_id' := λ X, begin rw category_theory.functor.map_id, refl end,
    map_comp' := λ X Y Z f g, by rw [map_comp, ←comp_app] },
  map := λ c c' f,
  { app := λ j, (F.obj j).map f } }.

@[simp] lemma flip_obj_obj (F : C ⥤ (D ⥤ E)) (c) (d) : (F.flip.obj d).obj c = (F.obj c).obj d := rfl
@[simp] lemma flip_obj_map (F : C ⥤ (D ⥤ E)) {c c' : C} (f : c ⟶ c') (d : D) :
  (F.flip.obj d).map f = (F.map f).app d := rfl
@[simp] lemma flip_map_app (F : C ⥤ (D ⥤ E)) {d d' : D} (f : d ⟶ d') (c : C) :
  (F.flip.map f).app c = (F.obj c).map f := rfl

end functor

@[simp, reassoc] lemma map_hom_inv_app (F : C ⥤ D ⥤ E) {X Y : C} (e : X ≅ Y) (Z : D) :
  (F.map e.hom).app Z ≫ (F.map e.inv).app Z = 𝟙 _ :=
by simp [← nat_trans.comp_app, ← functor.map_comp]

@[simp, reassoc] lemma map_inv_hom_app (F : C ⥤ D ⥤ E) {X Y : C} (e : X ≅ Y) (Z : D) :
  (F.map e.inv).app Z ≫ (F.map e.hom).app Z = 𝟙 _ :=
by simp [← nat_trans.comp_app, ← functor.map_comp]

end category_theory


import .diffeomorph

open function set
open_locale topological_space

variables {𝕜 : Type*} [nondiscrete_normed_field 𝕜]
{E : Type*} [normed_group E] [normed_space 𝕜 E]
{E' : Type*} [normed_group E'] [normed_space 𝕜 E']
{F : Type*} [normed_group F] [normed_space 𝕜 F]
{F' : Type*} [normed_group F'] [normed_space 𝕜 F']
{H : Type*} [topological_space H]
{H' : Type*} [topological_space H']
{G : Type*} [topological_space G]
{G' : Type*} [topological_space G']

/-- local diffeomorphisms, defined on open subsets of the space -/
@[nolint has_inhabited_instance]
structure local_diffeomorph
(I : model_with_corners 𝕜 E H) (I' : model_with_corners 𝕜 E' H')
(M : Type*) [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M]
(M' : Type*) [topological_space M'] [charted_space H' M'] [smooth_manifold_with_corners I' M']
extends local_homeomorph M M' :=
(smooth_to_fun      : smooth_in_charts_on I I' to_fun source)
(smooth_inv_fun     : smooth_in_charts_on I' I inv_fun target)

/-- A diffomorphism induces a local diffeomorphism on the whole space -/
def diffeomorph.to_local_diffeomorph
(I : model_with_corners 𝕜 E H) (I' : model_with_corners 𝕜 E' H')
(M : Type*) [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M]
(M' : Type*) [topological_space M'] [charted_space H' M'] [smooth_manifold_with_corners I' M']
(e : diffeomorph I I' M M') :
  local_diffeomorph I I' M M' :=
{ smooth_to_fun  := by { simp only [smooth_in_charts_on], erw times_cont_mdiff_in_charts_on_univ, exact e.smooth_to_fun },
  smooth_inv_fun := by { simp only [smooth_in_charts_on], erw times_cont_mdiff_in_charts_on_univ, exact e.smooth_inv_fun },
  ..e.to_homeomorph.to_local_homeomorph }

namespace local_diffeomorph

variables {I : model_with_corners 𝕜 E H} {I' : model_with_corners 𝕜 E' H'}
{J : model_with_corners 𝕜 F G} {J' : model_with_corners 𝕜 F' G'}
{M : Type*} [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M]
{M' : Type*} [topological_space M'] [charted_space H' M'] [smooth_manifold_with_corners I' M']
{N : Type*} [topological_space N] [charted_space G N] [smooth_manifold_with_corners J N]
{N' : Type*} [topological_space N'] [charted_space G' N'] [smooth_manifold_with_corners J' N']
(e : local_diffeomorph I I' M M') (e' : local_diffeomorph J J' N N')

instance : has_coe (local_diffeomorph I I' M M') (local_homeomorph M M') := ⟨local_diffeomorph.to_local_homeomorph⟩
instance : has_coe_to_fun (local_diffeomorph I I' M M') := ⟨_, λ e, e.to_local_equiv.to_fun⟩

/-- The inverse of a local homeomorphism -/
protected def symm : local_diffeomorph I' I M' M :=
{ smooth_to_fun      := e.smooth_inv_fun,
  smooth_inv_fun     := e.smooth_to_fun,
  ..e.to_local_homeomorph.symm }

protected lemma smooth_in_charts_on : smooth_in_charts_on I I' e e.source := e.smooth_to_fun

lemma smooth_in_charts_on_symm : smooth_in_charts_on I' I e.symm e.target := e.smooth_inv_fun

/- Register a few simp lemmas to make sure that `simp` puts the application of a local
diffeomorphism in its normal form, i.e., in terms of its coercion to a function. -/

@[simp, mfld_simps] lemma to_fun_eq_coe (e : local_diffeomorph I I' M M') : e.to_fun = e := rfl

@[simp, mfld_simps] lemma inv_fun_eq_coe (e : local_diffeomorph I I' M M') : e.inv_fun = e.symm := rfl

@[simp, mfld_simps] lemma coe_coe : (e.to_local_equiv : M → M') = e := rfl

@[simp, mfld_simps] lemma coe_coe_symm : (e.to_local_equiv.symm : M' → M) = e.symm := rfl

@[simp, mfld_simps] lemma map_source {x : M} (h : x ∈ e.source) : e x ∈ e.target :=
e.map_source' h

@[simp, mfld_simps] lemma map_target {x : M'} (h : x ∈ e.target) : e.symm x ∈ e.source :=
e.map_target' h

@[simp, mfld_simps] lemma left_inv {x : M} (h : x ∈ e.source) : e.symm (e x) = x :=
e.left_inv' h

@[simp, mfld_simps] lemma right_inv {x : M'} (h : x ∈ e.target) : e (e.symm x) = x :=
e.right_inv' h

lemma eq_of_local_equiv_eq {e e' : local_diffeomorph I I' M M'}
  (h : e.to_local_equiv = e'.to_local_equiv) : e = e' :=
begin
  cases e, cases e',
  dsimp at *,
  induction h,
  refl
end

lemma eventually_left_inverse (e : local_diffeomorph I I' M M') {x} (hx : x ∈ e.source) :
  ∀ᶠ y in 𝓝 x, e.symm (e y) = y :=
filter.eventually.mono (mem_nhds_sets e.open_source hx) e.left_inv'

end local_diffeomorph


import combinatorics.simple_graph.coloring

--OUTPUT 1
theorem two_colorable_bipartite {G : Type*} [graph G] : two_colorable G ↔ bipartite G :=
begin
  have h1 : two_colorable G → bipartite G, from sorry,
  have h2 : bipartite G → two_colorable G, from sorry,
  show two_colorable G ↔ bipartite G, from sorry,
end

--OUTPUT 2
theorem two_colorable_iff_bipartite {G : Type*} [graph G] : two_colorable G ↔ bipartite G :=
begin
  sorry,
end

--OUTPUT 3
theorem bipartite_graph_two_colorable {G : Type*} [graph G] : is_bipartite G ↔ is_two_colorable G :=
begin
  show is_bipartite G ↔ is_two_colorable G, from sorry,
end

--OUTPUT 4
theorem bipartite_two_colorable (G : Type*) [graph G] : two_colorable G ↔ bipartite G :=
begin
  have h1 : two_colorable G → bipartite G, from by {
    assume h1 : two_colorable G,
    have h2 : ∃ A B : set G, ∀ a : G, a ∈ A ∨ a ∈ B ∧ (∀ a b : G, a ∈ A ∧ b ∈ A → ¬(a b)) ∧ (∀ a b : G, a ∈ B ∧ b ∈ B → ¬(a b)) ∧ (∀ a b : G, a ∈ A ∧ b ∈ B → (a b)), from sorry,
    show bipartite G, from sorry,
  },
  have h2 : bipartite G → two_colorable G, from by {
    assume h2 : bipartite G,
    have h3 : ∃ A B : set G, ∀ a : G, a ∈ A ∨ a ∈ B ∧ (∀ a b : G, a ∈ A ∧ b ∈ A → ¬(a b)) ∧ (∀ a b : G, a ∈ B ∧ b ∈ B → ¬(a b)) ∧ (∀ a b : G, a ∈ A ∧ b ∈ B → (a b)), from sorry,
    show two_colorable G, from sorry,
  },
  show two_colorable G ↔ bipartite G, from sorry,
end

--OUTPUT 5
theorem bipartite_two_colorable (G : Type*) [graph G] : 2-colorable G ↔ bipartite G :=
begin
  have h1 : 2-colorable G → bipartite G, from sorry,
  have h2 : bipartite G → 2-colorable G, from sorry,
  show 2-colorable G ↔ bipartite G, from sorry,
end

--OUTPUT 6
theorem bipartite_graph_two_colorable (G : Type*) [graph G] :
  (∃ V1 V2 : set G, ∀ v1 ∈ V1, ∀ v2 ∈ V2, ∀ e : G, e ∈ edges G → v1 = e.1 ∨ v2 = e.2) ↔
  (∃ f : G → ℕ, ∀ e : G, e ∈ edges G → f e.1 ≠ f e.2) :=
begin
  split,
  {
    assume h1 : ∃ V1 V2 : set G, ∀ v1 ∈ V1, ∀ v2 ∈ V2, ∀ e : G, e ∈ edges G → v1 = e.1 ∨ v2 = e.2,
    have h2 : ∃ V1 V2 : set G, ∀ v1 ∈ V1, ∀ v2 ∈ V2, ∀ e : G, e ∈ edges G → v1 = e.1 ∨ v2 = e.2, from h1,
    cases h2 with V1 h2,
    cases h2 with V2 h2,
    use (λ v : G, if v ∈ V1 then 0 else 1),
    assume (v1 v2 : G) (h3 : v1 ∈ V1) (h4 : v2 ∈ V2) (e : G) (h5 : e ∈ edges G),
    have h6 : v1 ∉ V2, from sorry,
    have h7 : v2 ∉ V1, from sorry,
    show (if v1 ∈ V1 then 0 else 1) ≠ (if v2 ∈ V1 then 0 else 1), from sorry,
  },
  {
    assume h1 : ∃ f : G → ℕ, ∀ e : G, e ∈ edges G → f e.1 ≠ f e.2,
    have h2 : ∃ f : G → ℕ, ∀ e : G, e ∈ edges G → f e.1 ≠ f e.2, from h1,
    cases h2 with f h2,
    use (λ v : G, if f v = 0 then true else false),
    use (λ v : G, if f v = 1 then true else false),
    assume (v1 v2 : G) (h3 : v1 ∈ (λ v : G, if f v = 0 then true else false)) (h4 : v2 ∈ (λ v : G, if f v = 1 then true else false)) (e : G) (h5 : e ∈ edges G),
    have h6 : v1 ∉ (λ v : G, if f v = 1 then true else false), from sorry,
    have h7 : v2 ∉ (λ v : G, if f v = 0 then true else false), from sorry,
    show v1 = e.1 ∨ v2 = e.2, from sorry,
  }
end

/- 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 sorry,
  have h2 : (A ∩ B) ⊆ A, from sorry,
  have h3 : (A ∩ B) ⊆ S, from sorry,
  show (A ∩ B) ∈  𝒫 S, from sorry,
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 sorry
  ... = x*(x+y) + y*(x+y) : by sorry
  ... = x*x + x*y + y*x + y*y : by sorry
  ... = x^2 + 2*x*y + y^2 : by sorry,
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 sorry,
  have h2 : ∀ a b : G, ∃! y : G, y * a = b, from sorry,

  have h3 : ∀ a : G, ∃! x : G, a * x = a, from sorry,
  have h4 : ∀ a : G, ∃! y : G, y * a = a, from sorry,

  have h5 : ∀ a : G, classical.some (h3 a) = (1 : G), from sorry,
  have h6 : ∀ a : G, classical.some (h4 a) = (1 : G), from sorry,

  show ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a, from by {
    use (1 : G),
    have h7 : ∀ e : G, (∀ a : G, e * a = a ∧ a * e = a) → e = 1, from by {
      assume (e : G) (h7 : ∀ a : G, e * a = a ∧ a * e = a),
      have h8 : ∀ a : G, e = classical.some (h3 a), from sorry,
      have h9 : ∀ a : G, e = classical.some (h4 a), from sorry,
      show e = (1 : G), from sorry,
    },
    sorry,
  }
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
FEW SHOT PROMPTS TO CODEX(END)-/


/-
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 Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.module.basic
import Mathlib.PostPort

universes u_1 u_2 u_3

namespace Mathlib

/-!
# Prod instances for module and multiplicative actions

This file defines instances for binary product of modules
-/

namespace prod

protected instance has_scalar {α : Type u_1} {β : Type u_2} {γ : Type u_3} [has_scalar α β] [has_scalar α γ] : has_scalar α (β × γ) :=
  has_scalar.mk fun (a : α) (p : β × γ) => (a • fst p, a • snd p)

@[simp] theorem smul_fst {α : Type u_1} {β : Type u_2} {γ : Type u_3} [has_scalar α β] [has_scalar α γ] (a : α) (x : β × γ) : fst (a • x) = a • fst x :=
  rfl

@[simp] theorem smul_snd {α : Type u_1} {β : Type u_2} {γ : Type u_3} [has_scalar α β] [has_scalar α γ] (a : α) (x : β × γ) : snd (a • x) = a • snd x :=
  rfl

@[simp] theorem smul_mk {α : Type u_1} {β : Type u_2} {γ : Type u_3} [has_scalar α β] [has_scalar α γ] (a : α) (b : β) (c : γ) : a • (b, c) = (a • b, a • c) :=
  rfl

protected instance semimodule {α : Type u_1} {β : Type u_2} {γ : Type u_3} {r : semiring α} [add_comm_monoid β] [add_comm_monoid γ] [semimodule α β] [semimodule α γ] : semimodule α (β × γ) :=
  semimodule.mk sorry sorry


import data.quot tactic
open classical
noncomputable theory

variables (p : Type) {α : Type*} {β : Type*}

inductive eq' (a : α) : α → Type
| refl : eq' a
infix ` =' `:50 := eq'

def eq'.symm : ∀ {a b : α}, a =' b → b =' a
| _ _ (eq'.refl _) := (eq'.refl _)

def eq'.trans : ∀ {a b c : α}, a =' b → b =' c → a =' c
| _ _ _ (eq'.refl _) (eq'.refl _) := (eq'.refl _)

def eq'.congr_arg (f : α → β): ∀ {a b : α}, a =' b → f a =' f b
| _ _ (eq'.refl a) := eq'.refl _

def eq'.cast : ∀ {a b : Type}, a =' b → a → b
| _ _ (eq'.refl a) := id

def U (x : Type) : Type := trunc (trunc x =' trunc unit ⊕ p)
def V (x : Type) : Type := trunc (trunc x =' trunc empty ⊕ p)

def exU : trunc (Σ x : Type, U p x) := trunc.mk ⟨unit, trunc.mk $ sum.inl (eq'.refl _)⟩
def exV : trunc (Σ x : Type, V p x) := trunc.mk ⟨empty, trunc.mk $ sum.inl (eq'.refl _)⟩

axiom choice' {α  : Type*} {β : α → Type*} {r : Π x, β x → Type*}
  (f : Π i, trunc (Σ b : β i, r i b)) :
  trunc (Π i, Σ b : β i, r i b)

lemma choice'2 {α  : Type*} {β : α → Type*} (f : Π a, trunc (β a)) :
  trunc (Π a, β a) :=
let g : Π a, trunc (Σ b : β a, unit) := λ a, trunc.map (λ x, ⟨x, ()⟩) (f a) in
trunc.map (by intros g a; exact (g a).1) (choice' g)

lemma choice3 {α : Type*} : trunc (Σ f : α → α, Π a b : α, f a =' f b) :=
trunc.rec_on_subsingleton (choice'2 (@trunc.mk α))
begin

end

def not_uv_or_p : ∀ (u : Σ x : Type, U p x) (v : Σ x : Type, V p x),
  trunc ((trunc u.fst =' trunc v.fst → empty) ⊕ p) :=
begin
  rintros ⟨u, hu⟩ ⟨v, hv⟩,
  dsimp [U, V] at *,
  refine trunc.lift_on hu (λ hu, _) (λ _ _, subsingleton.elim _ _),
  refine trunc.lift_on hv (λ hv, _) (λ _ _, subsingleton.elim _ _),
  cases hu with hu hu,
  { cases hv with hv hv,
    { refine trunc.mk (sum.inl (λ e, _)),
      have : trunc unit =' trunc empty, from eq'.rec_on hu (eq'.rec_on hv e),
      have : trunc empty, from this.cast (trunc.mk ()),
      refine trunc.lift_on this id (assume a, by cases a) },
    { exact trunc.mk (sum.inr hv) } },
  { exact trunc.mk (sum.inr hu) }
end

axiom funext' {β : α → Type*}
  {f₁ f₂ : Π x : α, β x} (h : ∀ x, f₁ x =' f₂ x) : f₁ =' f₂

axiom univalence {α β : Sort*} : α ≃ β → α =' β

noncomputable lemma trunc_eq'_trunc_of_true {α β : Sort*} : α → β → trunc α =' trunc β :=
λ a b, univalence ⟨λ _, trunc.mk b, λ _, trunc.mk a, λ _, subsingleton.elim _ _,
  λ _, subsingleton.elim _ _⟩

-- noncomputable def p_implies_uv (hp : p) (u : Σ x : Type, U p x)
--   (v : Σ x : Type, V p x) : u.fst =' v.fst :=
-- begin
--   have : U p =' V p,
--   { refine funext' (λ x, _),
--     exact trunc_eq'_trunc_of_true (sum.inr hp) (sum.inr hp), },
--   revert u v,
--   refine eq'.rec_on this _,
--   assume u v,
--   exact trunc_eq'_trunc_of_true _ _,
-- end

noncomputable def em : trunc (p ⊕ (p → empty)) :=
let fU : trunc (Π {α : Type → Type → Type}, (Π p : Type, Σ x : Type, α p x)) :=
  choice'2 (λ α, choice' (λ p, _))  in
let fV : trunc (Π p : Type, Σ x : Type, V p x) := choice' exV in
trunc.rec_on_subsingleton fU (assume fU', trunc.rec_on_subsingleton fV (assume fV',
  let exU := fU' p, exV := fV' p in
  have p → trunc exU.1 =' trunc exV.1,
    from λ hp, have U p =' V p, from funext'
        (λ x, trunc_eq'_trunc_of_true (sum.inr hp) (sum.inr hp)),
      begin
        revert exU exV fU' fV',
        dsimp [fU, fV],
        refine eq'.rec_on this _,
        intros,
        exact trunc_eq'_trunc_of_true _ _,
      end,

  trunc.mk begin
    refine sum.rec_on (not_uv_or_p p(fU p) (fV p)) _ _,
    { assume h,
      exact sum.inr (assume hp : p, h (p_implies_uv p hp _ _)) },
    { exact sum.inl }
end))


/-
Copyright (c) 2021 OpenAI. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kunhao Zheng, Stanislas Polu, David Renshaw, OpenAI GPT-f
-/
import mathzoo.imports.miniF2F

open_locale nat rat real big_operators topological_space

theorem mathd_numbertheory_403 :
  ∑ k in (nat.proper_divisors 198), k = 270 :=
begin
  refl,
end


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

import category_theory.limits.shapes.finite_products
import category_theory.limits.shapes.zero_morphisms
import category_theory.limits.types
import category_theory.limits.mono_coprod

universe u

noncomputable theory

open category_theory category_theory.category category_theory.limits

namespace category_theory

namespace limits

variables {C : Type*} [category C] [has_finite_coproducts C]

variable {C}

namespace mono_coprod

namespace mono_inclusion_sub_coproduct

variables {I J : Type*} [fintype I] [decidable_eq I] [fintype J] [mono_coprod C] (X : I → C) (γ : J → I)
  (hγ : function.injective γ)

def α : sigma_obj (λ j, X (γ j)) ⟶ sigma_obj X := sigma.desc (λ j, sigma.ι _ (γ j))
def β : sigma_obj (λ (k : (finset.image γ ⊤)ᶜ), X k) ⟶ sigma_obj X := sigma.desc (λ k, sigma.ι _ k)
def φ := coprod.desc (α X γ) (β X γ)
def index (i : I) (hi : i ∈ finset.image γ ⊤) : J := (finset.mem_image.mp hi).some
lemma index_cond (i : I) (hi : i ∈ finset.image γ ⊤) : i = γ (index γ i hi) :=
(finset.mem_image.mp hi).some_spec.some_spec.symm

include hγ

lemma index_eq (i : I) (j : J) (hj : i = γ j) : index γ i (by { simp only [finset.mem_image],
  exact ⟨j, finset.mem_univ j, hj.symm⟩, }) = j :=
begin
  apply hγ,
  rw [← index_cond γ i, hj],
end

omit hγ

def ψ₁ (i : I) (hi : i ∈ finset.image γ ⊤) : X i ⟶ sigma_obj (λ j, X (γ j)) :=
eq_to_hom (by { congr, exact index_cond γ i hi,}) ≫ sigma.ι _ (index γ i hi)

lemma sigma.congr_ι {J D : Type*} [category D] (F : J → D) [has_coproduct F]
  (a b : J) (h : a = b) : eq_to_hom (by rw h) ≫ sigma.ι F a = sigma.ι F b :=
by { subst h, simp only [eq_to_hom_refl, id_comp], }

include hγ

lemma ψ₁_eq_ι (j : J) : ψ₁ X γ (γ j) (by { rw finset.mem_image, exact ⟨j, finset.mem_univ _, rfl⟩}) =
  sigma.ι _ j :=
sigma.congr_ι (λ (j : J), X (γ j)) (index γ (γ j) _) j (index_eq γ hγ (γ j) j rfl)

omit hγ

def ψ₂ (i : I) (hi : ¬ i ∈ (finset.image γ ⊤)) :
  X i ⟶ sigma_obj (λ (k : (finset.image γ ⊤)ᶜ), X k) :=
sigma.ι (λ (k : (finset.image γ ⊤)ᶜ), X k) ⟨i, by simpa only [finset.mem_compl] using hi⟩

def ψ : sigma_obj X ⟶ sigma_obj (λ j, X (γ j)) ⨿ sigma_obj (λ (k : (finset.image γ ⊤)ᶜ), X k) :=
sigma.desc (λ i, begin
  by_cases hi : i ∈ finset.image γ finset.univ,
  { exact ψ₁ X γ i hi ≫ coprod.inl, },
  { exact ψ₂ X γ i hi ≫ coprod.inr, },
end)

include hγ
@[simps]
def iso : sigma_obj (λ j, X (γ j)) ⨿ sigma_obj (λ (k : (finset.image γ ⊤)ᶜ), X k) ≅ sigma_obj X :=
{ hom := φ X γ,
  inv := ψ X γ,
  hom_inv_id' := begin
    dsimp only [φ, ψ, α, β],
    ext; discrete_cases,
    { rw [coprod.inl_desc_assoc, colimit.ι_desc_assoc, cofan.mk_ι_app, colimit.ι_desc,
        cofan.mk_ι_app, comp_id],
      dsimp,
      rw dif_pos, swap,
      { simp only [finset.mem_image],
        exact ⟨j, finset.mem_univ _, rfl⟩, },
      erw ψ₁_eq_ι X γ hγ j, },
    { rw [coprod.inr_desc_assoc, colimit.ι_desc_assoc, cofan.mk_ι_app, colimit.ι_desc,
        cofan.mk_ι_app, comp_id],
      dsimp,
      rw dif_neg, swap,
      { simpa only [finset.mem_compl] using j.2, },
      dsimp [ψ₂],
      congr,
      simp only [finset.mk_coe], },
  end,
  inv_hom_id' := begin
    dsimp only [φ, ψ, α, β],
    ext,
    discrete_cases,
    simp only [colimit.ι_desc_assoc, cofan.mk_ι_app, comp_id],
    dsimp only,
    split_ifs with hj,
    { simp [finset.mem_image] at hj,
      rcases hj with ⟨i, hi⟩,
      subst hi,
      erw ψ₁_eq_ι X γ hγ i,
      tidy },
    { dsimp [ψ₂],
      erw [category.assoc, coprod.inr_desc, colimit.ι_desc, cofan.mk_ι_app],
      refl, },
  end, }

end mono_inclusion_sub_coproduct

section

variables {I J : Type*} [fintype I] [fintype J] [mono_coprod C]
  (X : I → C) (γ : J → I)

@[simp]
def map_coproduct : sigma_obj (λ j, X (γ j)) ⟶ sigma_obj X := sigma.desc (λ j, sigma.ι _ (γ j))

lemma mono_inclusion_sub_coproduct (hγ : function.injective γ) : mono (map_coproduct X γ) :=
begin
  classical,
  let α : sigma_obj (λ j, X (γ j)) ⟶ sigma_obj X := sigma.desc
    (λ j, sigma.ι X (γ j)),
  change mono α,
  rw [show α = coprod.inl ≫ (mono_inclusion_sub_coproduct.iso X γ hγ).hom, by tidy],
  apply mono_comp,
end

end

instance mono_sigma_ι {I : Type*} [fintype I] [mono_coprod C] (X : I → C) (i : I):
  mono (sigma.ι X i) :=
begin
  let γ : fin 1 → I := λ x, i,
  have hγ : function.injective γ := λ x₁ x₂ h, subsingleton.elim _ _,
  let e : X i ≅ (∐ λ (j : fin 1), X (γ j)) :=
  { hom := sigma.ι (λ (j : fin 1), X (γ j)) 0,
    inv := sigma.desc (λ j, 𝟙 _),
    hom_inv_id' := by tidy,
    inv_hom_id' := by { ext, discrete_cases, tidy, }, },
  haveI := mono_inclusion_sub_coproduct X γ hγ,
  convert (mono_comp _ _ : mono (e.hom ≫ map_coproduct X γ)),
  simp only [map_coproduct, colimit.ι_desc, cofan.mk_ι_app],
end

end mono_coprod

end limits

end category_theory


import spectral_norm

noncomputable theory

open_locale nnreal

variables {K : Type*} [nontrivially_normed_field K]  [complete_space K] {L : Type*} [hL: field L]
  [algebra K L] (h_alg : algebra.is_algebraic K L)

include hL

lemma spectral_norm.unique' {f : L → nnreal} (hf_pow : is_pow_mult f)
  (hf_alg_norm : is_algebra_norm (normed_ring.to_is_norm K) f) (hf_na : is_nonarchimedean f)
  (hna : is_nonarchimedean (λ k : K, ∥k∥₊)) :
  f = spectral_norm h_alg  :=
begin
  apply eq_of_pow_mult_faithful (normed_field.to_is_mul_norm K) hf_pow hf_alg_norm
    (spectral_norm.is_pow_mult h_alg hna) (spectral_norm.is_algebra_norm h_alg hna),
  intro x,
  set E : Type* := id K⟮x⟯ with hEdef,
  letI hE : field E := (by rw [hEdef, id.def] ; apply_instance),
  letI : algebra K E := K⟮x⟯.algebra,

  set id1 : K⟮x⟯ →ₗ[K] E :=
  { to_fun := id,
    map_add' := λ x y, rfl,
    map_smul' := λ r x, rfl, },

  set id2 : E →ₗ[K] K⟮x⟯ :=
  { to_fun := id,
    map_add' := λ x y, rfl,
    map_smul' := λ r x, rfl },

  have hs_norm : is_norm (λ y : E, spectral_norm h_alg (id2 y : L)) :=
  { zero := by rw [map_zero, subfield.coe_zero, spectral_norm.zero],
    add  := λ a b, by rw [map_add]; exact (spectral_norm.is_algebra_norm h_alg hna).add _ _,
    mul  := λ a b, by simp only [linear_map.coe_mk, id.def, subfield.coe_mul];
      exact (spectral_norm.is_algebra_norm h_alg hna).mul _ _,
    ne_zero := λ a ha,
    begin
      apply (spectral_norm.is_algebra_norm h_alg hna).ne_zero,
      simp only [linear_map.coe_mk, id.def, ne.def, add_submonoid_class.coe_eq_zero],
      exact ha,
    end},

  have hs_neg : ∀ y : E, spectral_norm h_alg (id2 (-y) : L) = spectral_norm h_alg (id2 y : L),
  { intro y,
    simp only [linear_map.coe_mk, id.def, subfield.coe_neg],
    exact (spectral_norm.is_nonarchimedean h_alg hna).neg (spectral_norm.zero h_alg) _ },

  letI n1 : normed_ring E := norm_to_normed_ring hs_norm hs_neg,

  letI N1 : normed_space K E :=
  { norm_smul_le := λ k y,
    begin
      change (spectral_norm h_alg (id2 (k • y) : L) : ℝ) ≤ ∥ k ∥ * spectral_norm h_alg (id2 y : L),
      simp only [linear_map.coe_mk, id.def, intermediate_field.coe_smul],
      rw (spectral_norm.is_algebra_norm _ hna).smul,
      exact le_refl _,
    end,
    ..K⟮x⟯.algebra },

  have hf_norm : is_norm (λ y, f((algebra_map K⟮x⟯ L) y)) :=
  { zero := by rw [map_zero, hf_alg_norm.zero],
    add  := λ a b, by rw [map_add]; exact hf_alg_norm.add _ _,
    mul  := λ a b, by rw [map_mul]; exact hf_alg_norm.mul _ _,
    ne_zero := λ a ha, hf_alg_norm.ne_zero _ ((ring_hom.map_ne_zero _).mpr ha) },

  have hf_neg : ∀ y, f((algebra_map K⟮x⟯ L) (-y)) = f((algebra_map K⟮x⟯ L) y),
  { intro y,
    rw map_neg, exact hf_na.neg hf_alg_norm.zero _ },

  letI n2 : normed_ring K⟮x⟯ := norm_to_normed_ring hf_norm hf_neg,

  letI N2 : normed_space K K⟮x⟯ :=
  { norm_smul_le :=  λ k y,
    begin
      change (f ((algebra_map K⟮x⟯ L) (k • y)) : ℝ) ≤ ∥ k ∥ * f (algebra_map K⟮x⟯ L y),
      have : (algebra_map ↥K⟮x⟯ L) (k • y) = k • (algebra_map ↥K⟮x⟯ L y),
      { rw [← is_scalar_tower.algebra_map_smul K⟮x⟯ k y, smul_eq_mul, map_mul,
          ← is_scalar_tower.algebra_map_apply K ↥K⟮x⟯ L, algebra.smul_def] },
      rw [this, hf_alg_norm.smul],
      exact le_refl _,
    end,
    ..K⟮x⟯.algebra },

  haveI hKx_fin : finite_dimensional K ↥K⟮x⟯ := intermediate_field.adjoin.finite_dimensional
    (is_algebraic_iff_is_integral.mp (h_alg x)),
  haveI : finite_dimensional K E := hKx_fin,

  set Id1 : K⟮x⟯ →L[K] E := ⟨id1, id1.continuous_of_finite_dimensional⟩ with hId1,
  set Id2 : E →L[K] K⟮x⟯ := ⟨id2, id2.continuous_of_finite_dimensional⟩ with hId2,

  have hC1 : ∃ (C1 : ℝ), 0 < C1 ∧ ∀ (y : K⟮x⟯), ∥id1 y∥ ≤ C1 * ∥y∥ := Id1.is_bounded_linear_map.bound,
  have hC2 : ∃ (C2 : ℝ), 0 < C2 ∧ ∀ (y : E), ∥id2 y∥ ≤ C2 * ∥y∥ := Id2.is_bounded_linear_map.bound,

  obtain ⟨C1, hC1_pos, hC1⟩ := hC1,
  obtain ⟨C2, hC2_pos, hC2⟩ := hC2,
  use [⟨C2, le_of_lt hC2_pos⟩, ⟨C1, le_of_lt hC1_pos⟩, hC2_pos, hC1_pos],
  rw forall_and_distrib,
  --simp only at hC1 hC2,
  split,
  { intro y, exact hC2 ⟨y, (intermediate_field.algebra_adjoin_le_adjoin K _) y.2⟩ },
  { intro y, exact hC1 ⟨y, (intermediate_field.algebra_adjoin_le_adjoin K _) y.2⟩ },

end

lemma spectral_norm.unique_field_norm_ext {f : L → nnreal}
  (hf_field_norm : is_mul_norm f) (hf_ext : function_extends (λ x : K, ∥x∥₊) f)
  (hf_na : is_nonarchimedean f) (hna : is_nonarchimedean (λ k : K, ∥k∥₊)) (x : L) :
  f x = spectral_norm h_alg x :=
begin
  have hf_pow : is_pow_mult f := is_mul_norm.to_is_pow_mult hf_field_norm,
  have hf_alg_norm : is_algebra_norm (normed_ring.to_is_norm K) f :=
  { smul := λ k x, by rw [algebra.smul_def, hf_field_norm.mul_eq, hf_ext k],
    ..hf_field_norm},
  rw spectral_norm.unique' h_alg hf_pow hf_alg_norm hf_na hna
end

lemma spectral_norm.is_mul_norm (hna : is_nonarchimedean (λ k : K, ∥k∥₊)) :
  is_mul_norm (spectral_norm h_alg) :=
{ mul_eq := λ x y, begin
    by_cases hx : 0 = spectral_norm h_alg x,
    { rw [← hx, zero_mul],
      rw [eq_comm, (spectral_norm.is_algebra_norm h_alg hna).to_is_norm.zero_iff] at hx,
      rw [hx, zero_mul, (spectral_norm.is_algebra_norm h_alg hna).to_is_norm.zero] },
    { set f := c_seminorm (spectral_norm.is_norm_le_one_class h_alg) hx
        (spectral_norm.is_algebra_norm h_alg hna).to_is_norm.to_is_seminorm
        (spectral_norm.is_pow_mult h_alg hna) with hf,
      have hf_pow : is_pow_mult f := c_seminorm_is_pow_mult (spectral_norm.is_norm_le_one_class
        h_alg) hx (spectral_norm.is_algebra_norm h_alg hna).to_is_norm.to_is_seminorm
        (spectral_norm.is_pow_mult h_alg hna),
      have hf_alg_norm : is_algebra_norm (normed_ring.to_is_norm K) f :=
      { smul := λ k y,
        begin
          rw [← spectral_norm.extends h_alg, algebra.smul_def, hf],
          have h_mul : ∀ (y : L), spectral_norm h_alg ((algebra_map K L k) * y) =
            spectral_norm h_alg (algebra_map K L k) * spectral_norm h_alg y,
          { intro y, rw [spectral_norm.extends h_alg, ← algebra.smul_def],
            exact (spectral_norm.is_algebra_norm h_alg hna).smul _ _ },
          rw ← c_seminorm_apply_of_is_mult _ _ _ _ h_mul,
          exact c_seminorm_is_mult_of_is_mult _ _ _ _ h_mul _,
        end,
        ..(c_seminorm_is_norm _ _ _ _ _) },
      have hf_na : is_nonarchimedean f :=
      c_seminorm_is_nonarchimedean _ _ _ _ (spectral_norm.is_nonarchimedean h_alg hna),
      rw [← spectral_norm.unique' h_alg hf_pow hf_alg_norm hf_na hna],
      rw [hf, c_seminorm_c_is_mult (spectral_norm.is_norm_le_one_class h_alg) hx
        (spectral_norm.is_algebra_norm h_alg hna).to_is_norm.to_is_seminorm
        (spectral_norm.is_pow_mult h_alg hna)] }
  end
  ..spectral_norm.is_algebra_norm h_alg hna }

def spectral_norm.normed_field (h : is_nonarchimedean (λ k : K, ∥k∥₊)) : normed_field L :=
{ norm      := λ (x : L), (spectral_norm h_alg x : ℝ),
  dist      := λ (x y : L), (spectral_norm h_alg (x - y) : ℝ),
  dist_self := λ x, by simp only [sub_self, nnreal.coe_eq_zero, spectral_norm.zero],
  dist_comm := λ x y, by rw [nnreal.coe_eq, ← neg_sub, spectral_norm.neg h_alg h],
  dist_triangle := λ x y z, begin
    simp only [dist_eq_norm],
    rw ← sub_add_sub_cancel x y z,
    exact add_le_of_is_nonarchimedean (spectral_norm.zero h_alg)
      (spectral_norm.is_nonarchimedean h_alg h) _ _,
  end,
  eq_of_dist_eq_zero := λ x y hxy,
  begin
    simp only [nnreal.coe_eq_zero] at hxy,
    rw ← sub_eq_zero,
    rw is_norm.zero_iff (spectral_norm.is_mul_norm h_alg h).to_is_norm at hxy,
    exact hxy,
  end,
  dist_eq := λ x y, by refl,
  norm_mul' := λ x y,
  begin
    simp only [← nnreal.coe_mul, nnreal.coe_eq],
    exact (spectral_norm.is_mul_norm h_alg h).mul_eq x y,
  end,
  ..hL }

/- noncomputable! instance us : uniform_space L := infer_instance

instance spectral_norm.complete_space (h_fin : @finite_dimensional K L _ _ _) :
  complete_space L := sorry -/


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

import topology.sheaves.sheaf_condition.sites
import category_theory.limits.preserves.basic
import category_theory.category.pairwise
import category_theory.limits.constructions.binary_products

/-!
# Equivalent formulations of the sheaf condition

We give an equivalent formulation of the sheaf condition.

Given any indexed type `ι`, we define `overlap ι`,
a category with objects corresponding to
* individual open sets, `single i`, and
* intersections of pairs of open sets, `pair i j`,
with morphisms from `pair i j` to both `single i` and `single j`.

Any open cover `U : ι → opens X` provides a functor `diagram U : overlap ι ⥤ (opens X)ᵒᵖ`.

There is a canonical cone over this functor, `cone U`, whose cone point is `supr U`,
and in fact this is a limit cone.

A presheaf `F : presheaf C X` is a sheaf precisely if it preserves this limit.
We express this in two equivalent ways, as
* `is_limit (F.map_cone (cone U))`, or
* `preserves_limit (diagram U) F`
-/

noncomputable theory

universes v u

open topological_space
open Top
open opposite
open category_theory
open category_theory.limits

namespace Top.presheaf

variables {X : Top.{v}}

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

/--
An alternative formulation of the sheaf condition
(which we prove equivalent to the usual one below as
`is_sheaf_iff_is_sheaf_pairwise_intersections`).

A presheaf is a sheaf if `F` sends the cone `(pairwise.cocone U).op` to a limit cone.
(Recall `pairwise.cocone U` has cone point `supr U`, mapping down to the `U i` and the `U i ⊓ U j`.)
-/
def is_sheaf_pairwise_intersections (F : presheaf C X) : Prop :=
∀ ⦃ι : Type v⦄ (U : ι → opens X), nonempty (is_limit (F.map_cone (pairwise.cocone U).op))

/--
An alternative formulation of the sheaf condition
(which we prove equivalent to the usual one below as
`is_sheaf_iff_is_sheaf_preserves_limit_pairwise_intersections`).

A presheaf is a sheaf if `F` preserves the limit of `pairwise.diagram U`.
(Recall `pairwise.diagram U` is the diagram consisting of the pairwise intersections
`U i ⊓ U j` mapping into the open sets `U i`. This diagram has limit `supr U`.)
-/
def is_sheaf_preserves_limit_pairwise_intersections (F : presheaf C X) : Prop :=
∀ ⦃ι : Type v⦄ (U : ι → opens X), nonempty (preserves_limit (pairwise.diagram U).op F)

/-!
The remainder of this file shows that these conditions are equivalent
to the usual sheaf condition.
-/

variables [has_products C]

namespace sheaf_condition_pairwise_intersections

open category_theory.pairwise category_theory.pairwise.hom
open sheaf_condition_equalizer_products

/-- Implementation of `sheaf_condition_pairwise_intersections.cone_equiv`. -/
@[simps]
def cone_equiv_functor_obj (F : presheaf C X)
  ⦃ι : Type v⦄ (U : ι → opens ↥X) (c : limits.cone ((diagram U).op ⋙ F)) :
  limits.cone (sheaf_condition_equalizer_products.diagram F U) :=
{ X := c.X,
  π :=
  { app := λ Z,
      walking_parallel_pair.cases_on Z
        (pi.lift (λ (i : ι), c.π.app (op (single i))))
        (pi.lift (λ (b : ι × ι), c.π.app (op (pair b.1 b.2)))),
    naturality' := λ Y Z f,
    begin
      cases Y; cases Z; cases f,
      { ext i, dsimp,
        simp only [limit.lift_π, category.id_comp, fan.mk_π_app, category_theory.functor.map_id,
          category.assoc],
        dsimp,
        simp only [limit.lift_π, category.id_comp, fan.mk_π_app], },
      { ext ⟨i, j⟩, dsimp [sheaf_condition_equalizer_products.left_res],
        simp only [limit.lift_π, limit.lift_π_assoc, category.id_comp, fan.mk_π_app,
          category.assoc],
        have h := c.π.naturality (quiver.hom.op (hom.left i j)),
        dsimp at h,
        simpa using h, },
      { ext ⟨i, j⟩, dsimp [sheaf_condition_equalizer_products.right_res],
        simp only [limit.lift_π, limit.lift_π_assoc, category.id_comp, fan.mk_π_app,
          category.assoc],
        have h := c.π.naturality (quiver.hom.op (hom.right i j)),
        dsimp at h,
        simpa using h, },
      { ext i, dsimp,
        simp only [limit.lift_π, category.id_comp, fan.mk_π_app, category_theory.functor.map_id,
          category.assoc],
        dsimp,
        simp only [limit.lift_π, category.id_comp, fan.mk_π_app], },
    end, }, }

section
local attribute [tidy] tactic.case_bash

/-- Implementation of `sheaf_condition_pairwise_intersections.cone_equiv`. -/
@[simps]
def cone_equiv_functor (F : presheaf C X)
  ⦃ι : Type v⦄ (U : ι → opens ↥X) :
  limits.cone ((diagram U).op ⋙ F) ⥤
    limits.cone (sheaf_condition_equalizer_products.diagram F U) :=
{ obj := λ c, cone_equiv_functor_obj F U c,
  map := λ c c' f,
  { hom := f.hom,
    w' := λ j, begin
      cases j;
      { ext, simp only [limits.fan.mk_π_app, limits.cone_morphism.w,
        limits.limit.lift_π, category.assoc, cone_equiv_functor_obj_π_app], },
    end }, }.

end

/-- Implementation of `sheaf_condition_pairwise_intersections.cone_equiv`. -/
@[simps]
def cone_equiv_inverse_obj (F : presheaf C X)
  ⦃ι : Type v⦄ (U : ι → opens ↥X)
  (c : limits.cone (sheaf_condition_equalizer_products.diagram F U)) :
  limits.cone ((diagram U).op ⋙ F) :=
{ X := c.X,
  π :=
  { app :=
    begin
      intro x,
      induction x using opposite.rec,
      rcases x with (⟨i⟩|⟨i,j⟩),
      { exact c.π.app (walking_parallel_pair.zero) ≫ pi.π _ i, },
      { exact c.π.app (walking_parallel_pair.one) ≫ pi.π _ (i, j), }
    end,
    naturality' :=
    begin
      intros x y f,
      induction x using opposite.rec,
      induction y using opposite.rec,
      have ef : f = f.unop.op := rfl,
      revert ef,
      generalize : f.unop = f',
      rintro rfl,
      rcases x with ⟨i⟩|⟨⟩; rcases y with ⟨⟩|⟨j,j⟩; rcases f' with ⟨⟩,
      { dsimp, erw [F.map_id], simp, },
      { dsimp, simp only [category.id_comp, category.assoc],
        have h := c.π.naturality (walking_parallel_pair_hom.left),
        dsimp [sheaf_condition_equalizer_products.left_res] at h,
        simp only [category.id_comp] at h,
        have h' := h =≫ pi.π _ (i, j),
        rw h',
        simp,
        refl, },
      { dsimp, simp only [category.id_comp, category.assoc],
        have h := c.π.naturality (walking_parallel_pair_hom.right),
        dsimp [sheaf_condition_equalizer_products.right_res] at h,
        simp only [category.id_comp] at h,
        have h' := h =≫ pi.π _ (j, i),
        rw h',
        simp,
        refl, },
      { dsimp, erw [F.map_id], simp, },
    end, }, }

/-- Implementation of `sheaf_condition_pairwise_intersections.cone_equiv`. -/
@[simps]
def cone_equiv_inverse (F : presheaf C X)
  ⦃ι : Type v⦄ (U : ι → opens ↥X) :
  limits.cone (sheaf_condition_equalizer_products.diagram F U) ⥤
    limits.cone ((diagram U).op ⋙ F) :=
{ obj := λ c, cone_equiv_inverse_obj F U c,
  map := λ c c' f,
  { hom := f.hom,
    w' :=
    begin
      intro x,
      induction x using opposite.rec,
      rcases x with (⟨i⟩|⟨i,j⟩),
      { dsimp,
        rw [←(f.w walking_parallel_pair.zero), category.assoc], },
      { dsimp,
        rw [←(f.w walking_parallel_pair.one), category.assoc], },
    end }, }.

/-- Implementation of `sheaf_condition_pairwise_intersections.cone_equiv`. -/
@[simps]
def cone_equiv_unit_iso_app (F : presheaf C X) ⦃ι : Type v⦄ (U : ι → opens ↥X)
  (c : cone ((diagram U).op ⋙ F)) :
  (𝟭 (cone ((diagram U).op ⋙ F))).obj c ≅
    (cone_equiv_functor F U ⋙ cone_equiv_inverse F U).obj c :=
{ hom :=
  { hom := 𝟙 _,
    w' := λ j, begin
      induction j using opposite.rec, rcases j;
      { dsimp, simp only [limits.fan.mk_π_app, category.id_comp, limits.limit.lift_π], }
    end, },
  inv :=
  { hom := 𝟙 _,
    w' := λ j, begin
      induction j using opposite.rec, rcases j;
      { dsimp, simp only [limits.fan.mk_π_app, category.id_comp, limits.limit.lift_π], }
    end },
  hom_inv_id' := begin
    ext,
    simp only [category.comp_id, limits.cone.category_comp_hom, limits.cone.category_id_hom],
  end,
  inv_hom_id' := begin
    ext,
    simp only [category.comp_id, limits.cone.category_comp_hom, limits.cone.category_id_hom],
  end, }

/-- Implementation of `sheaf_condition_pairwise_intersections.cone_equiv`. -/
@[simps]
def cone_equiv_unit_iso (F : presheaf C X) ⦃ι : Type v⦄ (U : ι → opens X) :
  𝟭 (limits.cone ((diagram U).op ⋙ F)) ≅
    cone_equiv_functor F U ⋙ cone_equiv_inverse F U :=
nat_iso.of_components (cone_equiv_unit_iso_app F U) (by tidy)

/-- Implementation of `sheaf_condition_pairwise_intersections.cone_equiv`. -/
@[simps]
def cone_equiv_counit_iso (F : presheaf C X) ⦃ι : Type v⦄ (U : ι → opens X) :
  cone_equiv_inverse F U ⋙ cone_equiv_functor F U ≅
    𝟭 (limits.cone (sheaf_condition_equalizer_products.diagram F U)) :=
nat_iso.of_components (λ c,
{ hom :=
  { hom := 𝟙 _,
    w' :=
    begin
      rintro ⟨_|_⟩,
      { ext, dsimp, simp only [category.id_comp, limits.fan.mk_π_app, limits.limit.lift_π], },
      { ext ⟨i,j⟩, dsimp, simp only [category.id_comp, limits.fan.mk_π_app, limits.limit.lift_π], },
    end },
  inv :=
  { hom := 𝟙 _,
    w' :=
    begin
      rintro ⟨_|_⟩,
      { ext, dsimp, simp only [category.id_comp, limits.fan.mk_π_app, limits.limit.lift_π], },
      { ext ⟨i,j⟩, dsimp, simp only [category.id_comp, limits.fan.mk_π_app, limits.limit.lift_π], },
    end, },
  hom_inv_id' := by { ext, dsimp, simp only [category.comp_id], },
  inv_hom_id' := by { ext, dsimp, simp only [category.comp_id], }, })
(λ c d f, by { ext, dsimp, simp only [category.comp_id, category.id_comp], })

/--
Cones over `diagram U ⋙ F` are the same as a cones over the usual sheaf condition equalizer diagram.
-/
@[simps]
def cone_equiv (F : presheaf C X) ⦃ι : Type v⦄ (U : ι → opens X) :
  limits.cone ((diagram U).op ⋙ F) ≌ limits.cone (sheaf_condition_equalizer_products.diagram F U) :=
{ functor := cone_equiv_functor F U,
  inverse := cone_equiv_inverse F U,
  unit_iso := cone_equiv_unit_iso F U,
  counit_iso := cone_equiv_counit_iso F U, }

local attribute [reducible]
  sheaf_condition_equalizer_products.res
  sheaf_condition_equalizer_products.left_res

/--
If `sheaf_condition_equalizer_products.fork` is an equalizer,
then `F.map_cone (cone U)` is a limit cone.
-/
def is_limit_map_cone_of_is_limit_sheaf_condition_fork
  (F : presheaf C X) ⦃ι : Type v⦄ (U : ι → opens X)
  (P : is_limit (sheaf_condition_equalizer_products.fork F U)) :
  is_limit (F.map_cone (cocone U).op) :=
is_limit.of_iso_limit ((is_limit.of_cone_equiv (cone_equiv F U).symm).symm P)
{ hom :=
  { hom := 𝟙 _,
    w' :=
    begin
      intro x,
      induction x using opposite.rec,
      rcases x with ⟨⟩,
      { dsimp, simp, refl, },
      { dsimp,
        simp only [limit.lift_π, limit.lift_π_assoc, category.id_comp, fan.mk_π_app,
          category.assoc],
        rw ←F.map_comp,
        refl, }
    end },
  inv :=
  { hom := 𝟙 _,
    w' :=
    begin
      intro x,
      induction x using opposite.rec,
      rcases x with ⟨⟩,
      { dsimp, simp, refl, },
      { dsimp,
        simp only [limit.lift_π, limit.lift_π_assoc, category.id_comp, fan.mk_π_app,
          category.assoc],
        rw ←F.map_comp,
        refl, }
    end },
  hom_inv_id' := by { ext, dsimp, simp only [category.comp_id], },
  inv_hom_id' := by { ext, dsimp, simp only [category.comp_id], }, }

/--
If `F.map_cone (cone U)` is a limit cone,
then `sheaf_condition_equalizer_products.fork` is an equalizer.
-/
def is_limit_sheaf_condition_fork_of_is_limit_map_cone
  (F : presheaf C X) ⦃ι : Type v⦄ (U : ι → opens X)
  (Q : is_limit (F.map_cone (cocone U).op)) :
  is_limit (sheaf_condition_equalizer_products.fork F U) :=
is_limit.of_iso_limit ((is_limit.of_cone_equiv (cone_equiv F U)).symm Q)
{ hom :=
  { hom := 𝟙 _,
    w' :=
    begin
      rintro ⟨⟩,
      { dsimp, simp, refl, },
      { dsimp, ext ⟨i, j⟩,
        simp only [limit.lift_π, limit.lift_π_assoc, category.id_comp, fan.mk_π_app,
          category.assoc],
        rw ←F.map_comp,
        refl, }
    end },
  inv :=
  { hom := 𝟙 _,
    w' :=
    begin
      rintro ⟨⟩,
      { dsimp, simp, refl, },
      { dsimp, ext ⟨i, j⟩,
        simp only [limit.lift_π, limit.lift_π_assoc, category.id_comp, fan.mk_π_app,
          category.assoc],
        rw ←F.map_comp,
        refl, }
    end },
  hom_inv_id' := by { ext, dsimp, simp only [category.comp_id], },
  inv_hom_id' := by { ext, dsimp, simp only [category.comp_id], }, }

end sheaf_condition_pairwise_intersections

open sheaf_condition_pairwise_intersections

/--
The sheaf condition in terms of an equalizer diagram is equivalent
to the reformulation in terms of a limit diagram over `U i` and `U i ⊓ U j`.
-/
lemma is_sheaf_iff_is_sheaf_pairwise_intersections (F : presheaf C X) :
  F.is_sheaf ↔ F.is_sheaf_pairwise_intersections :=
iff.intro (λ h ι U, ⟨is_limit_map_cone_of_is_limit_sheaf_condition_fork F U (h U).some⟩)
  (λ h ι U, ⟨is_limit_sheaf_condition_fork_of_is_limit_map_cone F U (h U).some⟩)

/--
The sheaf condition in terms of an equalizer diagram is equivalent
to the reformulation in terms of the presheaf preserving the limit of the diagram
consisting of the `U i` and `U i ⊓ U j`.
-/
lemma is_sheaf_iff_is_sheaf_preserves_limit_pairwise_intersections (F : presheaf C X) :
  F.is_sheaf ↔ F.is_sheaf_preserves_limit_pairwise_intersections :=
begin
  rw is_sheaf_iff_is_sheaf_pairwise_intersections,
  split,
  { intros h ι U,
    exact ⟨preserves_limit_of_preserves_limit_cone (pairwise.cocone_is_colimit U).op (h U).some⟩ },
  { intros h ι U,
    haveI := (h U).some,
    exact ⟨preserves_limit.preserves (pairwise.cocone_is_colimit U).op⟩ }
end

end Top.presheaf

namespace Top.sheaf

variables {X : Top.{v}} {C : Type u} [category.{v} C] [has_products C]
variables (F : X.sheaf C) (U V : opens X)
open category_theory.limits

/-- For a sheaf `F`, `F(U ∪ V)` is the pullback of `F(U) ⟶ F(U ∩ V)` and `F(V) ⟶ F(U ∩ V)`.
This is the pullback cone. -/
def inter_union_pullback_cone : pullback_cone
  (F.1.map (hom_of_le inf_le_left : U ∩ V ⟶ _).op) (F.1.map (hom_of_le inf_le_right).op) :=
pullback_cone.mk (F.1.map (hom_of_le le_sup_left).op) (F.1.map (hom_of_le le_sup_right).op)
  (by { rw [← F.1.map_comp, ← F.1.map_comp], congr })

@[simp] lemma inter_union_pullback_cone_X :
  (inter_union_pullback_cone F U V).X = F.1.obj (op $ U ∪ V) := rfl
@[simp] lemma inter_union_pullback_cone_fst :
  (inter_union_pullback_cone F U V).fst = F.1.map (hom_of_le le_sup_left).op := rfl
@[simp] lemma inter_union_pullback_cone_snd :
  (inter_union_pullback_cone F U V).snd = F.1.map (hom_of_le le_sup_right).op := rfl

variable (s : pullback_cone
  (F.1.map (hom_of_le inf_le_left : U ∩ V ⟶ _).op) (F.1.map (hom_of_le inf_le_right).op))

/-- (Implementation).
Every cone over `F(U) ⟶ F(U ∩ V)` and `F(V) ⟶ F(U ∩ V)` factors through `F(U ∪ V)`. -/
def inter_union_pullback_cone_lift : s.X ⟶ F.1.obj (op (U ∪ V)) :=
begin
  let ι : walking_pair → opens X := λ j, walking_pair.cases_on j U V,
  have hι : U ∪ V = supr ι,
  { ext, split,
    { rintros (h|h),
    exacts [⟨_,⟨_,⟨walking_pair.left,rfl⟩,rfl⟩,h⟩, ⟨_,⟨_,⟨walking_pair.right,rfl⟩,rfl⟩,h⟩] },
    { rintros ⟨_,⟨_,⟨⟨⟩,⟨⟩⟩,⟨⟩⟩,z⟩, exacts [or.inl z, or.inr z] } },
  refine (F.1.is_sheaf_iff_is_sheaf_pairwise_intersections.mp F.2 ι).some.lift
    ⟨s.X, { app := _, naturality' := _ }⟩ ≫ F.1.map (eq_to_hom hι).op,
  { apply opposite.rec,
    rintro ((_|_)|(_|_)),
    exacts [s.fst, s.snd, s.fst ≫ F.1.map (hom_of_le inf_le_left).op,
      s.snd ≫ F.1.map (hom_of_le inf_le_left).op] },
  rintros i j f,
  induction i using opposite.rec,
  induction j using opposite.rec,
  let g : j ⟶ i := f.unop, have : f = g.op := rfl, clear_value g, subst this,
  rcases i with ((_|_)|(_|_)); rcases j with ((_|_)|(_|_)); rcases g; dsimp;
    simp only [category.id_comp, s.condition, category_theory.functor.map_id, category.comp_id],
  { rw [← cancel_mono (F.1.map (eq_to_hom $ inf_comm : U ∩ V ⟶ _).op), category.assoc,
      category.assoc],
    erw [← F.1.map_comp, ← F.1.map_comp],
    convert s.condition.symm },
  { convert s.condition }
end

lemma inter_union_pullback_cone_lift_left :
  inter_union_pullback_cone_lift F U V s ≫ F.1.map (hom_of_le le_sup_left).op = s.fst :=
begin
  erw [category.assoc, ←F.1.map_comp],
  exact (F.1.is_sheaf_iff_is_sheaf_pairwise_intersections.mp F.2 _).some.fac _
    (op $ pairwise.single walking_pair.left)
end

lemma inter_union_pullback_cone_lift_right :
  inter_union_pullback_cone_lift F U V s ≫ F.1.map (hom_of_le le_sup_right).op = s.snd :=
begin
  erw [category.assoc, ←F.1.map_comp],
  exact (F.1.is_sheaf_iff_is_sheaf_pairwise_intersections.mp F.2 _).some.fac _
    (op $ pairwise.single walking_pair.right)
end

/-- For a sheaf `F`, `F(U ∪ V)` is the pullback of `F(U) ⟶ F(U ∩ V)` and `F(V) ⟶ F(U ∩ V)`. -/
def is_limit_pullback_cone : is_limit (inter_union_pullback_cone F U V) :=
begin
  let ι : walking_pair → opens X := λ j, walking_pair.cases_on j U V,
  have hι : U ∪ V = supr ι,
  { ext, split,
    { rintros (h|h),
    exacts [⟨_,⟨_,⟨walking_pair.left,rfl⟩,rfl⟩,h⟩, ⟨_,⟨_,⟨walking_pair.right,rfl⟩,rfl⟩,h⟩] },
    { rintros ⟨_,⟨_,⟨⟨⟩,⟨⟩⟩,⟨⟩⟩,z⟩, exacts [or.inl z, or.inr z] } },
  apply pullback_cone.is_limit_aux',
  intro s,
  use inter_union_pullback_cone_lift F U V s,
  refine ⟨_,_,_⟩,
  { apply inter_union_pullback_cone_lift_left },
  { apply inter_union_pullback_cone_lift_right },
  { intros m h₁ h₂,
    rw ← cancel_mono (F.1.map (eq_to_hom hι.symm).op),
    apply (F.1.is_sheaf_iff_is_sheaf_pairwise_intersections.mp F.2 ι).some.hom_ext,
    apply opposite.rec,
    rintro ((_|_)|(_|_)); rw [category.assoc, category.assoc],
    { erw ← F.1.map_comp,
      convert h₁,
      apply inter_union_pullback_cone_lift_left },
    { erw ← F.1.map_comp,
      convert h₂,
      apply inter_union_pullback_cone_lift_right },
    all_goals
    { dsimp only [functor.op, pairwise.cocone_ι_app, functor.map_cone_π_app,
        cocone.op, pairwise.cocone_ι_app_2, unop_op, op_comp],
      simp_rw [F.1.map_comp, ← category.assoc],
      congr' 1,
      simp_rw [category.assoc, ← F.1.map_comp] },
    { convert h₁,
      apply inter_union_pullback_cone_lift_left },
    { convert h₂,
      apply inter_union_pullback_cone_lift_right } }
end

/-- If `U, V` are disjoint, then `F(U ∪ V) = F(U) × F(V)`. -/
def is_product_of_disjoint (h : U ∩ V = ⊥) : is_limit
    (binary_fan.mk (F.1.map (hom_of_le le_sup_left : _ ⟶ U ⊔ V).op)
      (F.1.map (hom_of_le le_sup_right : _ ⟶ U ⊔ V).op)) :=
is_product_of_is_terminal_is_pullback _ _ _ _
  (F.is_terminal_of_eq_empty h) (is_limit_pullback_cone F U V)

end Top.sheaf


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.monoidal.braided
import category_theory.functor.category
import category_theory.functor.const

/-!
# Monoidal structure on `C ⥤ D` when `D` is monoidal.

When `C` is any category, and `D` is a monoidal category,
there is a natural "pointwise" monoidal structure on `C ⥤ D`.

The initial intended application is tensor product of presheaves.
-/

universes v₁ v₂ u₁ u₂

open category_theory
open category_theory.monoidal_category

namespace category_theory.monoidal

variables {C : Type u₁} [category.{v₁} C]
variables {D : Type u₂} [category.{v₂} D] [monoidal_category.{v₂} D]

namespace functor_category

variables (F G F' G' : C ⥤ D)

/--
(An auxiliary definition for `functor_category_monoidal`.)
Tensor product of functors `C ⥤ D`, when `D` is monoidal.
 -/
@[simps]
def tensor_obj : C ⥤ D :=
{ obj := λ X, F.obj X ⊗ G.obj X,
  map := λ X Y f, F.map f ⊗ G.map f,
  map_id' := λ X, by rw [F.map_id, G.map_id, tensor_id],
  map_comp' := λ X Y Z f g, by rw [F.map_comp, G.map_comp, tensor_comp], }

variables {F G F' G'}
variables (α : F ⟶ G) (β : F' ⟶ G')

/--
(An auxiliary definition for `functor_category_monoidal`.)
Tensor product of natural transformations into `D`, when `D` is monoidal.
-/
@[simps]
def tensor_hom : tensor_obj F F' ⟶ tensor_obj G G' :=
{ app := λ X, α.app X ⊗ β.app X,
  naturality' :=
  λ X Y f, by { dsimp, rw [←tensor_comp, α.naturality, β.naturality, tensor_comp], } }

end functor_category

open category_theory.monoidal.functor_category

/--
When `C` is any category, and `D` is a monoidal category,
the functor category `C ⥤ D` has a natural pointwise monoidal structure,
where `(F ⊗ G).obj X = F.obj X ⊗ G.obj X`.
-/
instance functor_category_monoidal : monoidal_category (C ⥤ D) :=
{ tensor_obj := λ F G, tensor_obj F G,
  tensor_hom := λ F G F' G' α β, tensor_hom α β,
  tensor_id' := λ F G, by { ext, dsimp, rw [tensor_id], },
  tensor_comp' := λ F G H F' G' H' α β γ δ, by { ext, dsimp, rw [tensor_comp], },
  tensor_unit := (category_theory.functor.const C).obj (𝟙_ D),
  left_unitor :=  λ F,
    nat_iso.of_components (λ X, λ_ (F.obj X)) (λ X Y f, by { dsimp, rw left_unitor_naturality, }),
  right_unitor := λ F,
    nat_iso.of_components (λ X, ρ_ (F.obj X)) (λ X Y f, by { dsimp, rw right_unitor_naturality, }),
  associator := λ F G H,
    nat_iso.of_components
      (λ X, α_ (F.obj X) (G.obj X) (H.obj X)) (λ X Y f, by { dsimp, rw associator_naturality, }),
  left_unitor_naturality' := λ F G α, by { ext X, dsimp, rw left_unitor_naturality, },
  right_unitor_naturality' := λ F G α, by { ext X, dsimp, rw right_unitor_naturality, },
  associator_naturality' := λ F G H F' G' H' α β γ, by { ext X, dsimp, rw associator_naturality, },
  triangle' := λ F G, begin ext X, dsimp, rw triangle, end,
  pentagon' := λ F G H K, begin ext X, dsimp, rw pentagon, end, }

@[simp]
lemma tensor_unit_obj {X} : (𝟙_ (C ⥤ D)).obj X = 𝟙_ D := rfl

@[simp]
lemma tensor_unit_map {X Y} {f : X ⟶ Y} : (𝟙_ (C ⥤ D)).map f = 𝟙 (𝟙_ D) := rfl

@[simp]
lemma tensor_obj_obj {F G : C ⥤ D} {X} : (F ⊗ G).obj X = F.obj X ⊗ G.obj X := rfl

@[simp]
lemma tensor_obj_map {F G : C ⥤ D} {X Y} {f : X ⟶ Y} : (F ⊗ G).map f = F.map f ⊗ G.map f := rfl

@[simp]
lemma tensor_hom_app {F G F' G' : C ⥤ D} {α : F ⟶ G} {β : F' ⟶ G'} {X} :
  (α ⊗ β).app X = α.app X ⊗ β.app X := rfl

@[simp]
lemma left_unitor_hom_app {F : C ⥤ D} {X} :
  ((λ_ F).hom : (𝟙_ _) ⊗ F ⟶ F).app X = (λ_ (F.obj X)).hom := rfl

@[simp]
lemma left_unitor_inv_app {F : C ⥤ D} {X} :
  ((λ_ F).inv : F ⟶ (𝟙_ _) ⊗ F).app X = (λ_ (F.obj X)).inv := rfl

@[simp]
lemma right_unitor_hom_app {F : C ⥤ D} {X} :
  ((ρ_ F).hom : F ⊗ (𝟙_ _) ⟶ F).app X = (ρ_ (F.obj X)).hom := rfl

@[simp]
lemma right_unitor_inv_app {F : C ⥤ D} {X} :
  ((ρ_ F).inv : F ⟶ F ⊗ (𝟙_ _)).app X = (ρ_ (F.obj X)).inv := rfl

@[simp]
lemma associator_hom_app {F G H : C ⥤ D} {X} :
  ((α_ F G H).hom : (F ⊗ G) ⊗ H ⟶ F ⊗ (G ⊗ H)).app X = (α_ (F.obj X) (G.obj X) (H.obj X)).hom :=
rfl

@[simp]
lemma associator_inv_app {F G H : C ⥤ D} {X} :
  ((α_ F G H).inv : F ⊗ (G ⊗ H) ⟶ (F ⊗ G) ⊗ H).app X = (α_ (F.obj X) (G.obj X) (H.obj X)).inv :=
rfl

section braided_category

open category_theory.braided_category
variables [braided_category.{v₂} D]

/--
When `C` is any category, and `D` is a braided monoidal category,
the natural pointwise monoidal structure on the functor category `C ⥤ D`
is also braided.
-/
instance functor_category_braided : braided_category (C ⥤ D) :=
{ braiding := λ F G, nat_iso.of_components (λ X, β_ _ _) (by tidy),
  hexagon_forward' := λ F G H, by { ext X, apply hexagon_forward, },
  hexagon_reverse' := λ F G H, by { ext X, apply hexagon_reverse, }, }

example : braided_category (C ⥤ D) := category_theory.monoidal.functor_category_braided

end braided_category

section symmetric_category

open category_theory.symmetric_category
variables [symmetric_category.{v₂} D]

/--
When `C` is any category, and `D` is a symmetric monoidal category,
the natural pointwise monoidal structure on the functor category `C ⥤ D`
is also symmetric.
-/
instance functor_category_symmetric : symmetric_category (C ⥤ D) :=
{ symmetry' := λ F G, by { ext X, apply symmetry, },}

end symmetric_category

end category_theory.monoidal


import Mathlib.Tactic.Basic
import Mathlib.Data.Nat.Basic
import Mathlib.Init.Algebra.Order
import Mathlib.Init.Data.Nat.Basic
import Mathlib.Init.Data.Nat.Lemmas
import Mathlib.Data.String.Defs
import Mathlib.Data.String.Lemmas
import Mathlib.Data.Equiv.Basic
import Mathlib.Init.Function
import Timelib.Util
import Timelib.NanoPrecision.TimeZone.Basic
import Timelib.NanoPrecision.Duration.UnsignedDuration
import Timelib.NanoPrecision.Duration.SignedDuration
import Timelib.NanoPrecision.ClockTime.ClockTime

structure HClockTime where
  timeZone : TimeZone
  clockTime : ClockTime timeZone

def HClockTime.EquivSigma : Equiv HClockTime (Sigma ClockTime) := {
  toFun := fun oct => ⟨oct.timeZone, oct.clockTime⟩
  invFun := fun sig => ⟨sig.fst, sig.snd⟩
  left_inv := by simp [Function.LeftInverse]
  right_inv := by simp [Function.RightInverse, Function.LeftInverse]
}

section HClockTimeStuff

variable (t : HClockTime)

@[reducible]
def HClockTime.simultaneous : HClockTime → HClockTime → Prop
| ⟨_, ⟨naive_t₁⟩⟩, ⟨_, ⟨naive_t₂⟩⟩ => naive_t₁ = naive_t₂

def HClockTime.simultaneous.equivalence : Equivalence HClockTime.simultaneous :=  {
  refl := fun d => rfl
  symm := fun h => h.symm
  trans := fun h h' => Eq.trans h h'
}

instance instHClockTimeSetoid : Setoid HClockTime := ⟨HClockTime.simultaneous, HClockTime.simultaneous.equivalence⟩

instance : Inhabited <| HClockTime := ⟨TimeZone.UTC, Inhabited.default⟩

def HClockTime.nanoComponent : Nat := t.clockTime.nanoComponent
def HClockTime.secondComponent : Nat := t.clockTime.secondComponent
def HClockTime.minuteComponent : Nat := t.clockTime.minuteComponent
def HClockTime.hourComponent : Nat := t.clockTime.hourComponent

/--
Addition of a `Duration` to a `ClockTime`; wraps into the next clock cycle.
-/
instance : HAdd HClockTime SignedDuration HClockTime where
  hAdd t d := { t with clockTime := t.clockTime + d }

theorem HClockTime.hAdd_signed_def (dur : SignedDuration) : t + dur = { t with clockTime := t.clockTime + dur } := rfl

/--
Subtraction of a `SignedDuration` from a `ClockTime`; the implementation follows
that of `Fin oneDayNanos`, wrapping into the previous clock cycle on underflow
-/
instance : HSub HClockTime SignedDuration HClockTime where
  hSub t d := { t with clockTime := t.clockTime - d }

theorem HClockTime.hSub_signed_def (dur : SignedDuration) : t - dur = { t with clockTime := t.clockTime - dur } := rfl

theorem HClockTime.apply_unapply : t + t.timeZone.offset - t.timeZone.offset = t := by
  simp [HClockTime.hAdd_signed_def, HClockTime.hSub_signed_def]
  rw [HClockTime.mk.injEq]
  exact And.intro rfl (heq_of_eq (ClockTime.apply_unapply t.clockTime))

theorem HClockTime.unapply_apply : t - t.timeZone.offset + t.timeZone.offset = t := by
  simp [HClockTime.hAdd_signed_def, HClockTime.hSub_signed_def]
  rw [HClockTime.mk.injEq]
  exact And.intro rfl (heq_of_eq (ClockTime.unapply_apply t.clockTime))

/--
LT compares the underlying naive/TAI time.
-/
instance : LT HClockTime where
  lt := InvImage instLTNaiveClockTime.lt (fun t => t.clockTime.naive)

/--
LE compares the underlying naive/TAI time.
-/
instance : LE HClockTime where
  le := InvImage instLENaiveClockTime.le (fun t => t.clockTime.naive)

theorem HClockTime.le_def (d₁ d₂ : HClockTime) : (d₁ <= d₂) = (d₁.clockTime.naive <= d₂.clockTime.naive) := rfl
theorem HClockTime.lt_def (d₁ d₂ : HClockTime) : (d₁ < d₂) = (d₁.clockTime.naive < d₂.clockTime.naive) := rfl

instance instDecidableLTHClockTime (a b : HClockTime) : Decidable (a < b) := inferInstanceAs (Decidable (a.clockTime.naive < b.clockTime.naive))
instance instDecidableLEHClockTime (a b : HClockTime) : Decidable (a <= b) := inferInstanceAs (Decidable (a.clockTime.naive <= b.clockTime.naive))

/--
HClockTime is only a Preorder since it does not respect antisymmetry.
t₁ <= t₂ ∧ t₂ <= t₁ does not imply t₁ = t₂ since they may have different timezones.
-/
instance : Preorder HClockTime where
  le_refl (a) := le_refl a.clockTime.naive
  le_trans (a b c) := Nat.le_trans
  lt_iff_le_not_le (a b) := Nat.lt_iff_le_not_le

end HClockTimeStuff


import tactic.induction
import data.int.basic
import data.set.basic

import .base .board

noncomputable theory
open_locale classical

instance : inhabited State := ⟨state₀⟩

@[reducible]
def State.len (s : State) : ℕ :=
s.history.length

def State.nth (s : State) (n : ℕ) : option Board :=
(s.history ++ [s.board]).nth n

-----

lemma hist_ne_of_hist_len_ne {s₁ s₂ : State}
  (h : s₁.len ≠ s₂.len) :
  s₁.history ≠ s₂.history :=
by { contrapose! h, rw [State.len, h] }

lemma hist_len_finish {s : State} :
  s.finish.len = s.len := rfl

lemma state_nth_len {s : State} :
  s.nth s.len = some s.board :=
begin
  rw [State.len, State.nth, list.nth_eq_some],
  use length_lt_length_snoc, rw list.nth_le_append_right,
  { simp_rw nat.sub_self, refl },
  { refl },
end


import tactic

open tactic

/-!

This file contains three tactic-programming exercises of increasing difficulty.

They were (hastily) written to follow the metaprogramming tutorial at
Lean for the Curious Mathematician 2020.

If you're looking for more (better) exercises, we strongly recommend the
exercises by Blanchette et al
for the course Logical Verification at the Vrije Universiteit Amsterdam,
and the corresponding chapter of the course notes:

https://github.com/blanchette/logical_verification_2020/blob/master/lean/love07_metaprogramming_exercise_sheet.lean
https://github.com/blanchette/logical_verification_2020/raw/master/hitchhikers_guide.pdf

## Exercise 1

Write a `contradiction` tactic.
The tactic should look through the hypotheses in the local context
trying to find two that contradict each other,
i.e. proving `P` and `¬ P` for some proposition `P`.
It should use this contradiction to close the goal.

Bonus: handle `P → false` as well as `¬ P`.

This exercise is to practice manipulating the hypotheses and goal.

Note: this exists as `tactic.interactive.contradiction`.

-/

/-
This solution is a "slick version."

We write a function `find_absurd_proof` that takes an expr e and a list of exprs.

For each expr h in the list,
it tries to apply e to h. If `e : ¬ P` and `h : P`, this will succeed
and result in a proof of `false`. Otherwise it will fail.

`find_absurd_proof` finds the first `h` such that it succeeds, and uses the proof of `false`
to close the goal.

If no such `h` exists, `find_absurd_proof` will fail.
-/

meta def find_absurd_proof (e : expr) (ctx : list expr) : tactic unit :=
do prf ← ctx.mfirst (λ h, to_expr ``(%%e %%h)),
   exact prf

/-

`contr` maps over the local context `ctx`.
For every `e` in `ctx`, it calls `find_absurd_proof e ctx`.

Notice the double loop through `ctx`:
for each `e` in `ctx`, we search through all of `ctx` again!

`contr` calls the `exfalso` tactic before it begins,
to make sure the target is `false`.
-/

meta def tactic.interactive.contr : tactic unit :=
do exfalso,
   ctx ← local_context,
   ctx.mfirst (λ e, find_absurd_proof e ctx)

example (P Q R : Prop) (hp : P) (hq : Q) (hr : ¬ R) (hnq : ¬ Q) : false :=
by contr

example (P Q R : Prop) (hnq : ¬ Q) (hp : P) (hq : Q) (hr : ¬ R) : 0 = 1 :=
by contr

example (P Q R : Prop) (hp : P) (hq : Q) (hr : ¬ R) (hnq : Q → false) : false :=
by contr

/-!

## Exercise 2

Write a tactic that proves a given `nat`-valued declaration is nonnegative.
The tactic should take the name of a declaration whose return type is `ℕ`
(presumably with some arguments), e.g. `nat.add : ℕ → ℕ → ℕ`
or `list.length : Π α : Type, list α → ℕ`.
It should add a new declaration to the environment which proves all applications
of this function are nonnegative,
e.g. `nat.add_nonneg : ∀ m n : ℕ, 0 ≤ nat.add m n`.

Bonus: create reasonable names for these declarations, and/or take an optional argument
for the new name.

This tactic is not useful by itself, but it's a good way to practice
querying and modifying an environment and working under binders.
It is not a tactic to be used during a proof, but rather as a command.

Hints:
* For looking at declarations in the environment, you will need the `declaration` type,
  as well as the tactics `get_decl` and `add_decl`.
* You will have to manipulate an expression under binders.
  The tactics `mk_local_pis` and `pis`, or their lambda equivalents, will be helpful here.
* `mk_mapp` is a variant of `mk_app` that lets you provide implicit arguments.
-/

meta def add_nonneg_proof (n : name) : tactic unit :=

   -- first we find the declaration named `n` in the environment.
do d ← get_decl n,

   -- the type of d is `Π x y z ..., body`,
   -- where body contains a bunch of free variables.
   -- we instantiate the binders to get a body we can manipulate.
   (args, body) ← mk_local_pis d.type,

   -- args is a list of expressions, but we want a list of `option expr`s to give to `mk_mapp`.
   let args_with_some := args.map some,

   -- this line applies the expression named `n` to the variables we've created.
   -- d_body is the natural number that we want to prove is nonnegative.
   d_body ← mk_mapp n args_with_some,

   -- so we prove that `d_body` is nonnegative by applying `nat.zero_le`.
   nonneg_prf_body ← mk_app `nat.zero_le [d_body],

   -- now we abstract away the local constants we created.
   nonneg_prf ← lambdas args nonneg_prf_body,

   -- we create a name for our new proof.
   -- if `n` is `nat.add, we will call our new proof `nat.add.nonneg
   let new_decl_name := n.append `nonneg,

   -- we get the type of the proof we've constructed,
   decl_tp ← infer_type nonneg_prf,

   -- make a term of type `declaration`,
   let new_decl := mk_theorem new_decl_name d.univ_params decl_tp nonneg_prf,

   -- and add that declaration to the environment.
   add_decl new_decl

run_cmd add_nonneg_proof `nat.add
run_cmd add_nonneg_proof `list.length

#check nat.add.nonneg
#check list.length.nonneg

/-!

## Exercise 3 (challenge!)

The mathlib tactic `cancel_denoms` is intended to get rid of division by numerals
in expressions where this makes sense. For example,

-/

example (q : ℚ) (h : q / 3 > 0) : q > 0 :=
begin
  cancel_denoms at h, exact h
end

/-!

But it is not complete. In particular, it doesn't like nested division
or other operators in denominators. These all fail:

-/

example (q : ℚ) (h : q / (3 / 4) > 0) : false :=
begin
  -- cancel_denoms at h,
  admit
end

example (p q : ℚ) (h : q / 2 / 3 < q) : false :=
begin
  -- cancel_denoms at h,
  admit
end

example (p q : ℚ) (h : q / 2 < 3 / (4*q)) : false :=
begin
  -- cancel_denoms at h,
  admit
end

-- this one succeeds but doesn't do what it should
example (p q : ℚ) (h : q / (2*3) < q) : false :=
begin
  -- cancel_denoms at h,
  admit
end

/-!

Look at the code in `src/tactic/cancel_denoms.lean` and try to fix it.
See if you can solve any or all of these failing test cases.

If you succeed, a pull request to mathlib is strongly encouraged!

-/


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

import category_theory.comma
import category_theory.limits.preserves

universes v u -- declare the `v`'s first; see `category_theory.category` for an explanation

open category_theory category_theory.limits

variables {J : Type v} [small_category J]
variables {C : Type u} [𝒞 : category.{v} C]
include 𝒞
variable {X : C}

namespace category_theory.functor

def to_cocone (F : J ⥤ over X) : cocone (F ⋙ over.forget) :=
{ X := X,
  ι := { app := λ j, (F.obj j).hom } }

@[simp] lemma to_cocone_X (F : J ⥤ over X) : F.to_cocone.X = X := rfl
@[simp] lemma to_cocone_ι (F : J ⥤ over X) (j : J) : F.to_cocone.ι.app j = (F.obj j).hom := rfl

def to_cone (F : J ⥤ under X) : cone (F ⋙ under.forget) :=
{ X := X,
  π := { app := λ j, (F.obj j).hom } }

@[simp] lemma to_cone_X (F : J ⥤ under X) : F.to_cone.X = X := rfl
@[simp] lemma to_cone_π (F : J ⥤ under X) (j : J) : F.to_cone.π.app j = (F.obj j).hom := rfl

end category_theory.functor

namespace category_theory.over

def colimit (F : J ⥤ over X) [has_colimit (F ⋙ forget)] : cocone F :=
{ X := mk $ colimit.desc (F ⋙ forget) F.to_cocone,
  ι :=
  { app := λ j, hom_mk $ colimit.ι (F ⋙ forget) j,
    naturality' :=
    begin
      intros j j' f,
      have := colimit.w (F ⋙ forget) f,
      tidy
    end } }

@[simp] lemma colimit_X_hom (F : J ⥤ over X) [has_colimit (F ⋙ forget)] :
((colimit F).X).hom = colimit.desc (F ⋙ forget) F.to_cocone := rfl
@[simp] lemma colimit_ι_app (F : J ⥤ over X) [has_colimit (F ⋙ forget)] (j : J) :
((colimit F).ι).app j = hom_mk (colimit.ι (F ⋙ forget) j) := rfl

def forget_colimit_is_colimit (F : J ⥤ over X) [has_colimit (F ⋙ forget)] :
  is_colimit (forget.map_cocone (colimit F)) :=
is_colimit.of_iso_colimit (colimit.is_colimit (F ⋙ forget)) (cocones.ext (iso.refl _) (by tidy))

instance : reflects_colimits (forget : over X ⥤ C) :=
λ J 𝒥 F, by constructor; exactI λ t ht,
{ desc := λ s, hom_mk (ht.desc (forget.map_cocone s))
    begin
      apply ht.hom_ext, intro j,
      rw [←category.assoc, ht.fac],
      transitivity (F.obj j).hom,
      exact w (s.ι.app j), -- TODO: How to write (s.ι.app j).w?
      exact (w (t.ι.app j)).symm,
    end,
  fac' := begin
    intros s j, ext, exact ht.fac (forget.map_cocone s) j
    -- TODO: Ask Simon about multiple ext lemmas for defeq types (comma_morphism & over.category.hom)
  end,
  uniq' :=
  begin
    intros s m w,
    ext1 j,
    exact ht.uniq (forget.map_cocone s) m.left (λ j, congr_arg comma_morphism.left (w j))
  end }

instance has_colimit {F : J ⥤ over X} [has_colimit (F ⋙ forget)] : has_colimit F :=
{ cocone := colimit F,
  is_colimit := reflects_colimit.reflects (forget_colimit_is_colimit F) }

instance has_colimits_of_shape [has_colimits_of_shape J C] :
  has_colimits_of_shape J (over X) :=
λ F, infer_instance

instance has_colimits [has_colimits C] : has_colimits (over X) :=
λ J 𝒥, by resetI; apply_instance

instance forget_preserves_colimits [has_colimits C] {X : C} :
  preserves_colimits (forget : over X ⥤ C) :=
λ J 𝒥 F, by exactI
preserves_colimit_of_preserves_colimit_cocone (colimit.is_colimit F) (forget_colimit_is_colimit F)

end category_theory.over

namespace category_theory.under

def limit (F : J ⥤ under X) [has_limit (F ⋙ forget)] : cone F :=
{ X := mk $ limit.lift (F ⋙ forget) F.to_cone,
  π :=
  { app := λ j, hom_mk $ limit.π (F ⋙ forget) j,
    naturality' :=
    begin
      intros j j' f,
      have := (limit.w (F ⋙ forget) f).symm,
      tidy
    end } }

@[simp] lemma limit_X_hom (F : J ⥤ under X) [has_limit (F ⋙ forget)] :
((limit F).X).hom = limit.lift (F ⋙ forget) F.to_cone := rfl
@[simp] lemma limit_π_app (F : J ⥤ under X) [has_limit (F ⋙ forget)] (j : J) :
((limit F).π).app j = hom_mk (limit.π (F ⋙ forget) j) := rfl

def forget_limit_is_limit (F : J ⥤ under X) [has_limit (F ⋙ forget)] :
  is_limit (forget.map_cone (limit F)) :=
is_limit.of_iso_limit (limit.is_limit (F ⋙ forget)) (cones.ext (iso.refl _) (by tidy))

instance : reflects_limits (forget : under X ⥤ C) :=
λ J 𝒥 F, by constructor; exactI λ t ht,
{ lift := λ s, hom_mk (ht.lift (forget.map_cone s))
    begin
      apply ht.hom_ext, intro j,
      rw [category.assoc, ht.fac],
      transitivity (F.obj j).hom,
      exact w (s.π.app j),
      exact (w (t.π.app j)).symm,
    end,
  fac' := begin
    intros s j, ext, exact ht.fac (forget.map_cone s) j
  end,
  uniq' :=
  begin
    intros s m w,
    ext1 j,
    exact ht.uniq (forget.map_cone s) m.right (λ j, congr_arg comma_morphism.right (w j))
  end }

instance has_limit {F : J ⥤ under X} [has_limit (F ⋙ forget)] : has_limit F :=
{ cone := limit F,
  is_limit := reflects_limit.reflects (forget_limit_is_limit F) }

instance has_limits_of_shape [has_limits_of_shape J C] :
  has_limits_of_shape J (under X) :=
λ F, infer_instance

instance has_limits [has_limits C] : has_limits (under X) :=
λ J 𝒥, by resetI; apply_instance

instance forget_preserves_limits [has_limits C] {X : C} :
  preserves_limits (forget : under X ⥤ C) :=
λ J 𝒥 F, by exactI
preserves_limit_of_preserves_limit_cone (limit.is_limit F) (forget_limit_is_limit F)

end category_theory.under


import algebra.camera.basic

universe u

set_option old_structure_cmd true

/-!
# Uniform predicates
-/

@[ext] structure monotone_nonexpansive (α : Type u) [camera α] extends nonexpansive_fun α sprop :=
(mono : ∀ n a b, a ≼[n] b → to_fun a ⊆[n] to_fun b)

instance monotone_nonexpansive.fun_like (α : Type u) [camera α] :
  fun_like (monotone_nonexpansive α) α (λ _, sprop) := {
  coe := monotone_nonexpansive.to_fun,
  coe_injective' := by intros f g h; ext1; exact h,
}

instance monotone_nonexpansive.nonexpansive_fun_class (α : Type u) [camera α] :
  nonexpansive_fun_class (monotone_nonexpansive α) α sprop := {
  is_nonexpansive := monotone_nonexpansive.is_nonexpansive'
}

instance monotone_nonexpansive.setoid (α : Type u) [camera α] :
  setoid (monotone_nonexpansive α) := {
  r := λ x y, ∀ m a, ✓[m] a → (x a m ↔ y a m),
  iseqv := begin
    refine ⟨_, _, _⟩,
    { intros x n a h,
      refl, },
    { intros x y h m a h',
      rw h m a,
      exact h', },
    { intros x y z h₁ h₂ m a h',
      rw h₁ m a,
      rw h₂ m a,
      exact h',
      exact h', },
  end,
}

def upred (α : Type u) [camera α] : Type* := quotient (monotone_nonexpansive.setoid α)

def monotone_nonexpansive.eq_at {α : Type u} [camera α] (n : ℕ)
  (x y : monotone_nonexpansive α) : Prop :=
∀ m a, m ≤ n → ✓[m] a → (x a m ↔ y a m)

lemma monotone_nonexpansive.eq_at_respects_rel {α : Type u} [camera α] (n : ℕ)
  (a₁ a₂ b₁ b₂ : monotone_nonexpansive α) : a₁ ≈ b₁ →
    a₂ ≈ b₂ → monotone_nonexpansive.eq_at n a₁ a₂ = monotone_nonexpansive.eq_at n b₁ b₂ :=
begin
  intros h₁ h₂,
  ext1,
  split,
  { intros h m a hmn ha,
    rw ← h₁ m a ha,
    rw ← h₂ m a ha,
    exact h m a hmn ha, },
  { intros h m a hmn ha,
    rw h₁ m a ha,
    rw h₂ m a ha,
    exact h m a hmn ha, },
end

private def upred.eq_at {α : Type u} [camera α] (n : ℕ) : upred α → upred α → Prop :=
quotient.lift₂ (monotone_nonexpansive.eq_at n) (monotone_nonexpansive.eq_at_respects_rel n)

private lemma upred.eq_at_reflexive {α : Type u} [camera α] (n : ℕ)
  (x : upred α) : upred.eq_at n x x :=
begin
  refine quotient.induction_on x _, clear x, intro x,
  intros m a hmn h,
  refl,
end

private lemma upred.eq_at_symmetric {α : Type u} [camera α] (n : ℕ) (x y : upred α) :
  upred.eq_at n x y → upred.eq_at n y x :=
begin
  refine quotient.induction_on₂ x y _, clear x y, intros x y,
  intros h m a hmn ha,
  exact (h m a hmn ha).symm,
end

private lemma upred.eq_at_transitive {α : Type u} [camera α] (n : ℕ) (x y z : upred α) :
  upred.eq_at n x y → upred.eq_at n y z → upred.eq_at n x z :=
begin
  refine quotient.induction_on₃ x y z _, clear x y z, intros x y z,
  intros hxy hyz m a hmn h,
  rw hxy m a hmn h,
  rw hyz m a hmn h,
end

private lemma upred.eq_at_antitone {α : Type u} [camera α] :
  antitone (upred.eq_at : ℕ → upred α → upred α → Prop) :=
begin
  intros m n hmn x y,
  refine quotient.induction_on₂ x y _, clear x y, intros x y,
  intros h k a hk ha,
  exact h k a (hk.trans hmn) ha,
end

private lemma upred.eq_at_limit {α : Type u} [camera α] (x y : upred α) :
  (∀ n, upred.eq_at n x y) → x = y :=
begin
  refine quotient.induction_on x _, clear x, intro x,
  refine quotient.induction_on y _, clear y, intro y,
  intro h,
  refine quotient.sound _,
  intros m a ha,
  exact h m m a le_rfl ha,
end

private def monotone_nonexpansive.lim {α : Type u} [unital_camera α]
  (c : chain (monotone_nonexpansive α) monotone_nonexpansive.eq_at) : monotone_nonexpansive α :=
begin
  refine ⟨λ a, ⟨λ n, ∀ m ≤ n, ✓[m] a → c m a m, _⟩, _, _⟩,
  { intros m n hmn h k hk hak,
    exact h k (hk.trans hmn) hak, },
  { intros n x y h m hmn,
    split,
    { intros ha k hk hy,
      refine (c k).mono k x y _ _ le_rfl (ha k hk _),
      { refine ⟨1, _⟩,
        rw [mul_comm, one_mul],
        exact eq_at_mono (hk.trans hmn) h, },
      { have : camera.validn x =[n] camera.validn y := nonexpansive camera.validn h,
        rw this k (hk.trans hmn),
        exact hy, }, },
    { intros ha k hk hy,
      refine (c k).mono k y x _ _ le_rfl (ha k hk _),
      { refine ⟨1, _⟩,
        rw [mul_comm, one_mul],
        exact eq_at_mono (hk.trans hmn) (eq_at_symmetric n h), },
      { have : camera.validn x =[n] camera.validn y := nonexpansive camera.validn h,
        rw ← this k (hk.trans hmn),
        exact hy, }, }, },
  { intros n a b hab m hmn h k hkm hb,
    refine (c k).mono n _ _ hab k (hkm.trans hmn) _,
    refine h k hkm _,
    obtain ⟨c, hc⟩ := hab,
    have : camera.validn (a * c) =[n] camera.validn b := nonexpansive camera.validn hc,
    rw ← this k (hkm.trans hmn) at hb,
    exact camera.validn_mul a c k hb, },
end

private lemma monotone_nonexpansive.complete {α : Type u} [unital_camera α] (n : ℕ)
  (c : chain (monotone_nonexpansive α) monotone_nonexpansive.eq_at) :
  monotone_nonexpansive.eq_at n (monotone_nonexpansive.lim c) (c n) :=
begin
  intros m a hmn ha,
  split,
  { intro h,
    have := h m le_rfl ha,
    exact (c.prop m n hmn m a le_rfl ha).mp this, },
  { intros h k hk hak,
    refine (c.prop k n (hk.trans hmn) k a le_rfl hak).mpr _,
    exact (c n a).mono hk h, },
end

private noncomputable def upred.chain_out {α : Type u} [unital_camera α] (c : chain (upred α) upred.eq_at) :
  chain (monotone_nonexpansive α) monotone_nonexpansive.eq_at := {
  c := λ n, (c n).out,
  prop := begin
    intros m n hmn k a hk ha,
    have := c.prop m n hmn,
    rw ← quotient.out_eq (c.c m) at this,
    rw ← quotient.out_eq (c.c n) at this,
    exact this k a hk ha,
  end,
}

private noncomputable def upred.lim {α : Type u} [unital_camera α]
  (c : chain (upred α) upred.eq_at) : upred α :=
⟦monotone_nonexpansive.lim (upred.chain_out c)⟧

private lemma upred.complete {α : Type u} [unital_camera α] (n : ℕ) (c : chain (upred α) upred.eq_at) :
  upred.eq_at n (upred.lim c) (c n) :=
begin
  rw ← quotient.out_eq (c n),
  intros m a hmn ha,
  exact monotone_nonexpansive.complete n (upred.chain_out c) m a hmn ha,
end

instance upred_ofe (α : Type u) [camera α] : ofe (upred α) := {
  eq_at := upred.eq_at,
  eq_at_reflexive := upred.eq_at_reflexive,
  eq_at_symmetric := upred.eq_at_symmetric,
  eq_at_transitive := upred.eq_at_transitive,
  eq_at_mono' := upred.eq_at_antitone,
  eq_at_limit' := upred.eq_at_limit,
}

noncomputable instance upred_cofe (α : Type u) [unital_camera α] : cofe (upred α) := {
  lim := upred.lim,
  complete := upred.complete,
}

def upred.map_fun {α β : Type u} [unital_camera α] [unital_camera β] (f : α →ₖₕ β) :
  upred β → upred α :=
quotient.lift (λ g : monotone_nonexpansive β, ⟦{
  monotone_nonexpansive .
  to_fun := λ a, ⟨λ n, g (f a) n, λ m n hmn, (g (f a)).mono hmn⟩,
  is_nonexpansive' := begin
    intros n x y h m hmn,
    dsimp only [sprop.coe_fn_mk],
    have : f x =[n] f y := nonexpansive f h,
    split,
    exact g.mono n (f x) (f y) (incln_of_eq_at this) m hmn,
    exact g.mono n (f y) (f x) (incln_of_eq_at (eq_at_symmetric n this)) m hmn,
  end,
  mono := begin
    intros n x y h m hmn hm,
    have : f x ≼[n] f y := camera_hom.map_incln h,
    exact g.mono n (f x) (f y) this m hmn hm,
  end,
}⟧) begin
  intros x y h,
  refine quotient.sound _,
  intros n a hn,
  exact h n (f a) (f.map_valid' n a hn),
end

/-- `upred` is a locally nonexpansive functor from `unital_camera` to `cofe`. -/
def upred.map {α β : Type u} [unital_camera α] [unital_camera β] :
  (α →ₖₕ β) →ₙₑ (upred β →ₙₑ upred α) := {
  to_fun := λ f, ⟨upred.map_fun f, begin
    intros n p q,
    refine quotient.induction_on₂ p q _, clear p q, intros p q,
    intros h m a hmn hm,
    exact h m (f a) hmn (f.map_valid' m a hm),
  end⟩,
  is_nonexpansive' := begin
    intros n f g h p,
    refine quotient.induction_on p _, clear p, intro p,
    intros m a hmn hm,
    have : p (f a) =[n] p (g a) := nonexpansive p (h a),
    exact this _ hmn,
  end,
}


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

import for_mathlib.dold_kan.gamma_comp_n
import for_mathlib.dold_kan.n_reflects_iso

/-! The unit isomorphism of the Dold-Kan equivalence

In order to construct the unit isomorphism of the Dold-Kan equivalence,
we first construct natural transformations
`Γ₂N₁.nat_trans : N₁ ⋙ Γ₂ ⟶ to_karoubi (simplicial_object C)` and
`Γ₂N₂.nat_trans : N₂ ⋙ Γ₂ ⟶ 𝟭 (simplicial_object C)`.
It is then shown that `Γ₂N₂.nat_trans` is an isomorphism by using
that it becomes an isomorphism after the application of the functor
`N₂ : karoubi (simplicial_object C) ⥤ karoubi (chain_complex C ℕ)`
which reflects isomorphisms.

-/

noncomputable theory

open category_theory category_theory.category category_theory.limits
  category_theory.idempotents simplex_category opposite simplicial_object
open_locale simplicial dold_kan

namespace algebraic_topology

namespace dold_kan

variables {C : Type*} [category C] [preadditive C]

lemma P_infty_comp_map_mono_eq_zero (X : simplicial_object C) {n : ℕ}
  {Δ' : simplex_category} (i : Δ' ⟶ [n]) [hi : mono i] (h₁ : Δ'.len ≠ n) (h₂ : ¬is_δ₀ i) :
  P_infty.f n ≫ X.map i.op = 0 :=
begin
  unfreezingI { induction Δ' using simplex_category.rec with m, },
  obtain ⟨k, hk⟩ := nat.exists_eq_add_of_lt (len_lt_of_mono i
    (λ h, by { rw ← h at h₁,  exact h₁ rfl, })),
  simp only [len_mk] at hk,
  cases k,
  { change n = m + 1 at hk,
    unfreezingI { subst hk, obtain ⟨j, rfl⟩ := eq_δ_of_mono i, },
    rw is_δ₀.iff at h₂,
    have h₃ : 1 ≤ (j : ℕ),
    { by_contra,
      exact h₂ (by simpa only [fin.ext_iff, not_le, nat.lt_one_iff] using h), },
    exact (higher_faces_vanish.of_P (m+1) m).comp_δ_eq_zero j h₂ (by linarith), },
  { simp only [nat.succ_eq_add_one, ← add_assoc] at hk,
    clear h₂ hi,
    subst hk,
    obtain ⟨j₁, i, rfl⟩ := eq_comp_δ_of_not_surjective i (λ h, begin
      have h' := len_le_of_epi (simplex_category.epi_iff_surjective.2 h),
      dsimp at h',
      linarith,
    end),
    obtain ⟨j₂, i, rfl⟩ := eq_comp_δ_of_not_surjective i (λ h, begin
      have h' := len_le_of_epi (simplex_category.epi_iff_surjective.2 h),
      dsimp at h',
      linarith,
    end),
    by_cases hj₁ : j₁ = 0,
    { unfreezingI { subst hj₁, },
      rw [assoc, ← simplex_category.δ_comp_δ'' (fin.zero_le _)],
      simp only [op_comp, X.map_comp, assoc, P_infty_f],
      erw [(higher_faces_vanish.of_P _ _).comp_δ_eq_zero_assoc _ j₂.succ_ne_zero, zero_comp],
      rw fin.coe_succ,
      linarith, },
    { simp only [op_comp, X.map_comp, assoc, P_infty_f],
      erw [(higher_faces_vanish.of_P _ _).comp_δ_eq_zero_assoc _ hj₁, zero_comp],
      by_contra,
      exact hj₁ (by { simp only [fin.ext_iff, fin.coe_zero], linarith, }), }, },
end

@[reassoc]
lemma Γ₀_obj_termwise_map_mono_comp_P_infty (X : simplicial_object C) {Δ Δ' : simplex_category}
  (i : Δ ⟶ Δ') [mono i] :
  Γ₀.obj.termwise.map_mono (alternating_face_map_complex.obj X) i ≫ P_infty.f (Δ.len) =
    P_infty.f (Δ'.len) ≫ X.map i.op :=
begin
  unfreezingI
  { induction Δ using simplex_category.rec with n,
    induction Δ' using simplex_category.rec with n', },
  dsimp,
  /- We start with the case `i` is an identity -/
  by_cases n = n',
  { unfreezingI { subst h, },
    simp only [simplex_category.eq_id_of_mono i, Γ₀.obj.termwise.map_mono_id, op_id, X.map_id],
    dsimp,
    simp only [id_comp, comp_id], },
  by_cases hi : is_δ₀ i,
  /- The case `i = δ 0` -/
  { have h' : n' = n + 1 := hi.left,
    unfreezingI { subst h', },
    simp only [Γ₀.obj.termwise.map_mono_δ₀' _ i hi],
    dsimp,
    rw [← P_infty.comm' _ n rfl, alternating_face_map_complex.obj_d_eq],
    simp only [eq_self_iff_true, id_comp, if_true, preadditive.comp_sum],
    rw finset.sum_eq_single (0 : fin (n+2)), rotate,
    { intros b hb hb',
      rw preadditive.comp_zsmul,
      erw [P_infty_comp_map_mono_eq_zero X (simplex_category.δ b) h
        (by { rw is_δ₀.iff, exact hb', }), zsmul_zero], },
    { simp only [finset.mem_univ, not_true, is_empty.forall_iff], },
    { simpa only [hi.eq_δ₀, fin.coe_zero, pow_zero, one_zsmul], }, },
  /- The case `i ≠ δ 0` -/
  { rw [Γ₀.obj.termwise.map_mono_eq_zero _ i _ hi, zero_comp], swap,
    { by_contradiction h',
      exact h (congr_arg simplex_category.len h'.symm), },
    rw P_infty_comp_map_mono_eq_zero,
    { exact h, },
    { by_contradiction h',
      exact hi h', }, },
end

variable [has_finite_coproducts C]

namespace Γ₂N₁

/-- The natural transformation `N₁ ⋙ Γ₂ ⟶ to_karoubi (simplicial_object C)`. -/
@[simps]
def nat_trans : (N₁ : simplicial_object C ⥤ _) ⋙ Γ₂ ⟶ to_karoubi _ :=
{ app := λ X,
  { f :=
    { app := λ Δ, (Γ₀.splitting K[X]).desc Δ (λ A, P_infty.f A.1.unop.len ≫ X.map (A.e.op)),
      naturality' := λ Δ Δ' θ, begin
        apply (Γ₀.splitting K[X]).hom_ext',
        intro A,
        change _ ≫ (Γ₀.obj K[X]).map θ  ≫ _ = _,
        simp only [splitting.ι_desc_assoc, assoc,
          Γ₀.obj.map_on_summand'_assoc, splitting.ι_desc],
        erw Γ₀_obj_termwise_map_mono_comp_P_infty_assoc X (image.ι (θ.unop ≫ A.e)),
        dsimp only [to_karoubi],
        simp only [← X.map_comp],
        congr' 2,
        simp only [eq_to_hom_refl, id_comp, comp_id, ← op_comp],
        exact quiver.hom.unop_inj (A.fac_pull θ),
      end, },
    comm := begin
      apply (Γ₀.splitting K[X]).hom_ext,
      intro n,
      dsimp [N₁],
      simp only [← splitting.ι_summand_id, splitting.ι_desc,
        comp_id, splitting.ι_desc_assoc, assoc, P_infty_f_idem_assoc],
    end, },
  naturality' := λ X Y f, begin
    ext1,
    apply (Γ₀.splitting K[X]).hom_ext,
    intro n,
    dsimp [N₁, to_karoubi],
    simpa only [←splitting.ι_summand_id, splitting.ι_desc, splitting.ι_desc_assoc,
      assoc, P_infty_f_idem_assoc, karoubi.comp_f, nat_trans.comp_app, Γ₂_map_f_app,
      homological_complex.comp_f, alternating_face_map_complex.map_f,
      P_infty_f_naturality_assoc, nat_trans.naturality],
  end, }

end Γ₂N₁

/-- The compatibility isomorphism relating `N₂ ⋙ Γ₂` and `N₁ ⋙ Γ₂`. -/
@[simps]
def compatibility_Γ₂N₁_Γ₂N₂ : to_karoubi (simplicial_object C) ⋙ N₂ ⋙ Γ₂ ≅ N₁ ⋙ Γ₂ :=
eq_to_iso (functor.congr_obj (functor_extension₁_comp_whiskering_left_to_karoubi _ _) (N₁ ⋙ Γ₂))

namespace Γ₂N₂

/-- The natural transformation `N₂ ⋙ Γ₂ ⟶ 𝟭 (simplicial_object C)`. -/
def nat_trans : (N₂ : karoubi (simplicial_object C) ⥤ _) ⋙ Γ₂ ⟶ 𝟭 _ :=
((whiskering_left _ _ _).obj _).preimage (compatibility_Γ₂N₁_Γ₂N₂.hom ≫ Γ₂N₁.nat_trans)

lemma nat_trans_app_f_app (P : karoubi (simplicial_object C)) :
  Γ₂N₂.nat_trans.app P = (N₂ ⋙ Γ₂).map P.decomp_id_i ≫
    (compatibility_Γ₂N₁_Γ₂N₂.hom ≫ Γ₂N₁.nat_trans).app P.X ≫ P.decomp_id_p :=
whiskering_left_obj_preimage_app ((compatibility_Γ₂N₁_Γ₂N₂.hom ≫ Γ₂N₁.nat_trans)) P

end Γ₂N₂

lemma compatibility_Γ₂N₁_Γ₂N₂_nat_trans (X : simplicial_object C) :
  Γ₂N₁.nat_trans.app X = (compatibility_Γ₂N₁_Γ₂N₂.app X).inv ≫
    Γ₂N₂.nat_trans.app ((to_karoubi _).obj X) :=
begin
  rw [← cancel_epi (compatibility_Γ₂N₁_Γ₂N₂.app X).hom, iso.hom_inv_id_assoc],
  exact congr_app (((whiskering_left _ _ _).obj _).image_preimage
    (compatibility_Γ₂N₁_Γ₂N₂.hom ≫ Γ₂N₁.nat_trans : _ ⟶ to_karoubi _ ⋙ 𝟭 _ )).symm X,
end

lemma identity_N₂_objectwise (P : karoubi (simplicial_object C)) :
  N₂Γ₂.inv.app (N₂.obj P) ≫ N₂.map (Γ₂N₂.nat_trans.app P) = 𝟙 (N₂.obj P) :=
begin
  ext n,
  have eq₁ : (N₂Γ₂.inv.app (N₂.obj P)).f.f n = P_infty.f n ≫ P.p.app (op [n]) ≫
    (Γ₀.splitting (N₂.obj P).X).ι_summand (splitting.index_set.id (op [n])),
  { simp only [N₂Γ₂_inv_app_f_f, N₂_obj_p_f, assoc], },
  have eq₂ : (Γ₀.splitting (N₂.obj P).X).ι_summand (splitting.index_set.id (op [n])) ≫
    (N₂.map (Γ₂N₂.nat_trans.app P)).f.f n = P_infty.f n ≫ P.p.app (op [n]),
  { dsimp [N₂],
    simp only [Γ₂N₂.nat_trans_app_f_app, P_infty_on_Γ₀_splitting_summand_eq_self_assoc,
      functor.comp_map, compatibility_Γ₂N₁_Γ₂N₂_hom, nat_trans.comp_app,
      eq_to_hom_app, assoc, karoubi.comp_f, karoubi.eq_to_hom_f, eq_to_hom_refl, comp_id,
      karoubi.decomp_id_p_f, karoubi.comp_p_assoc, Γ₂_map_f_app,
      N₂_map_f_f, karoubi.decomp_id_i_f, Γ₂N₁.nat_trans_app_f_app],
    erw [splitting.ι_desc_assoc, assoc, assoc, splitting.ι_desc_assoc],
    dsimp [splitting.index_set.id, splitting.index_set.e],
    simp only [assoc, nat_trans.naturality, P_infty_f_naturality_assoc,
      app_idem_assoc, P_infty_f_idem_assoc],
    erw [P.X.map_id, comp_id], },
  simp only [karoubi.comp_f, homological_complex.comp_f, karoubi.id_eq, N₂_obj_p_f, assoc,
    eq₁, eq₂, P_infty_f_naturality_assoc, app_idem, P_infty_f_idem_assoc],
end

lemma identity_N₂ :
  ((𝟙 (N₂ : karoubi (simplicial_object C) ⥤ _ ) ◫ N₂Γ₂.inv) ≫
    (Γ₂N₂.nat_trans ◫ 𝟙 N₂) : N₂ ⟶ N₂) = 𝟙 N₂ :=
by { ext P : 2, dsimp, rw [Γ₂.map_id, N₂.map_id, comp_id, id_comp, identity_N₂_objectwise P], }

instance : is_iso (Γ₂N₂.nat_trans : (N₂ : karoubi (simplicial_object C) ⥤ _ ) ⋙ _ ⟶ _) :=
begin
  haveI : ∀ (P : karoubi (simplicial_object C)), is_iso (Γ₂N₂.nat_trans.app P),
  { intro P,
    haveI : is_iso (N₂.map (Γ₂N₂.nat_trans.app P)),
    { have h := identity_N₂_objectwise P,
      erw hom_comp_eq_id at h,
      rw h,
      apply_instance, },
    exact is_iso_of_reflects_iso _ N₂, },
  apply nat_iso.is_iso_of_is_iso_app,
end

instance : is_iso (Γ₂N₁.nat_trans : (N₁ : simplicial_object C ⥤ _ ) ⋙ _ ⟶ _) :=
begin
  haveI : ∀ (X : simplicial_object C), is_iso (Γ₂N₁.nat_trans.app X),
  { intro X,
    rw compatibility_Γ₂N₁_Γ₂N₂_nat_trans,
    apply_instance, },
  apply nat_iso.is_iso_of_is_iso_app,
end

/-- The unit isomorphism of the Dold-Kan equivalence. -/
@[simp]
def Γ₂N₂ : 𝟭 _ ≅ (N₂ : karoubi (simplicial_object C) ⥤ _) ⋙ Γ₂ :=
(as_iso Γ₂N₂.nat_trans).symm

/-- The natural isomorphism `to_karoubi (simplicial_object C) ≅ N₁ ⋙ Γ₂`. -/
@[simps]
def Γ₂N₁ : to_karoubi _  ≅ (N₁ : simplicial_object C ⥤ _) ⋙ Γ₂ :=
(as_iso Γ₂N₁.nat_trans).symm

end dold_kan

end algebraic_topology