/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Kenny Lau, Yury Kudryashov
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.list.pairwise
import Mathlib.logic.relation
import Mathlib.PostPort

universes u v

namespace Mathlib

namespace list

/- chain relation (conjunction of R a b ∧ R b c ∧ R c d ...) -/

theorem chain_iff {α : Type u} (R : α → α → Prop) : ∀ (ᾰ : α) (ᾰ_1 : List α),
  chain R ᾰ ᾰ_1 ↔ ᾰ_1 = [] ∨ Exists fun {b : α} => Exists fun {l : List α} => R ᾰ b ∧ chain R b l ∧ ᾰ_1 = b :: l := sorry

theorem rel_of_chain_cons {α : Type u} {R : α → α → Prop} {a : α} {b : α} {l : List α} (p : chain R a (b :: l)) : R a b :=
  and.left (iff.mp chain_cons p)

theorem chain_of_chain_cons {α : Type u} {R : α → α → Prop} {a : α} {b : α} {l : List α} (p : chain R a (b :: l)) : chain R b l :=
  and.right (iff.mp chain_cons p)

theorem chain.imp' {α : Type u} {R : α → α → Prop} {S : α → α → Prop} (HRS : ∀ {a b : α}, R a b → S a b) {a : α} {b : α} (Hab : ∀ {c : α}, R a c → S b c) {l : List α} (p : chain R a l) : chain S b l := sorry

theorem chain.imp {α : Type u} {R : α → α → Prop} {S : α → α → Prop} (H : ∀ (a b : α), R a b → S a b) {a : α} {l : List α} (p : chain R a l) : chain S a l :=
  chain.imp' H (H a) p

theorem chain.iff {α : Type u} {R : α → α → Prop} {S : α → α → Prop} (H : ∀ (a b : α), R a b ↔ S a b) {a : α} {l : List α} : chain R a l ↔ chain S a l :=
  { mp := chain.imp fun (a b : α) => iff.mp (H a b), mpr := chain.imp fun (a b : α) => iff.mpr (H a b) }

theorem chain.iff_mem {α : Type u} {R : α → α → Prop} {a : α} {l : List α} : chain R a l ↔ chain (fun (x y : α) => x ∈ a :: l ∧ y ∈ l ∧ R x y) a l := sorry

theorem chain_singleton {α : Type u} {R : α → α → Prop} {a : α} {b : α} : chain R a [b] ↔ R a b := sorry

theorem chain_split {α : Type u} {R : α → α → Prop} {a : α} {b : α} {l₁ : List α} {l₂ : List α} : chain R a (l₁ ++ b :: l₂) ↔ chain R a (l₁ ++ [b]) ∧ chain R b l₂ := sorry

theorem chain_map {α : Type u} {β : Type v} {R : α → α → Prop} (f : β → α) {b : β} {l : List β} : chain R (f b) (map f l) ↔ chain (fun (a b : β) => R (f a) (f b)) b l := sorry

theorem chain_of_chain_map {α : Type u} {β : Type v} {R : α → α → Prop} {S : β → β → Prop} (f : α → β) (H : ∀ (a b : α), S (f a) (f b) → R a b) {a : α} {l : List α} (p : chain S (f a) (map f l)) : chain R a l :=
  chain.imp H (iff.mp (chain_map f) p)

theorem chain_map_of_chain {α : Type u} {β : Type v} {R : α → α → Prop} {S : β → β → Prop} (f : α → β) (H : ∀ (a b : α), R a b → S (f a) (f b)) {a : α} {l : List α} (p : chain R a l) : chain S (f a) (map f l) :=
  iff.mpr (chain_map f) (chain.imp H p)

theorem chain_pmap_of_chain {α : Type u} {β : Type v} {R : α → α → Prop} {S : β → β → Prop} {p : α → Prop} {f : (a : α) → p a → β} (H : ∀ (a b : α) (ha : p a) (hb : p b), R a b → S (f a ha) (f b hb)) {a : α} {l : List α} (hl₁ : chain R a l) (ha : p a) (hl₂ : ∀ (a : α), a ∈ l → p a) : chain S (f a ha) (pmap f l hl₂) := sorry

theorem chain_of_chain_pmap {α : Type u} {β : Type v} {R : α → α → Prop} {S : β → β → Prop} {p : α → Prop} (f : (a : α) → p a → β) {l : List α} (hl₁ : ∀ (a : α), a ∈ l → p a) {a : α} (ha : p a) (hl₂ : chain S (f a ha) (pmap f l hl₁)) (H : ∀ (a b : α) (ha : p a) (hb : p b), S (f a ha) (f b hb) → R a b) : chain R a l := sorry

theorem chain_of_pairwise {α : Type u} {R : α → α → Prop} {a : α} {l : List α} (p : pairwise R (a :: l)) : chain R a l := sorry

theorem chain_iff_pairwise {α : Type u} {R : α → α → Prop} (tr : transitive R) {a : α} {l : List α} : chain R a l ↔ pairwise R (a :: l) := sorry

theorem chain_iff_nth_le {α : Type u} {R : α → α → Prop} {a : α} {l : List α} : chain R a l ↔
  (∀ (h : 0 < length l), R a (nth_le l 0 h)) ∧
    ∀ (i : ℕ) (h : i < length l - 1), R (nth_le l i (nat.lt_of_lt_pred h)) (nth_le l (i + 1) (iff.mp nat.lt_pred_iff h)) := sorry

theorem chain'.imp {α : Type u} {R : α → α → Prop} {S : α → α → Prop} (H : ∀ (a b : α), R a b → S a b) {l : List α} (p : chain' R l) : chain' S l :=
  list.cases_on l (fun (p : chain' R []) => trivial)
    (fun (l_hd : α) (l_tl : List α) (p : chain' R (l_hd :: l_tl)) => chain.imp H p) p

theorem chain'.iff {α : Type u} {R : α → α → Prop} {S : α → α → Prop} (H : ∀ (a b : α), R a b ↔ S a b) {l : List α} : chain' R l ↔ chain' S l :=
  { mp := chain'.imp fun (a b : α) => iff.mp (H a b), mpr := chain'.imp fun (a b : α) => iff.mpr (H a b) }

theorem chain'.iff_mem {α : Type u} {R : α → α → Prop} {l : List α} : chain' R l ↔ chain' (fun (x y : α) => x ∈ l ∧ y ∈ l ∧ R x y) l := sorry

@[simp] theorem chain'_nil {α : Type u} {R : α → α → Prop} : chain' R [] :=
  trivial

@[simp] theorem chain'_singleton {α : Type u} {R : α → α → Prop} (a : α) : chain' R [a] :=
  chain.nil

theorem chain'_split {α : Type u} {R : α → α → Prop} {a : α} {l₁ : List α} {l₂ : List α} : chain' R (l₁ ++ a :: l₂) ↔ chain' R (l₁ ++ [a]) ∧ chain' R (a :: l₂) := sorry

theorem chain'_map {α : Type u} {β : Type v} {R : α → α → Prop} (f : β → α) {l : List β} : chain' R (map f l) ↔ chain' (fun (a b : β) => R (f a) (f b)) l :=
  list.cases_on l (iff.refl (chain' R (map f []))) fun (l_hd : β) (l_tl : List β) => chain_map f

theorem chain'_of_chain'_map {α : Type u} {β : Type v} {R : α → α → Prop} {S : β → β → Prop} (f : α → β) (H : ∀ (a b : α), S (f a) (f b) → R a b) {l : List α} (p : chain' S (map f l)) : chain' R l :=
  chain'.imp H (iff.mp (chain'_map f) p)

theorem chain'_map_of_chain' {α : Type u} {β : Type v} {R : α → α → Prop} {S : β → β → Prop} (f : α → β) (H : ∀ (a b : α), R a b → S (f a) (f b)) {l : List α} (p : chain' R l) : chain' S (map f l) :=
  iff.mpr (chain'_map f) (chain'.imp H p)

theorem pairwise.chain' {α : Type u} {R : α → α → Prop} {l : List α} : pairwise R l → chain' R l := sorry

theorem chain'_iff_pairwise {α : Type u} {R : α → α → Prop} (tr : transitive R) {l : List α} : chain' R l ↔ pairwise R l :=
  list.cases_on l (idRhs (True ↔ pairwise R []) (iff.symm (iff_true_intro pairwise.nil)))
    fun (l_hd : α) (l_tl : List α) => idRhs (chain R l_hd l_tl ↔ pairwise R (l_hd :: l_tl)) (chain_iff_pairwise tr)

@[simp] theorem chain'_cons {α : Type u} {R : α → α → Prop} {x : α} {y : α} {l : List α} : chain' R (x :: y :: l) ↔ R x y ∧ chain' R (y :: l) :=
  chain_cons

theorem chain'.cons {α : Type u} {R : α → α → Prop} {x : α} {y : α} {l : List α} (h₁ : R x y) (h₂ : chain' R (y :: l)) : chain' R (x :: y :: l) :=
  iff.mpr chain'_cons { left := h₁, right := h₂ }

theorem chain'.tail {α : Type u} {R : α → α → Prop} {l : List α} (h : chain' R l) : chain' R (tail l) := sorry

theorem chain'.rel_head {α : Type u} {R : α → α → Prop} {x : α} {y : α} {l : List α} (h : chain' R (x :: y :: l)) : R x y :=
  rel_of_chain_cons h

theorem chain'.rel_head' {α : Type u} {R : α → α → Prop} {x : α} {l : List α} (h : chain' R (x :: l)) {y : α} (hy : y ∈ head' l) : R x y :=
  chain'.rel_head (eq.mp (Eq._oldrec (Eq.refl (chain' R (x :: l))) (Eq.symm (cons_head'_tail hy))) h)

theorem chain'.cons' {α : Type u} {R : α → α → Prop} {x : α} {l : List α} : chain' R l → (∀ (y : α), y ∈ head' l → R x y) → chain' R (x :: l) := sorry

theorem chain'_cons' {α : Type u} {R : α → α → Prop} {x : α} {l : List α} : chain' R (x :: l) ↔ (∀ (y : α), y ∈ head' l → R x y) ∧ chain' R l := sorry

theorem chain'.append {α : Type u} {R : α → α → Prop} {l₁ : List α} {l₂ : List α} (h₁ : chain' R l₁) (h₂ : chain' R l₂) (h : ∀ (x : α), x ∈ last' l₁ → ∀ (y : α), y ∈ head' l₂ → R x y) : chain' R (l₁ ++ l₂) := sorry

theorem chain'_pair {α : Type u} {R : α → α → Prop} {x : α} {y : α} : chain' R [x, y] ↔ R x y := sorry

theorem chain'.imp_head {α : Type u} {R : α → α → Prop} {x : α} {y : α} (h : ∀ {z : α}, R x z → R y z) {l : List α} (hl : chain' R (x :: l)) : chain' R (y :: l) :=
  chain'.cons' (chain'.tail hl) fun (z : α) (hz : z ∈ head' (tail (x :: l))) => h (chain'.rel_head' hl hz)

theorem chain'_reverse {α : Type u} {R : α → α → Prop} {l : List α} : chain' R (reverse l) ↔ chain' (flip R) l := sorry

theorem chain'_iff_nth_le {α : Type u} {R : α → α → Prop} {l : List α} : chain' R l ↔
  ∀ (i : ℕ) (h : i < length l - 1), R (nth_le l i (nat.lt_of_lt_pred h)) (nth_le l (i + 1) (iff.mp nat.lt_pred_iff h)) := sorry

/-- If `l₁ l₂` and `l₃` are lists and `l₁ ++ l₂` and `l₂ ++ l₃` both satisfy
  `chain' R`, then so does `l₁ ++ l₂ ++ l₃` provided `l₂ ≠ []` -/
theorem chain'.append_overlap {α : Type u} {R : α → α → Prop} {l₁ : List α} {l₂ : List α} {l₃ : List α} (h₁ : chain' R (l₁ ++ l₂)) (h₂ : chain' R (l₂ ++ l₃)) (hn : l₂ ≠ []) : chain' R (l₁ ++ l₂ ++ l₃) := sorry

/--
If `a` and `b` are related by the reflexive transitive closure of `r`, then there is a `r`-chain
starting from `a` and ending on `b`.
The converse of `relation_refl_trans_gen_of_exists_chain`.
-/
theorem exists_chain_of_relation_refl_trans_gen {α : Type u} {r : α → α → Prop} {a : α} {b : α} (h : relation.refl_trans_gen r a b) : ∃ (l : List α), chain r a l ∧ last (a :: l) (cons_ne_nil a l) = b := sorry

/--
Given a chain from `a` to `b`, and a predicate true at `b`, if `r x y → p y → p x` then
the predicate is true everywhere in the chain and at `a`.
That is, we can propagate the predicate up the chain.
-/
theorem chain.induction {α : Type u} {r : α → α → Prop} {a : α} {b : α} (p : α → Prop) (l : List α) (h : chain r a l) (hb : last (a :: l) (cons_ne_nil a l) = b) (carries : ∀ {x y : α}, r x y → p y → p x) (final : p b) (i : α) (H : i ∈ a :: l) : p i := sorry

/--
Given a chain from `a` to `b`, and a predicate true at `b`, if `r x y → p y → p x` then
the predicate is true at `a`.
That is, we can propagate the predicate all the way up the chain.
-/
theorem chain.induction_head {α : Type u} {r : α → α → Prop} {a : α} {b : α} (p : α → Prop) (l : List α) (h : chain r a l) (hb : last (a :: l) (cons_ne_nil a l) = b) (carries : ∀ {x y : α}, r x y → p y → p x) (final : p b) : p a :=
  chain.induction p l h hb carries final a (mem_cons_self a l)

/--
If there is an `r`-chain starting from `a` and ending at `b`, then `a` and `b` are related by the
reflexive transitive closure of `r`. The converse of `exists_chain_of_relation_refl_trans_gen`.
-/
theorem relation_refl_trans_gen_of_exists_chain {α : Type u} {r : α → α → Prop} {a : α} {b : α} (l : List α) (hl₁ : chain r a l) (hl₂ : last (a :: l) (cons_ne_nil a l) = b) : relation.refl_trans_gen r a b :=
  chain.induction_head (fun (_x : α) => relation.refl_trans_gen r _x b) l hl₁ hl₂
    (fun (x y : α) => relation.refl_trans_gen.head) relation.refl_trans_gen.refl


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

! This file was ported from Lean 3 source module data.pequiv
! leanprover-community/mathlib commit ee0c179cd3c8a45aa5bffbf1b41d8dbede452865
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Set.Basic

/-!

# Partial Equivalences

In this file, we define partial equivalences `PEquiv`, which are a bijection between a subset of `α`
and a subset of `β`. Notationally, a `PEquiv` is denoted by "`≃.`" (note that the full stop is part
of the notation). The way we store these internally is with two functions `f : α → Option β` and
the reverse function `g : β → Option α`, with the condition that if `f a` is `some b`,
then `g b` is `some a`.

## Main results

- `PEquiv.ofSet`: creates a `PEquiv` from a set `s`,
  which sends an element to itself if it is in `s`.
- `PEquiv.single`: given two elements `a : α` and `b : β`, create a `PEquiv` that sends them to
  each other, and ignores all other elements.
- `PEquiv.injective_of_forall_ne_isSome`/`injective_of_forall_isSome`: If the domain of a `PEquiv`
  is all of `α` (except possibly one point), its `toFun` is injective.

## Canonical order

`PEquiv` is canonically ordered by inclusion; that is, if a function `f` defined on a subset `s`
is equal to `g` on that subset, but `g` is also defined on a larger set, then `f ≤ g`. We also have
a definition of `⊥`, which is the empty `PEquiv` (sends all to `none`), which in the end gives us a
`SemilatticeInf` with an `OrderBot` instance.

## Tags

pequiv, partial equivalence

-/

universe u v w x

/-- A `PEquiv` is a partial equivalence, a representation of a bijection between a subset
  of `α` and a subset of `β`. See also `LocalEquiv` for a version that requires `toFun` and
`invFun` to be globally defined functions and has `source` and `target` sets as extra fields. -/
structure PEquiv (α : Type u) (β : Type v) where
  /-- The underlying partial function of a `PEquiv` -/
  toFun : α → Option β
  /-- The partial inverse of `toFun` -/
  invFun : β → Option α
  /-- `invFun` is the partial inverse of `toFun`  -/
  inv : ∀ (a : α) (b : β), a ∈ invFun b ↔ b ∈ toFun a
#align pequiv PEquiv

/-- A `PEquiv` is a partial equivalence, a representation of a bijection between a subset
  of `α` and a subset of `β`. See also `LocalEquiv` for a version that requires `toFun` and
`invFun` to be globally defined functions and has `source` and `target` sets as extra fields. -/
infixr:25 " ≃. " => PEquiv

namespace PEquiv

variable {α : Type u} {β : Type v} {γ : Type w} {δ : Type x}

open Function Option

instance : FunLike (α ≃. β) α fun _ => Option β :=
  { coe := toFun
    coe_injective' := by
      rintro ⟨f₁, f₂, hf⟩ ⟨g₁, g₂, hg⟩ (rfl : f₁ = g₁)
      congr with y x
      simp only [hf, hg] }

@[simp] theorem coe_mk (f₁ : α → Option β) (f₂ h) : (mk f₁ f₂ h : α → Option β) = f₁ :=
  rfl

theorem coe_mk_apply (f₁ : α → Option β) (f₂ : β → Option α) (h) (x : α) :
    (PEquiv.mk f₁ f₂ h : α → Option β) x = f₁ x :=
  rfl
#align pequiv.coe_mk_apply PEquiv.coe_mk_apply

@[ext] theorem ext {f g : α ≃. β} (h : ∀ x, f x = g x) : f = g :=
  FunLike.ext f g h
#align pequiv.ext PEquiv.ext

theorem ext_iff {f g : α ≃. β} : f = g ↔ ∀ x, f x = g x :=
  FunLike.ext_iff
#align pequiv.ext_iff PEquiv.ext_iff

/-- The identity map as a partial equivalence. -/
@[refl]
protected def refl (α : Type _) : α ≃. α where
  toFun := some
  invFun := some
  inv _ _ := eq_comm
#align pequiv.refl PEquiv.refl

/-- The inverse partial equivalence. -/
@[symm]
protected def symm (f : α ≃. β) : β ≃. α where
  toFun := f.2
  invFun := f.1
  inv _ _ := (f.inv _ _).symm
#align pequiv.symm PEquiv.symm

theorem mem_iff_mem (f : α ≃. β) : ∀ {a : α} {b : β}, a ∈ f.symm b ↔ b ∈ f a :=
  f.3 _ _
#align pequiv.mem_iff_mem PEquiv.mem_iff_mem

theorem eq_some_iff (f : α ≃. β) : ∀ {a : α} {b : β}, f.symm b = some a ↔ f a = some b :=
  f.3 _ _
#align pequiv.eq_some_iff PEquiv.eq_some_iff

/-- Composition of partial equivalences `f : α ≃. β` and `g : β ≃. γ`. -/
@[trans]
protected def trans (f : α ≃. β) (g : β ≃. γ) :
    α ≃. γ where
  toFun a := (f a).bind g
  invFun a := (g.symm a).bind f.symm
  inv a b := by simp_all [and_comm, eq_some_iff f, eq_some_iff g]
#align pequiv.trans PEquiv.trans

@[simp]
theorem refl_apply (a : α) : PEquiv.refl α a = some a :=
  rfl
#align pequiv.refl_apply PEquiv.refl_apply

@[simp]
theorem symm_refl : (PEquiv.refl α).symm = PEquiv.refl α :=
  rfl
#align pequiv.symm_refl PEquiv.symm_refl

@[simp]
theorem symm_symm (f : α ≃. β) : f.symm.symm = f := by cases f; rfl
#align pequiv.symm_symm PEquiv.symm_symm

theorem symm_injective : Function.Injective (@PEquiv.symm α β) :=
  LeftInverse.injective symm_symm
#align pequiv.symm_injective PEquiv.symm_injective

theorem trans_assoc (f : α ≃. β) (g : β ≃. γ) (h : γ ≃. δ) :
    (f.trans g).trans h = f.trans (g.trans h) :=
  ext fun _ => Option.bind_assoc _ _ _
#align pequiv.trans_assoc PEquiv.trans_assoc

theorem mem_trans (f : α ≃. β) (g : β ≃. γ) (a : α) (c : γ) :
    c ∈ f.trans g a ↔ ∃ b, b ∈ f a ∧ c ∈ g b :=
  Option.bind_eq_some'
#align pequiv.mem_trans PEquiv.mem_trans

theorem trans_eq_some (f : α ≃. β) (g : β ≃. γ) (a : α) (c : γ) :
    f.trans g a = some c ↔ ∃ b, f a = some b ∧ g b = some c :=
  Option.bind_eq_some'
#align pequiv.trans_eq_some PEquiv.trans_eq_some

theorem trans_eq_none (f : α ≃. β) (g : β ≃. γ) (a : α) :
    f.trans g a = none ↔ ∀ b c, b ∉ f a ∨ c ∉ g b := by
  simp only [eq_none_iff_forall_not_mem, mem_trans, imp_iff_not_or.symm]
  push_neg
  exact forall_swap
#align pequiv.trans_eq_none PEquiv.trans_eq_none

@[simp]
theorem refl_trans (f : α ≃. β) : (PEquiv.refl α).trans f = f := by
  ext; dsimp [PEquiv.trans]; rfl
#align pequiv.refl_trans PEquiv.refl_trans

@[simp]
theorem trans_refl (f : α ≃. β) : f.trans (PEquiv.refl β) = f := by
  ext; dsimp [PEquiv.trans]; simp
#align pequiv.trans_refl PEquiv.trans_refl

protected theorem inj (f : α ≃. β) {a₁ a₂ : α} {b : β} (h₁ : b ∈ f a₁) (h₂ : b ∈ f a₂) : a₁ = a₂ :=
  by rw [← mem_iff_mem] at *; cases h : f.symm b <;> simp_all
#align pequiv.inj PEquiv.inj

/-- If the domain of a `PEquiv` is `α` except a point, its forward direction is injective. -/
theorem injective_of_forall_ne_isSome (f : α ≃. β) (a₂ : α)
    (h : ∀ a₁ : α, a₁ ≠ a₂ → isSome (f a₁)) : Injective f :=
  HasLeftInverse.injective
    ⟨fun b => Option.recOn b a₂ fun b' => Option.recOn (f.symm b') a₂ id, fun x => by
      classical
        cases hfx : f x
        · have : x = a₂ := not_imp_comm.1 (h x) (hfx.symm ▸ by simp)
          simp [this]
        · dsimp only
          rw [(eq_some_iff f).2 hfx]
          rfl⟩
#align pequiv.injective_of_forall_ne_is_some PEquiv.injective_of_forall_ne_isSome

/-- If the domain of a `PEquiv` is all of `α`, its forward direction is injective. -/
theorem injective_of_forall_isSome {f : α ≃. β} (h : ∀ a : α, isSome (f a)) : Injective f :=
  (Classical.em (Nonempty α)).elim
    (fun hn => injective_of_forall_ne_isSome f (Classical.choice hn) fun a _ => h a) fun hn x =>
    (hn ⟨x⟩).elim
#align pequiv.injective_of_forall_is_some PEquiv.injective_of_forall_isSome

section OfSet

variable (s : Set α) [DecidablePred (· ∈ s)]

/-- Creates a `PEquiv` that is the identity on `s`, and `none` outside of it. -/
def ofSet (s : Set α) [DecidablePred (· ∈ s)] :
    α ≃. α where
  toFun a := if a ∈ s then some a else none
  invFun a := if a ∈ s then some a else none
  inv a b := by
    dsimp only
    split_ifs with hb ha ha
    · simp [eq_comm]
    · simp [ne_of_mem_of_not_mem hb ha]
    · simp [ne_of_mem_of_not_mem ha hb]
    · simp
#align pequiv.of_set PEquiv.ofSet

theorem mem_ofSet_self_iff {s : Set α} [DecidablePred (· ∈ s)] {a : α} : a ∈ ofSet s a ↔ a ∈ s :=
  by dsimp [ofSet]; split_ifs <;> simp [*]
#align pequiv.mem_of_set_self_iff PEquiv.mem_ofSet_self_iff

theorem mem_ofSet_iff {s : Set α} [DecidablePred (· ∈ s)] {a b : α} :
    a ∈ ofSet s b ↔ a = b ∧ a ∈ s := by
  dsimp [ofSet]
  split_ifs with h
  · simp only [mem_def, eq_comm, some.injEq, iff_self_and]
    rintro rfl
    exact h
  · simp only [mem_def, false_iff, not_and]
    rintro rfl
    exact h
#align pequiv.mem_of_set_iff PEquiv.mem_ofSet_iff

@[simp]
theorem ofSet_eq_some_iff {s : Set α} {_ : DecidablePred (· ∈ s)} {a b : α} :
    ofSet s b = some a ↔ a = b ∧ a ∈ s :=
  mem_ofSet_iff
#align pequiv.of_set_eq_some_iff PEquiv.ofSet_eq_some_iff

theorem ofSet_eq_some_self_iff {s : Set α} {_ : DecidablePred (· ∈ s)} {a : α} :
    ofSet s a = some a ↔ a ∈ s :=
  mem_ofSet_self_iff
#align pequiv.of_set_eq_some_self_iff PEquiv.ofSet_eq_some_self_iff

@[simp]
theorem ofSet_symm : (ofSet s).symm = ofSet s :=
  rfl
#align pequiv.of_set_symm PEquiv.ofSet_symm

@[simp]
theorem ofSet_univ : ofSet Set.univ = PEquiv.refl α :=
  rfl
#align pequiv.of_set_univ PEquiv.ofSet_univ

@[simp]
theorem ofSet_eq_refl {s : Set α} [DecidablePred (· ∈ s)] :
    ofSet s = PEquiv.refl α ↔ s = Set.univ :=
  ⟨fun h => by
    rw [Set.eq_univ_iff_forall]
    intro
    rw [← mem_ofSet_self_iff, h]
    exact rfl, fun h => by simp only [← ofSet_univ, h]⟩
#align pequiv.of_set_eq_refl PEquiv.ofSet_eq_refl

end OfSet

theorem symm_trans_rev (f : α ≃. β) (g : β ≃. γ) : (f.trans g).symm = g.symm.trans f.symm :=
  rfl
#align pequiv.symm_trans_rev PEquiv.symm_trans_rev

theorem self_trans_symm (f : α ≃. β) : f.trans f.symm = ofSet { a | (f a).isSome } := by
  ext
  dsimp [PEquiv.trans]
  simp only [eq_some_iff f, Option.isSome_iff_exists, Option.mem_def, bind_eq_some',
    ofSet_eq_some_iff]
  constructor
  · rintro ⟨b, hb₁, hb₂⟩
    exact ⟨PEquiv.inj _ hb₂ hb₁, b, hb₂⟩
  · simp (config := { contextual := true })
#align pequiv.self_trans_symm PEquiv.self_trans_symm

theorem symm_trans_self (f : α ≃. β) : f.symm.trans f = ofSet { b | (f.symm b).isSome } :=
  symm_injective <| by simp [symm_trans_rev, self_trans_symm, -symm_symm]
#align pequiv.symm_trans_self PEquiv.symm_trans_self

theorem trans_symm_eq_iff_forall_isSome {f : α ≃. β} :
    f.trans f.symm = PEquiv.refl α ↔ ∀ a, isSome (f a) := by
  rw [self_trans_symm, ofSet_eq_refl, Set.eq_univ_iff_forall]; rfl
#align pequiv.trans_symm_eq_iff_forall_is_some PEquiv.trans_symm_eq_iff_forall_isSome

instance : Bot (α ≃. β) :=
  ⟨{  toFun := fun _ => none
      invFun := fun _ => none
      inv := by simp }⟩

instance : Inhabited (α ≃. β) :=
  ⟨⊥⟩

@[simp]
theorem bot_apply (a : α) : (⊥ : α ≃. β) a = none :=
  rfl
#align pequiv.bot_apply PEquiv.bot_apply

@[simp]
theorem symm_bot : (⊥ : α ≃. β).symm = ⊥ :=
  rfl
#align pequiv.symm_bot PEquiv.symm_bot

@[simp]

@[simp]
theorem bot_trans (f : β ≃. γ) : (⊥ : α ≃. β).trans f = ⊥ := by
  ext; dsimp [PEquiv.trans]; simp
#align pequiv.bot_trans PEquiv.bot_trans

theorem isSome_symm_get (f : α ≃. β) {a : α} (h : isSome (f a)) :
    isSome (f.symm (Option.get _ h)) :=
  isSome_iff_exists.2 ⟨a, by rw [f.eq_some_iff, some_get]⟩
#align pequiv.is_some_symm_get PEquiv.isSome_symm_get

section Single

variable [DecidableEq α] [DecidableEq β] [DecidableEq γ]

/-- Create a `PEquiv` which sends `a` to `b` and `b` to `a`, but is otherwise `none`. -/
def single (a : α) (b : β) :
    α ≃. β where
  toFun x := if x = a then some b else none
  invFun x := if x = b then some a else none
  inv x y := by
    dsimp only
    split_ifs with h1 h2
    . simp [*]
    . simp only [mem_def, some.injEq, iff_false] at *
      exact Ne.symm h2
    . simp only [mem_def, some.injEq, false_iff] at *
      exact Ne.symm h1
    . simp
#align pequiv.single PEquiv.single

theorem mem_single (a : α) (b : β) : b ∈ single a b a :=
  if_pos rfl
#align pequiv.mem_single PEquiv.mem_single

theorem mem_single_iff (a₁ a₂ : α) (b₁ b₂ : β) : b₁ ∈ single a₂ b₂ a₁ ↔ a₁ = a₂ ∧ b₁ = b₂ := by
  dsimp [single]; split_ifs <;> simp [*, eq_comm]
#align pequiv.mem_single_iff PEquiv.mem_single_iff

@[simp]
theorem symm_single (a : α) (b : β) : (single a b).symm = single b a :=
  rfl
#align pequiv.symm_single PEquiv.symm_single

@[simp]
theorem single_apply (a : α) (b : β) : single a b a = some b :=
  if_pos rfl
#align pequiv.single_apply PEquiv.single_apply

theorem single_apply_of_ne {a₁ a₂ : α} (h : a₁ ≠ a₂) (b : β) : single a₁ b a₂ = none :=
  if_neg h.symm
#align pequiv.single_apply_of_ne PEquiv.single_apply_of_ne

theorem single_trans_of_mem (a : α) {b : β} {c : γ} {f : β ≃. γ} (h : c ∈ f b) :
    (single a b).trans f = single a c := by
  ext
  dsimp [single, PEquiv.trans]
  split_ifs <;> simp_all
#align pequiv.single_trans_of_mem PEquiv.single_trans_of_mem

theorem trans_single_of_mem {a : α} {b : β} (c : γ) {f : α ≃. β} (h : b ∈ f a) :
    f.trans (single b c) = single a c :=
  symm_injective <| single_trans_of_mem _ ((mem_iff_mem f).2 h)
#align pequiv.trans_single_of_mem PEquiv.trans_single_of_mem

@[simp]
theorem single_trans_single (a : α) (b : β) (c : γ) :
    (single a b).trans (single b c) = single a c :=
  single_trans_of_mem _ (mem_single _ _)
#align pequiv.single_trans_single PEquiv.single_trans_single

@[simp]
theorem single_subsingleton_eq_refl [Subsingleton α] (a b : α) : single a b = PEquiv.refl α := by
  ext (i j)
  dsimp [single]
  rw [if_pos (Subsingleton.elim i a), Subsingleton.elim i j, Subsingleton.elim b j]
#align pequiv.single_subsingleton_eq_refl PEquiv.single_subsingleton_eq_refl

theorem trans_single_of_eq_none {b : β} (c : γ) {f : δ ≃. β} (h : f.symm b = none) :
    f.trans (single b c) = ⊥ := by
  ext
  simp only [eq_none_iff_forall_not_mem, Option.mem_def, f.eq_some_iff] at h
  dsimp [PEquiv.trans, single]
  simp
  intros
  split_ifs <;> simp_all
#align pequiv.trans_single_of_eq_none PEquiv.trans_single_of_eq_none

theorem single_trans_of_eq_none (a : α) {b : β} {f : β ≃. δ} (h : f b = none) :
    (single a b).trans f = ⊥ :=
  symm_injective <| trans_single_of_eq_none _ h
#align pequiv.single_trans_of_eq_none PEquiv.single_trans_of_eq_none

theorem single_trans_single_of_ne {b₁ b₂ : β} (h : b₁ ≠ b₂) (a : α) (c : γ) :
    (single a b₁).trans (single b₂ c) = ⊥ :=
  single_trans_of_eq_none _ (single_apply_of_ne h.symm _)
#align pequiv.single_trans_single_of_ne PEquiv.single_trans_single_of_ne

end Single

section Order

instance : PartialOrder (α ≃. β) where
  le f g := ∀ (a : α) (b : β), b ∈ f a → b ∈ g a
  le_refl _ _ _ := id
  le_trans f g h fg gh a b := gh a b ∘ fg a b
  le_antisymm f g fg gf :=
    ext
      (by
        intro a
        cases' h : g a with b
        · exact eq_none_iff_forall_not_mem.2 fun b hb => Option.not_mem_none b <| h ▸ fg a b hb
        · exact gf _ _ h)

theorem le_def {f g : α ≃. β} : f ≤ g ↔ ∀ (a : α) (b : β), b ∈ f a → b ∈ g a :=
  Iff.rfl
#align pequiv.le_def PEquiv.le_def

instance : OrderBot (α ≃. β) :=
  { instBotPEquiv with bot_le := fun _ _ _ h => (not_mem_none _ h).elim }

instance [DecidableEq α] [DecidableEq β] : SemilatticeInf (α ≃. β) :=
  { instPartialOrderPEquiv with
    inf := fun f g =>
      { toFun := fun a => if f a = g a then f a else none
        invFun := fun b => if f.symm b = g.symm b then f.symm b else none
        inv := fun a b => by
          have hf := @mem_iff_mem _ _ f a b
          have hg := @mem_iff_mem _ _ g a b
          simp only [Option.mem_def] at *
          split_ifs with h1 h2 h2 <;> try simp [hf]
          · contrapose! h2
            rw [h2]
            rw [← h1, hf, h2] at hg
            simp only [mem_def, true_iff_iff, eq_self_iff_true] at hg
            rw [hg]
          · contrapose! h1
            rw [h1] at hf h2
            rw [← h2] at hg
            simp only [iff_true] at hf hg
            rw [hf, hg] }
    inf_le_left := fun _ _ _ _ => by simp; split_ifs <;> simp [*]
    inf_le_right := fun _ _ _ _ => by simp; split_ifs <;> simp [*]
    le_inf := fun f g h fg gh a b => by
      intro H
      have hf := fg a b H
      have hg := gh a b H
      simp only [Option.mem_def, PEquiv.coe_mk_apply] at *
      rw [hf, hg, if_pos rfl] }

end Order

end PEquiv

namespace Equiv

variable {α : Type _} {β : Type _} {γ : Type _}

/-- Turns an `Equiv` into a `PEquiv` of the whole type. -/
def toPEquiv (f : α ≃ β) : α ≃. β where
  toFun := some ∘ f
  invFun := some ∘ f.symm
  inv := by simp [Equiv.eq_symm_apply, eq_comm]
#align equiv.to_pequiv Equiv.toPEquiv

@[simp]
theorem toPEquiv_refl : (Equiv.refl α).toPEquiv = PEquiv.refl α :=
  rfl
#align equiv.to_pequiv_refl Equiv.toPEquiv_refl

theorem toPEquiv_trans (f : α ≃ β) (g : β ≃ γ) :
    (f.trans g).toPEquiv = f.toPEquiv.trans g.toPEquiv :=
  rfl
#align equiv.to_pequiv_trans Equiv.toPEquiv_trans

theorem toPEquiv_symm (f : α ≃ β) : f.symm.toPEquiv = f.toPEquiv.symm :=
  rfl
#align equiv.to_pequiv_symm Equiv.toPEquiv_symm

theorem toPEquiv_apply (f : α ≃ β) (x : α) : f.toPEquiv x = some (f x) :=
  rfl
#align equiv.to_pequiv_apply Equiv.toPEquiv_apply

end Equiv


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

Quotient types.
-/
prelude
/- We import propext here, otherwise we would need a quot.lift for propositions. -/
import init.data.sigma.basic init.logic init.propext init.data.setoid

universes u v

-- iff can now be used to do substitutions in a calculation
attribute [subst]
lemma iff_subst {a b : Prop} {p : Prop → Prop} (h₁ : a ↔ b) (h₂ : p a) : p b :=
eq.subst (propext h₁) h₂

namespace quot
constant sound : Π {α : Sort u} {r : α → α → Prop} {a b : α}, r a b → quot.mk r a = quot.mk r b

attribute [elab_as_eliminator] lift ind

protected lemma lift_beta {α : Sort u} {r : α → α → Prop} {β : Sort v} (f : α → β) (c : ∀ a b, r a b → f a = f b) (a : α) : lift f c (quot.mk r a) = f a :=
rfl

protected lemma ind_beta {α : Sort u} {r : α → α → Prop} {β : quot r → Prop} (p : ∀ a, β (quot.mk r a)) (a : α) : (ind p (quot.mk r a) : β (quot.mk r a)) = p a :=
rfl

attribute [reducible, elab_as_eliminator]
protected def lift_on {α : Sort u} {β : Sort v} {r : α → α → Prop} (q : quot r) (f : α → β) (c : ∀ a b, r a b → f a = f b) : β :=
lift f c q

attribute [elab_as_eliminator]
protected lemma induction_on {α : Sort u} {r : α → α → Prop} {β : quot r → Prop} (q : quot r) (h : ∀ a, β (quot.mk r a)) : β q :=
ind h q

lemma exists_rep {α : Sort u} {r : α → α → Prop} (q : quot r) : ∃ a : α, (quot.mk r a) = q :=
quot.induction_on q (λ a, ⟨a, rfl⟩)

section
variable {α : Sort u}
variable {r : α → α → Prop}
variable {β : quot r → Sort v}

local notation `⟦`:max a `⟧` := quot.mk r a

attribute [reducible]
protected def indep (f : Π a, β ⟦a⟧) (a : α) : psigma β :=
⟨⟦a⟧, f a⟩

protected lemma indep_coherent (f : Π a, β ⟦a⟧)
                     (h : ∀ (a b : α) (p : r a b), (eq.rec (f a) (sound p) : β ⟦b⟧) = f b)
                     : ∀ a b, r a b → quot.indep f a = quot.indep f b  :=
λ a b e, psigma.eq (sound e) (h a b e)

protected lemma lift_indep_pr1
  (f : Π a, β ⟦a⟧) (h : ∀ (a b : α) (p : r a b), (eq.rec (f a) (sound p) : β ⟦b⟧) = f b)
  (q : quot r) : (lift (quot.indep f) (quot.indep_coherent f h) q).1 = q  :=
quot.ind (λ (a : α), eq.refl (quot.indep f a).1) q

attribute [reducible, elab_as_eliminator]
protected def rec
   (f : Π a, β ⟦a⟧) (h : ∀ (a b : α) (p : r a b), (eq.rec (f a) (sound p) : β ⟦b⟧) = f b)
   (q : quot r) : β q :=
eq.rec_on (quot.lift_indep_pr1 f h q) ((lift (quot.indep f) (quot.indep_coherent f h) q).2)

attribute [reducible, elab_as_eliminator]
protected def rec_on
   (q : quot r) (f : Π a, β ⟦a⟧) (h : ∀ (a b : α) (p : r a b), (eq.rec (f a) (sound p) : β ⟦b⟧) = f b) : β q :=
quot.rec f h q

attribute [reducible, elab_as_eliminator]
protected def rec_on_subsingleton
   [h : ∀ a, subsingleton (β ⟦a⟧)] (q : quot r) (f : Π a, β ⟦a⟧) : β q :=
quot.rec f (λ a b h, subsingleton.elim _ (f b)) q

attribute [reducible, elab_as_eliminator]
protected def hrec_on
   (q : quot r) (f : Π a, β ⟦a⟧) (c : ∀ (a b : α) (p : r a b), f a == f b) : β q :=
quot.rec_on q f
  (λ a b p, eq_of_heq (calc
    (eq.rec (f a) (sound p) : β ⟦b⟧) == f a : eq_rec_heq (sound p) (f a)
                                 ... == f b : c a b p))
end
end quot

def quotient {α : Sort u} (s : setoid α) :=
@quot α setoid.r

namespace quotient

protected def mk {α : Sort u} [s : setoid α] (a : α) : quotient s :=
quot.mk setoid.r a

notation `⟦`:max a `⟧`:0 := quotient.mk a

attribute [reducible, elab_as_eliminator]
protected def lift {α : Sort u} {β : Sort v} [s : setoid α] (f : α → β) : (∀ a b, a ≈ b → f a = f b) → quotient s → β :=
quot.lift f

attribute [elab_as_eliminator]
protected lemma ind {α : Sort u} [s : setoid α] {β : quotient s → Prop} : (∀ a, β ⟦a⟧) → ∀ q, β q :=
quot.ind

attribute [reducible, elab_as_eliminator]
protected def lift_on {α : Sort u} {β : Sort v} [s : setoid α] (q : quotient s) (f : α → β) (c : ∀ a b, a ≈ b → f a = f b) : β :=
quot.lift_on q f c

attribute [elab_as_eliminator]
protected lemma induction_on {α : Sort u} [s : setoid α] {β : quotient s → Prop} (q : quotient s) (h : ∀ a, β ⟦a⟧) : β q :=
quot.induction_on q h

lemma exists_rep {α : Sort u} [s : setoid α] (q : quotient s) : ∃ a : α, ⟦a⟧ = q :=
quot.exists_rep q

section
variable {α : Sort u}
variable [s : setoid α]
variable {β : quotient s → Sort v}

protected def rec
   (f : Π a, β ⟦a⟧) (h : ∀ (a b : α) (p : a ≈ b), (eq.rec (f a) (quotient.sound p) : β ⟦b⟧) = f b)
   (q : quotient s) : β q :=
quot.rec f h q

attribute [reducible, elab_as_eliminator]
protected def rec_on
   (q : quotient s) (f : Π a, β ⟦a⟧) (h : ∀ (a b : α) (p : a ≈ b), (eq.rec (f a) (quotient.sound p) : β ⟦b⟧) = f b) : β q :=
quot.rec_on q f h

attribute [reducible, elab_as_eliminator]
protected def rec_on_subsingleton
   [h : ∀ a, subsingleton (β ⟦a⟧)] (q : quotient s) (f : Π a, β ⟦a⟧) : β q :=
@quot.rec_on_subsingleton _ _ _ h q f

attribute [reducible, elab_as_eliminator]
protected def hrec_on
   (q : quotient s) (f : Π a, β ⟦a⟧) (c : ∀ (a b : α) (p : a ≈ b), f a == f b) : β q :=
quot.hrec_on q f c
end

section
universes u_a u_b u_c
variables {α : Sort u_a} {β : Sort u_b} {φ : Sort u_c}
variables [s₁ : setoid α] [s₂ : setoid β]
include s₁ s₂

attribute [reducible, elab_as_eliminator]
protected def lift₂
   (f : α → β → φ)(c : ∀ a₁ a₂ b₁ b₂, a₁ ≈ b₁ → a₂ ≈ b₂ → f a₁ a₂ = f b₁ b₂)
   (q₁ : quotient s₁) (q₂ : quotient s₂) : φ :=
quotient.lift
  (λ (a₁ : α), quotient.lift (f a₁) (λ (a b : β), c a₁ a a₁ b (setoid.refl a₁)) q₂)
  (λ (a b : α) (h : a ≈ b),
     @quotient.ind β s₂
       (λ (a_1 : quotient s₂),
          (quotient.lift (f a) (λ (a_1 b : β), c a a_1 a b (setoid.refl a)) a_1)
          =
          (quotient.lift (f b) (λ (a b_1 : β), c b a b b_1 (setoid.refl b)) a_1))
       (λ (a' : β), c a a' b a' h (setoid.refl a'))
       q₂)
  q₁

attribute [reducible, elab_as_eliminator]
protected def lift_on₂
  (q₁ : quotient s₁) (q₂ : quotient s₂) (f : α → β → φ) (c : ∀ a₁ a₂ b₁ b₂, a₁ ≈ b₁ → a₂ ≈ b₂ → f a₁ a₂ = f b₁ b₂) : φ :=
quotient.lift₂ f c q₁ q₂

attribute [elab_as_eliminator]
protected lemma ind₂ {φ : quotient s₁ → quotient s₂ → Prop} (h : ∀ a b, φ ⟦a⟧ ⟦b⟧) (q₁ : quotient s₁) (q₂ : quotient s₂) : φ q₁ q₂ :=
quotient.ind (λ a₁, quotient.ind (λ a₂, h a₁ a₂) q₂) q₁

attribute [elab_as_eliminator]
protected lemma induction_on₂
   {φ : quotient s₁ → quotient s₂ → Prop} (q₁ : quotient s₁) (q₂ : quotient s₂) (h : ∀ a b, φ ⟦a⟧ ⟦b⟧) : φ q₁ q₂ :=
quotient.ind (λ a₁, quotient.ind (λ a₂, h a₁ a₂) q₂) q₁

attribute [elab_as_eliminator]
protected lemma induction_on₃
   [s₃ : setoid φ]
   {δ : quotient s₁ → quotient s₂ → quotient s₃ → Prop} (q₁ : quotient s₁) (q₂ : quotient s₂) (q₃ : quotient s₃) (h : ∀ a b c, δ ⟦a⟧ ⟦b⟧ ⟦c⟧)
   : δ q₁ q₂ q₃ :=
quotient.ind (λ a₁, quotient.ind (λ a₂, quotient.ind (λ a₃, h a₁ a₂ a₃) q₃) q₂) q₁
end

section exact
variable   {α : Sort u}
variable   [s : setoid α]
include s

private def rel (q₁ q₂ : quotient s) : Prop :=
quotient.lift_on₂ q₁ q₂
  (λ a₁ a₂, a₁ ≈ a₂)
  (λ a₁ a₂ b₁ b₂ a₁b₁ a₂b₂,
    propext (iff.intro
      (λ a₁a₂, setoid.trans (setoid.symm a₁b₁) (setoid.trans a₁a₂ a₂b₂))
      (λ b₁b₂, setoid.trans a₁b₁ (setoid.trans b₁b₂ (setoid.symm a₂b₂)))))

local infix ` ~ `:50 := rel

private lemma rel.refl : ∀ q : quotient s, q ~ q :=
λ q, quot.induction_on q (λ a, setoid.refl a)

private lemma eq_imp_rel {q₁ q₂ : quotient s} : q₁ = q₂ → q₁ ~ q₂ :=
assume h, eq.rec_on h (rel.refl q₁)

lemma exact {a b : α} : ⟦a⟧ = ⟦b⟧ → a ≈ b :=
assume h, eq_imp_rel h
end exact

section
universes u_a u_b u_c
variables {α : Sort u_a} {β : Sort u_b}
variables [s₁ : setoid α] [s₂ : setoid β]
include s₁ s₂

attribute [reducible, elab_as_eliminator]
protected def rec_on_subsingleton₂
   {φ : quotient s₁ → quotient s₂ → Sort u_c} [h : ∀ a b, subsingleton (φ ⟦a⟧ ⟦b⟧)]
   (q₁ : quotient s₁) (q₂ : quotient s₂) (f : Π a b, φ ⟦a⟧ ⟦b⟧) : φ q₁ q₂:=
@quotient.rec_on_subsingleton _ s₁ (λ q, φ q q₂) (λ a, quotient.ind (λ b, h a b) q₂) q₁
  (λ a, quotient.rec_on_subsingleton q₂ (λ b, f a b))

end
end quotient

section
variable {α : Type u}
variable (r : α → α → Prop)

inductive eqv_gen : α → α → Prop
| rel : Π x y, r x y → eqv_gen x y
| refl : Π x, eqv_gen x x
| symm : Π x y, eqv_gen x y → eqv_gen y x
| trans : Π x y z, eqv_gen x y → eqv_gen y z → eqv_gen x z

theorem eqv_gen.is_equivalence : equivalence (@eqv_gen α r) :=
mk_equivalence _ eqv_gen.refl eqv_gen.symm eqv_gen.trans

def eqv_gen.setoid : setoid α :=
setoid.mk _ (eqv_gen.is_equivalence r)

theorem quot.exact {a b : α} (H : quot.mk r a = quot.mk r b) : eqv_gen r a b :=
@quotient.exact _ (eqv_gen.setoid r) a b (@congr_arg _ _ _ _
  (quot.lift (@quotient.mk _ (eqv_gen.setoid r)) (λx y h, quot.sound (eqv_gen.rel x y h))) H)

theorem quot.eqv_gen_sound {r : α → α → Prop} {a b : α} (H : eqv_gen r a b) : quot.mk r a = quot.mk r b :=
eqv_gen.rec_on H
  (λ x y h, quot.sound h)
  (λ x, rfl)
  (λ x y _ IH, eq.symm IH)
  (λ x y z _ _ IH₁ IH₂, eq.trans IH₁ IH₂)
end

open decidable
instance {α : Sort u} {s : setoid α} [d : ∀ a b : α, decidable (a ≈ b)] : decidable_eq (quotient s) :=
λ q₁ q₂ : quotient s,
  quotient.rec_on_subsingleton₂ q₁ q₂
    (λ a₁ a₂,
      match (d a₁ a₂) with
      | (is_true h₁)  := is_true (quotient.sound h₁)
      | (is_false h₂) := is_false (λ h, absurd (quotient.exact h) h₂)
      end)


import order.boolean_algebra
import freealg

open freealg
--------------------------------------------------------------------------------

def atom_prop {A : Type*} [boolean_algebra A] (a : A) :=
  ¬(a ≤ ⊥) ∧ forall (X Y : A), a ≤ (X ⊔ Y) → (a ≤ X) ∨ (a ≤ Y)
def atom (A : Type*) [boolean_algebra A] :=
  {a : A // atom_prop a}

variables {A : Type*} [boolean_algebra A] (a : atom A) (X Y : A)

def elem : Prop := a.val ≤ X

lemma rw_eq : (X = Y) ↔ (X ≤ Y) ∧ (Y ≤ X) := le_antisymm_iff
lemma rw_sdiff : (X \ Y) = X ⊓ Yᶜ := sdiff_eq

lemma rw_bot : elem a ⊥ ↔ false := iff_false_intro a.prop.left
lemma rw_top : elem a ⊤ ↔ true := iff_true_intro le_top
lemma rw_sup : elem a (X ⊔ Y) ↔ (elem a X) ∨ (elem a Y) := iff.intro (a.prop.right X Y) (or.rec le_sup_left_of_le le_sup_right_of_le)
lemma rw_inf : elem a (X ⊓ Y) ↔ (elem a X) ∧ (elem a Y) := le_inf_iff
lemma rw_compl : elem a Xᶜ ↔ ¬ (elem a X) :=
  iff.intro
  (fun hc h, a.prop.left (calc a.val ≤ X ⊓ Xᶜ : le_inf h hc ... = ⊥ : inf_compl_eq_bot))
  (or.resolve_left (a.prop.right X Xᶜ (calc a.val ≤ ⊤ : le_top ... = X ⊔ Xᶜ : sup_compl_eq_top.symm)))

--------------------------------------------------------------------------------

def atomic_freealg : forall {n : nat}, (freealg n) → Prop
| 0 tt := true
| 0 ff := false
| (n + 1) ⟨a, b⟩ := (atomic_freealg a ∧ b = ⊥) ∨ (atomic_freealg b ∧ a = ⊥)

lemma atomic_freealg_is_atom {n : nat} (a : freealg n) :
  atomic_freealg a ↔ (atom_prop a) :=
begin
  induction n,
  {
    split,
    -- atomic_freealg -> atom_prop
    cases a; unfold atom_prop; unfold atomic_freealg;
    unfold_projs; unfold zero; unfold sup; unfold le; simp,
    intros; cases X; cases Y; simp at *; unfold le at *; try {assumption}; simp,
    -- reverse
    cases a; unfold atom_prop; unfold atomic_freealg; unfold_projs;
    unfold zero; unfold sup; unfold le; simp at *; intro H,
  },
  {
    split,
    -- atomic_freealg -> atom_prop
    {
      cases a; unfold atom_prop; unfold atomic_freealg;
      unfold_projs; unfold zero; unfold sup; unfold le; simp,
      intros Hatom, split,
      -- dealing with the non-triviality case
      {
        rewrite n_ih at Hatom,
        unfold atom_prop at *,
        unfold_projs at *,
        intro H,
        repeat {cases Hatom},
        {cases Hatom_left, contradiction},
        {rewrite n_ih at Hatom_left, cases Hatom_left, assumption}
      },
      --
      {
        intros X Y, cases X, cases Y, simp,
        rewrite n_ih at Hatom, rewrite n_ih at Hatom,
        unfold atom_prop at *,
        unfold_projs at *,
        intros HaXY HbXY,
        cases Hatom,
        {
          sorry,
        },
        {
          sorry,
        },
      }
    }
  }
end

lemma atomic {n : nat} (X Y : freealg n): (X ≤ Y) ↔
  forall (a : atom (freealg n)), (elem a X) → (elem a Y) :=
begin
  split,
  {
    intros HXY a,
    cases a, unfold elem, simp only [],
    intro HaX, apply (le_trans HaX HXY),
  },
  {
    sorry,
  }
end

--------------------------------------------------------------------------------

lemma foo_big (X₀ X₁ X₂ X₃ X₄ X₅ X₆ X₇ X₈ X₉ : A) :
  (X₀ ⊔ X₁ ⊔ (X₂ ⊓ X₃) ⊔ X₄ ⊔ X₅ ⊔ (X₆ ⊓ X₇ ⊓ X₈) ⊔ X₉)ᶜ
    ≤ (X₉ᶜ ⊓ ((X₆ᶜ ⊔ ⊥) ⊔ X₈ᶜ ⊔ X₇ᶜᶜᶜ) ⊓ X₅ᶜ ⊓ (X₀ᶜ \ X₁) ⊓ (X₃ᶜ ⊔ X₂ᶜ) ⊓ X₄ᶜ) :=
begin
  simp only [atomic, rw_eq, rw_sdiff, rw_bot, rw_top, rw_sup, rw_inf, rw_compl],
  tauto!,
  done
end


/-
Copyright (c) 2021 Oliver Nash. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Oliver Nash
-/
import analysis.normed_space.banach
import analysis.normed_space.finite_dimension
import analysis.convex.combination
import linear_algebra.affine_space.basis
import linear_algebra.affine_space.finite_dimensional

/-!
# Bases in normed affine spaces.

This file contains results about bases in normed affine spaces.

## Main definitions:

 * `continuous_barycentric_coord`
 * `is_open_map_barycentric_coord`
 * `interior_convex_hull_aff_basis`
 * `exists_subset_affine_independent_span_eq_top_of_open`
 * `interior_convex_hull_nonempty_iff_aff_span_eq_top`
-/

section barycentric

variables {ι 𝕜 E P : Type*} [nondiscrete_normed_field 𝕜] [complete_space 𝕜]
variables [normed_group E] [normed_space 𝕜 E] [finite_dimensional 𝕜 E]
variables [metric_space P] [normed_add_torsor E P]
variables (b : affine_basis ι 𝕜 P)

@[continuity]
lemma continuous_barycentric_coord (i : ι) : continuous (b.coord i) :=
(b.coord i).continuous_of_finite_dimensional

local attribute [instance] finite_dimensional.complete

lemma is_open_map_barycentric_coord [nontrivial ι] (i : ι) :
  is_open_map (b.coord i) :=
(b.coord i).is_open_map (continuous_barycentric_coord b i) (b.surjective_coord i)

end barycentric

open set

/-- Given a finite-dimensional normed real vector space, the interior of the convex hull of an
affine basis is the set of points whose barycentric coordinates are strictly positive with respect
to this basis.

TODO Restate this result for affine spaces (instead of vector spaces) once the definition of
convexity is generalised to this setting. -/
lemma interior_convex_hull_aff_basis {ι E : Type*} [fintype ι] [normed_group E] [normed_space ℝ E]
  (b : affine_basis ι ℝ E) :
  interior (convex_hull ℝ (range b.points)) = { x | ∀ i, 0 < b.coord i x } :=
begin
  cases subsingleton_or_nontrivial ι with h h,
  { -- The zero-dimensional case.
    haveI := h,
    suffices : range (b.points) = univ, { simp [this], },
    refine affine_subspace.eq_univ_of_subsingleton_span_eq_top _ b.tot,
    rw ← image_univ,
    exact subsingleton.image subsingleton_of_subsingleton b.points, },
  { -- The positive-dimensional case.
    haveI : finite_dimensional ℝ E,
    { classical,
      obtain ⟨i⟩ := (infer_instance : nonempty ι),
      exact finite_dimensional.of_fintype_basis (b.basis_of i), },
    have : convex_hull ℝ (range b.points) = ⋂ i, (b.coord i)⁻¹' Ici 0,
    { rw convex_hull_affine_basis_eq_nonneg_barycentric b, ext, simp, },
    ext,
    simp only [this, interior_Inter_of_fintype, ← is_open_map.preimage_interior_eq_interior_preimage
      (is_open_map_barycentric_coord b _) (continuous_barycentric_coord b _),
      interior_Ici, mem_Inter, mem_set_of_eq, mem_Ioi, mem_preimage], },
end

variables {V P : Type*} [normed_group V] [normed_space ℝ V] [metric_space P] [normed_add_torsor V P]
include V

open affine_map

/-- Given a set `s` of affine-independent points belonging to an open set `u`, we may extend `s` to
an affine basis, all of whose elements belong to `u`. -/
lemma exists_subset_affine_independent_span_eq_top_of_open {s u : set P} (hu : is_open u)
  (hsu : s ⊆ u) (hne : s.nonempty) (h : affine_independent ℝ (coe : s → P)) :
  ∃ t : set P, s ⊆ t ∧ t ⊆ u ∧ affine_independent ℝ (coe : t → P) ∧ affine_span ℝ t = ⊤ :=
begin
  obtain ⟨q, hq⟩ := hne,
  obtain ⟨ε, hε, hεu⟩ := metric.is_open_iff.mp hu q (hsu hq),
  obtain ⟨t, ht₁, ht₂, ht₃⟩ := exists_subset_affine_independent_affine_span_eq_top h,
  let f : P → P := λ y, line_map q y (ε / 2 / (dist y q)),
  have hf : ∀ y, f y ∈ u,
  { intros y,
    apply hεu,
    simp only [metric.mem_ball, f, line_map_apply, dist_vadd_left, norm_smul, real.norm_eq_abs,
      dist_eq_norm_vsub V y q],
    cases eq_or_ne (∥y -ᵥ q∥) 0 with hyq hyq, { rwa [hyq, mul_zero], },
    rw [← norm_pos_iff, norm_norm] at hyq,
    calc abs (ε / 2 / ∥y -ᵥ q∥) * ∥y -ᵥ q∥
          = ε / 2 / ∥y -ᵥ q∥ * ∥y -ᵥ q∥ : by rw [abs_div, abs_of_pos (half_pos hε), abs_of_pos hyq]
      ... = ε / 2 : div_mul_cancel _ (ne_of_gt hyq)
      ... < ε : half_lt_self hε, },
  have hεyq : ∀ (y ∉ s), ε / 2 / dist y q ≠ 0,
  { simp only [ne.def, div_eq_zero_iff, or_false, dist_eq_zero, bit0_eq_zero, one_ne_zero,
      not_or_distrib, ne_of_gt hε, true_and, not_false_iff],
    exact λ y h1 h2, h1 (h2.symm ▸ hq) },
  classical,
  let w : t → ℝˣ := λ p, if hp : (p : P) ∈ s then 1 else units.mk0 _ (hεyq ↑p hp),
  refine ⟨set.range (λ (p : t), line_map q p (w p : ℝ)), _, _, _, _⟩,
  { intros p hp, use ⟨p, ht₁ hp⟩, simp [w, hp], },
  { intros y hy,
    simp only [set.mem_range, set_coe.exists, subtype.coe_mk] at hy,
    obtain ⟨p, hp, hyq⟩ := hy,
    by_cases hps : p ∈ s;
    simp only [w, hps, line_map_apply_one, units.coe_mk0, dif_neg, dif_pos, not_false_iff,
      units.coe_one, subtype.coe_mk] at hyq;
    rw ← hyq;
    [exact hsu hps, exact hf p], },
  { exact (ht₂.units_line_map ⟨q, ht₁ hq⟩ w).range, },
  { rw [affine_span_eq_affine_span_line_map_units (ht₁ hq) w, ht₃], },
end

lemma interior_convex_hull_nonempty_iff_aff_span_eq_top [finite_dimensional ℝ V] {s : set V} :
  (interior (convex_hull ℝ s)).nonempty ↔ affine_span ℝ s = ⊤ :=
begin
  split,
  { rintros ⟨x, hx⟩,
    obtain ⟨u, hu₁, hu₂, hu₃⟩ := mem_interior.mp hx,
    let t : set V := {x},
    obtain ⟨b, hb₁, hb₂, hb₃, hb₄⟩ := exists_subset_affine_independent_span_eq_top_of_open hu₂
      (singleton_subset_iff.mpr hu₃) (singleton_nonempty x)
      (affine_independent_of_subsingleton ℝ (coe : t → V)),
    rw [eq_top_iff, ← hb₄, ← affine_span_convex_hull s],
    mono,
    exact hb₂.trans hu₁, },
  { intros h,
    obtain ⟨t, hts, h_tot, h_ind⟩ := exists_affine_independent ℝ V s,
    suffices : (interior (convex_hull ℝ (range (coe : t → V)))).nonempty,
    { rw [subtype.range_coe_subtype, set_of_mem_eq] at this,
      apply nonempty.mono _ this,
      mono* },
    haveI : fintype t := fintype_of_fin_dim_affine_independent ℝ h_ind,
    use finset.centroid ℝ (finset.univ : finset t) (coe : t → V),
    rw [h, ← @set_of_mem_eq V t, ← subtype.range_coe_subtype] at h_tot,
    let b : affine_basis t ℝ V := ⟨coe, h_ind, h_tot⟩,
    rw interior_convex_hull_aff_basis b,
    have htne : (finset.univ : finset t).nonempty,
    { simpa [finset.univ_nonempty_iff] using
        affine_subspace.nonempty_of_affine_span_eq_top ℝ V V h_tot, },
    simp [finset.centroid_def, b.coord_apply_combination_of_mem (finset.mem_univ _)
      (finset.sum_centroid_weights_eq_one_of_nonempty ℝ (finset.univ : finset t) htne),
      finset.centroid_weights_apply, nat.cast_pos, inv_pos, finset.card_pos.mpr htne], },
end


import words

namespace UA
  universes u_lang u_str u_strA u_strB

  section

    /- We wrap the main defenitions in a section,
    -- so that they become universe polymorphic within this file. -/

    section
      parameter [σ : signature.{u_lang}]
      include σ

      /- a `subStructure` is a subset which is closed under the operations -/

      variable {α : Type u_str}
      variable [act : action_on α]

      @[class] def closed (sub_medium : set α) :=
      ∀ (f) (input : vector α _), set.range input.nth ⊆ sub_medium → act f input ∈ sub_medium

      def subStructure (A : Structure.{u_lang u_str}) : Type u_str :=
      subtype (@closed A.medium A.action)

    end

    parameter [σ : signature.{u_lang}]
    include σ

    instance image_is_closed
    {{α : Type u_strA}} {{β : Type u_strB}} [actA : action_on α] [actB : action_on β]
    (φ : (α → β)) [hom : homomorphism φ] : closed (set.range φ) :=
    begin
      intros f yyy h,
      rw set.range_subset_iff at h,
      use actA f (vector.of_fn (λ i, partial_section φ ⟨yyy.nth i, h i⟩)),
      rw ← hom _ _,
      apply congr_arg,
      apply vector.ext,
      intro i,
      rw [vector.nth_map, vector.nth_of_fn, @partial_section_prop _ _ φ _ _],
    end

    lemma eval_on_substructure
    {{α : Type u_str}} [actA : action_on α] (X : set α) [cls : closed X] (w : word α) :
    vars w ⊆ X → eval w ∈ X := λ h,
    begin
      induction w with _ f www h_ind, {
        exact h (set.mem_singleton _),
      },
      {
        apply cls f (vector.of_fn (eval ∘ www)),
        rw set.range_subset_iff,
        intro i,
        rw vector.nth_of_fn,
        rw [vars, set.Union_subset_iff] at h,
        exact h_ind i (h i),
      },
    end

    lemma closed_iff
    {α : Type u_str} [actA : action_on α] {X : set α} :
    closed X ↔ ∀ w : word α, vars w ⊆ X → eval w ∈ X :=
    begin
      split, {
        introI,
        exact eval_on_substructure X,
      },
      {
        intros h_main f xxx h,
        convert h_main (word.opr f (word.var ∘ xxx.nth)) _, {
          apply vector.ext,
          intro i,
          rw vector.nth_of_fn,
          refl,
        },
        {
          simp_rw [vars, set.Union_subset_iff, set.singleton_subset_iff],
          rw [set.range_subset_iff] at h,
          exact h,
        },
      },
    end

    def closure {{α : Type u_str}} [actA : action_on α] (X : set α) : set α :=
    ⋂₀ { S | closed S ∧ X ⊆ S}

    instance closure_is_closed {α : Type u_str} [actA : action_on α] {X : set α} :
    closed (closure X) :=
    begin
      intros _ _ h_x S h_S,
      apply h_S.left _ _,
      revert h_x S,
      rw [closure, ← set.le_eq_subset, ← set.Inf_eq_sInter],
      exact le_Inf_iff.1,
    end

    lemma closure_inflationary {α : Type u_str} [actA : action_on α] {X : set α} :
    X ⊆ closure X :=
    begin
      intros _ _ S h_S,
      apply h_S.right _,
      assumption,
    end

    lemma closure_eq {α : Type u_str} [actA : action_on α] {X : set α} :
    closure X = eval '' {w | vars w ⊆ X} :=
    begin
      apply set.subset.antisymm,
      {
        rw [closure, ← set.le_eq_subset, ← set.Inf_eq_sInter],
        apply Inf_le _,
        rw set.le_eq_subset,
        split,
        {
          intros f xxx h,
          simp_rw [set.range_subset_iff, set.mem_image] at h,
          cases choose_from_relation _ h with www h_w,
          rw set.mem_image,
          use word.opr f www,
          split,
          {
            rw [set.mem_set_of_eq, vars, set.Union_subset_iff],
            exact λ i, (h_w i).left,
          },
          {
            convert eq.symm (UA.eval_is_hom _ (vector.of_fn www)),
            exact funext (λ i, (eq.symm (vector.nth_of_fn _ i))),
            apply vector.ext,
            intro i,
            rw [vector.nth_map, vector.nth_of_fn],
            exact eq.symm (h_w i).right,
          },
        },
        {
          intros x h_x,
          rw set.mem_image_eq,
          use word.var x,
          rw [set.mem_set_of_eq, vars],
          exact ⟨set.singleton_subset_iff.mpr h_x, rfl⟩,
        },
      },
      {
        rw set.image_subset_iff,
        intro w,
        rw set.mem_preimage,
        induction w with w f www h_ind; intro h,
        {
          rw [set.mem_set_of_eq, vars, set.singleton_subset_iff] at h,
          exact closure_inflationary h,
        },
        {
          refine UA.closure_is_closed f (vector.of_fn (eval ∘ www)) _,
          rw set.range_subset_iff,
          intro i,
          rw vector.nth_of_fn,
          rw [set.mem_set_of_eq, vars, set.Union_subset_iff] at h,
          exact (h_ind i) (h i),
        },
      },
    end

  end
end UA


import ring_theory.artinian
import ring_theory.ideal.operations
import algebra.module.torsion
import dimension_theory.length
import dimension_theory.noetherian
import dimension_theory.jacobson

variables (K : Type*) [field K] (R : Type*) [comm_ring R] [algebra K R] [algebra.finite_type K R]

lemma is_artinian_ring.is_field_of_is_domain [is_artinian_ring R] [h : nontrivial R] [is_domain R] :
  is_field R :=
begin
  refine ⟨h.1, mul_comm, _⟩,
  intros x hx,
  obtain ⟨n, y, hy⟩ := is_artinian.exists_pow_succ_smul_dvd x (1 : R),
  replace hy : x ^ n * (x * y - 1) = 0,
  { rw [mul_sub, sub_eq_zero], convert hy using 1, simp [nat.succ_eq_add_one, pow_add, mul_assoc] },
  rw [mul_eq_zero, sub_eq_zero] at hy,
  exact ⟨_, hy.resolve_left $ pow_ne_zero _ hx⟩
end

variables {R}

lemma is_artinian_ring.is_maximal_of_is_prime [is_artinian_ring R]
  (I : ideal R) [h : I.is_prime] : I.is_maximal :=
begin
  rw ← ideal.quotient.is_domain_iff_prime at h,
  rw ideal.quotient.maximal_ideal_iff_is_field_quotient,
  haveI : is_artinian_ring (R ⧸ I) :=
    function.surjective.is_artinian_ring ideal.quotient.mk_surjective,
  apply is_artinian_ring.is_field_of_is_domain,
end

lemma is_artinian_ring.is_maximal_iff_is_prime [is_artinian_ring R] (I : ideal R) :
  I.is_maximal ↔ I.is_prime :=
⟨ideal.is_maximal.is_prime, @@is_artinian_ring.is_maximal_of_is_prime _ _ I⟩

lemma is_artinian_ring.jacobson_eq_radical [is_artinian_ring R] (I : ideal R) :
  I.jacobson = I.radical :=
by simp_rw [ideal.jacobson, ideal.radical_eq_Inf, is_artinian_ring.is_maximal_iff_is_prime]

variables (R)

lemma is_artinian_ring.jacobson_eq_nilradical [is_artinian_ring R] :
  (⊥ : ideal R).jacobson = nilradical R :=
is_artinian_ring.jacobson_eq_radical _

lemma is_artinian_ring.is_nilpotent_nilradical [is_artinian_ring R] :
  is_nilpotent (nilradical R) :=
is_artinian_ring.jacobson_eq_nilradical R ▸ is_artinian_ring.is_nilpotent_jacobson_bot

variables {R}

lemma ideal.is_prime.inf_le_iff (I : ideal R) [hI : I.is_prime] (s : set (ideal R)) (hs : s.finite) :
  Inf s ≤ I ↔ ∃ J ∈ s, J ≤ I :=
begin
  refine ⟨_, λ ⟨J, H, e⟩, (Inf_le H).trans e⟩,
  apply set.finite.induction_on hs; clear hs s,
  { intro e, rw [Inf_empty, ← eq_top_iff] at e, exact ((hI.1 : _) e).elim },
  { intros J s h₁ hs H e,
    rw Inf_insert at e,
    by_cases Inf s ≤ I, { obtain ⟨K, hK, hK'⟩ := H h, exact ⟨K, set.mem_insert_of_mem _ hK, hK'⟩ },
    suffices : J ≤ I, { exact ⟨J, set.mem_insert _ _, this⟩ },
    change ¬ ∀ x ∈ Inf s, x ∈ I at h,
    push_neg at h,
    obtain ⟨x, hx, hx'⟩ := h,
    intros y hy,
    have := e (ideal.mul_le_inf (ideal.mul_mem_mul hy hx)),
    rw hI.mul_mem_iff_mem_or_mem at this,
    exact this.resolve_right hx' }
end

lemma ideal.is_prime.mem_of_Inf_eq (I : ideal R) [hI : I.is_prime]
  (s : set (ideal R)) (hs : s.finite) (H : Inf s = I) : I ∈ s :=
begin
  obtain ⟨J, hJ, e⟩ := (ideal.is_prime.inf_le_iff I s hs).mp H.le,
  exact e.antisymm (H.symm.trans_le $ Inf_le hJ) ▸ hJ
end

variables (R)

lemma is_artinian_ring.is_maximal_finite [H : is_artinian_ring R] :
  (set_of ideal.is_maximal : set $ ideal R).finite :=
begin
  nontriviality R,
  let S : set (ideal R) :=
  { J | ∃ s : set (ideal R), s.finite ∧ (∀ I ∈ s, ideal.is_maximal I) ∧ J = Inf s },
  obtain ⟨M, hM⟩ := ideal.exists_maximal R,
  have : S.nonempty := ⟨M, {M}, set.to_finite _, λ _ e, e.symm ▸ hM, Inf_singleton.symm⟩,
  obtain ⟨_, ⟨s, hs, hs', rfl⟩, h⟩ := set_has_minimal_iff_artinian.mpr H S this,
  convert hs,
  ext J,
  refine ⟨λ hJ, _, hs' J⟩,
  haveI : J.is_maximal := hJ,
  have : Inf s ≤ J,
  { rw [← inf_eq_right, ← Inf_insert],
    refine h _ ⟨_, hs.insert _, _, rfl⟩ (Inf_le_Inf $ set.subset_insert _ _),
    unfreezingI { rintros I (rfl|H') }, { apply_instance }, { exact hs' _ H' } },
  obtain ⟨M, hM, hM'⟩ := (ideal.is_prime.inf_le_iff J s hs).mp this,
  exact (hs' M hM).eq_of_le hJ.ne_top hM' ▸ hM,
end

lemma is_artinian_ring.is_prime_finite [H : is_artinian_ring R] :
  (set_of ideal.is_prime : set $ ideal R).finite :=
begin
  convert is_artinian_ring.is_maximal_finite R,
  ext,
  rw is_artinian_ring.is_maximal_iff_is_prime,
end

def submodule.order_iso_of_surjective {R S} (M) [comm_semiring R] [semiring S]
  [add_comm_monoid M] [algebra R S] [module S M] [module R M] [is_scalar_tower R S M]
  (h : function.surjective (algebra_map R S)) :
  submodule S M ≃o submodule R M :=
{ inv_fun := λ p,
  { smul_mem' := λ c x hx, by { obtain ⟨c, rfl⟩ := h c, simpa using p.smul_mem c hx }, ..p },
  left_inv := λ x, submodule.ext (λ _, iff.rfl),
  right_inv := λ x, submodule.ext (λ _, iff.rfl),
  ..submodule.restrict_scalars_embedding _ _ _ }

lemma is_noetherian_of_tower_of_surjective {R S} (M) [comm_semiring R] [semiring S]
  [add_comm_monoid M] [algebra R S] [module S M] [module R M] [is_scalar_tower R S M]
  (h : function.surjective (algebra_map R S)) :
  is_noetherian R M ↔ is_noetherian S M :=
begin
  refine ⟨is_noetherian_of_tower R, _⟩,
  simp_rw is_noetherian_iff_well_founded,
  exact (submodule.order_iso_of_surjective M h).symm.to_order_embedding.dual.well_founded
end

lemma is_artinian_of_tower_of_surjective {R S} (M) [comm_ring R] [comm_ring S]
  [add_comm_group M] [algebra R S] [module S M] [module R M] [is_scalar_tower R S M]
  (h : function.surjective (algebra_map R S)) :
  is_artinian R M ↔ is_artinian S M :=
begin
  refine ⟨is_artinian_of_tower R, _⟩,
  simp_rw is_artinian_iff_well_founded,
  exact (submodule.order_iso_of_surjective M h).symm.to_order_embedding.well_founded
end

instance (R) [ring R] (M) [add_comm_group M] [module R M]
  (N : submodule R M) [is_artinian R M] : is_artinian R (M ⧸ N) :=
is_artinian_of_surjective M (submodule.mkq N) (submodule.quotient.mk_surjective N)

lemma is_artinian_top_iff {M} [add_comm_group M] [module R M]:
  is_artinian R (⊤ : submodule R M) ↔ is_artinian R M :=
begin
  unfreezingI { split; assume h },
  { exact is_artinian_of_linear_equiv (linear_equiv.of_top (⊤ : submodule R M) rfl) },
  { exact is_artinian_of_linear_equiv (linear_equiv.of_top (⊤ : submodule R M) rfl).symm },
end

lemma is_noetherian_iff_is_artinian_of_mul (I J : ideal R) [I.is_maximal]
  (H : is_noetherian R (I * J : _) ↔ is_artinian R (I * J : _)) :
    is_noetherian R J ↔ is_artinian R J :=
begin
  let IJ := submodule.comap J.subtype (I * J),
  have : module.is_torsion_by_set R (↥J ⧸ IJ) I,
  { rintros x ⟨y, hy : y ∈ I⟩,
    obtain ⟨⟨x, hx⟩, rfl⟩ := submodule.mkq_surjective _ x,
    rw [subtype.coe_mk, ← map_smul, submodule.mkq_apply, submodule.quotient.mk_eq_zero],
    show _ ∈ I * J, by simpa using ideal.mul_mem_mul hy hx },
  letI : module (R ⧸ I) (J ⧸ IJ) := this.module,
  letI := ideal.quotient.field I,
  have : function.surjective (algebra_map R (R ⧸ I)) := ideal.quotient.mk_surjective,
  have : is_noetherian R (J ⧸ IJ) ↔ is_artinian R (J ⧸ IJ),
  { rw [is_noetherian_of_tower_of_surjective (J ⧸ IJ) this,
      (module.finite_length_tfae_of_field (R ⧸ I) (J ⧸ IJ)).out 1 2,
      ← is_artinian_of_tower_of_surjective (J ⧸ IJ) this] },
  split,
  { introI _,
    haveI := this.mp infer_instance,
    haveI : is_artinian R (I * J : _) := H.mp (is_noetherian_of_le ideal.mul_le_left),
    exact is_artinian_of_range_eq_ker
      (submodule.of_le (ideal.mul_le_left) : (I * J : _) →ₗ[R] J) IJ.mkq
      (submodule.of_le_injective _)
      (submodule.mkq_surjective _)
      (by simp [submodule.range_of_le]) },
  { introI _,
    haveI := this.mpr infer_instance,
    haveI : is_noetherian R (I * J : _) := H.mpr (is_artinian_of_le ideal.mul_le_left),
    exact is_noetherian_of_range_eq_ker
      (submodule.of_le (ideal.mul_le_left) : (I * J : _) →ₗ[R] J) IJ.mkq
      (submodule.of_le_injective _)
      (submodule.mkq_surjective _)
      (by simp [submodule.range_of_le]) },
end

lemma is_noetherian_iff_is_artinian_of_prod_eq_bot (s : multiset (ideal R))
  (hs : ∀ I ∈ s, ideal.is_maximal I) (h' : s.prod = ⊥) :
    is_noetherian_ring R ↔ is_artinian_ring R :=
begin
  rw [is_noetherian_ring_iff, ← is_noetherian_top_iff, is_artinian_ring_iff,
    ← is_artinian_top_iff],
  by_contra h,
  suffices : ¬ (is_noetherian R (⊥ : ideal R) ↔ is_artinian R (⊥ : ideal R)),
  { apply this, exact ⟨λ _, infer_instance, λ _, infer_instance⟩ },
  rw ← h', clear h',
  unfreezingI { induction s using multiset.induction with a s hs' },
  { rw [multiset.prod_zero, ideal.one_eq_top], exact h },
  { rw multiset.prod_cons,
    intro hs'',
    apply hs' (λ _ H, hs _ $ multiset.mem_cons_of_mem H),
    haveI := hs a (multiset.mem_cons_self a _),
    apply is_noetherian_iff_is_artinian_of_mul _ _ _ hs'' }
end

lemma is_artinian_ring.exists_multiset_ideal_is_maximal_and_prod_eq_bot
  (R : Type*) [comm_ring R] [is_artinian_ring R] :
  ∃ s : multiset (ideal R), (∀ I ∈ s, ideal.is_maximal I) ∧ s.prod = ⊥ :=
begin
  casesI subsingleton_or_nontrivial R, { exact ⟨∅, λ _ h, h.elim, subsingleton.elim _ _⟩ },
  obtain ⟨n, e⟩ := is_artinian_ring.is_nilpotent_nilradical R,
  have hn : n ≠ 0, { rintro rfl, apply @top_ne_bot (ideal R), simpa using e },
  refine ⟨n • (is_artinian_ring.is_prime_finite R).to_finset.1, _, _⟩,
  { intros I hI,
    rw [multiset.mem_nsmul hn, ← finset.mem_def, set.finite.mem_to_finset] at hI,
    rwa is_artinian_ring.is_maximal_iff_is_prime },
  { rw [multiset.prod_nsmul, eq_bot_iff, ← ideal.zero_eq_bot, ← e,
      nilradical_eq_Inf, finset.prod_val],
    apply ideal.pow_mono,
    refine ideal.prod_le_inf.trans (le_Inf $ λ I hI, finset.inf_le _),
    rwa set.finite.mem_to_finset }
end

lemma is_artinian_ring_iff_is_noetherian_ring :
  is_artinian_ring R ↔ is_noetherian_ring R ∧ ∀ I : ideal R, I.is_prime → I.is_maximal :=
begin
  casesI subsingleton_or_nontrivial R,
  { exact ⟨λ _, ⟨infer_instance, λ I h, (h.ne_top (subsingleton.elim _ _)).elim⟩,
      λ _, infer_instance⟩ },
  split,
  { introI H,
    obtain ⟨s, hs, hs'⟩ := is_artinian_ring.exists_multiset_ideal_is_maximal_and_prod_eq_bot R,
    have := is_noetherian_iff_is_artinian_of_prod_eq_bot _ s hs hs',
    simp_rw [is_artinian_ring.is_maximal_iff_is_prime, this], exact ⟨H, λ _ h, h⟩ },
  { rintros ⟨h₁, h₂⟩,
    resetI,
    obtain ⟨n, e⟩ := is_noetherian_ring.is_nilpotent_nilradical R,
    have hn : n ≠ 0, { rintro rfl, apply @top_ne_bot (ideal R), simpa using e },
    rwa ← is_noetherian_iff_is_artinian_of_prod_eq_bot _
      (n • (@minimal_primes_finite R _ _).to_finset.1) _ _,
    { simp_rw [multiset.mem_nsmul hn, ← finset.mem_def, set.finite.mem_to_finset],
      exact λ I hI, h₂ _ hI.1.1 },
    { rw [multiset.prod_nsmul, eq_bot_iff, ← ideal.zero_eq_bot, ← e, nilradical,
        ← ideal.Inf_minimal_primes, finset.prod_val],
      apply ideal.pow_mono,
      refine ideal.prod_le_inf.trans (le_Inf $ λ I hI, finset.inf_le _),
      rwa set.finite.mem_to_finset } }
end

lemma module.finite.trans' (R A B : Type*) [comm_semiring R] [comm_semiring A] [algebra R A]
  [add_comm_monoid B] [module R B] [module A B] [is_scalar_tower R A B] :
  ∀ [module.finite R A] [module.finite A B], module.finite R B
| ⟨⟨s, hs⟩⟩ ⟨⟨t, ht⟩⟩ := ⟨submodule.fg_def.2
  ⟨set.image2 (•) (↑s : set A) (↑t : set B),
    set.finite.image2 _ s.finite_to_set t.finite_to_set,
    by rw [set.image2_smul, submodule.span_smul hs (↑t : set B),
      ht, submodule.restrict_scalars_top]⟩⟩

lemma module.finite_of_tower (R S M : Type*) [comm_semiring R] [comm_semiring S] [add_comm_group M]
  [algebra R S] [module R M] [module S M] [is_scalar_tower R S M] [module.finite R S] :
  module.finite R M ↔ module.finite S M :=
⟨λ h, by exactI module.finite.of_restrict_scalars_finite R S M,
  λ h, by exactI module.finite.trans' R S M⟩

instance (I : ideal R) : module.finite R (R ⧸ I) :=
module.finite.of_surjective (ideal.quotient.mkₐ R I).to_linear_map ideal.quotient.mk_surjective

lemma linear_map.range_restrict_scalars {R S M N : Type*} [comm_semiring R] [semiring S]
  [add_comm_monoid M] [add_comm_monoid N] [algebra R S] [module R M] [module S M]
  [is_scalar_tower R S M] [module R N] [module S N] [is_scalar_tower R S N] (f : M →ₗ[S] N) :
  (f.restrict_scalars R).range = f.range.restrict_scalars R := rfl

lemma is_artinian_of_is_artinian_of_mul_of_field (I J : ideal R) [I.is_maximal]
  [is_artinian R J] (H : is_artinian K (I * J : _)) : is_artinian K J :=
begin
  let IJ := submodule.comap J.subtype (I * J),
  have : module.is_torsion_by_set R (↥J ⧸ IJ) I,
  { rintros x ⟨y, hy : y ∈ I⟩,
    obtain ⟨⟨x, hx⟩, rfl⟩ := submodule.mkq_surjective _ x,
    rw [subtype.coe_mk, ← map_smul, submodule.mkq_apply, submodule.quotient.mk_eq_zero],
    show _ ∈ I * J, by simpa using ideal.mul_mem_mul hy hx },
  letI : module (R ⧸ I) (J ⧸ IJ) := this.module,
  letI := ideal.quotient.field I,
  have : function.surjective (algebra_map R (R ⧸ I)) := ideal.quotient.mk_surjective,
  haveI : algebra.finite_type K (R ⧸ I) := (‹algebra.finite_type K R›).trans infer_instance,
  haveI : module.finite K (R ⧸ I) := finite_of_finite_type_of_is_jacobson_of_field K (R ⧸ I),
  have : is_artinian R (J ⧸ IJ) ↔ is_artinian K (J ⧸ IJ),
  { rw [is_artinian_of_tower_of_surjective (J ⧸ IJ) this,
      (module.finite_length_tfae_of_field (R ⧸ I) (J ⧸ IJ)).out 2 0,
      (module.finite_length_tfae_of_field K (J ⧸ IJ)).out 2 0],
    exact (module.finite_of_tower K (R ⧸ I) (J ⧸ IJ)).symm },
  haveI := this.mp infer_instance,
  refine is_artinian_of_range_eq_ker
    ((submodule.of_le (ideal.mul_le_left) : (I * J : _) →ₗ[R] J).restrict_scalars K)
    (IJ.mkq.restrict_scalars K) _ _ _,
  { rw linear_map.coe_restrict_scalars, exact submodule.of_le_injective ideal.mul_le_left },
  { rw linear_map.coe_restrict_scalars, exact submodule.mkq_surjective IJ },
  simp only [submodule.ker_mkq, linear_map.ker_restrict_scalars, submodule.range_of_le,
    linear_map.range_restrict_scalars]
end

.

lemma is_artinian_ring_iff_is_artinian_of_field :
  is_artinian_ring R ↔ is_artinian K R :=
begin
  classical,
  refine ⟨_, is_artinian_of_tower K⟩,
  introI H, by_contra H',
  obtain ⟨s, hs, hs'⟩ := is_artinian_ring.exists_multiset_ideal_is_maximal_and_prod_eq_bot R,
  suffices : ¬ is_artinian K s.prod, { rw hs' at this, exact this infer_instance },
  clear hs',
  induction s using multiset.induction_on with a s h₁ h₂,
  { rw [multiset.prod_zero, ideal.one_eq_top], rwa ← is_artinian_top_iff at H' },
  { intro h₃, rw [multiset.prod_cons] at h₃,
    apply h₁ (λ I hI, hs I $ multiset.mem_cons_of_mem hI),
    haveI := hs a (multiset.mem_cons_self a s),
    exact is_artinian_of_is_artinian_of_mul_of_field _ _ a s.prod h₃ }
end

lemma is_artinian_ring_iff_finite_of_field :
  is_artinian_ring R ↔ module.finite K R :=
(is_artinian_ring_iff_is_artinian_of_field K R).trans
  ((module.finite_length_tfae_of_field K R).out 2 0)

lemma is_artinian_ring_iff_ring_hom_finite_of_field {K R : Type*} [field K] [comm_ring R]
  (f : K →+* R) (hf : f.finite_type) :
  is_artinian_ring R ↔ f.finite :=
@@is_artinian_ring_iff_finite_of_field K _ R _ f.to_algebra hf

lemma finite_iff_forall_prime_is_maximal_of_field :
  module.finite K R ↔ ∀ I : ideal R, I.is_prime → I.is_maximal :=
begin
  haveI := is_noetherian_ring_of_fg ‹algebra.finite_type K R›.1,
  haveI := is_noetherian_ring_of_surjective (⊤ : subalgebra K R) R
    subalgebra.top_equiv.to_ring_equiv.to_ring_hom subalgebra.top_equiv.surjective,
  rw [← is_artinian_ring_iff_finite_of_field K R, is_artinian_ring_iff_is_noetherian_ring],
  exact and_iff_right infer_instance
end