/-
Copyright 2020 Google LLC

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

      http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
 -/
import measure_theory.measurable_space

import measure_theory.measure_space
import measure_theory.outer_measure
import measure_theory.lebesgue_measure
import measure_theory.integration

import measure_theory.borel_space
import data.set.countable
import formal_ml.nnreal
import formal_ml.ennreal
import formal_ml.sum
import formal_ml.lattice
import formal_ml.measurable_space
import formal_ml.classical
import formal_ml.core
import formal_ml.characteristic
import formal_ml.measure
import data.equiv.list

noncomputable def prod.outer_measure {α:Type*} {β:Type*} [Mα:measurable_space α] [Mβ:measurable_space β]
  (μα:measure_theory.outer_measure α) (μβ:measure_theory.outer_measure β):measure_theory.outer_measure (α × β) :=
  measure_theory.outer_measure.of_function
  (λ P:set (α × β), μα (prod.fst '' P) * μβ (prod.snd '' P))
begin
  simp,
end

noncomputable def prod.measure {α:Type*} {β:Type*} [Mα:measurable_space α] [Mβ:measurable_space β]
  (μα:measure_theory.measure α) (μβ:measure_theory.measure β):measure_theory.measure (α × β) :=
  (prod.outer_measure μα.to_outer_measure μβ.to_outer_measure).to_measure
begin
  unfold prod.measurable_space,
  simp,
  split;
  intros P A1;
  unfold measurable_space.comap at A1;
  cases A1 with s A1;
  cases A1 with A1 A2;
  subst P;
  apply measure_theory.outer_measure.of_function_caratheodory;
  simp,
  {intros t,
   have B1:μα (prod.fst '' t ∩ s) + μα (prod.fst '' t \ s) = μα (prod.fst '' t),
   {rw ← measure_theory.measure_eq_inter_diff', apply A1},
   rw ← B1,
   clear B1,
   rw right_distrib,
   apply @add_le_add ennreal _;apply ennreal.mul_le_mul;try {apply measure_theory.measure_mono};simp;rw set.subset_def;
   intros p B2;cases p;simp at B2;simp [B2];
   try {apply exists.intro p_snd,simp [B2]};
   {apply exists.intro p_fst,simp [B2]}},
  {intros t,
   have B1:μβ (prod.snd '' t ∩ s) + μβ (prod.snd '' t \ s) = μβ (prod.snd '' t),
   {rw ← measure_theory.measure_eq_inter_diff', apply A1},
   rw ← B1,
   clear B1,
   rw left_distrib,
   apply @add_le_add ennreal _;apply ennreal.mul_le_mul;try {apply measure_theory.measure_mono};simp;rw set.subset_def;
   intros p B2;cases p;simp at B2;simp [B2];
   try {apply exists.intro p_snd,simp [B2]};
   {apply exists.intro p_fst,simp [B2]}},
end

@[simp]
lemma set.prod_fst_image_of_prod {α:Type*} {β:Type*} (A:set α) (B:set β) (h:B.nonempty):(prod.fst '' (A.prod B)) = A :=
begin
  ext p;split;intros A1,
  simp at A1,simp [A1],
  simp [A1],
  apply h,
end

@[simp]
lemma set.prod_snd_image_of_prod {α:Type*} {β:Type*} (A:set α) (B:set β) (h:A.nonempty):(prod.snd '' (A.prod B)) = B :=
begin
  ext p;split;intros A1,
  simp at A1,simp [A1],
  simp [A1],
  apply h,
end

lemma prod.outer_measure.Inf_sum {α:Type*} {β:Type*} [Mα:measurable_space α] [Mβ:measurable_space β]
  (μα:measure_theory.outer_measure α) (μβ:measure_theory.outer_measure β) {P:set (α × β)}:
  prod.outer_measure μα μβ P =
  ⨅ (f:ℕ → set α) (g:ℕ → set β) (h₁: P ⊆ ⋃ n, (f n).prod (g n)), ∑' n, μα (f n) * μβ (g n) :=
begin
  unfold prod.outer_measure measure_theory.outer_measure.of_function,
  rw ← measure_theory.outer_measure.measure_of_eq_coe,
  simp,
  apply le_antisymm,
  simp,
  intros f g B1,
  apply @infi_le_of_le ennreal  _ _ _ _ (λ (n:ℕ), (f n).prod (g n)),
  apply @infi_le_of_le ennreal  _ _ _ _ _,
  apply ennreal.tsum_le_tsum,
  intros a,
  cases (set.eq_empty_or_nonempty (f a)) with B2 B2,
  {simp [B2]},
  cases (set.eq_empty_or_nonempty (g a)) with B3 B3,
  {simp [B3]},
  {simp [B2,B3,le_refl]},
  {simp [B1]},
  simp,
  intros h C1,
  apply @infi_le_of_le ennreal _ _ _ _ (λ n, prod.fst '' (h n)),
  apply @infi_le_of_le ennreal _ _ _ _ (λ n, prod.snd '' (h n)),
  apply @infi_le_of_le ennreal  _ _ _ _ _,
  simp,
  apply le_refl _,
  simp,
  apply @set.subset.trans (α × β) P (set.Union h) (⋃ (n : ℕ), (prod.fst '' h n).prod (prod.snd '' h n)) C1,
  apply set.Union_subset_Union,
  intro i,
  rw set.subset_def,
  intros a C2,cases a,simp,
  apply and.intro (exists.intro a_snd C2) (exists.intro a_fst C2),
end

lemma set.prod_subset_prod {α:Type*} {β:Type*} {A A':set α} {B B':set β}:A ⊆ A' → B ⊆ B' →
A.prod B ⊆ A'.prod B' := begin
  intros hA hB,
  intros p hp,
  split,
  simp at hp,
  apply hA,
  apply hp.left,
  apply hB,
  apply hp.right,
end

lemma prod.outer_measure.Inf_sum2 {α:Type*} {β:Type*} [Mα:measurable_space α] [Mβ:measurable_space β]
  (μα:measure_theory.measure α) (μβ:measure_theory.measure β) {P:set (α × β)}:
  prod.outer_measure μα.to_outer_measure μβ.to_outer_measure P =
  ⨅ (f:ℕ → set α) (g:ℕ → set β)
    (h₁ : ∀ n, measurable_set (f n))
    (h₂ : ∀ n, measurable_set (g n))
   (h₃: P ⊆ ⋃ n, (f n).prod (g n)), ∑' n, μα (f n) * μβ (g n) :=
begin
  rw prod.outer_measure.Inf_sum,
  apply le_antisymm,
  { simp,
    intros f g h₁ h₂ h₃,
    apply @infi_le_trans (ℕ→ set α) ennreal _ f,
    apply @infi_le_trans (ℕ→ set β) ennreal _ g,
    rw infi_prop_def,
    apply le_refl _,
    apply h₃ },
  { simp,
    intros f g h₃,
    have h4 := λ n, measure_theory.measurable_eq μα (f n),
    rw classical.skolem at h4,
    cases h4 with f' h4,
    have h5 := λ n, measure_theory.measurable_eq μβ (g n),
    rw classical.skolem at h5,
    cases h5 with g' h5,

    apply @infi_le_trans (ℕ→ set α) ennreal _ f',
    apply @infi_le_trans (ℕ→ set β) ennreal _ g',
    rw infi_prop_def,
    rw infi_prop_def,
    rw infi_prop_def,
    apply ennreal.tsum_le_tsum,
    intro n,
    rw (h4 n).right.left,
    rw (h5 n).right.left,
    apply le_refl _,
    apply @set.subset.trans _ P (⋃ (n : ℕ), (f n).prod (g n))
          (⋃ (n : ℕ), (f' n).prod (g' n)) h₃,
    apply set.Union_subset_Union,
    intro n,
    apply set.prod_subset_prod,
    apply (h4 n).right.right,
    apply (h5 n).right.right,
    { intro n, apply (h5 n).left },
    { intro n, apply (h4 n).left },
    },
 -- sorry

end

/-
  If we can make this into an equality, we're home free.
  See https://www.math.ucdavis.edu/~hunter/measure_theory/measure_notes_ch5.pdf
  Those notes focus on measurable sets. We could theoretically do the same. However,
  it would make the rest of the analysis much more complex.
  I wonder if using an "outer measure lower integral" would make this useful.
-/
lemma prod.outer_measure.apply_prod_le {α:Type*} {β:Type*} [Mα:measurable_space α] [Mβ:measurable_space β]
  (μα:measure_theory.outer_measure α) (μβ:measure_theory.outer_measure β) {A:set α} {B:set β}:
  prod.outer_measure μα μβ (A.prod B) ≤ μα A * μβ B :=
begin
  rw prod.outer_measure.Inf_sum,
  {apply @infi_le_of_le ennreal _ _ _ _ (λ (n:ℕ), ite (n = 0) A ∅),
  apply @infi_le_of_le ennreal _ _ _ _ (λ (n:ℕ), ite (n = 0) B ∅),
  apply @infi_le_of_le ennreal _ _ _ _ _,
  rw tsum_eq_single 0,
  {simp [le_refl]},
  intros b' B1,
  simp [B1],
  apply ennreal.t2_space,
  rw set.subset_def,
  intros p B2,
  simp,
  apply exists.intro 0,
  {simp at B2,simp [B2]}},
end

--measure_theory.lintegral_characteristic
/- The primary focus is on measures, instead of outer measures. This establishes an
    inequality when the sets are measurable and we are looking at a product of two
    measures. -/
lemma prod.outer_measure.le_apply_prod {α:Type*} {β:Type*} [Mα:measurable_space α] [Mβ:measurable_space β]
  (μα:measure_theory.measure α) (μβ:measure_theory.measure β) {A:set α} {B:set β}:
  (measurable_set A) → (measurable_set B) →
  μα A * μβ B  ≤ prod.outer_measure μα.to_outer_measure μβ.to_outer_measure (A.prod B) :=
begin
  intros A4 A5,
  rw prod.outer_measure.Inf_sum2,
  simp,
  intros f g A2 A3 A1,
  have h2:(A.prod B).characteristic ≤ ∑' (n : ℕ), ((f n).prod (g n)).characteristic,
  { apply function.le_trans (set.characteristic.subset A1),
    apply set.characteristic.Union,
     },
  have h3:∀ (a:α) (b:β), (A.characteristic a) * (B.characteristic b)  ≤
          ∑' (n : ℕ), ((f n).characteristic a * (g n).characteristic b),
  { intros a b,
    rw ← set.characteristic.prod,
    have h3a: (λ n, ((f n).characteristic a * (g n).characteristic b)) =
              (λ n, ((f n).prod (g n)).characteristic (a, b)),
    { ext n, rw set.characteristic.prod },
    rw h3a,
    have h3b:((∑' (n : ℕ), ((f n).prod (g n)).characteristic) (a, b)) =
        (∑' (n : ℕ), ((f n).prod (g n)).characteristic (a, b)) ,
    { apply ennreal.tsum_apply },
    rw ← h3b,
    apply h2 },
  have h4:∀ (b:β), measure_theory.lintegral μα  (λ a, A.characteristic a * (B.characteristic b))  ≤ measure_theory.lintegral μα (λ a,
            ∑' (n : ℕ), ((f n).characteristic a) * (g n).characteristic b),
  { intro b,
    have h4a: ∀ (a:α), (A.characteristic a) * (B.characteristic b)  ≤
          ∑' (n : ℕ), ((f n).characteristic a * (g n).characteristic b),
    { intro a, apply h3 },
    apply measure_theory.lintegral_mono, apply h4a },
  have h5:∀ (b:β), μα A * (B.characteristic b)  ≤
            ∑' (n : ℕ), ((μα (f n)) * (g n).characteristic b),
  { intro b,
    have h5a := h4 b,
    rw measure_theory.lintegral_mul_const at h5a,
    rw measure_theory.lintegral_characteristic at h5a,

    rw measure_theory.lintegral_tsum at h5a,
    have h5b : (λ i, (∫⁻ (a : α), (f i).characteristic a * (g i).characteristic b ∂μα)) =
               (λ i, μα (f i) * (g i).characteristic b),
    { ext1 i,
      rw measure_theory.lintegral_mul_const,
      --rw set.characteristic_integral,
      rw measure_theory.lintegral_characteristic,
      apply A2,
      apply measurable.characteristic,
      apply A2 },
    rw h5b at h5a,
      apply h5a,
    { intro i, apply measurable.ennreal_mul,
      apply measurable.characteristic,
      apply A2,
      apply measurable_const },
    { apply A4 },
    { apply measurable.characteristic, apply A4 } },
  have h6:∫⁻ (b : β),   (μα A) * B.characteristic b ∂μβ ≤
          ∫⁻ (b : β), ( ∑' (n : ℕ), (μα (f n)) * (g n).characteristic b)  ∂μβ,
  { apply measure_theory.lintegral_mono,
    apply h5, },
  rw measure_theory.lintegral_const_mul at h6,
  rw measure_theory.lintegral_characteristic at h6, -- set.characteristic_integral at h6,
  rw measure_theory.lintegral_tsum at h6,
  have h7: (λ i, ∫⁻ (b : β), μα (f i) * (g i).characteristic b ∂μβ) =
           (λ i,  μα (f i) *  μβ (g i)),
  {  ext1 i,
     rw measure_theory.lintegral_const_mul,
     rw measure_theory.lintegral_characteristic, -- set.characteristic_integral,
     apply A3, apply measurable.characteristic,
     apply A3 },
  rw h7 at h6,
  apply h6,
  { intro i, apply measurable.ennreal_mul,
    apply measurable_const,
    apply measurable.characteristic,
    apply A3 },
  { apply A5 },
  { apply measurable.characteristic, apply A5 },
end

lemma prod.measure_apply {α:Type*} {β:Type*} [Mα:measurable_space α] [Mβ:measurable_space β]
  (μα:measure_theory.measure α) (μβ:measure_theory.measure β) (S:set (α × β)):measurable_set S →
  prod.measure μα μβ S =
  prod.outer_measure μα.to_outer_measure μβ.to_outer_measure S :=
begin
  intro h,
  simp [prod.measure],
  rw measure_theory.to_measure_apply,
  apply h,
end

lemma prod.measure.apply_prod
{α:Type*} {β:Type*} [Mα:measurable_space α] [Mβ:measurable_space β]
  (μα:measure_theory.measure α) (μβ:measure_theory.measure β) (A:set α) (B:set β):measurable_set A →
  measurable_set B →
  (prod.measure μα μβ) (A.prod B) = (μα A) * (μβ B)  :=
begin
  intros A1 A2,
  rw prod.measure_apply,
  apply le_antisymm,
  { apply prod.outer_measure.apply_prod_le,
     },
  apply prod.outer_measure.le_apply_prod,
  apply A1,
  apply A2,
  apply measurable_set.prod A1 A2,
end


/- Tactics -/

example : p → q → p ∧ q ∧ p := by
  intro hp hq
  apply And.intro
  exact hp
  apply And.intro
  exact hq
  exact hp

example : p → q → p ∧ q ∧ p := by
  intro hp hq; apply And.intro hp; exact And.intro hq hp

/- Structuring proofs -/

example : p → q → p ∧ q ∧ p := by
  intro hp hq
  apply And.intro
  case left => exact hp
  case right =>
    apply And.intro
    case left => exact hq
    case right => exact hp

example : p → q → p ∧ q ∧ p := by
  intro hp hq
  apply And.intro
  . exact hp
  . apply And.intro
    . exact hq
    . exact hp


/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Tim Baumann, Stephen Morgan, Scott Morrison, Floris van Doorn
-/
import category_theory.natural_transformation

/-!
# The category of functors and natural transformations between two fixed categories.

We provide the category instance on `C ⥤ D`, with morphisms the natural transformations.

## Universes

If `C` and `D` are both small categories at the same universe level,
this is another small category at that level.
However if `C` and `D` are both large categories at the same universe level,
this is a small category at the next higher level.
-/

namespace category_theory

-- declare the `v`'s first; see `category_theory.category` for an explanation
universes v₁ v₂ v₃ u₁ u₂ u₃

open nat_trans category category_theory.functor

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

local attribute [simp] vcomp_app
/--
`functor.category C D` gives the category structure on functors and natural transformations
between categories `C` and `D`.

Notice that if `C` and `D` are both small categories at the same universe level,
this is another small category at that level.
However if `C` and `D` are both large categories at the same universe level,
this is a small category at the next higher level.
-/
instance functor.category : category.{(max u₁ v₂)} (C ⥤ D) :=
{ hom     := λ F G, nat_trans F G,
  id      := λ F, nat_trans.id F,
  comp    := λ _ _ _ α β, vcomp α β }

variables {C D} {E : Type u₃} [category.{v₃} E]
variables {F G H I : C ⥤ D}

namespace nat_trans

@[simp] lemma vcomp_eq_comp (α : F ⟶ G) (β : G ⟶ H) : vcomp α β = α ≫ β := rfl

lemma vcomp_app' (α : F ⟶ G) (β : G ⟶ H) (X : C) :
  (α ≫ β).app X = (α.app X) ≫ (β.app X) := rfl

lemma congr_app {α β : F ⟶ G} (h : α = β) (X : C) : α.app X = β.app X := by rw h
@[simp] lemma id_app (F : C ⥤ D) (X : C) : (𝟙 F : F ⟶ F).app X = 𝟙 (F.obj X) := rfl
@[simp] lemma comp_app {F G H : C ⥤ D} (α : F ⟶ G) (β : G ⟶ H) (X : C) :
  (α ≫ β).app X = α.app X ≫ β.app X := rfl

lemma app_naturality {F G : C ⥤ (D ⥤ E)} (T : F ⟶ G) (X : C) {Y Z : D} (f : Y ⟶ Z) :
  ((F.obj X).map f) ≫ ((T.app X).app Z) = ((T.app X).app Y) ≫ ((G.obj X).map f) :=
(T.app X).naturality f

lemma naturality_app {F G : C ⥤ (D ⥤ E)} (T : F ⟶ G) (Z : D) {X Y : C} (f : X ⟶ Y) :
  ((F.map f).app Z) ≫ ((T.app Y).app Z) = ((T.app X).app Z) ≫ ((G.map f).app Z) :=
congr_fun (congr_arg app (T.naturality f)) Z

/-- A natural transformation is a monomorphism if each component is. -/
lemma mono_app_of_mono (α : F ⟶ G) [∀ (X : C), mono (α.app X)] : mono α :=
⟨λ H g h eq, by { ext X, rw [←cancel_mono (α.app X), ←comp_app, eq, comp_app] }⟩

/-- A natural transformation is an epimorphism if each component is. -/
lemma epi_app_of_epi (α : F ⟶ G) [∀ (X : C), epi (α.app X)] : epi α :=
⟨λ H g h eq, by { ext X, rw [←cancel_epi (α.app X), ←comp_app, eq, comp_app] }⟩

/-- `hcomp α β` is the horizontal composition of natural transformations. -/
def hcomp {H I : D ⥤ E} (α : F ⟶ G) (β : H ⟶ I) : (F ⋙ H) ⟶ (G ⋙ I) :=
{ app         := λ X : C, (β.app (F.obj X)) ≫ (I.map (α.app X)),
  naturality' := λ X Y f,
  begin
    rw [functor.comp_map, functor.comp_map, ←assoc, naturality, assoc,
        ←map_comp I, naturality, map_comp, assoc]
  end }

infix ` ◫ `:80 := hcomp

@[simp] lemma hcomp_app {H I : D ⥤ E} (α : F ⟶ G) (β : H ⟶ I) (X : C) :
  (α ◫ β).app X = (β.app (F.obj X)) ≫ (I.map (α.app X)) := rfl

@[simp] lemma hcomp_id_app {H : D ⥤ E} (α : F ⟶ G) (X : C) : (α ◫ 𝟙 H).app X = H.map (α.app X) :=
  by {dsimp, simp} -- See note [dsimp, simp].

lemma id_hcomp_app {H : E ⥤ C} (α : F ⟶ G) (X : E) : (𝟙 H ◫ α).app X = α.app _ := by simp

-- Note that we don't yet prove a `hcomp_assoc` lemma here: even stating it is painful, because we
-- need to use associativity of functor composition. (It's true without the explicit associator,
-- because functor composition is definitionally associative,
-- but relying on the definitional equality causes bad problems with elaboration later.)

lemma exchange {I J K : D ⥤ E} (α : F ⟶ G) (β : G ⟶ H)
  (γ : I ⟶ J) (δ : J ⟶ K) : (α ≫ β) ◫ (γ ≫ δ) = (α ◫ γ) ≫ (β ◫ δ) :=
by ext; simp

end nat_trans
open nat_trans
namespace functor

/-- Flip the arguments of a bifunctor. See also `currying.lean`. -/
protected def flip (F : C ⥤ (D ⥤ E)) : D ⥤ (C ⥤ E) :=
{ obj := λ k,
  { obj := λ j, (F.obj j).obj k,
    map := λ j j' f, (F.map f).app k,
    map_id' := λ X, begin rw category_theory.functor.map_id, refl end,
    map_comp' := λ X Y Z f g, by rw [map_comp, ←comp_app] },
  map := λ c c' f,
  { app := λ j, (F.obj j).map f } }.

@[simp] lemma flip_obj_obj (F : C ⥤ (D ⥤ E)) (c) (d) : (F.flip.obj d).obj c = (F.obj c).obj d := rfl
@[simp] lemma flip_obj_map (F : C ⥤ (D ⥤ E)) {c c' : C} (f : c ⟶ c') (d : D) :
  (F.flip.obj d).map f = (F.map f).app d := rfl
@[simp] lemma flip_map_app (F : C ⥤ (D ⥤ E)) {d d' : D} (f : d ⟶ d') (c : C) :
  (F.flip.map f).app c = (F.obj c).map f := rfl

end functor

end category_theory


/-
Copyright (c) 2019 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau
-/
import ring_theory.polynomial.basic
import ring_theory.principal_ideal_domain
import ring_theory.adjoin.polynomial

/-!
# Adjoining elements to form subalgebras

This file develops the basic theory of finitely-generated subalgebras.

## Definitions

* `fg (S : subalgebra R A)` : A predicate saying that the subalgebra is finitely-generated
as an A-algebra

## Tags

adjoin, algebra, finitely-generated algebra

-/

universes u v w

open subsemiring ring submodule
open_locale pointwise

namespace algebra

variables {R : Type u} {A : Type v} {B : Type w}
  [comm_semiring R] [comm_semiring A] [algebra R A] {s t : set A}

theorem fg_trans (h1 : (adjoin R s).to_submodule.fg)
  (h2 : (adjoin (adjoin R s) t).to_submodule.fg) :
  (adjoin R (s ∪ t)).to_submodule.fg :=
begin
  rcases fg_def.1 h1 with ⟨p, hp, hp'⟩,
  rcases fg_def.1 h2 with ⟨q, hq, hq'⟩,
  refine fg_def.2 ⟨p * q, hp.mul hq, le_antisymm _ _⟩,
  { rw [span_le],
    rintros _ ⟨x, y, hx, hy, rfl⟩,
    change x * y ∈ _,
    refine subalgebra.mul_mem _ _ _,
    { have : x ∈ (adjoin R s).to_submodule,
      { rw ← hp', exact subset_span hx },
      exact adjoin_mono (set.subset_union_left _ _) this },
    have : y ∈ (adjoin (adjoin R s) t).to_submodule,
    { rw ← hq', exact subset_span hy },
    change y ∈ adjoin R (s ∪ t), rwa adjoin_union_eq_adjoin_adjoin },
  { intros r hr,
    change r ∈ adjoin R (s ∪ t) at hr,
    rw adjoin_union_eq_adjoin_adjoin at hr,
    change r ∈ (adjoin (adjoin R s) t).to_submodule at hr,
    rw [← hq', ← set.image_id q, finsupp.mem_span_image_iff_total (adjoin R s)] at hr,
    rcases hr with ⟨l, hlq, rfl⟩,
    have := @finsupp.total_apply A A (adjoin R s),
    rw [this, finsupp.sum],
    refine sum_mem _ _,
    intros z hz, change (l z).1 * _ ∈ _,
    have : (l z).1 ∈ (adjoin R s).to_submodule := (l z).2,
    rw [← hp', ← set.image_id p, finsupp.mem_span_image_iff_total R] at this,
    rcases this with ⟨l2, hlp, hl⟩,
    have := @finsupp.total_apply A A R,
    rw this at hl,
    rw [←hl, finsupp.sum_mul],
    refine sum_mem _ _,
    intros t ht, change _ * _ ∈ _, rw smul_mul_assoc, refine smul_mem _ _ _,
    exact subset_span ⟨t, z, hlp ht, hlq hz, rfl⟩ }
end

end algebra

namespace subalgebra

variables {R : Type u} {A : Type v} {B : Type w}
variables [comm_semiring R] [semiring A] [algebra R A] [semiring B] [algebra R B]

/-- A subalgebra `S` is finitely generated if there exists `t : finset A` such that
`algebra.adjoin R t = S`. -/
def fg (S : subalgebra R A) : Prop :=
∃ t : finset A, algebra.adjoin R ↑t = S

lemma fg_adjoin_finset (s : finset A) : (algebra.adjoin R (↑s : set A)).fg :=
⟨s, rfl⟩

theorem fg_def {S : subalgebra R A} : S.fg ↔ ∃ t : set A, set.finite t ∧ algebra.adjoin R t = S :=
⟨λ ⟨t, ht⟩, ⟨↑t, set.finite_mem_finset t, ht⟩,
λ ⟨t, ht1, ht2⟩, ⟨ht1.to_finset, by rwa set.finite.coe_to_finset⟩⟩

theorem fg_bot : (⊥ : subalgebra R A).fg :=
⟨∅, algebra.adjoin_empty R A⟩

theorem fg_of_fg_to_submodule {S : subalgebra R A} : S.to_submodule.fg → S.fg :=
λ ⟨t, ht⟩, ⟨t, le_antisymm
  (algebra.adjoin_le (λ x hx, show x ∈ S.to_submodule, from ht ▸ subset_span hx)) $
  show S.to_submodule ≤ (algebra.adjoin R ↑t).to_submodule,
  from (λ x hx, span_le.mpr
    (λ x hx, algebra.subset_adjoin hx)
      (show x ∈ span R ↑t, by { rw ht, exact hx }))⟩

theorem fg_of_noetherian [is_noetherian R A] (S : subalgebra R A) : S.fg :=
fg_of_fg_to_submodule (is_noetherian.noetherian S.to_submodule)

lemma fg_of_submodule_fg (h : (⊤ : submodule R A).fg) : (⊤ : subalgebra R A).fg :=
let ⟨s, hs⟩ := h in ⟨s, to_submodule_injective $
by { rw [algebra.top_to_submodule, eq_top_iff, ← hs, span_le], exact algebra.subset_adjoin }⟩

lemma fg_prod {S : subalgebra R A} {T : subalgebra R B} (hS : S.fg) (hT : T.fg) : (S.prod T).fg :=
begin
  obtain ⟨s, hs⟩ := fg_def.1 hS,
  obtain ⟨t, ht⟩ := fg_def.1 hT,
  rw [← hs.2, ← ht.2],
  exact fg_def.2 ⟨(linear_map.inl R A B '' (s ∪ {1})) ∪ (linear_map.inr R A B '' (t ∪ {1})),
    set.finite.union (set.finite.image _ (set.finite.union hs.1 (set.finite_singleton _)))
    (set.finite.image _ (set.finite.union ht.1 (set.finite_singleton _))),
    algebra.adjoin_inl_union_inr_eq_prod R s t⟩
end

section
open_locale classical
lemma fg_map (S : subalgebra R A) (f : A →ₐ[R] B) (hs : S.fg) : (S.map f).fg :=
let ⟨s, hs⟩ := hs in ⟨s.image f, by rw [finset.coe_image, algebra.adjoin_image, hs]⟩
end

lemma fg_of_fg_map (S : subalgebra R A) (f : A →ₐ[R] B) (hf : function.injective f)
  (hs : (S.map f).fg) : S.fg :=
let ⟨s, hs⟩ := hs in ⟨s.preimage f $ λ _ _ _ _ h, hf h, map_injective f hf $
by { rw [← algebra.adjoin_image, finset.coe_preimage, set.image_preimage_eq_of_subset, hs],
  rw [← alg_hom.coe_range, ← algebra.adjoin_le_iff, hs, ← algebra.map_top], exact map_mono le_top }⟩

lemma fg_top (S : subalgebra R A) : (⊤ : subalgebra R S).fg ↔ S.fg :=
⟨λ h, by { rw [← S.range_val, ← algebra.map_top], exact fg_map _ _ h },
λ h, fg_of_fg_map _ S.val subtype.val_injective $ by { rw [algebra.map_top, range_val], exact h }⟩

lemma induction_on_adjoin [is_noetherian R A] (P : subalgebra R A → Prop)
  (base : P ⊥) (ih : ∀ (S : subalgebra R A) (x : A), P S → P (algebra.adjoin R (insert x S)))
  (S : subalgebra R A) : P S :=
begin
  classical,
  obtain ⟨t, rfl⟩ := S.fg_of_noetherian,
  refine finset.induction_on t _ _,
  { simpa using base },
  intros x t hxt h,
  rw [finset.coe_insert],
  simpa only [algebra.adjoin_insert_adjoin] using ih _ x h,
end

end subalgebra

section semiring

variables {R : Type u} {A : Type v} {B : Type w}
variables [comm_semiring R] [comm_ring A] [comm_ring B] [algebra R A] [algebra R B]

/-- The image of a Noetherian R-algebra under an R-algebra map is a Noetherian ring. -/
instance alg_hom.is_noetherian_ring_range (f : A →ₐ[R] B) [is_noetherian_ring A] :
  is_noetherian_ring f.range :=
is_noetherian_ring_range f.to_ring_hom

end semiring

section ring

variables {R : Type u} {A : Type v} {B : Type w}
variables [comm_ring R] [comm_ring A] [comm_ring B] [algebra R A] [algebra R B]

theorem is_noetherian_ring_of_fg {S : subalgebra R A} (HS : S.fg)
  [is_noetherian_ring R] : is_noetherian_ring S :=
let ⟨t, ht⟩ := HS in ht ▸ (algebra.adjoin_eq_range R (↑t : set A)).symm ▸
by haveI : is_noetherian_ring (mv_polynomial (↑t : set A) R) :=
mv_polynomial.is_noetherian_ring;
convert alg_hom.is_noetherian_ring_range _; apply_instance

theorem is_noetherian_subring_closure (s : set R) (hs : s.finite) :
  is_noetherian_ring (subring.closure s) :=
show is_noetherian_ring (subalgebra_of_subring (subring.closure s)), from
algebra.adjoin_int s ▸ is_noetherian_ring_of_fg (subalgebra.fg_def.2 ⟨s, hs, rfl⟩)

end ring


import data.equiv.fin
import data.fin
import data.nat.basic
import tactic
import init.data.nat.lemmas

/-!

# Finite Tuples

This file contains some definitions and results around finite tuples in an arbitrary type.
We have chosen to implement finite `n`-tuples in `A` as maps `fin n → A`.
This is primarily due to some restrictions arising from our inductive constructions.

-/

def ftuple (A : Type*) (n : ℕ) := fin n → A

local notation `η` := sum_fin_sum_equiv.to_fun
local notation `δ` := sum_fin_sum_equiv.inv_fun

def fin.swap_args {m n} (f : fin (m + n)) : fin (n + m) := f.cast (by rwa add_comm)

namespace ftuple
section definitions
/-!
## Definitions
This section contains some basic definitions.
-/

variables {A : Type*} {B : Type*}

def inl {m n} : fin m → fin (m + n) := η ∘ sum.inl
def inr {m n} : fin n → fin (m + n) := η ∘ sum.inr

def nil : ftuple A 0 := λ i, fin.elim0 i
def cast {m n} (h : m = n) (as : ftuple A m) : ftuple A n := as ∘ (fin.cast h.symm)
def swap_args {m n} (as : ftuple A (m + n)) : ftuple A (n + m) := cast (by rwa add_comm) as
def cast_to {m} (as : ftuple A m) (n) (h : m = n) : ftuple A n := as.cast h
def of (a : A) : ftuple A 1 := λ i, a
def append {m n} (as : ftuple A m) (bs : ftuple A n) : ftuple A (m+n) := λ i, sum.cases_on (δ i) as bs
def map {n} (as : ftuple A n) (f : A → B) : ftuple B n := f ∘ as
def proj {m n} (f : fin m → fin n) (as : ftuple A n) : ftuple A m := as ∘ f
def init {m n} (as : ftuple A (m + n)) : ftuple A m := λ i, as (η $ sum.inl i)
def last {m n} (as : ftuple A (m + n)) : ftuple A n := λ i, as (η $ sum.inr i)
def compl {m n} (as : ftuple A (m+n)) (f : ftuple A m → A) (g : ftuple A (1 + n) → A) : A :=
  g $ append (of $ f as.init) as.last
def compr {m n} (as : ftuple A (n+m)) (f : ftuple A m → A) (g : ftuple A (n + 1) → A) : A :=
  g $ append as.init $ of $ f as.last

def cons {n} (a : A) (as : ftuple A n) : ftuple A (n+1) := fin.cons a as --((of a).append as).cast (by rw add_comm)
def head {n} (as : ftuple A (n+1)) := as 0
def tail {n} (as : ftuple A (n+1)) : ftuple A n := fin.tail as --(as.cast_to (1+n) (by rw add_comm)).last

def curry {n} (f : ftuple A (n+1) → B) : A → (ftuple A n → B) := λ a as, f (cons a as)
def uncurry {n} (f : A → (ftuple A n → B)) : ftuple A (n+1) → B := λ as, f as.head as.tail

end definitions

section map_lemmas

variables {A : Type*} {B : Type*} {C : Type*}

@[simp]
lemma map_of (a : A) (f : A → B) : (of a).map f = of (f a) := rfl

@[simp]
lemma map_proj {m n} (f : fin m → fin n) (g : A → B) (as : ftuple A n) :
  (as.proj f).map g = (as.map g).proj f := rfl

@[simp]
lemma map_init {m n} (f : A → B) (as : ftuple A (m+n)) : as.init.map f = (as.map f).init := rfl

@[simp]
lemma map_last {m n} (f : A → B) (as : ftuple A (m+n)) : as.last.map f = (as.map f).last := rfl

@[simp]
lemma map_map {n} (f : A → B) (g : B → C) (as : ftuple A n) : as.map (g ∘ f) = (as.map f).map g := rfl

@[simp]
lemma map_eval {n} (f : A → B) (as : ftuple A n) : ∀ i, (as.map f) i = f (as i) := by tauto

end map_lemmas

section other_lemmas

variables {A : Type*} {B : Type*}

-- There is only one empty tuple
lemma nil_unique (ft1 ft2 : ftuple A 0) : ft1 = ft2 :=
begin
  ext,
  exact fin_zero_elim x,
end

lemma cast_eval {m n} (h : m = n) (as : ftuple A m) (i : fin n):
  (cast h as) i = as (fin.cast h.symm i) := rfl

@[simp]
lemma cons_at_zero {n} (a : A) (as : ftuple A n) :
  cons a as 0 = a := rfl

@[simp]
lemma append_eval_inl {m n} (as : ftuple A m) (bs : ftuple A n) (i : fin m) :
  (as.append bs) (inl i) = as i :=
begin
  unfold append,
  dsimp only [],
  have : inl i = η (sum.inl i), by refl, rw this, clear this,
  rw equiv.left_inv,
end

@[simp]
lemma append_eval_inr {m n} (as : ftuple A m) (bs : ftuple A n) (i : fin n) :
  (as.append bs) (inr i) = bs i :=
begin
  unfold append,
  dsimp only [],
  have : inr i = η (sum.inr i), by refl, rw this, clear this,
  rw equiv.left_inv,
end

private lemma sub_helper {m n} (x : fin (m + n)) (hx : m ≤ x.val)
  : x.val - m < n :=
begin
  cases x with xv xp,
  apply (nat.sub_lt_left_iff_lt_add hx).mpr,
  exact xp,
end

lemma lt_swap {m n} (x : fin (m + n))
  : x.val < n + m :=
begin
  cases x with xv xp,
  rw add_comm at xp,
  exact xp,
end

lemma inr_val {m n} (x : fin n)
  : (@inr m n x).val = x.val + m:=
begin
  unfold inr,
  exact add_comm m x.val,
end

lemma inr_sub {m n} (x : fin (m + n)) (hx : m ≤ x.val)
  : inr (fin.sub_nat m x.swap_args hx) = x :=
begin
  ext,
  rw inr_val,
  rw fin.sub_nat_val _ _,
  exact nat.sub_add_cancel hx,
end

lemma eval_sub {m n} (as : ftuple A m) (bs : ftuple A n) (x : fin (m + n)) (hx : m ≤ x.val)
  : (as.append bs) x = bs (fin.sub_nat m x.swap_args hx) :=
begin
  conv_lhs
  { rw ← (inr_sub x hx), },
  rw append_eval_inr,
end

@[simp]
lemma map_append {m n} (as : ftuple A m) (bs : ftuple A n) (f : A → B) :
  (as.append bs).map f = (as.map f).append (bs.map f) :=
begin
  ext,
  rw map_eval,
  by_cases x.val < m,
  { let y : fin m := ⟨x.val, h⟩,
    change f (as.append bs (inl y)) = (as.map f).append (bs.map f) (inl y),
    repeat {rw append_eval_inl},
    refl, },
  { rw not_lt at h,
    let y := fin.sub_nat m x.swap_args h,
    repeat {rw eval_sub _ _  x h},
    rw map_eval, }
end

lemma cons_shift {n} (a : A) (as : ftuple A n)
  : ∀ i : fin n, ((cons a as) (i.succ) = as i) := by apply fin.cons_succ

lemma val_nonzero_of_fin_nonzero {n : ℕ} (i : fin n.succ) (h : i ≠ 0) : i.val ≠ 0 :=
begin
  intro contra,
  exact h ((fin.ext_iff i 0).mpr contra),
end

def zero_lt_val {n : ℕ} (i : fin n.succ) (h : i ≠ 0) : 0 < i.val :=
begin
  have hi := val_nonzero_of_fin_nonzero i h,
  exact nat.pos_of_ne_zero hi,
end

lemma cons_nil (a : A)
  : (cons a nil) = of a :=
begin
  ext,
  have hx : x = 0, by exact subsingleton.elim x 0,
  rw hx,
  rw cons_at_zero,
  refl,
end

lemma tail_shift {n : ℕ} (as : ftuple A n.succ)
  : ∀ i, as.tail i = as i.succ :=
begin
  intro i,
  symmetry,
  have : as = cons as.head as.tail,
  { unfold cons,
    erw fin.cons_self_tail },
  conv_lhs {rw this},
  apply fin.cons_succ,
end

lemma map_cons {n} (as : ftuple A n) (a : A) (f : A → B)
  : (cons a as).map f = cons (f a) (as.map f) :=
begin
  ext,
  by_cases hx : x = 0,
  { rw hx,
    rw cons_at_zero,
    refl, },
  { rw ← fin.succ_pred x hx,
    rw cons_shift,
    rw map_eval,
    rw cons_shift,
    refl, }
end

-- This will let us split up ftuples for the following theorem
lemma is_append {n : ℕ} (as : ftuple A (n.succ))
  : cons (as 0) as.tail = as :=
begin
  ext,
  by_cases x = 0,
  { rw [h, cons_at_zero], },
  { rw ← fin.succ_pred x h,
    rw cons_shift,
    apply tail_shift as, }
end

-- by induction on n.
theorem exists_rep {n} {f : A → B} (bs : ftuple B n) (surj : function.surjective f) :
  ∃ as : ftuple A n, as.map f = bs :=
begin
  induction n with n hn,
  { use nil,
    apply nil_unique, },
  { rw ←is_append bs,
    specialize surj (bs 0),
    cases surj with a ha,
    specialize hn bs.tail,
    cases hn with as has,
    use cons a as,
    ext,
    by_cases x = 0,
    { rw h,
      rw cons_at_zero,
      rw map_cons,
      rw cons_at_zero,
      exact ha, },
    { rw ← fin.succ_pred x h,
      repeat {rw map_cons},
      repeat {rw cons_shift},
      rw has, } }
end

end other_lemmas

section quotient_stuff

variables {A : Type*} [I : setoid A]
variables {B : Type*}

include I
lemma tail_rel {n} (a : A) (as bs : ftuple A n) :
  (∀ i, (cons a as) i ≈ (cons a bs) i) ↔
  (∀ i, as i ≈ bs i) :=
begin
  split,
  { intros h j,
    replace h := h (j.succ),
    repeat {rw cons_shift at h},
    exact h },
  { intros h j,
    by_cases c : j = 0,
    { rw c,
      simp_rw cons_at_zero },
    {  rw ← fin.succ_pred j c,
      repeat {rw cons_shift},
      finish, } }
end

lemma head_rel {n} (a b : A) (as : ftuple A n) :
  (∀ i, (cons a as) i ≈ (cons b as) i) ↔
  a ≈ b :=
begin
  split,
  { intro h,
    specialize h 0,
    repeat {rw cons_at_zero at h},
    exact h, },
  { intros h i,
    by_cases hi : i = 0,
    { rw hi,
      repeat {rw cons_at_zero},
      exact h, },
    { rw ← fin.succ_pred i hi,
      repeat {rw cons_shift}, } }
end

def quotient_lift : Π {n} (f : ftuple A n → B)
  (hyp : ∀ (as bs : ftuple A n), (∀ i, as i ≈ bs i) → f as = f bs),
  ftuple (quotient I) n → B := λ n, nat.rec_on n
  (λ f hyp, λ _, f nil)
  (λ n ind f hyp, uncurry $ quotient.lift (λ a, ind (curry f a)
  begin
    intros as bs h,
    change f _ = f _,
    apply hyp,
    rw tail_rel, assumption,
  end)
  begin
    intros a b h,
    dsimp only [],
    suffices : curry f a = curry f b, by simp_rw this,
    funext,
    change f _ = f _,
    apply hyp,
    rw head_rel, assumption,
  end)

-- by induction on n
theorem quotient_lift_beta {n} (f : ftuple A n → B)
  (hyp : ∀ (as bs : ftuple A n), (∀ i, as i ≈ bs i) → f as = f bs) (as : ftuple A n):
  (quotient_lift f hyp) (as.map (λ a, ⟦a⟧)) = f as :=
begin
  induction n with n ind,
  { have : as = nil, by apply nil_unique,
    rw this,
    refl },
  { erw ind,
    unfold curry,
    apply congr_arg,
    exact is_append as }
end

end quotient_stuff

end ftuple


import .infinite_sums
import .log_harmonic
import .factors_le

import data.finset.image
import data.pnat.defs
import data.real.ennreal
import order.filter.basic
import order.filter.at_top_bot
import algebra.big_operators.basic
import topology.algebra.infinite_sum

open real filter
open_locale big_operators

lemma prod_geom_series_primes_eq (n : ℕ) :
  ∏ p in primes_le n, ((1 - (↑p)⁻¹)⁻¹ : ℝ) ≤
  ↑(finset.card (primes_le n) + 1) :=
begin
  sorry,
end

-- def pnat_range (n : ℕ) : finset ℕ+ := finset.image nat.to_pnat' (finset.Icc 1 n)
--
-- lemma coe_pnat_range_eq {n : ℕ} : finset.image coe (pnat_range n) = finset.Icc 1 n :=
-- begin
--   rw pnat_range,
--   simp [finset.image_image],
--   rw (_ : finset.image (coe ∘ nat.to_pnat') (finset.Icc 1 n) = finset.image id (finset.Icc 1 n)),
--   { simp, },
--   apply finset.image_congr,
--   simp [set.eq_on],
--   intros x h1 h2 h3,
--   exfalso,
--   revert h1,
--   simp [h3],
-- end

lemma mem_pnat_fac_le_of_mem_Icc {n : ℕ} {x : ℕ} (hx : x ∈ finset.Icc 1 n) : (nat.to_pnat' x ∈ pnat_fac_le n) :=
begin
  simp [pnat_fac_le],
  cases x,
  { exfalso, revert hx, simp, },
  apply all_factors_le_of_le,
  simp at *,
  exact hx.right,
end

def pnat_fac_le_range (n : ℕ) : finset ↥(pnat_fac_le n) :=
  -- finset.image (λ x, ⟨nat.to_pnat' x.val, mem_pnat_fac_le_of_mem_Icc x.property⟩) (finset.Icc 1 n).attach
  (finset.Icc 1 n).attach.image (λ x, ⟨nat.to_pnat' x.val, mem_pnat_fac_le_of_mem_Icc x.property⟩)

lemma coe_pnat_fac_le_range_eq {n : ℕ} : finset.image coe (pnat_fac_le_range n) = finset.Icc 1 n :=
begin
  rw (_ : finset.image coe (pnat_fac_le_range n) = finset.image coe (finset.Icc 1 n).attach),
  { rw finset.attach_image_coe, },
  rw pnat_fac_le_range,
  rw finset.image_image,
  apply finset.image_congr,
  simp [set.eq_on],
  intros a ha _ h,
  exfalso,
  revert ha,
  rw h,
  simp,
end

-- lemma nnreal_sum_le_tsum {α : Type*} {f : α → nnreal} (s : finset α) :
--   s.sum (λ (x : α), f x) ≤ ∑' (x : α), f x :=
-- begin
--   -- Should be easy to prove this? Non-negative! Needs summable?!
--   rw sum_eq_tsum_indicator,
--   sorry,
-- end

lemma finset_sum_inv_le_tsum_pnat_inv {n : ℕ} :
  -- ∑ k : ℕ+ in finset.Icc 1 n, ((↑k)⁻¹ : nnreal) ≤
  harmonic n ≤ ∑' k : ↥(pnat_fac_le n), (↑k)⁻¹ :=
begin
  rw harmonic,
  rw ← coe_pnat_fac_le_range_eq,
  rw finset.sum_image,
  { rw ← ennreal.coe_le_coe,
    push_cast,
    -- Should be possible to avoid need for summable proof here?
    rw ennreal.coe_tsum (sum_inv_pnat_fac_le_eq_prod_geom_series n).summable,
    apply ennreal.sum_le_tsum, },
  { simp, },
end

lemma log_le_card_primes {n : ℕ} :
  log (↑n + 1) ≤ ↑(finset.card (primes_le n) + 1) :=
begin
  apply le_trans log_add_one_le_harmonic,
  norm_cast,
  apply le_trans finset_sum_inv_le_tsum_pnat_inv,
  -- rw (by simp : ∀ {x : ℕ}, (↑x : ℝ) = ((↑x : nnreal) : ℝ)),
  -- norm_cast,
  rw has_sum.tsum_eq (sum_inv_pnat_fac_le_eq_prod_geom_series n),
  apply le_trans _ (prod_geom_series_primes_eq _),
  push_cast,
  apply le_of_eq,
  apply finset.prod_congr rfl,
  intros p _,
  simp,
  rw nnreal.coe_sub _,
  { simp, },
  simp,
  norm_cast,
  simp,
end

theorem infinite_primes : tendsto (λ n, finset.card (primes_le n)) at_top at_top :=
begin
  sorry,
end


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Kenny Lau, Yury Kudryashov
-/
import data.list.pairwise
import logic.relation

/-!
# Relation chain

This file provides basic results about `list.chain` (definition in `data.list.defs`).
A list `[a₂, ..., aₙ]` is a `chain` starting at `a₁` with respect to the relation `r` if `r a₁ a₂`
and `r a₂ a₃` and ... and `r aₙ₋₁ aₙ`. We write it `chain r a₁ [a₂, ..., aₙ]`.
A graph-specialized version is in development and will hopefully be added under `combinatorics.`
sometime soon.
-/

universes u v

open nat

namespace list

variables {α : Type u} {β : Type v} {R : α → α → Prop}

mk_iff_of_inductive_prop list.chain list.chain_iff

theorem rel_of_chain_cons {a b : α} {l : list α}
  (p : chain R a (b :: l)) : R a b :=
(chain_cons.1 p).1

theorem chain_of_chain_cons {a b : α} {l : list α}
  (p : chain R a (b :: l)) : chain R b l :=
(chain_cons.1 p).2

theorem chain.imp' {S : α → α → Prop}
  (HRS : ∀ ⦃a b⦄, R a b → S a b) {a b : α} (Hab : ∀ ⦃c⦄, R a c → S b c)
  {l : list α} (p : chain R a l) : chain S b l :=
by induction p with _ a c l r p IH generalizing b; constructor;
   [exact Hab r, exact IH (@HRS _)]

theorem chain.imp {S : α → α → Prop}
  (H : ∀ a b, R a b → S a b) {a : α} {l : list α} (p : chain R a l) : chain S a l :=
p.imp' H (H a)

theorem chain.iff {S : α → α → Prop}
  (H : ∀ a b, R a b ↔ S a b) {a : α} {l : list α} : chain R a l ↔ chain S a l :=
⟨chain.imp (λ a b, (H a b).1), chain.imp (λ a b, (H a b).2)⟩

theorem chain.iff_mem {a : α} {l : list α} :
  chain R a l ↔ chain (λ x y, x ∈ a :: l ∧ y ∈ l ∧ R x y) a l :=
⟨λ p, by induction p with _ a b l r p IH; constructor;
  [exact ⟨mem_cons_self _ _, mem_cons_self _ _, r⟩,
   exact IH.imp (λ a b ⟨am, bm, h⟩,
    ⟨mem_cons_of_mem _ am, mem_cons_of_mem _ bm, h⟩)],
 chain.imp (λ a b h, h.2.2)⟩

theorem chain_singleton {a b : α} : chain R a [b] ↔ R a b :=
by simp only [chain_cons, chain.nil, and_true]

theorem chain_split {a b : α} {l₁ l₂ : list α} : chain R a (l₁ ++ b :: l₂) ↔
  chain R a (l₁ ++ [b]) ∧ chain R b l₂ :=
by induction l₁ with x l₁ IH generalizing a;
simp only [*, nil_append, cons_append, chain.nil, chain_cons, and_true, and_assoc]

theorem chain_map (f : β → α) {b : β} {l : list β} :
  chain R (f b) (map f l) ↔ chain (λ a b : β, R (f a) (f b)) b l :=
by induction l generalizing b; simp only [map, chain.nil, chain_cons, *]

theorem chain_of_chain_map {S : β → β → Prop} (f : α → β)
  (H : ∀ a b : α, S (f a) (f b) → R a b) {a : α} {l : list α}
  (p : chain S (f a) (map f l)) : chain R a l :=
((chain_map f).1 p).imp H

theorem chain_map_of_chain {S : β → β → Prop} (f : α → β)
  (H : ∀ a b : α, R a b → S (f a) (f b)) {a : α} {l : list α}
  (p : chain R a l) : chain S (f a) (map f l) :=
(chain_map f).2 $ p.imp H

theorem chain_pmap_of_chain {S : β → β → Prop} {p : α → Prop}
  {f : Π a, p a → β}
  (H : ∀ a b ha hb, R a b → S (f a ha) (f b hb))
  {a : α} {l : list α}
  (hl₁ : chain R a l) (ha : p a) (hl₂ : ∀ a ∈ l, p a) :
  chain S (f a ha) (list.pmap f l hl₂) :=
begin
  induction l with lh lt l_ih generalizing a,
  { simp },
  { simp [H _ _ _ _ (rel_of_chain_cons hl₁), l_ih _ (chain_of_chain_cons hl₁)] }
end

theorem chain_of_chain_pmap {S : β → β → Prop} {p : α → Prop}
  (f : Π a, p a → β) {l : list α} (hl₁ : ∀ a ∈ l, p a)
  {a : α} (ha : p a) (hl₂ : chain S (f a ha) (list.pmap f l hl₁))
  (H : ∀ a b ha hb, S (f a ha) (f b hb) → R a b) :
  chain R a l :=
begin
  induction l with lh lt l_ih generalizing a,
  { simp },
  { simp [H _ _ _ _ (rel_of_chain_cons hl₂), l_ih _ _ (chain_of_chain_cons hl₂)] }
end

theorem chain_of_pairwise {a : α} {l : list α} (p : pairwise R (a :: l)) : chain R a l :=
begin
  cases pairwise_cons.1 p with r p', clear p,
  induction p' with b l r' p IH generalizing a, {exact chain.nil},
  simp only [chain_cons, forall_mem_cons] at r,
  exact chain_cons.2 ⟨r.1, IH r'⟩
end

theorem chain_iff_pairwise (tr : transitive R) {a : α} {l : list α} :
  chain R a l ↔ pairwise R (a :: l) :=
⟨λ c, begin
  induction c with b b c l r p IH, {exact pairwise_singleton _ _},
  apply IH.cons _, simp only [mem_cons_iff, forall_eq_or_imp, r, true_and],
  show ∀ x ∈ l, R b x, from λ x m, (tr r (rel_of_pairwise_cons IH m)),
end, chain_of_pairwise⟩

theorem chain_iff_nth_le {R} : ∀ {a : α} {l : list α},
  chain R a l ↔ (∀ h : 0 < length l, R a (nth_le l 0 h)) ∧ (∀ i (h : i < length l - 1),
    R (nth_le l i (lt_of_lt_pred h)) (nth_le l (i+1) (lt_pred_iff.mp h)))
| a []       := by simp
| a (b :: t) :=
begin
  rw [chain_cons, chain_iff_nth_le],
  split,
  { rintro ⟨R, ⟨h0, h⟩⟩,
    split,
    { intro w, exact R },
    intros i w,
    cases i,
    { apply h0 },
    convert h i _ using 1,
    simp only [succ_eq_add_one, add_succ_sub_one, add_zero, length, add_lt_add_iff_right] at w,
    exact lt_pred_iff.mpr w, },
  rintro ⟨h0, h⟩, split,
  { apply h0, simp, },
  split,
  { apply h 0, },
  intros i w, convert h (i+1) _ using 1,
  exact lt_pred_iff.mp w,
end

theorem chain'.imp {S : α → α → Prop}
  (H : ∀ a b, R a b → S a b) {l : list α} (p : chain' R l) : chain' S l :=
by cases l; [trivial, exact p.imp H]

theorem chain'.iff {S : α → α → Prop}
  (H : ∀ a b, R a b ↔ S a b) {l : list α} : chain' R l ↔ chain' S l :=
⟨chain'.imp (λ a b, (H a b).1), chain'.imp (λ a b, (H a b).2)⟩

theorem chain'.iff_mem : ∀ {l : list α}, chain' R l ↔ chain' (λ x y, x ∈ l ∧ y ∈ l ∧ R x y) l
| []       := iff.rfl
| (x :: l) :=
  ⟨λ h, (chain.iff_mem.1 h).imp $ λ a b ⟨h₁, h₂, h₃⟩, ⟨h₁, or.inr h₂, h₃⟩,
   chain'.imp $ λ a b h, h.2.2⟩

@[simp] theorem chain'_nil : chain' R [] := trivial

@[simp] theorem chain'_singleton (a : α) : chain' R [a] := chain.nil

theorem chain'_split {a : α} : ∀ {l₁ l₂ : list α}, chain' R (l₁ ++ a :: l₂) ↔
  chain' R (l₁ ++ [a]) ∧ chain' R (a :: l₂)
| []        l₂ := (and_iff_right (chain'_singleton a)).symm
| (b :: l₁) l₂ := chain_split

theorem chain'_map (f : β → α) {l : list β} :
  chain' R (map f l) ↔ chain' (λ a b : β, R (f a) (f b)) l :=
by cases l; [refl, exact chain_map _]

theorem chain'_of_chain'_map {S : β → β → Prop} (f : α → β)
  (H : ∀ a b : α, S (f a) (f b) → R a b) {l : list α}
  (p : chain' S (map f l)) : chain' R l :=
((chain'_map f).1 p).imp H

theorem chain'_map_of_chain' {S : β → β → Prop} (f : α → β)
  (H : ∀ a b : α, R a b → S (f a) (f b)) {l : list α}
  (p : chain' R l) : chain' S (map f l) :=
(chain'_map f).2 $ p.imp H

theorem pairwise.chain' : ∀ {l : list α}, pairwise R l → chain' R l
| []       _ := trivial
| (a :: l) h := chain_of_pairwise h

theorem chain'_iff_pairwise (tr : transitive R) : ∀ {l : list α},
  chain' R l ↔ pairwise R l
| []       := (iff_true_intro pairwise.nil).symm
| (a :: l) := chain_iff_pairwise tr

@[simp] theorem chain'_cons {x y l} : chain' R (x :: y :: l) ↔ R x y ∧ chain' R (y :: l) :=
chain_cons

theorem chain'.cons {x y l} (h₁ : R x y) (h₂ : chain' R (y :: l)) :
  chain' R (x :: y :: l) :=
chain'_cons.2 ⟨h₁, h₂⟩

theorem chain'.tail : ∀ {l} (h : chain' R l), chain' R l.tail
| []            _ := trivial
| [x]           _ := trivial
| (x :: y :: l) h := (chain'_cons.mp h).right

theorem chain'.rel_head {x y l} (h : chain' R (x :: y :: l)) : R x y :=
rel_of_chain_cons h

theorem chain'.rel_head' {x l} (h : chain' R (x :: l)) ⦃y⦄ (hy : y ∈ head' l) : R x y :=
by { rw ← cons_head'_tail hy at h, exact h.rel_head }

theorem chain'.cons' {x} :
  ∀ {l : list α},  chain' R l → (∀ y ∈ l.head', R x y) → chain' R (x :: l)
| []       _  _ := chain'_singleton x
| (a :: l) hl H := hl.cons $ H _ rfl

theorem chain'_cons' {x l} : chain' R (x :: l) ↔ (∀ y ∈ head' l, R x y) ∧ chain' R l :=
⟨λ h, ⟨h.rel_head', h.tail⟩, λ ⟨h₁, h₂⟩, h₂.cons' h₁⟩

theorem chain'.drop : ∀ (n) {l} (h : chain' R l), chain' R (drop n l)
| 0       _             h := h
| _       []            _ := by {rw drop_nil, exact chain'_nil}
| (n + 1) [a]           _ := by {unfold drop, rw drop_nil, exact chain'_nil}
| (n + 1) (a :: b :: l) h := chain'.drop n (chain'_cons'.mp h).right

theorem chain'.append : ∀ {l₁ l₂ : list α} (h₁ : chain' R l₁) (h₂ : chain' R l₂)
  (h : ∀ (x ∈ l₁.last') (y ∈ l₂.head'), R x y),
  chain' R (l₁ ++ l₂)
| []            l₂ h₁ h₂ h := h₂
| [a]           l₂ h₁ h₂ h := h₂.cons' $ h _ rfl
| (a :: b :: l) l₂ h₁ h₂ h :=
  begin
    simp only [last'] at h,
    have : chain' R (b :: l) := h₁.tail,
    exact (this.append h₂ h).cons h₁.rel_head
  end

theorem chain'_pair {x y} : chain' R [x, y] ↔ R x y :=
by simp only [chain'_singleton, chain'_cons, and_true]

theorem chain'.imp_head {x y} (h : ∀ {z}, R x z → R y z) {l} (hl : chain' R (x :: l)) :
  chain' R (y :: l) :=
hl.tail.cons' $ λ z hz, h $ hl.rel_head' hz

theorem chain'_reverse : ∀ {l}, chain' R (reverse l) ↔ chain' (flip R) l
| []            := iff.rfl
| [a]           := by simp only [chain'_singleton, reverse_singleton]
| (a :: b :: l) := by rw [chain'_cons, reverse_cons, reverse_cons, append_assoc, cons_append,
    nil_append, chain'_split, ← reverse_cons, @chain'_reverse (b :: l), and_comm, chain'_pair, flip]

theorem chain'_iff_nth_le {R} : ∀ {l : list α},
  chain' R l ↔ ∀ i (h : i < length l - 1),
    R (nth_le l i (lt_of_lt_pred h)) (nth_le l (i+1) (lt_pred_iff.mp h))
| []            := by simp
| [a]           := by simp
| (a :: b :: t) :=
begin
  rw [chain'_cons, chain'_iff_nth_le],
  split,
  { rintro ⟨R, h⟩ i w,
    cases i,
    { exact R, },
    { convert h i _ using 1,
      simp only [succ_eq_add_one, add_succ_sub_one, add_zero, length, add_lt_add_iff_right] at w,
      simpa using w, } },
  { rintro h, split,
    { apply h 0, simp, },
    { intros i w, convert h (i+1) _ using 1,
      simp only [add_zero, length, add_succ_sub_one] at w,
      simpa using w, } },
end

/-- If `l₁ l₂` and `l₃` are lists and `l₁ ++ l₂` and `l₂ ++ l₃` both satisfy
  `chain' R`, then so does `l₁ ++ l₂ ++ l₃` provided `l₂ ≠ []` -/
lemma chain'.append_overlap : ∀ {l₁ l₂ l₃ : list α}
  (h₁ : chain' R (l₁ ++ l₂)) (h₂ : chain' R (l₂ ++ l₃)) (hn : l₂ ≠ []),
  chain' R (l₁ ++ l₂ ++ l₃)
| []             l₂        l₃ h₁ h₂ hn := h₂
| l₁             []        l₃ h₁ h₂ hn := (hn rfl).elim
| [a]            (b :: l₂) l₃ h₁ h₂ hn := by { simp at *, tauto }
| (a :: b :: l₁) (c :: l₂) l₃ h₁ h₂ hn := begin
  simp only [cons_append, chain'_cons] at h₁ h₂ ⊢,
  simp only [← cons_append] at h₁ h₂ ⊢,
  exact ⟨h₁.1, chain'.append_overlap h₁.2 h₂ (cons_ne_nil _ _)⟩
end

variables {r : α → α → Prop} {a b : α}
/--
If `a` and `b` are related by the reflexive transitive closure of `r`, then there is a `r`-chain
starting from `a` and ending on `b`.
The converse of `relation_refl_trans_gen_of_exists_chain`.
-/
lemma exists_chain_of_relation_refl_trans_gen (h : relation.refl_trans_gen r a b) :
  ∃ l, chain r a l ∧ last (a :: l) (cons_ne_nil _ _) = b :=
begin
  apply relation.refl_trans_gen.head_induction_on h,
  { exact ⟨[], chain.nil, rfl⟩ },
  { intros c d e t ih,
    obtain ⟨l, hl₁, hl₂⟩ := ih,
    refine ⟨d :: l, chain.cons e hl₁, _⟩,
    rwa last_cons_cons }
end

/--
Given a chain from `a` to `b`, and a predicate true at `b`, if `r x y → p y → p x` then
the predicate is true everywhere in the chain and at `a`.
That is, we can propagate the predicate up the chain.
-/
lemma chain.induction (p : α → Prop)
  (l : list α) (h : chain r a l)
  (hb : last (a :: l) (cons_ne_nil _ _) = b)
  (carries : ∀ ⦃x y : α⦄, r x y → p y → p x) (final : p b) : ∀ i ∈ a :: l, p i :=
begin
  induction l generalizing a,
  { cases hb,
    simp [final] },
  { rw chain_cons at h,
    rintro _ (rfl | _),
    apply carries h.1 (l_ih h.2 hb _ (or.inl rfl)),
    apply l_ih h.2 hb _ H }
end

/--
Given a chain from `a` to `b`, and a predicate true at `b`, if `r x y → p y → p x` then
the predicate is true at `a`.
That is, we can propagate the predicate all the way up the chain.
-/
@[elab_as_eliminator]
lemma chain.induction_head (p : α → Prop)
  (l : list α) (h : chain r a l)
  (hb : last (a :: l) (cons_ne_nil _ _) = b)
  (carries : ∀ ⦃x y : α⦄, r x y → p y → p x) (final : p b) : p a :=
(chain.induction p l h hb carries final) _ (mem_cons_self _ _)

/--
If there is an `r`-chain starting from `a` and ending at `b`, then `a` and `b` are related by the
reflexive transitive closure of `r`. The converse of `exists_chain_of_relation_refl_trans_gen`.
-/
lemma relation_refl_trans_gen_of_exists_chain (l) (hl₁ : chain r a l)
  (hl₂ : last (a :: l) (cons_ne_nil _ _) = b) :
  relation.refl_trans_gen r a b :=
chain.induction_head _ l hl₁ hl₂ (λ x y, relation.refl_trans_gen.head) relation.refl_trans_gen.refl

end list