/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Tim Baumann, Stephen Morgan, Scott Morrison, Floris van Doorn
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.functor
import Mathlib.PostPort

universes v u l u₂ v₂

namespace Mathlib

/-!
# Isomorphisms

This file defines isomorphisms between objects of a category.

## Main definitions

- `structure iso` : a bundled isomorphism between two objects of a category;
- `class is_iso` : an unbundled version of `iso`; note that `is_iso f` is usually *not* a `Prop`,
  because it holds the inverse morphism;
- `as_iso` : convert from `is_iso` to `iso`;
- `of_iso` : convert from `iso` to `is_iso`;
- standard operations on isomorphisms (composition, inverse etc)

## Notations

- `X ≅ Y` : same as `iso X Y`;
- `α ≪≫ β` : composition of two isomorphisms; it is called `iso.trans`

## Tags

category, category theory, isomorphism
-/

namespace category_theory

/--
An isomorphism (a.k.a. an invertible morphism) between two objects of a category.
The inverse morphism is bundled.

See also `category_theory.core` for the category with the same objects and isomorphisms playing
the role of morphisms.

See https://stacks.math.columbia.edu/tag/0017.
-/
structure iso {C : Type u} [category C] (X : C) (Y : C) where
  hom : X ⟶ Y
  inv : Y ⟶ X
  hom_inv_id' :
    autoParam (hom ≫ inv = 𝟙)
      (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
        (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])
  inv_hom_id' :
    autoParam (inv ≫ hom = 𝟙)
      (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
        (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])

@[simp] theorem iso.hom_inv_id {C : Type u} [category C] {X : C} {Y : C} (c : iso X Y) :
    iso.hom c ≫ iso.inv c = 𝟙 :=
  sorry

@[simp] theorem iso.inv_hom_id {C : Type u} [category C] {X : C} {Y : C} (c : iso X Y) :
    iso.inv c ≫ iso.hom c = 𝟙 :=
  sorry

@[simp] theorem iso.hom_inv_id_assoc {C : Type u} [category C] {X : C} {Y : C} (c : iso X Y)
    {X' : C} (f' : X ⟶ X') : iso.hom c ≫ iso.inv c ≫ f' = f' :=
  sorry

infixr:10 " ≅ " => Mathlib.category_theory.iso

namespace iso

theorem ext {C : Type u} [category C] {X : C} {Y : C} {α : X ≅ Y} {β : X ≅ Y} (w : hom α = hom β) :
    α = β :=
  sorry

/-- Inverse isomorphism. -/
def symm {C : Type u} [category C] {X : C} {Y : C} (I : X ≅ Y) : Y ≅ X := mk (inv I) (hom I)

@[simp] theorem symm_hom {C : Type u} [category C] {X : C} {Y : C} (α : X ≅ Y) :
    hom (symm α) = inv α :=
  rfl

@[simp] theorem symm_inv {C : Type u} [category C] {X : C} {Y : C} (α : X ≅ Y) :
    inv (symm α) = hom α :=
  rfl

@[simp] theorem symm_mk {C : Type u} [category C] {X : C} {Y : C} (hom : X ⟶ Y) (inv : Y ⟶ X)
    (hom_inv_id : hom ≫ inv = 𝟙) (inv_hom_id : inv ≫ hom = 𝟙) : symm (mk hom inv) = mk inv hom :=
  rfl

@[simp] theorem symm_symm_eq {C : Type u} [category C] {X : C} {Y : C} (α : X ≅ Y) :
    symm (symm α) = α :=
  sorry

@[simp] theorem symm_eq_iff {C : Type u} [category C] {X : C} {Y : C} {α : X ≅ Y} {β : X ≅ Y} :
    symm α = symm β ↔ α = β :=
  { mp := fun (h : symm α = symm β) => symm_symm_eq α ▸ symm_symm_eq β ▸ congr_arg symm h,
    mpr := congr_arg symm }

/-- Identity isomorphism. -/
@[simp] theorem refl_inv {C : Type u} [category C] (X : C) : inv (refl X) = 𝟙 :=
  Eq.refl (inv (refl X))

protected instance inhabited {C : Type u} [category C] {X : C} : Inhabited (X ≅ X) :=
  { default := refl X }

@[simp] theorem refl_symm {C : Type u} [category C] (X : C) : symm (refl X) = refl X := rfl

/-- Composition of two isomorphisms -/
def trans {C : Type u} [category C] {X : C} {Y : C} {Z : C} (α : X ≅ Y) (β : Y ≅ Z) : X ≅ Z :=
  mk (hom α ≫ hom β) (inv β ≫ inv α)

infixr:80 " ≪≫ " => Mathlib.category_theory.iso.trans

@[simp] theorem trans_mk {C : Type u} [category C] {X : C} {Y : C} {Z : C} (hom : X ⟶ Y)
    (inv : Y ⟶ X) (hom_inv_id : hom ≫ inv = 𝟙) (inv_hom_id : inv ≫ hom = 𝟙) (hom' : Y ⟶ Z)
    (inv' : Z ⟶ Y) (hom_inv_id' : hom' ≫ inv' = 𝟙) (inv_hom_id' : inv' ≫ hom' = 𝟙)
    (hom_inv_id'' : (hom ≫ hom') ≫ inv' ≫ inv = 𝟙) (inv_hom_id'' : (inv' ≫ inv) ≫ hom ≫ hom' = 𝟙) :
    mk hom inv ≪≫ mk hom' inv' = mk (hom ≫ hom') (inv' ≫ inv) :=
  rfl

@[simp] theorem trans_symm {C : Type u} [category C] {X : C} {Y : C} {Z : C} (α : X ≅ Y)
    (β : Y ≅ Z) : symm (α ≪≫ β) = symm β ≪≫ symm α :=
  rfl

@[simp] theorem trans_assoc {C : Type u} [category C] {X : C} {Y : C} {Z : C} {Z' : C} (α : X ≅ Y)
    (β : Y ≅ Z) (γ : Z ≅ Z') : (α ≪≫ β) ≪≫ γ = α ≪≫ β ≪≫ γ :=
  sorry

@[simp] theorem refl_trans {C : Type u} [category C] {X : C} {Y : C} (α : X ≅ Y) :
    refl X ≪≫ α = α :=
  ext (category.id_comp (hom α))

@[simp] theorem trans_refl {C : Type u} [category C] {X : C} {Y : C} (α : X ≅ Y) :
    α ≪≫ refl Y = α :=
  ext (category.comp_id (hom α))

@[simp] theorem symm_self_id {C : Type u} [category C] {X : C} {Y : C} (α : X ≅ Y) :
    symm α ≪≫ α = refl Y :=
  ext (inv_hom_id α)

@[simp] theorem self_symm_id {C : Type u} [category C] {X : C} {Y : C} (α : X ≅ Y) :
    α ≪≫ symm α = refl X :=
  ext (hom_inv_id α)

@[simp] theorem symm_self_id_assoc {C : Type u} [category C] {X : C} {Y : C} {Z : C} (α : X ≅ Y)
    (β : Y ≅ Z) : symm α ≪≫ α ≪≫ β = β :=
  eq.mpr (id (Eq._oldrec (Eq.refl (symm α ≪≫ α ≪≫ β = β)) (Eq.symm (trans_assoc (symm α) α β))))
    (eq.mpr (id (Eq._oldrec (Eq.refl ((symm α ≪≫ α) ≪≫ β = β)) (symm_self_id α)))
      (eq.mpr (id (Eq._oldrec (Eq.refl (refl Y ≪≫ β = β)) (refl_trans β))) (Eq.refl β)))

@[simp] theorem self_symm_id_assoc {C : Type u} [category C] {X : C} {Y : C} {Z : C} (α : X ≅ Y)
    (β : X ≅ Z) : α ≪≫ symm α ≪≫ β = β :=
  eq.mpr (id (Eq._oldrec (Eq.refl (α ≪≫ symm α ≪≫ β = β)) (Eq.symm (trans_assoc α (symm α) β))))
    (eq.mpr (id (Eq._oldrec (Eq.refl ((α ≪≫ symm α) ≪≫ β = β)) (self_symm_id α)))
      (eq.mpr (id (Eq._oldrec (Eq.refl (refl X ≪≫ β = β)) (refl_trans β))) (Eq.refl β)))

theorem inv_comp_eq {C : Type u} [category C] {X : C} {Y : C} {Z : C} (α : X ≅ Y) {f : X ⟶ Z}
    {g : Y ⟶ Z} : inv α ≫ f = g ↔ f = hom α ≫ g :=
  sorry

theorem eq_inv_comp {C : Type u} [category C] {X : C} {Y : C} {Z : C} (α : X ≅ Y) {f : X ⟶ Z}
    {g : Y ⟶ Z} : g = inv α ≫ f ↔ hom α ≫ g = f :=
  iff.symm (inv_comp_eq (symm α))

theorem comp_inv_eq {C : Type u} [category C] {X : C} {Y : C} {Z : C} (α : X ≅ Y) {f : Z ⟶ Y}
    {g : Z ⟶ X} : f ≫ inv α = g ↔ f = g ≫ hom α :=
  sorry

theorem eq_comp_inv {C : Type u} [category C] {X : C} {Y : C} {Z : C} (α : X ≅ Y) {f : Z ⟶ Y}
    {g : Z ⟶ X} : g = f ≫ inv α ↔ g ≫ hom α = f :=
  iff.symm (comp_inv_eq (symm α))

theorem inv_eq_inv {C : Type u} [category C] {X : C} {Y : C} (f : X ≅ Y) (g : X ≅ Y) :
    inv f = inv g ↔ hom f = hom g :=
  sorry

theorem hom_comp_eq_id {C : Type u} [category C] {X : C} {Y : C} (α : X ≅ Y) {f : Y ⟶ X} :
    hom α ≫ f = 𝟙 ↔ f = inv α :=
  eq.mpr (id (Eq._oldrec (Eq.refl (hom α ≫ f = 𝟙 ↔ f = inv α)) (Eq.symm (propext (eq_inv_comp α)))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (f = inv α ≫ 𝟙 ↔ f = inv α)) (category.comp_id (inv α))))
      (iff.refl (f = inv α)))

theorem comp_hom_eq_id {C : Type u} [category C] {X : C} {Y : C} (α : X ≅ Y) {f : Y ⟶ X} :
    f ≫ hom α = 𝟙 ↔ f = inv α :=
  eq.mpr (id (Eq._oldrec (Eq.refl (f ≫ hom α = 𝟙 ↔ f = inv α)) (Eq.symm (propext (eq_comp_inv α)))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (f = 𝟙 ≫ inv α ↔ f = inv α)) (category.id_comp (inv α))))
      (iff.refl (f = inv α)))

theorem hom_eq_inv {C : Type u} [category C] {X : C} {Y : C} (α : X ≅ Y) (β : Y ≅ X) :
    hom α = inv β ↔ hom β = inv α :=
  eq.mpr
    (id (Eq._oldrec (Eq.refl (hom α = inv β ↔ hom β = inv α)) (propext (inv_eq_inv (symm α) β))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (hom (symm α) = hom β ↔ hom β = inv α)) (propext eq_comm)))
      (iff.refl (hom β = hom (symm α))))

end iso

/-- `is_iso` typeclass expressing that a morphism is invertible.
    This contains the data of the inverse, but is a subsingleton type. -/
class is_iso {C : Type u} [category C] {X : C} {Y : C} (f : X ⟶ Y) where
  inv : Y ⟶ X
  hom_inv_id' :
    autoParam (f ≫ inv = 𝟙)
      (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
        (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])
  inv_hom_id' :
    autoParam (inv ≫ f = 𝟙)
      (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
        (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])

/-- Reinterpret a morphism `f` with an `is_iso f` instance as an `iso`. -/
def as_iso {C : Type u} [category C] {X : C} {Y : C} (f : X ⟶ Y) [h : is_iso f] : X ≅ Y :=
  iso.mk f (inv f)

@[simp] theorem as_iso_hom {C : Type u} [category C] {X : C} {Y : C} (f : X ⟶ Y) [is_iso f] :
    iso.hom (as_iso f) = f :=
  rfl

@[simp] theorem as_iso_inv {C : Type u} [category C] {X : C} {Y : C} (f : X ⟶ Y) [is_iso f] :
    iso.inv (as_iso f) = inv f :=
  rfl

namespace is_iso

@[simp] theorem hom_inv_id {C : Type u} [category C] {X : C} {Y : C} (f : X ⟶ Y) [is_iso f] :
    f ≫ inv f = 𝟙 :=
  hom_inv_id'

@[simp] theorem inv_hom_id {C : Type u} [category C] {X : C} {Y : C} (f : X ⟶ Y) [is_iso f] :
    inv f ≫ f = 𝟙 :=
  inv_hom_id'

@[simp] theorem hom_inv_id_assoc {C : Type u} [category C] {X : C} {Y : C} {Z : C} (f : X ⟶ Y)
    [is_iso f] (g : X ⟶ Z) : f ≫ inv f ≫ g = g :=
  iso.hom_inv_id_assoc (as_iso f) g

@[simp] theorem inv_hom_id_assoc {C : Type u} [category C] {X : C} {Y : C} {Z : C} (f : X ⟶ Y)
    [is_iso f] (g : Y ⟶ Z) : inv f ≫ f ≫ g = g :=
  iso.inv_hom_id_assoc (as_iso f) g

protected instance id {C : Type u} [category C] (X : C) : is_iso 𝟙 := mk 𝟙

protected instance of_iso {C : Type u} [category C] {X : C} {Y : C} (f : X ≅ Y) :
    is_iso (iso.hom f) :=
  mk (iso.inv f)

protected instance of_iso_inv {C : Type u} [category C] {X : C} {Y : C} (f : X ≅ Y) :
    is_iso (iso.inv f) :=
  is_iso.of_iso (iso.symm f)

protected instance inv_is_iso {C : Type u} [category C] {X : C} {Y : C} {f : X ⟶ Y} [is_iso f] :
    is_iso (inv f) :=
  is_iso.of_iso_inv (as_iso f)

protected instance comp_is_iso {C : Type u} [category C] {X : C} {Y : C} {Z : C} {f : X ⟶ Y}
    {h : Y ⟶ Z} [is_iso f] [is_iso h] : is_iso (f ≫ h) :=
  is_iso.of_iso (as_iso f ≪≫ as_iso h)

@[simp] theorem inv_id {C : Type u} [category C] {X : C} : inv 𝟙 = 𝟙 := rfl

@[simp] theorem inv_comp {C : Type u} [category C] {X : C} {Y : C} {Z : C} {f : X ⟶ Y} {h : Y ⟶ Z}
    [is_iso f] [is_iso h] : inv (f ≫ h) = inv h ≫ inv f :=
  rfl

@[simp] theorem inv_inv {C : Type u} [category C] {X : C} {Y : C} {f : X ⟶ Y} [is_iso f] :
    inv (inv f) = f :=
  rfl

@[simp] theorem iso.inv_inv {C : Type u} [category C] {X : C} {Y : C} (f : X ≅ Y) :
    inv (iso.inv f) = iso.hom f :=
  rfl

@[simp] theorem iso.inv_hom {C : Type u} [category C] {X : C} {Y : C} (f : X ≅ Y) :
    inv (iso.hom f) = iso.inv f :=
  rfl

@[simp] theorem inv_comp_eq {C : Type u} [category C] {X : C} {Y : C} {Z : C} (α : X ⟶ Y) [is_iso α]
    {f : X ⟶ Z} {g : Y ⟶ Z} : inv α ≫ f = g ↔ f = α ≫ g :=
  iso.inv_comp_eq (as_iso α)

@[simp] theorem eq_inv_comp {C : Type u} [category C] {X : C} {Y : C} {Z : C} (α : X ⟶ Y) [is_iso α]
    {f : X ⟶ Z} {g : Y ⟶ Z} : g = inv α ≫ f ↔ α ≫ g = f :=
  iso.eq_inv_comp (as_iso α)

@[simp] theorem comp_inv_eq {C : Type u} [category C] {X : C} {Y : C} {Z : C} (α : X ⟶ Y) [is_iso α]
    {f : Z ⟶ Y} {g : Z ⟶ X} : f ≫ inv α = g ↔ f = g ≫ α :=
  iso.comp_inv_eq (as_iso α)

@[simp] theorem eq_comp_inv {C : Type u} [category C] {X : C} {Y : C} {Z : C} (α : X ⟶ Y) [is_iso α]
    {f : Z ⟶ Y} {g : Z ⟶ X} : g = f ≫ inv α ↔ g ≫ α = f :=
  iso.eq_comp_inv (as_iso α)

protected instance epi_of_iso {C : Type u} [category C] {X : C} {Y : C} (f : X ⟶ Y) [is_iso f] :
    epi f :=
  epi.mk
    fun (Z : C) (g h : Y ⟶ Z) (w : f ≫ g = f ≫ h) =>
      eq.mpr (id (Eq._oldrec (Eq.refl (g = h)) (Eq.symm (inv_hom_id_assoc f g))))
        (eq.mpr (id (Eq._oldrec (Eq.refl (inv f ≫ f ≫ g = h)) w))
          (eq.mpr (id (Eq._oldrec (Eq.refl (inv f ≫ f ≫ h = h)) (inv_hom_id_assoc f h)))
            (Eq.refl h)))

protected instance mono_of_iso {C : Type u} [category C] {X : C} {Y : C} (f : X ⟶ Y) [is_iso f] :
    mono f :=
  mono.mk
    fun (Z : C) (g h : Z ⟶ X) (w : g ≫ f = h ≫ f) =>
      eq.mpr (id (Eq._oldrec (Eq.refl (g = h)) (Eq.symm (category.comp_id g))))
        (eq.mpr (id (Eq._oldrec (Eq.refl (g ≫ 𝟙 = h)) (Eq.symm (category.comp_id h))))
          (eq.mpr (id (Eq._oldrec (Eq.refl (g ≫ 𝟙 = h ≫ 𝟙)) (Eq.symm (hom_inv_id f))))
            (eq.mpr
              (id
                (Eq._oldrec (Eq.refl (g ≫ f ≫ inv f = h ≫ f ≫ inv f))
                  (Eq.symm (category.assoc g f (inv f)))))
              (eq.mpr (id (Eq._oldrec (Eq.refl ((g ≫ f) ≫ inv f = h ≫ f ≫ inv f)) w))
                (eq.mpr
                  (id
                    (Eq._oldrec (Eq.refl ((h ≫ f) ≫ inv f = h ≫ f ≫ inv f))
                      (Eq.symm (category.assoc h f (inv f)))))
                  (Eq.refl ((h ≫ f) ≫ inv f)))))))

end is_iso

theorem eq_of_inv_eq_inv {C : Type u} [category C] {X : C} {Y : C} {f : X ⟶ Y} {g : X ⟶ Y}
    [is_iso f] [is_iso g] (p : inv f = inv g) : f = g :=
  sorry

protected instance is_iso.subsingleton {C : Type u} [category C] {X : C} {Y : C} (f : X ⟶ Y) :
    subsingleton (is_iso f) :=
  sorry

theorem is_iso.inv_eq_inv {C : Type u} [category C] {X : C} {Y : C} {f : X ⟶ Y} {g : X ⟶ Y}
    [is_iso f] [is_iso g] : inv f = inv g ↔ f = g :=
  iso.inv_eq_inv (as_iso f) (as_iso g)

theorem hom_comp_eq_id {C : Type u} [category C] {X : C} {Y : C} (g : X ⟶ Y) [is_iso g]
    {f : Y ⟶ X} : g ≫ f = 𝟙 ↔ f = inv g :=
  iso.hom_comp_eq_id (as_iso g)

theorem comp_hom_eq_id {C : Type u} [category C] {X : C} {Y : C} (g : X ⟶ Y) [is_iso g]
    {f : Y ⟶ X} : f ≫ g = 𝟙 ↔ f = inv g :=
  iso.comp_hom_eq_id (as_iso g)

namespace iso

/-!
All these cancellation lemmas can be solved by `simp [cancel_mono]` (or `simp [cancel_epi]`),
but with the current design `cancel_mono` is not a good `simp` lemma,
because it generates a typeclass search.

When we can see syntactically that a morphism is a `mono` or an `epi`
because it came from an isomorphism, it's fine to do the cancellation via `simp`.

In the longer term, it might be worth exploring making `mono` and `epi` structures,
rather than typeclasses, with coercions back to `X ⟶ Y`.
Presumably we could write `X ↪ Y` and `X ↠ Y`.
-/

@[simp] theorem cancel_iso_hom_left {C : Type u} [category C] {X : C} {Y : C} {Z : C} (f : X ≅ Y)
    (g : Y ⟶ Z) (g' : Y ⟶ Z) : hom f ≫ g = hom f ≫ g' ↔ g = g' :=
  sorry

@[simp] theorem cancel_iso_inv_left {C : Type u} [category C] {X : C} {Y : C} {Z : C} (f : Y ≅ X)
    (g : Y ⟶ Z) (g' : Y ⟶ Z) : inv f ≫ g = inv f ≫ g' ↔ g = g' :=
  sorry

@[simp] theorem cancel_iso_hom_right {C : Type u} [category C] {X : C} {Y : C} {Z : C} (f : X ⟶ Y)
    (f' : X ⟶ Y) (g : Y ≅ Z) : f ≫ hom g = f' ≫ hom g ↔ f = f' :=
  sorry

@[simp] theorem cancel_iso_inv_right {C : Type u} [category C] {X : C} {Y : C} {Z : C} (f : X ⟶ Y)
    (f' : X ⟶ Y) (g : Z ≅ Y) : f ≫ inv g = f' ≫ inv g ↔ f = f' :=
  sorry

/-
Unfortunately cancelling an isomorphism from the right of a chain of compositions is awkward.
We would need separate lemmas for each chain length (worse: for each pair of chain lengths).

We provide two more lemmas, for case of three morphisms, because this actually comes up in practice,
but then stop.
-/

@[simp] theorem cancel_iso_hom_right_assoc {C : Type u} [category C] {W : C} {X : C} {X' : C}
    {Y : C} {Z : C} (f : W ⟶ X) (g : X ⟶ Y) (f' : W ⟶ X') (g' : X' ⟶ Y) (h : Y ≅ Z) :
    f ≫ g ≫ hom h = f' ≫ g' ≫ hom h ↔ f ≫ g = f' ≫ g' :=
  sorry

@[simp] theorem cancel_iso_inv_right_assoc {C : Type u} [category C] {W : C} {X : C} {X' : C}
    {Y : C} {Z : C} (f : W ⟶ X) (g : X ⟶ Y) (f' : W ⟶ X') (g' : X' ⟶ Y) (h : Z ≅ Y) :
    f ≫ g ≫ inv h = f' ≫ g' ≫ inv h ↔ f ≫ g = f' ≫ g' :=
  sorry

end iso

namespace functor

/-- A functor `F : C ⥤ D` sends isomorphisms `i : X ≅ Y` to isomorphisms `F.obj X ≅ F.obj Y` -/
def map_iso {C : Type u} [category C] {D : Type u₂} [category D] (F : C ⥤ D) {X : C} {Y : C}
    (i : X ≅ Y) : obj F X ≅ obj F Y :=
  iso.mk (map F (iso.hom i)) (map F (iso.inv i))

@[simp] theorem map_iso_hom {C : Type u} [category C] {D : Type u₂} [category D] (F : C ⥤ D) {X : C}
    {Y : C} (i : X ≅ Y) : iso.hom (map_iso F i) = map F (iso.hom i) :=
  rfl

@[simp] theorem map_iso_inv {C : Type u} [category C] {D : Type u₂} [category D] (F : C ⥤ D) {X : C}
    {Y : C} (i : X ≅ Y) : iso.inv (map_iso F i) = map F (iso.inv i) :=
  rfl

@[simp] theorem map_iso_symm {C : Type u} [category C] {D : Type u₂} [category D] (F : C ⥤ D)
    {X : C} {Y : C} (i : X ≅ Y) : map_iso F (iso.symm i) = iso.symm (map_iso F i) :=
  rfl

@[simp] theorem map_iso_trans {C : Type u} [category C] {D : Type u₂} [category D] (F : C ⥤ D)
    {X : C} {Y : C} {Z : C} (i : X ≅ Y) (j : Y ≅ Z) :
    map_iso F (i ≪≫ j) = map_iso F i ≪≫ map_iso F j :=
  iso.ext (map_comp F (iso.hom i) (iso.hom j))

@[simp] theorem map_iso_refl {C : Type u} [category C] {D : Type u₂} [category D] (F : C ⥤ D)
    (X : C) : map_iso F (iso.refl X) = iso.refl (obj F X) :=
  iso.ext (map_id F X)

protected instance map_is_iso {C : Type u} [category C] {X : C} {Y : C} {D : Type u₂} [category D]
    (F : C ⥤ D) (f : X ⟶ Y) [is_iso f] : is_iso (map F f) :=
  is_iso.of_iso (map_iso F (as_iso f))

@[simp] theorem map_inv {C : Type u} [category C] {D : Type u₂} [category D] (F : C ⥤ D) {X : C}
    {Y : C} (f : X ⟶ Y) [is_iso f] : map F (inv f) = inv (map F f) :=
  rfl

theorem map_hom_inv {C : Type u} [category C] {D : Type u₂} [category D] (F : C ⥤ D) {X : C} {Y : C}
    (f : X ⟶ Y) [is_iso f] : map F f ≫ map F (inv f) = 𝟙 :=
  sorry

theorem map_inv_hom {C : Type u} [category C] {D : Type u₂} [category D] (F : C ⥤ D) {X : C} {Y : C}
    (f : X ⟶ Y) [is_iso f] : map F (inv f) ≫ map F f = 𝟙 :=
  sorry

end Mathlib


/-
Copyright 2020 Google LLC

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

      http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
 -/
import measure_theory.measurable_space

import measure_theory.measure_space
import measure_theory.outer_measure
import measure_theory.lebesgue_measure
import measure_theory.integration

import measure_theory.borel_space
import data.set.countable
import formal_ml.nnreal
import formal_ml.ennreal
import formal_ml.sum
import formal_ml.lattice
import formal_ml.measurable_space
import formal_ml.classical
import formal_ml.core
import formal_ml.characteristic
import data.equiv.list

lemma measure_theory.measure_unmeasurable {α:Type*} [M:measurable_space α]
(μ:measure_theory.measure α)
(S:set α):
μ S = ⨅ (t : set α) (st : S ⊆ t) (ht : measurable_set t), μ t :=
begin
  have h1:μ S = μ.to_outer_measure.trim S,
  { rw μ.trimmed,  rw measure_theory.to_outer_measure_apply },
  rw measure_theory.outer_measure.trim_eq_infi at h1,
  apply h1,
end

lemma measure_theory.measurable_sequence {α:Type*} [M:measurable_space α]
(μ:measure_theory.measure α)
(S:set α):
(μ S ≠ ⊤) →
∃ (f:ℕ → set α),
∀ n, measurable_set (f n) ∧ (S ⊆ f n) ∧ μ (f n) ≤ ((μ S) + (1)/((n:ennreal) + 1)) :=
begin
  intros h1,

  have h2 : μ S = ⨅ (t : set α) (st : S ⊆ t) (ht : measurable_set t), μ t,
  { apply measure_theory.measure_unmeasurable },
  rw ←  ennreal.lt_top_iff_ne_top at h1,
  have h4 := h1,

   rw h2 at h1,
  have h:∀ (n:ℕ), ∃ (T:set α), measurable_set T ∧ (S ⊆ T) ∧
          μ T ≤ ((μ S) + (1)/((n:ennreal) + 1)),
  { intros n,
    have h3_4 : μ S + ((n:ennreal) + 1)⁻¹ < ⊤,
    { rw ennreal.add_lt_top,  split, apply h4,
      simp, apply ennreal.add_pos_of_pos, apply ennreal.zero_lt_one },
    have h3_1:0< (1)/((n:nnreal) + 1) := nnreal.unit_frac_pos n,
    have h3_2:= @ennreal.le_of_infi _ _ ((1)/((n:nnreal) + 1)) h1 h3_1,
    cases h3_2 with t h3_2,
    simp at h3_2,
    rw ← h2 at h3_2,
    have h3_5 : S ⊆ t,
    { apply ennreal.infi_prop_le_elim (S ⊆ t),
      apply lt_of_le_of_lt h3_2,
      apply h3_4, },
    rw infi_prop_def at h3_2,
    --apply h3_5,
    have h3_6 : measurable_set t,
    { apply ennreal.infi_prop_le_elim (measurable_set t),
      apply lt_of_le_of_lt h3_2,
      apply h3_4, },
    rw infi_prop_def at h3_2,
    apply exists.intro t,
    split,
    apply h3_6,
    split,
    apply h3_5,
    --simp,
    have h3_7:1 / ((n:ennreal) + 1) = ((n:ennreal) + 1)⁻¹,
    { rw ennreal.one_div, },
    rw h3_7,
    apply h3_2,
    apply h3_6,
    apply h3_5 },
  rw classical.skolem at h,
  apply h,--sorry
end

lemma measure_theory.measurable_eq {α:Type*} [M:measurable_space α]
(μ:measure_theory.measure α) (S:set α):∃ T:set α,
measurable_set T ∧ μ T = μ S ∧ S ⊆ T :=
begin
  have h1:μ S = μ.to_outer_measure.trim S,
  { rw μ.trimmed,  rw measure_theory.to_outer_measure_apply },
  rw measure_theory.outer_measure.trim_eq_infi at h1,
  --rw h1,
  have h2 : ((μ S) = (⊤:ennreal)) ∨ ((μ S) ≠ (⊤:ennreal)),
  { apply em },
  cases h2,
  { apply exists.intro set.univ, split,
    apply measurable_set.univ, split,
    rw h2, rw ← top_le_iff,
    rw ← h2, apply measure_theory.measure_mono, simp, simp },
  { have h3 := measure_theory.measurable_sequence μ S h2,
    cases h3 with f h3,
    have h7:S ⊆ ⋂ (n:ℕ), f n,
    { rw set.subset_Inter_iff, intro n, apply (h3 n).right.left },
    apply exists.intro (⋂ n, f n),
    split,
    apply measurable_set.Inter,
    apply (λ n, (h3 n).left),
    split,
    apply le_antisymm,
    { apply ennreal.le_of_forall_pos_le_add,
      intros ε h4 h5,
      have h6 := nnreal.exists_unit_frac_lt_pos h4,
      cases h6 with n h6,
      apply @le_trans _ _ _ (μ (f n)),
      apply measure_theory.measure_mono, apply set.Inter_subset,
      --apply le_ _,
      apply le_trans ((h3 n).right.right),
      --apply ennreal.le_of_add_le_add_left,
      --apply h5,

      apply @add_le_add_left ennreal _ _,
      apply le_of_lt _,

      rw ← ennreal.coe_one,
      have C8A1:(n:ennreal) = ((n:nnreal):ennreal),
      { simp },
      rw C8A1,
      rw ← ennreal.coe_add,
      rw ← ennreal.coe_div,
      rw ennreal.coe_lt_coe,
      apply h6,
      simp },
      apply measure_theory.measure_mono,
      apply h7,
      apply h7 },
end

/--
  This is like measure_theory.measure_eq_inter_diff, but leverages measure_theory.le_to_outer_measure_caratheodory,  which could be considered an implementation detail.
 -/
lemma measure_theory.measure_eq_inter_diff' {α:Type*} [M:measurable_space α]
  {μ:measure_theory.measure α} {s t:set α}:measurable_set t → μ s = μ (s ∩ t) + μ (s \ t) :=
begin
  intros A1,
  have A2:M ≤ μ.to_outer_measure.caratheodory := measure_theory.le_to_outer_measure_caratheodory μ,
  have A3:μ.to_outer_measure.caratheodory.measurable_set' t,
  {apply A2,apply A1},
  rw measure_theory.outer_measure.is_caratheodory_iff at A3,
  apply A3,
end


def is_smooth {α β} (f : α → β) : Prop := sorry

class IsSmooth {α β} (f : α → β) : Prop where
  (proof : is_smooth f)

instance identity : IsSmooth fun a : α => a := sorry
instance const (b : β) : IsSmooth fun a : α => b := sorry
instance swap (f : α → β → γ) [∀ a, IsSmooth (f a)] : IsSmooth (λ b a => f a b) := sorry
instance parm (f : α → β → γ) [IsSmooth f] (b : β) : IsSmooth (λ a => f a b) := sorry
instance comp (f : β → γ) (g : α → β) [IsSmooth f] [IsSmooth g] : IsSmooth (fun a => f (g a)) := sorry
instance diag (f : β → δ → γ) (g : α → β) (h : α → δ) [IsSmooth f] [∀ b, IsSmooth (f b)] [IsSmooth g] [IsSmooth h] : IsSmooth (λ a => f (g a) (h a)) := sorry

set_option trace.Meta.synthInstance true
set_option trace.Meta.synthInstance.globalInstances false
set_option trace.Meta.synthInstance.newSubgoal false
set_option trace.Meta.synthInstance.tryResolve false
set_option trace.Meta.synthInstance.resume false
set_option trace.Meta.synthInstance.generate false
set_option trace.Meta.synthInstance.newAnswer false
set_option trace.Meta.synthInstance.unusedArgs true
example (f : β → δ → γ) [IsSmooth f] (d : δ) : IsSmooth (λ (g : α → β) a => f (g a) d) := by infer_instance


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

! This file was ported from Lean 3 source module category_theory.adjunction.lifting
! leanprover-community/mathlib commit 9bc7dfa6e50f902fb0684c9670a680459ebaed68
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Limits.Shapes.Equalizers
import Mathbin.CategoryTheory.Limits.Shapes.Reflexive
import Mathbin.CategoryTheory.Monad.Adjunction
import Mathbin.CategoryTheory.Monad.Coequalizer

/-!
# Adjoint lifting

This file gives two constructions for building left adjoints: the adjoint triangle theorem and the
adjoint lifting theorem.
The adjoint triangle theorem says that given a functor `U : B ⥤ C` with a left adjoint `F` such
that `ε_X : FUX ⟶ X` is a regular epi. Then for any category `A` with coequalizers of reflexive
pairs, a functor `R : A ⥤ B` has a left adjoint if (and only if) the composite `R ⋙ U` does.
Note that the condition on `U` regarding `ε_X` is automatically satisfied in the case when `U` is
a monadic functor, giving the corollary: `monadic_adjoint_triangle_lift`, i.e. if `U` is monadic,
`A` has reflexive coequalizers then `R : A ⥤ B` has a left adjoint provided `R ⋙ U` does.

The adjoint lifting theorem says that given a commutative square of functors (up to isomorphism):

      Q
    A → B
  U ↓   ↓ V
    C → D
      R

where `U` and `V` are monadic and `A` has reflexive coequalizers, then if `R` has a left adjoint
then `Q` has a left adjoint.

## Implementation

It is more convenient to prove this theorem by assuming we are given the explicit adjunction rather
than just a functor known to be a right adjoint. In docstrings, we write `(η, ε)` for the unit
and counit of the adjunction `adj₁ : F ⊣ U` and `(ι, δ)` for the unit and counit of the adjunction
`adj₂ : F' ⊣ R ⋙ U`.

## TODO

Dualise to lift right adjoints through comonads (by reversing 1-cells) and dualise to lift right
adjoints through monads (by reversing 2-cells), and the combination.

## References
* https://ncatlab.org/nlab/show/adjoint+triangle+theorem
* https://ncatlab.org/nlab/show/adjoint+lifting+theorem
* Adjoint Lifting Theorems for Categories of Algebras (PT Johnstone, 1975)
* A unified approach to the lifting of adjoints (AJ Power, 1988)
-/

namespace CategoryTheory

open Category Limits

universe v₁ v₂ v₃ v₄ u₁ u₂ u₃ u₄

variable {A : Type u₁} {B : Type u₂} {C : Type u₃}

variable [Category.{v₁} A] [Category.{v₂} B] [Category.{v₃} C]

-- Hide implementation details in this namespace
namespace LiftAdjoint

variable {U : B ⥤ C} {F : C ⥤ B} (R : A ⥤ B) (F' : C ⥤ A)

variable (adj₁ : F ⊣ U) (adj₂ : F' ⊣ R ⋙ U)

/-- To show that `ε_X` is a coequalizer for `(FUε_X, ε_FUX)`, it suffices to assume it's always a
coequalizer of something (i.e. a regular epi).
-/
def counitCoequalises [∀ X : B, RegularEpi (adj₁.counit.app X)] (X : B) :
    IsColimit (Cofork.ofπ (adj₁.counit.app X) (adj₁.counit_naturality _)) :=
  Cofork.IsColimit.mk' _ fun s =>
    by
    refine' ⟨(regular_epi.desc' (adj₁.counit.app X) s.π _).1, _, _⟩
    · rw [← cancel_epi (adj₁.counit.app (regular_epi.W (adj₁.counit.app X)))]
      rw [← adj₁.counit_naturality_assoc]
      dsimp only [functor.comp_obj]
      rw [← s.condition, ← F.map_comp_assoc, ← U.map_comp, regular_epi.w, U.map_comp,
        F.map_comp_assoc, s.condition, ← adj₁.counit_naturality_assoc]
    · apply (regular_epi.desc' (adj₁.counit.app X) s.π _).2
    · intro m hm
      rw [← cancel_epi (adj₁.counit.app X)]
      apply hm.trans (regular_epi.desc' (adj₁.counit.app X) s.π _).2.symm
#align category_theory.lift_adjoint.counit_coequalises CategoryTheory.LiftAdjoint.counitCoequalises

include adj₁ adj₂

/-- (Implementation)
To construct the left adjoint, we use the coequalizer of `F' U ε_Y` with the composite

`F' U F U X ⟶ F' U F U R F U' X ⟶ F' U R F' U X ⟶ F' U X`

where the first morphism is `F' U F ι_UX`, the second is `F' U ε_RF'UX`, and the third is `δ_F'UX`.
We will show that this coequalizer exists and that it forms the object map for a left adjoint to
`R`.
-/
def otherMap (X) : F'.obj (U.obj (F.obj (U.obj X))) ⟶ F'.obj (U.obj X) :=
  F'.map (U.map (F.map (adj₂.Unit.app _) ≫ adj₁.counit.app _)) ≫ adj₂.counit.app _
#align category_theory.lift_adjoint.other_map CategoryTheory.LiftAdjoint.otherMap

/--
`(F'Uε_X, other_map X)` is a reflexive pair: in particular if `A` has reflexive coequalizers then
it has a coequalizer.
-/
instance (X : B) :
    IsReflexivePair (F'.map (U.map (adj₁.counit.app X))) (otherMap _ _ adj₁ adj₂ X) :=
  IsReflexivePair.mk' (F'.map (adj₁.Unit.app (U.obj X)))
    (by
      rw [← F'.map_comp, adj₁.right_triangle_components]
      apply F'.map_id)
    (by
      dsimp [other_map]
      rw [← F'.map_comp_assoc, U.map_comp, adj₁.unit_naturality_assoc,
        adj₁.right_triangle_components, comp_id, adj₂.left_triangle_components])

variable [HasReflexiveCoequalizers A]

/-- Construct the object part of the desired left adjoint as the coequalizer of `F'Uε_Y` with
`other_map`.
-/
noncomputable def constructLeftAdjointObj (Y : B) : A :=
  coequalizer (F'.map (U.map (adj₁.counit.app Y))) (otherMap _ _ adj₁ adj₂ Y)
#align category_theory.lift_adjoint.construct_left_adjoint_obj CategoryTheory.LiftAdjoint.constructLeftAdjointObj

/-- The homset equivalence which helps show that `R` is a right adjoint. -/
@[simps (config := { rhsMd := semireducible })]
noncomputable def constructLeftAdjointEquiv [∀ X : B, RegularEpi (adj₁.counit.app X)] (Y : A)
    (X : B) : (constructLeftAdjointObj _ _ adj₁ adj₂ X ⟶ Y) ≃ (X ⟶ R.obj Y) :=
  calc
    (constructLeftAdjointObj _ _ adj₁ adj₂ X ⟶ Y) ≃
        { f : F'.obj (U.obj X) ⟶ Y //
          F'.map (U.map (adj₁.counit.app X)) ≫ f = otherMap _ _ adj₁ adj₂ _ ≫ f } :=
      Cofork.IsColimit.homIso (colimit.isColimit _) _
    _ ≃
        { g : U.obj X ⟶ U.obj (R.obj Y) //
          U.map (F.map g ≫ adj₁.counit.app _) = U.map (adj₁.counit.app _) ≫ g } :=
      by
      apply (adj₂.hom_equiv _ _).subtypeEquiv _
      intro f
      rw [← (adj₂.hom_equiv _ _).Injective.eq_iff, eq_comm, adj₂.hom_equiv_naturality_left,
        other_map, assoc, adj₂.hom_equiv_naturality_left, ← adj₂.counit_naturality,
        adj₂.hom_equiv_naturality_left, adj₂.hom_equiv_unit, adj₂.right_triangle_components,
        comp_id, functor.comp_map, ← U.map_comp, assoc, ← adj₁.counit_naturality,
        adj₂.hom_equiv_unit, adj₂.hom_equiv_unit, F.map_comp, assoc]
      rfl
    _ ≃ { z : F.obj (U.obj X) ⟶ R.obj Y // _ } :=
      by
      apply (adj₁.hom_equiv _ _).symm.subtypeEquiv
      intro g
      rw [← (adj₁.hom_equiv _ _).symm.Injective.eq_iff, adj₁.hom_equiv_counit,
        adj₁.hom_equiv_counit, adj₁.hom_equiv_counit, F.map_comp, assoc, U.map_comp, F.map_comp,
        assoc, adj₁.counit_naturality, adj₁.counit_naturality_assoc]
      apply eq_comm
    _ ≃ (X ⟶ R.obj Y) := (Cofork.IsColimit.homIso (counitCoequalises adj₁ X) _).symm

#align category_theory.lift_adjoint.construct_left_adjoint_equiv CategoryTheory.LiftAdjoint.constructLeftAdjointEquiv

/-- Construct the left adjoint to `R`, with object map `construct_left_adjoint_obj`. -/
noncomputable def constructLeftAdjoint [∀ X : B, RegularEpi (adj₁.counit.app X)] : B ⥤ A :=
  by
  refine'
    adjunction.left_adjoint_of_equiv (fun X Y => construct_left_adjoint_equiv R _ adj₁ adj₂ Y X) _
  intro X Y Y' g h
  rw [construct_left_adjoint_equiv_apply, construct_left_adjoint_equiv_apply, Function.comp_apply,
    Function.comp_apply, Equiv.trans_apply, Equiv.trans_apply, Equiv.trans_apply, Equiv.trans_apply,
    Equiv.symm_apply_eq, Subtype.ext_iff, cofork.is_colimit.hom_iso_natural, Equiv.apply_symm_apply,
    Equiv.subtypeEquiv_apply, Equiv.subtypeEquiv_apply, Equiv.subtypeEquiv_apply,
    Equiv.subtypeEquiv_apply, Subtype.coe_mk, Subtype.coe_mk, Subtype.coe_mk, Subtype.coe_mk, ←
    adj₁.hom_equiv_naturality_right_symm, cofork.is_colimit.hom_iso_natural,
    adj₂.hom_equiv_naturality_right, functor.comp_map]
#align category_theory.lift_adjoint.construct_left_adjoint CategoryTheory.LiftAdjoint.constructLeftAdjoint

end LiftAdjoint

/-- The adjoint triangle theorem: Suppose `U : B ⥤ C` has a left adjoint `F` such that each counit
`ε_X : FUX ⟶ X` is a regular epimorphism. Then if a category `A` has coequalizers of reflexive
pairs, then a functor `R : A ⥤ B` has a left adjoint if the composite `R ⋙ U` does.

Note the converse is true (with weaker assumptions), by `adjunction.comp`.
See https://ncatlab.org/nlab/show/adjoint+triangle+theorem
-/
noncomputable def adjointTriangleLift {U : B ⥤ C} {F : C ⥤ B} (R : A ⥤ B) (adj₁ : F ⊣ U)
    [∀ X : B, RegularEpi (adj₁.counit.app X)] [HasReflexiveCoequalizers A]
    [IsRightAdjoint (R ⋙ U)] : IsRightAdjoint R
    where
  left := LiftAdjoint.constructLeftAdjoint R _ adj₁ (Adjunction.ofRightAdjoint _)
  adj := Adjunction.adjunctionOfEquivLeft _ _
#align category_theory.adjoint_triangle_lift CategoryTheory.adjointTriangleLift

/-- If `R ⋙ U` has a left adjoint, the domain of `R` has reflexive coequalizers and `U` is a monadic
functor, then `R` has a left adjoint.
This is a special case of `adjoint_triangle_lift` which is often more useful in practice.
-/
noncomputable def monadicAdjointTriangleLift (U : B ⥤ C) [MonadicRightAdjoint U] {R : A ⥤ B}
    [HasReflexiveCoequalizers A] [IsRightAdjoint (R ⋙ U)] : IsRightAdjoint R :=
  by
  let R' : A ⥤ _ := R ⋙ monad.comparison (adjunction.of_right_adjoint U)
  rsuffices : is_right_adjoint R'
  · let this : is_right_adjoint (R' ⋙ (monad.comparison (adjunction.of_right_adjoint U)).inv) := by
      infer_instance
    · let this : R' ⋙ (monad.comparison (adjunction.of_right_adjoint U)).inv ≅ R :=
        (iso_whisker_left R (monad.comparison _).asEquivalence.unitIso.symm : _) ≪≫ R.right_unitor
      exact adjunction.right_adjoint_of_nat_iso this
  let this : is_right_adjoint (R' ⋙ monad.forget (adjunction.of_right_adjoint U).toMonad) :=
    adjunction.right_adjoint_of_nat_iso
      (iso_whisker_left R (monad.comparison_forget (adjunction.of_right_adjoint U)).symm : _)
  let this : ∀ X, regular_epi ((monad.adj (adjunction.of_right_adjoint U).toMonad).counit.app X) :=
    by
    intro X
    simp only [monad.adj_counit]
    exact ⟨_, _, _, _, monad.beck_algebra_coequalizer X⟩
  exact adjoint_triangle_lift R' (monad.adj _)
#align category_theory.monadic_adjoint_triangle_lift CategoryTheory.monadicAdjointTriangleLift

variable {D : Type u₄}

variable [Category.{v₄} D]

/-- Suppose we have a commutative square of functors

      Q
    A → B
  U ↓   ↓ V
    C → D
      R

where `U` has a left adjoint, `A` has reflexive coequalizers and `V` has a left adjoint such that
each component of the counit is a regular epi.
Then `Q` has a left adjoint if `R` has a left adjoint.

See https://ncatlab.org/nlab/show/adjoint+lifting+theorem
-/
noncomputable def adjointSquareLift (Q : A ⥤ B) (V : B ⥤ D) (U : A ⥤ C) (R : C ⥤ D)
    (comm : U ⋙ R ≅ Q ⋙ V) [IsRightAdjoint U] [IsRightAdjoint V] [IsRightAdjoint R]
    [∀ X, RegularEpi ((Adjunction.ofRightAdjoint V).counit.app X)] [HasReflexiveCoequalizers A] :
    IsRightAdjoint Q :=
  by
  let this := adjunction.right_adjoint_of_nat_iso comm
  exact adjoint_triangle_lift Q (adjunction.of_right_adjoint V)
#align category_theory.adjoint_square_lift CategoryTheory.adjointSquareLift

/-- Suppose we have a commutative square of functors

      Q
    A → B
  U ↓   ↓ V
    C → D
      R

where `U` has a left adjoint, `A` has reflexive coequalizers and `V` is monadic.
Then `Q` has a left adjoint if `R` has a left adjoint.

See https://ncatlab.org/nlab/show/adjoint+lifting+theorem
-/
noncomputable def monadicAdjointSquareLift (Q : A ⥤ B) (V : B ⥤ D) (U : A ⥤ C) (R : C ⥤ D)
    (comm : U ⋙ R ≅ Q ⋙ V) [IsRightAdjoint U] [MonadicRightAdjoint V] [IsRightAdjoint R]
    [HasReflexiveCoequalizers A] : IsRightAdjoint Q :=
  by
  let this := adjunction.right_adjoint_of_nat_iso comm
  exact monadic_adjoint_triangle_lift V
#align category_theory.monadic_adjoint_square_lift CategoryTheory.monadicAdjointSquareLift

end CategoryTheory


/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import category_theory.category.Bipointed
import order.category.PartialOrder
import order.hom.bounded

/-!
# The category of bounded orders

This defines `BoundedOrder`, the category of bounded orders.
-/

universes u v

open category_theory

/-- The category of bounded orders with monotone functions. -/
structure BoundedOrder :=
(to_PartialOrder : PartialOrder)
[is_bounded_order : bounded_order to_PartialOrder]

namespace BoundedOrder

instance : has_coe_to_sort BoundedOrder Type* := induced_category.has_coe_to_sort to_PartialOrder
instance (X : BoundedOrder) : partial_order X := X.to_PartialOrder.str

attribute [instance]  BoundedOrder.is_bounded_order

/-- Construct a bundled `BoundedOrder` from a `fintype` `partial_order`. -/
def of (α : Type*) [partial_order α] [bounded_order α] : BoundedOrder := ⟨⟨α⟩⟩

@[simp] lemma coe_of (α : Type*) [partial_order α] [bounded_order α] : ↥(of α) = α := rfl

instance : inhabited BoundedOrder := ⟨of punit⟩

instance large_category : large_category.{u} BoundedOrder :=
{ hom := λ X Y, bounded_order_hom X Y,
  id := λ X, bounded_order_hom.id X,
  comp := λ X Y Z f g, g.comp f,
  id_comp' := λ X Y, bounded_order_hom.comp_id,
  comp_id' := λ X Y, bounded_order_hom.id_comp,
  assoc' := λ W X Y Z _ _ _, bounded_order_hom.comp_assoc _ _ _ }

instance concrete_category : concrete_category BoundedOrder :=
{ forget := ⟨coe_sort, λ X Y, coe_fn, λ X, rfl, λ X Y Z f g, rfl⟩,
  forget_faithful := ⟨λ X Y, by convert fun_like.coe_injective⟩ }

instance has_forget_to_PartialOrder : has_forget₂ BoundedOrder PartialOrder :=
{ forget₂ := { obj := λ X, X.to_PartialOrder, map := λ X Y, bounded_order_hom.to_order_hom } }

instance has_forget_to_Bipointed : has_forget₂ BoundedOrder Bipointed :=
{ forget₂ := { obj := λ X, ⟨X, ⊥, ⊤⟩, map := λ X Y f, ⟨f, map_bot f, map_top f⟩ },
  forget_comp := rfl }

/-- `order_dual` as a functor. -/
@[simps] def dual : BoundedOrder ⥤ BoundedOrder :=
{ obj := λ X, of (order_dual X), map := λ X Y, bounded_order_hom.dual }

/-- Constructs an equivalence between bounded orders from an order isomorphism between them. -/
@[simps] def iso.mk {α β : BoundedOrder.{u}} (e : α ≃o β) : α ≅ β :=
{ hom := e,
  inv := e.symm,
  hom_inv_id' := by { ext, exact e.symm_apply_apply _ },
  inv_hom_id' := by { ext, exact e.apply_symm_apply _ } }

/-- The equivalence between `BoundedOrder` and itself induced by `order_dual` both ways. -/
@[simps functor inverse] def dual_equiv : BoundedOrder ≌ BoundedOrder :=
equivalence.mk dual dual
  (nat_iso.of_components (λ X, iso.mk $ order_iso.dual_dual X) $ λ X Y f, rfl)
  (nat_iso.of_components (λ X, iso.mk $ order_iso.dual_dual X) $ λ X Y f, rfl)

end BoundedOrder

lemma BoundedOrder_dual_comp_forget_to_PartialOrder :
  BoundedOrder.dual ⋙ forget₂ BoundedOrder PartialOrder =
    forget₂ BoundedOrder PartialOrder ⋙ PartialOrder.dual := rfl

lemma BoundedOrder_dual_comp_forget_to_Bipointed :
  BoundedOrder.dual ⋙ forget₂ BoundedOrder Bipointed =
    forget₂ BoundedOrder Bipointed ⋙ Bipointed.swap := rfl


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

! This file was ported from Lean 3 source module linear_algebra.tensor_algebra.basic
! leanprover-community/mathlib commit b8d2eaa69d69ce8f03179a5cda774fc0cde984e4
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.FreeAlgebra
import Mathbin.Algebra.RingQuot
import Mathbin.Algebra.TrivSqZeroExt
import Mathbin.Algebra.Algebra.Operations
import Mathbin.LinearAlgebra.Multilinear.Basic

/-!
# Tensor Algebras

Given a commutative semiring `R`, and an `R`-module `M`, we construct the tensor algebra of `M`.
This is the free `R`-algebra generated (`R`-linearly) by the module `M`.

## Notation

1. `tensor_algebra R M` is the tensor algebra itself. It is endowed with an R-algebra structure.
2. `tensor_algebra.ι R` is the canonical R-linear map `M → tensor_algebra R M`.
3. Given a linear map `f : M → A` to an R-algebra `A`, `lift R f` is the lift of `f` to an
  `R`-algebra morphism `tensor_algebra R M → A`.

## Theorems

1. `ι_comp_lift` states that the composition `(lift R f) ∘ (ι R)` is identical to `f`.
2. `lift_unique` states that whenever an R-algebra morphism `g : tensor_algebra R M → A` is
  given whose composition with `ι R` is `f`, then one has `g = lift R f`.
3. `hom_ext` is a variant of `lift_unique` in the form of an extensionality theorem.
4. `lift_comp_ι` is a combination of `ι_comp_lift` and `lift_unique`. It states that the lift
  of the composition of an algebra morphism with `ι` is the algebra morphism itself.

## Implementation details

As noted above, the tensor algebra of `M` is constructed as the free `R`-algebra generated by `M`,
modulo the additional relations making the inclusion of `M` into an `R`-linear map.
-/

variable (R : Type _) [CommSemiring R]

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

namespace TensorAlgebra

/-- An inductively defined relation on `pre R M` used to force the initial algebra structure on
the associated quotient.
-/
inductive Rel : FreeAlgebra R M → FreeAlgebra R M → Prop-- force `ι` to be linear

  | add {a b : M} : Rel (FreeAlgebra.ι R (a + b)) (FreeAlgebra.ι R a + FreeAlgebra.ι R b)
  |
  smul {r : R} {a : M} :
    Rel (FreeAlgebra.ι R (r • a)) (algebraMap R (FreeAlgebra R M) r * FreeAlgebra.ι R a)
#align tensor_algebra.rel TensorAlgebra.Rel

end TensorAlgebra

/- ./././Mathport/Syntax/Translate/Command.lean:42:9: unsupported derive handler algebra[algebra] R -/
/-- The tensor algebra of the module `M` over the commutative semiring `R`.
-/
def TensorAlgebra :=
  RingQuot (TensorAlgebra.Rel R M)deriving Inhabited, Semiring,
  «./././Mathport/Syntax/Translate/Command.lean:42:9: unsupported derive handler algebra[algebra] R»
#align tensor_algebra TensorAlgebra

namespace TensorAlgebra

instance {S : Type _} [CommRing S] [Module S M] : Ring (TensorAlgebra S M) :=
  RingQuot.ring (Rel S M)

variable {M}

/-- The canonical linear map `M →ₗ[R] tensor_algebra R M`.
-/
irreducible_def ι : M →ₗ[R] TensorAlgebra R M :=
  { toFun := fun m => RingQuot.mkAlgHom R _ (FreeAlgebra.ι R m)
    map_add' := fun x y => by
      rw [← AlgHom.map_add]
      exact RingQuot.mkAlgHom_rel R rel.add
    map_smul' := fun r x => by
      rw [← AlgHom.map_smul]
      exact RingQuot.mkAlgHom_rel R rel.smul }
#align tensor_algebra.ι TensorAlgebra.ι

theorem ringQuot_mkAlgHom_freeAlgebra_ι_eq_ι (m : M) :
    RingQuot.mkAlgHom R (Rel R M) (FreeAlgebra.ι R m) = ι R m :=
  by
  rw [ι]
  rfl
#align tensor_algebra.ring_quot_mk_alg_hom_free_algebra_ι_eq_ι TensorAlgebra.ringQuot_mkAlgHom_freeAlgebra_ι_eq_ι

/-- Given a linear map `f : M → A` where `A` is an `R`-algebra, `lift R f` is the unique lift
of `f` to a morphism of `R`-algebras `tensor_algebra R M → A`.
-/
@[simps symm_apply]
irreducible_def lift {A : Type _} [Semiring A] [Algebra R A] :
  (M →ₗ[R] A) ≃ (TensorAlgebra R M →ₐ[R] A) :=
  { toFun :=
      RingQuot.liftAlgHom R ∘ fun f =>
        ⟨FreeAlgebra.lift R ⇑f, fun x y (h : Rel R M x y) => by
          induction h <;>
            simp only [Algebra.smul_def, FreeAlgebra.lift_ι_apply, LinearMap.map_smulₛₗ,
              RingHom.id_apply, map_mul, AlgHom.commutes, map_add]⟩
    invFun := fun F => F.toLinearMap.comp (ι R)
    left_inv := fun f => by
      rw [ι]
      ext1 x
      exact (RingQuot.liftAlgHom_mkAlgHom_apply _ _ _ _).trans (FreeAlgebra.lift_ι_apply f x)
    right_inv := fun F =>
      RingQuot.ringQuot_ext' _ _ _ <|
        FreeAlgebra.hom_ext <|
          funext fun x => by
            rw [ι]
            exact
              (RingQuot.liftAlgHom_mkAlgHom_apply _ _ _ _).trans (FreeAlgebra.lift_ι_apply _ _) }
#align tensor_algebra.lift TensorAlgebra.lift

variable {R}

@[simp]
theorem ι_comp_lift {A : Type _} [Semiring A] [Algebra R A] (f : M →ₗ[R] A) :
    (lift R f).toLinearMap.comp (ι R) = f :=
  by
  convert(lift R).symm_apply_apply f
  simp only [lift, Equiv.coe_fn_symm_mk]
#align tensor_algebra.ι_comp_lift TensorAlgebra.ι_comp_lift

@[simp]
theorem lift_ι_apply {A : Type _} [Semiring A] [Algebra R A] (f : M →ₗ[R] A) (x) :
    lift R f (ι R x) = f x := by
  conv_rhs => rw [← ι_comp_lift f]
  rfl
#align tensor_algebra.lift_ι_apply TensorAlgebra.lift_ι_apply

@[simp]
theorem lift_unique {A : Type _} [Semiring A] [Algebra R A] (f : M →ₗ[R] A)
    (g : TensorAlgebra R M →ₐ[R] A) : g.toLinearMap.comp (ι R) = f ↔ g = lift R f :=
  by
  rw [← (lift R).symm_apply_eq]
  simp only [lift, Equiv.coe_fn_symm_mk]
#align tensor_algebra.lift_unique TensorAlgebra.lift_unique

-- Marking `tensor_algebra` irreducible makes `ring` instances inaccessible on quotients.
-- https://leanprover.zulipchat.com/#narrow/stream/113488-general/topic/algebra.2Esemiring_to_ring.20breaks.20semimodule.20typeclass.20lookup/near/212580241
-- For now, we avoid this by not marking it irreducible.
@[simp]
theorem lift_comp_ι {A : Type _} [Semiring A] [Algebra R A] (g : TensorAlgebra R M →ₐ[R] A) :
    lift R (g.toLinearMap.comp (ι R)) = g :=
  by
  rw [← lift_symm_apply]
  exact (lift R).apply_symm_apply g
#align tensor_algebra.lift_comp_ι TensorAlgebra.lift_comp_ι

/-- See note [partially-applied ext lemmas]. -/
@[ext]
theorem hom_ext {A : Type _} [Semiring A] [Algebra R A] {f g : TensorAlgebra R M →ₐ[R] A}
    (w : f.toLinearMap.comp (ι R) = g.toLinearMap.comp (ι R)) : f = g :=
  by
  rw [← lift_symm_apply, ← lift_symm_apply] at w
  exact (lift R).symm.Injective w
#align tensor_algebra.hom_ext TensorAlgebra.hom_ext

-- This proof closely follows `free_algebra.induction`
/-- If `C` holds for the `algebra_map` of `r : R` into `tensor_algebra R M`, the `ι` of `x : M`,
and is preserved under addition and muliplication, then it holds for all of `tensor_algebra R M`.
-/
@[elab_as_elim]
theorem induction {C : TensorAlgebra R M → Prop}
    (h_grade0 : ∀ r, C (algebraMap R (TensorAlgebra R M) r)) (h_grade1 : ∀ x, C (ι R x))
    (h_mul : ∀ a b, C a → C b → C (a * b)) (h_add : ∀ a b, C a → C b → C (a + b))
    (a : TensorAlgebra R M) : C a :=
  by
  -- the arguments are enough to construct a subalgebra, and a mapping into it from M
  let s : Subalgebra R (TensorAlgebra R M) :=
    { carrier := C
      mul_mem' := h_mul
      add_mem' := h_add
      algebraMap_mem' := h_grade0 }
  let of : M →ₗ[R] s := (ι R).codRestrict s.to_submodule h_grade1
  -- the mapping through the subalgebra is the identity
  have of_id : AlgHom.id R (TensorAlgebra R M) = s.val.comp (lift R of) :=
    by
    ext
    simp [of]
  -- finding a proof is finding an element of the subalgebra
  convert Subtype.prop (lift R of a)
  exact AlgHom.congr_fun of_id a
#align tensor_algebra.induction TensorAlgebra.induction

/-- The left-inverse of `algebra_map`. -/
def algebraMapInv : TensorAlgebra R M →ₐ[R] R :=
  lift R (0 : M →ₗ[R] R)
#align tensor_algebra.algebra_map_inv TensorAlgebra.algebraMapInv

variable (M)

theorem algebraMap_leftInverse :
    Function.LeftInverse algebraMapInv (algebraMap R <| TensorAlgebra R M) := fun x => by
  simp [algebra_map_inv]
#align tensor_algebra.algebra_map_left_inverse TensorAlgebra.algebraMap_leftInverse

@[simp]
theorem algebraMap_inj (x y : R) :
    algebraMap R (TensorAlgebra R M) x = algebraMap R (TensorAlgebra R M) y ↔ x = y :=
  (algebraMap_leftInverse M).Injective.eq_iff
#align tensor_algebra.algebra_map_inj TensorAlgebra.algebraMap_inj

@[simp]
theorem algebraMap_eq_zero_iff (x : R) : algebraMap R (TensorAlgebra R M) x = 0 ↔ x = 0 :=
  map_eq_zero_iff (algebraMap _ _) (algebraMap_leftInverse _).Injective
#align tensor_algebra.algebra_map_eq_zero_iff TensorAlgebra.algebraMap_eq_zero_iff

@[simp]
theorem algebraMap_eq_one_iff (x : R) : algebraMap R (TensorAlgebra R M) x = 1 ↔ x = 1 :=
  map_eq_one_iff (algebraMap _ _) (algebraMap_leftInverse _).Injective
#align tensor_algebra.algebra_map_eq_one_iff TensorAlgebra.algebraMap_eq_one_iff

variable {M}

/-- The canonical map from `tensor_algebra R M` into `triv_sq_zero_ext R M` that sends
`tensor_algebra.ι` to `triv_sq_zero_ext.inr`. -/
def toTrivSqZeroExt [Module Rᵐᵒᵖ M] [IsCentralScalar R M] :
    TensorAlgebra R M →ₐ[R] TrivSqZeroExt R M :=
  lift R (TrivSqZeroExt.inrHom R M)
#align tensor_algebra.to_triv_sq_zero_ext TensorAlgebra.toTrivSqZeroExt

@[simp]
theorem toTrivSqZeroExt_ι (x : M) [Module Rᵐᵒᵖ M] [IsCentralScalar R M] :
    toTrivSqZeroExt (ι R x) = TrivSqZeroExt.inr x :=
  lift_ι_apply _ _
#align tensor_algebra.to_triv_sq_zero_ext_ι TensorAlgebra.toTrivSqZeroExt_ι

/-- The left-inverse of `ι`.

As an implementation detail, we implement this using `triv_sq_zero_ext` which has a suitable
algebra structure. -/
def ιInv : TensorAlgebra R M →ₗ[R] M :=
  by
  letI : Module Rᵐᵒᵖ M := Module.compHom _ ((RingHom.id R).fromOpposite mul_comm)
  haveI : IsCentralScalar R M := ⟨fun r m => rfl⟩
  exact (TrivSqZeroExt.sndHom R M).comp to_triv_sq_zero_ext.to_linear_map
#align tensor_algebra.ι_inv TensorAlgebra.ιInv

theorem ι_leftInverse : Function.LeftInverse ιInv (ι R : M → TensorAlgebra R M) := fun x => by
  simp [ι_inv]
#align tensor_algebra.ι_left_inverse TensorAlgebra.ι_leftInverse

variable (R)

@[simp]
theorem ι_inj (x y : M) : ι R x = ι R y ↔ x = y :=
  ι_leftInverse.Injective.eq_iff
#align tensor_algebra.ι_inj TensorAlgebra.ι_inj

@[simp]
theorem ι_eq_zero_iff (x : M) : ι R x = 0 ↔ x = 0 := by rw [← ι_inj R x 0, LinearMap.map_zero]
#align tensor_algebra.ι_eq_zero_iff TensorAlgebra.ι_eq_zero_iff

variable {R}

@[simp]
theorem ι_eq_algebraMap_iff (x : M) (r : R) : ι R x = algebraMap R _ r ↔ x = 0 ∧ r = 0 :=
  by
  refine' ⟨fun h => _, _⟩
  · letI : Module Rᵐᵒᵖ M := Module.compHom _ ((RingHom.id R).fromOpposite mul_comm)
    haveI : IsCentralScalar R M := ⟨fun r m => rfl⟩
    have hf0 : to_triv_sq_zero_ext (ι R x) = (0, x) := lift_ι_apply _ _
    rw [h, AlgHom.commutes] at hf0
    have : r = 0 ∧ 0 = x := Prod.ext_iff.1 hf0
    exact this.symm.imp_left Eq.symm
  · rintro ⟨rfl, rfl⟩
    rw [LinearMap.map_zero, RingHom.map_zero]
#align tensor_algebra.ι_eq_algebra_map_iff TensorAlgebra.ι_eq_algebraMap_iff

@[simp]
theorem ι_ne_one [Nontrivial R] (x : M) : ι R x ≠ 1 :=
  by
  rw [← (algebraMap R (TensorAlgebra R M)).map_one, Ne.def, ι_eq_algebra_map_iff]
  exact one_ne_zero ∘ And.right
#align tensor_algebra.ι_ne_one TensorAlgebra.ι_ne_one

/-- The generators of the tensor algebra are disjoint from its scalars. -/
theorem ι_range_disjoint_one :
    Disjoint (LinearMap.range (ι R : M →ₗ[R] TensorAlgebra R M))
      (1 : Submodule R (TensorAlgebra R M)) :=
  by
  rw [Submodule.disjoint_def]
  rintro _ ⟨x, hx⟩ ⟨r, rfl : algebraMap _ _ _ = _⟩
  rw [ι_eq_algebra_map_iff x] at hx
  rw [hx.2, RingHom.map_zero]
#align tensor_algebra.ι_range_disjoint_one TensorAlgebra.ι_range_disjoint_one

variable (R M)

/-- Construct a product of `n` elements of the module within the tensor algebra.

See also `pi_tensor_product.tprod`. -/
def tprod (n : ℕ) : MultilinearMap R (fun i : Fin n => M) (TensorAlgebra R M) :=
  (MultilinearMap.mkPiAlgebraFin R n (TensorAlgebra R M)).compLinearMap fun _ => ι R
#align tensor_algebra.tprod TensorAlgebra.tprod

@[simp]
theorem tprod_apply {n : ℕ} (x : Fin n → M) : tprod R M n x = (List.ofFn fun i => ι R (x i)).Prod :=
  rfl
#align tensor_algebra.tprod_apply TensorAlgebra.tprod_apply

variable {R M}

end TensorAlgebra

namespace FreeAlgebra

variable {R M}

/-- The canonical image of the `free_algebra` in the `tensor_algebra`, which maps
`free_algebra.ι R x` to `tensor_algebra.ι R x`. -/
def toTensor : FreeAlgebra R M →ₐ[R] TensorAlgebra R M :=
  FreeAlgebra.lift R (TensorAlgebra.ι R)
#align free_algebra.to_tensor FreeAlgebra.toTensor

@[simp]
theorem toTensor_ι (m : M) : (FreeAlgebra.ι R m).toTensor = TensorAlgebra.ι R m := by
  simp [to_tensor]
#align free_algebra.to_tensor_ι FreeAlgebra.toTensor_ι

end FreeAlgebra


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.limits.shapes.images
import Mathlib.category_theory.limits.shapes.kernels
import Mathlib.PostPort

universes u v

namespace Mathlib

/-!
# The morphism from `image f` to `kernel g` when `f ≫ g = 0`

We define the map, as the lift of `image.ι f` to `kernel g`,
and check some basic properties:

* this map is a monomorphism
* given `A --0--> B --g--> C`, where `[mono g]`, this map is an epimorphism
* given `A --f--> B --0--> C`, where `[epi f]`, this map is an epimorphism

In later files, we define the homology of complex as the cokernel of this map,
and say a complex is exact at a point if this map is an epimorphism.
-/

namespace category_theory

/-!
At this point we assume that we have all images, and all equalizers.
We need to assume all equalizers, not just kernels, so that
`factor_thru_image` is an epimorphism.
-/

/--
The morphism from `image f` to `kernel g` when `f ≫ g = 0`.
-/
def image_to_kernel_map {V : Type u} [category V] [limits.has_zero_morphisms V] [limits.has_images V] [limits.has_equalizers V] {A : V} {B : V} {C : V} (f : A ⟶ B) (g : B ⟶ C) (w : f ≫ g = 0) : limits.image f ⟶ limits.kernel g :=
  limits.kernel.lift g (limits.image.ι f) sorry

@[simp] theorem image_to_kernel_map_zero_left {V : Type u} [category V] [limits.has_zero_morphisms V] [limits.has_images V] [limits.has_equalizers V] {A : V} {B : V} {C : V} (g : B ⟶ C) [limits.has_zero_object V] {w : 0 ≫ g = 0} : image_to_kernel_map 0 g w = 0 := sorry

theorem image_to_kernel_map_zero_right {V : Type u} [category V] [limits.has_zero_morphisms V] [limits.has_images V] [limits.has_equalizers V] {A : V} {B : V} {C : V} (f : A ⟶ B) {w : f ≫ 0 = 0} : image_to_kernel_map f 0 w = limits.image.ι f ≫ inv (limits.kernel.ι 0) := sorry

theorem image_to_kernel_map_comp_right {V : Type u} [category V] [limits.has_zero_morphisms V] [limits.has_images V] [limits.has_equalizers V] {A : V} {B : V} {C : V} (f : A ⟶ B) (g : B ⟶ C) {D : V} (h : C ⟶ D) (w : f ≫ g = 0) : image_to_kernel_map f (g ≫ h)
    (eq.mpr
      (id
        (Eq.trans
          ((fun (a a_1 : A ⟶ D) (e_1 : a = a_1) (ᾰ ᾰ_1 : A ⟶ D) (e_2 : ᾰ = ᾰ_1) => congr (congr_arg Eq e_1) e_2)
            (f ≫ g ≫ h) 0 (Eq.trans (reassoc_of w D h) limits.zero_comp) 0 0 (Eq.refl 0))
          (propext (eq_self_iff_true 0))))
      trivial) =
  image_to_kernel_map f g w ≫
    limits.kernel.lift (g ≫ h) (limits.kernel.ι g)
      (eq.mpr
        (id
          (Eq.trans
            ((fun (a a_1 : limits.kernel g ⟶ D) (e_1 : a = a_1) (ᾰ ᾰ_1 : limits.kernel g ⟶ D) (e_2 : ᾰ = ᾰ_1) =>
                congr (congr_arg Eq e_1) e_2)
              (limits.kernel.ι g ≫ g ≫ h) 0 (Eq.trans (limits.kernel.condition_assoc g h) limits.zero_comp) 0 0
              (Eq.refl 0))
            (propext (eq_self_iff_true 0))))
        trivial) := sorry

theorem image_to_kernel_map_comp_left {V : Type u} [category V] [limits.has_zero_morphisms V] [limits.has_images V] [limits.has_equalizers V] {A : V} {B : V} {C : V} (f : A ⟶ B) (g : B ⟶ C) {Z : V} (h : Z ⟶ A) (w : f ≫ g = 0) : image_to_kernel_map (h ≫ f) g
    (eq.mpr
      (id
        (Eq.trans
          ((fun (a a_1 : Z ⟶ C) (e_1 : a = a_1) (ᾰ ᾰ_1 : Z ⟶ C) (e_2 : ᾰ = ᾰ_1) => congr (congr_arg Eq e_1) e_2)
            ((h ≫ f) ≫ g) 0
            (Eq.trans
              (Eq.trans (category.assoc h f g)
                ((fun (ᾰ ᾰ_1 : Z ⟶ A) (e_1 : ᾰ = ᾰ_1) (ᾰ_2 ᾰ_3 : A ⟶ C) (e_2 : ᾰ_2 = ᾰ_3) =>
                    congr (congr_arg category_struct.comp e_1) e_2)
                  h h (Eq.refl h) (f ≫ g) 0 w))
              limits.comp_zero)
            0 0 (Eq.refl 0))
          (propext (eq_self_iff_true 0))))
      trivial) =
  limits.image.pre_comp h f ≫ image_to_kernel_map f g w := sorry

@[simp] theorem image_to_kernel_map_comp_iso {V : Type u} [category V] [limits.has_zero_morphisms V] [limits.has_images V] [limits.has_equalizers V] {A : V} {B : V} {C : V} (f : A ⟶ B) (g : B ⟶ C) {D : V} (h : C ⟶ D) [is_iso h] (w : f ≫ g ≫ h = 0) : image_to_kernel_map f (g ≫ h) w =
  image_to_kernel_map f g
      (iff.mp (cancel_mono h)
        (eq.mpr
          (id
            ((fun (a a_1 : A ⟶ D) (e_1 : a = a_1) (ᾰ ᾰ_1 : A ⟶ D) (e_2 : ᾰ = ᾰ_1) => congr (congr_arg Eq e_1) e_2)
              ((f ≫ g) ≫ h) (f ≫ g ≫ h) (category.assoc f g h) (0 ≫ h) 0 limits.zero_comp))
          (eq.mp (Eq.refl (f ≫ g ≫ h = 0)) w))) ≫
    iso.inv (limits.kernel_comp_is_iso g h) := sorry

@[simp] theorem image_to_kernel_map_iso_comp {V : Type u} [category V] [limits.has_zero_morphisms V] [limits.has_images V] [limits.has_equalizers V] {A : V} {B : V} {C : V} (f : A ⟶ B) (g : B ⟶ C) {Z : V} (h : Z ⟶ A) [is_iso h] (w : (h ≫ f) ≫ g = 0) : image_to_kernel_map (h ≫ f) g w =
  limits.image.pre_comp h f ≫
    image_to_kernel_map f g
      (iff.mp (cancel_epi h)
        (eq.mpr
          (id
            ((fun (a a_1 : Z ⟶ C) (e_1 : a = a_1) (ᾰ ᾰ_1 : Z ⟶ C) (e_2 : ᾰ = ᾰ_1) => congr (congr_arg Eq e_1) e_2)
              (h ≫ f ≫ g) (h ≫ f ≫ g) (Eq.refl (h ≫ f ≫ g)) (h ≫ 0) 0 limits.comp_zero))
          (eq.mp
            ((fun (a a_1 : Z ⟶ C) (e_1 : a = a_1) (ᾰ ᾰ_1 : Z ⟶ C) (e_2 : ᾰ = ᾰ_1) => congr (congr_arg Eq e_1) e_2)
              ((h ≫ f) ≫ g) (h ≫ f ≫ g) (category.assoc h f g) 0 0 (Eq.refl 0))
            w))) := sorry

@[simp] theorem image_to_kernel_map_comp_hom_inv_comp {V : Type u} [category V] [limits.has_zero_morphisms V] [limits.has_images V] [limits.has_equalizers V] {A : V} {B : V} {C : V} (f : A ⟶ B) (g : B ⟶ C) {Z : V} {i : B ≅ Z} (w : (f ≫ iso.hom i) ≫ iso.inv i ≫ g = 0) : image_to_kernel_map (f ≫ iso.hom i) (iso.inv i ≫ g) w =
  iso.inv (limits.image.post_comp_is_iso f (iso.hom i)) ≫
    image_to_kernel_map f g
        (eq.mpr (id (Eq.refl (f ≫ g = 0)))
          (eq.mp
            ((fun (a a_1 : A ⟶ C) (e_1 : a = a_1) (ᾰ ᾰ_1 : A ⟶ C) (e_2 : ᾰ = ᾰ_1) => congr (congr_arg Eq e_1) e_2)
              ((f ≫ iso.hom i) ≫ iso.inv i ≫ g) (f ≫ g)
              (Eq.trans (category.assoc f (iso.hom i) (iso.inv i ≫ g))
                ((fun (ᾰ ᾰ_1 : A ⟶ B) (e_1 : ᾰ = ᾰ_1) (ᾰ_2 ᾰ_3 : B ⟶ C) (e_2 : ᾰ_2 = ᾰ_3) =>
                    congr (congr_arg category_struct.comp e_1) e_2)
                  f f (Eq.refl f) (iso.hom i ≫ iso.inv i ≫ g) g (iso.hom_inv_id_assoc i g)))
              0 0 (Eq.refl 0))
            w)) ≫
      iso.inv (limits.kernel_is_iso_comp (iso.inv i) g) := sorry

/--
`image_to_kernel_map` for `A --0--> B --g--> C`, where `[mono g]` is an epi
(i.e. the sequence is exact at `B`).
-/
theorem image_to_kernel_map_epi_of_zero_of_mono {V : Type u} [category V] [limits.has_zero_morphisms V] [limits.has_images V] [limits.has_equalizers V] {A : V} {B : V} {C : V} (g : B ⟶ C) [mono g] [limits.has_zero_object V] : epi
  (image_to_kernel_map 0 g
    (eq.mpr
      (id
        (Eq.trans
          ((fun (a a_1 : A ⟶ C) (e_1 : a = a_1) (ᾰ ᾰ_1 : A ⟶ C) (e_2 : ᾰ = ᾰ_1) => congr (congr_arg Eq e_1) e_2) (0 ≫ g)
            0 limits.zero_comp 0 0 (Eq.refl 0))
          (propext (eq_self_iff_true 0))))
      trivial)) := sorry

/--
`image_to_kernel_map` for `A --f--> B --0--> C`, where `[epi g]` is an epi
(i.e. the sequence is exact at `B`).
-/
theorem image_to_kernel_map_epi_of_epi_of_zero {V : Type u} [category V] [limits.has_zero_morphisms V] [limits.has_images V] [limits.has_equalizers V] {A : V} {B : V} {C : V} (f : A ⟶ B) [epi f] : epi
  (image_to_kernel_map f 0
    (eq.mpr
      (id
        (Eq.trans
          ((fun (a a_1 : A ⟶ C) (e_1 : a = a_1) (ᾰ ᾰ_1 : A ⟶ C) (e_2 : ᾰ = ᾰ_1) => congr (congr_arg Eq e_1) e_2) (f ≫ 0)
            0 limits.comp_zero 0 0 (Eq.refl 0))
          (propext (eq_self_iff_true 0))))
      trivial)) := sorry


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.pi.basic
import category_theory.limits.has_limits

/-!
# Limits in the category of indexed families of objects.

Given a functor `F : J ⥤ Π i, C i` into a category of indexed families,
1. we can assemble a collection of cones over `F ⋙ pi.eval C i` into a cone over `F`
2. if all those cones are limit cones, the assembled cone is a limit cone, and
3. if we have limits for each of `F ⋙ pi.eval C i`, we can produce a
   `has_limit F` instance
-/

open category_theory
open category_theory.limits

namespace category_theory.pi

universes v₁ v₂ u₁ u₂

variables {I : Type v₁} {C : I → Type u₁} [Π i, category.{v₁} (C i)]
variables {J : Type v₁} [small_category J]
variables {F : J ⥤ Π i, C i}

/--
A cone over `F : J ⥤ Π i, C i` has as its components cones over each of the `F ⋙ pi.eval C i`.
-/
def cone_comp_eval (c : cone F) (i : I) : cone (F ⋙ pi.eval C i) :=
{ X := c.X i,
  π :=
  { app := λ j, c.π.app j i,
    naturality' := λ j j' f, congr_fun (c.π.naturality f) i, } }

/--
A cocone over `F : J ⥤ Π i, C i` has as its components cocones over each of the `F ⋙ pi.eval C i`.
-/
def cocone_comp_eval (c : cocone F) (i : I) : cocone (F ⋙ pi.eval C i) :=
{ X := c.X i,
  ι :=
  { app := λ j, c.ι.app j i,
    naturality' := λ j j' f, congr_fun (c.ι.naturality f) i, } }

/--
Given a family of cones over the `F ⋙ pi.eval C i`, we can assemble these together as a `cone F`.
-/
def cone_of_cone_comp_eval (c : Π i, cone (F ⋙ pi.eval C i)) : cone F :=
{ X := λ i, (c i).X,
  π :=
  { app := λ j i, (c i).π.app j,
    naturality' := λ j j' f, by { ext i, exact (c i).π.naturality f, } } }

/--
Given a family of cocones over the `F ⋙ pi.eval C i`,
we can assemble these together as a `cocone F`.
-/
def cocone_of_cocone_comp_eval (c : Π i, cocone (F ⋙ pi.eval C i)) : cocone F :=
{ X := λ i, (c i).X,
  ι :=
  { app := λ j i, (c i).ι.app j,
    naturality' := λ j j' f, by { ext i, exact (c i).ι.naturality f, } } }

/--
Given a family of limit cones over the `F ⋙ pi.eval C i`,
assembling them together as a `cone F` produces a limit cone.
-/
def cone_of_cone_eval_is_limit {c : Π i, cone (F ⋙ pi.eval C i)} (P : Π i, is_limit (c i)) :
  is_limit (cone_of_cone_comp_eval c) :=
{ lift := λ s i, (P i).lift (cone_comp_eval s i),
  fac' := λ s j,
  begin
    ext i,
    exact (P i).fac (cone_comp_eval s i) j,
  end,
  uniq' := λ s m w,
  begin
    ext i,
    exact (P i).uniq (cone_comp_eval s i) (m i) (λ j, congr_fun (w j) i)
  end }

/--
Given a family of colimit cocones over the `F ⋙ pi.eval C i`,
assembling them together as a `cocone F` produces a colimit cocone.
-/
def cocone_of_cocone_eval_is_colimit
  {c : Π i, cocone (F ⋙ pi.eval C i)} (P : Π i, is_colimit (c i)) :
  is_colimit (cocone_of_cocone_comp_eval c) :=
{ desc := λ s i, (P i).desc (cocone_comp_eval s i),
  fac' := λ s j,
  begin
    ext i,
    exact (P i).fac (cocone_comp_eval s i) j,
  end,
  uniq' := λ s m w,
  begin
    ext i,
    exact (P i).uniq (cocone_comp_eval s i) (m i) (λ j, congr_fun (w j) i)
  end }

section

variables [∀ i, has_limit (F ⋙ pi.eval C i)]

/--
If we have a functor `F : J ⥤ Π i, C i` into a category of indexed families,
and we have limits for each of the `F ⋙ pi.eval C i`,
then `F` has a limit.
-/
lemma has_limit_of_has_limit_comp_eval : has_limit F :=
has_limit.mk
{ cone := cone_of_cone_comp_eval (λ i, limit.cone _),
  is_limit := cone_of_cone_eval_is_limit (λ i, limit.is_limit _), }

end

section

variables [∀ i, has_colimit (F ⋙ pi.eval C i)]

/--
If we have a functor `F : J ⥤ Π i, C i` into a category of indexed families,
and colimits exist for each of the `F ⋙ pi.eval C i`,
there is a colimit for `F`.
-/
lemma has_colimit_of_has_colimit_comp_eval : has_colimit F :=
has_colimit.mk
{ cocone := cocone_of_cocone_comp_eval (λ i, colimit.cocone _),
  is_colimit := cocone_of_cocone_eval_is_colimit (λ i, colimit.is_colimit _), }

end

/-!
As an example, we can use this to construct particular shapes of limits
in a category of indexed families.

With the addition of
`import category_theory.limits.shapes.types`
we can use:
```
local attribute [instance] has_limit_of_has_limit_comp_eval
example : has_binary_products (I → Type v₁) := ⟨by apply_instance⟩
```
-/

end category_theory.pi


import unitb.models.nondet

namespace decomposition

open nondet unitb function

section

parameter α : Type

@[reducible]
private def pred := α → Prop

structure program : Type 2 :=
  (asm : α → α → Prop)
  (mch : nondet.program α)

parameter {α}

structure compatible {t : Type} (hasm : α → α → Prop) (m : t → program) : Prop :=
  (step : ∀ i j, i ≠ j → ∀ s s', is_step (m j).mch s s' → (m i).asm s s')
  (asm : ∀ i, ∀ s s', hasm s s' → (m i).asm s s')

noncomputable def compose {t : Type} (m : t → program) {s₀ : α}
  (hasm : α → α → Prop)
  (h₀ : ∀ i, (m i).mch.first s₀)
  (h : compatible hasm m)
  [scheduling.sched t]
  [∀ i, scheduling.sched (m i).mch.lbl]
: program :=
{ mch :=
    { lbl := Σ i, (m i).mch.lbl
    , lbl_is_sched := by apply_instance
    , first := λ s, ∀ i, (m i).mch.first s
    , first_fis := ⟨_,h₀⟩
    , event' := λ i, (m i.1).mch.event' i.2 }
, asm := hasm }

def step (p : program) (s s' : α) : Prop :=
nondet.is_step p.mch s s' ∨ p.asm s s'

instance : system program :=
{ σ := α
, init := nondet.program.init ∘ program.mch
, step := step
, transient := nondet.program.transient ∘ program.mch
, transient_false := λ s, @system.transient_false _ _ s.mch
, transient_antimono := λ s, @system.transient_antimono _ _ s.mch }

structure program.ex (s : program) (τ : stream α) : Prop :=
    (init : s.mch.first (τ 0))
    (safety : unitb.saf_ex s τ)
    (liveness : ∀ e, fair' s.mch e τ)

lemma ex_of_ex_mch (s : program) (τ : stream α)
  (h : s.mch.ex τ)
: s.ex τ :=
begin
  apply decomposition.program.ex.mk,
  { apply h.init },
  { unfold saf_ex,
    refine temporal.henceforth_entails_henceforth _ _ h.safety,
    apply temporal.action_entails_action,
    intros s s',
    unfold unitb.step has_safety.step is_step step,
    apply or.intro_left },
  { apply h.liveness },
end

instance : system_sem program :=
{ (_ : system program) with
  ex := λ p, program.ex p
, init_sem  := λ s p τ Hτ H₀, by { apply H₀, apply Hτ.init }
, inhabited := λ s, exists_imp_exists (ex_of_ex_mch s) (system_sem.inhabited s.mch)
, safety    := λ s p, decomposition.program.ex.safety
, transient_sem := λ s p q τ Hτ T, by apply transient.semantics' _ Hτ.liveness T }

end

end decomposition


import linear_algebra.dimension
import analysis.topology.topological_structures
import algebra.pi_instances
import field_theory.subfield
import ring_theory.ideal_operations
import .topological_group
import .algebra_tensor

local attribute [instance] classical.prop_decidable

universes u v

set_option eqn_compiler.zeta true

class is_alg_closed_field (F : Type u) [field F] : Prop :=
(alg_closed : ∀ f : polynomial F, f.degree > 1 → ∃ x, f.eval x = 0)

variables {F : Type u} [discrete_field F]

class is_integral {K : Type v} [comm_ring K] (i : algebra F K) : Prop :=
(integral : ∀ x : K, ∃ f : polynomial F, f.monic ∧ polynomial.aeval F i x f = 0)

instance discrete_field_of_subalgebra_of_integral {K : Type v} [discrete_field K] (i : algebra F K)
  [is_integral i] (S : subalgebra i) : discrete_field S := sorry

class is_algebraic_closure {K : Type v} [discrete_field K] (i : algebra F K) extends is_alg_closed_field K, is_integral i : Prop

structure Gal {K : Type v} [comm_ring K] (i : algebra F K) extends K ≃ K :=
(hom : is_ring_hom to_fun)
(fix : ∀ x : F, to_fun (i x) = i x)
attribute [instance] Gal.hom

instance Gal.hom' {K : Type v} [comm_ring K] (i : algebra F K) (f : Gal i) : is_ring_hom f.to_equiv := f.hom

theorem Gal.ext {K : Type v} [comm_ring K] (i : algebra F K) : ∀ f g : Gal i, (∀ x, f.to_equiv x = g.to_equiv x) → f = g
| ⟨_, _, _⟩ ⟨_, _, _⟩ H := by rw Gal.mk.inj_eq; from equiv.ext _ _ H

def is_reduced_comm_ring (R : Type u) [comm_ring R] : Prop :=
(⊥ : ideal R).radical = ⊥

def algebraic_closure_field (F : Type u) [discrete_field F] : Type u := sorry
instance (F : Type u) [discrete_field F] : discrete_field (algebraic_closure_field F) := sorry
def algebraic_closure (F : Type u) [discrete_field F] : algebra F (algebraic_closure_field F) := sorry
instance (F : Type u) [discrete_field F] : is_algebraic_closure (algebraic_closure F) := sorry

-- http://www.math.uconn.edu/~kconrad/blurbs/galoistheory/separable2.pdf
class is_separable (S : subalgebra $ algebraic_closure F) : Prop :=
(separable : is_reduced_comm_ring (S.algebra.mod ⊗ (algebraic_closure F).mod))

variables F
structure finite_Galois_extension : Type u :=
(S : subalgebra $ algebraic_closure F)
(finite : vector_space.dim F S.algebra.mod < cardinal.omega)
(separable : is_separable S)
(proj : Gal (algebraic_closure F) → Gal S.algebra)
(proj_commutes : ∀ f : Gal (algebraic_closure F), ∀ x : S, ((proj f).to_equiv x).1 = f.to_equiv x.1)
attribute [instance] finite_Galois_extension.separable

variables {F}
instance Gal.group {K : Type v} [comm_ring K] (i : algebra F K) : group (Gal i) :=
{ mul := λ f g, ⟨f.to_equiv.trans g.to_equiv,
    @@is_ring_hom.comp _ _ _ f.hom _ _ g.hom,
    λ _, by simp [equiv.trans, f.fix, g.fix]⟩,
  mul_assoc := λ _ _ _, Gal.ext _ _ _ $ λ _, by simp,
  one := ⟨equiv.refl _, is_ring_hom.id, λ _, rfl⟩,
  one_mul := λ _, Gal.ext _ _ _ $ λ _, rfl,
  mul_one := λ _, Gal.ext _ _ _ $ λ _, rfl,
  inv := λ f, ⟨f.to_equiv.symm,
      ⟨show f.to_equiv.symm 1 = 1,
        by rw [equiv.symm_apply_eq, is_ring_hom.map_one f.to_equiv],
      λ x y, show f.to_equiv.symm (x * y) = f.to_equiv.symm x * f.to_equiv.symm y,
        by rw [equiv.symm_apply_eq, is_ring_hom.map_mul f.to_equiv];
          rw [equiv.apply_inverse_apply, equiv.apply_inverse_apply],
      λ x y, show f.to_equiv.symm (x + y) = f.to_equiv.symm x + f.to_equiv.symm y,
        by rw [equiv.symm_apply_eq, is_ring_hom.map_add f.to_equiv];
          rw [equiv.apply_inverse_apply, equiv.apply_inverse_apply]⟩,
    λ x, show f.to_equiv.symm (i x) = i x,
      by rw equiv.symm_apply_eq; from (f.fix x).symm⟩,
  mul_left_inv := λ _, Gal.ext _ _ _ $ λ _,
    equiv.apply_inverse_apply _ _ }

instance Gal.finite_Galois_extension.topological_space (E : finite_Galois_extension F) :
  topological_space (Gal E.S.algebra) := ⊤

instance Gal.finite_Galois_extension.topological_group (E : finite_Galois_extension F) :
  topological_group (Gal E.S.algebra) :=
{ continuous_mul := λ x1 h1, by apply is_open_prod_iff.2; intros x y H;
    refine ⟨{x}, {y}, trivial, trivial, _, _, _⟩; simp; simpa using H,
  continuous_inv := continuous_top }

variables (F)
instance Gal_algebraic_closure.topological_space : topological_space (Gal $ algebraic_closure F) :=
@topological_space.induced _
  (Π E : finite_Galois_extension F, Gal E.S.algebra)
  (λ f E, E.proj f)
  (@Pi.topological_space _ _ (λ _, ⊤))

instance Gal.topological_group : topological_group (Gal $ algebraic_closure F) :=
@topological_group.induced _ _ _ _ _
  (@Pi.topological_group (finite_Galois_extension F) (λ E, Gal E.S.algebra) _ _ _)
  (λ f S, S.proj f)
  (by constructor; intros f g; funext S; apply Gal.ext; intro x;
    apply subtype.eq; have := S.proj_commutes; dsimp at this ⊢;
    change ((S.proj (f * g)).to_equiv x).1 = ((S.proj f * S.proj g).to_equiv x).1;
    dsimp [(*), semigroup.mul, monoid.mul, group.mul]; simp [this])

variables {F}
def subalgebra.Gal {K : Type v} [comm_ring K] {i : algebra F K} (S : subalgebra i) : set (Gal i) :=
{ f | ∀ x ∈ S, f.to_equiv x = x }

instance Gal.intermediate.subgroup {K : Type v} [comm_ring K] {i : algebra F K} (S : subalgebra i) :
  is_subgroup S.Gal :=
{ mul_mem := λ f g H1 H2 x hx,
    show f.to_equiv.trans g.to_equiv x = x,
    by simp [H1 x hx, H2 x hx],
  one_mem := λ x hx, rfl,
  inv_mem := λ f H1 x hx,
    show f.to_equiv.symm x = x,
    by rw equiv.symm_apply_eq; from (H1 x hx).symm }

instance Gal.normal (E : finite_Galois_extension F) :
  normal_subgroup E.S.Gal :=
{ normal := λ f hf g x hx,
    show g.to_equiv.trans (f.to_equiv.trans g.to_equiv.symm) x = x,
    from have _ := E.proj_commutes g ⟨x, hx⟩,
    by simp at this ⊢; rw [← this, hf, this];
      [simp, from (((E.proj g).to_equiv) ⟨x, hx⟩).2] }

instance Gal.intermediate.topological_group (E : finite_Galois_extension F) :
  topological_group E.S.Gal :=
topological_group.induced _ _ subtype.val


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kevin Buzzard, Scott Morrison, Jakob von Raumer
-/
import category_theory.monoidal.braided
import category_theory.closed.monoidal
import algebra.category.Module.basic
import linear_algebra.tensor_product
import category_theory.linear.yoneda
import category_theory.monoidal.preadditive

/-!
# The symmetric monoidal category structure on R-modules

Mostly this uses existing machinery in `linear_algebra.tensor_product`.
We just need to provide a few small missing pieces to build the
`monoidal_category` instance and then the `symmetric_category` instance.

Note the universe level of the modules must be at least the universe level of the ring,
so that we have a monoidal unit.
For now, we simplify by insisting both universe levels are the same.

We then construct the monoidal closed structure on `Module R`.

If you're happy using the bundled `Module R`, it may be possible to mostly
use this as an interface and not need to interact much with the implementation details.
-/

universes u

open category_theory

namespace Module

variables {R : Type u} [comm_ring R]

namespace monoidal_category
-- The definitions inside this namespace are essentially private.
-- After we build the `monoidal_category (Module R)` instance,
-- you should use that API.

open_locale tensor_product
local attribute [ext] tensor_product.ext

/-- (implementation) tensor product of R-modules -/
def tensor_obj (M N : Module R) : Module R := Module.of R (M ⊗[R] N)
/-- (implementation) tensor product of morphisms R-modules -/
def tensor_hom {M N M' N' : Module R} (f : M ⟶ N) (g : M' ⟶ N') :
  tensor_obj M M' ⟶ tensor_obj N N' :=
tensor_product.map f g

lemma tensor_id (M N : Module R) : tensor_hom (𝟙 M) (𝟙 N) = 𝟙 (Module.of R (↥M ⊗ ↥N)) :=
by tidy

lemma tensor_comp {X₁ Y₁ Z₁ X₂ Y₂ Z₂ : Module R}
  (f₁ : X₁ ⟶ Y₁) (f₂ : X₂ ⟶ Y₂) (g₁ : Y₁ ⟶ Z₁) (g₂ : Y₂ ⟶ Z₂) :
    tensor_hom (f₁ ≫ g₁) (f₂ ≫ g₂) = tensor_hom f₁ f₂ ≫ tensor_hom g₁ g₂ :=
by tidy

/-- (implementation) the associator for R-modules -/
def associator (M N K : Module R) : tensor_obj (tensor_obj M N) K ≅ tensor_obj M (tensor_obj N K) :=
linear_equiv.to_Module_iso (tensor_product.assoc R M N K)

section

/-! The `associator_naturality` and `pentagon` lemmas below are very slow to elaborate.

We give them some help by expressing the lemmas first non-categorically, then using
`convert _aux using 1` to have the elaborator work as little as possible. -/

open tensor_product (assoc map)

private lemma associator_naturality_aux
  {X₁ X₂ X₃ : Type*}
  [add_comm_monoid X₁] [add_comm_monoid X₂] [add_comm_monoid X₃]
  [module R X₁] [module R X₂] [module R X₃]
  {Y₁ Y₂ Y₃ : Type*}
  [add_comm_monoid Y₁] [add_comm_monoid Y₂] [add_comm_monoid Y₃]
  [module R Y₁] [module R Y₂] [module R Y₃]
  (f₁ : X₁ →ₗ[R] Y₁) (f₂ : X₂ →ₗ[R] Y₂) (f₃ : X₃ →ₗ[R] Y₃) :
  (↑(assoc R Y₁ Y₂ Y₃) ∘ₗ (map (map f₁ f₂) f₃)) = ((map f₁ (map f₂ f₃)) ∘ₗ ↑(assoc R X₁ X₂ X₃)) :=
begin
  apply tensor_product.ext_threefold,
  intros x y z,
  refl
end

variables (R)

private lemma pentagon_aux
  (W X Y Z : Type*)
  [add_comm_monoid W] [add_comm_monoid X] [add_comm_monoid Y] [add_comm_monoid Z]
  [module R W] [module R X] [module R Y] [module R Z] :
  ((map (1 : W →ₗ[R] W) (assoc R X Y Z).to_linear_map).comp (assoc R W (X ⊗[R] Y) Z).to_linear_map)
    .comp (map ↑(assoc R W X Y) (1 : Z →ₗ[R] Z)) =
  (assoc R W X (Y ⊗[R] Z)).to_linear_map.comp (assoc R (W ⊗[R] X) Y Z).to_linear_map :=
begin
  apply tensor_product.ext_fourfold,
  intros w x y z,
  refl
end

end

lemma associator_naturality {X₁ X₂ X₃ Y₁ Y₂ Y₃ : Module R}
  (f₁ : X₁ ⟶ Y₁) (f₂ : X₂ ⟶ Y₂) (f₃ : X₃ ⟶ Y₃) :
    tensor_hom (tensor_hom f₁ f₂) f₃ ≫ (associator Y₁ Y₂ Y₃).hom =
    (associator X₁ X₂ X₃).hom ≫ tensor_hom f₁ (tensor_hom f₂ f₃) :=
by convert associator_naturality_aux f₁ f₂ f₃ using 1

lemma pentagon (W X Y Z : Module R) :
  tensor_hom (associator W X Y).hom (𝟙 Z) ≫ (associator W (tensor_obj X Y) Z).hom
  ≫ tensor_hom (𝟙 W) (associator X Y Z).hom =
    (associator (tensor_obj W X) Y Z).hom ≫ (associator W X (tensor_obj Y Z)).hom :=
by convert pentagon_aux R W X Y Z using 1

/-- (implementation) the left unitor for R-modules -/
def left_unitor (M : Module.{u} R) : Module.of R (R ⊗[R] M) ≅ M :=
(linear_equiv.to_Module_iso (tensor_product.lid R M) : of R (R ⊗ M) ≅ of R M).trans (of_self_iso M)

/-- (implementation) the right unitor for R-modules -/
def right_unitor (M : Module.{u} R) : Module.of R (M ⊗[R] R) ≅ M :=
(linear_equiv.to_Module_iso (tensor_product.rid R M) : of R (M ⊗ R) ≅ of R M).trans (of_self_iso M)

lemma right_unitor_naturality {M N : Module R} (f : M ⟶ N) :
  tensor_hom f (𝟙 (Module.of R R)) ≫ (right_unitor N).hom = (right_unitor M).hom ≫ f :=
begin
  ext x y, simp,
  erw [tensor_product.rid_tmul, tensor_product.rid_tmul],
  rw linear_map.map_smul,
  refl,
end

lemma triangle (M N : Module.{u} R) :
  (associator M (Module.of R R) N).hom ≫ tensor_hom (𝟙 M) (left_unitor N).hom =
    tensor_hom (right_unitor M).hom (𝟙 N) :=
begin
  apply tensor_product.ext_threefold,
  intros x y z,
  change R at y,
  dsimp [tensor_hom, associator],
  erw [tensor_product.lid_tmul, tensor_product.rid_tmul],
  exact (tensor_product.smul_tmul _ _ _).symm
end

end monoidal_category

open monoidal_category

instance monoidal_category : monoidal_category (Module.{u} R) :=
{ -- data
  tensor_obj   := tensor_obj,
  tensor_hom   := @tensor_hom _ _,
  tensor_unit  := Module.of R R,
  associator   := associator,
  left_unitor  := left_unitor,
  right_unitor := right_unitor,
  -- properties
  tensor_id'               := λ M N, tensor_id M N,
  tensor_comp'             := λ M N K M' N' K' f g h, tensor_comp f g h,
  associator_naturality'   := λ M N K M' N' K' f g h, associator_naturality f g h,
  left_unitor_naturality'  := λ M N f, left_unitor_naturality f,
  right_unitor_naturality' := λ M N f, right_unitor_naturality f,
  pentagon'                := λ M N K L, pentagon M N K L,
  triangle'                := λ M N, triangle M N, }

/-- Remind ourselves that the monoidal unit, being just `R`, is still a commutative ring. -/
instance : comm_ring ((𝟙_ (Module.{u} R) : Module.{u} R) : Type u) :=
(by apply_instance : comm_ring R)

namespace monoidal_category

@[simp]
lemma hom_apply {K L M N : Module.{u} R} (f : K ⟶ L) (g : M ⟶ N) (k : K) (m : M) :
  (f ⊗ g) (k ⊗ₜ m) = f k ⊗ₜ g m := rfl

@[simp]
lemma left_unitor_hom_apply {M : Module.{u} R} (r : R) (m : M) :
  ((λ_ M).hom : 𝟙_ (Module R) ⊗ M ⟶ M) (r ⊗ₜ[R] m) = r • m :=
tensor_product.lid_tmul m r

@[simp]
lemma left_unitor_inv_apply {M : Module.{u} R} (m : M) :
  ((λ_ M).inv : M ⟶ 𝟙_ (Module.{u} R) ⊗ M) m = 1 ⊗ₜ[R] m :=
tensor_product.lid_symm_apply m

@[simp]
lemma right_unitor_hom_apply {M : Module.{u} R} (m : M) (r : R) :
  ((ρ_ M).hom : M ⊗ 𝟙_ (Module R) ⟶ M) (m ⊗ₜ r) = r • m :=
tensor_product.rid_tmul m r

@[simp]
lemma right_unitor_inv_apply {M : Module.{u} R} (m : M) :
  ((ρ_ M).inv : M ⟶ M ⊗ 𝟙_ (Module.{u} R)) m = m ⊗ₜ[R] 1 :=
tensor_product.rid_symm_apply m

@[simp]
lemma associator_hom_apply {M N K : Module.{u} R} (m : M) (n : N) (k : K) :
  ((α_ M N K).hom : (M ⊗ N) ⊗ K ⟶ M ⊗ (N ⊗ K)) ((m ⊗ₜ n) ⊗ₜ k) = (m ⊗ₜ (n ⊗ₜ k)) := rfl

@[simp]
lemma associator_inv_apply {M N K : Module.{u} R} (m : M) (n : N) (k : K) :
  ((α_ M N K).inv : M ⊗ (N ⊗ K) ⟶ (M ⊗ N) ⊗ K) (m ⊗ₜ (n ⊗ₜ k)) = ((m ⊗ₜ n) ⊗ₜ k) := rfl

end monoidal_category

/-- (implementation) the braiding for R-modules -/
def braiding (M N : Module R) : tensor_obj M N ≅ tensor_obj N M :=
linear_equiv.to_Module_iso (tensor_product.comm R M N)

@[simp] lemma braiding_naturality {X₁ X₂ Y₁ Y₂ : Module.{u} R} (f : X₁ ⟶ Y₁) (g : X₂ ⟶ Y₂) :
  (f ⊗ g) ≫ (Y₁.braiding Y₂).hom =
    (X₁.braiding X₂).hom ≫ (g ⊗ f) :=
begin
  apply tensor_product.ext',
  intros x y,
  refl
end

@[simp] lemma hexagon_forward (X Y Z : Module.{u} R) :
  (α_ X Y Z).hom ≫ (braiding X _).hom ≫ (α_ Y Z X).hom =
  ((braiding X Y).hom ⊗ 𝟙 Z) ≫ (α_ Y X Z).hom ≫ (𝟙 Y ⊗ (braiding X Z).hom) :=
begin
  apply tensor_product.ext_threefold,
  intros x y z,
  refl,
end

@[simp] lemma hexagon_reverse (X Y Z : Module.{u} R) :
  (α_ X Y Z).inv ≫ (braiding _ Z).hom ≫ (α_ Z X Y).inv =
  (𝟙 X ⊗ (Y.braiding Z).hom) ≫ (α_ X Z Y).inv ≫ ((X.braiding Z).hom ⊗ 𝟙 Y) :=
begin
  apply (cancel_epi (α_ X Y Z).hom).1,
  apply tensor_product.ext_threefold,
  intros x y z,
  refl,
end

local attribute [ext] tensor_product.ext

/-- The symmetric monoidal structure on `Module R`. -/
instance symmetric_category : symmetric_category (Module.{u} R) :=
{ braiding := braiding,
  braiding_naturality' := λ X₁ X₂ Y₁ Y₂ f g, braiding_naturality f g,
  hexagon_forward' := hexagon_forward,
  hexagon_reverse' := hexagon_reverse, }

namespace monoidal_category

@[simp] lemma braiding_hom_apply {M N : Module.{u} R} (m : M) (n : N) :
  ((β_ M N).hom : M ⊗ N ⟶ N ⊗ M) (m ⊗ₜ n) = n ⊗ₜ m := rfl

@[simp] lemma braiding_inv_apply {M N : Module.{u} R} (m : M) (n : N) :
  ((β_ M N).inv : N ⊗ M ⟶ M ⊗ N) (n ⊗ₜ m) = m ⊗ₜ n := rfl

end monoidal_category

open opposite

instance : monoidal_preadditive (Module.{u} R) :=
{ tensor_zero' := by { intros, ext, simp, },
  zero_tensor' := by { intros, ext, simp, },
  tensor_add' := by { intros, ext, simp [tensor_product.tmul_add], },
  add_tensor' := by { intros, ext, simp [tensor_product.add_tmul], }, }

/--
Auxiliary definition for the `monoidal_closed` instance on `Module R`.
(This is only a separate definition in order to speed up typechecking. )
-/
@[simps]
def monoidal_closed_hom_equiv (M N P : Module.{u} R) :
  ((monoidal_category.tensor_left M).obj N ⟶ P) ≃
    (N ⟶ ((linear_coyoneda R (Module R)).obj (op M)).obj P) :=
{ to_fun := λ f, linear_map.compr₂ (tensor_product.mk R N M) ((β_ N M).hom ≫ f),
  inv_fun := λ f, (β_ M N).hom ≫ tensor_product.lift f,
  left_inv := λ f, begin ext m n,
    simp only [tensor_product.mk_apply, tensor_product.lift.tmul, linear_map.compr₂_apply,
      function.comp_app, coe_comp, monoidal_category.braiding_hom_apply],
  end,
  right_inv := λ f, begin ext m n,
    simp only [tensor_product.mk_apply, tensor_product.lift.tmul, linear_map.compr₂_apply,
      symmetric_category.symmetry_assoc],
  end, }

instance : monoidal_closed (Module.{u} R) :=
{ closed' := λ M,
  { is_adj :=
    { right := (linear_coyoneda R (Module.{u} R)).obj (op M),
      adj := adjunction.mk_of_hom_equiv
      { hom_equiv := λ N P, monoidal_closed_hom_equiv M N P, } } } }

-- I can't seem to express the function coercion here without writing `@coe_fn`.
@[simp]
lemma monoidal_closed_curry {M N P : Module.{u} R} (f : M ⊗ N ⟶ P) (x : M) (y : N) :
  @coe_fn _ _ linear_map.has_coe_to_fun ((monoidal_closed.curry f : N →ₗ[R] (M →ₗ[R] P)) y) x =
    f (x ⊗ₜ[R] y) :=
rfl

@[simp]
lemma monoidal_closed_uncurry {M N P : Module.{u} R}
  (f : N ⟶ (M ⟶[Module.{u} R] P)) (x : M) (y : N) :
  monoidal_closed.uncurry f (x ⊗ₜ[R] y) = (@coe_fn _ _ linear_map.has_coe_to_fun (f y)) x :=
by { simp only [monoidal_closed.uncurry, ihom.adjunction, is_left_adjoint.adj], simp, }

end Module


/-
Copyright (c) 2020 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta, Adam Topaz
-/

import data.fintype.basic
import data.fin
import category_theory.concrete_category.bundled
import category_theory.concrete_category
import category_theory.full_subcategory
import category_theory.skeletal

/-!
# The category of finite types.

We define the category of finite types, denoted `Fintype` as
(bundled) types with a `fintype` instance.

We also define `Fintype.skeleton`, the standard skeleton of `Fintype` whose objects are `fin n`
for `n : ℕ`. We prove that the obvious inclusion functor `Fintype.skeleton ⥤ Fintype` is an
equivalence of categories in `Fintype.skeleton.equivalence`.
We prove that `Fintype.skeleton` is a skeleton of `Fintype` in `Fintype.is_skeleton`.
-/

open_locale classical
open category_theory

/-- The category of finite types. -/
@[derive has_coe_to_sort]
def Fintype := bundled fintype

namespace Fintype

/-- Construct a bundled `Fintype` from the underlying type and typeclass. -/
def of (X : Type*) [fintype X] : Fintype := bundled.of X
instance : inhabited Fintype := ⟨⟨pempty⟩⟩
instance {X : Fintype} : fintype X := X.2

instance : category Fintype := induced_category.category bundled.α

/-- The fully faithful embedding of `Fintype` into the category of types. -/
@[derive [full, faithful], simps]
def incl : Fintype ⥤ Type* := induced_functor _

instance : concrete_category Fintype := ⟨incl⟩

/--
The "standard" skeleton for `Fintype`. This is the full subcategory of `Fintype` spanned by objects
of the form `fin n` for `n : ℕ`. We parameterize the objects of `Fintype.skeleton` directly as `ℕ`,
as the type `fin m ≃ fin n` is nonempty if and only if `n = m`.
-/
def skeleton := ℕ

namespace skeleton

/-- Given any natural number `n`, this creates the associated object of `Fintype.skeleton`. -/
def mk : ℕ → skeleton := id

instance : inhabited skeleton := ⟨mk 0⟩

/-- Given any object of `Fintype.skeleton`, this returns the associated natural number. -/
def to_nat : skeleton → ℕ := id

instance : category skeleton :=
{ hom := λ X Y, fin X → fin Y,
  id := λ _, id,
  comp := λ _ _ _ f g, g ∘ f }

lemma is_skeletal : skeletal skeleton := λ X Y ⟨h⟩, fin.equiv_iff_eq.mp $ nonempty.intro $
{ to_fun := h.1,
  inv_fun := h.2,
  left_inv := λ _, by {change (h.hom ≫ h.inv) _ = _, simpa},
  right_inv := λ _, by {change (h.inv ≫ h.hom) _ = _, simpa} }

/-- The canonical fully faithful embedding of `Fintype.skeleton` into `Fintype`. -/
def incl : skeleton ⥤ Fintype :=
{ obj := λ X, Fintype.of (fin X),
  map := λ _ _ f, f }

instance : full incl := { preimage := λ _ _ f, f }
instance : faithful incl := {}
instance : ess_surj incl :=
{ mem_ess_image := λ X,
  let F := fintype.equiv_fin X in
  ⟨fintype.card X, ⟨⟨F.symm, F, F.self_comp_symm, F.symm_comp_self⟩⟩⟩ }

noncomputable instance : is_equivalence incl :=
equivalence.equivalence_of_fully_faithfully_ess_surj _

/-- The equivalence between `Fintype.skeleton` and `Fintype`. -/
noncomputable def equivalence : skeleton ≌ Fintype := incl.as_equivalence

@[simp] lemma incl_mk_nat_card (n : ℕ) : fintype.card (incl.obj (mk n)) = n := finset.card_fin n

end skeleton

/-- `Fintype.skeleton` is a skeleton of `Fintype`. -/
noncomputable def is_skeleton : is_skeleton_of Fintype skeleton skeleton.incl :=
{ skel := skeleton.is_skeletal,
  eqv := by apply_instance }

end Fintype


/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import tactic.core

open tactic

structure C :=
 ( w : Type )
 ( x : list w )
 ( y : Type )
 ( z : prod w y )

def test_terminal_goal_1 : C :=
 begin
    fapply C.mk, -- We don't just split here, as we want the goals in order.
    success_if_fail { tactic.terminal_goal },
    exact ℕ,
    terminal_goal,
    exact [],
    success_if_fail { terminal_goal },
    exact bool,
    terminal_goal,
    exact (0, tt)
 end

 -- verifying that terminal_goal correctly considers all propositional goals as terminal
structure terminal_goal_struct :=
(x : ℕ)
(p : x = 0)

lemma test_terminal_goal_2 : ∃ F : terminal_goal_struct, F = ⟨ 0, by refl ⟩ :=
begin
  split,
  swap,
  split,
  terminal_goal,
  swap,
  success_if_fail { terminal_goal },
  exact 0,
  refl,
  refl,
end

structure terminal_goal_struct' :=
 ( w : ℕ → Type )
 ( x : list (w 0) )

def test_terminal_goal_3 : terminal_goal_struct' :=
begin
  split,
  swap,
  success_if_fail { terminal_goal },
  intros,
  success_if_fail { terminal_goal },
  exact ℕ,
  exact []
end

def f : unit → Type := λ _, ℕ

def test_terminal_goal_4 : Σ x : unit, f x :=
begin
  split,
  terminal_goal,
  swap,
  terminal_goal,
  exact (),
  dsimp [f],
  exact 0
end

def test_subsingleton_goal_1 : 0 = 0 :=
begin
 subsingleton_goal,
 refl
end

def test_subsingleton_goal_2 : list ℕ :=
begin
 success_if_fail { subsingleton_goal },
 exact []
end


import tactic
import field_theory.finite.basic
import field_theory.tower
import field_theory.subfield
import linear_algebra.finite_dimensional

universe u

variables {F0 F1 F2 : Type u} [F0_field: field F0] [F1_field: field F1] [F2_field: field F2]
variables [F1_in_F0: algebra F0 F1] [F2_in_F1: algebra F1 F2]

/- Prove F2 is a subfield of F0-/
lemma zero_in_F0_is_0_in_F2 : F2_field.one ∈ F2_field :=
begin
  sorry,
end


import tactic

namespace vilnius

/- ### implication -/

example (P Q : Prop) : P → Q → P :=
begin
  sorry
end

/- ### not -/

example (P Q : Prop) : (P → ¬ Q) → (Q → ¬ P) :=
begin
  sorry
end

/- ### and -/

example (P Q : Prop) : P ∧ Q → Q :=
begin
  sorry
end

example (P Q : Prop) : P → Q → P ∧ Q :=
begin
  sorry,
end

example (P Q : Prop) : P ∧ Q → Q ∧ P :=
begin
  sorry
end

example (P : Prop) : P ∧ ¬ P → false :=
begin
  sorry,
end

/- ## Or -/

example (P Q : Prop) : ¬ P ∨ Q → P → Q :=
begin
  sorry,
end

example (P Q R : Prop) : P ∨ (Q ∧ R) → ¬ P → ¬ Q → false :=
begin
  sorry,
end

end vilnius