/-
Copyright (c) 2022 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel
-/
import category_theory.limits.shapes.biproducts
import category_theory.limits.preserves.shapes.zero

/-!
# Preservation of biproducts

We define the image of a (binary) bicone under a functor that preserves zero morphisms and define
classes `preserves_biproduct` and `preserves_binary_biproduct`. We then

* show that a functor that preserves biproducts of a two-element type preserves binary biproducts,
* give the canonical isomorphism between the image of a biproduct and the biproduct of the images,
* show that in a preadditive category, a functor preserves a biproduct if and only if it preserves
  the corresponding product if and only if it preserves the corresponding coproduct.

-/

universes w₁ w₂ v₁ v₂ u₁ u₂

noncomputable theory

open category_theory
open category_theory.limits

namespace category_theory

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

section has_zero_morphisms
variables [has_zero_morphisms C] [has_zero_morphisms D]

namespace functor

section map
variables (F : C ⥤ D) [preserves_zero_morphisms F]

section bicone
variables {J : Type w₁}

/-- The image of a bicone under a functor. -/
@[simps]
def map_bicone {f : J → C} (b : bicone f) : bicone (F.obj ∘ f) :=
{ X := F.obj b.X,
  π := λ j, F.map (b.π j),
  ι := λ j, F.map (b.ι j),
  ι_π := λ j j',
  begin
    rw ← F.map_comp,
    split_ifs,
    { subst h,
      simp only [bicone_ι_π_self, category_theory.functor.map_id, eq_to_hom_refl] },
    { rw [bicone_ι_π_ne _ h, F.map_zero] }
  end }

lemma map_bicone_whisker {K : Type w₂} {g : K ≃ J} {f : J → C} (c : bicone f) :
  F.map_bicone (c.whisker g) = (F.map_bicone c).whisker g := rfl

end bicone

/-- The image of a binary bicone under a functor. -/
@[simps]
def map_binary_bicone {X Y : C} (b : binary_bicone X Y) : binary_bicone (F.obj X) (F.obj Y) :=
{ X := F.obj b.X,
  fst := F.map b.fst,
  snd := F.map b.snd,
  inl := F.map b.inl,
  inr := F.map b.inr,
  inl_fst' := by rw [← F.map_comp, b.inl_fst, F.map_id],
  inl_snd' := by rw [← F.map_comp, b.inl_snd, F.map_zero],
  inr_fst' := by rw [← F.map_comp, b.inr_fst, F.map_zero],
  inr_snd' := by rw [← F.map_comp, b.inr_snd, F.map_id] }

end map

end functor

open category_theory.functor

namespace limits

section bicone
variables {J : Type w₁} {K : Type w₂}

/-- A functor `F` preserves biproducts of `f` if `F` maps every bilimit bicone over `f` to a
    bilimit bicone over `F.obj ∘ f`. -/
class preserves_biproduct (f : J → C) (F : C ⥤ D) [preserves_zero_morphisms F] :=
(preserves : Π {b : bicone f}, b.is_bilimit → (F.map_bicone b).is_bilimit)

/-- A functor `F` preserves biproducts of `f` if `F` maps every bilimit bicone over `f` to a
    bilimit bicone over `F.obj ∘ f`. -/
def is_bilimit_of_preserves {f : J → C} (F : C ⥤ D) [preserves_zero_morphisms F]
  [preserves_biproduct f F] {b : bicone f} (hb : b.is_bilimit) : (F.map_bicone b).is_bilimit :=
preserves_biproduct.preserves hb

variables (J)

/-- A functor `F` preserves biproducts of shape `J` if it preserves biproducts of `f` for every
    `f : J → C`. -/
class preserves_biproducts_of_shape (F : C ⥤ D) [preserves_zero_morphisms F] :=
(preserves : Π {f : J → C}, preserves_biproduct f F)

attribute [instance, priority 100] preserves_biproducts_of_shape.preserves

end bicone

/-- A functor `F` preserves finite biproducts if it preserves biproducts of shape `J` whenever
    `J` is a fintype. -/
class preserves_finite_biproducts (F : C ⥤ D) [preserves_zero_morphisms F] :=
(preserves : Π {J : Type} [fintype J], preserves_biproducts_of_shape J F)

attribute [instance, priority 100] preserves_finite_biproducts.preserves

/-- A functor `F` preserves biproducts if it preserves biproducts of any shape `J` of size `w`.
    The usual notion of preservation of biproducts is recovered by choosing `w` to be the universe
    of the morphisms of `C`. -/
class preserves_biproducts (F : C ⥤ D) [preserves_zero_morphisms F] :=
(preserves : Π {J : Type w₁}, preserves_biproducts_of_shape J F)

attribute [instance, priority 100] preserves_biproducts.preserves

/-- Preserving biproducts at a bigger universe level implies preserving biproducts at a
smaller universe level. -/
def preserves_biproducts_shrink (F : C ⥤ D) [preserves_zero_morphisms F]
  [hp : preserves_biproducts.{max w₁ w₂} F] : preserves_biproducts.{w₁} F :=
⟨λ J, ⟨λ f, ⟨λ b ib, ((F.map_bicone b).whisker_is_bilimit_iff _).to_fun
  (is_bilimit_of_preserves F ((b.whisker_is_bilimit_iff equiv.ulift.{w₂}).inv_fun ib))⟩⟩⟩

@[priority 100]
instance preserves_finite_biproducts_of_preserves_biproducts (F : C ⥤ D)
  [preserves_zero_morphisms F] [preserves_biproducts.{w₁} F] : preserves_finite_biproducts F :=
{ preserves := λ J _, by letI := preserves_biproducts_shrink.{0} F; apply_instance }

/-- A functor `F` preserves binary biproducts of `X` and `Y` if `F` maps every bilimit bicone over
    `X` and `Y` to a bilimit bicone over `F.obj X` and `F.obj Y`. -/
class preserves_binary_biproduct (X Y : C) (F : C ⥤ D) [preserves_zero_morphisms F] :=
(preserves : Π {b : binary_bicone X Y}, b.is_bilimit → (F.map_binary_bicone b).is_bilimit)

/-- A functor `F` preserves binary biproducts of `X` and `Y` if `F` maps every bilimit bicone over
    `X` and `Y` to a bilimit bicone over `F.obj X` and `F.obj Y`. -/
def is_binary_bilimit_of_preserves {X Y : C} (F : C ⥤ D) [preserves_zero_morphisms F]
  [preserves_binary_biproduct X Y F] {b : binary_bicone X Y} (hb : b.is_bilimit) :
  (F.map_binary_bicone b).is_bilimit :=
preserves_binary_biproduct.preserves hb

/-- A functor `F` preserves binary biproducts if it preserves the binary biproduct of `X` and `Y`
    for all `X` and `Y`. -/
class preserves_binary_biproducts (F : C ⥤ D) [preserves_zero_morphisms F] :=
(preserves : Π {X Y : C}, preserves_binary_biproduct X Y F . tactic.apply_instance)

/-- A functor that preserves biproducts of a pair preserves binary biproducts. -/
def preserves_binary_biproduct_of_preserves_biproduct (F : C ⥤ D) [preserves_zero_morphisms F]
  (X Y : C) [preserves_biproduct (pair_function X Y) F] : preserves_binary_biproduct X Y F :=
{ preserves := λ b hb,
  { is_limit := is_limit.of_iso_limit
      ((is_limit.postcompose_hom_equiv (by exact diagram_iso_pair _) _).symm
        ((is_bilimit_of_preserves F (b.to_bicone_is_bilimit.symm hb)).is_limit)) $
      cones.ext (iso.refl _) (λ j, by { rcases j with ⟨⟨⟩⟩, tidy, }),
    is_colimit := is_colimit.of_iso_colimit
      ((is_colimit.precompose_inv_equiv (by exact diagram_iso_pair _ ) _).symm
        ((is_bilimit_of_preserves F (b.to_bicone_is_bilimit.symm hb)).is_colimit)) $
      cocones.ext (iso.refl _) (λ j, by { rcases j with ⟨⟨⟩⟩, tidy, }) } }

/-- A functor that preserves biproducts of a pair preserves binary biproducts. -/
def preserves_binary_biproducts_of_preserves_biproducts (F : C ⥤ D)
  [preserves_zero_morphisms F] [preserves_biproducts_of_shape walking_pair F] :
  preserves_binary_biproducts F :=
{ preserves := λ X Y, preserves_binary_biproduct_of_preserves_biproduct F X Y }

attribute [instance, priority 100] preserves_binary_biproducts.preserves

end limits

open category_theory.limits

namespace functor

section bicone
variables {J : Type w₁} (F : C ⥤ D) [preserves_zero_morphisms F] (f : J → C)
  [has_biproduct f] [preserves_biproduct f F]

instance has_biproduct_of_preserves : has_biproduct (F.obj ∘ f) :=
has_biproduct.mk
{ bicone := F.map_bicone (biproduct.bicone f),
  is_bilimit := preserves_biproduct.preserves (biproduct.is_bilimit _) }

/-- If `F` preserves a biproduct, we get a definitionally nice isomorphism
    `F.obj (⨁ f) ≅ ⨁ (F.obj ∘ f)`. -/
@[simp]
def map_biproduct : F.obj (⨁ f) ≅ ⨁ (F.obj ∘ f) :=
biproduct.unique_up_to_iso _ (preserves_biproduct.preserves (biproduct.is_bilimit _))

lemma map_biproduct_hom : (map_biproduct F f).hom = biproduct.lift (λ j, F.map (biproduct.π f j)) :=
rfl

lemma map_biproduct_inv : (map_biproduct F f).inv = biproduct.desc (λ j, F.map (biproduct.ι f j)) :=
rfl

end bicone

variables (F : C ⥤ D) [preserves_zero_morphisms F] (X Y : C) [has_binary_biproduct X Y]
  [preserves_binary_biproduct X Y F]

instance has_binary_biproduct_of_preserves : has_binary_biproduct (F.obj X) (F.obj Y) :=
has_binary_biproduct.mk
{ bicone := F.map_binary_bicone (binary_biproduct.bicone X Y),
  is_bilimit := preserves_binary_biproduct.preserves (binary_biproduct.is_bilimit _ _) }

/-- If `F` preserves a binary biproduct, we get a definitionally nice isomorphism
    `F.obj (X ⊞ Y) ≅ F.obj X ⊞ F.obj Y`. -/
@[simp]
def map_biprod : F.obj (X ⊞ Y) ≅ F.obj X ⊞ F.obj Y :=
biprod.unique_up_to_iso _ _
  (preserves_binary_biproduct.preserves (binary_biproduct.is_bilimit _ _))

lemma map_biprod_hom : (map_biprod F X Y).hom = biprod.lift (F.map biprod.fst) (F.map biprod.snd) :=
rfl

lemma map_biprod_inv : (map_biprod F X Y).inv = biprod.desc (F.map biprod.inl) (F.map biprod.inr) :=
rfl

end functor

namespace limits
variables (F : C ⥤ D) [preserves_zero_morphisms F]

section bicone
variables {J : Type w₁} (f : J → C) [has_biproduct f] [preserves_biproduct f F]
  {W : C}

lemma biproduct.map_lift_map_biprod (g : Π j, W ⟶ f j) :
  F.map (biproduct.lift g) ≫ (F.map_biproduct f).hom = biproduct.lift (λ j, F.map (g j)) :=
by { ext, simp [← F.map_comp] }

lemma biproduct.map_biproduct_inv_map_desc (g : Π j, f j ⟶ W) :
  (F.map_biproduct f).inv ≫ F.map (biproduct.desc g) = biproduct.desc (λ j, F.map (g j)) :=
by { ext, simp [← F.map_comp] }

lemma biproduct.map_biproduct_hom_desc (g : Π j, f j ⟶ W) :
  (F.map_biproduct f).hom ≫ biproduct.desc (λ j, F.map (g j)) = F.map (biproduct.desc g) :=
by rw [← biproduct.map_biproduct_inv_map_desc, iso.hom_inv_id_assoc]

end bicone

section binary_bicone
variables (X Y : C) [has_binary_biproduct X Y] [preserves_binary_biproduct X Y F] {W : C}

lemma biprod.map_lift_map_biprod (f : W ⟶ X) (g : W ⟶ Y) :
  F.map (biprod.lift f g) ≫ (F.map_biprod X Y).hom = biprod.lift (F.map f) (F.map g) :=
by ext; simp [← F.map_comp]

lemma biprod.lift_map_biprod (f : W ⟶ X) (g : W ⟶ Y) :
  biprod.lift (F.map f) (F.map g) ≫ (F.map_biprod X Y).inv = F.map (biprod.lift f g) :=
by rw [← biprod.map_lift_map_biprod, category.assoc, iso.hom_inv_id, category.comp_id]

lemma biprod.map_biprod_inv_map_desc (f : X ⟶ W) (g : Y ⟶ W) :
  (F.map_biprod X Y).inv ≫ F.map (biprod.desc f g) = biprod.desc (F.map f) (F.map g) :=
by ext; simp [← F.map_comp]

lemma biprod.map_biprod_hom_desc (f : X ⟶ W) (g : Y ⟶ W) :
 (F.map_biprod X Y).hom ≫ biprod.desc (F.map f) (F.map g) = F.map (biprod.desc f g) :=
by rw [← biprod.map_biprod_inv_map_desc, iso.hom_inv_id_assoc]

end binary_bicone

end limits

end has_zero_morphisms

open category_theory.functor

section preadditive
variables [preadditive C] [preadditive D] (F : C ⥤ D) [preserves_zero_morphisms F]

namespace limits

section fintype
variables {J : Type} [fintype J]

local attribute [tidy] tactic.discrete_cases

/-- A functor between preadditive categories that preserves (zero morphisms and) finite biproducts
    preserves finite products. -/
def preserves_product_of_preserves_biproduct {f : J → C} [preserves_biproduct f F] :
  preserves_limit (discrete.functor f) F :=
{ preserves := λ c hc, is_limit.of_iso_limit
  ((is_limit.postcompose_inv_equiv (discrete.comp_nat_iso_discrete _ _) _).symm
    (is_bilimit_of_preserves F (bicone_is_bilimit_of_limit_cone_of_is_limit hc)).is_limit) $
  cones.ext (iso.refl _) (by tidy) }

section
local attribute [instance] preserves_product_of_preserves_biproduct

/-- A functor between preadditive categories that preserves (zero morphisms and) finite biproducts
    preserves finite products. -/
def preserves_products_of_shape_of_preserves_biproducts_of_shape
  [preserves_biproducts_of_shape J F] : preserves_limits_of_shape (discrete J) F :=
{ preserves_limit := λ f, preserves_limit_of_iso_diagram _ discrete.nat_iso_functor.symm }

end

/-- A functor between preadditive categories that preserves (zero morphisms and) finite products
    preserves finite biproducts. -/
def preserves_biproduct_of_preserves_product {f : J → C} [preserves_limit (discrete.functor f) F] :
  preserves_biproduct f F :=
{ preserves := λ b hb, is_bilimit_of_is_limit _ $
    is_limit.of_iso_limit ((is_limit.postcompose_hom_equiv (discrete.comp_nat_iso_discrete _ _)
      (F.map_cone b.to_cone)).symm (is_limit_of_preserves F hb.is_limit)) $
      cones.ext (iso.refl _) (by tidy) }

/-- A functor between preadditive categories that preserves (zero morphisms and) finite products
    preserves finite biproducts. -/
def preserves_biproducts_of_shape_of_preserves_products_of_shape
  [preserves_limits_of_shape (discrete J) F] : preserves_biproducts_of_shape J F :=
{ preserves := λ f, preserves_biproduct_of_preserves_product F }

/-- A functor between preadditive categories that preserves (zero morphisms and) finite biproducts
    preserves finite coproducts. -/
def preserves_coproduct_of_preserves_biproduct {f : J → C} [preserves_biproduct f F] :
  preserves_colimit (discrete.functor f) F :=
{ preserves := λ c hc, is_colimit.of_iso_colimit
    ((is_colimit.precompose_hom_equiv (discrete.comp_nat_iso_discrete _ _) _).symm
      (is_bilimit_of_preserves F
        (bicone_is_bilimit_of_colimit_cocone_of_is_colimit hc)).is_colimit) $
    cocones.ext (iso.refl _) (by tidy) }

section
local attribute [instance] preserves_coproduct_of_preserves_biproduct

/-- A functor between preadditive categories that preserves (zero morphisms and) finite biproducts
    preserves finite coproducts. -/
def preserves_coproducts_of_shape_of_preserves_biproducts_of_shape
  [preserves_biproducts_of_shape J F] : preserves_colimits_of_shape (discrete J) F :=
{ preserves_colimit := λ f, preserves_colimit_of_iso_diagram _ discrete.nat_iso_functor.symm }

end

/-- A functor between preadditive categories that preserves (zero morphisms and) finite coproducts
    preserves finite biproducts. -/
def preserves_biproduct_of_preserves_coproduct {f : J → C}
  [preserves_colimit (discrete.functor f) F] : preserves_biproduct f F :=
{ preserves := λ b hb, is_bilimit_of_is_colimit _ $
    is_colimit.of_iso_colimit ((is_colimit.precompose_inv_equiv (discrete.comp_nat_iso_discrete _ _)
      (F.map_cocone b.to_cocone)).symm (is_colimit_of_preserves F hb.is_colimit)) $
      cocones.ext (iso.refl _) (by tidy) }

/-- A functor between preadditive categories that preserves (zero morphisms and) finite coproducts
    preserves finite biproducts. -/
def preserves_biproducts_of_shape_of_preserves_coproducts_of_shape
  [preserves_colimits_of_shape (discrete J) F] : preserves_biproducts_of_shape J F :=
{ preserves := λ f, preserves_biproduct_of_preserves_coproduct F }

end fintype

/-- A functor between preadditive categories that preserves (zero morphisms and) binary biproducts
    preserves binary products. -/
def preserves_binary_product_of_preserves_binary_biproduct {X Y : C}
  [preserves_binary_biproduct X Y F] : preserves_limit (pair X Y) F :=
{ preserves := λ c hc, is_limit.of_iso_limit
    ((is_limit.postcompose_inv_equiv (by exact diagram_iso_pair _) _).symm
      (is_binary_bilimit_of_preserves F
        (binary_bicone_is_bilimit_of_limit_cone_of_is_limit hc)).is_limit) $
    cones.ext (iso.refl _) (λ j, by { rcases j with ⟨⟨⟩⟩, tidy }) }

section
local attribute [instance] preserves_binary_product_of_preserves_binary_biproduct

/-- A functor between preadditive categories that preserves (zero morphisms and) binary biproducts
    preserves binary products. -/
def preserves_binary_products_of_preserves_binary_biproducts
  [preserves_binary_biproducts F] : preserves_limits_of_shape (discrete walking_pair) F :=
{ preserves_limit := λ K, preserves_limit_of_iso_diagram _ (diagram_iso_pair _).symm }

end

/-- A functor between preadditive categories that preserves (zero morphisms and) binary products
    preserves binary biproducts. -/
def preserves_binary_biproduct_of_preserves_binary_product {X Y : C}
  [preserves_limit (pair X Y) F] : preserves_binary_biproduct X Y F :=
{ preserves := λ b hb, is_binary_bilimit_of_is_limit _ $
    is_limit.of_iso_limit ((is_limit.postcompose_hom_equiv (by exact diagram_iso_pair _)
      (F.map_cone b.to_cone)).symm (is_limit_of_preserves F hb.is_limit)) $
        cones.ext (iso.refl _) (λ j, by { rcases j with ⟨⟨⟩⟩, tidy }) }

/-- A functor between preadditive categories that preserves (zero morphisms and) binary products
    preserves binary biproducts. -/
def preserves_binary_biproducts_of_preserves_binary_products
  [preserves_limits_of_shape (discrete walking_pair) F] : preserves_binary_biproducts F :=
{ preserves := λ X Y, preserves_binary_biproduct_of_preserves_binary_product F }

/-- A functor between preadditive categories that preserves (zero morphisms and) binary biproducts
    preserves binary coproducts. -/
def preserves_binary_coproduct_of_preserves_binary_biproduct {X Y : C}
  [preserves_binary_biproduct X Y F] : preserves_colimit (pair X Y) F :=
{ preserves := λ c hc, is_colimit.of_iso_colimit
    ((is_colimit.precompose_hom_equiv (by exact diagram_iso_pair _) _).symm
      (is_binary_bilimit_of_preserves F
        (binary_bicone_is_bilimit_of_colimit_cocone_of_is_colimit hc)).is_colimit) $
      cocones.ext (iso.refl _) (λ j, by { rcases j with ⟨⟨⟩⟩, tidy }) }

section
local attribute [instance] preserves_binary_coproduct_of_preserves_binary_biproduct

/-- A functor between preadditive categories that preserves (zero morphisms and) binary biproducts
    preserves binary coproducts. -/
def preserves_binary_coproducts_of_preserves_binary_biproducts
  [preserves_binary_biproducts F] : preserves_colimits_of_shape (discrete walking_pair) F :=
{ preserves_colimit := λ K, preserves_colimit_of_iso_diagram _ (diagram_iso_pair _).symm }

end

/-- A functor between preadditive categories that preserves (zero morphisms and) binary coproducts
    preserves binary biproducts. -/
def preserves_binary_biproduct_of_preserves_binary_coproduct {X Y : C}
  [preserves_colimit (pair X Y) F] : preserves_binary_biproduct X Y F :=
{ preserves := λ b hb, is_binary_bilimit_of_is_colimit _ $
    is_colimit.of_iso_colimit ((is_colimit.precompose_inv_equiv (by exact diagram_iso_pair _)
      (F.map_cocone b.to_cocone)).symm (is_colimit_of_preserves F hb.is_colimit)) $
        cocones.ext (iso.refl _) (λ j, by { rcases j with ⟨⟨⟩⟩, tidy }) }

/-- A functor between preadditive categories that preserves (zero morphisms and) binary coproducts
    preserves binary biproducts. -/
def preserves_binary_biproducts_of_preserves_binary_coproducts
  [preserves_colimits_of_shape (discrete walking_pair) F] : preserves_binary_biproducts F :=
{ preserves := λ X Y, preserves_binary_biproduct_of_preserves_binary_coproduct F }

end limits

end preadditive

end category_theory


/-
Copyright (c) 2020 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.linear_algebra.basic
import Mathlib.PostPort

universes u_1 u_2 u_3

namespace Mathlib

/-!
# modular equivalence for submodule
-/

/-- A predicate saying two elements of a module are equivalent modulo a submodule. -/
def smodeq {R : Type u_1} [ring R] {M : Type u_2} [add_comm_group M] [module R M]
    (U : submodule R M) (x : M) (y : M) :=
  submodule.quotient.mk x = submodule.quotient.mk y

protected theorem smodeq.def {R : Type u_1} [ring R] {M : Type u_2} [add_comm_group M] [module R M]
    {U : submodule R M} {x : M} {y : M} :
    smodeq U x y ↔ submodule.quotient.mk x = submodule.quotient.mk y :=
  iff.rfl

namespace smodeq

@[simp] theorem top {R : Type u_1} [ring R] {M : Type u_2} [add_comm_group M] [module R M] {x : M}
    {y : M} : smodeq ⊤ x y :=
  iff.mpr (submodule.quotient.eq ⊤) submodule.mem_top

@[simp] theorem bot {R : Type u_1} [ring R] {M : Type u_2} [add_comm_group M] [module R M] {x : M}
    {y : M} : smodeq ⊥ x y ↔ x = y :=
  sorry

theorem mono {R : Type u_1} [ring R] {M : Type u_2} [add_comm_group M] [module R M]
    {U₁ : submodule R M} {U₂ : submodule R M} {x : M} {y : M} (HU : U₁ ≤ U₂) (hxy : smodeq U₁ x y) :
    smodeq U₂ x y :=
  iff.mpr (submodule.quotient.eq U₂) (HU (iff.mp (submodule.quotient.eq U₁) hxy))

theorem refl {R : Type u_1} [ring R] {M : Type u_2} [add_comm_group M] [module R M]
    {U : submodule R M} {x : M} : smodeq U x x :=
  Eq.refl (submodule.quotient.mk x)

theorem symm {R : Type u_1} [ring R] {M : Type u_2} [add_comm_group M] [module R M]
    {U : submodule R M} {x : M} {y : M} (hxy : smodeq U x y) : smodeq U y x :=
  Eq.symm hxy

theorem trans {R : Type u_1} [ring R] {M : Type u_2} [add_comm_group M] [module R M]
    {U : submodule R M} {x : M} {y : M} {z : M} (hxy : smodeq U x y) (hyz : smodeq U y z) :
    smodeq U x z :=
  Eq.trans hxy hyz

theorem add {R : Type u_1} [ring R] {M : Type u_2} [add_comm_group M] [module R M]
    {U : submodule R M} {x₁ : M} {x₂ : M} {y₁ : M} {y₂ : M} (hxy₁ : smodeq U x₁ y₁)
    (hxy₂ : smodeq U x₂ y₂) : smodeq U (x₁ + x₂) (y₁ + y₂) :=
  sorry

theorem smul {R : Type u_1} [ring R] {M : Type u_2} [add_comm_group M] [module R M]
    {U : submodule R M} {x : M} {y : M} (hxy : smodeq U x y) (c : R) : smodeq U (c • x) (c • y) :=
  sorry

theorem zero {R : Type u_1} [ring R] {M : Type u_2} [add_comm_group M] [module R M]
    {U : submodule R M} {x : M} : smodeq U x 0 ↔ x ∈ U :=
  sorry

theorem map {R : Type u_1} [ring R] {M : Type u_2} [add_comm_group M] [module R M]
    {U : submodule R M} {x : M} {y : M} {N : Type u_3} [add_comm_group N] [module R N]
    (hxy : smodeq U x y) (f : linear_map R M N) :
    smodeq (submodule.map f U) (coe_fn f x) (coe_fn f y) :=
  iff.mpr (submodule.quotient.eq (submodule.map f U))
    (Eq.subst (linear_map.map_sub f x y) submodule.mem_map_of_mem
      (iff.mp (submodule.quotient.eq U) hxy))

theorem comap {R : Type u_1} [ring R] {M : Type u_2} [add_comm_group M] [module R M] {x : M} {y : M}
    {N : Type u_3} [add_comm_group N] [module R N] (V : submodule R N) {f : linear_map R M N}
    (hxy : smodeq V (coe_fn f x) (coe_fn f y)) : smodeq (submodule.comap f V) x y :=
  iff.mpr (submodule.quotient.eq (submodule.comap f V))
    ((fun (this : coe_fn f (x - y) ∈ V) => this)
      (Eq.symm (linear_map.map_sub f x y) ▸ iff.mp (submodule.quotient.eq V) hxy))

end Mathlib


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

Evaluate expressions in the language of (semi-)rings.
Based on http://www.cs.ru.nl/~freek/courses/tt-2014/read/10.1.1.61.3041.pdf .
-/
import algebra.group_power tactic.norm_num
import tactic.converter.interactive

namespace tactic
namespace ring

def horner {α} [comm_semiring α] (a x : α) (n : ℕ) (b : α) := a * x ^ n + b

meta structure cache :=
(α : expr)
(univ : level)
(comm_semiring_inst : expr)

meta def mk_cache (e : expr) : tactic cache :=
do α ← infer_type e,
   c ← mk_app ``comm_semiring [α] >>= mk_instance,
   u ← mk_meta_univ,
   infer_type α >>= unify (expr.sort (level.succ u)),
   u ← get_univ_assignment u,
   return ⟨α, u, c⟩

meta def cache.cs_app (c : cache) (n : name) : list expr → expr :=
(@expr.const tt n [c.univ] c.α c.comm_semiring_inst).mk_app

meta def cache.mk_app (c : cache) (n inst : name) (l : list expr) : tactic expr :=
do m ← mk_instance ((expr.const inst [c.univ] : expr) c.α),
   return $ (@expr.const tt n [c.univ] c.α m).mk_app l

meta inductive horner_expr : Type
| const (e : expr) : horner_expr
| xadd (e : expr) (a : horner_expr) (x : expr) (n : expr × ℕ) (b : horner_expr) : horner_expr

meta def horner_expr.e : horner_expr → expr
| (horner_expr.const e) := e
| (horner_expr.xadd e _ _ _ _) := e

meta instance : has_coe horner_expr expr := ⟨horner_expr.e⟩

meta def horner_expr.xadd' (c : cache) (a : horner_expr) (x : expr) (n : expr × ℕ) (b : horner_expr): horner_expr :=
horner_expr.xadd (c.cs_app ``horner [a, x, n.1, b]) a x n b

open horner_expr

meta def horner_expr.to_string : horner_expr → string
| (const e) := to_string e
| (xadd e a x (_, n) b) :=
    "(" ++ a.to_string ++ ") * (" ++ to_string x ++ ")^"
        ++ to_string n ++ " + " ++ b.to_string

meta def horner_expr.pp : horner_expr → tactic format
| (const e) := pp e
| (xadd e a x (_, n) b) := do
  pa ← a.pp, pb ← b.pp, px ← pp x,
  return $ "(" ++ pa ++ ") * (" ++ px ++ ")^" ++ to_string n ++ " + " ++ pb

meta instance : has_to_tactic_format horner_expr := ⟨horner_expr.pp⟩

meta def horner_expr.refl_conv (e : horner_expr) : tactic (horner_expr × expr) :=
do p ← mk_eq_refl e, return (e, p)

theorem zero_horner {α} [comm_semiring α] (x n b) :
  @horner α _ 0 x n b = b :=
by simp [horner]

theorem horner_horner {α} [comm_semiring α] (a₁ x n₁ n₂ b n')
  (h : n₁ + n₂ = n') :
  @horner α _ (horner a₁ x n₁ 0) x n₂ b = horner a₁ x n' b :=
by simp [h.symm, horner, pow_add, mul_assoc]

meta def eval_horner (c : cache) : horner_expr → expr → expr × ℕ → horner_expr → tactic (horner_expr × expr)
| ha@(const a) x n b :=
  if a.to_nat = some 0 then
    return (b, c.cs_app ``zero_horner [x, n.1, b])
  else (xadd' c ha x n b).refl_conv
| ha@(xadd a a₁ x₁ n₁ b₁) x n b :=
  if x₁ = x ∧ b₁.e.to_nat = some 0 then do
    (n', h) ← mk_app ``has_add.add [n₁.1, n.1] >>= norm_num,
    return (xadd' c a₁ x (n', n₁.2 + n.2) b,
      c.cs_app ``horner_horner [a₁, x, n₁.1, n.1, b, n', h])
  else (xadd' c ha x n b).refl_conv

theorem const_add_horner {α} [comm_semiring α] (k a x n b b') (h : k + b = b') :
  k + @horner α _ a x n b = horner a x n b' :=
by simp [h.symm, horner]

theorem horner_add_const {α} [comm_semiring α] (a x n b k b') (h : b + k = b') :
  @horner α _ a x n b + k = horner a x n b' :=
by simp [h.symm, horner]

theorem horner_add_horner_lt {α} [comm_semiring α] (a₁ x n₁ b₁ a₂ n₂ b₂ k a' b')
  (h₁ : n₁ + k = n₂) (h₂ : (a₁ + horner a₂ x k 0 : α) = a') (h₃ : b₁ + b₂ = b') :
  @horner α _ a₁ x n₁ b₁ + horner a₂ x n₂ b₂ = horner a' x n₁ b' :=
by simp [h₂.symm, h₃.symm, h₁.symm, horner, pow_add, mul_add, mul_comm, mul_left_comm]

theorem horner_add_horner_gt {α} [comm_semiring α] (a₁ x n₁ b₁ a₂ n₂ b₂ k a' b')
  (h₁ : n₂ + k = n₁) (h₂ : (horner a₁ x k 0 + a₂ : α) = a') (h₃ : b₁ + b₂ = b') :
  @horner α _ a₁ x n₁ b₁ + horner a₂ x n₂ b₂ = horner a' x n₂ b' :=
by simp [h₂.symm, h₃.symm, h₁.symm, horner, pow_add, mul_add, mul_comm, mul_left_comm]

theorem horner_add_horner_eq {α} [comm_semiring α] (a₁ x n b₁ a₂ b₂ a' b' t)
  (h₁ : a₁ + a₂ = a') (h₂ : b₁ + b₂ = b') (h₃ : horner a' x n b' = t) :
  @horner α _ a₁ x n b₁ + horner a₂ x n b₂ = t :=
by simp [h₃.symm, h₂.symm, h₁.symm, horner, add_mul, mul_comm]

meta def eval_add (c : cache) : horner_expr → horner_expr → tactic (horner_expr × expr)
| (const e₁) (const e₂) := do
  (e, p) ← mk_app ``has_add.add [e₁, e₂] >>= norm_num,
  return (const e, p)
| he₁@(const e₁) he₂@(xadd e₂ a x n b) :=
  if e₁.to_nat = some 0 then  do
    p ← mk_app ``zero_add [e₂],
    return (he₂, p)
  else do
    (b', h) ← eval_add he₁ b,
    return (xadd' c a x n b',
      c.cs_app ``const_add_horner [e₁, a, x, n.1, b, b', h])
| he₁@(xadd e₁ a x n b) he₂@(const e₂) :=
  if e₂.to_nat = some 0 then do
    p ← mk_app ``add_zero [e₁],
    return (he₁, p)
  else do
    (b', h) ← eval_add b he₂,
    return (xadd' c a x n b',
      c.cs_app ``horner_add_const [a, x, n.1, b, e₂, b', h])
| he₁@(xadd e₁ a₁ x₁ n₁ b₁) he₂@(xadd e₂ a₂ x₂ n₂ b₂) :=
  if expr.lex_lt x₁ x₂ then do
    (b', h) ← eval_add b₁ he₂,
    return (xadd' c a₁ x₁ n₁ b',
      c.cs_app ``horner_add_const [a₁, x₁, n₁.1, b₁, e₂, b', h])
  else if x₁ ≠ x₂ then do
    (b', h) ← eval_add he₁ b₂,
    return (xadd' c a₂ x₂ n₂ b',
      c.cs_app ``const_add_horner [e₁, a₂, x₂, n₂.1, b₂, b', h])
  else if n₁.2 < n₂.2 then do
    let k := n₂.2 - n₁.2,
    ek ← expr.of_nat (expr.const `nat []) k,
    (_, h₁) ← mk_app ``has_add.add [n₁.1, ek] >>= norm_num,
    α0 ← expr.of_nat c.α 0,
    (a', h₂) ← eval_add a₁ (xadd' c a₂ x₁ (ek, k) (const α0)),
    (b', h₃) ← eval_add b₁ b₂,
    return (xadd' c a' x₁ n₁ b',
      c.cs_app ``horner_add_horner_lt [a₁, x₁, n₁.1, b₁, a₂, n₂.1, b₂, ek, a', b', h₁, h₂, h₃])
  else if n₁ ≠ n₂ then do
    let k := n₁.2 - n₂.2,
    ek ← expr.of_nat (expr.const `nat []) k,
    (_, h₁) ← mk_app ``has_add.add [n₂.1, ek] >>= norm_num,
    α0 ← expr.of_nat c.α 0,
    (a', h₂) ← eval_add (xadd' c a₁ x₁ (ek, k) (const α0)) a₂,
    (b', h₃) ← eval_add b₁ b₂,
    return (xadd' c a' x₁ n₂ b',
      c.cs_app ``horner_add_horner_gt [a₁, x₁, n₁.1, b₁, a₂, n₂.1, b₂, ek, a', b', h₁, h₂, h₃])
  else do
    (a', h₁) ← eval_add a₁ a₂,
    (b', h₂) ← eval_add b₁ b₂,
    (t, h₃) ← eval_horner c a' x₁ n₁ b',
    return (t, c.cs_app ``horner_add_horner_eq
      [a₁, x₁, n₁.1, b₁, a₂, b₂, a', b', t, h₁, h₂, h₃])

theorem horner_neg {α} [comm_ring α] (a x n b a' b')
  (h₁ : -a = a') (h₂ : -b = b') :
  -@horner α _ a x n b = horner a' x n b' :=
by simp [h₂.symm, h₁.symm, horner]

meta def eval_neg (c : cache) : horner_expr → tactic (horner_expr × expr)
| (const e) := do
  (e', p) ← mk_app ``has_neg.neg [e] >>= norm_num,
  return (const e', p)
| (xadd e a x n b) := do
  (a', h₁) ← eval_neg a,
  (b', h₂) ← eval_neg b,
  p ← c.mk_app ``horner_neg ``comm_ring [a, x, n.1, b, a', b', h₁, h₂],
  return (xadd' c a' x n b', p)

theorem horner_const_mul {α} [comm_semiring α] (c a x n b a' b')
  (h₁ : c * a = a') (h₂ : c * b = b') :
  c * @horner α _ a x n b = horner a' x n b' :=
by simp [h₂.symm, h₁.symm, horner, mul_add, mul_assoc]

theorem horner_mul_const {α} [comm_semiring α] (a x n b c a' b')
  (h₁ : a * c = a') (h₂ : b * c = b') :
  @horner α _ a x n b * c = horner a' x n b' :=
by simp [h₂.symm, h₁.symm, horner, add_mul, mul_right_comm]

meta def eval_const_mul (c : cache) (k : expr) :
  horner_expr → tactic (horner_expr × expr)
| (const e) := do
  (e', p) ← mk_app ``has_mul.mul [k, e] >>= norm_num,
  return (const e', p)
| (xadd e a x n b) := do
  (a', h₁) ← eval_const_mul a,
  (b', h₂) ← eval_const_mul b,
  return (xadd' c a' x n b',
    c.cs_app ``horner_const_mul [k, a, x, n.1, b, a', b', h₁, h₂])

theorem horner_mul_horner_zero {α} [comm_semiring α] (a₁ x n₁ b₁ a₂ n₂ aa t)
  (h₁ : @horner α _ a₁ x n₁ b₁ * a₂ = aa)
  (h₂ : horner aa x n₂ 0 = t) :
  horner a₁ x n₁ b₁ * horner a₂ x n₂ 0 = t :=
by rw [← h₂, ← h₁];
   simp [horner, mul_add, mul_comm, mul_left_comm, mul_assoc]

theorem horner_mul_horner {α} [comm_semiring α]
  (a₁ x n₁ b₁ a₂ n₂ b₂ aa haa ab bb t)
  (h₁ : @horner α _ a₁ x n₁ b₁ * a₂ = aa)
  (h₂ : horner aa x n₂ 0 = haa)
  (h₃ : a₁ * b₂ = ab) (h₄ : b₁ * b₂ = bb)
  (H : haa + horner ab x n₁ bb = t) :
  horner a₁ x n₁ b₁ * horner a₂ x n₂ b₂ = t :=
by rw [← H, ← h₂, ← h₁, ← h₃, ← h₄];
   simp [horner, mul_add, mul_comm, mul_left_comm, mul_assoc]

meta def eval_mul (c : cache) : horner_expr → horner_expr → tactic (horner_expr × expr)
| (const e₁) (const e₂) := do
  (e', p) ← mk_app ``has_mul.mul [e₁, e₂] >>= norm_num,
  return (const e', p)
| (const e₁) e₂ :=
  match e₁.to_nat with
  | (some 0) := do
    α0 ← expr.of_nat c.α 0,
    p ← mk_app ``zero_mul [e₂],
    return (const α0, p)
  | (some 1) := do
    p ← mk_app ``one_mul [e₂],
    return (e₂, p)
  | _ := eval_const_mul c e₁ e₂
  end
| e₁ he₂@(const e₂) := do
  p₁ ← mk_app ``mul_comm [e₁, e₂],
  (e', p₂) ← eval_mul he₂ e₁,
  p ← mk_eq_trans p₁ p₂, return (e', p)
| he₁@(xadd e₁ a₁ x₁ n₁ b₁) he₂@(xadd e₂ a₂ x₂ n₂ b₂) :=
  if expr.lex_lt x₁ x₂ then do
    (a', h₁) ← eval_mul a₁ he₂,
    (b', h₂) ← eval_mul b₁ he₂,
    return (xadd' c a' x₁ n₁ b',
      c.cs_app ``horner_mul_const [a₁, x₁, n₁.1, b₁, e₂, a', b', h₁, h₂])
  else if x₁ ≠ x₂ then do
    (a', h₁) ← eval_mul he₁ a₂,
    (b', h₂) ← eval_mul he₁ b₂,
    return (xadd' c a' x₂ n₂ b',
      c.cs_app ``horner_const_mul [e₁, a₂, x₂, n₂.1, b₂, a', b', h₁, h₂])
  else do
    (aa, h₁) ← eval_mul he₁ a₂,
    α0 ← expr.of_nat c.α 0,
    (haa, h₂) ← eval_horner c aa x₁ n₂ (const α0),
    if b₂.e.to_nat = some 0 then
      return (haa, c.cs_app ``horner_mul_horner_zero
        [a₁, x₁, n₁.1, b₁, a₂, n₂.1, aa, haa, h₁, h₂])
    else do
      (ab, h₃) ← eval_mul a₁ b₂,
      (bb, h₄) ← eval_mul b₁ b₂,
      (t, H) ← eval_add c haa (xadd' c ab x₁ n₁ bb),
      return (t, c.cs_app ``horner_mul_horner
        [a₁, x₁, n₁.1, b₁, a₂, n₂.1, b₂, aa, haa, ab, bb, t, h₁, h₂, h₃, h₄, H])

theorem horner_pow {α} [comm_semiring α] (a x n m n' a')
  (h₁ : n * m = n') (h₂ : a ^ m = a') :
  @horner α _ a x n 0 ^ m = horner a' x n' 0 :=
by simp [h₁.symm, h₂.symm, horner, mul_pow, pow_mul]

meta def eval_pow (c : cache) : horner_expr → expr × ℕ → tactic (horner_expr × expr)
| e (_, 0) := do
  α1 ← expr.of_nat c.α 1,
  p ← mk_app ``pow_zero [e],
  return (const α1, p)
| e (_, 1) := do
  p ← mk_app ``pow_one [e],
  return (e, p)
| (const e) (e₂, m) := do
  (e', p) ← mk_app ``monoid.pow [e, e₂] >>= norm_num.derive,
  return (const e', p)
| he@(xadd e a x n b) m :=
  let N : expr := expr.const `nat [] in
  match b.e.to_nat with
  | some 0 := do
    (n', h₁) ← mk_app ``has_mul.mul [n.1, m.1] >>= norm_num,
    (a', h₂) ← eval_pow a m,
    α0 ← expr.of_nat c.α 0,
    return (xadd' c a' x (n', n.2 * m.2) (const α0),
      c.cs_app ``horner_pow [a, x, n.1, m.1, n', a', h₁, h₂])
  | _ := do
    e₂ ← expr.of_nat N (m.2-1),
    l ← mk_app ``monoid.pow [e, e₂],
    (tl, hl) ← eval_pow he (e₂, m.2-1),
    (t, p₂) ← eval_mul c tl he,
    hr ← mk_eq_refl e,
    p₂ ← c.mk_app ``norm_num.subst_into_prod ``has_mul [l, e, tl, e, t, hl, hr, p₂],
    p₁ ← mk_app ``pow_succ' [e, e₂],
    p ← mk_eq_trans p₁ p₂,
    return (t, p)
  end

theorem horner_atom {α} [comm_semiring α] (x : α) : x = horner 1 x 1 0 :=
by simp [horner]

meta def eval_atom (c : cache) (e : expr) : tactic (horner_expr × expr) :=
do α0 ← expr.of_nat c.α 0,
   α1 ← expr.of_nat c.α 1,
   n1 ← expr.of_nat (expr.const `nat []) 1,
   return (xadd' c (const α1) e (n1, 1) (const α0), c.cs_app ``horner_atom [e])

lemma subst_into_pow {α} [monoid α] (l r tl tr t)
  (prl : (l : α) = tl) (prr : (r : ℕ) = tr) (prt : tl ^ tr = t) : l ^ r = t :=
by simp [prl, prr, prt]

lemma unfold_sub {α} [add_group α] (a b c : α)
  (h : a + -b = c) : a - b = c := h

lemma unfold_div {α} [division_ring α] (a b c : α)
  (h : a * b⁻¹ = c) : a / b = c := h

meta def eval (c : cache) : expr → tactic (horner_expr × expr)
| `(%%e₁ + %%e₂) := do
  (e₁', p₁) ← eval e₁,
  (e₂', p₂) ← eval e₂,
  (e', p') ← eval_add c e₁' e₂',
  p ← c.mk_app ``norm_num.subst_into_sum ``has_add [e₁, e₂, e₁', e₂', e', p₁, p₂, p'],
  return (e', p)
| `(%%e₁ - %%e₂) := do
  e₂' ← mk_app ``has_neg.neg [e₂],
  e ← mk_app ``has_add.add [e₁, e₂'],
  (e', p) ← eval e,
  p' ← c.mk_app ``unfold_sub ``add_group [e₁, e₂, e', p],
  return (e', p')
| `(- %%e) := do
  (e₁, p₁) ← eval e,
  (e₂, p₂) ← eval_neg c e₁,
  p ← c.mk_app ``norm_num.subst_into_neg ``has_neg [e, e₁, e₂, p₁, p₂],
  return (e₂, p)
| `(%%e₁ * %%e₂) := do
  (e₁', p₁) ← eval e₁,
  (e₂', p₂) ← eval e₂,
  (e', p') ← eval_mul c e₁' e₂',
  p ← c.mk_app ``norm_num.subst_into_prod ``has_mul [e₁, e₂, e₁', e₂', e', p₁, p₂, p'],
  return (e', p)
| e@`(has_inv.inv %%_) := (do
    (e', p) ← norm_num.derive e,
    e'.to_rat,
    return (const e', p)) <|> eval_atom c e
| `(%%e₁ / %%e₂) := do
  e₂' ← mk_app ``has_inv.inv [e₂],
  e ← mk_app ``has_mul.mul [e₁, e₂'],
  (e', p) ← eval e,
  p' ← c.mk_app ``unfold_div ``division_ring [e₁, e₂, e', p],
  return (e', p')
| e@`(@has_pow.pow _ _ %%P %%e₁ %%e₂) := do
  (e₂', p₂) ← eval e₂,
  match e₂'.e.to_nat, P with
  | some k, `(monoid.has_pow) := do
    (e₁', p₁) ← eval e₁,
    (e', p') ← eval_pow c e₁' (e₂, k),
    p ← c.mk_app ``subst_into_pow ``monoid [e₁, e₂, e₁', e₂', e', p₁, p₂, p'],
    return (e', p)
  | some k, `(nat.has_pow) := do
    (e₁', p₁) ← eval e₁,
    (e', p') ← eval_pow c e₁' (e₂, k),
    p₃ ← c.mk_app ``subst_into_pow ``monoid [e₁, e₂, e₁', e₂', e', p₁, p₂, p'],
    p₄ ← mk_app ``nat.pow_eq_pow [e₁, e₂] >>= mk_eq_symm,
    p ← mk_eq_trans p₄ p₃,
    return (e', p)
  | _, _ := eval_atom c e
  end
| e := match e.to_nat with
  | some n := (const e).refl_conv
  | none := eval_atom c e
  end

meta def eval' (c : cache) (e : expr) : tactic (expr × expr) :=
do (e', p) ← eval c e, return (e', p)

theorem horner_def' {α} [comm_semiring α] (a x n b) : @horner α _ a x n b = x ^ n * a + b :=
by simp [horner, mul_comm]

theorem mul_assoc_rev {α} [semigroup α] (a b c : α) : a * (b * c) = a * b * c :=
by simp [mul_assoc]

theorem pow_add_rev {α} [monoid α] (a b : α) (m n : ℕ) : a ^ m * a ^ n = a ^ (m + n) :=
by simp [pow_add]

theorem pow_add_rev_right {α} [monoid α] (a b : α) (m n : ℕ) : b * a ^ m * a ^ n = b * a ^ (m + n) :=
by simp [pow_add, mul_assoc]

theorem add_neg_eq_sub {α} [add_group α] (a b : α) : a + -b = a - b := rfl

@[derive has_reflect]
inductive normalize_mode | raw | SOP | horner

meta def normalize (mode := normalize_mode.horner) (e : expr) : tactic (expr × expr) := do
pow_lemma ← simp_lemmas.mk.add_simp ``pow_one,
let lemmas := match mode with
| normalize_mode.SOP :=
  [``horner_def', ``add_zero, ``mul_one, ``mul_add, ``mul_sub,
   ``mul_assoc_rev, ``pow_add_rev, ``pow_add_rev_right,
   ``mul_neg_eq_neg_mul_symm, ``add_neg_eq_sub]
| normalize_mode.horner :=
  [``horner.equations._eqn_1, ``add_zero, ``one_mul, ``pow_one,
   ``neg_mul_eq_neg_mul_symm, ``add_neg_eq_sub]
| _ := []
end,
lemmas ← lemmas.mfoldl simp_lemmas.add_simp simp_lemmas.mk,
(_, e', pr) ← ext_simplify_core () {}
  simp_lemmas.mk (λ _, failed) (λ _ _ _ _ e, do
    c ← mk_cache e,
    (new_e, pr) ← match mode with
    | normalize_mode.raw := eval' c
    | normalize_mode.horner := trans_conv (eval' c) (simplify lemmas [])
    | normalize_mode.SOP :=
      trans_conv (eval' c) $
      trans_conv (simplify lemmas []) $
      simp_bottom_up' (λ e, norm_num e <|> pow_lemma.rewrite e)
    end e,
    guard (¬ new_e =ₐ e),
    return ((), new_e, some pr, ff))
   (λ _ _ _ _ _, failed) `eq e,
return (e', pr)

end ring

namespace interactive
open interactive interactive.types lean.parser
open tactic.ring

local postfix `?`:9001 := optional

/-- Tactic for solving equations in the language of rings.
  This version of `ring` fails if the target is not an equality
  that is provable by the axioms of commutative (semi)rings. -/
meta def ring1 : tactic unit :=
do `(%%e₁ = %%e₂) ← target,
  c ← mk_cache e₁,
  (e₁', p₁) ← eval c e₁,
  (e₂', p₂) ← eval c e₂,
  is_def_eq e₁' e₂',
  p ← mk_eq_symm p₂ >>= mk_eq_trans p₁,
  tactic.exact p

meta def ring.mode : lean.parser ring.normalize_mode :=
with_desc "(SOP|raw|horner)?" $
do mode ← ident?, match mode with
| none         := return ring.normalize_mode.horner
| some `horner := return ring.normalize_mode.horner
| some `SOP    := return ring.normalize_mode.SOP
| some `raw    := return ring.normalize_mode.raw
| _            := failed
end

/-- Tactic for solving equations in the language of rings.
  Attempts to prove the goal outright if there is no `at`
  specifier and the target is an equality, but if this
  fails it falls back to rewriting all ring expressions
  into a normal form. When writing a normal form,
  `ring SOP` will use sum-of-products form instead of horner form. -/
meta def ring (SOP : parse ring.mode) (loc : parse location) : tactic unit :=
match loc with
| interactive.loc.ns [none] := ring1
| _ := failed
end <|>
do ns ← loc.get_locals,
   tt ← tactic.replace_at (normalize SOP) ns loc.include_goal
      | fail "ring failed to simplify",
   when loc.include_goal $ try tactic.reflexivity

end interactive
end tactic

namespace conv.interactive
open conv interactive
open tactic tactic.interactive (ring.mode ring1)
open tactic.ring (normalize)

meta def ring (SOP : parse ring.mode) : conv unit :=
discharge_eq_lhs ring1
<|> replace_lhs (normalize SOP)
<|> fail "ring failed to simplify"

end conv.interactive


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

Generalizes the Cauchy completion of (ℚ, abs) to the completion of a
commutative ring with absolute value.
-/
import data.real.cau_seq

namespace cau_seq.completion
open cau_seq

section
parameters {α : Type*} [linear_ordered_field α]
parameters {β : Type*} [comm_ring β] {abv : β → α} [is_absolute_value abv]

def Cauchy := @quotient (cau_seq _ abv) cau_seq.equiv

def mk : cau_seq _ abv → Cauchy := quotient.mk

@[simp] theorem mk_eq_mk (f) : @eq Cauchy ⟦f⟧ (mk f) := rfl

theorem mk_eq {f g} : mk f = mk g ↔ f ≈ g := quotient.eq

def of_rat (x : β) : Cauchy := mk (const abv x)

instance : has_zero Cauchy := ⟨of_rat 0⟩
instance : has_one Cauchy := ⟨of_rat 1⟩
instance : inhabited Cauchy := ⟨0⟩

theorem of_rat_zero : of_rat 0 = 0 := rfl
theorem of_rat_one : of_rat 1 = 1 := rfl

@[simp] theorem mk_eq_zero {f} : mk f = 0 ↔ lim_zero f :=
by have : mk f = 0 ↔ lim_zero (f - 0) := quotient.eq;
   rwa sub_zero at this

instance : has_add Cauchy :=
⟨λ x y, quotient.lift_on₂ x y (λ f g, mk (f + g)) $
  λ f₁ g₁ f₂ g₂ hf hg, quotient.sound $
  by simpa [(≈), setoid.r, sub_eq_add_neg, add_comm, add_left_comm, add_assoc]
    using add_lim_zero hf hg⟩

@[simp] theorem mk_add (f g : cau_seq β abv) : mk f + mk g = mk (f + g) := rfl

instance : has_neg Cauchy :=
⟨λ x, quotient.lift_on x (λ f, mk (-f)) $
  λ f₁ f₂ hf, quotient.sound $
  by simpa [(≈), setoid.r] using neg_lim_zero hf⟩

@[simp] theorem mk_neg (f : cau_seq β abv) : -mk f = mk (-f) := rfl

instance : has_mul Cauchy :=
⟨λ x y, quotient.lift_on₂ x y (λ f g, mk (f * g)) $
  λ f₁ g₁ f₂ g₂ hf hg, quotient.sound $
  by simpa [(≈), setoid.r, mul_add, mul_comm, add_assoc, sub_eq_add_neg] using
    add_lim_zero (mul_lim_zero_right g₁ hf) (mul_lim_zero_right f₂ hg)⟩

@[simp] theorem mk_mul (f g : cau_seq β abv) : mk f * mk g = mk (f * g) := rfl

instance : has_sub Cauchy :=
⟨λ x y, quotient.lift_on₂ x y (λ f g, mk (f - g)) $
  λ f₁ g₁ f₂ g₂ hf hg, quotient.sound $ show ((f₁ - g₁) - (f₂ - g₂)).lim_zero,
    by simpa [sub_eq_add_neg, add_assoc, add_comm, add_left_comm] using sub_lim_zero hf hg⟩

@[simp] theorem mk_sub (f g : cau_seq β abv) : mk f - mk g = mk (f - g) := rfl

theorem of_rat_add (x y : β) : of_rat (x + y) = of_rat x + of_rat y :=
congr_arg mk (const_add _ _)

theorem of_rat_neg (x : β) : of_rat (-x) = -of_rat x :=
congr_arg mk (const_neg _)

theorem of_rat_mul (x y : β) : of_rat (x * y) = of_rat x * of_rat y :=
congr_arg mk (const_mul _ _)

private lemma zero_def : 0 = mk 0 := rfl

private lemma one_def : 1 = mk 1 := rfl

instance : comm_ring Cauchy :=
by refine { neg := has_neg.neg, sub := has_sub.sub, sub_eq_add_neg := _,
    add := (+), zero := (0 : Cauchy), mul := (*), one := 1, nsmul := nsmul_rec, npow := npow_rec,
    gsmul := gsmul_rec, .. }; try { intros; refl };
{ repeat {refine λ a, quotient.induction_on a (λ _, _)},
  simp [zero_def, one_def, mul_left_comm, mul_comm, mul_add, add_comm, add_left_comm,
          sub_eq_add_neg] }

theorem of_rat_sub (x y : β) : of_rat (x - y) = of_rat x - of_rat y :=
congr_arg mk (const_sub _ _)

end

open_locale classical
section

parameters {α : Type*} [linear_ordered_field α]
parameters {β : Type*} [field β] {abv : β → α} [is_absolute_value abv]
local notation `Cauchy` := @Cauchy _ _ _ _ abv _

noncomputable instance : has_inv Cauchy :=
⟨λ x, quotient.lift_on x
  (λ f, mk $ if h : lim_zero f then 0 else inv f h) $
λ f g fg, begin
  have := lim_zero_congr fg,
  by_cases hf : lim_zero f,
  { simp [hf, this.1 hf, setoid.refl] },
  { have hg := mt this.2 hf, simp [hf, hg],
    have If : mk (inv f hf) * mk f = 1 := mk_eq.2 (inv_mul_cancel hf),
    have Ig : mk (inv g hg) * mk g = 1 := mk_eq.2 (inv_mul_cancel hg),
    rw [mk_eq.2 fg, ← Ig] at If,
    rw mul_comm at Ig,
    rw [← mul_one (mk (inv f hf)), ← Ig, ← mul_assoc, If,
        mul_assoc, Ig, mul_one] }
end⟩

@[simp] theorem inv_zero : (0 : Cauchy)⁻¹ = 0 :=
congr_arg mk $ by rw dif_pos; [refl, exact zero_lim_zero]

@[simp] theorem inv_mk {f} (hf) : (@mk α _ β _ abv _ f)⁻¹ = mk (inv f hf) :=
congr_arg mk $ by rw dif_neg

lemma cau_seq_zero_ne_one : ¬ (0 : cau_seq _ abv) ≈ 1 := λ h,
have lim_zero (1 - 0), from setoid.symm h,
have lim_zero 1, by simpa,
one_ne_zero $ const_lim_zero.1 this

lemma zero_ne_one : (0 : Cauchy) ≠ 1 :=
λ h, cau_seq_zero_ne_one $ mk_eq.1 h

protected theorem inv_mul_cancel {x : Cauchy} : x ≠ 0 → x⁻¹ * x = 1 :=
quotient.induction_on x $ λ f hf, begin
  simp at hf, simp [hf],
  exact quotient.sound (cau_seq.inv_mul_cancel hf)
end

noncomputable def field : field Cauchy :=
{ inv              := has_inv.inv,
  mul_inv_cancel   := λ x x0, by rw [mul_comm, cau_seq.completion.inv_mul_cancel x0],
  exists_pair_ne   := ⟨0, 1, zero_ne_one⟩,
  inv_zero         := inv_zero,
  .. Cauchy.comm_ring }

local attribute [instance] field

theorem of_rat_inv (x : β) : of_rat (x⁻¹) = ((of_rat x)⁻¹ : Cauchy) :=
congr_arg mk $ by split_ifs with h; [simp [const_lim_zero.1 h], refl]

theorem of_rat_div (x y : β) : of_rat (x / y) = (of_rat x / of_rat y : Cauchy) :=
by simp only [div_eq_inv_mul, of_rat_inv, of_rat_mul]

end
end cau_seq.completion

variables {α : Type*} [linear_ordered_field α]
namespace cau_seq
section

variables (β : Type*) [ring β] (abv : β → α) [is_absolute_value abv]

class is_complete :=
(is_complete : ∀ s : cau_seq β abv, ∃ b : β, s ≈ const abv b)
end

section

variables {β : Type*} [ring β] {abv : β → α} [is_absolute_value abv]
variable [is_complete β abv]

lemma complete : ∀ s : cau_seq β abv, ∃ b : β, s ≈ const abv b :=
is_complete.is_complete

noncomputable def lim (s : cau_seq β abv) := classical.some (complete s)

lemma equiv_lim (s : cau_seq β abv) : s ≈ const abv (lim s) :=
classical.some_spec (complete s)

lemma eq_lim_of_const_equiv {f : cau_seq β abv} {x : β} (h : cau_seq.const abv x ≈ f) : x = lim f :=
const_equiv.mp $ setoid.trans h $ equiv_lim f

lemma lim_eq_of_equiv_const {f : cau_seq β abv} {x : β} (h : f ≈ cau_seq.const abv x) : lim f = x :=
(eq_lim_of_const_equiv $ setoid.symm h).symm

lemma lim_eq_lim_of_equiv {f g : cau_seq β abv} (h : f ≈ g) : lim f = lim g :=
lim_eq_of_equiv_const $ setoid.trans h $ equiv_lim g

@[simp] lemma lim_const (x : β) : lim (const abv x) = x :=
lim_eq_of_equiv_const $ setoid.refl _

lemma lim_add (f g : cau_seq β abv) : lim f + lim g = lim (f + g) :=
eq_lim_of_const_equiv $ show lim_zero (const abv (lim f + lim g) - (f + g)),
  by rw [const_add, add_sub_comm];
  exact add_lim_zero (setoid.symm (equiv_lim f)) (setoid.symm (equiv_lim g))

lemma lim_mul_lim (f g : cau_seq β abv) : lim f * lim g = lim (f * g) :=
eq_lim_of_const_equiv $ show lim_zero (const abv (lim f * lim g) - f * g),
  from have h : const abv (lim f * lim g) - f * g = (const abv (lim f) - f) * g
      + const abv (lim f) * (const abv (lim g) - g) :=
    by simp [const_mul (lim f), mul_add, add_mul, sub_eq_add_neg, add_comm, add_left_comm],
  by rw h; exact add_lim_zero (mul_lim_zero_left _ (setoid.symm (equiv_lim _)))
    (mul_lim_zero_right _ (setoid.symm (equiv_lim _)))

lemma lim_mul (f : cau_seq β abv) (x : β) : lim f * x = lim (f * const abv x) :=
by rw [← lim_mul_lim, lim_const]

lemma lim_neg (f : cau_seq β abv) : lim (-f) = -lim f :=
lim_eq_of_equiv_const (show lim_zero (-f - const abv (-lim f)),
  by rw [const_neg, sub_neg_eq_add, add_comm, ← sub_eq_add_neg];
  exact setoid.symm (equiv_lim f))

lemma lim_eq_zero_iff (f : cau_seq β abv) : lim f = 0 ↔ lim_zero f :=
⟨assume h,
  by have hf := equiv_lim f;
  rw h at hf;
  exact (lim_zero_congr hf).mpr (const_lim_zero.mpr rfl),
assume h,
  have h₁ : f = (f - const abv 0) := ext (λ n, by simp [sub_apply, const_apply]),
  by rw h₁ at h; exact lim_eq_of_equiv_const h ⟩

end

section
variables {β : Type*} [field β] {abv : β → α} [is_absolute_value abv] [is_complete β abv]

lemma lim_inv {f : cau_seq β abv} (hf : ¬ lim_zero f) : lim (inv f hf) = (lim f)⁻¹ :=
have hl : lim f ≠ 0 := by rwa ← lim_eq_zero_iff at hf,
lim_eq_of_equiv_const $ show lim_zero (inv f hf - const abv (lim f)⁻¹),
  from have h₁ : ∀ (g f : cau_seq β abv) (hf : ¬ lim_zero f), lim_zero (g - f * inv f hf * g) :=
    λ g f hf, by rw [← one_mul g, ← mul_assoc, ← sub_mul, mul_one, mul_comm, mul_comm f];
    exact mul_lim_zero_right _ (setoid.symm (cau_seq.inv_mul_cancel _)),
  have h₂ : lim_zero ((inv f hf - const abv (lim f)⁻¹) - (const abv (lim f) - f) *
      (inv f hf * const abv (lim f)⁻¹)) :=
    by rw [sub_mul, ← sub_add, sub_sub, sub_add_eq_sub_sub, sub_right_comm, sub_add];
    exact show lim_zero (inv f hf - const abv (lim f) * (inv f hf * const abv (lim f)⁻¹)
      - (const abv (lim f)⁻¹ - f * (inv f hf * const abv (lim f)⁻¹))),
    from sub_lim_zero
      (by rw [← mul_assoc, mul_right_comm, const_inv hl]; exact h₁ _ _ _)
      (by rw [← mul_assoc]; exact h₁ _ _ _),
  (lim_zero_congr h₂).mpr $ mul_lim_zero_left _ (setoid.symm (equiv_lim f))

end

section
variables [is_complete α abs]

lemma lim_le {f : cau_seq α abs} {x : α}
  (h : f ≤ cau_seq.const abs x) : lim f ≤ x :=
cau_seq.const_le.1 $ cau_seq.le_of_eq_of_le (setoid.symm (equiv_lim f)) h

lemma le_lim {f : cau_seq α abs} {x : α}
  (h : cau_seq.const abs x ≤ f) : x ≤ lim f :=
cau_seq.const_le.1 $ cau_seq.le_of_le_of_eq h (equiv_lim f)

lemma lt_lim {f : cau_seq α abs} {x : α}
  (h : cau_seq.const abs x < f) : x < lim f :=
cau_seq.const_lt.1 $ cau_seq.lt_of_lt_of_eq h (equiv_lim f)

lemma lim_lt {f : cau_seq α abs} {x : α}
  (h : f < cau_seq.const abs x) : lim f < x :=
cau_seq.const_lt.1 $ cau_seq.lt_of_eq_of_lt (setoid.symm (equiv_lim f)) h

end
end cau_seq


/-
Copyright (c) 2021 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import algebra.group.pi
import data.fintype.basic

/-!
# Matrices

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.
-/
universes u u' v w z

/-- `dmatrix m n` is the type of dependently typed matrices
whose rows are indexed by the fintype `m` and
whose columns are indexed by the fintype `n`. -/
@[nolint unused_arguments]
def dmatrix (m : Type u) (n : Type u') [fintype m] [fintype n] (α : m → n → Type v) :
  Type (max u u' v) :=
Π i j, α i j

variables {l m n o : Type*} [fintype l] [fintype m] [fintype n] [fintype o]
variables {α : m → n → Type v}

namespace dmatrix

section ext
variables {M N : dmatrix m n α}

theorem ext_iff : (∀ i j, M i j = N i j) ↔ M = N :=
⟨λ h, funext $ λ i, funext $ h i, λ h, by simp [h]⟩

@[ext] theorem ext : (∀ i j, M i j = N i j) → M = N :=
ext_iff.mp

end ext

/-- `M.map f` is the dmatrix obtained by applying `f` to each entry of the matrix `M`. -/
def map (M : dmatrix m n α) {β : m → n → Type w} (f : Π ⦃i j⦄, α i j → β i j) :
  dmatrix m n β := λ i j, f (M i j)

@[simp]
lemma map_apply {M : dmatrix m n α} {β : m → n → Type w} {f : Π ⦃i j⦄, α i j → β i j}
  {i : m} {j : n} : M.map f i j = f (M i j) :=
rfl

@[simp]
lemma map_map {M : dmatrix m n α} {β : m → n → Type w} {γ : m → n → Type z}
  {f : Π ⦃i j⦄, α i j → β i j} {g : Π ⦃i j⦄, β i j → γ i j} :
  (M.map f).map g = M.map (λ i j x, g (f x)) :=
by { ext, simp, }

/-- The transpose of a dmatrix. -/
def transpose (M : dmatrix m n α) : dmatrix n m (λ j i, α i j)
| x y := M y x

localized "postfix (name := dmatrix.transpose) `ᵀ`:1500 := dmatrix.transpose" in dmatrix

/-- `dmatrix.col u` is the column matrix whose entries are given by `u`. -/
def col {α : m → Type v} (w : Π i, α i) : dmatrix m unit (λ i j, α i)
| x y := w x

/-- `dmatrix.row u` is the row matrix whose entries are given by `u`. -/
def row {α : n → Type v} (v : Π j, α j) : dmatrix unit n (λ i j, α j)
| x y := v y

instance [∀ i j, inhabited (α i j)] : inhabited (dmatrix m n α) := pi.inhabited _
instance [∀ i j, has_add (α i j)] : has_add (dmatrix m n α) := pi.has_add
instance [∀ i j, add_semigroup (α i j)] : add_semigroup (dmatrix m n α) := pi.add_semigroup
instance [∀ i j, add_comm_semigroup (α i j)] : add_comm_semigroup (dmatrix m n α) :=
pi.add_comm_semigroup
instance [∀ i j, has_zero (α i j)] : has_zero (dmatrix m n α) := pi.has_zero
instance [∀ i j, add_monoid (α i j)] : add_monoid (dmatrix m n α) := pi.add_monoid
instance [∀ i j, add_comm_monoid (α i j)] : add_comm_monoid (dmatrix m n α) := pi.add_comm_monoid
instance [∀ i j, has_neg (α i j)] : has_neg (dmatrix m n α) := pi.has_neg
instance [∀ i j, has_sub (α i j)] : has_sub (dmatrix m n α) := pi.has_sub
instance [∀ i j, add_group (α i j)] : add_group (dmatrix m n α) := pi.add_group
instance [∀ i j, add_comm_group (α i j)] : add_comm_group (dmatrix m n α) := pi.add_comm_group
instance [∀ i j, unique (α i j)] : unique (dmatrix m n α) := pi.unique
instance [∀ i j, subsingleton (α i j)] : subsingleton (dmatrix m n α) := pi.subsingleton

@[simp] theorem zero_apply [∀ i j, has_zero (α i j)] (i j) : (0 : dmatrix m n α) i j = 0 := rfl
@[simp] theorem neg_apply [∀ i j, has_neg (α i j)] (M : dmatrix m n α) (i j) :
  (- M) i j = - M i j :=
rfl
@[simp] theorem add_apply [∀ i j, has_add (α i j)] (M N : dmatrix m n α) (i j) :
  (M + N) i j = M i j + N i j :=
rfl
@[simp] theorem sub_apply [∀ i j, has_sub (α i j)] (M N : dmatrix m n α) (i j) :
  (M - N) i j = M i j - N i j :=
rfl

@[simp] lemma map_zero [∀ i j, has_zero (α i j)] {β : m → n → Type w} [∀ i j, has_zero (β i j)]
  {f : Π ⦃i j⦄, α i j → β i j} (h : ∀ i j, f (0 : α i j) = 0) :
  (0 : dmatrix m n α).map f = 0 :=
by { ext, simp [h], }

lemma map_add [∀ i j, add_monoid (α i j)] {β : m → n → Type w} [∀ i j, add_monoid (β i j)]
  (f : Π ⦃i j⦄, α i j →+ β i j) (M N : dmatrix m n α) :
  (M + N).map (λ i j, @f i j) = M.map (λ i j, @f i j) + N.map (λ i j, @f i j) :=
by { ext, simp, }

lemma map_sub [∀ i j, add_group (α i j)] {β : m → n → Type w} [∀ i j, add_group (β i j)]
  (f : Π ⦃i j⦄, α i j →+ β i j) (M N : dmatrix m n α) :
  (M - N).map (λ i j, @f i j) = M.map (λ i j, @f i j) - N.map (λ i j, @f i j) :=
by { ext, simp }

instance subsingleton_of_empty_left [is_empty m] : subsingleton (dmatrix m n α) :=
⟨λ M N, by { ext, exact is_empty_elim i }⟩

instance subsingleton_of_empty_right [is_empty n] : subsingleton (dmatrix m n α) :=
⟨λ M N, by { ext, exact is_empty_elim j }⟩

end dmatrix

/-- The `add_monoid_hom` between spaces of dependently typed matrices
induced by an `add_monoid_hom` between their coefficients. -/
def add_monoid_hom.map_dmatrix
  [∀ i j, add_monoid (α i j)] {β : m → n → Type w} [∀ i j, add_monoid (β i j)]
  (f : Π ⦃i j⦄, α i j →+ β i j) :
  dmatrix m n α →+ dmatrix m n β :=
{ to_fun := λ M, M.map (λ i j, @f i j),
  map_zero' := by simp,
  map_add' := dmatrix.map_add f, }

@[simp] lemma add_monoid_hom.map_dmatrix_apply
  [∀ i j, add_monoid (α i j)] {β : m → n → Type w} [∀ i j, add_monoid (β i j)]
  (f : Π ⦃i j⦄, α i j →+ β i j) (M : dmatrix m n α) :
  add_monoid_hom.map_dmatrix f M = M.map (λ i j, @f i j) :=
rfl


/-
Copyright (c) 2020 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Yury Kudryashov
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.analysis.normed_space.banach
import Mathlib.analysis.normed_space.finite_dimension
import Mathlib.PostPort

universes u_1 u_2 u_3 u_4

namespace Mathlib

/-!
# Complemented subspaces of normed vector spaces

A submodule `p` of a topological module `E` over `R` is called *complemented* if there exists
a continuous linear projection `f : E →ₗ[R] p`, `∀ x : p, f x = x`. We prove that for
a closed subspace of a normed space this condition is equivalent to existence of a closed
subspace `q` such that `p ⊓ q = ⊥`, `p ⊔ q = ⊤`. We also prove that a subspace of finite codimension
is always a complemented subspace.

## Tags

complemented subspace, normed vector space
-/

namespace continuous_linear_map

theorem ker_closed_complemented_of_finite_dimensional_range {𝕜 : Type u_1}
    [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E] {F : Type u_3}
    [normed_group F] [normed_space 𝕜 F] [complete_space 𝕜] (f : continuous_linear_map 𝕜 E F)
    [finite_dimensional 𝕜 ↥(range f)] : submodule.closed_complemented (ker f) :=
  sorry

/-- If `f : E →L[R] F` and `g : E →L[R] G` are two surjective linear maps and
their kernels are complement of each other, then `x ↦ (f x, g x)` defines
a linear equivalence `E ≃L[R] F × G`. -/
def equiv_prod_of_surjective_of_is_compl {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2}
    [normed_group E] [normed_space 𝕜 E] {F : Type u_3} [normed_group F] [normed_space 𝕜 F]
    {G : Type u_4} [normed_group G] [normed_space 𝕜 G] [complete_space E] [complete_space (F × G)]
    (f : continuous_linear_map 𝕜 E F) (g : continuous_linear_map 𝕜 E G) (hf : range f = ⊤)
    (hg : range g = ⊤) (hfg : is_compl (ker f) (ker g)) : continuous_linear_equiv 𝕜 E (F × G) :=
  linear_equiv.to_continuous_linear_equiv_of_continuous
    (linear_map.equiv_prod_of_surjective_of_is_compl (↑f) (↑g) hf hg hfg) sorry

@[simp] theorem coe_equiv_prod_of_surjective_of_is_compl {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜]
    {E : Type u_2} [normed_group E] [normed_space 𝕜 E] {F : Type u_3} [normed_group F]
    [normed_space 𝕜 F] {G : Type u_4} [normed_group G] [normed_space 𝕜 G] [complete_space E]
    [complete_space (F × G)] {f : continuous_linear_map 𝕜 E F} {g : continuous_linear_map 𝕜 E G}
    (hf : range f = ⊤) (hg : range g = ⊤) (hfg : is_compl (ker f) (ker g)) :
    ↑(equiv_prod_of_surjective_of_is_compl f g hf hg hfg) = ↑(continuous_linear_map.prod f g) :=
  rfl

@[simp] theorem equiv_prod_of_surjective_of_is_compl_to_linear_equiv {𝕜 : Type u_1}
    [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E] {F : Type u_3}
    [normed_group F] [normed_space 𝕜 F] {G : Type u_4} [normed_group G] [normed_space 𝕜 G]
    [complete_space E] [complete_space (F × G)] {f : continuous_linear_map 𝕜 E F}
    {g : continuous_linear_map 𝕜 E G} (hf : range f = ⊤) (hg : range g = ⊤)
    (hfg : is_compl (ker f) (ker g)) :
    continuous_linear_equiv.to_linear_equiv (equiv_prod_of_surjective_of_is_compl f g hf hg hfg) =
        linear_map.equiv_prod_of_surjective_of_is_compl (↑f) (↑g) hf hg hfg :=
  rfl

@[simp] theorem equiv_prod_of_surjective_of_is_compl_apply {𝕜 : Type u_1}
    [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E] {F : Type u_3}
    [normed_group F] [normed_space 𝕜 F] {G : Type u_4} [normed_group G] [normed_space 𝕜 G]
    [complete_space E] [complete_space (F × G)] {f : continuous_linear_map 𝕜 E F}
    {g : continuous_linear_map 𝕜 E G} (hf : range f = ⊤) (hg : range g = ⊤)
    (hfg : is_compl (ker f) (ker g)) (x : E) :
    coe_fn (equiv_prod_of_surjective_of_is_compl f g hf hg hfg) x = (coe_fn f x, coe_fn g x) :=
  rfl

end continuous_linear_map

namespace subspace

/-- If `q` is a closed complement of a closed subspace `p`, then `p × q` is continuously
isomorphic to `E`. -/
def prod_equiv_of_closed_compl {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2}
    [normed_group E] [normed_space 𝕜 E] [complete_space E] (p : subspace 𝕜 E) (q : subspace 𝕜 E)
    (h : is_compl p q) (hp : is_closed ↑p) (hq : is_closed ↑q) :
    continuous_linear_equiv 𝕜 (↥p × ↥q) E :=
  linear_equiv.to_continuous_linear_equiv_of_continuous (submodule.prod_equiv_of_is_compl p q h)
    sorry

/-- Projection to a closed submodule along a closed complement. -/
def linear_proj_of_closed_compl {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2}
    [normed_group E] [normed_space 𝕜 E] [complete_space E] (p : subspace 𝕜 E) (q : subspace 𝕜 E)
    (h : is_compl p q) (hp : is_closed ↑p) (hq : is_closed ↑q) : continuous_linear_map 𝕜 E ↥p :=
  continuous_linear_map.comp (continuous_linear_map.fst 𝕜 ↥p ↥q)
    ↑(continuous_linear_equiv.symm (prod_equiv_of_closed_compl p q h hp hq))

@[simp] theorem coe_prod_equiv_of_closed_compl {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜]
    {E : Type u_2} [normed_group E] [normed_space 𝕜 E] [complete_space E] {p : subspace 𝕜 E}
    {q : subspace 𝕜 E} (h : is_compl p q) (hp : is_closed ↑p) (hq : is_closed ↑q) :
    ⇑(prod_equiv_of_closed_compl p q h hp hq) = ⇑(submodule.prod_equiv_of_is_compl p q h) :=
  rfl

@[simp] theorem coe_prod_equiv_of_closed_compl_symm {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜]
    {E : Type u_2} [normed_group E] [normed_space 𝕜 E] [complete_space E] {p : subspace 𝕜 E}
    {q : subspace 𝕜 E} (h : is_compl p q) (hp : is_closed ↑p) (hq : is_closed ↑q) :
    ⇑(continuous_linear_equiv.symm (prod_equiv_of_closed_compl p q h hp hq)) =
        ⇑(linear_equiv.symm (submodule.prod_equiv_of_is_compl p q h)) :=
  rfl

@[simp] theorem coe_continuous_linear_proj_of_closed_compl {𝕜 : Type u_1}
    [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E]
    [complete_space E] {p : subspace 𝕜 E} {q : subspace 𝕜 E} (h : is_compl p q) (hp : is_closed ↑p)
    (hq : is_closed ↑q) :
    ↑(linear_proj_of_closed_compl p q h hp hq) = submodule.linear_proj_of_is_compl p q h :=
  rfl

@[simp] theorem coe_continuous_linear_proj_of_closed_compl' {𝕜 : Type u_1}
    [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E]
    [complete_space E] {p : subspace 𝕜 E} {q : subspace 𝕜 E} (h : is_compl p q) (hp : is_closed ↑p)
    (hq : is_closed ↑q) :
    ⇑(linear_proj_of_closed_compl p q h hp hq) = ⇑(submodule.linear_proj_of_is_compl p q h) :=
  rfl

theorem closed_complemented_of_closed_compl {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜]
    {E : Type u_2} [normed_group E] [normed_space 𝕜 E] [complete_space E] {p : subspace 𝕜 E}
    {q : subspace 𝕜 E} (h : is_compl p q) (hp : is_closed ↑p) (hq : is_closed ↑q) :
    submodule.closed_complemented p :=
  Exists.intro (linear_proj_of_closed_compl p q h hp hq)
    (submodule.linear_proj_of_is_compl_apply_left h)

theorem closed_complemented_iff_has_closed_compl {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜]
    {E : Type u_2} [normed_group E] [normed_space 𝕜 E] [complete_space E] {p : subspace 𝕜 E} :
    submodule.closed_complemented p ↔
        is_closed ↑p ∧ ∃ (q : subspace 𝕜 E), ∃ (hq : is_closed ↑q), is_compl p q :=
  sorry

theorem closed_complemented_of_quotient_finite_dimensional {𝕜 : Type u_1}
    [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E]
    [complete_space E] {p : subspace 𝕜 E} [complete_space 𝕜]
    [finite_dimensional 𝕜 (submodule.quotient p)] (hp : is_closed ↑p) :
    submodule.closed_complemented p :=
  sorry

end Mathlib


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.limits.shapes.equalizers
import Mathlib.category_theory.limits.shapes.pullbacks
import Mathlib.category_theory.limits.shapes.regular_mono
import Mathlib.PostPort

universes v u l

namespace Mathlib

/-!
# Kernel pairs

This file defines what it means for a parallel pair of morphisms `a b : R ⟶ X` to be the kernel pair
for a morphism `f`.
Some properties of kernel pairs are given, namely allowing one to transfer between
the kernel pair of `f₁ ≫ f₂` to the kernel pair of `f₁`.
It is also proved that if `f` is a coequalizer of some pair, and `a`,`b` is a kernel pair for `f` then
it is a coequalizer of `a`,`b`.

## Implementation

The definition is essentially just a wrapper for `is_limit (pullback_cone.mk _ _ _)`, but the
constructions given here are useful, yet awkward to present in that language, so a basic API
is developed here.

## TODO

- Internal equivalence relations (or congruences) and the fact that every kernel pair induces one,
  and the converse in an effective regular category (WIP by b-mehta).

-/

namespace category_theory

/--
`is_kernel_pair f a b` expresses that `(a, b)` is a kernel pair for `f`, i.e. `a ≫ f = b ≫ f`
and the square
  R → X
  ↓   ↓
  X → Y
is a pullback square.
This is essentially just a convenience wrapper over `is_limit (pullback_cone.mk _ _ _)`.
-/
structure is_kernel_pair {C : Type u} [category C] {R : C} {X : C} {Y : C} (f : X ⟶ Y) (a : R ⟶ X)
    (b : R ⟶ X)
    where
  comm : a ≫ f = b ≫ f
  is_limit : limits.is_limit (limits.pullback_cone.mk a b comm)

theorem is_kernel_pair.comm_assoc {C : Type u} [category C] {R : C} {X : C} {Y : C} {f : X ⟶ Y}
    {a : R ⟶ X} {b : R ⟶ X} (c : is_kernel_pair f a b) {X' : C} (f' : Y ⟶ X') :
    a ≫ f ≫ f' = b ≫ f ≫ f' :=
  sorry

namespace is_kernel_pair

/-- The data expressing that `(a, b)` is a kernel pair is subsingleton. -/
protected instance subsingleton {C : Type u} [category C] {R : C} {X : C} {Y : C} (f : X ⟶ Y)
    (a : R ⟶ X) (b : R ⟶ X) : subsingleton (is_kernel_pair f a b) :=
  subsingleton.intro
    fun (P Q : is_kernel_pair f a b) =>
      cases_on P
        fun (P_comm : a ≫ f = b ≫ f)
          (P_is_limit : limits.is_limit (limits.pullback_cone.mk a b P_comm)) =>
          cases_on Q
            fun (Q_comm : a ≫ f = b ≫ f)
              (Q_is_limit : limits.is_limit (limits.pullback_cone.mk a b Q_comm)) =>
              (fun {f : X ⟶ Y} {a b : R ⟶ X} (comm comm_1 : a ≫ f = b ≫ f)
                  (is_limit : limits.is_limit (limits.pullback_cone.mk a b comm))
                  (is_limit_1 : limits.is_limit (limits.pullback_cone.mk a b comm_1)) =>
                  Eq.trans
                    ((fun {f : X ⟶ Y} {a b : R ⟶ X} (comm : a ≫ f = b ≫ f)
                        (is_limit : limits.is_limit (limits.pullback_cone.mk a b comm)) =>
                        Eq.refl (mk comm is_limit))
                      comm is_limit)
                    (congr (Eq.refl (mk comm)) (subsingleton.elim is_limit is_limit_1)))
                P_comm Q_comm P_is_limit Q_is_limit

/-- If `f` is a monomorphism, then `(𝟙 _, 𝟙 _)`  is a kernel pair for `f`. -/
def id_of_mono {C : Type u} [category C] {X : C} {Y : C} (f : X ⟶ Y) [mono f] :
    is_kernel_pair f 𝟙 𝟙 :=
  mk sorry
    (limits.pullback_cone.is_limit_aux' (limits.pullback_cone.mk 𝟙 𝟙 sorry)
      fun (s : limits.pullback_cone f f) =>
        { val := limits.pullback_cone.snd s, property := sorry })

protected instance inhabited {C : Type u} [category C] {X : C} {Y : C} (f : X ⟶ Y) [mono f] :
    Inhabited (is_kernel_pair f 𝟙 𝟙) :=
  { default := id_of_mono f }

/--
Given a pair of morphisms `p`, `q` to `X` which factor through `f`, they factor through any kernel
pair of `f`.
-/
def lift' {C : Type u} [category C] {R : C} {X : C} {Y : C} {f : X ⟶ Y} {a : R ⟶ X} {b : R ⟶ X}
    {S : C} (k : is_kernel_pair f a b) (p : S ⟶ X) (q : S ⟶ X) (w : p ≫ f = q ≫ f) :
    Subtype fun (t : S ⟶ R) => t ≫ a = p ∧ t ≫ b = q :=
  limits.pullback_cone.is_limit.lift' (is_limit k) p q w

/--
If `(a,b)` is a kernel pair for `f₁ ≫ f₂` and `a ≫ f₁ = b ≫ f₁`, then `(a,b)` is a kernel pair for
just `f₁`.
That is, to show that `(a,b)` is a kernel pair for `f₁` it suffices to only show the square
commutes, rather than to additionally show it's a pullback.
-/
def cancel_right {C : Type u} [category C] {R : C} {X : C} {Y : C} {Z : C} {a : R ⟶ X} {b : R ⟶ X}
    {f₁ : X ⟶ Y} {f₂ : Y ⟶ Z} (comm : a ≫ f₁ = b ≫ f₁) (big_k : is_kernel_pair (f₁ ≫ f₂) a b) :
    is_kernel_pair f₁ a b :=
  mk comm
    (limits.pullback_cone.is_limit_aux' (limits.pullback_cone.mk a b comm)
      fun (s : limits.pullback_cone f₁ f₁) =>
        let s' : limits.pullback_cone (f₁ ≫ f₂) (f₁ ≫ f₂) :=
          limits.pullback_cone.mk (limits.pullback_cone.fst s) (limits.pullback_cone.snd s)
            (limits.pullback_cone.condition_assoc s f₂);
        { val := limits.is_limit.lift (is_limit big_k) s', property := sorry })

/--
If `(a,b)` is a kernel pair for `f₁ ≫ f₂` and `f₂` is mono, then `(a,b)` is a kernel pair for
just `f₁`.
The converse of `comp_of_mono`.
-/
def cancel_right_of_mono {C : Type u} [category C] {R : C} {X : C} {Y : C} {Z : C} {a : R ⟶ X}
    {b : R ⟶ X} {f₁ : X ⟶ Y} {f₂ : Y ⟶ Z} [mono f₂] (big_k : is_kernel_pair (f₁ ≫ f₂) a b) :
    is_kernel_pair f₁ a b :=
  cancel_right sorry big_k

/--
If `(a,b)` is a kernel pair for `f₁` and `f₂` is mono, then `(a,b)` is a kernel pair for `f₁ ≫ f₂`.
The converse of `cancel_right_of_mono`.
-/
def comp_of_mono {C : Type u} [category C] {R : C} {X : C} {Y : C} {Z : C} {a : R ⟶ X} {b : R ⟶ X}
    {f₁ : X ⟶ Y} {f₂ : Y ⟶ Z} [mono f₂] (small_k : is_kernel_pair f₁ a b) :
    is_kernel_pair (f₁ ≫ f₂) a b :=
  mk sorry
    (limits.pullback_cone.is_limit_aux' (limits.pullback_cone.mk a b sorry)
      fun (s : limits.pullback_cone (f₁ ≫ f₂) (f₁ ≫ f₂)) =>
        { val :=
            subtype.val
              (limits.pullback_cone.is_limit.lift' (is_limit small_k) (limits.pullback_cone.fst s)
                (limits.pullback_cone.snd s) sorry),
          property := sorry })

/--
If `(a,b)` is the kernel pair of `f`, and `f` is a coequalizer morphism for some parallel pair, then
`f` is a coequalizer morphism of `a` and `b`.
-/
def to_coequalizer {C : Type u} [category C] {R : C} {X : C} {Y : C} {f : X ⟶ Y} {a : R ⟶ X}
    {b : R ⟶ X} (k : is_kernel_pair f a b) [r : regular_epi f] :
    limits.is_colimit (limits.cofork.of_π f (comm k)) :=
  limits.cofork.is_colimit.mk (limits.cofork.of_π f (comm k))
    (fun (s : limits.cofork a b) =>
      subtype.val (limits.cofork.is_colimit.desc' regular_epi.is_colimit (limits.cofork.π s) sorry))
    sorry sorry

end Mathlib


import data.qpf.univariate.basic
import control.bifunctor

universes u
variables {F : Type u → Type u} [functor F]

namespace qpf

section box
variables (F)

/-- apply a functor to a set of values. taken from
 [Basil Fürer, Andreas Lochbihler, Joshua Schneider, Dmitriy Traytel *Quotients of Bounded Natural Functors*][fuerer-lochbihler-schneider-traytel2020]
henceforth referred to as the QBNF paper
 -/
def box {α} (A : set α) : set (F α) :=
{ x | ∀ β (f g : α → β), (∀ a ∈ A, f a = g a) → f <$> x = g <$> x }

variables {F}

/--
Alternate notion of support set based on `box`.
Taken from the QBNF paper
-/
def supp' {α} (x : F α) : set α :=
⋂ A ∈ { A : set α | x ∈ box F A}, A

/--
Alternate notion of predicate lifting based on `box`.
Taken from the QBNF paper
-/
def liftp' {α} (x : F α) (p : α → Prop) : Prop :=
∀ a ∈ supp' x, p a

end box

end qpf

namespace ex

/-- polynomial functor isomorph to `α × _` for some `α` -/
def prod.pfunctor (α : Type) : pfunctor :=
⟨ α, λ _, unit ⟩

instance {α} : qpf (prod α) :=
{ P := prod.pfunctor α,
  abs := λ β ⟨a,f⟩, (a, f ()),
  repr := λ β ⟨x,y⟩, ⟨x, λ _, y⟩,
  abs_repr := λ β ⟨x,y⟩, rfl,
  abs_map := λ β γ f ⟨a,g⟩, rfl }

/-- example relation for products -/
def foo.R (α : Type) (x y : bool × α) : Prop :=
x.1 = y.1 ∧ (x.1 → x.2 = y.2)

lemma equivalence_foo.R (α) : equivalence (foo.R α) :=
begin
  refine ⟨_,_,_⟩,
  { intro, exact ⟨rfl,λ _, rfl⟩ },
  { intros x y h, refine ⟨h.1.symm, λ _, (h.2 _).symm⟩,
    rwa h.1 },
  { rintros x y z ⟨ha,ha'⟩ ⟨hb,hb'⟩,
    refine ⟨ha.trans hb, λ hh, _⟩,
    refine (ha' hh).trans (hb' _),
    rwa ← ha }
end

/-- example of a qpf -/
def foo (α : Type) :=
quot $ foo.R α

instance {α} [inhabited α] : inhabited (foo α) := ⟨ quot.mk _ (default _) ⟩

/-- functor operation of `foo` -/
def foo.map {α β} (f : α → β) (x : foo α) : foo β :=
quot.lift_on x (λ x : bool × α, quot.mk (foo.R β) $ f <$> x)
  (λ ⟨a₀,a₁⟩ ⟨b₀,b₁⟩ h, quot.sound ⟨h.1,λ h', show f a₁ = f b₁, from congr_arg f (h.2 h')⟩)

instance : functor foo :=
{ map := @foo.map }

@[simp]
lemma foo.map_mk {α β : Type} (f : α → β) (x : bool × α) :
  (f <$> quot.mk _ x : foo β) = quot.mk _ (f <$> x) :=
by simp [(<$>),foo.map]

noncomputable instance qpf.foo : qpf foo :=
@qpf.quotient_qpf (prod bool) _ ex.prod.qpf foo _ (λ α, quot.mk _) (λ α, quot.out)
  (by simp)
  (by intros; simp)

/-- constructor for `foo` -/
def foo.mk {α} (b : bool) (x : α) : foo α := quot.mk _ (b, x)

@[simp]
lemma foo.map_mk' {α β : Type} (f : α → β) (b : bool) (x : α) :
  f <$> foo.mk b x = foo.mk b (f x) :=
by simp only [foo.mk, foo.map_mk]; refl

@[simp]
lemma foo.map_tt {α : Type} (x y : α) :
  foo.mk tt x = foo.mk tt y ↔ x = y :=
by simp [foo.mk]; split; intro h; [replace h := quot.exact _ h, rw h];
   rw relation.eqv_gen_iff_of_equivalence at h;
   [exact h.2 rfl, apply equivalence_foo.R]

/-- consequence of original definition of `supp`. If there exists more than
one value of type `α`, then the support of `foo.mk ff x` is empty -/
lemma supp_mk_ff₀ {α} (x y : α) (h : ¬ x = y) : functor.supp (foo.mk ff x) = {} :=
begin
  dsimp [functor.supp], ext z, simp, -- split; intro h,
  classical, by_cases x = z,
  { use (λ a, ¬ z = a), subst z,
    dsimp [functor.liftp],
    simp, refine ⟨foo.mk ff ⟨y,h⟩,_⟩,
    simp, apply quot.sound, simp [foo.R] },
  { use (λ a, x = a),
    dsimp [functor.liftp],
    simp [h], use foo.mk ff ⟨x,rfl⟩,
    simp }
end

/-- consequence of original definition of `supp`. If there exists only
one value of type `α`, then the support of `foo.mk ff x` contains that value -/
lemma supp_mk_ff₁ {α} (x : α) (h : ∀ z, x = z) : functor.supp (foo.mk ff x) = {x} :=
begin
  dsimp [functor.supp], ext y, simp, split; intro h',
  { apply @h' (= x), dsimp [functor.liftp],
    use foo.mk ff ⟨x,rfl⟩, refl },
  { introv hp, simp [functor.liftp] at hp,
    rcases hp with ⟨⟨z,z',hz⟩,hp⟩,
    simp at hp, convert hz,
    rw [h'], apply h },
end

/--
Such a QPF is not uniform
-/
lemma foo_not_uniform : ¬ @qpf.is_uniform foo _ qpf.foo :=
begin
  simp only [qpf.is_uniform, foo, qpf.foo, set.image_univ, not_forall, not_imp],
  existsi [bool,ff,ff,λ a : unit, tt,λ a : unit, ff], split,
  { apply quot.sound, simp [foo.R, qpf.abs, prod.qpf._match_1] },
  { simp! only [set.range, set.ext_iff],
    simp only [not_exists, false_iff, bool.forall_bool, eq_self_iff_true, exists_false, not_true,
      and_self, set.mem_set_of_eq, iff_false],
    exact λ h, h () }
end

/-- intuitive consequence of original definition of `supp`. -/
lemma supp_mk_tt {α} (x : α) : functor.supp (foo.mk tt x) = {x} :=
begin
  dsimp [functor.supp], ext y, simp, split; intro h',
  { apply @h' (= x), dsimp [functor.liftp],
    use foo.mk tt ⟨x,rfl⟩, refl },
  { introv hp, simp [functor.liftp] at hp,
    rcases hp with ⟨⟨z,z',hz⟩,hp⟩,
    simp at hp, replace hp := quot.exact _ hp,
    rw relation.eqv_gen_iff_of_equivalence (equivalence_foo.R _) at hp,
    rcases hp with ⟨⟨⟩,hp⟩, subst y,
    replace hp := hp rfl, cases hp,
    exact hz }
end

/-- simple consequence of the definition of `supp` from the QBNF paper -/
lemma supp_mk_ff' {α} (x : α) : qpf.supp' (foo.mk ff x) = {} :=
begin
  dsimp [qpf.supp'], ext, simp, dsimp [qpf.box],
  use ∅, simp [foo.mk], intros, apply quot.sound,
  dsimp [foo.R], split, refl, rintro ⟨ ⟩
end

/-- simple consequence of the definition of `supp` from the QBNF paper -/
lemma supp_mk_tt' {α} (x : α) : qpf.supp' (foo.mk tt x) = {x} :=
begin
  dsimp [qpf.supp'], ext, simp, dsimp [qpf.box], split; intro h,
  { specialize h {x} _,
    { clear h, introv hfg, simp, rw hfg, simp },
    { simp at h, assumption }, },
  { introv hfg, subst x_1, classical,
    let f : α → α ⊕ bool := λ x, if x ∈ i then sum.inl x else sum.inr tt,
    let g : α → α ⊕ bool := λ x, if x ∈ i then sum.inl x else sum.inr ff,
    specialize hfg _ f g _,
    { intros, simp [*,f,g,if_pos] },
    { simp [f,g] at hfg, split_ifs at hfg,
      assumption, cases hfg } }
end
end ex


import tactic
import data.real.basic
-- import data.set
/-
- nom des variables dans la def de limite !
- variables muettes = variables globales : bof
- calcul avec abs : abs (l'-l) /2 >0 ??
(x ≠ 0 → |x| >0)
- ne pas ajouter l'inégalité au contexte si elle y est déjà !
- 'dsimp only at h' effectue les beta-réduction : (λ x, f x) 37 = f 37
- max : def et propriétés
- utiliser specialize ??

-/

-- dEAduction tactics
import structures2      -- hypo_analysis, targets_analysis
import utils            -- no_meta_vars
import user_notations   -- notations that can be used in deaduction UI for a new object
import compute
import push_neg_once    -- pushing negation just one step

-- dEAduction definitions
import set_definitions
import real_definitions

-- class real_number_subgroup (α : Type) :=
-- (subgroup : ((α = ℕ) ∨ (α = ℤ) ∨ (α = ℚ) ∨ (α = ℝ)) )

-- lemma real_number_subgroup_nat : (nat = ℕ) ∨ (nat = ℤ) ∨ (nat = ℚ) ∨ (nat = ℝ) :=
-- begin
--   left, refl,
-- end

-- instance : real_number_subgroup nat := ⟨real_number_subgroup_nat⟩

local attribute [instance] classical.prop_decidable

/-- `l` is the limit of the sequence `a` of reals -/
definition limit (u : ℕ → ℝ) (l : ℝ) : Prop :=
∀ ε > 0, ∃ N, ∀ n ≥ N, | u n - l | < ε

definition converging_seq (u : ℕ → ℝ) : Prop :=
∃ l, limit u l

definition limit_plus_infinity (u : ℕ → ℝ) : Prop :=
∀ M:ℝ, ∃ N:ℕ, ∀ n ≥ N, u n ≥ M

definition increasing_seq (u : ℕ → ℝ) : Prop :=
∀ p q , p ≤ q → u p ≤ u q

definition bounded_above (u : ℕ → ℝ) : Prop :=
∃ M:ℝ, ∀ n, u n ≤ M

definition bounded_below (u : ℕ → ℝ) : Prop :=
∃ m:ℝ, ∀ n, u n ≥ m

definition bounded_sequence (u : ℕ → ℝ) : Prop :=
∃ M>0, ∀ n, | u n | ≤ M

definition even (n:ℕ) : Prop := ∃ n', n=2 * n'

definition limit_function (f : ℝ → ℝ) (a : ℝ) (l : ℝ) : Prop :=
∀ ε > 0, ∃ δ>0, ∀ x: ℝ, ( | x-a | < δ → | f x  - l | < ε )

definition continuous_at (f : ℝ → ℝ) (a : ℝ) : Prop :=
limit_function (λ x, f x) a (f a)

definition continuous (f: ℝ → ℝ) : Prop :=
∀ a, continuous_at f a

definition cauchy (u: ℕ → ℝ) : Prop :=
∀ ε>0, ∃ N: ℕ, ∀ p≥N, ∀ q≥N, |u p - u q | < ε

definition uniformly_continuous (f: ℝ → ℝ) : Prop :=
∀ ε>0, ∃ δ>0, ∀ x y: ℝ,
(|x - y| < δ → |f x - f y | < ε)

section course
open tactic.interactive
-- notation `|` x `|` := abs x

-----------------
-- definitions --
-----------------
namespace definitions
/- dEAduction
PrettyName
  Définitions
-/

namespace generalites
/- dEAduction
PrettyName
  Généralités
-/

/-
abs_pos : 0 < |a| ↔ a ≠ 0
abs_mul x y : |x * y| = |x| * |y|
abs_add x y : |x + y| ≤ |x| + |y|
-/

/-
Max :
def
max ≥ n et n'
1) We will be using `max` a lot in this workshop. `max A B` is
the max of `A` and `B`. `max` is a definition, not a theorem, so
that means that there will be an API associated with it, i.e.
a list of little theorems which make `max` possible to use.
We just saw the two important theorems which we'll be using:
`le_max_left A B : A ≤ max A B` and
`le_max-right A B : B ≤ max A B`.
There are other cool functions in the `max` API, for example
`max_le : A ≤ C → B ≤ C → max A B ≤ C`. The easiest way to
find your way around the `max` API is to *guess* what the names
of the theorems are! For example what do you think
`max A B < C ↔ A < C ∧ B < C` is called?
-/

----------------------------------
namespace maximum
-- The name RealSubGroup will be replaced by ℝ in d∃∀duction,
-- but allows to treat the cases of integers or rationals.
variables {RealSubGroup : Type} [decidable_linear_order RealSubGroup]

lemma theorem.ppe_max_gauche :
∀ a b : RealSubGroup, a ≤ max a b :=
begin
  -- targets_analysis,
  intros a b,
  -- hypo_analysis,
  -- norm_num, tautology,
  exact le_max_left a b,
  -- todo
end

lemma theorem.ppe_max_droite :
∀ a b : RealSubGroup,  b ≤ max a b :=
begin
  have H := @theorem.ppe_max_gauche,
  intros a b, norm_num, tautology,
  -- exact le_max_right a b,
end

lemma theorem.max_ppe
(a b c : RealSubGroup) (Ha: a ≤ c) (Hb: b ≤ c) :
max a b ≤ c :=
begin
  norm_num, tautology,
  -- exact max_le Ha Hb,
end

lemma theorem.max_pp
(a b c : RealSubGroup) (Ha: a < c) (Hb: b < c) :
max a b < c :=
begin
  norm_num, tautology,
  -- exact max_lt Ha Hb,
end

end maximum

namespace valeur_absolue
variables {RealSubGroup : Type} [decidable_linear_ordered_comm_ring RealSubGroup]
-- [has_zero RealSubGroup]

-- A modifier : faire une classe "nombres" ?
lemma theorem.valeur_absolue :
∀ x : RealSubGroup,
((0:RealSubGroup) ≤ x) → (abs x = x) and ((x ≤ 0) → (abs x = -x)) :=
begin
  intro x, split, exact abs_of_nonneg, exact abs_of_nonpos,
end

lemma theorem.majoration_valeur_absolue :
∀ x r : RealSubGroup, (abs x < r) ↔ ((-r < x) ∧ (x < r))
:=
/- dEAduction
PrettyName
  Majoration d'une valeur absolue
-/
begin
  intros x r,
  exact abs_lt
end

lemma theorem.inegalite_triangulaire :
∀ x y : RealSubGroup, |x + y| ≤ |x| + |y|
:=
/- dEAduction
PrettyName
  Inégalité triangulaire
-/
begin
  intros x y, exact abs_add x y
end

lemma theorem.valeur_absolue_produit :
∀ x y : RealSubGroup,  |x * y| = |x| * |y|
:=
/- dEAduction
PrettyName
  Valeur absolue d'un produit
-/
begin
  intros x y, exact abs_mul x y
end

end valeur_absolue

end generalites
namespace suites

------------------------------
-- Définitions de la limite --
------------------------------

lemma definition.limit
{u : ℕ → ℝ} {l : ℝ} :
(limit u l) ↔
∀ ε > 0, ∃ N, ∀ n ≥ N, | u n - l | < ε
:=
/- dEAduction
PrettyName
  Limite d'une suite
ImplicitUse
  True
-/
begin
  refl
end

lemma definition.converging_seq
{u : ℕ → ℝ} :
(converging_seq u) ↔
∃ l, limit u l
:=
/- dEAduction
PrettyName
  Suite convergente
ImplicitUse
  True
-/
begin
  refl
end

lemma definition.limit_plus_infinity
{u : ℕ → ℝ} :
(limit_plus_infinity u) ↔ ∀ M:ℝ, ∃ N:ℕ, ∀ n ≥ N, u n ≥ M :=
/- dEAduction
PrettyName
  Limite infinie d'une suite
ImplicitUse
  True
-/
begin
  refl
end

lemma definition.increasing_seq
{u : ℕ → ℝ} :
(increasing_seq u) ↔
∀ p q, p ≤ q → u p ≤ u q
:=
/- dEAduction
PrettyName
  Suite croissante
ImplicitUse
  True
-/
begin
  refl
end

lemma definition.bounded_above
{u : ℕ → ℝ} :
(bounded_above u) ↔
∃ M:ℝ, ∀ n,  u n ≤ M
:=
/- dEAduction
PrettyName
  Suite majorée
ImplicitUse
  True
-/
begin
  refl
end

-- lemma definition.bounded_below
-- {u : ℕ → ℝ} :
-- (bounded_below_sequence u) ↔
-- ∃ M:ℝ, ∀ n,  u n ≥ M
-- :=
-- /- dEAduction
-- PrettyName
--   Suite minorée
-- ImplicitUse
--   True
-- -/
-- begin
--   refl
-- end

lemma definition.bounded
{u : ℕ → ℝ} :
(bounded_sequence u) ↔
∃ M>0, ∀ n, | u n | ≤ M
:=
/- dEAduction
PrettyName
  Suite bornée
ImplicitUse
  True
-/
begin
  refl
end

end suites

namespace fonctions

lemma definition.composition {X Y Z: Type} {f: X → Y} {g:Y → Z} {x:X}:
set.composition g f x = g (f x)
:=
begin
    todo,
end

lemma definition.limit_function (f : ℝ → ℝ) (a : ℝ) (l : ℝ) :
limit_function f a l ↔
( ∀ ε > 0, ∃ δ>0, ∀ x: ℝ, ( | x-a | < δ → | f x  - l | < ε ) ):=
/- dEAduction
PrettyName
  Limite d'une fonction
ImplicitUse
  True
-/
begin
  refl
end

lemma definition.continuous_at (f : ℝ → ℝ) (a : ℝ) :
(continuous_at f a) ↔ (limit_function f a (f a)) :=
/- dEAduction
PrettyName
  Continuité en un point
-/
begin
  refl
end

lemma definition.continuous (f: ℝ → ℝ) :
(continuous f) ↔ ∀ a, continuous_at f a :=
/- dEAduction
PrettyName
  Continuité
ImplicitUse
  True
-/
begin
  refl
end

end fonctions

end definitions

-----------------
--  exercices  --
-----------------
namespace exercices_suites_I
/- dEAduction
PrettyName
  Exercices sur les suites I
-/

-- open definitions

-- --------------------------------------------------
-- namespace exemples

-- end exemples

lemma exercise.limit_constante
(u : ℕ → ℝ) (c : ℝ) (H : ∀ n, u n = c) :
converging_seq u :=
/- dEAduction
PrettyName
  La limite d'une suite constante !
Description
  Dans ce premier exercice,
  il s'agit de démontrer, dans un cas très simple,
  l'existence d'une limite.
-/
begin
--   rw definition.limit,
--   intros ε Hε,
--   use 0,
--   intros n H1,
--   rw H,
-- `[ solve1 {norm_num at * }, trace "EFFECTIVE CODE n°4.0"] <|> `[ `[ norm_num at *, trace "EFFECTIVE CODE n°5.0"] <|> `[ skip, trace "EFFECTIVE CODE n°5.1"], compute_n 10, trace "EFFECTIVE CODE n°4.1"],
  todo,
end

lemma exercise.croissante_non_majoree
(u: ℕ → ℝ) (H1: increasing_seq u) (H2: not (bounded_above u)) :
limit_plus_infinity u :=
/- dEAduction
PrettyName
  Une suite croissante non majorée tend vers plus l'infini
Description
  Dans ce deuxième exercice,
  il s'agit à nouveau de démontrer une limite, mais infinie.
-/
begin
  todo,
end

lemma exercise.limite_positive
(u : ℕ → ℝ) (l : ℝ) (H : limit u l)
(H' : l >0) :
∃ N, ∀ n ≥ N, u n > 0
:=
/- dEAduction
PrettyName
  Suite dont la limite est strictement positive
Description
  Dans ce troisième exercice,
  il s'agit d'utiliser une hypothèse de limite.
-/
begin
  -- have W := exercise.limit_constante,
  -- hypo_analysis,
  todo,
end

lemma exercise.limite_inegalites
(u v: ℕ → ℝ) (l l' : ℝ) (H : limit u l)
(H' : limit v l'):
(∀n, u n ≤ v n ) → l ≤ l'
:=
/- dEAduction
PrettyName
  Passage à la limite dans une inégalité (*)
Description
  Comment démarrer ??
  Comment avoir un epsilon pertinent auquel appliquer nos
  définitions de limites ?...
-/
begin
  todo,
  -- contrapose H'' with H1,
  -- push_neg,
  -- push_neg at H1,
  -- let e := (l-l')/2, have H2 : e = (l-l')/2, refl, no_meta_vars,
  -- rw limit at H H',
  -- have H3: (e:ℝ) > 0, rotate, have H4 := H e H3, rotate 1, rotate, rotate,
  -- solve1 {norm_num at *, apply mul_pos, linarith only [H1], apply inv_pos.mpr, linarith},
  -- have H5 := H' e H3,
  -- cases H4 with n H6,
  -- cases H5 with n' H7,
  -- let n'' := max n n', have H8 : n'' = max n n', refl, no_meta_vars,
  -- have H9: (n'':ℕ) ≥ n, rotate, have H10 := H6 n'' H9, rotate 1, solve1 {norm_num at *, tautology }, rotate,
  -- have H11: (n'':ℕ) ≥ n', rotate, have H12 := H7 n'' H11, rotate 1, solve1 {norm_num at *, tautology }, rotate,
  -- use n'',
  -- rw generalites.valeur_absolue.theorem.majoration_valeur_absolue at H10,
  -- cases H10 with H14 H15,
  -- rw generalites.valeur_absolue.theorem.majoration_valeur_absolue at H12,
  -- cases H12 with H17 H18,
  -- linarith only [H18, H14, H2],
end

end exercices_suites_I

namespace exercices_suites_II
/- dEAduction
PrettyName
  Exercices sur les suites II
-/

lemma exercise.couper_epsilon_en_deux
(u : ℕ → ℝ) (l : ℝ) :
(limit u l) ↔
∀ ε > 0, ∃ N, ∀ n ≥ N, | u n - l | < 2*ε
:=
/- dEAduction
PrettyName
  Couper les epsilons en deux
Description
  Nous avons maintenant une limite dans les hypothèses,
  et une limite dans la conclusion !
-/
begin
  todo,
end

lemma exercise.couper_epsilon_en_100
(u : ℕ → ℝ) (l : ℝ) :
(limit u l) ↔
∀ ε > 0, ∃ N, ∀ n ≥ N, | u n - l | < 100*ε
:=
/- dEAduction
PrettyName
  Couper les epsilons en cent !
Description
  Simple variante du précédent,
  pour voir si vous avez compris...
-/
begin
  todo,
end

lemma exercise.limite_somme
(u v: ℕ → ℝ) (l l' : ℝ) (H : limit u l)
(H' : limit v l') :
limit (λn, u n + v n) (l+l')
:=
/- dEAduction
PrettyName
  Limite d'une somme
Description
  Aide : il peut être judicieux d'utiliser le résultat
  d'un exercice précédent...
-/
begin
--   rw definitions.definition.limit,
-- rw definitions.definition.limit at H H',
-- intro ε, intro H1,
-- have H2 := H _ H1,
-- have H3 := H' _ H1,
-- cases H2 with n H4,
-- cases H3 with n' H5,
-- let x2 := max n n', have H7 : x2 = max n n', refl,
-- have H9 := @definitions.maximum.theorem.ppe_max_gauche,
-- have H10 := H9 n n',
-- -- norm_num at H10,
-- rw H7 at H10,
  todo,
  -- rw limit,
  -- intro ε, intro H1,
  -- rw limit at H H',
  -- have H2: ((ε/2):ℝ) > 0, rotate, have H3 := H (ε/2) H2, rotate 1, solve1 {linarith only [H1] }, rotate,
  -- have H4: ((ε/2):ℝ) > 0, rotate, have H5 := H' (ε/2) H4, rotate 1, solve1 {assumption}, rotate,
  -- cases H3 with n H6,
  -- cases H5 with n' H7,
  -- use max n n',
  -- intro n'', intro H8,
  -- have H9: (n'':ℕ) ≥ n, rotate, have H10 := H6 n'' H9, rotate 1, solve1 {norm_num at *, tautology }, rotate,
  -- have H11: (n'':ℕ) ≥ n', rotate, have H12 := H7 n'' H11, rotate 1, solve1 {norm_num at *, tautology }, rotate,

  -- rw generalites.valeur_absolue.theorem.majoration_valeur_absolue at H10 H12,
  -- rw generalites.valeur_absolue.theorem.majoration_valeur_absolue,
  -- cases H12 with Ha Hb, cases H10 with Hc Hd,
  -- split,
  -- linarith only [Ha, Hc],
  -- linarith only [Hb, Hc, Hd],
end

lemma exercise.limite_unique
(u : ℕ → ℝ) (l : ℝ)(l' : ℝ) (H : limit u l) (H' : limit u l') :
l = l'
:=
/- dEAduction
PrettyName
  (*) Unicité de la limite
-/
begin
  -- by_contradiction,
  -- wlog Hll': l < l',
  -- -- exact lt_or_gt_of_ne a,
  -- rotate,
  -- set ε := (l'-l)/2 with Heps,
  -- have Hpos: ε >0, rotate, -- by compute1,
  -- specialize H ε Hpos, rotate 2,
  -- rotate,

  -- cases H with N1,
  -- specialize H' ε Hpos, cases H' with N2,
  -- set n := max N1 N2 with Hn,
  -- have HnsuppN1: n ≥ N1, from le_max_left N1 N2,
  -- have ineq1 := H_h n HnsuppN1,
  -- have HnsuppN2: n ≥ N2, from le_max_right N1 N2,
  -- have ineq1 := H'_h n HnsuppN2,

  -- -- sorry,
  -- todo,
  -- todo,
  todo,
end

lemma exercise.gendarmes
(u v w  : ℕ → ℝ) (l : ℝ)
(H : limit u l) (H' : limit w l)
(H'' : ∀n, (((u n) ≤ v n) and ((v n) ≤ w n))) :
limit v l
:=
/- dEAduction
PrettyName
  (**) Théorème des gendarmes
-/
begin
  todo,
end

lemma exercise.borne_fois_zero
(u v: ℕ → ℝ) (H : limit u 0)
(H' : bounded_sequence v) :
limit (λn, (u n) * (v n)) 0
:=
/- dEAduction
PrettyName
  (**) Limite d'un produit (cas particulier)
-/
begin
  todo,
end

/-
A essayer : appliquer somme, CV implique borné, borné x 0
-/
lemma limite_produit
(u u': ℕ → ℝ) (l l' : ℝ) (H : limit u l)
(H' : limit u' l') :
limit (λn, (u n) * (u' n)) (l*l')
:=
begin
  todo,
end

end exercices_suites_II

namespace exercices_fonctions
/- dEAduction
PrettyName
  Exercices sur les fonctions
-/

open definitions

open set

lemma exercise.limite_positive
(f: ℝ → ℝ)
(H0: continuous f) (H1: f(0) = 1):
∃ δ>(0:ℝ), ∀ x, |x| < δ → f(x) >0 :=
/- dEAduction
PrettyName
  Limite positive
Description
  Deux limites en hypothèse, une en conclusion...
-/
begin
  todo,
  -- have H2 := (H0 0) 1 _,
  -- rcases H2 with ⟨δ, H3, H4⟩,
  -- norm_num at H4,
  -- rw H1 at H4,
  -- use δ, split, rotate,
  -- intros x x_del,
  -- have H5 := H4 _ x_del,
  -- rw generalites.valeur_absolue.theorem.majoration_valeur_absolue at *,
  -- cases H5 with H5a H5b,
  -- linarith only [H5a], linarith, assumption,
end

lemma exercise.composition_limite_fonction
(f: ℝ → ℝ) (g: ℝ → ℝ) (a b c : ℝ)
(H0: limit_function (λ x, f x) a b)
(H1: limit_function (λ y, g y) b c):
limit_function (λ x, g ( f ( x)) ) a c :=
/- dEAduction
PrettyName
  Limite et composition
Description
  Deux limites en hypothèse, une en conclusion...
-/
begin
  todo,
end

lemma exercise.composition_continuite (f: ℝ → ℝ) (g: ℝ → ℝ)
(H: continuous f) (H': continuous g):
continuous (composition g f) :=
/- dEAduction
PrettyName
  Continuité et composition
-/
begin
  todo,
end

lemma exercise.image_convergente (u: ℕ → ℝ) (l : ℝ) (f: ℝ → ℝ)
(H: limit u l) (H': continuous f):
limit (λ n, f (u n)) (f l) :=
/- dEAduction
PrettyName
  Image d'une suite convergente
Description
  Deux limites en hypothèse, une en conclusion...
-/
begin
  todo,
end

end exercices_fonctions

namespace suites_de_Cauchy
/- dEAduction
PrettyName
  Suites de Cauchy
-/

-- open definitions

lemma definition.suite_de_cauchy
(u: ℕ → ℝ) :
cauchy u ↔ ∀ ε>0, ∃ N: ℕ, ∀ p≥N, ∀ q≥N, |u p - u q | < ε
:=
/- dEAduction
PrettyName
  Suites de Cauchy
ImplicitUse
  True
-/
begin
  refl,
end

-- definition increasing (k: ℕ → ℕ) : Prop :=
-- ∀ n, (k n) > (k (n+1))

-- definition limit_value (u: ℕ → ℝ) (a: ℝ) : Prop :=
-- ∃ k: ℕ → ℕ, increasing k ∧ limit (λ n, (u (k n))) a

-- lemma definition.increasing (k: ℕ → ℕ): (increasing k) ↔
-- ∀ n, (k n) > (k (n+1)) :=
-- begin
--   refl,
-- end

-- lemma theorem.increasing_limit (k: ℕ → ℕ) (H: increasing k):
-- limit_plus_infinity (coe k) :=
-- begin
--   todo,
-- end

-- lemma definition.limit_value (u: ℕ → ℝ) (a: ℝ) :
-- limit_value u a ↔
-- ∃ k: ℕ → ℕ, increasing k ∧ limit (λ n, (u (k n))) a :=
-- begin
--   refl,
-- end

-- lemma exercise.limit_limit_value
--  (u: ℕ → ℝ) (a b: ℝ) (H1: limit u a) (H2: limit_value u b) :
--  b = a :=
-- /- dEAduction
-- PrettyName
--   Une suite convergence a une unique valeur d'adhérence
-- -/
-- begin
--   todo,
-- end

lemma exercise.convergente_implique_cauchy (u: ℕ → ℝ):
converging_seq u → cauchy u :=
/- dEAduction
PrettyName
  Une suite convergente est de Cauchy
-/
begin
  todo,
  -- intro H,
  -- rw converging_seq at H, cases H with x H,
  -- have H := limit (λ n, (u n)^2)  (x^2)
end

-- lemma theorem.cauchy_bounded (u: ℕ → ℝ):
-- cauchy u → bounded_sequence u :=
-- /- dEAduction
-- PrettyName
--   Une suite de Cauchy est bornée
-- -/
-- begin
--   todo,
-- end

-- lemma theorem.bounded_limit_value (u: ℕ → ℝ):
-- bounded_sequence u → ∃ a, limit_value u a :=
-- /- dEAduction
-- PrettyName
--   Une suite bornée a une valeur d'adhérence
-- -/
-- begin
--   todo,
-- end

-- lemma exercise.limit_value_cauchy_converge (u: ℕ → ℝ)
-- (H1: cauchy u) (H2: ∃ a, limit_value u a) :
-- converging_seq u  :=
-- /- dEAduction
-- PrettyName
--   Une suite de Cauchy ayant une valeur d'adhérence converge
-- -/
-- begin
--   todo,
-- end

-- lemma exercise.cauchy_converge (u: ℕ → ℝ)
-- (H1: cauchy u):
-- converging_seq u  :=
-- /- dEAduction
-- PrettyName
--   Toute suite de Cauchy converge
-- -/
-- begin
--   todo,
-- end

end suites_de_Cauchy

namespace continuite_uniforme
/- dEAduction
PrettyName
  Continuité uniforme
-/

lemma definition.uniformly_continuous
(f: ℝ → ℝ) : uniformly_continuous f ↔
∀ ε>0, ∃ δ>0, ∀ x y: ℝ,
(|x - y| < δ → |f x - f y | < ε)
:=
/- dEAduction
PrettyName
  Continuité uniforme
ImplicitUse
  True
-/
begin
  refl,
end

lemma exercise.continue_de_uniformement_continue
(f: ℝ → ℝ) (H0: uniformly_continuous f):
continuous f :=
/- dEAduction
PrettyName
  Uniformément continu implique continu
-/
begin
  todo,
end

lemma exercise.cauchy_uniformement_continue
(u: ℕ → ℝ) (f: ℝ → ℝ)
(H0: cauchy u) (H1: uniformly_continuous f):
cauchy (λ n:ℕ, f (u n))
:=
/- dEAduction
PrettyName
  Image d'une suite de Cauchy
-/
begin
  todo,
end

-- TODO: cauchy => bornée, bornée => valeur d'adh,
-- Cauchy + va => cv

end continuite_uniforme

-- namespace DL
-- /- dEAduction
-- PrettyName
--   Développements limités
-- -/

-- definition DL_order_0 (f: ℝ → ℝ) : Prop :=
-- ∃ (φ : ℝ → ℝ), (limit_function φ 0 0) and
-- (∀ h, f h = f 0 + φ h)

-- definition DL_order_1 (f: ℝ → ℝ) (a : ℝ) : Prop :=
-- ∃ (φ : ℝ → ℝ), (limit_function φ 0 0) and
-- (∀ h, f h = f 0 + a * h + (φ h) * h)

-- lemma definition.DL_order_0
-- (f: ℝ → ℝ) (a : ℝ):
-- (DL_order_0 f) ↔ (∃ (φ : ℝ → ℝ), (limit_function φ 0 0) and
-- (∀ h, f h = f 0 + φ h))
-- :=
-- begin
--   todo
-- end

-- example
-- (f: ℝ → ℝ):
-- (DL_order_0 f) ↔ ∃ l, (limit_function f 0 l) :=
-- begin
--   todo
-- end
-- end DL

/-
On peut multiplier les variantes : si une fonction a une
limite >0 en un point, elle est >0 au voisinage.
Si lim f < lim g alors f < g au voisinage.

Signe à partir d'un DL !

-/

end course


/-
Copyright © 2018 François G. Dorais. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
-/

import .basic .cons .append

namespace tup
variable {α : Type*}

@[reducible]
definition bar (f : ℕ → α) (n : ℕ) : fin n → α
| ⟨i,_⟩ := f i

@[simp]
lemma bar_val (f : ℕ → α) {n : ℕ} :
∀ i, (bar f n)[i] = f i.val
| ⟨_,_⟩ := rfl

lemma take_bar (f : ℕ → α) {m n : ℕ} (h : m ≤ n) :
take h (bar f n) = bar f m :=
tup.ext (λ _, by simp)

definition extend {n : ℕ} (xs : α ^ n) (x : α) (i : ℕ) : α :=
if h : i < n then xs[⟨i,h⟩] else x

lemma extend_of_lt {n : ℕ} {xs : α ^ n} {x : α} {i : ℕ} (h : i < n) :
extend xs x i = xs[⟨i,h⟩] := dif_pos h

lemma extend_of_ge {n : ℕ} {xs : α ^ n} {x : α} {i : ℕ} (h : i ≥ n) :
extend xs x i = x := dif_neg (not_lt_of_ge h)

lemma bar_extend {n : ℕ} {xs : α ^ n} {x : α} :
bar (extend xs x) n = xs :=
ext (λ ⟨i,h⟩, extend_of_lt h)

end tup