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

/-!
# Extra facts about `prod`

This file defines `prod.swap : α × β → β × α` and proves various simple lemmas about `prod`.
-/

variables {α : Type*} {β : Type*} {γ : Type*} {δ : Type*}

@[simp] lemma prod_map (f : α → γ) (g : β → δ) (p : α × β) : prod.map f g p = (f p.1, g p.2) := rfl

namespace prod

@[simp] theorem «forall» {p : α × β → Prop} : (∀ x, p x) ↔ (∀ a b, p (a, b)) :=
⟨assume h a b, h (a, b), assume h ⟨a, b⟩, h a b⟩

@[simp] theorem «exists» {p : α × β → Prop} : (∃ x, p x) ↔ (∃ a b, p (a, b)) :=
⟨assume ⟨⟨a, b⟩, h⟩, ⟨a, b, h⟩, assume ⟨a, b, h⟩, ⟨⟨a, b⟩, h⟩⟩

theorem forall' {p : α → β → Prop} : (∀ x : α × β, p x.1 x.2) ↔ ∀ a b, p a b :=
prod.forall

theorem exists' {p : α → β → Prop} : (∃ x : α × β, p x.1 x.2) ↔ ∃ a b, p a b :=
prod.exists

@[simp] lemma map_mk (f : α → γ) (g : β → δ) (a : α) (b : β) : map f g (a, b) = (f a, g b) := rfl

lemma map_fst (f : α → γ) (g : β → δ) (p : α × β) : (map f g p).1 = f (p.1) := rfl

lemma map_snd (f : α → γ) (g : β → δ) (p : α × β) : (map f g p).2 = g (p.2) := rfl

lemma map_fst' (f : α → γ) (g : β → δ) : (prod.fst ∘ map f g) = f ∘ prod.fst :=
funext $ map_fst f g

lemma map_snd' (f : α → γ) (g : β → δ) : (prod.snd ∘ map f g) = g ∘ prod.snd :=
funext $ map_snd f g

/--
Composing a `prod.map` with another `prod.map` is equal to
a single `prod.map` of composed functions.
-/
lemma map_comp_map {ε ζ : Type*}
  (f : α → β) (f' : γ → δ) (g : β → ε) (g' : δ → ζ) :
  prod.map g g' ∘ prod.map f f' = prod.map (g ∘ f) (g' ∘ f') :=
rfl

/--
Composing a `prod.map` with another `prod.map` is equal to
a single `prod.map` of composed functions, fully applied.
-/
lemma map_map {ε ζ : Type*}
  (f : α → β) (f' : γ → δ) (g : β → ε) (g' : δ → ζ) (x : α × γ) :
  prod.map g g' (prod.map f f' x) = prod.map (g ∘ f) (g' ∘ f') x :=
rfl

@[simp] theorem mk.inj_iff {a₁ a₂ : α} {b₁ b₂ : β} : (a₁, b₁) = (a₂, b₂) ↔ (a₁ = a₂ ∧ b₁ = b₂) :=
⟨prod.mk.inj, by cc⟩

lemma mk.inj_left {α β : Type*} (a : α) :
  function.injective (prod.mk a : β → α × β) :=
by { intros b₁ b₂ h, simpa only [true_and, prod.mk.inj_iff, eq_self_iff_true] using h }

lemma mk.inj_right {α β : Type*} (b : β) :
  function.injective (λ a, prod.mk a b : α → α × β) :=
by { intros b₁ b₂ h, by simpa only [and_true, eq_self_iff_true, mk.inj_iff] using h }

lemma ext_iff {p q : α × β} : p = q ↔ p.1 = q.1 ∧ p.2 = q.2 :=
by rw [← @mk.eta _ _ p, ← @mk.eta _ _ q, mk.inj_iff]

@[ext]
lemma ext {α β} {p q : α × β} (h₁ : p.1 = q.1) (h₂ : p.2 = q.2) : p = q :=
ext_iff.2 ⟨h₁, h₂⟩

lemma map_def {f : α → γ} {g : β → δ} : prod.map f g = λ (p : α × β), (f p.1, g p.2) :=
funext (λ p, ext (map_fst f g p) (map_snd f g p))

lemma id_prod : (λ (p : α × α), (p.1, p.2)) = id :=
funext $ λ ⟨a, b⟩, rfl

lemma fst_surjective [h : nonempty β] : function.surjective (@fst α β) :=
λ x, h.elim $ λ y, ⟨⟨x, y⟩, rfl⟩

lemma snd_surjective [h : nonempty α] : function.surjective (@snd α β) :=
λ y, h.elim $ λ x, ⟨⟨x, y⟩, rfl⟩

lemma fst_injective [subsingleton β] : function.injective (@fst α β) :=
λ x y h, ext h (subsingleton.elim _ _)

lemma snd_injective [subsingleton α] : function.injective (@snd α β) :=
λ x y h, ext (subsingleton.elim _ _) h

/-- Swap the factors of a product. `swap (a, b) = (b, a)` -/
def swap : α × β → β × α := λp, (p.2, p.1)

@[simp] lemma swap_swap : ∀ x : α × β, swap (swap x) = x
| ⟨a, b⟩ := rfl

@[simp] lemma fst_swap {p : α × β} : (swap p).1 = p.2 := rfl

@[simp] lemma snd_swap {p : α × β} : (swap p).2 = p.1 := rfl

@[simp] lemma swap_prod_mk {a : α} {b : β} : swap (a, b) = (b, a) := rfl

@[simp] lemma swap_swap_eq : swap ∘ swap = @id (α × β) :=
funext swap_swap

@[simp] lemma swap_left_inverse : function.left_inverse (@swap α β) swap :=
swap_swap

@[simp] lemma swap_right_inverse : function.right_inverse (@swap α β) swap :=
swap_swap

lemma swap_injective : function.injective (@swap α β) :=
swap_left_inverse.injective

lemma swap_surjective : function.surjective (@swap α β) :=
swap_left_inverse.surjective

lemma swap_bijective : function.bijective (@swap α β) :=
⟨swap_injective, swap_surjective⟩

@[simp] lemma swap_inj {p q : α × β} : swap p = swap q ↔ p = q := swap_injective.eq_iff

lemma eq_iff_fst_eq_snd_eq : ∀{p q : α × β}, p = q ↔ (p.1 = q.1 ∧ p.2 = q.2)
| ⟨p₁, p₂⟩ ⟨q₁, q₂⟩ := by simp

lemma fst_eq_iff : ∀ {p : α × β} {x : α}, p.1 = x ↔ p = (x, p.2)
| ⟨a, b⟩ x := by simp

lemma snd_eq_iff : ∀ {p : α × β} {x : β}, p.2 = x ↔ p = (p.1, x)
| ⟨a, b⟩ x := by simp

theorem lex_def (r : α → α → Prop) (s : β → β → Prop)
  {p q : α × β} : prod.lex r s p q ↔ r p.1 q.1 ∨ p.1 = q.1 ∧ s p.2 q.2 :=
⟨λ h, by cases h; simp *,
 λ h, match p, q, h with
 | (a, b), (c, d), or.inl h := lex.left _ _ h
 | (a, b), (c, d), or.inr ⟨e, h⟩ :=
   by change a = c at e; subst e; exact lex.right _ h
 end⟩

instance lex.decidable [decidable_eq α]
  (r : α → α → Prop) (s : β → β → Prop) [decidable_rel r] [decidable_rel s] :
  decidable_rel (prod.lex r s) :=
λ p q, decidable_of_decidable_of_iff (by apply_instance) (lex_def r s).symm

end prod

open function

lemma function.injective.prod_map {f : α → γ} {g : β → δ} (hf : injective f) (hg : injective g) :
  injective (prod.map f g) :=
λ x y h, prod.ext (hf (prod.ext_iff.1 h).1) (hg $ (prod.ext_iff.1 h).2)

lemma function.surjective.prod_map {f : α → γ} {g : β → δ} (hf : surjective f) (hg : surjective g) :
  surjective (prod.map f g) :=
λ p, let ⟨x, hx⟩ := hf p.1 in let ⟨y, hy⟩ := hg p.2 in ⟨(x, y), prod.ext hx hy⟩


/-
  The structure presheaf is a sheaf of rings.

  https://stacks.math.columbia.edu/tag/01HR
-/

import topology.basic
import to_mathlib.localization.localization_alt
import sheaves.sheaf_on_standard_basis
import spectrum_of_a_ring.induced_homeomorphism
import spectrum_of_a_ring.quasi_compact
import spectrum_of_a_ring.structure_presheaf
import spectrum_of_a_ring.structure_sheaf_condition
import spectrum_of_a_ring.structure_sheaf_locality
import spectrum_of_a_ring.structure_sheaf_gluing

universes u v

local attribute [instance] classical.prop_decidable

variables {R : Type u} [comm_ring R]

open topological_space
open localization_alt
open localization
open classical

section structure_sheaf

theorem structure_presheaf_on_basis_is_sheaf_on_standard_basis_cofinal_system
: sheaf_on_standard_basis.is_sheaf_on_standard_basis_cofinal_system
    (D_fs_standard_basis R)
    (structure_presheaf_on_basis R).to_presheaf_on_basis :=
begin
  intros U BU OC Hγ,
  let f := some BU,
  let Rf := localization R (S U),
  have HRf : is_localization_data (powers f) (localization.of : R → Rf)
    := structure_presheaf.localization BU,
  let fi : OC.γ → R := λ i, classical.some (OC.BUis i),
  let Hfi : ∀ i, OC.Uis i = Spec.DO R (fi i) := λ i, classical.some_spec (OC.BUis i),
  let fi' : OC.γ → Rf := λ i, localization.of (fi i),
  let F : set Rf := set.range fi',
  -- Lemma: ⋃ D(gᵢ') = Spec Rf.
  have Hcov : ⋃₀ (Spec.D' '' F) = set.univ,
  { let φ : Spec Rf → Spec R := Zariski.induced localization.of,
    dsimp [F],
    apply set.eq_univ_of_univ_subset,
    rintros P HP,
    have H : φ P ∈ U,
      suffices : φ P ∈ Spec.DO R (f),
        rw some_spec BU,
        exact this,
      show φ P ∈ Spec.D'(f),
      rw ←phi_image_Df HRf,
      use P,
      split,
      { trivial, },
      { refl, },
    rw ←OC.Hcov at H,
    rcases H with ⟨UiS, ⟨⟨UiO, ⟨⟨i, Hi⟩, HUiO⟩⟩, HPUiS⟩⟩,
    use [φ ⁻¹' UiS],
    have Hin : φ ⁻¹' UiS ∈ Spec.D' '' set.range fi',
      rw [←HUiO, ←Hi, Hfi],
      dsimp only [Spec.DO],
      use [fi' i],
      split,
      { use [i], },
      { rw [←Zariski.induced.preimage_D localization.of _], },
    use [Hin],
    exact HPUiS, },
  -- We deduce: 1 ∈ <fi>
  have Hone : (1 : Rf) ∈ ideal.span F,
    erw [←ideal.eq_top_iff_one, ←Spec.V.empty_iff_ideal_top, ←Spec.V.set_eq_span],
    rw [Spec.D'.union F, ←set.compl_compl set.univ, set.compl_univ] at Hcov,
    apply set.ext,
    intros x,
    rw set.ext_iff at Hcov,
    replace Hcov := Hcov x,
    iterate 2 { rw set.mem_compl_iff at Hcov, },
    rw not_iff_not at Hcov,
    exact Hcov,
  -- α is injective.
  let αi := λ i, structure_presheaf_on_basis.res BU (OC.BUis i) (subset_covering i),
  let Rfi := λ i, localization R (S (OC.Uis i)),
  let α' := @α Rf _ _ Hγ Rfi _ αi _,
  have Hlocα : Π i, is_localization_data (powers (fi' i)) (αi i)
    := λ i, structure_presheaf.res.localization BU (OC.BUis i) (subset_covering i),
  have Hsc₁ := @standard_covering₁ Rf _ _ Hγ fi' Rfi _ αi _ Hlocα Hone,
  -- ker β = im α.
  let Rfij := λ i j, localization R (S ((OC.Uis i) ∩ (OC.Uis j))),
  let βij
    := λ i j, structure_presheaf_on_basis.res_to_inter BU (OC.BUis i) (OC.BUis j) (subset_covering i),
  have Hlocβ
    := λ i j, structure_presheaf.res_to_inter.localization BU (OC.BUis i) (OC.BUis j) (subset_covering i),
  let β' := @β Rf _ _ Hγ fi' Rfi _ αi _ Hlocα Rfij _ βij _ Hlocβ,
  have Hsc₂ := @standard_covering₂ Rf _ _ Hγ fi' Rfi _ αi _ Hlocα Rfij _ βij _ Hlocβ Hone,
  constructor,
  { -- Locality.
    intros s t Hst,
    dsimp [structure_presheaf_on_basis, coe_fn, has_coe_to_fun.coe] at s,
    dsimp [structure_presheaf_on_basis, coe_fn, has_coe_to_fun.coe] at t,
    apply Hsc₁,
    dsimp [α, αi],
    apply funext,
    intros i,
    rw ←structure_presheaf_on_basis.res_eq,
    exact (Hst i), },
  { -- Gluing.
    intros s Hs,
    have Hβ : β' s = 0,
      simp [β', β, -sub_eq_add_neg, sub_eq_zero, β1, β2],
      apply funext, intro j,
      apply funext, intro k,
      have Hsjk := Hs j k,
      dsimp only [sheaf_on_standard_basis.res_to_inter_left] at Hsjk,
      dsimp only [sheaf_on_standard_basis.res_to_inter_right] at Hsjk,
      rw structure_presheaf_on_basis.res_eq at Hsjk,
      -- The restriction to the left is the unique localization map from R[1/fj] to R[1/fjfk].
      let β1 := structure_presheaf_on_basis.res_to_inter_right (OC.BUis j) (OC.BUis k),
      let Hβ1 := @inverts_powers1 Rf _ _ Hγ fi' Rfij _ βij _ Hlocβ j k,
      have Hcompβ1 : βij j k = β1 ∘ (αi k),
        dsimp only [βij, β1, αi],
        dsimp only [structure_presheaf_on_basis.res_to_inter_right],
        dsimp only [structure_presheaf_on_basis.res_to_inter],
        erw ←structure_presheaf_on_basis.res_comp,
        refl,
      have Huniqueβ1
        := is_localization_unique.of_eq (powers (fi' k)) (αi k) (Hlocα k) β1 (s k) (βij j k) Hβ1 Hcompβ1,
      rw Huniqueβ1,
      -- The restriction to the right is the unique localization map from R[1/fk] to R[1/fjfk].
      let β2 := structure_presheaf_on_basis.res_to_inter_left (OC.BUis j) (OC.BUis k),
      let Hβ2 := @inverts_powers2 Rf _ _ Hγ fi' Rfij _ βij _ Hlocβ j k,
      have Hcompβ2 : βij j k = β2 ∘ (αi j),
        dsimp only [βij, β2, αi],
        dsimp only [structure_presheaf_on_basis.res_to_inter_left],
        dsimp only [structure_presheaf_on_basis.res_to_inter],
        erw ←structure_presheaf_on_basis.res_comp,
        refl,
      have Huniqueβ2
        := is_localization_unique.of_eq (powers (fi' j)) (αi j) (Hlocα j) β2 (s j) (βij j k) Hβ2 Hcompβ2,
      rw Huniqueβ2,
      -- Now we have it in the desired form.
      exact Hsjk.symm,
    -- Use global section found.
    rcases ((Hsc₂ s).1 Hβ) with ⟨S, HS⟩,
    use S,
    intros i,
    replace HS := (congr_fun HS) i,
    dsimp [α, αi] at HS,
    rw structure_presheaf_on_basis.res_eq,
    exact HS, }
end

theorem structure_presheaf_on_basis_is_sheaf_on_basis
: sheaf_on_standard_basis.is_sheaf_on_standard_basis
    (D_fs_standard_basis R)
    (structure_presheaf_on_basis R).to_presheaf_on_basis :=
begin
  apply sheaf_on_standard_basis.cofinal_systems_coverings_standard_case,
  { apply structure_presheaf_on_basis_is_compact, },
  { apply structure_presheaf_on_basis_is_sheaf_on_standard_basis_cofinal_system, },
end

-- Structure sheaf.

def structure_sheaf.presheaf (R : Type u) [comm_ring R] :=
presheaf_of_rings_extension
  (D_fs_standard_basis R)
  (structure_presheaf_on_basis R)

theorem strucutre_presheaf_is_sheaf_of_rings (R : Type u) [comm_ring R]
: is_sheaf_of_rings (structure_sheaf.presheaf R) :=
begin
  apply extension_is_sheaf_of_rings,
  intros U BU OC,
  exact structure_presheaf_on_basis_is_sheaf_on_basis BU OC,
end

def structure_sheaf (R : Type u) [comm_ring R] : sheaf_of_rings (Spec R) :=
{ F := structure_sheaf.presheaf R,
  locality := (strucutre_presheaf_is_sheaf_of_rings R).1,
  gluing := (strucutre_presheaf_is_sheaf_of_rings R).2, }

end structure_sheaf


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

Quotients -- extends the core library
-/
variables {α : Sort*} {β : Sort*}

namespace quot
variables {ra : α → α → Prop} {rb : β → β → Prop} {φ : quot ra → quot rb → Sort*}
local notation `⟦`:max a `⟧` := quot.mk _ a

protected def hrec_on₂ (qa : quot ra) (qb : quot rb) (f : ∀ a b, φ ⟦a⟧ ⟦b⟧)
  (ca : ∀ {b a₁ a₂}, ra a₁ a₂ → f a₁ b == f a₂ b)
  (cb : ∀ {a b₁ b₂}, rb b₁ b₂ → f a b₁ == f a b₂) : φ qa qb :=
quot.hrec_on qa (λ a, quot.hrec_on qb (f a) (λ b₁ b₂ pb, cb pb)) $ λ a₁ a₂ pa,
  quot.induction_on qb $ λ b,
    calc @quot.hrec_on _ _ (φ _) ⟦b⟧ (f a₁) (@cb _)
          == f a₁ b                                     : by simp
      ... == f a₂ b                                     : ca pa
      ... == @quot.hrec_on _ _ (φ _) ⟦b⟧ (f a₂) (@cb _) : by simp

end quot

namespace quotient
variables [sa : setoid α] [sb : setoid β]
variables {φ : quotient sa → quotient sb → Sort*}

protected def hrec_on₂ (qa : quotient sa) (qb : quotient sb) (f : ∀ a b, φ ⟦a⟧ ⟦b⟧)
  (c : ∀ a₁ b₁ a₂ b₂, a₁ ≈ a₂ → b₁ ≈ b₂ → f a₁ b₁ == f a₂ b₂) : φ qa qb :=
quot.hrec_on₂ qa qb f
  (λ _ _ _ p, c _ _ _ _ p (setoid.refl _))
  (λ _ _ _ p, c _ _ _ _ (setoid.refl _) p)
end quotient

@[simp] theorem quotient.eq [r : setoid α] {x y : α} : ⟦x⟧ = ⟦y⟧ ↔ x ≈ y :=
⟨quotient.exact, quotient.sound⟩

theorem forall_quotient_iff {α : Type*} [r : setoid α] {p : quotient r → Prop} :
  (∀a:quotient r, p a) ↔ (∀a:α, p ⟦a⟧) :=
⟨assume h x, h _, assume h a, a.induction_on h⟩

@[simp] lemma quotient.lift_beta [s : setoid α] (f : α → β) (h : ∀ (a b : α), a ≈ b → f a = f b) (x : α):
quotient.lift f h (quotient.mk x) = f x := rfl

@[simp] lemma quotient.lift_on_beta [s : setoid α] (f : α → β) (h : ∀ (a b : α), a ≈ b → f a = f b) (x : α):
quotient.lift_on (quotient.mk x) f h = f x := rfl

/-- Choose an element of the equivalence class using the axiom of choice.
  Sound but noncomputable. -/
noncomputable def quot.out {r : α → α → Prop} (q : quot r) : α :=
classical.some (quot.exists_rep q)

/-- Unwrap the VM representation of a quotient to obtain an element of the equivalence class.
  Computable but unsound. -/
meta def quot.unquot {r : α → α → Prop} : quot r → α := unchecked_cast

@[simp] theorem quot.out_eq {r : α → α → Prop} (q : quot r) : quot.mk r q.out = q :=
classical.some_spec (quot.exists_rep q)

/-- Choose an element of the equivalence class using the axiom of choice.
  Sound but noncomputable. -/
noncomputable def quotient.out [s : setoid α] : quotient s → α := quot.out

@[simp] theorem quotient.out_eq [s : setoid α] (q : quotient s) : ⟦q.out⟧ = q := q.out_eq

theorem quotient.mk_out [s : setoid α] (a : α) : ⟦a⟧.out ≈ a :=
quotient.exact (quotient.out_eq _)

instance pi_setoid {ι : Sort*} {α : ι → Sort*} [∀ i, setoid (α i)] : setoid (Π i, α i) :=
{ r := λ a b, ∀ i, a i ≈ b i,
  iseqv := ⟨
    λ a i, setoid.refl _,
    λ a b h i, setoid.symm (h _),
    λ a b c h₁ h₂ i, setoid.trans (h₁ _) (h₂ _)⟩ }

noncomputable def quotient.choice {ι : Type*} {α : ι → Type*} [S : ∀ i, setoid (α i)]
  (f : ∀ i, quotient (S i)) : @quotient (Π i, α i) (by apply_instance) :=
⟦λ i, (f i).out⟧

theorem quotient.choice_eq {ι : Type*} {α : ι → Type*} [∀ i, setoid (α i)]
  (f : ∀ i, α i) : quotient.choice (λ i, ⟦f i⟧) = ⟦f⟧ :=
quotient.sound $ λ i, quotient.mk_out _

/-- `trunc α` is the quotient of `α` by the always-true relation. This
  is related to the propositional truncation in HoTT, and is similar
  in effect to `nonempty α`, but unlike `nonempty α`, `trunc α` is data,
  so the VM representation is the same as `α`, and so this can be used to
  maintain computability. -/
def {u} trunc (α : Sort u) : Sort u := @quot α (λ _ _, true)

theorem true_equivalence : @equivalence α (λ _ _, true) :=
⟨λ _, trivial, λ _ _ _, trivial, λ _ _ _ _ _, trivial⟩

namespace trunc

/-- Constructor for `trunc α` -/
def mk (a : α) : trunc α := quot.mk _ a

/-- Any constant function lifts to a function out of the truncation -/
def lift (f : α → β) (c : ∀ a b : α, f a = f b) : trunc α → β :=
quot.lift f (λ a b _, c a b)

theorem ind {β : trunc α → Prop} : (∀ a : α, β (mk a)) → ∀ q : trunc α, β q := quot.ind

protected theorem lift_beta (f : α → β) (c) (a : α) : lift f c (mk a) = f a := rfl

@[reducible, elab_as_eliminator]
protected def lift_on (q : trunc α) (f : α → β)
  (c : ∀ a b : α, f a = f b) : β := lift f c q

@[elab_as_eliminator]
protected theorem induction_on {β : trunc α → Prop} (q : trunc α)
  (h : ∀ a, β (mk a)) : β q := ind h q

theorem exists_rep (q : trunc α) : ∃ a : α, mk a = q := quot.exists_rep q

attribute [elab_as_eliminator]
protected theorem induction_on₂
   {C : trunc α → trunc β → Prop} (q₁ : trunc α) (q₂ : trunc β) (h : ∀ a b, C (mk a) (mk b)) : C q₁ q₂ :=
trunc.induction_on q₁ $ λ a₁, trunc.induction_on q₂ (h a₁)

protected theorem eq (a b : trunc α) : a = b :=
trunc.induction_on₂ a b (λ x y, quot.sound trivial)

instance : subsingleton (trunc α) := ⟨trunc.eq⟩

def bind (q : trunc α) (f : α → trunc β) : trunc β :=
trunc.lift_on q f (λ a b, trunc.eq _ _)

def map (f : α → β) (q : trunc α) : trunc β := bind q (trunc.mk ∘ f)

instance : monad trunc :=
{ pure := @trunc.mk,
  bind := @trunc.bind }

instance : is_lawful_monad trunc :=
{ id_map := λ α q, trunc.eq _ _,
  pure_bind := λ α β q f, rfl,
  bind_assoc := λ α β γ x f g, trunc.eq _ _ }

variable {C : trunc α → Sort*}

@[reducible, elab_as_eliminator]
protected def rec
   (f : Π a, C (mk a)) (h : ∀ (a b : α), (eq.rec (f a) (trunc.eq (mk a) (mk b)) : C (mk b)) = f b)
   (q : trunc α) : C q :=
quot.rec f (λ a b _, h a b) q

@[reducible, elab_as_eliminator]
protected def rec_on (q : trunc α) (f : Π a, C (mk a))
  (h : ∀ (a b : α), (eq.rec (f a) (trunc.eq (mk a) (mk b)) : C (mk b)) = f b) : C q :=
trunc.rec f h q

@[reducible, elab_as_eliminator]
protected def rec_on_subsingleton
   [∀ a, subsingleton (C (mk a))] (q : trunc α) (f : Π a, C (mk a)) : C q :=
trunc.rec f (λ a b, subsingleton.elim _ (f b)) q

/-- Noncomputably extract a representative of `trunc α` (using the axiom of choice). -/
noncomputable def out : trunc α → α := quot.out

@[simp] theorem out_eq (q : trunc α) : mk q.out = q := trunc.eq _ _

end trunc

theorem nonempty_of_trunc (q : trunc α) : nonempty α :=
let ⟨a, _⟩ := q.exists_rep in ⟨a⟩

namespace quotient
variables {γ : Sort*} {φ : Sort*}
  {s₁ : setoid α} {s₂ : setoid β} {s₃ : setoid γ}

/- Versions of quotient definitions and lemmas ending in `'` use unification instead
of typeclass inference for inferring the `setoid` argument. This is useful when there are
several different quotient relations on a type, for example quotient groups, rings and modules -/

protected def mk' (a : α) : quotient s₁ := quot.mk s₁.1 a

@[elab_as_eliminator, reducible]
protected def lift_on' (q : quotient s₁) (f : α → φ)
  (h : ∀ a b, @setoid.r α s₁ a b → f a = f b) : φ := quotient.lift_on q f h

@[elab_as_eliminator, reducible]
protected def lift_on₂' (q₁ : quotient s₁) (q₂ : quotient s₂) (f : α → β → γ)
  (h : ∀ a₁ a₂ b₁ b₂, @setoid.r α s₁ a₁ b₁ → @setoid.r β s₂ a₂ b₂ → f a₁ a₂ = f b₁ b₂) : γ :=
quotient.lift_on₂ q₁ q₂ f h

@[elab_as_eliminator]
protected lemma induction_on' {p : quotient s₁ → Prop} (q : quotient s₁)
  (h : ∀ a, p (quotient.mk' a)) : p q := quotient.induction_on q h

@[elab_as_eliminator]
protected lemma induction_on₂' {p : quotient s₁ → quotient s₂ → Prop} (q₁ : quotient s₁)
  (q₂ : quotient s₂) (h : ∀ a₁ a₂, p (quotient.mk' a₁) (quotient.mk' a₂)) : p q₁ q₂ :=
quotient.induction_on₂ q₁ q₂ h

@[elab_as_eliminator]
protected lemma induction_on₃' {p : quotient s₁ → quotient s₂ → quotient s₃ → Prop}
  (q₁ : quotient s₁) (q₂ : quotient s₂) (q₃ : quotient s₃)
  (h : ∀ a₁ a₂ a₃, p (quotient.mk' a₁) (quotient.mk' a₂) (quotient.mk' a₃)) : p q₁ q₂ q₃ :=
quotient.induction_on₃ q₁ q₂ q₃ h

lemma exact' {a b : α} :
  (quotient.mk' a : quotient s₁) = quotient.mk' b → @setoid.r _ s₁ a b :=
quotient.exact

lemma sound' {a b : α} : @setoid.r _ s₁ a b → @quotient.mk' α s₁ a = quotient.mk' b :=
quotient.sound

@[simp] protected lemma eq' {a b : α} : @quotient.mk' α s₁ a = quotient.mk' b ↔ @setoid.r _ s₁ a b :=
quotient.eq

noncomputable def out' (a : quotient s₁) : α := quotient.out a

@[simp] theorem out_eq' (q : quotient s₁) : quotient.mk' q.out' = q := q.out_eq

theorem mk_out' (a : α) : @setoid.r α s₁ (quotient.mk' a).out a :=
quotient.exact (quotient.out_eq _)

end quotient


/-
Copyright (c) 2021 Kexing Ying. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kexing Ying
-/
import measure_theory.decomposition.radon_nikodym
import measure_theory.measure.lebesgue
import measure_theory.measure.with_density_vector_measure

/-!
# Probability density function

This file defines the probability density function of a random variable. In particular,
a measurable function `f` is said to the probability density function of a random variable `X`
if for all measurable set `S`, `ℙ(X ∈ S) = ∫ x in S, f x dx`. Probability density functions
is one way of describing the distribution of a random variable, and is useful for calculating
probabilities and finding moments (although the latter is better achieved with moment generating
functions).

This file also defines the continuous uniform distribution and proves some properties about
random variables with this distribution.

## Main definitions

* `measure_theory.measure.has_pdf` : A random variable `X : α → E` is said to `has_pdf` with
  respect to the measure `ℙ` on `α` and `μ` on `E` if there exists a measurable function `f`
  such that the push-forward measure of `ℙ` along `X` equals `μ.with_density f`.
* `measure_theory.measure.pdf` : If `X` is a random variable that `has_pdf X ℙ μ`, then `pdf X`
  is the measurable function `f` such that the push-forward measure of `ℙ` along `X` equals
  `μ.with_density f`.
* `measure_theory.measure.pdf.uniform` : A random variable `X` is said to follow the uniform
  distribution if it has a constant probability density function with a compact, non-null support.

## Main results

* `measure_theory.measure.pdf.integral_mul_eq_integral'` : Law of the unconscious statistician,
  i.e. if a random variable `X : α → E` has pdf `f`, then `𝔼(g(X)) = ∫ x, g x * f x dx` for
  all measurable `g : E → ℝ`.
* `measure_theory.measure.pdf.integral_mul_eq_integral` : A real-valued random variable `X` with
  pdf `f` has expectation `∫ x, x * f x dx`.
* `measure_theory.measure.pdf.uniform.integral_eq` : If `X` follows the uniform distribution with
  its pdf having support `s`, then `X` has expectation `(λ s)⁻¹ * ∫ x in s, x dx` where `λ`
  is the Lebesgue measure.

## TODOs

Ultimately, we would also like to define characteristic functions to describe distributions as
it exists for all random variables. However, to define this, we will need Fourier transforms
which we currently do not have.
-/

noncomputable theory
open_locale classical measure_theory nnreal ennreal

namespace measure_theory

open topological_space

variables {α E : Type*} [normed_group E] [measurable_space E] [second_countable_topology E]
  [normed_space ℝ E] [complete_space E] [borel_space E]

section lemmas

variables {m : measurable_space α} {μ : measure α}

lemma set_lintegral_mono_ae {s : set α} {f g : α → ℝ≥0∞}
  (hf : measurable f) (hg : measurable g) (hfg : ∀ᵐ x ∂μ, x ∈ s → f x ≤ g x) :
  ∫⁻ x in s, f x ∂μ ≤ ∫⁻ x in s, g x ∂μ :=
lintegral_mono_ae $ (ae_restrict_iff $ measurable_set_le hf hg).2 hfg

lemma set_lintegral_mono {s : set α} {f g : α → ℝ≥0∞}
  (hf : measurable f) (hg : measurable g) (hfg : ∀ x ∈ s, f x ≤ g x) :
  ∫⁻ x in s, f x ∂μ ≤ ∫⁻ x in s, g x ∂μ :=
set_lintegral_mono_ae hf hg (ae_of_all _ hfg)

lemma set_lintegral_lt_top_of_bdd_above
  {s : set α} (hs : μ s < ∞) {f : α → ℝ≥0} (hf : measurable f) (hbdd : bdd_above (f '' s)) :
  ∫⁻ x in s, f x ∂μ < ∞ :=
begin
  obtain ⟨M, hM⟩ := hbdd,
  rw mem_upper_bounds at hM,
  refine lt_of_le_of_lt (set_lintegral_mono hf.coe_nnreal_ennreal
    (@measurable_const _ _ _ _ ↑M) _) _,
  { simpa using hM },
  { rw lintegral_const,
    refine ennreal.mul_lt_top ennreal.coe_lt_top.ne _,
    simp [hs.ne] }
end

lemma set_lintegral_lt_top_of_is_compact [topological_space α] [opens_measurable_space α]
  {s : set α} (hs : μ s < ∞) (hsc : is_compact s) {f : α → ℝ≥0} (hf : continuous f) :
  ∫⁻ x in s, f x ∂μ < ∞ :=
set_lintegral_lt_top_of_bdd_above hs hf.measurable (hsc.image hf).bdd_above

end lemmas

namespace measure

/-- A random variable `X : α → E` is said to `has_pdf` with respect to the measure `ℙ` on `α` and
`μ` on `E` if there exists a measurable function `f` such that the push-forward measure of `ℙ`
along `X` equals `μ.with_density f`. -/
class has_pdf {m : measurable_space α} (X : α → E)
  (ℙ : measure α) (μ : measure E . volume_tac) : Prop :=
(pdf' : ∃ (f : E → ℝ≥0∞), measurable f ∧ map X ℙ = μ.with_density f)

/-- If `X` is a random variable that `has_pdf X ℙ μ`, then `pdf X` is the measurable function `f`
such that the push-forward measure of `ℙ` along `X` equals `μ.with_density f`. -/
def pdf {m : measurable_space α} (X : α → E) (ℙ : measure α) (μ : measure E . volume_tac) :=
if hX : has_pdf X ℙ μ then classical.some hX.pdf' else 0

@[measurability]
lemma measurable_pdf {m : measurable_space α}
  (X : α → E) (ℙ : measure α) (μ : measure E . volume_tac) :
  measurable (pdf X ℙ μ) :=
begin
  by_cases hX : has_pdf X ℙ μ,
  { rw [pdf, dif_pos hX],
    exact (classical.some_spec hX.pdf').1 },
  { rw [pdf, dif_neg hX],
    exact measurable_zero }
end

lemma pdf_spec {m : measurable_space α}
  (X : α → E) (ℙ : measure α) (μ : measure E . volume_tac) [hX : has_pdf X ℙ μ] :
  measure.map X ℙ = μ.with_density (pdf X ℙ μ) :=
begin
  rw [pdf, dif_pos hX],
  exact (classical.some_spec hX.pdf').2
end

lemma pdf_spec' {m : measurable_space α}
  (X : α → E) (ℙ : measure α) (μ : measure E . volume_tac) [hX : has_pdf X ℙ μ]
  {s : set E} (hs : measurable_set s) :
  measure.map X ℙ s = ∫⁻ x in s, pdf X ℙ μ x ∂μ :=
by rw [← with_density_apply _ hs, pdf_spec X ℙ μ]

namespace pdf

variables {m : measurable_space α} {ℙ : measure α} {μ : measure E}

section

lemma lintegral_eq_measure_univ {X : α → E} [has_pdf X ℙ μ] (hX : measurable X) :
  ∫⁻ x, pdf X ℙ μ x ∂μ = ℙ set.univ :=
begin
  rw [← set_lintegral_univ, ← pdf_spec' X ℙ μ measurable_set.univ,
      measure.map_apply hX measurable_set.univ, set.preimage_univ],
end

lemma ae_lt_top {m : measurable_space α} (ℙ : measure α) [is_finite_measure ℙ] {μ : measure E}
  {X : α → E} (hX : measurable X) : ∀ᵐ x ∂μ, pdf X ℙ μ x < ∞ :=
begin
  by_cases hpdf : has_pdf X ℙ μ,
  { refine ae_lt_top (measurable_pdf X ℙ μ) _,
    rw lintegral_eq_measure_univ hX,
    { exact (measure_lt_top _ _).ne },
    { exact hpdf } },
  { rw [pdf, dif_neg hpdf],
    exact filter.eventually_of_forall (λ x, with_top.zero_lt_top) }
end

lemma of_real_to_real_ae_eq [is_finite_measure ℙ] {X : α → E} (hX : measurable X) :
  (λ x, ennreal.of_real (pdf X ℙ μ x).to_real) =ᵐ[μ] pdf X ℙ μ :=
begin
  by_cases hpdf : has_pdf X ℙ μ,
  { haveI := hpdf,
    change μ {x : E | ennreal.of_real (pdf X ℙ μ x).to_real ≠ pdf X ℙ μ x} = 0,
    have : ∀ x, ennreal.of_real (pdf X ℙ μ x).to_real ≠ pdf X ℙ μ x ↔
      pdf X ℙ μ x = ∞,
    { intro x, split; intro h,
      { by_contra htop,
        rw [← ne.def, ← lt_top_iff_ne_top] at htop,
        exact h (ennreal.of_real_to_real htop.ne) },
      { rw h, simp } },
    { simp_rw this,
      suffices hne : ∀ᵐ x ∂μ, pdf X ℙ μ x ≠ ∞,
      { simp_rw [ae_iff, not_not] at hne, exact hne },
      convert ae_lt_top ℙ hX,
      simp_rw [lt_top_iff_ne_top] } },
  { convert ae_eq_refl _,
    ext1 x,
    rw [pdf, dif_neg hpdf, pi.zero_apply, ennreal.zero_to_real, ennreal.of_real_zero] }
end

/-- **The Law of the Unconscious Statistician**: Given a random variable `X` and a measurable
function `f`, we have `f ∘ X` is a random variable and have expectation `∫ x, f x * pdf X ∂μ`
where `μ` is a measure on the codomain of `X`. -/
lemma integral_mul_eq_integral' [is_finite_measure ℙ] {X : α → E} [has_pdf X ℙ μ]
  (hX : measurable X) (f : E → ℝ) (hf : measurable f)
  (hpdf : integrable (λ x, f x * (pdf X ℙ μ x).to_real) μ) :
  ∫ x, f x * (pdf X ℙ μ x).to_real ∂μ = ∫ x, f (X x) ∂ℙ :=
begin
  rw [← integral_map hX hf.ae_measurable, pdf_spec X ℙ μ,
      integral_eq_lintegral_pos_part_sub_lintegral_neg_part,
      integral_eq_lintegral_pos_part_sub_lintegral_neg_part,
      lintegral_with_density_eq_lintegral_mul, lintegral_with_density_eq_lintegral_mul],
  { congr' 2,
    { have : ∀ x, ennreal.of_real (f x * (pdf X ℙ μ x).to_real) =
        ennreal.of_real (pdf X ℙ μ x).to_real * ennreal.of_real (f x),
      { intro x,
        rw [mul_comm, ennreal.of_real_mul ennreal.to_real_nonneg] },
      simp_rw [this],
      exact lintegral_congr_ae (filter.eventually_eq.mul
        (of_real_to_real_ae_eq hX) (ae_eq_refl _)) },
    { have : ∀ x, ennreal.of_real (- (f x * (pdf X ℙ μ x).to_real)) =
        ennreal.of_real (pdf X ℙ μ x).to_real * ennreal.of_real (-f x),
      { intro x,
        rw [neg_mul_eq_neg_mul, mul_comm, ennreal.of_real_mul ennreal.to_real_nonneg] },
      simp_rw [this],
      exact lintegral_congr_ae (filter.eventually_eq.mul
        (of_real_to_real_ae_eq hX) (ae_eq_refl _)) } },
  { exact measurable_pdf X ℙ μ },
  { exact (measurable.neg hf).ennreal_of_real },
  { exact measurable_pdf X ℙ μ},
  { exact measurable.ennreal_of_real hf },
  { refine ⟨hf.ae_measurable, _⟩,
    rw [has_finite_integral, lintegral_with_density_eq_lintegral_mul _
          (measurable_pdf _ _ _) hf.nnnorm.coe_nnreal_ennreal],
    have : (λ x, (pdf X ℙ μ * λ x, ↑∥f x∥₊) x) =ᵐ[μ] (λ x, ∥f x * (pdf X ℙ μ x).to_real∥₊),
    { simp_rw [← smul_eq_mul, nnnorm_smul, ennreal.coe_mul],
      rw [smul_eq_mul, mul_comm],
      refine filter.eventually_eq.mul (ae_eq_refl _)
        (ae_eq_trans (of_real_to_real_ae_eq hX).symm _),
      convert ae_eq_refl _,
      ext1 x,
      exact real.ennnorm_eq_of_real ennreal.to_real_nonneg },
    rw lintegral_congr_ae this,
    exact hpdf.2 },
  { assumption },
end

/-- A random variable that `has_pdf` is quasi-measure preserving. -/
lemma to_quasi_measure_preserving (X : α → E) (hX : measurable X) [has_pdf X ℙ μ] :
  quasi_measure_preserving X ℙ μ :=
{ measurable := hX,
  absolutely_continuous :=
  begin
    rw pdf_spec X ℙ μ,
    exact with_density_absolutely_continuous _ _,
    all_goals { apply_instance }
  end }

lemma map_absolutely_continuous {X : α → E} (hX : measurable X) [has_pdf X ℙ μ] :
  map X ℙ ≪ μ :=
(to_quasi_measure_preserving X hX).absolutely_continuous

end

section real

variables [is_finite_measure ℙ] {X : α → ℝ} (hX : measurable X)

include hX

/-- A real-valued random variable `X` `has_pdf X ℙ λ` (where `λ` is the Lebesgue measure) if and
only if the push-forward measure of `ℙ` along `X` is absolutely continuous with respect to `λ`. -/
lemma has_pdf_iff : has_pdf X ℙ ↔ map X ℙ ≪ volume :=
begin
  split,
  { intro hX',
    exactI map_absolutely_continuous hX },
  { intro h,
    refine ⟨⟨(measure.map X ℙ).radon_nikodym_deriv volume, measurable_radon_nikodym_deriv _ _, _⟩⟩,
    haveI := ℙ.is_finite_measure_map hX,
    rwa with_density_radon_nikodym_deriv_eq }
end

/-- A real-valued random variable that `has_pdf` transformed under a `quasi_measure_preserving`
map also `has_pdf`. -/
lemma quasi_measure_preserving_has_pdf [has_pdf X ℙ]
  (g : ℝ → ℝ) (hg : quasi_measure_preserving g) :
  has_pdf (g ∘ X) ℙ :=
begin
  rw [has_pdf_iff (hg.measurable.comp hX), ← map_map hg.measurable hX, pdf_spec X ℙ],
  refine absolutely_continuous.mk (λ s hsm hs, _),
  rw [map_apply hg.measurable hsm, with_density_apply _ (hg.measurable hsm)],
  have := hg.absolutely_continuous hs,
  rw map_apply hg.measurable hsm at this,
  exact set_lintegral_measure_zero _ _ this,
  apply_instance
end

-- lemma comp_pdf_ae_eq [has_pdf X ℙ]
--   (g : ℝ → ℝ) (hg : quasi_measure_preserving g) :
--   pdf (g ∘ X) ℙ =ᵐ[volume] radon_nikodym_deriv (map (g ∘ X) ℙ) volume :=
-- begin
--   -- refine integrable.ae_eq_of_with_densityᵥ_eq _ _ _,
-- end

/-- If `X` is a real-valued random variable that has pdf `f`, then the expectation of `X` equals
`∫ x, x * f x ∂λ` where `λ` is the Lebesgue measure. -/
lemma integral_mul_eq_integral [has_pdf X ℙ]
  (hpdf : integrable (λ x, x * (pdf X ℙ volume x).to_real) volume) :
  ∫ x, x * (pdf X ℙ volume x).to_real ∂(volume) = ∫ x, X x ∂ℙ :=
integral_mul_eq_integral' hX _ measurable_id hpdf

lemma has_finite_integral_mul {f : ℝ → ℝ} {g : ℝ → ℝ≥0∞}
  (hg : pdf X ℙ =ᵐ[volume] g) (hgi : ∫⁻ x, ∥f x∥₊ * g x ∂(volume) < ∞) :
  has_finite_integral (λ x, f x * (pdf X ℙ volume x).to_real) volume :=
begin
  rw [has_finite_integral],
  have : (λ x, ↑∥f x∥₊ * g x) =ᵐ[volume] (λ x, ∥f x * (pdf X ℙ volume x).to_real∥₊),
  { refine ae_eq_trans (filter.eventually_eq.mul (ae_eq_refl (λ x, ∥f x∥₊))
      (ae_eq_trans hg.symm (of_real_to_real_ae_eq hX).symm)) _,
    simp_rw [← smul_eq_mul, nnnorm_smul, ennreal.coe_mul, smul_eq_mul],
    refine filter.eventually_eq.mul (ae_eq_refl _) _,
    convert ae_eq_refl _,
    ext1 x,
    exact real.ennnorm_eq_of_real ennreal.to_real_nonneg },
  rwa ← lintegral_congr_ae this,
end

end real

section

/-! **Uniform Distribution** -/

/-- A random variable `X` has uniform distribution if it has a probability density function `f`
with compact support `s` such that `f = (μ s)⁻¹ 1ₛ` a.e. where `1ₛ` is the indicator function
for `s`.

We require compact support since otherwise the expectation might not be finite. -/
class uniform {m : measurable_space α} (X : α → E) (ℙ : measure α) (μ : measure E . volume_tac)
  extends has_pdf X ℙ μ :=
(support' : set E) (compact_support' : is_compact support')
(support_not_null' : 0 < μ support')
(uniform' : pdf X ℙ μ =ᵐ[μ] support'.indicator ((μ support')⁻¹ • 1))

namespace uniform

/-- The support of the probability density function of a random variable of uniform distribution. -/
def support {m : measurable_space α}
  (X : α → E) (ℙ : measure α) (μ : measure E . volume_tac) [hX : uniform X ℙ μ] : set E :=
hX.support'

lemma is_compact_support {m : measurable_space α}
  (X : α → E) (ℙ : measure α) (μ : measure E . volume_tac) [hX : uniform X ℙ μ] :
  is_compact (support X ℙ μ) :=
hX.compact_support'

@[measurability]
lemma measurable_set_support {m : measurable_space α}
  (X : α → E) (ℙ : measure α) (μ : measure E . volume_tac) [hX : uniform X ℙ μ] :
  measurable_set (support X ℙ μ) :=
(is_compact_support X ℙ μ).is_closed.measurable_set

lemma support_not_null {m : measurable_space α}
  (X : α → E) (ℙ : measure α) (μ : measure E . volume_tac) [hX : uniform X ℙ μ] :
  0 < μ (support X ℙ μ) :=
hX.support_not_null'

lemma pdf_ae_eq {m : measurable_space α} (X : α → E) (ℙ : measure α) (μ : measure E . volume_tac)
  [hX : uniform X ℙ μ] :
  pdf X ℙ μ =ᵐ[μ] (support X ℙ μ).indicator ((μ (support X ℙ μ))⁻¹ • 1) :=
hX.uniform'

lemma pdf_to_real_ae_eq {m : measurable_space α}
  (X : α → E) (ℙ : measure α) (μ : measure E . volume_tac) [hX : uniform X ℙ μ] :
  (λ x, (pdf X ℙ μ x).to_real) =ᵐ[μ]
  (λ x, ((support X ℙ μ).indicator ((μ (support X ℙ μ))⁻¹ • (1 : E → ℝ≥0∞)) x).to_real) :=
filter.eventually_eq.fun_comp (pdf_ae_eq X ℙ μ) ennreal.to_real

variables [is_finite_measure ℙ] {X : α → ℝ} [uniform X ℙ volume]

lemma mul_pdf_integrable (hX : measurable X) :
  integrable (λ x : ℝ, x * (pdf X ℙ volume x).to_real) volume :=
begin
  by_cases hsupp : volume (support X ℙ) = ∞,
  { have : pdf X ℙ =ᵐ[volume] 0,
    { refine ae_eq_trans (pdf_ae_eq X ℙ) _,
      simp [hsupp] },
    refine integrable.congr (integrable_zero _ _ _) _,
    rw [(by simp : (λ x, 0 : ℝ → ℝ) = (λ x, x * (0 : ℝ≥0∞).to_real))],
    refine filter.eventually_eq.mul (ae_eq_refl _)
      (filter.eventually_eq.fun_comp this.symm ennreal.to_real) },
  refine ⟨ae_measurable_id'.mul (measurable_pdf X ℙ).ae_measurable.ennreal_to_real, _⟩,
  refine has_finite_integral_mul hX (pdf_ae_eq X ℙ) _,
  set ind := (volume (support X ℙ))⁻¹ • (1 : ℝ → ℝ≥0∞) with hind,
  have : ∀ x, ↑∥x∥₊ * (support X ℙ).indicator ind x =
    (support X ℙ).indicator (λ x, ∥x∥₊ * ind x) x :=
      λ x, ((support X ℙ).indicator_mul_right (λ x, ↑∥x∥₊) ind).symm,
  simp only [this, lintegral_indicator _ (measurable_set_support X ℙ), hind, mul_one,
             algebra.id.smul_eq_mul, pi.one_apply, pi.smul_apply],
  rw lintegral_mul_const _ measurable_nnnorm.coe_nnreal_ennreal,
  { exact ennreal.mul_lt_top (set_lintegral_lt_top_of_is_compact
      (lt_top_iff_ne_top.2 hsupp) (is_compact_support X ℙ) continuous_nnnorm).ne
      (ennreal.inv_lt_top.2 (support_not_null X ℙ)).ne },
  { apply_instance }
end

/-- A real uniform random variable `X` with support `s` has expectation
`(λ s)⁻¹ * ∫ x in s, x ∂λ` where `λ` is the Lebesgue measure. -/
lemma integral_eq (hX : measurable X) :
  ∫ x, X x ∂ℙ =
  (volume (support X ℙ))⁻¹.to_real * ∫ x in support X ℙ, x ∂(volume) :=
begin
  rw ← integral_mul_eq_integral hX (mul_pdf_integrable hX),
  all_goals { try { apply_instance } },
  rw integral_congr_ae (filter.eventually_eq.mul (ae_eq_refl _) (pdf_to_real_ae_eq X ℙ)),
  have : ∀ x, x * ((support X ℙ).indicator
      ((volume (support X ℙ))⁻¹ • (1 : ℝ → ℝ≥0∞)) x).to_real =
    x * ((support X ℙ).indicator
      ((volume (support X ℙ))⁻¹.to_real • (1 : ℝ → ℝ)) x),
  { refine λ x, congr_arg ((*) x) _,
    by_cases hx : x ∈ support X ℙ,
    { simp [set.indicator_of_mem hx] },
    { simp [set.indicator_of_not_mem hx] }},
  simp_rw [this, ← (support X ℙ).indicator_mul_right (λ x, x),
           integral_indicator (measurable_set_support X ℙ)],
  change ∫ x in support X ℙ, x * ((volume (support X ℙ))⁻¹.to_real • 1) ∂(volume) = _,
  rw [integral_mul_right, mul_comm, algebra.id.smul_eq_mul, mul_one],
end .

end uniform

end

end pdf

end measure

end measure_theory


/-
Copyright (c) 2018 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Simon Hudon

! This file was ported from Lean 3 source module data.pfunctor.multivariate.W
! leanprover-community/mathlib commit 23aa88e32dcc9d2a24cca7bc23268567ed4cd7d6
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Pfunctor.Multivariate.Basic

/-!
# The W construction as a multivariate polynomial functor.

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

W types are well-founded tree-like structures. They are defined
as the least fixpoint of a polynomial functor.

## Main definitions

 * `W_mk`     - constructor
 * `W_dest    - destructor
 * `W_rec`    - recursor: basis for defining functions by structural recursion on `P.W α`
 * `W_rec_eq` - defining equation for `W_rec`
 * `W_ind`    - induction principle for `P.W α`

## Implementation notes

Three views of M-types:

 * `Wp`: polynomial functor
 * `W`: data type inductively defined by a triple:
     shape of the root, data in the root and children of the root
 * `W`: least fixed point of a polynomial functor

Specifically, we define the polynomial functor `Wp` as:

 * A := a tree-like structure without information in the nodes
 * B := given the tree-like structure `t`, `B t` is a valid path
   (specified inductively by `W_path`) from the root of `t` to any given node.

As a result `Wp.obj α` is made of a dataless tree and a function from
its valid paths to values of `α`

## Reference

 * Jeremy Avigad, Mario M. Carneiro and Simon Hudon.
   [*Data Types as Quotients of Polynomial Functors*][avigad-carneiro-hudon2019]
-/

universe u v

namespace MvPFunctor

open TypeVec

open MvFunctor

variable {n : ℕ} (P : MvPFunctor.{u} (n + 1))

#print MvPFunctor.WPath /-
/-- A path from the root of a tree to one of its node -/
inductive WPath : P.getLast.W → Fin2 n → Type u
  |
  root (a : P.A) (f : P.getLast.B a → P.getLast.W) (i : Fin2 n) (c : P.drop.B a i) : W_path ⟨a, f⟩ i
  |
  child (a : P.A) (f : P.getLast.B a → P.getLast.W) (i : Fin2 n) (j : P.getLast.B a)
    (c : W_path (f j) i) : W_path ⟨a, f⟩ i
#align mvpfunctor.W_path MvPFunctor.WPath
-/

#print MvPFunctor.WPath.inhabited /-
instance WPath.inhabited (x : P.getLast.W) {i} [I : Inhabited (P.drop.B x.headI i)] :
    Inhabited (WPath P x i) :=
  ⟨match x, I with
    | ⟨a, f⟩, I => WPath.root a f i (@default _ I)⟩
#align mvpfunctor.W_path.inhabited MvPFunctor.WPath.inhabited
-/

#print MvPFunctor.wPathCasesOn /-
/-- Specialized destructor on `W_path` -/
def wPathCasesOn {α : TypeVec n} {a : P.A} {f : P.getLast.B a → P.getLast.W} (g' : P.drop.B a ⟹ α)
    (g : ∀ j : P.getLast.B a, P.WPath (f j) ⟹ α) : P.WPath ⟨a, f⟩ ⟹ α :=
  by
  intro i x; cases x
  case root _ _ i c => exact g' i c
  case child _ _ i j c => exact g j i c
#align mvpfunctor.W_path_cases_on MvPFunctor.wPathCasesOn
-/

#print MvPFunctor.wPathDestLeft /-
/-- Specialized destructor on `W_path` -/
def wPathDestLeft {α : TypeVec n} {a : P.A} {f : P.getLast.B a → P.getLast.W}
    (h : P.WPath ⟨a, f⟩ ⟹ α) : P.drop.B a ⟹ α := fun i c => h i (WPath.root a f i c)
#align mvpfunctor.W_path_dest_left MvPFunctor.wPathDestLeft
-/

#print MvPFunctor.wPathDestRight /-
/-- Specialized destructor on `W_path` -/
def wPathDestRight {α : TypeVec n} {a : P.A} {f : P.getLast.B a → P.getLast.W}
    (h : P.WPath ⟨a, f⟩ ⟹ α) : ∀ j : P.getLast.B a, P.WPath (f j) ⟹ α := fun j i c =>
  h i (WPath.child a f i j c)
#align mvpfunctor.W_path_dest_right MvPFunctor.wPathDestRight
-/

/- warning: mvpfunctor.W_path_dest_left_W_path_cases_on -> MvPFunctor.wPathDestLeft_wPathCasesOn is a dubious translation:
lean 3 declaration is
  forall {n : Nat} (P : MvPFunctor.{u1} (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne))))) {α : TypeVec.{u2} n} {a : MvPFunctor.A.{u1} (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne)))) P} {f : (PFunctor.B.{u1} (MvPFunctor.last.{u1} n P) a) -> (PFunctor.W.{u1} (MvPFunctor.last.{u1} n P))} (g' : TypeVec.Arrow.{u1, u2} n (MvPFunctor.b.{u1} n (MvPFunctor.drop.{u1} n P) a) α) (g : forall (j : PFunctor.B.{u1} (MvPFunctor.last.{u1} n P) a), TypeVec.Arrow.{u1, u2} n (MvPFunctor.WPath.{u1} n P (f j)) α), Eq.{max 1 (succ u1) (succ u2)} (TypeVec.Arrow.{u1, u2} n (MvPFunctor.b.{u1} n (MvPFunctor.drop.{u1} n P) a) α) (MvPFunctor.wPathDestLeft.{u1, u2} n P α a (fun (j : PFunctor.B.{u1} (MvPFunctor.last.{u1} n P) a) => f j) (MvPFunctor.wPathCasesOn.{u1, u2} n P α a (fun (j : PFunctor.B.{u1} (MvPFunctor.last.{u1} n P) a) => f j) g' g)) g'
but is expected to have type
  forall {n : Nat} (P : MvPFunctor.{u2} (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))) {α : TypeVec.{u1} n} {a : MvPFunctor.A.{u2} (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1))) P} {f : (PFunctor.B.{u2} (MvPFunctor.last.{u2} n P) a) -> (PFunctor.W.{u2} (MvPFunctor.last.{u2} n P))} (g' : TypeVec.Arrow.{u2, u1} n (MvPFunctor.B.{u2} n (MvPFunctor.drop.{u2} n P) a) α) (g : forall (j : PFunctor.B.{u2} (MvPFunctor.last.{u2} n P) a), TypeVec.Arrow.{u2, u1} n (MvPFunctor.WPath.{u2} n P (f j)) α), Eq.{max (succ u2) (succ u1)} (TypeVec.Arrow.{u2, u1} n (MvPFunctor.B.{u2} n (MvPFunctor.drop.{u2} n P) a) α) (MvPFunctor.wPathDestLeft.{u2, u1} n P α a (fun (j : PFunctor.B.{u2} (MvPFunctor.last.{u2} n P) a) => f j) (MvPFunctor.wPathCasesOn.{u2, u1} n P α a (fun (j : PFunctor.B.{u2} (MvPFunctor.last.{u2} n P) a) => f j) g' g)) g'
Case conversion may be inaccurate. Consider using '#align mvpfunctor.W_path_dest_left_W_path_cases_on MvPFunctor.wPathDestLeft_wPathCasesOnₓ'. -/
theorem wPathDestLeft_wPathCasesOn {α : TypeVec n} {a : P.A} {f : P.getLast.B a → P.getLast.W}
    (g' : P.drop.B a ⟹ α) (g : ∀ j : P.getLast.B a, P.WPath (f j) ⟹ α) :
    P.wPathDestLeft (P.wPathCasesOn g' g) = g' :=
  rfl
#align mvpfunctor.W_path_dest_left_W_path_cases_on MvPFunctor.wPathDestLeft_wPathCasesOn

/- warning: mvpfunctor.W_path_dest_right_W_path_cases_on -> MvPFunctor.wPathDestRight_wPathCasesOn is a dubious translation:
lean 3 declaration is
  forall {n : Nat} (P : MvPFunctor.{u1} (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne))))) {α : TypeVec.{u2} n} {a : MvPFunctor.A.{u1} (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne)))) P} {f : (PFunctor.B.{u1} (MvPFunctor.last.{u1} n P) a) -> (PFunctor.W.{u1} (MvPFunctor.last.{u1} n P))} (g' : TypeVec.Arrow.{u1, u2} n (MvPFunctor.b.{u1} n (MvPFunctor.drop.{u1} n P) a) α) (g : forall (j : PFunctor.B.{u1} (MvPFunctor.last.{u1} n P) a), TypeVec.Arrow.{u1, u2} n (MvPFunctor.WPath.{u1} n P (f j)) α), Eq.{max (succ u1) 1 (succ u1) (succ u2)} (forall (j : PFunctor.B.{u1} (MvPFunctor.last.{u1} n P) a), TypeVec.Arrow.{u1, u2} n (MvPFunctor.WPath.{u1} n P (f j)) α) (MvPFunctor.wPathDestRight.{u1, u2} n P α a (fun (j : PFunctor.B.{u1} (MvPFunctor.last.{u1} n P) a) => f j) (MvPFunctor.wPathCasesOn.{u1, u2} n P α a (fun (j : PFunctor.B.{u1} (MvPFunctor.last.{u1} n P) a) => f j) g' g)) g
but is expected to have type
  forall {n : Nat} (P : MvPFunctor.{u2} (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))) {α : TypeVec.{u1} n} {a : MvPFunctor.A.{u2} (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1))) P} {f : (PFunctor.B.{u2} (MvPFunctor.last.{u2} n P) a) -> (PFunctor.W.{u2} (MvPFunctor.last.{u2} n P))} (g' : TypeVec.Arrow.{u2, u1} n (MvPFunctor.B.{u2} n (MvPFunctor.drop.{u2} n P) a) α) (g : forall (j : PFunctor.B.{u2} (MvPFunctor.last.{u2} n P) a), TypeVec.Arrow.{u2, u1} n (MvPFunctor.WPath.{u2} n P (f j)) α), Eq.{max (succ u2) (succ u1)} (forall (j : PFunctor.B.{u2} (MvPFunctor.last.{u2} n P) a), TypeVec.Arrow.{u2, u1} n (MvPFunctor.WPath.{u2} n P (f j)) α) (MvPFunctor.wPathDestRight.{u2, u1} n P α a (fun (j : PFunctor.B.{u2} (MvPFunctor.last.{u2} n P) a) => f j) (MvPFunctor.wPathCasesOn.{u2, u1} n P α a (fun (j : PFunctor.B.{u2} (MvPFunctor.last.{u2} n P) a) => f j) g' g)) g
Case conversion may be inaccurate. Consider using '#align mvpfunctor.W_path_dest_right_W_path_cases_on MvPFunctor.wPathDestRight_wPathCasesOnₓ'. -/
theorem wPathDestRight_wPathCasesOn {α : TypeVec n} {a : P.A} {f : P.getLast.B a → P.getLast.W}
    (g' : P.drop.B a ⟹ α) (g : ∀ j : P.getLast.B a, P.WPath (f j) ⟹ α) :
    P.wPathDestRight (P.wPathCasesOn g' g) = g :=
  rfl
#align mvpfunctor.W_path_dest_right_W_path_cases_on MvPFunctor.wPathDestRight_wPathCasesOn

/- warning: mvpfunctor.W_path_cases_on_eta -> MvPFunctor.wPathCasesOn_eta is a dubious translation:
lean 3 declaration is
  forall {n : Nat} (P : MvPFunctor.{u1} (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne))))) {α : TypeVec.{u2} n} {a : MvPFunctor.A.{u1} (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne)))) P} {f : (PFunctor.B.{u1} (MvPFunctor.last.{u1} n P) a) -> (PFunctor.W.{u1} (MvPFunctor.last.{u1} n P))} (h : TypeVec.Arrow.{u1, u2} n (MvPFunctor.WPath.{u1} n P (WType.mk.{u1, u1} (PFunctor.A.{u1} (MvPFunctor.last.{u1} n P)) (PFunctor.B.{u1} (MvPFunctor.last.{u1} n P)) a f)) α), Eq.{max 1 (succ u1) (succ u2)} (TypeVec.Arrow.{u1, u2} n (MvPFunctor.WPath.{u1} n P (WType.mk.{u1, u1} (PFunctor.A.{u1} (MvPFunctor.last.{u1} n P)) (PFunctor.B.{u1} (MvPFunctor.last.{u1} n P)) a (fun (j : PFunctor.B.{u1} (MvPFunctor.last.{u1} n P) a) => f j))) α) (MvPFunctor.wPathCasesOn.{u1, u2} n P α a (fun (j : PFunctor.B.{u1} (MvPFunctor.last.{u1} n P) a) => f j) (MvPFunctor.wPathDestLeft.{u1, u2} n P α a f h) (MvPFunctor.wPathDestRight.{u1, u2} n P α a f h)) h
but is expected to have type
  forall {n : Nat} (P : MvPFunctor.{u2} (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))) {α : TypeVec.{u1} n} {a : MvPFunctor.A.{u2} (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1))) P} {f : (PFunctor.B.{u2} (MvPFunctor.last.{u2} n P) a) -> (PFunctor.W.{u2} (MvPFunctor.last.{u2} n P))} (h : TypeVec.Arrow.{u2, u1} n (MvPFunctor.WPath.{u2} n P (WType.mk.{u2, u2} (PFunctor.A.{u2} (MvPFunctor.last.{u2} n P)) (PFunctor.B.{u2} (MvPFunctor.last.{u2} n P)) a f)) α), Eq.{max (succ u2) (succ u1)} (TypeVec.Arrow.{u2, u1} n (MvPFunctor.WPath.{u2} n P (WType.mk.{u2, u2} (PFunctor.A.{u2} (MvPFunctor.last.{u2} n P)) (PFunctor.B.{u2} (MvPFunctor.last.{u2} n P)) a (fun (j : PFunctor.B.{u2} (MvPFunctor.last.{u2} n P) a) => f j))) α) (MvPFunctor.wPathCasesOn.{u2, u1} n P α a (fun (j : PFunctor.B.{u2} (MvPFunctor.last.{u2} n P) a) => f j) (MvPFunctor.wPathDestLeft.{u2, u1} n P α a f h) (MvPFunctor.wPathDestRight.{u2, u1} n P α a f h)) h
Case conversion may be inaccurate. Consider using '#align mvpfunctor.W_path_cases_on_eta MvPFunctor.wPathCasesOn_etaₓ'. -/
theorem wPathCasesOn_eta {α : TypeVec n} {a : P.A} {f : P.getLast.B a → P.getLast.W}
    (h : P.WPath ⟨a, f⟩ ⟹ α) : P.wPathCasesOn (P.wPathDestLeft h) (P.wPathDestRight h) = h := by
  ext (i x) <;> cases x <;> rfl
#align mvpfunctor.W_path_cases_on_eta MvPFunctor.wPathCasesOn_eta

/- warning: mvpfunctor.comp_W_path_cases_on -> MvPFunctor.comp_wPathCasesOn is a dubious translation:
lean 3 declaration is
  forall {n : Nat} (P : MvPFunctor.{u1} (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne))))) {α : TypeVec.{u2} n} {β : TypeVec.{u3} n} (h : TypeVec.Arrow.{u2, u3} n α β) {a : MvPFunctor.A.{u1} (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne)))) P} {f : (PFunctor.B.{u1} (MvPFunctor.last.{u1} n P) a) -> (PFunctor.W.{u1} (MvPFunctor.last.{u1} n P))} (g' : TypeVec.Arrow.{u1, u2} n (MvPFunctor.b.{u1} n (MvPFunctor.drop.{u1} n P) a) α) (g : forall (j : PFunctor.B.{u1} (MvPFunctor.last.{u1} n P) a), TypeVec.Arrow.{u1, u2} n (MvPFunctor.WPath.{u1} n P (f j)) α), Eq.{max 1 (succ u1) (succ u3)} (TypeVec.Arrow.{u1, u3} n (MvPFunctor.WPath.{u1} n P (WType.mk.{u1, u1} (PFunctor.A.{u1} (MvPFunctor.last.{u1} n P)) (PFunctor.B.{u1} (MvPFunctor.last.{u1} n P)) a (fun (j : PFunctor.B.{u1} (MvPFunctor.last.{u1} n P) a) => f j))) β) (TypeVec.comp.{u1, u2, u3} n (MvPFunctor.WPath.{u1} n P (WType.mk.{u1, u1} (PFunctor.A.{u1} (MvPFunctor.last.{u1} n P)) (PFunctor.B.{u1} (MvPFunctor.last.{u1} n P)) a (fun (j : PFunctor.B.{u1} (MvPFunctor.last.{u1} n P) a) => f j))) α β h (MvPFunctor.wPathCasesOn.{u1, u2} n P α a (fun (j : PFunctor.B.{u1} (MvPFunctor.last.{u1} n P) a) => f j) g' g)) (MvPFunctor.wPathCasesOn.{u1, u3} n P β a (fun (j : PFunctor.B.{u1} (MvPFunctor.last.{u1} n P) a) => f j) (TypeVec.comp.{u1, u2, u3} n (MvPFunctor.b.{u1} n (MvPFunctor.drop.{u1} n P) a) α β h g') (fun (i : PFunctor.B.{u1} (MvPFunctor.last.{u1} n P) a) => TypeVec.comp.{u1, u2, u3} n (MvPFunctor.WPath.{u1} n P (f i)) α β h (g i)))
but is expected to have type
  forall {n : Nat} (P : MvPFunctor.{u3} (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))) {α : TypeVec.{u2} n} {β : TypeVec.{u1} n} (h : TypeVec.Arrow.{u2, u1} n α β) {a : MvPFunctor.A.{u3} (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1))) P} {f : (PFunctor.B.{u3} (MvPFunctor.last.{u3} n P) a) -> (PFunctor.W.{u3} (MvPFunctor.last.{u3} n P))} (g' : TypeVec.Arrow.{u3, u2} n (MvPFunctor.B.{u3} n (MvPFunctor.drop.{u3} n P) a) α) (g : forall (j : PFunctor.B.{u3} (MvPFunctor.last.{u3} n P) a), TypeVec.Arrow.{u3, u2} n (MvPFunctor.WPath.{u3} n P (f j)) α), Eq.{max (succ u3) (succ u1)} (TypeVec.Arrow.{u3, u1} n (MvPFunctor.WPath.{u3} n P (WType.mk.{u3, u3} (PFunctor.A.{u3} (MvPFunctor.last.{u3} n P)) (PFunctor.B.{u3} (MvPFunctor.last.{u3} n P)) a (fun (j : PFunctor.B.{u3} (MvPFunctor.last.{u3} n P) a) => f j))) β) (TypeVec.comp.{u3, u2, u1} n (MvPFunctor.WPath.{u3} n P (WType.mk.{u3, u3} (PFunctor.A.{u3} (MvPFunctor.last.{u3} n P)) (PFunctor.B.{u3} (MvPFunctor.last.{u3} n P)) a (fun (j : PFunctor.B.{u3} (MvPFunctor.last.{u3} n P) a) => f j))) α β h (MvPFunctor.wPathCasesOn.{u3, u2} n P α a (fun (j : PFunctor.B.{u3} (MvPFunctor.last.{u3} n P) a) => f j) g' g)) (MvPFunctor.wPathCasesOn.{u3, u1} n P β a (fun (j : PFunctor.B.{u3} (MvPFunctor.last.{u3} n P) a) => f j) (TypeVec.comp.{u3, u2, u1} n (MvPFunctor.B.{u3} n (MvPFunctor.drop.{u3} n P) a) α β h g') (fun (i : PFunctor.B.{u3} (MvPFunctor.last.{u3} n P) a) => TypeVec.comp.{u3, u2, u1} n (MvPFunctor.WPath.{u3} n P (f i)) α β h (g i)))
Case conversion may be inaccurate. Consider using '#align mvpfunctor.comp_W_path_cases_on MvPFunctor.comp_wPathCasesOnₓ'. -/
theorem comp_wPathCasesOn {α β : TypeVec n} (h : α ⟹ β) {a : P.A} {f : P.getLast.B a → P.getLast.W}
    (g' : P.drop.B a ⟹ α) (g : ∀ j : P.getLast.B a, P.WPath (f j) ⟹ α) :
    h ⊚ P.wPathCasesOn g' g = P.wPathCasesOn (h ⊚ g') fun i => h ⊚ g i := by
  ext (i x) <;> cases x <;> rfl
#align mvpfunctor.comp_W_path_cases_on MvPFunctor.comp_wPathCasesOn

#print MvPFunctor.wp /-
/-- Polynomial functor for the W-type of `P`. `A` is a data-less well-founded
tree whereas, for a given `a : A`, `B a` is a valid path in tree `a` so
that `Wp.obj α` is made of a tree and a function from its valid paths to
the values it contains  -/
def wp : MvPFunctor n where
  A := P.getLast.W
  B := P.WPath
#align mvpfunctor.Wp MvPFunctor.wp
-/

#print MvPFunctor.W /-
/-- W-type of `P` -/
@[nolint has_nonempty_instance]
def W (α : TypeVec n) : Type _ :=
  P.wp.Obj α
#align mvpfunctor.W MvPFunctor.W
-/

#print MvPFunctor.mvfunctorW /-
instance mvfunctorW : MvFunctor P.W := by delta MvPFunctor.W <;> infer_instance
#align mvpfunctor.mvfunctor_W MvPFunctor.mvfunctorW
-/

/-!
First, describe operations on `W` as a polynomial functor.
-/

#print MvPFunctor.wpMk /-
/-- Constructor for `Wp` -/
def wpMk {α : TypeVec n} (a : P.A) (f : P.getLast.B a → P.getLast.W) (f' : P.WPath ⟨a, f⟩ ⟹ α) :
    P.W α :=
  ⟨⟨a, f⟩, f'⟩
#align mvpfunctor.Wp_mk MvPFunctor.wpMk
-/

#print MvPFunctor.wpRec /-
/-- Recursor for `Wp` -/
def wpRec {α : TypeVec n} {C : Type _}
    (g :
      ∀ (a : P.A) (f : P.getLast.B a → P.getLast.W), P.WPath ⟨a, f⟩ ⟹ α → (P.getLast.B a → C) → C) :
    ∀ (x : P.getLast.W) (f' : P.WPath x ⟹ α), C
  | ⟨a, f⟩, f' => g a f f' fun i => Wp_rec (f i) (P.wPathDestRight f' i)
#align mvpfunctor.Wp_rec MvPFunctor.wpRec
-/

/- warning: mvpfunctor.Wp_rec_eq -> MvPFunctor.wpRec_eq is a dubious translation:
lean 3 declaration is
  forall {n : Nat} (P : MvPFunctor.{u1} (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne))))) {α : TypeVec.{u2} n} {C : Type.{u3}} (g : forall (a : MvPFunctor.A.{u1} (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne)))) P) (f : (PFunctor.B.{u1} (MvPFunctor.last.{u1} n P) a) -> (PFunctor.W.{u1} (MvPFunctor.last.{u1} n P))), (TypeVec.Arrow.{u1, u2} n (MvPFunctor.WPath.{u1} n P (WType.mk.{u1, u1} (PFunctor.A.{u1} (MvPFunctor.last.{u1} n P)) (PFunctor.B.{u1} (MvPFunctor.last.{u1} n P)) a f)) α) -> ((PFunctor.B.{u1} (MvPFunctor.last.{u1} n P) a) -> C) -> C) (a : MvPFunctor.A.{u1} (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne)))) P) (f : (PFunctor.B.{u1} (MvPFunctor.last.{u1} n P) a) -> (PFunctor.W.{u1} (MvPFunctor.last.{u1} n P))) (f' : TypeVec.Arrow.{u1, u2} n (MvPFunctor.WPath.{u1} n P (WType.mk.{u1, u1} (PFunctor.A.{u1} (MvPFunctor.last.{u1} n P)) (PFunctor.B.{u1} (MvPFunctor.last.{u1} n P)) a f)) α), Eq.{succ u3} C (MvPFunctor.wpRec.{u1, u2, u3} n P α C g (WType.mk.{u1, u1} (PFunctor.A.{u1} (MvPFunctor.last.{u1} n P)) (PFunctor.B.{u1} (MvPFunctor.last.{u1} n P)) a f) f') (g a f f' (fun (i : PFunctor.B.{u1} (MvPFunctor.last.{u1} n P) a) => MvPFunctor.wpRec.{u1, u2, u3} n P α C g (f i) (MvPFunctor.wPathDestRight.{u1, u2} n P α a f f' i)))
but is expected to have type
  forall {n : Nat} (P : MvPFunctor.{u3} (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))) {α : TypeVec.{u2} n} {C : Type.{u1}} (g : forall (a : MvPFunctor.A.{u3} (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1))) P) (f : (PFunctor.B.{u3} (MvPFunctor.last.{u3} n P) a) -> (PFunctor.W.{u3} (MvPFunctor.last.{u3} n P))), (TypeVec.Arrow.{u3, u2} n (MvPFunctor.WPath.{u3} n P (WType.mk.{u3, u3} (PFunctor.A.{u3} (MvPFunctor.last.{u3} n P)) (PFunctor.B.{u3} (MvPFunctor.last.{u3} n P)) a f)) α) -> ((PFunctor.B.{u3} (MvPFunctor.last.{u3} n P) a) -> C) -> C) (a : MvPFunctor.A.{u3} (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1))) P) (f : (PFunctor.B.{u3} (MvPFunctor.last.{u3} n P) a) -> (PFunctor.W.{u3} (MvPFunctor.last.{u3} n P))) (f' : TypeVec.Arrow.{u3, u2} n (MvPFunctor.WPath.{u3} n P (WType.mk.{u3, u3} (PFunctor.A.{u3} (MvPFunctor.last.{u3} n P)) (PFunctor.B.{u3} (MvPFunctor.last.{u3} n P)) a f)) α), Eq.{succ u1} C (MvPFunctor.wpRec.{u3, u2, u1} n P α C g (WType.mk.{u3, u3} (PFunctor.A.{u3} (MvPFunctor.last.{u3} n P)) (PFunctor.B.{u3} (MvPFunctor.last.{u3} n P)) a f) f') (g a f f' (fun (i : PFunctor.B.{u3} (MvPFunctor.last.{u3} n P) a) => MvPFunctor.wpRec.{u3, u2, u1} n P α C g (f i) (MvPFunctor.wPathDestRight.{u3, u2} n P α a f f' i)))
Case conversion may be inaccurate. Consider using '#align mvpfunctor.Wp_rec_eq MvPFunctor.wpRec_eqₓ'. -/
theorem wpRec_eq {α : TypeVec n} {C : Type _}
    (g :
      ∀ (a : P.A) (f : P.getLast.B a → P.getLast.W), P.WPath ⟨a, f⟩ ⟹ α → (P.getLast.B a → C) → C)
    (a : P.A) (f : P.getLast.B a → P.getLast.W) (f' : P.WPath ⟨a, f⟩ ⟹ α) :
    P.wpRec g ⟨a, f⟩ f' = g a f f' fun i => P.wpRec g (f i) (P.wPathDestRight f' i) :=
  rfl
#align mvpfunctor.Wp_rec_eq MvPFunctor.wpRec_eq

/- warning: mvpfunctor.Wp_ind -> MvPFunctor.wp_ind is a dubious translation:
lean 3 declaration is
  forall {n : Nat} (P : MvPFunctor.{u1} (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne))))) {α : TypeVec.{u2} n} {C : forall (x : PFunctor.W.{u1} (MvPFunctor.last.{u1} n P)), (TypeVec.Arrow.{u1, u2} n (MvPFunctor.WPath.{u1} n P x) α) -> Prop}, (forall (a : MvPFunctor.A.{u1} (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne)))) P) (f : (PFunctor.B.{u1} (MvPFunctor.last.{u1} n P) a) -> (PFunctor.W.{u1} (MvPFunctor.last.{u1} n P))) (f' : TypeVec.Arrow.{u1, u2} n (MvPFunctor.WPath.{u1} n P (WType.mk.{u1, u1} (PFunctor.A.{u1} (MvPFunctor.last.{u1} n P)) (PFunctor.B.{u1} (MvPFunctor.last.{u1} n P)) a f)) α), (forall (i : PFunctor.B.{u1} (MvPFunctor.last.{u1} n P) a), C (f i) (MvPFunctor.wPathDestRight.{u1, u2} n P α a f f' i)) -> (C (WType.mk.{u1, u1} (PFunctor.A.{u1} (MvPFunctor.last.{u1} n P)) (PFunctor.B.{u1} (MvPFunctor.last.{u1} n P)) a f) f')) -> (forall (x : PFunctor.W.{u1} (MvPFunctor.last.{u1} n P)) (f' : TypeVec.Arrow.{u1, u2} n (MvPFunctor.WPath.{u1} n P x) α), C x f')
but is expected to have type
  forall {n : Nat} (P : MvPFunctor.{u2} (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))) {α : TypeVec.{u1} n} {C : forall (x : PFunctor.W.{u2} (MvPFunctor.last.{u2} n P)), (TypeVec.Arrow.{u2, u1} n (MvPFunctor.WPath.{u2} n P x) α) -> Prop}, (forall (a : MvPFunctor.A.{u2} (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1))) P) (f : (PFunctor.B.{u2} (MvPFunctor.last.{u2} n P) a) -> (PFunctor.W.{u2} (MvPFunctor.last.{u2} n P))) (f' : TypeVec.Arrow.{u2, u1} n (MvPFunctor.WPath.{u2} n P (WType.mk.{u2, u2} (PFunctor.A.{u2} (MvPFunctor.last.{u2} n P)) (PFunctor.B.{u2} (MvPFunctor.last.{u2} n P)) a f)) α), (forall (i : PFunctor.B.{u2} (MvPFunctor.last.{u2} n P) a), C (f i) (MvPFunctor.wPathDestRight.{u2, u1} n P α a f f' i)) -> (C (WType.mk.{u2, u2} (PFunctor.A.{u2} (MvPFunctor.last.{u2} n P)) (PFunctor.B.{u2} (MvPFunctor.last.{u2} n P)) a f) f')) -> (forall (x : PFunctor.W.{u2} (MvPFunctor.last.{u2} n P)) (f' : TypeVec.Arrow.{u2, u1} n (MvPFunctor.WPath.{u2} n P x) α), C x f')
Case conversion may be inaccurate. Consider using '#align mvpfunctor.Wp_ind MvPFunctor.wp_indₓ'. -/
-- Note: we could replace Prop by Type* and obtain a dependent recursor
theorem wp_ind {α : TypeVec n} {C : ∀ x : P.getLast.W, P.WPath x ⟹ α → Prop}
    (ih :
      ∀ (a : P.A) (f : P.getLast.B a → P.getLast.W) (f' : P.WPath ⟨a, f⟩ ⟹ α),
        (∀ i : P.getLast.B a, C (f i) (P.wPathDestRight f' i)) → C ⟨a, f⟩ f') :
    ∀ (x : P.getLast.W) (f' : P.WPath x ⟹ α), C x f'
  | ⟨a, f⟩, f' => ih a f f' fun i => Wp_ind _ _
#align mvpfunctor.Wp_ind MvPFunctor.wp_ind

/-!
Now think of W as defined inductively by the data ⟨a, f', f⟩ where
- `a  : P.A` is the shape of the top node
- `f' : P.drop.B a ⟹ α` is the contents of the top node
- `f  : P.last.B a → P.last.W` are the subtrees
 -/

#print MvPFunctor.wMk /-
/-- Constructor for `W` -/
def wMk {α : TypeVec n} (a : P.A) (f' : P.drop.B a ⟹ α) (f : P.getLast.B a → P.W α) : P.W α :=
  let g : P.getLast.B a → P.getLast.W := fun i => (f i).fst
  let g' : P.WPath ⟨a, g⟩ ⟹ α := P.wPathCasesOn f' fun i => (f i).snd
  ⟨⟨a, g⟩, g'⟩
#align mvpfunctor.W_mk MvPFunctor.wMk
-/

#print MvPFunctor.wRec /-
/-- Recursor for `W` -/
def wRec {α : TypeVec n} {C : Type _}
    (g : ∀ a : P.A, P.drop.B a ⟹ α → (P.getLast.B a → P.W α) → (P.getLast.B a → C) → C) : P.W α → C
  | ⟨a, f'⟩ =>
    let g' (a : P.A) (f : P.getLast.B a → P.getLast.W) (h : P.WPath ⟨a, f⟩ ⟹ α)
      (h' : P.getLast.B a → C) : C :=
      g a (P.wPathDestLeft h) (fun i => ⟨f i, P.wPathDestRight h i⟩) h'
    P.wpRec g' a f'
#align mvpfunctor.W_rec MvPFunctor.wRec
-/

/- warning: mvpfunctor.W_rec_eq -> MvPFunctor.wRec_eq is a dubious translation:
lean 3 declaration is
  forall {n : Nat} (P : MvPFunctor.{u1} (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne))))) {α : TypeVec.{u1} n} {C : Type.{u2}} (g : forall (a : MvPFunctor.A.{u1} (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne)))) P), (TypeVec.Arrow.{u1, u1} n (MvPFunctor.b.{u1} n (MvPFunctor.drop.{u1} n P) a) α) -> ((PFunctor.B.{u1} (MvPFunctor.last.{u1} n P) a) -> (MvPFunctor.W.{u1} n P α)) -> ((PFunctor.B.{u1} (MvPFunctor.last.{u1} n P) a) -> C) -> C) (a : MvPFunctor.A.{u1} (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne)))) P) (f' : TypeVec.Arrow.{u1, u1} n (MvPFunctor.b.{u1} n (MvPFunctor.drop.{u1} n P) a) α) (f : (PFunctor.B.{u1} (MvPFunctor.last.{u1} n P) a) -> (MvPFunctor.W.{u1} n P α)), Eq.{succ u2} C (MvPFunctor.wRec.{u1, u2} n P α C g (MvPFunctor.wMk.{u1} n P α a f' f)) (g a f' f (fun (i : PFunctor.B.{u1} (MvPFunctor.last.{u1} n P) a) => MvPFunctor.wRec.{u1, u2} n P α C g (f i)))
but is expected to have type
  forall {n : Nat} (P : MvPFunctor.{u2} (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))) {α : TypeVec.{u2} n} {C : Type.{u1}} (g : forall (a : MvPFunctor.A.{u2} (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1))) P), (TypeVec.Arrow.{u2, u2} n (MvPFunctor.B.{u2} n (MvPFunctor.drop.{u2} n P) a) α) -> ((PFunctor.B.{u2} (MvPFunctor.last.{u2} n P) a) -> (MvPFunctor.W.{u2} n P α)) -> ((PFunctor.B.{u2} (MvPFunctor.last.{u2} n P) a) -> C) -> C) (a : MvPFunctor.A.{u2} (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1))) P) (f' : TypeVec.Arrow.{u2, u2} n (MvPFunctor.B.{u2} n (MvPFunctor.drop.{u2} n P) a) α) (f : (PFunctor.B.{u2} (MvPFunctor.last.{u2} n P) a) -> (MvPFunctor.W.{u2} n P α)), Eq.{succ u1} C (MvPFunctor.wRec.{u2, u1} n P α C g (MvPFunctor.wMk.{u2} n P α a f' f)) (g a f' f (fun (i : PFunctor.B.{u2} (MvPFunctor.last.{u2} n P) a) => MvPFunctor.wRec.{u2, u1} n P α C g (f i)))
Case conversion may be inaccurate. Consider using '#align mvpfunctor.W_rec_eq MvPFunctor.wRec_eqₓ'. -/
/-- Defining equation for the recursor of `W` -/
theorem wRec_eq {α : TypeVec n} {C : Type _}
    (g : ∀ a : P.A, P.drop.B a ⟹ α → (P.getLast.B a → P.W α) → (P.getLast.B a → C) → C) (a : P.A)
    (f' : P.drop.B a ⟹ α) (f : P.getLast.B a → P.W α) :
    P.wRec g (P.wMk a f' f) = g a f' f fun i => P.wRec g (f i) :=
  by
  rw [W_mk, W_rec]; dsimp; rw [Wp_rec_eq]
  dsimp only [W_path_dest_left_W_path_cases_on, W_path_dest_right_W_path_cases_on]
  congr <;> ext1 i <;> cases f i <;> rfl
#align mvpfunctor.W_rec_eq MvPFunctor.wRec_eq

#print MvPFunctor.w_ind /-
/-- Induction principle for `W` -/
theorem w_ind {α : TypeVec n} {C : P.W α → Prop}
    (ih :
      ∀ (a : P.A) (f' : P.drop.B a ⟹ α) (f : P.getLast.B a → P.W α),
        (∀ i, C (f i)) → C (P.wMk a f' f)) :
    ∀ x, C x := by
  intro x; cases' x with a f
  apply @Wp_ind n P α fun a f => C ⟨a, f⟩; dsimp
  intro a f f' ih'
  dsimp [W_mk] at ih
  let ih'' := ih a (P.W_path_dest_left f') fun i => ⟨f i, P.W_path_dest_right f' i⟩
  dsimp at ih''; rw [W_path_cases_on_eta] at ih''
  apply ih''
  apply ih'
#align mvpfunctor.W_ind MvPFunctor.w_ind
-/

#print MvPFunctor.w_cases /-
theorem w_cases {α : TypeVec n} {C : P.W α → Prop}
    (ih : ∀ (a : P.A) (f' : P.drop.B a ⟹ α) (f : P.getLast.B a → P.W α), C (P.wMk a f' f)) :
    ∀ x, C x :=
  P.w_ind fun a f' f ih' => ih a f' f
#align mvpfunctor.W_cases MvPFunctor.w_cases
-/

#print MvPFunctor.wMap /-
/-- W-types are functorial -/
def wMap {α β : TypeVec n} (g : α ⟹ β) : P.W α → P.W β := fun x => g <$$> x
#align mvpfunctor.W_map MvPFunctor.wMap
-/

#print MvPFunctor.wMk_eq /-
theorem wMk_eq {α : TypeVec n} (a : P.A) (f : P.getLast.B a → P.getLast.W) (g' : P.drop.B a ⟹ α)
    (g : ∀ j : P.getLast.B a, P.WPath (f j) ⟹ α) :
    (P.wMk a g' fun i => ⟨f i, g i⟩) = ⟨⟨a, f⟩, P.wPathCasesOn g' g⟩ :=
  rfl
#align mvpfunctor.W_mk_eq MvPFunctor.wMk_eq
-/

#print MvPFunctor.w_map_wMk /-
theorem w_map_wMk {α β : TypeVec n} (g : α ⟹ β) (a : P.A) (f' : P.drop.B a ⟹ α)
    (f : P.getLast.B a → P.W α) : g <$$> P.wMk a f' f = P.wMk a (g ⊚ f') fun i => g <$$> f i :=
  by
  show _ = P.W_mk a (g ⊚ f') (MvFunctor.map g ∘ f)
  have : MvFunctor.map g ∘ f = fun i => ⟨(f i).fst, g ⊚ (f i).snd⟩ :=
    by
    ext i : 1
    dsimp [Function.comp]
    cases f i
    rfl
  rw [this]
  have : f = fun i => ⟨(f i).fst, (f i).snd⟩ := by
    ext1
    cases f x
    rfl
  rw [this]
  dsimp
  rw [W_mk_eq, W_mk_eq]
  have h := MvPFunctor.map_eq P.Wp g
  rw [h, comp_W_path_cases_on]
#align mvpfunctor.W_map_W_mk MvPFunctor.w_map_wMk
-/

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
#print MvPFunctor.objAppend1 /-
-- TODO: this technical theorem is used in one place in constructing the initial algebra.
-- Can it be avoided?
/-- Constructor of a value of `P.obj (α ::: β)` from components.
Useful to avoid complicated type annotation -/
@[reducible]
def objAppend1 {α : TypeVec n} {β : Type _} (a : P.A) (f' : P.drop.B a ⟹ α)
    (f : P.getLast.B a → β) : P.Obj (α ::: β) :=
  ⟨a, splitFun f' f⟩
#align mvpfunctor.obj_append1 MvPFunctor.objAppend1
-/

#print MvPFunctor.map_objAppend1 /-
theorem map_objAppend1 {α γ : TypeVec n} (g : α ⟹ γ) (a : P.A) (f' : P.drop.B a ⟹ α)
    (f : P.getLast.B a → P.W α) :
    appendFun g (P.wMap g) <$$> P.objAppend1 a f' f =
      P.objAppend1 a (g ⊚ f') fun x => P.wMap g (f x) :=
  by rw [obj_append1, obj_append1, map_eq, append_fun, ← split_fun_comp] <;> rfl
#align mvpfunctor.map_obj_append1 MvPFunctor.map_objAppend1
-/

/-!
Yet another view of the W type: as a fixed point for a multivariate polynomial functor.
These are needed to use the W-construction to construct a fixed point of a qpf, since
the qpf axioms are expressed in terms of `map` on `P`.
-/

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
#print MvPFunctor.wMk' /-
/-- Constructor for the W-type of `P` -/
def wMk' {α : TypeVec n} : P.Obj (α ::: P.W α) → P.W α
  | ⟨a, f⟩ => P.wMk a (dropFun f) (lastFun f)
#align mvpfunctor.W_mk' MvPFunctor.wMk'
-/

#print MvPFunctor.wDest' /-
/-- Destructor for the W-type of `P` -/
def wDest' {α : TypeVec.{u} n} : P.W α → P.Obj (α.append1 (P.W α)) :=
  P.wRec fun a f' f _ => ⟨a, splitFun f' f⟩
#align mvpfunctor.W_dest' MvPFunctor.wDest'
-/

#print MvPFunctor.wDest'_wMk /-
theorem wDest'_wMk {α : TypeVec n} (a : P.A) (f' : P.drop.B a ⟹ α) (f : P.getLast.B a → P.W α) :
    P.wDest' (P.wMk a f' f) = ⟨a, splitFun f' f⟩ := by rw [W_dest', W_rec_eq]
#align mvpfunctor.W_dest'_W_mk MvPFunctor.wDest'_wMk
-/

#print MvPFunctor.wDest'_wMk' /-
theorem wDest'_wMk' {α : TypeVec n} (x : P.Obj (α.append1 (P.W α))) : P.wDest' (P.wMk' x) = x := by
  cases' x with a f <;> rw [W_mk', W_dest'_W_mk, split_drop_fun_last_fun]
#align mvpfunctor.W_dest'_W_mk' MvPFunctor.wDest'_wMk'
-/

end MvPFunctor


/-
Copyright (c) 2022 Yury G. Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury G. Kudryashov

! This file was ported from Lean 3 source module topology.algebra.order.extr_closure
! leanprover-community/mathlib commit 50832daea47b195a48b5b33b1c8b2162c48c3afc
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Topology.LocalExtr
import Mathbin.Topology.Order.Basic

/-!
# Maximum/minimum on the closure of a set

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

In this file we prove several versions of the following statement: if `f : X → Y` has a (local or
not) maximum (or minimum) on a set `s` at a point `a` and is continuous on the closure of `s`, then
`f` has an extremum of the same type on `closure s` at `a`.
-/

open Filter Set

open Topology

variable {X Y : Type _} [TopologicalSpace X] [TopologicalSpace Y] [Preorder Y]
  [OrderClosedTopology Y] {f g : X → Y} {s : Set X} {a : X}

/- warning: is_max_on.closure -> IsMaxOn.closure is a dubious translation:
lean 3 declaration is
  forall {X : Type.{u1}} {Y : Type.{u2}} [_inst_1 : TopologicalSpace.{u1} X] [_inst_2 : TopologicalSpace.{u2} Y] [_inst_3 : Preorder.{u2} Y] [_inst_4 : OrderClosedTopology.{u2} Y _inst_2 _inst_3] {f : X -> Y} {s : Set.{u1} X} {a : X}, (IsMaxOn.{u1, u2} X Y _inst_3 f s a) -> (ContinuousOn.{u1, u2} X Y _inst_1 _inst_2 f (closure.{u1} X _inst_1 s)) -> (IsMaxOn.{u1, u2} X Y _inst_3 f (closure.{u1} X _inst_1 s) a)
but is expected to have type
  forall {X : Type.{u2}} {Y : Type.{u1}} [_inst_1 : TopologicalSpace.{u2} X] [_inst_2 : TopologicalSpace.{u1} Y] [_inst_3 : Preorder.{u1} Y] [_inst_4 : OrderClosedTopology.{u1} Y _inst_2 _inst_3] {f : X -> Y} {s : Set.{u2} X} {a : X}, (IsMaxOn.{u2, u1} X Y _inst_3 f s a) -> (ContinuousOn.{u2, u1} X Y _inst_1 _inst_2 f (closure.{u2} X _inst_1 s)) -> (IsMaxOn.{u2, u1} X Y _inst_3 f (closure.{u2} X _inst_1 s) a)
Case conversion may be inaccurate. Consider using '#align is_max_on.closure IsMaxOn.closureₓ'. -/
protected theorem IsMaxOn.closure (h : IsMaxOn f s a) (hc : ContinuousOn f (closure s)) :
    IsMaxOn f (closure s) a := fun x hx =>
  ContinuousWithinAt.closure_le hx ((hc x hx).mono subset_closure) continuousWithinAt_const h
#align is_max_on.closure IsMaxOn.closure

/- warning: is_min_on.closure -> IsMinOn.closure is a dubious translation:
lean 3 declaration is
  forall {X : Type.{u1}} {Y : Type.{u2}} [_inst_1 : TopologicalSpace.{u1} X] [_inst_2 : TopologicalSpace.{u2} Y] [_inst_3 : Preorder.{u2} Y] [_inst_4 : OrderClosedTopology.{u2} Y _inst_2 _inst_3] {f : X -> Y} {s : Set.{u1} X} {a : X}, (IsMinOn.{u1, u2} X Y _inst_3 f s a) -> (ContinuousOn.{u1, u2} X Y _inst_1 _inst_2 f (closure.{u1} X _inst_1 s)) -> (IsMinOn.{u1, u2} X Y _inst_3 f (closure.{u1} X _inst_1 s) a)
but is expected to have type
  forall {X : Type.{u2}} {Y : Type.{u1}} [_inst_1 : TopologicalSpace.{u2} X] [_inst_2 : TopologicalSpace.{u1} Y] [_inst_3 : Preorder.{u1} Y] [_inst_4 : OrderClosedTopology.{u1} Y _inst_2 _inst_3] {f : X -> Y} {s : Set.{u2} X} {a : X}, (IsMinOn.{u2, u1} X Y _inst_3 f s a) -> (ContinuousOn.{u2, u1} X Y _inst_1 _inst_2 f (closure.{u2} X _inst_1 s)) -> (IsMinOn.{u2, u1} X Y _inst_3 f (closure.{u2} X _inst_1 s) a)
Case conversion may be inaccurate. Consider using '#align is_min_on.closure IsMinOn.closureₓ'. -/
protected theorem IsMinOn.closure (h : IsMinOn f s a) (hc : ContinuousOn f (closure s)) :
    IsMinOn f (closure s) a :=
  h.dual.closure hc
#align is_min_on.closure IsMinOn.closure

/- warning: is_extr_on.closure -> IsExtrOn.closure is a dubious translation:
lean 3 declaration is
  forall {X : Type.{u1}} {Y : Type.{u2}} [_inst_1 : TopologicalSpace.{u1} X] [_inst_2 : TopologicalSpace.{u2} Y] [_inst_3 : Preorder.{u2} Y] [_inst_4 : OrderClosedTopology.{u2} Y _inst_2 _inst_3] {f : X -> Y} {s : Set.{u1} X} {a : X}, (IsExtrOn.{u1, u2} X Y _inst_3 f s a) -> (ContinuousOn.{u1, u2} X Y _inst_1 _inst_2 f (closure.{u1} X _inst_1 s)) -> (IsExtrOn.{u1, u2} X Y _inst_3 f (closure.{u1} X _inst_1 s) a)
but is expected to have type
  forall {X : Type.{u2}} {Y : Type.{u1}} [_inst_1 : TopologicalSpace.{u2} X] [_inst_2 : TopologicalSpace.{u1} Y] [_inst_3 : Preorder.{u1} Y] [_inst_4 : OrderClosedTopology.{u1} Y _inst_2 _inst_3] {f : X -> Y} {s : Set.{u2} X} {a : X}, (IsExtrOn.{u2, u1} X Y _inst_3 f s a) -> (ContinuousOn.{u2, u1} X Y _inst_1 _inst_2 f (closure.{u2} X _inst_1 s)) -> (IsExtrOn.{u2, u1} X Y _inst_3 f (closure.{u2} X _inst_1 s) a)
Case conversion may be inaccurate. Consider using '#align is_extr_on.closure IsExtrOn.closureₓ'. -/
protected theorem IsExtrOn.closure (h : IsExtrOn f s a) (hc : ContinuousOn f (closure s)) :
    IsExtrOn f (closure s) a :=
  h.elim (fun h => Or.inl <| h.closure hc) fun h => Or.inr <| h.closure hc
#align is_extr_on.closure IsExtrOn.closure

/- warning: is_local_max_on.closure -> IsLocalMaxOn.closure is a dubious translation:
lean 3 declaration is
  forall {X : Type.{u1}} {Y : Type.{u2}} [_inst_1 : TopologicalSpace.{u1} X] [_inst_2 : TopologicalSpace.{u2} Y] [_inst_3 : Preorder.{u2} Y] [_inst_4 : OrderClosedTopology.{u2} Y _inst_2 _inst_3] {f : X -> Y} {s : Set.{u1} X} {a : X}, (IsLocalMaxOn.{u1, u2} X Y _inst_1 _inst_3 f s a) -> (ContinuousOn.{u1, u2} X Y _inst_1 _inst_2 f (closure.{u1} X _inst_1 s)) -> (IsLocalMaxOn.{u1, u2} X Y _inst_1 _inst_3 f (closure.{u1} X _inst_1 s) a)
but is expected to have type
  forall {X : Type.{u2}} {Y : Type.{u1}} [_inst_1 : TopologicalSpace.{u2} X] [_inst_2 : TopologicalSpace.{u1} Y] [_inst_3 : Preorder.{u1} Y] [_inst_4 : OrderClosedTopology.{u1} Y _inst_2 _inst_3] {f : X -> Y} {s : Set.{u2} X} {a : X}, (IsLocalMaxOn.{u2, u1} X Y _inst_1 _inst_3 f s a) -> (ContinuousOn.{u2, u1} X Y _inst_1 _inst_2 f (closure.{u2} X _inst_1 s)) -> (IsLocalMaxOn.{u2, u1} X Y _inst_1 _inst_3 f (closure.{u2} X _inst_1 s) a)
Case conversion may be inaccurate. Consider using '#align is_local_max_on.closure IsLocalMaxOn.closureₓ'. -/
protected theorem IsLocalMaxOn.closure (h : IsLocalMaxOn f s a) (hc : ContinuousOn f (closure s)) :
    IsLocalMaxOn f (closure s) a :=
  by
  rcases mem_nhdsWithin.1 h with ⟨U, Uo, aU, hU⟩
  refine' mem_nhdsWithin.2 ⟨U, Uo, aU, _⟩
  rintro x ⟨hxU, hxs⟩
  refine' ContinuousWithinAt.closure_le _ _ continuousWithinAt_const hU
  · rwa [mem_closure_iff_nhdsWithin_neBot, nhdsWithin_inter_of_mem, ←
      mem_closure_iff_nhdsWithin_neBot]
    exact nhdsWithin_le_nhds (Uo.mem_nhds hxU)
  · exact (hc _ hxs).mono ((inter_subset_right _ _).trans subset_closure)
#align is_local_max_on.closure IsLocalMaxOn.closure

/- warning: is_local_min_on.closure -> IsLocalMinOn.closure is a dubious translation:
lean 3 declaration is
  forall {X : Type.{u1}} {Y : Type.{u2}} [_inst_1 : TopologicalSpace.{u1} X] [_inst_2 : TopologicalSpace.{u2} Y] [_inst_3 : Preorder.{u2} Y] [_inst_4 : OrderClosedTopology.{u2} Y _inst_2 _inst_3] {f : X -> Y} {s : Set.{u1} X} {a : X}, (IsLocalMinOn.{u1, u2} X Y _inst_1 _inst_3 f s a) -> (ContinuousOn.{u1, u2} X Y _inst_1 _inst_2 f (closure.{u1} X _inst_1 s)) -> (IsLocalMinOn.{u1, u2} X Y _inst_1 _inst_3 f (closure.{u1} X _inst_1 s) a)
but is expected to have type
  forall {X : Type.{u2}} {Y : Type.{u1}} [_inst_1 : TopologicalSpace.{u2} X] [_inst_2 : TopologicalSpace.{u1} Y] [_inst_3 : Preorder.{u1} Y] [_inst_4 : OrderClosedTopology.{u1} Y _inst_2 _inst_3] {f : X -> Y} {s : Set.{u2} X} {a : X}, (IsLocalMinOn.{u2, u1} X Y _inst_1 _inst_3 f s a) -> (ContinuousOn.{u2, u1} X Y _inst_1 _inst_2 f (closure.{u2} X _inst_1 s)) -> (IsLocalMinOn.{u2, u1} X Y _inst_1 _inst_3 f (closure.{u2} X _inst_1 s) a)
Case conversion may be inaccurate. Consider using '#align is_local_min_on.closure IsLocalMinOn.closureₓ'. -/
protected theorem IsLocalMinOn.closure (h : IsLocalMinOn f s a) (hc : ContinuousOn f (closure s)) :
    IsLocalMinOn f (closure s) a :=
  IsLocalMaxOn.closure h.dual hc
#align is_local_min_on.closure IsLocalMinOn.closure

/- warning: is_local_extr_on.closure -> IsLocalExtrOn.closure is a dubious translation:
lean 3 declaration is
  forall {X : Type.{u1}} {Y : Type.{u2}} [_inst_1 : TopologicalSpace.{u1} X] [_inst_2 : TopologicalSpace.{u2} Y] [_inst_3 : Preorder.{u2} Y] [_inst_4 : OrderClosedTopology.{u2} Y _inst_2 _inst_3] {f : X -> Y} {s : Set.{u1} X} {a : X}, (IsLocalExtrOn.{u1, u2} X Y _inst_1 _inst_3 f s a) -> (ContinuousOn.{u1, u2} X Y _inst_1 _inst_2 f (closure.{u1} X _inst_1 s)) -> (IsLocalExtrOn.{u1, u2} X Y _inst_1 _inst_3 f (closure.{u1} X _inst_1 s) a)
but is expected to have type
  forall {X : Type.{u2}} {Y : Type.{u1}} [_inst_1 : TopologicalSpace.{u2} X] [_inst_2 : TopologicalSpace.{u1} Y] [_inst_3 : Preorder.{u1} Y] [_inst_4 : OrderClosedTopology.{u1} Y _inst_2 _inst_3] {f : X -> Y} {s : Set.{u2} X} {a : X}, (IsLocalExtrOn.{u2, u1} X Y _inst_1 _inst_3 f s a) -> (ContinuousOn.{u2, u1} X Y _inst_1 _inst_2 f (closure.{u2} X _inst_1 s)) -> (IsLocalExtrOn.{u2, u1} X Y _inst_1 _inst_3 f (closure.{u2} X _inst_1 s) a)
Case conversion may be inaccurate. Consider using '#align is_local_extr_on.closure IsLocalExtrOn.closureₓ'. -/
protected theorem IsLocalExtrOn.closure (h : IsLocalExtrOn f s a)
    (hc : ContinuousOn f (closure s)) : IsLocalExtrOn f (closure s) a :=
  h.elim (fun h => Or.inl <| h.closure hc) fun h => Or.inr <| h.closure hc
#align is_local_extr_on.closure IsLocalExtrOn.closure


lemma zero_add (n : mynat) : 0 + n = n :=
begin
induction n with k Pk,
rw add_zero, refl,
rw add_succ, rw Pk, refl,
end


import lemmas basic

namespace myint

example (a : nat) : a • (0 : myint) = (0 : myint) := smul_zero a

def five_z : add_subgroup int := add_subgroup.closure ({5} : set ℤ)

def five_mint : add_subgroup myint := add_subgroup.closure ({5} : set myint)

example (a b : int) : (-a - b) = -(a+b) := (neg_add' a b).symm

-- `f` is the `add_monoid` homomorphism from `mint` to `int` induced by the equivalence
-- `myint_to_int_add_equiv`.
abbreviation f := add_equiv.to_add_monoid_hom myint_to_int_add_equiv -- abbreviate the homom to `f`.

/-
The pullback of `five_z` along `f`  is `five_mint`.
-/
example : five_z.comap f = five_mint :=
begin
  have five_eq : (5 : myint) = [[5,0]] := rfl,
  convert add_subgroup.comap_map_eq f five_mint, swap,
  { rw [(add_monoid_hom.ker_eq_bot_iff f).mpr (by apply add_equiv.injective), sup_bot_eq], },
  simp only [←add_subgroup.gmultiples_eq_closure,five_z, five_mint],
  ext, split,
  { --  Want to show that if `x : ℤ` is in `five_z`, then `x` is in the image of `five_mint` under `f`.
    rintro ⟨a | b, rfl⟩, -- There are two cases to consider. Either `x` 'is' `a • 5` or it is `-(1+b) • 5` for `a b : ℕ`.
    { use a • [[5,0]], -- We'll show `a • 5` is `f (a • [[5, 0]])`
      split,
      { use a, rw ←five_eq, conv_lhs { change (a) •ℤ (5 : myint)}, norm_num, },
      { rw nsmul_myint_pair, rw (show [[a • 5, a • 0]] = [[a * 5, 0]], from rfl),
        dsimp [myint_to_int_add_equiv, myint_to_int_equiv],
        rw myint_to_int_of_pair, conv_rhs { change (a) •ℤ (5 : int)}, simp, } },
    { use (1 + b) • [[0,5]], -- We'll show `-(1+b) • 5` is `f ((1+b) • [[0, 5]])`
      split,
      { use (int.neg_succ_of_nat b), -- We first show `(1+b) • [[0,5]]` is in `five_myint`.
        conv_lhs { change (int.neg_succ_of_nat b) •ℤ (5 : myint)},
        rw [gsmul_neg_succ_of_nat, five_eq, nat.succ_eq_add_one, add_comm],
        simp only [nsmul_myint_pair, myint.neg_pair'], },
      { conv_rhs { change ((int.neg_succ_of_nat b) •ℤ (5 : int)) },  -- Now we show equality.
        rw [gsmul_neg_succ_of_nat, add_comm, nsmul_myint_pair],
        dsimp [myint_to_int_add_equiv, myint_to_int_equiv, myint_to_int_of_pair],
        simp only [zero_sub, int.coe_nat_zero, mul_eq_mul_left_iff, nsmul_eq_mul, bit1_eq_bit1, int.coe_nat_succ,
          neg_inj, zero_add, int.nat_cast_eq_coe_nat, mul_zero, int.coe_nat_bit1, int.coe_nat_mul], -- found by `squeeze_simp`.
        left, refl, }, }, },
  { --  Want to show that if `x : ℤ` is in the image of `five_mint` under `f`, then `x ∈ five_z`.
    -- `x : ℤ` is written as `f (w • 5)` for some `w : ℤ`. We must show `f (w • 5) ∈ five_z`.
    rintro ⟨_, ⟨a | b, rfl⟩, rfl⟩, -- Split into cases where `w` 'equals' `a` or `-(1+b)` for `a b : ℕ`.
    { use a, conv_lhs { change (a •ℤ (5 :int)) },
      rw five_eq,
      simp only [add_equiv.coe_to_add_monoid_hom, int.coe_nat_eq_zero, mul_eq_mul_left_iff, nsmul_eq_mul, int.of_nat_eq_coe,
          gsmul_coe_nat, int.nat_cast_eq_coe_nat, add_monoid_hom.map_nsmul], -- found using `squeeze_simp`.
      left, dsimp [myint_to_int_add_equiv, myint_to_int_equiv, myint_to_int_of_pair], refl, },
    { use (-(1+b)), conv_lhs { change (-(1+b) •ℤ (5 :int)) },
      simp only [gsmul_int_int, gsmul_neg_succ_of_nat, add_equiv.coe_to_add_monoid_hom, add_equiv.map_neg, neg_add_rev, int.add_neg_one], -- found using `squeeze_simp`.
      rw [five_eq, nat.succ_eq_add_one, nsmul_myint_pair],
      dsimp [myint_to_int_add_equiv, myint_to_int_equiv, myint_to_int_of_pair],
      rw [←neg_add', mul_zero, sub_zero], refl, }, },
end

end myint