namespace Foo
namespace Bla

theorem ex1 {a b : Nat} (h : a ≤ b) : a + a ≤ b + b :=
  sorry

theorem ex2 {a b : Nat} (h : a ≤ b) : a + 2 ≤ b + 2 :=
  sorry

theorem ex3 {a b c d : Nat} (h : a ≤ b) (h : c ≤ d) : a + c ≤ b + d :=
  sorry

theorem ax1 {a b : Nat} (h : a ≤ b) : a - a ≤ b - b :=
  sorry

end Bla
end Foo

theorem tst1 (h : a ≤ b) : a + 2 ≤ b + 2 :=
  Foo.Bla.
        --^ textDocument/completion
#print ""

open Foo in
theorem tst2 (h : a ≤ b) : a + 2 ≤ b + 2 :=
  Bla.
    --^ textDocument/completion
#print ""

theorem tst3 (h : a ≤ b) : a + 2 ≤ b + 2 :=
  let aux := Foo.Bla.  -- we don't have the expected type here
                   --^ textDocument/completion
  aux

#print ""

theorem tst4 (h : a ≤ b) : a + 2 ≤ b + 2 :=
  let aux := Foo.Bla.e  -- we don't have the expected type here
                    --^ textDocument/completion
  aux


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

import category_theory.tactics.obviously
import tidy.auto_cast

namespace category_theory.graphs

universes v₁ v₂ u₁ u₂

class graph (vertices : Type u₁) :=
(edges : vertices → vertices → Sort v₁)

variable {C : Type u₁}
variables {W X Y Z : C}
variable [𝒞 : graph.{v₁} C]

def edges : C → C → Sort v₁ := @graph.edges.{v₁} C 𝒞

structure graph_hom (G : Type u₁) [graph.{v₁} G] (H : Type u₂) [graph.{v₂} H] :=
(onVertices : G → H)
(onEdges    : ∀ {X Y : G}, edges X Y → edges (onVertices X) (onVertices Y))

section
variables {G : Type u₁} [𝒢 : graph.{v₁} G] {H : Type u₂} [ℋ : graph.{v₂} H]
include 𝒢 ℋ

@[extensionality] lemma graph_hom_pointwise_equal
  {p q : graph_hom G H}
  (vertexWitness : ∀ X : G, p.onVertices X = q.onVertices X)
  (edgeWitness : ∀ X Y : G, ∀ f : edges X Y, ⟬ p.onEdges f ⟭ = q.onEdges f) : p = q :=
begin
  induction p with p_onVertices p_onEdges,
  induction q with q_onVertices q_onEdges,
  have h_vertices : p_onVertices = q_onVertices, exact funext vertexWitness,
  subst h_vertices,
  have h_edges : @p_onEdges = @q_onEdges,
  apply funext, intro X, apply funext, intro Y, apply funext, intro f,
  exact edgeWitness X Y f,
  subst h_edges
end
end

variables {G : Type u₁} [𝒢 : graph.{v₁} G]
include 𝒢

inductive path : G → G → Type (max u₁ v₁)
| nil  : Π (h : G), path h h
| cons : Π {h s t : G} (e : edges h s) (l : path s t), path h t

def path.length : Π {s t : G}, path s t → ℕ
| _ _ (path.nil _) := 0
| _ _ (@path.cons _ _ _ _ _ e l) := path.length l

notation a :: b := path.cons a b
notation `p[` l:(foldr `, ` (h t, path.cons h t) path.nil _ `]`) := l

inductive path_of_paths : G → G → Type (max u₁ v₁)
| nil  : Π (h : G), path_of_paths h h
| cons : Π {h s t : G} (e : path h s) (l : path_of_paths s t), path_of_paths h t

notation a :: b := path_of_paths.cons a b
notation `pp[` l:(foldr `, ` (h t, path_of_paths.cons h t) path_of_paths.nil _ `]`) := l

-- The pattern matching trick used here was explained by Jeremy Avigad at https://groups.google.com/d/msg/lean-user/JqaI12tdk3g/F9MZDxkFDAAJ
def concatenate_paths : Π {x y z : G}, path x y → path y z → path x z
| ._ ._ _ (path.nil _)               q := q
| ._ ._ _ (@path.cons ._ _ _ _ _ e p') q := path.cons e (concatenate_paths p' q)

@[simp] lemma concatenate_paths' {x' x y z : G} (e : edges x' x) (p : path x y) (q : path y z) : concatenate_paths (e :: p) q = e :: (concatenate_paths p q) := rfl

def concatenate_path_of_paths : Π {x y : G}, path_of_paths x y → path x y
| ._ ._ (path_of_paths.nil X) := path.nil X
| ._ ._ (@path_of_paths.cons ._ _ _ _ _ e p') := concatenate_paths e (concatenate_path_of_paths p')

end category_theory.graphs


import etv.defs
import etv.label

open_locale classical
noncomputable theory

variables
  {α : Type*} [linear_order α] {C : config α}
  {S : finset α} (l : C.label S)

private lemma mem_imply_nnil
  {α : Type*} (a : α) {l : list α} (ha : a ∈ l) : l ≠ [] :=
  by intro eq; subst eq; simp at ha; tauto

namespace config.label

def is_alpha_cup (a : α) (c : list α) : Prop :=
  (c ++ [a]).in S ∧ (c ++ [a]).sorted (<) ∧ (c ++ [a]).chain' l.slopeᶜ

instance decidable_is_alpha_cup (a : α) (c : list α) :
  decidable (l.is_alpha_cup a c) := by rw is_alpha_cup; apply_instance

theorem alpha_cup_is_cup (c : list α)
  (c_in_S : c.in S) (c_sorted : c.sorted (<))
  (c_chain : c.chain' l.slopeᶜ) : C.cup c :=
begin
  induction c with h0 c ih, simp,
  cases c with h1 c, simp,
  cases c with h2 c,
  { simp, simp at c_sorted, assumption, },
  simp, refine ⟨_, _, _⟩,
  simp at c_sorted; tauto,
  simp at c_in_S c_chain c_sorted; apply l.extend_left; tauto,
  apply ih; simp at ⊢ c_in_S c_chain c_sorted; tauto,
end

def alpha_cups' (a : α) : list (list α) :=
  (S.sort (≤)).sublists.filter (l.is_alpha_cup a)

def alpha_cup' (a : α) : option (list α) :=
  (l.alpha_cups' a).argmax list.length

def alpha_cup'_is_some {a : α} (ha : a ∈ S) :
  option.is_some (l.alpha_cup' a) :=
begin
  rw [←option.ne_none_iff_is_some, config.label.alpha_cup'], simp,
  apply mem_imply_nnil [], simp [is_alpha_cup, alpha_cups'], exact ha,
end

-- one off from actual definition
def alpha (a : α) : ℕ :=
  if ha : a ∈ S then (option.get (l.alpha_cup'_is_some ha)).length else 0

-- APIs for alpha: First, existence of a cup with length alpha + 1
def alpha_cup {a : α} (ha : a ∈ S) :
  Σ' c : list α, c.length = l.alpha a + 1 ∧
    c.in S ∧ c.sorted (<) ∧ c.chain' l.slopeᶜ ∧ a ∈ c.last' :=
begin
  have some := l.alpha_cup'_is_some ha,
  set c := option.get some with def_c,
  rw alpha, rw dif_pos ha, rw ←def_c,
  have h_argmax := option.get_mem some,
  rw [←def_c, alpha_cup'] at h_argmax,
  have c_alpha_cup := list.argmax_mem h_argmax,
  simp [alpha_cups', is_alpha_cup] at c_alpha_cup,
  use (c ++ [a]), simp, tauto,
end

-- Next, maximality of the cup with length alpha + 1
def cup_length_le_alpha {a : α} {c : list α}
  (c_in_S : c.in S)
  (c_sorted : c.sorted (<))
  (c_chain : c.chain' l.slopeᶜ)
  (c_last : a ∈ c.last') : c.length ≤ l.alpha a + 1 :=
begin
  have ha : a ∈ S := c_in_S _ (list.mem_of_mem_last' c_last),
  have some := l.alpha_cup'_is_some ha,
  set d := option.get some with def_d,
  rw alpha, rw dif_pos ha, rw ←def_d,
  have h_argmax := option.get_mem some,
  rw [←def_d, alpha_cup'] at h_argmax,
  rcases list.take_last' c_last with ⟨c', eq_c⟩,
  subst eq_c, simp,
  have c'_alpha_cup : c' ∈ l.alpha_cups' a := begin
    rw alpha_cups', simp, split,
    { apply list.sublist_of_subperm_of_sorted _ _
        (finset.sort_sorted_lt S),
      apply list.nodup.subperm,
      apply @list.nodup.sublist _ _ (c' ++ [a]),
      simp, exact (list.sorted.nodup c_sorted),
      intros a ha, simp, simp at c_in_S, exact (c_in_S.left) _ ha,
      apply list.pairwise.sublist _ c_sorted, simp, },
    { refine ⟨_, _, _⟩; assumption },
  end,
  exact list.le_of_mem_argmax c'_alpha_cup h_argmax,
end

theorem add_alpha {a : α} (ha : a ∈ S)
  {n : ℕ} {c : list α} (c_in_S : c.in S)
  (c_cup : C.ncup n c) (c_head : a ∈ c.head') :
  C.has_ncup (n + l.alpha a) S :=
begin
  rcases (l.alpha_cup ha) with
    ⟨d, d_length, d_in_S, d_sorted, d_chain, d_last⟩,
  have d_cup : C.cup d := l.alpha_cup_is_cup
   _ d_in_S d_sorted d_chain,
  rcases list.take_last' d_last with ⟨d', eq_d⟩,
  rcases list.take_head' c_head with ⟨c', eq_c⟩,
  use d' ++ a :: c',
  by_cases hd' : d' = [],
  { subst hd', simp at eq_d, subst eq_d, simp at d_length, rw d_length,
    rw ←eq_c, split; simp; assumption, },
  rcases list.take_last hd' with ⟨p, d'', eq_d'⟩,
  cases c' with q c'',
  { subst eq_c, cases c_cup with _ c_len, simp at c_len,
    subst c_len, rw ←eq_d, refine ⟨⟨_, _⟩, _⟩,
    assumption, rw d_length, exact add_comm _ _, assumption, },
  rw eq_d', split,
  { rw [config.ncup], split, simp, refine ⟨_, _, _⟩,
    convert d_cup, rw [eq_d, eq_d'], simp,
    rw eq_d' at eq_d, simp at eq_d,
    rw eq_d at d_chain d_sorted d_in_S,
    rw eq_c at c_in_S c_cup,
    rw list.sorted at d_sorted,
    rw [config.ncup, config.cup] at c_cup,
    apply l.extend_left,
    simp at d_in_S; tauto, simp at d_in_S; tauto,
    have t := @list.pairwise.sublist
      _ _ [p, a] (d'' ++ [p, a]) _ d_sorted,
    simp at t, exact t, simp,
    simp at d_chain; tauto,
    simp at c_in_S; tauto,
    simp at c_cup; tauto,
    rw ←eq_c, exact c_cup.left,
    rw eq_d at d_length, simp at d_length,
    rw ←eq_c, rw ←eq_d', simp, rw d_length,
    rw c_cup.right, exact add_comm _ _, },
  { rw ←eq_c, rw ←eq_d', simp, rw eq_d at d_in_S,
    simp at d_in_S, tauto, },
end

end config.label

namespace config

variables (C) (S)

def is_beta_cup (a : α) (c : list α) : Prop :=
  (c ++ [a]).in S ∧ C.cup (c ++ [a])

instance decidable_is_beta_cup (a : α) (c : list α) :
  decidable (C.is_beta_cup S a c) := by rw is_beta_cup; apply_instance

def beta_cups' (a : α) : list (list α) :=
  (S.sort (≤)).sublists.filter (C.is_beta_cup S a)

def beta_cup' (a : α) : option (list α) :=
  (C.beta_cups' S a).argmax list.length

def beta_cup'_is_some {a : α} (ha : a ∈ S) :
  option.is_some (C.beta_cup' S a) :=
begin
  rw ←option.ne_none_iff_is_some, rw config.beta_cup', simp,
  apply mem_imply_nnil [], simp [is_beta_cup, beta_cups'], exact ha,
end

-- one off from actual definition
def beta (a : α) : ℕ :=
  if ha : a ∈ S then (option.get (C.beta_cup'_is_some S ha)).length else 0

-- APIs for beta: First, existence of a cup with length alpha + 1
def beta_cup {a : α} (ha : a ∈ S) :
  Σ' c : list α, c.in S ∧ C.ncup (C.beta S a + 1) c ∧ a ∈ c.last' :=
begin
  have some := C.beta_cup'_is_some S ha,
  set c := option.get some with def_c,
  rw beta, rw dif_pos ha, rw ←def_c,
  have h_argmax := option.get_mem some,
  rw [←def_c, beta_cup'] at h_argmax,
  have c_beta_cup := list.argmax_mem h_argmax,
  simp [beta_cups', is_beta_cup] at c_beta_cup,
  use (c ++ [a]), simp [config.ncup], tauto,
end

theorem has_beta_cup {a : α} (ha : a ∈ S) :
  C.has_ncup (C.beta S a + 1) S :=
begin
  rcases C.beta_cup S ha with ⟨c, c_in, c_cup, -⟩,
  use c, tauto,
end

-- Next, maximality of the cup with length alpha + 1
def cup_length_le_beta {a : α} {c : list α}
  (c_in_S : c.in S)
  (c_cup : C.cup c)
  (c_last : a ∈ c.last') : c.length ≤ C.beta S a + 1 :=
begin
  have ha : a ∈ S := c_in_S _ (list.mem_of_mem_last' c_last),
  have some := C.beta_cup'_is_some S ha,
  set d := option.get some with def_d,
  rw beta, rw dif_pos ha, rw ←def_d,
  have h_argmax := option.get_mem some,
  rw [←def_d, beta_cup'] at h_argmax,
  rcases list.take_last' c_last with ⟨c', eq_c⟩,
  subst eq_c, simp,
  have c_sorted := list.chain'_iff_pairwise.mp c_cup.left,
  have c'_beta_cup : c' ∈ C.beta_cups' S a := begin
    rw beta_cups', simp, split,
    { apply list.sublist_of_subperm_of_sorted _ _
        (finset.sort_sorted_lt S),
      apply list.nodup.subperm,
      apply @list.nodup.sublist _ _ (c' ++ [a]), simp,
      exact (list.sorted.nodup c_sorted),
      intros a ha, simp, simp at c_in_S, exact (c_in_S.left) _ ha,
      apply list.pairwise.sublist _ c_sorted, simp, },
    { split; assumption },
  end,
  exact list.le_of_mem_argmax c'_beta_cup h_argmax,
end

end config

variables (l) {C}

theorem config.label.alpha_le_beta {a : α} (ha : a ∈ S) :
  l.alpha a ≤ C.beta S a :=
begin
  rcases (l.alpha_cup ha) with
    ⟨c, c_length, c_in, c_sorted, c_chain, c_last⟩,
  have c_cup := l.alpha_cup_is_cup _ c_in c_sorted c_chain,
  have ineq := C.cup_length_le_beta S c_in c_cup c_last,
  rw c_length at ineq, simp at ineq, exact ineq,
end

variables {l}

theorem slope_ff_inc_alpha
  {a b : α} (sab : ¬l.slope a b)
  (ha : a ∈ S) (hb : b ∈ S) (a_le_b : a < b) :
  l.alpha a < l.alpha b :=
begin
  rcases (l.alpha_cup ha) with
    ⟨c, c_length, c_in, c_sorted, c_chain, c_last⟩,
  rcases list.take_last' c_last with ⟨c', c_eq⟩,
  rw [nat.lt_iff_add_one_le, ←(add_le_add_iff_right 1)],
  set d := c ++ [b] with def_d,
  have d_length : d.length = l.alpha a + 1 + 1 :=
    by simp [def_d, c_length],
  rw ←d_length,
  apply l.cup_length_le_alpha,
  { rw def_d, simp, tauto, },
  { rw [def_d, c_eq, list.sorted, ←list.chain'_iff_pairwise],
    simp, rw [list.chain'_iff_pairwise, ←list.sorted],
    rw ←c_eq, exact ⟨c_sorted, a_le_b⟩, },
  { rw [def_d, c_eq], simp, rw ←c_eq,
    exact ⟨c_chain, sab⟩, },
  { rw def_d, simp, },
end

theorem slope_tt_inc_beta
  {a b : α} (sab : l.slope a b)
  (ha : a ∈ S) (hb : b ∈ S) (a_le_b : a < b) :
  C.beta S a < C.beta S b :=
begin
  rcases (C.beta_cup S ha) with
    ⟨c, c_in, ⟨c_cup, c_length⟩, c_last⟩,
  rcases list.take_last' c_last with ⟨c', c_eq⟩,
  rw [nat.lt_iff_add_one_le, ←(add_le_add_iff_right 1)],
  set d := c ++ [b] with def_d,
  have d_length : d.length = C.beta S a + 1 + 1 :=
    by simp [def_d, c_length],
  rw ←d_length,
  apply C.cup_length_le_beta S; rw def_d,
  simp, split; assumption,
  apply c_cup.extend_right sab; try {simp}; try {assumption},
  simp,
end

variables (C)

theorem config.alpha_eq_beta_inc {a b : α}
  (ha : a ∈ S) (hb : b ∈ S) (h : l.alpha a = l.alpha b) :
  a < b ↔ C.beta S a < C.beta S b :=
begin
  split,
  { intro hab,
    by_cases hl : l.slope a b,
    apply slope_tt_inc_beta hl; assumption,
    have h' := slope_ff_inc_alpha hl ha hb hab,
    rw h at h', simp at h', exfalso, assumption, },
  { intro hab,
    rcases (lt_trichotomy a b) with a_lt_b | a_eq_b | b_lt_a,
    exact a_lt_b,
    subst a_eq_b, simp at hab, exfalso, assumption,
    exfalso, by_cases hl : l.slope b a,
    have h' := slope_tt_inc_beta hl hb ha b_lt_a,
    have h'' := lt_trans h' hab, simp at h'', exact h'',
    have h' := slope_ff_inc_alpha hl hb ha b_lt_a,
    rw h at h', simp at h', exact h', },
end

variables {C} (l)

theorem config.label.beta_eq_alpha_inc {a b : α}
  (ha : a ∈ S) (hb : b ∈ S) (h : C.beta S a = C.beta S b) :
  a < b ↔ l.alpha a < l.alpha b :=
begin
  split,
  { intro hab,
    by_cases hl : l.slope a b,
    have h' := slope_tt_inc_beta hl ha hb hab,
    rw h at h', simp at h', exfalso, assumption,
    apply slope_ff_inc_alpha hl; assumption, },
  { intro hab,
    rcases (lt_trichotomy a b) with a_lt_b | a_eq_b | b_lt_a,
    exact a_lt_b,
    subst a_eq_b, simp at hab, exfalso, assumption,
    exfalso, by_cases hl : l.slope b a,
    have h' := slope_tt_inc_beta hl hb ha b_lt_a,
    rw h at h', simp at h', exact h',
    have h' := slope_ff_inc_alpha hl hb ha b_lt_a,
    have h'' := lt_trans h' hab, simp at h'', exact h'', },
end


/-
Copyright (c) 2020 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Yury Kudryashov
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.topology.instances.real_vector_space
import Mathlib.analysis.normed_space.add_torsor
import Mathlib.linear_algebra.affine_space.midpoint
import Mathlib.analysis.normed_space.linear_isometry
import Mathlib.PostPort

universes u_1 u_2 u_3 u_4

namespace Mathlib

/-!
# Mazur-Ulam Theorem

Mazur-Ulam theorem states that an isometric bijection between two normed affine spaces over `ℝ` is
affine. We formalize it in three definitions:

* `isometric.to_real_linear_isometry_equiv_of_map_zero` : given `E ≃ᵢ F` sending `0` to `0`,
  returns `E ≃ₗᵢ[ℝ] F` with the same `to_fun` and `inv_fun`;
* `isometric.to_real_linear_isometry_equiv` : given `f : E ≃ᵢ F`,
  returns `g : E ≃ₗᵢ[ℝ] F` with `g x = f x - f 0`.
* `isometric.to_affine_equiv` : given `PE ≃ᵢ PF`, returns `g : PE ≃ᵃ[ℝ] PF` with the same
  `to_equiv`.

The formalization is based on [Jussi Väisälä, *A Proof of the Mazur-Ulam Theorem*][Vaisala_2003].

## Tags

isometry, affine map, linear map
-/

namespace isometric

/-- If an isometric self-homeomorphism of a normed vector space over `ℝ` fixes `x` and `y`,
then it fixes the midpoint of `[x, y]`. This is a lemma for a more general Mazur-Ulam theorem,
see below. -/
theorem midpoint_fixed {E : Type u_1} {PE : Type u_2} [normed_group E] [normed_space ℝ E] [metric_space PE] [normed_add_torsor E PE] {x : PE} {y : PE} (e : PE ≃ᵢ PE) : coe_fn e x = x → coe_fn e y = y → coe_fn e (midpoint ℝ x y) = midpoint ℝ x y := sorry

/-- A bijective isometry sends midpoints to midpoints. -/
theorem map_midpoint {E : Type u_1} {PE : Type u_2} [normed_group E] [normed_space ℝ E] [metric_space PE] [normed_add_torsor E PE] {F : Type u_3} {PF : Type u_4} [normed_group F] [normed_space ℝ F] [metric_space PF] [normed_add_torsor F PF] (f : PE ≃ᵢ PF) (x : PE) (y : PE) : coe_fn f (midpoint ℝ x y) = midpoint ℝ (coe_fn f x) (coe_fn f y) := sorry

/-!
Since `f : PE ≃ᵢ PF` sends midpoints to midpoints, it is an affine map.
We define a conversion to a `continuous_linear_equiv` first, then a conversion to an `affine_map`.
-/

/-- Mazur-Ulam Theorem: if `f` is an isometric bijection between two normed vector spaces
over `ℝ` and `f 0 = 0`, then `f` is a linear equivalence. -/
def to_real_linear_isometry_equiv_of_map_zero {E : Type u_1} [normed_group E] [normed_space ℝ E] {F : Type u_3} [normed_group F] [normed_space ℝ F] (f : E ≃ᵢ F) (h0 : coe_fn f 0 = 0) : linear_isometry_equiv ℝ E F :=
  linear_isometry_equiv.mk
    (linear_equiv.mk
      (linear_map.to_fun
        (continuous_linear_map.to_linear_map
          (add_monoid_hom.to_real_linear_map (add_monoid_hom.of_map_midpoint ℝ ℝ (⇑f) h0 sorry) sorry)))
      sorry sorry (equiv.inv_fun (to_equiv f)) sorry sorry)
    sorry

@[simp] theorem coe_to_real_linear_equiv_of_map_zero {E : Type u_1} [normed_group E] [normed_space ℝ E] {F : Type u_3} [normed_group F] [normed_space ℝ F] (f : E ≃ᵢ F) (h0 : coe_fn f 0 = 0) : ⇑(to_real_linear_isometry_equiv_of_map_zero f h0) = ⇑f :=
  rfl

@[simp] theorem coe_to_real_linear_equiv_of_map_zero_symm {E : Type u_1} [normed_group E] [normed_space ℝ E] {F : Type u_3} [normed_group F] [normed_space ℝ F] (f : E ≃ᵢ F) (h0 : coe_fn f 0 = 0) : ⇑(linear_isometry_equiv.symm (to_real_linear_isometry_equiv_of_map_zero f h0)) = ⇑(isometric.symm f) :=
  rfl

/-- Mazur-Ulam Theorem: if `f` is an isometric bijection between two normed vector spaces
over `ℝ`, then `x ↦ f x - f 0` is a linear equivalence. -/
def to_real_linear_isometry_equiv {E : Type u_1} [normed_group E] [normed_space ℝ E] {F : Type u_3} [normed_group F] [normed_space ℝ F] (f : E ≃ᵢ F) : linear_isometry_equiv ℝ E F :=
  to_real_linear_isometry_equiv_of_map_zero (isometric.trans f (isometric.symm (isometric.add_right (coe_fn f 0)))) sorry

@[simp] theorem to_real_linear_equiv_apply {E : Type u_1} [normed_group E] [normed_space ℝ E] {F : Type u_3} [normed_group F] [normed_space ℝ F] (f : E ≃ᵢ F) (x : E) : coe_fn (to_real_linear_isometry_equiv f) x = coe_fn f x - coe_fn f 0 :=
  Eq.symm (sub_eq_add_neg (coe_fn f x) (coe_fn f 0))

@[simp] theorem to_real_linear_isometry_equiv_symm_apply {E : Type u_1} [normed_group E] [normed_space ℝ E] {F : Type u_3} [normed_group F] [normed_space ℝ F] (f : E ≃ᵢ F) (y : F) : coe_fn (linear_isometry_equiv.symm (to_real_linear_isometry_equiv f)) y = coe_fn (isometric.symm f) (y + coe_fn f 0) :=
  rfl

/-- Convert an isometric equivalence between two affine spaces to an `affine_map`. -/
def to_affine_equiv {E : Type u_1} {PE : Type u_2} [normed_group E] [normed_space ℝ E] [metric_space PE] [normed_add_torsor E PE] {F : Type u_3} {PF : Type u_4} [normed_group F] [normed_space ℝ F] [metric_space PF] [normed_add_torsor F PF] (f : PE ≃ᵢ PF) : affine_equiv ℝ PE PF :=
  affine_equiv.mk' (to_equiv f)
    (linear_isometry_equiv.to_linear_equiv
      (to_real_linear_isometry_equiv
        (isometric.trans (vadd_const (classical.arbitrary PE))
          (isometric.trans f (isometric.symm (vadd_const (coe_fn f (classical.arbitrary PE))))))))
    (classical.arbitrary PE) sorry

@[simp] theorem coe_to_affine_equiv {E : Type u_1} {PE : Type u_2} [normed_group E] [normed_space ℝ E] [metric_space PE] [normed_add_torsor E PE] {F : Type u_3} {PF : Type u_4} [normed_group F] [normed_space ℝ F] [metric_space PF] [normed_add_torsor F PF] (f : PE ≃ᵢ PF) : ⇑(to_affine_equiv f) = ⇑f :=
  rfl


import category_theory.abelian.ext

import for_mathlib.derived_functor

noncomputable theory

universe variables uᵣ v u

open category_theory opposite

namespace Ext

variables (R : Type uᵣ) [ring R] {C : Type u} [category.{v} C] [abelian C] [linear R C]
  [enough_projectives C]

local notation `Ext` i `,` A `,` B := ((Ext R C i).obj (op A)).obj B

def δ (n : ℕ) (A : short_exact_sequence C) (B : C) :
  (Ext n , A.1 , B) ⟶ (Ext (n+1) , A.3 , B) :=
let E  := (((linear_yoneda R C).obj B).right_op.left_derived n),
    E' := (((linear_yoneda R C).obj B).right_op.left_derived (n+1)) in
quiver.hom.unop (show E'.obj A.3 ⟶ E.obj A.1, from functor.left_derived.δ _ _ _)

lemma six_term_exact_seq (n : ℕ) (A : short_exact_sequence C) (B : C) :
  exact_seq (Module.{v} R) [
    ((«Ext» R C n).map A.g.op).app B, ((«Ext» R C n).map A.f.op).app B,
    δ R n A B,
    ((«Ext» R C (n+1)).map A.g.op).app B, ((«Ext» R C (n+1)).map A.f.op).app B
    ] :=
begin
  apply exact_seq.of_op,
  exact functor.left_derived.six_term_exact_seq _ n A,
end

end «Ext»


import topology.subset_properties
import topology.homeomorph

namespace homeomorph

variables {α β : Type*} [topological_space α] [topological_space β]
  (e : α ≃ₜ β) [totally_disconnected_space α]

include e

--TODO: Golf and add to mathlib
protected lemma totally_disconnected_space : totally_disconnected_space β :=
begin
  constructor,
  rintros A - hA,
  suffices : (e.symm '' A).subsingleton,
  { intros x hx y hy,
    apply e.symm.injective,
    apply this,
    exact ⟨x, hx, rfl⟩,
    exact ⟨y, hy, rfl⟩ },
  obtain ⟨h⟩ := (infer_instance : totally_disconnected_space α),
  apply h,
  { tauto },
  { exact is_preconnected.image hA _ e.symm.continuous.continuous_on }
end

end homeomorph


import pseudo_normed_group.category
import data.set.intervals
import for_mathlib.Profinite.extend
import condensed.ab

.

open_locale big_operators

universe u
variable (S : Fintype.{u})

@[derive add_comm_group]
def free_pfpng := S → ℤ

noncomputable theory
open_locale classical

instance : has_nnnorm (free_pfpng S) :=
⟨λ f, ∑ s, ∥f s∥₊⟩

namespace free_pfpng

@[simp] lemma nnnorm_zero : ∥(0 : free_pfpng S)∥₊ = 0 :=
by { change ∑ _, _ = _, simp }

@[simp] lemma nnnorm_neg (f : free_pfpng S) : ∥(-f)∥₊ = ∥f∥₊ :=
by { change ∑ _, _ = _, simpa }

lemma nnnorm_add (f₁ f₂ : free_pfpng S) : ∥f₁ + f₂∥₊ ≤ ∥f₁∥₊ + ∥f₂∥₊ :=
begin
  change ∑ _, _ ≤ ∑ _, _ + ∑ _, _,
  rw ← finset.sum_add_distrib,
  apply finset.sum_le_sum,
  intros s _,
  apply nnnorm_add_le,
end

instance (c) : topological_space { f : free_pfpng S | ∥f∥₊ ≤ c } := ⊥
instance (c) : discrete_topology { f : free_pfpng S | ∥f∥₊ ≤ c } := ⟨rfl⟩

lemma norm_eval_le {c : nnreal} {s : S}
  (f : free_pfpng S) (hf : ∥f∥₊ ≤ c) : ∥f s∥₊ ≤ c :=
le_trans (begin
  apply @finset.single_le_sum S nnreal _ (λ t, ∥f t∥₊) finset.univ,
  { intros _ _, apply zero_le },
  { exact finset.mem_univ s }
end) hf

instance (c) : fintype { f : free_pfpng S | ∥f∥₊ ≤ c } :=
begin
  let A := { f : free_pfpng S | ∥f∥₊ ≤ c },
  have h : ∃ (N : ℕ), c ≤ N := ⟨nat.ceil c, nat.le_ceil c⟩,
  let N := h.some, let hN : c ≤ N := h.some_spec,
  let ι : A → S → set.Icc (-(N : ℤ)) N :=
    λ a s, ⟨a.1 s, _, _⟩,
  rotate,
  { -- I'm sure there is a more efficient way to do this...
    have : - ∥a.val s∥ ≤ a.val s := neg_abs_le_self ↑(a.val s),
    replace this : - (c : ℝ) ≤ a.val s := le_trans _ this,
    swap,
    { simp only [subtype.val_eq_coe, neg_le_neg_iff],
      exact_mod_cast (norm_eval_le S a.val a.2) },
    replace this : -(N : ℝ) ≤ _ := le_trans _ this,
    swap,
    { rw [neg_le_neg_iff], exact_mod_cast hN },
    exact_mod_cast this },
  { have : ↑(a.val s) ≤ ∥a.val s∥ := le_max_left _ _,
    replace this : ↑(a.val s) ≤ (c : ℝ) := le_trans this _,
    swap, { exact_mod_cast (norm_eval_le S a.val a.2) },
    replace this := le_trans this hN,
    push_cast at this,
    exact_mod_cast this },
  have : function.injective ι,
  { rintros ⟨f,hf⟩ ⟨g,hg⟩ h,
    ext s,
    apply_fun (λ e, (e s).1) at h,
    assumption },
  apply fintype.of_injective ι this,
end

instance : profinitely_filtered_pseudo_normed_group (free_pfpng S) :=
{ filtration := λ c, { f | ∥ f ∥₊ ≤ c },
  filtration_mono := λ c₁ c₂ h f hf, le_trans hf h,
  zero_mem_filtration := λ c, by simp,
  neg_mem_filtration := λ c f hf, by simpa,
  add_mem_filtration := λ c₁ c₂ f₁ f₂ h₁ h₂,
    le_trans (nnnorm_add _ _ _) (add_le_add h₁ h₂),
  continuous_add' := λ c₁ c₂,
    continuous_of_discrete_topology,
  continuous_neg' := λ c, continuous_of_discrete_topology,
  continuous_cast_le := λ _ _ _, continuous_of_discrete_topology,
  ..(infer_instance : add_comm_group (free_pfpng S)) }

def map {S₁ S₂ : Fintype.{u}} (g : S₁ ⟶ S₂) :
  strict_comphaus_filtered_pseudo_normed_group_hom
  (free_pfpng S₁) (free_pfpng S₂) :=
{ to_fun := λ f s, ∑ t in finset.univ.filter (λ w, g w = s), f t,
  map_zero' := by simpa,
  map_add' := λ f g, by simpa [finset.sum_add_distrib],
  strict' := begin
    intros c f hf,
    refine le_trans _ hf,
    change ∑ s₂, ∥(∑ t in finset.univ.filter (λ w, g w = s₂), f t)∥₊ ≤
      ∑ s₁, _,
    have : ∑ s₂, ∥(∑ t in finset.univ.filter (λ w, g w = s₂), f t)∥₊ ≤
      ∑ s₂ : S₂, ∑ t in finset.univ.filter (λ w, g w = s₂), ∥f t∥₊,
    { apply finset.sum_le_sum,
      intros i _,
      apply nnnorm_sum_le },
    refine le_trans this _,
    rw ← finset.sum_bUnion,
    apply le_of_eq,
    apply finset.sum_congr,
    { rw finset.eq_univ_iff_forall,
      intros x,
      rw finset.mem_bUnion,
      use [g x, by simp] },
    { intros s₁ _, refl },
    { intros x _ y _ h,
      rintros a hh,
      apply h,
      simp only [finset.inf_eq_inter, finset.mem_inter, finset.mem_filter,
        finset.mem_univ, true_and] at hh,
      rw [← hh.1, ← hh.2] }
  end,
  continuous' := λ c, continuous_of_discrete_topology }

@[simp]
lemma map_id : map (𝟙 S) =
  strict_comphaus_filtered_pseudo_normed_group_hom.id :=
begin
  ext s,
  dsimp [map],
  simp [finset.filter_congr_decidable, finset.sum_filter],
end

@[simp]
lemma map_comp {S₁ S₂ S₃ : Fintype.{u}}
  (g₁ : S₁ ⟶ S₂) (g₂ : S₂ ⟶ S₃) :
  map (g₁ ≫ g₂) =
  (map g₂).comp (map g₁) :=
begin
  ext s₃,
  dsimp [map],
  erw ← finset.sum_bUnion,
  apply finset.sum_congr,
  { ext s,
    split,
    { intro h, simp only [finset.mem_filter, finset.mem_univ, true_and] at h,
      rw finset.mem_bUnion,
      use [g₁ s, by simpa] },
    { intro h, simp only [finset.mem_bUnion, finset.mem_filter,
      finset.mem_univ, true_and, exists_prop, exists_eq_right'] at h,
      simpa, } },
  { intros s₁ h,
    rw finset.mem_bUnion at h },
  { intros x hx y hy,
    simp only [finset.coe_filter, finset.coe_univ, set.sep_univ,
      set.mem_set_of_eq] at hx hy,
    intros h a ha,
    simp only [finset.inf_eq_inter, finset.mem_inter, finset.mem_filter,
      finset.mem_univ, true_and] at ha,
    apply h, rw [← ha.1, ← ha.2] }
end

end free_pfpng

@[simps]
def free_pfpng_functor : Fintype ⥤ ProFiltPseuNormGrp₁ :=
{ obj := λ S,
  { M := free_pfpng S,
    exhaustive' := λ f, ⟨∥f∥₊, le_refl _⟩ },
  map := λ S₁ S₂ f, free_pfpng.map f,
  map_id' := free_pfpng.map_id,
  map_comp' := λ _ _ _ g₁ g₂, free_pfpng.map_comp g₁ g₂ }

def Fintype.free_pfpng (T : Fintype) : ProFiltPseuNormGrp₁ :=
free_pfpng_functor.obj T

def Fintype.free_pfpng_unit :
  Fintype.to_Profinite ⟶ free_pfpng_functor ⋙ ProFiltPseuNormGrp₁.level.obj 1 :=
{ app := λ S,
  { to_fun := λ s,
    { val := λ t, if s = t then 1 else 0,
      property := begin
        show finset.sum _ _ ≤ _,
        rw finset.sum_eq_single_of_mem,
        swap 4, { exact s }, swap 2, { apply finset.mem_univ },
        { dsimp, rw [if_pos rfl, nnnorm_one], },
        rintro t - ht, dsimp, rw [if_neg ht.symm, nnnorm_zero],
      end },
    continuous_to_fun := continuous_bot },
  naturality' := λ S T f, begin
    ext s t,
    delta ProFiltPseuNormGrp₁.level,
    simp only [Fintype.to_Profinite_map_apply, Profinite.coe_comp, continuous_map.coe_mk,
      function.comp_app, subtype.coe_mk, category_theory.functor.comp_map, free_pfpng_functor_map,
      pseudo_normed_group.level_coe, subtype.coe_mk, free_pfpng.map, finset.mem_filter, true_and,
      finset.mem_univ, strict_comphaus_filtered_pseudo_normed_group_hom.coe_mk, finset.sum_ite_eq],
  end }

def Profinite.free_pfpng (S : Profinite) : ProFiltPseuNormGrp₁ :=
(Profinite.extend free_pfpng_functor).obj S

open category_theory
open category_theory.limits

def Profinite.free_pfpng_level_iso (S : Profinite.{u}) (r) :
  (ProFiltPseuNormGrp₁.level.obj r).obj S.free_pfpng ≅
  limits.limit (S.fintype_diagram ⋙ free_pfpng_functor ⋙ ProFiltPseuNormGrp₁.level.obj r) :=
(is_limit_of_preserves (ProFiltPseuNormGrp₁.level.obj r)
  (limit.is_limit _)).cone_point_unique_up_to_iso $ limit.is_limit _

def Profinite.to_free_pfpng (S : Profinite.{u}) :
  S ⟶ (ProFiltPseuNormGrp₁.level.obj 1).obj S.free_pfpng :=
(limit.is_limit _).map S.as_limit_cone (whisker_left _ $ Fintype.free_pfpng_unit.{u u}) ≫
(S.free_pfpng_level_iso 1).inv

--(limits.is_limit_of_preserves (ProFiltPseuNormGrp₁.level.obj 1) (limits.limit.is_limit _)).map
--  S.as_limit_cone $ whisker_left _ (Fintype.free_pfpng_unit) ≫ (functor.associator _ _ _).inv

def Profinite.free_pfpng_π (S : Profinite) (T : discrete_quotient S) :
  S.free_pfpng ⟶ (Fintype.of T).free_pfpng :=
category_theory.limits.limit.π _ _

lemma Profinite.free_pfpng_π_w (S : Profinite) {T₁ T₂ : discrete_quotient S} (f : T₁ ⟶ T₂) :
  Profinite.free_pfpng_π S T₁ ≫ (S.fintype_diagram ⋙ free_pfpng_functor).map f =
  Profinite.free_pfpng_π S T₂ :=
category_theory.limits.limit.w (S.fintype_diagram ⋙ free_pfpng_functor) _


/-
Copyright (c) 2019 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Bhavik Mehta
-/
import category_theory.structured_arrow
import category_theory.punit
import category_theory.reflects_isomorphisms
import category_theory.epi_mono

/-!
# Over and under categories

Over (and under) categories are special cases of comma categories.
* If `L` is the identity functor and `R` is a constant functor, then `comma L R` is the "slice" or
  "over" category over the object `R` maps to.
* Conversely, if `L` is a constant functor and `R` is the identity functor, then `comma L R` is the
  "coslice" or "under" category under the object `L` maps to.

## Tags

comma, slice, coslice, over, under
-/

namespace category_theory

universes v₁ v₂ u₁ u₂ -- morphism levels before object levels. See note [category_theory universes].
variables {T : Type u₁} [category.{v₁} T]

/--
The over category has as objects arrows in `T` with codomain `X` and as morphisms commutative
triangles.

See https://stacks.math.columbia.edu/tag/001G.
-/
@[derive category]
def over (X : T) := costructured_arrow (𝟭 T) X

-- Satisfying the inhabited linter
instance over.inhabited [inhabited T] : inhabited (over (default T)) :=
{ default :=
  { left := default T,
    hom := 𝟙 _ } }

namespace over

variables {X : T}

@[ext] lemma over_morphism.ext {X : T} {U V : over X} {f g : U ⟶ V}
  (h : f.left = g.left) : f = g :=
by tidy

@[simp] lemma over_right (U : over X) : U.right = punit.star := by tidy

@[simp] lemma id_left (U : over X) : comma_morphism.left (𝟙 U) = 𝟙 U.left := rfl
@[simp] lemma comp_left (a b c : over X) (f : a ⟶ b) (g : b ⟶ c) :
  (f ≫ g).left = f.left ≫ g.left := rfl

@[simp, reassoc] lemma w {A B : over X} (f : A ⟶ B) : f.left ≫ B.hom = A.hom :=
by have := f.w; tidy

/-- To give an object in the over category, it suffices to give a morphism with codomain `X`. -/
@[simps]
def mk {X Y : T} (f : Y ⟶ X) : over X :=
costructured_arrow.mk f

/-- We can set up a coercion from arrows with codomain `X` to `over X`. This most likely should not
    be a global instance, but it is sometimes useful. -/
def coe_from_hom {X Y : T} : has_coe (Y ⟶ X) (over X) :=
{ coe := mk }

section
local attribute [instance] coe_from_hom

@[simp] lemma coe_hom {X Y : T} (f : Y ⟶ X) : (f : over X).hom = f := rfl
end

/-- To give a morphism in the over category, it suffices to give an arrow fitting in a commutative
    triangle. -/
@[simps]
def hom_mk {U V : over X} (f : U.left ⟶ V.left) (w : f ≫ V.hom = U.hom . obviously) :
  U ⟶ V :=
costructured_arrow.hom_mk f w

/--
Construct an isomorphism in the over category given isomorphisms of the objects whose forward
direction gives a commutative triangle.
-/
@[simps]
def iso_mk {f g : over X} (hl : f.left ≅ g.left) (hw : hl.hom ≫ g.hom = f.hom . obviously) :
  f ≅ g :=
costructured_arrow.iso_mk hl hw

section
variable (X)
/--
The forgetful functor mapping an arrow to its domain.

See https://stacks.math.columbia.edu/tag/001G.
-/
def forget : over X ⥤ T := comma.fst _ _

end

@[simp] lemma forget_obj {U : over X} : (forget X).obj U = U.left := rfl
@[simp] lemma forget_map {U V : over X} {f : U ⟶ V} : (forget X).map f = f.left := rfl

/--
A morphism `f : X ⟶ Y` induces a functor `over X ⥤ over Y` in the obvious way.

See https://stacks.math.columbia.edu/tag/001G.
-/
def map {Y : T} (f : X ⟶ Y) : over X ⥤ over Y := comma.map_right _ $ discrete.nat_trans (λ _, f)

section
variables {Y : T} {f : X ⟶ Y} {U V : over X} {g : U ⟶ V}
@[simp] lemma map_obj_left : ((map f).obj U).left = U.left := rfl
@[simp] lemma map_obj_hom  : ((map f).obj U).hom  = U.hom ≫ f := rfl
@[simp] lemma map_map_left : ((map f).map g).left = g.left := rfl

/-- Mapping by the identity morphism is just the identity functor. -/
def map_id : map (𝟙 Y) ≅ 𝟭 _ :=
nat_iso.of_components (λ X, iso_mk (iso.refl _) (by tidy)) (by tidy)

/-- Mapping by the composite morphism `f ≫ g` is the same as mapping by `f` then by `g`. -/
def map_comp {Y Z : T} (f : X ⟶ Y) (g : Y ⟶ Z) : map (f ≫ g) ≅ map f ⋙ map g :=
nat_iso.of_components (λ X, iso_mk (iso.refl _) (by tidy)) (by tidy)

end

instance forget_reflects_iso : reflects_isomorphisms (forget X) :=
{ reflects := λ Y Z f t, by exactI
  ⟨⟨over.hom_mk (inv ((forget X).map f))
      ((as_iso ((forget X).map f)).inv_comp_eq.2 (over.w f).symm),
    by tidy⟩⟩ }

instance forget_faithful : faithful (forget X) := {}.

/--
If `k.left` is an epimorphism, then `k` is an epimorphism. In other words, `over.forget X` reflects
epimorphisms.
The converse does not hold without additional assumptions on the underlying category.
-/
-- TODO: Show the converse holds if `T` has binary products or pushouts.
lemma epi_of_epi_left {f g : over X} (k : f ⟶ g) [hk : epi k.left] : epi k :=
faithful_reflects_epi (forget X) hk

/--
If `k.left` is a monomorphism, then `k` is a monomorphism. In other words, `over.forget X` reflects
monomorphisms.
The converse of `category_theory.over.mono_left_of_mono`.

This lemma is not an instance, to avoid loops in type class inference.
-/
lemma mono_of_mono_left {f g : over X} (k : f ⟶ g) [hk : mono k.left] : mono k :=
faithful_reflects_mono (forget X) hk

/--
If `k` is a monomorphism, then `k.left` is a monomorphism. In other words, `over.forget X` preserves
monomorphisms.
The converse of `category_theory.over.mono_of_mono_left`.
-/
instance mono_left_of_mono {f g : over X} (k : f ⟶ g) [mono k] : mono k.left :=
begin
  refine ⟨λ (Y : T) l m a, _⟩,
  let l' : mk (m ≫ f.hom) ⟶ f := hom_mk l (by { dsimp, rw [←over.w k, reassoc_of a] }),
  suffices : l' = hom_mk m,
  { apply congr_arg comma_morphism.left this },
  rw ← cancel_mono k,
  ext,
  apply a,
end

section iterated_slice
variables (f : over X)

/-- Given f : Y ⟶ X, this is the obvious functor from (T/X)/f to T/Y -/
@[simps]
def iterated_slice_forward : over f ⥤ over f.left :=
{ obj := λ α, over.mk α.hom.left,
  map := λ α β κ, over.hom_mk κ.left.left (by { rw auto_param_eq, rw ← over.w κ, refl }) }

/-- Given f : Y ⟶ X, this is the obvious functor from T/Y to (T/X)/f -/
@[simps]
def iterated_slice_backward : over f.left ⥤ over f :=
{ obj := λ g, mk (hom_mk g.hom : mk (g.hom ≫ f.hom) ⟶ f),
  map := λ g h α, hom_mk (hom_mk α.left (w_assoc α f.hom)) (over_morphism.ext (w α)) }

/-- Given f : Y ⟶ X, we have an equivalence between (T/X)/f and T/Y -/
@[simps]
def iterated_slice_equiv : over f ≌ over f.left :=
{ functor := iterated_slice_forward f,
  inverse := iterated_slice_backward f,
  unit_iso :=
    nat_iso.of_components
    (λ g, over.iso_mk (over.iso_mk (iso.refl _) (by tidy)) (by tidy))
    (λ X Y g, by { ext, dsimp, simp }),
  counit_iso :=
    nat_iso.of_components
    (λ g, over.iso_mk (iso.refl _) (by tidy))
    (λ X Y g, by { ext, dsimp, simp }) }

lemma iterated_slice_forward_forget :
  iterated_slice_forward f ⋙ forget f.left = forget f ⋙ forget X :=
rfl

lemma iterated_slice_backward_forget_forget :
  iterated_slice_backward f ⋙ forget f ⋙ forget X = forget f.left :=
rfl

end iterated_slice

section
variables {D : Type u₂} [category.{v₂} D]

/-- A functor `F : T ⥤ D` induces a functor `over X ⥤ over (F.obj X)` in the obvious way. -/
@[simps]
def post (F : T ⥤ D) : over X ⥤ over (F.obj X) :=
{ obj := λ Y, mk $ F.map Y.hom,
  map := λ Y₁ Y₂ f,
  { left := F.map f.left,
    w' := by tidy; erw [← F.map_comp, w] } }

end

end over

/-- The under category has as objects arrows with domain `X` and as morphisms commutative
    triangles. -/
@[derive category]
def under (X : T) := structured_arrow X (𝟭 T)

-- Satisfying the inhabited linter
instance under.inhabited [inhabited T] : inhabited (under (default T)) :=
{ default :=
  { right := default T,
    hom := 𝟙 _ } }

namespace under

variables {X : T}

@[ext] lemma under_morphism.ext {X : T} {U V : under X} {f g : U ⟶ V}
  (h : f.right = g.right) : f = g :=
by tidy

@[simp] lemma under_left (U : under X) : U.left = punit.star := by tidy

@[simp] lemma id_right (U : under X) : comma_morphism.right (𝟙 U) = 𝟙 U.right := rfl
@[simp] lemma comp_right (a b c : under X) (f : a ⟶ b) (g : b ⟶ c) :
  (f ≫ g).right = f.right ≫ g.right := rfl

@[simp, reassoc] lemma w {A B : under X} (f : A ⟶ B) : A.hom ≫ f.right = B.hom :=
by have := f.w; tidy

/-- To give an object in the under category, it suffices to give an arrow with domain `X`. -/
@[simps]
def mk {X Y : T} (f : X ⟶ Y) : under X :=
structured_arrow.mk f

/-- To give a morphism in the under category, it suffices to give a morphism fitting in a
    commutative triangle. -/
@[simps]
def hom_mk {U V : under X} (f : U.right ⟶ V.right) (w : U.hom ≫ f = V.hom . obviously) :
  U ⟶ V :=
structured_arrow.hom_mk f w

/--
Construct an isomorphism in the over category given isomorphisms of the objects whose forward
direction gives a commutative triangle.
-/
def iso_mk {f g : under X} (hr : f.right ≅ g.right) (hw : f.hom ≫ hr.hom = g.hom) : f ≅ g :=
structured_arrow.iso_mk hr hw

@[simp]
lemma iso_mk_hom_right {f g : under X} (hr : f.right ≅ g.right) (hw : f.hom ≫ hr.hom = g.hom) :
  (iso_mk hr hw).hom.right = hr.hom := rfl

@[simp]
lemma iso_mk_inv_right {f g : under X} (hr : f.right ≅ g.right) (hw : f.hom ≫ hr.hom = g.hom) :
  (iso_mk hr hw).inv.right = hr.inv := rfl

section
variables (X)
/-- The forgetful functor mapping an arrow to its domain. -/
def forget : under X ⥤ T := comma.snd _ _

end

@[simp] lemma forget_obj {U : under X} : (forget X).obj U = U.right := rfl
@[simp] lemma forget_map {U V : under X} {f : U ⟶ V} : (forget X).map f = f.right := rfl

/-- A morphism `X ⟶ Y` induces a functor `under Y ⥤ under X` in the obvious way. -/
def map {Y : T} (f : X ⟶ Y) : under Y ⥤ under X := comma.map_left _ $ discrete.nat_trans (λ _, f)

section
variables {Y : T} {f : X ⟶ Y} {U V : under Y} {g : U ⟶ V}
@[simp] lemma map_obj_right : ((map f).obj U).right = U.right := rfl
@[simp] lemma map_obj_hom   : ((map f).obj U).hom   = f ≫ U.hom := rfl
@[simp] lemma map_map_right : ((map f).map g).right = g.right := rfl

/-- Mapping by the identity morphism is just the identity functor. -/
def map_id : map (𝟙 Y) ≅ 𝟭 _ :=
nat_iso.of_components (λ X, iso_mk (iso.refl _) (by tidy)) (by tidy)

/-- Mapping by the composite morphism `f ≫ g` is the same as mapping by `f` then by `g`. -/
def map_comp {Y Z : T} (f : X ⟶ Y) (g : Y ⟶ Z) : map (f ≫ g) ≅ map g ⋙ map f :=
nat_iso.of_components (λ X, iso_mk (iso.refl _) (by tidy)) (by tidy)

end

section
variables {D : Type u₂} [category.{v₂} D]

/-- A functor `F : T ⥤ D` induces a functor `under X ⥤ under (F.obj X)` in the obvious way. -/
@[simps]
def post {X : T} (F : T ⥤ D) : under X ⥤ under (F.obj X) :=
{ obj := λ Y, mk $ F.map Y.hom,
  map := λ Y₁ Y₂ f,
  { right := F.map f.right,
    w' := by tidy; erw [← F.map_comp, w] } }

end

end under

end category_theory


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

! This file was ported from Lean 3 source module category_theory.enriched.basic
! leanprover-community/mathlib commit c3019c79074b0619edb4b27553a91b2e82242395
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Monoidal.Types
import Mathbin.CategoryTheory.Monoidal.Center
import Mathbin.Tactic.ApplyFun

/-!
# Enriched categories

We set up the basic theory of `V`-enriched categories,
for `V` an arbitrary monoidal category.

We do not assume here that `V` is a concrete category,
so there does not need to be a "honest" underlying category!

Use `X ⟶[V] Y` to obtain the `V` object of morphisms from `X` to `Y`.

This file contains the definitions of `V`-enriched categories and
`V`-functors.

We don't yet define the `V`-object of natural transformations
between a pair of `V`-functors (this requires limits in `V`),
but we do provide a presheaf isomorphic to the Yoneda embedding of this object.

We verify that when `V = Type v`, all these notion reduce to the usual ones.
-/

universe w v u₁ u₂ u₃

noncomputable section

namespace CategoryTheory

open Opposite

open MonoidalCategory

variable (V : Type v) [Category.{w} V] [MonoidalCategory V]

/- ./././Mathport/Syntax/Translate/Command.lean:401:24: unsupported: (notation) in structure -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `«expr ⟶[] » -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `«expr ⟶[] » -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `«expr ⟶[] » -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `«expr ⟶[] » -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `«expr ⟶[] » -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `«expr ⟶[] » -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/-- A `V`-category is a category enriched in a monoidal category `V`.

Note that we do not assume that `V` is a concrete category,
so there may not be an "honest" underlying category at all!
-/
class EnrichedCategory (C : Type u₁) where
  Hom : C → C → V
  id : ∀ X, 𝟙_ V ⟶ «expr ⟶[] » X X
  comp : ∀ X Y Z, «expr ⟶[] » X Y ⊗ «expr ⟶[] » Y Z ⟶ «expr ⟶[] » X Z
  id_comp : ∀ X Y, (λ_ («expr ⟶[] » X Y)).inv ≫ (id X ⊗ 𝟙 _) ≫ comp X X Y = 𝟙 _ := by obviously
  comp_id : ∀ X Y, (ρ_ («expr ⟶[] » X Y)).inv ≫ (𝟙 _ ⊗ id Y) ≫ comp X Y Y = 𝟙 _ := by obviously
  and_assoc :
    ∀ W X Y Z,
      (α_ _ _ _).inv ≫ (comp W X Y ⊗ 𝟙 _) ≫ comp W Y Z = (𝟙 _ ⊗ comp X Y Z) ≫ comp W X Z := by
    obviously
#align category_theory.enriched_category CategoryTheory.EnrichedCategory

-- mathport name: enriched_category.hom
notation X " ⟶[" V "] " Y:10 => (EnrichedCategory.hom X Y : V)

variable (V) {C : Type u₁} [EnrichedCategory V C]

/-- The `𝟙_ V`-shaped generalized element giving the identity in a `V`-enriched category.
-/
def eId (X : C) : 𝟙_ V ⟶ X ⟶[V] X :=
  EnrichedCategory.id X
#align category_theory.e_id CategoryTheory.eId

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/-- The composition `V`-morphism for a `V`-enriched category.
-/
def eComp (X Y Z : C) : ((X ⟶[V] Y) ⊗ Y ⟶[V] Z) ⟶ X ⟶[V] Z :=
  EnrichedCategory.comp X Y Z
#align category_theory.e_comp CategoryTheory.eComp

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
-- We don't just use `restate_axiom` here; that would leave `V` as an implicit argument.
@[simp, reassoc.1]
theorem eId_comp (X Y : C) : (λ_ (X ⟶[V] Y)).inv ≫ (eId V X ⊗ 𝟙 _) ≫ eComp V X X Y = 𝟙 (X ⟶[V] Y) :=
  EnrichedCategory.id_comp X Y
#align category_theory.e_id_comp CategoryTheory.eId_comp

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
@[simp, reassoc.1]
theorem eComp_id (X Y : C) : (ρ_ (X ⟶[V] Y)).inv ≫ (𝟙 _ ⊗ eId V Y) ≫ eComp V X Y Y = 𝟙 (X ⟶[V] Y) :=
  EnrichedCategory.comp_id X Y
#align category_theory.e_comp_id CategoryTheory.eComp_id

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
@[simp, reassoc.1]
theorem e_assoc (W X Y Z : C) :
    (α_ _ _ _).inv ≫ (eComp V W X Y ⊗ 𝟙 _) ≫ eComp V W Y Z =
      (𝟙 _ ⊗ eComp V X Y Z) ≫ eComp V W X Z :=
  EnrichedCategory.assoc W X Y Z
#align category_theory.e_assoc CategoryTheory.e_assoc

section

variable {V} {W : Type v} [Category.{w} W] [MonoidalCategory W]

/-- A type synonym for `C`, which should come equipped with a `V`-enriched category structure.
In a moment we will equip this with the `W`-enriched category structure
obtained by applying the functor `F : lax_monoidal_functor V W` to each hom object.
-/
@[nolint has_nonempty_instance unused_arguments]
def TransportEnrichment (F : LaxMonoidalFunctor V W) (C : Type u₁) :=
  C
#align category_theory.transport_enrichment CategoryTheory.TransportEnrichment

instance (F : LaxMonoidalFunctor V W) : EnrichedCategory W (TransportEnrichment F C)
    where
  Hom := fun X Y : C => F.obj (X ⟶[V] Y)
  id := fun X : C => F.ε ≫ F.map (eId V X)
  comp := fun X Y Z : C => F.μ _ _ ≫ F.map (eComp V X Y Z)
  id_comp X Y := by
    rw [comp_tensor_id, category.assoc, ← F.to_functor.map_id, F.μ_natural_assoc,
      F.to_functor.map_id, F.left_unitality_inv_assoc, ← F.to_functor.map_comp, ←
      F.to_functor.map_comp, e_id_comp, F.to_functor.map_id]
  comp_id X Y := by
    rw [id_tensor_comp, category.assoc, ← F.to_functor.map_id, F.μ_natural_assoc,
      F.to_functor.map_id, F.right_unitality_inv_assoc, ← F.to_functor.map_comp, ←
      F.to_functor.map_comp, e_comp_id, F.to_functor.map_id]
  and_assoc P Q R S := by
    rw [comp_tensor_id, category.assoc, ← F.to_functor.map_id, F.μ_natural_assoc,
      F.to_functor.map_id, ← F.associativity_inv_assoc, ← F.to_functor.map_comp, ←
      F.to_functor.map_comp, e_assoc, id_tensor_comp, category.assoc, ← F.to_functor.map_id,
      F.μ_natural_assoc, F.to_functor.map_comp]

end

/-- Construct an honest category from a `Type v`-enriched category.
-/
def categoryOfEnrichedCategoryType (C : Type u₁) [𝒞 : EnrichedCategory (Type v) C] : Category.{v} C
    where
  Hom := 𝒞.Hom
  id X := eId (Type v) X PUnit.unit
  comp X Y Z f g := eComp (Type v) X Y Z ⟨f, g⟩
  id_comp' X Y f := congr_fun (eId_comp (Type v) X Y) f
  comp_id' X Y f := congr_fun (eComp_id (Type v) X Y) f
  assoc' W X Y Z f g h := (congr_fun (e_assoc (Type v) W X Y Z) ⟨f, g, h⟩ : _)
#align category_theory.category_of_enriched_category_Type CategoryTheory.categoryOfEnrichedCategoryType

/-- Construct a `Type v`-enriched category from an honest category.
-/
def enrichedCategoryTypeOfCategory (C : Type u₁) [𝒞 : Category.{v} C] : EnrichedCategory (Type v) C
    where
  Hom := 𝒞.Hom
  id X p := 𝟙 X
  comp X Y Z p := p.1 ≫ p.2
  id_comp X Y := by
    ext
    simp
  comp_id X Y := by
    ext
    simp
  and_assoc W X Y Z := by
    ext ⟨f, g, h⟩
    simp
#align category_theory.enriched_category_Type_of_category CategoryTheory.enrichedCategoryTypeOfCategory

/-- We verify that an enriched category in `Type u` is just the same thing as an honest category.
-/
def enrichedCategoryTypeEquivCategory (C : Type u₁) : EnrichedCategory (Type v) C ≃ Category.{v} C
    where
  toFun 𝒞 := category_of_enriched_category_Type C
  invFun 𝒞 := enriched_category_Type_of_category C
  left_inv 𝒞 := by
    cases 𝒞
    dsimp [enriched_category_Type_of_category]
    congr
    · ext (X⟨⟩)
      rfl
    · ext (X Y Z⟨f, g⟩)
      rfl
  right_inv 𝒞 := by
    rcases 𝒞 with @⟨@⟨⟨⟩⟩⟩
    dsimp
    congr
#align category_theory.enriched_category_Type_equiv_category CategoryTheory.enrichedCategoryTypeEquivCategory

section

variable {W : Type (v + 1)} [Category.{v} W] [MonoidalCategory W] [EnrichedCategory W C]

/-- A type synonym for `C`, which should come equipped with a `V`-enriched category structure.
In a moment we will equip this with the (honest) category structure
so that `X ⟶ Y` is `(𝟙_ W) ⟶ (X ⟶[W] Y)`.

We obtain this category by
transporting the enrichment in `V` along the lax monoidal functor `coyoneda_tensor_unit`,
then using the equivalence of `Type`-enriched categories with honest categories.

This is sometimes called the "underlying" category of an enriched category,
although some care is needed as the functor `coyoneda_tensor_unit`,
which always exists, does not necessarily coincide with
"the forgetful functor" from `V` to `Type`, if such exists.
When `V` is any of `Type`, `Top`, `AddCommGroup`, or `Module R`,
`coyoneda_tensor_unit` is just the usual forgetful functor, however.
For `V = Algebra R`, the usual forgetful functor is coyoneda of `R[X]`, not of `R`.
(Perhaps we should have a typeclass for this situation: `concrete_monoidal`?)
-/
@[nolint has_nonempty_instance unused_arguments]
def ForgetEnrichment (W : Type (v + 1)) [Category.{v} W] [MonoidalCategory W] (C : Type u₁)
    [EnrichedCategory W C] :=
  C
#align category_theory.forget_enrichment CategoryTheory.ForgetEnrichment

variable (W)

/-- Typecheck an object of `C` as an object of `forget_enrichment W C`. -/
def ForgetEnrichment.of (X : C) : ForgetEnrichment W C :=
  X
#align category_theory.forget_enrichment.of CategoryTheory.ForgetEnrichment.of

/-- Typecheck an object of `forget_enrichment W C` as an object of `C`. -/
def ForgetEnrichment.to (X : ForgetEnrichment W C) : C :=
  X
#align category_theory.forget_enrichment.to CategoryTheory.ForgetEnrichment.to

@[simp]
theorem ForgetEnrichment.to_of (X : C) : ForgetEnrichment.to W (ForgetEnrichment.of W X) = X :=
  rfl
#align category_theory.forget_enrichment.to_of CategoryTheory.ForgetEnrichment.to_of

@[simp]
theorem ForgetEnrichment.of_to (X : ForgetEnrichment W C) :
    ForgetEnrichment.of W (ForgetEnrichment.to W X) = X :=
  rfl
#align category_theory.forget_enrichment.of_to CategoryTheory.ForgetEnrichment.of_to

instance categoryForgetEnrichment : Category (ForgetEnrichment W C) :=
  by
  let I : enriched_category (Type v) (transport_enrichment (coyoneda_tensor_unit W) C) :=
    inferInstance
  exact enriched_category_Type_equiv_category C I
#align category_theory.category_forget_enrichment CategoryTheory.categoryForgetEnrichment

/-- We verify that the morphism types in `forget_enrichment W C` are `(𝟙_ W) ⟶ (X ⟶[W] Y)`.
-/
example (X Y : ForgetEnrichment W C) :
    (X ⟶ Y) = (𝟙_ W ⟶ ForgetEnrichment.to W X ⟶[W] ForgetEnrichment.to W Y) :=
  rfl

/-- Typecheck a `(𝟙_ W)`-shaped `W`-morphism as a morphism in `forget_enrichment W C`. -/
def ForgetEnrichment.homOf {X Y : C} (f : 𝟙_ W ⟶ X ⟶[W] Y) :
    ForgetEnrichment.of W X ⟶ ForgetEnrichment.of W Y :=
  f
#align category_theory.forget_enrichment.hom_of CategoryTheory.ForgetEnrichment.homOf

/-- Typecheck a morphism in `forget_enrichment W C` as a `(𝟙_ W)`-shaped `W`-morphism. -/
def ForgetEnrichment.homTo {X Y : ForgetEnrichment W C} (f : X ⟶ Y) :
    𝟙_ W ⟶ ForgetEnrichment.to W X ⟶[W] ForgetEnrichment.to W Y :=
  f
#align category_theory.forget_enrichment.hom_to CategoryTheory.ForgetEnrichment.homTo

@[simp]
theorem ForgetEnrichment.homTo_homOf {X Y : C} (f : 𝟙_ W ⟶ X ⟶[W] Y) :
    ForgetEnrichment.homTo W (ForgetEnrichment.homOf W f) = f :=
  rfl
#align category_theory.forget_enrichment.hom_to_hom_of CategoryTheory.ForgetEnrichment.homTo_homOf

@[simp]
theorem ForgetEnrichment.homOf_homTo {X Y : ForgetEnrichment W C} (f : X ⟶ Y) :
    ForgetEnrichment.homOf W (ForgetEnrichment.homTo W f) = f :=
  rfl
#align category_theory.forget_enrichment.hom_of_hom_to CategoryTheory.ForgetEnrichment.homOf_homTo

/-- The identity in the "underlying" category of an enriched category. -/
@[simp]
theorem forgetEnrichment_id (X : ForgetEnrichment W C) :
    ForgetEnrichment.homTo W (𝟙 X) = eId W (ForgetEnrichment.to W X : C) :=
  Category.id_comp _
#align category_theory.forget_enrichment_id CategoryTheory.forgetEnrichment_id

@[simp]
theorem forgetEnrichment_id' (X : C) :
    ForgetEnrichment.homOf W (eId W X) = 𝟙 (ForgetEnrichment.of W X : C) :=
  (forgetEnrichment_id W (ForgetEnrichment.of W X)).symm
#align category_theory.forget_enrichment_id' CategoryTheory.forgetEnrichment_id'

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/-- Composition in the "underlying" category of an enriched category. -/
@[simp]
theorem forgetEnrichment_comp {X Y Z : ForgetEnrichment W C} (f : X ⟶ Y) (g : Y ⟶ Z) :
    ForgetEnrichment.homTo W (f ≫ g) =
      ((λ_ (𝟙_ W)).inv ≫ (ForgetEnrichment.homTo W f ⊗ ForgetEnrichment.homTo W g)) ≫
        eComp W _ _ _ :=
  rfl
#align category_theory.forget_enrichment_comp CategoryTheory.forgetEnrichment_comp

end

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/-- A `V`-functor `F` between `V`-enriched categories
has a `V`-morphism from `X ⟶[V] Y` to `F.obj X ⟶[V] F.obj Y`,
satisfying the usual axioms.
-/
structure EnrichedFunctor (C : Type u₁) [EnrichedCategory V C] (D : Type u₂)
  [EnrichedCategory V D] where
  obj : C → D
  map : ∀ X Y : C, (X ⟶[V] Y) ⟶ obj X ⟶[V] obj Y
  map_id' : ∀ X : C, eId V X ≫ map X X = eId V (obj X) := by obviously
  map_comp' :
    ∀ X Y Z : C,
      eComp V X Y Z ≫ map X Z = (map X Y ⊗ map Y Z) ≫ eComp V (obj X) (obj Y) (obj Z) := by
    obviously
#align category_theory.enriched_functor CategoryTheory.EnrichedFunctor

restate_axiom enriched_functor.map_id'

restate_axiom enriched_functor.map_comp'

attribute [simp, reassoc.1] enriched_functor.map_id

attribute [simp, reassoc.1] enriched_functor.map_comp

/-- The identity enriched functor. -/
@[simps]
def EnrichedFunctor.id (C : Type u₁) [EnrichedCategory V C] : EnrichedFunctor V C C
    where
  obj X := X
  map X Y := 𝟙 _
#align category_theory.enriched_functor.id CategoryTheory.EnrichedFunctor.id

instance : Inhabited (EnrichedFunctor V C C) :=
  ⟨EnrichedFunctor.id V C⟩

/-- Composition of enriched functors. -/
@[simps]
def EnrichedFunctor.comp {C : Type u₁} {D : Type u₂} {E : Type u₃} [EnrichedCategory V C]
    [EnrichedCategory V D] [EnrichedCategory V E] (F : EnrichedFunctor V C D)
    (G : EnrichedFunctor V D E) : EnrichedFunctor V C E
    where
  obj X := G.obj (F.obj X)
  map X Y := F.map _ _ ≫ G.map _ _
#align category_theory.enriched_functor.comp CategoryTheory.EnrichedFunctor.comp

section

variable {W : Type (v + 1)} [Category.{v} W] [MonoidalCategory W]

/-- An enriched functor induces an honest functor of the underlying categories,
by mapping the `(𝟙_ W)`-shaped morphisms.
-/
def EnrichedFunctor.forget {C : Type u₁} {D : Type u₂} [EnrichedCategory W C] [EnrichedCategory W D]
    (F : EnrichedFunctor W C D) : ForgetEnrichment W C ⥤ ForgetEnrichment W D
    where
  obj X := ForgetEnrichment.of W (F.obj (ForgetEnrichment.to W X))
  map X Y f :=
    ForgetEnrichment.homOf W
      (ForgetEnrichment.homTo W f ≫ F.map (ForgetEnrichment.to W X) (ForgetEnrichment.to W Y))
  map_comp' X Y Z f g := by
    dsimp
    apply_fun forget_enrichment.hom_to W
    · simp only [iso.cancel_iso_inv_left, category.assoc, tensor_comp,
        forget_enrichment.hom_to_hom_of, enriched_functor.map_comp, forget_enrichment_comp]
      rfl
    · intro f g w
      apply_fun forget_enrichment.hom_of W  at w
      simpa using w
#align category_theory.enriched_functor.forget CategoryTheory.EnrichedFunctor.forget

end

section

variable {V}

variable {D : Type u₂} [EnrichedCategory V D]

/-!
We now turn to natural transformations between `V`-functors.

The mostly commonly encountered definition of an enriched natural transformation
is a collection of morphisms
```
(𝟙_ W) ⟶ (F.obj X ⟶[V] G.obj X)
```
satisfying an appropriate analogue of the naturality square.
(c.f. https://ncatlab.org/nlab/show/enriched+natural+transformation)

This is the same thing as a natural transformation `F.forget ⟶ G.forget`.

We formalize this as `enriched_nat_trans F G`, which is a `Type`.

However, there's also something much nicer: with appropriate additional hypotheses,
there is a `V`-object `enriched_nat_trans_obj F G` which contains more information,
and from which one can recover `enriched_nat_trans F G ≃ (𝟙_ V) ⟶ enriched_nat_trans_obj F G`.

Using these as the hom-objects, we can build a `V`-enriched category
with objects the `V`-functors.

For `enriched_nat_trans_obj` to exist, it suffices to have `V` braided and complete.

Before assuming `V` is complete, we assume it is braided and
define a presheaf `enriched_nat_trans_yoneda F G`
which is isomorphic to the Yoneda embedding of `enriched_nat_trans_obj F G`
whether or not that object actually exists.

This presheaf has components `(enriched_nat_trans_yoneda F G).obj A`
what we call the `A`-graded enriched natural transformations,
which are collections of morphisms
```
A ⟶ (F.obj X ⟶[V] G.obj X)
```
satisfying a similar analogue of the naturality square,
this time incorporating a half-braiding on `A`.

(We actually define `enriched_nat_trans F G`
as the special case `A := 𝟙_ V` with the trivial half-braiding,
and when defining `enriched_nat_trans_yoneda F G` we use the half-braidings
coming from the ambient braiding on `V`.)
-/

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/-- The type of `A`-graded natural transformations between `V`-functors `F` and `G`.
This is the type of morphisms in `V` from `A` to the `V`-object of natural transformations.
-/
@[ext, nolint has_nonempty_instance]
structure GradedNatTrans (A : Center V) (F G : EnrichedFunctor V C D) where
  app : ∀ X : C, A.1 ⟶ F.obj X ⟶[V] G.obj X
  naturality :
    ∀ X Y : C,
      (A.2.β (X ⟶[V] Y)).Hom ≫ (F.map X Y ⊗ app Y) ≫ eComp V _ _ _ =
        (app X ⊗ G.map X Y) ≫ eComp V _ _ _
#align category_theory.graded_nat_trans CategoryTheory.GradedNatTrans

variable [BraidedCategory V]

open BraidedCategory

/-- A presheaf isomorphic to the Yoneda embedding of
the `V`-object of natural transformations from `F` to `G`.
-/
@[simps]
def enrichedNatTransYoneda (F G : EnrichedFunctor V C D) : Vᵒᵖ ⥤ Type max u₁ w
    where
  obj A := GradedNatTrans ((Center.ofBraided V).obj (unop A)) F G
  map A A' f σ :=
    { app := fun X => f.unop ≫ σ.app X
      naturality := fun X Y => by
        have p := σ.naturality X Y
        dsimp at p⊢
        rw [← id_tensor_comp_tensor_id (f.unop ≫ σ.app Y) _, id_tensor_comp, category.assoc,
          category.assoc, ← braiding_naturality_assoc, id_tensor_comp_tensor_id_assoc, p, ←
          tensor_comp_assoc, category.id_comp] }
#align category_theory.enriched_nat_trans_yoneda CategoryTheory.enrichedNatTransYoneda

-- TODO assuming `[has_limits C]` construct the actual object of natural transformations
-- and show that the functor category is `V`-enriched.
end

section

attribute [local instance] category_of_enriched_category_Type

/-- We verify that an enriched functor between `Type v` enriched categories
is just the same thing as an honest functor.
-/
@[simps]
def enrichedFunctorTypeEquivFunctor {C : Type u₁} [𝒞 : EnrichedCategory (Type v) C] {D : Type u₂}
    [𝒟 : EnrichedCategory (Type v) D] : EnrichedFunctor (Type v) C D ≃ C ⥤ D
    where
  toFun F :=
    { obj := fun X => F.obj X
      map := fun X Y f => F.map X Y f
      map_id' := fun X => congr_fun (F.map_id X) PUnit.unit
      map_comp' := fun X Y Z f g => congr_fun (F.map_comp X Y Z) ⟨f, g⟩ }
  invFun F :=
    { obj := fun X => F.obj X
      map := fun X Y f => F.map f
      map_id' := fun X => by
        ext ⟨⟩
        exact F.map_id X
      map_comp' := fun X Y Z => by
        ext ⟨f, g⟩
        exact F.map_comp f g }
  left_inv F := by
    cases F
    simp
  right_inv F := by
    cases F
    simp
#align category_theory.enriched_functor_Type_equiv_functor CategoryTheory.enrichedFunctorTypeEquivFunctor

/-- We verify that the presheaf representing natural transformations
between `Type v`-enriched functors is actually represented by
the usual type of natural transformations!
-/
def enrichedNatTransYonedaTypeIsoYonedaNatTrans {C : Type v} [EnrichedCategory (Type v) C]
    {D : Type v} [EnrichedCategory (Type v) D] (F G : EnrichedFunctor (Type v) C D) :
    enrichedNatTransYoneda F G ≅
      yoneda.obj (enrichedFunctorTypeEquivFunctor F ⟶ enrichedFunctorTypeEquivFunctor G) :=
  NatIso.ofComponents
    (fun α =>
      { Hom := fun σ x =>
          { app := fun X => σ.app X x
            naturality' := fun X Y f => congr_fun (σ.naturality X Y) ⟨x, f⟩ }
        inv := fun σ =>
          { app := fun X x => (σ x).app X
            naturality := fun X Y => by
              ext ⟨x, f⟩
              exact (σ x).naturality f } })
    (by tidy)
#align category_theory.enriched_nat_trans_yoneda_Type_iso_yoneda_nat_trans CategoryTheory.enrichedNatTransYonedaTypeIsoYonedaNatTrans

end

end CategoryTheory


import tactic
import measure_theory.integration
import measure_theory.measurable_space

noncomputable theory
open set
open classical
open measure_theory
open measurable_space
open_locale ennreal

namespace cond_exp

def is_subsigmaalg {S : Type*} (Γ₁ Γ₂ : measurable_space S ) : Prop :=
  ∀ (E : set S ) , (Γ₁.is_measurable' E) → (Γ₂.is_measurable' E)

lemma is_subsigmaalg_iff_le {S : Type*} {Γ₁ Γ₂ : measurable_space S } :
  is_subsigmaalg Γ₁ Γ₂ ↔ Γ₁ ≤ Γ₂ :=
begin
  split ,
  { intros hsub E hE ,
    exact hsub E hE , } ,
  { intros hle E hE ,
    exact hle E hE , } ,
end

@[simp]
lemma self_is_subsigmaalg {S : Type*} (Γ : measurable_space S ) :
  is_subsigmaalg Γ Γ := by { intros E hE , exact hE , }

@[simp]
lemma self_le_self_sigmaalg {S : Type*} (Γ : measurable_space S ) :
  Γ ≤ Γ := by { intros E hE , exact hE , }

lemma self_is_subsigmaalg' {S : Type*} (Γ : measurable_space S ) :
  is_subsigmaalg Γ Γ :=
begin
  have key : Γ ≤ Γ ,
  { intros E hE ,
    exact hE , } ,
  rwa is_subsigmaalg_iff_le ,
end

def is_trivial_sigmaalg {S : Type*} (Γ : measurable_space S ) : Prop :=
  ∀ (E : set S ) , (Γ.is_measurable' E) → (E = ∅ ∨ E = univ)

@[simp]
lemma trivial_is_subsigmaalg {S : Type*}
  (Γtriv Γ : measurable_space S ) [htriv : is_trivial_sigmaalg Γtriv] :
  is_subsigmaalg Γtriv Γ :=
begin
  intros E hE ,
  have key := htriv E hE ,
  cases key with hemp huniv ,
  { rw hemp ,
    exact measurable_space.is_measurable_empty Γ , } ,
  { rw huniv ,
    have mbleuniv := (Γ.is_measurable_compl ∅ Γ.is_measurable_empty) ,
    simp at mbleuniv ,
    exact mbleuniv , } ,
end

@[simp]
lemma trivial_le_sigmaalg {S : Type*}
  (Γtriv Γ : measurable_space S ) [htriv : is_trivial_sigmaalg Γtriv] :
  Γtriv ≤ Γ :=
begin
  have key := ( @trivial_is_subsigmaalg S Γtriv Γ htriv ) ,
  rw ← is_subsigmaalg_iff_le ,
  exact key ,
end

lemma mble_of_submble {S T : Type*} [measurable_space T] (f : S → T)
  (Γsub Γfull : measurable_space S ) [hsub : Γsub ≤ Γfull] :
  (@measurable S T Γsub _ f) → (@measurable S T Γfull _ f) :=
begin
  intros hf B hB ,
  exact hsub (f⁻¹' B) (hf hB) ,
end

structure cond_exp_enn {S : Type*} (f : S → ennreal)
  (Γsub Γfull : measurable_space S ) [hsub : Γsub ≤ Γfull]
  (μ : @measure_theory.measure S Γfull) :=
  -- In the current version I am not requiring measurability
  --     [hf : @measurable S ennreal Γfull _ f]
  -- and integrability. I even failed to state integrability,
  -- the following does not work:
  --     [hintble : measure_theory.has_finite_integral f μ]
  -- Also I'm not requiring that the measure is a
  -- probability measure.
  --     [hproba : probability_measure μ]
  -- All of these would almost always
  -- be needed, so should they be a part of the definition?
    ( to_fun : S → ennreal )
    ( is_submeasurable : @measurable S ennreal Γsub _ to_fun )
    ( equal_subintegrals : ∀ (E : set S) , Γsub.is_measurable' E →
        ∫⁻ x in E , to_fun(x) ∂ μ = ∫⁻ x in E , f(x) ∂ μ )

-- Of course there should be a coercion to function,
-- just pick the `to_fun`! Somehow, I did not manage to
-- make this work at all...
@[instance]
def cond_exp_enn.has_coe_to_fun {S : Type*}
  {Γsub Γfull : measurable_space S} [hsub : is_subsigmaalg Γsub Γfull]
  {f : S → ennreal} {μ : @measure_theory.measure S Γfull} :
  has_coe_to_fun (@cond_exp_enn S f Γsub Γfull hsub μ)  :=
{ coe := sorry ,
  F := sorry ,
}

lemma cond_exp_enn_full {S : Type*}
  {Γ : measurable_space S}
  {f : S → ennreal} [hf : @measurable S ennreal Γ _ f]
  {μ : @measure_theory.measure S Γ} :
  @cond_exp_enn S f Γ Γ (self_le_self_sigmaalg Γ) μ :=
{ to_fun := f ,
  is_submeasurable := hf ,
  equal_subintegrals := by { intros E hE , refl , } ,
}

lemma cond_exp_enn_trivial {S : Type*}
  {Γtriv Γ : measurable_space S} [htriv  : is_trivial_sigmaalg Γtriv]
  {f : S → ennreal} [hf : @measurable S ennreal Γ _ f]
  {μ : @measure_theory.measure S Γ} [hproba : probability_measure μ] :
  @cond_exp_enn S f Γtriv Γ (@trivial_le_sigmaalg S Γtriv Γ htriv) μ :=
{ to_fun := ( λ (z : S) , ( ∫⁻ x , f(x) ∂ μ ) ) ,
  is_submeasurable := by simp ,
  equal_subintegrals :=
  begin
    intros E hE ,
    have key := htriv E hE ,
    cases key with hemp huniv ,
    { rw hemp ,
      simp , } ,
    { rw huniv ,
      simp ,
      rw hproba.measure_univ ,
      simp , } ,
  end
}

end cond_exp


lemma mul_comm (a b : mynat) : a * b = b * a :=
begin
induction b with k Pk,
rw zero_mul, rw mul_zero, refl,
rw mul_succ, rw succ_mul, rw Pk, refl,
end


example (P Q : Prop) : Q → (P ∨ Q) :=
begin
intro h,
right,
exact h,
end


import to_product
import sugar_yoneda
import category_theory.limits.limits
import category_theory.limits.shapes
universes v u
open Product_stuff
open Yoneda
open category_theory
open category_theory.limits
open category_theory.category
/-
The goal is define group obj in a category.
          reference : Douady : Algebre et théories galoisiennes page 45
          exemple : in the category of presheaf.
          in Ring ? Idem ?
     contexte : 𝒞 a un objet final et a les produit finis !
Pour coder μ X × X ⟶ X  We see that has X ⟶ T cospan f f)

-/
-- notation         f ` ⊗ `:20 g :20 := category_theory.limits.prod.map f g
-- notation         `T`C :20 := (terminal C)
-- notation         `T`X : 20 := (terminal.from X)
-- notation         f ` | `:20 g :20 :=  prod.lift f g
/-!
#     notations :
#         T C       :  C           (objet terminal)
#         (f | g)   :  Z ⟶ X ⨯ Y
#         T X       :  X ⟶ T C
#         (f ⊗ g)  :  Z1 ⨯ Z2 ⟶ X1 ⨯ X2
!-/

structure group_obj (C : Type u)[ 𝒞 : category.{v} C ] [ (has_binary_products.{v} C) ] [ (has_terminal.{v} C) ] :=
(X : C)
(μ : X ⨯ X ⟶ X)
(inv : X ⟶ X)
(ε :  T C ⟶ X)
(hyp_one_mul  :  (T X | 𝟙 X) ≫ (ε ⊗ 𝟙 X) ≫  μ  = 𝟙 X)
(hyp_mul_one  :  (𝟙 X | T X) ≫ ( 𝟙 X ⊗ ε) ≫ μ  = 𝟙 X)
(hyp_inv_mul  :  (inv | 𝟙 X) ≫  μ = (T X) ≫ ε )
(hyp_assoc    :  (μ ⊗ 𝟙 X) ≫ (μ) = (prod.associator X X X).hom ≫ (𝟙 X ⊗ μ)  ≫ μ )   -- (a *b) * c = (a * (b * c))

variables (C : Type u)
variables [𝒞 : category.{v} C]
variables  [has_binary_products.{v} C][has_terminal.{v} C]
include 𝒞
instance coee : has_coe (group_obj C) C := ⟨λ F, F.X⟩ --- ?
variables (G : group_obj C)
include G
-- we start by rewriting a little
lemma mul_one' : (𝟙 G.X | T G.X) ≫ ( 𝟙 G.X ⊗ G.ε) ≫ G.μ  = (𝟙 G.X  | (T G.X) ≫ G.ε) ≫ G.μ :=
begin
     rw ← assoc,
     rw prod.prod_comp_otimes,
     rw comp_id,
end
lemma one_mul' : (T G.X | 𝟙 G.X) ≫ (G.ε ⊗ 𝟙 G.X) ≫  G.μ  = ((T G.X) ≫ G.ε | 𝟙 G.X) ≫ G.μ :=
begin
     rw ← assoc,
     rw prod.prod_comp_otimes,
     rw comp_id,
end
lemma one_mul_R (R A : C) (ζ : R⟦G.X⟧ ): R < ((T G.X) ≫ G.ε | 𝟙 G.X) ≫ G.μ > ζ  =  ζ :=
 begin
     rw ← one_mul',
     rw G.hyp_one_mul,
     rw Yoneda.id,exact rfl,
end
lemma mul_one_R (R A : C) (ζ : R⟦G.X⟧ ): R < ( 𝟙 G.X | (T G.X) ≫ G.ε ) ≫ G.μ > ζ  =  ζ :=
begin
     rw ← mul_one', rw G.hyp_mul_one,rw Yoneda.id,
     exact rfl,
 end
def one   (R : C) : R ⟦(G.X) ⟧  :=
begin                                   ---- ici l'unité est R<ε> (T G.X) l'image du terminal
     exact (terminal.from R ≫ G.ε),
end
def mul (R : C) : R⟦ G.X⟧   → R⟦ G.X⟧  → R ⟦ G.X ⟧  :=  λ g1 g2,
begin
     let φ := ( g1 | g2),
     let β := (R< (G.μ) > : R⟦ G.X ⨯ G.X⟧  ⟶ R⟦G.X⟧),
     exact β φ,
end
variables (R : C)
include R
instance yoneda_mul : has_mul (R⟦ G.X⟧) := ⟨mul C G R ⟩
instance yoneda_one : has_one (R⟦ G.X⟧) := ⟨one C G R ⟩
@[PRODUCT]lemma mul_comp (a b : R ⟦ G.X⟧ ) : a * b = (R < G.μ >) (a | b) := rfl -- priority R < g.μ > (a | b) not ()
@[PRODUCT]lemma one_comp :  (1 : R ⟦ G.X ⟧) = terminal.from R ≫ G.ε := rfl

notation Y `⟶•`  := T Y
@[PRODUCT]lemma Terminal_comp{Y : C} ( a : R ⟶ Y) : a ≫ (Y ⟶•) = (R ⟶•) :=
by exact subsingleton.elim (a ≫ T Y) (T R)

lemma one_mulf' (ζ  : R⟦G.X ⟧) :    1 * ζ  = ζ  := begin
     rw mul_comp,rw one_comp, --- (T X | 𝟙 X) ≫ (ε ⊗ 𝟙 X) ≫  μ  = 𝟙 X)
     let V := one_mul_R C G R R ζ,
     rw [Yoneda.apply_to_composition, ← assoc,prod.left_composition,comp_id
     ,← assoc,Terminal_comp,Yoneda.composition_to_apply] at V,
     exact V,
     use G,
end
lemma mul_onef'(ζ : R⟦G.X ⟧)  : ζ * 1 = ζ := begin
     rw mul_comp,rw one_comp,
     have V := mul_one_R C G R R ζ,
     rw [Yoneda.apply_to_composition, ← assoc,prod.left_composition,comp_id,← assoc
     ,Terminal_comp,Yoneda.composition_to_apply] at V,
     exact V,
     use G,
end
def inv' (R :C) : R⟦ G.X⟧ → R⟦ G.X⟧   := λ  ζ, begin
     exact R<G.inv> ζ,
end
instance yoneda_inv (R :C) : has_inv (R⟦G.X⟧) := ⟨inv' C G R⟩
lemma  inv_comp (ζ : R ⟦ G.X⟧ ) : ζ⁻¹  =  (R<G.inv>) ζ  := rfl
lemma mul_left_inv' (ζ : R ⟦ G.X ⟧) : (ζ⁻¹ * ζ ) = 1 :=  begin
     rw inv_comp,rw mul_comp,rw one_comp,
      rw Yoneda.apply_to_composition,
     have V : R< (G.inv | 𝟙 G.X )   ≫  G.μ> ζ = (R<(T G.X) ≫ G.ε>) ζ ,
          rw G.hyp_inv_mul,
     rw [Yoneda.apply_to_composition,Yoneda.apply_to_composition,
     ← assoc,prod.left_composition,comp_id,← assoc,Terminal_comp,Yoneda.composition_to_apply] at V,
     assumption, use G,
end
lemma Grall (a b c : R ⟦G.X ⟧) : R < (prod.associator G.X G.X G.X).hom ≫ (𝟙 G.X ⊗ G.μ) ≫ G.μ> (a | b | c)
     =(R < G.μ>) (a | (R < G.μ> (b | c))) := begin
     tidy,
     rw [Yoneda.apply_to_composition, ← assoc,prod.left_composition,
     ← assoc,prod.prod_comp_otimes,Yoneda.apply_to_composition,Yoneda.apply_to_composition],
     rw comp_id,
     rw [← assoc,prod.left_composition,prod.lift_fst,prod.lift_fst,
     prod.lift_snd,← assoc,prod.lift_fst,prod.lift_snd],
end
-- (hyp_mul_inv  :  (inv | 𝟙 X ) ≫  μ = (T X) ≫ ε )
lemma mul_assoc' (a b c : R ⟦G.X ⟧) : a * b *c = a * ( b * c ) := begin
     iterate 4 { rw mul_comp}, PRODUCT_CAT,
     have ASSOC : R<((G.μ ⊗ (𝟙 G.X)) ≫ (G.μ)) >(a | b | c) = (R<(prod.associator G.X G.X G.X).hom ≫ (𝟙 G.X ⊗ G.μ)  ≫ G.μ>) (a | b | c),
          rw G.hyp_assoc,
     rw [Yoneda.apply_to_composition,← assoc,prod.prod_comp_otimes,comp_id,
     ← Yoneda.apply_to_composition, ← Yoneda.apply_to_composition] at ASSOC,
     have G_hyp : R < (prod.associator G.X G.X G.X).hom ≫ (𝟙 G.X ⊗ G.μ) ≫ G.μ> (a | b | c)
     =(R < G.μ>) (a | (R < G.μ> (b | c))),
          exact Grall C G R a b c ,
       rw G_hyp at ASSOC,assumption,
     -- R<(prod.associator G.X G.X G.X).hom ≫ (𝟙 G.X ⊗ G.μ)  ≫ G.μ> (a | b | c),

end

instance : group (R⟦G.X⟧) :=
{
     mul := has_mul.mul,
     mul_assoc := mul_assoc' C G R,
     one    := (1 : R⟦ G.X⟧),
     mul_one := mul_onef' C G R,
     one_mul := one_mulf' C G R,
     inv  := inv' C G R,
     mul_left_inv := mul_left_inv' C G R,
}


/- -----------------------------------------------------------------------
Pullbacks and pushouts.
----------------------------------------------------------------------- -/

import .s1_limits
import .s2_products

namespace qp

open stdaux

universe variables ℓobjx ℓhomx ℓobj ℓhom ℓobj₁ ℓhom₁ ℓobj₂ ℓhom₂

/- -----------------------------------------------------------------------
Pullbacks.
----------------------------------------------------------------------- -/

/-! #brief Homs in a cospan category.
-/
inductive CoSpanHom (N : ℕ) : option (fin N) → option (fin N) → Type
| id : ∀ (x : option (fin N)), CoSpanHom x x
| hom : ∀ (n : fin N), CoSpanHom (some n) none

/-! #brief A cospan category.
-/
definition CoSpanCat (N : ℕ) : Cat.{0 1}
:= { obj := option (fin N)
   , hom := CoSpanHom N
   , id := CoSpanHom.id
   , circ := λ x y z g f, begin cases f, { exact g }, { cases g, apply CoSpanHom.hom } end
   , circ_assoc := λ x y z w h g f, begin cases f, { trivial }, { cases g, trivial } end
   , circ_id_left := λ x y f, begin cases f, { trivial }, { trivial } end
   , circ_id_right := λ x y f, begin cases f, { trivial }, { trivial } end
   }

/-! #brief Functor which forgets the base hom.
-/
definition CoSpanCat.forget_base (N : ℕ)
    : Fun (CoSpanCat N) (CoSpanCat (nat.succ N))
:= { obj := λ n, option.cases_on n option.none (λ n', option.some (stdaux.fin.add n' 1))
   , hom := λ x y f
            , begin
                cases f,
                { apply CoSpanHom.id },
                { apply CoSpanHom.hom }
              end
   , hom_id := λ x, rfl
   , hom_circ := λ x y z g f
                 , begin
                     cases f,
                     { trivial },
                     { cases g, trivial }
                   end
   }

/-! #brief A cospan diagram.
-/
definition PullbackDrgm (C : Cat.{ℓobj ℓhom})
    {factor : list C^.obj} {t : C^.obj}
    (maps : HomsIn factor t)
    : Fun (CoSpanCat (list.length factor)) C
:= { obj := λ a, option.cases_on a t (list.get factor)
   , hom := λ a₁ a₂ f, begin cases f, { apply C^.id }, { exact HomsIn.get maps n } end
   , hom_id := λ a, rfl
   , hom_circ := λ a₁ a₂ a₃ g f
                 , begin
                     cases f,
                     { apply eq.symm C^.circ_id_right },
                     { cases g, apply eq.symm C^.circ_id_left }
                   end
   }

/-! #brief Every functor out of CoSpanCat is a PullbackDrgm.
-/
definition PullbackDrgm.mk_doms {C : Cat.{ℓobj ℓhom}}
    : ∀ {N : ℕ}
        (F : Fun (CoSpanCat N) C)
      , list C^.obj
| 0 F := []
| (nat.succ N) F := (F^.obj (some (fin_of 0))) :: @PullbackDrgm.mk_doms N (F □□ CoSpanCat.forget_base N)

/-! #brief Every functor out of CoSpanCat is a PullbackDrgm.
-/
theorem PullbackDrgm.length_mk_doms {C : Cat.{ℓobj ℓhom}}
    : ∀ {N : ℕ}
        (F : Fun (CoSpanCat N) C)
      , list.length (PullbackDrgm.mk_doms F) = N
| 0 F := rfl
| (nat.succ N) F := congr_arg nat.succ (@PullbackDrgm.length_mk_doms N (F □□ CoSpanCat.forget_base N))

/-! #brief Every functor out of CoSpanCat is a PullbackDrgm.
-/
definition PullbackDrgm.mk_homs {C : Cat.{ℓobj ℓhom}}
    : ∀ {N : ℕ}
        (F : Fun (CoSpanCat N) C)
      , @HomsIn C (PullbackDrgm.mk_doms F) (F^.obj none)
| 0 F := HomsIn.nil
| (nat.succ N) F
:= HomsIn.cons (F^.hom (CoSpanHom.hom (fin_of 0)))
               (@PullbackDrgm.mk_homs N (F □□ CoSpanCat.forget_base N))

/-! #brief Every functor out of CoSpanCat is a PullbackDrgm.
-/
theorem PullbackDrgm.uniq {C : Cat.{ℓobj ℓhom}}
    {N : ℕ}
    (F : Fun (CoSpanCat N) C)
    : PullbackDrgm C (PullbackDrgm.mk_homs F) == F
:= begin
     apply Fun.heq,
     { exact congr_arg CoSpanCat (PullbackDrgm.length_mk_doms F) },
     { trivial },
     { intros n₁ n₂ ωn,
       dsimp [PullbackDrgm],
       cases n₁ with n₁ ωn₁,
       { cases n₂ with n₂ ωn₂,
         { trivial },
         { exact sorry } -- TODO
       },
       { cases n₂ with n₂ ωn₂,
         { exact sorry }, -- TODO
         { exact sorry } -- TODO
       }
     },
     { intros x₁ y₁ x₂ y₂ f₁ f₂ ωf,
       cases f₁,
       { cases f₂,
         { exact sorry }, -- TODO
         { exact sorry } -- TODO
       },
       { cases f₂,
         { exact sorry }, -- TODO
         { exact sorry } -- TODO
       }
     }
   end

/-! #brief A cone over a pullback.
-/
definition PullbackCone (C : Cat.{ℓobj ℓhom})
    {factor : list C^.obj} {t : C^.obj}
    (maps : HomsIn factor t)
    : Type (max ℓobj ℓhom)
:= Cone (PullbackDrgm C maps)

/-! #brief Helper for making a pullback cone.
-/
definition PullbackCone.mk {C : Cat.{ℓobj ℓhom}}
    {factor : list C^.obj} {t : C^.obj}
    (maps : HomsIn factor t)
    (c : C^.obj)
    (to_t : C^.hom c t)
    (proj : HomsOut c factor)
    (ωproj : HomsList.repeat to_t (list.length factor)
              = homs_in_comp_out maps proj)
    : PullbackCone C maps
:= { obj := c
   , hom := λ x, option.cases_on x to_t (HomsOut.get proj)
   , comm := λ x₁ x₂ f, begin
                         cases f,
                         { exact eq.symm C^.circ_id_left },
                         { unfold PullbackDrgm,
                           apply eq_of_heq,
                           refine heq.trans (heq.symm (HomsList.get_repeat to_t n)) _,
                           refine heq.trans _ (get_homs_in_comp_out maps proj),
                           rw ωproj
                         }
                       end
   }

/-! #brief The projections out of a pullback cone.
-/
definition PullbackCone.Proj {C : Cat.{ℓobj ℓhom}}
    {factor : list C^.obj} {t : C^.obj}
    {maps : HomsIn factor t}
    (cone : PullbackCone C maps)
    : HomsOut cone^.obj factor
:= sorry -- HomsOut.enum (Cone.hom cone)

/-! #brief A pullback in a category.
-/
@[class] definition HasPullback (C : Cat.{ℓobj ℓhom})
    {factor : list C^.obj} {t : C^.obj}
    (maps : HomsIn factor t)
:= HasLimit (PullbackDrgm C maps)

instance HasPullback.HasLimit {C : Cat.{ℓobj ℓhom}}
    {factor : list C^.obj} {t : C^.obj}
    (maps : HomsIn factor t)
    [maps_HasPullback : HasPullback C maps]
    : HasLimit (PullbackDrgm C maps)
:= maps_HasPullback

/-! #brief A category with all pullbacks.
-/
class HasAllPullbacks (C : Cat.{ℓobj ℓhom})
:= (has_pullback : ∀ {base : C^.obj} {factor : list C^.obj} {t : C^.obj}
                     (maps : HomsIn (base :: factor) t)
                   , HasPullback C maps)

instance HasAllPullbacks.HasPullback (C : Cat.{ℓobj ℓhom})
    [C_HasAllPullbacks : HasAllPullbacks C]
    {base : C^.obj} {factor : list C^.obj} {t : C^.obj}
    (maps : HomsIn (base :: factor) t)
    : HasPullback C maps
:= HasAllPullbacks.has_pullback maps

instance HasAllPullbacks.HasAllLimitsFrom (C : Cat.{ℓobj ℓhom})
    [C_HasAllPullbacks : HasAllPullbacks C]
    (N : ℕ)
    : HasAllLimitsFrom C (CoSpanCat (nat.succ N))
:= { has_limit := λ L, let l := HasAllPullbacks.HasPullback C (PullbackDrgm.mk_homs L)
                       in cast (HasLimit.heq begin rw PullbackDrgm.length_mk_doms end rfl (PullbackDrgm.uniq L)) l
   }

/-! #brief A category with all pullbacks along a given hom.
-/
class HasPullbacksAlong (C : Cat.{ℓobj ℓhom})
    {base t : C^.obj} (f : C^.hom base t)
:= (has_pullback : ∀ {y : C^.obj} (map : C^.hom y t)
                   , HasPullback C (f ↗→ map ↗→↗))

instance HasPullbacksAlong.HasPullback (C : Cat.{ℓobj ℓhom})
    {base t : C^.obj} (f : C^.hom base t)
    {y : C^.obj} (map : C^.hom y t)
    [f_HasPullbacksAlong : HasPullbacksAlong C f]
    : HasPullback C (f ↗→ map ↗→↗)
:= HasPullbacksAlong.has_pullback f map

instance HasAllPullbacks.HasPullbacksAlong (C : Cat.{ℓobj ℓhom})
    [C_HasAllPullbacks : HasAllPullbacks C]
    {base t : C^.obj} (f : C^.hom base t)
    : HasPullbacksAlong C f
:= { has_pullback := λ y map, HasAllPullbacks.has_pullback (f ↗→ map ↗→↗)
   }

/-! #brief Helper for showing a category has a pullback.
-/
definition HasPullback.show (C : Cat.{ℓobj ℓhom})
    {factor : list C^.obj} {t : C^.obj}
    (maps : HomsIn factor t)
    (p : C^.obj)
    (to_t : C^.hom p t)
    (proj : HomsOut p factor)
    (ωproj : HomsList.repeat to_t (list.length factor)
              = homs_in_comp_out maps proj)
    (univ : ∀ {c : C^.obj} (to_t' : C^.hom c t) (hom : HomsOut c factor)
              (ωhom : HomsList.repeat
                       to_t'
                       (list.length factor)
                       = homs_in_comp_out maps hom)
            , C^.hom c p)
    (ωuniv : ∀ {c : C^.obj} (to_t' : C^.hom c t) (hom : HomsOut c factor)
              (ωhom : HomsList.repeat
                       to_t'
                       (list.length factor)
                       = homs_in_comp_out maps hom)
             , hom = HomsOut.comp proj (univ to_t' hom ωhom))
    (ωuniq : ∀ {c : C^.obj} (to_t' : C^.hom c t) (hom : HomsOut c factor)
              (ωhom : HomsList.repeat
                       to_t'
                       (list.length factor)
                       = homs_in_comp_out maps hom)
               (h : C^.hom c p)
               (ωcomm : hom = HomsOut.comp proj h)
             , h = univ to_t' hom ωhom)
    : HasPullback C maps
:= HasLimit.show p (λ x, option.cases_on x to_t ((HomsOut.get proj)))
    (λ x₁ x₂ f, begin
                 cases f,
                 { exact eq.symm C^.circ_id_left },
                 { unfold PullbackDrgm,
                   apply eq_of_heq,
                   refine heq.trans (heq.symm (HomsList.get_repeat to_t n)) _,
                   refine heq.trans _ (get_homs_in_comp_out maps proj),
                   rw ωproj
                 }
               end)
    (λ c hom ωcomm, univ (hom none) (HomsOut.enum (λ n, hom (some n)))
     begin
       exact sorry
     end)
    (λ c hom ωcomm a, begin exact sorry end)
    (λ c hom ωcomm h ωh, begin exact sorry end)

/-! #brief Pullbacks are cones.
-/
definition pullback.cone (C : Cat.{ℓobj ℓhom})
    {factor : list C^.obj} {t : C^.obj}
    (maps : HomsIn factor t)
    [maps_HasPullback : HasPullback C maps]
    : PullbackCone C maps
:= limit.cone (PullbackDrgm C maps)

/-! #brief The pullback of a collection of homs.
-/
definition pullback (C : Cat.{ℓobj ℓhom})
    {factor : list C^.obj} {t : C^.obj}
    (maps : HomsIn factor t)
    [maps_HasPullback : HasPullback C maps]
    : C^.obj
:= limit (PullbackDrgm C maps)

/-! #brief Projection out of a pullback.
-/
definition pullback.π (C : Cat.{ℓobj ℓhom})
    {factor : list C^.obj} {t : C^.obj}
    (maps : HomsIn factor t)
    [maps_HasPullback : HasPullback C maps]
    (n : fin (list.length factor))
    : C^.hom (pullback C maps) (list.get factor n)
:= limit.out (PullbackDrgm C maps) (some n)

/-! #brief The commutative square property of pullbacks.
-/
definition pullback.π_comm (C : Cat.{ℓobj ℓhom})
    {factor : list C^.obj} {t : C^.obj}
    (maps : HomsIn factor t)
    [maps_HasPullback : HasPullback C maps]
    (n₁ n₂ : fin (list.length factor))
    : HomsIn.get maps n₁ ∘∘ pullback.π C maps n₁
       = HomsIn.get maps n₂ ∘∘ pullback.π C maps n₂
:= sorry

/-! #brief Projection out of a pullback to the base.
-/
definition pullback.πbase (C : Cat.{ℓobj ℓhom})
    {factor : list C^.obj} {t : C^.obj}
    (maps : HomsIn factor t)
    [maps_HasPullback : HasPullback C maps]
    : C^.hom (pullback C maps) t
:= limit.out (PullbackDrgm C maps) none

/-! #brief Every cone is mediated through the pullback.
-/
definition pullback.univ (C : Cat.{ℓobj ℓhom})
    {factor : list C^.obj} {t : C^.obj}
    (maps : HomsIn factor t)
    [maps_HasPullback : HasPullback C maps]
    (c : PullbackCone C maps)
    : C^.hom c^.obj (pullback C maps)
:= limit.univ _ c

/-! #brief Every cone is mediated through the pullback.
-/
definition pullback.univ.mediates (C : Cat.{ℓobj ℓhom})
    {factor : list C^.obj} {t : C^.obj}
    (maps : HomsIn factor t)
    {maps_HasPullback : HasPullback C maps}
    (c : PullbackCone C maps)
    (n : fin (list.length factor))
    : c^.hom (some n) = C^.circ (@pullback.π C factor t maps maps_HasPullback n) (pullback.univ C maps c)
:= limit.univ.mediates c (some n)

/-! #brief Every cone is mediated through the pullback.
-/
definition pullback.univ.mediates_base (C : Cat.{ℓobj ℓhom})
    {factor : list C^.obj} {t : C^.obj}
    (maps : HomsIn factor t)
    {maps_HasPullback : HasPullback C maps}
    (c : PullbackCone C maps)
    : c^.hom none = C^.circ (@pullback.πbase C factor t maps maps_HasPullback) (pullback.univ C maps c)
:= limit.univ.mediates c none

/-! #brief The mediating map from the cone to the pullback is unique.
-/
definition pullback.univ.uniq (C : Cat.{ℓobj ℓhom})
    {factor : list C^.obj} {t : C^.obj}
    (maps : HomsIn factor t)
    {maps_HasPullback : HasPullback C maps}
    (c : PullbackCone C maps)
    (m : C^.hom c^.obj (pullback C maps))
    (ω : ∀ (n : fin (list.length factor))
         , c^.hom (some n) = (@pullback.π C factor t maps maps_HasPullback n) ∘∘ m)
    (ωbase : c^.hom none = (@pullback.πbase C factor t maps maps_HasPullback) ∘∘ m)
    : m = pullback.univ C maps c
:= limit.univ.uniq c m (λ x, option.cases_on x ωbase ω)

/-! #brief The unique iso between two pullbacks of the same homs.
-/
definition pullback.iso {C : Cat.{ℓobj ℓhom}}
    {factor : list C^.obj} {t : C^.obj}
    {maps : HomsIn factor t}
    (maps_HasPullback₁ maps_HasPullback₂ : HasPullback C maps)
    : C^.hom (@pullback C factor t maps maps_HasPullback₁)
             (@pullback C factor t maps maps_HasPullback₂)
:= limit.iso maps_HasPullback₁ maps_HasPullback₂

/-! #brief Pullbacks are unique up-to unique isomorphism.
-/
definition pullback.uniq {C : Cat.{ℓobj ℓhom}}
    {factor : list C^.obj} {t : C^.obj}
    {maps : HomsIn factor t}
    (maps_HasPullback₁ maps_HasPullback₂ : HasPullback C maps)
    : Iso (pullback.iso maps_HasPullback₁ maps_HasPullback₂)
          (pullback.iso maps_HasPullback₂ maps_HasPullback₁)
:= limit.uniq maps_HasPullback₁ maps_HasPullback₂

/- -----------------------------------------------------------------------
Pullbacks in functor categories.
----------------------------------------------------------------------- -/

/-! #brief Pullbacks in functor categories can be computed pointwise.
-/
instance FunCat.HasPullback {C : Cat.{ℓobj₁ ℓhom₁}} {D : Cat.{ℓobj₂ ℓhom₂}}
    [D_HasAllPullbacks : HasAllPullbacks D]
    {base : Fun C D} {factor : list (Fun C D)} {t : Fun C D}
    (maps : @HomsIn (FunCat C D) (base :: factor) t)
    : HasPullback (FunCat C D) maps
:= @FunCat.HasLimit _ _ _ (HasAllPullbacks.HasAllLimitsFrom D _) (PullbackDrgm (FunCat C D) maps)

/-! #brief Pullbacks in functor categories can be computed pointwise.
-/
instance FunCat.HasAllPullbacks {C : Cat.{ℓobj₁ ℓhom₁}} {D : Cat.{ℓobj₂ ℓhom₂}}
    [D_HasAllPullbacks : HasAllPullbacks D]
    : HasAllPullbacks (FunCat C D)
:= { has_pullback := λ base factor t maps, FunCat.HasPullback maps
   }

/- -----------------------------------------------------------------------
Pullback squares.
----------------------------------------------------------------------- -/

/-! #brief A pullback square.
-/
class IsPullback {C : Cat.{ℓobj ℓhom}}
    {p x y t : C^.obj}
    (base : C^.hom x t) (p₁ : C^.hom p x)
    (map : C^.hom y t)  (p₂ : C^.hom p y)
:= (has_pullback : HasPullback C (base ↗→ map ↗→↗))
   (ωpullback : @pullback C [x, y] t _ has_pullback = p)
   (ωπ₁ : @pullback.π C [x, y] t _ has_pullback (@fin_of 1 0) = p₁ ∘∘ cast_hom ωpullback)
   (ωπ₂ : @pullback.π C [x, y] t _ has_pullback (@fin_of 0 1) = p₂ ∘∘ cast_hom ωpullback)

/-! #brief Pullback squares have the usual commutative diagram.
-/
theorem ispullback.square {C : Cat.{ℓobj ℓhom}}
    {p x y t : C^.obj}
    {base : C^.hom x t} {p₁ : C^.hom p x}
    {map : C^.hom y t}  {p₂ : C^.hom p y}
    (isPullback : IsPullback base p₁ map p₂)
    : C^.circ base p₁ = C^.circ map p₂
:= sorry

/-! #brief The universal map into a pullback square.
-/
definition ispullback.univ {C : Cat.{ℓobj ℓhom}}
    {p x y t : C^.obj}
    {base : C^.hom x t} {p₁ : C^.hom p x}
    {map : C^.hom y t}  {p₂ : C^.hom p y}
    (isPullback : IsPullback base p₁ map p₂)
    {c : C^.obj} (h₁ : C^.hom c x) (h₂ : C^.hom c y)
    (ωsquare : C^.circ base h₁ = C^.circ map h₂)
    : C^.hom c p
:= C^.circ
    (cast_hom (IsPullback.ωpullback base p₁ map p₂))
    (@pullback.univ _ _ _ _ (IsPullback.has_pullback base p₁ map p₂)
      (PullbackCone.mk _ c (C^.circ base h₁) (h₁ ↗← h₂ ↗←↗)
        begin
          apply dlist.eq,
          { trivial },
          apply dlist.eq,
          { exact ωsquare },
          trivial
        end))

/-! #brief Helper for showing one has a pullback square.
-/
definition IsPullback.show {C : Cat.{ℓobj ℓhom}}
    {p x y t : C^.obj}
    {base : C^.hom x t} {p₁ : C^.hom p x}
    {map : C^.hom y t}  {p₂ : C^.hom p y}
    (univ
      : ∀ {c : C^.obj} (h₁ : C^.hom c x) (h₂ : C^.hom c y)
          (ωsquare : C^.circ base h₁ = C^.circ map h₂)
        , C^.hom c p)
    (ωsquare
      : C^.circ base p₁ = C^.circ map p₂)
    (ωuniv₁
      : ∀ {c : C^.obj} (h₁ : C^.hom c x) (h₂ : C^.hom c y)
          (ωsquare : C^.circ base h₁ = C^.circ map h₂)
        , h₁ = C^.circ p₁ (univ h₁ h₂ ωsquare))
    (ωuniv₂
      : ∀ {c : C^.obj} (h₁ : C^.hom c x) (h₂ : C^.hom c y)
          (ωsquare : C^.circ base h₁ = C^.circ map h₂)
        , h₂ = C^.circ p₂ (univ h₁ h₂ ωsquare))
    (ωuniv_uniq
      : ∀ {c : C^.obj} (h₁ : C^.hom c x) (h₂ : C^.hom c y)
          (ωsquare : C^.circ base h₁ = C^.circ map h₂)
          (univ' : C^.hom c p)
          (ωuniv'₁ : h₁ = C^.circ p₁ univ')
          (ωuniv'₂ : h₂ = C^.circ p₂ univ')
        , univ' = univ h₁ h₂ ωsquare)
    : IsPullback base p₁ map p₂
:= { has_pullback
      := HasPullback.show C (base ↗→ map ↗→↗) p
          (C^.circ base p₁)
          (p₁ ↗← p₂ ↗←↗)
          begin
            apply dlist.eq,
            { trivial },
            apply dlist.eq,
            { exact ωsquare },
            trivial
          end
          (λ c to_t homs ωhoms
           , begin
               cases homs with _ h₁ _ homs,
               cases homs with _ h₂ _ _,
               cases bb,
               apply univ h₁ h₂,
               refine @eq.trans _  _ to_t _  _ _,
               { apply eq.symm,
                 apply HomsList.congr_get ωhoms (@fin_of 1 0)
               },
               { apply HomsList.congr_get ωhoms (@fin_of 0 1) }
             end)
          (λ c to_t homs ωhoms
           , begin
               cases homs with _ h₁ _ homs,
               cases homs with _ h₂ _ _,
               cases bb,
               apply dlist.eq,
               { apply ωuniv₁ },
               apply dlist.eq,
               { apply ωuniv₂ },
               trivial
             end)
          (λ c to_t homs ωhoms h ωh
           , begin
               cases homs with _ h₁ _ homs,
               cases homs with _ h₂ _ _,
               cases bb,
               apply ωuniv_uniq,
               { apply dlist.congr_get ωh (@fin_of 1 0) },
               { apply dlist.congr_get ωh (@fin_of 0 1) }
             end)
   , ωpullback := rfl
   , ωπ₁ := eq.symm C^.circ_id_right
   , ωπ₂ := eq.symm C^.circ_id_right
   }

/- -----------------------------------------------------------------------
Maps from pullbacks to products.
----------------------------------------------------------------------- -/

/-! #brief The map from a pullback to the underlying product.
-/
definition pullback.to_finproduct (C : Cat.{ℓobj ℓhom})
    {factor : list C^.obj} {t : C^.obj}
    (maps : HomsIn factor t)
    [maps_HasPullback : HasPullback C maps]
    [dom_HasFinProduct : HasFinProduct C factor]
    : C^.hom (pullback C maps) (finproduct C factor)
:= sorry

/- -----------------------------------------------------------------------
Maps between pullbacks.
----------------------------------------------------------------------- -/

/-! #brief Building a map between pullbacks.
-/
definition pullback.hom (C : Cat.{ℓobj ℓhom})
    (base : C^.obj × C^.obj) (factor : list (C^.obj × C^.obj)) {t : C^.obj}
    (maps₁ : HomsIn (list.map prod.fst (base :: factor)) t)
    [maps₁_HasPullback : HasPullback C maps₁]
    (maps₂ : HomsIn (list.map prod.snd (base :: factor)) t)
    [maps₂_HasPullback : HasPullback C maps₂]
    (fns : HomsList C (base :: factor))
    : C^.hom (pullback C maps₁)
             (pullback C maps₂)
:= pullback.univ _ _
    (PullbackCone.mk maps₂ (pullback C maps₁)
      (HomsIn.get maps₂ fin.zero
        ∘∘ HomsList.get fns fin.zero
        ∘∘ pullback.π C maps₁ fin.zero)
      (homs_comp_out fns (pullback.cone C maps₁)^.Proj)
      sorry)

/- -----------------------------------------------------------------------
Fibers.
----------------------------------------------------------------------- -/

/-! #brief Fiber of a map over a global element.
-/
definition Fiber {C : Cat.{ℓobj ℓhom}}
    [C_HasFinal : HasFinal C]
    [C_HasAllPullbacks : HasAllPullbacks C]
    {x y : C^.obj} (f : C^.hom x y)
    (y₀ : C^.hom (final C) y)
    : C^.obj
:= pullback C (f ↗→ y₀ ↗→↗)

/-! #brief Projection out of a fiber.
-/
definition Fiber.π {C : Cat.{ℓobj ℓhom}}
    [C_HasFinal : HasFinal C]
    [C_HasAllPullbacks : HasAllPullbacks C]
    {x y : C^.obj} (f : C^.hom x y)
    (y₀ : C^.hom (final C) y)
    : C^.hom (Fiber f y₀) x
:= pullback.π C (f ↗→ y₀ ↗→↗) (@fin_of 1 0)

/-! #brief A hom into a fiber.
-/
definition Fiber.into {C : Cat.{ℓobj ℓhom}}
    [C_HasFinal : HasFinal C]
    [C_HasAllPullbacks : HasAllPullbacks C]
    {x y : C^.obj} (f : C^.hom x y)
    (y₀ : C^.hom (final C) y)
    {z : C^.obj}
    (h : C^.hom z x)
    (ωh : f ∘∘ h = y₀ ∘∘ final_hom z)
    : C^.hom z (Fiber f y₀)
:= pullback.univ C (f ↗→ y₀ ↗→↗)
    (PullbackCone.mk (f ↗→ y₀ ↗→↗) z
      (C^.circ f h)
      (h ↗← final_hom z ↗←↗)
      begin
        apply HomsList.eq, { trivial },
        apply HomsList.eq, { exact ωh },
        trivial
      end)

/-! #brief A cone over a fiber.
-/
definition Fiber.cone {C : Cat.{ℓobj ℓhom}}
    [C_HasFinal : HasFinal C]
    [C_HasAllPullbacks : HasAllPullbacks C]
    {x₁ x₂ y : C^.obj} {f₁ : C^.hom x₁ y} {f₂ : C^.hom x₂ y}
    {y₀ : C^.hom (final C) y}
    (h : C^.hom x₁ x₂)
    (ωh : y₀ ∘∘ final_hom (Fiber f₁ y₀)
           = f₂ ∘∘ h ∘∘ pullback.π C (f₁ ↗→ y₀ ↗→↗) (@fin_of 1 0))
:= PullbackCone.mk (f₂ ↗→ y₀ ↗→↗) (Fiber f₁ y₀)
      (y₀ ∘∘ final_hom (Fiber f₁ y₀))
      (h ∘∘ pullback.π C (f₁ ↗→ y₀ ↗→↗) (@fin_of 1 0) ↗← final_hom (Fiber f₁ y₀) ↗←↗)
      begin
        apply HomsList.eq, { exact eq.trans ωh (eq.symm C^.circ_assoc) },
        apply HomsList.eq, { trivial },
        trivial
      end

/-! #brief A hom between fibers.
-/
definition Fiber.hom {C : Cat.{ℓobj ℓhom}}
    [C_HasFinal : HasFinal C]
    [C_HasAllPullbacks : HasAllPullbacks C]
    {x₁ x₂ y : C^.obj} {f₁ : C^.hom x₁ y} {f₂ : C^.hom x₂ y}
    {y₀ : C^.hom (final C) y}
    (h : C^.hom x₁ x₂)
    (ωh : y₀ ∘∘ final_hom (Fiber f₁ y₀)
           = f₂ ∘∘ h ∘∘ pullback.π C (f₁ ↗→ y₀ ↗→↗) (@fin_of 1 0))
    : C^.hom (Fiber f₁ y₀) (Fiber f₂ y₀)
:= pullback.univ C (f₂ ↗→ y₀ ↗→↗) (Fiber.cone h ωh)

/- -----------------------------------------------------------------------
Products in OverCat.
----------------------------------------------------------------------- -/

/-! #brief Existence of products in an over-category.
-/
definition OverCat.HasFinProduct₀ (C : Cat.{ℓobj ℓhom}) (c : C^.obj)
    : HasFinProduct (OverCat C c) []
:= @HasFinProduct.show (OverCat C c) []
    (@final (OverCat C c) (OverCat.HasFinal C c))
    HomsOut.nil
    (λ X homs, @final_hom (OverCat C c) (OverCat.HasFinal C c) X)
    (λ X homs, begin cases homs, trivial end)
    (λ X homs h ωh, @final_hom.uniq (OverCat C c) (OverCat.HasFinal C c) X h)

/-! #brief Existence of products in an over-category.
-/
definition OverCat.HasFinProduct₁ (C : Cat.{ℓobj ℓhom}) (c : C^.obj)
    (factors : list (OverCat C c)^.obj)
    [factors_HasPullback : HasPullback C (HomsIn.of_list_OverObj factors)]
    : HasFinProduct (OverCat C c) factors
:= let pb : OverObj C c
         := { obj := pullback C (HomsIn.of_list_OverObj factors)
            , hom := pullback.πbase C (HomsIn.of_list_OverObj factors)
            }
in HasProduct.show (OverCat C c) (list.get factors)
    pb
    (λ n, { hom := cast_hom sorry
                    ∘∘ pullback.π C (HomsIn.of_list_OverObj factors)
                        { val := n^.val, is_lt := cast sorry n^.is_lt }
          , triangle := sorry
          })
    (λ X homs
     , { hom := pullback.univ C (HomsIn.of_list_OverObj factors)
                 (PullbackCone.mk (HomsIn.of_list_OverObj factors) X^.obj
                   X^.hom
                   (HomsOut.enum
                     (λ n, cast_hom sorry
                            ∘∘ (homs { val := n^.val, is_lt := cast sorry n^.is_lt})^.hom))
                   sorry)
       , triangle := sorry
       })
    (λ X hom n, sorry)
    (λ X hom h ωh, sorry)

/-! #brief Existence of products in an over-category.
-/
instance OverCat.HasFinProduct (C : Cat.{ℓobj ℓhom}) (c : C^.obj)
    [C_HasAllPullbacks : HasAllPullbacks C]
    : ∀ (factors : list (OverCat C c)^.obj)
      , HasFinProduct (OverCat C c) factors
| [] := OverCat.HasFinProduct₀ C c
| (factor₀ :: factors)
:= @OverCat.HasFinProduct₁ C c (factor₀ :: factors)
     (HasAllPullbacks.HasPullback C _)

instance OverCat.HasAllFinProducts (C : Cat.{ℓobj ℓhom}) (c : C^.obj)
    [C_HasAllPullbacks : HasAllPullbacks C]
    : HasAllFinProducts (OverCat C c)
:= { has_product := OverCat.HasFinProduct C c
   }

/- -----------------------------------------------------------------------
Pullbacks along final homs.
----------------------------------------------------------------------- -/

/-! Categories with products have pullbacks along final homs.
-/
instance HasAllFinProducts.final_hom.HasPullbacksAlong
    {C : Cat.{ℓobj ℓhom}}
    [C_HasFinal : HasFinal C]
    [C_HasAllFinProducts : HasAllFinProducts C]
    (x : C^.obj)
    : HasPullbacksAlong C (final_hom x)
:= { has_pullback
      := λ y map
         , HasPullback.show C (final_hom x ↗→ map ↗→↗)
            (finproduct C [x, y])
            (final_hom (finproduct C [x, y]))
            (finproduct.cone C [x, y])^.Proj
            begin
              apply eq.symm,
              apply dlist.eq,
              { apply final_hom.uniq },
              -- induction maps with _ m _ maps rec,
              -- { trivial },
              -- apply dlist.eq,
              -- { apply final_hom.uniq },
              -- apply rec
              exact sorry
            end
            begin exact sorry end
            begin exact sorry end
            begin exact sorry end
   }

end qp