import to_mathlib.analysis.inner_product_space.rotation
import to_mathlib.analysis.inner_product_space.dual
import local.parametric_h_principle

/-!
This is file proves the existence of a sphere eversion from the local verson of the h-principle.

We define the relation of immersions `R = immersion_sphere_rel ⊆ J¹(E, F)` which consist of all
`(x, y, ϕ)` such that if `x` is outside a ball around the origin with chosen radius `R < 1` then
`ϕ` must be injective on `(ℝ ∙ x)ᗮ` (the orthogonal complement of the span of `x`).
We show that `R` is open and ample.

Furthermore, we define a formal solution of sphere eversion that is holonomic near `0` and `1`.
We have to be careful since we're not actually working on the sphere,
but in the ambient space `E ≃ ℝ³`.
See `loc_formal_eversion` for the choice and constaints of the solution.

Finally, we obtain the existence of sphere eversion from the parametric local h-principle,
proven in `local.parametric_h_principle`.
-/
noncomputable theory

open metric finite_dimensional set function rel_loc filter (hiding mem_map) inner_product_space
  submodule linear_map (ker)
open_locale topology real_inner_product_space

section sphere_eversion

variables
{E : Type*} [normed_add_comm_group E] [inner_product_space ℝ E]
{F : Type*} [normed_add_comm_group F] [inner_product_space ℝ F]

local notation `𝕊²` := sphere (0 : E) 1
local notation `dim` := finrank ℝ
local notation `pr[`x`]ᗮ` := orthogonal_projection (ℝ ∙ x)ᗮ
local notation (name := dot_print_only) R ` ∙ `:1000 x := submodule.span R {x}
local notation (name := dot_local) R ` ∙ `:1000 x :=
  submodule.span R (@singleton _ _ set.has_singleton x)
local notation `B` := ball (0 : E) 0.9

/-- A map between vector spaces is a immersion viewed as a map on the sphere, when its
derivative at `x ∈ 𝕊²` is injective on the orthogonal complement of `x`
(the tangent space to the sphere). Note that this implies `f` is differentiable at every point
`x ∈ 𝕊²` since otherwise `D f x = 0`.
-/
def sphere_immersion (f : E → F) : Prop :=
∀ x ∈ 𝕊², inj_on (D f x) (ℝ ∙ x)ᗮ

variables (E F)

/-- The relation of immersionsof a two-sphere into its ambient Euclidean space. -/
def immersion_sphere_rel : rel_loc E F :=
{w : one_jet E F | w.1 ∉ B → inj_on w.2.2 (ℝ ∙ w.1)ᗮ }

local notation `R` := immersion_sphere_rel E F

variables {E F}

@[simp] lemma mem_loc_immersion_rel {x y φ} :
  (⟨x, y, φ⟩ : one_jet E F) ∈ immersion_sphere_rel E F ↔ x ∉ B → inj_on φ (ℝ ∙ x)ᗮ :=
iff.rfl

lemma sphere_immersion_of_sol (f : E → F) :
  (∀ x ∈ 𝕊², (x, f x, fderiv ℝ f x) ∈ immersion_sphere_rel E F) → sphere_immersion f :=
begin
  intros h x x_in,
  have : x ∉ B,
  { rw mem_sphere_zero_iff_norm at x_in,
    norm_num [x_in] },
  exact h x x_in this
end

lemma mem_slice_iff_of_not_mem {x : E} {w : F} {φ : E →L[ℝ] F} {p : dual_pair E}
  (hx : x ∉ B) (y : F) : w ∈ slice R p (x, y, φ) ↔ inj_on (p.update φ w) (ℝ ∙ x)ᗮ :=
begin
  change (x ∉ B → inj_on (p.update φ w) (ℝ ∙ x)ᗮ) ↔ inj_on (p.update φ w) (ℝ ∙ x)ᗮ,
  simp_rw [eq_true_intro hx, true_implies_iff]
end

section assume_finite_dimensional

variables [finite_dimensional ℝ E]

-- The following is extracted from `loc_immersion_rel_open` because it is slow to typecheck
lemma loc_immersion_rel_open_aux {x₀ : E} {y₀ : F} {φ₀ : E →L[ℝ] F} (hx₀ : x₀ ∉ B)
  (H : inj_on φ₀ (ℝ ∙ x₀)ᗮ) :
  ∀ᶠ (p : one_jet E F) in 𝓝 (x₀, y₀, φ₀), ⟪x₀, p.1⟫ ≠ 0 ∧
  injective ((p.2.2.comp $ (subtypeL (ℝ ∙ p.1)ᗮ).comp pr[p.1]ᗮ).comp (ℝ ∙ x₀)ᗮ.subtypeL) :=
begin
  -- This is true at (x₀, y₀, φ₀) and is an open condition because `p ↦ ⟪x₀, p.1⟫` and
  -- `p ↦ (p.2.2.comp $ (subtypeL (ℝ ∙ p.1)ᗮ).comp pr[p.1]ᗮ).comp j₀` are continuous
  set j₀ := subtypeL (ℝ ∙ x₀)ᗮ,
  let f : one_jet E F → ℝ × ((ℝ ∙ x₀)ᗮ →L[ℝ] F) :=
      λ p, (⟪x₀, p.1⟫, (p.2.2.comp $ (subtypeL (ℝ ∙ p.1)ᗮ).comp pr[p.1]ᗮ).comp j₀),
  let P : ℝ × ((ℝ ∙ x₀)ᗮ →L[ℝ] F) → Prop :=
      λ q, q.1 ≠ 0 ∧ injective q.2,
  have x₀_ne : x₀ ≠ 0,
  { refine λ hx₀', hx₀ _,
    rw hx₀',
    apply mem_ball_self,
    norm_num },
  -- The following suffices looks stupid but is much faster than using the change tactic.
  suffices : ∀ᶠ (p : one_jet E F) in 𝓝 (x₀, y₀, φ₀), P (f p), { exact this },
  apply continuous_at.eventually,
  { refine (continuous_at_const.inner continuous_at_fst).prod _,
    apply continuous_at.compL,
    { apply continuous_at.compL,
      exact continuous_at_snd.comp continuous_at_snd,
      -- Faster than change.
      suffices : continuous_at ((λ x, (ℝ ∙ x)ᗮ.subtypeL.comp pr[x]ᗮ) ∘ prod.fst) (x₀, y₀, φ₀),
      { exact this },
      apply continuous_at.comp _ continuous_at_fst,
      exact continuous_at_orthogonal_projection_orthogonal x₀_ne },
    exact continuous_at_const },
  { exact (continuous_fst.is_open_preimage _ is_open_compl_singleton).inter
          (continuous_snd.is_open_preimage _ continuous_linear_map.is_open_injective) },
  { split,
    { change ⟪x₀, x₀⟫ ≠ 0,
      apply (inner_self_eq_zero.not).mpr x₀_ne },
    { change injective (φ₀ ∘ (coe ∘ (pr[x₀]ᗮ ∘ coe))),
      rw [orthogonal_projection_comp_coe, comp.right_id],
      exact inj_on_iff_injective.mp H } }
end

lemma loc_immersion_rel_open : is_open (immersion_sphere_rel E F) :=
begin
  dsimp only [immersion_sphere_rel],
  rw is_open_iff_mem_nhds,
  rintros ⟨x₀, y₀, φ₀⟩ (H : x₀ ∉ B → inj_on φ₀ (ℝ ∙ x₀)ᗮ),
  change ∀ᶠ (p : one_jet E F) in 𝓝 (x₀, y₀, φ₀), _,
  by_cases hx₀ : x₀ ∈ B,
  { have : ∀ᶠ (p : one_jet E F) in 𝓝 (x₀, y₀, φ₀), p.1 ∈ B,
    { rw nhds_prod_eq,
      apply (is_open_ball.eventually_mem hx₀).prod_inl },
    apply this.mono,
    rintros ⟨x, y, φ⟩ (hx : x ∈ B) (Hx : x ∉ B),
    exact (Hx hx).elim },
  { replace H := H hx₀,
    set j₀ := subtypeL (ℝ ∙ x₀)ᗮ,
    let f : one_jet E F → ℝ × ((ℝ ∙ x₀)ᗮ →L[ℝ] F) :=
      λ p, (⟪x₀, p.1⟫, (p.2.2.comp $ (subtypeL (ℝ ∙ p.1)ᗮ).comp pr[p.1]ᗮ).comp j₀),
    let P : ℝ × ((ℝ ∙ x₀)ᗮ →L[ℝ] F) → Prop :=
      λ q, q.1 ≠ 0 ∧ injective q.2,
    have : ∀ᶠ (p : one_jet E F) in 𝓝 (x₀, y₀, φ₀), P (f p),
    { exact loc_immersion_rel_open_aux hx₀ H },
    apply this.mono, clear this,
    rintros ⟨x, y, φ⟩ ⟨hxx₀ : ⟪x₀, x⟫ ≠ 0, Hφ⟩ (hx : x ∉ B),
    dsimp only [P, f] at Hφ,
    change inj_on φ (ℝ ∙ x)ᗮ,
    have : range ((subtypeL (ℝ ∙ x)ᗮ) ∘ pr[x]ᗮ ∘ j₀) = (ℝ ∙ x)ᗮ,
    { rw function.surjective.range_comp,
      exact subtype.range_coe,
      exact (orthogonal_projection_orthogonal_line_iso hxx₀).surjective },
    rw ← this, clear this,
    exact function.injective.inj_on_range Hφ },
end

variables [finite_dimensional ℝ F]

-- In the next lemma the assumption `dim E = n + 1` is for convenience
-- using `finrank_orthogonal_span_singleton`. We could remove it to treat empty spheres...
lemma loc_immersion_rel_ample (n : ℕ) [fact (dim E = n+1)] (h : finrank ℝ E ≤ finrank ℝ F) :
  (immersion_sphere_rel E F).is_ample :=
begin
  classical, -- gives a minor speedup
  rw is_ample_iff,
  rintro ⟨x, y, φ⟩ p h_mem,
  by_cases hx : x ∈ B,
  { apply ample_slice_of_forall,
    intros w,
    simp only [hx, mem_loc_immersion_rel, not_true, is_empty.forall_iff] },
  have x_ne : x ≠ 0,
  { rintro rfl,
    apply hx,
    apply mem_ball_self,
    norm_num1 },
  have hφ : inj_on φ (ℝ ∙ x)ᗮ := h_mem hx, clear h_mem,
  let u : E := (inner_product_space.to_dual ℝ E).symm p.π,
  have u_ne : u ≠ 0,
  { exact (inner_product_space.to_dual ℝ E).symm.apply_ne_zero p.pi_ne_zero },
  by_cases H : ker p.π = (ℝ ∙ x)ᗮ,
  { have key : ∀ w, eq_on (p.update φ w) φ (ℝ ∙ x)ᗮ,
    { intros w x,
      rw ← H,
      exact p.update_ker_pi φ w },
    exact ample_slice_of_forall _ p (λ w _, hφ.congr (key w).symm) },
  obtain ⟨v', v'_in, hv', hπv'⟩ :
    ∃ v' : E, v' ∈ (ℝ ∙ x)ᗮ ∧ (ℝ ∙ x)ᗮ = (ker p.π ⊓ (ℝ ∙ x)ᗮ) ⊔ (ℝ ∙ v') ∧ p.π v' = 1,
  { have ne_z : p.π (pr[x]ᗮ u) ≠ 0,
    { rw ← to_dual_symm_apply,
      change ¬ ⟪u, pr[x]ᗮ u⟫ = 0,
      rw inner_projection_self_eq_zero_iff.not,
      contrapose! H,
      rw orthogonal_orthogonal at H,
      rw [← orthogonal_span_to_dual_symm, span_singleton_eq_span_singleton_of_ne u_ne H],
      apply_instance },
    have ne_z' : (p.π $ pr[x]ᗮ u)⁻¹ ≠ 0,
    { exact inv_ne_zero ne_z },
    refine ⟨(p.π $ pr[x]ᗮ u)⁻¹ • pr[x]ᗮ u, (ℝ ∙ x)ᗮ.smul_mem _ (pr[x]ᗮ u).2, _, _⟩,
    { have := orthogonal_line_inf_sup_line u x,
      rw [← orthogonal_span_to_dual_symm p.π,
        span_singleton_smul_eq ne_z'.is_unit],
      exact (orthogonal_line_inf_sup_line u x).symm },
    rw [p.π.map_smul, smul_eq_mul, inv_mul_cancel ne_z] },
  let p' : dual_pair E := { π := p.π, v := v', pairing := hπv' },
  apply ample_slice_of_ample_slice (show p'.π = p.π, from rfl),
  suffices : slice R p' (x, y, φ) = (map φ (ker p.π ⊓ (ℝ ∙ x)ᗮ))ᶜ,
  { rw [this],
    apply ample_of_two_le_codim,
    let Φ := φ.to_linear_map,
    suffices : 2 ≤ dim (F ⧸ map Φ (ker p.π ⊓ (ℝ ∙ x)ᗮ)),
    { rw ← finrank_eq_dim,
      exact_mod_cast this },
    apply le_of_add_le_add_right,
    rw submodule.finrank_quotient_add_finrank (map Φ $ ker p.π ⊓ (ℝ ∙ x)ᗮ),
    have : dim (ker p.π ⊓ (ℝ ∙ x)ᗮ : submodule ℝ E) + 1 = n,
    { have eq := submodule.dim_sup_add_dim_inf_eq (ker p.π ⊓ (ℝ ∙ x)ᗮ) (span ℝ {v'}),
      have eq₁ : dim (ℝ ∙ x)ᗮ = n, from finrank_orthogonal_span_singleton x_ne,
      have eq₂ : ker p.π ⊓ (ℝ ∙ x)ᗮ ⊓ span ℝ {v'} = (⊥ : submodule ℝ E),
      { erw [inf_left_right_swap, inf_comm, ← inf_assoc, p'.inf_eq_bot, bot_inf_eq] },
      have eq₃ : dim (span ℝ {v'}) = 1, apply finrank_span_singleton p'.v_ne_zero,
      rw [← hv', eq₁, eq₃, eq₂] at eq,
      simpa only [finrank_bot] using eq.symm },
    have : dim E = n+1, from fact.out _,
    linarith [finrank_map_le ℝ Φ (ker p.π ⊓ (ℝ ∙ x)ᗮ)] },
  ext w,
  rw mem_slice_iff_of_not_mem hx y,
  rw inj_on_iff_injective,
  let j := (ℝ ∙ x)ᗮ.subtypeL,
  let p'' : dual_pair (ℝ ∙ x)ᗮ := ⟨p.π.comp j, ⟨v', v'_in⟩, hπv'⟩,
  have eq : ((ℝ ∙ x)ᗮ : set E).restrict (p'.update φ w) = (p''.update (φ.comp j) w),
  { ext z,
    simp only [dual_pair.update, restrict_apply, continuous_linear_map.add_apply,
      continuous_linear_map.coe_comp', coe_subtypeL', submodule.coe_subtype, comp_app, coe_mk] },
  have eq' : map (φ.comp j) (ker p''.π) = map φ (ker p.π ⊓ (ℝ ∙ x)ᗮ),
  { have : map ↑j (ker p''.π) = ker p.π ⊓ (ℝ ∙ x)ᗮ,
    { ext z,
      simp only [mem_map, linear_map.mem_ker, continuous_linear_map.coe_comp',
                coe_subtypeL', submodule.coe_subtype, comp_app, mem_inf],
      split,
      { rintros ⟨t, ht, rfl⟩,
        rw [continuous_linear_map.coe_coe, subtypeL_apply],
        exact ⟨ht, t.2⟩ },
      { rintros ⟨hz, z_in⟩,
        exact ⟨⟨z, z_in⟩, hz, rfl⟩ }, },
    erw [← this, map_comp],
    refl },
  rw [eq, p''.injective_update_iff, mem_compl_iff, eq'],
  exact iff.rfl,
  rw ← show ((ℝ ∙ x)ᗮ : set E).restrict φ = φ.comp j, by { ext, refl },
  exact hφ.injective
end

end assume_finite_dimensional

/-- The main ingredient of the linear map in the formal eversion of the sphere. -/
def loc_formal_eversion_aux_φ [fact (dim E = 3)] (ω : orientation ℝ E (fin 3))
  (t : ℝ) (x : E) : E →L[ℝ] E :=
ω.rot (t, x) - (2 * t) • (submodule.subtypeL (ℝ ∙ x) ∘L orthogonal_projection (ℝ ∙ x))

section assume_finite_dimensional

variables [fact (dim E = 3)] [finite_dimensional ℝ E] (ω : orientation ℝ E (fin 3))

lemma smooth_at_loc_formal_eversion_aux_φ {p : ℝ × E} (hx : p.2 ≠ 0) :
  cont_diff_at ℝ ∞ (uncurry (loc_formal_eversion_aux_φ ω)) p :=
begin
  refine (ω.cont_diff_rot hx).sub _,
  refine cont_diff_at.smul (cont_diff_at_const.mul cont_diff_at_fst) _,
  exact (cont_diff_at_orthogonal_projection_singleton hx).comp p cont_diff_at_snd
end

/-- A formal eversion of `𝕊²`, viewed as a homotopy. -/
def loc_formal_eversion_aux : htpy_jet_sec E E :=
{ f := λ (t : ℝ) (x : E), (1 - 2 * smooth_step t) • x,
  φ := λ t x, smooth_step (‖x‖ ^ 2) • loc_formal_eversion_aux_φ ω (smooth_step t) x,
  f_diff := cont_diff.smul (cont_diff_const.sub $ cont_diff_const.mul $
    smooth_step.smooth.comp cont_diff_fst) cont_diff_snd,
  φ_diff := begin
    refine cont_diff_iff_cont_diff_at.mpr (λ x, _),
    cases eq_or_ne x.2 0 with hx hx,
    { refine cont_diff_at_const.congr_of_eventually_eq _, exact 0,
      have : ((λ x, ‖x‖ ^ 2) ⁻¹' Iio (1/4)) ∈ 𝓝 (0 : E),
      { refine is_open.mem_nhds _ _,
        exact (is_open_Iio.preimage (cont_diff_norm_sq ℝ : 𝒞 ∞ _).continuous),
        simp_rw [mem_preimage, norm_zero, zero_pow two_pos, mem_Iio],
        norm_num },
      have : ((λ x, smooth_step (‖x‖ ^ 2)) ⁻¹' {0}) ∈ 𝓝 (0 : E),
      { refine mem_of_superset this _,
        rw @preimage_comp _ _ _ _ smooth_step,
        refine preimage_mono _,
        intros x hx,
        rw [mem_preimage, mem_singleton_iff, smooth_step.of_lt hx] },
      have : ((λ p : ℝ × E, smooth_step (‖p.2‖ ^ 2)) ⁻¹' {0}) ∈ 𝓝 x,
      { rw [← hx] at this, exact continuous_at_snd.preimage_mem_nhds this },
      refine eventually_of_mem this _,
      rintro ⟨t, x⟩ hx,
      simp_rw [mem_preimage, mem_singleton_iff] at hx,
      show smooth_step (‖x‖ ^ 2) • loc_formal_eversion_aux_φ ω (smooth_step t) x = 0,
      simp_rw [hx, zero_smul] },
    refine cont_diff_at.smul _ _,
    refine (smooth_step.smooth.comp $ (cont_diff_norm_sq ℝ).comp cont_diff_snd).cont_diff_at,
    exact (smooth_at_loc_formal_eversion_aux_φ ω
      (show (prod.map smooth_step id x).2 ≠ 0, from hx)).comp x
      (smooth_step.smooth.prod_map cont_diff_id).cont_diff_at,
     end }

/-- A formal eversion of `𝕊²` into its ambient Euclidean space.
The corresponding map `E → E` is roughly a linear homotopy from `id` at `t = 0` to `- id` at
`t = 1`. The continuous linear maps are roughly rotations with angle `t * π`. However, we have to
keep track of a few complications:
* We need the formal solution to be holonomic near `0` and `1`.
  Therefore, we compose the above maps with a smooth step function that is constant `0` near `t = 0`
  and constant `1` near `t = 1`.
* We need to modify the derivative of `ω.rot` to also have the right behavior on `(ℝ ∙ x)`
  at `t = 1` (it is the identity, but it should be `-id`). Therefore, we subtract
  `(2 * t) • (submodule.subtypeL (ℝ ∙ x) ∘L orthogonal_projection (ℝ ∙ x))`,
  which is `2t` times the identity on `(ℝ ∙ x)`.
* We have to make sure the family of continuous linear map is smooth at `x = 0`. Therefore, we
  multiply the family with a factor of `smooth_step (‖x‖ ^ 2)`.
-/
def loc_formal_eversion : htpy_formal_sol (immersion_sphere_rel E E) :=
{ is_sol := begin
    intros t x,
    change x ∉ B →
      inj_on (smooth_step (‖x‖ ^ 2) • loc_formal_eversion_aux_φ ω (smooth_step t) x) (ℝ ∙ x)ᗮ,
    intros hx,
    have h2x : smooth_step (‖x‖ ^ 2) = 1,
    { refine smooth_step.of_gt _,
      rw [mem_ball, not_lt, dist_zero_right] at hx,
      refine (show (3 : ℝ)/4 < 0.9 ^ 2, by norm_num).trans_le _,
      rwa [sq_le_sq, show |(0.9 : ℝ)| = 0.9, by norm_num, abs_norm_eq_norm] },
    rw [h2x, one_smul],
    have h3x : x ≠ 0,
    { rintro rfl, apply hx, exact mem_ball_self (by norm_num) },
    refine (eq_on.inj_on_iff _).mpr (ω.inj_on_rot_of_ne (smooth_step t) h3x),
    intros v hv,
    simp_rw [loc_formal_eversion_aux_φ, continuous_linear_map.sub_apply,
      continuous_linear_map.smul_apply, continuous_linear_map.comp_apply,
      orthogonal_projection_mem_subspace_orthogonal_complement_eq_zero hv,
      _root_.map_zero, smul_zero, sub_zero],
  end,
  .. loc_formal_eversion_aux ω }

@[simp]
lemma loc_formal_eversion_f (t : ℝ) :
  (loc_formal_eversion ω t).f = λ x : E, ((1 : ℝ) - 2 * smooth_step t) • x :=
rfl

lemma loc_formal_eversion_φ (t : ℝ) (x : E) (v : E) :
  (loc_formal_eversion ω t).φ x v = smooth_step (‖x‖ ^ 2) •
    (ω.rot (smooth_step t, x) v -
    (2 * smooth_step t) • orthogonal_projection (ℝ ∙ x) v) :=
rfl

lemma loc_formal_eversion_zero (x : E) : (loc_formal_eversion ω 0).f x = x :=
by simp

lemma loc_formal_eversion_one (x : E) : (loc_formal_eversion ω 1).f x = -x :=
by simp [show (1 : ℝ) - 2 = -1, by norm_num]

lemma loc_formal_eversion_hol_at_zero {t : ℝ} (ht : t < 1/4) {x : E}
  (hx : smooth_step (‖x‖ ^ 2) = 1) : (loc_formal_eversion ω t).is_holonomic_at x :=
by simp_rw [jet_sec.is_holonomic_at, loc_formal_eversion_f, continuous_linear_map.ext_iff,
    loc_formal_eversion_φ, smooth_step.of_lt ht, hx, ω.rot_zero, mul_zero, zero_smul, sub_zero,
    show (has_smul.smul (1 : ℝ) : E → E) = id, from funext (one_smul ℝ), fderiv_id, function.id_def,
    eq_self_iff_true, implies_true_iff]

lemma loc_formal_eversion_hol_at_one {t : ℝ} (ht : 3/4 < t) {x : E}
  (hx : smooth_step (‖x‖ ^ 2) = 1) : (loc_formal_eversion ω t).is_holonomic_at x :=
begin
  simp_rw [jet_sec.is_holonomic_at, loc_formal_eversion_f, continuous_linear_map.ext_iff,
    loc_formal_eversion_φ, smooth_step.of_gt ht, hx],
  intro v,
  simp_rw [mul_one, show (1 : ℝ) - 2 = -1, by norm_num,
    show (has_smul.smul (-1 : ℝ) : E → E) = λ x, - x, from funext (λ v, by rw [neg_smul, one_smul]),
    fderiv_neg, fderiv_id', continuous_linear_map.neg_apply, continuous_linear_map.id_apply],
  obtain ⟨v', hv', v, hv, rfl⟩ := submodule.exists_sum_mem_mem_orthogonal (ℝ ∙ x) v,
  simp_rw [continuous_linear_map.map_add, ω.rot_one _ hv, ω.rot_eq_of_mem_span (1, x) hv'],
  simp_rw [neg_add, submodule.coe_add, orthogonal_projection_eq_self_iff.mpr hv',
    orthogonal_projection_mem_subspace_orthogonal_complement_eq_zero hv, submodule.coe_zero,
    add_zero, two_smul, one_smul],
  abel
end

lemma loc_formal_eversion_hol :
  ∀ᶠ (p : ℝ × E) near {0, 1} ×ˢ 𝕊², (loc_formal_eversion ω p.1).is_holonomic_at p.2 :=
begin
  have : (Iio (1/4 : ℝ) ∪ Ioi (3/4)) ×ˢ ((λ x, ‖x‖ ^ 2) ⁻¹' Ioi (3/4)) ∈
    𝓝ˢ (({0, 1} : set ℝ) ×ˢ 𝕊²),
  { refine (is_open.mem_nhds_set _).mpr _,
    exact (is_open_Iio.union is_open_Ioi).prod
      (is_open_Ioi.preimage (cont_diff_norm_sq ℝ : 𝒞 ∞ _).continuous),
    rintro ⟨s, x⟩ ⟨hs, hx⟩,
    refine ⟨_, _⟩,
    simp_rw [mem_insert_iff, mem_singleton_iff] at hs,
    rcases hs with rfl|rfl,
    exact or.inl (show (0 : ℝ) < 1 / 4, by norm_num),
    exact or.inr (show (3 / 4 : ℝ) < 1, by norm_num),
    simp_rw [mem_sphere_zero_iff_norm] at hx,
    simp_rw [mem_preimage, hx, one_pow, mem_Ioi],
    norm_num },
  have : (Iio (1/4 : ℝ) ∪ Ioi (3/4)) ×ˢ ((λ x, smooth_step (‖x‖ ^ 2)) ⁻¹' {1}) ∈
    𝓝ˢ (({0, 1} : set ℝ) ×ˢ 𝕊²),
  { refine mem_of_superset this (prod_mono subset.rfl _),
    rw @preimage_comp _ _ _ _ smooth_step,
    refine preimage_mono _,
    intros x hx,
    rw [mem_preimage, mem_singleton_iff, smooth_step.of_gt hx] },
  refine eventually_of_mem this _,
  rintro ⟨t, x⟩ ⟨ht|ht, hx⟩,
  { exact loc_formal_eversion_hol_at_zero ω ht hx },
  { exact loc_formal_eversion_hol_at_one ω ht hx }
end

end assume_finite_dimensional

open_locale unit_interval

theorem sphere_eversion_of_loc [fact (dim E = 3)] :
  ∃ f : ℝ → E → E,
  (𝒞 ∞ ↿f) ∧
  (∀ x ∈ 𝕊², f 0 x = x) ∧
  (∀ x ∈ 𝕊², f 1 x = -x) ∧
  ∀ t ∈ I, sphere_immersion (f t) :=
begin
  classical,
  borelize E,
  have rankE := fact.out (dim E = 3),
  haveI : finite_dimensional ℝ E := finite_dimensional_of_finrank_eq_succ rankE,
  let ω : orientation ℝ E (fin 3) :=
    ((std_orthonormal_basis _ _).reindex $ fin_congr (fact.out _ : dim E = 3)).to_basis.orientation,
  have is_closed_pair : is_closed ({0, 1} : set ℝ) :=
  (by simp : ({0, 1} : set ℝ).finite).is_closed,
  obtain ⟨f, h₁, h₂, h₃⟩ :=
    (loc_formal_eversion ω).exists_sol loc_immersion_rel_open (loc_immersion_rel_ample 2 le_rfl)
    ({0, 1} ×ˢ 𝕊²) (is_closed_pair.prod is_closed_sphere) 𝕊² (is_compact_sphere 0 1)
    (loc_formal_eversion_hol ω),
  refine ⟨f, h₁, _, _, _⟩,
  { intros x hx, rw [h₂ (0, x) (mk_mem_prod (by simp) hx), loc_formal_eversion_zero] },
  { intros x hx, rw [h₂ (1, x) (mk_mem_prod (by simp) hx), loc_formal_eversion_one] },
  { exact λ t ht, sphere_immersion_of_sol _ (λ x hx, h₃ x hx t ht) },
end

/- Stating the full statement with all type-class arguments and no uncommon notation. -/
example (E : Type*) [normed_add_comm_group E] [inner_product_space ℝ E] [fact (finrank ℝ E = 3)] :
  ∃ f : ℝ → E → E,
  (cont_diff ℝ ⊤ (uncurry f)) ∧
  (∀ x ∈ sphere (0 : E) 1, f 0 x = x) ∧
  (∀ x ∈ sphere (0 : E) 1, f 1 x = -x) ∧
  ∀ t ∈ unit_interval, sphere_immersion (f t) :=
sphere_eversion_of_loc

end sphere_eversion


universes u v

inductive Imf {α : Type u} {β : Type v} (f : α → β) : β → Type (max u v)
| mk : (a : α) → Imf f (f a)

def h {α β} {f : α → β} : {b : β} → Imf f b → α
| _, Imf.mk a => a

#print h

theorem ex : ∀ {α β : Sort u} (h : α = β) (a : α), cast h a ≅ a
  | α, _, rfl, a => HEq.refl a

#print ex


/-
Copyright (c) 2019 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/
import algebra.group.type_tags
import algebra.hom.equiv.basic
import algebra.hom.ring
import algebra.hom.units

/-!
# Unbundled monoid and group homomorphisms

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

This file is deprecated, and is no longer imported by anything in mathlib other than other
deprecated files, and test files. You should not need to import it.

This file defines predicates for unbundled monoid and group homomorphisms. Instead of using
this file, please use `monoid_hom`, defined in `algebra.hom.group`, with notation `→*`, for
morphisms between monoids or groups. For example use `φ : G →* H` to represent a group
homomorphism between multiplicative groups, and `ψ : A →+ B` to represent a group homomorphism
between additive groups.

## Main Definitions

`is_monoid_hom` (deprecated), `is_group_hom` (deprecated)

## Tags

is_group_hom, is_monoid_hom

-/

universes u v
variables {α : Type u} {β : Type v}

/-- Predicate for maps which preserve an addition. -/
structure is_add_hom {α β : Type*} [has_add α] [has_add β] (f : α → β) : Prop :=
(map_add [] : ∀ x y, f (x + y) = f x + f y)

/-- Predicate for maps which preserve a multiplication. -/
@[to_additive]
structure is_mul_hom {α β : Type*} [has_mul α] [has_mul β] (f : α → β) : Prop :=
(map_mul [] : ∀ x y, f (x * y) = f x * f y)

namespace is_mul_hom
variables [has_mul α] [has_mul β] {γ : Type*} [has_mul γ]

/-- The identity map preserves multiplication. -/
@[to_additive "The identity map preserves addition"]
lemma id : is_mul_hom (id : α → α) := {map_mul := λ _ _, rfl}

/-- The composition of maps which preserve multiplication, also preserves multiplication. -/
@[to_additive "The composition of addition preserving maps also preserves addition"]
lemma comp {f : α → β} {g : β → γ} (hf : is_mul_hom f) (hg : is_mul_hom g) : is_mul_hom (g ∘ f) :=
{ map_mul := λ x y, by simp only [function.comp, hf.map_mul, hg.map_mul] }

/-- A product of maps which preserve multiplication,
preserves multiplication when the target is commutative. -/
@[to_additive "A sum of maps which preserves addition, preserves addition when the target
is commutative."]
lemma mul {α β} [semigroup α] [comm_semigroup β]
  {f g : α → β} (hf : is_mul_hom f) (hg : is_mul_hom g) :
  is_mul_hom (λ a, f a * g a) :=
{ map_mul := λ a b, by simp only [hf.map_mul, hg.map_mul, mul_comm, mul_assoc, mul_left_comm] }

/-- The inverse of a map which preserves multiplication,
preserves multiplication when the target is commutative. -/
@[to_additive "The negation of a map which preserves addition, preserves addition when
the target is commutative."]
lemma inv {α β} [has_mul α] [comm_group β] {f : α → β} (hf : is_mul_hom f) :
  is_mul_hom (λ a, (f a)⁻¹) :=
{ map_mul := λ a b, (hf.map_mul a b).symm ▸ mul_inv _ _ }

end is_mul_hom

/-- Predicate for add_monoid homomorphisms (deprecated -- use the bundled `monoid_hom` version). -/
structure is_add_monoid_hom [add_zero_class α] [add_zero_class β] (f : α → β)
  extends is_add_hom f : Prop :=
(map_zero [] : f 0 = 0)

/-- Predicate for monoid homomorphisms (deprecated -- use the bundled `monoid_hom` version). -/
@[to_additive]
structure is_monoid_hom [mul_one_class α] [mul_one_class β] (f : α → β)
  extends is_mul_hom f : Prop :=
(map_one [] : f 1 = 1)

namespace monoid_hom

variables {M : Type*} {N : Type*} [mM : mul_one_class M] [mN : mul_one_class N]

include mM mN
/-- Interpret a map `f : M → N` as a homomorphism `M →* N`. -/
@[to_additive "Interpret a map `f : M → N` as a homomorphism `M →+ N`."]
def of {f : M → N} (h : is_monoid_hom f) : M →* N :=
{ to_fun := f,
  map_one' := h.2,
  map_mul' := h.1.1 }

variables {mM mN}
@[simp, to_additive]
lemma coe_of {f : M → N} (hf : is_monoid_hom f) : ⇑ (monoid_hom.of hf) = f :=
rfl

@[to_additive]

end monoid_hom

namespace mul_equiv

variables {M : Type*} {N : Type*} [mul_one_class M] [mul_one_class N]

/-- A multiplicative isomorphism preserves multiplication (deprecated). -/
@[to_additive "An additive isomorphism preserves addition (deprecated)."]
theorem is_mul_hom (h : M ≃* N) : is_mul_hom h := ⟨h.map_mul⟩

/-- A multiplicative bijection between two monoids is a monoid hom
  (deprecated -- use `mul_equiv.to_monoid_hom`). -/
@[to_additive "An additive bijection between two additive monoids is an additive
monoid hom (deprecated). "]
lemma is_monoid_hom (h : M ≃* N) : is_monoid_hom h :=
{ map_mul := h.map_mul,
  map_one := h.map_one }

end mul_equiv

namespace is_monoid_hom
variables [mul_one_class α] [mul_one_class β] {f : α → β} (hf : is_monoid_hom f)

/-- A monoid homomorphism preserves multiplication. -/
@[to_additive "An additive monoid homomorphism preserves addition."]
lemma map_mul (x y) : f (x * y) = f x * f y :=
hf.map_mul x y

/-- The inverse of a map which preserves multiplication,
preserves multiplication when the target is commutative. -/
@[to_additive "The negation of a map which preserves addition, preserves addition
when the target is commutative."]
lemma inv {α β} [mul_one_class α] [comm_group β] {f : α → β} (hf : is_monoid_hom f) :
  is_monoid_hom (λ a, (f a)⁻¹) :=
{ map_one := hf.map_one.symm ▸ inv_one,
  map_mul := λ a b, (hf.map_mul a b).symm ▸ mul_inv _ _ }

end is_monoid_hom

/-- A map to a group preserving multiplication is a monoid homomorphism. -/
@[to_additive "A map to an additive group preserving addition is an additive monoid
homomorphism."]
theorem is_mul_hom.to_is_monoid_hom [mul_one_class α] [group β] {f : α → β} (hf : is_mul_hom f) :
  is_monoid_hom f :=
{ map_one := mul_right_eq_self.1 $ by rw [← hf.map_mul, one_mul],
  map_mul := hf.map_mul }

namespace is_monoid_hom
variables [mul_one_class α] [mul_one_class β] {f : α → β}

/-- The identity map is a monoid homomorphism. -/
@[to_additive "The identity map is an additive monoid homomorphism."]
lemma id : is_monoid_hom (@id α) := { map_one := rfl, map_mul := λ _ _, rfl }

/-- The composite of two monoid homomorphisms is a monoid homomorphism. -/
@[to_additive "The composite of two additive monoid homomorphisms is an additive monoid
homomorphism."]
lemma comp (hf : is_monoid_hom f) {γ} [mul_one_class γ] {g : β → γ} (hg : is_monoid_hom g) :
  is_monoid_hom (g ∘ f) :=
{ map_one := show g _ = 1, by rw [hf.map_one, hg.map_one],
  ..is_mul_hom.comp hf.to_is_mul_hom hg.to_is_mul_hom }

end is_monoid_hom

namespace is_add_monoid_hom

/-- Left multiplication in a ring is an additive monoid morphism. -/
lemma is_add_monoid_hom_mul_left {γ : Type*} [non_unital_non_assoc_semiring γ] (x : γ) :
  is_add_monoid_hom (λ y : γ, x * y) :=
{ map_zero := mul_zero x, map_add := λ y z, mul_add x y z }

/-- Right multiplication in a ring is an additive monoid morphism. -/
lemma is_add_monoid_hom_mul_right {γ : Type*} [non_unital_non_assoc_semiring γ] (x : γ) :
  is_add_monoid_hom (λ y : γ, y * x) :=
{ map_zero := zero_mul x, map_add := λ y z, add_mul y z x }

end is_add_monoid_hom

/-- Predicate for additive group homomorphism (deprecated -- use bundled `monoid_hom`). -/
structure is_add_group_hom [add_group α] [add_group β] (f : α → β) extends is_add_hom f : Prop

/-- Predicate for group homomorphisms (deprecated -- use bundled `monoid_hom`). -/
@[to_additive]
structure is_group_hom [group α] [group β] (f : α → β) extends is_mul_hom f : Prop

@[to_additive]
lemma monoid_hom.is_group_hom {G H : Type*} {_ : group G} {_ : group H} (f : G →* H) :
  is_group_hom (f : G → H) :=
{ map_mul := f.map_mul }

@[to_additive]
lemma mul_equiv.is_group_hom {G H : Type*} {_ : group G} {_ : group H} (h : G ≃* H) :
  is_group_hom h := { map_mul := h.map_mul }

/-- Construct `is_group_hom` from its only hypothesis. -/
@[to_additive "Construct `is_add_group_hom` from its only hypothesis."]
lemma is_group_hom.mk' [group α] [group β] {f : α → β} (hf : ∀ x y, f (x * y) = f x * f y) :
  is_group_hom f :=
{ map_mul := hf }

namespace is_group_hom
variables [group α] [group β] {f : α → β} (hf : is_group_hom f)
open is_mul_hom (map_mul)

lemma map_mul : ∀ (x y), f (x * y) = f x * f y := hf.to_is_mul_hom.map_mul

/-- A group homomorphism is a monoid homomorphism. -/
@[to_additive "An additive group homomorphism is an additive monoid homomorphism."]
lemma to_is_monoid_hom : is_monoid_hom f :=
hf.to_is_mul_hom.to_is_monoid_hom

/-- A group homomorphism sends 1 to 1. -/
@[to_additive "An additive group homomorphism sends 0 to 0."]
lemma map_one : f 1 = 1 := hf.to_is_monoid_hom.map_one

/-- A group homomorphism sends inverses to inverses. -/
@[to_additive "An additive group homomorphism sends negations to negations."]
theorem map_inv (hf : is_group_hom f) (a : α) : f a⁻¹ = (f a)⁻¹ :=
eq_inv_of_mul_eq_one_left $ by rw [← hf.map_mul, inv_mul_self, hf.map_one]

@[to_additive] lemma map_div (hf : is_group_hom f) (a b : α) : f (a / b) = f a / f b :=
by simp_rw [div_eq_mul_inv, hf.map_mul, hf.map_inv]

/-- The identity is a group homomorphism. -/
@[to_additive "The identity is an additive group homomorphism."]
lemma id : is_group_hom (@id α) := { map_mul := λ _ _, rfl}

/-- The composition of two group homomorphisms is a group homomorphism. -/
@[to_additive "The composition of two additive group homomorphisms is an additive
group homomorphism."]
lemma comp (hf : is_group_hom f) {γ} [group γ] {g : β → γ} (hg : is_group_hom g) :
  is_group_hom (g ∘ f) :=
{ ..is_mul_hom.comp hf.to_is_mul_hom hg.to_is_mul_hom }

/-- A group homomorphism is injective iff its kernel is trivial. -/
@[to_additive "An additive group homomorphism is injective if its kernel is trivial."]
lemma injective_iff {f : α → β} (hf : is_group_hom f) :
  function.injective f ↔ (∀ a, f a = 1 → a = 1) :=
⟨λ h _, by rw ← hf.map_one; exact @h _ _,
  λ h x y hxy, eq_of_div_eq_one $ h _ $ by rwa [hf.map_div, div_eq_one]⟩

/-- The product of group homomorphisms is a group homomorphism if the target is commutative. -/
@[to_additive "The sum of two additive group homomorphisms is an additive group homomorphism
if the target is commutative."]
lemma mul {α β} [group α] [comm_group β]
  {f g : α → β} (hf : is_group_hom f) (hg : is_group_hom g) :
  is_group_hom (λa, f a * g a) :=
{ map_mul := (hf.to_is_mul_hom.mul hg.to_is_mul_hom).map_mul }

/-- The inverse of a group homomorphism is a group homomorphism if the target is commutative. -/
@[to_additive "The negation of an additive group homomorphism is an additive group homomorphism
if the target is commutative."]
lemma inv {α β} [group α] [comm_group β] {f : α → β} (hf : is_group_hom f) :
  is_group_hom (λa, (f a)⁻¹) :=
{ map_mul := hf.to_is_mul_hom.inv.map_mul }

end is_group_hom

namespace ring_hom
/-!
These instances look redundant, because `deprecated.ring` provides `is_ring_hom` for a `→+*`.
Nevertheless these are harmless, and helpful for stripping out dependencies on `deprecated.ring`.
-/
variables {R : Type*} {S : Type*}

section
variables [non_assoc_semiring R] [non_assoc_semiring S]

lemma to_is_monoid_hom (f : R →+* S) : is_monoid_hom f :=
{ map_one := f.map_one,
  map_mul := f.map_mul }

lemma to_is_add_monoid_hom (f : R →+* S) : is_add_monoid_hom f :=
{ map_zero := f.map_zero,
  map_add := f.map_add }
end

section
variables [ring R] [ring S]

lemma to_is_add_group_hom (f : R →+* S) : is_add_group_hom f :=
{ map_add := f.map_add }
end

end ring_hom

/-- Inversion is a group homomorphism if the group is commutative. -/
@[to_additive neg.is_add_group_hom
"Negation is an `add_group` homomorphism if the `add_group` is commutative."]
lemma inv.is_group_hom [comm_group α] : is_group_hom (has_inv.inv : α → α) :=
{ map_mul := mul_inv }

/-- The difference of two additive group homomorphisms is an additive group
homomorphism if the target is commutative. -/
lemma is_add_group_hom.sub {α β} [add_group α] [add_comm_group β]
  {f g : α → β} (hf : is_add_group_hom f) (hg : is_add_group_hom g) :
  is_add_group_hom (λa, f a - g a) :=
by simpa only [sub_eq_add_neg] using hf.add hg.neg

namespace units

variables {M : Type*} {N : Type*} [monoid M] [monoid N]

/-- The group homomorphism on units induced by a multiplicative morphism. -/
@[reducible] def map' {f : M → N} (hf : is_monoid_hom f) : Mˣ →* Nˣ :=
  map (monoid_hom.of hf)

@[simp] lemma coe_map' {f : M → N} (hf : is_monoid_hom f) (x : Mˣ) :
  ↑((map' hf : Mˣ → Nˣ) x) = f x :=
rfl

lemma coe_is_monoid_hom : is_monoid_hom (coe : Mˣ → M) := (coe_hom M).is_monoid_hom_coe

end units

namespace is_unit

variables {M : Type*} {N : Type*} [monoid M] [monoid N] {x : M}

lemma map' {f : M → N} (hf :is_monoid_hom f) {x : M} (h : is_unit x) :
  is_unit (f x) :=
h.map (monoid_hom.of hf)

end is_unit

lemma additive.is_add_hom [has_mul α] [has_mul β] {f : α → β} (hf : is_mul_hom f) :
  @is_add_hom (additive α) (additive β) _ _ f :=
{ map_add := is_mul_hom.map_mul hf }

lemma multiplicative.is_mul_hom [has_add α] [has_add β] {f : α → β} (hf : is_add_hom f) :
  @is_mul_hom (multiplicative α) (multiplicative β) _ _ f :=
{ map_mul := is_add_hom.map_add hf }

-- defeq abuse
lemma additive.is_add_monoid_hom [mul_one_class α] [mul_one_class β] {f : α → β}
  (hf : is_monoid_hom f) : @is_add_monoid_hom (additive α) (additive β) _ _ f :=
{ map_zero := hf.map_one,
  ..additive.is_add_hom hf.to_is_mul_hom }

lemma multiplicative.is_monoid_hom
  [add_zero_class α] [add_zero_class β] {f : α → β} (hf : is_add_monoid_hom f) :
  @is_monoid_hom (multiplicative α) (multiplicative β) _ _ f :=
{ map_one := is_add_monoid_hom.map_zero hf,
  ..multiplicative.is_mul_hom hf.to_is_add_hom }

lemma additive.is_add_group_hom [group α] [group β] {f : α → β} (hf : is_group_hom f) :
  @is_add_group_hom (additive α) (additive β) _ _ f :=
{ map_add := hf.to_is_mul_hom.map_mul }

lemma multiplicative.is_group_hom [add_group α] [add_group β] {f : α → β}
  (hf : is_add_group_hom f) : @is_group_hom (multiplicative α) (multiplicative β) _ _ f :=
{ map_mul := hf.to_is_add_hom.map_add }


import tactic.equiv_rw
import data.equiv.basic

variables {α β : Sort*}

lemma equiv.exists_congr_left' {p : α → Prop} (f : α ≃ β) :
  (∃x, p x) ↔ (∃y, p (f.symm y)) :=
⟨λ ⟨x, h⟩, ⟨f x, by rwa f.symm_apply_apply⟩, λ ⟨y, h⟩, ⟨f.symm y, h⟩⟩

lemma equiv.exists_congr_left {p : β → Prop} (f : α ≃ β) :
  (∃x, p (f x)) ↔ (∃y, p y) :=
f.symm.exists_congr_left'.symm


def OrderDual (α : Type u) : Type u := α

variable (α : Type u) [LE α] {a b : α}
instance : LE (OrderDual α) := ⟨fun x y : α => y ≤ x⟩

theorem foo' (c : α) : a ≤ b := sorry

example : a ≤ b :=
  foo' (OrderDual α) a

theorem foo : a ≤ b := sorry

example : a ≤ b :=
  foo (OrderDual α)


import data.real.basic

open set

lemma mem_Icc_iff {x a b : ℝ} : x ∈ Icc a b ↔ a ≤ x ∧ x ≤ b := iff.rfl


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl

A collection of specific limit computations.
-/
import analysis.normed_space.basic
import topology.instances.ennreal

noncomputable theory
local attribute [instance] classical.prop_decidable

open classical function lattice filter finset metric

variables {α : Type*} {β : Type*} {ι : Type*}

lemma has_sum_of_absolute_convergence_real {f : ℕ → ℝ} :
  (∃r, tendsto (λn, (range n).sum (λi, abs (f i))) at_top (nhds r)) → has_sum f
| ⟨r, hr⟩ :=
  begin
    refine has_sum_of_has_sum_norm ⟨r, (is_sum_iff_tendsto_nat_of_nonneg _ _).2 _⟩,
    exact assume i, norm_nonneg _,
    simpa only using hr
  end

lemma tendsto_pow_at_top_at_top_of_gt_1 {r : ℝ} (h : r > 1) : tendsto (λn:ℕ, r ^ n) at_top at_top :=
tendsto_infi.2 $ assume p, tendsto_principal.2 $
  let ⟨n, hn⟩ := exists_nat_gt (p / (r - 1)) in
  have hn_nn : (0:ℝ) ≤ n, from nat.cast_nonneg n,
  have r - 1 > 0, from sub_lt_iff_lt_add.mp $ by simp; assumption,
  have p ≤ r ^ n,
    from calc p = (p / (r - 1)) * (r - 1) : (div_mul_cancel _ $ ne_of_gt this).symm
      ... ≤ n * (r - 1) : mul_le_mul (le_of_lt hn) (le_refl _) (le_of_lt this) hn_nn
      ... ≤ 1 + n * (r - 1) : le_add_of_nonneg_of_le zero_le_one (le_refl _)
      ... = 1 + add_monoid.smul n (r - 1) : by rw [add_monoid.smul_eq_mul]
      ... ≤ (1 + (r - 1)) ^ n : pow_ge_one_add_mul (le_of_lt this) _
      ... ≤ r ^ n : by simp; exact le_refl _,
  show {n | p ≤ r ^ n} ∈ at_top,
    from mem_at_top_sets.mpr ⟨n, assume m hnm, le_trans this (pow_le_pow (le_of_lt h) hnm)⟩

lemma tendsto_inverse_at_top_nhds_0 : tendsto (λr:ℝ, r⁻¹) at_top (nhds 0) :=
tendsto_orderable_unbounded (no_top 0) (no_bot 0) $ assume l u hl hu,
  mem_at_top_sets.mpr ⟨u⁻¹ + 1, assume b hb,
    have u⁻¹ < b, from lt_of_lt_of_le (lt_add_of_pos_right _ zero_lt_one) hb,
    ⟨lt_trans hl $ inv_pos $ lt_trans (inv_pos hu) this,
    lt_of_one_div_lt_one_div hu $
    begin
      rw [inv_eq_one_div],
      simp [-one_div_eq_inv, div_div_eq_mul_div, div_one],
      simp [this]
    end⟩⟩

lemma tendsto_pow_at_top_nhds_0_of_lt_1 {r : ℝ} (h₁ : 0 ≤ r) (h₂ : r < 1) :
  tendsto (λn:ℕ, r^n) at_top (nhds 0) :=
by_cases
  (assume : r = 0, (tendsto_add_at_top_iff_nat 1).mp $ by simp [pow_succ, this, tendsto_const_nhds])
  (assume : r ≠ 0,
    have tendsto (λn, (r⁻¹ ^ n)⁻¹) at_top (nhds 0),
      from (tendsto_pow_at_top_at_top_of_gt_1 $ one_lt_inv (lt_of_le_of_ne h₁ this.symm) h₂).comp
        tendsto_inverse_at_top_nhds_0,
    tendsto.congr' (univ_mem_sets' $ by simp *) this)

lemma tendsto_pow_at_top_at_top_of_gt_1_nat {k : ℕ} (h : 1 < k) :
  tendsto (λn:ℕ, k ^ n) at_top at_top :=
tendsto_coe_nat_real_at_top_iff.1 $
  have hr : 1 < (k : ℝ), by rw [← nat.cast_one, nat.cast_lt]; exact h,
  by simpa using tendsto_pow_at_top_at_top_of_gt_1 hr

lemma tendsto_inverse_at_top_nhds_0_nat : tendsto (λ n : ℕ, (n : ℝ)⁻¹) at_top (nhds 0) :=
tendsto.comp (tendsto_coe_nat_real_at_top_iff.2 tendsto_id) tendsto_inverse_at_top_nhds_0

lemma tendsto_one_div_at_top_nhds_0_nat : tendsto (λ n : ℕ, 1/(n : ℝ)) at_top (nhds 0) :=
by simpa only [inv_eq_one_div] using tendsto_inverse_at_top_nhds_0_nat

lemma tendsto_one_div_add_at_top_nhds_0_nat :
  tendsto (λ n : ℕ, 1 / ((n : ℝ) + 1)) at_top (nhds 0) :=
suffices tendsto (λ n : ℕ, 1 / (↑(n + 1) : ℝ)) at_top (nhds 0), by simpa,
(tendsto_add_at_top_iff_nat 1).2 tendsto_one_div_at_top_nhds_0_nat

lemma is_sum_geometric {r : ℝ} (h₁ : 0 ≤ r) (h₂ : r < 1) :
  is_sum (λn:ℕ, r ^ n) (1 / (1 - r)) :=
have r ≠ 1, from ne_of_lt h₂,
have r + -1 ≠ 0,
  by rw [←sub_eq_add_neg, ne, sub_eq_iff_eq_add]; simp; assumption,
have tendsto (λn, (r ^ n - 1) * (r - 1)⁻¹) at_top (nhds ((0 - 1) * (r - 1)⁻¹)),
  from tendsto_mul
    (tendsto_sub (tendsto_pow_at_top_nhds_0_of_lt_1 h₁ h₂) tendsto_const_nhds) tendsto_const_nhds,
(is_sum_iff_tendsto_nat_of_nonneg (pow_nonneg h₁) _).mpr $
  by simp [neg_inv, geom_sum, div_eq_mul_inv, *] at *

lemma is_sum_geometric_two (a : ℝ) : is_sum (λn:ℕ, (a / 2) / 2 ^ n) a :=
begin
  convert is_sum_mul_left (a / 2) (is_sum_geometric
    (le_of_lt one_half_pos) one_half_lt_one),
  { funext n, simp,
    rw ← pow_inv; [refl, exact two_ne_zero] },
  { norm_num, rw div_mul_cancel _ two_ne_zero }
end

def pos_sum_of_encodable {ε : ℝ} (hε : 0 < ε)
  (ι) [encodable ι] : {ε' : ι → ℝ // (∀ i, 0 < ε' i) ∧ ∃ c, is_sum ε' c ∧ c ≤ ε} :=
begin
  let f := λ n, (ε / 2) / 2 ^ n,
  have hf : is_sum f ε := is_sum_geometric_two _,
  have f0 : ∀ n, 0 < f n := λ n, div_pos (half_pos hε) (pow_pos two_pos _),
  refine ⟨f ∘ encodable.encode, λ i, f0 _, _⟩,
  rcases has_sum_comp_of_has_sum_of_injective f (has_sum_spec hf) (@encodable.encode_injective ι _)
    with ⟨c, hg⟩,
  refine ⟨c, hg, is_sum_le_inj _ (@encodable.encode_injective ι _) _ _ hg hf⟩,
  { assume i _, exact le_of_lt (f0 _) },
  { assume n, exact le_refl _ }
end

lemma cauchy_seq_of_le_geometric [metric_space α] (r C : ℝ) (hr : r < 1) {f : ℕ → α}
  (hu : ∀n, dist (f n) (f (n+1)) ≤ C * r^n) : cauchy_seq f :=
begin
  refine cauchy_seq_of_has_sum_dist (has_sum_of_norm_bounded (λn, C * r^n) _ _),
  { by_cases h : C = 0,
    { simp [h, has_sum_zero] },
    { have Cpos : C > 0,
      { have := le_trans dist_nonneg (hu 0),
        simp only [mul_one, pow_zero] at this,
        exact lt_of_le_of_ne this (ne.symm h) },
      have rnonneg: r ≥ 0,
      { have := le_trans dist_nonneg (hu 1),
        simp only [pow_one] at this,
        exact nonneg_of_mul_nonneg_left this Cpos },
      refine has_sum_mul_left C _,
      exact has_sum_spec (@is_sum_geometric r rnonneg hr) }},
  show ∀n, abs (dist (f n) (f (n+1))) ≤ C * r^n,
  { assume n, rw abs_of_nonneg (dist_nonneg), exact hu n }
end

namespace nnreal

theorem exists_pos_sum_of_encodable {ε : nnreal} (hε : 0 < ε) (ι) [encodable ι] :
  ∃ ε' : ι → nnreal, (∀ i, 0 < ε' i) ∧ ∃c, is_sum ε' c ∧ c < ε :=
let ⟨a, a0, aε⟩ := dense hε in
let ⟨ε', hε', c, hc, hcε⟩ := pos_sum_of_encodable a0 ι in
⟨ λi, ⟨ε' i, le_of_lt $ hε' i⟩, assume i, nnreal.coe_lt.2 $ hε' i,
  ⟨c, is_sum_le (assume i, le_of_lt $ hε' i) is_sum_zero hc ⟩, nnreal.is_sum_coe.1 hc,
   lt_of_le_of_lt (nnreal.coe_le.1 hcε) aε ⟩

end nnreal

namespace ennreal

theorem exists_pos_sum_of_encodable {ε : ennreal} (hε : 0 < ε) (ι) [encodable ι] :
  ∃ ε' : ι → nnreal, (∀ i, 0 < ε' i) ∧ (∑ i, (ε' i : ennreal)) < ε :=
begin
  rcases dense hε with ⟨r, h0r, hrε⟩,
  rcases lt_iff_exists_coe.1 hrε with ⟨x, rfl, hx⟩,
  rcases nnreal.exists_pos_sum_of_encodable (coe_lt_coe.1 h0r) ι with ⟨ε', hp, c, hc, hcr⟩,
  exact ⟨ε', hp, (ennreal.tsum_coe_eq hc).symm ▸ lt_trans (coe_lt_coe.2 hcr) hrε⟩
end

end ennreal


inductive ty : Type
| unit : ty
| bool : ty
| arrow : ty -> ty -> ty

def nm := string

inductive tm : Type
| var : nm -> tm
| unit : tm
| true : tm
| false : tm
| app : tm -> tm -> tm
| lam : nm -> tm -> tm
| if_then_else : tm -> tm -> tm -> tm

inductive value : tm -> Prop
| unit : value tm.unit
| true : value tm.true
| false : value tm.false
| lam {x e} : value (tm.lam x e)

def subst : nm -> tm -> tm -> tm
| x e (tm.var y) :=
    if x = y then e else tm.var y
| x e tm.unit :=
    tm.unit
| x e tm.true :=
    tm.true
| x e tm.false :=
    tm.false
| x e (tm.app e1 e2) :=
    tm.app (subst x e e1) (subst x e e2)
| x e (tm.lam y e') :=
    if x = y then tm.lam y e' else tm.lam y (subst x e e')
| x e (tm.if_then_else e' e1 e2) :=
    tm.if_then_else (subst x e e') (subst x e e1) (subst x e e2)

inductive step : tm -> tm -> Prop
| app1 {e1 e1' e2} :
    step e1 e1' ->
    step (tm.app e1 e2) (tm.app e1' e2)
| app2 {v1 e2 e2'} :
    value v1 ->
    step e2 e2' ->
    step (tm.app v1 e2) (tm.app v1 e2')
| app_beta {x e1 v2} :
    value v2 ->
    step (tm.app (tm.lam x e1) v2) (subst x v2 e1)
| if_then_else {e e' e1 e2} :
    step e e' ->
    step (tm.if_then_else e e1 e2) (tm.if_then_else e' e1 e2)
| if_true {e1 e2} :
    step (tm.if_then_else tm.true e1 e2) e1
| if_false {e1 e2} :
    step (tm.if_then_else tm.false e1 e2) e2

inductive ctx : Type
| nil : ctx
| cons : nm -> ty -> ctx -> ctx

inductive lookup : nm -> ctx -> ty -> Prop
| here {x A Γ} :
    lookup x (ctx.cons x A Γ) A
| there {x y A B Γ} :
    x ≠ y ->
    lookup x Γ A ->
    lookup x (ctx.cons y B Γ) A

inductive of : ctx -> tm -> ty -> Prop
| var {x Γ A} :
    lookup x Γ A ->
    of Γ (tm.var x) A
| unit {Γ} :
    of Γ tm.unit ty.unit
| true {Γ} :
    of Γ tm.true ty.bool
| false {Γ} :
    of Γ tm.false ty.bool
| app {Γ e1 e2 A B} :
    of Γ e1 (ty.arrow A B) ->
    of Γ e2 A ->
    of Γ (tm.app e1 e2) B
| lam {Γ x e A B} :
    of (ctx.cons x A Γ) e B ->
    of Γ (tm.lam x e) (ty.arrow A B)
| if_then_else {Γ e e1 e2 A} :
    of Γ e ty.bool ->
    of Γ e1 A ->
    of Γ e2 A ->
    of Γ (tm.if_then_else e e1 e2) A

theorem substitution {Γ x A e e' A'} :
    of Γ e A
    -> of (ctx.cons x A Γ) e' A'
    -> of Γ (subst x e e') A'
:=
begin
  intros H,
  generalize ctx_cons : (ctx.cons x A Γ) = Γ',
  intros H',
  induction H',
  repeat {simp},
  case of.var {
      rewrite <- ctx_cons at H'_a,
      unfold subst,
      cases H'_a,
      case lookup.here {
        simp,
        assumption
      },
      case lookup.there {
        by_cases (x = H'_x),
          have H := (ne.symm H'_a_a), contradiction,
          simp [h], apply of.var, assumption
      }
  },
  case of.unit {
      apply of.unit
  },
  case of.true {
      apply of.true
  },
  case of.false {
      apply of.false
  },
  case of.app {
      apply of.app,
      apply H'_ih_a ctx_cons,
      apply H'_ih_a_1 ctx_cons
  },
  case of.if_then_else {
      apply of.if_then_else,
      apply H'_ih_a ctx_cons,
      apply H'_ih_a_1 ctx_cons,
      apply H'_ih_a_2 ctx_cons
  },
  case of.lam {
      unfold subst,
      by_cases (x = H'_x),
        simp [h], apply of.lam, sorry,
        simp [h], apply of.lam, sorry
  },
end

theorem preservation {e e'} :
    step e e' ->
    forall {Γ A}, of Γ e A ->
    of Γ e' A
:=
begin
    intros Hstep,
    induction Hstep,
    repeat {intros Γ A Hof},
    case step.app_beta {
        cases Hof,
        cases Hof_a,
        apply substitution Hof_a_1 Hof_a_a
    },
    case step.app1 {
        cases Hof,
        apply of.app,
        apply Hstep_ih Hof_a,
        apply Hof_a_1
    },
    case step.app2 {
        cases Hof,
        apply of.app,
        apply Hof_a,
        apply Hstep_ih Hof_a_1
    },
    case step.if_then_else {
        cases Hof,
        apply of.if_then_else,
        apply Hstep_ih Hof_a,
        apply Hof_a_1,
        apply Hof_a_2
    },
    case step.if_true {
        cases Hof,
        apply Hof_a_1
    },
    case step.if_false {
        cases Hof,
        apply Hof_a_2
    }
end

theorem progress {e A} :
    of ctx.nil e A ->
    (value e) ∨ (exists e', step e e')
:=
begin
    generalize empty : ctx.nil = Γ,
    intros H,
    induction H,
    case of.var {
        rewrite ←empty at H_a,
        cases H_a
    },
    case of.unit {
        left,
        exact value.unit
    },
    case of.app {
        cases H_ih_a empty,
        case or.inl {
            cases H_a,
            case of.var
                {rw ←empty at H_a_a, cases H_a_a},
            case of.app
                {cases h},
            case of.lam {
                cases H_ih_a_1 empty,
                right,
                existsi (subst H_a_x H_e2 H_a_e),
                apply step.app_beta,
                assumption,
                right,
                cases h_1,
                existsi (tm.app (tm.lam H_a_x H_a_e) h_1_w),
                eapply step.app2,
                exact value.lam,
                assumption
            },
            case of.if_then_else {
                cases h
            }
        },
        case or.inr {
            cases h with e H_step,
            right,
            existsi (tm.app e H_e2),
            apply step.app1,
            assumption
        }
    },
    case of.lam {
        left,
        exact value.lam
    },
    case of.true {
        left,
        exact value.true
    },
    case of.false {
        left,
        exact value.false
    },
    case of.if_then_else {
        cases H_ih_a empty,
        case or.inl {
            cases H_a,
            case of.var {
                rw ←empty at H_a_a,
                cases H_a_a
            },
            case of.true {
                right,
                existsi H_e1,
                exact step.if_true
            },
            case of.false {
                right,
                existsi H_e2,
                exact step.if_false
            },
            cases h,
            cases h
        },
        case or.inr {
            cases h,
            right,
            existsi (tm.if_then_else h_w H_e1 H_e2),
            exact (step.if_then_else h_h),
        }
    }
end


/-
Copyright (c) 2022 Junyan Xu. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Junyan Xu

! This file was ported from Lean 3 source module data.finsupp.well_founded
! leanprover-community/mathlib commit 290a7ba01fbcab1b64757bdaa270d28f4dcede35
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Dfinsupp.WellFounded
import Mathbin.Data.Finsupp.Lex

/-!
# Well-foundedness of the lexicographic and product orders on `finsupp`

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

`finsupp.lex.well_founded` and the two variants that follow it essentially say that if
`(>)` is a well order on `α`, `(<)` is well-founded on `N`, and `0` is a bottom element in `N`,
then the lexicographic `(<)` is well-founded on `α →₀ N`.

`finsupp.lex.well_founded_lt_of_finite` says that if `α` is finite and equipped with a linear
order and `(<)` is well-founded on `N`, then the lexicographic `(<)` is well-founded on `α →₀ N`.

`finsupp.well_founded_lt` and `well_founded_lt_of_finite` state the same results for the product
order `(<)`, but without the ordering conditions on `α`.

All results are transferred from `dfinsupp` via `finsupp.to_dfinsupp`.
-/

variable {α N : Type _}

namespace Finsupp

variable [hz : Zero N] {r : α → α → Prop} {s : N → N → Prop} (hbot : ∀ ⦃n⦄, ¬s n 0)
  (hs : WellFounded s)

include hbot hs

/- warning: finsupp.lex.acc -> Finsupp.Lex.acc is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {N : Type.{u2}} [hz : Zero.{u2} N] {r : α -> α -> Prop} {s : N -> N -> Prop}, (forall {{n : N}}, Not (s n (OfNat.ofNat.{u2} N 0 (OfNat.mk.{u2} N 0 (Zero.zero.{u2} N hz))))) -> (WellFounded.{succ u2} N s) -> (forall (x : Finsupp.{u1, u2} α N hz), (forall (a : α), (Membership.Mem.{u1, u1} α (Finset.{u1} α) (Finset.hasMem.{u1} α) a (Finsupp.support.{u1, u2} α N hz x)) -> (Acc.{succ u1} α (Inf.inf.{u1} (α -> α -> Prop) (Pi.hasInf.{u1, u1} α (fun (ᾰ : α) => α -> Prop) (fun (i : α) => Pi.hasInf.{u1, 0} α (fun (ᾰ : α) => Prop) (fun (i : α) => SemilatticeInf.toHasInf.{0} Prop (Lattice.toSemilatticeInf.{0} Prop (ConditionallyCompleteLattice.toLattice.{0} Prop (CompleteLattice.toConditionallyCompleteLattice.{0} Prop Prop.completeLattice)))))) (HasCompl.compl.{u1} (α -> α -> Prop) (Pi.hasCompl.{u1, u1} α (fun (ᾰ : α) => α -> Prop) (fun (i : α) => Pi.hasCompl.{u1, 0} α (fun (ᾰ : α) => Prop) (fun (i : α) => Prop.hasCompl))) r) (Ne.{succ u1} α)) a)) -> (Acc.{max (succ u1) (succ u2)} (Finsupp.{u1, u2} α N hz) (Finsupp.Lex.{u1, u2} α N hz r s) x))
but is expected to have type
  forall {α : Type.{u2}} {N : Type.{u1}} [hz : Zero.{u1} N] {r : α -> α -> Prop} {s : N -> N -> Prop}, (forall {{n : N}}, Not (s n (OfNat.ofNat.{u1} N 0 (Zero.toOfNat0.{u1} N hz)))) -> (WellFounded.{succ u1} N s) -> (forall (x : Finsupp.{u2, u1} α N hz), (forall (a : α), (Membership.mem.{u2, u2} α (Finset.{u2} α) (Finset.instMembershipFinset.{u2} α) a (Finsupp.support.{u2, u1} α N hz x)) -> (Acc.{succ u2} α (Inf.inf.{u2} (α -> α -> Prop) (Pi.instInfForAll.{u2, u2} α (fun (ᾰ : α) => α -> Prop) (fun (i : α) => Pi.instInfForAll.{u2, 0} α (fun (ᾰ : α) => Prop) (fun (i : α) => Lattice.toInf.{0} Prop (ConditionallyCompleteLattice.toLattice.{0} Prop (ConditionallyCompleteLinearOrder.toConditionallyCompleteLattice.{0} Prop (ConditionallyCompleteLinearOrderBot.toConditionallyCompleteLinearOrder.{0} Prop (CompleteLinearOrder.toConditionallyCompleteLinearOrderBot.{0} Prop Prop.completeLinearOrder))))))) (HasCompl.compl.{u2} (α -> α -> Prop) (Pi.hasCompl.{u2, u2} α (fun (ᾰ : α) => α -> Prop) (fun (i : α) => Pi.hasCompl.{u2, 0} α (fun (ᾰ : α) => Prop) (fun (i : α) => Prop.hasCompl))) r) (fun (x._@.Mathlib.Data.Finsupp.WellFounded._hyg.102 : α) (x._@.Mathlib.Data.Finsupp.WellFounded._hyg.104 : α) => Ne.{succ u2} α x._@.Mathlib.Data.Finsupp.WellFounded._hyg.102 x._@.Mathlib.Data.Finsupp.WellFounded._hyg.104)) a)) -> (Acc.{max (succ u1) (succ u2)} (Finsupp.{u2, u1} α N hz) (Finsupp.Lex.{u2, u1} α N hz r s) x))
Case conversion may be inaccurate. Consider using '#align finsupp.lex.acc Finsupp.Lex.accₓ'. -/
/-- Transferred from `dfinsupp.lex.acc`. See the top of that file for an explanation for the
  appearance of the relation `rᶜ ⊓ (≠)`. -/
theorem Lex.acc (x : α →₀ N) (h : ∀ a ∈ x.support, Acc (rᶜ ⊓ (· ≠ ·)) a) :
    Acc (Finsupp.Lex r s) x := by
  rw [lex_eq_inv_image_dfinsupp_lex]
  classical
    refine' InvImage.accessible to_dfinsupp (Dfinsupp.Lex.acc (fun a => hbot) (fun a => hs) _ _)
    simpa only [toDfinsupp_support] using h
#align finsupp.lex.acc Finsupp.Lex.acc

/- warning: finsupp.lex.well_founded -> Finsupp.Lex.wellFounded is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {N : Type.{u2}} [hz : Zero.{u2} N] {r : α -> α -> Prop} {s : N -> N -> Prop}, (forall {{n : N}}, Not (s n (OfNat.ofNat.{u2} N 0 (OfNat.mk.{u2} N 0 (Zero.zero.{u2} N hz))))) -> (WellFounded.{succ u2} N s) -> (WellFounded.{succ u1} α (Inf.inf.{u1} (α -> α -> Prop) (Pi.hasInf.{u1, u1} α (fun (ᾰ : α) => α -> Prop) (fun (i : α) => Pi.hasInf.{u1, 0} α (fun (ᾰ : α) => Prop) (fun (i : α) => SemilatticeInf.toHasInf.{0} Prop (Lattice.toSemilatticeInf.{0} Prop (ConditionallyCompleteLattice.toLattice.{0} Prop (CompleteLattice.toConditionallyCompleteLattice.{0} Prop Prop.completeLattice)))))) (HasCompl.compl.{u1} (α -> α -> Prop) (Pi.hasCompl.{u1, u1} α (fun (ᾰ : α) => α -> Prop) (fun (i : α) => Pi.hasCompl.{u1, 0} α (fun (ᾰ : α) => Prop) (fun (i : α) => Prop.hasCompl))) r) (Ne.{succ u1} α))) -> (WellFounded.{max (succ u1) (succ u2)} (Finsupp.{u1, u2} α N hz) (Finsupp.Lex.{u1, u2} α N hz r s))
but is expected to have type
  forall {α : Type.{u2}} {N : Type.{u1}} [hz : Zero.{u1} N] {r : α -> α -> Prop} {s : N -> N -> Prop}, (forall {{n : N}}, Not (s n (OfNat.ofNat.{u1} N 0 (Zero.toOfNat0.{u1} N hz)))) -> (WellFounded.{succ u1} N s) -> (WellFounded.{succ u2} α (Inf.inf.{u2} (α -> α -> Prop) (Pi.instInfForAll.{u2, u2} α (fun (ᾰ : α) => α -> Prop) (fun (i : α) => Pi.instInfForAll.{u2, 0} α (fun (ᾰ : α) => Prop) (fun (i : α) => Lattice.toInf.{0} Prop (ConditionallyCompleteLattice.toLattice.{0} Prop (ConditionallyCompleteLinearOrder.toConditionallyCompleteLattice.{0} Prop (ConditionallyCompleteLinearOrderBot.toConditionallyCompleteLinearOrder.{0} Prop (CompleteLinearOrder.toConditionallyCompleteLinearOrderBot.{0} Prop Prop.completeLinearOrder))))))) (HasCompl.compl.{u2} (α -> α -> Prop) (Pi.hasCompl.{u2, u2} α (fun (ᾰ : α) => α -> Prop) (fun (i : α) => Pi.hasCompl.{u2, 0} α (fun (ᾰ : α) => Prop) (fun (i : α) => Prop.hasCompl))) r) (fun (x._@.Mathlib.Data.Finsupp.WellFounded._hyg.228 : α) (x._@.Mathlib.Data.Finsupp.WellFounded._hyg.230 : α) => Ne.{succ u2} α x._@.Mathlib.Data.Finsupp.WellFounded._hyg.228 x._@.Mathlib.Data.Finsupp.WellFounded._hyg.230))) -> (WellFounded.{max (succ u1) (succ u2)} (Finsupp.{u2, u1} α N hz) (Finsupp.Lex.{u2, u1} α N hz r s))
Case conversion may be inaccurate. Consider using '#align finsupp.lex.well_founded Finsupp.Lex.wellFoundedₓ'. -/
theorem Lex.wellFounded (hr : WellFounded <| rᶜ ⊓ (· ≠ ·)) : WellFounded (Finsupp.Lex r s) :=
  ⟨fun x => Lex.acc hbot hs x fun a _ => hr.apply a⟩
#align finsupp.lex.well_founded Finsupp.Lex.wellFounded

/- warning: finsupp.lex.well_founded' -> Finsupp.Lex.wellFounded' is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {N : Type.{u2}} [hz : Zero.{u2} N] {r : α -> α -> Prop} {s : N -> N -> Prop}, (forall {{n : N}}, Not (s n (OfNat.ofNat.{u2} N 0 (OfNat.mk.{u2} N 0 (Zero.zero.{u2} N hz))))) -> (WellFounded.{succ u2} N s) -> (forall [_inst_1 : IsTrichotomous.{u1} α r], (WellFounded.{succ u1} α (Function.swap.{succ u1, succ u1, 1} α α (fun (ᾰ : α) (ᾰ : α) => Prop) r)) -> (WellFounded.{max (succ u1) (succ u2)} (Finsupp.{u1, u2} α N hz) (Finsupp.Lex.{u1, u2} α N hz r s)))
but is expected to have type
  forall {α : Type.{u2}} {N : Type.{u1}} [hz : Zero.{u1} N] {r : α -> α -> Prop} {s : N -> N -> Prop}, (forall {{n : N}}, Not (s n (OfNat.ofNat.{u1} N 0 (Zero.toOfNat0.{u1} N hz)))) -> (WellFounded.{succ u1} N s) -> (forall [_inst_1 : IsTrichotomous.{u2} α r], (WellFounded.{succ u2} α (Function.swap.{succ u2, succ u2, 1} α α (fun (ᾰ : α) (ᾰ : α) => Prop) r)) -> (WellFounded.{max (succ u1) (succ u2)} (Finsupp.{u2, u1} α N hz) (Finsupp.Lex.{u2, u1} α N hz r s)))
Case conversion may be inaccurate. Consider using '#align finsupp.lex.well_founded' Finsupp.Lex.wellFounded'ₓ'. -/
theorem Lex.wellFounded' [IsTrichotomous α r] (hr : WellFounded r.symm) :
    WellFounded (Finsupp.Lex r s) :=
  (lex_eq_invImage_dfinsupp_lex r s).symm ▸
    InvImage.wf _ (Dfinsupp.Lex.wellFounded' (fun a => hbot) (fun a => hs) hr)
#align finsupp.lex.well_founded' Finsupp.Lex.wellFounded'

omit hbot hs

/- warning: finsupp.lex.well_founded_lt -> Finsupp.Lex.wellFoundedLT is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {N : Type.{u2}} [_inst_1 : LT.{u1} α] [_inst_2 : IsTrichotomous.{u1} α (LT.lt.{u1} α _inst_1)] [hα : WellFoundedGT.{u1} α _inst_1] [_inst_3 : CanonicallyOrderedAddMonoid.{u2} N] [hN : WellFoundedLT.{u2} N (Preorder.toLT.{u2} N (PartialOrder.toPreorder.{u2} N (OrderedAddCommMonoid.toPartialOrder.{u2} N (CanonicallyOrderedAddMonoid.toOrderedAddCommMonoid.{u2} N _inst_3))))], WellFoundedLT.{max u1 u2} (Lex.{max u1 u2} (Finsupp.{u1, u2} α N (AddZeroClass.toHasZero.{u2} N (AddMonoid.toAddZeroClass.{u2} N (AddCommMonoid.toAddMonoid.{u2} N (OrderedAddCommMonoid.toAddCommMonoid.{u2} N (CanonicallyOrderedAddMonoid.toOrderedAddCommMonoid.{u2} N _inst_3))))))) (Finsupp.Lex.hasLt.{u1, u2} α N (AddZeroClass.toHasZero.{u2} N (AddMonoid.toAddZeroClass.{u2} N (AddCommMonoid.toAddMonoid.{u2} N (OrderedAddCommMonoid.toAddCommMonoid.{u2} N (CanonicallyOrderedAddMonoid.toOrderedAddCommMonoid.{u2} N _inst_3))))) _inst_1 (Preorder.toLT.{u2} N (PartialOrder.toPreorder.{u2} N (OrderedAddCommMonoid.toPartialOrder.{u2} N (CanonicallyOrderedAddMonoid.toOrderedAddCommMonoid.{u2} N _inst_3)))))
but is expected to have type
  forall {α : Type.{u1}} {N : Type.{u2}} [_inst_1 : LT.{u1} α] [_inst_2 : IsTrichotomous.{u1} α (fun (x._@.Mathlib.Data.Finsupp.WellFounded._hyg.381 : α) (x._@.Mathlib.Data.Finsupp.WellFounded._hyg.383 : α) => LT.lt.{u1} α _inst_1 x._@.Mathlib.Data.Finsupp.WellFounded._hyg.381 x._@.Mathlib.Data.Finsupp.WellFounded._hyg.383)] [hα : WellFoundedGT.{u1} α _inst_1] [_inst_3 : CanonicallyOrderedAddMonoid.{u2} N] [hN : WellFoundedLT.{u2} N (Preorder.toLT.{u2} N (PartialOrder.toPreorder.{u2} N (OrderedAddCommMonoid.toPartialOrder.{u2} N (CanonicallyOrderedAddMonoid.toOrderedAddCommMonoid.{u2} N _inst_3))))], WellFoundedLT.{max u2 u1} (Lex.{max u2 u1} (Finsupp.{u1, u2} α N (AddMonoid.toZero.{u2} N (AddCommMonoid.toAddMonoid.{u2} N (OrderedAddCommMonoid.toAddCommMonoid.{u2} N (CanonicallyOrderedAddMonoid.toOrderedAddCommMonoid.{u2} N _inst_3)))))) (Finsupp.instLTLexFinsupp.{u1, u2} α N (AddMonoid.toZero.{u2} N (AddCommMonoid.toAddMonoid.{u2} N (OrderedAddCommMonoid.toAddCommMonoid.{u2} N (CanonicallyOrderedAddMonoid.toOrderedAddCommMonoid.{u2} N _inst_3)))) _inst_1 (Preorder.toLT.{u2} N (PartialOrder.toPreorder.{u2} N (OrderedAddCommMonoid.toPartialOrder.{u2} N (CanonicallyOrderedAddMonoid.toOrderedAddCommMonoid.{u2} N _inst_3)))))
Case conversion may be inaccurate. Consider using '#align finsupp.lex.well_founded_lt Finsupp.Lex.wellFoundedLTₓ'. -/
instance Lex.wellFoundedLT [LT α] [IsTrichotomous α (· < ·)] [hα : WellFoundedGT α]
    [CanonicallyOrderedAddMonoid N] [hN : WellFoundedLT N] : WellFoundedLT (Lex (α →₀ N)) :=
  ⟨Lex.wellFounded' (fun n => (zero_le n).not_lt) hN.wf hα.wf⟩
#align finsupp.lex.well_founded_lt Finsupp.Lex.wellFoundedLT

variable (r)

/- warning: finsupp.lex.well_founded_of_finite -> Finsupp.Lex.wellFounded_of_finite is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {N : Type.{u2}} (r : α -> α -> Prop) {s : N -> N -> Prop} [_inst_1 : IsStrictTotalOrder.{u1} α r] [_inst_2 : Finite.{succ u1} α] [_inst_3 : Zero.{u2} N], (WellFounded.{succ u2} N s) -> (WellFounded.{max (succ u1) (succ u2)} (Finsupp.{u1, u2} α N _inst_3) (Finsupp.Lex.{u1, u2} α N _inst_3 r s))
but is expected to have type
  forall {α : Type.{u2}} {N : Type.{u1}} (r : α -> α -> Prop) {s : N -> N -> Prop} [_inst_1 : IsStrictTotalOrder.{u2} α r] [_inst_2 : Finite.{succ u2} α] [_inst_3 : Zero.{u1} N], (WellFounded.{succ u1} N s) -> (WellFounded.{max (succ u1) (succ u2)} (Finsupp.{u2, u1} α N _inst_3) (Finsupp.Lex.{u2, u1} α N _inst_3 r s))
Case conversion may be inaccurate. Consider using '#align finsupp.lex.well_founded_of_finite Finsupp.Lex.wellFounded_of_finiteₓ'. -/
theorem Lex.wellFounded_of_finite [IsStrictTotalOrder α r] [Finite α] [Zero N]
    (hs : WellFounded s) : WellFounded (Finsupp.Lex r s) :=
  InvImage.wf (@equivFunOnFinite α N _ _) (Pi.Lex.wellFounded r fun a => hs)
#align finsupp.lex.well_founded_of_finite Finsupp.Lex.wellFounded_of_finite

/- warning: finsupp.lex.well_founded_lt_of_finite -> Finsupp.Lex.wellFoundedLT_of_finite is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {N : Type.{u2}} [_inst_1 : LinearOrder.{u1} α] [_inst_2 : Finite.{succ u1} α] [_inst_3 : Zero.{u2} N] [_inst_4 : LT.{u2} N] [hwf : WellFoundedLT.{u2} N _inst_4], WellFoundedLT.{max u1 u2} (Lex.{max u1 u2} (Finsupp.{u1, u2} α N _inst_3)) (Finsupp.Lex.hasLt.{u1, u2} α N _inst_3 (Preorder.toLT.{u1} α (PartialOrder.toPreorder.{u1} α (SemilatticeInf.toPartialOrder.{u1} α (Lattice.toSemilatticeInf.{u1} α (LinearOrder.toLattice.{u1} α _inst_1))))) _inst_4)
but is expected to have type
  forall {α : Type.{u2}} {N : Type.{u1}} [_inst_1 : LinearOrder.{u2} α] [_inst_2 : Finite.{succ u2} α] [_inst_3 : Zero.{u1} N] [_inst_4 : LT.{u1} N] [hwf : WellFoundedLT.{u1} N _inst_4], WellFoundedLT.{max u1 u2} (Lex.{max u1 u2} (Finsupp.{u2, u1} α N _inst_3)) (Finsupp.instLTLexFinsupp.{u2, u1} α N _inst_3 (Preorder.toLT.{u2} α (PartialOrder.toPreorder.{u2} α (SemilatticeInf.toPartialOrder.{u2} α (Lattice.toSemilatticeInf.{u2} α (DistribLattice.toLattice.{u2} α (instDistribLattice.{u2} α _inst_1)))))) _inst_4)
Case conversion may be inaccurate. Consider using '#align finsupp.lex.well_founded_lt_of_finite Finsupp.Lex.wellFoundedLT_of_finiteₓ'. -/
theorem Lex.wellFoundedLT_of_finite [LinearOrder α] [Finite α] [Zero N] [LT N]
    [hwf : WellFoundedLT N] : WellFoundedLT (Lex (α →₀ N)) :=
  ⟨Finsupp.Lex.wellFounded_of_finite (· < ·) hwf.1⟩
#align finsupp.lex.well_founded_lt_of_finite Finsupp.Lex.wellFoundedLT_of_finite

#print Finsupp.wellFoundedLT /-
protected theorem wellFoundedLT [Zero N] [Preorder N] [WellFoundedLT N] (hbot : ∀ n : N, ¬n < 0) :
    WellFoundedLT (α →₀ N) :=
  ⟨InvImage.wf toDfinsupp (Dfinsupp.wellFoundedLT fun i a => hbot a).wf⟩
#align finsupp.well_founded_lt Finsupp.wellFoundedLT
-/

/- warning: finsupp.well_founded_lt' -> Finsupp.wellFoundedLT' is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {N : Type.{u2}} [_inst_1 : CanonicallyOrderedAddMonoid.{u2} N] [_inst_2 : WellFoundedLT.{u2} N (Preorder.toLT.{u2} N (PartialOrder.toPreorder.{u2} N (OrderedAddCommMonoid.toPartialOrder.{u2} N (CanonicallyOrderedAddMonoid.toOrderedAddCommMonoid.{u2} N _inst_1))))], WellFoundedLT.{max u1 u2} (Finsupp.{u1, u2} α N (AddZeroClass.toHasZero.{u2} N (AddMonoid.toAddZeroClass.{u2} N (AddCommMonoid.toAddMonoid.{u2} N (OrderedAddCommMonoid.toAddCommMonoid.{u2} N (CanonicallyOrderedAddMonoid.toOrderedAddCommMonoid.{u2} N _inst_1)))))) (Preorder.toLT.{max u1 u2} (Finsupp.{u1, u2} α N (AddZeroClass.toHasZero.{u2} N (AddMonoid.toAddZeroClass.{u2} N (AddCommMonoid.toAddMonoid.{u2} N (OrderedAddCommMonoid.toAddCommMonoid.{u2} N (CanonicallyOrderedAddMonoid.toOrderedAddCommMonoid.{u2} N _inst_1)))))) (Finsupp.preorder.{u1, u2} α N (AddZeroClass.toHasZero.{u2} N (AddMonoid.toAddZeroClass.{u2} N (AddCommMonoid.toAddMonoid.{u2} N (OrderedAddCommMonoid.toAddCommMonoid.{u2} N (CanonicallyOrderedAddMonoid.toOrderedAddCommMonoid.{u2} N _inst_1))))) (PartialOrder.toPreorder.{u2} N (OrderedAddCommMonoid.toPartialOrder.{u2} N (CanonicallyOrderedAddMonoid.toOrderedAddCommMonoid.{u2} N _inst_1)))))
but is expected to have type
  forall {α : Type.{u1}} {N : Type.{u2}} [_inst_1 : CanonicallyOrderedAddMonoid.{u2} N] [_inst_2 : WellFoundedLT.{u2} N (Preorder.toLT.{u2} N (PartialOrder.toPreorder.{u2} N (OrderedAddCommMonoid.toPartialOrder.{u2} N (CanonicallyOrderedAddMonoid.toOrderedAddCommMonoid.{u2} N _inst_1))))], WellFoundedLT.{max u2 u1} (Finsupp.{u1, u2} α N (AddMonoid.toZero.{u2} N (AddCommMonoid.toAddMonoid.{u2} N (OrderedAddCommMonoid.toAddCommMonoid.{u2} N (CanonicallyOrderedAddMonoid.toOrderedAddCommMonoid.{u2} N _inst_1))))) (Preorder.toLT.{max u1 u2} (Finsupp.{u1, u2} α N (AddMonoid.toZero.{u2} N (AddCommMonoid.toAddMonoid.{u2} N (OrderedAddCommMonoid.toAddCommMonoid.{u2} N (CanonicallyOrderedAddMonoid.toOrderedAddCommMonoid.{u2} N _inst_1))))) (Finsupp.preorder.{u1, u2} α N (AddMonoid.toZero.{u2} N (AddCommMonoid.toAddMonoid.{u2} N (OrderedAddCommMonoid.toAddCommMonoid.{u2} N (CanonicallyOrderedAddMonoid.toOrderedAddCommMonoid.{u2} N _inst_1)))) (PartialOrder.toPreorder.{u2} N (OrderedAddCommMonoid.toPartialOrder.{u2} N (CanonicallyOrderedAddMonoid.toOrderedAddCommMonoid.{u2} N _inst_1)))))
Case conversion may be inaccurate. Consider using '#align finsupp.well_founded_lt' Finsupp.wellFoundedLT'ₓ'. -/
instance wellFoundedLT' [CanonicallyOrderedAddMonoid N] [WellFoundedLT N] :
    WellFoundedLT (α →₀ N) :=
  Finsupp.wellFoundedLT fun a => (zero_le a).not_lt
#align finsupp.well_founded_lt' Finsupp.wellFoundedLT'

#print Finsupp.wellFoundedLT_of_finite /-
instance wellFoundedLT_of_finite [Finite α] [Zero N] [Preorder N] [WellFoundedLT N] :
    WellFoundedLT (α →₀ N) :=
  ⟨InvImage.wf equivFunOnFinite Function.wellFoundedLT.wf⟩
#align finsupp.well_founded_lt_of_finite Finsupp.wellFoundedLT_of_finite
-/

end Finsupp


/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Stephen Morgan, Scott Morrison, Johannes Hölzl
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.fully_faithful
import Mathlib.data.equiv.basic
import Mathlib.PostPort

universes u v w u' u_1 u_2

namespace Mathlib

/-!
# The category `Type`.

In this section we set up the theory so that Lean's types and functions between them
can be viewed as a `large_category` in our framework.

Lean can not transparently view a function as a morphism in this category,
and needs a hint in order to be able to type check.
We provide the abbreviation `as_hom f` to guide type checking,
as well as a corresponding notation `↾ f`. (Entered as `\upr `.)

We provide various simplification lemmas for functors and natural transformations valued in `Type`.

We define `ulift_functor`, from `Type u` to `Type (max u v)`, and show that it is fully faithful
(but not, of course, essentially surjective).

We prove some basic facts about the category `Type`:
*  epimorphisms are surjections and monomorphisms are injections,
* `iso` is both `iso` and `equiv` to `equiv` (at least within a fixed universe),
* every type level `is_lawful_functor` gives a categorical functor `Type ⥤ Type`
  (the corresponding fact about monads is in `src/category_theory/monad/types.lean`).
-/

namespace category_theory

protected instance types : large_category (Type u) :=
  category.mk

theorem types_hom {α : Type u} {β : Type u} : (α ⟶ β) = (α → β) :=
  rfl

theorem types_id (X : Type u) : 𝟙 = id :=
  rfl

theorem types_comp {X : Type u} {Y : Type u} {Z : Type u} (f : X ⟶ Y) (g : Y ⟶ Z) : f ≫ g = g ∘ f :=
  rfl

@[simp] theorem types_id_apply (X : Type u) (x : X) : 𝟙 = x :=
  rfl

@[simp] theorem types_comp_apply {X : Type u} {Y : Type u} {Z : Type u} (f : X ⟶ Y) (g : Y ⟶ Z) (x : X) : category_struct.comp f g x = g (f x) :=
  rfl

@[simp] theorem hom_inv_id_apply {X : Type u} {Y : Type u} (f : X ≅ Y) (x : X) : iso.inv f (iso.hom f x) = x :=
  congr_fun (iso.hom_inv_id f) x

@[simp] theorem inv_hom_id_apply {X : Type u} {Y : Type u} (f : X ≅ Y) (y : Y) : iso.hom f (iso.inv f y) = y :=
  congr_fun (iso.inv_hom_id f) y

/-- `as_hom f` helps Lean type check a function as a morphism in the category `Type`. -/
-- Unfortunately without this wrapper we can't use `category_theory` idioms, such as `is_iso f`.

-- If you don't mind some notation you can use fewer keystrokes:

def as_hom {α : Type u} {β : Type u} (f : α → β) : α ⟶ β :=
  f

prefix:200 "↾" => Mathlib.category_theory.as_hom

namespace functor

/--
The sections of a functor `J ⥤ Type` are
the choices of a point `u j : F.obj j` for each `j`,
such that `F.map f (u j) = u j` for every morphism `f : j ⟶ j'`.

We later use these to define limits in `Type` and in many concrete categories.
-/
def sections {J : Type u} [category J] (F : J ⥤ Type w) : set ((j : J) → obj F j) :=
  set_of fun (u : (j : J) → obj F j) => ∀ {j j' : J} (f : j ⟶ j'), map F f (u j) = u j'

end functor

namespace functor_to_types

@[simp] theorem map_comp_apply {C : Type u} [category C] (F : C ⥤ Type w) {X : C} {Y : C} {Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) (a : functor.obj F X) : functor.map F (f ≫ g) a = functor.map F g (functor.map F f a) := sorry

@[simp] theorem map_id_apply {C : Type u} [category C] (F : C ⥤ Type w) {X : C} (a : functor.obj F X) : functor.map F 𝟙 a = a := sorry

theorem naturality {C : Type u} [category C] (F : C ⥤ Type w) (G : C ⥤ Type w) {X : C} {Y : C} (σ : F ⟶ G) (f : X ⟶ Y) (x : functor.obj F X) : nat_trans.app σ Y (functor.map F f x) = functor.map G f (nat_trans.app σ X x) :=
  congr_fun (nat_trans.naturality σ f) x

@[simp] theorem comp {C : Type u} [category C] (F : C ⥤ Type w) (G : C ⥤ Type w) (H : C ⥤ Type w) {X : C} (σ : F ⟶ G) (τ : G ⟶ H) (x : functor.obj F X) : nat_trans.app (σ ≫ τ) X x = nat_trans.app τ X (nat_trans.app σ X x) :=
  rfl

@[simp] theorem hcomp {C : Type u} [category C] (F : C ⥤ Type w) (G : C ⥤ Type w) (σ : F ⟶ G) {D : Type u'} [𝒟 : category D] (I : D ⥤ C) (J : D ⥤ C) (ρ : I ⟶ J) {W : D} (x : functor.obj (I ⋙ F) W) : nat_trans.app (ρ ◫ σ) W x = functor.map G (nat_trans.app ρ W) (nat_trans.app σ (functor.obj I W) x) :=
  rfl

@[simp] theorem map_inv_map_hom_apply {C : Type u} [category C] (F : C ⥤ Type w) {X : C} {Y : C} (f : X ≅ Y) (x : functor.obj F X) : functor.map F (iso.inv f) (functor.map F (iso.hom f) x) = x :=
  congr_fun (iso.hom_inv_id (functor.map_iso F f)) x

@[simp] theorem map_hom_map_inv_apply {C : Type u} [category C] (F : C ⥤ Type w) {X : C} {Y : C} (f : X ≅ Y) (y : functor.obj F Y) : functor.map F (iso.hom f) (functor.map F (iso.inv f) y) = y :=
  congr_fun (iso.inv_hom_id (functor.map_iso F f)) y

@[simp] theorem hom_inv_id_app_apply {C : Type u} [category C] (F : C ⥤ Type w) (G : C ⥤ Type w) (α : F ≅ G) (X : C) (x : functor.obj F X) : nat_trans.app (iso.inv α) X (nat_trans.app (iso.hom α) X x) = x :=
  congr_fun (iso.hom_inv_id_app α X) x

@[simp] theorem inv_hom_id_app_apply {C : Type u} [category C] (F : C ⥤ Type w) (G : C ⥤ Type w) (α : F ≅ G) (X : C) (x : functor.obj G X) : nat_trans.app (iso.hom α) X (nat_trans.app (iso.inv α) X x) = x :=
  congr_fun (iso.inv_hom_id_app α X) x

end functor_to_types

/--
The isomorphism between a `Type` which has been `ulift`ed to the same universe,
and the original type.
-/
def ulift_trivial (V : Type u) : ulift V ≅ V :=
  iso.mk (id fun (ᾰ : ulift V) => ulift.cases_on ᾰ fun (ᾰ : V) => ᾰ) ulift.up

/--
The functor embedding `Type u` into `Type (max u v)`.
Write this as `ulift_functor.{5 2}` to get `Type 2 ⥤ Type 5`.
-/
def ulift_functor : Type u ⥤ Type (max u v) :=
  functor.mk (fun (X : Type u) => ulift X) fun (X Y : Type u) (f : X ⟶ Y) (x : ulift X) => ulift.up (f (ulift.down x))

@[simp] theorem ulift_functor_map {X : Type u} {Y : Type u} (f : X ⟶ Y) (x : ulift X) : functor.map ulift_functor f x = ulift.up (f (ulift.down x)) :=
  rfl

protected instance ulift_functor_full : full ulift_functor :=
  full.mk
    fun (X Y : Type u) (f : functor.obj ulift_functor X ⟶ functor.obj ulift_functor Y) (x : X) =>
      ulift.down (f (ulift.up x))

protected instance ulift_functor_faithful : faithful ulift_functor :=
  faithful.mk

/-- Any term `x` of a type `X` corresponds to a morphism `punit ⟶ X`. -/
-- TODO We should connect this to a general story about concrete categories

-- whose forgetful functor is representable.

def hom_of_element {X : Type u} (x : X) : PUnit ⟶ X :=
  fun (_x : PUnit) => x

theorem hom_of_element_eq_iff {X : Type u} (x : X) (y : X) : hom_of_element x = hom_of_element y ↔ x = y := sorry

/--
A morphism in `Type` is a monomorphism if and only if it is injective.

See https://stacks.math.columbia.edu/tag/003C.
-/
theorem mono_iff_injective {X : Type u} {Y : Type u} (f : X ⟶ Y) : mono f ↔ function.injective f := sorry

/--
A morphism in `Type` is an epimorphism if and only if it is surjective.

See https://stacks.math.columbia.edu/tag/003C.
-/
theorem epi_iff_surjective {X : Type u} {Y : Type u} (f : X ⟶ Y) : epi f ↔ function.surjective f := sorry

/-- `of_type_functor m` converts from Lean's `Type`-based `category` to `category_theory`. This
allows us to use these functors in category theory. -/
def of_type_functor (m : Type u → Type v) [Functor m] [is_lawful_functor m] : Type u ⥤ Type v :=
  functor.mk m fun (α β : Type u) => Functor.map

@[simp] theorem of_type_functor_obj (m : Type u → Type v) [Functor m] [is_lawful_functor m] : functor.obj (of_type_functor m) = m :=
  rfl

@[simp] theorem of_type_functor_map (m : Type u → Type v) [Functor m] [is_lawful_functor m] {α : Type u} {β : Type u} (f : α → β) : functor.map (of_type_functor m) f = Functor.map f :=
  rfl

end category_theory

-- Isomorphisms in Type and equivalences.

namespace equiv

/--
Any equivalence between types in the same universe gives
a categorical isomorphism between those types.
-/
def to_iso {X : Type u} {Y : Type u} (e : X ≃ Y) : X ≅ Y :=
  category_theory.iso.mk (to_fun e) (inv_fun e)

@[simp] theorem to_iso_hom {X : Type u} {Y : Type u} {e : X ≃ Y} : category_theory.iso.hom (to_iso e) = ⇑e :=
  rfl

@[simp] theorem to_iso_inv {X : Type u} {Y : Type u} {e : X ≃ Y} : category_theory.iso.inv (to_iso e) = ⇑(equiv.symm e) :=
  rfl

end equiv

namespace category_theory.iso

/--
Any isomorphism between types gives an equivalence.
-/
def to_equiv {X : Type u} {Y : Type u} (i : X ≅ Y) : X ≃ Y :=
  equiv.mk (hom i) (inv i) sorry sorry

@[simp] theorem to_equiv_fun {X : Type u} {Y : Type u} (i : X ≅ Y) : ⇑(to_equiv i) = hom i :=
  rfl

@[simp] theorem to_equiv_symm_fun {X : Type u} {Y : Type u} (i : X ≅ Y) : ⇑(equiv.symm (to_equiv i)) = inv i :=
  rfl

@[simp] theorem to_equiv_id (X : Type u) : to_equiv (refl X) = equiv.refl X :=
  rfl

@[simp] theorem to_equiv_comp {X : Type u} {Y : Type u} {Z : Type u} (f : X ≅ Y) (g : Y ≅ Z) : to_equiv (f ≪≫ g) = equiv.trans (to_equiv f) (to_equiv g) :=
  rfl

end category_theory.iso

namespace category_theory

/-- A morphism in `Type u` is an isomorphism if and only if it is bijective. -/
def is_iso_equiv_bijective {X : Type u} {Y : Type u} (f : X ⟶ Y) : is_iso f ≃ function.bijective f :=
  equiv_of_subsingleton_of_subsingleton sorry
    fun (b : function.bijective f) => is_iso.mk (iso.inv (equiv.to_iso (equiv.of_bijective f b)))

end category_theory

-- We prove `equiv_iso_iso` and then use that to sneakily construct `equiv_equiv_iso`.

-- (In this order the proofs are handled by `obviously`.)

/-- Equivalences (between types in the same universe) are the same as (isomorphic to) isomorphisms
of types. -/
@[simp] theorem equiv_iso_iso_hom {X : Type u} {Y : Type u} (e : X ≃ Y) : category_theory.iso.hom equiv_iso_iso e = equiv.to_iso e :=
  Eq.refl (category_theory.iso.hom equiv_iso_iso e)

/-- Equivalences (between types in the same universe) are the same as (equivalent to) isomorphisms
of types. -/
-- We leave `X` and `Y` as explicit arguments here, because the coercions from `equiv` to a function

-- won't fire without them.

-- TODO: is it still true?

def equiv_equiv_iso (X : Type u) (Y : Type u) : X ≃ Y ≃ (X ≅ Y) :=
  category_theory.iso.to_equiv equiv_iso_iso

@[simp] theorem equiv_equiv_iso_hom {X : Type u} {Y : Type u} (e : X ≃ Y) : coe_fn (equiv_equiv_iso X Y) e = equiv.to_iso e :=
  rfl

@[simp] theorem equiv_equiv_iso_inv {X : Type u} {Y : Type u} (e : X ≅ Y) : coe_fn (equiv.symm (equiv_equiv_iso X Y)) e = category_theory.iso.to_equiv e :=
  rfl


/-
Copyright (c) 2020 Joseph Myers. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Joseph Myers, Yury Kudryashov.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.group.prod
import Mathlib.algebra.group.type_tags
import Mathlib.algebra.group.pi
import Mathlib.algebra.pointwise
import Mathlib.data.equiv.basic
import Mathlib.data.set.finite
import Mathlib.PostPort

universes u_1 u_2 l u_3 u_4 u v w

namespace Mathlib

/-!
# Torsors of additive group actions

This file defines torsors of additive group actions.

## Notations

The group elements are referred to as acting on points.  This file
defines the notation `+ᵥ` for adding a group element to a point and
`-ᵥ` for subtracting two points to produce a group element.

## Implementation notes

Affine spaces are the motivating example of torsors of additive group actions. It may be appropriate
to refactor in terms of the general definition of group actions, via `to_additive`, when there is a
use for multiplicative torsors (currently mathlib only develops the theory of group actions for
multiplicative group actions).

## Notations

* `v +ᵥ p` is a notation for `has_vadd.vadd`, the left action of an additive monoid;

* `p₁ -ᵥ p₂` is a notation for `has_vsub.vsub`, difference between two points in an additive torsor
  as an element of the corresponding additive group;

## References

* https://en.wikipedia.org/wiki/Principal_homogeneous_space
* https://en.wikipedia.org/wiki/Affine_space

-/

/-- Type class for the `+ᵥ` notation. -/
class has_vadd (G : Type u_1) (P : Type u_2)
where
  vadd : G → P → P

/-- Type class for the `-ᵥ` notation. -/
class has_vsub (G : outParam (Type u_1)) (P : Type u_2)
where
  vsub : P → P → G

infixl:65 " +ᵥ " => Mathlib.has_vadd.vadd

infixl:65 " -ᵥ " => Mathlib.has_vsub.vsub

/-- Type class for additive monoid actions. -/
class add_action (G : Type u_1) (P : Type u_2) [add_monoid G]
extends has_vadd G P
where
  zero_vadd' : ∀ (p : P), 0 +ᵥ p = p
  vadd_assoc' : ∀ (g1 g2 : G) (p : P), g1 +ᵥ (g2 +ᵥ p) = g1 + g2 +ᵥ p

/-- An `add_torsor G P` gives a structure to the nonempty type `P`,
acted on by an `add_group G` with a transitive and free action given
by the `+ᵥ` operation and a corresponding subtraction given by the
`-ᵥ` operation. In the case of a vector space, it is an affine
space. -/
class add_torsor (G : outParam (Type u_1)) (P : Type u_2) [outParam (add_group G)]
extends has_vsub G P, add_action G P
where
  nonempty : Nonempty P
  vsub_vadd' : ∀ (p1 p2 : P), p1 -ᵥ p2 +ᵥ p2 = p1
  vadd_vsub' : ∀ (g : G) (p : P), g +ᵥ p -ᵥ p = g

/-- An `add_group G` is a torsor for itself. -/
protected instance add_group_is_add_torsor (G : Type u_1) [add_group G] : add_torsor G G :=
  add_torsor.mk Add.add sorry sorry Sub.sub sub_add_cancel add_sub_cancel

/-- Simplify addition for a torsor for an `add_group G` over
itself. -/
@[simp] theorem vadd_eq_add {G : Type u_1} [add_group G] (g1 : G) (g2 : G) : g1 +ᵥ g2 = g1 + g2 :=
  rfl

/-- Simplify subtraction for a torsor for an `add_group G` over
itself. -/
@[simp] theorem vsub_eq_sub {G : Type u_1} [add_group G] (g1 : G) (g2 : G) : g1 -ᵥ g2 = g1 - g2 :=
  rfl

/-- Adding the zero group element to a point gives the same point. -/
@[simp] theorem zero_vadd (G : Type u_1) {P : Type u_2} [add_monoid G] [A : add_action G P] (p : P) : 0 +ᵥ p = p :=
  add_action.zero_vadd' p

/-- Adding two group elements to a point produces the same result as
adding their sum. -/
theorem vadd_assoc {G : Type u_1} {P : Type u_2} [add_monoid G] [A : add_action G P] (g1 : G) (g2 : G) (p : P) : g1 +ᵥ (g2 +ᵥ p) = g1 + g2 +ᵥ p :=
  add_action.vadd_assoc' g1 g2 p

/-- Adding two group elements to a point produces the same result in either
order. -/
theorem vadd_comm (G : Type u_1) {P : Type u_2} [add_comm_monoid G] [A : add_action G P] (p : P) (g1 : G) (g2 : G) : g1 +ᵥ (g2 +ᵥ p) = g2 +ᵥ (g1 +ᵥ p) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (g1 +ᵥ (g2 +ᵥ p) = g2 +ᵥ (g1 +ᵥ p))) (vadd_assoc g1 g2 p)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (g1 + g2 +ᵥ p = g2 +ᵥ (g1 +ᵥ p))) (vadd_assoc g2 g1 p)))
      (eq.mpr (id (Eq._oldrec (Eq.refl (g1 + g2 +ᵥ p = g2 + g1 +ᵥ p)) (add_comm g1 g2))) (Eq.refl (g2 + g1 +ᵥ p))))

/-- If the same group element added to two points produces equal results,
those points are equal. -/
theorem vadd_left_cancel {G : Type u_1} {P : Type u_2} [add_group G] [A : add_action G P] {p1 : P} {p2 : P} (g : G) (h : g +ᵥ p1 = g +ᵥ p2) : p1 = p2 := sorry

@[simp] theorem vadd_left_cancel_iff {G : Type u_1} {P : Type u_2} [add_group G] [A : add_action G P] {p₁ : P} {p₂ : P} (g : G) : g +ᵥ p₁ = g +ᵥ p₂ ↔ p₁ = p₂ :=
  { mp := vadd_left_cancel g, mpr := fun (h : p₁ = p₂) => h ▸ rfl }

/-- Adding the group element `g` to a point is an injective function. -/
theorem vadd_left_injective {G : Type u_1} (P : Type u_2) [add_group G] [A : add_action G P] (g : G) : function.injective (has_vadd.vadd g) :=
  fun (p1 p2 : P) => vadd_left_cancel g

/-- Adding the result of subtracting from another point produces that
point. -/
@[simp] theorem vsub_vadd {G : Type u_1} {P : Type u_2} [add_group G] [T : add_torsor G P] (p1 : P) (p2 : P) : p1 -ᵥ p2 +ᵥ p2 = p1 :=
  add_torsor.vsub_vadd' p1 p2

/-- Adding a group element then subtracting the original point
produces that group element. -/
@[simp] theorem vadd_vsub {G : Type u_1} {P : Type u_2} [add_group G] [T : add_torsor G P] (g : G) (p : P) : g +ᵥ p -ᵥ p = g :=
  add_torsor.vadd_vsub' g p

/-- If the same point added to two group elements produces equal
results, those group elements are equal. -/
theorem vadd_right_cancel {G : Type u_1} {P : Type u_2} [add_group G] [T : add_torsor G P] {g1 : G} {g2 : G} (p : P) (h : g1 +ᵥ p = g2 +ᵥ p) : g1 = g2 :=
  eq.mpr (id (Eq._oldrec (Eq.refl (g1 = g2)) (Eq.symm (vadd_vsub g1 p))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (g1 +ᵥ p -ᵥ p = g2)) h))
      (eq.mpr (id (Eq._oldrec (Eq.refl (g2 +ᵥ p -ᵥ p = g2)) (vadd_vsub g2 p))) (Eq.refl g2)))

@[simp] theorem vadd_right_cancel_iff {G : Type u_1} {P : Type u_2} [add_group G] [T : add_torsor G P] {g1 : G} {g2 : G} (p : P) : g1 +ᵥ p = g2 +ᵥ p ↔ g1 = g2 :=
  { mp := vadd_right_cancel p, mpr := fun (h : g1 = g2) => h ▸ rfl }

/-- Adding a group element to the point `p` is an injective
function. -/
theorem vadd_right_injective {G : Type u_1} {P : Type u_2} [add_group G] [T : add_torsor G P] (p : P) : function.injective fun (_x : G) => _x +ᵥ p :=
  fun (g1 g2 : G) => vadd_right_cancel p

/-- Adding a group element to a point, then subtracting another point,
produces the same result as subtracting the points then adding the
group element. -/
theorem vadd_vsub_assoc {G : Type u_1} {P : Type u_2} [add_group G] [T : add_torsor G P] (g : G) (p1 : P) (p2 : P) : g +ᵥ p1 -ᵥ p2 = g + (p1 -ᵥ p2) := sorry

/-- Subtracting a point from itself produces 0. -/
@[simp] theorem vsub_self {G : Type u_1} {P : Type u_2} [add_group G] [T : add_torsor G P] (p : P) : p -ᵥ p = 0 :=
  eq.mpr (id (Eq._oldrec (Eq.refl (p -ᵥ p = 0)) (Eq.symm (zero_add (p -ᵥ p)))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (0 + (p -ᵥ p) = 0)) (Eq.symm (vadd_vsub_assoc 0 p p))))
      (eq.mpr (id (Eq._oldrec (Eq.refl (0 +ᵥ p -ᵥ p = 0)) (vadd_vsub 0 p))) (Eq.refl 0)))

/-- If subtracting two points produces 0, they are equal. -/
theorem eq_of_vsub_eq_zero {G : Type u_1} {P : Type u_2} [add_group G] [T : add_torsor G P] {p1 : P} {p2 : P} (h : p1 -ᵥ p2 = 0) : p1 = p2 :=
  eq.mpr (id (Eq._oldrec (Eq.refl (p1 = p2)) (Eq.symm (vsub_vadd p1 p2))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (p1 -ᵥ p2 +ᵥ p2 = p2)) h))
      (eq.mpr (id (Eq._oldrec (Eq.refl (0 +ᵥ p2 = p2)) (zero_vadd G p2))) (Eq.refl p2)))

/-- Subtracting two points produces 0 if and only if they are
equal. -/
@[simp] theorem vsub_eq_zero_iff_eq {G : Type u_1} {P : Type u_2} [add_group G] [T : add_torsor G P] {p1 : P} {p2 : P} : p1 -ᵥ p2 = 0 ↔ p1 = p2 :=
  { mp := eq_of_vsub_eq_zero, mpr := fun (h : p1 = p2) => h ▸ vsub_self p1 }

/-- Cancellation adding the results of two subtractions. -/
@[simp] theorem vsub_add_vsub_cancel {G : Type u_1} {P : Type u_2} [add_group G] [T : add_torsor G P] (p1 : P) (p2 : P) (p3 : P) : p1 -ᵥ p2 + (p2 -ᵥ p3) = p1 -ᵥ p3 := sorry

/-- Subtracting two points in the reverse order produces the negation
of subtracting them. -/
@[simp] theorem neg_vsub_eq_vsub_rev {G : Type u_1} {P : Type u_2} [add_group G] [T : add_torsor G P] (p1 : P) (p2 : P) : -(p1 -ᵥ p2) = p2 -ᵥ p1 := sorry

/-- Subtracting the result of adding a group element produces the same result
as subtracting the points and subtracting that group element. -/
theorem vsub_vadd_eq_vsub_sub {G : Type u_1} {P : Type u_2} [add_group G] [T : add_torsor G P] (p1 : P) (p2 : P) (g : G) : p1 -ᵥ (g +ᵥ p2) = p1 -ᵥ p2 - g := sorry

/-- Cancellation subtracting the results of two subtractions. -/
@[simp] theorem vsub_sub_vsub_cancel_right {G : Type u_1} {P : Type u_2} [add_group G] [T : add_torsor G P] (p1 : P) (p2 : P) (p3 : P) : p1 -ᵥ p3 - (p2 -ᵥ p3) = p1 -ᵥ p2 :=
  eq.mpr (id (Eq._oldrec (Eq.refl (p1 -ᵥ p3 - (p2 -ᵥ p3) = p1 -ᵥ p2)) (Eq.symm (vsub_vadd_eq_vsub_sub p1 p3 (p2 -ᵥ p3)))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (p1 -ᵥ (p2 -ᵥ p3 +ᵥ p3) = p1 -ᵥ p2)) (vsub_vadd p2 p3))) (Eq.refl (p1 -ᵥ p2)))

/-- Convert between an equality with adding a group element to a point
and an equality of a subtraction of two points with a group
element. -/
theorem eq_vadd_iff_vsub_eq {G : Type u_1} {P : Type u_2} [add_group G] [T : add_torsor G P] (p1 : P) (g : G) (p2 : P) : p1 = g +ᵥ p2 ↔ p1 -ᵥ p2 = g :=
  { mp := fun (h : p1 = g +ᵥ p2) => Eq.symm h ▸ vadd_vsub g p2,
    mpr := fun (h : p1 -ᵥ p2 = g) => h ▸ Eq.symm (vsub_vadd p1 p2) }

theorem vadd_eq_vadd_iff_neg_add_eq_vsub {G : Type u_1} {P : Type u_2} [add_group G] [T : add_torsor G P] {v₁ : G} {v₂ : G} {p₁ : P} {p₂ : P} : v₁ +ᵥ p₁ = v₂ +ᵥ p₂ ↔ -v₁ + v₂ = p₁ -ᵥ p₂ := sorry

namespace set

protected instance has_vsub {G : Type u_1} {P : Type u_2} [add_group G] [T : add_torsor G P] : has_vsub (set G) (set P) :=
  has_vsub.mk (image2 has_vsub.vsub)

@[simp] theorem vsub_empty {G : Type u_1} {P : Type u_2} [add_group G] [T : add_torsor G P] (s : set P) : s -ᵥ ∅ = ∅ :=
  image2_empty_right

@[simp] theorem empty_vsub {G : Type u_1} {P : Type u_2} [add_group G] [T : add_torsor G P] (s : set P) : ∅ -ᵥ s = ∅ :=
  image2_empty_left

@[simp] theorem singleton_vsub {G : Type u_1} {P : Type u_2} [add_group G] [T : add_torsor G P] (s : set P) (p : P) : singleton p -ᵥ s = has_vsub.vsub p '' s :=
  image2_singleton_left

@[simp] theorem vsub_singleton {G : Type u_1} {P : Type u_2} [add_group G] [T : add_torsor G P] (s : set P) (p : P) : s -ᵥ singleton p = (fun (_x : P) => _x -ᵥ p) '' s :=
  image2_singleton_right

@[simp] theorem singleton_vsub_self {G : Type u_1} {P : Type u_2} [add_group G] [T : add_torsor G P] (p : P) : singleton p -ᵥ singleton p = singleton 0 := sorry

/-- `vsub` of a finite set is finite. -/
theorem finite.vsub {G : Type u_1} {P : Type u_2} [add_group G] [T : add_torsor G P] {s : set P} {t : set P} (hs : finite s) (ht : finite t) : finite (s -ᵥ t) :=
  finite.image2 (fun (a b : P) => a -ᵥ b) hs ht

/-- Each pairwise difference is in the `vsub` set. -/
theorem vsub_mem_vsub {G : Type u_1} {P : Type u_2} [add_group G] [T : add_torsor G P] {s : set P} {t : set P} {ps : P} {pt : P} (hs : ps ∈ s) (ht : pt ∈ t) : ps -ᵥ pt ∈ s -ᵥ t :=
  mem_image2_of_mem hs ht

/-- `s -ᵥ t` is monotone in both arguments. -/
theorem vsub_subset_vsub {G : Type u_1} {P : Type u_2} [add_group G] [T : add_torsor G P] {s : set P} {t : set P} {s' : set P} {t' : set P} (hs : s ⊆ s') (ht : t ⊆ t') : s -ᵥ t ⊆ s' -ᵥ t' :=
  image2_subset hs ht

theorem vsub_self_mono {G : Type u_1} {P : Type u_2} [add_group G] [T : add_torsor G P] {s : set P} {t : set P} (h : s ⊆ t) : s -ᵥ s ⊆ t -ᵥ t :=
  vsub_subset_vsub h h

theorem vsub_subset_iff {G : Type u_1} {P : Type u_2} [add_group G] [T : add_torsor G P] {s : set P} {t : set P} {u : set G} : s -ᵥ t ⊆ u ↔ ∀ (x : P), x ∈ s → ∀ (y : P), y ∈ t → x -ᵥ y ∈ u :=
  image2_subset_iff

protected instance add_action {G : Type u_1} {P : Type u_2} [add_group G] [T : add_torsor G P] : add_action (set G) (set P) :=
  add_action.mk (image2 has_vadd.vadd) sorry sorry

theorem vadd_subset_vadd {G : Type u_1} {P : Type u_2} [add_group G] [T : add_torsor G P] {s : set G} {s' : set G} {t : set P} {t' : set P} (hs : s ⊆ s') (ht : t ⊆ t') : s +ᵥ t ⊆ s' +ᵥ t' :=
  image2_subset hs ht

@[simp] theorem vadd_singleton {G : Type u_1} {P : Type u_2} [add_group G] [T : add_torsor G P] (s : set G) (p : P) : s +ᵥ singleton p = (fun (_x : G) => _x +ᵥ p) '' s :=
  image2_singleton_right

@[simp] theorem singleton_vadd {G : Type u_1} {P : Type u_2} [add_group G] [T : add_torsor G P] (v : G) (s : set P) : singleton v +ᵥ s = has_vadd.vadd v '' s :=
  image2_singleton_left

theorem finite.vadd {G : Type u_1} {P : Type u_2} [add_group G] [T : add_torsor G P] {s : set G} {t : set P} (hs : finite s) (ht : finite t) : finite (s +ᵥ t) :=
  finite.image2 (fun (a : G) (b : P) => a +ᵥ b) hs ht

end set

@[simp] theorem vadd_vsub_vadd_cancel_right {G : Type u_1} {P : Type u_2} [add_group G] [T : add_torsor G P] (v₁ : G) (v₂ : G) (p : P) : v₁ +ᵥ p -ᵥ (v₂ +ᵥ p) = v₁ - v₂ := sorry

/-- If the same point subtracted from two points produces equal
results, those points are equal. -/
theorem vsub_left_cancel {G : Type u_1} {P : Type u_2} [add_group G] [T : add_torsor G P] {p1 : P} {p2 : P} {p : P} (h : p1 -ᵥ p = p2 -ᵥ p) : p1 = p2 :=
  eq.mp (Eq._oldrec (Eq.refl (p1 -ᵥ p2 = 0)) (propext vsub_eq_zero_iff_eq))
    (eq.mp (Eq._oldrec (Eq.refl (p1 -ᵥ p - (p2 -ᵥ p) = 0)) (vsub_sub_vsub_cancel_right p1 p2 p))
      (eq.mp (Eq._oldrec (Eq.refl (p1 -ᵥ p = p2 -ᵥ p)) (Eq.symm (propext sub_eq_zero))) h))

/-- The same point subtracted from two points produces equal results
if and only if those points are equal. -/
@[simp] theorem vsub_left_cancel_iff {G : Type u_1} {P : Type u_2} [add_group G] [T : add_torsor G P] {p1 : P} {p2 : P} {p : P} : p1 -ᵥ p = p2 -ᵥ p ↔ p1 = p2 :=
  { mp := vsub_left_cancel, mpr := fun (h : p1 = p2) => h ▸ rfl }

/-- Subtracting the point `p` is an injective function. -/
theorem vsub_left_injective {G : Type u_1} {P : Type u_2} [add_group G] [T : add_torsor G P] (p : P) : function.injective fun (_x : P) => _x -ᵥ p :=
  fun (p2 p3 : P) => vsub_left_cancel

/-- If subtracting two points from the same point produces equal
results, those points are equal. -/
theorem vsub_right_cancel {G : Type u_1} {P : Type u_2} [add_group G] [T : add_torsor G P] {p1 : P} {p2 : P} {p : P} (h : p -ᵥ p1 = p -ᵥ p2) : p1 = p2 := sorry

/-- Subtracting two points from the same point produces equal results
if and only if those points are equal. -/
@[simp] theorem vsub_right_cancel_iff {G : Type u_1} {P : Type u_2} [add_group G] [T : add_torsor G P] {p1 : P} {p2 : P} {p : P} : p -ᵥ p1 = p -ᵥ p2 ↔ p1 = p2 :=
  { mp := vsub_right_cancel, mpr := fun (h : p1 = p2) => h ▸ rfl }

/-- Subtracting a point from the point `p` is an injective
function. -/
theorem vsub_right_injective {G : Type u_1} {P : Type u_2} [add_group G] [T : add_torsor G P] (p : P) : function.injective (has_vsub.vsub p) :=
  fun (p2 p3 : P) => vsub_right_cancel

/-- Cancellation subtracting the results of two subtractions. -/
@[simp] theorem vsub_sub_vsub_cancel_left {G : Type u_1} {P : Type u_2} [add_comm_group G] [add_torsor G P] (p1 : P) (p2 : P) (p3 : P) : p3 -ᵥ p2 - (p3 -ᵥ p1) = p1 -ᵥ p2 := sorry

@[simp] theorem vadd_vsub_vadd_cancel_left {G : Type u_1} {P : Type u_2} [add_comm_group G] [add_torsor G P] (v : G) (p1 : P) (p2 : P) : v +ᵥ p1 -ᵥ (v +ᵥ p2) = p1 -ᵥ p2 := sorry

theorem vsub_vadd_comm {G : Type u_1} {P : Type u_2} [add_comm_group G] [add_torsor G P] (p1 : P) (p2 : P) (p3 : P) : p1 -ᵥ p2 +ᵥ p3 = p3 -ᵥ p2 +ᵥ p1 := sorry

theorem vadd_eq_vadd_iff_sub_eq_vsub {G : Type u_1} {P : Type u_2} [add_comm_group G] [add_torsor G P] {v₁ : G} {v₂ : G} {p₁ : P} {p₂ : P} : v₁ +ᵥ p₁ = v₂ +ᵥ p₂ ↔ v₂ - v₁ = p₁ -ᵥ p₂ :=
  eq.mpr (id (Eq._oldrec (Eq.refl (v₁ +ᵥ p₁ = v₂ +ᵥ p₂ ↔ v₂ - v₁ = p₁ -ᵥ p₂)) (propext vadd_eq_vadd_iff_neg_add_eq_vsub)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (-v₁ + v₂ = p₁ -ᵥ p₂ ↔ v₂ - v₁ = p₁ -ᵥ p₂)) (neg_add_eq_sub v₁ v₂)))
      (iff.refl (v₂ - v₁ = p₁ -ᵥ p₂)))

theorem vsub_sub_vsub_comm {G : Type u_1} {P : Type u_2} [add_comm_group G] [add_torsor G P] (p₁ : P) (p₂ : P) (p₃ : P) (p₄ : P) : p₁ -ᵥ p₂ - (p₃ -ᵥ p₄) = p₁ -ᵥ p₃ - (p₂ -ᵥ p₄) := sorry

namespace prod

protected instance add_torsor {G : Type u_1} {P : Type u_2} {G' : Type u_3} {P' : Type u_4} [add_group G] [add_group G'] [add_torsor G P] [add_torsor G' P'] : add_torsor (G × G') (P × P') :=
  add_torsor.mk (fun (v : G × G') (p : P × P') => (fst v +ᵥ fst p, snd v +ᵥ snd p)) sorry sorry
    (fun (p₁ p₂ : P × P') => (fst p₁ -ᵥ fst p₂, snd p₁ -ᵥ snd p₂)) sorry sorry

@[simp] theorem fst_vadd {G : Type u_1} {P : Type u_2} {G' : Type u_3} {P' : Type u_4} [add_group G] [add_group G'] [add_torsor G P] [add_torsor G' P'] (v : G × G') (p : P × P') : fst (v +ᵥ p) = fst v +ᵥ fst p :=
  rfl

@[simp] theorem snd_vadd {G : Type u_1} {P : Type u_2} {G' : Type u_3} {P' : Type u_4} [add_group G] [add_group G'] [add_torsor G P] [add_torsor G' P'] (v : G × G') (p : P × P') : snd (v +ᵥ p) = snd v +ᵥ snd p :=
  rfl

@[simp] theorem mk_vadd_mk {G : Type u_1} {P : Type u_2} {G' : Type u_3} {P' : Type u_4} [add_group G] [add_group G'] [add_torsor G P] [add_torsor G' P'] (v : G) (v' : G') (p : P) (p' : P') : (v, v') +ᵥ (p, p') = (v +ᵥ p, v' +ᵥ p') :=
  rfl

@[simp] theorem fst_vsub {G : Type u_1} {P : Type u_2} {G' : Type u_3} {P' : Type u_4} [add_group G] [add_group G'] [add_torsor G P] [add_torsor G' P'] (p₁ : P × P') (p₂ : P × P') : fst (p₁ -ᵥ p₂) = fst p₁ -ᵥ fst p₂ :=
  rfl

@[simp] theorem snd_vsub {G : Type u_1} {P : Type u_2} {G' : Type u_3} {P' : Type u_4} [add_group G] [add_group G'] [add_torsor G P] [add_torsor G' P'] (p₁ : P × P') (p₂ : P × P') : snd (p₁ -ᵥ p₂) = snd p₁ -ᵥ snd p₂ :=
  rfl

@[simp] theorem mk_vsub_mk {G : Type u_1} {P : Type u_2} {G' : Type u_3} {P' : Type u_4} [add_group G] [add_group G'] [add_torsor G P] [add_torsor G' P'] (p₁ : P) (p₂ : P) (p₁' : P') (p₂' : P') : (p₁, p₁') -ᵥ (p₂, p₂') = (p₁ -ᵥ p₂, p₁' -ᵥ p₂') :=
  rfl

end prod

namespace pi

/-- A product of `add_torsor`s is an `add_torsor`. -/
protected instance add_torsor {I : Type u} {fg : I → Type v} [(i : I) → add_group (fg i)] {fp : I → Type w} [T : (i : I) → add_torsor (fg i) (fp i)] : add_torsor ((i : I) → fg i) ((i : I) → fp i) :=
  add_torsor.mk (fun (g : (i : I) → fg i) (p : (i : I) → fp i) (i : I) => g i +ᵥ p i) sorry sorry
    (fun (p₁ p₂ : (i : I) → fp i) (i : I) => p₁ i -ᵥ p₂ i) sorry sorry

/-- Addition in a product of `add_torsor`s. -/
@[simp] theorem vadd_apply {I : Type u} {fg : I → Type v} [(i : I) → add_group (fg i)] {fp : I → Type w} [T : (i : I) → add_torsor (fg i) (fp i)] (x : (i : I) → fg i) (y : (i : I) → fp i) {i : I} : has_vadd.vadd x y i = x i +ᵥ y i :=
  rfl

end pi

namespace equiv

/-- `v ↦ v +ᵥ p` as an equivalence. -/
def vadd_const {G : Type u_1} {P : Type u_2} [add_group G] [add_torsor G P] (p : P) : G ≃ P :=
  mk (fun (v : G) => v +ᵥ p) (fun (p' : P) => p' -ᵥ p) sorry sorry

@[simp] theorem coe_vadd_const {G : Type u_1} {P : Type u_2} [add_group G] [add_torsor G P] (p : P) : ⇑(vadd_const p) = fun (v : G) => v +ᵥ p :=
  rfl

@[simp] theorem coe_vadd_const_symm {G : Type u_1} {P : Type u_2} [add_group G] [add_torsor G P] (p : P) : ⇑(equiv.symm (vadd_const p)) = fun (p' : P) => p' -ᵥ p :=
  rfl

/-- `p' ↦ p -ᵥ p'` as an equivalence. -/
def const_vsub {G : Type u_1} {P : Type u_2} [add_group G] [add_torsor G P] (p : P) : P ≃ G :=
  mk (has_vsub.vsub p) (fun (v : G) => -v +ᵥ p) sorry sorry

@[simp] theorem coe_const_vsub {G : Type u_1} {P : Type u_2} [add_group G] [add_torsor G P] (p : P) : ⇑(const_vsub p) = has_vsub.vsub p :=
  rfl

@[simp] theorem coe_const_vsub_symm {G : Type u_1} {P : Type u_2} [add_group G] [add_torsor G P] (p : P) : ⇑(equiv.symm (const_vsub p)) = fun (v : G) => -v +ᵥ p :=
  rfl

/-- The permutation given by `p ↦ v +ᵥ p`. -/
def const_vadd {G : Type u_1} (P : Type u_2) [add_group G] [add_torsor G P] (v : G) : perm P :=
  mk (has_vadd.vadd v) (has_vadd.vadd (-v)) sorry sorry

@[simp] theorem coe_const_vadd {G : Type u_1} (P : Type u_2) [add_group G] [add_torsor G P] (v : G) : ⇑(const_vadd P v) = has_vadd.vadd v :=
  rfl

@[simp] theorem const_vadd_zero (G : Type u_1) (P : Type u_2) [add_group G] [add_torsor G P] : const_vadd P 0 = 1 :=
  ext (zero_vadd G)

@[simp] theorem const_vadd_add {G : Type u_1} (P : Type u_2) [add_group G] [add_torsor G P] (v₁ : G) (v₂ : G) : const_vadd P (v₁ + v₂) = const_vadd P v₁ * const_vadd P v₂ :=
  ext fun (p : P) => Eq.symm (vadd_assoc v₁ v₂ p)

/-- `equiv.const_vadd` as a homomorphism from `multiplicative G` to `equiv.perm P` -/
def const_vadd_hom {G : Type u_1} (P : Type u_2) [add_group G] [add_torsor G P] : multiplicative G →* perm P :=
  monoid_hom.mk (fun (v : multiplicative G) => const_vadd P (coe_fn multiplicative.to_add v)) (const_vadd_zero G P) sorry

/-- Point reflection in `x` as a permutation. -/
def point_reflection {G : Type u_1} {P : Type u_2} [add_group G] [add_torsor G P] (x : P) : perm P :=
  equiv.trans (const_vsub x) (vadd_const x)

theorem point_reflection_apply {G : Type u_1} {P : Type u_2} [add_group G] [add_torsor G P] (x : P) (y : P) : coe_fn (point_reflection x) y = x -ᵥ y +ᵥ x :=
  rfl

@[simp] theorem point_reflection_symm {G : Type u_1} {P : Type u_2} [add_group G] [add_torsor G P] (x : P) : equiv.symm (point_reflection x) = point_reflection x := sorry

@[simp] theorem point_reflection_self {G : Type u_1} {P : Type u_2} [add_group G] [add_torsor G P] (x : P) : coe_fn (point_reflection x) x = x :=
  vsub_vadd x x

theorem point_reflection_involutive {G : Type u_1} {P : Type u_2} [add_group G] [add_torsor G P] (x : P) : function.involutive ⇑(point_reflection x) := sorry

/-- `x` is the only fixed point of `point_reflection x`. This lemma requires
`x + x = y + y ↔ x = y`. There is no typeclass to use here, so we add it as an explicit argument. -/
theorem point_reflection_fixed_iff_of_injective_bit0 {G : Type u_1} {P : Type u_2} [add_group G] [add_torsor G P] {x : P} {y : P} (h : function.injective bit0) : coe_fn (point_reflection x) y = y ↔ y = x := sorry

theorem injective_point_reflection_left_of_injective_bit0 {G : Type u_1} {P : Type u_2} [add_comm_group G] [add_torsor G P] (h : function.injective bit0) (y : P) : function.injective fun (x : P) => coe_fn (point_reflection x) y := sorry


open classical

variable p : Prop

example (h : ¬¬p) : p :=
  by_cases
    (assume h1 : p, h1)
    (assume h1 : ¬p, absurd h1 h)