/-
Copyright (c) 2018 Robert Y. Lewis. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Robert Y. Lewis
-/
import algebra.group_with_zero.power
import algebra.ring.equiv
import tactic.linarith

/-!
# Integer power operation on fields and division rings

This file collects basic facts about the operation of raising an element of a `division_ring` to an
integer power. More specialised results are provided in the case of a linearly ordered field.
-/

universe u

@[simp] lemma ring_hom.map_zpow {K L : Type*} [division_ring K] [division_ring L] (f : K →+* L) :
  ∀ (a : K) (n : ℤ), f (a ^ n) = f a ^ n :=
f.to_monoid_with_zero_hom.map_zpow

@[simp] lemma ring_equiv.map_zpow {K L : Type*} [division_ring K] [division_ring L] (f : K ≃+* L) :
  ∀ (a : K) (n : ℤ), f (a ^ n) = f a ^ n :=
f.to_ring_hom.map_zpow

@[simp] lemma zpow_bit1_neg {K : Type*} [division_ring K] (x : K) (n : ℤ) :
  (-x) ^ (bit1 n) = - x ^ bit1 n :=
by rw [zpow_bit1', zpow_bit1', neg_mul_neg, neg_mul_eq_mul_neg]

section ordered_field_power
open int

variables {K : Type u} [linear_ordered_field K] {a : K} {n : ℤ}

lemma zpow_nonneg {a : K} (ha : 0 ≤ a) : ∀ (z : ℤ), 0 ≤ a ^ z
| (n : ℕ) := by { rw zpow_coe_nat, exact pow_nonneg ha _ }
| -[1+n]  := by { rw zpow_neg_succ_of_nat, exact inv_nonneg.2 (pow_nonneg ha _) }

lemma zpow_pos_of_pos {a : K} (ha : 0 < a) : ∀ (z : ℤ), 0 < a ^ z
| (n : ℕ) := by { rw zpow_coe_nat, exact pow_pos ha _ }
| -[1+n]  := by { rw zpow_neg_succ_of_nat, exact inv_pos.2 (pow_pos ha _) }

lemma zpow_le_of_le {x : K} (hx : 1 ≤ x) {a b : ℤ} (h : a ≤ b) : x ^ a ≤ x ^ b :=
begin
  induction a with a a; induction b with b b,
  { simp only [of_nat_eq_coe, zpow_coe_nat],
    apply pow_le_pow hx,
    apply le_of_coe_nat_le_coe_nat h },
  { apply absurd h,
    apply not_le_of_gt,
    exact lt_of_lt_of_le (neg_succ_lt_zero _) (of_nat_nonneg _) },
  { simp only [zpow_neg_succ_of_nat, one_div, of_nat_eq_coe, zpow_coe_nat],
    apply le_trans (inv_le_one _); apply one_le_pow_of_one_le hx },
  { simp only [zpow_neg_succ_of_nat],
    apply (inv_le_inv _ _).2,
    { apply pow_le_pow hx,
      have : -(↑(a+1) : ℤ) ≤ -(↑(b+1) : ℤ), from h,
      have h' := le_of_neg_le_neg this,
      apply le_of_coe_nat_le_coe_nat h' },
    repeat { apply pow_pos (lt_of_lt_of_le zero_lt_one hx) } }
end

lemma pow_le_max_of_min_le {x : K} (hx : 1 ≤ x) {a b c : ℤ} (h : min a b ≤ c) :
      x ^ (-c) ≤ max (x ^ (-a)) (x ^ (-b)) :=
begin
  wlog hle : a ≤ b,
  have hnle : -b ≤ -a, from neg_le_neg hle,
  have hfle : x ^ (-b) ≤ x ^ (-a), from zpow_le_of_le hx hnle,
  have : x ^ (-c) ≤ x ^ (-a),
  { apply zpow_le_of_le hx,
    simpa only [min_eq_left hle, neg_le_neg_iff] using h },
  simpa only [max_eq_left hfle]
end

lemma zpow_le_one_of_nonpos {p : K} (hp : 1 ≤ p) {z : ℤ} (hz : z ≤ 0) : p ^ z ≤ 1 :=
calc p ^ z ≤ p ^ 0 : zpow_le_of_le hp hz
          ... = 1        : by simp

lemma one_le_zpow_of_nonneg {p : K} (hp : 1 ≤ p) {z : ℤ} (hz : 0 ≤ z) : 1 ≤ p ^ z :=
calc p ^ z ≥ p ^ 0 : zpow_le_of_le hp hz
          ... = 1        : by simp

theorem zpow_bit0_nonneg (a : K) (n : ℤ) : 0 ≤ a ^ bit0 n :=
by { rw zpow_bit0, exact mul_self_nonneg _ }

theorem zpow_two_nonneg (a : K) : 0 ≤ a ^ (2 : ℤ) :=
zpow_bit0_nonneg a 1

theorem zpow_bit0_pos {a : K} (h : a ≠ 0) (n : ℤ) : 0 < a ^ bit0 n :=
(zpow_bit0_nonneg a n).lt_of_ne (zpow_ne_zero _ h).symm

theorem zpow_two_pos_of_ne_zero (a : K) (h : a ≠ 0) : 0 < a ^ (2 : ℤ) :=
zpow_bit0_pos h 1

@[simp] theorem zpow_bit1_neg_iff : a ^ bit1 n < 0 ↔ a < 0 :=
⟨λ h, not_le.1 $ λ h', not_le.2 h $ zpow_nonneg h' _,
 λ h, by rw [bit1, zpow_add_one₀ h.ne]; exact mul_neg_of_pos_of_neg (zpow_bit0_pos h.ne _) h⟩

@[simp] theorem zpow_bit1_nonneg_iff : 0 ≤ a ^ bit1 n ↔ 0 ≤ a :=
le_iff_le_iff_lt_iff_lt.2 zpow_bit1_neg_iff

@[simp] theorem zpow_bit1_nonpos_iff : a ^ bit1 n ≤ 0 ↔ a ≤ 0 :=
begin
  rw [le_iff_lt_or_eq, zpow_bit1_neg_iff],
  split,
  { rintro (h | h),
    { exact h.le },
    { exact (zpow_eq_zero h).le } },
  { intro h,
    rcases eq_or_lt_of_le h with rfl|h,
    { exact or.inr (zero_zpow _ (bit1_ne_zero n)) },
    { exact or.inl h } }
end

@[simp] theorem zpow_bit1_pos_iff : 0 < a ^ bit1 n ↔ 0 < a :=
lt_iff_lt_of_le_iff_le zpow_bit1_nonpos_iff

end ordered_field_power

lemma one_lt_zpow {K} [linear_ordered_field K] {p : K} (hp : 1 < p) :
  ∀ z : ℤ, 0 < z → 1 < p ^ z
| (n : ℕ) h := (zpow_coe_nat p n).symm.subst (one_lt_pow hp $ int.coe_nat_ne_zero.mp h.ne')
| -[1+ n] h := ((int.neg_succ_not_pos _).mp h).elim

section ordered
variables  {K : Type*} [linear_ordered_field K]

lemma nat.zpow_pos_of_pos {p : ℕ} (h : 0 < p) (n:ℤ) : 0 < (p:K)^n :=
by { apply zpow_pos_of_pos, exact_mod_cast h }

lemma nat.zpow_ne_zero_of_pos {p : ℕ} (h : 0 < p) (n:ℤ) : (p:K)^n ≠ 0 :=
ne_of_gt (nat.zpow_pos_of_pos h n)

lemma zpow_strict_mono {x : K} (hx : 1 < x) :
  strict_mono (λ n:ℤ, x ^ n) :=
strict_mono_int_of_lt_succ $ λ n,
have xpos : 0 < x, from zero_lt_one.trans hx,
calc x ^ n < x ^ n * x : lt_mul_of_one_lt_right (zpow_pos_of_pos xpos _) hx
... = x ^ (n + 1) : (zpow_add_one₀ xpos.ne' _).symm

lemma zpow_strict_anti {x : K} (h₀ : 0 < x) (h₁ : x < 1) : strict_anti (λ n : ℤ, x ^ n) :=
strict_anti_int_of_succ_lt $ λ n,
calc x ^ (n + 1) = x ^ n * x : zpow_add_one₀ h₀.ne' _
... < x ^ n * 1 : (mul_lt_mul_left $ zpow_pos_of_pos h₀ _).2 h₁
... = x ^ n : mul_one _

@[simp] lemma zpow_lt_iff_lt {x : K} (hx : 1 < x) {m n : ℤ} :
  x ^ m < x ^ n ↔ m < n :=
(zpow_strict_mono hx).lt_iff_lt

@[simp] lemma zpow_le_iff_le {x : K} (hx : 1 < x) {m n : ℤ} :
  x ^ m ≤ x ^ n ↔ m ≤ n :=
(zpow_strict_mono hx).le_iff_le

lemma min_le_of_zpow_le_max {x : K} (hx : 1 < x) {a b c : ℤ}
  (h_max : x ^ (-c) ≤ max (x ^ (-a)) (x ^ (-b)) ) : min a b ≤ c :=
begin
  rw min_le_iff,
  refine or.imp (λ h, _) (λ h, _) (le_max_iff.mp h_max);
  rwa [zpow_le_iff_le hx, neg_le_neg_iff] at h
end

@[simp] lemma pos_div_pow_pos {a b : K} (ha : 0 < a) (hb : 0 < b) (k : ℕ) : 0 < a/b^k :=
div_pos ha (pow_pos hb k)

@[simp] lemma div_pow_le {a b : K} (ha : 0 < a) (hb : 1 ≤ b) (k : ℕ) : a/b^k ≤ a :=
(div_le_iff $ pow_pos (lt_of_lt_of_le zero_lt_one hb) k).mpr
(calc a = a * 1 : (mul_one a).symm
   ...  ≤ a*b^k : (mul_le_mul_left ha).mpr $ one_le_pow_of_one_le hb _)

lemma zpow_injective {x : K} (h₀ : 0 < x) (h₁ : x ≠ 1) :
  function.injective ((^) x : ℤ → K) :=
begin
  intros m n h,
  rcases h₁.lt_or_lt with H|H,
  { apply (zpow_strict_mono (one_lt_inv h₀ H)).injective,
    show x⁻¹ ^ m = x⁻¹ ^ n,
    rw [← zpow_neg_one, ← zpow_mul, ← zpow_mul, mul_comm _ m, mul_comm _ n, zpow_mul, zpow_mul,
      h], },
  { exact (zpow_strict_mono H).injective h, },
end

@[simp] lemma zpow_inj {x : K} (h₀ : 0 < x) (h₁ : x ≠ 1) {m n : ℤ} :
  x ^ m = x ^ n ↔ m = n :=
(zpow_injective h₀ h₁).eq_iff

end ordered

section
variables {K : Type*} [division_ring K]

@[simp, norm_cast] theorem rat.cast_zpow [char_zero K] (q : ℚ) (n : ℤ) :
  ((q ^ n : ℚ) : K) = q ^ n :=
(rat.cast_hom K).map_zpow q n

end


/-
Copyright (c) 2014 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Floris van Doorn, Leonardo de Moura
-/
import Mathlib.Init.ZeroOne
import Mathlib.Init.Data.Nat.Notation

namespace Nat

section recursor_workarounds

/-- A computable version of `Nat.rec`. Workaround until Lean has native support for this. -/
def recC.{u} {motive : ℕ → Sort u} (zero : motive zero)
  (succ : (n : ℕ) → motive n → motive (succ n)) :
  (t : ℕ) → motive t
| 0 => zero
| (n + 1) => succ n (recC zero succ n)

@[csimp]
theorem rec_eq_recC : @Nat.rec = @Nat.recC := by
  funext motive zero succ n
  induction n with
  | zero => rfl
  | succ n ih => rw [Nat.recC, ←ih]

end recursor_workarounds

set_option linter.deprecated false

protected

protected theorem zero_lt_bit0 : ∀ {n : Nat}, n ≠ 0 → 0 < bit0 n
  | 0, h => absurd rfl h
  | succ n, _ =>
    calc
      0 < succ (succ (bit0 n)) := zero_lt_succ _
      _ = bit0 (succ n) := (Nat.bit0_succ_eq n).symm

#align nat.zero_lt_bit0 Nat.zero_lt_bit0

protected theorem zero_lt_bit1 (n : Nat) : 0 < bit1 n :=
  zero_lt_succ _
#align nat.zero_lt_bit1 Nat.zero_lt_bit1

protected theorem bit0_ne_zero : ∀ {n : ℕ}, n ≠ 0 → bit0 n ≠ 0
  | 0, h => absurd rfl h
  | n + 1, _ =>
    suffices n + 1 + (n + 1) ≠ 0 from this
    suffices succ (n + 1 + n) ≠ 0 from this
    fun h => Nat.noConfusion h
#align nat.bit0_ne_zero Nat.bit0_ne_zero

protected theorem bit1_ne_zero (n : ℕ) : bit1 n ≠ 0 :=
  show succ (n + n) ≠ 0 from fun h => Nat.noConfusion h
#align nat.bit1_ne_zero Nat.bit1_ne_zero

end Nat


/-
Copyright (c) 2018 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Kenny Lau, Johan Commelin, Mario Carneiro, Kevin Buzzard
-/
import group_theory.submonoid.basic
import algebra.big_operators.basic

/-!
# Submonoids

This file defines unbundled multiplicative and additive submonoids (deprecated). For bundled form
see `group_theory/submonoid`.

We some results about images and preimages of submonoids under monoid homomorphisms. These theorems
use unbundled monoid homomorphisms (also deprecated).

There are also theorems about the submonoids generated by an element or a subset of a monoid,
defined inductively.

## Implementation notes

Unbundled submonoids will slowly be removed from mathlib.

## Tags
submonoid, submonoids, is_submonoid
-/

open_locale big_operators

variables {M : Type*} [monoid M] {s : set M}
variables {A : Type*} [add_monoid A] {t : set A}

/-- `s` is an additive submonoid: a set containing 0 and closed under addition. -/
class is_add_submonoid (s : set A) : Prop :=
(zero_mem : (0:A) ∈ s)
(add_mem {a b} : a ∈ s → b ∈ s → a + b ∈ s)

/-- `s` is a submonoid: a set containing 1 and closed under multiplication. -/
@[to_additive]
class is_submonoid (s : set M) : Prop :=
(one_mem : (1:M) ∈ s)
(mul_mem {a b} : a ∈ s → b ∈ s → a * b ∈ s)

lemma additive.is_add_submonoid
  (s : set M) : ∀ [is_submonoid s], @is_add_submonoid (additive M) _ s
| ⟨h₁, h₂⟩ := ⟨h₁, @h₂⟩

theorem additive.is_add_submonoid_iff
  {s : set M} : @is_add_submonoid (additive M) _ s ↔ is_submonoid s :=
⟨λ ⟨h₁, h₂⟩, ⟨h₁, @h₂⟩, λ h, by exactI additive.is_add_submonoid _⟩

lemma multiplicative.is_submonoid
  (s : set A) : ∀ [is_add_submonoid s], @is_submonoid (multiplicative A) _ s
| ⟨h₁, h₂⟩ := ⟨h₁, @h₂⟩

theorem multiplicative.is_submonoid_iff
  {s : set A} : @is_submonoid (multiplicative A) _ s ↔ is_add_submonoid s :=
⟨λ ⟨h₁, h₂⟩, ⟨h₁, @h₂⟩, λ h, by exactI multiplicative.is_submonoid _⟩

/-- The intersection of two submonoids of a monoid `M` is a submonoid of `M`. -/
@[to_additive "The intersection of two `add_submonoid`s of an `add_monoid` `M` is
an `add_submonoid` of M."]
instance is_submonoid.inter (s₁ s₂ : set M) [is_submonoid s₁] [is_submonoid s₂] :
  is_submonoid (s₁ ∩ s₂) :=
{ one_mem := ⟨is_submonoid.one_mem, is_submonoid.one_mem⟩,
  mul_mem := λ x y hx hy,
    ⟨is_submonoid.mul_mem hx.1 hy.1, is_submonoid.mul_mem hx.2 hy.2⟩ }

/-- The intersection of an indexed set of submonoids of a monoid `M` is a submonoid of `M`. -/
@[to_additive "The intersection of an indexed set of `add_submonoid`s of an `add_monoid` `M` is
an `add_submonoid` of `M`."]
instance is_submonoid.Inter {ι : Sort*} (s : ι → set M) [h : ∀ y : ι, is_submonoid (s y)] :
  is_submonoid (set.Inter s) :=
{ one_mem := set.mem_Inter.2 $ λ y, is_submonoid.one_mem,
  mul_mem := λ x₁ x₂ h₁ h₂, set.mem_Inter.2 $
    λ y, is_submonoid.mul_mem (set.mem_Inter.1 h₁ y) (set.mem_Inter.1 h₂ y) }

/-- The union of an indexed, directed, nonempty set of submonoids of a monoid `M` is a submonoid
    of `M`. -/
@[to_additive "The union of an indexed, directed, nonempty set
of `add_submonoid`s of an `add_monoid` `M` is an `add_submonoid` of `M`. "]
lemma is_submonoid_Union_of_directed {ι : Type*} [hι : nonempty ι]
  (s : ι → set M) [∀ i, is_submonoid (s i)]
  (directed : ∀ i j, ∃ k, s i ⊆ s k ∧ s j ⊆ s k) :
  is_submonoid (⋃i, s i) :=
{ one_mem := let ⟨i⟩ := hι in set.mem_Union.2 ⟨i, is_submonoid.one_mem⟩,
  mul_mem := λ a b ha hb,
    let ⟨i, hi⟩ := set.mem_Union.1 ha in
    let ⟨j, hj⟩ := set.mem_Union.1 hb in
    let ⟨k, hk⟩ := directed i j in
    set.mem_Union.2 ⟨k, is_submonoid.mul_mem (hk.1 hi) (hk.2 hj)⟩ }

section powers

/-- The set of natural number powers `1, x, x², ...` of an element `x` of a monoid. -/
def powers (x : M) : set M := {y | ∃ n:ℕ, x^n = y}
/-- The set of natural number multiples `0, x, 2x, ...` of an element `x` of an `add_monoid`. -/
def multiples (x : A) : set A := {y | ∃ n:ℕ, n • x = y}
attribute [to_additive multiples] powers

/-- 1 is in the set of natural number powers of an element of a monoid. -/
lemma powers.one_mem {x : M} : (1 : M) ∈ powers x := ⟨0, pow_zero _⟩

/-- 0 is in the set of natural number multiples of an element of an `add_monoid`. -/
lemma multiples.zero_mem {x : A} : (0 : A) ∈ multiples x := ⟨0, zero_nsmul _⟩
attribute [to_additive] powers.one_mem

/-- An element of a monoid is in the set of that element's natural number powers. -/
lemma powers.self_mem {x : M} : x ∈ powers x := ⟨1, pow_one _⟩

/-- An element of an `add_monoid` is in the set of that element's natural number multiples. -/
lemma multiples.self_mem {x : A} : x ∈ multiples x := ⟨1, one_nsmul _⟩
attribute [to_additive] powers.self_mem

/-- The set of natural number powers of an element of a monoid is closed under multiplication. -/
lemma powers.mul_mem {x y z : M} : (y ∈ powers x) → (z ∈ powers x) → (y * z ∈ powers x) :=
λ ⟨n₁, h₁⟩ ⟨n₂, h₂⟩, ⟨n₁ + n₂, by simp only [pow_add, *]⟩

/-- The set of natural number multiples of an element of an `add_monoid` is closed under
    addition. -/
lemma multiples.add_mem {x y z : A} :
  (y ∈ multiples x) → (z ∈ multiples x) → (y + z ∈ multiples x) :=
@powers.mul_mem (multiplicative A) _ _ _ _
attribute [to_additive] powers.mul_mem

/-- The set of natural number powers of an element of a monoid `M` is a submonoid of `M`. -/
@[to_additive "The set of natural number multiples of an element of
an `add_monoid` `M` is an `add_submonoid` of `M`."]
instance powers.is_submonoid (x : M) : is_submonoid (powers x) :=
{ one_mem := powers.one_mem,
  mul_mem := λ y z, powers.mul_mem }

/-- A monoid is a submonoid of itself. -/
@[to_additive "An `add_monoid` is an `add_submonoid` of itself."]
instance univ.is_submonoid : is_submonoid (@set.univ M) := by split; simp

/-- The preimage of a submonoid under a monoid hom is a submonoid of the domain. -/
@[to_additive "The preimage of an `add_submonoid` under an `add_monoid` hom is
an `add_submonoid` of the domain."]
instance preimage.is_submonoid {N : Type*} [monoid N] (f : M → N) [is_monoid_hom f]
  (s : set N) [is_submonoid s] : is_submonoid (f ⁻¹' s) :=
{ one_mem := show f 1 ∈ s, by rw is_monoid_hom.map_one f; exact is_submonoid.one_mem,
  mul_mem := λ a b (ha : f a ∈ s) (hb : f b ∈ s),
    show f (a * b) ∈ s, by rw is_monoid_hom.map_mul f; exact is_submonoid.mul_mem ha hb }

/-- The image of a submonoid under a monoid hom is a submonoid of the codomain. -/
@[instance, to_additive "The image of an `add_submonoid` under an `add_monoid`
hom is an `add_submonoid` of the codomain."]
lemma image.is_submonoid {γ : Type*} [monoid γ] (f : M → γ) [is_monoid_hom f]
  (s : set M) [is_submonoid s] : is_submonoid (f '' s) :=
{ one_mem := ⟨1, is_submonoid.one_mem, is_monoid_hom.map_one f⟩,
  mul_mem := λ a b ⟨x, hx⟩ ⟨y, hy⟩, ⟨x * y, is_submonoid.mul_mem hx.1 hy.1,
    by rw [is_monoid_hom.map_mul f, hx.2, hy.2]⟩ }

/-- The image of a monoid hom is a submonoid of the codomain. -/
@[to_additive "The image of an `add_monoid` hom is an `add_submonoid`
of the codomain."]
instance range.is_submonoid {γ : Type*} [monoid γ] (f : M → γ) [is_monoid_hom f] :
  is_submonoid (set.range f) :=
by rw ← set.image_univ; apply_instance

/-- Submonoids are closed under natural powers. -/
lemma is_submonoid.pow_mem {a : M} [is_submonoid s] (h : a ∈ s) : ∀ {n : ℕ}, a ^ n ∈ s
| 0 := by { rw pow_zero, exact is_submonoid.one_mem }
| (n + 1) := by { rw pow_succ, exact is_submonoid.mul_mem h is_submonoid.pow_mem }

/-- An `add_submonoid` is closed under multiplication by naturals. -/
lemma is_add_submonoid.smul_mem {a : A} [is_add_submonoid t] :
  ∀ (h : a ∈ t) {n : ℕ}, n • a ∈ t :=
@is_submonoid.pow_mem (multiplicative A) _ _ _ (multiplicative.is_submonoid _)
attribute [to_additive smul_mem] is_submonoid.pow_mem

/-- The set of natural number powers of an element of a submonoid is a subset of the submonoid. -/
lemma is_submonoid.power_subset {a : M} [is_submonoid s] (h : a ∈ s) : powers a ⊆ s :=
assume x ⟨n, hx⟩, hx ▸ is_submonoid.pow_mem h

/-- The set of natural number multiples of an element of an `add_submonoid` is a subset of the
    `add_submonoid`. -/
lemma is_add_submonoid.multiple_subset {a : A} [is_add_submonoid t] :
  a ∈ t → multiples a ⊆ t :=
@is_submonoid.power_subset (multiplicative A) _ _ _ (multiplicative.is_submonoid _)
attribute [to_additive multiple_subset] is_submonoid.power_subset

end powers

namespace is_submonoid

/-- The product of a list of elements of a submonoid is an element of the submonoid. -/
@[to_additive "The sum of a list of elements of an `add_submonoid` is an element of the
`add_submonoid`."]
lemma list_prod_mem [is_submonoid s] : ∀{l : list M}, (∀x∈l, x ∈ s) → l.prod ∈ s
| []     h := one_mem
| (a::l) h :=
  suffices a * l.prod ∈ s, by simpa,
  have a ∈ s ∧ (∀x∈l, x ∈ s), by simpa using h,
  is_submonoid.mul_mem this.1 (list_prod_mem this.2)

/-- The product of a multiset of elements of a submonoid of a `comm_monoid` is an element of
the submonoid. -/
@[to_additive "The sum of a multiset of elements of an `add_submonoid` of an `add_comm_monoid`
is an element of the `add_submonoid`. "]
lemma multiset_prod_mem {M} [comm_monoid M] (s : set M) [is_submonoid s] (m : multiset M) :
  (∀a∈m, a ∈ s) → m.prod ∈ s :=
begin
  refine quotient.induction_on m (assume l hl, _),
  rw [multiset.quot_mk_to_coe, multiset.coe_prod],
  exact list_prod_mem hl
end

/-- The product of elements of a submonoid of a `comm_monoid` indexed by a `finset` is an element
of the submonoid. -/
@[to_additive "The sum of elements of an `add_submonoid` of an `add_comm_monoid` indexed by
a `finset` is an element of the `add_submonoid`."]
lemma finset_prod_mem {M A} [comm_monoid M] (s : set M) [is_submonoid s] (f : A → M) :
  ∀(t : finset A), (∀b∈t, f b ∈ s) → ∏ b in t, f b ∈ s
| ⟨m, hm⟩ hs := multiset_prod_mem s _ (by simpa)

end is_submonoid

-- TODO: modify `subtype_instance` to produce this definition, then use it here
--  and for `subtype.group`

/-- Submonoids are themselves monoids. -/
@[to_additive "An `add_submonoid` is itself an `add_monoid`."]
def subtype.monoid {s : set M} [is_submonoid s] : monoid s :=
{ one := ⟨1, is_submonoid.one_mem⟩,
  mul := λ x y, ⟨x * y, is_submonoid.mul_mem x.2 y.2⟩,
  mul_one := λ x, subtype.eq $ mul_one x.1,
  one_mul := λ x, subtype.eq $ one_mul x.1,
  mul_assoc := λ x y z, subtype.eq $ mul_assoc x.1 y.1 z.1 }

/-- Submonoids of commutative monoids are themselves commutative monoids. -/
@[to_additive "An `add_submonoid` of a commutative `add_monoid` is itself
a commutative `add_monoid`. "]
def subtype.comm_monoid {M} [comm_monoid M] {s : set M} [is_submonoid s] : comm_monoid s :=
{ mul_comm := λ x y, subtype.eq $ mul_comm x.1 y.1,
  .. subtype.monoid }

section
local attribute [instance] subtype.monoid subtype.add_monoid

/-- Submonoids inherit the 1 of the monoid. -/
@[simp, norm_cast, to_additive "An `add_submonoid` inherits the 0 of the `add_monoid`. "]
lemma is_submonoid.coe_one [is_submonoid s] : ((1 : s) : M) = 1 := rfl
attribute [norm_cast] is_add_submonoid.coe_zero

/-- Submonoids inherit the multiplication of the monoid. -/
@[simp, norm_cast, to_additive "An `add_submonoid` inherits the addition of the `add_monoid`. "]
lemma is_submonoid.coe_mul [is_submonoid s] (a b : s) : ((a * b : s) : M) = a * b := rfl
attribute [norm_cast] is_add_submonoid.coe_add

/-- Submonoids inherit the exponentiation by naturals of the monoid. -/
@[simp, norm_cast] lemma is_submonoid.coe_pow [is_submonoid s] (a : s) (n : ℕ) :
  ((a ^ n : s) : M) = a ^ n :=
by induction n; simp [*, pow_succ]

/-- An `add_submonoid` inherits the multiplication by naturals of the `add_monoid`. -/
@[simp, norm_cast] lemma is_add_submonoid.smul_coe {A : Type*} [add_monoid A] {s : set A}
  [is_add_submonoid s] (a : s) (n : ℕ) : ((n • a : s) : A) = n • a :=
by induction n; simp [*, succ_nsmul, zero_nsmul]

attribute [to_additive smul_coe] is_submonoid.coe_pow

/-- The natural injection from a submonoid into the monoid is a monoid hom. -/
@[to_additive "The natural injection from an `add_submonoid` into
the `add_monoid` is an `add_monoid` hom. "]
instance subtype_val.is_monoid_hom [is_submonoid s] : is_monoid_hom (subtype.val : s → M) :=
{ map_one := rfl, map_mul := λ _ _, rfl }

/-- The natural injection from a submonoid into the monoid is a monoid hom. -/
@[to_additive "The natural injection from an `add_submonoid` into
the `add_monoid` is an `add_monoid` hom. "]
instance coe.is_monoid_hom [is_submonoid s] : is_monoid_hom (coe : s → M) :=
subtype_val.is_monoid_hom

/-- Given a monoid hom `f : γ → M` whose image is contained in a submonoid `s`, the induced map
    from `γ` to `s` is a monoid hom. -/
@[to_additive "Given an `add_monoid` hom `f : γ → M` whose image is contained in
an `add_submonoid` s, the induced map from `γ` to `s` is an `add_monoid` hom."]
instance subtype_mk.is_monoid_hom {γ : Type*} [monoid γ] [is_submonoid s] (f : γ → M)
  [is_monoid_hom f] (h : ∀ x, f x ∈ s) : is_monoid_hom (λ x, (⟨f x, h x⟩ : s)) :=
{ map_one := subtype.eq (is_monoid_hom.map_one f),
  map_mul := λ x y, subtype.eq (is_monoid_hom.map_mul f x y) }

/-- Given two submonoids `s` and `t` such that `s ⊆ t`, the natural injection from `s` into `t` is
    a monoid hom. -/
@[to_additive "Given two `add_submonoid`s `s` and `t` such that `s ⊆ t`, the
natural injection from `s` into `t` is an `add_monoid` hom."]
instance set_inclusion.is_monoid_hom (t : set M) [is_submonoid s] [is_submonoid t] (h : s ⊆ t) :
  is_monoid_hom (set.inclusion h) :=
subtype_mk.is_monoid_hom _ _

end

namespace add_monoid

/-- The inductively defined membership predicate for the submonoid generated by a subset of a
    monoid. -/
inductive in_closure (s : set A) : A → Prop
| basic {a : A} : a ∈ s → in_closure a
| zero : in_closure 0
| add {a b : A} : in_closure a → in_closure b → in_closure (a + b)

end add_monoid

namespace monoid

/-- The inductively defined membership predicate for the `add_submonoid` generated by a subset of an
    add_monoid. -/
inductive in_closure (s : set M) : M → Prop
| basic {a : M} : a ∈ s → in_closure a
| one : in_closure 1
| mul {a b : M} : in_closure a → in_closure b → in_closure (a * b)

attribute [to_additive] monoid.in_closure
attribute [to_additive] monoid.in_closure.one
attribute [to_additive] monoid.in_closure.mul

/-- The inductively defined submonoid generated by a subset of a monoid. -/
@[to_additive "The inductively defined `add_submonoid` genrated by a subset of an `add_monoid`."]
def closure (s : set M) : set M := {a | in_closure s a }

@[to_additive]
instance closure.is_submonoid (s : set M) : is_submonoid (closure s) :=
{ one_mem := in_closure.one, mul_mem := assume a b, in_closure.mul }

/-- A subset of a monoid is contained in the submonoid it generates. -/
@[to_additive "A subset of an `add_monoid` is contained in the `add_submonoid` it generates."]
theorem subset_closure {s : set M} : s ⊆ closure s :=
assume a, in_closure.basic

/-- The submonoid generated by a set is contained in any submonoid that contains the set. -/
@[to_additive "The `add_submonoid` generated by a set is contained in any `add_submonoid` that
contains the set."]
theorem closure_subset {s t : set M} [is_submonoid t] (h : s ⊆ t) : closure s ⊆ t :=
assume a ha, by induction ha; simp [h _, *, is_submonoid.one_mem, is_submonoid.mul_mem]

/-- Given subsets `t` and `s` of a monoid `M`, if `s ⊆ t`, the submonoid of `M` generated by `s` is
    contained in the submonoid generated by `t`. -/
@[to_additive "Given subsets `t` and `s` of an `add_monoid M`, if `s ⊆ t`, the `add_submonoid`
of `M` generated by `s` is contained in the `add_submonoid` generated by `t`."]
theorem closure_mono {s t : set M} (h : s ⊆ t) : closure s ⊆ closure t :=
closure_subset $ set.subset.trans h subset_closure

/-- The submonoid generated by an element of a monoid equals the set of natural number powers of
    the element. -/
@[to_additive "The `add_submonoid` generated by an element of an `add_monoid` equals the set of
natural number multiples of the element."]
theorem closure_singleton {x : M} : closure ({x} : set M) = powers x :=
set.eq_of_subset_of_subset (closure_subset $ set.singleton_subset_iff.2 $ powers.self_mem) $
  is_submonoid.power_subset $ set.singleton_subset_iff.1 $ subset_closure

/-- The image under a monoid hom of the submonoid generated by a set equals the submonoid generated
    by the image of the set under the monoid hom. -/
@[to_additive "The image under an `add_monoid` hom of the `add_submonoid` generated by a set equals
the `add_submonoid` generated by the image of the set under the `add_monoid` hom."]
lemma image_closure {A : Type*} [monoid A] (f : M → A) [is_monoid_hom f] (s : set M) :
  f '' closure s = closure (f '' s) :=
le_antisymm
  begin
    rintros _ ⟨x, hx, rfl⟩,
    apply in_closure.rec_on hx; intros,
    { solve_by_elim [subset_closure, set.mem_image_of_mem] },
    { rw [is_monoid_hom.map_one f], apply is_submonoid.one_mem },
    { rw [is_monoid_hom.map_mul f], solve_by_elim [is_submonoid.mul_mem] }
  end
  (closure_subset $ set.image_subset _ subset_closure)

/-- Given an element `a` of the submonoid of a monoid `M` generated by a set `s`, there exists
a list of elements of `s` whose product is `a`. -/
@[to_additive "Given an element `a` of the `add_submonoid` of an `add_monoid M` generated by
a set `s`, there exists a list of elements of `s` whose sum is `a`."]
theorem exists_list_of_mem_closure {s : set M} {a : M} (h : a ∈ closure s) :
  (∃l:list M, (∀x∈l, x ∈ s) ∧ l.prod = a) :=
begin
  induction h,
  case in_closure.basic : a ha { existsi ([a]), simp [ha] },
  case in_closure.one { existsi ([]), simp },
  case in_closure.mul : a b _ _ ha hb {
    rcases ha with ⟨la, ha, eqa⟩,
    rcases hb with ⟨lb, hb, eqb⟩,
    existsi (la ++ lb),
    simp [eqa.symm, eqb.symm, or_imp_distrib],
    exact assume a, ⟨ha a, hb a⟩
  }
end

/-- Given sets `s, t` of a commutative monoid `M`, `x ∈ M` is in the submonoid of `M` generated by
    `s ∪ t` iff there exists an element of the submonoid generated by `s` and an element of the
    submonoid generated by `t` whose product is `x`. -/
@[to_additive "Given sets `s, t` of a commutative `add_monoid M`, `x ∈ M` is in the `add_submonoid`
of `M` generated by `s ∪ t` iff there exists an element of the `add_submonoid` generated by `s`
and an element of the `add_submonoid` generated by `t` whose sum is `x`."]
theorem mem_closure_union_iff {M : Type*} [comm_monoid M] {s t : set M} {x : M} :
  x ∈ closure (s ∪ t) ↔ ∃ y ∈ closure s, ∃ z ∈ closure t, y * z = x :=
⟨λ hx, let ⟨L, HL1, HL2⟩ := exists_list_of_mem_closure hx in HL2 ▸
  list.rec_on L (λ _, ⟨1, is_submonoid.one_mem, 1, is_submonoid.one_mem, mul_one _⟩)
    (λ hd tl ih HL1, let ⟨y, hy, z, hz, hyzx⟩ := ih (list.forall_mem_of_forall_mem_cons HL1) in
      or.cases_on (HL1 hd $ list.mem_cons_self _ _)
        (λ hs, ⟨hd * y, is_submonoid.mul_mem (subset_closure hs) hy, z, hz,
          by rw [mul_assoc, list.prod_cons, ← hyzx]; refl⟩)
        (λ ht, ⟨y, hy, z * hd, is_submonoid.mul_mem hz (subset_closure ht),
          by rw [← mul_assoc, list.prod_cons, ← hyzx, mul_comm hd]; refl⟩)) HL1,
λ ⟨y, hy, z, hz, hyzx⟩, hyzx ▸ is_submonoid.mul_mem (closure_mono (set.subset_union_left _ _) hy)
  (closure_mono (set.subset_union_right _ _) hz)⟩

end monoid

/-- Create a bundled submonoid from a set `s` and `[is_submonoid s]`. -/
@[to_additive "Create a bundled additive submonoid from a set `s` and `[is_add_submonoid s]`."]
def submonoid.of (s : set M) [h : is_submonoid s] : submonoid M := ⟨s, h.1, h.2⟩

@[to_additive]
instance submonoid.is_submonoid (S : submonoid M) : is_submonoid (S : set M) := ⟨S.2, S.3⟩


import .basic ..data.dvector

/- Some definitions for specifying normal subgroups generated by group elements and by defining a group by generators and relations -/

open quotient_group set
open category_theory (mk_ob)

variables {α : Type*} [group α]

/-- the subgroup generated by a set is a normal subgroup if the set is closed under conjugates -/
lemma closure.normal_subgroup {s : set α} (hs : ∀ n ∈ s, ∀ g : α, g * n * g⁻¹ ∈ s) :
  normal_subgroup (group.closure s) :=
begin
  fapply normal_subgroup.mk, intros n H g, induction H,
  { constructor, apply hs _ H_a_1 },
  { simp, apply group.in_closure.one },
  { have := group.in_closure.inv (H_ih), simp only [mul_inv_rev, inv_inv] at this,
    rwa [mul_assoc] },
  { have := group.in_closure.mul (H_ih_a) (H_ih_a_1),
    rwa [mul_assoc, ←mul_assoc g⁻¹, inv_mul_cancel_left, ←mul_assoc, mul_assoc g] at this },
end

/-- The smallest set containing s closed under conjugations -/
inductive conjugates (s : set α) : set α
| base : Π{{x}}, x ∈ s → conjugates x
| normal : Π{{x}} y, conjugates x → conjugates (y * x * y⁻¹)

/-- Given a set s of group elements, return the normal subgroup of α generated by s.
  This is called the conjugate closure, normal closure or the normal subgroup generated by s. -/
def normal_closure (s : set α) : set α :=
group.closure (conjugates s)

instance (s : set α) : normal_subgroup (normal_closure s) :=
closure.normal_subgroup $ λ x hx y, conjugates.normal y hx

def group_modulo_relations (α : Type*) [group α] (s : set α) : Group :=
mk_ob $ quotient_group.quotient (normal_closure s)

notation α `/⟪`:95 R `⟫`:90 := group_modulo_relations α R

def group_of_generators_relations (gen : Type*) (relations : set (free_group gen)) : Group :=
(free_group gen)/⟪relations⟫

notation `⟪`:95 G `|`:90 R`⟫`:0 := group_of_generators_relations G R

def generated_of {G : Type*} {R : set (free_group G)} : G → ⟪G | R⟫ :=
  λ g, quotient_group.mk $ free_group.of g

local notation `⟪`:50 a `⟫`:50 := free_group.of a

def cyclic_group_presentation (n : ℕ) : Group := ⟪unit |{ ⟪()⟫^n }⟫

/- The dihedral groups -/

/- The dihedral groups are an easy case of the Coxeter groups -/
namespace dihedral_group
def r := ⟪ff⟫
def s := ⟪tt⟫
end dihedral_group
open dihedral_group

/-- The dihedral group of order 2n -/
def dihedral_group (n : ℕ) : Group := ⟪bool | {r^n, s^2, s * r * s * r}⟫

/-- The Coxeter group is the group with presentation ⟨ r_1, ... r_n | (r_ir_j)^{m_{i,j}} = 1 ⟩
If m_{i,j} = ∞, then no relation is imposed on r_ir_j. -/
-- Note: we currently don't require that m i i = 1 for all i, and that m i j ≥ 2 for i ≠ j.
def coxeter_group {α : Type*} (m : α → α → enat) : Group :=
⟪α | set.range (λ(x : α × α), (⟪x.1⟫ * ⟪x.2⟫)^(m x.1 x.2)) ⟫

/-- coxeter_group' adds new generators with no Coxeter relations on them -/
def coxeter_group' {α : Type*} (m : α → α → enat) (β : Type*) : Group :=
⟪α⊕β | set.range (λ(x : α × α), (⟪sum.inl x.1⟫ * ⟪sum.inl x.2⟫)^m x.1 x.2) ⟫

def matrix_of_graph {α : Type*} [decidable_eq α] (E : α → α → Prop) [decidable_rel E] (x y : α) :
  enat :=
if x = y then 1 else if E x y then 3 else 2

/- Annotated graphs for generalized Coxeter-type presentations (see xviii of the atlas) -/
structure annotated_graph :=
  (vertex : Type*)
  (edge : vertex → vertex → Prop)
  (annotation : Π{{x y}}, edge x y → enat)

/-- Turn a binary relation on a type into an annotated graph.
  By default, all edges are annotated with 3. -/
def annotated_graph_of_graph {α : Type*} (E : α → α → Prop) : annotated_graph :=
{ vertex := α,
  edge := E,
  annotation := λ _ _ _, 3}

def matrix_of_annotated_graph (Γ : annotated_graph) [decidable_eq Γ.vertex] [decidable_rel Γ.edge]
  (x y : Γ.vertex) : enat :=
if x = y then 1 else if h : Γ.edge x y then Γ.annotation h else 2

/-- "annotate Γ (a,b) n" returns an annotated graph Γ' which is identical to Γ, except that Γ'.annotation a b = n. -/
def annotate (Γ : annotated_graph) [decidable_rel Γ.edge] [decidable_eq Γ.vertex] (x : Γ.vertex × Γ.vertex) (n : ℕ+) : annotated_graph :=
{ vertex := Γ.vertex,
  edge := Γ.edge,
  annotation := λ a b H, if (a = x.1 ∧ b = x.2) ∨ (a = x.2 ∧ b = x.1) then n else Γ.annotation H }

/-- "insert edge Γ (a,b) n" returns Γ' which is Γ except Γ'.edge a b and Γ'.edge b a are true and annotated with n.
If an edge is already present, this does nothing. -/
def insert_edge (Γ : annotated_graph) [decidable_rel Γ.edge] [decidable_eq Γ.vertex] (x : Γ.vertex × Γ.vertex) (n : ℕ+) : annotated_graph :=
{ vertex := Γ.vertex,
  edge := λ a b, if (a = x.1 ∧ b = x.2) ∨ (a = x.2 ∧ b = x.1) then true else Γ.edge a b,
  annotation := λ a b H, if h : Γ.edge a b then Γ.annotation h else n }

/- Coxeter Y-diagrams -/
@[derive decidable_eq] inductive coxeter_vertices {n} (xs : dvector ℕ+ n) : Type
| torso {} : coxeter_vertices
| arm : ∀ x : dfin n, dfin (xs.nth'' x) → coxeter_vertices

open coxeter_vertices

inductive coxeter_edges_directed {n} (xs : dvector ℕ+ n) :
  coxeter_vertices xs → coxeter_vertices xs → Prop
| edge_torso : ∀ i : dfin n , coxeter_edges_directed torso (arm i dfin.fz')
| edge_arm : ∀ i : dfin n, ∀ v : dfin (xs.nth'' i), v.to_nat + 1 ≠ xs.nth'' i →
    coxeter_edges_directed (arm i v) (arm i (v+1))

inductive symmetric_closure {α : Type*} (E : α → α → Prop) : α → α → Prop
| incl : ∀ a b : α, E a b → symmetric_closure a b
| symm : ∀ a b : α, E a b → symmetric_closure b a

def coxeter_edges {n} (xs : dvector ℕ+ n) : coxeter_vertices xs → coxeter_vertices xs → Prop :=
symmetric_closure (coxeter_edges_directed xs)

-- TODO derive decidability instances
noncomputable instance decidable_coxeter_edges {n} (xs : dvector ℕ+ n) :
  decidable_rel $ coxeter_edges xs :=
λ _ _, classical.prop_decidable _

noncomputable instance decidable_rel_annotated_coxeter_edges {n} (xs : dvector ℕ+ n) :
  decidable_rel $ (annotated_graph_of_graph (coxeter_edges xs)).edge :=
λ _ _, classical.prop_decidable _

noncomputable instance decidable_eq_annotate_of_decidable (Γ : annotated_graph)
  [decidable_eq Γ.vertex] [decidable_rel Γ.edge] (x n) : decidable_eq $ (annotate Γ x n).vertex :=
λ _ _, classical.prop_decidable _

noncomputable instance decidable_rel_annotate_of_decidable (Γ : annotated_graph)
  [decidable_eq Γ.vertex] [decidable_rel Γ.edge] (x n) : decidable_rel $ (annotate Γ x n).edge :=
λ _ _, classical.prop_decidable _

noncomputable instance decidable_eq_insert_edge_of_decidable (Γ : annotated_graph)
  [decidable_rel Γ.edge] [decidable_eq Γ.vertex] (x n) : decidable_eq $ (insert_edge Γ x n).vertex :=
λ _ _, classical.prop_decidable _

noncomputable instance decidable_rel_insert_edge_of_decidable (Γ : annotated_graph)
  [decidable_rel Γ.edge] [decidable_eq Γ.vertex] (x n) : decidable_rel $ (insert_edge Γ x n).edge :=
λ _ _, classical.prop_decidable _

/- Derived subgroups -/

def commutator {α : Type*} [group α] : α × α → α
| ⟨x, y⟩ :=  x * y * x⁻¹ * y⁻¹

notation `⟦`:95 x `,` y `⟧`:0 := commutator (x,y)

def commutators_of {α : Type*} [group α] (s : set α) : set α :=
group.closure $ commutator '' s.prod s

/-- the derived subgroup of commutator subgroup is the subgroup generated by all commutators -/
def derived_subgroup (α : Type*) [group α] : set α :=
commutators_of set.univ

instance (α : Type*) [group α] : normal_subgroup (derived_subgroup α) :=
begin
  apply closure.normal_subgroup, intros x hx g, rcases hx with ⟨⟨y, z⟩, h, rfl⟩,
  use ⟨g * y * g⁻¹, g * z * g⁻¹⟩,
  split, split; trivial,
  simp [commutator, mul_assoc]
end

/-- The n-th derived subgroup is defined by iterating the derived subgroup operation -/
def iterated_derived_subgroup (α : Type*) [group α] (n : ℕ) : set α :=
nat.iterate commutators_of n set.univ

/-- the abelianization of G is the group G quotiented by its derived subgroup -/
def abelianization (α : Type*) [group α] : Group :=
mk_ob $ quotient_group.quotient $ derived_subgroup α

/-- A group is called perfect if its derived subgroup is the whole group -/
def is_perfect (α : Type*) [group α] : Prop := derived_subgroup α = set.univ

/-- A group is called solvable if its derived series eventually becomes trivial -/
def is_solvable (α : Type*) [group α] : Prop := ∃ n, iterated_derived_subgroup α n = {1}


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

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

/-!
# Constant functors are QPFs

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

universes u

namespace mvqpf
open_locale mvfunctor

variables (n : ℕ)

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

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

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

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

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

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

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

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

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

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

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

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

end const

end mvqpf


-- Copyright (c) 2018 Michael Jendrusch. All rights reserved.

import category_theory.category
import category_theory.functor
import category_theory.products
import category_theory.natural_isomorphism
import category_theory.tactics.obviously -- Give ourselves access to `rewrite_search`
import .tensor_product
import tactic.slice

open category_theory
open tactic

universes v u

open category_theory.category
open category_theory.functor
open category_theory.prod
open category_theory.functor.category.nat_trans
open category_theory.nat_iso

namespace category_theory.monoidal
class monoidal_category (C : Sort u) extends category.{v} C :=
-- curried tensor product of objects:
(tensor_obj               : C → C → C)
-- curried tensor product of morphisms:
(tensor_hom               : Π {X₁ Y₁ X₂ Y₂ : C}, hom X₁ Y₁ → hom X₂ Y₂ → hom (tensor_obj X₁ X₂) (tensor_obj Y₁ Y₂))
-- tensor product laws:
(tensor_map_id'           : ∀ (X₁ X₂ : C), tensor_hom (𝟙 X₁) (𝟙 X₂) = 𝟙 (tensor_obj X₁ X₂) . obviously)
(tensor_map_comp'         : ∀ {X₁ Y₁ Z₁ X₂ Y₂ Z₂ : C} (f₁ : X₁ ⟶ Y₁) (f₂ : X₂ ⟶ Y₂) (g₁ : Y₁ ⟶ Z₁) (g₂ : Y₂ ⟶ Z₂),
  tensor_hom (f₁ ≫ g₁) (f₂ ≫ g₂) = (tensor_hom f₁ f₂) ≫ (tensor_hom g₁ g₂) . obviously)
-- tensor unit:
(tensor_unit              : C)
-- associator:
(associator               : Π X Y Z : C, (tensor_obj (tensor_obj X Y) Z) ≅ (tensor_obj X (tensor_obj Y Z)))
(associator_naturality'   : assoc_natural tensor_obj @tensor_hom associator . obviously)
-- left unitor:
(left_unitor              : Π X : C, tensor_obj tensor_unit X ≅ X)
(left_unitor_naturality'  : left_unitor_natural tensor_obj @tensor_hom tensor_unit left_unitor . obviously)
-- right unitor:
(right_unitor             : Π X : C, tensor_obj X tensor_unit ≅ X)
(right_unitor_naturality' : right_unitor_natural tensor_obj @tensor_hom tensor_unit right_unitor . obviously)
-- pentagon identity:
(pentagon'                : pentagon @tensor_hom associator . obviously)
-- triangle identity:
(triangle'                : triangle @tensor_hom left_unitor right_unitor associator . obviously)

restate_axiom monoidal_category.tensor_map_id'
attribute [simp,search] monoidal_category.tensor_map_id
restate_axiom monoidal_category.tensor_map_comp'
attribute [simp,search] monoidal_category.tensor_map_comp
restate_axiom monoidal_category.associator_naturality'
attribute [search] monoidal_category.associator_naturality
restate_axiom monoidal_category.left_unitor_naturality'
attribute [search] monoidal_category.left_unitor_naturality
restate_axiom monoidal_category.right_unitor_naturality'
attribute [search] monoidal_category.right_unitor_naturality
restate_axiom monoidal_category.pentagon'
attribute [search] monoidal_category.pentagon
restate_axiom monoidal_category.triangle'
attribute [search] monoidal_category.triangle

@[obviously] meta def obviously'' := tactic.tidy {tactics := tidy.default_tactics ++ [rewrite_search {}]}

section
open monoidal_category

def one {C : Sort u} [monoidal_category.{v} C] (X : C) : X ≅ X :=
{ hom := 𝟙 X,
  inv := 𝟙 X }

def tensor_iso {C : Sort u} {X Y X' Y' : C} [monoidal_category.{v} C] (f : X ≅ Y) (g : X' ≅ Y') :
    tensor_obj X X' ≅ tensor_obj Y Y' :=
{ hom := tensor_hom f.hom g.hom,
  inv := tensor_hom f.inv g.inv}
end

open monoidal_category

section

variables (C : Sort u) [𝒞 : monoidal_category.{v} C]
include 𝒞

instance : category C := 𝒞.to_category

infixr ` ⊗ `:80 := tensor_obj
infixr ` ⊗ `:80 := tensor_hom
infixr ` ⊗ `:80 := tensor_iso

variables {U V W X Y Z : C}

@[search] definition interchange (f : U ⟶ V) (g : V ⟶ W) (h : X ⟶ Y) (k : Y ⟶ Z)
  : (f ≫ g) ⊗ (h ≫ k) = (f ⊗ h) ≫ (g ⊗ k) :=
tensor_map_comp C f h g k

@[simp,search] lemma interchange_left_identity (f : W ⟶ X) (g : X ⟶ Y) :
  (f ⊗ (𝟙 Z)) ≫ (g ⊗ (𝟙 Z)) = (f ≫ g) ⊗ (𝟙 Z) :=
begin
  rw ←interchange,
  simp
end

@[simp,search] lemma interchange_right_identity (f : W ⟶ X) (g : X ⟶ Y) :
  (𝟙 Z ⊗ f) ≫ (𝟙 Z ⊗ g) = (𝟙 Z) ⊗ (f ≫ g) :=
begin
  rw ←interchange,
  simp
end

@[search] lemma interchange_identities (f : W ⟶ X) (g : Y ⟶ Z) :
  ((𝟙 Y) ⊗ f) ≫ (g ⊗ (𝟙 X)) = (g ⊗ (𝟙 W)) ≫ ((𝟙 Z) ⊗ f) :=
begin
  rw ←interchange,
  rw ←interchange,
  simp
end

instance tensor_iso_of_iso
    {X Y X' Y' : C} (f : X ⟶ Y) (g : X' ⟶ Y')
    [is_iso f] [is_iso g] : is_iso (f ⊗ g) :=
{ inv := (is_iso.inv f) ⊗ (is_iso.inv g) }

@[simp,search] lemma tensor_left_equiv
    {X Y : C} (f g : X ⟶ Y) :
    ((𝟙 (tensor_unit C)) ⊗ f = (𝟙 (tensor_unit C)) ⊗ g) ↔ (f = g) :=
sorry

@[simp,search] lemma tensor_right_equiv
    {X Y : C} (f g : X ⟶ Y) :
    (f ⊗ (𝟙 (tensor_unit C)) = g ⊗ (𝟙 (tensor_unit C))) ↔ (f = g) :=
sorry

-- proof following the nLab:
@[search] lemma left_unitor_product_aux_perimeter (X Y : C) :
    ((associator (tensor_unit C) (tensor_unit C) X).hom ⊗ (𝟙 Y)) ≫
    (associator (tensor_unit C) ((tensor_unit C) ⊗ X) Y).hom ≫
    ((𝟙 (tensor_unit C)) ⊗ (associator (tensor_unit C) X Y).hom) ≫
    ((𝟙 (tensor_unit C)) ⊗ (left_unitor (X ⊗ Y)).hom)
  = (((right_unitor (tensor_unit C)).hom ⊗ (𝟙 X)) ⊗ (𝟙 Y)) ≫
    (associator (tensor_unit C) X Y).hom := by obviously

@[search] lemma left_unitor_product_aux_triangle (X Y : C) :
    ((associator (tensor_unit C) (tensor_unit C) X).hom ⊗ (𝟙 Y)) ≫
    (((𝟙 (tensor_unit C)) ⊗ (left_unitor X).hom) ⊗ (𝟙 Y))
  = ((right_unitor (tensor_unit C)).hom ⊗ (𝟙 X)) ⊗ (𝟙 Y) := by obviously

@[search] lemma left_unitor_product_aux_square (X Y : C) :
    (associator (tensor_unit C) ((tensor_unit C) ⊗ X) Y).hom ≫
    ((𝟙 (tensor_unit C)) ⊗ (left_unitor X).hom ⊗ (𝟙 Y))
  = (((𝟙 (tensor_unit C)) ⊗ (left_unitor X).hom) ⊗ (𝟙 Y)) ≫
    (associator (tensor_unit C) X Y).hom := by obviously

@[search] lemma left_unitor_product_aux (X Y : C) :
    ((𝟙 (tensor_unit C)) ⊗ (associator (tensor_unit C) X Y).hom) ≫
    ((𝟙 (tensor_unit C)) ⊗ (left_unitor (X ⊗ Y)).hom)
  = (𝟙 (tensor_unit C)) ⊗ ((left_unitor X).hom ⊗ (𝟙 Y)) :=
begin
  rw <-(cancel_epi (associator (tensor_unit C) ((tensor_unit C) ⊗ X) Y).hom),
  rw left_unitor_product_aux_square,
  rw <-(cancel_epi ((associator (tensor_unit C) (tensor_unit C) X).hom ⊗ (𝟙 Y))),
  conv {
    to_rhs,
    slice 1 2,
    rw left_unitor_product_aux_triangle,
  },
  obviously
end

@[search] lemma right_unitor_product_aux_perimeter (X Y : C) :
    ((associator X Y (tensor_unit C)).hom ⊗ (𝟙 (tensor_unit C))) ≫
    (associator X (Y ⊗ (tensor_unit C)) (tensor_unit C)).hom ≫
    ((𝟙 X) ⊗ (associator Y (tensor_unit C) (tensor_unit C)).hom) ≫
    ((𝟙 X) ⊗ (𝟙 Y) ⊗ (left_unitor (tensor_unit C)).hom)
  = ((right_unitor (X ⊗ Y)).hom ⊗ (𝟙 (tensor_unit C))) ≫
    (associator X Y (tensor_unit C)).hom := by obviously

@[search] lemma right_unitor_product_aux_triangle (X Y : C) :
    ((𝟙 X) ⊗ (associator Y (tensor_unit C) (tensor_unit C)).hom) ≫
    ((𝟙 X) ⊗ (𝟙 Y) ⊗ (left_unitor (tensor_unit C)).hom)
  = (𝟙 X) ⊗ (right_unitor Y).hom ⊗ (𝟙 (tensor_unit C)) := by obviously

@[search] lemma right_unitor_product_aux_square (X Y : C) :
    (associator X (Y ⊗ (tensor_unit C)) (tensor_unit C)).hom ≫
    ((𝟙 X) ⊗ (right_unitor Y).hom ⊗ (𝟙 (tensor_unit C)))
  = (((𝟙 X) ⊗ (right_unitor Y).hom) ⊗ (𝟙 (tensor_unit C))) ≫
    (associator X Y (tensor_unit C)).hom := by obviously

@[search] lemma right_unitor_product_aux (X Y : C) :
    ((associator X Y (tensor_unit C)).hom ⊗ (𝟙 (tensor_unit C))) ≫
    (((𝟙 X) ⊗ (right_unitor Y).hom) ⊗ (𝟙 (tensor_unit C)))
  = ((right_unitor (X ⊗ Y)).hom ⊗ (𝟙 (tensor_unit C))) :=
begin
  rw <-(cancel_mono (associator X Y (tensor_unit C)).hom),
  conv {
    to_lhs,
    slice 2 3,
    rw <-right_unitor_product_aux_square,
  },
  obviously
end

@[search] lemma left_unitor_product (X Y : C) :
  ((associator (tensor_unit C) X Y).hom) ≫
    ((left_unitor (X ⊗ Y)).hom)
  = ((left_unitor X).hom ⊗ (𝟙 Y)) :=
begin
  rw <-tensor_left_equiv,
  rw <-interchange_right_identity,
  apply left_unitor_product_aux
end

@[search] lemma right_unitor_product (X Y : C) :
    ((associator X Y (tensor_unit C)).hom) ≫
    ((𝟙 X) ⊗ (right_unitor Y).hom)
  = ((right_unitor (X ⊗ Y)).hom) :=
begin
  rw <-tensor_right_equiv,
  rw <-interchange_left_identity,
  apply right_unitor_product_aux
end

end

section

-- In order to be able to describe the tensor product as a functor, we
-- need to be up in at least `Type 1` for both objects and morphisms,
-- so that we can construct products.
variables (C : Type u) [𝒞 : monoidal_category.{v+1} C]
include 𝒞

@[reducible] def monoidal_category.tensor : (C × C) ⥤ C :=
{ obj := λ X, tensor_obj X.1 X.2,
  map := λ {X Y : C × C} (f : X ⟶ Y), tensor_hom f.1 f.2 }

@[reducible] def monoidal_category.left_assoc_functor : (C × C × C) ⥤ C :=
{ obj := λ X, (X.1 ⊗ X.2.1) ⊗ X.2.2,
  map := λ {X Y : C × C × C} (f : X ⟶ Y),
    (f.1 ⊗ f.2.1) ⊗ f.2.2 }
@[reducible] def monoidal_category.right_assoc_functor : (C × C × C) ⥤ C :=
{ obj := λ X, X.1 ⊗ (X.2.1 ⊗ X.2.2),
  map := λ {X Y : C × C × C} (f : X ⟶ Y),
    f.1 ⊗ (f.2.1 ⊗ f.2.2) }
@[reducible] def monoidal_category.left_unitor_functor : C ⥤ C :=
{ obj := λ X, tensor_unit C ⊗ X,
  map := λ {X Y : C} (f : X ⟶ Y), (𝟙 (tensor_unit C)) ⊗ f }
@[reducible] def monoidal_category.right_unitor_functor : C ⥤ C :=
{ obj := λ X, X ⊗ tensor_unit C,
  map := λ {X Y : C} (f : X ⟶ Y), f ⊗ (𝟙 (tensor_unit C)) }

open monoidal_category

-- natural isomorphisms for the associator and unitors.

@[reducible] def monoidal_category.associator_nat_iso :
  left_assoc_functor C ≅ right_assoc_functor C :=
nat_iso.of_components
  (by intros; simp; apply category_theory.monoidal.monoidal_category.associator)
  (by intros; simp; apply associator_naturality)
@[reducible] def monoidal_category.left_unitor_nat_iso :
  left_unitor_functor C ≅ functor.id C :=
nat_iso.of_components
  (by intros; simp; apply category_theory.monoidal.monoidal_category.left_unitor)
  (by intros; simp; apply left_unitor_naturality)
@[reducible] def monoidal_category.right_unitor_nat_iso :
  right_unitor_functor C ≅ functor.id C :=
nat_iso.of_components
  (by intros; simp; apply category_theory.monoidal.monoidal_category.right_unitor)
  (by intros; simp; apply right_unitor_naturality)

end

end category_theory.monoidal


/-
Copyright (c) 2022 Rémi Bottinelli. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Rémi Bottinelli, Junyan Xu

! This file was ported from Lean 3 source module category_theory.groupoid.subgroupoid
! leanprover-community/mathlib commit 70fd9563a21e7b963887c9360bd29b2393e6225a
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Groupoid.VertexGroup
import Mathbin.CategoryTheory.Groupoid.Basic
import Mathbin.CategoryTheory.Groupoid
import Mathbin.Algebra.Group.Defs
import Mathbin.Data.Set.Lattice
import Mathbin.GroupTheory.Subgroup.Basic
import Mathbin.Order.GaloisConnection

/-!
# Subgroupoid

This file defines subgroupoids as `structure`s containing the subsets of arrows and their
stability under composition and inversion.
Also defined are:

* containment of subgroupoids is a complete lattice;
* images and preimages of subgroupoids under a functor;
* the notion of normality of subgroupoids and its stability under intersection and preimage;
* compatibility of the above with `groupoid.vertex_group`.

## Main definitions

Given a type `C` with associated `groupoid C` instance.

* `subgroupoid C` is the type of subgroupoids of `C`
* `subgroupoid.is_normal` is the property that the subgroupoid is stable under conjugation
  by arbitrary arrows, _and_ that all identity arrows are contained in the subgroupoid.
* `subgroupoid.comap` is the "preimage" map of subgroupoids along a functor.
* `subgroupoid.map` is the "image" map of subgroupoids along a functor _injective on objects_.
* `subgroupoid.vertex_subgroup` is the subgroup of the `vertex group` at a given vertex `v`,
  assuming `v` is contained in the `subgroupoid` (meaning, by definition, that the arrow `𝟙 v`
  is contained in the subgroupoid).

## Implementation details

The structure of this file is copied from/inspired by `group_theory.subgroup.basic`
and `combinatorics.simple_graph.subgraph`.

## TODO

* Equivalent inductive characterization of generated (normal) subgroupoids.
* Characterization of normal subgroupoids as kernels.
* Prove that `full` and `disconnect` preserve intersections (and `disconnect` also unions)

## Tags

subgroupoid

-/

namespace CategoryTheory

open Set Groupoid

attribute [local protected] CategoryTheory.inv

universe u v

variable {C : Type u} [Groupoid C]

/-- A sugroupoid of `C` consists of a choice of arrows for each pair of vertices, closed
under composition and inverses.
-/
@[ext]
structure Subgroupoid (C : Type u) [Groupoid C] where
  arrows : ∀ c d : C, Set (c ⟶ d)
  inv : ∀ {c d} {p : c ⟶ d} (hp : p ∈ arrows c d), inv p ∈ arrows d c
  mul : ∀ {c d e} {p} (hp : p ∈ arrows c d) {q} (hq : q ∈ arrows d e), p ≫ q ∈ arrows c e
#align category_theory.subgroupoid CategoryTheory.Subgroupoid

attribute [protected] subgroupoid.inv subgroupoid.mul

namespace Subgroupoid

variable (S : Subgroupoid C)

theorem inv_mem_iff {c d : C} (f : c ⟶ d) : inv f ∈ S.arrows d c ↔ f ∈ S.arrows c d :=
  by
  constructor
  · rintro h
    suffices inv (inv f) ∈ S.arrows c d by simpa only [inv_eq_inv, is_iso.inv_inv] using this
    · apply S.inv h
  · apply S.inv
#align category_theory.subgroupoid.inv_mem_iff CategoryTheory.Subgroupoid.inv_mem_iff

theorem mul_mem_cancel_left {c d e : C} {f : c ⟶ d} {g : d ⟶ e} (hf : f ∈ S.arrows c d) :
    f ≫ g ∈ S.arrows c e ↔ g ∈ S.arrows d e :=
  by
  constructor
  · rintro h
    suffices inv f ≫ f ≫ g ∈ S.arrows d e by
      simpa only [inv_eq_inv, is_iso.inv_hom_id_assoc] using this
    · apply S.mul (S.inv hf) h
  · apply S.mul hf
#align category_theory.subgroupoid.mul_mem_cancel_left CategoryTheory.Subgroupoid.mul_mem_cancel_left

theorem mul_mem_cancel_right {c d e : C} {f : c ⟶ d} {g : d ⟶ e} (hg : g ∈ S.arrows d e) :
    f ≫ g ∈ S.arrows c e ↔ f ∈ S.arrows c d :=
  by
  constructor
  · rintro h
    suffices (f ≫ g) ≫ inv g ∈ S.arrows c d by
      simpa only [inv_eq_inv, is_iso.hom_inv_id, category.comp_id, category.assoc] using this
    · apply S.mul h (S.inv hg)
  · exact fun hf => S.mul hf hg
#align category_theory.subgroupoid.mul_mem_cancel_right CategoryTheory.Subgroupoid.mul_mem_cancel_right

/-- The vertices of `C` on which `S` has non-trivial isotropy -/
def objs : Set C :=
  { c : C | (S.arrows c c).Nonempty }
#align category_theory.subgroupoid.objs CategoryTheory.Subgroupoid.objs

theorem mem_objs_of_src {c d : C} {f : c ⟶ d} (h : f ∈ S.arrows c d) : c ∈ S.objs :=
  ⟨f ≫ inv f, S.mul h (S.inv h)⟩
#align category_theory.subgroupoid.mem_objs_of_src CategoryTheory.Subgroupoid.mem_objs_of_src

theorem mem_objs_of_tgt {c d : C} {f : c ⟶ d} (h : f ∈ S.arrows c d) : d ∈ S.objs :=
  ⟨inv f ≫ f, S.mul (S.inv h) h⟩
#align category_theory.subgroupoid.mem_objs_of_tgt CategoryTheory.Subgroupoid.mem_objs_of_tgt

theorem id_mem_of_nonempty_isotropy (c : C) : c ∈ objs S → 𝟙 c ∈ S.arrows c c :=
  by
  rintro ⟨γ, hγ⟩
  convert S.mul hγ (S.inv hγ)
  simp only [inv_eq_inv, is_iso.hom_inv_id]
#align category_theory.subgroupoid.id_mem_of_nonempty_isotropy CategoryTheory.Subgroupoid.id_mem_of_nonempty_isotropy

theorem id_mem_of_src {c d : C} {f : c ⟶ d} (h : f ∈ S.arrows c d) : 𝟙 c ∈ S.arrows c c :=
  id_mem_of_nonempty_isotropy S c (mem_objs_of_src S h)
#align category_theory.subgroupoid.id_mem_of_src CategoryTheory.Subgroupoid.id_mem_of_src

theorem id_mem_of_tgt {c d : C} {f : c ⟶ d} (h : f ∈ S.arrows c d) : 𝟙 d ∈ S.arrows d d :=
  id_mem_of_nonempty_isotropy S d (mem_objs_of_tgt S h)
#align category_theory.subgroupoid.id_mem_of_tgt CategoryTheory.Subgroupoid.id_mem_of_tgt

/-- A subgroupoid seen as a quiver on vertex set `C` -/
def asWideQuiver : Quiver C :=
  ⟨fun c d => Subtype <| S.arrows c d⟩
#align category_theory.subgroupoid.as_wide_quiver CategoryTheory.Subgroupoid.asWideQuiver

/-- The coercion of a subgroupoid as a groupoid -/
@[simps to_category_comp_coe, simps (config := lemmasOnly) inv_coe]
instance coe : Groupoid S.objs where
  Hom a b := S.arrows a.val b.val
  id a := ⟨𝟙 a.val, id_mem_of_nonempty_isotropy S a.val a.Prop⟩
  comp a b c p q := ⟨p.val ≫ q.val, S.mul p.Prop q.Prop⟩
  id_comp' := fun a b ⟨p, hp⟩ => by simp only [category.id_comp]
  comp_id' := fun a b ⟨p, hp⟩ => by simp only [category.comp_id]
  assoc' := fun a b c d ⟨p, hp⟩ ⟨q, hq⟩ ⟨r, hr⟩ => by simp only [category.assoc]
  inv a b p := ⟨inv p.val, S.inv p.Prop⟩
  inv_comp' := fun a b ⟨p, hp⟩ => by simp only [inv_comp]
  comp_inv' := fun a b ⟨p, hp⟩ => by simp only [comp_inv]
#align category_theory.subgroupoid.coe CategoryTheory.Subgroupoid.coe

@[simp]
theorem coe_inv_coe' {c d : S.objs} (p : c ⟶ d) :
    (CategoryTheory.inv p).val = CategoryTheory.inv p.val := by
  simp only [Subtype.val_eq_coe, ← inv_eq_inv, coe_inv_coe]
#align category_theory.subgroupoid.coe_inv_coe' CategoryTheory.Subgroupoid.coe_inv_coe'

/-- The embedding of the coerced subgroupoid to its parent-/
def hom : S.objs ⥤ C where
  obj c := c.val
  map c d f := f.val
  map_id' c := rfl
  map_comp' c d e f g := rfl
#align category_theory.subgroupoid.hom CategoryTheory.Subgroupoid.hom

theorem hom.inj_on_objects : Function.Injective (hom S).obj :=
  by
  rintro ⟨c, hc⟩ ⟨d, hd⟩ hcd
  simp only [Subtype.mk_eq_mk]
  exact hcd
#align category_theory.subgroupoid.hom.inj_on_objects CategoryTheory.Subgroupoid.hom.inj_on_objects

theorem hom.faithful : ∀ c d, Function.Injective fun f : c ⟶ d => (hom S).map f :=
  by
  rintro ⟨c, hc⟩ ⟨d, hd⟩ ⟨f, hf⟩ ⟨g, hg⟩ hfg
  simp only [Subtype.mk_eq_mk]
  exact hfg
#align category_theory.subgroupoid.hom.faithful CategoryTheory.Subgroupoid.hom.faithful

/-- The subgroup of the vertex group at `c` given by the subgroupoid -/
def vertexSubgroup {c : C} (hc : c ∈ S.objs) : Subgroup (c ⟶ c)
    where
  carrier := S.arrows c c
  mul_mem' f g hf hg := S.mul hf hg
  one_mem' := id_mem_of_nonempty_isotropy _ _ hc
  inv_mem' f hf := S.inv hf
#align category_theory.subgroupoid.vertex_subgroup CategoryTheory.Subgroupoid.vertexSubgroup

instance : SetLike (Subgroupoid C) (Σc d : C, c ⟶ d)
    where
  coe S := { F | F.2.2 ∈ S.arrows F.1 F.2.1 }
  coe_injective' := fun ⟨S, _, _⟩ ⟨T, _, _⟩ h =>
    by
    ext (c d f)
    apply Set.ext_iff.1 h ⟨c, d, f⟩

theorem mem_iff (S : Subgroupoid C) (F : Σc d, c ⟶ d) : F ∈ S ↔ F.2.2 ∈ S.arrows F.1 F.2.1 :=
  Iff.rfl
#align category_theory.subgroupoid.mem_iff CategoryTheory.Subgroupoid.mem_iff

theorem le_iff (S T : Subgroupoid C) : S ≤ T ↔ ∀ {c d}, S.arrows c d ⊆ T.arrows c d :=
  by
  rw [SetLike.le_def, Sigma.forall]
  exact forall_congr' fun c => Sigma.forall
#align category_theory.subgroupoid.le_iff CategoryTheory.Subgroupoid.le_iff

instance : Top (Subgroupoid C) :=
  ⟨{  arrows := fun _ _ => Set.univ
      mul := by
        rintro
        trivial
      inv := by
        rintro
        trivial }⟩

theorem mem_top {c d : C} (f : c ⟶ d) : f ∈ (⊤ : Subgroupoid C).arrows c d :=
  trivial
#align category_theory.subgroupoid.mem_top CategoryTheory.Subgroupoid.mem_top

theorem mem_top_objs (c : C) : c ∈ (⊤ : Subgroupoid C).objs :=
  by
  dsimp [Top.top, objs]
  simp only [univ_nonempty]
#align category_theory.subgroupoid.mem_top_objs CategoryTheory.Subgroupoid.mem_top_objs

instance : Bot (Subgroupoid C) :=
  ⟨{  arrows := fun _ _ => ∅
      mul := fun _ _ _ _ => False.elim
      inv := fun _ _ _ => False.elim }⟩

instance : Inhabited (Subgroupoid C) :=
  ⟨⊤⟩

instance : Inf (Subgroupoid C) :=
  ⟨fun S T =>
    { arrows := fun c d => S.arrows c d ∩ T.arrows c d
      inv := by
        rintro
        exact ⟨S.inv hp.1, T.inv hp.2⟩
      mul := by
        rintro
        exact ⟨S.mul hp.1 hq.1, T.mul hp.2 hq.2⟩ }⟩

instance : InfSet (Subgroupoid C) :=
  ⟨fun s =>
    { arrows := fun c d => ⋂ S ∈ s, Subgroupoid.arrows S c d
      inv := by
        intros
        rw [mem_Inter₂] at hp⊢
        exact fun S hS => S.inv (hp S hS)
      mul := by
        intros
        rw [mem_Inter₂] at hp hq⊢
        exact fun S hS => S.mul (hp S hS) (hq S hS) }⟩

instance : CompleteLattice (Subgroupoid C) :=
  {
    completeLatticeOfInf (Subgroupoid C)
      (by
        refine' fun s => ⟨fun S Ss F => _, fun T Tl F fT => _⟩ <;>
          simp only [Inf, mem_iff, mem_Inter]
        exacts[fun hp => hp S Ss, fun S Ss =>
          Tl Ss fT]) with
    bot := ⊥
    bot_le := fun S => empty_subset _
    top := ⊤
    le_top := fun S => subset_univ _
    inf := (· ⊓ ·)
    le_inf := fun R S T RS RT _ pR => ⟨RS pR, RT pR⟩
    inf_le_left := fun R S _ => And.left
    inf_le_right := fun R S _ => And.right }

theorem le_objs {S T : Subgroupoid C} (h : S ≤ T) : S.objs ⊆ T.objs := fun s ⟨γ, hγ⟩ =>
  ⟨γ, @h ⟨s, s, γ⟩ hγ⟩
#align category_theory.subgroupoid.le_objs CategoryTheory.Subgroupoid.le_objs

/-- The functor associated to the embedding of subgroupoids -/
def inclusion {S T : Subgroupoid C} (h : S ≤ T) : S.objs ⥤ T.objs
    where
  obj s := ⟨s.val, le_objs h s.Prop⟩
  map s t f := ⟨f.val, @h ⟨s, t, f.val⟩ f.Prop⟩
  map_id' _ := rfl
  map_comp' _ _ _ _ _ := rfl
#align category_theory.subgroupoid.inclusion CategoryTheory.Subgroupoid.inclusion

theorem inclusion_inj_on_objects {S T : Subgroupoid C} (h : S ≤ T) :
    Function.Injective (inclusion h).obj := fun ⟨s, hs⟩ ⟨t, ht⟩ => by
  simpa only [inclusion, Subtype.mk_eq_mk] using id
#align category_theory.subgroupoid.inclusion_inj_on_objects CategoryTheory.Subgroupoid.inclusion_inj_on_objects

theorem inclusion_faithful {S T : Subgroupoid C} (h : S ≤ T) (s t : S.objs) :
    Function.Injective fun f : s ⟶ t => (inclusion h).map f := fun ⟨f, hf⟩ ⟨g, hg⟩ =>
  by
  dsimp only [inclusion]
  simpa only [Subtype.mk_eq_mk] using id
#align category_theory.subgroupoid.inclusion_faithful CategoryTheory.Subgroupoid.inclusion_faithful

theorem inclusion_refl {S : Subgroupoid C} : inclusion (le_refl S) = 𝟭 S.objs :=
  Functor.hext (fun ⟨s, hs⟩ => rfl) fun ⟨s, hs⟩ ⟨t, ht⟩ ⟨f, hf⟩ => hEq_of_eq rfl
#align category_theory.subgroupoid.inclusion_refl CategoryTheory.Subgroupoid.inclusion_refl

theorem inclusion_trans {R S T : Subgroupoid C} (k : R ≤ S) (h : S ≤ T) :
    inclusion (k.trans h) = inclusion k ⋙ inclusion h :=
  rfl
#align category_theory.subgroupoid.inclusion_trans CategoryTheory.Subgroupoid.inclusion_trans

theorem inclusion_comp_embedding {S T : Subgroupoid C} (h : S ≤ T) : inclusion h ⋙ T.Hom = S.Hom :=
  rfl
#align category_theory.subgroupoid.inclusion_comp_embedding CategoryTheory.Subgroupoid.inclusion_comp_embedding

/-- The family of arrows of the discrete groupoid -/
inductive Discrete.Arrows : ∀ c d : C, (c ⟶ d) → Prop
  | id (c : C) : discrete.arrows c c (𝟙 c)
#align category_theory.subgroupoid.discrete.arrows CategoryTheory.Subgroupoid.Discrete.Arrows

/-- The only arrows of the discrete groupoid are the identity arrows. -/
def discrete : Subgroupoid C where
  arrows := Discrete.Arrows
  inv := by
    rintro _ _ _ ⟨⟩
    simp only [inv_eq_inv, is_iso.inv_id]
    constructor
  mul := by
    rintro _ _ _ _ ⟨⟩ _ ⟨⟩
    rw [category.comp_id]
    constructor
#align category_theory.subgroupoid.discrete CategoryTheory.Subgroupoid.discrete

theorem mem_discrete_iff {c d : C} (f : c ⟶ d) :
    f ∈ discrete.arrows c d ↔ ∃ h : c = d, f = eqToHom h :=
  ⟨by
    rintro ⟨⟩
    exact ⟨rfl, rfl⟩, by
    rintro ⟨rfl, rfl⟩
    constructor⟩
#align category_theory.subgroupoid.mem_discrete_iff CategoryTheory.Subgroupoid.mem_discrete_iff

/-- A subgroupoid is wide if its carrier set is all of `C`-/
structure IsWide : Prop where
  wide : ∀ c, 𝟙 c ∈ S.arrows c c
#align category_theory.subgroupoid.is_wide CategoryTheory.Subgroupoid.IsWide

theorem isWide_iff_objs_eq_univ : S.IsWide ↔ S.objs = Set.univ :=
  by
  constructor
  · rintro h
    ext
    constructor <;> simp only [top_eq_univ, mem_univ, imp_true_iff, forall_true_left]
    apply mem_objs_of_src S (h.wide x)
  · rintro h
    refine' ⟨fun c => _⟩
    obtain ⟨γ, γS⟩ := (le_of_eq h.symm : ⊤ ⊆ S.objs) (Set.mem_univ c)
    exact id_mem_of_src S γS
#align category_theory.subgroupoid.is_wide_iff_objs_eq_univ CategoryTheory.Subgroupoid.isWide_iff_objs_eq_univ

theorem IsWide.id_mem {S : Subgroupoid C} (Sw : S.IsWide) (c : C) : 𝟙 c ∈ S.arrows c c :=
  Sw.wide c
#align category_theory.subgroupoid.is_wide.id_mem CategoryTheory.Subgroupoid.IsWide.id_mem

theorem IsWide.eqToHom_mem {S : Subgroupoid C} (Sw : S.IsWide) {c d : C} (h : c = d) :
    eqToHom h ∈ S.arrows c d := by
  cases h
  simp only [eq_to_hom_refl]
  apply Sw.id_mem c
#align category_theory.subgroupoid.is_wide.eq_to_hom_mem CategoryTheory.Subgroupoid.IsWide.eqToHom_mem

/-- A subgroupoid is normal if it is wide and satisfies the expected stability under conjugacy. -/
structure IsNormal extends IsWide S : Prop where
  conj : ∀ {c d} (p : c ⟶ d) {γ : c ⟶ c} (hs : γ ∈ S.arrows c c), inv p ≫ γ ≫ p ∈ S.arrows d d
#align category_theory.subgroupoid.is_normal CategoryTheory.Subgroupoid.IsNormal

theorem IsNormal.conj' {S : Subgroupoid C} (Sn : IsNormal S) :
    ∀ {c d} (p : d ⟶ c) {γ : c ⟶ c} (hs : γ ∈ S.arrows c c), p ≫ γ ≫ inv p ∈ S.arrows d d :=
  fun c d p γ hs => by
  convert Sn.conj (inv p) hs
  simp
#align category_theory.subgroupoid.is_normal.conj' CategoryTheory.Subgroupoid.IsNormal.conj'

theorem IsNormal.conjugation_bij (Sn : IsNormal S) {c d} (p : c ⟶ d) :
    Set.BijOn (fun γ : c ⟶ c => inv p ≫ γ ≫ p) (S.arrows c c) (S.arrows d d) :=
  by
  refine'
    ⟨fun γ γS => Sn.conj p γS, fun γ₁ γ₁S γ₂ γ₂S h => _, fun δ δS =>
      ⟨p ≫ δ ≫ inv p, Sn.conj' p δS, _⟩⟩
  ·
    simpa only [inv_eq_inv, category.assoc, is_iso.hom_inv_id, category.comp_id,
      is_iso.hom_inv_id_assoc] using p ≫= h =≫ inv p
  ·
    simp only [inv_eq_inv, category.assoc, is_iso.inv_hom_id, category.comp_id,
      is_iso.inv_hom_id_assoc]
#align category_theory.subgroupoid.is_normal.conjugation_bij CategoryTheory.Subgroupoid.IsNormal.conjugation_bij

theorem top_isNormal : IsNormal (⊤ : Subgroupoid C) :=
  { wide := fun c => trivial
    conj := fun a b c d e => trivial }
#align category_theory.subgroupoid.top_is_normal CategoryTheory.Subgroupoid.top_isNormal

theorem infₛ_isNormal (s : Set <| Subgroupoid C) (sn : ∀ S ∈ s, IsNormal S) : IsNormal (infₛ s) :=
  { wide := by
      simp_rw [Inf, mem_Inter₂]
      exact fun c S Ss => (sn S Ss).wide c
    conj := by
      simp_rw [Inf, mem_Inter₂]
      exact fun c d p γ hγ S Ss => (sn S Ss).conj p (hγ S Ss) }
#align category_theory.subgroupoid.Inf_is_normal CategoryTheory.Subgroupoid.infₛ_isNormal

theorem discrete_isNormal : (@discrete C _).IsNormal :=
  { wide := fun c => by constructor
    conj := fun c d f γ hγ => by
      cases hγ
      simp only [inv_eq_inv, category.id_comp, is_iso.inv_hom_id]
      constructor }
#align category_theory.subgroupoid.discrete_is_normal CategoryTheory.Subgroupoid.discrete_isNormal

theorem IsNormal.vertexSubgroup (Sn : IsNormal S) (c : C) (cS : c ∈ S.objs) :
    (S.vertexSubgroup cS).Normal :=
  {
    conj_mem := fun x hx y => by
      rw [mul_assoc]
      exact Sn.conj' y hx }
#align category_theory.subgroupoid.is_normal.vertex_subgroup CategoryTheory.Subgroupoid.IsNormal.vertexSubgroup

section GeneratedSubgroupoid

-- TODO: proof that generated is just "words in X" and generated_normal is similarly
variable (X : ∀ c d : C, Set (c ⟶ d))

/-- The subgropoid generated by the set of arrows `X` -/
def generated : Subgroupoid C :=
  infₛ { S : Subgroupoid C | ∀ c d, X c d ⊆ S.arrows c d }
#align category_theory.subgroupoid.generated CategoryTheory.Subgroupoid.generated

theorem subset_generated (c d : C) : X c d ⊆ (generated X).arrows c d :=
  by
  dsimp only [generated, Inf]
  simp only [subset_Inter₂_iff]
  exact fun S hS f fS => hS _ _ fS
#align category_theory.subgroupoid.subset_generated CategoryTheory.Subgroupoid.subset_generated

/-- The normal sugroupoid generated by the set of arrows `X` -/
def generatedNormal : Subgroupoid C :=
  infₛ { S : Subgroupoid C | (∀ c d, X c d ⊆ S.arrows c d) ∧ S.IsNormal }
#align category_theory.subgroupoid.generated_normal CategoryTheory.Subgroupoid.generatedNormal

theorem generated_le_generatedNormal : generated X ≤ generatedNormal X :=
  by
  apply @infₛ_le_infₛ (subgroupoid C) _
  exact fun S ⟨h, _⟩ => h
#align category_theory.subgroupoid.generated_le_generated_normal CategoryTheory.Subgroupoid.generated_le_generatedNormal

theorem generatedNormal_isNormal : (generatedNormal X).IsNormal :=
  infₛ_isNormal _ fun S h => h.right
#align category_theory.subgroupoid.generated_normal_is_normal CategoryTheory.Subgroupoid.generatedNormal_isNormal

theorem IsNormal.generatedNormal_le {S : Subgroupoid C} (Sn : S.IsNormal) :
    generatedNormal X ≤ S ↔ ∀ c d, X c d ⊆ S.arrows c d :=
  by
  constructor
  · rintro h c d
    let h' := generated_le_generated_normal X
    rw [le_iff] at h h'
    exact ((subset_generated X c d).trans (@h' c d)).trans (@h c d)
  · rintro h
    apply @infₛ_le (subgroupoid C) _
    exact ⟨h, Sn⟩
#align category_theory.subgroupoid.is_normal.generated_normal_le CategoryTheory.Subgroupoid.IsNormal.generatedNormal_le

end GeneratedSubgroupoid

section Hom

variable {D : Type _} [Groupoid D] (φ : C ⥤ D)

/-- A functor between groupoid defines a map of subgroupoids in the reverse direction
by taking preimages.
 -/
def comap (S : Subgroupoid D) : Subgroupoid C
    where
  arrows c d := { f : c ⟶ d | φ.map f ∈ S.arrows (φ.obj c) (φ.obj d) }
  inv c d p hp := by
    rw [mem_set_of, inv_eq_inv, φ.map_inv p, ← inv_eq_inv]
    exact S.inv hp
  mul := by
    rintro
    simp only [mem_set_of, functor.map_comp]
    apply S.mul <;> assumption
#align category_theory.subgroupoid.comap CategoryTheory.Subgroupoid.comap

theorem comap_mono (S T : Subgroupoid D) : S ≤ T → comap φ S ≤ comap φ T := fun ST ⟨c, d, p⟩ =>
  @ST ⟨_, _, _⟩
#align category_theory.subgroupoid.comap_mono CategoryTheory.Subgroupoid.comap_mono

theorem isNormal_comap {S : Subgroupoid D} (Sn : IsNormal S) : IsNormal (comap φ S) :=
  { wide := fun c => by
      rw [comap, mem_set_of, Functor.map_id]
      apply Sn.wide
    conj := fun c d f γ hγ =>
      by
      simp_rw [inv_eq_inv f, comap, mem_set_of, functor.map_comp, functor.map_inv, ← inv_eq_inv]
      exact Sn.conj _ hγ }
#align category_theory.subgroupoid.is_normal_comap CategoryTheory.Subgroupoid.isNormal_comap

@[simp]
theorem comap_comp {E : Type _} [Groupoid E] (ψ : D ⥤ E) : comap (φ ⋙ ψ) = comap φ ∘ comap ψ :=
  rfl
#align category_theory.subgroupoid.comap_comp CategoryTheory.Subgroupoid.comap_comp

/-- The kernel of a functor between subgroupoid is the preimage. -/
def ker : Subgroupoid C :=
  comap φ discrete
#align category_theory.subgroupoid.ker CategoryTheory.Subgroupoid.ker

theorem mem_ker_iff {c d : C} (f : c ⟶ d) :
    f ∈ (ker φ).arrows c d ↔ ∃ h : φ.obj c = φ.obj d, φ.map f = eqToHom h :=
  mem_discrete_iff (φ.map f)
#align category_theory.subgroupoid.mem_ker_iff CategoryTheory.Subgroupoid.mem_ker_iff

theorem ker_isNormal : (ker φ).IsNormal :=
  isNormal_comap φ discrete_isNormal
#align category_theory.subgroupoid.ker_is_normal CategoryTheory.Subgroupoid.ker_isNormal

@[simp]
theorem ker_comp {E : Type _} [Groupoid E] (ψ : D ⥤ E) : ker (φ ⋙ ψ) = comap φ (ker ψ) :=
  rfl
#align category_theory.subgroupoid.ker_comp CategoryTheory.Subgroupoid.ker_comp

/-- The family of arrows of the image of a subgroupoid under a functor injective on objects -/
inductive Map.Arrows (hφ : Function.Injective φ.obj) (S : Subgroupoid C) : ∀ c d : D, (c ⟶ d) → Prop
  | im {c d : C} (f : c ⟶ d) (hf : f ∈ S.arrows c d) : map.arrows (φ.obj c) (φ.obj d) (φ.map f)
#align category_theory.subgroupoid.map.arrows CategoryTheory.Subgroupoid.Map.Arrows

theorem Map.arrows_iff (hφ : Function.Injective φ.obj) (S : Subgroupoid C) {c d : D} (f : c ⟶ d) :
    Map.Arrows φ hφ S c d f ↔
      ∃ (a b : C)(g : a ⟶ b)(ha : φ.obj a = c)(hb : φ.obj b = d)(hg : g ∈ S.arrows a b),
        f = eqToHom ha.symm ≫ φ.map g ≫ eqToHom hb :=
  by
  constructor
  · rintro ⟨g, hg⟩
    exact ⟨_, _, g, rfl, rfl, hg, eq_conj_eq_to_hom _⟩
  · rintro ⟨a, b, g, rfl, rfl, hg, rfl⟩
    rw [← eq_conj_eq_to_hom]
    constructor
    exact hg
#align category_theory.subgroupoid.map.arrows_iff CategoryTheory.Subgroupoid.Map.arrows_iff

/-- The "forward" image of a subgroupoid under a functor injective on objects -/
def map (hφ : Function.Injective φ.obj) (S : Subgroupoid C) : Subgroupoid D
    where
  arrows := Map.Arrows φ hφ S
  inv := by
    rintro _ _ _ ⟨⟩
    rw [inv_eq_inv, ← functor.map_inv, ← inv_eq_inv]
    constructor; apply S.inv; assumption
  mul := by
    rintro _ _ _ _ ⟨f, hf⟩ q hq
    obtain ⟨c₃, c₄, g, he, rfl, hg, gq⟩ := (map.arrows_iff φ hφ S q).mp hq
    cases hφ he; rw [gq, ← eq_conj_eq_to_hom, ← φ.map_comp]
    constructor; exact S.mul hf hg
#align category_theory.subgroupoid.map CategoryTheory.Subgroupoid.map

theorem mem_map_iff (hφ : Function.Injective φ.obj) (S : Subgroupoid C) {c d : D} (f : c ⟶ d) :
    f ∈ (map φ hφ S).arrows c d ↔
      ∃ (a b : C)(g : a ⟶ b)(ha : φ.obj a = c)(hb : φ.obj b = d)(hg : g ∈ S.arrows a b),
        f = eqToHom ha.symm ≫ φ.map g ≫ eqToHom hb :=
  Map.arrows_iff φ hφ S f
#align category_theory.subgroupoid.mem_map_iff CategoryTheory.Subgroupoid.mem_map_iff

theorem galoisConnection_map_comap (hφ : Function.Injective φ.obj) :
    GaloisConnection (map φ hφ) (comap φ) :=
  by
  rintro S T; simp_rw [le_iff]; constructor
  · exact fun h c d f fS => h (map.arrows.im f fS)
  · rintro h _ _ g ⟨a, gφS⟩
    exact h gφS
#align category_theory.subgroupoid.galois_connection_map_comap CategoryTheory.Subgroupoid.galoisConnection_map_comap

theorem map_mono (hφ : Function.Injective φ.obj) (S T : Subgroupoid C) :
    S ≤ T → map φ hφ S ≤ map φ hφ T := fun h => (galoisConnection_map_comap φ hφ).monotone_l h
#align category_theory.subgroupoid.map_mono CategoryTheory.Subgroupoid.map_mono

theorem le_comap_map (hφ : Function.Injective φ.obj) (S : Subgroupoid C) :
    S ≤ comap φ (map φ hφ S) :=
  (galoisConnection_map_comap φ hφ).le_u_l S
#align category_theory.subgroupoid.le_comap_map CategoryTheory.Subgroupoid.le_comap_map

theorem map_comap_le (hφ : Function.Injective φ.obj) (T : Subgroupoid D) :
    map φ hφ (comap φ T) ≤ T :=
  (galoisConnection_map_comap φ hφ).l_u_le T
#align category_theory.subgroupoid.map_comap_le CategoryTheory.Subgroupoid.map_comap_le

theorem map_le_iff_le_comap (hφ : Function.Injective φ.obj) (S : Subgroupoid C)
    (T : Subgroupoid D) : map φ hφ S ≤ T ↔ S ≤ comap φ T :=
  (galoisConnection_map_comap φ hφ).le_iff_le
#align category_theory.subgroupoid.map_le_iff_le_comap CategoryTheory.Subgroupoid.map_le_iff_le_comap

theorem mem_map_objs_iff (hφ : Function.Injective φ.obj) (d : D) :
    d ∈ (map φ hφ S).objs ↔ ∃ c ∈ S.objs, φ.obj c = d :=
  by
  dsimp [objs, map]
  constructor
  · rintro ⟨f, hf⟩
    change map.arrows φ hφ S d d f at hf
    rw [map.arrows_iff] at hf
    obtain ⟨c, d, g, ec, ed, eg, gS, eg⟩ := hf
    exact ⟨c, ⟨mem_objs_of_src S eg, ec⟩⟩
  · rintro ⟨c, ⟨γ, γS⟩, rfl⟩
    exact ⟨φ.map γ, ⟨γ, γS⟩⟩
#align category_theory.subgroupoid.mem_map_objs_iff CategoryTheory.Subgroupoid.mem_map_objs_iff

@[simp]
theorem map_objs_eq (hφ : Function.Injective φ.obj) : (map φ hφ S).objs = φ.obj '' S.objs :=
  by
  ext
  convert mem_map_objs_iff S φ hφ x
  simp only [mem_image, exists_prop]
#align category_theory.subgroupoid.map_objs_eq CategoryTheory.Subgroupoid.map_objs_eq

/-- The image of a functor injective on objects -/
def im (hφ : Function.Injective φ.obj) :=
  map φ hφ ⊤
#align category_theory.subgroupoid.im CategoryTheory.Subgroupoid.im

theorem mem_im_iff (hφ : Function.Injective φ.obj) {c d : D} (f : c ⟶ d) :
    f ∈ (im φ hφ).arrows c d ↔
      ∃ (a b : C)(g : a ⟶ b)(ha : φ.obj a = c)(hb : φ.obj b = d),
        f = eqToHom ha.symm ≫ φ.map g ≫ eqToHom hb :=
  by
  convert map.arrows_iff φ hφ ⊤ f
  simp only [Top.top, mem_univ, exists_true_left]
#align category_theory.subgroupoid.mem_im_iff CategoryTheory.Subgroupoid.mem_im_iff

theorem mem_im_objs_iff (hφ : Function.Injective φ.obj) (d : D) :
    d ∈ (im φ hφ).objs ↔ ∃ c : C, φ.obj c = d := by
  simp only [im, mem_map_objs_iff, mem_top_objs, exists_true_left]
#align category_theory.subgroupoid.mem_im_objs_iff CategoryTheory.Subgroupoid.mem_im_objs_iff

theorem obj_surjective_of_im_eq_top (hφ : Function.Injective φ.obj) (hφ' : im φ hφ = ⊤) :
    Function.Surjective φ.obj := by
  rintro d
  rw [← mem_im_objs_iff, hφ']
  apply mem_top_objs
#align category_theory.subgroupoid.obj_surjective_of_im_eq_top CategoryTheory.Subgroupoid.obj_surjective_of_im_eq_top

theorem isNormal_map (hφ : Function.Injective φ.obj) (hφ' : im φ hφ = ⊤) (Sn : S.IsNormal) :
    (map φ hφ S).IsNormal :=
  { wide := fun d => by
      obtain ⟨c, rfl⟩ := obj_surjective_of_im_eq_top φ hφ hφ' d
      change map.arrows φ hφ S _ _ (𝟙 _)
      rw [← Functor.map_id]
      constructor
      exact Sn.wide c
    conj := fun d d' g δ hδ => by
      rw [mem_map_iff] at hδ
      obtain ⟨c, c', γ, cd, cd', γS, hγ⟩ := hδ
      subst_vars
      cases hφ cd'
      have : d' ∈ (im φ hφ).objs := by
        rw [hφ']
        apply mem_top_objs
      rw [mem_im_objs_iff] at this
      obtain ⟨c', rfl⟩ := this
      have : g ∈ (im φ hφ).arrows (φ.obj c) (φ.obj c') :=
        by
        rw [hφ']
        trivial
      rw [mem_im_iff] at this
      obtain ⟨b, b', f, hb, hb', _, hf⟩ := this
      subst_vars
      cases hφ hb
      cases hφ hb'
      change map.arrows φ hφ S (φ.obj c') (φ.obj c') _
      simp only [eq_to_hom_refl, category.comp_id, category.id_comp, inv_eq_inv]
      suffices map.arrows φ hφ S (φ.obj c') (φ.obj c') (φ.map <| inv f ≫ γ ≫ f)
        by
        simp only [inv_eq_inv, functor.map_comp, functor.map_inv] at this
        exact this
      · constructor
        apply Sn.conj f γS }
#align category_theory.subgroupoid.is_normal_map CategoryTheory.Subgroupoid.isNormal_map

end Hom

section Thin

/-- A subgroupoid `is_thin` if it has at most one arrow between any two vertices. -/
abbrev IsThin :=
  Quiver.IsThin S.objs
#align category_theory.subgroupoid.is_thin CategoryTheory.Subgroupoid.IsThin

theorem isThin_iff : S.IsThin ↔ ∀ c : S.objs, Subsingleton (S.arrows c c) := by apply is_thin_iff
#align category_theory.subgroupoid.is_thin_iff CategoryTheory.Subgroupoid.isThin_iff

end Thin

section Disconnected

/-- A subgroupoid `is_totally_disconnected` if it has only isotropy arrows. -/
abbrev IsTotallyDisconnected :=
  IsTotallyDisconnected S.objs
#align category_theory.subgroupoid.is_totally_disconnected CategoryTheory.Subgroupoid.IsTotallyDisconnected

theorem isTotallyDisconnected_iff :
    S.IsTotallyDisconnected ↔ ∀ c d, (S.arrows c d).Nonempty → c = d :=
  by
  constructor
  · rintro h c d ⟨f, fS⟩
    rw [← @Subtype.mk_eq_mk _ _ c (mem_objs_of_src S fS) d (mem_objs_of_tgt S fS)]
    exact h ⟨c, mem_objs_of_src S fS⟩ ⟨d, mem_objs_of_tgt S fS⟩ ⟨f, fS⟩
  · rintro h ⟨c, hc⟩ ⟨d, hd⟩ ⟨f, fS⟩
    simp only [Subtype.mk_eq_mk]
    exact h c d ⟨f, fS⟩
#align category_theory.subgroupoid.is_totally_disconnected_iff CategoryTheory.Subgroupoid.isTotallyDisconnected_iff

/-- The isotropy subgroupoid of `S` -/
def disconnect : Subgroupoid C
    where
  arrows c d f := c = d ∧ f ∈ S.arrows c d
  inv := by
    rintro _ _ _ ⟨rfl, h⟩
    exact ⟨rfl, S.inv h⟩
  mul := by
    rintro _ _ _ _ ⟨rfl, h⟩ _ ⟨rfl, h'⟩
    exact ⟨rfl, S.mul h h'⟩
#align category_theory.subgroupoid.disconnect CategoryTheory.Subgroupoid.disconnect

theorem disconnect_le : S.disconnect ≤ S := by
  rw [le_iff]
  rintro _ _ _ ⟨⟩
  assumption
#align category_theory.subgroupoid.disconnect_le CategoryTheory.Subgroupoid.disconnect_le

theorem disconnect_normal (Sn : S.IsNormal) : S.disconnect.IsNormal :=
  { wide := fun c => ⟨rfl, Sn.wide c⟩
    conj := fun c d p γ ⟨_, h'⟩ => ⟨rfl, Sn.conj _ h'⟩ }
#align category_theory.subgroupoid.disconnect_normal CategoryTheory.Subgroupoid.disconnect_normal

@[simp]
theorem mem_disconnect_objs_iff {c : C} : c ∈ S.disconnect.objs ↔ c ∈ S.objs :=
  ⟨fun ⟨γ, h, γS⟩ => ⟨γ, γS⟩, fun ⟨γ, γS⟩ => ⟨γ, rfl, γS⟩⟩
#align category_theory.subgroupoid.mem_disconnect_objs_iff CategoryTheory.Subgroupoid.mem_disconnect_objs_iff

theorem disconnect_objs : S.disconnect.objs = S.objs :=
  by
  apply Set.ext
  apply mem_disconnect_objs_iff
#align category_theory.subgroupoid.disconnect_objs CategoryTheory.Subgroupoid.disconnect_objs

theorem disconnect_isTotallyDisconnected : S.disconnect.IsTotallyDisconnected :=
  by
  rw [is_totally_disconnected_iff]
  exact fun c d ⟨f, h, fS⟩ => h
#align category_theory.subgroupoid.disconnect_is_totally_disconnected CategoryTheory.Subgroupoid.disconnect_isTotallyDisconnected

end Disconnected

section Full

variable (D : Set C)

/-- The full subgroupoid on a set `D : set C` -/
def full : Subgroupoid C where
  arrows c d _ := c ∈ D ∧ d ∈ D
  inv := by
    rintro _ _ _ ⟨⟩
    constructor <;> assumption
  mul := by
    rintro _ _ _ _ ⟨⟩ _ ⟨⟩
    constructor <;> assumption
#align category_theory.subgroupoid.full CategoryTheory.Subgroupoid.full

theorem full_objs : (full D).objs = D :=
  Set.ext fun _ => ⟨fun ⟨f, h, _⟩ => h, fun h => ⟨𝟙 _, h, h⟩⟩
#align category_theory.subgroupoid.full_objs CategoryTheory.Subgroupoid.full_objs

@[simp]
theorem mem_full_iff {c d : C} {f : c ⟶ d} : f ∈ (full D).arrows c d ↔ c ∈ D ∧ d ∈ D :=
  Iff.rfl
#align category_theory.subgroupoid.mem_full_iff CategoryTheory.Subgroupoid.mem_full_iff

@[simp]
theorem mem_full_objs_iff {c : C} : c ∈ (full D).objs ↔ c ∈ D := by rw [full_objs]
#align category_theory.subgroupoid.mem_full_objs_iff CategoryTheory.Subgroupoid.mem_full_objs_iff

@[simp]
theorem full_empty : full ∅ = (⊥ : Subgroupoid C) :=
  by
  ext
  simp only [Bot.bot, mem_full_iff, mem_empty_iff_false, and_self_iff]
#align category_theory.subgroupoid.full_empty CategoryTheory.Subgroupoid.full_empty

@[simp]
theorem full_univ : full Set.univ = (⊤ : Subgroupoid C) :=
  by
  ext
  simp only [mem_full_iff, mem_univ, and_self_iff, true_iff_iff]
#align category_theory.subgroupoid.full_univ CategoryTheory.Subgroupoid.full_univ

theorem full_mono {D E : Set C} (h : D ≤ E) : full D ≤ full E :=
  by
  rw [le_iff]
  rintro c d f
  simp only [mem_full_iff]
  exact fun ⟨hc, hd⟩ => ⟨h hc, h hd⟩
#align category_theory.subgroupoid.full_mono CategoryTheory.Subgroupoid.full_mono

theorem full_arrow_eq_iff {c d : (full D).objs} {f g : c ⟶ d} : f = g ↔ (↑f : c.val ⟶ d.val) = ↑g :=
  by apply Subtype.ext_iff
#align category_theory.subgroupoid.full_arrow_eq_iff CategoryTheory.Subgroupoid.full_arrow_eq_iff

end Full

end Subgroupoid

end CategoryTheory


import data.finset.basic

import guidelines.protocol
import guidelines.definitions
import guidelines.requirements
import guidelines.proof

namespace multipaxos

structure state_defs (sys_state_t pid_t slot_t ballot_t value_t : Type) :=
  (curr : sys_state_t → pid_t → ballot_t)
  (stored : sys_state_t → pid_t → slot_t → option (proposal ballot_t value_t))
  (proposed : sys_state_t → slot_t → ballot_t → value_t → Prop)
  (voted : sys_state_t → pid_t → slot_t → ballot_t → Prop)
  (quorum : finset pid_t → Prop)

namespace state_defs

variables {sys_state_t pid_t slot_t ballot_t value_t : Type}

def chosen_ballot
  (defs : state_defs sys_state_t pid_t slot_t ballot_t value_t) :
    sys_state_t → slot_t → ballot_t → Prop :=
  (λ state slot ballot,
    ∃ q : finset pid_t, defs.quorum q ∧
      ∀ voter ∈ q, defs.voted state voter slot ballot)

def chosen
  (defs : state_defs sys_state_t pid_t slot_t ballot_t value_t) :
    sys_state_t → slot_t → value_t → Prop :=
  (λ state slot value,
    ∃ ballot, defs.chosen_ballot state slot ballot ∧ defs.proposed state slot ballot value)

end state_defs

variables {sys_state_t pid_t slot_t ballot_t value_t : Type}

def state_with_past_intervals
  (defs : state_defs sys_state_t pid_t slot_t ballot_t value_t)
  (proto : protocol sys_state_t) : protocol (sys_state_t × (pid_t → slot_t → set (interval ballot_t value_t))) :=
{ init := (λ hist_state, proto.init hist_state.fst ∧
  (∀ p s, hist_state.snd p s =
        {{upper := defs.curr hist_state.fst p, lower := defs.stored hist_state.fst p s}})),
  next := (λ fst_state snd_state, proto.next fst_state.fst snd_state.fst ∧
  (∀ p s, snd_state.snd p s = fst_state.snd p s ∪
          {{upper := defs.curr snd_state.fst p, lower := defs.stored snd_state.fst p s}})) }

variables [linear_order ballot_t] [decidable_eq pid_t]

structure proto_constraints
  (proto : protocol sys_state_t)
  (defs : state_defs sys_state_t pid_t slot_t ballot_t value_t) :=
  (quorums_intersect :
    ∀ q₁ q₂, defs.quorum q₁ → defs.quorum q₂ → (q₁ ∩ q₂).nonempty)
  (none_proposed_at_init :
    ∀ state slot ballot value, proto.init state → ¬defs.proposed state slot ballot value)
  (proposed_stable :
    ∀ slot ballot value,
      proto.stable (λ state, defs.proposed state slot ballot value))
  (proposals_unique :
    ∀ slot ballot v₁ v₂,
      proto.invariant (λ state,
        defs.proposed state slot ballot v₁ → defs.proposed state slot ballot v₂ → v₁ = v₂))
  (at_most_one_proposal_per_slot_per_step :
    ∀ slot s',
      proto.invariant (λ state,
        proto.next state s' →
          ∃ b v, ∀ bal val, defs.proposed s' slot bal val →
                 (defs.proposed state slot bal val ∨ (bal = b ∧ val = v))))
  (curr_increases :
    ∀ process s',
      proto.invariant (λ state,
        proto.next state s' → defs.curr state process ≤ defs.curr s' process))
  (stored_ballot_increases :
    ∀ process slot prop s',
      proto.invariant (λ state,
        proto.next state s' →
          defs.stored state process slot = some prop →
            ∃ prop', defs.stored s' process slot = some prop' ∧ prop.b ≤ prop'.b))
  (stored_is_proposed :
    ∀ process slot prop,
      proto.invariant (λ state,
        defs.stored state process slot = some prop →
          defs.proposed state slot prop.b prop.v))
  (new_votes_ge_curr_ballot :
    ∀ process slot ballot s',
      proto.invariant (λ state,
        proto.next state s' →
          defs.voted s' process slot ballot →
            defs.voted state process slot ballot ∨ defs.curr state process ≤ ballot))
  (voted_stable :
    ∀ process slot ballot,
      proto.stable (λ state, defs.voted state process slot ballot))
  (voted_imp_proposed :
    ∀ process slot ballot,
      proto.invariant (λ state,
        defs.voted state process slot ballot →
          ∃ value, defs.proposed state slot ballot value))
  (voted_le_stored :
    ∀ process slot ballot,
      proto.invariant (λ state,
        defs.voted state process slot ballot →
          ∃ prop, defs.stored state process slot = some prop ∧ ballot ≤ prop.b))
  (majority_have_upper_interval_if_proposed :
    ∀ slot ballot value,
      (state_with_past_intervals defs proto).invariant (λ state,
        defs.proposed state.fst slot ballot value →
        ∃ (q : finset pid_t)
             (promised_prop : pid_t → option (proposal ballot_t value_t)),
          defs.quorum q ∧
          (∀ (a ∈ q),
            {interval . lower := (promised_prop a), upper := ballot} ∈ state.snd a slot) ∧
          (∀ (a ∈ q) prop_a, promised_prop a = some prop_a → prop_a.b < ballot) ∧
          ((∀ (a ∈ q), promised_prop a = none) ∨
           (∃ (a ∈ q) prop_a,
             promised_prop a = some prop_a ∧
             (∀ (a' ∈ q) prop_a', promised_prop a' = some prop_a' → prop_a'.b ≤ prop_a.b) ∧
             prop_a.v = value))))

def safety (proto : protocol sys_state_t)
  (defs : state_defs sys_state_t pid_t slot_t ballot_t value_t)
  := proto.invariant (λ state, (∀ slot v v', defs.chosen state slot v → defs.chosen state slot v' → v = v'))

def safety_v2 (proto : protocol sys_state_t)
  (defs : state_defs sys_state_t pid_t slot_t ballot_t value_t)
  := proto.invariant (λ state, (∀ later_state slot v v', proto.reachable_from state later_state →
                                  defs.chosen state slot v → defs.chosen later_state slot v' → v = v'))

end multipaxos

variables (sys_state_t pid_t slot_t ballot_t value_t : Type)
          [linear_order ballot_t] [decidable_eq pid_t] (proto : protocol sys_state_t)
          (defs : multipaxos.state_defs sys_state_t pid_t slot_t ballot_t value_t)

-- Given a multipaxos algorithm, we can restrict to a single slot to get a
-- single-instance paxos algorithm.
def slot_instance_defs (slot : slot_t): paxos_defs sys_state_t pid_t ballot_t value_t :=
{ curr := λ state p, defs.curr state p,
  stored := λ state p, defs.stored state p slot,
  proposed := λ state ballot value, defs.proposed state slot ballot value,
  voted := λ state p ballot, defs.voted state p slot ballot,
  quorum := defs.quorum }

-- The single-instance paxos algorithm obtained in this way meets the safety
-- constraints.
def slot_instance_reqs_sat (multipaxos_constraints_met : multipaxos.proto_constraints proto defs) (slot : slot_t)
  : requirements proto (slot_instance_defs sys_state_t pid_t slot_t ballot_t value_t defs slot) :=
{ quorums_intersect := multipaxos_constraints_met.quorums_intersect,
  none_proposed_at_init := λ state ballot value is_init,
    multipaxos_constraints_met.none_proposed_at_init state slot ballot value is_init,
  proposed_stable := λ ballot value,
    multipaxos_constraints_met.proposed_stable slot ballot value,
  proposals_unique := λ ballot v₁ v₂,
    multipaxos_constraints_met.proposals_unique slot ballot v₁ v₂,
  at_most_one_proposal_per_step := λ s',
    multipaxos_constraints_met.at_most_one_proposal_per_slot_per_step slot s',
  curr_increases := multipaxos_constraints_met.curr_increases,
  stored_ballot_increases := λ process prop s',
    multipaxos_constraints_met.stored_ballot_increases process slot prop s',
  stored_is_proposed := λ process prop,
    multipaxos_constraints_met.stored_is_proposed process slot prop,
  new_votes_ge_curr_ballot := λ process ballot s',
    multipaxos_constraints_met.new_votes_ge_curr_ballot process slot ballot s',
  voted_stable := λ process ballot,
    multipaxos_constraints_met.voted_stable process slot ballot,
  voted_imp_proposed := λ process ballot,
    multipaxos_constraints_met.voted_imp_proposed process slot ballot,
  voted_le_stored := λ process ballot,
    multipaxos_constraints_met.voted_le_stored process slot ballot,
  majority_have_upper_interval_if_proposed := by {
    suffices key : (proto_with_intervals_recorded (slot_instance_defs sys_state_t pid_t slot_t ballot_t value_t defs slot) proto).invariant
      (λ restricted_state,
        ∃ full_state, (multipaxos.state_with_past_intervals defs proto).reachable full_state ∧
                      full_state.fst = restricted_state.fst ∧
                      restricted_state.snd = λ p, full_state.snd p slot),
    by {
      intros ballot value state reachable,
      rcases key state reachable
        with ⟨lift_state, lift_reachable, lift_state_is_lift, lift_snd_restriction_gives_snd⟩,
      rw lift_snd_restriction_gives_snd, rw ← lift_state_is_lift,
      exact multipaxos_constraints_met.majority_have_upper_interval_if_proposed
        slot ballot value lift_state lift_reachable,
    },
    rw protocol.prove_invariant,
    split,
    { intros s is_init,
      use ⟨s.fst, (λ p slot, {{upper := defs.curr s.fst p, lower := defs.stored s.fst p slot}})⟩,
      split,
      { exact ⟨0, is_init.left, by { intros p slot, refl }⟩ },
      split,
      { refl },
      rw function.funext_iff,
      exact is_init.right },
    rintros start start_reachable next ⟨lift_start, lift_reachable, lift_start_is_lift, lift_snd_restriction_gives_snd⟩ next_reachable,
    use ⟨next.fst, λ p s, lift_start.snd p s ∪
                       {{upper := defs.curr next.fst p, lower := defs.stored next.fst p s}}⟩,
    split,
    { rcases lift_reachable with ⟨n, hn⟩,
      exact ⟨n.succ, lift_start, hn, by { rw lift_start_is_lift, exact next_reachable.left },
            by { intros p s, refl }⟩ },
    split,
    { refl },
    rw function.funext_iff, intro p,
    rw next_reachable.right p, unfold prod.snd,
    rw lift_snd_restriction_gives_snd,
    unfold slot_instance_defs
  } }

theorem constraints_give_safety : multipaxos.proto_constraints proto defs → multipaxos.safety proto defs :=
begin
intro multipaxos_constraints_met,
suffices key : ∀ slot, proto.invariant (λ state, (∀ v v', defs.chosen state slot v → defs.chosen state slot v' → v = v')),
by { intros state reachable slot, exact key slot state reachable },
intro slot,
exact requirements_give_safety (slot_instance_reqs_sat sys_state_t pid_t slot_t ballot_t value_t proto defs multipaxos_constraints_met slot)
end

theorem constraints_give_safety_v2 : multipaxos.proto_constraints proto defs → multipaxos.safety_v2 proto defs :=
begin
intro multipaxos_constraints_met,
suffices key : ∀ slot, proto.invariant (λ state, (∀ later_state v v', proto.reachable_from state later_state →
                                                    defs.chosen state slot v → defs.chosen later_state slot v' → v = v')),
by { intros state reachable later_state slot, exact key slot state reachable later_state },
intro slot,
exact requirements_give_safety_v2 (slot_instance_reqs_sat sys_state_t pid_t slot_t ballot_t value_t proto defs multipaxos_constraints_met slot)
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

! This file was ported from Lean 3 source module logic.nonempty
! leanprover-community/mathlib commit d2d8742b0c21426362a9dacebc6005db895ca963
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Init.ZeroOne
import Mathlib.Logic.Basic

/-!
# Nonempty types

This file proves a few extra facts about `Nonempty`, which is defined in core Lean.

## Main declarations

* `Nonempty.some`: Extracts a witness of nonemptiness using choice. Takes `Nonempty α` explicitly.
* `Classical.arbitrary`: Extracts a witness of nonemptiness using choice. Takes `Nonempty α` as an
  instance.
-/

variable {γ : α → Type _}

instance (priority := 20) Zero.nonempty [Zero α] : Nonempty α :=
  ⟨0⟩

instance (priority := 20) One.nonempty [One α] : Nonempty α :=
  ⟨1⟩

theorem exists_true_iff_nonempty {α : Sort _} : (∃ _ : α, True) ↔ Nonempty α :=
  Iff.intro (fun ⟨a, _⟩ ↦ ⟨a⟩) fun ⟨a⟩ ↦ ⟨a, trivial⟩
#align exists_true_iff_nonempty exists_true_iff_nonempty

@[simp]
theorem nonempty_Prop {p : Prop} : Nonempty p ↔ p :=
  Iff.intro (fun ⟨h⟩ ↦ h) fun h ↦ ⟨h⟩
#align nonempty_Prop nonempty_Prop

theorem not_nonempty_iff_imp_false {α : Sort _} : ¬Nonempty α ↔ α → False :=
  ⟨fun h a ↦ h ⟨a⟩, fun h ⟨a⟩ ↦ h a⟩
#align not_nonempty_iff_imp_false not_nonempty_iff_imp_false

@[simp]
theorem nonempty_sigma : Nonempty (Σa : α, γ a) ↔ ∃ a : α, Nonempty (γ a) :=
  Iff.intro (fun ⟨⟨a, c⟩⟩ ↦ ⟨a, ⟨c⟩⟩) fun ⟨a, ⟨c⟩⟩ ↦ ⟨⟨a, c⟩⟩
#align nonempty_sigma nonempty_sigma

@[simp]
theorem nonempty_psigma {α} {β : α → Sort _} : Nonempty (PSigma β) ↔ ∃ a : α, Nonempty (β a) :=
  Iff.intro (fun ⟨⟨a, c⟩⟩ ↦ ⟨a, ⟨c⟩⟩) fun ⟨a, ⟨c⟩⟩ ↦ ⟨⟨a, c⟩⟩
#align nonempty_psigma nonempty_psigma

@[simp]
theorem nonempty_subtype {α} {p : α → Prop} : Nonempty (Subtype p) ↔ ∃ a : α, p a :=
  Iff.intro (fun ⟨⟨a, h⟩⟩ ↦ ⟨a, h⟩) fun ⟨a, h⟩ ↦ ⟨⟨a, h⟩⟩
#align nonempty_subtype nonempty_subtype

@[simp]
theorem nonempty_prod : Nonempty (α × β) ↔ Nonempty α ∧ Nonempty β :=
  Iff.intro (fun ⟨⟨a, b⟩⟩ ↦ ⟨⟨a⟩, ⟨b⟩⟩) fun ⟨⟨a⟩, ⟨b⟩⟩ ↦ ⟨⟨a, b⟩⟩
#align nonempty_prod nonempty_prod

@[simp]
theorem nonempty_pprod {α β} : Nonempty (PProd α β) ↔ Nonempty α ∧ Nonempty β :=
  Iff.intro (fun ⟨⟨a, b⟩⟩ ↦ ⟨⟨a⟩, ⟨b⟩⟩) fun ⟨⟨a⟩, ⟨b⟩⟩ ↦ ⟨⟨a, b⟩⟩
#align nonempty_pprod nonempty_pprod

@[simp]
theorem nonempty_sum : Nonempty (Sum α β) ↔ Nonempty α ∨ Nonempty β :=
  Iff.intro
    (fun ⟨h⟩ ↦
      match h with
      | Sum.inl a => Or.inl ⟨a⟩
      | Sum.inr b => Or.inr ⟨b⟩)
    fun h ↦
    match h with
    | Or.inl ⟨a⟩ => ⟨Sum.inl a⟩
    | Or.inr ⟨b⟩ => ⟨Sum.inr b⟩
#align nonempty_sum nonempty_sum

@[simp]
theorem nonempty_psum {α β} : Nonempty (PSum α β) ↔ Nonempty α ∨ Nonempty β :=
  Iff.intro
    (fun ⟨h⟩ ↦
      match h with
      | PSum.inl a => Or.inl ⟨a⟩
      | PSum.inr b => Or.inr ⟨b⟩)
    fun h ↦
    match h with
    | Or.inl ⟨a⟩ => ⟨PSum.inl a⟩
    | Or.inr ⟨b⟩ => ⟨PSum.inr b⟩
#align nonempty_psum nonempty_psum

@[simp]
theorem nonempty_ulift : Nonempty (ULift α) ↔ Nonempty α :=
  Iff.intro (fun ⟨⟨a⟩⟩ ↦ ⟨a⟩) fun ⟨a⟩ ↦ ⟨⟨a⟩⟩
#align nonempty_ulift nonempty_ulift

@[simp]
theorem nonempty_plift {α} : Nonempty (PLift α) ↔ Nonempty α :=
  Iff.intro (fun ⟨⟨a⟩⟩ ↦ ⟨a⟩) fun ⟨a⟩ ↦ ⟨⟨a⟩⟩
#align nonempty_plift nonempty_plift

@[simp]
theorem Nonempty.forall {α} {p : Nonempty α → Prop} : (∀ h : Nonempty α, p h) ↔ ∀ a, p ⟨a⟩ :=
  Iff.intro (fun h _ ↦ h _) fun h ⟨a⟩ ↦ h a
#align nonempty.forall Nonempty.forall

@[simp]
theorem Nonempty.exists {α} {p : Nonempty α → Prop} : (∃ h : Nonempty α, p h) ↔ ∃ a, p ⟨a⟩ :=
  Iff.intro (fun ⟨⟨a⟩, h⟩ ↦ ⟨a, h⟩) fun ⟨a, h⟩ ↦ ⟨⟨a⟩, h⟩
#align nonempty.exists Nonempty.exists

/-- Using `Classical.choice`, lifts a (`Prop`-valued) `Nonempty` instance to a (`Type`-valued)
  `Inhabited` instance. `Classical.inhabited_of_nonempty` already exists, in
  `Init/Classical.lean`, but the assumption is not a type class argument,
  which makes it unsuitable for some applications. -/
noncomputable def Classical.inhabited_of_nonempty' {α} [h : Nonempty α] : Inhabited α :=
  ⟨Classical.choice h⟩
#align classical.inhabited_of_nonempty' Classical.inhabited_of_nonempty'

/-- Using `Classical.choice`, extracts a term from a `Nonempty` type. -/
@[reducible]
protected noncomputable def Nonempty.some {α} (h : Nonempty α) : α :=
  Classical.choice h
#align nonempty.some Nonempty.some

/-- Using `Classical.choice`, extracts a term from a `Nonempty` type. -/
@[reducible]
protected noncomputable def Classical.arbitrary (α) [h : Nonempty α] : α :=
  Classical.choice h
#align classical.arbitrary Classical.arbitrary

/-- Given `f : α → β`, if `α` is nonempty then `β` is also nonempty.
  `Nonempty` cannot be a `functor`, because `Functor` is restricted to `Type`. -/
theorem Nonempty.map {α β} (f : α → β) : Nonempty α → Nonempty β
  | ⟨h⟩ => ⟨f h⟩
#align nonempty.map Nonempty.map

protected theorem Nonempty.map2 {α β γ : Sort _} (f : α → β → γ) :
    Nonempty α → Nonempty β → Nonempty γ
  | ⟨x⟩, ⟨y⟩ => ⟨f x y⟩
#align nonempty.map2 Nonempty.map2

protected theorem Nonempty.congr {α β} (f : α → β) (g : β → α) : Nonempty α ↔ Nonempty β :=
  ⟨Nonempty.map f, Nonempty.map g⟩
#align nonempty.congr Nonempty.congr

theorem Nonempty.elim_to_inhabited {α : Sort _} [h : Nonempty α] {p : Prop} (f : Inhabited α → p) :
    p :=
  h.elim <| f ∘ Inhabited.mk
#align nonempty.elim_to_inhabited Nonempty.elim_to_inhabited

protected instance Prod.Nonempty {α β} [h : Nonempty α] [h2 : Nonempty β] : Nonempty (α × β) :=
  h.elim fun g ↦ h2.elim fun g2 ↦ ⟨⟨g, g2⟩⟩

protected instance Pi.Nonempty {ι : Sort _} {α : ι → Sort _} [∀ i, Nonempty (α i)] :
    Nonempty (∀ i, α i) :=
  ⟨fun _ ↦ Classical.arbitrary _⟩

theorem Classical.nonempty_pi {ι} {α : ι → Sort _} : Nonempty (∀ i, α i) ↔ ∀ i, Nonempty (α i) :=
  ⟨fun ⟨f⟩ a ↦ ⟨f a⟩, @Pi.Nonempty _ _⟩
#align classical.nonempty_pi Classical.nonempty_pi

theorem subsingleton_of_not_nonempty {α : Sort _} (h : ¬Nonempty α) : Subsingleton α :=
  ⟨fun x ↦ False.elim <| not_nonempty_iff_imp_false.mp h x⟩
#align subsingleton_of_not_nonempty subsingleton_of_not_nonempty

theorem Function.Surjective.nonempty [h : Nonempty β] {f : α → β} (hf : Function.Surjective f) :
      Nonempty α :=
  let ⟨y⟩ := h
  let ⟨x, _⟩ := hf y
  ⟨x⟩
#align function.surjective.nonempty Function.Surjective.nonempty