/-
Copyright (c) 2019 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Bhavik Mehta
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.comma
import Mathlib.category_theory.punit
import Mathlib.category_theory.reflects_isomorphisms
import Mathlib.category_theory.epi_mono
import Mathlib.PostPort

universes v₁ u₁ v₂ u₂

namespace Mathlib

/-!
# Over and under categories

Over (and under) categories are special cases of comma categories.
* If `L` is the identity functor and `R` is a constant functor, then `comma L R` is the "slice" or
  "over" category over the object `R` maps to.
* Conversely, if `L` is a constant functor and `R` is the identity functor, then `comma L R` is the
  "coslice" or "under" category under the object `L` maps to.

## Tags

comma, slice, coslice, over, under
-/

namespace category_theory

/--
The over category has as objects arrows in `T` with codomain `X` and as morphisms commutative
triangles.

See https://stacks.math.columbia.edu/tag/001G.
-/
def over {T : Type u₁} [category T] (X : T) :=
  comma 𝟭 (functor.from_punit X)

-- Satisfying the inhabited linter

protected instance over.inhabited {T : Type u₁} [category T] [Inhabited T] : Inhabited (over Inhabited.default) :=
  { default := comma.mk 𝟙 }

namespace over

theorem over_morphism.ext {T : Type u₁} [category T] {X : T} {U : over X} {V : over X} {f : U ⟶ V} {g : U ⟶ V} (h : comma_morphism.left f = comma_morphism.left g) : f = g := sorry

@[simp] theorem over_right {T : Type u₁} [category T] {X : T} (U : over X) : comma.right U = PUnit.unit :=
  of_as_true trivial

@[simp] theorem id_left {T : Type u₁} [category T] {X : T} (U : over X) : comma_morphism.left 𝟙 = 𝟙 :=
  rfl

@[simp] theorem comp_left {T : Type u₁} [category T] {X : T} (a : over X) (b : over X) (c : over X) (f : a ⟶ b) (g : b ⟶ c) : comma_morphism.left (f ≫ g) = comma_morphism.left f ≫ comma_morphism.left g :=
  rfl

@[simp] theorem w {T : Type u₁} [category T] {X : T} {A : over X} {B : over X} (f : A ⟶ B) : comma_morphism.left f ≫ comma.hom B = comma.hom A := sorry

/-- To give an object in the over category, it suffices to give a morphism with codomain `X`. -/
@[simp] theorem mk_left {T : Type u₁} [category T] {X : T} {Y : T} (f : Y ⟶ X) : comma.left (mk f) = Y :=
  Eq.refl (comma.left (mk f))

/-- We can set up a coercion from arrows with codomain `X` to `over X`. This most likely should not
    be a global instance, but it is sometimes useful. -/
def coe_from_hom {T : Type u₁} [category T] {X : T} {Y : T} : has_coe (Y ⟶ X) (over X) :=
  has_coe.mk mk

@[simp] theorem coe_hom {T : Type u₁} [category T] {X : T} {Y : T} (f : Y ⟶ X) : comma.hom ↑f = f :=
  rfl

/-- To give a morphism in the over category, it suffices to give an arrow fitting in a commutative
    triangle. -/
def hom_mk {T : Type u₁} [category T] {X : T} {U : over X} {V : over X} (f : comma.left U ⟶ comma.left V) (w : autoParam (f ≫ comma.hom V = comma.hom U)
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
    (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])) : U ⟶ V :=
  comma_morphism.mk

/--
Construct an isomorphism in the over category given isomorphisms of the objects whose forward
direction gives a commutative triangle.
-/
@[simp] theorem iso_mk_inv_left {T : Type u₁} [category T] {X : T} {f : over X} {g : over X} (hl : comma.left f ≅ comma.left g) (hw : autoParam (iso.hom hl ≫ comma.hom g = comma.hom f)
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
    (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])) : comma_morphism.left (iso.inv (iso_mk hl)) = iso.inv hl :=
  Eq.refl (iso.inv hl)

/--
The forgetful functor mapping an arrow to its domain.

See https://stacks.math.columbia.edu/tag/001G.
-/
def forget {T : Type u₁} [category T] (X : T) : over X ⥤ T :=
  comma.fst 𝟭 (functor.from_punit X)

@[simp] theorem forget_obj {T : Type u₁} [category T] {X : T} {U : over X} : functor.obj (forget X) U = comma.left U :=
  rfl

@[simp] theorem forget_map {T : Type u₁} [category T] {X : T} {U : over X} {V : over X} {f : U ⟶ V} : functor.map (forget X) f = comma_morphism.left f :=
  rfl

/--
A morphism `f : X ⟶ Y` induces a functor `over X ⥤ over Y` in the obvious way.

See https://stacks.math.columbia.edu/tag/001G.
-/
def map {T : Type u₁} [category T] {X : T} {Y : T} (f : X ⟶ Y) : over X ⥤ over Y :=
  comma.map_right 𝟭 (discrete.nat_trans fun (_x : discrete PUnit) => f)

@[simp] theorem map_obj_left {T : Type u₁} [category T] {X : T} {Y : T} {f : X ⟶ Y} {U : over X} : comma.left (functor.obj (map f) U) = comma.left U :=
  rfl

@[simp] theorem map_obj_hom {T : Type u₁} [category T] {X : T} {Y : T} {f : X ⟶ Y} {U : over X} : comma.hom (functor.obj (map f) U) = comma.hom U ≫ f :=
  rfl

@[simp] theorem map_map_left {T : Type u₁} [category T] {X : T} {Y : T} {f : X ⟶ Y} {U : over X} {V : over X} {g : U ⟶ V} : comma_morphism.left (functor.map (map f) g) = comma_morphism.left g :=
  rfl

/-- Mapping by the identity morphism is just the identity functor. -/
def map_id {T : Type u₁} [category T] {Y : T} : map 𝟙 ≅ 𝟭 :=
  nat_iso.of_components (fun (X : over Y) => iso_mk (iso.refl (comma.left (functor.obj (map 𝟙) X)))) sorry

/-- Mapping by the composite morphism `f ≫ g` is the same as mapping by `f` then by `g`. -/
def map_comp {T : Type u₁} [category T] {X : T} {Y : T} {Z : T} (f : X ⟶ Y) (g : Y ⟶ Z) : map (f ≫ g) ≅ map f ⋙ map g :=
  nat_iso.of_components (fun (X_1 : over X) => iso_mk (iso.refl (comma.left (functor.obj (map (f ≫ g)) X_1)))) sorry

protected instance forget_reflects_iso {T : Type u₁} [category T] {X : T} : reflects_isomorphisms (forget X) :=
  reflects_isomorphisms.mk
    fun (Y Z : over X) (f : Y ⟶ Z) (t : is_iso (functor.map (forget X) f)) =>
      is_iso.mk (hom_mk (inv (functor.map (forget X) f)))

protected instance forget_faithful {T : Type u₁} [category T] {X : T} : faithful (forget X) :=
  faithful.mk

/--
If `k.left` is an epimorphism, then `k` is an epimorphism. In other words, `over.forget X` reflects
epimorphisms.
The converse does not hold without additional assumptions on the underlying category.
-/
-- TODO: Show the converse holds if `T` has binary products or pushouts.

theorem epi_of_epi_left {T : Type u₁} [category T] {X : T} {f : over X} {g : over X} (k : f ⟶ g) [hk : epi (comma_morphism.left k)] : epi k :=
  faithful_reflects_epi (forget X) hk

/--
If `k.left` is a monomorphism, then `k` is a monomorphism. In other words, `over.forget X` reflects
monomorphisms.
The converse of `category_theory.over.mono_left_of_mono`.

This lemma is not an instance, to avoid loops in type class inference.
-/
theorem mono_of_mono_left {T : Type u₁} [category T] {X : T} {f : over X} {g : over X} (k : f ⟶ g) [hk : mono (comma_morphism.left k)] : mono k :=
  faithful_reflects_mono (forget X) hk

/--
If `k` is a monomorphism, then `k.left` is a monomorphism. In other words, `over.forget X` preserves
monomorphisms.
The converse of `category_theory.over.mono_of_mono_left`.
-/
protected instance mono_left_of_mono {T : Type u₁} [category T] {X : T} {f : over X} {g : over X} (k : f ⟶ g) [mono k] : mono (comma_morphism.left k) :=
  mono.mk
    fun (Y : T) (l m : Y ⟶ comma.left f) (a : l ≫ comma_morphism.left k = m ≫ comma_morphism.left k) =>
      let l' : mk (m ≫ comma.hom f) ⟶ f := hom_mk l;
      congr_arg comma_morphism.left
        (eq.mpr (id (Eq._oldrec (Eq.refl (l' = hom_mk m)) (Eq.symm (propext (cancel_mono k))))) (over_morphism.ext a))

/-- Given f : Y ⟶ X, this is the obvious functor from (T/X)/f to T/Y -/
@[simp] theorem iterated_slice_forward_obj {T : Type u₁} [category T] {X : T} (f : over X) (α : over f) : functor.obj (iterated_slice_forward f) α = mk (comma_morphism.left (comma.hom α)) :=
  Eq.refl (functor.obj (iterated_slice_forward f) α)

/-- Given f : Y ⟶ X, this is the obvious functor from T/Y to (T/X)/f -/
@[simp] theorem iterated_slice_backward_map {T : Type u₁} [category T] {X : T} (f : over X) (g : over (comma.left f)) (h : over (comma.left f)) (α : g ⟶ h) : functor.map (iterated_slice_backward f) α = hom_mk (hom_mk (comma_morphism.left α)) :=
  Eq.refl (functor.map (iterated_slice_backward f) α)

/-- Given f : Y ⟶ X, we have an equivalence between (T/X)/f and T/Y -/
@[simp] theorem iterated_slice_equiv_counit_iso {T : Type u₁} [category T] {X : T} (f : over X) : equivalence.counit_iso (iterated_slice_equiv f) =
  nat_iso.of_components
    (fun (g : over (comma.left f)) =>
      iso_mk (iso.refl (comma.left (functor.obj (iterated_slice_backward f ⋙ iterated_slice_forward f) g))))
    (iterated_slice_equiv._proof_5 f) :=
  Eq.refl (equivalence.counit_iso (iterated_slice_equiv f))

theorem iterated_slice_forward_forget {T : Type u₁} [category T] {X : T} (f : over X) : iterated_slice_forward f ⋙ forget (comma.left f) = forget f ⋙ forget X :=
  rfl

theorem iterated_slice_backward_forget_forget {T : Type u₁} [category T] {X : T} (f : over X) : iterated_slice_backward f ⋙ forget f ⋙ forget X = forget (comma.left f) :=
  rfl

/-- A functor `F : T ⥤ D` induces a functor `over X ⥤ over (F.obj X)` in the obvious way. -/
@[simp] theorem post_map_right {T : Type u₁} [category T] {X : T} {D : Type u₂} [category D] (F : T ⥤ D) (Y₁ : over X) (Y₂ : over X) (f : Y₁ ⟶ Y₂) : comma_morphism.right (functor.map (post F) f) =
  id (fun (F : T ⥤ D) (Y₁ Y₂ : over X) (f : Y₁ ⟶ Y₂) => ulift.up (eq.mpr post._proof_1 (plift.up (of_as_true trivial))))
    F Y₁ Y₂ f :=
  Eq.refl (comma_morphism.right (functor.map (post F) f))

end over

/-- The under category has as objects arrows with domain `X` and as morphisms commutative
    triangles. -/
def under {T : Type u₁} [category T] (X : T) :=
  comma (functor.from_punit X) 𝟭

-- Satisfying the inhabited linter

protected instance under.inhabited {T : Type u₁} [category T] [Inhabited T] : Inhabited (under Inhabited.default) :=
  { default := comma.mk 𝟙 }

namespace under

theorem under_morphism.ext {T : Type u₁} [category T] {X : T} {U : under X} {V : under X} {f : U ⟶ V} {g : U ⟶ V} (h : comma_morphism.right f = comma_morphism.right g) : f = g := sorry

@[simp] theorem under_left {T : Type u₁} [category T] {X : T} (U : under X) : comma.left U = PUnit.unit :=
  of_as_true trivial

@[simp] theorem id_right {T : Type u₁} [category T] {X : T} (U : under X) : comma_morphism.right 𝟙 = 𝟙 :=
  rfl

@[simp] theorem comp_right {T : Type u₁} [category T] {X : T} (a : under X) (b : under X) (c : under X) (f : a ⟶ b) (g : b ⟶ c) : comma_morphism.right (f ≫ g) = comma_morphism.right f ≫ comma_morphism.right g :=
  rfl

@[simp] theorem w {T : Type u₁} [category T] {X : T} {A : under X} {B : under X} (f : A ⟶ B) : comma.hom A ≫ comma_morphism.right f = comma.hom B := sorry

/-- To give an object in the under category, it suffices to give an arrow with domain `X`. -/
@[simp] theorem mk_left {T : Type u₁} [category T] {X : T} {Y : T} (f : X ⟶ Y) : comma.left (mk f) = PUnit.unit :=
  Eq.refl (comma.left (mk f))

/-- To give a morphism in the under category, it suffices to give a morphism fitting in a
    commutative triangle. -/
@[simp] theorem hom_mk_left {T : Type u₁} [category T] {X : T} {U : under X} {V : under X} (f : comma.right U ⟶ comma.right V) (w : autoParam (comma.hom U ≫ f = comma.hom V)
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
    (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])) : comma_morphism.left (hom_mk f) =
  id
    (fun {X : T} {U V : under X} (f : comma.right U ⟶ comma.right V) (w : comma.hom U ≫ f = comma.hom V) =>
      eq.mpr hom_mk._proof_1 (ulift.up (eq.mpr hom_mk._proof_2 (plift.up (of_as_true trivial)))))
    X U V f w :=
  Eq.refl (comma_morphism.left (hom_mk f))

/--
Construct an isomorphism in the over category given isomorphisms of the objects whose forward
direction gives a commutative triangle.
-/
def iso_mk {T : Type u₁} [category T] {X : T} {f : under X} {g : under X} (hr : comma.right f ≅ comma.right g) (hw : comma.hom f ≫ iso.hom hr = comma.hom g) : f ≅ g :=
  comma.iso_mk (eq_to_iso sorry) hr sorry

@[simp] theorem iso_mk_hom_right {T : Type u₁} [category T] {X : T} {f : under X} {g : under X} (hr : comma.right f ≅ comma.right g) (hw : comma.hom f ≫ iso.hom hr = comma.hom g) : comma_morphism.right (iso.hom (iso_mk hr hw)) = iso.hom hr :=
  rfl

@[simp] theorem iso_mk_inv_right {T : Type u₁} [category T] {X : T} {f : under X} {g : under X} (hr : comma.right f ≅ comma.right g) (hw : comma.hom f ≫ iso.hom hr = comma.hom g) : comma_morphism.right (iso.inv (iso_mk hr hw)) = iso.inv hr :=
  rfl

/-- The forgetful functor mapping an arrow to its domain. -/
def forget {T : Type u₁} [category T] (X : T) : under X ⥤ T :=
  comma.snd (functor.from_punit X) 𝟭

@[simp] theorem forget_obj {T : Type u₁} [category T] {X : T} {U : under X} : functor.obj (forget X) U = comma.right U :=
  rfl

@[simp] theorem forget_map {T : Type u₁} [category T] {X : T} {U : under X} {V : under X} {f : U ⟶ V} : functor.map (forget X) f = comma_morphism.right f :=
  rfl

/-- A morphism `X ⟶ Y` induces a functor `under Y ⥤ under X` in the obvious way. -/
def map {T : Type u₁} [category T] {X : T} {Y : T} (f : X ⟶ Y) : under Y ⥤ under X :=
  comma.map_left 𝟭 (discrete.nat_trans fun (_x : discrete PUnit) => f)

@[simp] theorem map_obj_right {T : Type u₁} [category T] {X : T} {Y : T} {f : X ⟶ Y} {U : under Y} : comma.right (functor.obj (map f) U) = comma.right U :=
  rfl

@[simp] theorem map_obj_hom {T : Type u₁} [category T] {X : T} {Y : T} {f : X ⟶ Y} {U : under Y} : comma.hom (functor.obj (map f) U) = f ≫ comma.hom U :=
  rfl

@[simp] theorem map_map_right {T : Type u₁} [category T] {X : T} {Y : T} {f : X ⟶ Y} {U : under Y} {V : under Y} {g : U ⟶ V} : comma_morphism.right (functor.map (map f) g) = comma_morphism.right g :=
  rfl

/-- Mapping by the identity morphism is just the identity functor. -/
def map_id {T : Type u₁} [category T] {Y : T} : map 𝟙 ≅ 𝟭 :=
  nat_iso.of_components (fun (X : under Y) => iso_mk (iso.refl (comma.right (functor.obj (map 𝟙) X))) sorry) sorry

/-- Mapping by the composite morphism `f ≫ g` is the same as mapping by `f` then by `g`. -/
def map_comp {T : Type u₁} [category T] {X : T} {Y : T} {Z : T} (f : X ⟶ Y) (g : Y ⟶ Z) : map (f ≫ g) ≅ map g ⋙ map f :=
  nat_iso.of_components (fun (X_1 : under Z) => iso_mk (iso.refl (comma.right (functor.obj (map (f ≫ g)) X_1))) sorry)
    sorry

/-- A functor `F : T ⥤ D` induces a functor `under X ⥤ under (F.obj X)` in the obvious way. -/
@[simp] theorem post_map_left {T : Type u₁} [category T] {D : Type u₂} [category D] {X : T} (F : T ⥤ D) (Y₁ : under X) (Y₂ : under X) (f : Y₁ ⟶ Y₂) : comma_morphism.left (functor.map (post F) f) =
  id
    (fun {X : T} (F : T ⥤ D) (Y₁ Y₂ : under X) (f : Y₁ ⟶ Y₂) =>
      ulift.up (eq.mpr post._proof_1 (plift.up (of_as_true trivial))))
    X F Y₁ Y₂ f :=
  Eq.refl (comma_morphism.left (functor.map (post F) f))


/-
Copyright (c) 2022 Jun Yoshida. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
-/

/-!

# Miscellaneous lemmas on `LawfulMonad`

-/

universe u v
variable {m : Type u → Type v}

theorem map_bind [Monad m] [LawfulMonad m] {α β γ : Type u} (f : α → β) (x : m α) (g : β → m γ) : (f <$> x) >>= g = x >>= (g ∘ f) := by
  rw [map_eq_pure_bind, bind_assoc]
  apply bind_congr
  intro a; rw [pure_bind]
  rfl


import Mathlib.Tactic.Alias
import Mathlib.Tactic.RunCmd
import Std.Tactic.GuardExpr

open Lean Meta
namespace Alias
namespace A

/-- doc string for foo -/
theorem foo : 1 + 1 = 2 := rfl

/-- doc string for `alias foo` -/
alias foo ← foo1 foo2 foo3 _root_.B.foo4

example : 1 + 1 = 2 := foo1
example : 1 + 1 = 2 := foo2
example : 1 + 1 = 2 := foo3

def bar : Nat := 5
alias bar ← bar1 bar2
example : bar1 = 5 := rfl
example : bar2 = 5 := rfl

theorem baz (x : Nat) : x = x := rfl
alias baz ← baz1
example : 3 = 3 := baz1 3

theorem ab_iff_ba {t : Type} {a b : t} : a = b ↔ b = a := Iff.intro Eq.symm Eq.symm
alias ab_iff_ba ↔ ba_of_ab ab_of_ba
example {a b : Nat} : a = b → b = a := ba_of_ab
example {t : Type} {a b : t} : b = a → a = b := ab_of_ba

theorem a_iff_a_and_a (a : Prop) : a ↔ a ∧ a :=
  Iff.intro (λ x => ⟨x,x⟩) (λ x => x.1)

alias a_iff_a_and_a ↔ forward _
alias a_iff_a_and_a ↔ _ backward

example : True → True ∧ True := forward True
example : True ∧ True → True := backward True

/-- doc string for `alias a_iff_a_and_a` -/
alias a_iff_a_and_a ↔ ..
example : True → True ∧ True := a_and_a_of_a True
example : True ∧ True → True := a_of_a_and_a True

end A

-- test namespacing
example : 1 + 1 = 2 := A.foo1
example : 1 + 1 = 2 := B.foo4
example : True → True ∧ True := A.a_and_a_of_a True
example : True → True ∧ True := A.forward True
example : True ∧ True → True := A.backward True

namespace C

alias A.a_iff_a_and_a ↔ _root_.B.forward2 _
alias A.a_iff_a_and_a ↔ _ _root_.B.backward2

end C

example : True → True ∧ True := B.forward2 True
example : True ∧ True → True := B.backward2 True

theorem checkType : 1 + 1 = 2 ↔ 2 = 2 := .rfl
alias checkType ↔ forward backward

example : True := by
  have h1 := forward
  have h2 := backward
  guard_hyp h1 :ₛ 1 + 1 = 2 → 2 = 2
  guard_hyp h2 :ₛ 2 = 2 → 1 + 1 = 2
  trivial

end Alias


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

universes u₁ v₁ u₂

namespace Mathlib

namespace category_theory

namespace monad

namespace forget_creates_limits

/-- (Impl) The natural transformation used to define the new cone -/
@[simp] theorem γ_app {C : Type u₁} [category C] {T : C ⥤ C} [monad T] {J : Type v₁} [small_category J] (D : J ⥤ algebra T) (j : J) : nat_trans.app (γ D) j = algebra.a (functor.obj D j) :=
  Eq.refl (nat_trans.app (γ D) j)

/-- (Impl) This new cone is used to construct the algebra structure -/
@[simp] theorem new_cone_X {C : Type u₁} [category C] {T : C ⥤ C} [monad T] {J : Type v₁} [small_category J] (D : J ⥤ algebra T) (c : limits.cone (D ⋙ forget T)) : limits.cone.X (new_cone D c) = functor.obj T (limits.cone.X c) :=
  Eq.refl (limits.cone.X (new_cone D c))

/-- The algebra structure which will be the apex of the new limit cone for `D`. -/
@[simp] theorem cone_point_A {C : Type u₁} [category C] {T : C ⥤ C} [monad T] {J : Type v₁} [small_category J] (D : J ⥤ algebra T) (c : limits.cone (D ⋙ forget T)) (t : limits.is_limit c) : algebra.A (cone_point D c t) = limits.cone.X c :=
  Eq.refl (algebra.A (cone_point D c t))

/-- (Impl) Construct the lifted cone in `algebra T` which will be limiting. -/
@[simp] theorem lifted_cone_X {C : Type u₁} [category C] {T : C ⥤ C} [monad T] {J : Type v₁} [small_category J] (D : J ⥤ algebra T) (c : limits.cone (D ⋙ forget T)) (t : limits.is_limit c) : limits.cone.X (lifted_cone D c t) = cone_point D c t :=
  Eq.refl (limits.cone.X (lifted_cone D c t))

/-- (Impl) Prove that the lifted cone is limiting. -/
def lifted_cone_is_limit {C : Type u₁} [category C] {T : C ⥤ C} [monad T] {J : Type v₁} [small_category J] (D : J ⥤ algebra T) (c : limits.cone (D ⋙ forget T)) (t : limits.is_limit c) : limits.is_limit (lifted_cone D c t) :=
  limits.is_limit.mk fun (s : limits.cone D) => algebra.hom.mk (limits.is_limit.lift t (functor.map_cone (forget T) s))

end forget_creates_limits

-- Theorem 5.6.5 from [Riehl][riehl2017]

/-- The forgetful functor from the Eilenberg-Moore category creates limits. -/
protected instance forget_creates_limits {C : Type u₁} [category C] {T : C ⥤ C} [monad T] : creates_limits (forget T) :=
  creates_limits.mk
    fun (J : Type v₁) (𝒥 : small_category J) =>
      creates_limits_of_shape.mk
        fun (D : J ⥤ algebra T) =>
          creates_limit_of_reflects_iso
            fun (c : limits.cone (D ⋙ forget T)) (t : limits.is_limit c) =>
              lifts_to_limit.mk
                (liftable_cone.mk sorry
                  (limits.cones.ext (iso.refl (limits.cone.X (functor.map_cone (forget T) sorry))) sorry))
                sorry

/-- `D ⋙ forget T` has a limit, then `D` has a limit. -/
theorem has_limit_of_comp_forget_has_limit {C : Type u₁} [category C] {T : C ⥤ C} [monad T] {J : Type v₁} [small_category J] (D : J ⥤ algebra T) [limits.has_limit (D ⋙ forget T)] : limits.has_limit D :=
  has_limit_of_created D (forget T)

namespace forget_creates_colimits

-- Let's hide the implementation details in a namespace

-- We have a diagram D of shape J in the category of algebras, and we assume that we are given a

-- colimit for its image D ⋙ forget T under the forgetful functor, say its apex is L.

-- We'll construct a colimiting coalgebra for D, whose carrier will also be L.

-- To do this, we must find a map TL ⟶ L. Since T preserves colimits, TL is also a colimit.

-- In particular, it is a colimit for the diagram `(D ⋙ forget T) ⋙ T`

-- so to construct a map TL ⟶ L it suffices to show that L is the apex of a cocone for this diagram.

-- In other words, we need a natural transformation from const L to `(D ⋙ forget T) ⋙ T`.

-- But we already know that L is the apex of a cocone for the diagram `D ⋙ forget T`, so it

-- suffices to give a natural transformation `((D ⋙ forget T) ⋙ T) ⟶ (D ⋙ forget T)`:

/--
(Impl)
The natural transformation given by the algebra structure maps, used to construct a cocone `c` with
apex `colimit (D ⋙ forget T)`.
 -/
@[simp] theorem γ_app {C : Type u₁} [category C] {T : C ⥤ C} [monad T] {J : Type v₁} [small_category J] {D : J ⥤ algebra T} (j : J) : nat_trans.app γ j = algebra.a (functor.obj D j) :=
  Eq.refl (nat_trans.app γ j)

/--
(Impl)
A cocone for the diagram `(D ⋙ forget T) ⋙ T` found by composing the natural transformation `γ`
with the colimiting cocone for `D ⋙ forget T`.
-/
@[simp] theorem new_cocone_X {C : Type u₁} [category C] {T : C ⥤ C} [monad T] {J : Type v₁} [small_category J] {D : J ⥤ algebra T} (c : limits.cocone (D ⋙ forget T)) : limits.cocone.X (new_cocone c) = limits.cocone.X c :=
  Eq.refl (limits.cocone.X (new_cocone c))

/--
(Impl)
Define the map `λ : TL ⟶ L`, which will serve as the structure of the coalgebra on `L`, and
we will show is the colimiting object. We use the cocone constructed by `c` and the fact that
`T` preserves colimits to produce this morphism.
-/
def lambda {C : Type u₁} [category C] {T : C ⥤ C} [monad T] {J : Type v₁} [small_category J] {D : J ⥤ algebra T} (c : limits.cocone (D ⋙ forget T)) (t : limits.is_colimit c) [limits.preserves_colimit (D ⋙ forget T) T] : limits.cocone.X (functor.map_cocone T c) ⟶ limits.cocone.X c :=
  limits.is_colimit.desc (limits.preserves_colimit.preserves t) (new_cocone c)

/-- (Impl) The key property defining the map `λ : TL ⟶ L`. -/
theorem commuting {C : Type u₁} [category C] {T : C ⥤ C} [monad T] {J : Type v₁} [small_category J] {D : J ⥤ algebra T} (c : limits.cocone (D ⋙ forget T)) (t : limits.is_colimit c) [limits.preserves_colimit (D ⋙ forget T) T] (j : J) : functor.map T (nat_trans.app (limits.cocone.ι c) j) ≫ lambda c t =
  algebra.a (functor.obj D j) ≫ nat_trans.app (limits.cocone.ι c) j :=
  limits.is_colimit.fac (limits.preserves_colimit.preserves t) (new_cocone c) j

/--
(Impl)
Construct the colimiting algebra from the map `λ : TL ⟶ L` given by `lambda`. We are required to
show it satisfies the two algebra laws, which follow from the algebra laws for the image of `D` and
our `commuting` lemma.
-/
@[simp] theorem cocone_point_A {C : Type u₁} [category C] {T : C ⥤ C} [monad T] {J : Type v₁} [small_category J] {D : J ⥤ algebra T} (c : limits.cocone (D ⋙ forget T)) (t : limits.is_colimit c) [limits.preserves_colimit (D ⋙ forget T) T] [limits.preserves_colimit ((D ⋙ forget T) ⋙ T) T] : algebra.A (cocone_point c t) = limits.cocone.X c :=
  Eq.refl (algebra.A (cocone_point c t))

/-- (Impl) Construct the lifted cocone in `algebra T` which will be colimiting. -/
@[simp] theorem lifted_cocone_X {C : Type u₁} [category C] {T : C ⥤ C} [monad T] {J : Type v₁} [small_category J] {D : J ⥤ algebra T} (c : limits.cocone (D ⋙ forget T)) (t : limits.is_colimit c) [limits.preserves_colimit (D ⋙ forget T) T] [limits.preserves_colimit ((D ⋙ forget T) ⋙ T) T] : limits.cocone.X (lifted_cocone c t) = cocone_point c t :=
  Eq.refl (limits.cocone.X (lifted_cocone c t))

/-- (Impl) Prove that the lifted cocone is colimiting. -/
@[simp] theorem lifted_cocone_is_colimit_desc_f {C : Type u₁} [category C] {T : C ⥤ C} [monad T] {J : Type v₁} [small_category J] {D : J ⥤ algebra T} (c : limits.cocone (D ⋙ forget T)) (t : limits.is_colimit c) [limits.preserves_colimit (D ⋙ forget T) T] [limits.preserves_colimit ((D ⋙ forget T) ⋙ T) T] (s : limits.cocone D) : algebra.hom.f (limits.is_colimit.desc (lifted_cocone_is_colimit c t) s) =
  limits.is_colimit.desc t (functor.map_cocone (forget T) s) :=
  Eq.refl (algebra.hom.f (limits.is_colimit.desc (lifted_cocone_is_colimit c t) s))

end forget_creates_colimits

-- TODO: the converse of this is true as well

/--
The forgetful functor from the Eilenberg-Moore category for a monad creates any colimit
which the monad itself preserves.
-/
protected instance forget_creates_colimit {C : Type u₁} [category C] {T : C ⥤ C} [monad T] {J : Type v₁} [small_category J] (D : J ⥤ algebra T) [limits.preserves_colimit (D ⋙ forget T) T] [limits.preserves_colimit ((D ⋙ forget T) ⋙ T) T] : creates_colimit D (forget T) :=
  creates_colimit_of_reflects_iso
    fun (c : limits.cocone (D ⋙ forget T)) (t : limits.is_colimit c) =>
      lifts_to_colimit.mk
        (liftable_cocone.mk
          (limits.cocone.mk (forget_creates_colimits.cocone_point c t)
            (nat_trans.mk fun (j : J) => algebra.hom.mk (nat_trans.app (limits.cocone.ι c) j)))
          (limits.cocones.ext
            (iso.refl
              (limits.cocone.X
                (functor.map_cocone (forget T)
                  (limits.cocone.mk (forget_creates_colimits.cocone_point c t)
                    (nat_trans.mk fun (j : J) => algebra.hom.mk (nat_trans.app (limits.cocone.ι c) j))))))
            sorry))
        (forget_creates_colimits.lifted_cocone_is_colimit c t)

protected instance forget_creates_colimits_of_shape {C : Type u₁} [category C] {T : C ⥤ C} [monad T] {J : Type v₁} [small_category J] [limits.preserves_colimits_of_shape J T] : creates_colimits_of_shape J (forget T) :=
  creates_colimits_of_shape.mk fun (K : J ⥤ algebra T) => monad.forget_creates_colimit K

protected instance forget_creates_colimits {C : Type u₁} [category C] {T : C ⥤ C} [monad T] [limits.preserves_colimits T] : creates_colimits (forget T) :=
  creates_colimits.mk fun (J : Type v₁) (𝒥₁ : small_category J) => monad.forget_creates_colimits_of_shape

/--
For `D : J ⥤ algebra T`, `D ⋙ forget T` has a colimit, then `D` has a colimit provided colimits
of shape `J` are preserved by `T`.
-/
theorem forget_creates_colimits_of_monad_preserves {C : Type u₁} [category C] {T : C ⥤ C} [monad T] {J : Type v₁} [small_category J] [limits.preserves_colimits_of_shape J T] (D : J ⥤ algebra T) [limits.has_colimit (D ⋙ forget T)] : limits.has_colimit D :=
  has_colimit_of_created D (forget T)

end monad

protected instance comp_comparison_forget_has_limit {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v₁} [small_category J] (F : J ⥤ D) (R : D ⥤ C) [monadic_right_adjoint R] [limits.has_limit (F ⋙ R)] : limits.has_limit ((F ⋙ monad.comparison R) ⋙ monad.forget (left_adjoint R ⋙ R)) :=
  limits.has_limit_of_iso (iso_whisker_left F (iso.symm (monad.comparison_forget R)))

protected instance comp_comparison_has_limit {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v₁} [small_category J] (F : J ⥤ D) (R : D ⥤ C) [monadic_right_adjoint R] [limits.has_limit (F ⋙ R)] : limits.has_limit (F ⋙ monad.comparison R) :=
  monad.has_limit_of_comp_forget_has_limit (F ⋙ monad.comparison R)

/-- Any monadic functor creates limits. -/
def monadic_creates_limits {C : Type u₁} [category C] {D : Type u₂} [category D] (R : D ⥤ C) [monadic_right_adjoint R] : creates_limits R :=
  creates_limits_of_nat_iso (monad.comparison_forget R)

/--
The forgetful functor from the Eilenberg-Moore category for a monad creates any colimit
which the monad itself preserves.
-/
def monadic_creates_colimit_of_preserves_colimit {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v₁} [small_category J] (R : D ⥤ C) (K : J ⥤ D) [monadic_right_adjoint R] [limits.preserves_colimit (K ⋙ R) (left_adjoint R ⋙ R)] [limits.preserves_colimit ((K ⋙ R) ⋙ left_adjoint R ⋙ R) (left_adjoint R ⋙ R)] : creates_colimit K R :=
  creates_colimit_of_nat_iso (monad.comparison_forget R)

/-- A monadic functor creates any colimits of shapes it preserves. -/
def monadic_creates_colimits_of_shape_of_preserves_colimits_of_shape {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v₁} [small_category J] (R : D ⥤ C) [monadic_right_adjoint R] [limits.preserves_colimits_of_shape J R] : creates_colimits_of_shape J R :=
  creates_colimits_of_shape_of_nat_iso (monad.comparison_forget R)

/-- A monadic functor creates colimits if it preserves colimits. -/
def monadic_creates_colimits_of_preserves_colimits {C : Type u₁} [category C] {D : Type u₂} [category D] (R : D ⥤ C) [monadic_right_adjoint R] [limits.preserves_colimits R] : creates_colimits R :=
  creates_colimits.mk
    fun (J : Type v₁) (𝒥₁ : small_category J) => monadic_creates_colimits_of_shape_of_preserves_colimits_of_shape R

theorem has_limit_of_reflective {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v₁} [small_category J] (F : J ⥤ D) (R : D ⥤ C) [limits.has_limit (F ⋙ R)] [reflective R] : limits.has_limit F :=
  has_limit_of_created F R

/-- If `C` has limits of shape `J` then any reflective subcategory has limits of shape `J`. -/
theorem has_limits_of_shape_of_reflective {C : Type u₁} [category C] {D : Type u₂} [category D] {J : Type v₁} [small_category J] [limits.has_limits_of_shape J C] (R : D ⥤ C) [reflective R] : limits.has_limits_of_shape J D :=
  limits.has_limits_of_shape.mk fun (F : J ⥤ D) => has_limit_of_reflective F R

/-- If `C` has limits then any reflective subcategory has limits. -/
theorem has_limits_of_reflective {C : Type u₁} [category C] {D : Type u₂} [category D] (R : D ⥤ C) [limits.has_limits C] [reflective R] : limits.has_limits D :=
  limits.has_limits.mk fun (J : Type v₁) (𝒥₁ : small_category J) => has_limits_of_shape_of_reflective R

/--
The reflector always preserves terminal objects. Note this in general doesn't apply to any other
limit.
-/
def left_adjoint_preserves_terminal_of_reflective {C : Type u₁} [category C] {D : Type u₂} [category D] (R : D ⥤ C) [reflective R] [limits.has_terminal C] : limits.preserves_limits_of_shape (discrete pempty) (left_adjoint R) :=
  limits.preserves_limits_of_shape.mk
    fun (K : discrete pempty ⥤ C) =>
      let _inst : limits.has_terminal D := sorry;
      let _inst_3 : creates_limits R := monadic_creates_limits R;
      let _inst_6 : limits.preserves_limit (functor.empty D) R :=
        category_theory.preserves_limit_of_creates_limit_and_has_limit (functor.empty D) R;
      let _inst_7 : limits.preserves_limit (functor.empty C) (left_adjoint R) :=
        limits.preserves_terminal_of_iso (left_adjoint R)
          (functor.map_iso (left_adjoint R) (iso.symm (limits.preserves_terminal.iso R)) ≪≫
            as_iso (nat_trans.app (adjunction.counit (adjunction.of_right_adjoint R)) (⊤_D)));
      limits.preserves_limit_of_iso_diagram (left_adjoint R) (iso.symm (functor.unique_from_empty K))


/-
Copyright (c) 2021 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov, Yaël Dillies
-/

import algebra.group.defs
import order.synonym

/-!
# Group structure on the order type synonyms

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

Transfer algebraic instances from `α` to `αᵒᵈ` and `lex α`.
-/

open order_dual

variables {α β : Type*}

/-! ### `order_dual` -/

@[to_additive] instance [h : has_one α] : has_one αᵒᵈ := h
@[to_additive] instance [h : has_mul α] : has_mul αᵒᵈ := h
@[to_additive] instance [h : has_inv α] : has_inv αᵒᵈ := h
@[to_additive] instance [h : has_div α] : has_div αᵒᵈ := h
@[to_additive] instance [h : has_smul α β] : has_smul α βᵒᵈ := h
@[to_additive] instance order_dual.has_smul' [h : has_smul α β] : has_smul αᵒᵈ β := h
@[to_additive order_dual.has_smul]
instance order_dual.has_pow [h : has_pow α β] : has_pow αᵒᵈ β := h
@[to_additive order_dual.has_smul']
instance order_dual.has_pow' [h : has_pow α β] : has_pow α βᵒᵈ := h
@[to_additive] instance [h : semigroup α] : semigroup αᵒᵈ := h
@[to_additive] instance [h : comm_semigroup α] : comm_semigroup αᵒᵈ := h
@[to_additive] instance [h : left_cancel_semigroup α] : left_cancel_semigroup αᵒᵈ := h
@[to_additive] instance [h : right_cancel_semigroup α] : right_cancel_semigroup αᵒᵈ := h
@[to_additive] instance [h : mul_one_class α] : mul_one_class αᵒᵈ := h
@[to_additive] instance [h : monoid α] : monoid αᵒᵈ := h
@[to_additive] instance [h : comm_monoid α] : comm_monoid αᵒᵈ := h
@[to_additive] instance [h : left_cancel_monoid α] : left_cancel_monoid αᵒᵈ := h
@[to_additive] instance [h : right_cancel_monoid α] : right_cancel_monoid αᵒᵈ := h
@[to_additive] instance [h : cancel_monoid α] : cancel_monoid αᵒᵈ := h
@[to_additive] instance [h : cancel_comm_monoid α] : cancel_comm_monoid αᵒᵈ := h
@[to_additive] instance [h : has_involutive_inv α] : has_involutive_inv αᵒᵈ := h
@[to_additive] instance [h : div_inv_monoid α] : div_inv_monoid αᵒᵈ := h
@[to_additive order_dual.subtraction_monoid]
instance [h : division_monoid α] : division_monoid αᵒᵈ := h
@[to_additive order_dual.subtraction_comm_monoid]
instance [h : division_comm_monoid α] : division_comm_monoid αᵒᵈ := h
@[to_additive] instance [h : group α] : group αᵒᵈ := h
@[to_additive] instance [h : comm_group α] : comm_group αᵒᵈ := h

@[simp, to_additive] lemma to_dual_one [has_one α] : to_dual (1 : α) = 1 := rfl
@[simp, to_additive] lemma of_dual_one [has_one α] : (of_dual 1 : α) = 1 := rfl
@[simp, to_additive]
lemma to_dual_mul [has_mul α] (a b : α) : to_dual (a * b) = to_dual a * to_dual b := rfl
@[simp, to_additive]
lemma of_dual_mul [has_mul α] (a b : αᵒᵈ) : of_dual (a * b) = of_dual a * of_dual b := rfl
@[simp, to_additive] lemma to_dual_inv [has_inv α] (a : α) : to_dual a⁻¹ = (to_dual a)⁻¹ := rfl
@[simp, to_additive] lemma of_dual_inv [has_inv α] (a : αᵒᵈ) : of_dual a⁻¹ = (of_dual a)⁻¹ := rfl
@[simp, to_additive]
lemma to_dual_div [has_div α] (a b : α) : to_dual (a / b) = to_dual a / to_dual b := rfl
@[simp, to_additive]
lemma of_dual_div [has_div α] (a b : αᵒᵈ) : of_dual (a / b) = of_dual a / of_dual b := rfl
@[simp, to_additive]
lemma to_dual_smul [has_smul α β] (a : α) (b : β) : to_dual (a • b) = a • to_dual b := rfl
@[simp, to_additive]
lemma of_dual_smul [has_smul α β] (a : α) (b : βᵒᵈ) : of_dual (a • b) = a • of_dual b := rfl
@[simp, to_additive]
lemma to_dual_smul' [has_smul α β] (a : α) (b : β) : to_dual a • b = a • b := rfl
@[simp, to_additive]
lemma of_dual_smul' [has_smul α β] (a : αᵒᵈ) (b : β) : of_dual a • b = a • b := rfl
@[simp, to_additive to_dual_smul, to_additive_reorder 1 4]
lemma to_dual_pow [has_pow α β] (a : α) (b : β) : to_dual (a ^ b) = to_dual a ^ b := rfl
@[simp, to_additive of_dual_smul, to_additive_reorder 1 4]
lemma of_dual_pow [has_pow α β] (a : αᵒᵈ) (b : β) : of_dual (a ^ b) = of_dual a ^ b := rfl
@[simp, to_additive to_dual_smul', to_additive_reorder 1 4]
lemma pow_to_dual [has_pow α β] (a : α) (b : β) : a ^ to_dual b = a ^ b := rfl
@[simp, to_additive of_dual_smul', to_additive_reorder 1 4]
lemma pow_of_dual [has_pow α β] (a : α) (b : βᵒᵈ) : a ^ of_dual b = a ^ b := rfl

/-! ### Lexicographical order -/

@[to_additive] instance [h : has_one α] : has_one (lex α) := h
@[to_additive] instance [h : has_mul α] : has_mul (lex α) := h
@[to_additive] instance [h : has_inv α] : has_inv (lex α) := h
@[to_additive] instance [h : has_div α] : has_div (lex α) := h
@[to_additive] instance [h : has_smul α β] : has_smul α (lex β) := h
@[to_additive] instance lex.has_smul' [h : has_smul α β] : has_smul (lex α) β := h
@[to_additive lex.has_smul] instance lex.has_pow [h : has_pow α β] : has_pow (lex α) β := h
@[to_additive lex.has_smul'] instance lex.has_pow' [h : has_pow α β] : has_pow α (lex β) := h
@[to_additive] instance [h : semigroup α] : semigroup (lex α) := h
@[to_additive] instance [h : comm_semigroup α] : comm_semigroup (lex α) := h
@[to_additive] instance [h : left_cancel_semigroup α] : left_cancel_semigroup (lex α) := h
@[to_additive] instance [h : right_cancel_semigroup α] : right_cancel_semigroup (lex α) := h
@[to_additive] instance [h : mul_one_class α] : mul_one_class (lex α) := h
@[to_additive] instance [h : monoid α] : monoid (lex α) := h
@[to_additive] instance [h : comm_monoid α] : comm_monoid (lex α) := h
@[to_additive] instance [h : left_cancel_monoid α] : left_cancel_monoid (lex α) := h
@[to_additive] instance [h : right_cancel_monoid α] : right_cancel_monoid (lex α) := h
@[to_additive] instance [h : cancel_monoid α] : cancel_monoid (lex α) := h
@[to_additive] instance [h : cancel_comm_monoid α] : cancel_comm_monoid (lex α) := h
@[to_additive] instance [h : has_involutive_inv α] : has_involutive_inv (lex α) := h
@[to_additive] instance [h : div_inv_monoid α] : div_inv_monoid (lex α) := h
@[to_additive order_dual.subtraction_monoid]
instance [h : division_monoid α] : division_monoid (lex α) := h
@[to_additive order_dual.subtraction_comm_monoid]
instance [h : division_comm_monoid α] : division_comm_monoid (lex α) := h
@[to_additive] instance [h : group α] : group (lex α) := h
@[to_additive] instance [h : comm_group α] : comm_group (lex α) := h

@[simp, to_additive] lemma to_lex_one [has_one α] : to_lex (1 : α) = 1 := rfl
@[simp, to_additive] lemma of_lex_one [has_one α] : (of_lex 1 : α) = 1 := rfl
@[simp, to_additive]
lemma to_lex_mul [has_mul α] (a b : α) : to_lex (a * b) = to_lex a * to_lex b := rfl
@[simp, to_additive]
lemma of_lex_mul [has_mul α] (a b : lex α) : of_lex (a * b) = of_lex a * of_lex b := rfl
@[simp, to_additive] lemma to_lex_inv [has_inv α] (a : α) : to_lex a⁻¹ = (to_lex a)⁻¹ := rfl
@[simp, to_additive] lemma of_lex_inv [has_inv α] (a : lex α) : of_lex a⁻¹ = (of_lex a)⁻¹ := rfl
@[simp, to_additive]
lemma to_lex_div [has_div α] (a b : α) : to_lex (a / b) = to_lex a / to_lex b := rfl
@[simp, to_additive]
lemma of_lex_div [has_div α] (a b : lex α) : of_lex (a / b) = of_lex a / of_lex b := rfl
@[simp, to_additive]
lemma to_lex_smul [has_smul α β] (a : α) (b : β) : to_lex (a • b) = a • to_lex b := rfl
@[simp, to_additive]
lemma of_lex_smul [has_smul α β] (a : α) (b : lex β) : of_lex (a • b) = a • of_lex b := rfl
@[simp, to_additive]
lemma to_lex_smul' [has_smul α β] (a : α) (b : β) : to_lex a • b = a • b := rfl
@[simp, to_additive]
lemma of_lex_smul' [has_smul α β] (a : lex α) (b : β) : of_lex a • b = a • b := rfl
@[simp, to_additive to_lex_smul, to_additive_reorder 1 4]
lemma to_lex_pow [has_pow α β] (a : α) (b : β) : to_lex (a ^ b) = to_lex a ^ b := rfl
@[simp, to_additive of_lex_smul, to_additive_reorder 1 4]
lemma of_lex_pow [has_pow α β] (a : lex α) (b : β) : of_lex (a ^ b) = of_lex a ^ b := rfl
@[simp, to_additive to_lex_smul, to_additive_reorder 1 4]
lemma pow_to_lex [has_pow α β] (a : α) (b : β) : a ^ to_lex b = a ^ b := rfl
@[simp, to_additive of_lex_smul, to_additive_reorder 1 4]
lemma pow_of_lex [has_pow α β] (a : α) (b : lex β) : a ^ of_lex b = a ^ b := rfl


import Kenny.sites.basic order.complete_boolean_algebra

universes u v

namespace lattice

class Sup_lattice (X : Type u) extends lattice X, has_Sup X :=
(le_Sup : ∀ {s : set X} {a : X}, a ∈ s → a ≤ Sup s)
(Sup_le : ∀ {s : set X} {a : X}, (∀ (b : X), b ∈ s → b ≤ a) → Sup s ≤ a)

class Sup_distrib_lattice (X : Type u) extends Sup_lattice X :=
(inf_Sup_le {} : ∀ {x : X} {s : set X}, x ⊓ lattice.Sup s ≤ lattice.Sup ((⊓) x '' s))

section Sup_lattice

instance complete_lattice.to_Sup_lattice {X : Type u} [complete_lattice X] : Sup_lattice X :=
{ .. (infer_instance : complete_lattice X) }

variables {X : Type u} [Sup_lattice X]

theorem le_Sup' {s : set X} {a : X} : a ∈ s → a ≤ Sup s :=
Sup_lattice.le_Sup

theorem Sup_le' {s : set X} {a : X} : (∀ (b : X), b ∈ s → b ≤ a) → Sup s ≤ a :=
Sup_lattice.Sup_le

theorem Sup_singleton' (x : X) : Sup {x} = x :=
le_antisymm (Sup_le' $ λ b hb, set.eq_of_mem_singleton hb ▸ le_refl _) $
le_Sup' $ set.mem_singleton x

end Sup_lattice

section Sup_discrete_lattice

instance complete_distrib_lattice.to_Sup_distrib_lattice {X : Type u} [complete_distrib_lattice X] : Sup_distrib_lattice X :=
{ inf_Sup_le := λ x s, by rw [inf_Sup_eq, Sup_image],
  .. (infer_instance : complete_distrib_lattice X) }

variables {X : Type u} [Sup_distrib_lattice X]

theorem inf_Sup {x : X} {s : set X} : x ⊓ lattice.Sup s = lattice.Sup ((⊓) x '' s) :=
le_antisymm Sup_distrib_lattice.inf_Sup_le $ Sup_le' $ λ b ⟨c, hcs, hxcb⟩, hxcb ▸ inf_le_inf (le_refl x) (le_Sup' hcs)

end Sup_discrete_lattice

end lattice

namespace category_theory

open lattice

variables {X : Type u}

class is_univalent (X : Type u) [category.{v} X] : Prop :=
(univalent : ∀ x y : X, ∀ e : x ≅ y, x = y)

theorem eq_of_iso [category.{v} X] [is_univalent X] {x y : X} (e : x ≅ y) : x = y :=
is_univalent.univalent x y e

instance is_univalent_partial_order [partial_order X] : is_univalent X :=
⟨λ x y e, le_antisymm e.1.1.1 e.2.1.1⟩

instance semilattice_inf.has_pullback [semilattice_inf X] : has_pullback X :=
⟨λ F,
{ cone :=
  { X := F.obj pullback_diagram.base_left ⊓ F.obj pullback_diagram.base_right,
    π :=
    { app := λ p, pullback_diagram.rec_on p ⟨⟨inf_le_left⟩⟩ ⟨⟨inf_le_right⟩⟩
        ⟨⟨le_trans inf_le_left (F.map pullback_diagram.hom.to_target_left).down.down⟩⟩,
      naturality' := by intros; ext } },
  is_limit :=
  { lift := λ c, ⟨⟨le_inf (c.π.app pullback_diagram.base_left).down.down (c.π.app pullback_diagram.base_right).down.down⟩⟩,
    fac' := by intros; ext,
    uniq' := by intros; ext } }⟩

instance Sup_lattice.has_site [Sup_distrib_lattice X] : has_site X :=
{ cov := λ U, { c | U ≤ Sup (sigma.fst '' c) },
  iso_mem := λ U V e, show U ≤ _, by rw [set.image_singleton, Sup_singleton']; exact e.2.1.1,
  comp_mem := λ U S HS F HF, le_trans HS $ Sup_le' $ λ x hx, let ⟨m, hmS, hmx⟩ := hx in
    hmx ▸ le_trans (HF m hmS) (Sup_le' $ λ y hy, let ⟨n, hnFS, hny⟩ := hy in
      le_Sup' ⟨⟨n.1, ⟨⟨le_trans n.2.1.1 m.2.1.1⟩⟩⟩, ⟨m, hmS, n, hnFS, rfl⟩, hny⟩),
  pullback_mem := λ U S HS V f,
  calc  V
      ≤ V ⊓ Sup (sigma.fst '' S) : le_inf (le_refl V) (le_trans f.1.1 HS)
  ... = Sup ((⊓) V '' (sigma.fst '' S)) : inf_Sup
  ... = Sup ((⊓) V ∘ sigma.fst '' S) : congr_arg Sup (set.image_comp _ _ S).symm
  ... ≤ Sup (sigma.fst '' {m | ∃ t ∈ S, (⟨_, pullback.fst f t.2⟩ : Σ W, W ⟶ V) = m}) :
    Sup_le' (λ b ⟨c, hcs, hb⟩, le_Sup' ⟨⟨V ⊓ c.1, ⟨⟨inf_le_left⟩⟩⟩, ⟨c, hcs, rfl⟩, hb⟩) }

end category_theory


import analysis.calculus.local_extr
import analysis.calculus.times_cont_diff
import analysis.calculus.iterated_deriv
import tactic data.fin
open set

namespace rolle_general

lemma shing (n : ℕ) (i j : fin (n+1)) (h : (j.val : fin (n+2)) < (i.val.succ : fin (n+2))) :
    j.val < i.val.succ :=
begin
  have h1 : (j.val : fin (n+2)).val = j.val,
  { rw fin.coe_val_of_lt (show j.1 < n + 2, by linarith [j.2]) },
  have h2 : (i.val.succ : fin (n+2)).val = i.val.succ,
  { rw fin.coe_val_of_lt (show i.1 + 1 < n + 2, by linarith [i.2]) },
  change (j.val : fin (n+2)).val < (i.val.succ : fin (n+2)).val at h,
  rwa [h1, h2] at h,
end

example (n : ℕ) (i j : fin n) (h : (j.val : fin (n+2)) < (i.val.succ : fin (n+2))) : j.val < i.val.succ :=
begin
  change (j.val : fin (n+2)).val < (i.val.succ : fin (n+2)).val at h,
  rwa [fin.coe_val_of_lt (show j.1 < n + 2, by linarith [j.2]),
       fin.coe_val_of_lt (show i.1 + 1 < n + 2, by linarith [i.2])] at h,
end

lemma one_step (n : ℕ) (a b : ℝ) (f : ℝ → ℝ) (x : fin (n+2) → ℝ) (hx : strict_mono x) :
    ∀ (f : ℝ → ℝ), continuous_on f (Icc a b) →
    (∀ i, x i ∈ (Icc a b) ∧ f (x i) = 0)  →
    ∃ (xp : fin(n+1) → ℝ), strict_mono xp ∧ ∀ (i : fin (n+1)), xp i ∈ (Icc a b) ∧ deriv f (xp i) = 0 :=
begin
    intros f hf hxi,
    have h1 : ∀ (i : fin (n+1)), ∃ y ∈ (Ioo (x i) (x (i+1))), deriv f y = 0,
        sorry,
    choose xp hxp using h1,
    use xp, split,
    intros i j hij,
    have hi := (hxp i).1, have hj := (hxp j).1,
    cases hi with hi1 hi2, cases hj with hj1 hj2,
    rcases lt_trichotomy ((i+1) : fin (n+2) ) (j : fin (n+2)) with h1|h2|h3,
    --rcases lt_trichotomy (fin.cast_succ (i+1)) (fin.cast_succ j) with h1|h2|h3,
    -- case (i+1) < j
    have hii1 := hx h1, linarith,
    -- case (i+1) = j
    rw h2 at hi2, linarith,
    -- case j < (i+1) is not possible because i < j
    exfalso,
        have h3n : (j : ℕ) < ((i + 1) : ℕ),
            norm_num at h3,
            have m3 := shing n i j h3, exact m3,
        have gf1 := nat.lt_succ_iff.mp h3n,
        have hijn : (i : ℕ) < (j : ℕ), exact hij, --strange as it looks, linarith needs this
        linarith,
    intro i, split,
    swap, exact (hxp i).2,
    have g0 := (hxp i).1,
    split,
    have g1 := (hxi i).1, cases g1 with g11 g12, cases g0 with g01 g02,
    linarith,
    have g1 := (hxi (i+1)).1, cases g1 with g11 g12, cases g0 with g01 g02,
    linarith,
end

example (a b : ℝ) (hab : a < b) (f : ℝ → ℝ) (n : ℕ) (hf : times_cont_diff_on ℝ (n+1) f (Ioo a b) ) :
  times_cont_diff_on ℝ n (deriv f) (Ioo a b) :=
begin
  have : deriv f = (λ u : ℝ →L[ℝ] ℝ, u 1) ∘ (fderiv ℝ f), by { ext x, refl },
  simp only [this],
  have : times_cont_diff_on ℝ n (fderiv ℝ f) (Ioo a b),
  { apply ((times_cont_diff_on_succ_iff_fderiv_within (unique_diff_on_Ioo a b)).1 hf).2.congr,
    assume x hx,
    calc fderiv ℝ f x = fderiv_within ℝ f univ x : by simp
    ... = fderiv_within ℝ f (univ ∩ Ioo a b) x :
      (fderiv_within_inter (Ioo_mem_nhds hx.1 hx.2) unique_diff_within_at_univ).symm
    ... = fderiv_within ℝ f (Ioo a b) x : by simp },
  apply times_cont_diff.comp_times_cont_diff_on _ this,
  exact (is_bounded_bilinear_map_apply.is_bounded_linear_map_left _).times_cont_diff
end

--This proof will unfortunately **not** work for Icc:
/-

example (a b : ℝ) (hab : a < b) (f : ℝ → ℝ) (n : ℕ) (hf : times_cont_diff_on ℝ (n+1) f (Icc a b) ) :
  times_cont_diff_on ℝ n (deriv f) (Icc a b) :=
begin
  have : deriv f = (λ u : ℝ →L[ℝ] ℝ, u 1) ∘ (fderiv ℝ f), by { ext x, refl },
  simp only [this],
  have : times_cont_diff_on ℝ n (fderiv ℝ f) (Icc a b),
  { apply ((times_cont_diff_on_succ_iff_fderiv_within (unique_diff_on_Icc hab)).1 hf).2.congr,
    assume x hx,
    calc fderiv ℝ f x = fderiv_within ℝ f univ x : by simp
    ... = fderiv_within ℝ f (univ ∩ Icc a b) x :
      (fderiv_within_inter (Ioo_mem_nhds hx.1 hx.2) unique_diff_within_at_univ).symm
    ... = fderiv_within ℝ f (Icc a b) x : by simp },
  apply times_cont_diff.comp_times_cont_diff_on _ this,
  exact (is_bounded_bilinear_map_apply.is_bounded_linear_map_left _).times_cont_diff
end

-/

theorem general_rolle (n : ℕ) (A B : ℝ) (hAB : A < B) (x : fin (n+2) → ℝ) (hx : strict_mono x) :
    ∀ (f : ℝ → ℝ), times_cont_diff_on ℝ n f (Icc A B) →
    (∀ i, x i ∈ (Icc A B) ∧ f (x i) = 0)  →
    ∃ c ∈ Ioo A B, iterated_deriv (n+1) f c = 0 :=
begin
    induction n with d hd,
    { -- base case, just plain Rolle `exists_deriv_eq_zero`
        intros f hf hi,
        norm_cast at hf,
        rw times_cont_diff_on_zero at hf,
        --unfold strict_mono at hx,
        have h001 : 0 < 1, linarith,
        -- The above was needed because linarith fails on next one:
        have h002 : (0 : fin 2) < (1 : fin 2), exact h001, -- linarith fails !!!???
        have hx01 := hx h002, clear h001, clear h002,
        have hx0 := hi 0,
        have hx1 := hi 1,
        cases hx0 with h11 h121, cases hx1 with h21 h221,
        have h3 : 0 < 1, linarith,
        have h41 : continuous_on f (Icc (x 0) (x 1)),
            have h412 : (Icc (x 0) (x 1)) ⊆ Icc A B,
            intros z hz, cases hz with hz1 hz2,
            cases h11 with h11z h12z,
            split, linarith,
            cases h21 with h21z h22z,
            linarith,
            exact continuous_on.mono hf h412,
        have h42 : f (x 0) = f (x 1), rw [h121, h221],
        have h5 := exists_deriv_eq_zero f hx01 h41 h42,
        cases h5 with c hc, cases hc with hc1 hc2,
        have h6 : c ∈ Ioo A B,
            cases hc1 with h61 h62, cases h11 with h111 h112,
            have h71: A < c, linarith,
            cases h21 with h211 h212,
            have h72 : c < B, linarith,
            split, exact h71, exact h72,
        rw iterated_deriv_one,
        use [c, h6], exact hc2,
    },
    { -- induction step
        -- the derivative is in Cᵈ
        intros f hf hi,
        have hfc := times_cont_diff_on.continuous_on hf,
        have H := one_step d.succ A B f x hx f hfc hi,
        cases H with xp hxp, cases hxp with hxpx hxpi,
        set g := deriv f with hg,
        --have h1 := times_cont_diff_on_succ_iff_has_fderiv_within_at.mp hf (x 0) (hi 0).1,
        -- above is not immediately useful
        have h0 := unique_diff_on_Icc hAB,
        have h00 : ((d + 1) : with_top ℕ) ≤ d.succ, norm_cast,
        have h1 := times_cont_diff_on.fderiv_within hf h0 h00,
        simp only [] at h1,
        have h000 : (1 : with_top ℕ) ≤ d.succ, norm_cast, sorry,
        have h01 := times_cont_diff_on.continuous_on_iterated_deriv_within hf h000 h0,
        have hder : times_cont_diff_on ℝ d g (Icc A B), -- should come from hf
            rw hg,
            sorry, -- this seems much harder to get than it should!!!
        have hdg := hd xp hxpx g hder, clear hd,
        have G := hdg hxpi,
        have K : iterated_deriv (d.succ + 1) f = iterated_deriv d.succ g,
            apply iterated_deriv_succ',
        rw ← K at G,
        exact G,
    },
    done
end

end rolle_general

------------------ Scratch space below here ------------------------------

#check deriv
#check times_cont_diff_on.continuous_on_iterated_deriv_within
#check times_cont_diff_on.differentiable_on_iterated_deriv_within
variables (f : ℝ → ℝ)
example (a b : ℝ) (hab : a < b) (f : ℝ → ℝ) (n : ℕ) (hf : times_cont_diff_on ℝ (n+1) f (Ioo a b) ) :
    times_cont_diff_on ℝ n (deriv f) (Ioo a b) :=
begin
    refine times_cont_diff_on_of_differentiable_on_deriv _,
    have h0 := unique_diff_on_Ioo a b,
    have h := (times_cont_diff_on_iff_continuous_on_differentiable_on_deriv h0).mp hf,
    cases h with h1 h2,
    intros m hm,
    have g := h2 m,
    have g1 : (m : with_top ℕ) < n + 1, sorry,
    have g2 := g g1,
    sorry,
    --refine times_cont_diff.times_cont_diff_on _
end

#check unique_diff_on_Ioo
#check times_cont_diff_iff_continuous_differentiable.mp
#check iterated_deriv_within_succ
#check differentiable ℝ f
#check times_cont_diff_on_iff_continuous_on_differentiable_on_deriv
#check times_cont_diff_on ℝ 3 f
#check times_cont_diff_zero
#check  times_cont_diff_on_succ_iff_has_fderiv_within_at


/- Copyright (c) 2020 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: ...
-/
import linear_algebra.basic
import algebra.group.hom
/- we will probably need to import other files soon too, like `linear_algebra.finite_dimensional`. -/
-- set_option trace.simplify true
run_cmd mk_simp_attr `RW_REP
meta def rw_simp  : tactic unit :=
`[  try {simp only with RW_REP}, try {exact rfl}]
run_cmd add_interactive [`rw_simp]

universe variables u v w w'
open group
open linear_map
open linear_equiv
open submodule
open linear_map.general_linear_group
/-
     I thinck i add three  lemma into  mathlib  line 1922 at the file linear_algebra.bassic
def to_linear_map (f : general_linear_group R M) : M →ₗ[R] M :=(to_linear_equiv f).to_linear_map
def to_linear_map_inv (f : general_linear_group R M) :
M →ₗ[R] M := (to_linear_equiv f⁻¹).to_linear_map
def to_fun (f : general_linear_group R M) : M → M :=  f.val
-/
attribute [RW_REP] coe_add coe_neg coe_smul coe_mk subtype.eta   eq.symm
namespace NOTATION
notation  `GL`                := general_linear_group
notation  `L`:80 f :80        := general_linear_group.to_linear_map f
notation  `F`:80 f :82        := general_linear_group.to_fun f   --- add in mathlib
notation  a` ⊚ `:80 b:80      := linear_map.comp a b
end NOTATION
/- maybe needs a shorter name -/
/-- A representation of a group `G` is an `R`-module `M` with a group homomorphisme from  `G` to
  `GL(M)`. Normally `M` is a vector space, but we don't need that for the definition. -/

def group_representation (G R M : Type*) [group G] [ring R] [add_comm_group M] [module R M] :
  Type* :=  G →* GL R M
-- open NOTATION
variables {G : Type u} {R : Type v} {M : Type w} {M' : Type w'}
  [group G] [ring R] [add_comm_group M] [module R M] [add_comm_group M'] [module R M']

instance : has_coe_to_fun (group_representation G R M) := ⟨_, λ g, g.to_fun⟩   ---
def has_coe_to (ρ : group_representation G R M) : G → (M →ₗ[R] M ) := λ g, L ρ g
notation  `⟦` ρ `⟧` :=  has_coe_to ρ
namespace MY_TEST
variables (f  : M →ₗ[R] M) ( x y : M)
variables (ρ : group_representation G R M)
include ρ
example : f (x+ y) = f(x)+f(y) :=  f.add x y

@[RW_REP] theorem   linearity (g : G ) (x y : M): ⟦ ρ ⟧ g (x+y) = ⟦ρ⟧ g (x) + ⟦ρ⟧ g (y) :=
begin exact (⟦ρ⟧ g).add x y end

@[RW_REP] theorem   smul' (g : G)  (r : R)(m : M) : (⟦ ρ⟧  g) (r • m) = r • ((⟦ ρ ⟧  g) m) := begin
     exact ( ⟦ ρ ⟧ g).smul r m,
end
variables  (g g' : G)

variables (p : submodule R M)

@[RW_REP]lemma F_linearity (x y : M) (g : G) : (F ρ g) (x+y) = (F ρ g) x + (F ρ g) y := begin
     exact (L ρ g).add x y,   --- the same for L !
end

variables (h : ∀ x : M, ∀ g : G,  (L ρ  g) x ∈ p)

--- le mécanisme est le suivant :
--- ρ : G →* GL R M
--- le problème étant que :: c'est un morphsime de groupe  mais c'est une structure
--- GL R M donc convertion merdique via L
--- Il y a ⇑

theorem L_to_F  (g : G) : (F ρ g)  = ⟦ρ⟧ g  := rfl

example (ρ : group_representation G R M) ( g g' : G) : ρ (g * g') = ρ g * ρ g' := ρ.map_mul g g'
@[RW_REP]lemma rmap_mul (ρ : group_representation G R M) ( g g' : G) :
      ⟦ ρ ⟧  (g * g')  =  ⟦ρ⟧  g   ⊚  ⟦ ρ ⟧  g' :=
begin
     ext, rw comp_apply, iterate 3{rw ← L_to_F}, rw ρ.map_mul,exact rfl,
end
-- @[RW_REP]lemma rmap_mul' (ρ : group_representation G R M) ( g g' : G) :
--           ⟦ρ⟧  g   ⊚  ⟦ ρ ⟧  g' = ⟦ ρ ⟧  (g * g') :=
-- begin
--      ext, rw comp_apply, iterate 3{rw ← L_to_F}, rw ρ.map_mul,exact rfl,
-- end
@[RW_REP] lemma rmap_one (ρ : group_representation G R M)  :
      ⟦ ρ ⟧  (1)  =  linear_map.id := begin
      ext,rw ← L_to_F,rw ρ.map_one,exact rfl,
      end
@[RW_REP] lemma rmap_inv_mul (ρ : group_representation G R M)(g: G)  :
      ⟦ ρ ⟧  (g * g⁻¹ )  =  linear_map.id := begin
      rw mul_inv_self,exact rmap_one ρ,
      end
@[RW_REP] lemma rmap_mul_inv (ρ : group_representation G R M)(g: G)  :
      ⟦ ρ ⟧  (g⁻¹  * g )  =  linear_map.id := begin
      rw inv_mul_self,exact rmap_one ρ,
      end
@[RW_REP] lemma rmap_inv' (ρ : group_representation G R M) (g : G) :
     ⟦ρ⟧  g   ⊚  ⟦ ρ ⟧  g⁻¹  = linear_map.id := begin
          rw ← rmap_mul,exact rmap_inv_mul ρ g,
     end
@[RW_REP] lemma rmap_inv''(ρ : group_representation G R M) (g : G) :
     ⟦ρ⟧  g⁻¹    ⊚  ⟦ ρ ⟧  g  = linear_map.id := begin
          rw ← rmap_mul,exact rmap_mul_inv ρ g ,
     end
@[RW_REP] lemma rmap_inv_apply'' (ρ : group_representation G R M) (g : G)(x : M) :
     (⟦ρ⟧  g⁻¹    ⊚  ⟦ ρ ⟧  g ) x = x := begin
          rw rmap_inv'',exact rfl,
     end
@[RW_REP] lemma rmap_inv_apply' (ρ : group_representation G R M) (g : G)(x : M) :
     (⟦ρ⟧  g    ⊚  ⟦ ρ ⟧  g⁻¹  ) x = x := begin
          rw rmap_inv',exact rfl,
     end
def has_inv (ρ : group_representation G R M)(g : G) :  M ≃ₗ[R]  M :=  {
     to_fun := ⟦ ρ ⟧ g ,
     add := linearity ρ g ,
     smul :=  smul' ρ g,
     inv_fun :=  ⟦ ρ ⟧ g⁻¹,
     left_inv :=  rmap_inv_apply'' ρ g,
     right_inv :=  rmap_inv_apply' ρ g
}
-- @[RW_REP] lemma rmap_inv (ρ : group_representation G R M)(g : G) :  -- 207
--      ⟦ ρ ⟧ g⁻¹ =  to_linear_map_inv (has_inv' ρ g )   := begin
--           ext,
--           sorry,
--      end
@[RW_REP]lemma star_is_oo (ρ : group_representation G R M) ( g g' : G) :
      ⟦ρ⟧  g   ⊚  ⟦ ρ ⟧  g'  =  ⟦ρ⟧  g   *  ⟦ ρ ⟧  g' :=  by rw_simp

@[RW_REP]lemma rmap_map_assoc (ρ : group_representation G R M)( g1 g2 g3 : G) : ⟦ρ⟧ (g1 * g2 *g3)  =
     ⟦ρ⟧ (g1) ⊚  (⟦ρ⟧  g2 ⊚   ⟦ρ⟧ g3)  :=
begin
      rw  group.mul_assoc,rw rmap_mul,rw rmap_mul,
     -- rw_simp,
end
example (ρ : group_representation G R M)( g1 g2 g3 g4 : G) : ⟦ρ⟧ (g1 * (g2 *g3 * g4))  =
     ⟦ρ⟧ (g1) ⊚  (⟦ρ⟧  g2 ⊚   ⟦ρ⟧ g3) * ⟦ ρ ⟧ g4  :=
begin

     rw_simp,
end
@[RW_REP]lemma times_to_oo (ρ : group_representation G R M)( g g' : G) :  ⟦ ρ ⟧  (g * g')  =  ⟦ρ⟧  g  *  ⟦ ρ ⟧  g' := begin
     rw_simp,
end
example (ρ : group_representation G R M)( g1 g2 g3 : G) : ⟦ρ⟧ (g1 * g2 *g3)  =
     ⟦ρ⟧ (g1) ⊚  ⟦ρ⟧  g2  *   ⟦ρ⟧ g3  :=
begin
     rw_simp,
end
@[RW_REP]lemma mul_to_composition_of_function (ρ : group_representation G R M) ( g g' : G) :
 ⟦ ρ⟧  (g * g')  = ( ⟦ ρ⟧  g )  *  (⟦  ρ ⟧  g') := begin
  rw_simp,
end
@[RW_REP]lemma mixte_linearity (ρ : group_representation G R M) ( g g' : G) (x y : M) (r : R):
       ⟦ ρ⟧  (g * g') (x+r • y) = ⟦ ρ ⟧ g ( ⟦ ρ ⟧ g' x )+ r • ⟦ ρ ⟧ g ( ⟦ ρ ⟧ g' y ) := begin
          iterate 2 {rw ← comp_apply},rw_simp, rw ← rmap_mul,
end
-- @[RW_REP]lemma L_to_F (g : G) :  (L ρ g).to_fun = (F ρ g) := rfl

example :    ⟦ ρ ⟧  (g * g') = ( ⟦ ρ⟧  g) ⊚   ( ⟦ρ⟧ g')  := by rw_simp
lemma mul_one (ρ : group_representation G R M) : (L ρ 1) = 1 := begin
rw ρ.map_one, exact rfl,
end
end MY_TEST

namespace group_representation
/- do we want this instance? Then we don't have to write `(ρ g).1 x` instead of `ρ g x`. -/
instance : has_coe (general_linear_group R M) (M →ₗ[R] M) := ⟨λ x, x.1⟩
protected structure morphism (ρ : group_representation G R M) (π : group_representation G R M') :
  Type (max w w') :=
  (linear_map : M →ₗ[R] M')
  (commute : ∀(g : G), linear_map ∘ ρ g  = π g ∘ linear_map)
protected structure equiv (ρ : group_representation G R M) (π : group_representation G R M') :
  Type (max w w') :=
  (f : M ≃ₗ[R] M')
  (commute : ∀(g : G), f ∘  ρ g = π g ∘  f)

variables (ρ : group_representation G R M)
variables (g g' : G)(x : M)
-- example (x y : M) (g : G) :  ρ  g (x+y)= ρ g x + ρ g y := begin rw (L ρ g).add x y, end

namespace stability
/-
     We define the notion of stable submodule.
     We make a sub-representation.
     ligne  384 algebra module submodule (conduit)
     il y a des lemmes de convertions.
 -/
variables {ρ1 : group_representation G R M}{p : submodule R M}
/-
     Strategy maths : We have ρ g x ∈ p for x ∈ p so
     you have a map : ρ' g : p → p ... linear_map, invertible (restriction of ρ g⁻¹ ) and trivial trivial trivial
     For lean : this is not trivial. We have to verify some stuff.
     Lemma to try to deal with convertion
-/
@[RW_REP]lemma sub_module.eq_trans (x y : M) (hx : x ∈ p)(hy : y ∈ p) :
(x : M) = (y : M) →  (⟨x,hx⟩ : p)   = (⟨ y,hy⟩ : p )  := begin
     intros,congr ; try { assumption },
end
@[RW_REP] lemma sub_module.eq_trans' (x y : p) : (x : M) = (y : M) → x = y := begin
          intros,rcases x,rcases y,congr; try {assumption},
end
-- lemma sub_module_val (x : M) (hx : x ∈ p) : (⟨x,hx ⟩ : p).val = (x : M) := rfl

def stable_sub_module (ρ : group_representation G R M)(p : submodule R M) :=
                     ∀ g : G, ∀ x : p, (⟦ρ⟧ ρ g) x ∈ p
/-
     First Step : we define G → (p →ₗ[R] p)
-/

def restriction (h : stable_sub_module ρ p) : G → (p →ₗ[R] p)  := λ g, begin
     exact {
          to_fun    := λ x, ⟨( ⟦ ρ⟧  g ) x, h g x⟩,
          add       := begin  intros x y, rw_simp, end,
          smul      := begin intro c, intros x, rw_simp, end
     },
end
open MY_TEST
@[RW_REP]lemma restriction_ext (h : stable_sub_module ρ p) (y : p)
: (( ⟦ρ⟧  g) y : M ) = (restriction ρ h g y : M) := rfl
@[RW_REP]lemma restriction_ext' (h : stable_sub_module ρ p) (y : p)
:   (restriction ρ h g y : M) = (( ⟦ρ⟧  g) y : M ) := rfl
def  restriction_equiv (h : stable_sub_module ρ p) (g : G) :  (p ≃ p) :=
{ to_fun := (restriction ρ h g),
  inv_fun := (restriction ρ h g⁻¹),
  left_inv := begin
               intros x,
                    apply sub_module.eq_trans',
                    iterate 2 {rw ← restriction_ext},
                    rw ← comp_apply,
                    apply rmap_inv_apply'',
                    -- rw [← comp_apply,←  mul_to_composition_of_linear_map, inv_mul_self, ρ.map_one],
                    -- exact rfl,end,
               end
  , right_inv := begin
               intros x,
               apply sub_module.eq_trans',
               iterate 2 {rw ← restriction_ext},
               rw  ← comp_apply,
               apply rmap_inv_apply',
  end }
def Restriction (h : stable_sub_module ρ p) (g : G) : p ≃ₗ[R] p :=
 { .. restriction ρ h g, .. restriction_equiv ρ h g}

def sub_representation (h : stable_sub_module ρ p) : group_representation G R p :=
{ to_fun := λ g, of_linear_equiv (Restriction ρ h g),
  map_one' := begin
               rw units.ext_iff, --- Creer un helper pour la sous structure car c'est chiant
               ext,rcases x,
               apply sub_module.eq_trans,
                rw rmap_one,exact rfl,
               end,
  map_mul' := begin intros g1 g2,rw units.ext_iff, ext, rcases x,
                    apply sub_module.eq_trans,rw_simp,rw of_linear_equiv_val,
                    rw rmap_mul,
                    rw comp_apply, exact rfl,
 end }
 variables (h : stable_sub_module ρ p)
 #check sub_representation ρ h
 notation ρ `/`h := sub_representation ρ h
 #check  ⟦ ρ / h⟧  g
 @[RW_REP]lemma sub_representation.val (ρ : group_representation G R M) (h : stable_sub_module ρ p)( x : p) :
     (⟦ρ⟧ g ) x.val = ( ⟦ ρ / h ⟧  g) x    := rfl

@[RW_REP] lemma rw_sub_module_action_to (ρ : group_representation G R M) (h : stable_sub_module ρ p) (x : p) :
     (⟦ρ ⟧ g) x = ⟦ρ / h⟧ g x :=
     begin
          -- rw_simp, --- joke :D
          exact rfl,
     end
example (ρ : group_representation G R M) (h : stable_sub_module ρ p) (x y : p)(r : R) (g g' : G): true :=
     begin

          have R : ⟦ ρ ⟧ g ( ⟦ ρ ⟧ g' x )+ r • ⟦ ρ ⟧ g ( ⟦ ρ ⟧ g' y ) =   ⟦ ρ / h ⟧ (g * g') (x+ r • y),
               swap, trivial,
               iterate 2 {rw ← comp_apply}, rw ← rmap_mul,rw ← smul',rw ← linearity,rw_simp,
          end
end stability
end group_representation


variables {A: Type*} {B : Type*} {C : Type*} {D : Type*} {h : A → B} {g : B → C} {f : C → D}

theorem Q1007 : (f ∘ g) ∘ h = f ∘ (g ∘ h) :=
begin
trivial,
end