/-
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 Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.group_theory.submonoid.basic
import Mathlib.algebra.big_operators.basic
import Mathlib.PostPort

universes u_2 l u_1

namespace Mathlib

/-!
# 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
-/

/-- `s` is an additive submonoid: a set containing 0 and closed under addition. -/
class is_add_submonoid {A : Type u_2} [add_monoid A] (s : set A) where
  zero_mem : 0 ∈ s
  add_mem : ∀ {a b : A}, a ∈ s → b ∈ s → a + b ∈ s

/-- `s` is a submonoid: a set containing 1 and closed under multiplication. -/
class is_submonoid {M : Type u_1} [monoid M] (s : set M) where
  one_mem : 1 ∈ s
  mul_mem : ∀ {a b : M}, a ∈ s → b ∈ s → a * b ∈ s

theorem additive.is_add_submonoid {M : Type u_1} [monoid M] (s : set M) [is_submonoid s] :
    is_add_submonoid s :=
  is_submonoid.dcases_on _inst_3
    fun (one_mem : 1 ∈ s) (mul_mem : ∀ {a b : M}, a ∈ s → b ∈ s → a * b ∈ s) =>
      idRhs (is_add_submonoid s) (is_add_submonoid.mk one_mem mul_mem)

theorem additive.is_add_submonoid_iff {M : Type u_1} [monoid M] {s : set M} :
    is_add_submonoid s ↔ is_submonoid s :=
  sorry

theorem multiplicative.is_submonoid {A : Type u_2} [add_monoid A] (s : set A) [is_add_submonoid s] :
    is_submonoid s :=
  is_add_submonoid.dcases_on _inst_3
    fun (zero_mem : 0 ∈ s) (add_mem : ∀ {a b : A}, a ∈ s → b ∈ s → a + b ∈ s) =>
      idRhs (is_submonoid s) (is_submonoid.mk zero_mem add_mem)

theorem multiplicative.is_submonoid_iff {A : Type u_2} [add_monoid A] {s : set A} :
    is_submonoid s ↔ is_add_submonoid s :=
  sorry

/-- The intersection of two submonoids of a monoid `M` is a submonoid of `M`. -/
protected instance is_submonoid.inter {M : Type u_1} [monoid M] (s₁ : set M) (s₂ : set M)
    [is_submonoid s₁] [is_submonoid s₂] : is_submonoid (s₁ ∩ s₂) :=
  is_submonoid.mk { left := is_submonoid.one_mem, right := is_submonoid.one_mem }
    fun (x y : M) (hx : x ∈ s₁ ∩ s₂) (hy : y ∈ s₁ ∩ s₂) =>
      { left := is_submonoid.mul_mem (and.left hx) (and.left hy),
        right := is_submonoid.mul_mem (and.right hx) (and.right hy) }

/-- The intersection of an indexed set of submonoids of a monoid `M` is a submonoid of `M`. -/
protected instance is_add_submonoid.Inter {M : Type u_1} [add_monoid M] {ι : Sort u_2}
    (s : ι → set M) [h : ∀ (y : ι), is_add_submonoid (s y)] : is_add_submonoid (set.Inter s) :=
  is_add_submonoid.mk (iff.mpr set.mem_Inter fun (y : ι) => is_add_submonoid.zero_mem)
    fun (x₁ x₂ : M) (h₁ : x₁ ∈ set.Inter s) (h₂ : x₂ ∈ set.Inter s) =>
      iff.mpr set.mem_Inter
        fun (y : ι) =>
          is_add_submonoid.add_mem (iff.mp set.mem_Inter h₁ y) (iff.mp set.mem_Inter h₂ y)

/-- The union of an indexed, directed, nonempty set of submonoids of a monoid `M` is a submonoid
    of `M`. -/
theorem is_add_submonoid_Union_of_directed {M : Type u_1} [add_monoid M] {ι : Type u_2}
    [hι : Nonempty ι] (s : ι → set M) [∀ (i : ι), is_add_submonoid (s i)]
    (directed : ∀ (i j : ι), ∃ (k : ι), s i ⊆ s k ∧ s j ⊆ s k) :
    is_add_submonoid (set.Union fun (i : ι) => s i) :=
  sorry

/-- The set of natural number powers `1, x, x², ...` of an element `x` of a monoid. -/
/-- The set of natural number multiples `0, x, 2x, ...` of an element `x` of an `add_monoid`. -/
def powers {M : Type u_1} [monoid M] (x : M) : set M := set_of fun (y : M) => ∃ (n : ℕ), x ^ n = y

def multiples {A : Type u_2} [add_monoid A] (x : A) : set A :=
  set_of fun (y : A) => ∃ (n : ℕ), n •ℕ x = y

/-- 1 is in the set of natural number powers of an element of a monoid. -/
theorem powers.one_mem {M : Type u_1} [monoid M] {x : M} : 1 ∈ powers x :=
  Exists.intro 0 (pow_zero x)

/-- 0 is in the set of natural number multiples of an element of an `add_monoid`. -/
theorem multiples.zero_mem {A : Type u_2} [add_monoid A] {x : A} : 0 ∈ multiples x :=
  Exists.intro 0 (zero_nsmul x)

/-- An element of a monoid is in the set of that element's natural number powers. -/
theorem powers.self_mem {M : Type u_1} [monoid M] {x : M} : x ∈ powers x :=
  Exists.intro 1 (pow_one x)

/-- An element of an `add_monoid` is in the set of that element's natural number multiples. -/
theorem multiples.self_mem {A : Type u_2} [add_monoid A] {x : A} : x ∈ multiples x :=
  Exists.intro 1 (one_nsmul x)

/-- The set of natural number powers of an element of a monoid is closed under multiplication. -/
theorem powers.mul_mem {M : Type u_1} [monoid M] {x : M} {y : M} {z : M} :
    y ∈ powers x → z ∈ powers x → y * z ∈ powers x :=
  sorry

/-- The set of natural number multiples of an element of an `add_monoid` is closed under
    addition. -/
theorem multiples.add_mem {A : Type u_2} [add_monoid A] {x : A} {y : A} {z : A} :
    y ∈ multiples x → z ∈ multiples x → y + z ∈ multiples x :=
  powers.mul_mem

/-- The set of natural number powers of an element of a monoid `M` is a submonoid of `M`. -/
protected instance multiples.is_add_submonoid {M : Type u_1} [add_monoid M] (x : M) :
    is_add_submonoid (multiples x) :=
  is_add_submonoid.mk multiples.zero_mem fun (y z : M) => multiples.add_mem

/-- A monoid is a submonoid of itself. -/
protected instance univ.is_submonoid {M : Type u_1} [monoid M] : is_submonoid set.univ :=
  is_submonoid.mk
    (eq.mpr (id (propext ((fun {α : Type u_1} (x : α) => iff_true_intro (set.mem_univ x)) 1)))
      trivial)
    (eq.mpr
      (id
        (Eq.trans
          (Eq.trans
            (forall_congr_eq
              fun (a : M) =>
                forall_congr_eq
                  fun (b : M) =>
                    Eq.trans
                      (imp_congr_eq
                        (propext
                          ((fun {α : Type u_1} (x : α) => iff_true_intro (set.mem_univ x)) a))
                        (Eq.trans
                          (imp_congr_eq
                            (propext
                              ((fun {α : Type u_1} (x : α) => iff_true_intro (set.mem_univ x)) b))
                            (propext
                              ((fun {α : Type u_1} (x : α) => iff_true_intro (set.mem_univ x))
                                (a * b))))
                          (propext (forall_prop_of_true True.intro))))
                      (propext (forall_prop_of_true True.intro)))
            (propext (forall_const M)))
          (propext (forall_const M))))
      trivial)

/-- The preimage of a submonoid under a monoid hom is a submonoid of the domain. -/
protected instance preimage.is_add_submonoid {M : Type u_1} [add_monoid M] {N : Type u_2}
    [add_monoid N] (f : M → N) [is_add_monoid_hom f] (s : set N) [is_add_submonoid s] :
    is_add_submonoid (f ⁻¹' s) :=
  is_add_submonoid.mk
    ((fun (this : f 0 ∈ s) => this)
      (eq.mpr (id (Eq._oldrec (Eq.refl (f 0 ∈ s)) (is_add_monoid_hom.map_zero f)))
        is_add_submonoid.zero_mem))
    fun (a b : M) (ha : f a ∈ s) (hb : f b ∈ s) =>
      (fun (this : f (a + b) ∈ s) => this)
        (eq.mpr (id (Eq._oldrec (Eq.refl (f (a + b) ∈ s)) (is_add_monoid_hom.map_add f a b)))
          (is_add_submonoid.add_mem ha hb))

/-- The image of a submonoid under a monoid hom is a submonoid of the codomain. -/
instance image.is_add_submonoid {M : Type u_1} [add_monoid M] {γ : Type u_2} [add_monoid γ]
    (f : M → γ) [is_add_monoid_hom f] (s : set M) [is_add_submonoid s] :
    is_add_submonoid (f '' s) :=
  sorry

/-- The image of a monoid hom is a submonoid of the codomain. -/
protected instance range.is_add_submonoid {M : Type u_1} [add_monoid M] {γ : Type u_2}
    [add_monoid γ] (f : M → γ) [is_add_monoid_hom f] : is_add_submonoid (set.range f) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (is_add_submonoid (set.range f))) (Eq.symm set.image_univ)))
    (image.is_add_submonoid f set.univ)

/-- Submonoids are closed under natural powers. -/
theorem is_submonoid.pow_mem {M : Type u_1} [monoid M] {s : set M} {a : M} [is_submonoid s]
    (h : a ∈ s) {n : ℕ} : a ^ n ∈ s :=
  sorry

/-- An `add_submonoid` is closed under multiplication by naturals. -/
theorem is_add_submonoid.smul_mem {A : Type u_2} [add_monoid A] {t : set A} {a : A}
    [is_add_submonoid t] (h : a ∈ t) {n : ℕ} : n •ℕ a ∈ t :=
  is_submonoid.pow_mem

/-- The set of natural number powers of an element of a submonoid is a subset of the submonoid. -/
theorem is_submonoid.power_subset {M : Type u_1} [monoid M] {s : set M} {a : M} [is_submonoid s]
    (h : a ∈ s) : powers a ⊆ s :=
  sorry

/-- The set of natural number multiples of an element of an `add_submonoid` is a subset of the
    `add_submonoid`. -/
theorem is_add_submonoid.multiple_subset {A : Type u_2} [add_monoid A] {t : set A} {a : A}
    [is_add_submonoid t] : a ∈ t → multiples a ⊆ t :=
  is_submonoid.power_subset

namespace is_submonoid

/-- The product of a list of elements of a submonoid is an element of the submonoid. -/
theorem list_prod_mem {M : Type u_1} [monoid M] {s : set M} [is_submonoid s] {l : List M} :
    (∀ (x : M), x ∈ l → x ∈ s) → list.prod l ∈ s :=
  sorry

/-- The product of a multiset of elements of a submonoid of a `comm_monoid` is an element of
the submonoid. -/
theorem Mathlib.is_add_submonoid.multiset_sum_mem {M : Type u_1} [add_comm_monoid M] (s : set M)
    [is_add_submonoid s] (m : multiset M) : (∀ (a : M), a ∈ m → a ∈ s) → multiset.sum m ∈ s :=
  sorry

/-- The product of elements of a submonoid of a `comm_monoid` indexed by a `finset` is an element
of the submonoid. -/
theorem finset_prod_mem {M : Type u_1} {A : Type u_2} [comm_monoid M] (s : set M) [is_submonoid s]
    (f : A → M) (t : finset A) :
    (∀ (b : A), b ∈ t → f b ∈ s) → (finset.prod t fun (b : A) => f b) ∈ s :=
  sorry

end is_submonoid

-- TODO: modify `subtype_instance` to produce this definition, then use it here

--  and for `subtype.group`

/-- Submonoids are themselves monoids. -/
def subtype.add_monoid {M : Type u_1} [add_monoid M] {s : set M} [is_add_submonoid s] :
    add_monoid ↥s :=
  add_monoid.mk (fun (x y : ↥s) => { val := ↑x + ↑y, property := sorry }) sorry
    { val := 0, property := is_add_submonoid.zero_mem } sorry sorry

/-- Submonoids of commutative monoids are themselves commutative monoids. -/
def subtype.add_comm_monoid {M : Type u_1} [add_comm_monoid M] {s : set M} [is_add_submonoid s] :
    add_comm_monoid ↥s :=
  add_comm_monoid.mk add_monoid.add sorry add_monoid.zero sorry sorry sorry

/-- Submonoids inherit the 1 of the monoid. -/
@[simp] theorem is_submonoid.coe_one {M : Type u_1} [monoid M] {s : set M} [is_submonoid s] :
    ↑1 = 1 :=
  rfl

/-- Submonoids inherit the multiplication of the monoid. -/
@[simp] theorem is_add_submonoid.coe_add {M : Type u_1} [add_monoid M] {s : set M}
    [is_add_submonoid s] (a : ↥s) (b : ↥s) : ↑(a + b) = ↑a + ↑b :=
  rfl

/-- Submonoids inherit the exponentiation by naturals of the monoid. -/
@[simp] theorem is_submonoid.coe_pow {M : Type u_1} [monoid M] {s : set M} [is_submonoid s] (a : ↥s)
    (n : ℕ) : ↑(a ^ n) = ↑a ^ n :=
  sorry

/-- An `add_submonoid` inherits the multiplication by naturals of the `add_monoid`. -/
@[simp] theorem is_add_submonoid.smul_coe {A : Type u_1} [add_monoid A] {s : set A}
    [is_add_submonoid s] (a : ↥s) (n : ℕ) : ↑(n •ℕ a) = n •ℕ ↑a :=
  sorry

/-- The natural injection from a submonoid into the monoid is a monoid hom. -/
protected instance subtype_val.is_add_monoid_hom {M : Type u_1} [add_monoid M] {s : set M}
    [is_add_submonoid s] : is_add_monoid_hom subtype.val :=
  is_add_monoid_hom.mk rfl

/-- The natural injection from a submonoid into the monoid is a monoid hom. -/
protected instance coe.is_add_monoid_hom {M : Type u_1} [add_monoid M] {s : set M}
    [is_add_submonoid s] : is_add_monoid_hom coe :=
  subtype_val.is_add_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. -/
protected instance subtype_mk.is_add_monoid_hom {M : Type u_1} [add_monoid M] {s : set M}
    {γ : Type u_2} [add_monoid γ] [is_add_submonoid s] (f : γ → M) [is_add_monoid_hom f]
    (h : ∀ (x : γ), f x ∈ s) : is_add_monoid_hom fun (x : γ) => { val := f x, property := h x } :=
  is_add_monoid_hom.mk (subtype.eq (is_add_monoid_hom.map_zero f))

/-- Given two submonoids `s` and `t` such that `s ⊆ t`, the natural injection from `s` into `t` is
    a monoid hom. -/
protected instance set_inclusion.is_monoid_hom {M : Type u_1} [monoid M] {s : set M} (t : set M)
    [is_submonoid s] [is_submonoid t] (h : s ⊆ t) : is_monoid_hom (set.inclusion h) :=
  subtype_mk.is_monoid_hom (fun (x : ↥s) => ↑x) fun (x : ↥s) => set.inclusion._proof_1 h x

namespace add_monoid

/-- The inductively defined membership predicate for the submonoid generated by a subset of a
    monoid. -/
inductive in_closure {A : Type u_2} [add_monoid A] (s : set A) : A → Prop where
| basic : ∀ {a : A}, a ∈ s → in_closure s a
| zero : in_closure s 0
| add : ∀ {a b : A}, in_closure s a → in_closure s b → in_closure s (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 {M : Type u_1} [monoid M] (s : set M) : M → Prop where
| basic : ∀ {a : M}, a ∈ s → in_closure s a
| one : in_closure s 1
| mul : ∀ {a b : M}, in_closure s a → in_closure s b → in_closure s (a * b)

/-- The inductively defined submonoid generated by a subset of a monoid. -/
def Mathlib.add_monoid.closure {M : Type u_1} [add_monoid M] (s : set M) : set M :=
  set_of fun (a : M) => add_monoid.in_closure s a

protected instance Mathlib.add_monoid.closure.is_add_submonoid {M : Type u_1} [add_monoid M]
    (s : set M) : is_add_submonoid (add_monoid.closure s) :=
  is_add_submonoid.mk add_monoid.in_closure.zero fun (a b : M) => add_monoid.in_closure.add

/-- A subset of a monoid is contained in the submonoid it generates. -/
theorem Mathlib.add_monoid.subset_closure {M : Type u_1} [add_monoid M] {s : set M} :
    s ⊆ add_monoid.closure s :=
  fun (a : M) => add_monoid.in_closure.basic

/-- The submonoid generated by a set is contained in any submonoid that contains the set. -/
theorem Mathlib.add_monoid.closure_subset {M : Type u_1} [add_monoid M] {s : set M} {t : set M}
    [is_add_submonoid t] (h : s ⊆ t) : add_monoid.closure s ⊆ t :=
  sorry

/-- 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`. -/
theorem Mathlib.add_monoid.closure_mono {M : Type u_1} [add_monoid M] {s : set M} {t : set M}
    (h : s ⊆ t) : add_monoid.closure s ⊆ add_monoid.closure t :=
  add_monoid.closure_subset (set.subset.trans h add_monoid.subset_closure)

/-- The submonoid generated by an element of a monoid equals the set of natural number powers of
    the element. -/
theorem closure_singleton {M : Type u_1} [monoid M] {x : M} : closure (singleton x) = powers x :=
  set.eq_of_subset_of_subset (closure_subset (iff.mpr set.singleton_subset_iff powers.self_mem))
    (is_submonoid.power_subset (iff.mp set.singleton_subset_iff 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. -/
theorem Mathlib.add_monoid.image_closure {M : Type u_1} [add_monoid M] {A : Type u_2} [add_monoid A]
    (f : M → A) [is_add_monoid_hom f] (s : set M) :
    f '' add_monoid.closure s = add_monoid.closure (f '' s) :=
  sorry

/-- 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`. -/
theorem Mathlib.add_monoid.exists_list_of_mem_closure {M : Type u_1} [add_monoid M] {s : set M}
    {a : M} (h : a ∈ add_monoid.closure s) :
    ∃ (l : List M), (∀ (x : M), x ∈ l → x ∈ s) ∧ list.sum l = a :=
  sorry

/-- 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`. -/
theorem Mathlib.add_monoid.mem_closure_union_iff {M : Type u_1} [add_comm_monoid M] {s : set M}
    {t : set M} {x : M} :
    x ∈ add_monoid.closure (s ∪ t) ↔
        ∃ (y : M),
          ∃ (H : y ∈ add_monoid.closure s),
            ∃ (z : M), ∃ (H : z ∈ add_monoid.closure t), y + z = x :=
  sorry

end monoid

/-- Create a bundled submonoid from a set `s` and `[is_submonoid s]`. -/
def add_submonoid.of {M : Type u_1} [add_monoid M] (s : set M) [h : is_add_submonoid s] :
    add_submonoid M :=
  add_submonoid.mk s is_add_submonoid.zero_mem is_add_submonoid.add_mem

protected instance submonoid.is_submonoid {M : Type u_1} [monoid M] (S : submonoid M) :
    is_submonoid ↑S :=
  is_submonoid.mk (submonoid.one_mem' S) (submonoid.mul_mem' S)

end Mathlib


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

/-!
# Chains and flags

This file defines chains for an arbitrary relation and flags for an order and proves Hausdorff's
Maximality Principle.

## Main declarations

* `is_chain s`: A chain `s` is a set of comparable elements.
* `max_chain_spec`: Hausdorff's Maximality Principle.
* `flag`: The type of flags, aka maximal chains, of an order.

## Notes

Originally ported from Isabelle/HOL. The
[original file](https://isabelle.in.tum.de/dist/library/HOL/HOL/Zorn.html) was written by Jacques D.
Fleuriot, Tobias Nipkow, Christian Sternagel.
-/

open classical set

variables {α β : Type*}

/-! ### Chains -/

section chain
variables (r : α → α → Prop)

local infix ` ≺ `:50 := r

/-- A chain is a set `s` satisfying `x ≺ y ∨ x = y ∨ y ≺ x` for all `x y ∈ s`. -/
def is_chain (s : set α) : Prop := s.pairwise (λ x y, x ≺ y ∨ y ≺ x)

/-- `super_chain s t` means that `t` is a chain that strictly includes `s`. -/
def super_chain (s t : set α) : Prop := is_chain r t ∧ s ⊂ t

/-- A chain `s` is a maximal chain if there does not exists a chain strictly including `s`. -/
def is_max_chain (s : set α) : Prop := is_chain r s ∧ ∀ ⦃t⦄, is_chain r t → s ⊆ t → s = t

variables {r} {c c₁ c₂ c₃ s t : set α} {a b x y : α}

lemma is_chain_empty : is_chain r ∅ := set.pairwise_empty _

lemma set.subsingleton.is_chain (hs : s.subsingleton) : is_chain r s := hs.pairwise _

lemma is_chain.mono : s ⊆ t → is_chain r t → is_chain r s := set.pairwise.mono

lemma is_chain.mono_rel {r' : α → α → Prop} (h : is_chain r s)
  (h_imp : ∀ x y, r x y → r' x y) : is_chain r' s :=
h.mono' $ λ x y, or.imp (h_imp x y) (h_imp y x)

/-- This can be used to turn `is_chain (≥)` into `is_chain (≤)` and vice-versa. -/
lemma is_chain.symm (h : is_chain r s) : is_chain (flip r) s := h.mono' $ λ _ _, or.symm

lemma is_chain_of_trichotomous [is_trichotomous α r] (s : set α) : is_chain r s :=
λ a _ b _ hab, (trichotomous_of r a b).imp_right $ λ h, h.resolve_left hab

lemma is_chain.insert (hs : is_chain r s) (ha : ∀ b ∈ s, a ≠ b → a ≺ b ∨ b ≺ a) :
  is_chain r (insert a s) :=
hs.insert_of_symmetric (λ _ _, or.symm) ha

lemma is_chain_univ_iff : is_chain r (univ : set α) ↔ is_trichotomous α r :=
begin
  refine ⟨λ h, ⟨λ a b , _⟩, λ h, @is_chain_of_trichotomous _ _ h univ⟩,
  rw [or.left_comm, or_iff_not_imp_left],
  exact h trivial trivial,
end

lemma is_chain.image (r : α → α → Prop) (s : β → β → Prop) (f : α → β)
  (h : ∀ x y, r x y → s (f x) (f y)) {c : set α} (hrc : is_chain r c) :
  is_chain s (f '' c) :=
λ x ⟨a, ha₁, ha₂⟩ y ⟨b, hb₁, hb₂⟩, ha₂ ▸ hb₂ ▸ λ hxy,
  (hrc ha₁ hb₁ $ ne_of_apply_ne f hxy).imp (h _ _) (h _ _)

section total
variables [is_refl α r]

lemma is_chain.total (h : is_chain r s) (hx : x ∈ s) (hy : y ∈ s) : x ≺ y ∨ y ≺ x :=
(eq_or_ne x y).elim (λ e, or.inl $ e ▸ refl _) (h hx hy)

lemma is_chain.directed_on (H : is_chain r s) : directed_on r s :=
λ x hx y hy, (H.total hx hy).elim (λ h, ⟨y, hy, h, refl _⟩) $ λ h, ⟨x, hx, refl _, h⟩

protected lemma is_chain.directed {f : β → α} {c : set β} (h : is_chain (f ⁻¹'o r) c) :
  directed r (λ x : {a : β // a ∈ c}, f x) :=
λ ⟨a, ha⟩ ⟨b, hb⟩, by_cases
  (λ hab : a = b, by simp only [hab, exists_prop, and_self, subtype.exists];
    exact ⟨b, hb, refl _⟩) $
  λ hab, (h ha hb hab).elim (λ h, ⟨⟨b, hb⟩, h, refl _⟩) $ λ h, ⟨⟨a, ha⟩, refl _, h⟩

end total

lemma is_max_chain.is_chain (h : is_max_chain r s) : is_chain r s := h.1
lemma is_max_chain.not_super_chain (h : is_max_chain r s) : ¬super_chain r s t :=
λ ht, ht.2.ne $ h.2 ht.1 ht.2.1

lemma is_max_chain.bot_mem [has_le α] [order_bot α] (h : is_max_chain (≤) s) : ⊥ ∈ s :=
(h.2 (h.1.insert $ λ a _ _, or.inl bot_le) $ subset_insert _ _).symm ▸ mem_insert _ _

lemma is_max_chain.top_mem [has_le α] [order_top α] (h : is_max_chain (≤) s) : ⊤ ∈ s :=
(h.2 (h.1.insert $ λ a _ _, or.inr le_top) $ subset_insert _ _).symm ▸ mem_insert _ _

open_locale classical

/-- Given a set `s`, if there exists a chain `t` strictly including `s`, then `succ_chain s`
is one of these chains. Otherwise it is `s`. -/
def succ_chain (r : α → α → Prop) (s : set α) : set α :=
if h : ∃ t, is_chain r s ∧ super_chain r s t then some h else s

lemma succ_chain_spec (h : ∃ t, is_chain r s ∧ super_chain r s t) :
  super_chain r s (succ_chain r s) :=
let ⟨t, hc'⟩ := h in
have is_chain r s ∧ super_chain r s (some h),
  from @some_spec _ (λ t, is_chain r s ∧ super_chain r s t) _,
by simp [succ_chain, dif_pos, h, this.right]

lemma is_chain.succ (hs : is_chain r s) : is_chain r (succ_chain r s) :=
if h : ∃ t, is_chain r s ∧ super_chain r s t then (succ_chain_spec h).1
  else by { simp [succ_chain, dif_neg, h], exact hs }

lemma is_chain.super_chain_succ_chain (hs₁ : is_chain r s) (hs₂ : ¬ is_max_chain r s) :
  super_chain r s (succ_chain r s) :=
begin
  simp [is_max_chain, not_and_distrib, not_forall_not] at hs₂,
  obtain ⟨t, ht, hst⟩ := hs₂.neg_resolve_left hs₁,
  exact succ_chain_spec ⟨t, hs₁, ht, ssubset_iff_subset_ne.2 hst⟩,
end

lemma subset_succ_chain : s ⊆ succ_chain r s :=
if h : ∃ t, is_chain r s ∧ super_chain r s t then (succ_chain_spec h).2.1
  else by simp [succ_chain, dif_neg, h, subset.rfl]

/-- Predicate for whether a set is reachable from `∅` using `succ_chain` and `⋃₀`. -/
inductive chain_closure (r : α → α → Prop) : set α → Prop
| succ : ∀ {s}, chain_closure s → chain_closure (succ_chain r s)
| union : ∀ {s}, (∀ a ∈ s, chain_closure a) → chain_closure (⋃₀ s)

/-- An explicit maximal chain. `max_chain` is taken to be the union of all sets in `chain_closure`.
-/
def max_chain (r : α → α → Prop) := ⋃₀ set_of (chain_closure r)

lemma chain_closure_empty : chain_closure r ∅ :=
have chain_closure r (⋃₀ ∅),
  from chain_closure.union $ λ a h, h.rec _,
by simpa using this

lemma chain_closure_max_chain : chain_closure r (max_chain r) := chain_closure.union $ λ s, id

private lemma chain_closure_succ_total_aux (hc₁ : chain_closure r c₁) (hc₂ : chain_closure r c₂)
  (h : ∀ ⦃c₃⦄, chain_closure r c₃ → c₃ ⊆ c₂ → c₂ = c₃ ∨ succ_chain r c₃ ⊆ c₂) :
  succ_chain r c₂ ⊆ c₁ ∨ c₁ ⊆ c₂ :=
begin
  induction hc₁,
  case succ : c₃ hc₃ ih
  { cases ih with ih ih,
    { exact or.inl (ih.trans subset_succ_chain) },
    { exact (h hc₃ ih).imp_left (λ h, h ▸ subset.rfl) } },
  case union : s hs ih
  { refine (or_iff_not_imp_left.2 $ λ hn, sUnion_subset $ λ a ha, _),
    exact (ih a ha).resolve_left (λ h, hn $ h.trans $ subset_sUnion_of_mem ha) }
end

private lemma chain_closure_succ_total (hc₁ : chain_closure r c₁) (hc₂ : chain_closure r c₂)
  (h : c₁ ⊆ c₂) :
  c₂ = c₁ ∨ succ_chain r c₁ ⊆ c₂ :=
begin
  induction hc₂ generalizing c₁ hc₁ h,
  case succ : c₂ hc₂ ih
  { refine (chain_closure_succ_total_aux hc₁ hc₂ $ λ c₁, ih).imp h.antisymm' (λ h₁, _),
    obtain rfl | h₂ := ih hc₁ h₁,
    { exact subset.rfl },
    { exact h₂.trans subset_succ_chain } },
  case union : s hs ih
  { apply or.imp_left h.antisymm',
    apply classical.by_contradiction,
    simp [not_or_distrib, sUnion_subset_iff, not_forall],
    intros c₃ hc₃ h₁ h₂,
    obtain h | h := chain_closure_succ_total_aux hc₁ (hs c₃ hc₃) (λ c₄, ih _ hc₃),
    { exact h₁ (subset_succ_chain.trans h) },
    obtain h' | h' := ih c₃ hc₃ hc₁ h,
    { exact h₁ h'.subset },
    { exact h₂ (h'.trans $ subset_sUnion_of_mem hc₃) } }
end

lemma chain_closure.total (hc₁ : chain_closure r c₁) (hc₂ : chain_closure r c₂) :
  c₁ ⊆ c₂ ∨ c₂ ⊆ c₁ :=
(chain_closure_succ_total_aux hc₂ hc₁ $ λ c₃ hc₃, chain_closure_succ_total hc₃ hc₁).imp_left
  subset_succ_chain.trans

lemma chain_closure.succ_fixpoint (hc₁ : chain_closure r c₁) (hc₂ : chain_closure r c₂)
  (hc : succ_chain r c₂ = c₂) :
  c₁ ⊆ c₂ :=
begin
  induction hc₁,
  case succ : s₁ hc₁ h
  { exact (chain_closure_succ_total hc₁ hc₂ h).elim (λ h, h ▸ hc.subset) id },
  case union : s hs ih
  { exact sUnion_subset ih }
end

lemma chain_closure.succ_fixpoint_iff (hc : chain_closure r c) :
  succ_chain r c = c ↔ c = max_chain r :=
⟨λ h, (subset_sUnion_of_mem hc).antisymm $ chain_closure_max_chain.succ_fixpoint hc h,
  λ h, subset_succ_chain.antisymm' $ (subset_sUnion_of_mem hc.succ).trans h.symm.subset⟩

lemma chain_closure.is_chain (hc : chain_closure r c) : is_chain r c :=
begin
  induction hc,
  case succ : c hc h
  { exact h.succ },
  case union : s hs h
  { change ∀ c ∈ s, is_chain r c at h,
    exact λ c₁ ⟨t₁, ht₁, (hc₁ : c₁ ∈ t₁)⟩ c₂ ⟨t₂, ht₂, (hc₂ : c₂ ∈ t₂)⟩ hneq,
      ((hs _ ht₁).total $ hs _ ht₂).elim
        (λ ht, h t₂ ht₂ (ht hc₁) hc₂ hneq)
        (λ ht, h t₁ ht₁ hc₁ (ht hc₂) hneq) }
end

/-- **Hausdorff's maximality principle**

There exists a maximal totally ordered set of `α`.
Note that we do not require `α` to be partially ordered by `r`. -/
lemma max_chain_spec : is_max_chain r (max_chain r) :=
classical.by_contradiction $ λ h,
let ⟨h₁, H⟩ := chain_closure_max_chain.is_chain.super_chain_succ_chain h in
  H.ne (chain_closure_max_chain.succ_fixpoint_iff.mpr rfl).symm

end chain

/-! ### Flags -/

/-- The type of flags, aka maximal chains, of an order. -/
structure flag (α : Type*) [has_le α] :=
(carrier : set α)
(chain' : is_chain (≤) carrier)
(max_chain' : ∀ ⦃s⦄, is_chain (≤) s → carrier ⊆ s → carrier = s)

namespace flag
section has_le
variables [has_le α] {s t : flag α} {a : α}

instance : set_like (flag α) α :=
{ coe := carrier,
  coe_injective' := λ s t h, by { cases s, cases t, congr' } }

@[ext] lemma ext : (s : set α) = t → s = t := set_like.ext'
@[simp] lemma mem_coe_iff : a ∈ (s : set α) ↔ a ∈ s := iff.rfl
@[simp] lemma coe_mk (s : set α) (h₁ h₂) : (mk s h₁ h₂ : set α) = s := rfl
@[simp] lemma mk_coe (s : flag α) : mk (s : set α) s.chain' s.max_chain' = s := ext rfl

lemma chain_le (s : flag α) : is_chain (≤) (s : set α) := s.chain'
protected lemma max_chain (s : flag α) : is_max_chain (≤) (s : set α) := ⟨s.chain_le, s.max_chain'⟩

lemma top_mem [order_top α] (s : flag α) : (⊤ : α) ∈ s := s.max_chain.top_mem
lemma bot_mem [order_bot α] (s : flag α) : (⊥ : α) ∈ s := s.max_chain.bot_mem

end has_le

section preorder
variables [preorder α] {a b : α}

protected lemma le_or_le (s : flag α) (ha : a ∈ s) (hb : b ∈ s) : a ≤ b ∨ b ≤ a :=
s.chain_le.total ha hb

instance [order_top α] (s : flag α) : order_top s := subtype.order_top s.top_mem
instance [order_bot α] (s : flag α) : order_bot s := subtype.order_bot s.bot_mem
instance [bounded_order α] (s : flag α) : bounded_order s :=
subtype.bounded_order s.bot_mem s.top_mem

end preorder

section partial_order
variables [partial_order α]

lemma chain_lt (s : flag α) : is_chain (<) (s : set α) :=
λ a ha b hb h, (s.le_or_le ha hb).imp h.lt_of_le h.lt_of_le'

instance [decidable_eq α] [@decidable_rel α (≤)] [@decidable_rel α (<)] (s : flag α) :
  linear_order s :=
{ le_total := λ a b, s.le_or_le a.2 b.2,
  decidable_eq := subtype.decidable_eq,
  decidable_le := subtype.decidable_le,
  decidable_lt := subtype.decidable_lt,
  ..subtype.partial_order _ }

end partial_order

instance [linear_order α] : unique (flag α) :=
{ default := ⟨univ, is_chain_of_trichotomous _, λ s _, s.subset_univ.antisymm'⟩,
  uniq := λ s, set_like.coe_injective $ s.3 (is_chain_of_trichotomous _) $ subset_univ _ }

end flag


section
variables {α : Type*} [semiring α]

theorem mul_two_eq_add_self (x : α) : x * 2 = x + x :=
show x * (1 + 1) = x + x, by rw [mul_add, mul_one]

theorem two_mul_eq_add_self (x : α) : 2 * x = x + x :=
show (1 + 1) * x = x + x, by rw [add_mul, one_mul]

end

namespace linear_ordered_ring
variables (α : Type*) [i : linear_ordered_ring α]
include i

lemma one_pos : (0:α) < 1 := zero_lt_one α

lemma two_pos : (0:α) < 2 := _root_.add_pos (one_pos α) (one_pos α)

variable {α}

lemma add_pos (x y : α) : 0 < x → 0 < y → 0 < x + y := _root_.add_pos

lemma succ_pos (x : α) : 0 < x → 0 < x + 1 := λ h, add_pos x 1 h (one_pos α)

-- linear_ordered_ring.mul_pos (x y : α) : 0 < x → 0 < y → 0 < x * y

lemma bit0_pos (x : α) : 0 < x → 0 < bit0 x := λ h, add_pos x x h h

lemma bit1_pos (x : α) : 0 < x → 0 < bit1 x := λ h, succ_pos (bit0 x) (bit0_pos x h)

class num_pos (x : α) := (elim : (0:α) < x)

namespace num_pos
variable {i}

@[priority 30] instance one : @num_pos α i (1:α) := ⟨one_pos α⟩
@[priority 30] instance two : @num_pos α i (2:α) := ⟨two_pos α⟩
@[priority 30] instance bit0 (x : α) [@num_pos α i x] : @num_pos α i (bit0 x) := ⟨bit0_pos x (elim x)⟩
@[priority 30] instance bit1 (x : α) [@num_pos α i x] : @num_pos α i (bit1 x) := ⟨bit1_pos x (elim x)⟩
@[priority 10] instance succ (x : α) [@num_pos α i x] : @num_pos α i (x+1) := ⟨succ_pos x (elim x)⟩
@[priority 20] instance add (x y : α) [@num_pos α i x] [@num_pos α i y] : @num_pos α i (x + y) := ⟨add_pos x y (elim x) (elim y)⟩
@[priority 30] instance mul (x y : α) [@num_pos α i x] [@num_pos α i y] : @num_pos α i (x * y) := ⟨mul_pos x y (elim x) (elim y)⟩

end num_pos

class num_nonzero (x : α) := (elim : x ≠ (0:α))

@[priority 30] instance of_pos (x : α) {i : linear_ordered_ring α} [@num_pos α i x] : num_nonzero x := ⟨ne_of_gt $ num_pos.elim x⟩

end linear_ordered_ring

theorem pos_trivial {α : Type*} [linear_ordered_ring α] (x : α) [linear_ordered_ring.num_pos x] : (0:α) < x := linear_ordered_ring.num_pos.elim x
theorem nonzero_trivial {α : Type*} [linear_ordered_ring α] (x : α) [linear_ordered_ring.num_nonzero x] : x ≠ 0 := linear_ordered_ring.num_nonzero.elim x

section
variables {α : Type*} [linear_ordered_ring α]

theorem le_of_mul_ge_mul_left {a b c : α} : c * b ≤ c * a → c < 0 → a ≤ b :=
begin
intros h hc,
have hc : -c > 0 := neg_pos_of_neg hc,
apply le_of_mul_le_mul_left _ hc,
apply le_of_neg_le_neg,
rw [neg_mul_eq_neg_mul, neg_mul_eq_neg_mul, neg_neg],
assumption,
end

theorem le_of_mul_ge_mul_right {a b c : α} : b * c ≤ a * c → c < 0 → a ≤ b :=
begin
intros h hc,
have hc : -c > 0 := neg_pos_of_neg hc,
apply le_of_mul_le_mul_right _ hc,
apply le_of_neg_le_neg,
rw [neg_mul_eq_mul_neg, neg_mul_eq_mul_neg, neg_neg],
assumption,
end

end

section
variables {α : Type*} [linear_ordered_field α]

theorem div_le_of_le_mul_of_pos {x y : α} (z : α) : x ≤ y*z → 0 < z → x/z ≤ y :=
begin
intros hm hz,
apply le_of_mul_le_mul_right _ hz,
transitivity x,
{ apply le_of_eq,
  apply div_mul_cancel,
  apply ne_of_gt,
  assumption },
{ assumption },
end

theorem le_div_of_mul_le_of_pos {x y : α} (z : α) : x*z ≤ y → 0 < z → x ≤ y/z :=
begin
intros hm hz,
apply le_of_mul_le_mul_right _ hz,
transitivity y,
{ assumption },
{ apply le_of_eq,
  symmetry,
  apply div_mul_cancel,
  apply ne_of_gt,
  assumption },
end

theorem le_div_of_mul_ge_of_neg {x y : α} (z : α) : y ≤ x*z → z < 0 → x ≤ y/z :=
begin
intros hm hz,
apply le_of_mul_ge_mul_right _ hz,
transitivity y,
{ apply le_of_eq,
  apply div_mul_cancel,
  apply ne_of_lt,
  assumption },
{ assumption },
end

theorem div_le_of_ge_mul_of_neg {x y : α} (z : α) : y*z ≤ x → z < 0 → x/z ≤ y :=
begin
intros hm hz,
apply le_of_mul_ge_mul_right _ hz,
transitivity x,
{ assumption },
{ apply le_of_eq,
  symmetry,
  apply div_mul_cancel,
  apply ne_of_lt,
  assumption },
end

end

namespace order

inductive {u} lt_cmp {α : Type u} [has_lt α] (x y : α) : Type u
| eq : x = y → lt_cmp
| lt : x < y → lt_cmp
| gt : y < x → lt_cmp

inductive {u} le_cmp {α : Type u} [has_le α] (x y : α) : Type u
| le : x ≤ y → le_cmp
| ge : y ≤ x → le_cmp

variables {α : Type*} [decidable_linear_order α]

def lt_compare (x y : α) : lt_cmp x y :=
if hlt : x < y then
lt_cmp.lt hlt
else if hgt : y < x then
lt_cmp.gt hgt
else
lt_cmp.eq $ le_antisymm (le_of_not_gt hgt) (le_of_not_gt hlt)

def le_compare (x y : α) : le_cmp x y :=
if h : x < y then
le_cmp.le (le_of_lt h)
else
le_cmp.ge (le_of_not_gt h)

@[elab_as_eliminator]
def trichotomy_on (x y : α) {C : Sort*} : (x = y → C) → (x < y → C) → (y < x → C) → C :=
λ heq hlt hgt, lt_cmp.cases_on (lt_compare x y) heq hlt hgt

@[elab_as_eliminator]
def dichotomy_on (x y : α) {C : Sort*} : (x ≤ y → C) → (y ≤ x → C) → C :=
λ hle hge, le_cmp.cases_on (le_compare x y) hle hge

end order

namespace tactic
open interactive

/--
`by_trichotomy (x, y)` splits the goal into three branches, the first assuming `x = y`,
the second assuming `x < y` and the third assuming `y < x`.

This tactic requires that terms `x` and `y` have the same type and that this type has
`decidable_linear_order` instance.
-/
meta def interactive.by_trichotomy : parse types.texpr → tactic unit :=
λ e, do {
  `(@prod.mk %%t %%.(t) %%x %%y) ← to_expr e,
  d ← to_expr ``(decidable_linear_order %%t) >>= mk_instance
    <|> fail ("cannot find decidable_linear_order instance for type " ++ to_string t),
  to_expr ``(@order.trichotomy_on %%t %%d %%x %%y) >>= apply >> skip
}

/--
`by_trichotomy (x, y)` splits the goal into two branches, the first assuming `x ≤ y`
and the second assuming `y ≤ x`.

This tactic requires that terms `x` and `y` have the same type and that this type has
`decidable_linear_order` instance.
-/
meta def interactive.by_dichotomy : parse types.texpr → tactic unit :=
λ e, do {
  `(@prod.mk %%t %%.(t) %%x %%y) ← to_expr e,
  d ← to_expr ``(decidable_linear_order %%t) >>= mk_instance
    <|> fail ("cannot find decidable_linear_order instance for " ++ to_string t),
  to_expr ``(@order.dichotomy_on %%t %%d %%x %%y) >>= apply >> skip
}

end tactic


/-
Copyright (c) 2020 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser
-/
import algebra.group_action_hom
import algebra.module.basic
import data.set_like.basic
import group_theory.group_action.basic
/-!

# Sets invariant to a `mul_action`

In this file we define `sub_mul_action R M`; a subset of a `mul_action R M` which is closed with
respect to scalar multiplication.

For most uses, typically `submodule R M` is more powerful.

## Main definitions

* `sub_mul_action.mul_action` - the `mul_action R M` transferred to the subtype.
* `sub_mul_action.mul_action'` - the `mul_action S M` transferred to the subtype when
  `is_scalar_tower S R M`.
* `sub_mul_action.is_scalar_tower` - the `is_scalar_tower S R M` transferred to the subtype.

## Tags

submodule, mul_action
-/

open function

universes u u' u'' v
variables {S : Type u'} {T : Type u''} {R : Type u} {M : Type v}

set_option old_structure_cmd true

/-- A sub_mul_action is a set which is closed under scalar multiplication.  -/
structure sub_mul_action (R : Type u) (M : Type v) [has_scalar R M] : Type v :=
(carrier : set M)
(smul_mem' : ∀ (c : R) {x : M}, x ∈ carrier → c • x ∈ carrier)

namespace sub_mul_action

variables [has_scalar R M]

instance : set_like (sub_mul_action R M) M :=
⟨sub_mul_action.carrier, λ p q h, by cases p; cases q; congr'⟩

@[simp] lemma mem_carrier {p : sub_mul_action R M} {x : M} : x ∈ p.carrier ↔ x ∈ (p : set M) :=
iff.rfl

@[ext] theorem ext {p q : sub_mul_action R M} (h : ∀ x, x ∈ p ↔ x ∈ q) : p = q := set_like.ext h

/-- Copy of a sub_mul_action with a new `carrier` equal to the old one. Useful to fix definitional
equalities.-/
protected def copy (p : sub_mul_action R M) (s : set M) (hs : s = ↑p) : sub_mul_action R M :=
{ carrier := s,
  smul_mem' := hs.symm ▸ p.smul_mem' }

@[simp] lemma coe_copy (p : sub_mul_action R M) (s : set M) (hs : s = ↑p) :
  (p.copy s hs : set M) = s := rfl

lemma copy_eq (p : sub_mul_action R M) (s : set M) (hs : s = ↑p) : p.copy s hs = p :=
set_like.coe_injective hs

instance : has_bot (sub_mul_action R M) :=
⟨{ carrier := ∅, smul_mem' := λ c, set.not_mem_empty}⟩

instance : inhabited (sub_mul_action R M) := ⟨⊥⟩

end sub_mul_action

namespace sub_mul_action

section has_scalar

variables [has_scalar R M]
variables (p : sub_mul_action R M)
variables {r : R} {x : M}

lemma smul_mem (r : R) (h : x ∈ p) : r • x ∈ p := p.smul_mem' r h

instance : has_scalar R p :=
{ smul := λ c x, ⟨c • x.1, smul_mem _ c x.2⟩ }

variables {p}
@[simp, norm_cast] lemma coe_smul (r : R) (x : p) : ((r • x : p) : M) = r • ↑x := rfl
@[simp, norm_cast] lemma coe_mk (x : M) (hx : x ∈ p) : ((⟨x, hx⟩ : p) : M) = x := rfl

variables (p)

/-- Embedding of a submodule `p` to the ambient space `M`. -/
protected def subtype : p →[R] M :=
by refine {to_fun := coe, ..}; simp [coe_smul]

@[simp] theorem subtype_apply (x : p) : p.subtype x = x := rfl

lemma subtype_eq_val : ((sub_mul_action.subtype p) : p → M) = subtype.val := rfl

end has_scalar

section mul_action

variables [monoid R] [mul_action R M]

section
variables [has_scalar S R] [has_scalar S M] [is_scalar_tower S R M]
variables (p : sub_mul_action R M)

lemma smul_of_tower_mem (s : S) {x : M} (h : x ∈ p) : s • x ∈ p :=
by { rw [←one_smul R x, ←smul_assoc], exact p.smul_mem _ h }

instance has_scalar' : has_scalar S p :=
{ smul := λ c x, ⟨c • x.1, smul_of_tower_mem _ c x.2⟩ }

instance : is_scalar_tower S R p :=
{ smul_assoc := λ s r x, subtype.ext $ smul_assoc s r ↑x }

@[simp, norm_cast] lemma coe_smul_of_tower (s : S) (x : p) : ((s • x : p) : M) = s • ↑x := rfl

@[simp] lemma smul_mem_iff' {G} [group G] [has_scalar G R] [mul_action G M]
  [is_scalar_tower G R M] (g : G) {x : M} :
  g • x ∈ p ↔ x ∈ p :=
⟨λ h, inv_smul_smul g x ▸ p.smul_of_tower_mem g⁻¹ h, p.smul_of_tower_mem g⟩

end

section
variables [monoid S] [has_scalar S R] [mul_action S M] [is_scalar_tower S R M]
variables (p : sub_mul_action R M)

/-- If the scalar product forms a `mul_action`, then the subset inherits this action -/
instance mul_action' : mul_action S p :=
{ smul := (•),
  one_smul := λ x, subtype.ext $ one_smul _ x,
  mul_smul := λ c₁ c₂ x, subtype.ext $ mul_smul c₁ c₂ x }

instance : mul_action R p := p.mul_action'

end

end mul_action

section module

variables [semiring R] [add_comm_monoid M]
variables [module R M]
variables (p : sub_mul_action R M)

lemma zero_mem (h : (p : set M).nonempty) : (0 : M) ∈ p :=
let ⟨x, hx⟩ := h in zero_smul R (x : M) ▸ p.smul_mem 0 hx

/-- If the scalar product forms a `module`, and the `sub_mul_action` is not `⊥`, then the
subset inherits the zero. -/
instance [n_empty : nonempty p] : has_zero p :=
{ zero := ⟨0, n_empty.elim $ λ x, p.zero_mem ⟨x, x.prop⟩⟩ }

end module

section add_comm_group

variables [ring R] [add_comm_group M]
variables [module R M]
variables (p p' : sub_mul_action R M)
variables {r : R} {x y : M}

lemma neg_mem (hx : x ∈ p) : -x ∈ p := by { rw ← neg_one_smul R, exact p.smul_mem _ hx }

@[simp] lemma neg_mem_iff : -x ∈ p ↔ x ∈ p :=
⟨λ h, by { rw ←neg_neg x, exact neg_mem _ h}, neg_mem _⟩

instance : has_neg p := ⟨λx, ⟨-x.1, neg_mem _ x.2⟩⟩

@[simp, norm_cast] lemma coe_neg (x : p) : ((-x : p) : M) = -x := rfl

end add_comm_group

end sub_mul_action

namespace sub_mul_action

variables [division_ring S] [semiring R] [mul_action R M]
variables [has_scalar S R] [mul_action S M] [is_scalar_tower S R M]
variables (p : sub_mul_action R M) {s : S} {x y : M}

theorem smul_mem_iff (s0 : s ≠ 0) : s • x ∈ p ↔ x ∈ p :=
p.smul_mem_iff' (units.mk0 s s0)

end sub_mul_action


/-
Copyright (c) 2019 Reid Barton. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Patrick Massot, Sébastien Gouëzel, Zhouhang Zhou, Reid Barton
-/
import topology.dense_embedding

open set filter
open_locale topological_space

variables {α : Type*} {β : Type*} {γ : Type*} {δ : Type*}

/-- Homeomorphism between `α` and `β`, also called topological isomorphism -/
@[nolint has_inhabited_instance] -- not all spaces are homeomorphic to each other
structure homeomorph (α : Type*) (β : Type*) [topological_space α] [topological_space β]
  extends α ≃ β :=
(continuous_to_fun  : continuous to_fun . tactic.interactive.continuity')
(continuous_inv_fun : continuous inv_fun . tactic.interactive.continuity')

infix ` ≃ₜ `:25 := homeomorph

namespace homeomorph
variables [topological_space α] [topological_space β] [topological_space γ] [topological_space δ]

instance : has_coe_to_fun (α ≃ₜ β) := ⟨λ_, α → β, λe, e.to_equiv⟩

@[simp] lemma homeomorph_mk_coe (a : equiv α β) (b c) :
  ((homeomorph.mk a b c) : α → β) = a :=
rfl

@[simp] lemma coe_to_equiv (h : α ≃ₜ β) : ⇑h.to_equiv = h := rfl

/-- Inverse of a homeomorphism. -/
protected def symm (h : α ≃ₜ β) : β ≃ₜ α :=
{ continuous_to_fun  := h.continuous_inv_fun,
  continuous_inv_fun := h.continuous_to_fun,
  to_equiv := h.to_equiv.symm }

/-- See Note [custom simps projection]. We need to specify this projection explicitly in this case,
  because it is a composition of multiple projections. -/
def simps.apply (h : α ≃ₜ β) : α → β := h
/-- See Note [custom simps projection] -/
def simps.symm_apply (h : α ≃ₜ β) : β → α := h.symm

initialize_simps_projections homeomorph
  (to_equiv_to_fun → apply, to_equiv_inv_fun → symm_apply, -to_equiv)

lemma to_equiv_injective : function.injective (to_equiv : α ≃ₜ β → α ≃ β)
| ⟨e, h₁, h₂⟩ ⟨e', h₁', h₂'⟩ rfl := rfl

@[ext] lemma ext {h h' : α ≃ₜ β} (H : ∀ x, h x = h' x) : h = h' :=
to_equiv_injective $ equiv.ext H

/-- Identity map as a homeomorphism. -/
@[simps apply {fully_applied := ff}]
protected def refl (α : Type*) [topological_space α] : α ≃ₜ α :=
{ continuous_to_fun := continuous_id,
  continuous_inv_fun := continuous_id,
  to_equiv := equiv.refl α }

/-- Composition of two homeomorphisms. -/
protected def trans (h₁ : α ≃ₜ β) (h₂ : β ≃ₜ γ) : α ≃ₜ γ :=
{ continuous_to_fun  := h₂.continuous_to_fun.comp h₁.continuous_to_fun,
  continuous_inv_fun := h₁.continuous_inv_fun.comp h₂.continuous_inv_fun,
  to_equiv := equiv.trans h₁.to_equiv h₂.to_equiv }

@[simp] lemma homeomorph_mk_coe_symm (a : equiv α β) (b c) :
  ((homeomorph.mk a b c).symm : β → α) = a.symm :=
rfl

@[simp] lemma refl_symm : (homeomorph.refl α).symm = homeomorph.refl α := rfl

@[continuity]
protected lemma continuous (h : α ≃ₜ β) : continuous h := h.continuous_to_fun

@[continuity] -- otherwise `by continuity` can't prove continuity of `h.to_equiv.symm`
protected lemma continuous_symm (h : α ≃ₜ β) : continuous (h.symm) := h.continuous_inv_fun

@[simp] lemma apply_symm_apply (h : α ≃ₜ β) (x : β) : h (h.symm x) = x :=
h.to_equiv.apply_symm_apply x

@[simp] lemma symm_apply_apply (h : α ≃ₜ β) (x : α) : h.symm (h x) = x :=
h.to_equiv.symm_apply_apply x

protected lemma bijective (h : α ≃ₜ β) : function.bijective h := h.to_equiv.bijective
protected lemma injective (h : α ≃ₜ β) : function.injective h := h.to_equiv.injective
protected lemma surjective (h : α ≃ₜ β) : function.surjective h := h.to_equiv.surjective

/-- Change the homeomorphism `f` to make the inverse function definitionally equal to `g`. -/
def change_inv (f : α ≃ₜ β) (g : β → α) (hg : function.right_inverse g f) : α ≃ₜ β :=
have g = f.symm, from funext (λ x, calc g x = f.symm (f (g x)) : (f.left_inv (g x)).symm
                                        ... = f.symm x : by rw hg x),
{ to_fun := f,
  inv_fun := g,
  left_inv := by convert f.left_inv,
  right_inv := by convert f.right_inv,
  continuous_to_fun := f.continuous,
  continuous_inv_fun := by convert f.symm.continuous }

@[simp] lemma symm_comp_self (h : α ≃ₜ β) : ⇑h.symm ∘ ⇑h = id :=
funext h.symm_apply_apply

@[simp] lemma self_comp_symm (h : α ≃ₜ β) : ⇑h ∘ ⇑h.symm = id :=
funext h.apply_symm_apply

@[simp] lemma range_coe (h : α ≃ₜ β) : range h = univ :=
h.surjective.range_eq

lemma image_symm (h : α ≃ₜ β) : image h.symm = preimage h :=
funext h.symm.to_equiv.image_eq_preimage

lemma preimage_symm (h : α ≃ₜ β) : preimage h.symm = image h :=
(funext h.to_equiv.image_eq_preimage).symm

@[simp] lemma image_preimage (h : α ≃ₜ β) (s : set β) : h '' (h ⁻¹' s) = s :=
h.to_equiv.image_preimage s

@[simp] lemma preimage_image (h : α ≃ₜ β) (s : set α) : h ⁻¹' (h '' s) = s :=
h.to_equiv.preimage_image s

protected lemma inducing (h : α ≃ₜ β) : inducing h :=
inducing_of_inducing_compose h.continuous h.symm.continuous $
  by simp only [symm_comp_self, inducing_id]

lemma induced_eq (h : α ≃ₜ β) : topological_space.induced h ‹_› = ‹_› := h.inducing.1.symm

protected lemma quotient_map (h : α ≃ₜ β) : quotient_map h :=
quotient_map.of_quotient_map_compose h.symm.continuous h.continuous $
  by simp only [self_comp_symm, quotient_map.id]

lemma coinduced_eq (h : α ≃ₜ β) : topological_space.coinduced h ‹_› = ‹_› :=
h.quotient_map.2.symm

protected lemma embedding (h : α ≃ₜ β) : embedding h :=
⟨h.inducing, h.injective⟩

protected lemma second_countable_topology [topological_space.second_countable_topology β]
  (h : α ≃ₜ β) :
  topological_space.second_countable_topology α :=
h.inducing.second_countable_topology

lemma compact_image {s : set α} (h : α ≃ₜ β) : is_compact (h '' s) ↔ is_compact s :=
h.embedding.compact_iff_compact_image.symm

lemma compact_preimage {s : set β} (h : α ≃ₜ β) : is_compact (h ⁻¹' s) ↔ is_compact s :=
by rw ← image_symm; exact h.symm.compact_image

protected lemma dense_embedding (h : α ≃ₜ β) : dense_embedding h :=
{ dense   := h.surjective.dense_range,
  .. h.embedding }

@[simp] lemma is_open_preimage (h : α ≃ₜ β) {s : set β} : is_open (h ⁻¹' s) ↔ is_open s :=
h.quotient_map.is_open_preimage

@[simp] lemma is_open_image (h : α ≃ₜ β) {s : set α} : is_open (h '' s) ↔ is_open s :=
by rw [← preimage_symm, is_open_preimage]

@[simp] lemma is_closed_preimage (h : α ≃ₜ β) {s : set β} : is_closed (h ⁻¹' s) ↔ is_closed s :=
by simp only [← is_open_compl_iff, ← preimage_compl, is_open_preimage]

@[simp] lemma is_closed_image (h : α ≃ₜ β) {s : set α} : is_closed (h '' s) ↔ is_closed s :=
by rw [← preimage_symm, is_closed_preimage]

lemma preimage_closure (h : α ≃ₜ β) (s : set β) : h ⁻¹' (closure s) = closure (h ⁻¹' s) :=
by rw [h.embedding.closure_eq_preimage_closure_image, h.image_preimage]

lemma image_closure (h : α ≃ₜ β) (s : set α) : h '' (closure s) = closure (h '' s) :=
by rw [← preimage_symm, preimage_closure]

protected lemma is_open_map (h : α ≃ₜ β) : is_open_map h := λ s, h.is_open_image.2

protected lemma is_closed_map (h : α ≃ₜ β) : is_closed_map h := λ s, h.is_closed_image.2

protected lemma closed_embedding (h : α ≃ₜ β) : closed_embedding h :=
closed_embedding_of_embedding_closed h.embedding h.is_closed_map

@[simp] lemma map_nhds_eq (h : α ≃ₜ β) (x : α) : map h (𝓝 x) = 𝓝 (h x) :=
h.embedding.map_nhds_of_mem _ (by simp)

lemma symm_map_nhds_eq (h : α ≃ₜ β) (x : α) : map h.symm (𝓝 (h x)) = 𝓝 x :=
by rw [h.symm.map_nhds_eq, h.symm_apply_apply]

lemma nhds_eq_comap (h : α ≃ₜ β) (x : α) : 𝓝 x = comap h (𝓝 (h x)) :=
h.embedding.to_inducing.nhds_eq_comap x

@[simp] lemma comap_nhds_eq (h : α ≃ₜ β) (y : β) : comap h (𝓝 y) = 𝓝 (h.symm y) :=
by rw [h.nhds_eq_comap, h.apply_symm_apply]

/-- If an bijective map `e : α ≃ β` is continuous and open, then it is a homeomorphism. -/
def homeomorph_of_continuous_open (e : α ≃ β) (h₁ : continuous e) (h₂ : is_open_map e) :
  α ≃ₜ β :=
{ continuous_to_fun := h₁,
  continuous_inv_fun := begin
    rw continuous_def,
    intros s hs,
    convert ← h₂ s hs using 1,
    apply e.image_eq_preimage
  end,
  to_equiv := e }

@[simp] lemma comp_continuous_on_iff (h : α ≃ₜ β) (f : γ → α) (s : set γ) :
  continuous_on (h ∘ f) s ↔ continuous_on f s :=
h.inducing.continuous_on_iff.symm

@[simp] lemma comp_continuous_iff (h : α ≃ₜ β) {f : γ → α} :
  continuous (h ∘ f) ↔ continuous f :=
h.inducing.continuous_iff.symm

@[simp] lemma comp_continuous_iff' (h : α ≃ₜ β) {f : β → γ} :
  continuous (f ∘ h) ↔ continuous f :=
h.quotient_map.continuous_iff.symm

/-- If two sets are equal, then they are homeomorphic. -/
def set_congr {s t : set α} (h : s = t) : s ≃ₜ t :=
{ continuous_to_fun := continuous_subtype_mk _ continuous_subtype_val,
  continuous_inv_fun := continuous_subtype_mk _ continuous_subtype_val,
  to_equiv := equiv.set_congr h }

/-- Sum of two homeomorphisms. -/
def sum_congr (h₁ : α ≃ₜ β) (h₂ : γ ≃ₜ δ) : α ⊕ γ ≃ₜ β ⊕ δ :=
{ continuous_to_fun  :=
  begin
    convert continuous_sum_rec (continuous_inl.comp h₁.continuous)
      (continuous_inr.comp h₂.continuous),
    ext x, cases x; refl,
  end,
  continuous_inv_fun :=
  begin
    convert continuous_sum_rec (continuous_inl.comp h₁.symm.continuous)
      (continuous_inr.comp h₂.symm.continuous),
    ext x, cases x; refl
  end,
  to_equiv := h₁.to_equiv.sum_congr h₂.to_equiv }

/-- Product of two homeomorphisms. -/
def prod_congr (h₁ : α ≃ₜ β) (h₂ : γ ≃ₜ δ) : α × γ ≃ₜ β × δ :=
{ continuous_to_fun  := (h₁.continuous.comp continuous_fst).prod_mk
    (h₂.continuous.comp continuous_snd),
  continuous_inv_fun := (h₁.symm.continuous.comp continuous_fst).prod_mk
    (h₂.symm.continuous.comp continuous_snd),
  to_equiv := h₁.to_equiv.prod_congr h₂.to_equiv }

@[simp] lemma prod_congr_symm (h₁ : α ≃ₜ β) (h₂ : γ ≃ₜ δ) :
  (h₁.prod_congr h₂).symm = h₁.symm.prod_congr h₂.symm := rfl

@[simp] lemma coe_prod_congr (h₁ : α ≃ₜ β) (h₂ : γ ≃ₜ δ) :
  ⇑(h₁.prod_congr h₂) = prod.map h₁ h₂ := rfl

section
variables (α β γ)

/-- `α × β` is homeomorphic to `β × α`. -/
def prod_comm : α × β ≃ₜ β × α :=
{ continuous_to_fun  := continuous_snd.prod_mk continuous_fst,
  continuous_inv_fun := continuous_snd.prod_mk continuous_fst,
  to_equiv := equiv.prod_comm α β }

@[simp] lemma prod_comm_symm : (prod_comm α β).symm = prod_comm β α := rfl
@[simp] lemma coe_prod_comm : ⇑(prod_comm α β) = prod.swap := rfl

/-- `(α × β) × γ` is homeomorphic to `α × (β × γ)`. -/
def prod_assoc : (α × β) × γ ≃ₜ α × (β × γ) :=
{ continuous_to_fun  := (continuous_fst.comp continuous_fst).prod_mk
    ((continuous_snd.comp continuous_fst).prod_mk continuous_snd),
  continuous_inv_fun := (continuous_fst.prod_mk (continuous_fst.comp continuous_snd)).prod_mk
    (continuous_snd.comp continuous_snd),
  to_equiv := equiv.prod_assoc α β γ }

/-- `α × {*}` is homeomorphic to `α`. -/
@[simps apply {fully_applied := ff}]
def prod_punit : α × punit ≃ₜ α :=
{ to_equiv := equiv.prod_punit α,
  continuous_to_fun := continuous_fst,
  continuous_inv_fun := continuous_id.prod_mk continuous_const }

/-- `{*} × α` is homeomorphic to `α`. -/
def punit_prod : punit × α ≃ₜ α :=
(prod_comm _ _).trans (prod_punit _)

@[simp] lemma coe_punit_prod : ⇑(punit_prod α) = prod.snd := rfl

end

/-- `ulift α` is homeomorphic to `α`. -/
def {u v} ulift {α : Type u} [topological_space α] : ulift.{v u} α ≃ₜ α :=
{ continuous_to_fun := continuous_ulift_down,
  continuous_inv_fun := continuous_ulift_up,
  to_equiv := equiv.ulift }

section distrib

/-- `(α ⊕ β) × γ` is homeomorphic to `α × γ ⊕ β × γ`. -/
def sum_prod_distrib : (α ⊕ β) × γ ≃ₜ α × γ ⊕ β × γ :=
begin
  refine (homeomorph.homeomorph_of_continuous_open (equiv.sum_prod_distrib α β γ).symm _ _).symm,
  { convert continuous_sum_rec
      ((continuous_inl.comp continuous_fst).prod_mk continuous_snd)
      ((continuous_inr.comp continuous_fst).prod_mk continuous_snd),
    ext1 x, cases x; refl, },
  { exact (is_open_map_sum
    (open_embedding_inl.prod open_embedding_id).is_open_map
    (open_embedding_inr.prod open_embedding_id).is_open_map) }
end

/-- `α × (β ⊕ γ)` is homeomorphic to `α × β ⊕ α × γ`. -/
def prod_sum_distrib : α × (β ⊕ γ) ≃ₜ α × β ⊕ α × γ :=
(prod_comm _ _).trans $
sum_prod_distrib.trans $
sum_congr (prod_comm _ _) (prod_comm _ _)

variables {ι : Type*} {σ : ι → Type*} [Π i, topological_space (σ i)]

/-- `(Σ i, σ i) × β` is homeomorphic to `Σ i, (σ i × β)`. -/
def sigma_prod_distrib : ((Σ i, σ i) × β) ≃ₜ (Σ i, (σ i × β)) :=
homeomorph.symm $
homeomorph_of_continuous_open (equiv.sigma_prod_distrib σ β).symm
  (continuous_sigma $ λ i,
    (continuous_sigma_mk.comp continuous_fst).prod_mk continuous_snd)
  (is_open_map_sigma $ λ i,
    (open_embedding_sigma_mk.prod open_embedding_id).is_open_map)

end distrib

/--
A subset of a topological space is homeomorphic to its image under a homeomorphism.
-/
def image (e : α ≃ₜ β) (s : set α) : s ≃ₜ e '' s :=
{ continuous_to_fun := by continuity!,
  continuous_inv_fun := by continuity!,
  ..e.to_equiv.image s, }

end homeomorph


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

! This file was ported from Lean 3 source module algebra.category.Module.change_of_rings
! leanprover-community/mathlib commit 8f66240cab125b938b327d3850169d490cfbcdd8
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Category.Module.Basic
import Mathbin.RingTheory.TensorProduct

/-!
# Change Of Rings

## Main definitions

* `category_theory.Module.restrict_scalars`: given rings `R, S` and a ring homomorphism `R ⟶ S`,
  then `restrict_scalars : Module S ⥤ Module R` is defined by `M ↦ M` where `M : S-module` is seen
  as `R-module` by `r • m := f r • m` and `S`-linear map `l : M ⟶ M'` is `R`-linear as well.

* `category_theory.Module.extend_scalars`: given **commutative** rings `R, S` and ring homomorphism
  `f : R ⟶ S`, then `extend_scalars : Module R ⥤ Module S` is defined by `M ↦ S ⨂ M` where the
  module structure is defined by `s • (s' ⊗ m) := (s * s') ⊗ m` and `R`-linear map `l : M ⟶ M'`
  is sent to `S`-linear map `s ⊗ m ↦ s ⊗ l m : S ⨂ M ⟶ S ⨂ M'`.

## List of notations
Let `R, S` be rings and `f : R →+* S`
* if `M` is an `R`-module, `s : S` and `m : M`, then `s ⊗ₜ[R, f] m` is the pure tensor
  `s ⊗ m : S ⊗[R, f] M`.
-/

namespace CategoryTheory.Module

universe v u₁ u₂

namespace RestrictScalars

variable {R : Type u₁} {S : Type u₂} [Ring R] [Ring S] (f : R →+* S)

variable (M : ModuleCat.{v} S)

/-- Any `S`-module M is also an `R`-module via a ring homomorphism `f : R ⟶ S` by defining
    `r • m := f r • m` (`module.comp_hom`). This is called restriction of scalars. -/
def obj' : ModuleCat R where
  carrier := M
  isModule := Module.compHom M f
#align category_theory.Module.restrict_scalars.obj' CategoryTheory.Module.RestrictScalars.obj'

/-- Given an `S`-linear map `g : M → M'` between `S`-modules, `g` is also `R`-linear between `M` and
`M'` by means of restriction of scalars.
-/
def map' {M M' : ModuleCat.{v} S} (g : M ⟶ M') : obj' f M ⟶ obj' f M' :=
  { g with map_smul' := fun r => g.map_smul (f r) }
#align category_theory.Module.restrict_scalars.map' CategoryTheory.Module.RestrictScalars.map'

end RestrictScalars

/-- The restriction of scalars operation is functorial. For any `f : R →+* S` a ring homomorphism,
* an `S`-module `M` can be considered as `R`-module by `r • m = f r • m`
* an `S`-linear map is also `R`-linear
-/
def restrictScalars {R : Type u₁} {S : Type u₂} [Ring R] [Ring S] (f : R →+* S) :
    ModuleCat.{v} S ⥤ ModuleCat.{v} R
    where
  obj := RestrictScalars.obj' f
  map _ _ := RestrictScalars.map' f
  map_id' _ := LinearMap.ext fun m => rfl
  map_comp' _ _ _ g h := LinearMap.ext fun m => rfl
#align category_theory.Module.restrict_scalars CategoryTheory.Module.restrictScalars

@[simp]
theorem restrictScalars.map_apply {R : Type u₁} {S : Type u₂} [Ring R] [Ring S] (f : R →+* S)
    {M M' : ModuleCat.{v} S} (g : M ⟶ M') (x) : (restrictScalars f).map g x = g x :=
  rfl
#align category_theory.Module.restrict_scalars.map_apply CategoryTheory.Module.restrictScalars.map_apply

@[simp]
theorem restrictScalars.smul_def {R : Type u₁} {S : Type u₂} [Ring R] [Ring S] (f : R →+* S)
    {M : ModuleCat.{v} S} (r : R) (m : (restrictScalars f).obj M) : r • m = (f r • m : M) :=
  rfl
#align category_theory.Module.restrict_scalars.smul_def CategoryTheory.Module.restrictScalars.smul_def

theorem restrictScalars.smul_def' {R : Type u₁} {S : Type u₂} [Ring R] [Ring S] (f : R →+* S)
    {M : ModuleCat.{v} S} (r : R) (m : M) : (r • m : (restrictScalars f).obj M) = (f r • m : M) :=
  rfl
#align category_theory.Module.restrict_scalars.smul_def' CategoryTheory.Module.restrictScalars.smul_def'

instance (priority := 100) sMulCommClass_mk {R : Type u₁} {S : Type u₂} [Ring R] [CommRing S]
    (f : R →+* S) (M : Type v) [AddCommGroup M] [Module S M] :
    @SMulCommClass R S M (RestrictScalars.obj' f (ModuleCat.mk M)).isModule.toSMul _
    where smul_comm r s m := (by simp [← mul_smul, mul_comm] : f r • s • m = s • f r • m)
#align category_theory.Module.smul_comm_class_mk CategoryTheory.Module.sMulCommClass_mk

namespace ExtendScalars

open TensorProduct

variable {R : Type u₁} {S : Type u₂} [CommRing R] [CommRing S] (f : R →+* S)

section Unbundled

variable (M : Type v) [AddCommMonoid M] [Module R M]

-- mathport name: «expr ⊗ₜ[ , ] »
-- This notation is necessary because we need to reason about `s ⊗ₜ m` where `s : S` and `m : M`;
-- without this notation, one need to work with `s : (restrict_scalars f).obj ⟨S⟩`.
scoped[ChangeOfRings]
  notation s "⊗ₜ[" R "," f "]" m => @TensorProduct.tmul R _ _ _ _ _ (Module.compHom _ f) _ s m

end Unbundled

open ChangeOfRings

variable (M : ModuleCat.{v} R)

/-- Extension of scalars turn an `R`-module into `S`-module by M ↦ S ⨂ M
-/
def obj' : ModuleCat S :=
  ⟨TensorProduct R ((restrictScalars f).obj ⟨S⟩) M⟩
#align category_theory.Module.extend_scalars.obj' CategoryTheory.Module.ExtendScalars.obj'

/-- Extension of scalars is a functor where an `R`-module `M` is sent to `S ⊗ M` and
`l : M1 ⟶ M2` is sent to `s ⊗ m ↦ s ⊗ l m`
-/
def map' {M1 M2 : ModuleCat.{v} R} (l : M1 ⟶ M2) : obj' f M1 ⟶ obj' f M2 :=
  by-- The "by apply" part makes this require 75% fewer heartbeats to process (#16371).
  apply @LinearMap.baseChange R S M1 M2 _ _ ((algebraMap S _).comp f).toAlgebra _ _ _ _ l
#align category_theory.Module.extend_scalars.map' CategoryTheory.Module.ExtendScalars.map'

theorem map'_id {M : ModuleCat.{v} R} : map' f (𝟙 M) = 𝟙 _ :=
  LinearMap.ext fun x : obj' f M =>
    by
    dsimp only [map', ModuleCat.id_apply]
    induction' x using TensorProduct.induction_on with _ _ m s ihx ihy
    · simp only [map_zero]
    · rw [LinearMap.baseChange_tmul, ModuleCat.id_apply]
    · rw [map_add, ihx, ihy]
#align category_theory.Module.extend_scalars.map'_id CategoryTheory.Module.ExtendScalars.map'_id

theorem map'_comp {M₁ M₂ M₃ : ModuleCat.{v} R} (l₁₂ : M₁ ⟶ M₂) (l₂₃ : M₂ ⟶ M₃) :
    map' f (l₁₂ ≫ l₂₃) = map' f l₁₂ ≫ map' f l₂₃ :=
  LinearMap.ext fun x : obj' f M₁ => by
    dsimp only [map']
    induction' x using TensorProduct.induction_on with _ _ x y ihx ihy
    · rfl
    · rfl
    · simp only [map_add, ihx, ihy]
#align category_theory.Module.extend_scalars.map'_comp CategoryTheory.Module.ExtendScalars.map'_comp

end ExtendScalars

/-- Extension of scalars is a functor where an `R`-module `M` is sent to `S ⊗ M` and
`l : M1 ⟶ M2` is sent to `s ⊗ m ↦ s ⊗ l m`
-/
def extendScalars {R : Type u₁} {S : Type u₂} [CommRing R] [CommRing S] (f : R →+* S) :
    ModuleCat.{v} R ⥤ ModuleCat.{max v u₂} S
    where
  obj M := ExtendScalars.obj' f M
  map M1 M2 l := ExtendScalars.map' f l
  map_id' _ := ExtendScalars.map'_id f
  map_comp' _ _ _ := ExtendScalars.map'_comp f
#align category_theory.Module.extend_scalars CategoryTheory.Module.extendScalars

namespace ExtendScalars

open ChangeOfRings

variable {R : Type u₁} {S : Type u₂} [CommRing R] [CommRing S] (f : R →+* S)

@[simp]
protected theorem smul_tmul {M : ModuleCat.{v} R} (s s' : S) (m : M) :
    s • (s'⊗ₜ[R,f]m : (extendScalars f).obj M) = (s * s')⊗ₜ[R,f]m :=
  rfl
#align category_theory.Module.extend_scalars.smul_tmul CategoryTheory.Module.extendScalars.smul_tmul

@[simp]
theorem map_tmul {M M' : ModuleCat.{v} R} (g : M ⟶ M') (s : S) (m : M) :
    (extendScalars f).map g (s⊗ₜ[R,f]m) = s⊗ₜ[R,f]g m :=
  rfl
#align category_theory.Module.extend_scalars.map_tmul CategoryTheory.Module.extendScalars.map_tmul

end ExtendScalars

end CategoryTheory.Module


/-
Copyright (c) 2021 Oliver Nash. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Oliver Nash
-/
import algebra.lie.basic
import ring_theory.noetherian

/-!
# Lie subalgebras

This file defines Lie subalgebras of a Lie algebra and provides basic related definitions and
results.

## Main definitions

  * `lie_subalgebra`
  * `lie_subalgebra.incl`
  * `lie_subalgebra.map`
  * `lie_hom.range`
  * `lie_equiv.of_injective`
  * `lie_equiv.of_eq`
  * `lie_equiv.of_subalgebra`
  * `lie_equiv.of_subalgebras`

## Tags

lie algebra, lie subalgebra
-/

universes u v w w₁ w₂

section lie_subalgebra

variables (R : Type u) (L : Type v) [comm_ring R] [lie_ring L] [lie_algebra R L]

/-- A Lie subalgebra of a Lie algebra is submodule that is closed under the Lie bracket.
This is a sufficient condition for the subset itself to form a Lie algebra. -/
structure lie_subalgebra extends submodule R L :=
(lie_mem' : ∀ {x y}, x ∈ carrier → y ∈ carrier → ⁅x, y⁆ ∈ carrier)

attribute [nolint doc_blame] lie_subalgebra.to_submodule

/-- The zero algebra is a subalgebra of any Lie algebra. -/
instance : has_zero (lie_subalgebra R L) :=
⟨{ lie_mem' := λ x y hx hy, by { rw [((submodule.mem_bot R).1 hx), zero_lie],
                                exact submodule.zero_mem (0 : submodule R L), },
   ..(0 : submodule R L) }⟩

instance : inhabited (lie_subalgebra R L) := ⟨0⟩
instance : has_coe (lie_subalgebra R L) (submodule R L) := ⟨lie_subalgebra.to_submodule⟩
instance : has_mem L (lie_subalgebra R L) := ⟨λ x L', x ∈ (L' : set L)⟩

namespace lie_subalgebra

/-- A Lie subalgebra forms a new Lie ring. -/
instance (L' : lie_subalgebra R L) : lie_ring L' :=
{ bracket      := λ x y, ⟨⁅x.val, y.val⁆, L'.lie_mem' x.property y.property⟩,
  lie_add      := by { intros, apply set_coe.ext, apply lie_add, },
  add_lie      := by { intros, apply set_coe.ext, apply add_lie, },
  lie_self     := by { intros, apply set_coe.ext, apply lie_self, },
  leibniz_lie  := by { intros, apply set_coe.ext, apply leibniz_lie, } }

section

variables {R₁ : Type*} [semiring R₁]

/-- A Lie subalgebra inherits module structures from `L`. -/
instance [has_scalar R₁ R] [module R₁ L] [is_scalar_tower R₁ R L]
  (L' : lie_subalgebra R L) : module R₁ L' :=
L'.to_submodule.module'

instance [has_scalar R₁ R] [has_scalar R₁ᵐᵒᵖ R] [module R₁ L] [module R₁ᵐᵒᵖ L]
  [is_scalar_tower R₁ R L] [is_scalar_tower R₁ᵐᵒᵖ R L] [is_central_scalar R₁ L]
  (L' : lie_subalgebra R L) : is_central_scalar R₁ L' :=
L'.to_submodule.is_central_scalar

instance [has_scalar R₁ R] [module R₁ L] [is_scalar_tower R₁ R L]
  (L' : lie_subalgebra R L) : is_scalar_tower R₁ R L' :=
L'.to_submodule.is_scalar_tower

end

/-- A Lie subalgebra forms a new Lie algebra. -/
instance (L' : lie_subalgebra R L) : lie_algebra R L' :=
{ lie_smul := by { intros, apply set_coe.ext, apply lie_smul } }

variables {R L} (L' : lie_subalgebra R L)

@[simp] lemma zero_mem : (0 : L) ∈ L' := (L' : submodule R L).zero_mem

lemma smul_mem (t : R) {x : L} (h : x ∈ L') : t • x ∈ L' := (L' : submodule R L).smul_mem t h

lemma add_mem {x y : L} (hx : x ∈ L') (hy : y ∈ L') : (x + y : L) ∈ L' :=
(L' : submodule R L).add_mem hx hy

lemma sub_mem {x y : L} (hx : x ∈ L') (hy : y ∈ L') : (x - y : L) ∈ L' :=
(L' : submodule R L).sub_mem hx hy

@[simp] lemma neg_mem_iff {x : L} : -x ∈ L' ↔ x ∈ L' := L'.to_submodule.neg_mem_iff

lemma lie_mem {x y : L} (hx : x ∈ L') (hy : y ∈ L') : (⁅x, y⁆ : L) ∈ L' := L'.lie_mem' hx hy

@[simp] lemma mem_carrier {x : L} : x ∈ L'.carrier ↔ x ∈ (L' : set L) := iff.rfl

@[simp] lemma mem_mk_iff (S : set L) (h₁ h₂ h₃ h₄) {x : L} :
  x ∈ (⟨⟨S, h₁, h₂, h₃⟩, h₄⟩ : lie_subalgebra R L) ↔ x ∈ S :=
iff.rfl

@[simp] lemma mem_coe_submodule {x : L} : x ∈ (L' : submodule R L) ↔ x ∈ L' := iff.rfl

lemma mem_coe {x : L} : x ∈ (L' : set L) ↔ x ∈ L' := iff.rfl

@[simp, norm_cast] lemma coe_bracket (x y : L') : (↑⁅x, y⁆ : L) = ⁅(↑x : L), ↑y⁆ := rfl

lemma ext_iff (x y : L') : x = y ↔ (x : L) = y := subtype.ext_iff

lemma coe_zero_iff_zero (x : L') : (x : L) = 0 ↔ x = 0 := (ext_iff L' x 0).symm

@[ext] lemma ext (L₁' L₂' : lie_subalgebra R L) (h : ∀ x, x ∈ L₁' ↔ x ∈ L₂') :
  L₁' = L₂' :=
by { cases L₁', cases L₂', simp only [], ext x, exact h x, }

lemma ext_iff' (L₁' L₂' : lie_subalgebra R L) : L₁' = L₂' ↔ ∀ x, x ∈ L₁' ↔ x ∈ L₂' :=
⟨λ h x, by rw h, ext L₁' L₂'⟩

@[simp] lemma mk_coe (S : set L) (h₁ h₂ h₃ h₄) :
  ((⟨⟨S, h₁, h₂, h₃⟩, h₄⟩ : lie_subalgebra R L) : set L) = S := rfl

@[simp] lemma coe_to_submodule_mk (p : submodule R L) (h) :
  (({lie_mem' := h, ..p} : lie_subalgebra R L) : submodule R L) = p :=
by { cases p, refl, }

lemma coe_injective : function.injective (coe : lie_subalgebra R L → set L) :=
by { rintro ⟨⟨⟩⟩ ⟨⟨⟩⟩ h, congr' }

instance : set_like (lie_subalgebra R L) L := ⟨coe, coe_injective⟩

@[norm_cast] theorem coe_set_eq (L₁' L₂' : lie_subalgebra R L) :
  (L₁' : set L) = L₂' ↔ L₁' = L₂' := coe_injective.eq_iff

lemma to_submodule_injective :
  function.injective (coe : lie_subalgebra R L → submodule R L) :=
λ L₁' L₂' h, by { rw set_like.ext'_iff at h, rw ← coe_set_eq, exact h, }

@[simp] lemma coe_to_submodule_eq_iff (L₁' L₂' : lie_subalgebra R L) :
  (L₁' : submodule R L) = (L₂' : submodule R L) ↔ L₁' = L₂' :=
to_submodule_injective.eq_iff

@[norm_cast]
lemma coe_to_submodule : ((L' : submodule R L) : set L) = L' := rfl

section lie_module

variables {M : Type w} [add_comm_group M] [lie_ring_module L M]
variables {N : Type w₁} [add_comm_group N] [lie_ring_module L N] [module R N] [lie_module R L N]

/-- Given a Lie algebra `L` containing a Lie subalgebra `L' ⊆ L`, together with a Lie ring module
`M` of `L`, we may regard `M` as a Lie ring module of `L'` by restriction. -/
instance : lie_ring_module L' M :=
{ bracket     := λ x m, ⁅(x : L), m⁆,
  add_lie     := λ x y m, add_lie x y m,
  lie_add     := λ x y m, lie_add x y m,
  leibniz_lie := λ x y m, leibniz_lie x y m, }

@[simp] lemma coe_bracket_of_module (x : L') (m : M) : ⁅x, m⁆ = ⁅(x : L), m⁆ := rfl

variables [module R M] [lie_module R L M]

/-- Given a Lie algebra `L` containing a Lie subalgebra `L' ⊆ L`, together with a Lie module `M` of
`L`, we may regard `M` as a Lie module of `L'` by restriction. -/
instance : lie_module R L' M :=
{ smul_lie := λ t x m, by simp only [coe_bracket_of_module, smul_lie, submodule.coe_smul_of_tower],
  lie_smul := λ t x m, by simp only [coe_bracket_of_module, lie_smul], }

/-- An `L`-equivariant map of Lie modules `M → N` is `L'`-equivariant for any Lie subalgebra
`L' ⊆ L`. -/
def _root_.lie_module_hom.restrict_lie (f : M →ₗ⁅R,L⁆ N) (L' : lie_subalgebra R L) : M →ₗ⁅R,L'⁆ N :=
{ map_lie' := λ x m, f.map_lie ↑x m,
  .. (f : M →ₗ[R] N)}

@[simp] lemma _root_.lie_module_hom.coe_restrict_lie (f : M →ₗ⁅R,L⁆ N) :
  ⇑(f.restrict_lie L') = f :=
rfl

end lie_module

/-- The embedding of a Lie subalgebra into the ambient space as a morphism of Lie algebras. -/
def incl : L' →ₗ⁅R⁆ L :=
{ map_lie' := λ x y, by { simp only [linear_map.to_fun_eq_coe, submodule.subtype_apply], refl, },
  .. (L' : submodule R L).subtype, }

@[simp] lemma coe_incl : ⇑L'.incl = coe := rfl

/-- The embedding of a Lie subalgebra into the ambient space as a morphism of Lie modules. -/
def incl' : L' →ₗ⁅R,L'⁆ L :=
{ map_lie' := λ x y, by simp only [coe_bracket_of_module, linear_map.to_fun_eq_coe,
    submodule.subtype_apply, coe_bracket],
  .. (L' : submodule R L).subtype, }

@[simp] lemma coe_incl' : ⇑L'.incl' = coe := rfl

end lie_subalgebra

variables {R L} {L₂ : Type w} [lie_ring L₂] [lie_algebra R L₂]
variables (f : L →ₗ⁅R⁆ L₂)

namespace lie_hom

/-- The range of a morphism of Lie algebras is a Lie subalgebra. -/
def range : lie_subalgebra R L₂ :=
{ lie_mem' := λ x y,
    show x ∈ f.to_linear_map.range → y ∈ f.to_linear_map.range → ⁅x, y⁆ ∈ f.to_linear_map.range,
    by { repeat { rw linear_map.mem_range }, rintros ⟨x', hx⟩ ⟨y', hy⟩, refine ⟨⁅x', y'⁆, _⟩,
         rw [←hx, ←hy], change f ⁅x', y'⁆ = ⁅f x', f y'⁆, rw map_lie, },
  ..(f : L →ₗ[R] L₂).range }

@[simp] lemma range_coe : (f.range : set L₂) = set.range f :=
linear_map.range_coe ↑f

@[simp] lemma mem_range (x : L₂) : x ∈ f.range ↔ ∃ (y : L), f y = x := linear_map.mem_range

lemma mem_range_self (x : L) : f x ∈ f.range := linear_map.mem_range_self f x

/-- We can restrict a morphism to a (surjective) map to its range. -/
def range_restrict : L →ₗ⁅R⁆ f.range :=
{ map_lie' := λ x y, by { apply subtype.ext, exact f.map_lie x y, },
  ..(f : L →ₗ[R] L₂).range_restrict, }

@[simp] lemma range_restrict_apply (x : L) : f.range_restrict x = ⟨f x, f.mem_range_self x⟩ := rfl

lemma surjective_range_restrict : function.surjective (f.range_restrict) :=
begin
  rintros ⟨y, hy⟩,
  erw mem_range at hy, obtain ⟨x, rfl⟩ := hy,
  use x,
  simp only [subtype.mk_eq_mk, range_restrict_apply],
end

/-- A Lie algebra is equivalent to its range under an injective Lie algebra morphism. -/
noncomputable def equiv_range_of_injective (h : function.injective f) : L ≃ₗ⁅R⁆ f.range :=
lie_equiv.of_bijective f.range_restrict (λ x y hxy,
begin
  simp only [subtype.mk_eq_mk, range_restrict_apply] at hxy,
  exact h hxy,
end) f.surjective_range_restrict

@[simp] lemma equiv_range_of_injective_apply (h : function.injective f) (x : L) :
  f.equiv_range_of_injective h x = ⟨f x, mem_range_self f x⟩ :=
rfl

end lie_hom

lemma submodule.exists_lie_subalgebra_coe_eq_iff (p : submodule R L) :
  (∃ (K : lie_subalgebra R L), ↑K = p) ↔ ∀ (x y : L), x ∈ p → y ∈ p → ⁅x, y⁆ ∈ p :=
begin
  split,
  { rintros ⟨K, rfl⟩, exact K.lie_mem', },
  { intros h, use { lie_mem' := h, ..p }, exact lie_subalgebra.coe_to_submodule_mk p _, },
end

namespace lie_subalgebra

variables (K K' : lie_subalgebra R L) (K₂ : lie_subalgebra R L₂)

@[simp] lemma incl_range : K.incl.range = K :=
by { rw ← coe_to_submodule_eq_iff, exact (K : submodule R L).range_subtype, }

/-- The image of a Lie subalgebra under a Lie algebra morphism is a Lie subalgebra of the
codomain. -/
def map : lie_subalgebra R L₂ :=
{ lie_mem' := λ x y hx hy, by
  { erw submodule.mem_map at hx, rcases hx with ⟨x', hx', hx⟩, rw ←hx,
    erw submodule.mem_map at hy, rcases hy with ⟨y', hy', hy⟩, rw ←hy,
    erw submodule.mem_map,
    exact ⟨⁅x', y'⁆, K.lie_mem hx' hy', f.map_lie x' y'⟩, },
..((K : submodule R L).map (f : L →ₗ[R] L₂)) }

@[simp] lemma mem_map (x : L₂) : x ∈ K.map f ↔ ∃ (y : L), y ∈ K ∧ f y = x := submodule.mem_map

-- TODO Rename and state for homs instead of equivs.
@[simp] lemma mem_map_submodule (e : L ≃ₗ⁅R⁆ L₂) (x : L₂) :
  x ∈ K.map (e : L →ₗ⁅R⁆ L₂) ↔ x ∈ (K : submodule R L).map (e : L →ₗ[R] L₂) :=
iff.rfl

/-- The preimage of a Lie subalgebra under a Lie algebra morphism is a Lie subalgebra of the
domain. -/
def comap : lie_subalgebra R L :=
{ lie_mem' := λ x y hx hy, by
    { suffices : ⁅f x, f y⁆ ∈ K₂, by { simp [this], }, exact K₂.lie_mem hx hy, },
  ..((K₂ : submodule R L₂).comap (f : L →ₗ[R] L₂)), }

section lattice_structure

open set

instance : partial_order (lie_subalgebra R L) :=
{ le := λ N N', ∀ ⦃x⦄, x ∈ N → x ∈ N', -- Overriding `le` like this gives a better defeq.
  ..partial_order.lift (coe : lie_subalgebra R L → set L) coe_injective }

lemma le_def : K ≤ K' ↔ (K : set L) ⊆ K' := iff.rfl

@[simp, norm_cast] lemma coe_submodule_le_coe_submodule : (K : submodule R L) ≤ K' ↔ K ≤ K' :=
iff.rfl

instance : has_bot (lie_subalgebra R L) := ⟨0⟩

@[simp] lemma bot_coe : ((⊥ : lie_subalgebra R L) : set L) = {0} := rfl

@[simp] lemma bot_coe_submodule : ((⊥ : lie_subalgebra R L) : submodule R L) = ⊥ := rfl

@[simp] lemma mem_bot (x : L) : x ∈ (⊥ : lie_subalgebra R L) ↔ x = 0 := mem_singleton_iff

instance : has_top (lie_subalgebra R L) :=
⟨{ lie_mem' := λ x y hx hy, mem_univ ⁅x, y⁆,
   ..(⊤ : submodule R L) }⟩

@[simp] lemma top_coe : ((⊤ : lie_subalgebra R L) : set L) = univ := rfl

@[simp] lemma top_coe_submodule : ((⊤ : lie_subalgebra R L) : submodule R L) = ⊤ := rfl

@[simp] lemma mem_top (x : L) : x ∈ (⊤ : lie_subalgebra R L) := mem_univ x

lemma _root_.lie_hom.range_eq_map : f.range = map f ⊤ :=
by { ext, simp }

instance : has_inf (lie_subalgebra R L) :=
⟨λ K K', { lie_mem' := λ x y hx hy, mem_inter (K.lie_mem hx.1 hy.1) (K'.lie_mem hx.2 hy.2),
            ..(K ⊓ K' : submodule R L) }⟩

instance : has_Inf (lie_subalgebra R L) :=
⟨λ S, { lie_mem' := λ x y hx hy, by
        { simp only [submodule.mem_carrier, mem_Inter, submodule.Inf_coe, mem_set_of_eq,
            forall_apply_eq_imp_iff₂, exists_imp_distrib] at *,
          intros K hK, exact K.lie_mem (hx K hK) (hy K hK), },
        ..Inf {(s : submodule R L) | s ∈ S} }⟩

@[simp] theorem inf_coe : (↑(K ⊓ K') : set L) = K ∩ K' := rfl

@[simp] lemma Inf_coe_to_submodule (S : set (lie_subalgebra R L)) :
  (↑(Inf S) : submodule R L) = Inf {(s : submodule R L) | s ∈ S} := rfl

@[simp] lemma Inf_coe (S : set (lie_subalgebra R L)) : (↑(Inf S) : set L) = ⋂ s ∈ S, (s : set L) :=
begin
  rw [← coe_to_submodule, Inf_coe_to_submodule, submodule.Inf_coe],
  ext x,
  simpa only [mem_Inter, mem_set_of_eq, forall_apply_eq_imp_iff₂, exists_imp_distrib],
end

lemma Inf_glb (S : set (lie_subalgebra R L)) : is_glb S (Inf S) :=
begin
  have h : ∀ (K K' : lie_subalgebra R L), (K : set L) ≤ K' ↔ K ≤ K', { intros, exact iff.rfl, },
  apply is_glb.of_image h,
  simp only [Inf_coe],
  exact is_glb_binfi
end

/-- The set of Lie subalgebras of a Lie algebra form a complete lattice.

We provide explicit values for the fields `bot`, `top`, `inf` to get more convenient definitions
than we would otherwise obtain from `complete_lattice_of_Inf`. -/
instance : complete_lattice (lie_subalgebra R L) :=
{ bot          := ⊥,
  bot_le       := λ N _ h, by { rw mem_bot at h, rw h, exact N.zero_mem', },
  top          := ⊤,
  le_top       := λ _ _ _, trivial,
  inf          := (⊓),
  le_inf       := λ N₁ N₂ N₃ h₁₂ h₁₃ m hm, ⟨h₁₂ hm, h₁₃ hm⟩,
  inf_le_left  := λ _ _ _, and.left,
  inf_le_right := λ _ _ _, and.right,
  ..complete_lattice_of_Inf _ Inf_glb }

instance : add_comm_monoid (lie_subalgebra R L) :=
{ add       := (⊔),
  add_assoc := λ _ _ _, sup_assoc,
  zero      := ⊥,
  zero_add  := λ _, bot_sup_eq,
  add_zero  := λ _, sup_bot_eq,
  add_comm  := λ _ _, sup_comm, }

@[simp] lemma add_eq_sup : K + K' = K ⊔ K' := rfl

@[norm_cast, simp] lemma inf_coe_to_submodule :
  (↑(K ⊓ K') : submodule R L) = (K : submodule R L) ⊓ (K' : submodule R L) := rfl

@[simp] lemma mem_inf (x : L) : x ∈ K ⊓ K' ↔ x ∈ K ∧ x ∈ K' :=
by rw [← mem_coe_submodule, ← mem_coe_submodule, ← mem_coe_submodule, inf_coe_to_submodule,
  submodule.mem_inf]

lemma eq_bot_iff : K = ⊥ ↔ ∀ (x : L), x ∈ K → x = 0 :=
by { rw eq_bot_iff, exact iff.rfl, }

-- TODO[gh-6025]: make this an instance once safe to do so
lemma subsingleton_of_bot : subsingleton (lie_subalgebra R ↥(⊥ : lie_subalgebra R L)) :=
begin
  apply subsingleton_of_bot_eq_top,
  ext ⟨x, hx⟩, change x ∈ ⊥ at hx, rw submodule.mem_bot at hx, subst hx,
  simp only [true_iff, eq_self_iff_true, submodule.mk_eq_zero, mem_bot],
end

variables (R L)

lemma well_founded_of_noetherian [is_noetherian R L] :
  well_founded ((>) : lie_subalgebra R L → lie_subalgebra R L → Prop) :=
  let f : ((>) : lie_subalgebra R L → lie_subalgebra R L → Prop) →r
          ((>) : submodule R L → submodule R L → Prop) :=
  { to_fun       := coe,
    map_rel' := λ N N' h, h, }
in rel_hom_class.well_founded f (is_noetherian_iff_well_founded.mp infer_instance)

variables {R L K K' f}

section nested_subalgebras

variables (h : K ≤ K')

/-- Given two nested Lie subalgebras `K ⊆ K'`, the inclusion `K ↪ K'` is a morphism of Lie
algebras. -/
def hom_of_le : K →ₗ⁅R⁆ K' :=
{ map_lie' := λ x y, rfl,
  ..submodule.of_le h }

@[simp] lemma coe_hom_of_le (x : K) : (hom_of_le h x : L) = x := rfl

lemma hom_of_le_apply (x : K) : hom_of_le h x = ⟨x.1, h x.2⟩ := rfl

lemma hom_of_le_injective : function.injective (hom_of_le h) :=
λ x y, by simp only [hom_of_le_apply, imp_self, subtype.mk_eq_mk, set_like.coe_eq_coe,
  subtype.val_eq_coe]

/-- Given two nested Lie subalgebras `K ⊆ K'`, we can view `K` as a Lie subalgebra of `K'`,
regarded as Lie algebra in its own right. -/
def of_le : lie_subalgebra R K' := (hom_of_le h).range

@[simp] lemma mem_of_le (x : K') : x ∈ of_le h ↔ (x : L) ∈ K :=
begin
  simp only [of_le, hom_of_le_apply, lie_hom.mem_range],
  split,
  { rintros ⟨y, rfl⟩, exact y.property, },
  { intros h, use ⟨(x : L), h⟩, simp, },
end

lemma of_le_eq_comap_incl : of_le h = K.comap K'.incl :=
by { ext, rw mem_of_le, refl, }

@[simp] lemma coe_of_le : (of_le h : submodule R K') = (submodule.of_le h).range := rfl

/-- Given nested Lie subalgebras `K ⊆ K'`, there is a natural equivalence from `K` to its image in
`K'`.  -/
noncomputable def equiv_of_le : K ≃ₗ⁅R⁆ of_le h :=
(hom_of_le h).equiv_range_of_injective (hom_of_le_injective h)

@[simp]

end nested_subalgebras

lemma map_le_iff_le_comap {K : lie_subalgebra R L} {K' : lie_subalgebra R L₂} :
  map f K ≤ K' ↔ K ≤ comap f K' := set.image_subset_iff

lemma gc_map_comap : galois_connection (map f) (comap f) := λ K K', map_le_iff_le_comap

end lattice_structure

section lie_span

variables (R L) (s : set L)

/-- The Lie subalgebra of a Lie algebra `L` generated by a subset `s ⊆ L`. -/
def lie_span : lie_subalgebra R L := Inf {N | s ⊆ N}

variables {R L s}

lemma mem_lie_span {x : L} : x ∈ lie_span R L s ↔ ∀ K : lie_subalgebra R L, s ⊆ K → x ∈ K :=
by { change x ∈ (lie_span R L s : set L) ↔ _, erw Inf_coe, exact set.mem_Inter₂, }

lemma subset_lie_span : s ⊆ lie_span R L s :=
by { intros m hm, erw mem_lie_span, intros K hK, exact hK hm, }

lemma submodule_span_le_lie_span : submodule.span R s ≤ lie_span R L s :=
by { rw submodule.span_le, apply subset_lie_span, }

lemma lie_span_le {K} : lie_span R L s ≤ K ↔ s ⊆ K :=
begin
  split,
  { exact set.subset.trans subset_lie_span, },
  { intros hs m hm, rw mem_lie_span at hm, exact hm _ hs, },
end

lemma lie_span_mono {t : set L} (h : s ⊆ t) : lie_span R L s ≤ lie_span R L t :=
by { rw lie_span_le, exact set.subset.trans h subset_lie_span, }

lemma lie_span_eq : lie_span R L (K : set L) = K :=
le_antisymm (lie_span_le.mpr rfl.subset) subset_lie_span

lemma coe_lie_span_submodule_eq_iff {p : submodule R L} :
  (lie_span R L (p : set L) : submodule R L) = p ↔ ∃ (K : lie_subalgebra R L), ↑K = p :=
begin
  rw p.exists_lie_subalgebra_coe_eq_iff, split; intros h,
  { intros x m hm, rw [← h, mem_coe_submodule], exact lie_mem _ (subset_lie_span hm), },
  { rw [← coe_to_submodule_mk p h, coe_to_submodule, coe_to_submodule_eq_iff, lie_span_eq], },
end

variables (R L)

/-- `lie_span` forms a Galois insertion with the coercion from `lie_subalgebra` to `set`. -/
protected def gi : galois_insertion (lie_span R L : set L → lie_subalgebra R L) coe :=
{ choice    := λ s _, lie_span R L s,
  gc        := λ s t, lie_span_le,
  le_l_u    := λ s, subset_lie_span,
  choice_eq := λ s h, rfl }

@[simp] lemma span_empty : lie_span R L (∅ : set L) = ⊥ :=
(lie_subalgebra.gi R L).gc.l_bot

@[simp] lemma span_univ : lie_span R L (set.univ : set L) = ⊤ :=
eq_top_iff.2 $ set_like.le_def.2 $ subset_lie_span

variables {L}

lemma span_union (s t : set L) : lie_span R L (s ∪ t) = lie_span R L s ⊔ lie_span R L t :=
(lie_subalgebra.gi R L).gc.l_sup

lemma span_Union {ι} (s : ι → set L) : lie_span R L (⋃ i, s i) = ⨆ i, lie_span R L (s i) :=
(lie_subalgebra.gi R L).gc.l_supr

end lie_span

end lie_subalgebra

end lie_subalgebra

namespace lie_equiv

variables {R : Type u} {L₁ : Type v} {L₂ : Type w}
variables [comm_ring R] [lie_ring L₁] [lie_ring L₂] [lie_algebra R L₁] [lie_algebra R L₂]

/-- An injective Lie algebra morphism is an equivalence onto its range. -/
noncomputable def of_injective (f : L₁ →ₗ⁅R⁆ L₂) (h : function.injective f) :
  L₁ ≃ₗ⁅R⁆ f.range :=
{ map_lie' := λ x y, by { apply set_coe.ext, simpa, },
..(linear_equiv.of_injective ↑f $ by rwa [lie_hom.coe_to_linear_map])}

@[simp] lemma of_injective_apply (f : L₁ →ₗ⁅R⁆ L₂) (h : function.injective f) (x : L₁) :
  ↑(of_injective f h x) = f x := rfl

variables (L₁' L₁'' : lie_subalgebra R L₁) (L₂' : lie_subalgebra R L₂)

/-- Lie subalgebras that are equal as sets are equivalent as Lie algebras. -/
def of_eq (h : (L₁' : set L₁) = L₁'') : L₁' ≃ₗ⁅R⁆ L₁'' :=
{ map_lie' := λ x y, by { apply set_coe.ext, simp, },
  ..(linear_equiv.of_eq ↑L₁' ↑L₁''
      (by {ext x, change x ∈ (L₁' : set L₁) ↔ x ∈ (L₁'' : set L₁), rw h, } )) }

@[simp] lemma of_eq_apply (L L' : lie_subalgebra R L₁) (h : (L : set L₁) = L') (x : L) :
  (↑(of_eq L L' h x) : L₁) = x := rfl

variables (e : L₁ ≃ₗ⁅R⁆ L₂)

/-- An equivalence of Lie algebras restricts to an equivalence from any Lie subalgebra onto its
image. -/
def lie_subalgebra_map : L₁'' ≃ₗ⁅R⁆ (L₁''.map e : lie_subalgebra R L₂) :=
{ map_lie' := λ x y, by { apply set_coe.ext, exact lie_hom.map_lie (↑e : L₁ →ₗ⁅R⁆ L₂) ↑x ↑y, }
  ..(linear_equiv.submodule_map (e : L₁ ≃ₗ[R] L₂) ↑L₁'') }

@[simp] lemma lie_subalgebra_map_apply (x : L₁'') : ↑(e.lie_subalgebra_map _  x) = e x := rfl

/-- An equivalence of Lie algebras restricts to an equivalence from any Lie subalgebra onto its
image. -/
def of_subalgebras (h : L₁'.map ↑e = L₂') : L₁' ≃ₗ⁅R⁆ L₂' :=
{ map_lie' := λ x y, by { apply set_coe.ext, exact lie_hom.map_lie (↑e : L₁ →ₗ⁅R⁆ L₂) ↑x ↑y, },
  ..(linear_equiv.of_submodules (e : L₁ ≃ₗ[R] L₂) ↑L₁' ↑L₂' (by { rw ←h, refl, })) }

@[simp] lemma of_subalgebras_apply (h : L₁'.map ↑e = L₂') (x : L₁') :
  ↑(e.of_subalgebras _ _ h x) = e x := rfl

@[simp] lemma of_subalgebras_symm_apply (h : L₁'.map ↑e = L₂') (x : L₂') :
  ↑((e.of_subalgebras _ _ h).symm x) = e.symm x := rfl

end lie_equiv


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

! This file was ported from Lean 3 source module category_theory.sites.surjective
! 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.Sites.Subsheaf
import Mathbin.CategoryTheory.Sites.CompatibleSheafification

/-!

# Locally surjective morphisms

## Main definitions

- `is_locally_surjective` : A morphism of presheaves valued in a concrete category is locally
  surjective with respect to a grothendieck topology if every section in the target is locally
  in the set-theoretic image, i.e. the image sheaf coincides with the target.

## Main results

- `to_sheafify_is_locally_surjective` : `to_sheafify` is locally surjective.

-/

universe v u w v' u' w'

open Opposite CategoryTheory CategoryTheory.GrothendieckTopology

namespace CategoryTheory

variable {C : Type u} [Category.{v} C] (J : GrothendieckTopology C)

attribute [local instance] concrete_category.has_coe_to_sort concrete_category.has_coe_to_fun

variable {A : Type u'} [Category.{v'} A] [ConcreteCategory.{w'} A]

/-- Given `f : F ⟶ G`, a morphism between presieves, and `s : G.obj (op U)`, this is the sieve
of `U` consisting of the `i : V ⟶ U` such that `s` restricted along `i` is in the image of `f`. -/
@[simps (config := lemmasOnly)]
def imageSieve {F G : Cᵒᵖ ⥤ A} (f : F ⟶ G) {U : C} (s : G.obj (op U)) : Sieve U
    where
  arrows V i := ∃ t : F.obj (op V), f.app _ t = G.map i.op s
  downward_closed' := by
    rintro V W i ⟨t, ht⟩ j
    refine' ⟨F.map j.op t, _⟩
    rw [op_comp, G.map_comp, comp_apply, ← ht, elementwise_of f.naturality]
#align category_theory.image_sieve CategoryTheory.imageSieve

theorem imageSieve_eq_sieveOfSection {F G : Cᵒᵖ ⥤ A} (f : F ⟶ G) {U : C} (s : G.obj (op U)) :
    imageSieve f s = (imagePresheaf (whiskerRight f (forget A))).sieveOfSection s :=
  rfl
#align category_theory.image_sieve_eq_sieve_of_section CategoryTheory.imageSieve_eq_sieveOfSection

theorem imageSieve_whisker_forget {F G : Cᵒᵖ ⥤ A} (f : F ⟶ G) {U : C} (s : G.obj (op U)) :
    imageSieve (whiskerRight f (forget A)) s = imageSieve f s :=
  rfl
#align category_theory.image_sieve_whisker_forget CategoryTheory.imageSieve_whisker_forget

theorem imageSieve_app {F G : Cᵒᵖ ⥤ A} (f : F ⟶ G) {U : C} (s : F.obj (op U)) :
    imageSieve f (f.app _ s) = ⊤ := by
  ext (V i)
  simp only [sieve.top_apply, iff_true_iff, image_sieve_apply]
  have := elementwise_of (f.naturality i.op)
  exact ⟨F.map i.op s, this s⟩
#align category_theory.image_sieve_app CategoryTheory.imageSieve_app

/-- A morphism of presheaves `f : F ⟶ G` is locally surjective with respect to a grothendieck
topology if every section of `G` is locally in the image of `f`. -/
def IsLocallySurjective {F G : Cᵒᵖ ⥤ A} (f : F ⟶ G) : Prop :=
  ∀ (U : C) (s : G.obj (op U)), imageSieve f s ∈ J U
#align category_theory.is_locally_surjective CategoryTheory.IsLocallySurjective

theorem isLocallySurjective_iff_imagePresheaf_sheafify_eq_top {F G : Cᵒᵖ ⥤ A} (f : F ⟶ G) :
    IsLocallySurjective J f ↔ (imagePresheaf (whiskerRight f (forget A))).sheafify J = ⊤ :=
  by
  simp only [subpresheaf.ext_iff, Function.funext_iff, Set.ext_iff, top_subpresheaf_obj,
    Set.top_eq_univ, Set.mem_univ, iff_true_iff]
  exact ⟨fun H U => H (unop U), fun H U => H (op U)⟩
#align category_theory.is_locally_surjective_iff_image_presheaf_sheafify_eq_top CategoryTheory.isLocallySurjective_iff_imagePresheaf_sheafify_eq_top

theorem isLocallySurjective_iff_imagePresheaf_sheafify_eq_top' {F G : Cᵒᵖ ⥤ Type w} (f : F ⟶ G) :
    IsLocallySurjective J f ↔ (imagePresheaf f).sheafify J = ⊤ :=
  by
  simp only [subpresheaf.ext_iff, Function.funext_iff, Set.ext_iff, top_subpresheaf_obj,
    Set.top_eq_univ, Set.mem_univ, iff_true_iff]
  exact ⟨fun H U => H (unop U), fun H U => H (op U)⟩
#align category_theory.is_locally_surjective_iff_image_presheaf_sheafify_eq_top' CategoryTheory.isLocallySurjective_iff_imagePresheaf_sheafify_eq_top'

theorem isLocallySurjective_iff_isIso {F G : Sheaf J (Type w)} (f : F ⟶ G) :
    IsLocallySurjective J f.1 ↔ IsIso (imageSheafι f) :=
  by
  rw [image_sheaf_ι, is_locally_surjective_iff_image_presheaf_sheafify_eq_top',
    subpresheaf.eq_top_iff_is_iso]
  exact
    ⟨fun h => @is_iso_of_reflects_iso _ _ (image_sheaf_ι f) (Sheaf_to_presheaf J _) h _, fun h =>
      @functor.map_is_iso _ _ (Sheaf_to_presheaf J _) _ h⟩
#align category_theory.is_locally_surjective_iff_is_iso CategoryTheory.isLocallySurjective_iff_isIso

theorem isLocallySurjective_iff_whisker_forget {F G : Cᵒᵖ ⥤ A} (f : F ⟶ G) :
    IsLocallySurjective J f ↔ IsLocallySurjective J (whiskerRight f (forget A)) := by
  simpa only [is_locally_surjective_iff_image_presheaf_sheafify_eq_top]
#align category_theory.is_locally_surjective_iff_whisker_forget CategoryTheory.isLocallySurjective_iff_whisker_forget

theorem isLocallySurjective_of_surjective {F G : Cᵒᵖ ⥤ A} (f : F ⟶ G)
    (H : ∀ U, Function.Surjective (f.app U)) : IsLocallySurjective J f :=
  by
  intro U s
  obtain ⟨t, rfl⟩ := H _ s
  rw [image_sieve_app]
  exact J.top_mem _
#align category_theory.is_locally_surjective_of_surjective CategoryTheory.isLocallySurjective_of_surjective

theorem isLocallySurjective_of_iso {F G : Cᵒᵖ ⥤ A} (f : F ⟶ G) [IsIso f] :
    IsLocallySurjective J f :=
  by
  apply is_locally_surjective_of_surjective
  intro U
  apply Function.Bijective.surjective
  rw [← is_iso_iff_bijective]
  infer_instance
#align category_theory.is_locally_surjective_of_iso CategoryTheory.isLocallySurjective_of_iso

theorem IsLocallySurjective.comp {F₁ F₂ F₃ : Cᵒᵖ ⥤ A} {f₁ : F₁ ⟶ F₂} {f₂ : F₂ ⟶ F₃}
    (h₁ : IsLocallySurjective J f₁) (h₂ : IsLocallySurjective J f₂) :
    IsLocallySurjective J (f₁ ≫ f₂) := by
  intro U s
  have :
    (sieve.bind (image_sieve f₂ s) fun _ _ h => image_sieve f₁ h.some) ≤ image_sieve (f₁ ≫ f₂) s :=
    by
    rintro V i ⟨W, i, j, H, ⟨t', ht'⟩, rfl⟩
    refine' ⟨t', _⟩
    rw [op_comp, F₃.map_comp, nat_trans.comp_app, comp_apply, comp_apply, ht',
      elementwise_of f₂.naturality, H.some_spec]
  apply J.superset_covering this
  apply J.bind_covering
  · apply h₂
  · intros
    apply h₁
#align category_theory.is_locally_surjective.comp CategoryTheory.IsLocallySurjective.comp

section

variable (F : Cᵒᵖ ⥤ Type max u v)

/-- The image of `F` in `J.sheafify F` is isomorphic to the sheafification. -/
noncomputable def sheafificationIsoImagePresheaf :
    J.sheafify F ≅ ((imagePresheaf (J.toSheafify F)).sheafify J).toPresheaf
    where
  Hom :=
    J.sheafifyLift (toImagePresheafSheafify J _)
      ((isSheaf_iff_isSheaf_of_type J _).mpr <|
        Subpresheaf.sheafify_isSheaf _ <|
          (isSheaf_iff_isSheaf_of_type J _).mp <| sheafify_isSheaf J _)
  inv := Subpresheaf.ι _
  hom_inv_id' :=
    J.sheafify_hom_ext _ _ (J.sheafify_isSheaf _) (by simp [to_image_presheaf_sheafify])
  inv_hom_id' :=
    by
    rw [← cancel_mono (subpresheaf.ι _), category.id_comp, category.assoc]
    refine' Eq.trans _ (category.comp_id _)
    congr 1
    exact J.sheafify_hom_ext _ _ (J.sheafify_is_sheaf _) (by simp [to_image_presheaf_sheafify])
    infer_instance
#align category_theory.sheafification_iso_image_presheaf CategoryTheory.sheafificationIsoImagePresheaf

-- We need to sheafify
variable {B : Type w} [Category.{max u v} B] [ConcreteCategory.{max u v} B]
  [∀ X : C, Limits.HasColimitsOfShape (J.cover X)ᵒᵖ B]
  [∀ (P : Cᵒᵖ ⥤ B) (X : C) (S : J.cover X), Limits.HasMultiequalizer (S.index P)]
  [∀ (X : C) (W : J.cover X) (P : Cᵒᵖ ⥤ B),
      Limits.PreservesLimit (W.index P).multicospan (forget B)]
  [∀ X : C, Limits.PreservesColimitsOfShape (J.cover X)ᵒᵖ (forget B)]
  [∀ (α β : Type max u v) (fst snd : β → α),
      Limits.HasLimitsOfShape (Limits.WalkingMulticospan fst snd) B]

theorem toSheafify_isLocallySurjective (F : Cᵒᵖ ⥤ B) : IsLocallySurjective J (J.toSheafify F) :=
  by
  rw [is_locally_surjective_iff_whisker_forget, ← to_sheafify_comp_sheafify_comp_iso_inv]
  apply is_locally_surjective.comp
  · rw [is_locally_surjective_iff_image_presheaf_sheafify_eq_top, subpresheaf.eq_top_iff_is_iso]
    exact is_iso.of_iso_inv (sheafification_iso_image_presheaf J (F ⋙ forget B))
  · exact is_locally_surjective_of_iso _ _
#align category_theory.to_sheafify_is_locally_surjective CategoryTheory.toSheafify_isLocallySurjective

end

end CategoryTheory