/-
Copyright (c) 2019 Abhimanyu Pallavi Sudhir. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Abhimanyu Pallavi Sudhir, Yury Kudryashov
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.order.filter.ultrafilter
import Mathlib.order.filter.germ
import Mathlib.PostPort

universes u v

namespace Mathlib

/-!
# Ultraproducts

If `φ` is an ultrafilter, then the space of germs of functions `f : α → β` at `φ` is called
the *ultraproduct*. In this file we prove properties of ultraproducts that rely on `φ` being an
ultrafilter. Definitions and properties that work for any filter should go to `order.filter.germ`.

## Tags

ultrafilter, ultraproduct
-/

namespace filter

namespace germ

/-- If `φ` is an ultrafilter then the ultraproduct is a division ring. -/
protected instance division_ring {α : Type u} {β : Type v} {φ : ultrafilter α} [division_ring β] :
    division_ring (germ (↑φ) β) :=
  division_ring.mk ring.add sorry ring.zero sorry sorry ring.neg ring.sub sorry sorry ring.mul sorry
    ring.one sorry sorry sorry sorry div_inv_monoid.inv div_inv_monoid.div sorry sorry sorry

/-- If `φ` is an ultrafilter then the ultraproduct is a field. -/
protected instance field {α : Type u} {β : Type v} {φ : ultrafilter α} [field β] :
    field (germ (↑φ) β) :=
  field.mk comm_ring.add sorry comm_ring.zero sorry sorry comm_ring.neg comm_ring.sub sorry sorry
    comm_ring.mul sorry comm_ring.one sorry sorry sorry sorry sorry division_ring.inv sorry sorry
    sorry

/-- If `φ` is an ultrafilter then the ultraproduct is a linear order. -/
protected instance linear_order {α : Type u} {β : Type v} {φ : ultrafilter α} [linear_order β] :
    linear_order (germ (↑φ) β) :=
  linear_order.mk partial_order.le partial_order.lt sorry sorry sorry sorry
    (fun (a b : germ (↑φ) β) => classical.prop_decidable (a ≤ b))
    Mathlib.decidable_eq_of_decidable_le Mathlib.decidable_lt_of_decidable_le

@[simp] theorem const_div {α : Type u} {β : Type v} {φ : ultrafilter α} [division_ring β] (x : β)
    (y : β) : ↑(x / y) = ↑x / ↑y :=
  rfl

theorem coe_lt {α : Type u} {β : Type v} {φ : ultrafilter α} [preorder β] {f : α → β} {g : α → β} :
    ↑f < ↑g ↔ filter.eventually (fun (x : α) => f x < g x) ↑φ :=
  sorry

theorem coe_pos {α : Type u} {β : Type v} {φ : ultrafilter α} [preorder β] [HasZero β] {f : α → β} :
    0 < ↑f ↔ filter.eventually (fun (x : α) => 0 < f x) ↑φ :=
  coe_lt

theorem const_lt {α : Type u} {β : Type v} {φ : ultrafilter α} [preorder β] {x : β} {y : β} :
    ↑x < ↑y ↔ x < y :=
  iff.trans coe_lt lift_rel_const_iff

theorem lt_def {α : Type u} {β : Type v} {φ : ultrafilter α} [preorder β] : Less = lift_rel Less :=
  sorry

/-- If `φ` is an ultrafilter then the ultraproduct is an ordered ring. -/
protected instance ordered_ring {α : Type u} {β : Type v} {φ : ultrafilter α} [ordered_ring β] :
    ordered_ring (germ (↑φ) β) :=
  ordered_ring.mk ring.add sorry ring.zero sorry sorry ring.neg ring.sub sorry sorry ring.mul sorry
    ring.one sorry sorry sorry sorry ordered_add_comm_group.le ordered_add_comm_group.lt sorry sorry
    sorry sorry sorry sorry

/-- If `φ` is an ultrafilter then the ultraproduct is a linear ordered ring. -/
protected instance linear_ordered_ring {α : Type u} {β : Type v} {φ : ultrafilter α}
    [linear_ordered_ring β] : linear_ordered_ring (germ (↑φ) β) :=
  linear_ordered_ring.mk ordered_ring.add sorry ordered_ring.zero sorry sorry ordered_ring.neg
    ordered_ring.sub sorry sorry ordered_ring.mul sorry ordered_ring.one sorry sorry sorry sorry
    ordered_ring.le ordered_ring.lt sorry sorry sorry sorry sorry sorry sorry
    linear_order.decidable_le linear_order.decidable_eq linear_order.decidable_lt sorry

/-- If `φ` is an ultrafilter then the ultraproduct is a linear ordered field. -/
protected instance linear_ordered_field {α : Type u} {β : Type v} {φ : ultrafilter α}
    [linear_ordered_field β] : linear_ordered_field (germ (↑φ) β) :=
  linear_ordered_field.mk linear_ordered_ring.add sorry linear_ordered_ring.zero sorry sorry
    linear_ordered_ring.neg linear_ordered_ring.sub sorry sorry linear_ordered_ring.mul sorry
    linear_ordered_ring.one sorry sorry sorry sorry linear_ordered_ring.le linear_ordered_ring.lt
    sorry sorry sorry sorry sorry sorry sorry linear_ordered_ring.decidable_le
    linear_ordered_ring.decidable_eq linear_ordered_ring.decidable_lt sorry sorry field.inv sorry
    sorry

/-- If `φ` is an ultrafilter then the ultraproduct is a linear ordered commutative ring. -/
protected instance linear_ordered_comm_ring {α : Type u} {β : Type v} {φ : ultrafilter α}
    [linear_ordered_comm_ring β] : linear_ordered_comm_ring (germ (↑φ) β) :=
  linear_ordered_comm_ring.mk linear_ordered_ring.add sorry linear_ordered_ring.zero sorry sorry
    linear_ordered_ring.neg linear_ordered_ring.sub sorry sorry linear_ordered_ring.mul sorry
    linear_ordered_ring.one sorry sorry sorry sorry linear_ordered_ring.le linear_ordered_ring.lt
    sorry sorry sorry sorry sorry sorry sorry linear_ordered_ring.decidable_le
    linear_ordered_ring.decidable_eq linear_ordered_ring.decidable_lt sorry sorry

/-- If `φ` is an ultrafilter then the ultraproduct is a decidable linear ordered commutative
group. -/
protected instance linear_ordered_add_comm_group {α : Type u} {β : Type v} {φ : ultrafilter α}
    [linear_ordered_add_comm_group β] : linear_ordered_add_comm_group (germ (↑φ) β) :=
  linear_ordered_add_comm_group.mk ordered_add_comm_group.add sorry ordered_add_comm_group.zero
    sorry sorry ordered_add_comm_group.neg ordered_add_comm_group.sub sorry sorry
    ordered_add_comm_group.le ordered_add_comm_group.lt sorry sorry sorry sorry
    linear_order.decidable_le linear_order.decidable_eq linear_order.decidable_lt sorry

theorem max_def {α : Type u} {β : Type v} {φ : ultrafilter α} [linear_order β] (x : germ (↑φ) β)
    (y : germ (↑φ) β) : max x y = map₂ max x y :=
  sorry

theorem min_def {α : Type u} {β : Type v} {φ : ultrafilter α} [K : linear_order β] (x : germ (↑φ) β)
    (y : germ (↑φ) β) : min x y = map₂ min x y :=
  sorry

theorem abs_def {α : Type u} {β : Type v} {φ : ultrafilter α} [linear_ordered_add_comm_group β]
    (x : germ (↑φ) β) : abs x = map abs x :=
  sorry

@[simp] theorem const_max {α : Type u} {β : Type v} {φ : ultrafilter α} [linear_order β] (x : β)
    (y : β) : ↑(max x y) = max ↑x ↑y :=
  eq.mpr (id (Eq._oldrec (Eq.refl (↑(max x y) = max ↑x ↑y)) (max_def ↑x ↑y)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (↑(max x y) = map₂ max ↑x ↑y)) (map₂_const (↑φ) x y max)))
      (Eq.refl ↑(max x y)))

@[simp] theorem const_min {α : Type u} {β : Type v} {φ : ultrafilter α} [linear_order β] (x : β)
    (y : β) : ↑(min x y) = min ↑x ↑y :=
  eq.mpr (id (Eq._oldrec (Eq.refl (↑(min x y) = min ↑x ↑y)) (min_def ↑x ↑y)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (↑(min x y) = map₂ min ↑x ↑y)) (map₂_const (↑φ) x y min)))
      (Eq.refl ↑(min x y)))

@[simp] theorem const_abs {α : Type u} {β : Type v} {φ : ultrafilter α}
    [linear_ordered_add_comm_group β] (x : β) : ↑(abs x) = abs ↑x :=
  const_max x (-x)

end Mathlib


import ring_theory.ideal.operations
import dimension_theory.associate_prime

section

variables {R M A : Type*} [comm_ring R] [add_comm_group M] [module R M] [comm_ring A] [algebra R A]

variables {p : submodule R M}

variables (R M)

def module.coprimary : Prop :=
is_compl ↑(module.non_zero_divisors R M) { r : R | module.is_locally_nilpotent r M }

variables {R M}

namespace module.coprimary

protected
lemma nontrivial (H : module.coprimary R M) : nontrivial M :=
begin
  by_contra h,
  haveI := not_nontrivial_iff_subsingleton.mp h,
  apply set.subset_compl_iff_disjoint_right.mpr H.1 (one_mem $ module.non_zero_divisors R M),
  intro r,
  exact ⟨0, subsingleton.elim _ _⟩
end

protected
lemma nontrivial' (H : module.coprimary R M) : nontrivial R :=
begin
  have := H.nontrivial,
  revert this,
  contrapose,
  simp_rw [not_nontrivial_iff_subsingleton],
  introI _,
  exact module.subsingleton R _
end

protected
lemma or (H : module.coprimary R M) (x : R) :
  x ∈ module.non_zero_divisors R M ∨ module.is_locally_nilpotent x M :=
begin
  have : x ∈ (⊤ : set R) := trivial,
  rwa ← H.sup_eq_top at this
end

protected
lemma iff :
  module.coprimary R M ↔ nontrivial M ∧
    ∀ x, x ∈ module.non_zero_divisors R M ∨ module.is_locally_nilpotent x M :=
begin
  refine ⟨λ h, ⟨h.nontrivial, h.or⟩, _⟩,
  rintros ⟨h₁, h₂⟩,
  constructor,
  { rw ← set.subset_compl_iff_disjoint_left,
    rintros r hr₁ (hr₂ : r ∈ module.non_zero_divisors R M),
    obtain ⟨x, hx⟩ := (nontrivial_iff_exists_ne 0).mp h₁,
    obtain ⟨n, hn⟩ := hr₁ x,
    exact hx (pow_mem hr₂ n _ hn) },
  { rw codisjoint_iff, ext, simpa using h₂ x }
end

protected
lemma iff' [h : nontrivial M] :
  module.coprimary R M ↔ ∀ x, x ∈ module.non_zero_divisors R M ∨ module.is_locally_nilpotent x M :=
begin
  rw [coprimary.iff, and_iff_right h],
end

lemma iff_of_algebra : module.coprimary R A ↔ nontrivial A ∧
  ∀ x, algebra_map R A x ∈ non_zero_divisors A ∨ algebra_map R A x ∈ nilradical A :=
begin
  rw coprimary.iff,
  refine and_congr iff.rfl (forall_congr (λ x, or_congr _ _)),
  { rw module.non_zero_divisors_of_algebra, refl },
  { rw [module.is_locally_nilpotent_of_algebra, nilradical, ← ideal.mem_comap,
      ideal.comap_radical], refl }
end

lemma iff_of_algebra' [h : nontrivial A] : module.coprimary R A ↔
  ∀ x, algebra_map R A x ∈ non_zero_divisors A ∨ algebra_map R A x ∈ nilradical A :=
begin
  rw [iff_of_algebra, and_iff_right h],
end

lemma self [h : nontrivial R] : module.coprimary R R ↔
  ∀ x, x ∈ non_zero_divisors R ∨ x ∈ nilradical R :=
begin
  rw [iff_of_algebra, and_iff_right h],
  refl
end

variables (R M)

protected
lemma tfae [is_noetherian_ring R] :
  tfae [module.coprimary R M,
    associated_primes R M = {Inf (associated_primes R M)},
    ∃ J, associated_primes R M = {J}] :=
begin
  tfae_have : 1 → 2,
  { intro e,
    haveI := e.nontrivial,
    rw set.eq_singleton_iff_nonempty_unique_mem,
    refine ⟨associated_primes_nonempty _ _, λ I H, le_antisymm _ (Inf_le H)⟩,
    show (I : set R) ⊆ ↑(Inf (associated_primes R M)),
    rw [module.coprimary, ← eq_compl_iff_is_compl, eq_compl_comm, ← Union_associated_primes] at e,
    rw [coe_Inf_associated_primes, e],
    exact set.subset_bUnion_of_mem H },
  tfae_have : 2 → 3,
  { exact λ h, ⟨_, h⟩ },
  tfae_have : 3 → 1,
  { rintro ⟨J, e⟩,
    rw [module.coprimary, ← eq_compl_iff_is_compl, eq_compl_comm, ← Union_associated_primes,
      ← coe_Inf_associated_primes, e],
    simp },
  tfae_finish
end

variables {R M}

lemma iff_singleton [is_noetherian_ring R] :
  module.coprimary R M ↔ ∃ J, associated_primes R M = {J} :=
(coprimary.tfae R M).out 0 2

lemma iff_associated_primes' [is_noetherian_ring R] :
  module.coprimary R M ↔ associated_primes R M = {Inf (associated_primes R M)} :=
(coprimary.tfae R M).out 0 1

lemma associated_primes_eq' [is_noetherian_ring R] (h : module.coprimary R M) :
  associated_primes R M = {Inf (associated_primes R M)} :=
iff_associated_primes'.mp h

lemma Inf_associated_primes_is_associated_prime [is_noetherian_ring R] (h : module.coprimary R M) :
  is_associated_prime (Inf (associated_primes R M)) M :=
by { rw ← mem_associate_primes, convert set.mem_singleton _, rwa ← iff_associated_primes' }

lemma Inf_associated_primes_is_prime [is_noetherian_ring R] (h : module.coprimary R M) :
  ideal.is_prime (Inf (associated_primes R M)) :=
h.Inf_associated_primes_is_associated_prime.1

lemma iff_associated_primes [is_noetherian_ring R] [module.finite R M] :
  module.coprimary R M ↔ associated_primes R M = {(⊤ : submodule R M).annihilator.radical} :=
by rw [iff_associated_primes', ← Inf_associated_primes_eq_annihilator_radical]

end module.coprimary

def submodule.is_primary (p : submodule R M) : Prop :=
module.coprimary R (M ⧸ p)

lemma submodule.quotient.subsingleton_iff : subsingleton (M ⧸ p) ↔ p = ⊤ :=
begin
  split,
  { introsI e, rw eq_top_iff, intros x hx, rw ← submodule.quotient.mk_eq_zero,
    exact subsingleton.elim _ _ },
  { rintro rfl, constructor, intros a b,
    obtain ⟨a, rfl⟩ := submodule.quotient.mk_surjective _ a,
    obtain ⟨b, rfl⟩ := submodule.quotient.mk_surjective _ b,
    rw submodule.quotient.eq,
    trivial }
end

lemma submodule.quotient.nontrivial_iff : nontrivial (M ⧸ p) ↔ p ≠ ⊤ :=
begin
  rw [ne.def, ← submodule.quotient.subsingleton_iff, ← not_nontrivial_iff_subsingleton, not_not],
end

lemma submodule.is_primary_iff {p : submodule R M} :
  p.is_primary ↔ p ≠ ⊤ ∧ ∀ (r : R) (m : M), r • m ∈ p → m ∈ p ∨ ∀ m' : M, ∃ n : ℕ, r ^ n • m' ∈ p :=
begin
  rw [submodule.is_primary, module.coprimary.iff],
  refine and_congr submodule.quotient.nontrivial_iff (forall_congr $ λ x, _),
  simp_rw [or_iff_not_imp_left, module.mem_non_zero_divisors, ← submodule.quotient.mk_eq_zero,
    submodule.quotient.mk_smul],
  push_neg,
  split,
  { rintros H m e e' m', apply H ⟨_, e, e'⟩ },
  { rintros H ⟨m, e, e'⟩ m',
    obtain ⟨m, rfl⟩ := submodule.quotient.mk_surjective _ m,
    obtain ⟨m', rfl⟩ := submodule.quotient.mk_surjective _ m',
    exact H m e e' m' },
end

lemma comap_nilradical {R S : Type*} [comm_ring R] [comm_ring S] (f : R →+* S) :
  (nilradical S).comap f = f.ker.radical :=
ideal.comap_radical f 0

lemma ideal.submodule_is_primary_iff (I : ideal R) : submodule.is_primary I ↔ I.is_primary :=
begin
  by_cases I = ⊤,
  { have : ¬ submodule.is_primary I,
    { intro H, haveI := H.nontrivial, apply not_subsingleton (R ⧸ I), rw h, apply_instance },
    simpa [ideal.is_primary, h] },
  haveI := ideal.quotient.nontrivial h,
  rw [submodule.is_primary, module.coprimary.iff_of_algebra', ideal.is_primary, and_iff_right h],
  simp_rw [← ideal.mem_comap, comap_nilradical, ideal.quotient.algebra_map_eq, ideal.mk_ker,
    or_iff_not_imp_right, ← @ideal.quotient.eq_zero_iff_mem _ _ _ I],
  split,
  { intros H x y e hy, exact H y hy (ideal.quotient.mk I x) e },
  { intros H x hx y e, obtain ⟨y, rfl⟩ := ideal.quotient.mk_surjective y, exact (H e hx) }
end

lemma ideal.is_primary_iff_associated_primes [is_noetherian_ring R] {I : ideal R} :
  I.is_primary ↔ associated_primes R (R ⧸ I) = {I.radical} :=
begin
  rw [← ideal.submodule_is_primary_iff, submodule.is_primary,
    module.coprimary.iff_associated_primes, iff_iff_eq],
  congr,
  rw [submodule.top_annihilator_eq_ker],
  simp,
end

def inf_irreducible {α : Type*} [semilattice_inf α] (x : α) : Prop :=
∀ ⦃y z⦄, x = y ⊓ z → x = y ∨ x = z

lemma inf_irreducible_iff {α : Type*} [semilattice_inf α] (x : α) :
  inf_irreducible x ↔ ∀ y z, x ≤ y → x ≤ z → x = y ⊓ z → y ≤ x ∨ z ≤ x :=
forall₂_congr (λ y z, ⟨λ h _ _ e, or.imp eq.ge eq.ge (h e), λ h e, by simpa [e] using h⟩)

lemma module.coprimary_of_inf_irreducible [nontrivial M] [is_noetherian R M]
  (h : inf_irreducible (⊥ : submodule R M)) : module.coprimary R M :=
begin
  rw module.coprimary.iff',
  intro x,
  rw module.is_locally_nilpotent_iff_mem_radical,
  obtain ⟨n, hn, H⟩ := is_noetherian.exists_endomorphism_iterate_ker_inf_range_eq_bot
    (algebra_map R (module.End R M) x),
  cases h H.symm with h h,
  { refine or.inl (λ m hm, (_ : m ∈ (⊥ : submodule R M))),
    rw [h, ← map_pow, ← tsub_add_cancel_of_le (nat.one_le_iff_ne_zero.mpr hn), pow_add, pow_one],
    show _ • m = 0, rw [mul_smul, hm, smul_zero] },
  { refine or.inr ⟨n, _⟩,
    rw [submodule.mem_annihilator', ← submodule.map_le_iff_le_comap, ← eq_bot_iff, h,
      linear_map.range_eq_map, ← map_pow, algebra.algebra_map_eq_smul_one],
    refl }
end

lemma submodule.is_primary_of_inf_irreducible [is_noetherian R M]
  (h : inf_irreducible p) (h' : p ≠ ⊤) : p.is_primary :=
begin
  haveI : nontrivial (M ⧸ p) := submodule.quotient.nontrivial_iff.mpr h',
  apply module.coprimary_of_inf_irreducible,
  intros x y e,
  simp_rw [← (submodule.comap_injective_of_surjective p.mkq_surjective).eq_iff,
    submodule.comap_bot, p.ker_mkq],
  apply h,
  rw [← submodule.comap_inf, ← e, submodule.comap_bot, p.ker_mkq],
end

lemma exists_inf_irreducibles_inter {α : Type*} [semilattice_inf α] [order_top α]
  [well_founded_gt α] (a : α) (h : a ≠ ⊤) :
  ∃ s : finset α, s.inf id = a ∧ ∀ x ∈ s, x ≠ ⊤ ∧ inf_irreducible x :=
begin
  classical,
  revert h,
  apply well_founded_gt.induction a; clear a,
  intros x H hx,
  by_cases inf_irreducible x,
  { refine ⟨{x}, finset.inf_singleton, λ x' e, _⟩, rw finset.mem_singleton.mp e, exact ⟨hx, h⟩ },
  delta inf_irreducible at h,
  push_neg at h,
  obtain ⟨y, z, rfl, ey, ez⟩ := h,
  obtain ⟨s, hs₁, hs₂⟩ := H y (lt_of_le_of_ne inf_le_left ey) (λ e, by simpa [e] using ez),
  obtain ⟨t, ht₁, ht₂⟩ := H z (lt_of_le_of_ne inf_le_right ez) (λ e, by simpa [e] using ey),
  exact ⟨s ∪ t, by rw [finset.inf_union, hs₁, ht₁],
    λ x, by simpa [or_imp_distrib] using and.intro (hs₂ x) (ht₂ x)⟩
end

end


import Mathbin.Data.MvPolynomial.Basic
import Mathlib.Tactic.Cases
import Mathlib.Tactic.Ring

open MvPolynomial

section

universe u

variable {F : Type u} [Field F]

variable {vars : Type}
variable [DecidableEq vars]

noncomputable def increment (f : vars →₀ ℕ) (s : vars) : (vars →₀ ℕ) := f + Finsupp.single s (1 : ℕ)

variable (f g : vars →₀ ℕ)

noncomputable def decrement (f : vars →₀ ℕ) (s : vars) : (vars →₀ ℕ) := f - Finsupp.single s (1 : ℕ)

lemma inc_nochange (f : vars →₀ ℕ) {s a : vars} (hsa : ¬ s = a) : increment f s a = f a := by
  change coeFn f a + coeFn (Finsupp.single s 1) a =  coeFn f a
  rw [Finsupp.single_eq_of_ne hsa]
  ring

lemma inc_change (f : vars →₀ ℕ) {s a : vars} (hsa : s = a) : increment f s a = f a + 1 := by
  change coeFn f a + coeFn (Finsupp.single s 1) a =  coeFn f a + 1
  rw [hsa, Finsupp.single_eq_same]

lemma dec_nochange (f : vars →₀ ℕ) {s a : vars} (hsa : ¬ s = a) : decrement f s a = f a := by
  change coeFn f a - coeFn (Finsupp.single s 1) a =  coeFn f a
  rw [Finsupp.single_eq_of_ne hsa]
  ring

lemma dec_change (f : vars →₀ ℕ) {s a : vars} (hsa : s = a) : decrement f s a = f a - 1 := by
  change coeFn f a - coeFn (Finsupp.single s 1) a =  coeFn f a - 1
  rw [hsa, Finsupp.single_eq_same]

-- The fact that I need to include all of these lemmas is weird...
lemma coefn_funlike {α : vars →₀ ℕ} : coeFn α = FunLike.coe α := by rfl

lemma one_eq_one (n : ℕ) : n - 1 = n - One.one := by rfl

lemma equal_dec_equal
  (s : vars) (f g : vars →₀ ℕ)
  (hf : 0 < f s)
  (hg : 0 < g s)
  (hxy : decrement f s = decrement g s) :
  f = g :=
by
  apply Finsupp.ext
  intro a
  rw [FunLike.ext_iff] at hxy
  specialize hxy a
  by_cases h : s = a
  · rw [coefn_funlike, coefn_funlike] at *
    rw [dec_change f h, dec_change g h,
        one_eq_one, one_eq_one,
        ← Nat.pred_eq_sub_one (FunLike.coe f a),
        ← Nat.pred_eq_sub_one (FunLike.coe g a)] at hxy
    rw [h] at hf hg
    exact Nat.pred_injₓ hf hg hxy
  · rw [coefn_funlike, coefn_funlike] at *
    rw [dec_nochange f h, dec_nochange g h] at hxy
    exact hxy

lemma inc_dec_nonzero_equal
  (s : vars) (f : vars →₀ ℕ) (hf : 0 < f s) :
  increment (decrement f s) s = f :=
by
  apply Finsupp.ext
  intro a
  by_cases h : s = a
  · change (coeFn f) a - (coeFn $ Finsupp.single s 1) a + (coeFn $ Finsupp.single s 1) a = coeFn f a
    rw [h, Finsupp.single_eq_same]
    rw [← coefn_funlike, h] at hf
    exact Nat.succ_pred_eq_of_posₓ hf
  · change (coeFn f) a - (coeFn $ Finsupp.single s 1) a + (coeFn $ Finsupp.single s 1) a = coeFn f a
    rw [Finsupp.single_eq_of_ne h]
    ring

lemma dec_inc_equal (s : vars) (f : vars →₀ ℕ) : decrement (increment f s) s = f := by
  apply Finsupp.ext
  intro a
  by_cases h : s = a
  · change (coeFn f) a + (coeFn $ Finsupp.single s 1) a - (coeFn $ Finsupp.single s 1) a = coeFn f a
    rw [h, Finsupp.single_eq_same]
    ring
  · change (coeFn f) a + (coeFn $ Finsupp.single s 1) a - (coeFn $ Finsupp.single s 1) a = coeFn f a
    rw [Finsupp.single_eq_of_ne h]
    ring

/-
the div_X function in data.polynomial.div returns a polynomial in the form of a curly-brace enclosed support, to_fun, mem_support_to_fun
This is because a polynomial is defined as an add_monoid_algebra, which is a finsupp function, which has these three fields
Explicity
  support is the support of the function
  to_fun is the function itself
  mem_support_to_fun is the proof that the function is nonzero exacly on it's defined support
Frankly, this function should be generalized to all mv_polynomials
Not just mv_polynomials over vars
TODO generalize this method and add to mathlib candidates folder
-/
noncomputable def div_X_v2 (p : MvPolynomial vars F) (s : vars)
             (h : (∀ m : vars →₀ ℕ, m s = 0 -> p.coeff m = 0))
             : MvPolynomial vars F where
  toFun              := fun m => p.coeff (increment m s)
  support            := p.support.image (fun m => decrement m s)
  mem_support_to_fun := by
    intro a
    dsimp
    apply Iff.intro
    · intro h1
      have h2 := Finset.mem_image.1 h1
      rcases h2 with ⟨a_1, H, h3⟩
      rw [Eq.symm h3]
      clear h3
      clear h1
      have h4 : p.coeff a_1 ≠ 0 := (p.mem_support_to_fun a_1).1 H
      clear H
      suffices h6 : increment (decrement a_1 s) s = a_1
      rw [h6]
      exact h4
      have h7 : a_1 s ≠ 0
      intro foo
      apply h4
      apply h
      exact foo
      have h8 := Nat.pos_of_ne_zero h7
      apply inc_dec_nonzero_equal s a_1
      sorry -- exact h8 -- some annoying LE vs. < issues
    · intro h1
      apply Finset.mem_image.2
      apply Exists.intro (increment a s)
      apply Exists.intro
      exact dec_inc_equal s a
      exact (p.mem_support_to_fun (increment a s)).2 h1

/-- In the product of a polynomial with a variable, the coefficients of all terms without that variable are zero -/
lemma coeff_mul_X_eq_zero (a : MvPolynomial vars F) (s : vars) (m : vars →₀ ℕ) :
  m s = (0 : ℕ) → (a * (MvPolynomial.x s : MvPolynomial vars F)).coeff m = 0 :=
by
  intro hc
  rw [coeff_mul_X']
  apply if_neg
  rw [Finsupp.not_mem_support_iff, coefn_funlike, hc]
  rfl

-- TODO: the converse of the above statement
lemma right_cancel_X_mul {a b : MvPolynomial vars F} (s : vars)
  (h : a * (x s : MvPolynomial vars F) = b * (x s : MvPolynomial vars F)) :
  a = b :=
by
  apply MvPolynomial.ext _ _ (λ m => ?_)
  rw [← coeff_mul_X m s a, ← coeff_mul_X m s b, h]

lemma left_cancel_X_mul {a b : MvPolynomial vars F} (s : vars)
  (h : (x s : MvPolynomial vars F) * a = (x s : MvPolynomial vars F) * b):
  a = b :=
by
  apply right_cancel_X_mul s
  rw [_root_.mul_comm, h, _root_.mul_comm]

-- For all monomials with no X component, the coefficient of a is zero
-- a * b = c
-- then for all monomials with no X component, the coefficient of a is zero
lemma mul_no_constant_no_constant (a b c : MvPolynomial vars F) (s : vars) :
  (∀ m : vars →₀ ℕ, m s = 0 → a.coeff m = 0) → (a * b = c) → ∀ m : vars →₀ ℕ, m s = 0 -> c.coeff m = 0 :=
by
  intros ha heq m hc
  let aDivX := div_X_v2 a s ha
  have h1 : aDivX * (@x F vars _ s) = a
  · rw [ext_iff]
    intro m2
    rw [coeff_mul_X']
    by_cases h : HasMem.Mem s m2.support
    · have h2 : aDivX.coeff (Sub.sub m2 (Finsupp.single s One.one)) = a.coeff m2 := by
        have h3 : aDivX.coeff (Sub.sub m2 (Finsupp.single s One.one)) = a.coeff (increment (Sub.sub m2 (Finsupp.single s One.one)) s) := rfl
        rw [h3]
        clear h3
        have h4 : a.coeff (increment (Sub.sub m2 (Finsupp.single s One.one)) s) = a.coeff (increment (decrement m2 s) s) := rfl
        rw [h4]
        clear h4
        have h5 := (m2.mem_support_to_fun s).1 h
        have h6 := inc_dec_nonzero_equal s m2 (sorry) -- (Nat.pos_of_ne_zero h5) -- doesn't work because of LE vs <
        rw [h6]
      change (if HasMem.Mem s m2.support then coeff (Sub.sub m2 (Finsupp.single s One.one)) aDivX else Zero.zero) = coeff m2 a
      rw [h2]
      clear h2
      apply if_pos
      exact h
    · have h7 : a.coeff m2 = 0 := by
        apply ha
        by_contra a_1
        apply h ((m2.mem_support_to_fun s).2 a_1)
      rw [h7]
      apply if_neg
      exact h
  · have h4 : (aDivX * (@x F vars _ s)) * b = c := by
      rw [h1]
      exact heq
    clear h1
    rw [←h4]
    conv =>
      lhs
      congr
      skip
      rw [_root_.mul_comm, ←_root_.mul_assoc]
    apply coeff_mul_X_eq_zero
    exact hc


/-
Copyright (c) 2019 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Floris van Doorn, Yury Kudryashov, Sébastien Gouëzel, Chris Hughes
-/
import data.fin.basic
/-!
# Operation on tuples

We interpret maps `Π i : fin n, α i` as `n`-tuples of elements of possibly varying type `α i`,
`(α 0, …, α (n-1))`. A particular case is `fin n → α` of elements with all the same type.
In this case when `α i` is a constant map, then tuples are isomorphic (but not definitionally equal)
to `vector`s.

We define the following operations:

* `fin.tail` : the tail of an `n+1` tuple, i.e., its last `n` entries;
* `fin.cons` : adding an element at the beginning of an `n`-tuple, to get an `n+1`-tuple;
* `fin.init` : the beginning of an `n+1` tuple, i.e., its first `n` entries;
* `fin.snoc` : adding an element at the end of an `n`-tuple, to get an `n+1`-tuple. The name `snoc`
  comes from `cons` (i.e., adding an element to the left of a tuple) read in reverse order.
* `fin.insert_nth` : insert an element to a tuple at a given position.
* `fin.find p` : returns the first index `n` where `p n` is satisfied, and `none` if it is never
  satisfied.

-/
universes u v

namespace fin

variables {m n : ℕ}
open function

section tuple

/-- There is exactly one tuple of size zero. -/
example (α : fin 0 → Sort u) : unique (Π i : fin 0, α i) :=
by apply_instance

@[simp] lemma tuple0_le {α : Π i : fin 0, Type*} [Π i, preorder (α i)] (f g : Π i, α i) : f ≤ g :=
fin_zero_elim

variables {α : fin (n+1) → Type u} (x : α 0) (q : Πi, α i) (p : Π(i : fin n), α (i.succ))
  (i : fin n) (y : α i.succ) (z : α 0)

/-- The tail of an `n+1` tuple, i.e., its last `n` entries. -/
def tail (q : Πi, α i) : (Π(i : fin n), α (i.succ)) := λ i, q i.succ

lemma tail_def {n : ℕ} {α : fin (n+1) → Type*} {q : Π i, α i} :
  tail (λ k : fin (n+1), q k) = (λ k : fin n, q k.succ) := rfl

/-- Adding an element at the beginning of an `n`-tuple, to get an `n+1`-tuple. -/
def cons (x : α 0) (p : Π(i : fin n), α (i.succ)) : Πi, α i :=
λ j, fin.cases x p j

@[simp] lemma tail_cons : tail (cons x p) = p :=
by simp [tail, cons]

@[simp] lemma cons_succ : cons x p i.succ = p i :=
by simp [cons]

@[simp] lemma cons_zero : cons x p 0 = x :=
by simp [cons]

/-- Updating a tuple and adding an element at the beginning commute. -/
@[simp] lemma cons_update : cons x (update p i y) = update (cons x p) i.succ y :=
begin
  ext j,
  by_cases h : j = 0,
  { rw h, simp [ne.symm (succ_ne_zero i)] },
  { let j' := pred j h,
    have : j'.succ = j := succ_pred j h,
    rw [← this, cons_succ],
    by_cases h' : j' = i,
    { rw h', simp },
    { have : j'.succ ≠ i.succ, by rwa [ne.def, succ_inj],
      rw [update_noteq h', update_noteq this, cons_succ] } }
end

/-- Adding an element at the beginning of a tuple and then updating it amounts to adding it
directly. -/
lemma update_cons_zero : update (cons x p) 0 z = cons z p :=
begin
  ext j,
  by_cases h : j = 0,
  { rw h, simp },
  { simp only [h, update_noteq, ne.def, not_false_iff],
    let j' := pred j h,
    have : j'.succ = j := succ_pred j h,
    rw [← this, cons_succ, cons_succ] }
end

/-- Concatenating the first element of a tuple with its tail gives back the original tuple -/
@[simp] lemma cons_self_tail : cons (q 0) (tail q) = q :=
begin
  ext j,
  by_cases h : j = 0,
  { rw h, simp },
  { let j' := pred j h,
    have : j'.succ = j := succ_pred j h,
    rw [← this, tail, cons_succ] }
end

/-- Updating the first element of a tuple does not change the tail. -/
@[simp] lemma tail_update_zero : tail (update q 0 z) = tail q :=
by { ext j, simp [tail, fin.succ_ne_zero] }

/-- Updating a nonzero element and taking the tail commute. -/
@[simp] lemma tail_update_succ :
  tail (update q i.succ y) = update (tail q) i y :=
begin
  ext j,
  by_cases h : j = i,
  { rw h, simp [tail] },
  { simp [tail, (fin.succ_injective n).ne h, h] }
end

lemma comp_cons {α : Type*} {β : Type*} (g : α → β) (y : α) (q : fin n → α) :
  g ∘ (cons y q) = cons (g y) (g ∘ q) :=
begin
  ext j,
  by_cases h : j = 0,
  { rw h, refl },
  { let j' := pred j h,
    have : j'.succ = j := succ_pred j h,
    rw [← this, cons_succ, comp_app, cons_succ] }
end

lemma comp_tail {α : Type*} {β : Type*} (g : α → β) (q : fin n.succ → α) :
  g ∘ (tail q) = tail (g ∘ q) :=
by { ext j, simp [tail] }

lemma le_cons [Π i, preorder (α i)] {x : α 0} {q : Π i, α i} {p : Π i : fin n, α i.succ} :
  q ≤ cons x p ↔ q 0 ≤ x ∧ tail q ≤ p :=
forall_fin_succ.trans $ and_congr iff.rfl $ forall_congr $ λ j, by simp [tail]

lemma cons_le [Π i, preorder (α i)] {x : α 0} {q : Π i, α i} {p : Π i : fin n, α i.succ} :
  cons x p ≤ q ↔ x ≤ q 0 ∧ p ≤ tail q :=
@le_cons  _ (λ i, order_dual (α i)) _ x q p

@[simp]
lemma range_cons {α : Type*} {n : ℕ} (x : α) (b : fin n → α) :
  set.range (fin.cons x b : fin n.succ → α) = insert x (set.range b) :=
begin
  ext y,
  simp only [set.mem_range, set.mem_insert_iff],
  split,
  { rintros ⟨i, rfl⟩,
    refine cases (or.inl (cons_zero _ _)) (λ i, or.inr ⟨i, _⟩) i,
    rw cons_succ },
  { rintros (rfl | ⟨i, hi⟩),
    { exact ⟨0, fin.cons_zero _ _⟩ },
    { refine ⟨i.succ, _⟩,
      rw [cons_succ, hi] } }
end

/-- `fin.append ho u v` appends two vectors of lengths `m` and `n` to produce
one of length `o = m + n`.  `ho` provides control of definitional equality
for the vector length. -/
def append {α : Type*} {o : ℕ} (ho : o = m + n) (u : fin m → α) (v : fin n → α) : fin o → α :=
λ i, if h : (i : ℕ) < m
  then u ⟨i, h⟩
  else v ⟨(i : ℕ) - m, (tsub_lt_iff_left (le_of_not_lt h)).2 (ho ▸ i.property)⟩

@[simp] lemma fin_append_apply_zero {α : Type*} {o : ℕ} (ho : (o + 1) = (m + 1) + n)
  (u : fin (m + 1) → α) (v : fin n → α) :
  fin.append ho u v 0 = u 0 := rfl

end tuple

section tuple_right
/-! In the previous section, we have discussed inserting or removing elements on the left of a
tuple. In this section, we do the same on the right. A difference is that `fin (n+1)` is constructed
inductively from `fin n` starting from the left, not from the right. This implies that Lean needs
more help to realize that elements belong to the right types, i.e., we need to insert casts at
several places. -/

variables {α : fin (n+1) → Type u} (x : α (last n)) (q : Πi, α i) (p : Π(i : fin n), α i.cast_succ)
(i : fin n) (y : α i.cast_succ) (z : α (last n))

/-- The beginning of an `n+1` tuple, i.e., its first `n` entries -/
def init (q : Πi, α i) (i : fin n) : α i.cast_succ :=
q i.cast_succ

lemma init_def {n : ℕ} {α : fin (n+1) → Type*} {q : Π i, α i} :
  init (λ k : fin (n+1), q k) = (λ k : fin n, q k.cast_succ) := rfl

/-- Adding an element at the end of an `n`-tuple, to get an `n+1`-tuple. The name `snoc` comes from
`cons` (i.e., adding an element to the left of a tuple) read in reverse order. -/
def snoc (p : Π(i : fin n), α i.cast_succ) (x : α (last n)) (i : fin (n+1)) : α i :=
if h : i.val < n
then _root_.cast (by rw fin.cast_succ_cast_lt i h) (p (cast_lt i h))
else _root_.cast (by rw eq_last_of_not_lt h) x

@[simp] lemma init_snoc : init (snoc p x) = p :=
begin
  ext i,
  have h' := fin.cast_lt_cast_succ i i.is_lt,
  simp [init, snoc, i.is_lt, h'],
  convert cast_eq rfl (p i)
end

@[simp] lemma snoc_cast_succ : snoc p x i.cast_succ = p i :=
begin
  have : i.cast_succ.val < n := i.is_lt,
  have h' := fin.cast_lt_cast_succ i i.is_lt,
  simp [snoc, this, h'],
  convert cast_eq rfl (p i)
end

@[simp] lemma snoc_last : snoc p x (last n) = x :=
by { simp [snoc] }

/-- Updating a tuple and adding an element at the end commute. -/
@[simp] lemma snoc_update : snoc (update p i y) x = update (snoc p x) i.cast_succ y :=
begin
  ext j,
  by_cases h : j.val < n,
  { simp only [snoc, h, dif_pos],
    by_cases h' : j = cast_succ i,
    { have C1 : α i.cast_succ = α j, by rw h',
      have E1 : update (snoc p x) i.cast_succ y j = _root_.cast C1 y,
      { have : update (snoc p x) j (_root_.cast C1 y) j = _root_.cast C1 y, by simp,
        convert this,
        { exact h'.symm },
        { exact heq_of_cast_eq (congr_arg α (eq.symm h')) rfl } },
      have C2 : α i.cast_succ = α (cast_succ (cast_lt j h)),
        by rw [cast_succ_cast_lt, h'],
      have E2 : update p i y (cast_lt j h) = _root_.cast C2 y,
      { have : update p (cast_lt j h) (_root_.cast C2 y) (cast_lt j h) = _root_.cast C2 y,
          by simp,
        convert this,
        { simp [h, h'] },
        { exact heq_of_cast_eq C2 rfl } },
      rw [E1, E2],
      exact eq_rec_compose _ _ _ },
    { have : ¬(cast_lt j h = i),
        by { assume E, apply h', rw [← E, cast_succ_cast_lt] },
      simp [h', this, snoc, h] } },
  { rw eq_last_of_not_lt h,
    simp [ne.symm (ne_of_lt (cast_succ_lt_last i))] }
end

/-- Adding an element at the beginning of a tuple and then updating it amounts to adding it
directly. -/
lemma update_snoc_last : update (snoc p x) (last n) z = snoc p z :=
begin
  ext j,
  by_cases h : j.val < n,
  { have : j ≠ last n := ne_of_lt h,
    simp [h, update_noteq, this, snoc] },
  { rw eq_last_of_not_lt h,
    simp }
end

/-- Concatenating the first element of a tuple with its tail gives back the original tuple -/
@[simp] lemma snoc_init_self : snoc (init q) (q (last n)) = q :=
begin
  ext j,
  by_cases h : j.val < n,
  { have : j ≠ last n := ne_of_lt h,
    simp [h, update_noteq, this, snoc, init, cast_succ_cast_lt],
    have A : cast_succ (cast_lt j h) = j := cast_succ_cast_lt _ _,
    rw ← cast_eq rfl (q j),
    congr' 1; rw A },
  { rw eq_last_of_not_lt h,
    simp }
end

/-- Updating the last element of a tuple does not change the beginning. -/
@[simp] lemma init_update_last : init (update q (last n) z) = init q :=
by { ext j, simp [init, ne_of_lt, cast_succ_lt_last] }

/-- Updating an element and taking the beginning commute. -/
@[simp] lemma init_update_cast_succ :
  init (update q i.cast_succ y) = update (init q) i y :=
begin
  ext j,
  by_cases h : j = i,
  { rw h, simp [init] },
  { simp [init, h] }
end

/-- `tail` and `init` commute. We state this lemma in a non-dependent setting, as otherwise it
would involve a cast to convince Lean that the two types are equal, making it harder to use. -/
lemma tail_init_eq_init_tail {β : Type*} (q : fin (n+2) → β) :
  tail (init q) = init (tail q) :=
by { ext i, simp [tail, init, cast_succ_fin_succ] }

/-- `cons` and `snoc` commute. We state this lemma in a non-dependent setting, as otherwise it
would involve a cast to convince Lean that the two types are equal, making it harder to use. -/
lemma cons_snoc_eq_snoc_cons {β : Type*} (a : β) (q : fin n → β) (b : β) :
  @cons n.succ (λ i, β) a (snoc q b) = snoc (cons a q) b :=
begin
  ext i,
  by_cases h : i = 0,
  { rw h, refl },
  set j := pred i h with ji,
  have : i = j.succ, by rw [ji, succ_pred],
  rw [this, cons_succ],
  by_cases h' : j.val < n,
  { set k := cast_lt j h' with jk,
    have : j = k.cast_succ, by rw [jk, cast_succ_cast_lt],
    rw [this, ← cast_succ_fin_succ],
    simp },
  rw [eq_last_of_not_lt h', succ_last],
  simp
end

lemma comp_snoc {α : Type*} {β : Type*} (g : α → β) (q : fin n → α) (y : α) :
  g ∘ (snoc q y) = snoc (g ∘ q) (g y) :=
begin
  ext j,
  by_cases h : j.val < n,
  { have : j ≠ last n := ne_of_lt h,
    simp [h, this, snoc, cast_succ_cast_lt] },
  { rw eq_last_of_not_lt h,
    simp }
end

lemma comp_init {α : Type*} {β : Type*} (g : α → β) (q : fin n.succ → α) :
  g ∘ (init q) = init (g ∘ q) :=
by { ext j, simp [init] }

end tuple_right

section insert_nth

variables {α : fin (n+1) → Type u} {β : Type v}

/-- Define a function on `fin (n + 1)` from a value on `i : fin (n + 1)` and values on each
`fin.succ_above i j`, `j : fin n`. This version is elaborated as eliminator and works for
propositions, see also `fin.insert_nth` for a version without an `@[elab_as_eliminator]`
attribute. -/
@[elab_as_eliminator]
def succ_above_cases {α : fin (n + 1) → Sort u} (i : fin (n + 1)) (x : α i)
  (p : Π j : fin n, α (i.succ_above j)) (j : fin (n + 1)) : α j :=
if hj : j = i then eq.rec x hj.symm
else if hlt : j < i then eq.rec_on (succ_above_cast_lt hlt) (p _)
else eq.rec_on (succ_above_pred $ (ne.lt_or_lt hj).resolve_left hlt) (p _)

lemma forall_iff_succ_above {p : fin (n + 1) → Prop} (i : fin (n + 1)) :
  (∀ j, p j) ↔ p i ∧ ∀ j, p (i.succ_above j) :=
⟨λ h, ⟨h _, λ j, h _⟩, λ h, succ_above_cases i h.1 h.2⟩

/-- Insert an element into a tuple at a given position. For `i = 0` see `fin.cons`,
for `i = fin.last n` see `fin.snoc`. See also `fin.succ_above_cases` for a version elaborated
as an eliminator. -/
def insert_nth (i : fin (n + 1)) (x : α i) (p : Π j : fin n, α (i.succ_above j)) (j : fin (n + 1)) :
  α j :=
succ_above_cases i x p j

@[simp] lemma insert_nth_apply_same (i : fin (n + 1)) (x : α i) (p : Π j, α (i.succ_above j)) :
  insert_nth i x p i = x :=
by simp [insert_nth, succ_above_cases]

@[simp] lemma insert_nth_apply_succ_above (i : fin (n + 1)) (x : α i) (p : Π j, α (i.succ_above j))
  (j : fin n) :
  insert_nth i x p (i.succ_above j) = p j :=
begin
  simp only [insert_nth, succ_above_cases, dif_neg (succ_above_ne _ _)],
  by_cases hlt : j.cast_succ < i,
  { rw [dif_pos ((succ_above_lt_iff _ _).2 hlt)],
    apply eq_of_heq ((eq_rec_heq _ _).trans _),
    rw [cast_lt_succ_above hlt] },
  { rw [dif_neg (mt (succ_above_lt_iff _ _).1 hlt)],
    apply eq_of_heq ((eq_rec_heq _ _).trans _),
    rw [pred_succ_above (le_of_not_lt hlt)] }
end

@[simp] lemma succ_above_cases_eq_insert_nth :
  @succ_above_cases.{u + 1} = @insert_nth.{u} := rfl

@[simp] lemma insert_nth_comp_succ_above (i : fin (n + 1)) (x : β) (p : fin n → β) :
  insert_nth i x p ∘ i.succ_above = p :=
funext $ insert_nth_apply_succ_above i x p

lemma insert_nth_eq_iff {i : fin (n + 1)} {x : α i} {p : Π j, α (i.succ_above j)} {q : Π j, α j} :
  i.insert_nth x p = q ↔ q i = x ∧ p = (λ j, q (i.succ_above j)) :=
by simp [funext_iff, forall_iff_succ_above i, eq_comm]

lemma eq_insert_nth_iff {i : fin (n + 1)} {x : α i} {p : Π j, α (i.succ_above j)} {q : Π j, α j} :
  q = i.insert_nth x p ↔ q i = x ∧ p = (λ j, q (i.succ_above j)) :=
eq_comm.trans insert_nth_eq_iff

lemma insert_nth_apply_below {i j : fin (n + 1)} (h : j < i) (x : α i)
  (p : Π k, α (i.succ_above k)) :
  i.insert_nth x p j = eq.rec_on (succ_above_cast_lt h) (p $ j.cast_lt _) :=
by rw [insert_nth, succ_above_cases, dif_neg h.ne, dif_pos h]

lemma insert_nth_apply_above {i j : fin (n + 1)} (h : i < j) (x : α i)
  (p : Π k, α (i.succ_above k)) :
  i.insert_nth x p j = eq.rec_on (succ_above_pred h) (p $ j.pred _) :=
by rw [insert_nth, succ_above_cases, dif_neg h.ne', dif_neg h.not_lt]

lemma insert_nth_zero (x : α 0) (p : Π j : fin n, α (succ_above 0 j)) :
  insert_nth 0 x p = cons x (λ j, _root_.cast (congr_arg α (congr_fun succ_above_zero j)) (p j)) :=
begin
  refine insert_nth_eq_iff.2 ⟨by simp, _⟩,
  ext j,
  convert (cons_succ _ _ _).symm
end

@[simp] lemma insert_nth_zero' (x : β) (p : fin n → β) :
  @insert_nth _ (λ _, β) 0 x p = cons x p :=
by simp [insert_nth_zero]

lemma insert_nth_last (x : α (last n)) (p : Π j : fin n, α ((last n).succ_above j)) :
  insert_nth (last n) x p =
    snoc (λ j, _root_.cast (congr_arg α (succ_above_last_apply j)) (p j)) x :=
begin
  refine insert_nth_eq_iff.2 ⟨by simp, _⟩,
  ext j,
  apply eq_of_heq,
  transitivity snoc (λ j, _root_.cast (congr_arg α (succ_above_last_apply j)) (p j)) x j.cast_succ,
  { rw [snoc_cast_succ], exact (cast_heq _ _).symm },
  { apply congr_arg_heq,
    rw [succ_above_last] }
end

@[simp] lemma insert_nth_last' (x : β) (p : fin n → β) :
  @insert_nth _ (λ _, β) (last n) x p = snoc p x :=
by simp [insert_nth_last]

@[simp] lemma insert_nth_zero_right [Π j, has_zero (α j)] (i : fin (n + 1)) (x : α i) :
  i.insert_nth x 0 = pi.single i x :=
insert_nth_eq_iff.2 $ by simp [succ_above_ne, pi.zero_def]

lemma insert_nth_binop (op : Π j, α j → α j → α j) (i : fin (n + 1))
  (x y : α i) (p q : Π j, α (i.succ_above j)) :
  i.insert_nth (op i x y) (λ j, op _ (p j) (q j)) =
    λ j, op j (i.insert_nth x p j) (i.insert_nth y q j) :=
insert_nth_eq_iff.2 $ by simp

@[simp] lemma insert_nth_mul [Π j, has_mul (α j)] (i : fin (n + 1))
  (x y : α i) (p q : Π j, α (i.succ_above j)) :
  i.insert_nth (x * y) (p * q) = i.insert_nth x p * i.insert_nth y q :=
insert_nth_binop (λ _, (*)) i x y p q

@[simp] lemma insert_nth_add [Π j, has_add (α j)] (i : fin (n + 1))
  (x y : α i) (p q : Π j, α (i.succ_above j)) :
  i.insert_nth (x + y) (p + q) = i.insert_nth x p + i.insert_nth y q :=
insert_nth_binop (λ _, (+)) i x y p q

@[simp] lemma insert_nth_div [Π j, has_div (α j)] (i : fin (n + 1))
  (x y : α i) (p q : Π j, α (i.succ_above j)) :
  i.insert_nth (x / y) (p / q) = i.insert_nth x p / i.insert_nth y q :=
insert_nth_binop (λ _, (/)) i x y p q

@[simp] lemma insert_nth_sub [Π j, has_sub (α j)] (i : fin (n + 1))
  (x y : α i) (p q : Π j, α (i.succ_above j)) :
  i.insert_nth (x - y) (p - q) = i.insert_nth x p - i.insert_nth y q :=
insert_nth_binop (λ _, has_sub.sub) i x y p q

@[simp] lemma insert_nth_sub_same [Π j, add_group (α j)] (i : fin (n + 1))
  (x y : α i) (p : Π j, α (i.succ_above j)) :
  i.insert_nth x p - i.insert_nth y p = pi.single i (x - y) :=
by simp_rw [← insert_nth_sub, ← insert_nth_zero_right, pi.sub_def, sub_self, pi.zero_def]

variables [Π i, preorder (α i)]

lemma insert_nth_le_iff {i : fin (n + 1)} {x : α i} {p : Π j, α (i.succ_above j)} {q : Π j, α j} :
  i.insert_nth x p ≤ q ↔ x ≤ q i ∧ p ≤ (λ j, q (i.succ_above j)) :=
by simp [pi.le_def, forall_iff_succ_above i]

lemma le_insert_nth_iff {i : fin (n + 1)} {x : α i} {p : Π j, α (i.succ_above j)} {q : Π j, α j} :
  q ≤ i.insert_nth x p ↔ q i ≤ x ∧ (λ j, q (i.succ_above j)) ≤ p :=
by simp [pi.le_def, forall_iff_succ_above i]

open set

lemma insert_nth_mem_Icc {i : fin (n + 1)} {x : α i} {p : Π j, α (i.succ_above j)}
  {q₁ q₂ : Π j, α j} :
  i.insert_nth x p ∈ Icc q₁ q₂ ↔
    x ∈ Icc (q₁ i) (q₂ i) ∧ p ∈ Icc (λ j, q₁ (i.succ_above j)) (λ j, q₂ (i.succ_above j)) :=
by simp only [mem_Icc, insert_nth_le_iff, le_insert_nth_iff, and.assoc, and.left_comm]

lemma preimage_insert_nth_Icc_of_mem {i : fin (n + 1)} {x : α i} {q₁ q₂ : Π j, α j}
  (hx : x ∈ Icc (q₁ i) (q₂ i)) :
  i.insert_nth x ⁻¹' (Icc q₁ q₂) = Icc (λ j, q₁ (i.succ_above j)) (λ j, q₂ (i.succ_above j)) :=
set.ext $ λ p, by simp only [mem_preimage, insert_nth_mem_Icc, hx, true_and]

lemma preimage_insert_nth_Icc_of_not_mem {i : fin (n + 1)} {x : α i} {q₁ q₂ : Π j, α j}
  (hx : x ∉ Icc (q₁ i) (q₂ i)) :
  i.insert_nth x ⁻¹' (Icc q₁ q₂) = ∅ :=
set.ext $ λ p, by simp only [mem_preimage, insert_nth_mem_Icc, hx, false_and, mem_empty_eq]

end insert_nth

section find

/-- `find p` returns the first index `n` where `p n` is satisfied, and `none` if it is never
satisfied. -/
def find : Π {n : ℕ} (p : fin n → Prop) [decidable_pred p], option (fin n)
| 0     p _ := none
| (n+1) p _ := by resetI; exact option.cases_on
  (@find n (λ i, p (i.cast_lt (nat.lt_succ_of_lt i.2))) _)
  (if h : p (fin.last n) then some (fin.last n) else none)
  (λ i, some (i.cast_lt (nat.lt_succ_of_lt i.2)))

/-- If `find p = some i`, then `p i` holds -/
lemma find_spec : Π {n : ℕ} (p : fin n → Prop) [decidable_pred p] {i : fin n}
  (hi : i ∈ by exactI fin.find p), p i
| 0     p I i hi := option.no_confusion hi
| (n+1) p I i hi := begin
  dsimp [find] at hi,
  resetI,
  cases h : find (λ i : fin n, (p (i.cast_lt (nat.lt_succ_of_lt i.2)))) with j,
  { rw h at hi,
    dsimp at hi,
    split_ifs at hi with hl hl,
    { exact option.some_inj.1 hi ▸ hl },
    { exact option.no_confusion hi } },
  { rw h at hi,
    rw [← option.some_inj.1 hi],
    exact find_spec _ h }
end

/-- `find p` does not return `none` if and only if `p i` holds at some index `i`. -/
lemma is_some_find_iff : Π {n : ℕ} {p : fin n → Prop} [decidable_pred p],
  by exactI (find p).is_some ↔ ∃ i, p i
| 0     p _ := iff_of_false (λ h, bool.no_confusion h) (λ ⟨i, _⟩, fin_zero_elim i)
| (n+1) p _ := ⟨λ h, begin
  rw [option.is_some_iff_exists] at h,
  cases h with i hi,
  exactI ⟨i, find_spec _ hi⟩
end, λ ⟨⟨i, hin⟩, hi⟩,
begin
  resetI,
  dsimp [find],
  cases h : find (λ i : fin n, (p (i.cast_lt (nat.lt_succ_of_lt i.2)))) with j,
  { split_ifs with hl hl,
    { exact option.is_some_some },
    { have := (@is_some_find_iff n (λ x, p (x.cast_lt (nat.lt_succ_of_lt x.2))) _).2
        ⟨⟨i, lt_of_le_of_ne (nat.le_of_lt_succ hin)
        (λ h, by clear_aux_decl; cases h; exact hl hi)⟩, hi⟩,
      rw h at this,
      exact this } },
  { simp }
end⟩

/-- `find p` returns `none` if and only if `p i` never holds. -/
lemma find_eq_none_iff {n : ℕ} {p : fin n → Prop} [decidable_pred p] :
  find p = none ↔ ∀ i, ¬ p i :=
by rw [← not_exists, ← is_some_find_iff]; cases (find p); simp

/-- If `find p` returns `some i`, then `p j` does not hold for `j < i`, i.e., `i` is minimal among
the indices where `p` holds. -/
lemma find_min : Π {n : ℕ} {p : fin n → Prop} [decidable_pred p] {i : fin n}
  (hi : i ∈ by exactI fin.find p) {j : fin n} (hj : j < i), ¬ p j
| 0     p _ i hi j hj hpj := option.no_confusion hi
| (n+1) p _ i hi ⟨j, hjn⟩ hj hpj := begin
  resetI,
  dsimp [find] at hi,
  cases h : find (λ i : fin n, (p (i.cast_lt (nat.lt_succ_of_lt i.2)))) with k,
  { rw [h] at hi,
    split_ifs at hi with hl hl,
    { have := option.some_inj.1 hi,
      subst this,
      rw [find_eq_none_iff] at h,
      exact h ⟨j, hj⟩ hpj },
    { exact option.no_confusion hi } },
  { rw h at hi,
    dsimp at hi,
    have := option.some_inj.1 hi,
    subst this,
    exact find_min h (show (⟨j, lt_trans hj k.2⟩ : fin n) < k, from hj) hpj }
end

lemma find_min' {p : fin n → Prop} [decidable_pred p] {i : fin n}
  (h : i ∈ fin.find p) {j : fin n} (hj : p j) : i ≤ j :=
le_of_not_gt (λ hij, find_min h hij hj)

lemma nat_find_mem_find {p : fin n → Prop} [decidable_pred p]
  (h : ∃ i, ∃ hin : i < n, p ⟨i, hin⟩) :
  (⟨nat.find h, (nat.find_spec h).fst⟩ : fin n) ∈ find p :=
let ⟨i, hin, hi⟩ := h in
begin
  cases hf : find p with f,
  { rw [find_eq_none_iff] at hf,
    exact (hf ⟨i, hin⟩ hi).elim },
  { refine option.some_inj.2 (le_antisymm _ _),
    { exact find_min' hf (nat.find_spec h).snd },
    { exact nat.find_min' _ ⟨f.2, by convert find_spec p hf;
        exact fin.eta _ _⟩ } }
end

lemma mem_find_iff {p : fin n → Prop} [decidable_pred p] {i : fin n} :
  i ∈ fin.find p ↔ p i ∧ ∀ j, p j → i ≤ j :=
⟨λ hi, ⟨find_spec _ hi, λ _, find_min' hi⟩,
  begin
    rintros ⟨hpi, hj⟩,
    cases hfp : fin.find p,
    { rw [find_eq_none_iff] at hfp,
      exact (hfp _ hpi).elim },
    { exact option.some_inj.2 (le_antisymm (find_min' hfp hpi) (hj _ (find_spec _ hfp))) }
  end⟩

lemma find_eq_some_iff {p : fin n → Prop} [decidable_pred p] {i : fin n} :
  fin.find p = some i ↔ p i ∧ ∀ j, p j → i ≤ j :=
 mem_find_iff

lemma mem_find_of_unique {p : fin n → Prop} [decidable_pred p]
  (h : ∀ i j, p i → p j → i = j) {i : fin n} (hi : p i) : i ∈ fin.find p :=
mem_find_iff.2 ⟨hi, λ j hj, le_of_eq $ h i j hi hj⟩

end find

end fin


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Bhavik Mehta
-/
import category_theory.opposites

/-!
# The constant functor

`const J : C ⥤ (J ⥤ C)` is the functor that sends an object `X : C` to the functor `J ⥤ C` sending
every object in `J` to `X`, and every morphism to `𝟙 X`.

When `J` is nonempty, `const` is faithful.

We have `(const J).obj X ⋙ F ≅ (const J).obj (F.obj X)` for any `F : C ⥤ D`.
-/

-- declare the `v`'s first; see `category_theory.category` for an explanation
universes v₁ v₂ v₃ u₁ u₂ u₃

open category_theory

namespace category_theory.functor

variables (J : Type u₁) [category.{v₁} J]
variables {C : Type u₂} [category.{v₂} C]

/--
The functor sending `X : C` to the constant functor `J ⥤ C` sending everything to `X`.
-/
def const : C ⥤ (J ⥤ C) :=
{ obj := λ X,
  { obj := λ j, X,
    map := λ j j' f, 𝟙 X },
  map := λ X Y f, { app := λ j, f } }

namespace const
open opposite

variables {J}

@[simp] lemma obj_obj (X : C) (j : J) : ((const J).obj X).obj j = X := rfl
@[simp] lemma obj_map (X : C) {j j' : J} (f : j ⟶ j') : ((const J).obj X).map f = 𝟙 X := rfl
@[simp] lemma map_app {X Y : C} (f : X ⟶ Y) (j : J) : ((const J).map f).app j = f := rfl

/--
The contant functor `Jᵒᵖ ⥤ Cᵒᵖ` sending everything to `op X`
is (naturally isomorphic to) the opposite of the constant functor `J ⥤ C` sending everything to `X`.
-/
def op_obj_op (X : C) :
  (const Jᵒᵖ).obj (op X) ≅ ((const J).obj X).op :=
{ hom := { app := λ j, 𝟙 _ },
  inv := { app := λ j, 𝟙 _ } }

@[simp] lemma op_obj_op_hom_app (X : C) (j : Jᵒᵖ) : (op_obj_op X).hom.app j = 𝟙 _ := rfl
@[simp] lemma op_obj_op_inv_app (X : C) (j : Jᵒᵖ) : (op_obj_op X).inv.app j = 𝟙 _ := rfl

/--
The contant functor `Jᵒᵖ ⥤ C` sending everything to `unop X`
is (naturally isomorphic to) the opposite of
the constant functor `J ⥤ Cᵒᵖ` sending everything to `X`.
-/
def op_obj_unop (X : Cᵒᵖ) :
  (const Jᵒᵖ).obj (unop X) ≅ ((const J).obj X).left_op :=
{ hom := { app := λ j, 𝟙 _ },
  inv := { app := λ j, 𝟙 _ } }

-- Lean needs some help with universes here.
@[simp] lemma op_obj_unop_hom_app (X : Cᵒᵖ) (j : Jᵒᵖ) : (op_obj_unop.{v₁ v₂} X).hom.app j = 𝟙 _ :=
rfl
@[simp] lemma op_obj_unop_inv_app (X : Cᵒᵖ) (j : Jᵒᵖ) : (op_obj_unop.{v₁ v₂} X).inv.app j = 𝟙 _ :=
rfl

@[simp] lemma unop_functor_op_obj_map (X : Cᵒᵖ) {j₁ j₂ : J} (f : j₁ ⟶ j₂) :
  (unop ((functor.op (const J)).obj X)).map f = 𝟙 (unop X) := rfl
end const

section
variables {D : Type u₃} [category.{v₃} D]

/-- These are actually equal, of course, but not definitionally equal
  (the equality requires F.map (𝟙 _) = 𝟙 _). A natural isomorphism is
  more convenient than an equality between functors (compare id_to_iso). -/
@[simps] def const_comp (X : C) (F : C ⥤ D) :
  (const J).obj X ⋙ F ≅ (const J).obj (F.obj X) :=
{ hom := { app := λ _, 𝟙 _ },
  inv := { app := λ _, 𝟙 _ } }

/-- If `J` is nonempty, then the constant functor over `J` is faithful. -/
instance [nonempty J] : faithful (const J : C ⥤ J ⥤ C) :=
{ map_injective' := λ X Y f g e, nat_trans.congr_app e (classical.arbitrary J) }

end

end category_theory.functor


/-
Copyright (c) 2021 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Floris van Doorn
-/
import algebra.order.archimedean
import algebra.order.sub
import algebra.order.with_zero
import order.lattice_intervals
import order.conditionally_complete_lattice

/-!
# The type of nonnegative elements

This file defines instances and prove some properties about the nonnegative elements
`{x : α // 0 ≤ x}` of an arbitrary type `α`.

Currently we only state instances and states some `simp`/`norm_cast` lemmas.

When `α` is `ℝ`, this will give us some properties about `ℝ≥0`.

## Main declarations

* `{x : α // 0 ≤ x}` is a `canonically_linear_ordered_add_monoid` if `α` is a `linear_ordered_ring`.
* `{x : α // 0 ≤ x}` is a `linear_ordered_comm_group_with_zero` if `α` is a `linear_ordered_field`.

## Implementation Notes

Instead of `{x : α // 0 ≤ x}` we could also use `set.Ici (0 : α)`, which is definitionally equal.
However, using the explicit subtype has a big advantage: when writing and element explicitly
with a proof of nonnegativity as `⟨x, hx⟩`, the `hx` is expected to have type `0 ≤ x`. If we would
use `Ici 0`, then the type is expected to be `x ∈ Ici 0`. Although these types are definitionally
equal, this often confuses the elaborator. Similar problems arise when doing cases on an element.

The disadvantage is that we have to duplicate some instances about `set.Ici` to this subtype.
-/

open set

variables {α : Type*}

namespace nonneg

/-- This instance uses data fields from `subtype.partial_order` to help type-class inference.
The `set.Ici` data fields are definitionally equal, but that requires unfolding semireducible
definitions, so type-class inference won't see this. -/
instance order_bot [preorder α] {a : α} : order_bot {x : α // a ≤ x} :=
{ ..set.Ici.order_bot }

lemma bot_eq [preorder α] {a : α} : (⊥ : {x : α // a ≤ x}) = ⟨a, le_rfl⟩ := rfl

instance no_top_order [partial_order α] [no_top_order α] {a : α} : no_top_order {x : α // a ≤ x} :=
set.Ici.no_top_order

instance semilattice_inf [semilattice_inf α] {a : α} : semilattice_inf {x : α // a ≤ x} :=
set.Ici.semilattice_inf

instance densely_ordered [preorder α] [densely_ordered α] {a : α} :
  densely_ordered {x : α // a ≤ x} :=
show densely_ordered (Ici a), from set.densely_ordered

/-- If `Sup ∅ ≤ a` then `{x : α // a ≤ x}` is a `conditionally_complete_linear_order`. -/
@[reducible]
protected noncomputable def conditionally_complete_linear_order
  [conditionally_complete_linear_order α] {a : α} :
  conditionally_complete_linear_order {x : α // a ≤ x} :=
{ .. @ord_connected_subset_conditionally_complete_linear_order α (set.Ici a) _ ⟨⟨a, le_rfl⟩⟩ _ }

/-- If `Sup ∅ ≤ a` then `{x : α // a ≤ x}` is a `conditionally_complete_linear_order_bot`.

This instance uses data fields from `subtype.linear_order` to help type-class inference.
The `set.Ici` data fields are definitionally equal, but that requires unfolding semireducible
definitions, so type-class inference won't see this. -/
@[reducible]
protected noncomputable def conditionally_complete_linear_order_bot
  [conditionally_complete_linear_order α] {a : α} (h : Sup ∅ ≤ a) :
  conditionally_complete_linear_order_bot {x : α // a ≤ x} :=
{ cSup_empty := (function.funext_iff.1
    (@subset_Sup_def α (set.Ici a) _ ⟨⟨a, le_rfl⟩⟩) ∅).trans $ subtype.eq $
      by { rw bot_eq, cases h.lt_or_eq with h2 h2, { simp [h2.not_le] }, simp [h2] },
  ..nonneg.order_bot,
  ..nonneg.conditionally_complete_linear_order }

instance inhabited [preorder α] {a : α} : inhabited {x : α // a ≤ x} :=
⟨⟨a, le_rfl⟩⟩

instance has_zero [has_zero α] [preorder α] : has_zero {x : α // 0 ≤ x} :=
⟨⟨0, le_rfl⟩⟩

@[simp, norm_cast]
protected lemma coe_zero [has_zero α] [preorder α] : ((0 : {x : α // 0 ≤ x}) : α) = 0 := rfl

@[simp] lemma mk_eq_zero [has_zero α] [preorder α] {x : α} (hx : 0 ≤ x) :
  (⟨x, hx⟩ : {x : α // 0 ≤ x}) = 0 ↔ x = 0 :=
subtype.ext_iff

instance has_add [add_zero_class α] [preorder α] [covariant_class α α (+) (≤)] :
  has_add {x : α // 0 ≤ x} :=
⟨λ x y, ⟨x + y, add_nonneg x.2 y.2⟩⟩

@[simp] lemma mk_add_mk [add_zero_class α] [preorder α] [covariant_class α α (+) (≤)] {x y : α}
  (hx : 0 ≤ x) (hy : 0 ≤ y) : (⟨x, hx⟩ : {x : α // 0 ≤ x}) + ⟨y, hy⟩ = ⟨x + y, add_nonneg hx hy⟩ :=
rfl

@[simp, norm_cast]
protected lemma coe_add [add_zero_class α] [preorder α] [covariant_class α α (+) (≤)]
  (a b : {x : α // 0 ≤ x}) : ((a + b : {x : α // 0 ≤ x}) : α) = a + b := rfl

instance ordered_add_comm_monoid [ordered_add_comm_monoid α] :
  ordered_add_comm_monoid {x : α // 0 ≤ x} :=
subtype.coe_injective.ordered_add_comm_monoid (coe : {x : α // 0 ≤ x} → α) rfl (λ x y, rfl)

instance linear_ordered_add_comm_monoid [linear_ordered_add_comm_monoid α] :
  linear_ordered_add_comm_monoid {x : α // 0 ≤ x} :=
subtype.coe_injective.linear_ordered_add_comm_monoid (coe : {x : α // 0 ≤ x} → α) rfl (λ x y, rfl)

instance ordered_cancel_add_comm_monoid [ordered_cancel_add_comm_monoid α] :
  ordered_cancel_add_comm_monoid {x : α // 0 ≤ x} :=
subtype.coe_injective.ordered_cancel_add_comm_monoid (coe : {x : α // 0 ≤ x} → α) rfl (λ x y, rfl)

instance linear_ordered_cancel_add_comm_monoid [linear_ordered_cancel_add_comm_monoid α] :
  linear_ordered_cancel_add_comm_monoid {x : α // 0 ≤ x} :=
subtype.coe_injective.linear_ordered_cancel_add_comm_monoid
  (coe : {x : α // 0 ≤ x} → α) rfl (λ x y, rfl)

/-- Coercion `{x : α // 0 ≤ x} → α` as a `add_monoid_hom`. -/
def coe_add_monoid_hom [ordered_add_comm_monoid α] : {x : α // 0 ≤ x} →+ α :=
⟨coe, nonneg.coe_zero, nonneg.coe_add⟩

@[norm_cast]
lemma nsmul_coe [ordered_add_comm_monoid α] (n : ℕ) (r : {x : α // 0 ≤ x}) :
  ↑(n • r) = n • (r : α) :=
nonneg.coe_add_monoid_hom.map_nsmul _ _

instance archimedean [ordered_add_comm_monoid α] [archimedean α] : archimedean {x : α // 0 ≤ x} :=
⟨ assume x y pos_y,
  let ⟨n, hr⟩ := archimedean.arch (x : α) (pos_y : (0 : α) < y) in
  ⟨n, show (x : α) ≤ (n • y : {x : α // 0 ≤ x}), by simp [*, -nsmul_eq_mul, nsmul_coe]⟩ ⟩

instance has_one [ordered_semiring α] : has_one {x : α // 0 ≤ x} :=
{ one := ⟨1, zero_le_one⟩ }

@[simp, norm_cast]
protected lemma coe_one [ordered_semiring α] : ((1 : {x : α // 0 ≤ x}) : α) = 1 := rfl

@[simp] lemma mk_eq_one [ordered_semiring α] {x : α} (hx : 0 ≤ x) :
  (⟨x, hx⟩ : {x : α // 0 ≤ x}) = 1 ↔ x = 1 :=
subtype.ext_iff

instance has_mul [ordered_semiring α] : has_mul {x : α // 0 ≤ x} :=
{ mul := λ x y, ⟨x * y, mul_nonneg x.2 y.2⟩ }

@[simp, norm_cast]
protected lemma coe_mul [ordered_semiring α] (a b : {x : α // 0 ≤ x}) :
  ((a * b : {x : α // 0 ≤ x}) : α) = a * b := rfl

@[simp] lemma mk_mul_mk [ordered_semiring α] {x y : α} (hx : 0 ≤ x) (hy : 0 ≤ y) :
  (⟨x, hx⟩ : {x : α // 0 ≤ x}) * ⟨y, hy⟩ = ⟨x * y, mul_nonneg hx hy⟩ :=
rfl

instance ordered_semiring [ordered_semiring α] : ordered_semiring {x : α // 0 ≤ x} :=
subtype.coe_injective.ordered_semiring
  (coe : {x : α // 0 ≤ x} → α) rfl rfl (λ x y, rfl) (λ x y, rfl)

instance ordered_comm_semiring [ordered_comm_semiring α] : ordered_comm_semiring {x : α // 0 ≤ x} :=
subtype.coe_injective.ordered_comm_semiring
  (coe : {x : α // 0 ≤ x} → α) rfl rfl (λ x y, rfl) (λ x y, rfl)

-- These prevent noncomputable instances being found, as it does not require `linear_order` which
-- is frequently non-computable.
instance monoid_with_zero [ordered_semiring α] : monoid_with_zero {x : α // 0 ≤ x} :=
by apply_instance

instance comm_monoid_with_zero [ordered_comm_semiring α] : comm_monoid_with_zero {x : α // 0 ≤ x} :=
by apply_instance

instance nontrivial [linear_ordered_semiring α] : nontrivial {x : α // 0 ≤ x} :=
⟨ ⟨0, 1, λ h, zero_ne_one (congr_arg subtype.val h)⟩ ⟩

instance linear_ordered_semiring [linear_ordered_semiring α] :
  linear_ordered_semiring {x : α // 0 ≤ x} :=
subtype.coe_injective.linear_ordered_semiring
  (coe : {x : α // 0 ≤ x} → α) rfl rfl (λ x y, rfl) (λ x y, rfl)

instance linear_ordered_comm_monoid_with_zero [linear_ordered_comm_ring α] :
  linear_ordered_comm_monoid_with_zero {x : α // 0 ≤ x} :=
{ mul_le_mul_left := λ a b h c, mul_le_mul_of_nonneg_left h c.2,
  ..nonneg.linear_ordered_semiring,
  ..nonneg.ordered_comm_semiring }

/-- Coercion `{x : α // 0 ≤ x} → α` as a `ring_hom`. -/
def coe_ring_hom [ordered_semiring α] : {x : α // 0 ≤ x} →+* α :=
⟨coe, nonneg.coe_one, nonneg.coe_mul, nonneg.coe_zero, nonneg.coe_add⟩

instance has_inv [linear_ordered_field α] : has_inv {x : α // 0 ≤ x} :=
{ inv := λ x, ⟨x⁻¹, inv_nonneg.mpr x.2⟩ }

@[simp, norm_cast]
protected lemma coe_inv [linear_ordered_field α] (a : {x : α // 0 ≤ x}) :
  ((a⁻¹ : {x : α // 0 ≤ x}) : α) = a⁻¹ := rfl

@[simp] lemma inv_mk [linear_ordered_field α] {x : α} (hx : 0 ≤ x) :
  (⟨x, hx⟩ : {x : α // 0 ≤ x})⁻¹ = ⟨x⁻¹, inv_nonneg.mpr hx⟩ :=
rfl

instance linear_ordered_comm_group_with_zero [linear_ordered_field α] :
  linear_ordered_comm_group_with_zero {x : α // 0 ≤ x} :=
{ inv_zero := by { ext, exact inv_zero },
  mul_inv_cancel := by { intros a ha, ext, refine mul_inv_cancel (mt (λ h, _) ha), ext, exact h },
  ..nonneg.nontrivial,
  ..nonneg.has_inv,
  ..nonneg.linear_ordered_comm_monoid_with_zero }

instance has_div [linear_ordered_field α] : has_div {x : α // 0 ≤ x} :=
{ div := λ x y, ⟨x / y, div_nonneg x.2 y.2⟩ }

@[simp, norm_cast]
protected lemma coe_div [linear_ordered_field α] (a b : {x : α // 0 ≤ x}) :
  ((a / b : {x : α // 0 ≤ x}) : α) = a / b := rfl

@[simp] lemma mk_div_mk [linear_ordered_field α] {x y : α} (hx : 0 ≤ x) (hy : 0 ≤ y) :
  (⟨x, hx⟩ : {x : α // 0 ≤ x}) / ⟨y, hy⟩ = ⟨x / y, div_nonneg hx hy⟩ :=
rfl

instance canonically_ordered_add_monoid [ordered_ring α] :
  canonically_ordered_add_monoid {x : α // 0 ≤ x} :=
{ le_iff_exists_add     := λ ⟨a, ha⟩ ⟨b, hb⟩,
    by simpa only [mk_add_mk, subtype.exists, subtype.mk_eq_mk] using le_iff_exists_nonneg_add a b,
  ..nonneg.ordered_add_comm_monoid,
  ..nonneg.order_bot }

instance canonically_ordered_comm_semiring [ordered_comm_ring α] [no_zero_divisors α] :
  canonically_ordered_comm_semiring {x : α // 0 ≤ x} :=
{ eq_zero_or_eq_zero_of_mul_eq_zero := by { rintro ⟨a, ha⟩ ⟨b, hb⟩, simp },
  ..nonneg.canonically_ordered_add_monoid,
  ..nonneg.ordered_comm_semiring }

instance canonically_linear_ordered_add_monoid [linear_ordered_ring α] :
  canonically_linear_ordered_add_monoid {x : α // 0 ≤ x} :=
{ ..subtype.linear_order _, ..nonneg.canonically_ordered_add_monoid }

section linear_order

variables [has_zero α] [linear_order α]

/-- The function `a ↦ max a 0` of type `α → {x : α // 0 ≤ x}`. -/
def to_nonneg (a : α) : {x : α // 0 ≤ x} :=
⟨max a 0, le_max_right _ _⟩

@[simp]
lemma coe_to_nonneg {a : α} : (to_nonneg a : α) = max a 0 := rfl

@[simp]
lemma to_nonneg_of_nonneg {a : α} (h : 0 ≤ a) : to_nonneg a = ⟨a, h⟩ :=
by simp [to_nonneg, h]

@[simp]
lemma to_nonneg_coe {a : {x : α // 0 ≤ x}} : to_nonneg (a : α) = a :=
by { cases a with a ha, exact to_nonneg_of_nonneg ha }

@[simp]
lemma to_nonneg_le {a : α} {b : {x : α // 0 ≤ x}} : to_nonneg a ≤ b ↔ a ≤ b :=
by { cases b with b hb, simp [to_nonneg, hb] }

@[simp]
lemma to_nonneg_lt {a : {x : α // 0 ≤ x}} {b : α} : a < to_nonneg b ↔ ↑a < b :=
by { cases a with a ha, simp [to_nonneg, ha.not_lt] }

instance has_sub [has_sub α] : has_sub {x : α // 0 ≤ x} :=
⟨λ x y, to_nonneg (x - y)⟩

@[simp] lemma mk_sub_mk [has_sub α] {x y : α}
  (hx : 0 ≤ x) (hy : 0 ≤ y) : (⟨x, hx⟩ : {x : α // 0 ≤ x}) - ⟨y, hy⟩ = to_nonneg (x - y) :=
rfl

end linear_order

instance has_ordered_sub [linear_ordered_ring α] : has_ordered_sub {x : α // 0 ≤ x} :=
⟨by { rintro ⟨a, ha⟩ ⟨b, hb⟩ ⟨c, hc⟩, simp only [sub_le_iff_le_add, subtype.mk_le_mk, mk_sub_mk,
  mk_add_mk, to_nonneg_le, subtype.coe_mk]}⟩

end nonneg


namespace main
  open classical
  variables A B C : Prop

  #check A ∧ ¬ B → C
  #check (assume H : A, and.intro H H)
  #check (assume H : A ∧ ¬ B, and.intro (and.right H) (and.left H))
  #check (λ H : A ∧ ¬ B, and.intro (and.right H) (and.left H))

  example : A ∧ ¬ B → ¬ B ∧ A :=
    assume H : A ∧ ¬ B,
    and.intro (and.right H) (and.left H)

  -- implicit premise type
  example : A ∧ ¬ B → ¬ B ∧ A :=
    assume H,
    and.intro (and.right H) (and.left H)

  -- show.. from..
  example : A ∧ ¬ B → ¬ B ∧ A :=
    assume H : A ∧ ¬ B,
    show ¬ B ∧ A, from and.intro (and.right H) (and.left H)

  -- show .. from nested
  example : A ∧ ¬ B → ¬ B ∧ A :=
    assume H : A ∧ ¬ B,
    show ¬ B ∧ A, from and.intro
      (show ¬ B, from and.right H)
      (show A, from and.left H)

  -- moving premise into parameters
  example (A B : Prop) : A ∧ ¬ B → ¬ B ∧ A :=
    assume H : A ∧ ¬ B,
    show ¬ B ∧ A, from and.intro (and.right H) (and.left H)

  -- using sorry
  example : A ∧ ¬ B → ¬ B ∧ A :=
    assume H,
    sorry

  -- negation
  example : ¬ A :=
    assume H : A,
    show false, from sorry

  -- true is proved trivially
  example : true := trivial

  -- ex falso
  example : false → A :=
    assume H,
    show A, from false.elim H

  -- biconditional
  example : A ↔ B :=
    iff.intro
      (assume H : A,
       show B, from sorry)
      (assume H : B,
       show A, from sorry)

  -- by contradiction
  example : A :=
    by_contradiction
      (assume H : ¬ A,
      show false, from sorry)

  example (A B C : Prop) : (A → (B → C)) → (A ∧ B → C) :=
    assume H₁ : A → (B → C),
    assume H₂ : A ∧ B,
    show C, from H₁ (and.left H₂) (and.right H₂)

  example (A B C : Prop) : A ∧ (B ∨ C) → (A ∧ B) ∨ (A ∧ C) :=
    assume H₁ : A ∧ (B ∨ C),
        or.elim (and.right H₁)
          (assume H₂ : B,
           show (A ∧ B) ∨ (A ∧ C),
             from or.inl (and.intro (and.left H₁) H₂))
          (assume H₂ : C,
           show (A ∧ B) ∨ (A ∧ C),
             from or.inr (and.intro (and.left H₁) H₂))
end main


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

! This file was ported from Lean 3 source module model_theory.bundled
! leanprover-community/mathlib commit b3951c65c6e797ff162ae8b69eab0063bcfb3d73
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.ModelTheory.ElementaryMaps
import Mathbin.CategoryTheory.ConcreteCategory.Bundled

/-!
# Bundled First-Order Structures
This file bundles types together with their first-order structure.

## Main Definitions
* `first_order.language.Theory.Model` is the type of nonempty models of a particular theory.
* `first_order.language.equiv_setoid` is the isomorphism equivalence relation on bundled structures.

## TODO
* Define category structures on bundled structures and models.

-/

universe u v w w'

variable {L : FirstOrder.Language.{u, v}}

@[protected]
instance CategoryTheory.Bundled.structure {L : FirstOrder.Language.{u, v}}
    (M : CategoryTheory.Bundled.{w} L.Structure) : L.Structure M :=
  M.str
#align category_theory.bundled.Structure CategoryTheory.Bundled.structure

open FirstOrder Cardinal

namespace Equiv

variable (L) {M : Type w} [L.Structure M] {N : Type w'} (g : M ≃ N)

/-- A type bundled with the structure induced by an equivalence. -/
@[simps]
def bundledInduced : CategoryTheory.Bundled.{w'} L.Structure :=
  ⟨N, g.inducedStructure⟩
#align equiv.bundled_induced Equiv.bundledInduced

/-- An equivalence of types as a first-order equivalence to the bundled structure on the codomain.
-/
@[simp]
def bundledInducedEquiv : M ≃[L] g.bundledInduced L :=
  g.inducedStructureEquiv
#align equiv.bundled_induced_equiv Equiv.bundledInducedEquiv

end Equiv

namespace FirstOrder

namespace Language

/-- The equivalence relation on bundled `L.Structure`s indicating that they are isomorphic. -/
instance equivSetoid : Setoid (CategoryTheory.Bundled L.Structure)
    where
  R M N := Nonempty (M ≃[L] N)
  iseqv :=
    ⟨fun M => ⟨Equiv.refl L M⟩, fun M N => Nonempty.map Equiv.symm, fun M N P =>
      Nonempty.map2 fun MN NP => NP.comp MN⟩
#align first_order.language.equiv_setoid FirstOrder.Language.equivSetoid

variable (T : L.Theory)

namespace Theory

/-- The type of nonempty models of a first-order theory. -/
structure ModelCat where
  carrier : Type w
  [struc : L.Structure carrier]
  [is_model : T.Model carrier]
  [nonempty' : Nonempty carrier]
#align first_order.language.Theory.Model FirstOrder.Language.Theory.ModelCat

attribute [instance] Model.struc Model.is_model Model.nonempty'

namespace Model

instance : CoeSort T.ModelCat (Type w) :=
  ⟨ModelCat.Carrier⟩

@[simp]
theorem carrier_eq_coe (M : T.ModelCat) : M.carrier = M :=
  rfl
#align first_order.language.Theory.Model.carrier_eq_coe FirstOrder.Language.Theory.ModelCat.carrier_eq_coe

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/-- The object in the category of R-algebras associated to a type equipped with the appropriate
typeclasses. -/
def of (M : Type w) [L.Structure M] [M ⊨ T] [Nonempty M] : T.ModelCat :=
  ⟨M⟩
#align first_order.language.Theory.Model.of FirstOrder.Language.Theory.ModelCat.of

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
@[simp]
theorem coe_of (M : Type w) [L.Structure M] [M ⊨ T] [Nonempty M] : (of T M : Type w) = M :=
  rfl
#align first_order.language.Theory.Model.coe_of FirstOrder.Language.Theory.ModelCat.coe_of

instance (M : T.ModelCat) : Nonempty M :=
  inferInstance

section Inhabited

attribute [local instance] inhabited.trivial_structure

instance : Inhabited (ModelCat.{u, v, w} (∅ : L.Theory)) :=
  ⟨ModelCat.of _ PUnit⟩

end Inhabited

variable {T}

/-- Maps a bundled model along a bijection. -/
def equivInduced {M : ModelCat.{u, v, w} T} {N : Type w'} (e : M ≃ N) : ModelCat.{u, v, w'} T
    where
  carrier := N
  struc := e.inducedStructure
  is_model := @Equiv.theory_model L M N _ e.inducedStructure T e.inducedStructureEquiv _
  nonempty' := e.symm.Nonempty
#align first_order.language.Theory.Model.equiv_induced FirstOrder.Language.Theory.ModelCat.equivInduced

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
instance of_small (M : Type w) [Nonempty M] [L.Structure M] [M ⊨ T] [h : Small.{w'} M] :
    Small.{w'} (ModelCat.of T M) :=
  h
#align first_order.language.Theory.Model.of_small FirstOrder.Language.Theory.ModelCat.of_small

/-- Shrinks a small model to a particular universe. -/
noncomputable def shrink (M : ModelCat.{u, v, w} T) [Small.{w'} M] : ModelCat.{u, v, w'} T :=
  equivInduced (equivShrink M)
#align first_order.language.Theory.Model.shrink FirstOrder.Language.Theory.ModelCat.shrink

/-- Lifts a model to a particular universe. -/
def ulift (M : ModelCat.{u, v, w} T) : ModelCat.{u, v, max w w'} T :=
  equivInduced (Equiv.ulift.symm : M ≃ _)
#align first_order.language.Theory.Model.ulift FirstOrder.Language.Theory.ModelCat.ulift

/-- The reduct of any model of `φ.on_Theory T` is a model of `T`. -/
@[simps]
def reduct {L' : Language} (φ : L →ᴸ L') (M : (φ.onTheory T).ModelCat) : T.ModelCat
    where
  carrier := M
  struc := φ.reduct M
  nonempty' := M.nonempty'
  is_model := (@Lhom.onTheory_model L L' M (φ.reduct M) _ φ _ T).1 M.is_model
#align first_order.language.Theory.Model.reduct FirstOrder.Language.Theory.ModelCat.reduct

/-- When `φ` is injective, `default_expansion` expands a model of `T` to a model of `φ.on_Theory T`
  arbitrarily. -/
@[simps]
noncomputable def defaultExpansion {L' : Language} {φ : L →ᴸ L'} (h : φ.Injective)
    [∀ (n) (f : L'.Functions n), Decidable (f ∈ Set.range fun f : L.Functions n => φ.onFunction f)]
    [∀ (n) (r : L'.Relations n), Decidable (r ∈ Set.range fun r : L.Relations n => φ.onRelation r)]
    (M : T.ModelCat) [Inhabited M] : (φ.onTheory T).ModelCat
    where
  carrier := M
  struc := φ.defaultExpansion M
  nonempty' := M.nonempty'
  is_model :=
    (@Lhom.onTheory_model L L' M _ (φ.defaultExpansion M) φ (h.isExpansionOn_default M) T).2
      M.is_model
#align first_order.language.Theory.Model.default_expansion FirstOrder.Language.Theory.ModelCat.defaultExpansion

instance leftStructure {L' : Language} {T : (L.Sum L').Theory} (M : T.ModelCat) : L.Structure M :=
  (Lhom.sumInl : L →ᴸ L.Sum L').reduct M
#align first_order.language.Theory.Model.left_Structure FirstOrder.Language.Theory.ModelCat.leftStructure

instance rightStructure {L' : Language} {T : (L.Sum L').Theory} (M : T.ModelCat) : L'.Structure M :=
  (Lhom.sumInr : L' →ᴸ L.Sum L').reduct M
#align first_order.language.Theory.Model.right_Structure FirstOrder.Language.Theory.ModelCat.rightStructure

/-- A model of a theory is also a model of any subtheory. -/
@[simps]
def subtheoryModel (M : T.ModelCat) {T' : L.Theory} (h : T' ⊆ T) : T'.ModelCat
    where
  carrier := M
  is_model := ⟨fun φ hφ => realize_sentence_of_mem T (h hφ)⟩
#align first_order.language.Theory.Model.subtheory_Model FirstOrder.Language.Theory.ModelCat.subtheoryModel

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
instance subtheoryModel_models (M : T.ModelCat) {T' : L.Theory} (h : T' ⊆ T) :
    M.subtheoryModel h ⊨ T :=
  M.is_model
#align first_order.language.Theory.Model.subtheory_Model_models FirstOrder.Language.Theory.ModelCat.subtheoryModel_models

end Model

variable {T}

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/-- Bundles `M ⊨ T` as a `T.Model`. -/
def Model.bundled {M : Type w} [LM : L.Structure M] [ne : Nonempty M] (h : M ⊨ T) : T.ModelCat :=
  @ModelCat.of L T M LM h Ne
#align first_order.language.Theory.model.bundled FirstOrder.Language.Theory.Model.bundled

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
@[simp]
theorem coe_of {M : Type w} [L.Structure M] [Nonempty M] (h : M ⊨ T) : (h.Bundled : Type w) = M :=
  rfl
#align first_order.language.Theory.coe_of FirstOrder.Language.Theory.coe_of

end Theory

/-- A structure that is elementarily equivalent to a model, bundled as a model. -/
def ElementarilyEquivalent.toModel {M : T.ModelCat} {N : Type _} [LN : L.Structure N]
    (h : M ≅[L] N) : T.ModelCat where
  carrier := N
  struc := LN
  nonempty' := h.Nonempty
  is_model := h.theory_model
#align first_order.language.elementarily_equivalent.to_Model FirstOrder.Language.ElementarilyEquivalent.toModel

/-- An elementary substructure of a bundled model as a bundled model. -/
def ElementarySubstructure.toModel {M : T.ModelCat} (S : L.ElementarySubstructure M) : T.ModelCat :=
  S.ElementarilyEquivalent.symm.toModel T
#align first_order.language.elementary_substructure.to_Model FirstOrder.Language.ElementarySubstructure.toModel

instance {M : T.ModelCat} (S : L.ElementarySubstructure M) [h : Small S] : Small (S.toModel T) :=
  h

end Language

end FirstOrder


/-
Copyright © 2019, Oracle and/or its affiliates. All rights reserved.
-/

import .setup_definition .setup_properties

open set
open measure_theory
open probability_measure
open lattice

local attribute [instance] classical.prop_decidable

namespace stump

variables (μ: probability_measure ℍ) (target: ℍ)

lemma is_meas_to_target:
  is_measurable {a: nnreal | a ≤ target} :=
begin
  apply is_measurable_of_is_closed,
  have TEST: Icc 0 target = {a: nnreal | a ≤ target}, {
    unfold Icc,
    rw ext_iff,
    intro,
    simp at *,
  },
  rw ← TEST,
  apply is_closed_Icc,
end

@[simp]
lemma label_measurable: measurable (label target) :=
begin
  dunfold label,
  apply measurable.prod,
  apply measurable_id,
  unfold rle,
  unfold to_bool,
  apply measurable.if,
  apply is_meas_to_target,
  apply measurable_const,
  apply measurable_const,
end

lemma measurable_interval_function:
  ∀ f: nnreal → nnreal,
  (∀ x: nnreal, is_measurable (f ⁻¹' Iio x)) →
  measurable f :=
begin
  intros,
  have FOO:= borel_eq_generate_Iio nnreal,
  unfold measurable,
  unfold stump.meas_ℍ,
  rw FOO,
  apply measurable_generate_from,
  intros,
  unfold range at H,
  rw mem_set_of_eq at H,
  cases H,
  unfold is_measurable,
  unfold is_measurable at a,
  unfold stump.meas_ℍ at a,
  rw FOO at a,
  rw ← H_h,
  apply a,
end

lemma measurable_lt :let f := λ x: nnreal, μ (Icc 0 x) in
∀ y : nnreal,
(∃ θ : nnreal, {x : nnreal | f x < y} = Ico 0 θ)
∨
{x : nnreal | f x < y} = ∅
∨
(∃ θ : nnreal, {x : nnreal | f x < y} = Icc 0 θ)
∨
{x : nnreal | f x < y} = Ici 0
:=
begin
  intros f y,
  let S := {x : ℍ | f x < y},
  have hm : monotone f, from assume a b hab, prob_mono _ (Icc_subset_Icc (by refl) hab),
  have hm' : ∀ {x y}, f x < f y → x < y,
  {
    by_contradiction, push_neg at a,
    choose x₀ y₀ hxy using a,
    rcases hxy with ⟨hxy₁,hxy₂⟩,
    have : f y₀ ≤ f x₀, from hm hxy₂,
    rw ←not_lt at this, exact this hxy₁,
  },
  by_cases (∃ u, f(u) ≥ y),
  swap, push_neg at h,
  have hS : S = Ici 0,
  {
    ext z, dsimp [S, Ici],
    fsplit, assume h₁, by_contra, simp at *, assumption,
    assume h₁, apply h,
  },
  right, right, right, assumption,
  let T := {x : ℍ | f x ≥ y},
  have Tne : T ≠ ∅,
  {
    assume not, choose u hyp using h,
    have : u ∈ T, by assumption, finish,
  },
  have Tbdbl : bdd_below T, from ⟨ 0 , assume y hy, zero_le _ ⟩,
  let θ := Inf T,
  have Sleθ : ∀ x ∈ S, x ≤ θ,
  {
    assume s hs, refine le_cInf Tne _,
    assume b hb, dsimp [T,S] at hb hs,
    suffices : f s < f b, exact le_of_lt (hm' this),
    exact lt_of_lt_of_le hs hb,
  },
  by_cases case : (f θ < y),
  have hS : S = Icc 0 θ, from set.ext (assume x, iff.intro (assume h₁, ⟨ by simp , Sleθ _ h₁⟩) (assume h₂, lt_of_le_of_lt (hm h₂.2) case)),
  right, right, left, existsi θ, exact hS,
  have hS : S = Ico 0 θ,
  {
    ext x, fsplit,
    assume h₁,
    suffices : x ≠ θ, dsimp [Ico], refine ⟨ by simp , lt_of_le_of_ne (Sleθ _ h₁) this ⟩,
    assume not,
    have : θ ∉ S, from case, rw not at h₁, exact this h₁,
    assume h₁, dsimp [S,Ico] at h₁ ⊢,
    have : x ∉ T, assume not, have : θ ≤ x, from cInf_le Tbdbl not,
    replace h₁ := h₁.2, rw ←not_le at h₁, exact h₁ this,
    simp at this, assumption,
  },
  left, existsi θ, exact hS,
end

lemma measurable_Icc_0_x:
  measurable (λ x: nnreal, μ (Icc 0 x)) :=
begin
  apply measurable_interval_function,
  intros,
  unfold set.preimage,
  unfold Iio,
  conv {
    congr, congr, funext, rw mem_set_of_eq, skip,
  },
  have FOO := measurable_lt μ x,
  cases FOO,
  cases FOO,
  rw FOO_h,
  exact is_measurable_Ico,
  cases FOO,
  rw FOO,
  exact is_measurable.empty,
  cases FOO,
  cases FOO,
  rw FOO_h,
  apply is_measurable_of_is_closed,
  apply is_closed_Icc,
  rw FOO,
  have COMPL: (Ici (0: nnreal) = - Iio 0),
  {
    unfold Ici, unfold Iio,
    rw ext_iff, intro,
    rw mem_set_of_eq,
    rw compl_set_of,
    rw mem_set_of_eq,
    split; intro,
    simp,
    simp at a,
    tidy,
  },
  rw COMPL,
  apply is_measurable.compl,
  exact is_measurable_Iio,
end

noncomputable
def error1: nnreal → nnreal := λ h, μ (Icc 0 target) - μ (Icc 0 h)

noncomputable
def error2: nnreal → nnreal := λ h, μ (Icc 0 h) - μ (Icc 0 target)

noncomputable
def error_decomposed: nnreal → nnreal := λ h, ite (rle h target) (error1 μ target h) (error2 μ target h)

lemma decompose_error:
  error μ target = error_decomposed μ target :=
begin
  funext,
  unfold error_decomposed,
  by_cases (rle h target = tt),
  {
    dedup,
    rw h_1, simp,
    unfold error1,
    rw error_interval_1,
    rw ← Icc_diff_Ioc 0 h target,
    have INCL: Icc 0 h ⊆ Icc 0 target, swap,
    {
      have FOO:= @measure_diff nnreal _ μ _ _ INCL _ _ _,
      unfold_coes,
      unfold_coes at FOO,
      rw FOO,
      rw ← ennreal.coe_eq_coe,
      rw to_nnreal_sub,
      exact to_measure_lt_top μ (Icc 0 target),
      exact to_measure_lt_top μ (Icc 0 h),
      apply is_measurable_of_is_closed,
      apply is_closed_Icc,
      apply is_measurable_of_is_closed,
      apply is_closed_Icc,
      exact probability_measure.to_measure_lt_top μ (Icc 0 h),
    },
    {
      have H: h ≤ target, by {unfold rle at h_1, tidy},
      unfold Icc,
      rw subset_def, intros,
      rw mem_set_of_eq,
      rw mem_set_of_eq at a,
      cases a,
      split,
      assumption,
      transitivity h; assumption,
    },
    {
      tidy,
    },
    repeat {
      unfold rle at h_1,
      tidy,
    },
  },
  {
    dedup,
    simp at h_1, rw h_1, simp,
    unfold error2,
    rw error_interval_2,
    rw ← Icc_diff_Ioc 0 target h,
    have INCL: Icc 0 target ⊆ Icc 0 h, swap,
    {
      have FOO:= @measure_diff nnreal _ μ _ _ INCL _ _ _,
      unfold_coes,
      unfold_coes at FOO,
      rw FOO,
      rw ← ennreal.coe_eq_coe,
      rw to_nnreal_sub,
      exact to_measure_lt_top μ (Icc 0 h),
      exact to_measure_lt_top μ (Icc 0 target),
      apply is_measurable_of_is_closed,
      apply is_closed_Icc,
      apply is_measurable_of_is_closed,
      apply is_closed_Icc,
      exact probability_measure.to_measure_lt_top μ (Icc 0 target)
    },
    {
      have H: target < h,
      {
        unfold rle at h_1,
        tidy,
      },
      unfold Icc,
      rw subset_def, intros,
      rw mem_set_of_eq,
      rw mem_set_of_eq at a,
      cases a,
      split,
      assumption,
      transitivity target; try {assumption},
      exact le_of_lt H,
    },
    {
      tidy,
    },
    {
      unfold rle at h_1, simp at h_1,
      exact le_of_lt h_1,
    },
    {
      unfold rle at h_1, simp at h_1,
      exact (gt_from_lt h target).mp h_1,
    },
  },
end

lemma error_measurable:
  measurable (error μ target) :=
begin
  rw decompose_error,
  unfold error_decomposed,
  apply measurable.if,
  {
    unfold rle, simp, apply is_meas_to_target,
  },
  {
    unfold error1,
    apply nnreal.measurable_sub,
    {
      apply measurable_const,
    },
    {
      apply measurable_Icc_0_x,
    },
  },
  {
    unfold error2,
    apply nnreal.measurable_sub,
    {
      apply measurable_Icc_0_x,
    },
    {
      apply measurable_const,
    },
  },
end

@[simp]
lemma is_meas_gamma_1:
  ∀ ε,
  is_measurable {h: ℍ | error μ target h > ε} :=
begin
  intro,
  have COMPL: {h: ℍ | error μ target h > ε} = -{h: ℍ | error μ target h ≤ ε},
  {
    rw compl_set_of,
    simp,
  },
  rw COMPL,
  apply is_measurable.compl,
  have MLE := @measurable_le _ _ _ _ _ _ _ (λ h, error μ target h) (λ h, ε),
  apply MLE,
  apply error_measurable,
  apply measurable_const,
end

@[simp]
lemma is_meas_gamma_2:
  ∀ ε,
  is_measurable {h: ℍ | error μ target h ≤ ε} :=
begin
  intros,
  have COMPL: {h: ℍ | error μ target h ≤ ε} = -{h: ℍ | error μ target h > ε},
  {
    rw compl_set_of,
    simp,
  },
  rw COMPL,
  apply is_measurable.compl,
  apply is_meas_gamma_1,
end

@[simp]
lemma is_meas_one: ∀ θ,
  θ > 0 →
  is_measurable {x: ℍ |  ∀ p = label target x, (if p.snd then p.fst else 0) < θ} :=
begin
  introv T0,
  convert_to (is_measurable {x: ℍ | (if (label target x).snd then (label target x).fst else 0) < θ}),
  {
    rw ext_iff, intro,
    repeat {rw mem_set_of_eq},
    split; intros,
    apply a, trivial,
    rw H, assumption,
  },
  unfold label, simp, unfold rle,
  rw ite_equals_union_interval θ T0 target,
  apply is_measurable.union,
  {
    exact is_measurable_Ico,
  },
  {
    rw Ioi_complement target,
    apply is_measurable.compl,
    apply is_measurable.union,
    exact is_measurable_Iio,
    rw ← (Ico_diff_Ioo_eq_singleton (by exact lt_add_one target)),
    apply is_measurable.diff,
    exact is_measurable_Ico,
    exact is_measurable_Ioo,
  },
end

@[simp]
lemma is_meas_forall: ∀ θ,
  θ > 0 →
  ∀ n, is_measurable {S: vec ℍ n |  ∀ (i: dfin (nat.succ n)), ∀ p = label target (kth_projn S i), (if p.snd then p.fst else 0) < θ} :=
begin
  intros,
  convert_to (is_measurable {S: vec ℍ n |  ∀ (i: dfin (nat.succ n)), (if (label target (kth_projn S i)).snd then (label target (kth_projn S i)).fst else 0) < θ}),
  {
    rw ext_iff, intro,
    repeat {rw mem_set_of_eq},
    split; intros,
    apply (a_1 i), trivial,
    rw H, apply (a_1 i),
  },
  have FOO:= is_measurable_simple_vec (λ x, (if (label target x).snd then (label target x).fst else 0) < θ),
  apply FOO,
  convert_to (is_measurable {x: ℍ |  ∀ p = label target x, (if p.snd then p.fst else 0) < θ}),
  {
    rw ext_iff, intro,
    repeat {rw mem_set_of_eq},
    split; intros,
    rw H, assumption,
    apply a_1, trivial,
  },
  apply is_meas_one; assumption,
end

end stump


import algebra.ofe.basic

universes u v

/-!
# Complete OFEs
-/

@[ext] structure chain (α : Type u) (eq_at : ℕ → α → α → Prop) :=
(c : ℕ → α)
(prop : ∀ m n, m ≤ n → eq_at m (c m) (c n))

instance chain.fun_like (α : Type u) (eq_at : ℕ → α → α → Prop) :
  fun_like (chain α eq_at) ℕ (λ _, α) := {
  coe := chain.c,
  coe_injective' := λ p q h, by ext1; exact h,
}

class cofe (α : Type u) extends ofe α :=
(lim : chain α eq_at → α)
(complete : ∀ n c, eq_at n (lim c) (c n))

/-!
# Metric spaces of OFEs

OFEs form metric spaces. Complete OFEs directly correspond to complete metric spaces.
We prove the contraction mapping theorem, also known as Banach's fixed point theorem, for
complete OFEs.
-/

noncomputable theory
open_locale classical

def ofe_dist {α : Type u} [ofe α] (a b : α) : ℝ :=
⨅ (n : ℕ), if a =[n] b then (2 ^ n)⁻¹ else 2

lemma ofe_dist_bdd_below {α : Type u} [ofe α] (a b : α) :
  bdd_below (set.range (λ n, if a =[n] b then ((2 : ℝ) ^ n)⁻¹ else 2)) :=
begin
  refine ⟨0, _⟩,
  rintro r ⟨n, h⟩,
  rw ← h,
  dsimp only,
  split_ifs,
  { rw inv_nonneg,
    exact pow_nonneg zero_le_two _, },
  { exact zero_le_two, },
end

lemma ofe_dist_le' {α : Type u} [ofe α] (a b : α) (n : ℕ) :
  ofe_dist a b ≤ if a =[n] b then (2 ^ n)⁻¹ else 2 :=
cinfi_le (ofe_dist_bdd_below a b) _

lemma ofe_dist_le {α : Type u} [ofe α] (a b : α) (n : ℕ) (h : a =[n] b) :
  ofe_dist a b ≤ (2 ^ n)⁻¹ :=
begin
  have := ofe_dist_le' a b n,
  rw if_pos h at this,
  exact this,
end

lemma ofe_dist_le_two {α : Type u} [ofe α] (a b : α) :
  ofe_dist a b ≤ 2 :=
begin
  refine le_trans (ofe_dist_le' a b 0) _,
  split_ifs,
  { norm_num, },
  { refl, },
end

lemma le_ofe_dist' {α : Type u} [ofe α] (a b : α) (r : ℝ)
  (h : ∀ n, r ≤ if a =[n] b then (2 ^ n)⁻¹ else 2) :
  r ≤ ofe_dist a b :=
le_cinfi h

lemma le_ofe_dist {α : Type u} [ofe α] (a b : α) (r : ℝ)
  (h₁ : ∀ n, a =[ n] b → r ≤ (2 ^ n)⁻¹) (h₂ : r ≤ 2) :
  r ≤ ofe_dist a b :=
begin
  refine le_ofe_dist' a b r _,
  intro n,
  split_ifs,
  exact h₁ n h,
  exact h₂,
end

lemma ofe_dist_eq_one {α : Type u} [ofe α] {a b : α} (h : a ≠ b) :
  critical_point h = 0 → ofe_dist a b = 2 :=
begin
  intro hp,
  rw critical_point_eq_zero at hp,
  unfold ofe_dist,
  convert cinfi_const,
  { ext n,
    rw if_neg (hp n), },
  { apply_instance, },
end

lemma ofe_dist_eq_of_ne {α : Type u} [ofe α] {a b : α} (h : a ≠ b) :
  ofe_dist a b = 2 * (2 ^ critical_point h)⁻¹ :=
begin
  have := critical_point_spec h,
  refine le_antisymm _ _,
  { generalize hp : critical_point h = p,
    cases p,
    { rw ofe_dist_eq_one h hp,
      norm_num, },
    { refine le_of_le_of_eq (ofe_dist_le a b p _) _,
      { rw eq_at_iff_lt_critical_point h,
        rw hp,
        exact lt_add_one p, },
      { rw [pow_succ, mul_inv],
        simp only [mul_inv_cancel_left₀, ne.def,
          bit0_eq_zero, one_ne_zero, not_false_iff], }, }, },
  { refine le_ofe_dist a b _ _ _,
    { intros n hn,
      rw eq_at_iff_lt_critical_point h at hn,
      obtain ⟨k, hk⟩ := le_iff_exists_add.mp (nat.succ_le_of_lt hn),
      rw [hk, pow_add, pow_succ, mul_inv, mul_inv, ← mul_assoc, ← mul_assoc],
      simp only [mul_inv_cancel, ne.def, bit0_eq_zero, one_ne_zero,
        not_false_iff, one_mul, mul_le_iff_le_one_right, inv_pos, pow_pos,
        zero_lt_bit0, zero_lt_one],
      rw [inv_le, inv_one],
      refine one_le_pow_of_one_le _ _,
      exact one_le_two,
      exact pow_pos zero_lt_two _,
      exact zero_lt_one, },
    { simp only [mul_le_iff_le_one_right, zero_lt_bit0, zero_lt_one],
      rw [inv_le, inv_one],
      refine one_le_pow_of_one_le _ _,
      exact one_le_two,
      exact pow_pos zero_lt_two _,
      exact zero_lt_one, }, },
end

lemma lt_ofe_dist {α : Type u} [ofe α] (a b : α) (n : ℕ) (h : ¬a =[n] b) :
  (2 ^ n)⁻¹ < ofe_dist a b :=
begin
  rw ofe_dist_eq_of_ne (ne_of_exists_ne ⟨n, h⟩),
  obtain ⟨k, hk⟩ := le_iff_exists_add.mp (critical_point_min' (ne_of_exists_ne ⟨n, h⟩) h),
  generalize_proofs,
  rw hk,
  simp only [pow_add, mul_inv_rev, mul_lt_mul_right,
    inv_pos, pow_pos, zero_lt_bit0, zero_lt_one],
  refine lt_of_le_of_lt _ one_lt_two,
  rw [inv_le, inv_one],
  refine one_le_pow_of_one_le _ _,
  exact one_le_two,
  exact pow_pos zero_lt_two _,
  exact zero_lt_one,
end

lemma ofe_dist_nonneg {α : Type u} [ofe α] (a b : α) :
  0 ≤ ofe_dist a b :=
begin
  refine le_ofe_dist a b 0 _ zero_le_two,
  intros n h,
  rw inv_nonneg,
  exact pow_nonneg zero_le_two _,
end

lemma ofe_dist_le_of_eq_at {α : Type u} [ofe α] {a b c d : α} :
  (∀ n, a =[n] b → c =[n] d) → ofe_dist c d ≤ ofe_dist a b :=
begin
  intro h,
  refine le_ofe_dist _ _ _ _ (ofe_dist_le_two c d),
  intros n hab,
  exact ofe_dist_le c d n (h n hab),
end

lemma ofe_dist_eq_of_eq_at {α : Type u} [ofe α] {a b c d : α} :
  (∀ n, a =[n] b ↔ c =[n] d) → ofe_dist a b = ofe_dist c d :=
begin
  intro h,
  refine le_antisymm _ _,
  { exact ofe_dist_le_of_eq_at (λ n, (h n).mpr), },
  { exact ofe_dist_le_of_eq_at (λ n, (h n).mp), },
end

/-- Ordered families of equivalences induce a metric space.
This is not made an instance, because we don't want to overwrite the metric space
structure on any type. More importantly, we basically only need this structure to
prove the contraction mapping theorem, so the metric space API doesn't really need
to be visible. -/
def ofe.metric_space (α : Type u) [ofe α] : metric_space α := {
  dist := ofe_dist,
  dist_self := begin
    intro a,
    refine le_antisymm _ (ofe_dist_nonneg a a),
    have : ∀ n, ofe_dist a a ≤ (2 ^ n)⁻¹,
    { intro n,
      refine ofe_dist_le a a _ _,
      refl, },
    by_contra' h,
    obtain ⟨n, hn⟩ := exists_pow_lt_of_lt_one h one_half_lt_one,
    rw [div_pow, one_pow, one_div] at hn,
    exact not_lt_of_le (this n) hn,
  end,
  dist_comm := begin
    intros x y,
    unfold dist ofe_dist,
    congr' 1,
    ext n,
    rw eq_at_symm_iff,
  end,
  dist_triangle := begin
    intros x y z,
    unfold dist,
    by_contra',
    rw ← lt_sub_iff_add_lt at this,
    obtain ⟨n, hn⟩ := exists_lt_of_cinfi_lt this,
    dsimp only at hn,
    split_ifs at hn with hxy,
    { by_cases hxz : x =[n] z,
      { have := ofe_dist_le x z n hxz,
        have := ofe_dist_nonneg y z,
        linarith, },
      by_cases hyz : y =[n] z,
      { exact hxz (eq_at_trans _ hxy hyz), },
      suffices : ofe_dist x z = ofe_dist y z,
      { rw [this, sub_self, inv_lt_zero] at hn,
        refine not_le_of_lt hn _,
        exact pow_nonneg zero_le_two _, },
      by_cases hz : ∃ m, x =[m] z,
      { obtain ⟨m, hxz'⟩ := hz,
        by_cases h : n ≤ m,
        { cases hxz (eq_at_mono h hxz'), },
        push_neg at h,
        have hxy' := eq_at_mono h.le hxy,
        exact ofe_dist_eq_of_eq_at (eq_at_forall_trans' hxy hxz), },
      { push_neg at hz,
        refine ofe_dist_eq_of_eq_at _,
        intro m,
        split,
        { intro h,
          cases hz m h, },
        { intro h,
          have h₁ := eq_at_mono (min_le_right m n) hxy,
          have h₂ := eq_at_mono (min_le_left m n) h,
          cases hz _ (eq_at_trans _ h₁ h₂), }, }, },
    { have := ofe_dist_le_two x z,
      have := ofe_dist_nonneg y z,
      linarith, },
  end,
  eq_of_dist_eq_zero := begin
    intros a b h,
    rw eq_at_limit,
    intro n,
    by_contra hxy,
    have := lt_ofe_dist a b n hxy,
    unfold dist at h,
    rw h at this,
    refine not_le_of_lt this _,
    rw inv_nonneg,
    exact pow_nonneg zero_le_two _,
  end,
}

local attribute [instance] ofe.metric_space

lemma dist_def (α : Type u) [ofe α] : (dist : α → α → ℝ) = ofe_dist := rfl

lemma ofe_dist_eq {α : Type u} [ofe α] {a b : α} :
  ofe_dist a b = if h : a = b then 0 else 2 * (2 ^ critical_point h)⁻¹ :=
begin
  split_ifs,
  { rw [← dist_def, dist_eq_zero],
    exact h, },
  { rw ofe_dist_eq_of_ne, },
end

def cofe.complete_space (α : Type u) [cofe α] : complete_space α :=
begin
  split,
  intros f hf,
  rw metric.cauchy_iff at hf,
  choose hf₁ s hs₁ hs₂ using hf,
  resetI,
  have hpow : ∀ n, 0 < ((2 : ℝ) ^ n)⁻¹,
  { intro n,
    rw inv_pos,
    exact pow_pos two_pos _, },
  have hf : ∀ n, (⋂ (k : fin (n + 1)), s (2 ^ k.val)⁻¹ (hpow _)) ∈ f,
  { intro n,
    rw filter.Inter_mem,
    intro k,
    exact hs₁ _ _, },
  have hs₃ : ∀ n, (⋂ (k : fin (n + 1)), s (2 ^ k.val)⁻¹ (hpow _)).nonempty,
  { intro n,
    by_contra,
    rw set.not_nonempty_iff_eq_empty at h,
    have h₁ := hf n,
    have h₂ := filter.empty_not_mem f,
    rw h at h₁,
    exact h₂ h₁, },
  choose t ht using hs₃,
  have hts : ∀ m n, m ≤ n → t n ∈ s (2 ^ m)⁻¹ (hpow _),
  { intros m n hmn,
    have := ht n,
    rw set.mem_Inter at this,
    exact this ⟨m, nat.lt_succ_of_le hmn⟩, },
  have hchain : ∀ (m n : ℕ), m ≤ n → t m =[m] t n,
  { intros m n hmn,
    have := hs₂ (2 ^ m)⁻¹ (hpow m) (t n) (hts m n hmn) (t m) (hts m m le_rfl),
    by_contra,
    refine not_le_of_lt this _,
    rw dist_comm,
    exact (lt_ofe_dist _ _ _ h).le, },
  refine ⟨cofe.lim ⟨t, hchain⟩, _⟩,
  rw le_nhds_iff,
  intros u hlu hu,
  rw metric.is_open_iff at hu,
  obtain ⟨ε, hε₁, hε₂⟩ := hu _ hlu,
  obtain ⟨n, hn⟩ := exists_pow_lt_of_lt_one hε₁ (show (1 / 2 : ℝ) < 1, by linarith),
  refine f.sets_of_superset _ hε₂,
  refine f.sets_of_superset _ _,
  { exact s (2 ^ (n + 1))⁻¹ (hpow _), },
  { exact hs₁ _ _, },
  intros x hx,
  rw metric.mem_ball,
  refine lt_of_le_of_lt _ hn,
  refine le_trans (dist_triangle x (t (n + 1)) (cofe.lim ⟨t, hchain⟩)) _,
  rw [div_pow, one_pow, one_div],
  have : ((2 : ℝ) ^ n)⁻¹ = (2 ^ (n + 1))⁻¹ + (2 ^ (n + 1))⁻¹,
  { have := add_self_div_two ((2 : ℝ) ^ (n + 1))⁻¹,
    rw div_eq_iff at this,
    rw this,
    refine inv_eq_of_mul_eq_one_left _,
    rw mul_assoc,
    rw pow_succ,
    rw inv_mul_eq_one₀,
    exact mul_ne_zero two_ne_zero (pow_ne_zero _ two_ne_zero),
    exact two_ne_zero, },
  rw this,
  refine add_le_add (hs₂ _ _ x hx (t (n + 1)) (hts (n + 1) (n + 1) le_rfl)).le _,
  rw dist_comm,
  exact ofe_dist_le _ _ _ (cofe.complete (n + 1) ⟨t, hchain⟩),
end

local attribute [instance] cofe.complete_space

def contractive_is_contracting_with {α : Type u} [ofe α] {F : Type v}
  [contractive_fun_class F α α] (f : F) : contracting_with (1 / 2) f :=
begin
  split,
  { rw [div_lt_iff, one_mul],
    exact one_lt_two,
    exact zero_lt_two, },
  rw lipschitz_with_iff_dist_le_mul,
  intros x y,
  rw [nnreal.coe_div, nnreal.coe_one, nnreal.coe_two],
  by_cases x = y,
  { rw h,
    simp only [dist_self, mul_zero], },
  rw [dist_def, ofe_dist_eq_of_ne h, ofe_dist_eq],
  split_ifs with hfxy,
  { simp only [one_div, inv_mul_cancel_left₀, ne.def, bit0_eq_zero,
      one_ne_zero, not_false_iff, inv_nonneg, pow_nonneg,
      zero_le_bit0, zero_le_one], },
  have := critical_point_contractive f hfxy,
  obtain ⟨k, hk⟩ := le_iff_exists_add.mp (nat.succ_le_of_lt this),
  rw [hk, pow_add, pow_succ, mul_inv, mul_inv, ← mul_assoc, ← mul_assoc],
  simp only [mul_inv_cancel, ne.def, bit0_eq_zero, one_ne_zero,
    not_false_iff, one_mul, one_div, inv_mul_cancel_left₀,
    mul_le_iff_le_one_right, inv_pos, pow_pos, zero_lt_bit0, zero_lt_one],
  refine inv_le_one _,
  refine one_le_pow_of_one_le one_le_two _,
end

lemma uniform_continuous_of_nonexpansive {α : Type u} [ofe α] {F : Type v}
  [nonexpansive_fun_class F α α] (f : F) : uniform_continuous f :=
begin
  rw metric.uniform_continuous_iff,
  intros ε hε,
  refine ⟨ε, hε, _⟩,
  intros a b ha,
  by_cases f a = f b,
  { rw h,
    simp only [dist_def, ofe_dist_eq, dif_pos],
    exact hε, },
  have := critical_point_nonexpansive f h,
  rw [dist_def, ofe_dist_eq] at ha ⊢,
  rw dif_neg h,
  rw dif_neg (ne_of_apply_ne f h) at ha,
  refine lt_of_le_of_lt _ ha,
  rw [mul_le_mul_left, inv_le_inv],
  refine pow_le_pow _ this,
  exact one_le_two,
  exact pow_pos zero_lt_two _,
  exact pow_pos zero_lt_two _,
  exact zero_lt_two,
end

/-- The unique fixed point of a contractive function
in a type with a complete ordered family of equivalences. -/
def contractive_fixed_point {α : Type u} [cofe α] [nonempty α] {F : Type v}
  [contractive_fun_class F α α] (f : F) : α :=
contracting_with.fixed_point f (contractive_is_contracting_with f)