/-
Copyright (c) 2018 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Kenny Lau
-/
import algebra.module.pi
import algebra.big_operators.basic
import data.set.finite
import group_theory.submonoid.basic

/-!
# Dependent functions with finite support

For a non-dependent version see `data/finsupp.lean`.
-/

universes u u₁ u₂ v v₁ v₂ v₃ w x y l

open_locale big_operators

variables (ι : Type u) (β : ι → Type v) {β₁ : ι → Type v₁} {β₂ : ι → Type v₂}

namespace dfinsupp

variable [Π i, has_zero (β i)]

structure pre : Type (max u v) :=
(to_fun : Π i, β i)
(pre_support : multiset ι)
(zero : ∀ i, i ∈ pre_support ∨ to_fun i = 0)

instance inhabited_pre : inhabited (pre ι β) :=
⟨⟨λ i, 0, ∅, λ i, or.inr rfl⟩⟩

instance : setoid (pre ι β) :=
{ r := λ x y, ∀ i, x.to_fun i = y.to_fun i,
  iseqv := ⟨λ f i, rfl, λ f g H i, (H i).symm,
    λ f g h H1 H2 i, (H1 i).trans (H2 i)⟩ }

end dfinsupp

variable {ι}
/-- A dependent function `Π i, β i` with finite support. -/
@[reducible]
def dfinsupp [Π i, has_zero (β i)] : Type* :=
quotient (dfinsupp.pre.setoid ι β)
variable {β}

notation `Π₀` binders `, ` r:(scoped f, dfinsupp f) := r
infix ` →ₚ `:25 := dfinsupp

namespace dfinsupp

section basic
variables [Π i, has_zero (β i)] [Π i, has_zero (β₁ i)] [Π i, has_zero (β₂ i)]

instance : has_coe_to_fun (Π₀ i, β i) :=
⟨λ _, Π i, β i, λ f, quotient.lift_on f pre.to_fun $ λ _ _, funext⟩

instance : has_zero (Π₀ i, β i) := ⟨⟦⟨0, ∅, λ i, or.inr rfl⟩⟧⟩
instance : inhabited (Π₀ i, β i) := ⟨0⟩

@[simp] lemma coe_zero : ⇑(0 : Π₀ i, β i) = 0 := rfl
lemma zero_apply (i : ι) : (0 : Π₀ i, β i) i = 0 := rfl

lemma coe_fn_injective : @function.injective (Π₀ i, β i) (Π i, β i) coe_fn :=
λ f g H, quotient.induction_on₂ f g (λ _ _ H, quotient.sound H) (congr_fun H)

@[ext] lemma ext {f g : Π₀ i, β i} (H : ∀ i, f i = g i) : f = g :=
coe_fn_injective (funext H)

/-- The composition of `f : β₁ → β₂` and `g : Π₀ i, β₁ i` is
  `map_range f hf g : Π₀ i, β₂ i`, well defined when `f 0 = 0`.

This preserves the structure on `f`, and exists in various bundled forms for when `f` is itself
bundled:

* `dfinsupp.map_range.add_monoid_hom`
* `dfinsupp.map_range.add_equiv`
* `dfinsupp.map_range.linear_map`
* `dfinsupp.map_range.linear_equiv`
-/
def map_range (f : Π i, β₁ i → β₂ i) (hf : ∀ i, f i 0 = 0) (g : Π₀ i, β₁ i) : Π₀ i, β₂ i :=
quotient.lift_on g (λ x, ⟦(⟨λ i, f i (x.1 i), x.2,
  λ i, or.cases_on (x.3 i) or.inl $ λ H, or.inr $ by rw [H, hf]⟩ : pre ι β₂)⟧) $ λ x y H,
quotient.sound $ λ i, by simp only [H i]

@[simp] lemma map_range_apply
  (f : Π i, β₁ i → β₂ i) (hf : ∀ i, f i 0 = 0) (g : Π₀ i, β₁ i) (i : ι) :
  map_range f hf g i = f i (g i) :=
quotient.induction_on g $ λ x, rfl

@[simp] lemma map_range_id (h : ∀ i, id (0 : β₁ i) = 0 := λ i, rfl) (g : Π₀ (i : ι), β₁ i) :
  map_range (λ i, (id : β₁ i → β₁ i)) h g = g :=
by { ext, simp only [map_range_apply, id.def] }

lemma map_range_comp (f : Π i, β₁ i → β₂ i) (f₂ : Π i, β i → β₁ i)
  (hf : ∀ i, f i 0 = 0) (hf₂ : ∀ i, f₂ i 0 = 0) (h : ∀ i, (f i ∘ f₂ i) 0 = 0)
  (g : Π₀ (i : ι), β i) :
  map_range (λ i, f i ∘ f₂ i) h g = map_range f hf (map_range f₂ hf₂ g) :=
by { ext, simp only [map_range_apply] }

@[simp] lemma map_range_zero (f : Π i, β₁ i → β₂ i) (hf : ∀ i, f i 0 = 0) :
  map_range f hf (0 : Π₀ i, β₁ i) = 0 :=
by { ext, simp only [map_range_apply, coe_zero, pi.zero_apply, hf] }

/-- Let `f i` be a binary operation `β₁ i → β₂ i → β i` such that `f i 0 0 = 0`.
Then `zip_with f hf` is a binary operation `Π₀ i, β₁ i → Π₀ i, β₂ i → Π₀ i, β i`. -/
def zip_with (f : Π i, β₁ i → β₂ i → β i) (hf : ∀ i, f i 0 0 = 0)
  (g₁ : Π₀ i, β₁ i) (g₂ : Π₀ i, β₂ i) : (Π₀ i, β i) :=
begin
  refine quotient.lift_on₂ g₁ g₂ (λ x y, ⟦(⟨λ i, f i (x.1 i) (y.1 i), x.2 + y.2,
    λ i, _⟩ : pre ι β)⟧) _,
  { cases x.3 i with h1 h1,
    { left, rw multiset.mem_add, left, exact h1 },
    cases y.3 i with h2 h2,
    { left, rw multiset.mem_add, right, exact h2 },
    right, rw [h1, h2, hf] },
  exact λ x₁ x₂ y₁ y₂ H1 H2, quotient.sound $ λ i, by simp only [H1 i, H2 i]
end

@[simp] lemma zip_with_apply
  (f : Π i, β₁ i → β₂ i → β i) (hf : ∀ i, f i 0 0 = 0) (g₁ : Π₀ i, β₁ i) (g₂ : Π₀ i, β₂ i) (i : ι) :
  zip_with f hf g₁ g₂ i = f i (g₁ i) (g₂ i) :=
quotient.induction_on₂ g₁ g₂ $ λ _ _, rfl

end basic

section algebra

instance [Π i, add_zero_class (β i)] : has_add (Π₀ i, β i) :=
⟨zip_with (λ _, (+)) (λ _, add_zero 0)⟩

lemma add_apply [Π i, add_zero_class (β i)] (g₁ g₂ : Π₀ i, β i) (i : ι) :
  (g₁ + g₂) i = g₁ i + g₂ i :=
zip_with_apply _ _ g₁ g₂ i

@[simp] lemma coe_add [Π i, add_zero_class (β i)] (g₁ g₂ : Π₀ i, β i) :
  ⇑(g₁ + g₂) = g₁ + g₂ :=
funext $ add_apply g₁ g₂

instance [Π i, add_zero_class (β i)] : add_zero_class (Π₀ i, β i) :=
{ zero      := 0,
  add       := (+),
  zero_add  := λ f, ext $ λ i, by simp only [add_apply, zero_apply, zero_add],
  add_zero  := λ f, ext $ λ i, by simp only [add_apply, zero_apply, add_zero] }

instance [Π i, add_monoid (β i)] : add_monoid (Π₀ i, β i) :=
{ add_monoid .
  zero      := 0,
  add       := (+),
  add_assoc := λ f g h, ext $ λ i, by simp only [add_apply, add_assoc],
  .. dfinsupp.add_zero_class }

instance is_add_monoid_hom [Π i, add_zero_class (β i)] {i : ι} :
  is_add_monoid_hom (λ g : Π₀ i : ι, β i, g i) :=
{ map_add := λ f g, add_apply f g i, map_zero := zero_apply i }

instance [Π i, add_group (β i)] : has_neg (Π₀ i, β i) :=
⟨λ f, f.map_range (λ _, has_neg.neg) (λ _, neg_zero)⟩

instance [Π i, add_comm_monoid (β i)] : add_comm_monoid (Π₀ i, β i) :=
{ add_comm := λ f g, ext $ λ i, by simp only [add_apply, add_comm],
  .. dfinsupp.add_monoid }

lemma neg_apply [Π i, add_group (β i)] (g : Π₀ i, β i) (i : ι) : (- g) i = - g i :=
map_range_apply _ _ g i

@[simp] lemma coe_neg [Π i, add_group (β i)] (g : Π₀ i, β i) : ⇑(- g) = - g :=
funext $ neg_apply g

instance [Π i, add_group (β i)] : add_group (Π₀ i, β i) :=
{ add_left_neg := λ f, ext $ λ i, by simp only [add_apply, neg_apply, zero_apply, add_left_neg],
  .. dfinsupp.add_monoid,
  .. (infer_instance : has_neg (Π₀ i, β i)) }

lemma sub_apply [Π i, add_group (β i)] (g₁ g₂ : Π₀ i, β i) (i : ι) :
  (g₁ - g₂) i = g₁ i - g₂ i :=
by rw [sub_eq_add_neg]; simp [sub_eq_add_neg]

@[simp] lemma coe_sub [Π i, add_group (β i)] (g₁ g₂ : Π₀ i, β i) :
  ⇑(g₁ - g₂) = g₁ - g₂ :=
funext $ sub_apply g₁ g₂

instance [Π i, add_comm_group (β i)] : add_comm_group (Π₀ i, β i) :=
{ add_comm := λ f g, ext $ λ i, by simp only [add_apply, add_comm],
  ..dfinsupp.add_group }

/-- Dependent functions with finite support inherit a semiring action from an action on each
coordinate. -/
instance {γ : Type w} [monoid γ] [Π i, add_monoid (β i)] [Π i, distrib_mul_action γ (β i)] :
  has_scalar γ (Π₀ i, β i) :=
⟨λc v, v.map_range (λ _, (•) c) (λ _, smul_zero _)⟩

lemma smul_apply {γ : Type w} [monoid γ] [Π i, add_monoid (β i)]
  [Π i, distrib_mul_action γ (β i)] (b : γ) (v : Π₀ i, β i) (i : ι) :
  (b • v) i = b • (v i) :=
map_range_apply _ _ v i

@[simp] lemma coe_smul {γ : Type w} [monoid γ] [Π i, add_monoid (β i)]
  [Π i, distrib_mul_action γ (β i)] (b : γ) (v : Π₀ i, β i) :
  ⇑(b • v) = b • v :=
funext $ smul_apply b v

instance {γ : Type w} {δ : Type*} [monoid γ] [monoid δ]
  [Π i, add_monoid (β i)] [Π i, distrib_mul_action γ (β i)] [Π i, distrib_mul_action δ (β i)]
  [Π i, smul_comm_class γ δ (β i)] :
  smul_comm_class γ δ (Π₀ i, β i) :=
{ smul_comm := λ r s m, ext $ λ i, by simp only [smul_apply, smul_comm r s (m i)] }

instance {γ : Type w} {δ : Type*} [monoid γ] [monoid δ]
  [Π i, add_monoid (β i)] [Π i, distrib_mul_action γ (β i)] [Π i, distrib_mul_action δ (β i)]
  [has_scalar γ δ] [Π i, is_scalar_tower γ δ (β i)] :
  is_scalar_tower γ δ (Π₀ i, β i) :=
{ smul_assoc := λ r s m, ext $ λ i, by simp only [smul_apply, smul_assoc r s (m i)] }

/-- Dependent functions with finite support inherit a `distrib_mul_action` structure from such a
structure on each coordinate. -/
instance {γ : Type w} [monoid γ] [Π i, add_monoid (β i)] [Π i, distrib_mul_action γ (β i)] :
  distrib_mul_action γ (Π₀ i, β i) :=
{ smul_zero := λ c, ext $ λ i, by simp only [smul_apply, smul_zero, zero_apply],
  smul_add := λ c x y, ext $ λ i, by simp only [add_apply, smul_apply, smul_add],
  one_smul := λ x, ext $ λ i, by simp only [smul_apply, one_smul],
  mul_smul := λ r s x, ext $ λ i, by simp only [smul_apply, smul_smul],
  ..dfinsupp.has_scalar }

/-- Dependent functions with finite support inherit a module structure from such a structure on
each coordinate. -/
instance {γ : Type w} [semiring γ] [Π i, add_comm_monoid (β i)] [Π i, module γ (β i)] :
  module γ (Π₀ i, β i) :=
{ zero_smul := λ c, ext $ λ i, by simp only [smul_apply, zero_smul, zero_apply],
  add_smul := λ c x y, ext $ λ i, by simp only [add_apply, smul_apply, add_smul],
  ..dfinsupp.distrib_mul_action }

end algebra

section filter_and_subtype_domain

/-- `filter p f` is the function which is `f i` if `p i` is true and 0 otherwise. -/
def filter [Π i, has_zero (β i)] (p : ι → Prop) [decidable_pred p] (f : Π₀ i, β i) : Π₀ i, β i :=
quotient.lift_on f (λ x, ⟦(⟨λ i, if p i then x.1 i else 0, x.2,
  λ i, or.cases_on (x.3 i) or.inl $ λ H, or.inr $ by rw [H, if_t_t]⟩ : pre ι β)⟧) $ λ x y H,
quotient.sound $ λ i, by simp only [H i]

@[simp] lemma filter_apply [Π i, has_zero (β i)]
  (p : ι → Prop) [decidable_pred p] (i : ι) (f : Π₀ i, β i) :
  f.filter p i = if p i then f i else 0 :=
quotient.induction_on f $ λ x, rfl

lemma filter_apply_pos [Π i, has_zero (β i)]
  {p : ι → Prop} [decidable_pred p] (f : Π₀ i, β i) {i : ι} (h : p i) :
  f.filter p i = f i :=
by simp only [filter_apply, if_pos h]

lemma filter_apply_neg [Π i, has_zero (β i)]
  {p : ι → Prop} [decidable_pred p] (f : Π₀ i, β i) {i : ι} (h : ¬ p i) :
  f.filter p i = 0 :=
by simp only [filter_apply, if_neg h]

lemma filter_pos_add_filter_neg [Π i, add_zero_class (β i)] (f : Π₀ i, β i)
  (p : ι → Prop) [decidable_pred p] :
  f.filter p + f.filter (λi, ¬ p i) = f :=
ext $ λ i, by simp only [add_apply, filter_apply]; split_ifs; simp only [add_zero, zero_add]

/-- `subtype_domain p f` is the restriction of the finitely supported function
  `f` to the subtype `p`. -/
def subtype_domain [Π i, has_zero (β i)] (p : ι → Prop) [decidable_pred p]
  (f : Π₀ i, β i) : Π₀ i : subtype p, β i :=
begin
  fapply quotient.lift_on f,
  { intro x,
    refine ⟦⟨λ i, x.1 (i : ι),
      (x.2.filter p).attach.map $ λ j, ⟨j, (multiset.mem_filter.1 j.2).2⟩, _⟩⟧,
    refine λ i, or.cases_on (x.3 i) (λ H, _) or.inr,
    left, rw multiset.mem_map, refine ⟨⟨i, multiset.mem_filter.2 ⟨H, i.2⟩⟩, _, subtype.eta _ _⟩,
    apply multiset.mem_attach },
  intros x y H,
  exact quotient.sound (λ i, H i)
end

@[simp] lemma subtype_domain_zero [Π i, has_zero (β i)] {p : ι → Prop} [decidable_pred p] :
  subtype_domain p (0 : Π₀ i, β i) = 0 :=
rfl

@[simp] lemma subtype_domain_apply [Π i, has_zero (β i)] {p : ι → Prop} [decidable_pred p]
  {i : subtype p} {v : Π₀ i, β i} :
  (subtype_domain p v) i = v i :=
quotient.induction_on v $ λ x, rfl

@[simp] lemma subtype_domain_add [Π i, add_zero_class (β i)] {p : ι → Prop} [decidable_pred p]
  {v v' : Π₀ i, β i} :
  (v + v').subtype_domain p = v.subtype_domain p + v'.subtype_domain p :=
ext $ λ i, by simp only [add_apply, subtype_domain_apply]

instance subtype_domain.is_add_monoid_hom [Π i, add_zero_class (β i)]
  {p : ι → Prop} [decidable_pred p] :
  is_add_monoid_hom (subtype_domain p : (Π₀ i : ι, β i) → Π₀ i : subtype p, β i) :=
{ map_add := λ _ _, subtype_domain_add, map_zero := subtype_domain_zero }

@[simp]
lemma subtype_domain_neg [Π i, add_group (β i)] {p : ι → Prop} [decidable_pred p] {v : Π₀ i, β i} :
  (- v).subtype_domain p = - v.subtype_domain p :=
ext $ λ i, by simp only [neg_apply, subtype_domain_apply]

@[simp] lemma subtype_domain_sub [Π i, add_group (β i)] {p : ι → Prop} [decidable_pred p]
  {v v' : Π₀ i, β i} :
  (v - v').subtype_domain p = v.subtype_domain p - v'.subtype_domain p :=
ext $ λ i, by simp only [sub_apply, subtype_domain_apply]

end filter_and_subtype_domain

variable [dec : decidable_eq ι]
include dec

section basic
variable [Π i, has_zero (β i)]

omit dec
lemma finite_support (f : Π₀ i, β i) : set.finite {i | f i ≠ 0} :=
begin
  classical,
  exact quotient.induction_on f (λ x, x.2.to_finset.finite_to_set.subset (λ i H,
    multiset.mem_to_finset.2 ((x.3 i).resolve_right H)))
end
include dec

/-- Create an element of `Π₀ i, β i` from a finset `s` and a function `x`
defined on this `finset`. -/
def mk (s : finset ι) (x : Π i : (↑s : set ι), β (i : ι)) : Π₀ i, β i :=
⟦⟨λ i, if H : i ∈ s then x ⟨i, H⟩ else 0, s.1,
λ i, if H : i ∈ s then or.inl H else or.inr $ dif_neg H⟩⟧

@[simp] lemma mk_apply {s : finset ι} {x : Π i : (↑s : set ι), β i} {i : ι} :
  (mk s x : Π i, β i) i = if H : i ∈ s then x ⟨i, H⟩ else 0 :=
rfl

theorem mk_injective (s : finset ι) : function.injective (@mk ι β _ _ s) :=
begin
  intros x y H,
  ext i,
  have h1 : (mk s x : Π i, β i) i = (mk s y : Π i, β i) i, {rw H},
  cases i with i hi,
  change i ∈ s at hi,
  dsimp only [mk_apply, subtype.coe_mk] at h1,
  simpa only [dif_pos hi] using h1
end

/-- The function `single i b : Π₀ i, β i` sends `i` to `b`
and all other points to `0`. -/
def single (i : ι) (b : β i) : Π₀ i, β i :=
mk {i} $ λ j, eq.rec_on (finset.mem_singleton.1 j.prop).symm b

@[simp] lemma single_apply {i i' b} :
  (single i b : Π₀ i, β i) i' = (if h : i = i' then eq.rec_on h b else 0) :=
begin
  dsimp only [single],
  by_cases h : i = i',
  { have h1 : i' ∈ ({i} : finset ι) := finset.mem_singleton.2 h.symm,
    simp only [mk_apply, dif_pos h, dif_pos h1], refl },
  { have h1 : i' ∉ ({i} : finset ι) := finset.not_mem_singleton.2 (ne.symm h),
    simp only [mk_apply, dif_neg h, dif_neg h1] }
end

@[simp] lemma single_zero {i} : (single i 0 : Π₀ i, β i) = 0 :=
quotient.sound $ λ j, if H : j ∈ ({i} : finset _)
then by dsimp only; rw [dif_pos H]; cases finset.mem_singleton.1 H; refl
else dif_neg H

@[simp] lemma single_eq_same {i b} : (single i b : Π₀ i, β i) i = b :=
by simp only [single_apply, dif_pos rfl]

lemma single_eq_of_ne {i i' b} (h : i ≠ i') : (single i b : Π₀ i, β i) i' = 0 :=
by simp only [single_apply, dif_neg h]

lemma single_injective {i} : function.injective (single i : β i → Π₀ i, β i) :=
λ x y H, congr_fun (mk_injective _ H) ⟨i, by simp⟩

/-- Like `finsupp.single_eq_single_iff`, but with a `heq` due to dependent types -/
lemma single_eq_single_iff (i j : ι) (xi : β i) (xj : β j) :
  dfinsupp.single i xi = dfinsupp.single j xj ↔ i = j ∧ xi == xj ∨ xi = 0 ∧ xj = 0 :=
begin
  split,
  { intro h,
    by_cases hij : i = j,
    { subst hij,
      exact or.inl ⟨rfl, heq_of_eq (dfinsupp.single_injective h)⟩, },
    { have h_coe : ⇑(dfinsupp.single i xi) = dfinsupp.single j xj := congr_arg coe_fn h,
      have hci := congr_fun h_coe i,
      have hcj := congr_fun h_coe j,
      rw dfinsupp.single_eq_same at hci hcj,
      rw dfinsupp.single_eq_of_ne (ne.symm hij) at hci,
      rw dfinsupp.single_eq_of_ne (hij) at hcj,
      exact or.inr ⟨hci, hcj.symm⟩, }, },
  { rintros (⟨hi, hxi⟩ | ⟨hi, hj⟩),
    { subst hi,
      rw eq_of_heq hxi, },
    { rw [hi, hj, dfinsupp.single_zero, dfinsupp.single_zero], }, },
end

/-- Equality of sigma types is sufficient (but not necessary) to show equality of `dfinsupp`s. -/
lemma single_eq_of_sigma_eq
  {i j} {xi : β i} {xj : β j} (h : (⟨i, xi⟩ : sigma β) = ⟨j, xj⟩) :
  dfinsupp.single i xi = dfinsupp.single j xj :=
by { cases h, refl }

/-- Redefine `f i` to be `0`. -/
def erase (i : ι) (f : Π₀ i, β i) : Π₀ i, β i :=
quotient.lift_on f (λ x, ⟦(⟨λ j, if j = i then 0 else x.1 j, x.2,
λ j, or.cases_on (x.3 j) or.inl $ λ H, or.inr $ by simp only [H, if_t_t]⟩ : pre ι β)⟧) $ λ x y H,
quotient.sound $ λ j, if h : j = i then by simp only [if_pos h]
else by simp only [if_neg h, H j]

@[simp] lemma erase_apply {i j : ι} {f : Π₀ i, β i} :
  (f.erase i) j = if j = i then 0 else f j :=
quotient.induction_on f $ λ x, rfl

@[simp] lemma erase_same {i : ι} {f : Π₀ i, β i} : (f.erase i) i = 0 :=
by simp

lemma erase_ne {i i' : ι} {f : Π₀ i, β i} (h : i' ≠ i) : (f.erase i) i' = f i' :=
by simp [h]

end basic

section add_monoid

variable [Π i, add_zero_class (β i)]

@[simp] lemma single_add {i : ι} {b₁ b₂ : β i} : single i (b₁ + b₂) = single i b₁ + single i b₂ :=
ext $ assume i',
begin
  by_cases h : i = i',
  { subst h, simp only [add_apply, single_eq_same] },
  { simp only [add_apply, single_eq_of_ne h, zero_add] }
end

variables (β)

/-- `dfinsupp.single` as an `add_monoid_hom`. -/
@[simps] def single_add_hom (i : ι) : β i →+ Π₀ i, β i :=
{ to_fun := single i, map_zero' := single_zero, map_add' := λ _ _, single_add }

variables {β}

lemma single_add_erase {i : ι} {f : Π₀ i, β i} : single i (f i) + f.erase i = f :=
ext $ λ i',
if h : i = i'
then by subst h; simp only [add_apply, single_apply, erase_apply, dif_pos rfl, if_pos, add_zero]
else by simp only [add_apply, single_apply, erase_apply, dif_neg h, if_neg (ne.symm h), zero_add]

lemma erase_add_single {i : ι} {f : Π₀ i, β i} : f.erase i + single i (f i) = f :=
ext $ λ i',
if h : i = i'
then by subst h; simp only [add_apply, single_apply, erase_apply, dif_pos rfl, if_pos, zero_add]
else by simp only [add_apply, single_apply, erase_apply, dif_neg h, if_neg (ne.symm h), add_zero]

protected theorem induction {p : (Π₀ i, β i) → Prop} (f : Π₀ i, β i)
  (h0 : p 0) (ha : ∀i b (f : Π₀ i, β i), f i = 0 → b ≠ 0 → p f → p (single i b + f)) :
  p f :=
begin
  refine quotient.induction_on f (λ x, _),
  cases x with f s H, revert f H,
  apply multiset.induction_on s,
  { intros f H, convert h0, ext i, exact (H i).resolve_left id },
  intros i s ih f H,
  by_cases H1 : i ∈ s,
  { have H2 : ∀ j, j ∈ s ∨ f j = 0,
    { intro j, cases H j with H2 H2,
      { cases multiset.mem_cons.1 H2 with H3 H3,
        { left, rw H3, exact H1 },
        { left, exact H3 } },
      right, exact H2 },
    have H3 : (⟦{to_fun := f, pre_support := i ::ₘ s, zero := H}⟧ : Π₀ i, β i)
      = ⟦{to_fun := f, pre_support := s, zero := H2}⟧,
    { exact quotient.sound (λ i, rfl) },
    rw H3, apply ih },
  have H2 : p (erase i ⟦{to_fun := f, pre_support := i ::ₘ s, zero := H}⟧),
  { dsimp only [erase, quotient.lift_on_mk],
    have H2 : ∀ j, j ∈ s ∨ ite (j = i) 0 (f j) = 0,
    { intro j, cases H j with H2 H2,
      { cases multiset.mem_cons.1 H2 with H3 H3,
        { right, exact if_pos H3 },
        { left, exact H3 } },
      right, split_ifs; [refl, exact H2] },
    have H3 : (⟦{to_fun := λ (j : ι), ite (j = i) 0 (f j),
         pre_support := i ::ₘ s, zero := _}⟧ : Π₀ i, β i)
      = ⟦{to_fun := λ (j : ι), ite (j = i) 0 (f j), pre_support := s, zero := H2}⟧ :=
      quotient.sound (λ i, rfl),
    rw H3, apply ih },
  have H3 : single i _ + _ = (⟦{to_fun := f, pre_support := i ::ₘ s, zero := H}⟧ : Π₀ i, β i) :=
    single_add_erase,
  rw ← H3,
  change p (single i (f i) + _),
  cases classical.em (f i = 0) with h h,
  { rw [h, single_zero, zero_add], exact H2 },
  refine ha _ _ _ _ h H2,
  rw erase_same
end

lemma induction₂ {p : (Π₀ i, β i) → Prop} (f : Π₀ i, β i)
  (h0 : p 0) (ha : ∀i b (f : Π₀ i, β i), f i = 0 → b ≠ 0 → p f → p (f + single i b)) :
  p f :=
dfinsupp.induction f h0 $ λ i b f h1 h2 h3,
have h4 : f + single i b = single i b + f,
{ ext j, by_cases H : i = j,
  { subst H, simp [h1] },
  { simp [H] } },
eq.rec_on h4 $ ha i b f h1 h2 h3

@[simp] lemma add_closure_Union_range_single :
  add_submonoid.closure (⋃ i : ι, set.range (single i : β i → (Π₀ i, β i))) = ⊤ :=
top_unique $ λ x hx, (begin
  apply dfinsupp.induction x,
  exact add_submonoid.zero_mem _,
  exact λ a b f ha hb hf, add_submonoid.add_mem _
    (add_submonoid.subset_closure $ set.mem_Union.2 ⟨a, set.mem_range_self _⟩) hf
end)

/-- If two additive homomorphisms from `Π₀ i, β i` are equal on each `single a b`, then
they are equal. -/
lemma add_hom_ext {γ : Type w} [add_zero_class γ] ⦃f g : (Π₀ i, β i) →+ γ⦄
  (H : ∀ (i : ι) (y : β i), f (single i y) = g (single i y)) :
  f = g :=
begin
  refine add_monoid_hom.eq_of_eq_on_mdense add_closure_Union_range_single (λ f hf, _),
  simp only [set.mem_Union, set.mem_range] at hf,
  rcases hf with ⟨x, y, rfl⟩,
  apply H
end

/-- If two additive homomorphisms from `Π₀ i, β i` are equal on each `single a b`, then
they are equal.

See note [partially-applied ext lemmas]. -/
@[ext] lemma add_hom_ext' {γ : Type w} [add_zero_class γ] ⦃f g : (Π₀ i, β i) →+ γ⦄
  (H : ∀ x, f.comp (single_add_hom β x) = g.comp (single_add_hom β x)) :
  f = g :=
add_hom_ext $ λ x, add_monoid_hom.congr_fun (H x)

end add_monoid

@[simp] lemma mk_add [Π i, add_zero_class (β i)] {s : finset ι} {x y : Π i : (↑s : set ι), β i} :
  mk s (x + y) = mk s x + mk s y :=
ext $ λ i, by simp only [add_apply, mk_apply]; split_ifs; [refl, rw zero_add]

@[simp] lemma mk_zero [Π i, has_zero (β i)] {s : finset ι} :
  mk s (0 : Π i : (↑s : set ι), β i.1) = 0 :=
ext $ λ i, by simp only [mk_apply]; split_ifs; refl

@[simp] lemma mk_neg [Π i, add_group (β i)] {s : finset ι} {x : Π i : (↑s : set ι), β i.1} :
  mk s (-x) = -mk s x :=
ext $ λ i, by simp only [neg_apply, mk_apply]; split_ifs; [refl, rw neg_zero]

@[simp] lemma mk_sub [Π i, add_group (β i)] {s : finset ι} {x y : Π i : (↑s : set ι), β i.1} :
  mk s (x - y) = mk s x - mk s y :=
ext $ λ i, by simp only [sub_apply, mk_apply]; split_ifs; [refl, rw sub_zero]

instance [Π i, add_group (β i)] {s : finset ι} : is_add_group_hom (@mk ι β _ _ s) :=
{ map_add := λ _ _, mk_add }

section
variables (γ : Type w) [semiring γ] [Π i, add_comm_monoid (β i)] [Π i, module γ (β i)]
include γ

@[simp] lemma mk_smul {s : finset ι} {c : γ} (x : Π i : (↑s : set ι), β i.1) :
  mk s (c • x) = c • mk s x :=
ext $ λ i, by simp only [smul_apply, mk_apply]; split_ifs; [refl, rw smul_zero]

@[simp] lemma single_smul {i : ι} {c : γ} {x : β i} :
  single i (c • x) = c • single i x :=
ext $ λ i, by simp only [smul_apply, single_apply]; split_ifs; [cases h, rw smul_zero]; refl

end

section support_basic

variables [Π i, has_zero (β i)] [Π i (x : β i), decidable (x ≠ 0)]

/-- Set `{i | f x ≠ 0}` as a `finset`. -/
def support (f : Π₀ i, β i) : finset ι :=
quotient.lift_on f (λ x, x.2.to_finset.filter $ λ i, x.1 i ≠ 0) $
begin
  intros x y Hxy,
  ext i, split,
  { intro H,
    rcases finset.mem_filter.1 H with ⟨h1, h2⟩,
    rw Hxy i at h2,
    exact finset.mem_filter.2 ⟨multiset.mem_to_finset.2 $ (y.3 i).resolve_right h2, h2⟩ },
  { intro H,
    rcases finset.mem_filter.1 H with ⟨h1, h2⟩,
    rw ← Hxy i at h2,
    exact finset.mem_filter.2 ⟨multiset.mem_to_finset.2 $ (x.3 i).resolve_right h2, h2⟩ },
end

@[simp] theorem support_mk_subset {s : finset ι} {x : Π i : (↑s : set ι), β i.1} :
  (mk s x).support ⊆ s :=
λ i H, multiset.mem_to_finset.1 (finset.mem_filter.1 H).1

@[simp] theorem mem_support_to_fun (f : Π₀ i, β i) (i) : i ∈ f.support ↔ f i ≠ 0 :=
begin
  refine quotient.induction_on f (λ x, _),
  dsimp only [support, quotient.lift_on_mk],
  rw [finset.mem_filter, multiset.mem_to_finset],
  exact and_iff_right_of_imp (x.3 i).resolve_right
end

theorem eq_mk_support (f : Π₀ i, β i) : f = mk f.support (λ i, f i) :=
begin
  change f = mk f.support (λ i, f i.1),
  ext i,
  by_cases h : f i ≠ 0; [skip, rw [not_not] at h];
    simp [h]
end

@[simp] lemma support_zero : (0 : Π₀ i, β i).support = ∅ := rfl

lemma mem_support_iff (f : Π₀ i, β i) : ∀i:ι, i ∈ f.support ↔ f i ≠ 0 :=
f.mem_support_to_fun

@[simp] lemma support_eq_empty {f : Π₀ i, β i} : f.support = ∅ ↔ f = 0 :=
⟨λ H, ext $ by simpa [finset.ext_iff] using H, by simp {contextual:=tt}⟩

instance decidable_zero : decidable_pred (eq (0 : Π₀ i, β i)) :=
λ f, decidable_of_iff _ $ support_eq_empty.trans eq_comm

lemma support_subset_iff {s : set ι} {f : Π₀ i, β i} :
  ↑f.support ⊆ s ↔ (∀i∉s, f i = 0) :=
by simp [set.subset_def];
   exact forall_congr (assume i, not_imp_comm)

lemma support_single_ne_zero {i : ι} {b : β i} (hb : b ≠ 0) : (single i b).support = {i} :=
begin
  ext j, by_cases h : i = j,
  { subst h, simp [hb] },
  simp [ne.symm h, h]
end

lemma support_single_subset {i : ι} {b : β i} : (single i b).support ⊆ {i} :=
support_mk_subset

section map_range_and_zip_with

variables [Π i, has_zero (β₁ i)] [Π i, has_zero (β₂ i)]

lemma map_range_def [Π i (x : β₁ i), decidable (x ≠ 0)]
  {f : Π i, β₁ i → β₂ i} {hf : ∀ i, f i 0 = 0} {g : Π₀ i, β₁ i} :
  map_range f hf g = mk g.support (λ i, f i.1 (g i.1)) :=
begin
  ext i,
  by_cases h : g i ≠ 0; simp at h; simp [h, hf]
end

@[simp] lemma map_range_single {f : Π i, β₁ i → β₂ i} {hf : ∀ i, f i 0 = 0} {i : ι} {b : β₁ i} :
  map_range f hf (single i b) = single i (f i b) :=
dfinsupp.ext $ λ i', by by_cases i = i'; [{subst i', simp}, simp [h, hf]]

variables [Π i (x : β₁ i), decidable (x ≠ 0)] [Π i (x : β₂ i), decidable (x ≠ 0)]

lemma support_map_range {f : Π i, β₁ i → β₂ i} {hf : ∀ i, f i 0 = 0} {g : Π₀ i, β₁ i} :
  (map_range f hf g).support ⊆ g.support :=
by simp [map_range_def]

lemma zip_with_def {f : Π i, β₁ i → β₂ i → β i} {hf : ∀ i, f i 0 0 = 0}
  {g₁ : Π₀ i, β₁ i} {g₂ : Π₀ i, β₂ i} :
  zip_with f hf g₁ g₂ = mk (g₁.support ∪ g₂.support) (λ i, f i.1 (g₁ i.1) (g₂ i.1)) :=
begin
  ext i,
  by_cases h1 : g₁ i ≠ 0; by_cases h2 : g₂ i ≠ 0;
    simp only [not_not, ne.def] at h1 h2; simp [h1, h2, hf]
end

lemma support_zip_with {f : Π i, β₁ i → β₂ i → β i} {hf : ∀ i, f i 0 0 = 0}
  {g₁ : Π₀ i, β₁ i} {g₂ : Π₀ i, β₂ i} :
  (zip_with f hf g₁ g₂).support ⊆ g₁.support ∪ g₂.support :=
by simp [zip_with_def]

end map_range_and_zip_with

lemma erase_def (i : ι) (f : Π₀ i, β i) :
  f.erase i = mk (f.support.erase i) (λ j, f j.1) :=
by { ext j, by_cases h1 : j = i; by_cases h2 : f j ≠ 0; simp at h2; simp [h1, h2] }

@[simp] lemma support_erase (i : ι) (f : Π₀ i, β i) :
  (f.erase i).support = f.support.erase i :=
by { ext j, by_cases h1 : j = i; by_cases h2 : f j ≠ 0; simp at h2; simp [h1, h2] }

section filter_and_subtype_domain

variables {p : ι → Prop} [decidable_pred p]

lemma filter_def (f : Π₀ i, β i) :
  f.filter p = mk (f.support.filter p) (λ i, f i.1) :=
by ext i; by_cases h1 : p i; by_cases h2 : f i ≠ 0;
 simp at h2; simp [h1, h2]

@[simp] lemma support_filter (f : Π₀ i, β i) :
  (f.filter p).support = f.support.filter p :=
by ext i; by_cases h : p i; simp [h]

lemma subtype_domain_def (f : Π₀ i, β i) :
  f.subtype_domain p = mk (f.support.subtype p) (λ i, f i) :=
by ext i; by_cases h1 : p i; by_cases h2 : f i ≠ 0;
try {simp at h2}; dsimp; simp [h1, h2, ← subtype.val_eq_coe]

@[simp] lemma support_subtype_domain {f : Π₀ i, β i} :
  (subtype_domain p f).support = f.support.subtype p :=
by ext i; by_cases h1 : p i; by_cases h2 : f i ≠ 0;
try {simp at h2}; dsimp; simp [h1, h2]

end filter_and_subtype_domain

end support_basic

lemma support_add [Π i, add_zero_class (β i)] [Π i (x : β i), decidable (x ≠ 0)]
  {g₁ g₂ : Π₀ i, β i} :
  (g₁ + g₂).support ⊆ g₁.support ∪ g₂.support :=
support_zip_with

@[simp] lemma support_neg [Π i, add_group (β i)] [Π i (x : β i), decidable (x ≠ 0)]
  {f : Π₀ i, β i} :
  support (-f) = support f :=
by ext i; simp

lemma support_smul {γ : Type w} [semiring γ] [Π i, add_comm_monoid (β i)] [Π i, module γ (β i)]
  [Π ( i : ι) (x : β i), decidable (x ≠ 0)]
  (b : γ) (v : Π₀ i, β i) : (b • v).support ⊆ v.support :=
support_map_range

instance [Π i, has_zero (β i)] [Π i, decidable_eq (β i)] : decidable_eq (Π₀ i, β i) :=
assume f g, decidable_of_iff (f.support = g.support ∧ (∀i∈f.support, f i = g i))
  ⟨assume ⟨h₁, h₂⟩, ext $ assume i,
      if h : i ∈ f.support then h₂ i h else
        have hf : f i = 0, by rwa [f.mem_support_iff, not_not] at h,
        have hg : g i = 0, by rwa [h₁, g.mem_support_iff, not_not] at h,
        by rw [hf, hg],
    by intro h; subst h; simp⟩

section prod_and_sum

variables {γ : Type w}

-- [to_additive sum] for dfinsupp.prod doesn't work, the equation lemmas are not generated
/-- `sum f g` is the sum of `g i (f i)` over the support of `f`. -/
def sum [Π i, has_zero (β i)] [Π i (x : β i), decidable (x ≠ 0)] [add_comm_monoid γ]
  (f : Π₀ i, β i) (g : Π i, β i → γ) : γ :=
∑ i in f.support, g i (f i)

/-- `prod f g` is the product of `g i (f i)` over the support of `f`. -/
@[to_additive]
def prod [Π i, has_zero (β i)] [Π i (x : β i), decidable (x ≠ 0)] [comm_monoid γ]
  (f : Π₀ i, β i) (g : Π i, β i → γ) : γ :=
∏ i in f.support, g i (f i)

@[to_additive]
lemma prod_map_range_index {β₁ : ι → Type v₁} {β₂ : ι → Type v₂}
  [Π i, has_zero (β₁ i)] [Π i, has_zero (β₂ i)]
  [Π i (x : β₁ i), decidable (x ≠ 0)] [Π i (x : β₂ i), decidable (x ≠ 0)] [comm_monoid γ]
  {f : Π i, β₁ i → β₂ i} {hf : ∀ i, f i 0 = 0} {g : Π₀ i, β₁ i} {h : Π i, β₂ i → γ}
  (h0 : ∀i, h i 0 = 1) :
  (map_range f hf g).prod h = g.prod (λi b, h i (f i b)) :=
begin
  rw [map_range_def],
  refine (finset.prod_subset support_mk_subset _).trans _,
  { intros i h1 h2,
    dsimp, simp [h1] at h2, dsimp at h2,
    simp [h1, h2, h0] },
  { refine finset.prod_congr rfl _,
    intros i h1,
    simp [h1] }
end

@[to_additive]
lemma prod_zero_index [Π i, add_comm_monoid (β i)] [Π i (x : β i), decidable (x ≠ 0)]
  [comm_monoid γ] {h : Π i, β i → γ} : (0 : Π₀ i, β i).prod h = 1 :=
rfl

@[to_additive]
lemma prod_single_index [Π i, has_zero (β i)] [Π i (x : β i), decidable (x ≠ 0)] [comm_monoid γ]
  {i : ι} {b : β i} {h : Π i, β i → γ} (h_zero : h i 0 = 1) :
  (single i b).prod h = h i b :=
begin
  by_cases h : b ≠ 0,
  { simp [dfinsupp.prod, support_single_ne_zero h] },
  { rw [not_not] at h, simp [h, prod_zero_index, h_zero], refl }
end

@[to_additive]
lemma prod_neg_index [Π i, add_group (β i)] [Π i (x : β i), decidable (x ≠ 0)] [comm_monoid γ]
  {g : Π₀ i, β i} {h : Π i, β i → γ} (h0 : ∀i, h i 0 = 1) :
  (-g).prod h = g.prod (λi b, h i (- b)) :=
prod_map_range_index h0

omit dec
@[to_additive]
lemma prod_comm {ι₁ ι₂ : Sort*} {β₁ : ι₁ → Type*} {β₂ : ι₂ → Type*}
  [decidable_eq ι₁] [decidable_eq ι₂] [Π i, has_zero (β₁ i)] [Π i, has_zero (β₂ i)]
  [Π i (x : β₁ i), decidable (x ≠ 0)] [Π i (x : β₂ i), decidable (x ≠ 0)] [comm_monoid γ]
  (f₁ : Π₀ i, β₁ i) (f₂ : Π₀ i, β₂ i) (h : Π i, β₁ i → Π i, β₂ i → γ) :
  f₁.prod (λ i₁ x₁, f₂.prod $ λ i₂ x₂, h i₁ x₁ i₂ x₂) =
  f₂.prod (λ i₂ x₂, f₁.prod $ λ i₁ x₁, h i₁ x₁ i₂ x₂) := finset.prod_comm

@[simp] lemma sum_apply {ι₁ : Type u₁} [decidable_eq ι₁] {β₁ : ι₁ → Type v₁}
  [Π i₁, has_zero (β₁ i₁)] [Π i (x : β₁ i), decidable (x ≠ 0)]
  [Π i, add_comm_monoid (β i)]
  {f : Π₀ i₁, β₁ i₁} {g : Π i₁, β₁ i₁ → Π₀ i, β i} {i₂ : ι} :
  (f.sum g) i₂ = f.sum (λi₁ b, g i₁ b i₂) :=
(f.support.sum_hom (λf : Π₀ i, β i, f i₂)).symm
include dec

lemma support_sum {ι₁ : Type u₁} [decidable_eq ι₁] {β₁ : ι₁ → Type v₁}
  [Π i₁, has_zero (β₁ i₁)] [Π i (x : β₁ i), decidable (x ≠ 0)]
  [Π i, add_comm_monoid (β i)] [Π i (x : β i), decidable (x ≠ 0)]
  {f : Π₀ i₁, β₁ i₁} {g : Π i₁, β₁ i₁ → Π₀ i, β i} :
  (f.sum g).support ⊆ f.support.bUnion (λi, (g i (f i)).support) :=
have ∀i₁ : ι, f.sum (λ (i : ι₁) (b : β₁ i), (g i b) i₁) ≠ 0 →
    (∃ (i : ι₁), f i ≠ 0 ∧ ¬ (g i (f i)) i₁ = 0),
  from assume i₁ h,
  let ⟨i, hi, ne⟩ := finset.exists_ne_zero_of_sum_ne_zero h in
  ⟨i, (f.mem_support_iff i).mp hi, ne⟩,
by simpa [finset.subset_iff, mem_support_iff, finset.mem_bUnion, sum_apply] using this

@[simp, to_additive] lemma prod_one [Π i, add_comm_monoid (β i)] [Π i (x : β i), decidable (x ≠ 0)]
  [comm_monoid γ] {f : Π₀ i, β i} :
  f.prod (λi b, (1 : γ)) = 1 :=
finset.prod_const_one

@[simp, to_additive] lemma prod_mul [Π i, add_comm_monoid (β i)] [Π i (x : β i), decidable (x ≠ 0)]
  [comm_monoid γ] {f : Π₀ i, β i} {h₁ h₂ : Π i, β i → γ} :
  f.prod (λi b, h₁ i b * h₂ i b) = f.prod h₁ * f.prod h₂ :=
finset.prod_mul_distrib

@[simp, to_additive] lemma prod_inv [Π i, add_comm_monoid (β i)] [Π i (x : β i), decidable (x ≠ 0)]
  [comm_group γ] {f : Π₀ i, β i} {h : Π i, β i → γ} :
  f.prod (λi b, (h i b)⁻¹) = (f.prod h)⁻¹ :=
f.support.prod_hom (@has_inv.inv γ _)

@[to_additive]
lemma prod_add_index [Π i, add_comm_monoid (β i)] [Π i (x : β i), decidable (x ≠ 0)]
  [comm_monoid γ] {f g : Π₀ i, β i}
  {h : Π i, β i → γ} (h_zero : ∀i, h i 0 = 1) (h_add : ∀i b₁ b₂, h i (b₁ + b₂) = h i b₁ * h i b₂) :
  (f + g).prod h = f.prod h * g.prod h :=
have f_eq : ∏ i in f.support ∪ g.support, h i (f i) = f.prod h,
  from (finset.prod_subset (finset.subset_union_left _ _) $
    by simp [mem_support_iff, h_zero] {contextual := tt}).symm,
have g_eq : ∏ i in f.support ∪ g.support, h i (g i) = g.prod h,
  from (finset.prod_subset (finset.subset_union_right _ _) $
    by simp [mem_support_iff, h_zero] {contextual := tt}).symm,
calc ∏ i in (f + g).support, h i ((f + g) i) =
      ∏ i in f.support ∪ g.support, h i ((f + g) i) :
    finset.prod_subset support_add $
      by simp [mem_support_iff, h_zero] {contextual := tt}
  ... = (∏ i in f.support ∪ g.support, h i (f i)) *
      (∏ i in f.support ∪ g.support, h i (g i)) :
    by simp [h_add, finset.prod_mul_distrib]
  ... = _ : by rw [f_eq, g_eq]

/--
When summing over an `add_monoid_hom`, the decidability assumption is not needed, and the result is
also an `add_monoid_hom`.
-/
def sum_add_hom [Π i, add_zero_class (β i)] [add_comm_monoid γ] (φ : Π i, β i →+ γ) :
  (Π₀ i, β i) →+ γ :=
{ to_fun := (λ f,
    quotient.lift_on f (λ x, ∑ i in x.2.to_finset, φ i (x.1 i)) $ λ x y H,
    begin
      have H1 : x.2.to_finset ∩ y.2.to_finset ⊆ x.2.to_finset, from finset.inter_subset_left _ _,
      have H2 : x.2.to_finset ∩ y.2.to_finset ⊆ y.2.to_finset, from finset.inter_subset_right _ _,
      refine (finset.sum_subset H1 _).symm.trans
          ((finset.sum_congr rfl _).trans (finset.sum_subset H2 _)),
      { intros i H1 H2, rw finset.mem_inter at H2, rw H i,
        simp only [multiset.mem_to_finset] at H1 H2,
        rw [(y.3 i).resolve_left (mt (and.intro H1) H2), add_monoid_hom.map_zero] },
      { intros i H1, rw H i },
      { intros i H1 H2, rw finset.mem_inter at H2, rw ← H i,
        simp only [multiset.mem_to_finset] at H1 H2,
        rw [(x.3 i).resolve_left (mt (λ H3, and.intro H3 H1) H2), add_monoid_hom.map_zero] }
    end),
  map_add' := assume f g,
  begin
    refine quotient.induction_on f (λ x, _),
    refine quotient.induction_on g (λ y, _),
    change ∑ i in _, _ = (∑ i in _, _) + (∑ i in _, _),
    simp only, conv { to_lhs, congr, skip, funext, rw add_monoid_hom.map_add },
    simp only [finset.sum_add_distrib],
    congr' 1,
    { refine (finset.sum_subset _ _).symm,
      { intro i, simp only [multiset.mem_to_finset, multiset.mem_add], exact or.inl },
      { intros i H1 H2, simp only [multiset.mem_to_finset, multiset.mem_add] at H2,
        rw [(x.3 i).resolve_left H2, add_monoid_hom.map_zero] } },
    { refine (finset.sum_subset _ _).symm,
      { intro i, simp only [multiset.mem_to_finset, multiset.mem_add], exact or.inr },
      { intros i H1 H2, simp only [multiset.mem_to_finset, multiset.mem_add] at H2,
        rw [(y.3 i).resolve_left H2, add_monoid_hom.map_zero] } }
  end,
  map_zero' := rfl }

@[simp] lemma sum_add_hom_single [Π i, add_zero_class (β i)] [add_comm_monoid γ]
  (φ : Π i, β i →+ γ) (i) (x : β i) : sum_add_hom φ (single i x) = φ i x :=
(add_zero _).trans $ congr_arg (φ i) $ show (if H : i ∈ ({i} : finset _) then x else 0) = x,
from dif_pos $ finset.mem_singleton_self i

@[simp] lemma sum_add_hom_comp_single [Π i, add_zero_class (β i)] [add_comm_monoid γ]
  (f : Π i, β i →+ γ) (i : ι) :
  (sum_add_hom f).comp (single_add_hom β i) = f i :=
add_monoid_hom.ext $ λ x, sum_add_hom_single f i x

/-- While we didn't need decidable instances to define it, we do to reduce it to a sum -/
lemma sum_add_hom_apply [Π i, add_zero_class (β i)] [Π i (x : β i), decidable (x ≠ 0)]
  [add_comm_monoid γ] (φ : Π i, β i →+ γ) (f : Π₀ i, β i) :
  sum_add_hom φ f = f.sum (λ x, φ x) :=
begin
  refine quotient.induction_on f (λ x, _),
  change ∑ i in _, _ = (∑ i in finset.filter _ _, _),
  rw [finset.sum_filter, finset.sum_congr rfl],
  intros i _,
  dsimp only,
  split_ifs,
  refl,
  rw [(not_not.mp h), add_monoid_hom.map_zero],
end

omit dec
lemma sum_add_hom_comm {ι₁ ι₂ : Sort*} {β₁ : ι₁ → Type*} {β₂ : ι₂ → Type*} {γ : Type*}
  [decidable_eq ι₁] [decidable_eq ι₂] [Π i, add_zero_class (β₁ i)] [Π i, add_zero_class (β₂ i)]
  [add_comm_monoid γ]
  (f₁ : Π₀ i, β₁ i) (f₂ : Π₀ i, β₂ i) (h : Π i j, β₁ i →+ β₂ j →+ γ) :
  sum_add_hom (λ i₂, sum_add_hom (λ i₁, h i₁ i₂) f₁) f₂ =
  sum_add_hom (λ i₁, sum_add_hom (λ i₂, (h i₁ i₂).flip) f₂) f₁ :=
begin
  refine quotient.induction_on₂ f₁ f₂ (λ x₁ x₂, _),
  simp only [sum_add_hom, add_monoid_hom.finset_sum_apply, quotient.lift_on_mk,
    add_monoid_hom.coe_mk, add_monoid_hom.flip_apply],
  exact finset.sum_comm,
end

include dec
/-- The `dfinsupp` version of `finsupp.lift_add_hom`,-/
@[simps apply symm_apply]
def lift_add_hom [Π i, add_zero_class (β i)] [add_comm_monoid γ] :
  (Π i, β i →+ γ) ≃+ ((Π₀ i, β i) →+ γ) :=
{ to_fun := sum_add_hom,
  inv_fun := λ F i, F.comp (single_add_hom β i),
  left_inv := λ x, by { ext, simp },
  right_inv := λ ψ, by { ext, simp },
  map_add' := λ F G, by { ext, simp } }

/-- The `dfinsupp` version of `finsupp.lift_add_hom_single_add_hom`,-/
@[simp] lemma lift_add_hom_single_add_hom [Π i, add_comm_monoid (β i)] :
  lift_add_hom (single_add_hom β) = add_monoid_hom.id (Π₀ i, β i) :=
lift_add_hom.to_equiv.apply_eq_iff_eq_symm_apply.2 rfl

/-- The `dfinsupp` version of `finsupp.lift_add_hom_apply_single`,-/
lemma lift_add_hom_apply_single [Π i, add_zero_class (β i)] [add_comm_monoid γ]
  (f : Π i, β i →+ γ) (i : ι) (x : β i) :
  lift_add_hom f (single i x) = f i x :=
by simp

/-- The `dfinsupp` version of `finsupp.lift_add_hom_comp_single`,-/
lemma lift_add_hom_comp_single [Π i, add_zero_class (β i)] [add_comm_monoid γ]
  (f : Π i, β i →+ γ) (i : ι) :
  (lift_add_hom f).comp (single_add_hom β i) = f i :=
by simp

/-- The `dfinsupp` version of `finsupp.comp_lift_add_hom`,-/
lemma comp_lift_add_hom {δ : Type*} [Π i, add_zero_class (β i)] [add_comm_monoid γ]
  [add_comm_monoid δ] (g : γ →+ δ) (f : Π i, β i →+ γ) :
  g.comp (lift_add_hom f) = lift_add_hom (λ a, g.comp (f a)) :=
lift_add_hom.symm_apply_eq.1 $ funext $ λ a,
  by rw [lift_add_hom_symm_apply, add_monoid_hom.comp_assoc, lift_add_hom_comp_single]

@[simp]
lemma sum_add_hom_zero [Π i, add_zero_class (β i)] [add_comm_monoid γ] :
  sum_add_hom (λ i, (0 : β i →+ γ)) = 0 :=
(lift_add_hom : (Π i, β i →+ γ) ≃+ _).map_zero

@[simp]
lemma sum_add_hom_add [Π i, add_zero_class (β i)] [add_comm_monoid γ]
  (g : Π i, β i →+ γ) (h : Π i, β i →+ γ) :
  sum_add_hom (λ i, g i + h i) = sum_add_hom g + sum_add_hom h :=
lift_add_hom.map_add _ _

@[simp]
lemma sum_add_hom_single_add_hom [Π i, add_comm_monoid (β i)] :
  sum_add_hom (single_add_hom β) = add_monoid_hom.id _ :=
lift_add_hom_single_add_hom

lemma comp_sum_add_hom {δ : Type*} [Π i, add_zero_class (β i)] [add_comm_monoid γ]
  [add_comm_monoid δ] (g : γ →+ δ) (f : Π i, β i →+ γ) :
  g.comp (sum_add_hom f) = sum_add_hom (λ a, g.comp (f a)) :=
comp_lift_add_hom _ _

lemma sum_sub_index [Π i, add_group (β i)] [Π i (x : β i), decidable (x ≠ 0)]
  [add_comm_group γ] {f g : Π₀ i, β i}
  {h : Π i, β i → γ} (h_sub : ∀i b₁ b₂, h i (b₁ - b₂) = h i b₁ - h i b₂) :
  (f - g).sum h = f.sum h - g.sum h :=
begin
  have := (lift_add_hom (λ a, add_monoid_hom.of_map_sub (h a) (h_sub a))).map_sub f g,
  rw [lift_add_hom_apply, sum_add_hom_apply, sum_add_hom_apply, sum_add_hom_apply] at this,
  exact this,
end

@[to_additive]
lemma prod_finset_sum_index {γ : Type w} {α : Type x}
  [Π i, add_comm_monoid (β i)] [Π i (x : β i), decidable (x ≠ 0)]
  [comm_monoid γ]
  {s : finset α} {g : α → Π₀ i, β i}
  {h : Π i, β i → γ} (h_zero : ∀i, h i 0 = 1) (h_add : ∀i b₁ b₂, h i (b₁ + b₂) = h i b₁ * h i b₂) :
  ∏ i in s, (g i).prod h = (∑ i in s, g i).prod h :=
begin
  classical,
  exact finset.induction_on s
  (by simp [prod_zero_index])
  (by simp [prod_add_index, h_zero, h_add] {contextual := tt})
end

@[to_additive]
lemma prod_sum_index  {ι₁ : Type u₁} [decidable_eq ι₁] {β₁ : ι₁ → Type v₁}
  [Π i₁, has_zero (β₁ i₁)] [Π i (x : β₁ i), decidable (x ≠ 0)]
  [Π i, add_comm_monoid (β i)] [Π i (x : β i), decidable (x ≠ 0)]
  [comm_monoid γ]
  {f : Π₀ i₁, β₁ i₁} {g : Π i₁, β₁ i₁ → Π₀ i, β i}
  {h : Π i, β i → γ} (h_zero : ∀i, h i 0 = 1) (h_add : ∀i b₁ b₂, h i (b₁ + b₂) = h i b₁ * h i b₂) :
  (f.sum g).prod h = f.prod (λi b, (g i b).prod h) :=
(prod_finset_sum_index h_zero h_add).symm

@[simp] lemma sum_single [Π i, add_comm_monoid (β i)]
  [Π i (x : β i), decidable (x ≠ 0)] {f : Π₀ i, β i} :
  f.sum single = f :=
begin
  have := add_monoid_hom.congr_fun lift_add_hom_single_add_hom f,
  rw [lift_add_hom_apply, sum_add_hom_apply] at this,
  exact this,
end

@[to_additive]
lemma prod_subtype_domain_index [Π i, has_zero (β i)] [Π i (x : β i), decidable (x ≠ 0)]
  [comm_monoid γ] {v : Π₀ i, β i} {p : ι → Prop} [decidable_pred p]
  {h : Π i, β i → γ} (hp : ∀ x ∈ v.support, p x) :
  (v.subtype_domain p).prod (λi b, h i b) = v.prod h :=
finset.prod_bij (λp _, p)
  (by simp) (by simp)
  (assume ⟨a₀, ha₀⟩ ⟨a₁, ha₁⟩, by simp)
  (λ i hi, ⟨⟨i, hp i hi⟩, by simpa using hi, rfl⟩)

omit dec
lemma subtype_domain_sum [Π i, add_comm_monoid (β i)]
  {s : finset γ} {h : γ → Π₀ i, β i} {p : ι → Prop} [decidable_pred p] :
  (∑ c in s, h c).subtype_domain p = ∑ c in s, (h c).subtype_domain p :=
eq.symm (s.sum_hom _)

lemma subtype_domain_finsupp_sum {δ : γ → Type x} [decidable_eq γ]
  [Π c, has_zero (δ c)] [Π c (x : δ c), decidable (x ≠ 0)]
  [Π i, add_comm_monoid (β i)]
  {p : ι → Prop} [decidable_pred p]
  {s : Π₀ c, δ c} {h : Π c, δ c → Π₀ i, β i} :
  (s.sum h).subtype_domain p = s.sum (λc d, (h c d).subtype_domain p) :=
subtype_domain_sum

end prod_and_sum

/-! ### Bundled versions of `dfinsupp.map_range`

The names should match the equivalent bundled `finsupp.map_range` definitions.
-/

section map_range
omit dec

variables [Π i, add_zero_class (β i)] [Π i, add_zero_class (β₁ i)] [Π i, add_zero_class (β₂ i)]

lemma map_range_add (f : Π i, β₁ i → β₂ i) (hf : ∀ i, f i 0 = 0)
  (hf' : ∀ i x y, f i (x + y) = f i x + f i y) (g₁ g₂ : Π₀ i, β₁ i):
  map_range f hf (g₁ + g₂) = map_range f hf g₁ + map_range f hf g₂ :=
begin
  ext,
  simp only [map_range_apply f, coe_add, pi.add_apply, hf']
end

/-- `dfinsupp.map_range` as an `add_monoid_hom`. -/
@[simps apply]
def map_range.add_monoid_hom (f : Π i, β₁ i →+ β₂ i) : (Π₀ i, β₁ i) →+ (Π₀ i, β₂ i) :=
{ to_fun := map_range (λ i x, f i x) (λ i, (f i).map_zero),
  map_zero' := map_range_zero _ _,
  map_add' := map_range_add _ _ (λ i, (f i).map_add) }

@[simp]
lemma map_range.add_monoid_hom_id :
  map_range.add_monoid_hom (λ i, add_monoid_hom.id (β₂ i)) = add_monoid_hom.id _ :=
add_monoid_hom.ext map_range_id

lemma map_range.add_monoid_hom_comp (f : Π i, β₁ i →+ β₂ i) (f₂ : Π i, β i →+ β₁ i):
  map_range.add_monoid_hom (λ i, (f i).comp (f₂ i)) =
    (map_range.add_monoid_hom f).comp (map_range.add_monoid_hom f₂) :=
add_monoid_hom.ext $ map_range_comp (λ i x, f i x) (λ i x, f₂ i x) _ _ _

/-- `dfinsupp.map_range.add_monoid_hom` as an `add_equiv`. -/
@[simps apply]
def map_range.add_equiv (e : Π i, β₁ i ≃+ β₂ i) : (Π₀ i, β₁ i) ≃+ (Π₀ i, β₂ i) :=
{ to_fun := map_range (λ i x, e i x) (λ i, (e i).map_zero),
  inv_fun := map_range (λ i x, (e i).symm x) (λ i, (e i).symm.map_zero),
  left_inv := λ x, by rw ←map_range_comp; { simp_rw add_equiv.symm_comp_self, simp },
  right_inv := λ x, by rw ←map_range_comp; { simp_rw add_equiv.self_comp_symm, simp },
  .. map_range.add_monoid_hom (λ i, (e i).to_add_monoid_hom) }

@[simp]
lemma map_range.add_equiv_refl :
  (map_range.add_equiv $ λ i, add_equiv.refl (β₁ i)) = add_equiv.refl _ :=
add_equiv.ext map_range_id

lemma map_range.add_equiv_trans (f : Π i, β i ≃+ β₁ i) (f₂ : Π i, β₁ i ≃+ β₂ i):
  map_range.add_equiv (λ i, (f i).trans (f₂ i)) =
    (map_range.add_equiv f).trans (map_range.add_equiv f₂) :=
add_equiv.ext $ map_range_comp (λ i x, f₂ i x) (λ i x, f i x) _ _ _

@[simp]
lemma map_range.add_equiv_symm (e : Π i, β₁ i ≃+ β₂ i) :
  (map_range.add_equiv e).symm = map_range.add_equiv (λ i, (e i).symm) := rfl

end map_range

end dfinsupp

/-! ### Product and sum lemmas for bundled morphisms -/
section

variables [decidable_eq ι]

namespace monoid_hom
variables {R S : Type*}
variables [Π i, has_zero (β i)] [Π i (x : β i), decidable (x ≠ 0)]

@[simp, to_additive]
lemma map_dfinsupp_prod [comm_monoid R] [comm_monoid S]
  (h : R →* S) (f : Π₀ i, β i) (g : Π i, β i → R) :
  h (f.prod g) = f.prod (λ a b, h (g a b)) := h.map_prod _ _

@[to_additive]
lemma coe_dfinsupp_prod [monoid R] [comm_monoid S]
  (f : Π₀ i, β i) (g : Π i, β i → R →* S) :
  ⇑(f.prod g) = f.prod (λ a b, (g a b)) := coe_prod _ _

@[simp, to_additive]
lemma dfinsupp_prod_apply [monoid R] [comm_monoid S]
  (f : Π₀ i, β i) (g : Π i, β i → R →* S) (r : R) :
  (f.prod g) r = f.prod (λ a b, (g a b) r) := finset_prod_apply _ _ _

end monoid_hom

namespace add_monoid_hom
variables {R S : Type*}

open dfinsupp

/-! The above lemmas, repeated for `dfinsupp.sum_add_hom`. -/
@[simp]
lemma map_dfinsupp_sum_add_hom [add_comm_monoid R] [add_comm_monoid S] [Π i, add_comm_monoid (β i)]
  (h : R →+ S) (f : Π₀ i, β i) (g : Π i, β i →+ R) :
  h (sum_add_hom g f) = sum_add_hom (λ i, h.comp (g i)) f :=
congr_fun (comp_lift_add_hom h g) f

@[simp]
lemma dfinsupp_sum_add_hom_apply [add_zero_class R] [add_comm_monoid S] [Π i, add_comm_monoid (β i)]
  (f : Π₀ i, β i) (g : Π i, β i →+ R →+ S) (r : R) :
  (sum_add_hom g f) r = sum_add_hom (λ i, (eval r).comp (g i)) f :=
map_dfinsupp_sum_add_hom (eval r) f g

lemma coe_dfinsupp_sum_add_hom [add_zero_class R] [add_comm_monoid S] [Π i, add_comm_monoid (β i)]
  (f : Π₀ i, β i) (g : Π i, β i →+ R →+ S) :
  ⇑(sum_add_hom g f) = sum_add_hom (λ i, (coe_fn R S).comp (g i)) f :=
map_dfinsupp_sum_add_hom (coe_fn R S) f g

end add_monoid_hom

end


/-
Copyright (c) 2015 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Floris van Doorn

Theorems about 2-dimensional paths
-/

import .cubical.square
universes u v w
hott_theory

namespace hott
open function hott.is_equiv hott.equiv

namespace eq
  variables {A : Type _} {B : Type _} {C : Type _} {f : A → B} {a a' a₁ a₂ a₃ a₄ : A} {b b' : B}

  @[hott] theorem ap_is_constant_eq (p : Πx, f x = b) (q : a = a') :
      ap_is_constant f p q =
      eq_con_inv_of_con_eq ((eq_of_square (square_of_pathover (apd p q)))⁻¹ ⬝
      whisker_left (p a) (ap_constant q b)) :=
  begin
    induction q, dsimp [ap_constant, ap_is_constant, apd],
    hinduction p a, refl
  end

  @[hott] def ap_inv2 {p q : a = a'} (r : p = q)
    : square (ap (ap f) (inverse2 r))
             (inverse2 (ap (ap f) r))
             (ap_inv f p)
             (ap_inv f q) :=
  by induction r;exact hrfl

  @[hott] def ap_con2 {p₁ q₁ : a₁ = a₂} {p₂ q₂ : a₂ = a₃} (r₁ : p₁ = q₁) (r₂ : p₂ = q₂)
    : square (ap (ap f) (r₁ ◾ r₂))
             (ap (ap f) r₁ ◾ ap (ap f) r₂)
             (ap_con f p₁ p₂)
             (ap_con f q₁ q₂) :=
  by induction r₂;induction r₁;exact hrfl

  @[hott] theorem ap_con_right_inv_sq {A B : Type _} {a1 a2 : A} (f : A → B) (p : a1 = a2) :
    square (ap (ap f) (con.right_inv p))
           (con.right_inv (ap f p))
           (ap_con f p p⁻¹ ⬝ whisker_left _ (ap_inv f p))
           idp :=
  by induction p;apply hrefl

  @[hott] theorem ap_con_left_inv_sq {A B : Type _} {a1 a2 : A} (f : A → B) (p : a1 = a2) :
    square (ap (ap f) (con.left_inv p))
           (con.left_inv (ap f p))
           (ap_con f p⁻¹ p ⬝ whisker_right _ (ap_inv f p))
           idp :=
  by induction p;apply vrefl

  @[hott] def ap02_compose {A B C : Type _} (g : B → C) (f : A → B) {a a' : A}
    {p₁ p₂ : a = a'} (q : p₁ = p₂) :
    square (ap_compose g f p₁) (ap_compose g f p₂) (ap02 (g ∘ f) q) (ap02 g (ap02 f q)) :=
  by induction q; exact vrfl

  @[hott] def ap02_id {A : Type _} {a a' : A}
    {p₁ p₂ : a = a'} (q : p₁ = p₂) :
    square (ap_id p₁) (ap_id p₂) (ap02 id q) q :=
  by induction q; exact vrfl

  @[hott] theorem ap_ap_is_constant {A B C : Type _} (g : B → C) {f : A → B} {b : B}
    (p : Πx, f x = b) {x y : A} (q : x = y) :
    square (ap (ap g) (ap_is_constant f p q))
           (by exact (ap_is_constant (g ∘ f) (λa, ap g (p a)) q))
           (ap_compose g f q)⁻¹
           (ap_con _ _ _ ⬝ whisker_left _ (ap_inv _ _)) :=
  begin
    induction q, dsimp [ap_is_constant], hinduction (p x), apply ids
  end

  @[hott] theorem ap_ap_compose {A B C D : Type _} (h : C → D) (g : B → C) (f : A → B)
    {x y : A} (p : x = y) :
    square (ap_compose (h ∘ g) f p)
           (ap (ap h) (ap_compose g f p))
           (ap_compose h (g ∘ f) p)
           (ap_compose h g (ap f p)) :=
  by induction p; exact ids

  @[hott] def ap_compose_inv {A B C : Type _} (g : B → C) (f : A → B)
    {x y : A} (p : x = y) :
    square (ap_compose g f p⁻¹)
           (inverse2 (ap_compose g f p) ⬝ (ap_inv g (ap f p))⁻¹)
           (ap_inv (g ∘ f) p)
           (ap (ap g) (ap_inv f p)) :=
  by induction p; exact ids

  @[hott] def ap_compose_con (g : B → C) (f : A → B) (p : a₁ = a₂) (q : a₂ = a₃) :
    square (ap_compose g f (p ⬝ q))
           (ap_compose g f p ◾ ap_compose g f q ⬝ (ap_con g (ap f p) (ap f q))⁻¹)
           (ap_con (g ∘ f) p q)
           (ap (ap g) (ap_con f p q)) :=
  by induction q; induction p; exact ids

  @[hott] theorem ap_compose_natural {A B C : Type _} (g : B → C) (f : A → B)
    {x y : A} {p q : x = y} (r : p = q) :
    square (ap (ap (g ∘ f)) r)
           (ap (ap g ∘ ap f) r)
           (ap_compose g f p)
           (ap_compose g f q) :=
  natural_square_tr (ap_compose g f) r

  @[hott] theorem whisker_right_eq_of_con_inv_eq_idp {p q : a₁ = a₂} (r : p ⬝ q⁻¹ = idp) :
    whisker_right q⁻¹ (eq_of_con_inv_eq_idp r) ⬝ con.right_inv q = r :=
  begin induction q, hinduction r using eq.rec_symm, reflexivity end

  @[hott] theorem ap_eq_of_con_inv_eq_idp (f : A → B) {p q : a₁ = a₂} (r : p ⬝ q⁻¹ = idp)
  : ap02 f (eq_of_con_inv_eq_idp r) =
           eq_of_con_inv_eq_idp (whisker_left _ (ap_inv _ _)⁻¹ ⬝ (ap_con _ _ _)⁻¹ ⬝ ap02 f r) :=
  by induction q; hinduction r using eq.rec_symm; reflexivity

  @[hott] theorem eq_of_con_inv_eq_idp_con2 {p p' q q' : a₁ = a₂} (r : p = p') (s : q = q')
    (t : p' ⬝ q'⁻¹ = idp)
  : eq_of_con_inv_eq_idp (r ◾ inverse2 s ⬝ t) = r ⬝ eq_of_con_inv_eq_idp t ⬝ s⁻¹ :=
  by induction s; induction r; induction q; reflexivity

  @[hott] def naturality_apd_eq {A : Type _} {B : A → Type _} {a a₂ : A} {f g : Πa, B a}
    (H : f ~ g) (p : a = a₂)
    : apd f p = concato_eq (eq_concato (H a) (apd g p)) (H a₂)⁻¹ :=
  begin
    induction p, dsimp,
    hgeneralize : H a = p, revert p,
    hgeneralize : g a = x, intro p,
    induction p,
    reflexivity
  end

  @[hott] theorem con_tr_idp {P : A → Type _} {x y : A} (q : x = y) (u : P x) :
    con_tr idp q u = ap (λp, p ▸ u) (idp_con q) :=
  by induction q;reflexivity

  @[hott] def whisker_left_idp_con_eq_assoc
    {A : Type _} {a₁ a₂ a₃ : A} (p : a₁ = a₂) (q : a₂ = a₃)
    : whisker_left p (idp_con q)⁻¹ = con.assoc p idp q :=
  by induction q; reflexivity

  @[hott] def whisker_left_inverse2 {A : Type _} {a : A} {p : a = a} (q : p = idp)
    : whisker_left p q⁻² ⬝ q = con.right_inv p :=
  by hinduction q using eq.rec_symm; reflexivity

  @[hott] def cast_fn_cast_square {A : Type _} {B C : A → Type _} (f : Π⦃a⦄, B a → C a) {a₁ a₂ : A}
    (p : a₁ = a₂) (q : a₂ = a₁) (r : p ⬝ q = idp) (b : B a₁) :
    cast (ap C q) (f (cast (ap B p) b)) = f b :=
  have q⁻¹ = p, from inv_eq_of_idp_eq_con r⁻¹,
  begin induction this, induction q, reflexivity end

  @[hott] def ap011_ap_square_right {A B C : Type _} (f : A → B → C) {a a' : A} (p : a = a')
    {b₁ b₂ b₃ : B} {q₁₂ : b₁ = b₂} {q₂₃ : b₂ = b₃} {q₁₃ : b₁ = b₃} (r : q₁₂ ⬝ q₂₃ = q₁₃) :
    square (ap011 f p q₁₂) (ap (λx, f x b₃) p) (ap (f a) q₁₃) (ap (f a') q₂₃) :=
  by induction r; induction q₂₃; induction q₁₂; induction p; exact ids

  @[hott] def ap011_ap_square_left {A B C : Type _} (f : B → A → C) {a a' : A} (p : a = a')
    {b₁ b₂ b₃ : B} {q₁₂ : b₁ = b₂} {q₂₃ : b₂ = b₃} {q₁₃ : b₁ = b₃} (r : q₁₂ ⬝ q₂₃ = q₁₃) :
    square (ap011 f q₁₂ p) (ap (f b₃) p) (ap (λx, f x a) q₁₃) (ap (λx, f x a') q₂₃) :=
  by induction r; induction q₂₃; induction q₁₂; induction p; exact ids

  @[hott] def con2_assoc {A : Type _} {x y z t : A} {p p' : x = y} {q q' : y = z} {r r' : z = t}
    (h : p = p') (h' : q = q') (h'' : r = r') :
    square ((h ◾ h') ◾ h'') (h ◾ (h' ◾ h'')) (con.assoc p q r) (con.assoc p' q' r') :=
  by induction h; induction h'; induction h''; exact hrfl

  @[hott] def con_left_inv_idp {A : Type _} {x : A} {p : x = x} (q : p = idp)
    : con.left_inv p = q⁻² ◾ q :=
  by hinduction q using eq.rec_symm; reflexivity

  @[hott] def eckmann_hilton_con2 {A : Type _} {x : A} {p p' q q': idp = idp :> x = x}
    (h : p = p') (h' : q = q') : square (h ◾ h') (h' ◾ h) (eckmann_hilton p q) (eckmann_hilton p' q') :=
  by induction h; induction h'; exact hrfl

  @[hott] def ap_con_fn {A B : Type _} {a a' : A} {b : B} (g h : A → b = b) (p : a = a') :
    ap (λa, g a ⬝ h a) p = ap g p ◾ ap h p :=
  by induction p; reflexivity

  @[hott] def ap_eq_ap011 {A B C X : Type _} (f : A → B → C) (g : X → A) (h : X → B) {x x' : X}
    (p : x = x') : ap (λx, f (g x) (h x)) p = ap011 f (ap g p) (ap h p) :=
  by induction p; reflexivity

  @[hott] def ap_is_weakly_constant {A B : Type _} {f : A → B}
    (h : is_weakly_constant f) {a a' : A} (p : a = a') : ap f p = (h a a)⁻¹ ⬝ h a a' :=
  by induction p; exact (con.left_inv _)⁻¹

  @[hott] def ap_is_constant_idp {A B : Type _} {f : A → B} {b : B} (p : Πa, f a = b) {a : A} (q : a = a)
    (r : q = idp) : ap_is_constant f p q = ap02 f r ⬝ (con.right_inv (p a))⁻¹ :=
  by hinduction r using eq.rec_symm; exact (idp_con _)⁻¹

  @[hott] def con_right_inv_natural {A : Type _} {a a' : A} {p p' : a = a'} (q : p = p') :
    con.right_inv p = q ◾ q⁻² ⬝ con.right_inv p' :=
  by induction q; induction p; reflexivity

  @[hott] def whisker_right_ap {A B : Type _} {a a' : A}{b₁ b₂ b₃ : B} (q : b₂ = b₃) (f : A → b₁ = b₂)
    (p : a = a') : whisker_right q (ap f p) = ap (λa, f a ⬝ q) p :=
  by induction p; reflexivity

  @[hott] def ap02_ap_constant {A B C : Type _} {a a' : A} (f : B → C) (b : B) (p : a = a') :
    square (ap_constant p (f b)) (ap02 f (ap_constant p b)) (ap_compose f (λx, b) p) idp :=
  by induction p; exact ids

  @[hott] def ap_constant_compose {A B C : Type _} {a a' : A} (c : C) (f : A → B) (p : a = a') :
    square (ap_constant p c) (ap_constant (ap f p) c) (ap_compose (λx, c) f p) idp :=
  by induction p; exact ids

  @[hott] def ap02_constant {A B : Type _} {a a' : A} (b : B) {p p' : a = a'}
    (q : p = p') : square (ap_constant p b) (ap_constant p' b) (ap02 (λx, b) q) idp :=
  by induction q; exact vrfl

end eq
end hott


import Lean
open Lean

def checkGetBelowIndices (ctorName : Name) (indices : Array Nat) : MetaM Unit := do
  let actualIndices ← Meta.IndPredBelow.getBelowIndices ctorName
  if actualIndices != indices then
    throwError "wrong indices for {ctorName}: {actualIndices} ≟ {indices}"

namespace Ex
inductive LE : Nat → Nat → Prop
  | refl : LE n n
  | succ : LE n m → LE n m.succ
#eval checkGetBelowIndices ``LE.refl #[1]
#eval checkGetBelowIndices ``LE.succ #[1, 2, 3]

def typeOf {α : Sort u} (a : α) := α

theorem LE_brecOn : typeOf @LE.brecOn =
∀ {motive : (a a_1 : Nat) → LE a a_1 → Prop} {a a_1 : Nat} (x : LE a a_1),
  (∀ (a a_2 : Nat) (x : LE a a_2), @LE.below motive a a_2 x → motive a a_2 x) → motive a a_1 x := rfl

theorem LE.trans : LE m n → LE n o → LE m o := by
  intro h1 h2
  induction h2 with
  | refl => assumption
  | succ h2 ih => exact succ (ih h1)

theorem LE.trans' : LE m n → LE n o → LE m o
  | h1, refl    => h1
  | h1, succ h2 => succ (trans' h1 h2) -- the structural recursion in being performed on the implicit `Nat` parameter

inductive Even : Nat → Prop
  | zero : Even 0
  | ss   : Even n → Even n.succ.succ
#eval checkGetBelowIndices ``Even.zero #[]
#eval checkGetBelowIndices ``Even.ss #[1, 2]

theorem Even_brecOn : typeOf @Even.brecOn = ∀ {motive : (a : Nat) → Even a → Prop} {a : Nat} (x : Even a),
  (∀ (a : Nat) (x : Even a), @Even.below motive a x → motive a x) → motive a x := rfl

theorem Even.add : Even n → Even m → Even (n+m) := by
  intro h1 h2
  induction h2 with
  | zero => exact h1
  | ss h2 ih => exact ss ih

theorem Even.add' : Even n → Even m → Even (n+m)
  | h1, zero  => h1
  | h1, ss h2 => ss (add' h1 h2)  -- the structural recursion in being performed on the implicit `Nat` parameter

theorem mul_left_comm (n m o : Nat) : n * (m * o) = m * (n * o) := by
  rw [← Nat.mul_assoc, Nat.mul_comm n m, Nat.mul_assoc]

inductive Power2 : Nat → Prop
  | base : Power2 1
  | ind  : Power2 n → Power2 (2*n) -- Note that index here is not a constructor
#eval checkGetBelowIndices ``Power2.base #[]
#eval checkGetBelowIndices ``Power2.ind #[1, 2]

theorem Power2_brecOn : typeOf @Power2.brecOn = ∀ {motive : (a : Nat) → Power2 a → Prop} {a : Nat} (x : Power2 a),
  (∀ (a : Nat) (x : Power2 a), @Power2.below motive a x → motive a x) → motive a x := rfl

theorem Power2.mul : Power2 n → Power2 m → Power2 (n*m) := by
  intro h1 h2
  induction h2 with
  | base      => simp_all
  | ind h2 ih => exact mul_left_comm .. ▸ ind ih

/- The following example fails because the structural recursion cannot be performed on the `Nat`s and
   the `brecOn` construction doesn't work for inductive predicates -/
-- theorem Power2.mul' : Power2 n → Power2 m → Power2 (n*m)
--  | h1, base => by simp_all
--  | h1, ind h2 => mul_left_comm .. ▸ ind (mul' h1 h2)

inductive tm : Type :=
  | C : Nat → tm
  | P : tm → tm → tm

open tm

set_option hygiene false in
infixl:40 " ==> " => step
inductive step : tm → tm → Prop :=
  | ST_PlusConstConst : ∀ n1 n2,
      P (C n1) (C n2) ==> C (n1 + n2)
  | ST_Plus1 : ∀ t1 t1' t2,
      t1 ==> t1' →
      P t1 t2 ==> P t1' t2
  | ST_Plus2 : ∀ n1 t2 t2',
      t2 ==> t2' →
      P (C n1) t2 ==> P (C n1) t2'
#eval checkGetBelowIndices ``step.ST_PlusConstConst #[1, 2]
#eval checkGetBelowIndices ``step.ST_Plus1 #[1, 2, 3, 4]
#eval checkGetBelowIndices ``step.ST_Plus2 #[1, 2, 3, 4]

def deterministic {X : Type} (R : X → X → Prop) :=
  ∀ x y1 y2 : X, R x y1 → R x y2 → y1 = y2

theorem step_deterministic' : deterministic step := λ x y₁ y₂ hy₁ hy₂ =>
  @step.brecOn (λ s t st => ∀ y₂, s ==> y₂ → t = y₂) _ _ hy₁ (λ s t st hy₁ y₂ hy₂ =>
    match hy₁, hy₂ with
    | step.below.ST_PlusConstConst _ _, step.ST_PlusConstConst _ _ => rfl
    | step.below.ST_Plus1 _ _ _ hy₁ ih, step.ST_Plus1 _ t₁' _ _ => by rw [←ih t₁']; assumption
    | step.below.ST_Plus1 _ _ _ hy₁ ih, step.ST_Plus2 _ _ _ _ => by cases hy₁
    | step.below.ST_Plus2 _ _ _ _ ih, step.ST_Plus2 _ _ t₂ _ => by rw [←ih t₂]; assumption
    | step.below.ST_Plus2 _ _ _ hy₁ _, step.ST_PlusConstConst _ _ => by cases hy₁
    ) y₂ hy₂

section NestedRecursion

axiom f : Nat → Nat

inductive is_nat : Nat -> Prop
| Z : is_nat 0
| S {n} : is_nat n → is_nat (f n)
#eval checkGetBelowIndices ``is_nat.Z #[]
#eval checkGetBelowIndices ``is_nat.S #[1, 2]

axiom P : Nat → Prop
axiom F0 : P 0
axiom F1 : P (f 0)
axiom FS {n : Nat} : P n → P (f (f n))

-- we would like to write this
-- theorem foo : ∀ {n}, is_nat n → P n
-- | _, is_nat.Z => F0
-- | _, is_nat.S is_nat.Z => F1
-- | _, is_nat.S (is_nat.S h) => FS (foo h)

theorem foo' : ∀ {n}, is_nat n → P n := fun h =>
  @is_nat.brecOn (fun n hn => P n) _ h fun n h ih =>
  match ih with
  | is_nat.below.Z => F0
  | is_nat.below.S is_nat.below.Z _ => F1
  | is_nat.below.S (is_nat.below.S b hx) h₂ => FS hx

end NestedRecursion

end Ex


/-
Copyright (c) 2020 Patrick Massot. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Patrick Massot
-/
import analysis.specific_limits.basic

/-!
# Hofer's lemma

This is an elementary lemma about complete metric spaces. It is motivated by an
application to the bubbling-off analysis for holomorphic curves in symplectic topology.
We are *very* far away from having these applications, but the proof here is a nice
example of a proof needing to construct a sequence by induction in the middle of the proof.

## References:

* H. Hofer and C. Viterbo, *The Weinstein conjecture in the presence of holomorphic spheres*
-/

open_locale classical topological_space big_operators
open filter finset

local notation `d` := dist

lemma hofer {X: Type*} [metric_space X] [complete_space X]
  (x : X) (ε : ℝ) (ε_pos : 0 < ε)
  {ϕ : X → ℝ} (cont : continuous ϕ) (nonneg : ∀ y, 0 ≤ ϕ y) :
  ∃ (ε' > 0) (x' : X), ε' ≤ ε ∧
                       d x' x ≤ 2*ε ∧
                       ε * ϕ(x) ≤ ε' * ϕ x' ∧
                       ∀ y, d x' y ≤ ε' → ϕ y ≤ 2*ϕ x' :=
begin
  by_contradiction H,
  have reformulation : ∀ x' (k : ℕ), ε * ϕ x ≤ ε / 2 ^ k * ϕ x' ↔ 2^k * ϕ x ≤ ϕ x',
  { intros x' k,
    rw [div_mul_eq_mul_div, le_div_iff, mul_assoc, mul_le_mul_left ε_pos, mul_comm],
    exact pow_pos (by norm_num) k, },
  -- Now let's specialize to `ε/2^k`
  replace H : ∀ k : ℕ, ∀ x', d x' x ≤ 2 * ε ∧ 2^k * ϕ x ≤ ϕ x' →
    ∃ y, d x' y ≤ ε/2^k ∧ 2 * ϕ x' < ϕ y,
  { intros k x',
    push_neg at H,
    simpa [reformulation] using
      H (ε/2^k) (by simp [ε_pos, zero_lt_two]) x' (by simp [ε_pos, zero_lt_two, one_le_two]) },
  clear reformulation,
  haveI : nonempty X := ⟨x⟩,
  choose! F hF using H,  -- Use the axiom of choice
  -- Now define u by induction starting at x, with u_{n+1} = F(n, u_n)
  let u : ℕ → X := λ n, nat.rec_on n x F,
  have hu0 : u 0 = x := rfl,
  -- The properties of F translate to properties of u
  have hu :
    ∀ n,
      d (u n) x ≤ 2 * ε ∧ 2^n * ϕ x ≤ ϕ (u n) →
      d (u n) (u $ n + 1) ≤ ε / 2 ^ n ∧ 2 * ϕ (u n) < ϕ (u $ n + 1),
  { intro n,
    exact hF n (u n) },
  clear hF,
  -- Key properties of u, to be proven by induction
  have key : ∀ n, d (u n) (u (n + 1)) ≤ ε / 2 ^ n ∧ 2 * ϕ (u n) < ϕ (u (n + 1)),
  { intro n,
    induction n using nat.case_strong_induction_on with n IH,
    { specialize hu 0,
      simpa [hu0, mul_nonneg_iff, zero_le_one, ε_pos.le, le_refl] using hu },
    have A : d (u (n+1)) x ≤ 2 * ε,
    { rw [dist_comm],
      let r := range (n+1), -- range (n+1) = {0, ..., n}
      calc
      d (u 0) (u (n + 1))
          ≤ ∑ i in r, d (u i) (u $ i+1) : dist_le_range_sum_dist u (n + 1)
      ... ≤ ∑ i in r, ε/2^i             : sum_le_sum (λ i i_in, (IH i $ nat.lt_succ_iff.mp $
                                                                  finset.mem_range.mp i_in).1)
      ... = ∑ i in r, (1/2)^i*ε         : by { congr' with i, field_simp }
      ... = (∑ i in r, (1/2)^i)*ε       : finset.sum_mul.symm
      ... ≤ 2*ε                         : mul_le_mul_of_nonneg_right (sum_geometric_two_le _)
                                            (le_of_lt ε_pos), },
    have B : 2^(n+1) * ϕ x ≤ ϕ (u (n + 1)),
    { refine @geom_le (ϕ ∘ u) _ zero_le_two (n + 1) (λ m hm, _),
      exact (IH _ $ nat.lt_add_one_iff.1 hm).2.le },
    exact hu (n+1) ⟨A, B⟩, },
  cases forall_and_distrib.mp key with key₁ key₂,
  clear hu key,
  -- Hence u is Cauchy
  have cauchy_u : cauchy_seq u,
  { refine cauchy_seq_of_le_geometric _ ε one_half_lt_one (λ n, _),
    simpa only [one_div, inv_pow₀] using key₁ n },
  -- So u converges to some y
  obtain ⟨y, limy⟩ : ∃ y, tendsto u at_top (𝓝 y),
    from complete_space.complete cauchy_u,
  -- And ϕ ∘ u goes to +∞
  have lim_top : tendsto (ϕ ∘ u) at_top at_top,
  { let v := λ n, (ϕ ∘ u) (n+1),
    suffices : tendsto v at_top at_top,
      by rwa tendsto_add_at_top_iff_nat at this,
    have hv₀ : 0 < v 0,
    { have : 0 ≤ ϕ (u 0) := nonneg x,
      calc 0 ≤ 2 * ϕ (u 0) : by linarith
      ... < ϕ (u (0 + 1)) : key₂ 0 },
    apply tendsto_at_top_of_geom_le hv₀ one_lt_two,
    exact λ n, (key₂ (n+1)).le },
  -- But ϕ ∘ u also needs to go to ϕ(y)
  have lim : tendsto (ϕ ∘ u) at_top (𝓝 (ϕ y)),
    from tendsto.comp cont.continuous_at limy,
  -- So we have our contradiction!
  exact not_tendsto_at_top_of_tendsto_nhds lim lim_top,
end


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

import category_theory.adjunction.basic
import category_theory.yoneda
import category_theory.opposites

/-!
# Opposite adjunctions

This file contains constructions to relate adjunctions of functors to adjunctions of their
opposites.
These constructions are used to show uniqueness of adjoints (up to natural isomorphism).

## Tags
adjunction, opposite, uniqueness
-/

open category_theory

universes v₁ v₂ u₁ u₂ -- morphism levels before object levels. See note [category_theory universes].

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

namespace category_theory.adjunction

/-- If `G.op` is adjoint to `F.op` then `F` is adjoint to `G`. -/
@[simps unit_app counit_app] def adjoint_of_op_adjoint_op
  (F : C ⥤ D) (G : D ⥤ C) (h : G.op ⊣ F.op) : F ⊣ G :=
adjunction.mk_of_hom_equiv
{ hom_equiv := λ X Y,
  ((h.hom_equiv (opposite.op Y) (opposite.op X)).trans (op_equiv _ _)).symm.trans (op_equiv _ _) }

/-- If `G` is adjoint to `F.op` then `F` is adjoint to `G.unop`. -/
def adjoint_unop_of_adjoint_op (F : C ⥤ D) (G : Dᵒᵖ ⥤ Cᵒᵖ) (h : G ⊣ F.op) : F ⊣ G.unop :=
adjoint_of_op_adjoint_op F G.unop (h.of_nat_iso_left G.op_unop_iso.symm)

/-- If `G.op` is adjoint to `F` then `F.unop` is adjoint to `G`. -/
def unop_adjoint_of_op_adjoint (F : Cᵒᵖ ⥤ Dᵒᵖ) (G : D ⥤ C) (h : G.op ⊣ F) : F.unop ⊣ G :=
adjoint_of_op_adjoint_op _ _ (h.of_nat_iso_right F.op_unop_iso.symm)

/-- If `G` is adjoint to `F` then `F.unop` is adjoint to `G.unop`. -/
def unop_adjoint_unop_of_adjoint (F : Cᵒᵖ ⥤ Dᵒᵖ) (G : Dᵒᵖ ⥤ Cᵒᵖ) (h : G ⊣ F) : F.unop ⊣ G.unop :=
adjoint_unop_of_adjoint_op F.unop G (h.of_nat_iso_right F.op_unop_iso.symm)

/-- If `G` is adjoint to `F` then `F.op` is adjoint to `G.op`. -/
@[simps unit_app counit_app] def op_adjoint_op_of_adjoint
  (F : C ⥤ D) (G : D ⥤ C) (h : G ⊣ F) : F.op ⊣ G.op :=
adjunction.mk_of_hom_equiv
{ hom_equiv := λ X Y,
  (op_equiv _ Y).trans ((h.hom_equiv _ _).symm.trans (op_equiv X (opposite.op _)).symm) }

/-- If `G` is adjoint to `F.unop` then `F` is adjoint to `G.op`. -/
def adjoint_op_of_adjoint_unop (F : Cᵒᵖ ⥤ Dᵒᵖ) (G : D ⥤ C) (h : G ⊣ F.unop) : F ⊣ G.op :=
(op_adjoint_op_of_adjoint F.unop _ h).of_nat_iso_left F.op_unop_iso

/-- If `G.unop` is adjoint to `F` then `F.op` is adjoint to `G`. -/
def op_adjoint_of_unop_adjoint (F : C ⥤ D) (G : Dᵒᵖ ⥤ Cᵒᵖ) (h : G.unop ⊣ F) : F.op ⊣ G :=
(op_adjoint_op_of_adjoint _ G.unop h).of_nat_iso_right G.op_unop_iso

/-- If `G.unop` is adjoint to `F.unop` then `F` is adjoint to `G`. -/
def adjoint_of_unop_adjoint_unop (F : Cᵒᵖ ⥤ Dᵒᵖ) (G : Dᵒᵖ ⥤ Cᵒᵖ) (h : G.unop ⊣ F.unop) : F ⊣ G :=
(adjoint_op_of_adjoint_unop _ _ h).of_nat_iso_right G.op_unop_iso

/--
If `F` and `F'` are both adjoint to `G`, there is a natural isomorphism
`F.op ⋙ coyoneda ≅ F'.op ⋙ coyoneda`.
We use this in combination with `fully_faithful_cancel_right` to show left adjoints are unique.
-/
def left_adjoints_coyoneda_equiv {F F' : C ⥤ D} {G : D ⥤ C}
  (adj1 : F ⊣ G) (adj2 : F' ⊣ G):
  F.op ⋙ coyoneda ≅ F'.op ⋙ coyoneda :=
nat_iso.of_components
  (λ X, nat_iso.of_components
    (λ Y, ((adj1.hom_equiv X.unop Y).trans (adj2.hom_equiv X.unop Y).symm).to_iso)
    (by tidy))
  (by tidy)

/-- If `F` and `F'` are both left adjoint to `G`, then they are naturally isomorphic. -/
def left_adjoint_uniq {F F' : C ⥤ D} {G : D ⥤ C}
  (adj1 : F ⊣ G) (adj2 : F' ⊣ G) : F ≅ F' :=
nat_iso.remove_op (fully_faithful_cancel_right _ (left_adjoints_coyoneda_equiv adj2 adj1))

@[simp]
lemma hom_equiv_left_adjoint_uniq_hom_app {F F' : C ⥤ D} {G : D ⥤ C}
  (adj1 : F ⊣ G) (adj2 : F' ⊣ G) (x : C) :
  adj1.hom_equiv _ _ ((left_adjoint_uniq adj1 adj2).hom.app x) = adj2.unit.app x :=
begin
  apply (adj1.hom_equiv _ _).symm.injective,
  apply quiver.hom.op_inj,
  apply coyoneda.map_injective,
  swap, apply_instance,
  ext f y,
  simpa [left_adjoint_uniq, left_adjoints_coyoneda_equiv]
end

@[simp, reassoc]
lemma unit_left_adjoint_uniq_hom {F F' : C ⥤ D} {G : D ⥤ C} (adj1 : F ⊣ G) (adj2 : F' ⊣ G) :
  adj1.unit ≫ whisker_right (left_adjoint_uniq adj1 adj2).hom G = adj2.unit :=
begin
  ext x,
  rw [nat_trans.comp_app, ← hom_equiv_left_adjoint_uniq_hom_app adj1 adj2],
  simp [-hom_equiv_left_adjoint_uniq_hom_app, ←G.map_comp]
end

@[simp, reassoc]
lemma unit_left_adjoint_uniq_hom_app {F F' : C ⥤ D} {G : D ⥤ C}
  (adj1 : F ⊣ G) (adj2 : F' ⊣ G) (x : C) :
  adj1.unit.app x ≫ G.map ((left_adjoint_uniq adj1 adj2).hom.app x) = adj2.unit.app x :=
by { rw ← unit_left_adjoint_uniq_hom adj1 adj2, refl }

@[simp, reassoc]
lemma left_adjoint_uniq_hom_counit {F F' : C ⥤ D} {G : D ⥤ C} (adj1 : F ⊣ G) (adj2 : F' ⊣ G) :
  whisker_left G (left_adjoint_uniq adj1 adj2).hom ≫ adj2.counit = adj1.counit :=
begin
  ext x,
  apply quiver.hom.op_inj,
  apply coyoneda.map_injective,
  swap, apply_instance,
  ext y f,
  have : F.map (adj2.unit.app (G.obj x)) ≫ adj1.counit.app (F'.obj (G.obj x)) ≫
    adj2.counit.app x ≫ f = adj1.counit.app x ≫ f,
  { erw [← adj1.counit.naturality, ← F.map_comp_assoc], simpa },
  simpa [left_adjoint_uniq, left_adjoints_coyoneda_equiv] using this
end

@[simp, reassoc]
lemma left_adjoint_uniq_hom_app_counit {F F' : C ⥤ D} {G : D ⥤ C}
  (adj1 : F ⊣ G) (adj2 : F' ⊣ G) (x : D) :
  (left_adjoint_uniq adj1 adj2).hom.app (G.obj x) ≫ adj2.counit.app x = adj1.counit.app x :=
by { rw ← left_adjoint_uniq_hom_counit adj1 adj2, refl }

@[simp]
lemma left_adjoint_uniq_inv_app {F F' : C ⥤ D} {G : D ⥤ C}
  (adj1 : F ⊣ G) (adj2 : F' ⊣ G) (x : C) :
  (left_adjoint_uniq adj1 adj2).inv.app x = (left_adjoint_uniq adj2 adj1).hom.app x := rfl

@[simp, reassoc]
lemma left_adjoint_uniq_trans {F F' F'' : C ⥤ D} {G : D ⥤ C}
  (adj1 : F ⊣ G) (adj2 : F' ⊣ G) (adj3 : F'' ⊣ G) :
  (left_adjoint_uniq adj1 adj2).hom ≫ (left_adjoint_uniq adj2 adj3).hom =
    (left_adjoint_uniq adj1 adj3).hom :=
begin
  ext,
  apply quiver.hom.op_inj,
  apply coyoneda.map_injective,
  swap, apply_instance,
  ext,
  simp [left_adjoints_coyoneda_equiv, left_adjoint_uniq]
end

@[simp, reassoc]
lemma left_adjoint_uniq_trans_app {F F' F'' : C ⥤ D} {G : D ⥤ C}
  (adj1 : F ⊣ G) (adj2 : F' ⊣ G) (adj3 : F'' ⊣ G) (x : C) :
  (left_adjoint_uniq adj1 adj2).hom.app x ≫ (left_adjoint_uniq adj2 adj3).hom.app x =
    (left_adjoint_uniq adj1 adj3).hom.app x :=
by { rw ← left_adjoint_uniq_trans adj1 adj2 adj3, refl }

@[simp]
lemma left_adjoint_uniq_refl {F : C ⥤ D} {G : D ⥤ C} (adj1 : F ⊣ G) :
  (left_adjoint_uniq adj1 adj1).hom = 𝟙 _ :=
begin
  ext,
  apply quiver.hom.op_inj,
  apply coyoneda.map_injective,
  swap, apply_instance,
  ext,
  simp [left_adjoints_coyoneda_equiv, left_adjoint_uniq]
end

/-- If `G` and `G'` are both right adjoint to `F`, then they are naturally isomorphic. -/
def right_adjoint_uniq {F : C ⥤ D} {G G' : D ⥤ C}
  (adj1 : F ⊣ G) (adj2 : F ⊣ G') : G ≅ G' :=
nat_iso.remove_op
  (left_adjoint_uniq (op_adjoint_op_of_adjoint _ F adj2) (op_adjoint_op_of_adjoint _ _ adj1))

@[simp]
lemma hom_equiv_symm_right_adjoint_uniq_hom_app {F : C ⥤ D} {G G' : D ⥤ C}
  (adj1 : F ⊣ G) (adj2 : F ⊣ G') (x : D) :
  (adj2.hom_equiv _ _).symm ((right_adjoint_uniq adj1 adj2).hom.app x) = adj1.counit.app x :=
begin
  apply quiver.hom.op_inj,
  convert hom_equiv_left_adjoint_uniq_hom_app
    (op_adjoint_op_of_adjoint _ F adj2) (op_adjoint_op_of_adjoint _ _ adj1) (opposite.op x),
  simpa
end

@[simp, reassoc]
lemma unit_right_adjoint_uniq_hom_app {F : C ⥤ D} {G G' : D ⥤ C}
  (adj1 : F ⊣ G) (adj2 : F ⊣ G') (x : C) :
  adj1.unit.app x ≫ (right_adjoint_uniq adj1 adj2).hom.app (F.obj x) = adj2.unit.app x :=
begin
  apply quiver.hom.op_inj,
  convert left_adjoint_uniq_hom_app_counit
    (op_adjoint_op_of_adjoint _ _ adj2) (op_adjoint_op_of_adjoint _ _ adj1) (opposite.op x),
  all_goals { simpa }
end

@[simp, reassoc]
lemma unit_right_adjoint_uniq_hom {F : C ⥤ D} {G G' : D ⥤ C} (adj1 : F ⊣ G) (adj2 : F ⊣ G') :
  adj1.unit ≫ whisker_left F (right_adjoint_uniq adj1 adj2).hom = adj2.unit :=
by { ext x, simp }

@[simp, reassoc]
lemma right_adjoint_uniq_hom_app_counit {F : C ⥤ D} {G G' : D ⥤ C}
  (adj1 : F ⊣ G) (adj2 : F ⊣ G') (x : D) :
  F.map ((right_adjoint_uniq adj1 adj2).hom.app x) ≫ adj2.counit.app x = adj1.counit.app x :=
begin
  apply quiver.hom.op_inj,
  convert unit_left_adjoint_uniq_hom_app
    (op_adjoint_op_of_adjoint _ _ adj2) (op_adjoint_op_of_adjoint _ _ adj1) (opposite.op x),
  all_goals { simpa }
end

@[simp, reassoc]
lemma right_adjoint_uniq_hom_counit {F : C ⥤ D} {G G' : D ⥤ C} (adj1 : F ⊣ G) (adj2 : F ⊣ G') :
  whisker_right (right_adjoint_uniq adj1 adj2).hom F ≫ adj2.counit = adj1.counit :=
by { ext, simp }

@[simp]
lemma right_adjoint_uniq_inv_app {F : C ⥤ D} {G G' : D ⥤ C}
  (adj1 : F ⊣ G) (adj2 : F ⊣ G') (x : D) :
  (right_adjoint_uniq adj1 adj2).inv.app x = (right_adjoint_uniq adj2 adj1).hom.app x := rfl

@[simp, reassoc]
lemma right_adjoint_uniq_trans_app {F : C ⥤ D} {G G' G'' : D ⥤ C}
  (adj1 : F ⊣ G) (adj2 : F ⊣ G') (adj3 : F ⊣ G'') (x : D) :
  (right_adjoint_uniq adj1 adj2).hom.app x ≫ (right_adjoint_uniq adj2 adj3).hom.app x =
    (right_adjoint_uniq adj1 adj3).hom.app x :=
begin
  apply quiver.hom.op_inj,
  exact left_adjoint_uniq_trans_app (op_adjoint_op_of_adjoint _ _ adj3)
    (op_adjoint_op_of_adjoint _ _ adj2) (op_adjoint_op_of_adjoint _ _ adj1) (opposite.op x)
end

@[simp, reassoc]
lemma right_adjoint_uniq_trans {F : C ⥤ D} {G G' G'' : D ⥤ C}
  (adj1 : F ⊣ G) (adj2 : F ⊣ G') (adj3 : F ⊣ G'') :
  (right_adjoint_uniq adj1 adj2).hom ≫ (right_adjoint_uniq adj2 adj3).hom =
    (right_adjoint_uniq adj1 adj3).hom :=
by { ext, simp }

@[simp]
lemma right_adjoint_uniq_refl {F : C ⥤ D} {G : D ⥤ C} (adj1 : F ⊣ G) :
  (right_adjoint_uniq adj1 adj1).hom = 𝟙 _ :=
by { delta right_adjoint_uniq, simp }

/--
Given two adjunctions, if the left adjoints are naturally isomorphic, then so are the right
adjoints.
-/
def nat_iso_of_left_adjoint_nat_iso {F F' : C ⥤ D} {G G' : D ⥤ C}
  (adj1 : F ⊣ G) (adj2 : F' ⊣ G') (l : F ≅ F') :
  G ≅ G' :=
right_adjoint_uniq adj1 (adj2.of_nat_iso_left l.symm)

/--
Given two adjunctions, if the right adjoints are naturally isomorphic, then so are the left
adjoints.
-/
def nat_iso_of_right_adjoint_nat_iso {F F' : C ⥤ D} {G G' : D ⥤ C}
  (adj1 : F ⊣ G) (adj2 : F' ⊣ G') (r : G ≅ G') :
  F ≅ F' :=
left_adjoint_uniq adj1 (adj2.of_nat_iso_right r.symm)

end category_theory.adjunction


/-
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, Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.topology.continuous_on
import Mathlib.group_theory.submonoid.basic
import Mathlib.algebra.group.prod
import Mathlib.algebra.pointwise
import Mathlib.PostPort

universes u_5 l u_3 u_1 u_4 u_2

namespace Mathlib

/-!
# Theory of topological monoids

In this file we define mixin classes `has_continuous_mul` and `has_continuous_add`. While in many
applications the underlying type is a monoid (multiplicative or additive), we do not require this in
the definitions.
-/

/-- Basic hypothesis to talk about a topological additive monoid or a topological additive
semigroup. A topological additive monoid over `α`, for example, is obtained by requiring both the
instances `add_monoid α` and `has_continuous_add α`. -/
class has_continuous_add (M : Type u_5) [topological_space M] [Add M] where
  continuous_add : continuous fun (p : M × M) => prod.fst p + prod.snd p

/-- Basic hypothesis to talk about a topological monoid or a topological semigroup.
A topological monoid over `α`, for example, is obtained by requiring both the instances `monoid α`
and `has_continuous_mul α`. -/
class has_continuous_mul (M : Type u_5) [topological_space M] [Mul M] where
  continuous_mul : continuous fun (p : M × M) => prod.fst p * prod.snd p

theorem continuous_add {M : Type u_3} [topological_space M] [Add M] [has_continuous_add M] :
    continuous fun (p : M × M) => prod.fst p + prod.snd p :=
  has_continuous_add.continuous_add

theorem continuous.mul {α : Type u_1} {M : Type u_3} [topological_space M] [Mul M]
    [has_continuous_mul M] [topological_space α] {f : α → M} {g : α → M} (hf : continuous f)
    (hg : continuous g) : continuous fun (x : α) => f x * g x :=
  continuous.comp continuous_mul (continuous.prod_mk hf hg)

-- should `to_additive` be doing this?

theorem continuous_add_left {M : Type u_3} [topological_space M] [Add M] [has_continuous_add M]
    (a : M) : continuous fun (b : M) => a + b :=
  continuous.add continuous_const continuous_id

theorem continuous_add_right {M : Type u_3} [topological_space M] [Add M] [has_continuous_add M]
    (a : M) : continuous fun (b : M) => b + a :=
  continuous.add continuous_id continuous_const

theorem continuous_on.add {α : Type u_1} {M : Type u_3} [topological_space M] [Add M]
    [has_continuous_add M] [topological_space α] {f : α → M} {g : α → M} {s : set α}
    (hf : continuous_on f s) (hg : continuous_on g s) :
    continuous_on (fun (x : α) => f x + g x) s :=
  continuous.comp_continuous_on continuous_add (continuous_on.prod hf hg)

theorem tendsto_add {M : Type u_3} [topological_space M] [Add M] [has_continuous_add M] {a : M}
    {b : M} :
    filter.tendsto (fun (p : M × M) => prod.fst p + prod.snd p) (nhds (a, b)) (nhds (a + b)) :=
  iff.mp continuous_iff_continuous_at has_continuous_add.continuous_add (a, b)

theorem filter.tendsto.add {α : Type u_1} {M : Type u_3} [topological_space M] [Add M]
    [has_continuous_add M] {f : α → M} {g : α → M} {x : filter α} {a : M} {b : M}
    (hf : filter.tendsto f x (nhds a)) (hg : filter.tendsto g x (nhds b)) :
    filter.tendsto (fun (x : α) => f x + g x) x (nhds (a + b)) :=
  filter.tendsto.comp tendsto_add (filter.tendsto.prod_mk_nhds hf hg)

theorem tendsto.const_mul {α : Type u_1} {M : Type u_3} [topological_space M] [Mul M]
    [has_continuous_mul M] (b : M) {c : M} {f : α → M} {l : filter α}
    (h : filter.tendsto (fun (k : α) => f k) l (nhds c)) :
    filter.tendsto (fun (k : α) => b * f k) l (nhds (b * c)) :=
  filter.tendsto.mul tendsto_const_nhds h

theorem tendsto.add_const {α : Type u_1} {M : Type u_3} [topological_space M] [Add M]
    [has_continuous_add M] (b : M) {c : M} {f : α → M} {l : filter α}
    (h : filter.tendsto (fun (k : α) => f k) l (nhds c)) :
    filter.tendsto (fun (k : α) => f k + b) l (nhds (c + b)) :=
  filter.tendsto.add h tendsto_const_nhds

theorem continuous_at.add {α : Type u_1} {M : Type u_3} [topological_space M] [Add M]
    [has_continuous_add M] [topological_space α] {f : α → M} {g : α → M} {x : α}
    (hf : continuous_at f x) (hg : continuous_at g x) :
    continuous_at (fun (x : α) => f x + g x) x :=
  filter.tendsto.add hf hg

theorem continuous_within_at.add {α : Type u_1} {M : Type u_3} [topological_space M] [Add M]
    [has_continuous_add M] [topological_space α] {f : α → M} {g : α → M} {s : set α} {x : α}
    (hf : continuous_within_at f s x) (hg : continuous_within_at g s x) :
    continuous_within_at (fun (x : α) => f x + g x) s x :=
  filter.tendsto.add hf hg

protected instance prod.has_continuous_mul {M : Type u_3} {N : Type u_4} [topological_space M]
    [Mul M] [has_continuous_mul M] [topological_space N] [Mul N] [has_continuous_mul N] :
    has_continuous_mul (M × N) :=
  has_continuous_mul.mk
    (continuous.prod_mk
      (continuous.mul (continuous.comp continuous_fst continuous_fst)
        (continuous.comp continuous_fst continuous_snd))
      (continuous.mul (continuous.comp continuous_snd continuous_fst)
        (continuous.comp continuous_snd continuous_snd)))

protected instance has_continuous_mul_of_discrete_topology {N : Type u_4} [topological_space N]
    [Mul N] [discrete_topology N] : has_continuous_mul N :=
  has_continuous_mul.mk continuous_of_discrete_topology

theorem has_continuous_mul.of_nhds_one {M : Type (max u_1 u_2)} [monoid M] [topological_space M]
    (hmul : filter.tendsto (function.uncurry Mul.mul) (filter.prod (nhds 1) (nhds 1)) (nhds 1))
    (hleft : ∀ (x₀ : M), nhds x₀ = filter.map (fun (x : M) => x₀ * x) (nhds 1))
    (hright : ∀ (x₀ : M), nhds x₀ = filter.map (fun (x : M) => x * x₀) (nhds 1)) :
    has_continuous_mul M :=
  sorry

theorem has_continuous_mul_of_comm_of_nhds_one (M : Type (max u_1 u_2)) [comm_monoid M]
    [topological_space M]
    (hmul : filter.tendsto (function.uncurry Mul.mul) (filter.prod (nhds 1) (nhds 1)) (nhds 1))
    (hleft : ∀ (x₀ : M), nhds x₀ = filter.map (fun (x : M) => x₀ * x) (nhds 1)) :
    has_continuous_mul M :=
  sorry

theorem add_submonoid.top_closure_add_self_subset {M : Type u_3} [topological_space M]
    [add_monoid M] [has_continuous_add M] (s : add_submonoid M) :
    closure ↑s + closure ↑s ⊆ closure ↑s :=
  sorry

theorem submonoid.top_closure_mul_self_eq {M : Type u_3} [topological_space M] [monoid M]
    [has_continuous_mul M] (s : submonoid M) : closure ↑s * closure ↑s = closure ↑s :=
  sorry

/-- The (topological-space) closure of a submonoid of a space `M` with `has_continuous_mul` is
itself a submonoid. -/
def add_submonoid.topological_closure {M : Type u_3} [topological_space M] [add_monoid M]
    [has_continuous_add M] (s : add_submonoid M) : add_submonoid M :=
  add_submonoid.mk (closure ↑s) sorry sorry

theorem submonoid.submonoid_topological_closure {M : Type u_3} [topological_space M] [monoid M]
    [has_continuous_mul M] (s : submonoid M) : s ≤ submonoid.topological_closure s :=
  subset_closure

theorem submonoid.is_closed_topological_closure {M : Type u_3} [topological_space M] [monoid M]
    [has_continuous_mul M] (s : submonoid M) : is_closed ↑(submonoid.topological_closure s) :=
  sorry

theorem submonoid.topological_closure_minimal {M : Type u_3} [topological_space M] [monoid M]
    [has_continuous_mul M] (s : submonoid M) {t : submonoid M} (h : s ≤ t) (ht : is_closed ↑t) :
    submonoid.topological_closure s ≤ t :=
  closure_minimal h ht

theorem exists_open_nhds_zero_half {M : Type u_3} [topological_space M] [add_monoid M]
    [has_continuous_add M] {s : set M} (hs : s ∈ nhds 0) :
    ∃ (V : set M), is_open V ∧ 0 ∈ V ∧ ∀ (v : M), v ∈ V → ∀ (w : M), w ∈ V → v + w ∈ s :=
  sorry

theorem exists_nhds_zero_half {M : Type u_3} [topological_space M] [add_monoid M]
    [has_continuous_add M] {s : set M} (hs : s ∈ nhds 0) :
    ∃ (V : set M), ∃ (H : V ∈ nhds 0), ∀ (v : M), v ∈ V → ∀ (w : M), w ∈ V → v + w ∈ s :=
  sorry

theorem exists_nhds_one_split4 {M : Type u_3} [topological_space M] [monoid M]
    [has_continuous_mul M] {u : set M} (hu : u ∈ nhds 1) :
    ∃ (V : set M),
        ∃ (H : V ∈ nhds 1), ∀ {v w s t : M}, v ∈ V → w ∈ V → s ∈ V → t ∈ V → v * w * s * t ∈ u :=
  sorry

/-- Given a neighborhood `U` of `1` there is an open neighborhood `V` of `1`
such that `VV ⊆ U`. -/
theorem exists_open_nhds_one_mul_subset {M : Type u_3} [topological_space M] [monoid M]
    [has_continuous_mul M] {U : set M} (hU : U ∈ nhds 1) :
    ∃ (V : set M), is_open V ∧ 1 ∈ V ∧ V * V ⊆ U :=
  sorry

theorem tendsto_list_sum {α : Type u_1} {β : Type u_2} {M : Type u_3} [topological_space M]
    [add_monoid M] [has_continuous_add M] {f : β → α → M} {x : filter α} {a : β → M} (l : List β) :
    (∀ (c : β), c ∈ l → filter.tendsto (f c) x (nhds (a c))) →
        filter.tendsto (fun (b : α) => list.sum (list.map (fun (c : β) => f c b) l)) x
          (nhds (list.sum (list.map a l))) :=
  sorry

theorem continuous_list_sum {α : Type u_1} {β : Type u_2} {M : Type u_3} [topological_space M]
    [add_monoid M] [has_continuous_add M] [topological_space α] {f : β → α → M} (l : List β)
    (h : ∀ (c : β), c ∈ l → continuous (f c)) :
    continuous fun (a : α) => list.sum (list.map (fun (c : β) => f c a) l) :=
  iff.mpr continuous_iff_continuous_at
    fun (x : α) =>
      tendsto_list_sum l fun (c : β) (hc : c ∈ l) => iff.mp continuous_iff_continuous_at (h c hc) x

-- @[to_additive continuous_smul]

theorem continuous_pow {M : Type u_3} [topological_space M] [monoid M] [has_continuous_mul M]
    (n : ℕ) : continuous fun (a : M) => a ^ n :=
  sorry

theorem continuous.pow {α : Type u_1} {M : Type u_3} [topological_space M] [monoid M]
    [has_continuous_mul M] {f : α → M} [topological_space α] (h : continuous f) (n : ℕ) :
    continuous fun (b : α) => f b ^ n :=
  continuous.comp (continuous_pow n) h

theorem submonoid.mem_nhds_one {M : Type u_3} [topological_space M] [comm_monoid M]
    (S : submonoid M) (oS : is_open ↑S) : ↑S ∈ nhds 1 :=
  mem_nhds_sets oS (submonoid.one_mem S)

theorem tendsto_multiset_prod {α : Type u_1} {β : Type u_2} {M : Type u_3} [topological_space M]
    [comm_monoid M] [has_continuous_mul M] {f : β → α → M} {x : filter α} {a : β → M}
    (s : multiset β) :
    (∀ (c : β), c ∈ s → filter.tendsto (f c) x (nhds (a c))) →
        filter.tendsto (fun (b : α) => multiset.prod (multiset.map (fun (c : β) => f c b) s)) x
          (nhds (multiset.prod (multiset.map a s))) :=
  sorry

theorem tendsto_finset_sum {α : Type u_1} {β : Type u_2} {M : Type u_3} [topological_space M]
    [add_comm_monoid M] [has_continuous_add M] {f : β → α → M} {x : filter α} {a : β → M}
    (s : finset β) :
    (∀ (c : β), c ∈ s → filter.tendsto (f c) x (nhds (a c))) →
        filter.tendsto (fun (b : α) => finset.sum s fun (c : β) => f c b) x
          (nhds (finset.sum s fun (c : β) => a c)) :=
  tendsto_multiset_sum (finset.val s)

theorem continuous_multiset_prod {α : Type u_1} {β : Type u_2} {M : Type u_3} [topological_space M]
    [comm_monoid M] [has_continuous_mul M] [topological_space α] {f : β → α → M} (s : multiset β) :
    (∀ (c : β), c ∈ s → continuous (f c)) →
        continuous fun (a : α) => multiset.prod (multiset.map (fun (c : β) => f c a) s) :=
  sorry

theorem continuous_finset_prod {α : Type u_1} {β : Type u_2} {M : Type u_3} [topological_space M]
    [comm_monoid M] [has_continuous_mul M] [topological_space α] {f : β → α → M} (s : finset β) :
    (∀ (c : β), c ∈ s → continuous (f c)) →
        continuous fun (a : α) => finset.prod s fun (c : β) => f c a :=
  continuous_multiset_prod (finset.val s)

-- should `to_additive` be doing this?

protected instance additive.has_continuous_add {M : Type u_1} [h : topological_space M] [Mul M]
    [has_continuous_mul M] : has_continuous_add (additive M) :=
  has_continuous_add.mk continuous_mul

protected instance multiplicative.has_continuous_mul {M : Type u_1} [h : topological_space M]
    [Add M] [has_continuous_add M] : has_continuous_mul (multiplicative M) :=
  has_continuous_mul.mk continuous_add

end Mathlib


import logic.funrel

/-!
 * bool supported on a truth value.
--/

@[reducible]
definition subbool (p : Prop) : Type := {b // p ∨ b=ff}

instance (p : Prop) : inhabited (subbool p) := inhabited.mk ⟨ff,or.inr rfl⟩
instance (p : Prop) : has_zero (subbool p) := has_zero.mk ⟨ff,or.inr rfl⟩
instance (p : Prop) : decidable_eq (subbool p) :=
  λ a b, @decidable.cases_on (a.val=b.val) (λ_, decidable (a=b)) (bool.decidable_eq a.val b.val) (λ hn, is_false (λ (h : a=b), hn (congr (@rfl _ subtype.val) h))) (λ h, is_true (subtype.eq h))

instance : subsingleton (subbool false) :=
  begin
    constructor,
    intros a b,
    apply subtype.eq,
    apply a.property.elim; try { exact false.elim },
    apply b.property.elim; try { exact false.elim },
    intros hb ha,
    rw [hb, ha]
  end

namespace subbool

@[reducible,inline]
protected
definition ff (p : Prop) : subbool p := ⟨ff,or.inr rfl⟩

@[reducible,inline]
protected
definition tt {p : Prop} : p → subbool p := λ h, ⟨tt,or.inl h⟩

@[reducible]
protected
definition and {p : Prop} : subbool p → subbool p → subbool p
| ⟨tt,hl⟩ ⟨tt,_⟩ := ⟨tt,or.elim hl or.inl (λ tf, bool.no_confusion tf)⟩
| _ _ := ⟨ff,or.inr rfl⟩

@[reducible]
protected
definition or {p : Prop} : subbool p → subbool p → subbool p
| ⟨ff,_⟩ ⟨ff,_⟩ := ⟨ff, by right; refl⟩
| ⟨ff,_⟩ ⟨tt,qt⟩ := ⟨tt, qt.elim _root_.or.inl (λ tf, bool.no_confusion tf)⟩
| ⟨tt,qt⟩ ⟨ff,_⟩ := ⟨tt, qt.elim _root_.or.inl (λ tf, bool.no_confusion tf)⟩
| ⟨tt,qt⟩ ⟨tt,_⟩ := ⟨tt, qt.elim _root_.or.inl (λ tf, bool.no_confusion tf)⟩

@[reducible]
definition xor {p : Prop} : subbool p → subbool p → subbool p
| ⟨ff,_⟩ ⟨ff,_⟩ := ⟨ff, or.inr rfl⟩
| ⟨ff,_⟩ ⟨tt,qt⟩ := ⟨tt, or.elim qt or.inl (λ tf, bool.no_confusion tf)⟩
| ⟨tt,qt⟩ ⟨ff,_⟩ := ⟨tt, or.elim qt or.inl (λ tf, bool.no_confusion tf)⟩
| ⟨tt,_⟩ ⟨tt,_⟩ := ⟨ff, or.inr rfl⟩

@[simp]
protected
lemma xor_ff {p : Prop} (a : subbool p) : xor a ⟨ff,or.inr rfl⟩ = a :=
  by cases a; cases a_val; unfold xor

@[simp]
protected
lemma ff_xor {p : Prop} (a : subbool p) : xor ⟨ff,or.inr rfl⟩ a = a :=
  by cases a; cases a_val; unfold xor

@[simp]
protected
lemma xor_self {p : Prop} (a : subbool p) : xor a a = ⟨ff,or.inr rfl⟩ :=
  by cases a; cases a_val; unfold xor

protected
lemma xor_comm {p : Prop} (a b : subbool p) : xor a b = xor b a :=
  by cases a; cases a_val; cases b; cases b_val; unfold xor

protected
lemma xor_assoc {p : Prop} (a b c : subbool p) : xor (xor a b) c = xor a (xor b c) :=
  by cases a; cases a_val; cases b; cases b_val; cases c; cases c_val; unfold xor

--- Relax the restriction on the support.
@[reducible]
definition relax {p q : Prop} (hpq : p → q) : subbool p → subbool q
| ⟨a,ha⟩ := ⟨a, ha.elim (or.inl ∘ hpq) or.inr⟩

@[reducible,inline]
definition to_bool {p : Prop} : subbool p → bool := subtype.val

@[reducible]
definition from_bool (p : Prop) : bool → subbool true := λ x, ⟨x,or.inl true.intro⟩

end subbool


/-
Copyright (c) 2022 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser
-/
import linear_algebra.clifford_algebra.conjugation

/-!
# Recursive computation rules for the Clifford algebra

This file provides API for a special case `clifford_algebra.foldr` of the universal property
`clifford_algebra.lift` with `A = module.End R N` for some arbitrary module `N`. This specialization
resembles the `list.foldr` operation, allowing a bilinear map to be "folded" along the generators.

For convenience, this file also provides `clifford_algebra.foldl`, implemented via
`clifford_algebra.reverse`

## Main definitions

* `clifford_algebra.foldr`: a computation rule for building linear maps out of the clifford
  algebra starting on the right, analogous to using `list.foldr` on the generators.
* `clifford_algebra.foldl`: a computation rule for building linear maps out of the clifford
  algebra starting on the left, analogous to using `list.foldl` on the generators.

## Main statements

* `clifford_algebra.right_induction`: an induction rule that adds generators from the right.
* `clifford_algebra.left_induction`: an induction rule that adds generators from the left.
-/

universes u1 u2 u3

variables {R M N : Type*}
variables [comm_ring R] [add_comm_group M] [add_comm_group N]
variables [module R M] [module R N]
variables (Q : quadratic_form R M)

namespace clifford_algebra

section foldr

/-- Fold a bilinear map along the generators of a term of the clifford algebra, with the rule
given by `foldr Q f hf n (ι Q m * x) = f m (foldr Q f hf n x)`.

For example, `foldr f hf n (r • ι R u + ι R v * ι R w) = r • f u n + f v (f w n)`. -/
def foldr (f : M →ₗ[R] N →ₗ[R] N) (hf : ∀ m x, f m (f m x) = Q m • x) :
  N →ₗ[R] clifford_algebra Q →ₗ[R] N :=
(clifford_algebra.lift Q ⟨f, λ v, linear_map.ext $ hf v⟩).to_linear_map.flip

@[simp] lemma foldr_ι (f : M →ₗ[R] N →ₗ[R] N) (hf) (n : N) (m : M) :
  foldr Q f hf n (ι Q m) = f m n :=
linear_map.congr_fun (lift_ι_apply _ _ _) n

@[simp] lemma foldr_algebra_map (f : M →ₗ[R] N →ₗ[R] N) (hf) (n : N) (r : R) :
  foldr Q f hf n (algebra_map R _ r) = r • n :=
linear_map.congr_fun (alg_hom.commutes _ r) n

@[simp] lemma foldr_one (f : M →ₗ[R] N →ₗ[R] N) (hf) (n : N) :
  foldr Q f hf n 1 = n :=
linear_map.congr_fun (alg_hom.map_one _) n

@[simp] lemma foldr_mul (f : M →ₗ[R] N →ₗ[R] N) (hf) (n : N) (a b : clifford_algebra Q) :
  foldr Q f hf n (a * b) = foldr Q f hf (foldr Q f hf n b) a :=
linear_map.congr_fun (alg_hom.map_mul _ _ _) n

/-- This lemma demonstrates the origin of the `foldr` name. -/
lemma foldr_prod_map_ι (l : list M) (f : M →ₗ[R] N →ₗ[R] N) (hf) (n : N):
  foldr Q f hf n (l.map $ ι Q).prod = list.foldr (λ m n, f m n) n l :=
begin
  induction l with hd tl ih,
  { rw [list.map_nil, list.prod_nil, list.foldr_nil, foldr_one] },
  { rw [list.map_cons, list.prod_cons, list.foldr_cons, foldr_mul, foldr_ι, ih] },
end

end foldr

section foldl

/-- Fold a bilinear map along the generators of a term of the clifford algebra, with the rule
given by `foldl Q f hf n (ι Q m * x) = f m (foldl Q f hf n x)`.

For example, `foldl f hf n (r • ι R u + ι R v * ι R w) = r • f u n + f v (f w n)`. -/
def foldl (f : M →ₗ[R] N →ₗ[R] N) (hf : ∀ m x, f m (f m x) = Q m • x) :
  N →ₗ[R] clifford_algebra Q →ₗ[R] N :=
linear_map.compl₂ (foldr Q f hf) reverse

@[simp] lemma foldl_reverse (f : M →ₗ[R] N →ₗ[R] N) (hf) (n : N) (x : clifford_algebra Q) :
  foldl Q f hf n (reverse x) = foldr Q f hf n x :=
fun_like.congr_arg (foldr Q f hf n) $ reverse_reverse _

@[simp] lemma foldr_reverse (f : M →ₗ[R] N →ₗ[R] N) (hf) (n : N) (x : clifford_algebra Q) :
  foldr Q f hf n (reverse x) = foldl Q f hf n x := rfl

@[simp] lemma foldl_ι (f : M →ₗ[R] N →ₗ[R] N) (hf) (n : N) (m : M) :
  foldl Q f hf n (ι Q m) = f m n :=
by rw [←foldr_reverse, reverse_ι, foldr_ι]

@[simp] lemma foldl_algebra_map (f : M →ₗ[R] N →ₗ[R] N) (hf) (n : N) (r : R) :
  foldl Q f hf n (algebra_map R _ r) = r • n :=
by rw [←foldr_reverse, reverse.commutes, foldr_algebra_map]

@[simp] lemma foldl_one (f : M →ₗ[R] N →ₗ[R] N) (hf) (n : N) :
  foldl Q f hf n 1 = n :=
by rw [←foldr_reverse, reverse.map_one, foldr_one]

@[simp] lemma foldl_mul (f : M →ₗ[R] N →ₗ[R] N) (hf) (n : N) (a b : clifford_algebra Q) :
  foldl Q f hf n (a * b) = foldl Q f hf (foldl Q f hf n a) b :=
by rw [←foldr_reverse, ←foldr_reverse, ←foldr_reverse, reverse.map_mul, foldr_mul]

/-- This lemma demonstrates the origin of the `foldl` name. -/
lemma foldl_prod_map_ι (l : list M) (f : M →ₗ[R] N →ₗ[R] N) (hf) (n : N):
  foldl Q f hf n (l.map $ ι Q).prod = list.foldl (λ m n, f n m) n l :=
by rw [←foldr_reverse, reverse_prod_map_ι, ←list.map_reverse, foldr_prod_map_ι, list.foldr_reverse]

end foldl

lemma right_induction {P : clifford_algebra Q → Prop}
  (hr : ∀ r : R, P (algebra_map _ _ r))
  (h_add : ∀ x y, P x → P y → P (x + y))
  (h_ι_mul : ∀ m x, P x → P (x * ι Q m)) : ∀ x, P x :=
begin
  /- It would be neat if we could prove this via `foldr` like how we prove
  `clifford_algebra.induction`, but going via the grading seems easier. -/
  intro x,
  have : x ∈ ⊤ := submodule.mem_top,
  rw ←supr_ι_range_eq_top at this,
  apply submodule.supr_induction _ this (λ i x hx, _) _ h_add,
  { refine submodule.pow_induction_on_right _ hr h_add (λ x px m, _) hx,
    rintro ⟨m, rfl⟩,
    exact h_ι_mul _ _ px },
  { simpa only [map_zero] using hr 0}
end

lemma left_induction {P : clifford_algebra Q → Prop}
  (hr : ∀ r : R, P (algebra_map _ _ r))
  (h_add : ∀ x y, P x → P y → P (x + y))
  (h_mul_ι : ∀ x m, P x → P (ι Q m * x)) : ∀ x, P x :=
begin
  refine reverse_involutive.surjective.forall.2 _,
  intro x,
  induction x using clifford_algebra.right_induction with r x y hx hy m x hx,
  { simpa only [reverse.commutes] using hr r },
  { simpa only [map_add] using h_add _ _ hx hy },
  { simpa only [reverse.map_mul, reverse_ι] using h_mul_ι _ _ hx },
end

/-! ### Versions with extra state -/
/-- Auxiliary definition for `clifford_algebra.foldr'` -/
def foldr'_aux (f : M →ₗ[R] clifford_algebra Q × N →ₗ[R] N) :
  M →ₗ[R] module.End R (clifford_algebra Q × N) :=
begin
  have v_mul := (algebra.lmul R (clifford_algebra Q)).to_linear_map ∘ₗ (ι Q),
  have l := v_mul.compl₂ (linear_map.fst _ _ N),
  exact { to_fun := λ m, (l m).prod (f m),
          map_add' := λ v₂ v₂, linear_map.ext $ λ x, prod.ext
            (linear_map.congr_fun (l.map_add _ _) x) (linear_map.congr_fun (f.map_add _ _) x),
          map_smul' := λ c v, linear_map.ext $ λ x, prod.ext
            (linear_map.congr_fun (l.map_smul _ _) x) (linear_map.congr_fun (f.map_smul _ _) x), },
end

lemma foldr'_aux_apply_apply (f : M →ₗ[R] clifford_algebra Q × N →ₗ[R] N) (m : M) (x_fx) :
    foldr'_aux Q f m x_fx = (ι Q m * x_fx.1, f m x_fx) := rfl

lemma foldr'_aux_foldr'_aux (f : M →ₗ[R] clifford_algebra Q × N →ₗ[R] N)
  (hf : ∀ m x fx, f m (ι Q m * x, f m (x, fx)) = Q m • fx)
  (v : M) (x_fx) :
  foldr'_aux Q f v (foldr'_aux Q f v x_fx) = Q v • x_fx :=
begin
  cases x_fx with x fx,
  simp only [foldr'_aux_apply_apply],
  rw [←mul_assoc, ι_sq_scalar, ← algebra.smul_def, hf, prod.smul_mk],
end

/-- Fold a bilinear map along the generators of a term of the clifford algebra, with the rule
given by `foldr' Q f hf n (ι Q m * x) = f m (x, foldr' Q f hf n x)`.
Note this is like `clifford_algebra.foldr`, but with an extra `x` argument.
Implement the recursion scheme `F[n0](m * x) = f(m, (x, F[n0](x)))`. -/
def foldr' (f : M →ₗ[R] clifford_algebra Q × N →ₗ[R] N)
  (hf : ∀ m x fx, f m (ι Q m * x, f m (x, fx)) = Q m • fx)
  (n : N) :
  clifford_algebra Q →ₗ[R] N :=
linear_map.snd _ _ _ ∘ₗ foldr Q (foldr'_aux Q f) (foldr'_aux_foldr'_aux Q _ hf) (1, n)

lemma foldr'_algebra_map (f : M →ₗ[R] clifford_algebra Q × N →ₗ[R] N)
  (hf : ∀ m x fx, f m (ι Q m * x, f m (x, fx)) = Q m • fx) (n r) :
  foldr' Q f hf n (algebra_map R _ r) = r • n :=
congr_arg prod.snd (foldr_algebra_map _ _ _ _ _)

lemma foldr'_ι (f : M →ₗ[R] clifford_algebra Q × N →ₗ[R] N)
  (hf : ∀ m x fx, f m (ι Q m * x, f m (x, fx)) = Q m • fx) (n m) :
  foldr' Q f hf n (ι Q m) = f m (1, n) :=
congr_arg prod.snd (foldr_ι _ _ _ _ _)

lemma foldr'_ι_mul (f : M →ₗ[R] clifford_algebra Q × N →ₗ[R] N)
  (hf : ∀ m x fx, f m (ι Q m * x, f m (x, fx)) = Q m • fx) (n m) (x) :
  foldr' Q f hf n (ι Q m * x) = f m (x, foldr' Q f hf n x) :=
begin
  dsimp [foldr'],
  rw [foldr_mul, foldr_ι, foldr'_aux_apply_apply],
  refine congr_arg (f m) (prod.mk.eta.symm.trans _),
  congr' 1,
  induction x using clifford_algebra.left_induction with r x y hx hy m x hx,
  { simp_rw [foldr_algebra_map, prod.smul_mk, algebra.algebra_map_eq_smul_one] },
  { rw [map_add, prod.fst_add, hx, hy] },
  { rw [foldr_mul, foldr_ι, foldr'_aux_apply_apply, hx], },
end

end clifford_algebra