inductive Cat :=
| var (n : Nat) : Cat

mutual

inductive Obj : Cat → Type where
| var (C : Cat) (n : Nat) : Obj C
| varApp {C D : Cat} (v : Nat) (X : Obj C) : Obj D
| rAdjApp {C D : Cat} (F : Func C D) (X : Obj D) : Obj C

inductive Func : Cat → Cat → Type where
| id (C : Cat) : Func C C
| compVar {C D E : Cat} (F : Func C D) (v : Nat) : Func C E
| compRAdj {C D E : Cat} (F : Func C D) (G : Func E D) : Func C E

end

mutual

def ObjContainsRAdj {C' D' : Cat} (L : Func C' D') : {C : Cat} → (X : Obj C) → Prop
| _, Obj.var _ _     => False
| _, Obj.varApp _ X  => ObjContainsRAdj L X
| _, Obj.rAdjApp F X => FuncContainsRAdj L F ∨ ObjContainsRAdj L X

def FuncContainsRAdj {C' D' : Cat} (L : Func C' D') : {C D : Cat} → (F : Func C D) → Prop
| _, _, Func.id _         => False
| _, _, Func.compVar G v  => FuncContainsRAdj L G
| _, _, Func.compRAdj G H => FuncContainsRAdj L G ∨ HEq L H

end

noncomputable def Func.compAux {D E : Cat} (G : Func D E) : (C : Cat) → (F : Func C D) → Func C E :=
@Func.recOn (λ _ _ => Unit) (λ D E G => (C : Cat) → (F : Func C D) → Func C E)
  D E G
  (λ _ _ => ())
  (λ _ _ _ => ())
  (λ _ _ _ _ => ())
  (λ _ _ F => F)
  (λ D v ih C F => compVar (ih _ F) v)
  (λ F G ih _ C H => compRAdj (ih _ H) G)

noncomputable def Func.comp {C D E : Cat} (F : Func C D) (G : Func D E) : Func C E :=
Func.compAux G _ F

noncomputable def Func.app {C D : Cat} (F : Func C D) : (X : Obj C) → Obj D :=
@Func.recOn (λ _ _ => Unit) (λ C D _ => Obj C → Obj D)
  C D F
  (λ _ _ => ())
  (λ _ _ _ => ())
  (λ _ _ _ _ => ())
  (λ _ X => X)
  (λ F v ih X => Obj.varApp v (ih X))
  (λ F G ih _ X => Obj.rAdjApp G (ih X))

theorem Func.idApp {C : Cat} (X : Obj C) : (Func.id C).app X = X := rfl

theorem Func.compVarApp {C D E : Cat} (F : Func C D) (v : Nat) (X : Obj C) :
  (@Func.compVar C D E F v).app X = Obj.varApp v (F.app X) := rfl

theorem Func.compRAdjApp {C D E : Cat} (F : Func C D) (G : Func E D) (X : Obj C) :
  (Func.compRAdj F G).app X = Obj.rAdjApp G (F.app X) := rfl

def Func.var (C D : Cat) (v : Nat) : Func C D :=
Func.compVar (Func.id _) v

def Func.rAdj {C D : Cat} (F : Func D C) : Func C D :=
Func.compRAdj (Func.id _) F

noncomputable def Obj.cases : {C : Cat} → (X Y : Obj C) → Σ D : Cat, Obj D × Obj D
| C, X, rAdjApp F Y => cases (F.app X) Y
| C, X,           Y => ⟨C, X, Y⟩

theorem FuncAppContainsRAdj {C' D' : Cat} (G : Func C' D') :
  {C D : Cat} → (F : Func C D) → (X : Obj C) →
  ObjContainsRAdj G (F.app X) ↔ FuncContainsRAdj G F ∨ ObjContainsRAdj G X
| _, _, (Func.id _), X => by
rw [Func.idApp, FuncContainsRAdj, false_or, iff_self]
trivial
| _, _, (Func.compVar F v), X => by
rw [Func.compVarApp, ObjContainsRAdj, FuncContainsRAdj, FuncAppContainsRAdj G F, iff_self]
trivial
| _, _, (Func.compRAdj I H), X => by
rw [Func.compRAdjApp, ObjContainsRAdj, FuncContainsRAdj, FuncAppContainsRAdj G I]
sorry

theorem ObjContainsRAdjCases1 : {C D E : Cat} → {X Y : Obj E} → {F : Func C D} →
  ObjContainsRAdj F (X.cases Y).2.1 → ObjContainsRAdj F X ∨ ObjContainsRAdj F Y
| C, D, E, X, Obj.rAdjApp G Y, F, h => by
  rw [Obj.cases] at h
  have h' := ObjContainsRAdjCases1 h
  rw [FuncAppContainsRAdj] at h'
  rw [ObjContainsRAdj]
  sorry
| C, D, E, X, Obj.var _ _, F, h => by
  rw [Obj.cases] at h
  simp [Obj.cases] at h
  exact Or.inl h
  intros _ _ _ h
  injection h
| C, D, E, X, Obj.varApp v Y, F, h => by
  rw [Obj.cases] at h
  simp at h
  exact Or.inl h
  intros _ _ _ h
  injection h

theorem ObjContainsRAdjCases2 : {C D E : Cat} → {X Y : Obj E} → {F : Func C D} →
  ObjContainsRAdj F (X.cases Y).2.2 → ObjContainsRAdj F X ∨ ObjContainsRAdj F Y
| C, D, E, X, Obj.rAdjApp G Y, F, h => by
  rw [Obj.cases] at h
  have h' := ObjContainsRAdjCases2 h
  rw [FuncAppContainsRAdj] at h'
  rw [ObjContainsRAdj]
  sorry
| C, D, E, X, Obj.var _ _, F, h => by
  rw [Obj.cases] at h
  simp [Obj.cases] at h
  exact Or.inr h
  intros _ _ _ h
  injection h
| C, D, E, X, Obj.varApp v Y, F, h => by
  rw [Obj.cases] at h
  simp at h
  exact Or.inr h
  intros _ _ _ h
  injection h

structure Context : Type 1 :=
( HomVar {C : Cat} (X Y : Obj C) : Type )
( hasRAdj {C D : Cat} (F : Func C D) : Bool )

variable (Γ : Context)

mutual

inductive HomAux : {C : Cat} → (X Y : Obj C) → Type where
| var {C : Cat} (X Y : Obj C) (v : Γ.HomVar X Y) : HomAux (X.cases Y).2.1 (X.cases Y).2.2
| mapVar {C : Cat} (D : Cat) {X Y : Obj C} (v : Nat) (f : HomAux X Y) :
  HomAux ((Func.var C D v).app X) ((Func.var C D v).app Y)
| mapRAdj {C D : Cat} {X Y : Obj C} (F : Func D C) (f : HomAux X Y) :
  HomAux (F.rAdj.app X) (F.rAdj.app Y)
| restrict {C D : Cat} (F : Func C D)
  {X : Obj C} {Y : Obj D} :
  Hom (F.app X) Y → HomAux X (Obj.rAdjApp F Y)
| counit {C D : Cat} (F : Func C D) (X : Obj D) :
  HomAux (F.app (F.rAdj.app X)) X

inductive Hom : {C : Cat} → (X Y : Obj C) → Type where
| id {C : Cat} (X : Obj C) : Hom X X
| comp' {C : Cat} {X Y Z : Obj C} (f : HomAux X Y) (g : Hom Y Z) : Hom X Z

end

-- mutual

-- def HomAuxContainsVar {C' : Cat} {A B : Obj C'} (v : Γ.HomVar A B) :
--   {C : Cat} → {X Y : Obj C} → HomAux Γ X Y → Prop
-- | _, _, _, HomAux.mapVar _ f         => HomAuxContainsVar v f
-- | _, _, _, HomAux.mapRAdj F f        => HomAuxContainsVar v f
-- | _, _, _, @HomAux.var _ D X' Y' w => HEq w v
-- | _, _, _, HomAux.restrict F f    => HomContainsVar v f
-- | _, _, _, HomAux.counit F X      => False

-- def HomContainsVar {C' : Cat} {A B : Obj C'} (v : Γ.HomVar A B) :
--   {C : Cat} → {X Y : Obj C} → Hom Γ X Y → Prop
-- | _, _, _, Hom.id _ => False
-- | _, _, _, Hom.comp' f g => HomAuxContainsVar v f ∨ HomContainsVar v g

-- end

mutual

inductive HomAuxContainsVar {C' : Cat} {A B : Obj C'} (v : Γ.HomVar A B) :
  {C : Cat} → {X Y : Obj C} → HomAux Γ X Y → Prop where
| self : HomAuxContainsVar v (HomAux.var A B v)
| mapRAdj : HomAuxContainsVar v f → HomAuxContainsVar v (HomAux.mapRAdj F f)
| mapVar : HomAuxContainsVar v f → HomAuxContainsVar v (HomAux.mapVar D F f)
| restrict : HomContainsVar v f → HomAuxContainsVar v (HomAux.restrict _ f)

inductive HomContainsVar {C' : Cat} {A B : Obj C'} (v : Γ.HomVar A B) :
  {C : Cat} → {X Y : Obj C} → Hom Γ X Y → Prop where
| compLeft : HomAuxContainsVar v f → HomContainsVar v (Hom.comp' f g)
| compRight : HomContainsVar v g → HomContainsVar v (Hom.comp' f g)

end

variable {Γ}

namespace Hom

variable {C D : Cat}

section defs

def ofHomAux {X Y : Obj C} (f : HomAux Γ X Y) : Hom Γ X Y :=
Hom.comp' f (Hom.id _)

noncomputable def var {X Y : Obj C} (v : Γ.HomVar X Y) : Hom Γ (X.cases Y).2.1 (X.cases Y).2.2 :=
ofHomAux (HomAux.var _ _ v)

noncomputable def comp : {C : Cat} → {X Y Z : Obj C} →
  Hom Γ X Y → Hom Γ Y Z → Hom Γ X Z
| _, _, _, _, Hom.id _, g => g
| _, _, _, _, Hom.comp' f g, h => Hom.comp' f (comp g h)

noncomputable def mapAux : {C D : Cat} → (F : Func C D) → {X Y : Obj C} →
  (f : HomAux Γ X Y) → HomAux Γ (F.app X) (F.app Y)
| _, _, Func.id _,           _, _, f => f
| _, _, (Func.compVar F v),  _, _, f => HomAux.mapVar _ v (mapAux F f)
| _, _, (Func.compRAdj F G), _, _, f => HomAux.mapRAdj G (mapAux F f)

noncomputable def map {C D : Cat} (F : Func C D) : {X Y : Obj C} →
  (f : Hom Γ X Y) → Hom Γ (F.app X) (F.app Y)
| _, _, Hom.id _ => Hom.id _
| _, _, Hom.comp' f g => Hom.comp' (mapAux F f) (map F g)

noncomputable def restrict {C D : Cat} (F : Func C D) (hF : Γ.hasRAdj F)
  {X : Obj C} {Y : Obj D}
  (f : Hom Γ (F.app X) Y) : Hom Γ X (Obj.rAdjApp F Y) :=
ofHomAux (HomAux.restrict F f)

noncomputable def counit {C D : Cat} (F : Func C D) (hF : Γ.hasRAdj F) (X : Obj D) :
  Hom Γ (F.app (F.rAdj.app X)) X :=
ofHomAux (HomAux.counit F X)

end defs

section lemmas

theorem compId : {X Y : Obj C} → (f : Hom Γ X Y) → f.comp (Hom.id _) = f
| _, _, (Hom.id _) => by rw [comp]
| _, _, (Hom.comp' f g) => by rw [Hom.comp, compId g]

theorem idComp {X Y : Obj C} (f : Hom Γ X Y) : (Hom.id _).comp f = f :=
by rw [Hom.comp]

theorem compAssoc : {W X Y Z : Obj C} →
  (f : Hom Γ W X) → (g : Hom Γ X Y) → (h : Hom Γ Y Z) →
  (f.comp g).comp h = f.comp (g.comp h)
| _, _, _, _, Hom.id _,      h, i => by rw [idComp, idComp]
| _, _, _, _, Hom.comp' f g, h, i =>
by rw [Hom.comp, Hom.comp, Hom.comp, compAssoc g]

theorem mapId {X : Obj C} (F : Func C D) : map F (@Hom.id Γ C X) = Hom.id (F.app X) :=
by rw [Hom.map]

theorem mapComp (F : Func C D) : {X Y Z : Obj C} → (f : Hom Γ X Y) → (g : Hom Γ Y Z) →
  map F (f.comp g) = (map F f).comp (map F g)
| _, _, _, Hom.id _,      g => by rw [idComp, mapId, idComp]
| _, _, _, Hom.comp' f g, h => by rw [comp, map, map, mapComp F g, comp]

end lemmas

/- Now the other normalisation stuff.
  -- Suppose we have f : X → Y where X and Y are Objects of C.
  -- If Y is rAdj, then f must be restrict to be almostNormal
  -- If Y is not rAdj then f is almostNormal if every rAdj functor contained in
    f is contained in a variable in F or X or Y.
  -- A term is normal if every subterm (define properly) is almostNormal
 -/

end Hom

mutual

noncomputable def changeVarsAux (Γ₁ Γ₂ : Context)
  (h : ∀ {C D : Cat} (F : Func C D), Γ₁.hasRAdj F → Γ₂.hasRAdj F)
  (i : {C : Cat} → {X Y : Obj C} → Γ₁.HomVar X Y → Γ₂.HomVar X Y) :
  {C : Cat} → {X Y : Obj C} → HomAux Γ₁ X Y → HomAux Γ₂ X Y
| _, _, _, HomAux.mapVar _ v f => HomAux.mapVar _ v (changeVarsAux Γ₁ Γ₂ h i f)
| _, _, _, HomAux.mapRAdj F f => HomAux.mapRAdj F (changeVarsAux Γ₁ Γ₂ h i f)
| _, _, _, HomAux.var _ _ f => HomAux.var _ _ (i f)
| _, _, _, HomAux.restrict F f => HomAux.restrict F (changeVars Γ₁ Γ₂ h i f)
| _, _, _, HomAux.counit F X => HomAux.counit F X

noncomputable def changeVars (Γ₁ Γ₂ : Context)
  (h : ∀ {C D : Cat} (F : Func C D), Γ₁.hasRAdj F → Γ₂.hasRAdj F)
  (i : {C : Cat} → {X Y : Obj C} → Γ₁.HomVar X Y → Γ₂.HomVar X Y) :
  {C : Cat} → {X Y : Obj C} → Hom Γ₁ X Y → Hom Γ₂ X Y
| _, _, _, Hom.id _ => Hom.id _
| _, _, _, Hom.comp' f g => Hom.comp' (changeVarsAux Γ₁ Γ₂ h i f) (changeVars Γ₁ Γ₂ h i g)

end

mutual

noncomputable def changeVarsAux2 (Γ₁ Γ₂ : Context) :
  {C : Cat} → {X Y : Obj C} → (f : HomAux Γ₁ X Y) →
  (h : ∀ {C D : Cat} (F : Func C D), Γ₁.hasRAdj F → Γ₂.hasRAdj F) →
  (i : {C : Cat} → {X Y : Obj C} → (v : Γ₁.HomVar X Y) →
    HomAuxContainsVar Γ₁ v f → Γ₂.HomVar X Y)  → HomAux Γ₂ X Y
| _, _, _, HomAux.mapVar _ v f, h, i =>
    HomAux.mapVar _ v (changeVarsAux2 Γ₁ Γ₂ f h
      (by
        intros C X Y v hv
        apply i
        constructor
        assumption ))
| _, _, _, HomAux.mapRAdj F f, h, i => HomAux.mapRAdj F (changeVarsAux2 Γ₁ Γ₂ f h
   (by
        intros C X Y v hv
        have := i v
        apply this
        constructor
        assumption ))
| _, _, _, HomAux.var _ _ v, h, i => HomAux.var _ _ (i v (by constructor))
| _, _, _, HomAux.restrict F f, h, i => HomAux.restrict F (changeVars2 Γ₁ Γ₂ f h
  (by
    intros
    apply i
    constructor
    assumption ))
| _, _, _, HomAux.counit F X, h, i => HomAux.counit F X

noncomputable def changeVars2 (Γ₁ Γ₂ : Context) :
  {C : Cat} → {X Y : Obj C} → (f : Hom Γ₁ X Y) →
  (h : ∀ {C D : Cat} (F : Func C D), Γ₁.hasRAdj F → Γ₂.hasRAdj F) →
  (i : {C : Cat} → {X Y : Obj C} → (v : Γ₁.HomVar X Y) →
    HomContainsVar Γ₁ v f → Γ₂.HomVar X Y) → Hom Γ₂ X Y
| _, _, _, Hom.id _, _, _ => Hom.id _
| _, _, _, Hom.comp' f g, h, i =>
  Hom.comp' (changeVarsAux2 Γ₁ Γ₂ f h
    (by
      intros
      apply i
      constructor
      assumption))
    (changeVars2 Γ₁ Γ₂ g h
      (by
        intros C X Y v hv
        apply i v
        apply HomContainsVar.compRight
        assumption ))

end

noncomputable def toPresheaf (Γ₁ Γ₂ : Context)
  (h : ∀ {C D : Cat} (F : Func C D), Γ₁.hasRAdj F → Γ₂.hasRAdj F)
  (i : {C : Cat} → {X Y : Obj C} → Γ₁.HomVar X Y → Γ₂.HomVar X Y)
  {C : Cat} {X Y : Obj C} (f : Hom X Y) :


-- En el artículo "Single axioms for groups and abelian groups with
-- various operations" https://bit.ly/3kMBlA0 de McCune se demuestra que
-- el siguiente axioma caracteriza a los grupos
--    (x * (y * (((z * z⁻¹) * (u * y)⁻¹) * x))⁻¹) = u

import tactic

class mccune_group (α : Type*) extends has_mul α, has_inv α, inhabited α :=
(mccune (x y z u : α) : x * (y * (((z * z⁻¹) * (u * y)⁻¹) * x))⁻¹ = u)

namespace mccune_group
variables {α : Type*} [mccune_group α] (x y z u w v : α)

lemma l5 : x * (y * (z * z⁻¹ * (u * y)⁻¹ * x))⁻¹ = u := mccune _ _ _ _

lemma l7 : x * (y * y⁻¹ * (z * u)⁻¹ * (v * v⁻¹) * (z * x))⁻¹ = u :=
by simpa [l5 (v * v⁻¹)] using l5 x (y * y⁻¹ * (z * u)⁻¹ * (v * v⁻¹)) v u

lemma l9 : x * (y * (z * z⁻¹) * (u * x))⁻¹ = v * v⁻¹ * (y * u)⁻¹ * (w * w⁻¹) :=
by simpa [l5 (w * w⁻¹)] using l7 x w u (v * v⁻¹ * (y * u)⁻¹ * (w * w⁻¹)) z

lemma l10 : y * y⁻¹ * (z * z⁻¹ * (u * x)⁻¹ * u)⁻¹ * (v * v⁻¹) = x :=
by simpa [l9 _ _ _ u v y] using l7 x z u x z

lemma l12 : x * x⁻¹ * y⁻¹⁻¹ * (z * z⁻¹) = y :=
by simpa [l10] using l10 y x x (y * y⁻¹ * (y * y⁻¹)⁻¹) z

lemma l14 : (x * x⁻¹) * (y * z)⁻¹ = u * u⁻¹ * (y * z)⁻¹ := -- [10 -> 5]
begin
  convert l5 _ _ _ _,
  rw l10,
  exact x,
end

lemma l15 : (x * x⁻¹) * y⁻¹ = (z * z⁻¹) * y⁻¹ :=
by simpa [l12] using l14 x ((x * x⁻¹) * y⁻¹⁻¹) (z * z⁻¹) z

lemma l17 : u * u⁻¹ = v * v⁻¹ := -- [15 → 5 : 5]
begin
  rw ←l5 u u⁻¹ u (v * v⁻¹),
  rw l15 v _,
  rw l5,
end

instance : has_one α := ⟨arbitrary α * (arbitrary α)⁻¹⟩

@[simp] lemma l17' : u * u⁻¹ = 1 := l17 _ _

lemma l10' : (1 * ((1 * (u * x)⁻¹) * u)⁻¹) * 1 = x := l10 _ _ _ _ _

lemma l20' : (1 * (1*z)⁻¹)*1 = z⁻¹ :=
begin
  convert l10' _ _,
  rw l17',
  rw l17',
end

lemma l5' : x * (y * ((1 * (u * y)⁻¹) * x))⁻¹ = u := l5 _ _ _ _

lemma l22' : x * (y⁻¹ * (1 * x))⁻¹ = y := -- [17 → 5]
by { convert l5' _ _ y, simp }

lemma l7' : x * (((1 * (z * u)⁻¹) * 1) * (z * x))⁻¹ = u := l7 _ _ _ _ _

lemma l25' : x * (1⁻¹⁻¹ * (w * x))⁻¹ = w⁻¹ := -- [19 → 7:20]
begin
  convert l7' _ _ _,
  rw l17',
  convert (l20' _).symm,
  simp,
end

lemma l32' : 1⁻¹ * (y⁻¹ * 1)⁻¹ = y := -- [17 → 22]
begin
  convert l22' (1 : α)⁻¹ y,
  simp
end

lemma l34' : x⁻¹ * (1⁻¹⁻¹ * 1)⁻¹ = x⁻¹ := by simpa using l25' x⁻¹ x

lemma l36' : (1 * (x * 1⁻¹⁻¹)⁻¹)⁻¹ = x :=
begin
  convert l5' _ _ _,
  rw l25',
  exact x
end

lemma l44' : x * (1⁻¹⁻¹ * 1)⁻¹ = x := by simpa [l36'] using l34' (1 * (x * 1⁻¹⁻¹)⁻¹)
lemma l48' : (1 : α)⁻¹⁻¹ * 1 = 1 := by simpa using (l44' ((1 : α)⁻¹⁻¹ * 1)).symm
lemma l52' : x * 1⁻¹ = x := by simpa [l48'] using l44' x
lemma l57' : (1⁻¹ * u)⁻¹⁻¹ = u := by simpa [l52', l20'] using l10' u 1⁻¹

lemma l62' : (x⁻¹ * 1)⁻¹ = x⁻¹⁻¹ :=
by simpa [l32'] using (l57' (x⁻¹ * 1)⁻¹).symm

lemma l76' : (x * 1)⁻¹ = x⁻¹ := by simpa [l57'] using l62' (1⁻¹ * x)⁻¹

lemma l88' : 1⁻¹ * x⁻¹⁻¹ = x :=
by simpa [l76'] using l32' x

@[simp] lemma l116' : y * 1 = y :=
begin
  have := l88' (y * 1),
  rw l76' at this,
  rw l88' at this,
  exact this.symm
end

@[simp] lemma one_inv_inv : (1 : α)⁻¹⁻¹ = 1 :=
by simpa using l48'

@[simp] lemma one_inv : (1 : α)⁻¹ = 1 :=
by simpa using l88' (1 : α)

lemma l92' : (1 * y⁻¹)⁻¹ = y :=
by simpa using l36' y

lemma l126' : (y * z) * z⁻¹ = y :=
begin
  have := l5' ((1 : α) * (y * z)⁻¹)⁻¹ z y,
  rw l17' at this,
  simpa [l92'] using this,
end

lemma l201 : x * y⁻¹⁻¹ = x * y :=
by simpa [l126' x y] using l126' (x * y) y⁻¹

@[simp] lemma l207' : 1 * z = z :=
by simpa [l201] using l126' z z⁻¹

@[simp] lemma l227 : y⁻¹⁻¹ = y :=
by simpa using l201 1 y

@[simp] lemma inv_mul : x⁻¹ * x = 1 :=
by simpa using l17' x⁻¹

lemma l229 : (z * x)⁻¹ = x⁻¹ * z⁻¹ := -- 126->25:227,207
by simpa [l126'] using (l25' x⁻¹ (z * x)).symm

lemma thingy : x * (x⁻¹ * z) = z := -- [126->5:207,229,229,227,227]
begin
  have := l5' x z⁻¹ z,
  simp only [one_inv, l17', l207'] at this,
  rw [l229, l227] at this,
  exact this,
end

lemma l239 : x * ((x⁻¹ * u) * y) = u * y := -- [126->5:207,229,229,227,227]
by simpa [l229, l126'] using l5' x y⁻¹ (u * y)

lemma l260 : (x * y) * z = x * (y * z) := -- [215->215:229,229,229,227,227,239]
begin
  rw ←l239 x⁻¹ z y,
  rw thingy,
  simp
end

instance : group α :=
{ mul_assoc := l260,
  one_mul := by simp,
  mul_one := by simp,
  mul_left_inv := λ x, inv_mul _,
  ..(by apply_instance : has_one α),
  ..(by apply_instance : has_mul α),
  ..(by apply_instance : has_inv α) }

end mccune_group


import spaces.test_function
import measure_theory.measure.lebesgue

open measure_theory
open_locale test_function

abbreviation distribution {E : Type*} [normed_group E] [normed_space ℝ E] (Ω : set E)
  (F : Type*) [normed_group F] [normed_space ℝ F] (n : with_top ℕ) : Type* :=
Cc^n⟮Ω, E, ℝ; ℝ⟯ →L[ℝ] F

localized "notation `𝓓'` := distribution" in distribution

namespace distribution

variables {E : Type*} [normed_group E] [normed_space ℝ E] (Ω : set E)
  (F : Type*) [normed_group F] [normed_space ℝ F] (n : with_top ℕ)

noncomputable def dirac (x : E) : 𝓓' Ω ℝ n :=
  (bounded_continuous_function.eval_clm ℝ x) ∘L
  (bounded_cont_diff_map.to_bounded_continuous_functionL ℝ E ℝ n) ∘L
  (test_function.to_bounded_cont_diff_mapL)

@[simp] lemma dirac_apply (x : E) (f : Cc^n⟮Ω, E, ℝ; ℝ⟯) : dirac Ω n x f = f x := rfl

noncomputable def of_measure [measurable_space E] [opens_measurable_space E]
  (μ : measure E) [is_finite_measure_on_compacts μ] :
  𝓓' Ω ℝ n :=
(L1.integral_clm) ∘L (test_function.to_Lp n 1 μ)

@[simp] lemma of_measure_apply [measurable_space E] [opens_measurable_space E]
  (μ : measure E) [is_finite_measure_on_compacts μ] (f : Cc^n⟮Ω, E, ℝ; ℝ⟯) :
  of_measure Ω n μ f = ∫ x : E, f x ∂μ :=
by rw [of_measure, integral_eq f (f.integrable μ), L1.integral_eq]; refl

noncomputable def dirac' [measurable_space E] [opens_measurable_space E] (x : E) : 𝓓' Ω ℝ n :=
  of_measure Ω n (measure.dirac x)

lemma dirac_eq_dirac' [measurable_space E] [opens_measurable_space E] (x : E) :
  dirac Ω n x = dirac' Ω n x :=
begin
  ext f,
  rw [dirac', dirac_apply, of_measure_apply, integral_dirac]
end

end distribution

section dderiv -- This will be generalized to fderiv, but I want to do some tests

variables (Ω : set ℝ) (F : Type*) [normed_group F] [normed_space ℝ F]

--def dderivₗ : 𝓓' Ω F ⊤ →ₗ[ℝ] 𝓓' Ω F ⊤ :=

end dderiv


import analysis.special_functions.trigonometric.deriv
import analysis.special_functions.log.deriv
import analysis.special_functions.sqrt
import analysis.calculus.cont_diff
import data.nat.log
import analysis.calculus.mean_value
import analysis.special_functions.trigonometric.arctan_deriv
import tactic
import analysis.special_functions.pow_deriv
import analysis.special_functions.trigonometric.inverse_deriv
import analysis.special_functions.log.base
open_locale topological_space
open_locale topological_space filter classical real

noncomputable theory

open set
open set filter
open real
namespace real

/- # This proof was our last, and there for quite messy and unfinished. -/
/- # Our main goal was to go from deriv c*log(a * y + b) to our system of 2 equations. This system is called system_a_2. -/
/- # Now, for our previous functions a, y, b, then we found deriv c*log(a * y + b) = x / y. -/
/- # This system can be rewritten as deriv c*log(a * y + b) = c* (a'*y+a*y'+b')/(a*y +b) in general. -/
/- # Then for a general a, y, and b, for deriv c*log(a * y + b) = x / y to hold, then c* (a'*y+a*y'+b')/(a*y +b) = x / y must hold. -/
/- # The easiest way to show this holds it to rewrite this to (a*y +b)*x = c*y*(a'*y + a*y' + b') =>  a*y*x + b*x - c*y*(a'*y + a*y') + c*y*b'= 0  -/
/- # We have the assumption that b is a polynomial of order 8, and than a = c*b'/x, thus the previous equation is reduced to b*x - c*y*(a'*y + a*y')= 0   -/
/- # To get rid for 1/x^2 b*x in a', we multiply by x^2, such that we get  x^2*(b*x - c*y*(a'*y + a*y'))= 0   -/
/- # Thus we have to show x^2*(b*x - c*y*(a'*y + a*y'))= 0, but this only holds under certain for the coeffiecient in y and b.   -/
/- # The relation between the coeffiecient in y and b is system_eleven. Thus if system_eleven holds iff x^2*(b*x - c*y*(a'*y + a*y'))= 0.   -/
/- # We only managed to show that system_eleven implies x^2*(b*x - c*y*(a'*y + a*y'))= 0, but if we had more we would have shown the other way as well.  -/

def fun_z_gen (x:ℝ) (e2:ℝ) (e3:ℝ) (e4:ℝ): ℝ := x^4+e2*x^2+e3*x+e4
def fun_b_gen (x:ℝ) (d7:ℝ) (d6:ℝ) (d5:ℝ) (d4:ℝ) (d3:ℝ) (d2:ℝ) (d1:ℝ) (d0:ℝ): ℝ
:= -x^8+d7*x^7+d6*x^6+d5*x^5+d4*x^4+d3*x^3+d2*x^2+d1*x+d0 -- d_8 = - 1 as an assumption, could be better implemented.
def fun_a_gen (x:ℝ) (d7:ℝ) (d6:ℝ) (d5:ℝ) (d4:ℝ) (d3:ℝ) (d2:ℝ) (d1:ℝ) : ℝ
:= (-1/8)*(-8*x^6+7*d7*x^5+6*d6*x^4+5*d5*x^3+4*d4*x^2+3*d3*x+2*d2+d1*x⁻¹)  -- this comes from the assumption c*b'/x, but again could be better implemented.
def deriv_fun_a_gen (x:ℝ) (d7:ℝ) (d6:ℝ) (d5:ℝ) (d4:ℝ) (d3:ℝ) (d1:ℝ) : ℝ
:= -8*6*(-1/8)*x^5+7*5*(-1/8)*d7*x^4+6*4*(-1/8)*d6*x^3+5*3*(-1/8)*d5*x^2+4*2*(-1/8)*d4*x+3*(-1/8)*d3-(-1/8)*d1/(x)^2 -- done by hand due to time pressure.
def deriv_fun_z_gen (x:ℝ) (e2:ℝ) (e3:ℝ): ℝ := 4*x^3+2*e2*x+e3  -- done by hand due to time pressure.

def system_a_2 (e_2 e_3 e_4 d_0 d_1 d_2 d_3 d_4 d_5 d_6 d_7 : ℝ):= (100*e_4 + 71*e_2^2=0) ∧ (70*e_3^2 + 972*e_2*e_4+45*e_2^3=0) ∧ d_0 = -(e_2 ^ 4 / 128) - 83 * e_2 * e_3 ^ 2 / 720 - 3 * e_2 ^ 2 * e_4 / 16 - e_4 ^ 2 / 8 ∧ d_1 = -(1 / 210 * e_3 * (71 * e_2 ^ 2 + 100 * e_4)) ∧ d_2 = -e_2 ^ 3 / 4 - 7 * e_3 ^ 2 / 18 - e_2 * e_4 ∧ d_3 = -(22 * e_2 * e_3 / 15) ∧ d_4 = -(5 * e_2 ^ 2 / 4) - e_4 ∧ d_5 = -(4 / 3 * e_3) ∧ d_6 = -(2 * e_2) ∧ d_7 = 0
def system_eleven (e_2 e_3 e_4 d_0 d_1 d_2 d_3 d_4 d_5 d_6 d_7 : ℝ) := -((d_1*e_4)/64) = 0 ∧ -((d_1*e_3)/128) = 0 ∧ 1/64*(d_2*e_3 + 3*d_3*e_4) = 0 ∧ 1/128*(-128*d_0 + 4*d_2*e_2 + 9*d_3*e_3 + 16*d_4*e_4) = 0 ∧
1/64*(-63*d_1 + 6*d_3*e_2 + 10*d_4*e_3 + 15*d_5*e_4) = 0 ∧ 1/128*(-120*d_2 + 24*d_4*e_2 + 35*d_5*e_3 + 48*d_6*e_4) = 0 ∧ 1/64*(-55*d_3 + 20*d_5*e_2 + 27*d_6*e_3 + 35*d_7*e_4) = 0 ∧
1/128*(-96*d_4 + 60*d_6*e_2 + 77*d_7*e_3 - 96*e_4) = 0 ∧ 1/64*(-39*d_5 + 42*d_7*e_2 - 52*e_3) = 0 ∧ -(7/16)*(d_6 + 2*e_2) = 0 ∧ -((15*d_7)/64) = 0
def system_eleven_neg (e_2 e_3 e_4 d_0 d_1 d_2 d_3 d_4 d_5 d_6 d_7 : ℝ) := ((15/64)* d_7)=0 ∧ (7 / 16 * d_6 + 7 / 8 * e_2)=0 ∧ ((-1)/64* (-39 * d_5 + 42 * d_7 * e_2 - 52 * e_3))=0  ∧ ((-1)/128 * (-96* d_4 + 60 * d_6 * e_2 + 77 * d_7 * e_3 - 96 * e_4))=0 ∧ ((-1)/64 * (-55 * d_3 + 20 * d_5 * e_2 + 27 * d_6 * e_3 + 35 * d_7 * e_4))=0 ∧ ((-1)/128 * (-120 * d_2 + 24 * d_4 * e_2 + 35 * d_5 * e_3 + 48 * d_6 * e_4))=0 ∧ ((-1)/64*(-63 * d_1 + 6 * d_3 * e_2 + 10 * d_4 * e_3 + 15 * d_5 * e_4))=0 ∧ ((-1)/128 * (-128 * d_0 + 4 * d_2 * e_2 + 9 * d_3 * e_3 + 16 * d_4 * e_4))=0 ∧ ((-1)/64 * (d_2 * e_3 + 3 * d_3 * e_4))=0 ∧ ((d_1 * e_3)/128)=0 ∧ ((d_1 * e_4)/64)=0

/- # Needed system eleven with minus signs in front of it to match my other functions.  -/
lemma system_eleven_implies_system_eleven_neg (x:ℝ) (d7:ℝ) (d6:ℝ) (d5:ℝ) (d4:ℝ) (d3:ℝ) (d2:ℝ) (d1:ℝ) (d0:ℝ)
(e2:ℝ) (e3:ℝ) (e4:ℝ):
system_eleven e2 e3 e4 d0 d1 d2 d3 d4 d5 d6 d7 → system_eleven_neg e2 e3 e4 d0 d1 d2 d3 d4 d5 d6 d7:=
begin
  unfold system_eleven,
  unfold system_eleven_neg,
  intro h,
  cases h with h1 h2,
  cases h2 with h2 h3,
  cases h3 with h3 h4,
  cases h4 with h4 h5,
  cases h5 with h5 h6,
  cases h6 with h6 h7,
  cases h7 with h7 h8,
  cases h8 with h8 h9,
  cases h9 with h9 h10,
  cases h10 with h10 h11,
  split,
  linarith,
  split,
  linarith,
  split,
  linarith,
  split,
  linarith,
  split,
  linarith,
  split,
  linarith,
  split,
  linarith,
  split,
  linarith,
  split,
  linarith,
  split,
  linarith,
  linarith,
end

lemma system_eleven_neg_implies_system_eleven (x:ℝ) (d7:ℝ) (d6:ℝ) (d5:ℝ) (d4:ℝ) (d3:ℝ) (d2:ℝ) (d1:ℝ) (d0:ℝ)
(e2:ℝ) (e3:ℝ) (e4:ℝ):
system_eleven_neg e2 e3 e4 d0 d1 d2 d3 d4 d5 d6 d7 → system_eleven e2 e3 e4 d0 d1 d2 d3 d4 d5 d6 d7:=
begin
  unfold system_eleven,
  unfold system_eleven_neg,
  intro h,
  cases h with h1 h2,
  cases h2 with h2 h3,
  cases h3 with h3 h4,
  cases h4 with h4 h5,
  cases h5 with h5 h6,
  cases h6 with h6 h7,
  cases h7 with h7 h8,
  cases h8 with h8 h9,
  cases h9 with h9 h10,
  cases h10 with h10 h11,
  split,
  linarith,
  split,
  linarith,
  split,
  linarith,
  split,
  linarith,
  split,
  linarith,
  split,
  linarith,
  split,
  linarith,
  split,
  linarith,
  split,
  linarith,
  split,
  linarith,
  linarith,
end

lemma system_eleven_iff_system_eleven_neg (x:ℝ) (d7:ℝ) (d6:ℝ) (d5:ℝ) (d4:ℝ) (d3:ℝ) (d2:ℝ) (d1:ℝ) (d0:ℝ)
(e2:ℝ) (e3:ℝ) (e4:ℝ):
system_eleven e2 e3 e4 d0 d1 d2 d3 d4 d5 d6 d7 ↔ system_eleven_neg e2 e3 e4 d0 d1 d2 d3 d4 d5 d6 d7:=
begin
  split,
  apply system_eleven_implies_system_eleven_neg x d7 d6 d5 d4 d3 d2 d1 d0 e2 e3 e4,
  apply system_eleven_neg_implies_system_eleven x d7 d6 d5 d4 d3 d2 d1 d0 e2 e3 e4,
end

lemma unfolding_polynomial_first_term (x:ℝ) (d7:ℝ) (d6:ℝ) (d5:ℝ) (d4:ℝ) (d3:ℝ) (d2:ℝ) (d1:ℝ) (d0:ℝ):
x.fun_b_gen d7 d6 d5 d4 d3 d2 d1 d0 * x ^ 3= (-1) * x ^ 11 + d7 * x ^ 10 + d6 * x ^ 9 + d5 * x ^ 8 + d4 * x ^ 7 + d3 * x ^ 6 + d2 * x ^ 5 + d1 * x ^ 4 + d0 * x ^ 3:=
begin
  unfold fun_b_gen,
  repeat {conv_lhs {rw add_mul,}},
  ring_nf,
end

/- # Again, a better and more efficient way could have been used here, but due to time pressure this was not   -/
/- # Would have needed to add x≠0 to be with out sorrys, but due to time pressure, this has not been implemented.    -/
lemma unfolding_polynomial_second_term (x:ℝ) (d7:ℝ) (d6:ℝ) (d5:ℝ) (d4:ℝ) (d3:ℝ) (d2:ℝ) (d1:ℝ) (d0:ℝ)
(e2:ℝ) (e3:ℝ) (e4:ℝ):
1 / 8 * (x.deriv_fun_a_gen d7 d6 d5 d4 d3 d1 * x.fun_z_gen e2 e3 e4) * x ^ 2 = 3 / 4 * x ^ 11 + -(35 / 64 * d7 * x ^ 10) + 1 / 8 * (6 * e2 + -(3 * d6)) * x ^ 9 + 1 / 8 * (-(35 / 8 * d7 * e2) + 6 * e3 + -(15 / 8 * d5)) * x ^ 8 + 1 / 8 * (-(35 / 8 * d7 * e3) + -(3 * d6 * e2) + 6 * e4 + -d4) * x ^ 7 + 1 / 8 * (-(3 * d6 * e3) + -(35 / 8 * d7 * e4) + -(15 / 8 * d5 * e2) + -(3 / 8 * d3)) * x ^ 6 + 1 / 8 * (-(15 / 8 * d5 * e3) + -(3 * d6 * e4) + -(d4 * e2)) * x ^ 5 + 1 / 8 * (-(15 / 8 * d5 * e4) + -(d4 * e3) + -(3 / 8 * d3 * e2) + 1 / 8 * d1) * x ^ 4 + 1 / 8 * (-(d4 * e4) + -(3 / 8 * d3 * e3)) * x ^ 3 + 1 / 8 * (-(3 / 8 * d3 * e4) + 1 / 8 * d1 * e2) * x ^ 2 + 1 / 64 * d1 * e3 * x + 1 / 64 * d1 * e4:=
begin
  rw mul_assoc,
  rw mul_assoc,
  --unfold deriv_fun_a_gen,
  unfold fun_z_gen,
  repeat {conv_lhs {rw add_mul,}},
  have h1: x ^ 4 * x ^ 2 + e2 * x ^ 2 * x ^ 2 + e3 * x * x ^ 2 + e4 * x ^ 2 = x ^ 6 + e2 * x ^ 4 + e3 * x ^ 3 + e4 * x ^ 2,
    ring_nf,
  rw h1,
  unfold deriv_fun_a_gen,
  rw sub_mul,
  repeat {conv_lhs {rw add_mul,}},
  have h2: (-8) * 6 * ((-1) / 8) * x ^ 5 * (x ^ 6 + e2 * x ^ 4 + e3 * x ^ 3 + e4 * x ^ 2) = (6) * x ^ 11  + (6) * e2 * x ^ 9 + (6) * e3 * x ^ 8 + (6) * e4 * x ^ 7,
    ring_nf,
  rw h2,
  have h3: 7 * 5 * ((-1) / 8) * d7 * x ^ 4 * (x ^ 6 + e2 * x ^ 4 + e3 * x ^ 3 + e4 * x ^ 2)= (-35/8) * d7 * x ^ 10 + (-35/8) * d7 * e2 * x ^ 8 + (-35/8) * d7 *e3 * x ^ 7 + (-35/8) * d7 *e4 * x ^ 6,
    ring_nf,
  rw h3,
  have h4: 6 * 4 * ((-1) / 8) * d6 * x ^ 3 * (x ^ 6 + e2 * x ^ 4 + e3 * x ^ 3 + e4 * x ^ 2) = (-3) * d6 * x ^ 9  + (-3) * d6 *e2 * x ^ 7 + (-3) * d6 * e3 * x ^ 6 + (-3) * d6 * e4 * x ^ 5,
    ring_nf,
  rw h4,
  have h5: 5 * 3 * ((-1) / 8) * d5 * x ^ 2 * (x ^ 6 + e2 * x ^ 4 + e3 * x ^ 3 + e4 * x ^ 2) = (-15/8) * d5 * x ^ 8 + (-15/8) * d5 * e2 * x ^ 6 +(-15/8) * d5 * e3 * x ^ 5 + (-15/8) * d5 * e4 * x ^ 4,
    ring_nf,
  rw h5,
  --4 * 2 * ((-1) / 8) * d4 * x * (x ^ 6 + e2 * x ^ 4 + e3 * x ^ 3 + e4 * x ^ 2)
  have h6: 4 * 2 * ((-1) / 8) * d4 * x * (x ^ 6 + e2 * x ^ 4 + e3 * x ^ 3 + e4 * x ^ 2)  = (-1) * d4 * x ^ 7 + (-1) * d4 *e2 * x ^ 5 + (-1) * d4 * e3 * x ^ 4 + (-1) * d4 *e4 * x ^ 3,
    ring_nf,
  rw h6,
  --3 * ((-1) / 8) * d3 * (x ^ 6 + e2 * x ^ 4 + e3 * x ^ 3 + e4 * x ^ 2)
  have h7: 3 * ((-1) / 8) * d3 * (x ^ 6 + e2 * x ^ 4 + e3 * x ^ 3 + e4 * x ^ 2) = (-3/8) * d3 * x ^ 6 + (-3/8) * d3 *e2 * x ^ 4 + (-3/8) * d3 *e3 * x ^ 3 + (-3/8) * d3 *e4 * x ^ 2,
    ring_nf,
  rw h7,
  -- (-1) / 8 * d1 / x ^ 2 * (x ^ 6 + e2 * x ^ 4 + e3 * x ^ 3 + e4 * x ^ 2))
  have h8: (-1) / 8 * d1 / x ^ 2 * (x ^ 6 + e2 * x ^ 4 + e3 * x ^ 3 + e4 * x ^ 2) = (-1) / 8 * d1 * x ^ 4 + (-1) / 8 * d1 * e2 * x ^ 2 +  (-1) / 8 * d1 * e3 * x + (-1) / 8 * d1 * e4,
    ring_nf,
    sorry,
  rw h8,
  repeat {conv_lhs {rw sub_eq_add_neg,}},
  repeat {conv_lhs {rw ← add_assoc,}}, -----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------d1 * x ^ 4 +  d1 * e2 * x ^ 2 +  d1 * e3 * x +  d1 * e4,
  have h9: (6) * x ^ 11 + (6) * e2 * x ^ 9 + (6) * e3 * x ^ 8 + (6) * e4 * x ^ 7 + (-35/8) * d7 * x ^ 10 + (-35/8) * d7 * e2 * x ^ 8 +(-35/8) * d7 * e3 * x ^ 7 +(-35/8) * d7 * e4 * x ^ 6 +(-3) * d6 * x ^ 9 +(-3) * d6 * e2 * x ^ 7 + (-3) * d6 * e3 * x ^ 6 + (-3) * d6 * e4 * x ^ 5 + (-15/8) * d5 * x ^ 8 + (-15/8) * d5 * e2 * x ^ 6 + (-15/8) * d5 * e3 * x ^ 5 + (-15/8)* d5 * e4 * x ^ 4 + (-1) * d4 * x ^ 7 + (-1) * d4 * e2 * x ^ 5 + (-1) * d4 * e3 * x ^ 4 + (-1) * d4 * e4 * x ^ 3 +(-3/8) * d3 * x ^ 6 + (-3/8) * d3 * e2 * x ^ 4 + (-3/8) * d3 * e3 * x ^ 3 + (-3/8) * d3 * e4 * x ^ 2    =    (6) * x ^ 11   + (-35/8) * d7 * x ^ 10  + ((6) * e2   + (-3) * d6) * x ^ 9+ ((-35/8) * d7 * e2 + (6) * e3   + (-15/8) * d5 ) * x ^ 8 + ((-35/8) * d7 * e3  + (-3) * d6 * e2 + (6) * e4 + (-1) * d4) * x ^ 7+ ((-3) * d6 * e3 + (-35/8) * d7 * e4 + (-15/8) * d5 * e2 +(-3/8) * d3) * x ^ 6   + ((-15/8) * d5 * e3 + (-3) * d6 * e4  + (-1) * d4 * e2) * x ^ 5   +((-15/8) * d5 * e4 + (-1) * d4 * e3 + (-3/8) * d3 * e2) * x ^ 4 +((-1) * d4 * e4 +  (-3/8) * d3 * e3) * x ^ 3 + (-3/8) * d3 * e4 * x ^ 2,
    ring_nf,
  rw h9,
  have h10: (-((-1) / 8 * d1 * x ^ 4 + (-1) / 8 * d1 * e2 * x ^ 2 + (-1) / 8 * d1 * e3 * x + (-1) / 8 * d1 * e4))= (-1)*((-1) / 8* d1 * x ^ 4 + (-1) / 8*d1 * e2 * x ^ 2 + (-1) / 8* d1 * e3 * x + (-1) / 8*d1 * e4),
    ring_nf,
  rw h10,
  rw mul_add (-1) ((-1) / 8 * d1 * x ^ 4 + (-1) / 8 * d1 * e2 * x ^ 2 + (-1) / 8 * d1 * e3 * x ) ((-1) / 8 * d1 * e4),
  rw mul_add (-1) ((-1) / 8 * d1 * x ^ 4 + (-1) / 8 * d1 * e2 * x ^ 2 ) ((-1) / 8 * d1 * e3 * x ),
  rw mul_add (-1) ((-1) / 8 * d1 * x ^ 4) ((-1) / 8 * d1 * e2 * x ^ 2 ),
  have h11: (6) * x ^ 11 + (-35/8) * d7 * x ^ 10 + ((6) * e2 + (-3) * d6) * x ^ 9 +((-35/8) * d7 * e2 + (6) * e3 + (-15/8) * d5) * x ^ 8 +((-35/8) * d7 * e3 + (-3) * d6 * e2 + (6) * e4 + (-1) * d4) * x ^ 7 +((-3) * d6 * e3 + (-35/8) * d7 * e4 + (-15/8) * d5 * e2 + (-3/8) * d3) * x ^ 6 +((-15/8) * d5 * e3 + (-3) * d6 * e4 + (-1) * d4 * e2) * x ^ 5 +((-15/8) * d5 * e4 + (-1) * d4 * e3 + (-3/8) * d3 * e2) * x ^ 4 +((-1) * d4 * e4 + (-3/8) * d3 * e3) * x ^ 3 + (-3/8) * d3 * e4 * x ^ 2 +((-1) * ( (-1) / 8 * d1 * x ^ 4) + (-1) * ((-1) / 8 *d1 * e2 * x ^ 2) + (-1) * ( (-1) / 8 *d1 * e3 * x) + (-1) * ((-1) / 8 * d1 * e4)) = (6) * x ^ 11 + (-35/8) * d7 * x ^ 10 + ((6) * e2 + (-3) * d6) * x ^ 9 +((-35/8) * d7 * e2 + (6) * e3 + (-15/8) * d5) * x ^ 8 +((-35/8) * d7 * e3 + (-3) * d6 * e2 + (6) * e4 + (-1) * d4) * x ^ 7 +((-3) * d6 * e3 + (-35/8) * d7 * e4 + (-15/8) * d5 * e2 + (-3/8) * d3) * x ^ 6 +((-15/8) * d5 * e3 + (-3) * d6 * e4 + (-1) * d4 * e2) * x ^ 5 +((-15/8) * d5 * e4 + (-1) * d4 * e3 + (-3/8) * d3 * e2 +(-1) * (-1) / 8 *d1) * x ^ 4 +((-1) * d4 * e4 + (-3/8) * d3 * e3) * x ^ 3 + ((-3/8) * d3 * e4+ (-1) * (-1) / 8 * d1 * e2)* x ^ 2  + ((-1) * (-1) / 8 * d1 * e3) * x + (-1) * (-1) / 8 *d1 * e4,
    ring_nf,
  rw h11,
  repeat {conv_lhs {rw mul_add,}},
  repeat {conv_lhs {rw ← mul_assoc,}},
  conv_lhs {norm_num,}
end

lemma unfolding_polynomial_third_term (x:ℝ) (d7:ℝ) (d6:ℝ) (d5:ℝ) (d4:ℝ) (d3:ℝ) (d2:ℝ) (d1:ℝ) (d0:ℝ)
(e2:ℝ) (e3:ℝ) (e4:ℝ):
1 / 8 * (1 / 2 * x.fun_a_gen d7 d6 d5 d4 d3 d2 d1 * x.deriv_fun_z_gen e2 e3) * x ^ 2 = 1 / 4 * x ^ 11 + -(7 / 32) * d7 * x ^ 10 + -(1 / 128) * ((-16) * e2 + 24 * d6) * x ^ 9 + -(1 / 128) * ((-8) * e3 + 20 * d5 + 7 * d7 * 2 * e2) * x ^ 8 + -(1 / 128) * (16 * d4 + 6 * d6 * 2 * e2 + 7 * d7 * e3) * x ^ 7 + -(1 / 128) * (12 * d3 + 5 * d5 * 2 * e2 + 6 * d6 * e3) * x ^ 6 + -(1 / 128) * (8 * d2 + 4 * d4 * 2 * e2 + 5 * d5 * e3) * x ^ 5 + -(1 / 128) * (4 * d1 + 3 * d3 * 2 * e2 + 4 * d4 * e3) * x ^ 4 + -(1 / 128) * (2 * d2 * 2 * e2 + 3 * d3 * e3) * x ^ 3 + -(1 / 128) * (d1 * 2 * e2 + 2 * d2 * e3) * x ^ 2 + -(1 / 128) * d1 * e3 * x:=
begin
  rw mul_assoc,
  rw mul_assoc,
  --unfold fun_a_gen,
  unfold deriv_fun_z_gen,
  repeat {conv_lhs {rw add_mul,}},
  have h1: 4 * x ^ 3 * x ^ 2 + 2 * e2 * x * x ^ 2 + e3 * x ^ 2= 4 * x ^ 5  + 2 * e2 * x ^ 3 + e3 * x ^ 2,
    ring_nf,
  rw h1,
  unfold fun_a_gen,
  rw mul_assoc,
  repeat {conv_lhs {rw mul_add,}},
  have h2: 1 / 8 * (1 / 2 * (((-1) / 8 * ((-8) * x ^ 6) + (-1) / 8 * (7 * d7 * x ^ 5) + (-1) / 8 * (6 * d6 * x ^ 4) + (-1) / 8 * (5 * d5 * x ^ 3) + (-1) / 8 * (4 * d4 * x ^ 2) + (-1) / 8 * (3 * d3 * x) + (-1) / 8 * (2 * d2) + (-1) / 8 * (d1 * x⁻¹)) * (4 * x ^ 5))) = (-1) / 64 *(1 / 2 *(((-8) * 4* x ^ 11  + 7 * 4 * d7 * x ^ 10 + 6 *4 * d6 * x ^ 9 + 5 *4 * d5 * x ^ 8 + 4 * 4* d4 * x ^ 7 + 3 * 4 * d3 * x ^ 6 + 2 * 4* d2 * x ^5 + 4*d1*x⁻¹*x^5 ) )),
    ring_nf,
  have h2extra:  4*d1*x⁻¹*x^5= 4* d1 * x ^4,
      sorry,
  have h3: 1 / 8 * (1 / 2 * (((-1) / 8 * ((-8) * x ^ 6) + (-1) / 8 * (7 * d7 * x ^ 5) + (-1) / 8 * (6 * d6 * x ^ 4) + (-1) / 8 * (5 * d5 * x ^ 3) + (-1) / 8 * (4 * d4 * x ^ 2) + (-1) / 8 * (3 * d3 * x) + (-1) / 8 * (2 * d2) + (-1) / 8 * (d1 * x⁻¹)) * (4 * x ^ 5))) = (-1) / 64 *(1 / 2 *(((-8) * 4* x ^ 11  + 7 * 4 * d7 * x ^ 10 + 6 *4 * d6 * x ^ 9 + 5 *4 * d5 * x ^ 8 + 4 * 4* d4 * x ^ 7 + 3 * 4 * d3 * x ^ 6 + 2 * 4* d2 * x ^5 + 4*d1*x^4 ) )),
    rw h2,
    rw h2extra,
  rw h3,
  have h4: 1 / 8 * (1 / 2 * (((-1) / 8 * ((-8) * x ^ 6) + (-1) / 8 * (7 * d7 * x ^ 5) + (-1) / 8 * (6 * d6 * x ^ 4) + (-1) / 8 * (5 * d5 * x ^ 3) + (-1) / 8 * (4 * d4 * x ^ 2) + (-1) / 8 * (3 * d3 * x) + (-1) / 8 * (2 * d2) + (-1) / 8 * (d1 * x⁻¹)) * (2 * e2 * x ^ 3)))=(-1) / 64 *(1 / 2 *(((-8)  * 2 * e2 * x ^ 9 + 7 * d7 * 2 * e2 * x ^ 8 + 6 * d6 *  2 * e2 * x ^ 7 + 5 * d5 * 2 * e2 * x ^ 6 + 4 * d4 * 2 * e2 * x ^ 5 + 3 * d3 * 2 * e2 * x ^ 4 + 2 * d2 * 2 * e2 * x ^ 3 +d1 *  2 * e2 * x⁻¹ *x ^ 3) )),
    ring_nf,
  rw h4,
  have h5: 1 / 8 * (1 / 2 * (((-1) / 8 * ((-8) * x ^ 6) + (-1) / 8 * (7 * d7 * x ^ 5) + (-1) / 8 * (6 * d6 * x ^ 4) + (-1) / 8 * (5 * d5 * x ^ 3) + (-1) / 8 * (4 * d4 * x ^ 2) + (-1) / 8 * (3 * d3 * x) + (-1) / 8 * (2 * d2) + (-1) / 8 * (d1 * x⁻¹)) * (e3 * x ^ 2)))= (-1) / 64 *(1 / 2 *(((-8) * e3 * x ^ 8 + 7 * d7  * e3 * x ^ 7 + 6 * d6 * e3 * x ^ 6 + 5 * d5 * e3 * x ^ 5 + 4 * d4 * e3 * x ^ 4 + 3 * d3 * e3 * x ^ 3 + 2 * d2 *e3 * x ^ 2 + d1 * e3 * x ^ 2 * x⁻¹) )),
    ring_nf,
  rw h5,
  have h3extra: d1 * e3 * x ^ 2 * x⁻¹ = d1 * e3 * x,
    sorry,
  rw h3extra,
  have h4extra: d1 * 2 * e2 * x⁻¹ * x ^ 3 = d1 * 2 * e2 *  x ^ 2,
    sorry,
  rw h4extra,
  rw ← mul_add,
  rw ← mul_add,
  rw ← mul_add,
  rw ← mul_add,
  repeat {conv_lhs {rw ← add_assoc,}},
  have h5: (-8) * 4 * x ^ 11 + 7 * 4 * d7 * x ^ 10 + 6 * 4 * d6 * x ^ 9 + 5 * 4 * d5 * x ^ 8 + 4 * 4 * d4 * x ^ 7 + 3 * 4 * d3 * x ^ 6 + 2 * 4 * d2 * x ^ 5 + 4 * d1 * x ^ 4 + (-8) * 2 * e2 * x ^ 9 + 7 * d7 * 2 * e2 * x ^ 8 + 6 * d6 * 2 * e2 * x ^ 7 + 5 * d5 * 2 * e2 * x ^ 6 + 4 * d4 * 2 * e2 * x ^ 5 + 3 * d3 * 2 * e2 * x ^ 4 + 2 * d2 * 2 * e2 * x ^ 3 + d1 * 2 * e2 * x ^ 2 +(-8) * e3 * x ^ 8 + 7 * d7 * e3 * x ^ 7 + 6 * d6 * e3 * x ^ 6 +  5 * d5 * e3 * x ^ 5 + 4 * d4 * e3 * x ^ 4 +3 * d3 * e3 * x ^ 3 + 2 * d2 * e3 * x ^ 2 +d1 * e3 * x     =       (-8) * 4 * x ^ 11 + 7 * 4 * d7 * x ^ 10 + ((-8) * 2 * e2 + 6 * 4 * d6) * x ^ 9 + ( (-8) * e3  +5 * 4 * d5 + 7 * d7 * 2 * e2) * x ^ 8 + (4 * 4 * d4 + 6 * d6 * 2 * e2 + 7 * d7 * e3) * x ^ 7 + (3 * 4 * d3 + 5 * d5 * 2 * e2 + 6 * d6 * e3) * x ^ 6 + (2 * 4 * d2 + 4 * d4 * 2 * e2 +  5 * d5 * e3)* x ^ 5  + (4 * d1 + 3 * d3 * 2 * e2  + 4 * d4 * e3) * x ^ 4+ (2 * d2 * 2 * e2 +3 * d3 * e3) * x ^ 3 + (d1 * 2 * e2 + 2 * d2 * e3) * x ^ 2 + d1 * e3 * x,
    ring_nf,
  rw h5,
  repeat {conv_lhs {rw mul_add,}},
  repeat {conv_lhs {rw ← mul_assoc,}},
  conv_lhs {norm_num,},
  repeat {conv_lhs {rw ← mul_assoc,}},
  repeat {conv_lhs {rw ← neg_mul,}},
end

lemma eq_11 (x:ℝ) (d7:ℝ) (d6:ℝ) (d5:ℝ) (d4:ℝ) (d3:ℝ) (d2:ℝ) (d1:ℝ) (d0:ℝ)
(e2:ℝ) (e3:ℝ) (e4:ℝ):
d7 + -(35 / 64 * d7) + -(7 / 32 * d7)=(15/64)* d7:=
begin
  field_simp,
  ring_nf,
end

lemma eq_10 (x:ℝ) (d7:ℝ) (d6:ℝ) (d5:ℝ) (d4:ℝ) (d3:ℝ) (d2:ℝ) (d1:ℝ) (d0:ℝ)
(e2:ℝ) (e3:ℝ) (e4:ℝ):
(d6 + 1 / 8 * (6 * e2 + -(3 * d6)) + -(1 / 128 * (-(16 * e2) + 24 * d6)))=7 / 16 * d6 + 7 / 8 * e2:=
begin
  conv_lhs {simp,},
  conv_lhs {ring_nf,},
end

lemma eq_9 (x:ℝ) (d7:ℝ) (d6:ℝ) (d5:ℝ) (d4:ℝ) (d3:ℝ) (d2:ℝ) (d1:ℝ) (d0:ℝ)
(e2:ℝ) (e3:ℝ) (e4:ℝ):
(d5 + 1 / 8 * (-(35 / 8 * d7 * e2) + 6 * e3 + -(15 / 8 * d5)) + -(1 / 128 * (-(8 * e3) + 20 * d5 + 7 * d7 * 2 * e2)))=(-1)/64* (-39 * d5 + 42 * d7 * e2 - 52 * e3):=
begin
  simp,
  ring_nf,
end

lemma eq_8 (x:ℝ) (d7:ℝ) (d6:ℝ) (d5:ℝ) (d4:ℝ) (d3:ℝ) (d2:ℝ) (d1:ℝ) (d0:ℝ)
(e2:ℝ) (e3:ℝ) (e4:ℝ):
(d4 + -(1 / 128 * (16 * d4 + 6 * d6 * 2 * e2 + 7 * d7 * e3)) + 1 / 8 * (-(35 / 8 * d7 * e3) + -(3 * d6 * e2) + 6 * e4 + -d4))=(-1)/128 * (-96* d4 + 60 * d6 * e2 + 77 * d7 * e3 - 96 * e4):=
begin
  simp,
  ring_nf,
end

lemma eq_7 (x:ℝ) (d7:ℝ) (d6:ℝ) (d5:ℝ) (d4:ℝ) (d3:ℝ) (d2:ℝ) (d1:ℝ) (d0:ℝ)
(e2:ℝ) (e3:ℝ) (e4:ℝ):
(d3 + 1 / 8 * (-(3 * d6 * e3) + -(35 / 8 * d7 * e4) + -(15 / 8 * d5 * e2) + -(3 / 8 * d3)) + -(1 / 128 * (12 * d3 + 5 * d5 * 2 * e2 + 6 * d6 * e3)))=(-1)/64 * (-55 * d3 + 20 * d5 * e2 + 27 * d6 * e3 + 35 * d7 * e4):=
begin
  simp,
  ring_nf,
end

lemma eq_6 (x:ℝ) (d7:ℝ) (d6:ℝ) (d5:ℝ) (d4:ℝ) (d3:ℝ) (d2:ℝ) (d1:ℝ) (d0:ℝ)
(e2:ℝ) (e3:ℝ) (e4:ℝ):
(d2 + 1 / 8 * (-(15 / 8 * d5 * e3) + -(3 * d6 * e4) + -(d4 * e2)) + -(1 / 128 * (8 * d2 + 4 * d4 * 2 * e2 + 5 * d5 * e3))) =(-1)/128 * (-120 * d2 + 24 * d4 * e2 + 35 * d5 * e3 + 48 * d6 * e4):=
begin
  simp,
  ring_nf,
end

lemma eq_5 (x:ℝ) (d7:ℝ) (d6:ℝ) (d5:ℝ) (d4:ℝ) (d3:ℝ) (d2:ℝ) (d1:ℝ) (d0:ℝ)
(e2:ℝ) (e3:ℝ) (e4:ℝ):
(d1 + -(1 / 128 * (4 * d1 + 3 * d3 * 2 * e2 + 4 * d4 * e3)) + 1 / 8 * (-(15 / 8 * d5 * e4) + -(d4 * e3) + -(3 / 8 * d3 * e2) + 1 / 8 * d1))=(-1)/64*(-63 * d1 + 6 * d3 * e2 + 10 * d4 * e3 + 15 * d5 * e4):=
begin
  simp,
  ring_nf,
end

lemma eq_4 (x:ℝ) (d7:ℝ) (d6:ℝ) (d5:ℝ) (d4:ℝ) (d3:ℝ) (d2:ℝ) (d1:ℝ) (d0:ℝ)
(e2:ℝ) (e3:ℝ) (e4:ℝ):
(d0 + 1 / 8 * (-(d4 * e4) + -(3 / 8 * d3 * e3)) + -(1 / 128 * (2 * d2 * 2 * e2 + 3 * d3 * e3)))=(-1)/128 * (-128 * d0 + 4 * d2 * e2 + 9 * d3 * e3 + 16 * d4 * e4):=
begin
  simp,
  ring_nf,
end

lemma eq_3 (x:ℝ) (d7:ℝ) (d6:ℝ) (d5:ℝ) (d4:ℝ) (d3:ℝ) (d2:ℝ) (d1:ℝ) (d0:ℝ)
(e2:ℝ) (e3:ℝ) (e4:ℝ):
(1 / 8 * (-(3 / 8 * d3 * e4) + 1 / 8 * d1 * e2) + -(1 / 128 * (d1 * 2 * e2 + 2 * d2 * e3)))= (-1)/64 * (d2 * e3 + 3 * d3 * e4):=
begin
  simp,
  ring_nf,
end

lemma eq_2 (x:ℝ) (d7:ℝ) (d6:ℝ) (d5:ℝ) (d4:ℝ) (d3:ℝ) (d2:ℝ) (d1:ℝ) (d0:ℝ)
(e2:ℝ) (e3:ℝ) (e4:ℝ):
(1 / 64 * d1 * e3 + -(1 / 128 * d1 * e3))=((d1 * e3)/128):=
begin
  simp,
  ring_nf,
end

lemma eq_1 (x:ℝ) (d7:ℝ) (d6:ℝ) (d5:ℝ) (d4:ℝ) (d3:ℝ) (d2:ℝ) (d1:ℝ) (d0:ℝ)
(e2:ℝ) (e3:ℝ) (e4:ℝ):
1 / 64 * d1 * e4=((d1 * e4)/64):=
begin
  simp,
  ring_nf,
end

/- # Again, a better and more efficient way could have been used here, but due to time pressure this was not   -/
lemma unfolding_polynomial (x:ℝ) (d7:ℝ) (d6:ℝ) (d5:ℝ) (d4:ℝ) (d3:ℝ) (d2:ℝ) (d1:ℝ) (d0:ℝ)
(e2:ℝ) (e3:ℝ) (e4:ℝ):
((fun_b_gen x d7 d6 d5 d4 d3 d2 d1 d0)*x-(-1/8)*((deriv_fun_a_gen x d7 d6 d5 d4 d3 d1)*(fun_z_gen x e2 e3 e4)+(1/2)*(fun_a_gen x d7 d6 d5 d4 d3 d2 d1)*(deriv_fun_z_gen x e2 e3))) * x^2= (d7 + -(35 / 64 * d7) + -(7 / 32 * d7)) * x ^ 10 + (d6 + 1 / 8 * (6 * e2 + -(3 * d6)) + -(1 / 128 * (-(16 * e2) + 24 * d6))) * x ^ 9 + (d5 + 1 / 8 * (-(35 / 8 * d7 * e2) + 6 * e3 + -(15 / 8 * d5)) + -(1 / 128 * (-(8 * e3) + 20 * d5 + 7 * d7 * 2 * e2))) * x ^ 8 + (d4 + -(1 / 128 * (16 * d4 + 6 * d6 * 2 * e2 + 7 * d7 * e3)) + 1 / 8 * (-(35 / 8 * d7 * e3) + -(3 * d6 * e2) + 6 * e4 + -d4)) * x ^ 7 + (d3 + 1 / 8 * (-(3 * d6 * e3) + -(35 / 8 * d7 * e4) + -(15 / 8 * d5 * e2) + -(3 / 8 * d3)) + -(1 / 128 * (12 * d3 + 5 * d5 * 2 * e2 + 6 * d6 * e3))) * x ^ 6 + (d2 + 1 / 8 * (-(15 / 8 * d5 * e3) + -(3 * d6 * e4) + -(d4 * e2)) + -(1 / 128 * (8 * d2 + 4 * d4 * 2 * e2 + 5 * d5 * e3))) * x ^ 5 + (d1 + -(1 / 128 * (4 * d1 + 3 * d3 * 2 * e2 + 4 * d4 * e3)) + 1 / 8 * (-(15 / 8 * d5 * e4) + -(d4 * e3) + -(3 / 8 * d3 * e2) + 1 / 8 * d1)) * x ^ 4 + (d0 + 1 / 8 * (-(d4 * e4) + -(3 / 8 * d3 * e3)) + -(1 / 128 * (2 * d2 * 2 * e2 + 3 * d3 * e3))) * x ^ 3 + (1 / 8 * (-(3 / 8 * d3 * e4) + 1 / 8 * d1 * e2) + -(1 / 128 * (d1 * 2 * e2 + 2 * d2 * e3))) * x ^ 2 + (1 / 64 * d1 * e3 + -(1 / 128 * d1 * e3)) * x + 1 / 64 * d1 * e4:=
begin
  repeat {conv_lhs {rw sub_mul,}},
  conv_lhs {rw mul_assoc,},
  nth_rewrite 1 ← pow_one x,
  conv_lhs {rw ← pow_add,},
  conv_lhs {norm_num,},
  conv_lhs {rw mul_add,},
  conv_lhs {rw add_mul,},
  conv_lhs {rw unfolding_polynomial_first_term x d7 d6 d5 d4 d3 d2 d1 d0,},
  conv_lhs {rw unfolding_polynomial_second_term x d7 d6 d5 d4 d3 d2 d1 d0 e2 e3 e4,},
  conv_lhs {rw unfolding_polynomial_third_term x d7 d6 d5 d4 d3 d2 d1 d0 e2 e3 e4,},
  repeat {conv_lhs {rw ← add_assoc,}},
  have h: (-1) * x ^ 11 + d7 * x ^ 10 + d6 * x ^ 9 + d5 * x ^ 8 + d4 * x ^ 7 + d3 * x ^ 6 + d2 * x ^ 5 + d1 * x ^ 4 + d0 * x ^ 3 + 3 / 4 * x ^ 11 + -(35 / 64 * d7 * x ^ 10) + 1 / 8 * (6 * e2 + -(3 * d6)) * x ^ 9 + 1 / 8 * (-(35 / 8 * d7 * e2) + 6 * e3 + -(15 / 8 * d5)) * x ^ 8 + 1 / 8 * (-(35 / 8 * d7 * e3) + -(3 * d6 * e2) + 6 * e4 + -d4) * x ^ 7 + 1 / 8 * (-(3 * d6 * e3) + -(35 / 8 * d7 * e4) + -(15 / 8 * d5 * e2) + -(3 / 8 * d3)) * x ^ 6 + 1 / 8 * (-(15 / 8 * d5 * e3) + -(3 * d6 * e4) + -(d4 * e2)) * x ^ 5 + 1 / 8 * (-(15 / 8 * d5 * e4) + -(d4 * e3) + -(3 / 8 * d3 * e2) + 1 / 8 * d1) * x ^ 4 + 1 / 8 * (-(d4 * e4) + -(3 / 8 * d3 * e3)) * x ^ 3 + 1 / 8 * (-(3 / 8 * d3 * e4) + 1 / 8 * d1 * e2) * x ^ 2 + 1 / 64 * d1 * e3 * x + 1 / 64 * d1 * e4 + 1 / 4 * x ^ 11 + -(7 / 32) * d7 * x ^ 10 + -(1 / 128) * ((-16) * e2 + 24 * d6) * x ^ 9 + -(1 / 128) * ((-8) * e3 + 20 * d5 + 7 * d7 * 2 * e2) * x ^ 8 + -(1 / 128) * (16 * d4 + 6 * d6 * 2 * e2 + 7 * d7 * e3) * x ^ 7 + -(1 / 128) * (12 * d3 + 5 * d5 * 2 * e2 + 6 * d6 * e3) * x ^ 6 + -(1 / 128) * (8 * d2 + 4 * d4 * 2 * e2 + 5 * d5 * e3) * x ^ 5 + -(1 / 128) * (4 * d1 + 3 * d3 * 2 * e2 + 4 * d4 * e3) * x ^ 4 + -(1 / 128) * (2 * d2 * 2 * e2 + 3 * d3 * e3) * x ^ 3 + -(1 / 128) * (d1 * 2 * e2 + 2 * d2 * e3) * x ^ 2 + -(1 / 128) * d1 * e3 * x                             =                       (d7 + -(35 / 64 * d7) + -(7 / 32) * d7) * x ^ 10 + (d6+ 1 / 8 * (6 * e2 + -(3 * d6))  + -(1 / 128) * ((-16) * e2 + 24 * d6)) * x ^ 9 + (d5  + 1 / 8 * (-(35 / 8 * d7 * e2) + 6 * e3 + -(15 / 8 * d5))  + -(1 / 128) * ((-8) * e3 + 20 * d5 + 7 * d7 * 2 * e2)) * x ^ 8+ (d4 + -(1 / 128) * (16 * d4 + 6 * d6 * 2 * e2 + 7 * d7 * e3)   + 1 / 8 * (-(35 / 8 * d7 * e3) + -(3 * d6 * e2) + 6 * e4 + -d4)) * x ^ 7 + (d3  + 1 / 8 * (-(3 * d6 * e3) + -(35 / 8 * d7 * e4) + -(15 / 8 * d5 * e2) + -(3 / 8 * d3)) + -(1 / 128) * (12 * d3 + 5 * d5 * 2 * e2 + 6 * d6 * e3)) * x ^ 6 + (d2  + 1 / 8 * (-(15 / 8 * d5 * e3) + -(3 * d6 * e4) + -(d4 * e2))  + -(1 / 128) * (8 * d2 + 4 * d4 * 2 * e2 + 5 * d5 * e3)) * x ^ 5 + (d1  + -(1 / 128) * (4 * d1 + 3 * d3 * 2 * e2 + 4 * d4 * e3)  + 1 / 8 * (-(15 / 8 * d5 * e4) + -(d4 * e3) + -(3 / 8 * d3 * e2) + 1 / 8 * d1)) * x ^ 4+ (d0 + 1 / 8 * (-(d4 * e4) + -(3 / 8 * d3 * e3)) + -(1 / 128) * (2 * d2 * 2 * e2 + 3 * d3 * e3)) * x ^ 3 + (1 / 8 * (-(3 / 8 * d3 * e4) + 1 / 8 * d1 * e2) + -(1 / 128) * (d1 * 2 * e2 + 2 * d2 * e3)) * x ^ 2 + (1 / 64 * d1 * e3 + -(1 / 128) * d1 * e3) * x + 1 / 64 * d1 * e4 ,
    ring_nf,
  rw h,
  norm_num,
end

lemma system_eleven_implies_polynomial_eq_zero (x:ℝ) (d7:ℝ) (d6:ℝ) (d5:ℝ) (d4:ℝ) (d3:ℝ) (d2:ℝ) (d1:ℝ) (d0:ℝ)
(e2:ℝ) (e3:ℝ) (e4:ℝ) (h: system_eleven e2 e3 e4 d0 d1 d2 d3 d4 d5 d6 d7):
system_eleven e2 e3 e4 d0 d1 d2 d3 d4 d5 d6 d7 → ((fun_b_gen x d7 d6 d5 d4 d3 d2 d1 d0)*x-(-1/8)*((deriv_fun_a_gen x d7 d6 d5 d4 d3 d1)*(fun_z_gen x e2 e3 e4)+(1/2)*(fun_a_gen x d7 d6 d5 d4 d3 d2 d1)*(deriv_fun_z_gen x e2 e3))) * x^2= 0:=
begin
  intro h,
  rw system_eleven_iff_system_eleven_neg at h,
  cases h with h1 h2,
  cases h2 with h2 h3,
  cases h3 with h3 h4,
  cases h4 with h4 h5,
  cases h5 with h5 h6,
  cases h6 with h6 h7,
  cases h7 with h7 h8,
  cases h8 with h8 h9,
  cases h9 with h9 h10,
  cases h10 with h10 h11,
  rw unfolding_polynomial x d7 d6 d5 d4 d3 d2 d1 d0 e2 e3 e4,
  rw eq_1 x d7 d6 d5 d4 d3 d2 d1 d0 e2 e3 e4,
  rw eq_2 x d7 d6 d5 d4 d3 d2 d1 d0 e2 e3 e4,
  rw eq_3 x d7 d6 d5 d4 d3 d2 d1 d0 e2 e3 e4,
  rw eq_4 x d7 d6 d5 d4 d3 d2 d1 d0 e2 e3 e4,
  rw eq_5 x d7 d6 d5 d4 d3 d2 d1 d0 e2 e3 e4,
  rw eq_6 x d7 d6 d5 d4 d3 d2 d1 d0 e2 e3 e4,
  rw eq_7 x d7 d6 d5 d4 d3 d2 d1 d0 e2 e3 e4,
  rw eq_8 x d7 d6 d5 d4 d3 d2 d1 d0 e2 e3 e4,
  rw eq_9 x d7 d6 d5 d4 d3 d2 d1 d0 e2 e3 e4,
  rw eq_10 x d7 d6 d5 d4 d3 d2 d1 d0 e2 e3 e4,
  rw eq_11 x d7 d6 d5 d4 d3 d2 d1 d0 e2 e3 e4,
  rw [h11,h10,h9,h8,h7,h6,h5,h4,h3,h2,h1],
  simp only [zero_mul, add_zero],
  exact x,
end

lemma polynomial_eq_zero_implies_system_eleven (x:ℝ) (d7:ℝ) (d6:ℝ) (d5:ℝ) (d4:ℝ) (d3:ℝ) (d2:ℝ) (d1:ℝ) (d0:ℝ)
(e2:ℝ) (e3:ℝ) (e4:ℝ) (h: system_eleven e2 e3 e4 d0 d1 d2 d3 d4 d5 d6 d7):
 ((fun_b_gen x d7 d6 d5 d4 d3 d2 d1 d0)*x-(-1/8)*((deriv_fun_a_gen x d7 d6 d5 d4 d3 d1)*(fun_z_gen x e2 e3 e4)+(1/2)*(fun_a_gen x d7 d6 d5 d4 d3 d2 d1)*(deriv_fun_z_gen x e2 e3))) * x^2= 0 →system_eleven e2 e3 e4 d0 d1 d2 d3 d4 d5 d6 d7 :=
begin
  sorry, --discussed this with Alain friday, unfortunately we could not make it work
end

/- # Unfortunately, we did not have the time to fully connect the part above and the part below except for the lemma system_eleven_implies_polynomial_eq_zero   -/

lemma hd6 (e_2 e_3 e_4 d_0 d_1 d_2 d_3 d_4 d_5 d_6 d_7 : ℝ) (hnotzero : e_3 ≠ 0) : d_6 + 2 * e_2 = 0 ↔ d_6 = -(2 * e_2) :=
begin
  rw add_eq_zero_iff_eq_neg,
end

lemma hd5 (e_2 e_3 e_4 d_0 d_1 d_2 d_3 d_4 d_5 d_6 d_7 : ℝ) (hnotzero : e_3 ≠ 0) : -(39 * d_5) + 42 * d_7 * e_2 - 52 * e_3 = 0 ∧ d_6 = -(2 * e_2) ∧ d_7 = 0 ↔ d_5 = -52 / 39 * e_3 ∧ d_6 = -(2 * e_2) ∧ d_7 = 0 :=
begin
  simp,
  intros hd6 hd7,
  simp[hd7],
  rw [sub_eq_zero, ← neg_mul, mul_comm, ← eq_div_iff],
  ring_nf,
  norm_num,
end

lemma hd4 (e_2 e_3 e_4 d_0 d_1 d_2 d_3 d_4 d_5 d_6 d_7 : ℝ) (hnotzero : e_3 ≠ 0) : -(96 * d_4) + 60 * d_6 * e_2 + 77 * d_7 * e_3 - 96 * e_4 = 0 ∧ d_5 = (-52) / 39 * e_3 ∧ d_6 = -(2 * e_2) ∧ d_7 = 0 ↔
d_4 = -((5 * e_2^2) / 4) - e_4 ∧ d_5 = (-52) / 39 * e_3 ∧ d_6 = -(2 * e_2) ∧ d_7 = 0 :=
begin
  simp,
  intros hd5 hd6 hd7,
  simp[hd6, hd7],
  ring_nf,
  rw [add_eq_zero_iff_eq_neg, ← neg_mul, mul_comm, ← eq_div_iff],
  ring_nf,
  norm_num,
end

lemma hd3 (e_2 e_3 e_4 d_0 d_1 d_2 d_3 d_4 d_5 d_6 d_7 : ℝ) (hnotzero : e_3 ≠ 0) : -(55 * d_3) + 20 * d_5 * e_2 + 27 * d_6 * e_3 + 35 * d_7 * e_4 = 0 ∧ d_4 = -(5 * e_2 ^ 2 / 4) - e_4 ∧ d_5 = (-52) / 39 * e_3 ∧ d_6 = -(2 * e_2) ∧ d_7 = 0 ↔
d_3 = -((22 * e_2 * e_3) / 15) ∧ d_4 = -(5 * e_2 ^ 2 / 4) - e_4 ∧ d_5 = (-52) / 39 * e_3 ∧ d_6 = -(2 * e_2) ∧ d_7 = 0 :=
begin
  simp,
  intros hd4 hd5 hd6 hd7,
  simp[hd5, hd6, hd7],
  rw [add_assoc, add_eq_zero_iff_eq_neg, ← neg_mul, mul_comm, ← eq_div_iff],
  ring_nf,
  norm_num,
end

lemma hd2 (e_2 e_3 e_4 d_0 d_1 d_2 d_3 d_4 d_5 d_6 d_7 : ℝ) (hnotzero : e_3 ≠ 0) : -(120 * d_2) + 24 * d_4 * e_2 + 35 * d_5 * e_3 + 48 * d_6 * e_4 = 0 ∧ d_3 = -(22 * e_2 * e_3 / 15) ∧ d_4 = -(5 * e_2 ^ 2 / 4) - e_4 ∧ d_5 = (-52) / 39 * e_3 ∧ d_6 = -(2 * e_2) ∧ d_7 = 0 ↔
d_2 = -e_2 ^ 3 / 4 - (7 * e_3 ^ 2) / 18 - e_2 * e_4 ∧ d_3 = -(22 * e_2 * e_3 / 15) ∧ d_4 = -(5 * e_2 ^ 2 / 4) - e_4 ∧ d_5 = (-52) / 39 * e_3 ∧ d_6 = -(2 * e_2) ∧ d_7 = 0 :=
begin
  simp,
  intros hd3 hd4 hd5 hd6 hd7,
  simp[hd4, hd5, hd6],
  rw [add_assoc, add_assoc, add_eq_zero_iff_eq_neg, ← neg_mul, mul_comm, ← eq_div_iff],
  ring_nf,
  norm_num,
end

lemma hd1 (e_2 e_3 e_4 d_0 d_1 d_2 d_3 d_4 d_5 d_6 d_7 : ℝ) (hnotzero : e_3 ≠ 0) : -(63 * d_1) + 6 * d_3 * e_2 + 10 * d_4 * e_3 + 15 * d_5 * e_4 = 0 ∧ d_2 = -e_2 ^ 3 / 4 - 7 * e_3 ^ 2 / 18 - e_2 * e_4 ∧ d_3 = -(22 * e_2 * e_3 / 15) ∧ d_4 = -(5 * e_2 ^ 2 / 4) - e_4 ∧ d_5 = (-52) / 39 * e_3 ∧ d_6 = -(2 * e_2) ∧ d_7 = 0 ↔
d_1 = (-(1 / 210)) * e_3 * (71 * e_2 ^ 2 + 100 * e_4) ∧ d_2 = -e_2 ^ 3 / 4 - 7 * e_3 ^ 2 / 18 - e_2 * e_4 ∧ d_3 = -(22 * e_2 * e_3 / 15) ∧ d_4 = -(5 * e_2 ^ 2 / 4) - e_4 ∧ d_5 = (-52) / 39 * e_3 ∧ d_6 = -(2 * e_2) ∧ d_7 = 0 :=
begin
  simp,
  intros hd2 hd3 hd4 hd5 hd6 hd7,
  simp[hd3, hd4, hd5],
  rw [add_assoc, add_assoc, add_eq_zero_iff_eq_neg, ← neg_mul, mul_comm, ← eq_div_iff],
  ring_nf,
  norm_num,
end

lemma hd0 (e_2 e_3 e_4 d_0 d_1 d_2 d_3 d_4 d_5 d_6 d_7 : ℝ) (hnotzero : e_3 ≠ 0) : -(128 * d_0) + 4 * d_2 * e_2 + 9 * d_3 * e_3 + 16 * d_4 * e_4 = 0 ∧ d_1 = -(1 / 210) * e_3 * (71 * e_2 ^ 2 + 100 * e_4) ∧ d_2 = -e_2 ^ 3 / 4 - 7 * e_3 ^ 2 / 18 - e_2 * e_4 ∧ d_3 = -(22 * e_2 * e_3 / 15) ∧ d_4 = -(5 * e_2 ^ 2 / 4) - e_4 ∧ d_5 = (-52) / 39 * e_3 ∧ d_6 = -(2 * e_2) ∧ d_7 = 0 ↔
d_0 = -(e_2 ^ 4 / 128) - (83 * e_2 * e_3 ^ 2) / 720 - (3 * e_2 ^ 2 * e_4) / 16 - e_4 ^ 2 / 8 ∧ d_1 = -(1 / 210) * e_3 * (71 * e_2 ^ 2 + 100 * e_4) ∧ d_2 = -e_2 ^ 3 / 4 - 7 * e_3 ^ 2 / 18 - e_2 * e_4 ∧ d_3 = -(22 * e_2 * e_3 / 15) ∧ d_4 = -(5 * e_2 ^ 2 / 4) - e_4 ∧ d_5 = (-52) / 39 * e_3 ∧ d_6 = -(2 * e_2) ∧ d_7 = 0:=
begin
  simp,
  intros hd1 hd2 hd3 hd4 hd5 hd6 hd7,
  simp[hd2, hd3, hd4],
  rw [add_assoc, add_assoc, add_eq_zero_iff_eq_neg, ← neg_mul, mul_comm, ← eq_div_iff],
  ring_nf,
  norm_num,
end

lemma hsys3 (e_2 e_3 e_4 d_0 d_1 d_2 d_3 d_4 d_5 d_6 d_7 : ℝ) (hnotzero : e_3 ≠ 0) : d_2 * e_3 + 3 * d_3 * e_4 = 0 ∧ d_0 = -(e_2 ^ 4 / 128) - 83 * e_2 * e_3 ^ 2 / 720 - 3 * e_2 ^ 2 * e_4 / 16 - e_4 ^ 2 / 8 ∧ d_1 = -(1 / 210) * e_3 * (71 * e_2 ^ 2 + 100 * e_4) ∧ d_2 = -e_2 ^ 3 / 4 - 7 * e_3 ^ 2 / 18 - e_2 * e_4 ∧ d_3 = -(22 * e_2 * e_3 / 15) ∧ d_4 = -(5 * e_2 ^ 2 / 4) - e_4 ∧ d_5 = (-52) / 39 * e_3 ∧ d_6 = -(2 * e_2) ∧ d_7 = 0 ↔
(-(1 / 180)) * e_3 * (45 * e_2 ^ 3 + 70 * e_3 ^ 2 + 972 * e_2 * e_4) = 0 ∧ d_0 = -(e_2 ^ 4 / 128) - 83 * e_2 * e_3 ^ 2 / 720 - 3 * e_2 ^ 2 * e_4 / 16 - e_4 ^ 2 / 8 ∧ d_1 = -(1 / 210) * e_3 * (71 * e_2 ^ 2 + 100 * e_4) ∧ d_2 = -e_2 ^ 3 / 4 - 7 * e_3 ^ 2 / 18 - e_2 * e_4 ∧ d_3 = -(22 * e_2 * e_3 / 15) ∧ d_4 = -(5 * e_2 ^ 2 / 4) - e_4 ∧ d_5 = (-52) / 39 * e_3 ∧ d_6 = -(2 * e_2) ∧ d_7 = 0 :=
begin
  simp only [one_div, neg_mul, neg_eq_zero, inv_eq_zero, bit0_eq_zero, and.congr_left_iff, and_imp],
  intros hd0 hd1 hd2 hd3 hd4 hd5 hd6 hd7,
  rw [hd2, hd3],
  ring_nf,
  rw sub_eq_zero,
  rw add_eq_zero_iff_eq_neg,
  rw ← neg_neg ((1 / 4 * e_3 * e_2 ^ 2 + 27 / 5 * e_4 * e_3) * e_2),
  rw neg_inj,
  ring_nf,
end

lemma hsys2 (e_2 e_3 e_4 d_0 d_1 d_2 d_3 d_4 d_5 d_6 d_7 : ℝ) (hnotzero : e_3 ≠ 0) : d_1 = 0 ∧ -(1 / 180) * e_3 * (45 * e_2 ^ 3 + 70 * e_3 ^ 2 + 972 * e_2 * e_4) = 0 ∧ d_0 = -(e_2 ^ 4 / 128) - 83 * e_2 * e_3 ^ 2 / 720 - 3 * e_2 ^ 2 * e_4 / 16 - e_4 ^ 2 / 8 ∧ d_1 = -(1 / 210) * e_3 * (71 * e_2 ^ 2 + 100 * e_4) ∧ d_2 = -e_2 ^ 3 / 4 - 7 * e_3 ^ 2 / 18 - e_2 * e_4 ∧ d_3 = -(22 * e_2 * e_3 / 15) ∧ d_4 = -(5 * e_2 ^ 2 / 4) - e_4 ∧ d_5 = (-52) / 39 * e_3 ∧ d_6 = -(2 * e_2) ∧ d_7 = 0 ↔
-(1 / 210) * e_3 * (71 * e_2 ^ 2 + 100 * e_4) = 0 ∧ -(1 / 180) * e_3 * (45 * e_2 ^ 3 + 70 * e_3 ^ 2 + 972 * e_2 * e_4) = 0 ∧ d_0 = -(e_2 ^ 4 / 128) - 83 * e_2 * e_3 ^ 2 / 720 - 3 * e_2 ^ 2 * e_4 / 16 - e_4 ^ 2 / 8 ∧ d_1 = -(1 / 210) * e_3 * (71 * e_2 ^ 2 + 100 * e_4) ∧ d_2 = -e_2 ^ 3 / 4 - 7 * e_3 ^ 2 / 18 - e_2 * e_4 ∧ d_3 = -(22 * e_2 * e_3 / 15) ∧ d_4 = -(5 * e_2 ^ 2 / 4) - e_4 ∧ d_5 = (-52) / 39 * e_3 ∧ d_6 = -(2 * e_2) ∧ d_7 = 0 :=
begin
  simp only [one_div, neg_mul, neg_eq_zero, inv_eq_zero, bit0_eq_zero, and.congr_left_iff, and_imp],
  intros hsys3 hd0 hd1 hd2 hd3 hd4 hd5 hd6 hd7,
  rw[hd1],
  simp,
end

lemma hsys1 (e_2 e_3 e_4 d_0 d_1 d_2 d_3 d_4 d_5 d_6 d_7 : ℝ) (hnotzero3 : e_3 ≠ 0) (hnotzero4 : e_4 ≠ 0) : (d_1 = 0 ∨ e_4 = 0) ∧ -(1 / 210) * e_3 * (71 * e_2 ^ 2 + 100 * e_4) = 0 ∧ -(1 / 180) * e_3 * (45 * e_2 ^ 3 + 70 * e_3 ^ 2 + 972 * e_2 * e_4) = 0 ∧ d_0 = -(e_2 ^ 4 / 128) - 83 * e_2 * e_3 ^ 2 / 720 - 3 * e_2 ^ 2 * e_4 / 16 - e_4 ^ 2 / 8 ∧ d_1 = -(1 / 210) * e_3 * (71 * e_2 ^ 2 + 100 * e_4) ∧ d_2 = -e_2 ^ 3 / 4 - 7 * e_3 ^ 2 / 18 - e_2 * e_4 ∧ d_3 = -(22 * e_2 * e_3 / 15) ∧ d_4 = -(5 * e_2 ^ 2 / 4) - e_4 ∧ d_5 = (-52) / 39 * e_3 ∧ d_6 = -(2 * e_2) ∧ d_7 = 0 ↔
-(1 / 210) * e_3 * (71 * e_2 ^ 2 + 100 * e_4) = 0 ∧ -(1 / 210) * e_3 * (71 * e_2 ^ 2 + 100 * e_4) = 0 ∧ -(1 / 180) * e_3 * (45 * e_2 ^ 3 + 70 * e_3 ^ 2 + 972 * e_2 * e_4) = 0 ∧ d_0 = -(e_2 ^ 4 / 128) - 83 * e_2 * e_3 ^ 2 / 720 - 3 * e_2 ^ 2 * e_4 / 16 - e_4 ^ 2 / 8 ∧ d_1 = -(1 / 210) * e_3 * (71 * e_2 ^ 2 + 100 * e_4) ∧ d_2 = -e_2 ^ 3 / 4 - 7 * e_3 ^ 2 / 18 - e_2 * e_4 ∧ d_3 = -(22 * e_2 * e_3 / 15) ∧ d_4 = -(5 * e_2 ^ 2 / 4) - e_4 ∧ d_5 = (-52) / 39 * e_3 ∧ d_6 = -(2 * e_2) ∧ d_7 = 0 :=
begin
  simp only [one_div, neg_mul, neg_eq_zero, inv_eq_zero, bit0_eq_zero, and.congr_left_iff, and_imp],
  intros hsys2 hsys3 hd0 hd1 hd2 hd3 hd4 hd5 hd6 hd7,
  rw[hd1],
  simp*,
end

lemma system_a_notzero (e_2 e_3 e_4 d_0 d_1 d_2 d_3 d_4 d_5 d_6 d_7 : ℝ) (hnotzero3 : e_3 ≠ 0) (h : system_a_2 e_2 e_3 e_4 d_0 d_1 d_2 d_3 d_4 d_5 d_6 d_7) : e_4 ≠ 0 :=
begin
  unfold system_a_2 at h,
  cases h with h1 h,
  cases h with h2 h,
  by_contra,
  simp[h] at h1 h2,
  rw or_iff_right at h1,
  simp[h1] at h2,
  rw or_iff_right at h2,
  exact hnotzero3 h2,
  repeat {norm_num},
end

lemma system_a_iff_system_eleven (e_2 e_3 e_4 d_0 d_1 d_2 d_3 d_4 d_5 d_6 d_7 : ℝ) (hnotzero3 : e_3 ≠ 0) (hnotzero4 : e_4 ≠ 0) : system_eleven e_2 e_3 e_4 d_0 d_1 d_2 d_3 d_4 d_5 d_6 d_7 ↔ system_a_2 e_2 e_3 e_4 d_0 d_1 d_2 d_3 d_4 d_5 d_6 d_7 :=
begin
  unfold system_a_2,
  unfold system_eleven,
  simp[hnotzero3],
  norm_num,
  rw hd6 e_2 e_3 e_4 d_0 d_1 d_2 d_3 d_4 d_5 d_6 d_7 hnotzero3,
  rw hd5 e_2 e_3 e_4 d_0 d_1 d_2 d_3 d_4 d_5 d_6 d_7 hnotzero3,
  rw hd4 e_2 e_3 e_4 d_0 d_1 d_2 d_3 d_4 d_5 d_6 d_7 hnotzero3,
  rw hd3 e_2 e_3 e_4 d_0 d_1 d_2 d_3 d_4 d_5 d_6 d_7 hnotzero3,
  rw hd2 e_2 e_3 e_4 d_0 d_1 d_2 d_3 d_4 d_5 d_6 d_7 hnotzero3,
  rw hd1 e_2 e_3 e_4 d_0 d_1 d_2 d_3 d_4 d_5 d_6 d_7 hnotzero3,
  rw hd0 e_2 e_3 e_4 d_0 d_1 d_2 d_3 d_4 d_5 d_6 d_7 hnotzero3,
  rw hsys3 e_2 e_3 e_4 d_0 d_1 d_2 d_3 d_4 d_5 d_6 d_7 hnotzero3,
  rw hsys2 e_2 e_3 e_4 d_0 d_1 d_2 d_3 d_4 d_5 d_6 d_7 hnotzero3,
  rw hsys1 e_2 e_3 e_4 d_0 d_1 d_2 d_3 d_4 d_5 d_6 d_7 hnotzero3 hnotzero4,
  simp*,
  norm_num,
  ring_nf,
end

end real


/-
Copyright (c) 2020 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel
-/
import algebra.category.Module.kernels
import algebra.category.Module.limits
import category_theory.abelian.exact

/-!
# The category of left R-modules is abelian.

Additionally, two linear maps are exact in the categorical sense iff `range f = ker g`.
-/

open category_theory
open category_theory.limits

noncomputable theory

universes v u

namespace Module
variables {R : Type u} [ring R] {M N : Module.{v} R} (f : M ⟶ N)

/-- In the category of modules, every monomorphism is normal. -/
def normal_mono (hf : mono f) : normal_mono f :=
{ Z := of R f.range.quotient,
  g := f.range.mkq,
  w := linear_map.range_mkq_comp _,
  is_limit :=
    is_kernel.iso_kernel _ _ (kernel_is_limit _)
      /- The following [invalid Lean code](https://github.com/leanprover-community/lean/issues/341)
        might help you understand what's going on here:
        ```
        calc
        M   ≃ₗ[R] f.ker.quotient  : (submodule.quot_equiv_of_eq_bot _ (ker_eq_bot_of_mono _)).symm
        ... ≃ₗ[R] f.range         : linear_map.quot_ker_equiv_range f
        ... ≃ₗ[R] r.range.mkq.ker : linear_equiv.of_eq _ _ (submodule.ker_mkq _).symm
        ```
      -/
      (linear_equiv.to_Module_iso'
        (linear_equiv.trans (submodule.quot_equiv_of_eq_bot _ (ker_eq_bot_of_mono _)).symm
          (linear_equiv.trans (linear_map.quot_ker_equiv_range f)
            (linear_equiv.of_eq _ _ (submodule.ker_mkq _).symm)))) $
      by { ext, refl } }

/-- In the category of modules, every epimorphism is normal. -/
def normal_epi (hf : epi f) : normal_epi f :=
{ W := of R f.ker,
  g := f.ker.subtype,
  w := linear_map.comp_ker_subtype _,
  is_colimit :=
    is_cokernel.cokernel_iso _ _ (cokernel_is_colimit _)
      (linear_equiv.to_Module_iso'
      /- The following invalid Lean code might help you understand what's going on here:
        ```
        calc f.ker.subtype.range.quotient
            ≃ₗ[R] f.ker.quotient : submodule.quot_equiv_of_eq _ _ (submodule.range_subtype _)
        ... ≃ₗ[R] f.range        : linear_map.quot_ker_equiv_range f
        ... ≃ₗ[R] N              : linear_equiv.of_top _ (range_eq_top_of_epi _)
        ```
      -/
        (linear_equiv.trans
          (linear_equiv.trans (submodule.quot_equiv_of_eq _ _ (submodule.range_subtype _))
            (linear_map.quot_ker_equiv_range f)) (linear_equiv.of_top _ (range_eq_top_of_epi _)))) $
      by { ext, refl } }

/-- The category of R-modules is abelian. -/
instance : abelian (Module R) :=
{ has_finite_products := ⟨by apply_instance⟩,
  has_kernels := by apply_instance,
  has_cokernels := has_cokernels_Module,
  normal_mono := λ X Y, normal_mono,
  normal_epi := λ X Y, normal_epi }

variables {O : Module.{v} R} (g : N ⟶ O)

open linear_map
local attribute [instance] preadditive.has_equalizers_of_has_kernels

theorem exact_iff : exact f g ↔ f.range = g.ker :=
begin
  rw abelian.exact_iff' f g (kernel_is_limit _) (cokernel_is_colimit _),
  exact ⟨λ h, le_antisymm (range_le_ker_iff.2 h.1) (ker_le_range_iff.2 h.2),
    λ h, ⟨range_le_ker_iff.1 $ le_of_eq h, ker_le_range_iff.1 $ le_of_eq h.symm⟩⟩
end

end Module


def g (xs ys : List Nat) : Nat :=
  match xs, ys with
  | [a, b], _ => Nat.succ (a+b)
  | _, [b, c] => Nat.succ b
  | _, _   => 1

example (a b : Bool) (x y z : Nat) (xs : List Nat) (h1 : (if a then x else y) = 0) (h2 : xs.head! = 0) : g [x] xs = 1 := by
  simp [g]
  repeat any_goals (split at *)
  any_goals (first | decide | contradiction | injections)
  next b c _ _ _ =>
    show Nat.succ b = 1
    subst xs; simp [List.head!] at h2; simp [h2]
  next b c _ _ _ =>
    show Nat.succ b = 1
    subst xs; simp [List.head!] at h2; simp [h2]

example (a : Bool) (h1 : (if a then x else y) = 1) : x + y > 0 := by
  split at h1
  . subst h1; rw [Nat.succ_add]; apply Nat.zero_lt_succ
  . subst h1; apply Nat.zero_lt_succ

def f (x : Nat) : Nat :=
  match x with
  | 100 => 0
  | 200 => 0
  | _   => 1

example (h1 : f x = 0) (h2 : x > 300) : False := by
  simp [f] at h1
  split at h1
  . contradiction
  . contradiction
  . contradiction

example (h1 : f x = 0) (h2 : x > 300) : False := by
  simp [f] at h1
  split at h1 <;> contradiction


example (P Q : Prop) : P → (Q → P) :=
begin
    intro p,
    intro q,
    exact p,
end


import for_mathlib.coproduct group_theory.semidirect_product

noncomputable theory

universe u

variables {ι : Type} [decidable_eq ι] (r : free_group ι) (T : set ι) [decidable_pred T]

open free_group

def phi : closure_var T →* mul_aut (free_group (free_group ι)) :=
{ to_fun := λ g : closure_var T, free_group.equiv (mul_left (g : free_group ι)),
  map_one' := by simp [equiv.perm.one_def]; refl,
  map_mul' := λ x y, by simp [equiv.perm.mul_def]; refl }

def phi' : free_group ι →* mul_aut (free_group (free_group ι)) :=
{ to_fun := λ w, free_group.equiv (mul_left w),
  map_one' := by simp [equiv.perm.one_def, mul_aut.one_def],
  map_mul' := by simp [equiv.perm.mul_def, mul_aut.mul_def] }

lemma phi'_of' (n : C∞) (w w' : free_group ι) :
  phi' w (of' w' n) = of' (w * w') n := by simp [phi']

include r

def unnormalize : free_group (free_group ι) ⋊[phi T] closure_var T →* free_group ι :=
semidirect_product.lift
  (free_group.lift' (λ g : free_group ι,
    (mul_aut.conj g : free_group ι ≃* free_group ι).to_monoid_hom.comp
      (gpowers_hom (free_group ι) r)))
  (subgroup.subtype (closure_var T))
  (λ g, hom_ext (λ i, by simp [_root_.phi, of_eq_of']))

open semidirect_product

def unnormalize' : free_group (free_group ι) ⋊[phi'] free_group ι →* free_group ι :=
semidirect_product.lift
  (free_group.lift' (λ g : free_group ι,
    (mul_aut.conj g : free_group ι ≃* free_group ι).to_monoid_hom.comp
      (gpowers_hom (free_group ι) r)))
  (monoid_hom.id _)
  (λ g, hom_ext (λ i, by simp [_root_.phi', of_eq_of']))

@[simp] lemma unnormalize'_inr (w : free_group ι) : unnormalize' r (inr w) = w :=
semidirect_product.lift_inr _ _ _ _

lemma unnormalize'_inl (w : free_group (free_group ι)) :
  unnormalize' r (inl w) = free_group.lift' (λ g : free_group ι,
    (mul_aut.conj g : free_group ι ≃* free_group ι).to_monoid_hom.comp
      (gpowers_hom (free_group ι) r)) w :=
semidirect_product.lift_inl _ _ _ _

omit r

def remove_subscript (t : ι) : free_group (ι × C∞) →* free_group ι :=
free_group.lift' (λ g, (mul_aut.conj (of' t g.2)).to_monoid_hom.comp (of' g.1))

def mul_subscript (n : C∞) : free_group (ι × C∞) ≃* free_group (ι × C∞) :=
free_group.equiv (equiv.prod_congr (equiv.refl _) (mul_left n))

@[simp] lemma remove_subscript_comp_mul_subscript (t : ι) (n : C∞) :
  (remove_subscript t).comp (mul_subscript n).to_monoid_hom =
  (mul_aut.conj (of' t n)).to_monoid_hom.comp (remove_subscript t) :=
free_group.hom_ext (by simp [remove_subscript, mul_subscript, of_eq_of'])

@[simp] lemma remove_subscript_mul_subscript (t : ι) (n : C∞) (x) : remove_subscript t
  (mul_subscript n x) =  of' t n * remove_subscript t x * of' t n⁻¹ :=
by simpa [-remove_subscript_comp_mul_subscript] using monoid_hom.ext_iff.1
  (remove_subscript_comp_mul_subscript t n) x

@[simp] lemma remove_subscript_of' (t : ι) (l : ι × C∞) (n : C∞) : remove_subscript t (of' l n) =
  (mul_aut.conj (of' t l.2)).to_monoid_hom.comp (of' l.1) n :=
free_group.lift'_of' _ _ _

lemma remove_subscript_SD (t : ι) :
  free_group (free_group (ι × C∞)) ⋊[phi'] free_group (ι × C∞) →*
  free_group (free_group ι) ⋊[phi'] free_group ι :=
semidirect_product.lift (inl.comp
  (free_group.lift' (λ g, of' (remove_subscript t g))))
  (inr.comp (remove_subscript t))
  begin
    intro g,
    apply free_group.hom_ext,
    assume i,
    simp only [of_eq_of', lift'_of', monoid_hom.comp_apply, mul_equiv.to_monoid_hom_apply, phi'_of'],
    apply semidirect_product.ext;
    simp [phi']
  end

include r

/-- Not the correct definition -/
structure solver (T : set ι): Type :=
(to_fun : free_group ι → option (free_group (free_group ι) ⋊[phi'] free_group ι))
(inv : ∀ (x : free_group ι), x ∈ (set.univ : set (free_group ι)) →
  ∃ (y : free_group (free_group ι) ⋊[phi'] free_group ι), y ∈ to_fun x → unnormalize' r y = x)

instance : has_coe_to_fun (solver r T) :=
{ F := λ _, free_group ι → option (free_group (free_group ι) ⋊[phi'] free_group ι),
  coe := solver.to_fun }

lemma unnormalize_eq_of_mem {n : solver r T}
  {x : free_group ι} {y : free_group (free_group ι) ⋊[phi'] free_group ι}
  (h : y ∈ n x) : unnormalize' r y = x := sorry

lemma unnormalize_inl_eq_of_mem {n : solver r T}
  {x : free_group ι} {y : free_group (free_group ι) ⋊[phi'] free_group ι}
  (h : y ∈ n x) : unnormalize' r (inl y.left) = x * y.right⁻¹ :=
by rw [eq_mul_inv_iff_mul_eq, ← unnormalize'_inr r y.right, ← monoid_hom.map_mul,
    inl_left_mul_inr_right, unnormalize_eq_of_mem r T h]

variable {ι}

omit r

noncomputable def normalize_cons
  (t : ι) (r' : free_group (ι × C∞))
  {A B : set (ι × C∞)}
  [decidable_pred A] [decidable_pred B]
  (hA : solver r' A) (hB : solver r' B) :
  Π (old1 : free_group (ι × C∞))
  (old2 : free_group (free_group (ι × C∞)) ⋊[phi'] free_group (ι × C∞)),
  free_group (free_group (ι × C∞)) ⋊[phi'] free_group (ι × C∞)
| old1 ⟨w, ⟨[], _⟩⟩     := ⟨phi' old1 w, old1⟩
| old1 ⟨w, ⟨i :: l, _⟩⟩ :=
  if i.1.1 = t
  then if i.2 ≤ 1
    then option.elim (hA old1)
      (normalize_cons ⟨old1.1 ++ [i], sorry⟩ ⟨(phi' (of' i.1 i.2))⁻¹ w, ⟨l, sorry⟩⟩)
      (λ a, inr (of (t, 1))⁻¹ *
        normalize_cons (mul_subscript ii (right_hom a))
          ⟨phi' (of (t, 1)) (phi' a.right⁻¹ a.left * w), of' i.1 (ii * i.2) * ⟨l, sorry⟩⟩)
    else option.elim (hB old1)
      (normalize_cons ⟨old1.1 ++ [i], sorry⟩ ⟨(phi' (of' i.1 i.2))⁻¹ w, ⟨l, sorry⟩⟩)
      (λ a, inr (of (t, 1)) *
        normalize_cons (mul_subscript (ii⁻¹) (right_hom a))
          ⟨phi' (of (t, 1))⁻¹  (phi' a.right⁻¹ a.left * w), of' i.1 (ii⁻¹ * i.2) *⟨l, sorry⟩⟩)
  else normalize_cons ⟨old1.1 ++ [i], sorry⟩ ⟨(phi' (of' i.1 i.2))⁻¹ w, ⟨l, sorry⟩⟩
using_well_founded { rel_tac := λ _ _, `[exact ⟨λ _ _, true, sorry⟩], dec_tac := `[trivial] }

@[simp] lemma remove_subscript_unnormalize_normalize_cons
  (t : ι) (r' : free_group (ι × C∞))
  {A B : set (ι × C∞)}
  [decidable_pred A] [decidable_pred B]
  (hA : solver r' A)
  (hB : solver r' B) :
  Π (old1 : free_group (ι × C∞))
  (old2 : free_group (free_group (ι × C∞)) ⋊[phi'] free_group (ι × C∞)),
  remove_subscript t (unnormalize' r' (normalize_cons t r' hA hB old1 old2)) =
    remove_subscript t (old1 * unnormalize' r' old2)
| old1 ⟨w, ⟨[], _⟩⟩     := by rw normalize_cons; simp [inl_aut]
| old1 ⟨w, ⟨i :: l, _⟩⟩ := begin
  rw normalize_cons,
  split_ifs,
  { cases h1 : hA old1,
    { simp [remove_subscript_unnormalize_normalize_cons, inl_aut_inv, mul_assoc] },
    { have : i.1.2 = ii, from sorry,
      simp [remove_subscript_unnormalize_normalize_cons, mul_assoc, inl_aut_inv,
        unnormalize_inl_eq_of_mem _ _ h1, of_eq_of', inl_aut, this, h,
        unnormalize_eq_of_mem _ _ h1] } },
  { cases h2 : hB old1,
    { simp [remove_subscript_unnormalize_normalize_cons, inl_aut_inv, mul_assoc] },
    { have : i.1.2 = ii, from sorry,
      simp [remove_subscript_unnormalize_normalize_cons, mul_assoc, inl_aut_inv,
        unnormalize_inl_eq_of_mem _ _ h2, of_eq_of', inl_aut, this, h,
        unnormalize_eq_of_mem _ _ h2] } },
  { simp [remove_subscript_unnormalize_normalize_cons, inl_aut_inv, mul_assoc] }
end
using_well_founded { rel_tac := λ _ _, `[exact ⟨λ _ _, true, sorry⟩], dec_tac := `[trivial] }

noncomputable def normalize_with_subscript_aux
  (t : ι) (r' : free_group (ι × C∞))
  {A B : set (ι × C∞)}
  [decidable_pred A] [decidable_pred B]
  (hA : solver r' A) (hB : solver r' B) :
  Π (w : list (Σ i : ι, C∞)) (hw : reduced w),
  free_group (free_group (ι × C∞)) ⋊[phi'] free_group (ι × C∞)
| []       _ := 1
| (i :: l) _ := normalize_cons t r' hA hB (of' (i.1, 1) i.2)
  (normalize_with_subscript_aux l sorry)

noncomputable def normalize_with_subscript
  (t : ι) (r' : free_group (ι × C∞))
  {A B : set (ι × C∞)}
  [decidable_pred A] [decidable_pred B]
  (hA : solver r' A) (hB : solver r' B)
  (w : free_group ι) :
  free_group (free_group (ι × C∞)) ⋊[phi'] free_group (ι × C∞) :=
normalize_with_subscript_aux t r' hA hB w.1 w.2

lemma remove_subscript_unnormalize_normalize_with_subscript_aux
  (t : ι) (r' : free_group (ι × C∞))
  {A B : set (ι × C∞)}
  [decidable_pred A] [decidable_pred B]
  (hA : solver r' A) (hB : solver r' B) :
  Π (w : list (Σ i : ι, C∞)) (hw : reduced w),
  remove_subscript t (unnormalize' r' (normalize_with_subscript_aux t r' hA hB w hw)) = ⟨w, hw⟩
| []       _ := by simp [normalize_with_subscript_aux]
| (i :: l) _ := begin
  rw [normalize_with_subscript_aux, remove_subscript_unnormalize_normalize_cons,
    monoid_hom.map_mul, remove_subscript_unnormalize_normalize_with_subscript_aux],
  simp
end

@[simp] lemma remove_subscript_unnormalize_normalize_with_subscript
  (t : ι) (r' : free_group (ι × C∞)) {A B : set (ι × C∞)}
  [decidable_pred A] [decidable_pred B]
  (hA : solver r' A) (hB : solver r' B) (w : free_group ι) :
  remove_subscript t (unnormalize' r' (normalize_with_subscript t r' hA hB w)) = w :=
by cases w; apply remove_subscript_unnormalize_normalize_with_subscript_aux

def Icc_prod (x : ι) (a b : C∞) : set (ι × C∞) :=
{ p | p.1 = x → a ≤ p.2 ∧ p.2 ≤ b }

instance (x : ι) (a b : C∞) : decidable_pred (Icc_prod x a b) :=
by dunfold Icc_prod; apply_instance

/- need to cyclically reduce r' -/
def normalize (t x : ι) (r' : free_group (ι × C∞))
  (hx : x ∉ T) (ht : exp_sum t r = 1) (a b : C∞)
  (ha : a ∈ finset.min ((vars r').image prod.snd))
  (hb : b ∈ finset.max ((vars r').image prod.snd))
  (hr' : r' = ((free_group.to_SD t) r).left)
  (hr'₁ : solver r' (Icc_prod x a (b * ii⁻¹)))
  (hr'₂ : solver r' (Icc_prod x (a * ii) b)) (w : free_group ι) :
  option (free_group (free_group ι) ⋊[phi'] free_group ι) :=
let w' := remove_subscript_SD t (normalize_with_subscript t r' hr'₁ hr'₂ w) in
if w'.right ∈ closure_var T then some w' else none


import for_mathlib.derived.les2
import for_mathlib.unop

noncomputable theory

universes v u

open category_theory category_theory.limits

variables {A : Type u} [category.{v} A] [abelian A]

local notation `𝒦` := homotopy_category A (complex_shape.up ℤ)

namespace bounded_homotopy_category
variables {X Y Z : cochain_complex A ℤ} (f : X ⟶ Y) (g : Y ⟶ Z)

section
open homotopy_category

-- move me
@[reassoc]
lemma Ext_map_Ext_iso [enough_projectives A]
  (i : ℤ) (P₁ P₂ X₁ X₂ Y : bounded_homotopy_category A)
  [is_K_projective P₁.val] [is_K_projective P₂.val]
  (f₁ : P₁ ⟶ X₁) [is_quasi_iso f₁] (f₂ : P₂ ⟶ X₂) [is_quasi_iso f₂]
  (φ : X₁ ⟶ X₂) (φ' : P₁ ⟶ P₂) (h : φ' ≫ f₂ = f₁ ≫ φ) :
  ((Ext i).flip.obj Y).map φ.op ≫ (Ext_iso i P₁ X₁ Y f₁).hom =
    (Ext_iso i P₂ X₂ Y f₂).hom ≫ (preadditive_yoneda.obj (Y⟦i⟧)).map φ'.op :=
begin
  dsimp only [Ext_iso, functor.map_iso_hom, iso.op_hom, Ext, Ext0,
    functor.flip_obj_map, functor.comp_map, whiskering_left_obj_map, whisker_left_app,
    functor.flip_map_app],
  rw [← category_theory.functor.map_comp, ← op_comp,
      ← category_theory.functor.map_comp, ← op_comp],
  congr' 2,
  dsimp only [replacement_iso_hom, opposite.unop_op],
  refine lift_ext X₂.π _ _ _,
  simp only [category.assoc, lift_lifts, lift_lifts_assoc, quiver.hom.unop_op, h],
end

-- move me
@[reassoc]
lemma Ext_map_Ext_iso' [enough_projectives A]
  (i : ℤ) (X₁ X₂ Y : bounded_homotopy_category A) (φ : X₁ ⟶ X₂) :
  ((Ext i).flip.obj Y).map φ.op ≫ (Ext_iso i _ X₁ Y X₁.π).hom =
    (Ext_iso i _ X₂ Y X₂.π).hom ≫ (preadditive_yoneda.obj (Y⟦i⟧)).map (lift (X₁.π ≫ φ) X₂.π).op :=
Ext_map_Ext_iso _ _ _ _ _ _ _ _ _ _ $ by rw [lift_lifts]

lemma Ext_iso_naturality_snd_component
  [enough_projectives A]
  (i : ℤ) (P X Y₁ Y₂ : bounded_homotopy_category A)
  [is_K_projective P.val]
  (f : P ⟶ X) [is_quasi_iso f] (g : Y₁ ⟶ Y₂) :
  ((Ext i).obj _).map g ≫ (Ext_iso i P X _ f).hom =
  (Ext_iso i P X _ f).hom ≫ (preadditive_yoneda.flip.obj (opposite.op P)).map (g⟦i⟧') :=
begin
  dsimp only [Ext_iso, Ext, Ext0], ext t,
  dsimp, simp only [comp_apply], dsimp, simp,
end

end

def shift_iso [enough_projectives A]
  (n : ℤ) (X : cochain_complex A ℤ) (Y : bounded_homotopy_category A)
  [((homotopy_category.quotient A (complex_shape.up ℤ)).obj X).is_bounded_above] :
  (((Ext (n+1)).flip.obj Y)).obj (opposite.op $ (of' X)⟦(1:ℤ)⟧) ≅
  (((Ext n).flip.obj Y)).obj (opposite.op $ (of' X)) :=
begin
  let e := Ext_iso n (of' X).replace (of' X) Y (of' X).π,
  let e' := Ext_iso (n+1) ((of' X).replace⟦1⟧) ((of' X)⟦1⟧) Y ((of' X).π⟦(1:ℤ)⟧'),
  refine (e' ≪≫ _ ≪≫ e.symm),
  clear e e',
  refine add_equiv.to_AddCommGroup_iso _,
  refine shift_iso_aux 1 n _ _,
end

open category_theory.preadditive

lemma shift_iso_conj
  (n : ℤ)
  [enough_projectives A]
  (W : bounded_homotopy_category A)
  [homotopy_category.is_bounded_above ((homotopy_category.quotient _ _).obj X)]
  [homotopy_category.is_bounded_above ((homotopy_category.quotient _ _).obj Y)] :
  (shift_iso _ _ _).inv ≫ (((Ext (n+1)).flip.obj W).right_op.map ((of_hom f)⟦(1 : ℤ)⟧')).unop
    ≫ (shift_iso _ _ _).hom =
  ((Ext n).flip.obj W).map (of_hom f).op :=
begin
  dsimp only [shift_iso, iso.trans_hom, iso.trans_inv, iso.symm_inv, iso.symm_hom,
    functor.right_op_map, quiver.hom.unop_op],
  simp only [category.assoc],
  rw [Ext_map_Ext_iso_assoc (n+1)
    ((shift_functor (bounded_homotopy_category A) (1:ℤ)).obj (of' X).replace)
    ((shift_functor (bounded_homotopy_category A) (1:ℤ)).obj (of' Y).replace)
    _ _ _
    ((shift_functor (bounded_homotopy_category A) 1).map (of' X).π)
    ((shift_functor (bounded_homotopy_category A) 1).map (of' Y).π)
    _ ((lift ((of' X).π ≫ of_hom f) (of' Y).π)⟦1⟧'),
    iso.inv_hom_id_assoc],
  swap,
  { simp only [comp_neg, neg_comp, neg_inj, ← category_theory.functor.map_comp, lift_lifts], },
  simp only [← category.assoc, iso.comp_inv_eq],
  rw [Ext_map_Ext_iso', category.assoc, category.assoc], congr' 1,
  rw [← category.assoc, ← iso.eq_comp_inv],
  apply AddCommGroup.ext, intros φ,
  dsimp only [shift_iso_aux, add_equiv.to_AddCommGroup_iso],
  rw [comp_apply, comp_apply],
  dsimp only [add_equiv.coe_to_add_monoid_hom, add_equiv.symm, equiv.symm, add_equiv.to_equiv_mk,
    add_equiv.coe_mk],
  erw [preadditive_yoneda_obj_map_apply, preadditive_yoneda_obj_map_apply],
  simp only [← category.assoc, quiver.hom.unop_op, ← category_theory.functor.map_comp],
end

--attribute [simps] shift_iso_aux
lemma shift_iso_conj'
  (n : ℤ)
  [enough_projectives A]
  [homotopy_category.is_bounded_above ((homotopy_category.quotient _ _).obj X)]
  (W₁ W₂ : bounded_homotopy_category A) (f : W₁ ⟶ W₂) :
  (shift_iso n X W₁).inv ≫ ((Ext (n+1)).obj _).map f ≫ (shift_iso n X _).hom =
  ((Ext n).obj _).map f :=
begin
  dsimp only [shift_iso, iso.trans_hom, iso.trans_inv, iso.symm_hom, iso.symm_inv],
  simp only [category.assoc],
  slice_lhs 4 5 { rw Ext_iso_naturality_snd_component },
  simp only [category.assoc, iso.inv_hom_id_assoc, category.id_comp],
  rw ← iso.eq_inv_comp,
  simp_rw ← category.assoc,
  rw iso.comp_inv_eq,
  simp_rw category.assoc,
  rw Ext_iso_naturality_snd_component,
  rw iso.inv_hom_id_assoc,
  ext t,
  dsimp,
  simp only [comp_apply],
  dsimp,
  simp only [add_zero, unit_of_tensor_iso_unit_inv_app, opaque_eq_to_iso_inv,
    discrete.functor_map_id, nat_trans.id_app, category.id_comp, category.assoc,
    nat_trans.naturality, functor.comp_map, μ_hom_inv_app_assoc, functor.map_comp,
    ε_inv_app_obj, discrete.right_unitor_def, eq_to_iso.hom, eq_to_hom_map,
    eq_to_hom_app, μ_naturality_assoc, μ_inv_hom_app_assoc],
  erw ← nat_trans.naturality_assoc,
  erw ← nat_trans.naturality_assoc,
  dsimp, let s := _, change _ ≫ _ ≫ s = _, rw ← category.assoc, convert category.comp_id _,
  dsimp [s], simp,
end

@[reassoc] lemma shift_iso_Ext_map
  (n : ℤ)
  [enough_projectives A]
  (W : bounded_homotopy_category A)
  [homotopy_category.is_bounded_above ((homotopy_category.quotient _ _).obj X)]
  [homotopy_category.is_bounded_above ((homotopy_category.quotient _ _).obj Y)] :
  (((Ext (n+1)).flip.obj W).right_op.map ((of_hom f)⟦(1 : ℤ)⟧')).unop ≫ (shift_iso _ _ _).hom =
  (shift_iso _ _ _).hom ≫ ((Ext n).flip.obj W).map (of_hom f).op :=
by rw [← iso.inv_comp_eq, shift_iso_conj]

@[reassoc] lemma Ext_map_shift_iso_inv
  (n : ℤ)
  [enough_projectives A]
  (W : bounded_homotopy_category A)
  [homotopy_category.is_bounded_above ((homotopy_category.quotient _ _).obj X)]
  [homotopy_category.is_bounded_above ((homotopy_category.quotient _ _).obj Y)] :
  (shift_iso _ _ _).inv ≫ (((Ext (n+1)).flip.obj W).right_op.map ((of_hom f)⟦(1 : ℤ)⟧')).unop =
  ((Ext n).flip.obj W).map (of_hom f).op ≫ (shift_iso _ _ _).inv :=
by rw [iso.eq_comp_inv, category.assoc, shift_iso_conj]

def Ext_δ
  (n : ℤ)
  [enough_projectives A]
  (W : bounded_homotopy_category A)
  [homotopy_category.is_bounded_above ((homotopy_category.quotient _ _).obj X)]
  [homotopy_category.is_bounded_above ((homotopy_category.quotient _ _).obj Y)]
  [homotopy_category.is_bounded_above ((homotopy_category.quotient _ _).obj Z)]
  (w : ∀ i, short_exact (f.f i) (g.f i)) :
  ((Ext n).flip.obj W).obj (opposite.op $ of' X) ⟶
  ((Ext (n+1)).flip.obj W).obj (opposite.op $ of' Z) :=
(shift_iso n X W).inv ≫ (connecting_hom' f g (n+1) W w).unop

.

def map_cone {A₁ A₂ B₁ B₂ : cochain_complex A ℤ}
  [homotopy_category.is_bounded_above ((homotopy_category.quotient _ _).obj A₁)]
  [homotopy_category.is_bounded_above ((homotopy_category.quotient _ _).obj B₁)]
  [homotopy_category.is_bounded_above ((homotopy_category.quotient _ _).obj A₂)]
  [homotopy_category.is_bounded_above ((homotopy_category.quotient _ _).obj B₂)]
  (f₁ : A₁ ⟶ B₁) (f₂ : A₂ ⟶ B₂) (a : A₁ ⟶ A₂) (b : B₁ ⟶ B₂) (sq : f₁ ≫ b = a ≫ f₂) :
  cone f₁ ⟶ cone f₂ :=
(homotopy_category.quotient _ _).map $
{ f := λ i, biprod.lift (biprod.fst ≫ a.f _) (biprod.snd ≫ b.f _),
  comm' := begin
    rintros i j ⟨⟨rfl⟩⟩,
    ext,
    { dsimp [homological_complex.cone.d], simp },
    { dsimp [homological_complex.cone.d], simp,
      simp only [← homological_complex.comp_f, sq] },
    { dsimp [homological_complex.cone.d], simp },
    { dsimp [homological_complex.cone.d], simp },
  end }

.

lemma Ext_δ_natural
  (i : ℤ)
  [enough_projectives A]
  (W : bounded_homotopy_category A)
  {X₁ Y₁ Z₁ : cochain_complex A ℤ} (f₁ : X₁ ⟶ Y₁) (f₂ : Y₁ ⟶ Z₁)
  {X₂ Y₂ Z₂ : cochain_complex A ℤ} (g₁ : X₂ ⟶ Y₂) (g₂ : Y₂ ⟶ Z₂)
  (α₁ : X₁ ⟶ X₂) (α₂ : Y₁ ⟶ Y₂) (α₃ : Z₁ ⟶ Z₂)
  (sq₁ : f₁ ≫ α₂ = α₁ ≫ g₁) (sq₂ : f₂ ≫ α₃ = α₂ ≫ g₂)
  [homotopy_category.is_bounded_above ((homotopy_category.quotient _ _).obj X₁)]
  [homotopy_category.is_bounded_above ((homotopy_category.quotient _ _).obj Y₁)]
  [homotopy_category.is_bounded_above ((homotopy_category.quotient _ _).obj Z₁)]
  [homotopy_category.is_bounded_above ((homotopy_category.quotient _ _).obj X₂)]
  [homotopy_category.is_bounded_above ((homotopy_category.quotient _ _).obj Y₂)]
  [homotopy_category.is_bounded_above ((homotopy_category.quotient _ _).obj Z₂)]
  (w₁ : ∀ i, short_exact (f₁.f i) (f₂.f i))
  (w₂ : ∀ i, short_exact (g₁.f i) (g₂.f i)) :
  ((Ext i).flip.obj W).map (of_hom α₁).op ≫ Ext_δ f₁ f₂ i W w₁ =
    Ext_δ g₁ g₂ i W w₂ ≫ ((Ext (i + 1)).flip.obj W).map (of_hom α₃).op :=
begin
  -- TODO: This proof is SLOW.
  delta Ext_δ,
  let F := homotopy_category.quotient A (complex_shape.up ℤ),
  simp only [category.assoc],
  dsimp only [connecting_hom', unop_comp],
  simp only [unop_inv, category.assoc],
  simp only [← category.assoc, is_iso.comp_inv_eq],
  simp only [category.assoc],
  dsimp only [functor.right_op, quiver.hom.unop_op, functor.flip, opposite.unop_op],
  let t := _, change _ = _ ≫ _ ≫ t,
  have ht : t = ((Ext (i+1)).map (quiver.hom.op _)).app W,
  rotate 2,
  { apply map_cone,
    exact sq₁ },
  { -- Move the inv, and this should be doable.
    dsimp [t], rw is_iso.inv_comp_eq,
    ext f,
    dsimp [Ext, shift_iso, Ext_iso, preadditive_yoneda_obj, linear_map.to_add_monoid_hom],
    simp only [comp_apply], dsimp,
    simp only [← category.assoc],
    congr' 1,
    apply lift_ext (of' Z₂).π, swap, apply_instance,
    simp only [category.assoc, lift_lifts, lift_lifts_assoc],
    congr' 1, dsimp [map_cone, cone.π, homotopy_category.cone.π],
    erw [← F.map_comp, ← F.map_comp], congr' 1,
    dsimp [homological_complex.cone.π],
    ext,
    { simp },
    { simp,
      simp only [← homological_complex.comp_f, sq₂] } },
  rw ht, clear ht, clear t,
  ext f,
  dsimp [Ext, shift_iso, Ext_iso, preadditive_yoneda_obj, linear_map.to_add_monoid_hom],
  dsimp only [shift_iso_aux, add_equiv.symm],
  simp only [comp_apply],
  dsimp,
  simp only [← category.assoc], congr' 1,
  simp only [functor.map_comp, ← category.assoc], congr' 1,
  simp only [category.assoc],
  apply lift_ext (((of' X₂).π)⟦(1 : ℤ)⟧'),
  swap, apply_instance,
  simp only [category.assoc, ← functor.map_comp, lift_lifts],
  simp only [functor.map_comp, lift_lifts_assoc, lift_lifts, category.assoc],
  congr' 1,
  dsimp [cone_triangle, map_cone],
  simp only [comp_neg, neg_comp], congr' 1,
  erw [← F.map_comp, ← F.map_comp], congr' 1,
  dsimp [homological_complex.cone.out],
  ext,
  { simp, },
  { simp, }
end

.

lemma Ext_δ_natural'
  (i : ℤ)
  [enough_projectives A]
  (W₁ W₂ : bounded_homotopy_category A)
  (e : W₁ ⟶ W₂)
  {X Y Z : cochain_complex A ℤ} (f : X ⟶ Y) (g : Y ⟶ Z)
  [homotopy_category.is_bounded_above ((homotopy_category.quotient _ _).obj X)]
  [homotopy_category.is_bounded_above ((homotopy_category.quotient _ _).obj Y)]
  [homotopy_category.is_bounded_above ((homotopy_category.quotient _ _).obj Z)]
  (w : ∀ i, short_exact (f.f i) (g.f i)) :
  ((Ext i).obj _).map e ≫ Ext_δ f g i W₂ w =
  Ext_δ f g i W₁ w ≫ ((Ext (i+1)).obj _).map e :=
begin
  delta Ext_δ,
  dsimp [connecting_hom'],
  simp only [quiver.hom.unop_op, unop_inv],
  simp_rw ← category.assoc,
  rw is_iso.comp_inv_eq,
  simp_rw category.assoc,
  let t := _, change _ = _ ≫ _ ≫ t,
  have ht : t = ((Ext (i + 1)).obj _).map e,
  { dsimp only [t],
    rw [is_iso.inv_comp_eq, nat_trans.naturality] },
  rw ht, clear ht t,
  rw iso.eq_inv_comp,
  rw ← nat_trans.naturality,
  simp only [← category.assoc],
  congr' 1,
  rw [iso.comp_inv_eq, ← shift_iso_conj', iso.hom_inv_id_assoc],
end

lemma Ext_five_term_exact_seq'
  (n : ℤ)
  [enough_projectives A]
  (W : bounded_homotopy_category A)
  [homotopy_category.is_bounded_above ((homotopy_category.quotient _ _).obj X)]
  [homotopy_category.is_bounded_above ((homotopy_category.quotient _ _).obj Y)]
  [homotopy_category.is_bounded_above ((homotopy_category.quotient _ _).obj Z)]
  (w : ∀ i, short_exact (f.f i) (g.f i)) :
  let E := λ n, ((Ext n).flip.obj W) in
  exact_seq Ab.{v} $
    [ (E n).map (of_hom g).op
    , (E n).map (of_hom f).op
    , Ext_δ f g n W w
    , (E (n+1)).map (of_hom g).op ] :=
begin
  refine (Ext_five_term_exact_seq f g n W w).pair.unop.cons _,
  refine exact.cons _ (exact.exact_seq _),
  { rw [Ext_δ, functor.right_op_map, quiver.hom.unop_op, ← shift_iso_conj f n W,
      exact_iso_comp, exact_comp_hom_inv_comp_iff],
    have := (Ext_five_term_exact_seq f g (n+1) W w).unop.pair,
    erw [functor.map_neg, category_theory.unop_neg, abelian.exact_neg_left_iff] at this,
    exact this },
  { rw [Ext_δ, exact_iso_comp],
    exact ((Ext_five_term_exact_seq f g (n+1) W w).drop 1).pair.unop, }
end

end bounded_homotopy_category

namespace bounded_derived_category

variables [enough_projectives A]
variables {X Y Z : bounded_derived_category A} (f : X ⟶ Y) (g : Y ⟶ Z)
open homological_complex

def cone (f : X ⟶ Y) : bounded_derived_category A :=
(localization_functor _).obj $
{ val := homotopy_category.cone f.val.out,
  bdd := begin
    obtain ⟨a,ha⟩ := homotopy_category.is_bounded_above.cond X.val.val,
    obtain ⟨b,hb⟩ := homotopy_category.is_bounded_above.cond Y.val.val,
    constructor, use (max a b + 1),
    intros t ht,
    apply is_zero_biprod,
    { apply ha, refine le_trans (le_trans _ ht) _,
      refine le_trans (le_max_left a b) _,
      all_goals { linarith } },
    { apply hb,
      refine le_trans _ ht, refine le_trans (le_max_right a b) _,
      linarith }
  end }

-- UGH
end bounded_derived_category

-- move me
instance single_is_bounded_above (X : A) :
  homotopy_category.is_bounded_above {as := (homological_complex.single A (complex_shape.up ℤ) 0).obj X} :=
begin
  refine ⟨⟨1, _⟩⟩,
  intros i hi,
  dsimp,
  rw if_neg,
  { exact is_zero_zero _ },
  { rintro rfl, exact zero_lt_one.not_le hi }
end

-- move me
instance quotient_single_is_bounded_above (X : A) :
  ((homotopy_category.quotient A (complex_shape.up ℤ)).obj
    ((homological_complex.single A (complex_shape.up ℤ) 0).obj X)).is_bounded_above :=
single_is_bounded_above X

def Ext'_δ [enough_projectives A]
  {X Y Z : A} (W : A) {f : X ⟶ Y} {g : Y ⟶ Z}
  (h : short_exact f g) (n : ℤ) :
  ((Ext' n).flip.obj W).obj (opposite.op $ X) ⟶
  ((Ext' (n+1)).flip.obj W).obj (opposite.op $ Z) :=
begin
  refine @bounded_homotopy_category.Ext_δ _ _ _ _ _ _
    ((homological_complex.single _ _ _).map f)
    ((homological_complex.single _ _ _).map g)
    n _ _
    (quotient_single_is_bounded_above _)
    (quotient_single_is_bounded_above _)
    (quotient_single_is_bounded_above _) _,
  intro i, dsimp, by_cases hi : i = 0,
  { subst i, dsimp, simp only [eq_self_iff_true, category.comp_id, category.id_comp, if_true, h] },
  { rw [dif_neg hi, dif_neg hi, if_neg hi, if_neg hi, if_neg hi],
    refine ⟨exact_of_zero _ _⟩, }
end

lemma Ext'_δ_natural [enough_projectives A]
  {X₁ X₂ X₃ Y₁ Y₂ Y₃ : A}
  (f₁ : X₁ ⟶ X₂) (f₂ : X₂ ⟶ X₃)
  (g₁ : Y₁ ⟶ Y₂) (g₂ : Y₂ ⟶ Y₃)
  (α₁ : X₁ ⟶ Y₁) (α₂ : X₂ ⟶ Y₂) (α₃ : X₃ ⟶ Y₃)
  (sq₁ : f₁ ≫ α₂ = α₁ ≫ g₁) (sq₂ : f₂ ≫ α₃ = α₂ ≫ g₂)
  (Z : A) (hf : short_exact f₁ f₂) (hg : short_exact g₁ g₂) (i : ℤ) :
  ((Ext' i).flip.obj Z).map α₁.op ≫ Ext'_δ Z hf i =
    Ext'_δ Z hg i ≫ ((Ext' (i+1)).flip.obj Z).map α₃.op :=
begin
  delta Ext' Ext'_δ,
  apply bounded_homotopy_category.Ext_δ_natural _ _ _ _ _ _ _
    ((homological_complex.single A (complex_shape.up ℤ) 0).map α₂),
  all_goals { simp only [← category_theory.functor.map_comp, sq₁, sq₂, quiver.hom.unop_op] },
end

namespace category_theory
namespace short_exact

lemma Ext'_five_term_exact_seq [enough_projectives A]
  {X Y Z : A} (W : A) {f : X ⟶ Y} {g : Y ⟶ Z}
  (h : short_exact f g) (n : ℤ) :
  let E := λ n, ((Ext' n).flip.obj W) in
  exact_seq Ab.{v} $
    [ (E n).map g.op
    , (E n).map f.op
    , Ext'_δ W h n
    , (E (n+1)).map g.op ] :=
begin
  let f' := (homological_complex.single _ (complex_shape.up ℤ) (0:ℤ)).map f,
  let g' := (homological_complex.single _ (complex_shape.up ℤ) (0:ℤ)).map g,
  let W' := (bounded_homotopy_category.single _ 0).obj W,
  have Hfg : ∀ (i : ℤ), short_exact (f'.f i) (g'.f i),
  { intro i, dsimp, by_cases hi : i = 0,
    { subst i, dsimp, simp only [eq_self_iff_true, category.comp_id, category.id_comp, if_true, h] },
    { rw [dif_neg hi, dif_neg hi, if_neg hi, if_neg hi, if_neg hi],
      refine ⟨exact_of_zero _ _⟩, } },
  convert bounded_homotopy_category.Ext_five_term_exact_seq' f' g' n W' Hfg,
end

end short_exact
end category_theory


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.list.basic
import Mathlib.data.fin
import Mathlib.PostPort

universes u u_1

namespace Mathlib

namespace list

/- of_fn -/

theorem length_of_fn_aux {α : Type u} {n : ℕ} (f : fin n → α) (m : ℕ) (h : m ≤ n) (l : List α) :
    length (of_fn_aux f m h l) = length l + m :=
  sorry

@[simp] theorem length_of_fn {α : Type u} {n : ℕ} (f : fin n → α) : length (of_fn f) = n :=
  Eq.trans (length_of_fn_aux f n of_fn._proof_1 []) (zero_add n)

theorem nth_of_fn_aux {α : Type u} {n : ℕ} (f : fin n → α) (i : ℕ) (m : ℕ) (h : m ≤ n)
    (l : List α) :
    (∀ (i : ℕ), nth l i = of_fn_nth_val f (i + m)) →
        nth (of_fn_aux f m h l) i = of_fn_nth_val f i :=
  sorry

@[simp] theorem nth_of_fn {α : Type u} {n : ℕ} (f : fin n → α) (i : ℕ) :
    nth (of_fn f) i = of_fn_nth_val f i :=
  sorry

theorem nth_le_of_fn {α : Type u} {n : ℕ} (f : fin n → α) (i : fin n) :
    nth_le (of_fn f) (↑i) (Eq.symm (length_of_fn f) ▸ subtype.property i) = f i :=
  sorry

@[simp] theorem nth_le_of_fn' {α : Type u} {n : ℕ} (f : fin n → α) {i : ℕ}
    (h : i < length (of_fn f)) :
    nth_le (of_fn f) i h = f { val := i, property := length_of_fn f ▸ h } :=
  nth_le_of_fn f { val := i, property := length_of_fn f ▸ h }

@[simp] theorem map_of_fn {α : Type u} {β : Type u_1} {n : ℕ} (f : fin n → α) (g : α → β) :
    map g (of_fn f) = of_fn (g ∘ f) :=
  sorry

theorem array_eq_of_fn {α : Type u} {n : ℕ} (a : array n α) :
    array.to_list a = of_fn (array.read a) :=
  sorry

@[simp] theorem of_fn_zero {α : Type u} (f : fin 0 → α) : of_fn f = [] := rfl

@[simp] theorem of_fn_succ {α : Type u} {n : ℕ} (f : fin (Nat.succ n) → α) :
    of_fn f = f 0 :: of_fn fun (i : fin n) => f (fin.succ i) :=
  sorry

theorem of_fn_nth_le {α : Type u} (l : List α) :
    (of_fn fun (i : fin (length l)) => nth_le l (↑i) (subtype.property i)) = l :=
  sorry

-- not registered as a simp lemma, as otherwise it fires before `forall_mem_of_fn_iff` which

-- is much more useful

theorem mem_of_fn {α : Type u} {n : ℕ} (f : fin n → α) (a : α) : a ∈ of_fn f ↔ a ∈ set.range f :=
  sorry

@[simp] theorem forall_mem_of_fn_iff {α : Type u} {n : ℕ} {f : fin n → α} {P : α → Prop} :
    (∀ (i : α), i ∈ of_fn f → P i) ↔ ∀ (j : fin n), P (f j) :=
  sorry

@[simp] theorem of_fn_const {α : Type u} (n : ℕ) (c : α) :
    (of_fn fun (i : fin n) => c) = repeat c n :=
  sorry

end Mathlib


infix:50 " ≅ "  => HEq
theorem ex1 {α : Sort u} {a b : α} (h : a ≅ b) : a = b :=
  match h with
  | HEq.refl _ => rfl

theorem ex2 {α : Sort u2} {a : α} {motive : {β : Sort u2} → β → Sort u1} (m : motive a) {β : Sort u2} {b : β} (h : a ≅ b) : motive b :=
  match h, m with
  | HEq.refl _, m => m

theorem ex3 {α : Sort u} {a : α} {p : α → Sort v} {b : α} (h₁ : a ≅ b) (h₂ : p a) : p b :=
  match h₁, h₂ with
  | HEq.refl _, h₂ => h₂

theorem ex4 {α β : Sort u} {a : α} {b : β} (h : a ≅ b) : b ≅ a :=
  match h with
  | HEq.refl _ => HEq.refl _

theorem ex5 {α : Sort u} {a a' : α} (h : a = a') : a ≅ a' :=
  match h with
  | rfl => HEq.refl _

theorem ex6 {α β : Sort u} (h : α = β) (a : α) : cast h a ≅ a :=
  match h with
  | rfl => HEq.refl _

theorem ex7 {α β σ : Sort u} {a : α} {b : β} {c : σ} (h₁ : a ≅ b) (h₂ : b ≅ c) : a ≅ c :=
  match h₁, h₂ with
  | HEq.refl _, HEq.refl _ => HEq.refl _


import GroundZero.Structures
open GroundZero.Types.Equiv
open GroundZero.Structures
open GroundZero.Types

/-
  Univalence axiom formulated using equivalence J-rule.

  ua, idtoeqv, compRule, propUniq
  * HoTT 2.10

  Full univalence: (A ≃ B) ≃ (A = B).

  Proof that Type is not a set.
  * HoTT 3.1, example 3.1.9
-/

namespace GroundZero

universe u v u' v'

axiom J {C : Π (A B : Type u), A ≃ B → Type v}
  (h : Π (A : Type u), C A A (ideqv A))
  {A B : Type u} (e : A ≃ B) : C A B e

attribute [eliminator] J

axiom Jβrule {C : Π (A B : Type u), A ≃ B → Type v}
  {h : Π (A : Type u), C A A (ideqv A)} {A : Type u} :
  J h (ideqv A) = h A

noncomputable hott def Jrule (C : Π (A B : Type u), A ≃ B → Type v)
  (h : Π (A : Type u), C A A (ideqv A)) {A B : Type u} (e : A ≃ B) : C A B e :=
J h e

noncomputable hott def ua {A B : Type u} : A ≃ B → A = B :=
Jrule (λ A B _, A = B) idp

namespace ua

noncomputable hott def reflOnUa (A : Type u) : ua (ideqv A) = idp A :=
by apply Jβrule

noncomputable hott def transportRule {A B : Type u} (e : A ≃ B) (x : A) :
  transportconst (ua e) x = e x :=
begin
  induction e; transitivity;
  apply Id.map (transport id · x);
  apply reflOnUa; reflexivity
end

noncomputable hott def transportInvRule {A B : Type u} (e : A ≃ B) (x : B) :
  transportconst (ua e)⁻¹ x = e.left x :=
begin
  induction e; transitivity;
  apply Id.map (transport id ·⁻¹ x);
  apply reflOnUa; reflexivity
end

noncomputable hott def compRule {A B : Type u} (e : A ≃ B) (x : A) : x =[id, ua e] e x :=
transportRule e x

hott def idtoeqvAndId {A : Type u} : idtoeqv (idp A) = ideqv A :=
by reflexivity

noncomputable hott def uaβrule {A B : Type u} (e : A ≃ B) : idtoeqv (ua e) = e :=
begin induction e; change _ = idtoeqv (idp _); apply Id.map; apply reflOnUa end

noncomputable hott def propUniq {A B : Type u} (p : A = B) : ua (idtoeqv p) = p :=
begin induction p; exact Jβrule end

noncomputable hott def univalence (A B : Type u) : (A ≃ B) ≃ (A = B) :=
⟨ua, (⟨idtoeqv, uaβrule⟩, ⟨idtoeqv, propUniq⟩)⟩

noncomputable hott def propext {A B : Type u}
  (F : prop A) (G : prop B) : (A ↔ B) → A = B :=
λ h, ua (propEquivLemma F G h.left h.right)

noncomputable hott def uaTrans {A B γ : Type u} (p : A ≃ B) (q : B ≃ γ) :
  ua (Equiv.trans p q) = ua p ⬝ ua q :=
begin
  induction p; induction q; change ua (ideqv _) = _; symmetry;
  change _ = idp _ ⬝ _; apply Id.map (· ⬝ ua _); apply reflOnUa
end

hott def isZero : ℕ → 𝟐
| Nat.zero   => true
| Nat.succ _ => false

example (h : 0 = 1) : 𝟎 :=
ffNeqTt (Id.map isZero h)⁻¹

hott def succNeqZero {n : ℕ} : ¬(Nat.succ n = 0) :=
λ h, ffNeqTt (Id.map isZero h)

hott def negNeg : Π x, not (not x) = x
| true  => idp true
| false => idp false

hott def negBoolEquiv : 𝟐 ≃ 𝟐 :=
⟨not, (⟨not, negNeg⟩, ⟨not, negNeg⟩)⟩

noncomputable hott def universeNotASet : ¬(hset Type) :=
begin
  let p : 𝟐 = 𝟐 := ua negBoolEquiv; let h := transportconst p true;
  let g : h = false := transportRule negBoolEquiv true;
  intro ε; let f : h = true := Id.map (transportconst · true) (ε _ _ p (idp 𝟐));
  apply ffNeqTt; exact g⁻¹ ⬝ f
end

noncomputable hott def coproductSet {A B : Type}
  (f : hset A) (g : hset B) : hset (A + B)
| Coproduct.inl x, Coproduct.inl y =>
  transport prop (ua (@Coproduct.inl.inj' A B x y))⁻¹ (f _ _)
| Coproduct.inl x, Coproduct.inr y =>
  transport prop (ua (@Coproduct.inl.inlInr A B x y))⁻¹ emptyIsProp
| Coproduct.inr x, Coproduct.inl y =>
  transport prop (ua (@Coproduct.inr.inrInl A B x y))⁻¹ emptyIsProp
| Coproduct.inr x, Coproduct.inr y =>
  transport prop (ua (@Coproduct.inr.inj' A B x y))⁻¹ (g _ _)

-- exercise 2.17 (i) in HoTT book
noncomputable hott def productEquiv₁ {A A' B B' : Type u}
  (e₁ : A ≃ A') (e₂ : B ≃ B') : (A × B) ≃ (A' × B') :=
begin
  have p := ua e₁; have q := ua e₂;
  induction p; induction q; apply ideqv
end

noncomputable hott def productEquiv₂ {A A' B B' : Type u}
  (e₁ : A ≃ A') (e₂ : B ≃ B') : (A × B) ≃ (A' × B') :=
begin induction e₁; induction e₂; reflexivity end

section
  open GroundZero.Types.Product
  variable {A : Type u} {A' : Type v} {B : Type u'} {B' : Type v'}

  hott def productEquiv₃ (e₁ : A ≃ A') (e₂ : B ≃ B') : (A × B) ≃ (A' × B') :=
  prodEquiv e₁ e₂
end

section
  variable {C : 𝟐 → Type u}

  hott def familyOnBool.sec (w : C false × C true) : Π b, C b
  | false => w.1
  | true  => w.2

  hott def familyOnBool.ret (φ : Π b, C b) : C false × C true :=
  (φ false, φ true)

  hott def familyOnBool : (C false × C true) ≃ Π b, C b :=
  begin
    existsi familyOnBool.sec; apply Qinv.toBiinv;
    existsi familyOnBool.ret; apply Prod.mk;
    { intro φ; apply HITs.Interval.funext; intro b;
      induction b using Bool.casesOn <;> reflexivity };
    { intro w; reflexivity }
  end
end

end ua
end GroundZero


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

import category_theory.preadditive.default

/-!
# Preadditive structure on functor categories

If `C` and `D` are categories and `D` is preadditive,
then `C ⥤ D` is also preadditive.

-/

open_locale big_operators

namespace category_theory
open category_theory.limits preadditive

variables {C D : Type*} [category C] [category D] [preadditive D]

instance functor_category_preadditive : preadditive (C ⥤ D) :=
{ hom_group := λ F G,
  { add := λ α β,
    { app := λ X, α.app X + β.app X,
      naturality' := by { intros, rw [comp_add, add_comp, α.naturality, β.naturality] } },
    zero := { app := λ X, 0, naturality' := by { intros, rw [zero_comp, comp_zero] } },
    neg := λ α,
    { app := λ X, -α.app X,
      naturality' := by { intros, rw [comp_neg, neg_comp, α.naturality] } },
    sub := λ α β,
    { app := λ X, α.app X - β.app X,
      naturality' := by { intros, rw [comp_sub, sub_comp, α.naturality, β.naturality] } },
    add_assoc := by { intros, ext, apply add_assoc },
    zero_add := by { intros, ext, apply zero_add },
    add_zero := by { intros, ext, apply add_zero },
    sub_eq_add_neg := by { intros, ext, apply sub_eq_add_neg },
    add_left_neg := by { intros, ext, apply add_left_neg },
    add_comm := by { intros, ext, apply add_comm } },
  add_comp' := by { intros, ext, apply add_comp },
  comp_add' := by { intros, ext, apply comp_add } }

namespace nat_trans

variables {F G : C ⥤ D}

/-- Application of a natural transformation at a fixed object,
as group homomorphism -/
@[simps] def app_hom (X : C) : (F ⟶ G) →+ (F.obj X ⟶ G.obj X) :=
{ to_fun := λ α, α.app X,
  map_zero' := rfl,
  map_add' := λ _ _, rfl }

@[simp] lemma app_zero (X : C) : (0 : F ⟶ G).app X = 0 := rfl

@[simp] lemma app_add (X : C) (α β : F ⟶ G) : (α + β).app X = α.app X + β.app X := rfl

@[simp] lemma app_sub (X : C) (α β : F ⟶ G) : (α - β).app X = α.app X - β.app X := rfl

@[simp] lemma app_neg (X : C) (α : F ⟶ G) : (-α).app X = -α.app X := rfl

@[simp] lemma app_nsmul (X : C) (α : F ⟶ G) (n : ℕ) : (n • α).app X = n • α.app X :=
(app_hom X).map_nsmul α n

@[simp] lemma app_zsmul (X : C) (α : F ⟶ G) (n : ℤ) : (n • α).app X = n • α.app X :=
(app_hom X : (F ⟶ G) →+ (F.obj X ⟶ G.obj X)).map_zsmul α n

@[simp] lemma app_sum {ι : Type*} (s : finset ι) (X : C) (α : ι → (F ⟶ G)) :
  (∑ i in s, α i).app X = ∑ i in s, ((α i).app X) :=
by { rw [← app_hom_apply, add_monoid_hom.map_sum], refl }

end nat_trans

end category_theory


/-
Copyright (c) 2020 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau, Devon Tuma
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.group_theory.submonoid.operations
import Mathlib.group_theory.submonoid.membership
import Mathlib.PostPort

universes u_1 u_2

namespace Mathlib

/-!
# Non-zero divisors

In this file we define the submonoid `non_zero_divisors` of a `monoid_with_zero`.
-/

/-- The submonoid of non-zero-divisors of a `monoid_with_zero` `R`. -/
def non_zero_divisors (R : Type u_1) [monoid_with_zero R] : submonoid R :=
  submonoid.mk (set_of fun (x : R) => ∀ (z : R), z * x = 0 → z = 0) sorry sorry

theorem mul_mem_non_zero_divisors {R : Type u_1} [comm_ring R] {a : R} {b : R} : a * b ∈ non_zero_divisors R ↔ a ∈ non_zero_divisors R ∧ b ∈ non_zero_divisors R := sorry

theorem eq_zero_of_ne_zero_of_mul_right_eq_zero {A : Type u_2} [integral_domain A] {x : A} {y : A} (hnx : x ≠ 0) (hxy : y * x = 0) : y = 0 :=
  or.resolve_right (eq_zero_or_eq_zero_of_mul_eq_zero hxy) hnx

theorem eq_zero_of_ne_zero_of_mul_left_eq_zero {A : Type u_2} [integral_domain A] {x : A} {y : A} (hnx : x ≠ 0) (hxy : x * y = 0) : y = 0 :=
  or.resolve_left (eq_zero_or_eq_zero_of_mul_eq_zero hxy) hnx

theorem mem_non_zero_divisors_iff_ne_zero {A : Type u_2} [integral_domain A] {x : A} : x ∈ non_zero_divisors A ↔ x ≠ 0 := sorry

theorem map_ne_zero_of_mem_non_zero_divisors {R : Type u_1} [comm_ring R] [nontrivial R] {B : Type u_2} [ring B] {g : R →+* B} (hg : function.injective ⇑g) {x : ↥(non_zero_divisors R)} : coe_fn g ↑x ≠ 0 :=
  fun (h0 : coe_fn g ↑x = 0) =>
    one_ne_zero (subtype.property x 1 (Eq.symm (one_mul (subtype.val x)) ▸ hg (trans h0 (Eq.symm (ring_hom.map_zero g)))))

theorem map_mem_non_zero_divisors {A : Type u_2} [integral_domain A] {B : Type u_1} [integral_domain B] {g : A →+* B} (hg : function.injective ⇑g) {x : ↥(non_zero_divisors A)} : coe_fn g ↑x ∈ non_zero_divisors B :=
  fun (z : B) (hz : z * coe_fn g ↑x = 0) =>
    eq_zero_of_ne_zero_of_mul_right_eq_zero (map_ne_zero_of_mem_non_zero_divisors hg) hz

theorem le_non_zero_divisors_of_domain {A : Type u_2} [integral_domain A] {M : submonoid A} (hM : ¬↑0 ∈ M) : M ≤ non_zero_divisors A :=
  fun (x : A) (hx : x ∈ M) (y : A) (hy : y * x = 0) =>
    or.rec_on (eq_zero_or_eq_zero_of_mul_eq_zero hy) (fun (h : y = 0) => h) fun (h : x = 0) => absurd (h ▸ hx) hM

theorem powers_le_non_zero_divisors_of_domain {A : Type u_2} [integral_domain A] {a : A} (ha : a ≠ 0) : submonoid.powers a ≤ non_zero_divisors A :=
  le_non_zero_divisors_of_domain
    fun (h : ↑0 ∈ submonoid.powers a) => absurd (Exists.rec_on h fun (_x : ℕ) (hn : a ^ _x = ↑0) => pow_eq_zero hn) ha

theorem map_le_non_zero_divisors_of_injective {A : Type u_2} [integral_domain A] {B : Type u_1} [integral_domain B] {f : A →+* B} (hf : function.injective ⇑f) {M : submonoid A} (hM : M ≤ non_zero_divisors A) : submonoid.map (↑f) M ≤ non_zero_divisors B := sorry