/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies

! This file was ported from Lean 3 source module order.category.HeytAlg
! leanprover-community/mathlib commit e8ac6315bcfcbaf2d19a046719c3b553206dac75
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Order.Category.BddDistLat
import Mathbin.Order.Heyting.Hom

/-!
# The category of Heyting algebras

This file defines `HeytAlg`, the category of Heyting algebras.
-/

universe u

open CategoryTheory Opposite Order

/-- The category of Heyting algebras. -/
def HeytAlg :=
  Bundled HeytingAlgebra
#align HeytAlg HeytAlg

namespace HeytAlg

instance : CoeSort HeytAlg (Type _) :=
  Bundled.hasCoeToSort

instance (X : HeytAlg) : HeytingAlgebra X :=
  X.str

/-- Construct a bundled `HeytAlg` from a `heyting_algebra`. -/
def of (α : Type _) [HeytingAlgebra α] : HeytAlg :=
  Bundled.of α
#align HeytAlg.of HeytAlg.of

@[simp]
theorem coe_of (α : Type _) [HeytingAlgebra α] : ↥(of α) = α :=
  rfl
#align HeytAlg.coe_of HeytAlg.coe_of

instance : Inhabited HeytAlg :=
  ⟨of PUnit⟩

instance bundledHom : BundledHom HeytingHom
    where
  toFun α β [HeytingAlgebra α] [HeytingAlgebra β] := (coeFn : HeytingHom α β → α → β)
  id := HeytingHom.id
  comp := @HeytingHom.comp
  hom_ext α β [HeytingAlgebra α] [HeytingAlgebra β] := FunLike.coe_injective
#align HeytAlg.bundled_hom HeytAlg.bundledHom

deriving instance LargeCategory, ConcreteCategory for HeytAlg

@[simps]
instance hasForgetToLat : HasForget₂ HeytAlg BddDistLat
    where forget₂ :=
    { obj := fun X => BddDistLat.of X
      map := fun X Y f => (f : BoundedLatticeHom X Y) }
#align HeytAlg.has_forget_to_Lat HeytAlg.hasForgetToLat

/-- Constructs an isomorphism of Heyting algebras from an order isomorphism between them. -/
@[simps]
def Iso.mk {α β : HeytAlg.{u}} (e : α ≃o β) : α ≅ β
    where
  Hom := e
  inv := e.symm
  hom_inv_id' := by
    ext
    exact e.symm_apply_apply _
  inv_hom_id' := by
    ext
    exact e.apply_symm_apply _
#align HeytAlg.iso.mk HeytAlg.Iso.mk

end HeytAlg


import algebra.homology.exact
import for_mathlib.abelian_category
import for_mathlib.exact_seq2
.

noncomputable theory

open category_theory category_theory.limits
open opposite

-- move me
namespace category_theory

variables {𝓐 : Type*} [category 𝓐] [abelian 𝓐]

lemma exact_seq.is_iso_of_zero_of_zero {A B C D : 𝓐} {f : A ⟶ B} {g : B ⟶ C} {h : C ⟶ D}
  {L : list (arrow 𝓐)} (H : exact_seq 𝓐 (f :: g :: h :: L)) (hf : f = 0) (hh : h = 0) :
  is_iso g :=
begin
  subst f, subst h,
  have : mono g, { rw [H.pair.mono_iff_eq_zero], },
  haveI : epi g, { rw [(H.drop 1).pair.epi_iff_eq_zero] },
  exact is_iso_of_mono_of_epi g,
end

lemma exact.homology_is_zero {X Y Z : 𝓐} (f : X ⟶ Y) (g : Y ⟶ Z) (hfg : exact f g) :
  is_zero (homology f g hfg.w) :=
begin
  rw preadditive.exact_iff_homology_zero at hfg,
  rcases hfg with ⟨w, ⟨e⟩⟩,
  exact is_zero_of_iso_of_zero (is_zero_zero _) e.symm,
end

lemma exact_of_homology_is_zero {X Y Z : 𝓐} {f : X ⟶ Y} {g : Y ⟶ Z} {w : f ≫ g = 0}
  (H : is_zero (homology f g w)) :
  exact f g :=
begin
  rw preadditive.exact_iff_homology_zero,
  refine ⟨w, ⟨_⟩⟩,
  exact H.iso_zero
end

namespace limits
namespace is_zero

lemma exact {X Y Z : 𝓐} (hY : is_zero Y)
  (f : X ⟶ Y) (g : Y ⟶ Z) : exact f g :=
by simp only [abelian.exact_iff, hY.eq_of_tgt f 0, hY.eq_of_tgt (limits.kernel.ι g) 0,
    limits.zero_comp, eq_self_iff_true, and_true]

lemma homology_is_zero {X Y Z : 𝓐} (hY : is_zero Y)
  (f : X ⟶ Y) (g : Y ⟶ Z) (w : f ≫ g = 0) :
  is_zero (homology f g w) :=
exact.homology_is_zero f g $ hY.exact f g

lemma is_iso {X Y : 𝓐} (hX : is_zero X) (hY : is_zero Y) (f : X ⟶ Y) :
  is_iso f :=
{ out := ⟨0, hX.eq_of_src _ _, hY.eq_of_tgt _ _⟩ }

lemma op {X : 𝓐} (h : is_zero X) : is_zero (op X) :=
begin
  rw [is_zero_iff_id_eq_zero] at h ⊢,
  rw [← op_id, h, op_zero]
end

lemma unop {X : 𝓐ᵒᵖ} (h : is_zero X) : is_zero (unop X) :=
begin
  rw [is_zero_iff_id_eq_zero] at h ⊢,
  rw [← unop_id, h, unop_zero]
end

end is_zero

@[simp] lemma is_zero_op {X : 𝓐} : is_zero (op X) ↔ is_zero X := ⟨is_zero.unop, is_zero.op⟩
@[simp] lemma is_zero_unop {X : 𝓐ᵒᵖ} : is_zero (unop X) ↔ is_zero X := ⟨is_zero.op, is_zero.unop⟩

end limits

end category_theory


/-
Copyright (c) 2020 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin
-/
import order.antisymmetrization
import order.category.Preorder

/-!
# Category of partial orders

This defines `PartialOrder`, the category of partial orders with monotone maps.
-/

open category_theory

universe u

/-- The category of partially ordered types. -/
def PartialOrder := bundled partial_order

namespace PartialOrder

instance : bundled_hom.parent_projection @partial_order.to_preorder := ⟨⟩

attribute [derive [large_category, concrete_category]] PartialOrder

instance : has_coe_to_sort PartialOrder Type* := bundled.has_coe_to_sort

/-- Construct a bundled PartialOrder from the underlying type and typeclass. -/
def of (α : Type*) [partial_order α] : PartialOrder := bundled.of α

@[simp] lemma coe_of (α : Type*) [partial_order α] : ↥(of α) = α := rfl

instance : inhabited PartialOrder := ⟨of punit⟩

instance (α : PartialOrder) : partial_order α := α.str

instance has_forget_to_Preorder : has_forget₂ PartialOrder Preorder := bundled_hom.forget₂ _ _

/-- Constructs an equivalence between partial orders from an order isomorphism between them. -/
@[simps] def iso.mk {α β : PartialOrder.{u}} (e : α ≃o β) : α ≅ β :=
{ hom := e,
  inv := e.symm,
  hom_inv_id' := by { ext, exact e.symm_apply_apply x },
  inv_hom_id' := by { ext, exact e.apply_symm_apply x } }

/-- `order_dual` as a functor. -/
@[simps] def dual : PartialOrder ⥤ PartialOrder :=
{ obj := λ X, of (order_dual X), map := λ X Y, order_hom.dual }

/-- The equivalence between `PartialOrder` and itself induced by `order_dual` both ways. -/
@[simps functor inverse] def dual_equiv : PartialOrder ≌ PartialOrder :=
equivalence.mk dual dual
  (nat_iso.of_components (λ X, iso.mk $ order_iso.dual_dual X) $ λ X Y f, rfl)
  (nat_iso.of_components (λ X, iso.mk $ order_iso.dual_dual X) $ λ X Y f, rfl)

end PartialOrder

lemma PartialOrder_dual_comp_forget_to_Preorder :
  PartialOrder.dual ⋙ forget₂ PartialOrder Preorder =
    forget₂ PartialOrder Preorder ⋙ Preorder.dual := rfl

/-- `antisymmetrization` as a functor. It is the free functor. -/
def Preorder_to_PartialOrder : Preorder.{u} ⥤ PartialOrder :=
{ obj := λ X, PartialOrder.of (antisymmetrization X (≤)),
  map := λ X Y f, f.antisymmetrization,
  map_id' := λ X,
    by { ext, exact quotient.induction_on' x (λ x, quotient.map'_mk' _ (λ a b, id) _) },
  map_comp' := λ X Y Z f g,
    by { ext, exact quotient.induction_on' x (λ x, order_hom.antisymmetrization_apply_mk _ _) } }

/-- `Preorder_to_PartialOrder` is left adjoint to the forgetful functor, meaning it is the free
functor from `Preorder` to `PartialOrder`. -/
def Preorder_to_PartialOrder_forget_adjunction :
  Preorder_to_PartialOrder.{u} ⊣ forget₂ PartialOrder Preorder :=
adjunction.mk_of_hom_equiv
  { hom_equiv := λ X Y, { to_fun := λ f,
      ⟨f ∘ to_antisymmetrization (≤), f.mono.comp to_antisymmetrization_mono⟩,
    inv_fun := λ f, ⟨λ a, quotient.lift_on' a f $ λ a b h, (antisymm_rel.image h f.mono).eq, λ a b,
      quotient.induction_on₂' a b $ λ a b h, f.mono h⟩,
    left_inv := λ f, order_hom.ext _ _ $ funext $ λ x, quotient.induction_on' x $ λ x, rfl,
    right_inv := λ f, order_hom.ext _ _ $ funext $ λ x, rfl },
  hom_equiv_naturality_left_symm' := λ X Y Z f g,
    order_hom.ext _ _ $ funext $ λ x, quotient.induction_on' x $ λ x, rfl,
  hom_equiv_naturality_right' := λ X Y Z f g, order_hom.ext _ _ $ funext $ λ x, rfl }

/-- `Preorder_to_PartialOrder` and `order_dual` commute. -/
@[simps] def Preorder_to_PartialOrder_comp_to_dual_iso_to_dual_comp_Preorder_to_PartialOrder :
 (Preorder_to_PartialOrder.{u} ⋙ PartialOrder.dual) ≅
    (Preorder.dual ⋙ Preorder_to_PartialOrder) :=
nat_iso.of_components (λ X, PartialOrder.iso.mk $ order_iso.dual_antisymmetrization _) $
  λ X Y f, order_hom.ext _ _ $ funext $ λ x, quotient.induction_on' x $ λ x, rfl


/-
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.homology.homology

/-!
# Chain complexes supported in a single degree

We define `single V j c : V ⥤ homological_complex V c`,
which constructs complexes in `V` of shape `c`, supported in degree `j`.

Similarly `single₀ V : V ⥤ chain_complex V ℕ` is the special case for
`ℕ`-indexed chain complexes, with the object supported in degree `0`,
but with better definitional properties.

In `to_single₀_equiv` we characterize chain maps to a `ℕ`-indexed complex concentrated in degree 0;
they are equivalent to `{ f : C.X 0 ⟶ X // C.d 1 0 ≫ f = 0 }`.
(This is useful translating between a projective resolution and
an augmented exact complex of projectives.)
-/

open category_theory
open category_theory.limits

universes v u

variables (V : Type u) [category.{v} V] [has_zero_morphisms V] [has_zero_object V]

namespace homological_complex
variables {ι : Type*} [decidable_eq ι] (c : complex_shape ι)

local attribute [instance] has_zero_object.has_zero

/--
The functor `V ⥤ homological_complex V c` creating a chain complex supported in a single degree.

See also `chain_complex.single₀ : V ⥤ chain_complex V ℕ`,
which has better definitional properties,
if you are working with `ℕ`-indexed complexes.
-/
@[simps]
def single (j : ι) : V ⥤ homological_complex V c :=
{ obj := λ A,
  { X := λ i, if i = j then A else 0,
    d := λ i j, 0, },
  map := λ A B f,
  { f := λ i, if h : i = j then
      eq_to_hom (by { dsimp, rw if_pos h, }) ≫ f ≫ eq_to_hom (by { dsimp, rw if_pos h, })
    else
      0, },
  map_id' := λ A, begin
    ext,
    dsimp,
    split_ifs with h,
    { subst h, simp, },
    { rw if_neg h, simp, },
  end,
  map_comp' := λ A B C f g, begin
    ext,
    dsimp,
    split_ifs with h,
    { subst h, simp, },
    { simp, },
  end, }.

/--
The object in degree `j` of `(single V c h).obj A` is just `A`.
-/
@[simps]
def single_obj_X_self (j : ι) (A : V) : ((single V c j).obj A).X j ≅ A :=
eq_to_iso (by simp)

@[simp]
lemma single_map_f_self (j : ι) {A B : V} (f : A ⟶ B) :
  ((single V c j).map f).f j =
    (single_obj_X_self V c j A).hom ≫ f ≫ (single_obj_X_self V c j B).inv :=
by { simp, refl, }

instance (j : ι) : faithful (single V c j) :=
{ map_injective' := λ X Y f g w, begin
    have := congr_hom w j,
    dsimp at this,
    simp only [dif_pos] at this,
    rw [←is_iso.inv_comp_eq, inv_eq_to_hom, eq_to_hom_trans_assoc, eq_to_hom_refl, category.id_comp,
      ←is_iso.comp_inv_eq, category.assoc, inv_eq_to_hom, eq_to_hom_trans, eq_to_hom_refl,
      category.comp_id] at this,
    exact this,
  end, }

instance (j : ι) : full (single V c j) :=
{ preimage := λ X Y f, eq_to_hom (by simp) ≫ f.f j ≫ eq_to_hom (by simp),
  witness' := λ X Y f, begin
    ext i,
    dsimp,
    split_ifs,
    { subst h, simp, },
    { symmetry,
      apply zero_of_target_iso_zero,
      dsimp,
      rw [if_neg h], },
  end }

end homological_complex

open homological_complex

namespace chain_complex

local attribute [instance] has_zero_object.has_zero

/--
`chain_complex.single₀ V` is the embedding of `V` into `chain_complex V ℕ`
as chain complexes supported in degree 0.

This is naturally isomorphic to `single V _ 0`, but has better definitional properties.
-/
def single₀ : V ⥤ chain_complex V ℕ :=
{ obj := λ X,
  { X := λ n, match n with
    | 0 := X
    | (n+1) := 0
    end,
    d := λ i j, 0, },
  map := λ X Y f,
  { f := λ n, match n with
    | 0 := f
    | (n+1) := 0
    end, },
  map_id' := λ X, by { ext n, cases n, refl, dsimp, unfold_aux, simp, },
  map_comp' := λ X Y Z f g, by { ext n, cases n, refl, dsimp, unfold_aux, simp, } }

@[simp] lemma single₀_obj_X_0 (X : V) : ((single₀ V).obj X).X 0 = X := rfl
@[simp] lemma single₀_obj_X_succ (X : V) (n : ℕ) : ((single₀ V).obj X).X (n+1) = 0 := rfl
@[simp] lemma single₀_obj_X_d (X : V) (i j : ℕ) : ((single₀ V).obj X).d i j = 0 := rfl
@[simp]

section
variables [has_equalizers V] [has_cokernels V] [has_images V] [has_image_maps V]

/--
Sending objects to chain complexes supported at `0` then taking `0`-th homology
is the same as doing nothing.
-/
noncomputable
def homology_functor_0_single₀ : single₀ V ⋙ homology_functor V _ 0 ≅ (𝟭 V) :=
nat_iso.of_components (λ X, homology.congr _ _ (by simp) (by simp) ≪≫ homology_zero_zero)
  (λ X Y f, by { ext, dsimp [homology_functor], simp, })

/--
Sending objects to chain complexes supported at `0` then taking `(n+1)`-st homology
is the same as the zero functor.
-/
noncomputable
def homology_functor_succ_single₀ (n : ℕ) : single₀ V ⋙ homology_functor V _ (n+1) ≅ 0 :=
nat_iso.of_components (λ X, homology.congr _ _ (by simp) (by simp) ≪≫ homology_zero_zero)
  (λ X Y f, by ext)

end

variables {V}

/--
Morphisms from a `ℕ`-indexed chain complex `C`
to a single object chain complex with `X` concentrated in degree 0
are the same as morphisms `f : C.X 0 ⟶ X` such that `C.d 1 0 ≫ f = 0`.
-/
def to_single₀_equiv (C : chain_complex V ℕ) (X : V) :
  (C ⟶ (single₀ V).obj X) ≃ { f : C.X 0 ⟶ X // C.d 1 0 ≫ f = 0 } :=
{ to_fun := λ f, ⟨f.f 0, by { rw ←f.comm 1 0, simp, }⟩,
  inv_fun := λ f,
  { f := λ i, match i with
    | 0 := f.1
    | (n+1) := 0
    end,
    comm' := λ i j h, begin
      rcases i with _|_|i; cases j; unfold_aux; simp only [comp_zero, zero_comp, single₀_obj_X_d],
      { rw [C.shape, zero_comp], simp, },
      { exact f.2.symm, },
      { rw [C.shape, zero_comp], simp [i.succ_succ_ne_one.symm] },
    end, },
  left_inv := λ f, begin
    ext i,
    rcases i,
    { refl, },
    { ext, },
  end,
  right_inv := by tidy, }

variables (V)

/-- `single₀` is the same as `single V _ 0`. -/
def single₀_iso_single : single₀ V ≅ single V _ 0 :=
nat_iso.of_components
  (λ X,
  { hom := { f := λ i, by { cases i; simpa using 𝟙 _, } },
    inv := { f := λ i, by { cases i; simpa using 𝟙 _, } },
    hom_inv_id' := by { ext (_|i); { dsimp, simp, }, },
    inv_hom_id' := begin
      ext (_|i),
      { apply category.id_comp, },
      { apply has_zero_object.to_zero_ext, },
    end, })
  (λ X Y f, by { ext (_|i); { dsimp, simp, }, })

instance : faithful (single₀ V) := faithful.of_iso (single₀_iso_single V).symm
instance : full (single₀ V) := full.of_iso (single₀_iso_single V).symm

end chain_complex

namespace cochain_complex

local attribute [instance] has_zero_object.has_zero

/--
`cochain_complex.single₀ V` is the embedding of `V` into `cochain_complex V ℕ`
as cochain complexes supported in degree 0.

This is naturally isomorphic to `single V _ 0`, but has better definitional properties.
-/
def single₀ : V ⥤ cochain_complex V ℕ :=
{ obj := λ X,
  { X := λ n, match n with
    | 0 := X
    | (n+1) := 0
    end,
    d := λ i j, 0, },
  map := λ X Y f,
  { f := λ n, match n with
    | 0 := f
    | (n+1) := 0
    end, },
  map_id' := λ X, by { ext n, cases n, refl, dsimp, unfold_aux, simp, },
  map_comp' := λ X Y Z f g, by { ext n, cases n, refl, dsimp, unfold_aux, simp, } }

@[simp] lemma single₀_obj_X_0 (X : V) : ((single₀ V).obj X).X 0 = X := rfl
@[simp] lemma single₀_obj_X_succ (X : V) (n : ℕ) : ((single₀ V).obj X).X (n+1) = 0 := rfl
@[simp] lemma single₀_obj_X_d (X : V) (i j : ℕ) : ((single₀ V).obj X).d i j = 0 := rfl
@[simp] lemma single₀_obj_X_d_from (X : V) (j : ℕ) : ((single₀ V).obj X).d_from j = 0 :=
by { rw [d_from_eq ((single₀ V).obj X) rfl], simp, }
@[simp] lemma single₀_obj_X_d_to (X : V) (i : ℕ) : ((single₀ V).obj X).d_to i = 0 :=
begin
  cases i,
  { rw [d_to_eq_zero], simp, },
  { rw [d_to_eq ((single₀ V).obj X) rfl], simp, },
end
@[simp] lemma single₀_map_f_0 {X Y : V} (f : X ⟶ Y) : ((single₀ V).map f).f 0 = f := rfl
@[simp] lemma single₀_map_f_succ {X Y : V} (f : X ⟶ Y) (n : ℕ) :
  ((single₀ V).map f).f (n+1) = 0 := rfl

section
variables [has_equalizers V] [has_cokernels V] [has_images V] [has_image_maps V]

/--
Sending objects to cochain complexes supported at `0` then taking `0`-th homology
is the same as doing nothing.
-/
noncomputable
def homology_functor_0_single₀ : single₀ V ⋙ homology_functor V _ 0 ≅ (𝟭 V) :=
nat_iso.of_components (λ X, homology.congr _ _ (by simp) (by simp) ≪≫ homology_zero_zero)
  (λ X Y f, by { ext, dsimp [homology_functor], simp, })

/--
Sending objects to cochain complexes supported at `0` then taking `(n+1)`-st homology
is the same as the zero functor.
-/
noncomputable
def homology_functor_succ_single₀ (n : ℕ) : single₀ V ⋙ homology_functor V _ (n+1) ≅ 0 :=
nat_iso.of_components (λ X, homology.congr _ _ (by simp) (by simp) ≪≫ homology_zero_zero)
  (λ X Y f, by ext)

end

variables {V}

/--
Morphisms from a single object cochain complex with `X` concentrated in degree 0
to a `ℕ`-indexed cochain complex `C`
are the same as morphisms `f : X ⟶ C.X 0` such that `f ≫ C.d 0 1 = 0`.
-/
def from_single₀_equiv (C : cochain_complex V ℕ) (X : V) :
  ((single₀ V).obj X ⟶ C) ≃ { f : X ⟶ C.X 0 // f ≫ C.d 0 1 = 0 } :=
{ to_fun := λ f, ⟨f.f 0, by { rw f.comm 0 1, simp, }⟩,
  inv_fun := λ f,
  { f := λ i, match i with
    | 0 := f.1
    | (n+1) := 0
    end,
    comm' := λ i j h, begin
      rcases j with _|_|j; cases i; unfold_aux; simp only [comp_zero, zero_comp, single₀_obj_X_d],
      { convert comp_zero, rw [C.shape], simp, },
      { exact f.2, },
      { convert comp_zero, rw [C.shape], simp only [complex_shape.up_rel, zero_add],
        exact (nat.one_lt_succ_succ j).ne },
    end, },
  left_inv := λ f, begin
    ext i,
    rcases i,
    { refl, },
    { ext, },
  end,
  right_inv := by tidy, }

variables (V)

/-- `single₀` is the same as `single V _ 0`. -/
def single₀_iso_single : single₀ V ≅ single V _ 0 :=
nat_iso.of_components
  (λ X,
  { hom := { f := λ i, by { cases i; simpa using 𝟙 _, } },
    inv := { f := λ i, by { cases i; simpa using 𝟙 _, } },
    hom_inv_id' := by { ext (_|i); { dsimp, simp, }, },
    inv_hom_id' := begin
      ext (_|i),
      { apply category.id_comp, },
      { apply has_zero_object.to_zero_ext, },
    end, })
  (λ X Y f, by { ext (_|i); { dsimp, simp, }, })

instance : faithful (single₀ V) := faithful.of_iso (single₀_iso_single V).symm
instance : full (single₀ V) := full.of_iso (single₀_iso_single V).symm

end cochain_complex


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

noncomputable theory

open category_theory
open category_theory.limits

/-!
Some small examples of using limits and colimits in `Ab`, the category of additive commutative
groups.
-/

example (G H : Ab) (f : G ⟶ H) : Ab := kernel f
example (G H : Ab) (f : G ⟶ H) [epi f] : kernel (cokernel.π f) ≅ H :=
as_iso (kernel.ι (cokernel.π f))

-- TODO no images yet...


/-
Copyright (c) 2018 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, David Renshaw
-/
import Lean
import Mathlib.Lean.Meta
import Mathlib.Tactic.LeftRight

/-!
# mk_iff_of_inductive_prop

This file defines a tactic `tactic.mk_iff_of_inductive_prop` that generates `iff` rules for
inductive `Prop`s. For example, when applied to `List.Chain`, it creates a declaration with
the following type:

```lean
∀ {α : Type _} (R : α → α → Prop) (a : α) (l : List α),
  Chain R a l ↔ l = [] ∨ ∃(b : α) (l' : List α), R a b ∧ Chain R b l ∧ l = b :: l'
```

This tactic can be called using either the `mk_iff_of_inductive_prop` user command or
the `mk_iff` attribute.
-/

namespace Mathlib.Tactic.MkIff

open Lean Meta Elab

/-- `select m n` runs `tactic.right` `m` times, and then `tactic.left` `(n-m)` times.
Fails if `n < m`. -/
private def select (m n : Nat) (goal : MVarId) : MetaM MVarId :=
  match m,n with
  | 0, 0             => pure goal
  | 0, (_ + 1)       => do let [new_goal] ← Mathlib.Tactic.LeftRight.leftRightMeta `left 0 2 goal
                                | throwError "expected only one new goal"
                           pure new_goal
  | (m + 1), (n + 1) => do let [new_goal] ← Mathlib.Tactic.LeftRight.leftRightMeta `right 1 2 goal
                                | throwError "expected only one new goal"
                           select m n new_goal
  | _, _             => failure

/-- `compactRelation bs as_ps`: Produce a relation of the form:
```lean
R := λ as ∃ bs, Λ_i a_i = p_i[bs]
```
This relation is user-visible, so we compact it by removing each `b_j` where a `p_i = b_j`, and
hence `a_i = b_j`. We need to take care when there are `p_i` and `p_j` with `p_i = p_j = b_k`.
-/
partial def compactRelation :
  List Expr → List (Expr × Expr) → List (Option Expr) × List (Expr × Expr) × (Expr → Expr)
| [],    as_ps => ([], as_ps, id)
| b::bs, as_ps =>
  match as_ps.span (λ⟨_,p⟩ => ¬ p == b) with
    | (_, []) => -- found nothing in ps equal to b
        let (bs, as_ps', subst) := compactRelation bs as_ps
        (b::bs, as_ps', subst)
    | (ps₁, (a, _) :: ps₂) => -- found one that matches b. Remove it.
      let i := fun e ↦ e.replaceFVar b a
      let (bs, as_ps', subst) := compactRelation (bs.map i) ((ps₁ ++ ps₂).map (λ⟨a, p⟩ => (a, i p)))
      (none :: bs, as_ps', i ∘ subst)

/-- Generates an expression of the form `∃(args), inner`. `args` is assumed to be a list of fvars.
When possible, `p ∧ q` is used instead of `∃(_ : p), q`. -/
def mkExistsList (args : List Expr) (inner : Expr) : MetaM Expr :=
args.foldrM (λarg i:Expr => do
    let t ← inferType arg
    let l := (← inferType t).sortLevel!
    pure $ if arg.occurs i || l != Level.zero
      then mkApp2 (mkConst `Exists [l] : Expr) t (←(mkLambdaFVars #[arg] i))
      else mkApp2 (mkConst `And [] : Expr) t i)
  inner

/-- `mkOpList op empty [x1, x2, ...]` is defined as `op x1 (op x2 ...)`.
  Returns `empty` if the list is empty. -/
def mkOpList (op : Expr) (empty : Expr) : List Expr → Expr
| []        => empty
| [e]       => e
| (e :: es) => mkApp2 op e $ mkOpList op empty es

/-- `mkAndList [x1, x2, ...]` is defined as `x1 ∧ (x2 ∧ ...)`, or `True` if the list is empty. -/
def mkAndList : List Expr → Expr := mkOpList (mkConst `And) (mkConst `True)

/-- `mkOrList [x1, x2, ...]` is defined as `x1 ∨ (x2 ∨ ...)`, or `False` if the list is empty. -/
def mkOrList : List Expr → Expr := mkOpList (mkConst `Or) (mkConst `False)

/-- Drops the final element of a list. -/
def List.init : List α → List α
| []     => []
| [_]    => []
| a::l => a::init l

/-- Auxiliary data associated with a single constructor of an inductive declaration.
-/
structure Shape : Type where
  /-- For each forall-bound variable in the type of the constructor, minus
  the "params" that apply to the entire inductive type, this list contains `true`
  if that variable has been kept after `compactRelation`.

  For example, `List.Chain.nil` has type
  ```lean
    ∀ {α : Type u_1} {R : α → α → Prop} {a : α}, List.Chain R a []`
  ```
  and the first two variables `α` and `R` are "params", while the `a : α` gets
  eliminated in a `compactRelation`, so `variablesKept = [false].

  `List.Chain.cons` has type
  ```lean
    ∀ {α : Type u_1} {R : α → α → Prop} {a b : α} {l : List α},
       R a b → List.Chain R b l → List.Chain R a (b :: l)
  ```
  and the `a : α` gets eliminated, so `compactRelation = [false,true,true,true,true]`.
   -/
  variablesKept : List Bool

  /-- The number of equalities, or `none` in the case when we've reduced something
  of the form `p ∧ True` to just `p`.
  -/
  neqs : Option Nat

/-- Converts an inductive constructor `c` into a `Shape` that will be used later in
while proving the iff theorem, and a proposition representing the constructor.
-/
def constrToProp (univs : List Level) (params : List Expr) (idxs : List Expr) (c : Name) :
  MetaM (Shape × Expr)  :=
do let type := (← getConstInfo c).instantiateTypeLevelParams univs
   let type' ← Meta.forallBoundedTelescope type (params.length) fun fvars ty ↦ do
     pure $ ty.replaceFVars fvars params.toArray

   Meta.forallTelescope type' fun fvars ty ↦ do
     let idxs_inst := ty.getAppArgs.toList.drop params.length
     let (bs, eqs, subst) := compactRelation fvars.toList (idxs.zip idxs_inst)
     let eqs ← eqs.mapM (λ⟨idx, inst⟩ => do
          let ty ← idx.fvarId!.getType
          let instTy ← inferType inst
          let u := (←inferType ty).sortLevel!
          if ←isDefEq ty instTy
          then pure (mkApp3 (mkConst `Eq [u]) ty idx inst)
          else pure (mkApp4 (mkConst `HEq [u]) ty idx instTy inst))
     let (n, r) ← match bs.filterMap id, eqs with
     | [], [] => do
           pure (some 0, (mkConst `True))
     | bs', []  => do
          let t : Expr ← bs'.getLast!.fvarId!.getType
          let l := (←inferType t).sortLevel!
          if l == Level.zero then do
            let r ← mkExistsList (List.init bs') t
            pure (none, subst r)
          else do
            let r ← mkExistsList bs' (mkConst `True)
            pure (some 0, subst r)
     | bs', _ => do
       let r ← mkExistsList bs' (mkAndList eqs)
       pure (some eqs.length, subst r)
     pure (⟨bs.map Option.isSome, n⟩, r)

/-- Splits the goal `n` times via `refine ⟨?_,?_⟩`, and then applies `constructor` to
close the resulting subgoals.
-/
def splitThenConstructor (mvar : MVarId) (n : Nat) : MetaM Unit :=
match n with
| 0   => do
  let (subgoals',_) ← Term.TermElabM.run $ Tactic.run mvar do
    Tactic.evalTactic (←`(tactic| constructor))
  let [] := subgoals' | throwError "expected no subgoals"
  pure ()
| n  + 1 => do
  let (subgoals,_) ← Term.TermElabM.run $ Tactic.run mvar do
    Tactic.evalTactic (←`(tactic| refine ⟨?_,?_⟩))
  let [sg1, sg2] := subgoals | throwError "expected two subgoals"
  let (subgoals',_) ← Term.TermElabM.run $ Tactic.run sg1 do
    Tactic.evalTactic (←`(tactic| constructor))
  let [] := subgoals' | throwError "expected no subgoals"
  splitThenConstructor sg2 n

/-- Proves the left to right direction of a generated iff theorem.
`shape` is the output of a call to `constrToProp`.
-/
def toCases (mvar : MVarId) (shape : List Shape) : MetaM Unit :=
do
  let ⟨h, mvar'⟩ ← mvar.intro1
  let subgoals ← mvar'.cases h
  let _ ← (shape.zip subgoals.toList).enum.mapM fun ⟨p, ⟨⟨shape, t⟩, subgoal⟩⟩ ↦ do
    let vars := subgoal.fields
    let si := (shape.zip vars.toList).filterMap (λ ⟨c,v⟩ => if c then some v else none)
    let mvar'' ← select p (subgoals.size - 1) subgoal.mvarId
    match t with
    | none => do
      let v := vars.get! (shape.length - 1)
      let mv ← mvar''.existsi (List.init si)
      mv.assign v
    | some n => do
      let mv ← mvar''.existsi si
      splitThenConstructor mv (n - 1)
  pure ()

/-- Calls `cases` on `h` (assumed to be a binary sum) `n` times, and returns
the resulting subgoals and their corresponding new hypotheses.
-/
def nCasesSum (n : Nat) (mvar : MVarId) (h : FVarId) : MetaM (List (FVarId × MVarId)) :=
match n with
| 0 => pure [(h, mvar)]
| n' + 1 => do
  let #[sg1, sg2] ← mvar.cases h | throwError "expected two case subgoals"
  let #[Expr.fvar fvar1] ← pure sg1.fields | throwError "expected fvar"
  let #[Expr.fvar fvar2] ← pure sg2.fields | throwError "expected fvar"
  let rest ← nCasesSum n' sg2.mvarId fvar2
  pure ((fvar1, sg1.mvarId)::rest)

/-- Calls `cases` on `h` (assumed to be a binary product) `n` times, and returns
the resulting subgoal and the new hypotheses.
-/
def nCasesProd (n : Nat) (mvar : MVarId) (h : FVarId) : MetaM (MVarId × List FVarId) :=
match n with
| 0 => pure (mvar, [h])
| n' + 1 => do
  let #[sg] ← mvar.cases h | throwError "expected one case subgoals"
  let #[Expr.fvar fvar1, Expr.fvar fvar2] ← pure sg.fields | throwError "expected fvar"
  let (mvar', rest) ← nCasesProd n' sg.mvarId fvar2
  pure (mvar', fvar1::rest)

/--
Iterate over two lists, if the first element of the first list is `false`, insert `none` into the
result and continue with the tail of first list. Otherwise, wrap the first element of the second
list with `some` and continue with the tails of both lists. Return when either list is empty.

Example:
```
listBoolMerge [false, true, false, true] [0, 1, 2, 3, 4] = [none, (some 0), none, (some 1)]
```
-/
def listBoolMerge {α : Type _} : List Bool → List α → List (Option α)
| [], _ => []
| false :: xs, ys => none :: listBoolMerge xs ys
| true :: xs, y :: ys => some y :: listBoolMerge xs ys
| true :: _, [] => []

/-- Proves the right to left direction of a generated iff theorem.
-/
def toInductive (mvar : MVarId) (cs : List Name)
  (gs : List Expr) (s : List Shape) (h : FVarId) :
  MetaM Unit := do
  match s.length with
  | 0       => do let _ ← mvar.cases h
                  pure ()
  | (n + 1) => do
      let subgoals ← nCasesSum n mvar h
      let _ ← (cs.zip (subgoals.zip s)).mapM $ λ⟨constr_name, ⟨h, mv⟩, bs, e⟩ => do
        let n := (bs.filter id).length
        let (mvar', _fvars) ← match e with
        | none => nCasesProd (n-1) mv h
        | some 0 => do let ⟨mvar', fvars⟩ ← nCasesProd n mv h
                          let mvar'' ← mvar'.tryClear fvars.getLast!
                          pure ⟨mvar'', fvars⟩
        | some (e + 1) => do
           let (mv', fvars) ← nCasesProd n mv h
           let lastfv := fvars.getLast!
           let (mv2, fvars') ← nCasesProd e mv' lastfv

           /- `fvars'.foldlM subst mv2` fails when we have dependent equalities (`HEq`).
           `subst` will change the dependent hypotheses, so that the `uniq` local names
           are wrong afterwards. Instead we revert them and pull them out one-by-one. -/
           let (_, mv3) ← mv2.revert fvars'.toArray
           let mv4 ← fvars'.foldlM (λ mv _ => do let ⟨fv, mv'⟩ ← mv.intro1
                                                 subst mv' fv
                                   ) mv3
           pure (mv4, fvars)
        mvar'.withContext do
          let fvarIds := (←getLCtx).getFVarIds.toList
          let gs := fvarIds.take gs.length
          let hs := (fvarIds.reverse.take n).reverse
          let m := gs.map some ++ listBoolMerge bs hs
          let args ← m.mapM (λa => match a with
                                   | some v => pure $ mkFVar v
                                   | none => mkFreshExprMVar none)
          let c ← mkConstWithFreshMVarLevels constr_name
          let e := mkAppN c args.toArray
          let t ← inferType e
          let mt ← mvar'.getType
          let _ ← isDefEq t mt -- infer values for those mvars we just made
          mvar'.assign e

/-- Implementation for both `mk_iff` and `mk_iff_of_inductive_prop`.y
-/
def mkIffOfInductivePropImpl (ind : Name) (rel : Name) (relStx : Syntax) : MetaM Unit := do
  let .inductInfo inductVal ← getConstInfo ind |
    throwError "mk_iff only applies to inductive declarations"
  let constrs := inductVal.ctors
  let params := inductVal.numParams
  let type := inductVal.type

  let univNames := inductVal.levelParams
  let univs := univNames.map mkLevelParam
  /- we use these names for our universe parameters, maybe we should construct a copy of them
  using `uniq_name` -/

  let (thmTy,shape) ← Meta.forallTelescope type fun fvars ty ↦ do
    if !ty.isProp then throwError "mk_iff only applies to prop-valued declarations"
    let lhs := mkAppN (mkConst ind univs) fvars
    let fvars' := fvars.toList
    let shape_rhss ← constrs.mapM (constrToProp univs (fvars'.take params) (fvars'.drop params))
    let (shape, rhss) := shape_rhss.unzip
    pure (←mkForallFVars fvars (mkApp2 (mkConst `Iff) lhs (mkOrList rhss)),
          shape)

  let mvar ← mkFreshExprMVar (some thmTy)
  let mvarId := mvar.mvarId!
  let (fvars, mvarId') ← mvarId.intros
  let [mp, mpr] ← mvarId'.apply (mkConst `Iff.intro) | throwError "failed to split goal"

  toCases mp shape

  let ⟨mprFvar, mpr'⟩ ← mpr.intro1
  toInductive mpr' constrs ((fvars.toList.take params).map .fvar) shape mprFvar

  addDecl $ .thmDecl {
    name := rel
    levelParams := univNames
    type := thmTy
    value := ← instantiateMVars mvar
  }
  addDeclarationRanges rel {
    range := ← getDeclarationRange (← getRef)
    selectionRange := ← getDeclarationRange relStx
  }
  addConstInfo relStx rel

/--
Applying the `mk_iff` attribute to an inductively-defined proposition `mk_iff` makes an `iff` rule
`r` with the shape `∀ps is, i as ↔ ⋁_j, ∃cs, is = cs`, where `ps` are the type parameters, `is` are
the indices, `j` ranges over all possible constructors, the `cs` are the parameters for each of the
constructors, and the equalities `is = cs` are the instantiations for each constructor for each of
the indices to the inductive type `i`.

In each case, we remove constructor parameters (i.e. `cs`) when the corresponding equality would
be just `c = i` for some index `i`.

For example, if we try the following:
```lean
@[mk_iff]
structure Foo (m n : Nat) : Prop where
  equal : m = n
  sum_eq_two : m + n = 2
```

Then `#check Foo_iff` returns:
```lean
Foo_iff : ∀ (m n : Nat), Foo m n ↔ m = n ∧ m + n = 2
```

You can add an optional string after `mk_iff` to change the name of the generated lemma.
For example, if we try the following:
```lean
@[mk_iff bar]
structure Foo (m n : Nat) : Prop where
  equal : m = n
  sum_eq_two : m + n = 2
```

Then `#check bar` returns:
```lean
bar : ∀ (m n : ℕ), Foo m n ↔ m = n ∧ m + n = 2
```

See also the user command `mk_iff_of_inductive_prop`.
-/
syntax (name := mkIff) "mk_iff" (ppSpace ident)? : attr

/--
`mk_iff_of_inductive_prop i r` makes an `iff` rule for the inductively-defined proposition `i`.
The new rule `r` has the shape `∀ps is, i as ↔ ⋁_j, ∃cs, is = cs`, where `ps` are the type
parameters, `is` are the indices, `j` ranges over all possible constructors, the `cs` are the
parameters for each of the constructors, and the equalities `is = cs` are the instantiations for
each constructor for each of the indices to the inductive type `i`.

In each case, we remove constructor parameters (i.e. `cs`) when the corresponding equality would
be just `c = i` for some index `i`.

For example, `mk_iff_of_inductive_prop` on `List.Chain` produces:

```lean
∀ { α : Type _} (R : α → α → Prop) (a : α) (l : List α),
  Chain R a l ↔ l = [] ∨ ∃(b : α) (l' : List α), R a b ∧ Chain R b l ∧ l = b :: l'
```

See also the `mk_iff` user attribute.
-/
syntax (name := mkIffOfInductiveProp) "mk_iff_of_inductive_prop" ident ident : command

elab_rules : command
| `(command| mk_iff_of_inductive_prop $i:ident $r:ident) =>
    Command.liftCoreM <| MetaM.run' do
      mkIffOfInductivePropImpl i.getId r.getId r

initialize Lean.registerBuiltinAttribute {
  name := `mkIff
  descr := "Generate an `iff` lemma for an inductive `Prop`."
  add := fun decl stx _ => Lean.Meta.MetaM.run' do
    let (tgt, idStx) ← match stx with
      | `(attr| mk_iff $tgt:ident) =>
        pure ((← mkDeclName (← getCurrNamespace) {} tgt.getId).1, tgt.raw)
      | `(attr| mk_iff) => pure (decl.appendAfter "_iff", stx)
      | _ => throwError "unrecognized syntax"
    mkIffOfInductivePropImpl decl tgt idStx
}


import Lean
import UserAttr.BlaAttr

@[bla] def f (x : Nat) := x + 2
@[bla] def g (x : Nat) := x + 1

@[foo 10] def h1 (x : Nat) := 2*x + 1
@[foo 20 important] def h2 (x : Nat) := 2*x + 1

open Lean in
def hasBlaAttr (declName : Name) : CoreM Bool :=
  return blaAttr.hasTag (← getEnv) declName

#eval hasBlaAttr ``f
#eval hasBlaAttr ``id

open Lean in
def getFooAttrInfo? (declName : Name) : CoreM (Option (Nat × Bool)) :=
  return fooAttr.getParam? (← getEnv) declName

#eval getFooAttrInfo? ``f
#eval getFooAttrInfo? ``h1
#eval getFooAttrInfo? ``h2

@[my_simp] theorem f_eq : f x = x + 2 := rfl
@[my_simp] theorem g_eq : g x = x + 1 := rfl

example : f x + g x = 2*x + 3 := by
  simp_arith -- does not appy f_eq and g_eq
  simp_arith [f, g]

example : f x + g x = 2*x + 3 := by
  simp_arith [my_simp]

example : f x = id (x + 2) := by
  simp
  simp [my_simp]

macro "my_simp" : tactic => `(tactic| simp [my_simp])

example : f x = id (x + 2) := by
  my_simp

@[simp low, my_simp low]
axiom expand_mul_add (x y z : Nat) : x * (y + z) = x * y + x * y
@[simp high, my_simp high]
axiom expand_add_mul (x y z : Nat) : (x + y) * z = x * z + y * z
@[simp, my_simp]
axiom lassoc_add (x y z : Nat) : x + (y + z) = x + y + z

set_option trace.Meta.Tactic.simp.rewrite true

-- Rewrites: expand_mul_add -> expand_mul_add -> lassoc_add
theorem ex1 (x : Nat) : (x + x) * (x + x) = x * x + x * x + x * x + x * x := by simp only [my_simp]

-- Rewrites: expand_add_mul -> expand_mul_add -> lassoc_add
theorem ex2 (x : Nat) : (x + x) * (x + x) = x * x + x * x + x * x + x * x := by simp

open Lean Meta in
def checkProofs : MetaM Unit := do
  let .thmInfo info1 ← getConstInfo `ex1 | throwError "unexpected"
  let .thmInfo info2 ← getConstInfo `ex2 | throwError "unexpected"
  unless info1.value == info2.value do
    throwError "unexpected values"

#eval checkProofs

open Lean Meta in
def showThmsOf (simpAttrName : Name) : MetaM Unit := do
  let some simpExt ← getSimpExtension? simpAttrName
    | throwError "`{simpAttrName}` is not a simp attribute"
  let thms ← simpExt.getTheorems
  let thmNames := thms.lemmaNames.fold (init := #[]) fun acc origin => acc.push origin.key
  for thmName in thmNames do
    IO.println thmName

#eval showThmsOf `my_simp


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta

! This file was ported from Lean 3 source module category_theory.sites.pretopology
! leanprover-community/mathlib commit 9e7c80f638149bfb3504ba8ff48dfdbfc949fb1a
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Sites.Grothendieck

/-!
# Grothendieck pretopologies

Definition and lemmas about Grothendieck pretopologies.
A Grothendieck pretopology for a category `C` is a set of families of morphisms with fixed codomain,
satisfying certain closure conditions.

We show that a pretopology generates a genuine Grothendieck topology, and every topology has
a maximal pretopology which generates it.

The pretopology associated to a topological space is defined in `spaces.lean`.

## Tags

coverage, pretopology, site

## References

* [nLab, *Grothendieck pretopology*](https://ncatlab.org/nlab/show/Grothendieck+pretopology)
* [S. MacLane, I. Moerdijk, *Sheaves in Geometry and Logic*][MM92]
* [Stacks, *00VG*](https://stacks.math.columbia.edu/tag/00VG)
-/

universe v u

noncomputable section

namespace CategoryTheory

open CategoryTheory Category Limits Presieve

variable {C : Type u} [Category.{v} C] [HasPullbacks C]

variable (C)

#print CategoryTheory.Pretopology /-
/--
A (Grothendieck) pretopology on `C` consists of a collection of families of morphisms with a fixed
target `X` for every object `X` in `C`, called "coverings" of `X`, which satisfies the following
three axioms:
1. Every family consisting of a single isomorphism is a covering family.
2. The collection of covering families is stable under pullback.
3. Given a covering family, and a covering family on each domain of the former, the composition
   is a covering family.

In some sense, a pretopology can be seen as Grothendieck topology with weaker saturation conditions,
in that each covering is not necessarily downward closed.

See: https://ncatlab.org/nlab/show/Grothendieck+pretopology, or
https://stacks.math.columbia.edu/tag/00VH, or [MM92] Chapter III, Section 2, Definition 2.
Note that Stacks calls a category together with a pretopology a site, and [MM92] calls this
a basis for a topology.
-/
@[ext]
structure Pretopology where
  coverings : ∀ X : C, Set (Presieve X)
  has_isos : ∀ ⦃X Y⦄ (f : Y ⟶ X) [IsIso f], Presieve.singleton f ∈ coverings X
  pullbacks : ∀ ⦃X Y⦄ (f : Y ⟶ X) (S), S ∈ coverings X → pullbackArrows f S ∈ coverings Y
  Transitive :
    ∀ ⦃X : C⦄ (S : Presieve X) (Ti : ∀ ⦃Y⦄ (f : Y ⟶ X), S f → Presieve Y),
      S ∈ coverings X → (∀ ⦃Y⦄ (f) (H : S f), Ti f H ∈ coverings Y) → S.bind Ti ∈ coverings X
#align category_theory.pretopology CategoryTheory.Pretopology
-/

namespace Pretopology

instance : CoeFun (Pretopology C) fun _ => ∀ X : C, Set (Presieve X) :=
  ⟨coverings⟩

variable {C}

instance : LE (Pretopology C) where le K₁ K₂ := (K₁ : ∀ X : C, Set (Presieve X)) ≤ K₂

#print CategoryTheory.Pretopology.le_def /-
theorem le_def {K₁ K₂ : Pretopology C} : K₁ ≤ K₂ ↔ (K₁ : ∀ X : C, Set (Presieve X)) ≤ K₂ :=
  Iff.rfl
#align category_theory.pretopology.le_def CategoryTheory.Pretopology.le_def
-/

variable (C)

instance : PartialOrder (Pretopology C) :=
  { Pretopology.hasLe with
    le_refl := fun K => le_def.mpr le_rfl
    le_trans := fun K₁ K₂ K₃ h₁₂ h₂₃ => le_def.mpr (le_trans h₁₂ h₂₃)
    le_antisymm := fun K₁ K₂ h₁₂ h₂₁ => Pretopology.ext _ _ (le_antisymm h₁₂ h₂₁) }

instance : OrderTop (Pretopology C)
    where
  top :=
    { coverings := fun _ => Set.univ
      has_isos := fun _ _ _ _ => Set.mem_univ _
      pullbacks := fun _ _ _ _ _ => Set.mem_univ _
      Transitive := fun _ _ _ _ _ => Set.mem_univ _ }
  le_top K X S hS := Set.mem_univ _

instance : Inhabited (Pretopology C) :=
  ⟨⊤⟩

#print CategoryTheory.Pretopology.toGrothendieck /-
/-- A pretopology `K` can be completed to a Grothendieck topology `J` by declaring a sieve to be
`J`-covering if it contains a family in `K`.

See <https://stacks.math.columbia.edu/tag/00ZC>, or [MM92] Chapter III, Section 2, Equation (2).
-/
def toGrothendieck (K : Pretopology C) : GrothendieckTopology C
    where
  sieves X S := ∃ R ∈ K X, R ≤ (S : Presieve _)
  top_mem' X := ⟨Presieve.singleton (𝟙 _), K.has_isos _, fun _ _ _ => ⟨⟩⟩
  pullback_stable' X Y S g := by
    rintro ⟨R, hR, RS⟩
    refine' ⟨_, K.pullbacks g _ hR, _⟩
    rw [← sieve.sets_iff_generate, sieve.pullback_arrows_comm]
    apply sieve.pullback_monotone
    rwa [sieve.gi_generate.gc]
  transitive' := by
    rintro X S ⟨R', hR', RS⟩ R t
    choose t₁ t₂ t₃ using t
    refine' ⟨_, K.transitive _ _ hR' fun _ f hf => t₂ (RS _ hf), _⟩
    rintro Y _ ⟨Z, g, f, hg, hf, rfl⟩
    apply t₃ (RS _ hg) _ hf
#align category_theory.pretopology.to_grothendieck CategoryTheory.Pretopology.toGrothendieck
-/

/- warning: category_theory.pretopology.mem_to_grothendieck -> CategoryTheory.Pretopology.mem_toGrothendieck is a dubious translation:
lean 3 declaration is
  forall (C : Type.{u2}) [_inst_1 : CategoryTheory.Category.{u1, u2} C] [_inst_2 : CategoryTheory.Limits.HasPullbacks.{u1, u2} C _inst_1] (K : CategoryTheory.Pretopology.{u1, u2} C _inst_1 _inst_2) (X : C) (S : CategoryTheory.Sieve.{u1, u2} C _inst_1 X), Iff (Membership.Mem.{max u2 u1, max u2 u1} (CategoryTheory.Sieve.{u1, u2} C _inst_1 X) (Set.{max u2 u1} (CategoryTheory.Sieve.{u1, u2} C _inst_1 X)) (Set.hasMem.{max u2 u1} (CategoryTheory.Sieve.{u1, u2} C _inst_1 X)) S (coeFn.{max (succ u2) (succ u1), max (succ u2) (succ (max u2 u1))} (CategoryTheory.GrothendieckTopology.{u1, u2} C _inst_1) (fun (_x : CategoryTheory.GrothendieckTopology.{u1, u2} C _inst_1) => forall (X : C), Set.{max u2 u1} (CategoryTheory.Sieve.{u1, u2} C _inst_1 X)) (CategoryTheory.GrothendieckTopology.hasCoeToFun.{u1, u2} C _inst_1) (CategoryTheory.Pretopology.toGrothendieck.{u1, u2} C _inst_1 _inst_2 K) X)) (Exists.{succ (max u2 u1)} (CategoryTheory.Presieve.{u1, u2} C _inst_1 X) (fun (R : CategoryTheory.Presieve.{u1, u2} C _inst_1 X) => Exists.{0} (Membership.Mem.{max u2 u1, max u2 u1} (CategoryTheory.Presieve.{u1, u2} C _inst_1 X) (Set.{max u2 u1} (CategoryTheory.Presieve.{u1, u2} C _inst_1 X)) (Set.hasMem.{max u2 u1} (CategoryTheory.Presieve.{u1, u2} C _inst_1 X)) R (coeFn.{max (succ u2) (succ u1), max (succ u2) (succ (max u2 u1))} (CategoryTheory.Pretopology.{u1, u2} C _inst_1 _inst_2) (fun (_x : CategoryTheory.Pretopology.{u1, u2} C _inst_1 _inst_2) => forall (X : C), Set.{max u2 u1} (CategoryTheory.Presieve.{u1, u2} C _inst_1 X)) (CategoryTheory.Pretopology.hasCoeToFun.{u1, u2} C _inst_1 _inst_2) K X)) (fun (H : Membership.Mem.{max u2 u1, max u2 u1} (CategoryTheory.Presieve.{u1, u2} C _inst_1 X) (Set.{max u2 u1} (CategoryTheory.Presieve.{u1, u2} C _inst_1 X)) (Set.hasMem.{max u2 u1} (CategoryTheory.Presieve.{u1, u2} C _inst_1 X)) R (coeFn.{max (succ u2) (succ u1), max (succ u2) (succ (max u2 u1))} (CategoryTheory.Pretopology.{u1, u2} C _inst_1 _inst_2) (fun (_x : CategoryTheory.Pretopology.{u1, u2} C _inst_1 _inst_2) => forall (X : C), Set.{max u2 u1} (CategoryTheory.Presieve.{u1, u2} C _inst_1 X)) (CategoryTheory.Pretopology.hasCoeToFun.{u1, u2} C _inst_1 _inst_2) K X)) => LE.le.{max u2 u1} (CategoryTheory.Presieve.{u1, u2} C _inst_1 X) (Preorder.toLE.{max u2 u1} (CategoryTheory.Presieve.{u1, u2} C _inst_1 X) (PartialOrder.toPreorder.{max u2 u1} (CategoryTheory.Presieve.{u1, u2} C _inst_1 X) (CompleteSemilatticeInf.toPartialOrder.{max u2 u1} (CategoryTheory.Presieve.{u1, u2} C _inst_1 X) (CompleteLattice.toCompleteSemilatticeInf.{max u2 u1} (CategoryTheory.Presieve.{u1, u2} C _inst_1 X) (CategoryTheory.Presieve.completeLattice.{u2, u1} C _inst_1 X))))) R (coeFn.{max (succ u2) (succ u1), max (succ u2) (succ u1)} (CategoryTheory.Sieve.{u1, u2} C _inst_1 X) (fun (_x : CategoryTheory.Sieve.{u1, u2} C _inst_1 X) => CategoryTheory.Presieve.{u1, u2} C _inst_1 X) (CategoryTheory.Sieve.hasCoeToFun.{u1, u2} C _inst_1 X) S))))
but is expected to have type
  forall (C : Type.{u2}) [_inst_1 : CategoryTheory.Category.{u1, u2} C] [_inst_2 : CategoryTheory.Limits.HasPullbacks.{u1, u2} C _inst_1] (K : CategoryTheory.Pretopology.{u1, u2} C _inst_1 _inst_2) (X : C) (S : CategoryTheory.Sieve.{u1, u2} C _inst_1 X), Iff (Membership.mem.{max u2 u1, max u2 u1} (CategoryTheory.Sieve.{u1, u2} C _inst_1 X) (Set.{max u2 u1} (CategoryTheory.Sieve.{u1, u2} C _inst_1 X)) (Set.instMembershipSet.{max u2 u1} (CategoryTheory.Sieve.{u1, u2} C _inst_1 X)) S (CategoryTheory.GrothendieckTopology.sieves.{u1, u2} C _inst_1 (CategoryTheory.Pretopology.toGrothendieck.{u1, u2} C _inst_1 _inst_2 K) X)) (Exists.{succ (max u2 u1)} (CategoryTheory.Presieve.{u1, u2} C _inst_1 X) (fun (R : CategoryTheory.Presieve.{u1, u2} C _inst_1 X) => And (Membership.mem.{max u2 u1, max u2 u1} (CategoryTheory.Presieve.{u1, u2} C _inst_1 X) (Set.{max u2 u1} (CategoryTheory.Presieve.{u1, u2} C _inst_1 X)) (Set.instMembershipSet.{max u2 u1} (CategoryTheory.Presieve.{u1, u2} C _inst_1 X)) R (CategoryTheory.Pretopology.coverings.{u1, u2} C _inst_1 _inst_2 K X)) (LE.le.{max u2 u1} (CategoryTheory.Presieve.{u1, u2} C _inst_1 X) (Preorder.toLE.{max u2 u1} (CategoryTheory.Presieve.{u1, u2} C _inst_1 X) (PartialOrder.toPreorder.{max u2 u1} (CategoryTheory.Presieve.{u1, u2} C _inst_1 X) (CompleteSemilatticeInf.toPartialOrder.{max u2 u1} (CategoryTheory.Presieve.{u1, u2} C _inst_1 X) (CompleteLattice.toCompleteSemilatticeInf.{max u2 u1} (CategoryTheory.Presieve.{u1, u2} C _inst_1 X) (CategoryTheory.instCompleteLatticePresieve.{u1, u2} C _inst_1 X))))) R (CategoryTheory.Sieve.arrows.{u1, u2} C _inst_1 X S))))
Case conversion may be inaccurate. Consider using '#align category_theory.pretopology.mem_to_grothendieck CategoryTheory.Pretopology.mem_toGrothendieckₓ'. -/
theorem mem_toGrothendieck (K : Pretopology C) (X S) :
    S ∈ toGrothendieck C K X ↔ ∃ R ∈ K X, R ≤ (S : Presieve X) :=
  Iff.rfl
#align category_theory.pretopology.mem_to_grothendieck CategoryTheory.Pretopology.mem_toGrothendieck

#print CategoryTheory.Pretopology.ofGrothendieck /-
/-- The largest pretopology generating the given Grothendieck topology.

See [MM92] Chapter III, Section 2, Equations (3,4).
-/
def ofGrothendieck (J : GrothendieckTopology C) : Pretopology C
    where
  coverings X R := Sieve.generate R ∈ J X
  has_isos X Y f i := J.covering_of_eq_top (by simp)
  pullbacks X Y f R hR := by
    rw [Set.mem_def, sieve.pullback_arrows_comm]
    apply J.pullback_stable f hR
  Transitive X S Ti hS hTi := by
    apply J.transitive hS
    intro Y f
    rintro ⟨Z, g, f, hf, rfl⟩
    rw [sieve.pullback_comp]
    apply J.pullback_stable g
    apply J.superset_covering _ (hTi _ hf)
    rintro Y g ⟨W, h, g, hg, rfl⟩
    exact ⟨_, h, _, ⟨_, _, _, hf, hg, rfl⟩, by simp⟩
#align category_theory.pretopology.of_grothendieck CategoryTheory.Pretopology.ofGrothendieck
-/

/- warning: category_theory.pretopology.gi -> CategoryTheory.Pretopology.gi is a dubious translation:
lean 3 declaration is
  forall (C : Type.{u2}) [_inst_1 : CategoryTheory.Category.{u1, u2} C] [_inst_2 : CategoryTheory.Limits.HasPullbacks.{u1, u2} C _inst_1], GaloisInsertion.{max u2 u1, max u2 u1} (CategoryTheory.Pretopology.{u1, u2} C _inst_1 _inst_2) (CategoryTheory.GrothendieckTopology.{u1, u2} C _inst_1) (PartialOrder.toPreorder.{max u2 u1} (CategoryTheory.Pretopology.{u1, u2} C _inst_1 _inst_2) (CategoryTheory.Pretopology.partialOrder.{u1, u2} C _inst_1 _inst_2)) (PartialOrder.toPreorder.{max u2 u1} (CategoryTheory.GrothendieckTopology.{u1, u2} C _inst_1) (CategoryTheory.GrothendieckTopology.partialOrder.{u1, u2} C _inst_1)) (CategoryTheory.Pretopology.toGrothendieck.{u1, u2} C _inst_1 _inst_2) (CategoryTheory.Pretopology.ofGrothendieck.{u1, u2} C _inst_1 _inst_2)
but is expected to have type
  forall (C : Type.{u2}) [_inst_1 : CategoryTheory.Category.{u1, u2} C] [_inst_2 : CategoryTheory.Limits.HasPullbacks.{u1, u2} C _inst_1], GaloisInsertion.{max u2 u1, max u2 u1} (CategoryTheory.Pretopology.{u1, u2} C _inst_1 _inst_2) (CategoryTheory.GrothendieckTopology.{u1, u2} C _inst_1) (PartialOrder.toPreorder.{max u2 u1} (CategoryTheory.Pretopology.{u1, u2} C _inst_1 _inst_2) (CategoryTheory.Pretopology.instPartialOrderPretopology.{u1, u2} C _inst_1 _inst_2)) (PartialOrder.toPreorder.{max u2 u1} (CategoryTheory.GrothendieckTopology.{u1, u2} C _inst_1) (CategoryTheory.GrothendieckTopology.instPartialOrderGrothendieckTopology.{u1, u2} C _inst_1)) (CategoryTheory.Pretopology.toGrothendieck.{u1, u2} C _inst_1 _inst_2) (CategoryTheory.Pretopology.ofGrothendieck.{u1, u2} C _inst_1 _inst_2)
Case conversion may be inaccurate. Consider using '#align category_theory.pretopology.gi CategoryTheory.Pretopology.giₓ'. -/
/-- We have a galois insertion from pretopologies to Grothendieck topologies. -/
def gi : GaloisInsertion (toGrothendieck C) (ofGrothendieck C)
    where
  gc K J := by
    constructor
    · intro h X R hR
      exact h _ ⟨_, hR, sieve.le_generate R⟩
    · rintro h X S ⟨R, hR, RS⟩
      apply J.superset_covering _ (h _ hR)
      rwa [sieve.gi_generate.gc]
  le_l_u J X S hS := ⟨S, J.superset_covering S.le_generate hS, le_rfl⟩
  choice x hx := toGrothendieck C x
  choice_eq _ _ := rfl
#align category_theory.pretopology.gi CategoryTheory.Pretopology.gi

#print CategoryTheory.Pretopology.trivial /-
/--
The trivial pretopology, in which the coverings are exactly singleton isomorphisms. This topology is
also known as the indiscrete, coarse, or chaotic topology.

See <https://stacks.math.columbia.edu/tag/07GE>
-/
def trivial : Pretopology C
    where
  coverings X S := ∃ (Y : _)(f : Y ⟶ X)(h : IsIso f), S = Presieve.singleton f
  has_isos X Y f i := ⟨_, _, i, rfl⟩
  pullbacks X Y f S := by
    rintro ⟨Z, g, i, rfl⟩
    refine' ⟨pullback g f, pullback.snd, _, _⟩
    · skip
      refine' ⟨⟨pullback.lift (f ≫ inv g) (𝟙 _) (by simp), ⟨_, by tidy⟩⟩⟩
      apply pullback.hom_ext
      · rw [assoc, pullback.lift_fst, ← pullback.condition_assoc]
        simp
      · simp
    · apply pullback_singleton
  Transitive := by
    rintro X S Ti ⟨Z, g, i, rfl⟩ hS
    rcases hS g (singleton_self g) with ⟨Y, f, i, hTi⟩
    refine' ⟨_, f ≫ g, _, _⟩
    · skip
      infer_instance
    ext (W k)
    constructor
    · rintro ⟨V, h, k, ⟨_⟩, hh, rfl⟩
      rw [hTi] at hh
      cases hh
      apply singleton.mk
    · rintro ⟨_⟩
      refine' bind_comp g presieve.singleton.mk _
      rw [hTi]
      apply presieve.singleton.mk
#align category_theory.pretopology.trivial CategoryTheory.Pretopology.trivial
-/

instance : OrderBot (Pretopology C) where
  bot := trivial C
  bot_le K X R := by
    rintro ⟨Y, f, hf, rfl⟩
    exact K.has_isos f

/- warning: category_theory.pretopology.to_grothendieck_bot -> CategoryTheory.Pretopology.toGrothendieck_bot is a dubious translation:
lean 3 declaration is
  forall (C : Type.{u2}) [_inst_1 : CategoryTheory.Category.{u1, u2} C] [_inst_2 : CategoryTheory.Limits.HasPullbacks.{u1, u2} C _inst_1], Eq.{max (succ u2) (succ u1)} (CategoryTheory.GrothendieckTopology.{u1, u2} C _inst_1) (CategoryTheory.Pretopology.toGrothendieck.{u1, u2} C _inst_1 _inst_2 (Bot.bot.{max u2 u1} (CategoryTheory.Pretopology.{u1, u2} C _inst_1 _inst_2) (OrderBot.toHasBot.{max u2 u1} (CategoryTheory.Pretopology.{u1, u2} C _inst_1 _inst_2) (CategoryTheory.Pretopology.hasLe.{u1, u2} C _inst_1 _inst_2) (CategoryTheory.Pretopology.orderBot.{u1, u2} C _inst_1 _inst_2)))) (Bot.bot.{max u2 u1} (CategoryTheory.GrothendieckTopology.{u1, u2} C _inst_1) (CompleteLattice.toHasBot.{max u2 u1} (CategoryTheory.GrothendieckTopology.{u1, u2} C _inst_1) (CategoryTheory.GrothendieckTopology.completeLattice.{u1, u2} C _inst_1)))
but is expected to have type
  forall (C : Type.{u2}) [_inst_1 : CategoryTheory.Category.{u1, u2} C] [_inst_2 : CategoryTheory.Limits.HasPullbacks.{u1, u2} C _inst_1], Eq.{max (succ u2) (succ u1)} (CategoryTheory.GrothendieckTopology.{u1, u2} C _inst_1) (CategoryTheory.Pretopology.toGrothendieck.{u1, u2} C _inst_1 _inst_2 (Bot.bot.{max u2 u1} (CategoryTheory.Pretopology.{u1, u2} C _inst_1 _inst_2) (OrderBot.toBot.{max u2 u1} (CategoryTheory.Pretopology.{u1, u2} C _inst_1 _inst_2) (CategoryTheory.Pretopology.LE.{u1, u2} C _inst_1 _inst_2) (CategoryTheory.Pretopology.instOrderBotPretopologyLE.{u1, u2} C _inst_1 _inst_2)))) (Bot.bot.{max u2 u1} (CategoryTheory.GrothendieckTopology.{u1, u2} C _inst_1) (CompleteLattice.toBot.{max u2 u1} (CategoryTheory.GrothendieckTopology.{u1, u2} C _inst_1) (CategoryTheory.GrothendieckTopology.instCompleteLatticeGrothendieckTopology.{u1, u2} C _inst_1)))
Case conversion may be inaccurate. Consider using '#align category_theory.pretopology.to_grothendieck_bot CategoryTheory.Pretopology.toGrothendieck_botₓ'. -/
/-- The trivial pretopology induces the trivial grothendieck topology. -/
theorem toGrothendieck_bot : toGrothendieck C ⊥ = ⊥ :=
  (gi C).gc.l_bot
#align category_theory.pretopology.to_grothendieck_bot CategoryTheory.Pretopology.toGrothendieck_bot

end Pretopology

end CategoryTheory


import data.complex.basic

namespace cau_seq

theorem const_inv {α β : Type*} [discrete_field β] [discrete_linear_ordered_field α] {abv : β → α}
  [is_absolute_value abv] {x : β} (hx : x ≠ 0) :
  const abv (x⁻¹) = inv (const abv x) (by rwa const_lim_zero) :=
 ext (assume n, by simp[inv_apply, const_apply])

end cau_seq

namespace complex
open cau_seq

lemma re_const_equiv_of_const_equiv {f : ℕ → ℂ} (hf : is_cau_seq abs f) (z : ℂ) :
    cau_seq.const abs z ≈ ⟨f, hf⟩ → cau_seq.const _root_.abs z.re ≈ ⟨(λ (n : ℕ), (f n).re),
    complex.is_cau_seq_re ⟨f,hf⟩⟩ := begin
  assume h,assume ε ε0,cases h ε ε0 with i hi,existsi i,assume j ji,
  replace hi := hi j ji, simp at *, rw [←complex.neg_re,←complex.add_re],
  exact lt_of_le_of_lt (complex.abs_re_le_abs _) hi,
end

lemma im_const_equiv_of_const_equiv {f : ℕ → ℂ} (hf : is_cau_seq abs f) (z : ℂ) :
    cau_seq.const abs z ≈ ⟨f, hf⟩ → cau_seq.const _root_.abs z.im ≈ ⟨(λ (n : ℕ), (f n).im),
    complex.is_cau_seq_im ⟨f,hf⟩⟩ := begin
  assume h,assume ε ε0,cases h ε ε0 with i hi,existsi i,assume j ji,
  replace hi := hi j ji, simp at *, rw [←complex.neg_im,←complex.add_im],
  exact lt_of_le_of_lt (complex.abs_im_le_abs _) hi,
end

lemma eq_lim_of_const_equiv {f : cau_seq ℂ abs}  {z: ℂ} :
    cau_seq.const complex.abs z ≈ f → z = complex.lim f := begin
  assume h,
  unfold complex.lim,cases z with zre zim,simp,
  split, have := real.equiv_lim ⟨(λ (n : ℕ), (f.1 n).re), complex.is_cau_seq_re f⟩,
  rw ←cau_seq.const_equiv,simp at this,
  have hf := complex.re_const_equiv_of_const_equiv f.2 {re := zre, im := zim} h,simp at hf,
  exact setoid.trans hf this,
  have := real.equiv_lim ⟨(λ (n : ℕ), (f.1 n).im), complex.is_cau_seq_im f⟩,
  rw ←cau_seq.const_equiv,simp at this,
  have hf := complex.im_const_equiv_of_const_equiv f.2 {re := zre, im := zim} h,simp at hf,
  exact setoid.trans hf this,
end

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

lemma lim_eq_lim_of_equiv {f g : cau_seq ℂ complex.abs} (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 abs x) = x :=
lim_eq_of_equiv_const $ setoid.refl _

lemma lim_add (f g : cau_seq ℂ complex.abs) : lim f + lim g = lim ⇑(f + g) :=
eq_lim_of_const_equiv $ show lim_zero (const complex.abs (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 ℂ complex.abs) : lim f * lim g = lim ⇑(f * g) :=
eq_lim_of_const_equiv $ show lim_zero (const complex.abs (lim ⇑f * lim ⇑g) - f * g),
  from have h : const complex.abs (lim ⇑f * lim ⇑g) - f * g = g * (const complex.abs (lim f) - f)
      + const complex.abs (lim f) * (const complex.abs (lim g) - g) :=
    by simp [mul_sub, mul_comm, const_mul, mul_add],
  by rw h; exact add_lim_zero (mul_lim_zero _ (setoid.symm (equiv_lim f)))
      (mul_lim_zero _ (setoid.symm (equiv_lim g)))

lemma lim_mul (f : cau_seq ℂ complex.abs) (x : ℂ) : lim f * x = lim ⇑(f * const complex.abs x) :=
by rw [← lim_mul_lim, lim_const]

lemma lim_neg (f : cau_seq ℂ complex.abs) : lim ⇑(-f) = -lim f :=
lim_eq_of_equiv_const (show lim_zero (-f - const complex.abs (-lim ⇑f)),
  by rw [const_neg, sub_neg_eq_add, add_comm];
  exact setoid.symm (equiv_lim f))

lemma lim_eq_zero_iff (f : cau_seq ℂ complex.abs) : 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 complex.abs (0 : ℂ)) := cau_seq.ext (λ n, by simp [sub_apply, const_apply]),
  by rw h₁ at h; exact lim_eq_of_equiv_const h ⟩

lemma lim_inv {f : cau_seq ℂ complex.abs} (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 abs (lim ⇑f)⁻¹),
  from have h₁ : ∀ (g f : cau_seq ℂ abs) (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 _ (setoid.symm (cau_seq.inv_mul_cancel _)),
  have h₂ : lim_zero ((inv f hf - const abs (lim ⇑f)⁻¹) - (const abs (lim f) - f) *
      (inv f hf * const abs (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 abs (lim ⇑f) * (inv f hf * const abs (lim ⇑f)⁻¹)
      - (const abs (lim ⇑f)⁻¹ - f * (inv f hf * const abs (lim ⇑f)⁻¹))),
    from sub_lim_zero
      (by rw [← mul_assoc, mul_right_comm, cau_seq.const_inv hl]; exact h₁ _ _ _)
      (by rw [← mul_assoc]; exact h₁ _ _ _),
  (lim_zero_congr h₂).mpr $ by rw mul_comm; exact mul_lim_zero _ (setoid.symm (equiv_lim f))

end complex


/-
Copyright 2021 Google LLC

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

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

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

import measure_theory.measure_space
import measure_theory.outer_measure
import measure_theory.lebesgue_measure
import measure_theory.integration

import measure_theory.borel_space
import data.set.countable
import formal_ml.nnreal
import formal_ml.sum
import formal_ml.lattice
import formal_ml.measurable_space
import formal_ml.classical
import data.equiv.list
import formal_ml.probability_space
import formal_ml.prod_probability_space
import formal_ml.random_variable_independent_pair
import formal_ml.random_variable_identical_IID

/- This file introduces the uniform probability space over a finite outcome type.
   This is in turn used to define a uniform distribution over permutations. -/

--Probably stay here.------------------------

noncomputable def set.cardF {α:Type*} [F:fintype α] (s:set α):nat :=
  (@set.to_finset α s (@subtype.fintype α s (classical.decidable_pred s) F)).card

lemma set.univ_cardF_eq_fintype_card {α:Type*} [F:fintype α]:
  (@set.univ α).cardF = fintype.card α := begin
  simp [set.cardF],
  have h1:
    @finset.filter α (@set.univ α) (λ (a : α), @set.univ_decidable α a) (@finset.univ α F) =
    (@finset.univ α F),
  { ext1 a, split; intros A1; simp, },
  rw h1,
  simp [fintype.card],
end

lemma finset.disjoint_card_sum {α β:Type*} [decidable_eq α] [fintype α] [decidable_eq β]
  (f:β → finset α) (h:pairwise (disjoint on f)) (t:finset β):∀ (s:finset α),
  (⋃ (x:β) (h2:x∈ t), (@coe (finset α) (set α) _ (f x))) = ↑s → (s.card = t.sum (λ x, (f x).card)) := begin
  classical,
  apply finset.induction_on t,
  { intros s h1, simp, simp at h1,
    rw finset.ext_iff,
    intros a,
    rw set.ext_iff at h1,
    have h2 := h1 a,
    simp at h2,
    simp,
    apply h2 },
  { intros a s h3 h4 t' h5,
    rw finset.sum_insert,
    simp at h5,
    have h6:(f a) ∪ ((⋃ (x : β) (H : x ∈ s), ↑(f x)).to_finset) = t',
    { rw set.ext_iff at h5,
      rw finset.ext_iff,
      intros a',
      have h6_1 := h5 a',
      rw finset.mem_coe at h6_1,
      rw ← h6_1,
      split; intros h6_2; simp at h6_2; simp [h6_2] },
    rw ← h4 ((⋃ (x : β) (H : x ∈ s), ↑(f x)).to_finset),
    rw ← finset.card_union_eq,
    rw h6,
    rw disjoint_iff,
    simp, ext x, split; intros h1, simp at h1, cases h1 with h1 h2,
    cases h2 with i h2,
    cases h2 with h2 h7,
    have h8:i ≠ a,
    { intros contra,
       subst i, apply h3, apply h2,  },

    have h9 := h i a h8,
    simp [function.on_fun] at h9,
    rw disjoint_iff at h9,
    simp at h9,
    rw ← h9,
    simp [h1, h7],
    exfalso,
    apply h1,
    simp,
    apply h3,
         },

end

def semiring.of_nat_hom (α:Type*) [semiring α]:nat →+* α := {
  to_fun := coe,
  map_one' := begin
    simp,
  end,
  map_mul' := begin
   intros x y,
   simp,
  end,
  map_add' := begin
    intros x y,
    simp,
  end,
  map_zero' := begin
    simp,
  end
}

lemma finset.prod_coe_nat {α β:Type*} [comm_semiring α] {s:finset β} {f:β → nat}:
  (@coe nat α _) (s.prod f) = s.prod (λ (b:β), (@coe nat α _) (f b)) := begin
  have h1:(@coe nat α _) = (semiring.of_nat_hom α).to_fun,
  { refl },
  rw h1,
  simp,
end

lemma finset.sum_coe_nat {α β:Type*} [comm_semiring α] {s:finset β} {f:β → nat}:
  (@coe nat α _) (s.sum f) = s.sum (λ (b:β), (@coe nat α _) (f b)) := begin
  have h1:(@coe nat α _) = ⇑(semiring.of_nat_hom α),
  { refl },
  rw h1,
  rw ring_hom.map_sum,
end

/- TODO: reverse direction if you get a chance. -/
lemma disjoint_to_finset_iff {α:Type*} [F:fintype α] [decidable_eq α]
  {s t:set α} [decidable_pred s] [decidable_pred t]:disjoint s t ↔ disjoint (s.to_finset) (t.to_finset) :=
begin
  rw disjoint_iff,
  rw disjoint_iff,
  rw set.ext_iff,
  rw finset.ext_iff,
  simp, split; intros h1 x; have h2 := h1 x,
  { split; intros h3, apply absurd h3.right,
    apply h2, apply h3.left,  exfalso, apply h3 },
  { intros h3 h4, have h5 := and.intro h3 h4,
    rw h2 at h5, apply h5 },
end

---DEFINITELY stay here.--------------------

noncomputable def uniform_measure (α:Type*) [F:fintype α]:
  @measure_theory.measure α ⊤  := @measure_theory.measure.of_measurable α ⊤
  (λ (s:set α) (h:@measurable_set α ⊤ s),
  ((s.cardF):ennreal)/((fintype.card α):ennreal))
begin
  simp [set.cardF],
end
begin
  classical,
  intros f h_meas h_disjoint,
  let s:finset α := (⋃ (i : ℕ), f i).to_finset,
  begin
    simp,
    have h0:s = (⋃ (i : ℕ), f i).to_finset := rfl,
    rw div_eq_mul_inv,
    have h2:(λ (i:ℕ), (((f i).cardF):ennreal) / ((@fintype.card α F):ennreal)) =
         λ (i:ℕ), (((f i).cardF):ennreal) * ((@fintype.card α F):ennreal)⁻¹,
    { ext1 i, rw div_eq_mul_inv },
    rw h2,
    rw ennreal.tsum_mul_right,
    have h3:↑((@set.Union α ℕ f).cardF) = (∑' (i : ℕ), ↑((f i).cardF)),
    {

       have h4:∀ (x:α), ∃ (i:ℕ), x∈ s → x ∈ f i,
       { intros x, cases classical.em (x ∈ s) with h4_1 h4_1,
         rw h0 at h4_1,simp at h4_1, cases h4_1 with i h4_1,
         apply exists.intro i, intros h4_2, apply h4_1,
         apply exists.intro 0, intros h4_2, apply absurd h4_2, apply h4_1,  },
       rw classical.skolem at h4,
       cases h4 with g h4,
       let t := s.image g,
       rw @tsum_eq_sum ennreal ℕ _ _ _ _ t,
       have h5:s.card = (@set.Union α ℕ f).cardF,
       { simp [set.cardF], have h5_1:(λ (x : α), ∃ (i : ℕ), x ∈ f i) = (set.Union f),
         { ext;split; intros A1; simp at A1; cases A1 with i A1;
           simp; apply exists.intro i; apply A1, },
         rw h5_1,  },
       rw ← h5,
       rw ← finset.sum_coe_nat,
       simp only [nat.cast_inj, set.cardF],
       rw ← finset.disjoint_card_sum,
       { intros i j h_ne, simp [function.on_fun], rw ← disjoint_to_finset_iff,
         apply h_disjoint, apply h_ne },
       { simp, ext a, split, intros h6, simp at h6, simp,
         { cases h6 with a' h6,  cases h6 with h6 h7,
           apply exists.intro (g a'), apply h7 },
         { intros h6, simp, apply exists.intro a, split,
           { simp at h6, apply h6 },
           { apply h4, simp [s], simp at h6, apply h6 }, } },
         intros i h8,
         have h9:f i = ∅,
         { ext a, split; intros A1,
           exfalso, apply h8,
           have h9_1:a ∈ s,
           { simp [s], apply exists.intro i, apply A1 },
           have h9_2:a∈ f (g a) := h4 a h9_1,
           have h9_3:g a = i,
           { apply by_contradiction,
             intros h9_3_1,
             have h9_3_2:disjoint (f (g a)) (f i),
             { apply h_disjoint, apply h9_3_1, },
             rw disjoint_iff at h9_3_2,
             simp at h9_3_2,
             have h9_3_3:a∈ (f (g a)) ∩ (f i),
             { simp, apply and.intro h9_2 A1 },
             rw h9_3_2 at h9_3_3,
             apply h9_3_3 },
           subst i, simp [t], apply exists.intro a,
           split,
           apply exists.intro (g a),
           apply A1, refl, exfalso, apply A1 },
         rw h9,
         simp [set.cardF], refl,
     },
     rw h3,
  end
end

lemma uniform_measure_apply (α:Type*) [F:fintype α] (s:set α):
  (uniform_measure α) s =
  ((s.cardF):ennreal)/((fintype.card α):ennreal) := begin
  apply measure_theory.measure.of_measurable_apply,
  simp,
end

noncomputable def uniform_measure_space (α:Type*) [F:fintype α]:
  measure_theory.measure_space α := @measure_theory.measure_space.mk α ⊤
  (uniform_measure α)

lemma uniform_measure_space_apply (α:Type*) [F:fintype α] (s:set α):
  @measure_theory.measure_space.volume _ (uniform_measure_space α) s =
  ((s.cardF):ennreal)/((fintype.card α):ennreal) := begin
  have h1: (@measure_theory.measure_space.volume α (@uniform_measure_space α F)) =
           (uniform_measure α),
  { refl },
  rw h1,
  apply uniform_measure_apply,
end

lemma uniform_measure_space.to_measurable_space_eq_top (α:Type*) [F:fintype α]:
  (uniform_measure_space α).to_measurable_space = ⊤ := rfl

lemma uniform_measure_space.measurable_set'_all (α:Type*) [F:fintype α] (s:set α):
  (uniform_measure_space α).to_measurable_space.measurable_set' s := begin
  rw uniform_measure_space.to_measurable_space_eq_top,
  apply measurable_space.measurable_set_top,
end

/- DO NOT DELETE!
   There is already proven:
   1. permutations are finite.
   2. There cardinality is the factorial.
   This tells me we are on the right track! -/
#check fintype.card_perm

lemma fintype.card_ne_zero {α:Type*} [F:fintype α] [N:nonempty α]:
  ¬(fintype.card α = 0) := begin
  apply pos_iff_ne_zero.1,
  rw fintype.card_pos_iff,
  apply N,
end

noncomputable def uniform_probability_space (α:Type*) [F:fintype α] [N:nonempty α]:
  probability_space α := @probability_space.mk α (uniform_measure_space α)
begin
  simp,
  rw uniform_measure_space_apply,
  rw set.univ_cardF_eq_fintype_card,
  rw div_eq_mul_inv,
  apply ennreal.mul_inv_cancel,
  { simp, apply fintype.card_ne_zero },
  { simp },
end

lemma uniform_probability_space.to_measurable_space_eq_top (α:Type*) [F:fintype α] [NE:nonempty α]:
  (uniform_probability_space α).to_measurable_space = ⊤ := rfl

lemma uniform_probability_space.to_measure_space_eq (α:Type*) [F:fintype α] [NE:nonempty α]:
  (uniform_probability_space α).to_measure_space = uniform_measure_space α := rfl

lemma uniform_probability_space.measurable_set'_all (α:Type*) [F:fintype α] [nonempty α] (s:set α):
  (uniform_probability_space α).to_measurable_space.measurable_set' s := begin
  rw uniform_probability_space.to_measurable_space_eq_top,
  apply measurable_space.measurable_set_top,
end

def uniform_event {α:Type*} (s:set α) [F:fintype α] [N:nonempty α]:
  event (uniform_probability_space α) := {
  val := s,
  property := begin
    apply uniform_probability_space.measurable_set'_all,
  end
}

def uniform_probability_space.measurable_all {α β:Type*} [F:fintype α] [nonempty α]
(M:measurable_space β) (f:α → β):@measurable α β
  (uniform_probability_space α).to_measurable_space M f := begin
  intros S h1,
  apply uniform_probability_space.measurable_set'_all,
end

lemma uniform_probability_space_apply' (α:Type*) [F:fintype α] [nonempty α] (s:event (uniform_probability_space α)):
  Pr[s] =
  ((s.val.cardF):nnreal)/((fintype.card α):nnreal) := begin
  rw ← ennreal.coe_eq_coe,
  rw event_prob_def,
  rw uniform_probability_space.to_measure_space_eq,
  simp,
  rw ← subtype.val_eq_coe,
  rw @uniform_measure_space_apply α F s.val,
  rw ennreal.coe_div,
  have h1:∀ (n:ℕ), (@coe nnreal ennreal _ (@coe nat nnreal _ n)) = (@coe nat ennreal _ n),
  { simp },
  rw h1,
  rw h1,
  simp,
  apply fintype.card_ne_zero,
end

lemma uniform_probability_space_apply (α:Type*) [F:fintype α] [nonempty α] (s:set α):
  Pr[uniform_event s] =
  ((s.cardF):nnreal)/((fintype.card α):nnreal) := begin
  apply uniform_probability_space_apply',
end

def uniform_rv {α:Type*} [F:fintype α] [N:nonempty α] (M:measurable_space α):
  (uniform_probability_space α) →ᵣ M := {
  val := id,
  property := begin
    apply uniform_probability_space.measurable_all,
  end
}

def is_uniform_rv {Ω α:Type*} {P:probability_space Ω} [F:fintype α] {M:measurable_space α}
  (X:P →ᵣ M):Prop := ∀ (S:measurable_setB M),
  Pr[X ∈ᵣ S] = ((S.val.cardF):nnreal)/((fintype.card α):nnreal)

@[simp]
lemma is_uniform_rv_uniform_rv {α:Type*} [F:fintype α] [N:nonempty α] (M:measurable_space α):
  is_uniform_rv (uniform_rv M) := begin
  intros S,
  let S':= uniform_event S.val,
  begin
    have h1:@uniform_rv α F N M ∈ᵣ S = S',
    { apply event.eq, simp [uniform_rv, S', uniform_event], },
    rw h1,
    rw uniform_probability_space_apply,
  end
end

def nonempty_perm {α:Type*}:nonempty (equiv.perm α) := nonempty.intro (equiv.refl α)

def uniform_perm_rv (α:Type*) [D:decidable_eq α] [F:fintype α] (M:measurable_space (equiv.perm α)):_ →ᵣ M :=
  --(@uniform_probability_space (equiv.perm α) (@fintype_perm α D F) nonempty_perm) →ᵣ M :=
  @uniform_rv (equiv.perm α) (@fintype_perm α D F) nonempty_perm M

lemma is_uniform_rv_uniform_perm_rv {α:Type*} [F:fintype α] [N:decidable_eq α]
  (M:measurable_space (equiv.perm α)):
  @is_uniform_rv _ (equiv.perm α) _ (@fintype_perm α N F) _ (@uniform_perm_rv α N F M) := begin
  apply is_uniform_rv_uniform_rv,
end

lemma select_rv_union_helper {Ω α γ:Type*} [fintype α] [decidable_eq α] {P:probability_space Ω}
   {M:measurable_space γ} (TM:top_measurable α)
   (X:α → P →ᵣ M) (Y:P →ᵣ (TM.to_measurable_space)) (S:set γ):
   ((λ (ω : Ω), (X (Y.val ω)).val ω) ⁻¹' S) =
      ⋃ (a:α), ((Y.val ⁻¹' {a}) ∩ ((X a).val ⁻¹' S)) := begin
  ext1 ω,split; intros h1; simp at h1; simp [h1],
end

def select_rv {Ω α γ:Type*} [fintype α] [decidable_eq α] {P:probability_space Ω}
 {M:measurable_space γ}
 {TM:top_measurable α} (X:α → P →ᵣ M) (Y:P →ᵣ TM.to_measurable_space):
  P →ᵣ M := {
  val := (λ ω:Ω, (X (Y.val ω)).val ω),
  property := begin
    intros S h1,
    have h2:((λ (ω : Ω), (X (Y.val ω)).val ω) ⁻¹' S) =
      ⋃ (a:α), ((Y.val ⁻¹' {a}) ∩ ((X a).val ⁻¹' S)),
    { apply select_rv_union_helper },
    rw h2,
    haveI:encodable α := fintype.encodable α,
    apply measurable_set.Union,
    intros a,
    apply measurable_set.inter,
    apply Y.property,
    apply TM.all_measurable,
    apply (X a).property,
    apply h1,
  end
}

lemma select_rv_apply {Ω α γ:Type*} [fintype α] [decidable_eq α] {P:probability_space Ω}
   {M:measurable_space γ} {TM:top_measurable α}
   (X:α → P →ᵣ M) (Y:P →ᵣ (TM.to_measurable_space)) (S:measurable_setB M):
   (select_rv X Y ∈ᵣ S) = (∃ᵣ (a:α), ((Y =ᵣ a) ∧ ((X a) ∈ᵣ S))) := begin
  apply event.eq,
  simp [select_rv],
  ext; split; intros h1; simp at h1; simp [h1],
end

def perm_value_rv {Ω α:Type*} [fintype α] [decidable_eq α] {P:probability_space Ω}
  {TMp:top_measurable (equiv.perm α)}
  (Y:P →ᵣ (TMp.to_measurable_space)) (a:α)
  (M:measurable_space α):
  P →ᵣ M := {
  val := (λ ω:Ω, (Y.val ω) a),
  property := begin
    classical,
    intros S A1,
    let T := {p:equiv.perm α|p a ∈ S},
    begin
      have h1:((λ (ω : Ω), (Y.val ω) a) ⁻¹' S) = ⋃ (p∈ T), ((Y.val) ⁻¹' {p}),
      { ext ω, split; intros h1_1; simp [T] at h1_1; simp [h1_1,T] },
      rw h1,
      haveI:encodable (equiv.perm α) := fintype.encodable (equiv.perm α),
      apply measurable_set.Union,
      intros p,
      apply measurable_set.Union_Prop,
      intros h2,
      apply Y.property,
      apply TMp.all_measurable,
    end
  end
}

lemma perm_value_rv_apply {Ω α:Type*} [fintype α] [decidable_eq α] {P:probability_space Ω}
  {TMp:top_measurable (equiv.perm α)}
  (Y:P →ᵣ (TMp.to_measurable_space)) (a:α)
  (M:measurable_space α) (S:measurable_setB M)
  [D:decidable_pred (λ (p:equiv.perm α), p a ∈ S.val)]:
  (perm_value_rv Y a M) ∈ᵣ S =
   ∃ᵣ (p:equiv.perm α) in (set.to_finset (λ (p:equiv.perm α), p a ∈ S.val)),
    (Y =ᵣ p) :=
begin
  apply event.eq, ext ω, split; intros h1; simp [perm_value_rv] at h1;
  simp [perm_value_rv, h1]; apply h1,
end

--set_option pp.implicit true
lemma perm_value_rv_independent {Ω α κ:Type*} [fintype α] [decidable_eq α] {P:probability_space Ω}
  {TMp:top_measurable (equiv.perm α)}
  {Mκ:measurable_space κ}
  (Y:P →ᵣ (TMp.to_measurable_space)) (a:α) (X:P →ᵣ Mκ)
  (M:measurable_space α):
  random_variable_independent_pair X Y →
  random_variable_independent_pair X (perm_value_rv Y a M) :=
begin
  classical,
  intro h1,
  intros S T,
  rw perm_value_rv_apply,
  apply independent_event_pair_exists,
  { intros p h2,
    have h3:Y =ᵣ ↑p = Y ∈ᵣ ({p}:set (equiv.perm α)),
    { apply equal_eq_mem },
    rw h3,
    apply h1 },
  intros i h2 j h3 h_ne,
  simp [function.on_fun, disjoint_iff],

  { ext ω, split; intros h3,
   { simp at h3, exfalso, apply h_ne,
     cases h3, subst i, subst j },
   { exfalso, apply h3 } },
end

def permute_rv {Ω α γ:Type*} [fintype α] [decidable_eq α] {P:probability_space Ω}
   {TM:top_measurable (equiv.perm α)}
    {M:measurable_space γ} (X:α → P →ᵣ M) (perm:P →ᵣ TM.to_measurable_space)
     (TMα:top_measurable α):
   α → P  →ᵣ M := (λ (a:α), select_rv X (perm_value_rv perm a TMα))

lemma permute_rv_identical {Ω α γ:Type*} [F:fintype α] [decidable_eq α]
  {P:probability_space Ω}
   {M:measurable_space γ} {TM:top_measurable (equiv.perm α)}
  (TMα:top_measurable α)
  (X:α → P →ᵣ M) (perm:P →ᵣ (TM.to_measurable_space)):
  (∀ (a:α), random_variable_independent_pair perm (X a)) →
  (∀ (a a':α), random_variable_identical (X a) (X a')) →
  (∀ (a a':α), random_variable_identical (X a) ((permute_rv X perm TMα) a'))
   := begin
  intros h1 h2 a a',
  simp [permute_rv],
  intros S,
  rw select_rv_apply,
  have h3:eany_finset finset.univ (λ (a : α), perm_value_rv perm a' TMα =ᵣ a∧X a ∈ᵣ S)
           = (∃ᵣ (a : α), perm_value_rv perm a' TMα =ᵣ a∧X a ∈ᵣ S),
  {
    apply event.eq, simp,
  },
  rw ← h3,
  haveI:encodable α := fintype.encodable α,
  rw Pr_sum_disjoint_eq,
  have h4:(λ (b : α), Pr[perm_value_rv perm a' TMα =ᵣ b∧X b ∈ᵣ S]) =
    (λ (b : α), Pr[perm_value_rv perm a' TMα =ᵣ b] * Pr[X a ∈ᵣ S]),
  { ext b,
    have h4_1:random_variable_independent_pair (X b) perm,
    { apply random_variable_independent_pair.symm, apply (h1 b), },
    have h4_2 := perm_value_rv_independent perm a' (X b) TMα.to_measurable_space h4_1,
    have h4_3:(perm_value_rv perm a' TMα =ᵣ b) =
              perm_value_rv perm a' TMα ∈ᵣ (measurable_setB_top {b}),
    { apply equal_eq_mem },
    rw h4_3,
    have h4_4:independent_event_pair
                (perm_value_rv perm a' TMα ∈ᵣ (measurable_setB_top {b})) (X b ∈ᵣ S),
    { apply random_variable_independent_pair.symm,
      apply h4_2, },
    unfold independent_event_pair at h4_4,
    rw h4_4,
    --rw mul_comm,
    simp,
    left, apply h2 b a,
     },
   rw h4,
   rw ← @finset.sum_mul α nnreal finset.univ,
   rw  Pr_sum_univ_eq_one,
   simp,
   intros i j h_ne,
   rw function.on_fun,
   rw disjoint_iff,
   simp,
   ext ω, split; intros A1; simp at A1; simp [A1],
   apply h_ne,
   rw ← A1.left.left,
   rw ← A1.right.left,
   apply false.elim A1,
end

lemma random_variables_independent_proj {Ω α β γ:Type*} [fintype α] [fintype β]
  (P:probability_space Ω) (M:measurable_space γ) (X:α → P →ᵣ M) (f:β → α):
  (function.injective f) →
  (random_variable_independent X) →
  (random_variable_independent (λ (b:β), X (f b))) := begin
  classical,
  intros h1 h2,
  intros g T,
  simp,
  have h3:∀ (a:α), ∃ (S:measurable_setB M), ∀ (b:β), (f b = a) → (g b = S),
  { intros a, cases classical.em (∃ (b:β), f b = a) with h3_1 h3_1,
    { cases h3_1 with b h3_1,
      apply exists.intro (g b),
      intros b' h_b',
      rw ← h3_1 at h_b',
      have h3_2 := h1 h_b', rw h3_2 },
    { apply exists.intro measurable_setB_univ,
      intros b'  h_b',
      exfalso,
      apply h3_1,
      apply exists.intro b',
      apply h_b' }, },
  have h4 := classical.axiom_of_choice h3,
  cases h4 with g' h4,
  have h5:∀ (b:β), g b = g' (f b),
  { intros b, apply h4 (f b) b _, refl },
  have h6:(λ (b : β), Pr[X (f b) ∈ᵣ g b]) = (λ (a:α), Pr[X a ∈ᵣ g' a]) ∘ f,
  { ext1 b, simp, rw h5 },
  rw h6,
  have h7:T.prod ((λ (a:α), Pr[X a ∈ᵣ g' a]) ∘ f) = (T.image f).prod (λ (a:α), Pr[X a ∈ᵣ g' a]),
  { rw finset.prod_image, intros b h_b b' h_b' h_eq,
    apply h1, apply h_eq },
  rw h7,
  have h8: (∀ᵣ (s : β) in T,X (f s) ∈ᵣ g s) = (∀ᵣ (a:α) in (T.image f), X a ∈ᵣ g' a),
  { apply event.eq, simp, ext ω, split; intros h8_1; simp at h8_1; simp [h8_1];
    intros i h_i,
    { rw ← h5, apply h8_1 i h_i },
    { rw h5, apply h8_1 i h_i } },
  rw h8,
  apply h2,
end

lemma random_variables_IID_proj {Ω α β γ:Type*} [fintype α] [fintype β]
  (P:probability_space Ω) (M:measurable_space γ) (X:α → P →ᵣ M) (f:β → α):
  (function.injective f) →
  (random_variables_IID X) →
  (random_variables_IID (λ (b:β), X (f b))) := begin
  intros h1 h2, split,
  { apply random_variables_independent_proj, apply h1, apply h2.left },
  intros i j,
  apply h2.right,
end

lemma random_variable_independent_pair_combine_apply {Ω α γ κ:Type*}
  [F:fintype α]
  {P:probability_space Ω}
   {M:measurable_space γ} {Mκ:measurable_space κ}
  (X:P →ᵣ Mκ) (Y:α → P →ᵣ M) (a:α):
  random_variable_independent_pair X (pi.random_variable_combine Y) →
  random_variable_independent_pair X (Y a) := begin
  intros h1,
  intros S₁ S₂,
  have h2:(Y a ∈ᵣ S₂) = ((mf_pi (λ (a:α), M) a) ∘r (pi.random_variable_combine Y)) ∈ᵣ S₂,
  { apply event.eq, simp, split; intros h2_1; simp at h2_1; simp at h2_1, },
  rw h2,
  rw rv_compose_measurable_setB,
  apply h1,
end

lemma pairwise_disjoint_left {Ω α:Type*}
  {P:probability_space Ω}
  {E F:α → event P}:
  (pairwise (disjoint on (λ a, (E a).val))) →
 (pairwise (disjoint on (λ a, (E a ∧ F a).val))) := begin
  intros h1,
  intros i j h_eq,
  have h2 := h1 i j h_eq,
  simp [function.on_fun],
  simp [function.on_fun] at h2,
  rw disjoint_iff,
  rw disjoint_iff at h2,
  simp,
  rw ← set.subset_empty_iff,
  apply set.subset.trans,
  apply set.inter_subset_inter,
  apply set.inter_subset_left,
  apply set.inter_subset_left,
  simp at h2,
  rw h2,
end

/- Take a given event: The arugment for this is that for any fixed permutation,
   the IID property holds. If we can show that this holds for every permutation,
   then we will be done. -/
lemma permute_rv_independent {Ω α γ:Type*} [F:fintype α] [D:decidable_eq α] [inhabited α]
  {P:probability_space Ω}
   {M:measurable_space γ} {TM:top_measurable (equiv.perm α)}
  {TMα:top_measurable α}
  (X:α → P →ᵣ M) (perm:P →ᵣ (TM.to_measurable_space)):
  (random_variable_independent_pair perm (pi.random_variable_combine X)) →
  (random_variables_IID X) →
  (random_variable_independent (permute_rv X perm TMα)) := begin
  intros h1 h2,
  intros S T,
  simp,
  let a := inhabited.default α,
  begin
    have h4:∀ (S:measurable_setB M), ∀ (a':α),
       Pr[X a' ∈ᵣ S] = Pr[X a ∈ᵣ S],
    { intros S a', apply h2.right a' a },
    have h_pair_ind:∀ (a':α), random_variable_independent_pair perm (X a'),
    { intros a', apply random_variable_independent_pair_combine_apply perm X a' h1 },
    have h5:∀ (S:measurable_setB M), ∀ (a':α),
       Pr[permute_rv X perm TMα a' ∈ᵣ S] = Pr[X a ∈ᵣ S],
    { intros S a', symmetry,
      have h5_1 := permute_rv_identical TMα X perm h_pair_ind _ a a',
      apply h5_1,
      apply h2.right },
    rw @finset.prod_congr α nnreal _ T _   (λ (b:α), Pr[X a ∈ᵣ S b]),
    have h7:(∀ᵣ (s : α) in T, permute_rv X perm TMα s ∈ᵣ S s) =
      eany_finset (finset.univ) (λ (p:equiv.perm α), (perm =ᵣ p) ∧
          (∀ᵣ (s : α) in (T.image p),X s ∈ᵣ S (p.inv_fun s))),
    { apply event.eq, ext ω, split; intros h7_1;
      simp [equiv_cancel_left, permute_rv, select_rv, perm_value_rv] at h7_1;
      simp [equiv_cancel_left, permute_rv, select_rv, perm_value_rv, h7_1]; intros i h_i,
      { rw equiv_cancel_left, apply h7_1 i h_i },
      { have h7_2 := h7_1  i h_i, rw equiv_cancel_left at h7_2, apply h7_2 } },
    rw h7,
    --haveI:fintype (equiv.perm α) := infer_instance,
    haveI E:encodable (equiv.perm α) := fintype.encodable (equiv.perm α),
    rw @Pr_sum_disjoint_eq Ω (equiv.perm α) P,
    have h8:(λ (b : equiv.perm α), Pr[perm =ᵣ ↑b∧∀ᵣ (s : α) in (T.image b),X s ∈ᵣ S (b.inv_fun s)]) =
       (λ (b : equiv.perm α), T.prod (λ a', Pr[X a ∈ᵣ S a']) * Pr[perm =ᵣ ↑b]),
    { ext1 b,
      have h8_1:independent_event_pair (perm =ᵣ b) (∀ᵣ (s : α) in (T.image b),X s ∈ᵣ S (b.inv_fun s)),
      { apply random_variable_independent_pair_apply h1,
        apply equal_eq_mem_exists,
        apply joint_random_variable_mem_exists X (T.image b) (S ∘ (b.inv_fun)),
         },
      unfold independent_event_pair at h8_1,
      rw h8_1,
      rw mul_comm,
      have h8_2:random_variable_independent X :=h2.left,
      have h8_3:independent_events (λ (s : α),X s ∈ᵣ S (b.inv_fun s)),
      { apply h8_2 },
      rw ← h8_3 (T.image b), rw finset.prod_image, simp,
      left,
      apply finset.prod_congr, refl, intros x h_x, rw equiv_cancel_left, apply h4,
      intros i h_i j h_j h_eq, simp at h_eq, apply h_eq },
    rw h8,
    rw finset.sum_distrib_left,
    have h9:finset.univ.sum (λ (a : equiv.perm α), Pr[perm =ᵣ ↑a]) = 1,
    { rw Pr_sum_univ_eq_one },
    rw h9,
    simp,
    { apply pairwise_disjoint_left, apply event_eq_disjoint },
    refl,
    { intros x h_x, rw h5 },
  end
end

lemma permute_rv_IID' {Ω α γ:Type*} [fintype α] [decidable_eq α] [I:inhabited α]
  {P:probability_space Ω}
   {M:measurable_space γ} {TM:top_measurable (equiv.perm α)}
  {TMα:top_measurable α}
  (X:α → P →ᵣ M) (perm:P →ᵣ (TM.to_measurable_space)):
  (random_variables_IID X) →
  (random_variable_independent_pair perm (pi.random_variable_combine X)) →
  (random_variables_IID (permute_rv X perm TMα)) := begin
  intros h1 h2,
  split,
  apply permute_rv_independent,
  apply h2,
  apply h1,
  have h4:∀ (a a'), random_variable_identical (X a) (permute_rv X perm TMα a'),
  { apply permute_rv_identical,
    intros a'',
    apply random_variable_independent_pair_combine_apply,
    apply h2,
    apply h1.right },
  intros i j,
  apply random_variable_identical.trans,
  apply random_variable_identical.symm,
  apply h4 (inhabited.default α) i,
  apply h4,
end

lemma permute_rv_IID {Ω α γ:Type*} [fintype α] [decidable_eq α] {P:probability_space Ω}
   {M:measurable_space γ} {TM:top_measurable (equiv.perm α)}
  {TMα:top_measurable α}
  (X:α → P →ᵣ M) (perm:P →ᵣ (TM.to_measurable_space)):
  (random_variables_IID X) →
  (random_variable_independent_pair perm (pi.random_variable_combine X)) →
  (random_variables_IID (permute_rv X perm TMα)) := begin
  classical,
  cases classical.em (nonempty α) with h1 h1,
  { haveI:inhabited α := classical.inhabited_of_nonempty h1,
    apply permute_rv_IID' },
  intros h2 h3, apply random_variables_IID_empty,
  apply h1,
end

/--
   This is a core result, that a partition of an IID random variable results in two independent
   random variables.
   It is not as trivial as it appears, as one must handle events that expose correlations
   within each set. Again, the monotone class theorem is useful.

   Note: functions do not have to be injective, nor does β₁ or β₂ have to be nonempty.
   However, this can be used to prove the case when they
   are not, as you can create an injective function as an intermediate step,
   and case-based analysis can handle the cases where β₁ or β₂ are empty. -/
lemma random_variables_independent_disjoint_proj {Ω α β₁ β₂ γ:Type*} [fintype α] [fintype β₁] [fintype β₂] [nonempty β₁] [nonempty β₂]
  (P:probability_space Ω) (M:measurable_space γ) (X:α → P →ᵣ M) (f₁:β₁ → α) (f₂:β₂ → α):
  (function.injective f₁) →
  (function.injective f₂) →
  (disjoint (set.range f₁) (set.range f₂)) →
  (random_variable_independent X) →
  (random_variable_independent_pair (pi.random_variable_combine (λ (b:β₁), X (f₁ b))) (pi.random_variable_combine (λ (b:β₂), X (f₂ b)))) := begin
  intros h1 h2 h_disjoint_range h3,
  haveI:encodable β₁ := fintype.encodable β₁,
  haveI:encodable β₂ := fintype.encodable β₂,
  apply random_variable_independent_pair_on_semialgebra' pi_base,
  apply pi_base_is_semialgebra,
  apply pi_base_is_semialgebra,
  apply pi_base_eq_measurable_space_pi,
  apply pi_base_eq_measurable_space_pi,
  intros T₁ T₂ h_T₁ h_T₂,
  unfold independent_event_pair,
  have h_T₁_def := pi_base_eq T₁ h_T₁,
  have h_T₂_def := pi_base_eq T₂ h_T₂,
  cases h_T₁_def with g₁ h_T₁_def,
  cases h_T₂_def with g₂ h_T₂_def,
  subst T₁,
  subst T₂,
  classical,
  let U₁:finset α := (finset.image f₁ (@finset.univ β₁ _)),
  let U₂:finset α := (finset.image f₂ (@finset.univ β₂ _)),
  begin
    have h_mem_U₁:∀ (a:α), a ∈ U₁ ↔ a ∈ (set.range f₁),
    { simp [U₁], },
    have h_mem_U₂:∀ (a:α), a ∈ U₂ ↔ a ∈ (set.range f₂),
    { simp [U₂], },
    have h_b₁_ne_b₂:∀ (b₁:β₁) (b₂:β₂), f₁ b₁ ≠ f₂ b₂,
    { intros b₁ b₂ h_contra,
      rw disjoint_iff at h_disjoint_range,
      simp at h_disjoint_range,
      rw ← set.subset_empty_iff at h_disjoint_range,
      rw set.subset_def at h_disjoint_range,
      apply h_disjoint_range (f₁ b₁),
      rw set.mem_inter_iff,
      split,
      simp,
      rw h_contra,
      simp },

    have h_disjoint:disjoint U₁ U₂,
    { rw disjoint_iff, simp, ext a, split; intros h_sub1,
      { exfalso,
        rw finset.mem_inter at h_sub1,
        rw h_mem_U₁ at h_sub1,
        rw h_mem_U₂ at h_sub1,
        rw ← set.mem_inter_iff at h_sub1,
        rw disjoint_iff at h_disjoint_range,
        simp at h_disjoint_range,
        rw ← set.subset_empty_iff at h_disjoint_range,
        rw set.subset_def at h_disjoint_range,
        --have h_disjoint_range_contra := h_disjoint_range a h_sub1,
        apply h_disjoint_range,
        apply h_sub1 },
      { exfalso, apply h_sub1 } },
    have h_inv:∀ (a:α), ∃ (S:measurable_setB M),
      (∀ (b:β₁), f₁ b = a → S = g₁ b) ∧ (∀ (b:β₂), f₂ b = a → S = g₂ b),
    { intros a,
      cases classical.em (∃ (b:β₁), f₁ b = a) with h_in_U₁ h_notin_U₁,
      { cases h_in_U₁ with b₁ h_b₁,
        subst a,
        apply exists.intro (g₁ b₁),
        split,
        { intros b₁' h_b₁', simp [h1] at h_b₁', subst b₁' },
        { intros b₂' h_b₂', exfalso, apply h_b₁_ne_b₂ b₁ b₂', rw h_b₂' } },
      -- If a is not in U₁, then we consider when it is in U₂.
      cases classical.em (∃ (b₂:β₂), f₂ b₂ = a) with h_in_U₂ h_notin_U₂,
      { cases h_in_U₂ with b₂ h_b₂,
        subst a,
        apply exists.intro (g₂ b₂),
        split,
        { intros b₁' h_b₁', exfalso, apply h_b₁_ne_b₂ b₁' b₂, rw h_b₁' },
        { intros b₂' h_b₂', simp [h2] at h_b₂', subst b₂' } },
      -- If a is not in U₁ or U₂, then just use the universal set.
      { apply exists.intro (∅:measurable_setB M),
         split,
         { intros b₁ h_b₁, exfalso, apply h_notin_U₁,
           apply exists.intro b₁, apply h_b₁ },
         { intros b₂ h_b₂, exfalso, apply h_notin_U₂,
           apply exists.intro b₂, apply h_b₂ } } },
    rw classical.skolem at h_inv,
    cases h_inv with g_inv h_inv,
    have h_inv₁:pi.random_variable_combine (λ (b : β₁), X (f₁ b)) ∈ᵣ
          set.pi_measurable (set.univ) g₁ = (∀ᵣ a in U₁, X a ∈ᵣ g_inv a),
    { apply event.eq, ext1 ω, split; intros h_sub1;
      simp [pi.random_variable_combine, set.pi_measurable,
            pi.measurable_fun] at h_sub1;
      simp [pi.random_variable_combine, set.pi_measurable,
            pi.measurable_fun, h_sub1];
      intros b₁,
      { rw (h_inv (f₁ b₁)).left b₁ _, apply h_sub1, refl },
      { rw ← (h_inv (f₁ b₁)).left b₁ _, apply h_sub1, refl } },
    rw h_inv₁,
    have h_inv₂:pi.random_variable_combine (λ (b : β₂), X (f₂ b)) ∈ᵣ
          set.pi_measurable (set.univ) g₂ = (∀ᵣ a in U₂, X a ∈ᵣ g_inv a),
    { apply event.eq, ext1 ω, split; intros h_sub1;
      simp [pi.random_variable_combine, set.pi_measurable,
            pi.measurable_fun] at h_sub1;
      simp [pi.random_variable_combine, set.pi_measurable,
            pi.measurable_fun, h_sub1];
      intros b₂,
      { rw (h_inv (f₂ b₂)).right b₂ _, apply h_sub1, refl },
      { rw ← (h_inv (f₂ b₂)).right b₂ _, apply h_sub1, refl }, },
    rw h_inv₂,
    have h_union:((∀ᵣ (a : α) in U₁,X a ∈ᵣ g_inv a)∧(∀ᵣ (a : α) in U₂,X a ∈ᵣ g_inv a))
      = (∀ᵣ (a : α) in (U₁∪ U₂),X a ∈ᵣ g_inv a),
    { apply event.eq, ext1 ω, split; intros h_sub1; simp at h_sub1; simp [h_sub1],
      -- Simplification solves one direction.
      intros a h_sub2, cases h_sub2 with h_in_U₁ h_in_U₂,
      { cases h_in_U₁ with b₁ h_b₁, subst a, apply h_sub1.left },
      { cases h_in_U₂ with b₂ h_b₂, subst a, apply h_sub1.right } },
    rw h_union,
    rw ← h3 g_inv U₁,
    rw ← h3 g_inv U₂,
    rw ← h3 g_inv (U₁ ∪ U₂),
    rw finset.prod_union,
    apply h_disjoint,
  end
end


import mathlib.group
import group_theory.group_action.defs

/-!
# Pi instances for multiplicative actions

This file defines instances for mul_action and related structures on Pi types.

## See also

* `group_theory.group_action.prod`
* `group_theory.group_action.sigma`
* `group_theory.group_action.sum`
-/

open pi

universes u v w
variable {I : Prop}     -- The indexing type
variable {f : I → Type v} -- The family of types already equipped with instances
variables (x y : Π i, f i) (i : I)

namespace pi_Prop

@[to_additive pi_Prop.has_vadd]
instance has_smul {α : Type*} [Π i, has_smul α $ f i] :
  has_smul α (Π i : I, f i) :=
⟨λ s x, λ i, s • (x i)⟩

@[to_additive]
lemma smul_def {α : Type*} [Π i, has_smul α $ f i] (s : α) : s • x = λ i, s • x i := rfl
@[simp, to_additive]
lemma smul_apply {α : Type*} [Π i, has_smul α $ f i] (s : α) : (s • x) i = s • x i := rfl

@[to_additive pi_Prop.has_vadd']
instance has_smul' {g : I → Type*} [Π i, has_smul (f i) (g i)] :
  has_smul (Π i, f i) (Π i : I, g i) :=
⟨λ s x, λ i, (s i) • (x i)⟩

@[simp, to_additive]
lemma smul_apply' {g : I → Type*} [∀ i, has_smul (f i) (g i)] (s : Π i, f i) (x : Π i, g i) :
  (s • x) i = s i • x i :=
rfl
instance is_scalar_tower {α β : Type*}
  [has_smul α β] [Π i, has_smul β $ f i] [Π i, has_smul α $ f i]
  [Π i, is_scalar_tower α β (f i)] : is_scalar_tower α β (Π i : I, f i) :=
⟨λ x y z, funext $ λ i, smul_assoc x y (z i)⟩

instance is_scalar_tower' {g : I → Type*} {α : Type*}
  [Π i, has_smul α $ f i] [Π i, has_smul (f i) (g i)] [Π i, has_smul α $ g i]
  [Π i, is_scalar_tower α (f i) (g i)] : is_scalar_tower α (Π i : I, f i) (Π i : I, g i) :=
⟨λ x y z, funext $ λ i, smul_assoc x (y i) (z i)⟩

instance is_scalar_tower'' {g : I → Type*} {h : I → Type*}
  [Π i, has_smul (f i) (g i)] [Π i, has_smul (g i) (h i)] [Π i, has_smul (f i) (h i)]
  [Π i, is_scalar_tower (f i) (g i) (h i)] : is_scalar_tower (Π i, f i) (Π i, g i) (Π i, h i) :=
⟨λ x y z, funext $ λ i, smul_assoc (x i) (y i) (z i)⟩

@[to_additive]
instance smul_comm_class {α β : Type*}
  [Π i, has_smul α $ f i] [Π i, has_smul β $ f i] [∀ i, smul_comm_class α β (f i)] :
  smul_comm_class α β (Π i : I, f i) :=
⟨λ x y z, funext $ λ i, smul_comm x y (z i)⟩

@[to_additive]
instance smul_comm_class' {g : I → Type*} {α : Type*}
  [Π i, has_smul α $ g i] [Π i, has_smul (f i) (g i)] [∀ i, smul_comm_class α (f i) (g i)] :
  smul_comm_class α (Π i : I, f i) (Π i : I, g i) :=
⟨λ x y z, funext $ λ i, smul_comm x (y i) (z i)⟩

@[to_additive]
instance smul_comm_class'' {g : I → Type*} {h : I → Type*}
  [Π i, has_smul (g i) (h i)] [Π i, has_smul (f i) (h i)]
  [∀ i, smul_comm_class (f i) (g i) (h i)] : smul_comm_class (Π i, f i) (Π i, g i) (Π i, h i) :=
⟨λ x y z, funext $ λ i, smul_comm (x i) (y i) (z i)⟩

instance {α : Type*} [Π i, has_smul α $ f i] [Π i, has_smul αᵐᵒᵖ $ f i]
  [∀ i, is_central_scalar α (f i)] : is_central_scalar α (Π i, f i) :=
⟨λ r m, funext $ λ i, op_smul_eq_smul _ _⟩

/-- If `f i` has a faithful scalar action for a given `i`, then so does `Π i, f i`. This is
not an instance as `i` cannot be inferred. -/
@[to_additive pi_Prop.has_faithful_vadd_at]
lemma has_faithful_smul_at {α : Type*}
  [Π i, has_smul α $ f i] [Π i, nonempty (f i)] (i : I) [has_faithful_smul α (f i)] :
  has_faithful_smul α (Π i, f i) :=
⟨λ x y h, eq_of_smul_eq_smul $ λ a : f i, begin
  classical,
  have := congr_fun (h $ function.update (λ j, classical.choice (‹Π i, nonempty (f i)› j)) i a) i,
  simpa using this,
end⟩

@[to_additive pi_Prop.has_faithful_vadd]
instance has_faithful_smul {α : Type*}
  [nonempty I] [Π i, has_smul α $ f i] [Π i, nonempty (f i)] [Π i, has_faithful_smul α (f i)] :
  has_faithful_smul α (Π i, f i) :=
let ⟨i⟩ := ‹nonempty I› in has_faithful_smul_at i

@[to_additive]
instance mul_action (α) {m : monoid α} [Π i, mul_action α $ f i] :
  @mul_action α (Π i : I, f i) m :=
{ smul := (•),
  mul_smul := λ r s f, funext $ λ i, mul_smul _ _ _,
  one_smul := λ f, funext $ λ i, one_smul α _ }

@[to_additive]
instance mul_action' {g : I → Type*} {m : Π i, monoid (f i)} [Π i, mul_action (f i) (g i)] :
  @mul_action (Π i, f i) (Π i : I, g i) (@pi_Prop.monoid I f m) :=
{ smul := (•),
  mul_smul := λ r s f, funext $ λ i, mul_smul _ _ _,
  one_smul := λ f, funext $ λ i, one_smul _ _ }

instance distrib_mul_action (α) {m : monoid α} {n : ∀ i, add_monoid $ f i}
  [∀ i, distrib_mul_action α $ f i] :
  @distrib_mul_action α (Π i : I, f i) m (@pi_Prop.add_monoid I f n) :=
{ smul_zero := λ c, funext $ λ i, smul_zero _,
  smul_add := λ c f g, funext $ λ i, smul_add _ _ _,
  ..pi_Prop.mul_action _ }

instance distrib_mul_action' {g : I → Type*} {m : Π i, monoid (f i)} {n : Π i, add_monoid $ g i}
  [Π i, distrib_mul_action (f i) (g i)] :
  @distrib_mul_action (Π i, f i) (Π i, g i) (@pi_Prop.monoid I f m) (@pi_Prop.add_monoid I g n) :=
{ smul_add := by { intros, ext x, apply smul_add },
  smul_zero := by { intros, ext x, apply smul_zero } }

instance mul_distrib_mul_action (α) {m : monoid α} {n : Π i, monoid $ f i}
  [Π i, mul_distrib_mul_action α $ f i] :
  @mul_distrib_mul_action α (Π i : I, f i) m (@pi_Prop.monoid I f n) :=
{ smul_one := λ c, funext $ λ i, smul_one _,
  smul_mul := λ c f g, funext $ λ i, smul_mul' _ _ _,
  ..pi_Prop.mul_action _ }

instance mul_distrib_mul_action' {g : I → Type*} {m : Π i, monoid (f i)} {n : Π i, monoid $ g i}
  [Π i, mul_distrib_mul_action (f i) (g i)] :
  @mul_distrib_mul_action (Π i, f i) (Π i, g i) (@pi_Prop.monoid I f m) (@pi_Prop.monoid I g n) :=
{ smul_mul := by { intros, ext x, apply smul_mul' },
  smul_one := by { intros, ext x, apply smul_one } }

end pi_Prop

namespace function_Prop

/-- Non-dependent version of `pi_Prop.has_smul`. Lean gets confused by the dependent instance if
this is not present. -/
@[to_additive]
instance has_smul {ι : Prop} {R M : Type*} [has_smul R M] : has_smul R (ι → M) := pi_Prop.has_smul

/-- Non-dependent version of `pi_Prop.smul_comm_class`. Lean gets confused by the dependent instance
if this is not present. -/
@[to_additive]
instance smul_comm_class {ι : Prop} {α β M : Type*} [has_smul α M] [has_smul β M]
  [smul_comm_class α β M] :
  smul_comm_class α β (ι → M) :=
pi_Prop.smul_comm_class

end function_Prop