import laurent_measures.ses
import laurent_measures.condensed
import real_measures.condensed
import condensed.condensify
import laurent_measures.prop72 -- kmb's attempt to tidy up the analysis argument

universe u

noncomputable theory

open category_theory

open_locale nnreal

namespace laurent_measures

open laurent_measures_ses ProFiltPseuNormGrpWithTinv₁

section theta

variables (p : ℝ≥0) [fact (0 < p)] [fact (p < 1)]
local notation `r` := @r p

/-- If `0 < (p : ℝ≥0) < 1` and `S : Fintype` then `Θ p S` evaluates Laurent measures at 2⁻¹. -/
def Θ (S : Fintype.{u}) :
  (Fintype_LaurentMeasures.{u} r ⋙ PFPNGT₁_to_CHFPNG₁ₑₗ.{u} r).obj S ⟶
  (real_measures.functor p).obj S :=
strict_comphaus_filtered_pseudo_normed_group_hom.mk' (θ_to_add p)
begin
  intro c,
  use θ_bound' p c,
  convert continuous_θ_c p S c,
  simp only [θ_c, one_mul, eq_mpr_eq_cast, set_coe_cast],
  refl,
end

def Θ_fintype_nat_trans :
  (Fintype_LaurentMeasures.{u} r ⋙ PFPNGT₁_to_CHFPNG₁ₑₗ.{u} r) ⟶ (real_measures.functor.{u} p) :=
{ app := λ S, Θ p S,
  naturality' := λ S T f, by { ext x t, apply θ_natural, } }
.

end theta

section ses

variables (p : ℝ≥0) [fact (0 < p)] [fact (p < 1)]
local notation `r` := @r p

open CompHausFiltPseuNormGrp₁

lemma psi_bound (S : Fintype) (c' : ℝ≥0) ⦃F : laurent_measures r S⦄ (hF1 : (Θ p S) F = 0)
  (hF2 : ∥F∥₊ ≤ c') : ∥ψ F hF1∥₊ ≤ c' * (2 - r⁻¹)⁻¹ :=
begin
  delta ψ,
  rw nnnorm_def at hF2 ⊢,
  simp only [coe_mk],
  delta Θ at hF1,
  have foo : ∀ (s : S), ∑' (n : ℤ), ∥ite (F.d ≤ n) ((finset.range (n - F.d).nat_abs.succ).sum
    (λ (l : ℕ), (F s (n - 1 - l) : ℝ) * 2 ^ l)) 0∥₊ * r ^ n ≤
    (2 - r⁻¹)⁻¹ * ∑' n, ∥(F s n : ℝ)∥₊ * r ^ n :=
  λ s, by convert psi_aux_lemma.key_tsum_lemma (λ n, (F s n : ℝ)) r r_lt_one half_lt_r F.d
    (λ n hnd, lt_d_eq_zero' F s n hnd) (F.summable' s) (congr_fun hF1 s),
  convert le_trans (finset.sum_le_sum (λ (s : S) _, foo s)) _,
  { norm_cast },
  simp_rw real.nnnorm_int,
  rw [← finset.mul_sum, mul_comm],
  exact (nnreal.mul_le_mul_right hF2 _),
end

theorem short_exact (S : Profinite) :
  short_exact ((condensify_Tinv2 _).app S) ((condensify_map $ Θ_fintype_nat_trans p).app S) :=
begin
  refine condensify_nonstrict_exact _ _ (r⁻¹ + 2) (Tinv2_bound_by _)
    -- C₂ bound (note that `2⁻¹ < r < 1` implies the max is always the left term)
    (λ c, max (c * ( r⁻¹ + 2) * ( 2 - r⁻¹)⁻¹) c)
    -- C₄ bound (note that `2⁻¹ < r < 1` implies that the max is always the left term)
    (λ c, max ((1 - r)⁻¹ * c) c)
    -- if you want to remove `max` from C₂ then you do that here
    (λ c, le_max_right _ c)
    -- if you want to remove `max` from C₄ then you do that here
    (λ c, le_max_right _ c)
    (λ S, injective_ϕ')
    (λ S, by { ext1 F, apply θ_ϕ_complex }) _ _ _,

    -- now two goals left, basically corresponding to
    -- existence of a bounded splitting of ϕ (namely ψ)
    -- and existence of a bounded splitting of θ
    -- (namely binary expansion).

    -- Here's a proof of the ϕ goal using ψ.
    { clear S,
      -- change to unbundled language
      rintros S c' (F : laurent_measures r S) ⟨(hF1 : Θ p S F = 0),
        (hF2 : ∥F∥₊ ≤ c')⟩,
      simp only [set.mem_image],
      refine ⟨ψ F hF1, _, θ_ϕ_split_exact F hF1⟩,
      change (∥_∥₊ : ℝ≥0) ≤ _,
      -- because of silly definition of `C₂` involving max :-)
      refine le_trans _ (mul_le_mul_right' (le_max_left _ _) _),
      convert psi_bound p S c' hF1 hF2 using 1,
      have h1 : 2⁻¹ < r := half_lt_r,
      have h2 : (2 - 1 / r) ≠ 0 := ne_of_gt (tsub_pos_of_lt
        (by { rw [one_div], exact r_inv_lt_2 })),
      have h3 : r ≠ 0 := ne_of_gt r_pos,
      field_simp,
      simp [mul_tsub, tsub_mul, one_div, mul_assoc, mul_inv_cancel h3],
      ring_nf, },
  -- Now here's a proof of the θ goal using binary expansions
    { clear S,
      rintros S c' (f : real_measures p S) (hf : _ ≤ _),
      let measure_aux : laurent_measures r S :=
      { to_fun := λ s n,
        if 0 ≤ f s then nnreal.int.binary (∥f s∥₊) n
        else -nnreal.int.binary (∥f s∥₊) n,
        summable' := λ s, begin
          convert nnreal.int.binary_summable (∥f s∥₊) (r_lt_one : r < 1),
          ext,
          split_ifs;
          simp,
        end },
      refine ⟨measure_aux, _⟩,
      change _ ≤ _ ∧ _,
      split,
      { refine le_trans _ (le_max_left _ _),
        refine le_trans _ (mul_le_mul_of_nonneg_left hf zero_le'),
        change finset.sum _ _ ≤ _ * finset.sum _ _,
        rw finset.mul_sum,
        refine finset.sum_le_sum (λ s _, _),
        rcases (eq_zero_or_pos : ∥f s∥₊ = 0 ∨ _) with (h0 | hpos),
        { simp [h0, measure_aux] },
        { convert le_trans (theta_aux_lemma.tsum_le
            (∥f s∥₊) (r_pos : 0 < r) (r_lt_one : r < 1)) _,
          { ext n, congr', dsimp [measure_aux], split_ifs; simp },
          { rw mul_comm,
            apply nnreal.mul_le_mul_left,
            rw ← nnreal.rpow_int_cast,
            convert nnreal.rpow_le_rpow_of_exponent_ge
              (r_pos : 0 < r) (r_lt_one.le) (int.le_ceil _) using 1,
            delta «r»,
            rw [← nnreal.rpow_mul, mul_comm, nnreal.rpow_mul],
            congr', symmetry,
            rw ← nnreal.coe_eq,
            exact nnreal.pow_log_div_log_self hpos (by norm_num) (by norm_num), } } },
      { delta Θ_fintype_nat_trans Θ θ_to_add θ theta.ϑ,
        dsimp,
        ext s,
        split_ifs,
        { convert nnreal.coe_eq.2 (nnreal.int.binary_sum ∥f s∥₊),
          push_cast, rw real.nnnorm_of_nonneg h, refl, },
        { convert neg_inj.2 (nnreal.coe_eq.2 (nnreal.int.binary_sum ∥f s∥₊)),
          { push_cast, rw ← tsum_neg, congr', ext, simp },
          { push_neg at h,
            rw real.neg_nnnorm_of_neg h, } } } },
end

end ses

end laurent_measures


/-
Copyright (c) 2019 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Fabian Glöckle
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.linear_algebra.finite_dimensional
import Mathlib.tactic.apply_fun
import Mathlib.PostPort

universes u_1 u_2 u_3 u_4 u v w l

namespace Mathlib

/-!
# Dual vector spaces

The dual space of an R-module M is the R-module of linear maps `M → R`.

## Main definitions

* `dual R M` defines the dual space of M over R.
* Given a basis for a K-vector space `V`, `is_basis.to_dual` produces a map from `V` to `dual K V`.
* Given families of vectors `e` and `ε`, `dual_pair e ε` states that these families have the
  characteristic properties of a basis and a dual.

## Main results

* `to_dual_equiv` : the dual space is linearly equivalent to the primal space.
* `dual_pair.is_basis` and `dual_pair.eq_dual`: if `e` and `ε` form a dual pair, `e` is a basis and
  `ε` is its dual basis.

## Notation

We sometimes use `V'` as local notation for `dual K V`.

-/

namespace module

/-- The dual space of an R-module M is the R-module of linear maps `M → R`. -/
def dual (R : Type u_1) (M : Type u_2) [comm_ring R] [add_comm_group M] [module R M] :=
  linear_map R M R

namespace dual

protected instance inhabited (R : Type u_1) (M : Type u_2) [comm_ring R] [add_comm_group M] [module R M] : Inhabited (dual R M) :=
  id linear_map.inhabited

protected instance has_coe_to_fun (R : Type u_1) (M : Type u_2) [comm_ring R] [add_comm_group M] [module R M] : has_coe_to_fun (dual R M) :=
  has_coe_to_fun.mk (fun (x : dual R M) => M → R) linear_map.to_fun

/-- Maps a module M to the dual of the dual of M. See `vector_space.erange_coe` and
`vector_space.eval_equiv`. -/
def eval (R : Type u_1) (M : Type u_2) [comm_ring R] [add_comm_group M] [module R M] : linear_map R M (dual R (dual R M)) :=
  linear_map.flip linear_map.id

@[simp] theorem eval_apply (R : Type u_1) (M : Type u_2) [comm_ring R] [add_comm_group M] [module R M] (v : M) (a : dual R M) : coe_fn (coe_fn (eval R M) v) a = coe_fn a v := sorry

/-- The transposition of linear maps, as a linear map from `M →ₗ[R] M'` to
`dual R M' →ₗ[R] dual R M`. -/
def transpose {R : Type u_1} {M : Type u_2} [comm_ring R] [add_comm_group M] [module R M] {M' : Type u_3} [add_comm_group M'] [module R M'] : linear_map R (linear_map R M M') (linear_map R (dual R M') (dual R M)) :=
  linear_map.flip (linear_map.llcomp R M M' R)

theorem transpose_apply {R : Type u_1} {M : Type u_2} [comm_ring R] [add_comm_group M] [module R M] {M' : Type u_3} [add_comm_group M'] [module R M'] (u : linear_map R M M') (l : dual R M') : coe_fn (coe_fn transpose u) l = linear_map.comp l u :=
  rfl

theorem transpose_comp {R : Type u_1} {M : Type u_2} [comm_ring R] [add_comm_group M] [module R M] {M' : Type u_3} [add_comm_group M'] [module R M'] {M'' : Type u_4} [add_comm_group M''] [module R M''] (u : linear_map R M' M'') (v : linear_map R M M') : coe_fn transpose (linear_map.comp u v) = linear_map.comp (coe_fn transpose v) (coe_fn transpose u) :=
  rfl

end dual

end module

namespace is_basis

/-- The linear map from a vector space equipped with basis to its dual vector space,
taking basis elements to corresponding dual basis elements. -/
def to_dual {K : Type u} {V : Type v} {ι : Type w} [field K] [add_comm_group V] [vector_space K V] [de : DecidableEq ι] (B : ι → V) (h : is_basis K B) : linear_map K V (module.dual K V) :=
  constr h fun (v : ι) => constr h fun (w : ι) => ite (w = v) 1 0

theorem to_dual_apply {K : Type u} {V : Type v} {ι : Type w} [field K] [add_comm_group V] [vector_space K V] [de : DecidableEq ι] {B : ι → V} (h : is_basis K B) (i : ι) (j : ι) : coe_fn (coe_fn (to_dual B h) (B i)) (B j) = ite (i = j) 1 0 := sorry

@[simp] theorem to_dual_total_left {K : Type u} {V : Type v} {ι : Type w} [field K] [add_comm_group V] [vector_space K V] [de : DecidableEq ι] {B : ι → V} (h : is_basis K B) (f : ι →₀ K) (i : ι) : coe_fn (coe_fn (to_dual B h) (coe_fn (finsupp.total ι V K B) f)) (B i) = coe_fn f i := sorry

@[simp] theorem to_dual_total_right {K : Type u} {V : Type v} {ι : Type w} [field K] [add_comm_group V] [vector_space K V] [de : DecidableEq ι] {B : ι → V} (h : is_basis K B) (f : ι →₀ K) (i : ι) : coe_fn (coe_fn (to_dual B h) (B i)) (coe_fn (finsupp.total ι V K B) f) = coe_fn f i := sorry

theorem to_dual_apply_left {K : Type u} {V : Type v} {ι : Type w} [field K] [add_comm_group V] [vector_space K V] [de : DecidableEq ι] {B : ι → V} (h : is_basis K B) (v : V) (i : ι) : coe_fn (coe_fn (to_dual B h) v) (B i) = coe_fn (coe_fn (repr h) v) i := sorry

theorem to_dual_apply_right {K : Type u} {V : Type v} {ι : Type w} [field K] [add_comm_group V] [vector_space K V] [de : DecidableEq ι] {B : ι → V} (h : is_basis K B) (i : ι) (v : V) : coe_fn (coe_fn (to_dual B h) (B i)) v = coe_fn (coe_fn (repr h) v) i := sorry

/-- `h.to_dual_flip v` is the linear map sending `w` to `h.to_dual w v`. -/
def to_dual_flip {K : Type u} {V : Type v} {ι : Type w} [field K] [add_comm_group V] [vector_space K V] [de : DecidableEq ι] (B : ι → V) (h : is_basis K B) (v : V) : linear_map K V K :=
  coe_fn (linear_map.flip (to_dual B h)) v

-- TODO: unify this with `finsupp.lapply`.

/-- Evaluation of finitely supported functions at a fixed point `i`, as a `K`-linear map. -/
def eval_finsupp_at {K : Type u} {ι : Type w} [field K] (i : ι) : linear_map K (ι →₀ K) K :=
  linear_map.mk (fun (f : ι →₀ K) => coe_fn f i) sorry sorry

/-- `h.coord_fun i` sends vectors to their `i`'th coordinate with respect to the basis `h`. -/
def coord_fun {K : Type u} {V : Type v} {ι : Type w} [field K] [add_comm_group V] [vector_space K V] {B : ι → V} (h : is_basis K B) (i : ι) : linear_map K V K :=
  linear_map.comp (eval_finsupp_at i) (repr h)

theorem coord_fun_eq_repr {K : Type u} {V : Type v} {ι : Type w} [field K] [add_comm_group V] [vector_space K V] {B : ι → V} (h : is_basis K B) (v : V) (i : ι) : coe_fn (coord_fun h i) v = coe_fn (coe_fn (repr h) v) i :=
  rfl

-- TODO: this lemma should be called something like `to_dual_flip_apply`

theorem to_dual_swap_eq_to_dual {K : Type u} {V : Type v} {ι : Type w} [field K] [add_comm_group V] [vector_space K V] [de : DecidableEq ι] {B : ι → V} (h : is_basis K B) (v : V) (w : V) : coe_fn (to_dual_flip B h v) w = coe_fn (coe_fn (to_dual B h) w) v :=
  rfl

theorem to_dual_eq_repr {K : Type u} {V : Type v} {ι : Type w} [field K] [add_comm_group V] [vector_space K V] [de : DecidableEq ι] {B : ι → V} (h : is_basis K B) (v : V) (i : ι) : coe_fn (coe_fn (to_dual B h) v) (B i) = coe_fn (coe_fn (repr h) v) i :=
  to_dual_apply_left h v i

theorem to_dual_eq_equiv_fun {K : Type u} {V : Type v} {ι : Type w} [field K] [add_comm_group V] [vector_space K V] [de : DecidableEq ι] {B : ι → V} (h : is_basis K B) [fintype ι] (v : V) (i : ι) : coe_fn (coe_fn (to_dual B h) v) (B i) = coe_fn (equiv_fun h) v i := sorry

theorem to_dual_inj {K : Type u} {V : Type v} {ι : Type w} [field K] [add_comm_group V] [vector_space K V] [de : DecidableEq ι] {B : ι → V} (h : is_basis K B) (v : V) (a : coe_fn (to_dual B h) v = 0) : v = 0 := sorry

theorem to_dual_ker {K : Type u} {V : Type v} {ι : Type w} [field K] [add_comm_group V] [vector_space K V] [de : DecidableEq ι] {B : ι → V} (h : is_basis K B) : linear_map.ker (to_dual B h) = ⊥ :=
  iff.mpr linear_map.ker_eq_bot' (to_dual_inj h)

theorem to_dual_range {K : Type u} {V : Type v} {ι : Type w} [field K] [add_comm_group V] [vector_space K V] [de : DecidableEq ι] {B : ι → V} (h : is_basis K B) [fin : fintype ι] : linear_map.range (to_dual B h) = ⊤ := sorry

/-- Maps a basis for `V` to a basis for the dual space. -/
def dual_basis {K : Type u} {V : Type v} {ι : Type w} [field K] [add_comm_group V] [vector_space K V] [de : DecidableEq ι] {B : ι → V} (h : is_basis K B) : ι → module.dual K V :=
  fun (i : ι) => coe_fn (to_dual B h) (B i)

theorem dual_lin_independent {K : Type u} {V : Type v} {ι : Type w} [field K] [add_comm_group V] [vector_space K V] [de : DecidableEq ι] {B : ι → V} (h : is_basis K B) : linear_independent K (dual_basis h) :=
  linear_independent.map' (and.left h) (to_dual B h) (to_dual_ker h)

@[simp] theorem dual_basis_apply_self {K : Type u} {V : Type v} {ι : Type w} [field K] [add_comm_group V] [vector_space K V] [de : DecidableEq ι] {B : ι → V} (h : is_basis K B) (i : ι) (j : ι) : coe_fn (dual_basis h i) (B j) = ite (i = j) 1 0 :=
  to_dual_apply h i j

/-- A vector space is linearly equivalent to its dual space. -/
def to_dual_equiv {K : Type u} {V : Type v} {ι : Type w} [field K] [add_comm_group V] [vector_space K V] [de : DecidableEq ι] (B : ι → V) (h : is_basis K B) [fintype ι] : linear_equiv K V (module.dual K V) :=
  linear_equiv.of_bijective (to_dual B h) sorry sorry

theorem dual_basis_is_basis {K : Type u} {V : Type v} {ι : Type w} [field K] [add_comm_group V] [vector_space K V] [de : DecidableEq ι] {B : ι → V} (h : is_basis K B) [fintype ι] : is_basis K (dual_basis h) :=
  linear_equiv.is_basis h (to_dual_equiv B h)

@[simp] theorem total_dual_basis {K : Type u} {V : Type v} {ι : Type w} [field K] [add_comm_group V] [vector_space K V] [de : DecidableEq ι] {B : ι → V} (h : is_basis K B) [fintype ι] (f : ι →₀ K) (i : ι) : coe_fn (coe_fn (finsupp.total ι (module.dual K V) K (dual_basis h)) f) (B i) = coe_fn f i := sorry

theorem dual_basis_repr {K : Type u} {V : Type v} {ι : Type w} [field K] [add_comm_group V] [vector_space K V] [de : DecidableEq ι] {B : ι → V} (h : is_basis K B) [fintype ι] (l : module.dual K V) (i : ι) : coe_fn (coe_fn (repr (dual_basis_is_basis h)) l) i = coe_fn l (B i) := sorry

theorem dual_basis_equiv_fun {K : Type u} {V : Type v} {ι : Type w} [field K] [add_comm_group V] [vector_space K V] [de : DecidableEq ι] {B : ι → V} (h : is_basis K B) [fintype ι] (l : module.dual K V) (i : ι) : coe_fn (equiv_fun (dual_basis_is_basis h)) l i = coe_fn l (B i) := sorry

theorem dual_basis_apply {K : Type u} {V : Type v} {ι : Type w} [field K] [add_comm_group V] [vector_space K V] [de : DecidableEq ι] {B : ι → V} (h : is_basis K B) [fintype ι] (i : ι) (v : V) : coe_fn (dual_basis h i) v = coe_fn (equiv_fun h) v i :=
  to_dual_apply_right h i v

@[simp] theorem to_dual_to_dual {K : Type u} {V : Type v} {ι : Type w} [field K] [add_comm_group V] [vector_space K V] [de : DecidableEq ι] {B : ι → V} (h : is_basis K B) [fintype ι] : linear_map.comp (to_dual (dual_basis h) (dual_basis_is_basis h)) (to_dual B h) = module.dual.eval K V := sorry

theorem dual_dim_eq {K : Type u} {V : Type v} {ι : Type w} [field K] [add_comm_group V] [vector_space K V] {B : ι → V} (h : is_basis K B) [fintype ι] : cardinal.lift (vector_space.dim K V) = vector_space.dim K (module.dual K V) := sorry

end is_basis

namespace vector_space

theorem eval_ker {K : Type u} {V : Type v} [field K] [add_comm_group V] [vector_space K V] : linear_map.ker (module.dual.eval K V) = ⊥ := sorry

theorem dual_dim_eq {K : Type u} {V : Type v} [field K] [add_comm_group V] [vector_space K V] [finite_dimensional K V] : cardinal.lift (dim K V) = dim K (module.dual K V) := sorry

theorem erange_coe {K : Type u} {V : Type v} [field K] [add_comm_group V] [vector_space K V] [finite_dimensional K V] : linear_map.range (module.dual.eval K V) = ⊤ := sorry

/-- A vector space is linearly equivalent to the dual of its dual space. -/
def eval_equiv {K : Type u} {V : Type v} [field K] [add_comm_group V] [vector_space K V] [finite_dimensional K V] : linear_equiv K V (module.dual K (module.dual K V)) :=
  linear_equiv.of_bijective (module.dual.eval K V) eval_ker erange_coe

end vector_space

/-- `e` and `ε` have characteristic properties of a basis and its dual -/
structure dual_pair {K : Type u} {V : Type v} {ι : Type w} [DecidableEq ι] [field K] [add_comm_group V] [vector_space K V] (e : ι → V) (ε : ι → module.dual K V)
where
  eval : ∀ (i j : ι), coe_fn (ε i) (e j) = ite (i = j) 1 0
  total : ∀ {v : V}, (∀ (i : ι), coe_fn (ε i) v = 0) → v = 0
  finite : (v : V) → fintype ↥(set_of fun (i : ι) => coe_fn (ε i) v ≠ 0)

namespace dual_pair

/-- The coefficients of `v` on the basis `e` -/
def coeffs {K : Type u} {V : Type v} {ι : Type w} [dι : DecidableEq ι] [field K] [add_comm_group V] [vector_space K V] {e : ι → V} {ε : ι → module.dual K V} (h : dual_pair e ε) (v : V) : ι →₀ K :=
  finsupp.mk (set.to_finset (set_of fun (i : ι) => coe_fn (ε i) v ≠ 0)) (fun (i : ι) => coe_fn (ε i) v) sorry

@[simp] theorem coeffs_apply {K : Type u} {V : Type v} {ι : Type w} [dι : DecidableEq ι] [field K] [add_comm_group V] [vector_space K V] {e : ι → V} {ε : ι → module.dual K V} (h : dual_pair e ε) (v : V) (i : ι) : coe_fn (coeffs h v) i = coe_fn (ε i) v :=
  rfl

/-- linear combinations of elements of `e`.
This is a convenient abbreviation for `finsupp.total _ V K e l` -/
def lc {K : Type u} {V : Type v} {ι : Type w} [field K] [add_comm_group V] [vector_space K V] (e : ι → V) (l : ι →₀ K) : V :=
  finsupp.sum l fun (i : ι) (a : K) => a • e i

theorem dual_lc {K : Type u} {V : Type v} {ι : Type w} [dι : DecidableEq ι] [field K] [add_comm_group V] [vector_space K V] {e : ι → V} {ε : ι → module.dual K V} (h : dual_pair e ε) (l : ι →₀ K) (i : ι) : coe_fn (ε i) (lc e l) = coe_fn l i := sorry

@[simp] theorem coeffs_lc {K : Type u} {V : Type v} {ι : Type w} [dι : DecidableEq ι] [field K] [add_comm_group V] [vector_space K V] {e : ι → V} {ε : ι → module.dual K V} (h : dual_pair e ε) (l : ι →₀ K) : coeffs h (lc e l) = l := sorry

/-- For any v : V n, \sum_{p ∈ Q n} (ε p v) • e p = v -/
theorem decomposition {K : Type u} {V : Type v} {ι : Type w} [dι : DecidableEq ι] [field K] [add_comm_group V] [vector_space K V] {e : ι → V} {ε : ι → module.dual K V} (h : dual_pair e ε) (v : V) : lc e (coeffs h v) = v := sorry

theorem mem_of_mem_span {K : Type u} {V : Type v} {ι : Type w} [dι : DecidableEq ι] [field K] [add_comm_group V] [vector_space K V] {e : ι → V} {ε : ι → module.dual K V} (h : dual_pair e ε) {H : set ι} {x : V} (hmem : x ∈ submodule.span K (e '' H)) (i : ι) : coe_fn (ε i) x ≠ 0 → i ∈ H := sorry

theorem is_basis {K : Type u} {V : Type v} {ι : Type w} [dι : DecidableEq ι] [field K] [add_comm_group V] [vector_space K V] {e : ι → V} {ε : ι → module.dual K V} (h : dual_pair e ε) : is_basis K e := sorry

theorem eq_dual {K : Type u} {V : Type v} {ι : Type w} [dι : DecidableEq ι] [field K] [add_comm_group V] [vector_space K V] {e : ι → V} {ε : ι → module.dual K V} (h : dual_pair e ε) : ε = is_basis.dual_basis (is_basis h) := sorry


/-
Copyright (c) 2021 Oliver Nash. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Oliver Nash
-/
import algebra.algebra.restrict_scalars
import algebra.lie.tensor_product

/-!
# Extension and restriction of scalars for Lie algebras

Lie algebras have a well-behaved theory of extension and restriction of scalars.

## Main definitions

 * `lie_algebra.extend_scalars.lie_algebra`
 * `lie_algebra.restrict_scalars.lie_algebra`

## Tags

lie ring, lie algebra, extension of scalars, restriction of scalars, base change
-/

universes u v w w₁ w₂ w₃

open_locale tensor_product

variables (R : Type u) (A : Type w) (L : Type v)

namespace lie_algebra

namespace extend_scalars

variables [comm_ring R] [comm_ring A] [algebra R A] [lie_ring L] [lie_algebra R L]

/-- The Lie bracket on the extension of a Lie algebra `L` over `R` by an algebra `A` over `R`.

In fact this bracket is fully `A`-bilinear but without a significant upgrade to our mixed-scalar
support in the tensor product library, it is far easier to bootstrap like this, starting with the
definition below. -/
private def bracket' : (A ⊗[R] L) →ₗ[R] (A ⊗[R] L) →ₗ[R] A ⊗[R] L :=
tensor_product.curry $
  (tensor_product.map (linear_map.mul' R _) (lie_module.to_module_hom R L L : L ⊗[R] L →ₗ[R] L))
  ∘ₗ ↑(tensor_product.tensor_tensor_tensor_comm R A L A L)

@[simp] private lemma bracket'_tmul (s t : A) (x y : L) :
  bracket' R A L (s ⊗ₜ[R] x) (t ⊗ₜ[R] y) = (s*t) ⊗ₜ ⁅x, y⁆ :=
by simp [bracket']

instance : has_bracket (A ⊗[R] L) (A ⊗[R] L) := { bracket := λ x y, bracket' R A L x y, }

private lemma bracket_def (x y : A ⊗[R] L) : ⁅x, y⁆ = bracket' R A L x y := rfl

@[simp] lemma bracket_tmul (s t : A) (x y : L) : ⁅s ⊗ₜ[R] x, t ⊗ₜ[R] y⁆ = (s*t) ⊗ₜ ⁅x, y⁆ :=
by rw [bracket_def, bracket'_tmul]

private lemma bracket_lie_self (x : A ⊗[R] L) : ⁅x, x⁆ = 0 :=
begin
  simp only [bracket_def],
  apply x.induction_on,
  { simp only [linear_map.map_zero, eq_self_iff_true, linear_map.zero_apply], },
  { intros a l,
    simp only [bracket'_tmul, tensor_product.tmul_zero, eq_self_iff_true, lie_self], },
  { intros z₁ z₂ h₁ h₂,
    suffices : bracket' R A L z₁ z₂ + bracket' R A L z₂ z₁ = 0,
    { rw [linear_map.map_add, linear_map.map_add, linear_map.add_apply, linear_map.add_apply,
        h₁, h₂, zero_add, add_zero, add_comm, this], },
    apply z₁.induction_on,
    { simp only [linear_map.map_zero, add_zero, linear_map.zero_apply], },
    { intros a₁ l₁, apply z₂.induction_on,
      { simp only [linear_map.map_zero, add_zero, linear_map.zero_apply], },
      { intros a₂ l₂,
        simp only [← lie_skew l₂ l₁, mul_comm a₁ a₂, tensor_product.tmul_neg, bracket'_tmul,
          add_right_neg], },
      { intros y₁ y₂ hy₁ hy₂,
        simp only [hy₁, hy₂, add_add_add_comm, add_zero, linear_map.add_apply,
          linear_map.map_add], }, },
    { intros y₁ y₂ hy₁ hy₂,
      simp only [add_add_add_comm, hy₁, hy₂, add_zero, linear_map.add_apply,
        linear_map.map_add], }, },
end

private lemma bracket_leibniz_lie (x y z : A ⊗[R] L) : ⁅x, ⁅y, z⁆⁆ = ⁅⁅x, y⁆, z⁆ + ⁅y, ⁅x, z⁆⁆ :=
begin
  simp only [bracket_def],
  apply x.induction_on,
  { simp only [linear_map.map_zero, add_zero, eq_self_iff_true, linear_map.zero_apply], },
  { intros a₁ l₁,
    apply y.induction_on,
    { simp only [linear_map.map_zero, add_zero, eq_self_iff_true, linear_map.zero_apply], },
    { intros a₂ l₂,
      apply z.induction_on,
      { simp only [linear_map.map_zero, add_zero], },
      { intros a₃ l₃, simp only [bracket'_tmul],
        rw [mul_left_comm a₂ a₁ a₃, mul_assoc, leibniz_lie, tensor_product.tmul_add], },
      { intros u₁ u₂ h₁ h₂,
        simp only [add_add_add_comm, h₁, h₂, linear_map.map_add], }, },
    { intros u₁ u₂ h₁ h₂,
      simp only [add_add_add_comm, h₁, h₂, linear_map.add_apply, linear_map.map_add], }, },
  { intros u₁ u₂ h₁ h₂,
    simp only [add_add_add_comm, h₁, h₂, linear_map.add_apply, linear_map.map_add], },
end

instance : lie_ring (A ⊗[R] L) :=
{ add_lie     := λ x y z, by simp only [bracket_def, linear_map.add_apply, linear_map.map_add],
  lie_add     := λ x y z, by simp only [bracket_def, linear_map.map_add],
  lie_self    := bracket_lie_self R A L,
  leibniz_lie := bracket_leibniz_lie R A L, }

private lemma bracket_lie_smul (a : A) (x y : A ⊗[R] L) : ⁅x, a • y⁆ = a • ⁅x, y⁆ :=
begin
  apply x.induction_on,
  { simp only [zero_lie, smul_zero], },
  { intros a₁ l₁, apply y.induction_on,
    { simp only [lie_zero, smul_zero], },
    { intros a₂ l₂,
      simp only [bracket_def, bracket', tensor_product.smul_tmul', mul_left_comm a₁ a a₂,
        tensor_product.curry_apply, linear_map.mul'_apply, algebra.id.smul_eq_mul,
        function.comp_app, linear_equiv.coe_coe, linear_map.coe_comp, tensor_product.map_tmul,
        tensor_product.tensor_tensor_tensor_comm_tmul], },
    { intros z₁ z₂ h₁ h₂,
      simp only [h₁, h₂, smul_add, lie_add], }, },
  { intros z₁ z₂ h₁ h₂,
    simp only [h₁, h₂, smul_add, add_lie], },
end

instance lie_algebra : lie_algebra A (A ⊗[R] L) :=
{ lie_smul := bracket_lie_smul R A L, }

end extend_scalars

namespace restrict_scalars

open restrict_scalars

variables [h : lie_ring L]

include h

instance : lie_ring (restrict_scalars R A L) := h

variables [comm_ring A] [lie_algebra A L]

instance lie_algebra [comm_ring R] [algebra R A] : lie_algebra R (restrict_scalars R A L) :=
{ lie_smul := λ t x y, (lie_smul (algebra_map R A t)
    (restrict_scalars.add_equiv R A L x) (restrict_scalars.add_equiv R A L y) : _) }

end restrict_scalars

end lie_algebra


/-
Copyright (c) 2020 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author(s): Simon Hudon
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.lazy_list.basic
import Mathlib.data.tree
import Mathlib.data.int.basic
import Mathlib.control.bifunctor
import Mathlib.tactic.linarith.default
import Mathlib.testing.slim_check.gen
import Mathlib.PostPort

universes u_1 u l v w u_2 u_3

namespace Mathlib

/-!
# `sampleable` Class

This class permits the creation samples of a given type
controlling the size of those values using the `gen` monad`. It also
helps minimize examples by creating smaller versions of given values.

When testing a proposition like `∀ n : ℕ, prime n → n ≤ 100`,
`slim_check` requires that `ℕ` have an instance of `sampleable` and for
`prime n` to be decidable.  `slim_check` will then use the instance of
`sampleable` to generate small examples of ℕ and progressively increase
in size. For each example `n`, `prime n` is tested. If it is false,
the example will be rejected (not a test success nor a failure) and
`slim_check` will move on to other examples. If `prime n` is true, `n
≤ 100` will be tested. If it is false, `n` is a counter-example of `∀
n : ℕ, prime n → n ≤ 100` and the test fails. If `n ≤ 100` is true,
the test passes and `slim_check` moves on to trying more examples.

This is a port of the Haskell QuickCheck library.

## Main definitions
  * `sampleable` class
  * `sampleable_functor` and `sampleable_bifunctor` class
  * `sampleable_ext` class

### `sampleable`

`sampleable α` provides ways of creating examples of type `α`,
and given such an example `x : α`, gives us a way to shrink it
and find simpler examples.

### `sampleable_ext`

`sampleable_ext` generalizes the behavior of `sampleable`
and makes it possible to express instances for types that
do not lend themselves to introspection, such as `ℕ → ℕ`.
If we test a quantification over functions the
counter-examples cannot be shrunken or printed meaningfully.

For that purpose, `sampleable_ext` provides a proxy representation
`proxy_repr` that can be printed and shrunken as well
as interpreted (using `interp`) as an object of the right type.

### `sampleable_functor` and `sampleable_bifunctor`

`sampleable_functor F` and `sampleable_bifunctor F` makes it possible
to create samples of and shrink `F α` given a sampling function and a
shrinking function for arbitrary `α`.

This allows us to separate the logic for generating the shape of a
collection from the logic for generating its contents. Specifically,
the contents could be generated using either `sampleable` or
`sampleable_ext` instance and the `sampleable_(bi)functor` does not
need to use that information

## Shrinking

Shrinking happens when `slim_check` find a counter-example to a
property.  It is likely that the example will be more complicated than
necessary so `slim_check` proceeds to shrink it as much as
possible. Although equally valid, a smaller counter-example is easier
for a user to understand and use.

The `sampleable` class, beside having the `sample` function, has a
`shrink` function so that we can use specialized knowledge while
shrinking a value. It is not responsible for the whole shrinking process
however. It only has to take one step in the shrinking process.
`slim_check` will repeatedly call `shrink` until no more steps can
be taken. Because `shrink` guarantees that the size of the candidates
it produces is strictly smaller than the argument, we know that
`slim_check` is guaranteed to terminate.

## Tags

random testing

## References

  * https://hackage.haskell.org/package/QuickCheck

-/

namespace slim_check

/-- `sizeof_lt x y` compares the sizes of `x` and `y`. -/
def sizeof_lt {α : Sort u_1} [SizeOf α] (x : α) (y : α) :=
  sizeof x < sizeof y

/-- `shrink_fn α` is the type of functions that shrink an
argument of type `α` -/
def shrink_fn (α : Type u_1) [SizeOf α] :=
  (x : α) → lazy_list (Subtype fun (y : α) => sizeof_lt y x)

/-- `sampleable α` provides ways of creating examples of type `α`,
and given such an example `x : α`, gives us a way to shrink it
and find simpler examples.  -/
class sampleable (α : Type u)
where
  wf : SizeOf α
  sample : gen α
  shrink : (x : α) → lazy_list (Subtype fun (y : α) => sizeof y < sizeof x)

/-- `sampleable_functor F` makes it possible to create samples of and
shrink `F α` given a sampling function and a shrinking function for
arbitrary `α` -/
class sampleable_functor (F : Type u → Type v) [Functor F]
where
  wf : (α : Type u) → [_inst_1 : SizeOf α] → SizeOf (F α)
  sample : {α : Type u} → gen α → gen (F α)
  shrink : (α : Type u) → [_inst_1 : SizeOf α] → shrink_fn α → shrink_fn (F α)
  p_repr : (α : Type u) → has_repr α → has_repr (F α)

/-- `sampleable_bifunctor F` makes it possible to create samples of
and shrink `F α β` given a sampling function and a shrinking function
for arbitrary `α` and `β` -/
class sampleable_bifunctor (F : Type u → Type v → Type w) [bifunctor F]
where
  wf : (α : Type u) → (β : Type v) → [_inst_1 : SizeOf α] → [_inst_2 : SizeOf β] → SizeOf (F α β)
  sample : {α : Type u} → {β : Type v} → gen α → gen β → gen (F α β)
  shrink : (α : Type u) →
  (β : Type v) → [_inst_1 : SizeOf α] → [_inst_2 : SizeOf β] → shrink_fn α → shrink_fn β → shrink_fn (F α β)
  p_repr : (α : Type u) → (β : Type v) → has_repr α → has_repr β → has_repr (F α β)

/-- This function helps infer the proxy representation and
interpretation in `sampleable_ext` instances. -/
/-- `sampleable_ext` generalizes the behavior of `sampleable`
and makes it possible to express instances for types that
do not lend themselves to introspection, such as `ℕ → ℕ`.
If we test a quantification over functions the
counter-examples cannot be shrunken or printed meaningfully.

For that purpose, `sampleable_ext` provides a proxy representation
`proxy_repr` that can be printed and shrunken as well
as interpreted (using `interp`) as an object of the right type. -/
class sampleable_ext (α : Sort u)
where
  proxy_repr : Type v
  wf : SizeOf proxy_repr
  interp : autoParam (proxy_repr → α)
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.slim_check.sampleable.mk_trivial_interp")
    (Lean.Name.mkStr
      (Lean.Name.mkStr (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "slim_check") "sampleable")
      "mk_trivial_interp")
    [])
  p_repr : has_repr proxy_repr
  sample : gen proxy_repr
  shrink : shrink_fn proxy_repr

protected instance sampleable_ext.of_sampleable {α : Type u_1} [sampleable α] [has_repr α] : sampleable_ext α :=
  sampleable_ext.mk α (sample α) shrink

protected instance sampleable.functor {α : Type u_1} {F : Type u_1 → Type u_2} [Functor F] [sampleable_functor F] [sampleable α] : sampleable (F α) :=
  sampleable.mk (sampleable_functor.sample F (sample α)) (sampleable_functor.shrink α shrink)

protected instance sampleable.bifunctor {α : Type u_1} {β : Type u_2} {F : Type u_1 → Type u_2 → Type u_3} [bifunctor F] [sampleable_bifunctor F] [sampleable α] [sampleable β] : sampleable (F α β) :=
  sampleable.mk (sampleable_bifunctor.sample F (sample α) (sample β)) (sampleable_bifunctor.shrink α β shrink shrink)

protected instance sampleable_ext.functor {α : Type u_1} {F : Type u_1 → Type u_2} [Functor F] [sampleable_functor F] [sampleable_ext α] : sampleable_ext (F α) :=
  sampleable_ext.mk (F (sampleable_ext.proxy_repr α)) (sampleable_functor.sample F (sampleable_ext.sample α))
    (sampleable_functor.shrink (sampleable_ext.proxy_repr α) sampleable_ext.shrink)

protected instance sampleable_ext.bifunctor {α : Type u_1} {β : Type u_2} {F : Type u_1 → Type u_2 → Type u_3} [bifunctor F] [sampleable_bifunctor F] [sampleable_ext α] [sampleable_ext β] : sampleable_ext (F α β) :=
  sampleable_ext.mk (F (sampleable_ext.proxy_repr α) (sampleable_ext.proxy_repr β))
    (sampleable_bifunctor.sample F (sampleable_ext.sample α) (sampleable_ext.sample β))
    (sampleable_bifunctor.shrink (sampleable_ext.proxy_repr α) (sampleable_ext.proxy_repr β) sampleable_ext.shrink
      sampleable_ext.shrink)

/-- `nat.shrink' k n` creates a list of smaller natural numbers by
successively dividing `n` by 2 and subtracting the difference from
`k`. For example, `nat.shrink 100 = [50, 75, 88, 94, 97, 99]`. -/
def nat.shrink' (k : ℕ) (n : ℕ) : n ≤ k → List (Subtype fun (m : ℕ) => has_well_founded.r m k) → List (Subtype fun (m : ℕ) => has_well_founded.r m k) :=
  sorry

/-- `nat.shrink n` creates a list of smaller natural numbers by
successively dividing by 2 and subtracting the difference from
`n`. For example, `nat.shrink 100 = [50, 75, 88, 94, 97, 99]`. -/
def nat.shrink (n : ℕ) : List (Subtype fun (m : ℕ) => has_well_founded.r m n) :=
  dite (n > 0)
    (fun (h : n > 0) =>
      (fun (this : ∀ (k : ℕ), 1 < k → n / k < n) =>
          { val := n / bit1 (bit1 (bit0 1)), property := sorry } ::
            { val := n / bit1 1, property := sorry } :: nat.shrink' n n sorry [])
        sorry)
    fun (h : ¬n > 0) => []

/--
Transport a `sampleable` instance from a type `α` to a type `β` using
functions between the two, going in both directions.

Function `g` is used to define the well-founded order that
`shrink` is expected to follow.
-/
def sampleable.lift (α : Type u) {β : Type u} [sampleable α] (f : α → β) (g : β → α) (h : ∀ (a : α), sizeof (g (f a)) ≤ sizeof a) : sampleable β :=
  sampleable.mk (f <$> sample α)
    fun (x : β) =>
      (fun (this : ∀ (a : α), sizeof a < sizeof (g x) → sizeof (g (f a)) < sizeof (g x)) =>
          subtype.map f this <$> shrink (g x))
        sorry

protected instance nat.sampleable : sampleable ℕ :=
  sampleable.mk
    (gen.sized
      fun (sz : ℕ) =>
        gen.freq
          [(1, coe <$> gen.choose_any (fin (Nat.succ (sz ^ bit1 1)))),
            (bit1 1, coe <$> gen.choose_any (fin (Nat.succ sz)))]
          sorry)
    fun (x : ℕ) => lazy_list.of_list (nat.shrink x)

/-- `iterate_shrink p x` takes a decidable predicate `p` and a
value `x` of some sampleable type and recursively shrinks `x`.
It first calls `shrink x` to get a list of candidate sample,
finds the first that satisfies `p` and recursively tries
to shrink that one. -/
def iterate_shrink {α : Type} [has_to_string α] [sampleable α] (p : α → Prop) [decidable_pred p] : α → Option α :=
  well_founded.fix sorry
    fun (x : α) (f_rec : (y : α) → has_well_founded.r y x → Option α) =>
      do
        trace
            (string.empty ++ to_string x ++
              (string.str
                    (string.str (string.str string.empty (char.of_nat (bit0 (bit0 (bit0 (bit0 (bit0 1)))))))
                      (char.of_nat (bit0 (bit1 (bit0 (bit1 (bit1 1)))))))
                    (char.of_nat (bit0 (bit0 (bit0 (bit0 (bit0 1)))))) ++
                  to_string (lazy_list.to_list (shrink x)) ++
                string.empty))
            fun (_ : Unit) => pure Unit.unit
        let y ← lazy_list.find (fun (a : Subtype fun (y : α) => sizeof y < sizeof x) => p ↑a) (shrink x)
        f_rec ↑y sorry <|> some (subtype.val y)

protected instance fin.sampleable {n : ℕ} [fact (0 < n)] : sampleable (fin n) :=
  sampleable.lift ℕ fin.of_nat' subtype.val sorry

protected instance fin.sampleable' {n : ℕ} : sampleable (fin (Nat.succ n)) :=
  sampleable.lift ℕ fin.of_nat subtype.val sorry

protected instance pnat.sampleable : sampleable ℕ+ :=
  sampleable.lift ℕ nat.succ_pnat pnat.nat_pred sorry

/-- Redefine `sizeof` for `int` to make it easier to use with `nat` -/
def int.has_sizeof : SizeOf ℤ :=
  { sizeOf := int.nat_abs }

protected instance int.sampleable : sampleable ℤ :=
  sampleable.mk
    (gen.sized
      fun (sz : ℕ) =>
        gen.freq
          [(1, subtype.val <$> gen.choose (-(↑sz ^ bit1 1 + 1)) (↑sz ^ bit1 1 + 1) sorry),
            (bit1 1, subtype.val <$> gen.choose (-(↑sz + 1)) (↑sz + 1) sorry)]
          sorry)
    fun (x : ℤ) =>
      lazy_list.of_list
        (list.bind (nat.shrink (int.nat_abs x))
          fun (_x : Subtype fun (m : ℕ) => has_well_founded.r m (int.nat_abs x)) => sorry)

protected instance bool.sampleable : sampleable Bool :=
  sampleable.mk
    (do
      let x ← gen.choose_any Bool
      return x)
    fun (b : Bool) =>
      dite (↥b) (fun (h : ↥b) => lazy_list.singleton { val := false, property := sorry }) fun (h : ¬↥b) => lazy_list.nil

/--
Provided two shrinking functions `prod.shrink` shrinks a pair `(x, y)` by
first shrinking `x` and pairing the results with `y` and then shrinking
`y` and pairing the results with `x`.

All pairs either contain `x` untouched or `y` untouched. We rely on
shrinking being repeated for `x` to get maximally shrunken and then
for `y` to get shrunken too.
-/
def prod.shrink {α : Type u_1} {β : Type u_2} [SizeOf α] [SizeOf β] (shr_a : shrink_fn α) (shr_b : shrink_fn β) : shrink_fn (α × β) :=
  sorry

protected instance prod.sampleable : sampleable_bifunctor Prod :=
  sampleable_bifunctor.mk
    (fun (α : Type u) (β : Type v) (sama : gen α) (samb : gen β) =>
      do
        uliftable.up sama
        sorry)
    prod.shrink prod.has_repr

protected instance sigma.sampleable {α : Type u_1} {β : Type u_2} [sampleable α] [sampleable β] : sampleable (sigma fun (_x : α) => β) :=
  sampleable.lift (α × β) (fun (_x : α × β) => sorry) (fun (_x : sigma fun (_x : α) => β) => sorry) sorry

/-- shrinking function for sum types -/
def sum.shrink {α : Type u_1} {β : Type u_2} [SizeOf α] [SizeOf β] (shrink_α : shrink_fn α) (shrink_β : shrink_fn β) : shrink_fn (α ⊕ β) :=
  sorry

protected instance sum.sampleable : sampleable_bifunctor sum :=
  sampleable_bifunctor.mk
    (fun (α : Type u) (β : Type v) (sam_α : gen α) (sam_β : gen β) =>
      uliftable.up_map sum.inl sam_α <|> uliftable.up_map sum.inr sam_β)
    (fun (α : Type u) (β : Type v) (Iα : SizeOf α) (Iβ : SizeOf β) (shr_α : shrink_fn α) (shr_β : shrink_fn β) =>
      sum.shrink shr_α shr_β)
    sum.has_repr

protected instance rat.sampleable : sampleable ℚ :=
  sampleable.lift (ℤ × ℕ+) (fun (x : ℤ × ℕ+) => prod.cases_on x rat.mk_pnat)
    (fun (r : ℚ) => (rat.num r, { val := rat.denom r, property := rat.pos r })) sorry

/-- `sampleable_char` can be specialized into customized `sampleable char` instances.

The resulting instance has `1 / length` chances of making an unrestricted choice of characters
and it otherwise chooses a character from `characters` with uniform probabilities.  -/
def sampleable_char (length : ℕ) (characters : string) : sampleable char :=
  sampleable.mk
    (do
      let x ← gen.choose_nat 0 length sorry
      ite (subtype.val x = 0)
          (do
            let n ← sample ℕ
            pure (char.of_nat n))
          (do
            let i ← gen.choose_nat 0 (string.length characters - 1) sorry
            pure (string.iterator.curr (string.iterator.nextn (string.mk_iterator characters) ↑i))))
    fun (_x : char) => lazy_list.nil

protected instance char.sampleable : sampleable char := sorry

theorem list.sizeof_drop_lt_sizeof_of_lt_length {α : Type u} [SizeOf α] {xs : List α} {k : ℕ} (hk : 0 < k) (hk' : k < list.length xs) : sizeof (list.drop k xs) < sizeof xs := sorry

theorem list.sizeof_cons_lt_right {α : Type u} [SizeOf α] (a : α) (b : α) {xs : List α} (h : sizeof a < sizeof b) : sizeof (a :: xs) < sizeof (b :: xs) := sorry

theorem list.sizeof_cons_lt_left {α : Type u} [SizeOf α] (x : α) {xs : List α} {xs' : List α} (h : sizeof xs < sizeof xs') : sizeof (x :: xs) < sizeof (x :: xs') := sorry

theorem list.sizeof_append_lt_left {α : Type u} [SizeOf α] {xs : List α} {ys : List α} {ys' : List α} (h : sizeof ys < sizeof ys') : sizeof (xs ++ ys) < sizeof (xs ++ ys') := sorry

theorem list.one_le_sizeof {α : Type u} [SizeOf α] (xs : List α) : 1 ≤ sizeof xs := sorry

/--
`list.shrink_removes` shrinks a list by removing chunks of size `k` in
the middle of the list.
-/
def list.shrink_removes {α : Type u} [SizeOf α] (k : ℕ) (hk : 0 < k) (xs : List α) (n : ℕ) : n = list.length xs → lazy_list (Subtype fun (ys : List α) => sizeof_lt ys xs) :=
  sorry

/--
`list.shrink_one xs` shrinks list `xs` by shrinking only one item in
the list.
-/
def list.shrink_one {α : Type u} [SizeOf α] (shr : (x : α) → lazy_list (Subtype fun (y : α) => sizeof_lt y x)) : shrink_fn (List α) :=
  sorry

/-- `list.shrink_with shrink_f xs` shrinks `xs` by first
considering `xs` with chunks removed in the middle (starting with
chunks of size `xs.length` and halving down to `1`) and then
shrinks only one element of the list.

This strategy is taken directly from Haskell's QuickCheck -/
def list.shrink_with {α : Type u} [SizeOf α] (shr : (x : α) → lazy_list (Subtype fun (y : α) => sizeof_lt y x)) (xs : List α) : lazy_list (Subtype fun (ys : List α) => sizeof_lt ys xs) :=
  let n : ℕ := list.length xs;
  lazy_list.append
    (lazy_list.bind (lazy_list.cons n fun (_ : Unit) => lazy_list.map subtype.val (lazy_list.reverse (shrink n)))
      fun (k : ℕ) =>
        dite (0 < k) (fun (hk : 0 < k) => list.shrink_removes k hk xs n rfl) fun (hk : ¬0 < k) => lazy_list.nil)
    fun (_ : Unit) => list.shrink_one shr xs

protected instance list.sampleable : sampleable_functor List :=
  sampleable_functor.mk (fun (α : Type u) (sam_α : gen α) => gen.list_of sam_α)
    (fun (α : Type u) (Iα : SizeOf α) (shr_α : shrink_fn α) => list.shrink_with shr_α) list.has_repr

protected instance prop.sampleable_ext : sampleable_ext Prop :=
  sampleable_ext.mk Bool (gen.choose_any Bool) fun (_x : Bool) => lazy_list.nil

/-- `no_shrink` is a type annotation to signal that
a certain type is not to be shrunk. It can be useful in
combination with other types: e.g. `xs : list (no_shrink ℤ)`
will result in the list being cut down but individual
integers being kept as is. -/
def no_shrink (α : Type u_1) :=
  α

protected instance no_shrink.inhabited {α : Type u_1} [Inhabited α] : Inhabited (no_shrink α) :=
  { default := Inhabited.default }

/-- Introduction of the `no_shrink` type. -/
def no_shrink.mk {α : Type u_1} (x : α) : no_shrink α :=
  x

/-- Selector of the `no_shrink` type. -/
def no_shrink.get {α : Type u_1} (x : no_shrink α) : α :=
  x

protected instance no_shrink.sampleable {α : Type u_1} [sampleable α] : sampleable (no_shrink α) :=
  sampleable.mk (no_shrink.mk <$> sample α) fun (_x : no_shrink α) => lazy_list.nil

protected instance string.sampleable : sampleable string :=
  sampleable.mk
    (do
      let x ← gen.list_of (sample char)
      pure (list.as_string x))
    shrink

/-- implementation of `sampleable (tree α)` -/
def tree.sample {α : Type u} (sample : gen α) : ℕ → gen (tree α) :=
  sorry

/-- `rec_shrink x f_rec` takes the recursive call `f_rec` introduced
by `well_founded.fix` and turns it into a shrinking function whose
result is adequate to use in a recursive call. -/
def rec_shrink {α : Type u_1} [SizeOf α] (t : α) (sh : (x : α) → sizeof_lt x t → lazy_list (Subtype fun (y : α) => sizeof_lt y x)) : shrink_fn (Subtype fun (t' : α) => sizeof_lt t' t) :=
  sorry

theorem tree.one_le_sizeof {α : Type u_1} [SizeOf α] (t : tree α) : 1 ≤ sizeof t := sorry

protected instance tree.functor : Functor tree :=
  { map := tree.map, mapConst := fun (α β : Type u_1) => tree.map ∘ function.const β }

/--
Recursion principle for shrinking tree-like structures.
-/
def rec_shrink_with {α : Type u} [SizeOf α] (shrink_a : (x : α) → shrink_fn (Subtype fun (y : α) => sizeof_lt y x) → List (lazy_list (Subtype fun (y : α) => sizeof_lt y x))) : shrink_fn α :=
  well_founded.fix (sizeof_measure_wf α)
    fun (t : α) (f_rec : (y : α) → sizeof_measure α y t → lazy_list (Subtype fun (y_1 : α) => sizeof_lt y_1 y)) =>
      lazy_list.join (lazy_list.of_list (shrink_a t fun (_x : Subtype fun (y : α) => sizeof_lt y t) => sorry))

theorem rec_shrink_with_eq {α : Type u} [SizeOf α] (shrink_a : (x : α) → shrink_fn (Subtype fun (y : α) => sizeof_lt y x) → List (lazy_list (Subtype fun (y : α) => sizeof_lt y x))) (x : α) : rec_shrink_with shrink_a x =
  lazy_list.join
    (lazy_list.of_list
      (shrink_a x
        fun (t' : Subtype fun (y : α) => sizeof_lt y x) =>
          rec_shrink x (fun (x_1 : α) (h' : sizeof_lt x_1 x) => rec_shrink_with shrink_a x_1) t')) := sorry

/-- `tree.shrink_with shrink_f t` shrinks `xs` by using the empty tree,
each subtrees, and by shrinking the subtree to recombine them.

This strategy is taken directly from Haskell's QuickCheck -/
def tree.shrink_with {α : Type u} [SizeOf α] (shrink_a : shrink_fn α) : shrink_fn (tree α) :=
  rec_shrink_with fun (t : tree α) => sorry

protected instance sampleable_tree : sampleable_functor tree :=
  sampleable_functor.mk (fun (α : Type u_1) (sam_α : gen α) => gen.sized (tree.sample sam_α))
    (fun (α : Type u_1) (Iα : SizeOf α) (shr_α : shrink_fn α) => tree.shrink_with shr_α) tree.has_repr

/-- Type tag that signals to `slim_check` to use small values for a given type. -/
def small (α : Type u_1) :=
  α

/-- Add the `small` type tag -/
def small.mk {α : Type u_1} (x : α) : small α :=
  x

/-- Type tag that signals to `slim_check` to use large values for a given type. -/
def large (α : Type u_1) :=
  α

/-- Add the `large` type tag -/
def large.mk {α : Type u_1} (x : α) : large α :=
  x

protected instance small.functor : Functor small :=
  applicative.to_functor

protected instance large.functor : Functor large :=
  applicative.to_functor

protected instance small.inhabited {α : Type u} [Inhabited α] : Inhabited (small α) :=
  { default := Inhabited.default }

protected instance large.inhabited {α : Type u} [Inhabited α] : Inhabited (large α) :=
  { default := Inhabited.default }

protected instance small.sampleable_functor : sampleable_functor small :=
  sampleable_functor.mk
    (fun (α : Type u_1) (samp : gen α) => gen.resize (fun (n : ℕ) => n / bit1 (bit0 1) + bit1 (bit0 1)) samp)
    (fun (α : Type u_1) (_x : SizeOf α) => id) fun (α : Type u_1) => id

protected instance large.sampleable_functor : sampleable_functor large :=
  sampleable_functor.mk (fun (α : Type u_1) (samp : gen α) => gen.resize (fun (n : ℕ) => n * bit1 (bit0 1)) samp)
    (fun (α : Type u_1) (_x : SizeOf α) => id) fun (α : Type u_1) => id

protected instance ulift.sampleable_functor : sampleable_functor ulift :=
  sampleable_functor.mk (fun (α : Type v) (samp : gen α) => uliftable.up_map ulift.up samp)
    (fun (α : Type v) (_x : SizeOf α) (shr : shrink_fn α) (_x : ulift α) => sorry)
    fun (α : Type v) (h : has_repr α) => has_repr.mk (repr ∘ ulift.down)

/-!
## Subtype instances

The following instances are meant to improve the testing of properties of the form
`∀ i j, i ≤ j, ...`

The naive way to test them is to choose two numbers `i` and `j` and check that
the proper ordering is satisfied. Instead, the following instances make it
so that `j` will be chosen with considerations to the required ordering
constraints. The benefit is that we will not have to discard any choice
of `j`.
 -/

/-! ### Subtypes of `ℕ` -/

protected instance nat_le.sampleable {y : ℕ} : sampleable (Subtype fun (x : ℕ) => x ≤ y) :=
  sampleable.mk
    (do
      gen.choose_nat 0 y sorry
      sorry)
    fun (_x : Subtype fun (x : ℕ) => x ≤ y) => sorry

protected instance nat_ge.sampleable {x : ℕ} : sampleable (Subtype fun (y : ℕ) => x ≤ y) :=
  sampleable.mk
    (do
      sample ℕ
      sorry)
    fun (_x : Subtype fun (y : ℕ) => x ≤ y) => sorry

/- there is no `nat_lt.sampleable` instance because if `y = 0`, there is no valid choice
to satisfy `x < y` -/

protected instance nat_gt.sampleable {x : ℕ} : sampleable (Subtype fun (y : ℕ) => x < y) :=
  sampleable.mk
    (do
      sample ℕ
      sorry)
    fun (x_1 : Subtype fun (y : ℕ) => x < y) => shrink x_1

/-! ### Subtypes of any `linear_ordered_add_comm_group` -/

protected instance le.sampleable {α : Type u} {y : α} [sampleable α] [linear_ordered_add_comm_group α] : sampleable (Subtype fun (x : α) => x ≤ y) :=
  sampleable.mk
    (do
      let x ← sample α
      pure { val := y - abs x, property := sorry })
    fun (_x : Subtype fun (x : α) => x ≤ y) => lazy_list.nil

protected instance ge.sampleable {α : Type u} {x : α} [sampleable α] [linear_ordered_add_comm_group α] : sampleable (Subtype fun (y : α) => x ≤ y) :=
  sampleable.mk
    (do
      let y ← sample α
      pure { val := x + abs y, property := sorry })
    fun (_x : Subtype fun (y : α) => x ≤ y) => lazy_list.nil

/-!
### Subtypes of `ℤ`

Specializations of `le.sampleable` and `ge.sampleable` for `ℤ` to help instance search.
-/

protected instance int_le.sampleable {y : ℤ} : sampleable (Subtype fun (x : ℤ) => x ≤ y) :=
  sampleable.lift ℕ (fun (n : ℕ) => { val := y - ↑n, property := sorry })
    (fun (_x : Subtype fun (x : ℤ) => x ≤ y) => sorry) sorry

protected instance int_ge.sampleable {x : ℤ} : sampleable (Subtype fun (y : ℤ) => x ≤ y) :=
  sampleable.lift ℕ (fun (n : ℕ) => { val := x + ↑n, property := sorry })
    (fun (_x : Subtype fun (y : ℤ) => x ≤ y) => sorry) sorry

protected instance int_lt.sampleable {y : ℤ} : sampleable (Subtype fun (x : ℤ) => x < y) :=
  sampleable.lift ℕ (fun (n : ℕ) => { val := y - (↑n + 1), property := sorry })
    (fun (_x : Subtype fun (x : ℤ) => x < y) => sorry) sorry

protected instance int_gt.sampleable {x : ℤ} : sampleable (Subtype fun (y : ℤ) => x < y) :=
  sampleable.lift ℕ (fun (n : ℕ) => { val := x + (↑n + 1), property := sorry })
    (fun (_x : Subtype fun (y : ℤ) => x < y) => sorry) sorry

/-! ### Subtypes of any `list` -/

protected instance perm.slim_check {α : Type u} {xs : List α} : sampleable (Subtype fun (ys : List α) => xs ~ ys) :=
  sampleable.mk (gen.permutation_of xs) fun (_x : Subtype fun (ys : List α) => xs ~ ys) => lazy_list.nil

protected instance perm'.slim_check {α : Type u} {xs : List α} : sampleable (Subtype fun (ys : List α) => ys ~ xs) :=
  sampleable.mk (subtype.map id list.perm.symm <$> gen.permutation_of xs)
    fun (_x : Subtype fun (ys : List α) => ys ~ xs) => lazy_list.nil

/--
Print (at most) 10 samples of a given type to stdout for debugging.
-/
def print_samples {t : Type u} [has_repr t] (g : gen t) : io Unit :=
  do
    let xs ←
      io.run_rand
        (uliftable.down
          (do
            let xs ← mmap (reader_t.run g ∘ ulift.up) (list.range (bit0 (bit1 (bit0 1))))
            pure (ulift.up (list.map repr xs))))
    mmap' io.put_str_ln xs


/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import algebra.big_operators.basic
import combinatorics.set_family.compression.down
import data.nat.interval
import order.upper_lower
import tactic

/-!
# Shattering families

This file defines the shattering property and VC-dimension of set families.

## Main declarations

* `finset.shatter`: The shattering property.
* `finset.shatterer`: The set family of sets shattered by a set family.
* `finset.vc_dimension`: The Vapnik-Chervonenkis dimension.
-/

namespace finset
variables {α : Type*} [decidable_eq α]

lemma insert_inter_distrib (a : α) (s t : finset α) : insert a (s ∩ t) = insert a s ∩ insert a t :=
coe_injective $ by { push_cast, exact set.insert_inter_distrib _ _ _ }

end finset

open_locale big_operators finset_family

namespace finset
variables {α : Type*} [decidable_eq α] {𝒜 ℬ : finset (finset α)} {s t : finset α} {a : α} {n : ℕ}

/-- A set family shatters a set `s` if all subsets of `s` can be obtained as the intersection of `s`
and some element of the set family. We also say that `s` is traced by `𝒜`. -/
def shatter (𝒜 : finset (finset α)) (s : finset α) : Prop := ∀ ⦃t⦄, t ⊆ s → ∃ u ∈ 𝒜, s ∩ u = t

instance : decidable_pred 𝒜.shatter := λ s, finset.decidable_forall_of_decidable_subsets

lemma shatter.mono_left (h : 𝒜 ⊆ ℬ) (h𝒜 : 𝒜.shatter s) : ℬ.shatter s :=
λ t ht, let ⟨u, hu, hut⟩ := h𝒜 ht in ⟨u, h hu, hut⟩

lemma shatter.mono_right (h : t ⊆ s) (hs : 𝒜.shatter s) : 𝒜.shatter t :=
λ u hu, by { obtain ⟨v, hv, rfl⟩ := hs (hu.trans h),
  exact ⟨v, hv, inf_congr_right hu $ inf_le_of_left_le h⟩ }

lemma shatter.exists_superset (h : 𝒜.shatter s) : ∃ t ∈ 𝒜, s ⊆ t :=
Exists₂.imp (λ t _, (inter_eq_left_iff_subset _ _).1) (h subset.rfl)

lemma shatter_of_forall_subset (h : ∀ t ⊆ s, t ∈ 𝒜) : 𝒜.shatter s :=
λ t ht, ⟨t, h _ ht, (inter_eq_right_iff_subset _ _).2 ht⟩

protected lemma shatter.nonempty (h : 𝒜.shatter s) : 𝒜.nonempty :=
let ⟨t, ht, _⟩ := h subset.rfl in ⟨t, ht⟩

@[simp] lemma shatter_empty : 𝒜.shatter ∅ ↔ 𝒜.nonempty :=
⟨shatter.nonempty, λ ⟨s, hs⟩ t ht, ⟨s, hs, by rwa [empty_inter, eq_comm, ←subset_empty]⟩⟩

protected lemma shatter.iff (h : 𝒜.shatter s) : t ⊆ s ↔ ∃ u ∈ 𝒜, s ∩ u = t :=
⟨λ ht, h ht, by { rintro ⟨u, hu, rfl⟩, exact inter_subset_left _ _ }⟩

lemma shatter_iff : 𝒜.shatter s ↔ 𝒜.image (λ t, s ∩ t) = s.powerset :=
⟨λ h, by { ext t, rw [mem_image, mem_powerset, h.iff] },
  λ h t ht, by rwa [←mem_powerset, ←h, mem_image] at ht⟩

lemma univ_shatter [fintype α] : univ.shatter s := shatter_of_forall_subset $ λ _ _, mem_univ _

@[simp] lemma shatter_univ [fintype α] : 𝒜.shatter univ ↔ 𝒜 = univ :=
by { rw [shatter_iff, powerset_univ], simp_rw [univ_inter, image_id'] }

/-- The set family of sets that are shattered by `𝒜`. -/
def shatterer (𝒜 : finset (finset α)) : finset (finset α) := (𝒜.bUnion powerset).filter 𝒜.shatter

@[simp] lemma mem_shatterer : s ∈ 𝒜.shatterer ↔ 𝒜.shatter s :=
begin
  refine mem_filter.trans (and_iff_right_of_imp $ λ h, _),
  simp_rw [mem_bUnion, mem_powerset],
  exact h.exists_superset,
end

lemma shatterer_mono (h : 𝒜 ⊆ ℬ) : 𝒜.shatterer ⊆ ℬ.shatterer :=
λ _, by simpa using shatter.mono_left h

lemma subset_shatterer (h : is_lower_set (𝒜 : set (finset α))) : 𝒜 ⊆ 𝒜.shatterer :=
λ s hs, mem_shatterer.2 $ λ t ht, ⟨t, h ht hs, (inter_eq_right_iff_subset _ _).2 ht⟩

@[simp] lemma is_lower_set_shatterer (𝒜 : finset (finset α)) :
  is_lower_set (𝒜.shatterer : set (finset α)) :=
λ s t, by simpa using shatter.mono_right

@[simp] lemma shatterer_eq : 𝒜.shatterer = 𝒜 ↔ is_lower_set (𝒜 : set (finset α)) :=
begin
  refine ⟨λ h, _, λ h, subset.antisymm (λ s hs, _) $ subset_shatterer h⟩,
  { rw ←h,
    exact is_lower_set_shatterer _ },
  { obtain ⟨t, ht, hst⟩ := (mem_shatterer.1 hs).exists_superset,
    exact h hst ht }
end

@[simp] lemma shatterer_idem : 𝒜.shatterer.shatterer = 𝒜.shatterer := by simp

@[simp] lemma shatter_shatterer : 𝒜.shatterer.shatter s ↔ 𝒜.shatter s :=
by simp_rw [←mem_shatterer, shatterer_idem]

alias shatter_shatterer ↔ _ shatter.shatterer

attribute [protected] shatter.shatterer

section order
variables [linear_order α]

def order_shatter : finset (finset α) → list α → Prop
| 𝒜 [] := 𝒜.nonempty
| 𝒜 (a :: l) := (𝒜.non_member_subfamily a).order_shatter l ∧ (𝒜.member_subfamily a).order_shatter l
    ∧ ∀ ⦃s : finset α⦄, s ∈ 𝒜.non_member_subfamily a → ∀ ⦃t⦄, t ∈ 𝒜.member_subfamily a →
      s.filter (λ b, a < b) = t.filter (λ b, a < b)

instance : decidable_pred 𝒜.order_shatter :=
  begin
    sorry,
  end

def order_shatterer (𝒜 : finset (finset α)) : finset (finset α) :=
(𝒜.bUnion powerset).filter $ λ s, 𝒜.order_shatter $ s.sort (≤)

end order

def strongly_shatter (𝒜 : finset (finset α)) (s : finset α) : Prop :=
∃ t, ∀ ⦃u⦄, u ⊆ s → ∃ v ∈ 𝒜, s ∩ v = u ∧ v \ s = t

@[elab_as_eliminator]
lemma family_induction (p : finset (finset α) → Prop) (hemp : p ∅)(hone: p {∅})
  (h : ∀ a s (𝒜 : finset (finset α)), (∀ t ∈ 𝒜, t ⊆ insert a s) →
    p (𝒜.member_subfamily a) → p (𝒜.non_member_subfamily a) → p 𝒜) (𝒜 : finset (finset α)) : p 𝒜 :=
sorry

lemma aux {s : set α} {𝒜 : finset (finset α)} (h : ∀ t ∈ 𝒜, ↑t ⊆ s) : ∀ t ∈ 𝒜.shatterer, ↑t ⊆ s :=
begin
  intros t h0,
  rw mem_shatterer at h0,
  have h1: t ⊆ t,
  {
    simp,
  },
  specialize h0 h1,
  cases h0 with u h0,
  cases h0 with hu h0,
  have h2 := h u hu,
  have h3: t ⊆ u,
  exact (inter_eq_left_iff_subset t u).mp h0,
  exact (coe_subset.2 h3).trans (h u hu),
end

lemma insert_inj_non_mem (a : α) : {s : finset α | a ∉ s}.inj_on (λ s, insert a s) :=
λ s hs t ht (h : insert a s = _), by rw [←erase_insert hs, ←erase_insert ht, h]

/-- Pajor's variant of the **Sauer-Shelah lemma**. -/
lemma le_card_shatterer (𝒜 : finset (finset α)) : 𝒜.card ≤ 𝒜.shatterer.card :=
begin
  refine finset.family_induction _ _ _ _ 𝒜,
  { simp },
  {refl,},

  intros a s t h1 h2 h3,

  have h4:  (member_subfamily a t).card + (non_member_subfamily a t).card = t.card,
  {
    exact card_member_subfamily_add_card_non_member_subfamily a t,
  },

  rw ← h4,

  have h5: (member_subfamily a t).shatterer ∪ (non_member_subfamily a t).shatterer ⊆ t.shatterer,
  {
    have h51: (member_subfamily a t).shatterer ⊆ t.shatterer,
    {
      intro S,
      simp,
      intro hy1,
      intros E hy2,
      have hy1_origin := hy1,
      specialize hy1 hy2,
      cases hy1 with f1 hy1,
      cases hy1 with hu hy1,
      simp at hu,
      cases hu with hu1 hu2,
      use (insert a f1),
      split,
      exact hu1,

      have hy3: ¬ a ∈ S,
      {
        by_contra hn,
        have hy4: {a} ⊆ S,{exact singleton_subset_iff.mpr hn,},
        specialize hy1_origin hy4,
        cases hy1_origin with f12 hy5,
        cases hy5 with hf12 hy5,
        simp at hf12,
        cases hf12 with ha hb,
        apply hb,
        have hy6: a ∈ S ∩ f12 ,
        {
          rw hy5,
          simp,
        },
        rw mem_inter at hy6,
        exact hy6.right,
      },
      rw ← hy1,
      ext x,
      split,
      {
        intro h,
        rw mem_inter at h ⊢,
        split,
        exact h.left,
        cases h with ha hb,
        have hy4: x ≠ a,
        {
          by_contra hy5,
          apply hy3,
          rwa hy5 at ha,
        },
        rw mem_insert at hb,
        cases hb with hb1 hb2,
        exfalso,
        exact hy4 hb1,
        exact hb2,
      },
      {
        intro h,
        rw mem_inter at h ⊢,
        cases h with ha hb,
        split,
        exact ha,
        rw mem_insert,
        right,
        exact hb,
      },
    },
    have h52: (non_member_subfamily a t).shatterer ⊆ t.shatterer,
    {
      have h: (non_member_subfamily a t) ⊆ t,
      {
        intro a,
        simp,
        intros h0 h00,
        exact h0,
      },
      exact shatterer_mono h,
    },
    exact union_subset h51 h52,
  },

  have h8: ((member_subfamily a t).shatterer ∪ (non_member_subfamily a t).shatterer).card + ((member_subfamily a t).shatterer ∩ (non_member_subfamily a t).shatterer).card = (member_subfamily a t).shatterer.card + (non_member_subfamily a t).shatterer.card,
  {
    apply finset.card_union_add_card_inter,
  },
  have h7:  ((member_subfamily a t).shatterer ∪ (non_member_subfamily a t).shatterer).card + ((member_subfamily a t).shatterer ∩ (non_member_subfamily a t).shatterer).card ≤ t.shatterer.card,
  {
    set S': (finset (finset α)) := ((member_subfamily a t).shatterer ∩ (non_member_subfamily a t).shatterer).image (insert a),
    have hs': S' = ((member_subfamily a t).shatterer ∩ (non_member_subfamily a t).shatterer).image (insert a),
    {
      refl,
    },
    have hy1: ((member_subfamily a t).shatterer ∩ (non_member_subfamily a t).shatterer).card = S'.card,
    {
      rw hs',
      refine (finset.card_image_of_inj_on _).symm,
      intros z1 hz1 z2 hz2 h,
      have h₁: ¬ a ∈ z1,
      {
        rw coe_inter at hz1,
        have hz11 := hz1.left,
        have hy₁: ∀ (m: finset α) , m ∈ (member_subfamily a t) → (m:set α) ⊆ {a}ᶜ,
        {
          intros m hm,
          rw mem_member_subfamily at hm,
          have hm2 := hm.right,
          simp,
          assumption,
        },
        have hy₃: (z1:set α) ⊆ {a}ᶜ,
        {
          apply aux hy₁,
          exact hz11,
        },
        simp at hy₃,
        exact hy₃,
      },
      have h₂: ¬ a ∈ z2,
      {
        rw coe_inter at hz2,
        have hz22 := hz2.left,
        have hy₂: ∀ (m: finset α) , m ∈ (member_subfamily a t) → (m:set α) ⊆ {a}ᶜ,
        {
          intros m hm,
          rw mem_member_subfamily at hm,
          have hm2 := hm.right,
          simp,
          assumption,
        },
        have hy₃: (z2:set α) ⊆ {a}ᶜ,
        {
          apply aux hy₂,
          exact hz22,
        },
        simp at hy₃,
        exact hy₃,
      },
      apply insert_inj_non_mem a,
      apply h₁,
      apply h₂,
      apply h,
    },
    have hy2: disjoint ((member_subfamily a t).shatterer ∪ (non_member_subfamily a t).shatterer) S',
    {
      rw finset.disjoint_left,
      intros x hx,
      rw mem_union at hx,
      cases hx with hx1 hx2,
      {
        have hx3: a ∉ x,
        {
          have hy₁: ∀ (m: finset α) , m ∈ (member_subfamily a t) → (m:set α) ⊆ {a}ᶜ,
          {
          intros m hm,
          rw mem_member_subfamily at hm,
          have hm2 := hm.right,
          simp,
          assumption,
          },
          have hy₃: (x:set α) ⊆ {a}ᶜ,
        {
          apply aux hy₁,
          exact hx1,
        },
        simp at hy₃,
        exact hy₃,
        },
        have hS': ∀ y ∈ S', a∈y,
        {
          intros z hz,
          rw hs' at hz,
          rw mem_image at hz,
          cases hz with z0 hz,
          cases hz with hz0 hz,
          rw ← hz,
          exact mem_insert_self a z0,
        },
        by_contra hn,
        have hnn:= hS' x hn,
        exact hx3 hnn,
      },
      {
        have hx3: a ∉ x,
        {
          have hy₁: ∀ (m: finset α) , m ∈ (non_member_subfamily a t) → (m:set α) ⊆ {a}ᶜ,
          {
          intros m hm,
          rw mem_non_member_subfamily at hm,
          have hm2 := hm.right,
          simp,
          assumption,
          },
          have hy₃: (x:set α) ⊆ {a}ᶜ,
          {
            apply aux hy₁,
            exact hx2,
          },
        simp at hy₃,
        exact hy₃,
        },
        have hS': ∀ y ∈ S', a∈y,
        {
          intros z hz,
          rw hs' at hz,
          rw mem_image at hz,
          cases hz with z0 hz,
          cases hz with hz0 hz,
          rw ← hz,
          exact mem_insert_self a z0,
        },
        by_contra hn,
        have hnn:= hS' x hn,
        exact hx3 hnn,
      },
    },
    rw hy1,
    have hy3: S' ⊆ t.shatterer,
    {
      intros x h,
      rw hs' at h,
      rw finset.mem_image at h,
      cases h with y h,
      cases h with hy h,
      rw mem_inter at hy,
      cases hy with hy₁ hy₂,
      rw ← h,
      simp,
      intros y₀ hy₀,
      simp at hy₁,
      have h₁: erase y₀ a ⊆ y,
      {
        exact subset_insert_iff.mp hy₀,
      },
      specialize hy₁ h₁,
      cases hy₁ with u hy₁,
      cases hy₁ with hu hy₁,
      by_cases ha: a ∈ y₀ ,
      {
      use insert a u,
      split;
      rw mem_member_subfamily at hu,
      exact hu.left,
      rwa [←insert_inter_distrib, hy₁, insert_erase],
      },
      {
        simp at hy₂,
        have hemp : y₀ ⊆ y,
        {
          exact (subset_insert_iff_of_not_mem ha).mp hy₀,
        },
        specialize hy₂ hemp,
        cases hy₂ with u₀ hy₂,
        cases hy₂ with hu₀ hy₂,
        have hu₀t: u₀ ∈ t,
        {
          rw mem_non_member_subfamily at hu₀,
          exact hu₀.left,
        },
        use u₀,
        split,
        exact hu₀t,
        have hy₃: ¬ a ∈ u₀,
        {
          rw mem_non_member_subfamily at hu₀,
          exact hu₀.right,
        },
        rw ← hy₂,
        exact finset.insert_inter_of_not_mem hy₃,
      },
    },
    have hy4: ((member_subfamily a t).shatterer ∪ (non_member_subfamily a t).shatterer ∪ S') ⊆ t.shatterer,
    {
      exact union_subset h5 hy3,
    },
    rw ←  finset.card_disjoint_union hy2,
    apply finset.card_le_of_subset hy4,
  },
  suffices h: (member_subfamily a t).shatterer.card + (non_member_subfamily a t).shatterer.card ≤ t.shatterer.card,
  linarith,
  rw ← h8,
  assumption,
end

variables [fintype α]

/-- The Vapnik-Chervonenkis dimension of a set family is the maximal size of a set it shatters. -/
def vc_dimension (𝒜 : finset (finset α)) : ℕ := 𝒜.shatterer.sup card

lemma def_vc_dimension (𝒜 : finset (finset α)) :
  vc_dimension (𝒜 : finset (finset α)) = 𝒜.shatterer.sup card :=
rfl

lemma shatter.card_le_vc_dimension (h : 𝒜.shatter s) : s.card ≤ 𝒜.vc_dimension :=
begin
  rw def_vc_dimension,
  have hs: s ∈ 𝒜.shatterer,
  {simp,
  apply h,
  },
  exact finset.le_sup hs,
end

lemma ss_of_shatter_compress (a : α) (𝒜 : finset (finset α)):
  (𝓓 a 𝒜).shatterer ⊆ 𝒜.shatterer :=
begin
  intros F hF,
  have hF0 := hF,
  rw mem_shatterer,
  rw mem_shatterer at hF hF0,
  intros E hE,
  specialize hF hE,
  cases hF with S h,
  cases h with hS h1,
  by_cases hS2: S ∈ 𝒜 ,
  {
    use S,
    split;
    assumption,
  },
  {
    by_cases ha: a ∈ F,
    {
      have h0 : {a} ⊆ F,
      simp,
      exact ha,
      have h: E ∪ {a} ⊆ F,
      {exact union_subset hE h0,},
      specialize hF0 h,
      cases hF0 with S2 h11,
      cases h11 with hS2' h11,
      have h2: a ∈ S2,
      {
        have h3: a ∈ E ∪ {a},
        {simp,},
        rw ← h11 at h3,
        exact mem_of_mem_inter_right h3,
      },
      use erase S2 a,
      rw down.mem_compression at hS2',
      cases hS2' with hS2' hS2',
      {
        split,
        exact hS2'.right,
        have h3: a ∉ S,
        {
          rw down.mem_compression at hS,
          cases hS with hS hS,
          {
            exfalso,
            exact hS2 hS.1,
          },
          {
            cases hS with hS0 hS,
            by_contra hn,
            have himp: insert a S = S,
            {
            simp,
            exact hn,
            },
            rw himp at hS,
            exact hS0 hS,
          },
        },
        have h4: a ∉ E,
        {
          by_contra hn,
          rw ← h1 at hn,
          rw mem_inter at hn,
          exact h3 hn.2,
        },
        have h5: (F ∩ S2)\{a} = (E ∪ {a})\{a},
        {
          rw h11,
        },
        have h6: (E ∪ {a})\{a} = (E\{a}) ∪ ({a}\{a}):= finset.union_sdiff_distrib E {a} {a},
        simp at h6,
        have h7: E\{a} = E,
        {
          have h70: disjoint E {a},
          {
            simp,
            exact h4,
          },
          exact finset.sdiff_eq_self_of_disjoint h70,
        },
        rw h6 at h5,
        rw h7 at h5,
        rw ← h5,
        ext x,
        split,
        {
          intro hx,
          rw mem_inter at hx,
          rw mem_sdiff,
          split,
          {
            rw mem_inter,
            split,
            exact hx.1,
            have h8: S2.erase a ⊆ S2,
            {
              exact erase_subset a S2,
            },
            exact h8 hx.2,
          },
          {
            cases hx with hx1 hx2,
            rw mem_erase at hx2,
            simp,
            exact hx2.1,
          },
        },
        {
          intro hx,
          rw mem_inter,
          rw mem_sdiff at hx,
          cases hx with hx1 hx2,
          split,
          {
            rw mem_inter at hx1,
            exact hx1.1,
          },
          {
            rw mem_erase,
            simp at hx2,
            split,
            exact hx2,
            rw mem_inter at hx1,
            exact hx1.2,
          }
        }
      },
      {
        exfalso,
        cases hS2' with h3 h4,
        have h5: S2 = insert a S2,
        {
          have h6: insert a S2 = {a} ∪ S2 := insert_eq a S2,
          rw h6,
          have h7: {a} ∪ S2 = S2,
          {
            simp,
            exact h2,
          },
          rw h7,
        },
        rw ← h5 at h4,
        exact h3 h4,
      }

    },
    {
      rw down.mem_compression at hS,
      cases hS with hS hS,
      {
        exfalso,
        exact hS2 hS.1,
      },
      {
        cases hS with hS2 hS1,
        use insert a S,
        split,
        assumption,
        rw ← h1,
        have h7: {a} ∪ S = insert a S := rfl,
        rw ← h7,
        have h8: F ∩ ({a} ∪ S) = (F ∩ {a}) ∪ (F ∩ S) := finset.inter_distrib_left F {a} S,
        rw h8,
        have h9: F ∩ {a} = ∅ := inter_singleton_of_not_mem ha,
        rw h9,
        simp,
      }
    }
  }
end

/-- Down-compressing decreases the VC-dimension. -/
lemma vc_dimension_compress_le (a : α) (𝒜 : finset (finset α)) :
  (𝓓 a 𝒜).vc_dimension ≤ 𝒜.vc_dimension :=
begin
  have h: (𝓓 a 𝒜).shatterer ⊆ 𝒜.shatterer := ss_of_shatter_compress a 𝒜,
  rw def_vc_dimension,
  rw def_vc_dimension,
  simp,
  intros f hf,
  have hf': f ∈ (𝓓 a 𝒜).shatterer,
  rwa mem_shatterer,
  have h1: f ∈ 𝒜.shatterer := h hf',
  exact le_sup (h hf'),
end

/-- The **Sauer-Shelah lemma**. -/
lemma card_shatterer_le_sum_vc_dimension :
  𝒜.shatterer.card ≤ ∑ k in Iic 𝒜.vc_dimension, (fintype.card α).choose k :=
begin
  simp_rw [←card_univ, ←card_powerset_len],
  refine ((card_le_of_subset $ λ s hs, mem_bUnion.2 ⟨card s, _⟩).trans $ card_bUnion_le),
  exact ⟨mem_Iic.2 (mem_shatterer.1 hs).card_le_vc_dimension, mem_powerset_len_univ_iff.2 rfl⟩,
end

end finset


/-
Copyright (c) 2019 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel
-/
import geometry.manifold.algebra.smooth_functions
import linear_algebra.finite_dimensional
import analysis.normed_space.inner_product

/-!
# Constructing examples of manifolds over ℝ

We introduce the necessary bits to be able to define manifolds modelled over `ℝ^n`, boundaryless
or with boundary or with corners. As a concrete example, we construct explicitly the manifold with
boundary structure on the real interval `[x, y]`.

More specifically, we introduce
* `model_with_corners ℝ (euclidean_space ℝ (fin n)) (euclidean_half_space n)` for the model space
  used to define `n`-dimensional real manifolds with boundary
* `model_with_corners ℝ (euclidean_space ℝ (fin n)) (euclidean_quadrant n)` for the model space used
  to define `n`-dimensional real manifolds with corners

## Notations

In the locale `manifold`, we introduce the notations
* `𝓡 n` for the identity model with corners on `euclidean_space ℝ (fin n)`
* `𝓡∂ n` for `model_with_corners ℝ (euclidean_space ℝ (fin n)) (euclidean_half_space n)`.

For instance, if a manifold `M` is boundaryless, smooth and modelled on `euclidean_space ℝ (fin m)`,
and `N` is smooth with boundary modelled on `euclidean_half_space n`, and `f : M → N` is a smooth
map, then the derivative of `f` can be written simply as `mfderiv (𝓡 m) (𝓡∂ n) f` (as to why the
model with corners can not be implicit, see the discussion in `smooth_manifold_with_corners.lean`).

## Implementation notes

The manifold structure on the interval `[x, y] = Icc x y` requires the assumption `x < y` as a
typeclass. We provide it as `[fact (x < y)]`.
-/

noncomputable theory
open set function
open_locale manifold

/--
The half-space in `ℝ^n`, used to model manifolds with boundary. We only define it when
`1 ≤ n`, as the definition only makes sense in this case.
-/
def euclidean_half_space (n : ℕ) [has_zero (fin n)] : Type :=
{x : euclidean_space ℝ (fin n) // 0 ≤ x 0}

/--
The quadrant in `ℝ^n`, used to model manifolds with corners, made of all vectors with nonnegative
coordinates.
-/
def euclidean_quadrant (n : ℕ) : Type := {x : euclidean_space ℝ (fin n) // ∀i:fin n, 0 ≤ x i}

section
/- Register class instances for euclidean half-space and quadrant, that can not be noticed
without the following reducibility attribute (which is only set in this section). -/
local attribute [reducible] euclidean_half_space euclidean_quadrant
variable {n : ℕ}

instance [has_zero (fin n)] : topological_space (euclidean_half_space n) := by apply_instance
instance : topological_space (euclidean_quadrant n) := by apply_instance
instance [has_zero (fin n)] : inhabited (euclidean_half_space n) := ⟨⟨0, le_refl _⟩⟩
instance : inhabited (euclidean_quadrant n) := ⟨⟨0, λ i, le_refl _⟩⟩

lemma range_half_space (n : ℕ) [has_zero (fin n)] :
  range (λx : euclidean_half_space n, x.val) = {y | 0 ≤ y 0} :=
by simp

lemma range_quadrant (n : ℕ) :
  range (λx : euclidean_quadrant n, x.val) = {y | ∀i:fin n, 0 ≤ y i} :=
by simp

end

/--
Definition of the model with corners `(euclidean_space ℝ (fin n), euclidean_half_space n)`, used as
a model for manifolds with boundary. In the locale `manifold`, use the shortcut `𝓡∂ n`.
-/
def model_with_corners_euclidean_half_space (n : ℕ) [has_zero (fin n)] :
  model_with_corners ℝ (euclidean_space ℝ (fin n)) (euclidean_half_space n) :=
{ to_fun      := subtype.val,
  inv_fun     := λx, ⟨update x 0 (max (x 0) 0), by simp [le_refl]⟩,
  source      := univ,
  target      := {x | 0 ≤ x 0},
  map_source' := λx hx, x.property,
  map_target' := λx hx, mem_univ _,
  left_inv'   := λ ⟨xval, xprop⟩ hx, begin
    rw [subtype.mk_eq_mk, update_eq_iff],
    exact ⟨max_eq_left xprop, λ i _, rfl⟩
  end,
  right_inv'  := λx hx, update_eq_iff.2 ⟨max_eq_left hx, λ i _, rfl⟩,
  source_eq    := rfl,
  unique_diff' := by simpa only [singleton_pi]
    using unique_diff_on.pi (fin n) (λ _, ℝ) _ _ (λ i ∈ ({0} : set (fin n)), unique_diff_on_Ici 0),
  continuous_to_fun  := continuous_subtype_val,
  continuous_inv_fun := continuous_subtype_mk _ $ continuous_id.update 0 $
    (continuous_apply 0).max continuous_const }

/--
Definition of the model with corners `(euclidean_space ℝ (fin n), euclidean_quadrant n)`, used as a
model for manifolds with corners -/
def model_with_corners_euclidean_quadrant (n : ℕ) :
  model_with_corners ℝ (euclidean_space ℝ (fin n)) (euclidean_quadrant n) :=
{ to_fun      := subtype.val,
  inv_fun     := λx, ⟨λi, max (x i) 0, λi, by simp only [le_refl, or_true, le_max_iff]⟩,
  source      := univ,
  target      := {x | ∀ i, 0 ≤ x i},
  map_source' := λx hx, by simpa only [subtype.range_val] using x.property,
  map_target' := λx hx, mem_univ _,
  left_inv'   := λ ⟨xval, xprop⟩ hx, by { ext i, simp only [subtype.coe_mk, xprop i, max_eq_left] },
  right_inv' := λ x hx, by { ext1 i, simp only [hx i, max_eq_left] },
  source_eq    := rfl,
  unique_diff' := by simpa only [pi_univ_Ici]
    using unique_diff_on.univ_pi (fin n) (λ _, ℝ) _ (λ i, unique_diff_on_Ici 0),
  continuous_to_fun  := continuous_subtype_val,
  continuous_inv_fun := continuous_subtype_mk _ $ continuous_pi $ λ i,
    (continuous_id.max continuous_const).comp (continuous_apply i) }

localized "notation `𝓡 `n := model_with_corners_self ℝ (euclidean_space ℝ (fin n))" in manifold
localized "notation `𝓡∂ `n := model_with_corners_euclidean_half_space n" in manifold

/--
The left chart for the topological space `[x, y]`, defined on `[x,y)` and sending `x` to `0` in
`euclidean_half_space 1`.
-/
def Icc_left_chart (x y : ℝ) [fact (x < y)] :
  local_homeomorph (Icc x y) (euclidean_half_space 1) :=
{ source      := {z : Icc x y | z.val < y},
  target      := {z : euclidean_half_space 1 | z.val 0 < y - x},
  to_fun      := λ(z : Icc x y), ⟨λi, z.val - x, sub_nonneg.mpr z.property.1⟩,
  inv_fun     := λz, ⟨min (z.val 0 + x) y, by simp [le_refl, z.prop, le_of_lt (fact.out (x < y))]⟩,
  map_source' := by simp only [imp_self, sub_lt_sub_iff_right, mem_set_of_eq, forall_true_iff],
  map_target' :=
    by { simp only [min_lt_iff, mem_set_of_eq], assume z hz, left,
         dsimp [-subtype.val_eq_coe] at hz, linarith },
  left_inv'   := begin
    rintros ⟨z, hz⟩ h'z,
    simp only [mem_set_of_eq, mem_Icc] at hz h'z,
    simp only [hz, min_eq_left, sub_add_cancel]
  end,
  right_inv'  := begin
    rintros ⟨z, hz⟩ h'z,
    rw subtype.mk_eq_mk,
    funext,
    dsimp at hz h'z,
    have A : x + z 0 ≤ y, by linarith,
    rw subsingleton.elim i 0,
    simp only [A, add_comm, add_sub_cancel', min_eq_left],
  end,
  open_source := begin
    have : is_open {z : ℝ | z < y} := is_open_Iio,
    exact this.preimage continuous_subtype_val
  end,
  open_target := begin
    have : is_open {z : ℝ | z < y - x} := is_open_Iio,
    have : is_open {z : euclidean_space ℝ (fin 1) | z 0 < y - x} :=
      this.preimage (@continuous_apply (fin 1) (λ _, ℝ) _ 0),
    exact this.preimage continuous_subtype_val
  end,
  continuous_to_fun := begin
    apply continuous.continuous_on,
    apply continuous_subtype_mk,
    have : continuous (λ (z : ℝ) (i : fin 1), z - x) :=
      continuous.sub (continuous_pi $ λi, continuous_id) continuous_const,
    exact this.comp continuous_subtype_val,
  end,
  continuous_inv_fun := begin
    apply continuous.continuous_on,
    apply continuous_subtype_mk,
    have A : continuous (λ z : ℝ, min (z + x) y) :=
      (continuous_id.add continuous_const).min continuous_const,
    have B : continuous (λz : euclidean_space ℝ (fin 1), z 0) := continuous_apply 0,
    exact (A.comp B).comp continuous_subtype_val
  end }

/--
The right chart for the topological space `[x, y]`, defined on `(x,y]` and sending `y` to `0` in
`euclidean_half_space 1`.
-/
def Icc_right_chart (x y : ℝ) [fact (x < y)] :
  local_homeomorph (Icc x y) (euclidean_half_space 1) :=
{ source      := {z : Icc x y | x < z.val},
  target      := {z : euclidean_half_space 1 | z.val 0 < y - x},
  to_fun      := λ(z : Icc x y), ⟨λi, y - z.val, sub_nonneg.mpr z.property.2⟩,
  inv_fun     := λz,
    ⟨max (y - z.val 0) x, by simp [le_refl, z.prop, le_of_lt (fact.out (x < y)), sub_eq_add_neg]⟩,
  map_source' := by simp only [imp_self, mem_set_of_eq, sub_lt_sub_iff_left, forall_true_iff],
  map_target' :=
    by { simp only [lt_max_iff, mem_set_of_eq], assume z hz, left,
         dsimp [-subtype.val_eq_coe] at hz, linarith },
  left_inv'   := begin
    rintros ⟨z, hz⟩ h'z,
    simp only [mem_set_of_eq, mem_Icc] at hz h'z,
    simp only [hz, sub_eq_add_neg, max_eq_left, add_add_neg_cancel'_right, neg_add_rev, neg_neg]
  end,
  right_inv'  := begin
    rintros ⟨z, hz⟩ h'z,
    rw subtype.mk_eq_mk,
    funext,
    dsimp at hz h'z,
    have A : x ≤ y - z 0, by linarith,
    rw subsingleton.elim i 0,
    simp only [A, sub_sub_cancel, max_eq_left],
  end,
  open_source := begin
    have : is_open {z : ℝ | x < z} := is_open_Ioi,
    exact this.preimage continuous_subtype_val
  end,
  open_target := begin
    have : is_open {z : ℝ | z < y - x} := is_open_Iio,
    have : is_open {z : euclidean_space ℝ (fin 1) | z 0 < y - x} :=
      this.preimage (@continuous_apply (fin 1) (λ _, ℝ) _ 0),
    exact this.preimage continuous_subtype_val
  end,
  continuous_to_fun := begin
    apply continuous.continuous_on,
    apply continuous_subtype_mk,
    have : continuous (λ (z : ℝ) (i : fin 1), y - z) :=
      continuous_const.sub (continuous_pi (λi, continuous_id)),
    exact this.comp continuous_subtype_val,
  end,
  continuous_inv_fun := begin
    apply continuous.continuous_on,
    apply continuous_subtype_mk,
    have A : continuous (λ z : ℝ, max (y - z) x) :=
      (continuous_const.sub continuous_id).max continuous_const,
    have B : continuous (λz : euclidean_space ℝ (fin 1), z 0) := continuous_apply 0,
    exact (A.comp B).comp continuous_subtype_val
  end }

/--
Charted space structure on `[x, y]`, using only two charts taking values in
`euclidean_half_space 1`.
-/
instance Icc_manifold (x y : ℝ) [fact (x < y)] : charted_space (euclidean_half_space 1) (Icc x y) :=
{ atlas := {Icc_left_chart x y, Icc_right_chart x y},
  chart_at := λz, if z.val < y then Icc_left_chart x y else Icc_right_chart x y,
  mem_chart_source := λz, begin
    by_cases h' : z.val < y,
    { simp only [h', if_true],
      exact h' },
    { simp only [h', if_false],
      apply lt_of_lt_of_le (fact.out (x < y)),
      simpa only [not_lt] using h'}
  end,
  chart_mem_atlas := λz, by { by_cases h' : z.val < y; simp [h'] } }

/--
The manifold structure on `[x, y]` is smooth.
-/
instance Icc_smooth_manifold (x y : ℝ) [fact (x < y)] :
  smooth_manifold_with_corners (𝓡∂ 1) (Icc x y) :=
begin
  have M : times_cont_diff_on ℝ ∞ (λz : euclidean_space ℝ (fin 1), - z + (λi, y - x)) univ,
  { rw times_cont_diff_on_univ,
    exact times_cont_diff_id.neg.add times_cont_diff_const  },
  apply smooth_manifold_with_corners_of_times_cont_diff_on,
  assume e e' he he',
  simp only [atlas, mem_singleton_iff, mem_insert_iff] at he he',
  /- We need to check that any composition of two charts gives a `C^∞` function. Each chart can be
  either the left chart or the right chart, leaving 4 possibilities that we handle successively.
  -/
  rcases he with rfl | rfl; rcases he' with rfl | rfl,
  { -- `e = left chart`, `e' = left chart`
    exact (mem_groupoid_of_pregroupoid.mpr (symm_trans_mem_times_cont_diff_groupoid _ _ _)).1 },
  { -- `e = left chart`, `e' = right chart`
    apply M.congr_mono _ (subset_univ _),
    rintro _ ⟨⟨hz₁, hz₂⟩, ⟨⟨z, hz₀⟩, rfl⟩⟩,
    simp only [model_with_corners_euclidean_half_space, Icc_left_chart, Icc_right_chart,
      update_same, max_eq_left, hz₀, lt_sub_iff_add_lt] with mfld_simps at hz₁ hz₂,
    rw [min_eq_left hz₁.le, lt_add_iff_pos_left] at hz₂,
    ext i,
    rw subsingleton.elim i 0,
    simp only [model_with_corners_euclidean_half_space, Icc_left_chart, Icc_right_chart, *,
      pi_Lp.add_apply, pi_Lp.neg_apply, max_eq_left, min_eq_left hz₁.le, update_same]
      with mfld_simps,
    abel },
  { -- `e = right chart`, `e' = left chart`
    apply M.congr_mono _ (subset_univ _),
    rintro _ ⟨⟨hz₁, hz₂⟩, ⟨z, hz₀⟩, rfl⟩,
    simp only [model_with_corners_euclidean_half_space, Icc_left_chart, Icc_right_chart, max_lt_iff,
      update_same, max_eq_left hz₀] with mfld_simps at hz₁ hz₂,
    rw lt_sub at hz₁,
    ext i,
    rw subsingleton.elim i 0,
    simp only [model_with_corners_euclidean_half_space, Icc_left_chart, Icc_right_chart,
      pi_Lp.add_apply, pi_Lp.neg_apply, update_same, max_eq_left, hz₀, hz₁.le] with mfld_simps,
    abel },
  { -- `e = right chart`, `e' = right chart`
    exact (mem_groupoid_of_pregroupoid.mpr (symm_trans_mem_times_cont_diff_groupoid _ _ _)).1 }
end

/-! Register the manifold structure on `Icc 0 1`, and also its zero and one. -/
section

lemma fact_zero_lt_one : fact ((0 : ℝ) < 1) := ⟨zero_lt_one⟩

local attribute [instance] fact_zero_lt_one

instance : charted_space (euclidean_half_space 1) (Icc (0 : ℝ) 1) := by apply_instance
instance : smooth_manifold_with_corners (𝓡∂ 1) (Icc (0 : ℝ) 1) := by apply_instance

end


namespace graveyard

lemma closure_squeeze_term(X Y : set ℝ) (h₁ : X ⊆ Y) (h₂ : Y ⊆ closure(X))
    : closure(X) = closure(Y) :=
    -- Can either use set.eq_of_subset_of_subset or set.ext. The difference
    -- being whether we are showing that two sets are subsets of each other or
    -- whether we are showing that an object is an element of set X iff it is an
    -- element of Y. Both are equivalent, but we need to choose which to use.
    set.eq_of_subset_of_subset
      (assume x, assume h₃ : x ∈ closure(X),
        show x ∈ closure(Y), from
        begin
          intro ε,
          intro h₄,
          have h₅ : ∃ x' ∈ X, |x - x'| ≤ ε, from h₃ ε h₄,
          show ∃ y ∈ Y, |x - y| ≤ ε, from exists.elim h₅ (
            assume (x' : ℝ) (h: (∃hh₁ : (x' ∈ X), |x - x'| ≤ ε)),
            exists.elim h (
              assume (hhh₁ : x' ∈ X) (hhh₂ : |x - x'| ≤ ε),
              have hhh₃ : x' ∈ Y, from h₁ hhh₁,
              show ∃y ∈ Y, |x - y| ≤ ε, from
                exists.intro x' (exists.intro hhh₃ hhh₂))),
        end)
      (assume y, assume h₃ : y ∈ closure(Y),
        show y ∈ closure(X), from
          assume ε,
          assume h₄,
          have h₅ : ∃δ : ℝ, δ = ε/3, from exists_eq,
          have h₆ : ∃x ∈ X, |y - x| ≤ ε, from exists.elim h₅
            (assume (δ : ℝ) (hh₁ : δ = ε/3),
            have hh₃ : δ > 0, by linarith,
            have hh₂ : ∃ y' ∈ Y, |y - y'| ≤ δ, from h₃ δ hh₃,
            exists.elim hh₂
              (assume (y' : ℝ) (hh₄ : ∃ hhh₁ : y' ∈ Y, | y - y'| ≤ δ),
              exists.elim hh₄
                (assume (h4₁ : y' ∈ Y) (h4₂ : |y - y'| ≤ δ),
                have h4₃ : y' ∈ closure(X), from h₂ h4₁,
                have h4₄ : ∃x ∈ X, |y' - x| ≤ δ, from h4₃ δ hh₃,
                exists.elim h4₄
                  (assume (x : ℝ) (h4₅ : ∃ h5₁ : x ∈ X, |y' - x| ≤ δ),
                  exists.elim h4₅
                    (assume (h5₁ : x ∈ X) (h5₂ : |y' - x| ≤ δ),
                    --norm_add_le_of_le (by apply_instance) h4₂ h5₂
                    have h5₇ : |y - x| ≤ 2*δ, from sorry,
                    have h5₈ : |y - x| ≤ ε, by linarith,
                    have h5₉ : ∃x' ∈ X, |y - x'| ≤ ε, from
                       exists.intro x (exists.intro h5₁ h5₈),
                    h5₉))))),
          h₆)

end graveyard


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

import category_theory.limits.shapes.reflexive
import category_theory.limits.shapes.split_coequalizer
import category_theory.monad.algebra

/-!
# Special coequalizers associated to a monad

Associated to a monad `T : C ⥤ C` we have important coequalizer constructions:
Any algebra is a coequalizer (in the category of algebras) of free algebras. Furthermore, this
coequalizer is reflexive.
In `C`, this cofork diagram is a split coequalizer (in particular, it is still a coequalizer).
This split coequalizer is known as the Beck coequalizer (as it features heavily in Beck's
monadicity theorem).
-/
universes v₁ u₁

namespace category_theory
namespace monad
open limits

variables {C : Type u₁}
variables [category.{v₁} C]
variables {T : monad C} (X : algebra T)

/-!
Show that any algebra is a coequalizer of free algebras.
-/

/-- The top map in the coequalizer diagram we will construct. -/
@[simps]
def free_coequalizer.top_map : (monad.free T).obj (T.obj X.A) ⟶ (monad.free T).obj X.A :=
(monad.free T).map X.a

/-- The bottom map in the coequalizer diagram we will construct. -/
@[simps]
def free_coequalizer.bottom_map : (monad.free T).obj (T.obj X.A) ⟶ (monad.free T).obj X.A :=
{ f := T.μ.app X.A,
  h' := T.assoc X.A }

/-- The cofork map in the coequalizer diagram we will construct. -/
@[simps]
def free_coequalizer.π : (monad.free T).obj X.A ⟶ X :=
{ f := X.a,
  h' := X.assoc.symm }

lemma free_coequalizer.condition :
  free_coequalizer.top_map X ≫ free_coequalizer.π X =
  free_coequalizer.bottom_map X ≫ free_coequalizer.π X :=
algebra.hom.ext _ _ X.assoc.symm

instance : is_reflexive_pair (free_coequalizer.top_map X) (free_coequalizer.bottom_map X) :=
begin
  apply is_reflexive_pair.mk' _ _ _,
  apply (free T).map (T.η.app X.A),
  { ext,
    dsimp,
    rw [← functor.map_comp, X.unit, functor.map_id] },
  { ext,
    apply monad.right_unit }
end

/--
Construct the Beck cofork in the category of algebras. This cofork is reflexive as well as a
coequalizer.
-/
@[simps]
def beck_algebra_cofork : cofork (free_coequalizer.top_map X) (free_coequalizer.bottom_map X) :=
cofork.of_π _ (free_coequalizer.condition X)

/--
The cofork constructed is a colimit. This shows that any algebra is a (reflexive) coequalizer of
free algebras.
-/
def beck_algebra_coequalizer : is_colimit (beck_algebra_cofork X) :=
cofork.is_colimit.mk' _ $ λ s,
begin
  have h₁ : (T : C ⥤ C).map X.a ≫ s.π.f = T.μ.app X.A ≫ s.π.f :=
    congr_arg monad.algebra.hom.f s.condition,
  have h₂ : (T : C ⥤ C).map s.π.f ≫ s.X.a = T.μ.app X.A ≫ s.π.f := s.π.h,
  refine ⟨⟨T.η.app _ ≫ s.π.f, _⟩, _, _⟩,
  { dsimp,
    rw [functor.map_comp, category.assoc, h₂, monad.right_unit_assoc,
        (show X.a ≫ _ ≫ _ = _, from T.η.naturality_assoc _ _), h₁, monad.left_unit_assoc] },
  { ext,
    simpa [← T.η.naturality_assoc, T.left_unit_assoc] using T.η.app ((T : C ⥤ C).obj X.A) ≫= h₁ },
  { intros m hm,
    ext,
    dsimp only,
    rw ← hm,
    apply (X.unit_assoc _).symm }
end

/-- The Beck cofork is a split coequalizer. -/
def beck_split_coequalizer : is_split_coequalizer (T.map X.a) (T.μ.app _) X.a :=
⟨T.η.app _, T.η.app _, X.assoc.symm, X.unit, T.left_unit _, (T.η.naturality _).symm⟩

/-- This is the Beck cofork. It is a split coequalizer, in particular a coequalizer. -/
@[simps X]
def beck_cofork : cofork (T.map X.a) (T.μ.app _) :=
(beck_split_coequalizer X).as_cofork

@[simp] lemma beck_cofork_π : (beck_cofork X).π = X.a := rfl

/-- The Beck cofork is a coequalizer. -/
def beck_coequalizer : is_colimit (beck_cofork X) :=
(beck_split_coequalizer X).is_coequalizer

@[simp] lemma beck_coequalizer_desc (s : cofork (T.to_functor.map X.a) (T.μ.app X.A)) :
  (beck_coequalizer X).desc s = T.η.app _ ≫ s.π := rfl

end monad
end category_theory


/-
Copyright (c) 2019 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author(s): Simon Hudon
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.control.monad.basic
import Mathlib.data.fintype.basic
import Mathlib.PostPort

universes u_1 l u_2

namespace Mathlib

/-!
Type class for finitely enumerable types. The property is stronger
than `fintype` in that it assigns each element a rank in a finite
enumeration.
-/

/-- `fin_enum α` means that `α` is finite and can be enumerated in some order,
  i.e. `α` has an explicit bijection with `fin n` for some n. -/
class fin_enum (α : Sort u_1)
where
  card : ℕ
  equiv : α ≃ fin card
  dec_eq : DecidableEq α

namespace fin_enum

/-- transport a `fin_enum` instance across an equivalence -/
def of_equiv (α : Sort u_1) {β : Sort u_2} [fin_enum α] (h : β ≃ α) : fin_enum β :=
  mk (card α) (equiv.trans h (equiv α))

/-- create a `fin_enum` instance from an exhaustive list without duplicates -/
def of_nodup_list {α : Type u_1} [DecidableEq α] (xs : List α) (h : ∀ (x : α), x ∈ xs) (h' : list.nodup xs) : fin_enum α :=
  mk (list.length xs)
    (equiv.mk (fun (x : α) => { val := list.index_of x xs, property := sorry }) (fun (_x : fin (list.length xs)) => sorry)
      sorry sorry)

/-- create a `fin_enum` instance from an exhaustive list; duplicates are removed -/
def of_list {α : Type u_1} [DecidableEq α] (xs : List α) (h : ∀ (x : α), x ∈ xs) : fin_enum α :=
  of_nodup_list (list.erase_dup xs) sorry sorry

/-- create an exhaustive list of the values of a given type -/
def to_list (α : Type u_1) [fin_enum α] : List α :=
  list.map (⇑(equiv.symm (equiv α))) (list.fin_range (card α))

@[simp] theorem mem_to_list {α : Type u_1} [fin_enum α] (x : α) : x ∈ to_list α := sorry

@[simp] theorem nodup_to_list {α : Type u_1} [fin_enum α] : list.nodup (to_list α) := sorry

/-- create a `fin_enum` instance using a surjection -/
def of_surjective {α : Type u_1} {β : Type u_2} (f : β → α) [DecidableEq α] [fin_enum β] (h : function.surjective f) : fin_enum α :=
  of_list (list.map f (to_list β)) sorry

/-- create a `fin_enum` instance using an injection -/
def of_injective {α : Type u_1} {β : Type u_2} (f : α → β) [DecidableEq α] [fin_enum β] (h : function.injective f) : fin_enum α :=
  of_list (list.filter_map (function.partial_inv f) (to_list β)) sorry

protected instance pempty : fin_enum pempty :=
  of_list [] sorry

protected instance empty : fin_enum empty :=
  of_list [] sorry

protected instance punit : fin_enum PUnit :=
  of_list [PUnit.unit] sorry

protected instance prod {α : Type u_1} {β : Type u_2} [fin_enum α] [fin_enum β] : fin_enum (α × β) :=
  of_list (list.product (to_list α) (to_list β)) sorry

protected instance sum {α : Type u_1} {β : Type u_2} [fin_enum α] [fin_enum β] : fin_enum (α ⊕ β) :=
  of_list (list.map sum.inl (to_list α) ++ list.map sum.inr (to_list β)) sorry

protected instance fin {n : ℕ} : fin_enum (fin n) :=
  of_list (list.fin_range n) sorry

protected instance quotient.enum {α : Type u_1} [fin_enum α] (s : setoid α) [DecidableRel has_equiv.equiv] : fin_enum (quotient s) :=
  of_surjective quotient.mk sorry

/-- enumerate all finite sets of a given type -/
def finset.enum {α : Type u_1} [DecidableEq α] : List α → List (finset α) :=
  sorry

@[simp] theorem finset.mem_enum {α : Type u_1} [DecidableEq α] (s : finset α) (xs : List α) : s ∈ finset.enum xs ↔ ∀ (x : α), x ∈ s → x ∈ xs := sorry

protected instance finset.fin_enum {α : Type u_1} [fin_enum α] : fin_enum (finset α) :=
  of_list (finset.enum (to_list α)) sorry

protected instance subtype.fin_enum {α : Type u_1} [fin_enum α] (p : α → Prop) [decidable_pred p] : fin_enum (Subtype fun (x : α) => p x) :=
  of_list
    (list.filter_map
      (fun (x : α) => dite (p x) (fun (h : p x) => some { val := x, property := h }) fun (h : ¬p x) => none) (to_list α))
    sorry

protected instance sigma.fin_enum {α : Type u_1} (β : α → Type u_2) [fin_enum α] [(a : α) → fin_enum (β a)] : fin_enum (sigma β) :=
  of_list (list.bind (to_list α) fun (a : α) => list.map (sigma.mk a) (to_list (β a))) sorry

protected instance psigma.fin_enum {α : Type u_1} {β : α → Type u_2} [fin_enum α] [(a : α) → fin_enum (β a)] : fin_enum (psigma fun (a : α) => β a) :=
  of_equiv (sigma fun (i : α) => β i) (equiv.psigma_equiv_sigma fun (i : α) => β i)

protected instance psigma.fin_enum_prop_left {α : Prop} {β : α → Type u_1} [(a : α) → fin_enum (β a)] [Decidable α] : fin_enum (psigma fun (a : α) => β a) :=
  dite α (fun (h : α) => of_list (list.map (psigma.mk h) (to_list (β h))) sorry) fun (h : ¬α) => of_list [] sorry

protected instance psigma.fin_enum_prop_right {α : Type u_1} {β : α → Prop} [fin_enum α] [(a : α) → Decidable (β a)] : fin_enum (psigma fun (a : α) => β a) :=
  of_equiv (Subtype fun (a : α) => β a)
    (equiv.mk (fun (_x : psigma fun (a : α) => β a) => sorry) (fun (_x : Subtype fun (a : α) => β a) => sorry) sorry
      sorry)

protected instance psigma.fin_enum_prop_prop {α : Prop} {β : α → Prop} [Decidable α] [(a : α) → Decidable (β a)] : fin_enum (psigma fun (a : α) => β a) :=
  dite (∃ (a : α), β a) (fun (h : ∃ (a : α), β a) => of_list [psigma.mk sorry sorry] sorry)
    fun (h : ¬∃ (a : α), β a) => of_list [] sorry

protected instance fintype {α : Type u_1} [fin_enum α] : fintype α :=
  fintype.mk (finset.map (equiv.to_embedding (equiv.symm (equiv α))) finset.univ) sorry

/-- For `pi.cons x xs y f` create a function where every `i ∈ xs` is mapped to `f i` and
`x` is mapped to `y`  -/
def pi.cons {α : Type u_1} {β : α → Type u_2} [DecidableEq α] (x : α) (xs : List α) (y : β x) (f : (a : α) → a ∈ xs → β a) (a : α) : a ∈ x :: xs → β a :=
  sorry

/-- Given `f` a function whose domain is `x :: xs`, produce a function whose domain
is restricted to `xs`.  -/
def pi.tail {α : Type u_1} {β : α → Type u_2} {x : α} {xs : List α} (f : (a : α) → a ∈ x :: xs → β a) (a : α) : a ∈ xs → β a :=
  sorry

/-- `pi xs f` creates the list of functions `g` such that, for `x ∈ xs`, `g x ∈ f x` -/
def pi {α : Type u_1} {β : α → Type (max u_1 u_2)} [DecidableEq α] (xs : List α) : ((a : α) → List (β a)) → List ((a : α) → a ∈ xs → β a) :=
  sorry

theorem mem_pi {α : Type u_1} {β : α → Type (max u_1 u_2)} [fin_enum α] [(a : α) → fin_enum (β a)] (xs : List α) (f : (a : α) → a ∈ xs → β a) : f ∈ pi xs fun (x : α) => to_list (β x) := sorry

/-- enumerate all functions whose domain and range are finitely enumerable -/
def pi.enum {α : Type u_1} (β : α → Type (max u_1 u_2)) [fin_enum α] [(a : α) → fin_enum (β a)] : List ((a : α) → β a) :=
  list.map (fun (f : (a : α) → a ∈ to_list α → β a) (x : α) => f x (mem_to_list x))
    (pi (to_list α) fun (x : α) => to_list (β x))

theorem pi.mem_enum {α : Type u_1} {β : α → Type (max u_1 u_2)} [fin_enum α] [(a : α) → fin_enum (β a)] (f : (a : α) → β a) : f ∈ pi.enum β := sorry

protected instance pi.fin_enum {α : Type u_1} {β : α → Type (max u_1 u_2)} [fin_enum α] [(a : α) → fin_enum (β a)] : fin_enum ((a : α) → β a) :=
  of_list (pi.enum fun (a : α) => β a) sorry

protected instance pfun_fin_enum (p : Prop) [Decidable p] (α : p → Type u_1) [(hp : p) → fin_enum (α hp)] : fin_enum ((hp : p) → α hp) :=
  dite p (fun (hp : p) => of_list (list.map (fun (x : α hp) (hp' : p) => x) (to_list (α hp))) sorry)
    fun (hp : ¬p) => of_list [fun (hp' : p) => false.elim (hp hp')] sorry