/-
Copyright (c) 2021 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import category_theory.epi_mono
import category_theory.limits.has_limits
import category_theory.limits.shapes.equalizers

/-!
# Wide equalizers and wide coequalizers

This file defines wide (co)equalizers as special cases of (co)limits.

A wide equalizer for the family of morphisms `X ⟶ Y` indexed by `J` is the categorical
generalization of the subobject `{a ∈ A | ∀ j₁ j₂, f(j₁, a) = f(j₂, a)}`. Note that if `J` has
fewer than two morphisms this condition is trivial, so some lemmas and definitions assume `J` is
nonempty.

## Main definitions

* `walking_parallel_family` is the indexing category used for wide (co)equalizer diagrams
* `parallel_family` is a functor from `walking_parallel_family` to our category `C`.
* a `trident` is a cone over a parallel family.
  * there is really only one interesting morphism in a trident: the arrow from the vertex of the
    trident to the domain of f and g. It is called `trident.ι`.
* a `wide_equalizer` is now just a `limit (parallel_family f)`

Each of these has a dual.

## Main statements

* `wide_equalizer.ι_mono` states that every wide_equalizer map is a monomorphism
* `is_iso_limit_cone_parallel_family_of_self` states that the identity on the domain of `f` is an
  equalizer of `f` and `f`.

## Implementation notes
As with the other special shapes in the limits library, all the definitions here are given as
`abbreviation`s of the general statements for limits, so all the `simp` lemmas and theorems about
general limits can be used.

## References

* [F. Borceux, *Handbook of Categorical Algebra 1*][borceux-vol1]
-/

noncomputable theory

namespace category_theory.limits

open category_theory

universes w v u u₂

variables {J : Type w}

/-- The type of objects for the diagram indexing a wide (co)equalizer. -/
inductive walking_parallel_family (J : Type w) : Type w
| zero : walking_parallel_family
| one : walking_parallel_family

open walking_parallel_family

instance : decidable_eq (walking_parallel_family J)
| zero zero := is_true rfl
| zero one := is_false (λ t, walking_parallel_family.no_confusion t)
| one zero := is_false (λ t, walking_parallel_family.no_confusion t)
| one one := is_true rfl

instance : inhabited (walking_parallel_family J) := ⟨zero⟩

/-- The type family of morphisms for the diagram indexing a wide (co)equalizer. -/
@[derive decidable_eq] inductive walking_parallel_family.hom (J : Type w) :
  walking_parallel_family J → walking_parallel_family J → Type w
| id : Π X : walking_parallel_family.{w} J, walking_parallel_family.hom X X
| line : Π (j : J), walking_parallel_family.hom zero one

/-- Satisfying the inhabited linter -/
instance (J : Type v) : inhabited (walking_parallel_family.hom J zero zero) :=
{ default := hom.id _ }

open walking_parallel_family.hom

/-- Composition of morphisms in the indexing diagram for wide (co)equalizers. -/
def walking_parallel_family.hom.comp :
  Π (X Y Z : walking_parallel_family J)
    (f : walking_parallel_family.hom J X Y) (g : walking_parallel_family.hom J Y Z),
    walking_parallel_family.hom J X Z
  | _ _ _ (id _)   h := h
  | _ _ _ (line j) (id one) := line j.

local attribute [tidy] tactic.case_bash

instance walking_parallel_family.category : small_category (walking_parallel_family J) :=
{ hom  := walking_parallel_family.hom J,
  id   := walking_parallel_family.hom.id,
  comp := walking_parallel_family.hom.comp }

@[simp]
lemma walking_parallel_family.hom_id (X : walking_parallel_family J) :
  walking_parallel_family.hom.id X = 𝟙 X :=
rfl

variables {C : Type u} [category.{v} C]
variables {X Y : C} (f : J → (X ⟶ Y))

/--
`parallel_family f` is the diagram in `C` consisting of the given family of morphisms, each with
common domain and codomain.
-/
def parallel_family : walking_parallel_family J ⥤ C :=
{ obj := λ x, walking_parallel_family.cases_on x X Y,
  map := λ x y h, match x, y, h with
  | _, _, (id _) := 𝟙 _
  | _, _, (line j) := f j
  end,
  map_comp' :=
  begin
    rintro _ _ _ ⟨⟩ ⟨⟩;
    { unfold_aux, simp; refl },
  end }

@[simp] lemma parallel_family_obj_zero : (parallel_family f).obj zero = X := rfl
@[simp] lemma parallel_family_obj_one : (parallel_family f).obj one = Y := rfl

@[simp] lemma parallel_family_map_left {j : J} : (parallel_family f).map (line j) = f j := rfl

/-- Every functor indexing a wide (co)equalizer is naturally isomorphic (actually, equal) to a
    `parallel_family` -/
@[simps]
def diagram_iso_parallel_family (F : walking_parallel_family J ⥤ C) :
  F ≅ parallel_family (λ j, F.map (line j)) :=
nat_iso.of_components (λ j, eq_to_iso $ by cases j; tidy) $ by tidy

/-- `walking_parallel_pair` as a category is equivalent to a special case of
`walking_parallel_family`.  -/
@[simps]
def walking_parallel_family_equiv_walking_parallel_pair :
  walking_parallel_family.{w} (ulift bool) ≌ walking_parallel_pair :=
{ functor := parallel_family
      (λ p, cond p.down walking_parallel_pair_hom.left walking_parallel_pair_hom.right),
  inverse := parallel_pair (line (ulift.up tt)) (line (ulift.up ff)),
  unit_iso := nat_iso.of_components (λ X, eq_to_iso (by cases X; refl)) (by tidy),
  counit_iso := nat_iso.of_components (λ X, eq_to_iso (by cases X; refl)) (by tidy) }

/-- A trident on `f` is just a `cone (parallel_family f)`. -/
abbreviation trident := cone (parallel_family f)

/-- A cotrident on `f` and `g` is just a `cocone (parallel_family f)`. -/
abbreviation cotrident := cocone (parallel_family f)

variables {f}

/-- A trident `t` on the parallel family `f : J → (X ⟶ Y)` consists of two morphisms
    `t.π.app zero : t.X ⟶ X` and `t.π.app one : t.X ⟶ Y`. Of these, only the first one is
    interesting, and we give it the shorter name `trident.ι t`. -/
abbreviation trident.ι (t : trident f) := t.π.app zero

/-- A cotrident `t` on the parallel family `f : J → (X ⟶ Y)` consists of two morphisms
    `t.ι.app zero : X ⟶ t.X` and `t.ι.app one : Y ⟶ t.X`. Of these, only the second one is
    interesting, and we give it the shorter name `cotrident.π t`. -/
abbreviation cotrident.π (t : cotrident f) := t.ι.app one

@[simp] lemma trident.ι_eq_app_zero (t : trident f) : t.ι = t.π.app zero := rfl
@[simp] lemma cotrident.π_eq_app_one (t : cotrident f) : t.π = t.ι.app one := rfl

@[simp, reassoc] lemma trident.app_zero (s : trident f) (j : J) :
  s.π.app zero ≫ f j = s.π.app one :=
by rw [←s.w (line j), parallel_family_map_left]

@[simp, reassoc] lemma cotrident.app_one (s : cotrident f) (j : J) :
  f j ≫ s.ι.app one = s.ι.app zero :=
by rw [←s.w (line j), parallel_family_map_left]

/--
A trident on `f : J → (X ⟶ Y)` is determined by the morphism `ι : P ⟶ X` satisfying
`∀ j₁ j₂, ι ≫ f j₁ = ι ≫ f j₂`.
-/
@[simps]
def trident.of_ι [nonempty J] {P : C} (ι : P ⟶ X) (w : ∀ j₁ j₂, ι ≫ f j₁ = ι ≫ f j₂) :
  trident f :=
{ X := P,
  π :=
  { app := λ X, walking_parallel_family.cases_on X ι (ι ≫ f (classical.arbitrary J)),
    naturality' := λ i j f,
      begin
        dsimp,
        cases f with _ k,
        { simp },
        { simp [w (classical.arbitrary J) k] },
      end } }

/--
A cotrident on `f : J → (X ⟶ Y)` is determined by the morphism `π : Y ⟶ P` satisfying
`∀ j₁ j₂, f j₁ ≫ π = f j₂ ≫ π`.
-/
@[simps]
def cotrident.of_π [nonempty J] {P : C} (π : Y ⟶ P) (w : ∀ j₁ j₂, f j₁ ≫ π = f j₂ ≫ π) :
  cotrident f :=
{ X := P,
  ι :=
  { app := λ X, walking_parallel_family.cases_on X (f (classical.arbitrary J) ≫ π) π,
    naturality' := λ i j f,
      begin
        dsimp,
        cases f with _ k,
        { simp },
        { simp [w (classical.arbitrary J) k] }
      end } } -- See note [dsimp, simp]

lemma trident.ι_of_ι [nonempty J] {P : C} (ι : P ⟶ X) (w : ∀ j₁ j₂, ι ≫ f j₁ = ι ≫ f j₂) :
  (trident.of_ι ι w).ι = ι := rfl
lemma cotrident.π_of_π [nonempty J] {P : C} (π : Y ⟶ P) (w : ∀ j₁ j₂, f j₁ ≫ π = f j₂ ≫ π) :
  (cotrident.of_π π w).π = π := rfl

@[reassoc]
lemma trident.condition (j₁ j₂ : J) (t : trident f) : t.ι ≫ f j₁ = t.ι ≫ f j₂ :=
by rw [t.app_zero, t.app_zero]

@[reassoc]
lemma cotrident.condition (j₁ j₂ : J) (t : cotrident f) : f j₁ ≫ t.π = f j₂ ≫ t.π :=
by rw [t.app_one, t.app_one]

/-- To check whether two maps are equalized by both maps of a trident, it suffices to check it for
the first map -/
lemma trident.equalizer_ext [nonempty J] (s : trident f) {W : C} {k l : W ⟶ s.X}
  (h : k ≫ s.ι = l ≫ s.ι) : ∀ (j : walking_parallel_family J),
    k ≫ s.π.app j = l ≫ s.π.app j
| zero := h
| one := by rw [←s.app_zero (classical.arbitrary J), reassoc_of h]

/-- To check whether two maps are coequalized by both maps of a cotrident, it suffices to check it
for the second map -/
lemma cotrident.coequalizer_ext [nonempty J] (s : cotrident f) {W : C} {k l : s.X ⟶ W}
  (h : s.π ≫ k = s.π ≫ l) : ∀ (j : walking_parallel_family J),
    s.ι.app j ≫ k = s.ι.app j ≫ l
| zero := by rw [←s.app_one (classical.arbitrary J), category.assoc, category.assoc, h]
| one := h

lemma trident.is_limit.hom_ext [nonempty J] {s : trident f} (hs : is_limit s)
  {W : C} {k l : W ⟶ s.X} (h : k ≫ s.ι = l ≫ s.ι) :
  k = l :=
hs.hom_ext $ trident.equalizer_ext _ h

lemma cotrident.is_colimit.hom_ext [nonempty J] {s : cotrident f} (hs : is_colimit s)
  {W : C} {k l : s.X ⟶ W} (h : s.π ≫ k = s.π ≫ l) :
  k = l :=
hs.hom_ext $ cotrident.coequalizer_ext _ h

/-- If `s` is a limit trident over `f`, then a morphism `k : W ⟶ X` satisfying
    `∀ j₁ j₂, k ≫ f j₁ = k ≫ f j₂` induces a morphism `l : W ⟶ s.X` such that
    `l ≫ trident.ι s = k`. -/
def trident.is_limit.lift' [nonempty J] {s : trident f} (hs : is_limit s) {W : C} (k : W ⟶ X)
  (h : ∀ j₁ j₂, k ≫ f j₁ = k ≫ f j₂) :
  {l : W ⟶ s.X // l ≫ trident.ι s = k} :=
⟨hs.lift $ trident.of_ι _ h, hs.fac _ _⟩

/-- If `s` is a colimit cotrident over `f`, then a morphism `k : Y ⟶ W` satisfying
    `∀ j₁ j₂, f j₁ ≫ k = f j₂ ≫ k` induces a morphism `l : s.X ⟶ W` such that
    `cotrident.π s ≫ l = k`. -/
def cotrident.is_colimit.desc' [nonempty J] {s : cotrident f} (hs : is_colimit s) {W : C}
  (k : Y ⟶ W) (h : ∀ j₁ j₂, f j₁ ≫ k = f j₂ ≫ k) :
  {l : s.X ⟶ W // cotrident.π s ≫ l = k} :=
⟨hs.desc $ cotrident.of_π _ h, hs.fac _ _⟩

/-- This is a slightly more convenient method to verify that a trident is a limit cone. It
    only asks for a proof of facts that carry any mathematical content -/
def trident.is_limit.mk [nonempty J] (t : trident f)
  (lift : Π (s : trident f), s.X ⟶ t.X)
  (fac : ∀ (s : trident f), lift s ≫ t.ι = s.ι)
  (uniq : ∀ (s : trident f) (m : s.X ⟶ t.X)
  (w : ∀ j : walking_parallel_family J, m ≫ t.π.app j = s.π.app j), m = lift s) :
  is_limit t :=
{ lift := lift,
  fac' := λ s j, walking_parallel_family.cases_on j (fac s)
    (by rw [←t.w (line (classical.arbitrary J)), reassoc_of fac, s.w]),
  uniq' := uniq }

/-- This is another convenient method to verify that a trident is a limit cone. It
    only asks for a proof of facts that carry any mathematical content, and allows access to the
    same `s` for all parts. -/
def trident.is_limit.mk' [nonempty J] (t : trident f)
  (create : Π (s : trident f), {l // l ≫ t.ι = s.ι ∧ ∀ {m}, m ≫ t.ι = s.ι → m = l}) :
is_limit t :=
trident.is_limit.mk t
  (λ s, (create s).1)
  (λ s, (create s).2.1)
  (λ s m w, (create s).2.2 (w zero))

/-- This is a slightly more convenient method to verify that a cotrident is a colimit cocone. It
    only asks for a proof of facts that carry any mathematical content -/
def cotrident.is_colimit.mk [nonempty J] (t : cotrident f)
  (desc : Π (s : cotrident f), t.X ⟶ s.X)
  (fac : ∀ (s : cotrident f), t.π ≫ desc s = s.π)
  (uniq : ∀ (s : cotrident f) (m : t.X ⟶ s.X)
  (w : ∀ j : walking_parallel_family J, t.ι.app j ≫ m = s.ι.app j), m = desc s) :
  is_colimit t :=
{ desc := desc,
  fac' := λ s j, walking_parallel_family.cases_on j
    (by rw [←t.w_assoc (line (classical.arbitrary J)), fac, s.w]) (fac s),
  uniq' := uniq }

/-- This is another convenient method to verify that a cotrident is a colimit cocone. It
    only asks for a proof of facts that carry any mathematical content, and allows access to the
    same `s` for all parts. -/
def cotrident.is_colimit.mk' [nonempty J] (t : cotrident f)
  (create : Π (s : cotrident f), {l : t.X ⟶ s.X // t.π ≫ l = s.π ∧ ∀ {m}, t.π ≫ m = s.π → m = l}) :
  is_colimit t :=
cotrident.is_colimit.mk t
  (λ s, (create s).1)
  (λ s, (create s).2.1)
  (λ s m w, (create s).2.2 (w one))

/--
Given a limit cone for the family `f : J → (X ⟶ Y)`, for any `Z`, morphisms from `Z` to its point
are in bijection with morphisms `h : Z ⟶ X` such that `∀ j₁ j₂, h ≫ f j₁ = h ≫ f j₂`.
Further, this bijection is natural in `Z`: see `trident.is_limit.hom_iso_natural`.
-/
@[simps]
def trident.is_limit.hom_iso [nonempty J] {t : trident f} (ht : is_limit t) (Z : C) :
  (Z ⟶ t.X) ≃ {h : Z ⟶ X // ∀ j₁ j₂, h ≫ f j₁ = h ≫ f j₂} :=
{ to_fun := λ k, ⟨k ≫ t.ι, by simp⟩,
  inv_fun := λ h, (trident.is_limit.lift' ht _ h.prop).1,
  left_inv := λ k, trident.is_limit.hom_ext ht (trident.is_limit.lift' _ _ _).prop,
  right_inv := λ h, subtype.ext (trident.is_limit.lift' ht _ _).prop }

/-- The bijection of `trident.is_limit.hom_iso` is natural in `Z`. -/
lemma trident.is_limit.hom_iso_natural [nonempty J] {t : trident f} (ht : is_limit t)
  {Z Z' : C} (q : Z' ⟶ Z) (k : Z ⟶ t.X) :
  (trident.is_limit.hom_iso ht _ (q ≫ k) : Z' ⟶ X) =
  q ≫ (trident.is_limit.hom_iso ht _ k : Z ⟶ X) :=
category.assoc _ _ _

/--
Given a colimit cocone for the family `f : J → (X ⟶ Y)`, for any `Z`, morphisms from the cocone
point to `Z` are in bijection with morphisms `h : Z ⟶ X` such that
`∀ j₁ j₂, f j₁ ≫ h = f j₂ ≫ h`.  Further, this bijection is natural in `Z`: see
`cotrident.is_colimit.hom_iso_natural`.
-/
@[simps]
def cotrident.is_colimit.hom_iso [nonempty J] {t : cotrident f} (ht : is_colimit t) (Z : C) :
  (t.X ⟶ Z) ≃ {h : Y ⟶ Z // ∀ j₁ j₂, f j₁ ≫ h = f j₂ ≫ h} :=
{ to_fun := λ k, ⟨t.π ≫ k, by simp⟩,
  inv_fun := λ h, (cotrident.is_colimit.desc' ht _ h.prop).1,
  left_inv := λ k, cotrident.is_colimit.hom_ext ht (cotrident.is_colimit.desc' _ _ _).prop,
  right_inv := λ h, subtype.ext (cotrident.is_colimit.desc' ht _ _).prop }

/-- The bijection of `cotrident.is_colimit.hom_iso` is natural in `Z`. -/
lemma cotrident.is_colimit.hom_iso_natural [nonempty J] {t : cotrident f} {Z Z' : C}
  (q : Z ⟶ Z') (ht : is_colimit t) (k : t.X ⟶ Z) :
    (cotrident.is_colimit.hom_iso ht _ (k ≫ q) : Y ⟶ Z') =
    (cotrident.is_colimit.hom_iso ht _ k : Y ⟶ Z) ≫ q :=
(category.assoc _ _ _).symm

/-- This is a helper construction that can be useful when verifying that a category has certain wide
    equalizers. Given `F : walking_parallel_family ⥤ C`, which is really the same as
    `parallel_family (λ j, F.map (line j))`, and a trident on `λ j, F.map (line j)`, we get a cone
    on `F`.

    If you're thinking about using this, have a look at
    `has_wide_equalizers_of_has_limit_parallel_family`, which you may find to be an easier way of
    achieving your goal. -/
def cone.of_trident
  {F : walking_parallel_family J ⥤ C} (t : trident (λ j, F.map (line j))) : cone F :=
{ X := t.X,
  π :=
  { app := λ X, t.π.app X ≫ eq_to_hom (by tidy),
    naturality' := λ j j' g, by { cases g; { dsimp, simp } } } }

/-- This is a helper construction that can be useful when verifying that a category has all
    coequalizers. Given `F : walking_parallel_family ⥤ C`, which is really the same as
    `parallel_family (λ j, F.map (line j))`, and a cotrident on `λ j, F.map (line j)` we get a
    cocone on `F`.

    If you're thinking about using this, have a look at
    `has_wide_coequalizers_of_has_colimit_parallel_family`, which you may find to be an easier way
    of achieving your goal. -/
def cocone.of_cotrident
  {F : walking_parallel_family J ⥤ C} (t : cotrident (λ j, F.map (line j))) : cocone F :=
{ X := t.X,
  ι :=
  { app := λ X, eq_to_hom (by tidy) ≫ t.ι.app X,
    naturality' := λ j j' g, by { cases g; dsimp; simp [cotrident.app_one t] } } }

@[simp] lemma cone.of_trident_π
  {F : walking_parallel_family J ⥤ C} (t : trident (λ j, F.map (line j))) (j) :
  (cone.of_trident t).π.app j = t.π.app j ≫ eq_to_hom (by tidy) := rfl

@[simp] lemma cocone.of_cotrident_ι
  {F : walking_parallel_family J ⥤ C} (t : cotrident (λ j, F.map (line j))) (j) :
  (cocone.of_cotrident t).ι.app j = eq_to_hom (by tidy) ≫ t.ι.app j := rfl

/-- Given `F : walking_parallel_family ⥤ C`, which is really the same as
    `parallel_family (λ j, F.map (line j))` and a cone on `F`, we get a trident on
    `λ j, F.map (line j)`. -/
def trident.of_cone
  {F : walking_parallel_family J ⥤ C} (t : cone F) : trident (λ j, F.map (line j)) :=
{ X := t.X,
  π := { app := λ X, t.π.app X ≫ eq_to_hom (by tidy) } }

/-- Given `F : walking_parallel_family ⥤ C`, which is really the same as
    `parallel_family (F.map left) (F.map right)` and a cocone on `F`, we get a cotrident on
    `λ j, F.map (line j)`. -/
def cotrident.of_cocone
  {F : walking_parallel_family J ⥤ C} (t : cocone F) : cotrident (λ j, F.map (line j)) :=
{ X := t.X,
  ι := { app := λ X, eq_to_hom (by tidy) ≫ t.ι.app X } }

@[simp] lemma trident.of_cone_π {F : walking_parallel_family J ⥤ C} (t : cone F) (j) :
  (trident.of_cone t).π.app j = t.π.app j ≫ eq_to_hom (by tidy) := rfl
@[simp] lemma cotrident.of_cocone_ι {F : walking_parallel_family J ⥤ C} (t : cocone F) (j) :
  (cotrident.of_cocone t).ι.app j = eq_to_hom (by tidy) ≫ t.ι.app j := rfl

/--
Helper function for constructing morphisms between wide equalizer tridents.
-/
@[simps]
def trident.mk_hom [nonempty J] {s t : trident f} (k : s.X ⟶ t.X) (w : k ≫ t.ι = s.ι) : s ⟶ t :=
{ hom := k,
  w' :=
  begin
    rintro ⟨_|_⟩,
    { exact w },
    { simpa using w =≫ f (classical.arbitrary J) },
  end }

/--
To construct an isomorphism between tridents,
it suffices to give an isomorphism between the cone points
and check that it commutes with the `ι` morphisms.
-/
@[simps]
def trident.ext [nonempty J] {s t : trident f} (i : s.X ≅ t.X) (w : i.hom ≫ t.ι = s.ι) : s ≅ t :=
{ hom := trident.mk_hom i.hom w,
  inv := trident.mk_hom i.inv (by rw [← w, iso.inv_hom_id_assoc]) }

/--
Helper function for constructing morphisms between coequalizer cotridents.
-/
@[simps]
def cotrident.mk_hom [nonempty J] {s t : cotrident f} (k : s.X ⟶ t.X) (w : s.π ≫ k = t.π) :
  s ⟶ t :=
{ hom := k,
  w' :=
  begin
    rintro ⟨_|_⟩,
    { simpa using f (classical.arbitrary J) ≫= w },
    { exact w },
  end }

/--
To construct an isomorphism between cotridents,
it suffices to give an isomorphism between the cocone points
and check that it commutes with the `π` morphisms.
-/
def cotrident.ext [nonempty J] {s t : cotrident f} (i : s.X ≅ t.X) (w : s.π ≫ i.hom = t.π) :
  s ≅ t :=
{ hom := cotrident.mk_hom i.hom w,
  inv := cotrident.mk_hom i.inv (by rw [iso.comp_inv_eq, w]) }

variables (f)

section
/--
`has_wide_equalizer f` represents a particular choice of limiting cone for the parallel family of
morphisms `f`.
-/
abbreviation has_wide_equalizer := has_limit (parallel_family f)

variables [has_wide_equalizer f]

/-- If a wide equalizer of `f` exists, we can access an arbitrary choice of such by
    saying `wide_equalizer f`. -/
abbreviation wide_equalizer : C := limit (parallel_family f)

/-- If a wide equalizer of `f` exists, we can access the inclusion `wide_equalizer f ⟶ X` by
    saying `wide_equalizer.ι f`. -/
abbreviation wide_equalizer.ι : wide_equalizer f ⟶ X :=
limit.π (parallel_family f) zero

/--
A wide equalizer cone for a parallel family `f`.
-/
abbreviation wide_equalizer.trident : trident f := limit.cone (parallel_family f)

@[simp] lemma wide_equalizer.trident_ι :
  (wide_equalizer.trident f).ι = wide_equalizer.ι f := rfl

@[simp] lemma wide_equalizer.trident_π_app_zero :
  (wide_equalizer.trident f).π.app zero = wide_equalizer.ι f := rfl

@[reassoc] lemma wide_equalizer.condition (j₁ j₂ : J) :
  wide_equalizer.ι f ≫ f j₁ = wide_equalizer.ι f ≫ f j₂ :=
trident.condition j₁ j₂ $ limit.cone $ parallel_family f

/-- The wide_equalizer built from `wide_equalizer.ι f` is limiting. -/
def wide_equalizer_is_wide_equalizer [nonempty J] :
  is_limit (trident.of_ι (wide_equalizer.ι f) (wide_equalizer.condition f)) :=
is_limit.of_iso_limit (limit.is_limit _) (trident.ext (iso.refl _) (by tidy))

variables {f}

/-- A morphism `k : W ⟶ X` satisfying `∀ j₁ j₂, k ≫ f j₁ = k ≫ f j₂` factors through the
    wide equalizer of `f` via `wide_equalizer.lift : W ⟶ wide_equalizer f`. -/
abbreviation wide_equalizer.lift [nonempty J] {W : C} (k : W ⟶ X)
  (h : ∀ j₁ j₂, k ≫ f j₁ = k ≫ f j₂) :
  W ⟶ wide_equalizer f :=
limit.lift (parallel_family f) (trident.of_ι k h)

@[simp, reassoc]
lemma wide_equalizer.lift_ι [nonempty J] {W : C} (k : W ⟶ X) (h : ∀ j₁ j₂, k ≫ f j₁ = k ≫ f j₂) :
  wide_equalizer.lift k h ≫ wide_equalizer.ι f = k :=
limit.lift_π _ _

/-- A morphism `k : W ⟶ X` satisfying `∀ j₁ j₂, k ≫ f j₁ = k ≫ f j₂` induces a morphism
    `l : W ⟶ wide_equalizer f` satisfying `l ≫ wide_equalizer.ι f = k`. -/
def wide_equalizer.lift' [nonempty J] {W : C} (k : W ⟶ X) (h : ∀ j₁ j₂, k ≫ f j₁ = k ≫ f j₂) :
  {l : W ⟶ wide_equalizer f // l ≫ wide_equalizer.ι f = k} :=
⟨wide_equalizer.lift k h, wide_equalizer.lift_ι _ _⟩

/-- Two maps into a wide equalizer are equal if they are are equal when composed with the wide
    equalizer map. -/
@[ext] lemma wide_equalizer.hom_ext [nonempty J] {W : C} {k l : W ⟶ wide_equalizer f}
  (h : k ≫ wide_equalizer.ι f = l ≫ wide_equalizer.ι f) : k = l :=
trident.is_limit.hom_ext (limit.is_limit _) h

/-- A wide equalizer morphism is a monomorphism -/
instance wide_equalizer.ι_mono [nonempty J] : mono (wide_equalizer.ι f) :=
{ right_cancellation := λ Z h k w, wide_equalizer.hom_ext w }

end

section
variables {f}
/-- The wide equalizer morphism in any limit cone is a monomorphism. -/
lemma mono_of_is_limit_parallel_family [nonempty J] {c : cone (parallel_family f)}
  (i : is_limit c) :
  mono (trident.ι c) :=
{ right_cancellation := λ Z h k w, trident.is_limit.hom_ext i w }

end

section
/--
`has_wide_coequalizer f g` represents a particular choice of colimiting cocone
for the parallel family of morphisms `f`.
-/
abbreviation has_wide_coequalizer := has_colimit (parallel_family f)

variables [has_wide_coequalizer f]

/-- If a wide coequalizer of `f`, we can access an arbitrary choice of such by
    saying `wide_coequalizer f`. -/
abbreviation wide_coequalizer : C := colimit (parallel_family f)

/--  If a wide_coequalizer of `f` exists, we can access the corresponding projection by
    saying `wide_coequalizer.π f`. -/
abbreviation wide_coequalizer.π : Y ⟶ wide_coequalizer f :=
colimit.ι (parallel_family f) one

/--
An arbitrary choice of coequalizer cocone for a parallel family `f`.
-/
abbreviation wide_coequalizer.cotrident : cotrident f := colimit.cocone (parallel_family f)

@[simp] lemma wide_coequalizer.cotrident_π :
  (wide_coequalizer.cotrident f).π = wide_coequalizer.π f := rfl

@[simp] lemma wide_coequalizer.cotrident_ι_app_one :
  (wide_coequalizer.cotrident f).ι.app one = wide_coequalizer.π f := rfl

@[reassoc] lemma wide_coequalizer.condition (j₁ j₂ : J) :
  f j₁ ≫ wide_coequalizer.π f = f j₂ ≫ wide_coequalizer.π f :=
cotrident.condition j₁ j₂ $ colimit.cocone $ parallel_family f

/-- The cotrident built from `wide_coequalizer.π f` is colimiting. -/
def wide_coequalizer_is_wide_coequalizer [nonempty J] :
  is_colimit (cotrident.of_π (wide_coequalizer.π f) (wide_coequalizer.condition f)) :=
is_colimit.of_iso_colimit (colimit.is_colimit _) (cotrident.ext (iso.refl _) (by tidy))

variables {f}

/-- Any morphism `k : Y ⟶ W` satisfying `∀ j₁ j₂, f j₁ ≫ k = f j₂ ≫ k` factors through the
    wide coequalizer of `f` via `wide_coequalizer.desc : wide_coequalizer f ⟶ W`. -/
abbreviation wide_coequalizer.desc [nonempty J] {W : C} (k : Y ⟶ W)
  (h : ∀ j₁ j₂, f j₁ ≫ k = f j₂ ≫ k) :
  wide_coequalizer f ⟶ W :=
colimit.desc (parallel_family f) (cotrident.of_π k h)

@[simp, reassoc]
lemma wide_coequalizer.π_desc [nonempty J] {W : C} (k : Y ⟶ W) (h : ∀ j₁ j₂, f j₁ ≫ k = f j₂ ≫ k) :
  wide_coequalizer.π f ≫ wide_coequalizer.desc k h = k :=
colimit.ι_desc _ _

/-- Any morphism `k : Y ⟶ W` satisfying `∀ j₁ j₂, f j₁ ≫ k = f j₂ ≫ k` induces a morphism
    `l : wide_coequalizer f ⟶ W` satisfying `wide_coequalizer.π ≫ g = l`. -/
def wide_coequalizer.desc' [nonempty J] {W : C} (k : Y ⟶ W) (h : ∀ j₁ j₂, f j₁ ≫ k = f j₂ ≫ k) :
  {l : wide_coequalizer f ⟶ W // wide_coequalizer.π f ≫ l = k} :=
⟨wide_coequalizer.desc k h, wide_coequalizer.π_desc _ _⟩

/-- Two maps from a wide coequalizer are equal if they are equal when composed with the wide
    coequalizer map -/
@[ext] lemma wide_coequalizer.hom_ext [nonempty J] {W : C} {k l : wide_coequalizer f ⟶ W}
  (h : wide_coequalizer.π f ≫ k = wide_coequalizer.π f ≫ l) : k = l :=
cotrident.is_colimit.hom_ext (colimit.is_colimit _) h

/-- A wide coequalizer morphism is an epimorphism -/
instance wide_coequalizer.π_epi [nonempty J] : epi (wide_coequalizer.π f) :=
{ left_cancellation := λ Z h k w, wide_coequalizer.hom_ext w }

end

section
variables {f}

/-- The wide coequalizer morphism in any colimit cocone is an epimorphism. -/
lemma epi_of_is_colimit_parallel_family [nonempty J] {c : cocone (parallel_family f)}
  (i : is_colimit c) :
  epi (c.ι.app one) :=
{ left_cancellation := λ Z h k w, cotrident.is_colimit.hom_ext i w }

end

variables (C)

/-- `has_wide_equalizers` represents a choice of wide equalizer for every family of morphisms -/
abbreviation has_wide_equalizers := Π J, has_limits_of_shape (walking_parallel_family.{w} J) C

/-- `has_wide_coequalizers` represents a choice of wide coequalizer for every family of morphisms -/
abbreviation has_wide_coequalizers := Π J, has_colimits_of_shape (walking_parallel_family.{w} J) C

/-- If `C` has all limits of diagrams `parallel_family f`, then it has all wide equalizers -/
lemma has_wide_equalizers_of_has_limit_parallel_family
  [Π {J : Type w} {X Y : C} {f : J → (X ⟶ Y)}, has_limit (parallel_family f)] :
  has_wide_equalizers.{w} C :=
λ J, { has_limit := λ F, has_limit_of_iso (diagram_iso_parallel_family F).symm }

/-- If `C` has all colimits of diagrams `parallel_family f`, then it has all wide coequalizers -/
lemma has_wide_coequalizers_of_has_colimit_parallel_family
  [Π {J : Type w} {X Y : C} {f : J → (X ⟶ Y)}, has_colimit (parallel_family f)] :
  has_wide_coequalizers.{w} C :=
λ J, { has_colimit := λ F, has_colimit_of_iso (diagram_iso_parallel_family F) }

@[priority 10]
instance has_equalizers_of_has_wide_equalizers [has_wide_equalizers.{w} C] : has_equalizers C :=
has_limits_of_shape_of_equivalence.{w} walking_parallel_family_equiv_walking_parallel_pair

@[priority 10]
instance has_coequalizers_of_has_wide_coequalizers [has_wide_coequalizers.{w} C] :
  has_coequalizers C :=
has_colimits_of_shape_of_equivalence.{w} walking_parallel_family_equiv_walking_parallel_pair

end category_theory.limits


example (P Q F : Type) : (P → Q) → ((Q → F) → (P → F)) :=
begin
intros f g p,
have q : Q := f p,
exact g q,
end


import util.data.fin
import util.predicate.basic
import tactic.tauto

namespace predicate

universe variables u u' u₀ u₁ u₂

variables {α : Sort u₀}
variables {β : Sort u₁}
variables {γ : Sort u₂}
variables {σ : Sort u'}

@[simp, predicate]
lemma value_proj (p : var β γ) (f : var α β) (x : α)
: (p ! f).apply x = p.apply (f.apply x) :=
by { cases p, cases f, refl }

@[simp, predicate]
lemma contramap_apply (p : var α γ) (f : var β α) (x : β)
: x ⊨ (p ! f) = f.apply x ⊨ p :=
by { cases p , cases f, refl }

@[simp, predicate]
lemma p_and_to_fun (p₀ p₁ : pred' α) (x : α)
: x ⊨ p_and p₀ p₁ ↔ x ⊨ p₀ ∧ x ⊨ p₁ := by refl

@[simp, predicate]
lemma p_impl_to_fun (p₀ p₁ : pred' α) (x : α)
: x ⊨ p_impl p₀ p₁ ↔ (x ⊨ p₀ → x ⊨ p₁) := by refl

@[simp, predicate]
lemma p_equiv_to_fun (p₀ p₁ : pred' α) (x : α)
: x ⊨ p_equiv p₀ p₁ ↔ (x ⊨ p₀ ↔ x ⊨ p₁) :=
by { simp with lifted_fn }

lemma p_impl_revert {Γ p q : pred' α}
  (h : Γ ⊢ p_impl p q)
: Γ ⊢ p → Γ ⊢ q :=
begin
  intros h₁,
  constructor, introv h₂,
  apply h.apply _ h₂,
  apply h₁.apply _ h₂,
end

instance imp_to_fun ⦃α⦄ ⦃Γ p q : pred' α⦄ : has_coe_to_fun (Γ ⊢ p_impl p q) :=
{ F := λ _,(Γ ⊢ p) → (Γ ⊢ q)
, coe := p_impl_revert }

lemma p_imp_ext {Γ p q : pred' α}
  (h : ∀ σ, σ ⊨ Γ → σ ⊨ p → σ ⊨ q)
: Γ ⊢ p ⟶ q :=
⟨ h ⟩

lemma p_imp_sem {Γ p q : pred' α}
  (h : Γ ⊢ p ⟶ q)
: ∀ σ, σ ⊨ Γ → σ ⊨ p → σ ⊨ q :=
h.apply

lemma p_entails_of_fun (p₀ p₁ : pred' α)
: p_entails p₀ p₁ ↔ ∀ Γ, Γ ⊢ p₀ → Γ ⊢ p₁ :=
begin
  split ; intros h _,
  { intro h', apply h Γ h' },
  { constructor,
    introv h₀ h₁,
    apply (h  ⟨ eq σ ⟩ _).apply σ rfl,
    constructor, introv h,
    cases h, assumption, }
end

@[simp]
lemma False_eq_false (Γ : pred' β) : Γ ⊢ False ↔ Γ = False :=
begin
  split ; intro h,
  { cases h with h, cases Γ with Γ, simp [False,lifted₀],
    funext σ,
    specialize h σ, apply eq_false_intro,
    intro h',
    apply h h' },
  { rw h, constructor,
    intro, exact id }
end

@[simp, predicate]
lemma False_sem (σ : β) : σ ⊨ False ↔ false :=
by simp with predicate

@[simp]
lemma True_eq_true (Γ : pred' β) : Γ ⊢ True = true :=
by { apply eq_true_intro, constructor, intros, trivial }
@[simp]
lemma True_holds : ⊩ @True β :=
by simp [holds]

@[simp]
lemma coe_true : (true : pred' α) = True := rfl
@[simp]
lemma coe_false : (false : pred' α) = False := rfl

@[simp, predicate]
lemma True_sem (σ : β) : σ ⊨ True ↔ true :=
by simp [holds]

lemma p_forall_revert {Γ} {p : β → pred' α}
  (h : Γ ⊢ p_forall p)
: Π i, Γ ⊢ p i :=
begin
  introv,
  constructor, introv h₂,
  apply h.apply _ h₂,
end

instance forall_to_fun {Γ : pred' α} ⦃p  : β → pred' α⦄ : has_coe_to_fun (Γ ⊢ p_forall p) :=
{ F := λ _, Π i, (Γ ⊢ p i)
, coe := p_forall_revert }

-- instance : has_coe Prop (pred' α) :=
-- ⟨ lifted₀ ⟩

instance proof_coe (p : Prop) (Γ : pred' α) : has_coe p (Γ ⊢ p) :=
⟨ assume h, ⟨ λ x _, h ⟩ ⟩

-- instance to_prop_to_pred : has_coe (α → Prop) (pred' α) :=
-- ⟨ pred'.mk ⟩

@[simp, predicate]
lemma sem_coe (p : Prop) (x : β)
: x ⊨ (p : pred' β) ↔ p :=
by refl

@[simp, predicate]
lemma sem_seq (σ : γ) (f : var γ (α → β)) (x : var γ α)
: σ ⊨ var_seq f x = (σ ⊨ f) (σ ⊨ x)  :=
by { cases x, cases f, simp [var_seq], }

instance var_lawful_functor (α : Type u) : is_lawful_functor (var α) :=
by { constructor ; intros ; cases x ; refl }

instance var_lawful_applicative (α : Type u) : is_lawful_applicative (var α) :=
by { constructor ; intros ; casesm* var _ _ ; refl }

instance (α : Type u) : is_lawful_monad (var α) :=
{ pure_bind := by { intros, cases h : f x, simp! [h], }
, bind_assoc := by { intros ; cases x, simp!, funext, cases (f $ x i), refl }
, map_pure := by { intros ; casesm* var _ _ ; refl }
, seq_pure := by { intros ; casesm* var _ _ ; refl }
, seq_assoc := by intros ; casesm* var _ _ ; refl
, bind_map_eq_seq := by intros ; casesm* var _ _ ; refl
, bind_pure_comp_eq_map := by intros ; casesm* var _ _ ; refl
}
-- , ..predicate.var_lawful_applicative α }
-- , ..(predicate.var_lawful_applicative α).to_is_lawful_functor  }

@[simp, predicate]
lemma var_map_coe {α β σ : Type u} (f : α → β) (g : σ → α)
: ⟨ f  ⟩!⟨ g ⟩ = ⟨ f ∘ g ⟩ :=
by { simp [proj] }

@[simp, predicate]
lemma map_proj {α β γ σ : Type u} (f : α → β) (v₁ : var σ γ) (v₀ : var γ α)
: ⟨ f ⟩ ! (v₀ ! v₁) = ⟨ λ x, f $ v₀.apply $ v₁.apply x ⟩ :=
by { cases v₀, cases v₁, simp }

@[simp, predicate]
lemma var_seq_coe {α β σ : Type u} (f : σ → α → β) (g : σ → α)
: (⟨ f ⟩ : var _ _) <*> ⟨ g ⟩ = (⟨ λ s : σ, f s (g s) ⟩ : var σ β) :=
by { simp [has_seq.seq] }

@[simp, predicate]
lemma models_lt {α : Type u} [has_lt α] {s : σ} (x y : var σ α)
: s ⊨ x ≺ y ↔ x.apply s < y.apply s :=
by { cases x, cases y, refl }

@[simp, predicate]
lemma models_le {α : Type u} [has_le α] {s : σ} (x y : var σ α)
: s ⊨ x ≼ y ↔ x.apply s ≤ y.apply s :=
by { cases x, cases y, refl }

@[simp, predicate]
lemma models_wf {_ : has_well_founded α} (s : σ) (x y : var σ α)
: s ⊨ x ≺≺ y ↔ x.apply s << y.apply s :=
by { cases x, cases y, refl }

@[simp, predicate]
lemma models_eq {s : σ} (x y : var σ α)
: s ⊨ x ≃ y ↔ x.apply s = y.apply s :=
by { cases x, cases y, refl }

@[simp, predicate]
lemma models_mem {α β : Type _} {s : σ} [has_mem α β] (x : var σ α) (y : var σ β)
: s ⊨ (x ∊ y) ↔ x.apply s ∈ y.apply s :=
by { cases x, cases y, refl }

@[simp, predicate]
lemma coe_value {s : σ} (x : α)
: (x : var σ α).apply s = x :=
rfl

@[simp, predicate]
lemma coe_fun {s : σ} (x : σ → α)
: (⟨ x ⟩ : var σ α).apply s = x s :=
rfl

@[simp, predicate]
lemma coe_wf_coe {s : σ} (x y : α)
: (x : var σ α) ≺≺ y = ↑(x << y) :=
rfl

@[simp]
lemma eq_judgement {p : pred' α} (σ : α)
: ⟨ eq σ ⟩ ⊢ p ↔ σ ⊨ p :=
by { split ; intro h,
     { apply h.apply σ, exact rfl },
     { constructor, intros _ h', cases h', assumption } }

@[simp, predicate]
lemma models_prop {p : Prop} (σ : α)
: σ ⊨ ↑p ↔ p :=
by refl

@[simp, predicate]
lemma models_lifted₀ {p : Prop} (σ : α)
: σ ⊨ lifted₀ p ↔ p :=
by refl

@[simp, predicate]
lemma models_pred {p : α → β} (σ : α)
: σ ⊨ ⟨ p ⟩ = p σ :=
by refl

@[extensionality, priority 0]
lemma var_ext_sem {p q : var α β}
  (h : ∀ σ, p.apply σ = q.apply σ)
: p = q :=
begin
  cases p, cases q,
  congr, funext y,
  simp with predicate at h,
  rw h
end

@[extensionality]
lemma pred_ext_sem {p q : pred' α}
  (h : ∀ σ, σ ⊨ p ↔ σ ⊨ q)
: p = q :=
begin
  apply var_ext_sem, simp [h]
end

lemma pred_ext {p q : pred' α}
  (h : ∀ Γ, Γ ⊢ p ↔ Γ ⊢ q)
: p = q :=
begin
  cases p, cases q,
  congr, funext y,
  specialize h ⟨eq y⟩,
  simp with predicate at h,
  rw h,
end

lemma entails_of_pointwise {p q : pred' β}
  (h : ∀ σ, σ ⊨ p → σ ⊨ q)
: p ⟹ q :=
begin
  intros _, constructor, introv h',
  apply h,
end

lemma entails_of_forall_impl {p q : pred' β}
  (h : p ⟹ q)
: ∀ i, i ⊨ p ⟶ q :=
by { intros i hp, apply (h ⟨eq i⟩).apply i rfl hp, }

lemma ew_str {p : pred' β}
: ⊩ p → ∀ x, x ⊨ p :=
by { intros h _, apply (h ⟨eq x⟩).apply _ rfl }

lemma ew_wk {p : pred' β}
: (∀ x, x ⊨ p) → ⊩ p :=
by { intros h Γ, constructor,
     intros, apply h }

lemma ew_wk' {Γ p : pred' β}
: (∀ x, x ⊨ Γ → x ⊨ p) → Γ ⊢ p :=
by { intros h, constructor, apply h }

lemma judgement_sem {Γ p : pred' β}
: Γ ⊢ p → (∀ x, x ⊨ Γ → x ⊨ p) :=
by { intros h σ hΓ, apply h.apply _ hΓ }

section
open interactive interactive.types lean lean.parser
     tactic tactic.interactive (simp dsimp unfold_coes)
local postfix `?`:9001 := optional
local postfix *:9001 := many
meta def using_idents := (tk "using" *> ident*) <|> pure []

meta def lifted_asm (v Γ : expr)
  (rs : parse simp_arg_list)
  (h : name) : tactic unit :=
do h' ← get_local h,
   p ← to_expr ``(p_imp_sem  %%h' %%v %%Γ)
     <|> to_expr ``(judgement_sem %%h' %%v %%Γ)
     <|> to_expr ``(ew_str  %%h' %%v)
     <|> fail format!"assumtion {h} should be `⊩ p` or `p ⟹ q` or `Γ ⊢ p ⟶ q`",
   h ← note h none p,
   let l := loc.ns [some h.local_pp_name],
   try $ unfold_coes l,
   try $ simp none ff rs [] l,
   try (clear h')

meta def keep_flag := (tt <$ tk "keep") <|> pure ff
precedence `keep`:0

meta def lifted_pred
   (keep_Γ : parse keep_flag)
   (no_dflt : parse only_flag)
   (rs : parse simp_arg_list)
   (hs : parse using_idents) : tactic unit :=
do b ← tt <$ `[apply p_imp_ext _]
     <|> ff <$ `[apply pred_ext_sem]
     <|> ff <$ `[apply var_ext_sem]
     <|> tt <$ `[apply ew_wk' _]
     <|> ff <$ `[apply ew_wk _],
   v ← intro1,
   hΓ ← if b then intro1 else return (default _),
   mmap' (lifted_asm v hΓ rs) (hs : list _),
   when (b ∧ ¬ keep_Γ) $ clear hΓ,
   try (simp none no_dflt rs [`predicate] (loc.ns [none])),
   try (dsimp no_dflt rs [`predicate] (loc.ns [none])),
   try `[unfold_coes],
   try reflexivity
run_cmd add_interactive [`lifted_pred]
end

@[simp, predicate]
lemma value_coe_comp (x : α) (v : var β γ)
: (x : var γ α) ! v = (x : var β α) :=
by lifted_pred

@[simp, predicate]
lemma True_comp (v : var β γ)
: True ! v = True :=
by lifted_pred

@[simp, predicate]
lemma False_comp (v : var β γ)
: False ! v = False :=
by lifted_pred

@[simp]
lemma proj_assoc (x : var α β) (y : var β γ) (z : var γ σ)
: (z ! y) ! x = z ! (y ! x) :=
by lifted_pred

@[simp]
lemma p_and_comp (p q : pred' α) (f : var β α)
: ((p ⋀ q) ! f) = (p ! f) ⋀ (q ! f) :=
by lifted_pred

@[simp]
lemma const_over_comp (p : γ) (v : var β α)
: (p : var α γ) ! v = ↑p :=
by lifted_pred

@[predicate]
lemma coe_over_comp' (p : α → γ) (f : β → α)
: ⟨ p ⟩ ! ⟨ f ⟩ = ⟨ p ∘ f ⟩ :=
by lifted_pred

-- @[simp]
lemma coe_over_comp (p : α → γ) (f : β → α)
: (⟨ p ∘ f ⟩ : var _ _) = ⟨ p ⟩ ! ⟨ f ⟩ :=
by lifted_pred

@[simp]
lemma p_or_comp (p q : pred' α) (f : var β α)
: ((p ⋁ q) ! f) = (p ! f) ⋁ (q ! f) :=
by lifted_pred

@[simp, predicate]
lemma eq_comp (p q : var α γ) (f : var β α)
: ((p ≃ q) ! f) = (p ! f) ≃ (q ! f) :=
by lifted_pred

@[simp, predicate]
lemma wf_comp {_ : has_well_founded γ} (p q : var α γ) (f : var β α)
: ((p ≺≺ q) ! f) = (p ! f) ≺≺ (q ! f) :=
by lifted_pred

@[simp, predicate]
lemma lt_comp {γ : Type _} [has_lt γ] (p q : var α γ) (f : var β α)
: ((p ≺ q) ! f) = ((p ! f) ≺ (q ! f)) :=
by lifted_pred

@[simp, predicate]
lemma mem_comp {α γ} [has_mem α γ] (p : var σ α) (q : var σ γ) (f : var β σ)
: ((p ∊ q) ! f) = ((p ! f) ∊ (q ! f)) :=
by lifted_pred

@[simp, predicate]
lemma coe_apply (v : var α β)
: (⟨ v.apply ⟩ : var _ _) = v :=
by lifted_pred

@[simp, predicate]
lemma p_exists_comp {t} (p : t → pred' α) (f : var β α)
: (p_exists p ! f) = (∃∃ x, p x ! f) :=
by lifted_pred [p_exists]

@[simp]
lemma coe_to_prop_p_and (p q : α → Prop)
: (⟨λ s, p s ∧ q s⟩ : pred' α) = ⟨p⟩ ⋀ ⟨q⟩ := rfl

@[simp]
lemma coe_to_prop_p_or (p q : α → Prop)
: (⟨λ s, p s ∨ q s⟩ : pred' α) = ⟨p⟩ ⋁ ⟨q⟩ := rfl

@[simp]
lemma coe_to_prop_p_not (p : α → Prop)
: (⟨λ s, ¬ p s⟩ : pred' α) = - ⟨p⟩ := rfl

@[simp]
lemma coe_to_prop_p_equiv (p q : α → Prop)
: (⟨λ s, p s ↔ q s⟩ : pred' α) = ⟨p⟩ ≡ ⟨q⟩ :=
by { ext, simp }

lemma lifting_prop_asm (Γ : pred' α) {p : Prop} {q : pred' α}
  (h : p → Γ ⊢ q)
: Γ ⊢ p → Γ ⊢ q :=
begin
  intro h₁,
  constructor,
  introv h₂,
  have h₃ := h₁.apply _ h₂,
  apply (h h₃).apply _ h₂,
end

@[simp, predicate]
lemma p_not_to_fun (p₀ : pred' α) (x : α)
: x ⊨ (- p₀) ↔ ¬ x ⊨ p₀ := by { refl, }

lemma p_not_eq_not (p : pred' β) (x : β) : ¬ x ⊨ p ↔ x ⊨ (-p) :=
by refl

@[simp]
lemma p_not_True : (- True : pred' α) = (False) :=
by lifted_pred

@[simp]
lemma p_not_False : (- False : pred' α) = True :=
by lifted_pred

-- @[simp]
-- lemma entails_True (p q : pred' α)
-- : p ⟹ q ↔ (∀ h, h ⟹ p → h ⟹ q) :=
-- begin
--   split ; intro h,
--   { intros h₀ h₁, },
-- end

@[simp]
lemma entails_True (p : pred' α)
: p ⟹ True :=
by lifted_pred

@[simp]
lemma True_p_and (p : pred' α)
: True ⋀ p = p :=
by lifted_pred

@[simp]
lemma p_and_True (p : pred' α)
: p ⋀ True = p :=
by lifted_pred

@[simp]
lemma True_p_or (p : pred' α)
: True ⋁ p = True :=
by lifted_pred

@[simp]
lemma p_or_False (p : pred' α)
: p ⋁ False = p :=
by lifted_pred

@[simp]
lemma False_p_or (p : pred' α)
: False ⋁ p = p :=
by lifted_pred

@[refl]
lemma entails_refl (p : pred' β)
: p ⟹ p :=
by lifted_pred

@[refl]
lemma ctx_impl_refl (Γ p : pred' β)
: ctx_impl Γ p p :=
by lifted_pred

lemma p_impl_refl (Γ p : pred' β)
: Γ ⊢ p ⟶ p :=
by lifted_pred

@[simp,predicate]
lemma p_impl_refl_eq_True (p : pred' β)
: p ⟶ p = True :=
by lifted_pred

@[refl]
lemma v_eq_refl (Γ : pred' β) (v : var β α)
: Γ ⊢ v ≃ v :=
by lifted_pred

lemma v_eq_symm {Γ : pred' β} {v₀ v₁ : var β α}
  (h : Γ ⊢ v₁ ≃ v₀)
: Γ ⊢ v₀ ≃ v₁ :=
by lifted_pred using h ; rw h

@[mono]
lemma ctx_p_or_p_imp_p_or' {Γ p p' q q' : pred' α}
  (hp : ctx_impl Γ p p')
  (hq : ctx_impl Γ q q')
: ctx_impl Γ (p ⋁ q) (p' ⋁ q')  :=
by { lifted_pred using hp hq,
     begin [smt] intros, destruct a end, }

@[mono]
lemma p_or_p_imp_p_or' {p p' q q' : pred' α}
  (hp : p ⟹ p')
  (hq : q ⟹ q')
: (p ⋁ q)  ⟹  (p' ⋁ q')  :=
by { lifted_pred using hp hq,
     apply or.imp hp hq, }

@[mono]
lemma p_and_p_imp_p_and' {p p' q q' : pred' α}
  (hp : p ⟹ p')
  (hq : q ⟹ q')
: (p ⋀ q)  ⟹  (p' ⋀ q')  :=
by { lifted_pred only using hp hq,
     apply and.imp hp hq, }

lemma p_or_p_imp_p_or {p p' q q' : pred' α} {τ}
  (hp : τ ⊨ p ⟶ p')
  (hq : τ ⊨ q ⟶ q')
: τ ⊨ p ⋁ q → τ ⊨ p' ⋁ q' :=
by apply or.imp hp hq

@[mono]
lemma ctx_p_and_p_imp_p_and_right' {Γ p p' q q' : pred' α}
  (hp : ctx_impl Γ p p')
  (hq : ctx_impl Γ q q')
: ctx_impl Γ ( p ⋀ q ) ( p' ⋀ q' ) :=
by { lifted_pred using hp hq, intros, tauto }

lemma ctx_p_and_p_imp_p_and' {Γ p p' q q' : pred' α}
  (hp : ctx_impl Γ p p')
  (hq : ctx_impl Γ q q')
: ctx_impl Γ (p ⋀ q) (p' ⋀ q')  :=
by { lifted_pred using hp hq,
     begin [smt] intros end, }

lemma p_or_p_imp_p_or_right {p q q' : pred' α} {τ}
  (hq : τ ⊨ q ⟶ q')
: τ ⊨ p ⋁ q → τ ⊨ p ⋁ q' :=
by apply or.imp id hq

lemma p_or_p_imp_p_or_left {p p' q : pred' α} {τ}
  (hp : τ ⊨ p ⟶ p')
: τ ⊨ p ⋁ q → τ ⊨ p' ⋁ q :=
by apply or.imp hp id

lemma p_imp_p_imp_p_imp {p p' q q' : pred' α} {Γ}
  (hp : Γ ⊢ p' ⟶ p)
  (hq : Γ ⊢ q ⟶ q')
: Γ ⊢ p ⟶ q → Γ ⊢ p' ⟶ q' :=
by { intro h₂, constructor, introv h₀ h₁,
     replace hp := hp.apply _ h₀,
     replace hq := hq.apply _ h₀,
     replace h₂ := h₂.apply _ h₀,
     apply_assumption, solve_by_elim, }

lemma revert_p_imp {p q : pred' α}
  (h : ⊩ p ⟶ q)
: p ⊢ q :=
begin
  constructor, intro,
  exact (h True).apply σ trivial,
end

lemma revert_p_imp' {p q r : pred' α}
  (h : p ⟹ q)
: q ⊢ r → p ⊢ r :=
by { intro h₀, constructor,
     introv h₁, apply h₀.apply,
     apply (h p).apply _ h₁ h₁, }

@[simp]
lemma from_True {p : pred' α}
: True ⊢ p ↔ ⊩ p :=
by { unfold holds ; split ; intro h,
     intro, apply revert_p_imp' _ h, simp,
     apply h }

lemma intro_p_imp {p q : pred' α}
  (h : p ⊢ q)
: ⊩ p ⟶ q :=
begin
  intro, constructor, introv h',
  apply h.apply,
end

@[mono]
lemma p_imp_entails_p_imp {p p' q q' : pred' α}
  (hp : p' ⟹ p)
  (hq : q ⟹ q')
: ( p ⟶ q ) ⟹ ( p' ⟶ q' ) :=
by { lifted_pred using hp hq, intros,
     repeat { apply_assumption }, }

lemma p_imp_p_imp_p_imp_left {p p' q : pred' α} {Γ}
  (hp : Γ ⊢ p' ⟶ p)
: Γ ⊢ p ⟶ q → Γ ⊢ p' ⟶ q :=
p_imp_p_imp_p_imp hp (ctx_impl_refl _ _)

lemma p_imp_p_imp_p_imp_right {p q q' : pred' α} {Γ}
  (hq : Γ ⊢ q ⟶ q')
: Γ ⊢ p ⟶ q → Γ ⊢ p ⟶ q' :=
p_imp_p_imp_p_imp (ctx_impl_refl _ _) hq

lemma ctx_imp_entails_p_imp {Γ p p' q q' : pred' α}
  (hp : ctx_impl Γ p' p)
  (hq : ctx_impl Γ q q')
: ctx_impl Γ ( p ⟶ q ) ( p' ⟶ q' ) :=
by { lifted_pred using hp hq, intros, apply_assumption, solve_by_elim }

@[mono]
lemma ctx_imp_entails_p_imp_left {Γ p p' q q' : pred' α}
  (hp : ctx_impl Γ p' p)
  (hq : ctx_impl Γ q  q')
: ctx_impl Γ ( p ⟶ q ) ( p' ⟶ q' ) :=
by { lifted_pred using hp hq, intros, apply_assumption, tauto }

lemma entails_imp_entails_left {p p' q : pred' α}
  (hp : p' ⟹ p)
: ( p ⟹ q ) → ( p' ⟹ q ) :=
begin
  intros h₁ Γ, constructor,
  introv h₂ h₃,
  apply (h₁ Γ).apply _ h₂,
  apply (hp Γ).apply _ h₂ h₃,
end

@[simp]
lemma p_or_self (p : pred' β) :
p ⋁ p = p :=
by lifted_pred

@[simp]
lemma p_not_p_not_iff_self (p : pred' β) :
- - p = p :=
by lifted_pred [not_not_iff_self]

lemma p_not_eq_iff_eq_p_not (p q : pred' β) :
- p = q ↔ p = - q :=
by { split ; intro h,
     rw [← h,p_not_p_not_iff_self],
     rw [h,p_not_p_not_iff_self], }

@[simp]
lemma p_not_eq_p_not_iff_eq (p q : pred' β) :
- p = - q ↔ p = q :=
by simp [p_not_eq_iff_eq_p_not]

lemma p_and_over_or_left (p q r : pred' β)
: p ⋀ (q ⋁ r) = (p ⋀ q) ⋁ (p ⋀ r) :=
begin
  lifted_pred, split,
  { begin [smt] intros, eblast end },
  { begin [smt] intros, destruct a end },
end

lemma p_and_over_or_right (p q r : pred' β)
: (q ⋁ r) ⋀ p = (q ⋀ p) ⋁ (r ⋀ p) :=
begin
  lifted_pred, split,
  { begin [smt] intros, eblast end },
  { begin [smt] intros, destruct a end },
end

instance : is_left_distrib (pred' β) (⋀) (⋁) :=
⟨ p_and_over_or_left ⟩
instance : is_right_distrib (pred' β) (⋀) (⋁) :=
⟨ by { intros, apply p_and_over_or_right } ⟩
instance : is_left_id (pred' β) (⋀) True :=
⟨ by simp ⟩
instance : is_right_id (pred' β) (⋀) True :=
⟨ by simp ⟩
instance or_left_id : is_left_id (pred' β) (⋁) False :=
⟨ by simp ⟩
instance or_right_id : is_right_id (pred' β) (⋁) False :=
⟨ by simp ⟩

lemma p_or_over_and_left (p q r : pred' β)
: p ⋁ (q ⋀ r) = (p ⋁ q) ⋀ (p ⋁ r) :=
begin
  lifted_pred, split,
  { begin [smt] intros, destruct a end },
  { begin [smt] intros, destruct a.left, end },
end

lemma p_or_over_and_right (p q r : pred' β)
: (q ⋀ r) ⋁ p = (q ⋁ p) ⋀ (r ⋁ p) :=
by { lifted_pred [distrib_left_or] }

instance is_left_distrib_or_and : is_left_distrib (pred' β) (⋁) (⋀) :=
⟨ p_or_over_and_left ⟩
instance is_right_distrib_or_and : is_right_distrib (pred' β) (⋁) (⋀) :=
⟨ by { intros, apply p_or_over_and_right } ⟩

lemma mutual_p_imp {Γ p q : pred' β}
  (h₀ : Γ ⊢ p ⟶ q)
  (h₁ : Γ ⊢ q ⟶ p)
: Γ ⊢ p ≡ q :=
begin
  lifted_pred using h₀ h₁,
  split ; assumption,
end

lemma mutual_entails {p q : pred' β}
  (h₀ : p ⟹ q)
  (h₁ : q ⟹ p)
: p = q :=
begin
  lifted_pred using h₀ h₁,
  split ; assumption,
end

@[simp]
lemma False_entails (p : pred' β)
: False ⟹ p :=
by lifted_pred

@[simp]
lemma p_imp_False (p : pred' β)
: p ⟶ False = -p :=
by lifted_pred

lemma p_and_p_not_self (p : pred' β)
: p ⋀ -p = False :=
by lifted_pred

@[simp]
lemma p_or_p_not_self (p : pred' β)
: p ⋁ -p = True :=
by lifted_pred [classical.em]

lemma em (p : pred' β)
: ⊩ p ⋁ -p :=
by lifted_pred [classical.em]

lemma p_and_p_or_p_not_self (p q : pred' β)
: p ⋀ (q ⋁ -p) = p ⋀ q :=
by simp [p_and_over_or_left,p_and_p_not_self]

lemma p_not_and_self (p : pred' β)
: (-p) ⋀ p = False :=
by lifted_pred

lemma p_not_p_and (p q : pred' β)
: - (p ⋀ q) = -p ⋁ -q :=
by lifted_pred [classical.not_and_iff_not_or_not]

lemma p_not_p_or (p q : pred' β)
: - (p ⋁ q) = -p ⋀ -q :=
by lifted_pred [not_or_iff_not_and_not]

lemma p_not_and_self_or (p q : pred' β) :
- p ⋀ (p ⋁ q) = -p ⋀ q :=
by rw [p_and_over_or_left,p_not_and_self,False_p_or]

@[simp, predicate]
lemma p_exists_apply {t : Sort u'} {P : t → pred' β} (σ : β)
: σ ⊨ (∃∃ x, P x) ↔ (∃ x, σ ⊨ P x) :=
by { unfold p_exists }

lemma p_exists_to_fun {t : Sort u'} {h : pred' β} {P : t → pred' β}
  (x : t)
  (Hh : h ⊢ P x)
: h ⊢ (∃∃ x, P x) :=
by { constructor, intros _ h', existsi x,
     apply Hh.apply _ h', }

@[simp, predicate]
lemma models_p_forall {t : Sort u'} (P : t → pred' β) (σ : β)
: σ ⊨ (∀∀ x, P x) ↔ (∀ x, σ ⊨ P x) := by refl

lemma p_forall_to_fun {t : Sort u'} (h : pred' β) (P : t → pred' β)
: h ⊢ (∀∀ x, P x) ↔ (∀ x, h ⊢ P x) :=
begin
  split ; intro h,
  { intro, constructor, intros,
    cases h with h,
    apply h σ a, },
  { constructor,
    introv h' x,
    apply (h x).apply _ h', }
end

lemma p_forall_subtype_to_fun {t : Sort u'} (h : pred' β) (p : t → Prop) (q : t → pred' β)
: h ⊢ (∀∀ x, p x ⟶ q x) ↔ (∀ x, p x → h ⊢ q x) :=
begin
  split,
  { intros h x hp, apply h x hp },
  { intros h,
    constructor,
    introv hσ x hp,
    apply (h x hp).apply _ hσ, }
end

lemma ew_p_forall {t} (p : t → pred' β)
: ⊩ (∀∀ x, p x) ↔ ∀ x, ⊩ p x :=
by { simp only [holds,forall_swap] { single_pass := tt },
     apply forall_congr, intro,
     apply p_forall_to_fun }

lemma p_not_p_exists {t : Sort*} (p : t → pred' β) :
(- ∃∃ x, p x) = (∀∀ x, -p x) :=
by lifted_pred [not_exists_iff_forall_not,p_exists]

lemma p_not_p_forall {t : Sort*} (p : t → pred' β) :
(- ∀∀ x, p x) = (∃∃ x, -p x) :=
by { rw [p_not_eq_iff_eq_p_not,p_not_p_exists], simp [p_not_p_not_iff_self] }

lemma p_exists_p_imp {t} (p : t → pred' β) (q : pred' β)
: (∃∃ x, p x) ⟶ q = (∀∀ x, p x ⟶ q) :=
by lifted_pred [p_exists]

lemma p_or_comm (p q : pred' β) : p ⋁ q = q ⋁ p :=
by lifted_pred [or_comm]

lemma p_or_assoc (p q r : pred' β) : p ⋁ (q ⋁ r) = p ⋁ q ⋁ r :=
by lifted_pred [or_assoc]

instance p_or_is_assoc : is_associative (pred' β) (⋁) :=
⟨ by { intros, rw p_or_assoc, } ⟩
instance p_or_is_comm : is_commutative (pred' β) (⋁) :=
⟨ by apply p_or_comm ⟩

lemma p_and_comm (p q : pred' β) : p ⋀ q = q ⋀ p :=
by lifted_pred [and_comm]

lemma p_and_assoc (p q r : pred' β) : p ⋀ (q ⋀ r) = p ⋀ q ⋀ r :=
by lifted_pred [and_assoc]

instance p_and_is_assoc : is_associative (pred' β) (⋀) :=
⟨ by { intros, rw p_and_assoc, } ⟩
instance p_and_is_comm : is_commutative (pred' β) (⋀) :=
⟨ by apply p_and_comm ⟩

@[simp]
lemma p_and_p_imp (p q r : pred' β) : p ⋀ q ⟶ r = p ⟶ (q ⟶ r) :=
by lifted_pred

-- lemma p_imp_intro_wrong (Γ p q : pred' β)
--   (h : Γ ⊢ p → Γ ⊢ q)
-- : Γ ⊢ p ⟶ q :=
-- sorry

lemma p_imp_intro (p q r : pred' β)
  (h : ∀ Γ, Γ ⊢ p → Γ ⊢ q → Γ ⊢ r)
  (Γ : pred' β)
  (h' : Γ ⊢ p)
: Γ ⊢ q ⟶ r :=
begin
  constructor, introv hΓ hq,
  apply (h ⟨eq σ⟩ _ _).apply _ rfl ;
  constructor
  ; intros _ h
  ; cases h,
  { apply h'.apply _ hΓ },
  assumption
end

@[simp]
lemma p_or_intro_left (p q : pred' β)
: p ⟹ p ⋁ q :=
by { lifted_pred,
     begin [smt] intros end }

@[simp]
lemma p_or_intro_right (p q : pred' β)
: q ⟹ p ⋁ q :=
by { lifted_pred,
     begin [smt] intros end }

@[simp]
lemma p_and_intro (p q : pred' β)
: p ⟹ (q ⟶ p ⋀ q) :=
by { lifted_pred,
     begin [smt] intros end }

lemma p_or_entails_of_entails' {Γ p q r : pred' β}
  (h₀ : Γ ⊢ p ⟶ r)
  (h₁ : Γ ⊢ q ⟶ r)
: Γ ⊢ p ⋁ q ⟶ r :=
by { constructor, simp_intros _ hΓ _,
     have h₀ := h₀.apply σ hΓ, simp at h₀,
     have h₁ := h₁.apply σ hΓ, simp at h₁,
     begin [smt] intros, destruct a, end }

lemma p_or_entails_of_entails {p q r : pred' β}
  (h₀ : p ⟹ r)
  (h₁ : q ⟹ r)
: p ⋁ q ⟹ r :=
by { lifted_pred using h₀ h₁,
     begin [smt] intros, destruct a end }

lemma entails_p_or_of_entails_left {p q r : pred' β}
  (h₀ : p ⟹ q)
: p ⟹ q ⋁ r :=
by { lifted_pred using h₀,
     begin [smt] intros end }

lemma entails_p_or_of_entails_right {p q r : pred' β}
  (h₀ : p ⟹ r)
: p ⟹ q ⋁ r :=
by { lifted_pred using h₀,
     begin [smt] intros end }

lemma entails_p_and_of_entails {p q r : pred' β}
  (h₀ : p ⟹ q)
  (h₁ : p ⟹ r)
: p ⟹ q ⋀ r :=
by { lifted_pred using h₀ h₁,
     begin [smt] intros end }

lemma p_and_entails_of_entails_left {p q r : pred' β}
  (h₁ : p ⟹ r)
: p ⋀ q ⟹ r :=
by { lifted_pred using h₁,
     begin [smt] intros end }

lemma p_and_entails_of_entails_right {p q r : pred' β}
  (h₁ : q ⟹ r)
: p ⋀ q ⟹ r :=
by { lifted_pred using h₁,
     begin [smt] intros end }

@[simp]
lemma p_and_elim_left (p q : pred' β)
: p ⋀ q ⟹ p :=
by { lifted_pred,
     begin [smt] intros end }

@[simp]
lemma p_and_elim_right (p q : pred' β)
: p ⋀ q ⟹ q :=
by lifted_pred

lemma judgement.left {Γ p q : pred' β}
  (h : Γ ⊢ p ⋀ q)
: Γ ⊢ p :=
p_and_elim_left p q Γ h

lemma judgement.right {Γ p q : pred' β}
  (h : Γ ⊢ p ⋀ q)
: Γ ⊢ q :=
p_and_elim_right p q Γ h

lemma p_imp_trans {Γ p q r : pred' β}
  (h₀ : Γ ⊢ p ⟶ q)
  (h₁ : Γ ⊢ q ⟶ r)
: Γ ⊢ p ⟶ r :=
begin
  lifted_pred using h₀ h₁,
  intros,
  solve_by_elim,
end

@[trans]
lemma entails_trans {p q r : pred' β}
  (h₀ : p ⟹ q)
  (h₁ : q ⟹ r)
: p ⟹ r :=
begin
  lifted_pred using h₀ h₁,
  intro, solve_by_elim,
end

@[simp]
lemma p_not_comp' (p : pred' α) (f : var β α)
: -p ! f = -(p ! f) :=
by lifted_pred

lemma p_not_comp (p : pred' α) (f : var β α)
: -(p ! f) = -p ! f :=
by lifted_pred

@[mono]
lemma comp_entails_comp {p q : pred' β} (f : var α β)
  (H : p ⟹ q)
: p ! f ⟹ q ! f :=
begin
  intros Γ, constructor,
  introv h hp,
  simp at ⊢ hp,
  specialize H ⟨eq $ f.apply σ⟩,
  apply H.apply (f.apply σ) rfl hp,
end

@[mono]
lemma ctx_comp_imp_comp {Γ : pred' α} {p q : pred' β} (f : var α β)
  (H : p ⟹ q)
: ctx_impl Γ (p ! f) (q ! f) :=
by apply comp_entails_comp _ H

@[mono]
lemma ctx_p_not_entails_p_not_right {Γ p q : pred' β}
  (h : ctx_impl Γ q p)
: ctx_impl Γ (- p) (- q) :=
by { lifted_pred using h,
     begin [smt] intros end }

@[mono]
lemma p_not_entails_p_not_right {p q : pred' β}
  (h : q ⟹ p)
: - p ⟹ - q :=
by { lifted_pred using h,
     begin [smt] intros end }

lemma entails_of_eq (p q : pred' β)
  (h : p = q)
: p ⟹ q :=
by simp [h]

lemma p_imp_of_equiv {Γ : pred' β} (p q : pred' β)
  (h : Γ ⊢ p ≡ q)
: Γ ⊢ p ⟶ q :=
by lifted_pred using h ; simp [h]

lemma equiv_of_eq (Γ p q : pred' β)
  (h : p = q)
: Γ ⊢ p ≡ q :=
by { cases p, cases q, simp [h] }

lemma p_and_entails_p_or (p q : pred' β)
: p ⋀ q ⟹ p ⋁ q :=
by { lifted_pred,
     begin [smt] intros end }

@[simp]
lemma True_p_imp (p : pred' β)
: True ⟶ p = p :=
by lifted_pred

@[simp]
lemma p_imp_True (p : pred' β)
: p ⟶ True = True :=
by lifted_pred

@[simp]
lemma p_forall_True
: (∀∀ x : α, @True β) = True :=
by lifted_pred

@[simp]
lemma p_exists_True [nonempty α]
: (∃∃ x : α, @True β) = True :=
by { lifted_pred, apply classical.exists_true_of_nonempty, apply_instance }

lemma ew_eq_true {p : pred' β} : ⊩ p → p = True :=
by { intro h, lifted_pred using h,
     begin [smt] intros end }

@[mono, priority 0]
lemma ew_imp_ew {p q : pred' β}
  (H : p ⟹ q)
: ⊩ p → ⊩ q :=
by { intros hp, lifted_pred using hp H, solve_by_elim }

lemma entails_to_pointwise {p q : pred' β}
  (h : p ⟹ q)
: ∀ i, i ⊨ p → i ⊨ q :=
by { intros i h', apply (h ⟨eq i⟩).apply i rfl h' }

lemma impl_of_p_impl {p q : pred' β} (i : β)
  (h : ⊩ p ⟶ q)
: i ⊨ p → i ⊨ q :=
entails_of_forall_impl h _

open interactive.types interactive
open lean.parser lean tactic (hiding funext)
meta def entails_or_ew {α : Type u} (t : expr) (tag : string)
   (ent_tac ew_tac : tactic α) : tactic α :=
do match t with
    | `(_ ⟹ _) := ew_tac
    | `(_ ⊢ _) := ent_tac
    | `(⊩ _) := ew_tac
    | _ := fail format!"expecting {tag} of shape `_ ⟹ _` or `⊩ _`"
   end

meta def pointwise (h : parse (many ident)) (ids : parse with_ident_list) : tactic unit :=
do t ← target,
   try $ entails_or_ew t "goal" `[refine revert_p_imp _,refine ew_wk _] `[refine ew_wk _],
   tactic.intro_lst ids,
   ls ← mmap get_local h,
   mmap' (λ l : expr,
    do entails_or_ew t "goal" (to_expr ``(ew_str (intro_p_imp %%l)))
                              (to_expr ``(ew_str %%l))
           >>= note l.local_pp_name none,
       try (clear l)) ls

run_cmd add_interactive [`pointwise]

lemma p_or_over_p_exists_left {t} (p : t → pred' β) (q : pred' β) {w : t → pred' β}
  (h : ⊩ ∃∃ x : t, w x)
: q ⋁ (∃∃ x, p x) = (∃∃ x, q ⋁ p x) :=
begin
  lifted_pred,
  have h := (h ⟨eq σ⟩).apply _ rfl,
  have _inst : nonempty t := nonempty_of_exists h, resetI,
  simp [distrib_or_over_exists_left,p_exists],
end

@[congr]
lemma {v} p_exists_congr {α : Sort u} {β : Sort v} {p q : α → pred' β}
  (h : ∀ i, p i = q i)
: p_exists p = p_exists q :=
begin
  lifted_pred [p_exists],
  rw [exists_congr],
  intro, rw h,
end

lemma p_and_over_p_exists_right {t} (p : t → pred' β) (q : pred' β)
: (∃∃ x, p x) ⋀ q = (∃∃ x, p x ⋀ q) :=
by lifted_pred only [iff_self, exists_and_distrib_right]

lemma p_and_over_p_exists_left {t} (p : pred' β) (q : t → pred' β)
: p ⋀ (∃∃ x, q x) = (∃∃ x, p ⋀ q x) :=
begin
  rw [p_and_comm,p_and_over_p_exists_right],
  apply p_exists_congr,
  intro, simp [p_and_comm]
end

lemma shunting {β : Sort*} (p q r : pred' β)
: p ⟶ q ⋁ r = (p ⋀ - q) ⟶ r :=
begin
  lifted_pred,
  begin [smt] split, all_goals { intros },
              by_cases (q.apply σ),
  end,
end

lemma shunting' {β : Sort*} (p q r : pred' β)
: p ⟶ (q ⟶ r) = (p ⋀ q) ⟶ r :=
by lifted_pred

lemma imp_swap {β : Sort*} (p q r : pred' β)
: p ⟶ (q ⟶ r) = q ⟶ (p ⟶ r) :=
by { lifted_pred,
     begin [smt] split, all_goals { intros }, end }

lemma entails_swap {β : Sort*} (p q r : pred' β)
: p ⟹ (q ⟶ r) ↔ q ⟹ (p ⟶ r) :=
by simp [p_entails,imp_swap]
-- ◻◇p ⊢ ◻◇q τ
-- `τ : stream σ, h : (◻◇p) τ ⊢ (◻◇q) τ`
lemma p_not_p_imp {β : Sort*} (p q : pred' β)
: (-p) ⟶ q = p ⋁ q :=
by rw [← True_p_and (-p),← shunting,True_p_imp]

lemma p_imp_iff_p_not_p_or {β : Sort*} (p q : pred' β)
: p ⟶ q = -p ⋁ q :=
by rw [← p_not_p_imp,p_not_p_not_iff_self]

lemma p_or_not_and {β : Sort*} (p q : pred' β)
: p ⋁ (- p ⋀ q) = p ⋁ q :=
begin
  lifted_pred,
  begin [smt]
    split,
    all_goals { intros h }, destruct h,
    by_cases (p.apply σ)
  end
end

lemma p_exists_intro {t : Sort u'} {p : t → pred' β} (x : t)
: p x ⟹ (∃∃ x, p x) :=
by { lifted_pred, apply exists.intro x, }

lemma p_exists_elim {t : Sort u'} {p : t → pred' β} {q : pred' β}
  (H : ∀ x, p x ⟹ q)
: (∃∃ x, p x) ⟹ q :=
begin
  pointwise with σ,
  simp, intro,
  apply entails_to_pointwise (H x) σ,
end

lemma p_forall_p_imp_p_forall {Γ : pred' β} {t : Sort u'} (p q : t → pred' β)
: Γ ⊢ (∀∀ x, p x ⟶ q x) → Γ ⊢ (∀∀ x, p x) ⟶ (∀∀ x, q x) :=
begin
  intros h,
  lifted_pred [- exists_imp_distrib] using h,
  apply forall_imp_forall,
  intro x,
  apply h,
end

lemma p_exists_p_imp_p_exists {Γ : pred' β} {t : Sort u'} (p q : t → pred' β)
: Γ ⊢ (∀∀ x, p x ⟶ q x) → Γ ⊢ (∃∃ x, p x) ⟶ (∃∃ x, q x) :=
begin
  intros h,
  lifted_pred [- exists_imp_distrib] using h,
  apply exists_imp_exists,
  intro x,
  apply h,
end

lemma p_exists_entails_p_exists {t : Sort u'} (p q : t → pred' β)
: (∀ x, p x ⟹ q x) → (∃∃ x, p x) ⟹ (∃∃ x, q x) :=
begin
  intros h _,
  apply p_exists_p_imp_p_exists,
  constructor, introv h' x,
  apply (h x Γ).apply _ h'
end

lemma p_exists_over_p_or {t} (p q : t → pred' β)
: (∃∃ x, p x) ⋁ (∃∃ x, q x) = (∃∃ x, p x ⋁ q x) :=
begin
  lifted_pred, split ; simp_intros
  ; cases a with a_1 a_1 ; revert a_1,
  { apply exists_imp_exists, intro, apply or.intro_left, },
  { apply exists_imp_exists, intro, apply or.intro_right, },
  apply or.imp ; apply Exists.intro a_1,
end

@[simp]
lemma p_exists_imp_eq_p_forall_imp
  (p : α → pred' β) (q : pred' β)
: ((∃∃ x, p x) ⟶ q) = (∀∀ x, p x ⟶ q) :=
by lifted_pred

lemma p_exists_entails_eq_p_forall_entails
  (p : α → pred' β) (q : pred' β)
: ((∃∃ x, p x) ⟹ q) ↔ (∀ x, p x ⟹ q) :=
by simp [p_entails,p_exists_imp_eq_p_forall_imp,ew_p_forall]

lemma p_exists_imp_p_exists' {t : Sort u₀} {t' : Sort u₂}
  {Γ : pred' β}
  (p : t → pred' β)
  (q : t' → pred' β)
  (f : t → t')
  (h : Γ ⊢ (∀∀ x, p x ⟶ q (f x)))
: Γ ⊢ (∃∃ x, p x) ⟶ (∃∃ x, q x) :=
begin
  intros,
  lifted_pred keep [- exists_imp_distrib],
  apply exists_imp_exists' f _ ,
  intro x,
  apply (h.apply _ a),
end

lemma p_exists_entails_p_exists' {t : Sort u₀} {t' : Sort u₂}
  (p : t → pred' β)
  (q : t' → pred' β)
  (f : t → t')
  (h : (∀ x, p x ⟹ q (f x)))
: (∃∃ x, p x) ⟹ (∃∃ x, q x) :=
begin
  intro,
  apply p_exists_imp_p_exists' _ _ f,
  apply (ew_p_forall _).mpr h,
end

lemma p_exists_variable_change
  (p : α → pred' β) (q : γ → pred' β)
  (f : α → γ)
  (g : γ → α)
  (Hf : ∀ i, p i ⟹ q (f i))
  (Hg : ∀ j, q j ⟹ p (g j))
: (∃∃ i, p i) = (∃∃ j, q j) :=
begin
  lifted_pred [- exists_imp_distrib],
  rw exists_variable_change _ _ f g
  ; intro x
  ; apply entails_to_pointwise
  ; solve_by_elim,
end

lemma p_exists_partial_intro {t : Sort u₀} {t' : Sort u₂}
  (p : t → pred' β)
  (f : t' → t)
: (∃∃ x, p (f x)) ⟹ (∃∃ x, p x) :=
begin
  intro, apply p_exists_imp_p_exists' _ _ f,
  lifted_pred,
end

lemma p_exists_range_subtype {α : Sort u}
  (p : α → Prop) (q : α → pred' β)
: (∃∃ i, p i ⋀ q i : pred' β) = (∃∃ j : subtype p, q (j.val)) :=
by lifted_pred

lemma p_or_iff_not_imp (p q : pred' β)
: p ⋁ q = - p ⟶ q :=
begin
  lifted_pred,
  simp [or_iff_not_imp],
end

lemma p_forall_fin_zero (p : fin 0 → pred' β)
: (∀∀ i, p i) = True :=
begin
  lifted_pred,
  simp [forall_fin_zero_iff_true],
end

lemma p_forall_split_one {n : ℕ} (p : fin (nat.succ n) → pred' β)
: (∀∀ i, p i) = p fin.max ⋀ (∀∀ i, restr p i) :=
begin
  lifted_pred,
  simp [forall_split_one],
  refl,
end

lemma p_exists_split_one {n : ℕ} (p : fin (nat.succ n) → pred' β)
: (∃∃ i, p i) = p fin.max ⋁ (∃∃ i, restr p i) :=
begin
  lifted_pred,
  simp [exists_split_one],
  refl,
end

@[simp]
lemma whole_v_eq_prj (x : var α α) (y : var γ α)
: (whole ≃ x) ! y = y ≃ (x ! y) :=
by lifted_pred

@[simp]
lemma models_whole (s : σ)
: s ⊨ whole = s := rfl

instance entails_category {α} : category (@p_entails α) :=
  { ident := by { intro, refl }
  , comp  := by { intros, apply entails_trans ; assumption }
  , assoc := by { intros, refl }
  , left_ident  := by { intros, refl }
  , right_ident := by { intros, refl } }

end predicate


/-
Copyright (c) 2022 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang
-/
import morphisms.open_immersion
import morphisms.closed_immersion
import for_mathlib.locally_closed
import morphisms.integral

/-!

# Locally closed immersions

A morphism of schemes is a closed immersion if the underlying map is a closed embedding, and
the sheaf map is locally surjective.

-/

noncomputable theory

open category_theory category_theory.limits opposite topological_space

universe u

namespace algebraic_geometry

variables {X Y Z : Scheme.{u}} (f : X ⟶ Y) (g : Y ⟶ Z)

/-- A morphism is a `is_closed_immersion` if the preimages of affine open sets are affine. -/
@[mk_iff]
class is_immersion (f : X ⟶ Y) extends is_preimmersion f : Prop :=
(range_is_locally_closed [] : is_locally_closed (set.range f.1.base))

lemma is_immersion.base_embedding [is_immersion f] : embedding f.1.base :=
is_preimmersion.base_embedding f

instance [is_immersion f] [is_immersion g] : is_immersion (f ≫ g) :=
begin
  constructor,
  rw [Scheme.comp_val_base, coe_comp, set.range_comp],
  exact (is_immersion.range_is_locally_closed f).image (is_immersion.base_embedding g).to_inducing
    (is_immersion.range_is_locally_closed g)
end

instance is_open_immersion.to_is_immersion [is_open_immersion f] : is_immersion f :=
begin
  constructor,
  exact (is_open_immersion.base_open f).2.is_locally_closed
end

instance is_closed_immersion.to_is_immersion [is_closed_immersion f] : is_immersion f :=
⟨(is_closed_immersion.base_closed f).2.is_locally_closed⟩

lemma is_closed_immersion_iff_is_immersion {f : X ⟶ Y} :
  is_closed_immersion f ↔ is_immersion f ∧ is_closed (set.range f.1.base) :=
⟨λ H, by exactI ⟨infer_instance, H.2⟩, λ ⟨h₁, h₂⟩, by exactI ⟨h₂⟩⟩

lemma is_closed_immersion.of_is_immersion [is_immersion f] (hf : is_closed (set.range f.1.base)) :
  is_closed_immersion f :=
⟨hf⟩

/-- Also see `is_immersion.of_comp` in the file `morphisms/separated` -/
lemma is_immersion.of_comp_of_is_immersion [is_immersion (f ≫ g)] [is_immersion g] :
  is_immersion f :=
begin
  haveI := is_preimmersion.of_comp f g,
  constructor,
  rw [← set.preimage_image_eq (set.range f.1.base) (is_immersion.base_embedding g).inj,
    ← set.range_comp, ← coe_comp, ← Scheme.comp_val_base],
  exact (is_immersion.range_is_locally_closed (f ≫ g)).preimage g.1.base.2
end

@[simps]
def is_immersion.factor_opens [is_immersion f] : opens Y.carrier :=
⟨_, (is_immersion.range_is_locally_closed f).is_open_coboundary⟩

def is_immersion.factor_open_subscheme [is_immersion f] : Scheme :=
Y.restrict (is_immersion.factor_opens f).open_embedding

@[derive is_open_immersion]
def is_immersion.factor_open_immersion [is_immersion f] :
  is_immersion.factor_open_subscheme f ⟶ Y :=
Y.of_restrict _

-- move me
lemma opens.range_inclusion {X : Top} (U : opens X) : set.range U.inclusion = U :=
subtype.range_coe

def is_immersion.factor_closed_immersion [is_immersion f] :
  X ⟶ is_immersion.factor_open_subscheme f :=
is_open_immersion.lift (is_immersion.factor_open_immersion f) f
begin
  rw [is_immersion.factor_open_immersion, Scheme.of_restrict_val_base, opens.range_inclusion],
  exact subset_coboundary
end

@[simp, reassoc]
lemma is_immersion.factors [is_immersion f] :
  is_immersion.factor_closed_immersion f ≫ is_immersion.factor_open_immersion f = f :=
is_open_immersion.lift_fac _ _ _

-- move me
lemma is_open_immersion.range_lift (f : X ⟶ Z) (g : Y ⟶ Z) [is_open_immersion f]
  (H : set.range g.1.base ⊆ set.range f.1.base) :
  set.range (is_open_immersion.lift f g H).1.base = f.1.base ⁻¹' (set.range g.1.base) :=
LocallyRingedSpace.is_open_immersion.lift_range _ _ _

instance [is_immersion f] : is_closed_immersion (is_immersion.factor_closed_immersion f) :=
begin
  haveI : is_immersion (is_immersion.factor_closed_immersion f),
  { apply_with (is_immersion.of_comp_of_is_immersion _ (is_immersion.factor_open_immersion f))
    { instances := ff },
    rwa is_immersion.factors },
  apply is_closed_immersion.of_is_immersion,
  rw [is_immersion.factor_closed_immersion, is_open_immersion.range_lift],
  exact is_closed_preimage_coe_coboundary
end

lemma is_immersion_iff_exists_factor :
  is_immersion f ↔ ∃ {Z : Scheme} (g : X ⟶ Z) [is_closed_immersion g]
    (h : Z ⟶ Y) [is_open_immersion h], g ≫ h = f :=
begin
  split,
  { introI H, exact ⟨_, is_immersion.factor_closed_immersion f, infer_instance,
      is_immersion.factor_open_immersion f, infer_instance, is_immersion.factors f⟩ },
  { rintro ⟨_, _, _, _, _, rfl⟩, by exactI infer_instance }
end

instance is_immersion.to_mono [is_immersion f] : mono f :=
by { rw ← is_immersion.factors f, apply mono_comp }

instance is_immersion.to_locally_of_finite_type [is_immersion f] : locally_of_finite_type f :=
by { rw ← is_immersion.factors f, apply_instance }

lemma is_immersion_stable_under_composition :
  morphism_property.stable_under_composition @is_immersion :=
λ _ _ _ _ _ _ _, by exactI infer_instance

lemma is_immersion_respects_iso :
  morphism_property.respects_iso @is_immersion :=
is_immersion_stable_under_composition.respects_iso (λ _ _ _, infer_instance)

lemma is_immersion_stable_under_base_change :
  morphism_property.stable_under_base_change @is_immersion :=
begin
  intros X Y X' S f g f' g' H hg,
  rw is_immersion_iff_exists_factor at hg ⊢,
  obtain ⟨Z, i₁, _, i₂, _, rfl⟩ := hg,
  resetI,
  refine ⟨pullback i₂ f, pullback.lift (f' ≫ i₁) g' ((category.assoc _ _ _).trans H.w), _,
    pullback.snd, infer_instance, pullback.lift_snd _ _ _⟩,
  have : is_pullback f'
    (pullback.lift (f' ≫ i₁) g' ((category.assoc _ _ _).trans H.w)) i₁ pullback.fst :=
    is_pullback.of_bot (by rwa pullback.lift_snd)
      (pullback.lift_fst _ _ _).symm (is_pullback.of_has_pullback _ _),
  exact is_closed_immersion_stable_under_base_change this infer_instance
end

instance {X Y S : Scheme} (f : X ⟶ S) (g : Y ⟶ S) [is_immersion g] :
  is_immersion (pullback.fst : pullback f g ⟶ X) :=
is_immersion_stable_under_base_change.fst f g infer_instance

instance {X Y S : Scheme} (f : X ⟶ S) (g : Y ⟶ S) [is_immersion f] :
  is_immersion (pullback.snd : pullback f g ⟶ Y) :=
is_immersion_stable_under_base_change.snd f g infer_instance

lemma is_immersion_is_local_at_target :
  property_is_local_at_target @is_immersion :=
begin
  constructor,
  { exact is_immersion_respects_iso },
  { intros X Y f U hU,
    haveI := is_preimmersion_is_local_at_target.2 f U hU.1,
    constructor,
    rw [morphism_restrict_val_base, set.range_restrict_preimage],
    exact (is_immersion.range_is_locally_closed f).preimage continuous_subtype_coe },
  { introsI X Y f 𝒰 H,
    haveI := is_preimmersion_is_local_at_target.3 f 𝒰 infer_instance,
    constructor,
    apply (is_locally_closed_iff_coe_preimage_of_supr_eq_top 𝒰.supr_opens_range _).mpr,
    intro i,
    convert ((is_immersion_respects_iso.arrow_mk_iso_iff
      (morphism_restrict_opens_range f (𝒰.map i))).mpr (H i)).2 using 1,
    rw [morphism_restrict_val_base, set.range_restrict_preimage] },
end

lemma is_immersion_open_cover_tfae (f : X ⟶ Y) :
  tfae [is_immersion f,
    ∃ (𝒰 : Scheme.open_cover.{u} Y), ∀ (i : 𝒰.J),
      is_immersion (pullback.snd : (𝒰.pullback_cover f).obj i ⟶ 𝒰.obj i),
    ∀ (𝒰 : Scheme.open_cover.{u} Y) (i : 𝒰.J),
      is_immersion (pullback.snd : (𝒰.pullback_cover f).obj i ⟶ 𝒰.obj i),
    ∀ (U : opens Y.carrier), is_immersion (f ∣_ U),
    ∀ {U : Scheme} (g : U ⟶ Y) [is_open_immersion g],
      is_immersion (pullback.snd : pullback f g ⟶ U),
    ∃ {ι : Type u} (U : ι → opens Y.carrier) (hU : supr U = ⊤), (∀ i, is_immersion (f ∣_ (U i)))] :=
is_immersion_is_local_at_target.open_cover_tfae f

-- lemma is_immersion_open_cover_of_subset_supr (f : X ⟶ Y)
--   {ι : Type u} (U : ι → opens Y.carrier) (hU : set.range f.1.base ⊆ ((supr U : _) : set Y.carrier))
--   (h : ∀ i, is_immersion (f ∣_ U i)) : is_immersion f :=
-- begin
--   let V := supr U,
--   have hV : (opens.map f.val.base).obj V = ⊤,
--   { rw [eq_top_iff], exact set.image_subset_iff.mp ((subset_of_eq set.image_univ).trans hU) },
--   suffices : is_immersion (f ∣_ V),
--   { haveI : is_iso (X.of_restrict ((opens.map f.val.base).obj V).open_embedding),
--     { rw hV,
--       apply_with (is_iso_of_reflects_iso _ Scheme.forget_to_LocallyRingedSpace) { instances := ff },
--       convert_to is_iso X.to_LocallyRingedSpace.restrict_top_iso.hom,
--       apply_instance },
--     rw [← is_immersion_respects_iso.cancel_left_is_iso
--       (X.of_restrict ((opens.map f.val.base).obj V).open_embedding), ← morphism_restrict_ι],
--     apply_instance },
--   let U' : ι → opens (Y.restrict V.open_embedding).carrier := (opens.map V.inclusion).obj ∘ U,
--   have : supr U' = ⊤,
--   { rw [eq_top_iff],
--     rintro ⟨x, hx⟩ -,
--     obtain ⟨i, hi⟩ := opens.mem_supr.mp hx,
--     exact opens.mem_supr.mpr ⟨i, hi⟩ },
--   refine ((is_immersion_open_cover_tfae (f ∣_ V)).out 0 5).mpr ⟨_, U', this, λ i, _⟩,
--   refine (is_immersion_respects_iso.arrow_iso_iff (morphism_restrict_restrict f _ _ ≪≫
--     morphism_restrict_eq f ((V.functor_map_eq_inf _).trans _))).mpr (h i),
--   rw inf_eq_left,
--   exact le_supr U i,
-- end

lemma is_closed_immersion_pullback_diagonal_Spec {R S : CommRing}
  (f' : Scheme.Spec.obj (op S) ⟶ Scheme.Spec.obj (op R)) :
  is_closed_immersion (pullback.diagonal f') :=
begin
  let f : R ⟶ S := (Scheme.Spec.preimage f').unop,
  have : Scheme.Spec.map f.op = f', { rw [quiver.hom.op_unop, functor.image_preimage] },
  clear_value f, subst this,
  letI := f.to_algebra,
  have H := (is_pushout.of_is_colimit
    (CommRing.pushout_cocone_is_colimit f f)).op.map Scheme.Spec,
  let e : pullback.diagonal_obj (Scheme.Spec.map f.op) ≅
    Scheme.Spec.obj (op (CommRing.pushout_cocone f f).X) := limit.iso_limit_cone ⟨_, H.is_limit⟩,
  have : pullback.diagonal _ ≫ e.hom = Scheme.Spec.map
    (quiver.hom.op $ (@algebra.tensor_product.lmul' R S _ _ _).to_ring_hom),
  { apply pullback_cone.is_limit.hom_ext H.is_limit,
    { rw category.assoc,
      erw [is_limit.cone_point_unique_up_to_iso_hom_comp, pullback.diagonal_fst],
      rw [H.cone_fst, ← functor.map_comp, ← op_comp],
      transitivity Scheme.Spec.map (𝟙 _).op, { rw [op_id, category_theory.functor.map_id] },
      congr' 2, ext1, simp },
    { rw category.assoc,
      erw [is_limit.cone_point_unique_up_to_iso_hom_comp, pullback.diagonal_snd],
      rw [H.cone_snd, ← functor.map_comp, ← op_comp],
      transitivity Scheme.Spec.map (𝟙 _).op, { rw [op_id, category_theory.functor.map_id] },
      congr' 2, ext1, simp }, },
  rw [← is_closed_immersion_respects_iso.cancel_right_is_iso _ e.hom, this,
    is_closed_immersion_Spec_iff],
  exact λ x, ⟨x ⊗ₜ 1, (algebra.tensor_product.lmul'_apply_tmul _ _).trans (mul_one _)⟩,
end

-- -- move me
-- abbreviation Scheme.hom.lift_open (U : opens Y.carrier) (hU : set.range f.1.base ⊆ U.1) :
--   X ⟶ Y.restrict U.open_embedding :=
-- is_open_immersion.lift (Y.of_restrict U.open_embedding) f
--   (hU.trans $ subset_of_eq $ subtype.range_coe.symm)

-- lemma Scheme.hom.lift_open_of_restrict (U : opens Y.carrier) (hU : set.range f.1.base ⊆ U.1) :
--   X.of_restrict _ ≫ f.lift_open U hU = f ∣_ U :=
-- begin
--   rw ← cancel_mono (Y.of_restrict U.open_embedding),
--   rw [category.assoc, is_open_immersion.lift_fac, morphism_restrict_ι],
-- end

variable {f}

variables (𝒰 : Scheme.open_cover.{u} Y) (𝒱 : ∀ i, Scheme.open_cover.{u} (pullback f (𝒰.map i)))

def pullback.diagonal_cover :
  (pullback.diagonal_obj f).open_cover :=
(Scheme.pullback.open_cover_of_base 𝒰 f f).bind
  (λ i, Scheme.pullback.open_cover_of_left_right (𝒱 i) (𝒱 i) pullback.snd pullback.snd)

def pullback.diagonal_cover_diagonal :
  opens (pullback.diagonal_obj f).carrier :=
⨆ i : Σ i, (𝒱 i).J, ((pullback.diagonal_cover 𝒰 𝒱).map ⟨i.1, i.2, i.2⟩).opens_range

lemma pullback.diagonal_cover_map_eq (I) : (pullback.diagonal_cover 𝒰 𝒱).map I =
  pullback.map _ _ _ _
    ((𝒱 I.fst).map _ ≫ pullback.fst) ((𝒱 I.fst).map _ ≫ pullback.fst) (𝒰.map _)
    (by simp only [category.assoc, pullback.condition])
    (by simp only [category.assoc, pullback.condition]) :=
begin
  dsimp [pullback.diagonal_cover],
  apply pullback.hom_ext; simp only [category.assoc, pullback.lift_fst, pullback.lift_snd,
      pullback.lift_fst_assoc, pullback.lift_snd_assoc,
      pullback.diagonal_fst_assoc, pullback.diagonal_fst,
      pullback.diagonal_snd_assoc, pullback.diagonal_snd, category.comp_id]
end

lemma pullback.diagonal_cover_diagonal_eq_top_of_injective (hf : function.injective f.1.base) :
  pullback.diagonal_cover_diagonal 𝒰 𝒱 = ⊤ :=
begin
  rw eq_top_iff,
  rintro x -,
  let x₁ := (pullback.fst : pullback.diagonal_obj f ⟶ X).1.base x,
  let x₂ := (pullback.snd : pullback.diagonal_obj f ⟶ X).1.base x,
  have hx : x₁ = x₂,
  { apply hf, simp_rw [← Scheme.comp_val_base_apply, pullback.condition] },
  let i := 𝒰.f (f.1.base x₁),
  obtain ⟨t, ht⟩ : x₁ ∈ set.range (pullback.fst : pullback f (𝒰.map i) ⟶ _).1.base,
  { rw is_open_immersion.range_pullback_fst_of_right, exact (𝒰.covers $ f.1.base x₁) },
  obtain ⟨w, hw⟩ := (𝒱 i).covers t,
  rw ← hw at ht,
  refine opens.mem_supr.mpr ⟨⟨i, (𝒱 i).f t⟩, _⟩,
  change _ ∈ set.range ((pullback.diagonal_cover 𝒰 𝒱).map ⟨i, ((𝒱 i).f t, (𝒱 i).f t)⟩).1.base,
  simp_rw [pullback.diagonal_cover_map_eq 𝒰 𝒱, pullback.range_map],
  split,
  { exact ⟨w, ht⟩ },
  { rw hx at ht, exact ⟨w, ht⟩ }
end

lemma pullback.diagonal_range_subset_supr_diagonal_cover :
  set.range (pullback.diagonal f).1.base ⊆ (pullback.diagonal_cover_diagonal 𝒰 𝒱).1 :=
begin
  rintros _ ⟨x, rfl⟩,
  let i := 𝒰.f (f.1.base x),
  obtain ⟨y, hy : (𝒰.map i).1.base y = _⟩ := 𝒰.covers (f.1.base x),
  let T : pullback.triplet f (𝒰.map i) := ⟨x, y, _, rfl, hy⟩,
  obtain ⟨z, (hzx : _ = x), (rfl : _ = y)⟩ := T.exists_preimage,
  obtain ⟨w, hw⟩ := (𝒱 i).covers z,
  rw [← hzx, ← hw],
  refine opens.mem_supr.mpr ⟨⟨i, (𝒱 i).f z⟩,
    (pullback.diagonal ((𝒱 i).map ((𝒱 i).f z) ≫ pullback.snd)).1.base w, _⟩,
  simp_rw [← Scheme.comp_val_base_apply],
  congr' 3,
  dsimp [pullback.diagonal_cover],
  apply pullback.hom_ext; simp only [category.assoc, pullback.lift_fst, pullback.lift_snd,
      pullback.lift_fst_assoc, pullback.lift_snd_assoc,
      pullback.diagonal_fst_assoc, pullback.diagonal_fst,
      pullback.diagonal_snd_assoc, pullback.diagonal_snd, category.comp_id],
end

def pullback.diagonal_restrict_iso_diagonal (i j) :
  arrow.mk (pullback.diagonal f ∣_ ((pullback.diagonal_cover 𝒰 𝒱).map ⟨i, j, j⟩).opens_range) ≅
    arrow.mk (pullback.diagonal ((𝒱 i).map j ≫ pullback.snd)) :=
begin
  refine (morphism_restrict_opens_range _ _) ≪≫ arrow.iso_mk _ _ _,
  { dsimp [pullback.diagonal_cover],
    refine pullback.congr_hom rfl _ ≪≫
      pullback_diagonal_map_iso f (𝒰.map i) ((𝒱 i).map j) ((𝒱 i).map j) ≪≫
      as_iso pullback.fst,
    apply pullback.hom_ext; simp only [category.assoc, pullback.lift_fst, pullback.lift_snd,
        pullback.lift_fst_assoc, pullback.lift_snd_assoc],
      },
  { dsimp [pullback.diagonal_cover], exact iso.refl _ },
  { have : (pullback.fst : pullback ((𝒱 i).map j) ((𝒱 i).map j) ⟶ _) = pullback.snd,
    { rw ← cancel_epi (pullback.diagonal $ (𝒱 i).map j),
      rw [pullback.diagonal_fst, pullback.diagonal_snd] },
    dsimp [pullback.diagonal_cover],
    apply pullback.hom_ext,
    swap, simp only [this],
    all_goals { simp only [category.assoc, pullback.lift_fst, pullback.lift_snd,
      pullback.lift_fst_assoc, pullback.lift_snd_assoc, category.id_comp, category.comp_id,
      pullback_diagonal_map_iso_hom_fst, pullback_diagonal_map_iso_hom_snd,
      pullback.diagonal_fst, pullback.diagonal_snd] } }
end

lemma pullback.is_closed_immersion_lift_diagonal_aux
  (H : ∀ i j, is_closed_immersion (pullback.diagonal ((𝒱 i).map j ≫ pullback.snd))) :
  is_closed_immersion (pullback.diagonal f ∣_ pullback.diagonal_cover_diagonal 𝒰 𝒱) :=
begin
  rw (is_closed_immersion.open_cover_tfae (pullback.diagonal
    f ∣_ pullback.diagonal_cover_diagonal 𝒰 𝒱)).out 0 5,
  have : (⨆ i : Σ i, (𝒱 i).J, ((pullback.diagonal_cover 𝒰 𝒱).map ⟨i.1, i.2, i.2⟩).opens_range) =
    pullback.diagonal_cover_diagonal 𝒰 𝒱 := rfl,
  apply_fun (opens.map (pullback.diagonal_cover_diagonal 𝒰 𝒱).inclusion).obj at this,
  rw [opens.map_supr, opens.inclusion_map_eq_top] at this,
  refine ⟨_, _, this, _⟩,
  rintros ⟨i, j⟩,
  rw is_closed_immersion_respects_iso.arrow_mk_iso_iff
    (morphism_restrict_restrict _ _ _),
  rw is_closed_immersion_respects_iso.arrow_mk_iso_iff
    (morphism_restrict_eq _ $ (opens.functor_map_eq_inf _ _).trans (inf_eq_left.mpr _)),
  { rw is_closed_immersion_respects_iso.arrow_mk_iso_iff
    (pullback.diagonal_restrict_iso_diagonal 𝒰 𝒱 i j), apply H },
  { exact le_supr _ _ }
end

variable (f)

lemma pullback.is_closed_immersion_lift_diagonal :
  is_closed_immersion (pullback.diagonal f ∣_ pullback.diagonal_cover_diagonal
    Y.affine_cover (λ _, Scheme.affine_cover _)) :=
begin
  apply pullback.is_closed_immersion_lift_diagonal_aux,
  intros i j, apply is_closed_immersion_pullback_diagonal_Spec
end

local attribute [irreducible] Scheme.affine_cover

def Scheme.restrict_top_iso (X : Scheme.{u}) :
  X.restrict (opens.open_embedding $ ⊤) ≅ X :=
{ .. X.to_LocallyRingedSpace.restrict_top_iso }

-- Declaring it as an instance adds superfluous universe variables
@[instance]
lemma _root_.category_theory.limits.pullback.diagonal.is_immersion {X Y : Scheme.{u}} (f : X ⟶ Y) :
  is_immersion (pullback.diagonal f) :=
begin
  let U := (pullback.diagonal_cover_diagonal Y.affine_cover (λ _, Scheme.affine_cover _)),
  haveI : is_closed_immersion (pullback.diagonal f ∣_ U) :=
    pullback.is_closed_immersion_lift_diagonal f,
  have : (opens.map (pullback.diagonal f).val.base).obj U = ⊤,
  { ext1, show (pullback.diagonal f).val.base ⁻¹' U.1 = set.univ,
    rw [← set.univ_subset_iff, ← set.image_subset_iff, set.image_univ],
    exact pullback.diagonal_range_subset_supr_diagonal_cover _ _ },
  haveI : is_iso (X.of_restrict ((opens.map (pullback.diagonal f).val.base).obj U).open_embedding),
  { rw this, exact is_iso.of_iso X.restrict_top_iso },
  have := morphism_restrict_ι (pullback.diagonal f) U,
  rw [← is_iso.inv_comp_eq] at this,
  rw ← this,
  apply_instance
end
-- move me
def morphism_restrict.top_iso : arrow.mk (f ∣_ ⊤) ≅ arrow.mk f :=
arrow.iso_mk' (f ∣_ ⊤) f X.restrict_top_iso Y.restrict_top_iso (morphism_restrict_ι _ _).symm

-- Also see `separated_of_injective`
lemma pullback.diagonal_is_closed_immersion_of_injective {X Y : Scheme.{u}} (f : X ⟶ Y)
  (hf : function.injective f.1.base) :
  is_closed_immersion (pullback.diagonal f) :=
begin
  let U := (pullback.diagonal_cover_diagonal Y.affine_cover (λ _, Scheme.affine_cover _)),
  have hU : is_closed_immersion (pullback.diagonal f ∣_ U) :=
    pullback.is_closed_immersion_lift_diagonal f,
  have : U = ⊤ := pullback.diagonal_cover_diagonal_eq_top_of_injective _ _ hf,
  rw this at hU,
  exact (is_closed_immersion_respects_iso.arrow_mk_iso_iff (morphism_restrict.top_iso _)).mp hU
end

end algebraic_geometry


class HOp (α β γ) where hOp : α → β → γ

class LOp (α β) where lOp : α → β → β

class Op (α) where op : α → α → α

@[default_instance]
instance inst1 [LOp α β] : HOp α β β := ⟨LOp.lOp⟩

instance inst2 [Op α] : LOp α α := ⟨Op.op⟩

infix:75 " ⋆ " => HOp.hOp

section Test
variable (α) [LOp Nat α]
variable (x y z : α) (m n : Nat)

example : n ⋆ x = z := sorry -- TC works

example : 1 ⋆ x = z := sorry -- TC works

attribute [default_instance] inst2

example : n ⋆ x = z := sorry -- TC works

example : 1 ⋆ x = z := sorry -- TC fails

end Test


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import algebra.group.pi
import algebra.category.Group.preadditive
import category_theory.limits.shapes.biproducts
import algebra.category.Group.limits

/-!
# The category of abelian groups has finite biproducts
-/

open category_theory
open category_theory.limits

open_locale big_operators

universes w u

namespace AddCommGroup

-- As `AddCommGroup` is preadditive, and has all limits, it automatically has biproducts.
instance : has_binary_biproducts AddCommGroup :=
has_binary_biproducts.of_has_binary_products

instance : has_finite_biproducts AddCommGroup :=
has_finite_biproducts.of_has_finite_products

-- We now construct explicit limit data,
-- so we can compare the biproducts to the usual unbundled constructions.

/--
Construct limit data for a binary product in `AddCommGroup`, using `AddCommGroup.of (G × H)`.
-/
@[simps cone_X is_limit_lift]
def binary_product_limit_cone (G H : AddCommGroup.{u}) : limits.limit_cone (pair G H) :=
{ cone :=
  { X := AddCommGroup.of (G × H),
    π := { app := λ j, discrete.cases_on j
      (λ j, walking_pair.cases_on j (add_monoid_hom.fst G H) (add_monoid_hom.snd G H)),
      naturality' := by rintros ⟨⟨⟩⟩ ⟨⟨⟩⟩ ⟨⟨⟨⟩⟩⟩; refl, }},
  is_limit :=
  { lift := λ s, add_monoid_hom.prod (s.π.app ⟨walking_pair.left⟩) (s.π.app ⟨walking_pair.right⟩),
    fac' := by { rintros s (⟨⟩|⟨⟩); { ext x, simp, } },
    uniq' := λ s m w, begin
      ext; [rw ← w ⟨walking_pair.left⟩, rw ← w ⟨walking_pair.right⟩]; refl,
    end, } }

@[simp] lemma binary_product_limit_cone_cone_π_app_left (G H : AddCommGroup.{u}) :
  (binary_product_limit_cone G H).cone.π.app ⟨walking_pair.left⟩ = add_monoid_hom.fst G H := rfl

@[simp] lemma binary_product_limit_cone_cone_π_app_right (G H : AddCommGroup.{u}) :
  (binary_product_limit_cone G H).cone.π.app ⟨walking_pair.right⟩ = add_monoid_hom.snd G H := rfl

/--
We verify that the biproduct in AddCommGroup is isomorphic to
the cartesian product of the underlying types:
-/
@[simps hom_apply] noncomputable
def biprod_iso_prod (G H : AddCommGroup.{u}) : (G ⊞ H : AddCommGroup) ≅ AddCommGroup.of (G × H) :=
is_limit.cone_point_unique_up_to_iso
  (binary_biproduct.is_limit G H)
  (binary_product_limit_cone G H).is_limit

@[simp, elementwise] lemma biprod_iso_prod_inv_comp_fst (G H : AddCommGroup.{u}) :
  (biprod_iso_prod G H).inv ≫ biprod.fst = add_monoid_hom.fst G H :=
is_limit.cone_point_unique_up_to_iso_inv_comp _ _ (discrete.mk walking_pair.left)

@[simp, elementwise] lemma biprod_iso_prod_inv_comp_snd (G H : AddCommGroup.{u}) :
  (biprod_iso_prod G H).inv ≫ biprod.snd = add_monoid_hom.snd G H :=
is_limit.cone_point_unique_up_to_iso_inv_comp _ _ (discrete.mk walking_pair.right)

namespace has_limit
variables {J : Type w} (f : J → AddCommGroup.{max w u})

/--
The map from an arbitrary cone over a indexed family of abelian groups
to the cartesian product of those groups.
-/
@[simps]
def lift (s : fan f) :
  s.X ⟶ AddCommGroup.of (Π j,f j) :=
{ to_fun := λ x j, s.π.app ⟨j⟩ x,
  map_zero' := by { ext, simp },
  map_add' := λ x y, by { ext, simp }, }

/--
Construct limit data for a product in `AddCommGroup`, using `AddCommGroup.of (Π j, F.obj j)`.
-/
@[simps] def product_limit_cone : limits.limit_cone (discrete.functor f) :=
{ cone :=
  { X := AddCommGroup.of (Π j, f j),
    π := discrete.nat_trans (λ j, pi.eval_add_monoid_hom (λ j, f j) j.as), },
  is_limit :=
  { lift := lift f,
    fac' := λ s j, by { cases j, ext, simp, },
    uniq' := λ s m w,
    begin
      ext x j,
      dsimp only [has_limit.lift],
      simp only [add_monoid_hom.coe_mk],
      exact congr_arg (λ g : s.X ⟶ f j, (g : s.X → f j) x) (w ⟨j⟩),
    end, }, }

end has_limit

open has_limit

variables {J : Type} [fintype J]

/--
We verify that the biproduct we've just defined is isomorphic to the AddCommGroup structure
on the dependent function type
-/
@[simps hom_apply] noncomputable
def biproduct_iso_pi (f : J → AddCommGroup.{u}) :
  (⨁ f : AddCommGroup) ≅ AddCommGroup.of (Π j, f j) :=
is_limit.cone_point_unique_up_to_iso
  (biproduct.is_limit f)
  (product_limit_cone f).is_limit

@[simp, elementwise] lemma biproduct_iso_pi_inv_comp_π (f : J → AddCommGroup.{u}) (j : J) :
  (biproduct_iso_pi f).inv ≫ biproduct.π f j = pi.eval_add_monoid_hom (λ j, f j) j :=
is_limit.cone_point_unique_up_to_iso_inv_comp _ _ (discrete.mk j)

end AddCommGroup