/-
Copyright (c) 2020 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Floris van Doorn
-/
import measure_theory.measure.content
import measure_theory.group.prod
import group_theory.divisible
import topology.algebra.group.compact

/-!
# Haar measure

In this file we prove the existence and uniqueness (up to scalar multiples) of Haar measure
for a locally compact Hausdorff topological group.

For the construction, we follow the write-up by Jonathan Gleason,
*Existence and Uniqueness of Haar Measure*.
This is essentially the same argument as in
https://en.wikipedia.org/wiki/Haar_measure#A_construction_using_compact_subsets.

We construct the Haar measure first on compact sets. For this we define `(K : U)` as the (smallest)
number of left-translates of `U` that are needed to cover `K` (`index` in the formalization).
Then we define a function `h` on compact sets as `lim_U (K : U) / (K₀ : U)`,
where `U` becomes a smaller and smaller open neighborhood of `1`, and `K₀` is a fixed compact set
with nonempty interior. This function is `chaar` in the formalization, and we define the limit
formally using Tychonoff's theorem.

This function `h` forms a content, which we can extend to an outer measure and then a measure
(`haar_measure`).
We normalize the Haar measure so that the measure of `K₀` is `1`.
We show that for second countable spaces any left invariant Borel measure is a scalar multiple of
the Haar measure.

Note that `μ` need not coincide with `h` on compact sets, according to
[halmos1950measure, ch. X, §53 p.233]. However, we know that `h(K)` lies between `μ(Kᵒ)` and `μ(K)`,
where `ᵒ` denotes the interior.

## Main Declarations

* `haar_measure`: the Haar measure on a locally compact Hausdorff group. This is a left invariant
  regular measure. It takes as argument a compact set of the group (with non-empty interior),
  and is normalized so that the measure of the given set is 1.
* `haar_measure_self`: the Haar measure is normalized.
* `is_left_invariant_haar_measure`: the Haar measure is left invariant.
* `regular_haar_measure`: the Haar measure is a regular measure.
* `is_haar_measure_haar_measure`: the Haar measure satisfies the `is_haar_measure` typeclass, i.e.,
  it is invariant and gives finite mass to compact sets and positive mass to nonempty open sets.
* `haar` : some choice of a Haar measure, on a locally compact Hausdorff group, constructed as
  `haar_measure K` where `K` is some arbitrary choice of a compact set with nonempty interior.
* `haar_measure_unique`: Every σ-finite left invariant measure on a locally compact Hausdorff group
  is a scalar multiple of the Haar measure.

## References
* Paul Halmos (1950), Measure Theory, §53
* Jonathan Gleason, Existence and Uniqueness of Haar Measure
  - Note: step 9, page 8 contains a mistake: the last defined `μ` does not extend the `μ` on compact
    sets, see Halmos (1950) p. 233, bottom of the page. This makes some other steps (like step 11)
    invalid.
* https://en.wikipedia.org/wiki/Haar_measure
-/
noncomputable theory

open set has_inv function topological_space measurable_space
open_locale nnreal classical ennreal pointwise topology

namespace measure_theory
namespace measure

section group
variables {G : Type*} [group G]

/-! We put the internal functions in the construction of the Haar measure in a namespace,
  so that the chosen names don't clash with other declarations.
  We first define a couple of the functions before proving the properties (that require that `G`
  is a topological group). -/
namespace haar

/-- The index or Haar covering number or ratio of `K` w.r.t. `V`, denoted `(K : V)`:
  it is the smallest number of (left) translates of `V` that is necessary to cover `K`.
  It is defined to be 0 if no finite number of translates cover `K`. -/
@[to_additive add_index "additive version of `measure_theory.measure.haar.index`"]
def index (K V : set G) : ℕ :=
Inf $ finset.card '' {t : finset G | K ⊆ ⋃ g ∈ t, (λ h, g * h) ⁻¹' V }

@[to_additive add_index_empty]
lemma index_empty {V : set G} : index ∅ V = 0 :=
begin
  simp only [index, nat.Inf_eq_zero], left, use ∅,
  simp only [finset.card_empty, empty_subset, mem_set_of_eq, eq_self_iff_true, and_self],
end

variables [topological_space G]

/-- `prehaar K₀ U K` is a weighted version of the index, defined as `(K : U)/(K₀ : U)`.
  In the applications `K₀` is compact with non-empty interior, `U` is open containing `1`,
  and `K` is any compact set.
  The argument `K` is a (bundled) compact set, so that we can consider `prehaar K₀ U` as an
  element of `haar_product` (below). -/
@[to_additive "additive version of `measure_theory.measure.haar.prehaar`"]
def prehaar (K₀ U : set G) (K : compacts G) : ℝ := (index (K : set G) U : ℝ) / index K₀ U

@[to_additive]
lemma prehaar_empty (K₀ : positive_compacts G) {U : set G} : prehaar (K₀ : set G) U ⊥ = 0 :=
by rw [prehaar, compacts.coe_bot, index_empty, nat.cast_zero, zero_div]

@[to_additive]
lemma prehaar_nonneg (K₀ : positive_compacts G) {U : set G} (K : compacts G) :
  0 ≤ prehaar (K₀ : set G) U K :=
by apply div_nonneg; norm_cast; apply zero_le

/-- `haar_product K₀` is the product of intervals `[0, (K : K₀)]`, for all compact sets `K`.
  For all `U`, we can show that `prehaar K₀ U ∈ haar_product K₀`. -/
@[to_additive "additive version of `measure_theory.measure.haar.haar_product`"]
def haar_product (K₀ : set G) : set (compacts G → ℝ) :=
pi univ (λ K, Icc 0 $ index (K : set G) K₀)

@[simp, to_additive]
lemma mem_prehaar_empty {K₀ : set G} {f : compacts G → ℝ} :
  f ∈ haar_product K₀ ↔ ∀ K : compacts G, f K ∈ Icc (0 : ℝ) (index (K : set G) K₀) :=
by simp only [haar_product, pi, forall_prop_of_true, mem_univ, mem_set_of_eq]

/-- The closure of the collection of elements of the form `prehaar K₀ U`,
  for `U` open neighbourhoods of `1`, contained in `V`. The closure is taken in the space
  `compacts G → ℝ`, with the topology of pointwise convergence.
  We show that the intersection of all these sets is nonempty, and the Haar measure
  on compact sets is defined to be an element in the closure of this intersection. -/
@[to_additive "additive version of `measure_theory.measure.haar.cl_prehaar`"]
def cl_prehaar (K₀ : set G) (V : open_nhds_of (1 : G)) : set (compacts G → ℝ) :=
closure $ prehaar K₀ '' { U : set G | U ⊆ V.1 ∧ is_open U ∧ (1 : G) ∈ U }

variables [topological_group G]

/-!
### Lemmas about `index`
-/

/-- If `K` is compact and `V` has nonempty interior, then the index `(K : V)` is well-defined,
  there is a finite set `t` satisfying the desired properties. -/
@[to_additive add_index_defined "If `K` is compact and `V` has nonempty interior, then the index
`(K : V)` is well-defined, there is a finite set `t` satisfying the desired properties."]
lemma index_defined {K V : set G} (hK : is_compact K) (hV : (interior V).nonempty) :
  ∃ n : ℕ, n ∈ finset.card '' {t : finset G | K ⊆ ⋃ g ∈ t, (λ h, g * h) ⁻¹' V } :=
by { rcases compact_covered_by_mul_left_translates hK hV with ⟨t, ht⟩, exact ⟨t.card, t, ht, rfl⟩ }

@[to_additive add_index_elim]
lemma index_elim {K V : set G} (hK : is_compact K) (hV : (interior V).nonempty) :
  ∃ (t : finset G), K ⊆ (⋃ g ∈ t, (λ h, g * h) ⁻¹' V) ∧ finset.card t = index K V :=
by { have := nat.Inf_mem (index_defined hK hV), rwa [mem_image] at this }

@[to_additive le_add_index_mul]
lemma le_index_mul (K₀ : positive_compacts G) (K : compacts G) {V : set G}
  (hV : (interior V).nonempty) :
  index (K : set G) V ≤ index (K : set G) K₀ * index (K₀ : set G) V :=
begin
  obtain ⟨s, h1s, h2s⟩ := index_elim K.is_compact K₀.interior_nonempty,
  obtain ⟨t, h1t, h2t⟩ := index_elim K₀.is_compact hV,
  rw [← h2s, ← h2t, mul_comm],
  refine le_trans _ finset.card_mul_le,
  apply nat.Inf_le, refine ⟨_, _, rfl⟩, rw [mem_set_of_eq], refine subset.trans h1s _,
  apply Union₂_subset, intros g₁ hg₁, rw preimage_subset_iff, intros g₂ hg₂,
  have := h1t hg₂,
  rcases this with ⟨_, ⟨g₃, rfl⟩, A, ⟨hg₃, rfl⟩, h2V⟩, rw [mem_preimage, ← mul_assoc] at h2V,
  exact mem_bUnion (finset.mul_mem_mul hg₃ hg₁) h2V
end

@[to_additive add_index_pos]
lemma index_pos (K : positive_compacts G) {V : set G} (hV : (interior V).nonempty) :
  0 < index (K : set G) V :=
begin
  unfold index, rw [nat.Inf_def, nat.find_pos, mem_image],
  { rintro ⟨t, h1t, h2t⟩, rw [finset.card_eq_zero] at h2t, subst h2t,
    obtain ⟨g, hg⟩ := K.interior_nonempty,
    show g ∈ (∅ : set G), convert h1t (interior_subset hg), symmetry, apply bUnion_empty },
  { exact index_defined K.is_compact hV }
end

@[to_additive add_index_mono]
lemma index_mono {K K' V : set G} (hK' : is_compact K') (h : K ⊆ K')
  (hV : (interior V).nonempty) : index K V ≤ index K' V :=
begin
  rcases index_elim hK' hV with ⟨s, h1s, h2s⟩,
  apply nat.Inf_le, rw [mem_image], refine ⟨s, subset.trans h h1s, h2s⟩
end

@[to_additive add_index_union_le]
lemma index_union_le (K₁ K₂ : compacts G) {V : set G} (hV : (interior V).nonempty) :
  index (K₁.1 ∪ K₂.1) V ≤ index K₁.1 V + index K₂.1 V :=
begin
  rcases index_elim K₁.2 hV with ⟨s, h1s, h2s⟩,
  rcases index_elim K₂.2 hV with ⟨t, h1t, h2t⟩,
  rw [← h2s, ← h2t],
  refine le_trans _ (finset.card_union_le _ _),
  apply nat.Inf_le, refine ⟨_, _, rfl⟩, rw [mem_set_of_eq],
  apply union_subset; refine subset.trans (by assumption) _; apply bUnion_subset_bUnion_left;
    intros g hg; simp only [mem_def] at hg;
    simp only [mem_def, multiset.mem_union, finset.union_val, hg, or_true, true_or]
end

@[to_additive add_index_union_eq]
lemma index_union_eq (K₁ K₂ : compacts G) {V : set G} (hV : (interior V).nonempty)
  (h : disjoint (K₁.1 * V⁻¹) (K₂.1 * V⁻¹)) :
  index (K₁.1 ∪ K₂.1) V = index K₁.1 V + index K₂.1 V :=
begin
  apply le_antisymm (index_union_le K₁ K₂ hV),
  rcases index_elim (K₁.2.union K₂.2) hV with ⟨s, h1s, h2s⟩, rw [← h2s],
  have : ∀ (K : set G) , K ⊆ (⋃ g ∈ s, (λ h, g * h) ⁻¹' V) →
    index K V ≤ (s.filter (λ g, ((λ (h : G), g * h) ⁻¹' V ∩ K).nonempty)).card,
  { intros K hK, apply nat.Inf_le, refine ⟨_, _, rfl⟩, rw [mem_set_of_eq],
    intros g hg, rcases hK hg with ⟨_, ⟨g₀, rfl⟩, _, ⟨h1g₀, rfl⟩, h2g₀⟩,
    simp only [mem_preimage] at h2g₀,
    simp only [mem_Union], use g₀, split,
    { simp only [finset.mem_filter, h1g₀, true_and], use g,
      simp only [hg, h2g₀, mem_inter_iff, mem_preimage, and_self] },
    exact h2g₀ },
  refine le_trans (add_le_add (this K₁.1 $ subset.trans (subset_union_left _ _) h1s)
    (this K₂.1 $ subset.trans (subset_union_right _ _) h1s)) _,
  rw [← finset.card_union_eq, finset.filter_union_right],
  exact s.card_filter_le _,
  apply finset.disjoint_filter.mpr,
  rintro g₁ h1g₁ ⟨g₂, h1g₂, h2g₂⟩ ⟨g₃, h1g₃, h2g₃⟩,
  simp only [mem_preimage] at h1g₃ h1g₂,
  refine h.le_bot (_ : g₁⁻¹ ∈ _),
  split; simp only [set.mem_inv, set.mem_mul, exists_exists_and_eq_and, exists_and_distrib_left],
  { refine ⟨_, h2g₂, (g₁ * g₂)⁻¹, _, _⟩, simp only [inv_inv, h1g₂],
    simp only [mul_inv_rev, mul_inv_cancel_left] },
  { refine ⟨_, h2g₃, (g₁ * g₃)⁻¹, _, _⟩, simp only [inv_inv, h1g₃],
    simp only [mul_inv_rev, mul_inv_cancel_left] }

end

@[to_additive add_left_add_index_le]
lemma mul_left_index_le {K : set G} (hK : is_compact K) {V : set G} (hV : (interior V).nonempty)
  (g : G) : index ((λ h, g * h) '' K) V ≤ index K V :=
begin
  rcases index_elim hK hV with ⟨s, h1s, h2s⟩, rw [← h2s],
  apply nat.Inf_le, rw [mem_image],
  refine ⟨s.map (equiv.mul_right g⁻¹).to_embedding, _, finset.card_map _⟩,
  { simp only [mem_set_of_eq], refine subset.trans (image_subset _ h1s) _,
    rintro _ ⟨g₁, ⟨_, ⟨g₂, rfl⟩, ⟨_, ⟨hg₂, rfl⟩, hg₁⟩⟩, rfl⟩,
    simp only [mem_preimage] at hg₁, simp only [exists_prop, mem_Union, finset.mem_map,
      equiv.coe_mul_right, exists_exists_and_eq_and, mem_preimage, equiv.to_embedding_apply],
    refine ⟨_, hg₂, _⟩, simp only [mul_assoc, hg₁, inv_mul_cancel_left] }
end

@[to_additive is_left_invariant_add_index]
lemma is_left_invariant_index {K : set G} (hK : is_compact K) (g : G) {V : set G}
  (hV : (interior V).nonempty) : index ((λ h, g * h) '' K) V = index K V :=
begin
  refine le_antisymm (mul_left_index_le hK hV g) _,
  convert mul_left_index_le (hK.image $ continuous_mul_left g) hV g⁻¹,
  rw [image_image], symmetry, convert image_id' _, ext h, apply inv_mul_cancel_left
end

/-!
### Lemmas about `prehaar`
-/

@[to_additive add_prehaar_le_add_index]
lemma prehaar_le_index (K₀ : positive_compacts G) {U : set G} (K : compacts G)
  (hU : (interior U).nonempty) : prehaar (K₀ : set G) U K ≤ index (K : set G) K₀ :=
begin
  unfold prehaar, rw [div_le_iff]; norm_cast,
  { apply le_index_mul K₀ K hU },
  { exact index_pos K₀ hU }
end

@[to_additive]
lemma prehaar_pos (K₀ : positive_compacts G) {U : set G} (hU : (interior U).nonempty)
  {K : set G} (h1K : is_compact K) (h2K : (interior K).nonempty) :
  0 < prehaar (K₀ : set G) U ⟨K, h1K⟩ :=
by { apply div_pos; norm_cast, apply index_pos ⟨⟨K, h1K⟩, h2K⟩ hU, exact index_pos K₀ hU }

@[to_additive]
lemma prehaar_mono {K₀ : positive_compacts G} {U : set G} (hU : (interior U).nonempty)
  {K₁ K₂ : compacts G} (h : (K₁ : set G) ⊆ K₂.1) :
  prehaar (K₀ : set G) U K₁ ≤ prehaar (K₀ : set G) U K₂ :=
begin
  simp only [prehaar], rw [div_le_div_right], exact_mod_cast index_mono K₂.2 h hU,
  exact_mod_cast index_pos K₀ hU
end

@[to_additive]
lemma prehaar_self {K₀ : positive_compacts G} {U : set G} (hU : (interior U).nonempty) :
  prehaar (K₀ : set G) U K₀.to_compacts = 1 :=
div_self $ ne_of_gt $ by exact_mod_cast index_pos K₀ hU

@[to_additive]
lemma prehaar_sup_le {K₀ : positive_compacts G} {U : set G} (K₁ K₂ : compacts G)
  (hU : (interior U).nonempty) :
  prehaar (K₀ : set G) U (K₁ ⊔ K₂) ≤ prehaar (K₀ : set G) U K₁ + prehaar (K₀ : set G) U K₂ :=
begin
  simp only [prehaar], rw [div_add_div_same, div_le_div_right],
  exact_mod_cast index_union_le K₁ K₂ hU, exact_mod_cast index_pos K₀ hU
end

@[to_additive]
lemma prehaar_sup_eq {K₀ : positive_compacts G} {U : set G} {K₁ K₂ : compacts G}
  (hU : (interior U).nonempty) (h : disjoint (K₁.1 * U⁻¹) (K₂.1 * U⁻¹)) :
  prehaar (K₀ : set G) U (K₁ ⊔ K₂) = prehaar (K₀ : set G) U K₁ + prehaar (K₀ : set G) U K₂ :=
by { simp only [prehaar], rw [div_add_div_same], congr', exact_mod_cast index_union_eq K₁ K₂ hU h }

@[to_additive]
lemma is_left_invariant_prehaar {K₀ : positive_compacts G} {U : set G} (hU : (interior U).nonempty)
  (g : G) (K : compacts G) :
  prehaar (K₀ : set G) U (K.map _ $ continuous_mul_left g) = prehaar (K₀ : set G) U K :=
by simp only [prehaar, compacts.coe_map, is_left_invariant_index K.is_compact _ hU]

/-!
### Lemmas about `haar_product`
-/

@[to_additive]
lemma prehaar_mem_haar_product (K₀ : positive_compacts G) {U : set G} (hU : (interior U).nonempty) :
  prehaar (K₀ : set G) U ∈ haar_product (K₀ : set G) :=
by { rintro ⟨K, hK⟩ h2K, rw [mem_Icc], exact ⟨prehaar_nonneg K₀ _, prehaar_le_index K₀ _ hU⟩ }

@[to_additive]

/-!
### Lemmas about `chaar`
-/

/-- This is the "limit" of `prehaar K₀ U K` as `U` becomes a smaller and smaller open
  neighborhood of `(1 : G)`. More precisely, it is defined to be an arbitrary element
  in the intersection of all the sets `cl_prehaar K₀ V` in `haar_product K₀`.
  This is roughly equal to the Haar measure on compact sets,
  but it can differ slightly. We do know that
  `haar_measure K₀ (interior K) ≤ chaar K₀ K ≤ haar_measure K₀ K`. -/
@[to_additive add_chaar "additive version of `measure_theory.measure.haar.chaar`"]
def chaar (K₀ : positive_compacts G) (K : compacts G) : ℝ :=
classical.some (nonempty_Inter_cl_prehaar K₀) K

@[to_additive add_chaar_mem_add_haar_product]
lemma chaar_mem_haar_product (K₀ : positive_compacts G) : chaar K₀ ∈ haar_product (K₀ : set G) :=
(classical.some_spec (nonempty_Inter_cl_prehaar K₀)).1

@[to_additive add_chaar_mem_cl_add_prehaar]
lemma chaar_mem_cl_prehaar (K₀ : positive_compacts G) (V : open_nhds_of (1 : G)) :
  chaar K₀ ∈ cl_prehaar (K₀ : set G) V :=
by { have := (classical.some_spec (nonempty_Inter_cl_prehaar K₀)).2, rw [mem_Inter] at this,
     exact this V }

@[to_additive add_chaar_nonneg]
lemma chaar_nonneg (K₀ : positive_compacts G) (K : compacts G) : 0 ≤ chaar K₀ K :=
by { have := chaar_mem_haar_product K₀ K (mem_univ _), rw mem_Icc at this, exact this.1 }

@[to_additive add_chaar_empty]
lemma chaar_empty (K₀ : positive_compacts G) : chaar K₀ ⊥ = 0 :=
begin
  let eval : (compacts G → ℝ) → ℝ := λ f, f ⊥,
  have : continuous eval := continuous_apply ⊥,
  show chaar K₀ ∈ eval ⁻¹' {(0 : ℝ)},
  apply mem_of_subset_of_mem _ (chaar_mem_cl_prehaar K₀ ⊤),
  unfold cl_prehaar, rw is_closed.closure_subset_iff,
  { rintro _ ⟨U, ⟨h1U, h2U, h3U⟩, rfl⟩, apply prehaar_empty },
  { apply continuous_iff_is_closed.mp this, exact is_closed_singleton },
end

@[to_additive add_chaar_self]
lemma chaar_self (K₀ : positive_compacts G) : chaar K₀ K₀.to_compacts = 1 :=
begin
  let eval : (compacts G → ℝ) → ℝ := λ f, f K₀.to_compacts,
  have : continuous eval := continuous_apply _,
  show chaar K₀ ∈ eval ⁻¹' {(1 : ℝ)},
  apply mem_of_subset_of_mem _ (chaar_mem_cl_prehaar K₀ ⊤),
  unfold cl_prehaar, rw is_closed.closure_subset_iff,
  { rintro _ ⟨U, ⟨h1U, h2U, h3U⟩, rfl⟩, apply prehaar_self,
    rw h2U.interior_eq, exact ⟨1, h3U⟩ },
  { apply continuous_iff_is_closed.mp this, exact is_closed_singleton }
end

@[to_additive add_chaar_mono]
lemma chaar_mono {K₀ : positive_compacts G} {K₁ K₂ : compacts G} (h : (K₁ : set G) ⊆ K₂) :
  chaar K₀ K₁ ≤ chaar K₀ K₂ :=
begin
  let eval : (compacts G → ℝ) → ℝ := λ f, f K₂ - f K₁,
  have : continuous eval := (continuous_apply K₂).sub (continuous_apply K₁),
  rw [← sub_nonneg], show chaar K₀ ∈ eval ⁻¹' (Ici (0 : ℝ)),
  apply mem_of_subset_of_mem _ (chaar_mem_cl_prehaar K₀ ⊤),
  unfold cl_prehaar, rw is_closed.closure_subset_iff,
  { rintro _ ⟨U, ⟨h1U, h2U, h3U⟩, rfl⟩, simp only [mem_preimage, mem_Ici, eval, sub_nonneg],
    apply prehaar_mono _ h, rw h2U.interior_eq, exact ⟨1, h3U⟩ },
  { apply continuous_iff_is_closed.mp this, exact is_closed_Ici },
end

@[to_additive add_chaar_sup_le]
lemma chaar_sup_le {K₀ : positive_compacts G} (K₁ K₂ : compacts G) :
  chaar K₀ (K₁ ⊔ K₂) ≤ chaar K₀ K₁ + chaar K₀ K₂ :=
begin
  let eval : (compacts G → ℝ) → ℝ := λ f, f K₁ + f K₂ - f (K₁ ⊔ K₂),
  have : continuous eval :=
    ((@continuous_add ℝ _ _ _).comp ((continuous_apply K₁).prod_mk (continuous_apply K₂))).sub
      (continuous_apply (K₁ ⊔ K₂)),
  rw [← sub_nonneg], show chaar K₀ ∈ eval ⁻¹' (Ici (0 : ℝ)),
  apply mem_of_subset_of_mem _ (chaar_mem_cl_prehaar K₀ ⊤),
  unfold cl_prehaar, rw is_closed.closure_subset_iff,
  { rintro _ ⟨U, ⟨h1U, h2U, h3U⟩, rfl⟩, simp only [mem_preimage, mem_Ici, eval, sub_nonneg],
    apply prehaar_sup_le, rw h2U.interior_eq, exact ⟨1, h3U⟩ },
  { apply continuous_iff_is_closed.mp this, exact is_closed_Ici },
end

@[to_additive add_chaar_sup_eq]
lemma chaar_sup_eq [t2_space G] {K₀ : positive_compacts G} {K₁ K₂ : compacts G}
  (h : disjoint K₁.1 K₂.1) : chaar K₀ (K₁ ⊔ K₂) = chaar K₀ K₁ + chaar K₀ K₂ :=
begin
  rcases is_compact_is_compact_separated K₁.2 K₂.2 h with ⟨U₁, U₂, h1U₁, h1U₂, h2U₁, h2U₂, hU⟩,
  rcases compact_open_separated_mul_right K₁.2 h1U₁ h2U₁ with ⟨L₁, h1L₁, h2L₁⟩,
  rcases mem_nhds_iff.mp h1L₁ with ⟨V₁, h1V₁, h2V₁, h3V₁⟩,
  replace h2L₁ := subset.trans (mul_subset_mul_left h1V₁) h2L₁,
  rcases compact_open_separated_mul_right K₂.2 h1U₂ h2U₂ with ⟨L₂, h1L₂, h2L₂⟩,
  rcases mem_nhds_iff.mp h1L₂ with ⟨V₂, h1V₂, h2V₂, h3V₂⟩,
  replace h2L₂ := subset.trans (mul_subset_mul_left h1V₂) h2L₂,
  let eval : (compacts G → ℝ) → ℝ := λ f, f K₁ + f K₂ - f (K₁ ⊔ K₂),
  have : continuous eval :=
    ((@continuous_add ℝ _ _ _).comp ((continuous_apply K₁).prod_mk (continuous_apply K₂))).sub
      (continuous_apply (K₁ ⊔ K₂)),
  rw [eq_comm, ← sub_eq_zero], show chaar K₀ ∈ eval ⁻¹' {(0 : ℝ)},
  let V := V₁ ∩ V₂,
  apply mem_of_subset_of_mem _ (chaar_mem_cl_prehaar K₀
    ⟨⟨V⁻¹, (h2V₁.inter h2V₂).preimage continuous_inv⟩,
    by simp only [mem_inv, inv_one, h3V₁, h3V₂, V, mem_inter_iff, true_and]⟩),
  unfold cl_prehaar, rw is_closed.closure_subset_iff,
  { rintro _ ⟨U, ⟨h1U, h2U, h3U⟩, rfl⟩,
    simp only [mem_preimage, eval, sub_eq_zero, mem_singleton_iff], rw [eq_comm],
    apply prehaar_sup_eq,
    { rw h2U.interior_eq, exact ⟨1, h3U⟩ },
    { refine disjoint_of_subset _ _ hU,
      { refine subset.trans (mul_subset_mul subset.rfl _) h2L₁,
        exact subset.trans (inv_subset.mpr h1U) (inter_subset_left _ _) },
      { refine subset.trans (mul_subset_mul subset.rfl _) h2L₂,
        exact subset.trans (inv_subset.mpr h1U) (inter_subset_right _ _) }}},
  { apply continuous_iff_is_closed.mp this, exact is_closed_singleton }
end

@[to_additive is_left_invariant_add_chaar]
lemma is_left_invariant_chaar {K₀ : positive_compacts G} (g : G) (K : compacts G) :
  chaar K₀ (K.map _ $ continuous_mul_left g) = chaar K₀ K :=
begin
  let eval : (compacts G → ℝ) → ℝ := λ f, f (K.map _ $ continuous_mul_left g) - f K,
  have : continuous eval := (continuous_apply (K.map _ _)).sub (continuous_apply K),
  rw [← sub_eq_zero], show chaar K₀ ∈ eval ⁻¹' {(0 : ℝ)},
  apply mem_of_subset_of_mem _ (chaar_mem_cl_prehaar K₀ ⊤),
  unfold cl_prehaar, rw is_closed.closure_subset_iff,
  { rintro _ ⟨U, ⟨h1U, h2U, h3U⟩, rfl⟩,
    simp only [mem_singleton_iff, mem_preimage, eval, sub_eq_zero],
    apply is_left_invariant_prehaar, rw h2U.interior_eq, exact ⟨1, h3U⟩ },
  { apply continuous_iff_is_closed.mp this, exact is_closed_singleton },
end

variable [t2_space G]

/-- The function `chaar` interpreted in `ℝ≥0`, as a content -/
@[to_additive "additive version of `measure_theory.measure.haar.haar_content`"]
def haar_content (K₀ : positive_compacts G) : content G :=
{ to_fun        := λ K, ⟨chaar K₀ K, chaar_nonneg _ _⟩,
  mono'         := λ K₁ K₂ h, by simp only [←nnreal.coe_le_coe, subtype.coe_mk, chaar_mono, h],
  sup_disjoint' := λ K₁ K₂ h, by { simp only [chaar_sup_eq h], refl },
  sup_le'       := λ K₁ K₂,
    by simp only [←nnreal.coe_le_coe, nnreal.coe_add, subtype.coe_mk, chaar_sup_le] }

/-! We only prove the properties for `haar_content` that we use at least twice below. -/

@[to_additive]
lemma haar_content_apply (K₀ : positive_compacts G) (K : compacts G) :
  haar_content K₀ K = show nnreal, from ⟨chaar K₀ K, chaar_nonneg _ _⟩ := rfl

/-- The variant of `chaar_self` for `haar_content` -/
@[to_additive "The variant of `add_chaar_self` for `add_haar_content`."]
lemma haar_content_self {K₀ : positive_compacts G} : haar_content K₀ K₀.to_compacts = 1 :=
by { simp_rw [← ennreal.coe_one, haar_content_apply, ennreal.coe_eq_coe, chaar_self], refl }

/-- The variant of `is_left_invariant_chaar` for `haar_content` -/
@[to_additive "The variant of `is_left_invariant_add_chaar` for `add_haar_content`"]
lemma is_left_invariant_haar_content {K₀ : positive_compacts G} (g : G) (K : compacts G) :
  haar_content K₀ (K.map _ $ continuous_mul_left g) = haar_content K₀ K :=
by simpa only [ennreal.coe_eq_coe, ←nnreal.coe_eq, haar_content_apply]
  using is_left_invariant_chaar g K

@[to_additive]
lemma haar_content_outer_measure_self_pos {K₀ : positive_compacts G} :
  0 < (haar_content K₀).outer_measure K₀ :=
begin
  refine zero_lt_one.trans_le _,
  rw [content.outer_measure_eq_infi],
  refine le_infi₂ (λ U hU, le_infi $ λ hK₀, le_trans _ $ le_supr₂ K₀.to_compacts hK₀),
  exact haar_content_self.ge,
end

end haar
open haar

/-!
### The Haar measure
-/

variables [topological_space G] [t2_space G] [topological_group G] [measurable_space G]
  [borel_space G]

/-- The Haar measure on the locally compact group `G`, scaled so that `haar_measure K₀ K₀ = 1`. -/
@[to_additive "The Haar measure on the locally compact additive group `G`,
scaled so that `add_haar_measure K₀ K₀ = 1`."]
def haar_measure (K₀ : positive_compacts G) : measure G :=
((haar_content K₀).outer_measure K₀)⁻¹ • (haar_content K₀).measure

@[to_additive]
lemma haar_measure_apply {K₀ : positive_compacts G} {s : set G} (hs : measurable_set s) :
  haar_measure K₀ s = (haar_content K₀).outer_measure s / (haar_content K₀).outer_measure K₀ :=
begin
  change (((haar_content K₀).outer_measure) K₀)⁻¹ * (haar_content K₀).measure s = _,
  simp only [hs, div_eq_mul_inv, mul_comm, content.measure_apply],
end

@[to_additive]
instance is_mul_left_invariant_haar_measure (K₀ : positive_compacts G) :
  is_mul_left_invariant (haar_measure K₀) :=
begin
  rw [← forall_measure_preimage_mul_iff],
  intros g A hA,
  rw [haar_measure_apply hA, haar_measure_apply (measurable_const_mul g hA)],
  congr' 1,
  apply content.is_mul_left_invariant_outer_measure,
  apply is_left_invariant_haar_content,
end

@[to_additive]
lemma haar_measure_self {K₀ : positive_compacts G} : haar_measure K₀ K₀ = 1 :=
begin
  haveI : locally_compact_space G := K₀.locally_compact_space_of_group,
  rw [haar_measure_apply K₀.is_compact.measurable_set, ennreal.div_self],
  { rw [← pos_iff_ne_zero], exact haar_content_outer_measure_self_pos },
  { exact (content.outer_measure_lt_top_of_is_compact _ K₀.is_compact).ne }
end

/-- The Haar measure is regular. -/
@[to_additive "The additive Haar measure is regular."]
instance regular_haar_measure {K₀ : positive_compacts G} :
  (haar_measure K₀).regular :=
begin
  haveI : locally_compact_space G := K₀.locally_compact_space_of_group,
  apply regular.smul,
  rw ennreal.inv_ne_top,
  exact haar_content_outer_measure_self_pos.ne',
end

/-- The Haar measure is sigma-finite in a second countable group. -/
@[to_additive "The additive Haar measure is sigma-finite in a second countable group."]
instance sigma_finite_haar_measure [second_countable_topology G] {K₀ : positive_compacts G} :
  sigma_finite (haar_measure K₀) :=
by { haveI : locally_compact_space G := K₀.locally_compact_space_of_group, apply_instance, }

/-- The Haar measure is a Haar measure, i.e., it is invariant and gives finite mass to compact
sets and positive mass to nonempty open sets. -/
@[to_additive "The additive Haar measure is an additive Haar measure, i.e., it is invariant and
gives  finite mass to compact sets and positive mass to nonempty open sets."]
instance is_haar_measure_haar_measure (K₀ : positive_compacts G) :
  is_haar_measure (haar_measure K₀) :=
begin
  apply is_haar_measure_of_is_compact_nonempty_interior (haar_measure K₀) K₀ K₀.is_compact
    K₀.interior_nonempty,
  { simp only [haar_measure_self], exact one_ne_zero },
  { simp only [haar_measure_self], exact ennreal.coe_ne_top },
end

/-- `haar` is some choice of a Haar measure, on a locally compact group. -/
@[reducible, to_additive "`add_haar` is some choice of a Haar measure, on a locally compact
additive group."]
def haar [locally_compact_space G] : measure G := haar_measure $ classical.arbitrary _

section second_countable

variables [second_countable_topology G]

/-- The Haar measure is unique up to scaling. More precisely: every σ-finite left invariant measure
  is a scalar multiple of the Haar measure.
  This is slightly weaker than assuming that `μ` is a Haar measure (in particular we don't require
  `μ ≠ 0`). -/
@[to_additive "The additive Haar measure is unique up to scaling. More precisely: every σ-finite
left invariant measure is a scalar multiple of the additive Haar measure. This is slightly weaker
than assuming that `μ` is an additive Haar measure (in particular we don't require `μ ≠ 0`)."]
theorem haar_measure_unique (μ : measure G) [sigma_finite μ] [is_mul_left_invariant μ]
  (K₀ : positive_compacts G) : μ = μ K₀ • haar_measure K₀ :=
(measure_eq_div_smul μ (haar_measure K₀) K₀.is_compact.measurable_set
  (measure_pos_of_nonempty_interior _ K₀.interior_nonempty).ne'
  K₀.is_compact.measure_lt_top.ne).trans (by rw [haar_measure_self, div_one])

example [locally_compact_space G] (μ : measure G) [is_haar_measure μ] (K₀ : positive_compacts G) :
  μ = μ K₀.1 • haar_measure K₀ :=
haar_measure_unique μ K₀

/-- To show that an invariant σ-finite measure is regular it is sufficient to show that it is finite
  on some compact set with non-empty interior. -/
@[to_additive "To show that an invariant σ-finite measure is regular it is sufficient to show that
it is finite on some compact set with non-empty interior."]
theorem regular_of_is_mul_left_invariant {μ : measure G} [sigma_finite μ] [is_mul_left_invariant μ]
  {K : set G} (hK : is_compact K) (h2K : (interior K).nonempty) (hμK : μ K ≠ ∞) :
  regular μ :=
by { rw [haar_measure_unique μ ⟨⟨K, hK⟩, h2K⟩], exact regular.smul hμK }

@[to_additive is_add_haar_measure_eq_smul_is_add_haar_measure]
theorem is_haar_measure_eq_smul_is_haar_measure
  [locally_compact_space G] (μ ν : measure G) [is_haar_measure μ] [is_haar_measure ν] :
  ∃ (c : ℝ≥0∞), c ≠ 0 ∧ c ≠ ∞ ∧ μ = c • ν :=
begin
  have K : positive_compacts G := classical.arbitrary _,
  have νpos : 0 < ν K := measure_pos_of_nonempty_interior _ K.interior_nonempty,
  have νne : ν K ≠ ∞ := K.is_compact.measure_lt_top.ne,
  refine ⟨μ K / ν K, _, _, _⟩,
  { simp only [νne, (μ.measure_pos_of_nonempty_interior K.interior_nonempty).ne', ne.def,
      ennreal.div_zero_iff, not_false_iff, or_self] },
  { simp only [div_eq_mul_inv, νpos.ne', (K.is_compact.measure_lt_top).ne, or_self,
      ennreal.inv_eq_top, with_top.mul_eq_top_iff, ne.def, not_false_iff, and_false, false_and] },
  { calc
    μ = μ K • haar_measure K : haar_measure_unique μ K
    ... = (μ K / ν K) • (ν K • haar_measure K) :
      by rw [smul_smul, div_eq_mul_inv, mul_assoc, ennreal.inv_mul_cancel νpos.ne' νne, mul_one]
    ... = (μ K / ν K) • ν : by rw ← haar_measure_unique ν K }
end

@[priority 90, to_additive] -- see Note [lower instance priority]
instance regular_of_is_haar_measure
  [locally_compact_space G] (μ : measure G) [is_haar_measure μ] :
  regular μ :=
begin
  have K : positive_compacts G := classical.arbitrary _,
  obtain ⟨c, c0, ctop, hμ⟩ : ∃ (c : ℝ≥0∞), (c ≠ 0) ∧ (c ≠ ∞) ∧ (μ = c • haar_measure K) :=
    is_haar_measure_eq_smul_is_haar_measure μ _,
  rw hμ,
  exact regular.smul ctop,
end

/-- **Steinhaus Theorem** In any locally compact group `G` with a haar measure `μ`, for any
  measurable set `E` of positive measure, the set `E / E` is a neighbourhood of `1`. -/
@[to_additive "**Steinhaus Theorem** In any locally compact group `G` with a haar measure `μ`,
  for any measurable set `E` of positive measure, the set `E - E` is a neighbourhood of `0`."]
theorem div_mem_nhds_one_of_haar_pos (μ : measure G) [is_haar_measure μ] [locally_compact_space G]
  (E : set G) (hE : measurable_set E) (hEpos : 0 < μ E) :
  E / E ∈ 𝓝 (1 : G) :=
begin
  /- For any regular measure `μ` and set `E` of positive measure, we can find a compact set `K` of
     positive measure inside `E`. Further, for any outer regular measure `μ` there exists an open
     set `U` containing `K` with measure arbitrarily close to `K` (here `μ U < 2 * μ K` suffices).
     Then, we can pick an open neighborhood of `1`, say `V` such that such that `V * K` is contained
     in `U`. Now note that for any `v` in `V`, the sets `K` and `{v} * K` can not be disjoint
     because they are both of measure `μ K` (since `μ` is left regular) and also contained in `U`,
     yet we have that `μ U < 2 * μ K`. This show that `K / K` contains the neighborhood `V` of `1`,
     and therefore that it is itself such a neighborhood. -/
  obtain ⟨L, hL, hLE, hLpos, hLtop⟩ : ∃ (L : set G), measurable_set L ∧ L ⊆ E ∧ 0 < μ L ∧ μ L < ∞,
    from exists_subset_measure_lt_top hE hEpos,
  obtain ⟨K, hKL, hK, hKpos⟩ : ∃ (K : set G) (H : K ⊆ L), is_compact K ∧ 0 < μ K,
    from measurable_set.exists_lt_is_compact_of_ne_top hL (ne_of_lt hLtop) hLpos,
  have hKtop : μ K ≠ ∞,
  { apply ne_top_of_le_ne_top (ne_of_lt hLtop),
    apply measure_mono hKL },
  obtain ⟨U, hUK, hU, hμUK⟩ : ∃ (U : set G) (H : U ⊇ K), is_open U ∧ μ U < μ K + μ K,
   from set.exists_is_open_lt_add K hKtop hKpos.ne',
  obtain ⟨V, hV1, hVKU⟩ : ∃ (V ∈ 𝓝 (1 : G)), V * K ⊆ U,
    from compact_open_separated_mul_left hK hU hUK,
  have hv : ∀ (v : G), v ∈ V → ¬ disjoint ({v}* K) K,
  { intros v hv hKv,
    have hKvsub : {v} * K ∪ K ⊆ U,
    { apply set.union_subset _ hUK,
      apply subset_trans _ hVKU,
      apply set.mul_subset_mul _ (set.subset.refl K),
      simp only [set.singleton_subset_iff, hv] },
    replace hKvsub := @measure_mono _ _ μ _ _ hKvsub,
    have hcontr := lt_of_le_of_lt hKvsub hμUK,
    rw measure_union hKv (is_compact.measurable_set hK) at hcontr,
    have hKtranslate : μ ({v} * K) = μ K,
      by simp only [singleton_mul, image_mul_left, measure_preimage_mul],
    rw [hKtranslate, lt_self_iff_false] at hcontr,
    assumption },
  suffices : V ⊆ E / E, from filter.mem_of_superset hV1 this,
  assume v hvV,
  obtain ⟨x, hxK, hxvK⟩ : ∃ (x : G), x ∈ {v} * K ∧ x ∈ K, from set.not_disjoint_iff.1 (hv v hvV),
  refine ⟨x, v⁻¹ * x, hLE (hKL hxvK), _, _⟩,
  { apply hKL.trans hLE,
    simpa only [singleton_mul, image_mul_left, mem_preimage] using hxK },
  { simp only [div_eq_iff_eq_mul, ← mul_assoc, mul_right_inv, one_mul] },
end

end second_countable

end group

section comm_group

variables {G : Type*} [comm_group G] [topological_space G] [topological_group G] [t2_space G]
  [measurable_space G] [borel_space G] [second_countable_topology G]
  (μ : measure G) [is_haar_measure μ]

/-- Any Haar measure is invariant under inversion in an abelian group. -/
@[priority 100, to_additive
  "Any additive Haar measure is invariant under negation in an abelian group."]
instance is_haar_measure.is_inv_invariant [locally_compact_space G] :
  is_inv_invariant μ :=
begin
  -- the image measure is a Haar measure. By uniqueness up to multiplication, it is of the form
  -- `c μ`. Applying again inversion, one gets the measure `c^2 μ`. But since inversion is an
  -- involution, this is also `μ`. Hence, `c^2 = 1`, which implies `c = 1`.
  constructor,
  haveI : is_haar_measure (measure.map has_inv.inv μ) :=
    (mul_equiv.inv G).is_haar_measure_map μ continuous_inv continuous_inv,
  obtain ⟨c, cpos, clt, hc⟩ : ∃ (c : ℝ≥0∞), (c ≠ 0) ∧ (c ≠ ∞) ∧ (measure.map has_inv.inv μ = c • μ)
    := is_haar_measure_eq_smul_is_haar_measure _ _,
  have : map has_inv.inv (map has_inv.inv μ) = c^2 • μ,
    by simp only [hc, smul_smul, pow_two, measure.map_smul],
  have μeq : μ = c^2 • μ,
  { rw [map_map continuous_inv.measurable continuous_inv.measurable] at this,
    { simpa only [inv_involutive, involutive.comp_self, map_id] },
    all_goals { apply_instance } },
  have K : positive_compacts G := classical.arbitrary _,
  have : c^2 * μ K = 1^2 * μ K,
    by { conv_rhs { rw μeq },
         simp, },
  have : c^2 = 1^2 :=
    (ennreal.mul_eq_mul_right (measure_pos_of_nonempty_interior _ K.interior_nonempty).ne'
      K.is_compact.measure_lt_top.ne).1 this,
  have : c = 1 := (ennreal.pow_strict_mono two_ne_zero).injective this,
  rw [measure.inv, hc, this, one_smul]
end

@[to_additive]
lemma measure_preserving_zpow [compact_space G] [rootable_by G ℤ] {n : ℤ} (hn : n ≠ 0) :
  measure_preserving (λ (g : G), g^n) μ μ :=
{ measurable := (continuous_zpow n).measurable,
  map_eq :=
  begin
    let f := @zpow_group_hom G _ n,
    have hf : continuous f := continuous_zpow n,
    haveI : (μ.map f).is_haar_measure :=
      is_haar_measure_map μ f hf (rootable_by.surjective_pow G ℤ hn) (by simp),
    obtain ⟨C, -, -, hC⟩ := is_haar_measure_eq_smul_is_haar_measure (μ.map f) μ,
    suffices : C = 1, { rwa [this, one_smul] at hC, },
    have h_univ : (μ.map f) univ = μ univ,
    { rw [map_apply_of_ae_measurable hf.measurable.ae_measurable measurable_set.univ,
        preimage_univ], },
    have hμ₀ : μ univ ≠ 0 := is_open_pos_measure.open_pos univ is_open_univ univ_nonempty,
    have hμ₁ : μ univ ≠ ∞ := compact_space.is_finite_measure.measure_univ_lt_top.ne,
    rwa [hC, smul_apply, algebra.id.smul_eq_mul, mul_comm, ← ennreal.eq_div_iff hμ₀ hμ₁,
      ennreal.div_self hμ₀ hμ₁] at h_univ,
  end, }

@[to_additive]
lemma measure_preserving.zpow [compact_space G] [rootable_by G ℤ] {n : ℤ} (hn : n ≠ 0)
  {X : Type*} [measurable_space X] {μ' : measure X} {f : X → G} (hf : measure_preserving f μ' μ) :
  measure_preserving (λ x, (f x)^n) μ' μ :=
(measure_preserving_zpow μ hn).comp hf

end comm_group

end measure
end measure_theory


/-
Copyright (c) 2022 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel
-/
import measure_theory.measure.lebesgue
import analysis.calculus.deriv
import measure_theory.covering.one_dim
import order.monotone.extension

/-!
# Differentiability of monotone functions

We show that a monotone function `f : ℝ → ℝ` is differentiable almost everywhere, in
`monotone.ae_differentiable_at`. (We also give a version for a function monotone on a set, in
`monotone_on.ae_differentiable_within_at`.)

If the function `f` is continuous, this follows directly from general differentiation of measure
theorems. Let `μ` be the Stieltjes measure associated to `f`. Then, almost everywhere,
`μ [x, y] / Leb [x, y]` (resp. `μ [y, x] / Leb [y, x]`) converges to the Radon-Nikodym derivative
of `μ` with respect to Lebesgue when `y` tends to `x` in `(x, +∞)` (resp. `(-∞, x)`), by
`vitali_family.ae_tendsto_rn_deriv`. As `μ [x, y] = f y - f x` and `Leb [x, y] = y - x`, this
gives differentiability right away.

When `f` is only monotone, the same argument works up to small adjustments, as the associated
Stieltjes measure satisfies `μ [x, y] = f (y^+) - f (x^-)` (the right and left limits of `f` at `y`
and `x` respectively). One argues that `f (x^-) = f x` almost everywhere (in fact away from a
countable set), and moreover `f ((y - (y-x)^2)^+) ≤ f y ≤ f (y^+)`. This is enough to deduce the
limit of `(f y - f x) / (y - x)` by a lower and upper approximation argument from the known
behavior of `μ [x, y]`.
-/

open set filter function metric measure_theory measure_theory.measure is_doubling_measure
open_locale topology

/-- If `(f y - f x) / (y - x)` converges to a limit as `y` tends to `x`, then the same goes if
`y` is shifted a little bit, i.e., `f (y + (y-x)^2) - f x) / (y - x)` converges to the same limit.
This lemma contains a slightly more general version of this statement (where one considers
convergence along some subfilter, typically `𝓝[<] x` or `𝓝[>] x`) tailored to the application
to almost everywhere differentiability of monotone functions. -/
lemma tendsto_apply_add_mul_sq_div_sub {f : ℝ → ℝ} {x a c d : ℝ} {l : filter ℝ} (hl : l ≤ 𝓝[≠] x)
  (hf : tendsto (λ y, (f y - d) / (y - x)) l (𝓝 a))
  (h' : tendsto (λ y, y + c * (y-x)^2) l l) :
  tendsto (λ y, (f (y + c * (y-x)^2) - d) / (y - x)) l (𝓝 a) :=
begin
  have L : tendsto (λ y, (y + c * (y - x)^2 - x) / (y - x)) l (𝓝 1),
  { have : tendsto (λ y, (1 + c * (y - x))) l (𝓝 (1 + c * (x - x))),
    { apply tendsto.mono_left _ (hl.trans nhds_within_le_nhds),
      exact ((tendsto_id.sub_const x).const_mul c).const_add 1 },
    simp only [_root_.sub_self, add_zero, mul_zero] at this,
    apply tendsto.congr' (eventually.filter_mono hl _) this,
    filter_upwards [self_mem_nhds_within] with y hy,
    field_simp [sub_ne_zero.2 hy],
    ring },
  have Z := (hf.comp h').mul L,
  rw mul_one at Z,
  apply tendsto.congr' _ Z,
  have : ∀ᶠ y in l, y + c * (y-x)^2 ≠ x := by apply tendsto.mono_right h' hl self_mem_nhds_within,
  filter_upwards [this] with y hy,
  field_simp [sub_ne_zero.2 hy],
end

/-- A Stieltjes function is almost everywhere differentiable, with derivative equal to the
Radon-Nikodym derivative of the associated Stieltjes measure with respect to Lebesgue. -/
lemma stieltjes_function.ae_has_deriv_at (f : stieltjes_function) :
  ∀ᵐ x, has_deriv_at f (rn_deriv f.measure volume x).to_real x :=
begin
  /- Denote by `μ` the Stieltjes measure associated to `f`.
  The general theorem `vitali_family.ae_tendsto_rn_deriv` ensures that `μ [x, y] / (y - x)` tends
  to the Radon-Nikodym derivative as `y` tends to `x` from the right. As `μ [x, y] = f y - f (x^-)`
  and `f (x^-) = f x` almost everywhere, this gives differentiability on the right.
  On the left, `μ [y, x] / (x - y)` again tends to the Radon-Nikodym derivative.
  As `μ [y, x] = f x - f (y^-)`, this is not exactly the right result, so one uses a sandwiching
  argument to deduce the convergence for `(f x - f y) / (x - y)`. -/
  filter_upwards [
    vitali_family.ae_tendsto_rn_deriv (vitali_family (volume : measure ℝ) 1) f.measure,
    rn_deriv_lt_top f.measure volume, f.countable_left_lim_ne.ae_not_mem volume] with x hx h'x h''x,
  -- Limit on the right, following from differentiation of measures
  have L1 : tendsto (λ y, (f y - f x) / (y - x))
    (𝓝[>] x) (𝓝 ((rn_deriv f.measure volume x).to_real)),
  { apply tendsto.congr' _
      ((ennreal.tendsto_to_real h'x.ne).comp (hx.comp (real.tendsto_Icc_vitali_family_right x))),
    filter_upwards [self_mem_nhds_within],
    rintros y (hxy : x < y),
    simp only [comp_app, stieltjes_function.measure_Icc, real.volume_Icc, not_not.1 h''x],
    rw [← ennreal.of_real_div_of_pos (sub_pos.2 hxy), ennreal.to_real_of_real],
    exact div_nonneg (sub_nonneg.2 (f.mono hxy.le)) (sub_pos.2 hxy).le },
  -- Limit on the left, following from differentiation of measures. Its form is not exactly the one
  -- we need, due to the appearance of a left limit.
  have L2 : tendsto (λ y, (left_lim f y - f x) / (y - x))
    (𝓝[<] x) (𝓝 ((rn_deriv f.measure volume x).to_real)),
  { apply tendsto.congr' _
      ((ennreal.tendsto_to_real h'x.ne).comp (hx.comp (real.tendsto_Icc_vitali_family_left x))),
    filter_upwards [self_mem_nhds_within],
    rintros y (hxy : y < x),
    simp only [comp_app, stieltjes_function.measure_Icc, real.volume_Icc],
    rw [← ennreal.of_real_div_of_pos (sub_pos.2 hxy), ennreal.to_real_of_real, ← neg_neg (y - x),
        div_neg, neg_div', neg_sub, neg_sub],
    exact div_nonneg (sub_nonneg.2 (f.mono.left_lim_le hxy.le)) (sub_pos.2 hxy).le },
  -- Shifting a little bit the limit on the left, by `(y - x)^2`.
  have L3 : tendsto (λ y, (left_lim f (y + 1 * (y - x)^2) - f x) / (y - x))
    (𝓝[<] x) (𝓝 ((rn_deriv f.measure volume x).to_real)),
  { apply tendsto_apply_add_mul_sq_div_sub (nhds_left'_le_nhds_ne x) L2,
    apply tendsto_nhds_within_of_tendsto_nhds_of_eventually_within,
    { apply tendsto.mono_left _ nhds_within_le_nhds,
      have : tendsto (λ (y : ℝ), y + 1 * (y - x) ^ 2) (𝓝 x) (𝓝 (x + 1 * (x - x)^2)) :=
        tendsto_id.add (((tendsto_id.sub_const x).pow 2).const_mul 1),
      simpa using this },
    { have : Ioo (x - 1) x ∈ 𝓝[<] x,
      { apply Ioo_mem_nhds_within_Iio, exact ⟨by linarith, le_refl _⟩ },
      filter_upwards [this],
      rintros y ⟨hy : x - 1 < y, h'y : y < x⟩,
      rw mem_Iio,
      nlinarith } },
  -- Deduce the correct limit on the left, by sandwiching.
  have L4 : tendsto (λ y, (f y - f x) / (y - x))
    (𝓝[<] x) (𝓝 ((rn_deriv f.measure volume x).to_real)),
  { apply tendsto_of_tendsto_of_tendsto_of_le_of_le' L3 L2,
    { filter_upwards [self_mem_nhds_within],
      rintros y (hy : y < x),
      refine div_le_div_of_nonpos_of_le (by linarith) ((sub_le_sub_iff_right _).2 _),
      apply f.mono.le_left_lim,
      have : 0 < (x - y)^2 := sq_pos_of_pos (sub_pos.2 hy),
      linarith },
    { filter_upwards [self_mem_nhds_within],
      rintros y (hy : y < x),
      refine div_le_div_of_nonpos_of_le (by linarith) _,
      simpa only [sub_le_sub_iff_right] using f.mono.left_lim_le (le_refl y) } },
  -- prove the result by splitting into left and right limits.
  rw [has_deriv_at_iff_tendsto_slope, slope_fun_def_field, ← nhds_left'_sup_nhds_right',
    tendsto_sup],
  exact ⟨L4, L1⟩
end

/-- A monotone function is almost everywhere differentiable, with derivative equal to the
Radon-Nikodym derivative of the associated Stieltjes measure with respect to Lebesgue. -/
lemma monotone.ae_has_deriv_at {f : ℝ → ℝ} (hf : monotone f) :
  ∀ᵐ x, has_deriv_at f (rn_deriv hf.stieltjes_function.measure volume x).to_real x :=
begin
  /- We already know that the Stieltjes function associated to `f` (i.e., `g : x ↦ f (x^+)`) is
  differentiable almost everywhere. We reduce to this statement by sandwiching values of `f` with
  values of `g`, by shifting with `(y - x)^2` (which has no influence on the relevant
  scale `y - x`.)-/
  filter_upwards [hf.stieltjes_function.ae_has_deriv_at,
    hf.countable_not_continuous_at.ae_not_mem volume] with x hx h'x,
  have A : hf.stieltjes_function x = f x,
  { rw [not_not, hf.continuous_at_iff_left_lim_eq_right_lim] at h'x,
    apply le_antisymm _ (hf.le_right_lim (le_refl _)),
    rw ← h'x,
    exact hf.left_lim_le (le_refl _) },
  rw [has_deriv_at_iff_tendsto_slope, (nhds_left'_sup_nhds_right' x).symm, tendsto_sup,
    slope_fun_def_field, A] at hx,
  -- prove differentiability on the right, by sandwiching with values of `g`
  have L1 : tendsto (λ y, (f y - f x) / (y - x)) (𝓝[>] x)
     (𝓝 (rn_deriv hf.stieltjes_function.measure volume x).to_real),
  { -- limit of a helper function, with a small shift compared to `g`
    have : tendsto (λ y, (hf.stieltjes_function (y + (-1) * (y-x)^2) - f x) / (y - x)) (𝓝[>] x)
      (𝓝 (rn_deriv hf.stieltjes_function.measure volume x).to_real),
    { apply tendsto_apply_add_mul_sq_div_sub (nhds_right'_le_nhds_ne x) hx.2,
      apply tendsto_nhds_within_of_tendsto_nhds_of_eventually_within,
      { apply tendsto.mono_left _ nhds_within_le_nhds,
        have : tendsto (λ (y : ℝ), y + (-1) * (y - x) ^ 2) (𝓝 x) (𝓝 (x + (-1) * (x - x)^2)) :=
          tendsto_id.add (((tendsto_id.sub_const x).pow 2).const_mul (-1)),
        simpa using this },
      { have : Ioo x (x+1) ∈ 𝓝[>] x,
        { apply Ioo_mem_nhds_within_Ioi, exact ⟨le_refl _, by linarith⟩ },
        filter_upwards [this],
        rintros y ⟨hy : x < y, h'y : y < x + 1⟩,
        rw mem_Ioi,
        nlinarith } },
    -- apply the sandwiching argument, with the helper function and `g`
    apply tendsto_of_tendsto_of_tendsto_of_le_of_le' this hx.2,
    { filter_upwards [self_mem_nhds_within],
      rintros y (hy : x < y),
      have : 0 < (y - x)^2, from sq_pos_of_pos (sub_pos.2 hy),
      apply div_le_div_of_le_of_nonneg _ (sub_pos.2 hy).le,
      exact (sub_le_sub_iff_right _).2 (hf.right_lim_le (by linarith)) },
    { filter_upwards [self_mem_nhds_within],
      rintros y (hy : x < y),
      apply div_le_div_of_le_of_nonneg _ (sub_pos.2 hy).le,
      exact (sub_le_sub_iff_right _).2 (hf.le_right_lim (le_refl y)) } },
  -- prove differentiability on the left, by sandwiching with values of `g`
  have L2 : tendsto (λ y, (f y - f x) / (y - x)) (𝓝[<] x)
     (𝓝 (rn_deriv hf.stieltjes_function.measure volume x).to_real),
  { -- limit of a helper function, with a small shift compared to `g`
    have : tendsto (λ y, (hf.stieltjes_function (y + (-1) * (y-x)^2) - f x) / (y - x)) (𝓝[<] x)
      (𝓝 (rn_deriv hf.stieltjes_function.measure volume x).to_real),
    { apply tendsto_apply_add_mul_sq_div_sub (nhds_left'_le_nhds_ne x) hx.1,
      apply tendsto_nhds_within_of_tendsto_nhds_of_eventually_within,
      { apply tendsto.mono_left _ nhds_within_le_nhds,
        have : tendsto (λ (y : ℝ), y + (-1) * (y - x) ^ 2) (𝓝 x) (𝓝 (x + (-1) * (x - x)^2)) :=
          tendsto_id.add (((tendsto_id.sub_const x).pow 2).const_mul (-1)),
        simpa using this },
      { have : Ioo (x - 1) x ∈ 𝓝[<] x,
        { apply Ioo_mem_nhds_within_Iio, exact ⟨by linarith, le_refl _⟩ },
        filter_upwards [this],
        rintros y ⟨hy : x - 1 < y, h'y : y < x⟩,
        rw mem_Iio,
        nlinarith } },
    -- apply the sandwiching argument, with `g` and the helper function
    apply tendsto_of_tendsto_of_tendsto_of_le_of_le' hx.1 this,
    { filter_upwards [self_mem_nhds_within],
      rintros y (hy : y < x),
      apply div_le_div_of_nonpos_of_le (sub_neg.2 hy).le,
      exact (sub_le_sub_iff_right _).2 (hf.le_right_lim (le_refl _)) },
    { filter_upwards [self_mem_nhds_within],
      rintros y (hy : y < x),
      have : 0 < (y - x)^2, from sq_pos_of_neg (sub_neg.2 hy),
      apply div_le_div_of_nonpos_of_le (sub_neg.2 hy).le,
      exact (sub_le_sub_iff_right _).2 (hf.right_lim_le (by linarith)) } },
  -- conclude global differentiability
  rw [has_deriv_at_iff_tendsto_slope, slope_fun_def_field, (nhds_left'_sup_nhds_right' x).symm,
    tendsto_sup],
  exact ⟨L2, L1⟩
end

/-- A monotone real function is differentiable Lebesgue-almost everywhere. -/
theorem monotone.ae_differentiable_at {f : ℝ → ℝ} (hf : monotone f) :
  ∀ᵐ x, differentiable_at ℝ f x :=
by filter_upwards [hf.ae_has_deriv_at] with x hx using hx.differentiable_at

/-- A real function which is monotone on a set is differentiable Lebesgue-almost everywhere on
this set. This version does not assume that `s` is measurable. For a formulation with
`volume.restrict s` assuming that `s` is measurable, see `monotone_on.ae_differentiable_within_at`.
-/
theorem monotone_on.ae_differentiable_within_at_of_mem
  {f : ℝ → ℝ} {s : set ℝ} (hf : monotone_on f s) :
  ∀ᵐ x, x ∈ s → differentiable_within_at ℝ f s x :=
begin
  /- We use a global monotone extension of `f`, and argue that this extension is differentiable
  almost everywhere. Such an extension need not exist (think of `1/x` on `(0, +∞)`), but it exists
  if one restricts first the function to a compact interval `[a, b]`. -/
  apply ae_of_mem_of_ae_of_mem_inter_Ioo,
  assume a b as bs hab,
  obtain ⟨g, hg, gf⟩ : ∃ (g : ℝ → ℝ), monotone g ∧ eq_on f g (s ∩ Icc a b) :=
    (hf.mono (inter_subset_left s (Icc a b))).exists_monotone_extension
      (hf.map_bdd_below (inter_subset_left _ _) ⟨a, λ x hx, hx.2.1, as⟩)
      (hf.map_bdd_above (inter_subset_left _ _) ⟨b, λ x hx, hx.2.2, bs⟩),
  filter_upwards [hg.ae_differentiable_at] with x hx,
  assume h'x,
  apply hx.differentiable_within_at.congr_of_eventually_eq _ (gf ⟨h'x.1, h'x.2.1.le, h'x.2.2.le⟩),
  have : Ioo a b ∈ 𝓝[s] x, from nhds_within_le_nhds (Ioo_mem_nhds h'x.2.1 h'x.2.2),
  filter_upwards [self_mem_nhds_within, this] with y hy h'y,
  exact gf ⟨hy, h'y.1.le, h'y.2.le⟩,
end

/-- A real function which is monotone on a set is differentiable Lebesgue-almost everywhere on
this set. This version assumes that `s` is measurable and uses `volume.restrict s`.
For a formulation without measurability assumption,
see `monotone_on.ae_differentiable_within_at_of_mem`. -/
theorem monotone_on.ae_differentiable_within_at
  {f : ℝ → ℝ} {s : set ℝ} (hf : monotone_on f s) (hs : measurable_set s) :
  ∀ᵐ x ∂(volume.restrict s), differentiable_within_at ℝ f s x :=
begin
  rw ae_restrict_iff' hs,
  exact hf.ae_differentiable_within_at_of_mem
end


-- Notes 10/29/2019
/-
Moving from propositional logic to predicate logic

Over what values do variables range in prop. logic? → true and false
In predicate logic, variables range over arbitrary domains.

∀ p: Person, ∃ q: Person, p likes q
"For every person p, there exists a person q such that p likes q" → "everyone likes someone"

∃ p: Person, ∀ q: Person, p likes q
"someone likes everyone"

∃ p: Person, ∀ q: Person, ¬ (q likes p)
"there exists someone who everybody dislikes"

"everyone dislikes someone"
∀ p, ∃ q, ¬ likes p q

Propositions & existential quantifiers

(∃ p, ∀ q, ¬likes q p) → ¬likes p p
if everybody dislikes p, then p dislikes themselves

We need a way to reason with predicate logic and propositions

How do we verify whether a predicate logic propositions are true?
    Proof!

We can use our logical rules of deduction to reason about whether proofs are valid

IFF introduction:
If we have a proof of P and a proof of Q, we have a proof of P ∧ Q
If we have a proof of P ∧ Q, we have a proof of P and we have a proof of Q
If we need to prove P ↔ Q, it suffices to prove P ⇒ Q and Q ⇒ P

Syllogism:
To prove P ⇒ R, it suffices to show that
P ⇒ Q and Q ⇒ R

Can we automatically prove these?

-/

-- Remember the "day" inductive?
inductive day : Type
| monday
| tuesday
| wednesday
| thursday
| friday
| saturday
| sunday

def is_weekend : day → bool
| day.saturday := tt
| day.sunday := tt
| _ := ff

def is_weekday : day → bool := λ d, ¬is_weekend d

inductive emily_is_from_cville : Prop
-- the constructors for this prop are types of proofs
-- these are axioms: they are accepted to be true without further truth
| drivers_license
| passport
| utility_bill
open emily_is_from_cville
def a_proof : emily_is_from_cville := drivers_license -- axiomatically, we accept that a drivers' license is sufficient to conclude that emily is from cville
theorem a_proof' : emily_is_from_cville := passport


/-
Copyright (c) 2019 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin
-/

import data.nat.prime
import data.rat.defs
import order.well_founded
import tactic.linarith
import tactic.wlog

/-!
# IMO 1988 Q6 and constant descent Vieta jumping

Question 6 of IMO1988 is somewhat (in)famous. Several expert problem solvers
could not tackle the question within the given time limit.
The problem lead to the introduction of a new proof technique,
so called “Vieta jumping”.

In this file we formalise constant descent Vieta jumping,
and apply this to prove Q6 of IMO1988.
To illustrate the technique, we also prove a similar result.
-/

-- open_locale classical

local attribute [instance] classical.prop_decidable
local attribute [simp] sq

/-- Constant descent Vieta jumping.

This proof technique allows one to prove an arbitrary proposition `claim`,
by running a descent argument on a hyperbola `H` in the first quadrant of the plane,
under the following conditions:

* `h₀`     : There exists an integral point `(x,y)` on the hyperbola `H`.
* `H_symm` : The hyperbola has a symmetry along the diagonal in the plane.
* `H_zero` : If an integral point `(x,0)` lies on the hyperbola `H`, then `claim` is true.
* `H_diag` : If an integral point `(x,x)` lies on the hyperbola `H`, then `claim` is true.
* `H_desc` : If `(x,y)` is an integral point on the hyperbola `H`,
with `x < y` then there exists a “smaller” point on `H`: a point `(x',y')` with `x' < y' ≤ x`.

For reasons of usability, the hyperbola `H` is implemented as an arbitrary predicate.
(In question 6 of IMO1988, where this proof technique was first developped,
the predicate `claim` would be `∃ (d : ℕ), d ^ 2 = k` for some natural number `k`,
and the predicate `H` would be `λ a b, a * a + b * b = (a * b + 1) * k`.)

To ensure that the predicate `H` actually describes a hyperbola,
the user must provide arguments `B` and `C` that are used as coefficients for a quadratic equation.
Finally, `H_quad` is the proof obligation that the quadratic equation
  `(y:ℤ) * y - B x * y + C x = 0`
describes the same hyperbola as the predicate `H`.

For extra flexibility, one must provide a predicate `base` on the integral points in the plane.
In the descent step `H_desc` this will give the user the additional assumption that
the point `(x,y)` does not lie in this base locus.
The user must provide a proof that the proposition `claim` is true
if there exists an integral point `(x,y)` on the hyperbola `H` that lies in the base locus.
If such a base locus is not necessary, once can simply let it be `λ x y, false`.
-/
lemma constant_descent_vieta_jumping (x y : ℕ) {claim : Prop} {H : ℕ → ℕ → Prop}
  (h₀ : H x y) (B : ℕ → ℤ) (C : ℕ → ℤ) (base : ℕ → ℕ → Prop)
  (H_quad : ∀ {x y}, H x y ↔ (y:ℤ) * y - B x * y + C x = 0) (H_symm : ∀ {x y}, H x y ↔ H y x)
  (H_zero : ∀ {x}, H x 0 → claim) (H_diag : ∀ {x}, H x x → claim)
  (H_desc : ∀ {x y}, 0 < x → x < y → ¬base x y → H x y →
    ∀ y', y' * y' - B x * y' + C x = 0 → y' = B x - y → y' * y = C x → 0 ≤ y' ∧ y' ≤ x)
  (H_base : ∀ {x y}, H x y → base x y → claim) :
  claim :=
begin
  -- First of all, we may assume that x ≤ y.
  -- We justify this using H_symm.
  wlog hxy : x ≤ y,
  { rw H_symm at h₀, apply this y x h₀ B C base _ _ _ _ _ _ (le_of_not_le hxy), assumption' },
  -- In fact, we can easily deal with the case x = y.
  by_cases x_eq_y : x = y, {subst x_eq_y, exact H_diag h₀},
  -- Hence we may assume that x < y.
  replace hxy : x < y := lt_of_le_of_ne hxy x_eq_y, clear x_eq_y,
  -- Consider the upper branch of the hyperbola defined by H.
  let upper_branch : set (ℕ × ℕ) := {p | H p.1 p.2 ∧ p.1 < p.2},
  -- Note that the point p = (x,y) lies on the upper branch.
  let p : ℕ × ℕ := ⟨x,y⟩,
  have hp : p ∈ upper_branch := ⟨h₀, hxy⟩,
  -- We also consider the exceptional set of solutions (a,b) that satisfy
  -- a = 0 or a = b or B a = b or B a = b + a or that lie in the base locus.
  let exceptional : set (ℕ × ℕ) :=
  {p | H p.1 p.2 ∧ (base p.1 p.2 ∨ p.1 = 0 ∨ p.1 = p.2 ∨ B p.1 = p.2 ∨ B p.1 = p.2 + p.1) },
  -- Let S be the projection of the upper branch on to the y-axis
  -- after removing the exceptional locus.
  let S : set ℕ := prod.snd '' (upper_branch \ exceptional),
  -- The strategy is to show that the exceptional locus in nonempty
  -- by running a descent argument that starts with the given point p = (x,y).
  -- Our assumptions ensure that we can then prove the claim.
  suffices exc : exceptional.nonempty,
  { -- Suppose that there exists an element in the exceptional locus.
    simp [exceptional, -add_comm, set.nonempty] at exc,
    -- Let (a,b) be such an element, and consider all the possible cases.
    rcases exc with ⟨a, b, hH, hb⟩, rcases hb with _|rfl|rfl|hB|hB,
    -- The first three cases are rather easy to solve.
    { solve_by_elim },
    { rw H_symm at hH, solve_by_elim },
    { solve_by_elim },
    -- The final two cases are very similar.
    all_goals
    { -- Consider the quadratic equation that (a,b) satisfies.
      rw H_quad at hH,
      -- We find the other root of the equation, and Vieta's formulas.
      rcases Vieta_formula_quadratic hH with ⟨c, h_root, hV₁, hV₂⟩,
      -- By substitutions we find that b = 0 or b = a.
      simp [hB] at hV₁, subst hV₁,
      rw [← int.coe_nat_zero] at *,
      rw ← H_quad at h_root,
      -- And hence we are done by H_zero and H_diag.
      solve_by_elim } },
  -- To finish the main proof, we need to show that the exceptional locus is nonempty.
  -- So we assume that the exceptional locus is empty, and work towards deriving a contradiction.
  rw set.nonempty_iff_ne_empty,
  assume exceptional_empty,
  -- Observe that S is nonempty.
  have S_nonempty : S.nonempty,
  { -- It contains the image of p.
    use p.2,
    apply set.mem_image_of_mem,
    -- After all, we assumed that the exceptional locus is empty.
    rwa [exceptional_empty, set.diff_empty], },
  -- We are now set for an infinite descent argument.
  -- Let m be the smallest element of the nonempty set S.
  let  m     : ℕ                := well_founded.min     nat.lt_wf S S_nonempty,
  have m_mem : m ∈ S            := well_founded.min_mem nat.lt_wf S S_nonempty,
  have m_min : ∀ k ∈ S, ¬ k < m := λ k hk, well_founded.not_lt_min nat.lt_wf S S_nonempty hk,
  -- It suffices to show that there is point (a,b) with b ∈ S and b < m.
  rsuffices ⟨p', p'_mem, p'_small⟩ : ∃ p' : ℕ × ℕ, p'.2 ∈ S ∧ p'.2 < m,
  { solve_by_elim },
  -- Let (m_x, m_y) be a point on the upper branch that projects to m ∈ S
  -- and that does not lie in the exceptional locus.
  rcases m_mem with ⟨⟨mx, my⟩, ⟨⟨hHm, mx_lt_my⟩, h_base⟩, m_eq⟩,
  -- This means that m_y = m,
  -- and the conditions H(m_x, m_y) and m_x < m_y are satisfied.
  simp [exceptional, hHm] at mx_lt_my h_base m_eq,
  push_neg at h_base,
  -- Finally, it also means that (m_x, m_y) does not lie in the base locus,
  -- that m_x ≠ 0, m_x ≠ m_y, B(m_x) ≠ m_y, and B(m_x) ≠ m_x + m_y.
  rcases h_base with ⟨h_base, hmx, hm_diag, hm_B₁, hm_B₂⟩,
  replace hmx : 0 < mx := pos_iff_ne_zero.mpr hmx,
  -- Consider the quadratic equation that (m_x, m_y) satisfies.
  have h_quad := hHm, rw H_quad at h_quad,
  -- We find the other root of the equation, and Vieta's formulas.
  rcases Vieta_formula_quadratic h_quad with ⟨c, h_root, hV₁, hV₂⟩,
  -- No we rewrite Vietas formulas a bit, and apply the descent step.
  replace hV₁ : c = B mx - my := eq_sub_of_add_eq' hV₁,
  rw mul_comm at hV₂,
  have Hc := H_desc hmx mx_lt_my h_base hHm c h_root hV₁ hV₂,
  -- This means that we may assume that c ≥ 0 and c ≤ m_x.
  cases Hc with c_nonneg c_lt,
  -- In other words, c is a natural number.
  lift c to ℕ using c_nonneg,
  -- Recall that we are trying find a point (a,b) such that b ∈ S and b < m.
  -- We claim that p' = (c, m_x) does the job.
  let p' : ℕ × ℕ := ⟨c, mx⟩,
  use p',
  -- The second condition is rather easy to check, so we do that first.
  split, swap,
  { rwa m_eq at mx_lt_my },
  -- Now we need to show that p' projects onto S. In other words, that c ∈ S.
  -- We do that, by showing that it lies in the upper branch
  -- (which is sufficient, because we assumed that the exceptional locus is empty).
  apply set.mem_image_of_mem,
  rw [exceptional_empty, set.diff_empty],
  -- Now we are ready to prove that p' = (c, m_x) lies on the upper branch.
  -- We need to check two conditions: H(c, m_x) and c < m_x.
  split; dsimp only,
  { -- The first condition is not so hard. After all, c is the other root of the quadratic equation.
    rw [H_symm, H_quad],
    simpa using h_root, },
  { -- For the second condition, we note that it suffices to check that c ≠ m_x.
    suffices hc : c ≠ mx,
    { refine lt_of_le_of_ne _ hc,
      exact_mod_cast c_lt, },
    -- However, recall that B(m_x) ≠ m_x + m_y.
    -- If c = m_x, we can prove B(m_x) = m_x + m_y.
    contrapose! hm_B₂, subst c,
    simp [hV₁], }
    -- Hence p' = (c, m_x) lies on the upper branch, and we are done.
end

/--Question 6 of IMO1988. If a and b are two natural numbers
such that a*b+1 divides a^2 + b^2, show that their quotient is a perfect square.-/
lemma imo1988_q6 {a b : ℕ} (h : (a*b+1) ∣ a^2 + b^2) :
  ∃ d, d^2 = (a^2 + b^2)/(a*b + 1) :=
begin
  rcases h with ⟨k, hk⟩,
  rw [hk, nat.mul_div_cancel_left _ (nat.succ_pos (a*b))],
  simp only [sq] at hk,
  apply constant_descent_vieta_jumping a b hk (λ x, k * x) (λ x, x*x - k) (λ x y, false);
  clear hk a b,
  { -- We will now show that the fibers of the solution set are described by a quadratic equation.
    intros x y, dsimp only,
    rw [← int.coe_nat_inj', ← sub_eq_zero],
    apply eq_iff_eq_cancel_right.2,
    norm_cast,
    simp, ring, },
  { -- Show that the solution set is symmetric in a and b.
    intros x y, simp [add_comm (x*x), mul_comm x], },
  { -- Show that the claim is true if b = 0.
    suffices : ∀ a, a * a = k → ∃ d, d * d = k, by simpa,
    rintros x rfl, use x },
  { -- Show that the claim is true if a = b.
    intros x hx,
    suffices : k ≤ 1,
    { rw [nat.le_add_one_iff, le_zero_iff] at this,
      rcases this with rfl|rfl,
      { use 0, simp },
      { use 1, simp } },
    contrapose! hx with k_lt_one,
    apply ne_of_lt,
    calc x*x + x*x = x*x * 2       : by rw mul_two
               ... ≤ x*x * k       : nat.mul_le_mul_left (x*x) k_lt_one
               ... < (x*x + 1) * k : by linarith },
  { -- Show the descent step.
    intros x y hx x_lt_y hxky h z h_root hV₁ hV₀,
    split,
    { dsimp [-sub_eq_add_neg] at *,
      have hpos : z*z + x*x > 0,
      { apply add_pos_of_nonneg_of_pos,
        { apply mul_self_nonneg },
        { apply mul_pos; exact_mod_cast hx }, },
      have hzx : z*z + x*x = (z * x + 1) * k,
      { rw [← sub_eq_zero, ← h_root],
        ring, },
      rw hzx at hpos,
      replace hpos : z * x + 1 > 0 := pos_of_mul_pos_left hpos (int.coe_zero_le k),
      replace hpos : z * x ≥ 0 := int.le_of_lt_add_one hpos,
      apply nonneg_of_mul_nonneg_left hpos (by exact_mod_cast hx), },
    { contrapose! hV₀ with x_lt_z,
      apply ne_of_gt,
      calc z * y > x*x     : by apply mul_lt_mul'; linarith
             ... ≥ x*x - k : sub_le_self _ (int.coe_zero_le k) }, },
  { -- There is no base case in this application of Vieta jumping.
    simp },
end

/-
The following example illustrates the use of constant descent Vieta jumping
in the presence of a non-trivial base case.
-/

example {a b : ℕ} (h : a*b ∣ a^2 + b^2 + 1) :
  3*a*b = a^2 + b^2 + 1 :=
begin
  rcases h with ⟨k, hk⟩,
  suffices : k = 3, { simp * at *, ring, },
  simp only [sq] at hk,
  apply constant_descent_vieta_jumping a b hk (λ x, k * x) (λ x, x*x + 1) (λ x y, x ≤ 1);
  clear hk a b,
  { -- We will now show that the fibers of the solution set are described by a quadratic equation.
    intros x y, dsimp only,
    rw [← int.coe_nat_inj', ← sub_eq_zero],
    apply eq_iff_eq_cancel_right.2,
    simp, ring, },
  { -- Show that the solution set is symmetric in a and b.
    cc },
  { -- Show that the claim is true if b = 0.
    simp },
  { -- Show that the claim is true if a = b.
    intros x hx,
    have x_sq_dvd : x*x ∣ x*x*k := dvd_mul_right (x*x) k,
    rw ← hx at x_sq_dvd,
    obtain ⟨y, hy⟩ : x * x ∣ 1 := by simpa only [nat.dvd_add_self_left, add_assoc] using x_sq_dvd,
    obtain ⟨rfl,rfl⟩ : x = 1 ∧ y = 1 := by simpa [nat.mul_eq_one_iff] using hy.symm,
    simpa using hx.symm, },
  { -- Show the descent step.
    intros x y x_lt_y hx h_base h z h_root hV₁ hV₀,
    split,
    { have zy_pos : z * y ≥ 0,
      { rw hV₀, exact_mod_cast (nat.zero_le _) },
      apply nonneg_of_mul_nonneg_left zy_pos,
      linarith },
    { contrapose! hV₀ with x_lt_z,
      apply ne_of_gt,
      push_neg at h_base,
      calc z * y > x * y       : by apply mul_lt_mul_of_pos_right; linarith
             ... ≥ x * (x + 1) : by apply mul_le_mul; linarith
             ... > x * x + 1   :
        begin
          rw [mul_add, mul_one],
          apply add_lt_add_left,
          assumption_mod_cast
        end, } },
  { -- Show the base case.
    intros x y h h_base,
    obtain rfl|rfl : x = 0 ∨ x = 1 := by rwa [nat.le_add_one_iff, le_zero_iff] at h_base,
    { simpa using h, },
    { simp only [mul_one, one_mul, add_comm, zero_add] at h,
      have y_dvd : y ∣ y * k := dvd_mul_right y k,
      rw [← h, ← add_assoc, nat.dvd_add_left (dvd_mul_left y y)] at y_dvd,
      obtain rfl|rfl := (nat.dvd_prime nat.prime_two).mp y_dvd; apply mul_left_cancel₀,
      exacts [one_ne_zero, h.symm, two_ne_zero, h.symm] } }
end


import pq_to_group

universes u1 u2

section pq_like_morphism

variables {Q1 : Type u1} {Q2 : Type u2} [power_quandle Q1] [power_quandle Q2]

variables {φ : pq_group Q1 →* pq_group Q2}

theorem comes_from_is_pq_morph (f : Q1 → Q2)
(hf : ∀ x, φ (of x) = of (f x))
(hof : function.injective (of : Q2 → pq_group Q2)) : is_pq_morphism f :=
begin
  split,
  {
    intros a b,
    apply hof,
    rw ←rhd_of_eq_of_rhd,
    repeat {rw ←hf},
    rw ←rhd_of_eq_of_rhd,
    rw rhd_def_group,
    simp only [monoid_hom.map_mul, monoid_hom.map_mul_inv],
    rw rhd_def_group,
  },
  {
    intros a n,
    apply hof,
    rw of_pow_eq_pow_of,
    repeat {rw ←hf},
    rw of_pow_eq_pow_of,
    rw monoid_hom.map_gpow,
  },
end

theorem comes_from_pq_morph (f : Q1 → Q2)
(hf : ∀ x, φ (of x) = of (f x))
(hof : function.injective (of : Q2 → pq_group Q2)) : φ = L_of_morph f (comes_from_is_pq_morph f hf hof) :=
begin
  ext1,
  induction x,
  {
    rw quot_mk_helper,
    induction x,
    {
      rw incl_unit_eq_unit,
      simp only [monoid_hom.map_one],
    },
    {
      rw ←of_def,
      rw hf,
      refl,
    },
    {
      rw ←mul_def,
      simp only [monoid_hom.map_mul],
      rw x_ih_a,
      rw x_ih_b,
    },
    {
      rw ←inv_def,
      simp only [inv_inj, monoid_hom.map_inv],
      assumption,
    },
  },
  {refl,},
end

end pq_like_morphism


/-
Copyright (c) 2020 Pim Spelier, Daan van Gent. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Pim Spelier, Daan van Gent.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.fintype.basic
import Mathlib.data.num.lemmas
import Mathlib.tactic.derive_fintype
import Mathlib.PostPort

universes l

namespace Mathlib

/-!
# Encodings

This file contains the definition of a (finite) encoding, a map from a type to
strings in an alphabet, used in defining computability by Turing machines.
It also contains several examples:

## Examples

- `fin_encoding_nat_bool`   : a binary encoding of ℕ in a simple alphabet.
- `fin_encoding_nat_Γ'`    : a binary encoding of ℕ in the alphabet used for TM's.
- `unary_fin_encoding_nat` : a unary encoding of ℕ
- `fin_encoding_bool_bool`  : an encoding of bool.
-/

namespace computability

/-- An encoding of a type in a certain alphabet, together with a decoding. -/
structure encoding (α : Type) where
  Γ : Type
  encode : α → List Γ
  decode : List Γ → Option α
  decode_encode : ∀ (x : α), decode (encode x) = some x

/-- An encoding plus a guarantee of finiteness of the alphabet. -/
structure fin_encoding (α : Type) extends encoding α where
  Γ_fin : fintype (encoding.Γ _to_encoding)

/-- A standard Turing machine alphabet, consisting of blank,bit0,bit1,bra,ket,comma. -/
inductive Γ' where
| blank : Γ'
| bit : Bool → Γ'
| bra : Γ'
| ket : Γ'
| comma : Γ'

protected instance inhabited_Γ' : Inhabited Γ' := { default := Γ'.blank }

/-- The natural inclusion of bool in Γ'. -/
def inclusion_bool_Γ' : Bool → Γ' := Γ'.bit

/-- An arbitrary section of the natural inclusion of bool in Γ'. -/
def section_Γ'_bool : Γ' → Bool := sorry

theorem left_inverse_section_inclusion : function.left_inverse section_Γ'_bool inclusion_bool_Γ' :=
  fun (x : Bool) => bool.cases_on x rfl rfl

theorem inclusion_bool_Γ'_injective : function.injective inclusion_bool_Γ' :=
  function.has_left_inverse.injective (Exists.intro section_Γ'_bool left_inverse_section_inclusion)

/-- An encoding function of the positive binary numbers in bool. -/
def encode_pos_num : pos_num → List Bool := sorry

/-- An encoding function of the binary numbers in bool. -/
def encode_num : num → List Bool := sorry

/-- An encoding function of ℕ in bool. -/
def encode_nat (n : ℕ) : List Bool := encode_num ↑n

/-- A decoding function from `list bool` to the positive binary numbers. -/
def decode_pos_num : List Bool → pos_num := sorry

/-- A decoding function from `list bool` to the binary numbers. -/
def decode_num : List Bool → num := fun (l : List Bool) => ite (l = []) num.zero ↑(decode_pos_num l)

/-- A decoding function from `list bool` to ℕ. -/
def decode_nat : List Bool → ℕ := fun (l : List Bool) => ↑(decode_num l)

theorem encode_pos_num_nonempty (n : pos_num) : encode_pos_num n ≠ [] :=
  pos_num.cases_on n (list.cons_ne_nil tt [])
    (fun (m : pos_num) => list.cons_ne_nil tt (encode_pos_num m))
    fun (m : pos_num) => list.cons_ne_nil false (encode_pos_num m)

theorem decode_encode_pos_num (n : pos_num) : decode_pos_num (encode_pos_num n) = n := sorry

theorem decode_encode_num (n : num) : decode_num (encode_num n) = n := sorry

theorem decode_encode_nat (n : ℕ) : decode_nat (encode_nat n) = n := sorry

/-- A binary encoding of ℕ in bool. -/
def encoding_nat_bool : encoding ℕ :=
  encoding.mk Bool encode_nat (fun (n : List Bool) => some (decode_nat n)) sorry

/-- A binary fin_encoding of ℕ in bool. -/
def fin_encoding_nat_bool : fin_encoding ℕ := fin_encoding.mk encoding_nat_bool bool.fintype

/-- A binary encoding of ℕ in Γ'. -/
def encoding_nat_Γ' : encoding ℕ :=
  encoding.mk Γ' (fun (x : ℕ) => list.map inclusion_bool_Γ' (encode_nat x))
    (fun (x : List Γ') => some (decode_nat (list.map section_Γ'_bool x))) sorry

/-- A binary fin_encoding of ℕ in Γ'. -/
def fin_encoding_nat_Γ' : fin_encoding ℕ := fin_encoding.mk encoding_nat_Γ' Γ'.fintype

/-- A unary encoding function of ℕ in bool. -/
def unary_encode_nat : ℕ → List Bool := sorry

/-- A unary decoding function from `list bool` to ℕ. -/
def unary_decode_nat : List Bool → ℕ := list.length

theorem unary_decode_encode_nat (n : ℕ) : unary_decode_nat (unary_encode_nat n) = n :=
  Nat.rec rfl
    (fun (m : ℕ) (hm : unary_decode_nat (unary_encode_nat m) = m) =>
      Eq.symm (congr_arg Nat.succ (Eq.symm hm)))
    n

/-- A unary fin_encoding of ℕ. -/
def unary_fin_encoding_nat : fin_encoding ℕ :=
  fin_encoding.mk
    (encoding.mk Bool unary_encode_nat (fun (n : List Bool) => some (unary_decode_nat n)) sorry)
    bool.fintype

/-- An encoding function of bool in bool. -/
def encode_bool : Bool → List Bool := list.ret

/-- A decoding function from `list bool` to bool. -/
def decode_bool : List Bool → Bool := sorry

theorem decode_encode_bool (b : Bool) : decode_bool (encode_bool b) = b := bool.cases_on b rfl rfl

/-- A fin_encoding of bool in bool. -/
def fin_encoding_bool_bool : fin_encoding Bool :=
  fin_encoding.mk (encoding.mk Bool encode_bool (fun (x : List Bool) => some (decode_bool x)) sorry)
    bool.fintype

protected instance inhabited_fin_encoding : Inhabited (fin_encoding Bool) :=
  { default := fin_encoding_bool_bool }

protected instance inhabited_encoding : Inhabited (encoding Bool) :=
  { default := fin_encoding.to_encoding fin_encoding_bool_bool }

end Mathlib


/-
Copyright (c) 2021 Justus Springer. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Justus Springer
-/
import algebra.category.Mon.basic
import category_theory.limits.concrete_category
import category_theory.limits.preserves.filtered

/-!
# The forgetful functor from (commutative) (additive) monoids preserves filtered colimits.

Forgetful functors from algebraic categories usually don't preserve colimits. However, they tend
to preserve _filtered_ colimits.

In this file, we start with a small filtered category `J` and a functor `F : J ⥤ Mon`.
We then construct a monoid structure on the colimit of `F ⋙ forget Mon` (in `Type`), thereby
showing that the forgetful functor `forget Mon` preserves filtered colimits. Similarly for `AddMon`,
`CommMon` and `AddCommMon`.

-/

universe v

noncomputable theory
open_locale classical

open category_theory
open category_theory.limits
open category_theory.is_filtered (renaming max → max') -- avoid name collision with `_root_.max`.

namespace Mon.filtered_colimits

section

-- We use parameters here, mainly so we can have the abbreviations `M` and `M.mk` below, without
-- passing around `F` all the time.
parameters {J : Type v} [small_category J] (F : J ⥤ Mon.{v})

/--
The colimit of `F ⋙ forget Mon` in the category of types.
In the following, we will construct a monoid structure on `M`.
-/
@[to_additive "The colimit of `F ⋙ forget AddMon` in the category of types.
In the following, we will construct an additive monoid structure on `M`."]
abbreviation M : Type v := types.quot (F ⋙ forget Mon)

/-- The canonical projection into the colimit, as a quotient type. -/
@[to_additive "The canonical projection into the colimit, as a quotient type."]
abbreviation M.mk : (Σ j, F.obj j) → M := quot.mk (types.quot.rel (F ⋙ forget Mon))

@[to_additive]
lemma M.mk_eq (x y : Σ j, F.obj j)
  (h : ∃ (k : J) (f : x.1 ⟶ k) (g : y.1 ⟶ k), F.map f x.2 = F.map g y.2) :
  M.mk x = M.mk y :=
quot.eqv_gen_sound (types.filtered_colimit.eqv_gen_quot_rel_of_rel (F ⋙ forget Mon) x y h)

variables [is_filtered J]

/--
As `J` is nonempty, we can pick an arbitrary object `j₀ : J`. We use this object to define the
"one" in the colimit as the equivalence class of `⟨j₀, 1 : F.obj j₀⟩`.
-/
@[to_additive "As `J` is nonempty, we can pick an arbitrary object `j₀ : J`. We use this object to
define the \"zero\" in the colimit as the equivalence class of `⟨j₀, 0 : F.obj j₀⟩`."]
instance colimit_has_one : has_one M :=
{ one := M.mk ⟨is_filtered.nonempty.some, 1⟩ }

/--
The definition of the "one" in the colimit is independent of the chosen object of `J`.
In particular, this lemma allows us to "unfold" the definition of `colimit_one` at a custom chosen
object `j`.
-/
@[to_additive "The definition of the \"zero\" in the colimit is independent of the chosen object
of `J`. In particular, this lemma allows us to \"unfold\" the definition of `colimit_zero` at a
custom chosen object `j`."]
lemma colimit_one_eq (j : J) : (1 : M) = M.mk ⟨j, 1⟩ :=
begin
  apply M.mk_eq,
  refine ⟨max' _ j, left_to_max _ j, right_to_max _ j, _⟩,
  simp,
end

/--
The "unlifted" version of multiplication in the colimit. To multiply two dependent pairs
`⟨j₁, x⟩` and `⟨j₂, y⟩`, we pass to a common successor of `j₁` and `j₂` (given by `is_filtered.max`)
and multiply them there.
-/
@[to_additive "The \"unlifted\" version of addition in the colimit. To add two dependent pairs
`⟨j₁, x⟩` and `⟨j₂, y⟩`, we pass to a common successor of `j₁` and `j₂` (given by `is_filtered.max`)
and add them there."]
def colimit_mul_aux (x y : Σ j, F.obj j) : M :=
M.mk ⟨max' x.1 y.1, F.map (left_to_max x.1 y.1) x.2 * F.map (right_to_max x.1 y.1) y.2⟩

/-- Multiplication in the colimit is well-defined in the left argument. -/
@[to_additive "Addition in the colimit is well-defined in the left argument."]
lemma colimit_mul_aux_eq_of_rel_left {x x' y : Σ j, F.obj j}
  (hxx' : types.filtered_colimit.rel (F ⋙ forget Mon) x x') :
  colimit_mul_aux x y = colimit_mul_aux x' y :=
begin
  cases x with j₁ x, cases y with j₂ y, cases x' with j₃ x',
  obtain ⟨l, f, g, hfg⟩ := hxx',
  simp at hfg,
  obtain ⟨s, α, β, γ, h₁, h₂, h₃⟩ := tulip (left_to_max j₁ j₂) (right_to_max j₁ j₂)
    (right_to_max j₃ j₂) (left_to_max j₃ j₂) f g,
  apply M.mk_eq,
  use [s, α, γ],
  dsimp,
  simp_rw [monoid_hom.map_mul, ← comp_apply, ← F.map_comp, h₁, h₂, h₃, F.map_comp, comp_apply, hfg]
end

/-- Multiplication in the colimit is well-defined in the right argument. -/
@[to_additive "Addition in the colimit is well-defined in the right argument."]
lemma colimit_mul_aux_eq_of_rel_right {x y y' : Σ j, F.obj j}
  (hyy' : types.filtered_colimit.rel (F ⋙ forget Mon) y y') :
  colimit_mul_aux x y = colimit_mul_aux x y' :=
begin
  cases y with j₁ y, cases x with j₂ x, cases y' with j₃ y',
  obtain ⟨l, f, g, hfg⟩ := hyy',
  simp at hfg,
  obtain ⟨s, α, β, γ, h₁, h₂, h₃⟩ := tulip (right_to_max j₂ j₁) (left_to_max j₂ j₁)
    (left_to_max j₂ j₃) (right_to_max j₂ j₃) f g,
  apply M.mk_eq,
  use [s, α, γ],
  dsimp,
  simp_rw [monoid_hom.map_mul, ← comp_apply, ← F.map_comp, h₁, h₂, h₃, F.map_comp, comp_apply, hfg]
end

/-- Multiplication in the colimit. See also `colimit_mul_aux`. -/
@[to_additive "Addition in the colimit. See also `colimit_add_aux`."]
instance colimit_has_mul : has_mul M :=
{ mul := λ x y, begin
    refine quot.lift₂ (colimit_mul_aux F) _ _ x y,
  { intros x y y' h,
    apply colimit_mul_aux_eq_of_rel_right,
    apply types.filtered_colimit.rel_of_quot_rel,
    exact h },
  { intros x x' y h,
    apply colimit_mul_aux_eq_of_rel_left,
    apply types.filtered_colimit.rel_of_quot_rel,
    exact h },
  end }

/--
Multiplication in the colimit is independent of the chosen "maximum" in the filtered category.
In particular, this lemma allows us to "unfold" the definition of the multiplication of `x` and `y`,
using a custom object `k` and morphisms `f : x.1 ⟶ k` and `g : y.1 ⟶ k`.
-/
@[to_additive "Addition in the colimit is independent of the chosen \"maximum\" in the filtered
category. In particular, this lemma allows us to \"unfold\" the definition of the addition of `x`
and `y`, using a custom object `k` and morphisms `f : x.1 ⟶ k` and `g : y.1 ⟶ k`."]
lemma colimit_mul_mk_eq (x y : Σ j, F.obj j) (k : J) (f : x.1 ⟶ k) (g : y.1 ⟶ k) :
  (M.mk x) * (M.mk y) = M.mk ⟨k, F.map f x.2 * F.map g y.2⟩ :=
begin
  cases x with j₁ x, cases y with j₂ y,
  obtain ⟨s, α, β, h₁, h₂⟩ := bowtie (left_to_max j₁ j₂) f (right_to_max j₁ j₂) g,
  apply M.mk_eq,
  use [s, α, β],
  dsimp,
  simp_rw [monoid_hom.map_mul, ← comp_apply, ← F.map_comp, h₁, h₂],
end

@[to_additive]
instance colimit_monoid : monoid M :=
{ one_mul := λ x, begin
    apply quot.induction_on x, clear x, intro x, cases x with j x,
    rw [colimit_one_eq F j, colimit_mul_mk_eq F ⟨j, 1⟩ ⟨j, x⟩ j (𝟙 j) (𝟙 j),
      monoid_hom.map_one, one_mul, F.map_id, id_apply],
  end,
  mul_one := λ x, begin
    apply quot.induction_on x, clear x, intro x, cases x with j x,
    rw [colimit_one_eq F j, colimit_mul_mk_eq F ⟨j, x⟩ ⟨j, 1⟩ j (𝟙 j) (𝟙 j),
      monoid_hom.map_one, mul_one, F.map_id, id_apply],
  end,
  mul_assoc := λ x y z, begin
    apply quot.induction_on₃ x y z, clear x y z, intros x y z,
    cases x with j₁ x, cases y with j₂ y, cases z with j₃ z,
    rw [colimit_mul_mk_eq F ⟨j₁, x⟩ ⟨j₂, y⟩ _ (first_to_max₃ j₁ j₂ j₃) (second_to_max₃ j₁ j₂ j₃),
      colimit_mul_mk_eq F ⟨max₃ j₁ j₂ j₃, _⟩ ⟨j₃, z⟩ _ (𝟙 _) (third_to_max₃ j₁ j₂ j₃),
      colimit_mul_mk_eq F ⟨j₂, y⟩ ⟨j₃, z⟩ _ (second_to_max₃ j₁ j₂ j₃) (third_to_max₃ j₁ j₂ j₃),
      colimit_mul_mk_eq F ⟨j₁, x⟩ ⟨max₃ j₁ j₂ j₃, _⟩ _ (first_to_max₃ j₁ j₂ j₃) (𝟙 _)],
    simp only [F.map_id, id_apply, mul_assoc],
  end,
  ..colimit_has_one,
  ..colimit_has_mul }

/-- The bundled monoid giving the filtered colimit of a diagram. -/
@[to_additive "The bundled additive monoid giving the filtered colimit of a diagram."]
def colimit : Mon := Mon.of M

/-- The monoid homomorphism from a given monoid in the diagram to the colimit monoid. -/
@[to_additive "The additive monoid homomorphism from a given additive monoid in the diagram to the
colimit additive monoid."]
def cocone_morphism (j : J) : F.obj j ⟶ colimit :=
{ to_fun := (types.colimit_cocone (F ⋙ forget Mon)).ι.app j,
  map_one' := (colimit_one_eq j).symm,
  map_mul' := λ x y, begin
    convert (colimit_mul_mk_eq F ⟨j, x⟩ ⟨j, y⟩ j (𝟙 j) (𝟙 j)).symm,
    rw [F.map_id, id_apply, id_apply], refl,
  end }

@[simp, to_additive]
lemma cocone_naturality {j j' : J} (f : j ⟶ j') :
  F.map f ≫ (cocone_morphism j') = cocone_morphism j :=
monoid_hom.coe_inj ((types.colimit_cocone (F ⋙ forget Mon)).ι.naturality f)

/-- The cocone over the proposed colimit monoid. -/
@[to_additive "/-- The cocone over the proposed colimit additive monoid. -/"]
def colimit_cocone : cocone F :=
{ X := colimit,
  ι := { app := cocone_morphism } }.

/--
Given a cocone `t` of `F`, the induced monoid homomorphism from the colimit to the cocone point.
As a function, this is simply given by the induced map of the corresponding cocone in `Type`.
The only thing left to see is that it is a monoid homomorphism.
-/
@[to_additive "Given a cocone `t` of `F`, the induced additive monoid homomorphism from the colimit
to the cocone point. As a function, this is simply given by the induced map of the corresponding
cocone in `Type`. The only thing left to see is that it is an additive monoid homomorphism."]
def colimit_desc (t : cocone F) : colimit ⟶ t.X :=
{ to_fun := (types.colimit_cocone_is_colimit (F ⋙ forget Mon)).desc ((forget Mon).map_cocone t),
  map_one' := begin
    rw colimit_one_eq F is_filtered.nonempty.some,
    exact monoid_hom.map_one _,
  end,
  map_mul' := λ x y, begin
    apply quot.induction_on₂ x y, clear x y, intros x y,
    cases x with i x, cases y with j y,
    rw colimit_mul_mk_eq F ⟨i, x⟩ ⟨j, y⟩ (max' i j) (left_to_max i j) (right_to_max i j),
    dsimp [types.colimit_cocone_is_colimit],
    rw [monoid_hom.map_mul, t.w_apply, t.w_apply],
  end }

/-- The proposed colimit cocone is a colimit in `Mon`. -/
@[to_additive "The proposed colimit cocone is a colimit in `AddMon`."]
def colimit_cocone_is_colimit : is_colimit colimit_cocone :=
{ desc := colimit_desc,
  fac' := λ t j, monoid_hom.coe_inj
    ((types.colimit_cocone_is_colimit (F ⋙ forget Mon)).fac ((forget Mon).map_cocone t) j),
  uniq' := λ t m h, monoid_hom.coe_inj $
    (types.colimit_cocone_is_colimit (F ⋙ forget Mon)).uniq ((forget Mon).map_cocone t) m
      (λ j, funext $ λ x, monoid_hom.congr_fun (h j) x) }

@[to_additive]
instance forget_preserves_filtered_colimits : preserves_filtered_colimits (forget Mon) :=
{ preserves_filtered_colimits := λ J _ _, by exactI
  { preserves_colimit := λ F, preserves_colimit_of_preserves_colimit_cocone
      (colimit_cocone_is_colimit F) (types.colimit_cocone_is_colimit (F ⋙ forget Mon)) } }

end

end Mon.filtered_colimits

namespace CommMon.filtered_colimits

open Mon.filtered_colimits (colimit_mul_mk_eq)

section

-- We use parameters here, mainly so we can have the abbreviation `M` below, without
-- passing around `F` all the time.
parameters {J : Type v} [small_category J] [is_filtered J] (F : J ⥤ CommMon.{v})

/--
The colimit of `F ⋙ forget₂ CommMon Mon` in the category `Mon`.
In the following, we will show that this has the structure of a _commutative_ monoid.
-/
@[to_additive "The colimit of `F ⋙ forget₂ AddCommMon AddMon` in the category `AddMon`. In the
following, we will show that this has the structure of a _commutative_ additive monoid."]
abbreviation M : Mon := Mon.filtered_colimits.colimit (F ⋙ forget₂ CommMon Mon.{v})

@[to_additive]
instance colimit_comm_monoid : comm_monoid M :=
{ mul_comm := λ x y, begin
    apply quot.induction_on₂ x y, clear x y, intros x y,
    let k := max' x.1 y.1,
    let f := left_to_max x.1 y.1,
    let g := right_to_max x.1 y.1,
    rw [colimit_mul_mk_eq _ x y k f g, colimit_mul_mk_eq _ y x k g f],
    dsimp,
    rw mul_comm,
 end
  ..M.monoid }

/-- The bundled commutative monoid giving the filtered colimit of a diagram. -/
@[to_additive "The bundled additive commutative monoid giving the filtered colimit of a diagram."]
def colimit : CommMon := CommMon.of M

/-- The cocone over the proposed colimit commutative monoid. -/
@[to_additive "The cocone over the proposed colimit additive commutative monoid."]
def colimit_cocone : cocone F :=
{ X := colimit,
  ι := { ..(Mon.filtered_colimits.colimit_cocone (F ⋙ forget₂ CommMon Mon.{v})).ι } }

/-- The proposed colimit cocone is a colimit in `CommMon`. -/
@[to_additive "The proposed colimit cocone is a colimit in `AddCommMon`."]
def colimit_cocone_is_colimit : is_colimit colimit_cocone :=
{ desc := λ t, Mon.filtered_colimits.colimit_desc (F ⋙ forget₂ CommMon Mon.{v})
    ((forget₂ CommMon Mon.{v}).map_cocone t),
  fac' := λ t j, monoid_hom.coe_inj $
    (types.colimit_cocone_is_colimit (F ⋙ forget CommMon)).fac ((forget CommMon).map_cocone t) j,
  uniq' := λ t m h, monoid_hom.coe_inj $
    (types.colimit_cocone_is_colimit (F ⋙ forget CommMon)).uniq ((forget CommMon).map_cocone t) m
    ((λ j, funext $ λ x, monoid_hom.congr_fun (h j) x)) }

@[to_additive forget₂_AddMon_preserves_filtered_colimits]
instance forget₂_Mon_preserves_filtered_colimits :
  preserves_filtered_colimits (forget₂ CommMon Mon.{v}) :=
{ preserves_filtered_colimits := λ J _ _, by exactI
  { preserves_colimit := λ F, preserves_colimit_of_preserves_colimit_cocone
      (colimit_cocone_is_colimit F)
      (Mon.filtered_colimits.colimit_cocone_is_colimit (F ⋙ forget₂ CommMon Mon.{v})) } }

@[to_additive]
instance forget_preserves_filtered_colimits : preserves_filtered_colimits (forget CommMon) :=
limits.comp_preserves_filtered_colimits (forget₂ CommMon Mon) (forget Mon)

end

end CommMon.filtered_colimits


import Advent.List

import Advent.List.Shuffles

def DifferentList [BEq α] (xs: List α): Prop := ∀ i j : Fin (xs.length), (xs.get i = xs.get j) -> i = j

theorem DifListTail [BEq α] {xs: List α} (x: α): DifferentList (x :: xs) -> DifferentList xs := by
  intros xxs
  unfold DifferentList
  intros i j iej
  apply Fin.eq_of_val_eq
  let i1 := appendFin x xs i
  let j1 := appendFin x xs j
  let h1 := xxs i1 j1
  simp [List.get] at h1
  let i1ej1 := h1 iej
  simp [appendFin] at i1ej1
  exact i1ej1

theorem DifListShuffle [BEq α] {x y : α} {xs: List α}:
  DifferentList (x :: y :: xs) -> DifferentList (y :: x :: xs) := by
  intros dl i j iej
  rw [shuffledGet i, shuffledGet j] at iej
  let siej := dl _ _ iej
  let ssiej := congrArg shuffleIndex siej
  rw [shuffleCancelable, shuffleCancelable] at ssiej
  assumption

theorem DifListHead [da: DecidableEq α] {x: α} {xs: List α}:
  DifferentList (x::xs) -> xs.all (· != x) = true := by
  intros h
  cases xs
  . simp [List.all, List.foldr]
  . case cons y ys =>
    simp [List.all, List.foldr]
    constructor
    . simp [bne, BEq.beq, decide]
      apply decide_eq_false
      intro yex
      let i: Fin (x :: y :: ys).length := ⟨ 0, Nat.zero_lt_succ _ ⟩
      let j: Fin (x :: y :: ys).length := ⟨ 1, Nat.succ_le_succ (Nat.zero_lt_succ _) ⟩
      let h2 := h i j
      simp [List.get] at h2
      apply h2
      rw [yex]
    . apply DifListHead
      apply DifListTail y
      apply DifListShuffle
      exact h

theorem nilDifferent [BEq α] : DifferentList ([] : List α) := by
  unfold DifferentList
  intro i
  intros
  simp [List.length] at i
  cases i.isLt

theorem listAllCorrect {xs : List α} {p : α -> Bool} (i: Fin (xs.length)) :
  xs.all p = true -> p (xs.get i) = true := by
  intro all
  cases i
  case mk iv ilt =>
  cases xs
  . contradiction
  . case cons h t =>
    simp [List.all, List.foldr] at all
    cases all with | intro first rest =>
    cases iv <;> simp [List.get]
    assumption
    case succ iv =>
    apply listAllCorrect
    assumption

theorem differsHead [de: DecidableEq α] {x : α} {xs : List α} {i: Fin (xs.length)}
  (d: differs (x :: xs) = true) :
  ¬ (x = xs.get i) := by
  intro p
  unfold differs at d
  simp at d
  cases d with | intro all _ =>
  let une := listAllCorrect i all
  simp [bne, BEq.beq] at une
  let une := of_decide_eq_false une
  rw [p] at une
  contradiction

theorem correctLeft[DecidableEq α] (xs: List α) (p: differs xs = true): DifferentList xs := by
  cases xs
  . apply nilDifferent
  . case cons h t =>
    unfold DifferentList
    intros i j iej
    cases i with | mk iv ilt =>
    cases j with | mk jv jlt =>
    apply Fin.eq_of_val_eq
    simp
    cases iv
    . cases jv
      simp
      case succ j =>
        simp [List.get] at iej
        let xs := differsHead p iej
        contradiction
    . case succ i =>
      cases jv
      . simp [List.get] at iej
        let xs := differsHead p iej.symm
        contradiction
      . case succ j =>
        simp [List.get] at iej
        simp
        simp [differs] at p
        cases p with | intro _ tdiff =>
        let td := correctLeft t tdiff
        let u := td _ _ iej
        simp at u
        assumption

theorem correctRight [DecidableEq α] (xs: List α) (dl: DifferentList xs): differs xs = true := by
  cases xs <;> simp [differs]
  case cons h t =>
  simp [differs]
  constructor
  . apply DifListHead dl
  . apply correctRight
    apply DifListTail _ dl

theorem differsIsCorect [DecidableEq α] (xs: List α): (differs xs = true) <-> DifferentList xs := by
  apply Iff.intro
  apply correctLeft
  apply correctRight


-- ----------------------------------------------------
-- Ejercicio. Demostrar
--    ⊢ p ∨ ¬p
-- ----------------------------------------------------

import tactic
variable (p : Prop)

open_locale classical

-- 1ª demostración
example : p ∨ ¬p :=
by_contradiction
  ( assume h1 : ¬(p ∨ ¬p),
    have h2 : ¬p, from
      assume h3 : p,
      have h4 : p ∨ ¬p, from or.inl h3,
      show false, from h1 h4,
    have h5 : p ∨ ¬p, from or.inr h2,
    show false, from h1 h5 )

-- 2ª demostración
example : p ∨ ¬p :=
by_contradiction
  ( assume h1 : ¬(p ∨ ¬p),
    have h2 : ¬p, from
      assume h3 : p,
      have h4 : p ∨ ¬p, from or.inl h3,
      show false, from h1 h4,
    have h5 : p ∨ ¬p, from or.inr h2,
    h1 h5 )

-- 3ª demostración
example : p ∨ ¬p :=
by_contradiction
  ( assume h1 : ¬(p ∨ ¬p),
    have h2 : ¬p, from
      assume h3 : p,
      have h4 : p ∨ ¬p, from or.inl h3,
      show false, from h1 h4,
    h1 (or.inr h2) )

-- 4ª demostración
example : p ∨ ¬p :=
by_contradiction
  ( assume h1 : ¬(p ∨ ¬p),
    have h2 : ¬p, from
      assume h3 : p,
      have h4 : p ∨ ¬p, from or.inl h3,
      h1 h4,
    h1 (or.inr h2) )

-- 5ª demostración
example : p ∨ ¬p :=
by_contradiction
  ( assume h1 : ¬(p ∨ ¬p),
    have h2 : ¬p, from
      assume h3 : p,
      h1 (or.inl h3),
    h1 (or.inr h2) )

-- 6ª demostración
example : p ∨ ¬p :=
by_contradiction
  ( assume h1 : ¬(p ∨ ¬p),
    have h2 : ¬p, from
      λ h3, h1 (or.inl h3),
    h1 (or.inr h2) )

-- 7ª demostración
example : p ∨ ¬p :=
by_contradiction
  ( assume h1 : ¬(p ∨ ¬p),
    h1 (or.inr (λ h3, h1 (or.inl h3))) )

-- 8ª demostración
example : p ∨ ¬p :=
by_contradiction
  ( λ h1, h1 (or.inr (λ h3, h1 (or.inl h3))) )

-- 9ª demostración
example : p ∨ ¬p :=
-- by library_search
em p

-- #print axioms em

-- 10ª demostración
example : p ∨ ¬p :=
begin
  by_contra h1,
  apply h1,
  apply or.inr,
  intro h2,
  apply h1,
  exact or.inl h2,
end

-- 11ª demostración
example : p ∨ ¬p :=
begin
  by_contra h1,
  apply h1,
  apply or.inr,
  intro h2,
  exact h1 (or.inl h2),
end

-- 12ª demostración
example : p ∨ ¬p :=
begin
  by_contra h1,
  apply h1,
  apply or.inr,
  exact λ h2, h1 (or.inl h2),
end

-- 13ª demostración
example : p ∨ ¬p :=
begin
  by_contra h1,
  apply h1,
  exact or.inr (λ h2, h1 (or.inl h2)),
end

-- 14ª demostración
example : p ∨ ¬p :=
begin
  by_contra h1,
  exact h1 (or.inr (λ h2, h1 (or.inl h2))),
end

-- 15ª demostración
example : p ∨ ¬p :=
by_contra (λ h1, h1 (or.inr (λh2, h1 (or.inl h2))))

-- 16ª demostración
example : p ∨ ¬p :=
begin
  by_contra h1,
  apply h1,
  right,
  intro h2,
  apply h1,
  left,
  exact h2,
end

-- 17ª demostración
example : p ∨ ¬p :=
-- by hint
by tauto

-- 18ª demostración
example : p ∨ ¬p :=
by finish


def fin_seq (k: nat) (t: Type) := fin k -> t

namespace fin_seq

def push {t k} (v: t) (a: fin_seq k t): fin_seq (k + 1) t
| ⟨val, is_lt⟩ :=
  begin
    cases val with val',
    exact v, -- arg(0) = v
    apply a,
    existsi val',
    apply nat.lt_of_succ_lt_succ,
    exact is_lt,
  end

def pop {t k} (a: fin_seq (k + 1) t): prod t (fin_seq k t) :=
begin
  split,
  exact a 0,
  intro arg,
  cases arg with val is_lt,
  apply a,
  split,
  show val + 1 < k + 1,
  apply nat.succ_lt_succ,
  exact is_lt,
end

def empty: fin_seq 0 nat := fun _, 0

def singleton {t: Type} (v: t): fin_seq 1 t := fun _, v

instance : has_emptyc (fin_seq 0 nat) := ⟨empty⟩

instance {t: Type}: has_singleton t (fin_seq 1 t) := ⟨singleton⟩

lemma push_of_pop: forall {t: Type} {k} (a: fin_seq (k + 1) t),
  a = let p := pop a in
      push p.fst p.snd :=
begin
  intros t k a,
  apply funext,
  intro arg,
  cases arg with val is_lt,
  cases val with val',
  reflexivity,
    show a ⟨nat.succ val', is_lt⟩ =
  push ((pop a).fst) ((pop a).snd) ⟨val' + 1, is_lt⟩,
  unfold push,
  reflexivity,
end

@[simp] lemma empty_is_unique: forall x: fin_seq 0 nat, x = empty :=
begin
  intros x,
  apply funext,
  intro fin0,
  cases fin0 with val is_lt,
  cases is_lt,
end

@[simp] lemma pop_of_push: forall {t k} (v: t) (a: fin_seq k t),
  pop (push v a) = (v, a) :=
begin
  intros t k v a,
  simp [pop],
  have left: v = push v a 0,
  {
    reflexivity,
  },
  rw <- left,
  apply congr_arg,
  apply funext,
  intro x,
  cases x with val is_lt,
  reflexivity,
end

@[simp] lemma pop_1: forall v: nat, pop (singleton v) = ⟨v, empty⟩ :=
begin
  intro v,
  simp [singleton],
  simp [pop],
  have : forall x: fin 0 -> nat, (v, x) = (v, empty),
  {
    intro x,
    rw empty_is_unique x,
  },
  apply this,
end

@[simp] lemma push_at_0: forall {t k} v (rest: fin_seq k t), fin_seq.push v rest 0 = v :=
begin
  intros t k v rest,
  reflexivity,
end

@[simp] lemma push_at_succ: forall {t k} v (rest: fin_seq k t) (i: fin k), push v rest (fin.succ i) = rest i
  :=
begin
  intros t k v rest i,
  cases i with i is_lt,
  reflexivity,
end

@[simp] lemma singleton_at_0: forall {t} (v: t), ({v}: fin_seq 1 t) 0 = v :=
begin
  intros t v,
  reflexivity,
end

@[simp] lemma length_1_of_singleton: forall {t} (xs: fin_seq 1 t), ({xs 0}: fin_seq 1 _) = xs :=
begin
  intros t xs,
  apply funext,
  intro i,
  cases i with i is_lt,
  have := nat.le_of_lt_succ is_lt,
  have := nat.eq_zero_of_le_zero this,
  cases this,
  reflexivity,
end

@[simp] lemma length_2_of_insert_of_singleton: forall {t} (xs: fin_seq 2 t),
  fin_seq.push (xs 0) {xs 1} = xs :=
begin
  intros t xs,
  apply funext,
  intro i,
  induction i with i is_lt,
  cases is_lt with _ is_le,
  -- i = 1
  {
    reflexivity,
  },
  -- i = 0
  {
    cases is_le with _ is_le,
    -- i = 0
    {
      reflexivity,
    },
    -- i < 0
    {
      have := nat.not_succ_le_zero _ is_le,
      contradiction,
    },
  },
end

end fin_seq