/-
Copyright (c) 2020 Joseph Myers. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Joseph Myers
-/
import analysis.convex.strict_convex_between
import geometry.euclidean.basic

/-!
# Spheres

This file defines and proves basic results about spheres and cospherical sets of points in
Euclidean affine spaces.

## Main definitions

* `euclidean_geometry.sphere` bundles a `center` and a `radius`.

* `euclidean_geometry.cospherical` is the property of a set of points being equidistant from some
  point.

* `euclidean_geometry.concyclic` is the property of a set of points being cospherical and
  coplanar.

-/

noncomputable theory
open_locale real_inner_product_space

namespace euclidean_geometry

variables {V : Type*} (P : Type*)

open finite_dimensional

/-- A `sphere P` bundles a `center` and `radius`. This definition does not require the radius to
be positive; that should be given as a hypothesis to lemmas that require it. -/
@[ext] structure sphere [metric_space P] :=
(center : P)
(radius : ℝ)

variables {P}

section metric_space
variables [metric_space P]

instance [nonempty P] : nonempty (sphere P) := ⟨⟨classical.arbitrary P, 0⟩⟩

instance : has_coe (sphere P) (set P) := ⟨λ s, metric.sphere s.center s.radius⟩
instance : has_mem P (sphere P) := ⟨λ p s, p ∈ (s : set P)⟩

lemma sphere.mk_center (c : P) (r : ℝ) : (⟨c, r⟩ : sphere P).center = c := rfl

lemma sphere.mk_radius (c : P) (r : ℝ) : (⟨c, r⟩ : sphere P).radius = r := rfl

@[simp] lemma sphere.mk_center_radius (s : sphere P) : (⟨s.center, s.radius⟩ : sphere P) = s :=
by ext; refl

lemma sphere.coe_def (s : sphere P) : (s : set P) = metric.sphere s.center s.radius := rfl

@[simp] lemma sphere.coe_mk (c : P) (r : ℝ) : ↑(⟨c, r⟩ : sphere P) = metric.sphere c r := rfl

@[simp] lemma sphere.mem_coe {p : P} {s : sphere P} : p ∈ (s : set P) ↔ p ∈ s := iff.rfl

lemma mem_sphere {p : P} {s : sphere P} : p ∈ s ↔ dist p s.center = s.radius := iff.rfl

lemma mem_sphere' {p : P} {s : sphere P} : p ∈ s ↔ dist s.center p = s.radius :=
metric.mem_sphere'

lemma subset_sphere {ps : set P} {s : sphere P} : ps ⊆ s ↔ ∀ p ∈ ps, p ∈ s := iff.rfl

lemma dist_of_mem_subset_sphere {p : P} {ps : set P} {s : sphere P} (hp : p ∈ ps)
  (hps : ps ⊆ (s : set P)) : dist p s.center = s.radius :=
mem_sphere.1 (sphere.mem_coe.1 (set.mem_of_mem_of_subset hp hps))

lemma dist_of_mem_subset_mk_sphere {p c : P} {ps : set P} {r : ℝ} (hp : p ∈ ps)
  (hps : ps ⊆ ↑(⟨c, r⟩ : sphere P)) : dist p c = r :=
dist_of_mem_subset_sphere hp hps

lemma sphere.ne_iff {s₁ s₂ : sphere P} :
  s₁ ≠ s₂ ↔ s₁.center ≠ s₂.center ∨ s₁.radius ≠ s₂.radius :=
by rw [←not_and_distrib, ←sphere.ext_iff]

lemma sphere.center_eq_iff_eq_of_mem {s₁ s₂ : sphere P} {p : P} (hs₁ : p ∈ s₁) (hs₂ : p ∈ s₂) :
  s₁.center = s₂.center ↔ s₁ = s₂ :=
begin
  refine ⟨λ h, sphere.ext _ _ h _, λ h, h ▸ rfl⟩,
  rw mem_sphere at hs₁ hs₂,
  rw [←hs₁, ←hs₂, h]
end

lemma sphere.center_ne_iff_ne_of_mem {s₁ s₂ : sphere P} {p : P} (hs₁ : p ∈ s₁) (hs₂ : p ∈ s₂) :
  s₁.center ≠ s₂.center ↔ s₁ ≠ s₂ :=
(sphere.center_eq_iff_eq_of_mem hs₁ hs₂).not

lemma dist_center_eq_dist_center_of_mem_sphere {p₁ p₂ : P} {s : sphere P} (hp₁ : p₁ ∈ s)
  (hp₂ : p₂ ∈ s) : dist p₁ s.center = dist p₂ s.center :=
by rw [mem_sphere.1 hp₁, mem_sphere.1 hp₂]

lemma dist_center_eq_dist_center_of_mem_sphere' {p₁ p₂ : P} {s : sphere P} (hp₁ : p₁ ∈ s)
  (hp₂ : p₂ ∈ s) : dist s.center p₁ = dist s.center p₂ :=
by rw [mem_sphere'.1 hp₁, mem_sphere'.1 hp₂]

/-- A set of points is cospherical if they are equidistant from some
point.  In two dimensions, this is the same thing as being
concyclic. -/
def cospherical (ps : set P) : Prop :=
∃ (center : P) (radius : ℝ), ∀ p ∈ ps, dist p center = radius

/-- The definition of `cospherical`. -/
lemma cospherical_def (ps : set P) :
  cospherical ps ↔ ∃ (center : P) (radius : ℝ), ∀ p ∈ ps, dist p center = radius :=
iff.rfl

/-- A set of points is cospherical if and only if they lie in some sphere. -/
lemma cospherical_iff_exists_sphere {ps : set P} :
  cospherical ps ↔ ∃ s : sphere P, ps ⊆ (s : set P) :=
begin
  refine ⟨λ h, _, λ h, _⟩,
  { rcases h with ⟨c, r, h⟩,
    exact ⟨⟨c, r⟩, h⟩ },
  { rcases h with ⟨s, h⟩,
    exact ⟨s.center, s.radius, h⟩ }
end

/-- The set of points in a sphere is cospherical. -/

/-- A subset of a cospherical set is cospherical. -/
lemma cospherical.subset {ps₁ ps₂ : set P} (hs : ps₁ ⊆ ps₂) (hc : cospherical ps₂) :
  cospherical ps₁ :=
begin
  rcases hc with ⟨c, r, hcr⟩,
  exact ⟨c, r, λ p hp, hcr p (hs hp)⟩
end

/-- The empty set is cospherical. -/
lemma cospherical_empty [nonempty P] : cospherical (∅ : set P) :=
let ⟨p⟩ := ‹nonempty P› in ⟨p, 0, λ p, false.elim⟩

/-- A single point is cospherical. -/
lemma cospherical_singleton (p : P) : cospherical ({p} : set P) :=
begin
  use p,
  simp
end

end metric_space

section normed_space
variables [normed_add_comm_group V] [normed_space ℝ V] [metric_space P] [normed_add_torsor V P]
include V

/-- Two points are cospherical. -/
lemma cospherical_pair (p₁ p₂ : P) : cospherical ({p₁, p₂} : set P) :=
⟨midpoint ℝ p₁ p₂, ‖(2 : ℝ)‖⁻¹ * dist p₁ p₂, begin
  rintros p (rfl | rfl | _),
  { rw [dist_comm, dist_midpoint_left] },
  { rw [dist_comm, dist_midpoint_right] }
end⟩

/-- A set of points is concyclic if it is cospherical and coplanar. (Most results are stated
directly in terms of `cospherical` instead of using `concyclic`.) -/
structure concyclic (ps : set P) : Prop :=
(cospherical : cospherical ps)
(coplanar : coplanar ℝ ps)

/-- A subset of a concyclic set is concyclic. -/
lemma concyclic.subset {ps₁ ps₂ : set P} (hs : ps₁ ⊆ ps₂) (h : concyclic ps₂) : concyclic ps₁ :=
⟨h.1.subset hs, h.2.subset hs⟩

/-- The empty set is concyclic. -/
lemma concyclic_empty : concyclic (∅ : set P) :=
⟨cospherical_empty, coplanar_empty ℝ P⟩

/-- A single point is concyclic. -/
lemma concyclic_singleton (p : P) : concyclic ({p} : set P) :=
⟨cospherical_singleton p, coplanar_singleton ℝ p⟩

/-- Two points are concyclic. -/
lemma concyclic_pair (p₁ p₂ : P) : concyclic ({p₁, p₂} : set P) :=
⟨cospherical_pair p₁ p₂, coplanar_pair ℝ p₁ p₂⟩

end normed_space

section euclidean_space
variables
  [normed_add_comm_group V] [inner_product_space ℝ V] [metric_space P] [normed_add_torsor V P]
include V

/-- Any three points in a cospherical set are affinely independent. -/
lemma cospherical.affine_independent {s : set P} (hs : cospherical s) {p : fin 3 → P}
  (hps : set.range p ⊆ s) (hpi : function.injective p) :
  affine_independent ℝ p :=
begin
  rw affine_independent_iff_not_collinear,
  intro hc,
  rw collinear_iff_of_mem (set.mem_range_self (0 : fin 3)) at hc,
  rcases hc with ⟨v, hv⟩,
  rw set.forall_range_iff at hv,
  have hv0 : v ≠ 0,
  { intro h,
    have he : p 1 = p 0, by simpa [h] using hv 1,
    exact (dec_trivial : (1 : fin 3) ≠ 0) (hpi he) },
  rcases hs with ⟨c, r, hs⟩,
  have hs' := λ i, hs (p i) (set.mem_of_mem_of_subset (set.mem_range_self _) hps),
  choose f hf using hv,
  have hsd : ∀ i, dist ((f i • v) +ᵥ p 0) c = r,
  { intro i,
    rw ←hf,
    exact hs' i },
  have hf0 : f 0 = 0,
  { have hf0' := hf 0,
    rw [eq_comm, ←@vsub_eq_zero_iff_eq V, vadd_vsub, smul_eq_zero] at hf0',
    simpa [hv0] using hf0' },
  have hfi : function.injective f,
  { intros i j h,
    have hi := hf i,
    rw [h, ←hf j] at hi,
    exact hpi hi },
  simp_rw [←hsd 0, hf0, zero_smul, zero_vadd, dist_smul_vadd_eq_dist (p 0) c hv0] at hsd,
  have hfn0 : ∀ i, i ≠ 0 → f i ≠ 0 := λ i, (hfi.ne_iff' hf0).2,
  have hfn0' : ∀ i, i ≠ 0 → f i = (-2) * ⟪v, (p 0 -ᵥ c)⟫ / ⟪v, v⟫,
  { intros i hi,
    have hsdi := hsd i,
    simpa [hfn0, hi] using hsdi },
  have hf12 : f 1 = f 2, { rw [hfn0' 1 dec_trivial, hfn0' 2 dec_trivial] },
  exact (dec_trivial : (1 : fin 3) ≠ 2) (hfi hf12)
end

/-- Any three points in a cospherical set are affinely independent. -/
lemma cospherical.affine_independent_of_mem_of_ne {s : set P} (hs : cospherical s) {p₁ p₂ p₃ : P}
  (h₁ : p₁ ∈ s) (h₂ : p₂ ∈ s) (h₃ : p₃ ∈ s) (h₁₂ : p₁ ≠ p₂) (h₁₃ : p₁ ≠ p₃) (h₂₃ : p₂ ≠ p₃) :
  affine_independent ℝ ![p₁, p₂, p₃] :=
begin
  refine hs.affine_independent _ _,
  { simp [h₁, h₂, h₃, set.insert_subset] },
  { erw [fin.cons_injective_iff, fin.cons_injective_iff],
    simp [h₁₂, h₁₃, h₂₃, function.injective] }
end

/-- The three points of a cospherical set are affinely independent. -/
lemma cospherical.affine_independent_of_ne {p₁ p₂ p₃ : P} (hs : cospherical ({p₁, p₂, p₃} : set P))
  (h₁₂ : p₁ ≠ p₂) (h₁₃ : p₁ ≠ p₃) (h₂₃ : p₂ ≠ p₃) :
  affine_independent ℝ ![p₁, p₂, p₃] :=
hs.affine_independent_of_mem_of_ne (set.mem_insert _ _)
  (set.mem_insert_of_mem _ (set.mem_insert _ _))
  (set.mem_insert_of_mem _ (set.mem_insert_of_mem _ (set.mem_singleton _))) h₁₂ h₁₃ h₂₃

/-- Suppose that `p₁` and `p₂` lie in spheres `s₁` and `s₂`.  Then the vector between the centers
of those spheres is orthogonal to that between `p₁` and `p₂`; this is a version of
`inner_vsub_vsub_of_dist_eq_of_dist_eq` for bundled spheres.  (In two dimensions, this says that
the diagonals of a kite are orthogonal.) -/
lemma inner_vsub_vsub_of_mem_sphere_of_mem_sphere {p₁ p₂ : P} {s₁ s₂ : sphere P}
  (hp₁s₁ : p₁ ∈ s₁) (hp₂s₁ : p₂ ∈ s₁) (hp₁s₂ : p₁ ∈ s₂) (hp₂s₂ : p₂ ∈ s₂) :
  ⟪s₂.center -ᵥ s₁.center, p₂ -ᵥ p₁⟫ = 0 :=
inner_vsub_vsub_of_dist_eq_of_dist_eq (dist_center_eq_dist_center_of_mem_sphere hp₁s₁ hp₂s₁)
                                      (dist_center_eq_dist_center_of_mem_sphere hp₁s₂ hp₂s₂)

/-- Two spheres intersect in at most two points in a two-dimensional subspace containing their
centers; this is a version of `eq_of_dist_eq_of_dist_eq_of_mem_of_finrank_eq_two` for bundled
spheres. -/
lemma eq_of_mem_sphere_of_mem_sphere_of_mem_of_finrank_eq_two {s : affine_subspace ℝ P}
  [finite_dimensional ℝ s.direction] (hd : finrank ℝ s.direction = 2) {s₁ s₂ : sphere P}
  {p₁ p₂ p : P} (hs₁ : s₁.center ∈ s) (hs₂ : s₂.center ∈ s) (hp₁s : p₁ ∈ s) (hp₂s : p₂ ∈ s)
  (hps : p ∈ s) (hs : s₁ ≠ s₂) (hp : p₁ ≠ p₂) (hp₁s₁ : p₁ ∈ s₁) (hp₂s₁ : p₂ ∈ s₁) (hps₁ : p ∈ s₁)
  (hp₁s₂ : p₁ ∈ s₂) (hp₂s₂ : p₂ ∈ s₂) (hps₂ : p ∈ s₂) : p = p₁ ∨ p = p₂ :=
eq_of_dist_eq_of_dist_eq_of_mem_of_finrank_eq_two hd hs₁ hs₂ hp₁s hp₂s hps
  ((sphere.center_ne_iff_ne_of_mem hps₁ hps₂).2 hs) hp hp₁s₁ hp₂s₁ hps₁ hp₁s₂ hp₂s₂ hps₂

/-- Two spheres intersect in at most two points in two-dimensional space; this is a version of
`eq_of_dist_eq_of_dist_eq_of_finrank_eq_two` for bundled spheres. -/
lemma eq_of_mem_sphere_of_mem_sphere_of_finrank_eq_two [finite_dimensional ℝ V]
  (hd : finrank ℝ V = 2) {s₁ s₂ : sphere P} {p₁ p₂ p : P} (hs : s₁ ≠ s₂) (hp : p₁ ≠ p₂)
  (hp₁s₁ : p₁ ∈ s₁) (hp₂s₁ : p₂ ∈ s₁) (hps₁ : p ∈ s₁) (hp₁s₂ : p₁ ∈ s₂) (hp₂s₂ : p₂ ∈ s₂)
  (hps₂ : p ∈ s₂) : p = p₁ ∨ p = p₂ :=
eq_of_dist_eq_of_dist_eq_of_finrank_eq_two hd ((sphere.center_ne_iff_ne_of_mem hps₁ hps₂).2 hs)
  hp hp₁s₁ hp₂s₁ hps₁ hp₁s₂ hp₂s₂ hps₂

/-- Given a point on a sphere and a point not outside it, the inner product between the
difference of those points and the radius vector is positive unless the points are equal. -/
lemma inner_pos_or_eq_of_dist_le_radius {s : sphere P} {p₁ p₂ : P} (hp₁ : p₁ ∈ s)
  (hp₂ : dist p₂ s.center ≤ s.radius) : 0 < ⟪p₁ -ᵥ p₂, p₁ -ᵥ s.center⟫ ∨ p₁ = p₂ :=
begin
  by_cases h : p₁ = p₂, { exact or.inr h },
  refine or.inl _,
  rw mem_sphere at hp₁,
  rw [←vsub_sub_vsub_cancel_right p₁ p₂ s.center, inner_sub_left,
      real_inner_self_eq_norm_mul_norm/-, ←dist_eq_norm_vsub, hp₁-/, sub_pos],
  refine lt_of_le_of_ne
    ((real_inner_le_norm _ _).trans (mul_le_mul_of_nonneg_right _ (norm_nonneg _)))
    _,
  { rwa [←dist_eq_norm_vsub, ←dist_eq_norm_vsub, hp₁] },
  { rcases hp₂.lt_or_eq with hp₂' | hp₂',
    { refine ((real_inner_le_norm _ _).trans_lt (mul_lt_mul_of_pos_right _ _)).ne,
      { rwa [←hp₁, @dist_eq_norm_vsub V, @dist_eq_norm_vsub V] at hp₂' },
      { rw [norm_pos_iff, vsub_ne_zero],
        rintro rfl,
        rw ←hp₁ at hp₂',
        refine (dist_nonneg.not_lt : ¬dist p₂ s.center < 0) _,
        simpa using hp₂' } },
    { rw [←hp₁, @dist_eq_norm_vsub V, @dist_eq_norm_vsub V] at hp₂',
      nth_rewrite 0 ←hp₂',
      rw [ne.def, inner_eq_norm_mul_iff_real, hp₂', ←sub_eq_zero, ←smul_sub,
          vsub_sub_vsub_cancel_right, ←ne.def, smul_ne_zero_iff, vsub_ne_zero,
          and_iff_left (ne.symm h), norm_ne_zero_iff, vsub_ne_zero],
      rintro rfl,
      refine h (eq.symm _),
      simpa using hp₂' } }
end

/-- Given a point on a sphere and a point not outside it, the inner product between the
difference of those points and the radius vector is nonnegative. -/
lemma inner_nonneg_of_dist_le_radius {s : sphere P} {p₁ p₂ : P} (hp₁ : p₁ ∈ s)
  (hp₂ : dist p₂ s.center ≤ s.radius) : 0 ≤ ⟪p₁ -ᵥ p₂, p₁ -ᵥ s.center⟫ :=
begin
  rcases inner_pos_or_eq_of_dist_le_radius hp₁ hp₂ with h | rfl,
  { exact h.le },
  { simp }
end

/-- Given a point on a sphere and a point inside it, the inner product between the difference of
those points and the radius vector is positive. -/
lemma inner_pos_of_dist_lt_radius {s : sphere P} {p₁ p₂ : P} (hp₁ : p₁ ∈ s)
  (hp₂ : dist p₂ s.center < s.radius) : 0 < ⟪p₁ -ᵥ p₂, p₁ -ᵥ s.center⟫ :=
begin
  by_cases h : p₁ = p₂,
  { rw [h, mem_sphere] at hp₁,
    exact false.elim (hp₂.ne hp₁) },
  exact (inner_pos_or_eq_of_dist_le_radius hp₁ hp₂.le).resolve_right h
end

/-- Given three collinear points, two on a sphere and one not outside it, the one not outside it
is weakly between the other two points. -/
lemma wbtw_of_collinear_of_dist_center_le_radius {s : sphere P} {p₁ p₂ p₃ : P}
  (h : collinear ℝ ({p₁, p₂, p₃} : set P)) (hp₁ : p₁ ∈ s) (hp₂ : dist p₂ s.center ≤ s.radius)
  (hp₃ : p₃ ∈ s) (hp₁p₃ : p₁ ≠ p₃) : wbtw ℝ p₁ p₂ p₃ :=
h.wbtw_of_dist_eq_of_dist_le hp₁ hp₂ hp₃ hp₁p₃

/-- Given three collinear points, two on a sphere and one inside it, the one inside it is
strictly between the other two points. -/
lemma sbtw_of_collinear_of_dist_center_lt_radius {s : sphere P} {p₁ p₂ p₃ : P}
  (h : collinear ℝ ({p₁, p₂, p₃} : set P)) (hp₁ : p₁ ∈ s) (hp₂ : dist p₂ s.center < s.radius)
  (hp₃ : p₃ ∈ s) (hp₁p₃ : p₁ ≠ p₃) : sbtw ℝ p₁ p₂ p₃ :=
h.sbtw_of_dist_eq_of_dist_lt hp₁ hp₂ hp₃ hp₁p₃

end euclidean_space

end euclidean_geometry


import algebra.big_operators
import data.finset.slice
import data.rat
import tactic

open finset nat
open_locale big_operators

namespace finset
namespace bbsetpair2
--Bollobas set pair theorem
--A and B are the families of finite sets indexed by I
--sp is the condition the family satisfies
--spi is a shortcut for disjoint-ness  of A i and B i
--U is the universe of elements in any of the sets
-- it has size u
@[ext] structure setpair :=
  (A : ℕ → finset ℕ) (B : ℕ → finset ℕ) (I : finset ℕ)
  (sp : ∀i∈ I,∀j∈ I, ((A i)∩(B j)).nonempty ↔ i ≠ j)
  (spi : ∀i∈ I, disjoint (A i) (B i))
  (U : finset ℕ) (Ug : U = I.bUnion(λ i, (A i) ∪ (B i )))
  (u : ℕ) (ug: u= card U)
 --- we take the trivial system with I=∅
instance  : inhabited setpair :={
default:= {A:=λ _,∅, B:=λ _,∅,I:=∅,
sp:=begin tauto, end,
spi:=begin tauto, end,
U:=∅, Ug:=begin tauto, end,
u:=0, ug:=begin tauto,end,}}
-- density of a setpair system
@[simp]def den (S : setpair) :ℚ := ∑ i in S.I, ((1 : ℚ)/(card(S.A i)+card(S.B i)).choose (card (S.B i)))
-- helper - if A i and B j are disjoint then i=j
lemma sp' {S : setpair} {i j : ℕ}: i∈ S.I → j∈S.I → (disjoint (S.A i) (S.B j) → i = j):=
begin
  intros hi hj hd,
  by_contra,
  have ne: ((S.A i)∩(S.B j)).nonempty,
    apply (S.sp i hi j hj).mpr h,
    rw disjoint_iff_inter_eq_empty at hd,
    simp only [ * , not_nonempty_empty] at *,
end

-- the erase constructor - gives a new setpair without element x
-- we discard all i such that B i contains x and then erase x from any A i containing x
@[simp]def er  (S : setpair) (x : ℕ) : setpair :={
  A:=λ  n, erase (S.A n) x,
  B:=S.B,
  I:=S.I.filter(λi, x∉(S.B i)),
  sp:=begin
    intros i  hi j  hj,
    rw [mem_filter] at *,
    suffices same: ((S.A i).erase x ∩ S.B j) = (S.A i) ∩ (S.B j),{
      rw same, exact S.sp i hi.1 j hj.1,}, cases hj, cases hi, dsimp at *,
      ext1, simp only [mem_inter, mem_erase, ne.def, and.congr_left_iff, and_iff_right_iff_imp] at *,
      intros m n p, cases p,solve_by_elim,
  end,
  U:= (S.I.filter(λi, x∉(S.B i))).bUnion(λ i, (((S.A i).erase x) ∪ (S.B i ))),
  Ug:=rfl,
  u:=card((S.I.filter(λi, x∉(S.B i))).bUnion(λ i, (((S.A i).erase x) ∪ (S.B i )))),
  ug:=rfl,
  spi:=begin
    intros i hi,
    rw [mem_filter] at *,
    apply disjoint_of_subset_left _ (S.spi i hi.1), apply erase_subset _,end,
}

--- the sets are in the universe...
lemma univ_ss {S : setpair} {i : ℕ} : i ∈ S.I → (S.A i ∪ S.B i)⊆ S.U:=
begin
  intro hi, intros x, rw [setpair.Ug,mem_bUnion],tauto,
end
-- applying er y gives a smaller universe if y was in the universe.
lemma er_univ_lt (S : setpair) {y : ℕ} : y ∈ S.U → (er S y).u < S.u :=
begin
  intro hy,
  have ss: (er S y).U ⊆ S.U,{
    simp [er,S.Ug], intros i hi hy, intros x hx, rw [mem_bUnion], use i ,
    split, exact hi, rw [mem_union] at *, cases hx with ha hb,
    left, apply mem_of_mem_erase ha,right, exact hb,},
  have ey: y∉ (er S y).U, {simp [er,S.Ug]},
  simp [setpair.ug],
  apply card_lt_card,
  apply  (ssubset_iff_of_subset ss).mpr _,
  use [y, hy, ey],
end

-- pairs are disjoint so sizes add.
lemma card_pair {S : setpair} {i : ℕ} : i  ∈ S.I → card((S.A i ∪ S.B i)) = card(S.A i) + card(S.B i):=λ hi, card_union_eq (S.spi i hi)
-- U is partitioned into each pair and their complement
lemma card_U {S :setpair} {i : ℕ} : i ∈ S.I → card(S.U\(S.A i ∪ S.B i)) + card(S.A i) + card(S.B i) = card(S.U):=
begin
  intros hi, rw [add_assoc, ← card_pair hi],
  apply card_sdiff_add_card_eq_card (univ_ss hi),
end

lemma card_Udiv (S :setpair) :∀i∈ S.I, ((card(S.A i) + card(S.B i)).choose (card(S.B i)):ℚ)⁻¹*(card S.U)=
((card(S.A i) + card(S.B i)).choose (card (S.B i)):ℚ)⁻¹*((card(S.U\(S.A i ∪ S.B i)) + card(S.A i) + card(S.B i))) :=
begin
  intros i hi, rw ← card_U hi, norm_cast,
end

--- want to work mainly with non-trivial setpairs so assume ever A i is non-empty
def triv_sp (S : setpair) : Prop := (∃i∈S.I, card(S.A i) =0)
--- trivial sp has at most one pair.
lemma triv_imp_I1 {S :setpair} (h: triv_sp S) : card S.I ≤ 1:=
begin
  by_contra h',
    obtain ⟨a,ha,b,hb,ne⟩:=one_lt_card.mp (by linarith: 1< S.I.card),
    obtain ⟨x,hx⟩:=(S.sp a ha b hb).mpr ne,
    obtain ⟨i,h⟩:=h,
    rw card_eq_zero at h,
    cases h with hi hie,
    rw mem_inter at hx,
    have ia: i=a, {
      apply sp' hi ha  _, rw hie, simp only [disjoint_empty_left],
    },
    have ib: i=b, {
      apply sp' hi hb  _, rw hie, simp only [disjoint_empty_left],
    },
    rw [←ia,←ib] at ne, tauto,
end

-- non-trivial means each A i is non-empty so has at least one element
lemma ntriv_sp {S : setpair} (ht: ¬triv_sp S): ∀i∈S.I, 1 ≤ card(S.A i):=
begin
  rw triv_sp at ht,push_neg at ht, intros i hi,
  exact one_le_iff_ne_zero.mpr  (ht i hi),
end

-- making the casting of the densities slightly less painful
lemma binhelp {a b c d: ℕ } (h: (a+b)*c=d*a) (hc: 0 < c) (hd: 0 < d): (↑d:ℚ)⁻¹*(a+b)=(↑c:ℚ)⁻¹*a:=
begin
  have qh:((a:ℚ)+(b:ℚ))*(c:ℚ)=(d:ℚ)*(a:ℚ), norm_cast, exact h,
  have dnz: (d:ℚ)≠ 0,
  { simp only [ne.def, cast_eq_zero],  linarith,  },
  have cnz: (c:ℚ)≠ 0,
  { simp only [ne.def, cast_eq_zero],  linarith,  },
   rw ← div_eq_inv_mul,rw ← div_eq_inv_mul,
   rw div_eq_iff dnz, rw mul_comm, rw mul_div,
    rw mul_comm,
    symmetry,
    rw  div_eq_iff cnz, symmetry, rw mul_comm (↑a), exact qh,
end

-- the key fact we need for binomials -- really should have done this in the nats.
lemma binom_frac (a b : ℕ) (h:0 < a) :((a+b).choose(b):ℚ)⁻¹*(a+b)=((a-1+b).choose(b):ℚ)⁻¹*a:=
begin
  have a1: a= (a -1).succ,{
    rw succ_eq_add_one, linarith,},
  have ab: a+b= (a-1+b).succ,{
    rw [succ_eq_add_one, add_assoc,add_comm b 1,← add_assoc,←succ_eq_add_one,← a1],},
  have ch: (a-1+b).succ* (a-1+b).choose (a-1)= (a-1+b).succ.choose((a-1).succ)*((a-1).succ),
  apply succ_mul_choose_eq (a-1+b) (a-1),
  rw [←ab,← a1] at ch,
  have abn: (a-1+b)-(a-1)=b:=add_tsub_cancel_left (a-1) b,
  have abs : a+b-a=b:=add_tsub_cancel_left a b,
  have aln: a-1 ≤ a-1+b:=(by linarith),
  have aln2: a≤ a+b:=(by linarith),
  have f1:  (a-1+b).choose((a-1+b)-(a-1))=(a-1+b).choose(a-1):=choose_symm aln,
  rw abn at f1,
  have f2:  (a+b).choose(a+b-a)=(a+b).choose(a):=choose_symm aln2,
  rw abs at f2,
  rw [←f1, ← f2] at ch,
 -- clear_except ch,
  rw [mul_comm],
  norm_cast,
  rw [mul_comm], simp [ch],
  have ap :(a-1+b).choose b > 0,{
    apply choose_pos (by linarith: b≤ a-1+b),
  },
  have bp:(a+b).choose b >0,{
    apply choose_pos (by linarith:b≤a+b),},
  apply binhelp ch ap bp,
end

lemma den_rhs_1   {S : setpair} : ∑ i in S.I, ((card(S.A i) + card(S.B i)).choose (card (S.B i)):ℚ)⁻¹*card(S.U\(S.A i ∪ S.B i)) +
∑ i in S.I, ((card(S.A i) + card(S.B i)).choose (card (S.B i)):ℚ)⁻¹*(card(S.A i) + card(S.B i))
= den S * S.u :=
begin
  simp only [den, one_div], rw [setpair.ug],rw sum_mul, rw ← sum_add_distrib,
  apply sum_congr _ _, refl,
  intros i hi, rw ← mul_add, norm_cast, rw ← add_assoc,
  convert card_Udiv S i hi, exact card_U hi, norm_cast, exact (card_U hi).symm,
end

lemma den_rhs_2   {S : setpair} (ht: ¬triv_sp S) : ∑ i in S.I, ((card(S.A i) + card(S.B i)).choose (card (S.B i)):ℚ)⁻¹*(card(S.A i) + card(S.B i)) =
∑ i in S.I, ((card(S.A i)-1 + card(S.B i)).choose (card (S.B i)):ℚ)⁻¹*(card(S.A i))
 :=
begin
  apply sum_congr _ _, refl,
  intros i hi, rw binom_frac _ _ ((ntriv_sp ht) i hi),
end

lemma den_help_1 {S : setpair}  : ∀i, ∀y∈(S.U\((S.A i)∪(S.B i))), (S.A i).card +(S.B i).card = ((S.A i).erase y).card + (S.B i).card:=
begin
  intros i  y hy, simp only [add_left_inj], rw card_erase_eq_ite,split_ifs,
  simp only [*, mem_sdiff, mem_union, true_or, not_true, and_false] at *,
end

lemma den_help_2 {S : setpair}  : ∀i, ∀y∈(S.A i), (S.A i).card - 1 +(S.B i).card = ((S.A i).erase y).card + (S.B i).card:=
begin
  intros i  y hy, simp only [add_left_inj], rw card_erase_of_mem hy,
end

lemma den_rhs_3 {S : setpair}  : ∀ i∈S.I , ((card(S.A i) + card(S.B i)).choose (card (S.B i)):ℚ)⁻¹*(card(S.U\((S.A i)∪(S.B i)))) =
∑y in (S.U\((S.A i)∪(S.B i))), ((((S.A i).erase y).card + card(S.B i)).choose ((S.B i).card):ℚ)⁻¹:=
begin
  intros i hi, rw card_eq_sum_ones (S.U\((S.A i)∪(S.B i))),
  push_cast, rw zero_add, rw mul_sum, rw mul_one,
  rw sum_congr _ _, refl,
  intros y hy,rw (den_help_1  i  y hy),
end

lemma den_rhs_4 {S : setpair}  : ∀ i∈S.I , ((card(S.A i) - 1 + card(S.B i)).choose (card (S.B i)):ℚ)⁻¹*(card(S.A i)) =
∑y in (S.A i), ((((S.A i).erase y).card + card(S.B i)).choose ((S.B i).card):ℚ)⁻¹:=
begin
  intros i hi, nth_rewrite 1  card_eq_sum_ones (S.A i),
  push_cast, rw zero_add, rw mul_sum, rw mul_one,
  rw sum_congr _ _, refl,
  intros y hy,rw (den_help_2  i y hy),
end

lemma den_rhs_5 {S : setpair}  : ∑ i in S.I , ((card(S.A i) + card(S.B i)).choose (card (S.B i)):ℚ)⁻¹*(card(S.U\((S.A i)∪(S.B i)))) =
 ∑ i in S.I, (∑y in (S.U\((S.A i)∪(S.B i))), ((((S.A i).erase y).card + card(S.B i)).choose ((S.B i).card):ℚ)⁻¹):=
begin
  apply  sum_congr (rfl) (den_rhs_3),
end

lemma den_rhs_6 {S : setpair} : ∑ i in S.I, ((card(S.A i) - 1 + card(S.B i)).choose (card (S.B i)):ℚ)⁻¹*(card(S.A i)) =
∑ i in S.I, (∑y in (S.A i), ((((S.A i).erase y).card + card(S.B i)).choose ((S.B i).card):ℚ)⁻¹):=
begin
  apply  sum_congr (rfl) (den_rhs_4),
end

lemma disj_den {S : setpair}  : ∀i, disjoint (S.U\((S.A i)∪(S.B i))) (S.A i):=
begin
  intros i,
  apply disjoint_of_subset_right (subset_union_left (S.A i) (S.B i)),
  exact sdiff_disjoint,
end

lemma sp_sdiff (S : setpair) : ∀i∈S.I, (S.U\((S.A i)∪(S.B i)))∪ (S.A i) = (S.U\(S.B i)) :=
begin
  intros i hi,
  have he: (S.A i)∪ (S.B i)⊆ S.U:=univ_ss hi,
  have heA: (S.A i)⊆ S.U:=subset_trans (subset_union_left (S.A i) (S.B i)) he,
  have ab: disjoint (S.A i) (S.B i):=S.spi i hi,
  rw sdiff_union_distrib, ext x,split, simp only [mem_union, mem_inter, mem_sdiff] at *,
  intro h,
  rcases h, exact h.2, split, exact heA h, intro hb,
  exact  ab (mem_inter.mpr ⟨h,hb⟩),
  intros h, rw [mem_union,mem_inter,mem_sdiff],
  by_cases hA: x∈ (S.A i) ,
    right, exact hA, left,split, simp only [*, mem_sdiff, not_false_iff, and_self] at *, exact h,
end

lemma den_rhs_7 {S : setpair} : ∀i∈ S.I, (∑y in (S.U\((S.A i)∪(S.B i))), ((((S.A i).erase y).card + card(S.B i)).choose ((S.B i).card):ℚ)⁻¹)
+(∑y in (S.A i), ((((S.A i).erase y).card + card(S.B i)).choose ((S.B i).card):ℚ)⁻¹)=(∑y in (S.U\(S.B i)), ((((S.A i).erase y).card + card(S.B i)).choose ((S.B i).card):ℚ)⁻¹)
:=
begin
  intros i hi, rw [← sp_sdiff S i hi, sum_union (disj_den i )],
end

lemma den_rhs_8 {S : setpair}  : ∑ i in S.I, ((∑y in (S.U\((S.A i)∪(S.B i))), ((((S.A i).erase y).card + card(S.B i)).choose ((S.B i).card):ℚ)⁻¹)
+(∑y in (S.A i), ((((S.A i).erase y).card + card(S.B i)).choose ((S.B i).card):ℚ)⁻¹))=∑ i in S.I,(∑y in (S.U\(S.B i)), ((((S.A i).erase y).card + card(S.B i)).choose ((S.B i).card):ℚ)⁻¹)
:=
begin
   apply sum_congr (rfl) (den_rhs_7),
end

lemma doublecount {A B : finset ℕ} {f: ℕ → ℕ → ℚ}  {p: ℕ → ℕ → Prop} [decidable_rel p] :
 ∑ a in A, ∑ b in filter (λ i , p a i) B, f a b = ∑ b in B, ∑ a in filter (λ i, p i b) A, f a b:=
begin
  have inL: ∀a∈A,∑ b in filter (λ i, p a i) B, (f a b)= ∑ b in B, ite (p a b) (f a b) 0,{
      intros a ha, rw sum_filter,},
  have inL2: ∑a in A, ∑ b in filter (λ i, p a i) B, (f a b)= ∑ a in A, ∑ b in B, ite (p a b) (f a b) 0, {
      apply sum_congr, refl, exact inL,},
  have inR: ∀b∈B,∑ a in filter (λ i, p i b) A, (f a b)= ∑ a in A, ite (p a b) (f a b) 0,{
    intros b hb, rw sum_filter,},
  have inR2: ∑b in B, ∑ a in filter (λ i, p i b) A, (f a b)= ∑ b in B, ∑ a in A, ite (p a b) (f a b) 0, {
      apply sum_congr, refl, exact inR,},
  rw [inL2,inR2,sum_comm],
end

lemma doublecount' {A B : finset ℕ} {f g: ℕ → ℕ → ℚ} {a b : ℕ} {p: ℕ → ℕ → Prop} [decidable_rel p] : (∀a∈ A,∀b∈B , p a b → f a b = g a b)
 → ∑ a in A, ∑ b in filter (λ i , p a i) B, f a b = ∑ b in B, ∑ a in filter (λ i, p i b) A, g a b:=
begin
  intros h, rw doublecount, apply sum_congr, refl, intros b hb, apply sum_congr, refl,
  intro x, rw mem_filter, intro ha, exact h x ha.1 b hb ha.2,
end

lemma dc_4 {S : setpair} {f: ℕ → ℕ → ℚ} : ∑ i in S.I, ∑ y in S.U\(S.B i), f y i = ∑ i in S.I, ∑ y in filter (λ x, x∉(S.B i)) S.U, f y i:=
begin
  have H: ∀ i∈S.I, S.U\S.B i = filter (λ x, x∉ S.B i) S.U,{
    intros i hi, ext x,rw [mem_sdiff,mem_filter],},
  have H1: ∀ i∈S.I,∑ y in S.U\(S.B i), f y i =  ∑ y in filter (λ x, x∉(S.B i)) S.U, f y i,{
    intros i hi, apply sum_congr , exact H i hi, intros x hx,refl,},
    apply sum_congr, refl,exact H1,
end

lemma den_double {S : setpair} (ht: ¬triv_sp S) : (∑  y in S.U, den (er S y))= den S * S.u  :=
begin
  rw ← den_rhs_1,  simp only [den, er, one_div],
  rw [den_rhs_2 ht, den_rhs_5 , den_rhs_6 , ←  sum_add_distrib],
  rw [den_rhs_8,dc_4,doublecount],
end

lemma trival_mem {S : setpair} (h: ∃i∈S.I, (S.A i) = ∅) : card S.I ≤ 1 :=
begin
  by_contra h',
  obtain ⟨a,ha,b,hb,ne⟩:=one_lt_card.mp (by linarith: 1< S.I.card),
  obtain ⟨x,hx⟩:=(S.sp a ha b hb).mpr ne,
  obtain ⟨i, hi, inem⟩:=h,
  rw mem_inter at hx,
  have ha' : disjoint (S.A i) (S.B a),
    rw inem, simp only [disjoint_empty_left],
  have hb' : disjoint (S.A i) (S.B b),
    rw inem, simp only [disjoint_empty_left],
  have ia: i=a:=sp'  hi ha ha',
  have ib: i=b:=sp'  hi hb hb',
  rw ia at ib, tauto,
end

lemma trival_univ {S : setpair} (h: S.u = 0) : card S.I ≤ 1 :=
begin
  by_contra h',
  obtain ⟨a,ha,b,hb,ne⟩:=one_lt_card.mp (by linarith: 1< S.I.card),
  obtain ⟨x,hx⟩:=(S.sp a ha b hb).mpr ne,
  have xinU: x∈ S.U,{
    simp only [mem_inter, setpair.Ug, mem_bUnion, mem_union, exists_prop, not_le, _root_.ne.def] at *,
    use [a,ha,hx.1], },
  rw [setpair.ug,card_eq_zero] at h,
  have :S.U.nonempty:=⟨x,xinU⟩,
    rw h at this, apply not_nonempty_empty this,
end

lemma den_triv {S : setpair} (h: triv_sp S) :den S≤ 1:=
begin
  have I1: card(S.I) ≤ 1:=triv_imp_I1 h,
  have Ic: card S.I ∈ Icc 0 1, {
  simp only [mem_Icc, zero_le, true_and,I1],},
  fin_cases Ic,
  {-- empty sum is zero
    have : den S =0,{
    rw card_eq_zero at Ic, rw [den, Ic],
    apply sum_empty,
    },linarith,
  },
  {--- only have I={a} so sum over singleton
    rw card_eq_one at Ic, rw [den],
    cases Ic with a ha, rw ha,
    rw sum_singleton,
    set d:=((S.A a).card + (S.B a).card).choose ((S.B a).card),
    have nch: 0< d :=choose_pos (le_add_self),
    have d1: 1 ≤ d:= by linarith,
    clear_except d1,
    rw one_div, apply inv_le_one _, rwa one_le_cast,
  },
end

lemma emp_U_den {S : setpair} (h: S.u = 0): den S ≤ 1 :=
begin
  have Ic: card S.I ∈ Icc 0 1, {
  simp only [mem_Icc, zero_le, true_and, trival_univ h],},
  fin_cases Ic,
  {-- empty sum is zero
    have : den S =0,{
    rw card_eq_zero at Ic, rw [den, Ic],
    apply sum_empty,
    },linarith,
  },
  {--- only have I={a} so sum over singleton
    rw card_eq_one at Ic, rw [den],
    cases Ic with a ha, rw ha,
    rw sum_singleton,
    set d:=((S.A a).card + (S.B a).card).choose ((S.B a).card),
    have nch: 0< d :=choose_pos (le_add_self),
    have d1: 1 ≤ d:= by linarith,
    clear_except d1,
    rw one_div, apply inv_le_one _, rwa one_le_cast,
  },
end

theorem bollobas_sp {S : setpair} {n : ℕ}: S.u=n →  den S ≤ 1 :=
begin
  revert S,
  --- should really do induction on S.wA so n= 0 → I.nonempty → (∃i∈S.I, (S.A i) = ∅)
  induction n using nat.strong_induction_on with n hn,
  intros S hs,
  cases nat.eq_zero_or_pos n with Uem,
  {rw ← hs at Uem, exact emp_U_den Uem,},
   by_cases ht: triv_sp S,
   {--- do case where there is an empty set in A or no sets at all!
    exact den_triv ht, },
  { rw ← hs at h,
    apply (mul_le_iff_le_one_left (cast_pos.mpr h)).mp,
    have e: (∑  y in S.U, den (er S y)) = den S * S.u,{
      exact den_double ht,},
    rw ← e,
    have dc: ∀y∈ S.U, (er S y).u< S.u,{
      intros y hy, exact er_univ_lt S hy,},
    have dd: ∀y∈ S.U, den(er S y)≤ (1:ℚ),{
      intros y hy, rw hs at dc,
      apply  hn ((er S y).u) (dc y hy),refl,},
  { rw setpair.ug,
    rw card_eq_sum_ones,
    convert sum_le_sum dd, norm_cast,},
    exact rat.nontrivial, },
end

theorem bollobas_sp' {S : setpair} : den S ≤ 1 :=
begin
  set n:ℕ:=S.u with h, exact bollobas_sp h,
end
end bbsetpair2
end finset


import tuto_lib
/-
This file continues the elementary study of limits of sequences.
It can be skipped if the previous file was too easy, it won't introduce
any new tactic or trick.

Remember useful lemmas:

abs_le {x y : ℝ} : |x| ≤ y ↔ -y ≤ x ∧ x ≤ y

abs_add (x y : ℝ) : |x + y| ≤ |x| + |y|

abs_sub_comm (x y : ℝ) : |x - y| = |y - x|

ge_max_iff (p q r) : r ≥ max p q  ↔ r ≥ p ∧ r ≥ q

le_max_left p q : p ≤ max p q

le_max_right p q : q ≤ max p q

and the definition:

def seq_limit (u : ℕ → ℝ) (l : ℝ) : Prop :=
∀ ε > 0, ∃ N, ∀ n ≥ N, |u n - l| ≤ ε

You can also use a property proved in the previous file:

unique_limit : seq_limit u l → seq_limit u l' → l = l'

def extraction (φ : ℕ → ℕ) := ∀ n m, n < m → φ n < φ m
-/

variable { φ : ℕ → ℕ}

/-
The next lemma is proved by an easy induction, but we haven't seen induction
in this tutorial. If you did the natural number game then you can delete
the proof below and try to reconstruct it.
-/
/-- An extraction is greater than id -/
lemma id_le_extraction' : extraction φ → ∀ n, n ≤ φ n :=
begin
  intros hyp n,
  induction n with n hn,
  { exact nat.zero_le _ },
  { exact nat.succ_le_of_lt (by linarith [hyp n (n+1) (by linarith)]) },
end

/-- Extractions take arbitrarily large values for arbitrarily large
inputs. -/
-- 0039
lemma extraction_ge : extraction φ → ∀ N N', ∃ n ≥ N', φ n ≥ N :=
begin
  sorry
end

/-- A real number `a` is a cluster point of a sequence `u`
if `u` has a subsequence converging to `a`.

def cluster_point (u : ℕ → ℝ) (a : ℝ) :=
∃ φ, extraction φ ∧ seq_limit (u ∘ φ) a
-/

variables {u : ℕ → ℝ} {a l : ℝ}

/-
In the exercise, we use `∃ n ≥ N, ...` which is the abbreviation of
`∃ n, n ≥ N ∧ ...`.
Lean can read this abbreviation, but displays it as the confusing:
`∃ (n : ℕ) (H : n ≥ N)`
One gets used to it. Alternatively, one can get rid of it using the lemma
  exists_prop {p q : Prop} : (∃ (h : p), q) ↔ p ∧ q
-/

/-- If `a` is a cluster point of `u` then there are values of
`u` arbitrarily close to `a` for arbitrarily large input. -/
-- 0040
lemma near_cluster :
  cluster_point u a → ∀ ε > 0, ∀ N, ∃ n ≥ N, |u n - a| ≤ ε :=
begin
  sorry
end

/-
The above exercice can be done in five lines.
Hint: you can use the anonymous constructor syntax when proving
existential statements.
-/

/-- If `u` tends to `l` then its subsequences tend to `l`. -/
-- 0041
lemma subseq_tendsto_of_tendsto' (h : seq_limit u l) (hφ : extraction φ) :
seq_limit (u ∘ φ) l :=
begin
  sorry
end

/-- If `u` tends to `l` all its cluster points are equal to `l`. -/
-- 0042
lemma cluster_limit (hl : seq_limit u l) (ha : cluster_point u a) : a = l :=
begin
  sorry
end

/-- Cauchy_sequence sequence -/
def cauchy_sequence (u : ℕ → ℝ) := ∀ ε > 0, ∃ N, ∀ p q, p ≥ N → q ≥ N → |u p - u q| ≤ ε

-- 0043
example : (∃ l, seq_limit u l) → cauchy_sequence u :=
begin
  sorry
end

/-
In the next exercise, you can reuse
 near_cluster : cluster_point u a → ∀ ε > 0, ∀ N, ∃ n ≥ N, |u n - a| ≤ ε
-/
-- 0044
example (hu : cauchy_sequence u) (hl : cluster_point u l) : seq_limit u l :=
begin
  sorry
end


/-
Copyright (c) 2023 Kevin Buzzard. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author : Kevin Buzzard
-/

import tactic -- imports all the Lean tactics
import measure_theory.measurable_space

/-

# Measure theory

## Sigma algebras.

A σ-algebra on a type `X` is a collection of subsets of `X` satisfying some
axioms, and in Lean you write it like this:

-/

-- let X be a set
variable (X : Type)
-- ...and let 𝓐 be a sigma-algebra on X
variable (𝓐 : measurable_space X)

/-

Note that `measurable_space` is a *class*, so really we should be writing `[measurable_space X]`,
meaning "let `X` be equipped once and for all with a sigma algebra which we won't give a name to".
But in this sheet we'll consider making them explicitly.

Let's do the following exercise. Show that if `A` is a subset of `X` then `{0,A,Aᶜ,X}`
is a sigma algebra on `X`.

-/

def gen_by (A : set X) : measurable_space X :=
{ measurable_set' := λ S, S = ∅ ∨ S = A ∨ S = Aᶜ ∨ S = ⊤,
  measurable_set_empty := begin
    sorry,
  end,
  measurable_set_compl := begin
    sorry,
  end,
  measurable_set_Union := begin
    sorry,
  end }

-- An alternative approach to defining the sigma algebra generated by `{A}` is just
-- to use `measurable_space.generate_from`:

example (A : set X) : measurable_space X := measurable_space.generate_from {A}

-- But the problem with that approach is that you don't get the actual sets
-- in the sigma algebra for free. Try this, to see what I mean!
example (A : set X) : (measurable_space.generate_from {A}).measurable_set' = ({∅,A,Aᶜ,⊤} : set (set X)) :=
begin
  sorry,
end


import Std

inductive Expr where
  | var (i : Nat)
  | op  (lhs rhs : Expr)
  deriving Inhabited, Repr

def List.getIdx : List α → Nat → α → α
  | [],    i,   u => u
  | a::as, 0,   u => a
  | a::as, i+1, u => getIdx as i u

structure Context (α : Type u) where
  op    : α → α → α
  unit  : α
  assoc : (a b c : α) → op (op a b) c = op a (op b c)
  comm  : (a b : α) → op a b = op b a
  vars  : List α

theorem Context.left_comm (ctx : Context α) (a b c : α) : ctx.op a (ctx.op b c) = ctx.op b (ctx.op a c) := by
  rw [← ctx.assoc, ctx.comm a b, ctx.assoc]

def Expr.denote (ctx : Context α) : Expr → α
  | Expr.op a b => ctx.op (denote ctx a) (denote ctx b)
  | Expr.var i  => ctx.vars.getIdx i ctx.unit

theorem Expr.denote_op (ctx : Context α) (a b : Expr) : denote ctx (Expr.op a b) = ctx.op (denote ctx a) (denote ctx b) :=
  rfl

def Expr.concat : Expr → Expr → Expr
  | Expr.op a b, c => Expr.op a (concat b c)
  | Expr.var i, c  => Expr.op (Expr.var i) c

theorem Expr.denote_concat (ctx : Context α) (a b : Expr) : denote ctx (concat a b) = denote ctx (Expr.op a b) := by
  induction a with
  | var i => rfl
  | op _ _ _ ih => simp [denote, ih, ctx.assoc]

def Expr.flat : Expr → Expr
  | Expr.op a b => concat (flat a) (flat b)
  | Expr.var i  => Expr.var i

theorem Expr.denote_flat (ctx : Context α) (e : Expr) : denote ctx (flat e) = denote ctx e := by
  induction e with
  | var i => rfl
  | op a b ih₁ ih₂ => simp [flat, denote, denote_concat, ih₁, ih₂]

theorem Expr.eq_of_flat (ctx : Context α) (a b : Expr) (h : flat a = flat b) : denote ctx a = denote ctx b := by
  have h := congrArg (denote ctx) h
  simp [denote_flat] at h
  assumption

def Expr.length : Expr → Nat
  | op a b => 1 + b.length
  | _      => 1

def Expr.sort (e : Expr) : Expr :=
  loop e.length e
where
  loop : Nat → Expr → Expr
    | fuel+1, Expr.op a e =>
      let (e₁, e₂) := swap a e
      Expr.op e₁ (loop fuel e₂)
    | _, e => e

  swap : Expr → Expr → Expr × Expr
    | Expr.var i, Expr.op (Expr.var j) e =>
      if i > j then
        let (e₁, e₂) := swap (Expr.var j) e
        (e₁, Expr.op (Expr.var i) e₂)
      else
        let (e₁, e₂) := swap (Expr.var i) e
        (e₁, Expr.op (Expr.var j) e₂)
    | Expr.var i, Expr.var j =>
      if i > j then
        (Expr.var j, Expr.var i)
      else
        (Expr.var i, Expr.var j)
    | e₁, e₂ => (e₁, e₂)

theorem Expr.denote_sort (ctx : Context α) (e : Expr) : denote ctx (sort e) = denote ctx e := by
  apply denote_loop
where
  denote_loop (n : Nat) (e : Expr) : denote ctx (sort.loop n e) = denote ctx e := by
    induction n generalizing e with
    | zero => rfl
    | succ n ih =>
      match e with
      | var _  => rfl
      | op a b =>
        simp [denote, sort.loop]
        match h:sort.swap a b with
        | (r₁, r₂) =>
          have hs := denote_swap a b
          rw [h] at hs
          simp [denote] at hs
          simp [denote, ih]
          assumption

  denote_swap (e₁ e₂ : Expr) : denote ctx (Expr.op (sort.swap e₁ e₂).1 (sort.swap e₁ e₂).2) = denote ctx (Expr.op e₁ e₂) := by
    induction e₂ generalizing e₁ with
    | op a b ih' ih =>
      clear ih'
      cases e₁ with
      | var i =>
        cases a with
        | var j =>
          byCases h : i > j
          focus
            simp [sort.swap, h]
            match h:sort.swap (var j) b with
            | (r₁, r₂) => simp; rw [denote_op (a := var i), ← ih]; simp [h, denote]; rw [Context.left_comm]
          focus
            simp [sort.swap, h]
            match h:sort.swap (var i) b with
            | (r₁, r₂) =>
              simp
              rw [denote_op (a := var i), denote_op (a := var j), Context.left_comm, ← denote_op (a := var i), ← ih]
              simp [h, denote]
              rw [Context.left_comm]
        | _ => rfl
      | _ => rfl
    | var j =>
      cases e₁ with
      | var i =>
        byCases h : i > j
        focus simp [sort.swap, h, denote, Context.comm]
        focus simp [sort.swap, h]
      | _ => rfl

theorem Expr.eq_of_sort_flat (ctx : Context α) (a b : Expr) (h : sort (flat a) = sort (flat b)) : denote ctx a = denote ctx b := by
  have h := congrArg (denote ctx) h
  simp [denote_flat, denote_sort] at h
  assumption

theorem ex₁ (x₁ x₂ x₃ x₄ : Nat) : (x₁ + x₂) + (x₃ + x₄) = x₁ + x₂ + x₃ + x₄ :=
  Expr.eq_of_flat
    { op    := Nat.add
      assoc := Nat.add_assoc
      comm  := Nat.add_comm
      unit  := Nat.zero
      vars  := [x₁, x₂, x₃, x₄] }
    (Expr.op (Expr.op (Expr.var 0) (Expr.var 1)) (Expr.op (Expr.var 2) (Expr.var 3)))
    (Expr.op (Expr.op (Expr.op (Expr.var 0) (Expr.var 1)) (Expr.var 2)) (Expr.var 3))
    rfl

theorem ex₂ (x₁ x₂ x₃ x₄ : Nat) : (x₁ + x₂) + (x₃ + x₄) = x₃ + x₁ + x₂ + x₄ :=
  Expr.eq_of_sort_flat
    { op    := Nat.add
      assoc := Nat.add_assoc
      comm  := Nat.add_comm
      unit  := Nat.zero
      vars  := [x₁, x₂, x₃, x₄] }
    (Expr.op (Expr.op (Expr.var 0) (Expr.var 1)) (Expr.op (Expr.var 2) (Expr.var 3)))
    (Expr.op (Expr.op (Expr.op (Expr.var 2) (Expr.var 0)) (Expr.var 1)) (Expr.var 3))
    rfl

#print ex₂


import M4R.Set.Basic
import M4R.Set.Finite.Pairwise

namespace M4R

  inductive Perm : List α → List α → Prop
  | nil                           : Perm [] []
  | cons (x : α) {l₁ l₂ : List α} : Perm l₁ l₂ → Perm (x::l₁) (x::l₂)
  | swap (x y : α) (l : List α)   : Perm (y::x::l) (x::y::l)
  | trans {l₁ l₂ l₃ : List α}     : Perm l₁ l₂ → Perm l₂ l₃ → Perm l₁ l₃

  infix:50 " ~ " => Perm

  namespace Perm

    @[simp] protected theorem refl : ∀ (x : List α), x ~ x
    | []      => Perm.nil
    | (x::xl) => (Perm.refl xl).cons x

    protected theorem symm {x y : List α} (h : x ~ y) : y ~ x :=
      @Perm.recOn α (fun (a b : List α) _ => b ~ a) x y h
        Perm.nil
        (fun x _ _ _ r₁ => r₁.cons x)
        (fun x y l => swap y x l)
        (fun _ _ p₂₁ p₃₂ => p₃₂.trans p₂₁)

    instance PermEquivalence : Equivalence (@Perm α) where
      refl  := Perm.refl
      symm  := Perm.symm
      trans := Perm.trans

    instance PermSetoid (α : Type _) : Setoid (List α) where
      r := Perm
      iseqv := PermEquivalence

    theorem subset {l₁ l₂ : List α} (p : l₁ ~ l₂) : l₁ ⊆ l₂ :=
      fun x => @Perm.recOn α (fun (a b : List α) _ => x ∈ a → x ∈ b) l₁ l₂ p id
          (fun y a b _ xab xya => Or.elim xya
            (fun exy => Or.inl exy)
            (fun xa => Or.inr (xab xa)))
          (fun y z a xzya => Or.elim xzya
              (fun exz => Or.inr (Or.inl exz))
              (fun xya => Or.elim xya
                  (fun exy => Or.inl exy)
                  (fun xa => Or.inr (Or.inr xa))))
          (fun _ _ x₁₂ x₂₃ x₁ => x₂₃ (x₁₂ x₁))

    theorem mem_iff {l₁ l₂ : List α} (p : l₁ ~ l₂) (a : α) : a ∈ l₁ ↔ a ∈ l₂ :=
      Iff.intro (fun x => p.subset x) (fun x => p.symm.subset x)

    theorem append_right {l₁ l₂ : List α} (t : List α) (p : l₁ ~ l₂) : l₁++t ~ l₂++t :=
      @Perm.recOn α (fun a b pab => a++t ~ b++t) _ _ p
        (Perm.refl ([] ++ t))
        (fun x _ _ _ r₁ => r₁.cons x)
        (fun x y _ => swap x y _)
        (fun _ _ r₁ r₂ => r₁.trans r₂)

    theorem append_left {t₁ t₂ : List α} (l : List α) (p : t₁ ~ t₂) : l++t₁ ~ l++t₂ :=
      match l with
      | [] => p
      | x::xs => (append_left xs p).cons x

    theorem append {l₁ l₂ t₁ t₂ : List α} (p₁ : l₁ ~ l₂) (p₂ : t₁ ~ t₂) : l₁++t₁ ~ l₂++t₂ :=
      (p₁.append_right t₁).trans (p₂.append_left l₂)

    theorem middle (a : α) : ∀ (l₁ l₂ : List α), l₁++a::l₂ ~ a::(l₁++l₂)
    | []     , l₂ => Perm.refl _
    | (b::l₁), l₂ => ((@middle α a l₁ l₂).cons b).trans (swap a b _)

    theorem append_singleton (a : α) (l : List α) : l ++ [a] ~ a::l := by
      have := middle a l []
      rw [List.append_nil] at this
      exact this

    theorem append_comm {l₁ l₂ : List α} : (l₁++l₂) ~ (l₂++l₁) :=
      match l₁ with
      | []     => by simp
      | (a::t) => ((append_comm).cons a).trans (middle a l₂ t).symm

    theorem length_eq {l₁ l₂ : List α} (p : l₁ ~ l₂) : l₁.length = l₂.length :=
      @Perm.recOn α (fun (a b : List α) _ => a.length = b.length) l₁ l₂ p rfl
        (fun _ _ _ _ h => by simp[h])
        (fun _ _ _ => by simp)
        (fun _ _ r₁₂ r₂₃ => Eq.trans r₁₂ r₂₃)

    theorem eq_nil {l : List α} (p : l ~ []) : l = [] :=
      List.eq_nil_of_length_eq_zero p.length_eq
    theorem nil_eq {l : List α} (p : [] ~ l) : l = [] :=
      eq_nil p.symm

    theorem inductionOn (motive : List α → List α → Prop) {l₁ l₂ : List α} (p : l₁ ~ l₂)
      (h₁ : motive [] [])
      (h₂ : ∀ x l₁ l₂, l₁ ~ l₂ → motive l₁ l₂ → motive (x::l₁) (x::l₂))
      (h₃ : ∀ x y l₁ l₂, l₁ ~ l₂ → motive l₁ l₂ → motive (y::x::l₁) (x::y::l₂))
      (h₄ : ∀ l₁ l₂ l₃, l₁ ~ l₂ → l₂ ~ l₃ → motive l₁ l₂ → motive l₂ l₃ → motive l₁ l₃) : motive l₁ l₂ := by
        have P_refl : ∀ l, motive l l :=
          fun l => @List.recOn α (fun x => motive x x) l h₁ (fun x xs ih => h₂ x xs xs (Perm.refl xs) ih)
        exact Perm.recOn p h₁ h₂ (fun x y l => h₃ x y l l (Perm.refl l) (P_refl l)) (h₄ _ _ _)

    theorem invCore {a : α} {l₁ l₂ r₁ r₂ : List α} : l₁++a::r₁ ~ l₂++a::r₂ → l₁++r₁ ~ l₂++r₂ := by
      generalize e₁ : l₁++a::r₁ = s₁; generalize e₂ : l₂++a::r₂ = s₂
      intro p; revert l₁ l₂ r₁ r₂ e₁ e₂
      apply inductionOn (fun (t₁ t₂ : List α) => ∀ {l₁' l₂' r₁' r₂' : List α},
        l₁'++a::r₁' = t₁ → l₂'++a::r₂' = t₂ → l₁'++r₁' ~ l₂'++r₂') p
      { intro l₁ _ r₁ _ e₁ _
        have h₀ := List.not_mem_nil a; rw [←e₁] at h₀
        have : a ∈ l₁ ++ a :: r₁ := by apply (mem_iff (middle a l₁ r₁) _).mpr; apply Or.inl; rfl
        contradiction }
      { intro _ _ _ p₁₂ ih l₁ l₂ _ _ e₁ e₂
        match l₁, l₂ with
        | [], [] =>
          simp only [List.nil_append, List.cons.injEq] at e₁ e₂ ⊢
          rw [e₁.right, e₂.right]; exact p₁₂
        | [], List.cons _ _ =>
          simp only [List.nil_append, List.cons_append, List.cons.injEq] at e₁ e₂ ⊢
          rw [e₂.left, e₁.right, ←e₁.left]; apply trans p₁₂; rw [←e₂.right]; exact middle _ _ _
        | List.cons _ _, [] =>
          simp only [List.nil_append, List.cons_append, List.cons.injEq] at e₁ e₂ ⊢
          rw [e₁.left, ←e₂.left, e₂.right]; apply Perm.symm; apply trans p₁₂.symm
          rw [←e₁.right]; exact middle _ _ _
        | List.cons _ _, List.cons z l₂ =>
          simp only [List.cons_append, List.cons.injEq] at e₁ e₂ ⊢
          rw [e₁.left, e₂.left]; exact cons _ (ih e₁.right e₂.right) }
      { intro _ _ _ _ p₁₂ ih l₁ l₂ _ _ e₁ e₂
        match l₁, l₂ with
        | [], [] =>
          simp only [List.nil_append, List.cons.injEq] at e₁ e₂ ⊢
          rw [e₁.right, e₂.right, ←e₁.left, e₂.left]; exact Perm.cons _ p₁₂
        | [], List.cons _ l₂ =>
          match l₂ with
          | [] =>
            simp only [List.nil_append, List.cons_append, List.cons.injEq] at e₁ e₂ ⊢
            rw [e₁.right, e₂.left, e₂.right.right]; exact Perm.cons _ p₁₂
          | List.cons _ _ =>
            simp only [List.nil_append, List.cons_append, List.cons.injEq] at e₁ e₂ ⊢
            rw [e₁.right, e₂.left, e₂.right.left, ←e₁.left]; apply cons;
              apply trans p₁₂; rw [←e₂.right.right]; exact middle _ _ _
        | List.cons _ l₁, [] =>
          match l₁ with
          | [] =>
            simp only [List.nil_append, List.cons_append, List.cons.injEq] at e₁ e₂ ⊢
            rw [e₁.right.right, e₂.right, e₁.left]; exact Perm.cons _ p₁₂
          | List.cons _ l₂ =>
            simp only [List.nil_append, List.cons_append, List.cons.injEq] at e₁ e₂ ⊢
            rw [e₂.right, e₁.left, e₁.right.left, ←e₂.left]; apply cons;
              apply Perm.symm; apply trans p₁₂.symm; rw [←e₁.right.right]; exact middle _ _ _
        | List.cons _ l₁, List.cons _ l₂ =>
          match l₁, l₂ with
          | [], [] =>
            simp only [List.nil_append, List.cons_append, List.cons.injEq] at e₁ e₂ ⊢
            rw [e₁.left, e₂.left, ←e₁.right.left, ←e₂.right.left, e₁.right.right, e₂.right.right]
              exact cons _ p₁₂
          | [], List.cons _ _ =>
            simp only [List.nil_append, List.cons_append, List.cons.injEq] at e₁ e₂ ⊢
            rw [e₁.left, e₂.left, ←e₁.right.left, e₂.right.left, e₁.right.right]
              apply trans (cons _ p₁₂); rw [←e₂.right.right]; apply Perm.symm; apply trans (swap _ _ _);
                apply cons; apply Perm.symm; exact middle _ _ _
          | List.cons _ _, [] =>
            simp only [List.nil_append, List.cons_append, List.cons.injEq] at e₁ e₂ ⊢
            rw [e₁.left, e₂.left, e₁.right.left, ←e₂.right.left]; apply trans (swap _ _ _); apply cons;
              rw [e₂.right.right]; apply Perm.symm; apply trans p₁₂.symm; rw [←e₁.right.right]; exact middle _ _ _
          | List.cons _ _, List.cons _ _ =>
            simp only [List.cons_append, List.cons.injEq] at e₁ e₂ ⊢
            rw [e₁.left, e₂.left, e₁.right.left, e₂.right.left]; apply trans (swap _ _ _); apply cons;
              apply cons; exact ih e₁.right.right e₂.right.right }
      { intro _ t₂ _ p₁₂ p₂₃ ih₁ ih₂ l₁ _ r₁ _ e₁ e₃;
          rw [←e₁] at p₁₂; rw [←e₃] at p₂₃
          have : a ∈ t₂ := p₁₂.subset (by apply (mem_iff (middle a l₁ r₁) _).mpr; apply Or.inl; rfl)
          let ⟨l₂, r₂, e₂⟩ := List.mem_split this;
          exact trans (ih₁ e₁ e₂.symm) (ih₂ e₂.symm e₃) }

    theorem cons_inv {a : α} {l₁ l₂ : List α} : a::l₁ ~ a::l₂ → l₁ ~ l₂ :=
      @invCore _ _ [] [] _ _

    theorem pairwiseIff {r : α → α → Prop} (h : ∀ a b, r a b → r b a) :
      ∀ {l₁ l₂ : List α} (p : l₁ ~ l₂), Pairwise r l₁ ↔ Pairwise r l₂ := by
      have : ∀ {l₁ l₂}, l₁ ~ l₂ → Pairwise r l₁ → Pairwise r l₂ := by
        intro l₁ l₂ p₁₂ pwl₁
        induction pwl₁ generalizing l₂ with
        | nil => rw [p₁₂.nil_eq]; constructor
        | @cons a l₃ hl₃ pwl₃ ih =>
          let ⟨s, t, e⟩ := List.mem_split (p₁₂.subset (List.mem_cons_self a l₃))
          rw [e, Pairwise.middle, Pairwise.consIff]; rw [e] at p₁₂
          have p' : l₃ ~ s ++ t := (p₁₂.trans (middle _ _ _)).cons_inv
          exact And.intro (fun x xst => hl₃ x ((mem_iff p' _).mpr xst)) (ih p')
          exact h
      exact fun _ _ p => ⟨this p, this p.symm⟩

    theorem nodupIff {l₁ l₂ : List α} : l₁ ~ l₂ → (l₁.nodup ↔ l₂.nodup) :=
      pairwiseIff (@Ne.symm α)

    theorem sizeOf_Eq_sizeOf {l₁ l₂ : List α} (h : l₁ ~ l₂) :
      sizeOf l₁ = sizeOf l₂ := by
      induction h with
      | nil => rfl
      | cons _ _ h => rw [List.sizeOf_cons, List.sizeOf_cons, h]
      | swap _ _ _ => rw [List.sizeOf_cons, List.sizeOf_cons, List.sizeOf_cons, List.sizeOf_cons]
      | trans _ _ h₁ h₂ => exact Eq.trans h₁ h₂

    theorem filterMap (f : α → Option β) {l₁ l₂ : List α} (p : l₁ ~ l₂) :
      List.filterMap f l₁ ~ List.filterMap f l₂ := by
        induction p with
        | nil => simp only [List.filterMap]; exact Perm.nil
        | cons x p ih =>
          simp only [List.filterMap]
          cases f x with
          | none => exact ih
          | some a => exact cons a ih
        | swap x y l =>
          simp only [List.filterMap]
          cases f x with
          | none =>
            cases f y with
            | none => exact Perm.refl _
            | some b => exact Perm.cons b (Perm.refl _)
          | some a =>
            cases f y with
            | none => exact Perm.refl _
            | some b => exact Perm.swap a b _
        | trans p₁₂ p₂₃ ih₁₂ ih₂₃ => exact ih₁₂.trans ih₂₃

    theorem map (f : α → β) {l₁ l₂ : List α} (p : l₁ ~ l₂) : l₁.map f ~ l₂.map f := by
      rw [←List.filterMap_Eq_map f]; exact filterMap (some ∘ f) p

    theorem pmap {p : α → Prop} (f : ∀ a, p a → β)
      {l₁ l₂ : List α} (p : l₁ ~ l₂) {H₁ H₂} : l₁.pmap f H₁ ~ l₂.pmap f H₂ := by
        induction p with
        | nil => simp [Perm.refl]
        | cons x p ih => simp [ih, cons]
        | swap x y l₂=> simp [swap]
        | trans p₁ p₂ ih₁ ih₂ => apply ih₁.trans ih₂; exact fun a m => H₂ a (p₂.subset m)

    theorem exists_perm_sublist {l₁ l₂ l₂' : List α} (s : l₁ <+ l₂) (p : l₂ ~ l₂') :
      ∃ l₁', l₁' ~ l₁ ∧ l₁' <+ l₂' := by
        induction p generalizing l₁ with
        | nil => exact ⟨[], List.Sublist.eq_nil_of_sublist_nil s ▸ Perm.refl _, List.Sublist.nil_sublist _⟩
        | cons x p ih =>
          cases s with
          | cons _ _ _ s => let ⟨l, pl, hl⟩ := ih s; exact ⟨l, pl, hl.cons _ _ x⟩
          | cons' l₁ _ _ s => let ⟨l, pl, hl⟩ := ih s; exact ⟨x::l, pl.cons x, hl.cons' _ _ x⟩
        | swap x y l₂ =>
          cases s with
          | cons _ _ _ s =>
            cases s with
            | cons _ _ _ s => exact ⟨l₁, Perm.refl _, (s.cons _ _ y).cons _ _ x⟩
            | cons' l₁ _ _ s => exact ⟨x::l₁, Perm.refl _, (s.cons _ _ y).cons' _ _ x⟩
          | cons' l₁ _ _ s =>
            cases s with
            | cons _ _ _ s => exact ⟨y::l₁, Perm.refl _, (s.cons' _ _ y).cons _ _ x⟩
            | cons' l₁ _ _ s => exact ⟨x::y::l₁, Perm.swap _ _ _, (s.cons' _ _ y).cons' _ _ x⟩
        | trans p₁ p₂ ih₁ ih₂ => let ⟨l, pl, hl⟩ := ih₁ s; let ⟨m, pm, hm⟩ := ih₂ hl; exact ⟨m, pm.trans pl, hm⟩

    def Subperm (l₁ l₂ : List α) : Prop := ∃ l, l ~ l₁ ∧ l <+ l₂
    infix:50 " <+~ " => Subperm
  end Perm
end M4R

namespace List.Sublist
  open M4R

  protected theorem subperm {l₁ l₂ : List α} (s : l₁ <+ l₂) : l₁ <+~ l₂ :=
    ⟨l₁, M4R.Perm.refl _, s⟩

  theorem exists_perm_append {l₁ l₂ : List α} : l₁ <+ l₂ → ∃ l, l₂ ~ l₁ ++ l
  | nil             => ⟨[], Perm.refl _⟩
  | cons l₁ l₂ a s  =>
    let ⟨l, p⟩ := exists_perm_append s
    ⟨a::l, (p.cons a).trans (Perm.middle _ _ _).symm⟩
  | cons' l₁ l₂ a s =>
    let ⟨l, p⟩ := exists_perm_append s
    ⟨l, p.cons a⟩

end List.Sublist

namespace M4R
  namespace Perm
    protected theorem subperm {l₁ l₂ : List α} (p : l₁ ~ l₂) : l₁ <+~ l₂ :=
      ⟨l₂, p.symm, List.Sublist.refl _⟩

    theorem subperm_left {l l₁ l₂ : List α} (p : l₁ ~ l₂) : l <+~ l₁ ↔ l <+~ l₂ := by
      have : ∀ {l₁ l₂ : List α}, l₁ ~ l₂ → l <+~ l₁ → l <+~ l₂ := fun p ⟨u, pu, su⟩ =>
        let ⟨v, pv, sv⟩ := exists_perm_sublist su p
        ⟨v, pv.trans pu, sv⟩
      exact ⟨this p, this p.symm⟩

    theorem subperm_right {l₁ l₂ l : List α} (p : l₁ ~ l₂) : l₁ <+~ l ↔ l₂ <+~ l :=
      ⟨fun ⟨u, pu, su⟩ => ⟨u, pu.trans p, su⟩,
        fun ⟨u, pu, su⟩ => ⟨u, pu.trans p.symm, su⟩⟩

    namespace Subperm
      theorem nil_subperm {l : List α} : [] <+~ l :=
        ⟨[], Perm.nil, by simp⟩

      protected theorem refl (l : List α) : l <+~ l := (Perm.refl _).subperm

      protected theorem trans {l₁ l₂ l₃ : List α} : l₁ <+~ l₂ → l₂ <+~ l₃ → l₁ <+~ l₃
      | s, ⟨l₂', p₂, s₂⟩ =>
        let ⟨l₁', p₁, s₁⟩ := p₂.subperm_left.mpr s
        ⟨l₁', p₁, s₁.trans s₂⟩

      theorem length_le {l₁ l₂ : List α} : l₁ <+~ l₂ → l₁.length ≤ l₂.length
      | ⟨l, p, s⟩ => p.length_eq ▸ s.length_le_of_sublist

      theorem perm_of_length_le {l₁ l₂ : List α} : l₁ <+~ l₂ → l₂.length ≤ l₁.length → l₁ ~ l₂
      | ⟨l, p, s⟩, h =>
        have := List.Sublist.eq_of_sublist_of_length_le s (p.symm.length_eq ▸ h)
        this ▸ p.symm

      theorem antisymm {l₁ l₂ : List α} (h₁ : l₁ <+~ l₂) (h₂ : l₂ <+~ l₁) : l₁ ~ l₂ :=
        h₁.perm_of_length_le h₂.length_le

      theorem subset {l₁ l₂ : List α} : l₁ <+~ l₂ → l₁ ⊆ l₂
      | ⟨l, p, s⟩ => Subset.trans p.symm.subset s.subset

      theorem subperm_cons (a : α) {l₁ l₂ : List α} : a::l₁ <+~ a::l₂ ↔ l₁ <+~ l₂ :=
        ⟨fun ⟨l, p, s⟩ => by
          cases s with
          | cons _ _ _ s' =>
            exact (p.subperm_left.mpr (List.Sublist.sublist_cons _ _).subperm).trans s'.subperm
          | cons' u _ _ s' => exact ⟨u, p.cons_inv, s'⟩,
        fun ⟨l, p, s⟩ => ⟨a::l, p.cons a, s.cons' _ _ _⟩⟩

      theorem subperm_swap_left {a b : α} {l₁ l₂ : List α} : a::b::l₁ <+~ l₂ → b::a::l₁ <+~ l₂ :=
        fun ⟨t, p, s⟩ => ⟨t, p.trans (Perm.swap b a l₁), s⟩

      theorem cons_subperm_of_mem {a : α} {l₁ l₂ : List α} (d₁ : l₁.nodup) (h₁ : a ∉ l₁) (h₂ : a ∈ l₂)
        (s : l₁ <+~ l₂) : a :: l₁ <+~ l₂ := by
          let ⟨l, p, s⟩ := s
          induction s generalizing l₁ with
          | nil => cases h₂
          | cons r₁ r₂  b s' ih =>
            cases h₂ with
            | inl e => rw [e]; exact ⟨b::r₁, p.cons b, s'.cons' _ _ _⟩
            | inr m => let ⟨t, p', s'⟩ := ih d₁ h₁ m ⟨r₁, p, s'⟩ p; exact ⟨t, p', s'.cons _ _ _⟩
          | cons' r₁ r₂ b s' ih =>
            have bm : b ∈ l₁ := p.subset (List.mem_cons_self _ _)
            have am : a ∈ r₂ := h₂.resolve_left (fun e => h₁ (e.symm ▸ bm))
            cases List.mem_split bm with
            | intro t₁ t₂ =>
              let ⟨t₂, h⟩ := t₂; rw [h]
              have st : t₁ ++ t₂ <+ l₁ := by
                rw [h]; exact (List.Sublist.append_sublist_append_left t₁).mpr
                  (List.Sublist.cons t₂ t₂ b (List.Sublist.refl t₂))
              have rt : r₁ ~ t₁ ++ t₂ := cons_inv (p.trans (by rw [h]; exact Perm.middle _ _ _))
              let ⟨t, p', s'⟩ := ih (List.nodup_of_sublist st d₁) (fun h' => absurd (st.subset h') h₁) am
                ⟨r₁, rt, s'⟩ rt
              exact ⟨b::t, (p'.cons b).trans ((swap _ _ _).trans ((Perm.middle _ _ _).symm.cons a)), s'.cons' _ _ _⟩

      theorem subperm_append_left {l₁ l₂ : List α} : ∀ l, l++l₁ <+~ l++l₂ ↔ l₁ <+~ l₂
      | []   => Iff.rfl
      | a::l => (subperm_cons a).trans (subperm_append_left l)

      theorem subperm_append_right {l₁ l₂ : List α} (l : List α) : l₁++l <+~ l₂++l ↔ l₁ <+~ l₂ :=
        (append_comm.subperm_left.trans append_comm.subperm_right).trans (subperm_append_left l)

      theorem subperm_of_subset_nodup {l₁ l₂ : List α} (d : l₁.nodup) (H : l₁ ⊆ l₂) : l₁ <+~ l₂ := by
        induction d with
        | nil => exact ⟨[], Perm.nil, List.Sublist.nil_sublist _⟩
        | cons h d IH =>
          let ⟨H₁, H₂⟩ := List.forall_mem_cons.mp H
          exact cons_subperm_of_mem d (fun h' => by apply h _ h'; rfl) H₁ (IH H₂)

      @[simp] theorem subperm_nil {l : List α} (h : l <+~ []) : l = [] := by
        let ⟨t, p, s⟩ := h
        rw [List.Sublist.eq_nil_of_sublist_nil s] at p
        exact eq_nil p.symm

      theorem not_cons_self (l : List α) (a : α) : ¬ (a::l <+~ l) := by
        induction l with
        | nil =>
          intro h; have := subperm_nil h
          contradiction
        | cons x l ih =>
          intro h; exact ih ((subperm_cons x).mp (subperm_swap_left h))

      theorem exists_of_length_lt {l₁ l₂ : List α} :
        l₁ <+~ l₂ → l₁.length < l₂.length → ∃ a, a :: l₁ <+~ l₂ := by
          intro ⟨l, p, s⟩ hlt
          have : l.length < l₂.length → ∃ a, a :: l <+~ l₂ := by
            clear p hlt l₁
            induction s with
            | nil => intro hlt'; cases hlt'
            | cons l₁' l₂' a s ih =>
              intro hlt'
              cases Nat.lt_or_eq_of_le (Nat.le_of_lt_succ hlt') with
              | inl h' => exact (ih h').imp (fun a s => s.trans (List.Sublist.sublist_cons _ _).subperm)
              | inr h' => exact ⟨a, List.Sublist.eq_of_sublist_of_length_eq s h' ▸ Subperm.refl _⟩
            | cons' l₁' l₂' b s ih =>
              intro h'
              exact (ih (Nat.lt_of_succ_lt_succ h')).imp (fun a s =>
                (swap _ _ _).subperm_right.mp ((subperm_cons _).mpr s))
          exact (this (p.symm.length_eq ▸ hlt)).imp (fun a => (p.cons a).subperm_right.mp)

      theorem exists_of_subperm_ne {l₁ l₂ : List α} (h₁ : l₁ <+~ l₂) (h₂ : ¬ l₁ ~ l₂) : ∃ a, a::l₁ <+~ l₂ :=
        exists_of_length_lt h₁ (Nat.gt_of_not_le (mt (perm_of_length_le h₁) h₂))

    end Subperm

    protected theorem ext {l₁ l₂ : List α} (d₁ : l₁.nodup) (d₂ : l₂.nodup) : l₁ ~ l₂ ↔ ∀a, a ∈ l₁ ↔ a ∈ l₂ :=
      ⟨fun p a => p.mem_iff _, fun H =>
        Subperm.antisymm
          (Subperm.subperm_of_subset_nodup d₁ (fun a => (H a).mp))
          (Subperm.subperm_of_subset_nodup d₂ (fun a => (H a).mpr))⟩

    open Classical

    theorem insert (a : α) {l₁ l₂ : List α} (p : l₁ ~ l₂) : l₁.insert a ~ l₂.insert a :=
      if h : a ∈ l₁ then by
        simp only [List.insert, h, p.subset h]; exact p
      else by
        simp only [List.insert, h, mt (p.mem_iff a).mpr h]
        exact Perm.cons a p

    theorem insert_swap (x y : α) (l : List α) : (l.insert y).insert x ~ (l.insert x).insert y := by
      byCases xl : x ∈ l; { byCases yl : y ∈ l; { simp [xl, yl] } simp [xl, yl] }
      byCases xy : x = y; { simp [xy] } byCases yl : y ∈ l; { simp [xl, yl] }
      simp [xl, yl, List.not_mem_cons_of_ne_of_not_mem xy xl,
        List.not_mem_cons_of_ne_of_not_mem (Ne.symm xy) yl, swap]

    theorem union_right {l₁ l₂ : List α} (t₁ : List α) (h : l₁ ~ l₂) : l₁ ∪ t₁ ~ l₂ ∪ t₁ := by
      induction h with
      | nil => simp
      | cons a _ ih => exact ih.insert a
      | swap => exact insert_swap _ _ _
      | trans _ _ ih₁ ih₂ => exact ih₁.trans ih₂

    theorem union_left (l : List α) {t₁ t₂ : List α} (h : t₁ ~ t₂) : l ∪ t₁ ~ l ∪ t₂ := by
      induction l with
      | nil => simp [h]
      | cons a l ih => simp [insert a ih]

    theorem union {l₁ l₂ t₁ t₂ : List α} (p₁ : l₁ ~ l₂) (p₂ : t₁ ~ t₂) : l₁ ∪ t₁ ~ l₂ ∪ t₂ :=
      (p₁.union_right t₁).trans (p₂.union_left l₂)

    theorem Sublist.union_left (l₁ l₂ : List α) : l₁ <+ l₂ ∪ l₁ := by
      let ⟨t, s, e⟩ := List.sublist_suffix_of_union l₂ l₁
      rw [←e]; exact List.Sublist.sublist_append_right t l₁

    theorem Subperm.union_left (l₁ l₂ : List α) : l₁ <+~ l₂ ∪ l₁ :=
      (Sublist.union_left l₁ l₂).subperm

    theorem filter' (p : α → Prop) {l₁ l₂ : List α} (s : l₁ ~ l₂) : l₁.filter' p ~ l₂.filter' p := by
      rw [←List.filter_map_eq_filter']; exact s.filterMap _

    theorem cons_erase {a : α} {l : List α} (h : a ∈ l) : l ~ a :: l.erase a :=
      let ⟨l₁, l₂, _, e₁, e₂⟩ := List.exists_erase_eq h
      e₂.symm ▸ e₁.symm ▸ (middle a l₁ l₂)

    theorem erase (a : α) {l₁ l₂ : List α} (p : l₁ ~ l₂) :
      l₁.erase a ~ l₂.erase a :=
        if h₁ : a ∈ l₁ then
          have h₂ : a ∈ l₂ := p.subset h₁
          cons_inv ((cons_erase h₁).symm.trans (p.trans (cons_erase h₂)))
        else by
          have h₂ : a ∉ l₂ := mt (p.mem_iff _).mpr h₁
          rw [List.erase_of_not_mem h₁, List.erase_of_not_mem h₂]; exact p

    theorem diff_right {l₁ l₂ : List α} (t : List α) (h : l₁ ~ l₂) : l₁.diff t ~ l₂.diff t := by
      induction t generalizing l₁ l₂ h with
      | nil => simp [h]
      | cons a t ih =>
        simp only [List.diff_cons]
        exact ih (erase a h)

    theorem diff_left (l : List α) {t₁ t₂ : List α} (h : t₁ ~ t₂) : l.diff t₁ = l.diff t₂ := by
      induction h generalizing l with
      | nil => simp
      | cons a p ih => simp; exact ih _
      | swap x y t => simp [List.erase_comm]
      | trans p₁ p₂ ih₁ ih₂ => exact (ih₁ _).trans (ih₂ _)

    theorem diff {l₁ l₂ t₁ t₂ : List α} (hl : l₁ ~ l₂) (ht : t₁ ~ t₂) :
      l₁.diff t₁ ~ l₂.diff t₂ :=
        ht.diff_left l₂ ▸ hl.diff_right _

    theorem countp_eq (p : α → Prop) {l₁ l₂ : List α} (s : l₁ ~ l₂) : l₁.countp p = l₂.countp p := by
      rw [List.countp_eq_length_filter', List.countp_eq_length_filter']
      exact (s.filter' _).length_eq

    theorem count_eq {l₁ l₂ : List α} (p : l₁ ~ l₂) (a) : l₁.count a = l₂.count a :=
      p.countp_eq _

    theorem perm_iff_count {l₁ l₂ : List α} : l₁ ~ l₂ ↔ ∀ a, l₁.count a = l₂.count a :=
      ⟨count_eq, fun h => by
        induction l₁ generalizing l₂ with
        | nil => cases l₂ with
          | nil => exact Perm.refl _
          | cons b l₂ => have := h b; simp only [List.count.count_nil,
            List.count.count_cons_of_pos] at this; contradiction
        | cons a l₁ ih =>
          have : a ∈ l₂ := List.count.count_pos.mp ((List.count.count_cons_of_pos a l₁ ▸ h a :
            List.count a l₁ + 1 = List.count a l₂) ▸ Nat.succ_pos _)
          exact ((ih fun b => by
            have h₁ := h b; rw [(cons_erase this).count_eq] at h₁
            byCases h₂ : b = a
            { simp only [h₂, List.count.count_cons_of_pos] at h₁ ⊢; exact Nat.succ.inj h₁ }
            { simp only [List.count.count_cons_of_neg h₂] at h₁; exact h₁ }).cons a).trans (cons_erase this).symm⟩

    section bag_inter

      theorem bag_inter_right {l₁ l₂ : List α} (t : List α) (h : l₁ ~ l₂) :
        l₁.bag_inter t ~ l₂.bag_inter t := by
          induction h generalizing t with
          | nil => exact Perm.refl _
          | cons x p ih =>
            byCases hx : x ∈ t
            { rw [List.cons_bag_inter_of_pos _ hx, List.cons_bag_inter_of_pos _ hx]
            exact (ih (t.erase x)).cons x }
            { rw [List.cons_bag_inter_of_neg _ hx, List.cons_bag_inter_of_neg _ hx]
            exact ih t }
          | swap x y l =>
            byCases hxy : x = y
            { rw [hxy]; exact Perm.refl _ }
            { byCases hx : x ∈ t;
              { rw [List.cons_bag_inter_of_pos _ hx]
                byCases hy : y ∈ t;
                { rw [List.cons_bag_inter_of_pos _ hy,
                    List.cons_bag_inter_of_pos _ ((List.mem_erase_of_ne hxy).mpr hx),
                    List.cons_bag_inter_of_pos _ ((List.mem_erase_of_ne (Ne.symm hxy)).mpr hy),
                    List.erase_comm]
                  exact Perm.swap x y _ }
                { rw [List.cons_bag_inter_of_neg _ hy,
                    List.cons_bag_inter_of_pos _ hx,
                    List.cons_bag_inter_of_neg _ (mt List.mem_of_mem_erase hy)]
                  exact Perm.cons x (Perm.refl _) } }
              { rw [List.cons_bag_inter_of_neg _ hx]
                byCases hy : y ∈ t;
                { rw [List.cons_bag_inter_of_pos _ hy,
                    List.cons_bag_inter_of_pos _ hy,
                    List.cons_bag_inter_of_neg _ (mt List.mem_of_mem_erase hx)]
                  exact Perm.cons y (Perm.refl _) }
                { rw [List.cons_bag_inter_of_neg _ hy,
                    List.cons_bag_inter_of_neg _ hx,
                    List.cons_bag_inter_of_neg _ hy]
                  exact Perm.refl _ } } }
          | trans p₁ p₂ ih₁ ih₂ => exact (ih₁ _).trans (ih₂ _)

      theorem bag_inter_left (l : List α) {t₁ t₂ : List α} (p : t₁ ~ t₂) :
        l.bag_inter t₁ = l.bag_inter t₂ := by
          induction l generalizing t₁ t₂ p with
          | nil => simp only [List.nil_bag_inter]
          | cons a l ih =>
            byCases h : a ∈ t₁
            { rw [List.cons_bag_inter_of_pos _ h,
              List.cons_bag_inter_of_pos _ ((p.mem_iff a).mp h)]
              exact List.cons_ext.mpr ⟨rfl, ih (p.erase _)⟩ }
            { rw [List.cons_bag_inter_of_neg _ h,
              List.cons_bag_inter_of_neg _ (mt (p.mem_iff a).mpr h)]
              exact ih p }

      theorem bag_inter {l₁ l₂ t₁ t₂ : List α} (hl : l₁ ~ l₂) (ht : t₁ ~ t₂) :
        l₁.bag_inter t₁ ~ l₂.bag_inter t₂ :=
          ht.bag_inter_left l₂ ▸ hl.bag_inter_right _

    end bag_inter

    theorem dedup {l₁ l₂ : List α} (p : l₁ ~ l₂) : l₁.dedup ~ l₂.dedup :=
      perm_iff_count.mpr fun a => by
        byCases h : a ∈ l₁
        { simp only [List.mem_dedup, List.nodup_dedup, List.count_eq_one_of_mem, h, p.subset h] }
        { simp only [List.mem_dedup, List.count_eq_zero_of_not_mem, h, mt (p.mem_iff a).mpr h] }

  end Perm
end M4R


/-
Copyright (c) 2020 Joseph Myers. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Joseph Myers, Sébastien Gouëzel, Heather Macbeth
-/
import analysis.inner_product_space.projection
import analysis.normed_space.pi_Lp

/-!
# `L²` inner product space structure on finite products of inner product spaces

The `L²` norm on a finite product of inner product spaces is compatible with an inner product
$$
\langle x, y\rangle = \sum \langle x_i, y_i \rangle.
$$
This is recorded in this file as an inner product space instance on `pi_Lp 2`.

## Main definitions

- `euclidean_space 𝕜 n`: defined to be `pi_Lp 2 (n → 𝕜)` for any `fintype n`, i.e., the space
  from functions to `n` to `𝕜` with the `L²` norm. We register several instances on it (notably
  that it is a finite-dimensional inner product space).

- `orthonormal_basis 𝕜 ι`: defined to be an isometry to Euclidean space from a given
  finite-dimensional innner product space, `E ≃ₗᵢ[𝕜] euclidean_space 𝕜 ι`.

- `basis.to_orthonormal_basis`: constructs an `orthonormal_basis` for a finite-dimensional
  Euclidean space from a `basis` which is `orthonormal`.

- `linear_isometry_equiv.of_inner_product_space`: provides an arbitrary isometry to Euclidean space
  from a given finite-dimensional inner product space, induced by choosing an arbitrary basis.

- `complex.isometry_euclidean`: standard isometry from `ℂ` to `euclidean_space ℝ (fin 2)`

-/

open real set filter is_R_or_C
open_locale big_operators uniformity topological_space nnreal ennreal complex_conjugate direct_sum

noncomputable theory

variables {ι : Type*}
variables {𝕜 : Type*} [is_R_or_C 𝕜] {E : Type*} [inner_product_space 𝕜 E]
variables {E' : Type*} [inner_product_space 𝕜 E']
variables {F : Type*} [inner_product_space ℝ F]
variables {F' : Type*} [inner_product_space ℝ F']
local notation `⟪`x`, `y`⟫` := @inner 𝕜 _ _ x y

/-
 If `ι` is a finite type and each space `f i`, `i : ι`, is an inner product space,
then `Π i, f i` is an inner product space as well. Since `Π i, f i` is endowed with the sup norm,
we use instead `pi_Lp 2 f` for the product space, which is endowed with the `L^2` norm.
-/
instance pi_Lp.inner_product_space {ι : Type*} [fintype ι] (f : ι → Type*)
  [Π i, inner_product_space 𝕜 (f i)] : inner_product_space 𝕜 (pi_Lp 2 f) :=
{ inner := λ x y, ∑ i, inner (x i) (y i),
  norm_sq_eq_inner :=
  begin
    intro x,
    have h₁ : ∑ (i : ι), ∥x i∥ ^ (2 : ℕ) = ∑ (i : ι), ∥x i∥ ^ (2 : ℝ),
    { apply finset.sum_congr rfl,
      intros j hj,
      simp [←rpow_nat_cast] },
    have h₂ : 0 ≤ ∑ (i : ι), ∥x i∥ ^ (2 : ℝ),
    { rw [←h₁],
      exact finset.sum_nonneg (λ j (hj : j ∈ finset.univ), pow_nonneg (norm_nonneg (x j)) 2) },
    simp [norm, add_monoid_hom.map_sum, ←norm_sq_eq_inner],
    rw [←rpow_nat_cast ((∑ (i : ι), ∥x i∥ ^ (2 : ℝ)) ^ (2 : ℝ)⁻¹) 2],
    rw [←rpow_mul h₂],
    norm_num [h₁],
  end,
  conj_sym :=
  begin
    intros x y,
    unfold inner,
    rw ring_hom.map_sum,
    apply finset.sum_congr rfl,
    rintros z -,
    apply inner_conj_sym,
  end,
  add_left := λ x y z,
    show ∑ i, inner (x i + y i) (z i) = ∑ i, inner (x i) (z i) + ∑ i, inner (y i) (z i),
    by simp only [inner_add_left, finset.sum_add_distrib],
  smul_left := λ x y r,
    show ∑ (i : ι), inner (r • x i) (y i) = (conj r) * ∑ i, inner (x i) (y i),
    by simp only [finset.mul_sum, inner_smul_left] }

@[simp] lemma pi_Lp.inner_apply {ι : Type*} [fintype ι] {f : ι → Type*}
  [Π i, inner_product_space 𝕜 (f i)] (x y : pi_Lp 2 f) :
  ⟪x, y⟫ = ∑ i, ⟪x i, y i⟫ :=
rfl

lemma pi_Lp.norm_eq_of_L2 {ι : Type*} [fintype ι] {f : ι → Type*}
  [Π i, inner_product_space 𝕜 (f i)] (x : pi_Lp 2 f) :
  ∥x∥ = sqrt (∑ (i : ι), ∥x i∥ ^ 2) :=
by { rw [pi_Lp.norm_eq_of_nat 2]; simp [sqrt_eq_rpow] }

/-- The standard real/complex Euclidean space, functions on a finite type. For an `n`-dimensional
space use `euclidean_space 𝕜 (fin n)`. -/
@[reducible, nolint unused_arguments]
def euclidean_space (𝕜 : Type*) [is_R_or_C 𝕜]
  (n : Type*) [fintype n] : Type* := pi_Lp 2 (λ (i : n), 𝕜)

lemma euclidean_space.norm_eq {𝕜 : Type*} [is_R_or_C 𝕜] {n : Type*} [fintype n]
  (x : euclidean_space 𝕜 n) : ∥x∥ = real.sqrt (∑ (i : n), ∥x i∥ ^ 2) :=
pi_Lp.norm_eq_of_L2 x

variables [fintype ι]

section
local attribute [reducible] pi_Lp

instance : finite_dimensional 𝕜 (euclidean_space 𝕜 ι) := by apply_instance
instance : inner_product_space 𝕜 (euclidean_space 𝕜 ι) := by apply_instance

@[simp] lemma finrank_euclidean_space :
  finite_dimensional.finrank 𝕜 (euclidean_space 𝕜 ι) = fintype.card ι := by simp

lemma finrank_euclidean_space_fin {n : ℕ} :
  finite_dimensional.finrank 𝕜 (euclidean_space 𝕜 (fin n)) = n := by simp

/-- A finite, mutually orthogonal family of subspaces of `E`, which span `E`, induce an isometry
from `E` to `pi_Lp 2` of the subspaces equipped with the `L2` inner product. -/
def direct_sum.submodule_is_internal.isometry_L2_of_orthogonal_family
  [decidable_eq ι] {V : ι → submodule 𝕜 E} (hV : direct_sum.submodule_is_internal V)
  (hV' : @orthogonal_family 𝕜 _ _ _ _ (λ i, V i) _ (λ i, (V i).subtypeₗᵢ)) :
  E ≃ₗᵢ[𝕜] pi_Lp 2 (λ i, V i) :=
begin
  let e₁ := direct_sum.linear_equiv_fun_on_fintype 𝕜 ι (λ i, V i),
  let e₂ := linear_equiv.of_bijective _ hV.injective hV.surjective,
  refine (e₂.symm.trans e₁).isometry_of_inner _,
  suffices : ∀ v w, ⟪v, w⟫ = ⟪e₂ (e₁.symm v), e₂ (e₁.symm w)⟫,
  { intros v₀ w₀,
    convert this (e₁ (e₂.symm v₀)) (e₁ (e₂.symm w₀));
    simp only [linear_equiv.symm_apply_apply, linear_equiv.apply_symm_apply] },
  intros v w,
  transitivity ⟪(∑ i, (V i).subtypeₗᵢ (v i)), ∑ i, (V i).subtypeₗᵢ (w i)⟫,
  { simp only [sum_inner, hV'.inner_right_fintype, pi_Lp.inner_apply] },
  { congr; simp }
end

@[simp] lemma direct_sum.submodule_is_internal.isometry_L2_of_orthogonal_family_symm_apply
  [decidable_eq ι] {V : ι → submodule 𝕜 E} (hV : direct_sum.submodule_is_internal V)
  (hV' : @orthogonal_family 𝕜 _ _ _ _ (λ i, V i) _ (λ i, (V i).subtypeₗᵢ))
  (w : pi_Lp 2 (λ i, V i)) :
  (hV.isometry_L2_of_orthogonal_family hV').symm w = ∑ i, (w i : E) :=
begin
  classical,
  let e₁ := direct_sum.linear_equiv_fun_on_fintype 𝕜 ι (λ i, V i),
  let e₂ := linear_equiv.of_bijective _ hV.injective hV.surjective,
  suffices : ∀ v : ⨁ i, V i, e₂ v = ∑ i, e₁ v i,
  { exact this (e₁.symm w) },
  intros v,
  simp [e₂, direct_sum.submodule_coe, direct_sum.to_module, dfinsupp.sum_add_hom_apply]
end

end

/-- The vector given in euclidean space by being `1 : 𝕜` at coordinate `i : ι` and `0 : 𝕜` at
all other coordinates. -/
def euclidean_space.single [decidable_eq ι] (i : ι) (a : 𝕜) :
  euclidean_space 𝕜 ι :=
pi.single i a

@[simp] theorem euclidean_space.single_apply [decidable_eq ι] (i : ι) (a : 𝕜) (j : ι) :
  (euclidean_space.single i a) j = ite (j = i) a 0 :=
by { rw [euclidean_space.single, ← pi.single_apply i a j] }

lemma euclidean_space.inner_single_left [decidable_eq ι] (i : ι) (a : 𝕜) (v : euclidean_space 𝕜 ι) :
  ⟪euclidean_space.single i (a : 𝕜), v⟫ = conj a * (v i) :=
by simp [apply_ite conj]

lemma euclidean_space.inner_single_right [decidable_eq ι] (i : ι) (a : 𝕜)
  (v : euclidean_space 𝕜 ι) :
  ⟪v, euclidean_space.single i (a : 𝕜)⟫ =  a * conj (v i) :=
by simp [apply_ite conj, mul_comm]

variables (ι 𝕜 E)

/-- An orthonormal basis on E is an identification of `E` with its dimensional-matching
`euclidean_space 𝕜 ι`. -/
structure orthonormal_basis := of_repr :: (repr : E ≃ₗᵢ[𝕜] euclidean_space 𝕜 ι)

variables {ι 𝕜 E}

namespace orthonormal_basis

instance : inhabited (orthonormal_basis ι 𝕜 (euclidean_space 𝕜 ι)) :=
⟨of_repr (linear_isometry_equiv.refl 𝕜 (euclidean_space 𝕜 ι))⟩

/-- `b i` is the `i`th basis vector. -/
instance : has_coe_to_fun (orthonormal_basis ι 𝕜 E) (λ _, ι → E) :=
{ coe := λ b i, by classical; exact b.repr.symm (euclidean_space.single i (1 : 𝕜)) }

@[simp] protected lemma repr_symm_single [decidable_eq ι] (b : orthonormal_basis ι 𝕜 E) (i : ι) :
  b.repr.symm (euclidean_space.single i (1:𝕜)) = b i :=
by { classical, congr, simp, }

@[simp] protected lemma repr_self [decidable_eq ι] (b : orthonormal_basis ι 𝕜 E) (i : ι) :
  b.repr (b i) = euclidean_space.single i (1:𝕜) :=
begin
  classical,
  rw [← b.repr_symm_single i, linear_isometry_equiv.apply_symm_apply],
  congr,
  simp,
end

protected lemma repr_apply_apply (b : orthonormal_basis ι 𝕜 E) (v : E) (i : ι) :
  b.repr v i = ⟪b i, v⟫ :=
begin
  classical,
  rw [← b.repr.inner_map_map (b i) v, b.repr_self i, euclidean_space.inner_single_left],
  simp only [one_mul, eq_self_iff_true, map_one],
end

@[simp]
protected lemma orthonormal (b : orthonormal_basis ι 𝕜 E) : orthonormal 𝕜 b :=
begin
  classical,
  rw orthonormal_iff_ite,
  intros i j,
  rw [← b.repr.inner_map_map (b i) (b j), b.repr_self i, b.repr_self j],
  rw euclidean_space.inner_single_left,
  rw euclidean_space.single_apply,
  simp only [mul_boole, map_one],
end

/-- The `basis ι 𝕜 E` underlying the `orthonormal_basis` --/
protected def to_basis (b : orthonormal_basis ι 𝕜 E) : basis ι 𝕜 E :=
basis.of_equiv_fun b.repr.to_linear_equiv

@[simp] protected lemma coe_to_basis (b : orthonormal_basis ι 𝕜 E) :
  (⇑b.to_basis : ι → E) = ⇑b :=
begin
  change ⇑(basis.of_equiv_fun b.repr.to_linear_equiv) = b,
  ext j,
  rw basis.coe_of_equiv_fun,
  simp only [orthonormal_basis.repr_symm_single],
  congr,
end

@[simp] protected lemma coe_to_basis_repr (b : orthonormal_basis ι 𝕜 E) :
  b.to_basis.equiv_fun = b.repr.to_linear_equiv :=
begin
  change (basis.of_equiv_fun b.repr.to_linear_equiv).equiv_fun = b.repr.to_linear_equiv,
  ext x j,
  simp only [basis.of_equiv_fun_repr_apply, eq_self_iff_true,
    linear_isometry_equiv.coe_to_linear_equiv, basis.equiv_fun_apply],
end

protected lemma sum_repr_symm (b : orthonormal_basis ι 𝕜 E) (v : euclidean_space 𝕜 ι) :
  ∑ i , v i • b i = (b.repr.symm v) :=
by { classical, simpa using (b.to_basis.equiv_fun_symm_apply v).symm }

variable {v : ι → E}

/-- A basis that is orthonormal is an orthonormal basis. -/
def _root_.basis.to_orthonormal_basis (v : basis ι 𝕜 E) (hv : orthonormal 𝕜 v) :
  orthonormal_basis ι 𝕜 E :=
orthonormal_basis.of_repr $
linear_equiv.isometry_of_inner v.equiv_fun
begin
  intros x y,
  let p : euclidean_space 𝕜 ι := v.equiv_fun x,
  let q : euclidean_space 𝕜 ι := v.equiv_fun y,
  have key : ⟪p, q⟫ = ⟪∑ i, p i • v i, ∑ i, q i • v i⟫,
  { simp [sum_inner, inner_smul_left, hv.inner_right_fintype] },
  convert key,
  { rw [← v.equiv_fun.symm_apply_apply x, v.equiv_fun_symm_apply] },
  { rw [← v.equiv_fun.symm_apply_apply y, v.equiv_fun_symm_apply] }
end

@[simp] lemma _root_.basis.coe_to_orthonormal_basis_repr (v : basis ι 𝕜 E) (hv : orthonormal 𝕜 v) :
  ((v.to_orthonormal_basis hv).repr : E → euclidean_space 𝕜 ι) = v.equiv_fun :=
rfl

@[simp] lemma _root_.basis.coe_to_orthonormal_basis_repr_symm
  (v : basis ι 𝕜 E) (hv : orthonormal 𝕜 v) :
  ((v.to_orthonormal_basis hv).repr.symm : euclidean_space 𝕜 ι → E) = v.equiv_fun.symm :=
rfl

@[simp] lemma _root_.basis.to_basis_to_orthonormal_basis (v : basis ι 𝕜 E) (hv : orthonormal 𝕜 v) :
  (v.to_orthonormal_basis hv).to_basis = v :=
by simp [basis.to_orthonormal_basis, orthonormal_basis.to_basis]

@[simp] lemma _root_.basis.coe_to_orthonormal_basis (v : basis ι 𝕜 E) (hv : orthonormal 𝕜 v) :
  (v.to_orthonormal_basis hv : ι → E) = (v : ι → E) :=
calc (v.to_orthonormal_basis hv : ι → E) = ((v.to_orthonormal_basis hv).to_basis : ι → E) :
  by { classical, rw orthonormal_basis.coe_to_basis }
... = (v : ι → E) : by simp

/-- An orthonormal set that spans is an orthonormal basis -/
protected def mk (hon : orthonormal 𝕜 v) (hsp: submodule.span 𝕜 (set.range v) = ⊤):
  orthonormal_basis ι 𝕜 E :=
(basis.mk (orthonormal.linear_independent hon) hsp).to_orthonormal_basis (by rwa basis.coe_mk)

@[simp]
protected lemma coe_mk (hon : orthonormal 𝕜 v) (hsp: submodule.span 𝕜 (set.range v) = ⊤) :
  ⇑(orthonormal_basis.mk hon hsp) = v :=
by classical; rw [orthonormal_basis.mk, _root_.basis.coe_to_orthonormal_basis, basis.coe_mk]

end orthonormal_basis

/-- If `f : E ≃ₗᵢ[𝕜] E'` is a linear isometry of inner product spaces then an orthonormal basis `v`
of `E` determines a linear isometry `e : E' ≃ₗᵢ[𝕜] euclidean_space 𝕜 ι`. This result states that
`e` may be obtained either by transporting `v` to `E'` or by composing with the linear isometry
`E ≃ₗᵢ[𝕜] euclidean_space 𝕜 ι` provided by `v`. -/
@[simp] lemma basis.map_isometry_euclidean_of_orthonormal (v : basis ι 𝕜 E) (hv : orthonormal 𝕜 v)
  (f : E ≃ₗᵢ[𝕜] E') :
  ((v.map f.to_linear_equiv).to_orthonormal_basis (hv.map_linear_isometry_equiv f)).repr =
    f.symm.trans (v.to_orthonormal_basis hv).repr :=
linear_isometry_equiv.to_linear_equiv_injective $ v.map_equiv_fun _

/-- `ℂ` is isometric to `ℝ²` with the Euclidean inner product. -/
def complex.isometry_euclidean : ℂ ≃ₗᵢ[ℝ] (euclidean_space ℝ (fin 2)) :=
(complex.basis_one_I.to_orthonormal_basis
begin
  rw orthonormal_iff_ite,
  intros i, fin_cases i;
  intros j; fin_cases j;
  simp [real_inner_eq_re_inner]
end).repr

@[simp] lemma complex.isometry_euclidean_symm_apply (x : euclidean_space ℝ (fin 2)) :
  complex.isometry_euclidean.symm x = (x 0) + (x 1) * I :=
begin
  convert complex.basis_one_I.equiv_fun_symm_apply x,
  { simpa },
  { simp },
end

lemma complex.isometry_euclidean_proj_eq_self (z : ℂ) :
  ↑(complex.isometry_euclidean z 0) + ↑(complex.isometry_euclidean z 1) * (I : ℂ) = z :=
by rw [← complex.isometry_euclidean_symm_apply (complex.isometry_euclidean z),
  complex.isometry_euclidean.symm_apply_apply z]

@[simp] lemma complex.isometry_euclidean_apply_zero (z : ℂ) :
  complex.isometry_euclidean z 0 = z.re :=
by { conv_rhs { rw ← complex.isometry_euclidean_proj_eq_self z }, simp }

@[simp] lemma complex.isometry_euclidean_apply_one (z : ℂ) :
  complex.isometry_euclidean z 1 = z.im :=
by { conv_rhs { rw ← complex.isometry_euclidean_proj_eq_self z }, simp }

/-- The isometry between `ℂ` and a two-dimensional real inner product space given by a basis. -/
def complex.isometry_of_orthonormal {v : basis (fin 2) ℝ F} (hv : orthonormal ℝ v) : ℂ ≃ₗᵢ[ℝ] F :=
complex.isometry_euclidean.trans (v.to_orthonormal_basis hv).repr.symm

@[simp] lemma complex.map_isometry_of_orthonormal {v : basis (fin 2) ℝ F} (hv : orthonormal ℝ v)
  (f : F ≃ₗᵢ[ℝ] F') :
  complex.isometry_of_orthonormal (hv.map_linear_isometry_equiv f) =
    (complex.isometry_of_orthonormal hv).trans f :=
by simp [complex.isometry_of_orthonormal, linear_isometry_equiv.trans_assoc]

lemma complex.isometry_of_orthonormal_symm_apply
  {v : basis (fin 2) ℝ F} (hv : orthonormal ℝ v) (f : F) :
  (complex.isometry_of_orthonormal hv).symm f = (v.coord 0 f : ℂ) + (v.coord 1 f : ℂ) * I :=
by simp [complex.isometry_of_orthonormal]

lemma complex.isometry_of_orthonormal_apply
  {v : basis (fin 2) ℝ F} (hv : orthonormal ℝ v) (z : ℂ) :
  complex.isometry_of_orthonormal hv z = z.re • v 0 + z.im • v 1 :=
by simp [complex.isometry_of_orthonormal, (dec_trivial : (finset.univ : finset (fin 2)) = {0, 1})]

open finite_dimensional

/-- Given a natural number `n` equal to the `finrank` of a finite-dimensional inner product space,
there exists an isometry from the space to `euclidean_space 𝕜 (fin n)`. -/
def linear_isometry_equiv.of_inner_product_space
  [finite_dimensional 𝕜 E] {n : ℕ} (hn : finrank 𝕜 E = n) :
  E ≃ₗᵢ[𝕜] (euclidean_space 𝕜 (fin n)) :=
((fin_std_orthonormal_basis hn).to_orthonormal_basis
  (fin_std_orthonormal_basis_orthonormal hn)).repr

local attribute [instance] fact_finite_dimensional_of_finrank_eq_succ

/-- Given a natural number `n` one less than the `finrank` of a finite-dimensional inner product
space, there exists an isometry from the orthogonal complement of a nonzero singleton to
`euclidean_space 𝕜 (fin n)`. -/
def linear_isometry_equiv.from_orthogonal_span_singleton
  (n : ℕ) [fact (finrank 𝕜 E = n + 1)] {v : E} (hv : v ≠ 0) :
  (𝕜 ∙ v)ᗮ ≃ₗᵢ[𝕜] (euclidean_space 𝕜 (fin n)) :=
linear_isometry_equiv.of_inner_product_space (finrank_orthogonal_span_singleton hv)

section linear_isometry

variables {V : Type*} [inner_product_space 𝕜 V] [finite_dimensional 𝕜 V]

variables {S : submodule 𝕜 V} {L : S →ₗᵢ[𝕜] V}

open finite_dimensional

/-- Let `S` be a subspace of a finite-dimensional complex inner product space `V`.  A linear
isometry mapping `S` into `V` can be extended to a full isometry of `V`.

TODO:  The case when `S` is a finite-dimensional subspace of an infinite-dimensional `V`.-/
noncomputable def linear_isometry.extend (L : S →ₗᵢ[𝕜] V): V →ₗᵢ[𝕜] V :=
begin
  -- Build an isometry from Sᗮ to L(S)ᗮ through euclidean_space
  let d := finrank 𝕜 Sᗮ,
  have dim_S_perp : finrank 𝕜 Sᗮ = d := rfl,
  let LS := L.to_linear_map.range,
  have E : Sᗮ ≃ₗᵢ[𝕜] LSᗮ,
  { have dim_LS_perp : finrank 𝕜 LSᗮ = d,
    calc  finrank 𝕜 LSᗮ = finrank 𝕜 V - finrank 𝕜 LS : by simp only
        [← LS.finrank_add_finrank_orthogonal, add_tsub_cancel_left]
      ...               = finrank 𝕜 V - finrank 𝕜 S : by simp only
        [linear_map.finrank_range_of_inj L.injective]
      ...               = finrank 𝕜 Sᗮ : by simp only
        [← S.finrank_add_finrank_orthogonal, add_tsub_cancel_left]
      ...               = d : dim_S_perp,
    let BS := ((fin_std_orthonormal_basis dim_S_perp).to_orthonormal_basis
      (fin_std_orthonormal_basis_orthonormal dim_S_perp)),
    let BLS := ((fin_std_orthonormal_basis dim_LS_perp).to_orthonormal_basis
      (fin_std_orthonormal_basis_orthonormal dim_LS_perp)),
    exact BS.repr.trans BLS.repr.symm },
  let L3 := (LS)ᗮ.subtypeₗᵢ.comp E.to_linear_isometry,
  -- Project onto S and Sᗮ
  haveI : complete_space S := finite_dimensional.complete 𝕜 S,
  haveI : complete_space V := finite_dimensional.complete 𝕜 V,
  let p1 := (orthogonal_projection S).to_linear_map,
  let p2 := (orthogonal_projection Sᗮ).to_linear_map,
  -- Build a linear map from the isometries on S and Sᗮ
  let M := L.to_linear_map.comp p1 + L3.to_linear_map.comp p2,
  -- Prove that M is an isometry
  have M_norm_map : ∀ (x : V), ∥M x∥ = ∥x∥,
  { intro x,
    -- Apply M to the orthogonal decomposition of x
    have Mx_decomp : M x = L (p1 x) + L3 (p2 x),
    { simp only [linear_map.add_apply, linear_map.comp_apply, linear_map.comp_apply,
      linear_isometry.coe_to_linear_map]},
    -- Mx_decomp is the orthogonal decomposition of M x
    have Mx_orth : ⟪ L (p1 x), L3 (p2 x) ⟫ = 0,
    { have Lp1x : L (p1 x) ∈ L.to_linear_map.range := L.to_linear_map.mem_range_self (p1 x),
      have Lp2x : L3 (p2 x) ∈ (L.to_linear_map.range)ᗮ,
      { simp only [L3, linear_isometry.coe_comp, function.comp_app, submodule.coe_subtypeₗᵢ,
          ← submodule.range_subtype (LSᗮ)],
        apply linear_map.mem_range_self},
      apply submodule.inner_right_of_mem_orthogonal Lp1x Lp2x},
    -- Apply the Pythagorean theorem and simplify
    rw [← sq_eq_sq (norm_nonneg _) (norm_nonneg _), norm_sq_eq_add_norm_sq_projection x S],
    simp only [sq, Mx_decomp],
    rw norm_add_sq_eq_norm_sq_add_norm_sq_of_inner_eq_zero (L (p1 x)) (L3 (p2 x)) Mx_orth,
    simp only [linear_isometry.norm_map, p1, p2, continuous_linear_map.to_linear_map_eq_coe,
      add_left_inj, mul_eq_mul_left_iff, norm_eq_zero, true_or, eq_self_iff_true,
      continuous_linear_map.coe_coe, submodule.coe_norm, submodule.coe_eq_zero] },
  exact { to_linear_map := M, norm_map' := M_norm_map },
end

lemma linear_isometry.extend_apply (L : S →ₗᵢ[𝕜] V) (s : S):
  L.extend s = L s :=
begin
  haveI : complete_space S := finite_dimensional.complete 𝕜 S,
  simp only [linear_isometry.extend, continuous_linear_map.to_linear_map_eq_coe,
    ←linear_isometry.coe_to_linear_map],
  simp only [add_right_eq_self, linear_isometry.coe_to_linear_map,
    linear_isometry_equiv.coe_to_linear_isometry, linear_isometry.coe_comp, function.comp_app,
    orthogonal_projection_mem_subspace_eq_self, linear_map.coe_comp, continuous_linear_map.coe_coe,
    submodule.coe_subtype, linear_map.add_apply, submodule.coe_eq_zero,
    linear_isometry_equiv.map_eq_zero_iff, submodule.coe_subtypeₗᵢ,
    orthogonal_projection_mem_subspace_orthogonal_complement_eq_zero,
    submodule.orthogonal_orthogonal, submodule.coe_mem],
end

end linear_isometry

section matrix

open_locale matrix

variables {n m : ℕ}

local notation `⟪`x`, `y`⟫ₘ` := @inner 𝕜 (euclidean_space 𝕜 (fin m)) _ x y
local notation `⟪`x`, `y`⟫ₙ` := @inner 𝕜 (euclidean_space 𝕜 (fin n)) _ x y

/-- The inner product of a row of A and a row of B is an entry of B ⬝ Aᴴ. -/
lemma inner_matrix_row_row (A B : matrix (fin n) (fin m) 𝕜) (i j : (fin n)) :
  ⟪A i, B j⟫ₘ = (B ⬝ Aᴴ) j i := by {simp only [inner, matrix.mul_apply, star_ring_end_apply,
    matrix.conj_transpose_apply,mul_comm]}

/-- The inner product of a column of A and a column of B is an entry of Aᴴ ⬝ B -/
lemma inner_matrix_col_col (A B : matrix (fin n) (fin m) 𝕜) (i j : (fin m)) :
  ⟪Aᵀ i, Bᵀ j⟫ₙ = (Aᴴ ⬝ B) i j := rfl

end matrix


/-
Copyright (c) 2020 Kevin Kappelmann. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kevin Kappelmann
-/
import algebra.order.floor
import algebra.continued_fractions.basic
import algebra.order.field
/-!
# Computable Continued Fractions

## Summary

We formalise the standard computation of (regular) continued fractions for linear ordered floor
fields. The algorithm is rather simple. Here is an outline of the procedure adapted from Wikipedia:

Take a value `v`. We call `⌊v⌋` the *integer part* of `v` and `v − ⌊v⌋` the *fractional part* of
`v`.  A continued fraction representation of `v` can then be given by `[⌊v⌋; b₀, b₁, b₂,...]`, where
`[b₀; b₁, b₂,...]` recursively is the continued fraction representation of `1 / (v − ⌊v⌋)`.  This
process stops when the fractional part hits 0.

In other words: to calculate a continued fraction representation of a number `v`, write down the
integer part (i.e. the floor) of `v`. Subtract this integer part from `v`. If the difference is 0,
stop; otherwise find the reciprocal of the difference and repeat. The procedure will terminate if
and only if `v` is rational.

For an example, refer to `int_fract_pair.stream`.

## Main definitions

- `generalized_continued_fraction.int_fract_pair.stream`: computes the stream of integer and
  fractional parts of a given value as described in the summary.
- `generalized_continued_fraction.of`: computes the generalised continued fraction of a value `v`.
  In fact, it computes a regular continued fraction that terminates if and only if `v` is rational
  (those proofs will be added in a future commit).

## Implementation Notes

There is an intermediate definition `generalized_continued_fraction.int_fract_pair.seq1` between
`generalized_continued_fraction.int_fract_pair.stream` and `generalized_continued_fraction.of`
to wire up things. User should not (need to) directly interact with it.

The computation of the integer and fractional pairs of a value can elegantly be
captured by a recursive computation of a stream of option pairs. This is done in
`int_fract_pair.stream`. However, the type then does not guarantee the first pair to always be
`some` value, as expected by a continued fraction.

To separate concerns, we first compute a single head term that always exists in
`generalized_continued_fraction.int_fract_pair.seq1` followed by the remaining stream of option
pairs. This sequence with a head term (`seq1`) is then transformed to a generalized continued
fraction in `generalized_continued_fraction.of` by extracting the wanted integer parts of the
head term and the stream.

## References

- https://en.wikipedia.org/wiki/Continued_fraction

## Tags

numerics, number theory, approximations, fractions
-/

namespace generalized_continued_fraction

-- Fix a carrier `K`.
variable (K : Type*)

/--
We collect an integer part `b = ⌊v⌋` and fractional part `fr = v - ⌊v⌋` of a value `v` in a pair
`⟨b, fr⟩`.
-/
structure int_fract_pair := (b : ℤ) (fr : K)

variable {K}

/-! Interlude: define some expected coercions and instances. -/
namespace int_fract_pair

/-- Make an `int_fract_pair` printable. -/
instance [has_repr K] : has_repr (int_fract_pair K) :=
⟨λ p, "(b : " ++ (repr p.b) ++ ", fract : " ++ (repr p.fr) ++ ")"⟩

instance inhabited [inhabited K] : inhabited (int_fract_pair K) := ⟨⟨0, (default _)⟩⟩

/--
Maps a function `f` on the fractional components of a given pair.
-/
def mapFr {β : Type*} (f : K → β) (gp : int_fract_pair K) : int_fract_pair β :=
⟨gp.b, f gp.fr⟩

section coe
/-! Interlude: define some expected coercions. -/
/- Fix another type `β` which we will convert to. -/
variables {β : Type*} [has_coe K β]

/-- Coerce a pair by coercing the fractional component. -/
instance has_coe_to_int_fract_pair : has_coe (int_fract_pair K) (int_fract_pair β) :=
⟨mapFr coe⟩

@[simp, norm_cast]
lemma coe_to_int_fract_pair {b : ℤ} {fr : K} :
  (↑(int_fract_pair.mk b fr) : int_fract_pair β) = int_fract_pair.mk b (↑fr : β) :=
rfl

end coe

-- Note: this could be relaxed to something like `linear_ordered_division_ring` in the
-- future.
/- Fix a discrete linear ordered field with `floor` function. -/
variables [linear_ordered_field K] [floor_ring K]

/-- Creates the integer and fractional part of a value `v`, i.e. `⟨⌊v⌋, v - ⌊v⌋⟩`. -/
protected def of (v : K) : int_fract_pair K := ⟨⌊v⌋, int.fract v⟩

/--
Creates the stream of integer and fractional parts of a value `v` needed to obtain the continued
fraction representation of `v` in `generalized_continued_fraction.of`. More precisely, given a value
`v : K`, it recursively computes a stream of option `ℤ × K` pairs as follows:
- `stream v 0 = some ⟨⌊v⌋, v - ⌊v⌋⟩`
- `stream v (n + 1) = some ⟨⌊frₙ⁻¹⌋, frₙ⁻¹ - ⌊frₙ⁻¹⌋⟩`,
    if `stream v n = some ⟨_, frₙ⟩` and `frₙ ≠ 0`
- `stream v (n + 1) = none`, otherwise

For example, let `(v : ℚ) := 3.4`. The process goes as follows:
- `stream v 0 = some ⟨⌊v⌋, v - ⌊v⌋⟩ = some ⟨3, 0.4⟩`
- `stream v 1 = some ⟨⌊0.4⁻¹⌋, 0.4⁻¹ - ⌊0.4⁻¹⌋⟩ = some ⟨⌊2.5⌋, 2.5 - ⌊2.5⌋⟩ = some ⟨2, 0.5⟩`
- `stream v 2 = some ⟨⌊0.5⁻¹⌋, 0.5⁻¹ - ⌊0.5⁻¹⌋⟩ = some ⟨⌊2⌋, 2 - ⌊2⌋⟩ = some ⟨2, 0⟩`
- `stream v n = none`, for `n ≥ 3`
-/
protected def stream (v : K) : stream $ option (int_fract_pair K)
| 0 := some (int_fract_pair.of v)
| (n + 1) := do ap_n ← stream n,
  if ap_n.fr = 0 then none else int_fract_pair.of ap_n.fr⁻¹

/--
Shows that `int_fract_pair.stream` has the sequence property, that is once we return `none` at
position `n`, we also return `none` at `n + 1`.
-/
lemma stream_is_seq (v : K) : (int_fract_pair.stream v).is_seq :=
by { assume _ hyp, simp [int_fract_pair.stream, hyp] }

/--
Uses `int_fract_pair.stream` to create a sequence with head (i.e. `seq1`) of integer and fractional
parts of a value `v`. The first value of `int_fract_pair.stream` is never `none`, so we can safely
extract it and put the tail of the stream in the sequence part.

This is just an intermediate representation and users should not (need to) directly interact with
it. The setup of rewriting/simplification lemmas that make the definitions easy to use is done in
`algebra.continued_fractions.computation.translations`.
-/
protected def seq1 (v : K) : seq1 $ int_fract_pair K :=
⟨ int_fract_pair.of v,--the head
  seq.tail -- take the tail of `int_fract_pair.stream` since the first element is already in the
  -- head create a sequence from `int_fract_pair.stream`
  ⟨ int_fract_pair.stream v, -- the underlying stream
    @stream_is_seq _ _ _ v ⟩ ⟩ -- the proof that the stream is a sequence

end int_fract_pair

/--
Returns the `generalized_continued_fraction` of a value. In fact, the returned gcf is also
a `continued_fraction` that terminates if and only if `v` is rational (those proofs will be
added in a future commit).

The continued fraction representation of `v` is given by `[⌊v⌋; b₀, b₁, b₂,...]`, where
`[b₀; b₁, b₂,...]` recursively is the continued fraction representation of `1 / (v − ⌊v⌋)`. This
process stops when the fractional part `v - ⌊v⌋` hits 0 at some step.

The implementation uses `int_fract_pair.stream` to obtain the partial denominators of the continued
fraction. Refer to said function for more details about the computation process.
-/
protected def of [linear_ordered_field K] [floor_ring K] (v : K) :
  generalized_continued_fraction K :=
let ⟨h, s⟩ := int_fract_pair.seq1 v in -- get the sequence of integer and fractional parts.
⟨ h.b, -- the head is just the first integer part
  s.map (λ p, ⟨1, p.b⟩) ⟩ -- the sequence consists of the remaining integer parts as the partial
                          -- denominators; all partial numerators are simply 1

end generalized_continued_fraction


import .affine_coordinate_space

/-
This file exports
- std_basis, given finite index set, return standard vector-space basis
- std_frame, return standard frame on d-dimensional affine space
-/

/-
We've shown that <aff_pt_coord_tuple, aff_vec_coord_tuple>
constitutes an  affine space.There's no notion of a frame at this point.
However,  we can endow such a space with a standard frame, taking the point,
<1, 0, ..., 0> as the standard origin and the vectors, <0, 1, 0, ...>,
..., <0, 0, ..., 1> as the standard basis for the vector space. To
this end, we now define what it means to be a frame for an affine space
and we provide a function for obtaining a standard basis for any given
space of this kind.
-/

namespace aff_basis

universes u v w x

variables (X : Type u) (K : Type v) (V : Type w) (n : ℕ) (k : K)
[inhabited K] [field K] [add_comm_group V] [vector_space K V] [affine_space V X]

open vecl

abbreviation zero := zero_vector K n

def list.to_basis_vec : fin n → list K := λ x, (zero K n).update_nth (x.1 + 1) 1

lemma len_basis_vec_fixed (x : fin n) : (list.to_basis_vec K n x).length = n + 1 := sorry

lemma head_basis_vec_fixed (x : fin n) : (list.to_basis_vec K n x).head = 0 := sorry

def std_basis : fin n → aff_vec_coord_tuple K n :=
λ x, ⟨list.to_basis_vec K n x, len_basis_vec_fixed K n x, head_basis_vec_fixed K n x⟩

lemma std_is_basis : is_basis K (std_basis K n) := sorry

/-
Here we equip any generic affine coordinate space with a standard frame
-/
def aff_coord_space_std_frame :
    affine_frame (aff_pt_coord_tuple K n) K (aff_vec_coord_tuple K n) (fin n) :=
        ⟨pt_zero K n, std_basis K n, std_is_basis K n⟩

end aff_basis

/-
What's funny is that we don't actually have an explicit abstraction of
affine coordinate space, e.g., as a type.
-/