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

/-!
# Quotient types

This module extends the core library's treatment of quotient types (`init.data.quot`).

## Tags

quotient
-/

variables {α : Sort*} {β : Sort*}

namespace setoid

lemma ext {α : Sort*} :
  ∀{s t : setoid α}, (∀a b, @setoid.r α s a b ↔ @setoid.r α t a b) → s = t
| ⟨r, _⟩ ⟨p, _⟩ eq :=
  have r = p, from funext $ assume a, funext $ assume b, propext $ eq a b,
  by subst this

end setoid

namespace quot
variables {ra : α → α → Prop} {rb : β → β → Prop} {φ : quot ra → quot rb → Sort*}
local notation `⟦`:max a `⟧` := quot.mk _ a

instance (r : α → α → Prop) [inhabited α] : inhabited (quot r) := ⟨⟦default⟧⟩

instance [subsingleton α] : subsingleton (quot ra) :=
⟨λ x, quot.induction_on x (λ y, quot.ind (λ b, congr_arg _ (subsingleton.elim _ _)))⟩

/-- Recursion on two `quotient` arguments `a` and `b`, result type depends on `⟦a⟧` and `⟦b⟧`. -/
protected def hrec_on₂ (qa : quot ra) (qb : quot rb) (f : Π a b, φ ⟦a⟧ ⟦b⟧)
  (ca : ∀ {b a₁ a₂}, ra a₁ a₂ → f a₁ b == f a₂ b)
  (cb : ∀ {a b₁ b₂}, rb b₁ b₂ → f a b₁ == f a b₂) : φ qa qb :=
quot.hrec_on qa (λ a, quot.hrec_on qb (f a) (λ b₁ b₂ pb, cb pb)) $ λ a₁ a₂ pa,
  quot.induction_on qb $ λ b,
    calc @quot.hrec_on _ _ (φ _) ⟦b⟧ (f a₁) (@cb _)
          == f a₁ b                                     : by simp [heq_self_iff_true]
      ... == f a₂ b                                     : ca pa
      ... == @quot.hrec_on _ _ (φ _) ⟦b⟧ (f a₂) (@cb _) : by simp [heq_self_iff_true]

/-- Map a function `f : α → β` such that `ra x y` implies `rb (f x) (f y)`
to a map `quot ra → quot rb`. -/
protected def map (f : α → β) (h : (ra ⇒ rb) f f) : quot ra → quot rb :=
quot.lift (λ x, ⟦f x⟧) $ assume x y (h₁ : ra x y), quot.sound $ h h₁

/-- If `ra` is a subrelation of `ra'`, then we have a natural map `quot ra → quot ra'`. -/
protected def map_right {ra' : α → α → Prop} (h : ∀a₁ a₂, ra a₁ a₂ → ra' a₁ a₂) :
  quot ra → quot ra' :=
quot.map id h

/-- weaken the relation of a quotient -/
def factor {α : Type*} (r s : α → α → Prop) (h : ∀ x y, r x y → s x y) :
  quot r → quot s :=
quot.lift (quot.mk s) (λ x y rxy, quot.sound (h x y rxy))

lemma factor_mk_eq {α : Type*} (r s : α → α → Prop) (h : ∀ x y, r x y → s x y) :
  factor r s h ∘ quot.mk _ = quot.mk _ := rfl

variables {γ : Sort*} {r : α → α → Prop} {s : β → β → Prop}

/-- **Alias** of `quot.lift_beta`. -/
lemma lift_mk (f : α → γ) (h : ∀ a₁ a₂, r a₁ a₂ → f a₁ = f a₂) (a : α) :
  quot.lift f h (quot.mk r a) = f a := quot.lift_beta f h a

@[simp]
lemma lift_on_mk (a : α) (f : α → γ) (h : ∀ a₁ a₂, r a₁ a₂ → f a₁ = f a₂) :
  quot.lift_on (quot.mk r a) f h = f a := rfl

/-- Descends a function `f : α → β → γ` to quotients of `α` and `β`. -/
attribute [reducible, elab_as_eliminator]
protected def lift₂
  (f : α → β → γ)
  (hr : ∀ a b₁ b₂, s b₁ b₂ → f a b₁ = f a b₂)
  (hs : ∀ a₁ a₂ b, r a₁ a₂ → f a₁ b = f a₂ b)
  (q₁ : quot r) (q₂ : quot s) : γ :=
quot.lift (λ a, quot.lift (f a) (hr a))
(λ a₁ a₂ ha, funext (λ q, quot.induction_on q (λ b, hs a₁ a₂ b ha)))
q₁ q₂

@[simp]
lemma lift₂_mk (f : α → β → γ)
  (hr : ∀ a b₁ b₂, s b₁ b₂ → f a b₁ = f a b₂)
  (hs : ∀ a₁ a₂ b, r a₁ a₂ → f a₁ b = f a₂ b) (a : α) (b : β) :
  quot.lift₂ f hr hs (quot.mk r a) (quot.mk s b) = f a b := rfl

/-- Descends a function `f : α → β → γ` to quotients of `α` and `β` and applies it. -/
attribute [reducible, elab_as_eliminator]
protected def lift_on₂ (p : quot r) (q : quot s) (f : α → β → γ)
  (hr : ∀ a b₁ b₂, s b₁ b₂ → f a b₁ = f a b₂)
  (hs : ∀ a₁ a₂ b, r a₁ a₂ → f a₁ b = f a₂ b) : γ := quot.lift₂ f hr hs p q

@[simp]
lemma lift_on₂_mk (a : α) (b : β) (f : α → β → γ)
  (hr : ∀ a b₁ b₂, s b₁ b₂ → f a b₁ = f a b₂)
  (hs : ∀ a₁ a₂ b, r a₁ a₂ → f a₁ b = f a₂ b) :
  quot.lift_on₂ (quot.mk r a) (quot.mk s b) f hr hs = f a b := rfl

variables {t : γ → γ → Prop}

/-- Descends a function `f : α → β → γ` to quotients of `α` and `β` wih values in a quotient of
`γ`. -/
protected def map₂ (f : α → β → γ)
  (hr : ∀ a b₁ b₂, s b₁ b₂ → t (f a b₁) (f a b₂))
  (hs : ∀ a₁ a₂ b, r a₁ a₂ → t (f a₁ b) (f a₂ b))
  (q₁ : quot r) (q₂ : quot s) : quot t :=
quot.lift₂ (λ a b, quot.mk t $ f a b) (λ a b₁ b₂ hb, quot.sound (hr a b₁ b₂ hb))
(λ a₁ a₂ b ha, quot.sound (hs a₁ a₂ b ha)) q₁ q₂

@[simp]
lemma map₂_mk (f : α → β → γ)
  (hr : ∀ a b₁ b₂, s b₁ b₂ → t (f a b₁) (f a b₂))
  (hs : ∀ a₁ a₂ b, r a₁ a₂ → t (f a₁ b) (f a₂ b))
  (a : α) (b : β) : quot.map₂ f hr hs (quot.mk r a) (quot.mk s b) = quot.mk t (f a b) := rfl

attribute [elab_as_eliminator]
protected lemma induction_on₂
  {δ : quot r → quot s → Prop} (q₁ : quot r) (q₂ : quot s)
  (h : ∀ a b, δ (quot.mk r a) (quot.mk s b)) : δ q₁ q₂ :=
quot.ind (λ a₁, quot.ind (λ a₂, h a₁ a₂) q₂) q₁

attribute [elab_as_eliminator]
protected lemma induction_on₃
  {δ : quot r → quot s → quot t → Prop} (q₁ : quot r) (q₂ : quot s) (q₃ : quot t)
  (h : ∀ a b c, δ (quot.mk r a) (quot.mk s b) (quot.mk t c)) : δ q₁ q₂ q₃ :=
quot.ind (λ a₁, quot.ind (λ a₂, quot.ind (λ a₃, h a₁ a₂ a₃) q₃) q₂) q₁

end quot

namespace quotient
variables [sa : setoid α] [sb : setoid β]
variables {φ : quotient sa → quotient sb → Sort*}

instance (s : setoid α) [inhabited α] : inhabited (quotient s) := ⟨⟦default⟧⟩

instance (s : setoid α) [subsingleton α] : subsingleton (quotient s) :=
quot.subsingleton

/-- Induction on two `quotient` arguments `a` and `b`, result type depends on `⟦a⟧` and `⟦b⟧`. -/
protected def hrec_on₂ (qa : quotient sa) (qb : quotient sb) (f : Π a b, φ ⟦a⟧ ⟦b⟧)
  (c : ∀ a₁ b₁ a₂ b₂, a₁ ≈ a₂ → b₁ ≈ b₂ → f a₁ b₁ == f a₂ b₂) : φ qa qb :=
quot.hrec_on₂ qa qb f
  (λ _ _ _ p, c _ _ _ _ p (setoid.refl _))
  (λ _ _ _ p, c _ _ _ _ (setoid.refl _) p)

/-- Map a function `f : α → β` that sends equivalent elements to equivalent elements
to a function `quotient sa → quotient sb`. Useful to define unary operations on quotients. -/
protected def map (f : α → β) (h : ((≈) ⇒ (≈)) f f) : quotient sa → quotient sb :=
quot.map f h

@[simp] lemma map_mk (f : α → β) (h : ((≈) ⇒ (≈)) f f) (x : α) :
  quotient.map f h (⟦x⟧ : quotient sa) = (⟦f x⟧ : quotient sb) :=
rfl

variables {γ : Sort*} [sc : setoid γ]

/-- Map a function `f : α → β → γ` that sends equivalent elements to equivalent elements
to a function `f : quotient sa → quotient sb → quotient sc`.
Useful to define binary operations on quotients. -/
protected def map₂ (f : α → β → γ) (h : ((≈) ⇒ (≈) ⇒ (≈)) f f) :
  quotient sa → quotient sb → quotient sc :=
quotient.lift₂ (λ x y, ⟦f x y⟧) (λ x₁ y₁ x₂ y₂ h₁ h₂, quot.sound $ h h₁ h₂)

@[simp] lemma map₂_mk (f : α → β → γ) (h : ((≈) ⇒ (≈) ⇒ (≈)) f f) (x : α) (y : β) :
  quotient.map₂ f h (⟦x⟧ : quotient sa) (⟦y⟧ : quotient sb) = (⟦f x y⟧ : quotient sc) := rfl

end quotient

lemma quot.eq {α : Type*} {r : α → α → Prop} {x y : α} :
  quot.mk r x = quot.mk r y ↔ eqv_gen r x y :=
⟨quot.exact r, quot.eqv_gen_sound⟩

@[simp] theorem quotient.eq [r : setoid α] {x y : α} : ⟦x⟧ = ⟦y⟧ ↔ x ≈ y :=
⟨quotient.exact, quotient.sound⟩

theorem forall_quotient_iff {α : Type*} [r : setoid α] {p : quotient r → Prop} :
  (∀a:quotient r, p a) ↔ (∀a:α, p ⟦a⟧) :=
⟨assume h x, h _, assume h a, a.induction_on h⟩

@[simp] lemma quotient.lift_mk [s : setoid α] (f : α → β) (h : ∀ (a b : α), a ≈ b → f a = f b)
  (x : α) :
  quotient.lift f h (quotient.mk x) = f x := rfl

@[simp] lemma quotient.lift_comp_mk [setoid α] (f : α → β) (h : ∀ (a b : α), a ≈ b → f a = f b) :
  quotient.lift f h ∘ quotient.mk = f :=
rfl

@[simp] lemma quotient.lift₂_mk {α : Sort*} {β : Sort*} {γ : Sort*} [setoid α] [setoid β]
  (f : α → β → γ)
  (h : ∀ (a₁ : α) (a₂ : β) (b₁ : α) (b₂ : β), a₁ ≈ b₁ → a₂ ≈ b₂ → f a₁ a₂ = f b₁ b₂)
  (a : α) (b : β) :
  quotient.lift₂ f h (quotient.mk a) (quotient.mk b) = f a b := rfl

@[simp] lemma quotient.lift_on_mk [s : setoid α] (f : α → β) (h : ∀ (a b : α), a ≈ b → f a = f b)
  (x : α) :
  quotient.lift_on (quotient.mk x) f h = f x := rfl

@[simp] theorem quotient.lift_on₂_mk {α : Sort*} {β : Sort*} [setoid α] (f : α → α → β)
  (h : ∀ (a₁ a₂ b₁ b₂ : α), a₁ ≈ b₁ → a₂ ≈ b₂ → f a₁ a₂ = f b₁ b₂) (x y : α) :
  quotient.lift_on₂ (quotient.mk x) (quotient.mk y) f h = f x y := rfl

/-- `quot.mk r` is a surjective function. -/
lemma surjective_quot_mk (r : α → α → Prop) : function.surjective (quot.mk r) :=
quot.exists_rep

/-- `quotient.mk` is a surjective function. -/
lemma surjective_quotient_mk (α : Sort*) [s : setoid α] :
  function.surjective (quotient.mk : α → quotient s) :=
quot.exists_rep

/-- Choose an element of the equivalence class using the axiom of choice.
  Sound but noncomputable. -/
noncomputable def quot.out {r : α → α → Prop} (q : quot r) : α :=
classical.some (quot.exists_rep q)

/-- Unwrap the VM representation of a quotient to obtain an element of the equivalence class.
  Computable but unsound. -/
meta def quot.unquot {r : α → α → Prop} : quot r → α := unchecked_cast

@[simp] theorem quot.out_eq {r : α → α → Prop} (q : quot r) : quot.mk r q.out = q :=
classical.some_spec (quot.exists_rep q)

/-- Choose an element of the equivalence class using the axiom of choice.
  Sound but noncomputable. -/
noncomputable def quotient.out [s : setoid α] : quotient s → α := quot.out

@[simp] theorem quotient.out_eq [s : setoid α] (q : quotient s) : ⟦q.out⟧ = q := q.out_eq

theorem quotient.mk_out [s : setoid α] (a : α) : ⟦a⟧.out ≈ a :=
quotient.exact (quotient.out_eq _)

lemma quotient.mk_eq_iff_out [s : setoid α] {x : α} {y : quotient s} :
  ⟦x⟧ = y ↔ x ≈ quotient.out y :=
begin
  refine iff.trans _ quotient.eq,
  rw quotient.out_eq y,
end

lemma quotient.eq_mk_iff_out [s : setoid α] {x : quotient s} {y : α} :
  x = ⟦y⟧ ↔ quotient.out x ≈ y  :=
begin
  refine iff.trans _ quotient.eq,
  rw quotient.out_eq x,
end

@[simp] lemma quotient.out_equiv_out {s : setoid α} {x y : quotient s} :
  x.out ≈ y.out ↔ x = y :=
by rw [← quotient.eq_mk_iff_out, quotient.out_eq]

@[simp] lemma quotient.out_inj {s : setoid α} {x y : quotient s} :
  x.out = y.out ↔ x = y :=
⟨λ h, quotient.out_equiv_out.1 $ h ▸ setoid.refl _, λ h, h ▸ rfl⟩

section pi

instance pi_setoid {ι : Sort*} {α : ι → Sort*} [∀ i, setoid (α i)] : setoid (Π i, α i) :=
{ r := λ a b, ∀ i, a i ≈ b i,
  iseqv := ⟨
    λ a i, setoid.refl _,
    λ a b h i, setoid.symm (h _),
    λ a b c h₁ h₂ i, setoid.trans (h₁ _) (h₂ _)⟩ }

/-- Given a function `f : Π i, quotient (S i)`, returns the class of functions `Π i, α i` sending
each `i` to an element of the class `f i`. -/
noncomputable def quotient.choice {ι : Type*} {α : ι → Type*} [S : Π i, setoid (α i)]
  (f : Π i, quotient (S i)) : @quotient (Π i, α i) (by apply_instance) :=
⟦λ i, (f i).out⟧

@[simp] theorem quotient.choice_eq {ι : Type*} {α : ι → Type*} [Π i, setoid (α i)]
  (f : Π i, α i) : quotient.choice (λ i, ⟦f i⟧) = ⟦f⟧ :=
quotient.sound $ λ i, quotient.mk_out _

@[elab_as_eliminator] lemma quotient.induction_on_pi
   {ι : Type*} {α : ι → Sort*} [s : ∀ i, setoid (α i)]
   {p : (Π i, quotient (s i)) → Prop} (f : Π i, quotient (s i))
   (h : ∀ a : Π i, α i, p (λ i, ⟦a i⟧)) : p f :=
begin
  rw ← (funext (λ i, quotient.out_eq (f i)) : (λ i,  ⟦(f i).out⟧) = f),
  apply h,
end

end pi

lemma nonempty_quotient_iff (s : setoid α) : nonempty (quotient s) ↔ nonempty α :=
⟨assume ⟨a⟩, quotient.induction_on a nonempty.intro, assume ⟨a⟩, ⟨⟦a⟧⟩⟩

/-- `trunc α` is the quotient of `α` by the always-true relation. This
  is related to the propositional truncation in HoTT, and is similar
  in effect to `nonempty α`, but unlike `nonempty α`, `trunc α` is data,
  so the VM representation is the same as `α`, and so this can be used to
  maintain computability. -/
def {u} trunc (α : Sort u) : Sort u := @quot α (λ _ _, true)

theorem true_equivalence : @equivalence α (λ _ _, true) :=
⟨λ _, trivial, λ _ _ _, trivial, λ _ _ _ _ _, trivial⟩

namespace trunc

/-- Constructor for `trunc α` -/
def mk (a : α) : trunc α := quot.mk _ a

instance [inhabited α] : inhabited (trunc α) := ⟨mk default⟩

/-- Any constant function lifts to a function out of the truncation -/
def lift (f : α → β) (c : ∀ a b : α, f a = f b) : trunc α → β :=
quot.lift f (λ a b _, c a b)

theorem ind {β : trunc α → Prop} : (∀ a : α, β (mk a)) → ∀ q : trunc α, β q := quot.ind

protected theorem lift_mk (f : α → β) (c) (a : α) : lift f c (mk a) = f a := rfl

/-- Lift a constant function on `q : trunc α`. -/
@[reducible, elab_as_eliminator]
protected def lift_on (q : trunc α) (f : α → β)
  (c : ∀ a b : α, f a = f b) : β := lift f c q

@[elab_as_eliminator]
protected theorem induction_on {β : trunc α → Prop} (q : trunc α)
  (h : ∀ a, β (mk a)) : β q := ind h q

theorem exists_rep (q : trunc α) : ∃ a : α, mk a = q := quot.exists_rep q

attribute [elab_as_eliminator]
protected theorem induction_on₂ {C : trunc α → trunc β → Prop} (q₁ : trunc α) (q₂ : trunc β)
  (h : ∀ a b, C (mk a) (mk b)) : C q₁ q₂ :=
trunc.induction_on q₁ $ λ a₁, trunc.induction_on q₂ (h a₁)

protected theorem eq (a b : trunc α) : a = b :=
trunc.induction_on₂ a b (λ x y, quot.sound trivial)

instance : subsingleton (trunc α) := ⟨trunc.eq⟩

/-- The `bind` operator for the `trunc` monad. -/
def bind (q : trunc α) (f : α → trunc β) : trunc β :=
trunc.lift_on q f (λ a b, trunc.eq _ _)

/-- A function `f : α → β` defines a function `map f : trunc α → trunc β`. -/
def map (f : α → β) (q : trunc α) : trunc β := bind q (trunc.mk ∘ f)

instance : monad trunc :=
{ pure := @trunc.mk,
  bind := @trunc.bind }

instance : is_lawful_monad trunc :=
{ id_map := λ α q, trunc.eq _ _,
  pure_bind := λ α β q f, rfl,
  bind_assoc := λ α β γ x f g, trunc.eq _ _ }

variable {C : trunc α → Sort*}

/-- Recursion/induction principle for `trunc`. -/
@[reducible, elab_as_eliminator]
protected def rec
   (f : Π a, C (mk a)) (h : ∀ (a b : α), (eq.rec (f a) (trunc.eq (mk a) (mk b)) : C (mk b)) = f b)
   (q : trunc α) : C q :=
quot.rec f (λ a b _, h a b) q

/-- A version of `trunc.rec` taking `q : trunc α` as the first argument. -/
@[reducible, elab_as_eliminator]
protected def rec_on (q : trunc α) (f : Π a, C (mk a))
  (h : ∀ (a b : α), (eq.rec (f a) (trunc.eq (mk a) (mk b)) : C (mk b)) = f b) : C q :=
trunc.rec f h q

/-- A version of `trunc.rec_on` assuming the codomain is a `subsingleton`. -/
@[reducible, elab_as_eliminator]
protected def rec_on_subsingleton
   [∀ a, subsingleton (C (mk a))] (q : trunc α) (f : Π a, C (mk a)) : C q :=
trunc.rec f (λ a b, subsingleton.elim _ (f b)) q

/-- Noncomputably extract a representative of `trunc α` (using the axiom of choice). -/
noncomputable def out : trunc α → α := quot.out

@[simp] theorem out_eq (q : trunc α) : mk q.out = q := trunc.eq _ _

protected theorem nonempty (q : trunc α) : nonempty α :=
nonempty_of_exists q.exists_rep

end trunc

namespace quotient
variables {γ : Sort*} {φ : Sort*}
  {s₁ : setoid α} {s₂ : setoid β} {s₃ : setoid γ}

/-! Versions of quotient definitions and lemmas ending in `'` use unification instead
of typeclass inference for inferring the `setoid` argument. This is useful when there are
several different quotient relations on a type, for example quotient groups, rings and modules. -/

/-- A version of `quotient.mk` taking `{s : setoid α}` as an implicit argument instead of an
instance argument. -/
protected def mk' (a : α) : quotient s₁ := quot.mk s₁.1 a

/-- `quotient.mk'` is a surjective function. -/
lemma surjective_quotient_mk' : function.surjective (quotient.mk' : α → quotient s₁) :=
quot.exists_rep

/-- A version of `quotient.lift_on` taking `{s : setoid α}` as an implicit argument instead of an
instance argument. -/
@[elab_as_eliminator, reducible]
protected def lift_on' (q : quotient s₁) (f : α → φ)
  (h : ∀ a b, @setoid.r α s₁ a b → f a = f b) : φ := quotient.lift_on q f h

@[simp]
protected lemma lift_on'_mk' (f : α → φ) (h) (x : α) :
  quotient.lift_on' (@quotient.mk' _ s₁ x) f h = f x := rfl

/-- A version of `quotient.lift_on₂` taking `{s₁ : setoid α} {s₂ : setoid β}` as implicit arguments
instead of instance arguments. -/
@[elab_as_eliminator, reducible]
protected def lift_on₂' (q₁ : quotient s₁) (q₂ : quotient s₂) (f : α → β → γ)
  (h : ∀ a₁ a₂ b₁ b₂, @setoid.r α s₁ a₁ b₁ → @setoid.r β s₂ a₂ b₂ → f a₁ a₂ = f b₁ b₂) : γ :=
quotient.lift_on₂ q₁ q₂ f h

@[simp]
protected lemma lift_on₂'_mk' (f : α → β → γ) (h) (a : α) (b : β) :
  quotient.lift_on₂' (@quotient.mk' _ s₁ a) (@quotient.mk' _ s₂ b) f h = f a b := rfl

/-- A version of `quotient.ind` taking `{s : setoid α}` as an implicit argument instead of an
instance argument. -/
@[elab_as_eliminator]
protected lemma ind' {p : quotient s₁ → Prop}
  (h : ∀ a, p (quotient.mk' a)) (q : quotient s₁) : p q :=
quotient.ind h q

/-- A version of `quotient.ind₂` taking `{s₁ : setoid α} {s₂ : setoid β}` as implicit arguments
instead of instance arguments. -/
@[elab_as_eliminator]
protected lemma ind₂' {p : quotient s₁ → quotient s₂ → Prop}
  (h : ∀ a₁ a₂, p (quotient.mk' a₁) (quotient.mk' a₂))
  (q₁ : quotient s₁) (q₂ : quotient s₂) : p q₁ q₂ :=
quotient.ind₂ h q₁ q₂

/-- A version of `quotient.induction_on` taking `{s : setoid α}` as an implicit argument instead
of an instance argument. -/
@[elab_as_eliminator]
protected lemma induction_on' {p : quotient s₁ → Prop} (q : quotient s₁)
  (h : ∀ a, p (quotient.mk' a)) : p q := quotient.induction_on q h

/-- A version of `quotient.induction_on₂` taking `{s₁ : setoid α} {s₂ : setoid β}` as implicit
arguments instead of instance arguments. -/
@[elab_as_eliminator]
protected lemma induction_on₂' {p : quotient s₁ → quotient s₂ → Prop} (q₁ : quotient s₁)
  (q₂ : quotient s₂) (h : ∀ a₁ a₂, p (quotient.mk' a₁) (quotient.mk' a₂)) : p q₁ q₂ :=
quotient.induction_on₂ q₁ q₂ h

/-- A version of `quotient.induction_on₃` taking `{s₁ : setoid α} {s₂ : setoid β} {s₃ : setoid γ}`
as implicit arguments instead of instance arguments. -/
@[elab_as_eliminator]
protected lemma induction_on₃' {p : quotient s₁ → quotient s₂ → quotient s₃ → Prop}
  (q₁ : quotient s₁) (q₂ : quotient s₂) (q₃ : quotient s₃)
  (h : ∀ a₁ a₂ a₃, p (quotient.mk' a₁) (quotient.mk' a₂) (quotient.mk' a₃)) : p q₁ q₂ q₃ :=
quotient.induction_on₃ q₁ q₂ q₃ h

/-- A version of `quotient.rec_on_subsingleton` taking `{s₁ : setoid α}` as an implicit argument
instead of an instance argument. -/
@[elab_as_eliminator]
protected def rec_on_subsingleton' {φ : quotient s₁ → Sort*}
  [h : ∀ a, subsingleton (φ ⟦a⟧)] (q : quotient s₁) (f : Π a, φ (quotient.mk' a)) : φ q :=
quotient.rec_on_subsingleton q f

/-- A version of `quotient.rec_on_subsingleton₂` taking `{s₁ : setoid α} {s₂ : setoid α}`
as implicit arguments instead of instance arguments. -/
attribute [reducible, elab_as_eliminator]
protected def rec_on_subsingleton₂'
   {φ : quotient s₁ → quotient s₂ → Sort*} [h : ∀ a b, subsingleton (φ ⟦a⟧ ⟦b⟧)]
   (q₁ : quotient s₁) (q₂ : quotient s₂) (f : Π a₁ a₂, φ (quotient.mk' a₁) (quotient.mk' a₂)) :
   φ q₁ q₂ :=
quotient.rec_on_subsingleton₂ q₁ q₂ f

/-- Recursion on a `quotient` argument `a`, result type depends on `⟦a⟧`. -/
protected def hrec_on' {φ : quotient s₁ → Sort*} (qa : quotient s₁) (f : Π a, φ (quotient.mk' a))
  (c : ∀ a₁ a₂, a₁ ≈ a₂ → f a₁ == f a₂) : φ qa :=
quot.hrec_on qa f c

@[simp]

/-- Recursion on two `quotient` arguments `a` and `b`, result type depends on `⟦a⟧` and `⟦b⟧`. -/
protected def hrec_on₂' {φ : quotient s₁ → quotient s₂ → Sort*} (qa : quotient s₁)
  (qb : quotient s₂) (f : ∀ a b, φ (quotient.mk' a) (quotient.mk' b))
  (c : ∀ a₁ b₁ a₂ b₂, a₁ ≈ a₂ → b₁ ≈ b₂ → f a₁ b₁ == f a₂ b₂) : φ qa qb :=
quotient.hrec_on₂ qa qb f c

@[simp] lemma hrec_on₂'_mk' {φ : quotient s₁ → quotient s₂ → Sort*}
  (f : ∀ a b, φ (quotient.mk' a) (quotient.mk' b))
  (c : ∀ a₁ b₁ a₂ b₂, a₁ ≈ a₂ → b₁ ≈ b₂ → f a₁ b₁ == f a₂ b₂) (x : α) (qb : quotient s₂) :
  (quotient.mk' x).hrec_on₂' qb f c = qb.hrec_on' (f x) (λ b₁ b₂, c _ _ _ _ (setoid.refl _)) :=
rfl

/-- Map a function `f : α → β` that sends equivalent elements to equivalent elements
to a function `quotient sa → quotient sb`. Useful to define unary operations on quotients. -/
protected def map' (f : α → β) (h : (s₁.r ⇒ s₂.r) f f) :
  quotient s₁ → quotient s₂ :=
quot.map f h

@[simp] lemma map'_mk' (f : α → β) (h) (x : α) :
  (quotient.mk' x : quotient s₁).map' f h = (quotient.mk' (f x) : quotient s₂) :=
rfl

/-- A version of `quotient.map₂` using curly braces and unification. -/
protected def map₂' (f : α → β → γ) (h : (s₁.r ⇒ s₂.r ⇒ s₃.r) f f) :
  quotient s₁ → quotient s₂ → quotient s₃ :=
quotient.map₂ f h

@[simp] lemma map₂'_mk' (f : α → β → γ) (h) (x : α) :
  (quotient.mk' x : quotient s₁).map₂' f h =
    (quotient.map' (f x) (h (setoid.refl x)) : quotient s₂ → quotient s₃) :=
rfl

lemma exact' {a b : α} :
  (quotient.mk' a : quotient s₁) = quotient.mk' b → @setoid.r _ s₁ a b :=
quotient.exact

lemma sound' {a b : α} : @setoid.r _ s₁ a b → @quotient.mk' α s₁ a = quotient.mk' b :=
quotient.sound

@[simp]
protected lemma eq' {a b : α} : @quotient.mk' α s₁ a = quotient.mk' b ↔ @setoid.r _ s₁ a b :=
quotient.eq

/-- A version of `quotient.out` taking `{s₁ : setoid α}` as an implicit argument instead of an
instance argument. -/
noncomputable def out' (a : quotient s₁) : α := quotient.out a

@[simp] theorem out_eq' (q : quotient s₁) : quotient.mk' q.out' = q := q.out_eq

theorem mk_out' (a : α) : @setoid.r α s₁ (quotient.mk' a : quotient s₁).out' a :=
quotient.exact (quotient.out_eq _)

section

variables [setoid α]

protected lemma mk'_eq_mk (x : α) : quotient.mk' x = ⟦x⟧ := rfl

@[simp] protected lemma lift_on'_mk (x : α) (f : α → β) (h) : ⟦x⟧.lift_on' f h = f x := rfl

@[simp] protected lemma lift_on₂'_mk [setoid β] (f : α → β → γ) (h) (a : α) (b : β) :
  quotient.lift_on₂' ⟦a⟧ ⟦b⟧ f h = f a b := quotient.lift_on₂'_mk' _ _ _ _

@[simp] lemma map'_mk [setoid β] (f : α → β) (h) (x : α) : ⟦x⟧.map' f h = ⟦f x⟧ := rfl

end

end quotient


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

import control.functor.multivariate
import data.qpf.multivariate.basic

/-!
# Constant functors are QPFs

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

Constant functors map every type vectors to the same target type. This
is a useful device for constructing data types from more basic types
that are not actually functorial. For instance `const n nat` makes
`nat` into a functor that can be used in a functor-based data type
specification.
-/

universes u

namespace mvqpf
open_locale mvfunctor

variables (n : ℕ)

/-- Constant multivariate functor -/
@[nolint unused_arguments]
def const (A : Type*) (v : typevec.{u} n) : Type* :=
A

instance const.inhabited {A α} [inhabited A] : inhabited (const n A α) :=
⟨ (default : A) ⟩

namespace const
open mvfunctor mvpfunctor
variables {n} {A : Type u} {α β : typevec.{u} n} (f : α ⟹ β)

/-- Constructor for constant functor -/
protected def mk (x : A) : (const n A) α := x

/-- Destructor for constant functor -/
protected def get (x : (const n A) α) : A := x

@[simp] protected lemma mk_get (x : (const n A) α) : const.mk (const.get x) = x := rfl

@[simp] protected lemma get_mk (x : A) : const.get (const.mk x : const n A α) = x := rfl

/-- `map` for constant functor -/
protected def map : (const n A) α → (const n A) β :=
λ x, x

instance : mvfunctor (const n A) :=
{ map := λ α β f, const.map }

lemma map_mk (x : A) :
  f <$$> const.mk x = const.mk x := rfl

lemma get_map (x : (const n A) α) :
  const.get (f <$$> x) = const.get x := rfl

instance mvqpf : @mvqpf _ (const n A) (mvqpf.const.mvfunctor) :=
{ P         := mvpfunctor.const n A,
  abs       := λ α x, mvpfunctor.const.get x,
  repr      := λ α x, mvpfunctor.const.mk n x,
  abs_repr  := by intros; simp,
  abs_map   := by intros; simp; refl, }

end const

end mvqpf


def Hd : List α → Type
  | []     => PUnit
  | a :: _ => α

def hd : (as : List α) → Hd as
  | []     => ()
  | a :: l => a

theorem inj_hd (α : Type) : (a a': α) → (l l' : List α) → a :: l = a' :: l' → a = a' := by
  intro a a' l l' h
  show hd (a :: l) = hd (a' :: l')
  cases h
  rfl


/-
Copyright (c) 2014 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Jeremy Avigad

Weak orders "≤", strict orders "<", and structures that include both.
-/
import .binary
universes u v w
hott_theory
set_option old_structure_cmd true

namespace hott

open algebra

variable {A : Type _}

/- weak orders -/

class has_le (α : Type u) := (le : α → α → Type u)
class has_lt (α : Type u) := (lt : α → α → Type u)

@[reducible] def ge {α : Type u} [has_le α] (a b : α) : Type u := has_le.le b a
@[reducible] def gt {α : Type u} [has_lt α] (a b : α) : Type u := has_lt.lt b a

hott_theory_cmd "local infix [parsing_only] ` <= ` := hott.has_le.le"
hott_theory_cmd "local infix ` ≤ `  := hott.has_le.le"
hott_theory_cmd "local infix ` < ` := hott.has_lt.lt"
hott_theory_cmd "local infix [parsing_only] ` >= ` := hott.ge"
hott_theory_cmd "local infix ` ≥ `  := hott.ge"
hott_theory_cmd "local infix ` > ` := hott.gt"

namespace algebra
@[hott, class] structure weak_order (A : Type _) extends has_le A :=
(le_refl : Πa, le a a)
(le_trans : Πa b c, le a b → le b c → le a c)
(le_antisymm : Πa b, le a b → le b a → a = b)

section
  variable [s : weak_order A]
  include s

  @[hott, refl] def le.rfl {a : A} : a ≤ a := weak_order.le_refl _
  @[hott] def le.refl (a : A) : a ≤ a := weak_order.le_refl _

  @[hott] def le_of_eq {a b : A} (H : a = b) : a ≤ b := transport (λx, a ≤ x) H (le.refl a)
  @[hott] def ge_of_eq {a b : A} (H : a = b) : a ≥ b := le_of_eq H⁻¹

  @[hott, trans] def le.trans {a b c : A} : a ≤ b → b ≤ c → a ≤ c := weak_order.le_trans _ _ _

  @[hott, trans] def le.trans_eq {a b c : A} (H1 : a ≤ b) (H2 : b = c) : a ≤ c :=
  le.trans H1 (le_of_eq H2)

  @[hott, trans] def le.eq_trans {a b c : A} (H1 : a = b) (H2 : b ≤ c) : a ≤ c :=
  le.trans (le_of_eq H1) H2

  @[hott, trans] def ge.trans {a b c : A} (H1 : a ≥ b) (H2: b ≥ c) : a ≥ c := le.trans H2 H1

  @[hott, trans] def ge.trans_eq {a b c : A} (H1 : a ≥ b) (H2 : b = c) : a ≥ c :=
  le.eq_trans H2⁻¹ H1

  @[hott, trans] def ge.eq_trans {a b c : A} (H1 : a = b) (H2 : b ≥ c) : a ≥ c :=
  le.trans_eq H2 H1⁻¹

  @[hott] def le.antisymm {a b : A} : a ≤ b → b ≤ a → a = b := weak_order.le_antisymm _ _

  -- Alternate syntax. (Abbreviations do not migrate well.)
  @[hott] def eq_of_le_of_ge {a b : A} : a ≤ b → b ≤ a → a = b := le.antisymm
end

@[hott, class] structure linear_weak_order (A : Type _) extends weak_order A :=
(le_total : Πa b, le a b ⊎ le b a)

section
  variables [linear_weak_order A]

  @[hott] def le.total (a b : A) : a ≤ b ⊎ b ≤ a := linear_weak_order.le_total _ _

  @[hott] theorem le_of_not_ge {a b : A} (H : ¬ a ≥ b) : a ≤ b := sum.resolve_left (le.total _ _) H

  @[hott] def le_by_cases (a b : A) {P : Type _} (H1 : a ≤ b → P) (H2 : b ≤ a → P) : P :=
  begin
    cases (le.total a b) with H H,
    { exact H1 H},
    { exact H2 H}
  end
end

/- strict orders -/

@[hott, class] structure strict_order (A : Type _) extends has_lt A :=
(lt_irrefl : Πa, ¬ lt a a)
(lt_trans : Πa b c, lt a b → lt b c → lt a c)

section
  variable [s : strict_order A]
  include s

  @[hott] def lt.irrefl (a : A) : ¬ a < a := strict_order.lt_irrefl _
  @[hott] def not_lt_self (a : A) : ¬ a < a := lt.irrefl _   -- alternate syntax

  @[hott] theorem lt_self_iff_empty (a : A) : a < a ↔ empty :=
  iff_empty_intro (lt.irrefl a)

  @[hott, trans] def lt.trans {a b c : A} : a < b → b < c → a < c := strict_order.lt_trans _ _ _

  @[hott, trans] def lt.trans_eq {a b c : A} (H1 : a < b) (H2 : b = c) : a < c :=
  by hinduction H2; exact H1

  @[hott, trans] def lt.eq_trans {a b c : A} (H1 : a = b) (H2 : b < c) : a < c :=
  by hinduction H1; exact H2

  @[hott, trans] def gt.trans {a b c : A} (H1 : a > b) (H2: b > c) : a > c := lt.trans H2 H1

  @[hott, trans] def gt.trans_eq {a b c : A} (H1 : a > b) (H2 : b = c) : a > c :=
  by hinduction H2; exact H1

  @[hott, trans] def gt.eq_trans {a b c : A} (H1 : a = b) (H2 : b > c) : a > c :=
  by hinduction H1; exact H2

  @[hott] def ne_of_lt {a b : A} (lt_ab : a < b) : a ≠ b :=
  assume eq_ab : a = b,
  show empty, from lt.irrefl b (eq_ab ▸ lt_ab)

  @[hott] theorem ne_of_gt {a b : A} (gt_ab : a > b) : a ≠ b :=
  ne.symm (ne_of_lt gt_ab)

  @[hott] theorem lt.asymm {a b : A} (H : a < b) : ¬ b < a :=
  assume H1 : b < a, lt.irrefl _ (lt.trans H H1)

  @[hott] theorem not_lt_of_gt {a b : A} (H : a > b) : ¬ a < b := lt.asymm H    -- alternate syntax
end

/- well-founded orders -/

@[hott, class] structure wf_strict_order (A : Type _) extends strict_order A :=
(wf_rec : ΠP : A → Type _, (Πx, (Πy, lt y x → P y) → P x) → Πx, P x)

@[hott] def wf.rec_on {A : Type _} [s : wf_strict_order A] {P : A → Type _}
    (x : A) (H : Πx, (Πy, wf_strict_order.lt y x → P y) → P x) : P x :=
wf_strict_order.wf_rec P H x

/- structures with a weak and a strict order -/

@[hott, class] structure order_pair (A : Type _) extends weak_order A, has_lt A :=
(le_of_lt : Π a b, lt a b → le a b)
(lt_of_lt_of_le : Π a b c, lt a b → le b c → lt a c)
(lt_of_le_of_lt : Π a b c, le a b → lt b c → lt a c)
(lt_irrefl : Π a, ¬ lt a a)

section
  variable [s : order_pair A]
  variables {a b c : A}
  include s

  @[hott] def le_of_lt : a < b → a ≤ b := order_pair.le_of_lt _ _

  @[hott, trans] def lt_of_lt_of_le : a < b → b ≤ c → a < c := order_pair.lt_of_lt_of_le _ _ _

  @[hott, trans] def lt_of_le_of_lt : a ≤ b → b < c → a < c := order_pair.lt_of_le_of_lt _ _ _

  @[hott] private def lt_irrefl (s' : order_pair A) (a : A) : ¬ a < a := order_pair.lt_irrefl _

  @[hott] private def lt_trans (s' : order_pair A) (a b c: A) (lt_ab : a < b) (lt_bc : b < c) :
    a < c :=
  lt_of_lt_of_le lt_ab (le_of_lt lt_bc)

  @[hott, instance] def order_pair.to_strict_order : strict_order A :=
  { lt_irrefl := lt_irrefl s, lt_trans := lt_trans s, ..s }

  @[hott, trans] def gt_of_gt_of_ge (H1 : a > b) (H2 : b ≥ c) : a > c := lt_of_le_of_lt H2 H1

  @[hott, trans] def gt_of_ge_of_gt (H1 : a ≥ b) (H2 : b > c) : a > c := lt_of_lt_of_le H2 H1

  @[hott] def not_le_of_gt (H : a > b) : ¬ a ≤ b :=
  assume H1 : a ≤ b,
  lt.irrefl _ (lt_of_lt_of_le H H1)

  @[hott] theorem not_lt_of_ge (H : a ≥ b) : ¬ a < b :=
  assume H1 : a < b,
  lt.irrefl _ (lt_of_le_of_lt H H1)
end

@[hott, class] structure strong_order_pair (A : Type _) extends weak_order A, has_lt A :=
(le_iff_lt_sum_eq : Πa b, le a b ↔ lt a b ⊎ a = b)
(lt_irrefl : Π a, ¬ lt a a)

@[hott] def le_iff_lt_sum_eq [s : strong_order_pair A] {a b : A} : a ≤ b ↔ a < b ⊎ a = b :=
strong_order_pair.le_iff_lt_sum_eq _ _

@[hott] def lt_sum_eq_of_le [s : strong_order_pair A] {a b : A} (le_ab : a ≤ b) : a < b ⊎ a = b :=
iff.mp le_iff_lt_sum_eq le_ab

@[hott] def le_of_lt_sum_eq [s : strong_order_pair A] {a b : A} (lt_sum_eq : a < b ⊎ a = b) :
  a ≤ b :=
iff.mpr le_iff_lt_sum_eq lt_sum_eq

@[hott] private def lt_irrefl' [s : strong_order_pair A] (a : A) : ¬ a < a :=
strong_order_pair.lt_irrefl _

@[hott] private def le_of_lt' [s : strong_order_pair A] (a b : A) : a < b → a ≤ b :=
λHlt, le_of_lt_sum_eq (sum.inl Hlt)

@[hott] private def lt_iff_le_prod_ne [s : strong_order_pair A] {a b : A} :
  a < b ↔ (a ≤ b × a ≠ b) :=
iff.intro
  (λHlt, pair (le_of_lt_sum_eq (sum.inl Hlt)) (λHab, absurd (Hab ▸ Hlt) (lt_irrefl' _)))
  (λHand,
   have Hor : a < b ⊎ a = b, from lt_sum_eq_of_le Hand.fst,
   sum.resolve_right Hor Hand.snd)

@[hott] theorem lt_of_le_of_ne [s : strong_order_pair A] {a b : A} : a ≤ b → a ≠ b → a < b :=
λH1 H2, iff.mpr lt_iff_le_prod_ne (pair H1 H2)

@[hott] private def ne_of_lt' [s : strong_order_pair A] {a b : A} (H : a < b) : a ≠ b :=
((iff.mp (@lt_iff_le_prod_ne _ _ _ _)) H).snd

@[hott] private def lt_of_lt_of_le' [s : strong_order_pair A] (a b c : A) : a < b → b ≤ c → a < c :=
assume lt_ab : a < b,
assume le_bc : b ≤ c,
have le_ac : a ≤ c, from le.trans (le_of_lt' _ _ lt_ab) le_bc,
have ne_ac : a ≠ c, from
  assume eq_ac : a = c,
  have le_ba : b ≤ a, from eq_ac⁻¹ ▸ le_bc,
  have eq_ab : a = b, from le.antisymm  (le_of_lt' _ _ lt_ab) le_ba,
  show empty, from ne_of_lt' lt_ab eq_ab,
show a < c, from iff.mpr (lt_iff_le_prod_ne) (pair le_ac ne_ac)

@[hott] def lt_of_le_of_lt' [s : strong_order_pair A] (a b c : A) : a ≤ b → b < c → a < c :=
assume le_ab : a ≤ b,
assume lt_bc : b < c,
have le_ac : a ≤ c, from le.trans le_ab (le_of_lt' _ _ lt_bc),
have ne_ac : a ≠ c, from
  assume eq_ac : a = c,
  have le_cb : c ≤ b, from eq_ac ▸ le_ab,
  have eq_bc : b = c, from le.antisymm  (le_of_lt' _ _ lt_bc) le_cb,
  show empty, from ne_of_lt' lt_bc eq_bc,
show a < c, from iff.mpr (lt_iff_le_prod_ne) (pair le_ac ne_ac)

@[hott, instance] def strong_order_pair.to_order_pair [s : strong_order_pair A] : order_pair A :=
{ lt_irrefl := lt_irrefl',
  le_of_lt := le_of_lt',
  lt_of_le_of_lt := lt_of_le_of_lt',
  lt_of_lt_of_le := lt_of_lt_of_le', ..s }

/- linear orders -/

@[hott, class] structure linear_order_pair (A : Type _) extends order_pair A, linear_weak_order A

@[hott, class] structure linear_strong_order_pair (A : Type _) extends strong_order_pair A,
    linear_weak_order A

@[hott, instance] def linear_strong_order_pair.to_linear_order_pair
    [s : linear_strong_order_pair A] : linear_order_pair A :=
{ ..s, ..strong_order_pair.to_order_pair }

section
  variable [s : linear_strong_order_pair A]
  variables (a b c : A)
  include s

  @[hott] def lt.trichotomy : a < b ⊎ a = b ⊎ b < a :=
  sum.elim (le.total a b)
    (assume H : a ≤ b,
      sum.elim (iff.mp le_iff_lt_sum_eq H) sum.inl (assume H1, sum.inr (sum.inl H1)))
    (assume H : b ≤ a,
      sum.elim (iff.mp le_iff_lt_sum_eq H)
        (assume H1, sum.inr (sum.inr H1))
        (assume H1, sum.inr (sum.inl (H1⁻¹))))

  @[hott] def lt.by_cases {a b : A} {P : Type _}
    (H1 : a < b → P) (H2 : a = b → P) (H3 : b < a → P) : P :=
  sum.elim (lt.trichotomy _ _)
    (assume H, H1 H)
    (assume H, sum.elim H (assume H', H2 H') (assume H', H3 H'))

  @[hott] def lt_ge_by_cases {a b : A} {P : Type _} (H1 : a < b → P) (H2 : a ≥ b → P) : P :=
  lt.by_cases H1 (λH, H2 (le_of_eq H⁻¹)) (λH, H2 (le_of_lt H))

  @[hott] def le_of_not_gt {a b : A} (H : ¬ a > b) : a ≤ b :=
  lt.by_cases (assume H', absurd H' H) (assume H', le_of_eq H'⁻¹) (assume H', le_of_lt H')

  @[hott] theorem lt_of_not_ge {a b : A} (H : ¬ a ≥ b) : a < b :=
  lt.by_cases
    (assume H', absurd begin exact le_of_lt H' end H)
    (assume H', absurd (le_of_eq H') H)
    (assume H', H')

  @[hott] theorem lt_sum_ge : a < b ⊎ a ≥ b :=
  lt.by_cases
    (assume H1 : a < b, sum.inl H1)
    (assume H1 : a = b, sum.inr (le_of_eq H1⁻¹))
    (assume H1 : a > b, sum.inr (le_of_lt H1))

  @[hott] theorem le_sum_gt : a ≤ b ⊎ a > b :=
  sum.swap (lt_sum_ge b a)

  @[hott] theorem lt_sum_gt_of_ne {a b : A} (H : a ≠ b) : a < b ⊎ a > b :=
  lt.by_cases (assume H1, sum.inl H1) (assume H1, absurd H1 H) (assume H1, sum.inr H1)
end

open decidable

@[hott, class] structure decidable_linear_order (A : Type _) extends linear_strong_order_pair A :=
(decidable_lt : decidable_rel lt)

section
  variable [s : decidable_linear_order A]
  variables {a b c d : A}
  include s
  open hott.decidable

  @[hott, instance] def decidable_lt : decidable (a < b) :=
  @decidable_linear_order.decidable_lt _ _ _ _

  @[hott, instance] def decidable_le : decidable (a ≤ b) :=
  by_cases
    (assume H : a < b, inl (le_of_lt H))
    (assume H : ¬ a < b,
      have H1 : b ≤ a, from le_of_not_gt H,
      by_cases
        (assume H2 : b < a, inr (not_le_of_gt H2))
        (assume H2 : ¬ b < a, inl (le_of_not_gt H2)))

  @[hott, instance] def has_decidable_eq : decidable (a = b) :=
  by_cases
    (assume H : a ≤ b,
      by_cases
        (assume H1 : b ≤ a, inl (le.antisymm H H1))
        (assume H1 : ¬ b ≤ a, inr (assume H2 : a = b, H1 (le_of_eq H2⁻¹))))
    (assume H : ¬ a ≤ b,
      (inr (assume H1 : a = b, H (le_of_eq H1))))

  @[hott] theorem eq_sum_lt_of_not_lt {a b : A} (H : ¬ a < b) : a = b ⊎ b < a :=
  if Heq :: a = b then sum.inl Heq else sum.inr (lt_of_not_ge (λ Hge, H (lt_of_le_of_ne Hge Heq)))

  @[hott] theorem eq_sum_lt_of_le {a b : A} (H : a ≤ b) : a = b ⊎ a < b :=
    begin
      hinduction eq_sum_lt_of_not_lt (not_lt_of_ge H) with x1 H' H',
      exact sum.inl H'⁻¹,
      exact sum.inr H'
    end

  @[hott] def lt.cases {B : Type _} (a b : A) (t_lt t_eq t_gt : B) : B :=
  if' a = b then t_eq else (if' a < b then t_lt else t_gt)

  @[hott] theorem lt.cases_of_eq {B : Type _} {a b : A} {t_lt t_eq t_gt : B} (H : a = b) :
  lt.cases a b t_lt t_eq t_gt = t_eq := if_pos H

  @[hott] theorem lt.cases_of_lt {B : Type _} {a b : A} {t_lt t_eq t_gt : B} (H : a < b) :
    lt.cases a b t_lt t_eq t_gt = t_lt :=
  if_neg (ne_of_lt H) ⬝ if_pos H

  @[hott] theorem lt.cases_of_gt {B : Type _} {a b : A} {t_lt t_eq t_gt : B} (H : a > b) :
    lt.cases a b t_lt t_eq t_gt = t_gt :=
  if_neg (ne.symm (ne_of_lt H)) ⬝ if_neg (lt.asymm H)

  @[hott] def min (a b : A) : A := if' a ≤ b then a else b
  @[hott] def max (a b : A) : A := if' a ≤ b then b else a

  /- these show min and max form a lattice -/

  @[hott] theorem min_le_left (a b : A) : min a b ≤ a :=
  hott.decidable.by_cases
    (assume H : a ≤ b, by dsimp [min]; rwr [if_pos H])
    (assume H : ¬ a ≤ b, by dsimp [min]; rwr [if_neg H]; apply le_of_lt (lt_of_not_ge H))

  @[hott] theorem min_le_right (a b : A) : min a b ≤ b :=
  hott.decidable.by_cases
    (assume H : a ≤ b, by dsimp [min]; rwr [if_pos H]; apply H)
    (assume H : ¬ a ≤ b, by dsimp [min]; rwr [if_neg H])

  @[hott] theorem le_min {a b c : A} (H₁ : c ≤ a) (H₂ : c ≤ b) : c ≤ min a b :=
  hott.decidable.by_cases
    (assume H : a ≤ b, by dsimp [min]; rwr [if_pos H]; apply H₁)
    (assume H : ¬ a ≤ b, by dsimp [min]; rwr [if_neg H]; apply H₂)

  @[hott] theorem le_max_left (a b : A) : a ≤ max a b :=
  hott.decidable.by_cases
    (assume H : a ≤ b, by dsimp [max]; rwr [if_pos H]; apply H)
    (assume H : ¬ a ≤ b, by dsimp [max]; rwr [if_neg H])

  @[hott] theorem le_max_right (a b : A) : b ≤ max a b :=
  hott.decidable.by_cases
    (assume H : a ≤ b, by dsimp [max]; rwr [if_pos H])
    (assume H : ¬ a ≤ b, by dsimp [max]; rwr [if_neg H]; apply le_of_lt (lt_of_not_ge H))

  @[hott] theorem max_le {a b c : A} (H₁ : a ≤ c) (H₂ : b ≤ c) : max a b ≤ c :=
  hott.decidable.by_cases
    (assume H : a ≤ b, by dsimp [max]; rwr [if_pos H]; apply H₂)
    (assume H : ¬ a ≤ b, by dsimp [max]; rwr [if_neg H]; apply H₁)

  @[hott] theorem le_max_left_iff_unit (a b : A) : a ≤ max a b ↔ unit :=
  iff_unit_intro (le_max_left a b)

  @[hott] theorem le_max_right_iff_unit (a b : A) : b ≤ max a b ↔ unit :=
  iff_unit_intro (le_max_right a b)

  /- these are also proved for lattices, but with inf and sup in place of min and max -/

  @[hott] theorem eq_min {a b c : A} (H₁ : c ≤ a) (H₂ : c ≤ b) (H₃ : Π{d}, d ≤ a → d ≤ b → d ≤ c) :
    c = min a b :=
  le.antisymm (le_min H₁ H₂) (H₃ (min_le_left _ _) (min_le_right _ _))

  @[hott] theorem min.comm (a b : A) : min a b = min b a :=
  eq_min (min_le_right _ _) (min_le_left _ _) (λ c H₁ H₂, le_min H₂ H₁)

  @[hott] theorem min.assoc (a b c : A) : min (min a b) c = min a (min b c) :=
  begin
    apply eq_min,
    { apply le.trans, apply min_le_left, apply min_le_left },
    { apply le_min, apply le.trans, apply min_le_left, apply min_le_right, apply min_le_right },
    { intros d H₁ H₂, apply le_min, apply le_min H₁, apply le.trans H₂, apply min_le_left,
      apply le.trans H₂, apply min_le_right }
  end

  @[hott] theorem min.left_comm (a b c : A) : min a (min b c) = min b (min a c) :=
  binary.left_comm (@min.comm A s) (@min.assoc A s) a b c

  @[hott] theorem min.right_comm (a b c : A) : min (min a b) c = min (min a c) b :=
  binary.right_comm (@min.comm A s) (@min.assoc A s) a b c

  @[hott] theorem min_self (a : A) : min a a = a :=
  by apply inverse; apply eq_min (le.refl a) le.rfl; intros; assumption

  @[hott] theorem min_eq_left {a b : A} (H : a ≤ b) : min a b = a :=
  by apply inverse; apply eq_min le.rfl H; intros; assumption

  @[hott] theorem min_eq_right {a b : A} (H : b ≤ a) : min a b = b :=
  by rwr min.comm; exact min_eq_left H

  @[hott] theorem eq_max {a b c : A} (H₁ : a ≤ c) (H₂ : b ≤ c) (H₃ : Π{d}, a ≤ d → b ≤ d → c ≤ d) :
    c = max a b :=
  le.antisymm (H₃ (le_max_left _ _) (le_max_right _ _)) (max_le H₁ H₂)

  @[hott] theorem max.comm (a b : A) : max a b = max b a :=
  eq_max (le_max_right _ _) (le_max_left _ _) (λ c H₁ H₂, max_le H₂ H₁)

  @[hott] theorem max.assoc (a b c : A) : max (max a b) c = max a (max b c) :=
  begin
    apply eq_max,
    { apply le.trans, apply le_max_left a b, apply le_max_left },
    { apply max_le, apply le.trans, apply le_max_right a b, apply le_max_left, apply le_max_right },
    { intros d H₁ H₂, apply max_le, apply max_le H₁, apply le.trans (le_max_left _ _) H₂,
      apply le.trans (le_max_right _ _) H₂}
  end

  @[hott] theorem max.left_comm (a b c : A) : max a (max b c) = max b (max a c) :=
  binary.left_comm (@max.comm A s) (@max.assoc A s) a b c

  @[hott] theorem max.right_comm (a b c : A) : max (max a b) c = max (max a c) b :=
  binary.right_comm (@max.comm A s) (@max.assoc A s) a b c

  @[hott] theorem max_self (a : A) : max a a = a :=
  by apply inverse; apply eq_max (le.refl a) le.rfl; intros; assumption

  @[hott] theorem max_eq_left {a b : A} (H : b ≤ a) : max a b = a :=
  by apply inverse; apply eq_max le.rfl H; intros; assumption

  @[hott] theorem max_eq_right {a b : A} (H : a ≤ b) : max a b = b :=
  by rwr max.comm; exact max_eq_left H

  /- these rely on lt_of_lt -/

  @[hott] theorem min_eq_left_of_lt {a b : A} (H : a < b) : min a b = a :=
  min_eq_left (le_of_lt H)

  @[hott] theorem min_eq_right_of_lt {a b : A} (H : b < a) : min a b = b :=
  min_eq_right (le_of_lt H)

  @[hott] theorem max_eq_left_of_lt {a b : A} (H : b < a) : max a b = a :=
  max_eq_left (le_of_lt H)

  @[hott] theorem max_eq_right_of_lt {a b : A} (H : a < b) : max a b = b :=
  max_eq_right (le_of_lt H)

  /- these use the fact that it is a linear ordering -/

  @[hott] theorem lt_min {a b c : A} (H₁ : a < b) (H₂ : a < c) : a < min b c :=
  sum.elim (le_sum_gt _ _)
    (assume H : b ≤ c, by rwr (min_eq_left H); apply H₁)
    (assume H : b > c, by rwr (min_eq_right_of_lt H); apply H₂)

  @[hott] theorem max_lt {a b c : A} (H₁ : a < c) (H₂ : b < c) : max a b < c :=
  sum.elim (le_sum_gt _ _)
    (assume H : a ≤ b, by rwr (max_eq_right H); apply H₂)
    (assume H : a > b, by rwr (max_eq_left_of_lt H); apply H₁)
end
end algebra
end hott


/-
Copyright (c) 2018 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Simon Hudon

! This file was ported from Lean 3 source module data.pfunctor.multivariate.basic
! leanprover-community/mathlib commit 23aa88e32dcc9d2a24cca7bc23268567ed4cd7d6
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Control.Functor.Multivariate
import Mathbin.Data.Pfunctor.Univariate.Basic

/-!
# Multivariate polynomial functors.

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

Multivariate polynomial functors are used for defining M-types and W-types.
They map a type vector `α` to the type `Σ a : A, B a ⟹ α`, with `A : Type` and
`B : A → typevec n`. They interact well with Lean's inductive definitions because
they guarantee that occurrences of `α` are positive.
-/

universe u v

open MvFunctor

#print MvPFunctor /-
/-- multivariate polynomial functors
-/
structure MvPFunctor (n : ℕ) where
  A : Type u
  B : A → TypeVec.{u} n
#align mvpfunctor MvPFunctor
-/

namespace MvPFunctor

open MvFunctor (Liftp Liftr)

variable {n m : ℕ} (P : MvPFunctor.{u} n)

#print MvPFunctor.Obj /-
/-- Applying `P` to an object of `Type` -/
def Obj (α : TypeVec.{u} n) : Type u :=
  Σa : P.A, P.B a ⟹ α
#align mvpfunctor.obj MvPFunctor.Obj
-/

#print MvPFunctor.map /-
/-- Applying `P` to a morphism of `Type` -/
def map {α β : TypeVec n} (f : α ⟹ β) : P.Obj α → P.Obj β := fun ⟨a, g⟩ => ⟨a, TypeVec.comp f g⟩
#align mvpfunctor.map MvPFunctor.map
-/

instance : Inhabited (MvPFunctor n) :=
  ⟨⟨default, default⟩⟩

#print MvPFunctor.Obj.inhabited /-
instance Obj.inhabited {α : TypeVec n} [Inhabited P.A] [∀ i, Inhabited (α i)] :
    Inhabited (P.Obj α) :=
  ⟨⟨default, fun _ _ => default⟩⟩
#align mvpfunctor.obj.inhabited MvPFunctor.Obj.inhabited
-/

instance : MvFunctor P.Obj :=
  ⟨@MvPFunctor.map n P⟩

#print MvPFunctor.map_eq /-
theorem map_eq {α β : TypeVec n} (g : α ⟹ β) (a : P.A) (f : P.B a ⟹ α) :
    @MvFunctor.map _ P.Obj _ _ _ g ⟨a, f⟩ = ⟨a, g ⊚ f⟩ :=
  rfl
#align mvpfunctor.map_eq MvPFunctor.map_eq
-/

#print MvPFunctor.id_map /-
theorem id_map {α : TypeVec n} : ∀ x : P.Obj α, TypeVec.id <$$> x = x
  | ⟨a, g⟩ => rfl
#align mvpfunctor.id_map MvPFunctor.id_map
-/

#print MvPFunctor.comp_map /-
theorem comp_map {α β γ : TypeVec n} (f : α ⟹ β) (g : β ⟹ γ) :
    ∀ x : P.Obj α, (g ⊚ f) <$$> x = g <$$> f <$$> x
  | ⟨a, h⟩ => rfl
#align mvpfunctor.comp_map MvPFunctor.comp_map
-/

instance : LawfulMvFunctor P.Obj where
  id_map := @id_map _ P
  comp_map := @comp_map _ P

#print MvPFunctor.const /-
/-- Constant functor where the input object does not affect the output -/
def const (n : ℕ) (A : Type u) : MvPFunctor n :=
  { A
    B := fun a i => PEmpty }
#align mvpfunctor.const MvPFunctor.const
-/

section Const

variable (n) {A : Type u} {α β : TypeVec.{u} n}

#print MvPFunctor.const.mk /-
/-- Constructor for the constant functor -/
def const.mk (x : A) {α} : (const n A).Obj α :=
  ⟨x, fun i a => PEmpty.elim a⟩
#align mvpfunctor.const.mk MvPFunctor.const.mk
-/

variable {n A}

#print MvPFunctor.const.get /-
/-- Destructor for the constant functor -/
def const.get (x : (const n A).Obj α) : A :=
  x.1
#align mvpfunctor.const.get MvPFunctor.const.get
-/

#print MvPFunctor.const.get_map /-
@[simp]
theorem const.get_map (f : α ⟹ β) (x : (const n A).Obj α) : const.get (f <$$> x) = const.get x :=
  by
  cases x
  rfl
#align mvpfunctor.const.get_map MvPFunctor.const.get_map
-/

#print MvPFunctor.const.get_mk /-
@[simp]
theorem const.get_mk (x : A) : const.get (const.mk n x : (const n A).Obj α) = x := by rfl
#align mvpfunctor.const.get_mk MvPFunctor.const.get_mk
-/

#print MvPFunctor.const.mk_get /-
@[simp]
theorem const.mk_get (x : (const n A).Obj α) : const.mk n (const.get x) = x :=
  by
  cases x
  dsimp [const.get, const.mk]
  congr with (_⟨⟩)
#align mvpfunctor.const.mk_get MvPFunctor.const.mk_get
-/

end Const

#print MvPFunctor.comp /-
/-- Functor composition on polynomial functors -/
def comp (P : MvPFunctor.{u} n) (Q : Fin2 n → MvPFunctor.{u} m) : MvPFunctor m
    where
  A := Σa₂ : P.1, ∀ i, P.2 a₂ i → (Q i).1
  B a i := Σ(j : _)(b : P.2 a.1 j), (Q j).2 (a.snd j b) i
#align mvpfunctor.comp MvPFunctor.comp
-/

variable {P} {Q : Fin2 n → MvPFunctor.{u} m} {α β : TypeVec.{u} m}

#print MvPFunctor.comp.mk /-
/-- Constructor for functor composition -/
def comp.mk (x : P.Obj fun i => (Q i).Obj α) : (comp P Q).Obj α :=
  ⟨⟨x.1, fun i a => (x.2 _ a).1⟩, fun i a => (x.snd a.fst a.snd.fst).snd i a.snd.snd⟩
#align mvpfunctor.comp.mk MvPFunctor.comp.mk
-/

#print MvPFunctor.comp.get /-
/-- Destructor for functor composition -/
def comp.get (x : (comp P Q).Obj α) : P.Obj fun i => (Q i).Obj α :=
  ⟨x.1.1, fun i a => ⟨x.fst.snd i a, fun (j : Fin2 m) (b : (Q i).B _ j) => x.snd j ⟨i, ⟨a, b⟩⟩⟩⟩
#align mvpfunctor.comp.get MvPFunctor.comp.get
-/

#print MvPFunctor.comp.get_map /-
theorem comp.get_map (f : α ⟹ β) (x : (comp P Q).Obj α) :
    comp.get (f <$$> x) = (fun i (x : (Q i).Obj α) => f <$$> x) <$$> comp.get x :=
  by
  cases x
  rfl
#align mvpfunctor.comp.get_map MvPFunctor.comp.get_map
-/

#print MvPFunctor.comp.get_mk /-
@[simp]
theorem comp.get_mk (x : P.Obj fun i => (Q i).Obj α) : comp.get (comp.mk x) = x :=
  by
  cases x
  simp! [comp.get, comp.mk]
#align mvpfunctor.comp.get_mk MvPFunctor.comp.get_mk
-/

#print MvPFunctor.comp.mk_get /-
@[simp]
theorem comp.mk_get (x : (comp P Q).Obj α) : comp.mk (comp.get x) = x :=
  by
  cases x
  dsimp [comp.get, comp.mk]
  ext : 2 <;> intros ; rfl; rfl
  congr ; ext1 <;> intros <;> rfl
  ext : 2; congr ; rcases x_1 with ⟨a, b, c⟩ <;> rfl
#align mvpfunctor.comp.mk_get MvPFunctor.comp.mk_get
-/

#print MvPFunctor.liftP_iff /-
/-
lifting predicates and relations
-/
theorem liftP_iff {α : TypeVec n} (p : ∀ ⦃i⦄, α i → Prop) (x : P.Obj α) :
    LiftP p x ↔ ∃ a f, x = ⟨a, f⟩ ∧ ∀ i j, p (f i j) :=
  by
  constructor
  · rintro ⟨y, hy⟩
    cases' h : y with a f
    refine' ⟨a, fun i j => (f i j).val, _, fun i j => (f i j).property⟩
    rw [← hy, h, map_eq]
    rfl
  rintro ⟨a, f, xeq, pf⟩
  use ⟨a, fun i j => ⟨f i j, pf i j⟩⟩
  rw [xeq]; rfl
#align mvpfunctor.liftp_iff MvPFunctor.liftP_iff
-/

#print MvPFunctor.liftP_iff' /-
theorem liftP_iff' {α : TypeVec n} (p : ∀ ⦃i⦄, α i → Prop) (a : P.A) (f : P.B a ⟹ α) :
    @LiftP.{u} _ P.Obj _ α p ⟨a, f⟩ ↔ ∀ i x, p (f i x) :=
  by
  simp only [liftp_iff, Sigma.mk.inj_iff] <;> constructor <;> intro
  · casesm*Exists _, _ ∧ _
    subst_vars
    assumption
  repeat' first |constructor|assumption
#align mvpfunctor.liftp_iff' MvPFunctor.liftP_iff'
-/

#print MvPFunctor.liftR_iff /-
theorem liftR_iff {α : TypeVec n} (r : ∀ ⦃i⦄, α i → α i → Prop) (x y : P.Obj α) :
    LiftR r x y ↔ ∃ a f₀ f₁, x = ⟨a, f₀⟩ ∧ y = ⟨a, f₁⟩ ∧ ∀ i j, r (f₀ i j) (f₁ i j) :=
  by
  constructor
  · rintro ⟨u, xeq, yeq⟩
    cases' h : u with a f
    use a, fun i j => (f i j).val.fst, fun i j => (f i j).val.snd
    constructor
    · rw [← xeq, h]
      rfl
    constructor
    · rw [← yeq, h]
      rfl
    intro i j
    exact (f i j).property
  rintro ⟨a, f₀, f₁, xeq, yeq, h⟩
  use ⟨a, fun i j => ⟨(f₀ i j, f₁ i j), h i j⟩⟩
  dsimp; constructor
  · rw [xeq]
    rfl
  rw [yeq]; rfl
#align mvpfunctor.liftr_iff MvPFunctor.liftR_iff
-/

open Set MvFunctor

#print MvPFunctor.supp_eq /-
theorem supp_eq {α : TypeVec n} (a : P.A) (f : P.B a ⟹ α) (i) :
    @supp.{u} _ P.Obj _ α (⟨a, f⟩ : P.Obj α) i = f i '' univ :=
  by
  ext; simp only [supp, image_univ, mem_range, mem_set_of_eq]
  constructor <;> intro h
  · apply @h fun i x => ∃ y : P.B a i, f i y = x
    rw [liftp_iff']
    intros
    refine' ⟨_, rfl⟩
  · simp only [liftp_iff']
    cases h
    subst x
    tauto
#align mvpfunctor.supp_eq MvPFunctor.supp_eq
-/

end MvPFunctor

/-
Decomposing an n+1-ary pfunctor.
-/
namespace MvPFunctor

open TypeVec

variable {n : ℕ} (P : MvPFunctor.{u} (n + 1))

#print MvPFunctor.drop /-
/-- Split polynomial functor, get a n-ary functor
from a `n+1`-ary functor -/
def drop : MvPFunctor n where
  A := P.A
  B a := (P.B a).drop
#align mvpfunctor.drop MvPFunctor.drop
-/

#print MvPFunctor.last /-
/-- Split polynomial functor, get a univariate functor
from a `n+1`-ary functor -/
def last : PFunctor where
  A := P.A
  B a := (P.B a).getLast
#align mvpfunctor.last MvPFunctor.last
-/

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
#print MvPFunctor.appendContents /-
/-- append arrows of a polynomial functor application -/
@[reducible]
def appendContents {α : TypeVec n} {β : Type _} {a : P.A} (f' : P.drop.B a ⟹ α)
    (f : P.getLast.B a → β) : P.B a ⟹ (α ::: β) :=
  splitFun f' f
#align mvpfunctor.append_contents MvPFunctor.appendContents
-/

end MvPFunctor


import Radon.LC_limit
import analysis.normed_space.weak_dual

open_locale nnreal big_operators classical

noncomputable theory

open category_theory
open category_theory.limits
open topological_space

local attribute [instance]
  locally_constant.seminormed_add_comm_group
  locally_constant.pseudo_metric_space

namespace Profinite

/-- The weak dual of `C(X,ℝ)` is linearly equivalent to
the weak dual of `locally_constant X ℝ`. -/
def weak_dual_C_equiv_LC (X : Profinite.{0}) :
  weak_dual ℝ C(X,ℝ) ≃ₗ[ℝ] weak_dual ℝ (locally_constant X ℝ) :=
{ inv_fun := X.weak_dual_LC_to_C,
  left_inv := begin
    intros f, ext t,
    show (locally_constant.pkg X ℝ).extend _ _ = _,
    --  `dsimp [weak_dual_C_to_LC, weak_dual_LC_to_C]` works instead of `show` but is slower
    apply (locally_constant.pkg X ℝ).induction_on t,
    { apply is_closed_eq,
      refine (locally_constant.pkg X ℝ).continuous_extend,
      exact f.2 },
    { intros e,
      rw (locally_constant.pkg X ℝ).extend_coe, refl,
      apply continuous_linear_map.uniform_continuous,
      apply_instance }
  end,
  right_inv := begin
    intros f, ext t,
    show (locally_constant.pkg X ℝ).extend _ _ = _,
--  `dsimp [weak_dual_C_to_LC, weak_dual_LC_to_C, weak_dual.comap]` works instead of `show`,
--  but is slower,
    erw (locally_constant.pkg X ℝ).extend_coe,
    apply continuous_linear_map.uniform_continuous,
    apply_instance,
  end,
  ..(X.weak_dual_C_to_LC) }

/-- An auxiliary definition to be used in the constructions below. -/
def Radon_to_Radon_LC (X : Profinite.{0}) (p c : ℝ≥0) :
  X.Radon p c ⟶ X.Radon_LC p c :=
{ to_fun := λ μ, ⟨weak_dual_C_to_LC _ μ.1, μ.2⟩,
  continuous_to_fun := begin
    apply continuous.subtype_mk,
    refine continuous.comp _ continuous_subtype_coe,
    exact continuous_linear_map.continuous _,
  end }

/-- An auxiliary definition to be used in the constructions below. -/
def Radon_LC_to_Radon (X : Profinite.{0}) (p c : ℝ≥0) :
  X.Radon_LC p c → X.Radon p c :=
λ μ, ⟨weak_dual_LC_to_C _ μ.1, begin
    change (weak_dual_C_to_LC _ (weak_dual_LC_to_C _ μ.1)).bdd_LC p c,
    erw X.weak_dual_C_equiv_LC.apply_symm_apply,
    exact μ.2,
  end⟩

/-- An auxiliary definition to be used in the constructions below. -/
def Radon_LC_to_weak_dual (X : Profinite.{0}) (p c : ℝ≥0) :
  X.Radon_LC p c → weak_dual ℝ (locally_constant X ℝ) := subtype.val

/-- An auxiliary definition to be used in the constructions below. -/
def weak_dual_LC_to_fun (X : Profinite.{0}) :
  weak_dual ℝ (locally_constant X ℝ) → locally_constant X ℝ → ℝ := λ μ x, μ x

lemma continuous_weak_dual_LC_to_fun (X : Profinite.{0}) :
  continuous X.weak_dual_LC_to_fun :=
begin
  apply continuous_pi, intros e,
  exact weak_dual.eval_continuous _,
end

instance t2_space_weak_dual (X : Profinite.{0}) :
  t2_space (weak_dual ℝ (locally_constant X ℝ)) :=
⟨λ x y h, separated_by_continuous (X.continuous_weak_dual_LC_to_fun) $
  λ c, h $ by { ext t, apply_fun (λ e, e t) at c, exact c } ⟩

lemma Radon_LC_closed_embedding (X : Profinite.{0}) (p c : ℝ≥0)
  [fact (0 < p)] [fact (p ≤ 1)] :
  closed_embedding (X.Radon_LC_to_weak_dual p c) :=
closed_embedding_subtype_coe
begin
  apply is_compact.is_closed,
  let S := _, change is_compact S,
  have : S = set.range (X.Radon_LC_to_weak_dual p c),
  { erw subtype.range_val, refl },
  rw this, clear this,
  apply is_compact_range,
  exact continuous_subtype_coe,
end

/-- An auxiliary definition to be used in the constructions below. -/
def Radon_to_weak_dual (X : Profinite.{0}) (p c : ℝ≥0) :
  X.Radon p c → weak_dual ℝ C(X,ℝ) := subtype.val

lemma Radon_closed_embedding (X : Profinite.{0}) (p c : ℝ≥0)
  [fact (0 < p)] [fact (p ≤ 1)] :
  closed_embedding (X.Radon_to_weak_dual p c) :=
closed_embedding_subtype_coe
begin
  let T : set (weak_dual ℝ (locally_constant X ℝ)) :=
    { f | f.bdd_LC p c },
  change is_closed (X.weak_dual_C_to_LC ⁻¹' T),
  apply is_closed.preimage,
  exact (weak_dual_C_to_LC X).continuous,
  convert (X.Radon_LC_closed_embedding p c).closed_range,
  erw subtype.range_val, refl,
end

lemma Radon_closed_embedding_range_bdd (X : Profinite) (p c : ℝ≥0)
  [fact (0 < p)] [fact (p ≤ 1)] : metric.bounded
  (normed_space.dual.to_weak_dual ⁻¹' set.range (X.Radon_to_weak_dual p c)) :=
begin
  -- Use c^(1/p)
  letI : uniform_space (locally_constant.pkg X ℝ).space :=
    (locally_constant.pkg X ℝ).uniform_struct,
  refine (metric.bounded_iff_subset_ball 0).mpr _,
  refine ⟨c^(1/(p : ℝ)), λ μ hμ, mem_closed_ball_zero_iff.mpr _⟩,
  apply continuous_linear_map.op_norm_le_bound,
  refine (nnreal.coe_nonneg _).trans_eq (nnreal.coe_rpow _ _),
  intros f,
  apply (locally_constant.pkg X ℝ).induction_on f,
  { apply is_closed_le,
    refine continuous.comp (continuous_norm) _,
    exact μ.continuous,
    refine continuous.comp (continuous_mul_left _) continuous_norm },
  { intros e,
    let γ : weak_dual ℝ (locally_constant X ℝ) :=
      X.weak_dual_C_to_LC μ,
    dsimp [locally_constant.pkg],
    have : μ e = γ e, refl, rw this, clear this,
    have : ∥ e.to_continuous_map ∥ = ∥ e ∥,
    { simp only [continuous_map.norm_eq_supr_norm,
        locally_constant.norm_def, locally_constant.to_continuous_map_eq_coe,
        locally_constant.coe_continuous_map] },
    erw this, clear this,
    suffices : ∥ γ e ∥₊ ≤ c^(1 / (p : ℝ)) * ∥ e ∥₊, by exact_mod_cast this,
    have hp : 0 < (p : ℝ) := nnreal.coe_pos.mpr (fact.out (0 < p)),
    have hp' : (p : ℝ) ≠ 0,
    { exact ne_of_gt hp },
    rw [← nnreal.rpow_le_rpow_iff hp, nnreal.mul_rpow, ← nnreal.rpow_mul],
    rw [(show 1 / (p : ℝ) * p = 1, from (eq_div_iff hp').mp rfl), nnreal.rpow_one],
    obtain ⟨δ,hδ⟩ := hμ,
    have H := δ.2 e.discrete_quotient,
    replace H := mul_le_mul H (le_refl (∥ e ∥₊^(p : ℝ))) (zero_le _) (zero_le _),
    refine le_trans _ H, clear H,
    rw [mul_comm, finset.mul_sum],
    nth_rewrite 0 e.eq_sum,

    simp_rw [γ.map_sum, γ.map_smul],
    refine le_trans (real.pow_nnnorm_sum_le _ _ _) _,

    apply finset.sum_le_sum, rintros x -,
    rw [smul_eq_mul, nnnorm_mul, nnreal.mul_rpow],
    refine mul_le_mul _ (le_of_eq _) (zero_le _) (zero_le _),
    apply nnreal.rpow_le_rpow _ (le_of_lt hp),
    obtain ⟨x,rfl⟩ := discrete_quotient.proj_surjective _ x,
    change ∥ e x ∥₊ ≤ _,
    apply locally_constant.nnnorm_apply_le_nnnorm,
    congr' 2,
    change _ = X.Radon_to_weak_dual p c δ _, rw hδ, refl },
end

instance compact_space_Radon (X : Profinite) (p c : ℝ≥0)
  [fact (0 < p)] [fact (p ≤ 1)] :
  compact_space (X.Radon p c) :=
begin
  let e : X.Radon p c ≃ₜ set.range (X.Radon_to_weak_dual p c) :=
    homeomorph.of_embedding _ (X.Radon_closed_embedding p c).to_embedding,
  suffices : compact_space (set.range (X.Radon_to_weak_dual p c)),
  { resetI, apply e.symm.compact_space },
  rw ← is_compact_iff_compact_space,
  apply weak_dual.is_compact_of_bounded_of_closed,
  apply Radon_closed_embedding_range_bdd,
  exact (X.Radon_closed_embedding p c).closed_range,
end

/-- An auxiliary definition to be used in the constructions below. -/
def Radon_equiv_Radon_LC (X : Profinite.{0}) (p c : ℝ≥0) :
  X.Radon p c ≃ X.Radon_LC p c :=
{ to_fun := X.Radon_to_Radon_LC p c,
  inv_fun := X.Radon_LC_to_Radon p c,
  left_inv := begin
    intros t, ext1,
    apply X.weak_dual_C_equiv_LC.symm_apply_apply,
  end,
  right_inv := begin
    intros t, ext1,
    apply X.weak_dual_C_equiv_LC.apply_symm_apply,
  end }

lemma continuous_Radon_equiv_Radon_LC (X : Profinite.{0}) (p c : ℝ≥0) :
  continuous (X.Radon_equiv_Radon_LC p c) :=
continuous_map.continuous _

lemma continuous_Radon_equiv_Radon_LC_symm (X : Profinite.{0}) (p c : ℝ≥0)
  [fact (0 < p)] [fact (p ≤ 1)] :
  continuous (X.Radon_equiv_Radon_LC p c).symm :=
begin
  rw continuous_iff_is_closed,
  intros T hT,
  rw ← equiv.image_eq_preimage,
  apply is_compact.is_closed,
  apply is_compact.image,
  exact is_closed.is_compact hT,
  exact continuous_map.continuous _,
end

/-- An auxiliary definition to be used in the constructions below. -/
def Radon_homeomorph_Radon_LC (X : Profinite.{0}) (p c : ℝ≥0)
  [fact (0 < p)] [fact (p ≤ 1)] :
  X.Radon p c ≃ₜ X.Radon_LC p c :=
{ continuous_to_fun := continuous_Radon_equiv_Radon_LC _ _ _,
  continuous_inv_fun := continuous_Radon_equiv_Radon_LC_symm _ _ _,
  ..(X.Radon_equiv_Radon_LC p c) }

/-- An auxiliary definition to be used in the constructions below. -/
def Radon_iso_Radon_LC (X : Profinite.{0}) (p c : ℝ≥0)
  [fact (0 < p)] [fact (p ≤ 1)] :
  X.Radon p c ≅ X.Radon_LC p c :=
Top.iso_of_homeo (X.Radon_homeomorph_Radon_LC p c)

/-- The functor `X ↦ X.Radon p c` is isomorphic to its locally constant variant. -/
def Radon_functor_iso_Radon_LC_functor (p c : ℝ≥0)
  [fact (0 < p)] [fact (p ≤ 1)] :
  Radon_functor p c ≅ Radon_LC_functor p c :=
nat_iso.of_components
(λ X, X.Radon_iso_Radon_LC p c)
begin
  intros X Y f, ext, refl,
end

/-- A `CompHaus` variant of `Radon_functor`. -/
def Radon_CompHaus_functor (p c : ℝ≥0)
  [fact (0 < p)] [fact (p ≤ 1)] :
  Profinite.{0} ⥤ CompHaus.{0} :=
{ obj := λ X, CompHaus.of $ X.Radon p c,
  map := λ X Y f, (Radon_functor p c).map f,
  map_id' := (Radon_functor p c).map_id,
  map_comp' := λ _ _ _ f g, (Radon_functor p c).map_comp f g }

/-- The functor `X ↦ X.Radon p c` is isomorphic to its locally constant variant.
This is a variant taking values in `CompHaus` as opposed to `Top`. -/
def Radon_CompHaus_functor_iso_Radon_LC_CompHaus_functor (p c : ℝ≥0)
  [fact (0 < p)] [fact (p ≤ 1)] :
  Radon_CompHaus_functor p c ≅ Radon_LC_CompHaus_functor p c :=
nat_iso.of_components
(λ X,
{ hom := (Radon_functor_iso_Radon_LC_functor p c).hom.app X,
  inv := (Radon_functor_iso_Radon_LC_functor p c).inv.app X,
  hom_inv_id' := begin
    erw [← nat_trans.comp_app, iso.hom_inv_id], refl,
  end,
  inv_hom_id' := begin
    erw [← nat_trans.comp_app, iso.inv_hom_id], refl,
  end })
begin
  intros, ext, refl,
end

/-- The cone exhibiting `X.Radon p c` as the limit of `T.Radon p c` where
`T` varies over the discrete quotients of `X`. -/
def Radon_CompHaus_cone (X : Profinite.{0}) (p c : ℝ≥0)
  [fact (0 < p)] [fact (p ≤ 1)] :
  cone (X.diagram ⋙ Radon_CompHaus_functor p c) :=
(Radon_CompHaus_functor p c).map_cone X.as_limit_cone

/-- X.Radon_CompHaus_cone p c` is a limit cone, as promised. -/
def is_limit_Radon_CompHaus_cone (X : Profinite.{0}) (p c : ℝ≥0)
  [fact (0 < p)] [fact (p ≤ 1)] :
  is_limit (X.Radon_CompHaus_cone p c) :=
{ lift := λ S,
    (X.is_limit_Radon_LC_CompHaus_cone p c).lift
    ⟨S.X, S.π ≫ whisker_left _ (Radon_CompHaus_functor_iso_Radon_LC_CompHaus_functor p c).hom⟩ ≫
    (Radon_CompHaus_functor_iso_Radon_LC_CompHaus_functor p c).inv.app _,
  fac' := begin
    intros S j,
    erw [category.assoc, ← nat_trans.naturality,
      (X.is_limit_Radon_LC_CompHaus_cone p c).fac_assoc,
      ← nat_iso.app_inv, iso.comp_inv_eq], refl,
  end,
  uniq' := begin
    intros S m hm,
    rw [← nat_iso.app_inv, iso.eq_comp_inv],
    apply (X.is_limit_Radon_LC_CompHaus_cone p c).hom_ext, intros j,
    erw (X.is_limit_Radon_LC_CompHaus_cone p c).fac,
    dsimp, rw ← hm,
    simp only [category.assoc],
    erw ← nat_trans.naturality,
  end }

/-- The comparison between `Radon_LC` and `real_measures p` taking
values in `CompHaus` instead of `Top`, and restricted to the discrete quotients of `X`. -/
def Radon_LC_CompHaus_comparison (X : Profinite.{0}) (p c : ℝ≥0)
  [fact (0 < p)] [fact (p ≤ 1)] :
  X.diagram ⋙ Radon_LC_CompHaus_functor p c ≅
  X.fintype_diagram ⋙ real_measures.functor p ⋙ CompHausFiltPseuNormGrp₁.level.obj c :=
nat_iso.of_components
(λ T,
{ hom := (X.Radon_LC_comparison p c).hom.app _,
  inv := (X.Radon_LC_comparison p c).inv.app _,
  hom_inv_id' := begin
    erw [← nat_trans.comp_app, iso.hom_inv_id], refl,
  end,
  inv_hom_id' := begin
    erw [← nat_trans.comp_app, iso.inv_hom_id], refl,
  end })
begin
  intros S T i, dsimp,
  erw ((X.Radon_LC_comparison p c).hom).naturality, refl,
end

/-- The comparison between `Radon` and `real_measures p`
restricted to the discrete quotients of `X`. -/
def Radon_CompHaus_comparison (X : Profinite.{0}) (p c : ℝ≥0)
  [fact (0 < p)] [fact (p ≤ 1)] :
  X.diagram ⋙ Radon_CompHaus_functor p c ≅
  X.fintype_diagram ⋙ real_measures.functor p ⋙ CompHausFiltPseuNormGrp₁.level.obj c :=
iso_whisker_left _ (Radon_CompHaus_functor_iso_Radon_LC_CompHaus_functor _ _) ≪≫
Radon_LC_CompHaus_comparison _ _ _

/-- An auxiliary definition to be used in the constructions below. -/
def Radon_iso_limit (X : Profinite.{0}) (p c : ℝ≥0)
  [fact (0 < p)] [fact (p ≤ 1)] :
  CompHaus.of (X.Radon p c) ≅
  limit (X.fintype_diagram ⋙ real_measures.functor p ⋙ CompHausFiltPseuNormGrp₁.level.obj c) :=
(X.is_limit_Radon_CompHaus_cone p c).cone_point_unique_up_to_iso (limit.is_limit _) ≪≫
has_limit.iso_of_nat_iso (Radon_CompHaus_comparison _ _ _)

/-- The compact Hausdorff space `X.Radon p c` is isomorphic to the limit of
`real_measures p T` as `T` varies over the discrete quotients of `X`.
-/
def Radon_iso_real_measures (X : Profinite.{0}) (p c : ℝ≥0)
  [fact (0 < p)] [fact (p ≤ 1)] :
  CompHaus.of (X.Radon p c) ≅
  (CompHausFiltPseuNormGrp₁.level.obj c).obj
  ((Profinite.extend (real_measures.functor p)).obj X) :=
Radon_iso_limit _ _ _ ≪≫
has_limit.iso_of_nat_iso (functor.associator _ _ _).symm ≪≫
(limit.is_limit _).cone_point_unique_up_to_iso
(is_limit_of_preserves ((CompHausFiltPseuNormGrp₁.level.obj c))
  (limit.is_limit (X.fintype_diagram ⋙ real_measures.functor p)))

end Profinite


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.fin_category
import category_theory.limits.shapes.binary_products
import category_theory.limits.shapes.equalizers
import category_theory.limits.shapes.wide_pullbacks
import category_theory.limits.shapes.pullbacks
import data.fintype.basic

/-!
# Categories with finite limits.

A typeclass for categories with all finite (co)limits.
-/

universes w' w v' u' v u

noncomputable theory

open category_theory

namespace category_theory.limits

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

/--
A category has all finite limits if every functor `J ⥤ C` with a `fin_category J`
instance and `J : Type` has a limit.

This is often called 'finitely complete'.
-/
-- We can't just made this an `abbreviation`
-- because of https://github.com/leanprover-community/lean/issues/429
class has_finite_limits : Prop :=
(out (J : Type) [𝒥 : small_category J] [@fin_category J 𝒥] : @has_limits_of_shape J 𝒥 C _)

@[priority 100]
instance has_limits_of_shape_of_has_finite_limits
  (J : Type w) [small_category J] [fin_category J] [has_finite_limits C] :
  has_limits_of_shape J C :=
begin
  apply has_limits_of_shape_of_equivalence (fin_category.equiv_as_type J),
  apply has_finite_limits.out
end

@[priority 100]
instance has_finite_limits_of_has_limits_of_size [has_limits_of_size.{v' u'} C] :
  has_finite_limits C :=
⟨λ J hJ hJ', by { haveI := has_limits_of_size_shrink.{0 0} C,
  exact has_limits_of_shape_of_equivalence (fin_category.equiv_as_type J) }⟩

/-- If `C` has all limits, it has finite limits. -/
@[priority 100]
instance has_finite_limits_of_has_limits [has_limits C] : has_finite_limits C :=
infer_instance

/-- We can always derive `has_finite_limits C` by providing limits at an
arbitrary universe. -/
lemma has_finite_limits_of_has_finite_limits_of_size
  (h : ∀ (J : Type w) {𝒥 : small_category J} (hJ : @fin_category J 𝒥),
    by { resetI, exact has_limits_of_shape J C }) :
  has_finite_limits C :=
⟨λ J hJ hhJ,
  begin
    resetI,
    letI : category.{w w} (ulift_hom.{w} (ulift.{w 0} J)),
    { apply ulift_hom.category.{0}, exact category_theory.ulift_category J },
    haveI := h (ulift_hom.{w} (ulift.{w} J)) category_theory.fin_category_ulift,
    exact has_limits_of_shape_of_equivalence (ulift_hom_ulift_category.equiv.{w w} J).symm
  end ⟩

/--
A category has all finite colimits if every functor `J ⥤ C` with a `fin_category J`
instance and `J : Type` has a colimit.

This is often called 'finitely cocomplete'.
-/
class has_finite_colimits : Prop :=
(out (J : Type) [𝒥 : small_category J] [@fin_category J 𝒥] : @has_colimits_of_shape J 𝒥 C _)

@[priority 100]
instance has_colimits_of_shape_of_has_finite_colimits
  (J : Type w) [small_category J] [fin_category J] [has_finite_colimits C] :
  has_colimits_of_shape J C :=
begin
  apply has_colimits_of_shape_of_equivalence (fin_category.equiv_as_type J),
  apply has_finite_colimits.out
end

@[priority 100]
instance has_finite_colimits_of_has_colimits_of_size [has_colimits_of_size.{v' u'} C] :
  has_finite_colimits C :=
⟨λ J hJ hJ', by { haveI := has_colimits_of_size_shrink.{0 0} C,
  exact has_colimits_of_shape_of_equivalence (fin_category.equiv_as_type J) }⟩

/-- We can always derive `has_finite_colimits C` by providing colimits at an
arbitrary universe. -/
lemma has_finite_colimits_of_has_finite_colimits_of_size
  (h : ∀ (J : Type w) {𝒥 : small_category J} (hJ : @fin_category J 𝒥),
    by { resetI, exact has_colimits_of_shape J C }) :
  has_finite_colimits C :=
⟨λ J hJ hhJ,
  begin
    resetI,
    letI : category.{w w} (ulift_hom.{w} (ulift.{w 0} J)),
    { apply ulift_hom.category.{0}, exact category_theory.ulift_category J },
    haveI := h (ulift_hom.{w} (ulift.{w} J)) category_theory.fin_category_ulift,
    exact has_colimits_of_shape_of_equivalence (ulift_hom_ulift_category.equiv.{w w} J).symm
  end ⟩
section

open walking_parallel_pair walking_parallel_pair_hom

instance fintype_walking_parallel_pair : fintype walking_parallel_pair :=
{ elems := [walking_parallel_pair.zero, walking_parallel_pair.one].to_finset,
  complete := λ x, by { cases x; simp } }

local attribute [tidy] tactic.case_bash

instance (j j' : walking_parallel_pair) : fintype (walking_parallel_pair_hom j j') :=
{ elems := walking_parallel_pair.rec_on j
    (walking_parallel_pair.rec_on j' [walking_parallel_pair_hom.id zero].to_finset
      [left, right].to_finset)
    (walking_parallel_pair.rec_on j' ∅ [walking_parallel_pair_hom.id one].to_finset),
  complete := by tidy }

end

instance : fin_category walking_parallel_pair := { }

/-- Equalizers are finite limits, so if `C` has all finite limits, it also has all equalizers -/
example [has_finite_limits C] : has_equalizers C := by apply_instance

/-- Coequalizers are finite colimits, of if `C` has all finite colimits, it also has all
    coequalizers -/
example [has_finite_colimits C] : has_coequalizers C := by apply_instance

variables {J : Type v}

local attribute [tidy] tactic.case_bash

namespace wide_pullback_shape

instance fintype_obj [fintype J] : fintype (wide_pullback_shape J) :=
by { rw wide_pullback_shape, apply_instance }

instance fintype_hom (j j' : wide_pullback_shape J) : fintype (j ⟶ j') :=
{ elems :=
  begin
    cases j',
    { cases j,
      { exact {hom.id none} },
      { exact {hom.term j} } },
    { by_cases some j' = j,
      { rw h,
        exact {hom.id j} },
      { exact ∅ } }
  end,
  complete := by tidy }

end wide_pullback_shape

namespace wide_pushout_shape

instance fintype_obj [fintype J] : fintype (wide_pushout_shape J) :=
by { rw wide_pushout_shape, apply_instance }

instance fintype_hom (j j' : wide_pushout_shape J) : fintype (j ⟶ j') :=
{ elems :=
  begin
    cases j,
    { cases j',
      { exact {hom.id none} },
      { exact {hom.init j'} } },
    { by_cases some j = j',
      { rw h,
        exact {hom.id j'} },
      { exact ∅ } }
  end,
  complete := by tidy }

end wide_pushout_shape

instance fin_category_wide_pullback [fintype J] : fin_category (wide_pullback_shape J) :=
{ fintype_hom := wide_pullback_shape.fintype_hom }

instance fin_category_wide_pushout [fintype J] :
  fin_category (wide_pushout_shape J) :=
{ fintype_hom := wide_pushout_shape.fintype_hom }

/--
`has_finite_wide_pullbacks` represents a choice of wide pullback
for every finite collection of morphisms
-/
-- We can't just made this an `abbreviation`
-- because of https://github.com/leanprover-community/lean/issues/429
class has_finite_wide_pullbacks : Prop :=
(out (J : Type) [fintype J] : has_limits_of_shape (wide_pullback_shape J) C)

instance has_limits_of_shape_wide_pullback_shape
  (J : Type) [fintype J] [has_finite_wide_pullbacks C] :
  has_limits_of_shape (wide_pullback_shape J) C :=
by { haveI := @has_finite_wide_pullbacks.out C _ _ J, apply_instance }

/--
`has_finite_wide_pushouts` represents a choice of wide pushout
for every finite collection of morphisms
-/
class has_finite_wide_pushouts : Prop :=
(out (J : Type) [fintype J] : has_colimits_of_shape (wide_pushout_shape J) C)

instance has_colimits_of_shape_wide_pushout_shape
  (J : Type) [fintype J] [has_finite_wide_pushouts C] :
  has_colimits_of_shape (wide_pushout_shape J) C :=
by { haveI := @has_finite_wide_pushouts.out C _ _ J, apply_instance }

/--
Finite wide pullbacks are finite limits, so if `C` has all finite limits,
it also has finite wide pullbacks
-/
lemma has_finite_wide_pullbacks_of_has_finite_limits [has_finite_limits C] :
  has_finite_wide_pullbacks C :=
⟨λ J _, by exactI has_finite_limits.out _⟩

/--
Finite wide pushouts are finite colimits, so if `C` has all finite colimits,
it also has finite wide pushouts
-/
lemma has_finite_wide_pushouts_of_has_finite_limits [has_finite_colimits C] :
  has_finite_wide_pushouts C :=
⟨λ J _, by exactI has_finite_colimits.out _⟩

instance fintype_walking_pair : fintype walking_pair :=
{ elems := {walking_pair.left, walking_pair.right},
  complete := λ x, by { cases x; simp } }

/-- Pullbacks are finite limits, so if `C` has all finite limits, it also has all pullbacks -/
example [has_finite_wide_pullbacks C] : has_pullbacks C := by apply_instance

/-- Pushouts are finite colimits, so if `C` has all finite colimits, it also has all pushouts -/
example [has_finite_wide_pushouts C] : has_pushouts C := by apply_instance

end category_theory.limits


structure A where
  private x : Nat := 10

def g (a : Nat) : A :=
  {}

theorem ex1 (a : Nat) : (g a |>.x) = 10 :=
  rfl

structure B extends A where
  y : Nat
  x := 20

def f (a : Nat) : B :=
  { y := a }

theorem ex2 (a : Nat) : (f a |>.x) = 20 :=
  rfl


import data.nat.basic

-- The next lemma won't be used, it's a warming up exercise for the one below.
-- It could go to mathlib.
lemma exists_by_induction {α : Type*} {P : ℕ → α → Prop}
  (h₀ : ∃ a, P 0 a)
  (ih : ∀ n a, P n a → ∃ a', P (n+1) a') :
  ∃ f : ℕ → α, ∀ n, P n (f n) :=
begin
  choose f₀ hf₀ using h₀,
  choose! F hF using ih,
  exact ⟨λ n, nat.rec_on n f₀ F, λ n, nat.rec hf₀ (λ n ih, hF n _ ih) n⟩
end

-- We make `P` and `Q` explicit to help the elaborator when applying the lemma
-- (elab_as_eliminator isn't enough).
lemma exists_by_induction' {α : Type*} (P : ℕ → α → Prop) (Q : ℕ → α → α → Prop)
  (h₀ : ∃ a, P 0 a)
  (ih : ∀ n a, P n a → ∃ a', P (n+1) a' ∧ Q n a a') :
  ∃ f : ℕ → α, ∀ n, P n (f n) ∧ Q n (f n) (f $ n+1) :=
begin
  choose f₀ hf₀ using h₀,
  choose! F hF hF' using ih,
  have key : ∀ n, P n (nat.rec_on n f₀ F), from λ n, nat.rec hf₀ (λ n ih, hF n _ ih) n,
  exact ⟨λ n, nat.rec_on n f₀ F, λ n, ⟨key n, hF' n _ (key n)⟩⟩
end


--  An abstract formalization of "isomorphism is equality up to relabeling"
-- -------------------------------------------------------------------------
--
-- See `README.md` for more info.
--
-- Definitions related to `functorStructure`.

import Structure.Basic
import Structure.UniverseFunctor
import Structure.ProductStructure

open Morphisms
open HasStructure

set_option autoBoundImplicitLocal false

namespace StructureFunctor.functorStructure

-- `universeStructure` enables us to define functors for the two maps from a structure `T` to the
-- functor structure with `T` on one side.
--
-- In other words, `functorStructure` is functorial in both arguments.

section OneSided

variable (S : Structure)

def outgoingToFun {T₁ T₂ : Structure} (e : T₁ ≃ T₂) :
  StructureFunctor (functorStructure S T₁) (functorStructure S T₂) :=
compFun.congrArg_right.functor S e.toFun

namespace outgoingToFun

def respectsEquiv {T₁ T₂ : Structure} :
  GeneralizedFunctor.Functor (S := StructureEquiv.equivStructure T₁ T₂)
                             (T := functorStructure (functorStructure S T₁) (functorStructure S T₂))
                             (outgoingToFun S) :=
(compFun.congrArg_right.functor.functorFunctor S ⊙ StructureEquiv.toFunProj T₁ T₂).functor

def respectsComp {T₁ T₂ T₃ : Structure} (e : T₁ ≃ T₂) (f : T₂ ≃ T₃) :
  outgoingToFun S (f • e) ≃ outgoingToFun S f ⊙ outgoingToFun S e :=
compFun.congrArg_right.functor.respectsCompFun S e.toFun f.toFun

theorem respectsComp.nat {T₁ T₂ T₃ : Structure} {e₁ e₂ : T₁ ≃ T₂} {f₁ f₂ : T₂ ≃ T₃} (η : e₁ ≃ e₂) (θ : f₁ ≃ f₂) :
  compFun.congrArg (respectsEquiv S η) (respectsEquiv S θ) • respectsComp S e₁ f₁ ≈ respectsComp S e₂ f₂ • respectsEquiv S (StructureEquiv.comp_congrArg η θ) :=
compFun.congrArg_right.functor.respectsCompFun.nat S η.toFunEquiv θ.toFunEquiv

def respectsId (T : Structure) :
  outgoingToFun S (id_ T) ≃ @idFun (functorStructure S T) :=
compFun.congrArg_right.functor.respectsIdFun S T

end outgoingToFun

def outgoingFunctorDesc : UniverseStructureFunctorDesc :=
{ map             := λ T => functorStructure S T,
  toFun           := outgoingToFun                  S,
  respectsEquiv   := outgoingToFun.respectsEquiv    S,
  respectsComp    := outgoingToFun.respectsComp     S,
  respectsCompNat := outgoingToFun.respectsComp.nat S,
  respectsId      := outgoingToFun.respectsId       S }

def outgoingFunctorFunctor' : UniverseStructureFunctor :=
UniverseStructureFunctorDesc.universeStructureFunctor (outgoingFunctorDesc S)

def outgoingFunctorFunctor : UniverseFunctor universeStructure :=
UniverseStructureFunctorDesc.universeFunctor (outgoingFunctorDesc S)

def incomingToFun {T₁ T₂ : Structure} (e : T₁ ≃ T₂) :
  StructureFunctor (functorStructure T₁ S) (functorStructure T₂ S) :=
compFun.congrArg_left.functor S e.invFun

namespace incomingToFun

def respectsEquiv {T₁ T₂ : Structure} :
  GeneralizedFunctor.Functor (S := StructureEquiv.equivStructure T₁ T₂)
                             (T := functorStructure (functorStructure T₁ S) (functorStructure T₂ S))
                             (incomingToFun S) :=
(compFun.congrArg_left.functor.functorFunctor S ⊙ StructureEquiv.invFunProj T₁ T₂).functor

def respectsComp {T₁ T₂ T₃ : Structure} (e : T₁ ≃ T₂) (f : T₂ ≃ T₃) :
  incomingToFun S (f • e) ≃ incomingToFun S f ⊙ incomingToFun S e :=
compFun.congrArg_left.functor.respectsCompFun S f.invFun e.invFun

theorem respectsComp.nat {T₁ T₂ T₃ : Structure} {e₁ e₂ : T₁ ≃ T₂} {f₁ f₂ : T₂ ≃ T₃} (η : e₁ ≃ e₂) (θ : f₁ ≃ f₂) :
  compFun.congrArg (respectsEquiv S η) (respectsEquiv S θ) • respectsComp S e₁ f₁ ≈ respectsComp S e₂ f₂ • respectsEquiv S (StructureEquiv.comp_congrArg η θ) :=
compFun.congrArg_left.functor.respectsCompFun.nat S θ.invFunEquiv η.invFunEquiv

def respectsId (T : Structure) :
  incomingToFun S (id_ T) ≃ @idFun (functorStructure T S) :=
compFun.congrArg_left.functor.respectsIdFun S T

end incomingToFun

def incomingFunctorDesc : UniverseStructureFunctorDesc :=
{ map             := λ T => functorStructure T S,
  toFun           := incomingToFun                  S,
  respectsEquiv   := incomingToFun.respectsEquiv    S,
  respectsComp    := incomingToFun.respectsComp     S,
  respectsCompNat := incomingToFun.respectsComp.nat S,
  respectsId      := incomingToFun.respectsId       S }

def incomingFunctorFunctor' : UniverseStructureFunctor :=
UniverseStructureFunctorDesc.universeStructureFunctor (incomingFunctorDesc S)

def incomingFunctorFunctor : UniverseFunctor universeStructure :=
UniverseStructureFunctorDesc.universeFunctor (incomingFunctorDesc S)

end OneSided

-- `outgoingFunctorFunctor` and `incomingFunctorFunctor` are themselves functors.

def outgoingFunctorFunctorFunctor :
  StructureFunctor universeStructure (functorStructure universeStructure universeStructure) :=
{ map     := outgoingFunctorFunctor,
  functor := { mapEquiv  := λ e => { ext := λ T => congrArg (incomingFunctorFunctor T) e,
                                     nat := sorry },
               isFunctor := sorry } }

def incomingFunctorFunctorFunctor :
  StructureFunctor universeStructure (functorStructure universeStructure universeStructure) :=
{ map     := incomingFunctorFunctor,
  functor := { mapEquiv  := λ e => { ext := λ T => congrArg (outgoingFunctorFunctor T) e,
                                     nat := sorry },
               isFunctor := sorry } }

-- By uncurrying, we can obtain a `UniverseFunctor` that outputs arbitrary functor structures, i.e.
-- `(S, T) ↦ (S → T)`.

section TwoSided

def functorStructureFunctor : UniverseFunctor (StructureProduct.productStructure universeStructure universeStructure) :=
FunctorProductEquivalences.uncurry outgoingFunctorFunctorFunctor

end TwoSided

end StructureFunctor.functorStructure


import analysis.special_functions.pow

import polyhedral_lattice.cosimplicial
import combinatorial_lemma
import breen_deligne.eg

import thm95.constants.spectral_constants

import for_mathlib.nnreal

/-!
# Explicit formulas for the constants used in Theorem 9.5 of Analytic.pdf

Fix the following notation.

* `r` and `r'` are real numbers satisfying `0 < r < r' ≤ 1`
* `BD` denotes a Breen-Deligne package
* `κ'` is a sequence of nonnegative real numbers
* `Λ` denotes a polyhedral lattice

The main goal of this file is to define sequences of constants `k₁`, `K₁`, `k'`, `N₂`, `b`, `H`,
satisfying the inequalities below.
But first we make some abbreviations:

* `k₀ m := normed_spectral.k₀ m (k₁ m)`
* `K₀ m := normed_spectral.K₀ m (K₁ m)`
* `ε m := normed_spectral.ε m (K₁ m)`
* `k m := (k' m)^2`
* `K m := 2 * K₀ m * H m`

It is known that:

* `normed_spectral.k₀` always returns a number larger or equal to `1`.
* `normed_spectral.K₀` always returns a number larger or equal to `1`.
* `normed_spectral.ε` always returns a positive number.

The following inequalities are imposed on these constants
by the normed homological algebra of the rest of the proof:

* `1 < k₁ m`
* `1 ≤ K₁ m`
* `1 ≤ k' m`
* `k (m - 1) ≤ k₁ m`, for `m > 0`
* `K (m - 1) ≤ K₁ m`, for `m > 0`
* `m + 2 + (r + 1) / (r * (1 - r)) * (m + 2) ^ 2 ≤ K₁ m`
* `k₀ m ≤ k' m`
* `κ' i ≤ k' m` for all `i ≤ m+1`
* `(2 * k' m) * (r / r') ^ (b m) ≤ ε m`
* `k' m ≤ 2 ^ N₂ m`
* `k' m / (2 ^ N₂ m) ≤ r' ^ (b m)`
* `r ^ (b m) * (2 ^ N₂ m) ≤ 2 * k' m * (r / r') ^ (b m)`
* For `q ≤ m`, the technical condition
  `((BD.data.homotopy_mul BD.homotopy (N₂ m)).hom q (q + 1)).bound_by (H m)`
  saying that `H m` should be larger than a list of `m + 1` numbers depending on `BD` and `N₂ m`.

-/

noncomputable theory

open_locale nnreal

open real finset

namespace helper

/-- Given real numbers `r`, `r'`, `k'`, and `ε`, we define `b` to be the smallest natural number
larger than `log(ε / (2 * k')) / log(r/r')`. -/
def b (r r' k' ε : ℝ) : ℕ := nat.ceil ((log $ ε/(2 * k')) / log (r/r'))

/-- Under the constraints that `r`, `r'`, `k'`, and `ε` are positive real numbers
satisfying `r < r'`, the natural number `b = b r r' k' ε` satisfies
`(2 * k') * (r/r') ^ b ≤ ε`. -/
lemma b_spec {r r' k' ε : ℝ} (hr : 0 < r) (hr' : 0 < r') (hrr' : r < r')
  (hk' : 0 < k') (hε : 0 < ε) : (2 * k') * (r / r') ^ (b r r' k' ε) ≤ ε :=
begin
  have f₁ : 0 < 2*k' := mul_pos zero_lt_two hk',
  have f₂ : r/r' < 1 := (div_lt_one hr').mpr hrr',
  have f₃ : 0 < r/r' := div_pos hr hr',
  have f₄ :0 < (r / r') ^ b r r' k' ε := pow_pos f₃ _,
  rw [← le_div_iff' f₁, ← log_le_log f₄ (div_pos hε f₁), log_pow, ← div_le_iff_of_neg (log_neg f₃ f₂)],
  exact nat.le_ceil (log (ε / (2 * k')) / log (r / r')),
end

/-- Given real numbers `r'`, `k'`, and `b`, we define `N₂` to be the smallest natural number
larger than `log(k' / r'^b) / log(2)`. -/
def N₂ (r' k' b : ℝ) := nat.ceil (log (k'/r'^b) / log 2)

/-- Under the constraints that `r'` and `k'` are positive real numbers,
the natural number `N₂ = N₂ r' k' b` satisfies `k' / (2 ^ N₂) ≤ r' ^ b`. -/
lemma N₂_spec {r' k' b : ℝ} (hr' : 0 < r') (hk' : 0 < k') : k'/ (2 ^ (N₂ r' k' b)) ≤ r' ^ b :=
begin
  have f₁ : (0 : ℝ) < 2 ^ N₂ r' k' b := pow_pos zero_lt_two _,
  have f₂ : (0 : ℝ) < r' ^ b := rpow_pos_of_pos hr' _,
  have f₃ : 0 < k' / r' ^ b := div_pos hk' f₂,
  have f₄ : 0 < log 2 := log_pos one_lt_two,
  rw [div_le_iff' f₁, ← div_le_iff f₂,  ← log_le_log f₃ f₁, log_pow, ← div_le_iff f₄],
  apply nat.le_ceil,
end

/-- Under the constraints that `r'` is a positive real number and `k'` is nonnegative,
the natural number `N₂ = N₂ r' k' b` satisfies `r' ^b < 2 * k' / (2 ^ N₂)`. -/
lemma N₂_spec_of_pos' {r' k' b} (h : 0 < N₂ r' k' b) (hr' : 0 < r') (hk' : 0 ≤ k') :
  r' ^ b < 2 * k'  / 2 ^ N₂ r' k' b :=
begin
  have h' := nat.lt_ceil.mp h,
  have : 0 < log (k'/r'^b)/ log 2,
  { exact_mod_cast nat.lt_ceil.mp h },
  have f₁ : 0 < 2 ^ N₂ r' k' b := pow_pos zero_lt_two _,
  have Hk' : k' ≠ 0,
  { intro H,
    simpa [H, N₂] using h },
  have f₂ : 0 < r' ^ b := rpow_pos_of_pos hr' b,

  have f₃ : 0 < k' / r' ^ b := div_pos ((ne.symm Hk').le_iff_lt.mp hk') f₂,
  have f₃' : k' / r' ^ b ≠ 0 := f₃.ne.symm,
  have f₄ : (N₂ r' k' b : ℝ) < _ := nat.ceil_lt_add_one this.le,

  rwa [lt_div_iff, ← lt_div_iff', mul_div_assoc, ← log_lt_log_iff, log_mul, log_pow,
       ← lt_div_iff (log_pos one_lt_two), add_div, div_self (log_pos one_lt_two).ne.symm, add_comm],
  all_goals { assumption <|> norm_num  },
  assumption
end

end helper

section

/-!
In the rest of this file, we fix once and for all the following parameters:

* `r` and `r'` are nonnegative real numbers
* `BD` denotes a Breen-Deligne package
* `κ` and `κ'` are sequences of nonnegative real numbers,
  that are assumed to be "adept" with respect to `BD`
  and "very suitable" with respect to `BD`, `r`, and `r'`.
* `Λ` denotes a polyhedral lattice
-/

parameters (r r' : ℝ≥0)
parameters (BD : breen_deligne.package) (κ κ' : ℕ → ℝ≥0)
parameters (Λ : PolyhedralLattice)

/-!
We also let `m` denote a variable natural number.
-/

variables  (m : ℕ)

namespace thm95

open system_of_double_complexes

namespace universal_constants

open breen_deligne

/-- `k₁ m` is a sequence of nonnegative real numbers, defined recursively via
* `k₁ 0 = 2` (the important property being `k₁ 0 > 1`) and
* `k₁ (m+1)` is the maximum of `2` and `c`,
  where `c` is the square of the maximum of `k₀ m (k₁ m)`, and `κ' 0`, `κ' 1`, ..., `κ' (m+1)`.
  Here `k₀ m k` is the sequence of constants used in the proof of `normed_spectral`. -/
noncomputable def k₁ : ℕ → ℝ≥0
| 0     := 2 -- should be anything > 1
| (m+1) := max 2 ((max (normed_spectral.k₀ m (k₁ m)) $ (range $ m+2).sup κ')^2)

/-- All the numbers `k₁ m` are larger than `1`. -/
instance one_lt_k₁ : Π (m : ℕ), fact (1 < k₁ m)
| 0     := ⟨one_lt_two⟩
| (m+1) := ⟨lt_of_lt_of_le one_lt_two (le_max_left _ _)⟩

/-- `k₀ m` is the constant `k₀ m (k m)` used in the proof of `normed_spectral`. -/
abbreviation k₀ : ℝ≥0 := normed_spectral.k₀ m (k₁ m)

/-- `k' m` is the maximum of `k₀ m` and the constants `κ' 0`, `κ' 1`, ..., `κ' m`, `κ' (m+1)` -/
def k' : ℝ≥0 := max (k₀ m) $ (range $ m+2).sup κ'

/-- For indices `i` ranging over `0` up to `m+1`, we have `κ' i ≤ k' m`. -/
lemma κ'_le_k' {i : ℕ} (hi : i ≤ m+1) : κ' i ≤ k' m :=
le_max_iff.mpr $ or.inr $ le_sup $ mem_range.mpr $ nat.lt_succ_iff.mpr hi

-- A different way of telling Lean the same fact as the previous lemma.
instance fact_κ'_le_k' {i : ℕ} (hi : fact (i ≤ m+1)) : fact (κ' i ≤ k' m) := ⟨κ'_le_k' _ hi.1⟩

/-- We always have `1 ≤ k' m` for all `m`, since `1 ≤ k₀ m`. -/
instance one_le_k' : fact (1 ≤ k' m) := ⟨le_trans (fact.out _) $ le_max_left _ _⟩

/-- We always `k₀ m ≤ k' m`. -/
instance k₀_le_k' : fact (k₀ m ≤ k' m) := ⟨le_max_left _ _⟩

/-- `k m` is the square of `k' m`. -/
def k : ℝ≥0 := k' m * k' m

instance one_le_k : fact (1 ≤ k m) := by { delta k, apply_instance }

/-- For positive `m`, we have `k (m-1) ≤ k₁ m`. -/
instance k_le_k₁ [fact (0 < m)] : fact (k (m - 1) ≤ k₁ m) :=
begin
  unfreezingI {cases m},
  { exact false.elim (lt_irrefl 0 (fact.elim infer_instance)) },
  { apply fact.mk,
    simp only [k₁],
    convert le_max_right _ _,
    rw pow_two,
    refl }
end

/-- `k₁_sqrt m` denotes the square root of `k₁ m`. -/
def k₁_sqrt : ℝ≥0 := ⟨real.sqrt (k₁ m), real.sqrt_nonneg _⟩

instance one_lt_k₁_sqrt : fact (1 < k₁_sqrt m) := ⟨begin
  change (1 : ℝ) < real.sqrt (k₁ κ' m),
  rw [real.lt_sqrt zero_le_one, pow_two, mul_one],
  exact (universal_constants.one_lt_k₁ κ' m).elim,
end⟩

/-- `y m r` denotes `m + 2 + (r + 1) / (r - r^2) * (m + 2)^2`. -/
def y (m : ℕ) (r : ℝ≥0) := (m + 2 : ℝ≥0) + (r + 1) / (r * (1 - r)) * (m + 2)^2

/-- `H' m n` is the maximum of `1` and `c`, where `c` bounds the first `m+1` maps in the
`n`-th iteration of the homotopy of the Breen-Deligne package `BD`. -/
def H' (n : ℕ) :=
max 1 ((range $ m+1).sup $ λ q, ((BD.data.homotopy_mul BD.homotopy n).hom q (q + 1)).bound)

/-- `K₁` is a sequence of nonnegative real numbers, defined recursively via
* `K₁ 0 = 2 + (r + 1) / (r * (1 - r)) * 4`
* `K₁ (m+1) = max (y (m+1) r) c`, where
  - `y (m+1) r` is defined to be `m + 3 + (r + 1) / (r - r^2) * (m + 3)^2`
  - `c` is `2 * K₀ m (K₁ m) * (H' m N₂)`
  - `K₀ m K₁` denotes one of the constants used in the proof of `normed_spectral`
  - `N₂` denotes the natural number `N₂ r' (k' m) (b r r' (k' m) ε)` defined before
  - `ε` denotes the constant `ε m (K₁ m)` used in the proof of `normed_spectral`. -/
noncomputable def K₁ : ℕ → ℝ≥0
| 0     := 2 + (r + 1) / (r * (1 - r)) * 4
| (m+1) :=
max (y (m+1) r)
    (2 * normed_spectral.K₀ m (K₁ m) *
         (H' m $ helper.N₂ r' (k' m) (helper.b r r' (k' m) (normed_spectral.ε m (K₁ m)))))

/-- For all `m`, the number `K₁ m` is larger than `1`. -/
instance one_le_K₁ : ∀ m, fact (1 ≤ K₁ m)
| 0     := ⟨begin
             dsimp [K₁],
             apply le_add_right,
             exact one_le_two
            end⟩
| (m+1) := ⟨begin
              dsimp [K₁],
              refine le_max_iff.mpr (or.inl _),
              dsimp [y],
              apply le_add_right,
              norm_cast,
              exact le_add_self
            end⟩

/-- `K₀ m` is the constant `K₀ m (K m)` used in the proof of `normed_spectral` -/
abbreviation K₀ : ℝ≥0 := normed_spectral.K₀ m (K₁ m)

/-- `ε m` is the constant `ε m (K m)` used in the proof of `normed_spectral` -/
abbreviation ε : ℝ≥0 := normed_spectral.ε m (K₁ m)

instance ε_pos : fact (0 < ε m) := ⟨normed_spectral.ε_pos _ _⟩

variables [fact (0 < r)] [fact (0 < r')] [fact (r < r')] [fact (r' ≤ 1)]

/-- `b κ' r r' m` is the smallest `b` such that `2 * (k' m) * (r / r') ^ b ≤ (ε m)`. -/
def b : ℕ := helper.b r r' (k' m) (ε m)

/-- `b κ' r r' m` is the smallest `b` such that `2 * (k' m) * (r / r') ^ b ≤ (ε m)`.
This lemma proves that `b` indeed satisfies the property claimed at its definition. -/
lemma b_spec : (2 * k' m) * (r / r') ^ (b m) ≤ ε m :=
begin
  suffices : 2 * (k' κ' m : ℝ) * (r / r') ^ b r r' BD κ' m ≤ ε r r' BD κ' m,
  exact_mod_cast this,
  apply helper.b_spec ‹fact (0 < r)›.out ‹fact (0 < r')›.out ‹fact (r < r')›.out ; norm_cast ;
  apply fact.out
end

/-- `N₂ κ' r r' m` is the smallest `N₂` such that `N = 2 ^ N₂` satisfies
`(k' m) / N ≤ r' ^ (b κ' r r' m)`. -/
def N₂ : ℕ := helper.N₂ r' (k' m) (b m)

/-- `N₂ κ' r r' m` is the smallest `N₂` such that `N = 2 ^ N₂` satisfies
`(k' m) / N ≤ r' ^ (b κ' r r' m)`.
This lemma proves that `N₂` indeed satisfies the property claimed at its definition. -/
lemma N₂_spec : (k' m) / (2 ^ (N₂ m)) ≤ r' ^ b m :=
begin
  suffices : (k' κ' m : ℝ) / 2 ^ N₂ r r' BD κ' m ≤ r' ^ (b r r' BD κ' m : ℝ),
  exact_mod_cast this,
  apply helper.N₂_spec ‹fact (0 < r')›.out ; norm_cast ;
  apply fact.out
end

/-- `N₂ = N₂ κ' r r' m` is defined in such a way that `r' ^ b < 2 * k' m / 2 ^ N₂`,
where `b = b κ' r r' m`. -/
lemma N₂_spec_of_pos' (h : 0 < N₂ m) :
  r' ^ b m < 2 * k' m / 2 ^ N₂ m :=
begin
  suffices : (r' : ℝ) ^ (b r r' BD κ' m : ℝ) < 2 * k' κ' m / 2 ^ N₂ r r' BD κ' m,
  exact_mod_cast this,
  apply helper.N₂_spec_of_pos' h,
  { norm_cast,
    exact ‹fact (0 < r')›.out },
  apply nnreal.coe_nonneg
end

lemma k'_eq_one_of_N₂_spec_eq_zero (h : N₂ m = 0) : k' m = 1 :=
begin
  refine le_antisymm _ (universal_constants.one_le_k' _ _).1,
  obtain F := N₂_spec r r' BD κ' m,
  rw [h, pow_zero, div_one] at F,
  refine F.trans (pow_le_one (b r r' BD κ' m) (le_of_lt _) _);
  { apply fact.out _,
    assumption }
end

/-- `N m = 2 ^ N₂ m` is the smallest `N` that satisfies `(k' m) / N ≤ r' ^ (b m)` -/
def N : ℕ := 2 ^ N₂ m

instance N_pos : fact (0 < N m) := ⟨pow_pos zero_lt_two _⟩

/-- For all `m` we have `k' m ≤ N m = 2 ^ N₂ m`. -/
instance k'_le_two_pow_N : fact (k' m ≤ 2 ^ N₂ m) :=
{ out := begin
  rw [← mul_one ((2 : ℝ≥0) ^ _)],
  obtain F := N₂_spec r r' BD κ' m,
  rw [nnreal.div_le_iff (pow_pos zero_lt_two _).ne', mul_comm] at F,
  refine F.trans (mul_le_mul rfl.le _ _ _),
  { refine pow_le_one _ (zero_le r') _,
    apply fact.out _,
    assumption },
  repeat { exact pow_nonneg (zero_le _) _ }
end }

/-- For all `m` we have `r ^ (b m) * (N m) ≤ 2 * k' m * (r / r') ^ (b m)`. -/
lemma r_pow_b_mul_N_le : r ^ (b m) * (N m) ≤ 2 * k' m * (r / r') ^ (b m) :=
begin
  rw [mul_comm _ (_ ^ _), N, div_pow, nat.cast_pow, nat.cast_bit0, nat.cast_one, div_eq_mul_one_div,
    mul_assoc, div_mul_comm, mul_one],
  refine mul_le_mul_left' _ _,
  rw [nnreal.le_div_iff_mul_le, mul_comm, ← nnreal.le_div_iff_mul_le],
  { by_cases N0 : N₂ r r' BD κ' m = 0,
    { rw [k'_eq_one_of_N₂_spec_eq_zero _ _ BD _ _ N0, mul_one, N0, pow_zero, div_one],
      refine le_trans (pow_le_one _ (nnreal.coe_nonneg _) _) one_le_two,
      apply fact.out _,
      assumption },
    { exact le_of_lt (N₂_spec_of_pos' _ _ BD _ _ (zero_lt_iff.mpr N0)) } },
  { exact pow_ne_zero _ two_ne_zero },
  { exact pow_ne_zero _ (ne_of_gt (fact.out _)) }
end

/-- For all `m` we have `r ^ b m * N m ≤ ε m`. -/
lemma r_pow_b_le_ε : r ^ b m * N m ≤ ε m := (r_pow_b_mul_N_le _).trans (b_spec _)

/-- For all `m` we have `k' m * (2 ^ N₂ m)⁻¹ ≤ r' ^ b m`. -/
lemma N₂_spec' : k' m * (2 ^ N₂ m)⁻¹ ≤ r' ^ b m :=
by { rw [inv_eq_one_div, mul_one_div], exact N₂_spec r r' BD κ' m }

/-- `H BD κ' r r' m` is the universal bound on the norm of the `N₂`th Breen--Deligne homotopy
in the first `m` degrees. Here `N₂ = N₂ κ' r r' m`. -/
def H : ℕ := H' m (N₂ m)

lemma one_le_H : 1 ≤ H m := le_max_left _ _

instance H_pos : fact (0 < H m) := ⟨zero_lt_one.trans_le $ one_le_H _⟩
instance H_pos' : fact ((0:ℝ≥0) < H m) := by { norm_cast, apply_instance }

lemma bound_by_H {q : ℕ} (h : q ≤ m) :
  ((BD.data.homotopy_mul BD.homotopy (N₂ m)).hom q (q + 1)).bound_by (H m) :=
begin
  rw [H, H', universal_map.bound_by, le_max_iff],
  right,
  refine @le_sup _ _ _ _ (range $ m+1)
    (λ q, ((BD.data.homotopy_mul BD.homotopy (N₂ r r' BD κ' m)).hom q (q + 1)).bound) _ _,
  rwa [mem_range, nat.lt_succ_iff],
end

/-- `K m` is defined to be `2 * K₀ m (K₁ m) * H m`,
where `K₀ m (K₁ m)` is one of the constants used in the proof of `normed_spectral`. -/
def K : ℝ≥0 := 2 * normed_spectral.K₀ m (K₁ m) * H m

instance one_le_K : fact (1 ≤ K m) := fact.mk $
calc 1 = 1 * 1 * 1 : by simp
... ≤ 2 * normed_spectral.K₀ m (K₁ m) * H m :
begin
  refine mul_le_mul' (mul_le_mul' one_le_two $ (normed_spectral.one_le_K₀ _ _).1) _,
  norm_cast,
  apply one_le_H
end

/-- For all positive `m`, we have `K (m - 1) ≤ K₁ m`. -/
instance K_le_K₁ [fact (0 < m)] : fact (K (m - 1) ≤ K₁ m) :=
⟨begin
  tactic.unfreeze_local_instances,
  have hm : 0 < m, from fact.out _,
  cases m,
  { exfalso, exact nat.lt_asymm hm hm, },
  simp only [K₁, nat.succ_sub_succ_eq_sub, nat.sub_zero, le_max_iff],
  right,
  apply le_refl
end⟩

lemma K₁_spec : (m + 2 + (r + 1) / (r * (1 - r)) * (m + 2)^2 : ℝ≥0) ≤ K₁ m :=
begin
  cases m,
  { norm_num [K₁] },
  { simp only [K₁, le_max_iff],
    left,
    apply le_refl }
end

section open simplex_category

def c₀_aux (m : ℕ) (Λ : PolyhedralLattice) : ℝ≥0 :=
N m * lem98.d Λ (N m) / (k₁_sqrt m - 1) / r' / (range $ m+1).inf' ⟨0, by simp⟩ κ

-- define this such that the lemmas below hold
noncomputable def c₀ : ℕ → PolyhedralLattice → ℝ≥0
| 0 Λ := c₀_aux 0 Λ
| (m+1) Λ := max (c₀_aux (m+1) Λ)
    (max (c₀ m Λ)
    (max (c₀ m ((Λ.cosimplicial (N (m+1))).obj (mk 0)))
      ((range (m+1)).sup (λ i, c₀ m ((Λ.cosimplicial (N (m+1))).obj (mk (i + 1)))))))

lemma c₀_mono : fact (c₀ (m - 1) Λ ≤ c₀ m Λ) :=
begin
  fsplit,
  cases m,
  { apply le_refl, },
  { dsimp [c₀],
    apply le_trans _ (le_max_right _ _),
    apply le_trans _ (le_max_left _ _),
    simp, }
end

lemma c₀_pred_le (hm : 0 < m) : fact (c₀ (m - 1) ((Λ.cosimplicial (N m)).obj (mk 0)) ≤  c₀ m Λ) :=
begin
  fsplit,
  cases m,
  { cases hm, },
  { dsimp [c₀],
    apply le_trans _ (le_max_right _ _),
    apply le_trans _ (le_max_right _ _),
    apply le_trans _ (le_max_left _ _),
    simp, }
end

lemma c₀_pred_le_of_le (i : ℕ) (hi : i + 2 ≤ m + 1) :
  fact (c₀ (m - 1) ((Λ.cosimplicial (N m)).obj (mk (i + 1))) ≤ c₀ m Λ) :=
begin
  fsplit,
  cases m,
  { simpa using nat.succ_le_succ_iff.mp hi, },
  { dsimp [c₀],
    replace hi : i ∈ range (m + 1) :=
      mem_range.mpr (nat.succ_le_iff.mp (nat.succ_le_succ_iff.mp hi)),
    apply le_trans _ (le_max_right _ _),
    apply le_trans _ (le_max_right _ _),
    apply le_trans _ (le_max_right _ _),
    simp only [nat.succ_sub_succ_eq_sub, nat.sub_zero, nat.succ_eq_add_one],
    exact le_sup hi, }
end

lemma fix_this_in_mathlib :
  nnreal.semilattice_inf = lattice.to_semilattice_inf ℝ≥0 :=
begin
  apply semilattice_inf.ext, intros, refl,
end

lemma c₀_spec [BD.data.very_suitable r r' κ] (j : ℕ) (hj : j ≤ m) :
  lem98.d Λ (N m) ≤ (k₁_sqrt m - 1) * (r' * (κ j * c₀ m Λ)) / (N m) :=
begin
  have w := BD.data.pos κ,
  rw [nnreal.le_div_iff', ←nnreal.div_le_iff', ←nnreal.div_le_iff', ←nnreal.div_le_iff'],
  rotate,
  { exact (w _).ne' },
  { apply ne_of_gt, exact fact.out _ },
  { rw [← pos_iff_ne_zero, ←add_lt_add_iff_right (1 : ℝ≥0), tsub_add_cancel_of_le, zero_add]; apply fact.out, },
  { apply ne_of_gt, exact fact.out _ },
  cases m, { cases hj, apply le_refl, },
  refine le_trans _ (le_max_left _ _),
  dsimp [c₀_aux],
  apply nnreal.div_le_div_left_of,
  { rw [fix_this_in_mathlib, lt_inf'_iff], intros b mem, exact w b },
  { refine inf'_le _ _, exact mem_range_succ_iff.mpr hj },
end

end

end universal_constants

end thm95

end