/-
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 category_theory.monad.basic
import category_theory.adjunction.basic
import category_theory.functor.epi_mono

/-!
# Eilenberg-Moore (co)algebras for a (co)monad

This file defines Eilenberg-Moore (co)algebras for a (co)monad,
and provides the category instance for them.

Further it defines the adjoint pair of free and forgetful functors, respectively
from and to the original category, as well as the adjoint pair of forgetful and
cofree functors, respectively from and to the original category.

## References
* [Riehl, *Category theory in context*, Section 5.2.4][riehl2017]
-/

namespace category_theory
open category

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

variables {C : Type u₁} [category.{v₁} C]

namespace monad

/-- An Eilenberg-Moore algebra for a monad `T`.
    cf Definition 5.2.3 in [Riehl][riehl2017]. -/
structure algebra (T : monad C) : Type (max u₁ v₁) :=
(A : C)
(a : (T : C ⥤ C).obj A ⟶ A)
(unit' : T.η.app A ≫ a = 𝟙 A . obviously)
(assoc' : T.μ.app A ≫ a = (T : C ⥤ C).map a ≫ a . obviously)

restate_axiom algebra.unit'
restate_axiom algebra.assoc'
attribute [reassoc] algebra.unit algebra.assoc

namespace algebra
variables {T : monad C}

/-- A morphism of Eilenberg–Moore algebras for the monad `T`. -/
@[ext] structure hom (A B : algebra T) :=
(f : A.A ⟶ B.A)
(h' : (T : C ⥤ C).map f ≫ B.a = A.a ≫ f . obviously)

restate_axiom hom.h'
attribute [simp, reassoc] hom.h

namespace hom

/-- The identity homomorphism for an Eilenberg–Moore algebra. -/
def id (A : algebra T) : hom A A :=
{ f := 𝟙 A.A }

instance (A : algebra T) : inhabited (hom A A) := ⟨{ f := 𝟙 _ }⟩

/-- Composition of Eilenberg–Moore algebra homomorphisms. -/
def comp {P Q R : algebra T} (f : hom P Q) (g : hom Q R) : hom P R :=
{ f := f.f ≫ g.f }

end hom

instance : category_struct (algebra T) :=
{ hom := hom,
  id := hom.id,
  comp := @hom.comp _ _ _ }

@[simp] lemma comp_eq_comp {A A' A'' : algebra T} (f : A ⟶ A') (g : A' ⟶ A'') :
  algebra.hom.comp f g = f ≫ g := rfl
@[simp] lemma id_eq_id (A : algebra T) :
  algebra.hom.id A = 𝟙 A := rfl

@[simp]

/-- The category of Eilenberg-Moore algebras for a monad.
    cf Definition 5.2.4 in [Riehl][riehl2017]. -/
instance EilenbergMoore : category (algebra T) := {}.

/--
To construct an isomorphism of algebras, it suffices to give an isomorphism of the carriers which
commutes with the structure morphisms.
-/
@[simps]
def iso_mk {A B : algebra T} (h : A.A ≅ B.A) (w : (T : C ⥤ C).map h.hom ≫ B.a = A.a ≫ h.hom) :
  A ≅ B :=
{ hom := { f := h.hom },
  inv :=
  { f := h.inv,
    h' := by { rw [h.eq_comp_inv, category.assoc, ←w, ←functor.map_comp_assoc], simp } } }

end algebra

variables (T : monad C)

/-- The forgetful functor from the Eilenberg-Moore category, forgetting the algebraic structure. -/
@[simps] def forget : algebra T ⥤ C :=
{ obj := λ A, A.A,
  map := λ A B f, f.f }

/-- The free functor from the Eilenberg-Moore category, constructing an algebra for any object. -/
@[simps] def free : C ⥤ algebra T :=
{ obj := λ X,
  { A := T.obj X,
    a := T.μ.app X,
    assoc' := (T.assoc _).symm },
  map := λ X Y f,
  { f := T.map f,
    h' := T.μ.naturality _ } }

instance [inhabited C] : inhabited (algebra T) :=
⟨(free T).obj default⟩

/-- The adjunction between the free and forgetful constructions for Eilenberg-Moore algebras for
  a monad. cf Lemma 5.2.8 of [Riehl][riehl2017]. -/
-- The other two `simps` projection lemmas can be derived from these two, so `simp_nf` complains if
-- those are added too
@[simps unit counit]
def adj : T.free ⊣ T.forget :=
adjunction.mk_of_hom_equiv
{ hom_equiv := λ X Y,
  { to_fun := λ f, T.η.app X ≫ f.f,
    inv_fun := λ f,
    { f := T.map f ≫ Y.a,
      h' := by { dsimp, simp [←Y.assoc, ←T.μ.naturality_assoc] } },
    left_inv := λ f, by { ext, dsimp, simp },
    right_inv := λ f,
    begin
      dsimp only [forget_obj, monad_to_functor_eq_coe],
      rw [←T.η.naturality_assoc, Y.unit],
      apply category.comp_id,
    end }}

/--
Given an algebra morphism whose carrier part is an isomorphism, we get an algebra isomorphism.
-/
lemma algebra_iso_of_iso {A B : algebra T} (f : A ⟶ B) [is_iso f.f] : is_iso f :=
⟨⟨{ f := inv f.f,
    h' := by { rw [is_iso.eq_comp_inv f.f, category.assoc, ← f.h], simp } }, by tidy⟩⟩

instance forget_reflects_iso : reflects_isomorphisms T.forget :=
{ reflects := λ A B, algebra_iso_of_iso T }

instance forget_faithful : faithful T.forget := {}

/-- Given an algebra morphism whose carrier part is an epimorphism, we get an algebra epimorphism.
-/
lemma algebra_epi_of_epi {X Y : algebra T} (f : X ⟶ Y) [h : epi f.f] : epi f :=
(forget T).epi_of_epi_map h

/-- Given an algebra morphism whose carrier part is a monomorphism, we get an algebra monomorphism.
-/
lemma algebra_mono_of_mono {X Y : algebra T} (f : X ⟶ Y) [h : mono f.f] : mono f :=
(forget T).mono_of_mono_map h

instance : is_right_adjoint T.forget := ⟨T.free, T.adj⟩
@[simp] lemma left_adjoint_forget : left_adjoint T.forget = T.free := rfl
@[simp] lemma of_right_adjoint_forget : adjunction.of_right_adjoint T.forget = T.adj := rfl

/--
Given a monad morphism from `T₂` to `T₁`, we get a functor from the algebras of `T₁` to algebras of
`T₂`.
-/
@[simps]
def algebra_functor_of_monad_hom {T₁ T₂ : monad C} (h : T₂ ⟶ T₁) :
  algebra T₁ ⥤ algebra T₂ :=
{ obj := λ A,
  { A := A.A,
    a := h.app A.A ≫ A.a,
    unit' := by { dsimp, simp [A.unit] },
    assoc' := by { dsimp, simp [A.assoc] } },
  map := λ A₁ A₂ f,
  { f := f.f } }

/--
The identity monad morphism induces the identity functor from the category of algebras to itself.
-/
@[simps {rhs_md := semireducible}]
def algebra_functor_of_monad_hom_id {T₁ : monad C} :
  algebra_functor_of_monad_hom (𝟙 T₁) ≅ 𝟭 _ :=
nat_iso.of_components
  (λ X, algebra.iso_mk (iso.refl _) (by { dsimp, simp, }))
  (λ X Y f, by { ext, dsimp, simp })

/--
A composition of monad morphisms gives the composition of corresponding functors.
-/
@[simps {rhs_md := semireducible}]
def algebra_functor_of_monad_hom_comp {T₁ T₂ T₃ : monad C} (f : T₁ ⟶ T₂) (g : T₂ ⟶ T₃) :
  algebra_functor_of_monad_hom (f ≫ g) ≅
    algebra_functor_of_monad_hom g ⋙ algebra_functor_of_monad_hom f :=
nat_iso.of_components
  (λ X, algebra.iso_mk (iso.refl _) (by { dsimp, simp }))
  (λ X Y f, by { ext, dsimp, simp })

/--
If `f` and `g` are two equal morphisms of monads, then the functors of algebras induced by them
are isomorphic.
We define it like this as opposed to using `eq_to_iso` so that the components are nicer to prove
lemmas about.
-/
@[simps {rhs_md := semireducible}]
def algebra_functor_of_monad_hom_eq {T₁ T₂ : monad C} {f g : T₁ ⟶ T₂} (h : f = g) :
  algebra_functor_of_monad_hom f ≅ algebra_functor_of_monad_hom g :=
nat_iso.of_components
  (λ X, algebra.iso_mk (iso.refl _) (by { dsimp, simp [h] }))
  (λ X Y f, by { ext, dsimp, simp })

/--
Isomorphic monads give equivalent categories of algebras. Furthermore, they are equivalent as
categories over `C`, that is, we have `algebra_equiv_of_iso_monads h ⋙ forget = forget`.
-/
@[simps]
def algebra_equiv_of_iso_monads {T₁ T₂ : monad C} (h : T₁ ≅ T₂) :
  algebra T₁ ≌ algebra T₂ :=
{ functor := algebra_functor_of_monad_hom h.inv,
  inverse := algebra_functor_of_monad_hom h.hom,
  unit_iso :=
    algebra_functor_of_monad_hom_id.symm ≪≫
    algebra_functor_of_monad_hom_eq (by simp) ≪≫
    algebra_functor_of_monad_hom_comp _ _,
  counit_iso :=
    (algebra_functor_of_monad_hom_comp _ _).symm ≪≫
    algebra_functor_of_monad_hom_eq (by simp) ≪≫
    algebra_functor_of_monad_hom_id }

@[simp] lemma algebra_equiv_of_iso_monads_comp_forget {T₁ T₂ : monad C} (h : T₁ ⟶ T₂) :
  algebra_functor_of_monad_hom h ⋙ forget _ = forget _ :=
rfl

end monad

namespace comonad

/-- An Eilenberg-Moore coalgebra for a comonad `T`. -/
@[nolint has_nonempty_instance]
structure coalgebra (G : comonad C) : Type (max u₁ v₁) :=
(A : C)
(a : A ⟶ (G : C ⥤ C).obj A)
(counit' : a ≫ G.ε.app A = 𝟙 A . obviously)
(coassoc' : a ≫ G.δ.app A = a ≫ G.map a . obviously)

restate_axiom coalgebra.counit'
restate_axiom coalgebra.coassoc'
attribute [reassoc] coalgebra.counit coalgebra.coassoc

namespace coalgebra
variables {G : comonad C}

/-- A morphism of Eilenberg-Moore coalgebras for the comonad `G`. -/
@[ext, nolint has_nonempty_instance] structure hom (A B : coalgebra G) :=
(f : A.A ⟶ B.A)
(h' : A.a ≫ (G : C ⥤ C).map f = f ≫ B.a . obviously)

restate_axiom hom.h'
attribute [simp, reassoc] hom.h

namespace hom

/-- The identity homomorphism for an Eilenberg–Moore coalgebra. -/
def id (A : coalgebra G) : hom A A :=
{ f := 𝟙 A.A }

/-- Composition of Eilenberg–Moore coalgebra homomorphisms. -/
def comp {P Q R : coalgebra G} (f : hom P Q) (g : hom Q R) : hom P R :=
{ f := f.f ≫ g.f }

end hom

/-- The category of Eilenberg-Moore coalgebras for a comonad. -/
instance : category_struct (coalgebra G) :=
{ hom := hom,
  id := hom.id,
  comp := @hom.comp _ _ _ }

@[simp] lemma comp_eq_comp {A A' A'' : coalgebra G} (f : A ⟶ A') (g : A' ⟶ A'') :
  coalgebra.hom.comp f g = f ≫ g := rfl
@[simp] lemma id_eq_id (A : coalgebra G) :
  coalgebra.hom.id A = 𝟙 A := rfl

@[simp] lemma id_f (A : coalgebra G) : (𝟙 A : A ⟶ A).f = 𝟙 A.A := rfl
@[simp] lemma comp_f {A A' A'' : coalgebra G} (f : A ⟶ A') (g : A' ⟶ A'') :
  (f ≫ g).f = f.f ≫ g.f := rfl

/-- The category of Eilenberg-Moore coalgebras for a comonad. -/
instance EilenbergMoore : category (coalgebra G) := {}.

/--
To construct an isomorphism of coalgebras, it suffices to give an isomorphism of the carriers which
commutes with the structure morphisms.
-/
@[simps]
def iso_mk {A B : coalgebra G} (h : A.A ≅ B.A) (w : A.a ≫ (G : C ⥤ C).map h.hom = h.hom ≫ B.a) :
  A ≅ B :=
{ hom := { f := h.hom },
  inv :=
  { f := h.inv,
    h' := by { rw [h.eq_inv_comp, ←reassoc_of w, ←functor.map_comp], simp } } }

end coalgebra

variables (G : comonad C)

/-- The forgetful functor from the Eilenberg-Moore category, forgetting the coalgebraic
structure. -/
@[simps] def forget : coalgebra G ⥤ C :=
{ obj := λ A, A.A,
  map := λ A B f, f.f }

/-- The cofree functor from the Eilenberg-Moore category, constructing a coalgebra for any
object. -/
@[simps] def cofree : C ⥤ coalgebra G :=
{ obj := λ X,
  { A := G.obj X,
    a := G.δ.app X,
    coassoc' := (G.coassoc _).symm },
  map := λ X Y f,
  { f := G.map f,
    h' := (G.δ.naturality _).symm } }

/--
The adjunction between the cofree and forgetful constructions for Eilenberg-Moore coalgebras
for a comonad.
-/
-- The other two `simps` projection lemmas can be derived from these two, so `simp_nf` complains if
-- those are added too
@[simps unit counit]
def adj : G.forget ⊣ G.cofree :=
adjunction.mk_of_hom_equiv
{ hom_equiv := λ X Y,
  { to_fun := λ f,
    { f := X.a ≫ G.map f,
      h' := by { dsimp, simp [←coalgebra.coassoc_assoc] } },
    inv_fun := λ g, g.f ≫ G.ε.app Y,
    left_inv := λ f,
      by { dsimp, rw [category.assoc, G.ε.naturality, functor.id_map, X.counit_assoc] },
    right_inv := λ g,
    begin
      ext1, dsimp,
      rw [functor.map_comp, g.h_assoc, cofree_obj_a, comonad.right_counit],
      apply comp_id,
    end }}

/--
Given a coalgebra morphism whose carrier part is an isomorphism, we get a coalgebra isomorphism.
-/
lemma coalgebra_iso_of_iso {A B : coalgebra G} (f : A ⟶ B) [is_iso f.f] : is_iso f :=
⟨⟨{ f := inv f.f,
    h' := by { rw [is_iso.eq_inv_comp f.f, ←f.h_assoc], simp } }, by tidy⟩⟩

instance forget_reflects_iso : reflects_isomorphisms G.forget :=
{ reflects := λ A B, coalgebra_iso_of_iso G }

instance forget_faithful : faithful (forget G) := {}

/-- Given a coalgebra morphism whose carrier part is an epimorphism, we get an algebra epimorphism.
-/
lemma algebra_epi_of_epi {X Y : coalgebra G} (f : X ⟶ Y) [h : epi f.f] : epi f :=
(forget G).epi_of_epi_map h

/-- Given a coalgebra morphism whose carrier part is a monomorphism, we get an algebra monomorphism.
-/
lemma algebra_mono_of_mono {X Y : coalgebra G} (f : X ⟶ Y) [h : mono f.f] : mono f :=
(forget G).mono_of_mono_map h

instance : is_left_adjoint G.forget := ⟨_, G.adj⟩
@[simp] lemma right_adjoint_forget : right_adjoint G.forget = G.cofree := rfl
@[simp] lemma of_left_adjoint_forget : adjunction.of_left_adjoint G.forget = G.adj := rfl

end comonad

end category_theory


inductive Foo : Nat → Type _
| nil : Foo 0
| cons (t: Foo l) : Foo l

def Foo.bar (t₁: Foo l₁) (t₂ : Foo l₂) : Bool :=
  match t₂ with
  | cons s₁ => t₁.bar s₁
  | _ => false

attribute [simp] Foo.bar

example (h : t₂ = .nil) : Foo.bar t₁ t₂ = false := by
  unfold Foo.bar
  split
  · contradiction
  · rfl

set_option pp.proofs true
#print Foo.bar.match_1


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Bhavik Mehta
-/
import category_theory.functor.const
import category_theory.discrete_category

/-!
# The category `discrete punit`

We define `star : C ⥤ discrete punit` sending everything to `punit.star`,
show that any two functors to `discrete punit` are naturally isomorphic,
and construct the equivalence `(discrete punit ⥤ C) ≌ C`.
-/

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

namespace category_theory
variables (C : Type u) [category.{v} C]

namespace functor

/-- The constant functor sending everything to `punit.star`. -/
@[simps]
def star : C ⥤ discrete punit :=
(functor.const _).obj ⟨⟨⟩⟩

variable {C}
/-- Any two functors to `discrete punit` are isomorphic. -/
@[simps]
def punit_ext (F G : C ⥤ discrete punit) : F ≅ G :=
nat_iso.of_components (λ _, eq_to_iso dec_trivial) (λ _ _ _, dec_trivial)

/--
Any two functors to `discrete punit` are *equal*.
You probably want to use `punit_ext` instead of this.
-/
lemma punit_ext' (F G : C ⥤ discrete punit) : F = G :=
functor.ext (λ _, dec_trivial) (λ _ _ _, dec_trivial)

/-- The functor from `discrete punit` sending everything to the given object. -/
abbreviation from_punit (X : C) : discrete punit.{v+1} ⥤ C :=
(functor.const _).obj X

/-- Functors from `discrete punit` are equivalent to the category itself. -/
@[simps]
def equiv : (discrete punit ⥤ C) ≌ C :=
{ functor :=
  { obj := λ F, F.obj ⟨⟨⟩⟩,
    map := λ F G θ, θ.app ⟨⟨⟩⟩ },
  inverse := functor.const _,
  unit_iso :=
  begin
    apply nat_iso.of_components _ _,
    intro X,
    apply discrete.nat_iso,
    rintro ⟨⟨⟩⟩,
    apply iso.refl _,
    intros,
    ext ⟨⟨⟩⟩,
    simp,
  end,
  counit_iso :=
  begin
    refine nat_iso.of_components iso.refl _,
    intros X Y f,
    dsimp, simp,  -- See note [dsimp, simp].
  end }

end functor

/-- A category being equivalent to `punit` is equivalent to it having a unique morphism between
  any two objects. (In fact, such a category is also a groupoid; see `groupoid.of_hom_unique`) -/
theorem equiv_punit_iff_unique :
  nonempty (C ≌ discrete punit) ↔ (nonempty C) ∧ (∀ x y : C, nonempty $ unique (x ⟶ y)) :=
begin
  split,
  { rintro ⟨h⟩,
    refine ⟨⟨h.inverse.obj ⟨⟨⟩⟩⟩, λ x y, nonempty.intro _⟩,
    apply (unique_of_subsingleton _), swap,
    { have hx : x ⟶ h.inverse.obj ⟨⟨⟩⟩ := by convert h.unit.app x,
      have hy : h.inverse.obj ⟨⟨⟩⟩ ⟶ y := by convert h.unit_inv.app y,
      exact hx ≫ hy, },
    have : ∀ z, z = h.unit.app x ≫ (h.functor ⋙ h.inverse).map z ≫ h.unit_inv.app y,
    { intro z, simpa using congr_arg (≫ (h.unit_inv.app y)) (h.unit.naturality z), },
    apply subsingleton.intro,
    intros a b,
    rw [this a, this b],
    simp only [functor.comp_map], congr, },
  { rintro ⟨⟨p⟩, h⟩,
    haveI := λ x y, (h x y).some,
    refine nonempty.intro (category_theory.equivalence.mk
      ((functor.const _).obj ⟨⟨⟩⟩) ((functor.const _).obj p) _ (by apply functor.punit_ext)),
    exact nat_iso.of_components (λ _, { hom := default, inv := default }) (λ _ _ _, by tidy), },
end

end category_theory


/-
Copyright (c) 2022 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang
-/
import algebraic_geometry.gluing
import category_theory.limits.opposites
import algebraic_geometry.AffineScheme
import category_theory.limits.shapes.diagonal

/-!
# Fibred products of schemes

In this file we construct the fibred product of schemes via gluing.
We roughly follow [har77] Theorem 3.3.

In particular, the main construction is to show that for an open cover `{ Uᵢ }` of `X`, if there
exist fibred products `Uᵢ ×[Z] Y` for each `i`, then there exists a fibred product `X ×[Z] Y`.

Then, for constructing the fibred product for arbitrary schemes `X, Y, Z`, we can use the
construction to reduce to the case where `X, Y, Z` are all affine, where fibred products are
constructed via tensor products.

-/
universes v u
noncomputable theory

open category_theory category_theory.limits algebraic_geometry
namespace algebraic_geometry.Scheme

namespace pullback

variables {C : Type u} [category.{v} C]

variables {X Y Z : Scheme.{u}} (𝒰 : open_cover.{u} X) (f : X ⟶ Z) (g : Y ⟶ Z)
variables [∀ i, has_pullback (𝒰.map i ≫ f) g]

/-- The intersection of `Uᵢ ×[Z] Y` and `Uⱼ ×[Z] Y` is given by (Uᵢ ×[Z] Y) ×[X] Uⱼ -/
def V (i j : 𝒰.J) : Scheme :=
pullback ((pullback.fst : pullback ((𝒰.map i) ≫ f) g ⟶ _) ≫ (𝒰.map i)) (𝒰.map j)

/-- The canonical transition map `(Uᵢ ×[Z] Y) ×[X] Uⱼ ⟶ (Uⱼ ×[Z] Y) ×[X] Uᵢ` given by the fact
that pullbacks are associative and symmetric. -/
def t (i j : 𝒰.J) : V 𝒰 f g i j ⟶ V 𝒰 f g j i :=
begin
  haveI : has_pullback (pullback.snd ≫ 𝒰.map i ≫ f) g :=
    has_pullback_assoc_symm (𝒰.map j) (𝒰.map i) (𝒰.map i ≫ f) g,
  haveI : has_pullback (pullback.snd ≫ 𝒰.map j ≫ f) g :=
    has_pullback_assoc_symm (𝒰.map i) (𝒰.map j) (𝒰.map j ≫ f) g,
  refine (pullback_symmetry _ _).hom ≫ _,
  refine (pullback_assoc _ _ _ _).inv ≫ _,
  change pullback _ _ ⟶ pullback _ _,
  refine _ ≫ (pullback_symmetry _ _).hom,
  refine _ ≫ (pullback_assoc _ _ _ _).hom,
  refine pullback.map _ _ _ _ (pullback_symmetry _ _).hom (𝟙 _) (𝟙 _) _ _,
  rw [pullback_symmetry_hom_comp_snd_assoc, pullback.condition_assoc, category.comp_id],
  rw [category.comp_id, category.id_comp]
end

@[simp, reassoc]
lemma t_fst_fst (i j : 𝒰.J) : t 𝒰 f g i j ≫ pullback.fst ≫ pullback.fst = pullback.snd :=
begin
  delta t,
  simp only [category.assoc, id.def, pullback_symmetry_hom_comp_fst_assoc,
    pullback_assoc_hom_snd_fst, pullback.lift_fst_assoc, pullback_symmetry_hom_comp_snd,
    pullback_assoc_inv_fst_fst, pullback_symmetry_hom_comp_fst],
end

@[simp, reassoc]
lemma t_fst_snd (i j : 𝒰.J) :
  t 𝒰 f g i j ≫ pullback.fst ≫ pullback.snd = pullback.fst ≫ pullback.snd :=
begin
  delta t,
  simp only [pullback_symmetry_hom_comp_snd_assoc, category.comp_id, category.assoc, id.def,
    pullback_symmetry_hom_comp_fst_assoc, pullback_assoc_hom_snd_snd, pullback.lift_snd,
    pullback_assoc_inv_snd],
end

@[simp, reassoc]
lemma t_snd (i j : 𝒰.J) :
  t 𝒰 f g i j ≫ pullback.snd = pullback.fst ≫ pullback.fst :=
begin
  delta t,
  simp only [pullback_symmetry_hom_comp_snd_assoc, category.assoc, id.def,
    pullback_symmetry_hom_comp_snd, pullback_assoc_hom_fst, pullback.lift_fst_assoc,
    pullback_symmetry_hom_comp_fst, pullback_assoc_inv_fst_snd],
end

lemma t_id (i : 𝒰.J) : t 𝒰 f g i i = 𝟙 _ :=
begin
  apply pullback.hom_ext; rw category.id_comp,
  apply pullback.hom_ext,
  { rw ← cancel_mono (𝒰.map i), simp only [pullback.condition, category.assoc, t_fst_fst] },
  { simp only [category.assoc, t_fst_snd]},
  { rw ← cancel_mono (𝒰.map i),simp only [pullback.condition, t_snd, category.assoc] }
end

/-- The inclusion map of `V i j = (Uᵢ ×[Z] Y) ×[X] Uⱼ ⟶ Uᵢ ×[Z] Y`-/
abbreviation fV (i j : 𝒰.J) : V 𝒰 f g i j ⟶ pullback ((𝒰.map i) ≫ f) g := pullback.fst

/-- The map `((Xᵢ ×[Z] Y) ×[X] Xⱼ) ×[Xᵢ ×[Z] Y] ((Xᵢ ×[Z] Y) ×[X] Xₖ)` ⟶
  `((Xⱼ ×[Z] Y) ×[X] Xₖ) ×[Xⱼ ×[Z] Y] ((Xⱼ ×[Z] Y) ×[X] Xᵢ)` needed for gluing   -/
def t' (i j k : 𝒰.J) :
  pullback (fV 𝒰 f g i j) (fV 𝒰 f g i k) ⟶ pullback (fV 𝒰 f g j k) (fV 𝒰 f g j i) :=
begin
  refine (pullback_right_pullback_fst_iso _ _ _).hom ≫ _,
  refine _ ≫ (pullback_symmetry _ _).hom,
  refine _ ≫ (pullback_right_pullback_fst_iso _ _ _).inv,
  refine pullback.map _ _ _ _ (t 𝒰 f g i j) (𝟙 _) (𝟙 _) _ _,
  { simp only [←pullback.condition, category.comp_id, t_fst_fst_assoc] },
  { simp only [category.comp_id, category.id_comp]}
end

section end

@[simp, reassoc]
lemma t'_fst_fst_fst (i j k : 𝒰.J) :
  t' 𝒰 f g i j k ≫ pullback.fst ≫ pullback.fst ≫ pullback.fst = pullback.fst ≫ pullback.snd :=
begin
  delta t',
  simp only [category.assoc, pullback_symmetry_hom_comp_fst_assoc,
    pullback_right_pullback_fst_iso_inv_snd_fst_assoc, pullback.lift_fst_assoc, t_fst_fst,
    pullback_right_pullback_fst_iso_hom_fst_assoc],
end

@[simp, reassoc]
lemma t'_fst_fst_snd (i j k : 𝒰.J) :
  t' 𝒰 f g i j k ≫ pullback.fst ≫ pullback.fst ≫ pullback.snd =
    pullback.fst ≫ pullback.fst ≫ pullback.snd :=
begin
  delta t',
  simp only [category.assoc, pullback_symmetry_hom_comp_fst_assoc,
    pullback_right_pullback_fst_iso_inv_snd_fst_assoc, pullback.lift_fst_assoc, t_fst_snd,
    pullback_right_pullback_fst_iso_hom_fst_assoc],
end

@[simp, reassoc]
lemma t'_fst_snd (i j k : 𝒰.J) :
  t' 𝒰 f g i j k ≫ pullback.fst ≫ pullback.snd = pullback.snd ≫ pullback.snd :=
begin
  delta t',
  simp only [category.comp_id, category.assoc, pullback_symmetry_hom_comp_fst_assoc,
    pullback_right_pullback_fst_iso_inv_snd_snd, pullback.lift_snd,
    pullback_right_pullback_fst_iso_hom_snd],
end

@[simp, reassoc]
lemma t'_snd_fst_fst (i j k : 𝒰.J) :
  t' 𝒰 f g i j k ≫ pullback.snd ≫ pullback.fst ≫ pullback.fst = pullback.fst ≫ pullback.snd :=
begin
  delta t',
  simp only [category.assoc, pullback_symmetry_hom_comp_snd_assoc,
    pullback_right_pullback_fst_iso_inv_fst_assoc, pullback.lift_fst_assoc, t_fst_fst,
    pullback_right_pullback_fst_iso_hom_fst_assoc],
end

@[simp, reassoc]
lemma t'_snd_fst_snd (i j k : 𝒰.J) :
  t' 𝒰 f g i j k ≫ pullback.snd ≫ pullback.fst ≫ pullback.snd =
    pullback.fst ≫ pullback.fst ≫ pullback.snd :=
begin
  delta t',
  simp only [category.assoc, pullback_symmetry_hom_comp_snd_assoc,
    pullback_right_pullback_fst_iso_inv_fst_assoc, pullback.lift_fst_assoc, t_fst_snd,
    pullback_right_pullback_fst_iso_hom_fst_assoc],
end

@[simp, reassoc]
lemma t'_snd_snd (i j k : 𝒰.J) :
  t' 𝒰 f g i j k ≫ pullback.snd ≫ pullback.snd = pullback.fst ≫ pullback.fst ≫ pullback.fst :=
begin
  delta t',
  simp only [category.assoc, pullback_symmetry_hom_comp_snd_assoc,
    pullback_right_pullback_fst_iso_inv_fst_assoc, pullback.lift_fst_assoc, t_snd,
    pullback_right_pullback_fst_iso_hom_fst_assoc],
end

lemma cocycle_fst_fst_fst (i j k : 𝒰.J) :
  t' 𝒰 f g i j k ≫ t' 𝒰 f g j k i ≫ t' 𝒰 f g k i j ≫ pullback.fst ≫ pullback.fst ≫
  pullback.fst = pullback.fst ≫ pullback.fst ≫ pullback.fst :=
by simp only [t'_fst_fst_fst, t'_fst_snd, t'_snd_snd]

lemma cocycle_fst_fst_snd (i j k : 𝒰.J) :
  t' 𝒰 f g i j k ≫ t' 𝒰 f g j k i ≫ t' 𝒰 f g k i j ≫ pullback.fst ≫ pullback.fst ≫
  pullback.snd = pullback.fst ≫ pullback.fst ≫ pullback.snd :=
by simp only [t'_fst_fst_snd]

lemma cocycle_fst_snd (i j k : 𝒰.J) :
  t' 𝒰 f g i j k ≫ t' 𝒰 f g j k i ≫ t' 𝒰 f g k i j ≫ pullback.fst ≫ pullback.snd =
    pullback.fst ≫ pullback.snd :=
by simp only [t'_fst_snd, t'_snd_snd, t'_fst_fst_fst]

lemma cocycle_snd_fst_fst (i j k : 𝒰.J) :
  t' 𝒰 f g i j k ≫ t' 𝒰 f g j k i ≫ t' 𝒰 f g k i j ≫ pullback.snd ≫ pullback.fst ≫
  pullback.fst = pullback.snd ≫ pullback.fst ≫ pullback.fst :=
begin
  rw ← cancel_mono (𝒰.map i),
  simp only [pullback.condition_assoc, t'_snd_fst_fst, t'_fst_snd, t'_snd_snd]
end

lemma cocycle_snd_fst_snd (i j k : 𝒰.J) :
  t' 𝒰 f g i j k ≫ t' 𝒰 f g j k i ≫ t' 𝒰 f g k i j ≫ pullback.snd ≫ pullback.fst ≫
  pullback.snd = pullback.snd ≫ pullback.fst ≫ pullback.snd :=
by simp only [pullback.condition_assoc, t'_snd_fst_snd]

lemma cocycle_snd_snd (i j k : 𝒰.J) :
  t' 𝒰 f g i j k ≫ t' 𝒰 f g j k i ≫ t' 𝒰 f g k i j ≫ pullback.snd ≫ pullback.snd =
    pullback.snd ≫ pullback.snd :=
by simp only [t'_snd_snd, t'_fst_fst_fst, t'_fst_snd]

-- `by tidy` should solve it, but it times out.
lemma cocycle (i j k : 𝒰.J) :
  t' 𝒰 f g i j k ≫ t' 𝒰 f g j k i ≫ t' 𝒰 f g k i j = 𝟙 _ :=
begin
  apply pullback.hom_ext; rw category.id_comp,
  { apply pullback.hom_ext,
    { apply pullback.hom_ext,
      { simp_rw category.assoc,
        exact cocycle_fst_fst_fst 𝒰 f g i j k },
      { simp_rw category.assoc,
        exact cocycle_fst_fst_snd 𝒰 f g i j k } },
    { simp_rw category.assoc,
      exact cocycle_fst_snd 𝒰 f g i j k } },
  { apply pullback.hom_ext,
    { apply pullback.hom_ext,
      { simp_rw category.assoc,
        exact cocycle_snd_fst_fst 𝒰 f g i j k },
      { simp_rw category.assoc,
        exact cocycle_snd_fst_snd 𝒰 f g i j k } },
    { simp_rw category.assoc,
      exact cocycle_snd_snd 𝒰 f g i j k } }
end

/-- Given `Uᵢ ×[Z] Y`, this is the glued fibered product `X ×[Z] Y`. -/
@[simps]
def gluing : Scheme.glue_data.{u} :=
{ J := 𝒰.J,
  U := λ i, pullback ((𝒰.map i) ≫ f) g,
  V := λ ⟨i, j⟩, V 𝒰 f g i j, -- `p⁻¹(Uᵢ ∩ Uⱼ)` where `p : Uᵢ ×[Z] Y ⟶ Uᵢ ⟶ X`.
  f := λ i j, pullback.fst,
  f_id := λ i, infer_instance,
  f_open := infer_instance,
  t := λ i j, t 𝒰 f g i j,
  t_id := λ i, t_id 𝒰 f g i,
  t' := λ i j k, t' 𝒰 f g i j k,
  t_fac := λ i j k, begin
    apply pullback.hom_ext,
    apply pullback.hom_ext,
    all_goals { simp only [t'_snd_fst_fst, t'_snd_fst_snd, t'_snd_snd,
      t_fst_fst, t_fst_snd, t_snd, category.assoc] }
  end,
  cocycle := λ i j k, cocycle 𝒰 f g i j k }

/-- The first projection from the glued scheme into `X`. -/
def p1 : (gluing 𝒰 f g).glued ⟶ X :=
begin
  fapply multicoequalizer.desc,
  exact λ i, pullback.fst ≫ 𝒰.map i,
  rintro ⟨i, j⟩,
  change pullback.fst ≫ _ ≫ 𝒰.map i = (_ ≫ _) ≫ _ ≫ 𝒰.map j,
  rw pullback.condition,
  rw ← category.assoc,
  congr' 1,
  rw category.assoc,
  exact (t_fst_fst _ _ _ _ _).symm
end

/-- The second projection from the glued scheme into `Y`. -/
def p2 : (gluing 𝒰 f g).glued ⟶ Y :=
begin
  fapply multicoequalizer.desc,
  exact λ i, pullback.snd,
  rintro ⟨i, j⟩,
  change pullback.fst ≫ _ = (_ ≫ _) ≫ _,
  rw category.assoc,
  exact (t_fst_snd _ _ _ _ _).symm
end

lemma p_comm : p1 𝒰 f g ≫ f = p2 𝒰 f g ≫ g :=
begin
  apply multicoequalizer.hom_ext,
  intro i,
  erw [multicoequalizer.π_desc_assoc, multicoequalizer.π_desc_assoc],
  rw [category.assoc, pullback.condition]
end

variable (s : pullback_cone f g)

/-- (Implementation)
The canonical map `(s.X ×[X] Uᵢ) ×[s.X] (s.X ×[X] Uⱼ) ⟶ (Uᵢ ×[Z] Y) ×[X] Uⱼ`

This is used in `glued_lift`. -/
def glued_lift_pullback_map (i j : 𝒰.J) :
  pullback ((𝒰.pullback_cover s.fst).map i) ((𝒰.pullback_cover s.fst).map j) ⟶
    (gluing 𝒰 f g).V ⟨i, j⟩ :=
begin
  change pullback pullback.fst pullback.fst ⟶ pullback _ _,
  refine (pullback_right_pullback_fst_iso _ _ _).hom ≫ _,
  refine pullback.map _ _ _ _ _ (𝟙 _) (𝟙 _) _ _,
  { exact (pullback_symmetry _ _).hom ≫
      pullback.map _ _ _ _ (𝟙 _) s.snd f (category.id_comp _).symm s.condition },
  { simpa using pullback.condition },
  { simp only [category.comp_id, category.id_comp] }
end

@[reassoc]
lemma glued_lift_pullback_map_fst (i j : 𝒰.J) :
  glued_lift_pullback_map 𝒰 f g s i j ≫ pullback.fst = pullback.fst ≫
    (pullback_symmetry _ _).hom ≫
      pullback.map _ _ _ _ (𝟙 _) s.snd f (category.id_comp _).symm s.condition :=
begin
  delta glued_lift_pullback_map,
  simp only [category.assoc, id.def, pullback.lift_fst,
    pullback_right_pullback_fst_iso_hom_fst_assoc],
end
@[reassoc]
lemma glued_lift_pullback_map_snd (i j : 𝒰.J) :
  glued_lift_pullback_map 𝒰 f g s i j ≫ pullback.snd = pullback.snd ≫ pullback.snd :=
begin
  delta glued_lift_pullback_map,
  simp only [category.assoc, category.comp_id, id.def, pullback.lift_snd,
    pullback_right_pullback_fst_iso_hom_snd],
end

/--
The lifted map `s.X ⟶ (gluing 𝒰 f g).glued` in order to show that `(gluing 𝒰 f g).glued` is
indeed the pullback.

Given a pullback cone `s`, we have the maps `s.fst ⁻¹' Uᵢ ⟶ Uᵢ` and
`s.fst ⁻¹' Uᵢ ⟶ s.X ⟶ Y` that we may lift to a map `s.fst ⁻¹' Uᵢ ⟶ Uᵢ ×[Z] Y`.

to glue these into a map `s.X ⟶ Uᵢ ×[Z] Y`, we need to show that the maps agree on
`(s.fst ⁻¹' Uᵢ) ×[s.X] (s.fst ⁻¹' Uⱼ) ⟶ Uᵢ ×[Z] Y`. This is achieved by showing that both of these
maps factors through `glued_lift_pullback_map`.
-/
def glued_lift : s.X ⟶ (gluing 𝒰 f g).glued :=
begin
  fapply (𝒰.pullback_cover s.fst).glue_morphisms,
  { exact λ i, (pullback_symmetry _ _).hom ≫
      pullback.map _ _ _ _ (𝟙 _) s.snd f (category.id_comp _).symm s.condition ≫
      (gluing 𝒰 f g).ι i },
  intros i j,
  rw ← glued_lift_pullback_map_fst_assoc,
  have : _ = pullback.fst ≫ _ := (gluing 𝒰 f g).glue_condition i j,
  rw [← this, gluing_to_glue_data_t, gluing_to_glue_data_f],
  simp_rw ← category.assoc,
  congr' 1,
  apply pullback.hom_ext; simp_rw category.assoc,
  { rw [t_fst_fst, glued_lift_pullback_map_snd],
    congr' 1,
    rw [← iso.inv_comp_eq, pullback_symmetry_inv_comp_snd],
    erw pullback.lift_fst,
    rw category.comp_id },
  { rw [t_fst_snd, glued_lift_pullback_map_fst_assoc],
    erw [pullback.lift_snd, pullback.lift_snd],
    rw [pullback_symmetry_hom_comp_snd_assoc, pullback_symmetry_hom_comp_snd_assoc],
    exact pullback.condition_assoc _ }
end

lemma glued_lift_p1 : glued_lift 𝒰 f g s ≫ p1 𝒰 f g = s.fst :=
begin
  rw ← cancel_epi (𝒰.pullback_cover s.fst).from_glued,
  apply multicoequalizer.hom_ext,
  intro b,
  erw [multicoequalizer.π_desc_assoc, multicoequalizer.π_desc_assoc],
  delta glued_lift,
  simp_rw ← category.assoc,
  rw (𝒰.pullback_cover s.fst).ι_glue_morphisms,
  simp_rw category.assoc,
  erw [multicoequalizer.π_desc, pullback.lift_fst_assoc, pullback.condition, category.comp_id],
  rw pullback_symmetry_hom_comp_fst_assoc,
end

lemma glued_lift_p2 : glued_lift 𝒰 f g s ≫ p2 𝒰 f g = s.snd :=
begin
  rw ← cancel_epi (𝒰.pullback_cover s.fst).from_glued,
  apply multicoequalizer.hom_ext,
  intro b,
  erw [multicoequalizer.π_desc_assoc, multicoequalizer.π_desc_assoc],
  delta glued_lift,
  simp_rw ← category.assoc,
  rw (𝒰.pullback_cover s.fst).ι_glue_morphisms,
  simp_rw category.assoc,
  erw [multicoequalizer.π_desc, pullback.lift_snd],
  rw pullback_symmetry_hom_comp_snd_assoc,
  refl
end

/-- (Implementation)
The canonical map `(W ×[X] Uᵢ) ×[W] (Uⱼ ×[Z] Y) ⟶ (Uⱼ ×[Z] Y) ×[X] Uᵢ = V j i` where `W` is
the glued fibred product.

This is used in `lift_comp_ι`. -/
def pullback_fst_ι_to_V (i j : 𝒰.J) :
  pullback (pullback.fst : pullback (p1 𝒰 f g) (𝒰.map i) ⟶ _) ((gluing 𝒰 f g).ι j) ⟶
    V 𝒰 f g j i :=
(pullback_symmetry _ _ ≪≫
  (pullback_right_pullback_fst_iso (p1 𝒰 f g) (𝒰.map i) _)).hom ≫
    (pullback.congr_hom (multicoequalizer.π_desc _ _ _ _ _) rfl).hom

@[simp, reassoc] lemma pullback_fst_ι_to_V_fst (i j : 𝒰.J) :
  pullback_fst_ι_to_V 𝒰 f g i j ≫ pullback.fst = pullback.snd :=
begin
  delta pullback_fst_ι_to_V,
  simp only [iso.trans_hom, pullback.congr_hom_hom, category.assoc, pullback.lift_fst,
    category.comp_id, pullback_right_pullback_fst_iso_hom_fst, pullback_symmetry_hom_comp_fst],
end

@[simp, reassoc] lemma pullback_fst_ι_to_V_snd (i j : 𝒰.J) :
  pullback_fst_ι_to_V 𝒰 f g i j ≫ pullback.snd = pullback.fst ≫ pullback.snd :=
begin
  delta pullback_fst_ι_to_V,
  simp only [iso.trans_hom, pullback.congr_hom_hom, category.assoc, pullback.lift_snd,
    category.comp_id, pullback_right_pullback_fst_iso_hom_snd, pullback_symmetry_hom_comp_snd_assoc]
end
/-- We show that the map `W ×[X] Uᵢ ⟶ Uᵢ ×[Z] Y ⟶ W` is the first projection, where the
first map is given by the lift of `W ×[X] Uᵢ ⟶ Uᵢ` and `W ×[X] Uᵢ ⟶ W ⟶ Y`.

It suffices to show that the two map agrees when restricted onto `Uⱼ ×[Z] Y`. In this case,
both maps factor through `V j i` via `pullback_fst_ι_to_V` -/
lemma lift_comp_ι (i : 𝒰.J) : pullback.lift pullback.snd (pullback.fst ≫ p2 𝒰 f g)
  (by rw [← pullback.condition_assoc, category.assoc, p_comm]) ≫
  (gluing 𝒰 f g).ι i = (pullback.fst : pullback (p1 𝒰 f g) (𝒰.map i) ⟶ _) :=
begin
  apply ((gluing 𝒰 f g).open_cover.pullback_cover pullback.fst).hom_ext,
  intro j,
  dsimp only [open_cover.pullback_cover],
  transitivity pullback_fst_ι_to_V 𝒰 f g i j ≫ fV 𝒰 f g j i ≫ (gluing 𝒰 f g).ι _,
  { rw ← (show _ = fV 𝒰 f g j i ≫ _, from (gluing 𝒰 f g).glue_condition j i),
    simp_rw ← category.assoc,
    congr' 1,
    rw [gluing_to_glue_data_f, gluing_to_glue_data_t],
    apply pullback.hom_ext; simp_rw category.assoc,
    { rw [t_fst_fst, pullback.lift_fst, pullback_fst_ι_to_V_snd] },
    { rw [t_fst_snd, pullback.lift_snd, pullback_fst_ι_to_V_fst_assoc,
        pullback.condition_assoc], erw multicoequalizer.π_desc } },
  { rw [pullback.condition, ← category.assoc],
    congr' 1,
    apply pullback.hom_ext,
    { simp only [pullback_fst_ι_to_V_fst] },
    { simp only [pullback_fst_ι_to_V_fst] } }
end

/-- The canonical isomorphism between `W ×[X] Uᵢ` and `Uᵢ ×[X] Y`. That is, the preimage of `Uᵢ` in
`W` along `p1` is indeed `Uᵢ ×[X] Y`. -/
def pullback_p1_iso (i : 𝒰.J) :
  pullback (p1 𝒰 f g) (𝒰.map i) ≅ pullback (𝒰.map i ≫ f) g :=
begin
  fsplit,
  exact pullback.lift pullback.snd (pullback.fst ≫ p2 𝒰 f g)
    (by rw [← pullback.condition_assoc, category.assoc, p_comm]),
  refine pullback.lift ((gluing 𝒰 f g).ι i) pullback.fst
    (by erw multicoequalizer.π_desc),
  { apply pullback.hom_ext,
    { simpa using lift_comp_ι 𝒰 f g i },
    { simp only [category.assoc, pullback.lift_snd, pullback.lift_fst, category.id_comp] } },
  { apply pullback.hom_ext,
    { simp only [category.assoc, pullback.lift_fst, pullback.lift_snd, category.id_comp] },
    { simp only [category.assoc, pullback.lift_snd, pullback.lift_fst_assoc, category.id_comp],
      erw multicoequalizer.π_desc } },
end

@[simp, reassoc] lemma pullback_p1_iso_hom_fst (i : 𝒰.J) :
  (pullback_p1_iso 𝒰 f g i).hom ≫ pullback.fst = pullback.snd :=
by { delta pullback_p1_iso, simp only [pullback.lift_fst] }

@[simp, reassoc] lemma pullback_p1_iso_hom_snd (i : 𝒰.J) :
  (pullback_p1_iso 𝒰 f g i).hom ≫ pullback.snd = pullback.fst ≫ p2 𝒰 f g :=
by { delta pullback_p1_iso, simp only [pullback.lift_snd] }

@[simp, reassoc] lemma pullback_p1_iso_inv_fst (i : 𝒰.J) :
  (pullback_p1_iso 𝒰 f g i).inv ≫ pullback.fst = (gluing 𝒰 f g).ι i :=
by { delta pullback_p1_iso, simp only [pullback.lift_fst] }

@[simp, reassoc] lemma pullback_p1_iso_inv_snd (i : 𝒰.J) :
  (pullback_p1_iso 𝒰 f g i).inv ≫ pullback.snd = pullback.fst :=
by { delta pullback_p1_iso, simp only [pullback.lift_snd] }

@[simp, reassoc]
lemma pullback_p1_iso_hom_ι (i : 𝒰.J) :
  (pullback_p1_iso 𝒰 f g i).hom ≫ (gluing 𝒰 f g).ι i = pullback.fst :=
by rw [← pullback_p1_iso_inv_fst, iso.hom_inv_id_assoc]

/-- The glued scheme (`(gluing 𝒰 f g).glued`) is indeed the pullback of `f` and `g`. -/
def glued_is_limit : is_limit (pullback_cone.mk _ _ (p_comm 𝒰 f g)) :=
begin
  apply pullback_cone.is_limit_aux',
  intro s,
  refine ⟨glued_lift 𝒰 f g s, glued_lift_p1 𝒰 f g s, glued_lift_p2 𝒰 f g s, _⟩,
  intros m h₁ h₂,
  change m ≫ p1 𝒰 f g = _ at h₁,
  change m ≫ p2 𝒰 f g = _ at h₂,
  apply (𝒰.pullback_cover s.fst).hom_ext,
  intro i,
  rw open_cover.pullback_cover_map,
  have := pullback_right_pullback_fst_iso (p1 𝒰 f g) (𝒰.map i) m
    ≪≫ pullback.congr_hom h₁ rfl,
  erw (𝒰.pullback_cover s.fst).ι_glue_morphisms,
  rw [← cancel_epi (pullback_right_pullback_fst_iso (p1 𝒰 f g) (𝒰.map i) m
    ≪≫ pullback.congr_hom h₁ rfl).hom, iso.trans_hom, category.assoc, pullback.congr_hom_hom,
    pullback.lift_fst_assoc, category.comp_id, pullback_right_pullback_fst_iso_hom_fst_assoc,
    pullback.condition],
  transitivity pullback.snd ≫ (pullback_p1_iso 𝒰 f g _).hom ≫ (gluing 𝒰 f g).ι _,
  { congr' 1, rw ← pullback_p1_iso_hom_ι },
  simp_rw ← category.assoc,
  congr' 1,
  apply pullback.hom_ext,
  { simp only [category.comp_id, pullback_right_pullback_fst_iso_hom_snd, category.assoc,
      pullback_p1_iso_hom_fst, pullback.lift_snd, pullback.lift_fst,
      pullback_symmetry_hom_comp_fst] },
  { simp only [category.comp_id, pullback_right_pullback_fst_iso_hom_fst_assoc,
    pullback_p1_iso_hom_snd, category.assoc, pullback.lift_fst_assoc,
    pullback_symmetry_hom_comp_snd_assoc, pullback.lift_snd],
    rw [← pullback.condition_assoc, h₂] }
end

lemma has_pullback_of_cover : has_pullback f g := ⟨⟨⟨_, glued_is_limit 𝒰 f g⟩⟩⟩

instance affine_has_pullback {A B C : CommRing}
  (f : Spec.obj (opposite.op A) ⟶ Spec.obj (opposite.op C))
  (g : Spec.obj (opposite.op B) ⟶ Spec.obj (opposite.op C)) : has_pullback f g :=
begin
  rw [← Spec.image_preimage f, ← Spec.image_preimage g],
  exact ⟨⟨⟨_,is_limit_of_has_pullback_of_preserves_limit
    Spec (Spec.preimage f) (Spec.preimage g)⟩⟩⟩
end

instance base_affine_has_pullback {C : CommRing} {X Y : Scheme}
  (f : X ⟶ Spec.obj (opposite.op C))
  (g : Y ⟶ Spec.obj (opposite.op C)) : has_pullback f g :=
@@has_pullback_symmetry _ _ _
  (@@has_pullback_of_cover Y.affine_cover g f
    (λ i, @@has_pullback_symmetry _ _ _ $ affine_affine_has_pullback _ _))

instance left_affine_comp_pullback_has_pullback {X Y Z : Scheme}
  (f : X ⟶ Z) (g : Y ⟶ Z) (i : Z.affine_cover.J) :
    has_pullback ((Z.affine_cover.pullback_cover f).map i ≫ f) g :=
begin
  let Xᵢ := pullback f (Z.affine_cover.map i),
  let Yᵢ := pullback g (Z.affine_cover.map i),
  let W := pullback (pullback.snd : Yᵢ ⟶ _) (pullback.snd : Xᵢ ⟶ _),
  have := big_square_is_pullback (pullback.fst : W ⟶ _) (pullback.fst : Yᵢ ⟶ _)
    (pullback.snd : Xᵢ ⟶ _) (Z.affine_cover.map i) pullback.snd pullback.snd g
    pullback.condition.symm pullback.condition.symm
      (pullback_cone.flip_is_limit $ pullback_is_pullback _ _)
      (pullback_cone.flip_is_limit $ pullback_is_pullback _ _),
  have : has_pullback (pullback.snd ≫ Z.affine_cover.map i : Xᵢ ⟶ _) g :=
    ⟨⟨⟨_,this⟩⟩⟩,
  rw ← pullback.condition at this,
  exact this,
end

instance {X Y Z : Scheme} (f : X ⟶ Z) (g : Y ⟶ Z) : has_pullback f g :=
has_pullback_of_cover (Z.affine_cover.pullback_cover f) f g

instance : has_pullbacks Scheme := has_pullbacks_of_has_limit_cospan _

instance {X Y Z : Scheme} (f : X ⟶ Z) (g : Y ⟶ Z) [is_affine X] [is_affine Y] [is_affine Z] :
  is_affine (pullback f g) :=
is_affine_of_iso (pullback.map f g (Spec.map (Γ.map f.op).op) (Spec.map (Γ.map g.op).op)
  (Γ_Spec.adjunction.unit.app X) (Γ_Spec.adjunction.unit.app Y) (Γ_Spec.adjunction.unit.app Z)
  (Γ_Spec.adjunction.unit.naturality f) (Γ_Spec.adjunction.unit.naturality g) ≫
    (preserves_pullback.iso Spec _ _).inv)

/-- Given an open cover `{ Xᵢ }` of `X`, then `X ×[Z] Y` is covered by `Xᵢ ×[Z] Y`. -/
@[simps J obj map]
def open_cover_of_left (𝒰 : open_cover X) (f : X ⟶ Z) (g : Y ⟶ Z) : open_cover (pullback f g) :=
begin
  fapply ((gluing 𝒰 f g).open_cover.pushforward_iso
    (limit.iso_limit_cone ⟨_, glued_is_limit 𝒰 f g⟩).inv).copy 𝒰.J
    (λ i, pullback (𝒰.map i ≫ f) g)
    (λ i, pullback.map _ _ _ _ (𝒰.map i) (𝟙 _) (𝟙 _) (category.comp_id _) (by simp))
    (equiv.refl 𝒰.J) (λ _, iso.refl _),
  rintro (i : 𝒰.J),
  change pullback.map _ _ _ _ _ _ _ _ _ = 𝟙 _ ≫ (gluing 𝒰 f g).ι i ≫ _,
  refine eq.trans _ (category.id_comp _).symm,
  apply pullback.hom_ext,
  all_goals
  { dsimp,
    simp only [limit.iso_limit_cone_inv_π, pullback_cone.mk_π_app_left, category.comp_id,
      pullback_cone.mk_π_app_right, category.assoc, pullback.lift_fst, pullback.lift_snd],
    symmetry,
    exact multicoequalizer.π_desc _ _ _ _ _ },
end

/-- Given an open cover `{ Yᵢ }` of `Y`, then `X ×[Z] Y` is covered by `X ×[Z] Yᵢ`. -/
@[simps J obj map]
def open_cover_of_right (𝒰 : open_cover Y) (f : X ⟶ Z) (g : Y ⟶ Z) : open_cover (pullback f g) :=
begin
  fapply ((open_cover_of_left 𝒰 g f).pushforward_iso (pullback_symmetry _ _).hom).copy 𝒰.J
    (λ i, pullback f (𝒰.map i ≫ g))
    (λ i, pullback.map _ _ _ _ (𝟙 _) (𝒰.map i) (𝟙 _) (by simp) (category.comp_id _))
    (equiv.refl _) (λ i, pullback_symmetry _ _),
  intro i,
  dsimp [open_cover.bind],
  apply pullback.hom_ext; simp,
end

/-- Given an open cover `{ Xᵢ }` of `X` and an open cover `{ Yⱼ }` of `Y`, then
`X ×[Z] Y` is covered by `Xᵢ ×[Z] Yⱼ`. -/
@[simps J obj map]
def open_cover_of_left_right (𝒰X : X.open_cover) (𝒰Y : Y.open_cover)
  (f : X ⟶ Z) (g : Y ⟶ Z) : (pullback f g).open_cover :=
begin
  fapply ((open_cover_of_left 𝒰X f g).bind (λ x, open_cover_of_right 𝒰Y (𝒰X.map x ≫ f) g)).copy
    (𝒰X.J × 𝒰Y.J)
    (λ ij, pullback (𝒰X.map ij.1 ≫ f) (𝒰Y.map ij.2 ≫ g))
    (λ ij, pullback.map _ _ _ _ (𝒰X.map ij.1) (𝒰Y.map ij.2) (𝟙 _)
      (category.comp_id _) (category.comp_id _))
    (equiv.sigma_equiv_prod _ _).symm
    (λ _, iso.refl _),
  rintro ⟨i, j⟩,
  apply pullback.hom_ext; simpa,
end

/-- (Implementation). Use `open_cover_of_base` instead. -/
def open_cover_of_base' (𝒰 : open_cover Z) (f : X ⟶ Z) (g : Y ⟶ Z) : open_cover (pullback f g) :=
begin
  apply (open_cover_of_left (𝒰.pullback_cover f) f g).bind,
  intro i,
  let Xᵢ := pullback f (𝒰.map i),
  let Yᵢ := pullback g (𝒰.map i),
  let W := pullback (pullback.snd : Yᵢ ⟶ _) (pullback.snd : Xᵢ ⟶ _),
  have := big_square_is_pullback (pullback.fst : W ⟶ _) (pullback.fst : Yᵢ ⟶ _)
    (pullback.snd : Xᵢ ⟶ _) (𝒰.map i) pullback.snd pullback.snd g
    pullback.condition.symm pullback.condition.symm
      (pullback_cone.flip_is_limit $ pullback_is_pullback _ _)
      (pullback_cone.flip_is_limit $ pullback_is_pullback _ _),
  refine open_cover_of_is_iso
    ((pullback_symmetry _ _).hom ≫ (limit.iso_limit_cone ⟨_, this⟩).inv ≫
      pullback.map _ _ _ _ (𝟙 _) (𝟙 _) (𝟙 _) _ _),
  { simpa only [category.comp_id, category.id_comp, ← pullback.condition] },
  { simp only [category.comp_id, category.id_comp] },
  apply_instance
end

/-- Given an open cover `{ Zᵢ }` of `Z`, then `X ×[Z] Y` is covered by `Xᵢ ×[Zᵢ] Yᵢ`, where
  `Xᵢ = X ×[Z] Zᵢ` and `Yᵢ = Y ×[Z] Zᵢ` is the preimage of `Zᵢ` in `X` and `Y`. -/
@[simps J obj map]
def open_cover_of_base (𝒰 : open_cover Z) (f : X ⟶ Z) (g : Y ⟶ Z) : open_cover (pullback f g) :=
begin
  apply (open_cover_of_base' 𝒰 f g).copy
    𝒰.J
    (λ i, pullback (pullback.snd : pullback f (𝒰.map i) ⟶ _)
      (pullback.snd : pullback g (𝒰.map i) ⟶ _))
    (λ i, pullback.map _ _ _ _ pullback.fst pullback.fst (𝒰.map i)
      pullback.condition.symm pullback.condition.symm)
    ((equiv.prod_punit 𝒰.J).symm.trans (equiv.sigma_equiv_prod 𝒰.J punit).symm)
    (λ _, iso.refl _),
  intro i,
  change _ = _ ≫ _ ≫ _,
  refine eq.trans _ (category.id_comp _).symm,
  apply pullback.hom_ext; simp only [category.comp_id, open_cover_of_left_map,
    open_cover.pullback_cover_map, pullback_cone.mk_π_app_left, open_cover_of_is_iso_map,
    limit.iso_limit_cone_inv_π_assoc, category.assoc, pullback.lift_fst_assoc,
    pullback_symmetry_hom_comp_snd_assoc, pullback.lift_fst, limit.iso_limit_cone_inv_π,
    pullback_cone.mk_π_app_right, pullback_symmetry_hom_comp_fst_assoc, pullback.lift_snd],
end

end pullback

end algebraic_geometry.Scheme

namespace algebraic_geometry

instance {X Y S X' Y' S' : Scheme} (f : X ⟶ S) (g : Y ⟶ S) (f' : X' ⟶ S')
  (g' : Y' ⟶ S') (i₁ : X ⟶ X') (i₂ : Y ⟶ Y') (i₃ : S ⟶ S') (e₁ : f ≫ i₃ = i₁ ≫ f')
  (e₂ : g ≫ i₃ = i₂ ≫ g') [is_open_immersion i₁] [is_open_immersion i₂] [mono i₃] :
  is_open_immersion (pullback.map f g f' g' i₁ i₂ i₃ e₁ e₂) :=
begin
  rw pullback_map_eq_pullback_fst_fst_iso_inv,
  apply_instance
end

end algebraic_geometry


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

import category_theory.functor

universes v u -- declare the `v`'s first; see `category_theory.category` for an explanation

namespace category_theory

structure iso {C : Type u} [category.{v} C] (X Y : C) :=
(hom : X ⟶ Y)
(inv : Y ⟶ X)
(hom_inv_id' : hom ≫ inv = 𝟙 X . obviously)
(inv_hom_id' : inv ≫ hom = 𝟙 Y . obviously)

restate_axiom iso.hom_inv_id'
restate_axiom iso.inv_hom_id'
attribute [simp] iso.hom_inv_id iso.inv_hom_id

infixr ` ≅ `:10  := iso             -- type as \cong or \iso

variables {C : Type u} [𝒞 : category.{v} C]
include 𝒞
variables {X Y Z : C}

namespace iso

@[simp] lemma hom_inv_id_assoc (α : X ≅ Y) (f : X ⟶ Z) : α.hom ≫ α.inv ≫ f = f :=
by rw [←category.assoc, α.hom_inv_id, category.id_comp]

@[simp] lemma inv_hom_id_assoc (α : X ≅ Y) (f : Y ⟶ Z) : α.inv ≫ α.hom ≫ f = f :=
by rw [←category.assoc, α.inv_hom_id, category.id_comp]

@[extensionality] lemma ext (α β : X ≅ Y) (w : α.hom = β.hom) : α = β :=
suffices α.inv = β.inv, by cases α; cases β; cc,
calc α.inv
    = α.inv ≫ (β.hom ≫ β.inv) : by rw [iso.hom_inv_id, category.comp_id]
... = (α.inv ≫ α.hom) ≫ β.inv : by rw [category.assoc, ←w]
... = β.inv                   : by rw [iso.inv_hom_id, category.id_comp]

@[symm] def symm (I : X ≅ Y) : Y ≅ X :=
{ hom := I.inv,
  inv := I.hom,
  hom_inv_id' := I.inv_hom_id',
  inv_hom_id' := I.hom_inv_id' }

@[simp] lemma symm_hom (α : X ≅ Y) : α.symm.hom = α.inv := rfl
@[simp] lemma symm_inv (α : X ≅ Y) : α.symm.inv = α.hom := rfl

@[refl] def refl (X : C) : X ≅ X :=
{ hom := 𝟙 X,
  inv := 𝟙 X }

@[simp] lemma refl_hom (X : C) : (iso.refl X).hom = 𝟙 X := rfl
@[simp] lemma refl_inv (X : C) : (iso.refl X).inv = 𝟙 X := rfl

@[trans] def trans (α : X ≅ Y) (β : Y ≅ Z) : X ≅ Z :=
{ hom := α.hom ≫ β.hom,
  inv := β.inv ≫ α.inv }

infixr ` ≪≫ `:80 := iso.trans -- type as `\ll \gg`.

@[simp] lemma trans_hom (α : X ≅ Y) (β : Y ≅ Z) : (α ≪≫ β).hom = α.hom ≫ β.hom := rfl
@[simp] lemma trans_inv (α : X ≅ Y) (β : Y ≅ Z) : (α ≪≫ β).inv = β.inv ≫ α.inv := rfl

@[simp] lemma refl_symm (X : C) : (iso.refl X).hom = 𝟙 X := rfl
@[simp] lemma trans_symm (α : X ≅ Y) (β : Y ≅ Z) : (α ≪≫ β).inv = β.inv ≫ α.inv := rfl

lemma inv_comp_eq (α : X ≅ Y) {f : X ⟶ Z} {g : Y ⟶ Z} : α.inv ≫ f = g ↔ f = α.hom ≫ g :=
⟨λ H, by simp [H.symm], λ H, by simp [H]⟩

lemma eq_inv_comp (α : X ≅ Y) {f : X ⟶ Z} {g : Y ⟶ Z} : g = α.inv ≫ f ↔ α.hom ≫ g = f :=
(inv_comp_eq α.symm).symm

lemma comp_inv_eq (α : X ≅ Y) {f : Z ⟶ Y} {g : Z ⟶ X} : f ≫ α.inv = g ↔ f = g ≫ α.hom :=
⟨λ H, by simp [H.symm], λ H, by simp [H]⟩

lemma eq_comp_inv (α : X ≅ Y) {f : Z ⟶ Y} {g : Z ⟶ X} : g = f ≫ α.inv ↔ g ≫ α.hom = f :=
(comp_inv_eq α.symm).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 (f : X ⟶ Y) :=
(inv : Y ⟶ X)
(hom_inv_id' : f ≫ inv = 𝟙 X . obviously)
(inv_hom_id' : inv ≫ f = 𝟙 Y . obviously)

def inv (f : X ⟶ Y) [is_iso f] := is_iso.inv f

namespace is_iso

@[simp] lemma hom_inv_id (f : X ⟶ Y) [is_iso f] : f ≫ category_theory.inv f = 𝟙 X :=
is_iso.hom_inv_id' f
@[simp] lemma inv_hom_id (f : X ⟶ Y) [is_iso f] : category_theory.inv f ≫ f = 𝟙 Y :=
is_iso.inv_hom_id' f

@[simp] lemma hom_inv_id_assoc {Z} (f : X ⟶ Y) [is_iso f] (g : X ⟶ Z) : f ≫ category_theory.inv f ≫ g = g :=
by rw [←category.assoc, hom_inv_id, category.id_comp]
@[simp] lemma inv_hom_id_assoc {Z} (f : X ⟶ Y) [is_iso f] (g : Y ⟶ Z) : category_theory.inv f ≫ f ≫ g = g :=
by rw [←category.assoc, inv_hom_id, category.id_comp]

instance (X : C) : is_iso (𝟙 X) :=
{ inv := 𝟙 X }

instance of_iso (f : X ≅ Y) : is_iso f.hom :=
{ inv := f.inv }
instance of_iso_inverse (f : X ≅ Y) : is_iso f.inv :=
{ inv := f.hom }

end is_iso

def as_iso (f : X ⟶ Y) [is_iso f] : X ≅ Y :=
{ hom := f, inv := inv f }

@[simp] lemma as_iso_hom (f : X ⟶ Y) [is_iso f] : (as_iso f).hom = f := rfl
@[simp] lemma as_iso_inv (f : X ⟶ Y) [is_iso f] : (as_iso f).inv = inv f := rfl

instance (f : X ⟶ Y) : subsingleton (is_iso f) :=
⟨λ a b,
 suffices a.inv = b.inv, by cases a; cases b; congr; exact this,
 show (@as_iso C _ _ _ f a).inv = (@as_iso C _ _ _ f b).inv,
 by congr' 1; ext; refl⟩

namespace functor

universes u₁ v₁ u₂ v₂
variables {D : Type u₂}

variables [𝒟 : category.{v₂} D]
include 𝒟

def on_iso (F : C ⥤ D) {X Y : C} (i : X ≅ Y) : F.obj X ≅ F.obj Y :=
{ hom := F.map i.hom,
  inv := F.map i.inv,
  hom_inv_id' := by rw [←map_comp, iso.hom_inv_id, ←map_id],
  inv_hom_id' := by rw [←map_comp, iso.inv_hom_id, ←map_id] }

@[simp] lemma on_iso_hom (F : C ⥤ D) {X Y : C} (i : X ≅ Y) : (F.on_iso i).hom = F.map i.hom := rfl
@[simp] lemma on_iso_inv (F : C ⥤ D) {X Y : C} (i : X ≅ Y) : (F.on_iso i).inv = F.map i.inv := rfl

instance (F : C ⥤ D) (f : X ⟶ Y) [is_iso f] : is_iso (F.map f) :=
{ inv := F.map (inv f),
  hom_inv_id' := by rw [← F.map_comp, is_iso.hom_inv_id, map_id],
  inv_hom_id' := by rw [← F.map_comp, is_iso.inv_hom_id, map_id] }

end functor

instance epi_of_iso  (f : X ⟶ Y) [is_iso f] : epi f  :=
{ left_cancellation := begin
                         -- This is an interesting test case for better rewrite automation.
                         intros,
                         rw [←category.id_comp C g, ←category.id_comp C h],
                         rw [← is_iso.inv_hom_id f],
                         rw [category.assoc, w, category.assoc],
                       end }
instance mono_of_iso (f : X ⟶ Y) [is_iso f] : mono f :=
{ right_cancellation := begin
                         intros,
                         rw [←category.comp_id C g, ←category.comp_id C h],
                         rw [← is_iso.hom_inv_id f],
                         rw [←category.assoc, w, ←category.assoc]
                       end }

def Aut (X : C) := X ≅ X

attribute [extensionality Aut] iso.ext

instance {X : C} : group (Aut X) :=
by refine { one := iso.refl X,
            inv := iso.symm,
            mul := iso.trans, .. } ; obviously

end category_theory


#check 1.2
#check 1.2 + 2.3
#check 1.0
#eval 1.2 + 2.3
#check 1.
#check 3.1416

theorem ex : 31416e-4 = 3.1416 :=
  rfl

#eval 3.4e-100 * 1e98

#eval 12.3e90 * 1E-90
#eval 3.00e-100 * 1e100
#eval 3.00e-100 * 1.e100
#eval 3.00e-100 * 1.0e100

#eval 1e10
#eval 1e50
#eval 1e80
#eval 1e100
#eval 1e200
#eval 1e300
#eval 1e400

#eval 1 / 1e-1
#eval 1 / 1e-2
#eval 1 / 1e-10
#eval 1 / 1e-100
#eval 1 / 1e-200
#eval 1 / 1e-400


import algebra.ring data.hash_map data.num.lemmas

instance : has_coe ℕ+ ℕ := ⟨λn, n.1⟩

theorem to_bool_iff (p : Prop) [d : decidable p] : to_bool p ↔ p :=
match d with
| is_true hp := ⟨λh, hp, λ_, rfl⟩
| is_false hnp := ⟨λh, bool.no_confusion h, λhp, absurd hp hnp⟩
end

theorem to_bool_true {p : Prop} [decidable p] : p → to_bool p := (to_bool_iff p).2

theorem to_bool_tt {p : Prop} [decidable p] : p → to_bool p = tt := to_bool_true

theorem of_to_bool_true {p : Prop} [decidable p] : to_bool p → p := (to_bool_iff p).1

theorem bool_iff_false {b : bool} : ¬ b ↔ b = ff := by cases b; exact dec_trivial

theorem bool_eq_false {b : bool} : ¬ b → b = ff := bool_iff_false.1

theorem to_bool_ff_iff (p : Prop) [decidable p] : to_bool p = ff ↔ ¬p :=
bool_iff_false.symm.trans (not_congr (to_bool_iff _))

theorem to_bool_ff {p : Prop} [decidable p] : ¬p → to_bool p = ff := (to_bool_ff_iff p).2

theorem of_to_bool_ff {p : Prop} [decidable p] : to_bool p = ff → ¬p := (to_bool_ff_iff p).1

theorem to_bool_congr {p q : Prop} [decidable p] [decidable q] (h : p ↔ q) : to_bool p = to_bool q :=
begin
  ginduction to_bool q with h',
  exact to_bool_ff (mt h.1 $ of_to_bool_ff h'),
  exact to_bool_true (h.2 $ of_to_bool_true h')
end

theorem bor_iff (a b : bool) : a || b ↔ a ∨ b :=
by cases a; cases b; exact dec_trivial

theorem band_iff (a b : bool) : a && b ↔ a ∧ b :=
by cases a; cases b; exact dec_trivial

theorem bxor_iff (a b : bool) : bxor a b ↔ xor a b :=
by cases a; cases b; exact dec_trivial

lemma pos_num.lor_self (x y) : pos_num.lor (pos_num.lor x y) y = pos_num.lor x y := sorry

lemma nat.test_bit_size {x} : 0 < x → nat.test_bit x (nat.size x - 1) := sorry

lemma nat.test_bit_size_lt {x i} : nat.test_bit x i → i < nat.size x := sorry

lemma nat.lt_pow_size (x) : x < 2^nat.size x := sorry

lemma nat.size_le_of_lt_pow {x n} : x < 2^n → nat.size x ≤ n := sorry

lemma nat.size_monotone {x y} : x ≤ y → nat.size x ≤ nat.size y := sorry

def powerseries : list ℕ → ℕ
| [] := 0
| (x :: xs) := 2^x + powerseries xs

lemma one_bits_powerseries (x) : powerseries (num.one_bits x) = x :=
sorry

lemma mem_one_bits (x i) : i ∈ num.one_bits x ↔ num.test_bit x i :=
sorry

def int.quot : ℤ → ℤ → ℤ
| (m : ℕ) (n : ℕ) := (m / n : ℕ)
| (m : ℕ) -[1+ n] := -(m / nat.succ n : ℕ)
| -[1+ m] (n : ℕ) := -(nat.succ m / n : ℕ)
| -[1+ m] -[1+ n] := (nat.succ m / nat.succ n : ℕ)

def int.rem : ℤ → ℤ → ℤ
| (m : ℕ) (n : ℕ) := (m % n : ℕ)
| (m : ℕ) -[1+ n] := (m % nat.succ n : ℕ)
| -[1+ m] (n : ℕ) := -(nat.succ m % n : ℕ)
| -[1+ m] -[1+ n] := -(nat.succ m % nat.succ n : ℕ)

def int.div : ℤ → ℤ → ℤ
| (m : ℕ) (n : ℕ) := (m / n : ℕ)
| (m : ℕ) -[1+ n] := -(m / nat.succ n : ℕ)
| -[1+ m] (n : ℕ) := -(nat.succ m / n : ℕ)
| -[1+ m] -[1+ n] := (nat.succ m / nat.succ n : ℕ)

def int.nat_mod : ℤ → ℕ → ℕ
| (m : ℕ) n := m % n
| -[1+ m] n := n - nat.succ (m % n)

def int.mod : ℤ → ℤ → ℤ
| m (n : ℕ) := int.nat_mod m n
| m -[1+ n] := int.nat_mod (-m) (nat.succ n)

instance : has_div ℤ := ⟨int.div⟩
instance : has_mod ℤ := ⟨int.mod⟩

def int.all_nat (p : ℕ → Prop) : ℤ → Prop
| (n : ℕ) := p n
| -[1+ n] := true

def int.ex_nat (p : ℕ → Prop) : ℤ → Prop
| (n : ℕ) := p n
| -[1+ n] := false

def int.exists_of_ex_nat {p : ℕ → Prop} : ∀ (x : ℤ), x.ex_nat p → ∃ n, ↑n = x ∧ p n
| (n : ℕ) h := ⟨n, rfl, h⟩
| -[1+ n] h := false.elim h

def int.all_nat_of_forall {p : ℕ → Prop} : ∀ (x : ℤ), (∀ n, ↑n = x → p n) → x.all_nat p
| (n : ℕ) h := h n rfl
| -[1+ n] h := trivial

lemma int.shiftr_div_two_p (x) (n : ℕ) : int.shiftr x n = x / 2^n := sorry

lemma int.testbit_mod_two_p (n x i) : int.test_bit (x % 2^n) i =
  if i < n then int.test_bit x i else ff := sorry

theorem Ztestbit_two_p_m1 (n i) : int.test_bit (2^n - 1) i = to_bool (i < n) := sorry

def align (n : ℕ) (amount : ℕ) :=
  ((n + amount - 1) / amount) * amount.

lemma align_le (x y) (h : y > 0) : x ≤ align x y := sorry

lemma align_dvd (x y : ℤ) (h : y > 0) : y ∣ align x y := sorry

inductive option.rel {A B} (R: A → B → Prop) : option A → option B → Prop
| none : option.rel none none
| some (x y) : R x y → option.rel (some x) (some y)

inductive list.forall2 {A B} (P : A → B → Prop) : list A → list B → Prop
| nil : list.forall2 [] []
| cons {a1 al b1 bl} : P a1 b1 →
  list.forall2 al bl →
  list.forall2 (a1 :: al) (b1 :: bl)

theorem list.forall2.imp {A} {P Q : A → A → Prop} (H : ∀ x y, P x y → Q x y)
  {l1 l2} (al : list.forall2 P l1 l2) : list.forall2 Q l1 l2 :=
by induction al; constructor; try {assumption}; apply H; assumption

theorem list.forall2.iff {A} {P Q : A → A → Prop} (H : ∀ x y, P x y ↔ Q x y)
  {l1 l2} : list.forall2 P l1 l2 ↔ list.forall2 Q l1 l2 :=
⟨λh, h.imp (λx y, (H x y).1), λh, h.imp (λx y, (H x y).2)⟩

theorem list.forall2.trans {A} {P : A → A → Prop} (t : transitive P) : transitive (list.forall2 P) :=
begin
  intros x y z h12, revert z,
  induction h12 with a1 l1 a2 l2 p12 al12 IH; intros z h23,
  assumption,
  cases h23 with _ _ a3 l3 p23 al23,
  constructor,
  exact t p12 p23,
  exact IH al23
end

/- * Comparisons -/

inductive comparison : Type
| Ceq : comparison    /- same -/
| Cne : comparison    /- different -/
| Clt : comparison    /- less than -/
| Cle : comparison    /- less than or equal -/
| Cgt : comparison    /- greater than -/
| Cge : comparison    /- greater than or equal -/
export comparison

def negate_comparison : comparison → comparison
| Ceq := Cne
| Cne := Ceq
| Clt := Cge
| Cle := Cgt
| Cgt := Cle
| Cge := Clt

def swap_comparison : comparison → comparison
| Ceq := Ceq
| Cne := Cne
| Clt := Cgt
| Cle := Cge
| Cgt := Clt
| Cge := Cle

def {u} sorry' {α : Sort u} : α := sorry

def encode_int : ℤ → pos_num
| 0 := 1
| (nat.succ n) := bit0 $ pos_num.of_nat_succ n
| -[1+ n] := bit1 $ pos_num.of_nat_succ n

@[class] inductive semidecidable (p : Prop) : Type
| fail {} : semidecidable
| success : p → semidecidable

namespace semidecidable

instance of_decidable (p : Prop) [decidable p] : semidecidable p :=
if h : p then semidecidable.success h else semidecidable.fail

instance and (p q : Prop) : ∀ [semidecidable p] [semidecidable q], semidecidable (p ∧ q)
| fail _ := fail
| _ fail := fail
| (success hp) (success hq) := success ⟨hp, hq⟩

instance or (p q : Prop) : ∀ [semidecidable p] [semidecidable q], semidecidable (p ∨ q)
| (success hp) _ := success (_root_.or.inl hp)
| _ (success hq) := success (_root_.or.inr hq)
| fail fail := fail

def of_imp {p q : Prop} (h : p → q) : ∀ [semidecidable p], semidecidable q
| fail := fail
| (success hp) := success (h hp)

def bind (p) {q} : ∀ [semidecidable p], (p → semidecidable q) → semidecidable q
| (success hp) h := h hp
| fail _ := fail

def bind_opt {A} {C : option A → Prop} :
  ∀ (o : option A), (∀ x, semidecidable (C (some x))) → semidecidable (C o)
| (some x) h := h x
| none     _ := fail

instance imp (p q : Prop) [decidable p] [h : p → semidecidable q] : semidecidable (p → q) :=
if hp : p then @of_imp _ (p → q) (λx _, x) (h hp) else success (λhn, absurd hn hp)

end semidecidable


import Mathbin.Data.Finsupp.Basic

section

inductive Vars : Type
  | α : Vars
  | β : Vars
  | γ : Vars
  | δ : Vars

instance : DecidableEq Vars :=
  fun a b => match a, b with
   | .α, .α => isTrue rfl
   | .α, .β => isFalse (fun h => Vars.noConfusion h)
   | .α, .γ => isFalse (fun h => Vars.noConfusion h)
   | .α, .δ => isFalse (fun h => Vars.noConfusion h)
   | .β, .α => isFalse (fun h => Vars.noConfusion h)
   | .β, .β => isTrue rfl
   | .β, .γ => isFalse (fun h => Vars.noConfusion h)
   | .β, .δ => isFalse (fun h => Vars.noConfusion h)
   | .δ, .α => isFalse (fun h => Vars.noConfusion h)
   | .δ, .β => isFalse (fun h => Vars.noConfusion h)
   | .δ, .γ => isFalse (fun h => Vars.noConfusion h)
   | .δ, .δ => isTrue rfl
   | .γ, .δ => isFalse (fun h => Vars.noConfusion h)
   | .γ, .γ => isTrue rfl
   | .γ, .β => isFalse (fun h => Vars.noConfusion h)
   | .γ, .α => isFalse (fun h => Vars.noConfusion h)

lemma finsupp_vars_eq_ext (f g : Vars →₀ ℕ) : (f = g) ↔
  (f Vars.α = g Vars.α ∧ f Vars.β = g Vars.β ∧ f Vars.γ = g Vars.γ ∧ f Vars.δ = g Vars.δ) := by
  rw [Finsupp.ext_iff]
  apply Iff.intro
  · intro h
    apply And.intro
    exact h Vars.α
    apply And.intro
    exact h Vars.β
    apply And.intro
    exact h Vars.γ
    exact h Vars.δ
  · intro h
    intro a
    induction a
    apply And.left h
    apply And.left (And.right h)
    apply And.left (And.right (And.right h))
    apply And.right (And.right (And.right h))


/-
Copyright (c) 2020 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.ring_theory.noetherian
import Mathlib.ring_theory.ideal.operations
import Mathlib.ring_theory.algebra_tower
import Mathlib.PostPort

universes u_1 u_4 u_2 u_5 u_3

namespace Mathlib

/-!
# Finiteness conditions in commutative algebra

In this file we define several notions of finiteness that are common in commutative algebra.

## Main declarations

- `module.finite`, `algebra.finite`, `ring_hom.finite`, `alg_hom.finite`
  all of these express that some object is finitely generated *as module* over some base ring.
- `algebra.finite_type`, `ring_hom.finite_type`, `alg_hom.finite_type`
  all of these express that some object is finitely generated *as algebra* over some base ring.

-/

/-- A module over a commutative ring is `finite` if it is finitely generated as a module. -/
def module.finite (R : Type u_1) (M : Type u_4) [comm_ring R] [add_comm_group M] [module R M] :=
  submodule.fg ⊤

/-- An algebra over a commutative ring is of `finite_type` if it is finitely generated
over the base ring as algebra. -/
def algebra.finite_type (R : Type u_1) (A : Type u_2) [comm_ring R] [comm_ring A] [algebra R A] :=
  subalgebra.fg ⊤

/-- An algebra over a commutative ring is `finitely_presented` if it is the quotient of a
polynomial ring in `n` variables by a finitely generated ideal. -/
def algebra.finitely_presented (R : Type u_1) (A : Type u_2) [comm_ring R] [comm_ring A]
    [algebra R A] :=
  ∃ (n : ℕ),
    ∃ (f : alg_hom R (mv_polynomial (fin n) R) A),
      function.surjective ⇑f ∧ submodule.fg (ring_hom.ker (alg_hom.to_ring_hom f))

namespace module

theorem finite_def {R : Type u_1} {M : Type u_4} [comm_ring R] [add_comm_group M] [module R M] :
    finite R M ↔ submodule.fg ⊤ :=
  iff.rfl

protected instance is_noetherian.finite (R : Type u_1) (M : Type u_4) [comm_ring R]
    [add_comm_group M] [module R M] [is_noetherian R M] : finite R M :=
  is_noetherian.noetherian ⊤

namespace finite

theorem of_surjective {R : Type u_1} {M : Type u_4} {N : Type u_5} [comm_ring R] [add_comm_group M]
    [module R M] [add_comm_group N] [module R N] [hM : finite R M] (f : linear_map R M N)
    (hf : function.surjective ⇑f) : finite R N :=
  sorry

theorem of_injective {R : Type u_1} {M : Type u_4} {N : Type u_5} [comm_ring R] [add_comm_group M]
    [module R M] [add_comm_group N] [module R N] [is_noetherian R N] (f : linear_map R M N)
    (hf : function.injective ⇑f) : finite R M :=
  fg_of_injective f (iff.mpr linear_map.ker_eq_bot hf)

protected instance self (R : Type u_1) [comm_ring R] : finite R R :=
  Exists.intro (singleton 1)
    (eq.mpr
      (id
        ((fun (a a_1 : submodule R R) (e_1 : a = a_1) (ᾰ ᾰ_1 : submodule R R) (e_2 : ᾰ = ᾰ_1) =>
            congr (congr_arg Eq e_1) e_2)
          (submodule.span R ↑(singleton 1)) (submodule.span R (singleton 1))
          ((fun (s s_1 : set R) (e_2 : s = s_1) => congr_arg (submodule.span R) e_2)
            (↑(singleton 1)) (singleton 1) (finset.coe_singleton 1))
          ⊤ ⊤ (Eq.refl ⊤)))
      (eq.mp (Eq.refl (ideal.span 1 = ⊤)) ideal.span_singleton_one))

protected instance prod {R : Type u_1} {M : Type u_4} {N : Type u_5} [comm_ring R]
    [add_comm_group M] [module R M] [add_comm_group N] [module R N] [hM : finite R M]
    [hN : finite R N] : finite R (M × N) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (finite R (M × N))) (equations._eqn_1 R (M × N))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (submodule.fg ⊤)) (Eq.symm submodule.prod_top)))
      (submodule.fg_prod hM hN))

theorem equiv {R : Type u_1} {M : Type u_4} {N : Type u_5} [comm_ring R] [add_comm_group M]
    [module R M] [add_comm_group N] [module R N] [hM : finite R M] (e : linear_equiv R M N) :
    finite R N :=
  of_surjective (↑e) (linear_equiv.surjective e)

theorem trans {R : Type u_1} (A : Type u_2) (B : Type u_3) [comm_ring R] [comm_ring A] [algebra R A]
    [comm_ring B] [algebra R B] [algebra A B] [is_scalar_tower R A B] [hRA : finite R A]
    [hAB : finite A B] : finite R B :=
  sorry

protected instance finite_type {R : Type u_1} (A : Type u_2) [comm_ring R] [comm_ring A]
    [algebra R A] [hRA : finite R A] : algebra.finite_type R A :=
  subalgebra.fg_of_submodule_fg hRA

end finite

end module

namespace algebra

namespace finite_type

theorem self (R : Type u_1) [comm_ring R] : finite_type R R :=
  Exists.intro (singleton 1) (subsingleton.elim (adjoin R ↑(singleton 1)) ⊤)

protected theorem mv_polynomial (R : Type u_1) [comm_ring R] (ι : Type u_2) [fintype ι] :
    finite_type R (mv_polynomial ι R) :=
  sorry

theorem of_surjective {R : Type u_1} {A : Type u_2} {B : Type u_3} [comm_ring R] [comm_ring A]
    [algebra R A] [comm_ring B] [algebra R B] (hRA : finite_type R A) (f : alg_hom R A B)
    (hf : function.surjective ⇑f) : finite_type R B :=
  sorry

theorem equiv {R : Type u_1} {A : Type u_2} {B : Type u_3} [comm_ring R] [comm_ring A] [algebra R A]
    [comm_ring B] [algebra R B] (hRA : finite_type R A) (e : alg_equiv R A B) : finite_type R B :=
  of_surjective hRA (↑e) (alg_equiv.surjective e)

theorem trans {R : Type u_1} {A : Type u_2} {B : Type u_3} [comm_ring R] [comm_ring A] [algebra R A]
    [comm_ring B] [algebra R B] [algebra A B] [is_scalar_tower R A B] (hRA : finite_type R A)
    (hAB : finite_type A B) : finite_type R B :=
  fg_trans' hRA hAB

/-- An algebra is finitely generated if and only if it is a quotient
of a polynomial ring whose variables are indexed by a finset. -/
theorem iff_quotient_mv_polynomial {R : Type u_1} {A : Type u_2} [comm_ring R] [comm_ring A]
    [algebra R A] :
    finite_type R A ↔
        ∃ (s : finset A),
          ∃ (f : alg_hom R (mv_polynomial (Subtype fun (x : A) => x ∈ s) R) A),
            function.surjective ⇑f :=
  sorry

/-- An algebra is finitely generated if and only if it is a quotient
of a polynomial ring whose variables are indexed by a fintype. -/
theorem iff_quotient_mv_polynomial' {R : Type u_1} {A : Type u_2} [comm_ring R] [comm_ring A]
    [algebra R A] :
    finite_type R A ↔
        ∃ (ι : Type u_2),
          Exists (∃ (f : alg_hom R (mv_polynomial ι R) A), function.surjective ⇑f) :=
  sorry

/-- An algebra is finitely generated if and only if it is a quotient of a polynomial ring in `n`
variables. -/
theorem iff_quotient_mv_polynomial'' {R : Type u_1} {A : Type u_2} [comm_ring R] [comm_ring A]
    [algebra R A] :
    finite_type R A ↔
        ∃ (n : ℕ), ∃ (f : alg_hom R (mv_polynomial (fin n) R) A), function.surjective ⇑f :=
  sorry

/-- A finitely presented algebra is of finite type. -/
theorem of_finitely_presented {R : Type u_1} {A : Type u_2} [comm_ring R] [comm_ring A]
    [algebra R A] : finitely_presented R A → finite_type R A :=
  sorry

end finite_type

namespace finitely_presented

/-- If `e : A ≃ₐ[R] B` and `A` is finitely presented, then so is `B`. -/
theorem equiv (R : Type u_1) (A : Type u_2) (B : Type u_3) [comm_ring R] [comm_ring A] [algebra R A]
    [comm_ring B] [algebra R B] (hfp : finitely_presented R A) (e : alg_equiv R A B) :
    finitely_presented R B :=
  sorry

/-- The ring of polynomials in finitely many variables is finitely presented. -/
theorem mv_polynomial (R : Type u_1) [comm_ring R] (ι : Type u_2) [fintype ι] :
    finitely_presented R (mv_polynomial ι R) :=
  sorry

/-- `R` is finitely presented as `R`-algebra. -/
theorem self (R : Type u_1) [comm_ring R] : finitely_presented R R :=
  let hempty : finitely_presented R (mv_polynomial pempty R) := mv_polynomial R pempty;
  equiv R (mv_polynomial pempty R) R hempty (mv_polynomial.pempty_alg_equiv R)

end finitely_presented

end algebra

namespace ring_hom

/-- A ring morphism `A →+* B` is `finite` if `B` is finitely generated as `A`-module. -/
def finite {A : Type u_1} {B : Type u_2} [comm_ring A] [comm_ring B] (f : A →+* B) :=
  let _inst : algebra A B := to_algebra f;
  module.finite A B

/-- A ring morphism `A →+* B` is of `finite_type` if `B` is finitely generated as `A`-algebra. -/
def finite_type {A : Type u_1} {B : Type u_2} [comm_ring A] [comm_ring B] (f : A →+* B) :=
  algebra.finite_type A B

namespace finite

theorem id (A : Type u_1) [comm_ring A] : finite (id A) := module.finite.self A

theorem of_surjective {A : Type u_1} {B : Type u_2} [comm_ring A] [comm_ring B] (f : A →+* B)
    (hf : function.surjective ⇑f) : finite f :=
  let _inst : algebra A B := to_algebra f;
  module.finite.of_surjective (alg_hom.to_linear_map (algebra.of_id A B)) hf

theorem comp {A : Type u_1} {B : Type u_2} {C : Type u_3} [comm_ring A] [comm_ring B] [comm_ring C]
    {g : B →+* C} {f : A →+* B} (hg : finite g) (hf : finite f) : finite (comp g f) :=
  module.finite.trans B C

theorem finite_type {A : Type u_1} {B : Type u_2} [comm_ring A] [comm_ring B] {f : A →+* B}
    (hf : finite f) : finite_type f :=
  module.finite.finite_type B

end finite

namespace finite_type

theorem id (A : Type u_1) [comm_ring A] : finite_type (id A) := algebra.finite_type.self A

theorem comp_surjective {A : Type u_1} {B : Type u_2} {C : Type u_3} [comm_ring A] [comm_ring B]
    [comm_ring C] {f : A →+* B} {g : B →+* C} (hf : finite_type f) (hg : function.surjective ⇑g) :
    finite_type (comp g f) :=
  algebra.finite_type.of_surjective hf
    (alg_hom.mk (⇑g) (map_one' g) (map_mul' g) (map_zero' g) (map_add' g) fun (a : A) => rfl) hg

theorem of_surjective {A : Type u_1} {B : Type u_2} [comm_ring A] [comm_ring B] (f : A →+* B)
    (hf : function.surjective ⇑f) : finite_type f :=
  eq.mpr (id (Eq._oldrec (Eq.refl (finite_type f)) (Eq.symm (comp_id f))))
    (comp_surjective (id A) hf)

theorem comp {A : Type u_1} {B : Type u_2} {C : Type u_3} [comm_ring A] [comm_ring B] [comm_ring C]
    {g : B →+* C} {f : A →+* B} (hg : finite_type g) (hf : finite_type f) :
    finite_type (comp g f) :=
  algebra.finite_type.trans hf hg

end finite_type

end ring_hom

namespace alg_hom

/-- An algebra morphism `A →ₐ[R] B` is finite if it is finite as ring morphism.
In other words, if `B` is finitely generated as `A`-module. -/
def finite {R : Type u_1} {A : Type u_2} {B : Type u_3} [comm_ring R] [comm_ring A] [comm_ring B]
    [algebra R A] [algebra R B] (f : alg_hom R A B) :=
  ring_hom.finite (to_ring_hom f)

/-- An algebra morphism `A →ₐ[R] B` is of `finite_type` if it is of finite type as ring morphism.
In other words, if `B` is finitely generated as `A`-algebra. -/
def finite_type {R : Type u_1} {A : Type u_2} {B : Type u_3} [comm_ring R] [comm_ring A]
    [comm_ring B] [algebra R A] [algebra R B] (f : alg_hom R A B) :=
  ring_hom.finite_type (to_ring_hom f)

namespace finite

theorem id (R : Type u_1) (A : Type u_2) [comm_ring R] [comm_ring A] [algebra R A] :
    finite (alg_hom.id R A) :=
  ring_hom.finite.id A

theorem comp {R : Type u_1} {A : Type u_2} {B : Type u_3} {C : Type u_4} [comm_ring R] [comm_ring A]
    [comm_ring B] [comm_ring C] [algebra R A] [algebra R B] [algebra R C] {g : alg_hom R B C}
    {f : alg_hom R A B} (hg : finite g) (hf : finite f) : finite (comp g f) :=
  ring_hom.finite.comp hg hf

theorem of_surjective {R : Type u_1} {A : Type u_2} {B : Type u_3} [comm_ring R] [comm_ring A]
    [comm_ring B] [algebra R A] [algebra R B] (f : alg_hom R A B) (hf : function.surjective ⇑f) :
    finite f :=
  ring_hom.finite.of_surjective (↑f) hf

theorem finite_type {R : Type u_1} {A : Type u_2} {B : Type u_3} [comm_ring R] [comm_ring A]
    [comm_ring B] [algebra R A] [algebra R B] {f : alg_hom R A B} (hf : finite f) : finite_type f :=
  ring_hom.finite.finite_type hf

end finite

namespace finite_type

theorem id (R : Type u_1) (A : Type u_2) [comm_ring R] [comm_ring A] [algebra R A] :
    finite_type (alg_hom.id R A) :=
  ring_hom.finite_type.id A

theorem comp {R : Type u_1} {A : Type u_2} {B : Type u_3} {C : Type u_4} [comm_ring R] [comm_ring A]
    [comm_ring B] [comm_ring C] [algebra R A] [algebra R B] [algebra R C] {g : alg_hom R B C}
    {f : alg_hom R A B} (hg : finite_type g) (hf : finite_type f) : finite_type (comp g f) :=
  ring_hom.finite_type.comp hg hf

theorem comp_surjective {R : Type u_1} {A : Type u_2} {B : Type u_3} {C : Type u_4} [comm_ring R]
    [comm_ring A] [comm_ring B] [comm_ring C] [algebra R A] [algebra R B] [algebra R C]
    {f : alg_hom R A B} {g : alg_hom R B C} (hf : finite_type f) (hg : function.surjective ⇑g) :
    finite_type (comp g f) :=
  ring_hom.finite_type.comp_surjective hf hg

theorem of_surjective {R : Type u_1} {A : Type u_2} {B : Type u_3} [comm_ring R] [comm_ring A]
    [comm_ring B] [algebra R A] [algebra R B] (f : alg_hom R A B) (hf : function.surjective ⇑f) :
    finite_type f :=
  ring_hom.finite_type.of_surjective (↑f) hf

end Mathlib


/-
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.shift
import Mathlib.category_theory.concrete_category.default
import Mathlib.PostPort

universes v u l u_1

namespace Mathlib

/-!
# Differential objects in a category.

A differential object in a category with zero morphisms and a shift is
an object `X` equipped with
a morphism `d : X ⟶ X⟦1⟧`, such that `d^2 = 0`.

We build the category of differential objects, and some basic constructions
such as the forgetful functor, and zero morphisms and zero objects.
-/

namespace category_theory

/--
A differential object in a category with zero morphisms and a shift is
an object `X` equipped with
a morphism `d : X ⟶ X⟦1⟧`, such that `d^2 = 0`.
-/
structure differential_object (C : Type u) [category C] [limits.has_zero_morphisms C] [has_shift C]
where
  X : C
  d : X ⟶ functor.obj (equivalence.functor (shift C ^ 1)) X
  d_squared' : autoParam (d ≫ functor.map (equivalence.functor (shift C ^ 1)) d = 0)
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
    (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])

@[simp] theorem differential_object.d_squared {C : Type u} [category C] [limits.has_zero_morphisms C] [has_shift C] (c : differential_object C) : differential_object.d c ≫ functor.map (equivalence.functor (shift C)) (differential_object.d c) = 0 := sorry

namespace differential_object

/--
A morphism of differential objects is a morphism commuting with the differentials.
-/
structure hom {C : Type u} [category C] [limits.has_zero_morphisms C] [has_shift C] (X : differential_object C) (Y : differential_object C)
where
  f : X X ⟶ X Y
  comm' : autoParam (d X ≫ functor.map (equivalence.functor (shift C ^ 1)) f = f ≫ d Y)
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
    (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])

@[simp] theorem hom.comm {C : Type u} [category C] [limits.has_zero_morphisms C] [has_shift C] {X : differential_object C} {Y : differential_object C} (c : hom X Y) : d X ≫ functor.map (equivalence.functor (shift C)) (hom.f c) = hom.f c ≫ d Y := sorry

@[simp] theorem hom.comm_assoc {C : Type u} [category C] [limits.has_zero_morphisms C] [has_shift C] {X : differential_object C} {Y : differential_object C} (c : hom X Y) {X' : C} (f' : functor.obj (equivalence.functor (shift C)) (X Y) ⟶ X') : d X ≫ functor.map (equivalence.functor (shift C)) (hom.f c) ≫ f' = hom.f c ≫ d Y ≫ f' := sorry

namespace hom

/-- The identity morphism of a differential object. -/
@[simp] theorem id_f {C : Type u} [category C] [limits.has_zero_morphisms C] [has_shift C] (X : differential_object C) : f (id X) = 𝟙 :=
  Eq.refl (f (id X))

/-- The composition of morphisms of differential objects. -/
@[simp] theorem comp_f {C : Type u} [category C] [limits.has_zero_morphisms C] [has_shift C] {X : differential_object C} {Y : differential_object C} {Z : differential_object C} (f : hom X Y) (g : hom Y Z) : f (comp f g) = f f ≫ f g :=
  Eq.refl (f (comp f g))

end hom

protected instance category_of_differential_objects {C : Type u} [category C] [limits.has_zero_morphisms C] [has_shift C] : category (differential_object C) :=
  category.mk

@[simp] theorem id_f {C : Type u} [category C] [limits.has_zero_morphisms C] [has_shift C] (X : differential_object C) : hom.f 𝟙 = 𝟙 :=
  rfl

@[simp] theorem comp_f {C : Type u} [category C] [limits.has_zero_morphisms C] [has_shift C] {X : differential_object C} {Y : differential_object C} {Z : differential_object C} (f : X ⟶ Y) (g : Y ⟶ Z) : hom.f (f ≫ g) = hom.f f ≫ hom.f g :=
  rfl

/-- The forgetful functor taking a differential object to its underlying object. -/
def forget (C : Type u) [category C] [limits.has_zero_morphisms C] [has_shift C] : differential_object C ⥤ C :=
  functor.mk (fun (X : differential_object C) => X X) fun (X Y : differential_object C) (f : X ⟶ Y) => hom.f f

protected instance forget_faithful (C : Type u) [category C] [limits.has_zero_morphisms C] [has_shift C] : faithful (forget C) :=
  faithful.mk

protected instance has_zero_morphisms (C : Type u) [category C] [limits.has_zero_morphisms C] [has_shift C] : limits.has_zero_morphisms (differential_object C) :=
  limits.has_zero_morphisms.mk

@[simp] theorem zero_f {C : Type u} [category C] [limits.has_zero_morphisms C] [has_shift C] (P : differential_object C) (Q : differential_object C) : hom.f 0 = 0 :=
  rfl

end differential_object

end category_theory

namespace category_theory

namespace differential_object

protected instance has_zero_object (C : Type u) [category C] [limits.has_zero_object C] [limits.has_zero_morphisms C] [has_shift C] : limits.has_zero_object (differential_object C) :=
  limits.has_zero_object.mk (mk 0 0) (fun (X : differential_object C) => unique.mk { default := hom.mk 0 } sorry)
    fun (X : differential_object C) => unique.mk { default := hom.mk 0 } sorry

end differential_object

namespace differential_object

protected instance concrete_category_of_differential_objects (C : Type (u + 1)) [large_category C] [concrete_category C] [limits.has_zero_morphisms C] [has_shift C] : concrete_category (differential_object C) :=
  concrete_category.mk (forget C ⋙ forget C)

protected instance category_theory.has_forget₂ (C : Type (u + 1)) [large_category C] [concrete_category C] [limits.has_zero_morphisms C] [has_shift C] : has_forget₂ (differential_object C) C :=
  has_forget₂.mk (forget C)


/-
Copyright (c) 2018 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes

Definition of splitting fields, and definition of homomorphism into any field that splits
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.ring_theory.adjoin_root
import Mathlib.ring_theory.algebra_tower
import Mathlib.ring_theory.algebraic
import Mathlib.ring_theory.polynomial.default
import Mathlib.field_theory.minpoly
import Mathlib.linear_algebra.finite_dimensional
import Mathlib.tactic.field_simp
import Mathlib.PostPort

universes u v w u_1 u_2 u_3 l

namespace Mathlib

namespace polynomial

/-- a polynomial `splits` iff it is zero or all of its irreducible factors have `degree` 1 -/
def splits {α : Type u} {β : Type v} [field α] [field β] (i : α →+* β) (f : polynomial α) :=
  f = 0 ∨ ∀ {g : polynomial β}, irreducible g → g ∣ map i f → degree g = 1

@[simp] theorem splits_zero {α : Type u} {β : Type v} [field α] [field β] (i : α →+* β) : splits i 0 :=
  Or.inl rfl

@[simp] theorem splits_C {α : Type u} {β : Type v} [field α] [field β] (i : α →+* β) (a : α) : splits i (coe_fn C a) := sorry

theorem splits_of_degree_eq_one {α : Type u} {β : Type v} [field α] [field β] (i : α →+* β) {f : polynomial α} (hf : degree f = 1) : splits i f := sorry

theorem splits_of_degree_le_one {α : Type u} {β : Type v} [field α] [field β] (i : α →+* β) {f : polynomial α} (hf : degree f ≤ 1) : splits i f := sorry

theorem splits_mul {α : Type u} {β : Type v} [field α] [field β] (i : α →+* β) {f : polynomial α} {g : polynomial α} (hf : splits i f) (hg : splits i g) : splits i (f * g) := sorry

theorem splits_of_splits_mul {α : Type u} {β : Type v} [field α] [field β] (i : α →+* β) {f : polynomial α} {g : polynomial α} (hfg : f * g ≠ 0) (h : splits i (f * g)) : splits i f ∧ splits i g := sorry

theorem splits_of_splits_of_dvd {α : Type u} {β : Type v} [field α] [field β] (i : α →+* β) {f : polynomial α} {g : polynomial α} (hf0 : f ≠ 0) (hf : splits i f) (hgf : g ∣ f) : splits i g := sorry

theorem splits_of_splits_gcd_left {α : Type u} {β : Type v} [field α] [field β] (i : α →+* β) {f : polynomial α} {g : polynomial α} (hf0 : f ≠ 0) (hf : splits i f) : splits i (euclidean_domain.gcd f g) :=
  splits_of_splits_of_dvd i hf0 hf (euclidean_domain.gcd_dvd_left f g)

theorem splits_of_splits_gcd_right {α : Type u} {β : Type v} [field α] [field β] (i : α →+* β) {f : polynomial α} {g : polynomial α} (hg0 : g ≠ 0) (hg : splits i g) : splits i (euclidean_domain.gcd f g) :=
  splits_of_splits_of_dvd i hg0 hg (euclidean_domain.gcd_dvd_right f g)

theorem splits_map_iff {α : Type u} {β : Type v} {γ : Type w} [field α] [field β] [field γ] (i : α →+* β) (j : β →+* γ) {f : polynomial α} : splits j (map i f) ↔ splits (ring_hom.comp j i) f := sorry

theorem splits_one {α : Type u} {β : Type v} [field α] [field β] (i : α →+* β) : splits i 1 :=
  splits_C i 1

theorem splits_of_is_unit {α : Type u} {β : Type v} [field α] [field β] (i : α →+* β) {u : polynomial α} (hu : is_unit u) : splits i u :=
  splits_of_splits_of_dvd i one_ne_zero (splits_one i) (iff.mp is_unit_iff_dvd_one hu)

theorem splits_X_sub_C {α : Type u} {β : Type v} [field α] [field β] (i : α →+* β) {x : α} : splits i (X - coe_fn C x) :=
  splits_of_degree_eq_one i (degree_X_sub_C x)

theorem splits_X {α : Type u} {β : Type v} [field α] [field β] (i : α →+* β) : splits i X :=
  splits_of_degree_eq_one i degree_X

theorem splits_id_iff_splits {α : Type u} {β : Type v} [field α] [field β] (i : α →+* β) {f : polynomial α} : splits (ring_hom.id β) (map i f) ↔ splits i f := sorry

theorem splits_mul_iff {α : Type u} {β : Type v} [field α] [field β] (i : α →+* β) {f : polynomial α} {g : polynomial α} (hf : f ≠ 0) (hg : g ≠ 0) : splits i (f * g) ↔ splits i f ∧ splits i g := sorry

theorem splits_prod {α : Type u} {β : Type v} [field α] [field β] (i : α →+* β) {ι : Type w} {s : ι → polynomial α} {t : finset ι} : (∀ (j : ι), j ∈ t → splits i (s j)) → splits i (finset.prod t fun (x : ι) => s x) := sorry

theorem splits_prod_iff {α : Type u} {β : Type v} [field α] [field β] (i : α →+* β) {ι : Type w} {s : ι → polynomial α} {t : finset ι} : (∀ (j : ι), j ∈ t → s j ≠ 0) → (splits i (finset.prod t fun (x : ι) => s x) ↔ ∀ (j : ι), j ∈ t → splits i (s j)) := sorry

theorem degree_eq_one_of_irreducible_of_splits {β : Type v} [field β] {p : polynomial β} (h_nz : p ≠ 0) (hp : irreducible p) (hp_splits : splits (ring_hom.id β) p) : degree p = 1 := sorry

theorem exists_root_of_splits {α : Type u} {β : Type v} [field α] [field β] (i : α →+* β) {f : polynomial α} (hs : splits i f) (hf0 : degree f ≠ 0) : ∃ (x : β), eval₂ i x f = 0 := sorry

theorem exists_multiset_of_splits {α : Type u} {β : Type v} [field α] [field β] (i : α →+* β) {f : polynomial α} : splits i f →
  ∃ (s : multiset β),
    map i f = coe_fn C (coe_fn i (leading_coeff f)) * multiset.prod (multiset.map (fun (a : β) => X - coe_fn C a) s) := sorry

/-- Pick a root of a polynomial that splits. -/
def root_of_splits {α : Type u} {β : Type v} [field α] [field β] (i : α →+* β) {f : polynomial α} (hf : splits i f) (hfd : degree f ≠ 0) : β :=
  classical.some (exists_root_of_splits i hf hfd)

theorem map_root_of_splits {α : Type u} {β : Type v} [field α] [field β] (i : α →+* β) {f : polynomial α} (hf : splits i f) (hfd : degree f ≠ 0) : eval₂ i (root_of_splits i hf hfd) f = 0 :=
  classical.some_spec (exists_root_of_splits i hf hfd)

theorem roots_map {α : Type u} {β : Type v} [field α] [field β] (i : α →+* β) {f : polynomial α} (hf : splits (ring_hom.id α) f) : roots (map i f) = multiset.map (⇑i) (roots f) := sorry

theorem eq_prod_roots_of_splits {α : Type u} {β : Type v} [field α] [field β] {p : polynomial α} {i : α →+* β} (hsplit : splits i p) : map i p =
  coe_fn C (coe_fn i (leading_coeff p)) * multiset.prod (multiset.map (fun (a : β) => X - coe_fn C a) (roots (map i p))) := sorry

theorem eq_X_sub_C_of_splits_of_single_root {α : Type u} {β : Type v} [field α] [field β] (i : α →+* β) {x : α} {h : polynomial α} (h_splits : splits i h) (h_roots : roots (map i h) = singleton (coe_fn i x)) : h = coe_fn C (leading_coeff h) * (X - coe_fn C x) := sorry

theorem nat_degree_multiset_prod {R : Type u_1} [integral_domain R] {s : multiset (polynomial R)} (h : ∀ (p : polynomial R), p ∈ s → p ≠ 0) : nat_degree (multiset.prod s) = multiset.sum (multiset.map nat_degree s) := sorry

theorem nat_degree_eq_card_roots {α : Type u} {β : Type v} [field α] [field β] {p : polynomial α} {i : α →+* β} (hsplit : splits i p) : nat_degree p = coe_fn multiset.card (roots (map i p)) := sorry

theorem degree_eq_card_roots {α : Type u} {β : Type v} [field α] [field β] {p : polynomial α} {i : α →+* β} (p_ne_zero : p ≠ 0) (hsplit : splits i p) : degree p = ↑(coe_fn multiset.card (roots (map i p))) := sorry

theorem splits_of_exists_multiset {α : Type u} {β : Type v} [field α] [field β] (i : α →+* β) {f : polynomial α} {s : multiset β} (hs : map i f = coe_fn C (coe_fn i (leading_coeff f)) * multiset.prod (multiset.map (fun (a : β) => X - coe_fn C a) s)) : splits i f := sorry

theorem splits_of_splits_id {α : Type u} {β : Type v} [field α] [field β] (i : α →+* β) {f : polynomial α} : splits (ring_hom.id α) f → splits i f := sorry

theorem splits_iff_exists_multiset {α : Type u} {β : Type v} [field α] [field β] (i : α →+* β) {f : polynomial α} : splits i f ↔
  ∃ (s : multiset β),
    map i f = coe_fn C (coe_fn i (leading_coeff f)) * multiset.prod (multiset.map (fun (a : β) => X - coe_fn C a) s) := sorry

theorem splits_comp_of_splits {α : Type u} {β : Type v} {γ : Type w} [field α] [field β] [field γ] (i : α →+* β) (j : β →+* γ) {f : polynomial α} (h : splits i f) : splits (ring_hom.comp j i) f := sorry

/-- A monic polynomial `p` that has as much roots as its degree
can be written `p = ∏(X - a)`, for `a` in `p.roots`. -/
theorem prod_multiset_X_sub_C_of_monic_of_roots_card_eq {α : Type u} [field α] {p : polynomial α} (hmonic : monic p) (hroots : coe_fn multiset.card (roots p) = nat_degree p) : multiset.prod (multiset.map (fun (a : α) => X - coe_fn C a) (roots p)) = p := sorry

/-- A polynomial `p` that has as much roots as its degree
can be written `p = p.leading_coeff * ∏(X - a)`, for `a` in `p.roots`. -/
theorem C_leading_coeff_mul_prod_multiset_X_sub_C {α : Type u} [field α] {p : polynomial α} (hroots : coe_fn multiset.card (roots p) = nat_degree p) : coe_fn C (leading_coeff p) * multiset.prod (multiset.map (fun (a : α) => X - coe_fn C a) (roots p)) = p := sorry

/-- A polynomial splits if and only if it has as much roots as its degree. -/
theorem splits_iff_card_roots {α : Type u} [field α] {p : polynomial α} : splits (ring_hom.id α) p ↔ coe_fn multiset.card (roots p) = nat_degree p := sorry

end polynomial

/-- If `p` is the minimal polynomial of `a` over `F` then `F[a] ≃ₐ[F] F[x]/(p)` -/
def alg_equiv.adjoin_singleton_equiv_adjoin_root_minpoly (F : Type u_1) [field F] {R : Type u_2} [comm_ring R] [algebra F R] (x : R) : alg_equiv F (↥(algebra.adjoin F (singleton x))) (adjoin_root (minpoly F x)) :=
  alg_equiv.symm
    (alg_equiv.of_bijective
      (alg_hom.cod_restrict (adjoin_root.lift_hom (minpoly F x) x sorry) (algebra.adjoin F (singleton x)) sorry) sorry)

-- Speed up the following proof.

-- TODO: Why is this so slow?

/-- If `K` and `L` are field extensions of `F` and we have `s : finset K` such that
the minimal polynomial of each `x ∈ s` splits in `L` then `algebra.adjoin F s` embeds in `L`. -/
theorem lift_of_splits {F : Type u_1} {K : Type u_2} {L : Type u_3} [field F] [field K] [field L] [algebra F K] [algebra F L] (s : finset K) : (∀ (x : K), x ∈ s → is_integral F x ∧ polynomial.splits (algebra_map F L) (minpoly F x)) →
  Nonempty (alg_hom F (↥(algebra.adjoin F ↑s)) L) := sorry

namespace polynomial

/-- Non-computably choose an irreducible factor from a polynomial. -/
def factor {α : Type u} [field α] (f : polynomial α) : polynomial α :=
  dite (∃ (g : polynomial α), irreducible g ∧ g ∣ f)
    (fun (H : ∃ (g : polynomial α), irreducible g ∧ g ∣ f) => classical.some H)
    fun (H : ¬∃ (g : polynomial α), irreducible g ∧ g ∣ f) => X

protected instance irreducible_factor {α : Type u} [field α] (f : polynomial α) : irreducible (factor f) := sorry

theorem factor_dvd_of_not_is_unit {α : Type u} [field α] {f : polynomial α} (hf1 : ¬is_unit f) : factor f ∣ f := sorry

theorem factor_dvd_of_degree_ne_zero {α : Type u} [field α] {f : polynomial α} (hf : degree f ≠ 0) : factor f ∣ f :=
  factor_dvd_of_not_is_unit (mt degree_eq_zero_of_is_unit hf)

theorem factor_dvd_of_nat_degree_ne_zero {α : Type u} [field α] {f : polynomial α} (hf : nat_degree f ≠ 0) : factor f ∣ f :=
  factor_dvd_of_degree_ne_zero (mt nat_degree_eq_of_degree_eq_some hf)

/-- Divide a polynomial f by X - C r where r is a root of f in a bigger field extension. -/
def remove_factor {α : Type u} [field α] (f : polynomial α) : polynomial (adjoin_root (factor f)) :=
  map (adjoin_root.of (factor f)) f /ₘ (X - coe_fn C (adjoin_root.root (factor f)))

theorem X_sub_C_mul_remove_factor {α : Type u} [field α] (f : polynomial α) (hf : nat_degree f ≠ 0) : (X - coe_fn C (adjoin_root.root (factor f))) * remove_factor f = map (adjoin_root.of (factor f)) f := sorry

theorem nat_degree_remove_factor {α : Type u} [field α] (f : polynomial α) : nat_degree (remove_factor f) = nat_degree f - 1 := sorry

theorem nat_degree_remove_factor' {α : Type u} [field α] {f : polynomial α} {n : ℕ} (hfn : nat_degree f = n + 1) : nat_degree (remove_factor f) = n :=
  eq.mpr (id (Eq._oldrec (Eq.refl (nat_degree (remove_factor f) = n)) (nat_degree_remove_factor f)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (nat_degree f - 1 = n)) hfn))
      (eq.mpr (id (Eq._oldrec (Eq.refl (n + 1 - 1 = n)) (nat.add_sub_cancel n 1))) (Eq.refl n)))

/-- Auxiliary construction to a splitting field of a polynomial. Uses induction on the degree. -/
def splitting_field_aux (n : ℕ) {α : Type u} [field α] (f : polynomial α) : nat_degree f = n → Type u :=
  nat.rec_on n (fun (α : Type u) (_x : field α) (_x_1 : polynomial α) (_x : nat_degree _x_1 = 0) => α)
    fun (n : ℕ) (ih : {α : Type u} → [_inst_4 : field α] → (f : polynomial α) → nat_degree f = n → Type u) (α : Type u)
      (_x : field α) (f : polynomial α) (hf : nat_degree f = Nat.succ n) =>
      ih (remove_factor f) (nat_degree_remove_factor' hf)

namespace splitting_field_aux

theorem succ {α : Type u} [field α] (n : ℕ) (f : polynomial α) (hfn : nat_degree f = n + 1) : splitting_field_aux (n + 1) f hfn = splitting_field_aux n (remove_factor f) (nat_degree_remove_factor' hfn) :=
  rfl

protected instance field (n : ℕ) {α : Type u} [field α] {f : polynomial α} (hfn : nat_degree f = n) : field (splitting_field_aux n f hfn) :=
  nat.rec_on n (fun (α : Type u) (_x : field α) (_x_1 : polynomial α) (_x_2 : nat_degree _x_1 = 0) => _x)
    fun (n : ℕ)
      (ih :
      {α : Type u} →
        [_inst_4 : field α] → {f : polynomial α} → (hfn : nat_degree f = n) → field (splitting_field_aux n f hfn))
      (α : Type u) (_x : field α) (f : polynomial α) (hf : nat_degree f = Nat.succ n) => ih (nat_degree_remove_factor' hf)

protected instance inhabited {α : Type u} [field α] {n : ℕ} {f : polynomial α} (hfn : nat_degree f = n) : Inhabited (splitting_field_aux n f hfn) :=
  { default := bit1 (bit0 (bit1 (bit0 (bit0 1)))) }

protected instance algebra (n : ℕ) {α : Type u} [field α] {f : polynomial α} (hfn : nat_degree f = n) : algebra α (splitting_field_aux n f hfn) :=
  nat.rec_on n (fun (α : Type u) (_x : field α) (_x_1 : polynomial α) (_x_2 : nat_degree _x_1 = 0) => algebra.id α)
    fun (n : ℕ)
      (ih :
      {α : Type u} →
        [_inst_4 : field α] → {f : polynomial α} → (hfn : nat_degree f = n) → algebra α (splitting_field_aux n f hfn))
      (α : Type u) (_x : field α) (f : polynomial α) (hfn : nat_degree f = Nat.succ n) =>
      algebra.comap.algebra α (adjoin_root (factor f))
        (splitting_field_aux n (remove_factor f) (nat_degree_remove_factor' hfn))

protected instance algebra' {α : Type u} [field α] {n : ℕ} {f : polynomial α} (hfn : nat_degree f = n + 1) : algebra (adjoin_root (factor f)) (splitting_field_aux (n + 1) f hfn) :=
  splitting_field_aux.algebra n sorry

protected instance algebra'' {α : Type u} [field α] {n : ℕ} {f : polynomial α} (hfn : nat_degree f = n + 1) : algebra α (splitting_field_aux n (remove_factor f) (nat_degree_remove_factor' hfn)) :=
  splitting_field_aux.algebra (n + 1) hfn

protected instance algebra''' {α : Type u} [field α] {n : ℕ} {f : polynomial α} (hfn : nat_degree f = n + 1) : algebra (adjoin_root (factor f)) (splitting_field_aux n (remove_factor f) (nat_degree_remove_factor' hfn)) :=
  splitting_field_aux.algebra n (nat_degree_remove_factor' hfn)

protected instance scalar_tower {α : Type u} [field α] {n : ℕ} {f : polynomial α} (hfn : nat_degree f = n + 1) : is_scalar_tower α (adjoin_root (factor f)) (splitting_field_aux (n + 1) f hfn) :=
  is_scalar_tower.of_algebra_map_eq fun (x : α) => rfl

protected instance scalar_tower' {α : Type u} [field α] {n : ℕ} {f : polynomial α} (hfn : nat_degree f = n + 1) : is_scalar_tower α (adjoin_root (factor f)) (splitting_field_aux n (remove_factor f) (nat_degree_remove_factor' hfn)) :=
  is_scalar_tower.of_algebra_map_eq fun (x : α) => rfl

theorem algebra_map_succ {α : Type u} [field α] (n : ℕ) (f : polynomial α) (hfn : nat_degree f = n + 1) : algebra_map α (splitting_field_aux (n + 1) f hfn) =
  ring_hom.comp
    (algebra_map (adjoin_root (factor f)) (splitting_field_aux n (remove_factor f) (nat_degree_remove_factor' hfn)))
    (adjoin_root.of (factor f)) :=
  rfl

protected theorem splits (n : ℕ) {α : Type u} [field α] (f : polynomial α) (hfn : nat_degree f = n) : splits (algebra_map α (splitting_field_aux n f hfn)) f := sorry

theorem exists_lift (n : ℕ) {α : Type u} [field α] (f : polynomial α) (hfn : nat_degree f = n) {β : Type u_1} [field β] (j : α →+* β) (hf : splits j f) : ∃ (k : splitting_field_aux n f hfn →+* β), ring_hom.comp k (algebra_map α (splitting_field_aux n f hfn)) = j := sorry

theorem adjoin_roots (n : ℕ) {α : Type u} [field α] (f : polynomial α) (hfn : nat_degree f = n) : algebra.adjoin α ↑(multiset.to_finset (roots (map (algebra_map α (splitting_field_aux n f hfn)) f))) = ⊤ := sorry

end splitting_field_aux

/-- A splitting field of a polynomial. -/
def splitting_field {α : Type u} [field α] (f : polynomial α) :=
  splitting_field_aux (nat_degree f) f sorry

namespace splitting_field

protected instance field {α : Type u} [field α] (f : polynomial α) : field (splitting_field f) :=
  splitting_field_aux.field (nat_degree f) (_proof_1 f)

protected instance inhabited {α : Type u} [field α] (f : polynomial α) : Inhabited (splitting_field f) :=
  { default := bit1 (bit0 (bit1 (bit0 (bit0 1)))) }

protected instance algebra {α : Type u} [field α] (f : polynomial α) : algebra α (splitting_field f) :=
  splitting_field_aux.algebra (nat_degree f) (_proof_1 f)

protected theorem splits {α : Type u} [field α] (f : polynomial α) : splits (algebra_map α (splitting_field f)) f :=
  splitting_field_aux.splits (nat_degree f) f (_proof_1 f)

/-- Embeds the splitting field into any other field that splits the polynomial. -/
def lift {α : Type u} {β : Type v} [field α] [field β] (f : polynomial α) [algebra α β] (hb : splits (algebra_map α β) f) : alg_hom α (splitting_field f) β :=
  alg_hom.mk (ring_hom.to_fun (classical.some sorry)) sorry sorry sorry sorry sorry

theorem adjoin_roots {α : Type u} [field α] (f : polynomial α) : algebra.adjoin α ↑(multiset.to_finset (roots (map (algebra_map α (splitting_field f)) f))) = ⊤ :=
  splitting_field_aux.adjoin_roots (nat_degree f) f (_proof_1 f)

end splitting_field

/-- Typeclass characterising splitting fields. -/
class is_splitting_field (α : Type u) (β : Type v) [field α] [field β] [algebra α β] (f : polynomial α)
where
  splits : splits (algebra_map α β) f
  adjoin_roots : algebra.adjoin α ↑(multiset.to_finset (roots (map (algebra_map α β) f))) = ⊤

namespace is_splitting_field

protected instance splitting_field {α : Type u} [field α] (f : polynomial α) : is_splitting_field α (splitting_field f) f :=
  mk (splitting_field.splits f) (splitting_field.adjoin_roots f)

protected instance map {α : Type u} {β : Type v} {γ : Type w} [field α] [field β] [field γ] [algebra α β] [algebra β γ] [algebra α γ] [is_scalar_tower α β γ] (f : polynomial α) [is_splitting_field α γ f] : is_splitting_field β γ (map (algebra_map α β) f) := sorry

theorem splits_iff {α : Type u} (β : Type v) [field α] [field β] [algebra α β] (f : polynomial α) [is_splitting_field α β f] : splits (ring_hom.id α) f ↔ ⊤ = ⊥ := sorry

theorem mul {α : Type u} (β : Type v) {γ : Type w} [field α] [field β] [field γ] [algebra α β] [algebra β γ] [algebra α γ] [is_scalar_tower α β γ] (f : polynomial α) (g : polynomial α) (hf : f ≠ 0) (hg : g ≠ 0) [is_splitting_field α β f] [is_splitting_field β γ (map (algebra_map α β) g)] : is_splitting_field α γ (f * g) := sorry

/-- Splitting field of `f` embeds into any field that splits `f`. -/
def lift {α : Type u} (β : Type v) {γ : Type w} [field α] [field β] [field γ] [algebra α β] [algebra α γ] (f : polynomial α) [is_splitting_field α β f] (hf : splits (algebra_map α γ) f) : alg_hom α β γ :=
  dite (f = 0)
    (fun (hf0 : f = 0) =>
      alg_hom.comp (algebra.of_id α γ) (alg_hom.comp (↑(algebra.bot_equiv α β)) (eq.mpr sorry algebra.to_top)))
    fun (hf0 : ¬f = 0) => alg_hom.comp (eq.mpr sorry (Classical.choice sorry)) algebra.to_top

theorem finite_dimensional {α : Type u} (β : Type v) [field α] [field β] [algebra α β] (f : polynomial α) [is_splitting_field α β f] : finite_dimensional α β := sorry

/-- Any splitting field is isomorphic to `splitting_field f`. -/
def alg_equiv {α : Type u} (β : Type v) [field α] [field β] [algebra α β] (f : polynomial α) [is_splitting_field α β f] : alg_equiv α β (splitting_field f) :=
  alg_equiv.of_bijective (lift β f sorry) sorry


example (x y : ℕ) (h : x = y) : y = x :=
begin
  revert x y,
  intros,
  symmetry,
  assumption
end


example (x y : ℕ) (h : x = y) : y = x :=
begin
  revert x,
  intros,
  symmetry,
  assumption
end