/-
Copyright (c) 2015 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura, Mario Carneiro

! This file was ported from Lean 3 source module logic.equiv.defs
! leanprover-community/mathlib commit c4658a649d216f57e99621708b09dcb3dcccbd23
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.FunLike.Equiv
import Mathlib.Data.Quot
import Mathlib.Init.Data.Bool.Lemmas
import Mathlib.Logic.Unique
import Mathlib.Tactic.Conv
import Mathlib.Tactic.Relation.Rfl
import Mathlib.Tactic.Relation.Symm
import Mathlib.Tactic.Relation.Trans
import Mathlib.Tactic.Simps.Basic
import Mathlib.Tactic.Substs

/-!
# Equivalence between types

In this file we define two types:

* `Equiv α β` a.k.a. `α ≃ β`: a bijective map `α → β` bundled with its inverse map; we use this (and
  not equality!) to express that various `Type`s or `Sort`s are equivalent.

* `Equiv.Perm α`: the group of permutations `α ≃ α`. More lemmas about `Equiv.Perm` can be found in
  `GroupTheory.Perm`.

Then we define

* canonical isomorphisms between various types: e.g.,

  - `Equiv.refl α` is the identity map interpreted as `α ≃ α`;

* operations on equivalences: e.g.,

  - `Equiv.symm e : β ≃ α` is the inverse of `e : α ≃ β`;

  - `Equiv.trans e₁ e₂ : α ≃ γ` is the composition of `e₁ : α ≃ β` and `e₂ : β ≃ γ` (note the order
    of the arguments!);

* definitions that transfer some instances along an equivalence. By convention, we transfer
  instances from right to left.

  - `Equiv.inhabited` takes `e : α ≃ β` and `[Inhabited β]` and returns `Inhabited α`;
  - `Equiv.unique` takes `e : α ≃ β` and `[Unique β]` and returns `unique α`;
  - `Equiv.decidableEq` takes `e : α ≃ β` and `[DecidableEq β]` and returns `DecidableEq α`.

  More definitions of this kind can be found in other files. E.g., `Data.Equiv.TransferInstance`
  does it for many algebraic type classes like `Group`, `Module`, etc.

Many more such isomorphisms and operations are defined in `Logic.Equiv.Basic`.

## Tags

equivalence, congruence, bijective map
-/

open Function

universe u v w z

variable {α : Sort u} {β : Sort v} {γ : Sort w}

/-- `α ≃ β` is the type of functions from `α → β` with a two-sided inverse. -/
structure Equiv (α : Sort _) (β : Sort _) where
  toFun : α → β
  invFun : β → α
  left_inv : LeftInverse invFun toFun
  right_inv : RightInverse invFun toFun
#align equiv Equiv

infixl:25 " ≃ " => Equiv

/-- Turn an element of a type `F` satisfying `EquivLike F α β` into an actual
`Equiv`. This is declared as the default coercion from `F` to `α ≃ β`. -/
@[coe]
def EquivLike.toEquiv {F} [EquivLike F α β] (f :F) : α ≃ β where
  toFun := f
  invFun := EquivLike.inv f
  left_inv := EquivLike.left_inv f
  right_inv := EquivLike.right_inv f

/-- Any type satisfying `EquivLike` can be cast into `Equiv` via `EquivLike.toEquiv`. -/
instance {F} [EquivLike F α β] : CoeTC F (α ≃ β) :=
  ⟨EquivLike.toEquiv⟩

/-- `Perm α` is the type of bijections from `α` to itself. -/
@[reducible]
def Equiv.Perm (α : Sort _) :=
  Equiv α α
#align equiv.perm Equiv.Perm

namespace Equiv

instance : EquivLike (α ≃ β) α β where
  coe := toFun
  inv := invFun
  left_inv := left_inv
  right_inv := right_inv
  coe_injective' e₁ e₂ h₁ h₂ := by cases e₁; cases e₂; congr

/-- Helper instance when inference gets stuck on following the normal chain
`EquivLike → EmbeddingLike → FunLike → CoeFun`. -/
instance : FunLike (α ≃ β) α (fun _ => β) :=
  EmbeddingLike.toFunLike

@[simp] theorem coe_fn_mk (f : α → β) (g l r) : (Equiv.mk f g l r : α → β) = f :=
rfl
#align equiv.coe_fn_mk Equiv.coe_fn_mk

/-- The map `(r ≃ s) → (r → s)` is injective. -/
theorem coe_fn_injective : @Function.Injective (α ≃ β) (α → β) (fun e => e) :=
  FunLike.coe_injective'
#align equiv.coe_fn_injective Equiv.coe_fn_injective

protected theorem coe_inj {e₁ e₂ : α ≃ β} : (e₁ : α → β) = e₂ ↔ e₁ = e₂ :=
  @FunLike.coe_fn_eq _ _ _ _ e₁ e₂
#align equiv.coe_inj Equiv.coe_inj

@[ext] theorem ext {f g : Equiv α β} (H : ∀ x, f x = g x) : f = g := FunLike.ext f g H
#align equiv.ext Equiv.ext

protected theorem congr_arg {f : Equiv α β} {x x' : α} : x = x' → f x = f x' :=
  FunLike.congr_arg f
#align equiv.congr_arg Equiv.congr_arg

protected theorem congr_fun {f g : Equiv α β} (h : f = g) (x : α) : f x = g x :=
  FunLike.congr_fun h x
#align equiv.congr_fun Equiv.congr_fun

theorem ext_iff {f g : Equiv α β} : f = g ↔ ∀ x, f x = g x := FunLike.ext_iff
#align equiv.ext_iff Equiv.ext_iff

@[ext] theorem Perm.ext {σ τ : Equiv.Perm α} (H : ∀ x, σ x = τ x) : σ = τ := Equiv.ext H
#align equiv.perm.ext Equiv.Perm.ext

protected theorem Perm.congr_arg {f : Equiv.Perm α} {x x' : α} : x = x' → f x = f x' :=
  Equiv.congr_arg
#align equiv.perm.congr_arg Equiv.Perm.congr_arg

protected theorem Perm.congr_fun {f g : Equiv.Perm α} (h : f = g) (x : α) : f x = g x :=
  Equiv.congr_fun h x
#align equiv.perm.congr_fun Equiv.Perm.congr_fun

theorem Perm.ext_iff {σ τ : Equiv.Perm α} : σ = τ ↔ ∀ x, σ x = τ x := Equiv.ext_iff
#align equiv.perm.ext_iff Equiv.Perm.ext_iff

/-- Any type is equivalent to itself. -/
@[refl] protected def refl (α : Sort _) : α ≃ α := ⟨id, id, fun _ => rfl, fun _ => rfl⟩
#align equiv.refl Equiv.refl

instance inhabited' : Inhabited (α ≃ α) := ⟨Equiv.refl α⟩

/-- Inverse of an equivalence `e : α ≃ β`. -/
@[symm]
protected def symm (e : α ≃ β) : β ≃ α := ⟨e.invFun, e.toFun, e.right_inv, e.left_inv⟩
#align equiv.symm Equiv.symm

/-- See Note [custom simps projection] -/
def Simps.symm_apply (e : α ≃ β) : β → α := e.symm
#align equiv.simps.symm_apply Equiv.Simps.symm_apply

initialize_simps_projections Equiv (toFun → apply, invFun → symm_apply)

-- Porting note:
-- Added these lemmas as restatements of `left_inv` and `right_inv`,
-- which use the coercions.
-- We might even consider switching the names, and having these as a public API.
theorem left_inv' (e : α ≃ β) : Function.LeftInverse e.symm e := e.left_inv
theorem right_inv' (e : α ≃ β) : Function.RightInverse e.symm e := e.right_inv

/-- Composition of equivalences `e₁ : α ≃ β` and `e₂ : β ≃ γ`. -/
@[trans]
protected def trans (e₁ : α ≃ β) (e₂ : β ≃ γ) : α ≃ γ :=
  ⟨e₂ ∘ e₁, e₁.symm ∘ e₂.symm, e₂.left_inv.comp e₁.left_inv, e₂.right_inv.comp e₁.right_inv⟩
#align equiv.trans Equiv.trans

@[simps]
instance : Trans Equiv Equiv Equiv where
  trans := Equiv.trans

-- porting note: this is not a syntactic tautology any more because
-- the coercion from `e` to a function is now `FunLike.coe` not `e.toFun`
@[simp] theorem toFun_as_coe (e : α ≃ β) : e.toFun = e := rfl
#align equiv.to_fun_as_coe Equiv.toFun_as_coe

-- porting note: `simp` should prove this using `toFun_as_coe`, but it doesn't.
-- This might be a bug in `simp` -- see https://github.com/leanprover/lean4/issues/1937
-- If this issue is fixed then the simp linter probably will start complaining, and
-- this theorem can be deleted hopefully without breaking any `simp` proofs.
@[simp] theorem toFun_as_coe_apply (e : α ≃ β) (x : α) : e.toFun x = e x := rfl

@[simp] theorem invFun_as_coe (e : α ≃ β) : e.invFun = e.symm := rfl
#align equiv.inv_fun_as_coe Equiv.invFun_as_coe

protected theorem injective (e : α ≃ β) : Injective e := EquivLike.injective e
#align equiv.injective Equiv.injective

protected theorem surjective (e : α ≃ β) : Surjective e := EquivLike.surjective e
#align equiv.surjective Equiv.surjective

protected theorem bijective (e : α ≃ β) : Bijective e := EquivLike.bijective e
#align equiv.bijective Equiv.bijective

protected theorem subsingleton (e : α ≃ β) [Subsingleton β] : Subsingleton α :=
  e.injective.subsingleton
#align equiv.subsingleton Equiv.subsingleton

protected theorem subsingleton.symm (e : α ≃ β) [Subsingleton α] : Subsingleton β :=
  e.symm.injective.subsingleton
#align equiv.subsingleton.symm Equiv.subsingleton.symm

theorem subsingleton_congr (e : α ≃ β) : Subsingleton α ↔ Subsingleton β :=
  ⟨fun _ => e.symm.subsingleton, fun _ => e.subsingleton⟩
#align equiv.subsingleton_congr Equiv.subsingleton_congr

instance equiv_subsingleton_cod [Subsingleton β] : Subsingleton (α ≃ β) :=
  ⟨fun _ _ => Equiv.ext fun _ => Subsingleton.elim _ _⟩

instance equiv_subsingleton_dom [Subsingleton α] : Subsingleton (α ≃ β) :=
  ⟨fun f _ => Equiv.ext fun _ => @Subsingleton.elim _ (Equiv.subsingleton.symm f) _ _⟩

instance permUnique [Subsingleton α] : Unique (Perm α) :=
  uniqueOfSubsingleton (Equiv.refl α)

theorem Perm.subsingleton_eq_refl [Subsingleton α] (e : Perm α) : e = Equiv.refl α :=
  Subsingleton.elim _ _
#align equiv.perm.subsingleton_eq_refl Equiv.Perm.subsingleton_eq_refl

/-- Transfer `DecidableEq` across an equivalence. -/
protected def decidableEq (e : α ≃ β) [DecidableEq β] : DecidableEq α :=
  e.injective.decidableEq
#align equiv.decidable_eq Equiv.decidableEq

theorem nonempty_congr (e : α ≃ β) : Nonempty α ↔ Nonempty β := Nonempty.congr e e.symm
#align equiv.nonempty_congr Equiv.nonempty_congr

protected theorem nonempty (e : α ≃ β) [Nonempty β] : Nonempty α := e.nonempty_congr.mpr ‹_›
#align equiv.nonempty Equiv.nonempty

/-- If `α ≃ β` and `β` is inhabited, then so is `α`. -/
protected def inhabited [Inhabited β] (e : α ≃ β) : Inhabited α := ⟨e.symm default⟩
#align equiv.inhabited Equiv.inhabited

/-- If `α ≃ β` and `β` is a singleton type, then so is `α`. -/
protected def unique [Unique β] (e : α ≃ β) : Unique α := e.symm.surjective.unique
#align equiv.unique Equiv.unique

/-- Equivalence between equal types. -/
protected def cast {α β : Sort _} (h : α = β) : α ≃ β :=
  ⟨cast h, cast h.symm, fun _ => by cases h; rfl, fun _ => by cases h; rfl⟩
#align equiv.cast Equiv.cast

@[simp] theorem coe_fn_symm_mk (f : α → β) (g l r) : ((Equiv.mk f g l r).symm : β → α) = g := rfl
#align equiv.coe_fn_symm_mk Equiv.coe_fn_symm_mk

@[simp] theorem coe_refl : (Equiv.refl α : α → α) = id := rfl
#align equiv.coe_refl Equiv.coe_refl

/-- This cannot be a `simp` lemmas as it incorrectly matches against `e : α ≃ synonym α`, when
`synonym α` is semireducible. This makes a mess of `multiplicative.of_add` etc. -/
theorem Perm.coe_subsingleton {α : Type _} [Subsingleton α] (e : Perm α) : (e : α → α) = id := by
  rw [Perm.subsingleton_eq_refl e, coe_refl]
#align equiv.perm.coe_subsingleton Equiv.Perm.coe_subsingleton

-- porting note: marking this as `@[simp]` because `simp` doesn't fire on `coe_refl`
-- in an expression such as `Equiv.refl a x`
@[simp] theorem refl_apply (x : α) : Equiv.refl α x = x := rfl
#align equiv.refl_apply Equiv.refl_apply

@[simp] theorem coe_trans (f : α ≃ β) (g : β ≃ γ) : (f.trans g : α → γ) = g ∘ f := rfl
#align equiv.coe_trans Equiv.coe_trans

-- porting note: marking this as `@[simp]` because `simp` doesn't fire on `coe_trans`
-- in an expression such as `Equiv.trans f g x`
@[simp] theorem trans_apply (f : α ≃ β) (g : β ≃ γ) (a : α) : (f.trans g) a = g (f a) := rfl
#align equiv.trans_apply Equiv.trans_apply

@[simp] theorem apply_symm_apply (e : α ≃ β) (x : β) : e (e.symm x) = x := e.right_inv x
#align equiv.apply_symm_apply Equiv.apply_symm_apply

@[simp] theorem symm_apply_apply (e : α ≃ β) (x : α) : e.symm (e x) = x := e.left_inv x
#align equiv.symm_apply_apply Equiv.symm_apply_apply

@[simp] theorem symm_comp_self (e : α ≃ β) : e.symm ∘ e = id := funext e.symm_apply_apply
#align equiv.symm_comp_self Equiv.symm_comp_self

@[simp] theorem self_comp_symm (e : α ≃ β) : e ∘ e.symm = id := funext e.apply_symm_apply
#align equiv.self_comp_symm Equiv.self_comp_symm

@[simp] theorem symm_trans_apply (f : α ≃ β) (g : β ≃ γ) (a : γ) :
    (f.trans g).symm a = f.symm (g.symm a) := rfl
#align equiv.symm_trans_apply Equiv.symm_trans_apply

-- The `simp` attribute is needed to make this a `dsimp` lemma.
-- `simp` will always rewrite with `equiv.symm_symm` before this has a chance to fire.
@[simp, nolint simpNF] theorem symm_symm_apply (f : α ≃ β) (b : α) : f.symm.symm b = f b := rfl
#align equiv.symm_symm_apply Equiv.symm_symm_apply

theorem apply_eq_iff_eq (f : α ≃ β) {x y : α} : f x = f y ↔ x = y := EquivLike.apply_eq_iff_eq f
#align equiv.apply_eq_iff_eq Equiv.apply_eq_iff_eq

theorem apply_eq_iff_eq_symm_apply (f : α ≃ β) : f x = y ↔ x = f.symm y := by
  conv_lhs => rw [← apply_symm_apply f y]
  rw [apply_eq_iff_eq]
#align equiv.apply_eq_iff_eq_symm_apply Equiv.apply_eq_iff_eq_symm_apply

@[simp] theorem cast_apply {α β} (h : α = β) (x : α) : Equiv.cast h x = cast h x := rfl
#align equiv.cast_apply Equiv.cast_apply

@[simp] theorem cast_symm {α β} (h : α = β) : (Equiv.cast h).symm = Equiv.cast h.symm := rfl
#align equiv.cast_symm Equiv.cast_symm

@[simp] theorem cast_refl {α} (h : α = α := rfl) : Equiv.cast h = Equiv.refl α := rfl
#align equiv.cast_refl Equiv.cast_refl

@[simp] theorem cast_trans {α β γ} (h : α = β) (h2 : β = γ) :
    (Equiv.cast h).trans (Equiv.cast h2) = Equiv.cast (h.trans h2) :=
  ext fun x => by substs h h2; rfl
#align equiv.cast_trans Equiv.cast_trans

theorem cast_eq_iff_heq {α β} (h : α = β) {a : α} {b : β} : Equiv.cast h a = b ↔ HEq a b := by
  subst h; simp [coe_refl]
#align equiv.cast_eq_iff_heq Equiv.cast_eq_iff_heq

theorem symm_apply_eq {α β} (e : α ≃ β) {x y} : e.symm x = y ↔ x = e y :=
  ⟨fun H => by simp [H.symm], fun H => by simp [H]⟩
#align equiv.symm_apply_eq Equiv.symm_apply_eq

theorem eq_symm_apply {α β} (e : α ≃ β) {x y} : y = e.symm x ↔ e y = x :=
  (eq_comm.trans e.symm_apply_eq).trans eq_comm
#align equiv.eq_symm_apply Equiv.eq_symm_apply

@[simp] theorem symm_symm (e : α ≃ β) : e.symm.symm = e := by cases e; rfl
#align equiv.symm_symm Equiv.symm_symm

@[simp] theorem trans_refl (e : α ≃ β) : e.trans (Equiv.refl β) = e := by cases e; rfl
#align equiv.trans_refl Equiv.trans_refl

@[simp] theorem refl_symm : (Equiv.refl α).symm = Equiv.refl α := rfl
#align equiv.refl_symm Equiv.refl_symm

@[simp] theorem refl_trans (e : α ≃ β) : (Equiv.refl α).trans e = e := by cases e; rfl
#align equiv.refl_trans Equiv.refl_trans

@[simp] theorem symm_trans_self (e : α ≃ β) : e.symm.trans e = Equiv.refl β := ext <| by simp
#align equiv.symm_trans_self Equiv.symm_trans_self

@[simp] theorem self_trans_symm (e : α ≃ β) : e.trans e.symm = Equiv.refl α := ext <| by simp
#align equiv.self_trans_symm Equiv.self_trans_symm

theorem trans_assoc {δ} (ab : α ≃ β) (bc : β ≃ γ) (cd : γ ≃ δ) :
    (ab.trans bc).trans cd = ab.trans (bc.trans cd) := Equiv.ext fun _ => rfl
#align equiv.trans_assoc Equiv.trans_assoc

theorem leftInverse_symm (f : Equiv α β) : LeftInverse f.symm f := f.left_inv
#align equiv.left_inverse_symm Equiv.leftInverse_symm

theorem rightInverse_symm (f : Equiv α β) : Function.RightInverse f.symm f := f.right_inv
#align equiv.right_inverse_symm Equiv.rightInverse_symm

theorem injective_comp (e : α ≃ β) (f : β → γ) : Injective (f ∘ e) ↔ Injective f :=
  EquivLike.injective_comp e f
#align equiv.injective_comp Equiv.injective_comp

theorem comp_injective (f : α → β) (e : β ≃ γ) : Injective (e ∘ f) ↔ Injective f :=
  EquivLike.comp_injective f e
#align equiv.comp_injective Equiv.comp_injective

theorem surjective_comp (e : α ≃ β) (f : β → γ) : Surjective (f ∘ e) ↔ Surjective f :=
  EquivLike.surjective_comp e f
#align equiv.surjective_comp Equiv.surjective_comp

theorem comp_surjective (f : α → β) (e : β ≃ γ) : Surjective (e ∘ f) ↔ Surjective f :=
  EquivLike.comp_surjective f e
#align equiv.comp_surjective Equiv.comp_surjective

theorem bijective_comp (e : α ≃ β) (f : β → γ) : Bijective (f ∘ e) ↔ Bijective f :=
  EquivLike.bijective_comp e f
#align equiv.bijective_comp Equiv.bijective_comp

theorem comp_bijective (f : α → β) (e : β ≃ γ) : Bijective (e ∘ f) ↔ Bijective f :=
  EquivLike.comp_bijective f e
#align equiv.comp_bijective Equiv.comp_bijective

/-- If `α` is equivalent to `β` and `γ` is equivalent to `δ`, then the type of equivalences `α ≃ γ`
is equivalent to the type of equivalences `β ≃ δ`. -/
def equivCongr (ab : α ≃ β) (cd : γ ≃ δ) : (α ≃ γ) ≃ (β ≃ δ) where
  toFun ac := (ab.symm.trans ac).trans cd
  invFun bd := ab.trans <| bd.trans <| cd.symm
  left_inv ac := by ext x; simp only [trans_apply, comp_apply, symm_apply_apply]
  right_inv ac := by ext x; simp only [trans_apply, comp_apply, apply_symm_apply]
#align equiv.equiv_congr Equiv.equivCongr

@[simp] theorem equivCongr_refl {α β} :
    (Equiv.refl α).equivCongr (Equiv.refl β) = Equiv.refl (α ≃ β) := by ext; rfl
#align equiv.equiv_congr_refl Equiv.equivCongr_refl

@[simp] theorem equivCongr_symm {δ} (ab : α ≃ β) (cd : γ ≃ δ) :
    (ab.equivCongr cd).symm = ab.symm.equivCongr cd.symm := by ext; rfl
#align equiv.equiv_congr_symm Equiv.equivCongr_symm

@[simp] theorem equivCongr_trans {δ ε ζ} (ab : α ≃ β) (de : δ ≃ ε) (bc : β ≃ γ) (ef : ε ≃ ζ) :
    (ab.equivCongr de).trans (bc.equivCongr ef) = (ab.trans bc).equivCongr (de.trans ef) := by
  ext; rfl
#align equiv.equiv_congr_trans Equiv.equivCongr_trans

@[simp] theorem equivCongr_refl_left {α β γ} (bg : β ≃ γ) (e : α ≃ β) :
    (Equiv.refl α).equivCongr bg e = e.trans bg := rfl
#align equiv.equiv_congr_refl_left Equiv.equivCongr_refl_left

@[simp] theorem equivCongr_refl_right {α β} (ab e : α ≃ β) :
    ab.equivCongr (Equiv.refl β) e = ab.symm.trans e := rfl
#align equiv.equiv_congr_refl_right Equiv.equivCongr_refl_right

@[simp] theorem equivCongr_apply_apply {δ} (ab : α ≃ β) (cd : γ ≃ δ) (e : α ≃ γ) (x) :
    ab.equivCongr cd e x = cd (e (ab.symm x)) := rfl
#align equiv.equiv_congr_apply_apply Equiv.equivCongr_apply_apply

section permCongr

variable {α' β' : Type _} (e : α' ≃ β')

/-- If `α` is equivalent to `β`, then `Perm α` is equivalent to `Perm β`. -/
def permCongr : Perm α' ≃ Perm β' := equivCongr e e
#align equiv.perm_congr Equiv.permCongr

theorem permCongr_def (p : Equiv.Perm α') : e.permCongr p = (e.symm.trans p).trans e := rfl
#align equiv.perm_congr_def Equiv.permCongr_def

@[simp] theorem permCongr_refl : e.permCongr (Equiv.refl _) = Equiv.refl _ := by
  simp [permCongr_def]
#align equiv.perm_congr_refl Equiv.permCongr_refl

@[simp] theorem permCongr_symm : e.permCongr.symm = e.symm.permCongr := rfl
#align equiv.perm_congr_symm Equiv.permCongr_symm

@[simp] theorem permCongr_apply (p : Equiv.Perm α') (x) : e.permCongr p x = e (p (e.symm x)) := rfl
#align equiv.perm_congr_apply Equiv.permCongr_apply

theorem permCongr_symm_apply (p : Equiv.Perm β') (x) :
    e.permCongr.symm p x = e.symm (p (e x)) := rfl
#align equiv.perm_congr_symm_apply Equiv.permCongr_symm_apply

theorem permCongr_trans (p p' : Equiv.Perm α') :
    (e.permCongr p).trans (e.permCongr p') = e.permCongr (p.trans p') := by
  ext; simp only [trans_apply, comp_apply, permCongr_apply, symm_apply_apply]
#align equiv.perm_congr_trans Equiv.permCongr_trans

end permCongr

/-- Two empty types are equivalent. -/
def equivOfIsEmpty (α β : Sort _) [IsEmpty α] [IsEmpty β] : α ≃ β :=
  ⟨isEmptyElim, isEmptyElim, isEmptyElim, isEmptyElim⟩
#align equiv.equiv_of_is_empty Equiv.equivOfIsEmpty

/-- If `α` is an empty type, then it is equivalent to the `Empty` type. -/
def equivEmpty (α : Sort u) [IsEmpty α] : α ≃ Empty := equivOfIsEmpty α _
#align equiv.equiv_empty Equiv.equivEmpty

/-- If `α` is an empty type, then it is equivalent to the `PEmpty` type in any universe. -/
def equivPEmpty (α : Sort v) [IsEmpty α] : α ≃ PEmpty.{u} := equivOfIsEmpty α _
#align equiv.equiv_pempty Equiv.equivPEmpty

/-- `α` is equivalent to an empty type iff `α` is empty. -/
def equivEmptyEquiv (α : Sort u) : α ≃ Empty ≃ IsEmpty α :=
  ⟨fun e => Function.isEmpty e, @equivEmpty α, fun e => ext fun x => (e x).elim, fun _ => rfl⟩
#align equiv.equiv_empty_equiv Equiv.equivEmptyEquiv

/-- The `Sort` of proofs of a false proposition is equivalent to `PEmpty`. -/
def propEquivPEmpty {p : Prop} (h : ¬p) : p ≃ PEmpty := @equivPEmpty p <| IsEmpty.prop_iff.2 h
#align equiv.prop_equiv_pempty Equiv.propEquivPEmpty

/-- If both `α` and `β` have a unique element, then `α ≃ β`. -/
def equivOfUnique (α β : Sort _) [Unique.{u} α] [Unique.{v} β] : α ≃ β where
  toFun := default
  invFun := default
  left_inv _ := Subsingleton.elim _ _
  right_inv _ := Subsingleton.elim _ _
#align equiv.equiv_of_unique Equiv.equivOfUnique

/-- If `α` has a unique element, then it is equivalent to any `PUnit`. -/
def equivPUnit (α : Sort u) [Unique α] : α ≃ PUnit.{v} := equivOfUnique α _
#align equiv.equiv_punit Equiv.equivPUnit

/-- The `Sort` of proofs of a true proposition is equivalent to `PUnit`. -/
def propEquivPUnit {p : Prop} (h : p) : p ≃ PUnit.{0} := @equivPUnit p <| uniqueProp h
#align equiv.prop_equiv_punit Equiv.propEquivPUnit

/-- `ULift α` is equivalent to `α`. -/
@[simps (config := { fullyApplied := false }) apply]
protected def ulift {α : Type v} : ULift.{u} α ≃ α :=
  ⟨ULift.down, ULift.up, ULift.up_down, fun _ => rfl⟩
#align equiv.ulift Equiv.ulift
#align equiv.ulift_apply Equiv.ulift_apply

/-- `PLift α` is equivalent to `α`. -/
@[simps (config := { fullyApplied := false }) apply]
protected def plift : PLift α ≃ α := ⟨PLift.down, PLift.up, PLift.up_down, PLift.down_up⟩
#align equiv.plift Equiv.plift
#align equiv.plift_apply Equiv.plift_apply

/-- equivalence of propositions is the same as iff -/
def ofIff {P Q : Prop} (h : P ↔ Q) : P ≃ Q := ⟨h.mp, h.mpr, fun _ => rfl, fun _ => rfl⟩
#align equiv.of_iff Equiv.ofIff

/-- If `α₁` is equivalent to `α₂` and `β₁` is equivalent to `β₂`, then the type of maps `α₁ → β₁`
is equivalent to the type of maps `α₂ → β₂`. -/
-- porting note: removing `congr` attribute
@[simps apply]
def arrowCongr {α₁ β₁ α₂ β₂ : Sort _} (e₁ : α₁ ≃ α₂) (e₂ : β₁ ≃ β₂) : (α₁ → β₁) ≃ (α₂ → β₂) where
  toFun f := e₂ ∘ f ∘ e₁.symm
  invFun f := e₂.symm ∘ f ∘ e₁
  left_inv f := funext fun x => by simp only [comp_apply, symm_apply_apply]
  right_inv f := funext fun x => by simp only [comp_apply, apply_symm_apply]
#align equiv.arrow_congr_apply Equiv.arrowCongr_apply
#align equiv.arrow_congr Equiv.arrowCongr

theorem arrowCongr_comp {α₁ β₁ γ₁ α₂ β₂ γ₂ : Sort _} (ea : α₁ ≃ α₂) (eb : β₁ ≃ β₂) (ec : γ₁ ≃ γ₂)
    (f : α₁ → β₁) (g : β₁ → γ₁) :
    arrowCongr ea ec (g ∘ f) = arrowCongr eb ec g ∘ arrowCongr ea eb f := by
  ext; simp only [comp, arrowCongr_apply, eb.symm_apply_apply]
#align equiv.arrow_congr_comp Equiv.arrowCongr_comp

@[simp] theorem arrowCongr_refl {α β : Sort _} :
    arrowCongr (Equiv.refl α) (Equiv.refl β) = Equiv.refl (α → β) := rfl
#align equiv.arrow_congr_refl Equiv.arrowCongr_refl

@[simp] theorem arrowCongr_trans (e₁ : α₁ ≃ α₂) (e₁' : β₁ ≃ β₂) (e₂ : α₂ ≃ α₃) (e₂' : β₂ ≃ β₃) :
    arrowCongr (e₁.trans e₂) (e₁'.trans e₂') = (arrowCongr e₁ e₁').trans (arrowCongr e₂ e₂') := rfl
#align equiv.arrow_congr_trans Equiv.arrowCongr_trans

@[simp] theorem arrowCongr_symm (e₁ : α₁ ≃ α₂) (e₂ : β₁ ≃ β₂) :
    (arrowCongr e₁ e₂).symm = arrowCongr e₁.symm e₂.symm := rfl
#align equiv.arrow_congr_symm Equiv.arrowCongr_symm

/-- A version of `Equiv.arrowCongr` in `Type`, rather than `Sort`.

The `equiv_rw` tactic is not able to use the default `Sort` level `Equiv.arrowCongr`,
because Lean's universe rules will not unify `?l_1` with `imax (1 ?m_1)`.
-/
-- porting note: removing `congr` attribute
@[simps! apply]
def arrowCongr' {α₁ β₁ α₂ β₂ : Type _} (hα : α₁ ≃ α₂) (hβ : β₁ ≃ β₂) : (α₁ → β₁) ≃ (α₂ → β₂) :=
  Equiv.arrowCongr hα hβ
#align equiv.arrow_congr' Equiv.arrowCongr'
#align equiv.arrow_congr'_apply Equiv.arrowCongr'_apply

@[simp] theorem arrowCongr'_refl {α β : Type _} :
    arrowCongr' (Equiv.refl α) (Equiv.refl β) = Equiv.refl (α → β) := rfl
#align equiv.arrow_congr'_refl Equiv.arrowCongr'_refl

@[simp] theorem arrowCongr'_trans
    (e₁ : α₁ ≃ α₂) (e₁' : β₁ ≃ β₂) (e₂ : α₂ ≃ α₃) (e₂' : β₂ ≃ β₃) :
    arrowCongr' (e₁.trans e₂) (e₁'.trans e₂') = (arrowCongr' e₁ e₁').trans (arrowCongr' e₂ e₂') :=
  rfl
#align equiv.arrow_congr'_trans Equiv.arrowCongr'_trans

@[simp] theorem arrowCongr'_symm (e₁ : α₁ ≃ α₂) (e₂ : β₁ ≃ β₂) :
    (arrowCongr' e₁ e₂).symm = arrowCongr' e₁.symm e₂.symm := rfl
#align equiv.arrow_congr'_symm Equiv.arrowCongr'_symm

/-- Conjugate a map `f : α → α` by an equivalence `α ≃ β`. -/
@[simps! apply] def conj (e : α ≃ β) : (α → α) ≃ (β → β) := arrowCongr e e
#align equiv.conj Equiv.conj
#align equiv.conj_apply Equiv.conj_apply

@[simp] theorem conj_refl : conj (Equiv.refl α) = Equiv.refl (α → α) := rfl
#align equiv.conj_refl Equiv.conj_refl

@[simp] theorem conj_symm (e : α ≃ β) : e.conj.symm = e.symm.conj := rfl
#align equiv.conj_symm Equiv.conj_symm

@[simp] theorem conj_trans (e₁ : α ≃ β) (e₂ : β ≃ γ) :
    (e₁.trans e₂).conj = e₁.conj.trans e₂.conj := rfl
#align equiv.conj_trans Equiv.conj_trans

-- This should not be a simp lemma as long as `(∘)` is reducible:
-- when `(∘)` is reducible, Lean can unify `f₁ ∘ f₂` with any `g` using
-- `f₁ := g` and `f₂ := λ x, x`.  This causes nontermination.
theorem conj_comp (e : α ≃ β) (f₁ f₂ : α → α) : e.conj (f₁ ∘ f₂) = e.conj f₁ ∘ e.conj f₂ := by
  apply arrowCongr_comp
#align equiv.conj_comp Equiv.conj_comp

theorem eq_comp_symm {α β γ} (e : α ≃ β) (f : β → γ) (g : α → γ) : f = g ∘ e.symm ↔ f ∘ e = g :=
  (e.arrowCongr (Equiv.refl γ)).symm_apply_eq.symm
#align equiv.eq_comp_symm Equiv.eq_comp_symm

theorem comp_symm_eq {α β γ} (e : α ≃ β) (f : β → γ) (g : α → γ) : g ∘ e.symm = f ↔ g = f ∘ e :=
  (e.arrowCongr (Equiv.refl γ)).eq_symm_apply.symm
#align equiv.comp_symm_eq Equiv.comp_symm_eq

theorem eq_symm_comp {α β γ} (e : α ≃ β) (f : γ → α) (g : γ → β) : f = e.symm ∘ g ↔ e ∘ f = g :=
  ((Equiv.refl γ).arrowCongr e).eq_symm_apply
#align equiv.eq_symm_comp Equiv.eq_symm_comp

theorem symm_comp_eq {α β γ} (e : α ≃ β) (f : γ → α) (g : γ → β) : e.symm ∘ g = f ↔ g = e ∘ f :=
  ((Equiv.refl γ).arrowCongr e).symm_apply_eq
#align equiv.symm_comp_eq Equiv.symm_comp_eq

/-- `PUnit` sorts in any two universes are equivalent. -/
def punitEquivPUnit : PUnit.{v} ≃ PUnit.{w} :=
  ⟨fun _ => .unit, fun _ => .unit, fun ⟨⟩ => rfl, fun ⟨⟩ => rfl⟩
#align equiv.punit_equiv_punit Equiv.punitEquivPUnit

/-- `Prop` is noncomputably equivalent to `Bool`. -/
noncomputable def propEquivBool : Prop ≃ Bool where
  toFun p := @decide p (Classical.propDecidable _)
  invFun b := b
  left_inv p := by simp [@Bool.decide_iff p (Classical.propDecidable _)]
  right_inv b := by cases b <;> simp
#align equiv.Prop_equiv_bool Equiv.propEquivBool

section

/-- The sort of maps to `PUnit.{v}` is equivalent to `PUnit.{w}`. -/
def arrowPUnitEquivPUnit (α : Sort _) : (α → PUnit.{v}) ≃ PUnit.{w} :=
  ⟨fun _ => .unit, fun _ _ => .unit, fun _ => rfl, fun _ => rfl⟩
#align equiv.arrow_punit_equiv_punit Equiv.arrowPUnitEquivPUnit

/-- If `α` is `Subsingleton` and `a : α`, then the type of dependent functions `Π (i : α), β i`
is equivalent to `β a`. -/
@[simps] def piSubsingleton (β : α → Sort _) [Subsingleton α] (a : α) : (∀ a', β a') ≃ β a where
  toFun := eval a
  invFun x b := cast (congr_arg β <| Subsingleton.elim a b) x
  left_inv _ := funext fun b => by rw [Subsingleton.elim b a]; rfl
  right_inv _ := rfl
#align equiv.Pi_subsingleton_apply Equiv.piSubsingleton_apply
#align equiv.Pi_subsingleton_symm_apply Equiv.piSubsingleton_symm_apply
#align equiv.Pi_subsingleton Equiv.piSubsingleton

/-- If `α` has a unique term, then the type of function `α → β` is equivalent to `β`. -/
@[simps! (config := { fullyApplied := false }) apply]
def funUnique (α β) [Unique.{u} α] : (α → β) ≃ β := piSubsingleton _ default
#align equiv.fun_unique Equiv.funUnique
#align equiv.fun_unique_apply Equiv.funUnique_apply

/-- The sort of maps from `PUnit` is equivalent to the codomain. -/
def punitArrowEquiv (α : Sort _) : (PUnit.{u} → α) ≃ α := funUnique PUnit.{u} α
#align equiv.punit_arrow_equiv Equiv.punitArrowEquiv

/-- The sort of maps from `True` is equivalent to the codomain. -/
def trueArrowEquiv (α : Sort _) : (True → α) ≃ α := funUnique _ _
#align equiv.true_arrow_equiv Equiv.trueArrowEquiv

/-- The sort of maps from a type that `IsEmpty` is equivalent to `PUnit`. -/
def arrowPUnitOfIsEmpty (α β : Sort _) [IsEmpty α] : (α → β) ≃ PUnit.{u} where
  toFun _ := PUnit.unit
  invFun _ := isEmptyElim
  left_inv _ := funext isEmptyElim
  right_inv _ := rfl
#align equiv.arrow_punit_of_is_empty Equiv.arrowPUnitOfIsEmpty

/-- The sort of maps from `Empty` is equivalent to `PUnit`. -/
def emptyArrowEquivPUnit (α : Sort _) : (Empty → α) ≃ PUnit.{u} := arrowPUnitOfIsEmpty _ _
#align equiv.empty_arrow_equiv_punit Equiv.emptyArrowEquivPUnit

/-- The sort of maps from `PEmpty` is equivalent to `PUnit`. -/
def pemptyArrowEquivPUnit (α : Sort _) : (PEmpty → α) ≃ PUnit.{u} := arrowPUnitOfIsEmpty _ _
#align equiv.pempty_arrow_equiv_punit Equiv.pemptyArrowEquivPUnit

/-- The sort of maps from `False` is equivalent to `PUnit`. -/
def falseArrowEquivPUnit (α : Sort _) : (False → α) ≃ PUnit.{u} := arrowPUnitOfIsEmpty _ _
#align equiv.false_arrow_equiv_punit Equiv.falseArrowEquivPUnit

end

section

/-- A `PSigma`-type is equivalent to the corresponding `Sigma`-type. -/
@[simps apply symm_apply]
def psigmaEquivSigma {α} (β : α → Type _) : (Σ' i, β i) ≃ Σ i, β i where
  toFun a := ⟨a.1, a.2⟩
  invFun a := ⟨a.1, a.2⟩
  left_inv _ := rfl
  right_inv _ := rfl
#align equiv.psigma_equiv_sigma Equiv.psigmaEquivSigma
#align equiv.psigma_equiv_sigma_symm_apply Equiv.psigmaEquivSigma_symm_apply
#align equiv.psigma_equiv_sigma_apply Equiv.psigmaEquivSigma_apply

/-- A `PSigma`-type is equivalent to the corresponding `Sigma`-type. -/
@[simps apply symm_apply]
def psigmaEquivSigmaPLift {α} (β : α → Sort _) : (Σ' i, β i) ≃ Σ i : PLift α, PLift (β i.down) where
  toFun a := ⟨PLift.up a.1, PLift.up a.2⟩
  invFun a := ⟨a.1.down, a.2.down⟩
  left_inv _ := rfl
  right_inv _ := rfl
#align equiv.psigma_equiv_sigma_plift Equiv.psigmaEquivSigmaPLift
#align equiv.psigma_equiv_sigma_plift_symm_apply Equiv.psigmaEquivSigmaPLift_symm_apply
#align equiv.psigma_equiv_sigma_plift_apply Equiv.psigmaEquivSigmaPLift_apply

/-- A family of equivalences `Π a, β₁ a ≃ β₂ a` generates an equivalence between `Σ' a, β₁ a` and
`Σ' a, β₂ a`. -/
@[simps apply]
def psigmaCongrRight {β₁ β₂ : α → Sort _} (F : ∀ a, β₁ a ≃ β₂ a) : (Σ' a, β₁ a) ≃ Σ' a, β₂ a where
  toFun a := ⟨a.1, F a.1 a.2⟩
  invFun a := ⟨a.1, (F a.1).symm a.2⟩
  left_inv | ⟨a, b⟩ => congr_arg (PSigma.mk a) <| symm_apply_apply (F a) b
  right_inv | ⟨a, b⟩ => congr_arg (PSigma.mk a) <| apply_symm_apply (F a) b
#align equiv.psigma_congr_right Equiv.psigmaCongrRight
#align equiv.psigma_congr_right_apply Equiv.psigmaCongrRight_apply

-- Porting note: simp can now simplify the LHS, so I have removed `@[simp]`
theorem psigmaCongrRight_trans {α} {β₁ β₂ β₃ : α → Sort _}
    (F : ∀ a, β₁ a ≃ β₂ a) (G : ∀ a, β₂ a ≃ β₃ a) :
    (psigmaCongrRight F).trans (psigmaCongrRight G) =
      psigmaCongrRight fun a => (F a).trans (G a) := rfl
#align equiv.psigma_congr_right_trans Equiv.psigmaCongrRight_trans

-- Porting note: simp can now simplify the LHS, so I have removed `@[simp]`

-- Porting note: simp can now prove this, so I have removed `@[simp]`
theorem psigmaCongrRight_refl {α} {β : α → Sort _} :
    (psigmaCongrRight fun a => Equiv.refl (β a)) = Equiv.refl (Σ' a, β a) := rfl
#align equiv.psigma_congr_right_refl Equiv.psigmaCongrRight_refl

/-- A family of equivalences `Π a, β₁ a ≃ β₂ a` generates an equivalence between `Σ a, β₁ a` and
`Σ a, β₂ a`. -/
@[simps apply]
def sigmaCongrRight {α} {β₁ β₂ : α → Type _} (F : ∀ a, β₁ a ≃ β₂ a) : (Σ a, β₁ a) ≃ Σ a, β₂ a where
  toFun a := ⟨a.1, F a.1 a.2⟩
  invFun a := ⟨a.1, (F a.1).symm a.2⟩
  left_inv | ⟨a, b⟩ => congr_arg (Sigma.mk a) <| symm_apply_apply (F a) b
  right_inv | ⟨a, b⟩ => congr_arg (Sigma.mk a) <| apply_symm_apply (F a) b
#align equiv.sigma_congr_right Equiv.sigmaCongrRight
#align equiv.sigma_congr_right_apply Equiv.sigmaCongrRight_apply

-- Porting note: simp can now simplify the LHS, so I have removed `@[simp]`
theorem sigmaCongrRight_trans {α} {β₁ β₂ β₃ : α → Type _}
    (F : ∀ a, β₁ a ≃ β₂ a) (G : ∀ a, β₂ a ≃ β₃ a) :
    (sigmaCongrRight F).trans (sigmaCongrRight G) =
      sigmaCongrRight fun a => (F a).trans (G a) := rfl
#align equiv.sigma_congr_right_trans Equiv.sigmaCongrRight_trans

-- Porting note: simp can now simplify the LHS, so I have removed `@[simp]`
theorem sigmaCongrRight_symm {α} {β₁ β₂ : α → Type _} (F : ∀ a, β₁ a ≃ β₂ a) :
    (sigmaCongrRight F).symm = sigmaCongrRight fun a => (F a).symm := rfl
#align equiv.sigma_congr_right_symm Equiv.sigmaCongrRight_symm

-- Porting note: simp can now prove this, so I have removed `@[simp]`
theorem sigmaCongrRight_refl {α} {β : α → Type _} :
    (sigmaCongrRight fun a => Equiv.refl (β a)) = Equiv.refl (Σ a, β a) := rfl
#align equiv.sigma_congr_right_refl Equiv.sigmaCongrRight_refl

/-- A `PSigma` with `Prop` fibers is equivalent to the subtype.  -/
def psigmaEquivSubtype {α : Type v} (P : α → Prop) : (Σ' i, P i) ≃ Subtype P where
  toFun x := ⟨x.1, x.2⟩
  invFun x := ⟨x.1, x.2⟩
  left_inv _ := rfl
  right_inv _ := rfl
#align equiv.psigma_equiv_subtype Equiv.psigmaEquivSubtype

/-- A `Sigma` with `PLift` fibers is equivalent to the subtype. -/
def sigmaPLiftEquivSubtype {α : Type v} (P : α → Prop) : (Σ i, PLift (P i)) ≃ Subtype P :=
  ((psigmaEquivSigma _).symm.trans
    (psigmaCongrRight fun _ => Equiv.plift)).trans (psigmaEquivSubtype P)
#align equiv.sigma_plift_equiv_subtype Equiv.sigmaPLiftEquivSubtype

/-- A `Sigma` with `λ i, ULift (PLift (P i))` fibers is equivalent to `{ x // P x }`.
Variant of `sigmaPLiftEquivSubtype`.
-/
def sigmaULiftPLiftEquivSubtype {α : Type v} (P : α → Prop) :
    (Σ i, ULift (PLift (P i))) ≃ Subtype P :=
  (sigmaCongrRight fun _ => Equiv.ulift).trans (sigmaPLiftEquivSubtype P)
#align equiv.sigma_ulift_plift_equiv_subtype Equiv.sigmaULiftPLiftEquivSubtype

namespace Perm

/-- A family of permutations `Π a, Perm (β a)` generates a permuation `Perm (Σ a, β₁ a)`. -/
@[reducible] def sigmaCongrRight {α} {β : α → Sort _} (F : ∀ a, Perm (β a)) : Perm (Σ a, β a) :=
  Equiv.sigmaCongrRight F
#align equiv.perm.sigma_congr_right Equiv.Perm.sigmaCongrRight

@[simp] theorem sigmaCongrRight_trans {α} {β : α → Sort _}
    (F : ∀ a, Perm (β a)) (G : ∀ a, Perm (β a)) :
    (sigmaCongrRight F).trans (sigmaCongrRight G) = sigmaCongrRight fun a => (F a).trans (G a) :=
  Equiv.sigmaCongrRight_trans F G
#align equiv.perm.sigma_congr_right_trans Equiv.Perm.sigmaCongrRight_trans

@[simp] theorem sigmaCongrRight_symm {α} {β : α → Sort _} (F : ∀ a, Perm (β a)) :
    (sigmaCongrRight F).symm = sigmaCongrRight fun a => (F a).symm :=
  Equiv.sigmaCongrRight_symm F
#align equiv.perm.sigma_congr_right_symm Equiv.Perm.sigmaCongrRight_symm

@[simp] theorem sigmaCongrRight_refl {α} {β : α → Sort _} :
    (sigmaCongrRight fun a => Equiv.refl (β a)) = Equiv.refl (Σ a, β a) :=
  Equiv.sigmaCongrRight_refl
#align equiv.perm.sigma_congr_right_refl Equiv.Perm.sigmaCongrRight_refl

end Perm

/-- An equivalence `f : α₁ ≃ α₂` generates an equivalence between `Σ a, β (f a)` and `Σ a, β a`. -/
@[simps apply] def sigmaCongrLeft {β : α₂ → Sort _} (e : α₁ ≃ α₂) :
    (Σ a : α₁, β (e a)) ≃ Σ a : α₂, β a where
  toFun a := ⟨e a.1, a.2⟩
  invFun a := ⟨e.symm a.1, (e.right_inv' a.1).symm ▸ a.2⟩
  -- porting note: this was a pretty gnarly match already, and it got worse after porting
  left_inv := fun ⟨a, b⟩ =>
    match (motive := ∀ a' (h : a' = a), Sigma.mk _ (congr_arg e h.symm ▸ b) = ⟨a, b⟩)
      e.symm (e a), e.left_inv a with
    | _, rfl => rfl
  right_inv := fun ⟨a, b⟩ =>
    match (motive := ∀ a' (h : a' = a), Sigma.mk a' (h.symm ▸ b) = ⟨a, b⟩)
      e (e.symm a), e.apply_symm_apply _ with
    | _, rfl => rfl
#align equiv.sigma_congr_left_apply Equiv.sigmaCongrLeft_apply
#align equiv.sigma_congr_left Equiv.sigmaCongrLeft

/-- Transporting a sigma type through an equivalence of the base -/
def sigmaCongrLeft' {α₁ α₂} {β : α₁ → Sort _} (f : α₁ ≃ α₂) :
    (Σ a : α₁, β a) ≃ Σ a : α₂, β (f.symm a) := (sigmaCongrLeft f.symm).symm
#align equiv.sigma_congr_left' Equiv.sigmaCongrLeft'

/-- Transporting a sigma type through an equivalence of the base and a family of equivalences
of matching fibers -/
def sigmaCongr {α₁ α₂} {β₁ : α₁ → Sort _} {β₂ : α₂ → Sort _} (f : α₁ ≃ α₂)
    (F : ∀ a, β₁ a ≃ β₂ (f a)) : Sigma β₁ ≃ Sigma β₂ :=
  (sigmaCongrRight F).trans (sigmaCongrLeft f)
#align equiv.sigma_congr Equiv.sigmaCongr

/-- `Sigma` type with a constant fiber is equivalent to the product. -/
@[simps apply symm_apply] def sigmaEquivProd (α β : Type _) : (Σ _ : α, β) ≃ α × β :=
  ⟨fun a => ⟨a.1, a.2⟩, fun a => ⟨a.1, a.2⟩, fun ⟨_, _⟩ => rfl, fun ⟨_, _⟩ => rfl⟩
#align equiv.sigma_equiv_prod_apply Equiv.sigmaEquivProd_apply
#align equiv.sigma_equiv_prod_symm_apply Equiv.sigmaEquivProd_symm_apply
#align equiv.sigma_equiv_prod Equiv.sigmaEquivProd

/-- If each fiber of a `Sigma` type is equivalent to a fixed type, then the sigma type
is equivalent to the product. -/
def sigmaEquivProdOfEquiv {α β} {β₁ : α → Sort _} (F : ∀ a, β₁ a ≃ β) : Sigma β₁ ≃ α × β :=
  (sigmaCongrRight F).trans (sigmaEquivProd α β)
#align equiv.sigma_equiv_prod_of_equiv Equiv.sigmaEquivProdOfEquiv

/-- Dependent product of types is associative up to an equivalence. -/
def sigmaAssoc {α : Type _} {β : α → Type _} (γ : ∀ a : α, β a → Type _) :
    (Σ ab : Σ a : α, β a, γ ab.1 ab.2) ≃ Σ a : α, Σ b : β a, γ a b where
  toFun x := ⟨x.1.1, ⟨x.1.2, x.2⟩⟩
  invFun x := ⟨⟨x.1, x.2.1⟩, x.2.2⟩
  left_inv _ := rfl
  right_inv _ := rfl
#align equiv.sigma_assoc Equiv.sigmaAssoc

end

protected theorem exists_unique_congr {p : α → Prop} {q : β → Prop}
    (f : α ≃ β) (h : ∀ {x}, p x ↔ q (f x)) : (∃! x, p x) ↔ ∃! y, q y := by
  constructor
  · rintro ⟨a, ha₁, ha₂⟩
    exact ⟨f a, h.1 ha₁, fun b hb => f.symm_apply_eq.1 (ha₂ (f.symm b) (h.2 (by simpa using hb)))⟩
  · rintro ⟨b, hb₁, hb₂⟩
    exact ⟨f.symm b, h.2 (by simpa using hb₁), fun y hy => (eq_symm_apply f).2 (hb₂ _ (h.1 hy))⟩
#align equiv.exists_unique_congr Equiv.exists_unique_congr

protected theorem exists_unique_congr_left' {p : α → Prop} (f : α ≃ β) :
    (∃! x, p x) ↔ ∃! y, p (f.symm y) := Equiv.exists_unique_congr f fun {_} => by simp
#align equiv.exists_unique_congr_left' Equiv.exists_unique_congr_left'

protected theorem exists_unique_congr_left {p : β → Prop} (f : α ≃ β) :
    (∃! x, p (f x)) ↔ ∃! y, p y := (Equiv.exists_unique_congr_left' f.symm).symm
#align equiv.exists_unique_congr_left Equiv.exists_unique_congr_left

protected theorem forall_congr {p : α → Prop} {q : β → Prop} (f : α ≃ β)
    (h : ∀ {x}, p x ↔ q (f x)) : (∀ x, p x) ↔ (∀ y, q y) := by
  constructor <;> intro h₂ x
  . rw [← f.right_inv x]; apply h.mp; apply h₂
  · apply h.mpr; apply h₂
#align equiv.forall_congr Equiv.forall_congr

protected theorem forall_congr' {p : α → Prop} {q : β → Prop} (f : α ≃ β)
    (h : ∀ {x}, p (f.symm x) ↔ q x) : (∀ x, p x) ↔ ∀ y, q y :=
  (Equiv.forall_congr f.symm h.symm).symm
#align equiv.forall_congr' Equiv.forall_congr'

-- We next build some higher arity versions of `Equiv.forall_congr`.
-- Although they appear to just be repeated applications of `Equiv.forall_congr`,
-- unification of metavariables works better with these versions.
-- In particular, they are necessary in `equiv_rw`.
-- (Stopping at ternary functions seems reasonable: at least in 1-categorical mathematics,
-- it's rare to have axioms involving more than 3 elements at once.)

protected theorem forall₂_congr {p : α₁ → β₁ → Prop} {q : α₂ → β₂ → Prop} (eα : α₁ ≃ α₂)
    (eβ : β₁ ≃ β₂) (h : ∀ {x y}, p x y ↔ q (eα x) (eβ y)) : (∀ x y, p x y) ↔ ∀ x y, q x y :=
  Equiv.forall_congr _ <| Equiv.forall_congr _ h
#align equiv.forall₂_congr Equiv.forall₂_congr

protected theorem forall₂_congr' {p : α₁ → β₁ → Prop} {q : α₂ → β₂ → Prop}
    (eα : α₁ ≃ α₂) (eβ : β₁ ≃ β₂) (h : ∀ {x y}, p (eα.symm x) (eβ.symm y) ↔ q x y) :
    (∀ x y, p x y) ↔ ∀ x y, q x y := (Equiv.forall₂_congr eα.symm eβ.symm h.symm).symm
#align equiv.forall₂_congr' Equiv.forall₂_congr'

protected theorem forall₃_congr {p : α₁ → β₁ → γ₁ → Prop} {q : α₂ → β₂ → γ₂ → Prop}
    (eα : α₁ ≃ α₂) (eβ : β₁ ≃ β₂) (eγ : γ₁ ≃ γ₂) (h : ∀ {x y z}, p x y z ↔ q (eα x) (eβ y) (eγ z)) :
    (∀ x y z, p x y z) ↔ ∀ x y z, q x y z :=
  Equiv.forall₂_congr _ _ <| Equiv.forall_congr _ h
#align equiv.forall₃_congr Equiv.forall₃_congr

protected theorem forall₃_congr' {p : α₁ → β₁ → γ₁ → Prop} {q : α₂ → β₂ → γ₂ → Prop}
    (eα : α₁ ≃ α₂) (eβ : β₁ ≃ β₂) (eγ : γ₁ ≃ γ₂)
    (h : ∀ {x y z}, p (eα.symm x) (eβ.symm y) (eγ.symm z) ↔ q x y z) :
    (∀ x y z, p x y z) ↔ ∀ x y z, q x y z :=
  (Equiv.forall₃_congr eα.symm eβ.symm eγ.symm h.symm).symm
#align equiv.forall₃_congr' Equiv.forall₃_congr'

protected theorem forall_congr_left' {p : α → Prop} (f : α ≃ β) : (∀ x, p x) ↔ ∀ y, p (f.symm y) :=
  Equiv.forall_congr f <| by simp
#align equiv.forall_congr_left' Equiv.forall_congr_left'

protected theorem forall_congr_left {p : β → Prop} (f : α ≃ β) : (∀ x, p (f x)) ↔ ∀ y, p y :=
  (Equiv.forall_congr_left' f.symm).symm
#align equiv.forall_congr_left Equiv.forall_congr_left

protected theorem exists_congr_left {α β} (f : α ≃ β) {p : α → Prop} :
    (∃ a, p a) ↔ ∃ b, p (f.symm b) :=
  ⟨fun ⟨a, h⟩ => ⟨f a, by simpa using h⟩, fun ⟨b, h⟩ => ⟨_, h⟩⟩
#align equiv.exists_congr_left Equiv.exists_congr_left

end Equiv

namespace Quot

/-- An equivalence `e : α ≃ β` generates an equivalence between quotient spaces,
if `ra a₁ a₂ ↔ rb (e a₁) (e a₂). -/
protected def congr {ra : α → α → Prop} {rb : β → β → Prop} (e : α ≃ β)
    (eq : ∀ a₁ a₂, ra a₁ a₂ ↔ rb (e a₁) (e a₂)) : Quot ra ≃ Quot rb where
  toFun := Quot.map e fun a₁ a₂ => (eq a₁ a₂).1
  invFun := Quot.map e.symm fun b₁ b₂ h =>
    (eq (e.symm b₁) (e.symm b₂)).2
      ((e.apply_symm_apply b₁).symm ▸ (e.apply_symm_apply b₂).symm ▸ h)
  left_inv := by rintro ⟨a⟩; simp only [Quot.map, Equiv.symm_apply_apply]
  right_inv := by rintro ⟨a⟩; simp only [Quot.map, Equiv.apply_symm_apply]
#align quot.congr Quot.congr

@[simp] theorem congr_mk {ra : α → α → Prop} {rb : β → β → Prop} (e : α ≃ β)
    (eq : ∀ a₁ a₂ : α, ra a₁ a₂ ↔ rb (e a₁) (e a₂)) (a : α) :
    Quot.congr e eq (Quot.mk ra a) = Quot.mk rb (e a) := rfl
#align quot.congr_mk Quot.congr_mk

/-- Quotients are congruent on equivalences under equality of their relation.
An alternative is just to use rewriting with `eq`, but then computational proofs get stuck. -/
protected def congrRight {r r' : α → α → Prop} (eq : ∀ a₁ a₂, r a₁ a₂ ↔ r' a₁ a₂) :
    Quot r ≃ Quot r' := Quot.congr (Equiv.refl α) eq
#align quot.congr_right Quot.congrRight

/-- An equivalence `e : α ≃ β` generates an equivalence between the quotient space of `α`
by a relation `ra` and the quotient space of `β` by the image of this relation under `e`. -/
protected def congrLeft {r : α → α → Prop} (e : α ≃ β) :
    Quot r ≃ Quot fun b b' => r (e.symm b) (e.symm b') :=
  Quot.congr e fun _ _ => by simp only [e.symm_apply_apply]
#align quot.congr_left Quot.congrLeft

end Quot

namespace Quotient

/-- An equivalence `e : α ≃ β` generates an equivalence between quotient spaces,
if `ra a₁ a₂ ↔ rb (e a₁) (e a₂). -/
protected def congr {ra : Setoid α} {rb : Setoid β} (e : α ≃ β)
    (eq : ∀ a₁ a₂, @Setoid.r α ra a₁ a₂ ↔ @Setoid.r β rb (e a₁) (e a₂)) :
    Quotient ra ≃ Quotient rb := Quot.congr e eq
#align quotient.congr Quotient.congr

@[simp] theorem congr_mk {ra : Setoid α} {rb : Setoid β} (e : α ≃ β)
    (eq : ∀ a₁ a₂ : α, Setoid.r a₁ a₂ ↔ Setoid.r (e a₁) (e a₂)) (a : α) :
    Quotient.congr e eq (Quotient.mk ra a) = Quotient.mk rb (e a) := rfl
#align quotient.congr_mk Quotient.congr_mk

/-- Quotients are congruent on equivalences under equality of their relation.
An alternative is just to use rewriting with `eq`, but then computational proofs get stuck. -/
protected def congrRight {r r' : Setoid α}
    (eq : ∀ a₁ a₂, @Setoid.r α r a₁ a₂ ↔ @Setoid.r α r' a₁ a₂) : Quotient r ≃ Quotient r' :=
  Quot.congrRight eq
#align quotient.congr_right Quotient.congrRight

end Quotient


instance {α : Type u} : HAppend (Fin m → α) (Fin n → α) (Fin (m + n) → α) where
  hAppend a b i := if h : i < m then a ⟨i, h⟩ else b ⟨i - m, sorry⟩

def empty : Fin 0 → Nat := (nomatch ·)

theorem append_empty (x : Fin i → Nat) : x ++ empty = x :=
  funext fun i => dif_pos _

constant f : (Fin 0 → Nat) → Prop
example : f (empty ++ empty) = f empty := by simp only [append_empty] -- should work

@[congr] theorem Array.get_congr (as bs : Array α) (h : as = bs) (i : Fin as.size) (j : Nat) (hi : i = j) :
    as.get i = bs.get ⟨j, h ▸ hi ▸ i.2⟩ := by
  subst bs; subst j; rfl

example (as : Array Nat) (h : 0 + x < as.size) :
    as.get ⟨0 + x, h⟩ = as.get ⟨x, Nat.zero_add x ▸ h⟩ := by
  simp -- should work

example (as : Array (Nat → Nat)) (h : 0 + x < as.size) :
    as.get ⟨0 + x, h⟩ i = as.get ⟨x, Nat.zero_add x ▸ h⟩ i := by
  simp -- should also work

example (as : Array (Nat → Nat)) (h : 0 + x < as.size) :
    as.get ⟨0 + x, h⟩ i = as.get ⟨x, Nat.zero_add x ▸ h⟩ (0+i) := by
  simp -- should also work

example [Decidable p] : decide (p ∧ True) = decide p := by simp -- should work

def Pi.single [DecidableEq ι] {f : ι → Type u} [∀ i, Inhabited (f i)] (i : ι) (x : f i) : ∀ i, f i :=
  fun j => if h : j = i then h ▸ x else default

structure Set (α : Type u) where of :: mem : α → Prop

instance : CoeSort (Set α) (Type u) where coe s := Subtype s.mem

@[congr]
theorem dep_congr [DecidableEq ι] {p : ι → Set α} [∀ i, Inhabited (p i)] :
    ∀ {i j} (h : i = j) (x : p i) (y : α) (hx : x = y), Pi.single (f := (p ·)) i x = Pi.single (f := (p ·)) j ⟨y, hx ▸ h ▸ x.2⟩
  | _, _, rfl, _, _, rfl => rfl

theorem aux {p : Nat → Set Nat} {i j y : Nat} (x : p j) (h₁ : x = y) (h₂ : i = j) : Set.mem (p i) y := by
  have := x.2
  subst h₁ h₂
  assumption

example {p : Nat → Set Nat} [∀ i, Inhabited (p i)] (i : Nat) (x : p (0 + i)) (y : Nat) : Pi.single (f := (p ·)) (0 + i) x = Pi.single (f := (p ·)) i ⟨x, aux x rfl (Nat.zero_add i).symm ⟩ := by
  simp

def Submodule (α : Type u) [OfNat α 0] := { s : Set α // s.mem 0 }
instance [OfNat α 0] : CoeSort (Submodule α) (Type u) where coe s := s.1
instance [OfNat α 0] (p : Submodule α) : Inhabited p where default := ⟨0, p.2⟩

example (p : Nat → Submodule Nat) :
    Pi.single (f := (p ·)) (x - x) ⟨0, (p ..).2⟩ = Pi.single 0 ⟨0, (p ..).2⟩ := by
  simp only [Nat.sub_self] -- should work


import tactic
/--------------------------------------------------------------------------

``have``

  If ``f`` is a term of type ``P → Q`` and
  ``hp`` is a term of type ``P``, then
  ``have hq := f hp ,`` creates the hypothesis ``hq : Q`` .

``refine``

  If the target of the current goal is ``Q`` and
     ``f`` is a term of type ``P → Q``, then
     ``refine f _,`` changes target to ``P``.

Delete the ``sorry,`` below and replace them with a legitimate proof.

--------------------------------------------------------------------------/

example (P Q R : Prop) (hp : P) (f : P → Q) (g : Q → R) : R :=
begin
  sorry,
end

example (P Q R S T U: Type)
(hpq : P → Q)
(hqr : Q → R)
(hqt : Q → T)
(hst : S → T)
(htu : T → U)
: P → U :=
begin
  sorry,
end


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

import ring_theory.localization.at_prime
import order.minimal

/-!

# Minimal primes

We provide various results concerning the minimal primes above an ideal

## Main results
- `ideal.minimal_primes`: `I.minimal_primes` is the set of ideals that are minimal primes over `I`.
- `minimal_primes`: `minimal_primes R` is the set of minimal primes of `R`.
- `ideal.exists_minimal_primes_le`: Every prime ideal over `I` contains a minimal prime over `I`.
- `ideal.radical_minimal_primes`: The minimal primes over `I.radical` are precisely
  the minimal primes over `I`.
- `ideal.Inf_minimal_primes`: The intersection of minimal primes over `I` is `I.radical`.
- `ideal.exists_minimal_primes_comap_eq` If `p` is a minimal prime over `f ⁻¹ I`, then it is the
  preimage of some minimal prime over `I`.
- `ideal.minimal_primes_eq_comap`: The minimal primes over `I` are precisely the preimages of
  minimal primes of `R ⧸ I`.

-/

section

variables {R S : Type*} [comm_ring R] [comm_ring S] (I J : ideal R)

/-- `I.minimal_primes` is the set of ideals that are minimal primes over `I`. -/
def ideal.minimal_primes : set (ideal R) :=
minimals (≤) { p | p.is_prime ∧ I ≤ p }

/-- `minimal_primes R` is the set of minimal primes of `R`.
This is defined as `ideal.minimal_primes ⊥`. -/
def minimal_primes (R : Type*) [comm_ring R] : set (ideal R) := ideal.minimal_primes ⊥

variables {I J}

lemma ideal.exists_minimal_primes_le [J.is_prime] (e : I ≤ J) :
  ∃ p ∈ I.minimal_primes, p ≤ J :=
begin
  suffices : ∃ m ∈ { p : (ideal R)ᵒᵈ | ideal.is_prime p ∧ I ≤ order_dual.of_dual p },
    (order_dual.to_dual J) ≤ m ∧
      ∀ z ∈ { p : (ideal R)ᵒᵈ | ideal.is_prime p ∧ I ≤ p }, m ≤ z → z = m,
  { obtain ⟨p, h₁, h₂, h₃⟩ := this,
    simp_rw ← @eq_comm _ p at h₃,
    exact ⟨p, ⟨h₁, λ a b c, (h₃ a b c).le⟩, h₂⟩ },
  apply zorn_nonempty_partial_order₀,
  swap, { refine ⟨show J.is_prime, by apply_instance, e⟩ },
  rintros (c : set (ideal R)) hc hc' J' hJ',
  refine ⟨order_dual.to_dual (Inf c),
    ⟨ideal.Inf_is_prime_of_is_chain ⟨J', hJ'⟩ hc'.symm (λ x hx, (hc hx).1), _⟩, _⟩,
  { rw order_dual.of_dual_to_dual, convert le_Inf _, intros x hx, exact (hc hx).2 },
  { rintro z hz,
    rw order_dual.le_to_dual,
    exact Inf_le hz }
end

@[simp]
lemma ideal.radical_minimal_primes : I.radical.minimal_primes = I.minimal_primes :=
begin
  rw [ideal.minimal_primes, ideal.minimal_primes],
  congr,
  ext p,
  exact ⟨λ ⟨a, b⟩, ⟨a, ideal.le_radical.trans b⟩, λ ⟨a, b⟩, ⟨a, a.radical_le_iff.mpr b⟩⟩,
end

@[simp]
lemma ideal.Inf_minimal_primes :
  Inf I.minimal_primes = I.radical :=
begin
  rw I.radical_eq_Inf,
  apply le_antisymm,
  { intros x hx,
    rw ideal.mem_Inf at hx ⊢,
    rintros J ⟨e, hJ⟩,
    resetI,
    obtain ⟨p, hp, hp'⟩ := ideal.exists_minimal_primes_le e,
    exact hp' (hx hp) },
  { apply Inf_le_Inf _,
    intros I hI,
    exact hI.1.symm },
end

lemma ideal.exists_comap_eq_of_mem_minimal_primes_of_injective {f : R →+* S}
  (hf : function.injective f) (p ∈ minimal_primes R) :
  ∃ p' : ideal S, p'.is_prime ∧ p'.comap f = p :=
begin
  haveI := H.1.1,
  haveI : nontrivial (localization (submonoid.map f p.prime_compl)),
  { refine ⟨⟨1, 0, _⟩⟩,
    convert (is_localization.map_injective_of_injective p.prime_compl (localization.at_prime p)
      (localization $ p.prime_compl.map f) hf).ne one_ne_zero,
    { rw map_one }, { rw map_zero } },
  obtain ⟨M, hM⟩ := ideal.exists_maximal (localization (submonoid.map f p.prime_compl)),
  resetI,
  refine ⟨M.comap (algebra_map S $ localization (submonoid.map f p.prime_compl)),
    infer_instance, _⟩,
  rw [ideal.comap_comap, ← @@is_localization.map_comp _ _ _ _ localization.is_localization _
    p.prime_compl.le_comap_map _ localization.is_localization, ← ideal.comap_comap],
  suffices : _ ≤ p,
  { exact this.antisymm (H.2 ⟨infer_instance, bot_le⟩ this) },
  intros x hx,
  by_contra h,
  apply hM.ne_top,
  apply M.eq_top_of_is_unit_mem hx,
  apply is_unit.map,
  apply is_localization.map_units _ (show p.prime_compl, from ⟨x, h⟩),
  apply_instance
end

lemma ideal.exists_comap_eq_of_mem_minimal_primes {I : ideal S}
  (f : R →+* S) (p ∈ (I.comap f).minimal_primes) :
  ∃ p' : ideal S, p'.is_prime ∧ I ≤ p' ∧ p'.comap f = p :=
begin
  haveI := H.1.1,
  let f' := I^.quotient.mk^.comp f,
  have e : (I^.quotient.mk^.comp f).ker = I.comap f,
  { ext1, exact (submodule.quotient.mk_eq_zero _) },
  have : (I^.quotient.mk^.comp f).ker^.quotient.mk^.ker ≤ p,
  { rw [ideal.mk_ker, e], exact H.1.2 },
  obtain ⟨p', hp₁, hp₂⟩ := ideal.exists_comap_eq_of_mem_minimal_primes_of_injective
    (I^.quotient.mk^.comp f).ker_lift_injective (p.map (I^.quotient.mk^.comp f).ker^.quotient.mk) _,
  { resetI,
    refine ⟨p'.comap I^.quotient.mk, ideal.is_prime.comap _, _, _⟩,
    { exact ideal.mk_ker.symm.trans_le (ideal.comap_mono bot_le) },
    convert congr_arg (ideal.comap (I^.quotient.mk^.comp f).ker^.quotient.mk) hp₂,
    rwa [ideal.comap_map_of_surjective (I^.quotient.mk^.comp f).ker^.quotient.mk
      ideal.quotient.mk_surjective, eq_comm, sup_eq_left] },
  refine ⟨⟨_, bot_le⟩, _⟩,
  { apply ideal.map_is_prime_of_surjective _ this, exact ideal.quotient.mk_surjective },
  { rintro q ⟨hq, -⟩ hq',
    rw ← ideal.map_comap_of_surjective (I^.quotient.mk^.comp f).ker^.quotient.mk
      ideal.quotient.mk_surjective q,
    apply ideal.map_mono,
    resetI,
    apply H.2,
    { refine ⟨infer_instance, (ideal.mk_ker.trans e).symm.trans_le (ideal.comap_mono bot_le)⟩ },
    { refine (ideal.comap_mono hq').trans _, rw ideal.comap_map_of_surjective,
      exacts [sup_le rfl.le this, ideal.quotient.mk_surjective] } }
end

lemma ideal.exists_minimal_primes_comap_eq {I : ideal S}
  (f : R →+* S) (p ∈ (I.comap f).minimal_primes) :
  ∃ p' ∈ I.minimal_primes, ideal.comap f p' = p :=
begin
  obtain ⟨p', h₁, h₂, h₃⟩ := ideal.exists_comap_eq_of_mem_minimal_primes f p H,
  resetI,
  obtain ⟨q, hq, hq'⟩ := ideal.exists_minimal_primes_le h₂,
  refine ⟨q, hq, eq.symm _⟩,
  haveI := hq.1.1,
  have := (ideal.comap_mono hq').trans_eq h₃,
  exact (H.2 ⟨infer_instance, ideal.comap_mono hq.1.2⟩ this).antisymm this
end

lemma ideal.mimimal_primes_comap_of_surjective {f : R →+* S} (hf : function.surjective f)
  {I J : ideal S} (h : J ∈ I.minimal_primes) :
  J.comap f ∈ (I.comap f).minimal_primes :=
begin
  haveI := h.1.1,
  refine ⟨⟨infer_instance, ideal.comap_mono h.1.2⟩, _⟩,
  rintros K ⟨hK, e₁⟩ e₂,
  have : f.ker ≤ K := (ideal.comap_mono bot_le).trans e₁,
  rw [← sup_eq_left.mpr this, ring_hom.ker_eq_comap_bot, ← ideal.comap_map_of_surjective f hf],
  apply ideal.comap_mono _,
  apply h.2 _ _,
  { exactI ⟨ideal.map_is_prime_of_surjective hf this,
      ideal.le_map_of_comap_le_of_surjective f hf e₁⟩ },
  { exact ideal.map_le_of_le_comap e₂ }
end

lemma ideal.comap_minimal_primes_eq_of_surjective {f : R →+* S} (hf : function.surjective f)
  (I : ideal S) :
  (I.comap f).minimal_primes = ideal.comap f '' I.minimal_primes :=
begin
  ext J,
  split,
  { intro H, obtain ⟨p, h, rfl⟩ := ideal.exists_minimal_primes_comap_eq f J H, exact ⟨p, h, rfl⟩ },
  { rintros ⟨J, hJ, rfl⟩, exact ideal.mimimal_primes_comap_of_surjective hf hJ }
end

lemma ideal.minimal_primes_eq_comap :
  I.minimal_primes = ideal.comap I^.quotient.mk '' minimal_primes (R ⧸ I) :=
begin
  rw [minimal_primes, ← ideal.comap_minimal_primes_eq_of_surjective ideal.quotient.mk_surjective,
    ← ring_hom.ker_eq_comap_bot, ideal.mk_ker],
end

lemma ideal.minimal_primes_eq_subsingleton (hI : I.is_primary) :
  I.minimal_primes = {I.radical} :=
begin
  ext J,
  split,
  { exact λ H, let e := H.1.1.radical_le_iff.mpr H.1.2 in
      (H.2 ⟨ideal.is_prime_radical hI, ideal.le_radical⟩ e).antisymm e },
  { rintro (rfl : J = I.radical),
    exact ⟨⟨ideal.is_prime_radical hI, ideal.le_radical⟩, λ _ H _, H.1.radical_le_iff.mpr H.2⟩ }
end

lemma ideal.minimal_primes_eq_subsingleton_self [I.is_prime] :
  I.minimal_primes = {I} :=
begin
  ext J,
  split,
  { exact λ H, (H.2 ⟨infer_instance, rfl.le⟩ H.1.2).antisymm H.1.2 },
  { unfreezingI { rintro (rfl : J = I) }, refine ⟨⟨infer_instance, rfl.le⟩, λ _ h _, h.2⟩ },
end

end


/-
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, Sébastien Gouëzel, Patrick Massot

! This file was ported from Lean 3 source module topology.uniform_space.uniform_embedding
! leanprover-community/mathlib commit 195fcd60ff2bfe392543bceb0ec2adcdb472db4c
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Topology.UniformSpace.Cauchy
import Mathlib.Topology.UniformSpace.Separation
import Mathlib.Topology.DenseEmbedding

/-!
# Uniform embeddings of uniform spaces.

Extension of uniform continuous functions.
-/

open Filter Function Set Uniformity Topology

section

universe u v w
variable {α : Type u} {β : Type v} {γ : Type w} [UniformSpace α] [UniformSpace β] [UniformSpace γ]

/-!
### Uniform inducing maps
-/

/-- A map `f : α → β` between uniform spaces is called *uniform inducing* if the uniformity filter
on `α` is the pullback of the uniformity filter on `β` under `Prod.map f f`. If `α` is a separated
space, then this implies that `f` is injective, hence it is a `UniformEmbedding`. -/
@[mk_iff uniformInducing_iff]
structure UniformInducing (f : α → β) : Prop where
  /-- The uniformity filter on the domain is the pullback of the uniformity filter on the codomain
  under `Prod.map f f`. -/
  comap_uniformity : comap (fun x : α × α => (f x.1, f x.2)) (𝓤 β) = 𝓤 α
#align uniform_inducing UniformInducing
#align uniform_inducing_iff uniformInducing_iff

protected lemma UniformInducing.comap_uniformSpace {f : α → β} (hf : UniformInducing f) :
    ‹UniformSpace β›.comap f = ‹UniformSpace α› :=
  uniformSpace_eq hf.1
#align uniform_inducing.comap_uniform_space UniformInducing.comap_uniformSpace

lemma uniformInducing_iff' {f : α → β} :
    UniformInducing f ↔ UniformContinuous f ∧ comap (Prod.map f f) (𝓤 β) ≤ 𝓤 α := by
  rw [uniformInducing_iff, UniformContinuous, tendsto_iff_comap, le_antisymm_iff, and_comm]; rfl
#align uniform_inducing_iff' uniformInducing_iff'

protected lemma Filter.HasBasis.uniformInducing_iff {ι ι'} {p : ι → Prop} {p' : ι' → Prop} {s s'}
    (h : (𝓤 α).HasBasis p s) (h' : (𝓤 β).HasBasis p' s') {f : α → β} :
    UniformInducing f ↔
      (∀ i, p' i → ∃ j, p j ∧ ∀ x y, (x, y) ∈ s j → (f x, f y) ∈ s' i) ∧
        (∀ j, p j → ∃ i, p' i ∧ ∀ x y, (f x, f y) ∈ s' i → (x, y) ∈ s j) := by
  simp [uniformInducing_iff', h.uniformContinuous_iff h', (h'.comap _).le_basis_iff h, subset_def]
#align filter.has_basis.uniform_inducing_iff Filter.HasBasis.uniformInducing_iff

theorem UniformInducing.mk' {f : α → β}
    (h : ∀ s, s ∈ 𝓤 α ↔ ∃ t ∈ 𝓤 β, ∀ x y : α, (f x, f y) ∈ t → (x, y) ∈ s) : UniformInducing f :=
  ⟨by simp [eq_comm, Filter.ext_iff, subset_def, h]⟩
#align uniform_inducing.mk' UniformInducing.mk'

theorem uniformInducing_id : UniformInducing (@id α) :=
  ⟨by rw [← Prod.map_def, Prod.map_id, comap_id]⟩
#align uniform_inducing_id uniformInducing_id

theorem UniformInducing.comp {g : β → γ} (hg : UniformInducing g) {f : α → β}
    (hf : UniformInducing f) : UniformInducing (g ∘ f) :=
  ⟨by rw [← hf.1, ← hg.1, comap_comap]; rfl⟩
#align uniform_inducing.comp UniformInducing.comp

theorem UniformInducing.basis_uniformity {f : α → β} (hf : UniformInducing f) {ι : Sort _}
    {p : ι → Prop} {s : ι → Set (β × β)} (H : (𝓤 β).HasBasis p s) :
    (𝓤 α).HasBasis p fun i => Prod.map f f ⁻¹' s i :=
  hf.1 ▸ H.comap _
#align uniform_inducing.basis_uniformity UniformInducing.basis_uniformity

theorem UniformInducing.cauchy_map_iff {f : α → β} (hf : UniformInducing f) {F : Filter α} :
    Cauchy (map f F) ↔ Cauchy F := by
  simp only [Cauchy, map_neBot_iff, prod_map_map_eq, map_le_iff_le_comap, ← hf.comap_uniformity]
#align uniform_inducing.cauchy_map_iff UniformInducing.cauchy_map_iff

theorem uniformInducing_of_compose {f : α → β} {g : β → γ} (hf : UniformContinuous f)
    (hg : UniformContinuous g) (hgf : UniformInducing (g ∘ f)) : UniformInducing f := by
  refine' ⟨le_antisymm _ hf.le_comap⟩
  rw [← hgf.1, ← Prod.map_def, ← Prod.map_def, ← Prod.map_comp_map f f g g, ← comap_comap]
  exact comap_mono hg.le_comap
#align uniform_inducing_of_compose uniformInducing_of_compose

theorem UniformInducing.uniformContinuous {f : α → β} (hf : UniformInducing f) :
    UniformContinuous f := (uniformInducing_iff'.1 hf).1
#align uniform_inducing.uniform_continuous UniformInducing.uniformContinuous

theorem UniformInducing.uniformContinuous_iff {f : α → β} {g : β → γ} (hg : UniformInducing g) :
    UniformContinuous f ↔ UniformContinuous (g ∘ f) := by
  dsimp only [UniformContinuous, Tendsto]
  rw [← hg.comap_uniformity, ← map_le_iff_le_comap, Filter.map_map]; rfl
#align uniform_inducing.uniform_continuous_iff UniformInducing.uniformContinuous_iff

theorem UniformInducing.inducing {f : α → β} (h : UniformInducing f) : Inducing f := by
  obtain rfl := h.comap_uniformSpace
  exact inducing_induced f
#align uniform_inducing.inducing UniformInducing.inducing

theorem UniformInducing.prod {α' : Type _} {β' : Type _} [UniformSpace α'] [UniformSpace β']
    {e₁ : α → α'} {e₂ : β → β'} (h₁ : UniformInducing e₁) (h₂ : UniformInducing e₂) :
    UniformInducing fun p : α × β => (e₁ p.1, e₂ p.2) :=
  ⟨by simp [(· ∘ ·), uniformity_prod, ← h₁.1, ← h₂.1, comap_inf, comap_comap]⟩
#align uniform_inducing.prod UniformInducing.prod

theorem UniformInducing.denseInducing {f : α → β} (h : UniformInducing f) (hd : DenseRange f) :
    DenseInducing f :=
  { dense := hd
    induced := h.inducing.induced }
#align uniform_inducing.dense_inducing UniformInducing.denseInducing

protected theorem UniformInducing.injective [T0Space α] {f : α → β} (h : UniformInducing f) :
    Injective f :=
  h.inducing.injective

/-!
### Uniform embeddings
-/

/-- A map `f : α → β` between uniform spaces is a *uniform embedding* if it is uniform inducing and
injective. If `α` is a separated space, then the latter assumption follows from the former. -/
@[mk_iff uniformEmbedding_iff]
structure UniformEmbedding (f : α → β) extends UniformInducing f : Prop where
  /-- A uniform embedding is injective. -/
  inj : Function.Injective f
#align uniform_embedding UniformEmbedding
#align uniform_embedding_iff uniformEmbedding_iff

theorem uniformEmbedding_iff' {f : α → β} :
    UniformEmbedding f ↔ Injective f ∧ UniformContinuous f ∧ comap (Prod.map f f) (𝓤 β) ≤ 𝓤 α := by
  rw [uniformEmbedding_iff, and_comm, uniformInducing_iff']
#align uniform_embedding_iff' uniformEmbedding_iff'

theorem Filter.HasBasis.uniformEmbedding_iff' {ι ι'} {p : ι → Prop} {p' : ι' → Prop} {s s'}
    (h : (𝓤 α).HasBasis p s) (h' : (𝓤 β).HasBasis p' s') {f : α → β} :
    UniformEmbedding f ↔ Injective f ∧
      (∀ i, p' i → ∃ j, p j ∧ ∀ x y, (x, y) ∈ s j → (f x, f y) ∈ s' i) ∧
        (∀ j, p j → ∃ i, p' i ∧ ∀ x y, (f x, f y) ∈ s' i → (x, y) ∈ s j) := by
  rw [uniformEmbedding_iff, and_comm, h.uniformInducing_iff h']
#align filter.has_basis.uniform_embedding_iff' Filter.HasBasis.uniformEmbedding_iff'

theorem Filter.HasBasis.uniformEmbedding_iff {ι ι'} {p : ι → Prop} {p' : ι' → Prop} {s s'}
    (h : (𝓤 α).HasBasis p s) (h' : (𝓤 β).HasBasis p' s') {f : α → β} :
    UniformEmbedding f ↔ Injective f ∧ UniformContinuous f ∧
      (∀ j, p j → ∃ i, p' i ∧ ∀ x y, (f x, f y) ∈ s' i → (x, y) ∈ s j) := by
  simp only [h.uniformEmbedding_iff' h', h.uniformContinuous_iff h']
#align filter.has_basis.uniform_embedding_iff Filter.HasBasis.uniformEmbedding_iff

theorem uniformEmbedding_subtype_val {p : α → Prop} :
    UniformEmbedding (Subtype.val : Subtype p → α) :=
  { comap_uniformity := rfl
    inj := Subtype.val_injective }
#align uniform_embedding_subtype_val uniformEmbedding_subtype_val
#align uniform_embedding_subtype_coe uniformEmbedding_subtype_val

theorem uniformEmbedding_set_inclusion {s t : Set α} (hst : s ⊆ t) :
    UniformEmbedding (inclusion hst) where
  comap_uniformity := by rw [uniformity_subtype, uniformity_subtype, comap_comap]; rfl
  inj := inclusion_injective hst
#align uniform_embedding_set_inclusion uniformEmbedding_set_inclusion

theorem UniformEmbedding.comp {g : β → γ} (hg : UniformEmbedding g) {f : α → β}
    (hf : UniformEmbedding f) : UniformEmbedding (g ∘ f) :=
  { hg.toUniformInducing.comp hf.toUniformInducing with inj := hg.inj.comp hf.inj }
#align uniform_embedding.comp UniformEmbedding.comp

theorem Equiv.uniformEmbedding {α β : Type _} [UniformSpace α] [UniformSpace β] (f : α ≃ β)
    (h₁ : UniformContinuous f) (h₂ : UniformContinuous f.symm) : UniformEmbedding f :=
  uniformEmbedding_iff'.2 ⟨f.injective, h₁, by rwa [← Equiv.prodCongr_apply, ← map_equiv_symm]⟩
#align equiv.uniform_embedding Equiv.uniformEmbedding

theorem uniformEmbedding_inl : UniformEmbedding (Sum.inl : α → α ⊕ β) :=
  uniformEmbedding_iff'.2 ⟨Sum.inl_injective, uniformContinuous_inl, fun s hs =>
    ⟨Prod.map Sum.inl Sum.inl '' s ∪ range (Prod.map Sum.inr Sum.inr),
      union_mem_sup (image_mem_map hs) range_mem_map, fun x h => by simpa using h⟩⟩
#align uniform_embedding_inl uniformEmbedding_inl

theorem uniformEmbedding_inr : UniformEmbedding (Sum.inr : β → α ⊕ β) :=
  uniformEmbedding_iff'.2 ⟨Sum.inr_injective, uniformContinuous_inr, fun s hs =>
    ⟨range (Prod.map Sum.inl Sum.inl) ∪ Prod.map Sum.inr Sum.inr '' s,
      union_mem_sup range_mem_map (image_mem_map hs), fun x h => by simpa using h⟩⟩
#align uniform_embedding_inr uniformEmbedding_inr

/-- If the domain of a `UniformInducing` map `f` is a T₀ space, then `f` is injective,
hence it is a `UniformEmbedding`. -/
protected theorem UniformInducing.uniformEmbedding [T0Space α] {f : α → β}
    (hf : UniformInducing f) : UniformEmbedding f :=
  ⟨hf, hf.inducing.injective⟩
#align uniform_inducing.uniform_embedding UniformInducing.uniformEmbedding

theorem uniformEmbedding_iff_uniformInducing [T0Space α] {f : α → β} :
    UniformEmbedding f ↔ UniformInducing f :=
  ⟨UniformEmbedding.toUniformInducing, UniformInducing.uniformEmbedding⟩
#align uniform_embedding_iff_uniform_inducing uniformEmbedding_iff_uniformInducing

/-- If a map `f : α → β` sends any two distinct points to point that are **not** related by a fixed
`s ∈ 𝓤 β`, then `f` is uniform inducing with respect to the discrete uniformity on `α`:
the preimage of `𝓤 β` under `prod.map f f` is the principal filter generated by the diagonal in
`α × α`. -/
theorem comap_uniformity_of_spaced_out {α} {f : α → β} {s : Set (β × β)} (hs : s ∈ 𝓤 β)
    (hf : Pairwise fun x y => (f x, f y) ∉ s) : comap (Prod.map f f) (𝓤 β) = 𝓟 idRel := by
  refine' le_antisymm _ (@refl_le_uniformity α (UniformSpace.comap f _))
  calc
    comap (Prod.map f f) (𝓤 β) ≤ comap (Prod.map f f) (𝓟 s) := comap_mono (le_principal_iff.2 hs)
    _ = 𝓟 (Prod.map f f ⁻¹' s) := comap_principal
    _ ≤ 𝓟 idRel := principal_mono.2 ?_
  rintro ⟨x, y⟩; simpa [not_imp_not] using @hf x y
#align comap_uniformity_of_spaced_out comap_uniformity_of_spaced_out

/-- If a map `f : α → β` sends any two distinct points to point that are **not** related by a fixed
`s ∈ 𝓤 β`, then `f` is a uniform embedding with respect to the discrete uniformity on `α`. -/
theorem uniformEmbedding_of_spaced_out {α} {f : α → β} {s : Set (β × β)} (hs : s ∈ 𝓤 β)
    (hf : Pairwise fun x y => (f x, f y) ∉ s) : @UniformEmbedding α β ⊥ ‹_› f := by
  let _ : UniformSpace α := ⊥; have := discreteTopology_bot α
  exact UniformInducing.uniformEmbedding ⟨comap_uniformity_of_spaced_out hs hf⟩
#align uniform_embedding_of_spaced_out uniformEmbedding_of_spaced_out

protected theorem UniformEmbedding.embedding {f : α → β} (h : UniformEmbedding f) : Embedding f :=
  { toInducing := h.toUniformInducing.inducing
    inj := h.inj }
#align uniform_embedding.embedding UniformEmbedding.embedding

theorem UniformEmbedding.denseEmbedding {f : α → β} (h : UniformEmbedding f) (hd : DenseRange f) :
    DenseEmbedding f :=
  { h.embedding with dense := hd }
#align uniform_embedding.dense_embedding UniformEmbedding.denseEmbedding

theorem closedEmbedding_of_spaced_out {α} [TopologicalSpace α] [DiscreteTopology α]
    [SeparatedSpace β] {f : α → β} {s : Set (β × β)} (hs : s ∈ 𝓤 β)
    (hf : Pairwise fun x y => (f x, f y) ∉ s) : ClosedEmbedding f := by
  rcases @DiscreteTopology.eq_bot α _ _ with rfl; let _ : UniformSpace α := ⊥
  exact
    { (uniformEmbedding_of_spaced_out hs hf).embedding with
      closed_range := isClosed_range_of_spaced_out hs hf }
#align closed_embedding_of_spaced_out closedEmbedding_of_spaced_out

theorem closure_image_mem_nhds_of_uniformInducing {s : Set (α × α)} {e : α → β} (b : β)
    (he₁ : UniformInducing e) (he₂ : DenseInducing e) (hs : s ∈ 𝓤 α) :
    ∃ a, closure (e '' { a' | (a, a') ∈ s }) ∈ 𝓝 b := by
  obtain ⟨U, ⟨hU, hUo, hsymm⟩, hs⟩ :
    ∃ U, (U ∈ 𝓤 β ∧ IsOpen U ∧ SymmetricRel U) ∧ Prod.map e e ⁻¹' U ⊆ s := by
      rwa [← he₁.comap_uniformity, (uniformity_hasBasis_open_symmetric.comap _).mem_iff] at hs
  rcases he₂.dense.mem_nhds (UniformSpace.ball_mem_nhds b hU) with ⟨a, ha⟩
  refine ⟨a, mem_of_superset ?_ (closure_mono <| image_subset _ <| ball_mono hs a)⟩
  have ho : IsOpen (UniformSpace.ball (e a) U) := UniformSpace.isOpen_ball (e a) hUo
  refine mem_of_superset (ho.mem_nhds <| (mem_ball_symmetry hsymm).2 ha) fun y hy => ?_
  refine mem_closure_iff_nhds.2 fun V hV => ?_
  rcases he₂.dense.mem_nhds (inter_mem hV (ho.mem_nhds hy)) with ⟨x, hxV, hxU⟩
  exact ⟨e x, hxV, mem_image_of_mem e hxU⟩
#align closure_image_mem_nhds_of_uniform_inducing closure_image_mem_nhds_of_uniformInducing

theorem uniformEmbedding_subtypeEmb (p : α → Prop) {e : α → β} (ue : UniformEmbedding e)
    (de : DenseEmbedding e) : UniformEmbedding (DenseEmbedding.subtypeEmb p e) :=
  { comap_uniformity := by
      simp [comap_comap, (· ∘ ·), DenseEmbedding.subtypeEmb, uniformity_subtype,
        ue.comap_uniformity.symm]
    inj := (de.subtype p).inj }
#align uniform_embedding_subtype_emb uniformEmbedding_subtypeEmb

theorem UniformEmbedding.prod {α' : Type _} {β' : Type _} [UniformSpace α'] [UniformSpace β']
    {e₁ : α → α'} {e₂ : β → β'} (h₁ : UniformEmbedding e₁) (h₂ : UniformEmbedding e₂) :
    UniformEmbedding fun p : α × β => (e₁ p.1, e₂ p.2) :=
  { h₁.toUniformInducing.prod h₂.toUniformInducing with inj := h₁.inj.Prod_map h₂.inj }
#align uniform_embedding.prod UniformEmbedding.prod

theorem isComplete_of_complete_image {m : α → β} {s : Set α} (hm : UniformInducing m)
    (hs : IsComplete (m '' s)) : IsComplete s := by
  intro f hf hfs
  rw [le_principal_iff] at hfs
  obtain ⟨_, ⟨x, hx, rfl⟩, hyf⟩ : ∃ y ∈ m '' s, map m f ≤ 𝓝 y
  exact hs (f.map m) (hf.map hm.uniformContinuous) (le_principal_iff.2 (image_mem_map hfs))
  rw [map_le_iff_le_comap, ← nhds_induced, ← hm.inducing.induced] at hyf
  exact ⟨x, hx, hyf⟩
#align is_complete_of_complete_image isComplete_of_complete_image

theorem IsComplete.completeSpace_coe {s : Set α} (hs : IsComplete s) : CompleteSpace s :=
  completeSpace_iff_isComplete_univ.2 <|
    isComplete_of_complete_image uniformEmbedding_subtype_val.toUniformInducing <| by simp [hs]
#align is_complete.complete_space_coe IsComplete.completeSpace_coe

/-- A set is complete iff its image under a uniform inducing map is complete. -/
theorem isComplete_image_iff {m : α → β} {s : Set α} (hm : UniformInducing m) :
    IsComplete (m '' s) ↔ IsComplete s := by
  refine' ⟨isComplete_of_complete_image hm, fun c => _⟩
  haveI : CompleteSpace s := c.completeSpace_coe
  set m' : s → β := m ∘ (↑)
  suffices IsComplete (range m') by rwa [range_comp, Subtype.range_coe] at this
  have hm' : UniformInducing m' := hm.comp uniformEmbedding_subtype_val.toUniformInducing
  intro f hf hfm
  rw [Filter.le_principal_iff] at hfm
  have cf' : Cauchy (comap m' f) :=
    hf.comap' hm'.comap_uniformity.le (NeBot.comap_of_range_mem hf.1 hfm)
  rcases CompleteSpace.complete cf' with ⟨x, hx⟩
  rw [hm'.inducing.nhds_eq_comap, comap_le_comap_iff hfm] at hx
  exact ⟨m' x, mem_range_self _, hx⟩
#align is_complete_image_iff isComplete_image_iff

theorem completeSpace_iff_isComplete_range {f : α → β} (hf : UniformInducing f) :
    CompleteSpace α ↔ IsComplete (range f) := by
  rw [completeSpace_iff_isComplete_univ, ← isComplete_image_iff hf, image_univ]
#align complete_space_iff_is_complete_range completeSpace_iff_isComplete_range

theorem UniformInducing.isComplete_range [CompleteSpace α] {f : α → β} (hf : UniformInducing f) :
    IsComplete (range f) :=
  (completeSpace_iff_isComplete_range hf).1 ‹_›
#align uniform_inducing.is_complete_range UniformInducing.isComplete_range

theorem completeSpace_congr {e : α ≃ β} (he : UniformEmbedding e) :
    CompleteSpace α ↔ CompleteSpace β := by
  rw [completeSpace_iff_isComplete_range he.toUniformInducing, e.range_eq_univ,
    completeSpace_iff_isComplete_univ]
#align complete_space_congr completeSpace_congr

theorem completeSpace_coe_iff_isComplete {s : Set α} : CompleteSpace s ↔ IsComplete s :=
  (completeSpace_iff_isComplete_range uniformEmbedding_subtype_val.toUniformInducing).trans <| by
    rw [Subtype.range_coe]
#align complete_space_coe_iff_is_complete completeSpace_coe_iff_isComplete

theorem IsClosed.completeSpace_coe [CompleteSpace α] {s : Set α} (hs : IsClosed s) :
    CompleteSpace s :=
  hs.isComplete.completeSpace_coe
#align is_closed.complete_space_coe IsClosed.completeSpace_coe

/-- The lift of a complete space to another universe is still complete. -/
instance ULift.completeSpace [h : CompleteSpace α] : CompleteSpace (ULift α) :=
  haveI : UniformEmbedding (@Equiv.ulift α) := ⟨⟨rfl⟩, ULift.down_injective⟩
  (completeSpace_congr this).2 h
#align ulift.complete_space ULift.completeSpace

theorem completeSpace_extension {m : β → α} (hm : UniformInducing m) (dense : DenseRange m)
    (h : ∀ f : Filter β, Cauchy f → ∃ x : α, map m f ≤ 𝓝 x) : CompleteSpace α :=
  ⟨fun {f : Filter α} (hf : Cauchy f) =>
    let p : Set (α × α) → Set α → Set α := fun s t => { y : α | ∃ x : α, x ∈ t ∧ (x, y) ∈ s }
    let g := (𝓤 α).lift fun s => f.lift' (p s)
    have mp₀ : Monotone p := fun a b h t s ⟨x, xs, xa⟩ => ⟨x, xs, h xa⟩
    have mp₁ : ∀ {s}, Monotone (p s) := fun h x ⟨y, ya, yxs⟩ => ⟨y, h ya, yxs⟩
    have : f ≤ g := le_infᵢ₂ fun s hs => le_infᵢ₂ fun t ht =>
      le_principal_iff.mpr <| mem_of_superset ht fun x hx => ⟨x, hx, refl_mem_uniformity hs⟩
    have : NeBot g := hf.left.mono this
    have : NeBot (comap m g) :=
      comap_neBot fun t ht =>
        let ⟨t', ht', ht_mem⟩ := (mem_lift_sets <| monotone_lift' monotone_const mp₀).mp ht
        let ⟨t'', ht'', ht'_sub⟩ := (mem_lift'_sets mp₁).mp ht_mem
        let ⟨x, (hx : x ∈ t'')⟩ := hf.left.nonempty_of_mem ht''
        have h₀ : NeBot (𝓝[range m] x) := dense.nhdsWithin_neBot x
        have h₁ : { y | (x, y) ∈ t' } ∈ 𝓝[range m] x :=
          @mem_inf_of_left α (𝓝 x) (𝓟 (range m)) _ <| mem_nhds_left x ht'
        have h₂ : range m ∈ 𝓝[range m] x :=
          @mem_inf_of_right α (𝓝 x) (𝓟 (range m)) _ <| Subset.refl _
        have : { y | (x, y) ∈ t' } ∩ range m ∈ 𝓝[range m] x := @inter_mem α (𝓝[range m] x) _ _ h₁ h₂
        let ⟨y, xyt', b, b_eq⟩ := h₀.nonempty_of_mem this
        ⟨b, b_eq.symm ▸ ht'_sub ⟨x, hx, xyt'⟩⟩
    have : Cauchy g :=
      ⟨‹NeBot g›, fun s hs =>
        let ⟨s₁, hs₁, (comp_s₁ : compRel s₁ s₁ ⊆ s)⟩ := comp_mem_uniformity_sets hs
        let ⟨s₂, hs₂, (comp_s₂ : compRel s₂ s₂ ⊆ s₁)⟩ := comp_mem_uniformity_sets hs₁
        let ⟨t, ht, (prod_t : t ×ˢ t ⊆ s₂)⟩ := mem_prod_same_iff.mp (hf.right hs₂)
        have hg₁ : p (preimage Prod.swap s₁) t ∈ g :=
          mem_lift (symm_le_uniformity hs₁) <| @mem_lift' α α f _ t ht
        have hg₂ : p s₂ t ∈ g := mem_lift hs₂ <| @mem_lift' α α f _ t ht
        have hg : p (Prod.swap ⁻¹' s₁) t ×ˢ p s₂ t ∈ g ×ᶠ g := @prod_mem_prod α α _ _ g g hg₁ hg₂
        (g ×ᶠ g).sets_of_superset hg fun ⟨a, b⟩ ⟨⟨c₁, c₁t, hc₁⟩, ⟨c₂, c₂t, hc₂⟩⟩ =>
          have : (c₁, c₂) ∈ t ×ˢ t := ⟨c₁t, c₂t⟩
          comp_s₁ <| prod_mk_mem_compRel hc₁ <| comp_s₂ <| prod_mk_mem_compRel (prod_t this) hc₂⟩
    have : Cauchy (Filter.comap m g) := ‹Cauchy g›.comap' (le_of_eq hm.comap_uniformity) ‹_›
    let ⟨x, (hx : map m (Filter.comap m g) ≤ 𝓝 x)⟩ := h _ this
    have : ClusterPt x (map m (Filter.comap m g)) :=
      (le_nhds_iff_adhp_of_cauchy (this.map hm.uniformContinuous)).mp hx
    have : ClusterPt x g := this.mono map_comap_le
    ⟨x,
      calc
        f ≤ g := by assumption
        _ ≤ 𝓝 x := le_nhds_of_cauchy_adhp ‹Cauchy g› this
        ⟩⟩
#align complete_space_extension completeSpace_extension

theorem totallyBounded_preimage {f : α → β} {s : Set β} (hf : UniformEmbedding f)
    (hs : TotallyBounded s) : TotallyBounded (f ⁻¹' s) := fun t ht => by
  rw [← hf.comap_uniformity] at ht
  rcases mem_comap.2 ht with ⟨t', ht', ts⟩
  rcases totallyBounded_iff_subset.1 (totallyBounded_subset (image_preimage_subset f s) hs) _ ht'
    with ⟨c, cs, hfc, hct⟩
  refine' ⟨f ⁻¹' c, hfc.preimage (hf.inj.injOn _), fun x h => _⟩
  have := hct (mem_image_of_mem f h); simp at this⊢
  rcases this with ⟨z, zc, zt⟩
  rcases cs zc with ⟨y, -, rfl⟩
  exact ⟨y, zc, ts zt⟩
#align totally_bounded_preimage totallyBounded_preimage

instance CompleteSpace.sum [CompleteSpace α] [CompleteSpace β] : CompleteSpace (Sum α β) := by
  rw [completeSpace_iff_isComplete_univ, ← range_inl_union_range_inr]
  exact uniformEmbedding_inl.toUniformInducing.isComplete_range.union
    uniformEmbedding_inr.toUniformInducing.isComplete_range
#align complete_space.sum CompleteSpace.sum

end

theorem uniformEmbedding_comap {α : Type _} {β : Type _} {f : α → β} [u : UniformSpace β]
    (hf : Function.Injective f) : @UniformEmbedding α β (UniformSpace.comap f u) u f :=
  @UniformEmbedding.mk _ _ (UniformSpace.comap f u) _ _
    (@UniformInducing.mk _ _ (UniformSpace.comap f u) _ _ rfl) hf
#align uniform_embedding_comap uniformEmbedding_comap

/-- Pull back a uniform space structure by an embedding, adjusting the new uniform structure to
make sure that its topology is defeq to the original one. -/
def Embedding.comapUniformSpace {α β} [TopologicalSpace α] [u : UniformSpace β] (f : α → β)
    (h : Embedding f) : UniformSpace α :=
  (u.comap f).replaceTopology h.induced
#align embedding.comap_uniform_space Embedding.comapUniformSpace

theorem Embedding.to_uniformEmbedding {α β} [TopologicalSpace α] [u : UniformSpace β] (f : α → β)
    (h : Embedding f) : @UniformEmbedding α β (h.comapUniformSpace f) u f :=
  let _ := h.comapUniformSpace f
  { comap_uniformity := rfl
    inj := h.inj }
#align embedding.to_uniform_embedding Embedding.to_uniformEmbedding

section UniformExtension

variable {α : Type _} {β : Type _} {γ : Type _} [UniformSpace α] [UniformSpace β] [UniformSpace γ]
  {e : β → α} (h_e : UniformInducing e) (h_dense : DenseRange e) {f : β → γ}
  (h_f : UniformContinuous f)

local notation "ψ" => DenseInducing.extend (UniformInducing.denseInducing h_e h_dense) f

theorem uniformly_extend_exists [CompleteSpace γ] (a : α) : ∃ c, Tendsto f (comap e (𝓝 a)) (𝓝 c) :=
  let de := h_e.denseInducing h_dense
  have : Cauchy (𝓝 a) := cauchy_nhds
  have : Cauchy (comap e (𝓝 a)) :=
    this.comap' (le_of_eq h_e.comap_uniformity) (de.comap_nhds_neBot _)
  have : Cauchy (map f (comap e (𝓝 a))) := this.map h_f
  CompleteSpace.complete this
#align uniformly_extend_exists uniformly_extend_exists

theorem uniform_extend_subtype [CompleteSpace γ] {p : α → Prop} {e : α → β} {f : α → γ} {b : β}
    {s : Set α} (hf : UniformContinuous fun x : Subtype p => f x.val) (he : UniformEmbedding e)
    (hd : ∀ x : β, x ∈ closure (range e)) (hb : closure (e '' s) ∈ 𝓝 b) (hs : IsClosed s)
    (hp : ∀ x ∈ s, p x) : ∃ c, Tendsto f (comap e (𝓝 b)) (𝓝 c) := by
  have de : DenseEmbedding e := he.denseEmbedding hd
  have de' : DenseEmbedding (DenseEmbedding.subtypeEmb p e) := de.subtype p
  have ue' : UniformEmbedding (DenseEmbedding.subtypeEmb p e) := uniformEmbedding_subtypeEmb _ he de
  have : b ∈ closure (e '' { x | p x }) :=
    (closure_mono <| monotone_image <| hp) (mem_of_mem_nhds hb)
  let ⟨c, hc⟩ := uniformly_extend_exists ue'.toUniformInducing de'.dense hf ⟨b, this⟩
  replace hc : Tendsto (f ∘ Subtype.val) (((𝓝 b).comap e).comap Subtype.val) (𝓝 c) := by
    simpa only [nhds_subtype_eq_comap, comap_comap, DenseEmbedding.subtypeEmb_coe] using hc
  refine ⟨c, (tendsto_comap'_iff ?_).1 hc⟩
  rw [Subtype.range_coe_subtype]
  exact ⟨_, hb, by rwa [← de.toInducing.closure_eq_preimage_closure_image, hs.closure_eq]⟩
#align uniform_extend_subtype uniform_extend_subtype

theorem uniformly_extend_spec [CompleteSpace γ] (a : α) : Tendsto f (comap e (𝓝 a)) (𝓝 (ψ a)) := by
  simpa only [DenseInducing.extend] using
    tendsto_nhds_limUnder (uniformly_extend_exists h_e ‹_› h_f _)
#align uniformly_extend_spec uniformly_extend_spec

theorem uniformContinuous_uniformly_extend [CompleteSpace γ] : UniformContinuous ψ := fun d hd =>
  let ⟨s, hs, hs_comp⟩ := comp3_mem_uniformity hd
  have h_pnt : ∀ {a m}, m ∈ 𝓝 a → ∃ c ∈ f '' (e ⁻¹' m), (c, ψ a) ∈ s ∧ (ψ a, c) ∈ s :=
    fun {a m} hm =>
    have nb : NeBot (map f (comap e (𝓝 a))) :=
      ((h_e.denseInducing h_dense).comap_nhds_neBot _).map _
    have :
      f '' (e ⁻¹' m) ∩ ({ c | (c, ψ a) ∈ s } ∩ { c | (ψ a, c) ∈ s }) ∈ map f (comap e (𝓝 a)) :=
      inter_mem (image_mem_map <| preimage_mem_comap <| hm)
        (uniformly_extend_spec h_e h_dense h_f _
          (inter_mem (mem_nhds_right _ hs) (mem_nhds_left _ hs)))
    nb.nonempty_of_mem this
  have : (Prod.map f f) ⁻¹' s ∈ 𝓤 β := h_f hs
  have : (Prod.map f f) ⁻¹' s ∈ comap (Prod.map e e) (𝓤 α) := by
    rwa [← h_e.comap_uniformity] at this
  let ⟨t, ht, ts⟩ := this
  show (Prod.map ψ ψ) ⁻¹' d ∈ 𝓤 α from
    mem_of_superset (interior_mem_uniformity ht) fun ⟨x₁, x₂⟩ hx_t => by
      have : interior t ∈ 𝓝 (x₁, x₂) := isOpen_interior.mem_nhds hx_t
      let ⟨m₁, hm₁, m₂, hm₂, (hm : m₁ ×ˢ m₂ ⊆ interior t)⟩ := mem_nhds_prod_iff.mp this
      obtain ⟨_, ⟨a, ha₁, rfl⟩, _, ha₂⟩ := h_pnt hm₁
      obtain ⟨_, ⟨b, hb₁, rfl⟩, hb₂, _⟩ := h_pnt hm₂
      have : Prod.map f f (a, b) ∈ s :=
        ts <| mem_preimage.2 <| interior_subset (@hm (e a, e b) ⟨ha₁, hb₁⟩)
      exact hs_comp ⟨f a, ha₂, ⟨f b, this, hb₂⟩⟩
#align uniform_continuous_uniformly_extend uniformContinuous_uniformly_extend

variable [SeparatedSpace γ]

theorem uniformly_extend_of_ind (b : β) : ψ (e b) = f b :=
  DenseInducing.extend_eq_at _ h_f.continuous.continuousAt
#align uniformly_extend_of_ind uniformly_extend_of_ind

theorem uniformly_extend_unique {g : α → γ} (hg : ∀ b, g (e b) = f b) (hc : Continuous g) : ψ = g :=
  DenseInducing.extend_unique _ hg hc
#align uniformly_extend_unique uniformly_extend_unique

end UniformExtension


import .differentiablity
import analysis.special_functions.exp_log

open real

variables {E : Type*} [normed_group E] [normed_space ℝ E] {f : E → ℝ}
  {x : E}

@[differentiability] lemma differentiable_at.sin' (hc : differentiable_at ℝ f x) :
  differentiable_at ℝ (λx, real.sin (f x)) x := sorry

@[differentiability] lemma differentiable_at_id'' : differentiable_at ℝ (λ x, x) x :=
(has_fderiv_at_id x).differentiable_at

example {f : ℝ → ℝ} (x: ℝ) : differentiable_at ℝ (λx, real.sin (x)) x := by differentiability


import analysis.normed_space.finite_dimension

variables (K V : Type*) [nontrivially_normed_field K] [normed_add_comm_group V] [normed_space K V]

-- Def 2.3.2/2
def is_weakly_cartesian : Prop :=
  ∀ (U : subspace K V) (hU : finite_dimensional K U), is_closed (U : set V)

--Prop. 2.3.3/4
lemma is_weakly_cartesian_over_complete_of_fd [complete_space K] (h : finite_dimensional K V) :
  is_weakly_cartesian K V :=
λ U hU, submodule.closed_of_finite_dimensional _

lemma is_weakly_cartesian_over_complete [complete_space K] :
  is_weakly_cartesian K V :=
by { introsI U hU, exact submodule.closed_of_finite_dimensional U }

instance is_complete_of_fd_over_complete [complete_space K] (h : finite_dimensional K V):
  complete_space V :=
finite_dimensional.complete K V

-- TODO: probably won't need is_weakly_cartesian, since these lemmas are essentially in mathlib


import .basic
import ..myint.basic
import ..myfield.order

namespace hidden

open myring
open ordered_myring
open ordered_integral_domain

namespace frac

def le (x y : frac): Prop :=
x.num * y.denom ≤ y.num * x.denom

instance: has_le frac := ⟨le⟩

theorem le_def (x y: frac):
x ≤ y ↔ x.num * y.denom ≤ y.num * x.denom := iff.rfl

private theorem le_right {a x b y : frac} :
a ≈ b → x ≈ y → (a ≤ x) → (b ≤ y) :=
begin
  assume hab hxy halx,
  rw setoid_equiv at hab,
  rw setoid_equiv at hxy,
  rw le_def,
  rw le_def at halx,
  have : 0 < x.denom * a.denom, {
    from zero_lt_mul x.denom_pos a.denom_pos,
  },
  rw ←le_mul_cancel_pos_right _ _ (x.denom * a.denom) this,
  conv {
    congr,
    rw mul_assoc,
    rw mul_comm,
    rw mul_assoc,
    rw mul_assoc,
    congr, skip, congr, skip,
    rw mul_comm,
    rw ←hab,
    skip,
    rw mul_comm x.denom,
    rw mul_assoc,
    rw mul_comm,
    rw mul_assoc,
    rw mul_assoc,
    congr, skip, congr, skip,
    rw mul_comm,
    rw ←hxy,
  },
  have hrw: y.denom * (x.denom * (a.num * b.denom)) = y.denom * b.denom * (a.num * x.denom), {
    ac_refl,
  },
  have hrw2: b.denom * (a.denom * (x.num * y.denom)) = y.denom * b.denom * (x.num * a.denom), {
    ac_refl,
  },
  rw hrw,
  rw hrw2,
  apply le_mul_nonneg_left, {
    apply zero_le_mul; apply lt_impl_le, {
      from y.denom_pos,
    }, {
      from b.denom_pos,
    },
  }, {
    assumption,
  },
end

theorem le_well_defined (a x b y : frac) :
a ≈ b → x ≈ y → (a ≤ x) = (b ≤ y) :=
begin
  assume hab hxy,
  apply propext,
  from
    iff.intro
      (le_right hab hxy)
      (le_right (setoid.symm hab) (setoid.symm hxy)),
end

instance decidable_le: ∀ x y: frac, decidable (x ≤ y) :=
λ x y, myint.decidable_le _ _

end frac

namespace myrat

def le := quotient.lift₂ frac.le frac.le_well_defined

instance: has_le myrat := ⟨le⟩
instance has_le2: has_le (quotient frac.frac.setoid) := ⟨le⟩

instance decidable_le: ∀ x y: myrat, decidable (x ≤ y) :=
myint.quotient_decidable_rel frac.le frac.le_well_defined

private theorem le_frac_cls {x y : myrat} {a b : frac} :
(⟦a⟧ ≤ ⟦b⟧ ↔ a ≤ b) := iff.rfl

private theorem le_cls {a b : frac} :
(⟦a⟧ ≤ ⟦b⟧ ↔ a.num * b.denom ≤ b.num * a.denom) :=
iff.rfl

private theorem add_eq_cls {x y: frac}:
⟦x⟧ + ⟦y⟧ = ⟦x + y⟧ := rfl

private theorem mul_eq_cls {x y : frac}:
⟦x⟧ * ⟦y⟧ = ⟦x * y⟧ := rfl

variables x y z : myrat

instance: ordered_myfield myrat := ⟨
  by apply_instance,
  λ x y z: myrat,
  begin
    -- turn into z + x ≤ z + y ↔ x ≤ y for copy/paste purposes
    repeat {rw add_comm _ z},
    cases quotient.exists_rep x with a ha, subst ha,
    cases quotient.exists_rep y with b hb, subst hb,
    cases quotient.exists_rep z with c hc, subst hc,
    repeat { rw [add_eq_cls, le_cls] },
    repeat { rw frac.add_num <|> rw frac.add_denom, },
    rw [add_mul, add_mul],
    have : c.num * a.denom * (c.denom * b.denom) = c.num * b.denom * (c.denom * a.denom),
      ac_refl,
    rw this, clear this,
    rw ←le_add_cancel_left,
    have : a.num * c.denom * (c.denom * b.denom) = a.num * b.denom * c.denom * c.denom,
      ac_refl,
    rw this, clear this,
    have : b.num * c.denom * (c.denom * a.denom) = b.num * a.denom * c.denom * c.denom,
      ac_refl,
    rw this, clear this,
    rw le_mul_cancel_pos_right _ _ c.denom c.denom_pos,
    rw le_mul_cancel_pos_right _ _ c.denom c.denom_pos,
    from iff.rfl.mp,
    all_goals {apply myint.decidable_eq},
  end,
  λ x y: myrat,
  begin
    cases quotient.exists_rep x with a ha, subst ha,
    cases quotient.exists_rep y with b hb, subst hb,
    rw mul_eq_cls,
    rw rat_zero,
    repeat {rw le_cls},
    dsimp only [],
    repeat {rw zero_mul <|> rw mul_one},
    from zero_le_mul,
  end,
  λ x y z: myrat,
  begin
    assume hxy hyz,
    cases quotient.exists_rep x with a ha, subst ha,
    cases quotient.exists_rep y with b hb, subst hb,
    cases quotient.exists_rep z with c hc, subst hc,
    have hxy₁ := le_mul_nonneg_left _ _ _ (lt_impl_le c.denom_pos) hxy,
    have hyz₁ := le_mul_nonneg_left _ _ _ (lt_impl_le a.denom_pos) hyz,
    have : c.denom * (b.num * a.denom) = a.denom * (b.num * c.denom), ac_refl,
    rw this at hxy₁,
    have h : c.denom * (a.num * b.denom) ≤ a.denom * (c.num * b.denom),
      transitivity a.denom * (b.num * c.denom); assumption,
    clear hyz hxy hxy₁ hyz₁ this,
    have : c.denom * (a.num * b.denom) = b.denom * (a.num * c.denom), ac_refl,
    rw this at h, clear this,
    have : a.denom * (c.num * b.denom) = b.denom * (c.num * a.denom), ac_refl,
    rw this at h, clear this,
    rwa le_mul_cancel_pos_left _ _ b.denom b.denom_pos at h,
  end,
  λ x y: myrat,
  begin
    cases quotient.exists_rep x with a ha, subst ha,
    cases quotient.exists_rep y with b hb, subst hb,
    apply le_total_order,
  end,
  λ x y: myrat,
  begin
    assume hxy hyx,
    cases quotient.exists_rep x with a ha, subst ha,
    cases quotient.exists_rep y with b hb, subst hb,
    rw le_cls at hxy hyx,
    apply quotient.sound,
    rw frac.setoid_equiv,
    from le_antisymm hxy hyx,
  end⟩

theorem archimedes (x: myrat): ∃ n: myint, x ≤ ↑n :=
begin
  cases quotient.exists_rep x with a ha, subst ha,
  existsi abs a.num,
  rw coe_int,
  rw le_cls,
  simp,
  apply le_trans _ (self_le_abs _),
  conv {
    congr,
    rw mul_one,
    rw ←one_mul (abs a.num),
    rw mul_comm,
  },
  apply le_mul_comb_nonneg,
  from abs_nonneg _,
  from myint.le_add_rhs_coe 1 (le_refl _),
  from le_refl _,
  have := a.denom_pos,
  rw myint.lt_iff_succ_le at this,
  from this,
end

end myrat

end hidden


import Qpf
import Qpf.Examples._01_List
import Qpf.Macro.Tactic.FinDestr

open MvQPF

/-
  # Rose trees
  Now let us look at Rose Trees, that is, trees where each node has a label of type `α` and an arbitrary
  number of children.

  ```lean4
  inductive QpfTree (α : Type)
  | node : α → QpfList (QpfTree α) → QpfTree α
  ```

  First, we extract the shape functor. That is, we replace each distinct expression (which is not
  already a type variable) with a new type variable.
  In this case, that is only `QpfList (QpfTree α)`, which we represent with `β`

  ```lean4
  inductive QpfTree.Shape (α β : Type)
  | node : α → β  → QpfTree.Shape α β γ
  ```
-/

namespace QpfTree
  namespace Shape
    /-
      Since there is only one constructor, `def HeadT := Unit` would also have sufficed
    -/
    inductive HeadT
      | leaf
      | node

    abbrev ChildT : HeadT → TypeVec 4
      | .leaf => ![PFin2 1, PFin2 0, PFin2 0, PFin2 0]
      | .node => ![PFin2 0, PFin2 1, PFin2 1, PFin2 1]

    abbrev P := MvPFunctor.mk HeadT ChildT

    abbrev F := P.Obj.curried
  end Shape

  /-
    Before we can take the fixpoint, we need to compose this shape functor with QpfList in the second
    argument. Effectively, we want to define
    ```
      F α β := Shape.F α (QpfList β)
    ```

    Note that we don't care too much about whether `F` is a polynomial functor, we just require it
    to be a QPF, so we'll invoke the composition of QPFs here.

    To do so, we have to supply two binary functors to be composed with `Shape.P.Obj`.
    The first functor is trivial, it's the projection to the second argument (we count the
    arguments right-to-left, since that is how the `Vec`s are built).
    ```
      G₁ α β := α           -- (hence, G₁ := Prj 1)
    ```
    The second functor is a bit more involved. We want to invoke `QpfList`, which expects a single
    argument, but `G₂` should be a binary functor. Additionally, the argument we want to apply
    `QpfList` to is `β`, the second argument, so we compose `QpfList` with a projection functor
    ```
      G₂ α β := QpfList β   -- (hence, G₂ := Comp QpfList' ![Prj 0])
    ```
  -/

  abbrev Base : TypeFun 2
    := Comp Shape.P.Obj ![
        Prj 1,
        Prj 1,
        Prj 1,
        Comp QpfList' ![Prj 0]
    ]

  /-
    There is also a `qpf` command, which will define the right projections and compositions for us!
  -/
  qpf F_curried α β := Shape.F α (QpfList β)

  /-
    The command will give us a curried type function, the internal, uncurried, function can be found
    under `.typefun`
  -/
  #check (F_curried : Type _ → Type _ → Type _)
  #check (F_curried.typefun : TypeFun 2)

  abbrev F := F_curried.typefun

    -- -- Unfold the definitions, to see both are applications of `Comp`
    -- dsimp [F_manual, F_curried.typefun]
    -- apply congrArg;

    -- -- At this point, the goal is to show that two vectors, of known size are equal.
    -- -- These vectors are not definitially equal, but their respective elements are.
    -- funext i;
    -- -- The following tactic takes a `i : Fin2 n`, where `n` is a known constant, and breaks the goal
    -- -- into `n` subgoals, one for each concrete possible value of `i`
    -- fin_destr i <;> rfl

  /-
    Type class inference works as expected, it can reason about the vectors of functors involved
    in compositions
  -/
  example : MvQPF F := by infer_instance

  abbrev QpfTree' := Fix F
  abbrev QpfTree  := QpfTree'.curried

  /-
  ## Constructor

  -- We'd like to take `QpfList (QpfTree α)` as an argument, since that is what users expect.
  -- However, `Fix.mk` expects something akin to `(Comp QpfList' ![Prj 0]) ![_, QpfTree' ![α]]`,
  -- which is not definitionally equal, so we'll have to massage the types a bit
  -/

  def node (a : α) (children : QpfList (QpfTree α)) : QpfTree α :=
    Fix.mk ⟨Shape.HeadT.node,
            fun i _ => match i with
            | 0 => children
                    -- by
                    -- apply cast ?_ children;
                    -- unfold QpfList;
                    -- dsimp only [TypeFun.curried, TypeFun.curriedAux, TypeFun.reverseArgs]
                    -- apply congrArg
                    -- vec_eq;
            | 1 => a
    ⟩

  /-
    Even though there are some `sorry`s left in the formalization codebase, all of the machinery
    for inductive types is fully proven, and indeed, we can construct `QpfTree` without depending
    on `sorryAx`
  -/
  #print axioms node

end QpfTree

export QpfTree (QpfTree QpfTree')


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Reid Barton, Simon Hudon, Kenny Lau

! This file was ported from Lean 3 source module data.opposite
! leanprover-community/mathlib commit 99e8971dc62f1f7ecf693d75e75fbbabd55849de
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Logic.Equiv.Defs

/-!
# Opposites

In this file we define a type synonym `Opposite α := α`, denoted by `αᵒᵖ` and two synonyms for the
identity map, `op : α → αᵒᵖ` and `unop : αᵒᵖ → α`. If `α` is a category, then `αᵒᵖ` is the opposite
category, with all arrows reversed.
-/

universe v u

-- morphism levels before object levels. See note [CategoryTheory universes].
variable (α : Sort u)

/-- The type of objects of the opposite of `α`; used to define the opposite category.

  In order to avoid confusion between `α` and its opposite type, we
  set up the type of objects `Opposite α` using the following pattern,
  which will be repeated later for the morphisms.

  1. Define `Opposite α := α`.
  2. Define the isomorphisms `op : α → Opposite α`, `unop : Opposite α → α`.
  3. Make the definition `Opposite` irreducible.

  This has the following consequences.

  * `Opposite α` and `α` are distinct types in the elaborator, so you
    must use `op` and `unop` explicitly to convert between them.
  * Both `unop (op X) = X` and `op (unop X) = X` are definitional
    equalities. Notably, every object of the opposite category is
    definitionally of the form `op X`, which greatly simplifies the
    definition of the structure of the opposite category, for example.

  (Now that Lean 4 supports definitional eta equality for records, we could
  achieve the same goals using a structure with one field.)
-/
def Opposite : Sort u :=
  α
#align opposite Opposite

@[inherit_doc]
notation:max -- Use a high right binding power (like that of postfix ⁻¹) so that, for example,
-- `Presheaf Cᵒᵖ` parses as `Presheaf (Cᵒᵖ)` and not `(Presheaf C)ᵒᵖ`.
α "ᵒᵖ" => Opposite α

namespace Opposite

variable {α}

/-- The canonical map `α → αᵒᵖ`. -/
-- Porting note: pp_nodot has not been implemented.
--@[pp_nodot]
def op : α → αᵒᵖ :=
  id
#align opposite.op Opposite.op

/-- The canonical map `αᵒᵖ → α`. -/
-- Porting note: pp_nodot has not been implemented.
--@[pp_nodot]
def unop : αᵒᵖ → α :=
  id
#align opposite.unop Opposite.unop

theorem op_injective : Function.Injective (op : α → αᵒᵖ) := fun _ _ => id
#align opposite.op_injective Opposite.op_injective

theorem unop_injective : Function.Injective (unop : αᵒᵖ → α) := fun _ _ => id
#align opposite.unop_injective Opposite.unop_injective

@[simp]
theorem op_unop (x : αᵒᵖ) : op (unop x) = x :=
  rfl
#align opposite.op_unop Opposite.op_unop

@[simp]
theorem unop_op (x : α) : unop (op x) = x :=
  rfl
#align opposite.unop_op Opposite.unop_op

-- We could prove these by `Iff.rfl`, but that would make these eligible for `dsimp`. That would be
-- a bad idea because `Opposite` is irreducible.
@[simp]
theorem op_inj_iff (x y : α) : op x = op y ↔ x = y :=
  op_injective.eq_iff
#align opposite.op_inj_iff Opposite.op_inj_iff

@[simp]
theorem unop_inj_iff (x y : αᵒᵖ) : unop x = unop y ↔ x = y :=
  unop_injective.eq_iff
#align opposite.unop_inj_iff Opposite.unop_inj_iff

/-- The type-level equivalence between a type and its opposite. -/
def equivToOpposite : α ≃ αᵒᵖ where
  toFun := op
  invFun := unop
  left_inv := unop_op
  right_inv := op_unop
#align opposite.equiv_to_opposite Opposite.equivToOpposite

@[simp]
theorem equivToOpposite_coe : (equivToOpposite : α → αᵒᵖ) = op :=
  rfl
#align opposite.equiv_to_opposite_coe Opposite.equivToOpposite_coe

@[simp]
theorem equivToOpposite_symm_coe : (equivToOpposite.symm : αᵒᵖ → α) = unop :=
  rfl
#align opposite.equiv_to_opposite_symm_coe Opposite.equivToOpposite_symm_coe

theorem op_eq_iff_eq_unop {x : α} {y} : op x = y ↔ x = unop y :=
  equivToOpposite.apply_eq_iff_eq_symm_apply
#align opposite.op_eq_iff_eq_unop Opposite.op_eq_iff_eq_unop

theorem unop_eq_iff_eq_op {x} {y : α} : unop x = y ↔ x = op y :=
  equivToOpposite.symm.apply_eq_iff_eq_symm_apply
#align opposite.unop_eq_iff_eq_op Opposite.unop_eq_iff_eq_op

instance [Inhabited α] : Inhabited αᵒᵖ :=
  ⟨op default⟩

/-- A recursor for `Opposite`. Use as `induction x using Opposite.rec`. -/
@[simp]
protected def rec {F : αᵒᵖ → Sort v} (h : ∀ X, F (op X)) : ∀ X, F X := fun X => h (unop X)
#align opposite.rec Opposite.rec

end Opposite


import Std.Data.AssocList
import Std.Data.List.Lemmas

namespace MWE7

abbrev Strings := List String

def addBoth : (Std.AssocList String Strings) → String → String → (Std.AssocList String Strings)
| .nil, sub, sup            => .cons sup [] (.cons sub [sup] .nil)
| .cons a as tail, sub, sup => bif a = sub then .cons sub (as.insert sup) tail else .cons a as (addBoth tail sub sup)

theorem addBoth.nil (sub: String) (sup: String)
: (addBoth .nil sub sup).contains sub && (addBoth .nil sub sup).contains sup
:= by simp [addBoth]

theorem cond_eq_ite (c : Bool) (a b : α) : cond c a b = if c then a else b := by cases c <;> rfl

theorem addBoth.sub (ss: Std.AssocList String Strings) (sub: String) (sup: String)
: (addBoth ss sub sup).contains sub
:= by
  simp [Std.AssocList.contains]
  induction ss <;> simp [addBoth]
  . next key value tail tail_ih =>
    simp [addBoth]
    simp [cond_eq_ite]
    by_cases key = sup
    . case pos h =>
      simp [h]
      by_cases sub = sup
      . case pos ss =>
        simp [ss]
      . case neg ss =>
        split <;> simp_all
    . case neg =>
      split <;> simp_all

end MWE7