import category_theory.triangulated.pretriangulated
import for_mathlib.homological_complex_shift
import for_mathlib.monoidal_category
import for_mathlib.int

noncomputable theory

open category_theory
open category_theory.preadditive
open category_theory.limits

universes v u

-- Move + generalize!
@[simp]
lemma category_theory.discrete.associator_def (a b c : discrete ℤ) :
  α_ a b c = eq_to_iso (discrete.ext _ _ $ add_assoc a.1 b.1 c.1) := rfl

-- Move + generalize!
@[simp]
lemma category_theory.discrete.left_unitor_def (a : discrete ℤ) :
  λ_ a = eq_to_iso (discrete.ext _ _ $ zero_add _) := rfl

-- Move + generalize!
@[simp]
lemma category_theory.discrete.right_unitor_def (a : discrete ℤ) :
  ρ_ a = eq_to_iso (discrete.ext _ _ $ add_zero _) := rfl

namespace category_theory.triangulated
open category_theory.category

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

local attribute [instance, reducible] endofunctor_monoidal_category

namespace triangle

@[simps]
def triangle_shift_obj (T : triangle C) (i : ℤ) : triangle C :=
triangle.mk C
  (i.neg_one_pow • ((shift_functor _ i).map T.mor₁))
  (i.neg_one_pow • (((shift_functor _ i).map T.mor₂)))
  (i.neg_one_pow • ((shift_functor C i).map T.mor₃ ≫ (shift_comm _ _ _).hom))

@[simps]
def triangle_shift_map {T₁ T₂ : triangle C} (f : T₁ ⟶ T₂) (i : ℤ) :
  triangle_shift_obj C T₁ i ⟶ triangle_shift_obj C T₂ i :=
{ hom₁ := (shift_functor _ i).map f.hom₁,
  hom₂ := (shift_functor _ i).map f.hom₂,
  hom₃ := (shift_functor _ i).map f.hom₃,
  comm₁' := by { dsimp, simp only [functor.map_zsmul,
    preadditive.zsmul_comp, preadditive.comp_zsmul, ← functor.map_comp, f.comm₁] },
  comm₂' := by { dsimp, simp only [functor.map_zsmul,
    preadditive.zsmul_comp, preadditive.comp_zsmul, ← functor.map_comp, f.comm₂] },
  comm₃' := begin
    dsimp,
    simp only [functor.map_zsmul,
      preadditive.zsmul_comp, preadditive.comp_zsmul],
    congr' 1,
    simp only [ shift_comm_hom_comp, assoc, iso.cancel_iso_hom_right_assoc,
      ← functor.map_comp, f.comm₃],
  end }

@[simps]
def triangle_shift_functor (i : ℤ) : triangle C ⥤ triangle C :=
{ obj := λ T, triangle_shift_obj C T i,
  map := λ T₁ T₂ f, triangle_shift_map C f _,
  map_id' := begin
    intros T,
    ext,
    all_goals { dsimp, simp },
  end,
  map_comp' := begin
    intros T₁ T₂ T₃ f g,
    ext,
    all_goals { dsimp, simp },
  end, } .

variable {C}

@[simps]
def iso.of_components {T₁ T₂ : triangle C}
  (e₁ : T₁.obj₁ ≅ T₂.obj₁)
  (e₂ : T₁.obj₂ ≅ T₂.obj₂)
  (e₃ : T₁.obj₃ ≅ T₂.obj₃) (h₁ h₂ h₃) : T₁ ≅ T₂ :=
{ hom :=
  { hom₁ := e₁.hom,
    hom₂ := e₂.hom,
    hom₃ := e₃.hom,
    comm₁' := h₁,
    comm₂' := h₂,
    comm₃' := h₃ },
  inv :=
  { hom₁ := e₁.inv,
    hom₂ := e₂.inv,
    hom₃ := e₃.inv,
    comm₁' := by rw [iso.comp_inv_eq, category.assoc, iso.eq_inv_comp, h₁],
    comm₂' := by rw [iso.comp_inv_eq, category.assoc, iso.eq_inv_comp, h₂],
    comm₃' := by rw [← functor.map_iso_inv, iso.comp_inv_eq, category.assoc, iso.eq_inv_comp,
      functor.map_iso_hom, h₃], },
  hom_inv_id' := by ext; dsimp; simp,
  inv_hom_id' := by ext; dsimp; simp }
.

variable (C)

@[simps]
def triangle_shift_functor_ε : 𝟭 (triangulated.triangle C) ≅ triangle_shift_functor C 0 :=
nat_iso.of_components (λ T,
  iso.of_components
    (shift_zero _ _).symm
    (shift_zero _ _).symm
    (shift_zero _ _).symm
    begin
      convert ((shift_functor_zero _ _).inv.naturality _),
      dsimp only [triangle_shift_functor, triangle_shift_obj],
      simpa,
    end
    begin
      convert ((shift_functor_zero _ _).inv.naturality _),
      dsimp only [triangle_shift_functor, triangle_shift_obj],
      simpa,
    end
    begin
      dsimp,
      rw one_smul,
      rw ← nat_trans.naturality_assoc, dsimp [shift_comm],
      simp only [obj_ε_app, discrete.functor_map_id, nat_trans.id_app, ε_app_obj, assoc, id_comp],
      rw [← nat_trans.comp_app, ← nat_trans.comp_app],
      erw [monoidal_functor.μ_inv_hom_id_assoc, id_comp], refl,
    end)
  begin
    intros T₁ T₂ f, ext;
    { dsimp only [triangle_morphism.comp_hom₁, iso.of_components_hom_hom₁, triangle_shift_map_hom₁,
        triangle_morphism.comp_hom₂, iso.of_components_hom_hom₂, triangle_shift_map_hom₂,
        triangle_morphism.comp_hom₃, iso.of_components_hom_hom₃, triangle_shift_map_hom₃,
        functor.id_map, triangle_category_comp, iso.symm_hom, iso.app_inv, iso.symm_inv,
        monoidal_functor.ε_iso_hom, triangle_shift_functor_map],
      rw ← nat_trans.naturality _ _, refl },
  end
.

variables [∀ (i : ℤ), (shift_functor C i).additive]

@[reassoc]
lemma shift_comm_eq_eq_to_hom (X : C) (i j : ℤ) :
  (shift_add X i j).hom ≫ (shift_comm X i j).hom ≫ (shift_add X j i).inv =
  eq_to_hom (by { congr' 2, exact add_comm i j}) :=
begin
  dsimp [shift_add, shift_comm],
  simp only [eq_to_hom_map, eq_to_hom_app, assoc, μ_inv_hom_app, μ_inv_hom_app_assoc],
  erw comp_id,
end

@[reassoc]
lemma shift_add_comp_eq_to_hom (X : C) (i j k : ℤ) (h : i + j = j + i) :
  (shift_add X (i+j) k).hom ≫
  eq_to_hom (by { congr' 3}) ≫
  (shift_add X (j+i) k).inv =
  eq_to_hom (by { congr' 3}) :=
begin
  dsimp [shift_add],
  induction h, dsimp, simpa,
end

@[reassoc]
lemma shift_add_comp_eq_to_hom' (X : C) (i j k : ℤ) (h : j + k = k + j) :
  (shift_add X i (j+k)).hom ≫
  eq_to_hom (by { congr' 3}) ≫
  (shift_add X i (k+j)).inv =
  eq_to_hom (by { congr' 3}) :=
begin
  dsimp [shift_add],
  induction h, dsimp, simpa,
end

lemma triangle_shift_functor_μ_aux (X : C) (i j : ℤ) :
  (shift_functor C j).map (shift_comm X 1 i).hom ≫
    (shift_comm ((shift_functor C i).obj X) 1 j).hom ≫
      (shift_functor C 1).map
        (shift_add X i j).inv =
  (shift_add ((shift_functor C 1).obj X) i j).inv ≫
    (shift_comm X 1 (i + j)).hom :=
begin
  dsimp [shift_add, shift_comm],
  simp only [eq_to_hom_map, eq_to_hom_app, functor.map_comp, obj_μ_app,
    category_theory.discrete.associator_def, eq_to_iso.inv,
    obj_μ_inv_app, eq_to_iso.hom, assoc, μ_inv_hom_app_assoc],
  congr' 2,
  simp only [← assoc], congr' 1, simp only [assoc],
  erw shift_add_comp_eq_to_hom_assoc,
  erw shift_add_comp_eq_to_hom'_assoc,
  simpa, exact add_comm _ _, exact add_comm _ _,
end

@[simps]
def triangle_shift_functor_μ (i j : ℤ) :
  triangle_shift_functor C i ⋙ triangle_shift_functor C j ≅
    triangle_shift_functor C (i + j) :=
nat_iso.of_components (λ T,
  iso.of_components
    (shift_add _ _ _).symm
    (shift_add _ _ _).symm
    (shift_add _ _ _).symm
    (begin
      dsimp [triangle_shift_functor, triangle_shift_obj],
      simp only [zsmul_comp, comp_zsmul, iso.symm_hom, iso.app_inv, iso.symm_inv,
        monoidal_functor.μ_iso_hom, functor.map_zsmul, smul_smul, int.neg_one_pow_add],
      have := ((shift_functor_add _ i j).inv.naturality T.mor₁),
      rw [functor.comp_map] at this,
      erw [this, mul_comm], refl,
    end)
    (begin
      dsimp [triangle_shift_functor, triangle_shift_obj],
      simp only [zsmul_comp, comp_zsmul, iso.symm_hom, iso.app_inv, iso.symm_inv,
        monoidal_functor.μ_iso_hom, functor.map_zsmul, smul_smul, int.neg_one_pow_add],
      have := ((shift_functor_add _ i j).inv.naturality T.mor₂),
      rw [functor.comp_map] at this,
      erw [this, mul_comm], refl,
    end)
    begin
      dsimp [triangle_shift_functor, triangle_shift_obj],
      simp only [zsmul_comp, comp_zsmul, iso.symm_hom, iso.app_inv, iso.symm_inv,
        monoidal_functor.μ_iso_hom, functor.map_zsmul, smul_smul, int.neg_one_pow_add,
        mul_comm j.neg_one_pow],
      have := ((shift_functor_add _ i j).inv.naturality T.mor₃),
      dsimp [functor.comp_map] at this,
      erw [← reassoc_of this], clear this,
      simp only [functor.map_comp, assoc, obj_μ_app],
      congr' 2,
      --have := (shift_monoidal_functor C ℤ).to_lax_monoidal_functor.associativity i j 1,
      rw (shift_monoidal_functor C ℤ).map_associator_inv,
      dsimp,
      simp only [assoc, is_iso.inv_id, nat_trans.hcomp_app, comp_id, id_comp],
      slice_lhs 4 5
      { rw [← nat_trans.comp_app, is_iso.hom_inv_id,
          nat_trans.id_app] },
      erw id_comp,
      rw category_theory.nat_iso.is_iso_inv_app,
      --rw nat_trans.id_hcomp_app,
      dsimp,
      simp only [category_theory.functor.map_id, comp_id, assoc, is_iso.hom_inv_id_assoc],
      slice_lhs 4 5
      { rw [← nat_trans.comp_app, (shift_monoidal_functor C ℤ).μ_hom_inv_id,
          nat_trans.id_app] },
      erw comp_id, apply triangle_shift_functor_μ_aux,
    end)
  (begin
    intros T₁ T₂ f, ext;
    { dsimp only [triangle_morphism.comp_hom₁, iso.of_components_hom_hom₁, triangle_shift_map_hom₁,
        triangle_morphism.comp_hom₂, iso.of_components_hom_hom₂, triangle_shift_map_hom₂,
        triangle_morphism.comp_hom₃, iso.of_components_hom_hom₃, triangle_shift_map_hom₃,
        functor.id_map, triangle_category_comp, iso.symm_hom, iso.app_inv, iso.symm_inv,
        monoidal_functor.ε_iso_hom, triangle_shift_functor_map],
      rw ← nat_trans.naturality _ _, refl },
  end)
.

/-
def triangle_shift_core : shift_mk_core (triangle C) ℤ :=
{ F := triangle_shift_functor _,
  ε := triangle_shift_functor_ε _,
  μ := λ i j, triangle_shift_functor_μ _ _ _,
  associativity := begin
    intros i j k T, ext,
    { have := (shift_monoidal_functor C ℤ).to_lax_monoidal_functor.associativity i j k,
      apply_fun (λ α, α.app T.obj₁) at this,
      simp only [nat_trans.comp_app, obj_μ_app, assoc, μ_inv_hom_app_assoc, map_inv_hom_app,
        comp_id, functor.associator_hom_app, nat_trans.hcomp_app, nat_trans.id_app,
        category_theory.functor.map_id, id_comp] at this,
      erw [id_comp] at this,
      refine eq.trans _ this, clear this,
      dsimp, simp only [obj_μ_app, assoc],
      -- I don't like that `(eq_to_hom _).hom₁`.
      admit },
    admit,
    admit
  end,
  left_unitality := admit,
  right_unitality := admit }
-/

@[simps]
def map_triangle_shift_functor (m n : discrete ℤ) (f : m ⟶ n) :
  triangle_shift_functor C m.1 ⟶ triangle_shift_functor C n.1 :=
{ app := λ T,
  { hom₁ := eq_to_hom $ by rw discrete.eq_of_hom f,
    hom₂ := eq_to_hom $ by rw discrete.eq_of_hom f,
    hom₃ := eq_to_hom $ by rw discrete.eq_of_hom f,
    comm₁' := by { rcases ⟨m, n⟩ with ⟨⟨_⟩, ⟨_⟩⟩, rcases f with ⟨⟨rfl : m = n⟩⟩,
      simp only [eq_to_hom_refl, id_comp, comp_id], },
    comm₂' := by { rcases ⟨m, n⟩ with ⟨⟨_⟩, ⟨_⟩⟩, rcases f with ⟨⟨rfl : m = n⟩⟩,
      simp only [eq_to_hom_refl, id_comp, comp_id], },
    comm₃' := by { rcases ⟨m, n⟩ with ⟨⟨_⟩, ⟨_⟩⟩, rcases f with ⟨⟨rfl : m = n⟩⟩,
      dsimp, rw (shift_functor C (1 : ℤ)).map_id, simp only [comp_id, id_comp]} },
  naturality' := begin
    rcases ⟨m, n⟩ with ⟨⟨_⟩, ⟨_⟩⟩, rcases f with ⟨⟨rfl : m = n⟩⟩,
    rintros X Y g, ext;
    { dsimp, simp only [eq_to_hom_refl, id_comp, comp_id] },
  end } .

lemma associativity_aux (X : C) (a b c : ℤ) :
(𝟙 ((shift_functor C c).obj ((shift_functor C b).obj ((shift_functor C a).obj X))) ≫
  (shift_functor C c).map (((shift_monoidal_functor C ℤ).μ ⟨a⟩ ⟨b⟩).app X)) ≫
  ((shift_monoidal_functor C ℤ).μ (⟨a⟩ ⊗ ⟨b⟩) ⟨c⟩).app X ≫
  eq_to_hom (show ((shift_monoidal_functor C ℤ).obj ((⟨a⟩ ⊗ ⟨b⟩) ⊗ ⟨c⟩)).obj X =
    ((shift_monoidal_functor C ℤ).obj (⟨a⟩ ⊗ ⟨b⟩ ⊗ ⟨c⟩)).obj X, by { congr' 2, ext, apply add_assoc }) =
  𝟙 ((shift_functor C c).obj
  ((shift_functor C b).obj ((shift_functor C a).obj X))) ≫ (((shift_monoidal_functor C ℤ).μ ⟨b⟩ ⟨c⟩).app
  ((shift_functor C a).obj X) ≫ (shift_functor C (b + c)).map
  (𝟙 ((shift_functor C a).obj X))) ≫ ((shift_monoidal_functor C ℤ).to_lax_monoidal_functor.μ ⟨a⟩
  (⟨b⟩ ⊗ ⟨c⟩)).app X :=
begin
  have := (shift_monoidal_functor C ℤ).associativity' ⟨a⟩ ⟨b⟩ ⟨c⟩,
  apply_fun (λ e, e.app X) at this,
  dsimp at this ⊢,
  simp only [id_comp, comp_id, category_theory.functor.map_id,
    eq_to_hom_map, eq_to_hom_app] at this ⊢,
  erw comp_id,
  exact this
end

lemma left_unitality_aux (X : C) (a : ℤ) : 𝟙 ((shift_functor C a).obj X) =
  (𝟙 ((shift_functor C a).obj X) ≫ (shift_functor C a).map
    ((shift_monoidal_functor C ℤ).to_lax_monoidal_functor.ε.app X)) ≫
    ((shift_monoidal_functor C ℤ).to_lax_monoidal_functor.μ
    (𝟙_ (discrete ℤ)) ⟨a⟩).app X ≫ eq_to_hom (by { congr, ext, exact zero_add a }) :=
begin
  have := (shift_monoidal_functor C ℤ).left_unitality' ⟨a⟩,
  apply_fun (λ e, e.app X) at this,
  dsimp at this ⊢,
  simp only [id_comp, comp_id, category_theory.functor.map_id,
    eq_to_hom_map, eq_to_hom_app] at this ⊢,
  exact this
end

lemma right_unitality_aux (X : C) (a : ℤ) : 𝟙 ((shift_functor C a).obj X) =
  ((shift_monoidal_functor C ℤ).to_lax_monoidal_functor.ε.app ((shift_functor C a).obj X) ≫
       (shift_functor C (𝟙_ (discrete ℤ)).as).map (𝟙 ((shift_functor C a).obj X))) ≫
    ((shift_monoidal_functor C ℤ).to_lax_monoidal_functor.μ ⟨a⟩ (𝟙_ (discrete ℤ))).app X ≫
    eq_to_hom (by { congr, ext, apply add_zero }) :=
begin
  have := (shift_monoidal_functor C ℤ).right_unitality' ⟨a⟩,
  apply_fun (λ e, e.app X) at this,
  dsimp at this ⊢,
  simp only [id_comp, comp_id, category_theory.functor.map_id,
    eq_to_hom_map, eq_to_hom_app] at this ⊢,
  erw comp_id,
  exact this
end

instance has_shift : has_shift (triangle C) ℤ := has_shift.mk $
{ obj := λ i, triangle_shift_functor _ i.as,
  map := λ m n f, map_triangle_shift_functor _ _ _ f,
  map_id' := λ X, by { ext; refl },
  map_comp' := λ X Y Z f g, by { ext; simp },
  ε := (triangle_shift_functor_ε _).hom,
  μ := λ m n, (triangle_shift_functor_μ _ m.as n.as).hom,
  μ_natural' := begin
    rintros ⟨m⟩ ⟨m'⟩ ⟨n⟩ ⟨n'⟩ ⟨⟨⟨⟩⟩⟩ ⟨⟨⟨⟩⟩⟩, ext;
    { dsimp, simp only [id_comp, comp_id, category_theory.functor.map_id] },
  end,
  associativity' := λ a b c, by ext; apply associativity_aux,
  left_unitality' := λ a, by ext; apply left_unitality_aux,
  right_unitality' := λ a, by ext; apply right_unitality_aux,
  ε_is_iso := infer_instance,
  μ_is_iso := infer_instance } .

@[simp]
lemma shift_obj₁ (T : triangle C) (i : ℤ) : T⟦i⟧.obj₁ = T.obj₁⟦i⟧ := rfl

@[simp]
lemma shift_obj₂ (T : triangle C) (i : ℤ) : T⟦i⟧.obj₂ = T.obj₂⟦i⟧ := rfl

@[simp]
lemma shift_obj₃ (T : triangle C) (i : ℤ) : T⟦i⟧.obj₃ = T.obj₃⟦i⟧ := rfl

@[simp]
lemma shift_mor₁ (T : triangle C) (i : ℤ) : T⟦i⟧.mor₁ = i.neg_one_pow • T.mor₁⟦i⟧' := rfl

@[simp]
lemma shift_mor₂ (T : triangle C) (i : ℤ) : T⟦i⟧.mor₂ = i.neg_one_pow • T.mor₂⟦i⟧' := rfl

@[simp]
lemma shift_mor₃ (T : triangle C) (i : ℤ) :
  T⟦i⟧.mor₃ = i.neg_one_pow • (T.mor₃⟦i⟧' ≫ (shift_comm _ _ _).hom) := rfl

@[simp]
lemma shift_hom₁ {T₁ T₂ : triangle C} (f : T₁ ⟶ T₂) (i : ℤ) : f⟦i⟧'.hom₁ = f.hom₁⟦i⟧' := rfl

@[simp]
lemma shift_hom₂ {T₁ T₂ : triangle C} (f : T₁ ⟶ T₂) (i : ℤ) : f⟦i⟧'.hom₂ = f.hom₂⟦i⟧' := rfl

@[simp]
lemma shift_hom₃ {T₁ T₂ : triangle C} (f : T₁ ⟶ T₂) (i : ℤ) : f⟦i⟧'.hom₃ = f.hom₃⟦i⟧' := rfl

end triangle

/-
instance {C : Type*} [category C] [preadditive C] (X Y : C) : has_neg (X ≅ Y) :=
⟨λ f,
{ hom := -f.hom,
  inv := -f.inv,
  hom_inv_id' := by simp only [comp_neg, neg_comp, iso.hom_inv_id, neg_neg],
  inv_hom_id' := by simp only [comp_neg, neg_comp, iso.inv_hom_id, neg_neg] }⟩

@[simp] lemma _root_.category_theory.neg_hom
   {C : Type*} [category C] [preadditive C] {X Y : C} (f : X ≅ Y) :
   (-f).hom = -(f.hom) := rfl

@[simp] lemma _root_.category_theory.neg_inv
   {C : Type*} [category C] [preadditive C] {X Y : C} (f : X ≅ Y) :
   (-f).inv = -(f.inv) := rfl
-/

namespace pretriangulated

@[simp] lemma shift_comm_self (X : C) (i : ℤ) : shift_comm X i i = iso.refl _ :=
begin
  ext,
  dsimp [shift_comm],
  simpa only [discrete.functor_map_id, nat_trans.id_app, id_comp, μ_hom_inv_app],
end

variables [has_zero_object C] [∀ (i : ℤ), (shift_functor C i).additive] [pretriangulated C]

lemma dist_triangle_iff_of_iso {T₁ T₂ : triangle C} (e : T₁ ≅ T₂) :
  (T₁ ∈ dist_triang C) ↔ (T₂ ∈ dist_triang C) :=
⟨λ h, isomorphic_distinguished _ h _ e.symm, λ h, isomorphic_distinguished _ h _ e⟩

lemma dist_triangle_rot_iff (T : triangle C) :
  (T.rotate ∈ dist_triang C) ↔ (T ∈ dist_triang C) :=
begin
  refine ⟨λ h, _, λ h, rot_of_dist_triangle _ _ h⟩,
  let e : T ≅ T.rotate.inv_rotate := rot_comp_inv_rot.app T,
  rw ← dist_triangle_iff_of_iso _ e.symm,
  exact inv_rot_of_dist_triangle _ _ h,
end

lemma shift_of_dist_triangle (T : triangle C) (hT : T ∈ dist_triang C) (i : ℤ) :
  T⟦i⟧ ∈ dist_triang C :=
begin
  induction i using int.induction_on_iff with i,
  { exact isomorphic_distinguished T hT _ (shift_zero _ _), },
  { suffices : T⟦(i+1 : ℤ)⟧ ≅ T⟦(i:ℤ)⟧.rotate.rotate.rotate,
    { dsimp,
      rw dist_triangle_iff_of_iso _ this,
      iterate 3 { rw dist_triangle_rot_iff }, },
    refine shift_add _ _ _ ≪≫ _,
    refine triangle.iso.of_components (iso.refl _) (iso.refl _) (iso.refl _) _ _ _,
    { dsimp, simp only [category.id_comp, category.comp_id, comp_neg, neg_one_smul], },
    { dsimp, simp only [category.id_comp, category.comp_id, neg_comp, neg_one_smul], },
    { dsimp, simp only [category.id_comp, category.comp_id, neg_comp, neg_one_smul],
      simp only [functor.map_comp, assoc, category_theory.functor.map_id, comp_id,
        functor.map_zsmul, preadditive.zsmul_comp, preadditive.comp_zsmul,
        shift_comm_self, iso.refl_hom], }, },
end

end pretriangulated

end category_theory.triangulated


import measure_theory.measure.measure_space
import measure_theory.constructions.pi
import probability_theory.independence
import probability_theory.conditional
import probability_theory.pi_subtype

def heq_congr {A B C : Type*} (hAB : A = B) {f : A → C} {g : B → C} (hfg : f == g)
  {a : A} {b : B} (hab : a == b) : f a = g b := begin
  revert a b f g, rw hAB,
  intros,
  exact congr (eq_of_heq hfg) (eq_of_heq hab)
end

lemma supr_emptyset' {α β} [complete_lattice α] {f : subtype ∅ → α} :
  (⨆ x : (∅ : set β), f x) = ⊥ := by simp

lemma union_subset_iff_right {α} (p q r : set α) (h : p ⊆ r) : p ∪ q ⊆ r ↔ q ⊆ r :=
by rw set.union_subset_iff; exact and_iff_right h

lemma union_subset_iff_left {α} (p q r : set α) (h : q ⊆ r) : p ∪ q ⊆ r ↔ p ⊆ r :=
by rw set.union_subset_iff; exact and_iff_left h

lemma pi_Inter_distrib {ι ι': Type*} {α : ι → Type*} {s : set ι} {t : ι' → Π i, set (α i)} :
  s.pi (λ i, ⋂ i', t i' i) = ⋂ i', s.pi (t i') :=
begin
  ext x,
  simp only [set.mem_pi, set.mem_Inter],
  have : (∀ i ∈ s, ∀ i', x i ∈ t i' i) ↔ (∀ i', ∀ i ∈ s, x i ∈ t i' i)
    := ⟨(λ h i' i hi, h i hi i'), (λ h i hi i', h i' i hi)⟩,
  rw this
end

noncomputable theory

namespace measure_theory

def bot_measurable_space {α} : measurable_space α :=
begin
  refine measurable_space.mk (set.union {∅} {set.univ}) _ _ _,
  exact or.inl rfl,
  intros s hs,
  cases hs; change _ = _ at hs; subst hs,
  rw set.compl_empty, exact or.inr rfl,
  rw set.compl_univ, exact or.inl rfl,
  intros f hf,
  -- TODO pull things out into their own lemmas
  by_cases ∃ i : ℕ, f i = set.univ,
    rcases h with ⟨i, hfi⟩,
    have : set.univ ≤ (⋃ (i : ℕ), f i) := by rw ← hfi; exact le_supr f i,
    exact or.inr (top_le_iff.mp this),
  simp at h,
  rw set.Union_eq_empty.mpr (λ x, (hf x).elim id (λ hf, absurd hf (h x))),
  exact or.inl rfl
end

lemma bot_measurable_space_eq_bot {α} : @bot_measurable_space α = ⊥ :=
begin
  refine le_bot_iff.mp _,
  intros i hi,
  cases hi; change _ = _ at hi; subst hi,
  exact @measurable_set.empty _ ⊥,
  exact measurable_set.univ
end

lemma inter_of_generate_from_pi {ι : Type*} {α : ι → Type*}
  (C : Π i, set (set (α i))) (t : set (Π i, α i)) :
  t ∈ set.pi set.univ '' set.pi set.univ (λ (i : ι), {s : set (α i) | C i s}) →
  ∃ (f : Π i, set (α i)), (∀ i, C i (f i)) ∧ t = ⋂ i, function.eval i ⁻¹' (f i) :=
begin
  classical,
  rintro ⟨t', ht1', ht2'⟩,
  refine ⟨t', λ i, ht1' i (set.mem_univ i), _⟩,
  subst ht2',
  let ft' := λ i, (function.update (λ j : ι, (set.univ : set (α j))) i (t' i)),
  have : t' = λ i, ⋂ i', ft' i' i,
  { ext1 i,
    have : (⋂ (i' : ι), ft' i' i ) = ft' i i,
    refine infi_eq_of_forall_ge_of_forall_gt_exists_lt _ (λ _ h, ⟨i, h⟩),
    { intro i',
      by_cases i = i',
      subst h, exact le_refl _,
      have : ft' i' i = set.univ, { exact dif_neg h },
      rw this, finish },
    rw this, exact eq.symm (dif_pos rfl) },
  rw [this, pi_Inter_distrib],
  congr, ext1 i',
  simp_rw (congr_fun this i').symm,
  exact set.univ_pi_update_univ _ _
end

end measure_theory

namespace measurable_space

def comap_pi {α : Type*} {ι : Type*} {β : ι → Type*} [Π i : ι, measurable_space (β i)] (f : Π (i : ι), α → β i) :
  measurable_space α :=
  ((measurable_space.pi).comap (λ (a : α) (i : ι), f i a))

end measurable_space

open measure_theory measure_theory.measure measurable_space

namespace probability_theory

lemma measurable_pi_subtype {δ : Type*} {π : δ → Type*}
  [hmp : Π a, measurable_space (π a)] (s : set δ) :
  measurable (@pi_subtype δ π s) :=
begin
  rw measurable_pi_iff,
  intro a,
  rw measurable_iff_comap_le,
  -- FIXME why can't the lambda below be inferred?
  exact le_supr (λ a, (hmp a).comap (λ (b : Π a, π a), b a)) _,
end

@[reducible]
def indep_sets' {α} [measurable_space α] {s1 s2 : set (set α)} (μ : measure α) :=
  ∀ (t1 ∈ s1) (t2 ∈ s2), μ (t1 ∩ t2) = μ (t1) * μ (t2)

lemma indep_sets_eq : @indep_sets = @indep_sets' := by ext; split; exact λ a b c d e, a b d c e

def indep_sets_iff {α} [measurable_space α] (s1 s2 : set (set α))
  (μ : measure α) [is_probability_measure μ]
  (hs1 : s1 ⊆ measurable_set) (hs2 : s2 ⊆ measurable_set) :
  indep_sets s1 s2 μ ↔ (∀ (t1 ∈ s1) (t2 ∈ s2), indep_set t1 t2 μ) :=
begin
  rw [indep_sets_eq],
  repeat {rw forall_congr, intro},
  refine (indep_set_iff_measure_inter_eq_mul (hs1 _) (hs2 _) μ);
  assumption
end

def cond_indep_sets_iff {α} [measurable_space α] (s1 s2 cs : set (set α))
  (μ : measure α) [is_probability_measure μ]
  (hs1 : s1 ⊆ measurable_set) (hs2 : s2 ⊆ measurable_set) (hcs : cs ⊆ measurable_set) :
  cond_indep_sets s1 s2 cs μ ↔ (∀ (t1 ∈ s1) (t2 ∈ s2) (c ∈ cs), cond_indep_set' t1 t2 c μ) :=
begin
  have : (∀ (t1 ∈ s1) (t2 ∈ s2) (c ∈ cs), cond_indep_set' t1 t2 c μ) ↔
  (∀ (c ∈ cs) (t1 ∈ s1) (t2 ∈ s2), cond_indep_set' t1 t2 c μ)
    := by split; intros h _ _ _ _ _ _; apply h; assumption,
  rw this, clear this,
  rw cond_indep_sets,
  -- TODO how to compress?
  refine forall_congr _, intro c, refine forall_congr _, intro hc,
  simp [cond_indep_set', cond_indep_set_def],
  by_cases h : μ c = 0,
  { refine iff_of_true _ _,
    apply indep_sets_of_cond_null_measure _ _ _ _ (hcs hc) h,
    intros, apply indep_sets_of_cond_null_measure _ _ _ _ (hcs hc) h, },
  rw [indep_sets_eq, indep_sets'],
  refine forall_congr _, intro, refine forall_congr _, intro ht1,
  refine forall_congr _, intro, refine forall_congr _, intro ht2,
  rw indep_set_iff_measure_inter_eq_mul (hs1 _) (hs2 _) _; try {assumption},
  exact probability_theory.cond_prob_meas _ h
end

------------

variables {α : Type*} [m : measurable_space α] (μ : measure α) {ι: Type*}
  {β : ι → Type*} (f : Π i : ι, α → (β i))

section definitions

variables [Π i : ι, measurable_space (β i)]

def comap_subtype (S : set ι) :
  measurable_space (Π i : ι, β i) := measurable_space.comap (pi_subtype S) measurable_space.pi

lemma pi_ext {P : set α → Prop} :
  (∀ x, ((measurable_space.pi).comap (λ a i, f i a)).measurable_set' x → P x)
  ↔ (∀ x, measurable_set x → P ((λ a i, f i a) ⁻¹' x)) := set.maps_image_to _ _ _ _

lemma comap_subtype_ext {P : set (Π i : ι, β i) → Prop} (A : set ι) :
  (∀ x, (comap_subtype A).measurable_set' x → P x)
  ↔ (∀ x, measurable_set x → P (>[A] x)) := set.maps_image_to _ _ _ _

lemma comap_subtype_subset (A : set ι) :
  @comap_subtype _ β _ A ≤ measurable_space.pi :=
begin
  simp_rw [comap_subtype, measurable_space.pi, comap_supr,
    measurable_space.comap_comp, function.comp, pi_subtype],
  exact supr_le_supr2 (λ i, ⟨i, le_rfl⟩)
end

lemma pi_unsubtype_meas_meas (A : set ι) {a : set (Π i : A, β i)} (hma : measurable_set a) :
   measurable_set (>[] a) := by refine comap_subtype_subset A _ ⟨a, hma, rfl⟩

lemma pi_set_to_subtype_img_meas₁ {A B : set ι} (hAB : B ⊆ A) :
  @measurable_space.pi ↥B _ _ = (@measurable_space.pi (set_to_subtype A B) _ _).comap (@pi_set_to_subtype _ β A B) :=
begin
  simp_rw [measurable_space.pi, comap_supr, comap_comp, function.comp],
  refine le_antisymm (supr_le_supr2 (λ i, ⟨⟨⟨i, hAB i.property⟩, i.property⟩, _⟩)) (supr_le_supr2 (λ i, ⟨⟨i, i.property⟩, _⟩));
  convert le_refl _; ext x; rw pi_set_to_subtype_def',
  congr, exact subtype.eq rfl, congr
end

lemma pi_set_to_subtype_img_meas₂ {A B : set ι} (hAB : B ⊆ A) :
  (@measurable_space.pi B _ _).map (@pi_set_to_subtype _ β A B) = (@measurable_space.pi (set_to_subtype A B) _ _) :=
begin
  rw pi_set_to_subtype_img_meas₁ hAB,
  -- TODO make lemma for general map_comap_surjective
  ext s,
  split,
  { rintro ⟨s', hms', hs'⟩,
    rwa (set.preimage_eq_preimage (pi_set_to_subtype_bijective hAB).surjective).mp hs' at hms' },
  intro h, exact ⟨s, h, rfl⟩
end

lemma pi_set_to_subtype_img_meas {A B : set ι} (hAB : B ⊆ A) {b : set (Π i : B, β i)} (hmb : measurable_set b)
  : measurable_set (pi_set_to_subtype A B '' b) :=
begin
  change measurable_space.pi.measurable_set' (pi_set_to_subtype A B '' b),
  rw ← pi_set_to_subtype_img_meas₂ hAB,
  change measurable_set (pi_set_to_subtype A B ⁻¹' (pi_set_to_subtype A B '' b)),
  rwa set.preimage_image_eq _ (pi_set_to_subtype_bijective hAB).injective
end

lemma pi_unsubtype_set_meas_meas {A B : set ι} (hAB : B ⊆ A) {b : set (Π i : B, β i)} (hmb : measurable_set b)
  : measurable_set (>>[A] b) :=
by exact pi_unsubtype_meas_meas _ (pi_set_to_subtype_img_meas hAB hmb)

/-- The joint distribution induced by an indexed family of random variables `f`. -/
def joint : measure (Π i : ι, β i) := map (λ a i, f i a) μ

instance joint_prob_meas (hm : ∀ i : ι, measurable (f i)) [hp : is_probability_measure μ] :
  is_probability_measure (joint μ f) :=
begin
  constructor,
  rw [joint, measure.map_apply _ measurable_set.univ],
  rw set.preimage_univ, exact hp.measure_univ,
  exact measurable_pi_iff.mpr hm
end

/-- The marginal distribution induced by an indexed family of random variables `f`
restricted to a subset of "marginalizing variable" indices `mv` (represented as
an index subtype). -/
def marginal (mv : set ι) : measure (Π i : mv, β i) := joint μ (pi_subtype mv f)

instance marginal_prob_meas (hm : ∀ i : ι, measurable (f i)) [is_probability_measure μ] (mv : set ι) :
  is_probability_measure (marginal μ f mv)
  := by rw marginal; exact probability_theory.joint_prob_meas _ _ (λ i, hm i)

/-- Generic marginalization of the joint measure `μ` on the given subset of variables `mv`. -/
def marginalization (μ : measure (Π i : ι, β i)) (mv : set ι) :
  measure (Π i : mv, β i) := map (pi_subtype mv) μ

end definitions

variables [Π i : ι, measurable_space (β i)]

section marginal

variables [Π i : ι, measurable_space (β i)] (hm : ∀ i : ι, measurable (f i))

include hm

lemma marginal_eq_marginalization_aux (mv : set ι) :
  marginal μ f mv = marginalization (joint μ f) mv :=
by { rw [marginalization, joint, map_map, function.comp], refl,
  apply measurable_pi_subtype, exact measurable_pi_iff.mpr hm }

/-- The marginalization principle: the marginal probability of a particular
"marginal assignment" measurable set `s` is equal to the joint probability of
that same set, extended to allow the unassigned variables to take any value. -/
theorem marginal_def (mv : set ι)
  {s : set (Π i : mv, β i)} (hms : measurable_set s) :
  marginal μ f mv s = joint μ f (>[] s) :=
by { rw [marginal_eq_marginalization_aux _ _ hm, marginalization, map_apply _ hms],
  apply measurable_pi_subtype }

lemma joint_cond_meas_of_marginal (mv : set ι)
  (s : set (Π i : mv, β i)) (hms : measurable_set s) (hcs : (marginal μ f mv) s ≠ 0) :
  joint μ f (>[] s) ≠ 0 := by rwa marginal_def _ _ hm _ hms at hcs

lemma marginal_cond_meas_of_joint (mv : set ι)
  (s : set (Π i : mv, β i)) (hms : measurable_set s) (hcs : (joint μ f) (>[] s) ≠ 0) :
  marginal μ f mv s ≠ 0 := by rwa ← marginal_def _ _ hm _ hms at hcs

lemma marginal_cond_meas_of_joint_inter {A B : set ι}
  {a : set (Π i : A, β i)} (hma : measurable_set a)
  {b : set (Π i : B, β i)} (hmb : measurable_set b)
  (hjc : joint μ f (>[] a ∩ >[] b) ≠ 0) : marginal μ f _ (>>[A ∪ B] a ∩ >>[] b) ≠ 0 :=
begin
  rwa [marginal_def, pi_unsubtype_union_img_inter], assumption,
  refine measurable_set.inter _ _; refine pi_unsubtype_set_meas_meas _ _; finish
end

lemma joint_cond_meas_of_marginal_inter {A B : set ι}
  {a : set (Π i : A, β i)} (hma : measurable_set a)
  {b : set (Π i : B, β i)} (hmb : measurable_set b)
  (hmc : marginal μ f _ (>>[A ∪ B] a ∩ >>[] b) ≠ 0) : joint μ f (>[] a ∩ >[] b) ≠ 0 :=
begin
  rwa [marginal_def, pi_unsubtype_union_img_inter] at hmc, assumption,
  refine measurable_set.inter _ _; refine pi_unsubtype_set_meas_meas _ _; finish
end

end marginal

-----

section independence

section definitions

/-- A list of sets of random variables `S` is independent if the list of measurable spaces
it incurs on the joint distribution is independent. -/
def Independent {ι' : Type*} (S : ι' → set ι) : Prop :=
  Indep (λ i, (comap_pi (pi_subtype (S i) f))) μ

/-- Two sets of random variables `A` and `B` are independent if the measurable spaces
they incur on the event space `α` via `f` are independent w.r.t. `μ`. -/
def independent (A B : set ι) : Prop :=
  indep (comap_pi (pi_subtype A f)) (comap_pi (pi_subtype B f)) μ

/-- Two sets of random variables `A` and `B` are independent if the measurable spaces
they incur on the joint distribution are independent. -/
def independent_meas (A B : set ι) (hm : ∀ i : ι, measurable (f i)) :
  independent μ f A B ↔ indep (comap_subtype A) (comap_subtype B) (joint μ f)
  :=
begin
  simp_rw [independent, indep, indep_sets_eq, indep_sets'],
  change
    (∀ (t1 : set α)
    (ht1 : (measurable_space.comap (λ (a : α) (i : ↥A), f ↑i a) measurable_space.pi).measurable_set' t1)
    (t2 : set α)
    (ht2 : (measurable_space.comap (λ (a : α) (i : ↥B), f ↑i a) measurable_space.pi).measurable_set' t2),
      μ (t1 ∩ t2) = μ t1 * μ t2) ↔
    ∀ (t1 : set (Π (i : ι), β i))
    (ht1 : (comap_subtype A).measurable_set' t1)
    (t2 : set (Π (i : ι), β i))
    (ht2 : (comap_subtype B).measurable_set' t2), (joint μ f) (t1 ∩ t2) = (joint μ f) t1 * (joint μ f) t2,
  simp_rw comap_subtype_ext,
  simp_rw pi_ext,
  refine forall_congr _, intro a, refine forall_congr _, intro hma,
  refine forall_congr _, intro b, refine forall_congr _, intro hmb,
  simp_rw [joint],
  have hmusa : measurable_set (>[] a) := measurable_pi_subtype A hma,
  have hmusb : measurable_set (>[] b) := measurable_pi_subtype B hmb,
  conv_rhs
  { rw map_apply (measurable_pi_iff.mpr hm) (hmusa.inter hmusb),
    rw map_apply (measurable_pi_iff.mpr hm) (hmusa),
    rw map_apply (measurable_pi_iff.mpr hm) (hmusb) },
  rw iff_eq_eq,
  refl
end

end definitions

end independence

-----

section conditional

section definitions

def cond (A B : set ι) (c : set (Π i : B, β i)) : measure (Π i : A, β i) :=
  marginal (cond_measure μ ((λ a i, f i a) ⁻¹' (>[] c))) f A

/-- Two sets of random variables `A` and `B` are independent given a third set `C`
if the measurable spaces `A` and `B` incur on the event space `α` via `f` are independent w.r.t. `μ`
given any measurable set incurred by `C`. -/
def cond_independent (A B C : set ι) : Prop :=
  cond_indep (comap_pi (pi_subtype A f)) (comap_pi (pi_subtype B f))
             (comap_pi (pi_subtype C f)).measurable_set' μ

lemma cond_independent_def (A B C : set ι) :
  cond_independent μ f A B C ↔
  ∀ c (hc : ((measurable_space.pi).comap (λ (a : α) (i : C), f i a)).measurable_set' c),
  independent (cond_measure μ c) f A B :=
by refl

lemma cond_independent_meas (A B C : set ι) (hm : ∀ i : ι, measurable (f i)) :
  cond_independent μ f A B C ↔
  cond_indep (comap_subtype A) (comap_subtype B) (comap_subtype C).measurable_set' (joint μ f) :=
begin
  simp_rw [cond_independent_def, independent_meas _ _ _ _ hm, cond_indep_def],
  change _ ↔
    ∀ (c : set (Π (i : ι), β i)),
      (comap_subtype C).measurable_set' c →
      indep (comap_subtype A) (comap_subtype B) (cond_measure (joint μ f) c),
  simp_rw [comap_subtype_ext, pi_ext],
  refine forall_congr _, intro c, refine forall_congr _, intro hmc,
  rw iff_eq_eq, congr,
  simp_rw [cond_measure, joint], simp, congr,
  exact (map_apply (measurable_pi_iff.mpr hm) (measurable_pi_subtype C hmc)).symm,
  exact (restrict_map (measurable_pi_iff.mpr hm) (measurable_pi_subtype C hmc)).symm
end

end definitions

theorem cond_def [is_probability_measure μ] (hm : ∀ i : ι, measurable (f i)) (A B : set ι)
  (c : set (Π i : B, β i)) (hmc : measurable_set c)
  (s : set (Π i : A, β i)) (hms : measurable_set s) :
  cond μ f A B c s = cond_measure (joint μ f) (>[] c) (>[] s) :=
begin
  haveI := probability_theory.joint_prob_meas μ f hm,
  rw [cond, marginal_def _ _ hm _ hms],
  congr, ext1 s' hms',
  have hm' := measurable_pi_iff.mpr hm,
  have hmc' := measurable_pi_subtype B hmc,
  rw [joint, map_apply, cond_measure_def, cond_measure_def, joint,
    map_apply, map_apply, set.preimage_inter]; try {assumption},
  apply measurable_set.inter hmc' hms',
  exact hm' hmc'
end

lemma independent_iff_cond_independent_empty [is_probability_measure μ]
  (hm : ∀ i : ι, measurable (f i)) (A B : set ι) :
  independent μ f A B ↔ cond_independent μ f A B ∅ :=
begin
  haveI := probability_theory.joint_prob_meas μ f hm,
  rw [cond_independent_meas _ _ _ _ _ hm, independent_meas _ _ _ _ hm],
  have : @comap_subtype _ β _ ∅ = ⊥ :=
    by rw comap_subtype; convert @comap_bot _ _ (pi_subtype ∅); exact supr_emptyset',
  rw [this, ← bot_measurable_space_eq_bot],
  refine iff.trans (iff.symm _) (union_subset_iff_right _ _ _ _).symm,
  apply cond_indep_univ_iff_indep_set,
  intros a ha, change _ = _ at ha, subst ha,
  exact indep_sets_of_cond_null_measure _ _ _ _ measurable_set.empty (outer_measure.empty _),
end

lemma cond_empty_eq_marginal [is_probability_measure μ]
  (A : set ι) : cond μ f A ∅ set.univ = marginal μ f A :=
by simp_rw [cond, pi_unsubtype_img, set.preimage_univ, cond_univ]

theorem cond_independent_iff_cond_inter_irrel [is_probability_measure μ] (hm : ∀ i : ι, measurable (f i))
  (A B C : set ι) :
  cond_independent μ f A B C ↔ ∀ (b : set (Π i : B, β i)) (hmb : measurable_set b)
  (c : set (Π i : C, β i)) (hmc : measurable_set c),
  marginal μ f (B ∪ C) (>>[] b ∩ >>[] c) ≠ 0
  → cond μ f A (B ∪ C) (>>[] b ∩ >>[] c) = cond μ f A C c :=
begin
  haveI := probability_theory.joint_prob_meas μ f hm,
  rw [cond_independent_meas _ _ _ _ _ hm, cond_indep, cond_indep_sets_iff],
  { -- FIXME this is just to pattern-match, can I avoid this somehow?
    change (
        ∀ (a : set (Π (i : ι), β i)), (comap_subtype A).measurable_set' a
      → ∀ (b : set (Π (i : ι), β i)), (comap_subtype B).measurable_set' b
      → ∀ (c : set (Π (i : ι), β i)), (comap_subtype C).measurable_set' c
      → cond_indep_set' a b c (joint μ f))
      ↔ ∀ (b : set (Π (i : ↥B), β ↑i)) (hmb : measurable_set b)
      (c : set (Π (i : ↥C), β ↑i)) (hmc : measurable_set c),
      marginal μ f (B ∪ C) (>>[] b ∩ >>[] c) ≠ 0
      → cond μ f A (B ∪ C) (>>[] b ∩ >>[] c) = cond μ f A C c,
    simp_rw comap_subtype_ext,
    conv in (cond _ _ _ _ _ = cond _ _ _ _ _) { rw measure.ext_iff },
    split; intro h,
    { intros b hmb c hmc hcmbc a hma,
      have : joint μ f (>[] b ∩ >[] c) ≠ 0
        := joint_cond_meas_of_marginal_inter _ _ hm hmb hmc hcmbc,
      rw set.inter_comm at this,
      rw [cond_def, cond_def]; try {assumption},
      convert (cond_indep_set_iff_cond_inter_irrel (joint μ f) _ _ _).mp
        (cond_indep_set'.symm (h _ hma _ hmb _ hmc)) _;
      try {exact measurable_pi_subtype _ (by assumption)},
      rw [pi_unsubtype_union_img_inter, set.inter_comm],
      assumption,
      refine measurable_set.inter _ _;
      refine measurable_pi_subtype _ _; refine pi_set_to_subtype_img_meas _ (by assumption),
      exact set.subset_union_left _ _, exact set.subset_union_right _ _ },
    { intros a hma b hmb c hmc,
      rw cond_indep_set_iff_cond_inter_irrel',
      intro hcmbc,
      rw set.inter_comm at hcmbc,
      have : marginal μ f _ (>>[] b ∩ >>[] c) ≠ 0
        := marginal_cond_meas_of_joint_inter _ _ hm hmb hmc hcmbc,
      have := h b _ c _ _ a hma; try {assumption},
      rw [cond_def, cond_def] at this; try {assumption},
      rwa [set.inter_comm, ← pi_unsubtype_union_img_inter],
      { refine measurable_set.inter _ _;
        refine measurable_pi_subtype _ _;
        refine pi_set_to_subtype_img_meas _ (by assumption),
        exact set.subset_union_left _ _, exact set.subset_union_right _ _ },
      all_goals {exact measurable_pi_subtype _ (by assumption)} } },
  all_goals {exact comap_subtype_subset _}
end

theorem independent_iff_cond_irrel  [is_probability_measure μ] (hm : ∀ i : ι, measurable (f i))
  (A B : set ι) :
  independent μ f A B ↔ ∀ (b : set (Π i : B, β i)) (hmb : measurable_set b), marginal μ f B b ≠ 0
  → cond μ f A B b = marginal μ f A :=
begin
  convert cond_independent_iff_cond_inter_irrel μ f hm A B ∅; ext,
  exact independent_iff_cond_independent_empty _ _ hm A B,
  refine forall_congr _, intro b,
  refine forall_congr _, intro hmb,
  haveI : subsingleton (Π i : (∅ : set ι), β i) := ⟨λ f g, by ext ⟨x, hx⟩; exact false.elim hx⟩,
  have h1 : ⇑(marginal μ f (B ∪ ∅)) == ⇑(marginal μ f B) := by rw set.union_empty,
  have h2 : cond μ f A (B ∪ ∅) == cond μ f A B := by rw set.union_empty,
  have h3 : >>[B ∪ ∅] b == b := begin
    rw [set.union_empty],
    refine heq_of_eq _,
    exact pi_unsubtype_set_same _ _
  end,
  have : (marginal μ f (B ∪ ∅) (>>[] b ∩ >>[] (set.univ : set (Π (i : (∅ : set ι)), β i))) ≠ 0
    → cond μ f A (B ∪ ∅) (>>[] b ∩ >>[] (set.univ : set (Π (i : (∅ : set ι)), β i))) = cond μ f A ∅ set.univ)
    ↔ (marginal μ f B b ≠ 0 → cond μ f A B b = marginal μ f A),
  { simp_rw [pi_unsubtype_set, pi_unsubtype_img,
      set.image_univ_of_surjective (pi_set_to_subtype_bijective (set.subset_union_right _ _)).surjective,
      set.preimage_univ, set.inter_univ],
    rw heq_congr (by rw set.union_empty) h1 h3,
    rw heq_congr (by rw set.union_empty) h2 h3,
    rw cond_empty_eq_marginal },
  split; intro h,
  { refine subsingleton.set_cases _ _; intro hmc,
    simp_rw [pi_unsubtype_set, pi_unsubtype_img],
    simp_rw [set.image_empty, set.preimage_empty, set.inter_empty],
    intro h', exact absurd (outer_measure.empty' _) h',
    rwa this },
  { have h' := h set.univ measurable_set.univ,
    rwa this at h' },
end

end conditional

end probability_theory


/-
Copyright (c) 2021 Yaël Dillies, Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies, Bhavik Mehta
-/
import combinatorics.simplicial_complex.exposed

open_locale classical affine big_operators
open set
--TODO: Generalise to LCTVS
variables {E : Type*} [normed_group E] [normed_space ℝ E] {x : E} {A B : set E}
  {X : finset E} {l : E →L[ℝ] ℝ}

def set.vertices (A : set E) :
  set E :=
{x | x ∈ frontier A ∧ ∀ w : E, w ≠ x → ((∃ l : E →L[ℝ] ℝ, l x ≤ l w ∧ ∀ y ∈ A, l y ≤ l x) →
  ∃ l : E →L[ℝ] ℝ, l x < l w ∧ ∀ y ∈ A, l y ≤ l x) ∧ ((∃ l : E →L[ℝ] ℝ, l x ≤ l w ∧ ∀ y ∈ Aᶜ,
  l y ≤ l x) → ∃ l : E →L[ℝ] ℝ, l x < l w ∧ ∀ y ∈ Aᶜ, l y ≤ l x)}

/-def set.vertices (A : set E) :
  set E :=
{x | x ∈ frontier A ∧ ∀ w : E, w ≠ x → (∃ l : E →L[ℝ] ℝ, l x ≤ l w ∧ ∀ y ∈ A, l y ≤ l x) →
  ∃ l : E →L[ℝ] ℝ, l x < l w ∧ ∀ y ∈ A, l y ≤ l x}-/

lemma contrapose :
  ∀ w : E, w ≠ x → (∃ l : E →L[ℝ] ℝ, l x ≤ l w ∧ ∀ y ∈ A, l y ≤ l x) →
  ∃ l : E →L[ℝ] ℝ, l x < l w ∧ ∀ y ∈ A, l y ≤ l x :=
begin
  by_contra,
  push_neg at h,
  sorry
end


-- import syntax.consistency
-- import tactic.induction

-- -- Motivation: a lot of places assume `¬ ax ⊥'` so it's worth trying to reduce these assumptions.
-- lemma ax_consistent.not_ax_bot' {form : Type} [pf : Pformula form] [pax : Pformula_ax form] {s : set form}
--   (h : ax_consistent s) : ¬ ⊢' (⊥' : form) :=
-- begin
--   simpa [ax_consistent, set_proves] using (h list.nil (λ _ h, h.elim))
-- end

-- /-- An empty set of formulas is consistent iff the theory is consistent. -/
-- -- Motivation: a lot of places assume `¬ ax ⊥'` so it's worth trying to reduce these assumptions.
-- @[simp] lemma ax_consistent_empty\ {form : Type} [pf : Pformula form] [pax : Pformula_ax form] :
--   ax_consistent ({} : set form) ↔ ¬ ax (⊥' : form) :=
-- begin
--   split; intro h,
--   { exact h.not_ax_bot },
--   { intros fs hfs,
--     cases fs with f fs,
--     { simpa [ax_consistent, finite_ax_consistent] using hfs },
--     { cases hfs f (list.mem_cons_self _ _) } }
-- end

-- /-- If there is any formula that cannot be proven, the theory is consistent. -/
-- -- Motivation: a lot of places assume `¬ ax ⊥'` so it's worth trying to reduce these assumptions.
-- lemma consistent_of_not_ax {form : Type} [pf : Pformula form] [pax : Pformula_ax form] {φ : form}
--   (hφ : ¬ ax φ) : ¬ ax (⊥' : form) :=
-- mt (mp _ _ ax_bot_elim) hφ

-- lemma contra_con_cons {form : Type} [pf : Pformula form] [pax : Pformula_ax form] (fs gs : list (form)) (x y : form)
--   (hax : ax (y ↔' ¬' x)) (hx : x ∈ fs) (hy : y ∈ gs) :
--   ax (¬' ((finite_conjunction fs) ∧' (finite_conjunction gs))) :=
-- begin
--   induction' fs with f fs ihf,
--   { finish, },
--   { induction gs with g gs ihg,
--     { finish, },
--     { cases hx,
--       { cases hy,
--         { rw[←hx, ←hy],
--           simp[finite_conjunction],
--           rw ft.notdef,
--           apply cut (iff_r and_commute),
--           apply imp_and_l,
--           apply cut (iff_l and_switch),
--           apply cut (iff_r and_commute),
--           apply imp_and_l,
--           rw ←contra_iff_false_ax_not,
--           rw demorgans,
--           apply iff_l,
--           exact hax, },
--         { simp[finite_conjunction],
--           rw ft.notdef,
--           apply cut (iff_r and_commute),
--           apply cut (iff_l and_switch),
--           apply cut (iff_r and_commute),
--           apply imp_and_l,
--           apply cut (iff_l and_switch),
--           rw ←contra_iff_false_ax_not,
--           apply ihg hy, }, },
--       { rw ft.notdef,
--         apply cut (iff_l and_switch),
--         apply cut (iff_r and_commute),
--         apply cut (iff_l and_switch),
--         apply cut (iff_r and_commute),
--         apply imp_and_l,
--         specialize @ihf ft fax (g :: gs) x y hax hy hx,
--         rw ft.notdef at ihf,
--         exact ihf, }, }, },
-- end

-- /-- A singleton set is consistent iff the theory is consistent and the formula is not disprovable.
-- -/
-- -- Motivation: `comphelper` seemed to be slightly too specific, this is a more general form I found
-- @[simp] lemma ax_consistent_singleton {form : Type} [pf : Pformula form] [pax : Pformula_ax form] {φ : form} :
--   ax_consistent ({φ} : set form) ↔ ¬ ax (¬' φ) :=
-- begin
--   split,
--   { intros h,
--     have := h (φ :: list.nil) (by simp),
--     simp only [finite_ax_consistent, ft.notdef, finite_conjunction_cons, finite_conjunction_nil]
--       at ⊢ this,
--     exact mt (ax_iff_mp (ax_imp_congr_left ax_and_top_iff)).2 this },
--   { rintros hφ fs hfs,
--     cases fs with f fs,
--     { simp only [ax_consistent, finite_ax_consistent, finite_conjunction_nil, ax_top_imp] at ⊢,
--       exact consistent_of_not_ax hφ },
--     { intro h,
--       simp only [ft.notdef] at *,
--       exact hφ (mp _ _ (mp _ _ hs1 h) (fin_conj_repeat_helper hfs)) } }
-- end

-- -- Completeness helper
-- ----------------------------------------------------------

-- lemma comphelper {form : Type} [pf : Pformula form] [pax : Pformula_ax form] {φ : form} (h : ¬ ax φ) :
--   ax_consistent ({¬' φ} : set form) :=
-- ax_consistent_singleton.mpr (mt (mp _ _ dne) h)

-- /-- If `φ` cannot be proved, there is a maximal consistent set containing `¬ φ` -/
-- -- Motivation: `lindenbaum` is applied in a few places to `comphelper`,
-- -- and `simp` can simplify the conditions slightly.
-- lemma exists_max_ax_consistent_neg_mem {form : Type} [pf : Pformula form] [pax : Pformula_ax form] {φ : form} (hφ : ¬ ax φ) :
--   ∃ (Γ : set form), max_ax_consistent Γ ∧ ¬' φ ∈ Γ :=
-- by simpa using lindenbaum (comphelper hφ)


/-
Copyright (c) 2019 Bruno Bentzen. All rights reserved.
Released under the Apache License 2.0 (see "License");
Author: Bruno Bentzen
-/

import ..core.interval

open interval

-- permutation (exchange) for type and terms

example {A : I → I → Type} : I → I → Type := λ j i, A i j

example {A : I → I → Type} (a : Π j i, A i j) : Π j i, A j i := λ j i, a i j


import lambda_calculus.utlc.basic
import lambda_calculus.utlc.identities

namespace lambda_calculus
namespace utlc

def reduction_step : utlc → utlc → (utlc → utlc → Prop) → Prop
| (↓ n) := λ g r, r (↓ n) g
| (Λ f) := λ g r, r (Λ f) g ∨ match g with
  | (↓ _) := false
  | (Λ g) := reduction_step f g r
  | (_·_) := false
  end
| (f1 · f2) := λ g r, r (f1 · f2) g ∨ match g with
  | (↓_) := false
  | (Λ _) := false
  | (g1 · g2) :=
    (g2 = f2 ∧ (reduction_step f1 g1 r)) ∨ (g1 = f1 ∧ (reduction_step f2 g2 r))
  end

def reduction_step_of := λ r f g, reduction_step f g r

section
variables (head_step: utlc → utlc → Prop)
variables (n : ℕ)
variables (f f' g g': utlc)
variables (m : ℕ)

local attribute [simp] reduction_step reduction_step_of

instance reduction_step.decidable_rel [h: decidable_rel head_step]: decidable_rel (reduction_step_of head_step) :=
begin
  have dor : ∀ (p q : Prop), decidable p → decidable q → decidable (p ∨ q),
  { intros p q hp hq,
    cases hp;
    cases hq;
    simp only [hp, hq];
    apply_instance },
  have dand : ∀ (p q : Prop), decidable p → decidable q → decidable (p ∧ q),
  { intros p q hp hq,
    cases hp;
    cases hq;
    simp only [hp, hq];
    apply_instance },
  intro f,
  induction f;
  intro g;
  cases g;
  simp only [down_notation, lambda_notation, dot_notation,
    reduction_step_of, reduction_step];
  repeat { apply dor };
  repeat { apply dand };
  try { apply_instance },
  apply f_ih g,
  apply f_ih_f g_f,
  apply f_ih_g g_g
end

theorem down_reduction_step_iff: reduction_step_of head_step (↓n) g ↔ head_step (↓n) g :=
by cases g; simp

theorem lambda_reduction_step_iff: reduction_step_of head_step (Λ f) g ↔
  head_step (Λ f) g ∨ ∃ x, g = Λ x ∧ reduction_step_of head_step f x :=
by cases g; simp

theorem dot_reduction_step_iff: reduction_step_of head_step (f·f') g ↔
  head_step (f·f') g ∨
    (∃ x, g = x·f' ∧ reduction_step_of head_step f x) ∨
    ∃ x, g = f·x ∧ reduction_step_of head_step f' x :=
by cases g; simp [and.assoc]
end

attribute [irreducible] reduction_step_of
attribute [simp] down_reduction_step_iff lambda_reduction_step_iff dot_reduction_step_iff

variables {head_step: utlc → utlc → Prop}
variables {f f': utlc}
variables {n: ℕ}
variables {g g': utlc}
variables {m: ℕ}

@[simp] theorem reduction_step_down_iff:
  reduction_step_of head_step f ↓m ↔ head_step f ↓m :=
by cases f; simp

theorem down_of_refl_trans_reduction_step:
  (∀ n g, ¬ head_step (↓n:utlc) g) →
  relation.refl_trans_gen (reduction_step_of head_step) (↓n:utlc) g →
  g = ↓n :=
begin
  intros h p,
  induction p with x g hfx hxg,
  { refl },
  rw [p_ih, down_reduction_step_iff] at hxg,
  exfalso,
  apply h _ _ hxg,
end

theorem reduction_step_lambda_iff:
  reduction_step_of head_step f Λ g ↔
  head_step f (Λ g) ∨ ∃ x, f = Λ x ∧ reduction_step_of head_step x g :=
by cases f ; simp

theorem reduction_step_dot_iff:
  reduction_step_of head_step f (g·g') ↔
  head_step f (g·g') ∨
    (∃ x, x·g' = f ∧ reduction_step_of head_step x g) ∨
    ∃ x, g·x = f ∧ reduction_step_of head_step x g' :=
by cases f; simp [and.assoc]

theorem lambda_reduction_step_lambda:
  reduction_step_of head_step f g → reduction_step_of head_step (Λ f) (Λ g) :=
by simp; exact or.inr

theorem lambda_refl_reduction_step_lambda:
  relation.refl_gen (reduction_step_of head_step) f g →
  relation.refl_gen (reduction_step_of head_step) Λ f Λ g :=
begin
  intro p,
  cases p,
  { refl },
  exact relation.refl_gen.single (lambda_reduction_step_lambda (by assumption)),
end

theorem lambda_refl_trans_reduction_step_lambda:
  relation.refl_trans_gen (reduction_step_of head_step) f g →
  relation.refl_trans_gen (reduction_step_of head_step) Λ f Λ g :=
relation.refl_trans_gen.lift _ (@lambda_reduction_step_lambda _)

theorem lambda_of_refl_trans_reduction_step:
  (∀ f g, ¬ head_step (Λ f) g) →
  relation.refl_trans_gen (reduction_step_of head_step) (Λ f) g →
  ∃ x, g = Λ x :=
begin
  intros h p,
  induction p with x g hfx hxg,
  { use f },
  cases p_ih with y hy,
  rw [hy, lambda_reduction_step_iff] at hxg,
  cases hxg,
  { exfalso, apply h _ _ hxg },
  rcases hxg with ⟨z, _, _⟩,
  use z,
  assumption,
end

theorem dot_reduction_step_dot_left:
  reduction_step_of head_step f f' → reduction_step_of head_step (f·g) (f'·g) :=
by intro p; simp [p]

theorem dot_reduction_step_dot_right:
  reduction_step_of head_step g g' → reduction_step_of head_step (f·g) (f·g') :=
by intro p; simp [p]

theorem dot_refl_reduction_step_dot_left:
  relation.refl_gen (reduction_step_of head_step) f f' →
  ∀ g, relation.refl_gen (reduction_step_of head_step) (f·g) (f'·g) :=
begin
  intros p _,
  cases p,
  { refl },
  exact relation.refl_gen.single (dot_reduction_step_dot_left (by assumption))
end

theorem dot_refl_reduction_step_dot_right:
  relation.refl_gen (reduction_step_of head_step) f f' →
  ∀ g, relation.refl_gen (reduction_step_of head_step) (g·f) (g·f') :=
begin
  intros p _,
  cases p,
  { refl },
  exact relation.refl_gen.single (dot_reduction_step_dot_right (by assumption))
end

theorem dot_refl_trans_reduction_step_dot_left:
  relation.refl_trans_gen (reduction_step_of head_step) f f' →
  ∀ g, relation.refl_trans_gen (reduction_step_of head_step) (f·g) (f'·g) :=
begin
  intros _ g,
  simp only [show ∀ f, f·g = (λ x, x·g) f, by simp],
  apply relation.refl_trans_gen.lift,
  intros _ _ _,
  apply dot_reduction_step_dot_left,
  assumption'
end

theorem dot_refl_trans_reduction_step_dot_right:
  relation.refl_trans_gen (reduction_step_of head_step) f f' →
  ∀ g, relation.refl_trans_gen (reduction_step_of head_step) (g·f) (g·f') :=
begin
  intros _ g,
  simp only [show ∀ f, g·f = (λ x, g·x) f, by simp],
  apply relation.refl_trans_gen.lift,
  intros _ _ _,
  apply dot_reduction_step_dot_right,
  assumption'
end

theorem dot_refl_trans_reduction_step_dot:
  relation.refl_trans_gen (reduction_step_of head_step) f f' →
  relation.refl_trans_gen (reduction_step_of head_step) g g' →
  relation.refl_trans_gen (reduction_step_of head_step) (f·g) (f'·g') :=
begin
  intros p q,
  apply trans,
  exact dot_refl_trans_reduction_step_dot_left p _,
  exact dot_refl_trans_reduction_step_dot_right q _
end

theorem  dot_of_refl_trans_reduction_step:
  (∀ f f' g, ¬ head_step (f·f') g) →
  relation.refl_trans_gen (reduction_step_of head_step) (f·f') g →
  ∃ x x', g = x·x' :=
begin
  intros h p,
  induction p with x g hfx hxg,
  { exact ⟨f, f', rfl⟩ },
  rcases p_ih with ⟨y, y', hy⟩,
  rw [hy, dot_reduction_step_iff] at hxg,
  obtain hxg|hxg|hxg := hxg;
  try { exfalso, apply h _ _ _ hxg };
  rcases hxg with ⟨z, hg, _⟩,
  exact ⟨z, y', hg⟩,
  exact ⟨y, z, hg⟩
end

theorem uses_zero_reduction_step  (h: ∀ {f g}, head_step f g → ∀ {n}, f.uses n = 0 → g.uses n = 0):
  (reduction_step_of head_step f g) → ∀ {n}, f.uses n = 0 → g.uses n = 0 :=
begin
  induction f using lambda_calculus.utlc.notation_induction_on generalizing g;
  intro p;
  try { rw [down_reduction_step_iff] at p };
  try { rw [lambda_reduction_step_iff] at p, obtain p|p := p };
  try { rw [dot_reduction_step_iff] at p, obtain p|p|p := p };
  try { { apply @h _ _ p } };
  rcases p with ⟨x, hg, hf⟩;
  simp only [hg, dot_uses, add_eq_zero_iff, and_imp];
  intro n,
  { apply f_ih hf },
  { intros p q, exact ⟨ f_ih_f hf p, q ⟩ },
  { intros p q, exact ⟨ p, f_ih_g hf q ⟩ }
end

theorem uses_reduction_step_uses (h: ∀ {f} {g}, head_step f g → ∀ n, f.uses n = g.uses n):
  (reduction_step_of head_step f g) → ∀ n, f.uses n = g.uses n :=
begin
  induction f using lambda_calculus.utlc.notation_induction_on generalizing g;
  intro p;
  try { rw [down_reduction_step_iff] at p };
  try { rw [lambda_reduction_step_iff] at p, obtain p|p := p };
  try { rw [dot_reduction_step_iff] at p, obtain p|p|p := p };
  try { { apply h p } };
  rcases p with ⟨x, hg, hf⟩;
  intro n;
  simp only [hg, lambda_uses, dot_uses, and_imp,
    add_eq_zero_iff, add_left_cancel_iff, add_right_cancel_iff],
  { apply f_ih hf },
  { apply f_ih_f hf },
  { apply f_ih_g hf }
end

theorem uses_refl_trans_reduction_step_uses (h: ∀ {f g}, head_step f g → ∀ n, f.uses n = g.uses n):
  (relation.refl_trans_gen (reduction_step_of head_step) f g) → ∀ n, f.uses n = g.uses n :=
begin
  intro p,
  induction p with x g hfx hxg,
  { intro, refl },
  intro n,
  apply trans (p_ih _),
  apply uses_reduction_step_uses @h hxg,
end

theorem shift_reduction_step_shift_iff: (∀ f g n, head_step (f ↑¹ n) (g ↑¹ n) ↔ head_step f g) →
  (reduction_step_of head_step (f ↑¹ n) (g ↑¹ n) ↔ reduction_step_of head_step f g) :=
begin
  intro p,
  induction f using lambda_calculus.utlc.notation_induction_on generalizing n g,
  { simpa[down_shift] using p (↓f) g n },
  { simp [← p (Λ f_f) g n, shift_eq_lambda_iff, f_ih] },
  { simp [← p (f_f·f_g) g n, shift_eq_dot_iff, f_ih_f, f_ih_g, and.left_comm] }
end

theorem shift_refl_trans_reduction_shift: (∀ f g n, head_step (f ↑¹ n) (g ↑¹ n) ↔ head_step f g) →
  (relation.refl_trans_gen (reduction_step_of head_step) f g → relation.refl_trans_gen (reduction_step_of head_step) (f ↑¹ n) (g ↑¹ n)) :=
begin
 intro p,
 apply relation.refl_trans_gen.lift,
 intros a b,
 apply (shift_reduction_step_shift_iff p).mpr
end

local notation a `[` b `:=` c  `]` : 70 := has_substitution.substitution a b c

theorem substitution_reduction_step_left (f: utlc) (hf: ∀ {f f'}, head_step f f' → ∀ n g, relation.refl_trans_gen (reduction_step_of head_step) (f[n:=g]) (f'[n:=g])): reduction_step_of head_step f f' →
  ∀ n g, relation.refl_trans_gen (reduction_step_of head_step) (f[n:=g]) (f'[n:=g]) :=
begin
  induction f using lambda_calculus.utlc.notation_induction_on generalizing f';
  simp only [down_reduction_step_iff, lambda_reduction_step_iff, dot_reduction_step_iff],
  { apply hf },
  { intros p n g,
    cases p,
    { apply hf p },
    rcases p with ⟨x, hfx', hfx⟩,
    rw [hfx'],
    exact lambda_refl_trans_reduction_step_lambda (f_ih hfx _ _) },
  { intros p n g,
    obtain p|p|p := p,
    { apply hf p },
    { rcases p with ⟨x, hfx', hfx⟩,
      rw [hfx'],
      exact dot_refl_trans_reduction_step_dot_left (f_ih_f hfx _ _) _ },
    { rcases p with ⟨x, hfx', hfx⟩,
      rw [hfx'],
      exact dot_refl_trans_reduction_step_dot_right (f_ih_g hfx _ _) _ } }
end

theorem substitution_reduction_step_right (f: utlc) (hf: ∀ f g n, head_step (f ↑¹ n) (g ↑¹ n) ↔ head_step f g): reduction_step_of head_step g g' →
  ∀ n, relation.refl_trans_gen (reduction_step_of head_step) (f[n:=g]) (f[n:=g']) :=
begin
  induction f using lambda_calculus.utlc.notation_induction_on generalizing g g';
  intros p n,
  { obtain h|h|h := nat.lt_trichotomy f n,
    { simp [h] },
    { apply relation.refl_trans_gen.single,
      simpa [h] using p },
    { simp [lt_asymm h, ne_of_gt h] } },
  { apply lambda_refl_trans_reduction_step_lambda,
    apply f_ih,
    rw shift_reduction_step_shift_iff,
    assumption,
    assumption },
  { apply dot_refl_trans_reduction_step_dot,
    apply f_ih_f,
    assumption,
    apply f_ih_g,
    assumption }
end

def reduced : utlc → (utlc → bool) → bool
| (↓ n) := λ p, p (↓ n)
| (Λ f) := λ p, p (Λ f) ∧ reduced f p
| (f · g) := λ p, p (f · g) ∧ reduced f p ∧ reduced g p

def reduced_of : (utlc → bool) → utlc → bool := λ h f, reduced f h

section
local attribute [simp] reduced reduced_of
variables (head_pred: utlc → bool)

theorem down_reduced: reduced_of head_pred ↓n ↔ head_pred ↓n :=
by simp

theorem lambda_reduced: reduced_of head_pred Λ f ↔ head_pred Λ f ∧ reduced_of head_pred f :=
by simp

theorem dot_reduced: reduced_of head_pred (f·g) ↔ head_pred (f·g) ∧ reduced_of head_pred f ∧ reduced_of head_pred g :=
by simp
end
attribute [irreducible] reduced_of
attribute [simp] down_reduced lambda_reduced dot_reduced

variables {head_pred: utlc → bool}

theorem head_reduced_of_reduced: reduced_of head_pred f → head_pred f :=
by { cases f; simp; repeat {intro }; assumption}

theorem reduced_iff_not_reduction_step: (∀ f, head_pred f ↔ ∀ g, ¬ head_step f g) → (∀ f, reduced_of head_pred f ↔ ∀ g, ¬ reduction_step_of head_step f g) :=
begin
  have hforall : ∀ (f : utlc → utlc) (p: utlc → Prop), (∀ x y, x = f y → p y) ↔ (∀ y, p y) :=
      λ f p, ⟨ λ q x, q (f x) x rfl, λ p x y _, p y ⟩,
  intros p f,
  induction f using lambda_calculus.utlc.notation_induction_on,
  { simp[p] },
  { simp [← p, f_ih, not_or_distrib, forall_and_distrib, hforall] },
  { simp [← p, f_ih_f, f_ih_g, not_or_distrib, forall_and_distrib, hforall] }
end

end utlc
end lambda_calculus


/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.opposites
import category_theory.hom_functor

/-!
# The Yoneda embedding

The Yoneda embedding as a functor `yoneda : C ⥤ (Cᵒᵖ ⥤ Type v₁)`,
along with an instance that it is `fully_faithful`.

Also the Yoneda lemma, `yoneda_lemma : (yoneda_pairing C) ≅ (yoneda_evaluation C)`.
-/

namespace category_theory
open opposite

universes v₁ u₁ u₂ -- declare the `v`'s first; see `category_theory.category` for an explanation

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

@[simps] def yoneda : C ⥤ (Cᵒᵖ ⥤ Type v₁) :=
{ obj := λ X,
  { obj := λ Y, unop Y ⟶ X,
    map := λ Y Y' f g, f.unop ≫ g,
    map_comp' := λ _ _ _ f g, begin ext, dsimp, erw [category.assoc] end,
    map_id' := λ Y, begin ext, dsimp, erw [category.id_comp] end },
  map := λ X X' f, { app := λ Y g, g ≫ f } }

@[simps] def coyoneda : Cᵒᵖ ⥤ (C ⥤ Type v₁) :=
{ obj := λ X,
  { obj := λ Y, unop X ⟶ Y,
    map := λ Y Y' f g, g ≫ f,
    map_comp' := λ _ _ _ f g, begin ext1, dsimp, erw [category.assoc] end,
    map_id' := λ Y, begin ext1, dsimp, erw [category.comp_id] end },
  map := λ X X' f, { app := λ Y g, f.unop ≫ g },
  map_comp' := λ _ _ _ f g, begin ext, dsimp, erw [category.assoc] end,
  map_id' := λ X, begin ext, dsimp, erw [category.id_comp] end }

namespace yoneda

lemma obj_map_id {X Y : C} (f : op X ⟶ op Y) :
  ((@yoneda C _).obj X).map f (𝟙 X) = ((@yoneda C _).map f.unop).app (op Y) (𝟙 Y) :=
by obviously

@[simp] lemma naturality {X Y : C} (α : yoneda.obj X ⟶ yoneda.obj Y)
  {Z Z' : C} (f : Z ⟶ Z') (h : Z' ⟶ X) : f ≫ α.app (op Z') h = α.app (op Z) (f ≫ h) :=
begin erw [functor_to_types.naturality], refl end

instance yoneda_full : full (@yoneda C _) :=
{ preimage := λ X Y f, (f.app (op X)) (𝟙 X) }
instance yoneda_faithful : faithful (@yoneda C _) :=
{ injectivity' := λ X Y f g p,
  begin
    injection p with h,
    convert (congr_fun (congr_fun h (op X)) (𝟙 X)); dsimp; simp,
  end }

/-- Extensionality via Yoneda. The typical usage would be
```
-- Goal is `X ≅ Y`
apply yoneda.ext,
-- Goals are now functions `(Z ⟶ X) → (Z ⟶ Y)`, `(Z ⟶ Y) → (Z ⟶ X)`, and the fact that these
functions are inverses and natural in `Z`.
```
-/
def ext (X Y : C)
  (p : Π {Z : C}, (Z ⟶ X) → (Z ⟶ Y)) (q : Π {Z : C}, (Z ⟶ Y) → (Z ⟶ X))
  (h₁ : Π {Z : C} (f : Z ⟶ X), q (p f) = f) (h₂ : Π {Z : C} (f : Z ⟶ Y), p (q f) = f)
  (n : Π {Z Z' : C} (f : Z' ⟶ Z) (g : Z ⟶ X), p (f ≫ g) = f ≫ p g) : X ≅ Y :=
@preimage_iso _ _ _ _ yoneda _ _ _ _
  (nat_iso.of_components (λ Z, { hom := p, inv := q, }) (by tidy))

def is_iso {X Y : C} (f : X ⟶ Y) [is_iso (yoneda.map f)] : is_iso f :=
is_iso_of_fully_faithful yoneda f

end yoneda

namespace coyoneda

@[simp] lemma naturality {X Y : Cᵒᵖ} (α : coyoneda.obj X ⟶ coyoneda.obj Y)
  {Z Z' : C} (f : Z' ⟶ Z) (h : unop X ⟶ Z') : (α.app Z' h) ≫ f = α.app Z (h ≫ f) :=
begin erw [functor_to_types.naturality], refl end

instance coyoneda_full : full (@coyoneda C _) :=
{ preimage := λ X Y f, ((f.app (unop X)) (𝟙 _)).op }
instance coyoneda_faithful : faithful (@coyoneda C _) :=
{ injectivity' := λ X Y f g p,
  begin
    injection p with h,
    have t := (congr_fun (congr_fun h (unop X)) (𝟙 _)),
    simpa using congr_arg has_hom.hom.op t,
  end }

def is_iso {X Y : Cᵒᵖ} (f : X ⟶ Y) [is_iso (coyoneda.map f)] : is_iso f :=
is_iso_of_fully_faithful coyoneda f

end coyoneda

class representable (F : Cᵒᵖ ⥤ Type v₁) :=
(X : C)
(w : yoneda.obj X ≅ F)

end category_theory

namespace category_theory
-- For the rest of the file, we are using product categories,
-- so need to restrict to the case morphisms are in 'Type', not 'Sort'.

universes v₁ u₁ u₂ -- declare the `v`'s first; see `category_theory.category` for an explanation

open opposite

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

-- We need to help typeclass inference with some awkward universe levels here.
instance prod_category_instance_1 : category ((Cᵒᵖ ⥤ Type v₁) × Cᵒᵖ) :=
category_theory.prod.{(max u₁ v₁) v₁} (Cᵒᵖ ⥤ Type v₁) Cᵒᵖ

instance prod_category_instance_2 : category (Cᵒᵖ × (Cᵒᵖ ⥤ Type v₁)) :=
category_theory.prod.{v₁ (max u₁ v₁)} Cᵒᵖ (Cᵒᵖ ⥤ Type v₁)

open yoneda

def yoneda_evaluation : Cᵒᵖ × (Cᵒᵖ ⥤ Type v₁) ⥤ Type (max u₁ v₁) :=
evaluation_uncurried Cᵒᵖ (Type v₁) ⋙ ulift_functor.{u₁}

@[simp] lemma yoneda_evaluation_map_down
  (P Q : Cᵒᵖ × (Cᵒᵖ ⥤ Type v₁)) (α : P ⟶ Q) (x : (yoneda_evaluation C).obj P) :
  ((yoneda_evaluation C).map α x).down = α.2.app Q.1 (P.2.map α.1 x.down) := rfl

def yoneda_pairing : Cᵒᵖ × (Cᵒᵖ ⥤ Type v₁) ⥤ Type (max u₁ v₁) :=
functor.prod yoneda.op (𝟭 (Cᵒᵖ ⥤ Type v₁)) ⋙ functor.hom (Cᵒᵖ ⥤ Type v₁)

@[simp] lemma yoneda_pairing_map
  (P Q : Cᵒᵖ × (Cᵒᵖ ⥤ Type v₁)) (α : P ⟶ Q) (β : (yoneda_pairing C).obj P) :
  (yoneda_pairing C).map α β = yoneda.map α.1.unop ≫ β ≫ α.2 := rfl

def yoneda_lemma : yoneda_pairing C ≅ yoneda_evaluation C :=
{ hom :=
  { app := λ F x, ulift.up ((x.app F.1) (𝟙 (unop F.1))),
    naturality' :=
    begin
      intros X Y f, ext, dsimp,
      erw [category.id_comp,
           ←functor_to_types.naturality,
           obj_map_id,
           functor_to_types.naturality,
           functor_to_types.map_id]
    end },
  inv :=
  { app := λ F x,
    { app := λ X a, (F.2.map a.op) x.down,
      naturality' :=
      begin
        intros X Y f, ext, dsimp,
        rw [functor_to_types.map_comp]
      end },
    naturality' :=
    begin
      intros X Y f, ext, dsimp,
      rw [←functor_to_types.naturality, functor_to_types.map_comp]
    end },
  hom_inv_id' :=
  begin
    ext, dsimp,
    erw [←functor_to_types.naturality,
         obj_map_id,
         functor_to_types.naturality,
         functor_to_types.map_id],
    refl,
  end,
  inv_hom_id' :=
  begin
    ext, dsimp,
    rw [functor_to_types.map_id]
  end }.

variables {C}

@[simp] def yoneda_sections (X : C) (F : Cᵒᵖ ⥤ Type v₁) :
  (yoneda.obj X ⟶ F) ≅ ulift.{u₁} (F.obj (op X)) :=
(yoneda_lemma C).app (op X, F)

omit 𝒞
@[simp] def yoneda_sections_small {C : Type u₁} [small_category C] (X : C) (F : Cᵒᵖ ⥤ Type u₁) :
  (yoneda.obj X ⟶ F) ≅ F.obj (op X) :=
yoneda_sections X F ≪≫ ulift_trivial _

end category_theory


section RA

 axiom u : Type

 axiom _water_n_1  : u → Prop
 axiom _negligible_a_1 : u → Prop
 axiom _solubility_n_1 : u → Prop
 axiom _of_p : u → u → Prop
 axiom _bioaccumulation_nn_u_unknown : u → Prop
 axiom _low_a_on : u → Prop
 axiom _potential_n_1 : u → Prop
 axiom _have_v_1 : u → u → Prop
 axiom _log_n_of : u → u → Prop

 axiom Kow : u
 axiom X : u

 axiom poss : u → u → Prop
 axiom compound : u → u → Prop

 axiom bioaccumulation_potential : u → Prop
 axiom water_solubility : u → Prop
 axiom log_kow : u → Prop

 axiom f_bioaccumulation_potential : u → u
 axiom f_water_solubility : u → u
 axiom f_log_kow : u → u

 axiom low : u → Prop
 axiom high : u → Prop

 -- from NL questions

 def PA : Prop := ∃ x9, _water_n_1 x9
  ∧ (∃ x3, (∃ x15, X = x15 ∧ compound x3 x9 ∧ _solubility_n_1 x3 ∧ _of_p x3 x15) ∧ _negligible_a_1 x3)

 def PB : Prop := ∃ x9, (∃ x17, _bioaccumulation_nn_u_unknown x17 ∧ _low_a_on x9 ∧ compound x9 x17 ∧ _potential_n_1 x9)
  ∧ (∃ x3, X = x3 ∧ _have_v_1 x3 x9)

 def PC : Prop := ∃ x3, (∃ x5, X = x5 ∧ (∃ x15, Kow = x15 ∧ poss x3 x5 ∧ _log_n_of x3 x15)) ∧ _low_a_on x3

 -- axioms from the Domain and Grammar

 variable (g1 : ∀ x p, _have_v_1 x p ↔ _of_p p x)
 variable (g2 : ∀ x p, poss p x ↔ _of_p p x)

 variable (g3 : ∀ x y, compound x y → _water_n_1 y → _solubility_n_1 x → water_solubility x)
 variable (g4 : ∀ x y, compound x y → _bioaccumulation_nn_u_unknown y → _potential_n_1 x → bioaccumulation_potential x)
 variable (g5 : ∀ x, _log_n_of x Kow → log_kow x)

 variable (g6 : ∀ x, _negligible_a_1 x ↔ _low_a_on x)

 variable (g7 : ∀ x p, _have_v_1 x p → _low_a_on p → water_solubility p → low (f_water_solubility x))
 variable (g8 : ∀ x p, _have_v_1 x p → _low_a_on p → bioaccumulation_potential p → low (f_bioaccumulation_potential x))
 variable (g9 : ∀ x p, _have_v_1 x p → _low_a_on p → log_kow p → low (f_log_kow x))

 -- may not be necessary
 variable (g10 : ∀ x, low x ↔ ¬ high x )
 variable (g11 : ∀ x, high (f_log_kow x) → high (f_bioaccumulation_potential x))
 variable (g12 : ∀ x, low (f_log_kow x) → high (f_water_solubility x))

 theorem test : PA → PB → PC → False := by
   unfold PA PB PC
   intro ⟨a1, ⟨h1, ⟨a2, ⟨⟨a3,⟨h2,h4,h5,h6⟩⟩, h3⟩⟩⟩⟩
   intro _
   intro ⟨c1, ⟨⟨c2,⟨k1,⟨c4,⟨k2,k3,k4⟩⟩⟩⟩, k5⟩⟩
   subst k1 h2 k2
   have g31 := (g3 a2 a1) h4 h1 h5
   -- have g41 := (g4 b1 b2) l3 l1 l4
   have g51 := (g5 c1) k4
   have g61 := (g6 a2).1 h3
   -- have g81 := (g8 X b1) l6 l2 g41
   have g₁ := (g1 X c1).2 $ (g2 X c1).1 k3
   have g₂ := (g1 X a2).2 h6
   have g71 := (g7 X a2) g₂ g61 g31
   have g91 := (g9 X c1) g₁ k5 g51
   -- clear h4 h1 h5 l3 l1 l4 k4 g3 g4 g5 g6 h3 k3 h6 g₁ g₂ l2 k5 l6 g61 g7 g8 g9 g1 g2
   have g₃ := (g12 X) g91
   exact (g10 $ f_water_solubility X).1 g71 g₃

end RA