import util.meta.tactic

example (x y : ℕ)
  (h : x ≤ 7)
  (h' : y ≤ 7)
: (if x ≤ y then x else y) ≤ 7 :=
begin
  ite_cases with h₃,
  all_goals { assumption }
end

example (x y : ℕ)
  (h : x ≤ 7)
  (h' : y ≤ 7)
: (if h'' : x ≤ y then x else y) ≤ 7 :=
begin
  ite_cases with h₃,
  all_goals { assumption }
end

example (x y i j : ℕ)
  (h : x ≤ i)
  (h' : y ≤ j)
: (if h : x ≤ y then x else y) ≤ (if x ≤ y then i else j) :=
begin
  ite_cases with h₃,
  all_goals { assumption }
end

example (x y i j : ℕ)
  (h : x ≤ i)
  (h' : y ≤ j)
: (if x ≤ y then x else y) ≤ if (if x ≤ y then tt else ff) then i else j :=
begin
  ite_cases with h₃,
  all_goals { assumption }
end

example (x y i j : ℕ)
  (f : ℕ → ℕ)
  (h'' : (if h : x ≤ y then x ≤ i else y ≤ j))
  (h''' : f (if h : x ≤ y then y else x) ≤ 7)
  (h'''' : (if h : x ≤ y then y else x) ≤ 7)
: (if h : x ≤ y then x else y) ≤ (if x ≤ y then i else j) :=
begin
  ite_cases with h₃ at ⊢ h'' h''',
  all_goals { assumption }
end

example (x y i j : ℕ)
  (f : ℕ → ℕ)
  (h'' : (if h : x ≤ y then x ≤ i else y ≤ j))
  (h''' : f (if h : x ≤ y then y else x) ≤ 7)
  (h'''' : (if h : x ≤ y then y else x) ≤ 7)
: x ≤ i ∨ y ≤ j :=
begin
  ite_cases with h₃ at ⊢ h'' h'''
  ; [ right , left ]
  ; assumption
end


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta, Jakob von Raumer
-/
import category_theory.limits.has_limits
import category_theory.thin

/-!
# Wide pullbacks

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

We define the category `wide_pullback_shape`, (resp. `wide_pushout_shape`) which is the category
obtained from a discrete category of type `J` by adjoining a terminal (resp. initial) element.
Limits of this shape are wide pullbacks (pushouts).
The convenience method `wide_cospan` (`wide_span`) constructs a functor from this category, hitting
the given morphisms.

We use `wide_pullback_shape` to define ordinary pullbacks (pushouts) by using `J := walking_pair`,
which allows easy proofs of some related lemmas.
Furthermore, wide pullbacks are used to show the existence of limits in the slice category.
Namely, if `C` has wide pullbacks then `C/B` has limits for any object `B` in `C`.

Typeclasses `has_wide_pullbacks` and `has_finite_wide_pullbacks` assert the existence of wide
pullbacks and finite wide pullbacks.
-/

universes w w' v u

open category_theory category_theory.limits opposite

namespace category_theory.limits

variable (J : Type w)

/-- A wide pullback shape for any type `J` can be written simply as `option J`. -/
@[derive inhabited]
def wide_pullback_shape := option J

/-- A wide pushout shape for any type `J` can be written simply as `option J`. -/
@[derive inhabited]
def wide_pushout_shape := option J

namespace wide_pullback_shape

variable {J}

/-- The type of arrows for the shape indexing a wide pullback. -/
@[derive decidable_eq]
inductive hom : wide_pullback_shape J → wide_pullback_shape J → Type w
| id : Π X, hom X X
| term : Π (j : J), hom (some j) none

attribute [nolint unused_arguments] hom.decidable_eq

instance struct : category_struct (wide_pullback_shape J) :=
{ hom := hom,
  id := λ j, hom.id j,
  comp := λ j₁ j₂ j₃ f g,
  begin
    cases f,
      exact g,
    cases g,
    apply hom.term _
  end }

instance hom.inhabited : inhabited (hom none none) := ⟨hom.id (none : wide_pullback_shape J)⟩

local attribute [tidy] tactic.case_bash

instance subsingleton_hom : quiver.is_thin (wide_pullback_shape J) :=
λ _ _, ⟨by tidy⟩

instance category : small_category (wide_pullback_shape J) := thin_category

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

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

/--
Construct a functor out of the wide pullback shape given a J-indexed collection of arrows to a
fixed object.
-/
@[simps]
def wide_cospan (B : C) (objs : J → C) (arrows : Π (j : J), objs j ⟶ B) :
  wide_pullback_shape J ⥤ C :=
{ obj := λ j, option.cases_on j B objs,
  map := λ X Y f,
  begin
    cases f with _ j,
    { apply (𝟙 _) },
    { exact arrows j }
  end,
  map_comp' := λ _ _ _ f g,
  begin
    cases f,
    { simpa },
    cases g,
    simp
  end }

/-- Every diagram is naturally isomorphic (actually, equal) to a `wide_cospan` -/
def diagram_iso_wide_cospan (F : wide_pullback_shape J ⥤ C) :
  F ≅ wide_cospan (F.obj none) (λ j, F.obj (some j)) (λ j, F.map (hom.term j)) :=
nat_iso.of_components (λ j, eq_to_iso $ by tidy) $ by tidy

/-- Construct a cone over a wide cospan. -/
@[simps]
def mk_cone {F : wide_pullback_shape J ⥤ C} {X : C}
  (f : X ⟶ F.obj none) (π : Π j, X ⟶ F.obj (some j))
  (w : ∀ j, π j ≫ F.map (hom.term j) = f) : cone F :=
{ X := X,
  π :=
  { app := λ j, match j with
    | none := f
    | (some j) := π j
    end,
    naturality' := λ j j' f, by { cases j; cases j'; cases f; unfold_aux; dsimp; simp [w], }, } }

/-- Wide pullback diagrams of equivalent index types are equivlent. -/
def equivalence_of_equiv (J' : Type w') (h : J ≃ J') :
  wide_pullback_shape J ≌ wide_pullback_shape J' :=
{ functor := wide_cospan none (λ j, some (h j)) (λ j, hom.term (h j)),
  inverse := wide_cospan none (λ j, some (h.inv_fun j)) (λ j, hom.term (h.inv_fun j)),
  unit_iso := nat_iso.of_components (λ j, by cases j; simp)
    (λ j k f, by { simp only [eq_iff_true_of_subsingleton]}),
  counit_iso := nat_iso.of_components (λ j, by cases j; simp)
    (λ j k f, by { simp only [eq_iff_true_of_subsingleton]}) }

/-- Lifting universe and morphism levels preserves wide pullback diagrams. -/
def ulift_equivalence :
  ulift_hom.{w'} (ulift.{w'} (wide_pullback_shape J)) ≌ wide_pullback_shape (ulift J) :=
(ulift_hom_ulift_category.equiv.{w' w' w w} (wide_pullback_shape J)).symm.trans
  (equivalence_of_equiv _ (equiv.ulift.{w' w}.symm : J ≃ ulift.{w'} J))

end wide_pullback_shape

namespace wide_pushout_shape

variable {J}

/-- The type of arrows for the shape indexing a wide psuhout. -/
@[derive decidable_eq]
inductive hom : wide_pushout_shape J → wide_pushout_shape J → Type w
| id : Π X, hom X X
| init : Π (j : J), hom none (some j)

attribute [nolint unused_arguments] hom.decidable_eq

instance struct : category_struct (wide_pushout_shape J) :=
{ hom := hom,
  id := λ j, hom.id j,
  comp := λ j₁ j₂ j₃ f g,
  begin
    cases f,
      exact g,
    cases g,
    apply hom.init _
  end }

instance hom.inhabited : inhabited (hom none none) := ⟨hom.id (none : wide_pushout_shape J)⟩

local attribute [tidy] tactic.case_bash

instance subsingleton_hom : quiver.is_thin (wide_pushout_shape J) :=
λ _ _, ⟨by tidy⟩

instance category : small_category (wide_pushout_shape J) := thin_category

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

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

/--
Construct a functor out of the wide pushout shape given a J-indexed collection of arrows from a
fixed object.
-/
@[simps]
def wide_span (B : C) (objs : J → C) (arrows : Π (j : J), B ⟶ objs j) : wide_pushout_shape J ⥤ C :=
{ obj := λ j, option.cases_on j B objs,
  map := λ X Y f,
  begin
    cases f with _ j,
    { apply (𝟙 _) },
    { exact arrows j }
  end,
  map_comp' := by { rintros (_|_) (_|_) (_|_) (_|_) (_|_); simpa <|> simp } }

/-- Every diagram is naturally isomorphic (actually, equal) to a `wide_span` -/
def diagram_iso_wide_span (F : wide_pushout_shape J ⥤ C) :
  F ≅ wide_span (F.obj none) (λ j, F.obj (some j)) (λ j, F.map (hom.init j)) :=
nat_iso.of_components (λ j, eq_to_iso $ by tidy) $ by tidy

/-- Construct a cocone over a wide span. -/
@[simps]
def mk_cocone {F : wide_pushout_shape J ⥤ C} {X : C}
  (f : F.obj none ⟶ X) (ι : Π j, F.obj (some j) ⟶ X)
  (w : ∀ j, F.map (hom.init j) ≫ ι j = f) : cocone F :=
{ X := X,
  ι :=
  { app := λ j, match j with
    | none := f
    | (some j) := ι j
    end,
    naturality' := λ j j' f, by { cases j; cases j'; cases f; unfold_aux; dsimp; simp [w], }, } }

end wide_pushout_shape

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

/-- `has_wide_pullbacks` represents a choice of wide pullback for every collection of morphisms -/
abbreviation has_wide_pullbacks : Prop :=
Π (J : Type w), has_limits_of_shape (wide_pullback_shape J) C

/-- `has_wide_pushouts` represents a choice of wide pushout for every collection of morphisms -/
abbreviation has_wide_pushouts : Prop :=
Π (J : Type w), has_colimits_of_shape (wide_pushout_shape J) C

variables {C J}

/-- `has_wide_pullback B objs arrows` means that `wide_cospan B objs arrows` has a limit. -/
abbreviation has_wide_pullback (B : C) (objs : J → C)
  (arrows : Π (j : J), objs j ⟶ B) : Prop :=
has_limit (wide_pullback_shape.wide_cospan B objs arrows)

/-- `has_wide_pushout B objs arrows` means that `wide_span B objs arrows` has a colimit. -/
abbreviation has_wide_pushout (B : C) (objs : J → C)
  (arrows : Π (j : J), B ⟶ objs j) : Prop :=
has_colimit (wide_pushout_shape.wide_span B objs arrows)

/-- A choice of wide pullback. -/
noncomputable
abbreviation wide_pullback (B : C) (objs : J → C) (arrows : Π (j : J), objs j ⟶ B)
  [has_wide_pullback B objs arrows] : C :=
limit (wide_pullback_shape.wide_cospan B objs arrows)

/-- A choice of wide pushout. -/
noncomputable
abbreviation wide_pushout (B : C) (objs : J → C) (arrows : Π (j : J), B ⟶ objs j)
  [has_wide_pushout B objs arrows] : C :=
colimit (wide_pushout_shape.wide_span B objs arrows)

variable (C)

namespace wide_pullback

variables {C} {B : C} {objs : J → C} (arrows : Π (j : J), objs j ⟶ B)
variables [has_wide_pullback B objs arrows]

/-- The `j`-th projection from the pullback. -/
noncomputable
abbreviation π (j : J) : wide_pullback _ _ arrows ⟶ objs j :=
limit.π (wide_pullback_shape.wide_cospan _ _ _) (option.some j)

/-- The unique map to the base from the pullback. -/
noncomputable
abbreviation base : wide_pullback _ _ arrows ⟶ B :=
limit.π (wide_pullback_shape.wide_cospan _ _ _) option.none

@[simp, reassoc]

variables {arrows}

/-- Lift a collection of morphisms to a morphism to the pullback. -/
noncomputable
abbreviation lift {X : C} (f : X ⟶ B) (fs : Π (j : J), X ⟶ objs j)
  (w : ∀ j, fs j ≫ arrows j = f) : X ⟶ wide_pullback _ _ arrows :=
limit.lift (wide_pullback_shape.wide_cospan _ _ _)
  (wide_pullback_shape.mk_cone f fs $ by exact w)

variables (arrows)

variables {X : C} (f : X ⟶ B) (fs : Π (j : J), X ⟶ objs j)
  (w : ∀ j, fs j ≫ arrows j = f)

@[simp, reassoc]
lemma lift_π (j : J) : lift f fs w ≫ π arrows j = fs _ :=
by { simp, refl }

@[simp, reassoc]
lemma lift_base : lift f fs w ≫ base arrows = f :=
by { simp, refl }

lemma eq_lift_of_comp_eq (g : X ⟶ wide_pullback _ _ arrows) :
  (∀ j : J, g ≫ π arrows j = fs j) → g ≫ base arrows = f → g = lift f fs w :=
begin
  intros h1 h2,
  apply (limit.is_limit (wide_pullback_shape.wide_cospan B objs arrows)).uniq
    (wide_pullback_shape.mk_cone f fs $ by exact w),
  rintro (_|_),
  { apply h2 },
  { apply h1 }
end

lemma hom_eq_lift (g : X ⟶ wide_pullback _ _ arrows) :
  g = lift (g ≫ base arrows) (λ j, g ≫ π arrows j) (by tidy) :=
begin
  apply eq_lift_of_comp_eq,
  tidy,
end

@[ext]
lemma hom_ext (g1 g2 : X ⟶ wide_pullback _ _ arrows) :
  (∀ j : J, g1 ≫ π arrows j = g2 ≫ π arrows j) →
  g1 ≫ base arrows = g2 ≫ base arrows → g1 = g2 :=
begin
  intros h1 h2,
  apply limit.hom_ext,
  rintros (_|_),
  { apply h2 },
  { apply h1 },
end

end wide_pullback

namespace wide_pushout

variables {C} {B : C} {objs : J → C} (arrows : Π (j : J), B ⟶ objs j)
variables [has_wide_pushout B objs arrows]

/-- The `j`-th inclusion to the pushout. -/
noncomputable
abbreviation ι (j : J) : objs j ⟶ wide_pushout _ _ arrows :=
colimit.ι (wide_pushout_shape.wide_span _ _ _) (option.some j)

/-- The unique map from the head to the pushout. -/
noncomputable
abbreviation head : B ⟶ wide_pushout B objs arrows :=
colimit.ι (wide_pushout_shape.wide_span _ _ _) option.none

@[simp, reassoc]
lemma arrow_ι (j : J) : arrows j ≫ ι arrows j = head arrows :=
by apply colimit.w (wide_pushout_shape.wide_span _ _ _) (wide_pushout_shape.hom.init j)

variables {arrows}

/-- Descend a collection of morphisms to a morphism from the pushout. -/
noncomputable
abbreviation desc {X : C} (f : B ⟶ X) (fs : Π (j : J), objs j ⟶ X)
  (w : ∀ j, arrows j ≫ fs j = f) : wide_pushout _ _ arrows ⟶ X :=
colimit.desc (wide_pushout_shape.wide_span B objs arrows)
  (wide_pushout_shape.mk_cocone f fs $ by exact w)

variables (arrows)

variables {X : C} (f : B ⟶ X) (fs : Π (j : J), objs j ⟶ X)
  (w : ∀ j, arrows j ≫ fs j = f)

@[simp, reassoc]
lemma ι_desc (j : J) : ι arrows j ≫ desc f fs w = fs _ :=
by { simp, refl }

@[simp, reassoc]
lemma head_desc : head arrows ≫ desc f fs w = f :=
by { simp, refl }

lemma eq_desc_of_comp_eq (g : wide_pushout _ _ arrows ⟶ X) :
  (∀ j : J, ι arrows j ≫ g = fs j) → head arrows ≫ g = f → g = desc f fs w :=
begin
  intros h1 h2,
  apply (colimit.is_colimit (wide_pushout_shape.wide_span B objs arrows)).uniq
    (wide_pushout_shape.mk_cocone f fs $ by exact w),
  rintro (_|_),
  { apply h2 },
  { apply h1 }
end

lemma hom_eq_desc (g : wide_pushout _ _ arrows ⟶ X) :
  g = desc (head arrows ≫ g) (λ j, ι arrows j ≫ g) (λ j, by { rw ← category.assoc, simp }) :=
begin
  apply eq_desc_of_comp_eq,
  tidy,
end

@[ext]
lemma hom_ext (g1 g2 : wide_pushout _ _ arrows ⟶ X) :
  (∀ j : J, ι arrows j ≫ g1 = ι arrows j ≫ g2) →
  head arrows ≫ g1 = head arrows ≫ g2 → g1 = g2 :=
begin
  intros h1 h2,
  apply colimit.hom_ext,
  rintros (_|_),
  { apply h2 },
  { apply h1 },
end

end wide_pushout

variable (J)

/-- The action on morphisms of the obvious functor
  `wide_pullback_shape_op : wide_pullback_shape J ⥤ (wide_pushout_shape J)ᵒᵖ`-/
def wide_pullback_shape_op_map : Π (X Y : wide_pullback_shape J),
  (X ⟶ Y) → ((op X : (wide_pushout_shape J)ᵒᵖ) ⟶ (op Y : (wide_pushout_shape J)ᵒᵖ))
| _ _ (wide_pullback_shape.hom.id X) := quiver.hom.op (wide_pushout_shape.hom.id _)
| _ _ (wide_pullback_shape.hom.term j) := quiver.hom.op (wide_pushout_shape.hom.init _)

/-- The obvious functor `wide_pullback_shape J ⥤ (wide_pushout_shape J)ᵒᵖ` -/
@[simps]
def wide_pullback_shape_op : wide_pullback_shape J ⥤ (wide_pushout_shape J)ᵒᵖ :=
{ obj := λ X, op X,
  map := wide_pullback_shape_op_map J, }

/-- The action on morphisms of the obvious functor
`wide_pushout_shape_op : `wide_pushout_shape J ⥤ (wide_pullback_shape J)ᵒᵖ` -/
def wide_pushout_shape_op_map : Π (X Y : wide_pushout_shape J),
  (X ⟶ Y) → ((op X : (wide_pullback_shape J)ᵒᵖ) ⟶ (op Y : (wide_pullback_shape J)ᵒᵖ))
| _ _ (wide_pushout_shape.hom.id X) := quiver.hom.op (wide_pullback_shape.hom.id _)
| _ _ (wide_pushout_shape.hom.init j) := quiver.hom.op (wide_pullback_shape.hom.term _)

/-- The obvious functor `wide_pushout_shape J ⥤ (wide_pullback_shape J)ᵒᵖ` -/
@[simps]
def wide_pushout_shape_op : wide_pushout_shape J ⥤ (wide_pullback_shape J)ᵒᵖ :=
{ obj := λ X, op X,
  map := wide_pushout_shape_op_map J, }

/-- The obvious functor `(wide_pullback_shape J)ᵒᵖ ⥤ wide_pushout_shape J`-/
@[simps]
def wide_pullback_shape_unop : (wide_pullback_shape J)ᵒᵖ ⥤ wide_pushout_shape J :=
(wide_pullback_shape_op J).left_op

/-- The obvious functor `(wide_pushout_shape J)ᵒᵖ ⥤ wide_pullback_shape J` -/
@[simps]
def wide_pushout_shape_unop : (wide_pushout_shape J)ᵒᵖ ⥤ wide_pullback_shape J :=
(wide_pushout_shape_op J).left_op

/-- The inverse of the unit isomorphism of the equivalence
`wide_pushout_shape_op_equiv : (wide_pushout_shape J)ᵒᵖ ≌ wide_pullback_shape J` -/
def wide_pushout_shape_op_unop : wide_pushout_shape_unop J ⋙ wide_pullback_shape_op J ≅ 𝟭 _ :=
nat_iso.of_components (λ X, iso.refl _) (λ X Y f, dec_trivial)

/-- The counit isomorphism of the equivalence
`wide_pullback_shape_op_equiv : (wide_pullback_shape J)ᵒᵖ ≌ wide_pushout_shape J` -/
def wide_pushout_shape_unop_op : wide_pushout_shape_op J ⋙ wide_pullback_shape_unop J ≅ 𝟭 _ :=
nat_iso.of_components (λ X, iso.refl _) (λ X Y f, dec_trivial)

/-- The inverse of the unit isomorphism of the equivalence
`wide_pullback_shape_op_equiv : (wide_pullback_shape J)ᵒᵖ ≌ wide_pushout_shape J` -/
def wide_pullback_shape_op_unop : wide_pullback_shape_unop J ⋙ wide_pushout_shape_op J ≅ 𝟭 _ :=
nat_iso.of_components (λ X, iso.refl _) (λ X Y f, dec_trivial)

/-- The counit isomorphism of the equivalence
`wide_pushout_shape_op_equiv : (wide_pushout_shape J)ᵒᵖ ≌ wide_pullback_shape J` -/
def wide_pullback_shape_unop_op : wide_pullback_shape_op J ⋙ wide_pushout_shape_unop J ≅ 𝟭 _ :=
nat_iso.of_components (λ X, iso.refl _) (λ X Y f, dec_trivial)

/-- The duality equivalence `(wide_pushout_shape J)ᵒᵖ ≌ wide_pullback_shape J` -/
@[simps]
def wide_pushout_shape_op_equiv : (wide_pushout_shape J)ᵒᵖ ≌ wide_pullback_shape J :=
{ functor := wide_pushout_shape_unop J,
  inverse := wide_pullback_shape_op J,
  unit_iso := (wide_pushout_shape_op_unop J).symm,
  counit_iso := wide_pullback_shape_unop_op J, }

/-- The duality equivalence `(wide_pullback_shape J)ᵒᵖ ≌ wide_pushout_shape J` -/
@[simps]
def wide_pullback_shape_op_equiv : (wide_pullback_shape J)ᵒᵖ ≌ wide_pushout_shape J :=
{ functor := wide_pullback_shape_unop J,
  inverse := wide_pushout_shape_op J,
  unit_iso := (wide_pullback_shape_op_unop J).symm,
  counit_iso := wide_pushout_shape_unop_op J, }

/-- If a category has wide pullbacks on a higher universe level it also has wide pullbacks
on a lower universe level. -/
lemma has_wide_pullbacks_shrink [has_wide_pullbacks.{max w w'} C] : has_wide_pullbacks.{w} C :=
λ J, has_limits_of_shape_of_equivalence
  (wide_pullback_shape.equivalence_of_equiv _ equiv.ulift.{w'})

end category_theory.limits


/-
Copyright © 2020 Nicolò Cavalleri. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Nicolò Cavalleri.
-/

import geometry.manifold.tangent_bundle_derivation
import ring_theory.derivation

noncomputable theory

open_locale lie_group manifold

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

def Lb (I : model_with_corners 𝕜 E H)
  (G : Type*) [topological_space G] [charted_space H G] [smooth_manifold_with_corners I G]
  [group G] [topological_group G] [lie_group I G] (g : G) : C∞(I, G; I, G) :=
⟨(L g), smooth_mul_left⟩

@[simp] lemma Lb_apply (I : model_with_corners 𝕜 E H)
  {G : Type*} [topological_space G] [charted_space H G] [smooth_manifold_with_corners I G]
  [group G] [topological_group G] [lie_group I G] (g h : G) :
  (Lb I G g) h = g * h := rfl

@[simp] lemma Lb_mul (I : model_with_corners 𝕜 E H)
  (G : Type*) [topological_space G] [charted_space H G] [smooth_manifold_with_corners I G]
  [group G] [topological_group G] [lie_group I G] (g h : G) :
  Lb I G (g * h) = (Lb I G g).comp (Lb I G h) :=
by ext; simp only [smooth_map.comp_apply, Lb_apply, mul_assoc]

lemma Lb_apply_one (I : model_with_corners 𝕜 E H) {G : Type*} [topological_space G]
  [charted_space H G] [smooth_manifold_with_corners I G] [group G] [topological_group G]
  [lie_group I G] (g : G) : (Lb I G g) 1 = g := by rw [Lb_apply, mul_one]

structure left_invariant_vector_field (I : model_with_corners 𝕜 E H)
  (G : Type*) [topological_space G] [charted_space H G] [smooth_manifold_with_corners I G]
  [group G] [topological_group G] [lie_group I G] extends vector_field_derivation I G :=
(left_invariant' : ∀ f g, to_vector_field_derivation.eval g f = (fd (Lb I G g)) (1 : G) (to_vector_field_derivation.eval (1 : G)) f)

variables {I : model_with_corners 𝕜 E H}
  {G : Type*} [topological_space G] [charted_space H G] [smooth_manifold_with_corners I G]
  [group G] [topological_group G] [lie_group I G]

namespace left_invariant_vector_field

instance : has_coe (left_invariant_vector_field I G) (vector_field_derivation I G)
:= ⟨λ X, X.to_vector_field_derivation⟩

@[simp] lemma to_vfield_der_eq_coe (X : left_invariant_vector_field I G) :
  X.to_vector_field_derivation = X := rfl

@[simp] lemma coe_lift_eq_coe (X : left_invariant_vector_field I G) :
  ⇑(X : vector_field_derivation I G) = (X : C∞(I, G; 𝕜) → C∞(I, G; 𝕜)) := rfl

variables
{M : Type*} [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M] {x : M}
(X Y : left_invariant_vector_field I G) (f : C∞(I, G; 𝕜)) (g h : G)

def eval : point_derivation I G g :=
X.to_vector_field_derivation.eval g

@[simp] lemma coe_eval : (X : vector_field_derivation I G).eval g = X.eval g := rfl

@[simp] lemma eval_apply : X.eval g f = (X f) g := rfl

lemma left_invariant : X.eval g f = (fd (Lb I G g)) (1 : G) (X.eval (1 : G)) f :=
X.left_invariant' f g

lemma left_invariant_ext :
  X.eval (g * h) f = (fd (Lb I G g)) h (X.eval h) f :=
by rw [left_invariant, Lb_mul, ←fdifferential_comp, function.comp, apply_fdifferential,
  ←left_invariant, ←apply_fdifferential]

@[simp] lemma leftinvfield_comp_Lb : (X f).comp (Lb I G g) = X (f.comp (Lb I G g)) :=
by ext h; rw [smooth_map.comp_apply, Lb_apply, ←eval_apply, left_invariant_ext,
  apply_fdifferential, eval_apply]

instance : has_zero (left_invariant_vector_field I G) := ⟨⟨0, λ f g,
  by { simp only [vector_field_derivation.zero_apply, vector_field_derivation.eval_apply], sorry }⟩⟩
instance : inhabited (left_invariant_vector_field I G) := ⟨0⟩

instance : add_comm_group (left_invariant_vector_field I G) :=
{
  add := λ X Y, ⟨X + Y, λ f g, by { sorry }⟩,
  add_assoc := λ X Y Z, ext $ λ a, add_assoc _ _ _,
  zero_add := λ X, ext $ λ a, zero_add _,
  add_zero := λ X, ext $ λ a, add_zero _,
  add_comm := λ X Y, ext $ λ a, add_comm _ _,
  neg := λ X, ⟨-X⟩,
  add_left_neg := λ X, ext $ λ a, add_left_neg _,
  ..left_invariant_vector_field.has_zero
}

instance : module 𝕜 (left_invariant_vector_field I G) :=
semimodule.of_core $
{
  smul := λ r X, ⟨r • X, λ f g, by { sorry, }⟩,
  mul_smul := λ r s X, ext $ λ b, mul_smul _ _ _,
  one_smul := λ X, ext $ λ b, one_smul 𝕜 _,
  smul_add := λ r X Y, ext $ λ b, smul_add _ _ _,
  add_smul := λ r s X, ext $ λ b, add_smul _ _ _,
  ..vector_field_derivation.has_scalar
}

instance : has_bracket (left_invariant_vector_field I G) :=
{ bracket := λ X Y, ⟨⁅X, Y⁆, begin
    intros f g,
    have hX := X.left_invariant' (Y f) g, have hY := Y.left_invariant' (X f) g,
    simp only [apply_fdifferential, to_vfield_der_eq_coe, vector_field_derivation.eval_apply,
      coe_lift_eq_coe] at hX hY,
    simp only [apply_fdifferential, vector_field_derivation.eval_apply,
      vector_field_derivation.commutator_apply, coe_lift_eq_coe, to_vfield_der_eq_coe,
      smooth_map.sub_apply, hX, hY, leftinvfield_comp_Lb], end⟩ }

@[simp] lemma commutator_coe_vector_field_derivation :
  ⇑⁅X, Y⁆ = (⁅X, Y⁆ : vector_field_derivation I G) := rfl

lemma commutator_apply : ⁅X, Y⁆ f = X (Y f) - Y (X f) :=
by rw [commutator_coe_vector_field_derivation, vector_field_derivation.commutator_apply]; refl

instance : lie_ring (left_invariant_vector_field I G) :=
{ add_lie := λ X Y Z, by { sorry },
  lie_add := λ X Y Z, by { sorry },
  lie_self := λ X, by { sorry },
  jacobi := λ X Y Z, by { sorry } }

instance : lie_algebra 𝕜 (left_invariant_vector_field I G) :=
{ lie_smul := λ X Y Z, by { sorry, } }

end left_invariant_vector_field


import category_theory.arrow category_theory.category.Cat category_theory.abelian.transfer
import category_theory.limits.shapes.functor_category category_theory.limits.preserves.shapes.zero
import category_theory.abelian.functor_category
import algebra.homology.homology
import .category_theory

open category_theory

inductive walking_arrow
| source | target

inductive walking_arrow_hom : walking_arrow → walking_arrow → Type*
| id : Π {x : walking_arrow}, walking_arrow_hom x x
| arr : walking_arrow_hom walking_arrow.source walking_arrow.target

open walking_arrow walking_arrow_hom

def walking_arrow.comp : Π {x y z : walking_arrow},
  walking_arrow_hom x y → walking_arrow_hom y z → walking_arrow_hom x z
| _ _ _ id  id  := id
| _ _ _ id  arr := arr
| _ _ _ arr id  := arr

instance : small_category walking_arrow := {
  hom := walking_arrow_hom,
  id := λ x, walking_arrow_hom.id,
  comp := @walking_arrow.comp,
  id_comp' := by { intros X Y f, cases f; refl },
  comp_id' := by { intros X Y f, cases f; refl },
  assoc' := by { intros W X Y Z f g h, cases f; cases g; cases h; refl }
}

def walking_arrow.morphism_to_functor_obj {C : Type*} [category C] {x y : C} (f : x ⟶ y)
  : walking_arrow → C
| source := x
| target := y

def walking_arrow.morphism_to_functor_map {C : Type*} [category C] {x y : C} (f : x ⟶ y)
  : Π {a b : walking_arrow}, (a ⟶ b)
                           → (walking_arrow.morphism_to_functor_obj f a
                             ⟶ walking_arrow.morphism_to_functor_obj f b)
| _ _ id  := 𝟙 _
| _ _ arr := f

def walking_arrow.morphism_to_functor {C : Type*} [category C] {x y : C} (f : x ⟶ y)
  : walking_arrow ⥤ C := {
    obj := walking_arrow.morphism_to_functor_obj f,
    map := λ _ _, walking_arrow.morphism_to_functor_map f,
    map_comp' := by { intros X Y Z f g, cases f; cases g; symmetry;
                      dsimp [walking_arrow.comp, walking_arrow.morphism_to_functor_map];
                      try { exact category.id_comp' _ }; try { exact category.comp_id' _ }, }
  }

def walking_arrow.commutative_square_to_nat_trans_app {C : Type*} [category C] {x y x' y' : C}
  (f : x ⟶ y) (g : x' ⟶ y')
  (u : x ⟶ x') (v : y ⟶ y') (w : u ≫ g = f ≫ v)
  : Π (i : walking_arrow), (walking_arrow.morphism_to_functor f).obj i
                         ⟶ (walking_arrow.morphism_to_functor g).obj i
| source := u
| target := v

def arrow_category_iso_functor_category (C : Type*) [category C]
  : Cat.of (arrow C) ≅ Cat.of (walking_arrow ⥤ C) := {
  hom := {
    obj := λ f, walking_arrow.morphism_to_functor f.hom,
    map := λ f g w, {
      app := walking_arrow.commutative_square_to_nat_trans_app f.hom g.hom _ _ w.w,
      naturality' := by { intros i j a, cases a,
                          { delta walking_arrow.morphism_to_functor, unfold_projs,
                            simp [walking_arrow.morphism_to_functor_map] },
                          { symmetry, exact w.w } }
    },
    map_id' := by { intro X, ext i, cases i; refl },
    map_comp' := by { intros X Y Z f g, ext i, cases i; refl }
  },
  inv := {
    obj := λ f, arrow.mk (f.map walking_arrow_hom.arr),
    map := λ f g η, arrow.hom_mk (η.naturality walking_arrow_hom.arr).symm
  },
  hom_inv_id' := by { apply functor.hext,
                      { rintro ⟨_, _, f⟩, refl },
                      { rintros ⟨_, _, f⟩ ⟨_, _, g⟩ ⟨u, v, w⟩, refl } },
  inv_hom_id' := by { apply category_theory.functor.ext, swap,
                      { rintro ⟨f_obj, f_map, hf1, hf2⟩, apply functor.hext,
                        { intro i, cases i; refl },
                        { intros i j a, cases a,
                          { refine heq_of_eq_of_heq (category_theory.functor.map_id _ i)
                                    (heq_of_heq_of_eq _ (category_theory.functor.map_id _ i).symm),
                            congr' 1, cases i; refl },
                          { refl } } },
                      { rintro ⟨f_obj, f_map, hf1, hf2⟩ ⟨g_obj, g_map, hg1, hg2⟩ ⟨η, hη⟩,
                        rw Cat.comp_map, dsimp,
                        ext i, cases i; rw Cat.id_map;
                        repeat { rw nat_trans.comp_app };
                        rw [eq_to_hom_app, eq_to_hom_app, eq_to_hom_refl, eq_to_hom_refl,
                            category.id_comp, category.comp_id]; refl } }
}.

instance arrow_has_finite_limits {C : Type*} [category C] [limits.has_finite_limits C]
  : limits.has_finite_limits (arrow C) :=
  ⟨λ J i1 i2,  @adjunction.has_limits_of_shape_of_equivalence (walking_arrow ⥤ C) _ (arrow C) _ J i1
                                                              (category_theory.iso_to_equiv (arrow_category_iso_functor_category C)).functor
                                                              _
                                                              (@limits.has_finite_limits.out _ _ limits.functor_category_has_finite_limits J i1 i2)⟩.

instance {A : Type*} [category A] [preadditive A] {B : Type*} [category B] [preadditive B]
         {T : Type*} [category T] [preadditive T]
         {L : A ⥤ T} [L.additive] {R : B ⥤ T} [R.additive]
         (X Y : comma L R) : add_comm_group (comma_morphism X Y) := {
    add := λ w v, ⟨w.left + v.left, w.right + v.right, by simp⟩,
    zero := ⟨0, 0, by simp⟩,
    neg := λ w, ⟨-w.left, -w.right, by simp⟩,
    add_assoc := by { rintros ⟨wl, wr, hw⟩ ⟨vl, vr, hv⟩ ⟨ul, ur, hu⟩, apply comma_morphism.ext,
                      { exact add_assoc wl vl ul }, { exact add_assoc wr vr ur } },
    zero_add := by { rintro ⟨wl, wr, hw⟩, apply comma_morphism.ext,
                     { exact zero_add wl }, { exact zero_add wr } },
    add_zero := by { rintro ⟨wl, wr, hw⟩, apply comma_morphism.ext,
                     { exact add_zero wl }, { exact add_zero wr } },
    add_left_neg := by { rintro ⟨wl, wr, hw⟩, apply comma_morphism.ext,
                         { exact add_left_neg wl }, { exact add_left_neg wr } },
    add_comm := by { rintros ⟨wl, wr, hw⟩ ⟨vl, vr, hv⟩, apply comma_morphism.ext,
                     { exact add_comm wl vl }, { exact add_comm wr vr } }
  }.

@[simp]
lemma comma.add_left_eq {A : Type*} [category A] [preadditive A]
                        {B : Type*} [category B] [preadditive B]
                        {T : Type*} [category T] [preadditive T]
                        {L : A ⥤ T} [L.additive] {R : B ⥤ T} [R.additive]
                        {P Q : comma L R} (f g : P ⟶ Q)
                       : (f + g).left = f.left + g.left := rfl

@[simp]
lemma comma.add_right_eq {A : Type*} [category A] [preadditive A]
                         {B : Type*} [category B] [preadditive B]
                         {T : Type*} [category T] [preadditive T]
                         {L : A ⥤ T} [L.additive] {R : B ⥤ T} [R.additive]
                         {P Q : comma L R} (f g : P ⟶ Q)
                        : (f + g).right = f.right + g.right := rfl

instance {A : Type*} [category A] [preadditive A] {B : Type*} [category B] [preadditive B]
         {T : Type*} [category T] [preadditive T]
         {L : A ⥤ T} [L.additive] {R : B ⥤ T} [R.additive]
         : preadditive (comma L R) := {}.

instance arrow_preadditive {V : Type*} [category V] [preadditive V] : preadditive (arrow V) :=
category_theory.comma.category_theory.preadditive.

instance arrow_iso_functor_preserves_zero {V : Type*} [category V] [preadditive V]
  : @functor.preserves_zero_morphisms (arrow V) _ (walking_arrow ⥤ V) _
                                      (@preadditive.preadditive_has_zero_morphisms _ _ arrow_preadditive) _
                                      (arrow_category_iso_functor_category V).hom :=
  ⟨by { intros f g, ext i, cases i; refl }⟩

noncomputable
instance arr_ab {V : Type*} [category V] [abelian V] : abelian (arrow V) :=
  @abelian_of_equivalence _ _ arrow_preadditive _
                          (walking_arrow ⥤ V) _ _
                          (category_theory.iso_to_equiv (arrow_category_iso_functor_category V)).functor
                          arrow_iso_functor_preserves_zero _.

universes v' v u'' u' u
open category_theory.limits

def mk_arrow_diagram {C : Type u} [category.{v} C]
  {J : Type*} [category J] {K1 K2 : J ⥤ C} (η : K1 ⟶ K2)
  : J ⥤ arrow C := {
    obj := λ j, arrow.mk (η.app j),
    map := λ i j f, arrow.hom_mk' (η.naturality f)
  }.

def mk_arrow_cocone {C : Type u} [category.{v} C]
  {J : Type*} [category J] (K1 K2 : J ⥤ C) (η : K1 ⟶ K2)
  {c1 : cocone K1} (hc1 : is_colimit c1) (c2 : cocone K2)
  : cocone (mk_arrow_diagram η) := {
    X := hc1.desc ((cocones.precompose η).obj c2),
    ι := { app := λ j, arrow.hom_mk' (eq.trans (hc1.fac _ j) (congr_fun (congr_arg _ (cocones.precompose_obj_ι η c2)) j)),
           naturality' := by { intros, ext; dsimp [mk_arrow_diagram]; simp } }
  }.

noncomputable
def preserves_colim_into_arrow_category {C : Type u} [category.{(max u'' v)} C]
  {D : Type u'} [category.{v'} D] (F : arrow C ⥤ D)
  {J : Type u''} [small_category J] {K : J ⥤ arrow C}
  [has_colimits C]
  (H : ∀ {c1 : cocone (K ⋙ arrow.left_func)} (hc1 : is_colimit c1)
         {c2 : cocone (K ⋙ arrow.right_func)} (hc2 : is_colimit c2),
         is_colimit (F.map_cocone (mk_arrow_cocone (K ⋙ arrow.left_func) (K ⋙ arrow.right_func)
                                                   (whisker_left K arrow.left_to_right) hc1 c2)))
  : preserves_colimit K F :=
begin
  let e := category_theory.iso_to_equiv (arrow_category_iso_functor_category C),
  refine category_theory.limits.preserves_colimits_of_equiv_domain _ e _,
  constructor, intros c hc,
  let h := λ k,
          @preserves_colimits_of_shape.preserves_colimit _ _ _ _ _ _ _
            (@preserves_colimits_of_size.preserves_colimits_of_shape _ _ _ _ _
              (@limits.preserves_colimits_of_size_shrink _ _ _ _ _
                (@limits.evaluation_preserves_colimits C _ walking_arrow _ _ k)) J _)
            (K ⋙ e.functor),
  let hSource := @limits.is_colimit_of_preserves _ _ _ _ _ _ _ _ _ hc (h walking_arrow.source),
  let hTarget := @limits.is_colimit_of_preserves _ _ _ _ _ _ _ _ _ hc (h walking_arrow.target),
  refine is_colimit.of_iso_colimit _ (functor.map_cocone_comp' (K ⋙ e.functor) e.inverse F c).symm,
  convert H hSource hTarget,
  dsimp [mk_arrow_cocone, mk_arrow_diagram, functor.map_cocone,
          cocones.functoriality, cocones.precompose],
  have : ∀ h, c.X.map arr
            = hSource.desc { X := c.X.obj target,
                             ι := @whisker_left J _ (arrow C) _ C _ K _ _ arrow.left_to_right
                                  ≫ { app := λ (j : J), (c.ι.app j).app target,
                                      naturality' := h }},
  { intro h, refine hSource.hom_ext _, intro j,
    rw hSource.fac,
    symmetry,
    simp,
    refine eq.trans _ ((c.ι.app j).naturality arr),
    refl },
  congr,
  { dsimp [e, category_theory.iso_to_equiv, arrow_category_iso_functor_category],
    congr,
    apply this },
  { dsimp [e, category_theory.iso_to_equiv, arrow_category_iso_functor_category,
           functor.associator, category_struct.comp, nat_trans.vcomp],
    congr,
    { apply this },
    { ext, refl, intros j j' h, cases h, rw category.id_comp _, congr,
      { apply this },
      { apply this },
      { apply proof_irrel_heq } },
    { apply proof_irrel_heq } }
end.


/-
Copyright (c) 2021 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang
-/
import topology.gluing
import algebraic_geometry.open_immersion
import algebraic_geometry.locally_ringed_space.has_colimits

/-!
# Gluing Structured spaces

Given a family of gluing data of structured spaces (presheafed spaces, sheafed spaces, or locally
ringed spaces), we may glue them together.

The construction should be "sealed" and considered as a black box, while only using the API
provided.

## Main definitions

* `algebraic_geometry.PresheafedSpace.glue_data`: A structure containing the family of gluing data.
* `category_theory.glue_data.glued`: The glued presheafed space.
    This is defined as the multicoequalizer of `∐ V i j ⇉ ∐ U i`, so that the general colimit API
    can be used.
* `category_theory.glue_data.ι`: The immersion `ι i : U i ⟶ glued` for each `i : J`.

## Main results

* `algebraic_geometry.PresheafedSpace.glue_data.ι_is_open_immersion`: The map `ι i : U i ⟶ glued`
  is an open immersion for each `i : J`.
* `algebraic_geometry.PresheafedSpace.glue_data.ι_jointly_surjective` : The underlying maps of
  `ι i : U i ⟶ glued` are jointly surjective.
* `algebraic_geometry.PresheafedSpace.glue_data.V_pullback_cone_is_limit` : `V i j` is the pullback
  (intersection) of `U i` and `U j` over the glued space.

Analogous results are also provided for `SheafedSpace` and `LocallyRingedSpace`.

## Implementation details

Almost the whole file is dedicated to showing tht `ι i` is an open immersion. The fact that
this is an open embedding of topological spaces follows from `topology.gluing.lean`, and it remains
to construct `Γ(𝒪_{U_i}, U) ⟶ Γ(𝒪_X, ι i '' U)` for each `U ⊆ U i`.
Since `Γ(𝒪_X, ι i '' U)` is the the limit of `diagram_over_open`, the components of the structure
sheafs of the spaces in the gluing diagram, we need to construct a map
`ι_inv_app_π_app : Γ(𝒪_{U_i}, U) ⟶ Γ(𝒪_V, U_V)` for each `V` in the gluing diagram.

We will refer to ![this diagram](https://i.imgur.com/P0phrwr.png) in the following doc strings.
The `X` is the glued space, and the dotted arrow is a partial inverse guaranteed by the fact
that it is an open immersion. The map `Γ(𝒪_{U_i}, U) ⟶ Γ(𝒪_{U_j}, _)` is given by the composition
of the red arrows, and the map `Γ(𝒪_{U_i}, U) ⟶ Γ(𝒪_{V_{jk}}, _)` is given by the composition of the
blue arrows. To lift this into a map from `Γ(𝒪_X, ι i '' U)`, we also need to show that these
commute with the maps in the diagram (the green arrows), which is just a lengthy diagram-chasing.

-/

noncomputable theory

open topological_space category_theory opposite
open category_theory.limits algebraic_geometry.PresheafedSpace
open category_theory.glue_data

namespace algebraic_geometry

universes v u

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

namespace PresheafedSpace

/--
A family of gluing data consists of
1. An index type `J`
2. A presheafed space `U i` for each `i : J`.
3. A presheafed space `V i j` for each `i j : J`.
  (Note that this is `J × J → PresheafedSpace C` rather than `J → J → PresheafedSpace C` to
  connect to the limits library easier.)
4. An open immersion `f i j : V i j ⟶ U i` for each `i j : ι`.
5. A transition map `t i j : V i j ⟶ V j i` for each `i j : ι`.
such that
6. `f i i` is an isomorphism.
7. `t i i` is the identity.
8. `V i j ×[U i] V i k ⟶ V i j ⟶ V j i` factors through `V j k ×[U j] V j i ⟶ V j i` via some
    `t' : V i j ×[U i] V i k ⟶ V j k ×[U j] V j i`.
9. `t' i j k ≫ t' j k i ≫ t' k i j = 𝟙 _`.

We can then glue the spaces `U i` together by identifying `V i j` with `V j i`, such
that the `U i`'s are open subspaces of the glued space.
-/
@[nolint has_nonempty_instance]
structure glue_data extends glue_data (PresheafedSpace.{v} C) :=
(f_open : ∀ i j, is_open_immersion (f i j))

attribute [instance] glue_data.f_open

namespace glue_data

variables {C} (D : glue_data C)

local notation `𝖣` := D.to_glue_data
local notation `π₁ `i`, `j`, `k := @pullback.fst _ _ _ _ _ (D.f i j) (D.f i k) _
local notation `π₂ `i`, `j`, `k := @pullback.snd _ _ _ _ _ (D.f i j) (D.f i k) _
local notation `π₁⁻¹ `i`, `j`, `k :=
(PresheafedSpace.is_open_immersion.pullback_fst_of_right (D.f i j) (D.f i k)).inv_app
local notation `π₂⁻¹ `i`, `j`, `k :=
(PresheafedSpace.is_open_immersion.pullback_snd_of_left (D.f i j) (D.f i k)).inv_app

/-- The glue data of topological spaces associated to a family of glue data of PresheafedSpaces. -/
abbreviation to_Top_glue_data : Top.glue_data :=
{ f_open := λ i j, (D.f_open i j).base_open,
  to_glue_data := 𝖣 .map_glue_data (forget C) }

lemma ι_open_embedding [has_limits C] (i : D.J) : open_embedding (𝖣 .ι i).base :=
begin
  rw ← (show _ = (𝖣 .ι i).base, from 𝖣 .ι_glued_iso_inv (PresheafedSpace.forget _) _),
  exact open_embedding.comp (Top.homeo_of_iso
    (𝖣 .glued_iso (PresheafedSpace.forget _)).symm).open_embedding
    (D.to_Top_glue_data.ι_open_embedding i)
end

lemma pullback_base (i j k : D.J)  (S : set (D.V (i, j)).carrier) :
  (π₂ i, j, k) '' ((π₁ i, j, k) ⁻¹' S) = D.f i k ⁻¹' (D.f i j '' S) :=
begin
  have eq₁ : _ = (π₁ i, j, k).base := preserves_pullback.iso_hom_fst (forget C) _ _,
  have eq₂ : _ = (π₂ i, j, k).base := preserves_pullback.iso_hom_snd (forget C) _ _,
  rw [coe_to_fun_eq, coe_to_fun_eq, ← eq₁, ← eq₂, coe_comp, set.image_comp, coe_comp,
    set.preimage_comp, set.image_preimage_eq, Top.pullback_snd_image_fst_preimage],
  refl,
  rw ← Top.epi_iff_surjective,
  apply_instance
end

/-- The red and the blue arrows in ![this diagram](https://i.imgur.com/0GiBUh6.png) commute. -/
@[simp, reassoc]
lemma f_inv_app_f_app (i j k : D.J)  (U : (opens (D.V (i, j)).carrier)) :
  (D.f_open i j).inv_app U ≫ (D.f i k).c.app _ =
    (π₁ i, j, k).c.app (op U) ≫ (π₂⁻¹ i, j, k) (unop _) ≫ (D.V _).presheaf.map (eq_to_hom
      (begin
        delta is_open_immersion.open_functor,
        dsimp only [functor.op, is_open_map.functor, opens.map, unop_op],
        congr,
        apply pullback_base,
      end)) :=
begin
  have := PresheafedSpace.congr_app (@pullback.condition _ _ _ _ _ (D.f i j) (D.f i k) _),
  dsimp only [comp_c_app] at this,
  rw [← cancel_epi (inv ((D.f_open i j).inv_app U)), is_iso.inv_hom_id_assoc,
    is_open_immersion.inv_inv_app],
  simp_rw category.assoc,
  erw [(π₁ i, j, k).c.naturality_assoc,
    reassoc_of this, ← functor.map_comp_assoc, is_open_immersion.inv_naturality_assoc,
    is_open_immersion.app_inv_app_assoc, ← (D.V (i, k)).presheaf.map_comp,
    ← (D.V (i, k)).presheaf.map_comp],
  convert (category.comp_id _).symm,
  erw (D.V (i, k)).presheaf.map_id,
  refl
end

/--
We can prove the `eq` along with the lemma. Thus this is bundled together here, and the
lemma itself is separated below.
-/
lemma snd_inv_app_t_app' (i j k : D.J) (U : opens (pullback (D.f i j) (D.f i k)).carrier) :
  ∃ eq, (π₂⁻¹ i, j, k) U ≫ (D.t k i).c.app _ ≫ (D.V (k, i)).presheaf.map (eq_to_hom eq) =
    (D.t' k i j).c.app _ ≫ (π₁⁻¹ k, j, i) (unop _) :=
begin
  split,
  rw [← is_iso.eq_inv_comp, is_open_immersion.inv_inv_app, category.assoc,
    (D.t' k i j).c.naturality_assoc],
  simp_rw ← category.assoc,
  erw ← comp_c_app,
  rw [congr_app (D.t_fac k i j), comp_c_app],
  simp_rw category.assoc,
  erw [is_open_immersion.inv_naturality, is_open_immersion.inv_naturality_assoc,
    is_open_immersion.app_inv_app'_assoc],
  simp_rw [← (𝖣 .V (k, i)).presheaf.map_comp,
    eq_to_hom_map (functor.op _), eq_to_hom_op, eq_to_hom_trans],
  rintros x ⟨y, hy, eq⟩,
  replace eq := concrete_category.congr_arg ((𝖣 .t i k).base) eq,
  change ((π₂ i, j, k) ≫ D.t i k).base y = (D.t k i ≫ D.t i k).base x at eq,
  rw [𝖣 .t_inv, id_base, Top.id_app] at eq,
  subst eq,
  use (inv (D.t' k i j)).base y,
  change ((inv (D.t' k i j)) ≫ (π₁ k, i, j)).base y = _,
  congr' 2,
  rw [is_iso.inv_comp_eq, 𝖣 .t_fac_assoc, 𝖣 .t_inv, category.comp_id]
end

/-- The red and the blue arrows in ![this diagram](https://i.imgur.com/q6X1GJ9.png) commute. -/
@[simp, reassoc]
lemma snd_inv_app_t_app (i j k : D.J) (U : opens (pullback (D.f i j) (D.f i k)).carrier) :
  (π₂⁻¹ i, j, k) U ≫ (D.t k i).c.app _ = (D.t' k i j).c.app _ ≫ (π₁⁻¹ k, j, i) (unop _) ≫
    (D.V (k, i)).presheaf.map (eq_to_hom (D.snd_inv_app_t_app' i j k U).some.symm) :=
begin
  have e := (D.snd_inv_app_t_app' i j k U).some_spec,
  reassoc! e,
  rw ← e,
  simp [eq_to_hom_map],
end

variable [has_limits C]

lemma ι_image_preimage_eq (i j : D.J) (U : opens (D.U i).carrier) :
  (opens.map (𝖣 .ι j).base).obj ((D.ι_open_embedding i).is_open_map.functor.obj U) =
  (D.f_open j i).open_functor.obj ((opens.map (𝖣 .t j i).base).obj
    ((opens.map (𝖣 .f i j).base).obj U)) :=
begin
  ext1,
  dsimp only [opens.map_coe, is_open_map.functor_obj_coe],
  rw [← (show _ = (𝖣 .ι i).base, from 𝖣 .ι_glued_iso_inv (PresheafedSpace.forget _) i),
    ← (show _ = (𝖣 .ι j).base, from 𝖣 .ι_glued_iso_inv (PresheafedSpace.forget _) j),
    coe_comp, coe_comp, set.image_comp, set.preimage_comp, set.preimage_image_eq],
  refine eq.trans (D.to_Top_glue_data.preimage_image_eq_image' _ _ _) _,
  rw [coe_comp, set.image_comp],
  congr' 1,
  erw set.eq_preimage_iff_image_eq,
  rw ← set.image_comp,
  change (D.t i j ≫ D.t j i).base '' _ = _,
  rw 𝖣 .t_inv,
  { simp },
  { change function.bijective (Top.homeo_of_iso (as_iso _)),
    exact homeomorph.bijective _,
    apply_instance },
  { rw ← Top.mono_iff_injective,
    apply_instance }
end

/-- (Implementation). The map `Γ(𝒪_{U_i}, U) ⟶ Γ(𝒪_{U_j}, 𝖣.ι j ⁻¹' (𝖣.ι i '' U))` -/
def opens_image_preimage_map (i j : D.J) (U : opens (D.U i).carrier) :
  (D.U i).presheaf.obj (op U) ⟶ (D.U j).presheaf.obj _ :=
(D.f i j).c.app (op U) ≫ (D.t j i).c.app _ ≫ (D.f_open j i).inv_app (unop _) ≫
  (𝖣 .U j).presheaf.map (eq_to_hom (D.ι_image_preimage_eq i j U)).op

lemma opens_image_preimage_map_app' (i j k : D.J) (U : opens (D.U i).carrier) :
  ∃ eq, D.opens_image_preimage_map i j U ≫ (D.f j k).c.app _ =
    ((π₁ j, i, k) ≫ D.t j i ≫ D.f i j).c.app (op U) ≫ (π₂⁻¹ j, i, k) (unop _) ≫
      (D.V (j, k)).presheaf.map (eq_to_hom eq) :=
begin
  split,
  delta opens_image_preimage_map,
  simp_rw category.assoc,
  rw [(D.f j k).c.naturality, f_inv_app_f_app_assoc],
  erw ← (D.V (j, k)).presheaf.map_comp,
  simp_rw ← category.assoc,
  erw [← comp_c_app, ← comp_c_app],
  simp_rw category.assoc,
  dsimp only [functor.op, unop_op, quiver.hom.unop_op],
  rw [eq_to_hom_map (opens.map _), eq_to_hom_op, eq_to_hom_trans],
  congr
end

/-- The red and the blue arrows in ![this diagram](https://i.imgur.com/mBzV1Rx.png) commute. -/
lemma opens_image_preimage_map_app (i j k : D.J) (U : opens (D.U i).carrier) :
  D.opens_image_preimage_map i j U ≫ (D.f j k).c.app _ =
  ((π₁ j, i, k) ≫ D.t j i ≫ D.f i j).c.app (op U) ≫ (π₂⁻¹ j, i, k) (unop _) ≫
    (D.V (j, k)).presheaf.map (eq_to_hom ((opens_image_preimage_map_app' D i j k U).some)) :=
(opens_image_preimage_map_app' D i j k U).some_spec

-- This is proved separately since `reassoc` somehow timeouts.
lemma opens_image_preimage_map_app_assoc (i j k : D.J) (U : opens (D.U i).carrier)
  {X' : C} (f' : _ ⟶ X') :
  D.opens_image_preimage_map i j U ≫ (D.f j k).c.app _ ≫ f' =
    ((π₁ j, i, k) ≫ D.t j i ≫ D.f i j).c.app (op U) ≫ (π₂⁻¹ j, i, k) (unop _) ≫
    (D.V (j, k)).presheaf.map (eq_to_hom ((opens_image_preimage_map_app' D i j k U).some)) ≫ f' :=
by simpa only [category.assoc]
  using congr_arg (λ g, g ≫ f') (opens_image_preimage_map_app D i j k U)

/-- (Implementation) Given an open subset of one of the spaces `U ⊆ Uᵢ`, the sheaf component of
the image `ι '' U` in the glued space is the limit of this diagram. -/
abbreviation diagram_over_open {i : D.J} (U : opens (D.U i).carrier) :
  (walking_multispan _ _)ᵒᵖ ⥤ C :=
componentwise_diagram 𝖣 .diagram.multispan ((D.ι_open_embedding i).is_open_map.functor.obj U)

/-- (Implementation)
The projection from the limit of `diagram_over_open` to a component of `D.U j`. -/
abbreviation diagram_over_open_π {i : D.J} (U : opens (D.U i).carrier) (j : D.J) :=
limit.π (D.diagram_over_open U) (op (walking_multispan.right j))

/-- (Implementation) We construct the map `Γ(𝒪_{U_i}, U) ⟶ Γ(𝒪_V, U_V)` for each `V` in the gluing
diagram. We will lift these maps into `ι_inv_app`. -/
def ι_inv_app_π_app {i : D.J} (U : opens (D.U i).carrier) (j) :
  (𝖣 .U i).presheaf.obj (op U) ⟶ (D.diagram_over_open U).obj (op j) :=
begin
  rcases j with (⟨j, k⟩|j),
  { refine D.opens_image_preimage_map i j U ≫ (D.f j k).c.app _ ≫
      (D.V (j, k)).presheaf.map (eq_to_hom _),
    rw [functor.op_obj],
    congr' 1, ext1,
    dsimp only [functor.op_obj, opens.map_coe, unop_op, is_open_map.functor_obj_coe],
    rw set.preimage_preimage,
    change (D.f j k ≫ 𝖣 .ι j).base ⁻¹' _ = _,
    congr' 3,
    exact colimit.w 𝖣 .diagram.multispan (walking_multispan.hom.fst (j, k)) },
  { exact D.opens_image_preimage_map i j U }
end

/-- (Implementation) The natural map `Γ(𝒪_{U_i}, U) ⟶ Γ(𝒪_X, 𝖣.ι i '' U)`.
This forms the inverse of `(𝖣.ι i).c.app (op U)`. -/
def ι_inv_app {i : D.J} (U : opens (D.U i).carrier) :
  (D.U i).presheaf.obj (op U) ⟶ limit (D.diagram_over_open U) :=
limit.lift (D.diagram_over_open U)
{ X := (D.U i).presheaf.obj (op U),
  π := { app := λ j, D.ι_inv_app_π_app U (unop j),
  naturality' := λ X Y f', begin
    induction X using opposite.rec,
    induction Y using opposite.rec,
    let f : Y ⟶ X := f'.unop, have : f' = f.op := rfl, clear_value f, subst this,
    rcases f with (_|⟨j,k⟩|⟨j,k⟩),
    { erw [category.id_comp, category_theory.functor.map_id],
      rw category.comp_id },
    { erw category.id_comp, congr' 1 },
    erw category.id_comp,
    -- It remains to show that the blue is equal to red + green in the original diagram.
    -- The proof strategy is illustrated in ![this diagram](https://i.imgur.com/mBzV1Rx.png)
    -- where we prove red = pink = light-blue = green = blue.
    change D.opens_image_preimage_map i j U ≫ (D.f j k).c.app _ ≫
      (D.V (j, k)).presheaf.map (eq_to_hom _) = D.opens_image_preimage_map _ _ _ ≫
      ((D.f k j).c.app _ ≫ (D.t j k).c.app _) ≫ (D.V (j, k)).presheaf.map (eq_to_hom _),
    erw opens_image_preimage_map_app_assoc,
    simp_rw category.assoc,
    erw [opens_image_preimage_map_app_assoc, (D.t j k).c.naturality_assoc],
    rw snd_inv_app_t_app_assoc,
    erw ← PresheafedSpace.comp_c_app_assoc,
    -- light-blue = green is relatively easy since the part that differs does not involve
    -- partial inverses.
    have : D.t' j k i ≫ (π₁ k, i, j) ≫ D.t k i ≫ 𝖣 .f i k =
      (pullback_symmetry _ _).hom ≫ (π₁ j, i, k) ≫ D.t j i ≫ D.f i j,
    { rw [← 𝖣 .t_fac_assoc, 𝖣 .t'_comp_eq_pullback_symmetry_assoc,
        pullback_symmetry_hom_comp_snd_assoc, pullback.condition, 𝖣 .t_fac_assoc] },
    rw congr_app this,
    erw PresheafedSpace.comp_c_app_assoc (pullback_symmetry _ _).hom,
    simp_rw category.assoc,
    congr' 1,
    rw ← is_iso.eq_inv_comp,
    erw is_open_immersion.inv_inv_app,
    simp_rw category.assoc,
    erw [nat_trans.naturality_assoc, ← PresheafedSpace.comp_c_app_assoc,
      congr_app (pullback_symmetry_hom_comp_snd _ _)],
    simp_rw category.assoc,
    erw [is_open_immersion.inv_naturality_assoc, is_open_immersion.inv_naturality_assoc,
      is_open_immersion.inv_naturality_assoc, is_open_immersion.app_inv_app_assoc],
    repeat { erw ← (D.V (j, k)).presheaf.map_comp },
    congr,
  end } }

/-- `ι_inv_app` is the left inverse of `D.ι i` on `U`. -/
lemma ι_inv_app_π {i : D.J} (U : opens (D.U i).carrier) :
  ∃ eq, D.ι_inv_app U ≫ D.diagram_over_open_π U i = (D.U i).presheaf.map (eq_to_hom eq) :=
begin
  split,
  delta ι_inv_app,
  rw limit.lift_π,
  change D.opens_image_preimage_map i i U = _,
  dsimp [opens_image_preimage_map],
  rw [congr_app (D.t_id _), id_c_app, ← functor.map_comp],
  erw [is_open_immersion.inv_naturality_assoc, is_open_immersion.app_inv_app'_assoc],
  simp only [eq_to_hom_op, eq_to_hom_trans, eq_to_hom_map (functor.op _), ← functor.map_comp],
  rw set.range_iff_surjective.mpr _,
  { simp },
  { rw ← Top.epi_iff_surjective,
    apply_instance }
end

/-- The `eq_to_hom` given by `ι_inv_app_π`. -/
abbreviation ι_inv_app_π_eq_map {i : D.J} (U : opens (D.U i).carrier) :=
(D.U i).presheaf.map (eq_to_iso (D.ι_inv_app_π U).some).inv

/-- `ι_inv_app` is the right inverse of `D.ι i` on `U`. -/
lemma π_ι_inv_app_π (i j : D.J) (U : opens (D.U i).carrier) :
  D.diagram_over_open_π U i ≫ D.ι_inv_app_π_eq_map U ≫ D.ι_inv_app U ≫
    D.diagram_over_open_π U j = D.diagram_over_open_π U j :=
begin
  rw ← cancel_mono ((componentwise_diagram 𝖣 .diagram.multispan _).map
    (quiver.hom.op (walking_multispan.hom.snd (i, j))) ≫ (𝟙 _)),
  simp_rw category.assoc,
  rw limit.w_assoc,
  erw limit.lift_π_assoc,
  rw [category.comp_id, category.comp_id],
  change _ ≫ _ ≫ (_ ≫ _) ≫ _ = _,
  rw [congr_app (D.t_id _), id_c_app],
  simp_rw category.assoc,
  rw [← functor.map_comp_assoc, is_open_immersion.inv_naturality_assoc],
  erw is_open_immersion.app_inv_app_assoc,
  iterate 3 { rw ← functor.map_comp_assoc },
  rw nat_trans.naturality_assoc,
  erw ← (D.V (i, j)).presheaf.map_comp,
  convert limit.w (componentwise_diagram 𝖣 .diagram.multispan _)
    (quiver.hom.op (walking_multispan.hom.fst (i, j))),
  { rw category.comp_id,
    apply_with mono_comp { instances := ff },
    change mono ((_ ≫ D.f j i).c.app _),
    rw comp_c_app,
    apply_with mono_comp { instances := ff },
    erw D.ι_image_preimage_eq i j U,
    all_goals { apply_instance } },
end

/-- `ι_inv_app` is the inverse of `D.ι i` on `U`. -/
lemma π_ι_inv_app_eq_id (i : D.J) (U : opens (D.U i).carrier) :
  D.diagram_over_open_π U i ≫ D.ι_inv_app_π_eq_map U ≫ D.ι_inv_app U = 𝟙 _ :=
begin
  ext j,
  induction j using opposite.rec,
  rcases j with (⟨j, k⟩|⟨j⟩),
  { rw [← limit.w (componentwise_diagram 𝖣 .diagram.multispan _)
      (quiver.hom.op (walking_multispan.hom.fst (j, k))), ← category.assoc, category.id_comp],
    congr' 1,
    simp_rw category.assoc,
    apply π_ι_inv_app_π },
  { simp_rw category.assoc,
    rw category.id_comp,
    apply π_ι_inv_app_π }
end

instance componentwise_diagram_π_is_iso (i : D.J) (U : opens (D.U i).carrier) :
  is_iso (D.diagram_over_open_π U i) :=
begin
  use D.ι_inv_app_π_eq_map U ≫ D.ι_inv_app U,
  split,
  { apply π_ι_inv_app_eq_id },
  { rw [category.assoc, (D.ι_inv_app_π _).some_spec],
    exact iso.inv_hom_id ((D.to_glue_data.U i).presheaf.map_iso (eq_to_iso _)) }
end

instance ι_is_open_immersion (i : D.J) :
  is_open_immersion (𝖣 .ι i) :=
{ base_open := D.ι_open_embedding i,
  c_iso := λ U, by { erw ← colimit_presheaf_obj_iso_componentwise_limit_hom_π, apply_instance } }

/-- The following diagram is a pullback, i.e. `Vᵢⱼ` is the intersection of `Uᵢ` and `Uⱼ` in `X`.

Vᵢⱼ ⟶ Uᵢ
 |      |
 ↓      ↓
 Uⱼ ⟶ X
-/
def V_pullback_cone_is_limit (i j : D.J) : is_limit (𝖣 .V_pullback_cone i j) :=
pullback_cone.is_limit_aux' _ $ λ s,
begin
  refine ⟨_, _, _, _⟩,
  { refine PresheafedSpace.is_open_immersion.lift (D.f i j) s.fst _,
    erw ← D.to_Top_glue_data.preimage_range j i,
    have : s.fst.base ≫ D.to_Top_glue_data.to_glue_data.ι i =
      s.snd.base ≫ D.to_Top_glue_data.to_glue_data.ι j,
    { rw [← 𝖣 .ι_glued_iso_hom (PresheafedSpace.forget _) _,
        ← 𝖣 .ι_glued_iso_hom (PresheafedSpace.forget _) _],
      have := congr_arg PresheafedSpace.hom.base s.condition,
      rw [comp_base, comp_base] at this,
      reassoc! this,
      exact this _ },
    rw [← set.image_subset_iff, ← set.image_univ, ← set.image_comp, set.image_univ,
      ← coe_comp, this, coe_comp, ← set.image_univ, set.image_comp],
    exact set.image_subset_range _ _ },
  { apply is_open_immersion.lift_fac },
  { rw [← cancel_mono (𝖣 .ι j), category.assoc, ← (𝖣 .V_pullback_cone i j).condition],
    conv_rhs { rw ← s.condition },
    erw is_open_immersion.lift_fac_assoc },
  { intros m e₁ e₂, rw ← cancel_mono (D.f i j), erw e₁, rw is_open_immersion.lift_fac }
end

lemma ι_jointly_surjective (x : 𝖣 .glued) :
  ∃ (i : D.J) (y : D.U i), (𝖣 .ι i).base y = x :=
𝖣 .ι_jointly_surjective (PresheafedSpace.forget _ ⋙ category_theory.forget Top) x

end glue_data

end PresheafedSpace

namespace SheafedSpace

variables (C) [has_products.{v} C]

/--
A family of gluing data consists of
1. An index type `J`
2. A sheafed space `U i` for each `i : J`.
3. A sheafed space `V i j` for each `i j : J`.
  (Note that this is `J × J → SheafedSpace C` rather than `J → J → SheafedSpace C` to
  connect to the limits library easier.)
4. An open immersion `f i j : V i j ⟶ U i` for each `i j : ι`.
5. A transition map `t i j : V i j ⟶ V j i` for each `i j : ι`.
such that
6. `f i i` is an isomorphism.
7. `t i i` is the identity.
8. `V i j ×[U i] V i k ⟶ V i j ⟶ V j i` factors through `V j k ×[U j] V j i ⟶ V j i` via some
    `t' : V i j ×[U i] V i k ⟶ V j k ×[U j] V j i`.
9. `t' i j k ≫ t' j k i ≫ t' k i j = 𝟙 _`.

We can then glue the spaces `U i` together by identifying `V i j` with `V j i`, such
that the `U i`'s are open subspaces of the glued space.
-/
@[nolint has_nonempty_instance]
structure glue_data extends glue_data (SheafedSpace.{v} C) :=
(f_open : ∀ i j, SheafedSpace.is_open_immersion (f i j))

attribute [instance] glue_data.f_open

namespace glue_data

variables {C} (D : glue_data C)

local notation `𝖣` := D.to_glue_data

/-- The glue data of presheafed spaces associated to a family of glue data of sheafed spaces. -/
abbreviation to_PresheafedSpace_glue_data : PresheafedSpace.glue_data C :=
{ f_open := D.f_open,
  to_glue_data := 𝖣 .map_glue_data forget_to_PresheafedSpace }

variable [has_limits C]

/-- The gluing as sheafed spaces is isomorphic to the gluing as presheafed spaces. -/
abbreviation iso_PresheafedSpace : 𝖣 .glued.to_PresheafedSpace ≅
  D.to_PresheafedSpace_glue_data.to_glue_data.glued :=
𝖣 .glued_iso forget_to_PresheafedSpace

lemma ι_iso_PresheafedSpace_inv (i : D.J) :
  D.to_PresheafedSpace_glue_data.to_glue_data.ι i ≫ D.iso_PresheafedSpace.inv = 𝖣 .ι i :=
𝖣 .ι_glued_iso_inv _ _

instance ι_is_open_immersion (i : D.J) :
  is_open_immersion (𝖣 .ι i) :=
by { rw ← D.ι_iso_PresheafedSpace_inv, apply_instance }

lemma ι_jointly_surjective (x : 𝖣 .glued) :
  ∃ (i : D.J) (y : D.U i), (𝖣 .ι i).base y = x :=
𝖣 .ι_jointly_surjective (SheafedSpace.forget _ ⋙ category_theory.forget Top) x

/-- The following diagram is a pullback, i.e. `Vᵢⱼ` is the intersection of `Uᵢ` and `Uⱼ` in `X`.

Vᵢⱼ ⟶ Uᵢ
 |      |
 ↓      ↓
 Uⱼ ⟶ X
-/
def V_pullback_cone_is_limit (i j : D.J) : is_limit (𝖣 .V_pullback_cone i j) :=
𝖣 .V_pullback_cone_is_limit_of_map forget_to_PresheafedSpace i j
  (D.to_PresheafedSpace_glue_data.V_pullback_cone_is_limit _ _)

end glue_data

end SheafedSpace

namespace LocallyRingedSpace

/--
A family of gluing data consists of
1. An index type `J`
2. A locally ringed space `U i` for each `i : J`.
3. A locally ringed space `V i j` for each `i j : J`.
  (Note that this is `J × J → LocallyRingedSpace` rather than `J → J → LocallyRingedSpace` to
  connect to the limits library easier.)
4. An open immersion `f i j : V i j ⟶ U i` for each `i j : ι`.
5. A transition map `t i j : V i j ⟶ V j i` for each `i j : ι`.
such that
6. `f i i` is an isomorphism.
7. `t i i` is the identity.
8. `V i j ×[U i] V i k ⟶ V i j ⟶ V j i` factors through `V j k ×[U j] V j i ⟶ V j i` via some
    `t' : V i j ×[U i] V i k ⟶ V j k ×[U j] V j i`.
9. `t' i j k ≫ t' j k i ≫ t' k i j = 𝟙 _`.

We can then glue the spaces `U i` together by identifying `V i j` with `V j i`, such
that the `U i`'s are open subspaces of the glued space.
-/
@[nolint has_nonempty_instance]
structure glue_data extends glue_data LocallyRingedSpace :=
(f_open : ∀ i j, LocallyRingedSpace.is_open_immersion (f i j))

attribute [instance] glue_data.f_open

namespace glue_data

variables (D : glue_data)

local notation `𝖣` := D.to_glue_data

/-- The glue data of ringed spaces associated to a family of glue data of locally ringed spaces. -/
abbreviation to_SheafedSpace_glue_data : SheafedSpace.glue_data CommRing :=
{ f_open := D.f_open,
  to_glue_data := 𝖣 .map_glue_data forget_to_SheafedSpace }

/-- The gluing as locally ringed spaces is isomorphic to the gluing as ringed spaces. -/
abbreviation iso_SheafedSpace : 𝖣 .glued.to_SheafedSpace ≅
  D.to_SheafedSpace_glue_data.to_glue_data.glued :=
𝖣 .glued_iso forget_to_SheafedSpace

instance ι_is_open_immersion (i : D.J) :
  is_open_immersion (𝖣 .ι i) :=
by { delta is_open_immersion, rw ← D.ι_iso_SheafedSpace_inv,
  apply PresheafedSpace.is_open_immersion.comp }

instance (i j k : D.J) :
  preserves_limit (cospan (𝖣 .f i j) (𝖣 .f i k)) forget_to_SheafedSpace :=
infer_instance

lemma ι_jointly_surjective (x : 𝖣 .glued) :
  ∃ (i : D.J) (y : D.U i), (𝖣 .ι i).1.base y = x :=
𝖣 .ι_jointly_surjective ((LocallyRingedSpace.forget_to_SheafedSpace ⋙
  SheafedSpace.forget _) ⋙ forget Top) x

/-- The following diagram is a pullback, i.e. `Vᵢⱼ` is the intersection of `Uᵢ` and `Uⱼ` in `X`.

Vᵢⱼ ⟶ Uᵢ
 |      |
 ↓      ↓
 Uⱼ ⟶ X
-/
def V_pullback_cone_is_limit (i j : D.J) : is_limit (𝖣 .V_pullback_cone i j) :=
𝖣 .V_pullback_cone_is_limit_of_map forget_to_SheafedSpace i j
  (D.to_SheafedSpace_glue_data.V_pullback_cone_is_limit _ _)

end glue_data

end LocallyRingedSpace

end algebraic_geometry


import definitions
import wellformedness
import tactic

namespace TT

variables p q r φ ψ : term
variable {Γ : context}

lemma from_imp {Γ : context} : entails Γ ⊤ (q ⟹ r) → entails Γ q r :=
begin
  intro h₁,
  apply entails.cut _ (⊤ ⋀ q) _,
  apply_rules [entails.and_intro, entails.vac, entails.axm];
    { apply @WF.imp_left _ q r,
      exact WF.proof_right h₁
    },
  exact entails.imp_to_and h₁,
end

lemma to_imp {Γ : context} : entails Γ q r → entails Γ ⊤ (q ⟹ r) :=
begin
  intro h₁,
  apply_rules [entails.and_to_imp, entails.cut _ q _, entails.and_right _ ⊤ _, entails.axm],
  WF_prover,
  apply WF.proof_left h₁,
end
lemma entails.or_inl (wfq : WF Γ Ω q) (prfp :entails Γ ⊤ p) : entails Γ ⊤ (p ⋁ q) :=
  by {apply entails.cut _ p _, assumption, apply entails.or_left _ q, apply entails.axm, apply_rules [WF.or, WF.proof_right]}
lemma entails.or_inr (wfq : WF Γ Ω p) (prfp :entails Γ ⊤ q) : entails Γ ⊤ (p ⋁ q) :=
  by {apply entails.cut _ q _, assumption, apply entails.or_right _ q, apply entails.axm, apply_rules [WF.or, WF.proof_right]}

lemma proof_of_and_left (_ : WF Γ Ω p) (_ : WF Γ Ω q) : entails Γ (p ⋀ q) p :=
  by {intros, apply entails.and_left _ p q, apply entails.axm, apply WF.and, tidy}
lemma proof_of_and_right (_ : WF Γ Ω p) (_ : WF Γ Ω q) : entails Γ (p ⋀ q) q :=
  by {apply entails.and_right _ p q, apply entails.axm, apply WF.and, tidy}

example (_ : WF Γ Ω p) (_ : WF Γ Ω q) : entails Γ (p ⋀ q) (q ⋀ p) :=
begin
  apply entails.and_intro,
  apply proof_of_and_right,
  tidy,
  apply proof_of_and_left,
  tidy
end

lemma eq_sound {A : type} {a₁ a₂ : term} (eq : ⊨ (a₁ ≃[A] a₂)) (φ : term) : entails Γ ⊤ ⁅φ // a₁⁆ → entails Γ ⊤ ⁅φ // a₂⁆ :=
by sorry

lemma reverse_extensionality (A : type) : ⊨ (∀' (𝒫 A) $ ∀' (𝒫 A) $ (↑1 ≃[𝒫 A] ↑0) ⟹ (∀' A ((↑0 ∈ ↑2) ⇔ (↑0 ∈ ↑1)))) :=
begin
  apply entails.all_intro 𝒫 A,
  apply entails.all_intro 𝒫 A,
  apply to_imp,
  apply from_meta_imp,
  any_goals {apply_rules WF_rules; refl},
  intro h,
  sorry
end

def is_star {Γ : context} {a : term} : WF Γ 𝟙 a → entails Γ ⊤ (a ≃[𝟙] ⁎) :=
begin
  intro wfa,
  apply entails.sub 𝟙 a ⊤ (↑0 ≃[𝟙] ⁎),
  assumption,
  have : (⊤ : term) = ^ ⊤, by rw WF.lift_closed; exact WF.top,
  rw this,
  apply entails.all_elim,
  rw ←list.nil_append Γ,
  apply entails.weakening,
  exact entails.star_unique
end

local notation `[]` := list.nil

lemma phi_ent_phi_and_top (h : WF [] Ω φ): φ ⊨ (φ ⋀ ⊤) :=
begin
  apply entails.and_intro,
  apply entails.axm,
  exact h,
  apply entails.vac,
  exact h
end

section meta_conversion

lemma ent_to_meta {p} {wfP : WF [] Ω p} : entails Γ φ ψ  → entails Γ p φ → entails Γ p ψ :=
  λ _ _, (by {apply entails.cut _ φ _, tidy})

lemma meta_to_ent (wfφ : WF Γ Ω φ) : (∀ p, entails Γ p φ → entails Γ p ψ) → entails Γ φ ψ :=
  λ h, h φ (entails.axm wfφ)

end meta_conversion

end TT


theorem zero_lt_of_lt : {a b : Nat} → a < b → 0 < b
| 0,   _, h => h
| a+1, b, h =>
  have : a < b := Nat.lt_trans (Nat.lt_succ_self _) h
  zero_lt_of_lt this

def fold {m α β} [Monad m] (as : Array α) (b : β) (f : α → β → m β) : m β := do
let rec loop : (i : Nat) → i ≤ as.size → β → m β
  | 0,   h, b => b
  | i+1, h, b => do
    have h' : i < as.size          := Nat.lt_of_lt_of_le (Nat.lt_succ_self i) h
    have : as.size - 1 < as.size     := Nat.sub_lt (zero_lt_of_lt h') (by decide)
    have : as.size - 1 - i < as.size := Nat.lt_of_le_of_lt (Nat.sub_le (as.size - 1) i) this
    let b ← f (as.get ⟨as.size - 1 - i, this⟩) b
    loop i (Nat.le_of_lt h') b
loop as.size (Nat.le_refl _) b

#eval Id.run $ fold #[1, 2, 3, 4] 0 (pure $ · + ·)

theorem ex : (Id.run $ fold #[1, 2, 3, 4] 0 (pure $ · + ·)) = 10 :=
rfl

def fold2 {m α β} [Monad m] (as : Array α) (b : β) (f : α → β → m β) : m β :=
let rec loop (i : Nat) (h : i ≤ as.size) (b : β) : m β := do
  match i, h with
  | 0,   h => return b
  | i+1, h =>
    have h' : i < as.size          := Nat.lt_of_lt_of_le (Nat.lt_succ_self i) h
    have : as.size - 1 < as.size     := Nat.sub_lt (zero_lt_of_lt h') (by decide)
    have : as.size - 1 - i < as.size := Nat.lt_of_le_of_lt (Nat.sub_le (as.size - 1) i) this
    let b ← f (as.get ⟨as.size - 1 - i, this⟩) b
    loop i (Nat.le_of_lt h') b
loop as.size (Nat.le_refl _) b

def f (x : Nat) (ref : IO.Ref Nat) : IO Nat := do
let mut x := x
if x == 0 then
  x ← ref.get
IO.println x
return x + 1

def fTest : IO Unit := do
unless (← f 0 (← IO.mkRef 10)) == 11 do throw $ IO.userError "unexpected"
unless (← f 1 (← IO.mkRef 10)) == 2 do throw $ IO.userError "unexpected"

def g (x y : Nat) (ref : IO.Ref (Nat × Nat)) : IO (Nat × Nat) := do
  let mut (x, y) := (x, y)
  if x == 0 then
    (x, y) ← ref.get
  IO.println ("x: " ++ toString x ++ ", y: " ++ toString y)
  return (x, y)

def gTest : IO Unit := do
unless (← g 2 1 (← IO.mkRef (10, 20))) == (2, 1)   do throw $ IO.userError "unexpected"
unless (← g 0 1 (← IO.mkRef (10, 20))) == (10, 20) do throw $ IO.userError "unexpected"
return ()

#eval gTest

macro "ret!" x:term : doElem => `(return $x)

def f1 (x : Nat) : Nat := do
  let mut x := x
  if x == 0 then
    ret! 100
  x := x + 1
  ret! x

theorem ex1 : f1 0 = 100 := rfl
theorem ex2 : f1 1 = 2 := rfl
theorem ex3 : f1 3 = 4 := rfl

syntax "inc!" ident : doElem

macro_rules
| `(doElem| inc! $x) => `(doElem| $x:ident := $x + 1)

def f2 (x : Nat) : Nat := do
  let mut x := x
  inc! x
  ret! x

theorem ex4 : f2 0 = 1 := rfl
theorem ex5 : f2 3 = 4 := rfl


example (A B C D E F G H I J K L : Type)
(f1 : A → B) (f2 : B → E) (f3 : E → D) (f4 : D → A) (f5 : E → F)
(f6 : F → C) (f7 : B → C) (f8 : F → G) (f9 : G → J) (f10 : I → J)
(f11 : J → I) (f12 : I → H) (f13 : E → H) (f14 : H → K) (f15 : I → L)
 : A → L :=
begin
intro a,
apply f15,
apply f11,
apply f9,
apply f8,
apply f5,
apply f2,
apply f1,
exact a,
end


import linear_algebra.exterior_algebra  algebra.homology.resolution algebra.algebra.subalgebra linear_algebra.basis algebra.homology.chain_complex algebra.category.Module.basic
variables (R : Type*) (M : Type*)
open_locale classical tensor_product
/-
local attribute [semireducible] tensor_algebra exterior_algebra ring_quot
section
variables [comm_semiring R] [add_comm_monoid M] [semimodule R M]

def algebra_alg_hom (S : Type*) [semiring S] [algebra R S] : R →ₐ[R] S :=
{  commutes' := λ r, rfl,
   ..algebra_map R S }

def tensor_algebra.quot :
  free_algebra R M →ₐ[R] tensor_algebra R M :=
ring_quot.mk_alg_hom R (tensor_algebra.rel R M)

def power (n : ℕ) : submodule R (tensor_algebra R M) :=
submodule.span R (set.range $ @tensor_algebra.mk R _ M _ _ n)

variables [comm_semiring R] [add_comm_monoid M] [semimodule R M]

open exterior_algebra homological_complex tensor_algebra

def of_scalar : R →ₐ[R] exterior_algebra R M :=
(exterior_algebra.quot R M).comp
((ring_quot.mk_alg_hom R (tensor_algebra.rel R M)).comp
(algebra_alg_hom R (free_algebra R M)))

def lift {B : Type*} [add_comm_monoid B] [semimodule R B] (n : ℕ)
  (f : @multilinear_map R (fin n) (λ i, M) B _ _ _ _ _ _) :
   power R M n →ₗ[R] B :=
{ to_fun := λ x, quot.lift_on x,
  map_add' := _,
  map_smul' := _ }

--def power (n : ℕ) : submodule R (tensor_algebra R M) :=

def hm : submodule.span R (set.range (@wedge R _ M _ _ 0)) ≃ₗ[R] R :=
{ to_fun := _,
  map_add' := _,
  map_smul' := _,
  inv_fun := _,
  left_inv := _,
  right_inv := _ }

class is_power (n : ℕ) (N : Module R) :=
(quot : @multilinear_map R (fin n) (λ i, M) N _ _ _ _ _ _)
(property : ∀ (B : Module R) (f : @multilinear_map R (fin n) (λ i, M) B _ _ _ _ _ _),
 ∃! F : N →ₗ[R] B, F.comp_multilinear_map quot = f)
#print prefix power
def power_to_algebra (n : ℕ) (N : Module R) [is_power R M n N] :
  N →ₗ[R] tensor_algebra R M :=
{ to_fun := λ x, is_power.property
  map_add' := _,
  map_smul' := _ }

#exit
--if h : n = 0 then subalgebra.to_submodule (of_scalar R M).range else
--submodule.span R (set.range (@wedge R _ M _ _ n))
variables {R M}
lemma power_zero (n : ℕ) (h : n = 0) :
  power R M n = subalgebra.to_submodule (of_scalar R M).range :=
if_pos h

lemma power_nonzero (n : ℕ) (h : n ≠ 0) :
  power R M n = submodule.span R (set.range (@wedge R _ M _ _ n)) :=
if_neg h
variables (R)
-- m ∈ M corresponds to φ ∈ Hom(R, M)
def power_diff (i : ℕ) (x : M) : power R M i.succ →ₗ[R] power R M i :=
linear_map.cod_restrict _ ((algebra.lmul R _ $ ι R x).comp (submodule.subtype _)) $
  begin
    suffices : ∀ y ∈ set.range (@wedge R _ M _ _ i.succ),
      algebra.lmul R (exterior_algebra R M) (ι R x) y ∈ set.range (@wedge R _ M _ _ i), by
    {intro c,
    unfold power,
    split_ifs,

    rw power_nonzero _ (nat.succ_ne_zero _),},
    rintro ⟨y, hy⟩,
    rw power_nonzero _ (nat.succ_ne_zero _) at hy,
    /-suffices : ((algebra.lmul R (exterior_algebra R M) $ ι R x).comp (submodule.subtype $ power R M i.succ)).range ≤ power R M i,
    from λ c, this (linear_map.mem_range.2 ⟨c, rfl⟩),
    --erw submodule.map_span,
    rw power_nonzero _ (nat.succ_ne_zero _),
    unfold linear_map.range,
    erw submodule.map_span,-/

  end

variables [comm_ring R] [add_comm_group M] [module R M]

structure koszul_complex (x : M) :=
(C : chain_complex (Module R))
(iso_at_nat : ∀ n : ℕ, C.X n ≅ Module.of R (power R M n))
(bdd_below : bounded_below_by C 0)
(differential : ∀ i, C.d i = sorry)

end exterior_algebra
-/