import set_category.diagram_lemmas
import set_category.category_set
import set_category.em_square
import help_functions

namespace coalgebra

open category_theory
     set
     category_set
     diagram_lemmas
     help_functions
     classical
     em_square

universes v u

local notation f ` ⊚ `:80 g:80 := category_struct.comp g f

/-- The stucture of coalgebra of signature F -/
structure Coalgebra (F : Type u ⥤ Type u) : Type (u+1) :=
    (carrier : Type u) (α : carrier ⟶ F.obj carrier)

variables {F : Type u ⥤ Type u}

/-- Allows us to use the coalgebra as a Type referring to its carrier-/
instance Coalgebra_to_sort : has_coe_to_sort (Coalgebra F) :=
    ⟨Type u,  λ 𝔸, 𝔸.carrier⟩

variables {𝔸 Β ℂ: Coalgebra F}

/--
    A Set-Category morphism(φ : A -> B) is coalgebra morphism iff
    α_B ∘ φ =  F φ ∘ α_A
-/
@[simp , tidy] def is_coalgebra_homomorphism
        (ϕ : 𝔸 →  Β) : Prop :=
        Β.α ∘ ϕ =  (F.map ϕ) ∘ 𝔸.α

/--
    The subtype of coalgebra-homomorphism
-/
def homomorphism (𝔸 Β : Coalgebra F) : set (𝔸 → Β):=
    λ ϕ , is_coalgebra_homomorphism ϕ

/-- Allows us to use a homomorphism as a map-/
instance homomorphism_to_map (𝔸 Β : Coalgebra F) :
    has_coe_to_fun (homomorphism 𝔸 Β) :=
    { F := λ _, 𝔸 → Β, coe := λ m, m.val}

/--
    A proof that id is a coalgebra-homomorphism
-/
lemma id_is_hom (𝔸 : Coalgebra F):
     is_coalgebra_homomorphism (@id 𝔸) :=
     show 𝔸.α ∘ id =  (F.map id) ∘ 𝔸.α, from
        calc 𝔸.α ∘ id = (𝟙 (F.obj 𝔸)) ∘ 𝔸.α     : rfl
                ...   = (F.map (𝟙 𝔸)) ∘ 𝔸.α     : by rw ← functor.map_id' F 𝔸

/--
    A proof that composition of two homomorphism is a coalgebra-homomorphism
-/
lemma comp_is_hom (φ : homomorphism 𝔸 Β) (ψ : homomorphism Β ℂ)
    : is_coalgebra_homomorphism (ψ ∘ φ) :=
        have ab : Β.α ∘ φ =  F.map φ ∘ 𝔸.α := φ.property,
        have bc : ℂ.α ∘ ψ =  F.map ψ ∘ Β.α := ψ.property,

        calc
        (ℂ.α ∘ ψ) ∘ φ = (F.map ψ) ∘ Β.α  ∘ φ    : by rw bc
        ... = (F.map ψ) ∘ (F.map φ) ∘ 𝔸.α      : by rw ab
        ... = ((F.map ψ) ⊚ (F.map φ)) ∘ 𝔸.α   : rfl
        ... = (F.map (ψ ⊚ φ)) ∘ 𝔸.α           : by rw ← functor.map_comp

/--
    The category of Coalgebras of the signature F (Set-F)
-/
instance coalgebra_category : category (Coalgebra F) :=
{
    hom  := λ 𝔸 Β, homomorphism 𝔸 Β,
    id   := λ 𝔸 , ⟨@id 𝔸, id_is_hom 𝔸⟩ ,
    comp := λ 𝔸 Β ℂ φ ψ, ⟨ψ ∘ φ, comp_is_hom φ ψ⟩
}

instance set_F_to_set : has_coe (𝔸 ⟶ Β) (𝔸.carrier ⟶ Β.carrier)
    := ⟨λ ϕ :𝔸 ⟶ Β, ϕ⟩

open function

lemma empty_hom_dom (ϕ : 𝔸.carrier ⟶ Β.carrier)
    (em_𝔸 : ¬ nonempty 𝔸):
    is_coalgebra_homomorphism ϕ :=
    begin
        dsimp at *,
        ext1,
        have ex : ∃ a : 𝔸 , true := exists.intro x trivial,
        exact absurd (nonempty_of_exists ex) em_𝔸
    end

lemma empty_hom_codom (ϕ : 𝔸.carrier ⟶ Β.carrier)
    (em_Β : ¬ nonempty Β):
    is_coalgebra_homomorphism ϕ :=
    begin
        dsimp at *,
        ext1,
        have ex : ∃ b : Β , true := exists.intro (ϕ x) trivial,
        exact absurd (nonempty_of_exists ex) em_Β
    end

noncomputable
def empty_map (S : Type u) (emp : ¬ nonempty S) (X : Type u):
    S → X :=
    graph_to_map (λ s fs, false) -- ∀ a : A , ∃! b : B, G a b
    (λ s, absurd (⟨s⟩ : nonempty S) emp)

lemma not_nonempty_empty : ¬ nonempty (∅: set 𝔸) :=
assume ⟨s⟩, by tidy

noncomputable
def empty_coalgebra : Coalgebra F :=
    {
        carrier := (∅ : set 𝔸),
        α       := empty_map (∅ : set 𝔸) not_nonempty_empty (F.obj (∅ : set 𝔸))
    }

/--
    The inverse of homomorphism is homomorphism if the
    the homomorphism is bijective.
-/
theorem bij_inverse_of_hom_is_hom
    (φ : homomorphism 𝔸 Β)
    (bij : bijective φ) :
        let inv : Β → 𝔸 := some (bijective_iff_has_inverse.1 bij) in
        is_coalgebra_homomorphism inv :=
        begin
            intro inv,
            let hom :Β.α ∘ φ =  F.map φ ∘ 𝔸.α := φ.property,
            have has_lr_inv :left_inverse inv φ ∧ right_inverse inv φ
                := some_spec (bijective_iff_has_inverse.1 bij),

            calc
            𝔸.α ∘ inv = id ∘ 𝔸.α ∘ inv                     : rfl
            ... = (𝟙 (F.obj 𝔸)) ∘ 𝔸.α ∘ inv                : rfl
            ... = (F.map (𝟙 𝔸)) ∘ 𝔸.α ∘ inv                : by rw ← functor.map_id'
            ... = (F.map id) ∘ 𝔸.α ∘ inv                   : rfl
            ... = (F.map (inv ∘ φ)) ∘ 𝔸.α ∘ inv            : by rw id_of_left_inverse has_lr_inv.1
            ... = (F.map (inv ⊚ φ)) ∘ 𝔸.α ∘ inv           : rfl
            ... = ((F.map inv) ⊚ (F.map φ)) ∘ 𝔸.α ∘ inv   : by rw ← functor.map_comp
            ... = (F.map inv) ∘ ((F.map φ) ∘ 𝔸.α) ∘ inv    : rfl
            ... = (F.map inv) ∘ (Β.α ∘ φ) ∘ inv            : by rw hom
            ... = (F.map inv) ∘ Β.α ∘ (φ ∘ inv)            : rfl
            ... = ((F.map inv) ∘ Β.α ∘ id)                 : by rw id_of_right_inverse has_lr_inv.2
            ... = (F.map inv) ∘ Β.α                        : rfl
        end
/--
    Let 𝔸, Β, and ℂ be coalgebras and
    f : A → B, g : B → C set maps,
    so that ϕ := g ∘ f : A → C is a homomorphism.

    If f is a surjective homomorphism, then g is a homomorphism.
-/
lemma surj_to_hom
            (f : 𝔸.carrier ⟶ Β.carrier)
            (g : Β.carrier ⟶ ℂ.carrier)
            (hom_gf : is_coalgebra_homomorphism (g ∘ f))
            (hom_f : is_coalgebra_homomorphism f)
            (ep : epi f)
                : is_coalgebra_homomorphism g :=

        have  h1 : (ℂ.α ∘ g) ⊚ f = (F.map g ∘ Β.α) ⊚ f :=
        calc
        (ℂ.α ∘ g) ⊚ f = F.map (g ⊚ f) ∘ 𝔸.α   : hom_gf
        ... = (F.map g ⊚ F.map f) ∘ 𝔸.α        : by rw functor.map_comp
        ... = F.map g ∘ F.map f ∘ 𝔸.α           : by tidy
        ... = F.map g ∘ Β.α ∘ f                 : by rw [eq.symm hom_f],
        right_cancel f h1

/--
    If g is an injective homomorphismus, then f is a homomorphism.
-/
lemma inj_to_hom (f : 𝔸.carrier → Β.carrier)
               (g : Β.carrier → ℂ.carrier)
            (hom_gf : is_coalgebra_homomorphism (g ∘ f))
            (hom_g : is_coalgebra_homomorphism g)
            (inj : injective g)
                : is_coalgebra_homomorphism f :=
    begin
        cases classical.em (nonempty Β) with n_em_Β emp_Β,
        have  h1 : (F.map g) ⊚ (F.map f) ⊚ 𝔸.α = F.map g ⊚ (Β.α ⊚ f) :=
        calc
        ((F.map g) ⊚ (F.map f)) ∘ 𝔸.α
                = (F.map (g ⊚ f)) ∘ 𝔸.α  : by rw functor.map_comp
        ...     = F.map (g ∘ f) ∘ 𝔸.α     : rfl
        ...     = ℂ.α ∘ g ∘ f             : by rw [eq.symm hom_gf]
        ...     = (F.map g ∘ Β.α) ∘ f     : by rw [eq.symm hom_g],

        haveI inh_Β : inhabited Β := ⟨choice n_em_Β⟩,

        haveI fg_mono : mono (F.map g) := mono_preserving_functor g inj,

        exact  left_cancel (F.map g) (eq.symm h1),

        exact empty_hom_codom f emp_Β
    end

/--
    Let ϕ : 𝔸 → Β, ψ : 𝔸 → ℂ be homomorphisms,
    and ϕ is surjective.

    Then there exists a unique homomorphism χ : Β ⟶ ℂ,
    such that χ ∘ ϕ = ψ
    iff kern ϕ ⊆ kern ψ
-/
lemma coalgebra_diagram (ϕ : homomorphism 𝔸 Β)
                        (ψ : homomorphism 𝔸 ℂ)
                        (sur : surjective ϕ)
            :   (∃! χ : homomorphism Β ℂ , χ ∘ ϕ = ψ) ↔
                (sub_kern ϕ ψ)
                :=
    iff.intro
    -- The "exists such χ" → "kern ϕ ⊆ kern ψ" direction:
    begin
        intro ex,
        cases ex with χ h1,

        exact h1.left ▸ (kern_comp ϕ χ)
    end
    -- The "kern ϕ ⊆ kern ψ" → "exists a unique χ" direction:
    begin
        intro k,
        -- using the diagram lemma of Set-Category to
        -- prove the existance and uniqueness of such morphism
        have ex_uni : ∃ χ : Β → ℂ,
            (χ ∘ ϕ = ψ  ∧ ∀ χ₁, χ₁ ∘ ϕ = ψ → χ₁ = χ)
            := (diagram_surjective ϕ ψ sur).2 k,

        cases ex_uni with χ spec,
        -- χ : Β → ℂ
        -- spec : χ ∘ ϕ = ψ  ∧ ∀ χ₁, χ₁ ∘ ϕ = ψ → χ₁ = χ

        have hom_χ_ϕ : is_coalgebra_homomorphism (χ ∘ ϕ) :=
            (eq.symm spec.left) ▸ ψ.property,

        have hom_χ : is_coalgebra_homomorphism χ :=
            surj_to_hom ϕ χ hom_χ_ϕ ϕ.property
                    ((epi_iff_surjective ϕ).2 sur),

        have unique : ∀ (χ₁ : homomorphism Β ℂ),
                    χ₁ ∘ ϕ = ψ
                    → χ₁ = ⟨χ , hom_χ⟩ := by tidy,

        exact exists_unique.intro ⟨χ , hom_χ⟩
                                  spec.left unique
    end

/--
Let Q be a nonempty set,
    ϕ : 𝔸 ⟶ Β be a homomorphisms,
    f : A → Q and g : Q → B be maps with ϕ = g ∘ f and
    f surjective and g injective

    Then there exists a unique α_Q : Q → F(Q) coalgebra structure
    such that both f and g are homomorphisms.
-/
theorem Factorization {Q : Type u}
    (ϕ : homomorphism 𝔸 Β)
    (f : 𝔸.carrier ⟶ Q)
    (g : Q ⟶ Β.carrier)
    (h : ϕ.val = g ∘ f)
    (ep : epi f)
    (inj : injective g):
        ∃! α_Q : Q ⟶ F.obj Q ,
            @is_coalgebra_homomorphism F 𝔸 ⟨Q , α_Q⟩ f ∧
            @is_coalgebra_homomorphism F ⟨Q , α_Q⟩ Β g
    :=
begin
    cases classical.em (nonempty 𝔸) with n_em_𝔸 emp_𝔸,
    haveI inh_𝔸 : inhabited 𝔸 := ⟨choice n_em_𝔸⟩ ,
    haveI inh_ℚ : inhabited Q := ⟨f (default 𝔸)⟩,
    let hom_ϕ := ϕ.property,
    /-
        Using the E-M-Square
        A      ⟶(f)⟶     Q   ⟶(Β.α ∘ g)⟶ F(B),
        A ⟶(F f ∘ α_𝔸)⟶ F(Q)   ⟶(F g)⟶   F(B)
    -/
    /-
        showing that the triangles commute
    -/

    have commute
        : (Β.α ∘ g) ∘ f = (F.map g) ∘ ((F.map f) ∘ 𝔸.α) :=
        calc Β.α ∘ g ∘ f = Β.α ∘ ϕ.val                      : by simp [h]
                 ...     = (F.map ϕ.val) ∘ 𝔸.α             : hom_ϕ
                 ...     = (F.map (g ∘ f)) ∘ 𝔸.α           : by rw [h]
                 ...     = (F.map (g ⊚ f)) ∘ 𝔸.α           : rfl
                 ...     = ((F.map g) ⊚ (F.map f)) ∘ 𝔸.α   : by rw functor.map_comp
                 ...     = (F.map g) ∘ (F.map f) ∘ 𝔸.α     : by simp,

    /-
        we get the existance and the uniqueness of d
        the diagonal of the square and the coalgebra structure
    -/
    have em_square : _ := E_M_square
                f ep
                (Β.α ∘ g) ((F.map f) ∘ 𝔸.α) (F.map g)
                (mono_preserving_functor g inj)
                commute,

    cases em_square with d spec,

    have uni_d : _ := spec.2,

    let ℚ : Coalgebra F := ⟨Q , d⟩,

    have homomorphism_f : @is_coalgebra_homomorphism F 𝔸 ℚ f :=
        eq.symm spec.left.left,

    have homomorphism_g : @is_coalgebra_homomorphism F ℚ Β g :=
        spec.left.right,

    have unique : ∀ (α_Q : Q ⟶ F.obj Q),
        @is_coalgebra_homomorphism F 𝔸 ⟨Q , α_Q⟩ f ∧
        @is_coalgebra_homomorphism F ⟨Q , α_Q⟩ Β g →
        α_Q = d :=
        assume α_Q ⟨hom_f , hom_g⟩,
        uni_d α_Q ⟨eq.symm hom_f , hom_g⟩,

    exact
    exists_unique.intro
        d
        ⟨homomorphism_f , homomorphism_g⟩
        unique,

    have A_Q : nonempty Q → nonempty 𝔸 :=
       λ n_Q, ⟨some ((epi_iff_surjective f).1 ep (choice n_Q))⟩,
    have em_Q : nonempty Q → false :=
        λ n_Q, emp_𝔸 (A_Q n_Q),
    have n_Q : ¬ (nonempty Q) := em_Q,
    let α_Q : Q → F.obj Q := empty_map Q n_Q (F.obj Q),
    have hom_f : @is_coalgebra_homomorphism F 𝔸 ⟨Q , α_Q⟩ f
        := empty_hom_dom f emp_𝔸,
    exact exists_unique.intro α_Q
        ⟨hom_f , by tidy⟩ (by tidy)

end

theorem factorization {Q : Type u}
    (ϕ : homomorphism 𝔸 Β)
    (f : 𝔸.carrier ⟶ Q) (g : Q ⟶ Β.carrier)
    (h : ϕ.val = g ∘ f)
    (sur : surjective f)
    (inj : injective g) :
        (∃! α_Q : Q ⟶ F.obj Q ,
            @is_coalgebra_homomorphism F 𝔸 ⟨Q , α_Q⟩ f)
    :=
begin
    cases classical.em (nonempty 𝔸) with n_em_𝔸 emp_𝔸,
    haveI inh : inhabited 𝔸 := ⟨choice n_em_𝔸⟩ ,
    let hom_ϕ := ϕ.property,
    /-
        Using the E-M-Square
        A      ⟶(f)⟶     Q   ⟶(Β.α ∘ g)⟶ F(B),
        A ⟶(F f ∘ α_𝔸)⟶ F(Q)   ⟶(F g)⟶   F(B)
    -/
    /-
        showing that the triangles commute
    -/
    have commute
        : (Β.α ∘ g) ∘ f = (F.map g) ∘ ((F.map f) ∘ 𝔸.α) :=
        calc Β.α ∘ g ∘ f = Β.α ∘ ϕ.val                      : by simp [h]
                 ...     = (F.map ϕ.val) ∘ 𝔸.α             : hom_ϕ
                 ...     = (F.map (g ∘ f)) ∘ 𝔸.α           : by rw [h]
                 ...     = (F.map (g ⊚ f)) ∘ 𝔸.α           : rfl
                 ...     = ((F.map g) ⊚ (F.map f)) ∘ 𝔸.α   : by rw functor.map_comp
                 ...     = (F.map g) ∘ (F.map f) ∘ 𝔸.α     : by simp,

    haveI inh_Q : inhabited Q := ⟨f (default 𝔸)⟩ ,

    haveI epi_f : epi f := (epi_iff_surjective f).2 sur,
    haveI mono_Fg : mono (F.map g) := mono_preserving_functor g inj,
    /-
        we get the existance and the uniqueness of d
        the diagonal of the square and the coalgebra structure
    -/
    have em_square : _ := E_M_square
        f epi_f (Β.α ∘ g) ((F.map f) ∘ 𝔸.α)
            (F.map g) mono_Fg commute,

    cases em_square with d spec,

    have homomorphism_f : d ⊚ f = (F.map f) ⊚ 𝔸.α :=
        eq.symm spec.left.left,

    have com_tri_epi := commutative_triangles_epi
        f (Β.α ∘ g) ((F.map f) ∘ 𝔸.α) (F.map g) commute d (eq.symm homomorphism_f),

    have uni_f : ∀ (α_Q : Q ⟶ F.obj Q),
        @is_coalgebra_homomorphism F 𝔸 ⟨Q , α_Q⟩ f →
        α_Q = d :=
        assume α_Q hom_f,
        have com : α_Q ⊚ f = F.map f ∘ 𝔸.α := hom_f,
        com_tri_epi.1 α_Q (eq.symm com),

    exact exists_unique.intro d
        homomorphism_f uni_f,

    have A_Q : nonempty Q → nonempty 𝔸 :=
       λ n_Q, ⟨some (sur (choice n_Q))⟩,
    have em_Q : nonempty Q → false :=
        λ n_Q, emp_𝔸 (A_Q n_Q),
    have n_Q : ¬ (nonempty Q) := em_Q,
    let α_Q : Q → F.obj Q := empty_map Q n_Q (F.obj Q),
    have hom_f : @is_coalgebra_homomorphism F 𝔸 ⟨Q , α_Q⟩ f
        := empty_hom_dom f emp_𝔸,
    exact exists_unique.intro α_Q hom_f (by tidy)
end

theorem factorization_hom {Q : Type u}
    (ϕ : homomorphism 𝔸 Β)
    (f : 𝔸.carrier ⟶ Q) (g : Q ⟶ Β.carrier)
    (h : ϕ.val = g ∘ f)
    (sur : surjective f)
    (inj : injective g)
    [inhabited 𝔸] :
    let α_Q := some (factorization ϕ f g h sur inj) in
        @is_coalgebra_homomorphism F ⟨Q , α_Q⟩ Β g :=
    begin
        intros α_Q,

        have hom_ϕ := ϕ.property,

        have commute : (Β.α ∘ g) ∘ f = (F.map g) ∘ ((F.map f) ∘ 𝔸.α) :=
            calc Β.α ∘ g ∘ f
                        = Β.α ∘ ϕ.val                      : by simp [h]
                    ... = (F.map ϕ.val) ∘ 𝔸.α             : hom_ϕ
                    ... = (F.map (g ∘ f)) ∘ 𝔸.α           : by rw [h]
                    ... = (F.map (g ⊚ f)) ∘ 𝔸.α           : rfl
                    ... = ((F.map g) ⊚ (F.map f)) ∘ 𝔸.α   : by rw functor.map_comp
                    ... = (F.map g) ∘ (F.map f) ∘ 𝔸.α     : by simp,
        haveI inh_Q : inhabited Q := ⟨f (default 𝔸)⟩ ,
        haveI epi_f : epi f := (epi_iff_surjective f).2 sur,
        haveI mono_Fg : mono (F.map g) := mono_preserving_functor g inj,

        have spec := some_spec (factorization ϕ f g h sur inj),

        have com_tri_epi : _ := commutative_triangles_epi
            f (Β.α ∘ g) ((F.map f) ∘ 𝔸.α) (F.map g) commute α_Q (eq.symm spec.1),
        exact com_tri_epi.2
    end

end coalgebra


/-
Copyright (c) 2020 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Robert Y. Lewis
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.ring_theory.witt_vector.truncated
import Mathlib.ring_theory.witt_vector.identities
import Mathlib.data.padics.ring_homs
import Mathlib.PostPort

universes u_1

namespace Mathlib

/-!

# Comparison isomorphism between `witt_vector p (zmod p)` and `ℤ_[p]`

We construct a ring isomorphism between `witt_vector p (zmod p)` and `ℤ_[p]`.
This isomorphism follows from the fact that both satisfy the universal property
of the inverse limit of `zmod (p^n)`.

## Main declarations

* `witt_vector.to_zmod_pow`: a family of compatible ring homs `𝕎 (zmod p) → zmod (p^k)`
* `witt_vector.equiv`: the isomorphism

-/

namespace truncated_witt_vector

theorem eq_of_le_of_cast_pow_eq_zero (p : ℕ) [hp : fact (nat.prime p)] (n : ℕ) (R : Type u_1) [comm_ring R] [char_p R p] (i : ℕ) (hin : i ≤ n) (hpi : ↑p ^ i = 0) : i = n := sorry

theorem card_zmod (p : ℕ) [hp : fact (nat.prime p)] (n : ℕ) : fintype.card (truncated_witt_vector p n (zmod p)) = p ^ n :=
  eq.mpr (id (Eq._oldrec (Eq.refl (fintype.card (truncated_witt_vector p n (zmod p)) = p ^ n)) (card p n)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (fintype.card (zmod p) ^ n = p ^ n)) (zmod.card p))) (Eq.refl (p ^ n)))

theorem char_p_zmod (p : ℕ) [hp : fact (nat.prime p)] (n : ℕ) : char_p (truncated_witt_vector p n (zmod p)) (p ^ n) :=
  char_p_of_prime_pow_injective (truncated_witt_vector p n (zmod p)) p n (card_zmod p n)
    (eq_of_le_of_cast_pow_eq_zero p n (zmod p))

/--
The unique isomorphism between `zmod p^n` and `truncated_witt_vector p n (zmod p)`.

This isomorphism exists, because `truncated_witt_vector p n (zmod p)` is a finite ring
with characteristic and cardinality `p^n`.
-/
def zmod_equiv_trunc (p : ℕ) [hp : fact (nat.prime p)] (n : ℕ) : zmod (p ^ n) ≃+* truncated_witt_vector p n (zmod p) :=
  zmod.ring_equiv (truncated_witt_vector p n (zmod p)) (card_zmod p n)

theorem zmod_equiv_trunc_apply (p : ℕ) [hp : fact (nat.prime p)] (n : ℕ) {x : zmod (p ^ n)} : coe_fn (zmod_equiv_trunc p n) x = coe_fn (zmod.cast_hom (dvd_refl (p ^ n)) (truncated_witt_vector p n (zmod p))) x :=
  rfl

/--
The following diagram commutes:
```text
          zmod (p^n) ----------------------------> zmod (p^m)
            |                                        |
            |                                        |
            v                                        v
truncated_witt_vector p n (zmod p) ----> truncated_witt_vector p m (zmod p)
```
Here the vertical arrows are `truncated_witt_vector.zmod_equiv_trunc`,
the horizontal arrow at the top is `zmod.cast_hom`,
and the horizontal arrow at the bottom is `truncated_witt_vector.truncate`.
-/
theorem commutes (p : ℕ) [hp : fact (nat.prime p)] (n : ℕ) {m : ℕ} (hm : n ≤ m) : ring_hom.comp (truncate hm) (ring_equiv.to_ring_hom (zmod_equiv_trunc p m)) =
  ring_hom.comp (ring_equiv.to_ring_hom (zmod_equiv_trunc p n)) (zmod.cast_hom (pow_dvd_pow p hm) (zmod (p ^ n))) :=
  ring_hom.ext_zmod (ring_hom.comp (truncate hm) (ring_equiv.to_ring_hom (zmod_equiv_trunc p m)))
    (ring_hom.comp (ring_equiv.to_ring_hom (zmod_equiv_trunc p n)) (zmod.cast_hom (pow_dvd_pow p hm) (zmod (p ^ n))))

theorem commutes' (p : ℕ) [hp : fact (nat.prime p)] (n : ℕ) {m : ℕ} (hm : n ≤ m) (x : zmod (p ^ m)) : coe_fn (truncate hm) (coe_fn (zmod_equiv_trunc p m) x) =
  coe_fn (zmod_equiv_trunc p n) (coe_fn (zmod.cast_hom (pow_dvd_pow p hm) (zmod (p ^ n))) x) := sorry

theorem commutes_symm' (p : ℕ) [hp : fact (nat.prime p)] (n : ℕ) {m : ℕ} (hm : n ≤ m) (x : truncated_witt_vector p m (zmod p)) : coe_fn (ring_equiv.symm (zmod_equiv_trunc p n)) (coe_fn (truncate hm) x) =
  coe_fn (zmod.cast_hom (pow_dvd_pow p hm) (zmod (p ^ n))) (coe_fn (ring_equiv.symm (zmod_equiv_trunc p m)) x) := sorry

/--
The following diagram commutes:
```text
truncated_witt_vector p n (zmod p) ----> truncated_witt_vector p m (zmod p)
            |                                        |
            |                                        |
            v                                        v
          zmod (p^n) ----------------------------> zmod (p^m)
```
Here the vertical arrows are `(truncated_witt_vector.zmod_equiv_trunc p _).symm`,
the horizontal arrow at the top is `zmod.cast_hom`,
and the horizontal arrow at the bottom is `truncated_witt_vector.truncate`.
-/
theorem commutes_symm (p : ℕ) [hp : fact (nat.prime p)] (n : ℕ) {m : ℕ} (hm : n ≤ m) : ring_hom.comp (ring_equiv.to_ring_hom (ring_equiv.symm (zmod_equiv_trunc p n))) (truncate hm) =
  ring_hom.comp (zmod.cast_hom (pow_dvd_pow p hm) (zmod (p ^ n)))
    (ring_equiv.to_ring_hom (ring_equiv.symm (zmod_equiv_trunc p m))) :=
  ring_hom.ext fun (x : truncated_witt_vector p m (zmod p)) => commutes_symm' p n hm x

end truncated_witt_vector

namespace witt_vector

/--
`to_zmod_pow` is a family of compatible ring homs. We get this family by composing
`truncated_witt_vector.zmod_equiv_trunc` (in right-to-left direction)
with `witt_vector.truncate`.
-/
def to_zmod_pow (p : ℕ) [hp : fact (nat.prime p)] (k : ℕ) : witt_vector p (zmod p) →+* zmod (p ^ k) :=
  ring_hom.comp (ring_equiv.to_ring_hom (ring_equiv.symm (truncated_witt_vector.zmod_equiv_trunc p k))) (truncate k)

theorem to_zmod_pow_compat (p : ℕ) [hp : fact (nat.prime p)] (m : ℕ) (n : ℕ) (h : m ≤ n) : ring_hom.comp (zmod.cast_hom (pow_dvd_pow p h) (zmod (p ^ m))) (to_zmod_pow p n) = to_zmod_pow p m := sorry

/--
`to_padic_int` lifts `to_zmod_pow : 𝕎 (zmod p) →+* zmod (p ^ k)` to a ring hom to `ℤ_[p]`
using `padic_int.lift`, the universal property of `ℤ_[p]`.
-/
def to_padic_int (p : ℕ) [hp : fact (nat.prime p)] : witt_vector p (zmod p) →+* padic_int p :=
  padic_int.lift (to_zmod_pow_compat p)

theorem zmod_equiv_trunc_compat (p : ℕ) [hp : fact (nat.prime p)] (k₁ : ℕ) (k₂ : ℕ) (hk : k₁ ≤ k₂) : ring_hom.comp (truncated_witt_vector.truncate hk)
    (ring_hom.comp (ring_equiv.to_ring_hom (truncated_witt_vector.zmod_equiv_trunc p k₂)) (padic_int.to_zmod_pow k₂)) =
  ring_hom.comp (ring_equiv.to_ring_hom (truncated_witt_vector.zmod_equiv_trunc p k₁)) (padic_int.to_zmod_pow k₁) := sorry

/--
`from_padic_int` uses `witt_vector.lift` to lift `truncated_witt_vector.zmod_equiv_trunc`
composed with `padic_int.to_zmod_pow` to a ring hom `ℤ_[p] →+* 𝕎 (zmod p)`.
-/
def from_padic_int (p : ℕ) [hp : fact (nat.prime p)] : padic_int p →+* witt_vector p (zmod p) :=
  lift
    (fun (k : ℕ) =>
      ring_hom.comp (ring_equiv.to_ring_hom (truncated_witt_vector.zmod_equiv_trunc p k)) (padic_int.to_zmod_pow k))
    (zmod_equiv_trunc_compat p)

theorem to_padic_int_comp_from_padic_int (p : ℕ) [hp : fact (nat.prime p)] : ring_hom.comp (to_padic_int p) (from_padic_int p) = ring_hom.id (padic_int p) := sorry

theorem to_padic_int_comp_from_padic_int_ext (p : ℕ) [hp : fact (nat.prime p)] (x : padic_int p) : coe_fn (ring_hom.comp (to_padic_int p) (from_padic_int p)) x = coe_fn (ring_hom.id (padic_int p)) x := sorry

theorem from_padic_int_comp_to_padic_int (p : ℕ) [hp : fact (nat.prime p)] : ring_hom.comp (from_padic_int p) (to_padic_int p) = ring_hom.id (witt_vector p (zmod p)) := sorry

theorem from_padic_int_comp_to_padic_int_ext (p : ℕ) [hp : fact (nat.prime p)] (x : witt_vector p (zmod p)) : coe_fn (ring_hom.comp (from_padic_int p) (to_padic_int p)) x = coe_fn (ring_hom.id (witt_vector p (zmod p))) x := sorry

/--
The ring of Witt vectors over `zmod p` is isomorphic to the ring of `p`-adic integers. This
equivalence is witnessed by `witt_vector.to_padic_int` with inverse `witt_vector.from_padic_int`.
-/
def equiv (p : ℕ) [hp : fact (nat.prime p)] : witt_vector p (zmod p) ≃+* padic_int p :=
  ring_equiv.mk (⇑(to_padic_int p)) (⇑(from_padic_int p)) (from_padic_int_comp_to_padic_int_ext p)
    (to_padic_int_comp_from_padic_int_ext p) sorry sorry


import category_theory.category
import category_theory.functor
import category_theory.types
import help_functions

import tactic.tidy

namespace diagram_lemmas

universe u

open classical function set category_theory help_functions

local notation f ` ⊚ ` :80 g:80 := category_struct.comp g f

variables {F : Type u ⥤ Type u}
        {A B C : Type u}

lemma diagram_injective (f: B ⟶ A)
                        (g: C ⟶ A)
                        (inj : injective f)
                        : (∃! h : C ⟶ B , f ∘ h = g) ↔
                          (range g ⊆ range f)
    :=
        iff.intro
        begin
            tidy
        end
        begin
            assume im,
            let G : C → B → Prop := λ c b , g c = f b,
            have G1 :  ∀ c : C , ∃ b : B, G c b
                    :=
                        have G10 :
                            ∀ a : A , a ∈ range g →
                                    a ∈ range f := im,
                        have G11 :
                            ∀ c : C , g c ∈ range f :=
                                λ c ,
                                have G110 : g c ∈ range g := by tidy,
                                G10 (g c) G110,
                        have G12 : ∀ c : C , ∃ b : B , g c = f b :=
                            λ c : C,
                            have G110 : g c ∈ range f := G11 c,
                            by tidy,
                        G12,
            have G2 :  ∀ c : C , ∃! b : B, G c b
                    :=
                        λ c,
                        have G20 : G c (some (G1 c)) := some_spec (G1 c),
                        have G21 : f (some (G1 c)) = g c :=
                            show f (some (G1 c)) = g c,
                            from
                                have G210 : _ := G c (some (G1 c)),
                                by tidy,
                        have G22 : ∀ b₁ : B, G c b₁ →
                                    b₁ = (some (G1 c)) :=
                                    λ b₁ : B, assume cbG : G c b₁,
                                    show b₁ = (some (G1 c)), from
                                    have G220 : f b₁ = g c := by tidy,
                                    have G221 : f (some (G1 c)) = f b₁ := by rw [G21 , G220],
                                    eq.symm (inj G221),
                        by tidy,
            let h : C ⟶ B := graph_to_map G G2,
            have G3 : ∀ c , (f ∘ h) c = g c:=
                assume c,
                have G31 : h c = some (G2 c) := by tidy,
                have G32 : _ := some_spec (G2 c),
                have G33 : G c (some (G2 c)) := and.left G32,
                by tidy,
            have G4 : f ∘ h = g := funext G3,
            have G5 : ∀ h₁ : C ⟶ B , f ∘ h₁ = g → h₁ = h :=
                    assume h₁ fh,
                    have G51 : f ∘ h₁ = f ∘ h := by rw [fh , G4],
                    have G511 : f ⊚ h₁ = f ⊚ h := by tidy,
                    have G52 : mono f := iff.elim_right (mono_iff_injective f) inj,
                    have G53 : _ := G52.right_cancellation,
                    G53 h₁ h G511,
            exact exists_unique.intro h G4 G5
        end

lemma diagram_surjective
            (f : A ⟶ B)
            (g : A ⟶ C)
            (sur: surjective f)
            :   (∃! h : B ⟶ C , h ∘ f = g) ↔
                (sub_kern f g)
    :=
        iff.intro
        begin
            assume ex : ∃ h , (h ∘ f = g ∧
                            ∀ h₁, h₁ ∘ f = g → h₁ = h),
            show ∀ a₁ a₂ , kern f a₁  a₂ → kern g a₁ a₂,
            cases ex with h spec,
            exact spec.1 ▸ kern_comp f h
        end
        begin
            assume k : ∀ a₁ a₂ , f a₁ = f a₂ → g a₁ = g a₂,
            let h : B → C := λ b : B, g (surj_inv sur b),
            have s2 : ∀ a , f (surj_inv sur (f a)) = f a :=
                assume a , surj_inv_eq sur (f a),
            have s3 : ∀ a , g (surj_inv sur (f a)) = g a :=
                assume a , k (surj_inv sur (f a)) a (s2 a),
            have s4 : ∀ a , h (f a) = g a :=
                assume a,
                show g (surj_inv sur (f a)) = g a,
                from s3 a,
            have s5:  h ∘ f = g := funext s4,
            have s6 : ∀ h₂ :B → C , h₂ ∘ f = g → h₂ = h :=
                begin
                    assume h₂ h2,
                    have s61 : h₂ ∘ f = h ∘ f := by simp [s5 , h2],
                    haveI s62 : epi f := (epi_iff_surjective f).2 sur,
                    have left_cancel := s62.left_cancellation,
                    have s63 : h₂ = h := left_cancel h₂ h s61,
                    tidy
                end,

            exact exists_unique.intro h s5 s6,
        end

end diagram_lemmas


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.limits.preserves.shapes.binary_products
import Mathlib.category_theory.limits.preserves.shapes.terminal
import Mathlib.category_theory.adjunction.fully_faithful
import Mathlib.PostPort

universes v₁ v₂ u₁ u₂ l

namespace Mathlib

/-!
# Reflective functors

Basic properties of reflective functors, especially those relating to their essential image.

Note properties of reflective functors relating to limits and colimits are included in
`category_theory.monad.limits`.
-/

namespace category_theory

/--
A functor is *reflective*, or *a reflective inclusion*, if it is fully faithful and right adjoint.
-/
class reflective {C : Type u₁} {D : Type u₂} [category C] [category D] (R : D ⥤ C)
extends full R, faithful R, is_right_adjoint R
where

/--
For a reflective functor `i` (with left adjoint `L`), with unit `η`, we have `η_iL = iL η`.
-/
-- TODO: This holds more generally for idempotent adjunctions, not just reflective adjunctions.

theorem unit_obj_eq_map_unit {C : Type u₁} {D : Type u₂} [category C] [category D] {i : D ⥤ C} [reflective i] (X : C) : nat_trans.app (adjunction.unit (adjunction.of_right_adjoint i)) (functor.obj i (functor.obj (left_adjoint i) X)) =
  functor.map i (functor.map (left_adjoint i) (nat_trans.app (adjunction.unit (adjunction.of_right_adjoint i)) X)) := sorry

/--
When restricted to objects in `D` given by `i : D ⥤ C`, the unit is an isomorphism.
More generally this applies to objects essentially in the reflective subcategory, see
`functor.ess_image.unit_iso`.
-/
protected instance functor.ess_image.unit_iso_restrict {C : Type u₁} {D : Type u₂} [category C] [category D] {i : D ⥤ C} [reflective i] {B : D} : is_iso (nat_trans.app (adjunction.unit (adjunction.of_right_adjoint i)) (functor.obj i B)) :=
  eq.mpr sorry is_iso.inv_is_iso

/--
If `A` is essentially in the image of a reflective functor `i`, then `η_A` is an isomorphism.
This gives that the "witness" for `A` being in the essential image can instead be given as the
reflection of `A`, with the isomorphism as `η_A`.

(For any `B` in the reflective subcategory, we automatically have that `ε_B` is an iso.)
-/
def functor.ess_image.unit_is_iso {C : Type u₁} {D : Type u₂} [category C] [category D] {i : D ⥤ C} [reflective i] {A : C} (h : A ∈ functor.ess_image i) : is_iso (nat_trans.app (adjunction.unit (adjunction.of_right_adjoint i)) A) :=
  eq.mpr sorry is_iso.comp_is_iso

/-- If `η_A` is an isomorphism, then `A` is in the essential image of `i`. -/
theorem mem_ess_image_of_unit_is_iso {C : Type u₁} {D : Type u₂} [category C] [category D] {i : D ⥤ C} [is_right_adjoint i] (A : C) [is_iso (nat_trans.app (adjunction.unit (adjunction.of_right_adjoint i)) A)] : A ∈ functor.ess_image i :=
  Exists.intro (functor.obj (left_adjoint i) A)
    (Nonempty.intro (iso.symm (as_iso (nat_trans.app (adjunction.unit (adjunction.of_right_adjoint i)) A))))

/-- If `η_A` is a split monomorphism, then `A` is in the reflective subcategory. -/
theorem mem_ess_image_of_unit_split_mono {C : Type u₁} {D : Type u₂} [category C] [category D] {i : D ⥤ C} [reflective i] {A : C} [split_mono (nat_trans.app (adjunction.unit (adjunction.of_right_adjoint i)) A)] : A ∈ functor.ess_image i :=
  let η : 𝟭 ⟶ left_adjoint i ⋙ i := adjunction.unit (adjunction.of_right_adjoint i);
  mem_ess_image_of_unit_is_iso A


import SciLean.Core.AdjDiff

namespace SciLean

variable {α β γ : Type}
variable {X Y Z W : Type} [SemiHilbert X] [SemiHilbert Y] [SemiHilbert Z] [SemiHilbert W]
variable {Y₁ Y₂ : Type} [SemiHilbert Y₁] [SemiHilbert Y₂]
variable {ι κ : Type} [Enumtype ι] [Enumtype κ]

@[diff]
theorem adjoint_sum_eval
  (f : ι → κ → X → Y) [∀ i j, HasAdjointT (f i j)]
  : (λ (x : κ → X) => λ i => ∑ j, (f i j) (x j))†
    =
    λ y => λ j => ∑ i, (f i j)† (y i)
  := by sorry -- symdiff; sorry_proof

@[diff]
theorem adjDiff_sum_eval
  (f : ι → κ → X → Y) [hf : ∀ i j, HasAdjDiffT (f i j)]
  : ∂† (λ (x : κ → X) => λ i => ∑ j, (f i j) (x j))
    =
    λ x dy => λ j => ∑ i, ∂† (f i j) (x j) (dy i) :=
by
  unfold adjointDifferential
  have  := λ i j => (hf i j).1
  have  := λ i j => (hf i j).2
  sorry -- symdiff; symdiff
  -- done

@[diff]
theorem revDiff_sum_eval
  (f : ι → κ → X → Y) [hf : ∀ i j, HasAdjDiffT (f i j)]
  : ℛ (λ (x : κ → X) => λ i => ∑ j, (f i j) (x j))
    =
    λ x => (λ i => ∑ j, (f i j) (x j),
            λ dy => λ j => ∑ i, ∂† (f i j) (x j) (dy i)) :=
by
  unfold reverseDifferential; symdiff; done

unif_hint adjoint_sum_eval.unif_hint_1
  (f? : ι → κ → X → Y)
  (f : ι → κ → X → α → Y) (g : ι → κ → α)
where
  f? =?= λ i j x => f i j x (g i j)
  |-
  (λ (x : κ → X) => λ i => ∑ j, (f? i j) (x j))†
  =?=
  (λ (x : κ → X) => λ i => ∑ j, f i j (x j) (g i j))†

unif_hint adjoint_sum_eval.unif_hint_2
  (f? : ι → κ → X → Y)
  (f : ι → κ → W → α → Y) (g : ι → κ → α) (h : ι → κ → X → W)
where
  f? =?= λ i j x => f i j (h i j x) (g i j)
  |-
  (λ (x : κ → X) => λ i => ∑ j, (f? i j) (x j))†
  =?=
  (λ (x : κ → X) => λ i => ∑ j, f i j (h i j (x j)) (g i j))†

unif_hint adjoint_sum_eval.unif_hint_3
  (f? : ι → κ → X → Y)
  (f : ι → κ → W → Z → α → Y) (g : ι → κ → α) (h : ι → κ → X → W) (h' : ι → κ → X → Z)
where
  f? =?= λ i j x => f i j (h i j x) (h' i j x) (g i j)
  |-
  (λ (x : κ → X) => λ i => ∑ j, (f? i j) (x j))†
  =?=
  (λ (x : κ → X) => λ i => ∑ j, f i j (h i j (x j)) (h' i j (x j)) (g i j))†

unif_hint adjDiff_sum_eval.unif_hint_1
  (f? : ι → κ → X → Y)
  (f : ι → κ → X → α → Y) (g : ι → κ → α)
where
  f? =?= λ i j x => f i j x (g i j)
  |-
  ∂† (λ (x : κ → X) => λ i => ∑ j, (f? i j) (x j))
  =?=
  ∂† (λ (x : κ → X) => λ i => ∑ j, f i j (x j) (g i j))

unif_hint adjDiff_sum_eval.unif_hint_2
  (f? : ι → κ → X → Y)
  (f : ι → κ → W → α → Y) (g : ι → κ → α) (h : ι → κ → X → W)
where
  f? =?= λ i j x => f i j (h i j x) (g i j)
  |-
  ∂† (λ (x : κ → X) => λ i => ∑ j, (f? i j) (x j))
  =?=
  ∂† (λ (x : κ → X) => λ i => ∑ j, f i j (h i j (x j)) (g i j))

unif_hint adjDiff_sum_eval.unif_hint_3
  (f? : ι → κ → X → Y)
  (f : ι → κ → W → Z → α → Y) (g : ι → κ → α) (h : ι → κ → X → W) (h' : ι → κ → X → Z)
where
  f? =?= λ i j x => f i j (h i j x) (h' i j x) (g i j)
  |-
  ∂† (λ (x : κ → X) => λ i => ∑ j, (f? i j) (x j))
  =?=
  ∂† (λ (x : κ → X) => λ i => ∑ j, f i j (h i j (x j)) (h' i j (x j)) (g i j))

unif_hint revDiff_sum_eval.unif_hint_1
  (f? : ι → κ → X → Y)
  (f : ι → κ → X → α → Y) (g : ι → κ → α)
where
  f? =?= λ i j x => f i j x (g i j)
  |-
  ℛ (λ (x : κ → X) => λ i => ∑ j, (f? i j) (x j))
  =?=
  ℛ (λ (x : κ → X) => λ i => ∑ j, f i j (x j) (g i j))

unif_hint revDiff_sum_eval.unif_hint_2
  (f? : ι → κ → X → Y)
  (f : ι → κ → W → α → Y) (g : ι → κ → α) (h : ι → κ → X → W)
where
  f? =?= λ i j x => f i j (h i j x) (g i j)
  |-
  ℛ (λ (x : κ → X) => λ i => ∑ j, (f? i j) (x j))
  =?=
  ℛ (λ (x : κ → X) => λ i => ∑ j, f i j (h i j (x j)) (g i j))

unif_hint revDiff_sum_eval.unif_hint_3
  (f? : ι → κ → X → Y)
  (f : ι → κ → W → Z → α → Y) (g : ι → κ → α) (h : ι → κ → X → W) (h' : ι → κ → X → Z)
where
  f? =?= λ i j x => f i j (h i j x) (h' i j x) (g i j)
  |-
  ℛ (λ (x : κ → X) => λ i => ∑ j, (f? i j) (x j))
  =?=
  ℛ (λ (x : κ → X) => λ i => ∑ j, f i j (h i j (x j)) (h' i j (x j)) (g i j))


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon, Sean Leather
-/
import algebra.free_monoid
import algebra.opposites
import control.traversable.instances
import control.traversable.lemmas
import category_theory.endomorphism
import category_theory.types
import category_theory.category.Kleisli
/-!

# List folds generalized to `traversable`

Informally, we can think of `foldl` as a special case of `traverse` where we do not care about the
reconstructed data structure and, in a state monad, we care about the final state.

The obvious way to define `foldl` would be to use the state monad but it
is nicer to reason about a more abstract interface with `fold_map` as a
primitive and `fold_map_hom` as a defining property.

```
def fold_map {α ω} [has_one ω] [has_mul ω] (f : α → ω) : t α → ω := ...

lemma fold_map_hom (α β)
  [monoid α] [monoid β] (f : α →* β)
  (g : γ → α) (x : t γ) :
  f (fold_map g x) = fold_map (f ∘ g) x :=
...
```

`fold_map` uses a monoid ω to accumulate a value for every element of
a data structure and `fold_map_hom` uses a monoid homomorphism to
substitute the monoid used by `fold_map`. The two are sufficient to
define `foldl`, `foldr` and `to_list`. `to_list` permits the
formulation of specifications in terms of operations on lists.

Each fold function can be defined using a specialized
monoid. `to_list` uses a free monoid represented as a list with
concatenation while `foldl` uses endofunctions together with function
composition.

The definition through monoids uses `traverse` together with the
applicative functor `const m` (where `m` is the monoid). As an
implementation, `const` guarantees that no resource is spent on
reconstructing the structure during traversal.

A special class could be defined for `foldable`, similarly to Haskell,
but the author cannot think of instances of `foldable` that are not also
`traversable`.
-/

universes u v

open ulift category_theory mul_opposite

namespace monoid
variables {m : Type u → Type u} [monad m]
variables {α β : Type u}
/--
For a list, foldl f x [y₀,y₁] reduces as follows:

```
calc  foldl f x [y₀,y₁]
    = foldl f (f x y₀) [y₁]      : rfl
... = foldl f (f (f x y₀) y₁) [] : rfl
... = f (f x y₀) y₁              : rfl
```
with
```
f : α → β → α
x : α
[y₀,y₁] : list β
```

We can view the above as a composition of functions:
```
... = f (f x y₀) y₁              : rfl
... = flip f y₁ (flip f y₀ x)    : rfl
... = (flip f y₁ ∘ flip f y₀) x  : rfl
```

We can use traverse and const to construct this composition:
```
calc   const.run (traverse (λ y, const.mk' (flip f y)) [y₀,y₁]) x
     = const.run ((::) <$> const.mk' (flip f y₀) <*> traverse (λ y, const.mk' (flip f y)) [y₁]) x
...  = const.run ((::) <$> const.mk' (flip f y₀) <*>
         ( (::) <$> const.mk' (flip f y₁) <*> traverse (λ y, const.mk' (flip f y)) [] )) x
...  = const.run ((::) <$> const.mk' (flip f y₀) <*>
         ( (::) <$> const.mk' (flip f y₁) <*> pure [] )) x
...  = const.run ( ((::) <$> const.mk' (flip f y₁) <*> pure []) ∘
         ((::) <$> const.mk' (flip f y₀)) ) x
...  = const.run ( const.mk' (flip f y₁) ∘ const.mk' (flip f y₀) ) x
...  = const.run ( flip f y₁ ∘ flip f y₀ ) x
...  = f (f x y₀) y₁
```

And this is how `const` turns a monoid into an applicative functor and
how the monoid of endofunctions define `foldl`.
-/
@[reducible] def foldl (α : Type u) : Type u := (End α)ᵐᵒᵖ
def foldl.mk (f : α → α) : foldl α := op f
def foldl.get (x : foldl α) : α → α := unop x
@[simps] def foldl.of_free_monoid (f : β → α → β) : free_monoid α →* monoid.foldl β :=
{ to_fun := λ xs, op $ flip (list.foldl f) xs,
  map_one' := rfl,
  map_mul' := by intros; simp only [free_monoid.mul_def, flip, unop_op,
    list.foldl_append, op_inj]; refl }

@[reducible] def foldr (α : Type u) : Type u := End α
def foldr.mk (f : α → α) : foldr α := f
def foldr.get (x : foldr α) : α → α := x
@[simps] def foldr.of_free_monoid (f : α → β → β) : free_monoid α →* monoid.foldr β :=
{ to_fun := λ xs, flip (list.foldr f) xs,
  map_one' := rfl,
  map_mul' :=
    begin
      intros,
      simp only [free_monoid.mul_def, list.foldr_append, flip],
      refl
    end }

@[reducible] def mfoldl (m : Type u → Type u) [monad m] (α : Type u) : Type u :=
mul_opposite $ End $ Kleisli.mk m α
def mfoldl.mk (f : α → m α) : mfoldl m α := op f
def mfoldl.get (x : mfoldl m α) : α → m α := unop x
@[simps] def mfoldl.of_free_monoid [is_lawful_monad m] (f : β → α → m β) :
  free_monoid α →* monoid.mfoldl m β :=
{ to_fun := λ xs, op $ flip (list.mfoldl f) xs,
  map_one' := rfl,
  map_mul' := by intros; apply unop_injective; ext; apply list.mfoldl_append }

@[reducible] def mfoldr (m : Type u → Type u) [monad m] (α : Type u) : Type u :=
End $ Kleisli.mk m α
def mfoldr.mk (f : α → m α) : mfoldr m α := f
def mfoldr.get (x : mfoldr m α) : α → m α := x
@[simps] def mfoldr.of_free_monoid [is_lawful_monad m] (f : α → β → m β) :
  free_monoid α →* monoid.mfoldr m β :=
{ to_fun := λ xs, flip (list.mfoldr f) xs,
  map_one' := rfl,
  map_mul' := by intros; ext; apply list.mfoldr_append }

end monoid

namespace traversable
open monoid functor

section defs
variables {α β : Type u} {t : Type u → Type u} [traversable t]

def fold_map {α ω} [has_one ω] [has_mul ω] (f : α → ω) : t α → ω :=
traverse (const.mk' ∘ f)

def foldl (f : α → β → α) (x : α) (xs : t β) : α :=
(fold_map (foldl.mk ∘ flip f) xs).get x

def foldr (f : α → β → β) (x : β) (xs : t α) : β :=
(fold_map (foldr.mk ∘ f) xs).get x

/--
Conceptually, `to_list` collects all the elements of a collection
in a list. This idea is formalized by

  `lemma to_list_spec (x : t α) : to_list x = fold_map free_monoid.mk x`.

The definition of `to_list` is based on `foldl` and `list.cons` for
speed. It is faster than using `fold_map free_monoid.mk` because, by
using `foldl` and `list.cons`, each insertion is done in constant
time. As a consequence, `to_list` performs in linear.

On the other hand, `fold_map free_monoid.mk` creates a singleton list
around each element and concatenates all the resulting lists. In
`xs ++ ys`, concatenation takes a time proportional to `length xs`. Since
the order in which concatenation is evaluated is unspecified, nothing
prevents each element of the traversable to be appended at the end
`xs ++ [x]` which would yield a `O(n²)` run time. -/
def to_list : t α → list α :=
list.reverse ∘ foldl (flip list.cons) []

def length (xs : t α) : ℕ :=
down $ foldl (λ l _, up $ l.down + 1) (up 0) xs

variables {m : Type u → Type u} [monad m]

def mfoldl (f : α → β → m α) (x : α) (xs : t β) : m α :=
(fold_map (mfoldl.mk ∘ flip f) xs).get x

def mfoldr (f : α → β → m β) (x : β) (xs : t α) : m β :=
(fold_map (mfoldr.mk ∘ f) xs).get x

end defs

section applicative_transformation
variables {α β γ : Type u}

open function (hiding const)

def map_fold [monoid α] [monoid β] (f : α →* β) :
  applicative_transformation (const α) (const β) :=
{ app := λ x, f,
  preserves_seq'  := by { intros, simp only [f.map_mul, (<*>)], },
  preserves_pure' := by { intros, simp only [f.map_one, pure] } }

def free.mk : α → free_monoid α := list.ret

def free.map (f : α → β) : free_monoid α →* free_monoid β :=
{ to_fun := list.map f,
  map_mul' := λ x y,
    by simp only [free_monoid.mul_def, list.map_append, free_add_monoid.add_def],
  map_one' := by simp only [free_monoid.one_def, list.map, free_add_monoid.zero_def] }

lemma free.map_eq_map (f : α → β) (xs : list α) :
  f <$> xs = free.map f xs := rfl

lemma foldl.unop_of_free_monoid  (f : β → α → β) (xs : free_monoid α) (a : β) :
  unop (foldl.of_free_monoid f xs) a = list.foldl f a xs := rfl

variables (m : Type u → Type u) [monad m] [is_lawful_monad m]

variables {t : Type u → Type u} [traversable t] [is_lawful_traversable t]
open is_lawful_traversable

lemma fold_map_hom
  [monoid α] [monoid β] (f : α →* β)
  (g : γ → α) (x : t γ) :
  f (fold_map g x) = fold_map (f ∘ g) x :=
calc  f (fold_map g x)
    = f (traverse (const.mk' ∘ g) x)                                     : rfl
... = (map_fold f).app _ (traverse (const.mk' ∘ g) x)   : rfl
... = traverse ((map_fold f).app _ ∘ (const.mk' ∘ g)) x :
        naturality (map_fold f) _ _
... = fold_map (f ∘ g) x : rfl

lemma fold_map_hom_free
  [monoid β] (f : free_monoid α →* β) (x : t α) :
  f (fold_map free.mk x) = fold_map (f ∘ free.mk) x :=
fold_map_hom f _ x

variable {m}

lemma fold_mfoldl_cons (f : α → β → m α) (x : β) (y : α) :
  list.mfoldl f y (free.mk x) = f y x :=
by simp only [free.mk, list.ret, list.mfoldl, bind_pure]

lemma fold_mfoldr_cons (f : β → α → m α) (x : β) (y : α) :
  list.mfoldr f y (free.mk x) = f x y :=
by simp only [free.mk, list.ret, list.mfoldr, pure_bind]

end applicative_transformation

section equalities
open is_lawful_traversable list (cons)
variables {α β γ : Type u}
variables {t : Type u → Type u} [traversable t] [is_lawful_traversable t]

@[simp]
lemma foldl.of_free_monoid_comp_free_mk (f : α → β → α) :
  foldl.of_free_monoid f ∘ free.mk = foldl.mk ∘ flip f := rfl

@[simp]
lemma foldr.of_free_monoid_comp_free_mk (f : β → α → α) :
  foldr.of_free_monoid f ∘ free.mk = foldr.mk ∘ f := rfl

@[simp]
lemma mfoldl.of_free_monoid_comp_free_mk {m} [monad m] [is_lawful_monad m] (f : α → β → m α) :
  mfoldl.of_free_monoid f ∘ free.mk = mfoldl.mk ∘ flip f :=
by ext; simp [(∘), mfoldl.of_free_monoid, mfoldl.mk, flip, fold_mfoldl_cons]; refl

@[simp]
lemma mfoldr.of_free_monoid_comp_free_mk {m} [monad m] [is_lawful_monad m] (f : β → α → m α) :
  mfoldr.of_free_monoid f ∘ free.mk = mfoldr.mk ∘ f :=
by { ext, simp [(∘), mfoldr.of_free_monoid, mfoldr.mk, flip, fold_mfoldr_cons] }

lemma to_list_spec (xs : t α) :
  to_list xs = (fold_map free.mk xs : free_monoid _) :=
eq.symm $
calc  fold_map free.mk xs
    = (fold_map free.mk xs).reverse.reverse : by simp only [list.reverse_reverse]
... = (list.foldr cons [] (fold_map free.mk xs).reverse).reverse
                 : by simp only [list.foldr_eta]
... = (unop (foldl.of_free_monoid (flip cons) (fold_map free.mk xs)) []).reverse
                 : by simp [flip,list.foldr_reverse,foldl.of_free_monoid, unop_op]
... = to_list xs : begin
                     rw fold_map_hom_free (foldl.of_free_monoid (flip $ @cons α)),
                     simp only [to_list, foldl, list.reverse_inj, foldl.get,
                       foldl.of_free_monoid_comp_free_mk],
                     all_goals { apply_instance }
                   end

lemma fold_map_map [monoid γ]  (f : α → β) (g : β → γ) (xs : t α) :
  fold_map g (f <$> xs) = fold_map (g ∘ f) xs :=
by simp only [fold_map,traverse_map]

lemma foldl_to_list (f : α → β → α) (xs : t β) (x : α) :
  foldl f x xs = list.foldl f x (to_list xs) :=
begin
  rw ← foldl.unop_of_free_monoid,
  simp only [foldl, to_list_spec, fold_map_hom_free,
    foldl.of_free_monoid_comp_free_mk, foldl.get]
end

lemma foldr_to_list (f : α → β → β) (xs : t α) (x : β) :
  foldr f x xs = list.foldr f x (to_list xs) :=
begin
  change _ = foldr.of_free_monoid _ _ _,
  simp only [foldr, to_list_spec, fold_map_hom_free,
    foldr.of_free_monoid_comp_free_mk, foldr.get]
end

lemma to_list_map (f : α → β) (xs : t α) :
  to_list (f <$> xs) = f <$> to_list xs := by
{ simp only [to_list_spec,free.map_eq_map,fold_map_hom (free.map f), fold_map_map];
  refl }

@[simp] theorem foldl_map (g : β → γ) (f : α → γ → α) (a : α) (l : t β) :
  foldl f a (g <$> l) = foldl (λ x y, f x (g y)) a l :=
by simp only [foldl, fold_map_map, (∘), flip]

@[simp] theorem foldr_map (g : β → γ) (f : γ → α → α) (a : α) (l : t β) :
  foldr f a (g <$> l) = foldr (f ∘ g) a l :=
by simp only [foldr, fold_map_map, (∘), flip]

@[simp] theorem to_list_eq_self {xs : list α} : to_list xs = xs :=
begin
  simp only [to_list_spec, fold_map, traverse],
  induction xs,
  case list.nil { refl },
  case list.cons : _ _ ih { unfold list.traverse list.ret, rw ih, refl }
end

theorem length_to_list {xs : t α} : length xs = list.length (to_list xs) :=
begin
  unfold length,
  rw foldl_to_list,
  generalize : to_list xs = ys,
  let f := λ (n : ℕ) (a : α), n + 1,
  transitivity list.foldl f 0 ys,
  { generalize : 0 = n,
    induction ys with _ _ ih generalizing n,
    { simp only [list.foldl_nil] },
    { simp only [list.foldl, ih (n+1)] } },
  { induction ys with _ tl ih,
    { simp only [list.length, list.foldl_nil] },
    { simp only [list.foldl, list.length],
      rw [← ih],
      exact tl.foldl_hom (λx, x+1) f f 0 (λ n x, rfl) } }
end

variables {m : Type u → Type u} [monad m] [is_lawful_monad m]

lemma mfoldl_to_list {f : α → β → m α} {x : α} {xs : t β} :
  mfoldl f x xs = list.mfoldl f x (to_list xs) :=
calc mfoldl f x xs = unop (mfoldl.of_free_monoid f (to_list xs)) x :
  by simp only [mfoldl, to_list_spec, fold_map_hom_free (mfoldl.of_free_monoid f),
    mfoldl.of_free_monoid_comp_free_mk, mfoldl.get]
... = list.mfoldl f x (to_list xs) : by simp [mfoldl.of_free_monoid, unop_op, flip]

lemma mfoldr_to_list (f : α → β → m β) (x : β) (xs : t α) :
  mfoldr f x xs = list.mfoldr f x (to_list xs) :=
begin
  change _ = mfoldr.of_free_monoid f (to_list xs) x,
  simp only [mfoldr, to_list_spec, fold_map_hom_free (mfoldr.of_free_monoid f),
    mfoldr.of_free_monoid_comp_free_mk, mfoldr.get]
end

@[simp] theorem mfoldl_map (g : β → γ) (f : α → γ → m α) (a : α) (l : t β) :
  mfoldl f a (g <$> l) = mfoldl (λ x y, f x (g y)) a l :=
by simp only [mfoldl, fold_map_map, (∘), flip]

@[simp] theorem mfoldr_map (g : β → γ) (f : γ → α → m α) (a : α) (l : t β) :
  mfoldr f a (g <$> l) = mfoldr (f ∘ g) a l :=
by simp only [mfoldr, fold_map_map, (∘), flip]

end equalities

end traversable


/-
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]

set_option old_structure_cmd true
/-- 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)⟩

/-- A Lie subalgebra forms a new Lie ring. -/
instance lie_subalgebra_lie_ring (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, } }

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

namespace lie_subalgebra

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

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_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) :=
λ L₁' L₂' h, by cases L₁'; cases L₂'; congr'

@[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]

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

/-- 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 [module R M] [lie_module R L M] : 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], }

end lie_module

end lie_subalgebra

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

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

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

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, },
  simp only [is_glb.of_image h, Inf_coe, 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) :=
begin
  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, },
  apply f.well_founded, rw ← is_noetherian_iff_well_founded, apply_instance,
end

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, }

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_bInter_iff, }

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

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 :=
have h' : (f : L₁ →ₗ[R] L₂).ker = ⊥ := linear_map.ker_eq_bot_of_injective h,
{ map_lie' := λ x y, by { apply set_coe.ext, simpa, },
..(linear_equiv.of_injective ↑f h')}

@[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 of_subalgebra : 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.of_submodule (e : L₁ ≃ₗ[R] L₂) ↑L₁'') }

@[simp] lemma of_subalgebra_apply (x : L₁'') : ↑(e.of_subalgebra _  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) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Yaël Dillies, Bhavik Mehta
-/
import data.finset.lattice
import data.set.sigma

/-!
# Finite sets in a sigma type

This file defines a few `finset` constructions on `Σ i, α i`.

## Main declarations

* `finset.sigma`: Given a finset `s` in `ι` and finsets `t i` in each `α i`, `s.sigma t` is the
  finset of the dependent sum `Σ i, α i`
* `finset.sigma_lift`: Lifts maps `α i → β i → finset (γ i)` to a map
  `Σ i, α i → Σ i, β i → finset (Σ i, γ i)`.

## TODO

`finset.sigma_lift` can be generalized to any alternative functor. But to make the generalization
worth it, we must first refactor the functor library so that the `alternative` instance for `finset`
is computable and universe-polymorphic.
-/

open function multiset

variables {ι : Type*}

namespace finset
section sigma
variables {α : ι → Type*} {β : Type*} (s s₁ s₂ : finset ι) (t t₁ t₂ : Π i, finset (α i))

/-- `s.sigma t` is the finset of dependent pairs `⟨i, a⟩` such that `i ∈ s` and `a ∈ t i`. -/
protected def sigma : finset (Σ i, α i) := ⟨_, s.nodup.sigma $ λ i, (t i).nodup⟩

variables {s s₁ s₂ t t₁ t₂}

@[simp] lemma mem_sigma {a : Σ i, α i} : a ∈ s.sigma t ↔ a.1 ∈ s ∧ a.2 ∈ t a.1 := mem_sigma

@[simp, norm_cast] lemma coe_sigma (s : finset ι) (t : Π i, finset (α i)) :
  (s.sigma t : set (Σ i, α i)) = (s : set ι).sigma (λ i, t i) :=
set.ext $ λ _, mem_sigma

@[simp] lemma sigma_nonempty : (s.sigma t).nonempty ↔ ∃ i ∈ s, (t i).nonempty :=
by simp [finset.nonempty]

@[simp] lemma sigma_eq_empty : s.sigma t = ∅ ↔ ∀ i ∈ s, t i = ∅ :=
by simp only [← not_nonempty_iff_eq_empty, sigma_nonempty, not_exists]

@[mono] lemma sigma_mono (hs : s₁ ⊆ s₂) (ht : ∀ i, t₁ i ⊆ t₂ i) : s₁.sigma t₁ ⊆ s₂.sigma t₂ :=
λ ⟨i, a⟩ h, let ⟨hi, ha⟩ := mem_sigma.1 h in mem_sigma.2 ⟨hs hi, ht i ha⟩

lemma sigma_eq_bUnion [decidable_eq (Σ i, α i)] (s : finset ι) (t : Π i, finset (α i)) :
  s.sigma t = s.bUnion (λ i, (t i).map $ embedding.sigma_mk i) :=
by { ext ⟨x, y⟩, simp [and.left_comm] }

variables (s t) (f : (Σ i, α i) → β)

lemma sup_sigma [semilattice_sup β] [order_bot β] :
  (s.sigma t).sup f = s.sup (λ i, (t i).sup $ λ b, f ⟨i, b⟩) :=
begin
  refine (sup_le _).antisymm (sup_le $ λ i hi, sup_le $ λ b hb, le_sup $ mem_sigma.2 ⟨hi, hb⟩),
  rintro ⟨i, b⟩ hb,
  rw mem_sigma at hb,
  refine le_trans _ (le_sup hb.1),
  convert le_sup hb.2,
end

lemma inf_sigma [semilattice_inf β] [order_top β] :
  (s.sigma t).inf f = s.inf (λ i, (t i).inf $ λ b, f ⟨i, b⟩) :=
@sup_sigma _ _ (order_dual β) _ _ _ _ _

end sigma

section sigma_lift
variables {α β γ : ι → Type*} [decidable_eq ι]

/-- Lifts maps `α i → β i → finset (γ i)` to a map `Σ i, α i → Σ i, β i → finset (Σ i, γ i)`. -/
def sigma_lift (f : Π ⦃i⦄, α i → β i → finset (γ i)) (a : sigma α) (b : sigma β) :
  finset (sigma γ) :=
dite (a.1 = b.1) (λ h, (f (h.rec a.2) b.2).map $ embedding.sigma_mk _) (λ _, ∅)

lemma mem_sigma_lift (f : Π ⦃i⦄, α i → β i → finset (γ i))
  (a : sigma α) (b : sigma β) (x : sigma γ) :
  x ∈ sigma_lift f a b ↔ ∃ (ha : a.1 = x.1) (hb : b.1 = x.1), x.2 ∈ f (ha.rec a.2) (hb.rec b.2) :=
begin
  obtain ⟨⟨i, a⟩, j, b⟩ := ⟨a, b⟩,
  obtain rfl | h := decidable.eq_or_ne i j,
  { split,
    { simp_rw [sigma_lift, dif_pos rfl, mem_map, embedding.sigma_mk_apply],
      rintro ⟨x, hx, rfl⟩,
      exact ⟨rfl, rfl, hx⟩ },
    { rintro ⟨⟨⟩, ⟨⟩, hx⟩,
      rw [sigma_lift, dif_pos rfl, mem_map],
      exact ⟨_, hx, by simp [sigma.ext_iff]⟩ } },
  { rw [sigma_lift, dif_neg h],
    refine iff_of_false (not_mem_empty _) _,
    rintro ⟨⟨⟩, ⟨⟩, _⟩,
    exact h rfl }
end

lemma mk_mem_sigma_lift (f : Π ⦃i⦄, α i → β i → finset (γ i)) (i : ι) (a : α i) (b : β i)
  (x : γ i) :
  (⟨i, x⟩ : sigma γ) ∈ sigma_lift f ⟨i, a⟩ ⟨i, b⟩ ↔ x ∈ f a b :=
begin
  rw [sigma_lift, dif_pos rfl, mem_map],
  refine ⟨_, λ hx, ⟨_, hx, rfl⟩⟩,
  rintro ⟨x, hx, _, rfl⟩,
  exact hx,
end

lemma not_mem_sigma_lift_of_ne_left (f : Π ⦃i⦄, α i → β i → finset (γ i))
  (a : sigma α) (b : sigma β) (x : sigma γ) (h : a.1 ≠ x.1) :
  x ∉ sigma_lift f a b :=
by { rw mem_sigma_lift, exact λ H, h H.fst }

lemma not_mem_sigma_lift_of_ne_right (f : Π ⦃i⦄, α i → β i → finset (γ i))
  {a : sigma α} (b : sigma β) {x : sigma γ} (h : b.1 ≠ x.1) :
  x ∉ sigma_lift f a b :=
by { rw mem_sigma_lift, exact λ H, h H.snd.fst }

variables {f g : Π ⦃i⦄, α i → β i → finset (γ i)} {a : Σ i, α i} {b : Σ i, β i}

lemma sigma_lift_nonempty :
  (sigma_lift f a b).nonempty ↔ ∃ h : a.1 = b.1, (f (h.rec a.2) b.2).nonempty :=
begin
  simp_rw nonempty_iff_ne_empty,
  convert dite_ne_right_iff,
  ext h,
  simp_rw ←nonempty_iff_ne_empty,
  exact map_nonempty.symm,
end

lemma sigma_lift_eq_empty : (sigma_lift f a b) = ∅ ↔ ∀ h : a.1 = b.1, (f (h.rec a.2) b.2) = ∅ :=
begin
  convert dite_eq_right_iff,
  exact forall_congr_eq (λ h, propext map_eq_empty.symm),
end

lemma sigma_lift_mono (h : ∀ ⦃i⦄ ⦃a : α i⦄ ⦃b : β i⦄, f a b ⊆ g a b) (a : Σ i, α i) (b : Σ i, β i) :
  sigma_lift f a b ⊆ sigma_lift g a b :=
begin
  rintro x hx,
  rw mem_sigma_lift at ⊢ hx,
  obtain ⟨ha, hb, hx⟩ := hx,
  exact ⟨ha, hb, h hx⟩,
end

variables (f a b)

lemma card_sigma_lift :
  (sigma_lift f a b).card = dite (a.1 = b.1) (λ h, (f (h.rec a.2) b.2).card) (λ _, 0) :=
by { convert apply_dite _ _ _ _, ext h, exact (card_map _).symm }

end sigma_lift

end finset


/-
Copyright (c) 2021 Julian Kuelshammer. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Julian Kuelshammer

! This file was ported from Lean 3 source module algebra.category.Semigroup.basic
! leanprover-community/mathlib commit 47b51515e69f59bca5cf34ef456e6000fe205a69
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.PemptyInstances
import Mathbin.Algebra.Hom.Equiv.Basic
import Mathbin.CategoryTheory.ConcreteCategory.BundledHom
import Mathbin.CategoryTheory.Functor.ReflectsIsomorphisms
import Mathbin.CategoryTheory.Elementwise

/-!
# Category instances for has_mul, has_add, semigroup and add_semigroup

We introduce the bundled categories:
* `Magma`
* `AddMagma`
* `Semigroup`
* `AddSemigroup`
along with the relevant forgetful functors between them.

This closely follows `algebra.category.Mon.basic`.

## TODO

* Limits in these categories
* free/forgetful adjunctions
-/

universe u v

open CategoryTheory

/-- The category of magmas and magma morphisms. -/
@[to_additive AddMagma]
def Magma : Type (u + 1) :=
  Bundled Mul
#align Magma Magma
#align AddMagma AddMagma

/-- The category of additive magmas and additive magma morphisms. -/
add_decl_doc AddMagma

namespace Magma

@[to_additive]
instance bundledHom : BundledHom @MulHom :=
  ⟨@MulHom.toFun, @MulHom.id, @MulHom.comp, @MulHom.coe_inj⟩
#align Magma.bundled_hom Magma.bundledHom
#align AddMagma.bundled_hom AddMagma.bundledHom

deriving instance LargeCategory, ConcreteCategory for Magma

attribute [to_additive] Magma.largeCategory Magma.concreteCategory

@[to_additive]
instance : CoeSort Magma (Type _) :=
  Bundled.hasCoeToSort

/-- Construct a bundled `Magma` from the underlying type and typeclass. -/
@[to_additive]
def of (M : Type u) [Mul M] : Magma :=
  Bundled.of M
#align Magma.of Magma.of
#align AddMagma.of AddMagma.of

/-- Construct a bundled `AddMagma` from the underlying type and typeclass. -/
add_decl_doc AddMagma.of

/-- Typecheck a `mul_hom` as a morphism in `Magma`. -/
@[to_additive]
def ofHom {X Y : Type u} [Mul X] [Mul Y] (f : X →ₙ* Y) : of X ⟶ of Y :=
  f
#align Magma.of_hom Magma.ofHom
#align AddMagma.of_hom AddMagma.ofHom

/-- Typecheck a `add_hom` as a morphism in `AddMagma`. -/
add_decl_doc AddMagma.ofHom

@[simp, to_additive]
theorem ofHom_apply {X Y : Type u} [Mul X] [Mul Y] (f : X →ₙ* Y) (x : X) : ofHom f x = f x :=
  rfl
#align Magma.of_hom_apply Magma.ofHom_apply
#align AddMagma.of_hom_apply AddMagma.ofHom_apply

@[to_additive]
instance : Inhabited Magma :=
  ⟨Magma.of PEmpty⟩

@[to_additive]
instance (M : Magma) : Mul M :=
  M.str

@[simp, to_additive]
theorem coe_of (R : Type u) [Mul R] : (Magma.of R : Type u) = R :=
  rfl
#align Magma.coe_of Magma.coe_of
#align AddMagma.coe_of AddMagma.coe_of

end Magma

/-- The category of semigroups and semigroup morphisms. -/
@[to_additive AddSemigroupCat]
def SemigroupCat : Type (u + 1) :=
  Bundled Semigroup
#align Semigroup SemigroupCat
#align AddSemigroup AddSemigroupCat

/-- The category of additive semigroups and semigroup morphisms. -/
add_decl_doc AddSemigroupCat

namespace SemigroupCat

@[to_additive]
instance : BundledHom.ParentProjection Semigroup.toHasMul :=
  ⟨⟩

deriving instance LargeCategory, ConcreteCategory for SemigroupCat

attribute [to_additive] SemigroupCat.largeCategory SemigroupCat.concreteCategory

@[to_additive]
instance : CoeSort SemigroupCat (Type _) :=
  Bundled.hasCoeToSort

/-- Construct a bundled `Semigroup` from the underlying type and typeclass. -/
@[to_additive]
def of (M : Type u) [Semigroup M] : SemigroupCat :=
  Bundled.of M
#align Semigroup.of SemigroupCat.of
#align AddSemigroup.of AddSemigroupCat.of

/-- Construct a bundled `AddSemigroup` from the underlying type and typeclass. -/
add_decl_doc AddSemigroupCat.of

/-- Typecheck a `mul_hom` as a morphism in `Semigroup`. -/
@[to_additive]
def ofHom {X Y : Type u} [Semigroup X] [Semigroup Y] (f : X →ₙ* Y) : of X ⟶ of Y :=
  f
#align Semigroup.of_hom SemigroupCat.ofHom
#align AddSemigroup.of_hom AddSemigroupCat.ofHom

/-- Typecheck a `add_hom` as a morphism in `AddSemigroup`. -/
add_decl_doc AddSemigroupCat.ofHom

@[simp, to_additive]
theorem ofHom_apply {X Y : Type u} [Semigroup X] [Semigroup Y] (f : X →ₙ* Y) (x : X) :
    ofHom f x = f x :=
  rfl
#align Semigroup.of_hom_apply SemigroupCat.ofHom_apply
#align AddSemigroup.of_hom_apply AddSemigroupCat.ofHom_apply

@[to_additive]
instance : Inhabited SemigroupCat :=
  ⟨SemigroupCat.of PEmpty⟩

@[to_additive]
instance (M : SemigroupCat) : Semigroup M :=
  M.str

@[simp, to_additive]
theorem coe_of (R : Type u) [Semigroup R] : (SemigroupCat.of R : Type u) = R :=
  rfl
#align Semigroup.coe_of SemigroupCat.coe_of
#align AddSemigroup.coe_of AddSemigroupCat.coe_of

@[to_additive has_forget_to_AddMagma]
instance hasForgetToMagma : HasForget₂ SemigroupCat Magma :=
  BundledHom.forget₂ _ _
#align Semigroup.has_forget_to_Magma SemigroupCat.hasForgetToMagma
#align AddSemigroup.has_forget_to_AddMagma AddSemigroupCat.hasForgetToAddMagma

end SemigroupCat

variable {X Y : Type u}

section

variable [Mul X] [Mul Y]

/-- Build an isomorphism in the category `Magma` from a `mul_equiv` between `has_mul`s. -/
@[to_additive AddEquiv.toAddMagmaIso
      "Build an isomorphism in the category `AddMagma` from\nan `add_equiv` between `has_add`s.",
  simps]
def MulEquiv.toMagmaIso (e : X ≃* Y) : Magma.of X ≅ Magma.of Y
    where
  Hom := e.toMulHom
  inv := e.symm.toMulHom
#align mul_equiv.to_Magma_iso MulEquiv.toMagmaIso
#align add_equiv.to_AddMagma_iso AddEquiv.toAddMagmaIso

end

section

variable [Semigroup X] [Semigroup Y]

/-- Build an isomorphism in the category `Semigroup` from a `mul_equiv` between `semigroup`s. -/
@[to_additive AddEquiv.toAddSemigroupIso
      "Build an isomorphism in the category\n`AddSemigroup` from an `add_equiv` between `add_semigroup`s.",
  simps]
def MulEquiv.toSemigroupIso (e : X ≃* Y) : SemigroupCat.of X ≅ SemigroupCat.of Y
    where
  Hom := e.toMulHom
  inv := e.symm.toMulHom
#align mul_equiv.to_Semigroup_iso MulEquiv.toSemigroupIso
#align add_equiv.to_AddSemigroup_iso AddEquiv.toAddSemigroupIso

end

namespace CategoryTheory.Iso

/-- Build a `mul_equiv` from an isomorphism in the category `Magma`. -/
@[to_additive AddMagma_iso_to_add_equiv
      "Build an `add_equiv` from an isomorphism in the category\n`AddMagma`."]
def magmaIsoToMulEquiv {X Y : Magma} (i : X ≅ Y) : X ≃* Y
    where
  toFun := i.Hom
  invFun := i.inv
  left_inv x := by simp
  right_inv y := by simp
  map_mul' := by simp
#align category_theory.iso.Magma_iso_to_mul_equiv CategoryTheory.Iso.magmaIsoToMulEquiv
#align category_theory.iso.AddMagma_iso_to_add_equiv CategoryTheory.Iso.addMagmaIsoToAddEquiv

/-- Build a `mul_equiv` from an isomorphism in the category `Semigroup`. -/
@[to_additive "Build an `add_equiv` from an isomorphism in the category\n`AddSemigroup`."]
def semigroupIsoToMulEquiv {X Y : SemigroupCat} (i : X ≅ Y) : X ≃* Y
    where
  toFun := i.Hom
  invFun := i.inv
  left_inv x := by simp
  right_inv y := by simp
  map_mul' := by simp
#align category_theory.iso.Semigroup_iso_to_mul_equiv CategoryTheory.Iso.semigroupIsoToMulEquiv
#align category_theory.iso.Semigroup_iso_to_add_equiv CategoryTheory.Iso.semigroupIsoToAddEquiv

end CategoryTheory.Iso

/-- multiplicative equivalences between `has_mul`s are the same as (isomorphic to) isomorphisms
in `Magma` -/
@[to_additive addEquivIsoAddMagmaIso
      "additive equivalences between `has_add`s are the same\nas (isomorphic to) isomorphisms in `AddMagma`"]
def mulEquivIsoMagmaIso {X Y : Type u} [Mul X] [Mul Y] : X ≃* Y ≅ Magma.of X ≅ Magma.of Y
    where
  Hom e := e.toMagmaIso
  inv i := i.magmaIsoToMulEquiv
#align mul_equiv_iso_Magma_iso mulEquivIsoMagmaIso
#align add_equiv_iso_AddMagma_iso addEquivIsoAddMagmaIso

/-- multiplicative equivalences between `semigroup`s are the same as (isomorphic to) isomorphisms
in `Semigroup` -/
@[to_additive addEquivIsoAddSemigroupIso
      "additive equivalences between `add_semigroup`s are\nthe same as (isomorphic to) isomorphisms in `AddSemigroup`"]
def mulEquivIsoSemigroupIso {X Y : Type u} [Semigroup X] [Semigroup Y] :
    X ≃* Y ≅ SemigroupCat.of X ≅ SemigroupCat.of Y
    where
  Hom e := e.toSemigroupIso
  inv i := i.semigroupIsoToMulEquiv
#align mul_equiv_iso_Semigroup_iso mulEquivIsoSemigroupIso
#align add_equiv_iso_AddSemigroup_iso addEquivIsoAddSemigroupIso

@[to_additive]
instance Magma.forget_reflects_isos : ReflectsIsomorphisms (forget Magma.{u})
    where reflects X Y f _ := by
    skip
    let i := as_iso ((forget Magma).map f)
    let e : X ≃* Y := { f, i.to_equiv with }
    exact ⟨(is_iso.of_iso e.to_Magma_iso).1⟩
#align Magma.forget_reflects_isos Magma.forget_reflects_isos
#align AddMagma.forget_reflects_isos AddMagma.forget_reflects_isos

@[to_additive]
instance SemigroupCat.forget_reflects_isos : ReflectsIsomorphisms (forget SemigroupCat.{u})
    where reflects X Y f _ := by
    skip
    let i := as_iso ((forget SemigroupCat).map f)
    let e : X ≃* Y := { f, i.to_equiv with }
    exact ⟨(is_iso.of_iso e.to_Semigroup_iso).1⟩
#align Semigroup.forget_reflects_isos SemigroupCat.forget_reflects_isos
#align AddSemigroup.forget_reflects_isos AddSemigroupCat.forget_reflects_isos

/-!
Once we've shown that the forgetful functors to type reflect isomorphisms,
we automatically obtain that the `forget₂` functors between our concrete categories
reflect isomorphisms.
-/

example : ReflectsIsomorphisms (forget₂ SemigroupCat Magma) := by infer_instance


/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Stephen Morgan, Scott Morrison, Johannes Hölzl
-/
import category_theory.fully_faithful
import data.equiv.basic

/-!
# The category `Type`.

In this section we set up the theory so that Lean's types and functions between them
can be viewed as a `large_category` in our framework.

Lean can not transparently view a function as a morphism in this category, and needs a hint in
order to be able to type check. We provide the abbreviation `as_hom f` to guide type checking,
as well as a corresponding notation `↾ f`. (Entered as `\upr `.) The notation is enabled using
`open_locale category_theory.Type`.

We provide various simplification lemmas for functors and natural transformations valued in `Type`.

We define `ulift_functor`, from `Type u` to `Type (max u v)`, and show that it is fully faithful
(but not, of course, essentially surjective).

We prove some basic facts about the category `Type`:
*  epimorphisms are surjections and monomorphisms are injections,
* `iso` is both `iso` and `equiv` to `equiv` (at least within a fixed universe),
* every type level `is_lawful_functor` gives a categorical functor `Type ⥤ Type`
  (the corresponding fact about monads is in `src/category_theory/monad/types.lean`).
-/

namespace category_theory

-- morphism levels before object levels. See note [category_theory universes].
universes v v' w u u'

instance types : large_category (Type u) :=
{ hom     := λ a b, (a → b),
  id      := λ a, id,
  comp    := λ _ _ _ f g, g ∘ f }

lemma types_hom {α β : Type u} : (α ⟶ β) = (α → β) := rfl
lemma types_id (X : Type u) : 𝟙 X = id := rfl
lemma types_comp {X Y Z : Type u} (f : X ⟶ Y) (g : Y ⟶ Z) : f ≫ g = g ∘ f := rfl

@[simp]
lemma types_id_apply (X : Type u) (x : X) : ((𝟙 X) : X → X) x = x := rfl
@[simp]
lemma types_comp_apply {X Y Z : Type u} (f : X ⟶ Y) (g : Y ⟶ Z) (x : X) : (f ≫ g) x = g (f x) := rfl

@[simp]
lemma hom_inv_id_apply {X Y : Type u} (f : X ≅ Y) (x : X) : f.inv (f.hom x) = x :=
congr_fun f.hom_inv_id x
@[simp]
lemma inv_hom_id_apply {X Y : Type u} (f : X ≅ Y) (y : Y) : f.hom (f.inv y) = y :=
congr_fun f.inv_hom_id y

/-- `as_hom f` helps Lean type check a function as a morphism in the category `Type`. -/
-- Unfortunately without this wrapper we can't use `category_theory` idioms, such as `is_iso f`.
abbreviation as_hom {α β : Type u} (f : α → β) : α ⟶ β := f
-- If you don't mind some notation you can use fewer keystrokes:
localized "notation  `↾` f : 200 := as_hom f" in category_theory.Type -- type as \upr in VScode

section -- We verify the expected type checking behaviour of `as_hom`.
variables (α β γ : Type u) (f : α → β) (g : β → γ)

example : α → γ := ↾f ≫ ↾g
example [is_iso ↾f] : mono ↾f := by apply_instance
example [is_iso ↾f] : ↾f ≫ inv ↾f = 𝟙 α := by simp
end

namespace functor
variables {J : Type u} [category.{v} J]

/--
The sections of a functor `J ⥤ Type` are
the choices of a point `u j : F.obj j` for each `j`,
such that `F.map f (u j) = u j` for every morphism `f : j ⟶ j'`.

We later use these to define limits in `Type` and in many concrete categories.
-/
def sections (F : J ⥤ Type w) : set (Π j, F.obj j) :=
{ u | ∀ {j j'} (f : j ⟶ j'), F.map f (u j) = u j'}
end functor

namespace functor_to_types
variables {C : Type u} [category.{v} C] (F G H : C ⥤ Type w) {X Y Z : C}
variables (σ : F ⟶ G) (τ : G ⟶ H)

@[simp] lemma map_comp_apply (f : X ⟶ Y) (g : Y ⟶ Z) (a : F.obj X) :
  (F.map (f ≫ g)) a = (F.map g) ((F.map f) a) :=
by simp [types_comp]

@[simp] lemma map_id_apply (a : F.obj X) : (F.map (𝟙 X)) a = a :=
by simp [types_id]

lemma naturality (f : X ⟶ Y) (x : F.obj X) : σ.app Y ((F.map f) x) = (G.map f) (σ.app X x) :=
congr_fun (σ.naturality f) x

@[simp] lemma comp (x : F.obj X) : (σ ≫ τ).app X x = τ.app X (σ.app X x) := rfl

variables {D : Type u'} [𝒟 : category.{u'} D] (I J : D ⥤ C) (ρ : I ⟶ J) {W : D}

@[simp] lemma hcomp (x : (I ⋙ F).obj W) :
  (ρ ◫ σ).app W x = (G.map (ρ.app W)) (σ.app (I.obj W) x) :=
rfl

@[simp]

@[simp] lemma hom_inv_id_app_apply (α : F ≅ G) (X) (x) : α.inv.app X (α.hom.app X x) = x :=
congr_fun (α.hom_inv_id_app X) x
@[simp] lemma inv_hom_id_app_apply (α : F ≅ G) (X) (x) : α.hom.app X (α.inv.app X x) = x :=
congr_fun (α.inv_hom_id_app X) x

end functor_to_types

/--
The isomorphism between a `Type` which has been `ulift`ed to the same universe,
and the original type.
-/
def ulift_trivial (V : Type u) : ulift.{u} V ≅ V := by tidy

/--
The functor embedding `Type u` into `Type (max u v)`.
Write this as `ulift_functor.{5 2}` to get `Type 2 ⥤ Type 5`.
-/
def ulift_functor : Type u ⥤ Type (max u v) :=
{ obj := λ X, ulift.{v} X,
  map := λ X Y f, λ x : ulift.{v} X, ulift.up (f x.down) }

@[simp] lemma ulift_functor_map {X Y : Type u} (f : X ⟶ Y) (x : ulift.{v} X) :
  ulift_functor.map f x = ulift.up (f x.down) := rfl

instance ulift_functor_full : full.{u} ulift_functor :=
{ preimage := λ X Y f x, (f (ulift.up x)).down }
instance ulift_functor_faithful : faithful ulift_functor :=
{ map_injective' := λ X Y f g p, funext $ λ x,
    congr_arg ulift.down ((congr_fun p (ulift.up x)) : ((ulift.up (f x)) = (ulift.up (g x)))) }

/-- Any term `x` of a type `X` corresponds to a morphism `punit ⟶ X`. -/
-- TODO We should connect this to a general story about concrete categories
-- whose forgetful functor is representable.
def hom_of_element {X : Type u} (x : X) : punit ⟶ X := λ _, x

lemma hom_of_element_eq_iff {X : Type u} (x y : X) :
  hom_of_element x = hom_of_element y ↔ x = y :=
⟨λ H, congr_fun H punit.star, by cc⟩

/--
A morphism in `Type` is a monomorphism if and only if it is injective.

See https://stacks.math.columbia.edu/tag/003C.
-/
lemma mono_iff_injective {X Y : Type u} (f : X ⟶ Y) : mono f ↔ function.injective f :=
begin
  split,
  { intros H x x' h,
    resetI,
    rw ←hom_of_element_eq_iff at ⊢ h,
    exact (cancel_mono f).mp h },
  { refine λ H, ⟨λ Z g h H₂, _⟩,
    ext z,
    replace H₂ := congr_fun H₂ z,
    exact H H₂ }
end

/--
A morphism in `Type` is an epimorphism if and only if it is surjective.

See https://stacks.math.columbia.edu/tag/003C.
-/
lemma epi_iff_surjective {X Y : Type u} (f : X ⟶ Y) : epi f ↔ function.surjective f :=
begin
  split,
  { intros H,
    let g : Y ⟶ ulift Prop := λ y, ⟨true⟩,
    let h : Y ⟶ ulift Prop := λ y, ⟨∃ x, f x = y⟩,
    suffices : f ≫ g = f ≫ h,
    { resetI,
      rw cancel_epi at this,
      intro y,
      replace this := congr_fun this y,
      replace this : true = ∃ x, f x = y := congr_arg ulift.down this,
      rw ←this,
      trivial },
    ext x,
    change true ↔ ∃ x', f x' = f x,
    rw true_iff,
    exact ⟨x, rfl⟩ },
  { intro H,
    constructor,
    intros Z g h H₂,
    apply funext,
    rw ←forall_iff_forall_surj H,
    intro x,
    exact (congr_fun H₂ x : _) }
end

section

/-- `of_type_functor m` converts from Lean's `Type`-based `category` to `category_theory`. This
allows us to use these functors in category theory. -/
def of_type_functor (m : Type u → Type v) [_root_.functor m] [is_lawful_functor m] :
  Type u ⥤ Type v :=
{ obj       := m,
  map       := λα β, _root_.functor.map,
  map_id'   := assume α, _root_.functor.map_id,
  map_comp' := assume α β γ f g, funext $ assume a, is_lawful_functor.comp_map f g _ }

variables (m : Type u → Type v) [_root_.functor m] [is_lawful_functor m]

@[simp]
lemma of_type_functor_obj : (of_type_functor m).obj = m := rfl

@[simp]
lemma of_type_functor_map {α β} (f : α → β) :
  (of_type_functor m).map f = (_root_.functor.map f : m α → m β) := rfl

end

end category_theory

-- Isomorphisms in Type and equivalences.

namespace equiv

universe u

variables {X Y : Type u}

/--
Any equivalence between types in the same universe gives
a categorical isomorphism between those types.
-/
def to_iso (e : X ≃ Y) : X ≅ Y :=
{ hom := e.to_fun,
  inv := e.inv_fun,
  hom_inv_id' := funext e.left_inv,
  inv_hom_id' := funext e.right_inv }

@[simp] lemma to_iso_hom {e : X ≃ Y} : e.to_iso.hom = e := rfl
@[simp] lemma to_iso_inv {e : X ≃ Y} : e.to_iso.inv = e.symm := rfl

end equiv

universe u

namespace category_theory.iso
open category_theory

variables {X Y : Type u}

/--
Any isomorphism between types gives an equivalence.
-/
def to_equiv (i : X ≅ Y) : X ≃ Y :=
{ to_fun := i.hom,
  inv_fun := i.inv,
  left_inv := λ x, congr_fun i.hom_inv_id x,
  right_inv := λ y, congr_fun i.inv_hom_id y }

@[simp] lemma to_equiv_fun (i : X ≅ Y) : (i.to_equiv : X → Y) = i.hom := rfl
@[simp] lemma to_equiv_symm_fun (i : X ≅ Y) : (i.to_equiv.symm : Y → X) = i.inv := rfl

@[simp] lemma to_equiv_id (X : Type u) : (iso.refl X).to_equiv = equiv.refl X := rfl
@[simp] lemma to_equiv_comp {X Y Z : Type u} (f : X ≅ Y) (g : Y ≅ Z) :
  (f ≪≫ g).to_equiv = f.to_equiv.trans (g.to_equiv) := rfl

end category_theory.iso

namespace category_theory

/-- A morphism in `Type u` is an isomorphism if and only if it is bijective. -/
lemma is_iso_iff_bijective {X Y : Type u} (f : X ⟶ Y) : is_iso f ↔ function.bijective f :=
iff.intro
  (λ i, (by exactI as_iso f : X ≅ Y).to_equiv.bijective)
  (λ b, is_iso.of_iso (equiv.of_bijective f b).to_iso)

end category_theory

-- We prove `equiv_iso_iso` and then use that to sneakily construct `equiv_equiv_iso`.
-- (In this order the proofs are handled by `obviously`.)

/-- Equivalences (between types in the same universe) are the same as (isomorphic to) isomorphisms
of types. -/
@[simps] def equiv_iso_iso {X Y : Type u} : (X ≃ Y) ≅ (X ≅ Y) :=
{ hom := λ e, e.to_iso,
  inv := λ i, i.to_equiv, }

/-- Equivalences (between types in the same universe) are the same as (equivalent to) isomorphisms
of types. -/
def equiv_equiv_iso {X Y : Type u} : (X ≃ Y) ≃ (X ≅ Y) :=
(equiv_iso_iso).to_equiv

@[simp] lemma equiv_equiv_iso_hom {X Y : Type u} (e : X ≃ Y) :
  equiv_equiv_iso e = e.to_iso := rfl

@[simp] lemma equiv_equiv_iso_inv {X Y : Type u} (e : X ≅ Y) :
  equiv_equiv_iso.symm e = e.to_equiv := rfl


/-
Copyright (c) 2021 Rémy Degenne. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Rémy Degenne
-/
import measure_theory.function.lp_space
import analysis.normed_space.lattice_ordered_group

/-!
# Order related properties of Lp spaces

### Results

- `Lp E p μ` is an `ordered_add_comm_group` when `E` is a `normed_lattice_add_comm_group`.

### TODO

- move definitions of `Lp.pos_part` and `Lp.neg_part` to this file, and define them as
  `has_pos_part.pos` and `has_pos_part.neg` given by the lattice structure.
- show that if `E` is a `normed_lattice_add_comm_group` then so is `Lp E p μ` for `1 ≤ p`. In
  particular, this shows `order_closed_topology` for `Lp`.

-/

open topological_space measure_theory lattice_ordered_comm_group
open_locale ennreal

variables {α E : Type*} {m : measurable_space α} {μ : measure α} {p : ℝ≥0∞}

namespace measure_theory
namespace Lp

section order
variables [normed_lattice_add_comm_group E]

lemma coe_fn_le (f g : Lp E p μ) : f ≤ᵐ[μ] g ↔ f ≤ g :=
by rw [← subtype.coe_le_coe, ← ae_eq_fun.coe_fn_le, ← coe_fn_coe_base, ← coe_fn_coe_base]

lemma coe_fn_nonneg (f : Lp E p μ) : 0 ≤ᵐ[μ] f ↔ 0 ≤ f :=
begin
  rw ← coe_fn_le,
  have h0 := Lp.coe_fn_zero E p μ,
  split; intro h; filter_upwards [h, h0] with _ _ h2,
  { rwa h2, },
  { rwa ← h2, },
end

instance : covariant_class (Lp E p μ) (Lp E p μ) (+) (≤) :=
begin
  refine ⟨λ f g₁ g₂ hg₁₂, _⟩,
  rw ← coe_fn_le at hg₁₂ ⊢,
  filter_upwards [coe_fn_add f g₁, coe_fn_add f g₂, hg₁₂] with _ h1 h2 h3,
  rw [h1, h2, pi.add_apply, pi.add_apply],
  exact add_le_add le_rfl h3,
end

instance : ordered_add_comm_group (Lp E p μ) :=
{ add_le_add_left := λ f g hfg f', add_le_add_left hfg f',
  ..subtype.partial_order _, ..add_subgroup.to_add_comm_group _}

end order

end Lp
end measure_theory