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

import ring_theory.mv_polynomial.basic

/-!
# Multivariate polynomials over fields

This file contains basic facts about multivariate polynomials over fields, for example that the
dimension of the space of multivariate polynomials over a field is equal to the cardinality of
finitely supported functions from the indexing set to `ℕ`.
-/

noncomputable theory

open_locale classical

open set linear_map submodule
open_locale big_operators

namespace mv_polynomial
universes u v
variables {σ : Type u} {K : Type v}
variables (σ K) [field K]

lemma quotient_mk_comp_C_injective (I : ideal (mv_polynomial σ K)) (hI : I ≠ ⊤) :
  function.injective ((ideal.quotient.mk I).comp mv_polynomial.C) :=
begin
  refine (injective_iff_map_eq_zero _).2 (λ x hx, _),
  rw [ring_hom.comp_apply, ideal.quotient.eq_zero_iff_mem] at hx,
  refine classical.by_contradiction (λ hx0, absurd (I.eq_top_iff_one.2 _) hI),
  have := I.mul_mem_left (mv_polynomial.C x⁻¹) hx,
  rwa [← mv_polynomial.C.map_mul, inv_mul_cancel hx0, mv_polynomial.C_1] at this,
end

end mv_polynomial

namespace mv_polynomial

universe u
variables {σ : Type u} {K : Type u} [field K]

open_locale classical

lemma dim_mv_polynomial : module.rank K (mv_polynomial σ K) = cardinal.mk (σ →₀ ℕ) :=
by rw [← cardinal.lift_inj, ← (basis_monomials σ K).mk_eq_dim]

end mv_polynomial


theorem add_one_eq_succ (d : mynat) : d + 1 = succ d :=
begin
symmetry, refl,
end


import .quantum_state
import .paired_states

namespace quantum

/-
  Defines an quantum states as an instance of an inner product space as
  well as some useful lemmas for combining inner products with operators,
  tensor products etc.
-/

variables {n m p q : ℕ}

def inner_product {n : ℕ} : QState n 1 → QState n 1 → ℂ :=
 λφ ψ, matrix.trace ((φ†) ⬝ ψ)

notation `⟪` u `|` v `⟫` := inner_product u v
notation `|` z `|²`:= complex.norm_sq z

--helpers for inner_product
lemma ip_to_trace {n : ℕ} (ψ φ : QState n 1) :
 ⟪φ|ψ⟫ = finset.univ.sum (λ (x : fin 1), (matrix.diag (φ† ⬝ ψ) x)) :=
calc ⟪φ|ψ⟫
  = matrix.trace (φ† ⬝ ψ) : by rw [inner_product]
... = finset.univ.sum (λ (x : fin 1), (matrix.diag (φ† ⬝ ψ) x)) : by rw [matrix.trace]

lemma mul_ct_def {n : ℕ} (ψ φ : QState n 1) :
 φ† ⬝ ψ = λ (i k : fin 1), (matrix.dot_product (λ (j : fin n), φ† i j) (λ (j : fin n), ψ j k)) :=
by rw [matrix.mul]

lemma dot_prod_def {n : ℕ} (ψ φ : QState n 1) :
 (λ(i : fin 1) (k : fin 1), (matrix.dot_product (λ (j : fin n), φ† i j) (λ (j : fin n), ψ j k))) = (λ(i : fin 1) (k : fin 1), finset.univ.sum (λ (j : fin n), (φ† i j) * (ψ j k))) :=
begin
  funext i j,
  rw [matrix.dot_product],
end

lemma conj_transpose_def {n : ℕ} (ψ : QState n 1) (i : fin n) (j : fin 1) :
 (ψ†) j i = (ψ i j)^* :=
by rw [matrix.conj_transpose_apply]

lemma conj_tranpose_in_sum {n : ℕ} (ψ : QState n 1) :
 ∀(i k : fin 1), (λ (j : fin n), (ψ† i j) * ψ j k) = (λ (j : fin n), (ψ j i)^* * ψ j k) :=
begin
  intros i k,
  funext j,
  rw [conj_transpose_def],
end

lemma inner_product_apply {n : ℕ} (φ ψ: QState n 1) :
 ⟪φ|ψ⟫ = (finset.sum finset.univ (λ (x : fin 1), matrix.diag (λ (i k : fin 1), finset.sum finset.univ (λ (j : fin n), ((φ†) i j) * ((ψ) j k))) x)) :=
begin
  rw [ip_to_trace, mul_ct_def, dot_prod_def],
end

lemma le_iff_ge {a b : ℝ} : b ≤ a ↔ a ≥ b:= iff.rfl
lemma gt_of_ge_and_ne {a b : ℝ} (hne: ¬a = b) (hge : a ≥ b) : a > b :=
begin
  exact ne.lt_of_le (ne.symm hne) hge
end

lemma zero_of_sum_eq_zero {n : ℕ} (x : fin n → ℂ) :
 finset.sum finset.univ (λ(i : fin n), complex.norm_sq (x i) : fin n → ℂ) = 0 → ∀(i : fin n), complex.norm_sq (x i) = 0 :=
begin
  intro hzero,
  intro i,
  have h_re_zero : (finset.sum finset.univ (λ(i : fin n), (complex.norm_sq (x i)))) = 0, {
    norm_cast at hzero,
    exact hzero,
  },
  apply (finset.sum_eq_zero_iff_of_nonneg _).mp h_re_zero,
  {simp},
  {intros j j_in_set,
  apply complex.norm_sq_nonneg,}
end

instance inner_product_space {n : ℕ} : inner_product_space.core ℂ (QState n 1) :=
 {inner := λφ ψ, ⟪φ|ψ⟫,
  conj_sym := begin
    intros φ ψ,
    rw [star_ring_end_apply],
    calc ⟪ψ|φ⟫^*
     = (matrix.trace (ψ† ⬝ φ))^* : by rw [inner_product]
     ... = (matrix.trace ((ψ† ⬝ φ)††))^* : by rw [matrix.conj_transpose_conj_transpose]
     ... = (matrix.trace ((φ† ⬝ ψ††)†))^* : by rw [matrix.conj_transpose_mul]
     ... = (matrix.trace ((φ† ⬝ ψ)†))^* : by rw [matrix.conj_transpose_conj_transpose]
     ... = (matrix.trace (φ† ⬝ ψ))^*^* : by rw [matrix.trace_conj_transpose]
     ... = matrix.trace (φ† ⬝ ψ) : by rw [star_star]
     ... = ⟪φ|ψ⟫ : by rw [inner_product],
  end,
  add_left := begin
    intros ψ₁ ψ₂ φ,
    calc ⟪(ψ₁ + ψ₂)|φ⟫
      = matrix.trace ((ψ₁ + ψ₂)† ⬝ φ) : by rw [inner_product]
      ... = matrix.trace ((ψ₁† + ψ₂†) ⬝ φ) : by rw [matrix.conj_transpose_add]
      ... = matrix.trace ((ψ₁† ⬝ φ) + (ψ₂† ⬝ φ)) : by rw [matrix.add_mul]
      ... = matrix.trace (ψ₁† ⬝ φ) + matrix.trace (ψ₂† ⬝ φ) : by rw [matrix.trace_add]
      ... = ⟪ψ₁|φ⟫ + ⟪ψ₂|φ⟫ : by rw [inner_product],
  end,
  smul_left := begin
    intros φ ψ c,
    rw [star_ring_end_apply],
    calc ⟪c • φ|ψ⟫
      = matrix.trace ((c • φ)† ⬝ ψ) : by rw [inner_product]
      ... = (c^*) * (matrix.trace (φ† ⬝ ψ)) : by begin rw [matrix.conj_transpose_smul], simp end
      ... = (c^*) * ⟪φ|ψ⟫ : by rw [inner_product],
      end,
  nonneg_re := begin
    intro ψ,
    rw [le_iff_ge],
    calc (is_R_or_C.re ⟪ψ|ψ⟫)
     = is_R_or_C.re (finset.sum finset.univ (λ (x : fin 1), matrix.diag (λ (i k : fin 1), finset.sum finset.univ (λ (j : fin n), ((ψ†) i j) * ψ j k)) x)) :
     by rw [ip_to_trace, mul_ct_def, dot_prod_def]
     ... = finset.sum finset.univ (λ (x : fin n), (ψ x 0).re * (ψ x 0).re + (ψ x 0).im * (ψ x 0).im) : by simp
     ... = finset.sum finset.univ (λ (x : fin n), complex.norm_sq (ψ x 0)) : by simp [complex.norm_sq_apply]
     ... ≥ 0 : by begin
      have h_psi_nonneg : ∀ (i : fin n), i ∈ finset.univ → 0 ≤ complex.norm_sq (ψ i 0), {
        intros i hi,
        exact complex.norm_sq_nonneg (ψ i 0)
      },
      exact finset.sum_nonneg h_psi_nonneg,
     end
  end,
  definite := begin
    intros ψ hzero,

    have hsum : ⟪ψ|ψ⟫ = finset.sum finset.univ (λ (x : fin n), complex.norm_sq (ψ x 0)), {
      rw [inner_product_apply],
      simp,
      apply eq.symm,
      simp [complex.norm_sq_eq_conj_mul_self],
    },

    rw [hsum] at hzero,

    have h_component_zero: ∀(i : fin n), complex.norm_sq (ψ i 0) = 0, {
        apply zero_of_sum_eq_zero (λ(x : fin n), (ψ x 0)),
        exact hzero,
    },

    have all_components_zero: ∀ (i : fin n) (j : fin 1), ψ i j = 0, {
        intros i j,
        apply complex.norm_sq_eq_zero.mp,
        have hj : j = 0, by simp,
        rw [hj],
        exact h_component_zero i,
    },
    funext i j,
    exact all_components_zero i j,
  end}

lemma inner_prod_matrix_ct (ψ φ : QState n 1) (M : matrix (fin n) (fin n) ℂ) :
 ⟪φ|(M† ⬝ ψ)⟫ = ⟪(M ⬝ φ)|ψ⟫ :=
calc  ⟪φ|(M† ⬝ ψ)⟫
 = matrix.trace (φ† ⬝ (M† ⬝ ψ)) : by rw [inner_product]
 ... = matrix.trace ((φ† ⬝ M†) ⬝ ψ) : by rw [matrix.mul_assoc]
 ... = matrix.trace ((φ† ⬝ M†)†† ⬝ ψ) : by rw [matrix.conj_transpose_conj_transpose]
 ... = matrix.trace ((M†† ⬝ φ††)† ⬝ ψ) : by rw [matrix.conj_transpose_mul]
 ... = matrix.trace ((M ⬝ φ††)† ⬝ ψ) : by rw [matrix.conj_transpose_conj_transpose]
 ... = matrix.trace ((M ⬝ φ)† ⬝ ψ) : by rw [matrix.conj_transpose_conj_transpose]
 ... = ⟪(M ⬝ φ)|ψ⟫ : by rw [inner_product]

lemma inner_prod_indep_states_eq_prod (u v u' v' : QState 2 1) :
 ⟪(u ⊗ v)|(u' ⊗ v')⟫ = ⟪u|u'⟫ * ⟪v|v'⟫ :=
begin
  simp [inner_product_apply, tensor_prod_vec],
  rw [distrib_prop],
  rw [two_times_two_is_four],
  rw [extract_sum],
  rw [show (2 : fin 4) = @fin.succ 4 1, by refl],
  rw [show (↑(fin.succ (1 : fin 4)) : fin 4) = ((fin.succ (1 : fin 4)) : fin 4), by refl],
  rw [matrix.cons_val_zero, matrix.cons_val_zero, matrix.cons_val_one, matrix.cons_val_one],
  rw [matrix.cons_val_succ, matrix.vec_head, matrix.vec_head, matrix.cons_val_zero, matrix.cons_val_zero],
  rw [show (↑(1 : fin 4) : fin 3) = (1 : fin 3), by refl],
  rw [matrix.cons_val_one, matrix.cons_val_succ, matrix.cons_val_one],
  rw [show (3 : fin 4) = @fin.succ 4 (@fin.succ 4 1), by refl],
  rw [show (↑(fin.succ (↑(fin.succ (1 : fin 4)) : fin 4)) : fin 4) = ((fin.succ (fin.succ (1 : fin 4))) : fin 4), by refl],
  rw [matrix.vec_head, matrix.vec_head, matrix.cons_val_succ, matrix.cons_val_succ, matrix.cons_val_succ, matrix.cons_val_succ, matrix.cons_val_zero, matrix.cons_val_zero],
  rw [show (↑(1 : fin 4) : fin 2) = (1 : fin 2), by refl],
  rw [matrix.cons_val_one, matrix.cons_val_one, matrix.vec_head, matrix.vec_head],
  calc  (u 0 0 * v 0 0)^* * (u' 0 0 * v' 0 0) +
        (u 0 0 * v 1 0)^* * (u' 0 0 * v' 1 0) +
        (u 1 0 * v 0 0)^* * (u' 1 0 * v' 0 0) +
        (u 1 0 * v 1 0)^* * (u' 1 0 * v' 1 0)
   = ((u 0 0)^* * (v 0 0)^*) * (u' 0 0 * v' 0 0) +
        ((u 0 0)^* * (v 1 0)^*) * (u' 0 0 * v' 1 0) +
        ((u 1 0)^* * (v 0 0)^*) * (u' 1 0 * v' 0 0) +
        ((u 1 0)^* * (v 1 0)^*) * (u' 1 0 * v' 1 0) : by rw [star_mul', star_mul', star_mul', star_mul']
  ... = (u 0 0)^* * u' 0 0 * ((v 0 0)^* * v' 0 0) +
        (u 0 0)^* * u' 0 0 * ((v 1 0)^* * v' 1 0) +
        (u 1 0)^* * u' 1 0 * ((v 0 0)^* * v' 0 0) +
        (u 1 0)^* * u' 1 0 * ((v 1 0)^* * v' 1 0) : by ring,
end
 -- probability of finding particle in the +z state in the -z state
-- (they are orthogonal so will be zero)
lemma z_plus_prod_z_minus : |⟪z₊|z₋⟫|² = 0 :=
begin
  rw [inner_product_apply, z_plus, z_minus],
  simp,
end

-- probability of finding particle in the +z state in the +z state
-- (they are equal and normlized so will be one)
lemma z_plus_prod_z_plus : |⟪z₊|z₊⟫|² = 1 :=
begin
  rw [inner_product_apply, z_plus],
  simp,
end

lemma z_plus_prod_z_plus' : ⟪z₊|z₊⟫ = 1 :=
begin
  rw [inner_product_apply, z_plus],
  simp,
end

-- probability of finding particle in the +z state in the +x state
lemma z_plus_prod_x_plus : |⟪z₊|x₊⟫|² = 1/2 :=
begin
  rw [inner_product_apply, z_plus, x_plus],
  simp,
end

-- probability of finding particle in the +z state in the -x state
lemma z_plus_prod_x_minus : |⟪z₊|x₋⟫|² = 1/2 :=
begin
  rw [inner_product_apply, z_plus, x_minus],
  simp,
end

-- probability of finding particle in the +z state in the +y state
lemma z_plus_prod_y_plus : |⟪z₊|y₊⟫|² = 1/2 :=
begin
  rw [inner_product_apply, z_plus, y_plus],
  simp,
end

-- simple example of a state representing a pair of particles
lemma z_plus_z_plus_is_basis : |z₊z₊⟩ = !![1; 0; 0; 0] :=
begin
  rw [z_plus_z_plus, tensor_prod_vec, z_plus],
  simp,
end

end quantum


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

! This file was ported from Lean 3 source module data.set.intervals.surj_on
! leanprover-community/mathlib commit c3291da49cfa65f0d43b094750541c0731edc932
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Set.Intervals.Basic
import Mathbin.Data.Set.Function

/-!
# Monotone surjective functions are surjective on intervals

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

A monotone surjective function sends any interval in the domain onto the interval with corresponding
endpoints in the range.  This is expressed in this file using `set.surj_on`, and provided for all
permutations of interval endpoints.
-/

variable {α : Type _} {β : Type _} [LinearOrder α] [PartialOrder β] {f : α → β}

open Set Function

open OrderDual (toDual)

/- warning: surj_on_Ioo_of_monotone_surjective -> surjOn_Ioo_of_monotone_surjective is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} [_inst_1 : LinearOrder.{u1} α] [_inst_2 : PartialOrder.{u2} β] {f : α -> β}, (Monotone.{u1, u2} α β (PartialOrder.toPreorder.{u1} α (SemilatticeInf.toPartialOrder.{u1} α (Lattice.toSemilatticeInf.{u1} α (LinearOrder.toLattice.{u1} α _inst_1)))) (PartialOrder.toPreorder.{u2} β _inst_2) f) -> (Function.Surjective.{succ u1, succ u2} α β f) -> (forall (a : α) (b : α), Set.SurjOn.{u1, u2} α β f (Set.Ioo.{u1} α (PartialOrder.toPreorder.{u1} α (SemilatticeInf.toPartialOrder.{u1} α (Lattice.toSemilatticeInf.{u1} α (LinearOrder.toLattice.{u1} α _inst_1)))) a b) (Set.Ioo.{u2} β (PartialOrder.toPreorder.{u2} β _inst_2) (f a) (f b)))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} [_inst_1 : LinearOrder.{u2} α] [_inst_2 : PartialOrder.{u1} β] {f : α -> β}, (Monotone.{u2, u1} α β (PartialOrder.toPreorder.{u2} α (SemilatticeInf.toPartialOrder.{u2} α (Lattice.toSemilatticeInf.{u2} α (DistribLattice.toLattice.{u2} α (instDistribLattice.{u2} α _inst_1))))) (PartialOrder.toPreorder.{u1} β _inst_2) f) -> (Function.Surjective.{succ u2, succ u1} α β f) -> (forall (a : α) (b : α), Set.SurjOn.{u2, u1} α β f (Set.Ioo.{u2} α (PartialOrder.toPreorder.{u2} α (SemilatticeInf.toPartialOrder.{u2} α (Lattice.toSemilatticeInf.{u2} α (DistribLattice.toLattice.{u2} α (instDistribLattice.{u2} α _inst_1))))) a b) (Set.Ioo.{u1} β (PartialOrder.toPreorder.{u1} β _inst_2) (f a) (f b)))
Case conversion may be inaccurate. Consider using '#align surj_on_Ioo_of_monotone_surjective surjOn_Ioo_of_monotone_surjectiveₓ'. -/
theorem surjOn_Ioo_of_monotone_surjective (h_mono : Monotone f) (h_surj : Function.Surjective f)
    (a b : α) : SurjOn f (Ioo a b) (Ioo (f a) (f b)) :=
  by
  intro p hp
  rcases h_surj p with ⟨x, rfl⟩
  refine' ⟨x, mem_Ioo.2 _, rfl⟩
  contrapose! hp
  exact fun h => h.2.not_le (h_mono <| hp <| h_mono.reflect_lt h.1)
#align surj_on_Ioo_of_monotone_surjective surjOn_Ioo_of_monotone_surjective

/- warning: surj_on_Ico_of_monotone_surjective -> surjOn_Ico_of_monotone_surjective is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} [_inst_1 : LinearOrder.{u1} α] [_inst_2 : PartialOrder.{u2} β] {f : α -> β}, (Monotone.{u1, u2} α β (PartialOrder.toPreorder.{u1} α (SemilatticeInf.toPartialOrder.{u1} α (Lattice.toSemilatticeInf.{u1} α (LinearOrder.toLattice.{u1} α _inst_1)))) (PartialOrder.toPreorder.{u2} β _inst_2) f) -> (Function.Surjective.{succ u1, succ u2} α β f) -> (forall (a : α) (b : α), Set.SurjOn.{u1, u2} α β f (Set.Ico.{u1} α (PartialOrder.toPreorder.{u1} α (SemilatticeInf.toPartialOrder.{u1} α (Lattice.toSemilatticeInf.{u1} α (LinearOrder.toLattice.{u1} α _inst_1)))) a b) (Set.Ico.{u2} β (PartialOrder.toPreorder.{u2} β _inst_2) (f a) (f b)))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} [_inst_1 : LinearOrder.{u2} α] [_inst_2 : PartialOrder.{u1} β] {f : α -> β}, (Monotone.{u2, u1} α β (PartialOrder.toPreorder.{u2} α (SemilatticeInf.toPartialOrder.{u2} α (Lattice.toSemilatticeInf.{u2} α (DistribLattice.toLattice.{u2} α (instDistribLattice.{u2} α _inst_1))))) (PartialOrder.toPreorder.{u1} β _inst_2) f) -> (Function.Surjective.{succ u2, succ u1} α β f) -> (forall (a : α) (b : α), Set.SurjOn.{u2, u1} α β f (Set.Ico.{u2} α (PartialOrder.toPreorder.{u2} α (SemilatticeInf.toPartialOrder.{u2} α (Lattice.toSemilatticeInf.{u2} α (DistribLattice.toLattice.{u2} α (instDistribLattice.{u2} α _inst_1))))) a b) (Set.Ico.{u1} β (PartialOrder.toPreorder.{u1} β _inst_2) (f a) (f b)))
Case conversion may be inaccurate. Consider using '#align surj_on_Ico_of_monotone_surjective surjOn_Ico_of_monotone_surjectiveₓ'. -/
theorem surjOn_Ico_of_monotone_surjective (h_mono : Monotone f) (h_surj : Function.Surjective f)
    (a b : α) : SurjOn f (Ico a b) (Ico (f a) (f b)) :=
  by
  obtain hab | hab := lt_or_le a b
  · intro p hp
    rcases eq_left_or_mem_Ioo_of_mem_Ico hp with (rfl | hp')
    · exact mem_image_of_mem f (left_mem_Ico.mpr hab)
    · have := surjOn_Ioo_of_monotone_surjective h_mono h_surj a b hp'
      exact image_subset f Ioo_subset_Ico_self this
  · rw [Ico_eq_empty (h_mono hab).not_lt]
    exact surj_on_empty f _
#align surj_on_Ico_of_monotone_surjective surjOn_Ico_of_monotone_surjective

/- warning: surj_on_Ioc_of_monotone_surjective -> surjOn_Ioc_of_monotone_surjective is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} [_inst_1 : LinearOrder.{u1} α] [_inst_2 : PartialOrder.{u2} β] {f : α -> β}, (Monotone.{u1, u2} α β (PartialOrder.toPreorder.{u1} α (SemilatticeInf.toPartialOrder.{u1} α (Lattice.toSemilatticeInf.{u1} α (LinearOrder.toLattice.{u1} α _inst_1)))) (PartialOrder.toPreorder.{u2} β _inst_2) f) -> (Function.Surjective.{succ u1, succ u2} α β f) -> (forall (a : α) (b : α), Set.SurjOn.{u1, u2} α β f (Set.Ioc.{u1} α (PartialOrder.toPreorder.{u1} α (SemilatticeInf.toPartialOrder.{u1} α (Lattice.toSemilatticeInf.{u1} α (LinearOrder.toLattice.{u1} α _inst_1)))) a b) (Set.Ioc.{u2} β (PartialOrder.toPreorder.{u2} β _inst_2) (f a) (f b)))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} [_inst_1 : LinearOrder.{u2} α] [_inst_2 : PartialOrder.{u1} β] {f : α -> β}, (Monotone.{u2, u1} α β (PartialOrder.toPreorder.{u2} α (SemilatticeInf.toPartialOrder.{u2} α (Lattice.toSemilatticeInf.{u2} α (DistribLattice.toLattice.{u2} α (instDistribLattice.{u2} α _inst_1))))) (PartialOrder.toPreorder.{u1} β _inst_2) f) -> (Function.Surjective.{succ u2, succ u1} α β f) -> (forall (a : α) (b : α), Set.SurjOn.{u2, u1} α β f (Set.Ioc.{u2} α (PartialOrder.toPreorder.{u2} α (SemilatticeInf.toPartialOrder.{u2} α (Lattice.toSemilatticeInf.{u2} α (DistribLattice.toLattice.{u2} α (instDistribLattice.{u2} α _inst_1))))) a b) (Set.Ioc.{u1} β (PartialOrder.toPreorder.{u1} β _inst_2) (f a) (f b)))
Case conversion may be inaccurate. Consider using '#align surj_on_Ioc_of_monotone_surjective surjOn_Ioc_of_monotone_surjectiveₓ'. -/
theorem surjOn_Ioc_of_monotone_surjective (h_mono : Monotone f) (h_surj : Function.Surjective f)
    (a b : α) : SurjOn f (Ioc a b) (Ioc (f a) (f b)) := by
  simpa using surjOn_Ico_of_monotone_surjective h_mono.dual h_surj (to_dual b) (to_dual a)
#align surj_on_Ioc_of_monotone_surjective surjOn_Ioc_of_monotone_surjective

/- warning: surj_on_Icc_of_monotone_surjective -> surjOn_Icc_of_monotone_surjective is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} [_inst_1 : LinearOrder.{u1} α] [_inst_2 : PartialOrder.{u2} β] {f : α -> β}, (Monotone.{u1, u2} α β (PartialOrder.toPreorder.{u1} α (SemilatticeInf.toPartialOrder.{u1} α (Lattice.toSemilatticeInf.{u1} α (LinearOrder.toLattice.{u1} α _inst_1)))) (PartialOrder.toPreorder.{u2} β _inst_2) f) -> (Function.Surjective.{succ u1, succ u2} α β f) -> (forall {a : α} {b : α}, (LE.le.{u1} α (Preorder.toLE.{u1} α (PartialOrder.toPreorder.{u1} α (SemilatticeInf.toPartialOrder.{u1} α (Lattice.toSemilatticeInf.{u1} α (LinearOrder.toLattice.{u1} α _inst_1))))) a b) -> (Set.SurjOn.{u1, u2} α β f (Set.Icc.{u1} α (PartialOrder.toPreorder.{u1} α (SemilatticeInf.toPartialOrder.{u1} α (Lattice.toSemilatticeInf.{u1} α (LinearOrder.toLattice.{u1} α _inst_1)))) a b) (Set.Icc.{u2} β (PartialOrder.toPreorder.{u2} β _inst_2) (f a) (f b))))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} [_inst_1 : LinearOrder.{u2} α] [_inst_2 : PartialOrder.{u1} β] {f : α -> β}, (Monotone.{u2, u1} α β (PartialOrder.toPreorder.{u2} α (SemilatticeInf.toPartialOrder.{u2} α (Lattice.toSemilatticeInf.{u2} α (DistribLattice.toLattice.{u2} α (instDistribLattice.{u2} α _inst_1))))) (PartialOrder.toPreorder.{u1} β _inst_2) f) -> (Function.Surjective.{succ u2, succ u1} α β f) -> (forall {a : α} {b : α}, (LE.le.{u2} α (Preorder.toLE.{u2} α (PartialOrder.toPreorder.{u2} α (SemilatticeInf.toPartialOrder.{u2} α (Lattice.toSemilatticeInf.{u2} α (DistribLattice.toLattice.{u2} α (instDistribLattice.{u2} α _inst_1)))))) a b) -> (Set.SurjOn.{u2, u1} α β f (Set.Icc.{u2} α (PartialOrder.toPreorder.{u2} α (SemilatticeInf.toPartialOrder.{u2} α (Lattice.toSemilatticeInf.{u2} α (DistribLattice.toLattice.{u2} α (instDistribLattice.{u2} α _inst_1))))) a b) (Set.Icc.{u1} β (PartialOrder.toPreorder.{u1} β _inst_2) (f a) (f b))))
Case conversion may be inaccurate. Consider using '#align surj_on_Icc_of_monotone_surjective surjOn_Icc_of_monotone_surjectiveₓ'. -/
-- to see that the hypothesis `a ≤ b` is necessary, consider a constant function
theorem surjOn_Icc_of_monotone_surjective (h_mono : Monotone f) (h_surj : Function.Surjective f)
    {a b : α} (hab : a ≤ b) : SurjOn f (Icc a b) (Icc (f a) (f b)) :=
  by
  intro p hp
  rcases eq_endpoints_or_mem_Ioo_of_mem_Icc hp with (rfl | rfl | hp')
  · exact ⟨a, left_mem_Icc.mpr hab, rfl⟩
  · exact ⟨b, right_mem_Icc.mpr hab, rfl⟩
  · have := surjOn_Ioo_of_monotone_surjective h_mono h_surj a b hp'
    exact image_subset f Ioo_subset_Icc_self this
#align surj_on_Icc_of_monotone_surjective surjOn_Icc_of_monotone_surjective

/- warning: surj_on_Ioi_of_monotone_surjective -> surjOn_Ioi_of_monotone_surjective is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} [_inst_1 : LinearOrder.{u1} α] [_inst_2 : PartialOrder.{u2} β] {f : α -> β}, (Monotone.{u1, u2} α β (PartialOrder.toPreorder.{u1} α (SemilatticeInf.toPartialOrder.{u1} α (Lattice.toSemilatticeInf.{u1} α (LinearOrder.toLattice.{u1} α _inst_1)))) (PartialOrder.toPreorder.{u2} β _inst_2) f) -> (Function.Surjective.{succ u1, succ u2} α β f) -> (forall (a : α), Set.SurjOn.{u1, u2} α β f (Set.Ioi.{u1} α (PartialOrder.toPreorder.{u1} α (SemilatticeInf.toPartialOrder.{u1} α (Lattice.toSemilatticeInf.{u1} α (LinearOrder.toLattice.{u1} α _inst_1)))) a) (Set.Ioi.{u2} β (PartialOrder.toPreorder.{u2} β _inst_2) (f a)))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} [_inst_1 : LinearOrder.{u2} α] [_inst_2 : PartialOrder.{u1} β] {f : α -> β}, (Monotone.{u2, u1} α β (PartialOrder.toPreorder.{u2} α (SemilatticeInf.toPartialOrder.{u2} α (Lattice.toSemilatticeInf.{u2} α (DistribLattice.toLattice.{u2} α (instDistribLattice.{u2} α _inst_1))))) (PartialOrder.toPreorder.{u1} β _inst_2) f) -> (Function.Surjective.{succ u2, succ u1} α β f) -> (forall (a : α), Set.SurjOn.{u2, u1} α β f (Set.Ioi.{u2} α (PartialOrder.toPreorder.{u2} α (SemilatticeInf.toPartialOrder.{u2} α (Lattice.toSemilatticeInf.{u2} α (DistribLattice.toLattice.{u2} α (instDistribLattice.{u2} α _inst_1))))) a) (Set.Ioi.{u1} β (PartialOrder.toPreorder.{u1} β _inst_2) (f a)))
Case conversion may be inaccurate. Consider using '#align surj_on_Ioi_of_monotone_surjective surjOn_Ioi_of_monotone_surjectiveₓ'. -/
theorem surjOn_Ioi_of_monotone_surjective (h_mono : Monotone f) (h_surj : Function.Surjective f)
    (a : α) : SurjOn f (Ioi a) (Ioi (f a)) :=
  by
  rw [← compl_Iic, ← compl_compl (Ioi (f a))]
  refine' maps_to.surj_on_compl _ h_surj
  exact fun x hx => (h_mono hx).not_lt
#align surj_on_Ioi_of_monotone_surjective surjOn_Ioi_of_monotone_surjective

/- warning: surj_on_Iio_of_monotone_surjective -> surjOn_Iio_of_monotone_surjective is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} [_inst_1 : LinearOrder.{u1} α] [_inst_2 : PartialOrder.{u2} β] {f : α -> β}, (Monotone.{u1, u2} α β (PartialOrder.toPreorder.{u1} α (SemilatticeInf.toPartialOrder.{u1} α (Lattice.toSemilatticeInf.{u1} α (LinearOrder.toLattice.{u1} α _inst_1)))) (PartialOrder.toPreorder.{u2} β _inst_2) f) -> (Function.Surjective.{succ u1, succ u2} α β f) -> (forall (a : α), Set.SurjOn.{u1, u2} α β f (Set.Iio.{u1} α (PartialOrder.toPreorder.{u1} α (SemilatticeInf.toPartialOrder.{u1} α (Lattice.toSemilatticeInf.{u1} α (LinearOrder.toLattice.{u1} α _inst_1)))) a) (Set.Iio.{u2} β (PartialOrder.toPreorder.{u2} β _inst_2) (f a)))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} [_inst_1 : LinearOrder.{u2} α] [_inst_2 : PartialOrder.{u1} β] {f : α -> β}, (Monotone.{u2, u1} α β (PartialOrder.toPreorder.{u2} α (SemilatticeInf.toPartialOrder.{u2} α (Lattice.toSemilatticeInf.{u2} α (DistribLattice.toLattice.{u2} α (instDistribLattice.{u2} α _inst_1))))) (PartialOrder.toPreorder.{u1} β _inst_2) f) -> (Function.Surjective.{succ u2, succ u1} α β f) -> (forall (a : α), Set.SurjOn.{u2, u1} α β f (Set.Iio.{u2} α (PartialOrder.toPreorder.{u2} α (SemilatticeInf.toPartialOrder.{u2} α (Lattice.toSemilatticeInf.{u2} α (DistribLattice.toLattice.{u2} α (instDistribLattice.{u2} α _inst_1))))) a) (Set.Iio.{u1} β (PartialOrder.toPreorder.{u1} β _inst_2) (f a)))
Case conversion may be inaccurate. Consider using '#align surj_on_Iio_of_monotone_surjective surjOn_Iio_of_monotone_surjectiveₓ'. -/
theorem surjOn_Iio_of_monotone_surjective (h_mono : Monotone f) (h_surj : Function.Surjective f)
    (a : α) : SurjOn f (Iio a) (Iio (f a)) :=
  @surjOn_Ioi_of_monotone_surjective _ _ _ _ _ h_mono.dual h_surj a
#align surj_on_Iio_of_monotone_surjective surjOn_Iio_of_monotone_surjective

/- warning: surj_on_Ici_of_monotone_surjective -> surjOn_Ici_of_monotone_surjective is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} [_inst_1 : LinearOrder.{u1} α] [_inst_2 : PartialOrder.{u2} β] {f : α -> β}, (Monotone.{u1, u2} α β (PartialOrder.toPreorder.{u1} α (SemilatticeInf.toPartialOrder.{u1} α (Lattice.toSemilatticeInf.{u1} α (LinearOrder.toLattice.{u1} α _inst_1)))) (PartialOrder.toPreorder.{u2} β _inst_2) f) -> (Function.Surjective.{succ u1, succ u2} α β f) -> (forall (a : α), Set.SurjOn.{u1, u2} α β f (Set.Ici.{u1} α (PartialOrder.toPreorder.{u1} α (SemilatticeInf.toPartialOrder.{u1} α (Lattice.toSemilatticeInf.{u1} α (LinearOrder.toLattice.{u1} α _inst_1)))) a) (Set.Ici.{u2} β (PartialOrder.toPreorder.{u2} β _inst_2) (f a)))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} [_inst_1 : LinearOrder.{u2} α] [_inst_2 : PartialOrder.{u1} β] {f : α -> β}, (Monotone.{u2, u1} α β (PartialOrder.toPreorder.{u2} α (SemilatticeInf.toPartialOrder.{u2} α (Lattice.toSemilatticeInf.{u2} α (DistribLattice.toLattice.{u2} α (instDistribLattice.{u2} α _inst_1))))) (PartialOrder.toPreorder.{u1} β _inst_2) f) -> (Function.Surjective.{succ u2, succ u1} α β f) -> (forall (a : α), Set.SurjOn.{u2, u1} α β f (Set.Ici.{u2} α (PartialOrder.toPreorder.{u2} α (SemilatticeInf.toPartialOrder.{u2} α (Lattice.toSemilatticeInf.{u2} α (DistribLattice.toLattice.{u2} α (instDistribLattice.{u2} α _inst_1))))) a) (Set.Ici.{u1} β (PartialOrder.toPreorder.{u1} β _inst_2) (f a)))
Case conversion may be inaccurate. Consider using '#align surj_on_Ici_of_monotone_surjective surjOn_Ici_of_monotone_surjectiveₓ'. -/
theorem surjOn_Ici_of_monotone_surjective (h_mono : Monotone f) (h_surj : Function.Surjective f)
    (a : α) : SurjOn f (Ici a) (Ici (f a)) :=
  by
  rw [← Ioi_union_left, ← Ioi_union_left]
  exact
    (surjOn_Ioi_of_monotone_surjective h_mono h_surj a).union_union
      (@image_singleton _ _ f a ▸ surj_on_image _ _)
#align surj_on_Ici_of_monotone_surjective surjOn_Ici_of_monotone_surjective

/- warning: surj_on_Iic_of_monotone_surjective -> surjOn_Iic_of_monotone_surjective is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} [_inst_1 : LinearOrder.{u1} α] [_inst_2 : PartialOrder.{u2} β] {f : α -> β}, (Monotone.{u1, u2} α β (PartialOrder.toPreorder.{u1} α (SemilatticeInf.toPartialOrder.{u1} α (Lattice.toSemilatticeInf.{u1} α (LinearOrder.toLattice.{u1} α _inst_1)))) (PartialOrder.toPreorder.{u2} β _inst_2) f) -> (Function.Surjective.{succ u1, succ u2} α β f) -> (forall (a : α), Set.SurjOn.{u1, u2} α β f (Set.Iic.{u1} α (PartialOrder.toPreorder.{u1} α (SemilatticeInf.toPartialOrder.{u1} α (Lattice.toSemilatticeInf.{u1} α (LinearOrder.toLattice.{u1} α _inst_1)))) a) (Set.Iic.{u2} β (PartialOrder.toPreorder.{u2} β _inst_2) (f a)))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} [_inst_1 : LinearOrder.{u2} α] [_inst_2 : PartialOrder.{u1} β] {f : α -> β}, (Monotone.{u2, u1} α β (PartialOrder.toPreorder.{u2} α (SemilatticeInf.toPartialOrder.{u2} α (Lattice.toSemilatticeInf.{u2} α (DistribLattice.toLattice.{u2} α (instDistribLattice.{u2} α _inst_1))))) (PartialOrder.toPreorder.{u1} β _inst_2) f) -> (Function.Surjective.{succ u2, succ u1} α β f) -> (forall (a : α), Set.SurjOn.{u2, u1} α β f (Set.Iic.{u2} α (PartialOrder.toPreorder.{u2} α (SemilatticeInf.toPartialOrder.{u2} α (Lattice.toSemilatticeInf.{u2} α (DistribLattice.toLattice.{u2} α (instDistribLattice.{u2} α _inst_1))))) a) (Set.Iic.{u1} β (PartialOrder.toPreorder.{u1} β _inst_2) (f a)))
Case conversion may be inaccurate. Consider using '#align surj_on_Iic_of_monotone_surjective surjOn_Iic_of_monotone_surjectiveₓ'. -/
theorem surjOn_Iic_of_monotone_surjective (h_mono : Monotone f) (h_surj : Function.Surjective f)
    (a : α) : SurjOn f (Iic a) (Iic (f a)) :=
  @surjOn_Ici_of_monotone_surjective _ _ _ _ _ h_mono.dual h_surj a
#align surj_on_Iic_of_monotone_surjective surjOn_Iic_of_monotone_surjective


/-
Copyright (c) 202 Yury G. Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury G. Kudryashov

! This file was ported from Lean 3 source module topology.metric_space.emetric_paracompact
! leanprover-community/mathlib commit 57ac39bd365c2f80589a700f9fbb664d3a1a30c2
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.SetTheory.Ordinal.Basic
import Mathlib.Tactic.WLOG
import Mathlib.Topology.MetricSpace.EMetricSpace
import Mathlib.Topology.Paracompact

/-!
# (Extended) metric spaces are paracompact

In this file we provide two instances:

* `EMetric.ParacompactSpace`: a `PseudoEMetricSpace` is paracompact; formalization is based
  on [MR0236876];
* `EMetric.normal_of_metric`: an `EMetricSpace` is a normal topological space.

## TODO

Generalize to `PseudoMetrizableSpace`s.

## Tags

metric space, paracompact space, normal space
-/

variable {α : Type _}

open ENNReal Topology Set

namespace EMetric

-- See note [lower instance priority]
/-- A `PseudoEMetricSpace` is always a paracompact space. Formalization is based
on [MR0236876]. -/
instance (priority := 100) [PseudoEMetricSpace α] : ParacompactSpace α := by
  /- We start with trivial observations about `1 / 2 ^ k`. Here and below we use `1 / 2 ^ k` in
    the comments and `2⁻¹ ^ k` in the code. -/
  have pow_pos : ∀ k : ℕ, (0 : ℝ≥0∞) < 2⁻¹ ^ k := fun k =>
    ENNReal.pow_pos (ENNReal.inv_pos.2 ENNReal.two_ne_top) _
  have hpow_le : ∀ {m n : ℕ}, m ≤ n → (2⁻¹ : ℝ≥0∞) ^ n ≤ 2⁻¹ ^ m := @fun m n h =>
    pow_le_pow_of_le_one' (ENNReal.inv_le_one.2 ENNReal.one_lt_two.le) h
  have h2pow : ∀ n : ℕ, 2 * (2⁻¹ : ℝ≥0∞) ^ (n + 1) = 2⁻¹ ^ n := fun n => by
    simp [pow_succ, ← mul_assoc, ENNReal.mul_inv_cancel]
  -- Consider an open covering `S : Set (Set α)`
  refine' ⟨fun ι s ho hcov => _⟩
  simp only [unionᵢ_eq_univ_iff] at hcov
  -- choose a well founded order on `S`
  -- porting note: todo: add lemma that claims `∃ i : LinearOrder ι, WellFoundedLT ι
  let _ : LinearOrder ι := by classical exact linearOrderOfSTO WellOrderingRel
  have wf : WellFounded ((· < ·) : ι → ι → Prop) := @IsWellFounded.wf ι WellOrderingRel _
  -- Let `ind x` be the minimal index `s : S` such that `x ∈ s`.
  set ind : α → ι := fun x => wf.min { i : ι | x ∈ s i } (hcov x)
  have mem_ind : ∀ x, x ∈ s (ind x) := fun x => wf.min_mem _ (hcov x)
  have nmem_of_lt_ind : ∀ {x i}, i < ind x → x ∉ s i := @fun x i hlt hxi =>
    wf.not_lt_min _ (hcov x) hxi hlt
  /- The refinement `D : ℕ → ι → Set α` is defined recursively. For each `n` and `i`, `D n i`
    is the union of balls `ball x (1 / 2 ^ n)` over all points `x` such that

    * `ind x = i`;
    * `x` does not belong to any `D m j`, `m < n`;
    * `ball x (3 / 2 ^ n) ⊆ s i`;

    We define this sequence using `Nat.strongRecOn'`, then restate it as `Dn` and `memD`.
  -/
  set D : ℕ → ι → Set α := fun n =>
    Nat.strongRecOn' n fun n D' i =>
      ⋃ (x : α) (hxs : ind x = i) (hb : ball x (3 * 2⁻¹ ^ n) ⊆ s i) (hlt :
        ∀ (m : ℕ) (H : m < n), ∀ (j : ι), x ∉ D' m H j), ball x (2⁻¹ ^ n) with hD
  have Dn : ∀ n i, D n i = ⋃ (x : α) (hxs : ind x = i) (hb : ball x (3 * 2⁻¹ ^ n) ⊆ s i)
      (hlt : ∀ m < n, ∀ (j : ι), x ∉ D m j), ball x (2⁻¹ ^ n) := fun n s => by
    simp only [hD]
    rw [Nat.strongRecOn'_beta]
  have memD : ∀ {n i y},
      y ∈ D n i ↔ ∃ x : α, ind x = i ∧ ball x (3 * 2⁻¹ ^ n) ⊆ s i ∧
        (∀ m < n, ∀ (j : ι), x ∉ D m j) ∧ edist y x < 2⁻¹ ^ n := by
    intro n i y
    rw [Dn n i]
    simp only [mem_unionᵢ, mem_ball, exists_prop]
  -- The sets `D n i` cover the whole space. Indeed, for each `x` we can choose `n` such that
  -- `ball x (3 / 2 ^ n) ⊆ s (ind x)`, then either `x ∈ D n i`, or `x ∈ D m i` for some `m < n`.
  have Dcov : ∀ x, ∃ n i, x ∈ D n i := fun x => by
    obtain ⟨n, hn⟩ : ∃ n : ℕ, ball x (3 * 2⁻¹ ^ n) ⊆ s (ind x) := by
      -- This proof takes 5 lines because we can't import `specific_limits` here
      rcases isOpen_iff.1 (ho <| ind x) x (mem_ind x) with ⟨ε, ε0, hε⟩
      have : 0 < ε / 3 := ENNReal.div_pos_iff.2 ⟨ε0.lt.ne', ENNReal.coe_ne_top⟩
      rcases ENNReal.exists_inv_two_pow_lt this.ne' with ⟨n, hn⟩
      refine' ⟨n, Subset.trans (ball_subset_ball _) hε⟩
      simpa only [div_eq_mul_inv, mul_comm] using (ENNReal.mul_lt_of_lt_div hn).le
    by_contra' h
    apply h n (ind x)
    exact memD.2 ⟨x, rfl, hn, fun _ _ _ => h _ _, mem_ball_self (pow_pos _)⟩
  -- Each `D n i` is a union of open balls, hence it is an open set
  have Dopen : ∀ n i, IsOpen (D n i) := fun n i => by
    rw [Dn]
    iterate 4 refine' isOpen_unionᵢ fun _ => _
    exact isOpen_ball
  -- the covering `D n i` is a refinement of the original covering: `D n i ⊆ s i`
  have HDS : ∀ n i, D n i ⊆ s i := fun n i x => by
    rw [memD]
    rintro ⟨y, rfl, hsub, -, hyx⟩
    refine hsub (hyx.trans_le <| le_mul_of_one_le_left' ?_)
    norm_num1
  -- Let us show the rest of the properties. Since the definition expects a family indexed
  -- by a single parameter, we use `ℕ × ι` as the domain.
  refine' ⟨ℕ × ι, fun ni => D ni.1 ni.2, fun _ => Dopen _ _, _, _, fun ni => ⟨ni.2, HDS _ _⟩⟩
  -- The sets `D n i` cover the whole space as we proved earlier
  · refine' unionᵢ_eq_univ_iff.2 fun x => _
    rcases Dcov x with ⟨n, i, h⟩
    exact ⟨⟨n, i⟩, h⟩
  /- Let us prove that the covering `D n i` is locally finite. Take a point `x` and choose
    `n`, `i` so that `x ∈ D n i`. Since `D n i` is an open set, we can choose `k` so that
    `B = ball x (1 / 2 ^ (n + k + 1)) ⊆ D n i`. -/
  · intro x
    rcases Dcov x with ⟨n, i, hn⟩
    have : D n i ∈ 𝓝 x := IsOpen.mem_nhds (Dopen _ _) hn
    rcases(nhds_basis_uniformity uniformity_basis_edist_inv_two_pow).mem_iff.1 this with
      ⟨k, -, hsub : ball x (2⁻¹ ^ k) ⊆ D n i⟩
    set B := ball x (2⁻¹ ^ (n + k + 1))
    refine' ⟨B, ball_mem_nhds _ (pow_pos _), _⟩
    -- The sets `D m i`, `m > n + k`, are disjoint with `B`
    have Hgt : ∀ m ≥ n + k + 1, ∀ (i : ι), Disjoint (D m i) B := fun m hm i => by
      rw [disjoint_iff_inf_le]
      rintro y ⟨hym, hyx⟩
      rcases memD.1 hym with ⟨z, rfl, _hzi, H, hz⟩
      -- porting note: `clear` needed due to `linarith` bug
      have : z ∉ ball x (2⁻¹ ^ k) := fun hz' => H n (by clear hz hD; linarith) i (hsub hz')
      apply this
      calc
        edist z x ≤ edist y z + edist y x := edist_triangle_left _ _ _
        _ < 2⁻¹ ^ m + 2⁻¹ ^ (n + k + 1) := (ENNReal.add_lt_add hz hyx)
        _ ≤ 2⁻¹ ^ (k + 1) + 2⁻¹ ^ (k + 1) :=
          -- porting note: `clear` needed due to `linarith` bug
          (add_le_add (hpow_le <| by clear hz hD; linarith) (hpow_le <| by clear hz hD; linarith))
        _ = 2⁻¹ ^ k := by rw [← two_mul, h2pow]
    -- For each `m ≤ n + k` there is at most one `j` such that `D m j ∩ B` is nonempty.
    have Hle : ∀ m ≤ n + k, Set.Subsingleton { j | (D m j ∩ B).Nonempty } := by
      rintro m hm j₁ ⟨y, hyD, hyB⟩ j₂ ⟨z, hzD, hzB⟩
      by_contra' h' : j₁ ≠ j₂
      wlog h : j₁ < j₂ generalizing j₁ j₂ y z
      · exact this z hzD hzB y hyD hyB h'.symm (h'.lt_or_lt.resolve_left h)
      rcases memD.1 hyD with ⟨y', rfl, hsuby, -, hdisty⟩
      rcases memD.1 hzD with ⟨z', rfl, -, -, hdistz⟩
      suffices : edist z' y' < 3 * 2⁻¹ ^ m
      exact nmem_of_lt_ind h (hsuby this)
      calc
        edist z' y' ≤ edist z' x + edist x y' := edist_triangle _ _ _
        _ ≤ edist z z' + edist z x + (edist y x + edist y y') :=
          (add_le_add (edist_triangle_left _ _ _) (edist_triangle_left _ _ _))
        _ < 2⁻¹ ^ m + 2⁻¹ ^ (n + k + 1) + (2⁻¹ ^ (n + k + 1) + 2⁻¹ ^ m) := by
          apply_rules [ENNReal.add_lt_add]
        _ = 2 * (2⁻¹ ^ m + 2⁻¹ ^ (n + k + 1)) := by simp only [two_mul, add_comm]
        _ ≤ 2 * (2⁻¹ ^ m + 2⁻¹ ^ (m + 1)) :=
          (mul_le_mul' le_rfl <| add_le_add le_rfl <| hpow_le (add_le_add hm le_rfl))
        _ = 3 * 2⁻¹ ^ m := by
          rw [mul_add, h2pow, ← two_add_one_eq_three, add_mul, one_mul]
    -- Finally, we glue `Hgt` and `Hle`
    have : (⋃ (m ≤ n + k) (i ∈ { i : ι | (D m i ∩ B).Nonempty }), {(m, i)}).Finite :=
      (finite_le_nat _).bunionᵢ' fun i hi =>
        (Hle i hi).finite.bunionᵢ' fun _ _ => finite_singleton _
    refine' this.subset fun I hI => _
    simp only [mem_unionᵢ]
    refine' ⟨I.1, _, I.2, hI, Prod.mk.eta.symm⟩
    exact not_lt.1 fun hlt => (Hgt I.1 hlt I.2).le_bot hI.choose_spec

-- see Note [lower instance priority]
instance (priority := 100) normal_of_emetric [EMetricSpace α] : NormalSpace α :=
  normal_of_paracompact_t2
#align emetric.normal_of_emetric EMetric.normal_of_emetric

end EMetric


import algebra.group data.set.basic group_theory.subgroup group_theory.quotient_group

open function quotient_group is_subgroup is_group_hom

universe u
--Todo: prove the first isomorphism theorem

variables {G : Type*} {H : Type*} [group G] [group H]
variables (N K : set G)
variables [is_subgroup N] [is_subgroup K]

-- introducing the group isomorphism
class is_group_isom (f : G → H) extends is_group_hom f : Prop :=
(group_bij : bijective f)

namespace is_group_isom

variables (f : G → H) [is_group_isom f]

def automorphism (f₁ : G → G) := is_group_isom f₁

--lemma quot_is_isom (f :)

theorem isomorphism_thm_one (φ : G → H) [is_group_hom φ] :
surjective φ → ∃ (f₂ : (quotient (ker φ)) → H), is_group_isom f₂ :=
begin
intros,
existsi _,
swap,
sorry,
end

end is_group_isom

class is_ring_isom {α : Type*} {β : Type*} [ring α] [ring β] (f : α → β) extends is_ring_hom f : Prop :=
(ring_bij : bijective f)

#print notation $
    -- s $ t means s(t) where s is a function, and t is the input. the reason this exists is because it has very low binding power, so you can evaluate t first, then s $ t, making it a better alternative to s(t)


import NBG.SetTheory.Axioms.Basic
open Classical

def isTransitive (X: Class) :=
  ∀(y z: Class),(y∈X) → (z∈y) → z ∈ X
class Transitive (X: Class) where
  isTransitive: isTransitive X

theorem TrClassisExists:
  ∃(Tr: Class), ∀(z: Class),
    (z∈Tr) ↔ ((z∈U) ∧ (isTransitive z)) := sorry

noncomputable def Tr : Class := choose TrClassisExists
noncomputable def Tr_def:
∀(z: Class),
    (z∈Tr) ↔ ((z∈U) ∧ (isTransitive z)) :=
  choose_spec TrClassisExists

theorem TrIsInductive: isInductive Tr := sorry
theorem OmegaIsInductive: isTransitive ω := sorry

theorem OmegaIsInTr: ω ⊂ Tr := sorry
theorem OmegaSubsetTr: ω ∈ Tr := sorry


import for_mathlib.nonarchimedean.basic
import for_mathlib.nonarchimedean.is_subgroups_basis

local prefix 𝓝:100 := nhds

variables {R : Type*} [comm_ring R]

open set lattice topological_add_group submodule

namespace ideal

-- Note: making the following an instance is useless, instance resolution would never guess I
def adic_basis (I : ideal R) : subgroups_basis R :=
begin
  apply subgroups_basis.of_indexed_submodules_of_comm  (λ n : ℕ, I^n),
  { intros i j,
    use (i + j),
    simp only [],
    rw pow_add,
    exact mul_le_inf },
  { intros r i,
    use i,
    exact le_trans mul_le_inf inf_le_right },
  { intro i,
    use i,
    exact le_trans mul_le_inf inf_le_left }
end

def adic_topology (I : ideal R) : topological_space R :=
begin
  letI := adic_basis I,
  exact (ring_filter_basis.to_add_group_filter_basis R).topology,
end
end ideal

def is_ideal_adic [H : topological_space R] [topological_ring R] (J : ideal R) : Prop :=
H = J.adic_topology

notation `is-`J`-adic` := is_ideal_adic J

lemma is_ideal_adic.mem_nhds_zero [topological_space R] [topological_ring R] {J : ideal R}
  (H : is-J-adic) {U : set R} : U ∈ 𝓝 (0 : R) ↔ ∃ n : ℕ, (J^n).carrier ⊆ U :=
begin
  dsimp [is_ideal_adic] at H,
  erw [H, subgroups_basis.mem_nhds_zero, set.exists_mem_range],
  exact iff.rfl
end

lemma is_ideal_adic_iff [topological_space R] [topological_ring R] {J : ideal R} :
  is-J-adic ↔ (∀ n : ℕ, is_open (J^n).carrier) ∧ (∀ s ∈ nhds (0 : R), ∃ n : ℕ, (J^n).carrier ⊆ s) :=
begin
  split,
  { intro H,
    split,
    { intro n,
       letI := ideal.adic_basis J,
      refine subgroups_basis.is_op R H (set.mem_range_self _) },
    { intros s hs,
      exact (is_ideal_adic.mem_nhds_zero H).mp hs } },
  { rintro ⟨H₁, H₂⟩,
    apply topological_add_group.ext,
    { apply @topological_ring.to_topological_add_group },
    { apply subgroups_basis.is_topological_add_group },
    { ext s,
      letI := ideal.adic_basis J,
      split; intro H,
      { rw subgroups_basis.mem_nhds_zero,
        cases H₂ s H with n hn,
        use [(J ^ n).carrier, mem_range_self _, hn] },
      { rcases subgroups_basis.mem_nhds_zero.mp H with  ⟨_, ⟨n, rfl⟩, hn⟩,
        rw mem_nhds_sets_iff,
        refine ⟨_, hn, H₁ n, (J^n).zero_mem⟩ } } }
end

lemma is_ideal_adic.nonarchimedean [topological_space R] [topological_ring R] {J : ideal R}
  (H : is-J-adic) : nonarchimedean R :=
begin
  intros U U_in,
  rcases (is_ideal_adic.mem_nhds_zero H).mp U_in with ⟨n, hn⟩,
  exact ⟨⟨(J^n).carrier,
         ⟨(is_ideal_adic_iff.mp H).left _, submodule.submodule_is_add_subgroup (J ^ n)⟩⟩,
         hn⟩,
end

class with_ideal (R : Type*) [comm_ring R] := (ideal : ideal R)

namespace with_ideal
open topological_add_group
variables [with_ideal R]

protected def topological_space : topological_space R := (ideal R).adic_topology

local attribute [instance] with_ideal.topological_space

protected lemma topological_ring : topological_ring R :=
begin
  letI := ideal.adic_basis (with_ideal.ideal R),
  exact ring_filter_basis.is_topological_ring _ rfl
end

local attribute [instance] with_ideal.topological_ring

protected lemma nonarchimedean : nonarchimedean R :=
by apply subgroups_basis.nonarchimedean
end with_ideal

variables [topological_space R] [topological_ring R]

lemma is_ideal_adic_pow {J : ideal R} (h : is-J-adic) {n : ℕ} (hn : n > 0) :
  is-J^n-adic :=
begin
  rw is_ideal_adic_iff at h ⊢,
  split,
  { intro m, rw ← pow_mul, apply h.left },
  { intros V hV,
    cases h.right V hV with m hm,
    use m,
    refine set.subset.trans _ hm,
    cases n, { exfalso, exact nat.not_succ_le_zero 0 hn },
    rw [← pow_mul, nat.succ_mul],
    apply ideal.pow_le_pow,
    apply nat.le_add_left }
end

lemma is_bot_adic_iff {A : Type*} [comm_ring A] [topological_space A] [topological_ring A] :
is-(⊥ : ideal A)-adic ↔ discrete_topology A :=
begin
  rw is_ideal_adic_iff,
  split,
  { rintro ⟨h, h'⟩,
    rw @topological_add_group.discrete_iff_open_zero A _ _ _,
    simpa using h 1 },
  { introsI,
    split,
    { intros n,
      simp, },
    { intros U U_nhds,
      use 1,
      rw pow_one,
      change ({0} : set A) ⊆ U,
      simp [mem_of_nhds U_nhds] } },
end

variables (R)

def is_adic : Prop := ∃ (J : ideal R), is-J-adic


import algebra.big_operators.basic

open_locale big_operators

namespace finset

theorem sum_one_range_eq (n : ℕ) : ∑ i in range n, 1 = n :=
sum_range_induction (λ _, 1) id rfl (λ _, rfl) n

end finset


import order.complete_lattice
import data.real.ennreal

-- TODO: Is there a better way?
class complete_ordered_add_comm_monoid (α : Type*)
extends complete_lattice α, add_comm_monoid α :=
(add_le_add_left : ∀ (a b : α), a ≤ b → ∀ (c : α), c + a ≤ c + b)
(lt_of_add_lt_add_left : ∀ (a b c : α), a + b < a + c → b < c)

instance to_complete_lattice {α : Type*} [complete_ordered_add_comm_monoid α]
: complete_lattice α := by apply_instance

instance to_ordered_add_comm_monoid {α : Type*} [complete_ordered_add_comm_monoid α]
: ordered_add_comm_monoid α := { .._inst_1 }

noncomputable instance ennreal.complete_ordered_add_comm_monoid
: complete_ordered_add_comm_monoid ennreal :=
{ ..ennreal.canonically_ordered_comm_semiring }

lemma Sup_add_le_add_Sup
{α : Type*} [complete_ordered_add_comm_monoid α] {A B : set α}
: Sup (A + B) ≤ (Sup A) + (Sup B) :=
Sup_le $ λ _ ⟨a, b, ha, hb, hx⟩, (hx ▸ add_le_add (le_Sup ha) (le_Sup hb))

lemma supr_add_le_add_supr
{α : Type*} [complete_ordered_add_comm_monoid α] {ι : Type*} (s t : ι → α)
: supr (s + t) ≤ (supr s) + (supr t) :=
supr_le $ λ i, add_le_add (le_supr s i) (le_supr t i)


/-
Copyright (c) 2019 Seul Baek. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Seul Baek
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.omega.clause
import Mathlib.PostPort

universes l

namespace Mathlib

/-
Correctness lemmas for equality elimination.
See 5.5 of <http://www.decision-procedures.org/> for details.
-/

namespace omega

def symdiv (i : ℤ) (j : ℤ) : ℤ :=
  ite (bit0 1 * (i % j) < j) (i / j) (i / j + 1)

def symmod (i : ℤ) (j : ℤ) : ℤ :=
  ite (bit0 1 * (i % j) < j) (i % j) (i % j - j)

theorem symmod_add_one_self {i : ℤ} : 0 < i → symmod i (i + 1) = -1 := sorry

theorem mul_symdiv_eq {i : ℤ} {j : ℤ} : j * symdiv i j = i - symmod i j := sorry

theorem symmod_eq {i : ℤ} {j : ℤ} : symmod i j = i - j * symdiv i j :=
  eq.mpr (id (Eq._oldrec (Eq.refl (symmod i j = i - j * symdiv i j)) mul_symdiv_eq))
    (eq.mpr (id (Eq._oldrec (Eq.refl (symmod i j = i - (i - symmod i j))) (sub_sub_cancel i (symmod i j))))
      (Eq.refl (symmod i j)))

/-- (sgm v b as n) is the new value assigned to the nth variable
after a single step of equality elimination using valuation v,
term ⟨b, as⟩, and variable index n. If v satisfies the initial
constraint set, then (v ⟨n ↦ sgm v b as n⟩) satisfies the new
constraint set after equality elimination. -/
def sgm (v : ℕ → ℤ) (b : ℤ) (as : List ℤ) (n : ℕ) : ℤ :=
  let a_n : ℤ := list.func.get n as;
  let m : ℤ := a_n + 1;
  (symmod b m + coeffs.val v (list.map (fun (x : ℤ) => symmod x m) as)) / m

def rhs : ℕ → ℤ → List ℤ → term :=
  sorry

theorem rhs_correct_aux {v : ℕ → ℤ} {m : ℤ} {as : List ℤ} {k : ℕ} : ∃ (d : ℤ), m * d + coeffs.val_between v (list.map (fun (x : ℤ) => symmod x m) as) 0 k = coeffs.val_between v as 0 k := sorry

theorem rhs_correct {v : ℕ → ℤ} {b : ℤ} {as : List ℤ} (n : ℕ) : 0 < list.func.get n as → 0 = term.val v (b, as) → v n = term.val (update n (sgm v b as n) v) (rhs n b as) := sorry

def sym_sym (m : ℤ) (b : ℤ) : ℤ :=
  symdiv b m + symmod b m

def coeffs_reduce : ℕ → ℤ → List ℤ → term :=
  sorry

theorem coeffs_reduce_correct {v : ℕ → ℤ} {b : ℤ} {as : List ℤ} {n : ℕ} : 0 < list.func.get n as → 0 = term.val v (b, as) → 0 = term.val (update n (sgm v b as n) v) (coeffs_reduce n b as) := sorry

-- Requires : t1.coeffs[m] = 1

def cancel (m : ℕ) (t1 : term) (t2 : term) : term :=
  term.add (term.mul (-list.func.get m (prod.snd t2)) t1) t2

def subst (n : ℕ) (t1 : term) (t2 : term) : term :=
  term.add (term.mul (list.func.get n (prod.snd t2)) t1) (prod.fst t2, list.func.set 0 (prod.snd t2) n)

theorem subst_correct {v : ℕ → ℤ} {b : ℤ} {as : List ℤ} {t : term} {n : ℕ} : 0 < list.func.get n as →
  0 = term.val v (b, as) → term.val v t = term.val (update n (sgm v b as n) v) (subst n (rhs n b as) t) := sorry

/-- The type of equality elimination rules. -/
inductive ee
where
| drop : ee
| nondiv : ℤ → ee
| factor : ℤ → ee
| neg : ee
| reduce : ℕ → ee
| cancel : ℕ → ee

namespace ee

def repr : ee → string :=
  sorry

protected instance has_repr : has_repr ee :=
  has_repr.mk repr

end ee

/-- Apply a given sequence of equality elimination steps to a clause. -/
def eq_elim : List ee → clause → clause :=
  sorry

theorem sat_empty : clause.sat ([], []) :=
  Exists.intro (fun (_x : ℕ) => 0) { left := of_as_true trivial, right := of_as_true trivial }

theorem sat_eq_elim {es : List ee} {c : clause} : clause.sat c → clause.sat (eq_elim es c) := sorry

/-- If the result of equality elimination is unsatisfiable, the original clause is unsatisfiable. -/
theorem unsat_of_unsat_eq_elim (ee : List ee) (c : clause) : clause.unsat (eq_elim ee c) → clause.unsat c :=
  fun (h1 : clause.unsat (eq_elim ee c)) => id fun (h2 : clause.sat c) => h1 (sat_eq_elim h2)


/-
Copyright (c) 2014 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura, Floris van Doorn
-/
import .path .meta.rewrite

universes u v w
hott_theory

/- prod -/

@[reducible] def pair := @prod.mk

@[hott] protected def prod.elim {a b c} (H₁ : a × b) (H₂ : a → b → c) : c :=
prod.rec H₂ H₁

@[hott] def prod.flip {α : Type u} {β : Type v} : α × β → β × α
| ⟨a,b⟩ := ⟨b,a⟩

@[hott] def prod.swap {α : Type u} {β : Type v} : α × β → β × α
| ⟨a,b⟩ := ⟨b,a⟩

@[hott, elab_as_eliminator] def prod.destruct {α : Type u} {β : Type v} {C} :=
@prod.cases_on α β C

/- sum -/

infixr ` ⊎ `:30 := sum

@[hott] protected def sum.elim {a b c} (H₁ : a ⊎ b) (H₂ : a → c) (H₃ : b → c) : c :=
sum.rec H₂ H₃ H₁

@[hott] def sum.swap {a b} : a ⊎ b → b ⊎ a
| (sum.inl ha) := sum.inr ha
| (sum.inr hb) := sum.inl hb

@[hott] def sum.functor {A A' B B'} (f : A → A') (g : B → B') : A ⊎ B → A' ⊎ B'
| (sum.inl a) := sum.inl (f a)
| (sum.inr b) := sum.inr (g b)

@[hott] def sum.functor_right (A) {B B'} (g : B → B') : A ⊎ B → A ⊎ B' :=
sum.functor id g

@[hott] def sum.functor_left {A A'} (B) (f : A → A') : A ⊎ B → A' ⊎ B :=
sum.functor f id

namespace hott
open unit

/- not -/

@[hott] def not (a : Type _) := a → empty
hott_theory_cmd "local prefix ¬ := hott.not"

@[hott] def absurd {a b : Type _} (H₁ : a) (H₂ : ¬a) : b :=
empty.rec (λ e, b) (H₂ H₁)

@[hott] def mt {a b : Type _} (H₁ : a → b) (H₂ : ¬b) : ¬a :=
assume Ha : a, absurd (H₁ Ha) H₂

@[hott] def not_empty : ¬empty :=
assume H : empty, H

@[hott] def non_contradictory (a : Type _) : Type _ := ¬¬a

@[hott] def non_contradictory_intro {a : Type _} (Ha : a) : ¬¬a :=
assume Hna : ¬a, absurd Ha Hna

@[hott] def not.intro {a : Type _} (H : a → empty) : ¬a := H

/- empty -/

@[hott] def empty.elim {c : Type _} (H : empty) : c :=
empty.rec _ H

@[hott, reducible] def ne {A : Type _} (a b : A) := ¬(a = b)
hott_theory_cmd "local notation a ≠ b := hott.ne a b"

namespace ne
  variable {A : Type _}
  variables {a b : A}

  @[hott] def intro (H : a = b → empty) : a ≠ b := H

  @[hott] def elim (H : a ≠ b) : a = b → empty := H

  @[hott] def irrefl (H : a ≠ a) : empty := H rfl

  @[hott] def symm (H : a ≠ b) : b ≠ a :=
  assume (H₁ : b = a), H (H₁⁻¹)
end ne

@[hott] def empty_of_ne {A : Type _} {a : A} : a ≠ a → empty := ne.irrefl

section
  variables {p : Type}

  @[hott] def ne_empty_of_self : p → p ≠ empty :=
  assume (Hp : p) (Heq : p = empty), Heq ▸ Hp

  @[hott] def ne_unit_of_not : ¬p → p ≠ unit :=
  assume (Hnp : ¬p) (Heq : p = unit), (Heq ▸ Hnp) star

  @[hott] def unit_ne_empty : ¬unit = empty :=
  ne_empty_of_self star
end

@[hott] def hott.non_contradictory_em (a : Type _) : ¬¬(a ⊎ ¬a) :=
assume not_em : ¬(a ⊎ ¬a),
  have neg_a : ¬a, from
    assume pos_a : a, absurd (sum.inl pos_a) not_em,
  absurd (sum.inr neg_a) not_em

variables {a : Type _} {b : Type _} {c : Type _} {d : Type _}

/- iff -/

@[hott] def iff (a b : Type _) := (a → b) × (b → a)

hott_theory_cmd "local notation a <-> b := hott.iff a b"
hott_theory_cmd "local notation a ↔ b := hott.iff a b"

@[hott, intro!] def iff.intro : (a → b) → (b → a) → (a ↔ b) := prod.mk

@[hott] def iff.elim : ((a → b) → (b → a) → c) → (a ↔ b) → c :=
λ H₁ H₂, prod.rec H₁ H₂

@[hott] def iff.elim_left : (a ↔ b) → a → b := prod.fst

@[hott] def iff.mp := @iff.elim_left

@[hott] def iff.elim_right : (a ↔ b) → b → a := prod.snd

@[hott] def iff.mpr := @iff.elim_right

@[hott, refl] def iff.refl (a : Type _) : a ↔ a :=
iff.intro (assume H, H) (assume H, H)

@[hott] def iff.rfl {a : Type _} : a ↔ a :=
iff.refl a

@[hott] def iff.of_eq {a b : Type _} (H : a = b) : a ↔ b :=
eq.rec_on H iff.rfl

@[hott, trans] def iff.trans (H₁ : a ↔ b) (H₂ : b ↔ c) : a ↔ c :=
iff.intro
  (assume Ha, iff.mp H₂ (iff.mp H₁ Ha))
  (assume Hc, iff.mpr H₁ (iff.mpr H₂ Hc))

@[hott, trans] def iff.trans_eq {a b c : Type _} (H₁ : a ↔ b) (H₂ : b = c) : a ↔ c :=
iff.trans H₁ (iff.of_eq H₂)

@[hott, trans] def iff.eq_trans {a b c : Type _} (H₁ : a = b) (H₂ : b ↔ c) : a ↔ c :=
iff.trans (iff.of_eq H₁) H₂

@[hott, symm] def iff.symm (H : a ↔ b) : b ↔ a :=
iff.intro (iff.elim_right H) (iff.elim_left H)

@[hott] def iff.comm : (a ↔ b) ↔ (b ↔ a) :=
iff.intro iff.symm iff.symm

@[hott] def not_iff_not_of_iff (H₁ : a ↔ b) : ¬a ↔ ¬b :=
iff.intro
 (assume (Hna : ¬ a) (Hb : b), Hna (iff.elim_right H₁ Hb))
 (assume (Hnb : ¬ b) (Ha : a), Hnb (iff.elim_left H₁ Ha))

@[hott] def of_iff_unit (H : a ↔ unit) : a :=
iff.mp (iff.symm H) ()

@[hott] def not_of_iff_empty : (a ↔ empty) → ¬a := iff.mp

@[hott] def iff_unit_intro (H : a) : a ↔ unit :=
iff.intro
  (λ Hl, ())
  (λ Hr, H)

@[hott] def iff_empty_intro (H : ¬a) : a ↔ empty :=
iff.intro H (empty.rec _)

@[hott] def not_non_contradictory_iff_absurd (a : Type _) : ¬¬¬a ↔ ¬a :=
iff.intro
  (λ (Hl : ¬¬¬a) (Ha : a), Hl (non_contradictory_intro Ha))
  absurd

@[hott, congr] def imp_congr (H1 : a ↔ c) (H2 : b ↔ d) : (a → b) ↔ (c → d) :=
iff.intro
  (λHab Hc, iff.mp H2 (Hab (iff.mpr H1 Hc)))
  (λHcd Ha, iff.mpr H2 (Hcd (iff.mp H1 Ha)))

@[hott] def not_not_intro (Ha : a) : ¬¬a :=
assume Hna : ¬a, Hna Ha

@[hott] def not_of_not_not_not (H : ¬¬¬a) : ¬a :=
λ Ha, absurd (not_not_intro Ha) H

@[hott, hsimp] def not_unit : (¬ unit) ↔ empty :=
iff_empty_intro (not_not_intro ())

@[hott, hsimp] def not_empty_iff : (¬ empty) ↔ unit :=
iff_unit_intro not_empty

@[hott] def not_congr (H : a ↔ b) : ¬a ↔ ¬b :=
iff.intro (λ H₁ H₂, H₁ (iff.mpr H H₂)) (λ H₁ H₂, H₁ (iff.mp H H₂))

@[hott, hsimp] def ne_self_iff_empty {A : Type _} (a : A) : (not (a = a)) ↔ empty :=
iff.intro empty_of_ne empty.elim

@[hott, hsimp] def eq_self_iff_unit {A : Type _} (a : A) : (a = a) ↔ unit :=
iff_unit_intro rfl

@[hott, hsimp] def iff_not_self (a : Type _) : (a ↔ ¬a) ↔ empty :=
iff_empty_intro (λ H,
   have H' : ¬a, from (λ Ha, (iff.mp H Ha) Ha),
   H' (iff.mpr H H'))

@[hott, hsimp] def not_iff_self (a : Type _) : (¬a ↔ a) ↔ empty :=
iff_empty_intro (λ H,
   have H' : ¬a, from (λ Ha, (iff.mpr H Ha) Ha),
   H' (iff.mp H H'))

@[hott, hsimp] def unit_iff_empty : (unit ↔ empty) ↔ empty :=
iff_empty_intro (λ H, iff.mp H ())

@[hott, hsimp] def empty_iff_unit : (empty ↔ unit) ↔ empty :=
iff_empty_intro (λ H, iff.mpr H ())

@[hott] def empty_of_unit_iff_empty : (unit ↔ empty) → empty :=
assume H, iff.mp H ()

/- prod simp rules -/
@[hott] def prod.imp {a b c d} (H₂ : a → c) (H₃ : b → d) : a × b → c × d
| ⟨ha, hb⟩ := ⟨H₂ ha, H₃ hb⟩

@[hott, congr] def prod_congr (H1 : a ↔ c) (H2 : b ↔ d) : (a × b) ↔ (c × d) :=
iff.intro (prod.imp (iff.mp H1) (iff.mp H2)) (prod.imp (iff.mpr H1) (iff.mpr H2))

@[hott, hsimp] def prod.comm : a × b ↔ b × a :=
iff.intro prod.swap prod.swap

@[hott, hsimp] def prod.assoc : (a × b) × c ↔ a × (b × c) :=
iff.intro
  (λ ⟨⟨Ha, Hb⟩, Hc⟩, ⟨Ha, ⟨Hb, Hc⟩⟩)
  (λ ⟨Ha, ⟨Hb, Hc⟩⟩, ⟨⟨Ha, Hb⟩, Hc⟩)

@[hott, hsimp] def prod.fst_comm : a × (b × c) ↔ b × (a × c) :=
iff.intro
  (λ ⟨Ha, ⟨Hb, Hc⟩⟩, ⟨Hb, ⟨Ha, Hc⟩⟩)
  (λ ⟨Hb, ⟨Ha, Hc⟩⟩, ⟨Ha, ⟨Hb, Hc⟩⟩)

@[hott] def prod_iff_left {a b : Type _} (Hb : b) : (a × b) ↔ a :=
iff.intro prod.fst (λHa, prod.mk Ha Hb)

@[hott] def prod_iff_right {a b : Type _} (Ha : a) : (a × b) ↔ b :=
iff.intro prod.snd (prod.mk Ha)

@[hott, hsimp] def prod_unit (a : Type _) : a × unit ↔ a :=
prod_iff_left ()

@[hott, hsimp] def unit_prod (a : Type _) : unit × a ↔ a :=
prod_iff_right ()

@[hott, hsimp] def prod_empty (a : Type _) : a × empty ↔ empty :=
iff_empty_intro prod.snd

@[hott, hsimp] def empty_prod  (a : Type _) : empty × a ↔ empty :=
iff_empty_intro prod.fst

@[hott, hsimp] def not_prod_self (a : Type _) : (¬a × a) ↔ empty :=
iff_empty_intro (λ H, prod.elim H (λ H₁ H₂, absurd H₂ H₁))

@[hott, hsimp] def prod_not_self (a : Type _) : (a × ¬a) ↔ empty :=
iff_empty_intro (λ H, prod.elim H (λ H₁ H₂, absurd H₁ H₂))

@[hott, hsimp] def prod_self (a : Type _) : a × a ↔ a :=
iff.intro prod.fst (assume H, prod.mk H H)

/- sum simp rules -/

@[hott] def sum.imp (H₂ : a → c) (H₃ : b → d) : a ⊎ b → c ⊎ d
| (sum.inl H) := sum.inl (H₂ H)
| (sum.inr H) := sum.inr (H₃ H)

@[hott] def sum.imp_left (H : a → b) : a ⊎ c → b ⊎ c :=
sum.imp H id

@[hott] def sum.imp_right (H : a → b) : c ⊎ a → c ⊎ b :=
sum.imp id H

@[hott, congr] def sum_congr (H1 : a ↔ c) (H2 : b ↔ d) : (a ⊎ b) ↔ (c ⊎ d) :=
iff.intro (sum.imp (iff.mp H1) (iff.mp H2)) (sum.imp (iff.mpr H1) (iff.mpr H2))

@[hott, hsimp] def sum.comm : a ⊎ b ↔ b ⊎ a := iff.intro sum.swap sum.swap

@[hott, hsimp] def sum.assoc : (a ⊎ b) ⊎ c ↔ a ⊎ (b ⊎ c) :=
iff.intro
  (λ Habc, match Habc with
    | sum.inl (sum.inl Ha) := sum.inl Ha
    | sum.inl (sum.inr Hb) := sum.inr (sum.inl Hb)
    | sum.inr Hc := sum.inr (sum.inr Hc)
    end)
  (λ Habc, match Habc with
    | sum.inl Ha := sum.inl (sum.inl Ha)
    | sum.inr (sum.inl Hb) := sum.inl (sum.inr Hb)
    | sum.inr (sum.inr Hc) := sum.inr Hc
    end)

@[hott, hsimp] def sum.left_comm : a ⊎ (b ⊎ c) ↔ b ⊎ (a ⊎ c) :=
begin
  transitivity, {symmetry, exact sum.assoc},
  transitivity, {apply sum_congr, apply sum.comm, refl},
  apply sum.assoc
end

@[hott, hsimp] def sum_unit (a : Type _) : a ⊎ unit ↔ unit :=
iff_unit_intro (sum.inr ())

@[hott, hsimp] def unit_sum (a : Type _) : unit ⊎ a ↔ unit :=
iff_unit_intro (sum.inl ())

@[hott, hsimp] def sum_empty (a : Type _) : a ⊎ empty ↔ a :=
iff.intro (λ Hae, match Hae with sum.inl Ha := Ha end) sum.inl

@[hott, hsimp] def empty_sum (a : Type _) : empty ⊎ a ↔ a :=
iff.trans sum.comm (sum_empty _)

@[hott, hsimp] def sum_self (a : Type _) : a ⊎ a ↔ a :=
iff.intro (λ Haa, Haa.elim id id) sum.inl

/- sum resolution rulse -/

@[hott] def sum.resolve_left {a b : Type _} (H : a ⊎ b) (na : ¬ a) : b :=
  sum.elim H (λ Ha, absurd Ha na) id

@[hott] def sum.neg_resolve_left {a b : Type _} (H : ¬ a ⊎ b) (Ha : a) : b :=
  sum.elim H (λ na, absurd Ha na) id

@[hott] def sum.resolve_right {a b : Type _} (H : a ⊎ b) (nb : ¬ b) : a :=
  sum.elim H id (λ Hb, absurd Hb nb)

@[hott] def sum.neg_resolve_right {a b : Type _} (H : a ⊎ ¬ b) (Hb : b) : a :=
  sum.elim H id (λ nb, absurd Hb nb)

/- iff simp rules -/

@[hott, hsimp] def iff_unit (a : Type _) : (a ↔ unit) ↔ a :=
iff.intro (assume H, iff.mpr H star) iff_unit_intro

@[hott, hsimp] def unit_iff (a : Type _) : (unit ↔ a) ↔ a :=
iff.trans iff.comm (iff_unit _)

@[hott, hsimp] def iff_empty (a : Type _) : (a ↔ empty) ↔ ¬ a :=
iff.intro prod.fst iff_empty_intro

@[hott, hsimp] def empty_iff (a : Type _) : (empty ↔ a) ↔ ¬ a :=
iff.trans iff.comm (iff_empty _)

@[hott, hsimp] def iff_self (a : Type _) : (a ↔ a) ↔ unit :=
iff_unit_intro iff.rfl

@[hott, congr] def iff_congr (H1 : a ↔ c) (H2 : b ↔ d) : (a ↔ b) ↔ (c ↔ d) :=
prod_congr (imp_congr H1 H2) (imp_congr H2 H1)

/- decidable -/

class inductive decidable (p : Type u) : Type u
| inl :  p → decidable
| inr : ¬p → decidable

@[hott, instance] def decidable_unit : decidable unit :=
decidable.inl ()

@[hott, instance] def decidable_empty : decidable empty :=
decidable.inr not_empty

-- We use "dependent" if-then-else to be able to communicate the if-then-else condition
-- to the branches
@[hott] def dite (c : Type _) [H : decidable c] {A : Type _} (Hp : c → A) (Hn : ¬ c → A): A :=
decidable.rec_on H Hp Hn

/- if-then-else -/

@[hott] def ite (c : Type _) [H : decidable c] {A : Type _} (t e : A) : A :=
decidable.rec_on H (λ Hc, t) (λ Hnc, e)

hott_theory_cmd "local notation `if' ` c ` then ` t:45 ` else ` e:45 := hott.ite c t e"
hott_theory_cmd "local notation `if ` binder ` :: ` c ` then ` t:scoped ` else ` e:scoped := hott.dite c t e"

namespace decidable
  variables {p : Type _} {q : Type _}

  @[hott] def by_cases {q : Type _} [C : decidable p] : (p → q) → (¬p → q) → q := dite _

  @[hott] theorem em (p : Type _) [H : decidable p] : p ⊎ ¬p := by_cases sum.inl sum.inr

  @[hott] theorem by_contradiction [Hp : decidable p] (H : ¬p → empty) : p :=
  if H1 :: p then H1 else empty.rec _ (H H1)
end decidable

section
  variables {p : Type _} {q : Type _}
  open hott.decidable
  @[hott] def decidable_of_decidable_of_iff (Hp : decidable p) (H : p ↔ q) : decidable q :=
  if Hp :: p then inl (iff.mp H Hp)
  else inr (iff.mp (not_iff_not_of_iff H) Hp)

  @[hott] def decidable_of_decidable_of_eq {p q : Type _} (Hp : decidable p) (H : p = q)
    : decidable q :=
  decidable_of_decidable_of_iff Hp (iff.of_eq H)

  @[hott] protected def sum.by_cases [Hp : decidable p] [Hq : decidable q] {A : Type _}
                                   (h : p ⊎ q) (h₁ : p → A) (h₂ : q → A) : A :=
  if hp :: p then h₁ hp else
    if hq :: q then h₂ hq else
      empty.rec _ (sum.elim h hp hq)
end

section
  variables {p : Type _} {q : Type _}
  open hott.decidable

  @[hott, instance] def decidable_prod [Hp : decidable p] [Hq : decidable q] : decidable (p × q) :=
  if hp :: p then
    if hq :: q then inl (prod.mk hp hq)
    else inr (assume H : p × q, hq H.snd)
  else inr (assume H : p × q, hp H.fst)

  @[hott, instance] def decidable_sum [Hp : decidable p] [Hq : decidable q] : decidable (p ⊎ q) :=
  if hp :: p then inl (sum.inl hp) else
    if hq :: q then inl (sum.inr hq) else
      inr (λ hpq, sum.rec hp hq hpq)

  @[hott, instance] def decidable_not [Hp : decidable p] : decidable (¬p) :=
  if hp :: p then inr (absurd hp) else inl hp

  @[hott, instance] def decidable_implies [Hp : decidable p] [Hq : decidable q] : decidable (p → q) :=
  if hp :: p then
    if hq :: q then inl (assume H, hq)
    else inr (assume H : p → q, absurd (H hp) hq)
  else inl (assume Hp, absurd Hp hp)

  @[hott, instance] def decidable_iff [Hp : decidable p] [Hq : decidable q] : decidable (p ↔ q) :=
  decidable_prod

end

@[hott, reducible] def decidable_pred {A : Type _} (R : A   →   Type _) := Π (a   : A), decidable (R a)
@[hott, reducible] def decidable_rel {A : Type _} (R : A → A → Type _) := Π (a b : A), decidable (R a b)
@[hott, reducible] def decidable_eq (A : Type _) := decidable_rel (@eq A)
@[hott, reducible, instance] def decidable_ne {A : Type _} [H : decidable_eq A] (a b : A) : decidable (a ≠ b) :=
decidable_implies

namespace bool
  protected def no_confusion {P : Sort u} {v1 v2 : bool} (H12 : v1 = v2) : bool.no_confusion_type P v1 v2 :=
  eq.rec (λ (H11 : v1 = v1), bool.cases_on v1 (λ (a : P), a) (λ (a : P), a)) H12 H12

  @[hott] def ff_ne_tt : ff = tt → empty :=
  bool.no_confusion
end bool

open hott.bool
@[hott] def is_dec_eq {A : Type _} (p : A → A → bool) : Type _   := Π ⦃x y : A⦄, p x y = tt → x = y
@[hott] def is_dec_refl {A : Type _} (p : A → A → bool) : Type _ := Πx, p x x = tt

open hott.decidable
@[hott, instance] protected def bool.has_decidable_eq : Πa b : bool, decidable (a = b)
| ff ff := inl rfl
| ff tt := inr ff_ne_tt
| tt ff := inr (ne.symm ff_ne_tt)
| tt tt := inl rfl

@[hott] def decidable_eq_of_bool_pred {A : Type _} {p : A → A → bool} (H₁ : is_dec_eq p) (H₂ : is_dec_refl p) : decidable_eq A :=
λ x y : A, if Hp :: p x y = tt then inl (H₁ Hp)
 else inr begin intro Hxy, apply Hp, rwr Hxy, apply H₂ end

/- inhabited -/

@[hott] protected def inhabited.value {A : Type _} : inhabited A → A
| ⟨v⟩ := v

@[hott] protected def inhabited.destruct {A : Type _} {B : Type _} (H1 : inhabited A) (H2 : A → B) : B :=
inhabited.rec H2 H1

/- subsingleton -/

class subsingleton (A : Type _) :=
(prop : (Π a b : A, a = b))

@[hott] protected def subsingleton.elim {A : Type _} [H : subsingleton A] : Π(a b : A), a = b :=
subsingleton.rec (λp, p) H

@[hott] protected theorem rec_subsingleton {p : Type _} [H : decidable p]
    {H1 : p → Type _} {H2 : ¬p → Type _}
    [H3 : Π(h : p), subsingleton (H1 h)] [H4 : Π(h : ¬p), subsingleton (H2 h)]
  : subsingleton (decidable.rec_on H H1 H2) :=
decidable.rec_on H (λh, H3 h) (λh, H4 h) --this can be proven using dependent version of "by_cases"

@[hott] def if_pos {c : Type _} [H : decidable c] (Hc : c) {A : Type _} {t e : A} : (ite c t e) = t :=
decidable.rec
  (λ Hc : c,    eq.refl (@ite c (decidable.inl Hc) A t e))
  (λ Hnc : ¬c,  absurd Hc Hnc)
  H

@[hott] def if_neg {c : Type _} [H : decidable c] (Hnc : ¬c) {A : Type _} {t e : A} : (ite c t e) = e :=
decidable.rec
  (λ Hc : c,    absurd Hc Hnc)
  (λ Hnc : ¬c,  eq.refl (@ite c (decidable.inr Hnc) A t e))
  H

@[hott, hsimp] theorem if_t_t (c : Type _) [H : decidable c] {A : Type _} (t : A) : (ite c t t) = t :=
decidable.rec
  (λ Hc  : c,  eq.refl (@ite c (decidable.inl Hc)  A t t))
  (λ Hnc : ¬c, eq.refl (@ite c (decidable.inr Hnc) A t t))
  H

@[hott] theorem implies_of_if_pos {c t e : Type _} [H : decidable c] (h : ite c t e) : c → t :=
assume Hc, transport id (if_pos Hc) h

@[hott] theorem implies_of_if_neg {c t e : Type _} [H : decidable c] (h : ite c t e) : ¬c → e :=
assume Hc, transport id (if_neg Hc) h

@[hott] theorem if_ctx_congr {A : Type _} {b c : Type _} [dec_b : decidable b] [dec_c : decidable c]
                     {x y u v : A}
                     (h_c : b ↔ c) (h_t : c → x = u) (h_e : ¬c → y = v) :
        ite b x y = ite c u v :=
if hp :: b then
  calc
    ite b x y = x           : if_pos hp
         ...  = u           : h_t (iff.mp h_c hp)
         ...  = ite c u v   : (if_pos (iff.mp h_c hp)).inverse
else
  calc
    ite b x y = y         : if_neg hp
         ...  = v         : h_e (iff.mp (not_iff_not_of_iff h_c) hp)
         ...  = ite c u v : (if_neg (iff.mp (not_iff_not_of_iff h_c) hp)).inverse

@[hott, congr] theorem if_congr {A : Type _} {b c : Type _} [dec_b : decidable b] [dec_c : decidable c]
                 {x y u v : A}
                 (h_c : b ↔ c) (h_t : x = u) (h_e : y = v) :
        ite b x y = ite c u v :=
@if_ctx_congr A b c dec_b dec_c x y u v h_c (λ h, h_t) (λ h, h_e)

@[hott, congr] theorem if_ctx_simp_congr {A : Type _} {b c : Type _} [dec_b : decidable b] {x y u v : A}
                        (h_c : b ↔ c) (h_t : c → x = u) (h_e : ¬c → y = v) :
        ite b x y = (@ite c (decidable_of_decidable_of_iff dec_b h_c) A u v) :=
@if_ctx_congr A b c dec_b (decidable_of_decidable_of_iff dec_b h_c) x y u v h_c h_t h_e

@[hott, congr] theorem if_simp_congr {A : Type _} {b c : Type _} [dec_b : decidable b] {x y u v : A}
                 (h_c : b ↔ c) (h_t : x = u) (h_e : y = v) :
        ite b x y = (@ite c (decidable_of_decidable_of_iff dec_b h_c) A u v) :=
@if_ctx_simp_congr A b c dec_b x y u v h_c (λ h, h_t) (λ h, h_e)

@[hott, hsimp] def if_unit {A : Type _} (t e : A) : (if' unit then t else e) = t :=
if_pos star

@[hott, hsimp] def if_empty {A : Type _} (t e : A) : (if' empty then t else e) = e :=
if_neg not_empty

@[hott] theorem if_ctx_congr_prop {b c x y u v : Type _} [dec_b : decidable b] [dec_c : decidable c]
                      (h_c : b ↔ c) (h_t : c → (x ↔ u)) (h_e : ¬c → (y ↔ v)) :
        ite b x y ↔ ite c u v :=
if hp :: b then
  calc
    ite b x y ↔ x         : iff.of_eq (if_pos hp)
         ...  ↔ u         : h_t (iff.mp h_c hp)
         ...  ↔ ite c u v : iff.of_eq (if_pos (iff.mp h_c hp)).inverse
else
  calc
    ite b x y ↔ y         : iff.of_eq (if_neg hp)
         ...  ↔ v         : h_e (iff.mp (not_iff_not_of_iff h_c) hp)
         ...  ↔ ite c u v : iff.of_eq (if_neg (iff.mp (not_iff_not_of_iff h_c) hp)).inverse

@[hott, congr] theorem if_congr_prop {b c x y u v : Type _} [dec_b : decidable b] [dec_c : decidable c]
                      (h_c : b ↔ c) (h_t : x ↔ u) (h_e : y ↔ v) :
        ite b x y ↔ ite c u v :=
if_ctx_congr_prop h_c (λ h, h_t) (λ h, h_e)

@[hott] theorem if_ctx_simp_congr_prop {b c x y u v : Type _} [dec_b : decidable b]
                               (h_c : b ↔ c) (h_t : c → (x ↔ u)) (h_e : ¬c → (y ↔ v)) :
        ite b x y ↔ (@ite c (decidable_of_decidable_of_iff dec_b h_c) _ u v) :=
@if_ctx_congr_prop b c x y u v dec_b (decidable_of_decidable_of_iff dec_b h_c) h_c h_t h_e

@[hott, congr] theorem if_simp_congr_prop {b c x y u v : Type _} [dec_b : decidable b]
                           (h_c : b ↔ c) (h_t : x ↔ u) (h_e : y ↔ v) :
        ite b x y ↔ (@ite c (decidable_of_decidable_of_iff dec_b h_c) _ u v) :=
@if_ctx_simp_congr_prop b c x y u v dec_b h_c (λ h, h_t) (λ h, h_e)

-- Remark: dite and ite are "definitionally equal" when we ignore the proofs.
@[hott] theorem dite_ite_eq (c : Type _) [H : decidable c] {A : Type _} (t : A) (e : A) :
  dite c (λh, t) (λh, e) = ite c t e :=
by refl

@[hott] def is_unit (c : Type _) [H : decidable c] : Type :=
if' c then unit else empty

@[hott] def is_empty (c : Type _) [H : decidable c] : Type :=
if' c then empty else unit

@[hott] def of_is_unit {c : Type _} [H₁ : decidable c] (H₂ : is_unit c) : c :=
if Hc :: c then Hc else begin unfreezeI, induction H₁, assumption, cases H₂ end

notation `dec_star` := of_is_unit star

@[hott] theorem not_of_not_is_unit {c : Type _} [H₁ : decidable c] (H₂ : ¬ is_unit c) : ¬ c :=
if Hc :: c then absurd star (if_pos Hc ▸ H₂) else Hc

@[hott] theorem not_of_is_empty {c : Type _} [H₁ : decidable c] (H₂ : is_empty c) : ¬ c :=
if Hc :: c then begin unfreezeI, induction H₁, cases H₂, assumption end else Hc

@[hott] theorem of_not_is_empty {c : Type _} [H₁ : decidable c] (H₂ : ¬ is_empty c) : c :=
if Hc :: c then Hc else absurd star (if_neg Hc ▸ H₂)

end hott


-- https://github.com/leanprover/lean4/blob/fa0964c07e70bd3ad546a18d9c450c9c27d29920/tests/lean/run/mergeSortCPDT.lean
def List.insert (p : α → α → Bool) (a : α) (bs : List α) : List α :=
  match bs with
  | [] => [a]
  | b :: bs' => if p a b then a :: bs else b :: bs'.insert p a

def List.merge (p : α → α → Bool) (as bs : List α) : List α :=
  match as with
  | [] => bs
  | a :: as' => insert p a (merge p as' bs)

def List.split (as : List α) : List α × List α :=
  match as with
  | []  => ([], [])
  | [a] => ([a], [])
  | a :: b :: as =>
    let (as, bs) := split as
    (a :: as, b :: bs)

@[simp] def List.atLeast2 (as : List α) : Bool :=
  match as with
  | []      => false
  | [_]     => false
  | _::_::_ => true

theorem List.length_split_of_atLeast2 {as : List α} (h : as.atLeast2) : as.split.1.length < as.length ∧ as.split.2.length < as.length := by
  match as with
  | []  => simp at h
  | [_] => simp at h
  | [_, _] => simp [split]
  | [_, _, _] => simp [split]
  | a::b::c::d::as =>
    -- TODO: simplify using linear arith and more automation
    have : (c::d::as).atLeast2 := by simp_arith
    have ih := length_split_of_atLeast2 this
    simp_arith [split] at ih |-
    have ⟨ih₁, ih₂⟩ := ih
    exact ⟨Nat.le_trans ih₁ (by simp_arith), Nat.le_trans ih₂ (by simp_arith)⟩

def List.mergeSortBy (p : α → α → Bool) (as : List α) : List α :=
  if h : as.atLeast2 then
    match he:as.split with
    | (as', bs') =>
      -- TODO: simplify using more automation
      have ⟨h₁, h₂⟩ := length_split_of_atLeast2 h
      have : as'.length < as.length := by simp [he] at h₁; assumption
      have : bs'.length < as.length := by simp [he] at h₂; assumption
      merge p (mergeSortBy p as') (mergeSortBy p bs')
  else
    as
termination_by _ as => as.length

def List.mergeSort [Ord α] : List α → List α := mergeSortBy (λ x y => compare x y |>.isLE)