import category_theory.category
import category_theory.isomorphism
import category_theory.types
import category_theory.isomorphism
import data.finset.basic
import data.finset.sort
import data.int.parity
import .article2

namespace exercises

universe u

section endomaps

open category_theory

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

structure endomap (α : Type*) [category α] :=
(carrier : α)
(endo : carrier ⟶ carrier)

structure endomaps_map (dom: endomap α) (ima: endomap α) :=
(map : dom.carrier ⟶ ima.carrier)
(preserve : dom.endo ≫ map = map ≫ ima.endo)

-- Exercise 1 page 137
def endomap_maps_comp {A B C: endomap α} (f : endomaps_map A B) (g : endomaps_map B C) : endomaps_map A C :=
{
    map := f.map ≫ g.map,
    preserve :=
       calc A.endo ≫ f.map ≫ g.map = (f.map ≫ B.endo) ≫ g.map : by rw [← category.assoc, f.preserve]
            ... = f.map ≫ g.map ≫ C.endo : by simp [g.preserve]
            ... = (f.map ≫ g.map) ≫ C.endo : by simp,
}

variables {A B : endomap α}

@[simp]
lemma endo_inj (f : endomaps_map A  B) (pre) :
    (endomaps_map.mk f.map pre) = f :=
begin
    cases f,
    refl,
end

def endo_category : category (endomap α) :=
{
    hom := λ x y, endomaps_map x y,
    id := λ x, { map := 𝟙 x.carrier, preserve := by simp },
    comp := λ _ _ _ f g, endomap_maps_comp f g,
    id_comp' := λ _ _ f, by {simp at *, unfold endomap_maps_comp, simp},
    comp_id' := λ _ _ f, by {simp at *, unfold endomap_maps_comp, simp},
    assoc'   := λ _ _ _ _ f g h, by {simp, unfold endomap_maps_comp, simp}
}

def Endoset := @endomap Type* category_theory.types
def Endoset_map (dom: Endoset) (ima: Endoset):= endomaps_map dom ima

def endoset_category : category Endoset := endo_category

def x : Endoset := ⟨ ℕ, λ n, n + 2 ⟩
def y : Endoset := ⟨ ℕ, λ n, n + 1 ⟩

def yx : endomaps_map y x := {
     map := λ n:ℕ,  nat.mul n 2,
     preserve := by {
         ext a,
         change nat.mul (a + 1) 2 = (a * 2) + 2,
         simp,
         ring,
     }
}

-- Exercise 2 page 139
example {X: α} (endo r : X ⟶ X) (idem : idempotent endo) (ret : is_retraction endo r) : endo = 𝟙 X :=
    calc endo = endo ≫ 𝟙 X : by simp
        ... = endo ≫ (endo ≫ r) : by {unfold is_retraction at ret, rw ←ret}
        ... = (endo ≫ endo) ≫ r : by simp
        ... = endo ≫ r : by rw idempotent.repeat
        ... = 𝟙 X : ret

def involution {A : α} (f : A ⟶ A) := f ≫ f = 𝟙 A

-- Exercise 4 page 140
def minus : endomap Type*  := {
    carrier := ℤ,
    endo := λ x, -x
}

example  : @involution Type*  infer_instance ℤ (λ x:ℤ, -x) :=
begin
    unfold involution,
    ext,
    simp,
end

-- Exercise 5 page 140
example  : @idempotent Type*  infer_instance ℤ (λ x:ℤ, abs x) := {
    repeat := by {
        simp,
        ext,
        rw ← abs_abs,
        simp,
    }
}

-- Exercise 6 page 140
example  : @is_iso Type* infer_instance ℤ ℤ  (λ x:ℤ, x + 3) := {
    inv := λ x, x - 3,
}

lemma prod_ne_one_of_gr {a b: ℤ} (h: b > 1) : a * b ≠ 1 :=
begin
    intros prod,
    have h := int.eq_one_of_mul_eq_one_left (by linarith) prod,
    linarith,
end

-- Exercise 7 page 140
example (iso: @is_iso Type* infer_instance ℤ ℤ  (λ x:ℤ, x * 5)) : false :=
begin
    have : iso.inv ≫ (λ x:ℤ, x * 5) = 𝟙 ℤ := @is_iso.inv_hom_id Type* infer_instance ℤ ℤ  (λ x:ℤ, x * 5) iso,
    have h := congr_fun this 1,
    simp at h,
    exact prod_ne_one_of_gr (by linarith) h ,
end

-- Exercise 8 page 140
example (A : α)  (f : A ⟶ A) (inv: involution f) : f ≫ f ≫ f = f :=
begin
    unfold involution at inv,
    rw inv,
    exact category.comp_id _,
end

example (A : α)  (f : A ⟶ A) [ide: idempotent f] : f ≫ f ≫ f = f :=
begin
    rw ide.repeat,
    rw ide.repeat,
end

end endomaps

section irr_graphs

variables {α β δ γ ε ζ : Type u}

structure irr_graph (α : Type u) (β : Type u) :=
(s t : α → β)

structure irr_graph_map (dom : irr_graph α β) (ima : irr_graph δ γ) :=
(fa  : α → δ)
(fd : β → γ)
(pres: fd ∘ dom.s = ima.s ∘ fa)
(pret: fd ∘ dom.t = ima.t ∘ fa)

variables {A : irr_graph α β} {B : irr_graph δ γ} {C : irr_graph ε ζ}

-- Exercise 11 page 142
def irr_graph_map_comp (f : irr_graph_map A B) (g : irr_graph_map B C) : irr_graph_map A C :=
{
    fa := g.fa ∘ f.fa,
    fd := g.fd ∘ f.fd,
    pres :=
        calc (g.fd ∘ f.fd) ∘ A.s = g.fd ∘ (f.fd ∘ A.s) : by simp
             ... = g.fd ∘ (B.s ∘ f.fa) : by rw f.pres
             ... = (g.fd ∘ B.s) ∘ f.fa : by simp
             ... = (C.s ∘ g.fa) ∘ f.fa : by rw g.pres,

    pret := by {
        calc (g.fd ∘ f.fd) ∘ A.t = g.fd ∘ (f.fd ∘ A.t) : by simp
             ... = g.fd ∘ (B.t ∘ f.fa) : by rw f.pret
             ... = (g.fd ∘ B.t) ∘ f.fa : by simp
             ... = (C.t ∘ g.fa) ∘ f.fa : by rw g.pret,
    },
}

def endo_to_irr_graph_on_obj (e: Endoset) : irr_graph e.carrier e.carrier :=
{
    s := id,
    t := e.endo
}

def endo_to_irr_graph_on_maps {A B : Endoset} (f: Endoset_map A B) :
    irr_graph_map (endo_to_irr_graph_on_obj A) (endo_to_irr_graph_on_obj B) :=
{
    fa := f.map,
    fd := f.map,
    pres := by {
        unfold endo_to_irr_graph_on_obj,
        simp,
    },
    pret := by {
        exact f.preserve,
    }
}

-- Exercise 12 page 143
lemma endo_insertion_functorial {A B C : Endoset} (f: Endoset_map A B) (g: Endoset_map B C) :
    endo_to_irr_graph_on_maps( endomap_maps_comp f g ) = irr_graph_map_comp (endo_to_irr_graph_on_maps f) (endo_to_irr_graph_on_maps g) :=
begin
    refl
end

-- Exercise 13 page 144
example {A B : Endoset} (f : irr_graph_map (endo_to_irr_graph_on_obj A) (endo_to_irr_graph_on_obj B) ) :
    ∃ g : Endoset_map A B, endo_to_irr_graph_on_maps g = f :=
begin
    have : f.fd = f.fa := f.pres,

    use f.fa,
    {
        have pret := f.pret,
        rw this at pret,
        exact pret,
    },
    {
        cases f,
        unfold endo_to_irr_graph_on_maps,
        simp,
        exact this.symm,
    }
end

end irr_graphs

section simpler

open category_theory

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

structure simpler (α : Type*) [category α] :=
(dom : α)
(ima : α)
(map : dom ⟶ ima)

structure simpler_map (dom: simpler α) (ima: simpler α) :=
(dommap : dom.dom ⟶ ima.dom)
(imamap : dom.ima ⟶ ima.ima)
(preserve : dom.map ≫ imamap = dommap ≫ ima.map)

variables {A B : simpler α}

@[simp]
lemma simpler_inj (f : simpler_map A  B) (pre) :
    (simpler_map.mk f.dommap f.imamap pre) = f :=
begin
    cases f,
    refl,
end

def simpler_maps_comp {A B C: simpler α} (f : simpler_map A B) (g : simpler_map B C) :
simpler_map A C :=
{
    dommap := f.dommap ≫ g.dommap,
    imamap := f.imamap ≫ g.imamap,
    preserve :=
       calc A.map ≫ f.imamap ≫ g.imamap
            = (f.dommap ≫ B.map) ≫ g.imamap : by rw [← category.assoc, f.preserve]
        ... = f.dommap ≫ B.map ≫ g.imamap : by  rw [category.assoc]
        ... = f.dommap ≫ g.dommap ≫ C.map : by rw [← g.preserve]
        ... = (f.dommap ≫ g.dommap) ≫ C.map : by rw [← category.assoc],
}

instance simpler_category : category (simpler α) :=
{
    hom := λ x y, simpler_map x y,
    id := λ x, { dommap := 𝟙 x.dom, imamap := 𝟙 x.ima,  preserve := by simp },
    comp := λ _ _ _ f g, simpler_maps_comp f g,
    id_comp' := λ _ _ f, by {simp at *, unfold simpler_maps_comp, simp},
    comp_id' := λ _ _ f, by {simp at *, unfold simpler_maps_comp, simp},
    assoc'   := λ _ _ _ _ f g h, by {simp, unfold simpler_maps_comp, simp}
}

def simpler_set := @simpler Type* category_theory.types
def simpler_set_map (dom: simpler_set) (ima: simpler_set):= simpler_map dom ima

def SimplerSetCategory := category simpler_set

def endo_inclusion_on_objs (e : endomap α) : simpler α := ⟨ e.carrier, e.carrier, e.endo ⟩
def endo_inclusion_on_maps {A B : endomap α } (f : endomaps_map A B) :
    simpler_map (endo_inclusion_on_objs A) (endo_inclusion_on_objs B) :=
{
    dommap := f.map,
    imamap := f.map,
    preserve := f.preserve
}

-- Exercise 14 page 144

def AddOne : simpler_set := ⟨ ℕ, ℕ, λ n, n + 1 ⟩
def AddTwo : simpler_set := ⟨ ℕ, ℕ, λ n, n + 2 ⟩

def AddOneEndo : Endoset := ⟨ ℕ, λ n, n + 1 ⟩
def AddTwoEndo : Endoset := ⟨ ℕ, λ n, n + 2 ⟩

def AddOneToAddTwo : simpler_map (endo_inclusion_on_objs AddOneEndo) (endo_inclusion_on_objs AddTwoEndo) := {
     dommap := λ n:ℕ, nat.add n  1,
     imamap := λ n:ℕ, nat.add n  2,
     preserve := by {
         ext a,
         change nat.add (a + 1) 2 = (a + 2) + 1,
         simp,
     }
}

example : ¬ ∃ f, endo_inclusion_on_maps f = AddOneToAddTwo :=
begin
    intros h,
    rcases h with ⟨ f, h⟩ ,
    unfold endo_inclusion_on_maps at h,
    unfold AddOneToAddTwo at h,
    simp at *,
    cases h,
    rw h_left at h_right,
    have := congr_fun h_right 0,
    exact (nat.succ_ne_self 1) this.symm,
end

end simpler

section ref_graphs

variables {α β δ γ ε ζ : Type u}

structure ref_graph (α : Type u) (β : Type u) extends irr_graph α β  :=
(i : β → α)
(rets: s ∘ i = id)
(rett: t ∘ i = id)

structure ref_graph_map (dom : ref_graph α β) (ima : ref_graph δ γ)
    extends irr_graph_map dom.to_irr_graph ima.to_irr_graph :=
(prei: fa ∘ dom.i = ima.i ∘ fd)

variables {A : ref_graph α β} {B : ref_graph δ γ} {C : ref_graph ε ζ}

def ref_graph_map_comp (f : ref_graph_map A B) (g : ref_graph_map B C) : ref_graph_map A C :=
{
    prei := by {
        simp,
            calc (g.fa ∘ f.fa) ∘ A.i = g.fa ∘ (f.fa ∘ A.i) : by simp
                ... = g.fa ∘ B.i ∘ f.fd : by rw f.prei
                ... = (g.fa ∘ B.i) ∘ f.fd : by simp
                ... = (C.i ∘ g.fd) ∘ f.fd : by rw g.prei
                ... = C.i ∘ (g.fd ∘ f.fd) : by simp,

        },

    ..irr_graph_map_comp f.to_irr_graph_map g.to_irr_graph_map,
}

-- Exercise 15 page 145
example : (A.i ∘ A.s) ∘ (A.i ∘ A.s) = A.i ∘ A.s :=
calc (A.i ∘ A.s) ∘ (A.i ∘ A.s) = A.i ∘ (A.s ∘ A.i) ∘ A.s : by simp
    ... = A.i ∘ A.s : by simp[A.rets]

example : (A.i ∘ A.t) ∘ (A.i ∘ A.t) = A.i ∘ A.t :=
calc (A.i ∘ A.t) ∘ (A.i ∘ A.t) = A.i ∘ (A.t ∘ A.i) ∘ A.t : by simp
    ... = A.i ∘ A.t : by simp[A.rett]

example : (A.i ∘ A.t) ∘ (A.i ∘ A.s) = A.i ∘ A.s :=
calc (A.i ∘ A.t) ∘ (A.i ∘ A.s) = A.i ∘ (A.t ∘ A.i) ∘ A.s : by simp
    ... = A.i ∘ A.s : by simp[A.rett]

example : (A.i ∘ A.s) ∘ (A.i ∘ A.t) = A.i ∘ A.t :=
calc (A.i ∘ A.s) ∘ (A.i ∘ A.t) = A.i ∘ (A.s ∘ A.i) ∘ A.t : by simp
    ... = A.i ∘ A.t : by simp [A.rets]

-- Exercise 16 page 145
example (f : ref_graph_map A B) : f.fd = B.s ∘ f.fa ∘ A.i :=
calc f.fd = (B.s ∘ B.i) ∘ f.fd : by simp [B.rets]
     ... = B.s ∘ (B.i ∘ f.fd) : by simp
     ... = B.s ∘ f.fa ∘ A.i : by rw f.prei

end ref_graphs

open category_theory
variables {C : Type*}
variables [category C]
variables {A B T : C}

def injective (a : A ⟶ B) := ∀ (T : C) (x1 x2 : T ⟶ A), x1 ≫ a = x2 ≫ a → x1 = x2

-- Exercise 18 page 146
theorem injective_of_retraction {a : A ⟶ B} {p : B ⟶ A} (ret: is_retraction a p) :
    injective a :=
begin
    intros T x1 x2 h,
    unfold is_retraction at ret,
    calc x1 = x1 ≫ 𝟙 A : by simp
        ... = x1 ≫ a ≫ p : by rw ret
        ... = (x1 ≫ a) ≫ p : by simp
        ... = x2 ≫ a ≫ p : by {rw h, simp}
        ... = x2 : by {simp [ret]}
end

section endo_example

open category_theory

inductive Xs : Type
| x | z

inductive Ys : Type
| ybar | y | z

def alpha : Xs → Xs
| Xs.x := Xs.z
| Xs.z := Xs.z

def beta  : Ys → Ys
| Ys.ybar := Ys.y
| Ys.y := Ys.z
| Ys.z := Ys.z

def as : Xs → Ys
| Xs.x := Ys.y
| Xs.z := Ys.z

def X : Endoset := ⟨ Xs, alpha ⟩
def Y : Endoset := ⟨ Ys, beta ⟩

-- Exercise 19 page 147
def a : Endoset_map X Y := ⟨ as, by {ext, cases x; refl} ⟩

-- Exercise 20 page 147
-- FixMe simplify proof
example : @injective Endoset endo_category  X Y a :=
begin
    intros e x1 x2 h,
    cases x1,
    cases x2,
    unfold a at h,
    congr,
    ext,
    injections_and_clear,
    dsimp at *,

    have foo := congr_fun h_1 x,
    simp at foo,
    cases x1_map x,
    {

        cases x2_map x, refl, simp, unfold as at foo,
        simp at foo,
        exact foo,
    },
    {
        cases x2_map x, simp, unfold as at foo,
        simp at foo,
        exact foo,
        refl,
    }
end

-- Exercise 21 page 147
def as_ret1 : Ys → Xs
| Ys.ybar := Xs.x
| Ys.y := Xs.x
| Ys.z := Xs.z

def as_ret2 : Ys → Xs
| Ys.ybar := Xs.z
| Ys.y := Xs.x
| Ys.z := Xs.z

-- FixMe simplify proof
example : ∀ (f : Ys → Xs), f ∘ as = id → f = as_ret1 ∨ f = as_ret2 :=
begin
    intros f h,
    apply classical.or_iff_not_imp_left.mpr,
    intros notret1,
    ext,
    have h1: f Ys.ybar ≠ as_ret1 Ys.ybar,
    {
        have a1 : f Ys.y = as_ret1 Ys.y, {change (f ∘ as) Xs.x = Xs.x, rw h, refl},
        have a2 : f Ys.z = as_ret1 Ys.z, {change (f ∘ as) Xs.z = Xs.z, rw h, refl},
        intros eq_ybar,
        have  eq : f = as_ret1 , {ext, cases x_1; assumption},
        exact notret1 eq,
    },

    cases x,
    {
        have  :f Ys.ybar = as_ret1 Ys.ybar ∨ f Ys.ybar = as_ret2 Ys.ybar,
        {
            change f Ys.ybar = Xs.x ∨ f Ys.ybar = Xs.z,
            cases f Ys.ybar; simp
        },

        cases this,
        exact false.elim (h1 this),
        exact this,
    },
    {
      change (f ∘ as) Xs.x = Xs.x,
      rw h,
      simp,
    },
    {
      change (f ∘ as) Xs.z = Xs.z,
      rw h,
      simp,
    }
end

-- Exercise 22 page 147
example : as_ret1 ∘ beta ≠ alpha ∘ as_ret1 :=
begin
    intros h,
    have := congr_fun h Ys.ybar,
    injections,
end

example : as_ret2 ∘ beta ≠ alpha ∘ as_ret2 :=
begin
    intros h,
    have := congr_fun h Ys.ybar,
    injections,
end

-- Exercise 25 page 148
example (α β δ γ : Type*) (A : irr_graph α β) (B : irr_graph δ γ) (f : irr_graph_map A B)
    : f.fd ∘ A.s = f.fd ∘ A.t
    → B.s ∘ f.fa = B.t ∘ f.fa :=
begin
    intros h,
    rw ← f.pres,
    rw h,
    rw f.pret,
end

-- Exercise 26 page 148
def zinc (n : ℤ) : ℚ := ↑ n

def z5x_endo : Endoset := ⟨ ℤ, λ n, n * 5 ⟩
def q5x_endo : Endoset := ⟨ ℚ, λ p, p * 5 ⟩

-- part 1
def zinc_endo_map : Endoset_map z5x_endo q5x_endo :=
{
    map := zinc,
    preserve := by {
        ext,
        simp,
        change zinc (x * 5) = (zinc x) * 5,
        unfold zinc,
        simp,
    }
}

def x5 (p : ℚ) : ℚ := p * 5

-- part 2
example : ∃ (f : ℚ → ℚ), f ∘ x5 = id ∧ x5 ∘ f = id :=
begin
    use λ q, q / 5,
    split;
    {
        ext, simp, unfold x5, ring,

    }
end

lemma endomap_eq (α : Type*) [category α]  (A : endomap α ) (B : endomap α) (f : endomaps_map A B) (g :endomaps_map A B)  :
  f.map = g.map → f = g :=
begin
    intros h,
    cases f, cases g,
    simp at *,
    exact h,
end

-- part 3
example : @injective Endoset endo_category  z5x_endo q5x_endo zinc_endo_map :=
begin
    intros e x1 x2 h,
    unfold zinc_endo_map at h,
    injections_and_clear,
    simp at h_1,

    change zinc ∘ x1.map = zinc ∘ x2.map at h_1,

    have caca : x1.map = x2.map, {
        ext,
        have foo := congr_fun h_1 x,
        simp at foo,
        unfold zinc at foo,
        norm_cast at *,
        exact foo,
    },

    apply endomap_eq,
    exact caca,

end

-- Exercise 27 page 148
inductive Set27 : Type
| x | y

def a27 : Set27 → Set27
| Set27.x := Set27.y
| Set27.y := Set27.y

def X27 : Endoset := ⟨ Set27, a27 ⟩

def invert_map : Endoset_map X27 X27 :=
{
    map := a27,
    preserve := by {
        ext,
        cases x; refl,
    }
}

instance : category Endoset :=  endoset_category

example (Y27 : Endoset) (auto : Y27.endo ≫ Y27.endo = 𝟙 Y27.carrier) (f: Endoset_map X27 Y27):
    ¬ @injective Endoset endoset_category X27 Y27 f :=
begin
    intros inj,
    suffices h: f.map Set27.x = f.map Set27.y,
    {

        unfold injective at inj,
        have := inj X27 (𝟙 X27) invert_map,
        simp at this,

        have foo := this (by {
            apply endomap_eq,
            ext,
            cases x,
            {
                rw h,
                refl,
            },
            {
                refl,

            }
        }),
        unfold invert_map at foo,

        have caca := congr_arg (λ m:Endoset_map _ _, m.map) foo,
        simp at caca,
        have := congr_fun caca Set27.x,
        change Set27.x = Set27.y at this,
        simp at this_1,
        exact this_1,
    },
    {
        have  : Y27.endo (f.map Set27.x) = Y27.endo (f.map Set27.y) → f.map Set27.x = f.map Set27.y , {
            -- automorph is injective
            intros h,
            have := congr_arg Y27.endo h,
            have foo := congr_fun auto (f.map Set27.x),
            simp at foo,
            rw foo at this,
            have foo := congr_fun auto (f.map Set27.y),
            simp at foo,
            rw foo at this,
            exact this,
        },
        apply this,

        have prex := congr_fun f.preserve Set27.x,
        have prey := congr_fun f.preserve Set27.y,
        simp at *,
        rw ← prey,
        rw ← prex,
        refl,

    }
end

end endo_example

end exercises


import Smt.Tactic.Concretize

def generalAdd [Add α] (a b : α) := a + b

example : @generalAdd Int _ 3 3 = (6 : Int) := by
  concretize [generalAdd]
  rfl


import analysis.calculus.bump_function_inner
import topology.metric_space.hausdorff_distance

import local.one_jet

/-!
# Local partial differential relations and their formal solutions

This file defines `rel_loc E F`, the type of first order partial differential relations
for maps between two real normed spaces `E` and `F`.

To any `R : rel_loc E F` we associate the type `sol R` of maps `f : E → F` of
solutions of `R`, and its formal counterpart `formal_sol R`.

The h-principle question is whether we can deform any formal solution into a solution.
The type of deformations is `htpy_jet_sec E F` (homotopies of 1-jet sections).
-/

noncomputable theory

open set function real filter
open_locale unit_interval topology

variables (E : Type*) [normed_add_comm_group E] [normed_space ℝ E]
variables (F : Type*) [normed_add_comm_group F] [normed_space ℝ F]
variables (P : Type*) [normed_add_comm_group P] [normed_space ℝ P]

/-- A first order relation for maps between real vector spaces. -/
def rel_loc := set (one_jet E F)

instance : has_mem (E × F × (E →L[ℝ] F)) (rel_loc E F) := set.has_mem

variables {E F}

/-- A predicate stating that a 1-jet section is a formal solution to a first order relation for
maps between vector spaces. -/
def jet_sec.is_formal_sol (𝓕 : jet_sec E F) (R : rel_loc E F) : Prop :=
∀ x, (x, 𝓕.f x, 𝓕.φ x) ∈ R

namespace rel_loc

/-- A formal solution to a local relation `R`. -/
@[ext] structure formal_sol (R : rel_loc E F) extends jet_sec E F :=
(is_sol : ∀ x, (x, f x, φ x) ∈ R)

instance (R : rel_loc E F) : has_coe (formal_sol R) (jet_sec E F):=
⟨formal_sol.to_jet_sec⟩

@[simp] lemma formal_sol.to_jet_sec_eq_coe {R : rel_loc E F} (𝓕 : formal_sol R) :
𝓕.to_jet_sec = (𝓕 : jet_sec E F) := rfl

@[simp] lemma formal_sol.coe_is_formal_sol  {R : rel_loc E F} (𝓕 : formal_sol R) :
  (𝓕 : jet_sec E F).is_formal_sol R := 𝓕.is_sol

/-- Bundling a formal solution from a 1-jet section that is a formal solution. -/
def _root_.jet_sec.is_formal_sol.formal_sol  {𝓕 : jet_sec E F} {R : rel_loc E F}
  (h : 𝓕.is_formal_sol R) : formal_sol R :=
{is_sol := h, ..𝓕}

instance (R : rel_loc E F) : has_coe_to_fun (formal_sol R) (λ S, E → F × (E →L[ℝ] F)) :=
⟨λ 𝓕, λ x, (𝓕.f x, 𝓕.φ x)⟩

@[simp] lemma formal_sol.coe_apply  {R : rel_loc E F} (𝓕 : formal_sol R) (x : E) :
(𝓕 : jet_sec E F) x = 𝓕 x := rfl

variables  {R : rel_loc E F}

lemma formal_sol.eq_iff {𝓕 𝓕' : formal_sol R} {x : E} :
  𝓕 x = 𝓕' x ↔ 𝓕.f x = 𝓕'.f x ∧ 𝓕.φ x = 𝓕'.φ x :=
jet_sec.eq_iff

/-- A formal solution (f, φ) is holonomic at `x` if the differential of `f` at `x` is `φ x`. -/
def formal_sol.is_holonomic_at (𝓕 : formal_sol R) (x : E) : Prop := D 𝓕.f x = 𝓕.φ x

-- TODO: this should come from a lemma about `jet_sec`
lemma formal_sol.is_holonomic_at_congr (𝓕 𝓕' : formal_sol R) {s : set E}
  (h : ∀ᶠ x near s, 𝓕 x = 𝓕' x) : ∀ᶠ x near s, 𝓕.is_holonomic_at x ↔ 𝓕'.is_holonomic_at x :=
begin
  apply h.eventually_nhds_set.mono,
  intros x hx,
  have hf : 𝓕.f =ᶠ[𝓝 x] 𝓕'.f,
  { apply hx.mono,
    simp_rw rel_loc.formal_sol.eq_iff,
    tauto },
  unfold rel_loc.formal_sol.is_holonomic_at,
  rw [hf.fderiv_eq, (rel_loc.formal_sol.eq_iff.mp hx.self_of_nhds).2]
end

variable (P)
/-- A family of formal solutions is a 1-parameter family of formal solutions. -/
@[ext] structure family_formal_sol (R : rel_loc E F) extends family_jet_sec E F P :=
(is_sol : ∀ t x, (x, f t x, φ t x) ∈ R)

/-- A homotopy of formal solutions is a 1-parameter family of formal solutions. -/
@[reducible] def htpy_formal_sol (R : rel_loc E F) := R.family_formal_sol ℝ

def htpy_formal_sol.to_htpy_jet_sec {R : rel_loc E F} (𝓕 : R.htpy_formal_sol) : htpy_jet_sec E F :=
𝓕.to_family_jet_sec

open rel_loc

instance (R : rel_loc E F) : has_coe_to_fun (family_formal_sol P R) (λ S, P → jet_sec E F) :=
⟨λ S t,
 { f := S.f t,
   f_diff := S.f_diff.comp (cont_diff_const.prod cont_diff_id),
   φ := S.φ t,
   φ_diff := S.φ_diff.comp (cont_diff_const.prod cont_diff_id) }⟩

end rel_loc


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Reid Barton, Patrick Massot, Scott Morrison
-/
import category_theory.adjunction.reflective
import category_theory.concrete_category.unbundled_hom
import category_theory.monad.limits
import category_theory.limits.has_limits
import topology.category.Top.basic
import topology.uniform_space.completion

/-!
# The category of uniform spaces

We construct the category of uniform spaces, show that the complete separated uniform spaces
form a reflective subcategory, and hence possess all limits that uniform spaces do.

TODO: show that uniform spaces actually have all limits!
-/

universes u

open category_theory

/-- A (bundled) uniform space. -/
def UniformSpace : Type (u+1) := bundled uniform_space

namespace UniformSpace

/-- The information required to build morphisms for `UniformSpace`. -/
instance : unbundled_hom @uniform_continuous :=
⟨@uniform_continuous_id, @uniform_continuous.comp⟩

attribute [derive [large_category, concrete_category]] UniformSpace

instance : has_coe_to_sort UniformSpace Type* := bundled.has_coe_to_sort

instance (x : UniformSpace) : uniform_space x := x.str

/-- Construct a bundled `UniformSpace` from the underlying type and the typeclass. -/
def of (α : Type u) [uniform_space α] : UniformSpace := ⟨α⟩

instance : inhabited UniformSpace := ⟨UniformSpace.of empty⟩

@[simp] lemma coe_of (X : Type u) [uniform_space X] : (of X : Type u) = X := rfl

instance (X Y : UniformSpace) : has_coe_to_fun (X ⟶ Y) (λ _, X → Y) :=
⟨category_theory.functor.map (forget UniformSpace)⟩

@[simp] lemma coe_comp {X Y Z : UniformSpace} (f : X ⟶ Y) (g : Y ⟶ Z) :
  (f ≫ g : X → Z) = g ∘ f := rfl
@[simp] lemma coe_id (X : UniformSpace) : (𝟙 X : X → X) = id := rfl
@[simp] lemma coe_mk {X Y : UniformSpace} (f : X → Y) (hf : uniform_continuous f) :
  ((⟨f, hf⟩ : X ⟶ Y) : X → Y) = f := rfl

lemma hom_ext {X Y : UniformSpace} {f g : X ⟶ Y} : (f : X → Y) = g → f = g := subtype.eq

/-- The forgetful functor from uniform spaces to topological spaces. -/
instance has_forget_to_Top : has_forget₂ UniformSpace.{u} Top.{u} :=
{ forget₂ :=
  { obj := λ X, Top.of X,
    map := λ X Y f, { to_fun := f,
                      continuous_to_fun := uniform_continuous.continuous f.property }, }, }

end UniformSpace

/-- A (bundled) complete separated uniform space. -/
structure CpltSepUniformSpace :=
(α : Type u)
[is_uniform_space : uniform_space α]
[is_complete_space : complete_space α]
[is_separated : separated_space α]

namespace CpltSepUniformSpace

instance : has_coe_to_sort CpltSepUniformSpace (Type u) := ⟨CpltSepUniformSpace.α⟩

attribute [instance] is_uniform_space is_complete_space is_separated

/-- The function forgetting that a complete separated uniform spaces is complete and separated. -/
def to_UniformSpace (X : CpltSepUniformSpace) : UniformSpace :=
UniformSpace.of X

instance complete_space (X : CpltSepUniformSpace) : complete_space ((to_UniformSpace X).α) :=
CpltSepUniformSpace.is_complete_space X

instance separated_space (X : CpltSepUniformSpace) : separated_space ((to_UniformSpace X).α) :=
CpltSepUniformSpace.is_separated X

/-- Construct a bundled `UniformSpace` from the underlying type and the appropriate typeclasses. -/
def of (X : Type u) [uniform_space X] [complete_space X] [separated_space X] :
CpltSepUniformSpace := ⟨X⟩

@[simp] lemma coe_of (X : Type u) [uniform_space X] [complete_space X] [separated_space X] :
  (of X : Type u) = X := rfl

instance : inhabited CpltSepUniformSpace :=
begin
  haveI : separated_space empty := separated_iff_t2.mpr (by apply_instance),
  exact ⟨CpltSepUniformSpace.of empty⟩
end

/-- The category instance on `CpltSepUniformSpace`. -/
instance category : large_category CpltSepUniformSpace :=
induced_category.category to_UniformSpace

/-- The concrete category instance on `CpltSepUniformSpace`. -/
instance concrete_category : concrete_category CpltSepUniformSpace :=
induced_category.concrete_category to_UniformSpace

instance has_forget_to_UniformSpace : has_forget₂ CpltSepUniformSpace UniformSpace :=
induced_category.has_forget₂ to_UniformSpace

end CpltSepUniformSpace

namespace UniformSpace

open uniform_space
open CpltSepUniformSpace

/-- The functor turning uniform spaces into complete separated uniform spaces. -/
noncomputable def completion_functor : UniformSpace ⥤ CpltSepUniformSpace :=
{ obj := λ X, CpltSepUniformSpace.of (completion X),
  map := λ X Y f, ⟨completion.map f.1, completion.uniform_continuous_map⟩,
  map_id' := λ X, subtype.eq completion.map_id,
  map_comp' := λ X Y Z f g, subtype.eq (completion.map_comp g.property f.property).symm, }.

/-- The inclusion of a uniform space into its completion. -/
def completion_hom (X : UniformSpace) :
  X ⟶ (forget₂ CpltSepUniformSpace UniformSpace).obj (completion_functor.obj X) :=
{ val := (coe : X → completion X),
  property := completion.uniform_continuous_coe X }

@[simp] lemma completion_hom_val (X : UniformSpace) (x) :
  (completion_hom X) x = (x : completion X) := rfl

/-- The mate of a morphism from a `UniformSpace` to a `CpltSepUniformSpace`. -/
noncomputable def extension_hom {X : UniformSpace} {Y : CpltSepUniformSpace}
  (f : X ⟶ (forget₂ CpltSepUniformSpace UniformSpace).obj Y) :
  completion_functor.obj X ⟶ Y :=
{ val := completion.extension f,
  property := completion.uniform_continuous_extension }

@[simp] lemma extension_hom_val {X : UniformSpace} {Y : CpltSepUniformSpace}
  (f : X ⟶ (forget₂ _ _).obj Y) (x) :
  (extension_hom f) x = completion.extension f x := rfl.

@[simp]

/-- The completion functor is left adjoint to the forgetful functor. -/
noncomputable def adj : completion_functor ⊣ forget₂ CpltSepUniformSpace UniformSpace :=
adjunction.mk_of_hom_equiv
{ hom_equiv := λ X Y,
  { to_fun := λ f, completion_hom X ≫ f,
    inv_fun := λ f, extension_hom f,
    left_inv := λ f, by { dsimp, erw extension_comp_coe },
    right_inv := λ f,
    begin
      apply subtype.eq, funext x, cases f,
      exact @completion.extension_coe _ _ _ _ _ (CpltSepUniformSpace.separated_space _) f_property _
    end },
  hom_equiv_naturality_left_symm' := λ X X' Y f g,
  begin
    apply hom_ext, funext x, dsimp,
    erw [coe_comp, ←completion.extension_map],
    refl, exact g.property, exact f.property,
  end }

noncomputable instance : is_right_adjoint (forget₂ CpltSepUniformSpace UniformSpace) :=
⟨completion_functor, adj⟩
noncomputable instance : reflective (forget₂ CpltSepUniformSpace UniformSpace) := {}

open category_theory.limits

-- TODO Once someone defines `has_limits UniformSpace`, turn this into an instance.
example [has_limits.{u} UniformSpace.{u}] : has_limits.{u} CpltSepUniformSpace.{u} :=
has_limits_of_reflective $ forget₂ CpltSepUniformSpace UniformSpace.{u}

end UniformSpace


example (P Q : Type) (p : P) (h : P → Q) : Q :=
begin
    exact h(p),
end


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

universes w u v u_1

namespace Mathlib

/-!
# The category of graded objects

For any type `β`, a `β`-graded object over some category `C` is just
a function `β → C` into the objects of `C`.
We put the "pointwise" category structure on these, as the non-dependent specialization of
`category_theory.pi`.

We describe the `comap` functors obtained by precomposing with functions `β → γ`.

As a consequence a fixed element (e.g. `1`) in an additive group `β` provides a shift
functor on `β`-graded objects

When `C` has coproducts we construct the `total` functor `graded_object β C ⥤ C`,
show that it is faithful, and deduce that when `C` is concrete so is `graded_object β C`.
-/

namespace category_theory

/-- A type synonym for `β → C`, used for `β`-graded objects in a category `C`. -/
def graded_object (β : Type w) (C : Type u) :=
  β → C

-- Satisfying the inhabited linter...

protected instance inhabited_graded_object (β : Type w) (C : Type u) [Inhabited C] : Inhabited (graded_object β C) :=
  { default := fun (b : β) => Inhabited.default }

/--
A type synonym for `β → C`, used for `β`-graded objects in a category `C`
with a shift functor given by translation by `s`.
-/
def graded_object_with_shift {β : Type w} [add_comm_group β] (s : β) (C : Type u) :=
  graded_object β C

namespace graded_object

protected instance category_of_graded_objects {C : Type u} [category C] (β : Type w) : category (graded_object β C) :=
  category_theory.pi fun (_x : β) => C

/--
The natural isomorphism comparing between
pulling back along two propositionally equal functions.
-/
def comap_eq (C : Type u) [category C] {β : Type w} {γ : Type w} {f : β → γ} {g : β → γ} (h : f = g) : pi.comap (fun (i : γ) => C) f ≅ pi.comap (fun (i : γ) => C) g :=
  iso.mk (nat_trans.mk fun (X : γ → C) (b : β) => eq_to_hom sorry)
    (nat_trans.mk fun (X : γ → C) (b : β) => eq_to_hom sorry)

theorem comap_eq_symm (C : Type u) [category C] {β : Type w} {γ : Type w} {f : β → γ} {g : β → γ} (h : f = g) : comap_eq C (Eq.symm h) = iso.symm (comap_eq C h) :=
  Eq.refl (comap_eq C (Eq.symm h))

theorem comap_eq_trans (C : Type u) [category C] {β : Type w} {γ : Type w} {f : β → γ} {g : β → γ} {h : β → γ} (k : f = g) (l : g = h) : comap_eq C (Eq.trans k l) = comap_eq C k ≪≫ comap_eq C l := sorry

/--
The equivalence between β-graded objects and γ-graded objects,
given an equivalence between β and γ.
-/
def comap_equiv (C : Type u) [category C] {β : Type w} {γ : Type w} (e : β ≃ γ) : graded_object β C ≌ graded_object γ C :=
  equivalence.mk' (pi.comap (fun (_x : β) => C) ⇑(equiv.symm e)) (pi.comap (fun (_x : γ) => C) ⇑e)
    (comap_eq C sorry ≪≫ iso.symm (pi.comap_comp (fun (_x : β) => C) ⇑e ⇑(equiv.symm e)))
    (pi.comap_comp (fun (_x : γ) => C) ⇑(equiv.symm e) ⇑e ≪≫ comap_eq C sorry)

protected instance has_shift {C : Type u} [category C] {β : Type u_1} [add_comm_group β] (s : β) : has_shift (graded_object_with_shift s C) :=
  has_shift.mk (comap_equiv C (equiv.mk (fun (b : β) => b - s) (fun (b : β) => b + s) sorry sorry))

@[simp] theorem shift_functor_obj_apply {C : Type u} [category C] {β : Type u_1} [add_comm_group β] (s : β) (X : β → C) (t : β) : functor.obj (equivalence.functor (shift (graded_object_with_shift s C))) X t = X (t + s) :=
  rfl

@[simp] theorem shift_functor_map_apply {C : Type u} [category C] {β : Type u_1} [add_comm_group β] (s : β) {X : graded_object_with_shift s C} {Y : graded_object_with_shift s C} (f : X ⟶ Y) (t : β) : functor.map (equivalence.functor (shift (graded_object_with_shift s C))) f t = f (t + s) :=
  rfl

protected instance has_zero_morphisms {C : Type u} [category C] [limits.has_zero_morphisms C] (β : Type w) : limits.has_zero_morphisms (graded_object β C) :=
  limits.has_zero_morphisms.mk

@[simp] theorem zero_apply {C : Type u} [category C] [limits.has_zero_morphisms C] (β : Type w) (X : graded_object β C) (Y : graded_object β C) (b : β) : HasZero.zero b = 0 :=
  rfl

protected instance has_zero_object {C : Type u} [category C] [limits.has_zero_object C] [limits.has_zero_morphisms C] (β : Type w) : limits.has_zero_object (graded_object β C) :=
  limits.has_zero_object.mk (fun (b : β) => 0)
    (fun (X : graded_object β C) => unique.mk { default := fun (b : β) => 0 } sorry)
    fun (X : graded_object β C) => unique.mk { default := fun (b : β) => 0 } sorry

end graded_object

namespace graded_object

-- The universes get a little hairy here, so we restrict the universe level for the grading to 0.

-- Since we're typically interested in grading by ℤ or a finite group, this should be okay.

-- If you're grading by things in higher universes, have fun!

/--
The total object of a graded object is the coproduct of the graded components.
-/
def total (β : Type) (C : Type u) [category C] [limits.has_coproducts C] : graded_object β C ⥤ C :=
  functor.mk (fun (X : graded_object β C) => ∐ fun (i : ulift β) => X (ulift.down i))
    fun (X Y : graded_object β C) (f : X ⟶ Y) => limits.sigma.map fun (i : ulift β) => f (ulift.down i)

/--
The `total` functor taking a graded object to the coproduct of its graded components is faithful.
To prove this, we need to know that the coprojections into the coproduct are monomorphisms,
which follows from the fact we have zero morphisms and decidable equality for the grading.
-/
protected instance total.category_theory.faithful (β : Type) (C : Type u) [category C] [limits.has_coproducts C] [limits.has_zero_morphisms C] : faithful (total β C) :=
  faithful.mk

end graded_object

namespace graded_object

protected instance category_theory.concrete_category (β : Type) (C : Type (u + 1)) [large_category C] [concrete_category C] [limits.has_coproducts C] [limits.has_zero_morphisms C] : concrete_category (graded_object β C) :=
  concrete_category.mk (total β C ⋙ forget C)

protected instance category_theory.has_forget₂ (β : Type) (C : Type (u + 1)) [large_category C] [concrete_category C] [limits.has_coproducts C] [limits.has_zero_morphisms C] : has_forget₂ (graded_object β C) C :=
  has_forget₂.mk (total β C)


/-
Copyright (c) 2021 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser
-/
import group_theory.subgroup.basic
import algebra.graded_monoid
import algebra.direct_sum.basic
import algebra.big_operators.pi

/-!
# Additively-graded multiplicative structures on `⨁ i, A i`

This module provides a set of heterogeneous typeclasses for defining a multiplicative structure
over `⨁ i, A i` such that `(*) : A i → A j → A (i + j)`; that is to say, `A` forms an
additively-graded ring. The typeclasses are:

* `direct_sum.gnon_unital_non_assoc_semiring A`
* `direct_sum.gsemiring A`
* `direct_sum.gcomm_semiring A`

Respectively, these imbue the external direct sum `⨁ i, A i` with:

* `direct_sum.non_unital_non_assoc_semiring`, `direct_sum.non_unital_non_assoc_ring`
* `direct_sum.semiring`, `direct_sum.ring`
* `direct_sum.comm_semiring`, `direct_sum.comm_ring`

the base ring `A 0` with:

* `direct_sum.grade_zero.non_unital_non_assoc_semiring`,
  `direct_sum.grade_zero.non_unital_non_assoc_ring`
* `direct_sum.grade_zero.semiring`, `direct_sum.grade_zero.ring`
* `direct_sum.grade_zero.comm_semiring`, `direct_sum.grade_zero.comm_ring`

and the `i`th grade `A i` with `A 0`-actions (`•`) defined as left-multiplication:

* `direct_sum.grade_zero.has_scalar (A 0)`, `direct_sum.grade_zero.smul_with_zero (A 0)`
* `direct_sum.grade_zero.module (A 0)`
* (nothing)

Note that in the presence of these instances, `⨁ i, A i` itself inherits an `A 0`-action.

`direct_sum.of_zero_ring_hom : A 0 →+* ⨁ i, A i` provides `direct_sum.of A 0` as a ring
homomorphism.

`direct_sum.to_semiring` extends `direct_sum.to_add_monoid` to produce a `ring_hom`.

## Direct sums of subobjects

Additionally, this module provides helper functions to construct `gsemiring` and `gcomm_semiring`
instances for:

* `A : ι → submonoid S`:
  `direct_sum.gsemiring.of_add_submonoids`, `direct_sum.gcomm_semiring.of_add_submonoids`.
* `A : ι → subgroup S`:
  `direct_sum.gsemiring.of_add_subgroups`, `direct_sum.gcomm_semiring.of_add_subgroups`.
* `A : ι → submodule S`:
  `direct_sum.gsemiring.of_submodules`, `direct_sum.gcomm_semiring.of_submodules`.

If `complete_lattice.independent (set.range A)`, these provide a gradation of `⨆ i, A i`, and the
mapping `⨁ i, A i →+ ⨆ i, A i` can be obtained as
`direct_sum.to_monoid (λ i, add_submonoid.inclusion $ le_supr A i)`.

## tags

graded ring, filtered ring, direct sum, add_submonoid
-/

set_option old_structure_cmd true

variables {ι : Type*} [decidable_eq ι]

namespace direct_sum

open_locale direct_sum

/-! ### Typeclasses -/
section defs

variables (A : ι → Type*)

/-- A graded version of `non_unital_non_assoc_semiring`. -/
class gnon_unital_non_assoc_semiring [has_add ι] [Π i, add_comm_monoid (A i)] extends
  graded_monoid.ghas_mul A :=
(mul_zero : ∀ {i j} (a : A i), mul a (0 : A j) = 0)
(zero_mul : ∀ {i j} (b : A j), mul (0 : A i) b = 0)
(mul_add : ∀ {i j} (a : A i) (b c : A j), mul a (b + c) = mul a b + mul a c)
(add_mul : ∀ {i j} (a b : A i) (c : A j), mul (a + b) c = mul a c + mul b c)

end defs

section defs

variables (A : ι → Type*)

/-- A graded version of `semiring`. -/
class gsemiring [add_monoid ι] [Π i, add_comm_monoid (A i)] extends
  gnon_unital_non_assoc_semiring A, graded_monoid.gmonoid A

/-- A graded version of `comm_semiring`. -/
class gcomm_semiring [add_comm_monoid ι] [Π i, add_comm_monoid (A i)] extends
  gsemiring A, graded_monoid.gcomm_monoid A

end defs

lemma of_eq_of_graded_monoid_eq {A : ι → Type*} [Π (i : ι), add_comm_monoid (A i)]
  {i j : ι} {a : A i} {b : A j} (h : graded_monoid.mk i a = graded_monoid.mk j b) :
  direct_sum.of A i a = direct_sum.of A j b :=
dfinsupp.single_eq_of_sigma_eq h

variables (A : ι → Type*)

/-! ### Instances for `⨁ i, A i` -/

section one
variables [has_zero ι] [graded_monoid.ghas_one A] [Π i, add_comm_monoid (A i)]

instance : has_one (⨁ i, A i) :=
{ one := direct_sum.of (λ i, A i) 0 graded_monoid.ghas_one.one }

end one

section mul
variables [has_add ι] [Π i, add_comm_monoid (A i)] [gnon_unital_non_assoc_semiring A]

open add_monoid_hom (flip_apply coe_comp comp_hom_apply_apply)

/-- The piecewise multiplication from the `has_mul` instance, as a bundled homomorphism. -/
@[simps]
def gmul_hom {i j} : A i →+ A j →+ A (i + j) :=
{ to_fun := λ a,
  { to_fun := λ b, graded_monoid.ghas_mul.mul a b,
    map_zero' := gnon_unital_non_assoc_semiring.mul_zero _,
    map_add' := gnon_unital_non_assoc_semiring.mul_add _ },
  map_zero' := add_monoid_hom.ext $ λ a, gnon_unital_non_assoc_semiring.zero_mul a,
  map_add' := λ a₁ a₂, add_monoid_hom.ext $ λ b, gnon_unital_non_assoc_semiring.add_mul _ _ _}

/-- The multiplication from the `has_mul` instance, as a bundled homomorphism. -/
def mul_hom : (⨁ i, A i) →+ (⨁ i, A i) →+ ⨁ i, A i :=
direct_sum.to_add_monoid $ λ i,
  add_monoid_hom.flip $ direct_sum.to_add_monoid $ λ j, add_monoid_hom.flip $
    (direct_sum.of A _).comp_hom.comp $ gmul_hom A

instance : non_unital_non_assoc_semiring (⨁ i, A i) :=
{ mul := λ a b, mul_hom A a b,
  zero := 0,
  add := (+),
  zero_mul := λ a, by simp only [add_monoid_hom.map_zero, add_monoid_hom.zero_apply],
  mul_zero := λ a, by simp only [add_monoid_hom.map_zero],
  left_distrib := λ a b c, by simp only [add_monoid_hom.map_add],
  right_distrib := λ a b c, by simp only [add_monoid_hom.map_add, add_monoid_hom.add_apply],
  .. direct_sum.add_comm_monoid _ _}

variables {A}

lemma mul_hom_of_of {i j} (a : A i) (b : A j) :
  mul_hom A (of _ i a) (of _ j b) = of _ (i + j) (graded_monoid.ghas_mul.mul a b) :=
begin
  unfold mul_hom,
  rw [to_add_monoid_of, flip_apply, to_add_monoid_of, flip_apply, coe_comp, function.comp_app,
      comp_hom_apply_apply, coe_comp, function.comp_app, gmul_hom_apply_apply],
end

lemma of_mul_of {i j} (a : A i) (b : A j) :
  of _ i a * of _ j b = of _ (i + j) (graded_monoid.ghas_mul.mul a b) :=
mul_hom_of_of a b

end mul

section semiring
variables [Π i, add_comm_monoid (A i)] [add_monoid ι] [gsemiring A]

open add_monoid_hom (flip_hom coe_comp comp_hom_apply_apply flip_apply flip_hom_apply)

private lemma one_mul (x : ⨁ i, A i) : 1 * x = x :=
suffices mul_hom A 1 = add_monoid_hom.id (⨁ i, A i),
  from add_monoid_hom.congr_fun this x,
begin
  apply add_hom_ext, intros i xi,
  unfold has_one.one,
  rw mul_hom_of_of,
  exact of_eq_of_graded_monoid_eq (one_mul $ graded_monoid.mk i xi),
end

private lemma mul_one (x : ⨁ i, A i) : x * 1 = x :=
suffices (mul_hom A).flip 1 = add_monoid_hom.id (⨁ i, A i),
  from add_monoid_hom.congr_fun this x,
begin
  apply add_hom_ext, intros i xi,
  unfold has_one.one,
  rw [flip_apply, mul_hom_of_of],
  exact of_eq_of_graded_monoid_eq (mul_one $ graded_monoid.mk i xi),
end

private lemma mul_assoc (a b c : ⨁ i, A i) : a * b * c = a * (b * c) :=
suffices (mul_hom A).comp_hom.comp (mul_hom A)            -- `λ a b c, a * b * c` as a bundled hom
       = (add_monoid_hom.comp_hom flip_hom $              -- `λ a b c, a * (b * c)` as a bundled hom
             (mul_hom A).flip.comp_hom.comp (mul_hom A)).flip,
  from add_monoid_hom.congr_fun (add_monoid_hom.congr_fun (add_monoid_hom.congr_fun this a) b) c,
begin
  ext ai ax bi bx ci cx : 6,
  dsimp only [coe_comp, function.comp_app, comp_hom_apply_apply, flip_apply, flip_hom_apply],
  rw [mul_hom_of_of, mul_hom_of_of, mul_hom_of_of, mul_hom_of_of],
  exact of_eq_of_graded_monoid_eq (mul_assoc (graded_monoid.mk ai ax) ⟨bi, bx⟩ ⟨ci, cx⟩),
end

/-- The `semiring` structure derived from `gsemiring A`. -/
instance semiring : semiring (⨁ i, A i) :=
{ one := 1,
  mul := (*),
  zero := 0,
  add := (+),
  one_mul := one_mul A,
  mul_one := mul_one A,
  mul_assoc := mul_assoc A,
  ..direct_sum.non_unital_non_assoc_semiring _, }

lemma of_pow {i} (a : A i) (n : ℕ) :
  of _ i a ^ n = of _ (n • i) (graded_monoid.gmonoid.gnpow _ a) :=
begin
  induction n with n,
  { exact of_eq_of_graded_monoid_eq (pow_zero $ graded_monoid.mk _ a).symm, },
  { rw [pow_succ, n_ih, of_mul_of],
    exact of_eq_of_graded_monoid_eq (pow_succ (graded_monoid.mk _ a) n).symm, },
end

lemma of_list_dprod {α} (l : list α) (fι : α → ι) (fA : Π a, A (fι a)) :
  of A _ (l.dprod fι fA) = (l.map $ λ a, of A (fι a) (fA a)).prod :=
begin
  induction l,
  { simp only [list.map_nil, list.prod_nil, list.dprod_nil],
    refl },
  { simp only [list.map_cons, list.prod_cons, list.dprod_cons, ←l_ih, direct_sum.of_mul_of],
    refl },
end

lemma list_prod_of_fn_of_eq_dprod (n : ℕ) (fι : fin n → ι) (fA : Π a, A (fι a)) :
  (list.of_fn $ λ a, of A (fι a) (fA a)).prod = of A _ ((list.fin_range n).dprod fι fA) :=
by rw [list.of_fn_eq_map, of_list_dprod]

open_locale big_operators

/-- A heavily unfolded version of the definition of multiplication -/
lemma mul_eq_sum_support_ghas_mul
  [Π (i : ι) (x : A i), decidable (x ≠ 0)] (a a' : ⨁ i, A i) :
  a * a' =
    ∑ (ij : ι × ι) in (dfinsupp.support a).product (dfinsupp.support a'),
      direct_sum.of _ _ (graded_monoid.ghas_mul.mul (a ij.fst) (a' ij.snd)) :=
begin
  change direct_sum.mul_hom _ a a' = _,
  dsimp [direct_sum.mul_hom, direct_sum.to_add_monoid, dfinsupp.lift_add_hom_apply],
  simp only [dfinsupp.sum_add_hom_apply, dfinsupp.sum, dfinsupp.finset_sum_apply,
    add_monoid_hom.coe_finset_sum, finset.sum_apply, add_monoid_hom.flip_apply,
    add_monoid_hom.comp_hom_apply_apply, add_monoid_hom.comp_apply,
    direct_sum.gmul_hom_apply_apply],
  rw finset.sum_product,
end

end semiring

section comm_semiring

variables [Π i, add_comm_monoid (A i)] [add_comm_monoid ι] [gcomm_semiring A]

private lemma mul_comm (a b : ⨁ i, A i) : a * b = b * a :=
suffices mul_hom A = (mul_hom A).flip,
  from add_monoid_hom.congr_fun (add_monoid_hom.congr_fun this a) b,
begin
  apply add_hom_ext, intros ai ax, apply add_hom_ext, intros bi bx,
  rw [add_monoid_hom.flip_apply, mul_hom_of_of, mul_hom_of_of],
  exact of_eq_of_graded_monoid_eq (gcomm_semiring.mul_comm ⟨ai, ax⟩ ⟨bi, bx⟩),
end

/-- The `comm_semiring` structure derived from `gcomm_semiring A`. -/
instance comm_semiring : comm_semiring (⨁ i, A i) :=
{ one := 1,
  mul := (*),
  zero := 0,
  add := (+),
  mul_comm := mul_comm A,
  ..direct_sum.semiring _, }

end comm_semiring

section non_unital_non_assoc_ring
variables [Π i, add_comm_group (A i)] [has_add ι] [gnon_unital_non_assoc_semiring A]

/-- The `ring` derived from `gsemiring A`. -/
instance non_assoc_ring : non_unital_non_assoc_ring (⨁ i, A i) :=
{ mul := (*),
  zero := 0,
  add := (+),
  neg := has_neg.neg,
  ..(direct_sum.non_unital_non_assoc_semiring _),
  ..(direct_sum.add_comm_group _), }

end non_unital_non_assoc_ring

section ring
variables [Π i, add_comm_group (A i)] [add_monoid ι] [gsemiring A]

/-- The `ring` derived from `gsemiring A`. -/
instance ring : ring (⨁ i, A i) :=
{ one := 1,
  mul := (*),
  zero := 0,
  add := (+),
  neg := has_neg.neg,
  ..(direct_sum.semiring _),
  ..(direct_sum.add_comm_group _), }

end ring

section comm_ring
variables [Π i, add_comm_group (A i)] [add_comm_monoid ι] [gcomm_semiring A]

/-- The `comm_ring` derived from `gcomm_semiring A`. -/
instance comm_ring : comm_ring (⨁ i, A i) :=
{ one := 1,
  mul := (*),
  zero := 0,
  add := (+),
  neg := has_neg.neg,
  ..(direct_sum.ring _),
  ..(direct_sum.comm_semiring _), }

end comm_ring

/-! ### Instances for `A 0`

The various `g*` instances are enough to promote the `add_comm_monoid (A 0)` structure to various
types of multiplicative structure.
-/

section grade_zero

section one
variables [has_zero ι] [graded_monoid.ghas_one A] [Π i, add_comm_monoid (A i)]

@[simp] lemma of_zero_one : of _ 0 (1 : A 0) = 1 := rfl

end one

section mul
variables [add_zero_class ι] [Π i, add_comm_monoid (A i)] [gnon_unital_non_assoc_semiring A]

@[simp] lemma of_zero_smul {i} (a : A 0) (b : A i) : of _ _ (a • b) = of _ _ a * of _ _ b :=
(of_eq_of_graded_monoid_eq (graded_monoid.mk_zero_smul a b)).trans (of_mul_of _ _).symm

@[simp] lemma of_zero_mul (a b : A 0) : of _ 0 (a * b) = of _ 0 a * of _ 0 b:=
of_zero_smul A a b

instance grade_zero.non_unital_non_assoc_semiring : non_unital_non_assoc_semiring (A 0) :=
function.injective.non_unital_non_assoc_semiring (of A 0) dfinsupp.single_injective
  (of A 0).map_zero (of A 0).map_add (of_zero_mul A) (λ x n, dfinsupp.single_smul n x)

instance grade_zero.smul_with_zero (i : ι) : smul_with_zero (A 0) (A i) :=
begin
  letI := smul_with_zero.comp_hom (⨁ i, A i) (of A 0).to_zero_hom,
  refine dfinsupp.single_injective.smul_with_zero (of A i).to_zero_hom (of_zero_smul A),
end

end mul

section semiring
variables [Π i, add_comm_monoid (A i)] [add_monoid ι] [gsemiring A]

@[simp] lemma of_zero_pow (a : A 0) : ∀ n : ℕ, of _ 0 (a ^ n) = of _ 0 a ^ n
| 0 := by rw [pow_zero, pow_zero, direct_sum.of_zero_one]
| (n + 1) := by rw [pow_succ, pow_succ, of_zero_mul, of_zero_pow]

/-- The `semiring` structure derived from `gsemiring A`. -/
instance grade_zero.semiring : semiring (A 0) :=
function.injective.semiring (of A 0) dfinsupp.single_injective
  (of A 0).map_zero (of_zero_one A) (of A 0).map_add (of_zero_mul A)
  (λ x n, dfinsupp.single_smul n x) (λ x n, of_zero_pow _ _ _)

/-- `of A 0` is a `ring_hom`, using the `direct_sum.grade_zero.semiring` structure. -/
def of_zero_ring_hom : A 0 →+* (⨁ i, A i) :=
{ map_one' := of_zero_one A, map_mul' := of_zero_mul A, ..(of _ 0) }

/-- Each grade `A i` derives a `A 0`-module structure from `gsemiring A`. Note that this results
in an overall `module (A 0) (⨁ i, A i)` structure via `direct_sum.module`.
-/
instance grade_zero.module {i} : module (A 0) (A i) :=
begin
  letI := module.comp_hom (⨁ i, A i) (of_zero_ring_hom A),
  exact dfinsupp.single_injective.module (A 0) (of A i) (λ a, of_zero_smul A a),
end

end semiring

section comm_semiring

variables [Π i, add_comm_monoid (A i)] [add_comm_monoid ι] [gcomm_semiring A]

/-- The `comm_semiring` structure derived from `gcomm_semiring A`. -/
instance grade_zero.comm_semiring : comm_semiring (A 0) :=
function.injective.comm_semiring (of A 0) dfinsupp.single_injective
  (of A 0).map_zero (of_zero_one A) (of A 0).map_add (of_zero_mul A)
  (λ x n, dfinsupp.single_smul n x) (λ x n, of_zero_pow _ _ _)

end comm_semiring

section ring
variables [Π i, add_comm_group (A i)] [add_zero_class ι] [gnon_unital_non_assoc_semiring A]

/-- The `non_unital_non_assoc_ring` derived from `gnon_unital_non_assoc_semiring A`. -/
instance grade_zero.non_unital_non_assoc_ring : non_unital_non_assoc_ring (A 0) :=
function.injective.non_unital_non_assoc_ring (of A 0) dfinsupp.single_injective
  (of A 0).map_zero (of A 0).map_add (of_zero_mul A)
  (of A 0).map_neg (of A 0).map_sub
  (λ x n, begin
    letI : Π i, distrib_mul_action ℕ (A i) := λ i, infer_instance,
    exact dfinsupp.single_smul n x
  end)
  (λ x n, begin
    letI : Π i, distrib_mul_action ℤ (A i) := λ i, infer_instance,
    exact dfinsupp.single_smul n x
  end)

end ring

section ring
variables [Π i, add_comm_group (A i)] [add_monoid ι] [gsemiring A]

/-- The `ring` derived from `gsemiring A`. -/
instance grade_zero.ring : ring (A 0) :=
function.injective.ring (of A 0) dfinsupp.single_injective
  (of A 0).map_zero (of_zero_one A) (of A 0).map_add (of_zero_mul A)
  (of A 0).map_neg (of A 0).map_sub
  (λ x n, begin
    letI : Π i, distrib_mul_action ℕ (A i) := λ i, infer_instance,
    exact dfinsupp.single_smul n x
  end)
  (λ x n, begin
    letI : Π i, distrib_mul_action ℤ (A i) := λ i, infer_instance,
    exact dfinsupp.single_smul n x
  end) (λ x n, of_zero_pow _ _ _)

end ring

section comm_ring
variables [Π i, add_comm_group (A i)] [add_comm_monoid ι] [gcomm_semiring A]

/-- The `comm_ring` derived from `gcomm_semiring A`. -/
instance grade_zero.comm_ring : comm_ring (A 0) :=
function.injective.comm_ring (of A 0) dfinsupp.single_injective
  (of A 0).map_zero (of_zero_one A) (of A 0).map_add (of_zero_mul A)
  (of A 0).map_neg (of A 0).map_sub
  (λ x n, begin
    letI : Π i, distrib_mul_action ℕ (A i) := λ i, infer_instance,
    exact dfinsupp.single_smul n x
  end)
  (λ x n, begin
    letI : Π i, distrib_mul_action ℤ (A i) := λ i, infer_instance,
    exact dfinsupp.single_smul n x
  end) (λ x n, of_zero_pow _ _ _)

end comm_ring

end grade_zero

section to_semiring

variables {R : Type*} [Π i, add_comm_monoid (A i)] [add_monoid ι] [gsemiring A] [semiring R]
variables {A}

/-- If two ring homomorphisms from `⨁ i, A i` are equal on each `of A i y`,
then they are equal.

See note [partially-applied ext lemmas]. -/
@[ext]
lemma ring_hom_ext' ⦃F G : (⨁ i, A i) →+* R⦄
  (h : ∀ i, (↑F : _ →+ R).comp (of A i) = (↑G : _ →+ R).comp (of A i)) : F = G :=
ring_hom.coe_add_monoid_hom_injective $ direct_sum.add_hom_ext' h

/-- Two `ring_hom`s out of a direct sum are equal if they agree on the generators. -/
lemma ring_hom_ext ⦃f g : (⨁ i, A i) →+* R⦄ (h : ∀ i x, f (of A i x) = g (of A i x)) :
  f = g :=
ring_hom_ext' $ λ i, add_monoid_hom.ext $ h i

/-- A family of `add_monoid_hom`s preserving `direct_sum.ghas_one.one` and `direct_sum.ghas_mul.mul`
describes a `ring_hom`s on `⨁ i, A i`. This is a stronger version of `direct_sum.to_monoid`.

Of particular interest is the case when `A i` are bundled subojects, `f` is the family of
coercions such as `add_submonoid.subtype (A i)`, and the `[gsemiring A]` structure originates from
`direct_sum.gsemiring.of_add_submonoids`, in which case the proofs about `ghas_one` and `ghas_mul`
can be discharged by `rfl`. -/
@[simps]
def to_semiring
  (f : Π i, A i →+ R) (hone : f _ (graded_monoid.ghas_one.one) = 1)
  (hmul : ∀ {i j} (ai : A i) (aj : A j), f _ (graded_monoid.ghas_mul.mul ai aj) = f _ ai * f _ aj) :
  (⨁ i, A i) →+* R :=
{ to_fun := to_add_monoid f,
  map_one' := begin
    change (to_add_monoid f) (of _ 0 _) = 1,
    rw to_add_monoid_of,
    exact hone
  end,
  map_mul' := begin
    rw (to_add_monoid f).map_mul_iff,
    ext xi xv yi yv : 4,
    show to_add_monoid f (of A xi xv * of A yi yv) =
         to_add_monoid f (of A xi xv) * to_add_monoid f (of A yi yv),
    rw [of_mul_of, to_add_monoid_of, to_add_monoid_of, to_add_monoid_of],
    exact hmul _ _,
  end,
  .. to_add_monoid f}

@[simp] lemma to_semiring_of (f : Π i, A i →+ R) (hone hmul) (i : ι) (x : A i) :
  to_semiring f hone hmul (of _ i x) = f _ x :=
to_add_monoid_of f i x

@[simp] lemma to_semiring_coe_add_monoid_hom (f : Π i, A i →+ R) (hone hmul):
  (to_semiring f hone hmul : (⨁ i, A i) →+ R) = to_add_monoid f := rfl

/-- Families of `add_monoid_hom`s preserving `direct_sum.ghas_one.one` and `direct_sum.ghas_mul.mul`
are isomorphic to `ring_hom`s on `⨁ i, A i`. This is a stronger version of `dfinsupp.lift_add_hom`.
-/
@[simps]
def lift_ring_hom :
  {f : Π {i}, A i →+ R //
    f (graded_monoid.ghas_one.one) = 1 ∧
    ∀ {i j} (ai : A i) (aj : A j), f (graded_monoid.ghas_mul.mul ai aj) = f ai * f aj} ≃
    ((⨁ i, A i) →+* R) :=
{ to_fun := λ f, to_semiring f.1 f.2.1 f.2.2,
  inv_fun := λ F,
    ⟨λ i, (F : (⨁ i, A i) →+ R).comp (of _ i), begin
      simp only [add_monoid_hom.comp_apply, ring_hom.coe_add_monoid_hom],
      rw ←F.map_one,
      refl
    end, λ i j ai aj, begin
      simp only [add_monoid_hom.comp_apply, ring_hom.coe_add_monoid_hom],
      rw [←F.map_mul, of_mul_of],
    end⟩,
  left_inv := λ f, begin
    ext xi xv,
    exact to_add_monoid_of f.1 xi xv,
  end,
  right_inv := λ F, begin
    apply ring_hom.coe_add_monoid_hom_injective,
    ext xi xv,
    simp only [ring_hom.coe_add_monoid_hom_mk,
      direct_sum.to_add_monoid_of,
      add_monoid_hom.mk_coe,
      add_monoid_hom.comp_apply, to_semiring_coe_add_monoid_hom],
  end}

end to_semiring

end direct_sum

/-! ### Concrete instances -/

section uniform

variables (ι)

/-- A direct sum of copies of a `semiring` inherits the multiplication structure. -/
instance non_unital_non_assoc_semiring.direct_sum_gnon_unital_non_assoc_semiring
  {R : Type*} [add_monoid ι] [non_unital_non_assoc_semiring R] :
  direct_sum.gnon_unital_non_assoc_semiring (λ i : ι, R) :=
{ mul_zero := λ i j, mul_zero,
  zero_mul := λ i j, zero_mul,
  mul_add := λ i j, mul_add,
  add_mul := λ i j, add_mul,
  ..has_mul.ghas_mul ι }

/-- A direct sum of copies of a `semiring` inherits the multiplication structure. -/
instance semiring.direct_sum_gsemiring {R : Type*} [add_monoid ι] [semiring R] :
  direct_sum.gsemiring (λ i : ι, R) :=
{ ..non_unital_non_assoc_semiring.direct_sum_gnon_unital_non_assoc_semiring ι, ..monoid.gmonoid ι }

open_locale direct_sum

-- To check `has_mul.ghas_mul_mul` matches
example {R : Type*} [add_monoid ι] [semiring R] (i j : ι) (a b : R) :
  (direct_sum.of _ i a * direct_sum.of _ j b : ⨁ i, R) = direct_sum.of _ (i + j) (by exact a * b) :=
by rw [direct_sum.of_mul_of, has_mul.ghas_mul_mul]

/-- A direct sum of copies of a `comm_semiring` inherits the commutative multiplication structure.
-/
instance comm_semiring.direct_sum_gcomm_semiring {R : Type*} [add_comm_monoid ι] [comm_semiring R] :
  direct_sum.gcomm_semiring (λ i : ι, R) :=
{ ..comm_monoid.gcomm_monoid ι, ..semiring.direct_sum_gsemiring ι }

end uniform


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

import for_mathlib.category_theory.morphism_property_misc
import category_theory.lifting_properties.basic
import for_mathlib.category_theory.retracts
import for_mathlib.category_theory.lifting_properties.morphism_property

noncomputable theory

open category_theory category_theory.category opposite

namespace algebraic_topology

variables {C : Type*} [category C] (F G : morphism_property C) {F' G' : morphism_property Cᵒᵖ}

def factorisation_axiom :=
∀ ⦃X Z : C⦄ (f : X ⟶ Z), ∃ (Y : C) (i : X ⟶ Y) (hi : F i) (p : Y ⟶ Z) (hp : G p), i ≫ p = f

namespace factorisation_axiom

variables {X Y Z : C}

variables {F G}

def obj (h : factorisation_axiom F G) (f : X ⟶ Z) : C := (h f).some

def i (h : factorisation_axiom F G) (f : X ⟶ Z) : X ⟶ h.obj f :=
(h f).some_spec.some
def p (h : factorisation_axiom F G) (f : X ⟶ Z) : h.obj f ⟶ Z :=
(h f).some_spec.some_spec.some_spec.some

lemma i_property (h : factorisation_axiom F G) (f : X ⟶ Z) : F (h.i f) :=
(h f).some_spec.some_spec.some
lemma p_property (h : factorisation_axiom F G) (f : X ⟶ Z) : G (h.p f) :=
(h f).some_spec.some_spec.some_spec.some_spec.some

@[simp, reassoc]
lemma fac (h : factorisation_axiom F G) (f : X ⟶ Z) : (h.i f) ≫ (h.p f) = f :=
(h f).some_spec.some_spec.some_spec.some_spec.some_spec

lemma op (h : factorisation_axiom F G) : factorisation_axiom G.op F.op :=
λ X Z f,
begin
  rcases h f.unop with ⟨Y, i, hi, p, hp, fac⟩,
  use [op Y, p.op, hp, i.op, hi],
  rw [← op_comp, fac, f.op_unop],
end

lemma unop (h : factorisation_axiom F' G') : factorisation_axiom G'.unop F'.unop :=
λ X Z f,
begin
  rcases h f.op with ⟨Y, i, hi, p, hp, fac⟩,
  use [Y.unop, p.unop, hp, i.unop, hi],
  rw [← unop_comp, fac, f.unop_op],
end

variables (F G F' G')

lemma iff_op : factorisation_axiom F G ↔ factorisation_axiom G.op F.op := ⟨op, unop⟩
lemma iff_unop : factorisation_axiom F' G' ↔ factorisation_axiom G'.unop F'.unop := ⟨unop, op⟩

lemma is_retract_of_fac_and_llp (i : X ⟶ Z) {j : X ⟶ Y} {p : Y ⟶ Z} (fac : j ≫ p = i)
  [has_lifting_property i p] : is_retract_hom i j :=
begin
  have fac₂ : j ≫ p = i ≫ 𝟙 Z,
  { rw [comp_id, fac], },
  have sq := (comm_sq.mk fac₂).lift,
  let s : arrow.mk i ⟶ arrow.mk j :=
  { left := 𝟙 X,
    right := (comm_sq.mk fac₂).lift,
    w' := by { dsimp, simp only [functor.id_map, arrow.mk_hom, comm_sq.fac_left, id_comp], }, },
  let r : arrow.mk j ⟶ arrow.mk i :=
  { left := 𝟙 X,
    right := p,
    w' := by { dsimp, simp only [id_comp, fac], }, },
  use [s, r],
  ext,
  { dsimp, rw id_comp, },
  { dsimp, rw comm_sq.fac_right, },
end

variables {F G}

lemma eq_llp_with
  (h₁ : factorisation_axiom F G) (h₂ : F.has_lifting_property G)
  (h₃ : F.is_stable_by_retract) : F = G.llp_with :=
begin
  ext X Y i,
  split,
  { exact λ hi X Y, h₂ i hi, },
  { intro hi,
    rcases h₁ i with ⟨Z, j, hj, p, hp, fac⟩,
    haveI : has_lifting_property i p := hi p hp,
    exact h₃ i j (is_retract_of_fac_and_llp i fac) hj, },
end

lemma eq_rlp_with
  (h₁ : factorisation_axiom F G) (h₂ : F.has_lifting_property G)
  (h₃ : G.is_stable_by_retract) : G = F.rlp_with :=
by rw [← G.unop_op, eq_llp_with h₁.op h₂.op h₃.op, F.llp_with_op, morphism_property.unop_op]

lemma under (h : factorisation_axiom F G) (A : C) :
  factorisation_axiom (F.inverse_image (under.forget A)) (G.inverse_image (under.forget A)) :=
λ X Y f, begin
  let f' := (under.forget A).map f,
  refine ⟨under.mk (X.hom ≫ h.i f'), under.hom_mk (h.i f'), h.i_property f',
    under.hom_mk (h.p f'), h.p_property f', _⟩,
  tidy,
end

end factorisation_axiom

end algebraic_topology


import QL.FOL.Tait.tait QL.FOL.semantics logic

universes u v

namespace fol
open_locale logic_symbol aclogic
variables {L : language.{u}} {m n : ℕ}

namespace Tait

open subformula

noncomputable def finset_mlift (Δ : finset (bounded_subformula L m n)) :
  finset (bounded_subformula L (m + 1) n) := Δ.image mlift

@[simp] lemma finset_mlift_union (Δ Γ : finset (bounded_subformula L m n)) : finset_mlift (Δ ∪ Γ) = finset_mlift Δ ∪ finset_mlift Γ :=
by simp[finset_mlift, finset.image_union]

@[simp] lemma mem_finset_mlift_iff (p : bounded_subformula L m n) (Δ : finset (bounded_subformula L m n)) :
  mlift p ∈ finset_mlift Δ ↔ p ∈ Δ :=
by simp[finset_mlift]

-- Tate caluculus
inductive derivation : Π {m}, finset (bounded_formula L m) → Type u
| AxL {m} : ∀ (Δ : finset (bounded_formula L m)) {k} (r : L.pr k) (v : fin k → bounded_term L m),
    relation r v ∈ Δ → neg_relation r v ∈ Δ → derivation Δ
| verum {m} : ∀ (Δ : finset (bounded_formula L m)), ⊤ ∈ Δ → derivation Δ
| or_left {m} : ∀ (Δ : finset (bounded_formula L m)) (p q : bounded_formula L m),
    derivation (insert p Δ) → derivation (insert (p ⊔ q) Δ)
| or_right {m} : ∀ (Δ : finset (bounded_formula L m)) (p q : bounded_formula L m),
    derivation (insert q Δ) → derivation (insert (p ⊔ q) Δ)
| and {m} : ∀ (Δ : finset (bounded_formula L m)) (p q : bounded_formula L m),
    derivation (insert p Δ) → derivation (insert q Δ) → derivation (insert (p ⊓ q) Δ)
| all {m} : ∀ (Δ : finset (bounded_subformula L m 0)) (p : bounded_subformula L m 1),
    derivation (insert p.push (finset_mlift Δ)) → derivation (insert (∀'p) Δ)
| ex {m} : ∀ (Δ : finset (bounded_subformula L m 0)) (t : bounded_term L m) (p : bounded_subformula L m 1),
    derivation (insert (subst t p) Δ) → derivation (insert (∃'p) Δ)

variables {L m}

def derivable {m} (Δ : finset (bounded_formula L m)) : Prop := nonempty (derivation Δ)

prefix `⊢ᵀ `:45 := derivable

@[reducible] def preTheory (L : language.{u}) (μ) := logic.Theory (subformula L μ 0)

@[reducible] def bounded_preTheory (L : language.{u}) (m : ℕ) := logic.Theory (subformula L (fin m) 0)

@[reducible] def Theory (L : language.{u}) := logic.Theory (subformula L (fin 0) 0)

def provable (T : bounded_preTheory L m) (p : bounded_formula L m) : Prop :=
∃ Δ : finset (bounded_formula L m), ↑Δ ⊆ subformula.not '' T ∧ ⊢ᵀ insert p Δ

instance : has_turnstile (bounded_formula L m) := ⟨provable⟩

def provable_def {T : set (bounded_formula L m)} {p : bounded_formula L m} :
  T ⊢ p ↔ ∃ Δ : finset (bounded_formula L m), ↑Δ ⊆ subformula.not '' T ∧ ⊢ᵀ insert p Δ := by refl

namespace derivable
variables {m} {Δ Γ : finset (bounded_formula L m)}

lemma AxL {k} (r : L.pr k) (v : fin k → bounded_term L m) (h : relation r v ∈ Δ) (hneg : neg_relation r v ∈ Δ) : ⊢ᵀ Δ :=
⟨derivation.AxL Δ r v h hneg⟩

lemma verum (h : ⊤ ∈ Δ) : ⊢ᵀ Δ := ⟨derivation.verum Δ h⟩

lemma or_left (p q : bounded_formula L m) : ⊢ᵀ insert p Δ → ⊢ᵀ insert (p ⊔ q) Δ := λ ⟨d⟩, ⟨derivation.or_left Δ p q d⟩

lemma or_right (p q : bounded_formula L m) : ⊢ᵀ insert q Δ → ⊢ᵀ insert (p ⊔ q) Δ := λ ⟨d⟩, ⟨derivation.or_right Δ p q d⟩

lemma and {p q : bounded_formula L m} : ⊢ᵀ insert p Δ → ⊢ᵀ insert q Δ → ⊢ᵀ insert (p ⊓ q) Δ := λ ⟨d₁⟩ ⟨d₂⟩, ⟨derivation.and Δ p q d₁ d₂⟩

lemma all {p : bounded_subformula L m 1} : ⊢ᵀ insert p.push (finset_mlift Δ) → ⊢ᵀ insert (∀'p) Δ := λ ⟨d⟩, ⟨derivation.all Δ p d⟩

lemma ex {t} {p : bounded_subformula L m 1} : ⊢ᵀ insert (subst t p) Δ → ⊢ᵀ insert (∃'p) Δ := λ ⟨d⟩, ⟨derivation.ex Δ t p d⟩

protected lemma cast (h : ⊢ᵀ Δ) (e : Δ = Γ) : ⊢ᵀ Γ := cast (by rw e) h

@[elab_as_eliminator]
theorem rec_on {C : Π {m} (Δ : finset (bounded_formula L m)), ⊢ᵀ Δ → Prop}
  {m : ℕ} {Δ : finset (bounded_formula L m)} (d : ⊢ᵀ Δ)
  (hAxL : ∀ {m} (Δ : finset (bounded_formula L m)) {k} (r : L.pr k) (v : fin k → bounded_term L m)
    (h : relation r v ∈ Δ) (hneg : neg_relation r v ∈ Δ), C Δ (AxL r v h hneg))
  (hverum : ∀ {m} (Δ : finset (bounded_formula L m)) (h : ⊤ ∈ Δ), C Δ (verum h))
  (hor_left : ∀ {m} (Δ : finset (bounded_formula L m)) (p q : bounded_formula L m) (d : ⊢ᵀ insert p Δ),
    C (insert p Δ) d → C (insert (p ⊔ q) Δ) (or_left p q d))
  (hor_right : ∀ {m} (Δ : finset (bounded_formula L m)) (p q : bounded_formula L m) (d : ⊢ᵀ insert q Δ),
    C (insert q Δ) d → C (insert (p ⊔ q) Δ) (or_right p q d))
  (hand : ∀ {m} (Δ : finset (bounded_formula L m)) (p q : bounded_formula L m) (d₁ : ⊢ᵀ insert p Δ) (d₂ : ⊢ᵀ insert q Δ),
    C (insert p Δ) d₁ → C (insert q Δ) d₂ → C (insert (p ⊓ q) Δ) (and d₁ d₂))
  (hall : ∀ {m} (Δ : finset (bounded_formula L m)) (p : bounded_subformula L m 1) (d : ⊢ᵀ insert p.push (finset_mlift Δ)),
    C (insert p.push (finset_mlift Δ)) d → C (insert (∀'p) Δ) (all d))
  (hex : ∀ {m} (Δ : finset (bounded_formula L m)) (t) (p : bounded_subformula L m 1) (d : ⊢ᵀ insert (subst t p) Δ),
    C (insert (subst t p) Δ) d → C (insert (∃'p) Δ) (ex d)) : C Δ d :=
 by unfreezingI {
  begin
    cases d,
    induction d,
    case AxL : m Δ k r v h hneg { exact hAxL Δ r v h hneg },
    case verum : m Δ h { exact hverum Δ h },
    case or_left : m Δ p q _ ih { exact hor_left Δ p q _ ih },
    case or_right : m Δ p q _ ih { exact hor_right Δ p q _ ih },
    case and : m Δ p q _ _ ih₁ ih₂ { exact hand Δ p q _ _ ih₁ ih₂ },
    case all : m Δ p _ ih { exact hall Δ p _ ih },
    case ex : m Δ t p _ ih { exact hex Δ t p _ ih }
  end }

protected lemma weakening (h : ⊢ᵀ Δ) : ∀ {Γ}, Δ ⊆ Γ → ⊢ᵀ Γ :=
begin
  apply rec_on h,
  { intros m Δ k r v h hneg Γ ss, refine AxL r v (ss h) (ss hneg) },
  { intros m Δ h Γ ss, refine verum (ss h) },
  { intros m Δ p q h IH Γ ss,
    have : ⊢ᵀ insert p Γ, from IH (finset.insert_subset_insert _ (finset.insert_subset.mp ss).2),
    have : ⊢ᵀ insert (p ⊔ q) Γ, from or_left p q this,
    refine derivable.cast this (by { simp, exact (finset.insert_subset.mp ss).1}) },
  { intros m Δ p q h IH Γ ss,
    have : ⊢ᵀ insert q Γ, from IH (finset.insert_subset_insert _ (finset.insert_subset.mp ss).2),
    have : ⊢ᵀ insert (p ⊔ q) Γ, from or_right p q this,
    refine derivable.cast this (by { simp, exact (finset.insert_subset.mp ss).1}) },
  { intros m Δ p q h₁ h₂ IH₁ IH₂ Γ ss,
    have l₁ : ⊢ᵀ insert p Γ, from IH₁ (finset.insert_subset_insert _ $ (finset.insert_subset.mp ss).2),
    have l₂ : ⊢ᵀ insert q Γ, from IH₂ (finset.insert_subset_insert _ $ (finset.insert_subset.mp ss).2),
    have : ⊢ᵀ insert (p ⊓ q) Γ, from and l₁ l₂,
    refine derivable.cast this (by { simp, exact (finset.insert_subset.mp ss).1}) },
  { intros m Δ p h IH Γ ss,
    have : ⊢ᵀ insert p.push (finset_mlift Γ),
      from IH (finset.insert_subset_insert _ $ finset.image_subset_image (finset.insert_subset.mp ss).2),
    have : ⊢ᵀ insert (∀'p) Γ := all this,
    refine derivable.cast this (by { simp, exact (finset.insert_subset.mp ss).1}) },
  { intros m Δ t p h IH Γ ss,
    have : ⊢ᵀ insert (subst t p) Γ, from IH (finset.insert_subset_insert _ (finset.insert_subset.mp ss).2),
    have : ⊢ᵀ insert (∃'p) Γ := ex this,
    refine derivable.cast this (by { simp, exact (finset.insert_subset.mp ss).1}) }
end

lemma and' {p q : bounded_formula L m} (hp : ⊢ᵀ insert p Δ) (hq : ⊢ᵀ insert q Γ) : ⊢ᵀ insert (p ⊓ q) (Δ ∪ Γ) :=
by { have hp' : ⊢ᵀ insert p (Δ ∪ Γ), from derivable.weakening hp (by intros x; simp; tauto),
     have hq' : ⊢ᵀ insert q (Δ ∪ Γ), from derivable.weakening hq (by intros x; simp; tauto),
     exact derivable.and hp' hq' }

section
variables {Δ}

open axiomatic_classical_logic' axiomatic_classical_logic

lemma provable_of_derivation (h : ⊢ᵀ Δ) : ∅ ⊢ (Δ.image of_tait).disjunction :=
begin
  apply derivable.rec_on h,
  { intros m Δ k r v h nh,
    suffices : ∅ ⊢ fol.subformula.relation r v ⊔ ∼fol.subformula.relation r v ⟶ (finset.image of_tait Δ).disjunction,
    from this ⨀ excluded_middle,
    refine or_imply _ _ _ ⨀ _ ⨀ _,
    { refine imply_fdisj (by { simp, refine ⟨_, h, by simp⟩ }) },
    { refine imply_fdisj (by { simp, refine ⟨_, nh, by simp⟩ }) } },
  { intros m Δ hΔ, exact (imply_fdisj
      (by { show of_tait ⊤ ∈ Δ.image of_tait, exact finset.mem_image_of_mem of_tait hΔ })) ⨀ (by simp) },
  { intros m Δ p q b IH, simp[fdisj_insert] at IH ⊢, exact imply_or_left _ _ ⨀ IH },
  { intros m Δ p q b IH, simp[fdisj_insert] at IH ⊢, exact imply_or_right _ _ ⨀ IH },
  { intros m Δ p q _ _ IH₁ IH₂, simp[fdisj_insert] at IH₁ IH₂ ⊢,
    exact ⟨IH₁, IH₂⟩ },
  { intros m Δ p b IH, simp[fdisj_insert] at IH ⊢,
    have e : has_negation.neg '' (of_tait '' (↑(finset_mlift Δ) : set (bounded_formula L (m + 1)))) =
      𝗟' (has_negation.neg '' (of_tait '' ↑Δ)),
    { ext q, simp[finset_mlift, bounded_preTheory.mlift, of_tait_mlift] },
    have : 𝗟'(has_negation.neg '' (of_tait '' ↑Δ)) ⊢ of_tait (push p),
    { simpa[←e] using IH },
    by simpa[←of_tait_pull] using provable.generalize this },
  { intros m Δ t p b IH, simp[fdisj_insert, of_tait_subst] at IH ⊢,
    refine provable.use t IH }
end

end

end derivable

end Tait

open subformula

namespace provable
open axiomatic_classical_logic' axiomatic_classical_logic

def of_Tait_provable {T : bounded_preTheory L m} {p : bounded_formula L m} :
  to_tait '' T ⊢ p.to_tait → T ⊢ p :=
begin
  simp[Tait.provable_def],
  intros Δ ss b,
  have le : has_negation.neg '' (Tait.subformula.of_tait '' ↑Δ) ≤ T,
  from @le_of _ _ (has_negation.neg '' (Tait.subformula.of_tait '' ↑Δ)) T
    (by { simp, intros p hp,
      have := ss (by simpa using hp), simp at this, rcases this with ⟨q, hq, rfl⟩,
      have l₁ : T ⊢ ∼Tait.subformula.of_tait (∼q.to_tait) ⟷ ∼∼q.to_tait.of_tait,
      from equiv_neg_of_equiv (Tait.subformula.to_tait_not_equiv q.to_tait),
      have l₂ : T ⊢ ∼∼q.to_tait.of_tait ⟷ q, from equiv_trans (by simp) (to_tait_of_tait q),
      refine of_equiv (by_axiom hq) (equiv_symm $ equiv_trans l₁ l₂) }),
  have : has_negation.neg '' (Tait.subformula.of_tait '' ↑Δ) ⊢ (to_tait p).of_tait,
  by simpa[fdisj_insert] using b.provable_of_derivation,
  have := le this,
  exact of_equiv this (to_tait_of_tait p)
end

end provable

end fol


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.currying
import category_theory.limits.preserves.limits

/-!
# (Co)limits in functor categories.

We show that if `D` has limits, then the functor category `C ⥤ D` also has limits
(`category_theory.limits.functor_category_has_limits`),
and the evaluation functors preserve limits
(`category_theory.limits.evaluation_preserves_limits`)
(and similarly for colimits).

We also show that `F : D ⥤ K ⥤ C` preserves (co)limits if it does so for each `k : K`
(`category_theory.limits.preserves_limits_of_evaluation` and
`category_theory.limits.preserves_colimits_of_evaluation`).
-/

open category_theory category_theory.category

-- morphism levels before object levels. See note [category_theory universes].
universes v₁ v₂ u₁ u₂ v v' u u'

namespace category_theory.limits

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

variables {J : Type u₁} [category.{v₁} J] {K : Type u₂} [category.{v₂} K]

@[simp, reassoc]
lemma limit.lift_π_app (H : J ⥤ K ⥤ C) [has_limit H] (c : cone H) (j : J) (k : K) :
  (limit.lift H c).app k ≫ (limit.π H j).app k = (c.π.app j).app k :=
congr_app (limit.lift_π c j) k

@[simp, reassoc]
lemma colimit.ι_desc_app (H : J ⥤ K ⥤ C) [has_colimit H] (c : cocone H) (j : J) (k : K) :
  (colimit.ι H j).app k ≫ (colimit.desc H c).app k = (c.ι.app j).app k :=
congr_app (colimit.ι_desc c j) k

/--
The evaluation functors jointly reflect limits: that is, to show a cone is a limit of `F`
it suffices to show that each evaluation cone is a limit. In other words, to prove a cone is
limiting you can show it's pointwise limiting.
-/
def evaluation_jointly_reflects_limits {F : J ⥤ K ⥤ C} (c : cone F)
  (t : Π (k : K), is_limit (((evaluation K C).obj k).map_cone c)) : is_limit c :=
{ lift := λ s,
  { app := λ k, (t k).lift ⟨s.X.obj k, whisker_right s.π ((evaluation K C).obj k)⟩,
    naturality' := λ X Y f, (t Y).hom_ext $ λ j,
    begin
      rw [assoc, (t Y).fac _ j],
      simpa using
        ((t X).fac_assoc ⟨s.X.obj X, whisker_right s.π ((evaluation K C).obj X)⟩ j _).symm,
    end },
  fac' := λ s j, nat_trans.ext _ _ $ funext $ λ k, (t k).fac _ j,
  uniq' := λ s m w, nat_trans.ext _ _ $ funext $ λ x, (t x).hom_ext $ λ j,
      (congr_app (w j) x).trans
        ((t x).fac ⟨s.X.obj _, whisker_right s.π ((evaluation K C).obj _)⟩ j).symm }

/--
Given a functor `F` and a collection of limit cones for each diagram `X ↦ F X k`, we can stitch
them together to give a cone for the diagram `F`.
`combined_is_limit` shows that the new cone is limiting, and `eval_combined` shows it is
(essentially) made up of the original cones.
-/
@[simps] def combine_cones (F : J ⥤ K ⥤ C) (c : Π (k : K), limit_cone (F.flip.obj k)) :
  cone F :=
{ X :=
  { obj := λ k, (c k).cone.X,
    map := λ k₁ k₂ f, (c k₂).is_limit.lift ⟨_, (c k₁).cone.π ≫ F.flip.map f⟩,
    map_id' := λ k, (c k).is_limit.hom_ext (λ j, by { dsimp, simp }),
    map_comp' := λ k₁ k₂ k₃ f₁ f₂, (c k₃).is_limit.hom_ext (λ j, by simp) },
  π :=
  { app := λ j, { app := λ k, (c k).cone.π.app j },
    naturality' := λ j₁ j₂ g, nat_trans.ext _ _ $ funext $ λ k, (c k).cone.π.naturality g } }

/-- The stitched together cones each project down to the original given cones (up to iso). -/
def evaluate_combined_cones (F : J ⥤ K ⥤ C) (c : Π (k : K), limit_cone (F.flip.obj k)) (k : K) :
  ((evaluation K C).obj k).map_cone (combine_cones F c) ≅ (c k).cone :=
cones.ext (iso.refl _) (by tidy)

/-- Stitching together limiting cones gives a limiting cone. -/
def combined_is_limit (F : J ⥤ K ⥤ C) (c : Π (k : K), limit_cone (F.flip.obj k)) :
  is_limit (combine_cones F c) :=
evaluation_jointly_reflects_limits _
  (λ k, (c k).is_limit.of_iso_limit (evaluate_combined_cones F c k).symm)

/--
The evaluation functors jointly reflect colimits: that is, to show a cocone is a colimit of `F`
it suffices to show that each evaluation cocone is a colimit. In other words, to prove a cocone is
colimiting you can show it's pointwise colimiting.
-/
def evaluation_jointly_reflects_colimits {F : J ⥤ K ⥤ C} (c : cocone F)
  (t : Π (k : K), is_colimit (((evaluation K C).obj k).map_cocone c)) : is_colimit c :=
{ desc := λ s,
  { app := λ k, (t k).desc ⟨s.X.obj k, whisker_right s.ι ((evaluation K C).obj k)⟩,
    naturality' := λ X Y f, (t X).hom_ext $ λ j,
    begin
      rw [(t X).fac_assoc _ j],
      erw ← (c.ι.app j).naturality_assoc f,
      erw (t Y).fac ⟨s.X.obj _, whisker_right s.ι _⟩ j,
      dsimp,
      simp,
    end },
  fac' := λ s j, nat_trans.ext _ _ $ funext $ λ k, (t k).fac _ j,
  uniq' := λ s m w, nat_trans.ext _ _ $ funext $ λ x, (t x).hom_ext $ λ j,
      (congr_app (w j) x).trans
        ((t x).fac ⟨s.X.obj _, whisker_right s.ι ((evaluation K C).obj _)⟩ j).symm }

/--
Given a functor `F` and a collection of colimit cocones for each diagram `X ↦ F X k`, we can stitch
them together to give a cocone for the diagram `F`.
`combined_is_colimit` shows that the new cocone is colimiting, and `eval_combined` shows it is
(essentially) made up of the original cocones.
-/
@[simps] def combine_cocones (F : J ⥤ K ⥤ C) (c : Π (k : K), colimit_cocone (F.flip.obj k)) :
  cocone F :=
{ X :=
  { obj := λ k, (c k).cocone.X,
    map := λ k₁ k₂ f, (c k₁).is_colimit.desc ⟨_, F.flip.map f ≫ (c k₂).cocone.ι⟩,
    map_id' := λ k, (c k).is_colimit.hom_ext (λ j, by { dsimp, simp }),
    map_comp' := λ k₁ k₂ k₃ f₁ f₂, (c k₁).is_colimit.hom_ext (λ j, by simp) },
  ι :=
  { app := λ j, { app := λ k, (c k).cocone.ι.app j },
    naturality' := λ j₁ j₂ g, nat_trans.ext _ _ $ funext $ λ k, (c k).cocone.ι.naturality g } }

/-- The stitched together cocones each project down to the original given cocones (up to iso). -/
def evaluate_combined_cocones
  (F : J ⥤ K ⥤ C) (c : Π (k : K), colimit_cocone (F.flip.obj k)) (k : K) :
  ((evaluation K C).obj k).map_cocone (combine_cocones F c) ≅ (c k).cocone :=
cocones.ext (iso.refl _) (by tidy)

/-- Stitching together colimiting cocones gives a colimiting cocone. -/
def combined_is_colimit (F : J ⥤ K ⥤ C) (c : Π (k : K), colimit_cocone (F.flip.obj k)) :
  is_colimit (combine_cocones F c) :=
evaluation_jointly_reflects_colimits _
  (λ k, (c k).is_colimit.of_iso_colimit (evaluate_combined_cocones F c k).symm)

noncomputable theory

instance functor_category_has_limits_of_shape
  [has_limits_of_shape J C] : has_limits_of_shape J (K ⥤ C) :=
{ has_limit := λ F, has_limit.mk
  { cone := combine_cones F (λ k, get_limit_cone _),
    is_limit := combined_is_limit _ _ } }

instance functor_category_has_colimits_of_shape
  [has_colimits_of_shape J C] : has_colimits_of_shape J (K ⥤ C) :=
{ has_colimit := λ F, has_colimit.mk
  { cocone := combine_cocones _ (λ k, get_colimit_cocone _),
    is_colimit := combined_is_colimit _ _ } }

instance functor_category_has_limits_of_size [has_limits_of_size.{v₁ u₁} C] :
  has_limits_of_size.{v₁ u₁} (K ⥤ C) := ⟨infer_instance⟩

instance functor_category_has_colimits_of_size [has_colimits_of_size.{v₁ u₁} C] :
  has_colimits_of_size.{v₁ u₁} (K ⥤ C) := ⟨infer_instance⟩

end category_theory.limits

namespace category_theory.limits

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

variables {J : Type v} [category.{v} J] {K : Type v} [category.{v₂} K]

instance evaluation_preserves_limits_of_shape [has_limits_of_shape J C] (k : K) :
  preserves_limits_of_shape J ((evaluation K C).obj k) :=
{ preserves_limit :=
  λ F, preserves_limit_of_preserves_limit_cone (combined_is_limit _ _) $
    is_limit.of_iso_limit (limit.is_limit _)
      (evaluate_combined_cones F _ k).symm }

/--
If `F : J ⥤ K ⥤ C` is a functor into a functor category which has a limit,
then the evaluation of that limit at `k` is the limit of the evaluations of `F.obj j` at `k`.
-/
def limit_obj_iso_limit_comp_evaluation [has_limits_of_shape J C] (F : J ⥤ K ⥤ C) (k : K) :
  (limit F).obj k ≅ limit (F ⋙ ((evaluation K C).obj k)) :=
preserves_limit_iso ((evaluation K C).obj k) F

@[simp, reassoc]
lemma limit_obj_iso_limit_comp_evaluation_hom_π
  [has_limits_of_shape J C] (F : J ⥤ (K ⥤ C)) (j : J) (k : K) :
  (limit_obj_iso_limit_comp_evaluation F k).hom ≫ limit.π (F ⋙ ((evaluation K C).obj k)) j =
    (limit.π F j).app k :=
begin
  dsimp [limit_obj_iso_limit_comp_evaluation],
  simp,
end

@[simp, reassoc]
lemma limit_obj_iso_limit_comp_evaluation_inv_π_app
  [has_limits_of_shape J C] (F : J ⥤ (K ⥤ C)) (j : J) (k : K):
  (limit_obj_iso_limit_comp_evaluation F k).inv ≫ (limit.π F j).app k =
    limit.π (F ⋙ ((evaluation K C).obj k)) j :=
begin
  dsimp [limit_obj_iso_limit_comp_evaluation],
  rw iso.inv_comp_eq,
  simp,
end

@[ext]
lemma limit_obj_ext {H : J ⥤ K ⥤ C} [has_limits_of_shape J C]
  {k : K} {W : C} {f g : W ⟶ (limit H).obj k}
  (w : ∀ j, f ≫ (limits.limit.π H j).app k = g ≫ (limits.limit.π H j).app k) : f = g :=
begin
  apply (cancel_mono (limit_obj_iso_limit_comp_evaluation H k).hom).1,
  ext,
  simpa using w j,
end

instance evaluation_preserves_colimits_of_shape [has_colimits_of_shape J C] (k : K) :
  preserves_colimits_of_shape J ((evaluation K C).obj k) :=
{ preserves_colimit :=
  λ F, preserves_colimit_of_preserves_colimit_cocone (combined_is_colimit _ _) $
    is_colimit.of_iso_colimit (colimit.is_colimit _)
      (evaluate_combined_cocones F _ k).symm }

/--
If `F : J ⥤ K ⥤ C` is a functor into a functor category which has a colimit,
then the evaluation of that colimit at `k` is the colimit of the evaluations of `F.obj j` at `k`.
-/
def colimit_obj_iso_colimit_comp_evaluation [has_colimits_of_shape J C] (F : J ⥤ K ⥤ C) (k : K) :
  (colimit F).obj k ≅ colimit (F ⋙ ((evaluation K C).obj k)) :=
preserves_colimit_iso ((evaluation K C).obj k) F

@[simp, reassoc]
lemma colimit_obj_iso_colimit_comp_evaluation_ι_inv
  [has_colimits_of_shape J C] (F : J ⥤ (K ⥤ C)) (j : J) (k : K) :
  colimit.ι (F ⋙ ((evaluation K C).obj k)) j ≫ (colimit_obj_iso_colimit_comp_evaluation F k).inv =
    (colimit.ι F j).app k :=
begin
  dsimp [colimit_obj_iso_colimit_comp_evaluation],
  simp,
end

@[simp, reassoc]
lemma colimit_obj_iso_colimit_comp_evaluation_ι_app_hom
  [has_colimits_of_shape J C] (F : J ⥤ (K ⥤ C)) (j : J) (k : K) :
  (colimit.ι F j).app k ≫ (colimit_obj_iso_colimit_comp_evaluation F k).hom =
     colimit.ι (F ⋙ ((evaluation K C).obj k)) j :=
begin
  dsimp [colimit_obj_iso_colimit_comp_evaluation],
  rw ←iso.eq_comp_inv,
  simp,
end

@[ext]
lemma colimit_obj_ext {H : J ⥤ K ⥤ C} [has_colimits_of_shape J C]
  {k : K} {W : C} {f g : (colimit H).obj k ⟶ W}
  (w : ∀ j, (colimit.ι H j).app k ≫ f = (colimit.ι H j).app k ≫ g) : f = g :=
begin
  apply (cancel_epi (colimit_obj_iso_colimit_comp_evaluation H k).inv).1,
  ext,
  simpa using w j,
end

instance evaluation_preserves_limits [has_limits C] (k : K) :
  preserves_limits ((evaluation K C).obj k) :=
{ preserves_limits_of_shape := λ J 𝒥, by resetI; apply_instance }

/-- `F : D ⥤ K ⥤ C` preserves the limit of some `G : J ⥤ D` if it does for each `k : K`. -/
def preserves_limit_of_evaluation (F : D ⥤ K ⥤ C) (G : J ⥤ D)
  (H : Π (k : K), preserves_limit G (F ⋙ (evaluation K C).obj k : D ⥤ C)) :
  preserves_limit G F := ⟨λ c hc,
begin
  apply evaluation_jointly_reflects_limits,
  intro X,
  haveI := H X,
  change is_limit ((F ⋙ (evaluation K C).obj X).map_cone c),
  exact preserves_limit.preserves hc,
end⟩

/-- `F : D ⥤ K ⥤ C` preserves limits of shape `J` if it does for each `k : K`. -/
def preserves_limits_of_shape_of_evaluation (F : D ⥤ K ⥤ C) (J : Type v) [small_category J]
  (H : Π (k : K), preserves_limits_of_shape J (F ⋙ (evaluation K C).obj k)) :
  preserves_limits_of_shape J F :=
⟨λ G, preserves_limit_of_evaluation F G (λ k, preserves_limits_of_shape.preserves_limit)⟩

/-- `F : D ⥤ K ⥤ C` preserves all limits if it does for each `k : K`. -/
def preserves_limits_of_evaluation (F : D ⥤ K ⥤ C)
  (H : Π (k : K), preserves_limits (F ⋙ (evaluation K C).obj k)) :
  preserves_limits F :=
⟨λ L hL, by exactI preserves_limits_of_shape_of_evaluation
    F L (λ k, preserves_limits.preserves_limits_of_shape)⟩

instance evaluation_preserves_colimits [has_colimits C] (k : K) :
  preserves_colimits ((evaluation K C).obj k) :=
{ preserves_colimits_of_shape := λ J 𝒥, by resetI; apply_instance }

/-- `F : D ⥤ K ⥤ C` preserves the colimit of some `G : J ⥤ D` if it does for each `k : K`. -/
def preserves_colimit_of_evaluation (F : D ⥤ K ⥤ C) (G : J ⥤ D)
  (H : Π (k), preserves_colimit G (F ⋙ (evaluation K C).obj k)) : preserves_colimit G F := ⟨λ c hc,
begin
  apply evaluation_jointly_reflects_colimits,
  intro X,
  haveI := H X,
  change is_colimit ((F ⋙ (evaluation K C).obj X).map_cocone c),
  exact preserves_colimit.preserves hc,
end⟩

/-- `F : D ⥤ K ⥤ C` preserves all colimits of shape `J` if it does for each `k : K`. -/
def preserves_colimits_of_shape_of_evaluation (F : D ⥤ K ⥤ C) (J : Type v) [small_category J]
  (H : Π (k : K), preserves_colimits_of_shape J (F ⋙ (evaluation K C).obj k)) :
  preserves_colimits_of_shape J F :=
⟨λ G, preserves_colimit_of_evaluation F G (λ k, preserves_colimits_of_shape.preserves_colimit)⟩

/-- `F : D ⥤ K ⥤ C` preserves all colimits if it does for each `k : K`. -/
def preserves_colimits_of_evaluation (F : D ⥤ K ⥤ C)
  (H : Π (k : K), preserves_colimits (F ⋙ (evaluation K C).obj k)) :
  preserves_colimits F :=
⟨λ L hL, by exactI preserves_colimits_of_shape_of_evaluation
    F L (λ k, preserves_colimits.preserves_colimits_of_shape)⟩
open category_theory.prod

/--
For a functor `G : J ⥤ K ⥤ C`, its limit `K ⥤ C` is given by `(G' : K ⥤ J ⥤ C) ⋙ lim`.
Note that this does not require `K` to be small.
-/
@[simps] def limit_iso_swap_comp_lim [has_limits_of_shape J C] (G : J ⥤ K ⥤ C) [has_limit G] :
  limit G ≅ curry.obj (swap K J ⋙ uncurry.obj G) ⋙ lim :=
nat_iso.of_components (λ Y, limit_obj_iso_limit_comp_evaluation G Y ≪≫
  (lim.map_iso (eq_to_iso (by
  { apply functor.hext,
    { intro X, simp },
    { intros X₁ X₂ f, dsimp only [swap], simp }}))))
  begin
    intros Y₁ Y₂ f,
    ext1 x,
    dsimp only [swap],
    simp only [limit_obj_iso_limit_comp_evaluation_hom_π_assoc, category.comp_id,
      limit_obj_iso_limit_comp_evaluation_hom_π, eq_to_iso.hom, curry.obj_map_app,
      nat_trans.naturality, category.id_comp, eq_to_hom_refl, functor.comp_map,
      eq_to_hom_app, lim_map_π_assoc, lim_map_π, category.assoc,
      uncurry.obj_map, lim_map_eq_lim_map, iso.trans_hom,
      nat_trans.id_app, category_theory.functor.map_id, functor.map_iso_hom],
    erw category.id_comp,
  end

/--
For a functor `G : J ⥤ K ⥤ C`, its colimit `K ⥤ C` is given by `(G' : K ⥤ J ⥤ C) ⋙ colim`.
Note that this does not require `K` to be small.
-/
@[simps]
def colimit_iso_swap_comp_colim [has_colimits_of_shape J C] (G : J ⥤ K ⥤ C) [has_colimit G] :
  colimit G ≅ curry.obj (swap K J ⋙ uncurry.obj G) ⋙ colim :=
nat_iso.of_components (λ Y, colimit_obj_iso_colimit_comp_evaluation G Y ≪≫
  (colim.map_iso (eq_to_iso (by
  { apply functor.hext,
    { intro X, simp },
    { intros X Y f, dsimp only [swap], simp, } }))))
  begin
    intros Y₁ Y₂ f,
    ext1 x,
    rw ← (colimit.ι G x).naturality_assoc f,
    dsimp only [swap],
    simp only [eq_to_iso.hom, colimit_obj_iso_colimit_comp_evaluation_ι_app_hom_assoc,
      curry.obj_map_app, colimit.ι_map, category.id_comp, eq_to_hom_refl, iso.trans_hom,
      functor.comp_map, eq_to_hom_app, colimit.ι_map_assoc, functor.map_iso_hom,
      category.assoc, uncurry.obj_map, nat_trans.id_app, category_theory.functor.map_id],
    erw category.id_comp,
  end

end category_theory.limits


theorem ex1 [Monad m] [LawfulMonad m] (b : Bool) (ma : m α) (mb : α → m α) :
    (do let mut x ← ma
        if b then
          x ← mb x
        pure x)
    =
    (ma >>= fun x => if b then mb x else pure x) := by
  cases b <;> simp

attribute [simp] map_eq_pure_bind seq_eq_bind_map

theorem ex2 [Monad m] [LawfulMonad m] (b : Bool) (ma : m α) (mb : α → m α) (a : α) :
    (do let mut x ← ma
        if b then
          x ← mb x
        pure x)
    =
    (StateT.run' (m := m)
      (do ma >>= set
          if b then get >>= fun x => mb x >>= set
          get) a)  := by
  cases b <;> simp


import SciLean.Core.Integral
import SciLean.Core.AdjDiff

namespace SciLean

--------------------------------------------------------------------------------
-- Junk
--------------------------------------------------------------------------------

variable {X Y ι : Type} [Enumtype ι] [FinVec X ι] [Hilbert Y]

example (f : X⟿Y) : (λ g : X⟿Y => ∫ x, ⟪f x, g x⟫)† = f := by simp
example (f : X⟿Y) : (λ g : X⟿Y => ∫ x, ⟪g x, f x⟫)† = f := by simp; done

example : HasAdjointT fun (g : X⟿Y) => fun x ⟿ g x := by infer_instance
example : IsSmoothT fun (g : X⟿Y) => fun x ⟿ g x := by infer_instance

#check (fun (g : X⟿Y) => fun x ⟿ g x)†
       rewrite_by simp; trace_state

-- instance oj  {X Y Y' Z} [Vec X] [Vec Y] [Vec Y'] [Vec Z]
--   (f : X → Y → Y' → Z) [IsSmoothNT 3 f]
--   (g' : X → Y') [IsSmoothNT 1 g']
--   : IsSmoothNT 2 λ (g : X⟿Y) x => f x (g x) (g' x) := sorry_proof

-- instance {X Y Z} [Vec X] [Vec Y] [Vec Z] (f : X → Y → Z) [IsSmoothNT 2 f]
--   : IsSmoothNT 2 λ (g : X⟿Y) x => f x (g x) := by apply oj (λ x y _ => f x y) (λ x => x)

-- instance oh {X Y Y₁ Y₂ Z} [Vec X] [Vec Y] [Vec Y₁] [Vec Y₂] [Vec Z]
--   (f : Y₁ → Y₂ → Z) [IsSmoothNT 2 f]
--   (g₁ : X → Y → Y₁) [IsSmoothNT 2 g₁]
--   (g₂ : X → Y → Y₂) [IsSmoothNT 2 g₂]
--   : IsSmoothNT 2 λ (g : X⟿Y) x => f (g₁ x (g x)) (g₂ x (g x)) := sorry_proof

-- instance  {Y'} [Vec Y'] {Z} [Hilbert Z]
--   (A : X → Y → Y' → Z) [∀ x y', HasAdjointT (λ y => A x y y')] [IsSmoothNT 3 A]
--   (g' : X → Y' := λ _ => 0) [IsSmoothT g']
--   : HasAdjointT (λ (g : X⟿Y) => λ x ⟿ A x (g x) (g' x)) :=
-- by  sorry_proof

instance scomb_highorder_adjoint {Z W} [SemiHilbert W] [Hilbert Z]
  (F : (X⟿Y) → W → (X⟿Z)) [HasAdjointNT 2 F]  -- [IsSmoothNT 2 F]
  (G : (X⟿Y) → W) [HasAdjointT G]
  : HasAdjointT (λ (g : X⟿Y) => λ x ⟿ F g (G g) x) := by (try infer_instance); sorry_proof

set_option synthInstance.maxSize 2000 in
instance scomb_highorder_adjoint_simp {Z W} [SemiHilbert W] [Hilbert Z]
  (F : (X⟿Y) → W → (X⟿Z)) [HasAdjointNT 2 F] [IsSmoothNT 2 F]
  (G : (X⟿Y) → W) [HasAdjointT G] [IsSmoothT G]
  : (λ (g : X⟿Y) => λ (x:X) ⟿ (F g (G g) x))†
    =
    λ h =>
      let gw := (uncurryN 2 F)† h
      let (g',w) := gw
      let g'' := G† w
      λ x ⟿ g' x + g'' x
  := by sorry_proof

instance elemwise_adjoint {Z} [Hilbert Z] (A : X → Y → Z) [∀ x, HasAdjointT (A x)] [IsSmoothNT 2 A]
  : HasAdjointT (λ (g : X⟿Y) => λ x ⟿ A x (g x)) :=
by
  try infer_instance
  sorry_proof

@[simp ↓, diff]
theorem elemwise_adjoint_simp {Z} [Hilbert Z] (A : X → Y → Z) [∀ x, HasAdjointT (A x)] [IsSmoothNT 2 A]
  : (λ (g : X⟿Y) => λ x ⟿ A x (g x))†
    =
    λ g => λ x ⟿ (A x)† (g x) := by sorry_proof

instance elemwise_adjoint_alt1 {X Y ι : Type} [Enumtype ι] [FinVec X ι] [Hilbert Y]
  {X' Y' ι' : Type} [Enumtype ι'] [FinVec X' ι'] [Hilbert Y']
  (D : (X⟿Y) → (X'⟿Y')) [HasAdjointT D]
  {Z} [Hilbert Z] (A : X' → Y' → Z) [∀ x, HasAdjointT (A x)] [IsSmoothNT 2 A]
  : HasAdjointT (λ (g : X⟿Y) => λ x ⟿ A x (D g x)) :=
by
  try infer_instance
  let G := λ g : X'⟿Y' => λ x ⟿ A x (g x)
  let h : (λ (g : X⟿Y) => λ x ⟿ A x (D g x)) = λ g => G (D g) := by rfl
  rw [h]
  infer_instance
  done

@[simp ↓, diff]
theorem elemwise_adjoint_simp_alt1 {X Y ι : Type} [Enumtype ι] [FinVec X ι] [Hilbert Y]
  {X' Y' ι' : Type} [Enumtype ι'] [FinVec X' ι'] [Hilbert Y']
  (D : (X⟿Y) → (X'⟿Y')) [HasAdjointT D]
  {Z} [Hilbert Z] (A : X' → Y' → Z) [∀ x, HasAdjointT (A x)] [IsSmoothNT 2 A]
  : (λ (g : X⟿Y) => λ x ⟿ A x (D g x))†
    =
    λ g' => D† (λ x ⟿ (A x)† (g' x))
  :=
by
  let G := λ g : X'⟿Y' => λ x ⟿ A x (g x)
  let h : (λ (g : X⟿Y) => λ x ⟿ A x (D g x)) = λ g => G (D g) := by rfl
  rw [h]
  simp
  done

instance elemwise_adjoint_alt2 {Y'} [Vec Y'] {Z} [Hilbert Z]
  (A : X → Y → Y' → Z) [∀ x y', HasAdjointT (λ y => A x y y')] [IsSmoothNT 3 A]
  (g' : X → Y') [IsSmoothT g']
  : HasAdjointT (λ (g : X⟿Y) => λ x ⟿ A x (g x) (g' x)) :=
by
  try infer_instance
  apply elemwise_adjoint_alt1 (λ x => x) (λ x y => A x y (g' x))
  done

@[simp ↓, diff]
theorem elemwise_adjoint_simp_alt2 {Y'} [Vec Y'] {Z} [Hilbert Z]
  (A : X → Y → Y' → Z) [∀ x y', HasAdjointT (λ y => A x y y')] [IsSmoothNT 3 A]
  (g' : X → Y' := λ _ => 0) [IsSmoothT g']
  : (λ (g : X⟿Y) => λ x ⟿ A x (g x) (g' x))†
    =
    λ h => λ x ⟿ (λ y => A x y (g' x))† (h x) :=
by
  rw[elemwise_adjoint_simp_alt1 (λ x => x) (λ x y => A x y (g' x))]
  rw[id.arg_x.adj_simp]
  done

example  : HasAdjointT fun (g : X⟿Y) => fun x ⟿ g x := by infer_instance
example  : HasAdjointT fun (g : X⟿Y) => fun x ⟿ (2:ℝ) * g x := by infer_instance
example  : HasAdjointT fun (g : ℝ⟿ℝ) => fun (x : ℝ) ⟿ x * g x := by infer_instance

example  (f : X⟿Y) : HasAdjointT fun (g : X⟿Y) => fun x ⟿ ⟪g x, f x⟫ := by infer_instance
example  (f : X⟿Y) : HasAdjointT fun (g : X⟿Y) => fun x ⟿ ⟪f x, g x⟫ := by infer_instance

example  : HasAdjointT fun (g : X⟿Y) => fun x ⟿ g x + g x :=
by
  try infer_instance
  apply elemwise_adjoint (λ _ y => y + y)
  done

example  : HasAdjointT fun (g : ℝ⟿Y) => fun x ⟿ g x + x * g x :=
by
  try infer_instance
  apply elemwise_adjoint (λ x y => y + x * y)
  done

instance : HasAdjoint (Smooth.differentialScalar : (ℝ⟿X) → (ℝ⟿X)) := sorry_proof

example  : HasAdjointT fun (g : ℝ⟿Y) => ⅆ g := by infer_instance
example  : HasAdjointT fun (g : ℝ⟿Y) => fun x ⟿ ⅆ g x := by infer_instance

set_option synthInstance.maxSize 20000 in
example  : HasAdjointT fun (g : ℝ⟿Y) => fun x ⟿ g x + ⅆ g x :=
by
  have : HasAdjointNT 2 (λ (g dg : ℝ ⟿ X) => λ x ⟿ g x + dg x) := sorry_proof
  apply scomb_highorder_adjoint (λ g (dg : ℝ ⟿ X) => λ x ⟿ g x + dg x) (λ g => ⅆ g)
  infer_instance

-- set_option trace.Meta.synthPending true in
-- example  (f : ℝ⟿ℝ) : HasAdjointT fun (g : ℝ⟿ℝ) => fun x ⟿ ⟪f x, g x⟫ := by infer_instance

example (D : (ℝ⟿ℝ) → (ℝ⟿ℝ)) [HasAdjointT D] : HasAdjointT fun (g : ℝ⟿ℝ) => fun x ⟿ D g x := by infer_instance
example (D : (ℝ⟿ℝ) → (ℝ⟿ℝ)) [HasAdjointT D] : HasAdjointT fun (g : ℝ⟿ℝ) => fun x ⟿ x * D g x := by infer_instance

set_option synthInstance.maxSize 2000 in
example  (f : ℝ⟿ℝ) : HasAdjointT fun (g : ℝ⟿ℝ) => fun x ⟿ ⟪ⅆ f x, ⅆ g x⟫ := by (try infer_instance); sorry_proof

example  (f : X⟿Y) : (fun (g : X⟿Y) => fun x ⟿ ⟪g x, f x⟫)† = λ h => λ x ⟿ h x * f x := by simp; done
example  (f : X⟿Y) : (fun (g : X⟿Y) => fun x ⟿ ⟪f x, g x⟫)† = λ h => λ x ⟿ h x * f x := by simp; done

example  (f : X⟿Y) : HasAdjointT fun (g : X⟿Y) => fun x ⟿ ⟪f x, g x⟫ := by infer_instance
example  (f : X⟿Y) : HasAdjointT fun (g : X⟿Y) => fun x ⟿ ⟪g x, f x⟫ := by infer_instance
example  (f : X⟿Y) (A : (X⟿Y) → (X⟿Y)) [HasAdjointT A] : HasAdjointT fun (g : X⟿Y) => fun x ⟿ ⟪A g x, f x⟫ := by (try infer_instance); admit
example  (f : X⟿Y) (A : (X⟿Y) → (X⟿Y)) [HasAdjointT A] : HasAdjointT fun (g : X⟿Y) => fun x ⟿ ⟪f x, A g x⟫ := by infer_instance

-- @[simp ↓, diff]
-- theorem smooth_diff_to_normal_diff {X Y} [Vec X] [Vec Y] (f : X → Y) [IsSmoothT f]
--   : ∂ (λ x ⟿ f x) = λ x ⟿ λ dx ⊸ ∂ f x dx := by simp[Smooth.differential]; done

-- @[simp ↓, diff]
-- theorem smooth_sdif_to_normal_sdiff {X} [Vec X] (f : ℝ → X) [IsSmoothT f]
--   : ⅆ (λ x ⟿ f x) = λ x ⟿ ⅆ f x := by simp[Smooth.differential]; done

#check Nat

-- set_option synthInstance.maxSize 2000 in
-- example (f : ℝ⟿ℝ) : ∇ (fun (g : ℝ⟿ℝ) => (∫ x, ⟪f x, ⅆ g x⟫))
--                       =
--                       (λ g => - ⅆ f) := by simp[variationalGradient, tangentMap,Smooth.differential]; done
  -- simp[differentialScalar,tangentMap,Smooth.differential,Smooth.differentialScalar]; done

#check Nat

example (f : ℝ⟿ℝ) : IsSmoothNT 2 (fun (g : ℝ⟿ℝ) x => ⟪f x, g x⟫) := by infer_instance

-- example (f : ℝ⟿ℝ) : IsSmoothNT 2 (fun (g : ℝ⟿ℝ) x => ⟪f x, ⅆ g x⟫) := by infer_instance

-- def a : IsSmoothT (fun (g : ℝ⟿ℝ) => ⅆ g) := by infer_instance


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

Extra definitions on option.
-/

namespace option
variables {α : Type*} {β : Type*}

attribute [inline] option.is_some option.is_none

/-- An elimination principle for `option`. It is a nondependent version of `option.rec_on`. -/
@[simp] protected def elim : option α → β → (α → β) → β
| (some x) y f := f x
| none     y f := y

instance has_mem : has_mem α (option α) := ⟨λ a b, b = some a⟩

@[simp] theorem mem_def {a : α} {b : option α} : a ∈ b ↔ b = some a :=
iff.rfl

theorem is_none_iff_eq_none {o : option α} : o.is_none = tt ↔ o = none :=
⟨option.eq_none_of_is_none, λ e, e.symm ▸ rfl⟩

theorem some_inj {a b : α} : some a = some b ↔ a = b := by simp

/--
`o = none` is decidable even if the wrapped type does not have decidable equality.

This is not an instance because it is not definitionally equal to `option.decidable_eq`.
Try to use `o.is_none` or `o.is_some` instead.
-/
@[inline]
def decidable_eq_none {o : option α} : decidable (o = none) :=
decidable_of_decidable_of_iff (bool.decidable_eq _ _) is_none_iff_eq_none

instance decidable_forall_mem {p : α → Prop} [decidable_pred p] :
  ∀ o : option α, decidable (∀ a ∈ o, p a)
| none     := is_true (by simp [false_implies_iff])
| (some a) := if h : p a
  then is_true $ λ o e, some_inj.1 e ▸ h
  else is_false $ mt (λ H, H _ rfl) h

instance decidable_exists_mem {p : α → Prop} [decidable_pred p] :
  ∀ o : option α, decidable (∃ a ∈ o, p a)
| none     := is_false (λ ⟨a, ⟨h, _⟩⟩, by cases h)
| (some a) := if h : p a
  then is_true $ ⟨_, rfl, h⟩
  else is_false $ λ ⟨_, ⟨rfl, hn⟩⟩, h hn

/-- inhabited `get` function. Returns `a` if the input is `some a`,
  otherwise returns `default`. -/
@[reducible] def iget [inhabited α] : option α → α
| (some x) := x
| none     := default α

@[simp] theorem iget_some [inhabited α] {a : α} : (some a).iget = a := rfl

/-- `guard p a` returns `some a` if `p a` holds, otherwise `none`. -/
def guard (p : α → Prop) [decidable_pred p] (a : α) : option α :=
if p a then some a else none

/-- `filter p o` returns `some a` if `o` is `some a`
  and `p a` holds, otherwise `none`. -/
def filter (p : α → Prop) [decidable_pred p] (o : option α) : option α :=
o.bind (guard p)

def to_list : option α → list α
| none     := []
| (some a) := [a]

@[simp] theorem mem_to_list {a : α} {o : option α} : a ∈ to_list o ↔ a ∈ o :=
by cases o; simp [to_list, eq_comm]

def lift_or_get (f : α → α → α) : option α → option α → option α
| none     none     := none
| (some a) none     := some a       -- get a
| none     (some b) := some b       -- get b
| (some a) (some b) := some (f a b) -- lift f

instance lift_or_get_comm (f : α → α → α) [h : is_commutative α f] :
  is_commutative (option α) (lift_or_get f) :=
⟨λ a b, by cases a; cases b; simp [lift_or_get, h.comm]⟩

instance lift_or_get_assoc (f : α → α → α) [h : is_associative α f] :
  is_associative (option α) (lift_or_get f) :=
⟨λ a b c, by cases a; cases b; cases c; simp [lift_or_get, h.assoc]⟩

instance lift_or_get_idem (f : α → α → α) [h : is_idempotent α f] :
  is_idempotent (option α) (lift_or_get f) :=
⟨λ a, by cases a; simp [lift_or_get, h.idempotent]⟩

instance lift_or_get_is_left_id (f : α → α → α) :
  is_left_id (option α) (lift_or_get f) none :=
⟨λ a, by cases a; simp [lift_or_get]⟩

instance lift_or_get_is_right_id (f : α → α → α) :
  is_right_id (option α) (lift_or_get f) none :=
⟨λ a, by cases a; simp [lift_or_get]⟩

inductive rel (r : α → β → Prop) : option α → option β → Prop
| some {a b} : r a b → rel (some a) (some b)
| none       : rel none none

/-- Partial bind. If for some `x : option α`, `f : Π (a : α), a ∈ x → option β` is a
  partial function defined on `a : α` giving an `option β`, where `some a = x`,
  then `pbind x f h` is essentially the same as `bind x f`
  but is defined only when all `x = some a`, using the proof to apply `f`. -/
@[simp] def pbind : Π (x : option α), (Π (a : α), a ∈ x → option β) → option β
| none     _ := none
| (some a) f := f a rfl

/-- Partial map. If `f : Π a, p a → β` is a partial function defined on
  `a : α` satisfying `p`, then `pmap f x h` is essentially the same as `map f x`
  but is defined only when all members of `x` satisfy `p`, using the proof
  to apply `f`. -/
@[simp] def pmap {p : α → Prop} (f : Π (a : α), p a → β) :
  Π x : option α, (∀ a ∈ x, p a) → option β
| none     _ := none
| (some a) H := some (f a (H a (mem_def.mpr rfl)))

/--
Flatten an `option` of `option`, a specialization of `mjoin`.
-/
@[simp] def join : option (option α) → option α :=
λ x, bind x id

protected def {u v} traverse {F : Type u → Type v} [applicative F] {α β : Type*} (f : α → F β) :
  option α → F (option β)
| none := pure none
| (some x) := some <$> f x

/- By analogy with `monad.sequence` in `init/category/combinators.lean`. -/

/-- If you maybe have a monadic computation in a `[monad m]` which produces a term of type `α`, then
there is a naturally associated way to always perform a computation in `m` which maybe produces a
result. -/
def {u v} maybe {m : Type u → Type v} [monad m] {α : Type u} : option (m α) → m (option α)
| none := return none
| (some fn) := some <$> fn

/-- Map a monadic function `f : α → m β` over an `o : option α`, maybe producing a result. -/
def {u v w} mmap {m : Type u → Type v} [monad m] {α : Type w} {β : Type u} (f : α → m β)
  (o : option α) : m (option β) := (o.map f).maybe

/--
A monadic analogue of `option.elim`.
-/
def melim {α β : Type*} {m : Type* → Type*} [monad m] (x : m (option α)) (y : m β) (z : α → m β) :
  m β :=
x >>= λ o, option.elim o y z

/--
A monadic analogue of `option.get_or_else`.
-/
def mget_or_else {α : Type*} {m : Type* → Type*} [monad m] (x : m (option α)) (y : m α) : m α :=
melim x y pure

end option