/-
Copyright (c) 2021 Luke Kershaw. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Luke Kershaw
-/
import category_theory.additive.basic
import category_theory.shift
import category_theory.preadditive.additive_functor
import category_theory.triangulated.basic
import category_theory.triangulated.rotate

/-!
# Pretriangulated Categories

This file contains the definition of pretriangulated categories and triangulated functors
between them.

## Implementation Notes

We work under the assumption that pretriangulated categories are preadditive categories,
but not necessarily additive categories, as is assumed in some sources.

TODO: generalise this to n-angulated categories as in https://arxiv.org/abs/1006.4592
-/

noncomputable theory

open category_theory
open category_theory.preadditive
open category_theory.limits

universes v v₀ v₁ v₂ u u₀ u₁ u₂

namespace category_theory.triangulated
open category_theory.category

/-
We work in an preadditive category `C` equipped with an additive shift.
-/
variables (C : Type u) [category.{v} C] [has_zero_object C] [has_shift C] [preadditive C]
  [functor.additive (shift C).functor]

/--
A preadditive category `C` with an additive shift, and a class of "distinguished triangles"
relative to that shift is called pretriangulated if the following hold:
* Any triangle that is isomorphic to a distinguished triangle is also distinguished.
* Any triangle of the form `(X,X,0,id,0,0)` is distinguished.
* For any morphism `f : X ⟶ Y` there exists a distinguished triangle of the form `(X,Y,Z,f,g,h)`.
* The triangle `(X,Y,Z,f,g,h)` is distinguished if and only if `(Y,Z,X⟦1⟧,g,h,-f⟦1⟧)` is.
* Given a diagram:
  ```
        f       g       h
    X  ───> Y  ───> Z  ───> X⟦1⟧
    │       │                │
    │a      │b               │a⟦1⟧'
    V       V                V
    X' ───> Y' ───> Z' ───> X'⟦1⟧
        f'      g'      h'
  ```
  where the left square commutes, and whose rows are distinguished triangles,
  there exists a morphism `c : Z ⟶ Z'` such that `(a,b,c)` is a triangle morphism.
See https://stacks.math.columbia.edu/tag/0145
-/
class pretriangulated :=
(distinguished_triangles [] : set (triangle C))
(isomorphic_distinguished : Π (T₁ ∈ distinguished_triangles) (T₂ : triangle C) (T₁ ≅ T₂),
  T₂ ∈ distinguished_triangles)
(contractible_distinguished : Π (X : C), (contractible_triangle C X) ∈ distinguished_triangles)
(distinguished_cocone_triangle : Π (X Y : C) (f: X ⟶ Y), (∃ (Z : C) (g : Y ⟶ Z) (h : Z ⟶ X⟦1⟧),
  triangle.mk _ f g h ∈ distinguished_triangles))
(rotate_distinguished_triangle : Π (T : triangle C),
  T ∈ distinguished_triangles ↔ T.rotate ∈ distinguished_triangles)
(complete_distinguished_triangle_morphism : Π (T₁ T₂ : triangle C)
  (h₁ : T₁ ∈ distinguished_triangles) (h₂ : T₂ ∈ distinguished_triangles) (a : T₁.obj₁ ⟶ T₂.obj₁)
  (b : T₁.obj₂ ⟶ T₂.obj₂) (comm₁ : T₁.mor₁ ≫ b = a ≫ T₂.mor₁),
  (∃ (c : T₁.obj₃ ⟶ T₂.obj₃), (T₁.mor₂ ≫ c = b ≫ T₂.mor₂) ∧ (T₁.mor₃ ≫ a⟦1⟧' = c ≫ T₂.mor₃) ))

namespace pretriangulated
variables [pretriangulated C]

notation `dist_triang`:20 C := distinguished_triangles C
/--
Given any distinguished triangle `T`, then we know `T.rotate` is also distinguished.
-/
lemma rot_of_dist_triangle (T ∈ dist_triang C) : (T.rotate ∈ dist_triang C) :=
(rotate_distinguished_triangle T).mp H

/--
Given any distinguished triangle `T`, then we know `T.inv_rotate` is also distinguished.
-/
lemma inv_rot_of_dist_triangle (T ∈ dist_triang C) : (T.inv_rotate ∈ dist_triang C) :=
(rotate_distinguished_triangle (T.inv_rotate)).mpr
  (isomorphic_distinguished T H (T.inv_rotate.rotate) T (inv_rot_comp_rot.symm.app T))

/--
Given any distinguished triangle
```
      f       g       h
  X  ───> Y  ───> Z  ───> X⟦1⟧
```
the composition `f ≫ g = 0`.
See https://stacks.math.columbia.edu/tag/0146
-/
lemma comp_dist_triangle_mor_zero₁₂ (T ∈ dist_triang C) : T.mor₁ ≫ T.mor₂ = 0 :=
begin
  have h := contractible_distinguished T.obj₁,
  have f := complete_distinguished_triangle_morphism,
  specialize f (contractible_triangle C T.obj₁) T h H (𝟙 T.obj₁) T.mor₁,
  have t : (contractible_triangle C T.obj₁).mor₁ ≫ T.mor₁ = 𝟙 T.obj₁ ≫ T.mor₁,
    by refl,
  specialize f t,
  cases f with c f,
  rw ← f.left,
  simp only [limits.zero_comp, contractible_triangle_mor₂],
end -- TODO : tidy this proof up

/--
Given any distinguished triangle
```
      f       g       h
  X  ───> Y  ───> Z  ───> X⟦1⟧
```
the composition `g ≫ h = 0`.
See https://stacks.math.columbia.edu/tag/0146
-/
lemma comp_dist_triangle_mor_zero₂₃  (T ∈ dist_triang C) : T.mor₂ ≫ T.mor₃ = 0 :=
comp_dist_triangle_mor_zero₁₂ C T.rotate (rot_of_dist_triangle C T H)

/--
Given any distinguished triangle
```
      f       g       h
  X  ───> Y  ───> Z  ───> X⟦1⟧
```
the composition `h ≫ f⟦1⟧ = 0`.
See https://stacks.math.columbia.edu/tag/0146
-/
lemma comp_dist_triangle_mor_zero₃₁ (T ∈ dist_triang C) :
  T.mor₃ ≫ ((shift C).functor.map T.mor₁) = 0 :=
have H₂ : _ := rot_of_dist_triangle C T.rotate (rot_of_dist_triangle C T H),
by simpa using comp_dist_triangle_mor_zero₁₂ C (T.rotate.rotate) H₂

/-
TODO: If `C` is pretriangulated with respect to a shift,
then `Cᵒᵖ` is pretriangulated with respect to the inverse shift.
-/
end pretriangulated
end category_theory.triangulated

namespace category_theory.triangulated
namespace pretriangulated

variables (C : Type u₁) [category.{v₁} C] [has_zero_object C] [has_shift C] [preadditive C]
[functor.additive (shift C).functor] [functor.additive (shift C).inverse]
variables (D : Type u₂) [category.{v₂} D] [has_zero_object D] [has_shift D] [preadditive D]
[functor.additive (shift D).functor] [functor.additive (shift D).inverse]

/--
The underlying structure of a triangulated functor between pretriangulated categories `C` and `D`
is a functor `F : C ⥤ D` together with given functorial isomorphisms `ξ X : F(X⟦1⟧) ⟶ F(X)⟦1⟧`.
-/
structure triangulated_functor_struct extends (C ⥤ D) :=
(comm_shift : (shift C).functor ⋙ to_functor ≅ to_functor ⋙ (shift D).functor)

instance : inhabited (triangulated_functor_struct C C) :=
⟨{ obj := λ X, X,
  map := λ _ _ f, f,
  comm_shift := by refl }⟩

variables {C D}
/--
Given a `triangulated_functor_struct` we can define a function from triangles of `C` to
triangles of `D`.
-/
@[simp]
def triangulated_functor_struct.map_triangle (F : triangulated_functor_struct C D)
  (T : triangle C) : triangle D :=
triangle.mk _ (F.map T.mor₁) (F.map T.mor₂) (F.map T.mor₃ ≫ F.comm_shift.hom.app T.obj₁)

variables (C D)
/--
A triangulated functor between pretriangulated categories `C` and `D` is a functor `F : C ⥤ D`
together with given functorial isomorphisms `ξ X : F(X⟦1⟧) ⟶ F(X)⟦1⟧` such that for every
distinguished triangle `(X,Y,Z,f,g,h)` of `C`, the triangle
`(F(X), F(Y), F(Z), F(f), F(g), F(h) ≫ (ξ X))` is a distinguished triangle of `D`.
See https://stacks.math.columbia.edu/tag/014V
-/
structure triangulated_functor [pretriangulated C] [pretriangulated D] extends
  triangulated_functor_struct C D :=
(map_distinguished' : Π (T: triangle C), (T ∈ dist_triang C) →
  (to_triangulated_functor_struct.map_triangle T ∈ dist_triang D) )

instance [pretriangulated C] : inhabited (triangulated_functor C C) :=
⟨{obj := λ X, X,
  map := λ _ _ f, f,
  comm_shift := by refl ,
  map_distinguished' := begin
    rintros ⟨_,_,_,_⟩ Tdt,
    dsimp at *,
    rwa category.comp_id,
  end }⟩

variables {C D} [pretriangulated C] [pretriangulated D]
/--
Given a `triangulated_functor` we can define a function from triangles of `C` to triangles of `D`.
-/
@[simp]
def triangulated_functor.map_triangle (F : triangulated_functor C D) (T : triangle C) :
  triangle D :=
triangle.mk _ (F.map T.mor₁) (F.map T.mor₂) (F.map T.mor₃ ≫ F.comm_shift.hom.app T.obj₁)

/--
Given a `triangulated_functor` and a distinguished triangle `T` of `C`, then the triangle it
maps onto in `D` is also distinguished.
-/
lemma triangulated_functor.map_distinguished (F : triangulated_functor C D) (T : triangle C)
  (h : T ∈ dist_triang C) : (F.map_triangle T) ∈ dist_triang D := F.map_distinguished' T h

end pretriangulated
end category_theory.triangulated


import hmem.stack
import hmem.encoding.basic
import hmem.split_cost
import complexity.basic

variables {μ: Type*} [decidable_eq μ] [has_zero μ] [has_one μ] [ne_zero (1:μ)]

namespace hmem
namespace encoding

def encode_list {α: Type*} [α_en: complexity.has_encoding (runtime_model μ) α]: list α → memory μ
| [] := memory.null _
| (x::xs) := (((memory.null _).setv 1).setm 0 (encode x)).setm 1 (encode_list xs)

instance (α: Type*) [α_en: complexity.has_encoding (runtime_model μ) α]: complexity.has_encoding (runtime_model μ) (list α) :=
⟨ ⟨ encode_list,
begin
  intros x y,
  split,
  {  induction x generalizing y;
    cases y,
    { simp only [has_equiv.equiv, eq_self_iff_true, imp_true_iff] },
    { simp only [has_equiv.equiv, (list.cons_ne_nil _ _).symm, iff_false, encode_list],
      intro h,
      apply @zero_ne_one μ,
      apply memory.getv_congr h,
      refl,
      rw [memory.getv_setm, memory.getv_setm, memory.getv_setv] },
    { simp only [has_equiv.equiv, (list.cons_ne_nil _ _), iff_false, encode_list],
      intro h,
      apply (@zero_ne_one μ _ _ _).symm,
      apply memory.getv_congr h,
      rw [memory.getv_setm, memory.getv_setm, memory.getv_setv],
      refl },
    simp only [has_equiv.equiv, encode_list, encode],
    intro h,
    split,
    {
      rw ← complexity.encoding.encode_inj α_en.value,
      apply memory.getm_congr 0 h;
      { rw [memory.getm_setm_ne, memory.getm_setm],
        refl,
        apply zero_ne_one } },
    apply x_ih,
    apply memory.getm_congr 1 h;
    { rw [memory.getm_setm] } },
  intro h,
  rw [h],
  unfold has_equiv.equiv,
end ⟩ ⟩

theorem encode_nil {α: Type*} [complexity.has_encoding (runtime_model μ) α]: encode (@list.nil α) = memory.null μ := rfl

theorem encode_cons {α: Type*} [complexity.has_encoding (runtime_model μ) α] (x: α) (xs: list α): encode (x::xs) = (((memory.null μ).setv 1).setm 0 (encode x)).setm 1 (encode xs) := rfl

def split (μ: Type*) [decidable_eq μ] [has_zero μ] [has_one μ] [ne_zero (1:μ)]: program μ :=
[ -- xs
  instruction.ite (λ a, a = 0) [
    -- list.nil
    instruction.const source.nil 1
    -- 1 list.nil list.nil
  ],
  -- 1 x xs
  instruction.swap (source.imm 0 source.nil) (source.imm 1 source.nil),
  -- 1 xs x
  instruction.recurse (source.imm 0 source.nil),
  -- 1 [ 1 fst snd ] x
  instruction.swap (source.imm 0 (source.imm 0 source.nil)) (source.imm 1 source.nil)
  -- 1 (x::snd) fst
]

theorem split_result {α: Type*} [complexity.has_encoding (runtime_model μ) α] (l : list α):
  (split μ).has_result (encode l) (encode (list.split l)) :=
begin
  induction l,
  { apply thunk.apply_step_over',
    { unfold split },
    { unfold thunk.step_over thunk.step },
    simp only [encode_nil, memory.getv_null, eq_self_iff_true, if_true],
    apply thunk.apply_step_over,
    { unfold thunk.step_over thunk.step instruction.const },
    simp only [memory.setvs, source.get, memory.setvp_nil],
    simp only [list.split, encode_pair, encode_nil, memory.null_setv_setm_null],
    exact ⟨1, rfl⟩, },
  { apply thunk.apply_step_over',
    { unfold split },
    { unfold thunk.step_over thunk.step },
    simp only [encode_cons, memory.getv_setm, memory.getv_setv, one_ne_zero, if_false],
    apply thunk.apply_step_over,
    { unfold thunk.step_over thunk.step instruction.swap },
    simp only [memory.mop, memory.setms, memory.getms, source.get,
      memory.setmp_nil, memory.setmp_cons, memory.setm_setm,
      memory.getmp_nil, memory.getmp_cons,
      memory.getm_setm, memory.getm_setm_ne _ 1 _ 0 (zero_ne_one' μ),
      memory.setm_setm_ne _ 1 0 _ _ (one_ne_zero' μ)],
    apply thunk.apply_step_over_recurse,
    { simp only [memory.getms, source.get, memory.getmp_cons, memory.getmp_nil,
      memory.getm_setm, memory.getm_setm_ne _ 1 _ 0 (zero_ne_one' μ)],
      exact l_ih },
    simp only [memory.setm_setm, memory.setm_setm_ne _ 1 0 _ _ (one_ne_zero' μ)],
    apply thunk.apply_step_over,
    { unfold thunk.step_over thunk.step instruction.swap },
    cases hs:l_tl.split,
    simp only [memory.mop, memory.setms, memory.getms, source.get,
      list.split, hs, encode_pair, encode_cons,
      memory.setmp_nil, memory.setmp_cons, memory.setm_setm,
      memory.getmp_nil, memory.getmp_cons,
      memory.getm_setm, memory.getm_setm_ne _ 1 _ 0 (zero_ne_one' μ),
      memory.setm_setm, memory.setm_setm_ne _ 1 0 _ _ (one_ne_zero' μ)],
    exact ⟨1, rfl⟩ }
end

def merge {μ: Type*} [decidable_eq μ] [has_zero μ] [has_one μ] [ne_zero (1:μ)] (cmp: program μ): program μ :=
[ -- 1 as bs
  instruction.uop id source.nil (source.imm 0 source.nil),
  -- (as_nil) as bs
  instruction.ite (λ a, a = 0) [
    -- 0 [] bs
    instruction.move source.nil (source.imm 1 source.nil)
    -- bs
  ],
  instruction.uop id source.nil (source.imm 1 source.nil),
  -- (bs_nil) [1 a as] bs
  instruction.ite (λ a, a = 0) [
    -- 0 [1 a as] []
    instruction.move source.nil (source.imm 0 source.nil)
    -- 1 a as
  ],
  -- 0 [1 a as] [1 b bs]
  instruction.swap (source.imm 0 (source.imm 1 source.nil)) (source.imm 1 (source.imm 0 source.nil)),
  -- 0 [1 a b] [1 as bs]
  instruction.copy (source.imm 1 source.nil) source.nil,
  -- 0 [1 a b] [0 [1 a b] [1 as bs]]
  instruction.call cmp (source.imm 0 source.nil),
  -- 0 [(a ≼ b) ? ?] [0 [1 a b] [1 as bs]]
  instruction.uop id source.nil (source.imm 0 source.nil),
  -- (a ≼ b) [(a ≼ b) ? ?] [0 [1 a b] [1 as bs]]
  instruction.ite (λ a, a = 1) [
    -- a ≼ b
    -- 1 [1 null null] [0 [1 a b] [1 as bs]]
    instruction.move (source.imm 0 (source.imm 0 source.nil)) (source.imm 1 (source.imm 1 (source.imm 0 source.nil))),
    -- 1 [1 as null] [0 [1 a b] [1 null bs]]
    instruction.const (source.imm 0 (source.imm 1 source.nil)) 1,
    -- 1 [1 as [1 null null]]] [0 [1 a b] [1 null bs]]
    instruction.move (source.imm 0 (source.imm 1 (source.imm 0 source.nil))) (source.imm 1 (source.imm 0 (source.imm 1 source.nil))),
    -- 1 [1 as [1 b null]]] [0 [1 a null] [1 null bs]]
    instruction.move (source.imm 0 (source.imm 1 (source.imm 1 source.nil))) (source.imm 1 (source.imm 1 (source.imm 1 source.nil))),
    -- 1 [1 as [1 b bs]]] [0 [1 a null] [1 null null]]
    instruction.recurse (source.imm 0 source.nil),
    -- 1 xs [0 [1 a null] [1 null null]]
    instruction.move (source.imm 1 (source.imm 0 (source.imm 1 source.nil))) (source.imm 0 source.nil),
    -- 1 null [0 [1 a xs] [1 null null]]
    instruction.move source.nil (source.imm 1 (source.imm 0 source.nil))
    -- 1 a xs
  ],
  -- ¬ a ≼ b
  -- 0 [0 null null] [0 [1 a b] [1 as bs]]
  instruction.const (source.imm 0 source.nil) 1,
  -- 0 [1 null null] [0 [1 a b] [1 as bs]]
  instruction.move (source.imm 0 (source.imm 1 source.nil)) (source.imm 1 (source.imm 1 (source.imm 1 source.nil))),
  -- 0 [1 null bs] [0 [1 a b] [1 as null]]
  instruction.const (source.imm 0 (source.imm 0 source.nil)) 1,
  -- 0 [1 [1 null null] bs] [0 [1 a b] [1 as null]]
  instruction.move (source.imm 0 (source.imm 0 (source.imm 0 source.nil))) (source.imm 1 (source.imm 0 (source.imm 0 source.nil))),
  -- 0 [1 [1 a null] bs] [0 [1 null b] [1 as null]]
  instruction.move (source.imm 0 (source.imm 0 (source.imm 1 source.nil))) (source.imm 1 (source.imm 1 (source.imm 0 source.nil))),
  -- 0 [1 [1 a as] b]] [0 [1 null b] [1 null null]]
  instruction.recurse (source.imm 0 source.nil),
  -- 0 xs [0 [1 null b] [1 null null]]
  instruction.move (source.imm 1 (source.imm 0 (source.imm 0 source.nil))) (source.imm 1 (source.imm 0 (source.imm 1 source.nil))),
  -- 0 xs [0 [1 b null] [1 null null]]
    instruction.move (source.imm 1 (source.imm 0 (source.imm 1 source.nil))) (source.imm 0 source.nil),
  -- 0 null [0 [1 b xs] [1 null null]]
  instruction.move source.nil (source.imm 1 (source.imm 0 source.nil))
  -- 1 b xs
]

theorem merge_result {α: Type*} [complexity.has_encoding (runtime_model μ) α]
  (fcmp: α → α → Prop) [dcmp: decidable_rel fcmp]
  (pcmp: program μ) (hcmp: ∀ (a b: α), pcmp.has_result (encode (a, b)) (encode (dcmp a b))):
  ∀ (as bs: list α), (merge pcmp).has_result (encode (as, bs)) (encode (list.merge fcmp as bs)) :=
begin
  intros as bs,
  simp only [encode_pair],
  induction h:(as.length + bs.length) using nat.strong_induction_on with n ih generalizing as bs,
  cases as,
  { apply thunk.apply_step_over',
    { unfold merge },
    { unfold thunk.step_over thunk.step instruction.uop },
    apply thunk.apply_step_over,
    { unfold thunk.step_over thunk.step },
    simp only [encode_nil, id, vector.map_cons, vector.map_nil, vector.nth_cons_zero, fin.mk_zero,
      memory.setvs, memory.getvs, source.get,
      memory.setvp_nil, memory.getvp_cons, memory.getvp_nil,
      ← memory.setv_setm, memory.setv_setv, memory.getv_null,
      memory.getm_setm, memory.getm_setm_ne _ 1 _ 0 (zero_ne_one' μ),
      memory.getv_setm, memory.getv_setv, eq_self_iff_true, if_true],
    apply thunk.apply_step_over,
    { unfold thunk.step_over thunk.step instruction.move },
    cases bs;
    simp only [memory.setms, memory.getms, source.get,
      memory.setmp_cons, memory.setmp_nil, memory.getmp_cons, memory.getmp_nil,
      memory.getm_setm, list.merge];
    exact ⟨1, rfl⟩ },
  cases bs,
  { apply thunk.apply_step_over',
    { unfold merge },
    { unfold thunk.step_over thunk.step instruction.uop },
    apply thunk.apply_step_over,
    { unfold thunk.step_over thunk.step },
    simp only [encode_nil, id, vector.map_cons, vector.map_nil, vector.nth_cons_zero, fin.mk_zero,
      memory.setvs, memory.getvs, source.get,
      memory.setvp_nil, memory.getvp_cons, memory.getvp_nil,
      ← memory.setv_setm, memory.setv_setv, memory.getv_null,
      memory.getm_setm, memory.getm_setm_ne _ 1 _ 0 (zero_ne_one' μ),
      memory.getv_setm, memory.getv_setv, encode_cons, one_ne_zero' μ, if_false],
    apply thunk.apply_step_over,
    { unfold thunk.step_over thunk.step },
    apply thunk.apply_step_over,
    { unfold thunk.step_over thunk.step },
    simp only [encode_nil, id, vector.map_cons, vector.map_nil, vector.nth_cons_zero, fin.mk_zero,
      memory.setvs, memory.getvs, source.get,
      memory.setvp_nil, memory.getvp_cons, memory.getvp_nil,
      ← memory.setv_setm, memory.setv_setv, memory.getv_null,
      memory.getm_setm, memory.getm_setm_ne _ 1 _ 0 (zero_ne_one' μ),
      memory.getv_setm, memory.getv_setv, eq_self_iff_true, if_true],
    apply thunk.apply_step_over,
    { unfold thunk.step_over thunk.step instruction.move },
    simp only [memory.setms, memory.getms, source.get,
      memory.setmp_cons, memory.setmp_nil, memory.getmp_cons, memory.getmp_nil,
      memory.getm_setm, memory.getm_setm_ne _ 1 _ 0 (zero_ne_one' μ),
      list.merge, ← encode_cons],
    exact ⟨1, rfl⟩ },
  { apply thunk.apply_step_over',
    { unfold merge },
    { unfold thunk.step_over thunk.step instruction.uop },
    apply thunk.apply_step_over,
    { unfold thunk.step_over thunk.step },
    simp only [encode_nil, id, vector.map_cons, vector.map_nil, vector.nth_cons_zero, fin.mk_zero,
      memory.setvs, memory.getvs, source.get,
      memory.setvp_nil, memory.getvp_cons, memory.getvp_nil,
      ← memory.setv_setm, memory.setv_setv, memory.getv_null,
      memory.getm_setm, memory.getm_setm_ne _ 1 _ 0 (zero_ne_one' μ),
      memory.getv_setm, memory.getv_setv, encode_cons, one_ne_zero' μ, if_false],
    apply thunk.apply_step_over,
    { unfold thunk.step_over thunk.step },
    apply thunk.apply_step_over,
    { unfold thunk.step_over thunk.step },
    simp only [encode_nil, id, vector.map_cons, vector.map_nil, vector.nth_cons_zero, fin.mk_zero,
      memory.setvs, memory.getvs, source.get,
      memory.setvp_nil, memory.getvp_cons, memory.getvp_nil,
      ← memory.setv_setm, memory.setv_setv, memory.getv_null,
      memory.getm_setm, memory.getm_setm_ne _ 1 _ 0 (zero_ne_one' μ),
      memory.getv_setm, memory.getv_setv, encode_cons, one_ne_zero' μ, if_false],
    apply thunk.apply_step_over,
    { unfold thunk.step_over thunk.step instruction.swap },
    apply thunk.apply_step_over,
    { unfold thunk.step_over thunk.step instruction.copy },
    simp only [memory.setms, memory.getms, source.get,
      memory.setmp_cons, memory.setmp_nil, memory.getmp_cons, memory.getmp_nil,
      memory.getm_setm, memory.getm_setm_ne _ 1 _ 0 (zero_ne_one' μ),
      memory.setm_setm, memory.setm_setm_ne _ 1 0 _ _ (one_ne_zero' μ),
      memory.mop],
    apply thunk.apply_step_over_call,
    { simp only [memory.getms, source.get,
        memory.getmp_cons, memory.getmp_nil,
        memory.getm_setm, memory.getm_setm_ne _ 1 _ 0 (zero_ne_one' μ)],
      rw [← encode_pair],
      apply hcmp },
    apply thunk.apply_step_over,
    { unfold thunk.step_over thunk.step },
    apply thunk.apply_step_over,
    { unfold thunk.step_over thunk.step },
    simp only [encode_nil, id, vector.map_cons, vector.map_nil, vector.nth_cons_zero, fin.mk_zero,
      memory.setvs, memory.getvs, source.get,
      memory.setvp_nil, memory.getvp_cons, memory.getvp_nil,
      ← memory.setv_setm, memory.setv_setv, memory.getv_null,
      memory.getm_setm, memory.getm_setm_ne _ 1 _ 0 (zero_ne_one' μ),
      memory.setm_setm, memory.setm_setm_ne _ 1 0 _ _ (one_ne_zero' μ)],
    cases hcmp:dcmp as_hd bs_hd,
    { rw[encode_is_false (decidable.is_false h_1)],
      simp [memory.getv_setm, memory.getv_setv, memory.getv_null],
      apply thunk.apply_step_over,
      { unfold thunk.step_over thunk.step instruction.const },
      apply thunk.apply_step_over,
      { unfold thunk.step_over thunk.step instruction.move },
      apply thunk.apply_step_over,
      { unfold thunk.step_over thunk.step },
      apply thunk.apply_step_over,
      { unfold thunk.step_over thunk.step },
      apply thunk.apply_step_over,
      { unfold thunk.step_over thunk.step },
      simp only [encode_nil, id, vector.map_cons, vector.map_nil, vector.nth_cons_zero, fin.mk_zero,
        memory.setvs, memory.setms, memory.getvs, memory.getms, source.get,
        memory.setvp_cons, memory.setvp_nil, memory.getvp_cons, memory.getvp_nil,
        memory.setmp_cons, memory.setmp_nil, memory.getmp_cons, memory.getmp_nil, memory.mop,
        ← memory.setv_setm, memory.setv_setv, memory.getv_null,
        memory.getm_setv, memory.getm_null, memory.null_setv_setm_null,
        memory.getm_setm, memory.getm_setm_ne _ 1 _ 0 (zero_ne_one' μ),
        memory.setm_setm, memory.setm_setm_ne _ 1 0 _ _ (one_ne_zero' μ)],
      apply thunk.apply_step_over_recurse,
      { simp only [memory.getms, source.get, memory.getmp_cons, memory.getmp_nil,
           memory.getm_setm, memory.getm_setm_ne _ 1 _ 0 (zero_ne_one' μ)],
        rw [← encode_cons, ← encode_pair],
        apply ih _ _ _ _ rfl,
        simpa only [← h, list.length_cons, ← nat.add_assoc] using nat.lt_succ_self _ },
      apply thunk.apply_step_over,
      { unfold thunk.step_over thunk.step },
      apply thunk.apply_step_over,
      { unfold thunk.step_over thunk.step },
      apply thunk.apply_step_over,
      { unfold thunk.step_over thunk.step },
      simp only [
        list.merge, h_1, if_false,
        memory.setms, memory.getms, source.get,
        memory.setmp_cons, memory.setmp_nil, memory.getmp_cons, memory.getmp_nil, memory.mop,
        memory.getm_setm, memory.getm_setm_ne _ 1 _ 0 (zero_ne_one' μ),
        memory.setm_setm, memory.setm_setm_ne _ 1 0 _ _ (one_ne_zero' μ)],
      exact ⟨1, rfl⟩ },
    { rw[encode_is_true (decidable.is_true h_1)],
      simp [memory.getv_setm, memory.getv_setv, memory.getv_null],
      apply thunk.apply_step_over,
      { unfold thunk.step_over thunk.step instruction.move },
      apply thunk.apply_step_over,
      { unfold thunk.step_over thunk.step instruction.const },
      apply thunk.apply_step_over,
      { unfold thunk.step_over thunk.step },
      apply thunk.apply_step_over,
      { unfold thunk.step_over thunk.step },
      simp only [encode_nil, id, vector.map_cons, vector.map_nil, vector.nth_cons_zero, fin.mk_zero,
        memory.setvs, memory.setms, memory.getvs, memory.getms, source.get,
        memory.setvp_cons, memory.setvp_nil, memory.getvp_cons, memory.getvp_nil,
        memory.setmp_cons, memory.setmp_nil, memory.getmp_cons, memory.getmp_nil, memory.mop,
        ← memory.setv_setm, memory.setv_setv, memory.getv_null,
        memory.getm_setv, memory.getm_null, memory.null_setv_setm_null,
        memory.getm_setm, memory.getm_setm_ne _ 1 _ 0 (zero_ne_one' μ),
        memory.setm_setm, memory.setm_setm_ne _ 1 0 _ _ (one_ne_zero' μ)],
      apply thunk.apply_step_over_recurse,
      { simp only [memory.getms, source.get, memory.getmp_cons, memory.getmp_nil,
           memory.getm_setm, memory.getm_setm_ne _ 1 _ 0 (zero_ne_one' μ),
           memory.getm_setm_ne _ 0 _ 1 (one_ne_zero' μ),
           memory.getm_setv, memory.getm_null],
        rw [← encode_cons, ← encode_pair],
        apply ih _ _ _ _ rfl,
        simpa only [← h, list.length_cons, add_lt_add_iff_right] using nat.lt_succ_self _ },
      apply thunk.apply_step_over,
      { unfold thunk.step_over thunk.step },
      apply thunk.apply_step_over,
      { unfold thunk.step_over thunk.step },
      simp only [
        list.merge, h_1, if_true,
        memory.setms, memory.getms, source.get,
        memory.setmp_cons, memory.setmp_nil, memory.getmp_cons, memory.getmp_nil, memory.mop,
        memory.getm_setm, memory.getm_setm_ne _ 1 _ 0 (zero_ne_one' μ),
        memory.setm_setm, memory.setm_setm_ne _ 1 0 _ _ (one_ne_zero' μ)],
      exact ⟨1, rfl⟩ } }
end

def merge_sort {μ: Type*} [decidable_eq μ] [has_zero μ] [has_one μ] [ne_zero (1:μ)] (cmp: program μ): program μ :=
[ -- l
  instruction.ite (λ a, a = 0) [
    -- list.nil
  ],
  -- 1 a l
  instruction.uop id source.nil (source.imm 1 source.nil),
  -- (l.nil) a l
  instruction.ite (λ a, a = 0) [
    -- 0 a list.nil
    instruction.const source.nil 1
    -- 1 a list.nil
  ],
  -- 1 a [1 b l]
  instruction.move (source.imm 0 source.nil) source.nil,
  -- 0 [1 a [1 b l]] null
  instruction.call (split μ) (source.imm 0 source.nil),
  -- 0 [1 l₁ l₂]
  instruction.move source.nil (source.imm 0 source.nil),
  -- 1 l₁ l₂
  instruction.recurse (source.imm 0 source.nil),
  -- 1 ms₁ l₂
  instruction.swap (source.imm 0 source.nil) (source.imm 1 source.nil),
  -- 1 l₂ ms₁
  instruction.recurse (source.imm 0 source.nil),
  -- 1 ms₂ ms₁
  instruction.swap (source.imm 0 source.nil) (source.imm 1 source.nil),
  -- 1 ms₁ ms₂
  instruction.move (source.imm 0 source.nil) source.nil,
  -- 0 [1 ms₁ ms₂] null
  instruction.call (merge cmp) (source.imm 0 source.nil),
  -- 0 m null
  instruction.move source.nil (source.imm 0 source.nil)
  -- m
]

theorem merge_sort_result
  {α: Type*} [complexity.has_encoding (runtime_model μ) α]
  (fcmp: α → α → Prop) [dcmp: decidable_rel fcmp]
  (pcmp: program μ) (hcmp: ∀ (a b: α), pcmp.has_result (encode (a, b)) (encode (dcmp a b))):
  ∀ (l: list α), (merge_sort pcmp).has_result (encode l) (encode (list.merge_sort fcmp l)) :=
begin
  intros l,
  induction hn:l.length using nat.strong_induction_on with n ih generalizing l,
  cases l with a l,
  { apply thunk.apply_step_over',
    unfold merge_sort,
    { unfold thunk.step_over thunk.step },
    simp only [encode_nil, memory.getv_null, eq_self_iff_true, if_true, list.merge_sort],
    exact ⟨1, rfl⟩ },
  apply thunk.apply_step_over',
  unfold merge_sort,
  { unfold thunk.step_over thunk.step },
  simp only [encode_cons, memory.getv_setm, memory.getv_setv, (one_ne_zero' μ), if_false],
  apply thunk.apply_step_over,
  { unfold thunk.step_over thunk.step instruction.uop },
  cases l with b l,
  { apply thunk.apply_step_over,
    { unfold thunk.step_over thunk.step },
    simp only [id, encode_nil, memory.setvs, memory.getvs, source.get,
      memory.setvp_nil, memory.getvp_cons, memory.getvp_nil,
      memory.getv_setm, memory.getm_setm, memory.getv_null,
      memory.getv_setv, ← memory.setv_setm, memory.setv_setv,
      fin.mk_zero, vector.map_cons, vector.nth_cons_zero,
      eq_self_iff_true, if_true],
    apply thunk.apply_step_over,
    { unfold thunk.step_over thunk.step instruction.const },
    simp only [id, encode_nil, memory.setvs, memory.getvs, source.get,
      memory.setvp_nil, memory.getvp_cons, memory.getvp_nil,
      memory.getv_setm, memory.getm_setm, memory.getv_null,
      memory.getv_setv, ← memory.setv_setm, memory.setv_setv,
      eq_self_iff_true, if_true],
    unfold list.merge_sort,
    rw [encode_cons],
    exact ⟨1, rfl⟩ },
  apply thunk.apply_step_over,
  { unfold thunk.step_over thunk.step },
  simp only [id, encode_cons, memory.setvs, memory.getvs, source.get,
    memory.setvp_nil, memory.getvp_cons, memory.getvp_nil,
    memory.getv_setm, memory.getm_setm, memory.getv_null,
    memory.getv_setv, ← memory.setv_setm, memory.setv_setv,
    fin.mk_zero, vector.map_cons, vector.nth_cons_zero,
    (one_ne_zero' μ), if_false],
  apply thunk.apply_step_over,
  { unfold thunk.step_over thunk.step instruction.move },
  simp only [memory.setms, memory.getms, source.get,
    memory.setmp_cons, memory.setmp_nil, memory.getmp_cons, memory.getmp_nil,
    memory.mop],
  apply thunk.apply_step_over_call,
  { simp only [memory.getms, source.get,
      memory.getmp_cons, memory.getmp_nil,
      memory.getm_setm, memory.getm_setm_ne _ 1 _ 0 (zero_ne_one' μ)],
    rw [← encode_cons, ← encode_cons],
    apply split_result },
  apply thunk.apply_step_over,
  { unfold thunk.step_over thunk.step },
  simp only [memory.getms, memory.setms, source.get,
    memory.setmp_cons, memory.setmp_nil, memory.getmp_cons, memory.getmp_nil,
    memory.setm_setm, memory.getm_setm ],
  cases e : list.split (a::b::l) with l₁ l₂,
  simp only [e, encode_pair],
  apply thunk.apply_step_over_recurse,
  { simp only [memory.getms, source.get,
      memory.getmp_cons, memory.getmp_nil,
      memory.getm_setm, memory.getm_setm_ne _ 1 _ 0 (zero_ne_one' μ)],
    apply ih _ _ _ rfl,
    exact hn ▸ (list.length_split_lt e).left },
  apply thunk.apply_step_over,
  { unfold thunk.step_over thunk.step instruction.swap },
  simp only [memory.getms, memory.setms, source.get,
    memory.setmp_cons, memory.setmp_nil, memory.getmp_cons, memory.getmp_nil,
    memory.setm_setm, memory.getm_setm,
    memory.getm_setm_ne _ 1 _ 0 (zero_ne_one' μ),
    memory.setm_setm, memory.setm_setm_ne _ 1 0 _ _ (one_ne_zero' μ),
    memory.mop ],
  apply thunk.apply_step_over_recurse,
  { simp only [memory.getms, source.get,
      memory.getmp_cons, memory.getmp_nil,
      memory.getm_setm, memory.getm_setm_ne _ 1 _ 0 (zero_ne_one' μ)],
    apply ih _ _ _ rfl,
    exact hn ▸ (list.length_split_lt e).right },
  apply thunk.apply_step_over,
  { unfold thunk.step_over thunk.step },
  apply thunk.apply_step_over,
  { unfold thunk.step_over thunk.step },
  simp only [memory.getms, memory.setms, source.get,
    memory.setmp_cons, memory.setmp_nil, memory.getmp_cons, memory.getmp_nil,
    memory.setm_setm, memory.getm_setm,
    memory.getm_setm_ne _ 1 _ 0 (zero_ne_one' μ),
    memory.setm_setm, memory.setm_setm_ne _ 1 0 _ _ (one_ne_zero' μ),
    memory.mop ],
  rw [← encode_pair],
  apply thunk.apply_step_over_call,
  { simp only [memory.getms, source.get,
      memory.getmp_cons, memory.getmp_nil,
      memory.getm_setm],
      apply merge_result fcmp,
      apply hcmp },
  apply thunk.apply_step_over,
  { unfold thunk.step_over thunk.step },
  simp only [memory.getms, memory.setms, source.get,
    memory.setmp_cons, memory.setmp_nil, memory.getmp_cons, memory.getmp_nil,
    memory.setm_setm, memory.getm_setm,
    memory.getm_setm_ne _ 1 _ 0 (zero_ne_one' μ),
    memory.setm_setm, memory.setm_setm_ne _ 1 0 _ _ (one_ne_zero' μ),
    memory.mop],
  rw [list.merge_sort_cons_cons],
  exact ⟨1, rfl⟩,
  exact e,
end

end encoding
end hmem


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

! This file was ported from Lean 3 source module algebra.category.Ring.colimits
! leanprover-community/mathlib commit 70fd9563a21e7b963887c9360bd29b2393e6225a
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Category.Ring.Basic
import Mathbin.CategoryTheory.Limits.HasLimits
import Mathbin.CategoryTheory.ConcreteCategory.Elementwise

/-!
# The category of commutative rings has all colimits.

This file uses a "pre-automated" approach, just as for `Mon/colimits.lean`.
It is a very uniform approach, that conceivably could be synthesised directly
by a tactic that analyses the shape of `comm_ring` and `ring_hom`.
-/

universe u v

open CategoryTheory

open CategoryTheory.Limits

-- [ROBOT VOICE]:
-- You should pretend for now that this file was automatically generated.
-- It follows the same template as colimits in Mon.
/-
`#print comm_ring` says:

structure comm_ring : Type u → Type u
fields:
comm_ring.zero : Π (α : Type u) [c : comm_ring α], α
comm_ring.one : Π (α : Type u) [c : comm_ring α], α
comm_ring.neg : Π {α : Type u} [c : comm_ring α], α → α
comm_ring.add : Π {α : Type u} [c : comm_ring α], α → α → α
comm_ring.mul : Π {α : Type u} [c : comm_ring α], α → α → α

comm_ring.zero_add : ∀ {α : Type u} [c : comm_ring α] (a : α), 0 + a = a
comm_ring.add_zero : ∀ {α : Type u} [c : comm_ring α] (a : α), a + 0 = a
comm_ring.one_mul : ∀ {α : Type u} [c : comm_ring α] (a : α), 1 * a = a
comm_ring.mul_one : ∀ {α : Type u} [c : comm_ring α] (a : α), a * 1 = a
comm_ring.add_left_neg : ∀ {α : Type u} [c : comm_ring α] (a : α), -a + a = 0
comm_ring.add_comm : ∀ {α : Type u} [c : comm_ring α] (a b : α), a + b = b + a
comm_ring.mul_comm : ∀ {α : Type u} [c : comm_ring α] (a b : α), a * b = b * a
comm_ring.add_assoc : ∀ {α : Type u} [c : comm_ring α] (a b c_1 : α), a + b + c_1 = a + (b + c_1)
comm_ring.mul_assoc : ∀ {α : Type u} [c : comm_ring α] (a b c_1 : α), a * b * c_1 = a * (b * c_1)
comm_ring.left_distrib : ∀ {α : Type u} [c : comm_ring α] (a b c_1 : α),
                                                            a * (b + c_1) = a * b + a * c_1
comm_ring.right_distrib : ∀ {α : Type u} [c : comm_ring α] (a b c_1 : α),
                                                            (a + b) * c_1 = a * c_1 + b * c_1
-/
namespace CommRingCat.Colimits

/-!
We build the colimit of a diagram in `CommRing` by constructing the
free commutative ring on the disjoint union of all the commutative rings in the diagram,
then taking the quotient by the commutative ring laws within each commutative ring,
and the identifications given by the morphisms in the diagram.
-/

variable {J : Type v} [SmallCategory J] (F : J ⥤ CommRingCat.{v})

/-- An inductive type representing all commutative ring expressions (without relations)
on a collection of types indexed by the objects of `J`.
-/
inductive Prequotient-- There's always `of`

  | of : ∀ (j : J) (x : F.obj j), prequotient-- Then one generator for each operation

  | zero : prequotient
  | one : prequotient
  | neg : prequotient → prequotient
  | add : prequotient → prequotient → prequotient
  | mul : prequotient → prequotient → prequotient
#align CommRing.colimits.prequotient CommRingCat.Colimits.Prequotient

instance : Inhabited (Prequotient F) :=
  ⟨Prequotient.zero⟩

open Prequotient

/-- The relation on `prequotient` saying when two expressions are equal
because of the commutative ring laws, or
because one element is mapped to another by a morphism in the diagram.
-/
inductive Relation : Prequotient F → Prequotient F → Prop-- Make it an equivalence relation:

  | refl : ∀ x, relation x x
  | symm : ∀ (x y) (h : relation x y), relation y x
  |
  trans :
    ∀ (x y z) (h : relation x y) (k : relation y z), relation x z-- There's always a `map` relation

  |
  map :
    ∀ (j j' : J) (f : j ⟶ j') (x : F.obj j),
      relation (of j' (F.map f x))
        (of j x)-- Then one relation per operation, describing the interaction with `of`

  | zero : ∀ j, relation (of j 0) zero
  | one : ∀ j, relation (of j 1) one
  | neg : ∀ (j) (x : F.obj j), relation (of j (-x)) (neg (of j x))
  | add : ∀ (j) (x y : F.obj j), relation (of j (x + y)) (add (of j x) (of j y))
  |
  mul :
    ∀ (j) (x y : F.obj j),
      relation (of j (x * y))
        (mul (of j x) (of j y))-- Then one relation per argument of each operation

  | neg_1 : ∀ (x x') (r : relation x x'), relation (neg x) (neg x')
  | add_1 : ∀ (x x' y) (r : relation x x'), relation (add x y) (add x' y)
  | add_2 : ∀ (x y y') (r : relation y y'), relation (add x y) (add x y')
  | mul_1 : ∀ (x x' y) (r : relation x x'), relation (mul x y) (mul x' y)
  |
  mul_2 : ∀ (x y y') (r : relation y y'), relation (mul x y) (mul x y')-- And one relation per axiom

  | zero_add : ∀ x, relation (add zero x) x
  | add_zero : ∀ x, relation (add x zero) x
  | one_mul : ∀ x, relation (mul one x) x
  | mul_one : ∀ x, relation (mul x one) x
  | add_left_neg : ∀ x, relation (add (neg x) x) zero
  | add_comm : ∀ x y, relation (add x y) (add y x)
  | mul_comm : ∀ x y, relation (mul x y) (mul y x)
  | add_assoc : ∀ x y z, relation (add (add x y) z) (add x (add y z))
  | mul_assoc : ∀ x y z, relation (mul (mul x y) z) (mul x (mul y z))
  | left_distrib : ∀ x y z, relation (mul x (add y z)) (add (mul x y) (mul x z))
  | right_distrib : ∀ x y z, relation (mul (add x y) z) (add (mul x z) (mul y z))
#align CommRing.colimits.relation CommRingCat.Colimits.Relation

/-- The setoid corresponding to commutative expressions modulo monoid relations and identifications.
-/
def colimitSetoid : Setoid (Prequotient F)
    where
  R := Relation F
  iseqv := ⟨Relation.refl, Relation.symm, Relation.trans⟩
#align CommRing.colimits.colimit_setoid CommRingCat.Colimits.colimitSetoid

attribute [instance] colimit_setoid

/-- The underlying type of the colimit of a diagram in `CommRing`.
-/
def ColimitType : Type v :=
  Quotient (colimitSetoid F)deriving Inhabited
#align CommRing.colimits.colimit_type CommRingCat.Colimits.ColimitType

instance : AddGroup (ColimitType F)
    where
  zero := Quot.mk _ zero
  neg := by
    fapply @Quot.lift
    · intro x
      exact Quot.mk _ (neg x)
    · intro x x' r
      apply Quot.sound
      exact relation.neg_1 _ _ r
  add := by
    fapply @Quot.lift _ _ (colimit_type F → colimit_type F)
    · intro x
      fapply @Quot.lift
      · intro y
        exact Quot.mk _ (add x y)
      · intro y y' r
        apply Quot.sound
        exact relation.add_2 _ _ _ r
    · intro x x' r
      funext y
      induction y
      dsimp
      apply Quot.sound
      · exact relation.add_1 _ _ _ r
      · rfl
  zero_add x := by
    induction x
    dsimp
    apply Quot.sound
    apply relation.zero_add
    rfl
  add_zero x := by
    induction x
    dsimp
    apply Quot.sound
    apply relation.add_zero
    rfl
  add_left_neg x := by
    induction x
    dsimp
    apply Quot.sound
    apply relation.add_left_neg
    rfl
  add_assoc x y z := by
    induction x
    induction y
    induction z
    dsimp
    apply Quot.sound
    apply relation.add_assoc
    rfl
    rfl
    rfl

instance : AddGroupWithOne (ColimitType F) :=
  { ColimitType.addGroup F with one := Quot.mk _ one }

instance : CommRing (ColimitType F) :=
  { ColimitType.addGroupWithOne F with
    one := Quot.mk _ one
    mul := by
      fapply @Quot.lift _ _ (colimit_type F → colimit_type F)
      · intro x
        fapply @Quot.lift
        · intro y
          exact Quot.mk _ (mul x y)
        · intro y y' r
          apply Quot.sound
          exact relation.mul_2 _ _ _ r
      · intro x x' r
        funext y
        induction y
        dsimp
        apply Quot.sound
        · exact relation.mul_1 _ _ _ r
        · rfl
    one_mul := fun x => by
      induction x
      dsimp
      apply Quot.sound
      apply relation.one_mul
      rfl
    mul_one := fun x => by
      induction x
      dsimp
      apply Quot.sound
      apply relation.mul_one
      rfl
    add_comm := fun x y => by
      induction x
      induction y
      dsimp
      apply Quot.sound
      apply relation.add_comm
      rfl
      rfl
    mul_comm := fun x y => by
      induction x
      induction y
      dsimp
      apply Quot.sound
      apply relation.mul_comm
      rfl
      rfl
    add_assoc := fun x y z => by
      induction x
      induction y
      induction z
      dsimp
      apply Quot.sound
      apply relation.add_assoc
      rfl
      rfl
      rfl
    mul_assoc := fun x y z => by
      induction x
      induction y
      induction z
      dsimp
      apply Quot.sound
      apply relation.mul_assoc
      rfl
      rfl
      rfl
    left_distrib := fun x y z => by
      induction x
      induction y
      induction z
      dsimp
      apply Quot.sound
      apply relation.left_distrib
      rfl
      rfl
      rfl
    right_distrib := fun x y z => by
      induction x
      induction y
      induction z
      dsimp
      apply Quot.sound
      apply relation.right_distrib
      rfl
      rfl
      rfl }

@[simp]
theorem quot_zero : Quot.mk Setoid.r zero = (0 : ColimitType F) :=
  rfl
#align CommRing.colimits.quot_zero CommRingCat.Colimits.quot_zero

@[simp]
theorem quot_one : Quot.mk Setoid.r one = (1 : ColimitType F) :=
  rfl
#align CommRing.colimits.quot_one CommRingCat.Colimits.quot_one

@[simp]
theorem quot_neg (x) : Quot.mk Setoid.r (neg x) = (-Quot.mk Setoid.r x : ColimitType F) :=
  rfl
#align CommRing.colimits.quot_neg CommRingCat.Colimits.quot_neg

@[simp]
theorem quot_add (x y) :
    Quot.mk Setoid.r (add x y) = (Quot.mk Setoid.r x + Quot.mk Setoid.r y : ColimitType F) :=
  rfl
#align CommRing.colimits.quot_add CommRingCat.Colimits.quot_add

@[simp]
theorem quot_mul (x y) :
    Quot.mk Setoid.r (mul x y) = (Quot.mk Setoid.r x * Quot.mk Setoid.r y : ColimitType F) :=
  rfl
#align CommRing.colimits.quot_mul CommRingCat.Colimits.quot_mul

/-- The bundled commutative ring giving the colimit of a diagram. -/
def colimit : CommRingCat :=
  CommRingCat.of (ColimitType F)
#align CommRing.colimits.colimit CommRingCat.Colimits.colimit

/-- The function from a given commutative ring in the diagram to the colimit commutative ring. -/
def coconeFun (j : J) (x : F.obj j) : ColimitType F :=
  Quot.mk _ (of j x)
#align CommRing.colimits.cocone_fun CommRingCat.Colimits.coconeFun

/-- The ring homomorphism from a given commutative ring in the diagram to the colimit commutative
ring. -/
def coconeMorphism (j : J) : F.obj j ⟶ colimit F
    where
  toFun := coconeFun F j
  map_one' := by apply Quot.sound <;> apply relation.one
  map_mul' := by intros <;> apply Quot.sound <;> apply relation.mul
  map_zero' := by apply Quot.sound <;> apply relation.zero
  map_add' := by intros <;> apply Quot.sound <;> apply relation.add
#align CommRing.colimits.cocone_morphism CommRingCat.Colimits.coconeMorphism

@[simp]
theorem cocone_naturality {j j' : J} (f : j ⟶ j') :
    F.map f ≫ coconeMorphism F j' = coconeMorphism F j :=
  by
  ext
  apply Quot.sound
  apply Relation.Map
#align CommRing.colimits.cocone_naturality CommRingCat.Colimits.cocone_naturality

@[simp]
theorem cocone_naturality_components (j j' : J) (f : j ⟶ j') (x : F.obj j) :
    (coconeMorphism F j') (F.map f x) = (coconeMorphism F j) x :=
  by
  rw [← cocone_naturality F f]
  rfl
#align CommRing.colimits.cocone_naturality_components CommRingCat.Colimits.cocone_naturality_components

/-- The cocone over the proposed colimit commutative ring. -/
def colimitCocone : Cocone F where
  pt := colimit F
  ι := { app := coconeMorphism F }
#align CommRing.colimits.colimit_cocone CommRingCat.Colimits.colimitCocone

/-- The function from the free commutative ring on the diagram to the cone point of any other
cocone. -/
@[simp]
def descFunLift (s : Cocone F) : Prequotient F → s.pt
  | of j x => (s.ι.app j) x
  | zero => 0
  | one => 1
  | neg x => -desc_fun_lift x
  | add x y => desc_fun_lift x + desc_fun_lift y
  | mul x y => desc_fun_lift x * desc_fun_lift y
#align CommRing.colimits.desc_fun_lift CommRingCat.Colimits.descFunLift

/-- The function from the colimit commutative ring to the cone point of any other cocone. -/
def descFun (s : Cocone F) : ColimitType F → s.pt :=
  by
  fapply Quot.lift
  · exact desc_fun_lift F s
  · intro x y r
    induction r <;> try dsimp
    -- refl
    · rfl
    -- symm
    · exact r_ih.symm
    -- trans
    · exact Eq.trans r_ih_h r_ih_k
    -- map
    · simp
    -- zero
    · simp
    -- one
    · simp
    -- neg
    · simp
    -- add
    · simp
    -- mul
    · simp
    -- neg_1
    · rw [r_ih]
    -- add_1
    · rw [r_ih]
    -- add_2
    · rw [r_ih]
    -- mul_1
    · rw [r_ih]
    -- mul_2
    · rw [r_ih]
    -- zero_add
    · rw [zero_add]
    -- add_zero
    · rw [add_zero]
    -- one_mul
    · rw [one_mul]
    -- mul_one
    · rw [mul_one]
    -- add_left_neg
    · rw [add_left_neg]
    -- add_comm
    · rw [add_comm]
    -- mul_comm
    · rw [mul_comm]
    -- add_assoc
    · rw [add_assoc]
    -- mul_assoc
    · rw [mul_assoc]
    -- left_distrib
    · rw [left_distrib]
    -- right_distrib
    · rw [right_distrib]
#align CommRing.colimits.desc_fun CommRingCat.Colimits.descFun

/-- The ring homomorphism from the colimit commutative ring to the cone point of any other
cocone. -/
def descMorphism (s : Cocone F) : colimit F ⟶ s.pt
    where
  toFun := descFun F s
  map_one' := rfl
  map_zero' := rfl
  map_add' x y := by induction x <;> induction y <;> rfl
  map_mul' x y := by induction x <;> induction y <;> rfl
#align CommRing.colimits.desc_morphism CommRingCat.Colimits.descMorphism

/-- Evidence that the proposed colimit is the colimit. -/
def colimitIsColimit : IsColimit (colimitCocone F)
    where
  desc s := descMorphism F s
  uniq s m w := by
    ext
    induction x
    induction x
    · have w' :=
        congr_fun (congr_arg (fun f : F.obj x_j ⟶ s.X => (f : F.obj x_j → s.X)) (w x_j)) x_x
      erw [w']
      rfl
    · simp
    · simp
    · simp [*]
    · simp [*]
    · simp [*]
    rfl
#align CommRing.colimits.colimit_is_colimit CommRingCat.Colimits.colimitIsColimit

instance hasColimits_commRingCat : HasColimits CommRingCat
    where HasColimitsOfShape J 𝒥 :=
    {
      HasColimit := fun F =>
        has_colimit.mk
          { Cocone := colimit_cocone F
            IsColimit := colimit_is_colimit F } }
#align CommRing.colimits.has_colimits_CommRing CommRingCat.Colimits.hasColimits_commRingCat

end CommRingCat.Colimits


import .basic --.single
namespace ftype
-- Embedding and subftypeebras

open_locale classical
noncomputable theory

def subftype {A : ftype} (ground : set A) : ftype :=
  {E := {x : A // x ∈ ground}, fin := by {apply_instance}}

@[ext] structure embed (A B : ftype) :=
  (f     : A → B )
  (f_inj : function.injective f)

instance emb_to_fn {A B : ftype} : has_coe_to_fun (embed A B) := {F := λ _, A → B.E, coe := embed.f}

def embed.img {A B : ftype} (emb : embed A B) : set A → set B :=
  λ X, (X.image emb)

--instance emb_to_set_fn {A B : ftype} : has_coe (embed A B) (set A → set B.E) := ⟨embed.img⟩

lemma embed.on_subset {A B : ftype} (emb : embed A B) {X Y : set A} :
  (X ⊆ Y) → (emb.img X) ⊆ (emb.img Y) :=
  λ h, by tidy

lemma embed.on_size {A B : ftype} (emb : embed A B) (X : set A) :
  size (emb.img X) = size X :=
begin
  simp only [size, size_nat, int.coe_nat_inj'],
  rw (by {simp [as_finset], tidy,} : (as_finset B (emb.img X)) = finset.image emb.f (as_finset A X)),
  apply finset.card_image_of_injective, apply emb.f_inj,
end

lemma embed.on_inter {A B : ftype} (emb : embed A B) {X Y : set A} :
  emb.img (X ∩ Y) = emb.img X ∩ emb.img Y :=
  (set.image_inter emb.f_inj).symm

lemma embed.on_union {A B : ftype} (emb : embed A B) {X Y : set A} :
  emb.img (X ∪ Y) = emb.img X ∪ emb.img Y :=
  set.image_union _ _ _

def embed.id {A : ftype} : embed A A :=
  ⟨id, function.injective_id⟩

def embed.compose {A B C: ftype} : (embed A B) → (embed B C) → (embed A C) := λ e1 e2,
  ⟨e2.f ∘ e1.f, λ x x' h, e1.f_inj (e2.f_inj h)⟩

def embed.from_subftype {A : ftype} (X : set A) : embed (subftype X) A :=
  ⟨λ e, e.val, by tidy⟩

def embed.from_nested_pair {A : ftype} {X₁ X₂ : set A} (hX₁X₂ : X₁ ⊆ X₂) : embed (subftype X₁) (subftype X₂) :=
  ⟨λ x, ⟨x.1, by tidy⟩, by tidy⟩

lemma embed.compose_subset_nested_pair {A : ftype} (X₁ X₂ : set A) (hX₁X₂ : X₁ ⊆ X₂) :
 (embed.compose (embed.from_nested_pair hX₁X₂) (embed.from_subftype X₂)) = embed.from_subftype X₁ := rfl

lemma embed.compose_nested_triple {A : ftype} (X₁ X₂ X₃ : set A) (h₁₂ : X₁ ⊆ X₂) (h₂₃ : X₂ ⊆ X₃) :
  (embed.compose (embed.from_nested_pair h₁₂) (embed.from_nested_pair h₂₃)) = embed.from_nested_pair (subset.trans h₁₂ h₂₃) := rfl

--Subalgebra coercion

--instance coe_to_coe_set {α β: Type} [has_coe α β] : has_coe (set α) (set β) := ⟨λ X, coe '' X⟩

instance coe_mem_from_subftype {A : ftype} {S : set A} : has_coe (subftype S) A := ⟨subtype.val⟩

instance coe_set_from_subftype {A : ftype} {S : set A} : has_coe (set (subftype S)) (set A) := ⟨λ X, coe '' X⟩

--instance coe_single_from_subftype {A : ftype} {S : set A} : has_coe (single (subftype S)) (single A) := ⟨(embed.from_subset S).single_emb⟩

--@[simp] lemma coe_single_subftype_compose {A : ftype} {S : set A} (e : single (subftype S)) : ((e: single A) : set A) = (e : set A) := rfl
--lemma coe_subftype_single_compose {A : ftype} {S : set A} (e : single (subftype S)) : ((e: subftype S) : set A) = (e : set A) := rfl

@[simp] lemma subftype_coe_size {A : ftype} {S : set A} (X : set (subftype S)) : size X = size (X : set A) :=
  ((embed.from_subftype S).on_size X).symm

@[simp] lemma subftype_coe_subset {A : ftype} {S : set A} {X Y : set (subftype S)} : (X ⊆ Y) ↔ ((X: set A) ⊆ (Y: set A)) :=
begin
  refine ⟨λ h, (embed.from_subftype S).on_subset h, λ h, _⟩,
  have h1 : ∀ (Z : set (subftype S)), (Z : set A) = (coe '' Z) := λ Z, rfl,
  rw [h1 X, h1 Y, subtype.coe_image, subtype.coe_image] at h,
  intros x hx, cases x,
  cases @h x_val ⟨x_property, hx⟩,
  assumption,
end

@[simp] lemma subftype_coe_union {A : ftype} {S : set A} {X Y : set (subftype S)} :
  (((X ∪ Y) : set (subftype S)) : set A) = ((X: set A) ∪ (Y:set A)) :=
  (embed.from_subftype S).on_union

@[simp] lemma subftype_coe_inter {A : ftype} {S : set A} {X Y : set (subftype S)} :
  (((X ∩ Y) : set (subftype S)) : set A) = ((X: set A) ∩ (Y:set A)) :=
  (embed.from_subftype S).on_inter

@[simp] lemma subftype_coe_compl {A : ftype} {S : set A} {X : set (subftype S)} :
  (((Xᶜ : set (subftype S))) : set A) = S \ (X : set A)  :=
begin
  -- Fix this garbage!
  unfold_coes, ext, refine ⟨λ h, ⟨_,_⟩, λ h,_⟩,
  rcases h with ⟨_,⟨_,_⟩⟩, rw ←h_h_right, tidy, apply h_h_left,
  have := (embed.from_subftype S).f_inj h_h_right,
  rw this, assumption,
  -- No really, fix it!
end

@[simp] lemma coe_univ {A : ftype} (S : set A) :
  ((univ : set (subftype S)) : set A) = S :=
by tidy

@[simp] lemma coe_empty {A : ftype} (S : set A) :
  ((∅ : set (subftype S)) : set A) = ∅ :=
by tidy

@[simp] lemma coe_set_is_subset {A : ftype} {S : set A} (X : set (subftype S)) :
  (X : set A) ⊆ S :=
by tidy

@[simp] lemma coe_img_set {A : ftype} {Y Y' : set A} (hYY' : Y ⊆ Y') (X : set (subftype Y)) :
  (((embed.from_nested_pair hYY').img X) : set A) = (X : set A) :=
by {simp only [embed.img], unfold_coes, tidy}

@[simp] lemma coe_img_elem {A : ftype} {Y Y' : set A} (hYY' : Y ⊆ Y') (x : subftype Y) :
  (((embed.from_nested_pair hYY') x ) : A) = (x : A) :=
by {unfold_coes, tidy}

-- This next coe doesn't seem to work in practice, even when a P ⊆ Q proof term is in the local context

--instance coe_from_nested_pair {A : ftype} {P Q: set A} {hPQ : P ⊆ Q} : has_coe (subftype P) (subftype Q)
--  := ⟨(embed.from_nested_pair hPQ).f⟩

--instance coe_set_from_nested_pair {A : ftype} {P Q: set A} {hPQ : P ⊆ Q} : has_coe (set (subftype P).E) (set (subftype Q).E)
--  := ⟨λ (X : set (subftype P).E), ((embed.from_nested_pair).f '' X : set (subftype Q).E)⟩

/-instance embed.coe_to_fun {A B : ftype.ftype} : has_coe_to_fun (ftype.embed A B) := {
  F := (λ _, A → B),
  coe := λ emb, emb.f,
}-/
--def subftype.embed {E : set A} : ftype.embed (subftype E) A := sorry

---- Isomorphisms

structure iso (A B : ftype) :=
  (fwd : embed A B)
  (bwd : embed B A)
  (fwd_then_bwd : embed.compose fwd bwd = embed.id)
  (bwd_then_fwd : embed.compose bwd fwd = embed.id)

--def ftype.canonical (size : ℤ) :
--  (0 ≤ size) → ftype := sorry

-- Construct a ftype from a finite set S (probably deprecated)
def powersetalg (γ : Type)[fintype γ] : ftype :=
{
  E       := γ,
  fin  := by apply_instance,
}

end ftype


/-
Copyright (c) 2020 David Wärn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: David Wärn
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.order.ideal
import Mathlib.data.finset.default
import Mathlib.PostPort

universes u_1 u_2

namespace Mathlib

/-!
# The back and forth method and countable dense linear orders

## Results

Suppose `α β` are linear orders, with `α` countable and `β` dense, nonempty, without endpoints.
Then there is an order embedding `α ↪ β`. If in addition `α` is dense, nonempty, without
endpoints and `β` is countable, then we can upgrade this to an order isomorhpism `α ≃ β`.

The idea for both results is to consider "partial isomorphisms", which
identify a finite subset of `α` with a finite subset of `β`, and prove that
for any such partial isomorphism `f` and `a : α`, we can extend `f` to
include `a` in its domain.

## References

https://en.wikipedia.org/wiki/Back-and-forth_method

## Tags

back and forth, dense, countable, order

-/

namespace order

/-- Suppose `α` is a nonempty dense linear order without endpoints, and
    suppose `lo`, `hi`, are finite subssets with all of `lo` strictly
    before `hi`. Then there is an element of `α` strictly between `lo`
    and `hi`. -/
theorem exists_between_finsets {α : Type u_1} [linear_order α] [densely_ordered α] [no_bot_order α] [no_top_order α] [nonem : Nonempty α] (lo : finset α) (hi : finset α) (lo_lt_hi : ∀ (x : α), x ∈ lo → ∀ (y : α), y ∈ hi → x < y) : ∃ (m : α), (∀ (x : α), x ∈ lo → x < m) ∧ ∀ (y : α), y ∈ hi → m < y := sorry

/-- The type of partial order isomorphisms between `α` and `β` defined on finite subsets.
    A partial order isomorphism is encoded as a finite subset of `α × β`, consisting
    of pairs which should be identified. -/
def partial_iso (α : Type u_1) (β : Type u_2) [linear_order α] [linear_order β] :=
  Subtype
    fun (f : finset (α × β)) =>
      ∀ (p q : α × β), p ∈ f → q ∈ f → cmp (prod.fst p) (prod.fst q) = cmp (prod.snd p) (prod.snd q)

namespace partial_iso

protected instance inhabited (α : Type u_1) (β : Type u_2) [linear_order α] [linear_order β] : Inhabited (partial_iso α β) :=
  { default := { val := ∅, property := sorry } }

protected instance preorder (α : Type u_1) (β : Type u_2) [linear_order α] [linear_order β] : preorder (partial_iso α β) :=
  subtype.preorder
    fun (f : finset (α × β)) =>
      ∀ (p q : α × β), p ∈ f → q ∈ f → cmp (prod.fst p) (prod.fst q) = cmp (prod.snd p) (prod.snd q)

/-- For each `a`, we can find a `b` in the codomain, such that `a`'s relation to
the domain of `f` is `b`'s relation to the image of `f`.

Thus, if `a` is not already in `f`, then we can extend `f` by sending `a` to `b`.
-/
theorem exists_across {α : Type u_1} {β : Type u_2} [linear_order α] [linear_order β] [densely_ordered β] [no_bot_order β] [no_top_order β] [Nonempty β] (f : partial_iso α β) (a : α) : ∃ (b : β), ∀ (p : α × β), p ∈ subtype.val f → cmp (prod.fst p) a = cmp (prod.snd p) b := sorry

/-- A partial isomorphism between `α` and `β` is also a partial isomorphism between `β` and `α`. -/
protected def comm {α : Type u_1} {β : Type u_2} [linear_order α] [linear_order β] : partial_iso α β → partial_iso β α :=
  subtype.map (finset.image ⇑(equiv.prod_comm α β)) sorry

/-- The set of partial isomorphisms defined at `a : α`, together with a proof that any
    partial isomorphism can be extended to one defined at `a`. -/
def defined_at_left {α : Type u_1} (β : Type u_2) [linear_order α] [linear_order β] [densely_ordered β] [no_bot_order β] [no_top_order β] [Nonempty β] (a : α) : cofinal (partial_iso α β) :=
  cofinal.mk (fun (f : partial_iso α β) => ∃ (b : β), (a, b) ∈ subtype.val f) sorry

/-- The set of partial isomorphisms defined at `b : β`, together with a proof that any
    partial isomorphism can be extended to include `b`. We prove this by symmetry. -/
def defined_at_right (α : Type u_1) {β : Type u_2} [linear_order α] [linear_order β] [densely_ordered α] [no_bot_order α] [no_top_order α] [Nonempty α] (b : β) : cofinal (partial_iso α β) :=
  cofinal.mk (fun (f : partial_iso α β) => ∃ (a : α), (a, b) ∈ subtype.val f) sorry

/-- Given an ideal which intersects `defined_at_left β a`, pick `b : β` such that
    some partial function in the ideal maps `a` to `b`. -/
def fun_of_ideal {α : Type u_1} {β : Type u_2} [linear_order α] [linear_order β] [densely_ordered β] [no_bot_order β] [no_top_order β] [Nonempty β] (a : α) (I : ideal (partial_iso α β)) : (∃ (f : partial_iso α β), f ∈ defined_at_left β a ∧ f ∈ I) →
  Subtype
    fun (b : β) =>
      ∃ (f :
        Subtype
          fun (f : finset (α × β)) =>
            ∀ (p q : α × β), p ∈ f → q ∈ f → cmp (prod.fst p) (prod.fst q) = cmp (prod.snd p) (prod.snd q)),
        ∃ (H : f ∈ I), (a, b) ∈ subtype.val f :=
  (classical.indefinite_description
      fun (x : β) =>
        ∃ (f :
          Subtype
            fun (f : finset (α × β)) =>
              ∀ (p q : α × β), p ∈ f → q ∈ f → cmp (prod.fst p) (prod.fst q) = cmp (prod.snd p) (prod.snd q)),
          ∃ (H : f ∈ I), (a, x) ∈ subtype.val f) ∘
    sorry

/-- Given an ideal which intersects `defined_at_right α b`, pick `a : α` such that
    some partial function in the ideal maps `a` to `b`. -/
def inv_of_ideal {α : Type u_1} {β : Type u_2} [linear_order α] [linear_order β] [densely_ordered α] [no_bot_order α] [no_top_order α] [Nonempty α] (b : β) (I : ideal (partial_iso α β)) : (∃ (f : partial_iso α β), f ∈ defined_at_right α b ∧ f ∈ I) →
  Subtype
    fun (a : α) =>
      ∃ (f :
        Subtype
          fun (f : finset (α × β)) =>
            ∀ (p q : α × β), p ∈ f → q ∈ f → cmp (prod.fst p) (prod.fst q) = cmp (prod.snd p) (prod.snd q)),
        ∃ (H : f ∈ I), (a, b) ∈ subtype.val f :=
  (classical.indefinite_description
      fun (x : α) =>
        ∃ (f :
          Subtype
            fun (f : finset (α × β)) =>
              ∀ (p q : α × β), p ∈ f → q ∈ f → cmp (prod.fst p) (prod.fst q) = cmp (prod.snd p) (prod.snd q)),
          ∃ (H : f ∈ I), (x, b) ∈ subtype.val f) ∘
    sorry

end partial_iso

/-- Any countable linear order embeds in any nonempty dense linear order without endpoints. -/
def embedding_from_countable_to_dense (α : Type u_1) (β : Type u_2) [linear_order α] [linear_order β] [encodable α] [densely_ordered β] [no_bot_order β] [no_top_order β] [Nonempty β] : α ↪o β :=
  let our_ideal : ideal (partial_iso α β) := ideal_of_cofinals Inhabited.default (partial_iso.defined_at_left β);
  let F :
    (a : α) →
      Subtype
        fun (b : β) =>
          ∃ (f :
            Subtype
              fun (f : finset (α × β)) =>
                ∀ (p q : α × β), p ∈ f → q ∈ f → cmp (prod.fst p) (prod.fst q) = cmp (prod.snd p) (prod.snd q)),
            ∃ (H : f ∈ our_ideal), (a, b) ∈ subtype.val f :=
    fun (a : α) => partial_iso.fun_of_ideal a our_ideal sorry;
  order_embedding.of_strict_mono (fun (a : α) => subtype.val (F a)) sorry

/-- Any two countable dense, nonempty linear orders without endpoints are order isomorphic. -/
def iso_of_countable_dense (α : Type u_1) (β : Type u_2) [linear_order α] [linear_order β] [encodable α] [densely_ordered α] [no_bot_order α] [no_top_order α] [Nonempty α] [encodable β] [densely_ordered β] [no_bot_order β] [no_top_order β] [Nonempty β] : α ≃o β := sorry


/-
Copyright (c) 2020 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.field_theory.minpoly
import Mathlib.field_theory.splitting_field
import Mathlib.field_theory.tower
import Mathlib.ring_theory.power_basis
import Mathlib.PostPort

universes u_1 u_2 u_3 u_4

namespace Mathlib

/-!
# Normal field extensions

In this file we define normal field extensions and prove that for a finite extension, being normal
is the same as being a splitting field (`normal.of_is_splitting_field` and
`normal.exists_is_splitting_field`).

## Main Definitions

- `normal F K` where `K` is a field extension of `F`.
-/

--TODO(Commelin): refactor normal to extend `is_algebraic`??

/-- Typeclass for normal field extension: `K` is a normal extension of `F` iff the minimal
polynomial of every element `x` in `K` splits in `K`, i.e. every conjugate of `x` is in `K`. -/
def normal (F : Type u_1) (K : Type u_2) [field F] [field K] [algebra F K] :=
  ∀ (x : K), is_integral F x ∧ polynomial.splits (algebra_map F K) (minpoly F x)

protected instance normal_self (F : Type u_1) [field F] : normal F F :=
  fun (x : F) =>
    { left := is_integral_algebra_map,
      right :=
        eq.mpr (id (Eq._oldrec (Eq.refl (polynomial.splits (algebra_map F F) (minpoly F x))) (minpoly.eq_X_sub_C' x)))
          (polynomial.splits_X_sub_C (algebra_map F F)) }

theorem normal.is_integral (F : Type u_1) {K : Type u_2} [field F] [field K] [algebra F K] [h : normal F K] (x : K) : is_integral F x :=
  and.left (h x)

theorem normal.splits (F : Type u_1) {K : Type u_2} [field F] [field K] [algebra F K] [h : normal F K] (x : K) : polynomial.splits (algebra_map F K) (minpoly F x) :=
  and.right (h x)

theorem normal.exists_is_splitting_field (F : Type u_1) (K : Type u_2) [field F] [field K] [algebra F K] [normal F K] [finite_dimensional F K] : ∃ (p : polynomial F), polynomial.is_splitting_field F K p := sorry

theorem normal.tower_top_of_normal (F : Type u_1) (K : Type u_2) [field F] [field K] [algebra F K] (E : Type u_3) [field E] [algebra F E] [algebra K E] [is_scalar_tower F K E] [h : normal F E] : normal K E := sorry

theorem normal.of_alg_equiv {F : Type u_1} [field F] {E : Type u_3} [field E] [algebra F E] {E' : Type u_4} [field E'] [algebra F E'] [h : normal F E] (f : alg_equiv F E E') : normal F E' := sorry

theorem alg_equiv.transfer_normal {F : Type u_1} [field F] {E : Type u_3} [field E] [algebra F E] {E' : Type u_4} [field E'] [algebra F E'] (f : alg_equiv F E E') : normal F E ↔ normal F E' :=
  { mp := fun (h : normal F E) => normal.of_alg_equiv f,
    mpr := fun (h : normal F E') => normal.of_alg_equiv (alg_equiv.symm f) }

theorem normal.of_is_splitting_field {F : Type u_1} [field F] {E : Type u_3} [field E] [algebra F E] {p : polynomial F} [hFEp : polynomial.is_splitting_field F E p] : normal F E := sorry

/-- Restrict algebra homomorphism to image of normal subfield -/
def alg_hom.restrict_normal_aux {F : Type u_1} {K : Type u_2} [field F] [field K] [algebra F K] (ϕ : alg_hom F K K) (E : Type u_3) [field E] [algebra F E] [algebra E K] [is_scalar_tower F E K] [h : normal F E] : alg_hom F ↥(alg_hom.range (is_scalar_tower.to_alg_hom F E K)) ↥(alg_hom.range (is_scalar_tower.to_alg_hom F E K)) :=
  alg_hom.mk (fun (x : ↥(alg_hom.range (is_scalar_tower.to_alg_hom F E K))) => { val := coe_fn ϕ ↑x, property := sorry })
    sorry sorry sorry sorry sorry

/-- Restrict algebra homomorphism to normal subfield -/
def alg_hom.restrict_normal {F : Type u_1} {K : Type u_2} [field F] [field K] [algebra F K] (ϕ : alg_hom F K K) (E : Type u_3) [field E] [algebra F E] [algebra E K] [is_scalar_tower F E K] [normal F E] : alg_hom F E E :=
  alg_hom.comp
    (alg_hom.comp
      (alg_equiv.to_alg_hom (alg_equiv.symm (alg_hom.alg_equiv.of_injective_field (is_scalar_tower.to_alg_hom F E K))))
      (alg_hom.restrict_normal_aux ϕ E))
    (alg_equiv.to_alg_hom (alg_hom.alg_equiv.of_injective_field (is_scalar_tower.to_alg_hom F E K)))

theorem alg_hom.restrict_normal_commutes {F : Type u_1} {K : Type u_2} [field F] [field K] [algebra F K] (ϕ : alg_hom F K K) (E : Type u_3) [field E] [algebra F E] [algebra E K] [is_scalar_tower F E K] [normal F E] (x : E) : coe_fn (algebra_map E K) (coe_fn (alg_hom.restrict_normal ϕ E) x) = coe_fn ϕ (coe_fn (algebra_map E K) x) := sorry

theorem alg_hom.restrict_normal_comp {F : Type u_1} {K : Type u_2} [field F] [field K] [algebra F K] (ϕ : alg_hom F K K) (ψ : alg_hom F K K) (E : Type u_3) [field E] [algebra F E] [algebra E K] [is_scalar_tower F E K] [normal F E] : alg_hom.comp (alg_hom.restrict_normal ϕ E) (alg_hom.restrict_normal ψ E) = alg_hom.restrict_normal (alg_hom.comp ϕ ψ) E := sorry

/-- Restrict algebra isomorphism to a normal subfield -/
def alg_equiv.restrict_normal {F : Type u_1} {K : Type u_2} [field F] [field K] [algebra F K] (χ : alg_equiv F K K) (E : Type u_3) [field E] [algebra F E] [algebra E K] [is_scalar_tower F E K] [h : normal F E] : alg_equiv F E E :=
  alg_equiv.of_alg_hom (alg_hom.restrict_normal (alg_equiv.to_alg_hom χ) E)
    (alg_hom.restrict_normal (alg_equiv.to_alg_hom (alg_equiv.symm χ)) E) sorry sorry

theorem alg_equiv.restrict_normal_commutes {F : Type u_1} {K : Type u_2} [field F] [field K] [algebra F K] (χ : alg_equiv F K K) (E : Type u_3) [field E] [algebra F E] [algebra E K] [is_scalar_tower F E K] [normal F E] (x : E) : coe_fn (algebra_map E K) (coe_fn (alg_equiv.restrict_normal χ E) x) = coe_fn χ (coe_fn (algebra_map E K) x) :=
  alg_hom.restrict_normal_commutes (alg_equiv.to_alg_hom χ) E x

theorem alg_equiv.restrict_normal_trans {F : Type u_1} {K : Type u_2} [field F] [field K] [algebra F K] (χ : alg_equiv F K K) (ω : alg_equiv F K K) (E : Type u_3) [field E] [algebra F E] [algebra E K] [is_scalar_tower F E K] [normal F E] : alg_equiv.restrict_normal (alg_equiv.trans χ ω) E =
  alg_equiv.trans (alg_equiv.restrict_normal χ E) (alg_equiv.restrict_normal ω E) := sorry

/-- Restriction to an normal subfield as a group homomorphism -/
def alg_equiv.restrict_normal_hom {F : Type u_1} {K : Type u_2} [field F] [field K] [algebra F K] (E : Type u_3) [field E] [algebra F E] [algebra E K] [is_scalar_tower F E K] [normal F E] : alg_equiv F K K →* alg_equiv F E E :=
  monoid_hom.mk' (fun (χ : alg_equiv F K K) => alg_equiv.restrict_normal χ E) sorry


/-
Copyright (c) 2020 Barinder Singh Banwait. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Barinder Singh Banwait, with lots of help from the good folk on the Leanprover Zulip chat :)
-/
import ring_theory.noetherian
import ring_theory.integral_closure
import ring_theory.adjoin
import ring_theory.algebra
import ring_theory.localization
import linear_algebra.basic

/-!
# Integrally closedness

Let R ⊆ A be an extension of integral domains.

## Main definitions

* `is_integrally_closed_in R A : Prop` is the assertion that `R` is integrally closed in `A`. It is
   a structure, implemented as the predicate that all elements of `A` that are integral over `R`
   already belong to `R`.

* `is_integrally_closed R` is the definition that `R` is integrally closed in an absolute sense.
   This is implemented as the following implication: if for all `r` and `s` in `R` with `s ≠ 0`,
   `r^n ∈ ⟨ r^{n-1}s, ⋯ , s^n ⟩

## Main statements

* `fundamental_theorem_integrally_closedness` is the statement that an integral domain is integrally
  closed if and only if it is integrall closed in a field of fractions.

## References

* [J. Neukirch, *Algebraic Number Theory*][neukirch-ant]

## Tags

Integrally closed

-/

universes u v

variables (R : Type u) {A : Type v}
variables [comm_ring R] [comm_ring A]
variables [algebra R A]
variables i : ℕ
variables (K : Type*)
open submodule
open function
open finset
open_locale big_operators

structure is_integrally_closed_in (R : Type u) (A : Type v) [comm_ring R] [comm_ring A]
[algebra R A] : Prop :=
(inj : injective (algebra_map R A))
(closed : ∀ (a : A), is_integral R a → ∃  r : R, algebra_map R A r = a)

-- def my_set (R) [integral_domain R] (r : R) (s : R) (n : ℕ) :=
-- { x | ∃ (i:ℕ ) (h : 0≤ i) (h2 :i≤ n-1), x = r^(n-1-i) *s^(i+1) }

def my_set (R) [integral_domain R] (r : R) (s : R) (n : ℕ) :=
{ x | ∃ (c : ℕ × ℕ) (hy: c ∈ (finset.nat.antidiagonal n).erase ⟨0, n⟩), x = r ^ c.2 * s ^ c.1 }

def is_integrally_closed (R) [integral_domain R] : Prop :=
∀ (r : R) (s : R), (s ≠ 0) ∧ (∃ n : ℕ ,
r^n ∈ span R (my_set R r s n)) → s ∣ r

open submodule

lemma mwe (R) [integral_domain R] (n : ℕ) (f : ℕ → R) (hf : f 0 = 1) : ∀ ⦃r s : R⦄, s ≠ 0 →
  ∑ ij in finset.nat.antidiagonal n, f ij.1 * r ^ ij.2 * s ^ ij.1 = 0 →
  r^n ∈ span R (my_set R r s n) :=
begin
  intros r s,
  intro s_non_zero,
  intro H,
  let p' : ℕ × ℕ := ⟨0, n⟩,
  have LM : p' ∈ finset.nat.antidiagonal n,
  {
    rw finset.nat.mem_antidiagonal,
    linarith,
  },
  rw ← finset.insert_erase LM at H,
  simp at H,
  rw hf at H,
  simp at H,
  have KL : r^n = -∑ (x : ℕ × ℕ) in (nat.antidiagonal n).erase p', f x.fst * r ^ x.snd * s ^ x.fst,
  {
    exact eq_neg_of_add_eq_zero H,
  },
  rw KL,
  rw my_set,
  rw mem_span,
  intro p,
  intro p_H,
  rw ideal.neg_mem_iff p,
  apply sum_mem,
  intro c,
  intro c_H,
  have x_in_my_set : r ^ c.snd * s ^ c.fst ∈ {x : R | ∃ (c : ℕ × ℕ) (hy : c ∈ (nat.antidiagonal n).erase (0, n)), x = r ^ c.snd * s ^ c.fst},
  {
    simp,
    use c.fst,
    use c.snd,
    split,
    split,
    intro something,
    by_contradiction HAPPY,
    have obv : c = p',
    {
      exact prod.ext something HAPPY,
    },
    rw obv at c_H,
    rw mem_erase at c_H,
    cases c_H,
    contradiction,
    rw ← finset.nat.mem_antidiagonal,
    rw mem_erase at c_H,
    cases c_H with c_H_1 c_H_2,
    exact c_H_2,
    refl,
  },
  have x_in_p : r ^ c.snd * s ^ c.fst ∈ ↑p,
  {
    exact set.mem_of_mem_of_subset x_in_my_set p_H,
  },
  rw mul_assoc,
  exact p.smul_mem (f c.fst) x_in_p,
end

lemma lin_comb_mem (R) [integral_domain R] (n : ℕ) (r s : R) (s_non_zero : s ≠ 0) :
  r^n ∈ span R (my_set R r s n) → ∃ (f : ℕ → R) (h_f: f 0 = 1),
  ∑ ij in finset.nat.antidiagonal n, f ij.1 * r ^ ij.2 * s ^ ij.1 = 0 :=
begin
  intro H,
  -- trying finsupp.mem_span_iff_total but it just isn't working :(
  sorry,
end

lemma mwe_deluxe (R) [integral_domain R] (n : ℕ) {r s : R} (h_s : s ≠ 0) :
  r^n ∈ span R (my_set R r s n) ↔ ∃ (f : ℕ → R) (hf : f 0 = 1), ∑ ij in finset.nat.antidiagonal n, f ij.1 * r ^ ij.2 * s ^ ij.1 = 0 :=
begin
  split,
  intro H,
  apply lin_comb_mem,
  exact h_s,
  exact H,
  intro k,
  cases k with f B,
  cases B with C HC,
  apply mwe,
  exact C,
  exact h_s,
  exact HC,
end

lemma equiv_johan_absolute_deluxe (R) [integral_domain R] :
  is_integrally_closed R ↔ ∀ (r s : R), s ≠ 0 → (∃ (n : ℕ) (f : ℕ → R) (hf : f 0 = 1),
  ∑ ij in finset.nat.antidiagonal n, f ij.1 * r ^ ij.2 * s ^ ij.1 = 0) → s ∣ r :=
begin
  split,
  intros h r s,
  intro k,
  unfold is_integrally_closed at h,
  specialize h r s,
  intro m,
  apply h,
  split,
  exact k,
  cases m with n m1,
  cases m1 with f m2,
  cases m2 with hf m3,
  use n,
  rw mwe_deluxe,
  use f,
  split,
  exact hf,
  exact m3,
  exact k,
  unfold is_integrally_closed,
  intro H,
  intros r s,
  intro H2,
  cases H2 with A B,
  apply H,
  exact A,
  cases B with n B_n,
  use n,
  specialize H r s A,
  rw mwe_deluxe at B_n,
  exact B_n,
  exact A,
end

lemma fundamental_theorem_integrally_closedness (R : Type u) (A : Type v) [integral_domain R]
[comm_ring A] [algebra R A] (H : fraction_map R A):
  is_integrally_closed R ↔ is_integrally_closed_in R A :=
begin
  split,
  rw equiv_johan_absolute_deluxe,
  intro H,
  sorry,
  sorry,
end

-- class dedekind_domain (α : Type*) extends integral_domain α :=
-- (noetherian : is_noetherian_ring α)
-- (factors_prod : ∀{a : α}, a ≠ 0 → (factors a).prod ~ᵤ a)
-- (prime_factors : ∀{a : α}, a ≠ 0 → ∀x∈factors a, prime x)


/-
Copyright (c) 2021 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Adam Topaz
-/
import category_theory.limits.creates
import category_theory.sites.sheafification

/-!

# Limits and colimits of sheaves

## Limits

We prove that the forgetful functor from `Sheaf J D` to presheaves creates limits.
If the target category `D` has limits (of a certain shape),
this then implies that `Sheaf J D` has limits of the same shape and that the forgetful
functor preserves these limits.

## Colimits

Given a diagram `F : K ⥤ Sheaf J D` of sheaves, and a colimit cocone on the level of presheaves,
we show that the cocone obtained by sheafifying the cocone point is a colimit cocone of sheaves.

This allows us to show that `Sheaf J D` has colimits (of a certain shape) as soon as `D` does.

-/
namespace category_theory
namespace Sheaf

open category_theory.limits
open opposite

section limits

universes w v u
variables {C : Type (max v u)} [category.{v} C] {J : grothendieck_topology C}
variables {D : Type w} [category.{max v u} D]
variables {K : Type (max v u)} [small_category K]

noncomputable theory

section

/-- An auxiliary definition to be used below.

Whenever `E` is a cone of shape `K` of sheaves, and `S` is the multifork associated to a
covering `W` of an object `X`, with respect to the cone point `E.X`, this provides a cone of
shape `K` of objects in `D`, with cone point `S.X`.

See `is_limit_multifork_of_is_limit` for more on how this definition is used.
-/
def multifork_evaluation_cone (F : K ⥤ Sheaf J D)
  (E : cone (F ⋙ Sheaf_to_presheaf J D)) (X : C) (W : J.cover X) (S : multifork (W.index E.X)) :
  cone (F ⋙ Sheaf_to_presheaf J D ⋙ (evaluation Cᵒᵖ D).obj (op X)) :=
{ X := S.X,
  π :=
  { app := λ k, (presheaf.is_limit_of_is_sheaf J (F.obj k).1 W (F.obj k).2).lift $
      multifork.of_ι _ S.X (λ i, S.ι i ≫ (E.π.app k).app (op i.Y)) begin
        intros i,
        simp only [category.assoc],
        erw [← (E.π.app k).naturality, ← (E.π.app k).naturality],
        dsimp,
        simp only [← category.assoc],
        congr' 1,
        apply S.condition,
      end,
    naturality' := begin
      intros i j f,
      dsimp [presheaf.is_limit_of_is_sheaf],
      rw [category.id_comp],
      apply presheaf.is_sheaf.hom_ext (F.obj j).2 W,
      intros ii,
      erw [presheaf.is_sheaf.amalgamate_map],
      rw [category.assoc, ← (F.map f).naturality, ← category.assoc],
      erw [presheaf.is_sheaf.amalgamate_map],
      dsimp [multifork.of_ι],
      rw [category.assoc, ← E.w f],
      simp,
    end } }

variables [has_limits_of_shape K D]

/-- If `E` is a cone of shape `K` of sheaves, which is a limit on the level of presheves,
this definition shows that the limit presheaf satisfies the multifork variant of the sheaf
condition, at a given covering `W`.

This is used below in `is_sheaf_of_is_limit` to show that the limit presheaf is indeed a sheaf.
-/
def is_limit_multifork_of_is_limit (F : K ⥤ Sheaf J D)
  (E : cone (F ⋙ Sheaf_to_presheaf J D))
  (hE : is_limit E) (X : C) (W : J.cover X) : is_limit (W.multifork E.X) :=
multifork.is_limit.mk _
(λ S, (is_limit_of_preserves ((evaluation Cᵒᵖ D).obj (op X)) hE).lift $
  multifork_evaluation_cone F E X W S)
begin
  intros S i,
  apply (is_limit_of_preserves ((evaluation Cᵒᵖ D).obj (op i.Y)) hE).hom_ext,
  intros k,
  dsimp [multifork.of_ι],
  erw [category.assoc, (E.π.app k).naturality],
  dsimp,
  rw ← category.assoc,
  erw (is_limit_of_preserves ((evaluation Cᵒᵖ D).obj (op X)) hE).fac
    (multifork_evaluation_cone F E X W S),
  dsimp [multifork_evaluation_cone, presheaf.is_limit_of_is_sheaf],
  erw presheaf.is_sheaf.amalgamate_map,
  refl,
end
begin
  intros S m hm,
  apply (is_limit_of_preserves ((evaluation Cᵒᵖ D).obj (op X)) hE).hom_ext,
  intros k,
  dsimp,
  erw (is_limit_of_preserves ((evaluation Cᵒᵖ D).obj (op X)) hE).fac,
  apply presheaf.is_sheaf.hom_ext (F.obj k).2 W,
  intros i,
  erw presheaf.is_sheaf.amalgamate_map,
  dsimp [multifork.of_ι],
  change _ = S.ι i ≫ _,
  erw [← hm, category.assoc, ← (E.π.app k).naturality, category.assoc],
  refl,
end

/-- If `E` is a cone which is a limit on the level of presheaves,
then the limit presheaf is again a sheaf.

This is used to show that the forgetful functor from sheaves to presheaves creates limits.
-/
lemma is_sheaf_of_is_limit (F : K ⥤ Sheaf J D) (E : cone (F ⋙ Sheaf_to_presheaf J D))
  (hE : is_limit E) : presheaf.is_sheaf J E.X :=
begin
  rw presheaf.is_sheaf_iff_multifork,
  intros X S,
  exact ⟨is_limit_multifork_of_is_limit _ _ hE _ _⟩,
end

instance (F : K ⥤ Sheaf J D) : creates_limit F (Sheaf_to_presheaf J D) :=
creates_limit_of_reflects_iso $ λ E hE,
{ lifted_cone := ⟨⟨E.X, is_sheaf_of_is_limit _ _ hE⟩, ⟨E.π.app, E.π.naturality⟩⟩,
  valid_lift := cones.ext (eq_to_iso rfl) $ λ j, by { dsimp, simp },
  makes_limit :=
  { lift := λ S, hE.lift ((Sheaf_to_presheaf J D).map_cone S),
    fac' := λ S j, hE.fac ((Sheaf_to_presheaf J D).map_cone S) j,
    uniq' := λ S m hm, hE.uniq ((Sheaf_to_presheaf J D).map_cone S) m hm } }

instance : creates_limits_of_shape K (Sheaf_to_presheaf J D) := {}

instance : has_limits_of_shape K (Sheaf J D) :=
has_limits_of_shape_of_has_limits_of_shape_creates_limits_of_shape (Sheaf_to_presheaf J D)

end

instance [has_limits D] : creates_limits (Sheaf_to_presheaf J D) := {}

instance [has_limits D] : has_limits (Sheaf J D) :=
has_limits_of_has_limits_creates_limits (Sheaf_to_presheaf J D)

end limits

section colimits

universes w v u
variables {C : Type (max v u)} [category.{v} C] {J : grothendieck_topology C}
variables {D : Type w} [category.{max v u} D]
variables {K : Type (max v u)} [small_category K]
-- Now we need a handful of instances to obtain sheafification...
variables [concrete_category.{max v u} D]
variables [∀ (P : Cᵒᵖ ⥤ D) (X : C) (S : J.cover X), has_multiequalizer (S.index P)]
variables [preserves_limits (forget D)]
variables [∀ (X : C), has_colimits_of_shape (J.cover X)ᵒᵖ D]
variables [∀ (X : C), preserves_colimits_of_shape (J.cover X)ᵒᵖ (forget D)]
variables [reflects_isomorphisms (forget D)]

/-- Construct a cocone by sheafifying a cocone point of a cocone `E` of presheaves
over a functor which factors through sheaves.
In `is_colimit_sheafify_cocone`, we show that this is a colimit cocone when `E` is a colimit. -/
@[simps]
def sheafify_cocone {F : K ⥤ Sheaf J D} (E : cocone (F ⋙ Sheaf_to_presheaf J D)) : cocone F :=
{ X := ⟨J.sheafify E.X, grothendieck_topology.plus.is_sheaf_plus_plus _ _⟩,
  ι :=
  { app := λ k, by apply E.ι.app k ≫ J.to_sheafify E.X, -- annoying...
    naturality' := λ i j f, by erw [category.comp_id, ← category.assoc, E.w f] } }

/-- If `E` is a colimit cocone of presheaves, over a diagram factoring through sheaves,
then `sheafify_cocone E` is a colimit cocone. -/
@[simps]
def is_colimit_sheafify_cocone {F : K ⥤ Sheaf J D} (E : cocone (F ⋙ Sheaf_to_presheaf J D))
  (hE : is_colimit E) :
  is_colimit (sheafify_cocone E) :=
{ desc := λ S, J.sheafify_lift (hE.desc ((Sheaf_to_presheaf J D).map_cocone S)) S.X.2,
  fac' := begin
    intros S j,
    dsimp [sheafify_cocone],
    erw [category.assoc, J.to_sheafify_sheafify_lift, hE.fac],
    refl,
  end,
  uniq' := begin
    intros S m hm,
    apply J.sheafify_lift_unique,
    apply hE.uniq ((Sheaf_to_presheaf J D).map_cocone S),
    intros j,
    erw [← category.assoc, hm j],
    refl,
  end }

instance [has_colimits_of_shape K D] : has_colimits_of_shape K (Sheaf J D) :=
⟨λ F, has_colimit.mk ⟨sheafify_cocone (colimit.cocone _),
  is_colimit_sheafify_cocone _ (colimit.is_colimit _)⟩⟩

instance [has_colimits D] : has_colimits (Sheaf J D) := ⟨infer_instance⟩

end colimits

end Sheaf
end category_theory


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon, Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.natural_isomorphism
import Mathlib.category_theory.eq_to_hom
import Mathlib.PostPort

universes u₁ v₁ w₀ w₁ w₂

namespace Mathlib

/-!
# Categories of indexed families of objects.

We define the pointwise category structure on indexed families of objects in a category
(and also the dependent generalization).

-/

namespace category_theory

/--
`pi C` gives the cartesian product of an indexed family of categories.
-/
protected instance pi {I : Type w₀} (C : I → Type u₁) [(i : I) → category (C i)] :
    category ((i : I) → C i) :=
  category.mk

/--
This provides some assistance to typeclass search in a common situation,
which otherwise fails. (Without this `category_theory.pi.has_limit_of_has_limit_comp_eval` fails.)
-/
instance pi' {I : Type v₁} (C : I → Type u₁) [(i : I) → category (C i)] :
    category ((i : I) → C i) :=
  category_theory.pi C

namespace pi

@[simp] theorem id_apply {I : Type w₀} (C : I → Type u₁) [(i : I) → category (C i)]
    (X : (i : I) → C i) (i : I) : 𝟙 = 𝟙 :=
  rfl

@[simp] theorem comp_apply {I : Type w₀} (C : I → Type u₁) [(i : I) → category (C i)]
    {X : (i : I) → C i} {Y : (i : I) → C i} {Z : (i : I) → C i} (f : X ⟶ Y) (g : Y ⟶ Z) (i : I) :
    category_struct.comp f g i = f i ≫ g i :=
  rfl

/--
The evaluation functor at `i : I`, sending an `I`-indexed family of objects to the object over `i`.
-/
@[simp] theorem eval_map {I : Type w₀} (C : I → Type u₁) [(i : I) → category (C i)] (i : I)
    (f : (i : I) → C i) (g : (i : I) → C i) (α : f ⟶ g) : functor.map (eval C i) α = α i :=
  Eq.refl (functor.map (eval C i) α)

/--
Pull back an `I`-indexed family of objects to an `J`-indexed family, along a function `J → I`.
-/
@[simp] theorem comap_map {I : Type w₀} (C : I → Type u₁) [(i : I) → category (C i)] {J : Type w₁}
    (h : J → I) (f : (i : I) → C i) (g : (i : I) → C i) (α : f ⟶ g) (i : J) :
    functor.map (comap C h) α i = α (h i) :=
  Eq.refl (functor.map (comap C h) α i)

/--
The natural isomorphism between
pulling back a grading along the identity function,
and the identity functor. -/
def comap_id (I : Type w₀) (C : I → Type u₁) [(i : I) → category (C i)] : comap C id ≅ 𝟭 :=
  iso.mk (nat_trans.mk fun (X : (i : I) → C i) => 𝟙) (nat_trans.mk fun (X : (i : I) → C i) => 𝟙)

/--
The natural isomorphism comparing between
pulling back along two successive functions, and
pulling back along their composition
-/
def comap_comp {I : Type w₀} (C : I → Type u₁) [(i : I) → category (C i)] {J : Type w₁}
    {K : Type w₂} (f : K → J) (g : J → I) : comap C g ⋙ comap (C ∘ g) f ≅ comap C (g ∘ f) :=
  iso.mk (nat_trans.mk fun (X : (i : I) → C i) (b : K) => 𝟙)
    (nat_trans.mk fun (X : (i : I) → C i) (b : K) => 𝟙)

/-- The natural isomorphism between pulling back then evaluating, and just evaluating. -/
def comap_eval_iso_eval {I : Type w₀} (C : I → Type u₁) [(i : I) → category (C i)] {J : Type w₁}
    (h : J → I) (j : J) : comap C h ⋙ eval (C ∘ h) j ≅ eval C (h j) :=
  nat_iso.of_components
    (fun (f : (i : I) → C i) => iso.refl (functor.obj (comap C h ⋙ eval (C ∘ h) j) f)) sorry

protected instance sum_elim_category {I : Type w₀} (C : I → Type u₁) [(i : I) → category (C i)]
    {J : Type w₀} {D : J → Type u₁} [(j : J) → category (D j)] (s : I ⊕ J) :
    category (sum.elim C D s) :=
  sorry

/--
The bifunctor combining an `I`-indexed family of objects with a `J`-indexed family of objects
to obtain an `I ⊕ J`-indexed family of objects.
-/
@[simp] theorem sum_obj_obj {I : Type w₀} (C : I → Type u₁) [(i : I) → category (C i)] {J : Type w₀}
    {D : J → Type u₁} [(j : J) → category (D j)] (f : (i : I) → C i) (g : (j : J) → D j)
    (s : I ⊕ J) : functor.obj (functor.obj (sum C) f) g s = sum.rec f g s :=
  Eq.refl (functor.obj (functor.obj (sum C) f) g s)

end pi

namespace functor

/--
Assemble an `I`-indexed family of functors into a functor between the pi types.
-/
def pi {I : Type w₀} {C : I → Type u₁} [(i : I) → category (C i)] {D : I → Type u₁}
    [(i : I) → category (D i)] (F : (i : I) → C i ⥤ D i) : ((i : I) → C i) ⥤ ((i : I) → D i) :=
  mk (fun (f : (i : I) → C i) (i : I) => obj (F i) (f i))
    fun (f g : (i : I) → C i) (α : f ⟶ g) (i : I) => map (F i) (α i)

-- One could add some natural isomorphisms showing

-- how `functor.pi` commutes with `pi.eval` and `pi.comap`.

end functor

namespace nat_trans

/--
Assemble an `I`-indexed family of natural transformations into a single natural transformation.
-/
def pi {I : Type w₀} {C : I → Type u₁} [(i : I) → category (C i)] {D : I → Type u₁}
    [(i : I) → category (D i)] {F : (i : I) → C i ⥤ D i} {G : (i : I) → C i ⥤ D i}
    (α : (i : I) → F i ⟶ G i) : functor.pi F ⟶ functor.pi G :=
  mk fun (f : (i : I) → C i) (i : I) => app (α i) (f i)

end Mathlib


import tactic.interactive
import algebra.group.basic

/-!
`refine_struct` caused a variety of interesting problems,
which were identified in
https://github.com/leanprover-community/mathlib/pull/2251
and
https://leanprover.zulipchat.com/#narrow/stream/113488-general/topic/Need.20help.20with.20class.20instance.20resolution

These tests are quite specific to testing the patch made in
https://github.com/leanprover-community/mathlib/pull/2319
and are not a complete test suite for `refine_struct`.
-/

instance pi_has_one {α : Type*} {β : α → Type*} [Π x, has_one (β x)] : has_one (Π x, β x) :=
by refine_struct { .. }; exact λ _, 1

open tactic

run_cmd (do
  (declaration.defn _ _ _ b _ _) ← get_decl ``pi_has_one,
  -- Make sure that `eq.mpr` really doesn't occur in the body:
  when (b.list_constant.contains ``eq.mpr) $
    fail "result generated by `refine_struct` contained an unnecessary `eq.mpr`",
  -- Make sure that `id` really doesn't occur in the body:
  when (b.list_constant.contains ``id) $
    fail "result generated by `refine_struct` contained an unnecessary `id`")

-- Next we check that fields defined for embedded structures are unfolded
-- when seen by fields in the outer structure.
structure foo (α : Type):=
(a : α)

structure bar (α : Type) extends foo α :=
(b : a = a)

example : bar ℕ :=
begin
  refine_struct { a := 1, .. },
  -- We're making sure that the goal is
  -- ⊢ 1 = 1
  -- rather than
  -- ⊢ {a := 1}.a = {a := 1}.a
  guard_target 1 = 1,
  trivial
end

section
variables {α : Type} [_inst : monoid α]
include _inst

example : true :=
begin
  have : group α,
  { refine_struct { .._inst },
    guard_tags _field inv group, admit,
    guard_tags _field div group, admit,
    guard_tags _field div_eq_mul_inv group, admit,
    guard_tags _field zpow group, admit,
    guard_tags _field zpow_zero' group, admit,
    guard_tags _field zpow_succ' group, admit,
    guard_tags _field zpow_neg' group, admit,
    guard_tags _field mul_left_inv group, admit, },
  trivial
end
end

def my_foo {α} (x : semigroup α) (y : group α) : true := trivial

example {α : Type} : true :=
begin
  have : true,
  { refine_struct (@my_foo α { .. } { .. } ),
      -- 18 goals
    guard_tags _field mul semigroup, admit,
      -- case semigroup, mul
      -- α : Type
      -- ⊢ α → α → α

    guard_tags _field mul_assoc semigroup, admit,
      -- case semigroup, mul_assoc
      -- α : Type
      -- ⊢ ∀ (a b c : α), a * b * c = a * (b * c)

    guard_tags _field mul group, admit,
      -- case group, mul
      -- α : Type
      -- ⊢ α → α → α

    guard_tags _field mul_assoc group, admit,
      -- case group, mul_assoc
      -- α : Type
      -- ⊢ ∀ (a b c : α), a * b * c = a * (b * c)

    guard_tags _field one group, admit,
      -- case group, one
      -- α : Type
      -- ⊢ α

    guard_tags _field one_mul group, admit,
      -- case group, one_mul
      -- α : Type
      -- ⊢ ∀ (a : α), 1 * a = a

    guard_tags _field mul_one group, admit,
      -- case group, mul_one
      -- α : Type
      -- ⊢ ∀ (a : α), a * 1 = a

    guard_tags _field npow group, admit,
      -- case group, npow
      -- α : Type
      -- ⊢ ℕ → α → α

    guard_tags _field npow_zero' group, admit,
      -- case group, inv
      -- α : Type
      -- ⊢ ∀ (x : α), sorry 0 x = 1

    guard_tags _field npow_succ' group, admit,
      -- case group, npow_succ'
      -- α : Type
      -- ⊢ ∀ (n : ℕ) (x : α), sorry n.succ x = x * sorry n x

    guard_tags _field inv group, admit,
      -- case group, inv
      -- α : Type
      -- ⊢ α → α

    guard_tags _field div group, admit,
      -- case group, div
      -- α : Type
      -- ⊢ α → α

    guard_tags _field div_eq_mul_inv group, admit,
      -- case group, div_eq_mul_inv
      -- α : Type
      -- ⊢ α → α

    guard_tags _field zpow group, admit,
      -- case group, zpow
      -- α : Type
      -- ⊢ ℤ → α → α

    guard_tags _field zpow_zero' group, admit,
      -- case group, zpow_zero'
      -- α : Type
      -- ⊢ ∀ (a : α), sorry 0 a = 1

    guard_tags _field zpow_succ' group, admit,
      -- case group, inv
      -- α : Type
      -- ⊢ ∀ (n : ℕ) (a : α), sorry (int.of_nat n.succ) a = a * sorry (int.of_nat n) a

    guard_tags _field zpow_neg' group, admit,
      -- case group, inv
      -- α : Type
      -- ⊢ ∀ (n : ℕ) (a : α), sorry -[1+ n] a = sorry (sorry ↑(n.succ) a)

    guard_tags _field mul_left_inv group, admit,
      -- case group, mul_left_inv
      -- α : Type
      -- ⊢ ∀ (a : α), a⁻¹ * a = 1
  },
  trivial
end

def my_bar {α} (x : semigroup α) (y : group α) (i j : α) : α := i

example {α : Type} : true :=
begin
  have : monoid α,
  { refine_struct { mul := my_bar { .. } { .. } },
    guard_tags _field mul semigroup, admit,
    guard_tags _field mul_assoc semigroup, admit,
    guard_tags _field mul group, admit,
    guard_tags _field mul_assoc group, admit,
    guard_tags _field one group, admit,
    guard_tags _field one_mul group, admit,
    guard_tags _field mul_one group, admit,
    guard_tags _field npow group, admit,
    guard_tags _field npow_zero' group, admit,
    guard_tags _field npow_succ' group, admit,
    guard_tags _field inv group, admit,
    guard_tags _field div group, admit,
    guard_tags _field div_eq_mul_inv group, admit,
    guard_tags _field zpow group, admit,
    guard_tags _field zpow_zero' group, admit,
    guard_tags _field zpow_succ' group, admit,
    guard_tags _field zpow_neg' group, admit,
    guard_tags _field mul_left_inv group, admit,
    guard_tags _field mul_assoc monoid, admit,
    guard_tags _field one monoid, admit,
    guard_tags _field one_mul monoid, admit,
    guard_tags _field mul_one monoid, admit,
    guard_tags _field npow monoid, admit,
    guard_tags _field npow_zero' monoid, admit,
    guard_tags _field npow_succ' monoid, admit, },
  trivial
end

def my_semigroup := semigroup

example {α} (mul : α → α → α) (h : false) : my_semigroup α :=
begin
  refine_struct { mul := mul, .. },
  field mul_assoc {
    guard_target ∀ a b c : α, mul (mul a b) c = mul a (mul b c),
    exact h.elim }
end