import for_mathlib.category_theory.localization.predicate
import category_theory.adjunction.limits
import category_theory.is_connected
import for_mathlib.category_theory.localization.products
import for_mathlib.category_theory.localization.opposite

noncomputable theory

open category_theory category_theory.category

namespace category_theory

namespace limits

def is_terminal.of_equivalence {C D : Type*} [category C] [category D] (e : C ≌ D) {X : C}
  (hX : is_terminal X) : is_terminal (e.functor.obj X) :=
begin
  change is_limit _,
  let e' : functor.empty C ⋙ e.functor ≅ functor.empty D := functor.empty_ext _ _,
  equiv_rw (is_limit.postcompose_inv_equiv e' _).symm,
  exact is_limit.of_iso_limit (is_limit_of_preserves e.functor hX)
    (cones.ext (iso.refl _) (by rintro ⟨⟨⟩⟩)),
end

end limits

@[simps]
instance localization.lifting.of_comp {C D E : Type*} [category C] [category D] [category E]
  (L : C ⥤ D) (W : morphism_property C) [L.is_localization W] (F : D ⥤ E) :
  localization.lifting L W (L ⋙ F) F := ⟨iso.refl _⟩

section

variables (C : Type*) [category C]

inductive obj_rel : C → C → Prop
| of_hom ⦃X Y : C⦄ (f : X ⟶ Y) : obj_rel X Y

def connected_components := quot (obj_rel C)

variable {C}

def to_connected_components (X : C) : connected_components C :=
quot.mk _ X

variable (C)

class is_preconnected' : Prop :=
(subsingleton_connected_components : subsingleton (connected_components C))

attribute [instance] is_preconnected'.subsingleton_connected_components

class is_connected' extends is_preconnected' C : Prop :=
[is_nonempty : nonempty C]

lemma connected_components.nat_trans_from_eq {D : Type*} [category D]
  (X Y : D) (α : (functor.const C).obj X ⟶ (functor.const C).obj Y)
  (j j' : C) (h : to_connected_components j = to_connected_components j') :
    α.app j = (α.app j' : X ⟶ Y) :=
begin
  let β : C → (X ⟶ Y) := λ j, α.app j,
  let l : connected_components C → (X ⟶ Y),
  { refine quot.lift β _,
    rintro x y ⟨f⟩,
    dsimp [β],
    have eq := α.naturality f,
    dsimp at eq,
    rw [id_comp, comp_id] at eq,
    rw eq, },
  have hl : ∀ (j : C), α.app j = l (to_connected_components j) := λ j, rfl,
  simp only [hl, h],
end

lemma nat_trans_from_is_preconnected' {D : Type*} [category D]
  [is_preconnected' C] (X Y : D) (α : (functor.const C).obj X ⟶ (functor.const C).obj Y)
  (j j' : C) : α.app j = (α.app j' : X ⟶ Y) :=
begin
  apply connected_components.nat_trans_from_eq,
  apply subsingleton.elim,
end

@[simps]
def connected_components.op_equiv :
  connected_components C ≃ connected_components Cᵒᵖ :=
{ to_fun := quot.lift (λ X, to_connected_components (opposite.op X))
    (by { rintros X Y ⟨f⟩, symmetry, exact quot.sound ⟨f.op⟩, }),
  inv_fun := quot.lift (λ X, to_connected_components (opposite.unop X))
    (by { rintros X Y ⟨f⟩, symmetry, exact quot.sound ⟨f.unop⟩, }),
  left_inv := by { rintro ⟨X⟩, refl, },
  right_inv := by { rintro ⟨X⟩, refl, }, }

variables {C} {D E : Type*} [category D] [category E]

def connected_components.map (F : C ⥤ D) :
  connected_components C → connected_components D :=
quot.lift (λ X, to_connected_components (F.obj X))
  (by { rintros X Y ⟨f⟩, exact quot.sound ⟨F.map f⟩, })

@[simp]
lemma connected_components.map_id (C : Type*) [category C] :
  connected_components.map (𝟭 C) = id := by tidy

@[simp]
lemma connected_components.map_id_apply (x : connected_components C) :
  connected_components.map (𝟭 C) x = x :=
by simp only [connected_components.map_id, id.def]

@[simp]
lemma connected_components.map_comp (F : C ⥤ D) (G : D ⥤ E) :
  connected_components.map (F ⋙ G) =
    connected_components.map G ∘ connected_components.map F := by tidy

@[simp]
lemma connected_components.map_comp_apply (F : C ⥤ D) (G : D ⥤ E) (x : connected_components C) :
  connected_components.map (F ⋙ G) x =
  connected_components.map G (connected_components.map F x) :=
by simp only [connected_components.map_comp]

lemma connected_components.map_eq_of_nat_trans {F G : C ⥤ D} (τ : F ⟶ G) :
  connected_components.map F = connected_components.map G :=
by { ext ⟨X⟩, exact quot.sound ⟨τ.app X⟩, }

lemma connected_components.map_eq_of_nat_trans_apply {F G : C ⥤ D} (τ : F ⟶ G)
  (x : connected_components C):
  connected_components.map F x = connected_components.map G x :=
by rw connected_components.map_eq_of_nat_trans τ

@[simps]
def connected_components.equiv_of_equivalence (e : C ≌ D) :
  connected_components C ≃ connected_components D :=
{ to_fun := connected_components.map e.functor,
  inv_fun := connected_components.map e.inverse,
  left_inv := λ x, by simpa only [connected_components.map_comp_apply,
    connected_components.map_id_apply]
    using connected_components.map_eq_of_nat_trans_apply e.unit_iso.inv x,
  right_inv := λ x, by simpa only [connected_components.map_comp_apply,
    connected_components.map_id_apply]
    using connected_components.map_eq_of_nat_trans_apply e.counit_iso.hom x, }

lemma is_preconnected'.of_equivalence (e : C ≌ D) (h : is_preconnected' C) :
  is_preconnected' D :=
⟨⟨λ X Y, (connected_components.equiv_of_equivalence e).symm.injective (subsingleton.elim _ _)⟩⟩

lemma is_connected'.of_equivalence (e : C ≌ D) (h : is_connected' C) :
  is_connected' D :=
begin
  haveI : nonempty D := ⟨e.functor.obj h.is_nonempty.some⟩,
  haveI : is_preconnected' D := is_preconnected'.of_equivalence e h.1,
  constructor,
end

lemma is_preconnected'.op (h : is_preconnected' C) : is_preconnected' Cᵒᵖ :=
⟨⟨λ X Y, (connected_components.op_equiv C).symm.injective (subsingleton.elim _ _)⟩⟩

lemma is_preconnected'.unop (h : is_preconnected' Cᵒᵖ) : is_preconnected' C :=
⟨⟨λ X Y, (connected_components.op_equiv C).injective (subsingleton.elim _ _)⟩⟩

lemma is_connected'.op (h : is_connected' C) : is_connected' Cᵒᵖ :=
begin
  haveI : nonempty Cᵒᵖ := ⟨opposite.op h.is_nonempty.some⟩,
  haveI : is_preconnected' Cᵒᵖ := is_preconnected'.op infer_instance,
  constructor,
end

lemma is_connected'.unop (h : is_connected' Cᵒᵖ) : is_connected' C :=
begin
  haveI : nonempty C := ⟨opposite.unop h.is_nonempty.some⟩,
  haveI : is_preconnected' C := is_preconnected'.unop infer_instance,
  constructor,
end

end

namespace morphism_property

variables {C : Type*} [category C] (W : morphism_property C)

class multiplicative : Prop :=
(contains_identities [] : W.contains_identities)
(comp [] : W.stable_under_composition)

section

variable [multiplicative W]

@[priority 100]
instance contains_identities_of_multiplicative : W.contains_identities :=
multiplicative.contains_identities _

instance : multiplicative W.op :=
{ contains_identities := (multiplicative.contains_identities W).op,
  comp := (multiplicative.comp W).op, }

include W
@[protected, nolint unused_arguments]
structure category :=
(obj : C)

variable {W}

@[ext]
structure category.hom (X Y : W.category) :=
(f : X.obj ⟶ Y.obj)
(hf : W f)

@[simps]
instance : category W.category :=
{ hom := category.hom,
  id := λ X,
  { f := 𝟙 _,
    hf := contains_identities.id _ _, },
  comp := λ X Y Z φ φ',
  { f := φ.f ≫ φ'.f,
    hf := multiplicative.comp W φ.f φ'.f φ.hf φ'.hf, }, }

@[simps]
def category.mk_iso {X Y : W.category} (e : X.obj ≅ Y.obj) (h₁ : W e.hom) (h₂ : W e.inv) :
  X ≅ Y :=
{ hom := ⟨e.hom, h₁⟩,
  inv := ⟨e.inv, h₂⟩, }

end

end morphism_property

namespace functor

variables (C₁ C₂ C₃ : Type*) [category C₁] [category C₂] [category C₃]
  (F : C₁ ⥤ C₂) (G : C₂ ⥤ C₃)

@[simps]
def whiskering_left_id : (whiskering_left C₁ C₁ C₃).obj (𝟭 C₁) ≅ 𝟭 _ :=
nat_iso.of_components functor.left_unitor (by tidy)

@[simps]
def whiskering_right_id : (whiskering_right C₁ C₃ C₃).obj (𝟭 C₃) ≅ 𝟭 _ :=
nat_iso.of_components functor.right_unitor (by tidy)

variables {C₁ C₂}

@[simps]
def equivalence_whiskering_left (e : C₁ ≌ C₂) : (C₂ ⥤ C₃) ≌ C₁ ⥤ C₃ :=
{ functor := (whiskering_left _ _ _).obj e.functor,
  inverse := (whiskering_left _ _ _).obj e.inverse,
  unit_iso := (whiskering_left_id _ _).symm ≪≫ (whiskering_left _ _ C₃).map_iso e.counit_iso.symm,
  counit_iso := (whiskering_left _ _ C₃).map_iso e.unit_iso.symm ≪≫ whiskering_left_id _ _,
  functor_unit_iso_comp' := λ F, begin
    ext X,
    dsimp,
    simp only [id_comp, comp_id, ← F.map_comp, equivalence.counit_inv_functor_comp, F.map_id],
  end, }

instance is_equivalence_whiskering_left [is_equivalence F] :
  is_equivalence ((whiskering_left _ _ C₃).obj F) :=
is_equivalence.of_equivalence (equivalence_whiskering_left C₃ (as_equivalence F))

variables {C₂ C₃} (C₁)

@[simps]
def equivalence_whiskering_right (e : C₂ ≌ C₃) : (C₁ ⥤ C₂) ≌ C₁ ⥤ C₃ :=
{ functor := (whiskering_right _ _ _).obj e.functor,
  inverse := (whiskering_right _ _ _).obj e.inverse,
  unit_iso := (whiskering_right_id C₁ C₂).symm ≪≫ (whiskering_right C₁ _ _).map_iso e.unit_iso,
  counit_iso := (whiskering_right C₁ _ _).map_iso e.counit_iso ≪≫ whiskering_right_id C₁ C₃,
  functor_unit_iso_comp' := λ F, begin
    ext X,
    dsimp,
    simp,
  end, }

instance is_equivalence_whiskering_right [is_equivalence G] :
  is_equivalence ((whiskering_right C₁ _ _).obj G) :=
is_equivalence.of_equivalence (equivalence_whiskering_right C₁ (as_equivalence G))

end functor

namespace structured_arrow

variables {C₀ C₁ C₂ C₃ : Type*} [category C₀] [category C₁] [category C₂] [category C₃]
  (X₃ X₃' : C₃) (f : X₃' ⟶ X₃) (F : C₁ ⥤ C₂) (eF : C₁ ≌ C₂)
  (G G' G'' : C₂ ⥤ C₃) (τ τ' : G ⟶ G') (τ'' : G' ⟶ G'') (eG : G ≅ G')

@[simps]
def whiskering_left : structured_arrow X₃ (F ⋙ G) ⥤ structured_arrow X₃ G :=
{ obj := λ X₂, mk X₂.hom,
  map := λ X₂ X₂' φ, hom_mk (F.map φ.right) (w φ), }

variables {X₃ X₃'}

@[simps]
def precomp : structured_arrow X₃ G ⥤ structured_arrow X₃' G :=
{ obj := λ X₂, mk (f ≫ X₂.hom),
  map := λ X₂ X₂' φ, hom_mk φ.right (by tidy), }

variables {G G'} (X₃)

@[simps]
def postcomp : structured_arrow X₃ G ⥤ structured_arrow X₃ G' :=
{ obj := λ X₂, mk (X₂.hom ≫ τ.app X₂.right),
  map := λ X₂ X₂' φ, hom_mk φ.right begin
    dsimp,
    simp only [assoc, ← τ.naturality, w_assoc φ],
  end, }

variable (G)

@[simps]
def postcomp_id : postcomp X₃ (𝟙 G) ≅ 𝟭 _ :=
nat_iso.of_components (λ X, structured_arrow.iso_mk (iso.refl _) (by tidy)) (by tidy)

variable {G}

@[simps]
def postcomp_comp : postcomp X₃ τ ⋙ postcomp X₃ τ'' ≅
  postcomp X₃ (τ ≫ τ'') :=
nat_iso.of_components (λ X, structured_arrow.iso_mk (iso.refl _) (by tidy)) (by tidy)

@[simps]
def postcomp_iso_of_eq (h : τ = τ') : postcomp X₃ τ ≅ postcomp X₃ τ' :=
nat_iso.of_components (λ X, structured_arrow.iso_mk (iso.refl _)
  (by { dsimp, rw [G'.map_id, comp_id, h], })) (by tidy)

@[simps]
def postcomp_iso : equivalence (structured_arrow X₃ G) (structured_arrow X₃ G') :=
{ functor := postcomp X₃ eG.hom,
  inverse := postcomp X₃ eG.inv,
  unit_iso := (postcomp_id X₃ G).symm ≪≫ postcomp_iso_of_eq X₃ _ _ eG.hom_inv_id.symm ≪≫
    (postcomp_comp _ _ _ _).symm,
  counit_iso := postcomp_comp _ _ _ _ ≪≫ postcomp_iso_of_eq X₃ _ _ eG.inv_hom_id ≪≫
    (postcomp_id X₃ G'), }

instance [is_iso τ] : is_equivalence (postcomp X₃ τ) :=
is_equivalence.of_equivalence (postcomp_iso X₃ (as_iso τ))

variable (G)

@[simps]
def whiskering_left_equivalence :
equivalence (structured_arrow X₃ (eF.functor ⋙ G)) (structured_arrow X₃ G) :=
{ functor := whiskering_left X₃ eF.functor G,
  inverse := (postcomp_iso X₃ ((functor.left_unitor _).symm ≪≫
      iso_whisker_right eF.counit_iso.symm _≪≫ functor.associator _ _ _)).functor ⋙
    whiskering_left X₃ eF.inverse (eF.functor ⋙ G),
  unit_iso := nat_iso.of_components
    (λ Y, structured_arrow.iso_mk (eF.unit_iso.app _) begin
      dsimp,
      simp only [comp_id, id_comp],
      congr' 2,
      simpa only [← cancel_mono (eF.counit_iso.hom.app (eF.functor.obj Y.right)),
        equivalence.functor_unit_comp, iso.inv_hom_id_app],
    end) (by tidy),
  counit_iso := nat_iso.of_components
    (λ X, structured_arrow.iso_mk (eF.counit_iso.app _) begin
      dsimp,
      simp only [id_comp, assoc, ← G.map_comp, iso.inv_hom_id_app],
      dsimp,
      simp only [functor.map_id, comp_id],
    end) (by tidy), }

instance [is_equivalence F] : is_equivalence (whiskering_left X₃ F G) :=
is_equivalence.of_equivalence (whiskering_left_equivalence X₃ (functor.as_equivalence F) G)

end structured_arrow

namespace functor

variables {C D H : Type*} [category C] [category D] [category H]
  {F : C ⥤ D} (RF RF' : H ⥤ D) (e : RF ≅ RF') {L : C ⥤ H} (α : F ⟶ L ⋙ RF) (α' : F ⟶ L ⋙ RF')
  (W : morphism_property C) [L.is_localization W]

class is_right_derived_functor : Prop :=
(is_initial [] : nonempty (limits.is_initial (structured_arrow.mk α :
  structured_arrow F ((whiskering_left C H D).obj L))))

variables {RF RF'}

lemma is_right_derived_functor.of_iso [RF.is_right_derived_functor α]
  (eq : α' = α ≫ whisker_left L e.hom) : RF'.is_right_derived_functor α' :=
⟨⟨limits.is_initial.of_iso (is_right_derived_functor.is_initial α).some
  (structured_arrow.iso_mk e eq.symm)⟩⟩

variables (RF RF')

def is_right_derived_functor_to [RF.is_right_derived_functor α] (G : H ⥤ D) (β : F ⟶ L ⋙ G) :
  RF ⟶ G :=
(structured_arrow.proj _ _).map
  ((functor.is_right_derived_functor.is_initial α).some.to (structured_arrow.mk β))

@[simp, reassoc]
lemma is_right_derived_functor_to_comm [RF.is_right_derived_functor α] (G : H ⥤ D)
  (β : F ⟶ L ⋙ G) :
  α ≫ whisker_left L (RF.is_right_derived_functor_to α G β) = β :=
structured_arrow.w ((functor.is_right_derived_functor.is_initial α).some.to
  (structured_arrow.mk β))

@[simp, reassoc]
lemma is_right_derived_functor_to_comm_app [RF.is_right_derived_functor α] (G : H ⥤ D)
  (β : F ⟶ L ⋙ G) (X : C) :
  α.app X ≫ (RF.is_right_derived_functor_to α G β).app (L.obj X) = β.app X :=
congr_app (RF.is_right_derived_functor_to_comm α G β) X

lemma is_right_derived_functor_to_ext [RF.is_right_derived_functor α] {G : H ⥤ D}
  (γ₁ γ₂ : RF ⟶ G) (hγ : α ≫ whisker_left L γ₁ = α ≫ whisker_left L γ₂) : γ₁ = γ₂ :=
begin
  let F' : structured_arrow F ((whiskering_left C H D).obj L) :=
    structured_arrow.mk α,
  let δ₁ : F' ⟶ structured_arrow.mk (α ≫ whisker_left L γ₁) := structured_arrow.hom_mk γ₁ rfl,
  let δ₂ : F' ⟶ structured_arrow.mk (α ≫ whisker_left L γ₁) := structured_arrow.hom_mk γ₂ hγ.symm,
  exact (structured_arrow.proj _ _).congr_map
    ((functor.is_right_derived_functor.is_initial α).some.hom_ext δ₁ δ₂),
end

end functor

namespace nat_trans

variables {C D H : Type*} [category C] [category D] [category H]
  {F G G' : C ⥤ D} (τ : F ⟶ G) (τ' : G ⟶ G') {RF RG RG' : H ⥤ D} {L : C ⥤ H}
  (α : F ⟶ L ⋙ RF) (β : G ⟶ L ⋙ RG) (γ : G' ⟶ L ⋙ RG')

def right_derived [RF.is_right_derived_functor α] : RF ⟶ RG :=
RF.is_right_derived_functor_to α RG (τ ≫ β)

@[simp]
lemma right_derived_comp [RF.is_right_derived_functor α]
  [RG.is_right_derived_functor β] :
  nat_trans.right_derived τ α β ≫ nat_trans.right_derived τ' β γ =
    nat_trans.right_derived (τ ≫ τ') α γ :=
begin
  dsimp only [right_derived],
  apply RF.is_right_derived_functor_to_ext α,
  simp only [whisker_left_comp, functor.is_right_derived_functor_to_comm_assoc, assoc,
    functor.is_right_derived_functor_to_comm],
end

@[simp]
lemma right_derived_id [RF.is_right_derived_functor α] :
  nat_trans.right_derived (𝟙 F) α α = 𝟙 RF :=
begin
  dsimp only [right_derived],
  apply RF.is_right_derived_functor_to_ext α,
  simp only [id_comp, functor.is_right_derived_functor_to_comm, whisker_left_id', comp_id],
end

@[simp, reassoc]
lemma right_derived_app [RF.is_right_derived_functor α] (X : C) :
  α.app X ≫ (right_derived τ α β).app (L.obj X) = τ.app X ≫ β.app X :=
begin
  dsimp only [right_derived],
  simp only [functor.is_right_derived_functor_to_comm_app, comp_app],
end

end nat_trans

namespace nat_iso

variables {C D H : Type*} [category C] [category D] [category H]
  {F G : C ⥤ D} (e : F ≅ G) {RF RG : H ⥤ D} {L : C ⥤ H}
  (α : F ⟶ L ⋙ RF) (β : G ⟶ L ⋙ RG)

@[simps]
def right_derived [RF.is_right_derived_functor α] [RG.is_right_derived_functor β] :
  RF ≅ RG :=
{ hom := nat_trans.right_derived e.hom α β,
  inv := nat_trans.right_derived e.inv β α, }

instance [RF.is_right_derived_functor α] [RG.is_right_derived_functor β] (τ : F ⟶ G)
  [is_iso τ] : is_iso (nat_trans.right_derived τ α β) :=
is_iso.of_iso (nat_iso.right_derived (as_iso τ) α β)

end nat_iso

namespace functor

variables {C D H : Type*} [category C] [category D] [category H]
  (F : C ⥤ D) (RF : H ⥤ D) {L : C ⥤ H} (α : F ⟶ L ⋙ RF)
  (W : morphism_property C) [L.is_localization W]

class has_right_derived_functor : Prop :=
(has_initial' : limits.has_initial (structured_arrow F ((whiskering_left C _ D).obj W.Q)))

variable (L)

lemma has_right_derived_functor_iff :
  has_right_derived_functor F W ↔
    limits.has_initial (structured_arrow F ((whiskering_left C H D).obj L)) :=
begin
  let Φ := structured_arrow.whiskering_left F ((whiskering_left _ _ _).obj
      (localization.equivalence_from_model L W).functor)
      ((whiskering_left C _ D).obj W.Q),
  let Φ' := structured_arrow.postcomp F ((whiskering_left _ _ D).map_iso
    (localization.Q_comp_equivalence_from_model_functor_iso L W)).inv,
  split,
  { intro h,
    haveI := h.has_initial',
    exact adjunction.has_colimits_of_shape_of_equivalence (Φ' ⋙ Φ), },
  { introI,
    exact ⟨adjunction.has_colimits_of_shape_of_equivalence (inv (Φ' ⋙ Φ))⟩, },
end

lemma is_right_derived_functor.has_right_derived_functor [RF.is_right_derived_functor α] :
  F.has_right_derived_functor W :=
begin
  rw F.has_right_derived_functor_iff L W,
  exact limits.is_initial.has_initial (is_right_derived_functor.is_initial α).some,
end

lemma has_right_derived_functor.has_initial [has_right_derived_functor F W] :
  limits.has_initial (structured_arrow F ((whiskering_left C H D).obj L)) :=
(has_right_derived_functor_iff F L W).1 infer_instance

def has_right_derived_functor.initial [has_right_derived_functor F W] :
  (structured_arrow F ((whiskering_left C H D).obj L)) :=
begin
  haveI := has_right_derived_functor.has_initial F L W,
  exact limits.initial _,
end

def right_derived_functor [has_right_derived_functor F W] : H ⥤ D :=
(has_right_derived_functor.initial F L W).right

def right_derived_functor_α [has_right_derived_functor F W] :
  F ⟶ L ⋙ F.right_derived_functor L W :=
(has_right_derived_functor.initial F L W).hom

instance right_derived_functor_is_right_derived_functor [has_right_derived_functor F W] :
  (F.right_derived_functor L W).is_right_derived_functor (F.right_derived_functor_α L W) :=
⟨⟨begin
  haveI := has_right_derived_functor.has_initial F L W,
  exact limits.is_initial.of_iso limits.initial_is_initial
    (structured_arrow.iso_mk (iso.refl _) (by tidy)),
end⟩⟩

end functor

section

variables {C D : Type*} [category C] [category D]
  (W : morphism_property C) (W' : morphism_property D)

structure localizor_morphism :=
(functor : C ⥤ D)
(mapW : ∀ ⦃X Y : C⦄ (f : X ⟶ Y) (hf : W f), W' (functor.map f))

namespace localizor_morphism

variables {W W'} (Φ : localizor_morphism W W')

section

@[simps]
def op : localizor_morphism W.op W'.op :=
{ functor := Φ.functor.op,
  mapW := λ X Y f hf, Φ.mapW _ hf, }

variables [morphism_property.multiplicative W] [morphism_property.multiplicative W']

@[simps]
def induced_functor : W.category ⥤ W'.category :=
{ obj := λ X, ⟨Φ.functor.obj X.obj⟩,
  map := λ X Y φ,
  { f := Φ.functor.map φ.f,
    hf := Φ.mapW φ.f φ.hf, }, }

@[derive category]
def right_resolution (Y : D) := structured_arrow (⟨Y⟩ : W'.category) Φ.induced_functor

@[simps]
def right_resolution.mk {Y : D} (X : C) (f : Y ⟶ Φ.functor.obj X) (hf : W' f) :
  Φ.right_resolution Y :=
structured_arrow.mk (⟨f, hf⟩ : (⟨Y⟩ : W'.category) ⟶ Φ.induced_functor.obj ⟨X⟩)

@[derive category]
def left_resolution (Y : D) := costructured_arrow Φ.induced_functor (⟨Y⟩ : W'.category)

@[simps]
def left_resolution.mk {Y : D} (X : C) (f : Φ.functor.obj X ⟶ Y) (hf : W' f) :
  Φ.left_resolution Y :=
costructured_arrow.mk (⟨f, hf⟩ : Φ.induced_functor.obj ⟨X⟩ ⟶ (⟨Y⟩ : W'.category))

variable {Φ}

@[simps]
def left_resolution.op {Y : D} (X : Φ.left_resolution Y) :
  Φ.op.right_resolution (opposite.op Y) :=
right_resolution.mk Φ.op (opposite.op X.left.1) X.hom.1.op X.hom.2

@[simps]
def right_resolution.unop {Y : D} (X : Φ.op.right_resolution (opposite.op Y)) :
  Φ.left_resolution Y :=
left_resolution.mk Φ (opposite.unop X.right.1) X.hom.1.unop X.hom.2

@[simps]
def left_resolution.unop_op {Y : D} (X : Φ.left_resolution Y) :
  X.op.unop ≅ X :=
costructured_arrow.iso_mk
  (morphism_property.category.mk_iso (iso.refl _)
    (morphism_property.contains_identities.id _ _)
    (morphism_property.contains_identities.id _ _))
  (by { ext, dsimp, simp, })

@[simps]
def right_resolution.op_unop {Y : D} (X : Φ.op.right_resolution (opposite.op Y)) :
  X.unop.op ≅ X :=
structured_arrow.iso_mk
  (morphism_property.category.mk_iso (iso.refl _)
    (morphism_property.contains_identities.id _ _)
    (morphism_property.contains_identities.id _ _))
  (by { ext, dsimp, simp, })

variable (Φ)

@[simps]
def left_resolution.op_functor (Y : D) :
  Φ.left_resolution Y ⥤ (Φ.op.right_resolution (opposite.op Y))ᵒᵖ :=
{ obj := λ X, opposite.op (left_resolution.op X),
  map := λ X₁ X₂ f, quiver.hom.op (structured_arrow.hom_mk ⟨f.left.1.op, f.left.2⟩
    (by { ext, dsimp, simpa only [← costructured_arrow.w f], })), }

@[simps]
def right_resolution.unop_functor (Y : D) :
  (Φ.op.right_resolution (opposite.op Y))ᵒᵖ ⥤ Φ.left_resolution Y :=
{ obj := λ X, (opposite.unop X).unop,
  map := λ X₁ X₂ f, costructured_arrow.hom_mk ⟨f.unop.right.1.unop, f.unop.right.2⟩
    (by { ext, dsimp, simpa only [← structured_arrow.w f.unop], }), }

@[simps]
def left_resolution.op_equivalence (Y : D) :
  Φ.left_resolution Y ≌ (Φ.op.right_resolution (opposite.op Y))ᵒᵖ :=
{ functor := left_resolution.op_functor _ _,
  inverse := right_resolution.unop_functor _ _,
  unit_iso := nat_iso.of_components (λ X, X.unop_op.symm) (by tidy),
  counit_iso := nat_iso.of_components (λ X, ((opposite.unop X).op_unop).symm.op)
    (λ X Y f, quiver.hom.unop_inj (by tidy)),
  functor_unit_iso_comp' := λ X, quiver.hom.unop_inj (by tidy), }

end

variables {C' D' : Type*} [category C'] [category D'] (L₁ : C ⥤ C') (L₂ : D ⥤ D')
  [L₁.is_localization W] [L₂.is_localization W']

abbreviation lift_functor : C' ⥤ D' :=
localization.lift (Φ.functor ⋙ L₂)
  (λ X Y f (hf : W f),
    by { dsimp, exact localization.inverts L₂ W' _ (Φ.mapW f hf), }) L₁

def fac_functor : L₁ ⋙ Φ.lift_functor L₁ L₂ ≅ Φ.functor ⋙ L₂ :=
localization.fac _ _ _

class is_localization_equivalence : Prop :=
(nonempty_is_equivalence : nonempty (is_equivalence (Φ.lift_functor W.Q W'.Q)))

namespace is_localization_equivalence

lemma iff_aux (C'' D'' : Type*) [category C''] [category D''] (L₁' : C ⥤ C'') (L₂' : D ⥤ D'')
  [L₁'.is_localization W] [L₂'.is_localization W']
  (h : is_equivalence (Φ.lift_functor L₁ L₂)) : is_equivalence (Φ.lift_functor L₁' L₂') :=
begin
  let F₁ : C' ⥤ C'' := localization.lift L₁' (localization.inverts L₁' W) L₁,
  let F₂ : D' ⥤ D'' := localization.lift L₂' (localization.inverts L₂' W') L₂,
  have e : Φ.lift_functor L₁ L₂ ⋙ F₂ ≅ F₁ ⋙ Φ.lift_functor L₁' L₂' :=
    localization.lift_nat_iso L₁ W (L₁ ⋙ Φ.lift_functor L₁ L₂ ⋙ F₂)
      (L₁ ⋙ F₁ ⋙ Φ.lift_functor L₁' L₂') _ _ begin
      refine (functor.associator _ _ _).symm ≪≫ iso_whisker_right (Φ.fac_functor L₁ L₂) _ ≪≫
        functor.associator _ _ _ ≪≫ iso_whisker_left _ (localization.fac _ _ _) ≪≫
        (Φ.fac_functor L₁' L₂').symm ≪≫
        iso_whisker_right (localization.fac L₁' (localization.inverts L₁' W) L₁).symm _ ≪≫
        functor.associator _ _ _,
    end,
  exact is_equivalence.cancel_comp_left F₁ _ infer_instance
    (is_equivalence.of_iso e infer_instance),
end

lemma iff (F : C' ⥤ D') (e : L₁ ⋙ F ≅ Φ.functor ⋙ L₂) :
  Φ.is_localization_equivalence ↔ nonempty (is_equivalence F) :=
begin
  have h : nonempty (is_equivalence F) ↔ nonempty (is_equivalence (Φ.lift_functor L₁ L₂)),
  { letI : localization.lifting L₁ W (Φ.functor ⋙ L₂) F := ⟨e⟩,
    let e' : F ≅ Φ.lift_functor L₁ L₂ :=
      localization.lift_nat_iso L₁ W (Φ.functor ⋙ L₂) (Φ.functor ⋙ L₂) _ _ (iso.refl _),
    exact ⟨λ h₁, ⟨is_equivalence.of_iso e' h₁.some⟩,
      λ h₂, ⟨is_equivalence.of_iso e'.symm h₂.some⟩⟩, },
  rw h, clear h,
  split,
  { intro h,
    exact ⟨(iff_aux Φ _ _ _ _ _ _ h.nonempty_is_equivalence.some)⟩, },
  { intro h,
    exact ⟨⟨(iff_aux Φ _ _ _ _ _ _ h.some)⟩⟩, },
end

lemma iff_is_equivalence_lift_functor :
  Φ.is_localization_equivalence ↔ nonempty (is_equivalence (Φ.lift_functor L₁ L₂)) :=
is_localization_equivalence.iff Φ L₁ L₂ (Φ.lift_functor L₁ L₂) (Φ.fac_functor L₁ L₂)

lemma iff_is_localization :
  Φ.is_localization_equivalence ↔ (Φ.functor ⋙ L₂).is_localization W :=
begin
  split,
  { intro h,
    rw iff_is_equivalence_lift_functor Φ W.Q L₂ at h,
    letI := h.some,
    exact functor.is_localization.of_equivalence W.Q W (Φ.functor ⋙ L₂)
      (functor.as_equivalence (Φ.lift_functor W.Q L₂)) (Φ.fac_functor _ _), },
  { introI,
    rw iff_is_equivalence_lift_functor Φ (Φ.functor ⋙ L₂) L₂,
    exact ⟨is_equivalence.of_iso (localization.lifting.uniq (Φ.functor ⋙ L₂) W
      (Φ.functor ⋙ L₂) (𝟭 _) _) infer_instance⟩, },
end

instance [hΦ : Φ.is_localization_equivalence] :
  is_equivalence (Φ.lift_functor L₁ L₂) :=
((iff_is_equivalence_lift_functor Φ L₁ L₂).mp hΦ).some

instance is_localization_of_is_localization_equivalence [hΦ : Φ.is_localization_equivalence] :
  (Φ.functor ⋙ L₂).is_localization W :=
by simpa only [← iff_is_localization Φ L₂] using hΦ

instance op_is_localization_equivalence [hΦ : Φ.is_localization_equivalence] :
  Φ.op.is_localization_equivalence :=
begin
  rw iff_is_localization Φ W'.Q at hΦ,
  rw iff_is_localization Φ.op W'.Q.op,
  haveI := hΦ,
  change (Φ.functor ⋙ W'.Q).op.is_localization W.op,
  apply_instance,
end

end is_localization_equivalence

end localizor_morphism

end

namespace right_derivability_structure

variables {C₀ C H : Type*} [category C] [category C₀] [category H]
  {W₀ : morphism_property C₀}
  {W : morphism_property C} (Φ : localizor_morphism W₀ W)
  [localizor_morphism.is_localization_equivalence Φ]
  [morphism_property.multiplicative W₀] [morphism_property.multiplicative W]

structure basic :=
(right_resolution_connected : ∀ (Y : C), is_connected' (Φ.right_resolution Y))
(nonempty_arrow_right_resolution :
  ∀ ⦃Y₁ Y₂ : C⦄ (f : Y₁ ⟶ Y₂), ∃ (X₁ : Φ.right_resolution Y₁) (X₂ : Φ.right_resolution Y₂)
  (f' : X₁.right.obj ⟶ X₂.right.obj), X₁.hom.1 ≫ Φ.functor.map f' = f ≫ X₂.hom.1)

namespace basic

variables {Φ} (β : basic Φ) (L : C ⥤ H) [L.is_localization W]
  {D : Type*} [category D]

def some_right_resolution (Y : C) : Φ.right_resolution Y :=
(β.right_resolution_connected Y).is_nonempty.some

variables {F : C ⥤ D} (hF : W₀.is_inverted_by (Φ.functor ⋙ F))

namespace existence_derived_functor

include β hF

def RF : H ⥤ D :=
localization.lift (Φ.functor ⋙ F) hF (Φ.functor ⋙ L)

def ε : (Φ.functor ⋙ L) ⋙ RF β L hF ≅ Φ.functor ⋙ F :=
begin
  letI : localization.lifting (Φ.functor ⋙ L) W₀ (Φ.functor ⋙ F) (RF β L hF) :=
    localization.lifting_lift _ _ _,
  refine localization.lifting.iso (Φ.functor ⋙ L) W₀ _ _,
end

def α' (X : C) : (functor.const (Φ.right_resolution X)).obj (F.obj X) ⟶
  (functor.const (Φ.right_resolution X)).obj ((RF β L hF).obj (L.obj X)) :=
{ app := λ X₀, F.map X₀.hom.1 ≫ (ε β L hF).inv.app _ ≫
    (RF β L hF).map (localization.iso_of_hom L W _ X₀.hom.2).inv,
  naturality' := λ X₀ X₀' φ, begin
    dsimp,
    simp only [functor.map_inv, id_comp, comp_id],
    have eq₁ := φ.w,
    have eq₂ := (ε β L hF).inv.naturality φ.right.1,
    dsimp at eq₁ eq₂,
    rw id_comp at eq₁,
    rw eq₁,
    dsimp,
    rw [functor.map_comp, assoc, reassoc_of eq₂],
    congr' 2,
    simp only [functor.map_comp],
    erw is_iso.comp_inv_eq, -- should be tidied
    rw is_iso.inv_hom_id_assoc,
  end, }

def α_app (X : C) : F.obj X ⟶ (RF β L hF).obj (L.obj X) :=
(α' β L hF X).app (β.some_right_resolution X)

lemma α_app_eq {X : C} (X₀ : Φ.right_resolution X) :
  (α_app β L hF) X = (α' β L hF X).app X₀ :=
begin
  haveI := β.right_resolution_connected X,
  apply nat_trans_from_is_preconnected',
end

@[simps]
def α : F ⟶ L ⋙ RF β L hF :=
{ app := λ X, (α_app β L hF) X,
  naturality' := λ Y₁ Y₂ f, begin
    obtain ⟨X₁, X₂, f', fac⟩ := β.nonempty_arrow_right_resolution f,
    rw [α_app_eq β L hF X₁, α_app_eq β L hF X₂],
    dsimp [α'],
    have eq₁ := F.congr_map fac,
    have eq₂ := (ε β L hF).inv.naturality f',
    simp only [functor.map_comp] at eq₁,
    dsimp at eq₂,
    simp only [assoc, ← reassoc_of eq₁, reassoc_of eq₂, ← functor.map_comp],
    congr' 3,
    rw [is_iso.eq_inv_comp, ← L.map_comp_assoc, fac, L.map_comp, assoc,
      is_iso.hom_inv_id, comp_id],
  end, }

instance (X₀ : C₀) : is_iso ((α β L hF).app (Φ.functor.obj X₀)) :=
begin
  let X₀' := localizor_morphism.right_resolution.mk Φ X₀ (𝟙 _)
    (morphism_property.contains_identities.id W _),
  dsimp [α],
  rw α_app_eq β L hF (localizor_morphism.right_resolution.mk Φ X₀ (𝟙 _)
    (morphism_property.contains_identities.id W _)),
  dsimp [α'],
  simp only [functor.map_id, is_iso.inv_id, comp_id, id_comp],
  apply_instance,
end

@[simps]
def RF' : structured_arrow F ((whiskering_left C H D).obj L) :=
structured_arrow.mk (α β L hF)

instance is_iso_RF'_hom_app (X₀ : C₀) :
  is_iso ((RF' β L hF).hom.app (Φ.functor.obj X₀)) :=
(infer_instance : is_iso ((α β L hF).app (Φ.functor.obj X₀)))

instance (G : structured_arrow F ((whiskering_left C H D).obj L)) :
  subsingleton (RF' β L hF ⟶ G) :=
⟨λ φ₁ φ₂, begin
  apply structured_arrow.ext,
  apply localization.nat_trans_ext (Φ.functor ⋙ L) W₀,
  intro X₀,
  have eq₁ := congr_app φ₁.w (Φ.functor.obj X₀),
  have eq₂ := congr_app φ₂.w (Φ.functor.obj X₀),
  dsimp at eq₁ eq₂ ⊢,
  rw [id_comp] at eq₁ eq₂,
  rw [← cancel_epi ((α β L hF).app (Φ.functor.obj X₀))],
  dsimp,
  rw [← eq₁, eq₂],
end⟩

def RF_τ' (G : structured_arrow F ((whiskering_left C H D).obj L)) :
  RF β L hF ⟶ G.right :=
localization.lift_nat_trans (Φ.functor ⋙ L) W₀ _ _ _ _
  ((ε β L hF).hom ≫ whisker_left _ G.hom ≫ (functor.associator _ _ _).inv)

@[simp]
lemma RF_τ'_app_eq (G : structured_arrow F ((whiskering_left C H D).obj L)) (X₀ : C₀) :
  (RF_τ' β L hF G).app (L.obj (Φ.functor.obj X₀)) =
    (ε β L hF).hom.app X₀ ≫ G.hom.app (Φ.functor.obj X₀) :=
begin
  dsimp [RF_τ'],
  erw localization.lift_nat_trans_app,
  simp only [localization.lifting.of_comp_iso, iso.refl_hom, nat_trans.id_app,
    nat_trans.comp_app, whisker_left_app, functor.associator_inv_app,
    comp_id, iso.refl_inv, assoc],
  erw id_comp,
end

def RF_τ (G : structured_arrow F ((whiskering_left C H D).obj L)) :
  RF' β L hF ⟶ G :=
begin
  refine structured_arrow.hom_mk (RF_τ' β L hF G) _,
  ext X,
  let X₀ := β.some_right_resolution X,
  have eq := (RF_τ' β L hF G).naturality (L.map X₀.hom.f),
  haveI : is_iso (L.map X₀.hom.f) := localization.inverts L W _ X₀.hom.hf,
  dsimp at ⊢ eq,
  simp only [← cancel_mono (G.right.map (L.map X₀.hom.f)), assoc, ← eq, RF_τ'_app_eq,
    α_app_eq β L hF X₀, α', ← functor.map_comp_assoc],
  erw [is_iso.inv_hom_id, functor.map_id, id_comp, iso.inv_hom_id_app_assoc, G.hom.naturality],
  refl,
end

instance (G : structured_arrow F ((whiskering_left C H D).obj L)) :
  unique (RF' β L hF ⟶ G) :=
unique_of_subsingleton (RF_τ β L hF G)

lemma is_initial_RF' : limits.is_initial (RF' β L hF) := limits.is_initial.of_unique _

instance RF_is_right_derived_functor :
  (RF β L hF).is_right_derived_functor (α _ _ _) :=
⟨⟨is_initial_RF' β L hF⟩⟩

end existence_derived_functor

variable (F)

open existence_derived_functor

/-
The following lemma is a consequence of Lemma 6.5 of
_Structures de dérivabilité_ by Bruno Kahn, Georges Maltsiniotis,
Advances in mathematics 218 (2018).
-/

lemma existence_derived_functor : F.has_right_derived_functor W :=
functor.is_right_derived_functor.has_right_derived_functor F (RF β W.Q hF) W.Q (α _ _ _) W

include β hF

lemma is_iso_app (F' : H ⥤ D) (α' : F ⟶ L ⋙ F') [F'.is_right_derived_functor α'] (X₀ : C₀) :
  is_iso (α'.app (Φ.functor.obj X₀)) :=
begin
  have h := nat_trans.right_derived_app (𝟙 F) (α β L hF) α' (Φ.functor.obj X₀),
  rw [nat_trans.id_app, id_comp] at h,
  rw ← h,
  apply_instance,
end

end basic

end right_derivability_structure

namespace functor

variables {C D H : Type*} [category C] [category D] [category H]
  {F : C ⥤ D} (LF LF' : H ⥤ D) (e : LF ≅ LF') {L : C ⥤ H} (α : L ⋙ LF ⟶ F) (α' : L ⋙ LF' ⟶ F)
  (W : morphism_property C) [L.is_localization W]

class is_left_derived_functor : Prop :=
(is_terminal [] : nonempty (limits.is_terminal (costructured_arrow.mk α :
  costructured_arrow ((whiskering_left C H D).obj L) F)))

variables {LF LF'}

lemma is_left_derived_functor.of_iso [LF.is_left_derived_functor α]
  (eq : α' = whisker_left L e.inv ≫ α) : LF'.is_left_derived_functor α' :=
⟨⟨limits.is_terminal.of_iso (is_left_derived_functor.is_terminal α).some
    (costructured_arrow.iso_mk e (by { dsimp, rw eq, ext, simp only [nat_trans.comp_app,
      whisker_left_app, iso.hom_inv_id_app_assoc], }))⟩⟩

variables (LF LF')

def is_left_derived_functor_from [LF.is_left_derived_functor α] (G : H ⥤ D) (β : L ⋙ G ⟶ F) :
  G ⟶ LF :=
(costructured_arrow.proj _ _).map
  ((functor.is_left_derived_functor.is_terminal α).some.from (costructured_arrow.mk β))

@[simp, reassoc]
lemma is_left_derived_functor_from_comm [LF.is_left_derived_functor α] (G : H ⥤ D)
  (β : L ⋙ G ⟶ F) :
  whisker_left L (LF.is_left_derived_functor_from α G β) ≫ α = β :=
costructured_arrow.w ((functor.is_left_derived_functor.is_terminal α).some.from
  (costructured_arrow.mk β))

@[simp, reassoc]
lemma is_left_derived_functor_from_comm_app [LF.is_left_derived_functor α] (G : H ⥤ D)
  (β : L ⋙ G ⟶ F) (X : C) :
  (LF.is_left_derived_functor_from α G β).app (L.obj X) ≫ α.app X = β.app X :=
congr_app (LF.is_left_derived_functor_from_comm α G β) X

lemma is_left_derived_functor_from_ext [LF.is_left_derived_functor α] {G : H ⥤ D}
  (γ₁ γ₂ : G ⟶ LF) (hγ : whisker_left L γ₁ ≫ α = whisker_left L γ₂ ≫ α) : γ₁ = γ₂ :=
begin
  let F' : costructured_arrow ((whiskering_left C H D).obj L) F :=
    costructured_arrow.mk α,
  let G' : costructured_arrow ((whiskering_left C H D).obj L) F :=
    @costructured_arrow.mk _ _ _ _ F G ((whiskering_left C H D).obj L) (whisker_left L γ₁ ≫ α),
  let δ₁ : G' ⟶ F' := costructured_arrow.hom_mk γ₁ rfl,
  let δ₂ : G' ⟶ F' := costructured_arrow.hom_mk γ₂ hγ.symm,
  exact (costructured_arrow.proj _ _).congr_map
    ((functor.is_left_derived_functor.is_terminal α).some.hom_ext δ₁ δ₂),
end

end functor

namespace nat_trans

variables {C D H : Type*} [category C] [category D] [category H]
  {F G G' : C ⥤ D} (τ : F ⟶ G) (τ' : G ⟶ G') {LF LG LG' : H ⥤ D} {L : C ⥤ H}
  (α : L ⋙ LF ⟶ F) (β : L ⋙ LG ⟶ G) (γ : L ⋙ LG' ⟶ G')

def left_derived [LG.is_left_derived_functor β] : LF ⟶ LG :=
LG.is_left_derived_functor_from β LF (α ≫ τ)

@[simp]
lemma left_derived_comp [LG.is_left_derived_functor β]
  [LG'.is_left_derived_functor γ] :
  nat_trans.left_derived τ α β ≫ nat_trans.left_derived τ' β γ =
    nat_trans.left_derived (τ ≫ τ') α γ :=
begin
  dsimp only [left_derived],
  apply LG'.is_left_derived_functor_from_ext γ,
  simp only [whisker_left_comp, assoc, functor.is_left_derived_functor_from_comm,
    functor.is_left_derived_functor_from_comm_assoc],
end

@[simp]
lemma left_derived_id [LF.is_left_derived_functor α] :
  nat_trans.left_derived (𝟙 F) α α = 𝟙 LF :=
begin
  dsimp only [left_derived],
  apply LF.is_left_derived_functor_from_ext α,
  simp only [comp_id, functor.is_left_derived_functor_from_comm, whisker_left_id', id_comp],
end

@[simp, reassoc]
lemma left_derived_app [LG.is_left_derived_functor β] (X : C) :
  (left_derived τ α β).app (L.obj X) ≫ β.app X = α.app X ≫ τ.app X :=
begin
  dsimp only [left_derived],
  simp only [functor.is_left_derived_functor_from_comm_app, comp_app],
end

end nat_trans

namespace nat_iso

variables {C D H : Type*} [category C] [category D] [category H]
  {F G : C ⥤ D} (e : F ≅ G) {LF LG : H ⥤ D} {L : C ⥤ H}
  (α : L ⋙ LF ⟶ F) (β : L ⋙ LG ⟶ G)

@[simps]
def left_derived [LF.is_left_derived_functor α] [LG.is_left_derived_functor β] :
  LF ≅ LG :=
{ hom := nat_trans.left_derived e.hom α β,
  inv := nat_trans.left_derived e.inv β α, }

instance [LF.is_left_derived_functor α] [LG.is_left_derived_functor β] (τ : F ⟶ G)
  [is_iso τ] : is_iso (nat_trans.left_derived τ α β) :=
is_iso.of_iso (nat_iso.left_derived (as_iso τ) α β)

end nat_iso

namespace functor

variables {C D H : Type*} [category C] [category D] [category H]
  (F : C ⥤ D) (LF : H ⥤ D) (L : C ⥤ H) (α : L ⋙ LF ⟶ F)
  (W : morphism_property C) [L.is_localization W]

class has_left_derived_functor : Prop :=
(has_terminal' : limits.has_terminal (costructured_arrow ((whiskering_left C _ D).obj W.Q) F))

namespace costructured_arrow_equivalence_op

@[simps]
def functor : (costructured_arrow ((whiskering_left C H D).obj L) F) ⥤
    (structured_arrow F.op ((whiskering_left Cᵒᵖ Hᵒᵖ Dᵒᵖ).obj L.op))ᵒᵖ :=
{ obj := λ X, opposite.op (structured_arrow.mk
    (show F.op ⟶ ((whiskering_left Cᵒᵖ Hᵒᵖ Dᵒᵖ).obj L.op).obj X.left.op,
      by exact (functor.op_hom _ _).map X.hom.op)),
  map := λ X₁ X₂ f, quiver.hom.op
    (structured_arrow.hom_mk ((functor.op_hom H D).map (quiver.hom.op f.left))
      (by { rw ← costructured_arrow.w f, refl, })), }

@[simps]
def inverse : (structured_arrow F.op ((whiskering_left Cᵒᵖ Hᵒᵖ Dᵒᵖ).obj L.op))ᵒᵖ ⥤
    (costructured_arrow ((whiskering_left C H D).obj L) F) :=
{ obj := λ X, costructured_arrow.mk
      (show ((whiskering_left C H D).obj L).obj X.unop.right.unop ⟶ F,
        by exact ((functor.op_inv C D).map X.unop.hom).unop ≫ F.op_unop_iso.hom),
  map := λ X₁ X₂ f, costructured_arrow.hom_mk (((functor.op_inv _ _).map f.unop.right).unop)
      (by { rw ← structured_arrow.w f.unop, dsimp, ext, tidy, }), }

@[simps]
def unit_iso : 𝟭 _ ≅ functor F L ⋙ inverse F L :=
nat_iso.of_components (λ X, costructured_arrow.iso_mk (functor.op_unop_iso X.left).symm
    (by { ext, dsimp, tidy, })) (by tidy)

@[simps]
def counit_iso : inverse F L ⋙ functor F L ≅ 𝟭 _ :=
nat_iso.of_components (λ X, begin
  change opposite.op (opposite.unop _) ≅ opposite.op (opposite.unop _),
  apply iso.op,
  refine structured_arrow.iso_mk (functor.unop_op_iso _).symm _,
  ext, dsimp, tidy,
end) (λ X Y f, quiver.hom.unop_inj (by { dsimp, tidy, }))

end costructured_arrow_equivalence_op

def costructured_arrow_equivalence_op :
  (costructured_arrow ((whiskering_left C H D).obj L) F) ≌
    (structured_arrow F.op ((whiskering_left Cᵒᵖ Hᵒᵖ Dᵒᵖ).obj L.op))ᵒᵖ :=
{ functor := costructured_arrow_equivalence_op.functor _ _,
  inverse := costructured_arrow_equivalence_op.inverse _ _,
  unit_iso := costructured_arrow_equivalence_op.unit_iso _ _,
  counit_iso := costructured_arrow_equivalence_op.counit_iso _ _,
  functor_unit_iso_comp' := λ X, quiver.hom.unop_inj begin
    dsimp [structured_arrow.iso_mk, structured_arrow.hom_mk, comma.iso_mk],
    tidy,
  end, }

variable (L)

lemma has_left_derived_functor_iff_op :
  has_left_derived_functor F W ↔ has_right_derived_functor F.op W.op :=
begin
  have h : F.has_left_derived_functor W ↔
    limits.has_terminal (costructured_arrow ((whiskering_left C _ D).obj W.Q) F) :=
    ⟨λ h, h.1, λ h, ⟨h⟩⟩,
  rw [h, has_right_derived_functor_iff F.op W.Q.op W.op],
  have e := costructured_arrow_equivalence_op F W.Q,
  split,
  { introI,
    haveI : limits.has_terminal
      (structured_arrow F.op ((whiskering_left Cᵒᵖ (W.localization)ᵒᵖ Dᵒᵖ).obj W.Q.op))ᵒᵖ :=
      adjunction.has_limits_of_shape_of_equivalence e.inverse,
    exact limits.has_initial_of_has_terminal_op, },
  { introI,
    exact adjunction.has_limits_of_shape_of_equivalence e.functor, },
end

lemma has_left_derived_functor_iff :
  has_left_derived_functor F W ↔
    limits.has_terminal (costructured_arrow ((whiskering_left C H D).obj L) F) :=
begin
  rw [has_left_derived_functor_iff_op, has_right_derived_functor_iff F.op L.op W.op],
  have e := costructured_arrow_equivalence_op F L,
  split,
  { introI,
    exact adjunction.has_limits_of_shape_of_equivalence e.functor, },
  { introI,
    haveI : limits.has_terminal
      (structured_arrow F.op ((whiskering_left Cᵒᵖ Hᵒᵖ Dᵒᵖ).obj L.op))ᵒᵖ :=
      adjunction.has_limits_of_shape_of_equivalence e.inverse,
    exact limits.has_initial_of_has_terminal_op, },
end

lemma is_left_derived_functor.has_left_derived_functor [LF.is_left_derived_functor α] :
  F.has_left_derived_functor W :=
begin
  rw F.has_left_derived_functor_iff L W,
  exact limits.is_terminal.has_terminal (is_left_derived_functor.is_terminal α).some,
end

variables {F L LF F α}

lemma is_left_derived_functor.op (hα : LF.is_left_derived_functor α) :
  @is_right_derived_functor _ _ _ _ _ _ F.op LF.op L.op ((functor.op_hom _ _).map α.op) :=
is_right_derived_functor.mk
  (nonempty.intro (limits.initial_unop_of_terminal
    (limits.is_terminal.of_equivalence (costructured_arrow_equivalence_op F L)
      hα.is_terminal.some)))

variables (F L LF F α)

lemma has_left_derived_functor.has_terminal [has_left_derived_functor F W] :
  limits.has_terminal (costructured_arrow ((whiskering_left C H D).obj L) F) :=
(has_left_derived_functor_iff F L W).1 infer_instance

def has_left_derived_functor.initial [has_left_derived_functor F W] :
  (costructured_arrow ((whiskering_left C H D).obj L) F) :=
begin
  haveI := has_left_derived_functor.has_terminal F L W,
  exact limits.terminal _,
end

def left_derived_functor [has_left_derived_functor F W] : H ⥤ D :=
(has_left_derived_functor.initial F L W).left

def left_derived_functor_α [has_left_derived_functor F W] :
  L ⋙ F.left_derived_functor L W ⟶ F :=
(has_left_derived_functor.initial F L W).hom

instance left_derived_functor_is_left_derived_functor [has_left_derived_functor F W] :
  (F.left_derived_functor L W).is_left_derived_functor (F.left_derived_functor_α L W) :=
⟨⟨begin
  haveI := has_left_derived_functor.has_terminal F L W,
  exact limits.is_terminal.of_iso limits.terminal_is_terminal
    (costructured_arrow.iso_mk (iso.refl _) (by tidy)),
end⟩⟩

end functor

namespace left_derivability_structure

variables {C₀ C H : Type*} [category C] [category C₀] [category H]
  {W₀ : morphism_property C₀}
  {W : morphism_property C} (L : C ⥤ H) [L.is_localization W] (Φ : localizor_morphism W₀ W)
  [localizor_morphism.is_localization_equivalence Φ]
  [morphism_property.multiplicative W₀] [morphism_property.multiplicative W]

structure basic :=
(left_resolution_connected : ∀ (Y : C), is_connected' (Φ.left_resolution Y))
(nonempty_arrow_left_resolution :
  ∀ ⦃Y₁ Y₂ : C⦄ (f : Y₁ ⟶ Y₂), ∃ (X₁ : Φ.left_resolution Y₁) (X₂ : Φ.left_resolution Y₂)
  (f' : X₁.left.obj ⟶ X₂.left.obj), Φ.functor.map f' ≫ X₂.hom.1 = X₁.hom.1 ≫ f)

namespace basic

variables {L Φ}

def op (β : basic  Φ) : right_derivability_structure.basic Φ.op :=
{ right_resolution_connected := λ Y, (is_connected'.of_equivalence
      (localizor_morphism.left_resolution.op_equivalence Φ (opposite.unop Y))
      (β.left_resolution_connected (opposite.unop Y))).unop,
  nonempty_arrow_right_resolution := λ Y₁ Y₂ f, begin
    obtain ⟨X₁, X₂, f', fac⟩ := β.nonempty_arrow_left_resolution f.unop,
    exact ⟨X₂.op, X₁.op, f'.op, quiver.hom.unop_inj fac⟩,
  end, }

variables (β : basic Φ) {D : Type*} [category D] (F : C ⥤ D)
  (hF : W₀.is_inverted_by (Φ.functor ⋙ F))

include β hF

lemma existence_derived_functor : F.has_left_derived_functor W :=
by simpa only [functor.has_left_derived_functor_iff_op]
  using β.op.existence_derived_functor F.op hF.op

lemma is_iso_app (F' : H ⥤ D) (α' : L ⋙ F' ⟶ F) [hα' : F'.is_left_derived_functor α'] (X₀ : C₀) :
  is_iso (α'.app (Φ.functor.obj X₀)) :=
begin
  suffices : is_iso (α'.app (Φ.functor.obj X₀)).op,
  { haveI := this,
    exact is_iso.of_iso ((as_iso (α'.app (Φ.functor.obj X₀)).op).unop), },
  let α'' : F.op ⟶ L.op ⋙ F'.op := (functor.op_hom C D).map α'.op,
  haveI : F'.op.is_right_derived_functor α'' := hα'.op,
  exact β.op.is_iso_app L.op F.op hF.op F'.op α'' (opposite.op X₀),
end

end basic

end left_derivability_structure

end category_theory


/-
Copyright 2020 Google LLC

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

      http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
 -/
import measure_theory.measurable_space

import measure_theory.measure_space
import measure_theory.outer_measure
import measure_theory.lebesgue_measure
import measure_theory.integration
import measure_theory.borel_space
import data.set.countable
import formal_ml.measurable_space
import formal_ml.probability_space
import formal_ml.real_random_variable
import data.complex.exponential
import formal_ml.ennreal
import formal_ml.nnreal
import formal_ml.sum
import formal_ml.exp_bound

/-
  The Vapnik-Chevronenkis Dimension and its connection to learning is one of the most
  remarkable and fundamental results in machine learning. In particular, it allows us
  to understand simple, infinite hypothesis spaces, like the separating hyperplane,
  and begin to understand the complexity of neural networks. This analysis is also a
  precursor to understanding support vector machines and structural risk.
 -/

lemma finset.subset_of_not_mem_of_subset_insert {α:Type*} [decidable_eq α] {x:α} {S T:finset α}:x∉ S →
  S ⊆ insert x T → S ⊆ T :=
begin
  intros A1 A2,
  rw finset.subset_iff,
  rw finset.subset_iff at A2,
  intros a B1,
  have B2 := A2 B1,
  rw finset.mem_insert at B2,
  cases B2,
  subst a,
  exfalso,
  apply A1,
  apply B1,
  apply B2,
end

/-
  A type is of class inhabited if it has at least one element.
  Thus, its cardinality is not zero.
--Not sure where to put this. Here is fine for now.
--Note: this is the kind of trivial thing that takes ten minutes to prove.
-/

/--
  Normally, we would not assume that the representation type was encodable (i.e. countable).
  Specifically, one could imagine real numbers as part of the representation type.
  However, that creates some issues with measurability.
 -/
structure VC_PAC_problem :=
   (Ω:Type*)                           -- Underlying outcome type
   (p:probability_space Ω)             -- Underlying probability space
   (X:Type*)                           -- instance type
   (MX:measurable_space X)             -- Measurable space for the instances
   (H:Type*)                           -- Representation type
   (ER:encodable H)                    -- The representation type is encodable.
   (R:H → (set X))                     -- Representation scheme
   (MC:∀ h:H, is_measurable (R(h)))   -- Concepts are measurable.
   (Di:Type*)                          -- number of examples
   (FDi:fintype Di)                    -- number of examples are finite
   (EDi:encodable Di)                  -- example index is encodable
   (D:Di → (p →ᵣ MX))                  -- example distribution
   (IID:random_variables_IID D)        -- examples are IID
   (has_example:inhabited Di)          -- there exists an example
   (c:H)                               -- the correct hypothesis

namespace VC_PAC_problem

variable (P:VC_PAC_problem)

--The measurable space for the hypotheses is ⊤.
--Everything is measurable.
def MH:measurable_space (P.H) := ⊤

--The space of training datasets.
def data_space:measurable_space (P.Di → P.X) := @measurable_space.pi P.Di (λ i, P.X) (λ i, P.MX)

--The learning algorithm is a function of the training dataset.
def algorithm:Type* := measurable_fun (P.data_space) P.MH

def concept (h:P.H):measurable_set P.MX := measurable_set.mk (P.MC h)

def target_concept:measurable_set P.MX := (P.concept P.c)

def in_concept (h:P.H) (i:P.Di):event (P.p) := @rv_event P.Ω P.p P.X P.MX (P.D i) (P.concept h)

def label_positive (i:P.Di):event (P.p) := P.in_concept P.c i

def example_correct (h:P.H) (i:P.Di):event (P.p) :=
    (P.in_concept h i) =ₑ (P.label_positive i)

def example_error (h:P.H) (i:P.Di):event (P.p) :=
    ¬ₑ (P.example_correct h i)

/-
  num_examples P is the number of examples in the problem.
  This is defined as the cardinality of the index type of the examples.
-/
def num_examples:nat
   := @fintype.card P.Di P.FDi

--the measurable space on hypotheses and instances.
def MHX:measurable_space (P.H × P.X) := P.MH ×ₘ P.MX

noncomputable def training_error (h:P.H):P.p →ᵣ (borel nnreal) :=
  average_identifier (P.example_error h) (P.FDi)

/-
  The number of examples is the number of elements of type P.Di.
  P.FDi.elems is the set of all elements in P.Di, and P.FDi.elems.card is the cardinality of
  P.FDi.elems.
-/
lemma num_examples_eq_finset_card:
  P.num_examples = P.FDi.elems.card :=
begin
  refl,
end

/-
  The number of examples do not equal zero.
 -/
lemma num_examples_ne_zero:
  P.num_examples ≠ 0 :=
begin
  unfold VC_PAC_problem.num_examples,
  apply @card_ne_zero_of_inhabited P.Di P.has_example P.FDi,
end

/-
  The expected test error.
  The test error is equal to the expected training error. Because we have not defined a generating
  process for examples, we use this as the definition.
-/
noncomputable def test_error'
    (h:P.H):ennreal := E[P.training_error h]

lemma example_error_IID (P:VC_PAC_problem) (i:P.H):
  @events_IID P.Ω P.Di P.p P.FDi  (P.example_error i) :=
begin
  /-
    To prove that the errors of a particular hypothesis are IID, we must use an alternate
    formulation of the example_error events. Specifically, instead of constructing a hierarchy
    of random variables, we must make a leap from the established IID random variable
    (the data), construct another IID random variable (the product of
    the classification and the label), and show that the set of all label/classification pairs
    that aren't equal are a measurable set (because has_measurable_eq Mγ).

    The indexed set of events of each IID random variable being in a measurable set is IID,
    so the result holds.

    Note that while this proof looks a little long, most of the proof is just unwrapping
    the traditional and internal definitions of example error, and then using simp to show that
    they are equal on all outcomes.
  -/
  let S:measurable_set P.MX := (P.concept i ∩ (P.target_concept)ᶜ) ∪ ((P.concept i)ᶜ ∩ (P.target_concept)),
  begin
  have B1:S = (P.concept i ∩ P.target_conceptᶜ) ∪ (((P.concept i)ᶜ) ∩ ((P.target_concept))) := rfl,
  have A1:@random_variables_IID P.Ω P.p P.Di P.FDi P.X P.MX P.D,
  {
    apply P.IID,
  },
  have A2:@events_IID P.Ω P.Di P.p P.FDi (λ j:P.Di, @rv_event P.Ω P.p P.X P.MX (P.D j) S),
  {
    apply rv_event_IID,
    apply A1,
  },
  have A3: (λ j:P.Di, @rv_event P.Ω P.p P.X P.MX (P.D j) S) = P.example_error i,
  {
    apply funext,
    intro j,
    apply event.eq,
    rw B1,
    unfold VC_PAC_problem.example_error VC_PAC_problem.example_correct VC_PAC_problem.target_concept
    VC_PAC_problem.label_positive  VC_PAC_problem.in_concept,
    rw enot_val_def,
    rw event_eqv_def,
    rw rv_event_val_def,
    rw eor_val_def,
    repeat {rw eand_val_def},
    rw measurable_union_val_def2,
    repeat {rw measurable_inter_val_def2},
    repeat {rw measurable_set_compl_val_def},
    repeat {rw enot_val_def},
    repeat {rw rv_event_val_def},
    ext ω,
    split;intros A3B;simp;simp at A3B,
    {
      cases A3B with A3B A3B,
      {
        split,
        {
          intros A3BA,
          apply A3B.right,
        },
        {
          intro A3BA,
          exfalso,
          apply A3BA,
          apply A3B.left,
        },
      },
      {
        split;intros A3BA,
        {
          intros A3BB,
          apply A3B.left A3BA,
        },
        {
          apply A3B.right,
        },
      },
    },
    {
      cases (classical.em ((P.D j).val ω ∈ (P.concept i).val)) with A3C A3C,
      {
        apply or.inl (and.intro A3C (A3B.left A3C)),
      },
      {
        apply or.inr (and.intro A3C (A3B.right A3C)),
      },
    },
  },
  rw ← A3,
  exact A2,
  end
end

/-
  The expected test error.
  The test error is equal to the expected training error. Because we have not defined a generating
  process for examples, we use this as the definition.
-/
lemma test_error_def
    (h:P.H) (i:P.Di):P.test_error' h = Pr[P.example_error h i] :=
begin
  unfold VC_PAC_problem.test_error' VC_PAC_problem.training_error,
  rw average_identifier_eq_pr_elem,
  apply VC_PAC_problem.example_error_IID,
end

--This is probably true, but just very hard to prove.
def test_error_measurable:Prop :=
  @measurable P.H ennreal P.MH (borel ennreal) P.test_error'

noncomputable def test_error (TEM:P.test_error_measurable):P.MH →ₘ (borel ennreal) := {
  val := P.test_error',
  property := TEM,
}

def C:set (set P.X) := set.range P.R

def Φ:ℕ → ℕ → ℕ
| 0 m := 1
| d 0 := 1
| (nat.succ d) (nat.succ m) :=  Φ (d.succ) m + Φ d m

@[simp]
lemma phi_d_zero_eq_one {d:ℕ}:Φ d 0 = 1 :=
begin
  cases d;unfold Φ,
end

@[simp]
lemma phi_zero_m_eq_one {m:ℕ}:Φ 0 m = 1 :=
begin
  cases m;unfold Φ,
end

lemma phi_succ_succ {d m:ℕ}:Φ d.succ m.succ = Φ d.succ m + Φ d m := rfl

end VC_PAC_problem

def finset.to_set_of_sets {α:Type*} (C:finset (finset α)):set (set α) :=
  (λ c:finset α, (↑c:set α)) '' (↑C:set (finset α))

lemma finset.mem_to_set_of_sets {α:Type*} {C:finset (finset α)} {c:finset α}:
  (↑c ∈ (C.to_set_of_sets)) ↔ c ∈ C :=
begin
  unfold finset.to_set_of_sets,
  simp,
end

lemma finset.mem_to_set_of_sets' {α:Type*} {C:finset (finset α)} {c:set α}:
  c∈ C.to_set_of_sets ↔ ∃ c' ∈ C, c=(↑c') :=
begin
  unfold finset.to_set_of_sets,
  split;intro A1,
  {
    simp at A1,
    cases A1 with c' A1,
    apply exists.intro c',
    apply exists.intro A1.left,
    rw A1.right,
  },
  {
    simp,
    cases A1 with c' A1,
    apply exists.intro c',
    cases A1 with A1 A2,
    simp [A1, A2],
  },
end

/-
  It is important to be able to talk about the VC dimension of a set of sets without
  referring to a particular problem. For that reason, I have placed it outside of the
  VC_PAC_problem.
-/
namespace VC_PAC_problem
section VC_PAC_problem
universe u
variable {α:Type u}
open_locale classical

--The set of restrictions of concepts onto S, conventionally written as Πc(S) and represented as vectors.
noncomputable def restrict_set (C:set (set α)) (S:finset α):finset (finset α) :=
  S.powerset.filter (λ x, ∃ c∈ C, c ∩ (↑S) = (↑x))

--Does there exist a concept that agrees with any subset of S on S?
def shatters (C:set (set α)) (S:finset α):Prop :=
  (restrict_set C S) = S.powerset

--What is the largest extended natural number n such that all finite sets of size ≤ n can be shattered?
--Note that if the VC dimension is infinity, then that means that any finite set can be shattered,
--but it does not say anything about infinite sets. See Kearns and Vazirani, page 51.
--For example, the Borel algebra on the reals shatters every finite set, but does not shatter
--all infinite sets (e.g. it does not shatter the reals themselves), so it has a VC dimension of
--infinity.
--Note: an empty hypothesis space, by this definition, has a VCD of infinity. This may cause problems.
/-noncomputable def VCD (C:set (set α)):enat := Sup {n:enat|∃ (X':finset α), ((X'.card:enat) = n)  ∧
  shatters C (X')}-/

/-
  Consider all sets that can be shattered. What is the supremum of their sizes (in enat)?
 -/
noncomputable def VCD (C:set (set α)):enat := Sup
  ((λ X':finset α, (↑(X'.card):enat)) '' {X':finset α|shatters C (X')})

/-
  Normally, this restriction is defined for sets of exactly size m. However, this
  runs into problems if there do not exist sets of a certain size.
 -/
noncomputable def restrict_set_bound (C:set (set α)) (m:ℕ):nat := Sup ((λ X', (restrict_set C X').card) ''
   {X':finset α|X'.card ≤ m})

lemma restrict_set_subset {C:set (set α)} (S:finset α):restrict_set C S⊆ S.powerset :=
begin
  unfold restrict_set,
  simp,
end

lemma mem_restrict_set_subset {C:set (set α)} {S:finset α} {c:finset α}:c ∈ restrict_set C S →
  c⊆ S :=
begin
  intros A1,
  rw ← finset.mem_powerset,
  have A2:= @restrict_set_subset α C S,
  apply A2,
  apply A1,
end

-- filter (λ x, true)
--{S':set P.X|∃ c ∈ P.C, (S')= c ∩ (S)}
lemma mem_restrict_set {C:set (set α)} (S:finset α) (T:finset α):
  T ∈ restrict_set C S ↔ (∃ c∈ C, c ∩ (↑S) = (↑T)) :=
begin
  unfold restrict_set,
  rw finset.mem_filter,
  split;intros B1,
  {
    apply B1.right,
  },
  {
    split,
    rw finset.mem_powerset,
    cases B1 with c B1,
    cases B1 with B1 B2,
    rw finset.subset_iff,
    intros x A1,
    have B3:= set.inter_subset_right c (↑S),
    rw B2 at B3,
    apply B3,
    simp,
    apply A1,
    apply B1,
  },
end

lemma shatters_iff {C:set (set α)} (S:finset α):
   (shatters C S) ↔ (∀ S'⊆ S, ∃ c∈ C, c ∩(↑S) = (↑S')) :=
begin
  unfold shatters,
  split;intros A1,
  {
    intros S' B1,
    rw finset.ext_iff at A1,
    have B2 := A1 S',
    rw finset.mem_powerset at B2,
    rw ← B2 at B1,
    rw mem_restrict_set at B1,
    apply B1,
  },
  {
    apply finset.subset.antisymm,
    apply restrict_set_subset,
    rw finset.subset_iff,
    intros S' C1,
    rw finset.mem_powerset at C1,
    have C2 := A1 S' C1,
    rw mem_restrict_set,
    apply C2,
  },
end

lemma shatters_def (C:set (set α)) (S:finset α):
  shatters C S = ((restrict_set C S) = S.powerset) := rfl

/-Introducing a trivial upper bound establishes that Sup exists meaningfully (instead
  of a default value of zero).-/
lemma restrict_set_trivial_upper_bound  {C:set (set α)} (X':finset α):
  (restrict_set C X').card ≤ 2^(X'.card) :=
begin
  have B1:(restrict_set C X').card ≤ X'.powerset.card,
  {
    apply finset.card_le_of_subset,
    apply restrict_set_subset,
  },
  apply le_trans B1,
  rw finset.card_powerset,
end

lemma restrict_set_le_upper_bound {C:set (set α)} (X':finset α):
  (restrict_set C X').card ≤ restrict_set_bound C (X'.card) :=
begin
  apply le_cSup,
  rw bdd_above_def,
  unfold upper_bounds,
  apply exists.intro (2^(X'.card)),
  simp,
  intros a X'',
  intros A1 A2,
  subst A2,
  have A3:2^(X''.card) ≤ 2^(X'.card),
  {
    apply linear_ordered_semiring.pow_monotone one_le_two A1,
  },
  apply le_trans _ A3,
  apply restrict_set_trivial_upper_bound,
  simp,
  apply exists.intro X',
  split,
  refl,
  refl,
end

lemma shatters_card_le_VCD {C:set (set α)} {S:finset α}:shatters C S → (S.card:enat) ≤ VCD C :=
begin
  unfold VCD,
  intros A1,
  apply le_Sup,
  simp,
  apply exists.intro S,
  simp [A1],
end

lemma VCD_le {C:set (set α)} {d:enat}:(∀ S:finset α, shatters C S → (↑S.card)  ≤ d) → VCD C ≤ d :=
begin
  intros A1,
  unfold VCD,
  apply Sup_le,
  intros b B1,
  simp at B1,
  cases B1 with X' B1,
  cases B1 with B1 B2,
  subst b,
  apply A1 X' B1,
end

lemma restrict_set_elements_subset_of_VCD_zero {C:set (set α)} {S T U:finset α}:(VCD C = 0) →
  T ∈ (restrict_set C S) → U ∈ (restrict_set C S) → T ⊆ U :=
begin
  intros A1 A2 A3,
  rw finset.subset_iff,
  intros x B1,
  apply by_contradiction,
  intros B2,
  have B3 := (mem_restrict_set _ _).mp A2,
  have B4 := (mem_restrict_set _ _).mp A3,
  cases B3 with c_yes B3,
  cases B4 with c_no B4,
  cases B3 with B3 B5,
  cases B4 with B4 B6,
  have C1:↑T ⊆ c_yes, {rw ← B5,apply set.inter_subset_left},
  have C2:x∈ c_yes,{apply C1,simp,apply B1},
  have C3:c_yes ∩ {x} = {x},
  {ext,split;intros B8A;simp;simp at B8A,apply B8A.right,subst x_1,simp [C2]},
  have C4:↑U ⊆ c_no, {rw ← B6,apply set.inter_subset_left},
  have C5:T ⊆ S,
  {
    rw ← finset.coe_subset,rw ← B5, apply set.inter_subset_right,
  },
  have C6:x ∈ S,
  {
    apply C5, apply B1,
  },
  have C7:x∉ c_no,
  {
    intros C5A,apply B2,rw ← finset.mem_coe,rw ← B6, simp,
    apply and.intro C5A C6,
  },
  have C8:c_no ∩ ↑({x}:finset α) = ↑(∅:finset α),
  {
    simp,
    ext,split;intros C8A,
    simp at C8A,cases C8A with C8A C8B,subst x_1,exfalso,apply C7 C8A,
    exfalso, apply C8A,
  },
  have C9:shatters C {x},
  {
    unfold shatters,
    rw finset.powerset_singleton,
    apply finset.subset.antisymm,
    apply restrict_set_subset,
    rw finset.subset_iff,
    intros X' C9A,
    simp at C9A,cases C9A;subst X';rw mem_restrict_set,
    {apply exists.intro c_no, apply exists.intro B4, exact C8},
    {apply exists.intro c_yes, apply exists.intro B3,simp,apply C3},
  },
  have C10:1 ≤ VCD C,
  {
    apply shatters_card_le_VCD C9,
  },
  rw A1 at C10,
  have C11:(0:enat) < (1:enat) := enat.zero_lt_one,
  rw lt_iff_not_ge at C11,
  apply C11,
  apply C10,
end

lemma restrict_set_elements_eq_of_VCD_zero {C:set (set α)} {S T U:finset α}:(VCD C = 0) →
  T ∈ (restrict_set C S) → U ∈ (restrict_set C S) → T = U :=
begin
  intros A1 A2 A3,
  apply finset.subset.antisymm,
  apply restrict_set_elements_subset_of_VCD_zero A1 A2 A3,
  apply restrict_set_elements_subset_of_VCD_zero A1 A3 A2,
end

--Note: S could be either empty or have a unique element.
lemma finset.card_identical_elements {α:Type*} [decidable_eq α] {S:finset α}:
   (∀ a b:α,  a ∈ S → b ∈ S → a=b ) → S.card ≤ 1 :=
begin
  --intros A1,
  apply finset.induction_on S,
  {
    simp,
  },
  {
    intros a s B1 B2 B3,
    have C1:s = ∅,
    {
      rw ← finset.subset_empty,
      rw finset.subset_iff,
      intros b C1A,
      exfalso,
      apply B1,
      have C1B:a = b,
      {
        apply B3;simp [C1A],
      },
      rw C1B,
      apply C1A,
    },
    rw C1,
    simp,
  },
end

lemma mem_restrict_set_of_mem_restrict_set {C:set (set α)} {S₁ S₂ T:finset α}:
  T ∈ restrict_set C S₂ →
  S₁ ⊆ S₂ →
  (T ∩ S₁) ∈ restrict_set C S₁ :=
begin
  repeat {rw mem_restrict_set},
  intros A1 A2,
  cases A1 with c A1,
  apply exists.intro c,
  cases A1 with A1 A3,
  apply exists.intro A1,
  simp,
  rw ← A3,
  rw set.inter_assoc,
  rw ← finset.coe_subset at A2,
  rw set.inter_eq_self_of_subset_right A2,
end

lemma set.insert_inter_of_not_mem {α:Type*} {A B:set α} {x:α}:(x∉ B) → ((insert x A) ∩ B = A ∩ B) :=
begin
  intros A1,
  ext a,
  split;intros A2;simp at A2;simp,
  {
    cases A2 with A2 A3,
    cases A2 with A2 A4,
    {
      subst A2,
      exfalso,
      apply A1 A3,
    },
    {
      apply and.intro A4 A3,
    },
  },
  {
    apply and.intro (or.inr A2.left) A2.right,
  },
end

lemma set.inter_insert_of_not_mem {α:Type*} {A B:set α} {x:α}:(x∉ A) → (A ∩ (insert x B) = A ∩ B) :=
begin
  intros A1,
  rw set.inter_comm,
  rw set.insert_inter_of_not_mem A1,
  rw set.inter_comm,
end

lemma set.not_mem_of_inter_insert {α:Type*} {A B:set α} {x:α}:(x∉ A) → (A ∩ (insert x B) = A ∩ B) :=
begin
  intros A1,
  rw set.inter_comm,
  rw set.insert_inter_of_not_mem A1,
  rw set.inter_comm,
end

lemma set.inter_insert_of_mem {α:Type*} {A B:set α} {x:α}:(x∈ A) → (A ∩ (insert x B) = insert x (A ∩ B)) :=
begin
  intros A1,
  rw set.insert_inter,
  rw set.insert_eq_of_mem A1,
end

lemma set.mem_of_inter_insert {α:Type*} {A B C:set α} {x:α}:
  (A ∩ (insert x B) = insert x (C)) → (x ∈ A) :=
begin
  intros A1,
  have B1 := set.mem_insert x (C),
  rw ← A1 at B1,
  simp at B1,
  apply B1,
end

lemma set.eq_of_insert_of_not_mem {α:Type*} {A B:set α} {x:α}:(x∉ A) → (x∉ B) → (insert x A  = insert x B)
  → A = B :=
begin
  intros A1 A3 A2,
  ext a;split;intros B1;have C1 := set.mem_insert_of_mem x B1,
  {
    rw A2 at C1,
    apply set.mem_of_mem_insert_of_ne C1,
    intros C2,
    subst a,
    apply A1 B1,
  },
  {
    rw ← A2 at C1,
    apply set.mem_of_mem_insert_of_ne C1,
    intros C2,
    subst a,
    apply A3 B1,
  },
end

lemma set.insert_subset_insert {α:Type*} {A B:set α} {x:α}:A ⊆ B → (insert x A) ⊆ (insert x B) :=
begin
  intros A1,
  rw set.subset_def,
  intros a B1,
  simp at B1,
  simp,
  cases B1 with B1 B1,
  apply or.inl B1,
  apply or.inr (A1 B1),
end

lemma finset.eq_of_insert_of_not_mem {α:Type*} {A B:finset α} {x:α}:(x∉ A) → (x∉ B) → (insert x A  = insert x B)
  → A = B :=
begin
  intros A1 A3 A2,
  ext a;split;intros B1;have C1 := finset.mem_insert_of_mem B1,
  {
    rw A2 at C1,
    apply finset.mem_of_mem_insert_of_ne C1,
    intros C2,
    subst a,
    apply A1 B1,
  },
  {
    rw ← A2 at C1,
    apply finset.mem_of_mem_insert_of_ne C1,
    intros C2,
    subst a,
    apply A3 B1,
  },
end

lemma mem_restrict_set_insert {C:set (set α)} {S c:finset α} {x:α}:x∉ S → (x∉ c) →
  ((c ∈ restrict_set C S) ↔ (insert x c ∈ restrict_set C (insert x S)) ∨ c∈ restrict_set C (insert x S))
 :=
begin
  repeat {rw mem_restrict_set},
  intros A1 AX,split;intros A2,
  {
    cases A2 with c' A2,
    cases A2 with A2 A3,
    cases (em (x∈ c')) with B1 B1,
    {
      left,
      apply exists.intro c',
      apply exists.intro A2,
      simp,
      have B2:insert x c' = c' := set.insert_eq_of_mem B1,
      rw ← B2,
      rw ← set.insert_inter,
      rw A3,
    },
    {
      right,
      apply exists.intro c',
      apply exists.intro A2,
      simp,
      rw set.inter_insert_of_not_mem B1,
      apply A3,
    },
  },
  {
    cases A2 with A2 A2;cases A2 with c' A2;cases A2 with A2 A3;
    apply exists.intro c';apply exists.intro A2,
    {
      simp at A3,
      have C1:=set.mem_of_inter_insert A3,
      rw set.inter_insert_of_mem C1 at A3,
      apply set.eq_of_insert_of_not_mem _ _ A3,
      simp,
      intro C2,
      apply A1,
      apply AX,
    },
    {
      ext a;split;intros D1,
      {
        rw ← A3,
        simp at D1,
        simp [D1],
      },
      {
        have D2:a ≠ x,
        {
          intros D2A,
          subst a,
          apply AX D1,
        },
        rw ← A3 at D1,
        simp [D2] at D1,
        simp [D1],
      },
    },
  },
end

lemma finset.insert_inter_eq_insert_inter_insert {α:Type*} [decidable_eq α]
  {S T:finset α} {a:α}:(insert a S) ∩ (insert a T) = insert a (S ∩ T) :=
begin
  ext b,
  split;intros A1,
  {
    rw finset.mem_insert,
    simp at A1,
    cases A1,
    subst a,
    simp,
    cases A1 with A1 A2,
    cases A1 with A1 A1,
    apply or.inl A1,
    simp [A1,A2],
  },
  {
    simp,
    simp at A1,
    cases A1 with A1 A1,
    apply or.inl A1,
    simp [A1],
  },
end

lemma mem_restrict_set_erase {C:set (set α)} {S c:finset α} {x:α}:x∉ S → (x∈ c) →
  (c ∈ restrict_set C (insert x S))  → (c.erase x ∈ restrict_set C S)
 :=
begin
  intros A1 A2 A3,
  rw mem_restrict_set_insert A1,
  left,
  rw finset.insert_erase,
  apply A3,
  apply A2,
  apply finset.not_mem_erase,
end

lemma restrict_card_le_one_of_VCD_zero {C:set (set α)} {S:finset α}:(VCD C = 0) →
  (restrict_set C S).card ≤ 1 :=
begin
  intros A1,
  apply finset.card_identical_elements,
  intros T U B1 B2,
  apply restrict_set_elements_eq_of_VCD_zero A1 B1 B2,
end

lemma restrict_set_empty_of_empty {S:finset α}:restrict_set ∅ S = ∅ :=
begin
  ext c,
  rw mem_restrict_set,
  split;intros B1,
  {
    cases B1 with c2 B1,
    cases B1 with B1 B2,
    simp at B1,
    exfalso,
    apply B1,
  },
  {
    exfalso,
    simp at B1,
    apply B1,
  },
end

lemma restrict_set_nonempty_empty {C:set (set α)}:
  set.nonempty C → restrict_set C ∅ = {∅} :=
begin
  intros A1,
  ext c,
  rw mem_restrict_set,split;intros B1,
  {
    simp,
    cases B1 with c' B1,
    cases B1 with B1 B2,
    rw ← finset.coe_inj,
    rw ← B2,
    simp,
  },
  {
    simp at B1,
    subst c,
    rw set.nonempty_def at A1,
    cases A1 with c' A1,
    apply exists.intro c',
    apply exists.intro A1,
    simp,
  },
end

lemma restrict_set_empty_card_le_1 {C:set (set α)}:
  (restrict_set C ∅).card ≤ 1 :=
begin
  cases (set.eq_empty_or_nonempty C) with B1 B1,
  {
    subst C,
    rw restrict_set_empty_of_empty,
    simp,
  },
  {
    rw restrict_set_nonempty_empty B1,
    simp,
  },
end

lemma filter_union {S:finset α} {P:α → Prop}:
  finset.filter P S ∪ finset.filter (λ a, ¬P a)  S = S :=
begin
  ext a;split;intro A1,
  {
    simp at A1,
    cases A1 with A1 A1;apply A1.left,
  },
  {
    simp,
    simp [A1],
    apply em,
  },
end

lemma filter_disjoint {S T:finset α} {P:α → Prop}:
  disjoint (finset.filter P S) (finset.filter (λ a, ¬P a)  T) :=
begin
  rw finset.disjoint_left,
  intros a B1 B2,
  simp at B1,
  simp at B2,
  apply B2.right,
  apply B1.right,
end

lemma filter_disjoint' {S:finset α} {P:α → Prop}:
  disjoint (finset.filter P S) (finset.filter (λ a, ¬P a)  S) :=
  @filter_disjoint α S S P

lemma filter_card {S:finset α} {P:α → Prop}:
  (finset.filter P S).card + (finset.filter (λ a, ¬P a)  S).card = S.card :=
begin
  have A1:(finset.filter P S ∪ finset.filter (λ a, ¬P a)  S).card = S.card,
  {
    rw filter_union,
  },
  rw ← A1,
  rw finset.card_union_eq,
  apply filter_disjoint,
end

lemma recursive_restrict_set_card {C:set (set α)} {x:α} {S:finset α}:x∉ S →
  ((restrict_set C (insert x S)).filter (λ c,(x∉c ∧ (insert x c) ∈ (restrict_set
C (insert x S))))).card + (restrict_set C S).card = (restrict_set C (insert x S)).card :=
begin
  intro A1,
  let Ex := restrict_set C (insert x S),
  let E := restrict_set C S,
  begin
    have B1:Ex = restrict_set C (insert x S) := rfl,
    have B2:E = restrict_set C S := rfl,

    repeat {rw ← B1},
    repeat {rw ← B2},
    rw add_comm,
    rw ← @filter_card _ Ex (λ c, x ∈ c),
    simp,
    simp,
    rw ← @filter_card _ (finset.filter (λ c, x∉ c) Ex)
       (λ c, (insert x c) ∈ Ex),
    simp,
    repeat {rw finset.filter_filter},
    rw add_comm _ (finset.filter (λ (a : finset α), x ∉ a ∧ insert x a ∉ Ex) Ex).card,
    rw ← add_assoc,
    simp,
    have C1:(finset.filter (λ (a : finset α), x ∉ a ∧ insert x a ∉ Ex) Ex) =
      (finset.filter (λ (a : finset α), insert x a ∉ Ex) E),
    {
      ext c,split;repeat {rw B1};repeat {rw B2};intros C1A;simp at C1A;simp [C1A],
      { rw mem_restrict_set_insert A1 C1A.right.left, apply or.inr C1A.left},
      {
        have C1B:x ∉ c,
        {
          have C1B1:c ⊆ S := mem_restrict_set_subset C1A.left,
          intro C1B2,
          apply A1,
          apply C1B1,
          apply C1B2,
        },
        have C1C := (mem_restrict_set_insert A1 C1B).mp C1A.left,
        simp [C1A.right] at C1C,
        apply and.intro C1C C1B,
      },
    },
    rw C1,
    clear C1,
    have C2:(finset.filter (has_mem.mem x) Ex).card =
      (finset.filter (λ a, insert x a ∈ Ex) E).card ,
    {
      have C2A:(finset.filter (has_mem.mem x) Ex) =
        (finset.filter (λ a, insert x a ∈ Ex) E).image (insert x),
      {
        ext a,split;repeat {rw B1};repeat {rw B2};intros C2A1;simp at C2A1;simp,
        {
          apply exists.intro (a.erase x),
          cases C2A1 with C2A1 C2A2,
          have C2A3:insert x (a.erase x) = a := finset.insert_erase C2A2,
          have C2A4:x ∉ a.erase x := finset.not_mem_erase x a,
          split,
          split,
          apply mem_restrict_set_erase A1 C2A2 C2A1,
          rw C2A3,
          apply C2A1,
          apply C2A3,
        },
        {
          cases C2A1 with c C2A1,
          cases C2A1 with C2A1 C2A2,
          cases C2A1 with C2A1 C2A3,
          subst a,
          simp [C2A3],
        },
      },
      rw C2A,
      clear C2A,
      repeat {rw B1},
      repeat {rw B2},
      apply finset.card_image_of_inj_on,
      intros c C2B c' C2C,
      simp at C2B,
      simp at C2C,
      have C2D:∀ {c'':finset α}, c'' ∈ restrict_set C S → x ∉ c'',
      {
        intros c'' C2D1 C2D3,
        apply A1,
        have C2D2 := mem_restrict_set_subset C2D1,
        apply C2D2,
        apply C2D3,
      },
      apply finset.eq_of_insert_of_not_mem,
      apply C2D C2B.left,
      apply C2D C2C.left,
    },

    rw C2,
    rw  ← @filter_card _ E (λ a, insert x a ∈ Ex),
    simp,
  end
end

lemma enat.le_coe_eq_coe {v:enat} {d:nat}:v ≤ d → ∃ d':ℕ, v = d'  ∧ d' ≤ d :=
begin
  --intros A1,
  apply enat.cases_on v,
  {
    intros A1,
    simp at A1,
    exfalso,
    apply A1,
  },
  {
    intros n A1,
    apply exists.intro n,
    simp at A1,
    simp [A1],
  },
end

lemma phi_monotone_m {d  m₁ m₂:ℕ}:m₁ ≤ m₂ → Φ d m₁ ≤ Φ d m₂ :=
begin
  intros A1,
  rw le_iff_exists_add at A1,
  cases A1 with c A1,
  subst m₂,
  induction c,
  simp,
  have A2:(m₁ + c_n.succ) = (m₁ + c_n).succ := rfl,
  rw A2,
  cases d,
  simp,
  rw phi_succ_succ,
  apply le_trans c_ih,
  simp,
end

lemma phi_le_d_succ {d m:ℕ}:Φ d m ≤ Φ d.succ m :=
begin
  revert d,
  induction m,
  intro d,
  simp,
  intro d,
  rw phi_succ_succ,
  cases d,
  simp,
  rw phi_succ_succ,
  rw add_comm,
  simp,
  apply le_trans m_ih,
  apply m_ih,
end

lemma phi_monotone_d {d₁ d₂ m:ℕ}:d₁ ≤ d₂ → Φ d₁ m ≤ Φ d₂ m :=
begin
  intros A1,
  rw le_iff_exists_add at A1,
  cases A1 with c A1,
  subst d₂,
  induction c,
  simp,
  have A2:(d₁ + c_n.succ) = (d₁ + c_n).succ := rfl,
  rw A2,
  apply le_trans c_ih,
  apply phi_le_d_succ,
end

lemma eq_restrict_set {C:finset (finset α)} {S:finset α}:(∀ c∈ C , c⊆ S)→
  C = restrict_set (C.to_set_of_sets) S :=
begin
  intros A1,
  ext c,split;intros B1,
  {
    rw mem_restrict_set,
    apply exists.intro (↑c),
    split,
    rw finset.mem_to_set_of_sets,
    apply B1,
    have B2 := A1 c B1,
    apply set.inter_eq_self_of_subset_left,
    simp,
    apply B2,
  },
  {
    rw mem_restrict_set at B1,
    cases B1 with c' B1,
    cases B1 with B1 B2,
    rw finset.mem_to_set_of_sets' at B1,
    cases B1 with c'' B1,
    cases B1 with B1 B2,
    subst c',
    rw set.inter_eq_self_of_subset_left at B2,
    simp at B2,
    subst c'',
    apply B1,
    simp,
    apply A1 c'' B1,
  },
end

lemma finite_restrict_set_eq_image {C:finset (finset α)} {S:finset α}:
  (restrict_set C.to_set_of_sets S) = C.image (λ S', S'∩ S) :=
begin
  ext,split;intros A1A,
  {
    simp,
    rw mem_restrict_set at A1A,
    cases A1A with c A1A,
    cases A1A with A1A A1B,
    rw finset.mem_to_set_of_sets' at A1A,
    cases A1A with c' A1A,
    apply exists.intro c',
    cases A1A with A1A A1C,
    rw A1C at A1B,
    rw ← finset.coe_inter at A1B,
    rw finset.coe_inj at A1B,
    apply and.intro A1A A1B,
  },
  {
    simp at A1A,
    cases A1A with c A1A,
    cases A1A with A1A A1B,
    subst a,
    rw mem_restrict_set,
    apply exists.intro (↑c),
    split,
    rw finset.mem_to_set_of_sets,
    apply A1A,
    rw finset.coe_inter,
  },
end

lemma finite_restrict_set_le {C:finset (finset α)} {S:finset α}:
  (restrict_set C.to_set_of_sets S).card ≤ C.card :=
begin
  rw finite_restrict_set_eq_image,
  apply finset.card_image_le,
end

lemma shatters_subset {S:finset α} {x:α} {C:set (set α)} {S':finset α}:x∉S →
   shatters (
          (
            (restrict_set C (insert x S)).filter
            (λ (c:finset α),(x∉c ∧ ((insert x c) ∈ (restrict_set C (insert x S)))))
          ).to_set_of_sets
        ) S'  → S' ⊆ S :=
begin
  intros A1 A2,
  rw shatters_iff at A2,
  have D1A:S' ⊆ S' := finset.subset.refl S',
  have D1B := A2 S' D1A,
  cases D1B with c D1B,
  cases D1B with D1B D1C,
  rw finset.mem_to_set_of_sets' at D1B,
  cases D1B with c' D1B,
  cases D1B with D1B D1D,
  subst c,
  simp at D1B,
  cases D1B with D1B D1E,
  cases D1E with D1E D1F,
  have D1G:= mem_restrict_set_subset D1B,
  rw ← finset.coe_inter at D1C,
  rw finset.coe_inj at D1C,
  have D1H:S'⊆ c',
  {
    rw ← D1C,
    apply finset.inter_subset_left,
  },
  apply finset.subset.trans D1H,
  apply finset.subset_of_not_mem_of_subset_insert D1E D1G,
end

lemma shatters_succ {S:finset α} {x:α} {C:set (set α)} {S':finset α}:x∉S →
   shatters (
          (
            (restrict_set C (insert x S)).filter
            (λ (c:finset α),(x∉c ∧ ((insert x c) ∈ (restrict_set C (insert x S)))))
          ).to_set_of_sets
        ) S'  → shatters C (insert x S') :=
begin
  intros A1 A2,
  rw shatters_iff,
  intros c B1,
  have D1:S' ⊆ S := shatters_subset A1 A2,
  have D2:(insert x (↑S':set α)) ⊆ (insert x ↑S),
  {
    apply set.insert_subset_insert,
    simp,
    apply D1,
  },

  rw shatters_iff at A2,
  cases (em (x ∈ c)) with A3 A3,
  {
    have C1:c.erase x ⊆ S',
    {
      rw ← finset.subset_insert_iff,
      apply B1,
    },
    have B2 := A2 (c.erase x) C1,
    cases B2 with c' B2,
    cases B2 with B2 B3,
    simp,
    rw finset.mem_to_set_of_sets' at B2,
    cases B2 with c'' B2,
    cases B2 with B2 B4,
    simp at B2,
    cases B2 with B2 B5,
    cases B5 with B5 B6,
    rw mem_restrict_set at B6,
    cases B6 with c''' B6,
    cases B6 with B6 B7,
    subst c',
    apply exists.intro c''',
    apply and.intro B6,
    simp at B7,
    rw ← finset.coe_inter at B3,
    rw finset.coe_inj at B3,

    have B8:insert x (c'' ∩ S') = insert x (c.erase x),
    {
      rw B3,
    },
    rw finset.insert_erase A3 at B8,
    have B9 := set.mem_of_inter_insert B7,
    rw ← finset.insert_inter_eq_insert_inter_insert at B8,
    rw ← B8,
    rw finset.coe_inter,
    repeat {rw finset.coe_insert},
    rw ← B7,
    rw set.inter_assoc,
    rw set.inter_comm (insert x ↑S),
    rw ← set.inter_assoc,
    symmetry,
    apply set.inter_eq_self_of_subset_left,
    have B10:=set.inter_subset_right c''' (insert x ↑S'),
    apply set.subset.trans B10 D2,
   },
  {
    have E1:c ⊆ S',
    {
      rw finset.subset_iff,
      intros a E1A,
      have E1B := B1 E1A,
      rw finset.mem_insert at E1B,
      cases E1B with E1B E1B,
      {
        subst a,
        exfalso,
        apply A3 E1A,
      },
      apply E1B,
    },
    have E2 := A2 c E1,
    cases E2 with c' E2,
    cases E2 with E2 E3,
    rw finset.mem_to_set_of_sets' at E2,
    cases E2 with c'' E2,
    cases E2 with E2 E3,
    simp at E2,
    subst c',
    cases E2 with E2 E4,
    cases E4 with E4 E5,
    rw mem_restrict_set at E2,
    cases E2 with c''' E2,
    cases E2 with E2 E6,
    apply exists.intro c''',
    apply exists.intro E2,
    have E7:x ∉ (↑c'':set α),
    {simp [E4]},
    rw ← set.inter_insert_of_not_mem E7 at E3,
    simp at E6,
    rw ← E3,
    simp,
    rw ← E6,
    rw set.inter_assoc,
    rw set.inter_comm (insert x ↑S),
    rw ← set.inter_assoc,
    symmetry,
    apply set.inter_eq_self_of_subset_left,
    have E8:=set.inter_subset_right c''' (insert x ↑S'),
    apply set.subset.trans E8 D2,
  },
end

lemma VCD_succ {S:finset α} {x:α} {C:set (set α)} {d:ℕ}:x∉S → VCD C = d.succ →
    VCD (
          (
            (restrict_set C (insert x S)).filter
            (λ (c:finset α),(x∉c ∧ ((insert x c) ∈ (restrict_set C (insert x S)))))
          ).to_set_of_sets
        ) ≤ d :=
begin
  intros A1 A2,
  apply VCD_le,
  intros T B1,
  have B2:T ⊆ S := shatters_subset A1 B1,
  have B3:x ∉ T,
  {
    intro B3A,
    apply A1,
    apply B2,
    apply B3A,
  },
  have B4:shatters C (insert x T),
  {
    apply shatters_succ,
    apply A1,
    apply B1,
  },
  have B5:((insert x T).card:enat) ≤ VCD C,
  {
    apply shatters_card_le_VCD B4,
  },
  rw A2 at B5,
  simp at B5,
  rw finset.card_insert_of_not_mem B3 at B5,
  have B6:T.card + 1 = (T.card).succ := rfl,
  rw B6 at B5,
  rw nat.succ_le_succ_iff at B5,
  simp,
  apply B5
end

--This is known as Sauer's Lemma, or Sauer-Saleh Lemma.
--This connects VC-dimension to the complexity of the hypothesis space restricted to a finite set
--of certain size.
lemma restrict_set_le_phi {C:set (set α)} {S:finset α} (d:ℕ):
  (VCD C = d) →
  (restrict_set C S).card ≤ Φ d S.card :=
begin
  revert d,
  revert C,
  apply finset.induction_on S,
  {
    intros C d A1,
    simp,
    apply restrict_set_empty_card_le_1,
  },
  {
    intros x S B1 B2 C d B3,
    cases d,
    {
      rw phi_zero_m_eq_one,
      apply restrict_card_le_one_of_VCD_zero,
      simp at B3,
      apply B3,
    },
    let C':finset (finset α) := (restrict_set C (insert x S)).filter (λ c,(x∉c ∧ (insert x c) ∈ (restrict_set C (insert x S)))),
    begin
      have C0:C' = (restrict_set C (insert x S)).filter (λ c,(x∉c ∧ (insert x c) ∈ (restrict_set C (insert x S)))) := rfl,
      rw ← recursive_restrict_set_card B1,
      rw ← C0,
      have D1:C'.card + (restrict_set C S).card ≤ C'.card +  Φ d.succ S.card,
      {
        simp [B2,B3],
      },
      apply le_trans D1,

      have C5:C' = restrict_set (C'.to_set_of_sets) S,
      {
        apply eq_restrict_set,
        intros c C3A,
        rw C0 at C3A,
        simp at C3A,
        have C3C := mem_restrict_set_subset C3A.left,
        apply finset.subset_of_not_mem_of_subset_insert C3A.right.left C3C,
      },
      rw C5,
      have C6:VCD (C'.to_set_of_sets) ≤ (d:enat),
      {
        rw C0,
        apply VCD_succ,
        apply B1,
        apply B3
      },
      have C7:∃d':ℕ, VCD (C'.to_set_of_sets) = d' ∧ d' ≤ d,
      {
        apply enat.le_coe_eq_coe C6,
      },
      cases C7 with d' C7,
      have C8:(restrict_set C'.to_set_of_sets S).card + Φ d.succ S.card ≤ Φ d S.card + Φ d.succ S.card,
      {
        simp,
        have C8A:(restrict_set C'.to_set_of_sets S).card ≤ Φ d' S.card,
        {
          apply B2,
          apply C7.left,
        },
        apply le_trans C8A,
        apply phi_monotone_d,
        apply C7.right,
      },
      apply le_trans C8,
      rw finset.card_insert_of_not_mem B1,
      rw phi_succ_succ,
      rw add_comm,
    end,
  },
end

-- TODO: prove Φ d m = (finset.range (d.succ)).sum (λ i, nat.choose m i)
-- See mathlib/src/data/nat/choose/basic.lean
-- TODO: introduce ε-nets, and show that the VC dimension of C is a bound on
-- the VC-dimension of the ε-net.
-- TODO: show that if the training examples cover the ε-net, then any consistent
-- algorithm will get a hypothesis with low error.
-- TODO: Introduce the proof from 3.5.2 proving a bound on the probability of
-- hitting the ε-net.
end VC_PAC_problem
end VC_PAC_problem


import bridge_char
import rigid_elements.main
import for_mathlib.valuation_subring.basic

noncomputable theory
open_locale tensor_product
open_locale classical

open module

variables {K F : Type*} [field K] [field F] --[is_prime_field F]

open finite_dimensional

namespace main_theorem_mul_setup

lemma mk_rigid_pair
  (T : submodule F (mul_base_change K F))
  (hT : T.dual_annihilator.acl) :
  rigid_pair (mul_subgroup.mk' T.restrict) (mul_subgroup.mk' T.nonrig.restrict) :=
begin
  let T' := mul_subgroup.mk' T.restrict,
  let H' := mul_subgroup.mk' T.nonrig.restrict,
  have hle' : T' ≤ H',
  { intros t ht,
    use T'.is_unit_of_mem ht,
    apply T.le_nonrig,
    obtain ⟨u,hu⟩ := ht,
    exact hu },
  apply rigid_pair.mk_of_le T' H' hle',
  { refine ⟨(-1 : Kˣ).is_unit, _⟩,
    change _ ∈ T,
    rw [← T.dual_annihilator_dual_annihilator_comap,
      submodule.mem_dual_annihilator_comap_iff],
    intros φ hφ,
    have := hT.neg_one φ hφ,
    convert this, ext, refl },
  { intros x hx hx',
    have hx'' := hx',
    contrapose! hx',
    use is_unit.mk0 x hx,
    change _ ∈ T.nonrig,
    dsimp [submodule.nonrig],
    rw submodule.mem_sup,
    refine ⟨0, T.zero_mem, (units.mk0 x hx).as, _, _⟩,
    { apply submodule.subset_span,
      refine ⟨units.mk0 x hx,_,rfl⟩,
      dsimp [submodule.nonrig_condition],
      split,
      { contrapose! hx'',
        apply hle', use (is_unit.mk0 x hx), dsimp [submodule.restrict],
        change _ ∈ T, convert hx'', ext, refl },
      { intros y hy,
        rw ← hy at hx',
        have : ((units.mk0 x hx)⁻¹ : K) * y = x⁻¹ + 1,
        { field_simp [hy], },
        rw ← this at hx',
        cases hx' with hx'1 hx'2,
        split,
        { contrapose! hx'1,
          use y.is_unit, change _ ∈ T, convert hx'1, ext, refl },
        { contrapose! hx'2,
          use (units.mk0 x hx)⁻¹.is_unit.mul y.is_unit,
          change _ ∈ T, convert hx'2, ext, refl } } },
    { rw zero_add, congr' 1, ext, refl } },
end

lemma mk_rigid_pair_char_two
  [is_prime_field F]
  (htwo : (2 : F) = 0)
  (T : submodule F (mul_base_change K F))
  (hT : T.dual_annihilator.acl) :
  rigid_pair (mul_subgroup.mk' T.restrict) (mul_subgroup.mk' T.restrict) :=
begin
  let T' := mul_subgroup.mk' T.restrict,
  have hneg1 : (-1 : K) ∈ T',
  { refine ⟨(-1 : Kˣ).is_unit, _⟩,
    change _ ∈ T,
    rw [← T.dual_annihilator_dual_annihilator_comap,
      submodule.mem_dual_annihilator_comap_iff],
    intros φ hφ,
    have := hT.neg_one φ hφ,
    convert this, ext, refl },
  apply rigid_pair.mk_of_le T' T' (le_refl _) hneg1,
  { intros x hx1 hx2,
    let y : Kˣ := units.mk0 x hx1,
    let z : Kˣ := units.mk0 (1 + x) _,
    have hh := submodule.dependent_of_acl _ hT (-y) z _,
    rw fintype.not_linear_independent_iff at hh,
    obtain ⟨g,h1,i,h2⟩ := hh,
    simp only [fin.sum_univ_succ, submodule.mkq_apply, matrix.cons_val_zero,
      fintype.univ_of_subsingleton, fin.mk_zero,
      matrix.cons_val_succ, finset.sum_singleton, fin.succ_zero_eq_one] at h1,
    let a := g 0,
    let b := g 1,
    change a • _ + b • _ = _ at h1,
    cases eq_zero_or_one_of_is_prime_field_of_two _ htwo a with ha ha;
    cases eq_zero_or_one_of_is_prime_field_of_two _ htwo b with hb hb,
    { fin_cases i; contradiction, },
    { simp only [ha,hb, zero_smul, zero_add, one_smul,
        submodule.quotient.mk_eq_zero] at h1,
      left, rw submodule.dual_annihilator_dual_annihilator_comap at h1,
      use z.is_unit, change _ ∈ T, convert h1, ext, refl },
    { simp only [ha,hb, zero_smul, add_zero, one_smul,
        submodule.quotient.mk_eq_zero] at h1,
      exfalso,
      apply hx2,
      rw submodule.dual_annihilator_dual_annihilator_comap at h1,
      rw (show x = (-1 : K) * (-x), by ring), apply T'.mul_mem hneg1,
      use (-y).is_unit, change _ ∈ T, convert h1, ext, refl },
    { simp only [ha,hb, one_smul, ← submodule.mkq_apply,
        ← linear_map.map_add, ← units.as_mul] at h1,
      simp only [submodule.mkq_apply, submodule.quotient.mk_eq_zero,
        submodule.dual_annihilator_dual_annihilator_comap] at h1,
      right,
      have : (2 : F) • y.as = (0 : mul_base_change K F),
      { rw [htwo, zero_smul], },
      rw [← sub_zero (-y * z).as,← this,(show (2 : F) = 1 + 1, by ring),
        add_smul, one_smul, ← units.as_mul, sub_eq_add_neg,
        ← units.as_inv, ← units.as_mul] at h1,
      rw (show (x⁻¹ + 1) = (-1) * (-(x⁻¹ + 1)), by ring),
      apply T'.mul_mem hneg1,
      have : -(x⁻¹ + 1) = ↑(-y * z * (y * y)⁻¹),
      { push_cast, field_simp,
        dsimp [z], ring },
      rw this,
      use (-y * z * (y * y)⁻¹).is_unit, change _ ∈ T, convert h1, ext, refl },
    { dsimp [y,z], ring, },
    { intro c, rw add_eq_zero_iff_neg_eq at c, rw c at hneg1,
      exact hx2 hneg1 } }
end

end main_theorem_mul_setup

theorem main_theorem_mul_char_ne_two
  [is_prime_field F]
  (htwo : (2 : F) ≠ 0)
  (T : submodule F (mul_base_change K F))
  (hT : T.dual_annihilator.acl) :
  ∃ (R : valuation_subring K)
    (H : submodule F (mul_base_change K F))
    (hTH : T ≤ H)
    (units : ∀ u : Kˣ, u ∈ R.unit_group → u.as ∈ H)
    (principal_units : ∀ u : Kˣ, u ∈ R.principal_unit_group → u.as ∈ T)
    (fd : finite_dimensional F (↥H ⧸ T.comap H.subtype)),
    finrank F (↥H ⧸ T.comap H.subtype) ≤ 1 :=
begin
  let T' := mul_subgroup.mk' T.restrict,
  let H' := mul_subgroup.mk' T.nonrig.restrict,
  let P : rigid_pair T' H' := main_theorem_mul_setup.mk_rigid_pair T hT,
  obtain ⟨t,ht1,ht2,ht3⟩ := P.exists_preadditive,
  let t' : Kˣ := units.mk0 t ht1,
  let E := T.nonrig ⊔ (submodule.span F ({t'.as} : set (mul_base_change K F))),
  have hE : E = T.nonrig,
  { suffices : (submodule.span F ({t'.as} : set (mul_base_change K F))) ≤ T.nonrig,
    { dsimp [E], exact sup_eq_left.mpr this, },
    rw [submodule.span_le, set.singleton_subset_iff],
    change t'.as ∈ T.nonrig,
    suffices : (2 : F) • t'.as ∈ T.nonrig,
    { convert T.nonrig.smul_mem ((2 : F)⁻¹) this using 1,
      rw [← mul_smul, inv_mul_cancel htwo, one_smul] },
    rw [(show (2 : F) = 1 + 1, by ring), add_smul, one_smul, ← units.as_mul],
    obtain ⟨u,hu⟩ := ht2, convert hu, ext, refl },
  let P' : rigid_pair T' (H'.adjoin_ne_zero t ht1) := _,
  change rigid_pair.preadditive P' at ht3,
  let R := ht3.valuation_subring,
  use [R, T.nonrig, T.le_nonrig],
  refine ⟨_,_,_,_⟩,
  { intros u hu,
    rw ← hE,
    suffices : H'.adjoin_ne_zero t ht1 ≤ mul_subgroup.mk' E.restrict,
    { have hh := ht3.mem_of_mem_units u hu,
      change u ∈ E.restrict,
      suffices : (u : K) ∈ mul_subgroup.mk' E.restrict,
      { obtain ⟨h1,h2⟩ := this,
        convert h2, ext, refl },
      exact this hh, },
    apply mul_subgroup.adjoin_ne_zero_le,
    { intros u hu,
      use H'.is_unit_of_mem hu,
      apply submodule.mem_sup_left,
      obtain ⟨v,hv⟩ := hu,
      exact hv },
    { use is_unit.mk0 t ht1,
      apply submodule.mem_sup_right,
      convert submodule.mem_span_singleton_self _, ext, refl } },
  { intros u hu,
    have := ht3.mem_of_mem_principal_units u hu,
    obtain ⟨v,hv⟩ := this,
    convert hv, ext, refl },
  { apply bridge_finite_dimensional _ hT },
  { apply bridge_codim _ hT },
end

theorem main_theorem_mul_char_two
  [is_prime_field F]
  (htwo : (2 : F) = 0)
  (T : submodule F (mul_base_change K F))
  (hT : T.dual_annihilator.acl) :
  ∃ (R : valuation_subring K)
    (H : submodule F (mul_base_change K F))
    (hTH : T ≤ H)
    (units : ∀ u : Kˣ, u ∈ R.unit_group → u.as ∈ H)
    (principal_units : ∀ u : Kˣ, u ∈ R.principal_unit_group → u.as ∈ T)
    (fd : finite_dimensional F (↥H ⧸ T.comap H.subtype)),
    finrank F (↥H ⧸ T.comap H.subtype) ≤ 1 :=
begin
  let T' := mul_subgroup.mk' T.restrict,
  let P : rigid_pair T' T' :=
    main_theorem_mul_setup.mk_rigid_pair_char_two htwo T hT,
  obtain ⟨t,ht1,ht2,ht3⟩ := P.exists_preadditive,
  let t' : Kˣ := units.mk0 t ht1,
  let P' : rigid_pair T' (T'.adjoin_ne_zero t ht1) := _,
  change rigid_pair.preadditive P' at ht3,
  let R := ht3.valuation_subring, use R,
  let H := T ⊔ (submodule.span F ({t'.as} : set (mul_base_change K F))),
  have hfd : finite_dimensional F (↥H ⧸ (T.comap H.subtype)),
  { let e := (T.comap H.subtype).mkq.comp (submodule.of_le (le_sup_right : _ ≤ T ⊔ _)),
    have he : function.surjective e,
    { apply submodule.mkq_comp_sup_mod_surjective },
    apply e.finite_dimensional_of_surjective, rwa linear_map.range_eq_top },
  use [H, le_sup_left],
  refine ⟨_,_,_,_⟩,
  { intros u hu,
    have hh := ht3.mem_of_mem_units u hu,
    suffices : T'.adjoin_ne_zero t ht1 ≤ mul_subgroup.mk' H.restrict,
    { replace hh := this hh,
      obtain ⟨v,hv⟩ := hh,
      convert hv, ext, refl },
    apply mul_subgroup.adjoin_ne_zero_le,
    { intros u hu, use T'.is_unit_of_mem hu, change _ ∈ H,
      apply submodule.mem_sup_left, obtain ⟨v,hv⟩ := hu, exact hv },
    { use t'.is_unit,
      apply submodule.mem_sup_right,
      convert submodule.mem_span_singleton_self _, ext, refl } },
  { intros u hu,
    have := ht3.mem_of_mem_principal_units u hu,
    obtain ⟨v,hv⟩ := this,
    convert hv, ext, refl },
  { exact hfd },
  { by_cases htT : t ∈ T',
    { have : H = T,
      { erw [sup_eq_left],
        rw submodule.span_singleton_le_iff_mem, obtain ⟨v,hv⟩ := htT, convert hv, ext, refl },
      rw this at hfd ⊢, resetI, rw finrank_le_one_iff, use 0, rintros ⟨w,hw⟩, use 0,
      symmetry,
      simp, },
    apply submodule.finrank_le_one_of_not_linear_independent T {t'.as} t'.as
      (set.mem_singleton (units.as t')),
    { contrapose! htT,
      use t'.is_unit, change _ ∈ T, convert htT, ext, refl },
    { rintros v (rfl : v = t'.as),
      rw fintype.not_linear_independent_iff, use ![1,-1],
      split, { simp [fin.sum_univ_succ] }, { use 0, norm_num } } },
end

theorem main_theorem_mul
  [is_prime_field F]
  (T : submodule F (mul_base_change K F))
  (hT : T.dual_annihilator.acl) :
  ∃ (R : valuation_subring K)
    (H : submodule F (mul_base_change K F))
    (hTH : T ≤ H)
    (units : ∀ u : Kˣ, u ∈ R.unit_group → u.as ∈ H)
    (principal_units : ∀ u : Kˣ, u ∈ R.principal_unit_group → u.as ∈ T)
    (fd : finite_dimensional F (↥H ⧸ T.comap H.subtype)),
    finrank F (↥H ⧸ T.comap H.subtype) ≤ 1 :=
begin
  by_cases htwo : (2 : F) = 0,
  apply main_theorem_mul_char_two, assumption',
  apply main_theorem_mul_char_ne_two, assumption'
end

theorem main_theorem_mul_char
  (p ℓ : ℕ)
  [fact (nat.prime p)]
  (HH : p ≠ ℓ)
  [char_p K p]
  [char_p F ℓ]
  (htwo : (2 : F) ≠ 0)
  (T : submodule F (mul_base_change K F))
  (hT : T.dual_annihilator.acl) :
  ∃ (R : valuation_subring K)
    (H : submodule F (mul_base_change K F))
    (hTH : T ≤ H)
    (units : ∀ u : Kˣ, u ∈ R.unit_group → u.as ∈ H)
    (principal_units : ∀ u : Kˣ, u ∈ R.principal_unit_group → u.as ∈ T)
    (fd : finite_dimensional F (↥H ⧸ T.comap H.subtype)),
    finrank F (↥H ⧸ T.comap H.subtype) ≤ 1 :=
begin
  let T' := mul_subgroup.mk' T.restrict,
  let H' := mul_subgroup.mk' T.nonrig.restrict,
  let P : rigid_pair T' H' := main_theorem_mul_setup.mk_rigid_pair T hT,
  obtain ⟨t,ht1,ht2,ht3⟩ := P.exists_preadditive,
  let t' : Kˣ := units.mk0 t ht1,
  let E := T.nonrig ⊔ (submodule.span F ({t'.as} : set (mul_base_change K F))),
  have hE : E = T.nonrig,
  { suffices : (submodule.span F ({t'.as} : set (mul_base_change K F))) ≤ T.nonrig,
    { dsimp [E], exact sup_eq_left.mpr this, },
    rw [submodule.span_le, set.singleton_subset_iff],
    change t'.as ∈ T.nonrig,
    suffices : (2 : F) • t'.as ∈ T.nonrig,
    { convert T.nonrig.smul_mem ((2 : F)⁻¹) this using 1,
      rw [← mul_smul, inv_mul_cancel htwo, one_smul] },
    rw [(show (2 : F) = 1 + 1, by ring), add_smul, one_smul, ← units.as_mul],
    obtain ⟨u,hu⟩ := ht2, convert hu, ext, refl },
  let P' : rigid_pair T' (H'.adjoin_ne_zero t ht1) := _,
  change rigid_pair.preadditive P' at ht3,
  let R := ht3.valuation_subring,
  use [R, T.nonrig, T.le_nonrig],
  refine ⟨_,_,_,_⟩,
  { intros u hu,
    rw ← hE,
    suffices : H'.adjoin_ne_zero t ht1 ≤ mul_subgroup.mk' E.restrict,
    { have hh := ht3.mem_of_mem_units u hu,
      change u ∈ E.restrict,
      suffices : (u : K) ∈ mul_subgroup.mk' E.restrict,
      { obtain ⟨h1,h2⟩ := this,
        convert h2, ext, refl },
      exact this hh, },
    apply mul_subgroup.adjoin_ne_zero_le,
    { intros u hu,
      use H'.is_unit_of_mem hu,
      apply submodule.mem_sup_left,
      obtain ⟨v,hv⟩ := hu,
      exact hv },
    { use is_unit.mk0 t ht1,
      apply submodule.mem_sup_right,
      convert submodule.mem_span_singleton_self _, ext, refl } },
  { intros u hu,
    have := ht3.mem_of_mem_principal_units u hu,
    obtain ⟨v,hv⟩ := this,
    convert hv, ext, refl },
  { apply bridge_char_finite_dimensional p ℓ HH _ hT },
  { apply bridge_char_codim p ℓ HH _ hT },
end