import ring_theory.localization
/-!
This file proves some properties on localizations that are needed to define mutations.

## Main statements

* `is_localization_of_lift_of_sup`: let `A`, `B`, and `C` are commutative rings, and `M` and `N`
  are submonoids of `A`. Suppose that `B` is a localization of `A` at `M` and `C` is a localization
  of `A` at `M ⊔ N`. Then `C` is a localization of `B` at the image of `N` by the localization map
  from `A` to `B`.

-/

namespace is_localization

section

variables
{A : Type*}  [comm_ring A]
(M N : submonoid A)
(B : Type*) [comm_ring B] (C : Type*) [comm_ring C]
[algebra A B] [algebra A C]
[is_localization M B] [is_localization (M ⊔ N) C]

include M N

noncomputable def lift_of_sup : B →+* C :=
lift $ λ h, by simpa only [set_like.coe_mk] using map_units C (⟨h.1, set_like.le_def.mp le_sup_left h.2⟩ : M ⊔ N)

noncomputable def algebra_of_lift_of_sup : algebra B C := ring_hom.to_algebra (lift_of_sup M N B C)

local attribute[instance] algebra_of_lift_of_sup

lemma eq_comp_map_of_lift_of_sup (a : A) : algebra_map A C a = (algebra_map B C (algebra_map A B a)):=
begin
  have : algebra_map B C = lift_of_sup M N B C := by refl,
  rw [this, lift_of_sup, lift_eq],
end

lemma eq_comp_of_lift_of_sup : (algebra_map A C) = (algebra_map B C).comp (algebra_map A B) :=
by ext; by rw [ring_hom.coe_comp]; by exact eq_comp_map_of_lift_of_sup M N B C _

lemma is_localization_of_lift_of_sup
{A : Type*}  [comm_ring A]
(M : submonoid A) (N : submonoid A)
(B : Type*) [comm_ring B] (C : Type*) [comm_ring C]
[algebra A B] [algebra A C]
[is_localization M B] [is_localization (M ⊔ N) C] :
is_localization (N.map (algebra_map A B) : submonoid B) C :=
{ map_units :=
  begin
    intros n',
    rcases submonoid.mem_map.mp n'.property with ⟨n, ⟨hn, H⟩⟩,
    have : n ∈ M ⊔ N := set_like.le_def.mp le_sup_right hn,
    simp only [ring_hom.coe_monoid_hom, subtype.val_eq_coe] at H,
    rw [<- H, <- eq_comp_map_of_lift_of_sup],
    exact is_localization.map_units C ⟨n, this⟩,
  end,
  surj :=
  begin
    intros c,
    rcases surj (M ⊔ N) c with ⟨⟨a, ⟨mn, h_mn⟩⟩ , H⟩,
    rcases submonoid.mem_sup.mp h_mn with ⟨m, hm, n, hn, H'⟩,
    repeat {rw eq_comp_map_of_lift_of_sup M N B C at H},
    rw [set_like.coe_mk] at H,
    dsimp at H,
    have : algebra_map A B n ∈ (N.map (algebra_map A B) : submonoid B),
    apply submonoid.mem_map.mpr,
    use n,
    use hn,
    rw [ring_hom.coe_monoid_hom],
    fsplit,
    fsplit,
    exact ↑((is_unit.unit (map_units B ⟨m, hm⟩))⁻¹) * (algebra_map A B a),
    exact ⟨algebra_map A B n, this⟩,
    simp only [set_like.coe_mk, ring_hom.map_mul],
    rw [<- H, <- H'],
    simp only [ring_hom.map_mul],
    ring_nf,
    apply congr_arg ( * c),
    nth_rewrite  0 <- one_mul ((algebra_map B C) ((algebra_map A B) n)),
    apply congr_arg ( * ((algebra_map B C) ((algebra_map A B) n))),
    rw <- ring_hom.map_mul,
    rw <- ring_hom.map_one (algebra_map B C),
    apply congr_arg,
    rw units.mul_inv_of_eq,
    rw is_unit.unit_spec,
  end,
  eq_iff_exists :=
  begin
    intros b₁ b₂,
    split,
    { intros h,
      rcases surj M b₁ with ⟨⟨a₁, ⟨m₁, hm₁⟩⟩, H₁⟩,
      rcases surj M b₂ with ⟨⟨a₂, ⟨m₂, hm₂⟩⟩, H₂⟩,
      have : algebra_map A C (a₁ * m₂) = algebra_map A C (a₂ * m₁),
      rw eq_comp_map_of_lift_of_sup M N B C,
      rw eq_comp_map_of_lift_of_sup M N B C,
      dsimp at *,
      simp only [ring_hom.map_mul],
      rw [<- H₁, <- H₂],
      simp only [ring_hom.map_mul],
      rw h,
      ring,
      rcases (eq_iff_exists (M ⊔ N) C).mp this with ⟨⟨mn, mn_in⟩, hmn⟩,
      rcases submonoid.mem_sup.mp mn_in with ⟨m, hm, n, hn, H'⟩,
      dsimp at *,
      have : algebra_map A B n ∈ submonoid.map ↑(algebra_map A B) N,
      apply submonoid.mem_map.mpr,
      use n,
      use hn,
      rw [ring_hom.coe_monoid_hom],
      use ⟨algebra_map A B n, this⟩,
      dsimp,
      refine (is_unit.mul_left_inj _).mp _,
      exact algebra_map A B m,
      exact map_units B ⟨m, hm⟩,
      repeat {rw [mul_assoc, <- ring_hom.map_mul]},
      rw mul_comm at H',
      rw H',
      have hb₁ : b₁ = mk' B a₁ ⟨m₁, hm₁⟩ := eq_mk'_iff_mul_eq.mpr H₁,
      have hb₂ : b₂ = mk' B a₂ ⟨m₂, hm₂⟩ := eq_mk'_iff_mul_eq.mpr H₂,
      rw [hb₁, hb₂],
      nth_rewrite_lhs 0 mul_comm,
      nth_rewrite_rhs 0 mul_comm,
      rw [mul_mk'_eq_mk'_of_mul, mul_mk'_eq_mk'_of_mul],
      refine mk'_eq_of_eq _,
      dsimp,
      exact calc mn * a₂ * m₁ = a₂ * m₁ * mn : by ring
      ...                     = a₁ * m₂ * mn : by rw <-hmn
      ...                     = mn * a₁ * m₂ : by ring },
    { intros h,
      rcases h with ⟨⟨n', hn'⟩, H⟩,
      rcases submonoid.mem_map.mp hn' with ⟨n, ⟨hn, H'⟩⟩,
      have n_in : n ∈ M ⊔ N := submonoid.mem_sup_right hn,
      rcases surj M b₁ with ⟨⟨a₁, ⟨m₁, hm₁⟩⟩, H₁⟩,
      rcases surj M b₂ with ⟨⟨a₂, ⟨m₂, hm₂⟩⟩, H₂⟩,
      dsimp at *,
      have : ∃ m : M, a₁ * m₂ * n * m = a₂ * m₁ * n * m,
      refine (eq_iff_exists M B).mp _,
      simp only [ring_hom.map_mul],
      rw H',
      rw [<- H₁, <- H₂],
      exact calc b₁ * (algebra_map A B) m₁ * (algebra_map A B) m₂ * n'
               = b₁ * n' * (algebra_map A B) m₁ * (algebra_map A B) m₂  : by ring
      ...      = b₂ * n' * (algebra_map A B) m₁ * (algebra_map A B) m₂  : by rw H
      ...      = b₂ * (algebra_map A B) m₂ * (algebra_map A B) m₁ * n'  : by ring,
      rcases this with ⟨⟨m, hm⟩, H''⟩,
      dsimp at H'',
      have p : algebra_map A C (a₁ * m₂) = algebra_map A C (a₂ * m₁),
      refine (eq_iff_exists (M ⊔ N) C).mpr _,
      use ⟨n * m, mul_comm m n ▸ submonoid.mul_mem _ (submonoid.mem_sup_left hm) (submonoid.mem_sup_right hn)⟩,
      dsimp,
      repeat {rw <- mul_assoc},
      exact H'',
      repeat {rw eq_comp_map_of_lift_of_sup M N B C at p},
      simp only [ring_hom.map_mul] at p,
      rw [<- H₁, <- H₂] at p,
      refine (is_unit.mul_left_inj _).mp _,
      exact algebra_map A C (m₁ * m₂),
      have : m₁ * m₂ ∈ M ⊔ N,
      refine submonoid.mul_mem _ (submonoid.mem_sup_left hm₁) (submonoid.mem_sup_left hm₂),
      exact map_units C ⟨m₁ * m₂, this⟩,
      repeat {rw eq_comp_map_of_lift_of_sup M N B C},
      simp only [ring_hom.map_mul] at *,
      repeat {rw mul_assoc at *},
      nth_rewrite 3 mul_comm,
      exact p }
  end, }

end

section

variables
{A : Type*}  [comm_ring A]
{M : submonoid A} {N : submonoid A}
(B : Type*) [comm_ring B] (C : Type*) [comm_ring C]
[algebra A B] [algebra A C]
[is_localization M B] [is_localization N C]
(h : M ≤ N)

include h

noncomputable def lift_of_le : B →+* C :=
@lift_of_sup A _ M N B _ C _ _ _ _ (by rw sup_eq_right.mpr h; by apply_instance)

noncomputable def algebra_of_lift_of_le : algebra B C :=
ring_hom.to_algebra (lift_of_le B C h)

lemma eq_comp_map_of_lift_of_le (a : A) :
algebra_map A C a = @algebra_map B C _ _ (algebra_of_lift_of_le B C h) (algebra_map A B a) :=
begin
  have : @algebra_map B C _ _ (algebra_of_lift_of_le B C h) = lift_of_le B C h := by refl,
  rw this,
  dunfold lift_of_le lift_of_sup,
  rw lift_eq,
end

def is_localization_of_lift_of_le (h : M ≤ N) :
@is_localization _ _ (N.map (algebra_map A B) : submonoid B) C _ (algebra_of_lift_of_le B C h) :=
@is_localization_of_lift_of_sup A _ M N B _ C _ _ _ _ (by rw sup_eq_right.mpr h; apply_instance)

end

section

variables
{A : Type*} [comm_ring A] {M N : submonoid A}
(B : Type*) [comm_ring B]
[algebra A B] [is_localization M B]

lemma is_localization_of_le_of_exists_mul_mem (h_le : M ≤ N) (h : ∀ n : N, ∃ a : A, ↑n * a ∈ M) :
is_localization N B :=
begin
  split,
  { rintros ⟨n, hn⟩,
    rcases h ⟨n, hn⟩ with ⟨a, hm⟩,
    let p := map_units B ⟨n * a, hm⟩,
    simp only [set_like.coe_mk, is_unit.mul_iff, ring_hom.map_mul] at p,
    exact p.left },
  { intros b,
    rcases surj M b with ⟨⟨a, ⟨m, hm⟩⟩, H⟩,
    use ⟨a, ⟨m, set_like.le_def.mp h_le hm⟩⟩,
    exact H },
  { intros a₁ a₂,
    split,
    intros ha,
    rcases (eq_iff_exists M B).mp ha with ⟨⟨m, hm⟩, H⟩,
    use ⟨m, set_like.le_def.mp h_le hm⟩,
    exact H,
    rintros ⟨⟨n, hn⟩, H⟩,
    rcases h ⟨n, hn⟩ with ⟨a, hm⟩,
    apply (eq_iff_exists M B).mpr _,
    use ⟨n * a, hm⟩,
    rw [set_like.coe_mk, <-mul_assoc, <-mul_assoc],
    congr' 1 }
end

end

section

variables {A : Type*} [integral_domain A] {f : A} (h_ne : f ≠ 0)
(B : Type*) [integral_domain B] (C : Type*) [integral_domain C]
[algebra A B] [algebra A C]
[is_localization.away f B] [is_fraction_ring A C]

--local attribute[instance] algebra_of_lift_of_le
include f h_ne

noncomputable def lift_of_away_frac : B →+* C :=
lift_of_le B C (powers_le_non_zero_divisors_of_no_zero_divisors  h_ne)

noncomputable def algebra_of_away_frac : algebra B C :=
ring_hom.to_algebra (lift_of_away_frac h_ne B C)

--local attribute [instance] algebra_of_away_frac

lemma eq_comp_map_of_lift_of_of_away_frac (a : A) : algebra_map A C a =
@algebra_map B C _ _ (algebra_of_away_frac h_ne B C) (algebra_map A B a) :=
begin
  have : @algebra_map B C _ _ (algebra_of_away_frac h_ne B C) = lift_of_away_frac h_ne B C := by refl,
  rw this,
  dunfold lift_of_away_frac lift_of_le lift_of_sup,
  rw lift_eq,
end

def is_localization_of_away :
@is_localization B _ ((non_zero_divisors A).map (algebra_map A B) : submonoid B) C _
  (algebra_of_lift_of_le B C
  (powers_le_non_zero_divisors_of_no_zero_divisors  h_ne)) :=
is_localization_of_lift_of_le B C _

lemma non_zero_map_le_non_zero :
((non_zero_divisors A).map (algebra_map A B) : submonoid B) ≤ non_zero_divisors B :=
begin
  rintros x ⟨a, ⟨ha, H⟩⟩,
  rw <- H,
  refine ring_hom.map_mem_non_zero_divisors _ _ ha,
  refine is_localization.injective B (powers_le_non_zero_divisors_of_no_zero_divisors  h_ne),
end

lemma exists_mul_mem_of_away_of_ne_zero (g : non_zero_divisors B) :
∃ b : B, ↑g * b ∈ ((non_zero_divisors A).map (algebra_map A B) : submonoid B) :=
begin
  rcases is_localization.surj (submonoid.powers f) (g : B) with ⟨⟨gn, ⟨gd, hg⟩⟩, H⟩,
  dsimp at H,
  use algebra_map A B gd,
  rw H,
  simp only [submonoid.mem_map],
  refine ⟨gn, _, rfl⟩,
  rw mem_non_zero_divisors_iff_ne_zero,
  intros h,
  let p := (is_localization.to_map_eq_zero_iff B (powers_le_non_zero_divisors_of_no_zero_divisors  h_ne)).mpr h,
  rw <- H at p,
  have hgd : (algebra_map A B) gd ∈ non_zero_divisors B,
  rw mem_non_zero_divisors_iff_ne_zero,
  refine is_localization.to_map_ne_zero_of_mem_non_zero_divisors B (powers_le_non_zero_divisors_of_no_zero_divisors  h_ne) _,
  refine set_like.le_def.mp (powers_le_non_zero_divisors_of_no_zero_divisors  h_ne) hg,
  let q := (non_zero_divisors B).mul_mem' g.2 hgd,
  simp at q,
  rw mem_non_zero_divisors_iff_ne_zero at q,
  refine q p,
end

set_option pp.implicit false

def is_fraction_of_algebra_of_away_frac :
@is_fraction_ring B _ C _ (algebra_of_away_frac h_ne B C):=
begin
  letI : algebra B C := (algebra_of_away_frac h_ne B C),
  haveI := is_localization_of_away h_ne B C,
  exact is_localization_of_le_of_exists_mul_mem C (non_zero_map_le_non_zero h_ne B)
    (λ n, exists_mul_mem_of_away_of_ne_zero h_ne B n),
end

end

end is_localization


/-
Copyright (c) 2021 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import analysis.convex.basic
import topology.algebra.order.basic

/-!
# Strictly convex sets

This file defines strictly convex sets.

A set is strictly convex if the open segment between any two distinct points lies in its interior.
-/

open set
open_locale convex pointwise

variables {𝕜 𝕝 E F β : Type*}

open function set
open_locale convex

section ordered_semiring
variables [ordered_semiring 𝕜] [topological_space E] [topological_space F]

section add_comm_monoid
variables [add_comm_monoid E] [add_comm_monoid F]

section has_smul
variables (𝕜) [has_smul 𝕜 E] [has_smul 𝕜 F] (s : set E)

/-- A set is strictly convex if the open segment between any two distinct points lies is in its
interior. This basically means "convex and not flat on the boundary". -/
def strict_convex : Prop :=
s.pairwise $ λ x y, ∀ ⦃a b : 𝕜⦄, 0 < a → 0 < b → a + b = 1 → a • x + b • y ∈ interior s

variables {𝕜 s} {x y : E} {a b : 𝕜}

lemma strict_convex_iff_open_segment_subset :
  strict_convex 𝕜 s ↔ s.pairwise (λ x y, open_segment 𝕜 x y ⊆ interior s) :=
forall₅_congr $ λ x hx y hy hxy, (open_segment_subset_iff 𝕜).symm

lemma strict_convex.open_segment_subset (hs : strict_convex 𝕜 s) (hx : x ∈ s) (hy : y ∈ s)
  (h : x ≠ y) :
  open_segment 𝕜 x y ⊆ interior s :=
strict_convex_iff_open_segment_subset.1 hs hx hy h

lemma strict_convex_empty : strict_convex 𝕜 (∅ : set E) := pairwise_empty _

lemma strict_convex_univ : strict_convex 𝕜 (univ : set E) :=
begin
  intros x hx y hy hxy a b ha hb hab,
  rw interior_univ,
  exact mem_univ _,
end

protected lemma strict_convex.eq (hs : strict_convex 𝕜 s) (hx : x ∈ s) (hy : y ∈ s) (ha : 0 < a)
  (hb : 0 < b) (hab : a + b = 1) (h : a • x + b • y ∉ interior s) : x = y :=
hs.eq hx hy $ λ H, h $ H ha hb hab

protected lemma strict_convex.inter {t : set E} (hs : strict_convex 𝕜 s) (ht : strict_convex 𝕜 t) :
  strict_convex 𝕜 (s ∩ t) :=
begin
  intros x hx y hy hxy a b ha hb hab,
  rw interior_inter,
  exact ⟨hs hx.1 hy.1 hxy ha hb hab, ht hx.2 hy.2 hxy ha hb hab⟩,
end

lemma directed.strict_convex_Union {ι : Sort*} {s : ι → set E} (hdir : directed (⊆) s)
  (hs : ∀ ⦃i : ι⦄, strict_convex 𝕜 (s i)) :
  strict_convex 𝕜 (⋃ i, s i) :=
begin
  rintro x hx y hy hxy a b ha hb hab,
  rw mem_Union at hx hy,
  obtain ⟨i, hx⟩ := hx,
  obtain ⟨j, hy⟩ := hy,
  obtain ⟨k, hik, hjk⟩ := hdir i j,
  exact interior_mono (subset_Union s k) (hs (hik hx) (hjk hy) hxy ha hb hab),
end

lemma directed_on.strict_convex_sUnion {S : set (set E)} (hdir : directed_on (⊆) S)
  (hS : ∀ s ∈ S, strict_convex 𝕜 s) :
  strict_convex 𝕜 (⋃₀ S) :=
begin
  rw sUnion_eq_Union,
  exact (directed_on_iff_directed.1 hdir).strict_convex_Union (λ s, hS _ s.2),
end

end has_smul

section module
variables [module 𝕜 E] [module 𝕜 F] {s : set E}

protected lemma strict_convex.convex (hs : strict_convex 𝕜 s) : convex 𝕜 s :=
convex_iff_pairwise_pos.2 $ λ x hx y hy hxy a b ha hb hab, interior_subset $ hs hx hy hxy ha hb hab

/-- An open convex set is strictly convex. -/
protected lemma convex.strict_convex (h : is_open s) (hs : convex 𝕜 s) : strict_convex 𝕜 s :=
λ x hx y hy _ a b ha hb hab, h.interior_eq.symm ▸ hs hx hy ha.le hb.le hab

lemma is_open.strict_convex_iff (h : is_open s) : strict_convex 𝕜 s ↔ convex 𝕜 s :=
⟨strict_convex.convex, convex.strict_convex h⟩

lemma strict_convex_singleton (c : E) : strict_convex 𝕜 ({c} : set E) := pairwise_singleton _ _

lemma set.subsingleton.strict_convex (hs : s.subsingleton) : strict_convex 𝕜 s := hs.pairwise _

lemma strict_convex.linear_image [semiring 𝕝] [module 𝕝 E] [module 𝕝 F]
  [linear_map.compatible_smul E F 𝕜 𝕝] (hs : strict_convex 𝕜 s) (f : E →ₗ[𝕝] F)
  (hf : is_open_map f) :
  strict_convex 𝕜 (f '' s) :=
begin
  rintro _ ⟨x, hx, rfl⟩ _ ⟨y, hy, rfl⟩ hxy a b ha hb hab,
  refine hf.image_interior_subset _ ⟨a • x + b • y, hs hx hy (ne_of_apply_ne _ hxy) ha hb hab, _⟩,
  rw [map_add, f.map_smul_of_tower a, f.map_smul_of_tower b]
end

lemma strict_convex.is_linear_image (hs : strict_convex 𝕜 s) {f : E → F} (h : is_linear_map 𝕜 f)
  (hf : is_open_map f) :
  strict_convex 𝕜 (f '' s) :=
hs.linear_image (h.mk' f) hf

lemma strict_convex.linear_preimage {s : set F} (hs : strict_convex 𝕜 s) (f : E →ₗ[𝕜] F)
  (hf : continuous f) (hfinj : injective f) :
  strict_convex 𝕜 (s.preimage f) :=
begin
  intros x hx y hy hxy a b ha hb hab,
  refine preimage_interior_subset_interior_preimage hf _,
  rw [mem_preimage, f.map_add, f.map_smul, f.map_smul],
  exact hs hx hy (hfinj.ne hxy) ha hb hab,
end

lemma strict_convex.is_linear_preimage {s : set F} (hs : strict_convex 𝕜 s) {f : E → F}
  (h : is_linear_map 𝕜 f) (hf : continuous f) (hfinj : injective f) :
  strict_convex 𝕜 (s.preimage f) :=
hs.linear_preimage (h.mk' f) hf hfinj

section linear_ordered_cancel_add_comm_monoid
variables [topological_space β] [linear_ordered_cancel_add_comm_monoid β] [order_topology β]
  [module 𝕜 β] [ordered_smul 𝕜 β]

lemma strict_convex_Iic (r : β) : strict_convex 𝕜 (Iic r) :=
begin
  rintro x (hx : x ≤ r) y (hy : y ≤ r) hxy a b ha hb hab,
  refine (subset_interior_iff_subset_of_open is_open_Iio).2 Iio_subset_Iic_self _,
  rw ←convex.combo_self hab r,
  obtain rfl | hx := hx.eq_or_lt,
  { exact add_lt_add_left (smul_lt_smul_of_pos (hy.lt_of_ne hxy.symm) hb) _ },
  obtain rfl | hy := hy.eq_or_lt,
  { exact add_lt_add_right (smul_lt_smul_of_pos hx ha) _ },
  { exact add_lt_add (smul_lt_smul_of_pos hx ha) (smul_lt_smul_of_pos hy hb) }
end

lemma strict_convex_Ici (r : β) : strict_convex 𝕜 (Ici r) := @strict_convex_Iic 𝕜 βᵒᵈ _ _ _ _ _ _ r

lemma strict_convex_Icc (r s : β) : strict_convex 𝕜 (Icc r s) :=
(strict_convex_Ici r).inter $ strict_convex_Iic s

lemma strict_convex_Iio (r : β) : strict_convex 𝕜 (Iio r) :=
(convex_Iio r).strict_convex is_open_Iio

lemma strict_convex_Ioi (r : β) : strict_convex 𝕜 (Ioi r) :=
(convex_Ioi r).strict_convex is_open_Ioi

lemma strict_convex_Ioo (r s : β) : strict_convex 𝕜 (Ioo r s) :=
(strict_convex_Ioi r).inter $ strict_convex_Iio s

lemma strict_convex_Ico (r s : β) : strict_convex 𝕜 (Ico r s) :=
(strict_convex_Ici r).inter $ strict_convex_Iio s

lemma strict_convex_Ioc (r s : β) : strict_convex 𝕜 (Ioc r s) :=
(strict_convex_Ioi r).inter $ strict_convex_Iic s

lemma strict_convex_interval (r s : β) : strict_convex 𝕜 (interval r s) :=
strict_convex_Icc _ _

end linear_ordered_cancel_add_comm_monoid
end module
end add_comm_monoid

section add_cancel_comm_monoid
variables [add_cancel_comm_monoid E] [has_continuous_add E] [module 𝕜 E] {s : set E}

/-- The translation of a strictly convex set is also strictly convex. -/
lemma strict_convex.preimage_add_right (hs : strict_convex 𝕜 s) (z : E) :
  strict_convex 𝕜 ((λ x, z + x) ⁻¹' s) :=
begin
  intros x hx y hy hxy a b ha hb hab,
  refine preimage_interior_subset_interior_preimage (continuous_add_left _) _,
  have h := hs hx hy ((add_right_injective _).ne hxy) ha hb hab,
  rwa [smul_add, smul_add, add_add_add_comm, ←add_smul, hab, one_smul] at h,
end

/-- The translation of a strictly convex set is also strictly convex. -/
lemma strict_convex.preimage_add_left (hs : strict_convex 𝕜 s) (z : E) :
  strict_convex 𝕜 ((λ x, x + z) ⁻¹' s) :=
by simpa only [add_comm] using hs.preimage_add_right z

end add_cancel_comm_monoid

section add_comm_group
variables [add_comm_group E] [add_comm_group F] [module 𝕜 E] [module 𝕜 F]

section continuous_add
variables [has_continuous_add E] {s t : set E}

lemma strict_convex.add (hs : strict_convex 𝕜 s) (ht : strict_convex 𝕜 t) :
  strict_convex 𝕜 (s + t) :=
begin
  rintro _ ⟨v, w, hv, hw, rfl⟩ _ ⟨x, y, hx, hy, rfl⟩ h a b ha hb hab,
  rw [smul_add, smul_add, add_add_add_comm],
  obtain rfl | hvx := eq_or_ne v x,
  { refine interior_mono (add_subset_add (singleton_subset_iff.2 hv) subset.rfl) _,
    rw [convex.combo_self hab, singleton_add],
    exact (is_open_map_add_left _).image_interior_subset _
      (mem_image_of_mem _ $ ht hw hy (ne_of_apply_ne _ h) ha hb hab) },
  exact subset_interior_add_left (add_mem_add (hs hv hx hvx ha hb hab) $
    ht.convex hw hy ha.le hb.le hab)
end

lemma strict_convex.add_left (hs : strict_convex 𝕜 s) (z : E) :
  strict_convex 𝕜 ((λ x, z + x) '' s) :=
by simpa only [singleton_add] using (strict_convex_singleton z).add hs

lemma strict_convex.add_right (hs : strict_convex 𝕜 s) (z : E) :
  strict_convex 𝕜 ((λ x, x + z) '' s) :=
by simpa only [add_comm] using hs.add_left z

/-- The translation of a strictly convex set is also strictly convex. -/
lemma strict_convex.vadd (hs : strict_convex 𝕜 s) (x : E) : strict_convex 𝕜 (x +ᵥ s) :=
hs.add_left x

end continuous_add

section continuous_smul
variables [linear_ordered_field 𝕝] [module 𝕝 E] [has_continuous_const_smul 𝕝 E]
  [linear_map.compatible_smul E E 𝕜 𝕝] {s : set E} {x : E}

lemma strict_convex.smul (hs : strict_convex 𝕜 s) (c : 𝕝) : strict_convex 𝕜 (c • s) :=
begin
  obtain rfl | hc := eq_or_ne c 0,
  { exact (subsingleton_zero_smul_set _).strict_convex },
  { exact hs.linear_image (linear_map.lsmul _ _ c) (is_open_map_smul₀ hc) }
end

lemma strict_convex.affinity [has_continuous_add E] (hs : strict_convex 𝕜 s) (z : E) (c : 𝕝) :
  strict_convex 𝕜 (z +ᵥ c • s) :=
(hs.smul c).vadd z

end continuous_smul
end add_comm_group
end ordered_semiring

section ordered_comm_semiring
variables [ordered_comm_semiring 𝕜] [topological_space E]

section add_comm_group
variables [add_comm_group E] [module 𝕜 E] [no_zero_smul_divisors 𝕜 E]
  [has_continuous_const_smul 𝕜 E] {s : set E}

lemma strict_convex.preimage_smul (hs : strict_convex 𝕜 s) (c : 𝕜) :
  strict_convex 𝕜 ((λ z, c • z) ⁻¹' s) :=
begin
  classical,
  obtain rfl | hc := eq_or_ne c 0,
  { simp_rw [zero_smul, preimage_const],
    split_ifs,
    { exact strict_convex_univ },
    { exact strict_convex_empty } },
  refine hs.linear_preimage (linear_map.lsmul _ _ c) _ (smul_right_injective E hc),
  unfold linear_map.lsmul linear_map.mk₂ linear_map.mk₂' linear_map.mk₂'ₛₗ,
  exact continuous_const_smul _,
end

end add_comm_group
end ordered_comm_semiring

section ordered_ring
variables [ordered_ring 𝕜] [topological_space E] [topological_space F]

section add_comm_group
variables [add_comm_group E] [add_comm_group F] [module 𝕜 E] [module 𝕜 F] {s t : set E} {x y : E}

lemma strict_convex.eq_of_open_segment_subset_frontier [nontrivial 𝕜] [densely_ordered 𝕜]
  (hs : strict_convex 𝕜 s) (hx : x ∈ s) (hy : y ∈ s) (h : open_segment 𝕜 x y ⊆ frontier s) :
  x = y :=
begin
  obtain ⟨a, ha₀, ha₁⟩ := densely_ordered.dense (0 : 𝕜) 1 zero_lt_one,
  classical,
  by_contra hxy,
  exact (h ⟨a, 1 - a, ha₀, sub_pos_of_lt ha₁, add_sub_cancel'_right _ _, rfl⟩).2
    (hs hx hy hxy ha₀ (sub_pos_of_lt ha₁) $ add_sub_cancel'_right _ _),
end

lemma strict_convex.add_smul_mem (hs : strict_convex 𝕜 s) (hx : x ∈ s) (hxy : x + y ∈ s)
  (hy : y ≠ 0) {t : 𝕜} (ht₀ : 0 < t) (ht₁ : t < 1) :
  x + t • y ∈ interior s :=
begin
  have h : x + t • y = (1 - t) • x + t • (x + y),
  { rw [smul_add, ←add_assoc, ←add_smul, sub_add_cancel, one_smul] },
  rw h,
  refine hs hx hxy (λ h, hy $ add_left_cancel _) (sub_pos_of_lt ht₁) ht₀ (sub_add_cancel _ _),
  exact x,
  rw [←h, add_zero],
end

lemma strict_convex.smul_mem_of_zero_mem (hs : strict_convex 𝕜 s) (zero_mem : (0 : E) ∈ s)
  (hx : x ∈ s) (hx₀ : x ≠ 0) {t : 𝕜} (ht₀ : 0 < t) (ht₁ : t < 1) :
  t • x ∈ interior s :=
by simpa using hs.add_smul_mem zero_mem (by simpa using hx) hx₀ ht₀ ht₁

lemma strict_convex.add_smul_sub_mem (h : strict_convex 𝕜 s) (hx : x ∈ s) (hy : y ∈ s) (hxy : x ≠ y)
  {t : 𝕜} (ht₀ : 0 < t) (ht₁ : t < 1) : x + t • (y - x) ∈ interior s :=
begin
  apply h.open_segment_subset hx hy hxy,
  rw open_segment_eq_image',
  exact mem_image_of_mem _ ⟨ht₀, ht₁⟩,
end

/-- The preimage of a strictly convex set under an affine map is strictly convex. -/
lemma strict_convex.affine_preimage {s : set F} (hs : strict_convex 𝕜 s) {f : E →ᵃ[𝕜] F}
  (hf : continuous f) (hfinj : injective f) :
  strict_convex 𝕜 (f ⁻¹' s) :=
begin
  intros x hx y hy hxy a b ha hb hab,
  refine preimage_interior_subset_interior_preimage hf _,
  rw [mem_preimage, convex.combo_affine_apply hab],
  exact hs hx hy (hfinj.ne hxy) ha hb hab,
end

/-- The image of a strictly convex set under an affine map is strictly convex. -/
lemma strict_convex.affine_image (hs : strict_convex 𝕜 s) {f : E →ᵃ[𝕜] F} (hf : is_open_map f) :
  strict_convex 𝕜 (f '' s) :=
begin
  rintro _ ⟨x, hx, rfl⟩ _ ⟨y, hy, rfl⟩ hxy a b ha hb hab,
  exact hf.image_interior_subset _ ⟨a • x + b • y, ⟨hs hx hy (ne_of_apply_ne _ hxy) ha hb hab,
    convex.combo_affine_apply hab⟩⟩,
end

variables [topological_add_group E]

lemma strict_convex.neg (hs : strict_convex 𝕜 s) : strict_convex 𝕜 (-s) :=
hs.is_linear_preimage is_linear_map.is_linear_map_neg continuous_id.neg neg_injective

lemma strict_convex.sub (hs : strict_convex 𝕜 s) (ht : strict_convex 𝕜 t) :
  strict_convex 𝕜 (s - t) :=
(sub_eq_add_neg s t).symm ▸ hs.add ht.neg

end add_comm_group
end ordered_ring

section linear_ordered_field
variables [linear_ordered_field 𝕜] [topological_space E]

section add_comm_group
variables [add_comm_group E] [add_comm_group F] [module 𝕜 E] [module 𝕜 F] {s : set E} {x : E}

/-- Alternative definition of set strict convexity, using division. -/
lemma strict_convex_iff_div :
  strict_convex 𝕜 s ↔ s.pairwise
    (λ x y, ∀ ⦃a b : 𝕜⦄, 0 < a → 0 < b → (a / (a + b)) • x + (b / (a + b)) • y ∈ interior s) :=
⟨λ h x hx y hy hxy a b ha hb, begin
  apply h hx hy hxy (div_pos ha $ add_pos ha hb) (div_pos hb $ add_pos ha hb),
  rw ←add_div,
  exact div_self (add_pos ha hb).ne',
end, λ h x hx y hy hxy a b ha hb hab, by convert h hx hy hxy ha hb; rw [hab, div_one] ⟩

lemma strict_convex.mem_smul_of_zero_mem (hs : strict_convex 𝕜 s) (zero_mem : (0 : E) ∈ s)
  (hx : x ∈ s) (hx₀ : x ≠ 0) {t : 𝕜} (ht : 1 < t) :
  x ∈ t • interior s :=
begin
  rw mem_smul_set_iff_inv_smul_mem₀ (zero_lt_one.trans ht).ne',
  exact hs.smul_mem_of_zero_mem zero_mem hx hx₀ (inv_pos.2 $ zero_lt_one.trans ht)  (inv_lt_one ht),
end

end add_comm_group
end linear_ordered_field

/-!
#### Convex sets in an ordered space

Relates `convex` and `set.ord_connected`.
-/

section
variables [topological_space E]

/-- A set in a linear ordered field is strictly convex if and only if it is convex. -/
@[simp] lemma strict_convex_iff_convex [linear_ordered_field 𝕜] [topological_space 𝕜]
  [order_topology 𝕜] {s : set 𝕜} :
  strict_convex 𝕜 s ↔ convex 𝕜 s :=
begin
  refine ⟨strict_convex.convex, λ hs, strict_convex_iff_open_segment_subset.2 (λ x hx y hy hxy, _)⟩,
  obtain h | h := hxy.lt_or_lt,
  { refine (open_segment_subset_Ioo h).trans _,
    rw ←interior_Icc,
    exact interior_mono (Icc_subset_segment.trans $ hs.segment_subset hx hy) },
  { rw open_segment_symm,
    refine (open_segment_subset_Ioo h).trans _,
    rw ←interior_Icc,
    exact interior_mono (Icc_subset_segment.trans $ hs.segment_subset hy hx) }
end

lemma strict_convex_iff_ord_connected [linear_ordered_field 𝕜] [topological_space 𝕜]
  [order_topology 𝕜] {s : set 𝕜} :
  strict_convex 𝕜 s ↔ s.ord_connected :=
strict_convex_iff_convex.trans convex_iff_ord_connected

alias strict_convex_iff_ord_connected ↔ strict_convex.ord_connected _

end


/-
Copyright (c) 2020 Anne Baanen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Anne Baanen
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.ring_theory.algebraic
import Mathlib.ring_theory.localization
import Mathlib.PostPort

universes u_1 u_2

namespace Mathlib

/-!
# Ideals over/under ideals

This file concerns ideals lying over other ideals.
Let `f : R →+* S` be a ring homomorphism (typically a ring extension), `I` an ideal of `R` and
`J` an ideal of `S`. We say `J` lies over `I` (and `I` under `J`) if `I` is the `f`-preimage of `J`.
This is expressed here by writing `I = J.comap f`.

## Implementation notes

The proofs of the `comap_ne_bot` and `comap_lt_comap` families use an approach
specific for their situation: we construct an element in `I.comap f` from the
coefficients of a minimal polynomial.
Once mathlib has more material on the localization at a prime ideal, the results
can be proven using more general going-up/going-down theory.
-/

namespace ideal

theorem coeff_zero_mem_comap_of_root_mem_of_eval_mem {R : Type u_1} [comm_ring R] {S : Type u_2} [comm_ring S] {f : R →+* S} {I : ideal S} {r : S} (hr : r ∈ I) {p : polynomial R} (hp : polynomial.eval₂ f r p ∈ I) : polynomial.coeff p 0 ∈ comap f I := sorry

theorem coeff_zero_mem_comap_of_root_mem {R : Type u_1} [comm_ring R] {S : Type u_2} [comm_ring S] {f : R →+* S} {I : ideal S} {r : S} (hr : r ∈ I) {p : polynomial R} (hp : polynomial.eval₂ f r p = 0) : polynomial.coeff p 0 ∈ comap f I :=
  coeff_zero_mem_comap_of_root_mem_of_eval_mem hr (Eq.symm hp ▸ ideal.zero_mem I)

theorem exists_coeff_ne_zero_mem_comap_of_non_zero_divisor_root_mem {R : Type u_1} [comm_ring R] {S : Type u_2} [comm_ring S] {f : R →+* S} {I : ideal S} {r : S} (r_non_zero_divisor : ∀ {x : S}, x * r = 0 → x = 0) (hr : r ∈ I) {p : polynomial R} (p_ne_zero : p ≠ 0) (hp : polynomial.eval₂ f r p = 0) : ∃ (i : ℕ), polynomial.coeff p i ≠ 0 ∧ polynomial.coeff p i ∈ comap f I := sorry

theorem exists_coeff_ne_zero_mem_comap_of_root_mem {R : Type u_1} [comm_ring R] {S : Type u_2} [integral_domain S] {f : R →+* S} {I : ideal S} {r : S} (r_ne_zero : r ≠ 0) (hr : r ∈ I) {p : polynomial R} (p_ne_zero : p ≠ 0) (hp : polynomial.eval₂ f r p = 0) : ∃ (i : ℕ), polynomial.coeff p i ≠ 0 ∧ polynomial.coeff p i ∈ comap f I :=
  exists_coeff_ne_zero_mem_comap_of_non_zero_divisor_root_mem
    (fun (_x : S) (h : _x * r = 0) => or.resolve_right (iff.mp mul_eq_zero h) r_ne_zero) hr

theorem exists_coeff_mem_comap_sdiff_comap_of_root_mem_sdiff {R : Type u_1} [comm_ring R] {S : Type u_2} [integral_domain S] {f : R →+* S} {I : ideal S} {J : ideal S} [is_prime I] (hIJ : I ≤ J) {r : S} (hr : r ∈ ↑J \ ↑I) {p : polynomial R} (p_ne_zero : polynomial.map (quotient.mk (comap f I)) p ≠ 0) (hpI : polynomial.eval₂ f r p ∈ I) : ∃ (i : ℕ), polynomial.coeff p i ∈ ↑(comap f J) \ ↑(comap f I) := sorry

theorem comap_ne_bot_of_root_mem {R : Type u_1} [comm_ring R] {S : Type u_2} [integral_domain S] {f : R →+* S} {I : ideal S} {r : S} (r_ne_zero : r ≠ 0) (hr : r ∈ I) {p : polynomial R} (p_ne_zero : p ≠ 0) (hp : polynomial.eval₂ f r p = 0) : comap f I ≠ ⊥ := sorry

theorem comap_lt_comap_of_root_mem_sdiff {R : Type u_1} [comm_ring R] {S : Type u_2} [integral_domain S] {f : R →+* S} {I : ideal S} {J : ideal S} [is_prime I] (hIJ : I ≤ J) {r : S} (hr : r ∈ ↑J \ ↑I) {p : polynomial R} (p_ne_zero : polynomial.map (quotient.mk (comap f I)) p ≠ 0) (hp : polynomial.eval₂ f r p ∈ I) : comap f I < comap f J := sorry

theorem comap_ne_bot_of_algebraic_mem {R : Type u_1} [comm_ring R] {S : Type u_2} [integral_domain S] {I : ideal S} [algebra R S] {x : S} (x_ne_zero : x ≠ 0) (x_mem : x ∈ I) (hx : is_algebraic R x) : comap (algebra_map R S) I ≠ ⊥ := sorry

theorem comap_ne_bot_of_integral_mem {R : Type u_1} [comm_ring R] {S : Type u_2} [integral_domain S] {I : ideal S} [algebra R S] [nontrivial R] {x : S} (x_ne_zero : x ≠ 0) (x_mem : x ∈ I) (hx : is_integral R x) : comap (algebra_map R S) I ≠ ⊥ :=
  comap_ne_bot_of_algebraic_mem x_ne_zero x_mem (is_integral.is_algebraic R hx)

theorem eq_bot_of_comap_eq_bot {R : Type u_1} [comm_ring R] {S : Type u_2} [integral_domain S] {I : ideal S} [algebra R S] [nontrivial R] (hRS : algebra.is_integral R S) (hI : comap (algebra_map R S) I = ⊥) : I = ⊥ := sorry

theorem mem_of_one_mem {S : Type u_2} [integral_domain S] {I : ideal S} (h : 1 ∈ I) (x : S) : x ∈ I :=
  Eq.symm (iff.mpr (eq_top_iff_one I) h) ▸ submodule.mem_top

theorem comap_lt_comap_of_integral_mem_sdiff {R : Type u_1} [comm_ring R] {S : Type u_2} [integral_domain S] {I : ideal S} {J : ideal S} [algebra R S] [hI : is_prime I] (hIJ : I ≤ J) {x : S} (mem : x ∈ ↑J \ ↑I) (integral : is_integral R x) : comap (algebra_map R S) I < comap (algebra_map R S) J := sorry

theorem is_maximal_of_is_integral_of_is_maximal_comap {R : Type u_1} [comm_ring R] {S : Type u_2} [integral_domain S] [algebra R S] (hRS : algebra.is_integral R S) (I : ideal S) [is_prime I] (hI : is_maximal (comap (algebra_map R S) I)) : is_maximal I := sorry

theorem is_maximal_of_is_integral_of_is_maximal_comap' {R : Type u_1} {S : Type u_2} [comm_ring R] [integral_domain S] (f : R →+* S) (hf : ring_hom.is_integral f) (I : ideal S) [hI' : is_prime I] (hI : is_maximal (comap f I)) : is_maximal I :=
  is_maximal_of_is_integral_of_is_maximal_comap hf I hI

theorem is_maximal_comap_of_is_integral_of_is_maximal {R : Type u_1} [comm_ring R] {S : Type u_2} [integral_domain S] [algebra R S] (hRS : algebra.is_integral R S) (I : ideal S) [hI : is_maximal I] : is_maximal (comap (algebra_map R S) I) := sorry

theorem is_maximal_comap_of_is_integral_of_is_maximal' {R : Type u_1} {S : Type u_2} [comm_ring R] [integral_domain S] (f : R →+* S) (hf : ring_hom.is_integral f) (I : ideal S) (hI : is_maximal I) : is_maximal (comap f I) :=
  is_maximal_comap_of_is_integral_of_is_maximal hf I

theorem integral_closure.comap_ne_bot {R : Type u_1} [comm_ring R] {S : Type u_2} [integral_domain S] [algebra R S] [nontrivial R] {I : ideal ↥(integral_closure R S)} (I_ne_bot : I ≠ ⊥) : comap (algebra_map R ↥(integral_closure R S)) I ≠ ⊥ := sorry

theorem integral_closure.eq_bot_of_comap_eq_bot {R : Type u_1} [comm_ring R] {S : Type u_2} [integral_domain S] [algebra R S] [nontrivial R] {I : ideal ↥(integral_closure R S)} : comap (algebra_map R ↥(integral_closure R S)) I = ⊥ → I = ⊥ :=
  imp_of_not_imp_not (comap (algebra_map R ↥(integral_closure R S)) I = ⊥) (I = ⊥) integral_closure.comap_ne_bot

theorem integral_closure.comap_lt_comap {R : Type u_1} [comm_ring R] {S : Type u_2} [integral_domain S] [algebra R S] {I : ideal ↥(integral_closure R S)} {J : ideal ↥(integral_closure R S)} [is_prime I] (I_lt_J : I < J) : comap (algebra_map R ↥(integral_closure R S)) I < comap (algebra_map R ↥(integral_closure R S)) J := sorry

theorem integral_closure.is_maximal_of_is_maximal_comap {R : Type u_1} [comm_ring R] {S : Type u_2} [integral_domain S] [algebra R S] (I : ideal ↥(integral_closure R S)) [is_prime I] (hI : is_maximal (comap (algebra_map R ↥(integral_closure R S)) I)) : is_maximal I :=
  is_maximal_of_is_integral_of_is_maximal_comap (fun (x : ↥(integral_closure R S)) => integral_closure.is_integral x) I hI

/-- `comap (algebra_map R S)` is a surjection from the prime spec of `R` to prime spec of `S`.
`hP : (algebra_map R S).ker ≤ P` is a slight generalization of the extension being injective -/
theorem exists_ideal_over_prime_of_is_integral' {R : Type u_1} [comm_ring R] {S : Type u_2} [integral_domain S] [algebra R S] (H : algebra.is_integral R S) (P : ideal R) [is_prime P] (hP : ring_hom.ker (algebra_map R S) ≤ P) : ∃ (Q : ideal S), is_prime Q ∧ comap (algebra_map R S) Q = P := sorry

/-- More general going-up theorem than `exists_ideal_over_prime_of_is_integral'`.
TODO: Version of going-up theorem with arbitrary length chains (by induction on this)?
  Not sure how best to write an ascending chain in Lean -/
theorem exists_ideal_over_prime_of_is_integral {R : Type u_1} [comm_ring R] {S : Type u_2} [integral_domain S] [algebra R S] (H : algebra.is_integral R S) (P : ideal R) [is_prime P] (I : ideal S) [is_prime I] (hIP : comap (algebra_map R S) I ≤ P) : ∃ (Q : ideal S), ∃ (H : Q ≥ I), is_prime Q ∧ comap (algebra_map R S) Q = P := sorry

/-- `comap (algebra_map R S)` is a surjection from the max spec of `S` to max spec of `R`.
`hP : (algebra_map R S).ker ≤ P` is a slight generalization of the extension being injective -/
theorem exists_ideal_over_maximal_of_is_integral {R : Type u_1} [comm_ring R] {S : Type u_2} [integral_domain S] [algebra R S] (H : algebra.is_integral R S) (P : ideal R) [P_max : is_maximal P] (hP : ring_hom.ker (algebra_map R S) ≤ P) : ∃ (Q : ideal S), is_maximal Q ∧ comap (algebra_map R S) Q = P := sorry


/-
Copyright (c) 2019 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon
-/
import Mathlib.Tactic.Monotonicity
import Mathlib.Tactic.NormNum
import Mathlib.Algebra.Order.Ring.Defs
-- import measure_theory.measure.lebesgue
-- import measure_theory.function.locally_integrable
import Mathlib.Data.List.Defs

open List Set

example (x y z k : ℕ)
    (h : 3 ≤ (4 : ℕ))
    (h' : z ≤ y) :
    (k + 3 + x) - y ≤ (k + 4 + x) - z := by
  mono
  -- norm_num

example (x y z k : ℤ)
    (h : 3 ≤ (4 : ℤ))
    (h' : z ≤ y) :
    (k + 3 + x) - y ≤ (k + 4 + x) - z := by
  mono
  -- norm_num

example (x y z a b : ℕ)
    (h : a ≤ (b : ℕ))
    (h' : z ≤ y) :
    (1 + a + x) - y ≤ (1 + b + x) - z := by
  transitivity (1 + a + x - z)
  · mono
  · mono
    -- mono
    -- mono

example (x y z a b : ℤ)
    (h : a ≤ (b : ℤ))
    (h' : z ≤ y) :
    (1 + a + x) - y ≤ (1 + b + x) - z := by
  apply @le_trans ℤ _ _ (1 + a + x - z)
  -- transitivity (1 + a + x - z)
  · mono
  · mono
    -- mono
    -- mono

example (x y z : ℤ)
    (h' : z ≤ y) :
    (1 + 3 + x) - y ≤ (1 + 4 + x) - z := by
  apply @le_trans ℤ _ _ (1 + 3 + x - z)
  -- transitivity (1 + 3 + x - z)
  · mono
  · mono
    -- mono
    norm_num

example {x y z : ℕ} : true := by
  have : y + x ≤ y + z := by
    mono
    guard_target = x ≤ z
    admit
  trivial

example {x y z : ℕ} : true := by
  suffices : x + y ≤ z + y ; trivial
  mono
  guard_target = x ≤ z
  admit

example {x y z w : ℕ} : true := by
  have : x + y ≤ z + w := by
    mono
    guard_target = x ≤ z ; admit
    guard_target = y ≤ w ; admit
  trivial

-- example
--   (h : 3 + 6 ≤ 4 + 5)
-- : 1 + 3 + 2 + 6 ≤ 4 + 2 + 1 + 5 :=
-- begin
--   ac_mono,
-- end

-- example
--   (h : 3 ≤ (4 : ℤ))
--   (h' : 5 ≤ (6 : ℤ))
-- : (1 + 3 + 2) - 6 ≤ (4 + 2 + 1 : ℤ) - 5 :=
-- begin
--   ac_mono,
--   mono,
-- end

-- example
--   (h : 3 ≤ (4 : ℤ))
--   (h' : 5 ≤ (6 : ℤ))
-- : (1 + 3 + 2) - 6 ≤ (4 + 2 + 1 : ℤ) - 5 :=
-- begin
--   transitivity (1 + 3 + 2 - 5 : ℤ),
--   { ac_mono },
--   { ac_mono },
-- end

-- example (x y z : ℤ)
--   (h : 3 ≤ (4 : ℤ))
--   (h' : z ≤ y)
-- : (1 + 3 + x) - y ≤ (1 + 4 + x) - z :=
-- begin
--   ac_mono, mono*
-- end

-- @[simp]
-- def List.le' {α : Type _} [LE α] : List α → List α → Prop
--  | (x::xs) (y::ys) => x ≤ y ∧ List.le' xs ys
--  | [] [] => true
--  | _ _ => false

-- @[simp]
-- instance list_has_le {α : Type _} [LE α] : LE (List α) :=
-- ⟨ List.le' ⟩

-- lemma list.le_refl {α : Type _} [Preorder α] {xs : LE α} : xs ≤ xs := by
--   induction' xs with x xs
--   · trivial
--   · simp [has_le.le,list.le]
--     split
--     · exact le_rfl
--     · apply xs_ih

-- -- @[trans]
-- lemma List.le_trans {α : Type _} [Preorder α]
--     {xs zs : List α} (ys : List α)
--     (h  : xs ≤ ys)
--     (h' : ys ≤ zs) :
--     xs ≤ zs := by
--   revert ys zs
--   induction' xs with x xs
--   ; intros ys zs h h'
--   ; cases ys with y ys
--   ; cases zs with z zs
--   ; try { cases h ; cases h' ; done },
--   { apply list.le_refl },
--   { simp [has_le.le,list.le],
--     split,
--     apply le_trans h.left h'.left,
--     apply xs_ih _ h.right h'.right, }

-- @[mono]
-- lemma list_le_mono_left {α : Type*} [preorder α] {xs ys zs : list α}
--     (h : xs ≤ ys) :
--     xs ++ zs ≤ ys ++ zs := by
--   revert ys
--   induction xs with x xs ; intros ys h
--   · cases ys ; apply list.le_refl ; cases h
--   · cases ys with y ys ; cases h ; simp [has_le.le,list.le] at *
--     revert h ; apply and.imp_right
--     apply xs_ih

-- @[mono]
-- lemma list_le_mono_right {α : Type*} [preorder α] {xs ys zs : list α}
--     (h : xs ≤ ys) :
--     zs ++ xs ≤ zs ++ ys := by
--   revert ys zs
--   induction xs with x xs ; intros ys zs h
--   · cases ys
--     · simp ; apply list.le_refl
--     · cases h
--   · cases ys with y ys ; cases h ; simp [has_le.le,list.le] at *
--     suffices : list.le' ((zs ++ [x]) ++ xs) ((zs ++ [y]) ++ ys)
--     · refine cast _ this ; simp
--     apply list.le_trans (zs ++ [y] ++ xs)
--     · apply list_le_mono_left
--       induction zs with z zs
--       · simp [has_le.le,list.le] ; apply h.left
--       · simp [has_le.le,list.le] ; split ; exact le_rfl
--         apply zs_ih
--     · apply xs_ih h.right

-- lemma bar_bar'
--   (h : [] ++ [3] ++ [2] ≤ [1] ++ [5] ++ [4])
-- : [] ++ [3] ++ [2] ++ [2] ≤ [1] ++ [5] ++ ([4] ++ [2]) :=
-- begin
--   ac_mono,
-- end

-- lemma bar_bar''
--   (h : [3] ++ [2] ++ [2] ≤ [5] ++ [4] ++ [])
-- : [1] ++ ([3] ++ [2]) ++ [2] ≤ [1] ++ [5] ++ ([4] ++ []) :=
-- begin
--   ac_mono,
-- end

-- lemma bar_bar
--   (h : [3] ++ [2] ≤ [5] ++ [4])
-- : [1] ++ [3] ++ [2] ++ [2] ≤ [1] ++ [5] ++ ([4] ++ [2]) :=
-- begin
--   ac_mono,
-- end

-- def P (x : ℕ) := 7 ≤ x
-- def Q (x : ℕ) := x ≤ 7

-- @[mono]
-- lemma P_mono {x y : ℕ}
--     (h : x ≤ y) :
--     P x → P y := by
--   intro h'
--   apply le_trans h' h

-- @[mono]
-- lemma Q_mono {x y : ℕ}
--     (h : y ≤ x) :
--     Q x → Q y := by
--   apply le_trans h

-- example (x y z : ℕ)
--   (h : x ≤ y)
-- : P (x + z) → P (z + y) :=
-- begin
--   ac_mono,
--   ac_mono,
-- end

-- example (x y z : ℕ)
--   (h : y ≤ x)
-- : Q (x + z) → Q (z + y) :=
-- begin
--   ac_mono,
--   ac_mono,
-- end

-- example (x y z k m n : ℤ)
--   (h₀ : z ≤ 0)
--   (h₁ : y ≤ x)
-- : (m + x + n) * z + k ≤ z * (y + n + m) + k :=
-- begin
--   ac_mono,
--   ac_mono,
--   ac_mono,
-- end

-- example (x y z k m n : ℕ)
--   (h₀ : z ≥ 0)
--   (h₁ : x ≤ y)
-- : (m + x + n) * z + k ≤ z * (y + n + m) + k :=
-- begin
--   ac_mono,
--   ac_mono,
--   ac_mono,
-- end

-- example (x y z k m n : ℕ)
--   (h₀ : z ≥ 0)
--   (h₁ : x ≤ y)
-- : (m + x + n) * z + k ≤ z * (y + n + m) + k :=
-- begin
--   ac_mono,
--   -- ⊢ (m + x + n) * z ≤ z * (y + n + m)
--   ac_mono,
--   -- ⊢ m + x + n ≤ y + n + m
--   ac_mono,
-- end

-- example (x y z k m n : ℕ)
--   (h₀ : z ≥ 0)
--   (h₁ : x ≤ y)
-- : (m + x + n) * z + k ≤ z * (y + n + m) + k :=
-- by { ac_mono* := h₁ }

-- example (x y z k m n : ℕ)
--   (h₀ : z ≥ 0)
--   (h₁ : m + x + n ≤ y + n + m)
-- : (m + x + n) * z + k ≤ z * (y + n + m) + k :=
-- by { ac_mono* := h₁ }

-- example (x y z k m n : ℕ)
--   (h₀ : z ≥ 0)
--   (h₁ : n + x + m ≤ y + n + m)
-- : (m + x + n) * z + k ≤ z * (y + n + m) + k :=
-- begin
--   ac_mono* : m + x + n ≤ y + n + m,
--   transitivity ; [ skip , apply h₁ ],
--   apply le_of_eq,
--   ac_refl,
-- end

-- example (x y z k m n : ℤ)
--   (h₁ : x ≤ y)
-- : true :=
-- begin
--   have : (m + x + n) * z + k ≤ z * (y + n + m) + k,
--   { ac_mono,
--     success_if_fail { ac_mono },
--     admit },
--   trivial
-- end

-- example (x y z k m n : ℕ)
--   (h₁ : x ≤ y)
-- : true :=
-- begin
--   have : (m + x + n) * z + k ≤ z * (y + n + m) + k,
--   { ac_mono*,
--     change 0 ≤ z, apply nat.zero_le, },
--   trivial
-- end

-- example (x y z k m n : ℕ)
--   (h₁ : x ≤ y)
-- : true :=
-- begin
--   have : (m + x + n) * z + k ≤ z * (y + n + m) + k,
--   { ac_mono,
--     change (m + x + n) * z ≤ z * (y + n + m),
--     admit },
--   trivial,
-- end

-- example (x y z k m n i j : ℕ)
--   (h₁ : x + i = y + j)
-- : (m + x + n + i) * z + k = z * (j + n + m + y) + k :=
-- begin
--   ac_mono^3,
--   cc
-- end

-- example (x y z k m n i j : ℕ)
--     (h₁ : x + i = y + j) :
--     z * (x + i + n + m) + k = z * (y + j + n + m) + k := by
--   congr
--   -- simp [h₁]

-- example (x y z k m n i j : ℕ)
--   (h₁ : x + i = y + j)
-- : (m + x + n + i) * z + k = z * (j + n + m + y) + k :=
-- begin
--   ac_mono*,
--   cc,
-- end

-- example (x y : ℕ)
--   (h : x ≤ y)
-- : true :=
-- begin
--   (do v ← mk_mvar,
--       p ← to_expr ```(%%v + x ≤ y + %%v),
--       assert `h' p),
--   ac_mono := h,
--   trivial,
--   exact 1,
-- end

-- example {x y z w : ℕ} : true := by
--   have : x * y ≤ z * w := by
--     mono with [0 ≤ z,0 ≤ y]
--     · guard_target = 0 ≤ z ; admit
--     · guard_target = 0 ≤ y ; admit
--     guard_target' = x ≤ z ; admit
--     guard_target' = y ≤ w ; admit
--   trivial

-- example {x y z w : Prop} : true := by
--   have : x ∧ y → z ∧ w := by
--     mono
--     guard_target = x → z ; admit
--     guard_target = y → w ; admit
--   trivial

-- example {x y z w : Prop} : true := by
--   have : x ∨ y → z ∨ w := by
--     mono
--     guard_target = x → z ; admit
--     guard_target = y → w ; admit
--   trivial

-- example {x y z w : ℤ} : true := by
--   suffices : x + y < w + z ; trivial
--   have : x < w ; admit
--   have : y ≤ z ; admit
--   mono right

-- example {x y z w : ℤ} : true := by
--   suffices : x * y < w * z ; trivial
--   have : x < w ; admit
--   have : y ≤ z ; admit
--   mono right
--   · guard_target = 0 < y ; admit
--   · guard_target = 0 ≤ w ; admit

-- example (x y : ℕ)
--   (h : x ≤ y)
-- : true :=
-- begin
--   (do v ← mk_mvar,
--       p ← to_expr ```(%%v + x ≤ y + %%v),
--       assert `h' p),
--   ac_mono := h,
--   trivial,
--   exact 3
-- end

-- example {α} [LinearOrder α]
--     (a b c d e : α) :
--     max a b ≤ e → b ≤ e := by
--   mono
--   apply le_max_right

-- example (a b c d e : Prop)
--     (h : d → a) (h' : c → e) :
--     (a ∧ b → c) ∨ d → (d ∧ b → e) ∨ a := by
--   mono
--   mono
--   mono

-- example : ∫ x in Icc 0 1, real.exp x ≤ ∫ x in Icc 0 1, real.exp (x+1) := by
--   mono
--   · exact real.continuous_exp.locally_integrable.integrable_on_is_compact is_compact_Icc
--   · exact (real.continuous_exp.comp $ continuous_add_right 1)
--       .locally_integrable.integrable_on_is_compact is_compact_Icc
--   intro x
--   dsimp only
--   mono
--   linarith


/-
Copyright (c) 2019 Reid Barton. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Mario Carneiro, Patrick Massot
-/
import topology.separation
import topology.bases

/-!
# Dense embeddings

This file defines three properties of functions:

* `dense_range f`      means `f` has dense image;
* `dense_inducing i`   means `i` is also `inducing`;
* `dense_embedding e`  means `e` is also an `embedding`.

The main theorem `continuous_extend` gives a criterion for a function
`f : X → Z` to a regular (T₃) space Z to extend along a dense embedding
`i : X → Y` to a continuous function `g : Y → Z`. Actually `i` only
has to be `dense_inducing` (not necessarily injective).

-/

noncomputable theory

open set filter
open_locale classical topological_space filter

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

/-- `i : α → β` is "dense inducing" if it has dense range and the topology on `α`
  is the one induced by `i` from the topology on `β`. -/
@[protect_proj] structure dense_inducing [topological_space α] [topological_space β] (i : α → β)
  extends inducing i : Prop :=
(dense : dense_range i)

namespace dense_inducing
variables [topological_space α] [topological_space β]
variables {i : α → β} (di : dense_inducing i)

lemma nhds_eq_comap (di : dense_inducing i) :
  ∀ a : α, 𝓝 a = comap i (𝓝 $ i a) :=
di.to_inducing.nhds_eq_comap

protected lemma continuous (di : dense_inducing i) : continuous i :=
di.to_inducing.continuous

lemma closure_range : closure (range i) = univ :=
di.dense.closure_range

protected lemma preconnected_space [preconnected_space α] (di : dense_inducing i) :
  preconnected_space β :=
di.dense.preconnected_space di.continuous

lemma closure_image_mem_nhds {s : set α} {a : α} (di : dense_inducing i) (hs : s ∈ 𝓝 a) :
  closure (i '' s) ∈ 𝓝 (i a) :=
begin
  rw [di.nhds_eq_comap a, ((nhds_basis_opens _).comap _).mem_iff] at hs,
  rcases hs with ⟨U, ⟨haU, hUo⟩, sub : i ⁻¹' U ⊆ s⟩,
  refine mem_of_superset (hUo.mem_nhds haU) _,
  calc U ⊆ closure (i '' (i ⁻¹' U)) : di.dense.subset_closure_image_preimage_of_is_open hUo
     ... ⊆ closure (i '' s)         : closure_mono (image_subset i sub)
end

lemma dense_image (di : dense_inducing i) {s : set α} : dense (i '' s) ↔ dense s :=
begin
  refine ⟨λ H x, _, di.dense.dense_image di.continuous⟩,
  rw [di.to_inducing.closure_eq_preimage_closure_image, H.closure_eq, preimage_univ],
  trivial
end

/-- If `i : α → β` is a dense embedding with dense complement of the range, then any compact set in
`α` has empty interior. -/
lemma interior_compact_eq_empty [t2_space β] (di : dense_inducing i) (hd : dense (range i)ᶜ)
  {s : set α} (hs : is_compact s) : interior s = ∅ :=
begin
  refine eq_empty_iff_forall_not_mem.2 (λ x hx, _),
  rw [mem_interior_iff_mem_nhds] at hx,
  have := di.closure_image_mem_nhds hx,
  rw (hs.image di.continuous).is_closed.closure_eq at this,
  rcases hd.inter_nhds_nonempty this with ⟨y, hyi, hys⟩,
  exact hyi (image_subset_range _ _ hys)
end

/-- The product of two dense inducings is a dense inducing -/
protected lemma prod [topological_space γ] [topological_space δ]
  {e₁ : α → β} {e₂ : γ → δ} (de₁ : dense_inducing e₁) (de₂ : dense_inducing e₂) :
  dense_inducing (λ(p : α × γ), (e₁ p.1, e₂ p.2)) :=
{ induced := (de₁.to_inducing.prod_mk de₂.to_inducing).induced,
  dense := de₁.dense.prod_map de₂.dense }

open topological_space

/-- If the domain of a `dense_inducing` map is a separable space, then so is the codomain. -/
protected lemma separable_space [separable_space α] : separable_space β :=
di.dense.separable_space di.continuous

variables [topological_space δ] {f : γ → α} {g : γ → δ} {h : δ → β}
/--
```
 γ -f→ α
g↓     ↓e
 δ -h→ β
```
-/
lemma tendsto_comap_nhds_nhds  {d : δ} {a : α} (di : dense_inducing i)
  (H : tendsto h (𝓝 d) (𝓝 (i a))) (comm : h ∘ g = i ∘ f) : tendsto f (comap g (𝓝 d)) (𝓝 a) :=
begin
  have lim1 : map g (comap g (𝓝 d)) ≤ 𝓝 d := map_comap_le,
  replace lim1 : map h (map g (comap g (𝓝 d))) ≤ map h (𝓝 d) := map_mono lim1,
  rw [filter.map_map, comm, ← filter.map_map, map_le_iff_le_comap] at lim1,
  have lim2 :  comap i (map h (𝓝 d)) ≤  comap i  (𝓝 (i a)) := comap_mono H,
  rw ← di.nhds_eq_comap at lim2,
  exact le_trans lim1 lim2,
end

protected lemma nhds_within_ne_bot (di : dense_inducing i) (b : β) :
  ne_bot (𝓝[range i] b) :=
di.dense.nhds_within_ne_bot b

lemma comap_nhds_ne_bot (di : dense_inducing i) (b : β) : ne_bot (comap i (𝓝 b)) :=
comap_ne_bot $ λ s hs,
let ⟨_, ⟨ha, a, rfl⟩⟩ := mem_closure_iff_nhds.1 (di.dense b) s hs in ⟨a, ha⟩

variables [topological_space γ]

/-- If `i : α → β` is a dense inducing, then any function `f : α → γ` "extends"
  to a function `g = extend di f : β → γ`. If `γ` is Hausdorff and `f` has a
  continuous extension, then `g` is the unique such extension. In general,
  `g` might not be continuous or even extend `f`. -/
def extend (di : dense_inducing i) (f : α → γ) (b : β) : γ :=
@@lim _ ⟨f (di.dense.some b)⟩ (comap i (𝓝 b)) f

lemma extend_eq_of_tendsto [t2_space γ] {b : β} {c : γ} {f : α → γ}
  (hf : tendsto f (comap i (𝓝 b)) (𝓝 c)) :
  di.extend f b = c :=
by haveI := di.comap_nhds_ne_bot; exact hf.lim_eq

lemma extend_eq_at [t2_space γ] {f : α → γ} {a : α} (hf : continuous_at f a) :
  di.extend f (i a) = f a :=
extend_eq_of_tendsto _ $ di.nhds_eq_comap a ▸ hf

lemma extend_eq_at' [t2_space γ] {f : α → γ} {a : α} (c : γ) (hf : tendsto f (𝓝 a) (𝓝 c)) :
  di.extend f (i a) = f a :=
di.extend_eq_at (continuous_at_of_tendsto_nhds hf)

lemma extend_eq [t2_space γ] {f : α → γ} (hf : continuous f) (a : α) :
  di.extend f (i a) = f a :=
di.extend_eq_at hf.continuous_at

/-- Variation of `extend_eq` where we ask that `f` has a limit along `comap i (𝓝 b)` for each
`b : β`. This is a strictly stronger assumption than continuity of `f`, but in a lot of cases
you'd have to prove it anyway to use `continuous_extend`, so this avoids doing the work twice. -/
lemma extend_eq' [t2_space γ] {f : α → γ}
  (di : dense_inducing i) (hf : ∀ b, ∃ c, tendsto f (comap i (𝓝 b)) (𝓝 c)) (a : α) :
  di.extend f (i a) = f a :=
begin
  rcases hf (i a) with ⟨b, hb⟩,
  refine di.extend_eq_at' b _,
  rwa ← di.to_inducing.nhds_eq_comap at hb,
end

lemma extend_unique_at [t2_space γ] {b : β} {f : α → γ} {g : β → γ} (di : dense_inducing i)
  (hf : ∀ᶠ x in comap i (𝓝 b), g (i x) = f x) (hg : continuous_at g b) :
  di.extend f b = g b :=
begin
  refine di.extend_eq_of_tendsto (λ s hs, mem_map.2 _),
  suffices : ∀ᶠ (x : α) in comap i (𝓝 b), g (i x) ∈ s,
    from hf.mp (this.mono $ λ x hgx hfx, hfx ▸ hgx),
  clear hf f,
  refine eventually_comap.2 ((hg.eventually hs).mono _),
  rintros _ hxs x rfl,
  exact hxs
end

lemma extend_unique [t2_space γ] {f : α → γ} {g : β → γ} (di : dense_inducing i)
  (hf : ∀ x, g (i x) = f x) (hg : continuous g) :
  di.extend f = g :=
funext $ λ b, extend_unique_at di (eventually_of_forall hf) hg.continuous_at

lemma continuous_at_extend [regular_space γ] {b : β} {f : α → γ} (di : dense_inducing i)
  (hf : ∀ᶠ x in 𝓝 b, ∃c, tendsto f (comap i $ 𝓝 x) (𝓝 c)) :
  continuous_at (di.extend f) b :=
begin
  set φ := di.extend f,
  haveI := di.comap_nhds_ne_bot,
  suffices : ∀ V' ∈ 𝓝 (φ b), is_closed V' → φ ⁻¹' V' ∈ 𝓝 b,
    by simpa [continuous_at, (closed_nhds_basis _).tendsto_right_iff],
  intros V' V'_in V'_closed,
  set V₁ := {x | tendsto f (comap i $ 𝓝 x) (𝓝 $ φ x)},
  have V₁_in : V₁ ∈ 𝓝 b,
  { filter_upwards [hf],
    rintros x ⟨c, hc⟩,
    dsimp [V₁, φ],
    rwa di.extend_eq_of_tendsto hc },
  obtain ⟨V₂, V₂_in, V₂_op, hV₂⟩ : ∃ V₂ ∈ 𝓝 b, is_open V₂ ∧ ∀ x ∈ i ⁻¹' V₂, f x ∈ V',
  { simpa [and_assoc] using ((nhds_basis_opens' b).comap i).tendsto_left_iff.mp
                            (mem_of_mem_nhds V₁_in : b ∈ V₁) V' V'_in },
  suffices : ∀ x ∈ V₁ ∩ V₂, φ x ∈ V',
  { filter_upwards [inter_mem V₁_in V₂_in] using this, },
  rintros x ⟨x_in₁, x_in₂⟩,
  have hV₂x : V₂ ∈ 𝓝 x := is_open.mem_nhds V₂_op x_in₂,
  apply V'_closed.mem_of_tendsto x_in₁,
  use V₂,
  tauto,
end

lemma continuous_extend [regular_space γ] {f : α → γ} (di : dense_inducing i)
  (hf : ∀b, ∃c, tendsto f (comap i (𝓝 b)) (𝓝 c)) : continuous (di.extend f) :=
continuous_iff_continuous_at.mpr $ assume b, di.continuous_at_extend $ univ_mem' hf

lemma mk'
  (i : α → β)
  (c     : continuous i)
  (dense : ∀x, x ∈ closure (range i))
  (H     : ∀ (a:α) s ∈ 𝓝 a,
    ∃t ∈ 𝓝 (i a), ∀ b, i b ∈ t → b ∈ s) :
  dense_inducing i :=
{ induced := (induced_iff_nhds_eq i).2 $
    λ a, le_antisymm (tendsto_iff_comap.1 $ c.tendsto _) (by simpa [filter.le_def] using H a),
  dense := dense }
end dense_inducing

/-- A dense embedding is an embedding with dense image. -/
structure dense_embedding [topological_space α] [topological_space β] (e : α → β)
  extends dense_inducing e : Prop :=
(inj : function.injective e)

theorem dense_embedding.mk'
  [topological_space α] [topological_space β] (e : α → β)
  (c     : continuous e)
  (dense : dense_range e)
  (inj   : function.injective e)
  (H     : ∀ (a:α) s ∈ 𝓝 a,
    ∃t ∈ 𝓝 (e a), ∀ b, e b ∈ t → b ∈ s) :
  dense_embedding e :=
{ inj := inj,
  ..dense_inducing.mk' e c dense H}

namespace dense_embedding
open topological_space
variables [topological_space α] [topological_space β] [topological_space γ] [topological_space δ]
variables {e : α → β} (de : dense_embedding e)

lemma inj_iff {x y} : e x = e y ↔ x = y := de.inj.eq_iff

lemma to_embedding : embedding e :=
{ induced := de.induced,
  inj := de.inj }

/-- If the domain of a `dense_embedding` is a separable space, then so is its codomain. -/
protected lemma separable_space [separable_space α] : separable_space β :=
de.to_dense_inducing.separable_space

/-- The product of two dense embeddings is a dense embedding. -/
protected lemma prod {e₁ : α → β} {e₂ : γ → δ} (de₁ : dense_embedding e₁)
  (de₂ : dense_embedding e₂) :
  dense_embedding (λ(p : α × γ), (e₁ p.1, e₂ p.2)) :=
{ inj := assume ⟨x₁, x₂⟩ ⟨y₁, y₂⟩,
    by simp; exact assume h₁ h₂, ⟨de₁.inj h₁, de₂.inj h₂⟩,
  ..dense_inducing.prod de₁.to_dense_inducing de₂.to_dense_inducing }

/-- The dense embedding of a subtype inside its closure. -/
@[simps] def subtype_emb {α : Type*} (p : α → Prop) (e : α → β) (x : {x // p x}) :
  {x // x ∈ closure (e '' {x | p x})} :=
⟨e x, subset_closure $ mem_image_of_mem e x.prop⟩

protected lemma subtype (p : α → Prop) : dense_embedding (subtype_emb p e) :=
{ dense := dense_iff_closure_eq.2 $
    begin
      ext ⟨x, hx⟩,
      rw image_eq_range at hx,
      simpa [closure_subtype, ← range_comp, (∘)],
    end,
  inj := (de.inj.comp subtype.coe_injective).cod_restrict _,
  induced := (induced_iff_nhds_eq _).2 (assume ⟨x, hx⟩,
    by simp [subtype_emb, nhds_subtype_eq_comap, de.to_inducing.nhds_eq_comap, comap_comap, (∘)]) }

lemma dense_image {s : set α} : dense (e '' s) ↔ dense s :=
de.to_dense_inducing.dense_image

end dense_embedding

lemma dense.dense_embedding_coe [topological_space α] {s : set α} (hs : dense s) :
  dense_embedding (coe : s → α) :=
{ dense := hs.dense_range_coe,
  .. embedding_subtype_coe }

lemma is_closed_property [topological_space β] {e : α → β} {p : β → Prop}
  (he : dense_range e) (hp : is_closed {x | p x}) (h : ∀a, p (e a)) :
  ∀b, p b :=
have univ ⊆ {b | p b},
  from calc univ = closure (range e) : he.closure_range.symm
    ... ⊆ closure {b | p b} : closure_mono $ range_subset_iff.mpr h
    ... = _ : hp.closure_eq,
assume b, this trivial

lemma is_closed_property2 [topological_space β] {e : α → β} {p : β → β → Prop}
  (he : dense_range e) (hp : is_closed {q:β×β | p q.1 q.2}) (h : ∀a₁ a₂, p (e a₁) (e a₂)) :
  ∀b₁ b₂, p b₁ b₂ :=
have ∀q:β×β, p q.1 q.2,
  from is_closed_property (he.prod_map he) hp $ λ _, h _ _,
assume b₁ b₂, this ⟨b₁, b₂⟩

lemma is_closed_property3 [topological_space β] {e : α → β} {p : β → β → β → Prop}
  (he : dense_range e) (hp : is_closed {q:β×β×β | p q.1 q.2.1 q.2.2})
  (h : ∀a₁ a₂ a₃, p (e a₁) (e a₂) (e a₃)) :
  ∀b₁ b₂ b₃, p b₁ b₂ b₃ :=
have ∀q:β×β×β, p q.1 q.2.1 q.2.2,
  from is_closed_property (he.prod_map $ he.prod_map he) hp $ λ _, h _ _ _,
assume b₁ b₂ b₃, this ⟨b₁, b₂, b₃⟩

@[elab_as_eliminator]
lemma dense_range.induction_on [topological_space β] {e : α → β} (he : dense_range e) {p : β → Prop}
  (b₀ : β) (hp : is_closed {b | p b}) (ih : ∀a:α, p $ e a) : p b₀ :=
is_closed_property he hp ih b₀

@[elab_as_eliminator]
lemma dense_range.induction_on₂ [topological_space β] {e : α → β} {p : β → β → Prop}
  (he : dense_range e) (hp : is_closed {q:β×β | p q.1 q.2}) (h : ∀a₁ a₂, p (e a₁) (e a₂))
  (b₁ b₂ : β) : p b₁ b₂ := is_closed_property2 he hp h _ _

@[elab_as_eliminator]
lemma dense_range.induction_on₃ [topological_space β] {e : α → β} {p : β → β → β → Prop}
  (he : dense_range e) (hp : is_closed {q:β×β×β | p q.1 q.2.1 q.2.2})
  (h : ∀a₁ a₂ a₃, p (e a₁) (e a₂) (e a₃))
  (b₁ b₂ b₃ : β) : p b₁ b₂ b₃ := is_closed_property3 he hp h _ _ _

section
variables [topological_space β] [topological_space γ] [t2_space γ]
variables {f : α → β}

/-- Two continuous functions to a t2-space that agree on the dense range of a function are equal. -/
lemma dense_range.equalizer (hfd : dense_range f)
  {g h : β → γ} (hg : continuous g) (hh : continuous h) (H : g ∘ f = h ∘ f) :
  g = h :=
funext $ λ y, hfd.induction_on y (is_closed_eq hg hh) $ congr_fun H
end


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.set_theory.game.short
import Mathlib.PostPort

universes u l

namespace Mathlib

/-!
# Games described via "the state of the board".

We provide a simple mechanism for constructing combinatorial (pre-)games, by describing
"the state of the board", and providing an upper bound on the number of turns remaining.

## Implementation notes

We're very careful to produce a computable definition, so small games can be evaluated
using `dec_trivial`. To achieve this, I've had to rely solely on induction on natural numbers:
relying on general well-foundedness seems to be poisonous to computation?

See `set_theory/game/domineering` for an example using this construction.
-/

namespace pgame

/--
`pgame_state S` describes how to interpret `s : S` as a state of a combinatorial game.
Use `pgame.of s` or `game.of s` to construct the game.

`pgame_state.L : S → finset S` and `pgame_state.R : S → finset S` describe the states reachable
by a move by Left or Right. `pgame_state.turn_bound : S → ℕ` gives an upper bound on the number of
possible turns remaining from this state.
-/
class state (S : Type u)
where
  turn_bound : S → ℕ
  L : S → finset S
  R : S → finset S
  left_bound : ∀ {s t : S}, t ∈ L s → turn_bound t < turn_bound s
  right_bound : ∀ {s t : S}, t ∈ R s → turn_bound t < turn_bound s

theorem turn_bound_ne_zero_of_left_move {S : Type u} [state S] {s : S} {t : S} (m : t ∈ state.L s) : state.turn_bound s ≠ 0 := sorry

theorem turn_bound_ne_zero_of_right_move {S : Type u} [state S] {s : S} {t : S} (m : t ∈ state.R s) : state.turn_bound s ≠ 0 := sorry

theorem turn_bound_of_left {S : Type u} [state S] {s : S} {t : S} (m : t ∈ state.L s) (n : ℕ) (h : state.turn_bound s ≤ n + 1) : state.turn_bound t ≤ n :=
  nat.le_of_lt_succ (nat.lt_of_lt_of_le (state.left_bound m) h)

theorem turn_bound_of_right {S : Type u} [state S] {s : S} {t : S} (m : t ∈ state.R s) (n : ℕ) (h : state.turn_bound s ≤ n + 1) : state.turn_bound t ≤ n :=
  nat.le_of_lt_succ (nat.lt_of_lt_of_le (state.right_bound m) h)

/--
Construct a `pgame` from a state and a (not necessarily optimal) bound on the number of
turns remaining.
-/
def of_aux {S : Type u} [state S] (n : ℕ) (s : S) (h : state.turn_bound s ≤ n) : pgame :=
  sorry

/-- Two different (valid) turn bounds give equivalent games. -/
def of_aux_relabelling {S : Type u} [state S] (s : S) (n : ℕ) (m : ℕ) (hn : state.turn_bound s ≤ n) (hm : state.turn_bound s ≤ m) : relabelling (of_aux n s hn) (of_aux m s hm) :=
  sorry

/-- Construct a combinatorial `pgame` from a state. -/
def of {S : Type u} [state S] (s : S) : pgame :=
  of_aux (state.turn_bound s) s sorry

/--
The equivalence between `left_moves` for a `pgame` constructed using `of_aux _ s _`, and `L s`.
-/
def left_moves_of_aux {S : Type u} [state S] (n : ℕ) {s : S} (h : state.turn_bound s ≤ n) : left_moves (of_aux n s h) ≃ Subtype fun (t : S) => t ∈ state.L s :=
  Nat.rec (fun (h : state.turn_bound s ≤ 0) => equiv.refl (left_moves (of_aux 0 s h)))
    (fun (n_n : ℕ)
      (n_ih : (h : state.turn_bound s ≤ n_n) → left_moves (of_aux n_n s h) ≃ Subtype fun (t : S) => t ∈ state.L s)
      (h : state.turn_bound s ≤ Nat.succ n_n) => equiv.refl (left_moves (of_aux (Nat.succ n_n) s h)))
    n h

/--
The equivalence between `left_moves` for a `pgame` constructed using `of s`, and `L s`.
-/
def left_moves_of {S : Type u} [state S] (s : S) : left_moves (of s) ≃ Subtype fun (t : S) => t ∈ state.L s :=
  left_moves_of_aux (state.turn_bound s) (of._proof_1 s)

/--
The equivalence between `right_moves` for a `pgame` constructed using `of_aux _ s _`, and `R s`.
-/
def right_moves_of_aux {S : Type u} [state S] (n : ℕ) {s : S} (h : state.turn_bound s ≤ n) : right_moves (of_aux n s h) ≃ Subtype fun (t : S) => t ∈ state.R s :=
  Nat.rec (fun (h : state.turn_bound s ≤ 0) => equiv.refl (right_moves (of_aux 0 s h)))
    (fun (n_n : ℕ)
      (n_ih : (h : state.turn_bound s ≤ n_n) → right_moves (of_aux n_n s h) ≃ Subtype fun (t : S) => t ∈ state.R s)
      (h : state.turn_bound s ≤ Nat.succ n_n) => equiv.refl (right_moves (of_aux (Nat.succ n_n) s h)))
    n h

/-- The equivalence between `right_moves` for a `pgame` constructed using `of s`, and `R s`. -/
def right_moves_of {S : Type u} [state S] (s : S) : right_moves (of s) ≃ Subtype fun (t : S) => t ∈ state.R s :=
  right_moves_of_aux (state.turn_bound s) (of._proof_1 s)

/--
The relabelling showing `move_left` applied to a game constructed using `of_aux`
has itself been constructed using `of_aux`.
-/
def relabelling_move_left_aux {S : Type u} [state S] (n : ℕ) {s : S} (h : state.turn_bound s ≤ n) (t : left_moves (of_aux n s h)) : relabelling (move_left (of_aux n s h) t)
  (of_aux (n - 1) (↑(coe_fn (left_moves_of_aux n h) t)) (relabelling_move_left_aux._proof_1 n h t)) :=
  Nat.rec (fun (h : state.turn_bound s ≤ 0) (t : left_moves (of_aux 0 s h)) => False._oldrec sorry)
    (fun (n_n : ℕ)
      (n_ih :
      (h : state.turn_bound s ≤ n_n) →
        (t : left_moves (of_aux n_n s h)) →
          relabelling (move_left (of_aux n_n s h) t) (of_aux (n_n - 1) ↑(coe_fn (left_moves_of_aux n_n h) t) sorry))
      (h : state.turn_bound s ≤ Nat.succ n_n) (t : left_moves (of_aux (Nat.succ n_n) s h)) =>
      relabelling.refl (move_left (of_aux (Nat.succ n_n) s h) t))
    n h t

/--
The relabelling showing `move_left` applied to a game constructed using `of`
has itself been constructed using `of`.
-/
def relabelling_move_left {S : Type u} [state S] (s : S) (t : left_moves (of s)) : relabelling (move_left (of s) t) (of ↑(equiv.to_fun (left_moves_of s) t)) :=
  relabelling.trans (relabelling_move_left_aux (state.turn_bound s) (of._proof_1 s) t)
    (of_aux_relabelling (↑(coe_fn (left_moves_of_aux (state.turn_bound s) (of._proof_1 s)) t)) (state.turn_bound s - 1)
      (state.turn_bound ↑(equiv.to_fun (left_moves_of s) t)) sorry sorry)

/--
The relabelling showing `move_right` applied to a game constructed using `of_aux`
has itself been constructed using `of_aux`.
-/
def relabelling_move_right_aux {S : Type u} [state S] (n : ℕ) {s : S} (h : state.turn_bound s ≤ n) (t : right_moves (of_aux n s h)) : relabelling (move_right (of_aux n s h) t)
  (of_aux (n - 1) (↑(coe_fn (right_moves_of_aux n h) t)) (relabelling_move_right_aux._proof_1 n h t)) :=
  Nat.rec (fun (h : state.turn_bound s ≤ 0) (t : right_moves (of_aux 0 s h)) => False._oldrec sorry)
    (fun (n_n : ℕ)
      (n_ih :
      (h : state.turn_bound s ≤ n_n) →
        (t : right_moves (of_aux n_n s h)) →
          relabelling (move_right (of_aux n_n s h) t) (of_aux (n_n - 1) ↑(coe_fn (right_moves_of_aux n_n h) t) sorry))
      (h : state.turn_bound s ≤ Nat.succ n_n) (t : right_moves (of_aux (Nat.succ n_n) s h)) =>
      relabelling.refl (move_right (of_aux (Nat.succ n_n) s h) t))
    n h t

/--
The relabelling showing `move_right` applied to a game constructed using `of`
has itself been constructed using `of`.
-/
def relabelling_move_right {S : Type u} [state S] (s : S) (t : right_moves (of s)) : relabelling (move_right (of s) t) (of ↑(equiv.to_fun (right_moves_of s) t)) :=
  relabelling.trans (relabelling_move_right_aux (state.turn_bound s) (of._proof_1 s) t)
    (of_aux_relabelling (↑(coe_fn (right_moves_of_aux (state.turn_bound s) (of._proof_1 s)) t)) (state.turn_bound s - 1)
      (state.turn_bound ↑(equiv.to_fun (right_moves_of s) t)) sorry sorry)

protected instance fintype_left_moves_of_aux {S : Type u} [state S] (n : ℕ) (s : S) (h : state.turn_bound s ≤ n) : fintype (left_moves (of_aux n s h)) :=
  fintype.of_equiv (Subtype fun (t : S) => t ∈ state.L s) (equiv.symm (left_moves_of_aux n h))

protected instance fintype_right_moves_of_aux {S : Type u} [state S] (n : ℕ) (s : S) (h : state.turn_bound s ≤ n) : fintype (right_moves (of_aux n s h)) :=
  fintype.of_equiv (Subtype fun (t : S) => t ∈ state.R s) (equiv.symm (right_moves_of_aux n h))

protected instance short_of_aux {S : Type u} [state S] (n : ℕ) {s : S} (h : state.turn_bound s ≤ n) : short (of_aux n s h) :=
  sorry

protected instance short_of {S : Type u} [state S] (s : S) : short (of s) :=
  id (pgame.short_of_aux (state.turn_bound s) (of._proof_1 s))

end pgame

namespace game

/-- Construct a combinatorial `game` from a state. -/
def of {S : Type u} [pgame.state S] (s : S) : game :=
  quotient.mk (pgame.of s)


import data.real.basic
import .affnK
import tactic.linarith
/-
Amanda:

Go to line 730ish and find the proof I just copied and pasted in. It is an example basis proof.
Dig into the details and you'll be able to adapt this, or at least some of it.
-/
import linear_algebra.basis
-- Testing vec_n_basis
⁻¹
/-
protected noncomputable def span : basis ι R (span R (range v)) :=
basis.mk (linear_independent_span hli) $
begin
  rw eq_top_iff,
  intros x _,
  have h₁ : subtype.val '' set.range (λ i, subtype.mk (v i) _) = range v,
  { rw ← set.range_comp },
  have h₂ : map (submodule.subtype _) (span R (set.range (λ i, subtype.mk (v i) _)))
    = span R (range v),
  { rw [← span_image, submodule.subtype_eq_val, h₁] },
  have h₃ : (x : M) ∈ map (submodule.subtype _) (span R (set.range (λ i, subtype.mk (v i) _))),
  { rw h₂, apply subtype.mem x },
  rcases mem_map.1 h₃ with ⟨y, hy₁, hy₂⟩,
  have h_x_eq_y : x = y,
  { rw [subtype.ext_iff, ← hy₂], simp },
  rwa h_x_eq_y
end
-/
→
open submodule
/-

protected theorem lt_asymm {n m : ℕ} (h₁ : n < m) : ¬ m < n :=
le_lt_antisymm (nat.le_of_lt h₁)

∘
-/
@[simp]
lemma eznat :  ∀ (a b : ℕ), a + b < a → false :=
begin
  intros a b c,
  cases b,
  suffices : ¬a < a, from by contradiction, exact irrefl _,
  let h1 : 0 < b.succ := by simp *,
  let h2 : a + 0 < a + b.succ := by simp *,
  let h3 : a + 0 < a := by exact lt_trans h2 c,
  suffices : ¬a < a, from by contradiction, exact irrefl _,

end

@[simp]
lemma eznat2 :  ∀ (a b : ℕ), b + a < a → false :=
begin
  intros a b c,
  rw ←(nat.add_comm a b) at c,
  exact eznat _ _ c,
end

#check nat.add_comm

#check nat.succ_ne_zero
#check nat.add_lt_add_left
#check lt_trans

#check finset.sum

#check nat.add_lt_add_left

def fin0notnonempty : ¬nonempty (fin 0) := begin
  by_contradiction,
  cases h,
  cases h,
    let : ¬h_val < 0 := nat.not_lt_zero _,
    contradiction
end
#check absurd

#check @linear_independent_fin_cons ℚ (vec_n ℚ 2) _ _ _

#check @linear_independent_empty_type (fin 0) ℚ (vec_n ℚ 1) sorry _ _ _ fin0notnonempty

#check submodule
#check module

#check submodule.

#check finset.not_mem_empty
#check set.not_mem_empty

#check set

#check submodule.span

#check funext

#check ext

def vec_1_basis :=
let v := (λ a : fin 1, (λ b : fin 1, vec.mk (1 : ℚ)))  in
  vec_n_basis.mk v
begin
  /-
lemma linear_independent_fin_cons {n} {v : fin n → V} :
  linear_independent K (fin.cons x v : fin (n + 1) → V) ↔
    linear_independent K v ∧ x ∉ submodule.span K (range v)
  -/
  let empty_basis : fin 0 → vec_n ℚ 1 := begin
    assume f0,
    cases f0,
    let : ¬f0_val < 0 := nat.not_lt_zero _,
    contradiction,
  end,
  let empli : linear_independent ℚ empty_basis :=
    @linear_independent_empty_type (fin 0) ℚ (vec_n ℚ 1) _ _ _ _ fin0notnonempty,
  let consb : fin 1 → vec_n ℚ 1 := (fin.cons (v ⟨0, by linarith⟩) empty_basis),
  let consbeqv : consb = v := begin
    suffices feh : ∀i, consb i = v i, from funext feh,
    intros,
    cases i,
    cases i_val,
    refl,
    let ht :  i_val + 1 = i_val.succ := by repeat { apply nat.add_one _ },
          rw ←ht at i_property,
          let : false := by exact eznat2 _ _ i_property,
    contradiction,
    /-

          let ht :  i_val + 2 = i_val.succ.succ := by repeat { apply nat.add_one _ },
          rw ←ht at i_property,
          let : false := by exact eznat2 _ _ i_property,
    -/
  end,
  let licons : linear_independent ℚ consb :=
  begin
    apply (@linear_independent_fin_cons ℚ (vec_n ℚ 1) _ _ _ (v ⟨0, by linarith⟩) _ empty_basis).mpr,
    split,
    exact empli,
    dsimp only [submodule.span, Inf],
    dsimp only [coe_sort, has_coe_to_sort.coe, coe, lift_t, has_lift_t.lift, coe_t, has_coe_t.coe, set_like.coe],
    dsimp only [set.range, set.Inter],
    --simp *,
    dsimp only [infi, Inf, complete_semilattice_Inf.Inf, complete_lattice.Inf, set.range],
    simp only [forall_apply_eq_imp_iff', and_imp, fin.mk_zero, exists_prop, nat.not_lt_zero, add_zero, int.coe_nat_zero, id.def,
    ge_iff_le, int.coe_nat_one, set_like.mem_coe, set.mem_set_of_eq, mem_carrier, exists_imp_distrib,
    has_subset.subset, set.subset],
    dsimp [set_of, has_mem.mem, set.mem],
    assume a,
    let empvecs : set (vec_n ℚ 1) := ∅,
    let empsm := @submodule.span ℚ (vec_n ℚ 1) _ _ _ ∅,
    let empsmemp := @submodule.span_empty ℚ (vec_n ℚ 1) _ _ _,
    let empsmeqbot : empsm = ⊥ := by simp *,
    let app_ := a ⊥,
    let huh : (∀ (a : fin 0), (↑(⊥ : submodule ℚ (vec_n ℚ 1)) : set _) (empty_basis a)) := begin
      intros f0,
      cases f0,
      let : ¬f0_val < 0 := nat.not_lt_zero _,
      contradiction,
    end,
    let hmm := app_ huh,
    let veq0 : (v 0) = 0 := (@mem_bot ℚ (vec_n ℚ 1) _ _ _ _).mp hmm,
    let vneq0_0 : (v 0 0) ≠ 0 := begin
      simp *,
      unfold has_zero.zero,
      dsimp [vec_zero ℚ],
      assume h,
      injection h, revert h_1,
      dec_trivial,
    end,
    let veq0_0 : (v 0 0) = 0 := begin
      rw veq0,
      refl,
    end,
    contradiction
    --intros a,
    /-let h2 : ((λ (a : vec_n ℚ 1), ∀ (a_1 : submodule ℚ (vec_n ℚ 1)),
              (∀ (a : fin 0), empty_basis a ∈ a_1) → a ∈ a_1) : set (vec_n ℚ 1)) (v 0)
      :=
        begin
          let h3 : _ := (mem_carrier ({carrier := λ (a : vec_n ℚ 1), ∀ (a_1 : submodule ℚ (vec_n ℚ 1)),
          (∀ (a : fin 0), empty_basis a ∈ a_1) → a ∈ a_1, zero_mem' := _, add_mem' := _, smul_mem' := _}
            : submodule ℚ (vec_n ℚ 1))).mpr h,

        end,
    let h1
      : h0 = ∅
      := by admit,-/
  end,
  rw consbeqv at licons,
  exact licons,
--#check not
 -- eapply
--#check ∉
  /-

theorem linear_independent_iff' : linear_independent R v ↔
  ∀ s : finset ι, ∀ g : ι → R, ∑ i in s, g i • v i = 0 → ∀ i ∈ s, g i = 0 :=
  -/
  /-
  eapply (@linear_independent_iff' (fin 1) ℚ (vec_n ℚ 1) v _ _ _).mpr,
  intros a b c d e,-/
/-

lemma sum_range_succ {β} [add_comm_monoid β] (f : ℕ → β) (n : ℕ) :
  ∑ x in range (n + 1), f x = ∑ x in range n, f x + f n :=
by simp only [add_comm, sum_range_succ_comm]
-/
  --unfold finset.sum at *,
 -- revert c,
  --unfold_projs,
  --dsimp [finset.sum] at c,

  /-ext,
  split,
  {
    /-intro h,
    dsimp only [has_bot.bot, has_zero.zero, add_zero_class.zero, add_monoid.zero, add_comm_monoid.zero],
    suffices h' : x = {support := ∅, to_fun := λ (_x : fin 1), semiring.zero, mem_support_to_fun := _},
    exact h',
    dsimp only [linear_map.ker, submodule.comap, set.preimage] at h,
    have h₀ : ⇑(finsupp.total (fin 1) (vec_n ℚ 1) ℚ (λ (a b : fin 1), {coord := 1})) x ∈ ↑⊥ := by exact h,
    dsimp only [has_bot.bot, has_zero.zero, add_zero_class.zero, add_monoid.zero, add_comm_monoid.zero] at h₀,
    dsimp only [vec_zero] at h₀,
    have h₁ : ⇑(finsupp.total (fin 1) (vec_n ℚ 1) ℚ (λ (a b : fin 1), {coord := 1})) x = λ (_x : fin 1), mk_vec ℚ 0 := by exact h₀,
    dsimp only [finsupp.total, finsupp.lsum, coe_fn, has_coe_to_fun.coe] at h₁,
    dsimp [finsupp.sum] at h₁,
    simp only [linear_map.id_coe, id.def] at h₁,
    sorry,-/
  },
  {
    intro h,
    dsimp only [has_bot.bot, has_zero.zero, add_zero_class.zero, add_monoid.zero, add_comm_monoid.zero] at h,
    have h₀ : x = {support := ∅, to_fun := λ (_x : fin 1), semiring.zero, mem_support_to_fun := _} := by exact h,
    dsimp only [linear_map.ker, submodule.comap, set.preimage],
    suffices h' : ⇑(finsupp.total (fin 1) (vec_n ℚ 1) ℚ (λ (a b : fin 1), {coord := 1})) x ∈ ↑⊥,
    exact h',
    dsimp only [has_bot.bot, has_zero.zero, add_zero_class.zero, add_monoid.zero, add_comm_monoid.zero],
    dsimp only [vec_zero],
    suffices h' : ⇑(finsupp.total (fin 1) (vec_n ℚ 1) ℚ (λ (a b : fin 1), {coord := 1})) x = λ (_x : fin 1), mk_vec ℚ 0,
    exact h',
    dsimp only [finsupp.total, finsupp.lsum, coe_fn, has_coe_to_fun.coe],
    rw h₀,
    dsimp [finsupp.sum],
    refl,
  }-/
end begin
  dsimp only [submodule.span, Inf],
  dsimp only [has_top.top, set.univ],
  dsimp only [coe_sort, has_coe_to_sort.coe, coe, lift_t, has_lift_t.lift, coe_t, has_coe_t.coe, set_like.coe],
  dsimp only [set.range, set.Inter],
  simp only [nonempty_of_inhabited, set.mem_set_of_eq, exists_const],
  ext,
  split,
  {
    intro,
    exact true.intro,
  },
  {
    intro,
    dsimp only [infi, Inf, complete_semilattice_Inf.Inf, complete_lattice.Inf, set.range],
    simp *,
    dsimp [set_of],
    intros f g,
    simp [has_subset.subset, set.subset] at g,
    /-
    (λ (a : vec_n ℚ 2),
      (∀ ⦃a : vec_n ℚ 2⦄,
        (a ∈ λ (x : vec_n ℚ 2),
          ∃ (y : fin 2), (λ (j : fin 2), ite (y = j) {coord := 1} {coord := 0}) = x)
            → a ∈ c.carrier) → a ∈ c)
        = t
    -/
    let h3 := x ⟨0, by linarith⟩,
    destruct h3,

    intros,
    let one_ : vec_n ℚ 1 := (λ i, {coord := 1}),

    let h4 : one_ ∈ f := by apply @g one_ rfl,
    let onex := coord•one_,
    let onexmem : onex ∈ f :=
      by exact @submodule.smul_mem ℚ (vec_n ℚ 1) _ _ _ f one_ coord h4,
    haveI := onex,
    let h6 : coord • (λ (i : fin 1), {coord := 1} : vec_n ℚ 1) = onex := rfl,
    let onexeq : (∀ (i : fin 1), x i = onex i) := begin
        intros,
        cases i,
        cases i_val,
        { rw ←h6,
          let h7 : (coord • (λ (i : fin 1), {coord := 1}) : vec_n ℚ 1) ⟨0, i_property⟩
            = (coord • {coord := 1}) := begin
              refl
            end,
          simp [h7],
          dsimp [has_scalar.smul],
          simp *,
          let h16 : x 0 = h3 := by refl,
          rw h16,
          exact a,
         },
        {
          cases i_val,
          let h10 : (1 )= (1) := rfl,
          let h11 := lt_irrefl 1,
          contradiction,

          let h12 : 1 < i_val.succ.succ := by exact nat.one_lt_succ_succ i_val,
          let h13 : 1 < 1 := by exact lt_trans h12 i_property,
          let h14 : ¬1<1 := by exact lt_irrefl _,
          contradiction,
        },
    end,
    let h20 : x = onex := by exact funext onexeq,
    rw h20,
    exact onexmem,

  },
end

#check submodule.span

def vec_2_basis :=
let v := (λ i : fin 2, (λ j : fin 2,
  if i = j then mk_vec ℚ 1 else mk_vec ℚ 0
))  in
  vec_n_basis.mk v
begin
  /-
lemma linear_independent_fin_cons {n} {v : fin n → V} :
  linear_independent K (fin.cons x v : fin (n + 1) → V) ↔
    linear_independent K v ∧ x ∉ submodule.span K (range v)
  -/
  let empty_basis : fin 0 → vec_n ℚ 2 := begin
    assume f0,
    cases f0,
    let : ¬f0_val < 0 := nat.not_lt_zero _,
    contradiction,
  end,
  let empli : linear_independent ℚ empty_basis :=
    @linear_independent_empty_type (fin 0) ℚ (vec_n ℚ 2) _ _ _ _ fin0notnonempty,
  let consb : fin 1 → vec_n ℚ 2 := (fin.cons (v ⟨0, by linarith⟩) empty_basis),
  let consb3 : fin 2 → vec_n ℚ 2 := (fin.snoc consb (v ⟨1, by linarith⟩)),

  /-let consbeqv : consb = v := begin
    suffices feh : ∀i, consb i = v i, from funext feh,
    intros,
    cases i,
    cases i_val,
    refl,
    let ht :  i_val + 1 = i_val.succ := by repeat { apply nat.add_one _ },
          rw ←ht at i_property,
          let : false := by exact eznat2 _ _ i_property,
    contradiction,
    /-

          let ht :  i_val + 2 = i_val.succ.succ := by repeat { apply nat.add_one _ },
          rw ←ht at i_property,
          let : false := by exact eznat2 _ _ i_property,
    -/
  end,-/
  let licons : linear_independent ℚ consb :=
  begin
    apply (@linear_independent_fin_cons ℚ (vec_n ℚ 2) _ _ _ (v ⟨0, by linarith⟩) _ empty_basis).mpr,
    split,
    exact empli,
    dsimp only [submodule.span, Inf],
    dsimp only [coe_sort, has_coe_to_sort.coe, coe, lift_t, has_lift_t.lift, coe_t, has_coe_t.coe, set_like.coe],
    dsimp only [set.range, set.Inter],
    --simp *,
    dsimp only [infi, Inf, complete_semilattice_Inf.Inf, complete_lattice.Inf, set.range],
    simp only [forall_apply_eq_imp_iff', and_imp, fin.mk_zero, exists_prop, nat.not_lt_zero, add_zero, int.coe_nat_zero, id.def,
    ge_iff_le, int.coe_nat_one, set_like.mem_coe, set.mem_set_of_eq, mem_carrier, exists_imp_distrib,
    has_subset.subset, set.subset],
    dsimp [set_of, has_mem.mem, set.mem],
    assume a,
    let empvecs : set (vec_n ℚ 2) := ∅,
    let empsm := @submodule.span ℚ (vec_n ℚ 2) _ _ _ ∅,
    let empsmemp := @submodule.span_empty ℚ (vec_n ℚ 2) _ _ _,
    let empsmeqbot : empsm = ⊥ := by simp *,
    let app_ := a ⊥,
    let huh : (∀ (a : fin 0), (↑(⊥ : submodule ℚ (vec_n ℚ 2)) : set _) (empty_basis a)) := begin
      intros f0,
      cases f0,
      let : ¬f0_val < 0 := nat.not_lt_zero _,
      contradiction,
    end,
    let hmm := app_ huh,
    let veq0 : (v 0) = 0 := (@mem_bot ℚ (vec_n ℚ 2) _ _ _ _).mp hmm,
    let vneq0_0 : (v 0 0) ≠ 0 := begin
      simp *,
      unfold has_zero.zero,
      dsimp [vec_zero ℚ],
      assume h,
      injection h, revert h_1,
      dec_trivial,
    end,
    let veq0_0 : (v 0 0) = 0 := begin
      rw veq0,
      refl,
    end,
    contradiction
  end,
  let consb2 : fin 2 → vec_n ℚ 2 := (fin.snoc consb (v ⟨1, by linarith⟩)),
  let licons2 : linear_independent ℚ consb2 :=
  begin
    apply (@linear_independent_fin_snoc ℚ (vec_n ℚ 2) _ _ _ (v ⟨1, by linarith⟩) _ consb).mpr,
    split,
    exact licons,
    let span_ := span ℚ (set.range consb),
    dsimp only [submodule.span, Inf],
    dsimp only [coe_sort, has_coe_to_sort.coe, coe, lift_t, has_lift_t.lift, coe_t, has_coe_t.coe, set_like.coe],
    dsimp only [set.range, set.Inter],
    --simp *,
    dsimp only [infi, Inf, complete_semilattice_Inf.Inf, complete_lattice.Inf, set.range],
    simp only [forall_apply_eq_imp_iff', and_imp, fin.mk_zero, exists_prop, nat.not_lt_zero, add_zero, int.coe_nat_zero, id.def,
    ge_iff_le, int.coe_nat_one, set_like.mem_coe, set.mem_set_of_eq, mem_carrier, exists_imp_distrib,
    has_subset.subset, set.subset],
    dsimp [set_of, has_mem.mem, set.mem],
    assume a,

  end
end
begin
  dsimp only [submodule.span, Inf],
  dsimp only [has_top.top, set.univ],
  dsimp only [coe_sort, has_coe_to_sort.coe, coe, lift_t, has_lift_t.lift, coe_t, has_coe_t.coe, set_like.coe],
  dsimp only [set.range, set.Inter],
  simp only [nonempty_of_inhabited, set.mem_set_of_eq, exists_const],
  ext,
  split,
  {
    intros,
    exact true.intro,
  },
  {
    intros,
    intro,
    dsimp only [infi, Inf, complete_semilattice_Inf.Inf, complete_lattice.Inf, set.range],
    simp *,
    dsimp [set_of],
    intros c d,
    dsimp [has_subset.subset, set.subset] at d,--, has_mem.mem, set.mem] at d,
    --rw ←d at t,
    --rw d.symm,
    let smdef : set (vec_n ℚ 2) :=
      (λ (a : vec_n ℚ 2),
      (∀ ⦃a : vec_n ℚ 2⦄, (∃ (y : fin 2),
        (λ (j : fin 2), ite (y = j) ({coord := 1}: vec ℚ) ({coord := 0}: vec ℚ)
        ) = a) → c.carrier a)
          → (↑c : set _) a),
    let tt : t = smdef := by exact d.symm,
    simp *,
    dsimp [has_mem.mem, set.mem],
    assume cmem : _,
    let v0 := v ⟨0, by linarith⟩,
    let v1 := v ⟨1, by linarith⟩,
    let v0mem : v0 ∈ c := begin
      --let h0 :
      let c0 : vec_n ℚ 2 :=
        (λ (j : fin 2), ite (0 = j) ({coord := 1}: vec ℚ) ({coord := 0}: vec ℚ)),
      let h0 : c.carrier c0 := cmem 0,
      let h1 : c0 = v0 :=
        begin
          suffices sh : ∀ i, c0 i = v0 i, from funext sh,
          intros,
          cases i,
          cases i_val,
          refl,
          cases i_val,
          refl,
          let ht :  i_val + 2 = i_val.succ.succ := by repeat { apply nat.add_one _ },
          rw ←ht at i_property,
          let : false := by exact eznat2 _ _ i_property,
          contradiction,
        end,
      rw ←h1,
      exact (mem_carrier c).mp h0,
    end,
    let v1mem : v1 ∈ c := begin
      --let h0 :
      let c1 : vec_n ℚ 2 :=
        (λ (j : fin 2), ite (1 = j) ({coord := 1}: vec ℚ) ({coord := 0}: vec ℚ)),
      let h0 : c.carrier c1 := cmem ⟨1, by linarith⟩,
      let h1 : c1 = v1 :=
        begin
          suffices sh : ∀ i, c1 i = v1 i, from funext sh,
          intros,
          cases i,
          cases i_val,
          refl,
          cases i_val,
          refl,
          let ht :  i_val + 2 = i_val.succ.succ := by repeat { apply nat.add_one _ },
          rw ←ht at i_property,
          let : false := by exact eznat2 _ _ i_property,
          contradiction,
        end,
      rw ←h1,
      exact (mem_carrier c).mp h0,
    end,

    --let x0 := x ⟨0, by linarith⟩,
    --let x1 := x ⟨1, by linarith⟩,
    destruct x ⟨0, by linarith⟩,
    intros c0 e0,
    destruct x ⟨1, by linarith⟩,
    intros c1 e1,
    let c0smulv0 := λ (j : fin 2), ite (0 = j) ({coord := c0}: vec ℚ) ({coord := 0}: vec ℚ),
    let c0smulv0_eq :
      (c0 • v0 = c0smulv0)
        := begin
         -- simp *,
          suffices sh : ∀ i, (c0 • v0) i = c0smulv0 i, from funext sh,
          intros,
          cases i,
          cases i_val,
          simp *,
          let h0 : ite (0 = 0) ({coord := c0} : vec ℚ) ({coord := 0} : vec ℚ) = ({coord := c0} : vec ℚ) := rfl,
          simp *,
          dsimp [has_scalar.smul],
          simp *,
          cases i_val,
          simp *,
          let h0 : ite (1 = 0) ({coord := c0} : vec ℚ) ({coord := 0} : vec ℚ) = ({coord := 0} : vec ℚ) := rfl,
          simp *,
          dsimp [has_scalar.smul],
          simp *,
          let ht :  i_val + 2 = i_val.succ.succ := by repeat { apply nat.add_one _ },
          rw ←ht at i_property,
          let : false := by exact eznat2 _ _ i_property,
          contradiction,

        end,
    let c0smulv0mem : c0smulv0 ∈ c :=
      begin
        rw ←c0smulv0_eq,
        exact @submodule.smul_mem ℚ (vec_n ℚ 2) _ _ _ c v0 c0 v0mem
      end,

    let c1smulv1 := λ (j : fin 2), ite (1 = j) ({coord := c1}: vec ℚ) ({coord := 0}: vec ℚ),

    let c1smulv1_eq :
      (c1 • v1 = c1smulv1)
        := begin
         -- simp *,
          suffices sh : ∀ i, (c1 • v1) i = c1smulv1 i, from funext sh,
          intros,
          cases i,
          cases i_val,
          simp *,
          --let h0 : ite (1 = 0) ({coord := c1} : vec ℚ) ({coord := 0} : vec ℚ) = ({coord := c1} : vec ℚ) := rfl,
          --simp *,
          dsimp [has_scalar.smul],
          simp *,
          cases i_val,
          simp *,
          --let h0 : ite (0 = 0) ({coord := c1} : vec ℚ) ({coord := 0} : vec ℚ) = ({coord := 0} : vec ℚ) := rfl,
          --simp *,
          dsimp [has_scalar.smul],
          simp *,
          let ht :  i_val + 2 = i_val.succ.succ := by repeat { apply nat.add_one _ },
          rw ←ht at i_property,
          let : false := by exact eznat2 _ _ i_property,
          contradiction,

        end,
    let c1smulv1mem : c1smulv1 ∈ c :=
      begin
        rw ←c1smulv1_eq,
        exact @submodule.smul_mem ℚ (vec_n ℚ 2) _ _ _ c v1 c1 v1mem
      end,

    let comb_mem : c0smulv0 + c1smulv1 ∈ c :=
      by exact @submodule.add_mem ℚ (vec_n ℚ 2) _ _ _ c  _ _ c0smulv0mem c1smulv1mem,

    let x_combeq : x = c0smulv0 + c1smulv1 := begin
      suffices sh : ∀ i, x i = (c0smulv0 + c1smulv1) i, from funext sh,
      intros,
      cases i,
      cases i_val,
      /-
      x ⟨0, i_property⟩ = (c0smulv0 + c1smulv1) ⟨0, i_property⟩
      -/
      rw e0,
      simp *, refl,
      cases i_val,
      rw e1,
      simp *, refl,
      let ht :  i_val + 2 = i_val.succ.succ := by repeat { apply nat.add_one _ },
      rw ←ht at i_property,
      let : false := by exact eznat2 _ _ i_property,
      contradiction,
    end,

    rw x_combeq,
    exact comb_mem,
  }
end

def vec_2_basis_hard :=
let v := (λ i : fin 2,
  if i = 0 then mk_vec_n ℚ 2 ⟨[4, 3],rfl⟩ else mk_vec_n ℚ 2 ⟨[-1, 1],rfl⟩)
  in
  vec_n_basis.mk v
  begin

  end
  begin

  end

#check @fintype.linear_independent_iff (fin 2) ℚ (vec_n ℚ 2) sorry _ _ _ _

variables (sm : submodule ℚ (vec_n ℚ 1)) (v : (vec_n ℚ 1))

let h15 := funext one

#check @linear_independent_iff' (fin 1) ℚ (vec_n ℚ 1) sorry _ _ _

#check nat.add_succ_sub_one

#check funext
#check (1:ℚ) • v

#check ↑(finset.range 3)

#check nat.add_succ_lt_add
#check nat.succ_succ_ne_one

#check smul_prod

#check lt_tra

#check lt_one_add
#check nat.lt_add_left

#check nat.succ_succ

#check iff.mpr

#check lt_add_one

#check nat.succ

#check submodule
/-
(
  λ (a : vec_n ℚ 2),
  (∀ ⦃a : vec_n ℚ 2⦄,
    set.mem a
    (
      λ (x : vec_n ℚ 2),
      ∃ (y : fin 2),
      (
        λ (j : fin 2),
        ite (y = j) {coord := 1} {coord := 0}
      )
      = x
    )
    →
    set.mem a c.carrier
  )
  →
  set.mem a ↑c
)
= t

-/

#check nat.lt_add_of_zero_lt_left

#check @submodule.smul_mem

#check smul_add

#check finset

#check v ∈ sm

#check (↑sm:set (vec_n ℚ 1)) v

def dajks : fin 2 → ℕ
| ⟨0, _⟩ := 1
| ⟨1, _⟩ := 2
| ⟨n, _⟩ := 0

def dasjsj : ∀i ∈ finset.range 2, ℕ
:= λi : _, λ j, begin
  cases i,
  exact 0,
  cases i,
  exact 0,
  cases i,

end

#check nat.lt

#check nat_ceil_lt_add_one
#check nat_mul_inj

#check lt_irrefl

#check lt_add_one
#check submodule

#check module

#check {[1]} ⊆  {[1], [2]}

#check ⦃a : vec_n ℚ 1⦄

#check eq_bot_iff

#check eq

#check set.set_of_mem_eq

def n := 1
def K := ℚ

def myfinset : finset ℕ := finset.range 4
@[reducible]
abbreviation pt_nf := ∀i ∈{i|i∈myfinset}, pt ℚ
@[reducible]
abbreviation vec_nf := fin (n) → vec ℚ

#check set.range

#eval 0 ∈ myfinset
#eval myfinset

def mk_pt_nf (vals : vector ℚ n) : pt_nf :=
  λj : _, λmf:_, begin

  end

def mk_vec_nf (vals : vector ℚ n) : vec_nf ℚ n :=
  λi, mk_vec ℚ (vals.nth i)

def pt_nf.coords
 (ptn : pt_nf ) : fin n → ℚ :=
  λi : fin n, (ptn i).coord

def vec_nf.coords (vecn : vec_nf ) : fin n → K :=
  λi, (vecn i).coord

structure vec_nf_basis :=
  (basis_vecs:fin n → vec_nf )
  (basis_independent : linear_independent ℚ basis_vecs)
  (basis_spans : submodule.span ℚ (set.range basis_vecs) = ⊤)

instance : has_lift_t (vec_nf_basis K n) (fin n → vec_n K n) := ⟨λvb, vb.basis_vecs⟩

open_locale affine
--done
instance : add_comm_group (vec_nf) := by apply_instance
instance : affine_space (vec_nf) (pt_nf) := by apply_instance

/-
Frame built from primitive (fin n)-indexed maps pts and vecs.
Constructors are Base (standard) frame or a derived frame.
-/
inductive fm : Π (dim : ℕ) , Type
| base : Π (dim : ℕ), fm dim

@[simp]
def fm.basis
{dim : ℕ} :
fm  dim → (vec_n_basis ℚ dim)
| (fm.base dim ) := ⟨(λ i j, if j = i then mk_vec K 1 else mk_vec K 0), sorry, sorry⟩


/-
Copyright © 2020 Nicolò Cavalleri. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Nicolò Cavalleri
-/

import geometry.manifold.times_cont_mdiff
import topology.continuous_function.basic

/-!
# Smooth bundled map

In this file we define the type `times_cont_mdiff_map` of `n` times continuously differentiable
bundled maps.
-/

variables {𝕜 : Type*} [nondiscrete_normed_field 𝕜]
{E : Type*} [normed_group E] [normed_space 𝕜 E]
{E' : Type*} [normed_group E'] [normed_space 𝕜 E']
{H : Type*} [topological_space H]
{H' : Type*} [topological_space H']
(I : model_with_corners 𝕜 E H) (I' : model_with_corners 𝕜 E' H')
(M : Type*) [topological_space M] [charted_space H M]
(M' : Type*) [topological_space M'] [charted_space H' M']
{E'' : Type*} [normed_group E''] [normed_space 𝕜 E'']
{H'' : Type*} [topological_space H'']
{I'' : model_with_corners 𝕜 E'' H''}
{M'' : Type*} [topological_space M''] [charted_space H'' M'']
(n : with_top ℕ)

/-- Bundled `n` times continuously differentiable maps. -/
@[protect_proj]
structure times_cont_mdiff_map :=
(to_fun                  : M → M')
(times_cont_mdiff_to_fun : times_cont_mdiff I I' n to_fun)

/-- Bundled smooth maps. -/
@[reducible] def smooth_map := times_cont_mdiff_map I I' M M' ⊤

localized "notation `C^` n `⟮` I `, ` M `; ` I' `, ` M' `⟯` :=
  times_cont_mdiff_map I I' M M' n" in manifold
localized "notation `C^` n `⟮` I `, ` M `; ` k `⟯` :=
  times_cont_mdiff_map I (model_with_corners_self k k) M k n" in manifold

open_locale manifold

namespace times_cont_mdiff_map

variables {I} {I'} {M} {M'} {n}

instance : has_coe_to_fun C^n⟮I, M; I', M'⟯ := ⟨_, times_cont_mdiff_map.to_fun⟩
instance : has_coe C^n⟮I, M; I', M'⟯ C(M, M') :=
⟨λ f, ⟨f.to_fun, f.times_cont_mdiff_to_fun.continuous⟩⟩

variables {f g : C^n⟮I, M; I', M'⟯}

protected lemma times_cont_mdiff (f : C^n⟮I, M; I', M'⟯) :
  times_cont_mdiff I I' n f := f.times_cont_mdiff_to_fun

protected lemma smooth (f : C^∞⟮I, M; I', M'⟯) :
  smooth I I' f := f.times_cont_mdiff_to_fun

protected lemma mdifferentiable' (f : C^n⟮I, M; I', M'⟯) (hn : 1 ≤ n) :
  mdifferentiable I I' f :=
f.times_cont_mdiff.mdifferentiable hn

protected lemma mdifferentiable (f : C^∞⟮I, M; I', M'⟯) :
  mdifferentiable I I' f :=
f.times_cont_mdiff.mdifferentiable le_top

protected lemma mdifferentiable_at (f : C^∞⟮I, M; I', M'⟯) {x} :
  mdifferentiable_at I I' f x :=
f.mdifferentiable x

lemma coe_inj ⦃f g : C^n⟮I, M; I', M'⟯⦄ (h : (f : M → M') = g) : f = g :=
by cases f; cases g; cases h; refl

@[ext] theorem ext (h : ∀ x, f x = g x) : f = g :=
by cases f; cases g; congr'; exact funext h

/-- The identity as a smooth map. -/
def id : C^n⟮I, M; I, M⟯ := ⟨id, times_cont_mdiff_id⟩

/-- The composition of smooth maps, as a smooth map. -/
def comp (f : C^n⟮I', M'; I'', M''⟯) (g : C^n⟮I, M; I', M'⟯) : C^n⟮I, M; I'', M''⟯ :=
{ to_fun := λ a, f (g a),
  times_cont_mdiff_to_fun := f.times_cont_mdiff_to_fun.comp g.times_cont_mdiff_to_fun, }

@[simp] lemma comp_apply (f : C^n⟮I', M'; I'', M''⟯) (g : C^n⟮I, M; I', M'⟯) (x : M) :
  f.comp g x = f (g x) := rfl

instance [inhabited M'] : inhabited C^n⟮I, M; I', M'⟯ :=
⟨⟨λ _, default _, times_cont_mdiff_const⟩⟩

/-- Constant map as a smooth map -/
def const (y : M') : C^n⟮I, M; I', M'⟯ := ⟨λ x, y, times_cont_mdiff_const⟩

end times_cont_mdiff_map

instance continuous_linear_map.has_coe_to_times_cont_mdiff_map :
  has_coe (E →L[𝕜] E') C^n⟮𝓘(𝕜, E), E; 𝓘(𝕜, E'), E'⟯ :=
⟨λ f, ⟨f.to_fun, f.times_cont_mdiff⟩⟩


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Mario Carneiro, Reid Barton
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.topology.category.Top.opens
import Mathlib.PostPort

universes v u

namespace Mathlib

/-!
# Presheaves on a topological space

We define `presheaf C X` simply as `(opens X)ᵒᵖ ⥤ C`,
and inherit the category structure with natural transformations as morphisms.

We define
* `pushforward_obj {X Y : Top.{v}} (f : X ⟶ Y) (ℱ : X.presheaf C) : Y.presheaf C`
with notation `f _* ℱ`
and for `ℱ : X.presheaf C` provide the natural isomorphisms
* `pushforward.id : (𝟙 X) _* ℱ ≅ ℱ``
* `pushforward.comp : (f ≫ g) _* ℱ ≅ g _* (f _* ℱ)`
along with their `@[simp]` lemmas.
-/

namespace Top

def presheaf (C : Type u) [category_theory.category C] (X : Top) :=
  topological_space.opens ↥Xᵒᵖ ⥤ C

namespace presheaf

/-- Pushforward a presheaf on `X` along a continuous map `f : X ⟶ Y`, obtaining a presheaf on `Y`. -/
def pushforward_obj {C : Type u} [category_theory.category C] {X : Top} {Y : Top} (f : X ⟶ Y) (ℱ : presheaf C X) : presheaf C Y :=
  category_theory.functor.op (topological_space.opens.map f) ⋙ ℱ

infixl:80 " _* " => Mathlib.Top.presheaf.pushforward_obj

@[simp] theorem pushforward_obj_obj {C : Type u} [category_theory.category C] {X : Top} {Y : Top} (f : X ⟶ Y) (ℱ : presheaf C X) (U : topological_space.opens ↥Yᵒᵖ) : category_theory.functor.obj (f _* ℱ) U =
  category_theory.functor.obj ℱ
    (category_theory.functor.obj (category_theory.functor.op (topological_space.opens.map f)) U) :=
  rfl

@[simp] theorem pushforward_obj_map {C : Type u} [category_theory.category C] {X : Top} {Y : Top} (f : X ⟶ Y) (ℱ : presheaf C X) {U : topological_space.opens ↥Yᵒᵖ} {V : topological_space.opens ↥Yᵒᵖ} (i : U ⟶ V) : category_theory.functor.map (f _* ℱ) i =
  category_theory.functor.map ℱ
    (category_theory.functor.map (category_theory.functor.op (topological_space.opens.map f)) i) :=
  rfl

def pushforward_eq {C : Type u} [category_theory.category C] {X : Top} {Y : Top} {f : X ⟶ Y} {g : X ⟶ Y} (h : f = g) (ℱ : presheaf C X) : f _* ℱ ≅ g _* ℱ :=
  category_theory.iso_whisker_right
    (category_theory.nat_iso.op (category_theory.iso.symm (topological_space.opens.map_iso f g h))) ℱ

@[simp] theorem pushforward_eq_hom_app {C : Type u} [category_theory.category C] {X : Top} {Y : Top} {f : X ⟶ Y} {g : X ⟶ Y} (h : f = g) (ℱ : presheaf C X) (U : topological_space.opens ↥Yᵒᵖ) : category_theory.nat_trans.app (category_theory.iso.hom (pushforward_eq h ℱ)) U =
  category_theory.functor.map ℱ
    (id
      (category_theory.has_hom.hom.op
        (category_theory.eq_to_hom
          (eq.mpr
            (id
              (Eq._oldrec
                (Eq.refl
                  (category_theory.functor.obj (topological_space.opens.map g) (opposite.unop U) =
                    category_theory.functor.obj (topological_space.opens.map f) (opposite.unop U)))
                h))
            (Eq.refl (category_theory.functor.obj (topological_space.opens.map g) (opposite.unop U))))))) :=
  rfl

@[simp] theorem pushforward_eq_rfl {C : Type u} [category_theory.category C] {X : Top} {Y : Top} (f : X ⟶ Y) (ℱ : presheaf C X) (U : topological_space.opens ↥Y) : category_theory.nat_trans.app (category_theory.iso.hom (pushforward_eq rfl ℱ)) (opposite.op U) = 𝟙 := sorry

theorem pushforward_eq_eq {C : Type u} [category_theory.category C] {X : Top} {Y : Top} {f : X ⟶ Y} {g : X ⟶ Y} (h₁ : f = g) (h₂ : f = g) (ℱ : presheaf C X) : pushforward_eq h₁ ℱ = pushforward_eq h₂ ℱ :=
  rfl

namespace pushforward

def id {C : Type u} [category_theory.category C] {X : Top} (ℱ : presheaf C X) : 𝟙 _* ℱ ≅ ℱ :=
  category_theory.iso_whisker_right
      (category_theory.nat_iso.op (category_theory.iso.symm (topological_space.opens.map_id X))) ℱ ≪≫
    category_theory.functor.left_unitor ℱ

@[simp] theorem id_hom_app' {C : Type u} [category_theory.category C] {X : Top} (ℱ : presheaf C X) (U : set ↥X) (p : is_open U) : category_theory.nat_trans.app (category_theory.iso.hom (id ℱ)) (opposite.op { val := U, property := p }) =
  category_theory.functor.map ℱ 𝟙 := sorry

@[simp] theorem id_hom_app {C : Type u} [category_theory.category C] {X : Top} (ℱ : presheaf C X) (U : topological_space.opens ↥Xᵒᵖ) : category_theory.nat_trans.app (category_theory.iso.hom (id ℱ)) U =
  category_theory.functor.map ℱ (category_theory.eq_to_hom (topological_space.opens.op_map_id_obj U)) := sorry

@[simp] theorem id_inv_app' {C : Type u} [category_theory.category C] {X : Top} (ℱ : presheaf C X) (U : set ↥X) (p : is_open U) : category_theory.nat_trans.app (category_theory.iso.inv (id ℱ)) (opposite.op { val := U, property := p }) =
  category_theory.functor.map ℱ 𝟙 := sorry

def comp {C : Type u} [category_theory.category C] {X : Top} (ℱ : presheaf C X) {Y : Top} {Z : Top} (f : X ⟶ Y) (g : Y ⟶ Z) : (f ≫ g) _* ℱ ≅ g _* (f _* ℱ) :=
  category_theory.iso_whisker_right
    (category_theory.nat_iso.op (category_theory.iso.symm (topological_space.opens.map_comp f g))) ℱ

@[simp] theorem comp_hom_app {C : Type u} [category_theory.category C] {X : Top} (ℱ : presheaf C X) {Y : Top} {Z : Top} (f : X ⟶ Y) (g : Y ⟶ Z) (U : topological_space.opens ↥Zᵒᵖ) : category_theory.nat_trans.app (category_theory.iso.hom (comp ℱ f g)) U = 𝟙 := sorry

@[simp] theorem comp_inv_app {C : Type u} [category_theory.category C] {X : Top} (ℱ : presheaf C X) {Y : Top} {Z : Top} (f : X ⟶ Y) (g : Y ⟶ Z) (U : topological_space.opens ↥Zᵒᵖ) : category_theory.nat_trans.app (category_theory.iso.inv (comp ℱ f g)) U = 𝟙 := sorry

end pushforward

/--
A morphism of presheaves gives rise to a morphisms of the pushforwards of those presheaves.
-/
def pushforward_map {C : Type u} [category_theory.category C] {X : Top} {Y : Top} (f : X ⟶ Y) {ℱ : presheaf C X} {𝒢 : presheaf C X} (α : ℱ ⟶ 𝒢) : f _* ℱ ⟶ f _* 𝒢 :=
  category_theory.nat_trans.mk
    fun (U : topological_space.opens ↥Yᵒᵖ) =>
      category_theory.nat_trans.app α
        (category_theory.functor.obj (category_theory.functor.op (topological_space.opens.map f)) U)