/-
We now introduce the applicative typeclass. Here
it is as copied mostly verbatim from Lean's library
(credit DeMoura and Ulrich).
-/

import .functor

namespace hidden

open function   -- for definition of "const" used at end of file
universes u v

/-
Now suppose that we want to generalize functors, which allow
for mapping of *one-argument* functions, such as inc, over
functorial values, to enable mapping of n-argument functions
over functorial values for any natural number, n.

As a special case, we have the usual functor mapping function,
which works as follows: (α → β) → f α → f β. In plain English,
it takes a pure one-argument function from (α → β) and applies
it to each value in the functorial value of type f α.

Now consider a function of type α → β → γ (think of addition
of nats, of type nat → nat → nat, for example). Here what we
will want is a mapping function that takes a pure function of
type α → β → γ then a functor of α values *then a functor of
β values* to produce a functor of γ values.

So suppose our pure function is nat addition and that we
want to map this two-argument function. We'll need a list
of natural numbers as first arguments. We'll map add over
it, but of course we won't get a list of resulting nats;
rather we'll get a list of partially evaluated functions.
-/

#reduce nat.add <$> [1,2,3] -- remember <$> is functor.map

/-
We will then want to apply each of these functions to each
of their second arguments.
-/

/-
Now consider mapping a pure function with three arguments.
We take our pure function, map it over the list of first
arguments, getting a list of partially evaluate functions
that expect two more arguments. We then want to apply each
of these to their second arguments in a second list to get
a list of further partially evaluate functions expecting
their last arguments. We apply them to their arguments in
the third list to finally get a list of the values of the
function applied to all of its arguments, which come from
the given lists.
-/

/-
So what we're seeing here is that once we bootstrap the
process given a pure function, what we've now got is a
situation in which we have a *list* of functions each of
which takes some number of arguments, and that many lists
of arguments.
-/

/-
Bootstrap
-/
class has_pure (f : Type u → Type v) :=
(pure {α : Type u} : α → f α)

/-
Apply next step. Given a context (list, tree, option)
of functions of type (α → β), *where β can itself be a
function type*, and given a context of argument values
(of type α), compute and return a corresponding context
of result values (of type β). Understand that if β is
itself a function type, then what's returned here is
"another collection of functions." The seq function is
thus a means to apply a context containing functions
to a context containing arguments to get a context of
results, each of which itself could be a function of
one fewer arguments.
-/
class has_seq (f : Type u → Type v) : Type (max (u+1) v) :=
(seq  : Π {α β : Type u}, f (α → β) → f α → f β)

-- infix notation for seq (** instead of * to not conflict)
infixl ` <**> `:60 := has_seq.seq

/-
And finally, the applicative functor typeclass. Note that
this typeclass (1) extends functor, thus inheriting its map
field; (2) it also extends has_pure and has_seq, as defined
just above, thus gaining pure and seq fields, each of the
requisite type.

Finally, note that we implement the "map" function once and
for all, for all instances of this typeclass. What does it
do? It takes a function of type α → β, uses pure to turn it
into a (singleton) container of functions, and then uses the
seq (<*>) operator to map this container of functions (x)
over a container of argument values (y).
-/
class applicative (f : Type u → Type v) extends functor f, has_pure f, has_seq f :=
(map       := λ _ _ x y, pure x <**> y)

/-
Note that it *extends* the functor typeclass. Look for the use of
its "map" function in the definition of the applicative functor's
"seq" functions, coming up next.
-/

/-
The "applicative option" instance implements function application
*with built-in failure propagation*.
-/

def pure_option {α : Type u} : α → option α
| a := some a

def seq_option : Π {α β : Type u}, option (α → β) → option α → option β
| α β none _ := none
| α β (some func) oa := functor.map func oa  -- Use's functor's option_map!

instance : has_pure option := ⟨ @pure_option ⟩
instance : has_seq option := ⟨ @seq_option ⟩
instance : applicative option := ⟨ ⟩

-- examples with one-argument functions
#reduce pure (nat.succ) <**> none
#reduce none <**> some 1
#reduce pure (nat.succ) <**> (some 1)
#eval pure (λ s, s++"!") <**> (some "Hello")

-- examples with multi-argument functions
#reduce pure (nat.mul) <**> some 3
#reduce pure (nat.mul) <**> some 3 <**> some 4
#reduce pure (nat.mul) <**> none <**> some 4
#reduce pure (nat.mul) <**> some 3 <**> none

/-
Think of "none" as indicating a failure to compute
a function argument. What we've thus produced here,
in the form of the (applicative option) instance is
a generalization of *function application,* where
a failure to produce the function to be applied, or
the failure to produce any of its arguments, yields
a failure return. In the case where the function and
all of its arguments are given, we just get ordinary
function application.

Another way to think about this is that <**> handles
any error propagation "under the hood", leaving us as
programmers with an notion of function application
that appears works pretty much as usual. This is an
example that shows how, by overloading applicative
for option we obtain a new programming abstraction:
of ordinary function application (on the surface)
but with additional effects handling (in this case
error handling) being taken care of under the hood.
-/

/-
The applicative list typeclass instance.

In the preceding example, we had either zero or one
functions in an option and zero or one arguments in
a second option. In the "normal" case, where both the
function and the argument are provided, we just apply
the function to the argument and return the result in
a "some _" option value.

Now we turn to (applicative list) type. Here the seq
operator will take a list of zero or more functions and
a list of zero or more arguments and will return a list
containing the values obtained by applying each function
in the function list to each value in the argument list.

The way to think about this is that we are implementing
a kind of non-deterministic, multi-valued computation.
-/

def pure_list {α : Type u} : α → list α | a := [a]
def seq_list : Π {α β : Type u}, list (α → β) → list α → list β
| α β list.nil _ := list.nil
| α β (hf::tf) l := list.append (functor.map hf l) (seq_list tf l)

instance : has_pure list := ⟨ @pure_list ⟩
instance : has_seq list := ⟨ @seq_list ⟩
instance : applicative list := ⟨ ⟩

-- tests with one-argument functions
#reduce seq_list [] [1,2,3] -- apply empty list of functions
#reduce [] <**> [1,2,3]      -- same thing using infix operator

#reduce seq_list [nat.succ] []
#reduce [nat.succ] <**> []

#reduce seq_list [nat.succ] [1,2,3]
#reduce [nat.succ] <**> [1,2,3]

#reduce seq_list (pure nat.succ) [1,2,3]
#reduce (pure nat.succ) <**> [1,2,3]

#reduce [nat.succ, nat.pred] <**> []
#reduce [nat.succ, nat.pred] <**> [1,2,3]

-- tests with two-argument functions!
#reduce (pure nat.add) <*> [1,2,3]
#reduce (pure nat.add) <**> [1,2,3] <**> [2,4,6]
#reduce [nat.add, nat.mul] <**> [1,2,3] <**> [2,4,6]

/-
In practice we usually don't explicitly apply lists of
multiple functions directly to argument lists. Rather,
again in practice, we're usually interesting in applying
a single function to mult-valued arguments, so we use
"pure" to lift the function value into the list context
and then everything else is done by <**>, which, as we
have just seen, does tend to produce lists of functions
as intermediate results that get "applied" by <**> to
downstream argument lists (multi-valued arguments).
-/

end hidden


import category_theory.preadditive.functor_category
import category_theory.limits.shapes.finite_products
import category_theory.limits.shapes.biproducts
import category_theory.limits.preserves.filtered

import for_mathlib.homological_complex2
import for_mathlib.additive_functor

import breen_deligne.homotopy

noncomputable theory

open_locale big_operators

open category_theory category_theory.limits

namespace category_theory
namespace preadditive

variables {𝒜 : Type*} [category 𝒜] [has_zero_morphisms 𝒜] [has_finite_biproducts 𝒜]

-- move this
@[simps {fully_applied := ff}]
def Pow (n : ℕ) : 𝒜 ⥤ 𝒜 :=
{ obj := λ A, ⨁ (λ (i : fin n), A),
  map := λ A B f, biproduct.map (λ i, f),
  map_id' := λ A, by { ext i j, simp only [biproduct.ι_map, category.id_comp, category.comp_id], },
  map_comp' := λ A B C f g, by { ext i j, simp only [biproduct.ι_map_assoc, category.assoc], } }

-- move this
attribute [simps] comp_hom
.

instance (n : ℕ) {J : Type*} [category J] : preserves_colimits_of_shape J (Pow n : 𝒜 ⥤ 𝒜) :=
{ preserves_colimit := λ K,
  { preserves := λ c hc,
    { desc := λ s, biproduct.desc $ λ i,
        let t : cocone K :=
        { X := s.X,
          ι := { app := λ j, show K.obj j ⟶ (K ⋙ Pow n).obj j, from biproduct.ι _ i,
                naturality' := by intros X Y f;
                  simp only [functor.comp_map, Pow_map, biproduct.ι_map], } ≫ s.ι } in
        hc.desc t,
      fac' := begin
        intros, ext,
        simp only [Pow_map, functor.map_cocone_ι_app, biproduct.map_desc,
          is_colimit.fac, nat_trans.comp_app, biproduct.ι_desc],
      end,
      uniq' := begin
        intros, ext i,
        simp only [biproduct.ι_desc],
        let t : cocone K :=
        { X := s.X,
          ι := { app := λ j, show K.obj j ⟶ (K ⋙ Pow n).obj j, from biproduct.ι _ i,
                naturality' := by intros X Y f;
                  simp only [functor.comp_map, Pow_map, biproduct.ι_map], } ≫ s.ι },
        refine hc.uniq t (_ ≫ m) _,
        intro j,
        simp only [nat_trans.comp_app, ← w,
          functor.map_cocone_ι_app, Pow_map, biproduct.ι_map_assoc],
      end } } }

instance (n : ℕ) : preserves_colimits (Pow n : 𝒜 ⥤ 𝒜) :=
{ preserves_colimits_of_shape := λ J hJ, by apply_instance }

end preadditive
end category_theory

namespace homotopy

variables {ι 𝒜 : Type*} [category 𝒜] [preadditive 𝒜] {c : complex_shape ι}
variables {C D : homological_complex 𝒜 c} {f g : C ⟶ D}

@[simps]
def congr (h : homotopy f g) (f' g' : C ⟶ D) (hf : f = f') (hg : g = g') :
  homotopy f' g' :=
{ comm := by simpa only [hf, hg] using h.comm,
  .. h }

end homotopy

namespace breen_deligne

open category_theory.preadditive

variables (BD : data)
variables {𝒜 : Type*} [category 𝒜] [preadditive 𝒜] [has_finite_biproducts 𝒜]
variables (F : 𝒜 ⥤ 𝒜)

namespace basic_universal_map

variables {m n o : ℕ} (f : basic_universal_map m n) (g : basic_universal_map n o)

@[simps {fully_applied := ff}]
def eval_Pow : (Pow m : 𝒜 ⥤ 𝒜) ⟶ Pow n :=
{ app := λ A, biproduct.matrix (λ i j, f j i • 𝟙 A),
  naturality' := begin
    intros, ext i j,
    simp only [Pow_map, biproduct.ι_map_assoc, category.assoc, biproduct.matrix_π,
      biproduct.map_π, biproduct.ι_desc, biproduct.matrix_π_assoc, biproduct.ι_desc_assoc,
      comp_zsmul, zsmul_comp, category.comp_id, category.id_comp],
  end }

@[simp] lemma eval_Pow_comp : @eval_Pow 𝒜 _ _ _ _ _ (comp g f) = f.eval_Pow ≫ g.eval_Pow :=
begin
  ext A i j,
  simp only [eval_Pow_app, nat_trans.comp_app, category.assoc, biproduct.ι_map_assoc,
    biproduct.matrix_π, biproduct.ι_matrix_assoc, biproduct.lift_desc,
    biproduct.map_π, biproduct.ι_desc, biproduct.matrix_π_assoc, biproduct.ι_desc_assoc,
    comp_zsmul, zsmul_comp, category.comp_id, category.id_comp],
  simp only [comp, add_monoid_hom.mk'_apply, matrix.mul, matrix.dot_product,
    finset.sum_smul, mul_smul],
  rw [finset.sum_congr rfl],
  rintros j -,
  rw smul_comm,
end

end basic_universal_map

namespace universal_map

variables {m n o : ℕ} (f : universal_map m n) (g : universal_map n o)

/- Note: this definition is generalized in `eval1half.lean` for a functor
`F : A₁ ⥤ A₂`. This generalization is used in `apply_Pow.lean`. -/
def eval_Pow : universal_map m n →+ (Pow m ⋙ F ⟶ Pow n ⋙ F) :=
free_abelian_group.lift $ λ g : basic_universal_map m n, whisker_right g.eval_Pow F

lemma eval_Pow_of (g : basic_universal_map m n) :
  eval_Pow F (free_abelian_group.of g) = whisker_right g.eval_Pow F :=
free_abelian_group.lift.of _ _

@[simp] lemma eval_Pow_zero : eval_Pow F (0 : universal_map m n) = 0 :=
add_monoid_hom.map_zero _

lemma eval_Pow_zero_app (A : 𝒜) : (eval_Pow F (0 : universal_map m n)).app A = 0 :=
by rw [eval_Pow_zero, zero_app]

lemma eval_Pow_comp : eval_Pow F (universal_map.comp g f) = eval_Pow F f ≫ eval_Pow F g :=
begin
  rw [← add_monoid_hom.comp_apply, ← add_monoid_hom.comp_hom_apply_apply,
    ← add_monoid_hom.comp_apply, eq_comm,
    ← category_theory.preadditive.comp_hom_apply_apply, ← add_monoid_hom.flip_apply,
    ← add_monoid_hom.comp_apply, ← add_monoid_hom.comp_hom_apply_apply,
    ← add_monoid_hom.flip_apply _ _ (eval_Pow F),
    ← add_monoid_hom.comp_apply, ← add_monoid_hom.comp_hom_apply_apply,
    ← add_monoid_hom.comp_apply, ← add_monoid_hom.comp_hom_apply_apply],
  congr' 2,
  clear f g,
  ext g f : 2,
  simp only [add_monoid_hom.comp_hom_apply_apply, add_monoid_hom.comp_apply,
    add_monoid_hom.flip_apply, category_theory.preadditive.comp_hom_apply_apply,
    comp_of, eval_Pow_of, whisker_right_comp, basic_universal_map.eval_Pow_comp],
end

lemma eval_Pow_comp_app (A : 𝒜) :
  (eval_Pow F (universal_map.comp g f)).app A = (eval_Pow F f).app A ≫ (eval_Pow F g).app A :=
by rw [eval_Pow_comp, nat_trans.comp_app]

@[simps {fully_applied := ff}]
def eval_Pow_functor : FreeMat ⥤ (𝒜 ⥤ 𝒜) :=
{ obj := λ n, Pow n ⋙ F,
  map := λ m n f, eval_Pow F f,
  map_id' := λ n,
  begin
    refine (eval_Pow_of F _).trans _,
    ext A : 2, dsimp,
    rw ← F.map_id, congr' 1,
    ext i j : 2,
    simp only [biproduct.ι_matrix, category.comp_id, biproduct.lift_π, basic_universal_map.id],
    rw biproduct.ι_π,
    split_ifs with hij,
    { cases hij, rw [matrix.one_apply_eq, one_smul, eq_to_hom_refl], },
    { rw [matrix.one_apply_ne, zero_smul], dsimp, rintro rfl, exact hij rfl }
  end,
  map_comp' := λ m n o f g, eval_Pow_comp F _ _ }

instance eval_Pow_functor_additive : (eval_Pow_functor F).additive :=
{ map_add' := λ m n f g, by { dsimp [eval_Pow], rw add_monoid_hom.map_add } }

end universal_map

namespace data

open universal_map

@[simps {fully_applied := ff}]
def eval_functor' : data ⥤ chain_complex (𝒜 ⥤ 𝒜) ℕ :=
(eval_Pow_functor F).map_homological_complex _

@[simps {fully_applied := ff}]
def eval_functor : data ⥤ 𝒜 ⥤ chain_complex 𝒜 ℕ :=
eval_functor' F ⋙ homological_complex.functor_eval.flip
.

-- generalize to arbitrary homological complexes
instance homological_complex.functor_eval_flip_preserves_colimits_of_shape
  (J : Type*) [category J] (F : chain_complex (𝒜 ⥤ 𝒜) ℕ)
  [∀ i, preserves_colimits_of_shape J (F.X i)] :
  preserves_colimits_of_shape J (homological_complex.functor_eval.flip.obj F) :=
{ preserves_colimit := λ K,
  { preserves := λ c hc,
    let t : Π (s : cocone (K ⋙ homological_complex.functor_eval.flip.obj F))
        (i : ℕ), cocone (K ⋙ F.X i) := λ s i,
    { X := s.X.X i,
      ι := { app := λ j, show (K ⋙ F.X i).obj j ⟶ s.X.X i, from (s.ι.app j).f i,
            naturality' := begin
              intros a b φ, have := s.ι.naturality φ, dsimp at this ⊢,
              simp only [category.comp_id] at this ⊢,
              rw ← this, refl
            end } },
      u : Π (s : cocone (K ⋙ homological_complex.functor_eval.flip.obj F))
        (i j : ℕ), cocone (K ⋙ F.X i) := λ s i j,
    { X := s.X.X j,
      ι := { app := λ k, show (K ⋙ F.X i).obj k ⟶ s.X.X j,
                         from (whisker_left K (F.d i j)).app k ≫ (s.ι.app k).f j,
            naturality' := begin
              intros a b φ, have := s.ι.naturality φ, dsimp at this ⊢,
              simp only [category.comp_id] at this ⊢,
              rw [← this, (F.d i j).naturality_assoc], refl,
            end } } in
    { desc := λ s,
      { f := λ i, (is_colimit_of_preserves (F.X i) hc).desc (t s i),
        comm' := begin
          intros i j h, dsimp,
          have := (is_colimit_of_preserves (F.X i) hc).uniq (u s i j),
          refine (this _ _).trans (this _ _).symm,
          { intros j', dsimp,
            erw [(is_colimit_of_preserves (F.X i) hc).fac_assoc],
            apply (s.ι.app j').comm, },
          { intros j', dsimp,
            rw nat_trans.naturality_assoc,
            erw [(is_colimit_of_preserves (F.X j) hc).fac], }
        end },
      fac' := by { intros, ext i, dsimp, erw [(is_colimit_of_preserves (F.X i) hc).fac], },
      uniq' := begin
        intros, ext i,
        exact (is_colimit_of_preserves (F.X i) hc).uniq (t s i) (m.f i)
          (λ j, homological_complex.congr_hom (w j) i),
      end, } } }

instance eval_functor_preserves_colimits_of_shape
  (BD : data) (J : Type*) [category J] [preserves_colimits_of_shape J F] :
  preserves_colimits_of_shape J ((eval_functor F).obj BD) :=
begin
  refine @homological_complex.functor_eval_flip_preserves_colimits_of_shape _ _ _ _ J _
    ((eval_functor' F).obj BD) (id _),
  intro i,
  show preserves_colimits_of_shape J (Pow (BD.X i) ⋙ F),
  apply_instance
end

instance eval_functor_preserves_filtered_colimits (BD : data) [preserves_filtered_colimits F] :
  preserves_filtered_colimits ((eval_functor F).obj BD) :=
{ preserves_filtered_colimits := by introsI; apply_instance }

-- @[simps]
-- def eval_functor.obj (M : 𝒜) : chain_complex 𝒜 ℕ :=
-- { X := λ n, (Pow (BD.X n) ⋙ F).obj M,
--   d := λ m n, (eval_Pow F (BD.d m n)).app M,
--   shape' := λ i j h, by rw [BD.shape i j h, universal_map.eval_Pow_zero_app],
--   d_comp_d' := λ i j k hij hjk, begin
--     rw [← universal_map.eval_Pow_comp_app],
--     have := BD.d_comp_d i j k,
--     convert universal_map.eval_Pow_zero_app _ _ using 3,
--   end }

-- @[simps {fully_applied := ff}]
-- def eval_functor : 𝒜 ⥤ chain_complex 𝒜 ℕ :=
-- { obj := eval_functor.obj BD F,
--   map := λ A B f,
--   { f := λ n, (Pow (BD.X n) ⋙ F).map f,
--     comm' := λ m n h, by simp only [eval_functor.obj_d, nat_trans.naturality] },
--   map_id' := λ A, by { ext n, exact category_theory.functor.map_id _ _ },
--   map_comp' := λ A B C f g, by { ext n, exact category_theory.functor.map_comp _ _ _ } }

-- @[simps {fully_applied := ff}]
-- def map_eval_functor {BD₁ BD₂ : data} (φ : BD₁ ⟶ BD₂) :
--   BD₁.eval_functor F ⟶ BD₂.eval_functor F :=
-- { app := λ A,
--   { f := λ i, (universal_map.eval_Pow F (φ.f i)).app A,
--     comm' := by { intros, dsimp only [eval_functor_obj, eval_functor.obj_d],
--       simp only [← nat_trans.comp_app, ← eval_Pow_comp F], congr' 2, apply φ.comm } },
--   naturality' := λ A B f, by { ext i : 2, apply nat_trans.naturality } }

end data

namespace package

open universal_map

variables (BD' : package) (A : 𝒜)

def eval_homotopy := (eval_Pow_functor F).map_homotopy BD'.homotopy

def eval_homotopy' (A : 𝒜) :=
(eval_Pow_functor F ⋙ (evaluation _ _).obj A).map_homotopy BD'.homotopy

local attribute [instance] has_binary_biproducts_of_finite_biproducts

@[simps]
def Biprod : 𝒜 ⥤ 𝒜 :=
{ obj := λ A, A ⊞ A,
  map := λ A B f, biprod.map f f,
  map_id' := λ A,
    by ext; simp only [biprod.inl_map, biprod.inr_map, category.id_comp, category.comp_id],
  map_comp' := λ A B C f g,
    by ext; simp only [biprod.inl_map_assoc, biprod.inr_map_assoc, category.assoc] }
.

@[simps {fully_applied := ff}]
def Biprod_iso_Pow_two_components (A : 𝒜) : A ⊞ A ≅ (Pow 2).obj A :=
{ hom := biprod.desc
    (biproduct.ι (λ i : fin 2, A) 0)
    (biproduct.ι (λ i : fin 2, A) 1),
  inv := biprod.lift (biproduct.π _ 0) (biproduct.π _ 1),
  hom_inv_id' := begin
    ext;
    simp only [biprod.lift_fst, biprod.lift_snd, biprod.inl_desc_assoc, biprod.inr_desc_assoc,
      biproduct.ι_π_self, category.assoc];
    erw category.id_comp;
    simp only [biprod.inl_fst, biprod.inl_snd, biprod.inr_fst, biprod.inr_snd];
    rw [biproduct.ι_π_ne]; dec_trivial
  end,
  inv_hom_id' := begin
    ext i j,
    erw [category.comp_id],
    simp only [add_comp, comp_add, biprod.lift_desc, category.assoc],
    fin_cases i with [0,1];
    rw [biproduct.ι_π_self_assoc, biproduct.ι_π_ne_assoc, zero_comp],
    swap 2, { dec_trivial },
    swap 3, { dec_trivial },
    { rw add_zero },
    { rw zero_add }
  end }
.

@[simps {fully_applied := ff}]
def Biprod_iso_Pow_two : (Biprod : 𝒜 ⥤ 𝒜) ≅ Pow 2 :=
nat_iso.of_components Biprod_iso_Pow_two_components $ λ A B f,
begin
  ext ⟨i⟩;
  simp only [biproduct.ι_map, Biprod_iso_Pow_two_components_hom, Biprod_map, Pow_map,
    biprod.inl_map_assoc, biprod.inl_desc_assoc, biprod.inr_map_assoc, biprod.inr_desc_assoc,
    biprod.inr_map, category.assoc, biprod.inr_desc],
end
.

@[simps]
def Pow_comp_Pow_components (m n : ℕ) (A : 𝒜) :
  (Pow n).obj ((Pow m).obj A) ≅ (Pow (m * n)).obj A :=
{ hom := biproduct.desc $ λ j, biproduct.desc $ λ i,
    biproduct.ι (λ i : fin _, A) (fin_prod_fin_equiv (i, j)),
  inv := biproduct.lift $ λ j, biproduct.lift $ λ i,
    biproduct.π (λ i : fin _, A) (fin_prod_fin_equiv (i, j)),
  hom_inv_id' := begin
    ext j i j' i' : 4,
    erw [biproduct.ι_desc_assoc, category.comp_id],
    simp only [biproduct.ι_desc_assoc, category.assoc, biproduct.lift_π],
    by_cases hj : j = j',
    { subst hj, rw [biproduct.ι_π_self_assoc],
      by_cases hi : i = i',
      { subst hi, rw [biproduct.ι_π_self, biproduct.ι_π_self] },
      { rw [biproduct.ι_π_ne, biproduct.ι_π_ne],
        { exact hi },
        { simpa only [equiv.apply_eq_iff_eq, and_true, prod.mk.inj_iff, eq_self_iff_true, ne.def] using hi, } } },
    { rw [biproduct.ι_π_ne, biproduct.ι_π_ne_assoc, zero_comp, comp_zero],
      { exact hj },
      { simp only [equiv.apply_eq_iff_eq, prod.mk.inj_iff, ne.def, hj, not_false_iff, and_false], } }
  end,
  inv_hom_id' := begin
    ext k k' : 2,
    erw [category.comp_id],
    simp only [category.assoc, biproduct.lift_desc, sum_comp, comp_sum],
    by_cases h : k = k',
    { subst h,
      rw [biproduct.ι_π_self,
        finset.sum_eq_single ((fin_prod_fin_equiv.symm k).snd : fin _),
        finset.sum_eq_single ((fin_prod_fin_equiv.symm k).fst : fin _)],
      { rw [prod.mk.eta, equiv.apply_symm_apply, biproduct.ι_π_self, biproduct.ι_π_self_assoc], },
      { rintro ⟨i⟩ - hi,
        rw [biproduct.ι_π_ne_assoc, zero_comp],
        dsimp [- fin_prod_fin_equiv_symm_apply],
        simp only [ne.def, ← equiv.symm_apply_eq, prod.ext_iff, not_and_distrib] at hi ⊢,
        exact or.inl (ne.symm hi) },
      { intro h, exact (h (finset.mem_univ _)).elim },
      { rintro ⟨j⟩ - hj,
        rw finset.sum_eq_zero,
        rintro ⟨i⟩ -,
        rw [biproduct.ι_π_ne_assoc, zero_comp],
        dsimp [- fin_prod_fin_equiv_symm_apply],
        simp only [ne.def, ← equiv.symm_apply_eq, prod.ext_iff, not_and_distrib] at hj ⊢,
        exact or.inr (ne.symm hj) },
      { intro h, exact (h (finset.mem_univ _)).elim } },
    { rw [biproduct.ι_π_ne, finset.sum_eq_zero],
      { rintro j -,
        rw [finset.sum_eq_zero],
        rintro i -,
        by_cases hk : k = fin_prod_fin_equiv (i,j),
        { subst hk,
          rw [biproduct.ι_π_self_assoc, biproduct.ι_π_ne],
          simpa only [ne.def] using h, },
        { rw [biproduct.ι_π_ne_assoc, zero_comp],
          dsimp [- fin_prod_fin_equiv_symm_apply],
          simpa only [ne.def] using h, } },
      { rw [ne.def], exact h } },
  end }
.

@[simps {fully_applied := ff}]
def Pow_comp_Pow (m n : ℕ) : (Pow m ⋙ Pow n : 𝒜 ⥤ 𝒜) ≅ Pow (m * n) :=
nat_iso.of_components (Pow_comp_Pow_components m n) $ λ A B f,
begin
  ext ⟨j⟩ ⟨i⟩ ⟨k⟩,
  simp only [biproduct.ι_map, Pow_comp_Pow_components_hom, Pow_map, functor.comp_map,
    biproduct.ι_map_assoc, category.assoc, biproduct.map_π, biproduct.ι_desc_assoc],
end
.

lemma _root_.free_abelian_group.eq_zero_induction
  {α M : Type*} [add_group M] (f : free_abelian_group α → M)
  (h1 : ∀ a, f (free_abelian_group.of a) = 0) (h2 : ∀ x y, f (x + y) = f x + f y) :
  ∀ x, f x = 0 :=
begin
  let F := add_monoid_hom.mk' f h2,
  have hF : ∀ x, F x = f x := λ _, rfl,
  intro x,
  refine free_abelian_group.induction_on x _ h1 _ _,
  { exact F.map_zero },
  { intros, show F _ = 0, rw [F.map_neg, hF, h1, neg_zero], },
  { intros x y hx hy, show F _ = 0, rw [F.map_add, hF, hF, hx, hy, add_zero], },
end

lemma aux' (m n : ℕ) (f : universal_map m n) :
  F.map ((Pow_comp_Pow 2 m).inv.app A ≫ (Pow m).map (Biprod_iso_Pow_two.inv.app A)) ≫
    ((eval_Pow_functor F).map f).app (Biprod.obj A) =
  ((eval_Pow_functor F).map ((mul 2) f)).app A ≫ F.map ((Pow_comp_Pow 2 n).inv.app A ≫
    (Pow n).map (Biprod_iso_Pow_two.inv.app A)) :=
begin
  rw [← sub_eq_zero],
  refine free_abelian_group.eq_zero_induction _ _ _ f; clear f,
  { intro f,
    rw [sub_eq_zero],
    dsimp only [eval_Pow_functor],
    rw [mul_of, eval_Pow_of, eval_Pow_of],
    dsimp only [whisker_right_app, basic_universal_map.eval_Pow_app],
    rw [← F.map_comp, ← F.map_comp],
    congr' 1,
    dsimp only [Pow_comp_Pow, Biprod_iso_Pow_two],
    erw [nat_iso.of_components_inv_app, nat_iso.of_components_inv_app,
      nat_iso.of_components_inv_app],
    dsimp only [Pow_comp_Pow_components_inv, Biprod_iso_Pow_two_components_inv, Pow_map],
    apply category_theory.limits.biproduct.hom_ext,
    rintro ⟨j⟩,
    apply category_theory.limits.biproduct.hom_ext',
    refine fin_prod_fin_equiv.forall_congr_left.mp _,
    rintro ⟨b, i⟩,
    rw [biproduct.lift_map, biproduct.lift_matrix, biproduct.lift_π, comp_sum,
      biproduct.lift_map, category.assoc, biproduct.ι_matrix_assoc, biproduct.lift_π],
    rw [finset.sum_eq_single i],
    { rw [category.assoc],
      ext;
      rw [category.assoc, category.assoc, comp_zsmul, zsmul_comp, comp_zsmul, comp_zsmul,
        category.comp_id, category.assoc, category.assoc];
      [rw biprod.lift_fst, rw biprod.lift_snd];
      rw [biproduct.lift_π, biproduct.lift_π, biproduct.lift_π,
        biproduct.ι_π, basic_universal_map.mul_apply, matrix.reindex_linear_equiv_apply,
        matrix.reindex_apply, matrix.submatrix_apply,
        matrix.kronecker_map, equiv.symm_apply_apply, equiv.symm_apply_apply];
      simp only [dite_eq_ite, equiv.apply_eq_iff_eq, and_true, prod.mk.inj_iff,
        eq_self_iff_true, eq_to_hom_refl, matrix.one_apply,
        ite_mul, ite_smul, one_mul, zero_mul, zero_smul, @eq_comm _ b, smul_ite, smul_zero];
      congr' 1, },
    { rintro i' - hi',
      rw [ne.def, eq_comm] at hi',
      rw [category.assoc],
      ext;
      rw [category.assoc, category.assoc, comp_zsmul, zsmul_comp, comp_zsmul, comp_zsmul,
        category.comp_id, zero_comp];
      [rw biprod.lift_fst, rw biprod.lift_snd];
      rw [biproduct.lift_π, biproduct.ι_π];
      simp only [dite_eq_ite, equiv.apply_eq_iff_eq, and_true, prod.mk.inj_iff,
        eq_self_iff_true, eq_to_hom_refl, equiv.ulift_symm_apply,
        eq_false_intro hi', and_false, if_false, smul_zero], },
    { intro h, exact (h (finset.mem_univ _)).elim } },
  { intros x y,
    simp only [add_monoid_hom.map_add, functor.map_add, comp_add, add_comp, nat_trans.app_add],
    abel }
end
.

@[simps {fully_applied := ff}]
def aux :
  (data.eval_functor F).obj ((data.mul 2).obj BD'.data) ≅
  Biprod ⋙ (data.eval_functor F).obj BD'.data :=
nat_iso.of_components (λ A,
  homological_complex.hom.iso_of_components (λ i, begin
      refine F.map_iso _,
      refine (Pow_comp_Pow 2 (BD'.data.X i)).symm.app A ≪≫ _,
      refine (Pow _).map_iso (Biprod_iso_Pow_two.symm.app A)
    end) $ λ i j hij, aux' F A (BD'.data.X i) (BD'.data.X j) (BD'.data.d i j)) $ λ A B f, begin
      ext i,
      dsimp only [data.eval_functor, data.eval_functor', eval_Pow, eval_Pow_functor_obj,
        functor.map_iso_hom, functor.comp_obj, functor.comp_map, functor.flip_obj_map,
        iso.trans_hom, iso.symm_hom, nat_iso.app_hom,
        functor.map_homological_complex_obj_X,
        homological_complex.functor_eval_map_app_f,
        homological_complex.comp_f,
        homological_complex.hom.iso_of_components_hom_f],
      rw [← F.map_comp, ← F.map_comp, ← category.assoc, nat_trans.naturality,
        category.assoc, category.assoc, functor.comp_map, ← functor.map_comp, ← functor.map_comp,
        nat_trans.naturality],
  end
.

-- move this up
lemma quux (n : ℕ) {N : ℕ} (k : fin N) (A : 𝒜) :
  (basic_universal_map.proj n k).eval_Pow.app A =
  biproduct.matrix (λ i j, if i = fin_prod_fin_equiv (k, j) then 𝟙 A else 0) :=
begin
  apply category_theory.limits.biproduct.hom_ext,
  rintro ⟨j⟩,
  apply category_theory.limits.biproduct.hom_ext',
  refine fin_prod_fin_equiv.forall_congr_left.mp _,
  rintro ⟨l, i⟩,
  dsimp only [basic_universal_map.eval_Pow_app],
  rw [biproduct.matrix_π, biproduct.matrix_π, biproduct.ι_desc, biproduct.ι_desc],
  dsimp only [basic_universal_map.proj, basic_universal_map.proj_aux,
    matrix.reindex_linear_equiv_apply, matrix.reindex_apply, matrix.submatrix,
    matrix.kronecker_map, matrix.of_apply],
  simp only [ite_mul, ite_smul, one_mul, one_smul, zero_mul, zero_smul, matrix.one_apply],
  rw [← ite_and],
  congr' 1,
  apply propext,
  rw [← equiv.symm_apply_eq, prod.ext_iff],
  apply and_congr iff.rfl,
  dsimp only [equiv.punit_prod_symm_apply],
  rw [eq_comm],
end
.

-- move this up
lemma eval_Pow_add {m n : ℕ} (f g : basic_universal_map m n) (A : 𝒜) :
  (f + g).eval_Pow.app A = f.eval_Pow.app A + g.eval_Pow.app A :=
begin
  dsimp [basic_universal_map.eval_Pow_app],
  ext ⟨i⟩ ⟨j⟩,
  simp only [biproduct.ι_matrix, biproduct.lift_π, comp_add, add_comp, add_zsmul],
end
.

def eval_functor_homotopy (A : 𝒜) : _root_.homotopy
  (((data.eval_functor F).obj BD'.data).map (biprod.fst + biprod.snd : A ⊞ A ⟶ A))
  (((data.eval_functor F).obj BD'.data).map (biprod.fst : A ⊞ A ⟶ A) +
    ((data.eval_functor F).obj BD'.data).map (biprod.snd : A ⊞ A ⟶ A)) :=
begin
  refine ((eval_homotopy' F BD' A).symm.comp_left ((aux F BD').inv.app A)).congr _ _ _ _,
  { ext i,
    rw [homological_complex.comp_f, aux_inv_app_f,
      functor.map_homological_complex_map_f, functor.comp_map, eval_Pow_functor_map,
      evaluation_obj_map, data.eval_functor_obj_map_f],
    dsimp only [data.sum, universal_map.sum],
    rw [eval_Pow_of, whisker_right_app, ← F.map_comp, fin.sum_univ_two,
      eval_Pow_add, quux, quux],
    congr' 1,
    apply category_theory.limits.biproduct.hom_ext', rintro m,
    rw [biproduct.ι_desc_assoc, biproduct.ι_map, category.assoc],
    apply category_theory.limits.biproduct.hom_ext, rintro n,
    rw [category.assoc],
    apply category_theory.limits.biprod.hom_ext';
    [rw [biprod.inl_desc_assoc], rw [biprod.inr_desc_assoc]];
    rw [category.assoc, biproduct.ι_desc_assoc, add_comp, comp_add,
      biproduct.matrix_π, biproduct.matrix_π, biproduct.ι_desc, biproduct.ι_desc,
      category.assoc, add_comp, comp_add];
    simp only [biprod.inl_fst_assoc, biprod.inl_snd_assoc,
      biprod.inr_fst_assoc, biprod.inr_snd_assoc, zero_comp, add_zero, zero_add,
      true_and, equiv.apply_eq_iff_eq, prod.mk.inj_iff, one_ne_zero,
      fin.zero_eq_one_iff, fin.one_eq_zero_iff, eq_self_iff_true, if_false, false_and],
      all_goals
      { by_cases hmn : m = n,
        { cases hmn, rw [if_pos rfl, biproduct.ι_π_self], },
        { rw [if_neg, biproduct.ι_π_ne]; [rw [ne.def], skip]; exact hmn } } },
  { ext i,
    rw [homological_complex.comp_f, aux_inv_app_f,
      functor.map_homological_complex_map_f, functor.comp_map, eval_Pow_functor_map,
      evaluation_obj_map,
      homological_complex.add_f_apply,
      data.eval_functor_obj_map_f, data.eval_functor_obj_map_f],
    dsimp only [data.proj, proj],
    rw [add_monoid_hom.map_sum, fin.sum_univ_two, eval_Pow_of, eval_Pow_of,
      nat_trans.app_add, whisker_right_app, whisker_right_app, comp_add,
      ← F.map_comp, ← F.map_comp, quux, quux],
    congr' 2;
    { apply category_theory.limits.biproduct.hom_ext, rintro n,
      rw [biproduct.map_π, category.assoc, biproduct.matrix_π],
      apply category_theory.limits.biproduct.hom_ext', rintro m,
      rw [biproduct.ι_desc_assoc, category.assoc],
      apply category_theory.limits.biprod.hom_ext';
      [rw [biprod.inl_desc_assoc], rw [biprod.inr_desc_assoc]],
      all_goals
      { rw [biproduct.ι_desc_assoc, biproduct.ι_desc];
        simp only [true_and, equiv.apply_eq_iff_eq, prod.mk.inj_iff, eq_self_iff_true];
        by_cases hmn : m = n,
        { cases hmn,
          simp only [biproduct.ι_π_self_assoc, eq_self_iff_true, if_true, if_false,
            biprod.inl_fst, biprod.inr_fst, biprod.inl_snd, biprod.inr_snd,
            zero_ne_one, one_ne_zero, false_and, fin.one_eq_zero_iff, fin.zero_eq_one_iff], },
        { rw biproduct.ι_π_ne_assoc, swap, { rw [ne.def], exact hmn },
          simp only [hmn, if_false, and_false, zero_comp, comp_zero] } } } }
end
.

end package

end breen_deligne


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

import algebraic_topology.split_simplicial_object
import for_mathlib.dold_kan.degeneracies
import for_mathlib.dold_kan.functor_n

/-!

# Split simplicial objects in preadditive categories

In this file we define a functor `nondeg_complex : simplicial_object.split C ⥤ chain_complex C ℕ`
when `C` is a preadditive category with finite coproducts, and get an isomorphism
`to_karoubi_nondeg_complex_iso_N₁ : nondeg_complex ⋙ to_karoubi _ ≅ forget C ⋙ dold_kan.N₁`.
-/

noncomputable theory

open category_theory category_theory.limits category_theory.category
  category_theory.preadditive category_theory.idempotents opposite
  algebraic_topology algebraic_topology.dold_kan

open_locale big_operators simplicial dold_kan

namespace simplicial_object

namespace splitting

variables {C : Type*} [category C] [has_finite_coproducts C]
  {X : simplicial_object C} (s : splitting X)

/-- The projection on a summand of the coproduct decomposition given
by a splitting of a simplicial object. -/
def π_summand [has_zero_morphisms C] {Δ : simplex_categoryᵒᵖ} (A : index_set Δ) :
  X.obj Δ ⟶ s.N A.1.unop.len :=
begin
  refine (s.iso Δ).inv ≫ sigma.desc (λ B, _),
  by_cases B = A,
  { exact eq_to_hom (by { subst h, refl, }), },
  { exact 0, },
end

@[simp, reassoc]
lemma ι_π_summand_eq_id [has_zero_morphisms C] {Δ : simplex_categoryᵒᵖ} (A : index_set Δ) :
  s.ι_summand A ≫ s.π_summand A = 𝟙 _ :=
begin
  dsimp [ι_summand, π_summand],
  simp only [summand, assoc, is_iso.hom_inv_id_assoc],
  erw [colimit.ι_desc, cofan.mk_ι_app],
  dsimp,
  simp only [eq_self_iff_true, if_true],
end

@[simp, reassoc]
lemma ι_π_summand_eq_zero [has_zero_morphisms C] {Δ : simplex_categoryᵒᵖ} (A B : index_set Δ)
  (h : B ≠ A) : s.ι_summand A ≫ s.π_summand B = 0 :=
begin
  dsimp [ι_summand, π_summand],
  simp only [summand, assoc, is_iso.hom_inv_id_assoc],
  erw [colimit.ι_desc, cofan.mk_ι_app],
  apply dif_neg,
  exact h.symm,
end

variable [preadditive C]

lemma decomposition_id (Δ : simplex_categoryᵒᵖ) :
  𝟙 (X.obj Δ) = ∑ (A : index_set Δ), s.π_summand A ≫ s.ι_summand A :=
begin
  apply s.hom_ext',
  intro A,
  rw [comp_id, comp_sum, finset.sum_eq_single A, ι_π_summand_eq_id_assoc],
  { intros B h₁ h₂,
    rw [s.ι_π_summand_eq_zero_assoc _ _ h₂, zero_comp], },
  { simp only [finset.mem_univ, not_true, is_empty.forall_iff], },
end

@[simp, reassoc]
lemma σ_comp_π_summand_id_eq_zero {n : ℕ} (i : fin (n+1)) :
  X.σ i ≫ s.π_summand (index_set.id (op [n+1])) = 0 :=
begin
  apply s.hom_ext',
  intro A,
  dsimp only [simplicial_object.σ],
  rw [comp_zero, s.ι_summand_epi_naturality_assoc A (simplex_category.σ i).op,
    ι_π_summand_eq_zero],
  symmetry,
  change ¬ (A.epi_comp (simplex_category.σ i).op).eq_id,
  rw index_set.eq_id_iff_len_eq,
  have h := simplex_category.len_le_of_epi (infer_instance : epi A.e),
  dsimp at ⊢ h,
  linarith,
end

/-- If a simplicial object `X` in an additive category is split,
then `P_infty` vanishes on all the summands of `X _[n]` which do
not correspond to the identity of `[n]`. -/
lemma ι_summand_comp_P_infty_eq_zero {X : simplicial_object C}
  (s : simplicial_object.splitting X)
  {n : ℕ} (A : simplicial_object.splitting.index_set (op [n]))
  (hA : ¬ A.eq_id) :
  s.ι_summand A ≫ P_infty.f n = 0 :=
begin
  rw simplicial_object.splitting.index_set.eq_id_iff_mono at hA,
  rw [simplicial_object.splitting.ι_summand_eq, assoc,
    degeneracy_comp_P_infty X n A.e hA, comp_zero],
end

lemma comp_P_infty_eq_zero_iff {Z : C} {n : ℕ} (f : Z ⟶ X _[n]) :
  f ≫ P_infty.f n = 0 ↔ f ≫ s.π_summand (index_set.id (op [n])) = 0 :=
begin
  split,
  { intro h,
    cases n,
    { dsimp at h,
      rw [comp_id] at h,
      rw [h, zero_comp], },
    { have h' := f ≫= P_infty_f_add_Q_infty_f (n+1),
      dsimp at h',
      rw [comp_id, comp_add, h, zero_add] at h',
      rw [← h', assoc, Q_infty_f, decomposition_Q, preadditive.sum_comp,
        preadditive.comp_sum, finset.sum_eq_zero],
      intros i hi,
      simp only [assoc, σ_comp_π_summand_id_eq_zero, comp_zero], }, },
  { intro h,
    rw [← comp_id f, assoc, s.decomposition_id, preadditive.sum_comp,
      preadditive.comp_sum, fintype.sum_eq_zero],
    intro A,
    by_cases hA : A.eq_id,
    { dsimp at hA,
      subst hA,
      rw [assoc, reassoc_of h, zero_comp], },
    { simp only [assoc, s.ι_summand_comp_P_infty_eq_zero A hA, comp_zero], }, },
end

@[simp, reassoc]
lemma P_infty_comp_π_summand_id (n : ℕ) :
  P_infty.f n ≫ s.π_summand (index_set.id (op [n])) = s.π_summand (index_set.id (op [n])) :=
begin
  conv_rhs { rw ← id_comp (s.π_summand _), },
  symmetry,
  rw [← sub_eq_zero, ← sub_comp, ← comp_P_infty_eq_zero_iff, sub_comp, id_comp,
    P_infty_f_idem, sub_self],
end

@[simp, reassoc]
lemma π_summand_comp_ι_summand_comp_P_infty_eq_P_infty (n : ℕ) :
  s.π_summand (index_set.id (op [n])) ≫ s.ι_summand (index_set.id (op [n])) ≫ P_infty.f n =
    P_infty.f n :=
begin
  conv_rhs { rw ← id_comp (P_infty.f n), },
  erw [s.decomposition_id, preadditive.sum_comp],
  rw [fintype.sum_eq_single (index_set.id (op [n])), assoc],
  rintros A (hA : ¬A.eq_id),
  rw [assoc, s.ι_summand_comp_P_infty_eq_zero A hA, comp_zero],
end

/-- The differentials `s.d i j : s.N i ⟶ s.N j` on nondegenerate simplices of a split
simplicial object are induced by the differentials on the alternating face map complex. -/
@[simp]
def d (i j : ℕ) : s.N i ⟶ s.N j :=
s.ι_summand (index_set.id (op [i])) ≫ K[X].d i j ≫ s.π_summand (index_set.id (op [j]))

lemma ι_summand_comp_d_comp_π_summand_eq_zero (j k : ℕ) (A : index_set (op [j])) (hA : ¬A.eq_id) :
  s.ι_summand A ≫ K[X].d j k ≫ s.π_summand (index_set.id (op [k])) = 0 :=
begin
  rw A.eq_id_iff_mono at hA,
  rw [← assoc, ← s.comp_P_infty_eq_zero_iff, assoc, ← P_infty.comm j k, s.ι_summand_eq, assoc,
    degeneracy_comp_P_infty_assoc X j A.e hA, zero_comp, comp_zero],
end

/-- If `s` is a splitting of a simplicial object `X` in a preadditive category,
`s.nondeg_complex` is a chain complex which is given in degree `n` by
the nondegenerate `n`-simplices of `X`. -/
@[simps]
def nondeg_complex : chain_complex C ℕ :=
{ X := s.N,
  d := s.d,
  shape' := λ i j hij, by simp only [d, K[X].shape i j hij, zero_comp, comp_zero],
  d_comp_d' := λ i j k hij hjk, begin
    simp only [d, assoc],
    have eq : K[X].d i j ≫ 𝟙 (X.obj (op [j])) ≫ K[X].d j k ≫
      s.π_summand (index_set.id (op [k])) = 0 :=
      by erw [id_comp, homological_complex.d_comp_d_assoc, zero_comp],
    rw s.decomposition_id at eq,
    classical,
    rw [fintype.sum_eq_add_sum_compl (index_set.id (op [j])), add_comp, comp_add, assoc,
      preadditive.sum_comp, preadditive.comp_sum, finset.sum_eq_zero, add_zero] at eq, swap,
    { intros A hA,
      simp only [finset.mem_compl, finset.mem_singleton] at hA,
      simp only [assoc, ι_summand_comp_d_comp_π_summand_eq_zero _ _ _ _ hA, comp_zero], },
    rw [eq, comp_zero],
  end }

/-- The chain complex `s.nondeg_complex` attached to a splitting of a simplicial object `X`
becomes isomorphic to the normalized Moore complex `N₁.obj X` defined as a formal direct
factor in the category `karoubi (chain_complex C ℕ)`. -/
@[simps]
def to_karoubi_nondeg_complex_iso_N₁ : (to_karoubi _).obj s.nondeg_complex ≅ N₁.obj X :=
{ hom :=
  { f :=
    { f := λ n, s.ι_summand (index_set.id (op [n])) ≫ P_infty.f n,
      comm' := λ i j hij, begin
        dsimp,
        rw [assoc, assoc, assoc, π_summand_comp_ι_summand_comp_P_infty_eq_P_infty,
          homological_complex.hom.comm],
      end, },
    comm := by { ext n, dsimp, rw [id_comp, assoc, P_infty_f_idem], }, },
  inv :=
  { f :=
    { f := λ n, s.π_summand (index_set.id (op [n])),
      comm' := λ i j hij, begin
        dsimp,
        slice_rhs 1 1 { rw ← id_comp (K[X].d i j), },
        erw s.decomposition_id,
        rw [sum_comp, sum_comp, finset.sum_eq_single (index_set.id (op [i])), assoc, assoc],
        { intros A h hA,
          simp only [assoc, s.ι_summand_comp_d_comp_π_summand_eq_zero _ _ _ hA, comp_zero], },
        { simp only [finset.mem_univ, not_true, is_empty.forall_iff], },
      end, },
    comm := by { ext n, dsimp, simp only [comp_id, P_infty_comp_π_summand_id], }, },
  hom_inv_id' := begin
    ext n,
    simpa only [assoc, P_infty_comp_π_summand_id, karoubi.comp_f,
      homological_complex.comp_f, ι_π_summand_eq_id],
  end,
  inv_hom_id' := begin
    ext n,
    simp only [π_summand_comp_ι_summand_comp_P_infty_eq_P_infty, karoubi.comp_f,
      homological_complex.comp_f, N₁_obj_p, karoubi.id_eq],
  end, }

end splitting

namespace split

variables {C : Type*} [category C] [preadditive C] [has_finite_coproducts C]

/-- The functor which sends a split simplicial object in a preadditive category to
the chain complex which consists of nondegenerate simplices. -/
@[simps]
def nondeg_complex_functor : split C ⥤ chain_complex C ℕ :=
{ obj := λ S, S.s.nondeg_complex,
  map := λ S₁ S₂ Φ,
  { f := Φ.f,
    comm' := λ i j hij, begin
      dsimp,
      erw [← ι_summand_naturality_symm_assoc Φ (splitting.index_set.id (op [i])),
        ((alternating_face_map_complex C).map Φ.F).comm_assoc i j],
      simp only [assoc],
      congr' 2,
      apply S₁.s.hom_ext',
      intro A,
      dsimp [alternating_face_map_complex],
      erw ι_summand_naturality_symm_assoc Φ A,
      by_cases A.eq_id,
      { dsimp at h,
        subst h,
        simpa only [splitting.ι_π_summand_eq_id, comp_id, splitting.ι_π_summand_eq_id_assoc], },
      { have h' : splitting.index_set.id (op [j]) ≠ A := by { symmetry, exact h, },
        rw [S₁.s.ι_π_summand_eq_zero_assoc _ _ h', S₂.s.ι_π_summand_eq_zero _ _ h',
          zero_comp, comp_zero], },
    end }, }

/-- The natural isomorphism (in `karoubi (chain_complex C ℕ)`) between the chain complex
of nondegenerate simplices of a split simplicial object and the normalized Moore complex
defined as a formal direct factor of the alternating face map complex. -/
@[simps]
def to_karoubi_nondeg_complex_functor_iso_N₁ :
  nondeg_complex_functor ⋙ to_karoubi (chain_complex C ℕ) ≅ forget C ⋙ dold_kan.N₁ :=
nat_iso.of_components (λ S, S.s.to_karoubi_nondeg_complex_iso_N₁)
  (λ S₁ S₂ Φ, begin
    ext n,
    dsimp,
    simp only [karoubi.comp_f, to_karoubi_map_f, homological_complex.comp_f,
      nondeg_complex_functor_map_f, splitting.to_karoubi_nondeg_complex_iso_N₁_hom_f_f,
      N₁_map_f, alternating_face_map_complex.map_f, assoc, P_infty_f_idem_assoc],
    erw ← split.ι_summand_naturality_symm_assoc Φ (splitting.index_set.id (op [n])),
    rw P_infty_f_naturality,
  end)

--@[simps]
--def nondeg_complex_functor_iso_forget_comp_normalized_Moore_complex {A : Type*} [category A] [abelian A] :
--  nondeg_complex_functor ≅ forget A ⋙ normalized_Moore_complex A :=
--(whiskering_right_to_karoubi_iso_equiv _ _).inv_fun
--  (to_karoubi_N'_iso_N₁
--    ≪≫ iso_whisker_left _ (N₁_iso_normalized_Moore_complex_comp_to_karoubi A))

end split

end simplicial_object


import Lean
import Mathlib.Tactic.RCases

import Verbose.Common

open Lean

open Lean.Parser.Tactic
open Lean Meta

def MaybeTypedIdent := Name × Option Syntax

open Lean Elab Tactic
open Option
open RCases

-- TODO: replace Syntax.missing by something smarter
def RCasesPattOfMaybeTypedIdent : MaybeTypedIdent → RCasesPatt
| (n, some pe) => RCasesPatt.typed Syntax.missing (RCasesPatt.one Syntax.missing  n) pe
| (n, none)    => RCasesPatt.one Syntax.missing n

def obtainTac (fact : Term) (news : Array MaybeTypedIdent) : TacticM Unit :=
do
  let orig_goal ← getMainGoal
  for new in news do
    checkName new.1
  let applied_fact_expr : Expr ← elabTerm fact none
  let news := Array.toList news
  match news with
  | [(name, stuff)] => do
    let type ← inferType applied_fact_expr
    if let some new := stuff then
      if not (← isDefEq (← elabTerm new type) type) then throwError "No way"
    let intermediate_goal ← assert orig_goal name type (← elabTerm fact none)
    let (_, new_goal) ← intro1P intermediate_goal
    replaceMainGoal [new_goal]
  | news =>
    let news_patt := news.map RCasesPattOfMaybeTypedIdent
    let new_goals ← rcases #[(none, fact)] (RCasesPatt.tuple Syntax.missing news_patt) (← getMainGoal)
    replaceMainGoal new_goals

declare_syntax_cat maybeTypedIdent
syntax ident : maybeTypedIdent
syntax "("ident ":" term")" : maybeTypedIdent

-- We could also use the less specific type `Syntax → MaybeTypedIdent`
def toMaybeTypedIdent : TSyntax `maybeTypedIdent → MaybeTypedIdent
| `(maybeTypedIdent| ($x:ident : $type:term)) => (x.getId, type)
| `(maybeTypedIdent| $x:ident) => (x.getId, none)
| _ => (Name.anonymous, none) -- This should never happen

declare_syntax_cat maybeApplied
syntax term : maybeApplied
syntax term "applied to" term : maybeApplied
syntax term "applied to [" term,* "]" : maybeApplied

def maybeAppliedToTerm : TSyntax `maybeApplied → MetaM Term
| `(maybeApplied| $e:term) => pure e
| `(maybeApplied| $e:term applied to $x:term) => `($e $x)
| `(maybeApplied| $e:term applied to [$args:term,*]) => `($e $args*)
| _ => pure ⟨Syntax.missing⟩ -- This should never happen

declare_syntax_cat newStuff
syntax maybeTypedIdent : newStuff
syntax maybeTypedIdent "such that" maybeTypedIdent,* : newStuff

def newStuffToArray : TSyntax `newStuff → Array MaybeTypedIdent
| `(newStuff| $x:maybeTypedIdent) => #[toMaybeTypedIdent x]
| `(newStuff| $x:maybeTypedIdent such that $news:maybeTypedIdent,*) =>
    #[toMaybeTypedIdent x] ++ (Array.map toMaybeTypedIdent news)
| _ => #[]

elab "By " e:maybeApplied "we get " colGt news:newStuff : tactic => do
obtainTac (← maybeAppliedToTerm e)  (newStuffToArray news)

example (P : Nat → Prop) (h : ∀ n, P n) : P 0 := by
  By h applied to 0 we get h₀
  exact h₀

example (P : Nat → Nat → Prop) (h : ∀ n k, P n (k+1)) : P 0 1 := by
  --rcases h 0 0 with (h₀ : P 0 0)
  By h applied to [0, 0] we get (h₀ : P 0 1)
  exact h₀

example (n : Nat) (h : ∃ k, n = 2*k) : True := by
  By h we get k such that (H : n = 2*k)
  trivial

example (n : Nat) (h : ∃ k, n = 2*k) : True := by
  By h we get k such that H
  trivial


import Lean
open Lean.SubExpr

def ps := [#[], #[0], #[1], #[0,1], #[1,0] , #[0,0], #[1,2,3]]
theorem Pos.roundtrip :
  true = ps.all fun x => x == (Pos.toArray <| Pos.ofArray <| x)
  := by native_decide

theorem Pos.append_roundtrip :
  true = (List.all
    (ps.bind fun p => ps.map fun q => (p,q))
    (fun (x,y) => (x ++ y) == (Pos.toArray <| (Pos.append (Pos.ofArray x) (Pos.ofArray y))))
  ) := by native_decide

theorem Pos.stringRoundtrip :
  true = ps.all (fun p =>
    let x := Pos.ofArray p
    some x == (Except.toOption $ Pos.fromString? $ Pos.toString $ x)
  ) := by native_decide

#eval Pos.toString Nat.zero


/-
Copyright (c) 2021 Gabriel Ebner. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Gabriel Ebner
-/
import Lean
import Mathlib.Tactic.Cache
import Mathlib.Tactic.RCases

open Tactic

namespace Mathlib.Tactic.Ext
open Lean Meta

def withExtHyps (struct : Name) (k : Array Expr → (x y : Expr) → Array (Name × Expr) → MetaM α) : MetaM α := do
  unless isStructure (← getEnv) struct do throwError "not a structure: {struct}"
  let structC ← mkConstWithLevelParams struct
  forallTelescope (← inferType structC) fun params _ => do
  withNewBinderInfos (params.map (·.fvarId!, BinderInfo.implicit)) do
  withLocalDeclD `x (mkAppN structC params) fun x => do
  withLocalDeclD `y (mkAppN structC params) fun y => do
    let mut hyps := #[]
    for field in getStructureFieldsFlattened (← getEnv) struct (includeSubobjectFields := false) do
      let x_f ← mkProjection x field
      let y_f ← mkProjection y field
      if ← isProof x_f then
        pure ()
      else if ← isDefEq (← inferType x_f) (← inferType y_f) then
        hyps := hyps.push (field, ← mkEq x_f y_f)
      else
        hyps := hyps.push (field, ← mkHEq x_f y_f)
    k params x y hyps

scoped elab "ext_type%" struct:ident : term => do
  withExtHyps (← resolveGlobalConstNoOverload struct) fun params x y hyps => do
    let mut ty ← mkEq x y
    for (f, h) in hyps.reverse do
      ty := mkForall f BinderInfo.default h ty
    mkForallFVars (params |>.push x |>.push y) ty

def mkIff (p q : Expr) : Expr := mkApp2 (mkConst ``Iff) p q

def mkAndN : List Expr → Expr
  | [] => mkConst ``True
  | [p] => p
  | [p, q] => mkAnd p q
  | p :: ps => mkAnd p (mkAndN ps)

scoped elab "ext_iff_type%" struct:ident : term => do
  withExtHyps (← resolveGlobalConstNoOverload struct) fun params x y hyps => do
    mkForallFVars (params |>.push x |>.push y) <|
      mkIff (← mkEq x y) <| mkAndN (hyps.map (·.2)).toList

elab "subst_eqs" : tactic =>
  open Elab.Tactic in
  liftMetaTactic1 fun mvarId => substEqs mvarId

scoped macro "ext_proof%" : term =>
  `(fun {..} {..} => by intros; subst_eqs; rfl)

syntax "split_ands" : tactic
macro_rules | `(tactic| split_ands) => `(tactic| skip)
macro_rules | `(tactic| split_ands) => `(tactic| refine And.intro ?_ ?_ <;> split_ands)

macro_rules | `(tactic| rfl) => `(tactic| exact HEq.rfl)

scoped macro "ext_iff_proof%" : term => `(fun {..} {..} =>
  ⟨fun _ => by subst_eqs; split_ands <;> rfl,
   fun _ => by (repeat cases ‹_ ∧ _›); subst_eqs; rfl⟩)

scoped macro "declareExtTheoremsFor" struct:ident : command => do
  let extName := mkIdent <| struct.getId.eraseMacroScopes.mkStr "ext"
  let extIffName := mkIdent <| struct.getId.eraseMacroScopes.mkStr "ext_iff"
  `(@[ext] protected theorem $extName:ident : ext_type% $struct:ident := ext_proof%
    protected theorem $extIffName:ident : ext_iff_type% $struct:ident := ext_iff_proof%)

open Elab.Command MonadRecDepth in
def liftCommandElabM (k : CommandElabM α) : AttrM α := do
  let (a, commandState) ←
    k.run { fileName := (← getEnv).mainModule.toString, fileMap := default } |>.run {
      env := ← getEnv, maxRecDepth := ← getMaxRecDepth,
      scopes := [{ header := "", opts := ← getOptions }]
    }
  modify fun coreState => { coreState with
    traceState.traces := coreState.traceState.traces ++ commandState.traceState.traces
    env := commandState.env
  }
  if let some err := commandState.messages.msgs.toArray.find?
      (·.severity matches MessageSeverity.error) then
    throwError err.data
  pure a

initialize extExtension : SimpleScopedEnvExtension (Name × Array DiscrTree.Key) (DiscrTree Name) ←
  registerSimpleScopedEnvExtension {
    name := `ext
    addEntry := fun dt (n, ks) => dt.insertCore ks n
    initial := {}
  }

def extAttribute : AttributeImpl where
  name := `ext
  descr := "Marks a lemma as extensionality lemma"
  add decl stx kind := do
    if isStructure (← getEnv) decl then
      liftCommandElabM do
        Elab.Command.elabCommand <|<- `(declareExtTheoremsFor $(mkIdent decl))
    else MetaM.run' do
      let declTy := (← getConstInfo decl).type
      let (xs, bis, declTy) ← withReducible <| forallMetaTelescopeReducing declTy
      if declTy.isAppOfArity ``Eq 3 && (declTy.getArg! 1).isMVar && (declTy.getArg! 2).isMVar then
        let ty := declTy.getArg! 0
        let key ←
          if (← withReducible <| whnf ty).isForall then
            pure #[DiscrTree.Key.star] -- FIXME: workaround
          else
            withReducible <| DiscrTree.mkPath ty
        extExtension.add (decl, key) kind
      else
        throwError "@[ext] attribute only applies to structures or lemmas proving x = y, got {declTy}"

initialize registerBuiltinAttribute extAttribute

def extLemmas (env : Environment) : DiscrTree Name :=
  extExtension.getState env

open Lean.Elab.Tactic in
elab "apply_ext_lemma" : tactic => do
  let tgt ← getMainTarget
  unless tgt.isAppOfArity ``Eq 3 do
    throwError "applyExtLemma only applies to equations, not{indentExpr tgt}"
  let ty := tgt.getArg! 0
  let s ← saveState
  for lem in ← (extLemmas (← getEnv)).getMatch ty do
    try
      liftMetaTactic (apply · (← mkConstWithFreshMVarLevels lem))
      return
    catch e =>
      s.restore
  throwError "no applicable extensionality lemma found for{indentExpr ty}"

scoped syntax "ext_or_skip" (ppSpace rintroPat)* : tactic
macro_rules | `(tactic| ext_or_skip) => `(tactic| skip)
macro_rules
| `(tactic| ext_or_skip $xs:rintroPat*) =>
  `(tactic| apply_ext_lemma; ext_or_skip $xs:rintroPat*)
macro_rules
| `(tactic| ext_or_skip $x:rintroPat $xs:rintroPat*) =>
  `(tactic| rintro $x:rintroPat; ext_or_skip $xs:rintroPat*)

-- TODO: support `ext : n`

syntax "ext" (colGt ppSpace rintroPat)* (" : " num)? : tactic
macro_rules
| `(tactic| ext) => do
  `(tactic| first | intro; ext | apply_ext_lemma; ext | skip)
macro_rules
| `(tactic| ext $xs:rintroPat*) =>
  `(tactic| apply_ext_lemma; ext_or_skip $xs:rintroPat*)

syntax "ext1" (colGt ppSpace rintroPat)* : tactic
macro_rules
| `(tactic| ext1 $xs:rintroPat*) =>
  `(tactic| apply_ext_lemma; rintro $xs:rintroPat*)

-- TODO
syntax "ext1?" (colGt ppSpace rintroPat)* : tactic
syntax "ext?" (colGt ppSpace rintroPat)* (" : " num)? : tactic


import temporal_logic.basic
import tactic.squeeze

universe variables u u₀ u₁ u₂

variables {α : Sort u₀} {β : Sort u₁} {γ : Sort u₂}

namespace temporal
open predicate

class postponable (p : cpred) : Prop :=
  (postpone : ◇p = p)
export postponable (postpone)

instance henceforth_persistent {p : cpred} : persistent (◻p) :=
by { constructor, simp only [temporal.henceforth_henceforth, eq_self_iff_true] with tl_simp }

instance persistent_not {p : cpred} [postponable p] : persistent (-p) :=
by { constructor, rw [← not_eventually, postpone p] }

instance leads_to_persistent {p q : cpred} : persistent (p ~> q) :=
by { constructor, simp only [tl_leads_to, is_persistent, eq_self_iff_true] }

instance and_persistent {p q : cpred} [persistent p] [persistent q]
: persistent (p ⋀ q) :=
by { constructor, simp only [henceforth_and, is_persistent, eq_self_iff_true], }

instance coe_persistent (p : Prop)
: persistent (p : cpred) :=
by { constructor, cases classical.prop_complete p ; subst p ;
     simp only [eq_self_iff_true, temporal.hence_false, predicate.coe_false,predicate.coe_true, eq_self_iff_true, temporal.hence_true] with tl_simp, }

instance false_persistent
: persistent (False : cpred) :=
by { constructor, simp only [eq_self_iff_true, temporal.hence_false] with tl_simp, }

instance forall_persistent {p : α → cpred} [∀ i, persistent (p i)]
: persistent (p_forall p) :=
by { constructor, simp only [henceforth_forall, is_persistent, eq_self_iff_true], }

instance exists_persistent {p : α → cpred} [∀ i, persistent (p i)]
: persistent (p_exists p) :=
by { constructor, apply mutual_entails,
     apply henceforth_str,
     apply p_exists_elim, intro, rw ← is_persistent (p x),
     mono, apply p_exists_intro, }

instance (p : cpred) : postponable (◇p) :=
by { constructor, simp only [eventually_eventually, temporal.eventually_eventually, eq_self_iff_true] }

instance postponable_not {p : cpred} [persistent p] : postponable (-p) :=
by { constructor, rw [← not_henceforth, is_persistent p] }

instance or_postponable {p q : cpred} [postponable p] [postponable q]
: postponable (p ⋁ q) :=
by { constructor, simp only [eventually_or, postpone, eq_self_iff_true], }

instance imp_postponable {p q : cpred} [persistent p] [postponable q]
: postponable (p ⟶ q) :=
by { simp only [p_imp_iff_p_not_p_or], apply_instance }

instance coe_postponable (p : Prop)
: postponable (p : cpred) :=
by { constructor, cases classical.prop_complete p ; subst p ; simp only [temporal.event_false, eq_self_iff_true, predicate.coe_false, predicate.coe_true, temporal.eventually_true, eq_self_iff_true] with tl_simp, }

instance forall_postponable (p : α → cpred) [∀ i, postponable (p i)]
: postponable (p_forall p) :=
⟨ begin
    apply mutual_entails,
    { rw [p_entails_of_fun],
      introv h, rw p_forall_to_fun, intro i,
      rw ← postpone (p i), revert h, apply p_impl_revert,
      revert Γ, change (_ ⟹ _),
      mono, rw [p_entails_of_fun],
      introv h, apply p_forall_revert h },
    apply eventually_weaken
  end ⟩

instance exists_postponable (p : α → cpred) [∀ i, postponable (p i)]
: postponable (p_exists p) :=
by constructor ; simp only [eventually_exists, postpone, eq_self_iff_true]

instance lifted₀_postponable (c : Prop) : postponable (lifted₀ c) :=
by { constructor, ext, simp only [lifted₀, eventually, iff_self, predicate.lifted₀, exists_const] }

instance lifted₀_persistent (c : Prop) : persistent (lifted₀ c) :=
by { constructor, ext, simp only [lifted₀, henceforth, forall_const, iff_self, predicate.lifted₀] }

instance True_postponable : postponable True :=
by { dunfold True, apply_instance }

instance True_persistent : persistent True :=
by { dunfold True, apply_instance }

instance False_postponable : postponable False :=
by { dunfold False, apply_instance }

instance False_persistent : persistent False :=
by { dunfold False, apply_instance }

-- instance not_forall_persistent {p : α → cpred} [∀ i, persistent (- p i)]
-- : persistent (- p_forall p) :=
-- by { constructor, squeeze_simp [p_not_p_forall], apply is_persistent }

inductive list_persistent : list cpred → Prop
 | nil_persistent : list_persistent []
 | cons_persistent (x : cpred) (xs : list $ cpred)
   [persistent x]
   (h : list_persistent xs)
 : list_persistent (x :: xs)

export list_persistent (nil_persistent)

def with_h_asms (Γ : cpred) : Π (xs : list (cpred)) (x : cpred), Prop
 | [] x := Γ ⊢ x
 | (x :: xs) y := Γ ⊢ x → with_h_asms xs y

lemma indirect_judgement (h p : pred' β)
  (H : ∀ Γ, Γ ⊢ h → Γ ⊢ p)
: h ⊢ p :=
by { apply H, lifted_pred keep, assumption }

lemma judgement_trans (p q r : pred' β)
  (h₀ : p ⊢ q)
  (h₁ : q ⊢ r)
: p ⊢ r :=
by { lifted_pred keep,
     apply h₁.apply,
     apply h₀.apply _ a }

@[trans]
lemma judgement_trans' {p q r : pred' β}
  (h₀ : p ⊢ q)
  (h₁ : q ⊢ r)
: p ⊢ r :=
judgement_trans _ _ _ h₀ h₁

lemma p_imp_postpone (Γ p q : cpred)
  [persistent Γ]
  [postponable q]
  (h : ctx_impl Γ p q)
: ctx_impl Γ (◇p) q :=
begin
  rw ← postpone q,
  mono,
end

lemma persistent_to_henceforth {p q : cpred}
  [persistent p]
  (h : p ⊢ q)
: p ⊢ ◻ q :=
by { rw ← is_persistent p,
     lifted_pred keep, intro i,
     apply h.apply _ (a i), }

lemma henceforth_deduction {Γ p q : cpred}
  (h : Γ ⊢ ◻(p ⟶ q))
: Γ ⊢ p → Γ ⊢ q :=
henceforth_str (p ⟶ q) Γ h

instance has_coe_to_fun_henceforth (Γ p q : cpred) : has_coe_to_fun (Γ ⊢ ◻(p ⟶ q)) :=
{ F := λ _, Γ ⊢ p → Γ ⊢ q
, coe :=  henceforth_deduction }

instance has_coe_to_fun_leads_to (Γ p q : cpred) : has_coe_to_fun (Γ ⊢ p ~> q) :=
temporal.has_coe_to_fun_henceforth _ _ _

end temporal


import M.Pluto.Language.Constant
import M.PlutusCore

namespace Pluto.Proof

open Pluto.Language
open PlutusCore (ByteString Data)

theorem show_constant_integer (i : Int) : toString (I ann i) = toString i :=
  rfl

theorem show_constant_bytestring (s : ByteString) : toString (S ann s) = "0x" ++ toString s :=
  rfl

theorem show_constant_text (t : String) : toString (T ann t) = "\"" ++ toString t ++ "\"" :=
  rfl

theorem show_constant_unit : toString (U ann ) = "()" :=
  rfl

theorem show_constant_true : toString (B ann true) = "True" :=
  rfl

theorem show_constant_false : toString (B ann false) = "False" :=
  rfl

theorem show_constant_data_integer : toString (D ann (Data.I i)) = "data " ++ toString i :=
  by simp [toString, showData]

theorem show_constant_data_bytestring : toString (D ann (Data.B b)) = "data " ++ ("0x" ++ toString b) :=
  by simp [toString, showData]

example : toString (I () 3                                           ) = "3"        := rfl

example : toString (S () $ ByteString.mk $ ByteArray.mk #[0xca, 0xfe]) = "0xcafe"   := rfl

example : toString (T () "test"                                      ) = "\"test\"" := rfl

example : toString (U ()                                             ) = "()"       := rfl

example : toString (B () true                                        ) = "True"     := rfl

example : toString (B () false                                       ) = "False"    := rfl

private def testData :=
  Data.List
    [
      Data.Map []
    , Data.Map [
        (Data.I 3, Data.List [])
      ]
    , Data.Map [
        (Data.B $ ByteString.mk $ ByteArray.mk #[0xca, 0xfe], Data.List [Data.I 2])
      ]
    , Data.Map [
        (Data.I 10, Data.I 20)
      , (Data.I 30, Data.I 40)
    ]
    , Data.Constr 2 [Data.I 9, Data.I (-10)]
    , Data.Constr 1 [Data.I (-11)]
    , Data.Constr 0 []
    ]

example : toString (D () testData) = "data [{},{3=[]},{0xcafe=[2]},{10=20,30=40},sigma2.[9,-10],sigma1.[-11],sigma0.[]]" :=
  by simp [toString, testData, showData, intercalateData, intercalateData']

end Pluto.Proof


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