/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl
-/

import algebra.group.pi
import algebra.ring.opposite
import data.equiv.mul_add
import data.finset.fold
import data.fintype.basic
import data.set.pairwise

/-!
# Big operators

In this file we define products and sums indexed by finite sets (specifically, `finset`).

## Notation

We introduce the following notation, localized in `big_operators`.
To enable the notation, use `open_locale big_operators`.

Let `s` be a `finset α`, and `f : α → β` a function.

* `∏ x in s, f x` is notation for `finset.prod s f` (assuming `β` is a `comm_monoid`)
* `∑ x in s, f x` is notation for `finset.sum s f` (assuming `β` is an `add_comm_monoid`)
* `∏ x, f x` is notation for `finset.prod finset.univ f`
  (assuming `α` is a `fintype` and `β` is a `comm_monoid`)
* `∑ x, f x` is notation for `finset.sum finset.univ f`
  (assuming `α` is a `fintype` and `β` is an `add_comm_monoid`)

## Implementation Notes

The first arguments in all definitions and lemmas is the codomain of the function of the big
operator. This is necessary for the heuristic in `@[to_additive]`.
See the documentation of `to_additive.attr` for more information.

-/

universes u v w
variables {β : Type u} {α : Type v} {γ : Type w}

namespace finset

/--
`∏ x in s, f x` is the product of `f x`
as `x` ranges over the elements of the finite set `s`.
-/
@[to_additive "`∑ x in s, f x` is the sum of `f x` as `x` ranges over the elements
of the finite set `s`."]
protected def prod [comm_monoid β] (s : finset α) (f : α → β) : β := (s.1.map f).prod

@[simp, to_additive] lemma prod_mk [comm_monoid β] (s : multiset α) (hs : s.nodup) (f : α → β) :
  (⟨s, hs⟩ : finset α).prod f = (s.map f).prod :=
rfl

end finset

/--
There is no established mathematical convention
for the operator precedence of big operators like `∏` and `∑`.
We will have to make a choice.

Online discussions, such as https://math.stackexchange.com/q/185538/30839
seem to suggest that `∏` and `∑` should have the same precedence,
and that this should be somewhere between `*` and `+`.
The latter have precedence levels `70` and `65` respectively,
and we therefore choose the level `67`.

In practice, this means that parentheses should be placed as follows:
```lean
∑ k in K, (a k + b k) = ∑ k in K, a k + ∑ k in K, b k →
  ∏ k in K, a k * b k = (∏ k in K, a k) * (∏ k in K, b k)
```
(Example taken from page 490 of Knuth's *Concrete Mathematics*.)
-/
library_note "operator precedence of big operators"

localized "notation `∑` binders `, ` r:(scoped:67 f, finset.sum finset.univ f) := r"
  in big_operators
localized "notation `∏` binders `, ` r:(scoped:67 f, finset.prod finset.univ f) := r"
  in big_operators

localized "notation `∑` binders ` in ` s `, ` r:(scoped:67 f, finset.sum s f) := r"
  in big_operators
localized "notation `∏` binders ` in ` s `, ` r:(scoped:67 f, finset.prod s f) := r"
  in big_operators

open_locale big_operators

namespace finset
variables {s s₁ s₂ : finset α} {a : α} {f g : α → β}

@[to_additive] lemma prod_eq_multiset_prod [comm_monoid β] (s : finset α) (f : α → β) :
  ∏ x in s, f x = (s.1.map f).prod := rfl

@[to_additive]
theorem prod_eq_fold [comm_monoid β] (s : finset α) (f : α → β) :
  ∏ x in s, f x = s.fold (*) 1 f :=
rfl

@[simp] lemma sum_multiset_singleton (s : finset α) :
  s.sum (λ x, {x}) = s.val :=
by simp only [sum_eq_multiset_sum, multiset.sum_map_singleton]

end finset

@[to_additive]
lemma monoid_hom.map_prod [comm_monoid β] [comm_monoid γ] (g : β →* γ) (f : α → β) (s : finset α) :
  g (∏ x in s, f x) = ∏ x in s, g (f x) :=
by simp only [finset.prod_eq_multiset_prod, g.map_multiset_prod, multiset.map_map]

@[to_additive]
lemma mul_equiv.map_prod [comm_monoid β] [comm_monoid γ] (g : β ≃* γ) (f : α → β) (s : finset α) :
  g (∏ x in s, f x) = ∏ x in s, g (f x) :=
g.to_monoid_hom.map_prod f s

lemma ring_hom.map_list_prod [semiring β] [semiring γ] (f : β →+* γ) (l : list β) :
  f l.prod = (l.map f).prod :=
f.to_monoid_hom.map_list_prod l

lemma ring_hom.map_list_sum [non_assoc_semiring β] [non_assoc_semiring γ]
  (f : β →+* γ) (l : list β) :
  f l.sum = (l.map f).sum :=
f.to_add_monoid_hom.map_list_sum l

/-- A morphism into the opposite ring acts on the product by acting on the reversed elements -/
lemma ring_hom.unop_map_list_prod [semiring β] [semiring γ] (f : β →+* γᵐᵒᵖ) (l : list β) :
  mul_opposite.unop (f l.prod) = (l.map (mul_opposite.unop ∘ f)).reverse.prod :=
f.to_monoid_hom.unop_map_list_prod l

lemma ring_hom.map_multiset_prod [comm_semiring β] [comm_semiring γ] (f : β →+* γ)
  (s : multiset β) :
  f s.prod = (s.map f).prod :=
f.to_monoid_hom.map_multiset_prod s

lemma ring_hom.map_multiset_sum [non_assoc_semiring β] [non_assoc_semiring γ]
  (f : β →+* γ) (s : multiset β) :
  f s.sum = (s.map f).sum :=
f.to_add_monoid_hom.map_multiset_sum s

lemma ring_hom.map_prod [comm_semiring β] [comm_semiring γ] (g : β →+* γ) (f : α → β)
  (s : finset α) :
  g (∏ x in s, f x) = ∏ x in s, g (f x) :=
g.to_monoid_hom.map_prod f s

lemma ring_hom.map_sum [non_assoc_semiring β] [non_assoc_semiring γ]
  (g : β →+* γ) (f : α → β) (s : finset α) :
  g (∑ x in s, f x) = ∑ x in s, g (f x) :=
g.to_add_monoid_hom.map_sum f s

@[to_additive]
lemma monoid_hom.coe_prod [mul_one_class β] [comm_monoid γ] (f : α → β →* γ) (s : finset α) :
  ⇑(∏ x in s, f x) = ∏ x in s, f x :=
(monoid_hom.coe_fn β γ).map_prod _ _

-- See also `finset.prod_apply`, with the same conclusion
-- but with the weaker hypothesis `f : α → β → γ`.
@[simp, to_additive]
lemma monoid_hom.finset_prod_apply [mul_one_class β] [comm_monoid γ] (f : α → β →* γ)
  (s : finset α) (b : β) : (∏ x in s, f x) b = ∏ x in s, f x b :=
(monoid_hom.eval b).map_prod _ _

variables {s s₁ s₂ : finset α} {a : α} {f g : α → β}

namespace finset

section comm_monoid
variables [comm_monoid β]

@[simp, to_additive]
lemma prod_empty {f : α → β} : (∏ x in (∅:finset α), f x) = 1 := rfl

@[simp, to_additive]
lemma prod_cons (h : a ∉ s) : (∏ x in (cons a s h), f x) = f a * ∏ x in s, f x :=
fold_cons h

@[simp, to_additive]
lemma prod_insert [decidable_eq α] : a ∉ s → (∏ x in (insert a s), f x) = f a * ∏ x in s, f x :=
fold_insert

/--
The product of `f` over `insert a s` is the same as
the product over `s`, as long as `a` is in `s` or `f a = 1`.
-/
@[simp, to_additive "The sum of `f` over `insert a s` is the same as
the sum over `s`, as long as `a` is in `s` or `f a = 0`."]
lemma prod_insert_of_eq_one_if_not_mem [decidable_eq α] (h : a ∉ s → f a = 1) :
  ∏ x in insert a s, f x = ∏ x in s, f x :=
begin
  by_cases hm : a ∈ s,
  { simp_rw insert_eq_of_mem hm },
  { rw [prod_insert hm, h hm, one_mul] },
end

/--
The product of `f` over `insert a s` is the same as the product over `s`, as long as `f a = 1`.
-/
@[simp, to_additive "The sum of `f` over `insert a s` is the same as
the sum over `s`, as long as `f a = 0`."]
lemma prod_insert_one [decidable_eq α] (h : f a = 1) :
  ∏ x in insert a s, f x = ∏ x in s, f x :=
prod_insert_of_eq_one_if_not_mem (λ _, h)

@[simp, to_additive]
lemma prod_singleton : (∏ x in (singleton a), f x) = f a :=
eq.trans fold_singleton $ mul_one _

@[to_additive]
lemma prod_pair [decidable_eq α] {a b : α} (h : a ≠ b) :
  (∏ x in ({a, b} : finset α), f x) = f a * f b :=
by rw [prod_insert (not_mem_singleton.2 h), prod_singleton]

@[simp, priority 1100, to_additive]
lemma prod_const_one : (∏ x in s, (1 : β)) = 1 :=
by simp only [finset.prod, multiset.map_const, multiset.prod_repeat, one_pow]

@[simp, to_additive]
lemma prod_image [decidable_eq α] {s : finset γ} {g : γ → α} :
  (∀ x ∈ s, ∀ y ∈ s, g x = g y → x = y) → (∏ x in (s.image g), f x) = ∏ x in s, f (g x) :=
fold_image

@[simp, to_additive]
lemma prod_map (s : finset α) (e : α ↪ γ) (f : γ → β) :
  (∏ x in (s.map e), f x) = ∏ x in s, f (e x) :=
by rw [finset.prod, finset.map_val, multiset.map_map]; refl

@[congr, to_additive]
lemma prod_congr (h : s₁ = s₂) : (∀ x ∈ s₂, f x = g x) → s₁.prod f = s₂.prod g :=
by rw [h]; exact fold_congr
attribute [congr] finset.sum_congr

@[to_additive]
lemma prod_union_inter [decidable_eq α] :
  (∏ x in (s₁ ∪ s₂), f x) * (∏ x in (s₁ ∩ s₂), f x) = (∏ x in s₁, f x) * (∏ x in s₂, f x) :=
fold_union_inter

@[to_additive]
lemma prod_union [decidable_eq α] (h : disjoint s₁ s₂) :
  (∏ x in (s₁ ∪ s₂), f x) = (∏ x in s₁, f x) * (∏ x in s₂, f x) :=
by rw [←prod_union_inter, (disjoint_iff_inter_eq_empty.mp h)]; exact (mul_one _).symm

@[to_additive]
lemma prod_filter_mul_prod_filter_not (s : finset α) (p : α → Prop) [decidable_pred p]
  [decidable_pred (λ x, ¬p x)] (f : α → β) :
  (∏ x in s.filter p, f x) * (∏ x in s.filter (λ x, ¬p x), f x) = ∏ x in s, f x :=
begin
  haveI := classical.dec_eq α,
  rw [← prod_union (filter_inter_filter_neg_eq p s).le, filter_union_filter_neg_eq]
end

end comm_monoid

end finset

section
open finset
variables [fintype α] [decidable_eq α] [comm_monoid β]

@[to_additive]
lemma is_compl.prod_mul_prod {s t : finset α} (h : is_compl s t) (f : α → β) :
  (∏ i in s, f i) * (∏ i in t, f i) = ∏ i, f i :=
(finset.prod_union h.disjoint).symm.trans $ by rw [← finset.sup_eq_union, h.sup_eq_top]; refl

end

namespace finset

section comm_monoid
variables [comm_monoid β]

/-- Multiplying the products of a function over `s` and over `sᶜ` gives the whole product.
For a version expressed with subtypes, see `fintype.prod_subtype_mul_prod_subtype`. -/
@[to_additive "Adding the sums of a function over `s` and over `sᶜ` gives the whole sum.
For a version expressed with subtypes, see `fintype.sum_subtype_add_sum_subtype`. "]
lemma prod_mul_prod_compl [fintype α] [decidable_eq α] (s : finset α) (f : α → β) :
  (∏ i in s, f i) * (∏ i in sᶜ, f i) = ∏ i, f i :=
is_compl.prod_mul_prod is_compl_compl f

@[to_additive]
lemma prod_compl_mul_prod [fintype α] [decidable_eq α] (s : finset α) (f : α → β) :
  (∏ i in sᶜ, f i) * (∏ i in s, f i) = ∏ i, f i :=
(@is_compl_compl _ s _).symm.prod_mul_prod f

@[to_additive]
lemma prod_sdiff [decidable_eq α] (h : s₁ ⊆ s₂) :
  (∏ x in (s₂ \ s₁), f x) * (∏ x in s₁, f x) = (∏ x in s₂, f x) :=
by rw [←prod_union sdiff_disjoint, sdiff_union_of_subset h]

@[simp, to_additive]
lemma prod_sum_elim [decidable_eq (α ⊕ γ)]
  (s : finset α) (t : finset γ) (f : α → β) (g : γ → β) :
  ∏ x in s.map function.embedding.inl ∪ t.map function.embedding.inr, sum.elim f g x =
    (∏ x in s, f x) * (∏ x in t, g x) :=
begin
  rw [prod_union, prod_map, prod_map],
  { simp only [sum.elim_inl, function.embedding.inl_apply, function.embedding.inr_apply,
      sum.elim_inr] },
  { simp only [disjoint_left, finset.mem_map, finset.mem_map],
    rintros _ ⟨i, hi, rfl⟩ ⟨j, hj, H⟩,
    cases H }
end

@[to_additive]
lemma prod_bUnion [decidable_eq α] {s : finset γ} {t : γ → finset α}
  (hs : set.pairwise_disjoint ↑s t) :
  (∏ x in (s.bUnion t), f x) = ∏ x in s, ∏ i in t x, f i :=
begin
  haveI := classical.dec_eq γ,
  induction s using finset.induction_on with x s hxs ih hd,
  { simp_rw [bUnion_empty, prod_empty] },
  { simp_rw [coe_insert, set.pairwise_disjoint_insert, mem_coe] at hs,
    have : disjoint (t x) (finset.bUnion s t),
    { exact (disjoint_bUnion_right _ _ _).mpr (λ y hy, hs.2 y hy $ λ H, hxs $ H.substr hy) },
    rw [bUnion_insert, prod_insert hxs, prod_union this, ih hs.1] }
end

@[to_additive]
lemma prod_product {s : finset γ} {t : finset α} {f : γ×α → β} :
  (∏ x in s.product t, f x) = ∏ x in s, ∏ y in t, f (x, y) :=
begin
  haveI := classical.dec_eq α, haveI := classical.dec_eq γ,
  rw [product_eq_bUnion, prod_bUnion],
  { congr, funext, exact prod_image (λ _ _ _ _ H, (prod.mk.inj H).2) },
  simp only [disjoint_iff_ne, mem_image],
  rintro x _ y _ h ⟨i, z⟩ hz,
  rw [inf_eq_inter, mem_inter, mem_image, mem_image] at hz,
  obtain ⟨⟨_, _, rfl, _⟩, _, _, rfl, _⟩ := hz,
  exact h rfl,
end

/-- An uncurried version of `finset.prod_product`. -/
@[to_additive "An uncurried version of `finset.sum_product`"]
lemma prod_product' {s : finset γ} {t : finset α} {f : γ → α → β} :
  (∏ x in s.product t, f x.1 x.2) = ∏ x in s, ∏ y in t, f x y :=
prod_product

/-- Product over a sigma type equals the product of fiberwise products. For rewriting
in the reverse direction, use `finset.prod_sigma'`.  -/
@[to_additive "Sum over a sigma type equals the sum of fiberwise sums. For rewriting
in the reverse direction, use `finset.sum_sigma'`"]
lemma prod_sigma {σ : α → Type*}
  (s : finset α) (t : Π a, finset (σ a)) (f : sigma σ → β) :
  (∏ x in s.sigma t, f x) = ∏ a in s, ∏ s in (t a), f ⟨a, s⟩ :=
by classical;
calc (∏ x in s.sigma t, f x) =
       ∏ x in s.bUnion (λ a, (t a).map (function.embedding.sigma_mk a)), f x : by rw sigma_eq_bUnion
  ... = ∏ a in s, ∏ x in (t a).map (function.embedding.sigma_mk a), f x :
    prod_bUnion $ assume a₁ ha a₂ ha₂ h x hx,
    by { simp only [inf_eq_inter, mem_inter, mem_map, function.embedding.sigma_mk_apply] at hx,
      rcases hx with ⟨⟨y, hy, rfl⟩, ⟨z, hz, hz'⟩⟩, cc }
  ... = ∏ a in s, ∏ s in t a, f ⟨a, s⟩ :
    prod_congr rfl $ λ _ _, prod_map _ _ _

@[to_additive]
lemma prod_sigma' {σ : α → Type*}
  (s : finset α) (t : Π a, finset (σ a)) (f : Π a, σ a → β) :
  (∏ a in s, ∏ s in (t a), f a s) = ∏ x in s.sigma t, f x.1 x.2 :=
eq.symm $ prod_sigma s t (λ x, f x.1 x.2)

@[to_additive]
lemma prod_fiberwise_of_maps_to [decidable_eq γ] {s : finset α} {t : finset γ} {g : α → γ}
  (h : ∀ x ∈ s, g x ∈ t) (f : α → β) :
  (∏ y in t, ∏ x in s.filter (λ x, g x = y), f x) = ∏ x in s, f x :=
begin
  letI := classical.dec_eq α,
  rw [← bUnion_filter_eq_of_maps_to h] {occs := occurrences.pos [2]},
  refine (prod_bUnion $ λ x' hx y' hy hne, _).symm,
  rw [function.on_fun, disjoint_filter],
  rintros x hx rfl,
  exact hne
end

@[to_additive]
lemma prod_image' [decidable_eq α] {s : finset γ} {g : γ → α} (h : γ → β)
  (eq : ∀ c ∈ s, f (g c) = ∏ x in s.filter (λ c', g c' = g c), h x) :
  (∏ x in s.image g, f x) = ∏ x in s, h x :=
calc (∏ x in s.image g, f x) = ∏ x in s.image g, ∏ x in s.filter (λ c', g c' = x), h x :
  prod_congr rfl $ λ x hx, let ⟨c, hcs, hc⟩ := mem_image.1 hx in hc ▸ (eq c hcs)
... = ∏ x in s, h x : prod_fiberwise_of_maps_to (λ x, mem_image_of_mem g) _

@[to_additive]
lemma prod_mul_distrib : ∏ x in s, (f x * g x) = (∏ x in s, f x) * (∏ x in s, g x) :=
eq.trans (by rw one_mul; refl) fold_op_distrib

@[to_additive]
lemma prod_comm {s : finset γ} {t : finset α} {f : γ → α → β} :
  (∏ x in s, ∏ y in t, f x y) = (∏ y in t, ∏ x in s, f x y) :=
begin
  classical,
  apply finset.induction_on s,
  { simp only [prod_empty, prod_const_one] },
  { intros _ _ H ih,
    simp only [prod_insert H, prod_mul_distrib, ih] }
end

@[to_additive]
lemma prod_product_right {s : finset γ} {t : finset α} {f : γ×α → β} :
  (∏ x in s.product t, f x) = ∏ y in t, ∏ x in s, f (x, y) :=
by rw [prod_product, prod_comm]

/-- An uncurried version of `finset.prod_product_right`. -/
@[to_additive "An uncurried version of `finset.prod_product_right`"]
lemma prod_product_right' {s : finset γ} {t : finset α} {f : γ → α → β} :
  (∏ x in s.product t, f x.1 x.2) = ∏ y in t, ∏ x in s, f x y :=
prod_product_right

@[to_additive]
lemma prod_hom_rel [comm_monoid γ] {r : β → γ → Prop} {f : α → β} {g : α → γ} {s : finset α}
  (h₁ : r 1 1) (h₂ : ∀ a b c, r b c → r (f a * b) (g a * c)) : r (∏ x in s, f x) (∏ x in s, g x) :=
by { delta finset.prod, apply multiset.prod_hom_rel; assumption }

@[to_additive]
lemma prod_eq_one {f : α → β} {s : finset α} (h : ∀ x ∈ s, f x = 1) : (∏ x in s, f x) = 1 :=
calc (∏ x in s, f x) = ∏ x in s, 1 : finset.prod_congr rfl h
  ... = 1 : finset.prod_const_one

@[to_additive]
lemma prod_subset_one_on_sdiff [decidable_eq α] (h : s₁ ⊆ s₂) (hg : ∀ x ∈ (s₂ \ s₁), g x = 1)
  (hfg : ∀ x ∈ s₁, f x = g x) : ∏ i in s₁, f i = ∏ i in s₂, g i :=
begin
  rw [← prod_sdiff h, prod_eq_one hg, one_mul],
  exact prod_congr rfl hfg
end

@[to_additive]
lemma prod_subset (h : s₁ ⊆ s₂) (hf : ∀ x ∈ s₂, x ∉ s₁ → f x = 1) :
  (∏ x in s₁, f x) = ∏ x in s₂, f x :=
by haveI := classical.dec_eq α; exact prod_subset_one_on_sdiff h (by simpa) (λ _ _, rfl)

@[to_additive]
lemma prod_filter_of_ne {p : α → Prop} [decidable_pred p] (hp : ∀ x ∈ s, f x ≠ 1 → p x) :
  (∏ x in (s.filter p), f x) = (∏ x in s, f x) :=
prod_subset (filter_subset _ _) $ λ x,
  by { classical, rw [not_imp_comm, mem_filter], exact λ h₁ h₂, ⟨h₁, hp _ h₁ h₂⟩ }

-- If we use `[decidable_eq β]` here, some rewrites fail because they find a wrong `decidable`
-- instance first; `{∀ x, decidable (f x ≠ 1)}` doesn't work with `rw ← prod_filter_ne_one`
@[to_additive]
lemma prod_filter_ne_one [∀ x, decidable (f x ≠ 1)] :
  (∏ x in (s.filter $ λ x, f x ≠ 1), f x) = (∏ x in s, f x) :=
prod_filter_of_ne $ λ _ _, id

@[to_additive]
lemma prod_filter (p : α → Prop) [decidable_pred p] (f : α → β) :
  (∏ a in s.filter p, f a) = (∏ a in s, if p a then f a else 1) :=
calc (∏ a in s.filter p, f a) = ∏ a in s.filter p, if p a then f a else 1 :
    prod_congr rfl (assume a h, by rw [if_pos (mem_filter.1 h).2])
  ... = ∏ a in s, if p a then f a else 1 :
    begin
      refine prod_subset (filter_subset _ s) (assume x hs h, _),
      rw [mem_filter, not_and] at h,
      exact if_neg (h hs)
    end

@[to_additive]
lemma prod_eq_single_of_mem {s : finset α} {f : α → β} (a : α) (h : a ∈ s)
  (h₀ : ∀ b ∈ s, b ≠ a → f b = 1) : (∏ x in s, f x) = f a :=
begin
  haveI := classical.dec_eq α,
  calc (∏ x in s, f x) = ∏ x in {a}, f x :
      begin
        refine (prod_subset _ _).symm,
        { intros _ H, rwa mem_singleton.1 H },
        { simpa only [mem_singleton] }
      end
      ... = f a : prod_singleton
end

@[to_additive]
lemma prod_eq_single {s : finset α} {f : α → β} (a : α)
  (h₀ : ∀ b ∈ s, b ≠ a → f b = 1) (h₁ : a ∉ s → f a = 1) : (∏ x in s, f x) = f a :=
by haveI := classical.dec_eq α;
from classical.by_cases
  (assume : a ∈ s, prod_eq_single_of_mem a this h₀)
  (assume : a ∉ s,
    (prod_congr rfl $ λ b hb, h₀ b hb $ by rintro rfl; cc).trans $
      prod_const_one.trans (h₁ this).symm)

@[to_additive]

@[to_additive]
lemma prod_eq_mul {s : finset α} {f : α → β} (a b : α) (hn : a ≠ b)
  (h₀ : ∀ c ∈ s, c ≠ a ∧ c ≠ b → f c = 1) (ha : a ∉ s → f a = 1) (hb : b ∉ s → f b = 1) :
  (∏ x in s, f x) = (f a) * (f b) :=
begin
  haveI := classical.dec_eq α;
  by_cases h₁ : a ∈ s; by_cases h₂ : b ∈ s,
  { exact prod_eq_mul_of_mem a b h₁ h₂ hn h₀ },
  { rw [hb h₂, mul_one],
    apply prod_eq_single_of_mem a h₁,
    exact λ c hc hca, h₀ c hc ⟨hca, ne_of_mem_of_not_mem hc h₂⟩ },
  { rw [ha h₁, one_mul],
    apply prod_eq_single_of_mem b h₂,
    exact λ c hc hcb, h₀ c hc ⟨ne_of_mem_of_not_mem hc h₁, hcb⟩ },
  { rw [ha h₁, hb h₂, mul_one],
    exact trans
      (prod_congr rfl (λ c hc, h₀ c hc ⟨ne_of_mem_of_not_mem hc h₁, ne_of_mem_of_not_mem hc h₂⟩))
      prod_const_one }
end

@[to_additive]
lemma prod_attach {f : α → β} : (∏ x in s.attach, f x) = (∏ x in s, f x) :=
by haveI := classical.dec_eq α; exact
  calc (∏ x in s.attach, f x.val) = (∏ x in (s.attach).image subtype.val, f x) :
    by rw [prod_image]; exact assume x _ y _, subtype.eq
  ... = _ : by rw [attach_image_val]

/-- A product over `s.subtype p` equals one over `s.filter p`. -/
@[simp, to_additive "A sum over `s.subtype p` equals one over `s.filter p`."]
lemma prod_subtype_eq_prod_filter (f : α → β) {p : α → Prop} [decidable_pred p] :
  ∏ x in s.subtype p, f x = ∏ x in s.filter p, f x :=
begin
  conv_lhs { erw ←prod_map (s.subtype p) (function.embedding.subtype _) f },
  exact prod_congr (subtype_map _) (λ x hx, rfl)
end

/-- If all elements of a `finset` satisfy the predicate `p`, a product
over `s.subtype p` equals that product over `s`. -/
@[to_additive "If all elements of a `finset` satisfy the predicate `p`, a sum
over `s.subtype p` equals that sum over `s`."]
lemma prod_subtype_of_mem (f : α → β) {p : α → Prop} [decidable_pred p]
    (h : ∀ x ∈ s, p x) : ∏ x in s.subtype p, f x = ∏ x in s, f x :=
by simp_rw [prod_subtype_eq_prod_filter, filter_true_of_mem h]

/-- A product of a function over a `finset` in a subtype equals a
product in the main type of a function that agrees with the first
function on that `finset`. -/
@[to_additive "A sum of a function over a `finset` in a subtype equals a
sum in the main type of a function that agrees with the first
function on that `finset`."]
lemma prod_subtype_map_embedding {p : α → Prop} {s : finset {x // p x}} {f : {x // p x} → β}
    {g : α → β} (h : ∀ x : {x // p x}, x ∈ s → g x = f x) :
  ∏ x in s.map (function.embedding.subtype _), g x = ∏ x in s, f x :=
begin
  rw finset.prod_map,
  exact finset.prod_congr rfl h
end

@[to_additive]
lemma prod_finset_coe (f : α → β) (s : finset α) :
  ∏ (i : (s : set α)), f i = ∏ i in s, f i :=
prod_attach

@[to_additive]
lemma prod_subtype {p : α → Prop} {F : fintype (subtype p)} (s : finset α)
  (h : ∀ x, x ∈ s ↔ p x) (f : α → β) :
  ∏ a in s, f a = ∏ a : subtype p, f a :=
have (∈ s) = p, from set.ext h, by { substI p, rw [←prod_finset_coe], congr }

@[to_additive] lemma prod_apply_dite {s : finset α} {p : α → Prop} {hp : decidable_pred p}
  [decidable_pred (λ x, ¬ p x)] (f : Π (x : α), p x → γ) (g : Π (x : α), ¬p x → γ)
  (h : γ → β) :
  (∏ x in s, h (if hx : p x then f x hx else g x hx)) =
  (∏ x in (s.filter p).attach, h (f x.1 (mem_filter.mp x.2).2)) *
    (∏ x in (s.filter (λ x, ¬ p x)).attach, h (g x.1 (mem_filter.mp x.2).2)) :=
calc ∏ x in s, h (if hx : p x then f x hx else g x hx)
    = (∏ x in s.filter p, h (if hx : p x then f x hx else g x hx)) *
    (∏ x in s.filter (λ x, ¬ p x), h (if hx : p x then f x hx else g x hx)) :
  (prod_filter_mul_prod_filter_not s p _).symm
... = (∏ x in (s.filter p).attach, h (if hx : p x.1 then f x.1 hx else g x.1 hx)) *
    (∏ x in (s.filter (λ x, ¬ p x)).attach, h (if hx : p x.1 then f x.1 hx else g x.1 hx)) :
  congr_arg2 _ prod_attach.symm prod_attach.symm
... = (∏ x in (s.filter p).attach, h (f x.1 (mem_filter.mp x.2).2)) *
    (∏ x in (s.filter (λ x, ¬ p x)).attach, h (g x.1 (mem_filter.mp x.2).2)) :
  congr_arg2 _
    (prod_congr rfl (λ x hx, congr_arg h (dif_pos (mem_filter.mp x.2).2)))
    (prod_congr rfl (λ x hx, congr_arg h (dif_neg (mem_filter.mp x.2).2)))

@[to_additive] lemma prod_apply_ite {s : finset α}
  {p : α → Prop} {hp : decidable_pred p} (f g : α → γ) (h : γ → β) :
  (∏ x in s, h (if p x then f x else g x)) =
  (∏ x in s.filter p, h (f x)) * (∏ x in s.filter (λ x, ¬ p x), h (g x)) :=
trans (prod_apply_dite _ _ _)
  (congr_arg2 _ (@prod_attach _ _ _ _ (h ∘ f)) (@prod_attach _ _ _ _ (h ∘ g)))

@[to_additive] lemma prod_dite {s : finset α} {p : α → Prop} {hp : decidable_pred p}
  (f : Π (x : α), p x → β) (g : Π (x : α), ¬p x → β) :
  (∏ x in s, if hx : p x then f x hx else g x hx) =
  (∏ x in (s.filter p).attach, f x.1 (mem_filter.mp x.2).2) *
    (∏ x in (s.filter (λ x, ¬ p x)).attach, g x.1 (mem_filter.mp x.2).2) :=
by simp [prod_apply_dite _ _ (λ x, x)]

@[to_additive] lemma prod_ite {s : finset α}
  {p : α → Prop} {hp : decidable_pred p} (f g : α → β) :
  (∏ x in s, if p x then f x else g x) =
  (∏ x in s.filter p, f x) * (∏ x in s.filter (λ x, ¬ p x), g x) :=
by simp [prod_apply_ite _ _ (λ x, x)]

@[to_additive] lemma prod_ite_of_false {p : α → Prop} {hp : decidable_pred p} (f g : α → β)
  (h : ∀ x ∈ s, ¬p x) : (∏ x in s, if p x then f x else g x) = (∏ x in s, g x) :=
by { rw prod_ite, simp [filter_false_of_mem h, filter_true_of_mem h] }

@[to_additive] lemma prod_ite_of_true {p : α → Prop} {hp : decidable_pred p} (f g : α → β)
  (h : ∀ x ∈ s, p x) : (∏ x in s, if p x then f x else g x) = (∏ x in s, f x) :=
by { simp_rw ←(ite_not (p _)), apply prod_ite_of_false, simpa }

@[to_additive] lemma prod_apply_ite_of_false {p : α → Prop} {hp : decidable_pred p} (f g : α → γ)
  (k : γ → β) (h : ∀ x ∈ s, ¬p x) :
  (∏ x in s, k (if p x then f x else g x)) = (∏ x in s, k (g x)) :=
by { simp_rw apply_ite k, exact prod_ite_of_false _ _ h }

@[to_additive] lemma prod_apply_ite_of_true {p : α → Prop} {hp : decidable_pred p} (f g : α → γ)
  (k : γ → β) (h : ∀ x ∈ s, p x) :
  (∏ x in s, k (if p x then f x else g x)) = (∏ x in s, k (f x)) :=
by { simp_rw apply_ite k, exact prod_ite_of_true _ _ h }

@[to_additive]
lemma prod_extend_by_one [decidable_eq α] (s : finset α) (f : α → β) :
  ∏ i in s, (if i ∈ s then f i else 1) = ∏ i in s, f i :=
prod_congr rfl $ λ i hi, if_pos hi

@[simp, to_additive]
lemma prod_dite_eq [decidable_eq α] (s : finset α) (a : α) (b : Π x : α, a = x → β) :
  (∏ x in s, (if h : a = x then b x h else 1)) = ite (a ∈ s) (b a rfl) 1 :=
begin
  split_ifs with h,
  { rw [finset.prod_eq_single a, dif_pos rfl],
    { intros, rw dif_neg, cc },
    { cc } },
  { rw finset.prod_eq_one,
    intros, rw dif_neg, intro, cc }
end

@[simp, to_additive]
lemma prod_dite_eq' [decidable_eq α] (s : finset α) (a : α) (b : Π x : α, x = a → β) :
  (∏ x in s, (if h : x = a then b x h else 1)) = ite (a ∈ s) (b a rfl) 1 :=
begin
  split_ifs with h,
  { rw [finset.prod_eq_single a, dif_pos rfl],
    { intros, rw dif_neg, cc },
    { cc } },
  { rw finset.prod_eq_one,
    intros, rw dif_neg, intro, cc }
end

@[simp, to_additive] lemma prod_ite_eq [decidable_eq α] (s : finset α) (a : α) (b : α → β) :
  (∏ x in s, (ite (a = x) (b x) 1)) = ite (a ∈ s) (b a) 1 :=
prod_dite_eq s a (λ x _, b x)

/--
  When a product is taken over a conditional whose condition is an equality test on the index
  and whose alternative is 1, then the product's value is either the term at that index or `1`.

  The difference with `prod_ite_eq` is that the arguments to `eq` are swapped.
-/
@[simp, to_additive] lemma prod_ite_eq' [decidable_eq α] (s : finset α) (a : α) (b : α → β) :
  (∏ x in s, (ite (x = a) (b x) 1)) = ite (a ∈ s) (b a) 1 :=
prod_dite_eq' s a (λ x _, b x)

@[to_additive]
lemma prod_ite_index (p : Prop) [decidable p] (s t : finset α) (f : α → β) :
  (∏ x in if p then s else t, f x) = if p then ∏ x in s, f x else ∏ x in t, f x :=
apply_ite (λ s, ∏ x in s, f x) _ _ _

@[simp, to_additive]
lemma prod_dite_irrel (p : Prop) [decidable p] (s : finset α) (f : p → α → β) (g : ¬p → α → β):
  (∏ x in s, if h : p then f h x else g h x) = if h : p then ∏ x in s, f h x else ∏ x in s, g h x :=
by { split_ifs with h; refl }

@[simp] lemma sum_pi_single' {ι M : Type*} [decidable_eq ι] [add_comm_monoid M]
  (i : ι) (x : M) (s : finset ι) :
  ∑ j in s, pi.single i x j = if i ∈ s then x else 0 :=
sum_dite_eq' _ _ _

@[simp] lemma sum_pi_single {ι : Type*} {M : ι → Type*}
  [decidable_eq ι] [Π i, add_comm_monoid (M i)] (i : ι) (f : Π i, M i) (s : finset ι) :
  ∑ j in s, pi.single j (f j) i = if i ∈ s then f i else 0 :=
sum_dite_eq _ _ _

/--
  Reorder a product.

  The difference with `prod_bij'` is that the bijection is specified as a surjective injection,
  rather than by an inverse function.
-/
@[to_additive "
  Reorder a sum.

  The difference with `sum_bij'` is that the bijection is specified as a surjective injection,
  rather than by an inverse function.
"]
lemma prod_bij {s : finset α} {t : finset γ} {f : α → β} {g : γ → β}
  (i : Π a ∈ s, γ) (hi : ∀ a ha, i a ha ∈ t) (h : ∀ a ha, f a = g (i a ha))
  (i_inj : ∀ a₁ a₂ ha₁ ha₂, i a₁ ha₁ = i a₂ ha₂ → a₁ = a₂) (i_surj : ∀ b ∈ t, ∃ a ha, b = i a ha) :
  (∏ x in s, f x) = (∏ x in t, g x) :=
congr_arg multiset.prod
  (multiset.map_eq_map_of_bij_of_nodup f g s.2 t.2 i hi h i_inj i_surj)

/--
  Reorder a product.

  The difference with `prod_bij` is that the bijection is specified with an inverse, rather than
  as a surjective injection.
-/
@[to_additive "
  Reorder a sum.

  The difference with `sum_bij` is that the bijection is specified with an inverse, rather than
  as a surjective injection.
"]
lemma prod_bij' {s : finset α} {t : finset γ} {f : α → β} {g : γ → β}
  (i : Π a ∈ s, γ) (hi : ∀ a ha, i a ha ∈ t) (h : ∀ a ha, f a = g (i a ha))
  (j : Π a ∈ t, α) (hj : ∀ a ha, j a ha ∈ s) (left_inv : ∀ a ha, j (i a ha) (hi a ha) = a)
  (right_inv : ∀ a ha, i (j a ha) (hj a ha) = a) :
  (∏ x in s, f x) = (∏ x in t, g x) :=
begin
  refine prod_bij i hi h _ _,
  {intros a1 a2 h1 h2 eq, rw [←left_inv a1 h1, ←left_inv a2 h2], cc,},
  {intros b hb, use j b hb, use hj b hb, exact (right_inv b hb).symm,},
end

@[to_additive]
lemma prod_bij_ne_one {s : finset α} {t : finset γ} {f : α → β} {g : γ → β}
  (i : Π a ∈ s, f a ≠ 1 → γ) (hi : ∀ a h₁ h₂, i a h₁ h₂ ∈ t)
  (i_inj : ∀ a₁ a₂ h₁₁ h₁₂ h₂₁ h₂₂, i a₁ h₁₁ h₁₂ = i a₂ h₂₁ h₂₂ → a₁ = a₂)
  (i_surj : ∀ b ∈ t, g b ≠ 1 → ∃ a h₁ h₂, b = i a h₁ h₂)
  (h : ∀ a h₁ h₂, f a = g (i a h₁ h₂)) :
  (∏ x in s, f x) = (∏ x in t, g x) :=
by classical; exact
calc (∏ x in s, f x) = ∏ x in (s.filter $ λ x, f x ≠ 1), f x : prod_filter_ne_one.symm
  ... = ∏ x in (t.filter $ λ x, g x ≠ 1), g x :
    prod_bij (assume a ha, i a (mem_filter.mp ha).1 (mem_filter.mp ha).2)
      (assume a ha, (mem_filter.mp ha).elim $ λ h₁ h₂, mem_filter.mpr
        ⟨hi a h₁ h₂, λ hg, h₂ (hg ▸ h a h₁ h₂)⟩)
      (assume a ha, (mem_filter.mp ha).elim $ h a)
      (assume a₁ a₂ ha₁ ha₂,
        (mem_filter.mp ha₁).elim $ λ ha₁₁ ha₁₂,
          (mem_filter.mp ha₂).elim $ λ ha₂₁ ha₂₂, i_inj a₁ a₂ _ _ _ _)
      (assume b hb, (mem_filter.mp hb).elim $ λ h₁ h₂,
        let ⟨a, ha₁, ha₂, eq⟩ := i_surj b h₁ h₂ in ⟨a, mem_filter.mpr ⟨ha₁, ha₂⟩, eq⟩)
  ... = (∏ x in t, g x) : prod_filter_ne_one

@[to_additive] lemma prod_dite_of_false {p : α → Prop} {hp : decidable_pred p}
  (h : ∀ x ∈ s, ¬ p x) (f : Π (x : α), p x → β) (g : Π (x : α), ¬p x → β) :
  (∏ x in s, if hx : p x then f x hx else g x hx) =
  ∏ (x : s), g x.val (h x.val x.property) :=
prod_bij (λ x hx, ⟨x,hx⟩) (λ x hx, by simp) (λ a ha, by { dsimp, rw dif_neg })
  (λ a₁ a₂ h₁ h₂ hh, congr_arg coe hh) (λ b hb, ⟨b.1, b.2, by simp⟩)

@[to_additive] lemma prod_dite_of_true {p : α → Prop} {hp : decidable_pred p}
  (h : ∀ x ∈ s, p x) (f : Π (x : α), p x → β) (g : Π (x : α), ¬p x → β) :
  (∏ x in s, if hx : p x then f x hx else g x hx) =
  ∏ (x : s), f x.val (h x.val x.property) :=
prod_bij (λ x hx, ⟨x,hx⟩) (λ x hx, by simp) (λ a ha, by { dsimp, rw dif_pos })
  (λ a₁ a₂ h₁ h₂ hh, congr_arg coe hh) (λ b hb, ⟨b.1, b.2, by simp⟩)

@[to_additive]
lemma nonempty_of_prod_ne_one (h : (∏ x in s, f x) ≠ 1) : s.nonempty :=
s.eq_empty_or_nonempty.elim (λ H, false.elim $ h $ H.symm ▸ prod_empty) id

@[to_additive]
lemma exists_ne_one_of_prod_ne_one (h : (∏ x in s, f x) ≠ 1) : ∃ a ∈ s, f a ≠ 1 :=
begin
  classical,
  rw ← prod_filter_ne_one at h,
  rcases nonempty_of_prod_ne_one h with ⟨x, hx⟩,
  exact ⟨x, (mem_filter.1 hx).1, (mem_filter.1 hx).2⟩
end

@[to_additive]
lemma prod_range_succ_comm (f : ℕ → β) (n : ℕ) :
  ∏ x in range (n + 1), f x = f n * ∏ x in range n, f x :=
by rw [range_succ, prod_insert not_mem_range_self]

@[to_additive]
lemma prod_range_succ (f : ℕ → β) (n : ℕ) :
  ∏ x in range (n + 1), f x = (∏ x in range n, f x) * f n :=
by simp only [mul_comm, prod_range_succ_comm]

@[to_additive]
lemma prod_range_succ' (f : ℕ → β) :
  ∀ n : ℕ, (∏ k in range (n + 1), f k) = (∏ k in range n, f (k+1)) * f 0
| 0       := prod_range_succ _ _
| (n + 1) := by rw [prod_range_succ _ n, mul_right_comm, ← prod_range_succ', prod_range_succ]

@[to_additive]
lemma eventually_constant_prod {u : ℕ → β} {N : ℕ} (hu : ∀ n ≥ N, u n = 1) {n : ℕ} (hn : N ≤ n) :
  ∏ k in range (n + 1), u k = ∏ k in range (N + 1), u k :=
begin
  obtain ⟨m, rfl : n = N + m⟩ := le_iff_exists_add.mp hn,
  clear hn,
  induction m with m hm,
  { simp },
  erw [prod_range_succ, hm],
  simp [hu]
end

@[to_additive]
lemma prod_range_add (f : ℕ → β) (n m : ℕ) :
  ∏ x in range (n + m), f x =
  (∏ x in range n, f x) * (∏ x in range m, f (n + x)) :=
begin
  induction m with m hm,
  { simp },
  { rw [nat.add_succ, prod_range_succ, hm, prod_range_succ, mul_assoc], },
end

@[to_additive]
lemma prod_range_add_div_prod_range {α : Type*} [comm_group α] (f : ℕ → α) (n m : ℕ) :
  (∏ k in range (n + m), f k) / (∏ k in range n, f k) = ∏ k in finset.range m, f (n + k) :=
div_eq_of_eq_mul' (prod_range_add f n m)

@[to_additive]
lemma prod_range_zero (f : ℕ → β) :
  ∏ k in range 0, f k = 1 :=
by rw [range_zero, prod_empty]

@[to_additive sum_range_one]
lemma prod_range_one (f : ℕ → β) :
  ∏ k in range 1, f k = f 0 :=
by { rw [range_one], apply @prod_singleton β ℕ 0 f }

open multiset

@[to_additive] lemma prod_multiset_map_count [decidable_eq α] (s : multiset α)
  {M : Type*} [comm_monoid M] (f : α → M) :
  (s.map f).prod = ∏ m in s.to_finset, (f m) ^ (s.count m) :=
begin
  induction s using multiset.induction_on with a s ih,
  { simp only [prod_const_one, count_zero, prod_zero, pow_zero, multiset.map_zero] },
  simp only [multiset.prod_cons, map_cons, to_finset_cons, ih],
  by_cases has : a ∈ s.to_finset,
  { rw [insert_eq_of_mem has, ← insert_erase has, prod_insert (not_mem_erase _ _),
        prod_insert (not_mem_erase _ _), ← mul_assoc, count_cons_self, pow_succ],
    congr' 1, refine prod_congr rfl (λ x hx, _),
    rw [count_cons_of_ne (ne_of_mem_erase hx)] },
  rw [prod_insert has, count_cons_self, count_eq_zero_of_not_mem (mt mem_to_finset.2 has), pow_one],
  congr' 1, refine prod_congr rfl (λ x hx, _),
  rw count_cons_of_ne,
  rintro rfl, exact has hx
end

@[to_additive]
lemma prod_multiset_count [decidable_eq α] [comm_monoid α] (s : multiset α) :
  s.prod = ∏ m in s.to_finset, m ^ (s.count m) :=
by { convert prod_multiset_map_count s id, rw map_id }

@[to_additive] lemma prod_mem_multiset [decidable_eq α]
  (m : multiset α) (f : {x // x ∈ m} → β) (g : α → β)
  (hfg : ∀ x, f x = g x) :
  ∏ (x : {x // x ∈ m}), f x = ∏ x in m.to_finset, g x :=
prod_bij (λ x _, x.1) (λ x _, multiset.mem_to_finset.mpr x.2)
  (λ _ _, hfg _)
  (λ _ _ _ _ h, by { ext, assumption })
  (λ y hy, ⟨⟨y, multiset.mem_to_finset.mp hy⟩, finset.mem_univ _, rfl⟩)

/--
To prove a property of a product, it suffices to prove that
the property is multiplicative and holds on factors.
-/
@[to_additive "To prove a property of a sum, it suffices to prove that
the property is additive and holds on summands."]
lemma prod_induction {M : Type*} [comm_monoid M] (f : α → M) (p : M → Prop)
  (p_mul : ∀ a b, p a → p b → p (a * b)) (p_one : p 1) (p_s : ∀ x ∈ s, p $ f x) :
  p $ ∏ x in s, f x :=
multiset.prod_induction _ _ p_mul p_one (multiset.forall_mem_map_iff.mpr p_s)

/--
To prove a property of a product, it suffices to prove that
the property is multiplicative and holds on factors.
-/
@[to_additive "To prove a property of a sum, it suffices to prove that
the property is additive and holds on summands."]
lemma prod_induction_nonempty {M : Type*} [comm_monoid M] (f : α → M) (p : M → Prop)
  (p_mul : ∀ a b, p a → p b → p (a * b)) (hs_nonempty : s.nonempty) (p_s : ∀ x ∈ s, p $ f x) :
  p $ ∏ x in s, f x :=
multiset.prod_induction_nonempty p p_mul (by simp [nonempty_iff_ne_empty.mp hs_nonempty])
  (multiset.forall_mem_map_iff.mpr p_s)

/--
For any product along `{0, ..., n-1}` of a commutative-monoid-valued function, we can verify that
it's equal to a different function just by checking ratios of adjacent terms.
This is a multiplicative discrete analogue of the fundamental theorem of calculus. -/
lemma prod_range_induction {M : Type*} [comm_monoid M]
  (f s : ℕ → M) (h0 : s 0 = 1) (h : ∀ n, s (n + 1) = s n * f n) (n : ℕ) :
  ∏ k in finset.range n, f k = s n :=
begin
  induction n with k hk,
  { simp only [h0, finset.prod_range_zero] },
  { simp only [hk, finset.prod_range_succ, h, mul_comm] }
end

/--
For any sum along `{0, ..., n-1}` of a commutative-monoid-valued function,
we can verify that it's equal to a different function
just by checking differences of adjacent terms.
This is a discrete analogue
of the fundamental theorem of calculus.
-/
lemma sum_range_induction {M : Type*} [add_comm_monoid M]
  (f s : ℕ → M) (h0 : s 0 = 0) (h : ∀ n, s (n + 1) = s n + f n) (n : ℕ) :
  ∑ k in finset.range n, f k = s n :=
@prod_range_induction (multiplicative M) _ f s h0 h n

/-- A telescoping sum along `{0, ..., n-1}` of an additive commutative group valued function
reduces to the difference of the last and first terms.-/
lemma sum_range_sub {G : Type*} [add_comm_group G] (f : ℕ → G) (n : ℕ) :
  ∑ i in range n, (f (i+1) - f i) = f n - f 0 :=
by { apply sum_range_induction; simp }

lemma sum_range_sub' {G : Type*} [add_comm_group G] (f : ℕ → G) (n : ℕ) :
  ∑ i in range n, (f i - f (i+1)) = f 0 - f n :=
by { apply sum_range_induction; simp }

/-- A telescoping product along `{0, ..., n-1}` of a commutative group valued function
reduces to the ratio of the last and first factors.-/
@[to_additive]
lemma prod_range_div {M : Type*} [comm_group M] (f : ℕ → M) (n : ℕ) :
  ∏ i in range n, (f (i+1) * (f i)⁻¹) = f n * (f 0)⁻¹ :=
by simpa only [← div_eq_mul_inv] using @sum_range_sub (additive M) _ f n

@[to_additive]
lemma prod_range_div' {M : Type*} [comm_group M] (f : ℕ → M) (n : ℕ) :
  ∏ i in range n, (f i * (f (i+1))⁻¹) = (f 0) * (f n)⁻¹ :=
by simpa only [← div_eq_mul_inv] using @sum_range_sub' (additive M) _ f n

/--
A telescoping sum along `{0, ..., n-1}` of an `ℕ`-valued function
reduces to the difference of the last and first terms
when the function we are summing is monotone.
-/
lemma sum_range_sub_of_monotone {f : ℕ → ℕ} (h : monotone f) (n : ℕ) :
  ∑ i in range n, (f (i+1) - f i) = f n - f 0 :=
begin
  refine sum_range_induction _ _ (tsub_self _) (λ n, _) _,
  have h₁ : f n ≤ f (n+1) := h (nat.le_succ _),
  have h₂ : f 0 ≤ f n := h (nat.zero_le _),
  rw [tsub_add_eq_add_tsub h₂, add_tsub_cancel_of_le h₁],
end

@[simp, to_additive] lemma prod_const (b : β) : (∏ x in s, b) = b ^ s.card :=
by haveI := classical.dec_eq α; exact
finset.induction_on s (by simp) (λ a s has ih,
by rw [prod_insert has, card_insert_of_not_mem has, pow_succ, ih])

@[to_additive]
lemma pow_eq_prod_const (b : β) : ∀ n, b ^ n = ∏ k in range n, b := by simp

@[to_additive sum_nsmul]
lemma prod_pow (s : finset α) (n : ℕ) (f : α → β) :
  ∏ x in s, f x ^ n = (∏ x in s, f x) ^ n :=
by haveI := classical.dec_eq α; exact
finset.induction_on s (by simp) (by simp [mul_pow] {contextual := tt})

@[to_additive]
lemma prod_flip {n : ℕ} (f : ℕ → β) :
  ∏ r in range (n + 1), f (n - r) = ∏ k in range (n + 1), f k :=
begin
  induction n with n ih,
  { rw [prod_range_one, prod_range_one] },
  { rw [prod_range_succ', prod_range_succ _ (nat.succ n)],
    simp [← ih] }
end

@[to_additive]
lemma prod_involution {s : finset α} {f : α → β} :
  ∀ (g : Π a ∈ s, α)
  (h : ∀ a ha, f a * f (g a ha) = 1)
  (g_ne : ∀ a ha, f a ≠ 1 → g a ha ≠ a)
  (g_mem : ∀ a ha, g a ha ∈ s)
  (g_inv : ∀ a ha, g (g a ha) (g_mem a ha) = a),
  (∏ x in s, f x) = 1 :=
by haveI := classical.dec_eq α;
haveI := classical.dec_eq β; exact
finset.strong_induction_on s
  (λ s ih g h g_ne g_mem g_inv,
    s.eq_empty_or_nonempty.elim (λ hs, hs.symm ▸ rfl)
      (λ ⟨x, hx⟩,
      have hmem : ∀ y ∈ (s.erase x).erase (g x hx), y ∈ s,
        from λ y hy, (mem_of_mem_erase (mem_of_mem_erase hy)),
      have g_inj : ∀ {x hx y hy}, g x hx = g y hy → x = y,
        from λ x hx y hy h, by rw [← g_inv x hx, ← g_inv y hy]; simp [h],
      have ih': ∏ y in erase (erase s x) (g x hx), f y = (1 : β) :=
        ih ((s.erase x).erase (g x hx))
          ⟨subset.trans (erase_subset _ _) (erase_subset _ _),
            λ h, not_mem_erase (g x hx) (s.erase x) (h (g_mem x hx))⟩
          (λ y hy, g y (hmem y hy))
          (λ y hy, h y (hmem y hy))
          (λ y hy, g_ne y (hmem y hy))
          (λ y hy, mem_erase.2 ⟨λ (h : g y _ = g x hx), by simpa [g_inj h] using hy,
            mem_erase.2 ⟨λ (h : g y _ = x),
              have y = g x hx, from g_inv y (hmem y hy) ▸ by simp [h],
              by simpa [this] using hy, g_mem y (hmem y hy)⟩⟩)
          (λ y hy, g_inv y (hmem y hy)),
      if hx1 : f x = 1
      then ih' ▸ eq.symm (prod_subset hmem
        (λ y hy hy₁,
          have y = x ∨ y = g x hx, by simp [hy] at hy₁; tauto,
          this.elim (λ hy, hy.symm ▸ hx1)
            (λ hy, h x hx ▸ hy ▸ hx1.symm ▸ (one_mul _).symm)))
      else by rw [← insert_erase hx, prod_insert (not_mem_erase _ _),
        ← insert_erase (mem_erase.2 ⟨g_ne x hx hx1, g_mem x hx⟩),
        prod_insert (not_mem_erase _ _), ih', mul_one, h x hx]))

/-- The product of the composition of functions `f` and `g`, is the product
over `b ∈ s.image g` of `f b` to the power of the cardinality of the fibre of `b`. See also
`finset.prod_image`. -/
lemma prod_comp [decidable_eq γ] (f : γ → β) (g : α → γ) :
  ∏ a in s, f (g a) = ∏ b in s.image g, f b ^ (s.filter (λ a, g a = b)).card  :=
calc ∏ a in s, f (g a)
    = ∏ x in (s.image g).sigma (λ b : γ, s.filter (λ a, g a = b)), f (g x.2) :
  prod_bij (λ a ha, ⟨g a, a⟩) (by simp; tauto) (λ _ _, rfl) (by simp) (by finish)
... = ∏ b in s.image g, ∏ a in s.filter (λ a, g a = b), f (g a) : prod_sigma _ _ _
... = ∏ b in s.image g, ∏ a in s.filter (λ a, g a = b), f b :
  prod_congr rfl (λ b hb, prod_congr rfl (by simp {contextual := tt}))
... = ∏ b in s.image g, f b ^ (s.filter (λ a, g a = b)).card :
  prod_congr rfl (λ _ _, prod_const _)

@[to_additive]
lemma prod_piecewise [decidable_eq α] (s t : finset α) (f g : α → β) :
  (∏ x in s, (t.piecewise f g) x) = (∏ x in s ∩ t, f x) * (∏ x in s \ t, g x) :=
by { rw [piecewise, prod_ite, filter_mem_eq_inter, ← sdiff_eq_filter], }

@[to_additive]
lemma prod_inter_mul_prod_diff [decidable_eq α] (s t : finset α) (f : α → β) :
  (∏ x in s ∩ t, f x) * (∏ x in s \ t, f x) = (∏ x in s, f x) :=
by { convert (s.prod_piecewise t f f).symm, simp [finset.piecewise] }

@[to_additive]
lemma prod_eq_mul_prod_diff_singleton [decidable_eq α] {s : finset α} {i : α} (h : i ∈ s)
  (f : α → β) : ∏ x in s, f x = f i * ∏ x in s \ {i}, f x :=
by { convert (s.prod_inter_mul_prod_diff {i} f).symm, simp [h] }

@[to_additive]
lemma prod_eq_prod_diff_singleton_mul [decidable_eq α] {s : finset α} {i : α} (h : i ∈ s)
  (f : α → β) : ∏ x in s, f x = (∏ x in s \ {i}, f x) * f i :=
by { rw [prod_eq_mul_prod_diff_singleton h, mul_comm] }

@[to_additive]
lemma _root_.fintype.prod_eq_mul_prod_compl [decidable_eq α] [fintype α] (a : α) (f : α → β) :
  ∏ i, f i = (f a) * ∏ i in {a}ᶜ, f i :=
prod_eq_mul_prod_diff_singleton (mem_univ a) f

@[to_additive]
lemma _root_.fintype.prod_eq_prod_compl_mul [decidable_eq α] [fintype α] (a : α) (f : α → β) :
  ∏ i, f i = (∏ i in {a}ᶜ, f i) * f a :=
prod_eq_prod_diff_singleton_mul (mem_univ a) f

lemma dvd_prod_of_mem (f : α → β) {a : α} {s : finset α} (ha : a ∈ s) :
  f a ∣ ∏ i in s, f i :=
begin
  classical,
  rw finset.prod_eq_mul_prod_diff_singleton ha,
  exact dvd_mul_right _ _,
end

/-- A product can be partitioned into a product of products, each equivalent under a setoid. -/
@[to_additive "A sum can be partitioned into a sum of sums, each equivalent under a setoid."]
lemma prod_partition (R : setoid α) [decidable_rel R.r] :
  (∏ x in s, f x) = ∏ xbar in s.image quotient.mk, ∏ y in s.filter (λ y, ⟦y⟧ = xbar), f y :=
begin
  refine (finset.prod_image' f (λ x hx, _)).symm,
  refl,
end

/-- If we can partition a product into subsets that cancel out, then the whole product cancels. -/
@[to_additive "If we can partition a sum into subsets that cancel out, then the whole sum cancels."]
lemma prod_cancels_of_partition_cancels (R : setoid α) [decidable_rel R.r]
  (h : ∀ x ∈ s, (∏ a in s.filter (λ y, y ≈ x), f a) = 1) : (∏ x in s, f x) = 1 :=
begin
  rw [prod_partition R, ←finset.prod_eq_one],
  intros xbar xbar_in_s,
  obtain ⟨x, x_in_s, xbar_eq_x⟩ := mem_image.mp xbar_in_s,
  rw [←xbar_eq_x, filter_congr (λ y _, @quotient.eq _ R y x)],
  apply h x x_in_s,
end

@[to_additive]
lemma prod_update_of_not_mem [decidable_eq α] {s : finset α} {i : α}
  (h : i ∉ s) (f : α → β) (b : β) : (∏ x in s, function.update f i b x) = (∏ x in s, f x) :=
begin
  apply prod_congr rfl (λ j hj, _),
  have : j ≠ i, by { assume eq, rw eq at hj, exact h hj },
  simp [this]
end

@[to_additive]
lemma prod_update_of_mem [decidable_eq α] {s : finset α} {i : α} (h : i ∈ s) (f : α → β) (b : β) :
  (∏ x in s, function.update f i b x) = b * (∏ x in s \ (singleton i), f x) :=
by { rw [update_eq_piecewise, prod_piecewise], simp [h] }

/-- If a product of a `finset` of size at most 1 has a given value, so
do the terms in that product. -/
@[to_additive eq_of_card_le_one_of_sum_eq "If a sum of a `finset` of size at most 1 has a given
value, so do the terms in that sum."]
lemma eq_of_card_le_one_of_prod_eq {s : finset α} (hc : s.card ≤ 1) {f : α → β} {b : β}
    (h : ∏ x in s, f x = b) : ∀ x ∈ s, f x = b :=
begin
  intros x hx,
  by_cases hc0 : s.card = 0,
  { exact false.elim (card_ne_zero_of_mem hx hc0) },
  { have h1 : s.card = 1 := le_antisymm hc (nat.one_le_of_lt (nat.pos_of_ne_zero hc0)),
    rw card_eq_one at h1,
    cases h1 with x2 hx2,
    rw [hx2, mem_singleton] at hx,
    simp_rw hx2 at h,
    rw hx,
    rw prod_singleton at h,
    exact h }
end

/-- Taking a product over `s : finset α` is the same as multiplying the value on a single element
`f a` by the product of `s.erase a`. -/
@[to_additive "Taking a sum over `s : finset α` is the same as adding the value on a single element
`f a` to the sum over `s.erase a`."]
lemma mul_prod_erase [decidable_eq α] (s : finset α) (f : α → β) {a : α} (h : a ∈ s) :
  f a * (∏ x in s.erase a, f x) = ∏ x in s, f x :=
by rw [← prod_insert (not_mem_erase a s), insert_erase h]

/-- A variant of `finset.mul_prod_erase` with the multiplication swapped. -/
@[to_additive "A variant of `finset.add_sum_erase` with the addition swapped."]
lemma prod_erase_mul [decidable_eq α] (s : finset α) (f : α → β) {a : α} (h : a ∈ s) :
  (∏ x in s.erase a, f x) * f a = ∏ x in s, f x :=
by rw [mul_comm, mul_prod_erase s f h]

/-- If a function applied at a point is 1, a product is unchanged by
removing that point, if present, from a `finset`. -/
@[to_additive "If a function applied at a point is 0, a sum is unchanged by
removing that point, if present, from a `finset`."]
lemma prod_erase [decidable_eq α] (s : finset α) {f : α → β} {a : α} (h : f a = 1) :
  ∏ x in s.erase a, f x = ∏ x in s, f x :=
begin
  rw ←sdiff_singleton_eq_erase,
  refine prod_subset (sdiff_subset _ _) (λ x hx hnx, _),
  rw sdiff_singleton_eq_erase at hnx,
  rwa eq_of_mem_of_not_mem_erase hx hnx
end

/-- If a product is 1 and the function is 1 except possibly at one
point, it is 1 everywhere on the `finset`. -/
@[to_additive "If a sum is 0 and the function is 0 except possibly at one
point, it is 0 everywhere on the `finset`."]
lemma eq_one_of_prod_eq_one {s : finset α} {f : α → β} {a : α} (hp : ∏ x in s, f x = 1)
    (h1 : ∀ x ∈ s, x ≠ a → f x = 1) : ∀ x ∈ s, f x = 1 :=
begin
  intros x hx,
  classical,
  by_cases h : x = a,
  { rw h,
    rw h at hx,
    rw [←prod_subset (singleton_subset_iff.2 hx)
                      (λ t ht ha, h1 t ht (not_mem_singleton.1 ha)),
        prod_singleton] at hp,
    exact hp },
  { exact h1 x hx h }
end

lemma prod_pow_boole [decidable_eq α] (s : finset α) (f : α → β) (a : α) :
  (∏ x in s, (f x)^(ite (a = x) 1 0)) = ite (a ∈ s) (f a) 1 :=
by simp

end comm_monoid

/-- If `f = g = h` everywhere but at `i`, where `f i = g i + h i`, then the product of `f` over `s`
  is the sum of the products of `g` and `h`. -/
lemma prod_add_prod_eq [comm_semiring β] {s : finset α} {i : α} {f g h : α → β}
  (hi : i ∈ s) (h1 : g i + h i = f i) (h2 : ∀ j ∈ s, j ≠ i → g j = f j)
  (h3 : ∀ j ∈ s, j ≠ i → h j = f j) : ∏ i in s, g i + ∏ i in s, h i = ∏ i in s, f i :=
by { classical, simp_rw [prod_eq_mul_prod_diff_singleton hi, ← h1, right_distrib],
     congr' 2; apply prod_congr rfl; simpa }

lemma card_eq_sum_ones (s : finset α) : s.card = ∑ _ in s, 1 :=
by simp

lemma sum_const_nat {m : ℕ} {f : α → ℕ} (h₁ : ∀ x ∈ s, f x = m) :
  (∑ x in s, f x) = card s * m :=
begin
  rw [← nat.nsmul_eq_mul, ← sum_const],
  apply sum_congr rfl h₁
end

@[simp]
lemma sum_boole {s : finset α} {p : α → Prop} [non_assoc_semiring β] {hp : decidable_pred p} :
  (∑ x in s, if p x then (1 : β) else (0 : β)) = (s.filter p).card :=
by simp [sum_ite]

lemma sum_comp [add_comm_monoid β] [decidable_eq γ] (f : γ → β) (g : α → γ) :
  ∑ a in s, f (g a) = ∑ b in s.image g, (s.filter (λ a, g a = b)).card • (f b) :=
@prod_comp (multiplicative β) _ _ _ _ _ _ _
attribute [to_additive "The sum of the composition of functions `f` and `g`, is the sum
over `b ∈ s.image g` of `f b` times of the cardinality of the fibre of `b`. See also
`finset.sum_image`."] prod_comp

lemma eq_sum_range_sub [add_comm_group β] (f : ℕ → β) (n : ℕ) :
  f n = f 0 + ∑ i in range n, (f (i+1) - f i) :=
by rw [finset.sum_range_sub, add_sub_cancel'_right]

lemma eq_sum_range_sub' [add_comm_group β] (f : ℕ → β) (n : ℕ) :
  f n = ∑ i in range (n + 1), if i = 0 then f 0 else f i - f (i - 1) :=
begin
  conv_lhs { rw [finset.eq_sum_range_sub f] },
  simp [finset.sum_range_succ', add_comm]
end

section opposite

open mul_opposite

/-- Moving to the opposite additive commutative monoid commutes with summing. -/
@[simp] lemma op_sum [add_comm_monoid β] {s : finset α} (f : α → β) :
  op (∑ x in s, f x) = ∑ x in s, op (f x) :=
(op_add_equiv : β ≃+ βᵐᵒᵖ).map_sum _ _

@[simp] lemma unop_sum [add_comm_monoid β] {s : finset α} (f : α → βᵐᵒᵖ) :
  unop (∑ x in s, f x) = ∑ x in s, unop (f x) :=
(op_add_equiv : β ≃+ βᵐᵒᵖ).symm.map_sum _ _

end opposite

section comm_group
variables [comm_group β]

@[simp, to_additive]
lemma prod_inv_distrib : (∏ x in s, (f x)⁻¹) = (∏ x in s, f x)⁻¹ :=
(monoid_hom.map_prod (comm_group.inv_monoid_hom : β →* β) f s).symm

@[to_additive zsmul_sum]
lemma prod_zpow (f : α → β) (s : finset α) (n : ℤ) :
  (∏ a in s, f a) ^ n = ∏ a in s, (f a) ^ n :=
(zpow_group_hom n : β →* β).map_prod f s

end comm_group

@[simp] theorem card_sigma {σ : α → Type*} (s : finset α) (t : Π a, finset (σ a)) :
  card (s.sigma t) = ∑ a in s, card (t a) :=
multiset.card_sigma _ _

lemma card_bUnion [decidable_eq β] {s : finset α} {t : α → finset β}
  (h : ∀ x ∈ s, ∀ y ∈ s, x ≠ y → disjoint (t x) (t y)) :
  (s.bUnion t).card = ∑ u in s, card (t u) :=
calc (s.bUnion t).card = ∑ i in s.bUnion t, 1 : by simp
... = ∑ a in s, ∑ i in t a, 1 : finset.sum_bUnion h
... = ∑ u in s, card (t u) : by simp

lemma card_bUnion_le [decidable_eq β] {s : finset α} {t : α → finset β} :
  (s.bUnion t).card ≤ ∑ a in s, (t a).card :=
by haveI := classical.dec_eq α; exact
finset.induction_on s (by simp)
  (λ a s has ih,
    calc ((insert a s).bUnion t).card ≤ (t a).card + (s.bUnion t).card :
    by rw bUnion_insert; exact finset.card_union_le _ _
    ... ≤ ∑ a in insert a s, card (t a) :
    by rw sum_insert has; exact add_le_add_left ih _)

theorem card_eq_sum_card_fiberwise [decidable_eq β] {f : α → β} {s : finset α} {t : finset β}
  (H : ∀ x ∈ s, f x ∈ t) :
  s.card = ∑ a in t, (s.filter (λ x, f x = a)).card :=
by simp only [card_eq_sum_ones, sum_fiberwise_of_maps_to H]

theorem card_eq_sum_card_image [decidable_eq β] (f : α → β) (s : finset α) :
  s.card = ∑ a in s.image f, (s.filter (λ x, f x = a)).card :=
card_eq_sum_card_fiberwise (λ _, mem_image_of_mem _)

@[simp] lemma sum_sub_distrib [add_comm_group β] :
  ∑ x in s, (f x - g x) = (∑ x in s, f x) - (∑ x in s, g x) :=
by simpa only [sub_eq_add_neg] using sum_add_distrib.trans (congr_arg _ sum_neg_distrib)

section prod_eq_zero
variables [comm_monoid_with_zero β]

lemma prod_eq_zero (ha : a ∈ s) (h : f a = 0) : (∏ x in s, f x) = 0 :=
by { haveI := classical.dec_eq α, rw [←prod_erase_mul _ _ ha, h, mul_zero] }

lemma prod_boole {s : finset α} {p : α → Prop} [decidable_pred p] :
  ∏ i in s, ite (p i) (1 : β) (0 : β) = ite (∀ i ∈ s, p i) 1 0 :=
begin
  split_ifs,
  { apply prod_eq_one,
    intros i hi,
    rw if_pos (h i hi) },
  { push_neg at h,
    rcases h with ⟨i, hi, hq⟩,
    apply prod_eq_zero hi,
    rw [if_neg hq] },
end

variables [nontrivial β] [no_zero_divisors β]

lemma prod_eq_zero_iff : (∏ x in s, f x) = 0 ↔ (∃ a ∈ s, f a = 0) :=
begin
  classical,
  apply finset.induction_on s,
  exact ⟨not.elim one_ne_zero, λ ⟨_, H, _⟩, H.elim⟩,
  assume a s ha ih,
  rw [prod_insert ha, mul_eq_zero, bex_def, exists_mem_insert, ih, ← bex_def]
end

theorem prod_ne_zero_iff : (∏ x in s, f x) ≠ 0 ↔ (∀ a ∈ s, f a ≠ 0) :=
by { rw [ne, prod_eq_zero_iff], push_neg }

end prod_eq_zero

section comm_group_with_zero
variables [comm_group_with_zero β]

@[simp]
lemma prod_inv_distrib' : (∏ x in s, (f x)⁻¹) = (∏ x in s, f x)⁻¹ :=
begin
  classical,
  by_cases h : ∃ x ∈ s, f x = 0,
  { simpa [prod_eq_zero_iff.mpr h, prod_eq_zero_iff] using h },
  { push_neg at h,
    have h' := prod_ne_zero_iff.mpr h,
    have hf : ∀ x ∈ s, (f x)⁻¹ * f x = 1 := λ x hx, inv_mul_cancel (h x hx),
    apply mul_right_cancel₀ h',
    simp [h, h', ← finset.prod_mul_distrib, prod_congr rfl hf] }
end

end comm_group_with_zero

@[to_additive]
lemma prod_unique_nonempty {α β : Type*} [comm_monoid β] [unique α]
  (s : finset α) (f : α → β) (h : s.nonempty) :
  (∏ x in s, f x) = f (default α) :=
begin
  obtain ⟨a, ha⟩ := h,
  have : s = {a},
  { ext b,
    simpa [subsingleton.elim a b] using ha },
  rw [this, finset.prod_singleton, subsingleton.elim a (default α)]
end

end finset

namespace fintype

open finset

/-- `fintype.prod_bijective` is a variant of `finset.prod_bij` that accepts `function.bijective`.

See `function.bijective.prod_comp` for a version without `h`. -/
@[to_additive "`fintype.sum_equiv` is a variant of `finset.sum_bij` that accepts
`function.bijective`.

See `function.bijective.sum_comp` for a version without `h`. "]
lemma prod_bijective {α β M : Type*} [fintype α] [fintype β] [comm_monoid M]
  (e : α → β) (he : function.bijective e) (f : α → M) (g : β → M) (h : ∀ x, f x = g (e x)) :
  ∏ x : α, f x = ∏ x : β, g x :=
prod_bij
  (λ x _, e x)
  (λ x _, mem_univ (e x))
  (λ x _, h x)
  (λ x x' _ _ h, he.injective h)
  (λ y _, (he.surjective y).imp $ λ a h, ⟨mem_univ _, h.symm⟩)

/-- `fintype.prod_equiv` is a specialization of `finset.prod_bij` that
automatically fills in most arguments.

See `equiv.prod_comp` for a version without `h`.
-/
@[to_additive "`fintype.sum_equiv` is a specialization of `finset.sum_bij` that
automatically fills in most arguments.

See `equiv.sum_comp` for a version without `h`.
"]
lemma prod_equiv {α β M : Type*} [fintype α] [fintype β] [comm_monoid M]
  (e : α ≃ β) (f : α → M) (g : β → M) (h : ∀ x, f x = g (e x)) :
  ∏ x : α, f x = ∏ x : β, g x :=
prod_bijective e e.bijective f g h

@[to_additive]
lemma prod_finset_coe [comm_monoid β] :
  ∏ (i : (s : set α)), f i = ∏ i in s, f i :=
(finset.prod_subtype s (λ _, iff.rfl) f).symm

@[to_additive]
lemma prod_unique {α β : Type*} [comm_monoid β] [unique α] (f : α → β) :
  (∏ x : α, f x) = f (default α) :=
by rw [univ_unique, prod_singleton]

@[to_additive] lemma prod_empty {α β : Type*} [comm_monoid β] [is_empty α] (f : α → β) :
  (∏ x : α, f x) = 1 :=
by rw [eq_empty_of_is_empty (univ : finset α), finset.prod_empty]

@[to_additive]
lemma prod_subsingleton {α β : Type*} [comm_monoid β] [subsingleton α] (f : α → β) (a : α) :
  (∏ x : α, f x) = f a :=
begin
  haveI : unique α := unique_of_subsingleton a,
  convert prod_unique f
end

@[to_additive]
lemma prod_subtype_mul_prod_subtype {α β : Type*} [fintype α] [comm_monoid β]
  (p : α → Prop) (f : α → β) [decidable_pred p] :
  (∏ (i : {x // p x}), f i) * (∏ i : {x // ¬ p x}, f i) = ∏ i, f i :=
begin
  classical,
  let s := {x | p x}.to_finset,
  rw [← finset.prod_subtype s, ← finset.prod_subtype sᶜ],
  { exact finset.prod_mul_prod_compl _ _ },
  { simp },
  { simp }
end

end fintype

namespace list

@[to_additive] lemma prod_to_finset {M : Type*} [decidable_eq α] [comm_monoid M]
  (f : α → M) : ∀ {l : list α} (hl : l.nodup), l.to_finset.prod f = (l.map f).prod
| [] _ := by simp
| (a :: l) hl := let ⟨not_mem, hl⟩ := list.nodup_cons.mp hl in
  by simp [finset.prod_insert (mt list.mem_to_finset.mp not_mem), prod_to_finset hl]

end list

namespace multiset

variables [decidable_eq α]

@[simp] lemma to_finset_sum_count_eq (s : multiset α) :
  (∑ a in s.to_finset, s.count a) = s.card :=
multiset.induction_on s rfl
  (assume a s ih,
    calc (∑ x in to_finset (a ::ₘ s), count x (a ::ₘ s)) =
      ∑ x in to_finset (a ::ₘ s), ((if x = a then 1 else 0) + count x s) :
        finset.sum_congr rfl $ λ _ _, by split_ifs;
        [simp only [h, count_cons_self, nat.one_add], simp only [count_cons_of_ne h, zero_add]]
      ... = card (a ::ₘ s) :
      begin
        by_cases a ∈ s.to_finset,
        { have : ∑ x in s.to_finset, ite (x = a) 1 0 = ∑ x in {a}, ite (x = a) 1 0,
          { rw [finset.sum_ite_eq', if_pos h, finset.sum_singleton, if_pos rfl], },
          rw [to_finset_cons, finset.insert_eq_of_mem h, finset.sum_add_distrib, ih, this,
            finset.sum_singleton, if_pos rfl, add_comm, card_cons] },
        { have ha : a ∉ s, by rwa mem_to_finset at h,
          have : ∑ x in to_finset s, ite (x = a) 1 0 = ∑ x in to_finset s, 0, from
            finset.sum_congr rfl (λ x hx, if_neg $ by rintro rfl; cc),
          rw [to_finset_cons, finset.sum_insert h, if_pos rfl, finset.sum_add_distrib, this,
            finset.sum_const_zero, ih, count_eq_zero_of_not_mem ha, zero_add, add_comm, card_cons] }
      end)

lemma count_sum' {s : finset β} {a : α} {f : β → multiset α} :
  count a (∑ x in s, f x) = ∑ x in s, count a (f x) :=
by { dunfold finset.sum, rw count_sum }

@[simp] lemma to_finset_sum_count_nsmul_eq (s : multiset α) :
  (∑ a in s.to_finset, s.count a • {a}) = s :=
begin
  apply ext', intro b,
  rw count_sum',
  have h : count b s = count b (count b s • {b}),
  { rw [count_nsmul, count_singleton_self, mul_one] },
  rw h, clear h,
  apply finset.sum_eq_single b,
  { intros c h hcb, rw count_nsmul, convert mul_zero (count c s),
    apply count_eq_zero.mpr, exact finset.not_mem_singleton.mpr (ne.symm hcb) },
  { intro hb, rw [count_eq_zero_of_not_mem (mt mem_to_finset.2 hb), count_nsmul, zero_mul]}
end

theorem exists_smul_of_dvd_count (s : multiset α) {k : ℕ}
  (h : ∀ (a : α), a ∈ s → k ∣ multiset.count a s) :
  ∃ (u : multiset α), s = k • u :=
begin
  use ∑ a in s.to_finset, (s.count a / k) • {a},
  have h₂ : ∑ (x : α) in s.to_finset, k • (count x s / k) • ({x} : multiset α) =
    ∑ (x : α) in s.to_finset, count x s • {x},
  { apply finset.sum_congr rfl,
    intros x hx,
    rw [← mul_nsmul, nat.mul_div_cancel' (h x (mem_to_finset.mp hx))] },
  rw [← finset.sum_nsmul, h₂, to_finset_sum_count_nsmul_eq]
end

end multiset

@[simp, norm_cast] lemma nat.cast_sum [add_comm_monoid β] [has_one β] (s : finset α) (f : α → ℕ) :
  ↑(∑ x in s, f x : ℕ) = (∑ x in s, (f x : β)) :=
(nat.cast_add_monoid_hom β).map_sum f s

@[simp, norm_cast] lemma int.cast_sum [add_comm_group β] [has_one β] (s : finset α) (f : α → ℤ) :
  ↑(∑ x in s, f x : ℤ) = (∑ x in s, (f x : β)) :=
(int.cast_add_hom β).map_sum f s

@[simp, norm_cast] lemma nat.cast_prod {R : Type*} [comm_semiring R] (f : α → ℕ) (s : finset α) :
  (↑∏ i in s, f i : R) = ∏ i in s, f i :=
(nat.cast_ring_hom R).map_prod _ _

@[simp, norm_cast] lemma int.cast_prod {R : Type*} [comm_ring R] (f : α → ℤ) (s : finset α) :
  (↑∏ i in s, f i : R) = ∏ i in s, f i :=
(int.cast_ring_hom R).map_prod _ _

@[simp, norm_cast] lemma units.coe_prod {M : Type*} [comm_monoid M] (f : α → units M)
  (s : finset α) : (↑∏ i in s, f i : M) = ∏ i in s, f i :=
(units.coe_hom M).map_prod _ _

lemma nat_abs_sum_le {ι : Type*} (s : finset ι) (f : ι → ℤ) :
  (∑ i in s, f i).nat_abs ≤ ∑ i in s, (f i).nat_abs :=
begin
  classical,
  apply finset.induction_on s,
  { simp only [finset.sum_empty, int.nat_abs_zero] },
  { intros i s his IH,
    simp only [his, finset.sum_insert, not_false_iff],
    exact (int.nat_abs_add_le _ _).trans (add_le_add le_rfl IH) }
end


@[simp]
theorem exists_prop {p q : Prop} : (∃ h : p, q) ↔ p ∧ q :=
Iff.intro (fun ⟨hp, hq⟩ => And.intro hp hq) (fun ⟨hp, hq⟩ => Exists.intro hp hq)

namespace Option

def get {α : Type u} : ∀ {o : Option α}, isSome o → α
| some x, h => x

@[simp] theorem isSome_none : @isSome α none = false := rfl
@[simp] theorem isSome_some {a : α} : isSome (some a) = true := rfl
@[simp] theorem get_some (x : α) (h : isSome (some x)) : Option.get h = x := rfl

theorem eq_some_iff_get_eq {o : Option α} {a : α} :
  o = some a ↔ ∃ h : o.isSome, Option.get h = a := by
  cases o; simp; intro h; cases h; contradiction
  simp [exists_prop]


import dismantlable

variables {V: Type} [fintype V] [inhabited V] [decidable_eq V] {c: V}

open classical
noncomputable theory

-- Induced subgraph generated by a vertex set S ⊆ V
def induced_subgraph (S: set V) (G: refl_graph V) : refl_graph {v:V// v ∈ S} :=
{ adj := λ a b, G.adj a b,
  sym :=  λ a b h, G.sym h,
  selfloop := begin intro a, apply G.selfloop end}

lemma ind_subgraph_is_induced {G: refl_graph V} : ∀ S: set V, ∀ v w : {v:V// v ∈ S}, G.adj v w ↔ (induced_subgraph S G).adj v w :=
begin
  intros S v w, split,
  intro Gadj, rw induced_subgraph, exact Gadj,
  intro Iadj, rw induced_subgraph at Iadj, exact Iadj,
end

-- Induced subgraph of one vertex removed
def ind_subgraph_one_vtx (v: V) (G: refl_graph V) : refl_graph {w : V // w ≠ v}
:= induced_subgraph (λ x, x ≠ v) G

-- v is the cornered vtx. cing_vtx is the vtx cornering v
def cing_vtx {v: V} {G: refl_graph V} (h: corner_vtx G v) :=
some h

-- a vertex can't corner itself
theorem cing_vtx_distinct {v: V} {G: refl_graph V} (h: corner_vtx G v) : cing_vtx h ≠ v :=
begin
  obtain ⟨hw1, hw2⟩ := (some_spec h),
  exact hw1
end

-- subset inclusion property of corners
theorem cing_vtx_nhds {v: V} {G: refl_graph V} (h: corner_vtx G v) : neighbor_set' G v ⊆ neighbor_set' G (cing_vtx h) :=
begin
  obtain ⟨hw1, hw2⟩ := (some_spec h),
  exact hw2
end

lemma cing_vtx_nhds_vtx {v: V} {G: refl_graph V} (h: corner_vtx G v) : ∀ w: V, G.adj v w → G.adj (cing_vtx h) w :=
begin
  obtain ⟨hw1, hw2⟩ := (some_spec h),
  intros w hw, conv at hw2 {congr, rw neighbor_set', skip, rw neighbor_set'},
  exact set.mem_of_subset_of_mem hw2 hw,
end

-- from type V to subtype {w: V // w ≠ v}, for cornering vtxs
def cing_vtx_subtype {v: V} {G: refl_graph V} (h: corner_vtx G v) : {w: V // w ≠ v}
:= ⟨cing_vtx h, cing_vtx_distinct h⟩

-- correctness of cing_vtx_subtype
theorem val_cing_vtx_subtype {v: V} {G: refl_graph V} (h: corner_vtx G v) : (cing_vtx_subtype h).val = cing_vtx h := rfl

-- from type V to subtype {w: V // w ≠ v}, for cornering vtxs
def not_corner_vtx_subtype (v: V) (G: refl_graph V) (h: v ≠ c) : {w: V // w ≠ c} := ⟨v,h⟩

def has_retract  (G: refl_graph V)  : Prop :=
∃ f: graph_hom G (ind_subgraph_one_vtx c G), ∀ v ≠ c, v = f.to_fun(v)

def retract_fun (G: refl_graph V) (h : corner_vtx G c) :
V → {w: V // w ≠ c} := λ v, if eq: v = c then cing_vtx_subtype h else ⟨v,eq⟩

--retract_fun works correctly
lemma retract_fun_works_pos_refl (G: refl_graph V) (h: corner_vtx G c) :
let H:= ind_subgraph_one_vtx c G in
H.adj (retract_fun G h c) (cing_vtx_subtype h) :=
begin
  intro H,
  suffices : retract_fun G h c = cing_vtx_subtype h,
  rw this, exact H.selfloop (cing_vtx_subtype h),
  rw retract_fun, simp,
end

lemma retract_fun_works_neg_refl (G: refl_graph V) (H:= ind_subgraph_one_vtx c G) (h: corner_vtx G c) :
∀ (v: V) (ne: v ≠ c), H.adj (retract_fun G h v) (not_corner_vtx_subtype v G ne) :=
begin
  intros v ne,
  suffices : retract_fun G h v = not_corner_vtx_subtype v G ne,
  rw this, exact H.selfloop (not_corner_vtx_subtype v G ne),
  rw retract_fun, simp, rw [dif_neg ne, not_corner_vtx_subtype],
end

-- retract_fun preserves edge relations
lemma retract_fun_works_pos_adj (G: refl_graph V) (h: corner_vtx G c) :
∀ (v: V) (adj: G.adj c v), (ind_subgraph_one_vtx c G).adj (retract_fun G  h c) (retract_fun G  h v) :=
begin
  intros v hyp, by_cases eq: v=c, rw eq, exact (ind_subgraph_one_vtx c G).selfloop (retract_fun G h c),
  rw retract_fun, simp, rw [dif_neg eq], rw cing_vtx_subtype,
  have adj : G.adj (cing_vtx h) v,
    exact cing_vtx_nhds_vtx h v hyp,
  rw ind_subgraph_one_vtx,
  exact (ind_subgraph_is_induced (λ (x : V), x ≠ c) ⟨cing_vtx h, _⟩ ⟨v, eq⟩).1 adj,
end

-- retract function is identity on non-corner vtxs
def retract_fn_noncorner_vtx (G: refl_graph V) (h: corner_vtx G c) : ∀ (v: {w // w ≠ c}), retract_fun G h ↑v = v :=
begin
  intro v, rw [retract_fun], simp, rw cing_vtx_subtype, intro eq,
  have neq : ↑ v ≠ c, exact v.2, exfalso, exact neq eq,
end

def retract_fn_noncorner_vtx_fn (G: refl_graph V) (h: corner_vtx G c) : function.equiv ((retract_fun G h) ∘ coe) (λ x, x) :=
begin
  rw function.equiv, exact retract_fn_noncorner_vtx G h,
end

--retract function is identity on lists and vectors as well
def retract_fn_noncorner_vtx_list (G: refl_graph V) (h: corner_vtx G c) : ∀ (v: list {w // w ≠ c}), list.map (retract_fun G h ∘ coe) v = v :=
begin
  intro v, induction v, simp,
  simp, split, exact retract_fn_noncorner_vtx G h v_hd, exact v_ih,
end

def retract_fn_noncorner_vtx_vect {n : ℕ } (G: refl_graph V) (h: corner_vtx G c) : ∀ (v: vector  {w // w ≠ c} n), vector.map (retract_fun G h ∘ coe) v = v :=
begin
  intro v, induction v, rw vector.map, simp, exact retract_fn_noncorner_vtx_list G h v_val,
end

def vec_map_comp {a b c: Type} {n : ℕ} (f: a → b) (g: b → c) : ∀ (v: vector a n), vector.map g (vector.map f v) = vector.map (g ∘ f) v :=
begin
  intro v, induction v, rw vector.map, rw vector.map, rw vector.map, simp,
end

lemma ind_subgraph_is_induced' {G: refl_graph V} (h: corner_vtx G c): ∀ v w : V, G.adj v w → (ind_subgraph_one_vtx c G).adj ((retract_fun G h) v) ((retract_fun G h) w) :=
begin
  intros v w,
  rw retract_fun, simp,
  by_cases v_eq : v=c, by_cases w_eq : w=c,
  rw [dif_pos v_eq, dif_pos w_eq, v_eq, w_eq], intro Gadj,
  exact (ind_subgraph_one_vtx c G).selfloop (cing_vtx_subtype h),
  rw [dif_pos v_eq, dif_neg w_eq, cing_vtx_subtype], intro Gadj, rw v_eq at Gadj,
  let nbors := cing_vtx_nhds_vtx h w Gadj,
  exact (ind_subgraph_is_induced (λ x, x ≠ c) ⟨cing_vtx h, _⟩ ⟨w, w_eq⟩).1 nbors,
  by_cases w_eq : w=c,
  rw [dif_neg v_eq, dif_pos w_eq, cing_vtx_subtype], intro Gadj, rw [w_eq, rgraph_adj_symm] at Gadj,
  let nbors := cing_vtx_nhds_vtx h v Gadj,
  let ind := (ind_subgraph_is_induced (λ x, x ≠ c) ⟨cing_vtx h, _⟩ ⟨v, v_eq⟩).1 nbors,
  exact rgraph_adj_symm.1 ind,
  rw [dif_neg v_eq, dif_neg w_eq],
  exact (ind_subgraph_is_induced (λ x, x ≠ c) ⟨v, v_eq⟩ ⟨w, w_eq⟩).1,
end

def corner_retract (G: refl_graph V) (h : corner_vtx G c): graph_hom G (ind_subgraph_one_vtx c G) :=
{ to_fun := retract_fun G h,
  map_edges :=
  begin
    let H := (ind_subgraph_one_vtx c G),
    intros v w adj, by_cases v_eq: v=c, by_cases w_eq: w = c,
    rw [v_eq, w_eq], exact H.selfloop (retract_fun G h c),
    rw v_eq, rw v_eq at adj, exact retract_fun_works_pos_adj G h w adj,
    by_cases w_eq: w=c,
    rw retract_fun, simp, rw [dif_neg v_eq, dif_pos w_eq, cing_vtx_subtype],
    rw [w_eq, rgraph_adj_symm] at adj,
    let cing_vtx_adj := cing_vtx_nhds_vtx h v adj,
    exact (ind_subgraph_is_induced (λ (x : V), x ≠ c) ⟨v, v_eq⟩ ⟨cing_vtx h, _⟩).1(rgraph_adj_symm.1 cing_vtx_adj),
    rw retract_fun, simp, rw [dif_neg v_eq, dif_neg w_eq],
    exact (ind_subgraph_is_induced (λ (x : V), x ≠ c) ⟨v, v_eq⟩ ⟨w, w_eq⟩).1 adj,
  end
}

-- goal: to prove that a retract H of a graph G has cop_number H ≤ cop_number G.
-- the standard proof method of this is to "simulate two games played on G and H where the cop strategy is the image_strat and the robber strategy on G is restricted to H."

-- The image strategy of a cop is a strategy played on induced_subgraph G c.
-- The idea is that the cop will behave the same way as he does on G, except when he is to move to c he will move to the cornering vtx instead. This is well-defined because the cornering vtx is adjacent to all the neighbors of c.

def image_strat_init {n: ℕ} (G: refl_graph V) (h: corner_vtx G c) (CS: cop_strat G n) : vector {w // w ≠ c} n := vector.map (corner_retract G h).to_fun CS.strat.init

def cr_pos_to_retract {n: ℕ} (G: refl_graph V) (h: corner_vtx G c) (s: vector V n × V) :  vector {w // w ≠ c} n × {w // w ≠ c} := (vector.map (corner_retract G h).to_fun s.1, (corner_retract G h).to_fun s.2)

def cr_pos_from_retract {n: ℕ} (G: refl_graph V)(h: corner_vtx G c) (s: vector {w // w ≠ c} n × {w // w ≠ c}) : vector V n × V  := (vector.map (λ t, ↑t) s.1, s.2)

def image_strat_fun {n: ℕ} (G: refl_graph V) (h: corner_vtx G c) (CS: cop_strat G n) : vector {w // w ≠ c} n × {w // w ≠ c} → vector {w // w ≠ c} n := λ s, vector.map (corner_retract G h).to_fun (CS.strat.strat (cr_pos_from_retract G h s))

def pre_image_strat {n: ℕ} (G: refl_graph V) (h: corner_vtx G c) (CS: cop_strat G n)
: pre_cop_strat (ind_subgraph_one_vtx c G) n :=
{ init := image_strat_init G h CS, strat := image_strat_fun G h CS}

-- Now we need to coerce a robber strategy on the induced subgraph to a robber strategy on the graph itself. The idea is to have the robber move as if they were still playing against a cop strategy on the induced subgraph.

def rob_coe_init_fn {n: ℕ} (G: refl_graph V) (h: corner_vtx G c) (RS: pre_rob_strat (ind_subgraph_one_vtx c G) n): vector V n → V :=
λ x, RS.strat.init (vector.map (corner_retract G h).to_fun x)

def rob_coe_init_fn_restr {n: ℕ} (G: refl_graph V) (h: corner_vtx G c) (RS: pre_rob_strat (ind_subgraph_one_vtx c G) n) : ∀ x, (rob_coe_init_fn G h RS) x ≠ c :=
begin
  intro x, rw rob_coe_init_fn, simp,
  exact (RS.strat.init (vector.map (corner_retract G h).to_fun x)).2,
end

def rob_coe_strat_fn {n: ℕ} (G: refl_graph V) (h: corner_vtx G c) (RS: rob_strat (ind_subgraph_one_vtx c G) n) : vector V n × V → V := λ s, RS.strat.strat (cr_pos_to_retract G h s)

def rob_coe_strat_fn_restr {n: ℕ} (G: refl_graph V) (h: corner_vtx G c) (RS: rob_strat (ind_subgraph_one_vtx c G) n) : ∀ s, (rob_coe_strat_fn G h RS) s ≠ c :=
begin
  intro s, rw rob_coe_strat_fn, simp,
  exact (RS.strat.strat (cr_pos_to_retract G h s)).2,
end

def pre_rob_coe_strat {n: ℕ} (G: refl_graph V) (h: corner_vtx G c) (RS: rob_strat (ind_subgraph_one_vtx c G) n) : pre_rob_strat G n :=
{ init := rob_coe_init_fn G h RS, strat := rob_coe_strat_fn G h RS}

-- rw image_strat_fun, simp,
--     have : capture (cr_pos_from_retract G h K),
--       rw capture, cases cap with i cap, use i, rw cr_pos_from_retract, simp,
--       by_contradiction, let nocap := subtype.ne_of_val_ne h, contradiction,
--     let G_nocheat := CS.cop_nocheat (cr_pos_from_retract G h K) this,
--     rw corner_retract, simp, rw G_nocheat, rw cr_pos_from_retract, simp,
--     let map_comp := vec_map_comp coe (retract_fun G h) K.1,
--     rw map_comp, exact retract_fn_noncorner_vtx_vect G h K.1,

def image_strat {n: ℕ} (G: refl_graph V) (h: corner_vtx G c) (CS: cop_strat G n)
: cop_strat (ind_subgraph_one_vtx c G) n :=
{ strat := pre_image_strat G h CS,
  nocheat :=
  begin
    intros RS i cap, conv {congr, congr, rw pre_image_strat}, simp,
    rw image_strat_fun, simp,
    set K := (pre_round (pre_image_strat G h CS) RS i),
    have : capture (cr_pos_from_retract G h K),
      rw capture, cases cap with i cap, use i, rw cr_pos_from_retract, simp, exact subtype.coe_inj.2 cap,
    let G_nocheat := CS.nocheat (pre_rob_coe_strat G h RS) i,
  end,
  cop_legal :=
  begin
    intros i v P, rw image_strat_fun, simp,
    let move := ((corner_retract G h).to_fun ((CS.cop_strat (cr_pos_from_retract G h (P, v))).nth i)),
    suffices : G.adj (P.nth i) move,
      exact (ind_subgraph_is_induced (λ (x : V), x ≠ c) (P.nth i) move).1 this,
    let G_legal := CS.cop_legal i v (vector.map (λ t, ↑t) P), simp at G_legal,
    let G_copmove := (CS.cop_strat (vector.map coe P, ↑v)).nth i,
    by_cases is_c : G_copmove = c, swap,
    have : ↑((corner_retract G h).to_fun G_copmove) = G_copmove,
      rw corner_retract, simp, rw retract_fun, simp, rw dif_neg is_c, refl,
    change G.adj ↑(P.nth i) G_copmove at G_legal, rw this.symm at G_legal, exact G_legal,
    have : ↑((corner_retract G h).to_fun G_copmove) = cing_vtx h,
      rw corner_retract, simp, rw retract_fun, simp, rw [dif_pos is_c, cing_vtx_subtype], simp,
    change G.adj ↑(P.nth i) G_copmove at G_legal, rw is_c at G_legal,
    let cing_adj := (cing_vtx_nhds_vtx h) ↑(P.nth i) (rgraph_adj_symm.1 G_legal),
    rw this.symm at cing_adj, exact rgraph_adj_symm.1 cing_adj,
  end,
}

-- coercing a robber strat on a graph with corner removed back to the original graph.
def rob_strat_coe {n: ℕ} (G: refl_graph V) (h: corner_vtx G c) (RS: rob_strat (ind_subgraph_one_vtx c G) n) : rob_strat G n :=
{
  rob_init := rob_coe_init_fn G RS h,
  rob_strat := rob_coe_strat_fn G RS h,
  rob_nocheat :=
  begin
    intros K cap, rw rob_coe_strat_fn, simp,
    have neqc: K.2 ≠ c, sorry,
    suffices : RS.rob_strat (cr_pos_to_retract G h K) = ⟨ K.snd, neqc⟩,
      exact subtype.ext_iff_val.1 this,
    exact RS.rob_nocheat (cr_pos_to_retract G h K),
  end,
  rob_legal :=
  begin
    intros v P, by_cases v=c, swap,
    rw [cr_pos_to_retract, corner_retract], simp,
    sorry, sorry,
  end
}

lemma cop_num_le_retract [inhabited {w : V// w ≠ c}] (G: refl_graph V) : let H := ind_subgraph_one_vtx c G in
corner_vtx G c → cop_number H ≤ cop_number G :=
begin
  intros H h,
  unfold cop_number,
  let n := Inf {k : ℕ | k_cop_win G k},
  suffices : k_cop_win H n, exact nat.Inf_le this,
  have n_win: k_cop_win G n, exact nat.Inf_mem (lots_of_cops G),
  rw k_cop_win at n_win, cases n_win with CS n_win,
  rw k_cop_win, use image_strat G h CS,
  rw winning_strat_cop, intro RS,
  rw winning_strat_cop at n_win, specialize n_win (rob_strat_coe G h RS),
  cases n_win with m cap, use m, cases m,
  -- base case
  rw [round, rob_strat_coe] at cap, simp at cap,
  rw capture at cap, cases cap with i cap, simp at cap,
  have no_cap_at_c : CS.cop_init.nth i ≠ c,
    let x := rob_coe_init_fn_restr G RS h CS.cop_init, rw cap.symm at x, exact x,
  rw [round, capture], use i, simp, rw subtype.ext_iff, rw rob_coe_init_fn at cap, simp at cap, conv {congr, skip, rw image_strat,}, simp, rw image_strat_init, rw cap.symm,
  rw image_strat, simp, rw image_strat_init, simp, rw corner_retract, simp, rw retract_fun, simp, rw dif_neg no_cap_at_c, refl,
  -- inductive case, must case on parity of round
  sorry,
end

-- how to circumvent assuming that subtype is inhabited
lemma cwg_retract_is_cw [inhabited {w : V// w ≠ c}] ( G: refl_graph V) : let H := ind_subgraph_one_vtx c G in
corner_vtx G c →  cop_win_graph G → cop_win_graph H :=
begin
  intros H corner cw,
  rw cop_win_graph at cw,
  let leq := cop_num_le_retract G corner, rw cw at leq,
  have : 0 < cop_number (ind_subgraph_one_vtx c G) ,
    exact zero_cops_cant_win (ind_subgraph_one_vtx c G),
  rw cop_win_graph, linarith,
end

def dismantling_order (G: refl_graph V) : list V → Prop
| [] := G ≅ singleton_graph
| (a::L) := (corner_vtx G a) ∧ dismantling_order L

def dismantlable_graph (G: refl_graph V) := ∃ L, dismantling_order G L


/-
  Spec(R) is quasi-compact.

  https://stacks.math.columbia.edu/tag/00E8
-/

import topology.basic
import linear_algebra.basic
import linear_algebra.finsupp
import to_mathlib.opens
import to_mathlib.ideals
import sheaves.covering.covering
import sheaves.covering.covering_on_standard_basis
import sheaves.sheaf_on_standard_basis
import spectrum_of_a_ring.standard_basis
import spectrum_of_a_ring.induced_continuous_map
import spectrum_of_a_ring.induced_homeomorphism
import spectrum_of_a_ring.structure_presheaf
import spectrum_of_a_ring.structure_presheaf_localization

noncomputable theory

local attribute [instance] classical.prop_decidable

universe u

open topological_space lattice classical localization localization_alt

variables {α : Type u} [comm_ring α]

section refinement

local attribute [instance] classical.prop_decidable

parameters (X : Type u) [T : topological_space X]
parameters (B : set (opens X)) [HB : opens.is_basis B]

include T HB

lemma refine_cover_with_basis (OC : covering opens.univ)
: ∃ (D : set (opens X)),
    (D ⊆ B)
  ∧ (∀ V ∈ D, ∃ i, V ⊆ OC.Uis i)
  ∧ (Sup D = opens.univ) :=
begin
  existsi [λ V, V ∈ B ∧ ∃ i : OC.γ, V ⊆ OC.Uis i],
  refine ⟨_, _, _⟩,
  { intros U HU,
    exact HU.1, },
  { intros V HV,
    exact HV.2, },
  { apply opens.ext,
    apply set.ext,
    intros x,
    split,
    { intros Hx,
      simp [opens.univ], },
    { intros Hx,
      rw ←OC.Hcov at Hx,
      rcases Hx with ⟨U, HU, HxU⟩,
      rcases HU with ⟨OU, HOU, HOUval⟩,
      rcases HOU with ⟨i, HOU⟩,
      rw ←HOUval at HxU,
      have HU' := opens.is_basis_iff_nbhd.1 HB HxU,
      rcases HU' with ⟨U', ⟨BU', HxU', HU'OU⟩⟩,
      use U',
      simp,
      refine ⟨⟨_, _⟩, _⟩,
      { exact U'.2, },
      { rw ←HOU at HU'OU,
        exact ⟨BU', ⟨i, HU'OU⟩⟩, },
      { exact HxU', } } }
end

end refinement

-- A cover by basis elements has a finite subcover.

section quasi_compact

variables (R : Type u) [comm_ring R]

lemma D_fs_quasi_compact :
∀ S : set R, ⋃₀ (Spec.D' '' S) = Spec.univ R →
∃ F ⊆ S,
    set.finite F
  ∧ ⋃₀ (Spec.D' '' F) = Spec.univ R :=
begin
  rintros S HScov,
  -- We get that V(S) = ∅.
  have HVS : Spec.V S = ∅,
    rw Spec.D'.union at HScov,
    rw ←set.compl_compl (Spec.V S),
    rw HScov,
    exact set.compl_univ,
  rw Spec.V.set_eq_span at HVS,
  -- It follows that (S) = R.
  have HST := (Spec.V.empty_iff_ideal_top _).1 HVS,
  have Hone : (1 : R) ∈ ideal.span S := by simp [HST],
  -- Deduce that 1 = Σrᵢfᵢ for some {f₁, ..., fₙ}.
  have Hlc := ideal.mem_span_iff_total Hone,
  rcases Hlc with ⟨lc, Hlc, H⟩,
  have Hfs := (finsupp.mem_supported _ _).1 Hlc,
  use ↑lc.support,
  refine ⟨_, ⟨_, _⟩⟩,
  { -- {f₁, ..., fₙ} ⊆ S.
    exact Hfs, },
  { -- Prove it's finite.
    apply set.finite_mem_finset, },
  { -- ⋃ D(fᵢ) = Spec(R)
    rw Spec.D'.union,
    simp [Spec.univ],
    rw ←set.compl_empty,
    congr,
    rw Spec.V.set_eq_span,
    erw Spec.V.empty_iff_ideal_top,
    suffices Hsuff : (1:R) ∈ ideal.span (↑(lc.support) : set R),
      rw ((ideal.eq_top_iff_one _).2 Hsuff),
    rw finsupp.total_apply at H,
    rw ←H,
    simp [finsupp.sum],
    apply ideal.span_mem_finset, }
end

lemma D_fs.subset : ∀ {D}, D ⊆ D_fs R → ∃ S, (Spec.DO R '' S) = D :=
begin
  intros D HD,
  use {f : R | ∃ U : opens (Spec R), U ∈ D ∧ U.1 = Spec.D' f },
  apply set.ext,
  intros x,
  split,
  { intros Hx,
    rcases Hx with ⟨f, ⟨Hf, Hx⟩⟩,
    rcases Hf with ⟨Df, ⟨HDf, HDfval⟩⟩,
    rw ←Hx,
    have Heq : Df = Spec.DO R f,
      apply opens.ext,
      exact HDfval,
    rw ←Heq,
    exact HDf, },
  { intros Hx,
    have HxD := HD Hx,
    rcases HxD with ⟨f, Hf⟩,
    simp,
    use [f, x],
    { exact ⟨Hx, by rw Hf; simp [Spec.DO]⟩, },
    { exact Hf.symm, } }
end

lemma Spec.DO.val_eq_D' : subtype.val ∘ Spec.DO R = Spec.D' :=
begin
  rw function.funext_iff,
  intros f,
  simp [Spec.DO],
end

lemma Spec.quasi_compact.aux : compact (Spec.univ R) :=
begin
  rw compact_iff_finite_subcover,
  intros C HC Hcov,
  replace Hcov := set.subset.antisymm Hcov (λ x Hx, trivial),
  let OC := covering.from_cover (@opens.univ (Spec R) _) C HC Hcov,
  have BDfs : opens.is_basis (D_fs R) := D_fs_basis R,
  have BC := @refine_cover_with_basis (Spec R) _ (D_fs R) BDfs OC,
  rcases BC with ⟨D, ⟨BD, HDUi, HUD⟩⟩,
  have HS := D_fs.subset R BD,
  rcases HS with ⟨S, HS⟩,
  rw ←HS at HUD,
  replace HUD := subtype.ext.1 HUD,
  rw opens.Sup_s at HUD,
  rw ←set.image_comp at HUD,
  rw Spec.DO.val_eq_D' at HUD,
  have HF := D_fs_quasi_compact R S HUD,
  rcases HF with ⟨F, HFS, ⟨HFfin, HFcov⟩⟩,
  have HUD : ∀ {U}, U ∈ Spec.DO R '' F → U ∈ D,
    intros U HU,
    rcases HU with ⟨f, ⟨Hf, HU⟩⟩,
    replace Hf := HFS Hf,
    rw ←HS,
    exact ⟨f, ⟨Hf, HU⟩⟩,
  let Fisaux : ∀ {U}, U ∈ (Spec.DO R '' F) → set (Spec R) :=
    λ U HU, (OC.Uis (classical.some (HDUi U (HUD HU)))).1,
  let Finsprop := λ U HU, classical.some_spec (HDUi U (HUD HU)),
  let Fis : { f // f ∈ F } → set (Spec R) :=
    λ U, Fisaux ⟨U, ⟨U.2, rfl⟩⟩,
  use [set.range Fis],
  have HFis : set.range Fis ⊆ C,
    intros U HU,
    rcases HU with ⟨f, Hf⟩,
    rw ←Hf,
    simp [Fis],
    apply covering.from_cover.Uis,
  use [HFis],
  split,
  { constructor,
    replace HFfin := set.finite.fintype HFfin,
    apply @set.fintype_range _ _ _ Fis HFfin, },
  { intros x Hx,
    have Hx' := Hx,
    have HUis : (⋃OC.Uis).val = Spec.univ R := (subtype.ext.1 OC.Hcov),
    rw ←HFcov at Hx,
    rcases Hx with ⟨U, ⟨⟨f, ⟨Hf, HDf⟩⟩, HxU⟩⟩,
    rw ←HDf at HxU,
    use [Fis ⟨f, Hf⟩],
    use [⟨f, Hf⟩],
    have HDfUi := Finsprop ⟨Spec.D' f, D_fs_open R f⟩ ⟨f, ⟨Hf, rfl⟩⟩,
    simp [Fis],
    exact HDfUi HxU, },
end

lemma Spec.compact : compact_space (Spec R) :=
begin
  constructor,
  apply Spec.quasi_compact.aux,
end

-- This is what we really need.

-- D(f) = ⋃i=1,..,n D(gi)

lemma lemma_standard_open
{U : opens (Spec R)} (BU : U ∈ D_fs R) (OC : covering_standard_basis (D_fs R) (Spec.DO R (some BU)))
: ∃ (γf : Type u) (Hf : fintype γf) (ρ : γf → OC.γ),
Spec.DO R (some BU) ⊆ ⋃ (λ i, Spec.DO R (some (OC.BUis (ρ i)))) :=
begin
  let f := some BU,
  let Rf := localization R (S U),
  have Hf : U.1 = Spec.D' f,
    rw some_spec BU,
    simp [f, Spec.DO],
  have HOCUis : ∀ i, OC.Uis i = Spec.DO R (some (OC.BUis i)),
      intros i,
      rw ←some_spec (OC.BUis i),

  have HRf : is_localization_data (powers f) (localization.of : R → Rf)
     := structure_presheaf.localization BU,
  let g : R → Rf := of,
  let φ : Spec Rf → Spec R := Zariski.induced g,
  have Hcompact := Spec.quasi_compact.aux Rf,

  have HcompactDf : compact (Spec.D' f),
    rw ←phi_image_Df HRf,
    exact compact_image Hcompact (Zariski.induced.continuous g),

  let Uis : set (set (Spec R)) := set.range (subtype.val ∘ OC.Uis),
  have OUis : ∀ (t : set (Spec R)), t ∈ Uis → is_open t,
    intros t Ht,
    rcases Ht with ⟨i, Ht⟩,
    rw ←Ht,
    simp,
    exact (OC.Uis i).2,
  have HUis : ⋃₀ Uis = (⋃ OC.Uis).val,
    simp,
    apply set.ext,
    intros x,
    split,
    { rintros ⟨Ui, ⟨⟨i, HUi⟩, HxUi⟩⟩,
      exact ⟨Ui, ⟨OC.Uis i, ⟨⟨i, rfl⟩, HUi⟩⟩, HxUi⟩, },
    { rintros ⟨Ui, ⟨OUi, ⟨⟨i, HOUi⟩, HUi⟩⟩, HxUi⟩,
      rw ←HOUi at HUi,
      exact ⟨Ui, ⟨⟨i, HUi⟩, HxUi⟩⟩, },
  have HDfUis : Spec.D' f ⊆ ⋃₀ Uis,
    rw [HUis, OC.Hcov],
    simp [f, Spec.DO, set.subset.refl],
  have Hfincov
    := @compact_elim_finite_subcover (Spec R) _ (Spec.D' f) Uis HcompactDf OUis HDfUis,

  rcases Hfincov with ⟨Uis', HUis', ⟨HfinUis', Hfincov⟩⟩,

  have HUis'fintype := set.finite.fintype HfinUis',
  let ρ : Uis' → OC.γ := λ V, some (HUis' V.2),
  use [Uis', HUis'fintype, ρ],

  intros x Hx,
  dsimp only [Spec.DO] at Hx,
  replace Hx := Hfincov Hx,
  rcases Hx with ⟨Ui, ⟨HUi', HxUi⟩⟩,
  use Ui,
  have HUi : Ui ∈ subtype.val '' set.range (λ (i : Uis'), Spec.DO R (some (OC.BUis (ρ i)))),
    use [OC.Uis (ρ ⟨Ui, HUi'⟩)],
    split,
    { use ⟨Ui, HUi'⟩,
      dsimp [ρ],
      rw ←HOCUis (ρ ⟨Ui, HUi'⟩), },
    { exact some_spec (HUis' HUi'), },
  use HUi,
  exact HxUi,
end

theorem structure_presheaf_on_basis_is_compact
: sheaf_on_standard_basis.basis_is_compact (D_fs_standard_basis R) :=
begin
  rintros U BU ⟨⟨γ, Uis, Hcov⟩, BUis⟩,
  dsimp only [subtype.coe_mk] at *,
  rw some_spec BU at Hcov,
  rcases (lemma_standard_open R BU ⟨⟨Uis, Hcov⟩, BUis⟩) with ⟨γf, Hγf, ρ, H⟩,
  use [γf, Hγf, ρ],
  apply le_antisymm,
  { intros x Hx,
    rcases Hx with ⟨Ui, ⟨⟨OUi, ⟨⟨i, Hi⟩, HUival⟩⟩, HxUi⟩⟩,
    dsimp at Hi,
    rw ←some_spec BU at Hcov,
    rw ←Hcov,
    rw ←Hi at HUival,
    use [Ui, ⟨Uis (ρ i), ⟨⟨ρ i, rfl⟩, HUival⟩⟩, HxUi], },
  { have HUis : Uis = λ i, Spec.DO R (some (BUis i)),
      apply funext,
      intros i,
      rw ←some_spec (BUis i),
    rw HUis,
    dsimp [function.comp],
    rw some_spec BU,
    exact H, },
end

end quasi_compact


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

! This file was ported from Lean 3 source module algebra.homology.homology
! leanprover-community/mathlib commit 618ea3d5c99240cd7000d8376924906a148bf9ff
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Homology.ImageToKernel
import Mathbin.Algebra.Homology.HomologicalComplex
import Mathbin.CategoryTheory.GradedObject

/-!
# The homology of a complex

Given `C : homological_complex V c`, we have `C.cycles i` and `C.boundaries i`,
both defined as subobjects of `C.X i`.

We show these are functorial with respect to chain maps,
as `C.cycles_map f i` and `C.boundaries_map f i`.

As a consequence we construct `homology_functor i : homological_complex V c ⥤ V`,
computing the `i`-th homology.
-/

universe v u

open CategoryTheory CategoryTheory.Limits

variable {ι : Type _}

variable {V : Type u} [Category.{v} V] [HasZeroMorphisms V]

variable {c : ComplexShape ι} (C : HomologicalComplex V c)

open Classical ZeroObject

noncomputable section

namespace HomologicalComplex

section Cycles

variable [HasKernels V]

/-- The cycles at index `i`, as a subobject. -/
abbrev cycles (i : ι) : Subobject (C.pt i) :=
  kernelSubobject (C.dFrom i)
#align homological_complex.cycles HomologicalComplex.cycles

theorem cycles_eq_kernelSubobject {i j : ι} (r : c.Rel i j) :
    C.cycles i = kernelSubobject (C.d i j) :=
  C.kernel_from_eq_kernel r
#align homological_complex.cycles_eq_kernel_subobject HomologicalComplex.cycles_eq_kernelSubobject

/-- The underlying object of `C.cycles i` is isomorphic to `kernel (C.d i j)`,
for any `j` such that `rel i j`.
-/
def cyclesIsoKernel {i j : ι} (r : c.Rel i j) : (C.cycles i : V) ≅ kernel (C.d i j) :=
  Subobject.isoOfEq _ _ (C.cycles_eq_kernelSubobject r) ≪≫ kernelSubobjectIso (C.d i j)
#align homological_complex.cycles_iso_kernel HomologicalComplex.cyclesIsoKernel

theorem cycles_eq_top {i} (h : ¬c.Rel i (c.next i)) : C.cycles i = ⊤ :=
  by
  rw [eq_top_iff]
  apply le_kernel_subobject
  rw [C.d_from_eq_zero h, comp_zero]
#align homological_complex.cycles_eq_top HomologicalComplex.cycles_eq_top

end Cycles

section Boundaries

variable [HasImages V]

/-- The boundaries at index `i`, as a subobject. -/
abbrev boundaries (C : HomologicalComplex V c) (j : ι) : Subobject (C.pt j) :=
  imageSubobject (C.dTo j)
#align homological_complex.boundaries HomologicalComplex.boundaries

theorem boundaries_eq_imageSubobject [HasEqualizers V] {i j : ι} (r : c.Rel i j) :
    C.boundaries j = imageSubobject (C.d i j) :=
  C.image_to_eq_image r
#align homological_complex.boundaries_eq_image_subobject HomologicalComplex.boundaries_eq_imageSubobject

/-- The underlying object of `C.boundaries j` is isomorphic to `image (C.d i j)`,
for any `i` such that `rel i j`.
-/
def boundariesIsoImage [HasEqualizers V] {i j : ι} (r : c.Rel i j) :
    (C.boundaries j : V) ≅ image (C.d i j) :=
  Subobject.isoOfEq _ _ (C.boundaries_eq_imageSubobject r) ≪≫ imageSubobjectIso (C.d i j)
#align homological_complex.boundaries_iso_image HomologicalComplex.boundariesIsoImage

theorem boundaries_eq_bot [HasZeroObject V] {j} (h : ¬c.Rel (c.prev j) j) : C.boundaries j = ⊥ :=
  by
  rw [eq_bot_iff]
  refine' image_subobject_le _ 0 _
  rw [C.d_to_eq_zero h, zero_comp]
#align homological_complex.boundaries_eq_bot HomologicalComplex.boundaries_eq_bot

end Boundaries

section

variable [HasKernels V] [HasImages V]

theorem boundaries_le_cycles (C : HomologicalComplex V c) (i : ι) : C.boundaries i ≤ C.cycles i :=
  image_le_kernel _ _ (C.dTo_comp_dFrom i)
#align homological_complex.boundaries_le_cycles HomologicalComplex.boundaries_le_cycles

/-- The canonical map from `boundaries i` to `cycles i`.
-/
abbrev boundariesToCycles (C : HomologicalComplex V c) (i : ι) :
    (C.boundaries i : V) ⟶ (C.cycles i : V) :=
  imageToKernel _ _ (C.dTo_comp_dFrom i)
#align homological_complex.boundaries_to_cycles HomologicalComplex.boundariesToCycles

/-- Prefer `boundaries_to_cycles`. -/
@[simp]
theorem image_to_kernel_as_boundariesToCycles (C : HomologicalComplex V c) (i : ι) (h) :
    (C.boundaries i).of_le (C.cycles i) h = C.boundariesToCycles i :=
  rfl
#align homological_complex.image_to_kernel_as_boundaries_to_cycles HomologicalComplex.image_to_kernel_as_boundariesToCycles

variable [HasCokernels V]

/-- The homology of a complex at index `i`.
-/
abbrev homology (C : HomologicalComplex V c) (i : ι) : V :=
  homology (C.dTo i) (C.dFrom i) (C.dTo_comp_dFrom i)
#align homological_complex.homology HomologicalComplex.homology

/-- The `j`th homology of a homological complex (as kernel of 'the differential from `Cⱼ`' modulo
the image of 'the differential to `Cⱼ`') is isomorphic to the kernel of `d : Cⱼ → Cₖ` modulo
the image of `d : Cᵢ → Cⱼ` when `rel i j` and `rel j k`. -/
def homologyIso (C : HomologicalComplex V c) {i j k : ι} (hij : c.Rel i j) (hjk : c.Rel j k) :
    C.homology j ≅ homology (C.d i j) (C.d j k) (C.d_comp_d i j k) :=
  homology.mapIso _ _
    (Arrow.isoMk (C.xPrevIso hij) (Iso.refl _) <| by dsimp <;> rw [C.d_to_eq hij, category.comp_id])
    (Arrow.isoMk (Iso.refl _) (C.xNextIso hjk) <| by
      dsimp <;> rw [C.d_from_comp_X_next_iso hjk, category.id_comp])
    rfl
#align homological_complex.homology_iso HomologicalComplex.homologyIso

end

end HomologicalComplex

/-- The 0th homology of a chain complex is isomorphic to the cokernel of `d : C₁ ⟶ C₀`. -/
def ChainComplex.homologyZeroIso [HasKernels V] [HasImages V] [HasCokernels V]
    (C : ChainComplex V ℕ) [Epi (factorThruImage (C.d 1 0))] : C.homology 0 ≅ cokernel (C.d 1 0) :=
  (homology.mapIso _ _
        (Arrow.isoMk (C.xPrevIso rfl) (Iso.refl _) <| by
            rw [C.d_to_eq rfl] <;> exact (category.comp_id _).symm :
          Arrow.mk (C.dTo 0) ≅ Arrow.mk (C.d 1 0))
        (Arrow.isoMk (Iso.refl _) (Iso.refl _) <| by
            simp [C.d_from_eq_zero fun h : _ = _ =>
                one_ne_zero <| by rwa [ChainComplex.next_nat_zero] at h] :
          Arrow.mk (C.dFrom 0) ≅ Arrow.mk 0)
        rfl).trans <|
    homologyOfZeroRight _
#align chain_complex.homology_zero_iso ChainComplex.homologyZeroIso

/-- The 0th cohomology of a cochain complex is isomorphic to the kernel of `d : C₀ → C₁`. -/
def CochainComplex.homologyZeroIso [HasZeroObject V] [HasKernels V] [HasImages V] [HasCokernels V]
    (C : CochainComplex V ℕ) : C.homology 0 ≅ kernel (C.d 0 1) :=
  (homology.mapIso _ _
          (Arrow.isoMk (C.xPrevIsoSelf (by rw [CochainComplex.prev_nat_zero] <;> exact one_ne_zero))
              (Iso.refl _) (by simp) :
            Arrow.mk (C.dTo 0) ≅ Arrow.mk 0)
          (Arrow.isoMk (Iso.refl _) (C.xNextIso rfl) (by simp) :
            Arrow.mk (C.dFrom 0) ≅ Arrow.mk (C.d 0 1)) <|
        by simpa).trans <|
    homologyOfZeroLeft _
#align cochain_complex.homology_zero_iso CochainComplex.homologyZeroIso

/-- The `n + 1`th homology of a chain complex (as kernel of 'the differential from `Cₙ₊₁`' modulo
the image of 'the differential to `Cₙ₊₁`') is isomorphic to the kernel of `d : Cₙ₊₁ → Cₙ` modulo
the image of `d : Cₙ₊₂ → Cₙ₊₁`. -/
def ChainComplex.homologySuccIso [HasKernels V] [HasImages V] [HasCokernels V]
    (C : ChainComplex V ℕ) (n : ℕ) :
    C.homology (n + 1) ≅ homology (C.d (n + 2) (n + 1)) (C.d (n + 1) n) (C.d_comp_d _ _ _) :=
  C.homologyIso rfl rfl
#align chain_complex.homology_succ_iso ChainComplex.homologySuccIso

/-- The `n + 1`th cohomology of a cochain complex (as kernel of 'the differential from `Cₙ₊₁`'
modulo the image of 'the differential to `Cₙ₊₁`') is isomorphic to the kernel of `d : Cₙ₊₁ → Cₙ₊₂`
modulo the image of `d : Cₙ → Cₙ₊₁`. -/
def CochainComplex.homologySuccIso [HasKernels V] [HasImages V] [HasCokernels V]
    (C : CochainComplex V ℕ) (n : ℕ) :
    C.homology (n + 1) ≅ homology (C.d n (n + 1)) (C.d (n + 1) (n + 2)) (C.d_comp_d _ _ _) :=
  C.homologyIso rfl rfl
#align cochain_complex.homology_succ_iso CochainComplex.homologySuccIso

open HomologicalComplex

/-! Computing the cycles is functorial. -/

section

variable [HasKernels V]

variable {C₁ C₂ C₃ : HomologicalComplex V c} (f : C₁ ⟶ C₂)

/-- The morphism between cycles induced by a chain map.
-/
abbrev cyclesMap (f : C₁ ⟶ C₂) (i : ι) : (C₁.cycles i : V) ⟶ (C₂.cycles i : V) :=
  Subobject.factorThru _ ((C₁.cycles i).arrow ≫ f.f i) (kernelSubobject_factors _ _ (by simp))
#align cycles_map cyclesMap

@[simp, reassoc.1, elementwise]
theorem cyclesMap_arrow (f : C₁ ⟶ C₂) (i : ι) :
    cyclesMap f i ≫ (C₂.cycles i).arrow = (C₁.cycles i).arrow ≫ f.f i := by simp
#align cycles_map_arrow cyclesMap_arrow

@[simp]
theorem cyclesMap_id (i : ι) : cyclesMap (𝟙 C₁) i = 𝟙 _ :=
  by
  dsimp only [cyclesMap]
  simp
#align cycles_map_id cyclesMap_id

@[simp]
theorem cyclesMap_comp (f : C₁ ⟶ C₂) (g : C₂ ⟶ C₃) (i : ι) :
    cyclesMap (f ≫ g) i = cyclesMap f i ≫ cyclesMap g i :=
  by
  dsimp only [cyclesMap]
  simp [subobject.factor_thru_right]
#align cycles_map_comp cyclesMap_comp

variable (V c)

/-- Cycles as a functor. -/
@[simps]
def cyclesFunctor (i : ι) : HomologicalComplex V c ⥤ V
    where
  obj C := C.cycles i
  map C₁ C₂ f := cyclesMap f i
#align cycles_functor cyclesFunctor

end

/-! Computing the boundaries is functorial. -/

section

variable [HasImages V] [HasImageMaps V]

variable {C₁ C₂ C₃ : HomologicalComplex V c} (f : C₁ ⟶ C₂)

/-- The morphism between boundaries induced by a chain map.
-/
abbrev boundariesMap (f : C₁ ⟶ C₂) (i : ι) : (C₁.boundaries i : V) ⟶ (C₂.boundaries i : V) :=
  imageSubobjectMap (f.sqTo i)
#align boundaries_map boundariesMap

variable (V c)

/-- Boundaries as a functor. -/
@[simps]
def boundariesFunctor (i : ι) : HomologicalComplex V c ⥤ V
    where
  obj C := C.boundaries i
  map C₁ C₂ f := imageSubobjectMap (f.sqTo i)
#align boundaries_functor boundariesFunctor

end

section

/-! The `boundaries_to_cycles` morphisms are natural. -/

variable [HasEqualizers V] [HasImages V] [HasImageMaps V]

variable {C₁ C₂ : HomologicalComplex V c} (f : C₁ ⟶ C₂)

@[simp, reassoc.1]
theorem boundariesToCycles_naturality (i : ι) :
    boundariesMap f i ≫ C₂.boundariesToCycles i = C₁.boundariesToCycles i ≫ cyclesMap f i :=
  by
  ext
  simp
#align boundaries_to_cycles_naturality boundariesToCycles_naturality

variable (V c)

/-- The natural transformation from the boundaries functor to the cycles functor. -/
@[simps]
def boundariesToCyclesNatTrans (i : ι) : boundariesFunctor V c i ⟶ cyclesFunctor V c i
    where
  app C := C.boundariesToCycles i
  naturality' C₁ C₂ f := boundariesToCycles_naturality f i
#align boundaries_to_cycles_nat_trans boundariesToCyclesNatTrans

/-- The `i`-th homology, as a functor to `V`. -/
@[simps]
def homologyFunctor [HasCokernels V] (i : ι) : HomologicalComplex V c ⥤ V
    where
  -- It would be nice if we could just write
  -- `cokernel (boundaries_to_cycles_nat_trans V c i)`
  -- here, but universe implementation details get in the way...
  obj C := C.homology i
  map C₁ C₂ f := homology.map _ _ (f.sqTo i) (f.sqFrom i) rfl
  map_id' := by
    intros ; ext1
    simp only [homology.π_map, kernel_subobject_map_id, hom.sq_from_id, category.id_comp,
      category.comp_id]
  map_comp' := by
    intros ; ext1
    simp only [hom.sq_from_comp, kernel_subobject_map_comp, homology.π_map_assoc, homology.π_map,
      category.assoc]
#align homology_functor homologyFunctor

/-- The homology functor from `ι`-indexed complexes to `ι`-graded objects in `V`. -/
@[simps]
def gradedHomologyFunctor [HasCokernels V] : HomologicalComplex V c ⥤ GradedObject ι V
    where
  obj C i := C.homology i
  map C C' f i := (homologyFunctor V c i).map f
  map_id' := by
    intros ; ext
    simp only [pi.id_apply, homology.π_map, homologyFunctor_map, kernel_subobject_map_id,
      hom.sq_from_id, category.id_comp, category.comp_id]
  map_comp' := by
    intros ; ext
    simp only [hom.sq_from_comp, kernel_subobject_map_comp, homology.π_map_assoc, pi.comp_apply,
      homology.π_map, homologyFunctor_map, category.assoc]
#align graded_homology_functor gradedHomologyFunctor

end


/-
Copyright (c) 2022 Henrik Böving. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Henrik Böving
-/
namespace Cpdt
namespace Chapter8

inductive IList (α : Type) : Nat → Type where
  | nil : IList α 0
  | cons : α → IList α n → IList α n.succ

namespace IList

def append : IList α n → IList α m → IList α (m + n)
  | nil, ys => ys
  | cons x xs, ys => cons x (append xs ys)

def inject : (xs : List α) → (IList α xs.length)
  | [] => nil
  | x :: xs => cons x (inject xs)

def unject : (xs : IList α n) → {ys : List α // ys.length = n}
  | nil => ⟨[], rfl⟩
  | cons x xs =>
    let ⟨rest, prop⟩ := unject xs
    ⟨x :: rest, by simp [prop]⟩

theorem inject_unject_inv : (unject (inject xs)).val = xs := by
  induction xs <;> simp_all[unject, inject]

def head : IList α (Nat.succ n) → α
  | cons x xs => x

end IList
end Chapter8
end Cpdt