import for_mathlib.derived.K_projective

open category_theory

variables (A : Type*) [category A] [abelian A] [enough_projectives A]

structure bounded_derived_category :=
(val : bounded_homotopy_category A)
[proj : homotopy_category.is_K_projective val.val]

variable {A}
@[ext]
structure bounded_derived_category_hom (X Y : bounded_derived_category A) :=
(val : X.val ⟶ Y.val)

namespace bounded_derived_category

instance (X : bounded_derived_category A) : homotopy_category.is_K_projective X.val.val := X.proj

@[simps]
instance : category (bounded_derived_category A) :=
{ hom := λ X Y, bounded_derived_category_hom X Y,
  id := λ X, ⟨𝟙 X.val⟩,
  comp := λ X Y Z f g, ⟨f.val ≫ g.val⟩,
  id_comp' := λ X Y f, by { ext1, apply category.id_comp _ },
  comp_id' := λ X Y f, by { ext1, apply category.comp_id _ },
  assoc' := λ X Y Z W f g h, by { ext1, apply category.assoc _ _ _ } }

variable (A)
def forget : bounded_derived_category A ⥤ bounded_homotopy_category A :=
{ obj := λ X, X.val,
  map := λ X Y f, f.val, }

variable {A}

@[simp] lemma forget_map_mk {X Y : bounded_derived_category A} (f : X.val ⟶ Y.val) :
  (forget A).map { val := f } = f :=
rfl

instance : faithful (forget A) := {}

instance : full (forget A) :=
{ preimage := λ X Y f, ⟨f⟩, }

variable {A}
@[simps]
def of (X : bounded_homotopy_category A) [homotopy_category.is_K_projective X.val] :
  bounded_derived_category A := { val := X }

@[simp] lemma forget_obj_of {X : bounded_homotopy_category A} [homotopy_category.is_K_projective X.val] :
  (forget A).obj (of X) = X :=
rfl

@[simps]
def mk_iso {X Y : bounded_derived_category A} (i : (forget A).obj X ≅ (forget A).obj Y) :
  X ≅ Y :=
{ hom := ⟨i.hom⟩,
  inv := ⟨i.inv⟩,
  hom_inv_id' := by { ext1, simp },
  inv_hom_id' := by { ext1, simp } }

variable (A)
@[simps]
noncomputable def localization_functor :
  bounded_homotopy_category A ⥤ bounded_derived_category A :=
{ obj := λ X, of $ X.replace,
  map := λ X Y f, ⟨bounded_homotopy_category.lift (X.π ≫ f) Y.π⟩,
  map_id' := begin
    intros X, symmetry, ext1, apply bounded_homotopy_category.lift_unique,
    dsimp, simp only [category.id_comp, category.comp_id],
  end,
  map_comp' := begin
    intros X Y Z f g,
    symmetry, ext1, apply bounded_homotopy_category.lift_unique,
    dsimp, simp only [category.assoc, bounded_homotopy_category.lift_lifts,
      bounded_homotopy_category.lift_lifts_assoc],
  end }

open homotopy_category

lemma is_iso_localization_functor_map_of_is_quasi_iso
  (X Y : bounded_homotopy_category A) (f : X ⟶ Y)
  [is_quasi_iso f] : is_iso ((localization_functor _).map f) :=
begin
  use bounded_homotopy_category.lift Y.π (X.π ≫ f),
  split,
  { ext1, dsimp,
    apply bounded_homotopy_category.lift_ext (X.π ≫ f),
    simp only [category.assoc, bounded_homotopy_category.lift_lifts, category.comp_id,
      category.id_comp],
    apply_instance },
  { ext1, dsimp,
    apply bounded_homotopy_category.lift_ext Y.π,
    simp only [category.assoc, bounded_homotopy_category.lift_lifts, category.comp_id,
      category.id_comp],
    apply_instance }
end

open_locale zero_object
open category_theory.limits

-- MOVE THIS
lemma zero_is_K_projective {X : bounded_homotopy_category A} (hX : is_zero X) :
  is_K_projective X.val :=
begin
  constructor,
  introsI Y _ f, apply (bounded_homotopy_category.zero_val hX).eq_of_src f
end

protected noncomputable
def zero : bounded_derived_category A :=
{ val := bounded_homotopy_category.zero,
  proj := zero_is_K_projective _ $ bounded_homotopy_category.is_zero_zero }

protected lemma is_zero_zero : limits.is_zero (bounded_derived_category.zero A) :=
{ unique_to := λ Y, nonempty.intro $ unique.mk ⟨⟨0⟩⟩ $ λ a,
    by { ext1, cases a, apply bounded_homotopy_category.is_zero_zero.eq_of_src },
  unique_from := λ Y, nonempty.intro $ unique.mk ⟨⟨0⟩⟩ $ λ a,
    by { ext1, cases a, apply bounded_homotopy_category.is_zero_zero.eq_of_tgt } }

instance has_zero_object : limits.has_zero_object (bounded_derived_category A) :=
⟨⟨bounded_derived_category.zero A, bounded_derived_category.is_zero_zero A⟩⟩

@[simps]
def has_shift_functor (i : ℤ) : bounded_derived_category A ⥤ bounded_derived_category A:=
{ obj := λ X,
  { val := X.val⟦i⟧,
    proj := by { dsimp, apply_instance } },
  map := λ X Y f, ⟨f.val⟦i⟧'⟩,
  map_id' := λ X, by { ext1, dsimp, apply category_theory.functor.map_id },
  map_comp' := λ X Y Z f g, by { ext1, dsimp, apply category_theory.functor.map_comp } }

@[simps] def has_shift_functor_forget (m : ℤ) :
  has_shift_functor A m ⋙ forget A ≅ forget A ⋙ shift_functor (bounded_homotopy_category A) m :=
begin
  fapply nat_iso.of_components,
  { exact λ X, bounded_homotopy_category.mk_iso (by refl), },
  { intros,
    erw [category.id_comp, category.comp_id],
    refl, },
end

noncomputable instance : has_shift (bounded_derived_category A) ℤ :=
has_shift_of_fully_faithful (forget A) (has_shift_functor A) (has_shift_functor_forget A)

@[simp]
lemma shift_functor_val (m : ℤ) {X Y : bounded_derived_category A} (f : X ⟶ Y) :
  ((shift_functor (bounded_derived_category A) m).map f).val =
    (shift_functor (bounded_homotopy_category A) m).map f.val :=
rfl

@[simps]
noncomputable
def shift_functor_forget (m : ℤ) :
  shift_functor (bounded_derived_category A) m ⋙ forget A ≅
    forget A ⋙ shift_functor (bounded_homotopy_category A) m :=
has_shift_of_fully_faithful_comm
  (forget A) (shift_functor (bounded_derived_category A)) (has_shift_functor_forget A) m

@[simps]
noncomputable
def shift_functor_localization_functor (m : ℤ) :
  shift_functor (bounded_homotopy_category A) m ⋙ localization_functor A ≅
    localization_functor A ⋙ shift_functor (bounded_derived_category A) m :=
begin
  fapply nat_iso.of_components,
  { intros,
    apply mk_iso,
    refine _ ≪≫ ((shift_functor_forget A m).app _).symm,
    dsimp,
    exact
    { hom := bounded_homotopy_category.lift ((shift_functor (bounded_homotopy_category A) m).obj X).π
        ((shift_functor (bounded_homotopy_category A) m).map X.π),
      inv := bounded_homotopy_category.lift ((shift_functor (bounded_homotopy_category A) m).map X.π)
        ((shift_functor (bounded_homotopy_category A) m).obj X).π, }, },
  { intros, ext, dsimp,
    simp only [bounded_homotopy_category.lift_comp_lift_self_assoc, category_theory.category.assoc],
    erw [category.comp_id, category.id_comp],
    simp [bounded_homotopy_category.shift_functor_map_lift], },
end

-- TODO replace this by pulling back a preadditive instance along `forget`?
@[simps]
instance preadditive : preadditive (bounded_derived_category A) :=
{ hom_group := λ P Q,
  { add := λ f g, ⟨f.val + g.val⟩,
    add_assoc := by { intros, ext, apply add_assoc },
    zero := ⟨0⟩,
    zero_add := by { intros, ext, apply zero_add },
    add_zero := by { intros, ext, apply add_zero },
    nsmul := λ n f, ⟨n • f.val⟩,
    nsmul_zero' := by { intros f, ext, refine add_comm_monoid.nsmul_zero' f.val, },
    nsmul_succ' := by { intros n f, ext, exact add_comm_monoid.nsmul_succ' _ f.val },
    neg := λ f, ⟨-f.val⟩,
    sub := λ f g, ⟨f.val - g.val⟩,
    sub_eq_add_neg := by { intros, ext, apply sub_eq_add_neg },
    zsmul := λ n f, ⟨n • f.val⟩,
    zsmul_zero' := by { intros f, ext, apply add_comm_group.zsmul_zero' f.val },
    zsmul_succ' := by { intros n f, ext, apply add_comm_group.zsmul_succ' _ f.val },
    zsmul_neg' := by { intros n f, ext, apply add_comm_group.zsmul_neg' _ f.val },
    add_left_neg := by { intros, ext, apply add_left_neg },
    add_comm := by { intros, ext, apply add_comm } },
  add_comp' :=
    by { intros P Q R f₁ f₂ g, ext, apply preadditive.add_comp _ _ _ f₁.val f₂.val g.val },
  comp_add' :=
    by { intros P Q R f g₁ g₂, ext, apply preadditive.comp_add _ _ _ f.val g₁.val g₂.val } }

instance additive (n : ℤ) : (shift_functor (bounded_derived_category A) n).additive :=
{ map_add' := begin
    intros P Q f g,
    ext1,
    dsimp,
    erw ← (shift_functor (bounded_homotopy_category A) n).map_add,
  end }

variable (A)
@[simps]
noncomputable def forget_triangulated_functor_struct :
  triangulated.pretriangulated.triangulated_functor_struct
    (bounded_derived_category A) (bounded_homotopy_category A) :=
{ to_functor := forget A,
  comm_shift := nat_iso.of_components (λ X, by refl) (by tidy), }

variable {A}
@[simps]
def lift {C : Type*} [category C] (F : bounded_homotopy_category A ⥤ C) :
  bounded_derived_category A ⥤ C :=
{ obj := λ X, F.obj X.val,
  map := λ X Y f, F.map f.val,
  map_id' := λ X, F.map_id _,
  map_comp' := λ X Y Z f g, F.map_comp _ _ }

noncomputable
def localize_lift {C : Type*} [category C]
  (F : bounded_homotopy_category A ⥤ C)
  [∀ (X Y : bounded_homotopy_category A) (f : X ⟶ Y)
    [h : is_quasi_iso f], is_iso (F.map f)] :
  localization_functor A ⋙ lift F ≅ F :=
nat_iso.of_components
(λ X, as_iso $ F.map X.π)
begin
  intros X Y f,
  dsimp,
  simp only [← F.map_comp],
  congr' 1,
  rw bounded_homotopy_category.lift_lifts,
end

@[simp, reassoc] lemma π_lift_id_π (X : bounded_derived_category A) :
  X.val.π ≫ bounded_homotopy_category.lift (𝟙 X.val) X.val.π = 𝟙 X.val.replace :=
begin
  refine bounded_homotopy_category.lift_ext X.val.π _ _ _,
  rw [category.assoc, bounded_homotopy_category.lift_lifts, category.id_comp, category.comp_id],
end

@[simps]
noncomputable
def localization_iso (X : bounded_derived_category A) :
  (localization_functor A).obj X.val ≅ X :=
{ hom := ⟨X.val.π⟩,
  inv := ⟨bounded_homotopy_category.lift (𝟙 _) X.val.π⟩, }

noncomputable
def lift_unique {C : Type*} [category C]
  (F : bounded_homotopy_category A ⥤ C)
  [∀ (X Y : bounded_homotopy_category A) (f : X ⟶ Y)
    [h : is_quasi_iso f], is_iso (F.map f)]
  (G : bounded_derived_category A ⥤ C)
  (e : F ≅ localization_functor A ⋙ G) :
  lift F ≅ G :=
nat_iso.of_components
(λ X, e.app X.val ≪≫ G.map_iso (localization_iso _))
begin
  intros X Y f,
  simp only [lift_map, iso.trans_hom, iso.app_hom, functor.map_iso_hom, nat_trans.naturality_assoc,
    functor.comp_map, category.assoc, nat_iso.cancel_nat_iso_hom_left],
  rw [← functor.map_comp, ← functor.map_comp],
  congr' 1,
  ext,
  simp only [category_theory.category_comp_val, localization_functor_map_val,
    localization_iso_hom_val, bounded_homotopy_category.lift_lifts],
end

open category_theory.triangulated

variable {A}
@[simps obj₁ obj₂ obj₃ mor₁ mor₂ mor₃]
noncomputable
def replace_triangle (S : triangle (bounded_homotopy_category A)) :
  triangle (bounded_derived_category A) :=
{ obj₁ := of $ S.obj₁.replace,
  obj₂ := of $ S.obj₂.replace,
  obj₃ := of $ S.obj₃.replace,
  mor₁ := ⟨bounded_homotopy_category.lift (S.obj₁.π ≫ S.mor₁) S.obj₂.π⟩,
  mor₂ := ⟨bounded_homotopy_category.lift (S.obj₂.π ≫ S.mor₂) S.obj₃.π⟩,
  mor₃ := begin
    haveI : is_quasi_iso
      ((shift_functor (bounded_homotopy_category A) (1 : ℤ)).map S.obj₁.π) :=
    by { change is_quasi_iso ((S.obj₁.π)⟦(1 : ℤ)⟧'), by apply_instance }, -- WAT?
    exact ⟨bounded_homotopy_category.lift (S.obj₃.π ≫ S.mor₃) (S.obj₁.π⟦(1 : ℤ)⟧')⟩,
  end }

@[simps]
noncomputable
def replace_triangle_map {S T : triangle (bounded_homotopy_category A)} (f : S ⟶ T) :
  replace_triangle S ⟶ replace_triangle T :=
{ hom₁ := ⟨bounded_homotopy_category.lift (S.obj₁.π ≫ f.hom₁) T.obj₁.π⟩,
  hom₂ := ⟨bounded_homotopy_category.lift (S.obj₂.π ≫ f.hom₂) T.obj₂.π⟩,
  hom₃ := ⟨bounded_homotopy_category.lift (S.obj₃.π ≫ f.hom₃) T.obj₃.π⟩,
  comm₁' := by { ext, dsimp, simp only [triangle_morphism.comm₁, category.assoc,
    bounded_homotopy_category.lift_comp_lift_comp], },
  comm₂' := by { ext, dsimp, simp only [triangle_morphism.comm₂, category.assoc,
    bounded_homotopy_category.lift_comp_lift_comp], },
  comm₃' := begin
    ext, dsimp,
    rw [bounded_homotopy_category.shift_functor_map_lift, category_theory.functor.map_comp,
      bounded_homotopy_category.lift_comp_lift_comp, bounded_homotopy_category.lift_comp_lift_comp,
      category.assoc, triangle_morphism.comm₃, category.assoc],
  end, }

.

lemma replace_triangle_map_id (X : triangle (bounded_homotopy_category A)) :
  replace_triangle_map (𝟙 X) = 𝟙 (replace_triangle X) :=
by tidy

lemma replace_triangle_map_comp {X Y Z : triangle (bounded_homotopy_category A)}
  (f : X ⟶ Y) (g : Y ⟶ Z) :
  replace_triangle_map (f ≫ g) = replace_triangle_map f ≫ replace_triangle_map g :=
by ext; tidy

noncomputable
def replace_triangle' : triangle (bounded_homotopy_category A) ⥤ triangle (bounded_derived_category A) :=
{ obj := replace_triangle,
  map := λ S T f, replace_triangle_map f,
  map_id' := replace_triangle_map_id,
  map_comp' := λ X Y Z f g, replace_triangle_map_comp f g, }

attribute [simps obj_obj₁ obj_obj₂ obj_obj₃ obj_mor₁ obj_mor₂ obj_mor₃] replace_triangle'
attribute [simps map_hom₁ map_hom₂ map_hom₃] replace_triangle'

noncomputable
def replace_triangle_rotate (S : triangle (bounded_homotopy_category A)) :
  (replace_triangle S).rotate ≅ replace_triangle S.rotate :=
begin
  fapply triangle.iso.of_components,
  exact iso.refl _,
  exact iso.refl _,
  exact ((shift_functor_localization_functor A 1).app S.obj₁).symm,
  { ext, dsimp, simp, },
  { ext, dsimp, erw [category.id_comp, category.id_comp], simp, },
  { ext, dsimp,
    simp only [bounded_homotopy_category.lift_neg, bounded_homotopy_category.lift_comp_lift_comp,
      preadditive.comp_neg, preadditive.neg_comp, neg_inj, category.assoc,
      category_theory.functor.map_id],
   erw [category.id_comp, category.comp_id],
   simp [bounded_homotopy_category.shift_functor_map_lift], },
end

@[simps]
noncomputable def forget_replace_triangle (S : triangle (bounded_homotopy_category A)) :
  (forget_triangulated_functor_struct A).map_triangle.obj (replace_triangle S) ≅
    bounded_homotopy_category.replace_triangle S :=
begin
  fapply triangle.iso.of_components,
  apply iso.refl _,
  apply iso.refl _,
  apply iso.refl _,
  all_goals { dsimp, simp, },
end

variable (A)

def pretriangulated_distinguished_triangles :=
 { T |
    ∃ (S : triangle (bounded_homotopy_category A))
      (hS : S ∈ dist_triang (bounded_homotopy_category A))
      (f : T ≅ replace_triangle S), true }

variable {A}

lemma isomorphic_distinguished (T₁ : triangle (bounded_derived_category A))
  (m : T₁ ∈ pretriangulated_distinguished_triangles A)
  (T₂ : triangle (bounded_derived_category A)) (i : T₂ ≅ T₁) :
  T₂ ∈ pretriangulated_distinguished_triangles A :=
begin
  obtain ⟨S₁, hS₁, f₁, hf₁⟩ := m,
  exact ⟨S₁, hS₁, i ≪≫ f₁, trivial⟩,
end

lemma forget_replace_triangle_distinguished (S : triangle (bounded_homotopy_category A))
  (m : S ∈ dist_triang (bounded_homotopy_category A)) :
  (forget_triangulated_functor_struct A).map_triangle.obj (replace_triangle S) ∈ dist_triang (bounded_homotopy_category A) :=
pretriangulated.isomorphic_distinguished
  _ (bounded_homotopy_category.distinguished_replace_triangle S m)
  _ (forget_replace_triangle S)

lemma forget_distinguished_of_distinguished
  {T : triangle (bounded_derived_category A)} (m : T ∈ pretriangulated_distinguished_triangles A) :
  (forget_triangulated_functor_struct A).map_triangle.obj T ∈ dist_triang (bounded_homotopy_category A) :=
begin
  obtain ⟨S, hS, f, -⟩ := m,
  exact pretriangulated.isomorphic_distinguished _ (forget_replace_triangle_distinguished _ hS)
    _ ((forget_triangulated_functor_struct A).map_triangle.map_iso f),
end

lemma pretriangulated_contractible_distinguished (X : bounded_derived_category A) :
  contractible_triangle (bounded_derived_category A) X ∈
    pretriangulated_distinguished_triangles A :=
begin
  refine ⟨contractible_triangle _ X.val, pretriangulated.contractible_distinguished _, ⟨_, trivial⟩⟩,
  symmetry,
  fapply triangle.iso.of_components,
  exact localization_iso X,
  exact localization_iso X,
  refine _ ≪≫ localization_iso 0,
  { dsimp,
    refine (localization_functor _).map_iso _,
    refine ⟨0,0,_,_⟩,
    simp only [eq_iff_true_of_subsingleton],
    simp only [zero_comp, auto_param_eq],
    erw ← (forget A).map_id,
    simp only [id_zero, functor.map_zero] },
  { ext,
    dsimp,
    simp only [bounded_homotopy_category.lift_lifts] },
  { ext,
    dsimp,
    simp only [bounded_homotopy_category.lift_lifts, category.assoc, comp_zero] },
  { ext,
    dsimp,
    simp only [bounded_homotopy_category.lift_lifts, comp_zero] },
end

@[simp]
lemma shift_functor_map_val (m : ℤ) {X Y : bounded_derived_category A} (f : X ⟶ Y) :
  ((shift_functor (bounded_derived_category A) m).map f).val =
    (shift_functor (bounded_homotopy_category A) m).map f.val :=
rfl

lemma pretriangulated_distinguished_cocone_triangle
  {X Y : bounded_derived_category A}
  (f : X ⟶ Y) :
  ∃ (Z : bounded_derived_category A) (g : Y ⟶ Z)
    (h : Z ⟶ (shift_functor (bounded_derived_category A) 1).obj X),
    triangle.mk (bounded_derived_category A) f g h ∈
      pretriangulated_distinguished_triangles A :=
begin
  obtain ⟨Z, g, h, m⟩ := pretriangulated.distinguished_cocone_triangle _ _ f.val,
  use (localization_functor A).obj Z,
  use (localization_iso Y).inv ≫ (localization_functor A).map g,
  refine ⟨(localization_functor A).map (h ≫ eq_to_hom (by refl)) ≫ (localization_iso _).hom, _⟩,
  refine ⟨_, m, ⟨_, trivial⟩⟩,
  symmetry,
  fapply triangle.iso.of_components,
  { exact localization_iso _, },
  { exact localization_iso _, },
  { exact iso.refl _, },
  { ext, dsimp, simp only [bounded_homotopy_category.lift_lifts], },
  { ext, dsimp,
    simp only [category.comp_id, bounded_derived_category.π_lift_id_π_assoc], },
  { ext, dsimp,
    simp only [category.comp_id, category.id_comp, bounded_homotopy_category.lift_lifts], },
end

lemma rotate_distinguished_triangle (T : triangle (bounded_derived_category A)) :
  T ∈ pretriangulated_distinguished_triangles A ↔
    T.rotate ∈ pretriangulated_distinguished_triangles A :=
begin
  split,
  { rintro ⟨S, hS, f, -⟩,
    use S.rotate,
    refine ⟨pretriangulated.rot_of_dist_triangle _ _ hS, _, trivial⟩,
    exact (rotate _).map_iso f ≪≫ replace_triangle_rotate _, },
  { rintro ⟨S, hS, f, -⟩,
    use S.inv_rotate,
    refine ⟨pretriangulated.inv_rot_of_dist_triangle _ _ hS, _, trivial⟩,

    apply (iso_equiv_of_fully_faithful (rotate (bounded_derived_category A))).inv_fun,
    refine f ≪≫ _ ≪≫ (replace_triangle_rotate _).symm,
    apply replace_triangle'.map_iso,
    exact (triangle_rotation _).counit_iso.symm.app S, },
end

lemma complete_distinguished_triangle_morphism (T₁ T₂ : triangle (bounded_derived_category A))
    (m₁ : T₁ ∈ pretriangulated_distinguished_triangles A)
    (m₂ : T₂ ∈ pretriangulated_distinguished_triangles A)
    (a : T₁.obj₁ ⟶ T₂.obj₁) (b : T₁.obj₂ ⟶ T₂.obj₂)
    (comm : T₁.mor₁ ≫ b = a ≫ T₂.mor₁) :
      (∃ (c : T₁.obj₃ ⟶ T₂.obj₃), T₁.mor₂ ≫ c = b ≫ T₂.mor₂ ∧
        T₁.mor₃ ≫ (shift_functor (bounded_derived_category A) 1).map a = c ≫ T₂.mor₃) :=
begin
  -- We work formally, just using the fact this is true in the bounded homotopy category,
  -- without needing to care why.
  obtain ⟨c', h1, h2⟩ := pretriangulated.complete_distinguished_triangle_morphism
    ((forget_triangulated_functor_struct A).map_triangle.obj T₁)
    ((forget_triangulated_functor_struct A).map_triangle.obj T₂)
    (forget_distinguished_of_distinguished m₁)
    (forget_distinguished_of_distinguished m₂) ((forget A).map a) ((forget A).map b)
    (congr_arg bounded_derived_category_hom.val comm),
  use c',
  dsimp at h1 h2,
  split,
  { apply (forget A).map_injective,
    simpa only [(forget A).map_comp] using h1, },
  { apply (forget A).map_injective,
    simp only [category_theory.category.comp_id] at h2,
    simp only [(forget A).map_comp],
    exact h2, },
end

variable (A)

instance pretriangulated : triangulated.pretriangulated (bounded_derived_category A) :=
{ distinguished_triangles := pretriangulated_distinguished_triangles A,
  isomorphic_distinguished := isomorphic_distinguished,
  contractible_distinguished := pretriangulated_contractible_distinguished,
  distinguished_cocone_triangle := λ X Y f, pretriangulated_distinguished_cocone_triangle f,
  rotate_distinguished_triangle := rotate_distinguished_triangle,
  complete_distinguished_triangle_morphism := complete_distinguished_triangle_morphism, }

variable (A)
noncomputable
def Ext (n : ℤ) : (bounded_derived_category A)ᵒᵖ ⥤ bounded_derived_category A ⥤ Ab :=
functor.flip $ shift_functor _ n ⋙ preadditive_yoneda

@[simp]
lemma Ext_obj_obj (n : ℤ) (X : (bounded_derived_category A)ᵒᵖ) (Y : bounded_derived_category A) :
  ((Ext A n).obj X).obj Y = AddCommGroup.of (X.unop ⟶ Y⟦n⟧) := rfl

@[simp]
lemma Ext_map_app_apply (n : ℤ) {X Y : (bounded_derived_category A)ᵒᵖ}
  (f : X ⟶ Y) (Z : bounded_derived_category A) (e : ((Ext A n).obj X).obj Z) :
  ((Ext A n).map f).app Z e = f.unop ≫ e := rfl

@[simp]
lemma Ext_obj_map (n : ℤ) (X : (bounded_derived_category A)ᵒᵖ) {Y Z : bounded_derived_category A}
  (f : Y ⟶ Z) (e : ((Ext A n).obj X).obj Y) : ((Ext A n).obj X).map f e =
  e ≫ f⟦n⟧' := rfl

end bounded_derived_category

/-
0 → A → B → C → 0

A -f→ B → Cone(f) → A[1]

Canonical Cone(f) → C quasi iso

-/


/-
  First argument of the ring lemma.

  We show that the map from R[1/f] to R[1/fᵢ] inverts fᵢ/1.
-/

import ring_theory.localization
import to_mathlib.localization.localization_alt
import spectrum_of_a_ring.structure_presheaf
import spectrum_of_a_ring.structure_presheaf_localization
import spectrum_of_a_ring.structure_presheaf_res

universe u

local attribute [instance] classical.prop_decidable

noncomputable theory

section structure_presheaf

open topological_space
open classical
open localization
open localization_alt

variables {R : Type u} [comm_ring R]
variables {U V : opens (Spec R)} (BU : U ∈ D_fs R) (BV : V ∈ D_fs R) (H : V ⊆ U)

lemma structure_presheaf.res.inverts_data
: inverts_data
    (powers (of (some BV)))
    (structure_presheaf_on_basis.res BU BV H) :=
begin
  rintros ⟨s, Hs⟩,
  rcases (indefinite_description _ Hs) with ⟨n, Hn⟩,
  rw ←@is_semiring_hom.map_pow R _ _ _ of (@is_ring_hom.is_semiring_hom _ _ _ _ of of.is_ring_hom) _ _ at Hn,
  dsimp only [subtype.coe_mk],
  rw ←Hn,
  dsimp [structure_presheaf_on_basis.res],
  rw is_localization_initial_comp,
  exact structure_presheaf.inverts_data BV ⟨(some BV)^n, ⟨n, rfl⟩⟩,
end

lemma structure_presheaf.res.has_denom_data
: has_denom_data
    (powers (of (some BV)))
    (structure_presheaf_on_basis.res BU BV H) :=
begin
  intros x,
  rcases (structure_presheaf.has_denom_data BV x) with ⟨⟨⟨q, Hq⟩, p⟩, Hpq⟩,
  rcases (indefinite_description _ Hq) with ⟨n, Hn⟩,
  dsimp only [subtype.coe_mk] at Hpq,
  let p' : localization R (S U) := of p,
  let q' : localization R (S U) := (of ((some BV)^n)),
  have Hq' : q' ∈ powers ((of : R → localization R (S U)) (some BV)),
    dsimp [q'],
    rw is_semiring_hom.map_pow (of : R → localization R (S U)),
    exact ⟨n, rfl⟩,
  use ⟨⟨q', Hq'⟩, p'⟩,
  dsimp only [subtype.coe_mk, q', p', structure_presheaf_on_basis.res],
  iterate 2 { rw is_localization_initial_comp, },
  rw Hn,
  exact Hpq,
end

lemma structure_presheaf.res.ker_le
: ker (structure_presheaf_on_basis.res BU BV H) ≤ submonoid_ann (powers (of (some BV))) :=
begin
  intros x Hx,
  change structure_presheaf_on_basis.res BU BV H x = 0 at Hx,
  rcases (structure_presheaf.has_denom_data BU x) with ⟨⟨⟨q, Hq⟩, p⟩, Hpq⟩,
  rcases (indefinite_description _ Hq) with ⟨n, Hn⟩,
  dsimp only [subtype.coe_mk] at Hpq,
  have Hofp : structure_presheaf_on_basis.res BU BV H (of p) = 0,
    rw [←Hpq, is_ring_hom.map_mul (structure_presheaf_on_basis.res BU BV H), Hx, mul_zero],
  dsimp only [structure_presheaf_on_basis.res] at Hofp,
  rw is_localization_initial_comp at Hofp,
  have Hpker : p ∈ ker (of : R → localization R (S V)) := Hofp,
  have Hpann := (structure_presheaf.ker_le BV) Hpker,
  rcases Hpann with ⟨⟨⟨u, ⟨v, ⟨m, Hm⟩⟩⟩, Huv⟩, Hp⟩,
  dsimp only [subtype.coe_mk] at Huv,
  dsimp only [subtype.coe_mk] at Hp,
  rw [Hp, ←Hm] at Huv,
  rcases (indefinite_description _ (pow_eq.of_basis_subset BU BV H)) with ⟨a, Ha⟩,
  rcases (indefinite_description _ Ha) with ⟨e, Hea⟩,
  rw mul_comm at Hea,
  dsimp only [submonoid_ann, set.range, ann_aux],
  let g' : localization R (S U) := (of (some BV))^(e * n + m),
  let Hg' : g' ∈ powers ((of : R → localization R (S U)) (some BV)),
    dsimp [g'],
    exact ⟨(e * n + m), rfl⟩,
  have Hxann : x * g' = 0,
    dsimp [g'],
    rw [←is_semiring_hom.map_pow (of : R → localization R (S U)), pow_add],
    rw [is_ring_hom.map_mul (of : R → localization R (S U)), pow_mul, Hea, mul_pow],
    rw [is_ring_hom.map_mul (of : R → localization R (S U))],
    rw [←mul_assoc, ←mul_assoc, Hn, mul_comm x, Hpq, mul_comm (of p), mul_assoc],
    rw [←is_ring_hom.map_mul (of : R → localization R (S U)), Huv],
    rw [is_ring_hom.map_zero (of : R → localization R (S U)), mul_zero],
  use ⟨⟨x, ⟨g', Hg'⟩⟩, Hxann⟩,
end

lemma structure_presheaf.res.localization
: is_localization_data
    (powers (of (some BV)))
    (structure_presheaf_on_basis.res BU BV H) :=
{ inverts := structure_presheaf.res.inverts_data BU BV H,
  has_denom := structure_presheaf.res.has_denom_data BU BV H,
  ker_le := structure_presheaf.res.ker_le BU BV H }

end structure_presheaf


/-
Copyright (c) 2018 Robert Y. Lewis. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Robert Y. Lewis

A tactic for discharging linear arithmetic goals using Fourier-Motzkin elimination.

`linarith` is (in principle) complete for ℚ and ℝ. It is not complete for non-dense orders, i.e. ℤ.

@TODO: investigate storing comparisons in a list instead of a set, for possible efficiency gains
@TODO: delay proofs of denominator normalization and nat casting until after contradiction is found
-/

import tactic.ring data.nat.gcd data.list.basic meta.rb_map

meta def nat.to_pexpr : ℕ → pexpr
| 0 := ``(0)
| 1 := ``(1)
| n := if n % 2 = 0 then ``(bit0 %%(nat.to_pexpr (n/2))) else ``(bit1 %%(nat.to_pexpr (n/2)))

open native
namespace linarith

section lemmas

lemma int.coe_nat_bit0 (n : ℕ) : (↑(bit0 n : ℕ) : ℤ) = bit0 (↑n : ℤ) := by simp [bit0]
lemma int.coe_nat_bit1 (n : ℕ) : (↑(bit1 n : ℕ) : ℤ) = bit1 (↑n : ℤ) := by simp [bit1, bit0]
lemma int.coe_nat_bit0_mul (n : ℕ) (x : ℕ) : (↑(bit0 n * x) : ℤ) = (↑(bit0 n) : ℤ) * (↑x : ℤ) := by simp
lemma int.coe_nat_bit1_mul (n : ℕ) (x : ℕ) : (↑(bit1 n * x) : ℤ) = (↑(bit1 n) : ℤ) * (↑x : ℤ) := by simp
lemma int.coe_nat_one_mul (x : ℕ) : (↑(1 * x) : ℤ) = 1 * (↑x : ℤ) := by simp
lemma int.coe_nat_zero_mul (x : ℕ) : (↑(0 * x) : ℤ) = 0 * (↑x : ℤ) := by simp
lemma int.coe_nat_mul_bit0 (n : ℕ) (x : ℕ) : (↑(x * bit0 n) : ℤ) = (↑x : ℤ) * (↑(bit0 n) : ℤ) := by simp
lemma int.coe_nat_mul_bit1 (n : ℕ) (x : ℕ) : (↑(x * bit1 n) : ℤ) = (↑x : ℤ) * (↑(bit1 n) : ℤ) := by simp
lemma int.coe_nat_mul_one (x : ℕ) : (↑(x * 1) : ℤ) = (↑x : ℤ) * 1 := by simp
lemma int.coe_nat_mul_zero (x : ℕ) : (↑(x * 0) : ℤ) = (↑x : ℤ) * 0 := by simp

lemma nat_eq_subst {n1 n2 : ℕ} {z1 z2 : ℤ} (hn : n1 = n2) (h1 : ↑n1 = z1) (h2 : ↑n2 = z2) : z1 = z2 :=
by simpa [eq.symm h1, eq.symm h2, int.coe_nat_eq_coe_nat_iff]

lemma nat_le_subst {n1 n2 : ℕ} {z1 z2 : ℤ} (hn : n1 ≤ n2) (h1 : ↑n1 = z1) (h2 : ↑n2 = z2) : z1 ≤ z2 :=
by simpa [eq.symm h1, eq.symm h2, int.coe_nat_le]

lemma nat_lt_subst {n1 n2 : ℕ} {z1 z2 : ℤ} (hn : n1 < n2) (h1 : ↑n1 = z1) (h2 : ↑n2 = z2) : z1 < z2 :=
by simpa [eq.symm h1, eq.symm h2, int.coe_nat_lt]

lemma eq_of_eq_of_eq {α} [ordered_semiring α] {a b : α} (ha : a = 0) (hb : b = 0) : a + b = 0 :=
by simp *

lemma le_of_eq_of_le {α} [ordered_semiring α] {a b : α} (ha : a = 0) (hb : b ≤ 0) : a + b ≤ 0 :=
by simp *

lemma lt_of_eq_of_lt {α} [ordered_semiring α] {a b : α} (ha : a = 0) (hb : b < 0) : a + b < 0 :=
by simp *

lemma le_of_le_of_eq {α} [ordered_semiring α] {a b : α} (ha : a ≤ 0) (hb : b = 0) : a + b ≤ 0 :=
by simp *

lemma lt_of_lt_of_eq {α} [ordered_semiring α] {a b : α} (ha : a < 0) (hb : b = 0) : a + b < 0 :=
by simp *

lemma mul_neg {α} [ordered_ring α] {a b : α} (ha : a < 0) (hb : b > 0) : b * a < 0 :=
have (-b)*a > 0, from mul_pos_of_neg_of_neg (neg_neg_of_pos hb) ha,
neg_of_neg_pos (by simpa)

lemma mul_nonpos {α} [ordered_ring α] {a b : α} (ha : a ≤ 0) (hb : b > 0) : b * a ≤ 0 :=
have (-b)*a ≥ 0, from mul_nonneg_of_nonpos_of_nonpos (le_of_lt (neg_neg_of_pos hb)) ha,
nonpos_of_neg_nonneg (by simp at this; exact this)

lemma mul_eq {α} [ordered_semiring α] {a b : α} (ha : a = 0) (hb : b > 0) : b * a = 0 :=
by simp *

lemma eq_of_not_lt_of_not_gt {α} [linear_order α] (a b : α) (h1 : ¬ a < b) (h2 : ¬ b < a) : a = b :=
le_antisymm (le_of_not_gt h2) (le_of_not_gt h1)

lemma add_subst {α} [ring α] {n e1 e2 t1 t2 : α} (h1 : n * e1 = t1) (h2 : n * e2 = t2) :
      n * (e1 + e2) = t1 + t2 := by simp [left_distrib, *]

lemma sub_subst {α} [ring α] {n e1 e2 t1 t2 : α} (h1 : n * e1 = t1) (h2 : n * e2 = t2) :
      n * (e1 - e2) = t1 - t2 := by simp [left_distrib, *]

lemma neg_subst {α} [ring α] {n e t : α} (h1 : n * e = t) : n * (-e) = -t := by simp *

private meta def apnn : tactic unit := `[norm_num]

lemma mul_subst {α} [comm_ring α] {n1 n2 k e1 e2 t1 t2 : α} (h1 : n1 * e1 = t1) (h2 : n2 * e2 = t2)
     (h3 : n1*n2 = k . apnn) : k * (e1 * e2) = t1 * t2 :=
have h3 : n1 * n2 = k, from h3,
by rw [←h3, mul_comm n1, mul_assoc n2, ←mul_assoc n1, h1, ←mul_assoc n2, mul_comm n2, mul_assoc, h2] -- OUCH

lemma div_subst {α} [field α] {n1 n2 k e1 e2 t1 : α} (h1 : n1 * e1 = t1) (h2 : n2 / e2 = 1) (h3 : n1*n2 = k) :
      k * (e1 / e2) = t1 :=
by rw [←h3, mul_assoc, mul_div_comm, h2, ←mul_assoc, h1, mul_comm, one_mul]

end lemmas

section datatypes

@[derive decidable_eq]
inductive ineq
| eq | le | lt

open ineq

def ineq.max : ineq → ineq → ineq
| eq a := a
| le a := a
| lt a := lt

def ineq.is_lt : ineq → ineq → bool
| eq le := tt
| eq lt := tt
| le lt := tt
| _ _ := ff

def ineq.to_string : ineq → string
| eq := "="
| le := "≤"
| lt := "<"

instance : has_to_string ineq := ⟨ineq.to_string⟩

/--
  The main datatype for FM elimination.
  Variables are represented by natural numbers, each of which has an integer coefficient.
  Index 0 is reserved for constants, i.e. `coeffs.find 0` is the coefficient of 1.
  The represented term is coeffs.keys.sum (λ i, coeffs.find i * Var[i]).
  str determines the direction of the comparison -- is it < 0, ≤ 0, or = 0?
-/
meta structure comp :=
(str : ineq)
(coeffs : rb_map ℕ int)

meta instance : inhabited comp := ⟨⟨ineq.eq, mk_rb_map⟩⟩

meta inductive comp_source
| assump : ℕ → comp_source
| add : comp_source → comp_source → comp_source
| scale : ℕ → comp_source → comp_source

meta def comp_source.flatten : comp_source → rb_map ℕ ℕ
| (comp_source.assump n) := mk_rb_map.insert n 1
| (comp_source.add c1 c2) := (comp_source.flatten c1).add (comp_source.flatten c2)
| (comp_source.scale n c) := (comp_source.flatten c).map (λ v, v * n)

meta def comp_source.to_string : comp_source → string
| (comp_source.assump e) := to_string e
| (comp_source.add c1 c2) := comp_source.to_string c1 ++ " + " ++ comp_source.to_string c2
| (comp_source.scale n c) := to_string n ++ " * " ++ comp_source.to_string c

meta instance comp_source.has_to_format : has_to_format comp_source :=
⟨λ a, comp_source.to_string a⟩

meta structure pcomp :=
(c : comp)
(src : comp_source)

meta def map_lt (m1 m2 : rb_map ℕ int) : bool :=
list.lex (prod.lex (<) (<)) m1.to_list m2.to_list

-- make more efficient
meta def comp.lt (c1 c2 : comp) : bool :=
(c1.str.is_lt c2.str) || (c1.str = c2.str) && map_lt c1.coeffs c2.coeffs

meta instance comp.has_lt : has_lt comp := ⟨λ a b, comp.lt a b⟩
meta instance pcomp.has_lt : has_lt pcomp := ⟨λ p1 p2, p1.c < p2.c⟩
meta instance pcomp.has_lt_dec : decidable_rel ((<) : pcomp → pcomp → Prop) := by apply_instance

meta def comp.coeff_of (c : comp) (a : ℕ) : ℤ :=
c.coeffs.zfind a

meta def comp.scale (c : comp) (n : ℕ) : comp :=
{ c with coeffs := c.coeffs.map ((*) (n : ℤ)) }

meta def comp.add (c1 c2 : comp) : comp :=
⟨c1.str.max c2.str, c1.coeffs.add c2.coeffs⟩

meta def pcomp.scale (c : pcomp) (n : ℕ) : pcomp :=
⟨c.c.scale n, comp_source.scale n c.src⟩

meta def pcomp.add (c1 c2 : pcomp) : pcomp :=
⟨c1.c.add c2.c, comp_source.add c1.src c2.src⟩

meta instance pcomp.to_format : has_to_format pcomp :=
⟨λ p, to_fmt p.c.coeffs ++ to_string p.c.str ++ "0"⟩

meta instance comp.to_format : has_to_format comp :=
⟨λ p, to_fmt p.coeffs⟩

end datatypes

section fm_elim

/-- If c1 and c2 both contain variable a with opposite coefficients,
   produces v1, v2, and c such that a has been cancelled in c := v1*c1 + v2*c2 -/
meta def elim_var (c1 c2 : comp) (a : ℕ) : option (ℕ × ℕ × comp) :=
let v1 := c1.coeff_of a,
    v2 := c2.coeff_of a in
if v1 * v2 < 0 then
  let vlcm :=  nat.lcm v1.nat_abs v2.nat_abs,
      v1' := vlcm / v1.nat_abs,
      v2' := vlcm / v2.nat_abs in
  some ⟨v1', v2', comp.add (c1.scale v1') (c2.scale v2')⟩
else none

meta def pelim_var (p1 p2 : pcomp) (a : ℕ) : option pcomp :=
do (n1, n2, c) ← elim_var p1.c p2.c a,
   return ⟨c, comp_source.add (p1.src.scale n1) (p2.src.scale n2)⟩

meta def comp.is_contr (c : comp) : bool := c.coeffs.empty ∧ c.str = ineq.lt

meta def pcomp.is_contr (p : pcomp) : bool := p.c.is_contr

meta def elim_with_set (a : ℕ) (p : pcomp) (comps : rb_set pcomp) : rb_set pcomp :=
if ¬ p.c.coeffs.contains a then mk_rb_set.insert p else
comps.fold mk_rb_set $ λ pc s,
match pelim_var p pc a with
| some pc := s.insert pc
| none := s
end

/--
  The state for the elimination monad.
    vars: the set of variables present in comps
    comps: a set of comparisons
    inputs: a set of pairs of exprs (t, pf), where t is a term and pf is a proof that t {<, ≤, =} 0,
      indexed by ℕ.
    has_false: stores a pcomp of 0 < 0 if one has been found
    TODO: is it more efficient to store comps as a list, to avoid comparisons?
-/
meta structure linarith_structure :=
(vars : rb_set ℕ)
(comps : rb_set pcomp)

@[reducible] meta def linarith_monad :=
state_t linarith_structure (except_t pcomp id)

meta instance : monad linarith_monad := state_t.monad
meta instance : monad_except pcomp linarith_monad :=
state_t.monad_except pcomp

meta def get_vars : linarith_monad (rb_set ℕ) :=
linarith_structure.vars <$> get

meta def get_var_list : linarith_monad (list ℕ) :=
rb_set.to_list <$> get_vars

meta def get_comps : linarith_monad (rb_set pcomp) :=
linarith_structure.comps <$> get

meta def validate : linarith_monad unit :=
do ⟨_, comps⟩ ← get,
match comps.to_list.find (λ p : pcomp, p.is_contr) with
| none := return ()
| some c := throw c
end

meta def update (vars : rb_set ℕ) (comps : rb_set pcomp) : linarith_monad unit :=
state_t.put ⟨vars, comps⟩ >> validate

meta def monad.elim_var (a : ℕ) : linarith_monad unit :=
do vs ← get_vars,
   when (vs.contains a) $
do comps ← get_comps,
   let cs' := comps.fold mk_rb_set (λ p s, s.union (elim_with_set a p comps)),
   update (vs.erase a) cs'

meta def elim_all_vars : linarith_monad unit :=
get_var_list >>= list.mmap' monad.elim_var

end fm_elim

section parse

open ineq tactic

meta def map_of_expr_mul_aux (c1 c2 : rb_map ℕ ℤ) : option (rb_map ℕ ℤ) :=
match c1.keys, c2.keys with
| [0], _ := some $ c2.scale (c1.zfind 0)
| _, [0] := some $ c1.scale (c2.zfind 0)
| [], _ := some mk_rb_map
| _, [] := some mk_rb_map
| _, _ := none
end

/--
  Turns an expression into a map from ℕ to ℤ, for use in a comp object.
    The expr_map ℕ argument identifies which expressions have already been assigned numbers.
    Returns a new map.
-/
meta def map_of_expr : expr_map ℕ → expr → option (expr_map ℕ × rb_map ℕ ℤ)
| m e@`(%%e1 * %%e2) :=
   (do (m', comp1) ← map_of_expr m e1,
      (m', comp2) ← map_of_expr m' e2,
      mp ← map_of_expr_mul_aux comp1 comp2,
      return (m', mp)) <|>
   (match m.find e with
    | some k := return (m, mk_rb_map.insert k 1)
    | none := let n := m.size + 1 in return (m.insert e n, mk_rb_map.insert n 1)
    end)
| m `(%%e1 + %%e2) :=
   do (m', comp1) ← map_of_expr m e1,
      (m', comp2) ← map_of_expr m' e2,
      return (m', comp1.add comp2)
| m `(%%e1 - %%e2) :=
   do (m', comp1) ← map_of_expr m e1,
      (m', comp2) ← map_of_expr m' e2,
      return (m', comp1.add (comp2.scale (-1)))
| m `(-%%e) := do (m', comp) ← map_of_expr m e, return (m', comp.scale (-1))
| m e :=
  match e.to_int, m.find e with
  | some 0, _ := return ⟨m, mk_rb_map⟩
  | some z, _ := return ⟨m, mk_rb_map.insert 0 z⟩
  | none, some k := return (m, mk_rb_map.insert k 1)
  | none, none := let n := m.size + 1 in
    return (m.insert e n, mk_rb_map.insert n 1)
  end

meta def parse_into_comp_and_expr : expr → option (ineq × expr)
| `(%%e < 0) := (ineq.lt, e)
| `(%%e ≤ 0) := (ineq.le, e)
| `(%%e = 0) := (ineq.eq, e)
| _ := none

meta def to_comp (e : expr) (m : expr_map ℕ) : option (comp × expr_map ℕ) :=
do (iq, e) ← parse_into_comp_and_expr e,
   (m', comp') ← map_of_expr m e,
   return ⟨⟨iq, comp'⟩, m'⟩

meta def to_comp_fold : expr_map ℕ → list expr →
      (list (option comp) × expr_map ℕ)
| m [] := ([], m)
| m (h::t) :=
  match to_comp h m with
  | some (c, m') := let (l, mp) := to_comp_fold m' t in (c::l, mp)
  | none := let (l, mp) := to_comp_fold m t in (none::l, mp)
  end

/--
  Takes a list of proofs of props of the form t {<, ≤, =} 0, and creates a linarith_structure.
-/
meta def mk_linarith_structure (l : list expr) : tactic (linarith_structure × rb_map ℕ (expr × expr)) :=
do pftps ← l.mmap infer_type,
  let (l', map) := to_comp_fold mk_rb_map pftps,
  let lz := list.enum $ ((l.zip pftps).zip l').filter_map (λ ⟨a, b⟩, prod.mk a <$> b),
  let prmap := rb_map.of_list $ lz.map (λ ⟨n, x⟩, (n, x.1)),
  let vars : rb_set ℕ := rb_map.set_of_list $ list.range map.size.succ,
  let pc : rb_set pcomp := rb_map.set_of_list $
    lz.map (λ ⟨n, x⟩, ⟨x.2, comp_source.assump n⟩),
  return (⟨vars, pc⟩, prmap)

meta def linarith_monad.run {α} (tac : linarith_monad α) (l : list expr) : tactic ((pcomp ⊕ α) × rb_map ℕ (expr × expr)) :=
do (struct, inputs) ← mk_linarith_structure l,
match (state_t.run (validate >> tac) struct).run with
| (except.ok (a, _)) := return (sum.inr a, inputs)
| (except.error contr) := return (sum.inl contr, inputs)
end

end parse

section prove
open ineq tactic

meta def get_rel_sides : expr → tactic (expr × expr)
| `(%%a < %%b) := return (a, b)
| `(%%a ≤ %%b) := return (a, b)
| `(%%a = %%b) := return (a, b)
| `(%%a ≥ %%b) := return (a, b)
| `(%%a > %%b) := return (a, b)
| _ := failed

meta def mul_expr (n : ℕ) (e : expr) : pexpr :=
if n = 1 then ``(%%e) else
``(%%(nat.to_pexpr n) * %%e)

meta def add_exprs_aux : pexpr → list pexpr → pexpr
| p [] := p
| p [a] := ``(%%p + %%a)
| p (h::t) := add_exprs_aux ``(%%p + %%h) t

meta def add_exprs : list pexpr → pexpr
| [] := ``(0)
| (h::t) := add_exprs_aux h t

meta def find_contr (m : rb_set pcomp) : option pcomp :=
m.keys.find (λ p, p.c.is_contr)

meta def ineq_const_mul_nm : ineq → name
| lt := ``mul_neg
| le := ``mul_nonpos
| eq := ``mul_eq

meta def ineq_const_nm : ineq → ineq → (name × ineq)
| eq eq := (``eq_of_eq_of_eq, eq)
| eq le := (``le_of_eq_of_le, le)
| eq lt := (``lt_of_eq_of_lt, lt)
| le eq := (``le_of_le_of_eq, le)
| le le := (`add_nonpos, le)
| le lt := (`add_neg_of_nonpos_of_neg, lt)
| lt eq := (``lt_of_lt_of_eq, lt)
| lt le := (`add_neg_of_neg_of_nonpos, lt)
| lt lt := (`add_neg, lt)

meta def mk_single_comp_zero_pf (c : ℕ) (h : expr) : tactic (ineq × expr) :=
do tp ← infer_type h,
  some (iq, e) ← return $ parse_into_comp_and_expr tp,
  if c = 0 then
    do e' ← mk_app ``zero_mul [e], return (eq, e')
  else if c = 1 then return (iq, h)
  else
    do nm ← resolve_name (ineq_const_mul_nm iq),
       tp ← (prod.snd <$> (infer_type h >>= get_rel_sides)) >>= infer_type,
       cpos ← to_expr ``((%%c.to_pexpr : %%tp) > 0),
       (_, ex) ← solve_aux cpos `[norm_num, done],
--       e' ← mk_app (ineq_const_mul_nm iq) [h, ex], -- this takes many seconds longer in some examples! why?
       e' ← to_expr ``(%%nm %%h %%ex) ff,
       return (iq, e')

meta def mk_lt_zero_pf_aux (c : ineq) (pf npf : expr) (coeff : ℕ) : tactic (ineq × expr) :=
do (iq, h') ← mk_single_comp_zero_pf coeff npf,
   let (nm, niq) := ineq_const_nm c iq,
   n ← resolve_name nm,
   e' ← to_expr ``(%%n %%pf %%h'),
   return (niq, e')

/--
  Takes a list of coefficients [c] and list of expressions, of equal length.
  Each expression is a proof of a prop of the form t {<, ≤, =} 0.
  Produces a proof that the sum of (c*t) {<, ≤, =} 0, where the comp is as strong as possible.
-/
meta def mk_lt_zero_pf : list ℕ → list expr → tactic expr
| _ [] := fail "no linear hypotheses found"
| [c] [h] := prod.snd <$> mk_single_comp_zero_pf c h
| (c::ct) (h::t) :=
  do (iq, h') ← mk_single_comp_zero_pf c h,
     prod.snd <$> (ct.zip t).mfoldl (λ pr ce, mk_lt_zero_pf_aux pr.1 pr.2 ce.2 ce.1) (iq, h')
| _ _ := fail "not enough args to mk_lt_zero_pf"

meta def term_of_ineq_prf (prf : expr) : tactic expr :=
do (lhs, _) ← infer_type prf >>= get_rel_sides,
   return lhs

meta structure linarith_config :=
(discharger : tactic unit := `[ring])
(restrict_type : option Type := none)
(restrict_type_reflect : reflected restrict_type . apply_instance)
(exfalso : bool := tt)

meta def ineq_pf_tp (pf : expr) : tactic expr :=
do (_, z) ← infer_type pf >>= get_rel_sides,
   infer_type z

meta def mk_neg_one_lt_zero_pf (tp : expr) : tactic expr :=
to_expr ``((neg_neg_of_pos zero_lt_one : -1 < (0 : %%tp)))

/--
  Assumes e is a proof that t = 0. Creates a proof that -t = 0.
-/
meta def mk_neg_eq_zero_pf (e : expr) : tactic expr :=
to_expr ``(neg_eq_zero.mpr %%e)

meta def add_neg_eq_pfs : list expr → tactic (list expr)
| [] := return []
| (h::t) :=
  do some (iq, tp) ← parse_into_comp_and_expr <$> infer_type h,
  match iq with
  | ineq.eq := do nep ← mk_neg_eq_zero_pf h, tl ← add_neg_eq_pfs t, return $ h::nep::tl
  | _ := list.cons h <$> add_neg_eq_pfs t
  end

/--
  Takes a list of proofs of propositions of the form t {<, ≤, =} 0,
  and tries to prove the goal `false`.
-/
meta def prove_false_by_linarith1 (cfg : linarith_config) : list expr → tactic unit
| [] := fail "no args to linarith"
| l@(h::t) :=
  do l' ← add_neg_eq_pfs l,
     hz ← ineq_pf_tp h >>= mk_neg_one_lt_zero_pf,
     (sum.inl contr, inputs) ← elim_all_vars.run (hz::l')
       | fail "linarith failed to find a contradiction",
     let coeffs := inputs.keys.map (λ k, (contr.src.flatten.ifind k)),
     let pfs : list expr := inputs.keys.map (λ k, (inputs.ifind k).1),
     let zip := (coeffs.zip pfs).filter (λ pr, pr.1 ≠ 0),
     let (coeffs, pfs) := zip.unzip,
     mls ← zip.mmap (λ pr, do e ← term_of_ineq_prf pr.2, return (mul_expr pr.1 e)),
     sm ← to_expr $ add_exprs mls,
     tgt ← to_expr ``(%%sm = 0),
     (a, b) ← solve_aux tgt (cfg.discharger >> done),
     pf ← mk_lt_zero_pf coeffs pfs,
     pftp ← infer_type pf,
     (_, nep, _) ← rewrite_core b pftp,
     pf' ← mk_eq_mp nep pf,
     mk_app `lt_irrefl [pf'] >>= exact

end prove

section normalize
open tactic

set_option eqn_compiler.max_steps 50000

meta def rem_neg (prf : expr) : expr → tactic expr
| `(_ ≤ _) := to_expr ``(lt_of_not_ge %%prf)
| `(_ < _) := to_expr ``(le_of_not_gt %%prf)
| `(_ > _) := to_expr ``(le_of_not_gt %%prf)
| `(_ ≥ _) := to_expr ``(lt_of_not_ge %%prf)
| e := failed

meta def rearr_comp : expr → expr → tactic expr
| prf `(%%a ≤ 0) := return prf
| prf  `(%%a < 0) := return prf
| prf  `(%%a = 0) := return prf
| prf  `(%%a ≥ 0) := to_expr ``(neg_nonpos.mpr %%prf)
| prf  `(%%a > 0) := to_expr ``(neg_neg_of_pos %%prf)
| prf  `(0 ≥ %%a) := to_expr ``(show %%a ≤ 0, from %%prf)
| prf  `(0 > %%a) := to_expr ``(show %%a < 0, from %%prf)
| prf  `(0 = %%a) := to_expr ``(eq.symm %%prf)
| prf  `(0 ≤ %%a) := to_expr ``(neg_nonpos.mpr %%prf)
| prf  `(0 < %%a) := to_expr ``(neg_neg_of_pos %%prf)
| prf  `(%%a ≤ %%b) := to_expr ``(sub_nonpos.mpr %%prf)
| prf  `(%%a < %%b) := to_expr ``(sub_neg_of_lt %%prf)
| prf  `(%%a = %%b) := to_expr ``(sub_eq_zero.mpr %%prf)
| prf  `(%%a > %%b) := to_expr ``(sub_neg_of_lt %%prf)
| prf  `(%%a ≥ %%b) := to_expr ``(sub_nonpos.mpr %%prf)
| prf  `(¬ %%t) := do nprf ← rem_neg prf t, tp ← infer_type nprf, rearr_comp nprf tp
| prf  _ := fail "couldn't rearrange comp"

meta def is_numeric : expr → option ℚ
| `(%%e1 + %%e2) := (+) <$> is_numeric e1 <*> is_numeric e2
| `(%%e1 - %%e2) := has_sub.sub <$> is_numeric e1 <*> is_numeric e2
| `(%%e1 * %%e2) := (*) <$> is_numeric e1 <*> is_numeric e2
| `(%%e1 / %%e2) := (/) <$> is_numeric e1 <*> is_numeric e2
| `(-%%e) := rat.neg <$> is_numeric e
| e := e.to_rat

inductive {u} tree (α : Type u) : Type u
| nil {} : tree
| node : α → tree → tree → tree

def tree.repr {α} [has_repr α] : tree α → string
| tree.nil := "nil"
| (tree.node a t1 t2) := "tree.node " ++ repr a ++ " (" ++ tree.repr t1 ++ ") (" ++ tree.repr t2 ++ ")"

instance {α} [has_repr α] : has_repr (tree α) := ⟨tree.repr⟩

meta def find_cancel_factor : expr → ℕ × tree ℕ
| `(%%e1 + %%e2) :=
  let (v1, t1) := find_cancel_factor e1, (v2, t2) := find_cancel_factor e2, lcm := v1.lcm v2 in
  (lcm, tree.node lcm t1 t2)
| `(%%e1 - %%e2) :=
  let (v1, t1) := find_cancel_factor e1, (v2, t2) := find_cancel_factor e2, lcm := v1.lcm v2 in
  (lcm, tree.node lcm t1 t2)
| `(%%e1 * %%e2) :=
  match is_numeric e1, is_numeric e2 with
  | none, none := (1, tree.node 1 tree.nil tree.nil)
  | _, _ :=
    let (v1, t1) := find_cancel_factor e1, (v2, t2) := find_cancel_factor e2, pd := v1*v2 in
    (pd, tree.node pd t1 t2)
  end
| `(%%e1 / %%e2) :=
  match is_numeric e2 with
  | some q := let (v1, t1) := find_cancel_factor e1, n := v1.lcm q.num.nat_abs in
    (n, tree.node n t1 (tree.node q.num.nat_abs tree.nil tree.nil))
  | none := (1, tree.node 1 tree.nil tree.nil)
  end
| `(-%%e) := find_cancel_factor e
| _ := (1, tree.node 1 tree.nil tree.nil)

open tree

meta def mk_prod_prf : ℕ → tree ℕ → expr → tactic expr
| v (node _ lhs rhs) `(%%e1 + %%e2) :=
  do v1 ← mk_prod_prf v lhs e1, v2 ← mk_prod_prf v rhs e2, mk_app ``add_subst [v1, v2]
| v (node _ lhs rhs) `(%%e1 - %%e2) :=
  do v1 ← mk_prod_prf v lhs e1, v2 ← mk_prod_prf v rhs e2, mk_app ``sub_subst [v1, v2]
| v (node n lhs@(node ln _ _) rhs) `(%%e1 * %%e2) :=
  do tp ← infer_type e1, v1 ← mk_prod_prf ln lhs e1, v2 ← mk_prod_prf (v/ln) rhs e2,
     ln' ← tp.of_nat ln, vln' ← tp.of_nat (v/ln), v' ← tp.of_nat v,
     ntp ← to_expr ``(%%ln' * %%vln' = %%v'),
     (_, npf) ← solve_aux ntp `[norm_num, done],
     mk_app ``mul_subst [v1, v2, npf]
| v (node n lhs rhs@(node rn _ _)) `(%%e1 / %%e2) :=
  do tp ← infer_type e1, v1 ← mk_prod_prf (v/rn) lhs e1,
     rn' ← tp.of_nat rn, vrn' ← tp.of_nat (v/rn), n' ← tp.of_nat n, v' ← tp.of_nat v,
     ntp ← to_expr ``(%%rn' / %%e2 = 1),
     (_, npf) ← solve_aux ntp `[norm_num, done],
     ntp2 ← to_expr ``(%%vrn' * %%n' = %%v'),
     (_, npf2) ← solve_aux ntp2 `[norm_num, done],
     mk_app ``div_subst [v1, npf, npf2]
| v t `(-%%e) := do v' ← mk_prod_prf v t e, mk_app ``neg_subst [v']
| v _ e :=
  do tp ← infer_type e,
     v' ← tp.of_nat v,
     e' ← to_expr ``(%%v' * %%e),
     mk_app `eq.refl [e']

/--
 e is a term with rational division. produces a natural number n and a proof that n*e = e',
 where e' has no division.
-/
meta def kill_factors (e : expr) : tactic (ℕ × expr) :=
let (n, t) := find_cancel_factor e in
do e' ← mk_prod_prf n t e, return (n, e')

open expr
meta def expr_contains (n : name) : expr → bool
| (const nm _) := nm = n
| (lam _ _ _ bd) := expr_contains bd
| (pi _ _ _ bd) := expr_contains bd
| (app e1 e2) := expr_contains e1 || expr_contains e2
| _ := ff

lemma sub_into_lt {α} [ordered_semiring α] {a b : α} (he : a = b) (hl : a ≤ 0) : b ≤ 0 :=
by rwa he at hl

meta def norm_hyp_aux (h' lhs : expr) : tactic expr :=
do (v, lhs') ← kill_factors lhs,
   if v = 1 then return h' else do
   (ih, h'') ← mk_single_comp_zero_pf v h',
   (_, nep, _) ← infer_type h'' >>= rewrite_core lhs',
   mk_eq_mp nep h''

meta def norm_hyp (h : expr) : tactic expr :=
do htp ← infer_type h,
   h' ← rearr_comp h htp,
   some (c, lhs) ← parse_into_comp_and_expr <$> infer_type h',
   if expr_contains `has_div.div lhs then
     norm_hyp_aux h' lhs
   else return h'

meta def get_contr_lemma_name : expr → option name
| `(%%a < %%b) := return `lt_of_not_ge
| `(%%a ≤ %%b) := return `le_of_not_gt
| `(%%a = %%b) := return ``eq_of_not_lt_of_not_gt
| `(%%a ≥ %%b) := return `le_of_not_gt
| `(%%a > %%b) := return `lt_of_not_ge
| `(¬ %%a < %%b) := return `not.intro
| `(¬ %%a ≤ %%b) := return `not.intro
| `(¬ %%a = %%b) := return `not.intro
| `(¬ %%a ≥ %%b) := return `not.intro
| `(¬ %%a > %%b) := return `not.intro
| _ := none

-- assumes the input t is of type ℕ. Produces t' of type ℤ such that ↑t = t' and a proof of equality
meta def cast_expr (e : expr) : tactic (expr × expr) :=
do s ← [`int.coe_nat_add, `int.coe_nat_zero, `int.coe_nat_one,
        ``int.coe_nat_bit0_mul, ``int.coe_nat_bit1_mul, ``int.coe_nat_zero_mul, ``int.coe_nat_one_mul,
        ``int.coe_nat_mul_bit0, ``int.coe_nat_mul_bit1, ``int.coe_nat_mul_zero, ``int.coe_nat_mul_one,
        ``int.coe_nat_bit0, ``int.coe_nat_bit1].mfoldl simp_lemmas.add_simp simp_lemmas.mk,
   ce ← to_expr ``(↑%%e : ℤ),
   simplify s [] ce {fail_if_unchanged := ff}

meta def is_nat_int_coe : expr → option expr
| `((↑(%%n : ℕ) : ℤ)) := some n
| _ := none

meta def mk_coe_nat_nonneg_prf (e : expr) : tactic expr :=
mk_app `int.coe_nat_nonneg [e]

meta def get_nat_comps : expr → list expr
| `(%%a + %%b) := (get_nat_comps a).append (get_nat_comps b)
| `(%%a * %%b) := (get_nat_comps a).append (get_nat_comps b)
| e := match is_nat_int_coe e with
  | some e' := [e']
  | none := []
  end

meta def mk_coe_nat_nonneg_prfs (e : expr) : tactic (list expr) :=
(get_nat_comps e).mmap mk_coe_nat_nonneg_prf

meta def mk_cast_eq_and_nonneg_prfs (pf a b : expr) (ln : name) : tactic (list expr) :=
do (a', prfa) ← cast_expr a,
   (b', prfb) ← cast_expr b,
   la ← mk_coe_nat_nonneg_prfs a',
   lb ← mk_coe_nat_nonneg_prfs b',
   pf' ← mk_app ln [pf, prfa, prfb],
   return $ pf'::(la.append lb)

meta def mk_int_pfs_of_nat_pf (pf : expr) : tactic (list expr) :=
do tp ← infer_type pf,
match tp with
| `(%%a = %%b) := mk_cast_eq_and_nonneg_prfs pf a b ``nat_eq_subst
| `(%%a ≤ %%b) := mk_cast_eq_and_nonneg_prfs pf a b ``nat_le_subst
| `(%%a < %%b) := mk_cast_eq_and_nonneg_prfs pf a b ``nat_lt_subst
| `(%%a ≥ %%b) := mk_cast_eq_and_nonneg_prfs pf b a ``nat_le_subst
| `(%%a > %%b) := mk_cast_eq_and_nonneg_prfs pf b a ``nat_lt_subst
| `(¬ %%a ≤ %%b) := do pf' ← mk_app ``lt_of_not_ge [pf], mk_cast_eq_and_nonneg_prfs pf' b a ``nat_lt_subst
| `(¬ %%a < %%b) := do pf' ← mk_app ``le_of_not_gt [pf], mk_cast_eq_and_nonneg_prfs pf' b a ``nat_le_subst
| `(¬ %%a ≥ %%b) := do pf' ← mk_app ``lt_of_not_ge [pf], mk_cast_eq_and_nonneg_prfs pf' a b ``nat_lt_subst
| `(¬ %%a > %%b) := do pf' ← mk_app ``le_of_not_gt [pf], mk_cast_eq_and_nonneg_prfs pf' a b ``nat_le_subst
| _ := fail "mk_int_pfs_of_nat_pf failed: proof is not an inequality"
end

meta def mk_non_strict_int_pf_of_strict_int_pf (pf : expr) : tactic expr :=
do tp ← infer_type pf,
match tp with
| `(%%a < %%b) := to_expr ``(@cast (%%a < %%b) (%%a + 1 ≤ %%b) (by refl) %%pf)
| `(%%a > %%b) := to_expr ``(@cast (%%a > %%b) (%%a ≥ %%b + 1) (by refl) %%pf)
| `(¬ %%a ≤ %%b) := to_expr ``(@cast (%%a > %%b) (%%a ≥ %%b + 1) (by refl) (lt_of_not_ge %%pf))
| `(¬ %%a ≥ %%b) := to_expr ``(@cast (%%a < %%b) (%%a + 1 ≤ %%b) (by refl) (lt_of_not_ge %%pf))
| _ := fail "mk_non_strict_int_pf_of_strict_int_pf failed: proof is not an inequality"
end

meta def guard_is_nat_prop : expr → tactic unit
| `(%%a = _) := infer_type a >>= unify `(ℕ)
| `(%%a ≤ _) := infer_type a >>= unify `(ℕ)
| `(%%a < _) := infer_type a >>= unify `(ℕ)
| `(%%a ≥ _) := infer_type a >>= unify `(ℕ)
| `(%%a > _) := infer_type a >>= unify `(ℕ)
| `(¬ %%p) := guard_is_nat_prop p
| _ := failed

meta def guard_is_strict_int_prop : expr → tactic unit
| `(%%a < _) := infer_type a >>= unify `(ℤ)
| `(%%a > _) := infer_type a >>= unify `(ℤ)
| `(¬ %%a ≤ _) := infer_type a >>= unify `(ℤ)
| `(¬ %%a ≥ _) := infer_type a >>= unify `(ℤ)
| _ := failed

meta def replace_nat_pfs : list expr → tactic (list expr)
| [] := return []
| (h::t) :=
  (do infer_type h >>= guard_is_nat_prop,
      ls ← mk_int_pfs_of_nat_pf h,
      list.append ls <$> replace_nat_pfs t) <|> list.cons h <$> replace_nat_pfs t

meta def replace_strict_int_pfs : list expr → tactic (list expr)
| [] := return []
| (h::t) :=
  (do infer_type h >>= guard_is_strict_int_prop,
      l ← mk_non_strict_int_pf_of_strict_int_pf h,
      list.cons l <$> replace_strict_int_pfs t) <|> list.cons h <$> replace_strict_int_pfs t

meta def partition_by_type_aux : rb_lmap expr expr → list expr → tactic (rb_lmap expr expr)
| m [] := return m
| m (h::t) := do tp ← ineq_pf_tp h, partition_by_type_aux (m.insert tp h) t

meta def partition_by_type (l : list expr) : tactic (rb_lmap expr expr) :=
partition_by_type_aux mk_rb_map l

private meta def try_linarith_on_lists (cfg : linarith_config) (ls : list (list expr)) : tactic unit :=
(first $ ls.map $ prove_false_by_linarith1 cfg) <|> fail "linarith failed"

/--
  Takes a list of proofs of propositions.
  Filters out the proofs of linear (in)equalities,
  and tries to use them to prove `false`.
  If pref_type is given, starts by working over this type
-/
meta def prove_false_by_linarith (cfg : linarith_config) (pref_type : option expr) (l : list expr) : tactic unit :=
do l' ← replace_nat_pfs l,
   l'' ← replace_strict_int_pfs l',
   ls ← list.reduce_option <$> l''.mmap (λ h, (do s ← norm_hyp h, return (some s)) <|> return none)
          >>= partition_by_type,
   pref_type ← (unify pref_type.iget `(ℕ) >> return (some `(ℤ) : option expr)) <|> return pref_type,
   match cfg.restrict_type, ls.values, pref_type with
   | some rtp, _, _ :=
      do m ← mk_mvar, unify `(some %%m : option Type) cfg.restrict_type_reflect, m ← instantiate_mvars m,
         prove_false_by_linarith1 cfg (ls.ifind m)
   | none, [ls'], _ := prove_false_by_linarith1 cfg ls'
   | none, ls', none := try_linarith_on_lists cfg ls'
   | none, _, (some t) := prove_false_by_linarith1 cfg (ls.ifind t) <|> try_linarith_on_lists cfg (ls.erase t).values
   end

end normalize

end linarith

section
open tactic linarith

open lean lean.parser interactive tactic interactive.types
local postfix `?`:9001 := optional
local postfix *:9001 := many

meta def linarith.interactive_aux (cfg : linarith_config) : option expr →
     parse ident* → (parse (tk "using" *> pexpr_list)?) → tactic unit
| pt l (some pe) := pe.mmap (λ p, i_to_expr p >>= note_anon) >> linarith.interactive_aux pt l none
| pt [] none :=
  do t ← target,
     if t = `(false) then local_context >>= prove_false_by_linarith cfg pt
     else match get_contr_lemma_name t with
     | some nm := seq (applyc nm) (do t ← intro1 >>= ineq_pf_tp, linarith.interactive_aux (some t) [] none)
     | none := if cfg.exfalso then exfalso >> linarith.interactive_aux pt [] none
               else fail "linarith failed: target type is not an inequality."
     end
| pt ls none := (ls.mmap get_local) >>= prove_false_by_linarith cfg pt

/--
  Tries to prove a goal of `false` by linear arithmetic on hypotheses.
  If the goal is a linear (in)equality, tries to prove it by contradiction.
  If the goal is not `false` or an inequality, applies `exfalso` and tries linarith on the
  hypotheses.
  `linarith` will use all relevant hypotheses in the local context.
  `linarith h1 h2 h3` will only use hypotheses h1, h2, h3.
  `linarith using [t1, t2, t3]` will add proof terms t1, t2, t3 to the local context.

  Config options:
  `linarith {exfalso := ff}` will fail on a goal that is neither an inequality nor `false`
  `linarith {restrict_type := T}` will run only on hypotheses that are inequalities over `T`
  `linarith {discharger := tac}` will use `tac` instead of `ring` for normalization.
    Options: `ring2`, `ring SOP`, `simp`
-/
meta def tactic.interactive.linarith (ids : parse (many ident))
     (using_hyps : parse (tk "using" *> pexpr_list)?) (cfg : linarith_config := {}) : tactic unit :=
linarith.interactive_aux cfg none ids using_hyps

end


import topology.category.Profinite.default
import injective_map
import algebra.free_algebra
import data.finset.basic
import group_theory.free_abelian_group
import linear_algebra.free_module.basic

noncomputable theory

universe u

def bool_to_Z : bool → ℤ := λ x, ite (x = tt) 1 0

instance totally_separated_of_profinite (S : Profinite.{u}) : totally_separated_space S :=
  totally_separated_of_totally_disconnected_compact_hausdorff S

def I (S : Profinite.{u}) : Type u :=
  {fI : S → bool // continuous fI}

def inj_map (S : Profinite.{u}) : S → ((I S) → bool) :=
  map_to_I' S

def CSZ (S : Profinite.{u}) : Type u := {f : S → ℤ // continuous f}

instance ring_SZ (S : Profinite.{u}) : comm_ring (S → ℤ) := pi.comm_ring

def subring_CSZ (S : Profinite.{u}) : subring (S → ℤ) :=
{ carrier := {f : S → ℤ | continuous f},
  zero_mem' := begin
    simp only [set.mem_set_of_eq],
    refine continuous_def.mpr _,
    intros s hs,
    by_cases hzero : (0 : ℤ) ∈ s,
    { have : (0 ⁻¹' s : set S) = set.univ,
      { ext1,
        simp only [set.mem_preimage, set.mem_univ, pi.zero_apply, iff_true],
        assumption },
      rw this,
      exact is_open_univ, },
    { have : (0 ⁻¹' s : set S) = ∅,
      { ext1,
        simp only [set.mem_preimage, pi.zero_apply],
        rw ← not_iff_not,
        split, tauto, exact λ h, hzero, },
      rw this,
      exact is_open_empty, },
  end,
  one_mem' := begin
    simp only [set.mem_set_of_eq],
    refine continuous_def.mpr _,
    intros s hs,
    by_cases hzero : (1 : ℤ) ∈ s,
    { have : (1 ⁻¹' s : set S) = set.univ,
      { ext1,
        simp only [set.mem_preimage, set.mem_univ, pi.zero_apply, iff_true],
        assumption },
      rw this,
      exact is_open_univ, },
    { have : (1 ⁻¹' s : set S) = ∅,
      { ext1,
        simp only [set.mem_preimage, pi.zero_apply],
        rw ← not_iff_not,
        split, tauto, exact λ h, hzero, },
      rw this,
      exact is_open_empty, },
  end,
  add_mem' := λ f g hf hg, continuous.add hf hg,
  mul_mem' := λ f g hf hg, continuous.mul hf hg,
  neg_mem' := λ f hf, continuous.neg hf,
}

instance ring_CSZ (S : Profinite.{u}) : comm_ring (CSZ S) := (subring_CSZ S).to_comm_ring

instance alg_CSZ (S : Profinite.{u}) : algebra ℤ (CSZ S) := algebra_int (CSZ S)

def prod_N (I : Type u) : Type u := Π (n : ℕ), I

def N_order : (ℕ → ℕ → Prop) := λ n m, n ≤ m

def prod_order (I : Type u) : Π (n : ℕ), I → I → Prop := λ n, @well_ordering_rel I

def lex_order (I : Type u) : (prod_N I) → (prod_N I) → Prop :=
  λ x y, pi.lex N_order (prod_order I) x y

def sub_prod (I : Type u) : Type u :=
  {x : prod_N I // (∀ n : ℕ, ordinal.typein (well_ordering_rel) (x n) ≠ 0 →
    (ordinal.typein (well_ordering_rel) (x n) > ordinal.typein (well_ordering_rel) (x n.succ))) ∧
    (∀ n : ℕ, (ordinal.typein (well_ordering_rel) (x n) ≥ ordinal.typein (well_ordering_rel) (x n.succ))) ∧
    {n : ℕ | ordinal.typein (well_ordering_rel) (x n) > 0}.finite }

def subset_prod (I : Type u) : set (prod_N I) :=
  {x : prod_N I | (∀ n : ℕ, ordinal.typein (well_ordering_rel) (x n) ≠ 0 →
    (ordinal.typein (well_ordering_rel) (x n) > ordinal.typein (well_ordering_rel) (x n.succ))) ∧
    (∀ n : ℕ, (ordinal.typein (well_ordering_rel) (x n) ≥ ordinal.typein (well_ordering_rel) (x n.succ))) ∧
    {n : ℕ | ordinal.typein (well_ordering_rel) (x n) > 0}.finite }

instance decidable_eq_IS (S : Profinite.{u}) : decidable_eq (I S) := classical.dec_eq _

def e_indices {I : Type u} (L : sub_prod I) [decidable_eq I] : finset I :=
  finset.image L.val (set.finite.to_finset L.property.2.2)

def e_cont {S : Profinite.{u}} (i : I S) :
  continuous (bool_to_Z ∘ (λ ι : (I S → bool), ι i) ∘ map_to_I' S) :=
  continuous_bot.comp ((continuous_apply i).comp (inj_to_prod' S).1)

def e {S : Profinite.{u}} (i : I S) : CSZ S :=
  ⟨bool_to_Z ∘ (λ ι : (I S → bool), ι i) ∘ map_to_I' S, e_cont i⟩

def prod_e {S : Profinite.{u}} (L : sub_prod (I S)) : CSZ S := finset.prod (e_indices L) e

def Eset (S : Profinite.{u}) : set (sub_prod (I S)) := {L : sub_prod (I S) | ∀ s : finset (sub_prod (I S)),
  (∀ L' : sub_prod (I S), L' ∈ s → (lex_order (I S)) L'.val L.val) → finset.sum s prod_e ≠ prod_e L}

-- def Eset' (S : Profinite.{u}) : set (prod_N (I S)) := {L | ∀ s : finset (sub_prod (I S)),
--   (∀ L' : sub_prod (I S), L' ∈ s → (lex_order (I S)) L'.val L.val) → finset.sum s prod_e ≠ prod_e L}

def Imu (S : Profinite.{u}) (mu : ordinal.{u}) : set (I S) := {i : (I S) | ordinal.typein well_ordering_rel i < mu}

def Smu (S : Profinite.{u}) (mu : ordinal.{u}) : set S := (map_to_I' S) ⁻¹' {f : (I S) → bool | f ⁻¹' {tt} ⊆ Imu S mu}

instance Smu_closed (S : Profinite.{u}) (mu : ordinal.{u}) : is_closed (Smu S mu) :=
begin
  refine is_closed.preimage (inj_to_prod' S).1 (is_compact.is_closed _),
  let s : Π (i : (I S)), set bool :=
    λ i, ite ((ordinal.typein well_ordering_rel i) < mu) (set.univ : set bool) {ff},
  have h : {f : I S → bool | f ⁻¹' {tt} ⊆ Imu S mu} = {x : (I S) → bool | ∀ (i : (I S)), x i ∈ s i},
  { ext f, split,
    { intros hf i,
      have hs : s i = ite ((ordinal.typein well_ordering_rel i) < mu) (set.univ : set bool) {ff} := rfl,
      rw hs,
      split_ifs, { tauto },
      by_contra',
      apply h,
      have hf' : i ∈ f ⁻¹' {tt} := by tidy,
      exact hf hf', },
    { intros hf i hi,
      unfold Imu,
      have hi' : f i = tt := hi,
      simp only [set.mem_set_of_eq],
      have h' := hf i,
      rw hi' at h',
      have hs : s i = ite ((ordinal.typein well_ordering_rel i) < mu) (set.univ : set bool) {ff} := rfl,
      rw hs at h',
      split_ifs at h', { exact h },
      exfalso,
      tauto } },
  rw h,
  exact is_compact_pi_infinite (λ i, topological_space.noetherian_space.is_compact (s i)),
end

lemma Smu_compact (S : Profinite.{u}) (mu : ordinal.{u}) : is_compact (Smu S mu) :=
  is_closed.is_compact (Smu_closed S mu)

instance Smu_top (S : Profinite.{u}) (mu : ordinal.{u}) : topological_space (Smu S mu) :=
  subtype.topological_space

instance Smu_comp (S : Profinite.{u}) (mu : ordinal.{u}) : compact_space (Smu S mu) :=
  is_compact_iff_compact_space.mp (Smu_compact S mu)

instance Smu_t2  (S : Profinite.{u}) (mu : ordinal.{u}) : t2_space (Smu S mu) :=
  subtype.t2_space

instance Smu_tot_disc (S : Profinite.{u}) (mu : ordinal.{u}) : totally_disconnected_space (Smu S mu) :=
  subtype.totally_disconnected_space

def Smu_prof (S : Profinite.{u}) (mu : ordinal.{u}) : Profinite.{u} :=
  Profinite.of (Smu S mu)

def I_map_ord (I : Type*) : I → ordinal := ordinal.typein (@well_ordering_rel I)

def I_lsub (I : Type*) : ordinal := ordinal.lsub (I_map_ord I)

def I_lsub_zero_iff (I : Type*) := @ordinal.lsub_eq_zero_iff I (I_map_ord I)

lemma Imu_zero_is_empty (S : Profinite.{u}) : Imu S 0 = ∅ :=
begin
  unfold Imu,
  ext, split,
  { intros hx,
    exfalso,
    have hx₁ : ordinal.typein well_ordering_rel x < 0 := hx,
    have hx₂ : 0 ≤ ordinal.typein well_ordering_rel x := ordinal.zero_le _,
    rw ← not_le at hx₁,
    exact hx₁ hx₂ },
  { tauto },
end

lemma Smu_zero_is_subsingleton (S : Profinite.{u}) : (Smu S 0).subsingleton :=
begin
  unfold Smu,
  rw Imu_zero_is_empty S,
  have h : {f : I S → bool | f ⁻¹' {tt} ⊆ ∅} = {function.const (I S) ff},
  { ext f, split,
    { intros hf,
      apply set.mem_singleton_of_eq,
      ext,
      simp only [function.const_apply],
      by_contra',
      rw eq_tt_eq_not_eq_ff at this,
      have hx : x ∈ f ⁻¹' {tt} := this,
      exact hf hx },
    { intros hf,
      rw (set.eq_of_mem_singleton hf),
      exact subset_of_eq (set.preimage_const_of_not_mem (λ hff, bool.ff_ne_tt (set.eq_of_mem_singleton hff))) } },
  rw h,
  exact set.subsingleton.preimage set.subsingleton_singleton (inj_to_prod' S).2,
end

lemma unique_Smu_zero (S : Profinite.{u}) [inhabited S] : unique (Smu S 0) :=
begin
  exact unique_of_subsingleton _,
  -- refine {to_inhabited := _, uniq := _},
  -- sorry,
  -- intros a,
  -- cases a,
  -- exact (Smu_zero_is_subsingleton S) a_property trivial,
  -- refine (Smu_zero_is_subsingleton S) a.property _,
end

lemma Smu_prof_subsingleton (S : Profinite.{u}) : subsingleton (Smu_prof S 0) :=
 (Smu S 0).subsingleton_coe.mpr (Smu_zero_is_subsingleton S)

lemma Eset_zero_subsingleton (S : Profinite.{u}) [hS : subsingleton S] : (Eset S).subsingleton :=
begin
  unfold Eset,
  intros a ha b hb,
  ext,
  sorry,
  -- apply (map_to_I' S),
end

instance no_zero_smul_divisors_CSZ (S : Profinite.{u}) : no_zero_smul_divisors ℤ (CSZ S) :=
begin
  refine {eq_zero_or_eq_zero_of_smul_eq_zero := _},
  intros n f hnf,
  by_cases n = 0,
  { left, exact h },
  right,
  ext,
  sorry,
end

theorem nobeling_mu (S : Profinite.{u}) (mu : ordinal) :
  linear_independent ℤ ((Eset (Smu_prof S mu)).restrict prod_e) ∧
  submodule.span ℤ (prod_e '' (Eset (Smu_prof S mu))) = (⊤ : submodule ℤ (CSZ (Smu_prof S mu))) :=
begin
  induction mu using ordinal.induction with mu IH,
  simp only [] at IH,
  cases ordinal.zero_or_succ_or_limit mu,
  { split,
    { rw h,
      apply linear_independent_unique, },
    { sorry, }, },
  cases h,
  { sorry },
  { sorry },
end

theorem nobeling (S : Profinite.{u}) : linear_independent ℤ ((Eset S).restrict prod_e) ∧ submodule.span ℤ (prod_e '' Eset S) = (⊤ : submodule ℤ (CSZ S)) :=
begin
  sorry,
  -- let lambda := ordinal.typein well_ordering_rel (I S),
  -- induction lambda using ordinal.induction with lambda IH,
end

variables S : Profinite.{u}
variables T : Profinite
#check ordinal.typein (@well_ordering_rel (I S))
#check I_lsub_zero_iff (I T)
#check I T
#check S
#check function.const (I S) ff

theorem nobelings_thm (S : Profinite.{u}) : module.free ℤ (CSZ S) := -- ≅ free_abelian_group (Eset S) :=
begin
  rw module.free_iff_set _ _,
  use prod_e '' (Eset S),
  have hs : submodule.span ℤ (prod_e '' (Eset S)) = ⊤,
  { sorry },
  have hli : linear_independent ℤ (coe : ((prod_e) '' (Eset S)) → CSZ S),
  { sorry },
  sorry,
  -- let b := basis.mk hli,
  -- use ⟨hli, hs⟩,
end


/-
Copyright (c) 2018 Patrick Massot. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Patrick Massot, Johannes Hölzl
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.topology.uniform_space.uniform_embedding
import Mathlib.topology.uniform_space.complete_separated
import Mathlib.topology.algebra.group
import Mathlib.tactic.abel
import Mathlib.PostPort

universes u_3 l u_1 u_2 u u_4 u_5

namespace Mathlib

/-!
# Uniform structure on topological groups

* `topological_add_group.to_uniform_space` and `topological_add_group_is_uniform` can be used to
  construct a canonical uniformity for a topological add group.

* extension of ℤ-bilinear maps to complete groups (useful for ring completions)

* `add_group_with_zero_nhd`: construct the topological structure from a group with a neighbourhood
  around zero. Then with `topological_add_group.to_uniform_space` one can derive a `uniform_space`.
-/

/-- A uniform (additive) group is a group in which the addition and negation are
  uniformly continuous. -/
class uniform_add_group (α : Type u_3) [uniform_space α] [add_group α] where
  uniform_continuous_sub : uniform_continuous fun (p : α × α) => prod.fst p - prod.snd p

theorem uniform_add_group.mk' {α : Type u_1} [uniform_space α] [add_group α]
    (h₁ : uniform_continuous fun (p : α × α) => prod.fst p + prod.snd p)
    (h₂ : uniform_continuous fun (p : α) => -p) : uniform_add_group α :=
  sorry

theorem uniform_continuous_sub {α : Type u_1} [uniform_space α] [add_group α]
    [uniform_add_group α] : uniform_continuous fun (p : α × α) => prod.fst p - prod.snd p :=
  uniform_add_group.uniform_continuous_sub

theorem uniform_continuous.sub {α : Type u_1} {β : Type u_2} [uniform_space α] [add_group α]
    [uniform_add_group α] [uniform_space β] {f : β → α} {g : β → α} (hf : uniform_continuous f)
    (hg : uniform_continuous g) : uniform_continuous fun (x : β) => f x - g x :=
  uniform_continuous.comp uniform_continuous_sub (uniform_continuous.prod_mk hf hg)

theorem uniform_continuous.neg {α : Type u_1} {β : Type u_2} [uniform_space α] [add_group α]
    [uniform_add_group α] [uniform_space β] {f : β → α} (hf : uniform_continuous f) :
    uniform_continuous fun (x : β) => -f x :=
  sorry

theorem uniform_continuous_neg {α : Type u_1} [uniform_space α] [add_group α]
    [uniform_add_group α] : uniform_continuous fun (x : α) => -x :=
  uniform_continuous.neg uniform_continuous_id

theorem uniform_continuous.add {α : Type u_1} {β : Type u_2} [uniform_space α] [add_group α]
    [uniform_add_group α] [uniform_space β] {f : β → α} {g : β → α} (hf : uniform_continuous f)
    (hg : uniform_continuous g) : uniform_continuous fun (x : β) => f x + g x :=
  sorry

theorem uniform_continuous_add {α : Type u_1} [uniform_space α] [add_group α]
    [uniform_add_group α] : uniform_continuous fun (p : α × α) => prod.fst p + prod.snd p :=
  uniform_continuous.add uniform_continuous_fst uniform_continuous_snd

protected instance uniform_add_group.to_topological_add_group {α : Type u_1} [uniform_space α]
    [add_group α] [uniform_add_group α] : topological_add_group α :=
  topological_add_group.mk (uniform_continuous.continuous uniform_continuous_neg)

protected instance prod.uniform_add_group {α : Type u_1} {β : Type u_2} [uniform_space α]
    [add_group α] [uniform_add_group α] [uniform_space β] [add_group β] [uniform_add_group β] :
    uniform_add_group (α × β) :=
  uniform_add_group.mk
    (uniform_continuous.prod_mk
      (uniform_continuous.sub
        (uniform_continuous.comp uniform_continuous_fst uniform_continuous_fst)
        (uniform_continuous.comp uniform_continuous_fst uniform_continuous_snd))
      (uniform_continuous.sub
        (uniform_continuous.comp uniform_continuous_snd uniform_continuous_fst)
        (uniform_continuous.comp uniform_continuous_snd uniform_continuous_snd)))

theorem uniformity_translate {α : Type u_1} [uniform_space α] [add_group α] [uniform_add_group α]
    (a : α) :
    filter.map (fun (x : α × α) => (prod.fst x + a, prod.snd x + a)) (uniformity α) =
        uniformity α :=
  sorry

theorem uniform_embedding_translate {α : Type u_1} [uniform_space α] [add_group α]
    [uniform_add_group α] (a : α) : uniform_embedding fun (x : α) => x + a :=
  sorry

theorem uniformity_eq_comap_nhds_zero (α : Type u_1) [uniform_space α] [add_group α]
    [uniform_add_group α] :
    uniformity α = filter.comap (fun (x : α × α) => prod.snd x - prod.fst x) (nhds 0) :=
  sorry

theorem group_separation_rel {α : Type u_1} [uniform_space α] [add_group α] [uniform_add_group α]
    (x : α) (y : α) : (x, y) ∈ Mathlib.separation_rel α ↔ x - y ∈ closure (singleton 0) :=
  sorry

theorem uniform_continuous_of_tendsto_zero {α : Type u_1} {β : Type u_2} [uniform_space α]
    [add_group α] [uniform_add_group α] [uniform_space β] [add_group β] [uniform_add_group β]
    {f : α → β} [is_add_group_hom f] (h : filter.tendsto f (nhds 0) (nhds 0)) :
    uniform_continuous f :=
  sorry

theorem uniform_continuous_of_continuous {α : Type u_1} {β : Type u_2} [uniform_space α]
    [add_group α] [uniform_add_group α] [uniform_space β] [add_group β] [uniform_add_group β]
    {f : α → β} [is_add_group_hom f] (h : continuous f) : uniform_continuous f :=
  sorry

/-- The right uniformity on a topological group. -/
def topological_add_group.to_uniform_space (G : Type u) [add_comm_group G] [topological_space G]
    [topological_add_group G] : uniform_space G :=
  uniform_space.mk
    (uniform_space.core.mk (filter.comap (fun (p : G × G) => prod.snd p - prod.fst p) (nhds 0))
      sorry sorry sorry)
    sorry

theorem uniformity_eq_comap_nhds_zero' (G : Type u) [add_comm_group G] [topological_space G]
    [topological_add_group G] :
    uniformity G = filter.comap (fun (p : G × G) => prod.snd p - prod.fst p) (nhds 0) :=
  rfl

theorem topological_add_group_is_uniform {G : Type u} [add_comm_group G] [topological_space G]
    [topological_add_group G] : uniform_add_group G :=
  sorry

theorem to_uniform_space_eq {G : Type u} [u : uniform_space G] [add_comm_group G]
    [uniform_add_group G] : topological_add_group.to_uniform_space G = u :=
  sorry

namespace add_comm_group

/- TODO: when modules are changed to have more explicit base ring, then change replace `is_Z_bilin`
by using `is_bilinear_map ℤ` from `tensor_product`. -/

/-- `ℤ`-bilinearity for maps between additive commutative groups. -/
class is_Z_bilin {α : Type u_1} {β : Type u_2} {γ : Type u_3} [add_comm_group α] [add_comm_group β]
    [add_comm_group γ] (f : α × β → γ)
    where
  add_left : ∀ (a a' : α) (b : β), f (a + a', b) = f (a, b) + f (a', b)
  add_right : ∀ (a : α) (b b' : β), f (a, b + b') = f (a, b) + f (a, b')

theorem is_Z_bilin.comp_hom {α : Type u_1} {β : Type u_2} {γ : Type u_3} {δ : Type u_4}
    [add_comm_group α] [add_comm_group β] [add_comm_group γ] (f : α × β → γ) [is_Z_bilin f]
    {g : γ → δ} [add_comm_group δ] [is_add_group_hom g] : is_Z_bilin (g ∘ f) :=
  sorry

protected instance is_Z_bilin.comp_swap {α : Type u_1} {β : Type u_2} {γ : Type u_3}
    [add_comm_group α] [add_comm_group β] [add_comm_group γ] (f : α × β → γ) [is_Z_bilin f] :
    is_Z_bilin (f ∘ prod.swap) :=
  is_Z_bilin.mk (fun (a a' : β) (b : α) => is_Z_bilin.add_right f b a a')
    fun (a : β) (b b' : α) => is_Z_bilin.add_left f b b' a

theorem is_Z_bilin.zero_left {α : Type u_1} {β : Type u_2} {γ : Type u_3} [add_comm_group α]
    [add_comm_group β] [add_comm_group γ] (f : α × β → γ) [is_Z_bilin f] (b : β) : f (0, b) = 0 :=
  sorry

theorem is_Z_bilin.zero_right {α : Type u_1} {β : Type u_2} {γ : Type u_3} [add_comm_group α]
    [add_comm_group β] [add_comm_group γ] (f : α × β → γ) [is_Z_bilin f] (a : α) : f (a, 0) = 0 :=
  is_Z_bilin.zero_left (f ∘ prod.swap)

theorem is_Z_bilin.zero {α : Type u_1} {β : Type u_2} {γ : Type u_3} [add_comm_group α]
    [add_comm_group β] [add_comm_group γ] (f : α × β → γ) [is_Z_bilin f] : f (0, 0) = 0 :=
  is_Z_bilin.zero_left f 0

theorem is_Z_bilin.neg_left {α : Type u_1} {β : Type u_2} {γ : Type u_3} [add_comm_group α]
    [add_comm_group β] [add_comm_group γ] (f : α × β → γ) [is_Z_bilin f] (a : α) (b : β) :
    f (-a, b) = -f (a, b) :=
  sorry

theorem is_Z_bilin.neg_right {α : Type u_1} {β : Type u_2} {γ : Type u_3} [add_comm_group α]
    [add_comm_group β] [add_comm_group γ] (f : α × β → γ) [is_Z_bilin f] (a : α) (b : β) :
    f (a, -b) = -f (a, b) :=
  is_Z_bilin.neg_left (f ∘ prod.swap) b a

theorem is_Z_bilin.sub_left {α : Type u_1} {β : Type u_2} {γ : Type u_3} [add_comm_group α]
    [add_comm_group β] [add_comm_group γ] (f : α × β → γ) [is_Z_bilin f] (a : α) (a' : α) (b : β) :
    f (a - a', b) = f (a, b) - f (a', b) :=
  sorry

theorem is_Z_bilin.sub_right {α : Type u_1} {β : Type u_2} {γ : Type u_3} [add_comm_group α]
    [add_comm_group β] [add_comm_group γ] (f : α × β → γ) [is_Z_bilin f] (a : α) (b : β) (b' : β) :
    f (a, b - b') = f (a, b) - f (a, b') :=
  is_Z_bilin.sub_left (f ∘ prod.swap) b b' a

end add_comm_group

-- α, β and G are abelian topological groups, G is a uniform space

theorem is_Z_bilin.tendsto_zero_left {α : Type u_1} {β : Type u_2} [topological_space α]
    [add_comm_group α] [topological_space β] [add_comm_group β] {G : Type u_5} [uniform_space G]
    [add_comm_group G] {ψ : α × β → G} (hψ : continuous ψ) [ψbilin : add_comm_group.is_Z_bilin ψ]
    (x₁ : α) : filter.tendsto ψ (nhds (x₁, 0)) (nhds 0) :=
  sorry

theorem is_Z_bilin.tendsto_zero_right {α : Type u_1} {β : Type u_2} [topological_space α]
    [add_comm_group α] [topological_space β] [add_comm_group β] {G : Type u_5} [uniform_space G]
    [add_comm_group G] {ψ : α × β → G} (hψ : continuous ψ) [ψbilin : add_comm_group.is_Z_bilin ψ]
    (y₁ : β) : filter.tendsto ψ (nhds (0, y₁)) (nhds 0) :=
  eq.mp
    (Eq._oldrec (Eq.refl (filter.tendsto ψ (nhds (0, y₁)) (nhds (ψ (0, y₁)))))
      (add_comm_group.is_Z_bilin.zero_left ψ y₁))
    (continuous.tendsto hψ (0, y₁))

-- β is a dense subgroup of α, inclusion is denoted by e

theorem tendsto_sub_comap_self {α : Type u_1} {β : Type u_2} [topological_space α]
    [add_comm_group α] [topological_add_group α] [topological_space β] [add_comm_group β]
    {e : β → α} [is_add_group_hom e] (de : dense_inducing e) (x₀ : α) :
    filter.tendsto (fun (t : β × β) => prod.snd t - prod.fst t)
        (filter.comap (fun (p : β × β) => (e (prod.fst p), e (prod.snd p))) (nhds (x₀, x₀)))
        (nhds 0) :=
  sorry

namespace dense_inducing

-- β is a dense subgroup of α, inclusion is denoted by e

-- δ is a dense subgroup of γ, inclusion is denoted by f

/-- Bourbaki GT III.6.5 Theorem I:
ℤ-bilinear continuous maps from dense images into a complete Hausdorff group extend by continuity.
Note: Bourbaki assumes that α and β are also complete Hausdorff, but this is not necessary. -/
theorem extend_Z_bilin {α : Type u_1} {β : Type u_2} {γ : Type u_3} {δ : Type u_4} {G : Type u_5}
    [topological_space α] [add_comm_group α] [topological_add_group α] [topological_space β]
    [add_comm_group β] [topological_add_group β] [topological_space γ] [add_comm_group γ]
    [topological_add_group γ] [topological_space δ] [add_comm_group δ] [topological_add_group δ]
    [uniform_space G] [add_comm_group G] [uniform_add_group G] [separated_space G]
    [complete_space G] {e : β → α} [is_add_group_hom e] (de : dense_inducing e) {f : δ → γ}
    [is_add_group_hom f] (df : dense_inducing f) {φ : β × δ → G} (hφ : continuous φ)
    [bilin : add_comm_group.is_Z_bilin φ] : continuous (extend (dense_inducing.prod de df) φ) :=
  sorry

end Mathlib


import combinatorics.quiver.path
import phase0.params

open cardinal function quiver quiver.path set with_bot
open_locale cardinal

universe u

namespace con_nf
variables [params.{u}]

section Iio_Iic
variables {α β : Λ}

abbreviation Iio_index (α : Λ) := Iio (α : type_index)
abbreviation Iic_index (α : Λ) := Iic (α : type_index)

instance coe_Iio_Iic : has_coe_t (Iio α) (Iic α) := ⟨λ β, ⟨β.1, le_of_lt β.2⟩⟩

instance coe_Iio : has_coe_t (Iio α) (Iio_index α) := ⟨λ β, ⟨β.1, coe_lt_coe.2 β.2⟩⟩
instance coe_Iic : has_coe_t (Iic α) (Iic_index α) := ⟨λ β, ⟨β.1, coe_le_coe.2 β.2⟩⟩

abbreviation Iio_coe : Iio α → Iio_index α := coe
abbreviation Iic_coe : Iic α → Iic_index α := coe

@[simp] lemma Iio.coe_mk (β : Λ) (hβ : β < α) :
  ((⟨β, hβ⟩ : Iio α) : Iio_index α) = ⟨β, coe_lt_coe.2 hβ⟩ := rfl
@[simp] lemma Iic.coe_mk (β : Λ) (hβ : β ≤ α) :
  ((⟨β, hβ⟩ : Iic α) : Iic_index α) = ⟨β, coe_le_coe.2 hβ⟩ := rfl

lemma Iio.coe_injective : injective (coe : Iio α → Iio_index α) :=
begin
  rintro ⟨β, hβ⟩ ⟨γ, hγ⟩ h,
  simp only [Iio.coe_mk, subtype.mk_eq_mk] at h,
  have := with_bot.coe_injective h,
  subst this,
end
lemma Iic.coe_injective : injective (coe : Iic α → Iic_index α) :=
begin
  rintro ⟨β, hβ⟩ ⟨γ, hγ⟩ h,
  simp only [Iic.coe_mk, subtype.mk_eq_mk] at h,
  have := with_bot.coe_injective h,
  subst this,
end

@[simp] lemma Iio.coe_inj {β γ : Iio α} : Iio_coe β = γ ↔ β = γ :=
Iio.coe_injective.eq_iff
@[simp] lemma Iic.coe_inj {β γ : Iic α} : Iic_coe β = γ ↔ β = γ :=
Iic.coe_injective.eq_iff

section Iio_index
variables {hβ : (β : type_index) ∈ Iio_index α}

instance : has_bot (Iio_index α) := ⟨⟨⊥, bot_lt_coe _⟩⟩
instance : inhabited (Iio_index α) := ⟨⊥⟩

@[simp] lemma Iio_index.bot_ne_mk_coe : (⊥ : Iio_index α) ≠ ⟨β, hβ⟩ :=
ne_of_apply_ne subtype.val bot_ne_coe

@[simp] lemma Iio_index.mk_coe_ne_bot : (⟨β, hβ⟩ : Iio_index α) ≠ ⊥ :=
ne_of_apply_ne subtype.val coe_ne_bot

@[simp] lemma Iio_index.bot_ne_coe {β : Iio α} : ⊥ ≠ (β : Iio_index α) :=
ne_of_apply_ne subtype.val bot_ne_coe

@[simp] lemma Iio_index.coe_ne_bot {β : Iio α} : (β : Iio_index α) ≠ ⊥ :=
ne_of_apply_ne subtype.val coe_ne_bot

end Iio_index

section Iic_index
variables {hβ : (β : type_index) ∈ Iic_index α}

instance : has_bot (Iic_index α) := ⟨⟨⊥, bot_le⟩⟩
instance : inhabited (Iic_index α) := ⟨⊥⟩

@[simp] lemma Iic_index.bot_ne_mk_coe : (⊥ : Iic_index α) ≠ ⟨β, hβ⟩ :=
ne_of_apply_ne subtype.val bot_ne_coe

@[simp] lemma Iic_index.mk_coe_ne_bot : (⟨β, hβ⟩ : Iic_index α) ≠ ⊥ :=
ne_of_apply_ne subtype.val coe_ne_bot
end Iic_index

end Iio_Iic

/-!
We now intend to deal with the familiar tools from phase 1 along paths `A` from `α ⟶ β` down the
TTT type hierarchy, instead of linearly level-by-level. We will construct three main definitions:

* `le_index`: A type index `β`, together with a path down from `α` to level `β`.
* `lt_index`: A type index `β`, together with a path down from `α`, to some level `γ`, and then
    directly to level `β`. This enforces that the path obtained from composing `A` with this new
    `γ ⟶ β` morphism is nontrivial by construction.
* `proper_lt_index`: Like `lt_index` but the type index `β` is proper; that is, it lies in `Λ`.

Each of these types is progressively more stringent, and they have natural coercions upwards (i.e.
from `proper_lt_index` to `lt_index` to `le_index`, and the transitive coercion from
`proper_lt_index` to `le_index`). They also have coercions to their index types (`type_index` in the
first two cases, and `Λ` in the third).

We will then proceed to define new API for many phase 1 constructions (tangles, f-maps, ...)
that use these three types instead of `Λ`, `type_index`, and `Iio α`. All of the properties that
were proven in phase 1 of course still hold for the functions under these new names - their
functionality has not changed.

These constructions are helpful for stating and proving the freedom-of-action theorem, since it
allows for the possibility that the type of `β`-tangles (for instance) depends on the path downwards
from `α` to `β`. In our actual construction, this does hold, since phase 1 is conducted entirely
linearly, but this feature is not actually needed for defining and proving statements in most of
phase 2, so we use this alternate formalisation.
-/

section improper
variables {α : type_index}

/-- We define the type of paths from certain types to lower types as elements of this quiver. -/
instance quiver : quiver type_index := ⟨(>)⟩

/-- A (finite) path from the type α to the base type.
This can be seen as a way that we can perceive extensionality, iteratively descending to lower
types in the hierarchy until we reach the base type.
This plays the role of an extended type index in the paper. -/
def extended_index (α : type_index) := quiver.path α ⊥

/-- If there is a path between `α` and `β`, we must have `β ≤ α`.
The case `β = α` can occur with the nil path. -/
lemma le_of_path : Π {β : type_index}, path α β → β ≤ α
| β nil := le_rfl
| β (cons p f) := (le_of_lt f).trans $ le_of_path p

lemma path_eq_nil : ∀ p : path α α, p = nil
| nil := rfl
| (cons p f) := ((le_of_path p).not_lt f).elim

/-! The next few results won't be needed in the same way in Lean 4. -/

def path.Iic_rec' {α : Λ} {β : Iic_index α}
  (motive : Π (γ : type_index), path (β : type_index) γ → Sort*) :
  motive β nil → (Π (γ δ : type_index) (hγ : γ ≤ α) (hδ : δ ≤ α) (A : path (β : type_index) γ)
    (h : δ < γ), motive γ A → motive δ (A.cons h)) →
  Π (γ : Iic_index α) (A : path (β : type_index) γ),
  motive (⟨γ, (le_of_path A).trans β.prop⟩ : Iic_index α) A :=
λ hn hc γ, path.rec hn
  (λ γ δ A h, hc γ δ ((le_of_path A).trans β.prop) ((le_of_path (A.cons h)).trans β.prop) A h)

def motive_equiv {α : Λ} {β : Iic_index α}
  {motive : Π (γ : Iic_index α), path (β : type_index) γ → Sort*}
  {γ : Iic_index α} {A : path (β : type_index) γ} :
  motive (⟨γ, γ.prop⟩ : Iic_index α) A ≃ motive γ A :=
equiv.cast (by cases γ; refl)

/-- An induction principle for paths that allows us to use `Iic_index α` instead of needing to
define the motive for all `type_index`. -/
@[elab_as_eliminator]
def path.Iic_rec {α : Λ} {β : Iic_index α}
  {motive : Π (γ : Iic_index α), path (β : type_index) γ → Sort*} :
  motive β nil → (Π (γ δ : Iic_index α) (A : path (β : type_index) γ) (h : δ < γ),
    motive γ A → motive δ (A.cons h)) →
  Π (γ : Iic_index α) (A : path (β : type_index) γ), motive γ A :=
λ hn hc γ A, motive_equiv (motive_equiv (show _, from
  path.Iic_rec' (λ γ A, motive ⟨γ, (le_of_path A).trans β.prop⟩ A)
  (motive_equiv.symm hn)
  (λ γ δ hγ hδ A h, hc ⟨γ, (le_of_path A).trans β.prop⟩
    ⟨δ, (le_of_path (A.cons h)).trans β.prop⟩ A h)
  γ A))

@[simp] lemma path.Iic_rec_nil {α : Λ} {β : Iic_index α}
  {motive : Π (γ : Iic_index α), path (β : type_index) γ → Sort*} {hn : motive β nil} {hc} :
  @path.Iic_rec _ _ _ motive hn hc β nil = hn :=
begin
  rw [path.Iic_rec, path.Iic_rec'],
  simp only [subtype.coe_mk, motive_equiv, equiv.cast_symm, equiv.cast_apply, cast_cast, cast_eq],
end

@[simp] lemma path.Iic_rec_cons {α : Λ} {β : Iic_index α}
  {motive : Π (γ : Iic_index α), path (β : type_index) γ → Sort*}
  {hn : motive β nil} {hc} (γ δ : Iic_index α) (A : path (β : type_index) γ) (h : δ < γ) :
  @path.Iic_rec _ _ _ motive hn hc δ (A.cons h) = hc γ δ A h (path.Iic_rec hn hc γ A) :=
begin
  rw [path.Iic_rec, path.Iic_rec'],
  dsimp only [subtype.coe_mk, motive_equiv],
  simp only [equiv.cast_refl, equiv.cast_symm, equiv.cast_apply, equiv.coe_refl, id.def],
  rw cast_eq_iff_heq,
  congr,
  rw subtype.coe_eta,
  rw subtype.coe_eta,
  exact (cast_heq _ _).symm,
end

/-- There are at most `Λ` `α`-extended type indices. -/
@[simp] lemma mk_extended_index (α : type_index) : #(extended_index α) ≤ #Λ :=
begin
  refine le_trans ((cardinal.le_def _ _).2 ⟨⟨to_list, to_list_injective (α : type_index) ⊥⟩⟩) _,
  convert mk_list_le_max _ using 1, simp only [mk_type_index, max_eq_right, aleph_0_le_mk],
end

/-- If `β < γ`, we have a path directly between the two types in the opposite order.
Note that the `⟶` symbol (long right arrow) is not the normal `→` (right arrow),
even though monospace fonts often display them similarly. -/
instance lt_to_hom (β γ : Λ) : has_lift_t (β < γ) ((γ : type_index) ⟶ β) := ⟨coe_lt_coe.2⟩

/-- The direct path from the base type to `α`. -/
def type_index.extend : Π α : type_index, extended_index α
| ⊥ := nil
| (α : Λ) := hom.to_path $ with_bot.bot_lt_coe α

instance (α : type_index) : inhabited (extended_index α) := ⟨α.extend⟩

/-- There exists an `α`-extended type index. --/
lemma mk_extended_index_ne_zero (α : type_index) : #(extended_index α) ≠ 0 := cardinal.mk_ne_zero _

/-- A type index `β`, together with a path down from `α` to level `β`. Hence, `β ≤ α`.
This type is intended to be used in place of `β : type_index, β ≤ α` in phase 2. -/
@[ext, protect_proj] structure le_index (α : type_index) :=
(index : type_index)
(path : path α index)

namespace le_index

instance : inhabited (le_index α) := ⟨⟨⊥, α.extend⟩⟩

/-- By forgetting the path that we took from `α` to the lower index `β`, we can recover the type
index `β` that this `le_index` wraps. -/
instance has_coe_type_index : has_coe (le_index α) type_index := ⟨le_index.index⟩

@[simp] lemma coe_mk (index : type_index) (path : path (α : type_index) index) :
  ((⟨index, path⟩ : le_index α) : type_index) = index := rfl

/-- Add an index to a `le_index`. -/
def cons (A : le_index α) {γ : type_index} (hγ : γ < A.index) : le_index α :=
⟨γ, A.path.cons hγ⟩

end le_index

/-- A type index `β`, together with a path `A` down from `α` to level `γ` and then to level `β`.
This enforces that the path obtained from composing `A` with this new `γ ⟶ β` morphism is
nontrivial by construction. This type is intended to be used in place of `β : type_index, β < α`
and `β : Iio_index α` in phase 2. -/
@[ext] structure lt_index (α : type_index) :=
(index : type_index)
(higher : type_index)
(index_lt_higher : index < higher)
(path' : path α higher)

namespace lt_index

/-- A constructor for `lt_index` with less explicit arguments. -/
def mk' {index higher : type_index} (index_lt : index < higher)
  (path' : path (α : type_index) higher) : lt_index α :=
⟨index, higher, index_lt, path'⟩

instance {α : Λ} : inhabited (lt_index α) := ⟨mk' (bot_lt_coe _) path.nil⟩

/-- A path compatible with the one from `le_index`, formed by composing the inner `path'` field
with the morphism `higher ⟶ index`. By construction, this path is always nontrivial. -/
def path (A : lt_index α) : path (α : type_index) A.index := A.path'.cons A.index_lt_higher

/-- An `lt_index` is not equal to its source `α`. This is the lemma that justifies the name
`lt_index` as compared to `le_index`, which permits the trivial path `α ⟶ α`. -/
lemma index_lt (A : lt_index α) : A.index < α := A.index_lt_higher.trans_le $ le_of_path A.path'

/-- The natural coercion from `lt_index` to `le_index`. An analogous concept to `le_of_lt`. -/
def to_le_index (A : lt_index α) : le_index α := ⟨A.index, A.path⟩

instance has_coe_le_index : has_coe (lt_index α) (le_index α) := ⟨to_le_index⟩

/-- By forgetting the path that we took from `α` to the lower index `β`, we can recover the type
index `β` that this `lt_index` wraps. -/
instance has_coe_type_index : has_coe (lt_index α) type_index := ⟨index⟩

end lt_index
end improper

/-- A proper type index `β`, together with a path `A` down from `α` to level `γ` and then to level
`β`. This enforces that the path obtained from composing `A` with this new `γ ⟶ β` morphism is
nontrivial by construction. This type is intended to be used in phase of `β : Λ, β < α` and
`β : Iio α` in phase 2. -/
@[ext, nolint has_nonempty_instance] structure proper_lt_index (α : Λ) :=
(index higher : Λ)
(index_lt_higher : index < higher)
(path' : path (α : type_index) higher)

namespace proper_lt_index
variables {α : Λ}

/-- A constructor for `proper_lt_index` with less explicit arguments. -/
def mk' {α index higher : Λ} (index_lt : index < higher) (path' : path (α : type_index) higher) :
  proper_lt_index α :=
⟨index, higher, index_lt, path'⟩

/-- A path compatible with the one from `le_index`, formed by composing the inner `path'` field
with the morphism `higher ⟶ index`. By construction, this path is always nontrivial. -/
def path (A : proper_lt_index α) : path (α : type_index) A.index :=
A.path'.cons $ coe_lt_coe.2 A.index_lt_higher

/-- A `proper_lt_index` is not equal to its source `α`. See also `lt_index.ne`. -/
lemma index_lt (A : proper_lt_index α) : A.index < α :=
A.index_lt_higher.trans_le $ coe_le_coe.1 $ le_of_path A.path'

/-- The natural coercion from `proper_lt_index` to `le_index`.
An analogous concept to `le_of_lt`, also converting `index: Λ` into a `type_index`. -/
def to_le_index (A : proper_lt_index α) : le_index α :=
⟨A.index, A.path⟩

/-- The natural coercion from `proper_lt_index` to `to_lt_index`, by converting `index : Λ` into a
`type_index`. -/
def to_lt_index (A : proper_lt_index α) : lt_index α :=
⟨A.index, A.higher, coe_lt_coe.2 A.index_lt_higher, A.path'⟩

instance has_coe_lt_index : has_coe (proper_lt_index α) (lt_index α) := ⟨to_lt_index⟩

/-- By forgetting the path that we took from `α` to the lower index `β`, we can recover the proper
type index `β` that this `proper_lt_index` wraps. -/
instance has_coe_Λ : has_coe (proper_lt_index α) Λ := ⟨index⟩

end proper_lt_index
end con_nf