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

! This file was ported from Lean 3 source module data.fintype.card
! leanprover-community/mathlib commit 92ca63f0fb391a9ca5f22d2409a6080e786d99f7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Fintype.Basic
import Mathlib.Data.Finset.Card
import Mathlib.Data.List.NodupEquivFin
import Mathlib.Tactic.Positivity

/-!
# Cardinalities of finite types

## Main declarations

* `Fintype.card α`: Cardinality of a fintype. Equal to `Finset.univ.card`.
* `Fintype.truncEquivFin`: A fintype `α` is computably equivalent to `Fin (card α)`. The
  `trunc`-free, noncomputable version is `Fintype.equivFin`.
* `Fintype.truncEquivOfCardEq` `Fintype.equivOfCardEq`: Two fintypes of same cardinality are
  equivalent. See above.
* `Fin.equiv_iff_eq`: `fin m ≃ fin n` iff `m = n`.
* `Infinite.natEmbedding`: An embedding of `ℕ` into an infinite type.

We also provide the following versions of the pigeonholes principle.
* `Fintype.exists_ne_map_eq_of_card_lt` and `isEpty_of_card_lt`: Finitely many pigeons and
  pigeonholes. Weak formulation.
* `Finite.exists_ne_map_eq_of_infinite`: Infinitely many pigeons in finitely many pigeonholes.
  Weak formulation.
* `Finite.exists_infinite_fiber`: Infinitely many pigeons in finitely many pigeonholes. Strong
  formulation.

Some more pigeonhole-like statements can be found in `Data.Fintype.CardEmbedding`.

Types which have an injection from/a surjection to an `Infinite` type are themselves `Infinite`.
See `Infinite.of_injective` and `Infinite.of_surjective`.

## Instances

We provide `Infinite` instances for
* specific types: `ℕ`, `ℤ`, `String`
* type constructors: `Multiset α`, `List α`

-/

open Function

open Nat

universe u v

variable {α β γ : Type _}

open Finset Function

namespace Fintype

/-- `card α` is the number of elements in `α`, defined when `α` is a fintype. -/
def card (α) [Fintype α] : ℕ :=
  (@univ α _).card
#align fintype.card Fintype.card

/-- There is (computably) an equivalence between `α` and `Fin (card α)`.

Since it is not unique and depends on which permutation
of the universe list is used, the equivalence is wrapped in `Trunc` to
preserve computability.

See `Fintype.equivFin` for the noncomputable version,
and `Fintype.truncEquivFinOfCardEq` and `Fintype.equivFinOfCardEq`
for an equiv `α ≃ Fin n` given `Fintype.card α = n`.

See `Fintype.truncFinBijection` for a version without `[DecidableEq α]`.
-/
def truncEquivFin (α) [DecidableEq α] [Fintype α] : Trunc (α ≃ Fin (card α)) := by
  unfold card Finset.card
  exact
    Quot.recOnSubsingleton'
      (motive := fun s : Multiset α =>
        (∀ x : α, x ∈ s) → s.Nodup → Trunc (α ≃ Fin (Multiset.card s)))
      univ.val
      (fun l (h : ∀ x : α, x ∈ l) (nd : l.Nodup) => Trunc.mk (nd.getEquivOfForallMemList _ h).symm)
      mem_univ_val univ.2
#align fintype.trunc_equiv_fin Fintype.truncEquivFin

/-- There is (noncomputably) an equivalence between `α` and `Fin (card α)`.

See `Fintype.truncEquivFin` for the computable version,
and `Fintype.truncEquivFinOfCardEq` and `Fintype.equivFinOfCardEq`
for an equiv `α ≃ Fin n` given `Fintype.card α = n`.
-/
noncomputable def equivFin (α) [Fintype α] : α ≃ Fin (card α) :=
  letI := Classical.decEq α
  (truncEquivFin α).out
#align fintype.equiv_fin Fintype.equivFin

/-- There is (computably) a bijection between `Fin (card α)` and `α`.

Since it is not unique and depends on which permutation
of the universe list is used, the bijection is wrapped in `Trunc` to
preserve computability.

See `Fintype.truncEquivFin` for a version that gives an equivalence
given `[DecidableEq α]`.
-/
def truncFinBijection (α) [Fintype α] : Trunc { f : Fin (card α) → α // Bijective f } := by
  unfold card Finset.card
  refine
    Quot.recOnSubsingleton'
      (motive := fun s : Multiset α =>
        (∀ x : α, x ∈ s) → s.Nodup → Trunc {f : Fin (Multiset.card s) → α // Bijective f})
      univ.val
      (fun l (h : ∀ x : α, x ∈ l) (nd : l.Nodup) => Trunc.mk (nd.getBijectionOfForallMemList _ h))
      mem_univ_val univ.2

#align fintype.trunc_fin_bijection Fintype.truncFinBijection

theorem subtype_card {p : α → Prop} (s : Finset α) (H : ∀ x : α, x ∈ s ↔ p x) :
    @card { x // p x } (Fintype.subtype s H) = s.card :=
  Multiset.card_pmap _ _ _
#align fintype.subtype_card Fintype.subtype_card

theorem card_of_subtype {p : α → Prop} (s : Finset α) (H : ∀ x : α, x ∈ s ↔ p x)
    [Fintype { x // p x }] : card { x // p x } = s.card := by
  rw [← subtype_card s H]
  congr
  apply Subsingleton.elim
#align fintype.card_of_subtype Fintype.card_of_subtype

@[simp]
theorem card_ofFinset {p : Set α} (s : Finset α) (H : ∀ x, x ∈ s ↔ x ∈ p) :
    @Fintype.card p (ofFinset s H) = s.card :=
  Fintype.subtype_card s H
#align fintype.card_of_finset Fintype.card_ofFinset

theorem card_of_finset' {p : Set α} (s : Finset α) (H : ∀ x, x ∈ s ↔ x ∈ p) [Fintype p] :
    Fintype.card p = s.card := by rw [← card_ofFinset s H]; congr; apply Subsingleton.elim
#align fintype.card_of_finset' Fintype.card_of_finset'

end Fintype

namespace Fintype

theorem ofEquiv_card [Fintype α] (f : α ≃ β) : @card β (ofEquiv α f) = card α :=
  Multiset.card_map _ _
#align fintype.of_equiv_card Fintype.ofEquiv_card

theorem card_congr {α β} [Fintype α] [Fintype β] (f : α ≃ β) : card α = card β := by
  rw [← ofEquiv_card f]; congr; apply Subsingleton.elim
#align fintype.card_congr Fintype.card_congr

@[congr]
theorem card_congr' {α β} [Fintype α] [Fintype β] (h : α = β) : card α = card β :=
  card_congr (by rw [h])
#align fintype.card_congr' Fintype.card_congr'

section

variable [Fintype α] [Fintype β]

/-- If the cardinality of `α` is `n`, there is computably a bijection between `α` and `Fin n`.

See `Fintype.equivFinOfCardEq` for the noncomputable definition,
and `Fintype.truncEquivFin` and `Fintype.equivFin` for the bijection `α ≃ Fin (card α)`.
-/
def truncEquivFinOfCardEq [DecidableEq α] {n : ℕ} (h : Fintype.card α = n) : Trunc (α ≃ Fin n) :=
  (truncEquivFin α).map fun e => e.trans (Fin.cast h).toEquiv
#align fintype.trunc_equiv_fin_of_card_eq Fintype.truncEquivFinOfCardEq

/-- If the cardinality of `α` is `n`, there is noncomputably a bijection between `α` and `Fin n`.

See `Fintype.truncEquivFinOfCardEq` for the computable definition,
and `Fintype.truncEquivFin` and `Fintype.equivFin` for the bijection `α ≃ Fin (card α)`.
-/
noncomputable def equivFinOfCardEq {n : ℕ} (h : Fintype.card α = n) : α ≃ Fin n :=
  letI := Classical.decEq α
  (truncEquivFinOfCardEq h).out
#align fintype.equiv_fin_of_card_eq Fintype.equivFinOfCardEq

/-- Two `fintype`s with the same cardinality are (computably) in bijection.

See `Fintype.equivOfCardEq` for the noncomputable version,
and `Fintype.truncEquivFinOfCardEq` and `Fintype.equivFinOfCardEq` for
the specialization to `Fin`.
-/
def truncEquivOfCardEq [DecidableEq α] [DecidableEq β] (h : card α = card β) : Trunc (α ≃ β) :=
  (truncEquivFinOfCardEq h).bind fun e => (truncEquivFin β).map fun e' => e.trans e'.symm
#align fintype.trunc_equiv_of_card_eq Fintype.truncEquivOfCardEq

/-- Two `Fintype`s with the same cardinality are (noncomputably) in bijection.

See `Fintype.truncEquivOfCardEq` for the computable version,
and `Fintype.truncEquivFinOfCardEq` and `Fintype.equivFinOfCardEq` for
the specialization to `Fin`.
-/
noncomputable def equivOfCardEq (h : card α = card β) : α ≃ β := by
  letI := Classical.decEq α
  letI := Classical.decEq β
  exact (truncEquivOfCardEq h).out
#align fintype.equiv_of_card_eq Fintype.equivOfCardEq

end

theorem card_eq {α β} [_F : Fintype α] [_G : Fintype β] : card α = card β ↔ Nonempty (α ≃ β) :=
  ⟨fun h =>
    haveI := Classical.propDecidable
    (truncEquivOfCardEq h).nonempty,
    fun ⟨f⟩ => card_congr f⟩
#align fintype.card_eq Fintype.card_eq

/-- Note: this lemma is specifically about `Fintype.ofSubsingleton`. For a statement about
arbitrary `Fintype` instances, use either `Fintype.card_le_one_iff_subsingleton` or
`Fintype.card_unique`. -/
@[simp]
theorem card_ofSubsingleton (a : α) [Subsingleton α] : @Fintype.card _ (ofSubsingleton a) = 1 :=
  rfl
#align fintype.card_of_subsingleton Fintype.card_ofSubsingleton

@[simp]
theorem card_unique [Unique α] [h : Fintype α] : Fintype.card α = 1 :=
  Subsingleton.elim (ofSubsingleton default) h ▸ card_ofSubsingleton _
#align fintype.card_unique Fintype.card_unique

/-- Note: this lemma is specifically about `Fintype.of_is_empty`. For a statement about
arbitrary `Fintype` instances, use `Fintype.card_eq_zero_iff`. -/
@[simp]
theorem card_of_isEmpty [IsEmpty α] : Fintype.card α = 0 :=
  rfl
#align fintype.card_of_is_empty Fintype.card_of_isEmpty

end Fintype

namespace Set

variable {s t : Set α}

-- We use an arbitrary `[Fintype s]` instance here,
-- not necessarily coming from a `[Fintype α]`.
@[simp]
theorem toFinset_card {α : Type _} (s : Set α) [Fintype s] : s.toFinset.card = Fintype.card s :=
  Multiset.card_map Subtype.val Finset.univ.val
#align set.to_finset_card Set.toFinset_card

end Set

theorem Finset.card_univ [Fintype α] : (Finset.univ : Finset α).card = Fintype.card α :=
  rfl
#align finset.card_univ Finset.card_univ

theorem Finset.eq_univ_of_card [Fintype α] (s : Finset α) (hs : s.card = Fintype.card α) :
    s = univ :=
  eq_of_subset_of_card_le (subset_univ _) <| by rw [hs, Finset.card_univ]
#align finset.eq_univ_of_card Finset.eq_univ_of_card

theorem Finset.card_eq_iff_eq_univ [Fintype α] (s : Finset α) :
    s.card = Fintype.card α ↔ s = Finset.univ :=
  ⟨s.eq_univ_of_card, by
    rintro rfl
    exact Finset.card_univ⟩
#align finset.card_eq_iff_eq_univ Finset.card_eq_iff_eq_univ

theorem Finset.card_le_univ [Fintype α] (s : Finset α) : s.card ≤ Fintype.card α :=
  card_le_of_subset (subset_univ s)
#align finset.card_le_univ Finset.card_le_univ

theorem Finset.card_lt_univ_of_not_mem [Fintype α] {s : Finset α} {x : α} (hx : x ∉ s) :
    s.card < Fintype.card α :=
  card_lt_card ⟨subset_univ s, not_forall.2 ⟨x, fun hx' => hx (hx' <| mem_univ x)⟩⟩
#align finset.card_lt_univ_of_not_mem Finset.card_lt_univ_of_not_mem

theorem Finset.card_lt_iff_ne_univ [Fintype α] (s : Finset α) :
    s.card < Fintype.card α ↔ s ≠ Finset.univ :=
  s.card_le_univ.lt_iff_ne.trans (not_congr s.card_eq_iff_eq_univ)
#align finset.card_lt_iff_ne_univ Finset.card_lt_iff_ne_univ

theorem Finset.card_compl_lt_iff_nonempty [Fintype α] [DecidableEq α] (s : Finset α) :
    sᶜ.card < Fintype.card α ↔ s.Nonempty :=
  sᶜ.card_lt_iff_ne_univ.trans s.compl_ne_univ_iff_nonempty
#align finset.card_compl_lt_iff_nonempty Finset.card_compl_lt_iff_nonempty

theorem Finset.card_univ_diff [DecidableEq α] [Fintype α] (s : Finset α) :
    (Finset.univ \ s).card = Fintype.card α - s.card :=
  Finset.card_sdiff (subset_univ s)
#align finset.card_univ_diff Finset.card_univ_diff

theorem Finset.card_compl [DecidableEq α] [Fintype α] (s : Finset α) :
    sᶜ.card = Fintype.card α - s.card :=
  Finset.card_univ_diff s
#align finset.card_compl Finset.card_compl

theorem Fintype.card_compl_set [Fintype α] (s : Set α) [Fintype s] [Fintype (↥(sᶜ) : Sort _)] :
    Fintype.card (↥(sᶜ) : Sort _) = Fintype.card α - Fintype.card s := by
  classical rw [← Set.toFinset_card, ← Set.toFinset_card, ← Finset.card_compl, Set.toFinset_compl]
#align fintype.card_compl_set Fintype.card_compl_set

@[simp]
theorem Fintype.card_fin (n : ℕ) : Fintype.card (Fin n) = n :=
  List.length_finRange n
#align fintype.card_fin Fintype.card_fin

@[simp]
theorem Finset.card_fin (n : ℕ) : Finset.card (Finset.univ : Finset (Fin n)) = n := by
  rw [Finset.card_univ, Fintype.card_fin]
#align finset.card_fin Finset.card_fin

/-- `Fin` as a map from `ℕ` to `Type` is injective. Note that since this is a statement about
equality of types, using it should be avoided if possible. -/
theorem fin_injective : Function.Injective Fin := fun m n h =>
  (Fintype.card_fin m).symm.trans <| (Fintype.card_congr <| Equiv.cast h).trans (Fintype.card_fin n)
#align fin_injective fin_injective

/-- A reversed version of `Fin.cast_eq_cast` that is easier to rewrite with. -/
theorem Fin.cast_eq_cast' {n m : ℕ} (h : Fin n = Fin m) :
    _root_.cast h = ⇑(Fin.cast <| fin_injective h) := by
  cases fin_injective h
  rfl
#align fin.cast_eq_cast' Fin.cast_eq_cast'

theorem card_finset_fin_le {n : ℕ} (s : Finset (Fin n)) : s.card ≤ n := by
  simpa only [Fintype.card_fin] using s.card_le_univ
#align card_finset_fin_le card_finset_fin_le

theorem Fin.equiv_iff_eq {m n : ℕ} : Nonempty (Fin m ≃ Fin n) ↔ m = n :=
  ⟨fun ⟨h⟩ => by simpa using Fintype.card_congr h, fun h => ⟨Equiv.cast <| h ▸ rfl⟩⟩
#align fin.equiv_iff_eq Fin.equiv_iff_eq

--@[simp] Porting note: simp can prove it
theorem Fintype.card_subtype_eq (y : α) [Fintype { x // x = y }] :
    Fintype.card { x // x = y } = 1 :=
  Fintype.card_unique
#align fintype.card_subtype_eq Fintype.card_subtype_eq

--@[simp] Porting note: simp can prove it
theorem Fintype.card_subtype_eq' (y : α) [Fintype { x // y = x }] :
    Fintype.card { x // y = x } = 1 :=
  Fintype.card_unique
#align fintype.card_subtype_eq' Fintype.card_subtype_eq'

@[simp]
theorem Fintype.card_empty : Fintype.card Empty = 0 :=
  rfl
#align fintype.card_empty Fintype.card_empty

@[simp]
theorem Fintype.card_pempty : Fintype.card PEmpty = 0 :=
  rfl
#align fintype.card_pempty Fintype.card_pempty

theorem Fintype.card_unit : Fintype.card Unit = 1 :=
  rfl
#align fintype.card_unit Fintype.card_unit

@[simp]
theorem Fintype.card_punit : Fintype.card PUnit = 1 :=
  rfl
#align fintype.card_punit Fintype.card_punit

@[simp]
theorem Fintype.card_bool : Fintype.card Bool = 2 :=
  rfl
#align fintype.card_bool Fintype.card_bool

@[simp]
theorem Fintype.card_ulift (α : Type _) [Fintype α] : Fintype.card (ULift α) = Fintype.card α :=
  Fintype.ofEquiv_card _
#align fintype.card_ulift Fintype.card_ulift

@[simp]
theorem Fintype.card_plift (α : Type _) [Fintype α] : Fintype.card (PLift α) = Fintype.card α :=
  Fintype.ofEquiv_card _
#align fintype.card_plift Fintype.card_plift

@[simp]
theorem Fintype.card_orderDual (α : Type _) [Fintype α] : Fintype.card αᵒᵈ = Fintype.card α :=
  rfl
#align fintype.card_order_dual Fintype.card_orderDual

@[simp]
theorem Fintype.card_lex (α : Type _) [Fintype α] : Fintype.card (Lex α) = Fintype.card α :=
  rfl
#align fintype.card_lex Fintype.card_lex

/-- Given that `α ⊕ β` is a fintype, `α` is also a fintype. This is non-computable as it uses
that `Sum.inl` is an injection, but there's no clear inverse if `α` is empty. -/
noncomputable def Fintype.sumLeft {α β} [Fintype (Sum α β)] : Fintype α :=
  Fintype.ofInjective (Sum.inl : α → Sum α β) Sum.inl_injective
#align fintype.sum_left Fintype.sumLeft

/-- Given that `α ⊕ β` is a fintype, `β` is also a fintype. This is non-computable as it uses
that `Sum.inr` is an injection, but there's no clear inverse if `β` is empty. -/
noncomputable def Fintype.sumRight {α β} [Fintype (Sum α β)] : Fintype β :=
  Fintype.ofInjective (Sum.inr : β → Sum α β) Sum.inr_injective
#align fintype.sum_right Fintype.sumRight

/-!
### Relation to `Finite`

In this section we prove that `α : Type _` is `Finite` if and only if `Fintype α` is nonempty.
-/

-- @[nolint fintype_finite] -- Porting note: do we need this
protected theorem Fintype.finite {α : Type _} (_inst : Fintype α) : Finite α :=
  ⟨Fintype.equivFin α⟩
#align fintype.finite Fintype.finite

/-- For efficiency reasons, we want `Finite` instances to have higher
priority than ones coming from `Fintype` instances. -/
-- @[nolint fintype_finite] -- Porting note: do we need this
instance (priority := 900) Finite.of_fintype (α : Type _) [Fintype α] : Finite α :=
  Fintype.finite ‹_›
#align finite.of_fintype Finite.of_fintype

theorem finite_iff_nonempty_fintype (α : Type _) : Finite α ↔ Nonempty (Fintype α) :=
  ⟨fun h =>
    let ⟨_k, ⟨e⟩⟩ := @Finite.exists_equiv_fin α h
    ⟨Fintype.ofEquiv _ e.symm⟩,
    fun ⟨_⟩ => inferInstance⟩
#align finite_iff_nonempty_fintype finite_iff_nonempty_fintype

/-- See also `nonempty_encodable`, `nonempty_denumerable`. -/
theorem nonempty_fintype (α : Type _) [Finite α] : Nonempty (Fintype α) :=
  (finite_iff_nonempty_fintype α).mp ‹_›
#align nonempty_fintype nonempty_fintype

/-- Noncomputably get a `Fintype` instance from a `Finite` instance. This is not an
instance because we want `Fintype` instances to be useful for computations. -/
noncomputable def Fintype.ofFinite (α : Type _) [Finite α] : Fintype α :=
  (nonempty_fintype α).some
#align fintype.of_finite Fintype.ofFinite

theorem Finite.of_injective {α β : Sort _} [Finite β] (f : α → β) (H : Injective f) : Finite α := by
  cases nonempty_fintype (PLift β)
  rw [← Equiv.injective_comp Equiv.plift f, ← Equiv.comp_injective _ Equiv.plift.symm] at H
  haveI := Fintype.ofInjective _ H
  exact Finite.of_equiv _ Equiv.plift
#align finite.of_injective Finite.of_injective

theorem Finite.of_surjective {α β : Sort _} [Finite α] (f : α → β) (H : Surjective f) : Finite β :=
  Finite.of_injective _ <| injective_surjInv H
#align finite.of_surjective Finite.of_surjective

theorem Finite.exists_univ_list (α) [Finite α] : ∃ l : List α, l.Nodup ∧ ∀ x : α, x ∈ l := by
  cases nonempty_fintype α
  obtain ⟨l, e⟩ := Quotient.exists_rep (@univ α _).1
  have := And.intro (@univ α _).2 (@mem_univ_val α _)
  exact ⟨_, by rwa [← e] at this⟩
#align finite.exists_univ_list Finite.exists_univ_list

theorem List.Nodup.length_le_card {α : Type _} [Fintype α] {l : List α} (h : l.Nodup) :
    l.length ≤ Fintype.card α := by
  classical exact List.toFinset_card_of_nodup h ▸ l.toFinset.card_le_univ
#align list.nodup.length_le_card List.Nodup.length_le_card

namespace Fintype

variable [Fintype α] [Fintype β]

theorem card_le_of_injective (f : α → β) (hf : Function.Injective f) : card α ≤ card β :=
  Finset.card_le_card_of_inj_on f (fun _ _ => Finset.mem_univ _) fun _ _ _ _ h => hf h
#align fintype.card_le_of_injective Fintype.card_le_of_injective

theorem card_le_of_embedding (f : α ↪ β) : card α ≤ card β :=
  card_le_of_injective f f.2
#align fintype.card_le_of_embedding Fintype.card_le_of_embedding

theorem card_lt_of_injective_of_not_mem (f : α → β) (h : Function.Injective f) {b : β}
    (w : b ∉ Set.range f) : card α < card β :=
  calc
    card α = (univ.map ⟨f, h⟩).card := (card_map _).symm
    _ < card β :=
      Finset.card_lt_univ_of_not_mem <| by rwa [← mem_coe, coe_map, coe_univ, Set.image_univ]

#align fintype.card_lt_of_injective_of_not_mem Fintype.card_lt_of_injective_of_not_mem

theorem card_lt_of_injective_not_surjective (f : α → β) (h : Function.Injective f)
    (h' : ¬Function.Surjective f) : card α < card β :=
  let ⟨_y, hy⟩ := not_forall.1 h'
  card_lt_of_injective_of_not_mem f h hy
#align fintype.card_lt_of_injective_not_surjective Fintype.card_lt_of_injective_not_surjective

theorem card_le_of_surjective (f : α → β) (h : Function.Surjective f) : card β ≤ card α :=
  card_le_of_injective _ (Function.injective_surjInv h)
#align fintype.card_le_of_surjective Fintype.card_le_of_surjective

theorem card_range_le {α β : Type _} (f : α → β) [Fintype α] [Fintype (Set.range f)] :
    Fintype.card (Set.range f) ≤ Fintype.card α :=
  Fintype.card_le_of_surjective (fun a => ⟨f a, by simp⟩) fun ⟨_, a, ha⟩ => ⟨a, by simpa using ha⟩
#align fintype.card_range_le Fintype.card_range_le

theorem card_range {α β F : Type _} [EmbeddingLike F α β] (f : F) [Fintype α]
    [Fintype (Set.range f)] : Fintype.card (Set.range f) = Fintype.card α :=
  Eq.symm <| Fintype.card_congr <| Equiv.ofInjective _ <| EmbeddingLike.injective f
#align fintype.card_range Fintype.card_range

/-- The pigeonhole principle for finitely many pigeons and pigeonholes.
This is the `Fintype` version of `Finset.exists_ne_map_eq_of_card_lt_of_maps_to`.
-/
theorem exists_ne_map_eq_of_card_lt (f : α → β) (h : Fintype.card β < Fintype.card α) :
    ∃ x y, x ≠ y ∧ f x = f y :=
  let ⟨x, _, y, _, h⟩ := Finset.exists_ne_map_eq_of_card_lt_of_maps_to h fun x _ => mem_univ (f x)
  ⟨x, y, h⟩
#align fintype.exists_ne_map_eq_of_card_lt Fintype.exists_ne_map_eq_of_card_lt

theorem card_eq_one_iff : card α = 1 ↔ ∃ x : α, ∀ y, y = x := by
  rw [← card_unit, card_eq]
  exact
    ⟨fun ⟨a⟩ => ⟨a.symm (), fun y => a.injective (Subsingleton.elim _ _)⟩,
     fun ⟨x, hx⟩ =>
      ⟨⟨fun _ => (), fun _ => x, fun _ => (hx _).trans (hx _).symm, fun _ =>
          Subsingleton.elim _ _⟩⟩⟩
#align fintype.card_eq_one_iff Fintype.card_eq_one_iff

theorem card_eq_zero_iff : card α = 0 ↔ IsEmpty α := by
  rw [card, Finset.card_eq_zero, univ_eq_empty_iff]
#align fintype.card_eq_zero_iff Fintype.card_eq_zero_iff

theorem card_eq_one_iff_nonempty_unique : card α = 1 ↔ Nonempty (Unique α) :=
  ⟨fun h =>
    let ⟨d, h⟩ := Fintype.card_eq_one_iff.mp h
    ⟨{  default := d
        uniq := h }⟩,
    fun ⟨_h⟩ => Fintype.card_unique⟩
#align fintype.card_eq_one_iff_nonempty_unique Fintype.card_eq_one_iff_nonempty_unique

/-- A `Fintype` with cardinality zero is equivalent to `Empty`. -/
def cardEqZeroEquivEquivEmpty : card α = 0 ≃ (α ≃ Empty) :=
  (Equiv.ofIff card_eq_zero_iff).trans (Equiv.equivEmptyEquiv α).symm
#align fintype.card_eq_zero_equiv_equiv_empty Fintype.cardEqZeroEquivEquivEmpty

theorem card_pos_iff : 0 < card α ↔ Nonempty α :=
  pos_iff_ne_zero.trans <| not_iff_comm.mp <| not_nonempty_iff.trans card_eq_zero_iff.symm
#align fintype.card_pos_iff Fintype.card_pos_iff

theorem card_pos [h : Nonempty α] : 0 < card α :=
  card_pos_iff.mpr h
#align fintype.card_pos Fintype.card_pos

theorem card_ne_zero [Nonempty α] : card α ≠ 0 :=
  _root_.ne_of_gt card_pos
#align fintype.card_ne_zero Fintype.card_ne_zero

instance [Nonempty α] : NeZero (card α) := ⟨card_ne_zero⟩

theorem card_le_one_iff : card α ≤ 1 ↔ ∀ a b : α, a = b :=
  let n := card α
  have hn : n = card α := rfl
  match n, hn with
  | 0, ha =>
    ⟨fun _h => fun a => (card_eq_zero_iff.1 ha.symm).elim a, fun _ => ha ▸ Nat.le_succ _⟩
  | 1, ha =>
    ⟨fun _h => fun a b => by
      let ⟨x, hx⟩ := card_eq_one_iff.1 ha.symm
      rw [hx a, hx b], fun _ => ha ▸ le_rfl⟩
  | n + 2, ha =>
    ⟨fun h => False.elim $ by rw [← ha] at h; cases h with | step h => cases h; done, fun h =>
      card_unit ▸ card_le_of_injective (fun _ => ()) fun _ _ _ => h _ _⟩
#align fintype.card_le_one_iff Fintype.card_le_one_iff

theorem card_le_one_iff_subsingleton : card α ≤ 1 ↔ Subsingleton α :=
  card_le_one_iff.trans subsingleton_iff.symm
#align fintype.card_le_one_iff_subsingleton Fintype.card_le_one_iff_subsingleton

theorem one_lt_card_iff_nontrivial : 1 < card α ↔ Nontrivial α := by
  classical
    rw [← not_iff_not]
    push_neg
    rw [not_nontrivial_iff_subsingleton, card_le_one_iff_subsingleton]
#align fintype.one_lt_card_iff_nontrivial Fintype.one_lt_card_iff_nontrivial

theorem exists_ne_of_one_lt_card (h : 1 < card α) (a : α) : ∃ b : α, b ≠ a :=
  haveI : Nontrivial α := one_lt_card_iff_nontrivial.1 h
  exists_ne a
#align fintype.exists_ne_of_one_lt_card Fintype.exists_ne_of_one_lt_card

theorem exists_pair_of_one_lt_card (h : 1 < card α) : ∃ a b : α, a ≠ b :=
  haveI : Nontrivial α := one_lt_card_iff_nontrivial.1 h
  exists_pair_ne α
#align fintype.exists_pair_of_one_lt_card Fintype.exists_pair_of_one_lt_card

theorem card_eq_one_of_forall_eq {i : α} (h : ∀ j, j = i) : card α = 1 :=
  Fintype.card_eq_one_iff.2 ⟨i, h⟩
#align fintype.card_eq_one_of_forall_eq Fintype.card_eq_one_of_forall_eq

theorem one_lt_card [h : Nontrivial α] : 1 < Fintype.card α :=
  Fintype.one_lt_card_iff_nontrivial.mpr h
#align fintype.one_lt_card Fintype.one_lt_card

theorem one_lt_card_iff : 1 < card α ↔ ∃ a b : α, a ≠ b :=
  one_lt_card_iff_nontrivial.trans nontrivial_iff
#align fintype.one_lt_card_iff Fintype.one_lt_card_iff

nonrec theorem two_lt_card_iff : 2 < card α ↔ ∃ a b c : α, a ≠ b ∧ a ≠ c ∧ b ≠ c := by
  simp_rw [← Finset.card_univ, two_lt_card_iff, mem_univ, true_and_iff]
#align fintype.two_lt_card_iff Fintype.two_lt_card_iff

theorem card_of_bijective {f : α → β} (hf : Bijective f) : card α = card β :=
  card_congr (Equiv.ofBijective f hf)
#align fintype.card_of_bijective Fintype.card_of_bijective

end Fintype

namespace Finite

variable [Finite α]

-- Porting note: new theorem
theorem surjective_of_injective {f : α → α} (hinj : Injective f) : Surjective f := by
  intro x
  have := Classical.propDecidable
  cases nonempty_fintype α
  have h₁ : image f univ = univ :=
    eq_of_subset_of_card_le (subset_univ _)
      ((card_image_of_injective univ hinj).symm ▸ le_rfl)
  have h₂ : x ∈ image f univ := h₁.symm ▸ mem_univ x
  obtain ⟨y, h⟩ := mem_image.1 h₂
  exact ⟨y, h.2⟩

theorem injective_iff_surjective {f : α → α} : Injective f ↔ Surjective f :=
  ⟨surjective_of_injective, fun hsurj =>
    HasLeftInverse.injective ⟨surjInv hsurj, leftInverse_of_surjective_of_rightInverse
      (surjective_of_injective (injective_surjInv _))
      (rightInverse_surjInv _)⟩⟩
#align finite.injective_iff_surjective Finite.injective_iff_surjective

theorem injective_iff_bijective {f : α → α} : Injective f ↔ Bijective f := by
  simp [Bijective, injective_iff_surjective]
#align finite.injective_iff_bijective Finite.injective_iff_bijective

theorem surjective_iff_bijective {f : α → α} : Surjective f ↔ Bijective f := by
  simp [Bijective, injective_iff_surjective]
#align finite.surjective_iff_bijective Finite.surjective_iff_bijective

theorem injective_iff_surjective_of_equiv {f : α → β} (e : α ≃ β) : Injective f ↔ Surjective f :=
  have : Injective (e.symm ∘ f) ↔ Surjective (e.symm ∘ f) := injective_iff_surjective
  ⟨fun hinj => by
    simpa [Function.comp] using e.surjective.comp (this.1 (e.symm.injective.comp hinj)),
    fun hsurj => by
    simpa [Function.comp] using e.injective.comp (this.2 (e.symm.surjective.comp hsurj))⟩
#align finite.injective_iff_surjective_of_equiv Finite.injective_iff_surjective_of_equiv

alias injective_iff_bijective ↔ _root_.Function.Injective.bijective_of_finite _
#align function.injective.bijective_of_finite Function.Injective.bijective_of_finite

alias surjective_iff_bijective ↔ _root_.Function.Surjective.bijective_of_finite _
#align function.surjective.bijective_of_finite Function.Surjective.bijective_of_finite

alias injective_iff_surjective_of_equiv ↔
  _root_.Function.Injective.surjective_of_fintype _root_.Function.Surjective.injective_of_fintype
#align function.injective.surjective_of_fintype Function.Injective.surjective_of_fintype
#align function.surjective.injective_of_fintype Function.Surjective.injective_of_fintype

end Finite

namespace Fintype

variable [Fintype α] [Fintype β]

theorem bijective_iff_injective_and_card (f : α → β) :
    Bijective f ↔ Injective f ∧ card α = card β :=
  ⟨fun h => ⟨h.1, card_of_bijective h⟩, fun h =>
    ⟨h.1, h.1.surjective_of_fintype <| equivOfCardEq h.2⟩⟩
#align fintype.bijective_iff_injective_and_card Fintype.bijective_iff_injective_and_card

theorem bijective_iff_surjective_and_card (f : α → β) :
    Bijective f ↔ Surjective f ∧ card α = card β :=
  ⟨fun h => ⟨h.2, card_of_bijective h⟩, fun h =>
    ⟨h.1.injective_of_fintype <| equivOfCardEq h.2, h.1⟩⟩
#align fintype.bijective_iff_surjective_and_card Fintype.bijective_iff_surjective_and_card

theorem _root_.Function.LeftInverse.rightInverse_of_card_le {f : α → β} {g : β → α}
    (hfg : LeftInverse f g) (hcard : card α ≤ card β) : RightInverse f g :=
  have hsurj : Surjective f := surjective_iff_hasRightInverse.2 ⟨g, hfg⟩
  rightInverse_of_injective_of_leftInverse
    ((bijective_iff_surjective_and_card _).2
        ⟨hsurj, le_antisymm hcard (card_le_of_surjective f hsurj)⟩).1
    hfg
#align function.left_inverse.right_inverse_of_card_le Function.LeftInverse.rightInverse_of_card_le

theorem _root_.Function.RightInverse.leftInverse_of_card_le {f : α → β} {g : β → α}
    (hfg : RightInverse f g) (hcard : card β ≤ card α) : LeftInverse f g :=
  Function.LeftInverse.rightInverse_of_card_le hfg hcard
#align function.right_inverse.left_inverse_of_card_le Function.RightInverse.leftInverse_of_card_le

end Fintype

namespace Equiv

variable [Fintype α] [Fintype β]

open Fintype

/-- Construct an equivalence from functions that are inverse to each other. -/
@[simps]
def ofLeftInverseOfCardLe (hβα : card β ≤ card α) (f : α → β) (g : β → α) (h : LeftInverse g f) :
    α ≃ β where
  toFun := f
  invFun := g
  left_inv := h
  right_inv := h.rightInverse_of_card_le hβα
#align equiv.of_left_inverse_of_card_le Equiv.ofLeftInverseOfCardLe
#align equiv.of_left_inverse_of_card_le_symm_apply Equiv.ofLeftInverseOfCardLe_symm_apply
#align equiv.of_left_inverse_of_card_le_apply Equiv.ofLeftInverseOfCardLe_apply

/-- Construct an equivalence from functions that are inverse to each other. -/
@[simps]
def ofRightInverseOfCardLe (hαβ : card α ≤ card β) (f : α → β) (g : β → α) (h : RightInverse g f) :
    α ≃ β where
  toFun := f
  invFun := g
  left_inv := h.leftInverse_of_card_le hαβ
  right_inv := h
#align equiv.of_right_inverse_of_card_le Equiv.ofRightInverseOfCardLe
#align equiv.of_right_inverse_of_card_le_symm_apply Equiv.ofRightInverseOfCardLe_symm_apply
#align equiv.of_right_inverse_of_card_le_apply Equiv.ofRightInverseOfCardLe_apply

end Equiv

@[simp]
theorem Fintype.card_coe (s : Finset α) [Fintype s] : Fintype.card s = s.card :=
  @Fintype.card_of_finset' _ _ _ (fun _ => Iff.rfl) (id _)
#align fintype.card_coe Fintype.card_coe

/-- Noncomputable equivalence between a finset `s` coerced to a type and `Fin s.card`. -/
noncomputable def Finset.equivFin (s : Finset α) : s ≃ Fin s.card :=
  Fintype.equivFinOfCardEq (Fintype.card_coe _)
#align finset.equiv_fin Finset.equivFin

/-- Noncomputable equivalence between a finset `s` as a fintype and `Fin n`, when there is a
proof that `s.card = n`. -/
noncomputable def Finset.equivFinOfCardEq {s : Finset α} {n : ℕ} (h : s.card = n) : s ≃ Fin n :=
  Fintype.equivFinOfCardEq ((Fintype.card_coe _).trans h)
#align finset.equiv_fin_of_card_eq Finset.equivFinOfCardEq

/-- Noncomputable equivalence between two finsets `s` and `t` as fintypes when there is a proof
that `s.card = t.card`.-/
noncomputable def Finset.equivOfCardEq {s t : Finset α} (h : s.card = t.card) : s ≃ t :=
  Fintype.equivOfCardEq ((Fintype.card_coe _).trans (h.trans (Fintype.card_coe _).symm))
#align finset.equiv_of_card_eq Finset.equivOfCardEq

@[simp]
theorem Fintype.card_Prop : Fintype.card Prop = 2 :=
  rfl
#align fintype.card_Prop Fintype.card_Prop

theorem set_fintype_card_le_univ [Fintype α] (s : Set α) [Fintype s] :
    Fintype.card s ≤ Fintype.card α :=
  Fintype.card_le_of_embedding (Function.Embedding.subtype s)
#align set_fintype_card_le_univ set_fintype_card_le_univ

theorem set_fintype_card_eq_univ_iff [Fintype α] (s : Set α) [Fintype s] :
    Fintype.card s = Fintype.card α ↔ s = Set.univ := by
  rw [← Set.toFinset_card, Finset.card_eq_iff_eq_univ, ← Set.toFinset_univ, Set.toFinset_inj]
#align set_fintype_card_eq_univ_iff set_fintype_card_eq_univ_iff

namespace Function.Embedding

/-- An embedding from a `Fintype` to itself can be promoted to an equivalence. -/
noncomputable def equivOfFintypeSelfEmbedding [Finite α] (e : α ↪ α) : α ≃ α :=
  Equiv.ofBijective e e.2.bijective_of_finite
#align function.embedding.equiv_of_fintype_self_embedding Function.Embedding.equivOfFintypeSelfEmbedding

@[simp]
theorem equiv_of_fintype_self_embedding_to_embedding [Finite α] (e : α ↪ α) :
    e.equivOfFintypeSelfEmbedding.toEmbedding = e := by
  ext
  rfl
#align function.embedding.equiv_of_fintype_self_embedding_to_embedding Function.Embedding.equiv_of_fintype_self_embedding_to_embedding

/-- If `‖β‖ < ‖α‖` there are no embeddings `α ↪ β`.
This is a formulation of the pigeonhole principle.

Note this cannot be an instance as it needs `h`. -/
@[simp]
theorem is_empty_of_card_lt [Fintype α] [Fintype β] (h : Fintype.card β < Fintype.card α) :
    IsEmpty (α ↪ β) :=
  ⟨fun f =>
    let ⟨_x, _y, ne, feq⟩ := Fintype.exists_ne_map_eq_of_card_lt f h
    ne <| f.injective feq⟩
#align function.embedding.is_empty_of_card_lt Function.Embedding.is_empty_of_card_lt

/-- A constructive embedding of a fintype `α` in another fintype `β` when `card α ≤ card β`. -/
def truncOfCardLe [Fintype α] [Fintype β] [DecidableEq α] [DecidableEq β]
    (h : Fintype.card α ≤ Fintype.card β) : Trunc (α ↪ β) :=
  (Fintype.truncEquivFin α).bind fun ea =>
    (Fintype.truncEquivFin β).map fun eb =>
      ea.toEmbedding.trans ((Fin.castLe h).toEmbedding.trans eb.symm.toEmbedding)
#align function.embedding.trunc_of_card_le Function.Embedding.truncOfCardLe

theorem nonempty_of_card_le [Fintype α] [Fintype β] (h : Fintype.card α ≤ Fintype.card β) :
    Nonempty (α ↪ β) := by classical exact (truncOfCardLe h).nonempty
#align function.embedding.nonempty_of_card_le Function.Embedding.nonempty_of_card_le

theorem nonempty_iff_card_le [Fintype α] [Fintype β] :
    Nonempty (α ↪ β) ↔ Fintype.card α ≤ Fintype.card β :=
  ⟨fun ⟨e⟩ => Fintype.card_le_of_embedding e, nonempty_of_card_le⟩
#align function.embedding.nonempty_iff_card_le Function.Embedding.nonempty_iff_card_le

theorem exists_of_card_le_finset [Fintype α] {s : Finset β} (h : Fintype.card α ≤ s.card) :
    ∃ f : α ↪ β, Set.range f ⊆ s := by
  rw [← Fintype.card_coe] at h
  rcases nonempty_of_card_le h with ⟨f⟩
  exact ⟨f.trans (Embedding.subtype _), by simp [Set.range_subset_iff]⟩
#align function.embedding.exists_of_card_le_finset Function.Embedding.exists_of_card_le_finset

end Function.Embedding

@[simp]
theorem Finset.univ_map_embedding {α : Type _} [Fintype α] (e : α ↪ α) : univ.map e = univ := by
  rw [← e.equiv_of_fintype_self_embedding_to_embedding, univ_map_equiv_to_embedding]
#align finset.univ_map_embedding Finset.univ_map_embedding

namespace Fintype

theorem card_lt_of_surjective_not_injective [Fintype α] [Fintype β] (f : α → β)
    (h : Function.Surjective f) (h' : ¬Function.Injective f) : card β < card α :=
  card_lt_of_injective_not_surjective _ (Function.injective_surjInv h) fun hg =>
    have w : Function.Bijective (Function.surjInv h) := ⟨Function.injective_surjInv h, hg⟩
    h' <| h.injective_of_fintype (Equiv.ofBijective _ w).symm
#align fintype.card_lt_of_surjective_not_injective Fintype.card_lt_of_surjective_not_injective

end Fintype

theorem Fintype.card_subtype_le [Fintype α] (p : α → Prop) [DecidablePred p] :
    Fintype.card { x // p x } ≤ Fintype.card α :=
  Fintype.card_le_of_embedding (Function.Embedding.subtype _)
#align fintype.card_subtype_le Fintype.card_subtype_le

theorem Fintype.card_subtype_lt [Fintype α] {p : α → Prop} [DecidablePred p] {x : α} (hx : ¬p x) :
    Fintype.card { x // p x } < Fintype.card α :=
  Fintype.card_lt_of_injective_of_not_mem (↑) Subtype.coe_injective <| by
    rwa [Subtype.range_coe_subtype]
#align fintype.card_subtype_lt Fintype.card_subtype_lt

theorem Fintype.card_subtype [Fintype α] (p : α → Prop) [DecidablePred p] :
    Fintype.card { x // p x } = ((Finset.univ : Finset α).filter p).card := by
  refine' Fintype.card_of_subtype _ _
  simp
#align fintype.card_subtype Fintype.card_subtype

@[simp]
theorem Fintype.card_subtype_compl [Fintype α] (p : α → Prop) [Fintype { x // p x }]
    [Fintype { x // ¬p x }] :
    Fintype.card { x // ¬p x } = Fintype.card α - Fintype.card { x // p x } := by
  classical
    rw [Fintype.card_of_subtype (Set.toFinset (pᶜ)), Set.toFinset_compl p,
      Finset.card_compl, Fintype.card_of_subtype (Set.toFinset p)] <;>
    · intro
      simp only [Set.mem_toFinset, Set.mem_compl_iff]
      rfl
#align fintype.card_subtype_compl Fintype.card_subtype_compl

theorem Fintype.card_subtype_mono (p q : α → Prop) (h : p ≤ q) [Fintype { x // p x }]
    [Fintype { x // q x }] : Fintype.card { x // p x } ≤ Fintype.card { x // q x } :=
  Fintype.card_le_of_embedding (Subtype.impEmbedding _ _ h)
#align fintype.card_subtype_mono Fintype.card_subtype_mono

/-- If two subtypes of a fintype have equal cardinality, so do their complements. -/
theorem Fintype.card_compl_eq_card_compl [Finite α] (p q : α → Prop) [Fintype { x // p x }]
    [Fintype { x // ¬p x }] [Fintype { x // q x }] [Fintype { x // ¬q x }]
    (h : Fintype.card { x // p x } = Fintype.card { x // q x }) :
    Fintype.card { x // ¬p x } = Fintype.card { x // ¬q x } :=
  by
  cases nonempty_fintype α
  simp only [Fintype.card_subtype_compl, h]
#align fintype.card_compl_eq_card_compl Fintype.card_compl_eq_card_compl

theorem Fintype.card_quotient_le [Fintype α] (s : Setoid α)
    [DecidableRel ((· ≈ ·) : α → α → Prop)] : Fintype.card (Quotient s) ≤ Fintype.card α :=
  Fintype.card_le_of_surjective _ (surjective_quotient_mk _)
#align fintype.card_quotient_le Fintype.card_quotient_le

theorem Fintype.card_quotient_lt [Fintype α] {s : Setoid α} [DecidableRel ((· ≈ ·) : α → α → Prop)]
    {x y : α} (h1 : x ≠ y) (h2 : x ≈ y) : Fintype.card (Quotient s) < Fintype.card α :=
  Fintype.card_lt_of_surjective_not_injective _ (surjective_quotient_mk _) fun w =>
    h1 (w <| Quotient.eq.mpr h2)
#align fintype.card_quotient_lt Fintype.card_quotient_lt

theorem univ_eq_singleton_of_card_one {α} [Fintype α] (x : α) (h : Fintype.card α = 1) :
    (univ : Finset α) = {x} := by
  symm
  apply eq_of_subset_of_card_le (subset_univ {x})
  apply le_of_eq
  simp [h, Finset.card_univ]
#align univ_eq_singleton_of_card_one univ_eq_singleton_of_card_one

namespace Finite

variable [Finite α]

theorem wellFounded_of_trans_of_irrefl (r : α → α → Prop) [IsTrans α r] [IsIrrefl α r] :
    WellFounded r := by
  classical
  cases nonempty_fintype α;
  exact
    have :
      ∀ x y, r x y → (univ.filter fun z => r z x).card < (univ.filter fun z => r z y).card :=
      fun x y hxy =>
      Finset.card_lt_card <| by
        simp only [Finset.lt_iff_ssubset.symm, lt_iff_le_not_le, Finset.le_iff_subset,
            Finset.subset_iff, mem_filter, true_and_iff, mem_univ, hxy];
        exact
          ⟨fun z hzx => _root_.trans hzx hxy,
            not_forall_of_exists_not ⟨x, not_imp.2 ⟨hxy, irrefl x⟩⟩⟩
    Subrelation.wf (this _ _) (measure _).wf
#align finite.well_founded_of_trans_of_irrefl Finite.wellFounded_of_trans_of_irrefl

theorem Preorder.wellFounded_lt [Preorder α] : WellFounded ((· < ·) : α → α → Prop) :=
  wellFounded_of_trans_of_irrefl _
#align finite.preorder.well_founded_lt Finite.Preorder.wellFounded_lt

theorem Preorder.wellFounded_gt [Preorder α] : WellFounded ((· > ·) : α → α → Prop) :=
  wellFounded_of_trans_of_irrefl _
#align finite.preorder.well_founded_gt Finite.Preorder.wellFounded_gt

instance (priority := 10) LinearOrder.isWellOrder_lt [LinearOrder α] : IsWellOrder α (· < ·)
    where wf := Preorder.wellFounded_lt
#align finite.linear_order.is_well_order_lt Finite.LinearOrder.isWellOrder_lt

instance (priority := 10) LinearOrder.isWellOrder_gt [LinearOrder α] : IsWellOrder α (· > ·)
    where wf := Preorder.wellFounded_gt
#align finite.linear_order.is_well_order_gt Finite.LinearOrder.isWellOrder_gt

end Finite

-- @[nolint fintype_finite] -- Porting note: do we need this?
protected theorem Fintype.false [Infinite α] (_h : Fintype α) : False :=
  not_finite α
#align fintype.false Fintype.false

@[simp]
theorem is_empty_fintype {α : Type _} : IsEmpty (Fintype α) ↔ Infinite α :=
  ⟨fun ⟨h⟩ => ⟨fun h' => (@nonempty_fintype α h').elim h⟩, fun ⟨h⟩ => ⟨fun h' => h h'.finite⟩⟩
#align is_empty_fintype is_empty_fintype

/-- A non-infinite type is a fintype. -/
noncomputable def fintypeOfNotInfinite {α : Type _} (h : ¬Infinite α) : Fintype α :=
  @Fintype.ofFinite _ (not_infinite_iff_finite.mp h)
#align fintype_of_not_infinite fintypeOfNotInfinite

section

open Classical

/-- Any type is (classically) either a `Fintype`, or `Infinite`.

One can obtain the relevant typeclasses via `cases fintype_or_infinite α; resetI`.
-/
noncomputable def fintypeOrInfinite (α : Type _) : PSum (Fintype α) (Infinite α) :=
  if h : Infinite α then PSum.inr h else PSum.inl (fintypeOfNotInfinite h)
#align fintype_or_infinite fintypeOrInfinite

end

theorem Finset.exists_minimal {α : Type _} [Preorder α] (s : Finset α) (h : s.Nonempty) :
    ∃ m ∈ s, ∀ x ∈ s, ¬x < m := by
  obtain ⟨c, hcs : c ∈ s⟩ := h
  have : WellFounded (@LT.lt { x // x ∈ s } _) := Finite.wellFounded_of_trans_of_irrefl _
  obtain ⟨⟨m, hms : m ∈ s⟩, -, H⟩ := this.has_min Set.univ ⟨⟨c, hcs⟩, trivial⟩
  exact ⟨m, hms, fun x hx hxm => H ⟨x, hx⟩ trivial hxm⟩
#align finset.exists_minimal Finset.exists_minimal

theorem Finset.exists_maximal {α : Type _} [Preorder α] (s : Finset α) (h : s.Nonempty) :
    ∃ m ∈ s, ∀ x ∈ s, ¬m < x :=
  @Finset.exists_minimal αᵒᵈ _ s h
#align finset.exists_maximal Finset.exists_maximal

namespace Infinite

theorem of_not_fintype (h : Fintype α → False) : Infinite α :=
  is_empty_fintype.mp ⟨h⟩
#align infinite.of_not_fintype Infinite.of_not_fintype

/-- If `s : Set α` is a proper subset of `α` and `f : α → s` is injective, then `α` is infinite. -/
theorem of_injective_to_set {s : Set α} (hs : s ≠ Set.univ) {f : α → s} (hf : Injective f) :
    Infinite α :=
  of_not_fintype fun h => by
    skip
    classical
      refine' lt_irrefl (Fintype.card α) _
      calc
        Fintype.card α ≤ Fintype.card s := Fintype.card_le_of_injective f hf
        _ = s.toFinset.card := s.toFinset_card.symm
        _ < Fintype.card α :=
          Finset.card_lt_card <| by rwa [Set.toFinset_ssubset_univ, Set.ssubset_univ_iff]

#align infinite.of_injective_to_set Infinite.of_injective_to_set

/-- If `s : Set α` is a proper subset of `α` and `f : s → α` is surjective, then `α` is infinite. -/
theorem of_surjective_from_set {s : Set α} (hs : s ≠ Set.univ) {f : s → α} (hf : Surjective f) :
    Infinite α :=
  of_injective_to_set hs (injective_surjInv hf)
#align infinite.of_surjective_from_set Infinite.of_surjective_from_set

theorem exists_not_mem_finset [Infinite α] (s : Finset α) : ∃ x, x ∉ s :=
  not_forall.1 fun h => Fintype.false ⟨s, h⟩
#align infinite.exists_not_mem_finset Infinite.exists_not_mem_finset

-- see Note [lower instance priority]
instance (priority := 100) (α : Type _) [H : Infinite α] : Nontrivial α :=
  ⟨let ⟨x, _hx⟩ := exists_not_mem_finset (∅ : Finset α)
    let ⟨y, hy⟩ := exists_not_mem_finset ({x} : Finset α)
    ⟨y, x, by simpa only [mem_singleton] using hy⟩⟩

protected theorem nonempty (α : Type _) [Infinite α] : Nonempty α := by infer_instance
#align infinite.nonempty Infinite.nonempty

theorem of_injective {α β} [Infinite β] (f : β → α) (hf : Injective f) : Infinite α :=
  ⟨fun _I => (Finite.of_injective f hf).false⟩
#align infinite.of_injective Infinite.of_injective

theorem of_surjective {α β} [Infinite β] (f : α → β) (hf : Surjective f) : Infinite α :=
  ⟨fun _I => (Finite.of_surjective f hf).false⟩
#align infinite.of_surjective Infinite.of_surjective

end Infinite

instance : Infinite ℕ :=
  Infinite.of_not_fintype <| by
    intro h
    exact (Finset.range _).card_le_univ.not_lt ((Nat.lt_succ_self _).trans_eq (card_range _).symm)

instance Int.infinite : Infinite ℤ :=
  Infinite.of_injective Int.ofNat fun _ _ => Int.ofNat.inj

instance [Nonempty α] : Infinite (Multiset α) :=
  let ⟨x⟩ := ‹Nonempty α›
  Infinite.of_injective (fun n => Multiset.replicate n x) (Multiset.replicate_left_injective _)

instance [Nonempty α] : Infinite (List α) :=
  Infinite.of_surjective ((↑) : List α → Multiset α) (surjective_quot_mk _)

instance String.infinite : Infinite String :=
  Infinite.of_injective (String.mk) <| by
    intro _ _ h
    cases h with
    | refl => rfl

instance Infinite.set [Infinite α] : Infinite (Set α) :=
  Infinite.of_injective singleton Set.singleton_injective
#align infinite.set Infinite.set

instance [Infinite α] : Infinite (Finset α) :=
  Infinite.of_injective singleton Finset.singleton_injective

instance [Infinite α] : Infinite (Option α) :=
  Infinite.of_injective some (Option.some_injective α)

instance Sum.infinite_of_left [Infinite α] : Infinite (Sum α β) :=
  Infinite.of_injective Sum.inl Sum.inl_injective
#align sum.infinite_of_left Sum.infinite_of_left

instance Sum.infinite_of_right [Infinite β] : Infinite (Sum α β) :=
  Infinite.of_injective Sum.inr Sum.inr_injective
#align sum.infinite_of_right Sum.infinite_of_right

instance Prod.infinite_of_right [Nonempty α] [Infinite β] : Infinite (α × β) :=
  Infinite.of_surjective Prod.snd Prod.snd_surjective
#align prod.infinite_of_right Prod.infinite_of_right

instance Prod.infinite_of_left [Infinite α] [Nonempty β] : Infinite (α × β) :=
  Infinite.of_surjective Prod.fst Prod.fst_surjective
#align prod.infinite_of_left Prod.infinite_of_left

namespace Infinite

private noncomputable def natEmbeddingAux (α : Type _) [Infinite α] : ℕ → α
  | n =>
    letI := Classical.decEq α
    Classical.choose
      (exists_not_mem_finset
        ((Multiset.range n).pmap (fun m (hm : m < n) => natEmbeddingAux _ m) fun _ =>
            Multiset.mem_range.1).toFinset)

-- Porting note: new theorem, to work around missing `wlog`
private theorem natEmbeddingAux_injective_aux (α : Type _) [Infinite α] (m n : ℕ)
  (h : Infinite.natEmbeddingAux α m = Infinite.natEmbeddingAux α n) (hmn : m < n) : m = n := by
  letI := Classical.decEq α
  exfalso
  refine'
    (Classical.choose_spec
        (exists_not_mem_finset
          ((Multiset.range n).pmap (fun m (_hm : m < n) => natEmbeddingAux α m) fun _ =>
              Multiset.mem_range.1).toFinset))
      _
  refine' Multiset.mem_toFinset.2 (Multiset.mem_pmap.2 ⟨m, Multiset.mem_range.2 hmn, _⟩)
  rw [h, natEmbeddingAux]

private theorem natEmbeddingAux_injective (α : Type _) [Infinite α] :
    Function.Injective (natEmbeddingAux α) := by
  rintro m n h
  letI := Classical.decEq α
  rcases lt_trichotomy m n with hmn | rfl | hnm
  · apply natEmbeddingAux_injective_aux α m n h hmn
  · rfl
  · apply (natEmbeddingAux_injective_aux α n m h.symm hnm).symm

/-- Embedding of `ℕ` into an infinite type. -/
noncomputable def natEmbedding (α : Type _) [Infinite α] : ℕ ↪ α :=
  ⟨_, natEmbeddingAux_injective α⟩
#align infinite.nat_embedding Infinite.natEmbedding

/-- See `Infinite.exists_superset_card_eq` for a version that, for a `s : Finset α`,
provides a superset `t : finset α`, `s ⊆ t` such that `t.card` is fixed. -/
theorem exists_subset_card_eq (α : Type _) [Infinite α] (n : ℕ) : ∃ s : Finset α, s.card = n :=
  ⟨(range n).map (natEmbedding α), by rw [card_map, card_range]⟩
#align infinite.exists_subset_card_eq Infinite.exists_subset_card_eq

/-- See `Infinite.exists_subset_card_eq` for a version that provides an arbitrary
`s : Finset α` for any cardinality. -/
theorem exists_superset_card_eq [Infinite α] (s : Finset α) (n : ℕ) (hn : s.card ≤ n) :
    ∃ t : Finset α, s ⊆ t ∧ t.card = n :=
  by
  induction' n with n IH generalizing s
  · exact ⟨s, subset_refl _, Nat.eq_zero_of_le_zero hn⟩
  · cases' hn.eq_or_lt with hn' hn'
    · exact ⟨s, subset_refl _, hn'⟩
    obtain ⟨t, hs, ht⟩ := IH _ (Nat.le_of_lt_succ hn')
    obtain ⟨x, hx⟩ := exists_not_mem_finset t
    refine' ⟨Finset.cons x t hx, hs.trans (Finset.subset_cons _), _⟩
    simp [hx, ht]
#align infinite.exists_superset_card_eq Infinite.exists_superset_card_eq

end Infinite

/-- If every finset in a type has bounded cardinality, that type is finite. -/
noncomputable def fintypeOfFinsetCardLe {ι : Type _} (n : ℕ) (w : ∀ s : Finset ι, s.card ≤ n) :
    Fintype ι := by
  apply fintypeOfNotInfinite
  intro i
  obtain ⟨s, c⟩ := Infinite.exists_subset_card_eq ι (n + 1)
  specialize w s
  rw [c] at w
  exact Nat.not_succ_le_self n w
#align fintype_of_finset_card_le fintypeOfFinsetCardLe

theorem not_injective_infinite_finite {α β} [Infinite α] [Finite β] (f : α → β) : ¬Injective f :=
  fun hf => (Finite.of_injective f hf).false
#align not_injective_infinite_finite not_injective_infinite_finite

/-- The pigeonhole principle for infinitely many pigeons in finitely many pigeonholes. If there are
infinitely many pigeons in finitely many pigeonholes, then there are at least two pigeons in the
same pigeonhole.

See also: `Fintype.exists_ne_map_eq_of_card_lt`, `Finite.exists_infinite_fiber`.
-/
theorem Finite.exists_ne_map_eq_of_infinite {α β} [Infinite α] [Finite β] (f : α → β) :
    ∃ x y : α, x ≠ y ∧ f x = f y := by
  simpa only [Injective, not_forall, not_imp, and_comm] using not_injective_infinite_finite f
#align finite.exists_ne_map_eq_of_infinite Finite.exists_ne_map_eq_of_infinite

instance Function.Embedding.is_empty {α β} [Infinite α] [Finite β] : IsEmpty (α ↪ β) :=
  ⟨fun f => not_injective_infinite_finite f f.2⟩
#align function.embedding.is_empty Function.Embedding.is_empty

/-- The strong pigeonhole principle for infinitely many pigeons in
finitely many pigeonholes.  If there are infinitely many pigeons in
finitely many pigeonholes, then there is a pigeonhole with infinitely
many pigeons.

See also: `Finite.exists_ne_map_eq_of_infinite`
-/
theorem Finite.exists_infinite_fiber [Infinite α] [Finite β] (f : α → β) :
    ∃ y : β, Infinite (f ⁻¹' {y}) := by
  classical
    by_contra' hf
    cases nonempty_fintype β
    haveI := fun y => fintypeOfNotInfinite <| hf y
    let key : Fintype α :=
      { elems := univ.bunionᵢ fun y : β => (f ⁻¹' {y}).toFinset
        complete := by simp }
    exact key.false
#align finite.exists_infinite_fiber Finite.exists_infinite_fiber

theorem not_surjective_finite_infinite {α β} [Finite α] [Infinite β] (f : α → β) : ¬Surjective f :=
  fun hf => (Infinite.of_surjective f hf).not_finite ‹_›
#align not_surjective_finite_infinite not_surjective_finite_infinite

section Trunc

/-- A `Fintype` with positive cardinality constructively contains an element.
-/
def truncOfCardPos {α} [Fintype α] (h : 0 < Fintype.card α) : Trunc α :=
  letI := Fintype.card_pos_iff.mp h
  truncOfNonemptyFintype α
#align trunc_of_card_pos truncOfCardPos

end Trunc

/-- A custom induction principle for fintypes. The base case is a subsingleton type,
and the induction step is for non-trivial types, and one can assume the hypothesis for
smaller types (via `Fintype.card`).

The major premise is `Fintype α`, so to use this with the `induction` tactic you have to give a name
to that instance and use that name.
-/
@[elab_as_elim]
theorem Fintype.induction_subsingleton_or_nontrivial {P : ∀ (α) [Fintype α], Prop} (α : Type _)
    [Fintype α] (hbase : ∀ (α) [Fintype α] [Subsingleton α], P α)
    (hstep :
      ∀ (α) [Fintype α] [Nontrivial α],
        ∀ _ih : ∀ (β) [Fintype β], ∀ _h : Fintype.card β < Fintype.card α, P β, P α) :
    P α := by
  obtain ⟨n, hn⟩ : ∃ n, Fintype.card α = n := ⟨Fintype.card α, rfl⟩
  induction' n using Nat.strong_induction_on with n ih generalizing α
  cases' subsingleton_or_nontrivial α with hsing hnontriv
  · apply hbase
  · apply hstep
    intro β _ hlt
    rw [hn] at hlt
    exact ih (Fintype.card β) hlt _ rfl
#align fintype.induction_subsingleton_or_nontrivial Fintype.induction_subsingleton_or_nontrivial

namespace Tactic

--open Positivity

private theorem card_univ_pos (α : Type _) [Fintype α] [Nonempty α] :
    0 < (Finset.univ : Finset α).card :=
  Finset.univ_nonempty.card_pos

--Porting note: not porting meta code yet
-- /-- Extension for the `positivity` tactic: `finset.card s` is positive if `s` is nonempty. -/
-- @[positivity]
-- unsafe def positivity_finset_card : expr → tactic strictness
--   | q(Finset.card $(s)) => do
--     let p
--       ←-- TODO: Partial decision procedure for `finset.nonempty`
--             to_expr
--             ``(Finset.Nonempty $(s)) >>=
--           find_assumption
--     positive <$> mk_app `` Finset.Nonempty.card_pos [p]
--   | q(@Fintype.card $(α) $(i)) => positive <$> mk_mapp `` Fintype.card_pos [α, i, none]
--   | e =>
--     pp e >>=
--       fail ∘
--       format.bracket "The expression `" "` isn't of the form `finset.card s` or `fintype.card α`"
-- #align tactic.positivity_finset_card tactic.positivity_finset_card

end Tactic


def proper_subset :
  ∀ { α : Type },
    set α → set α → Prop :=
  λ α x y, forall (e : α),
    (e ∈ x → e ∈ y) ∧ (∃ f, f ∈ y ∧ f ∉ x)

example :
  ∀ a b c : ℕ, a = b → b = c → a = c
:=
begin
intros a b c,
assume ab bc,
rewrite ab,
rw bc, -- shorthand
-- and rw does rfl for us
end

example :
  ∀ a b c : ℕ, a = b → b = c → a = c
:=
begin
intros a b c,
assume ab bc,
rewrite ←bc,
rw ←ab,
end

example : ∀ n : ℕ, true :=
begin
assume n,
cases n,  -- whoa, that's cool
trivial,
trivial,
end

example : ∀ P Q : Prop, P ∨ Q → true :=
begin
intros P Q,
assume h,
cases h, -- whoa, now I get it!
trivial,
trivial
end

example : 4 = 5 → 0 = 1 :=
begin
assume four_equals_five,
cases four_equals_five, --whoa!
end

example :
proper_subset
  { 1, 3 }
  { n | ∃ m, n = 2 * m + 1 }
:=
begin
unfold proper_subset,
intro o,
split,
assume h,

cases h,
apply exists.intro 1,
assumption,

cases h,
apply exists.intro 0,
assumption,

cases h,
apply exists.intro 5,

split,
apply exists.intro 2,
exact rfl,

intro h,
cases h,
cases h,
cases h,
cases h,
cases h,
end

lemma quiz : proper_subset { 1, 2 } { n : nat | true } :=
begin
unfold proper_subset,
assume n,
split,
assume f,
trivial,
apply exists.intro 5,
split,
trivial,
assume fn12,
cases fn12,
cases fn12,
cases fn12,
cases fn12,
cases fn12,
end


open classical
local attribute [instance] classical.prop_decidable

lemma Proof_1 (A B : Prop) : A → ¬ (¬ A ∧ B) :=
begin
    intro ha,
    by_contradiction,
    apply and.left a,
    apply ha
end

-- Respuestas para Proof_2: Notar que siempre se puede hacer mas corto de lo que mostramos aqui.
-- Version granular
lemma Proof_2_1 (A B : Prop) : (¬ A ∧ ¬ B) → ¬ (A ∨ B) :=
begin
    intro h1,
    intro haob,
    apply or.elim haob,
        intro ha,
        apply (and.left h1),
        apply ha,
        intro hb,
        apply and.right h1,
        apply hb
end

-- Version compacta (viable)
lemma Proof_2_2 (A B C D : Prop) : (¬ A ∧ ¬ B) → ¬ (A ∨ B) :=
begin
    intro h1,
    by_contradiction h2,
    apply or.elim h2,
        intro ha,
        apply ((and.left h1) ha),
        intro hb,
        apply ((and.right h1) hb)
end

lemma Proof_3 (A B C : Prop) : A ∧ (B ∨ C) → (A ∧ B) ∨ (A ∧ C) :=
begin
    intro h,
    apply (or.elim (and.right h)),
        intro hb,
            apply or.inl,
            apply and.intro,
                apply (and.left h),
                apply hb,
        intro hc,
            apply or.inr,
            apply and.intro,
                apply (and.left h),
                apply hc
end


/-
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
-/
import data.pfunctor.multivariate.basic

/-!
# Multivariate quotients of polynomial functors.

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

Basic definition of multivariate QPF. QPFs form a compositional framework
for defining inductive and coinductive types, their quotients and nesting.

The idea is based on building ever larger functors. For instance, we can define
a list using a shape functor:

```lean
inductive list_shape (a b : Type)
| nil : list_shape
| cons : a -> b -> list_shape
```

This shape can itself be decomposed as a sum of product which are themselves
QPFs. It follows that the shape is a QPF and we can take its fixed point
and create the list itself:

```lean
def list (a : Type) := fix list_shape a -- not the actual notation
```

We can continue and define the quotient on permutation of lists and create
the multiset type:

```lean
def multiset (a : Type) := qpf.quot list.perm list a -- not the actual notion
```

And `multiset` is also a QPF. We can then create a novel data type (for Lean):

```lean
inductive tree (a : Type)
| node : a -> multiset tree -> tree
```

An unordered tree. This is currently not supported by Lean because it nests
an inductive type inside of a quotient. We can go further and define
unordered, possibly infinite trees:

```lean
coinductive tree' (a : Type)
| node : a -> multiset tree' -> tree'
```

by using the `cofix` construct. Those options can all be mixed and
matched because they preserve the properties of QPF. The latter example,
`tree'`, combines fixed point, co-fixed point and quotients.

## Related modules

 * constructions
   * fix
   * cofix
   * quot
   * comp
   * sigma / pi
   * prj
   * const

each proves that some operations on functors preserves the QPF structure

## Reference

 * [Jeremy Avigad, Mario M. Carneiro and Simon Hudon, *Data Types as Quotients of Polynomial Functors*][avigad-carneiro-hudon2019]
-/

universe u

open_locale mvfunctor

/--
Multivariate quotients of polynomial functors.
-/
class mvqpf {n : ℕ} (F : typevec.{u} n → Type*) [mvfunctor F] :=
(P         : mvpfunctor.{u} n)
(abs       : Π {α}, P.obj α → F α)
(repr      : Π {α}, F α → P.obj α)
(abs_repr  : ∀ {α} (x : F α), abs (repr x) = x)
(abs_map   : ∀ {α β} (f : α ⟹ β) (p : P.obj α), abs (f <$$> p) = f <$$> abs p)

namespace mvqpf
variables {n : ℕ} {F : typevec.{u} n → Type*} [mvfunctor F] [q : mvqpf F]
include q
open mvfunctor (liftp liftr)

/-!
### Show that every mvqpf is a lawful mvfunctor.
-/

protected theorem id_map {α : typevec n} (x : F α) : typevec.id <$$> x = x :=
by { rw ←abs_repr x, cases repr x with a f, rw [←abs_map], reflexivity }

@[simp] theorem comp_map {α β γ : typevec n} (f : α ⟹ β) (g : β ⟹ γ) (x : F α) :
  (g ⊚ f) <$$> x = g <$$> f <$$> x :=
by { rw ←abs_repr x, cases repr x with a f, rw [←abs_map, ←abs_map, ←abs_map], reflexivity }

@[priority 100]
instance is_lawful_mvfunctor : is_lawful_mvfunctor F :=
{ id_map := @mvqpf.id_map n F _ _,
  comp_map := @comp_map n F _ _ }

/- Lifting predicates and relations -/

theorem liftp_iff {α : typevec n} (p : Π ⦃i⦄, α i → Prop) (x : F α) :
  liftp p x ↔ ∃ a f, x = abs ⟨a, f⟩ ∧ ∀ i j, p (f i j) :=
begin
  split,
  { rintros ⟨y, hy⟩, cases h : repr y with a f,
    use [a, λ i j, (f i j).val], split,
    { rw [←hy, ←abs_repr y, h, ←abs_map], reflexivity },
    intros i j, apply (f i j).property },
  rintros ⟨a, f, h₀, h₁⟩, dsimp at *,
  use abs (⟨a, λ i j, ⟨f i j, h₁ i j⟩⟩),
  rw [←abs_map, h₀], reflexivity
end

theorem liftr_iff {α : typevec n} (r : Π ⦃i⦄, α i → α i → Prop) (x y : F α) :
  liftr r x y ↔ ∃ a f₀ f₁, x = abs ⟨a, f₀⟩ ∧ y = abs ⟨a, f₁⟩ ∧ ∀ i j, r (f₀ i j) (f₁ i j) :=
begin
  split,
  { rintros ⟨u, xeq, yeq⟩, cases h : repr u with a f,
    use [a, λ i j, (f i j).val.fst, λ i j, (f i j).val.snd],
    split, { rw [←xeq, ←abs_repr u, h, ←abs_map], refl },
    split, { rw [←yeq, ←abs_repr u, h, ←abs_map], refl },
    intros i j, exact (f i j).property },
  rintros ⟨a, f₀, f₁, xeq, yeq, h⟩,
  use abs ⟨a, λ i j, ⟨(f₀ i j, f₁ i j), h i j⟩⟩,
  dsimp, split,
  { rw [xeq, ←abs_map], refl },
  rw [yeq, ←abs_map], refl
end

open set
open mvfunctor

theorem mem_supp {α : typevec n} (x : F α) (i) (u : α i) :
  u ∈ supp x i ↔ ∀ a f, abs ⟨a, f⟩ = x → u ∈ f i '' univ :=
begin
  rw [supp], dsimp, split,
  { intros h a f haf,
    have : liftp (λ i u, u ∈ f i '' univ) x,
    { rw liftp_iff, refine ⟨a, f, haf.symm, _⟩,
      intros i u, exact mem_image_of_mem _ (mem_univ _) },
    exact h this },
  intros h p, rw liftp_iff,
  rintros ⟨a, f, xeq, h'⟩,
  rcases h a f xeq.symm with ⟨i, _, hi⟩,
  rw ←hi, apply h'
end

theorem supp_eq {α : typevec n} {i} (x : F α) :
  supp x i = { u | ∀ a f, abs ⟨a, f⟩ = x → u ∈ f i '' univ } :=
by ext; apply mem_supp

theorem has_good_supp_iff {α : typevec n} (x : F α) :
  (∀ p, liftp p x ↔ ∀ i (u ∈ supp x i), p i u) ↔
    ∃ a f, abs ⟨a, f⟩ = x ∧ ∀ i a' f', abs ⟨a', f'⟩ = x → f i '' univ ⊆ f' i '' univ :=
begin
  split,
  { intros h,
    have : liftp (supp x) x, by { rw h, introv, exact id, },
    rw liftp_iff at this, rcases this with ⟨a, f, xeq, h'⟩,
    refine ⟨a, f, xeq.symm, _⟩,
    intros a' f' h'',
    rintros hu u ⟨j, h₂, hfi⟩,
    have hh : u ∈ supp x a', by rw ←hfi; apply h',
    refine (mem_supp x _ u).mp hh _ _ hu, },
  rintros ⟨a, f, xeq, h⟩ p, rw liftp_iff, split,
  { rintros ⟨a', f', xeq', h'⟩ i u usuppx,
    rcases (mem_supp x _ u).mp @usuppx a' f' xeq'.symm with ⟨i, _, f'ieq⟩,
    rw ←f'ieq, apply h' },
  intro h',
  refine ⟨a, f, xeq.symm, _⟩, intros j y,
  apply h', rw mem_supp,
  intros a' f' xeq',
  apply h _ a' f' xeq',
  apply mem_image_of_mem _ (mem_univ _)
end

variable (q)

/-- A qpf is said to be uniform if every polynomial functor
representing a single value all have the same range. -/
def is_uniform : Prop := ∀ ⦃α : typevec n⦄ (a a' : q.P.A)
    (f : q.P.B a ⟹ α) (f' : q.P.B a' ⟹ α),
  abs ⟨a, f⟩ = abs ⟨a', f'⟩ → ∀ i, f i '' univ = f' i '' univ

/-- does `abs` preserve `liftp`? -/
def liftp_preservation : Prop :=
∀ ⦃α : typevec n⦄ (p : Π ⦃i⦄, α i → Prop) (x : q.P.obj α), liftp p (abs x) ↔ liftp p x

/-- does `abs` preserve `supp`? -/
def supp_preservation : Prop :=
∀ ⦃α⦄ (x : q.P.obj α), supp (abs x) = supp x

variable [q]

theorem supp_eq_of_is_uniform (h : q.is_uniform) {α : typevec n} (a : q.P.A) (f : q.P.B a ⟹ α) :
  ∀ i, supp (abs ⟨a, f⟩) i = f i '' univ :=
begin
  intro, ext u, rw [mem_supp], split,
  { intro h', apply h' _ _ rfl },
  intros h' a' f' e,
  rw [←h _ _ _ _ e.symm], apply h'
end

theorem liftp_iff_of_is_uniform (h : q.is_uniform) {α : typevec n} (x : F α) (p : Π i, α i → Prop) :
  liftp p x ↔ ∀ i (u ∈ supp x i), p i u :=
begin
  rw [liftp_iff, ←abs_repr x],
  cases repr x with a f,  split,
  { rintros ⟨a', f', abseq, hf⟩ u,
    rw [supp_eq_of_is_uniform h, h _ _ _ _ abseq],
    rintros b ⟨i, _, hi⟩, rw ←hi, apply hf },
  intro h',
  refine ⟨a, f, rfl, λ _ i, h' _ _ _⟩,
  rw supp_eq_of_is_uniform h,
  exact ⟨i, mem_univ i, rfl⟩
end

theorem supp_map (h : q.is_uniform) {α β : typevec n} (g : α ⟹ β) (x : F α) (i) :
  supp (g <$$> x) i = g i '' supp x i :=
begin
  rw ←abs_repr x, cases repr x with a f, rw [←abs_map, mvpfunctor.map_eq],
  rw [supp_eq_of_is_uniform h, supp_eq_of_is_uniform h, ← image_comp],
  refl,
end

theorem supp_preservation_iff_uniform :
  q.supp_preservation ↔ q.is_uniform :=
begin
  split,
  { intros h α a a' f f' h' i,
    rw [← mvpfunctor.supp_eq,← mvpfunctor.supp_eq,← h,h',h] },
  { rintros h α ⟨a,f⟩, ext, rwa [supp_eq_of_is_uniform,mvpfunctor.supp_eq], }
end

theorem liftp_preservation_iff_uniform :
  q.liftp_preservation ↔ q.is_uniform :=
by rw [← supp_preservation_iff_liftp_preservation, supp_preservation_iff_uniform]

end mvqpf


import data.nat.modeq data.nat.basic data.nat.prime data.int.basic tactic.norm_num
def prime : ℤ → Prop := λ x,nat.prime (int.nat_abs x)

theorem prime_dvd_mul {p m n : ℤ} (pp : prime p) : p ∣ m * n ↔ p ∣ m ∨ p ∣ n :=begin
    have H:int.nat_abs p ∣int.nat_abs m * int.nat_abs n ↔ int.nat_abs p ∣ int.nat_abs m ∨ int.nat_abs p ∣int.nat_abs n:=begin
        unfold prime at pp,revert pp, exact nat.prime.dvd_mul,end,
    rw [←int.coe_nat_dvd,←int.coe_nat_dvd,←int.coe_nat_dvd,int.coe_nat_mul,int.nat_abs_dvd,int.nat_abs_dvd,int.nat_abs_dvd,
    ←int.abs_eq_nat_abs,←int.abs_eq_nat_abs] at H,cases lt_trichotomy m 0 with Hm Hm,
    cases lt_trichotomy n 0 with Hn Hn,rwa[abs_of_neg Hm,abs_of_neg Hn,dvd_neg,dvd_neg,neg_mul_neg] at H,
    cases Hn with Hn Hn,rw Hn,norm_num,rwa[abs_of_neg Hm,abs_of_pos Hn,dvd_neg,←neg_mul_eq_neg_mul,dvd_neg] at H,
    cases Hm with Hm Hm,rw Hm,simp,cases lt_trichotomy n 0 with Hn Hn,rwa[abs_of_neg Hn,abs_of_pos Hm,dvd_neg,mul_neg_eq_neg_mul_symm,dvd_neg] at H,
    cases Hn with Hn Hn,rw Hn,simp,rwa[abs_of_pos Hn,abs_of_pos Hm] at H,
end
theorem dioph_identity:∀ a b p q:ℤ, (a*a+b*b)*(p*p+q*q)=(a*p+b*q)*(a*p+b*q)+(a*q-b*p)*(a*q-b*p):=begin
    intros,rw[mul_add,mul_add,add_mul,add_mul,add_mul,add_mul,mul_sub,sub_mul,sub_mul],norm_num,
end
theorem lemma_1 : ∀ a b p q : ℤ,∃ x y:ℤ, x*x+y*y=(a*a+b*b)*(p*p+q*q):=begin
    intros,existsi [(a*p+b*q),(a*q-b*p)],
    rw [mul_add,mul_add,add_mul,add_mul,add_mul,add_mul,mul_sub,sub_mul,sub_mul],norm_num,
end

theorem lemma_2 : ∀ (a b p q :ℤ), prime (p*p+q*q)→ (p*p+q*q) ∣ (a*a + b*b) → ∃ x y:ℤ,(x*x+y*y)*(p*p+q*q)=(a*a+b*b):=begin
    intros a b p q H1 H2,
    have H3:(p*p+q*q) ∣ (b*p-a*q)*(b*p+a*q):=begin
        rw[mul_add,sub_mul,sub_mul,add_sub],
        have H3:a * q * (b * p) =b * p * (a * q):=by norm_num,
        rw H3,rw sub_add_cancel,clear H3,
        have H3:b * p * (b * p) - a * q * (a * q)=(p*p)*(a*a+b*b)-(a*a)*(p*p+q*q):=by rw[mul_add,mul_add];norm_num,
        rw H3,exact dvd_sub (dvd_mul_of_dvd_right H2 _) (dvd_mul_left _ _),
    end,
    rw prime_dvd_mul H1 at H3,revert a b p q H1 H2 H3,
    have H:∀ a b p q:ℤ,prime (p * p + q * q)→p * p + q * q ∣ a * a + b * b→ p * p + q * q ∣ b * p - a * q→∃ (x y : ℤ), (x * x + y * y) * (p * p + q * q) = a * a + b * b:=begin
        assume a b p q H1 H2 H3,
        have H4:=dioph_identity b a q p,
        have H5:=dvd_mul_left (p * p + q * q) (b * b + a * a),rw [add_comm (p*p),H4,add_comm (q*q)] at H5,
        have H6:=iff.elim_right (dvd_add_iff_left (dvd_mul_of_dvd_right H3 (b * p - a * q))) H5,clear  H5,
        have H7:=mul_dvd_mul H3 H3, have H8:=exists_eq_mul_left_of_dvd H3,cases H8 with c Hc,
        cases exists_eq_mul_left_of_dvd H2 with d Hd,
        have H10:(b * b + a * a) * (q * q + p * p) = d*  (q * q + p * p) * (q * q + p * p):=begin rw[add_comm(b*b),Hd],simp,end,rw H10 at H4,clear H10,
        have H10:=dvd_mul_left ((q * q + p * p) * (q * q + p * p) ) d,
        rw[←mul_assoc,H4,add_comm (q*q),←dvd_add_iff_left H7] at H10,have H11:= dvd_of_mul_left_dvd H10,rw prime_dvd_mul at H11,simp at H11,
        cases exists_eq_mul_left_of_dvd H11 with e He,rw [add_comm(q*q),←Hd] at H4,
        existsi [c,e],clear H10 H2 H6 H3 H7 Hd d,
        suffices :(c * c + e * e) * (p * p + q * q) * (p * p + q * q) = (a * a + b * b) * (p * p + q * q),
        have H3:(p*p + q*q)≠0:=begin intro,unfold prime at H1,rw a_1 at H1,revert H1,simp [int.nat_abs_zero,nat.prime,(dec_trivial:¬0≥2)],end,
        have H2:(c * c + e * e) * (p * p + q * q) * (p * p + q * q) / (p * p + q * q)= (a * a + b * b) * (p * p + q * q) / (p * p + q * q):=by rw this,
        rwa[int.mul_div_cancel ((c * c + e * e) * (p * p + q * q)) H3,int.mul_div_cancel (a * a + b * b) H3] at H2,rw H4,
        have H12:(c * c + e * e) * (p * p + q * q) * (p * p + q * q) = (c * (p * p + q * q))*(c * (p * p + q * q))+ (e * (p * p + q * q))*(e * (p * p + q * q)):=begin
            rw [add_mul _ _ (p * p + q * q),add_mul _ _ (p * p + q * q)],norm_num,end,
        rw [H12,←Hc,←He],norm_num,assumption,
    end,intros a b p q H1 H2 H3,cases H3 with H3 H3,exact H a b p q H1 H2 H3,
    have H4:p * p + q * q ∣ -a * -a + b * b:=by rwa neg_mul_neg,
    have H5:p * p + q * q ∣ b * p - -a * q:=by revert H3;simp;assumption,
    have H6:=H (-a) b p q H1 H4 H5,rwa neg_mul_neg at H6,
end

open list
open nat
theorem squares_nat_int{a:ℕ}:(∃ x y:ℤ, x*x+y*y = ↑a)→∃x y:ℕ, x*x+y*y = a:=begin
    simp,assume x y hxy,existsi [(int.nat_abs x),int.nat_abs y],rw [←int.coe_nat_eq_coe_nat_iff,int.coe_nat_add,int.coe_nat_mul,int.coe_nat_mul],
    rwa[←int.abs_eq_nat_abs,←int.abs_eq_nat_abs, abs_mul_abs_self,abs_mul_abs_self],
end
theorem lemma_3:∀ n x:ℕ,x∣n→(¬∃x₁ x₂, x=x₁ *x₁+x₂ * x₂)→∃ p:ℕ,(p*x)∣n∧(¬∃p₁ p₂:ℕ,(p₁*p₁+p₂*p₂)=p):=begin
    have: ∀ (L:list ℕ) (x a b:ℕ),x * prod L = a*a+b*b →(∀ p:ℕ,p∈L→nat.prime p)→x∣prod L→(∀ x₁ x₂:ℕ, x≠x₁ *x₁+x₂ * x₂)→∃ p:ℕ,(p*x)∣prod L∧(∀ p₁ p₂:ℕ,p≠p₁*p₁+p₂*p₂):=begin
        assume L,induction L with p1 L hi,simp,intros,have:=a_3 a b a_1,contradiction,simp,
        assume x a b hab hp hL hx hxs,cases classical.em (∃ p1₁ p1₂:ℕ,p1₁ *p1₁ +p1₂ *p1₂ =p1),
        cases h with p1₁,cases h_h with p1₂,rw ←h_h_h at hp,rw [mul_comm,mul_assoc,←h_h_h]at hab,
        have pdvd:=dvd_mul_right (p1₁ * p1₁ + p1₂ * p1₂) (prod L * x),rw [hab,←int.coe_nat_dvd,int.coe_nat_add,int.coe_nat_add,int.coe_nat_mul,int.coe_nat_mul,int.coe_nat_mul,int.coe_nat_mul] at pdvd,have:=lemma_2 a b p1₁ p1₂ hp pdvd,
        cases this with x₁ hx1,cases hx1 with y₁ hxy,have:∃ x₂ y₂:nat,x*prod L = x₂*x₂+y₂*y₂,
        existsi [int.nat_abs x₁,int.nat_abs y₁],rw[←int.coe_nat_mul,←int.coe_nat_mul,←int.coe_nat_mul,←int.coe_nat_mul,←int.coe_nat_add,←int.coe_nat_add,←hab,int.coe_nat_mul,mul_comm] at hxy,
        have: (↑(p1₁ * p1₁ + p1₂ * p1₂) * (x₁ * x₁ + y₁ * y₁)) / ↑(p1₁ * p1₁ + p1₂ * p1₂)=(↑(p1₁ * p1₁ + p1₂ * p1₂) * ↑(prod L * x)) / ↑(p1₁ * p1₁ + p1₂ * p1₂),rw hxy,rw [int.mul_div_cancel_left,int.mul_div_cancel_left] at this,
        rw[mul_comm x,←int.coe_nat_eq_coe_nat_iff,← this,int.coe_nat_add,int.coe_nat_mul,int.coe_nat_mul,←int.abs_eq_nat_abs,← int.abs_eq_nat_abs,abs_mul_abs_self,abs_mul_abs_self],rw [h_h_h,←int.coe_nat_zero,ne.def,int.coe_nat_eq_coe_nat_iff],have:=prime.pos hp,intro,rw[h_h_h, a_1] at this,revert this,exact dec_trivial,
        rw [h_h_h,←int.coe_nat_zero,ne.def,int.coe_nat_eq_coe_nat_iff],have:=prime.pos hp,intro,rw[h_h_h, a_1] at this,revert this,exact dec_trivial,
        clear hxy x₁ y₁,cases this with x₁ hxy,cases hxy with y₁ hxy,have:= hi x x₁ y₁ hxy hL,
end


/-
Copyright (c) 2021 Yury G. Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury G. Kudryashov
-/
import data.set.intervals.monotone
import topology.algebra.order.monotone_continuity
import topology.urysohns_bounded

/-!
# Tietze extension theorem

In this file we prove a few version of the Tietze extension theorem. The theorem says that a
continuous function `s → ℝ` defined on a closed set in a normal topological space `Y` can be
extended to a continuous function on the whole space. Moreover, if all values of the original
function belong to some (finite or infinite, open or closed) interval, then the extension can be
chosen so that it takes values in the same interval. In particular, if the original function is a
bounded function, then there exists a bounded extension of the same norm.

The proof mostly follows <https://ncatlab.org/nlab/show/Tietze+extension+theorem>. We patch a small
gap in the proof for unbounded functions, see
`exists_extension_forall_exists_le_ge_of_closed_embedding`.

## Implementation notes

We first prove the theorems for a closed embedding `e : X → Y` of a topological space into a normal
topological space, then specialize them to the case `X = s : set Y`, `e = coe`.

## Tags

Tietze extension theorem, Urysohn's lemma, normal topological space
-/

variables {X Y : Type*} [topological_space X] [topological_space Y] [normal_space Y]

open metric set filter
open_locale bounded_continuous_function topological_space
noncomputable theory

namespace bounded_continuous_function

/-- One step in the proof of the Tietze extension theorem. If `e : C(X, Y)` is a closed embedding
of a topological space into a normal topological space and `f : X →ᵇ ℝ` is a bounded continuous
function, then there exists a bounded continuous function `g : Y →ᵇ ℝ` of the norm `∥g∥ ≤ ∥f∥ / 3`
such that the distance between `g ∘ e` and `f` is at most `(2 / 3) * ∥f∥`. -/
lemma tietze_extension_step (f : X →ᵇ ℝ) (e : C(X, Y)) (he : closed_embedding e) :
  ∃ g : Y →ᵇ ℝ, ∥g∥ ≤ ∥f∥ / 3 ∧ dist (g.comp_continuous e) f ≤ (2 / 3) * ∥f∥ :=
begin
  have h3 : (0 : ℝ) < 3 := by norm_num1,
  have h23 : 0 < (2 / 3 : ℝ) := by norm_num1,
  -- In the trivial case `f = 0`, we take `g = 0`
  rcases eq_or_ne f 0 with (rfl|hf), { use 0, simp },
  replace hf : 0 < ∥f∥ := norm_pos_iff.2 hf,
  /- Otherwise, the closed sets `e '' (f ⁻¹' (Iic (-∥f∥ / 3)))` and `e '' (f ⁻¹' (Ici (∥f∥ / 3)))`
  are disjoint, hence by Urysohn's lemma there exists a function `g` that is equal to `-∥f∥ / 3`
  on the former set and is equal to `∥f∥ / 3` on the latter set. This function `g` satisfies the
  assertions of the lemma. -/
  have hf3 : -∥f∥ / 3 < ∥f∥ / 3, from (div_lt_div_right h3).2 (left.neg_lt_self hf),
  have hc₁ : is_closed (e '' (f ⁻¹' (Iic (-∥f∥ / 3)))),
    from he.is_closed_map _ (is_closed_Iic.preimage f.continuous),
  have hc₂ : is_closed (e '' (f ⁻¹' (Ici (∥f∥ / 3)))),
    from he.is_closed_map _ (is_closed_Ici.preimage f.continuous),
  have hd : disjoint (e '' (f ⁻¹' (Iic (-∥f∥ / 3)))) (e '' (f ⁻¹' (Ici (∥f∥ / 3)))),
  { refine disjoint_image_of_injective he.inj (disjoint.preimage _ _),
    rwa [Iic_disjoint_Ici, not_le] },
  rcases exists_bounded_mem_Icc_of_closed_of_le hc₁ hc₂ hd hf3.le with ⟨g, hg₁, hg₂, hgf⟩,
  refine ⟨g, _, _⟩,
  { refine (norm_le $ div_nonneg hf.le h3.le).mpr (λ y, _),
    simpa [real.norm_eq_abs, abs_le, neg_div] using hgf y },
  { refine (dist_le $ mul_nonneg h23.le hf.le).mpr (λ x, _),
    have hfx : -∥f∥ ≤ f x ∧ f x ≤ ∥f∥,
      by simpa only [real.norm_eq_abs, abs_le] using f.norm_coe_le_norm x,
    cases le_total (f x) (-∥f∥ / 3) with hle₁ hle₁,
    { calc |g (e x) - f x| = -∥f∥ / 3 - f x:
        by rw [hg₁ (mem_image_of_mem _ hle₁), abs_of_nonneg (sub_nonneg.2 hle₁)]
      ... ≤ (2 / 3) * ∥f∥ : by linarith },
    { cases le_total (f x) (∥f∥ / 3) with hle₂ hle₂,
      { simp only [neg_div] at *,
        calc dist (g (e x)) (f x) ≤ |g (e x)| + |f x| : dist_le_norm_add_norm _ _
        ... ≤ ∥f∥ / 3 + ∥f∥ / 3 :
          add_le_add (abs_le.2 $ hgf _) (abs_le.2 ⟨hle₁, hle₂⟩)
        ... = (2 / 3) * ∥f∥ : by linarith },
      { calc |g (e x) - f x| = f x - ∥f∥ / 3 :
          by rw [hg₂ (mem_image_of_mem _ hle₂), abs_sub_comm, abs_of_nonneg (sub_nonneg.2 hle₂)]
        ... ≤ (2 / 3) * ∥f∥ : by linarith } } }
end

/-- **Tietze extension theorem** for real-valued bounded continuous maps, a version with a closed
embedding and bundled composition. If `e : C(X, Y)` is a closed embedding of a topological space
into a normal topological space and `f : X →ᵇ ℝ` is a bounded continuous function, then there exists
a bounded continuous function `g : Y →ᵇ ℝ` of the same norm such that `g ∘ e = f`. -/
lemma exists_extension_norm_eq_of_closed_embedding' (f : X →ᵇ ℝ) (e : C(X, Y))
  (he : closed_embedding e) :
  ∃ g : Y →ᵇ ℝ, ∥g∥ = ∥f∥ ∧ g.comp_continuous e = f :=
begin
  /- For the proof, we iterate `tietze_extension_step`. Each time we apply it to the difference
  between the previous approximation and `f`. -/
  choose F hF_norm hF_dist using λ f : X →ᵇ ℝ, tietze_extension_step f e he,
  set g : ℕ → Y →ᵇ ℝ := λ n, (λ g, g + F (f - g.comp_continuous e))^[n] 0,
  have g0 : g 0 = 0 := rfl,
  have g_succ : ∀ n, g (n + 1) = g n + F (f - (g n).comp_continuous e),
    from λ n, function.iterate_succ_apply' _ _ _,
  have hgf : ∀ n, dist ((g n).comp_continuous e) f ≤ (2 / 3) ^ n * ∥f∥,
  { intro n, induction n with n ihn,
    { simp [g0] },
    { rw [g_succ n, add_comp_continuous, ← dist_sub_right, add_sub_cancel', pow_succ, mul_assoc],
      refine (hF_dist _).trans (mul_le_mul_of_nonneg_left _ (by norm_num1)),
      rwa ← dist_eq_norm' } },
  have hg_dist : ∀ n, dist (g n) (g (n + 1)) ≤ 1 / 3 * ∥f∥ * (2 / 3) ^ n,
  { intro n,
    calc dist (g n) (g (n + 1)) = ∥F (f - (g n).comp_continuous e)∥ :
      by rw [g_succ, dist_eq_norm', add_sub_cancel']
    ... ≤ ∥f - (g n).comp_continuous e∥ / 3 : hF_norm _
    ... = (1 / 3) * dist ((g n).comp_continuous e) f :
      by rw [dist_eq_norm', one_div, div_eq_inv_mul]
    ... ≤ (1 / 3) * ((2 / 3) ^ n * ∥f∥) :
      mul_le_mul_of_nonneg_left (hgf n) (by norm_num1)
    ... = 1 / 3 * ∥f∥ * (2 / 3) ^ n : by ac_refl },
  have hg_cau : cauchy_seq g, from cauchy_seq_of_le_geometric _ _ (by norm_num1) hg_dist,
  have : tendsto (λ n, (g n).comp_continuous e) at_top (𝓝 $ (lim at_top g).comp_continuous e),
    from ((continuous_comp_continuous e).tendsto _).comp hg_cau.tendsto_lim,
  have hge : (lim at_top g).comp_continuous e = f,
  { refine tendsto_nhds_unique this (tendsto_iff_dist_tendsto_zero.2 _),
    refine squeeze_zero (λ _, dist_nonneg) hgf _,
    rw ← zero_mul (∥f∥),
    refine (tendsto_pow_at_top_nhds_0_of_lt_1 _ _).mul tendsto_const_nhds; norm_num1 },
  refine ⟨lim at_top g, le_antisymm _ _, hge⟩,
  { rw [← dist_zero_left, ← g0],
    refine (dist_le_of_le_geometric_of_tendsto₀ _ _ (by norm_num1)
      hg_dist hg_cau.tendsto_lim).trans_eq _,
    field_simp [show (3 - 2 : ℝ) = 1, by norm_num1] },
  { rw ← hge, exact norm_comp_continuous_le _ _ }
end

/-- **Tietze extension theorem** for real-valued bounded continuous maps, a version with a closed
embedding and unbundled composition. If `e : C(X, Y)` is a closed embedding of a topological space
into a normal topological space and `f : X →ᵇ ℝ` is a bounded continuous function, then there exists
a bounded continuous function `g : Y →ᵇ ℝ` of the same norm such that `g ∘ e = f`. -/
lemma exists_extension_norm_eq_of_closed_embedding (f : X →ᵇ ℝ) {e : X → Y}
  (he : closed_embedding e) :
  ∃ g : Y →ᵇ ℝ, ∥g∥ = ∥f∥ ∧ g ∘ e = f :=
begin
  rcases exists_extension_norm_eq_of_closed_embedding' f ⟨e, he.continuous⟩ he with ⟨g, hg, rfl⟩,
  exact ⟨g, hg, rfl⟩
end

/-- **Tietze extension theorem** for real-valued bounded continuous maps, a version for a closed
set. If `f` is a bounded continuous real-valued function defined on a closed set in a normal
topological space, then it can be extended to a bounded continuous function of the same norm defined
on the whole space. -/
lemma exists_norm_eq_restrict_eq_of_closed {s : set Y} (f : s →ᵇ ℝ) (hs : is_closed s) :
  ∃ g : Y →ᵇ ℝ, ∥g∥ = ∥f∥ ∧ g.restrict s = f :=
exists_extension_norm_eq_of_closed_embedding' f ((continuous_map.id _).restrict s)
  (closed_embedding_subtype_coe hs)

/-- **Tietze extension theorem** for real-valued bounded continuous maps, a version for a closed
embedding and a bounded continuous function that takes values in a non-trivial closed interval.
See also `exists_extension_forall_mem_of_closed_embedding` for a more general statement that works
for any interval (finite or infinite, open or closed).

If `e : X → Y` is a closed embedding and `f : X →ᵇ ℝ` is a bounded continuous function such that
`f x ∈ [a, b]` for all `x`, where `a ≤ b`, then there exists a bounded continuous function
`g : Y →ᵇ ℝ` such that `g y ∈ [a, b]` for all `y` and `g ∘ e = f`. -/
lemma exists_extension_forall_mem_Icc_of_closed_embedding (f : X →ᵇ ℝ) {a b : ℝ} {e : X → Y}
  (hf : ∀ x, f x ∈ Icc a b) (hle : a ≤ b) (he : closed_embedding e) :
  ∃ g : Y →ᵇ ℝ, (∀ y, g y ∈ Icc a b) ∧ g ∘ e = f :=
begin
  rcases exists_extension_norm_eq_of_closed_embedding (f - const X ((a + b) / 2)) he
    with ⟨g, hgf, hge⟩,
  refine ⟨const Y ((a + b) / 2) + g, λ y, _, _⟩,
  { suffices : ∥f - const X ((a + b) / 2)∥ ≤ (b - a) / 2,
      by simpa [real.Icc_eq_closed_ball, add_mem_closed_ball_iff_norm]
        using (norm_coe_le_norm g y).trans (hgf.trans_le this),
    refine (norm_le $ div_nonneg (sub_nonneg.2 hle) zero_le_two).2 (λ x, _),
    simpa only [real.Icc_eq_closed_ball] using hf x },
  { ext x,
    have : g (e x) = f x - (a + b) / 2 := congr_fun hge x,
    simp [this] }
end

/-- **Tietze extension theorem** for real-valued bounded continuous maps, a version for a closed
embedding. Let `e` be a closed embedding of a nonempty topological space `X` into a normal
topological space `Y`. Let `f` be a bounded continuous real-valued function on `X`. Then there
exists a bounded continuous function `g : Y →ᵇ ℝ` such that `g ∘ e = f` and each value `g y` belongs
to a closed interval `[f x₁, f x₂]` for some `x₁` and `x₂`.  -/
lemma exists_extension_forall_exists_le_ge_of_closed_embedding [nonempty X] (f : X →ᵇ ℝ) {e : X → Y}
  (he : closed_embedding e) :
  ∃ g : Y →ᵇ ℝ, (∀ y, ∃ x₁ x₂, g y ∈ Icc (f x₁) (f x₂)) ∧ g ∘ e = f :=
begin
  inhabit X,
  -- Put `a = ⨅ x, f x` and `b = ⨆ x, f x`
  obtain ⟨a, ha⟩ : ∃ a, is_glb (range f) a,
    from ⟨_, is_glb_cinfi (real.bounded_iff_bdd_below_bdd_above.1 f.bounded_range).1⟩,
  obtain ⟨b, hb⟩ : ∃ b, is_lub (range f) b,
    from ⟨_, is_lub_csupr (real.bounded_iff_bdd_below_bdd_above.1 f.bounded_range).2⟩,
  -- Then `f x ∈ [a, b]` for all `x`
  have hmem : ∀ x, f x ∈ Icc a b, from λ x, ⟨ha.1 ⟨x, rfl⟩, hb.1 ⟨x, rfl⟩⟩,
  -- Rule out the trivial case `a = b`
  have hle : a ≤ b := (hmem default).1.trans (hmem default).2,
  rcases hle.eq_or_lt with (rfl|hlt),
  { have : ∀ x, f x = a, by simpa using hmem,
    use const Y a, simp [this, function.funext_iff] },
  -- Put `c = (a + b) / 2`. Then `a < c < b` and `c - a = b - c`.
  set c := (a + b) / 2,
  have hac : a < c := left_lt_add_div_two.2 hlt,
  have hcb : c < b := add_div_two_lt_right.2 hlt,
  have hsub : c - a = b - c, by { simp only [c], field_simp, ring },
  /- Due to `exists_extension_forall_mem_Icc_of_closed_embedding`, there exists an extension `g`
  such that `g y ∈ [a, b]` for all `y`. However, if `a` and/or `b` do not belong to the range of
  `f`, then we need to ensure that these points do not belong to the range of `g`. This is done
  in two almost identical steps. First we deal with the case `∀ x, f x ≠ a`. -/
  obtain ⟨g, hg_mem, hgf⟩ : ∃ g : Y →ᵇ ℝ, (∀ y, ∃ x, g y ∈ Icc (f x) b) ∧ g ∘ e = f,
  { rcases exists_extension_forall_mem_Icc_of_closed_embedding f hmem hle he
      with ⟨g, hg_mem, hgf⟩,
    -- If `a ∈ range f`, then we are done.
    rcases em (∃ x, f x = a) with ⟨x, rfl⟩|ha',
    { exact ⟨g, λ y, ⟨x, hg_mem _⟩, hgf⟩ },
    /- Otherwise, `g ⁻¹' {a}` is disjoint with `range e ∪ g ⁻¹' (Ici c)`, hence there exists a
    function `dg : Y → ℝ` such that `dg ∘ e = 0`, `dg y = 0` whenever `c ≤ g y`, `dg y = c - a`
    whenever `g y = a`, and `0 ≤ dg y ≤ c - a` for all `y`.  -/
    have hd : disjoint (range e ∪ g ⁻¹' (Ici c)) (g ⁻¹' {a}),
    { refine disjoint_union_left.2 ⟨_, disjoint.preimage _ _⟩,
      { rintro _ ⟨⟨x, rfl⟩, rfl : g (e x) = a⟩,
        exact ha' ⟨x, (congr_fun hgf x).symm⟩ },
      { exact set.disjoint_singleton_right.2 hac.not_le } },
    rcases exists_bounded_mem_Icc_of_closed_of_le
      (he.closed_range.union $ is_closed_Ici.preimage g.continuous)
      (is_closed_singleton.preimage g.continuous) hd (sub_nonneg.2 hac.le)
      with ⟨dg, dg0, dga, dgmem⟩,
    replace hgf : ∀ x, (g + dg) (e x) = f x,
    { intro x, simp [dg0 (or.inl $ mem_range_self _), ← hgf] },
    refine ⟨g + dg, λ y, _, funext hgf⟩,
    { have hay : a < (g + dg) y,
      { rcases (hg_mem y).1.eq_or_lt with rfl|hlt,
        { refine (lt_add_iff_pos_right _).2 _,
          calc 0 < c - g y : sub_pos.2 hac
             ... = dg y    : (dga rfl).symm },
        { exact hlt.trans_le ((le_add_iff_nonneg_right _).2 $ (dgmem y).1) } },
      rcases ha.exists_between hay with ⟨_, ⟨x, rfl⟩, hax, hxy⟩,
      refine ⟨x, hxy.le, _⟩,
      cases le_total c (g y) with hc hc,
      { simp [dg0 (or.inr hc), (hg_mem y).2] },
      { calc g y + dg y ≤ c + (c - a) : add_le_add hc (dgmem _).2
                    ... = b           : by rw [hsub, add_sub_cancel'_right] } } },
  /- Now we deal with the case `∀ x, f x ≠ b`. The proof is the same as in the first case, with
  minor modifications that make it hard to deduplicate code. -/
  choose xl hxl hgb using hg_mem,
  rcases em (∃ x, f x = b) with ⟨x, rfl⟩|hb',
  { exact ⟨g, λ y, ⟨xl y, x, hxl y, hgb y⟩, hgf⟩ },
  have hd : disjoint (range e ∪ g ⁻¹' (Iic c)) (g ⁻¹' {b}),
  { refine disjoint_union_left.2 ⟨_, disjoint.preimage _ _⟩,
    { rintro _ ⟨⟨x, rfl⟩, rfl : g (e x) = b⟩,
      exact hb' ⟨x, (congr_fun hgf x).symm⟩ },
    { exact set.disjoint_singleton_right.2 hcb.not_le } },
  rcases exists_bounded_mem_Icc_of_closed_of_le
    (he.closed_range.union $ is_closed_Iic.preimage g.continuous)
    (is_closed_singleton.preimage g.continuous) hd (sub_nonneg.2 hcb.le)
    with ⟨dg, dg0, dgb, dgmem⟩,
  replace hgf : ∀ x, (g - dg) (e x) = f x,
  { intro x, simp [dg0 (or.inl $ mem_range_self _), ← hgf] },
  refine ⟨g - dg, λ y, _, funext hgf⟩,
  { have hyb : (g - dg) y < b,
    { rcases (hgb y).eq_or_lt with rfl|hlt,
      { refine (sub_lt_self_iff _).2 _,
        calc 0 < g y - c : sub_pos.2 hcb
           ... = dg y    : (dgb rfl).symm },
      { exact ((sub_le_self_iff _).2 (dgmem _).1).trans_lt hlt } },
    rcases hb.exists_between hyb with ⟨_, ⟨xu, rfl⟩, hyxu, hxub⟩,
    cases lt_or_le c (g y) with hc hc,
    { rcases em (a ∈ range f) with ⟨x, rfl⟩|ha',
      { refine ⟨x, xu, _, hyxu.le⟩,
        calc f x = c - (b - c) : by rw [← hsub, sub_sub_cancel]
             ... ≤ g y - dg y  : sub_le_sub hc.le (dgmem _).2 },
      { have hay : a < (g - dg) y,
        { calc a = c - (b - c)   : by rw [← hsub, sub_sub_cancel]
             ... < g y - (b - c) : sub_lt_sub_right hc _
             ... ≤ g y - dg y    : sub_le_sub_left (dgmem _).2 _ },
        rcases ha.exists_between hay with ⟨_, ⟨x, rfl⟩, ha, hxy⟩,
        exact ⟨x, xu, hxy.le, hyxu.le⟩ } },
    { refine ⟨xl y, xu, _, hyxu.le⟩,
      simp [dg0 (or.inr hc), hxl] } },
end

/-- **Tietze extension theorem** for real-valued bounded continuous maps, a version for a closed
embedding. Let `e` be a closed embedding of a nonempty topological space `X` into a normal
topological space `Y`. Let `f` be a bounded continuous real-valued function on `X`. Let `t` be
a nonempty convex set of real numbers (we use `ord_connected` instead of `convex` to automatically
deduce this argument by typeclass search) such that `f x ∈ t` for all `x`. Then there exists
a bounded continuous real-valued function `g : Y →ᵇ ℝ` such that `g y ∈ t` for all `y` and
`g ∘ e = f`. -/
lemma exists_extension_forall_mem_of_closed_embedding (f : X →ᵇ ℝ) {t : set ℝ} {e : X → Y}
  [hs : ord_connected t] (hf : ∀ x, f x ∈ t) (hne : t.nonempty) (he : closed_embedding e) :
  ∃ g : Y →ᵇ ℝ, (∀ y, g y ∈ t) ∧ g ∘ e = f :=
begin
  casesI is_empty_or_nonempty X,
  { rcases hne with ⟨c, hc⟩,
    refine ⟨const Y c, λ y, hc, funext $ λ x, is_empty_elim x⟩ },
  rcases exists_extension_forall_exists_le_ge_of_closed_embedding f he with ⟨g, hg, hgf⟩,
  refine ⟨g, λ y, _, hgf⟩,
  rcases hg y with ⟨xl, xu, h⟩,
  exact hs.out (hf _) (hf _) h
end

/-- **Tietze extension theorem** for real-valued bounded continuous maps, a version for a closed
set. Let `s` be a closed set in a normal topological space `Y`. Let `f` be a bounded continuous
real-valued function on `s`. Let `t` be a nonempty convex set of real numbers (we use
`ord_connected` instead of `convex` to automatically deduce this argument by typeclass search) such
that `f x ∈ t` for all `x : s`. Then there exists a bounded continuous real-valued function
`g : Y →ᵇ ℝ` such that `g y ∈ t` for all `y` and `g.restrict s = f`. -/
lemma exists_forall_mem_restrict_eq_of_closed {s : set Y} (f : s →ᵇ ℝ) (hs : is_closed s)
  {t : set ℝ} [ord_connected t] (hf : ∀ x, f x ∈ t) (hne : t.nonempty) :
  ∃ g : Y →ᵇ ℝ, (∀ y, g y ∈ t) ∧ g.restrict s = f :=
begin
  rcases exists_extension_forall_mem_of_closed_embedding f hf hne (closed_embedding_subtype_coe hs)
    with ⟨g, hg, hgf⟩,
  exact ⟨g, hg, fun_like.coe_injective hgf⟩
end

end bounded_continuous_function

namespace continuous_map

/-- **Tietze extension theorem** for real-valued continuous maps, a version for a closed
embedding. Let `e` be a closed embedding of a nonempty topological space `X` into a normal
topological space `Y`. Let `f` be a continuous real-valued function on `X`. Let `t` be a nonempty
convex set of real numbers (we use `ord_connected` instead of `convex` to automatically deduce this
argument by typeclass search) such that `f x ∈ t` for all `x`. Then there exists a continuous
real-valued function `g : C(Y, ℝ)` such that `g y ∈ t` for all `y` and `g ∘ e = f`. -/
lemma exists_extension_forall_mem_of_closed_embedding (f : C(X, ℝ)) {t : set ℝ} {e : X → Y}
  [hs : ord_connected t] (hf : ∀ x, f x ∈ t) (hne : t.nonempty) (he : closed_embedding e) :
  ∃ g : C(Y, ℝ), (∀ y, g y ∈ t) ∧ g ∘ e = f :=
begin
  have h : ℝ ≃o Ioo (-1 : ℝ) 1 := order_iso_Ioo_neg_one_one ℝ,
  set F : X →ᵇ ℝ :=
  { to_fun := coe ∘ (h ∘ f),
    continuous_to_fun := continuous_subtype_coe.comp (h.continuous.comp f.continuous),
    map_bounded' := bounded_range_iff.1 ((bounded_Ioo (-1 : ℝ) 1).mono $
      forall_range_iff.2 $ λ x, (h (f x)).2) },
  set t' : set ℝ := (coe ∘ h) '' t,
  have ht_sub : t' ⊆ Ioo (-1 : ℝ) 1 := image_subset_iff.2 (λ x hx, (h x).2),
  haveI : ord_connected t',
  { constructor, rintros _ ⟨x, hx, rfl⟩ _ ⟨y, hy, rfl⟩ z hz,
    lift z to Ioo (-1 : ℝ) 1 using (Icc_subset_Ioo (h x).2.1 (h y).2.2 hz),
    change z ∈ Icc (h x) (h y) at hz, rw [← h.image_Icc] at hz,
    rcases hz with ⟨z, hz, rfl⟩,
    exact ⟨z, hs.out hx hy hz, rfl⟩ },
  have hFt : ∀ x, F x ∈ t', from λ x, mem_image_of_mem _ (hf x),
  rcases F.exists_extension_forall_mem_of_closed_embedding hFt (hne.image _) he
    with ⟨G, hG, hGF⟩,
  set g : C(Y, ℝ) := ⟨h.symm ∘ cod_restrict G _ (λ y, ht_sub (hG y)), h.symm.continuous.comp $
    continuous_subtype_mk _ G.continuous⟩,
  have hgG : ∀ {y a}, g y = a ↔ G y = h a,
    from λ y a, h.to_equiv.symm_apply_eq.trans subtype.ext_iff,
  refine ⟨g, λ y, _, _⟩,
  { rcases hG y with ⟨a, ha, hay⟩,
    convert ha,
    exact hgG.2 hay.symm },
  { ext x, exact hgG.2 (congr_fun hGF _) }
end

/-- **Tietze extension theorem** for real-valued continuous maps, a version for a closed
embedding. Let `e` be a closed embedding of a nonempty topological space `X` into a normal
topological space `Y`. Let `f` be a continuous real-valued function on `X`. Then there exists a
continuous real-valued function `g : C(Y, ℝ)` such that `g ∘ e = f`. -/
lemma exists_extension_of_closed_embedding (f : C(X, ℝ)) (e : X → Y) (he : closed_embedding e) :
  ∃ g : C(Y, ℝ), g ∘ e = f :=
(exists_extension_forall_mem_of_closed_embedding f (λ x, mem_univ _) univ_nonempty he).imp $
  λ g, and.right

/-- **Tietze extension theorem** for real-valued continuous maps, a version for a closed set. Let
`s` be a closed set in a normal topological space `Y`. Let `f` be a continuous real-valued function
on `s`. Let `t` be a nonempty convex set of real numbers (we use `ord_connected` instead of `convex`
to automatically deduce this argument by typeclass search) such that `f x ∈ t` for all `x : s`. Then
there exists a continuous real-valued function `g : C(Y, ℝ)` such that `g y ∈ t` for all `y` and
`g.restrict s = f`. -/
lemma exists_restrict_eq_forall_mem_of_closed {s : set Y} (f : C(s, ℝ)) {t : set ℝ}
  [ord_connected t] (ht : ∀ x, f x ∈ t) (hne : t.nonempty) (hs : is_closed s) :
  ∃ g : C(Y, ℝ), (∀ y, g y ∈ t) ∧ g.restrict s = f :=
let ⟨g, hgt, hgf⟩ := exists_extension_forall_mem_of_closed_embedding f ht hne
  (closed_embedding_subtype_coe hs)
in ⟨g, hgt, coe_injective hgf⟩

/-- **Tietze extension theorem** for real-valued continuous maps, a version for a closed set. Let
`s` be a closed set in a normal topological space `Y`. Let `f` be a continuous real-valued function
on `s`. Then there exists a continuous real-valued function `g : C(Y, ℝ)` such that
`g.restrict s = f`. -/
lemma exists_restrict_eq_of_closed {s : set Y} (f : C(s, ℝ)) (hs : is_closed s) :
  ∃ g : C(Y, ℝ), g.restrict s = f :=
let ⟨g, hg, hgf⟩ := exists_restrict_eq_forall_mem_of_closed f (λ _, mem_univ _) univ_nonempty hs
in ⟨g, hgf⟩

end continuous_map